!AColorSelectorMorph commentStamp: 'gvc 5/18/2007 13:52'! ColorComponentSelector showing an alpha gradient over a hatched background.! !AColorSelectorMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 11:54'! initialize "Initialize the receiver." super initialize. self value: 1.0; color: Color black! ! !AColorSelectorMorph methodsFor: 'visual properties' stamp: 'gvc 9/19/2006 15:46'! fillStyle: fillStyle "If it is a color then override with gradient." fillStyle isColor ifTrue: [self color: fillStyle] ifFalse: [super fillStyle: fillStyle]! ! !AColorSelectorMorph methodsFor: 'drawing' stamp: 'gvc 9/19/2006 14:28'! drawOn: aCanvas "Draw a hatch pattern first." aCanvas fillRectangle: self innerBounds fillStyle: (InfiniteForm with: self hatchForm). super drawOn: aCanvas ! ! !AColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/3/2009 13:43'! color: aColor "Set the gradient colors." super color: aColor asNontranslucentColor. self fillStyle: self defaultFillStyle! ! !AColorSelectorMorph methodsFor: 'private' stamp: 'gvc 9/22/2006 09:17'! hatchForm "Answer a form showing a grid hatch pattern." ^ColorPresenterMorph hatchForm! ! !AColorSelectorMorph methodsFor: 'protocol' stamp: 'gvc 9/3/2009 13:43'! defaultFillStyle "Answer the hue gradient." ^(GradientFillStyle colors: {self color alpha: 0. self color}) origin: self topLeft; direction: (self bounds isWide ifTrue: [self width@0] ifFalse: [0@self height])! ! !AGroupHasBeenAdded commentStamp: 'TorstenBergmann 2/4/2014 21:09'! Notify that a group has been added! !AGroupHasBeenAdded class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 16:32'! group: aGroup into: anHolder ^ self group: aGroup from: anHolder! ! !AGroupHasBeenCreated commentStamp: 'TorstenBergmann 2/4/2014 21:09'! Notify that a group has been created! !AGroupHasBeenRegistered commentStamp: 'TorstenBergmann 2/4/2014 21:09'! Notify that a group has been registered! !AGroupHasBeenRegistered class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 13:40'! with: aGroup ^ self new group: aGroup! ! !AGroupHasBeenRemoved commentStamp: 'TorstenBergmann 2/4/2014 21:10'! Notify that a group has been removed! !AGroupHasBeenRenamed commentStamp: 'TorstenBergmann 2/4/2014 21:10'! Notify that a group has been renamed! !AGroupHasBeenUnregistered commentStamp: 'TorstenBergmann 2/4/2014 21:10'! Notify that a group has been unregistered! !AGroupHasBeenUnregistered class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 13:40'! with: aGroup ^ self new group: aGroup! ! !AIBlockContext commentStamp: ''! I am a specific context for the ASTInterpreter that represents BlockContext in Pharo. I have one aditional role with is to manage myself the exception handling and I do not delegate it to the context of the BlockClosure>>on:do: method Instance Variables exceptionHandler: homeContext: exceptionHandler - is nil if there are no exception handler is an ExceptionHandler which represents an ExceptionClass, a handlerBlock and the isActive boolean. It represents in Pharo the temporaries of the BlockClosure>>on:do: method homeContext - is the homeContext of the BlockClosure ! !AIBlockContext methodsFor: 'accessing' stamp: 'ClementBera 12/7/2012 10:40'! returnContext ^ self homeContext returnContext! ! !AIBlockContext methodsFor: 'debugging' stamp: 'ClementBera 3/6/2013 16:07'! debugPrintString ^'Block in : ', self methodClass name, '>>#', (self method ifNotNil: [:mth | mth selector] ifNil: [#unknownSelector]), String lf, self code formattedCode printString! ! !AIBlockContext methodsFor: 'testing' stamp: 'ClementBera 10/18/2012 16:44'! = anAIBlockContext (super = anAIBlockContext) ifFalse: [^false]. (self homeContext = anAIBlockContext homeContext) ifFalse: [^false]. (self exceptionHandler = anAIBlockContext exceptionHandler) ifFalse: [^false]. ^true! ! !AIBlockContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 20:52'! exceptionHandler: anExceptionHandler exceptionHandler := anExceptionHandler! ! !AIBlockContext methodsFor: 'printing' stamp: 'ClementBera 12/7/2012 10:58'! printOn: aStream aStream nextPutAll: 'AIBlockCtxt: '. aStream nextPutAll: self code formattedCode! ! !AIBlockContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 14:57'! homeContext: aContext homeContext := aContext! ! !AIBlockContext methodsFor: 'accessing' stamp: 'CamilloBruni 3/6/2013 11:32'! method ^ self homeContext method! ! !AIBlockContext methodsFor: 'testing' stamp: 'CamilloBruni 12/12/2011 14:19'! hasExceptionHandler ^ exceptionHandler isNil not! ! !AIBlockContext methodsFor: 'accessing' stamp: 'CamilloBruni 3/6/2013 12:39'! methodClass ^ self homeContext methodClass! ! !AIBlockContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 14:57'! homeContext ^ homeContext! ! !AIBlockContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 20:52'! exceptionHandler ^ exceptionHandler! ! !AIBlockContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 15:05'! receiver ^ self homeContext receiver! ! !AIBlockContext class methodsFor: 'instance creation' stamp: 'ClementBera 7/26/2013 16:11'! fromVMContext: aBlockContext |sender| sender := aBlockContext sender. ^ self new initializeContext: aBlockContext; homeContext: aBlockContext home asASTInterpreterContext ; closure: aBlockContext closure asASTBlockClosure; exceptionHandler: (sender ifNotNil: [ sender isHandlerContext ifTrue: [ (ExceptionHandler on: (sender tempAt: 1) do: (sender tempAt: 2)) enabled: (sender tempAt: 1)] ]) ; yourself! ! !AIContext commentStamp: ''! I am an abstract specific context for the ASTInterpreter that represents ContextPart in Pharo. Instance Variables arguments: closure: isExecuted: outerContext: temporaries: arguments - is the collection of the arguments of the method closure - is either a CompiledMethod or an ASTBlockClosure, depending if I am an AIBlockClosure or an AIMethodContext isExecuted - permits to know if my method has already been executed. In Pharo, when I am terminated my pc is set to nil. Then, you can know if I am terminated by checking if my pc is nil. In the ASTInterpreter we don't have pc so we use isExecuted boolean to know if the context is terminated. (isExecuted make the test ASTInterpreterTest>>testNonLocalReturnPart2 pass with the returningBlock) outerContext - is my sender temporaries - is the collection of the arguments + the temporaries of the method ! !AIContext methodsFor: 'initialize-release' stamp: 'ClementBera 10/18/2012 13:37'! initializeContext: aContext self outerContext: aContext outerContext asASTInterpreterContext. self arguments: aContext arguments. aContext tempNames do: [:tempName | self temporaries at: tempName put: (aContext tempNamed: tempName)]! ! !AIContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 17:33'! closure: anObject closure := anObject! ! !AIContext methodsFor: 'compatibility layer' stamp: 'ClementBera 3/4/2013 15:53'! selector "Answer the selector of the method that created the receiver." ^self code selector ifNil: [self code defaultSelector].! ! !AIContext methodsFor: 'compatibility layer' stamp: 'CamilloBruni 12/8/2011 14:45'! contextTag ^ self! ! !AIContext methodsFor: 'exception-handling' stamp: 'ClementBEra 3/6/2013 17:54'! cannotReturn: result closure notNil ifTrue: [^self cannotReturn: result to: self home sender]. Smalltalk tools debugger openContext: thisContext label: 'computation has been terminated' contents: nil! ! !AIContext methodsFor: 'accessing' stamp: 'ClementBera 3/18/2013 14:16'! currentExecutedNode ^ currentExecutedNode! ! !AIContext methodsFor: 'exception-handling' stamp: 'CamilloBruni 12/9/2011 16:27'! nextHandlerContext ^ self outerContext findNextHandlerContextStarting! ! !AIContext methodsFor: 'accessing' stamp: 'ClementBera 3/4/2013 10:59'! tempNamed: aName put: aValue self flag: 'the error signal doesnt work inside the interpreter '. (self temporaries includesKey: aName) ifTrue: [ ^ self temporaries at: aName put: aValue ]. self homeContext ifNil: [ (VariableNotDefined signalForVariable: aName context: self) == true ifTrue: [ ^ self tempNamed: aName put: aValue]]. ^ self homeContext tempNamed: aName put: aValue ! ! !AIContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 19:36'! methodClass ^ closure methodClass! ! !AIContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 17:33'! closure ^ closure! ! !AIContext methodsFor: 'testing' stamp: 'ClementBera 1/14/2013 16:40'! isRootContext ^false! ! !AIContext methodsFor: 'initialization' stamp: 'ClementBera 10/22/2012 20:39'! initialize self flag: 'for now the easies solution'.! ! !AIContext methodsFor: 'compatibility layer' stamp: 'CamilloBruni 3/6/2013 12:46'! home ^ self homeContext! ! !AIContext methodsFor: 'exception-handling' stamp: 'CamilloBruni 12/12/2011 14:42'! cannotReturn: result to: homeContext "The receiver tried to return result to homeContext that no longer exists." ^ BlockCannotReturn new result: result; deadHome: homeContext; signal! ! !AIContext methodsFor: 'exception-handling' stamp: 'CamilloBruni 12/9/2011 16:31'! findContextSuchThat: testBlock "Search self and my sender chain for first one that satisfies testBlock. Return nil if none satisfy" | ctxt | ctxt := self. [ctxt isNil] whileFalse: [ (testBlock value: ctxt) ifTrue: [^ ctxt]. ctxt := ctxt outerContext ]. ^ nil! ! !AIContext methodsFor: 'accessing' stamp: 'ClementBera 3/18/2013 14:16'! currentExecutedNode: anObject currentExecutedNode := anObject! ! !AIContext methodsFor: 'continuation' stamp: 'ClementBera 3/18/2013 16:37'! die currentExecutedNode := nil! ! !AIContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 17:33'! outerContext ^ outerContext! ! !AIContext methodsFor: 'accessing' stamp: 'ClementBera 1/14/2013 16:43'! createTemp: aName self temporaries at: aName put: nil.! ! !AIContext methodsFor: 'printing' stamp: 'ClementBera 12/7/2012 10:57'! printOn: aStream aStream nextPutAll: 'AIContext: should be instantiated'! ! !AIContext methodsFor: 'continuation' stamp: 'CamilloBruni 12/12/2011 16:07'! resume: value "Unwind thisContext to self and resume with value as result of last send. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: value to: self]. " ctxt := thisContext. [ ctxt := ctxt findNextUnwindContextUpTo: self. ctxt isNil ] whileFalse: [ (ctxt tempAt: 2) ifNil:[ ctxt tempAt: 2 put: true. unwindBlock := ctxt tempAt: 1. thisContext terminateTo: ctxt. unwindBlock value]. ]." thisContext terminateTo: self value: value. ! ! !AIContext methodsFor: 'testing' stamp: 'ClementBera 3/18/2013 16:38'! isDead ^currentExecutedNode isNil! ! !AIContext methodsFor: 'continuation' stamp: 'ClementBera 12/7/2012 11:39'! return: value "Unwind thisContext to self and return value to self's sender. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext" "can't be nil will be root but anyway ... there is 2 root the main root and a new root so can't test if root" self outerContext ifNil: [self cannotReturn: value to: self returnContext]. self outerContext resume: value! ! !AIContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/8/2011 15:23'! temporaries: aNameCollection aNameCollection do: [ :aVarName| self temporaries at: aVarName put: nil ].! ! !AIContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 20:01'! code ^ self closure code! ! !AIContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 17:33'! outerContext: anObject outerContext := anObject! ! !AIContext methodsFor: 'compatibility layer' stamp: 'ClementBera 3/4/2013 15:51'! sender "to make it compatible with exceptions in Pharo code" ^self homeContext! ! !AIContext methodsFor: 'continuation' stamp: 'CamilloBruni 12/12/2011 16:14'! terminateTo: previousContext value: aReturnValue "Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender." PrimitiveFailed signal. ! ! !AIContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 17:35'! arguments: aCollection arguments := aCollection! ! !AIContext methodsFor: 'debugging' stamp: 'ClementBera 3/5/2013 13:47'! debugPrintString self subclassResponsibility ! ! !AIContext methodsFor: 'exception-handling' stamp: 'CamilloBruni 12/13/2011 15:07'! findNextHandlerContextStarting "Return the next handler marked context, returning nil if there is none. Search starts with self and proceeds up to nil." ^ self findContextSuchThat: [ :ctxt| ctxt hasExceptionHandler ]! ! !AIContext methodsFor: 'testing' stamp: 'ClementBera 10/18/2012 16:39'! = anAIContext (anAIContext class == self class)ifFalse: [^false]. (self closure = anAIContext closure)ifFalse: [^false]. (self temporaries = anAIContext temporaries)ifFalse: [^false]. (self arguments = anAIContext arguments)ifFalse: [^false]. (self outerContext = anAIContext outerContext)ifFalse:[^false]. ^true ! ! !AIContext methodsFor: 'exception-handling' stamp: 'CamilloBruni 12/13/2011 15:10'! handleSignal: exception "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then execute my handle block (second arg), otherwise forward this message to the next handler context. If none left, execute exception's defaultAction (see nil>>handleSignal:)." | result | (self exceptionHandler handles: exception) ifFalse: [ ^ self nextHandlerContext handleSignal: exception]. exception privHandlerContext: self contextTag. "self tempAt: 3 put: false. " "disable self while executing handle block" result := self exceptionHandler handle: exception. self return: result. "return from self if not otherwise directed in handle block" ! ! !AIContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 17:35'! arguments ^ arguments! ! !AIContext methodsFor: 'testing' stamp: 'CamilloBruni 12/12/2011 14:20'! hasExceptionHandler ^ false! ! !AIContext methodsFor: 'debugging' stamp: 'ClementBera 3/18/2013 10:28'! stack |context stack limit| stack := OrderedCollection new. context := self. limit := 1. [limit := limit + 1. context isNil or: [limit > 40]] whileFalse: [ stack add: context. context := context homeContext. ]. ^ stack! ! !AIContext methodsFor: 'accessing' stamp: 'ClementBera 3/4/2013 10:59'! homeContext self subclassResponsibility! ! !AIContext methodsFor: 'accessing' stamp: 'ClementBera 3/4/2013 10:59'! tempNamed: aName self temporaries at: aName ifPresent: [ :value| ^ value]. self homeContext ifNil: [ (VariableNotDefined signalForVariable: aName context: self) == true ifTrue: [ ^ self tempNamed: aName]]. ^ self homeContext tempNamed: aName.! ! !AIContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 18:12'! temporaries ^ temporaries ifNil: [ temporaries := SmallDictionary new]! ! !AIMethodContext commentStamp: ''! I am a specific context for the ASTInterpreter that represents MethodContext in Pharo. Instance Variables receiver: receiver - is the receiver of my method ! !AIMethodContext methodsFor: 'debugging' stamp: 'ClementBera 3/5/2013 13:48'! debugPrintString ^self code methodClass name, '>>#', self code printString! ! !AIMethodContext methodsFor: 'testing' stamp: 'ClementBera 10/18/2012 11:31'! = anAIMethodContext (super = anAIMethodContext) ifFalse: [^false]. (self receiver = anAIMethodContext receiver) ifFalse: [^false]. ^true! ! !AIMethodContext methodsFor: 'printing' stamp: 'ClementBera 12/7/2012 10:58'! printOn: aStream aStream nextPutAll: 'AIMethodCtxt: '. aStream print: self method ! ! !AIMethodContext methodsFor: 'accessing' stamp: 'ClementBera 10/19/2012 11:00'! method ^ self closure method! ! !AIMethodContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 17:33'! receiver: anObject receiver := anObject! ! !AIMethodContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 20:05'! returnContext ^ self outerContext! ! !AIMethodContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 17:33'! receiver ^ receiver! ! !AIMethodContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 20:04'! homeContext ^ self returnContext! ! !AIMethodContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/12/2011 15:51'! returnContext: aContext ^ self outerContext: aContext! ! !AIMethodContext class methodsFor: 'instance creation' stamp: 'ClementBera 10/18/2012 14:39'! fromVMContext: aMethodContext ^self new initializeContext: aMethodContext; closure: aMethodContext method; receiver: aMethodContext receiver; yourself! ! !AIRootContext commentStamp: ''! I am a specific context for the ASTInterpreter that represents the first context that is interpreted. This way, when I am fully interpreted it means that the interpreting task is finished. holds the code from a DoIt ! !AIRootContext methodsFor: 'accessing' stamp: 'ClementBera 3/18/2013 11:23'! method: aString method := FakeCompiledMethod new sourceCode: aString! ! !AIRootContext methodsFor: 'accessing' stamp: 'ClementBera 3/18/2013 16:29'! method ^ method! ! !AIRootContext methodsFor: 'accessing' stamp: 'ClementBera 12/11/2012 09:49'! tempNamed: aName put: aValue "This code permits temp to work in root context " ^self temporaries at: aName put: aValue ! ! !AIRootContext methodsFor: 'accessing' stamp: 'ClementBera 3/18/2013 15:53'! methodClass ^self class! ! !AIRootContext methodsFor: 'testing' stamp: 'ClementBera 1/14/2013 16:40'! isRootContext ^true! ! !AIRootContext methodsFor: 'accessing' stamp: 'ClementBera 3/18/2013 15:47'! receiver ^ self! ! !AIRootContext methodsFor: 'debugging' stamp: 'ClementBera 3/6/2013 16:08'! debugPrintString ^self methodClass! ! !AIRootContext methodsFor: 'testing' stamp: 'ClementBera 10/18/2012 16:44'! = anObject ^ self == anObject! ! !AIRootContext methodsFor: 'printing' stamp: 'ClementBera 3/18/2013 15:57'! printOn: aStream aStream nextPutAll: 'AIRootContext: '; nextPutAll: 'AIRootContext>>DoIt'.! ! !AIRootContext methodsFor: 'exception-handling' stamp: 'ClementBera 3/4/2013 14:58'! handleSignal: exception ^ exception resumeUnchecked: exception defaultAction! ! !AIRootContext methodsFor: 'accessing' stamp: 'ClementBera 1/14/2013 16:43'! outerContext ^ nil! ! !AIRootContext methodsFor: 'continuation' stamp: 'CamilloBruni 12/12/2011 15:56'! resume: aValue "" ^ super resume: aValue! ! !AIRootContext methodsFor: 'testing' stamp: 'CamilloBruni 12/12/2011 14:19'! hasExceptionHandler ^ true! ! !AIRootContext methodsFor: 'accessing' stamp: 'CamilloBruni 12/12/2011 15:32'! returnContext ^ self outerContext! ! !AJAlignmentInstruction commentStamp: ''! I am a pseudo instruction used to align the following instruction to a multiple of a given byte number. Example: asm := AJx64Assembler noStackFrame. "align the following instruction to a word (2bytes)" asm alignWord. asm inc: asm RAX. "align the following instruction to a double (4bytes)" asm alignDouble. asm inc: asm RAX. "align the following instruction to a QuadWord (8bytes)" asm alignQuad. asm inc: asm RAX. "align the following instruction to a multiple of an arbirary count" asm align: 64. asm inc: asm RAX.! !AJAlignmentInstruction methodsFor: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:50'! alignDouble self align: 4! ! !AJAlignmentInstruction methodsFor: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:50'! alignQuad self align: 8! ! !AJAlignmentInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/12/2012 13:55'! printSelfOn: aStream self align <= 1 ifTrue: [ ^ self ]. aStream nextPut: $|. self align <= 8 ifTrue: [ self align timesRepeat: [ aStream nextPutAll: '----|']] ifFalse: [ aStream nextPutAll: (self align asString padded: #left to: 4 with: $ ); nextPut: $|]! ! !AJAlignmentInstruction methodsFor: 'initialization' stamp: ''! initialize super initialize. self alignByte.! ! !AJAlignmentInstruction methodsFor: 'visitor' stamp: 'CamilloBruni 4/12/2012 13:38'! accept: anObject self shouldBeImplemented ! ! !AJAlignmentInstruction methodsFor: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:50'! alignWord self align: 2! ! !AJAlignmentInstruction methodsFor: 'emitting code' stamp: 'CamilloBruni 4/12/2012 13:44'! emitCode: asm | padding | padding := self paddingForPosition: position. "new machine code: | padding |" machineCode := ByteArray new: padding .! ! !AJAlignmentInstruction methodsFor: 'accessing' stamp: ''! align ^ alignTo! ! !AJAlignmentInstruction methodsFor: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:50'! alignByte self align: 1! ! !AJAlignmentInstruction methodsFor: 'emitting code' stamp: 'CamilloBruni 4/12/2012 13:50'! paddingForPosition: aPositionNumber | padding | padding := aPositionNumber \\ self align. padding = 0 ifFalse: [ padding := self align - padding ]. ^ padding! ! !AJAlignmentInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/12/2012 13:56'! name ^ String streamContents: [ :s| self printSelfOn: s]! ! !AJAlignmentInstruction methodsFor: 'accessing' stamp: ''! align: bytesSize "align the data to the given byte count" alignTo := bytesSize! ! !AJAlignmentInstruction class methodsFor: 'instance creation' stamp: ''! alignDouble ^ self new alignDouble! ! !AJAlignmentInstruction class methodsFor: 'instance creation' stamp: ''! alignQuad ^ self new alignQuad! ! !AJAlignmentInstruction class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/12/2012 13:50'! align: byteSize ^ self new align: byteSize! ! !AJAlignmentInstruction class methodsFor: 'instance creation' stamp: ''! alignWord ^ self new alignWord! ! !AJAssembler commentStamp: 'TorstenBergmann 1/30/2014 09:08'! Common superclass for assemblers. Add a subclass for each specific processor architecures (x86, ...) ! !AJBaseReg commentStamp: 'MartinMcClure 1/27/2013 09:59'! AJBaseReg -- abstract superclass of all register operands. Instance Variables: size Width in bytes (1, 2, 4, 8...) code Non-negative integer, encoding varies with subclass. For AJx86GPRegisters, ten bits: xyttttnnnn where nnnn is the register number 0-15, tttt is the "type", which encodes size as a power of 2. Higher types are used in other subclasses. If y is 1, REX prefix is required to encode this register. If x is 1, this register cannot be used when any REX prefix is present in the instruction. name Name by which this register may be referenced in instructions! !AJBaseReg methodsFor: 'accessing' stamp: ''! code "Answer the value of code" ^ code! ! !AJBaseReg methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 16:04'! prohibitsRex "Answer true if this register cannot be used in any instruction that has a REX prefix. Of the general-purpose registers, this is true only of SPL, BPL, SIL, DIL." ^ (code & RegProhibitsRexMask) ~~ 0! ! !AJBaseReg methodsFor: 'comparing' stamp: ''! hash ^ code hash! ! !AJBaseReg methodsFor: 'accessing' stamp: ''! code: anObject "Set the value of code" code := anObject! ! !AJBaseReg methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 11:07'! description ^ String streamContents: [ :s | self descriptionOn: s ].! ! !AJBaseReg methodsFor: 'accessing' stamp: ''! size ^ size! ! !AJBaseReg methodsFor: 'private' stamp: 'CamilloBruni 10/17/2012 15:54'! basicAnnotation: anObject "private setter" annotation := anObject! ! !AJBaseReg methodsFor: 'initialize-release' stamp: 'MartinMcClure 1/27/2013 09:35'! initializeWithCode: aRegisterCode name: aSymbol super initialize. self code: aRegisterCode. "Also sets size" name := aSymbol! ! !AJBaseReg methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 11:24'! influencingRegisters ^ #()! ! !AJBaseReg methodsFor: 'accessing' stamp: 'CamilloBruni 10/17/2012 15:54'! annotation: anObject "registers gereally are used as single instances, hence putting an annotation on the default register will change the annotation for all the users. To avoid that, the receiver is copied first" ^ self copy basicAnnotation: anObject; yourself! ! !AJBaseReg methodsFor: 'comparing' stamp: ''! = otherReg ^ (self class == otherReg class) and: [ code = otherReg code ]! ! !AJBaseReg methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:07'! descriptionOn: aStream self subclassResponsibility! ! !AJBaseReg methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:59'! type ^ code bitAnd: RegTypeMask! ! !AJBaseReg methodsFor: 'testing' stamp: ''! isGeneralPurpose self subclassResponsibility ! ! !AJBaseReg methodsFor: 'testing' stamp: ''! isUpperBank "Used for emitting the REX Prefix Byte on 64bit machines" ^ self index > 7! ! !AJBaseReg methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 15:34'! isX86 self subclassResponsibility! ! !AJBaseReg methodsFor: 'accessing' stamp: ''! name ^ name! ! !AJBaseReg methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 16:04'! requiresRex "Answer true if use of this register requires that the instruction have a REX prefix. This can be because the register cannot be accessed except with REX (high bank or 64-only low byte) or because the register is 64-bits wide" ^(code & RegRequiresRexMask) ~~ 0! ! !AJBaseReg methodsFor: 'accessing' stamp: ''! index ^ code bitAnd: RegCodeMask! ! !AJBaseReg class methodsFor: 'instance creation' stamp: ''! code: aRegisterCode name: aSymbol ^ self basicNew initializeWithCode: aRegisterCode name: aSymbol! ! !AJCallArgument commentStamp: 'TorstenBergmann 2/4/2014 21:38'! Argument for a call! !AJCallArgument methodsFor: 'accessing' stamp: ''! size: aSmallInteger size := aSmallInteger! ! !AJCallArgument methodsFor: 'accessing' stamp: ''! size ^ size ! ! !AJCallArgument methodsFor: 'accessing' stamp: ''! instructionName ^ #push! ! !AJCallArgument methodsFor: 'visitor' stamp: ''! accept: anObject ^ anObject visitCallArgument: self ! ! !AJCallArgument methodsFor: 'function calls' stamp: ''! prepareCallAlignments callInfo noticeArgument: self ! ! !AJCallArgument methodsFor: 'accessing' stamp: ''! stackOffset: anOffset stackOffset := anOffset ! ! !AJCallArgument methodsFor: 'accessing' stamp: ''! name ^ 'argument push:'! ! !AJCallCleanup commentStamp: 'TorstenBergmann 2/4/2014 21:38'! Cleanup for calls! !AJCallCleanup methodsFor: 'accessing' stamp: ''! name ^ 'call cleanup'! ! !AJCallCleanup methodsFor: 'visitor' stamp: ''! accept: anObject ^ anObject visitCallCleanup: self! ! !AJCallCleanup methodsFor: 'function calls' stamp: ''! prepareCallAlignments callInfo callCleanup: self ! ! !AJCallInfo commentStamp: 'TorstenBergmann 2/4/2014 21:36'! Infos for a call! !AJCallInfo methodsFor: 'accessing' stamp: ''! callCleanup: aCallCleanup self assert: callCleanup isNil. callCleanup := aCallCleanup ! ! !AJCallInfo methodsFor: 'accessing' stamp: ''! defaultArgumentSize self subclassResponsibility ! ! !AJCallInfo methodsFor: 'accessing' stamp: ''! stackSize: anObject stackSize := anObject! ! !AJCallInfo methodsFor: 'accessing' stamp: ''! noCleanup ^ noCleanup ! ! !AJCallInfo methodsFor: 'accessing' stamp: ''! alignmentInsertionPoint: instruction alignInsertionPoint := instruction! ! !AJCallInfo methodsFor: 'accessing' stamp: ''! noticeArgument: aCallArgument arguments add: aCallArgument. stackSize := stackSize + aCallArgument size.! ! !AJCallInfo methodsFor: 'accessing' stamp: ''! asm: assembler asm := assembler! ! !AJCallInfo methodsFor: 'accessing' stamp: ''! stackSize ^ stackSize! ! !AJCallInfo methodsFor: 'initialization' stamp: ''! initialize arguments := OrderedCollection new. stackSize := 0. stackAlignment := 1. noCleanup := false.! ! !AJCallInfo methodsFor: 'testing' stamp: ''! needsAlignment ^ stackAlignment > 1! ! !AJCallInfo methodsFor: 'accessing' stamp: ''! disableCleanup noCleanup := true! ! !AJCallInfo methodsFor: 'pushing args' stamp: ''! push: anArgument asm pushArgument: anArgument forCall: self. ! ! !AJCallInfo methodsFor: 'accessing' stamp: ''! name ^ 'call info' ! ! !AJCallInfo methodsFor: 'accessing' stamp: ''! alignment: aStackAlignment stackAlignment := aStackAlignment ! ! !AJCdeclCallInfo commentStamp: 'TorstenBergmann 2/4/2014 21:37'! Infos for a class according to Cdecl spec! !AJCdeclCallInfo methodsFor: 'accessing' stamp: ''! defaultArgumentSize ^ 4! ! !AJCdeclCallInfo methodsFor: 'emitting code' stamp: 'CamilloBruni 3/29/2012 14:01'! alignedCleanup asm mov: savedSP to: asm ESP. asm releaseTemps: 1 "release our temp afterwards" ! ! !AJCdeclCallInfo methodsFor: 'emitting code' stamp: ''! emitCleanup noCleanup ifTrue: [ ^ self ]. asm insert: ( asm instructionsFor: [ self needsAlignment ifTrue: [ self alignedCleanup ] ifFalse: [ self normalCleanup ] ] ) after: callCleanup! ! !AJCdeclCallInfo methodsFor: 'emitting code' stamp: 'CamilloBruni 4/4/2012 16:57'! emitAlignmentIfNeeded | alignment | self needsAlignment ifTrue: [ ^ self emitAlignment ]. self emitCleanup! ! !AJCdeclCallInfo methodsFor: 'emitting code' stamp: ''! normalCleanup stackSize > 0 ifTrue: [ asm add: asm ESP with: stackSize ]! ! !AJCdeclCallInfo methodsFor: 'emitting code' stamp: 'CamilloBruni 7/23/2012 13:29'! emitAlignment | instructions | instructions := asm instructionsFor: [ asm decorateWith: 'align stack' during: [ savedSP := asm reserveTemp annotation: 'saved SP'. asm mov: asm ESP to: savedSP. stackSize > 0 ifTrue: [ asm sub: asm ESP with: (stackSize asUImm annotation: 'stack size') ]. asm and: asm ESP with: stackAlignment - 1; neg: asm ESP; add: asm ESP with: savedSP ] ]. asm insert: instructions after: alignInsertionPoint. self emitCleanup! ! !AJConstants commentStamp: 'TorstenBergmann 1/30/2014 08:58'! A shared pool for constants from AsmJIT! !AJConstants class methodsFor: 'initialization' stamp: 'MartinMcClure 1/27/2013 15:13'! initialize "AJConstants initialize" "Operand is none, used only internally." OpNONE := 0. "Operand is register" OpREG := 1. "Operand is memory" OpMem := 2. "Operand is immediate." OpImm := 3. "Operand is label. " OpLabel := 4. RegTypeMask := 16rF0. RegCodeMask := 16r0F. RegRequiresRexMask := 16r100. RegProhibitsRexMask := 16r200. RegHighByteMask := 2r111100. "1 byte size." SizeByte := 1. "2 bytes size." SizeWord := 2. "4 bytes size." SizeDWord := 4. "8 bytes size." SizeQWord := 8. "10 bytes size." SizeTWord := 10. "16 bytes size." SizeDQWord := 16. "ID for AX/EAX/RAX registers." RIDEAX := 0. "ID for CX/ECX/RCX registers." RIDECX := 1. "ID for DX/EDX/RDX registers." RIDEDX := 2. "ID for BX/EBX/RBX registers." RIDEBX := 3. "ID for SP/ESP/RSP registers." RIDESP := 4. "ID for BP/EBP/RBP registers." RIDEBP := 5. "ID for SI/ESI/RSI registers." RIDESI := 6. "ID for DI/EDI/RDI registers." RIDEDI := 7. "8 bit general purpose register type." RegGPB := 16r00. "16 bit general purpose register type." RegGPW := 16r10. "32 bit general purpose register type." RegGPD := 16r20. "64 bit general purpose register type. " RegGPQ := 16r30. "X87 (FPU) register type. " RegX87 := 16r50. "64 bit mmx register type." RegMM := 16r60. "128 bit sse register type." RegXMM := 16r70. "Segment override prefixes." "No segment override prefix." SegmentNONE := 0. "Use 'cs' segment override prefix." SegmentCS := 1. "Use 'ss' segment override prefix." SegmentSS := 2. "Use 'ds' segment override prefix." SegmentDS := 3. "Use 'es' segment override prefix." SegmentES := 4. "Use 'fs' segment override prefix." SegmentFS := 5. "Use 'gs' segment override prefix." SegmentGS := 6. self initializePrefetchHints. self initializeConditionCodes. self initOpCodes. ! ! !AJConstants class methodsFor: 'initialization' stamp: ''! initializePrefetchHints "Prefetch hints." "Prefetch to L0 cache." PrefetchT0 := 1. "Prefetch to L1 cache." PrefetchT1 := 2. "Prefetch to L2 cache." PrefetchT2 := 3. "Prefetch using NT hint." PrefetchNTA := 0. ! ! !AJConstants class methodsFor: 'initialization' stamp: ''! initializeConditionCodes "Condition codes." "No condition code." CcNOCONDITION := -1. "Condition codes from processor manuals." CcA := 16r7. CcAE := 16r3. CcB := 16r2. CcBE := 16r6. CcC := 16r2. CcE := 16r4. CcG := 16rF. CcGE := 16rD. CcL := 16rC. CcLE := 16rE. CcNA := 16r6. CcNAE := 16r2. CcNB := 16r3. CcNBE := 16r7. CcNC := 16r3. CcNE := 16r5. CcNG := 16rE. CcNGE := 16rC. CcNL := 16rD. CcNLE := 16rF. CcNO := 16r1. CcNP := 16rB. CcNS := 16r9. CcNZ := 16r5. CcO := 16r0. CcP := 16rA. CcPE := 16rA. CcPO := 16rB. CcS := 16r8. CcZ := 16r4. " Simplified condition codes" CcOVERFLOW := 16r0. CcNOOVERFLOW := 16r1. CcBELOW := 16r2. CcABOVEEQUAL := 16r3. CcEQUAL := 16r4. CcNOTEQUAL := 16r5. CcBELOWEQUAL := 16r6. CcABOVE := 16r7. CcSIGN := 16r8. CcNOTSIGN := 16r9. CcPARITYEVEN := 16rA. CcPARITYODD := 16rB. CcLESS := 16rC. CcGREATEREQUAL := 16rD. CcLESSEQUAL := 16rE. CcGREATER := 16rF. "aliases" CcZERO := 16r4. CcNOTZERO := 16r5. CcNEGATIVE := 16r8. CcPOSITIVE := 16r9. "x87 floating point only" CcFPUNORDERED := 16. CcFPNOTUNORDERED := 17. ! ! !AJConstants class methodsFor: 'initialization' stamp: 'CamilloBruni 3/29/2012 13:49'! initOpCodes " x86 " OG8 := 16r01. OG16 := 16r02. OG32 := 16r04. OG64 := 16r08. OMEM := 16r40. OIMM := 16r80. O64Only := 16r100. OG8163264 := OG64 + OG32 + OG16 + OG8. OG163264 := OG64 + OG32 + OG16. OG3264 := OG64 + OG32. " x87" OFM1 := 16r01. OFM2 := 16r02. OFM4 := 16r04. OFM8 := 16r08. OFM10 := 16r10. OFM24 := OFM2 + OFM4. OFM248 := OFM2 + OFM4 + OFM8. OFM48 := OFM4 + OFM8. OFM4810 := OFM4 + OFM8 + OFM10. " mm|xmm" ONOREX := 16r01. " Used by MMX/SSE instructions. OG8 is never used for them " OMM := 16r10. OXMM := 16r20. OMMMEM := OMM + OMEM. OXMMMEM := OXMM + OMEM. OMMXMM := OMM + OXMM. OMMXMMMEM := OMM + OXMM + OMEM.! ! !AJData commentStamp: ''! I represent a pure data section in an assembly instruction stream. Example: asm := AJx64Assembler noStackFrame. "add a raw byte" asm db: 16rFF. "add a raw word" asm dw: #[16r34 16r12]. "add a raw double" asm dw: #[16r78 16r56 16r34 16r12]. "add a arbitrary sized data section with a byteArray" asm data: #[1 2 3 4 5 6 7 8 9 10 11 12 ].! !AJData methodsFor: 'accessing' stamp: 'CamilloBruni 4/12/2012 14:22'! data: aByteArray "the will be put in the executable." machineCode := aByteArray! ! !AJData methodsFor: 'testing' stamp: ''! is16 ^ self size = 2! ! !AJData methodsFor: 'accessing' stamp: ''! size ^ self data size! ! !AJData methodsFor: 'visitor' stamp: ''! accept: anObject anObject instructionData: self! ! !AJData methodsFor: 'accessing' stamp: 'CamilloBruni 4/12/2012 14:22'! data ^ machineCode! ! !AJData methodsFor: 'emitting code' stamp: 'CamilloBruni 4/12/2012 14:22'! emitCode: asm machineCode ifNil: [ machineCode := #[] ]! ! !AJData methodsFor: 'testing' stamp: ''! is32 ^ self size = 4! ! !AJData methodsFor: 'testing' stamp: ''! is8 ^ self size = 1! ! !AJData methodsFor: 'testing' stamp: ''! is64 ^ self size = 8! ! !AJData methodsFor: 'accessing' stamp: ''! name name ifNotNil: [ ^ name ]. "standard data sections" self is8 ifTrue: [ ^ 'db' ]. self is16 ifTrue: [ ^ 'dw' ]. self is32 ifTrue: [ ^ 'dd' ].! ! !AJData class methodsFor: 'instance creation' stamp: ''! data: aDataByteArray ^ self new data: aDataByteArray; yourself! ! !AJData class methodsFor: 'instance creation' stamp: ''! byte: aByteValue ^ self data: (ByteArray with: aByteValue)! ! !AJData class methodsFor: 'instance creation' stamp: ''! label: aLabel data: aDataByteArray ^ self new label: aLabel; data: aDataByteArray; yourself! ! !AJGeneratedCode commentStamp: 'TorstenBergmann 1/30/2014 09:09'! Instances of this class include the bytes and labels generated by AsmJIT |asm| asm := AJx64Assembler noStackFrame. asm neg: asm AL. asm ret. asm generatedCode ! !AJGeneratedCode methodsFor: 'initialization' stamp: ''! initialize labels := Dictionary new. ! ! !AJGeneratedCode methodsFor: 'output' stamp: ''! saveToFile self saveToFile: 'asm.bin'! ! !AJGeneratedCode methodsFor: 'output' stamp: ''! dumpWithLabels "dump the native code , interspersed with labels" | offsets i str | offsets := OrderedCollection new. labels keysAndValuesDo: [ :name :offset | offsets add: (offset -> name) ]. offsets := offsets sort: [:a :b | a key < b key ]. str := String new writeStream. i := 0. offsets do: [:offset | i to: offset key -1 do: [:x | str nextPutAll: ((bytes at: i+1) printStringBase: 16 nDigits: 2) ; space. i:=i+1. ]. str cr; nextPutAll: offset value; cr. ]. i to: bytes size-1 do: [:x | str nextPutAll: ((bytes at: i+1) printStringBase: 16 nDigits: 2) ; space. i := i + 1] . ^ str contents! ! !AJGeneratedCode methodsFor: 'accessing' stamp: ''! bytes: aBytes bytes := aBytes ! ! !AJGeneratedCode methodsFor: 'initialize-release' stamp: 'CamilloBruni 4/4/2012 16:30'! fromInstructions: instructions bytes := ByteArray new: 100 streamContents: [:stream| instructions do: [ :each | each extractLabels: [:name :pos | labels at: name put: pos ]. each storeOn: stream ]].! ! !AJGeneratedCode methodsFor: 'printing' stamp: ''! printOn: aStream bytes notNil ifTrue: [ aStream nextPutAll: self dumpWithLabels ]! ! !AJGeneratedCode methodsFor: 'accessing' stamp: ''! bytes ^ bytes! ! !AJGeneratedCode methodsFor: 'accessing' stamp: ''! offsetAt: aLabelName ^ labels at: aLabelName! ! !AJGeneratedCode methodsFor: 'output' stamp: ''! saveToFile: fileName (FileStream forceNewFileNamed: fileName) nextPutAll: bytes; close ! ! !AJGeneratedCode methodsFor: 'accessing' stamp: ''! labels: aLabels "turn labels into a simple name->offset pairs" aLabels keysAndValuesDo: [:name :lbl | labels at: name put: lbl paddedOffset ]. ! ! !AJGeneratedCode class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/25/2012 12:44'! fromInstructions: instructions ^ self new fromInstructions: instructions! ! !AJImmediate commentStamp: ''! I am an immediate (constant integer) operand used by the assembler. Example: "create an immediate from an integer" 1 asImm. "implicitely use an immediate in an assembly instrution" asm := AJx64Assembler new. asm add: 1 to: asm RAX. ! !AJImmediate methodsFor: 'testing' stamp: ''! isInt8 ^ size ifNil: [ self fitsInSize: 1 ] ifNotNil: [ size = 1 ]! ! !AJImmediate methodsFor: 'converting' stamp: 'CamilloBruni 4/4/2012 16:52'! asQWord "answer the 64bit word representing a value" (self fitsInSize: 8) ifFalse: [ Error signal: self asString, ' exceeds quadword (64bit) range' ]. (self isSigned and: [ value < 0 ]) ifTrue: [ ^ (1<<64) + value ]. ^ value! ! !AJImmediate methodsFor: 'emitting code' stamp: 'CamilloBruni 4/4/2012 16:53'! emitUsing: emitter size: aSize label ifNotNil: [ "this will set the label offset" emitter setLabelPosition: label. ]. aSize = 1 ifTrue: [ ^ emitter emitByte: self asByte ]. aSize = 2 ifTrue: [ ^ emitter emitWord: self asWord ]. aSize = 4 ifTrue: [ ^ emitter emitDWord: self asDWord ]. aSize = 8 ifTrue: [ ^ emitter emitQWord: self asQWord ]. self error: aSize asString, 'bytes is an invalid immediate value size'! ! !AJImmediate methodsFor: 'testing' stamp: 'CamilloBruni 4/4/2012 16:54'! fitsInSize: aSize | maxSize | maxSize := 1 << (aSize * 8). self isUnsigned ifTrue: [ ^ maxSize > value ]. value < 0 ifTrue: [ ^ 0 - value <= (maxSize >> 1) ]. ^ value < (maxSize>>1)! ! !AJImmediate methodsFor: 'converting' stamp: 'CamilloBruni 4/4/2012 16:52'! asDWord "answer the 32bit word representing a value" (self fitsInSize: 4) ifFalse: [ Error signal: self asString, ' exceeds doubleword (32bit) range' ]. (self isSigned and: [ value < 0 ]) ifTrue: [ ^ (1<<32) + value ]. ^ value! ! !AJImmediate methodsFor: 'testing' stamp: ''! isImm ^ true! ! !AJImmediate methodsFor: 'testing' stamp: ''! isSigned ^ isUnsigned not! ! !AJImmediate methodsFor: 'converting' stamp: ''! asByte "answer the byte representing a value" (self fitsInSize: 1) ifFalse: [ Error signal: self asString, ' exceeds byte (8bit) range' ]. (self isSigned and: [ value < 0 ]) ifTrue: [ ^ (1<<8) + value ]. ^ value! ! !AJImmediate methodsFor: 'initialization' stamp: ''! initialize value := 0. isUnsigned := false.! ! !AJImmediate methodsFor: 'accessing' stamp: ''! value ^ value! ! !AJImmediate methodsFor: 'accessing' stamp: ''! ivalue: aValue "signed integer value" value := aValue. isUnsigned := false.! ! !AJImmediate methodsFor: 'printing' stamp: 'CamilloBruni 10/5/2012 14:39'! printOn: aStream aStream nextPut: $(. self printAnnotationOn: aStream. value > 1000000 ifTrue: [ aStream nextPutAll: value hex] ifFalse: [ aStream print: value]. aStream space. aStream nextPut: ( self isSigned ifTrue: [ $i ] ifFalse: [ $u ]). size ifNotNil: [ aStream print: size]. aStream nextPut: $). ! ! !AJImmediate methodsFor: 'accessing' stamp: ''! label: aLabelName label := aLabelName! ! !AJImmediate methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 15:53'! requiresRex "Answer true if use of this operand requires that the instruction have a REX prefix." ^ false! ! !AJImmediate methodsFor: 'accessing' stamp: ''! uvalue: aValue "unsigned value" self assert: (aValue >=0). value := aValue. isUnsigned := true.! ! !AJImmediate methodsFor: 'testing' stamp: 'CamilloBruni 4/4/2012 16:54'! isInt32 ^ value >= -2147483648 and: [ value <= 2147483647 ] ! ! !AJImmediate methodsFor: 'converting' stamp: ''! asWord "answer the 16bit word representing a value" (self fitsInSize: 2) ifFalse: [ Error signal: self asString, ' value exceeds word (16bit) range' ]. (self isSigned and: [ value < 0 ]) ifTrue: [ ^ (1<<16) + value ]. ^ value! ! !AJImmediate methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 17:49'! prohibitsRex "Answer true if use of this operand requires that the instruction *not* have a REX prefix." ^ false! ! !AJImmediate methodsFor: 'accessing' stamp: ''! extractLabels: aBlock label ifNotNil: [ label extractLabels: aBlock ] ! ! !AJImmediate methodsFor: 'accessing' stamp: ''! size ^ size! ! !AJImmediate methodsFor: 'accessing' stamp: ''! sizeFor: anOperand "Check if I am a valid size to be used together with anOperand If so, I will use as much size as it" self assert: (self fitsInSize: anOperand size). ^anOperand size! ! !AJImmediate methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:54'! ptr "turn receiver into a memory operand with absolute address == receiver" ^ AJMem new displacement: self! ! !AJImmediate methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/18/2012 16:49'! asNBExternalType: gen ^ NBFFIConst value: self! ! !AJImmediate methodsFor: 'testing' stamp: ''! isUnsigned ^ isUnsigned! ! !AJImmediate methodsFor: 'accessing' stamp: ''! size: aSize size := aSize! ! !AJImmediate methodsFor: 'accessing' stamp: ''! relocMode ^ relocMode ifNil: [#RelocNone ]! ! !AJImmediate methodsFor: 'testing' stamp: ''! isZero ^ value = 0! ! !AJImmediate class methodsFor: 'as yet unclassified' stamp: ''! ivalue: aValue ^ self new ivalue: aValue! ! !AJInstruction commentStamp: 'TorstenBergmann 1/30/2014 09:11'! Implement machine code instructions! !AJInstruction methodsFor: 'iterating' stamp: ''! last "answer the last instruction in the list" | nn l | nn := self. [ (l := nn next) notNil ] whileTrue: [ nn := l ]. ^ nn! ! !AJInstruction methodsFor: 'accessing' stamp: ''! insert: anInstructions | n | self halt. n := next. next := anInstructions. anInstructions do: [:each | each increaseLevel: level ]. anInstructions last next: n! ! !AJInstruction methodsFor: 'printing' stamp: 'MartinMcClure 11/26/2012 18:54'! printSelfOn: aStream self printAnnotationOn: aStream. aStream nextPutAll: (self name ). "padRightTo: 4)." self printOperandsOn: aStream. self printMachineCodeOn: aStream! ! !AJInstruction methodsFor: 'printing' stamp: ''! printStringLimitedTo: aNumber ^ String streamContents: [:s | self printOn: s] ! ! !AJInstruction methodsFor: 'testing' stamp: ''! isLabelUsed: anAJJumpLabel ^ false! ! !AJInstruction methodsFor: 'testing' stamp: ''! hasLabel self shouldBeImplemented.! ! !AJInstruction methodsFor: 'accessing' stamp: ''! next ^ next! ! !AJInstruction methodsFor: 'helpers' stamp: ''! find: aByteString self shouldBeImplemented.! ! !AJInstruction methodsFor: 'accessing' stamp: ''! level ^ level! ! !AJInstruction methodsFor: 'accessing' stamp: ''! position: anObject position := anObject! ! !AJInstruction methodsFor: 'accessing' stamp: ''! annotation ^ annotation! ! !AJInstruction methodsFor: 'accessing' stamp: ''! annotation: anObject annotation := anObject! ! !AJInstruction methodsFor: 'accessing' stamp: ''! increaseLevel: num level := level + num! ! !AJInstruction methodsFor: 'initialization' stamp: ''! initialize level := 0! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/16/2012 15:29'! printOperandsOn: aStream (operands notNil and: [operands isEmpty not]) ifTrue: [aStream space; nextPut: $(. operands do: [ :operand | operand printAsOperandOn: aStream] separatedBy: [aStream space]. aStream nextPut: $)]! ! !AJInstruction methodsFor: 'visitor' stamp: ''! accept: anObject self subclassResponsibility! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/16/2012 15:24'! printOn: aStream "[ ^self ] value." self printListOn: aStream asLineStream! ! !AJInstruction methodsFor: 'visitor' stamp: ''! setPrologue: anInstrucitons "do nothing"! ! !AJInstruction methodsFor: 'accessing' stamp: ''! machineCodeSize ^ machineCode ifNil: [ 0 ] ifNotNil: [ machineCode size ]! ! !AJInstruction methodsFor: 'emitting code' stamp: ''! emitCodeAtOffset: offset assembler: asm position := offset. self emitCode: asm. next ifNotNil: [ next emitCodeAtOffset: offset + self machineCodeSize assembler: asm ].! ! !AJInstruction methodsFor: 'helpers' stamp: 'MartinMcClure 1/27/2013 17:40'! checkOperandsForConflict "Subclasses may signal an error here."! ! !AJInstruction methodsFor: 'accessing' stamp: 'MartinMcClure 2/9/2013 14:30'! operands: anObject operands := anObject! ! !AJInstruction methodsFor: 'accessing' stamp: ''! operands ^ operands! ! !AJInstruction methodsFor: 'accessing' stamp: ''! extractLabels: aBlock operands ifNotNil: [ operands do: [:each | each extractLabels: aBlock ]]! ! !AJInstruction methodsFor: 'printing' stamp: ''! storeOn: aStream "store machine code to binary stream" machineCode ifNotNil: [ aStream nextPutAll: machineCode ]! ! !AJInstruction methodsFor: 'emitting code' stamp: ''! emitCode: asm machineCode := #[] ! ! !AJInstruction methodsFor: 'manipulating' stamp: ''! insert: newInstruction before: anInstruction "replace a single instruction with one or more other instructions" | instr anext | anInstruction == self ifTrue: [ newInstruction last next: self. ^ newInstruction ]. instr := self. [ (anext := instr next) notNil and: [ anext ~~ anInstruction ]] whileTrue: [ instr := anext ]. instr next ifNotNil: [ newInstruction do: [:each | each increaseLevel: instr level ]. newInstruction last next: instr next. instr next: newInstruction ]. ! ! !AJInstruction methodsFor: 'accessing' stamp: ''! next: anObject next := anObject! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/16/2012 15:27'! printListOn: aStream self printIndentOn: aStream. self printSelfOn: aStream. next ifNotNil: [ aStream cr. next printListOn: aStream ]! ! !AJInstruction methodsFor: 'accessing' stamp: ''! level: aLevel level := aLevel ! ! !AJInstruction methodsFor: 'manipulating' stamp: ''! replace: anInstruction with: otherInstructions "replace a single instruction with one or more other instructions" | instr | anInstruction == self ifTrue: [ otherInstructions last next: self next. ^ otherInstructions ]. instr := self. [ instr notNil and: [instr next ~~ anInstruction ]] whileTrue: [ instr := instr next ]. instr notNil ifTrue: [ otherInstructions last next: instr next next. instr next: otherInstructions ]. ! ! !AJInstruction methodsFor: 'accessing' stamp: ''! instructionName ^ name! ! !AJInstruction methodsFor: 'iterating' stamp: ''! do: aBlock "evaluate all instructions for the list" | nn | nn := self. [ nn notNil ] whileTrue: [ aBlock value: nn. nn := nn next. ].! ! !AJInstruction methodsFor: 'accessing' stamp: ''! name: anObject name := anObject! ! !AJInstruction methodsFor: 'accessing' stamp: ''! position ^ position! ! !AJInstruction methodsFor: 'function calls' stamp: ''! prepareCallAlignments "do nothing"! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 10/12/2012 11:40'! printMachineCodeOn: aStream (machineCode isNil or: [machineCode isEmpty]) ifTrue: [^ self]. aStream padColumn: 65; nextPutAll: '#['. machineCode do: [ :byte | byte printOn: aStream base: 16 length: 2 padded: true ] separatedBy: [ aStream space ]. aStream nextPut: $]! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/23/2012 16:44'! printIndentOn: aStream level ifNil: [ ^ self ]. level timesRepeat: [ aStream nextPutAll: '| ']! ! !AJInstruction methodsFor: 'visitor' stamp: ''! processTempsWith: anObject "do nothing"! ! !AJInstruction methodsFor: 'accessing' stamp: ''! name ^ name ifNil: ['undefined']! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/16/2012 15:33'! printAnnotationOn: aStream annotation ifNil: [^ self]. aStream nextPut: $"; nextPutAll: annotation asString; nextPut: $"; cr. self printIndentOn: aStream! ! !AJInstructionDecoration commentStamp: 'TorstenBergmann 1/30/2014 09:16'! Used to decorate instructions with annotations! !AJInstructionDecoration methodsFor: 'accessing' stamp: ''! end end := true! ! !AJInstructionDecoration methodsFor: 'printing' stamp: 'CamilloBruni 7/23/2012 16:42'! printSelfOn: aStream end ifFalse: [ aStream nextPutAll: '/ "' ] ifTrue: [ aStream nextPutAll: '\ "end ' ]. aStream nextPutAll: annotation; nextPut: $". ! ! !AJInstructionDecoration methodsFor: 'printing' stamp: 'CamilloBruni 7/23/2012 16:43'! printIndentOn: aStream end ifFalse: [ super printIndentOn: aStream. aStream cr ]. ^ super printIndentOn: aStream! ! !AJInstructionDecoration methodsFor: 'visitor' stamp: ''! accept: anObject anObject instructionDecoration: self! ! !AJInstructionDecoration methodsFor: 'accessing' stamp: ''! start end := false! ! !AJJumpInstruction commentStamp: 'TorstenBergmann 1/30/2014 09:12'! An assembler jump instruction including a jump label and a description! !AJJumpInstruction methodsFor: 'printing' stamp: ''! printSelfOn: aStream aStream nextPutAll: name; space. label printSelfOn: aStream. machineCode ifNotNil: [ aStream space; nextPut: $[ . machineCode do: [:byte | aStream nextPutAll: (byte printStringBase: 16)] separatedBy: [ aStream space ]. aStream nextPut: $]. ]. ! ! !AJJumpInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:54'! description ^ description! ! !AJJumpInstruction methodsFor: 'accessing' stamp: ''! label ^ label! ! !AJJumpInstruction methodsFor: 'visitor' stamp: ''! accept: anObject ^ anObject jumpInstruction: self! ! !AJJumpInstruction methodsFor: 'testing' stamp: ''! isLabelUsed: anAJJumpLabel ^ label = anAJJumpLabel ! ! !AJJumpInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:55'! description: anInstructionDescription description := anInstructionDescription! ! !AJJumpInstruction methodsFor: 'accessing' stamp: ''! label: anObject label := anObject! ! !AJJumpInstruction methodsFor: 'accessing' stamp: ''! codeSize ^ machineCode size! ! !AJJumpLabel commentStamp: 'TorstenBergmann 1/30/2014 09:13'! A label for a jump! !AJJumpLabel methodsFor: 'accessing' stamp: ''! isSet: anObject isSet := anObject! ! !AJJumpLabel methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 14:48'! printSelfOn: aStream aStream nextPutAll: '@@'; nextPutAll: name asString ! ! !AJJumpLabel methodsFor: 'accessing' stamp: ''! extractLabels: aBlock aBlock value: name value: position! ! !AJJumpLabel methodsFor: 'visitor' stamp: ''! accept: anObject anObject jumpLabel: self! ! !AJJumpLabel methodsFor: 'accessing' stamp: ''! isSet ^ isSet == true! ! !AJJumpLabel methodsFor: 'emitting code' stamp: ''! emitCode: asm ! ! !AJJumpLabel methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: '@@'; nextPutAll: name asString ! ! !AJJumpLabel methodsFor: 'testing' stamp: 'CamilloBruni 8/22/2012 16:43'! isLabel ^ true! ! !AJJumpLabel methodsFor: 'printing' stamp: ''! printAsOperandOn: aStream aStream nextPutAll: '@@'; nextPutAll: name asString ! ! !AJLineStream commentStamp: 'TorstenBergmann 1/30/2014 09:10'! Utility class implementing a specific stream for printing instructions! !AJLineStream methodsFor: 'error handling' stamp: 'CamilloBruni 7/16/2012 14:59'! doesNotUnderstand: aMessage writeStream perform: aMessage selector withArguments: aMessage arguments! ! !AJLineStream methodsFor: 'writing' stamp: ''! lf self updateLineStart. writeStream lf! ! !AJLineStream methodsFor: 'writing' stamp: 'CamilloBruni 7/16/2012 15:23'! padColumn: maxCharacterPosition "pad the current line up to maxCharacterPosition with spaces" [writeStream position - lineStart < maxCharacterPosition] whileTrue: [writeStream space]! ! !AJLineStream methodsFor: 'writing' stamp: ''! crlf self updateLineStart. writeStream crlf! ! !AJLineStream methodsFor: 'writing' stamp: ''! updateLineStart lineStart := writeStream position! ! !AJLineStream methodsFor: 'writing' stamp: 'CamilloBruni 7/16/2012 15:22'! writeStream: aWriteStream writeStream := aWriteStream. self updateLineStart! ! !AJLineStream methodsFor: 'writing' stamp: 'CamilloBruni 7/16/2012 15:00'! on: aStream ^ self new writeStream: aStream; yourself! ! !AJLineStream methodsFor: 'writing' stamp: ''! cr self updateLineStart. writeStream cr! ! !AJLineStream class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/16/2012 15:33'! on: aWriteStream ^ self new writeStream: aWriteStream; yourself! ! !AJMMRegister commentStamp: ''! I am register used for the MMX integer instructions on IA-32 processors. MMX registers are 64Bit wide, depending on the instructions used the register is used either as 1 x 64bit value, 2 x 32bit values, 4 x 16bit values or 8 x 8bit values. Note that the MMX register overlap with the floating point register and only use the lower 64bits of the 80bits FPU registers.! !AJMMRegister methodsFor: 'testing' stamp: ''! isRegTypeMM ^ true! ! !AJMMRegister methodsFor: 'testing' stamp: ''! isGeneralPurpose ^ false! ! !AJMMRegister methodsFor: 'accessing' stamp: ''! code: aCode code := aCode. size := 8.! ! !AJMMRegister methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2013 11:32'! influencingRegisters "MMX registers overlap with the ST register" self shouldBeImplemented.! ! !AJMMRegister methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:13'! descriptionOn: s s nextPutAll: 'An MMX register'.! ! !AJMMRegister methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 15:28'! isX86 ^ true! ! !AJMem commentStamp: ''! I am memory operand used in assembly instructions. I can be created from an immedate or a register. Memory operands are used to read values indirectly from memory using certain offsets. Example: asm := AJx86Assembler new. "create an memory operand on the address 1234" 1234 asImm ptr "create a simple memory operand with RAX as base" asm RAX ptr. "the same with a 8 byte offset" asm RAX ptr + 8! !AJMem methodsFor: 'testing' stamp: 'MartinMcClure 1/4/2013 22:14'! hasUpperBankIndex "True iff I have an index register, and it is one of r8-r15" ^ self hasIndex and: [ self index isUpperBank ]! ! !AJMem methodsFor: 'accessing' stamp: ''! hasLabel "Answer the value of hasLabel" ^ false! ! !AJMem methodsFor: 'testing' stamp: ''! isRip ^ self base isRip! ! !AJMem methodsFor: 'testing' stamp: ''! hasBase ^ base notNil! ! !AJMem methodsFor: 'accessing' stamp: ''! displacement "Answer the value of displacement" ^ displacement! ! !AJMem methodsFor: 'accessing' stamp: 'CamilloBruni 4/4/2012 16:45'! + displacementOrIndex displacementOrIndex isInteger ifTrue: [ self displacement: (AJImmediate new ivalue: displacementOrIndex). ^ self ]. displacementOrIndex isGeneralPurpose ifTrue: [ index := displacementOrIndex. ^ self ]. self error: 'Expected integer or general purpose register for memory displacement but got ', displacementOrIndex class name, '.'.! ! !AJMem methodsFor: 'accessing' stamp: 'CamilloBruni 4/4/2012 16:40'! - aDisplacement aDisplacement isInteger ifFalse: [ self error: 'Expected integer for memory displacement but got ', aDisplacement class name, '.' ]. self displacement: (AJImmediate new ivalue: aDisplacement negated). ^ self! ! !AJMem methodsFor: 'initialization' stamp: ''! initialize displacement := AJImmediate new. shift := 0.! ! !AJMem methodsFor: 'printing' stamp: 'MartinMcClure 1/25/2013 22:21'! printOn: aStream self printAnnotationOn: aStream. aStream nextPutAll: 'mem['. base ifNotNil: [ base printAsMemBaseOn: aStream. (index isNil and: [ displacement isNil ]) ifFalse: [ aStream nextPutAll: ' + ' ] ]. index ifNotNil: [ aStream nextPutAll: index registerName. self printScaleOn: aStream. displacement ifNotNil: [ aStream nextPutAll: ' + ' ] ]. displacement ifNotNil: [ aStream print: displacement ]. aStream nextPut: $]! ! !AJMem methodsFor: 'emitting' stamp: ''! emitBaseDisplacementModRM: emitter code: rCode | mod | self base isRip ifTrue: [ emitter emitMod: 0 reg: rCode rm: 2r101. displacement emitUsing: emitter size: 4. ^ self ]. mod := 0. displacement isZero ifFalse: [ mod := displacement isInt8 ifTrue: [ 1 ] ifFalse: [ 2 ]]. self base index == RIDESP ifTrue: [ "ESP/RSP/R12" emitter emitMod: mod reg: rCode rm: RIDESP. emitter emitScale: 0 index: RIDESP base: RIDESP ] ifFalse: [ (self base index ~= RIDEBP and: [ displacement isZero ]) ifTrue: [ "just base, and not EBP/RBP/R13 " ^ emitter emitMod: 0 reg: rCode rm: base index ]. "force emitting displacement" mod = 0ifTrue: [ mod := 1 ]. emitter emitMod: mod reg: rCode rm: base index ]. mod = 1 ifTrue: [ displacement emitUsing: emitter size: 1 ]. mod = 2 ifTrue: [ displacement emitUsing: emitter size: 4 ].! ! !AJMem methodsFor: 'accessing' stamp: ''! hasLabel: anObject "Set the value of hasLabel" hasLabel := anObject! ! !AJMem methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 16:16'! requiresRex "Answer true if use of this operand requires that the instruction have a REX prefix. For a memory reference, this is true if width of the transfer is 64, or if either the base or index register is in the upper bank -- the use of a 64-bit base or index register is not enough by itself." ^ self is64 or: [ (self hasBase and: [ base isUpperBank ]) or: [ self hasIndex and: [ index isUpperBank ] ] ]! ! !AJMem methodsFor: 'emitting' stamp: ''! emit32BitAbsoluteDisplacementModRM: emitter code: rCode self hasIndex ifTrue: [ self assert: index index ~= RIDESP. " ESP/RSP" emitter emitMod: 0 reg: rCode rm: 4. emitter emitScale: shift index: index index base: 5 ] ifFalse: [ emitter emitMod: 0 reg: rCode rm: 5 ]. self hasLabel ifTrue: [ "X86 uses absolute addressing model, all relative addresses will be relocated to absolute ones." "target is label" target addRelocationAt: emitter offset displacement: displacement absolute: true size: 4. emitter emitInt32: 0 ] ifFalse: [ " Absolute address" displacement emitUsing: emitter size: 4 ]! ! !AJMem methodsFor: 'accessing' stamp: ''! index "Answer the value of index" ^ index! ! !AJMem methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 17:49'! prohibitsRex "Answer true if use of this operand requires that the instruction *not* have a REX prefix." ^ false! ! !AJMem methodsFor: 'testing' stamp: ''! hasIndex ^ index notNil! ! !AJMem methodsFor: 'accessing' stamp: 'MartinMcClure 1/27/2013 16:23'! size ^ size! ! !AJMem methodsFor: 'accessing' stamp: ''! segmentPrefix "Answer the value of segmentPrefix" ^ segmentPrefix! ! !AJMem methodsFor: 'accessing' stamp: ''! base: anObject "Set the value of base" base := anObject! ! !AJMem methodsFor: 'accessing' stamp: ''! shift "Answer the value of shift" ^ shift! ! !AJMem methodsFor: 'emitting' stamp: 'MartinMcClure 1/4/2013 22:22'! emitModRM: emitter code: rCode immSize: immSize "Receiver is memory location. rCode is a register number" "[base + displacement]" (self hasBase and: [ self hasIndex not ]) ifTrue: [ ^ self emitBaseDisplacementModRM: emitter code: rCode ]. "[base + index * scale + displacement]" (self hasBase and: [ self hasIndex ]) ifTrue: [ ^ self emitScaledBaseDisplacementModRM: emitter code: rCode ]. " Address | 32-bit mode | 64-bit mode ------------------------------+-------------+--------------- [displacement] | ABSOLUTE | RELATIVE (RIP) [index * scale + displacemnt] | ABSOLUTE | ABSOLUTE (ZERO EXTENDED) In 32 bit mode is used absolute addressing model. In 64 bit mode is used relative addressing model together with absolute addressing one. The main problem is that if the instruction contains a SIB byte then relative addressing (RIP) is not possible. " emitter is32BitMode ifTrue: [ ^ self emit32BitAbsoluteDisplacementModRM: emitter code: rCode ]. emitter is64BitMode ifTrue: [ self shouldBeImplemented ]. self invalidInstruction! ! !AJMem methodsFor: 'testing' stamp: ''! hasSegmentPrefix ^ segmentPrefix notNil! ! !AJMem methodsFor: 'accessing' stamp: ''! shift: value "Set the value of shift" self assert: (value >=0 and: [ value < 4 ]). shift := value! ! !AJMem methodsFor: 'accessing' stamp: ''! size: anObject "Set the value of size" size := anObject! ! !AJMem methodsFor: 'accessing' stamp: ''! segmentPrefix: anObject "Set the value of segmentPrefix" segmentPrefix := anObject! ! !AJMem methodsFor: 'accessing' stamp: ''! base "Answer the value of base" ^ base! ! !AJMem methodsFor: 'accessing' stamp: ''! index: anIndex "Set the value of index, must be a general purpose register" self assert: (anIndex isGeneralPurpose). index := anIndex! ! !AJMem methodsFor: 'accessing' stamp: 'MartinMcClure 1/3/2013 21:15'! scale: aScale "a valid scale values is 1 , 2 , 4 and 8" aScale = 1 ifTrue: [ shift := 0. ^ self ]. aScale = 2 ifTrue: [ shift := 1. ^ self ]. aScale = 4 ifTrue: [ shift := 2. ^ self ]. aScale = 8 ifTrue: [ shift := 3. ^ self ]. self error: 'invalid scale value'! ! !AJMem methodsFor: 'testing' stamp: ''! isMem ^ true! ! !AJMem methodsFor: 'testing' stamp: ''! isUpperBank "see `AJBaseReg >> #isUpperBank` " ^ self base isUpperBank! ! !AJMem methodsFor: 'accessing' stamp: ''! displacement: anImm "Set the value of displacement" self assert: anImm isImm. displacement := anImm! ! !AJMem methodsFor: 'accessing' stamp: ''! * aScale self scale: aScale! ! !AJMem methodsFor: 'emitting' stamp: ''! emitScaledBaseDisplacementModRM: emitter code: rCode self assert: index index ~= RIDESP. (base index ~= RIDEBP and: [ displacement isZero ]) ifTrue: [ emitter emitMod: 0 reg: rCode rm: 4. ^ emitter emitScale: shift index: index index base: base index ]. displacement isInt8 ifTrue: [ emitter emitMod: 1 reg: rCode rm: 4. emitter emitScale: shift index: index index base: base index. displacement emitUsing: emitter size: 1 ] ifFalse: [ emitter emitMod: 2 reg: rCode rm: 4. emitter emitScale: shift index: index index base: base index. displacement emitUsing: emitter size: 4 ]. ^ self! ! !AJMem methodsFor: 'printing' stamp: 'MartinMcClure 1/25/2013 22:22'! printScaleOn: aStream aStream nextPutAll: ' * '. (2 raisedToInteger: shift) printOn: aStream! ! !AJOperand commentStamp: ''! I am a generic operand used in the ASMJit assembler. I define the interface for setting the final instruction code and annotations.! !AJOperand methodsFor: 'accessing' stamp: ''! compilerData ^ compilerData! ! !AJOperand methodsFor: 'testing' stamp: ''! is16 ^ self size == 2! ! !AJOperand methodsFor: 'converting' stamp: ''! asAJOperand "receiver is already an operand. no nothing"! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegCode: aRegCode self shouldBeImplemented ! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegTypeMM ^ false! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegTypeGPQ ^ self isRegType: RegGPQ! ! !AJOperand methodsFor: 'testing' stamp: ''! isRip ^ false! ! !AJOperand methodsFor: 'accessing' stamp: ''! size32 ^ self size: 4! ! !AJOperand methodsFor: 'testing' stamp: 'MartinMcClure 1/4/2013 22:15'! hasUpperBankIndex "True iff I have an index register, and it is one of r8-r15" ^ false "Only can be true for memory references."! ! !AJOperand methodsFor: 'testing' stamp: ''! isLabel ^ false! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegTypeX87 ^ false! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegMem: aRegType self shouldBeImplemented ! ! !AJOperand methodsFor: 'accessing' stamp: ''! annotation ^ annotation! ! !AJOperand methodsFor: 'accessing' stamp: ''! annotation: anObject annotation := anObject! ! !AJOperand methodsFor: 'testing' stamp: ''! isImm ^ false ! ! !AJOperand methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:51'! ptr16 "turn receiver into a memory operand with receiver as base, with 2 bytes size" ^ self ptr size: 2! ! !AJOperand methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:52'! ptr64 "turn receiver into a memory operand with receiver as base, with 8 bytes size" ^ self ptr size: 8! ! !AJOperand methodsFor: 'accessing' stamp: ''! stackSize ^ self size! ! !AJOperand methodsFor: 'accessing' stamp: ''! clearId operandId := 0.! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegIndex: aRegIndex ^ self isReg and: [ self index == (aRegIndex bitAnd: RegCodeMask ) ] ! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegTypeGPB ^ self isRegType: RegGPB! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegTypeXMM ^ false! ! !AJOperand methodsFor: 'printing' stamp: 'CamilloBruni 10/17/2012 15:57'! printAsOperandOn: aStream self printAnnotationOn: aStream. ^ self printOn: aStream ! ! !AJOperand methodsFor: 'code generation' stamp: ''! emitPushOnStack: asm asm push: self! ! !AJOperand methodsFor: 'testing' stamp: ''! is64 ^ self size == 8! ! !AJOperand methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 15:54'! requiresRex "Answer true if use of this operand requires that the instruction have a REX prefix." self subclassResponsibility! ! !AJOperand methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 17:48'! prohibitsRex "Answer true if use of this operand requires that the instruction *not* have a REX prefix." self subclassResponsibility! ! !AJOperand methodsFor: 'accessing' stamp: ''! size16 ^ self size: 2! ! !AJOperand methodsFor: 'labels' stamp: ''! extractLabels: aBlockClosure " do nothing"! ! !AJOperand methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:52'! ptr8 "turn receiver into a memory operand with receiver as base, with 1 byte size" ^ self ptr size: 1! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegTypeGPW ^ self isRegType: RegGPW! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegMem ^ self isReg or: [ self isMem ]! ! !AJOperand methodsFor: 'accessing' stamp: ''! size "Return size of operand in bytes." self shouldBeImplemented ! ! !AJOperand methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:52'! ptr "turn receiver into a memory operand " self subclassResponsibility ! ! !AJOperand methodsFor: 'converting' stamp: 'IgorStasenko 5/28/2012 01:52'! ptr32 "turn receiver into a memory operand with receiver as base, with 4 bytes size" ^ self ptr size: 4! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegType: aRegType ^ self isReg and: [self type == aRegType]! ! !AJOperand methodsFor: 'accessing' stamp: ''! size8 ^ self size: 1! ! !AJOperand methodsFor: 'testing' stamp: ''! isNone "Return true if operand is none (OP_NONE)." self shouldBeImplemented ! ! !AJOperand methodsFor: 'testing' stamp: ''! is32 ^ self size == 4! ! !AJOperand methodsFor: 'accessing' stamp: ''! operandId ^ operandId! ! !AJOperand methodsFor: 'testing' stamp: ''! isReg ^ false! ! !AJOperand methodsFor: 'testing' stamp: ''! isMem ^ false! ! !AJOperand methodsFor: 'accessing' stamp: ''! size64 ^ self size: 8! ! !AJOperand methodsFor: 'testing' stamp: ''! is8 ^ self size == 1! ! !AJOperand methodsFor: 'testing' stamp: ''! isRegTypeGPD ^ self isRegType: RegGPD! ! !AJOperand methodsFor: 'printing' stamp: 'CamilloBruni 8/24/2012 13:56'! printAnnotationOn: aStream annotation ifNil: [ ^ self ]. aStream nextPut: $" ; nextPutAll: annotation asString; nextPut: $"; space.! ! !AJRegister commentStamp: ''! I am an abstract superclass for the standard x86 registers.! !AJRegister methodsFor: 'testing' stamp: ''! isReg ^ true! ! !AJRegister methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 12:43'! influencingRegisters self is8 ifFalse: [ ^ self as8 influencingRegisters ]. ^ { self as8. self as16. self as32. self as64}! ! !AJRegister methodsFor: 'accessing' stamp: ''! code: aCode code := aCode. size := 1 << (( code bitAnd: RegTypeMask ) >> 4).! ! !AJRegister methodsFor: 'accessing' stamp: ''! size ^ 1 << (( code bitAnd: RegTypeMask ) >> 4).! ! !AJRegister methodsFor: 'testing' stamp: ''! isGeneralPurpose ^ false! ! !AJRegister methodsFor: 'testing' stamp: 'MartinMcClure 1/30/2013 20:52'! isX86 "Return whether this register is available in the standard x86 instruction set" ^ self requiresRex not & (self index < 8)! ! !AJReleaseTemps commentStamp: 'TorstenBergmann 2/4/2014 21:37'! Handling release of temps! !AJReleaseTemps methodsFor: 'printing' stamp: ''! printSelfOn: aStream aStream nextPutAll: 'Release temps: '; print: count ! ! !AJReleaseTemps methodsFor: 'accessing' stamp: ''! count ^ count! ! !AJReleaseTemps methodsFor: 'accessing' stamp: ''! count: anObject count := anObject! ! !AJReleaseTemps methodsFor: 'visitor' stamp: ''! accept: anObject anObject visitReleaseTemps: self ! ! !AJReleaseTemps methodsFor: 'printing' stamp: ''! printOn: aStream ^ self printSelfOn: aStream ! ! !AJReleaseTemps methodsFor: 'visitor' stamp: ''! processTempsWith: anObject anObject releaseTemps: count! ! !AJReserveTemp commentStamp: 'IgorStasenko 1/18/2012 13:09'! note: assembler should set size even before realizing a temp into stack location reference! !AJReserveTemp methodsFor: 'accessing' stamp: ''! operand ^ operands first! ! !AJReserveTemp methodsFor: 'testing' stamp: 'IgorStasenko 8/13/2013 13:45'! prohibitsRex "This test is used to validate if operand(s) is valid.. but reserve temp could not have an operand assigned yet and validation can be only performed at instruction analyzis stage (right before emitting the code), but not at instruction creation time" self flag: #todo. ^ false! ! !AJReserveTemp methodsFor: 'converting' stamp: ''! asAJOperand ^ operands first! ! !AJReserveTemp methodsFor: 'accessing' stamp: ''! size ^ size! ! !AJReserveTemp methodsFor: 'accessing' stamp: ''! stackSize ^ self size! ! !AJReserveTemp methodsFor: 'accessing' stamp: ''! size: number size := number! ! !AJReserveTemp methodsFor: 'visitor' stamp: ''! accept: anObject ^ anObject reserveTemp: self! ! !AJReserveTemp methodsFor: 'printing' stamp: ''! printOn: aStream ^ self printSelfOn: aStream ! ! !AJReserveTemp methodsFor: 'testing' stamp: ''! isMem ^ true! ! !AJReserveTemp methodsFor: 'accessing' stamp: ''! operand: anObject anObject annotation: annotation. operands := Array with: anObject ! ! !AJReserveTemp methodsFor: 'printing' stamp: 'CamilloBruni 7/20/2012 13:29'! printAsOperandOn: aStream annotation ifNotNil: [ aStream nextPut: $"; nextPutAll: annotation asString; nextPut: $"; space ]. operands ifNil: [ ^ aStream nextPutAll: 'aStackTEMP' ]. self operand printAsOperandOn: aStream.! ! !AJReserveTemp methodsFor: 'visitor' stamp: ''! processTempsWith: anObject anObject reserveTemp: self ! ! !AJReserveTemp methodsFor: 'emitting code' stamp: ''! emitPushOnStack: asm ^ asm push: self! ! !AJReserveTemp methodsFor: 'accessing' stamp: 'CamilloBruni 8/24/2012 13:32'! name ^ name ifNil: [ 'Reserve temp' ]! ! !AJRoutineEpilogue commentStamp: 'TorstenBergmann 1/30/2014 09:15'! In assembly language programming an epilogue is a few lines of code that appears at the end of a routine! !AJRoutinePrologue commentStamp: 'IgorStasenko 5/11/2011 00:32'! This is a pseudo-instruction to indicate a place in native code for routine prologue. It is later replaced by real instructions which contain code for initializing stack frame & extra stack space required by routine.! !AJRoutinePrologue methodsFor: 'visitor' stamp: 'CamilloBruni 10/4/2012 18:54'! setPrologue: anInstructions "do nothing" | old | old := next. next := anInstructions. anInstructions last next: old ! ! !AJRoutinePrologue methodsFor: 'accessing' stamp: ''! name ^ 'prologue' ! ! !AJRoutinePrologue methodsFor: 'visitor' stamp: ''! accept: anObject ^ anObject visitRoutinePrologue: self! ! !AJRoutinePrologue methodsFor: 'emitting code' stamp: ''! emitCode: asm machineCode := #[]! ! !AJRoutineStackManager commentStamp: 'TorstenBergmann 2/4/2014 21:37'! Stack handling for routines! !AJRoutineStackManager methodsFor: 'initialization' stamp: ''! initialize self reset. noStackFrame := false.! ! !AJRoutineStackManager methodsFor: 'as yet unclassified' stamp: ''! newStdCall self stackFrameCheck. ^ calls add: (AJStdCallCallInfo new) ! ! !AJRoutineStackManager methodsFor: 'as yet unclassified' stamp: ''! noStackFrame noStackFrame := true.! ! !AJRoutineStackManager methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 4/4/2012 16:33'! analyzeInstructions: anInstructions assembler: asm instructions := anInstructions. assembler := asm. instructions do: #prepareCallAlignments. calls do: [:callInfo | callInfo asm: assembler. callInfo emitAlignmentIfNeeded ]. instructions do: [:each | each processTempsWith: self]. self emitPrologue. ^ instructions ! ! !AJRoutineStackManager methodsFor: 'as yet unclassified' stamp: ''! newCdeclCall self stackFrameCheck. ^ calls add: (AJCdeclCallInfo new)! ! !AJRoutineStackManager methodsFor: 'as yet unclassified' stamp: ''! releaseTemps: count temps := temps - count! ! !AJRoutineStackManager methodsFor: 'initialize-release' stamp: ''! reset instructions := nil. assembler := nil. calls := OrderedCollection new. temps := maxTemps := extraStackBytes := 0. ! ! !AJRoutineStackManager methodsFor: 'as yet unclassified' stamp: ''! reserveExtraBytesOnStack: numBytes self stackFrameCheck. extraStackBytes := numBytes ! ! !AJRoutineStackManager methodsFor: 'emitting' stamp: ''! emitPrologue noStackFrame == true ifTrue: [ ^self ]. instructions do: [:each | each setPrologue: (assembler instructionsFor: [ | numBytes | assembler push: assembler EBP; mov: assembler ESP to: assembler EBP. numBytes := extraStackBytes. numBytes := numBytes + (maxTemps * assembler wordSize ). numBytes > 0 ifTrue: [ (assembler sub: assembler ESP with: numBytes) annotation: extraStackBytes asString , ' extra bytes + ' , maxTemps asString , ' temps' ] ]). ] ! ! !AJRoutineStackManager methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/7/2013 19:06'! reserveTemp: anAJReserveTemp self stackFrameCheck. temps := temps + 1. maxTemps := maxTemps max: temps . anAJReserveTemp operand: (assembler stackFrameValueAtOffset: extraStackBytes + (temps * assembler wordSize )).! ! !AJRoutineStackManager methodsFor: 'as yet unclassified' stamp: ''! stackFrameCheck noStackFrame ifTrue: [ self error: 'Operation requires stack frame management to be enabled for generated code' ].! ! !AJRoutineStackManager methodsFor: 'as yet unclassified' stamp: ''! emitEpilogue: popExtraBytes assembler: asm asm leave. popExtraBytes > 0 ifTrue: [ asm ret: popExtraBytes asUImm ] ifFalse: [ asm ret. ].! ! !AJStackAlignmentTests commentStamp: 'TorstenBergmann 2/4/2014 21:39'! SUnit Tests for stack alignment! !AJStackAlignmentTests methodsFor: 'tests' stamp: ''! testNewProtocolForAlignedCalls | asm callInfo | asm := self newAssembler. asm cdeclCall: [:call | call push: EAX; push: EAX; push: 4. asm call: EAX. callInfo := call. ] alignment: 32. asm generatedCode. "to analyze instructions" self assert: callInfo stackSize = 12. self assert: callInfo needsAlignment ! ! !AJStackAlignmentTests methodsFor: 'utility' stamp: ''! newAssembler ^ AJx86Assembler new! ! !AJStackAlignmentTests methodsFor: 'tests' stamp: ''! testJumps | asm callInfo | asm := self newAssembler. asm noStackFrame. asm jmp: #foo; nop; nop; nop; nop; nop; nop; nop; nop; label: #foo. ^ asm generatedCode.! ! !AJStackInstruction commentStamp: 'TorstenBergmann 2/4/2014 21:37'! Stack instructions! !AJStackInstruction methodsFor: 'accessing' stamp: ''! callInfo: anObject callInfo := anObject! ! !AJStackInstruction methodsFor: 'accessing' stamp: ''! callInfo ^ callInfo! ! !AJStdCallCallInfo commentStamp: 'IgorStasenko 8/5/2011 06:17'! stdcall calling convention. Used on windows. No need for stack cleanup after call. No need to align stack before making call.! !AJStdCallCallInfo methodsFor: 'emitting code' stamp: ''! emitAlignmentIfNeeded "do nothing" "stdcall calling convention requires no stack alignment, no stack cleanup after call"! ! !AJStdCallCallInfo methodsFor: 'emitting code' stamp: ''! emitAlignment "do nothing" "stdcall calling convention requires no stack alignment, no stack cleanup after call"! ! !AJx64Assembler commentStamp: ''! I am an assembler for the Intel x86-64 architecture.! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12W "A 16bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ R12W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9 "A 64bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ R9! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RCX "A 64bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ RCX! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RIP "A 64bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ RIP! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10B "A 8bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ R10B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'MartinMcClure 1/27/2013 20:55'! SIL ^ SIL! ! !AJx64Assembler methodsFor: 'register' stamp: ''! basePointer ^ RBP ! ! !AJx64Assembler methodsFor: 'accessing' stamp: ''! numGPRegisters ^ 16! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14B "A 8bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ R14B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9D "A 32bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ R9D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM9 "An SSE register" ^ XMM9! ! !AJx64Assembler methodsFor: 'initialization' stamp: 'CamilloBruni 4/17/2012 18:16'! initialize super initialize. is64 := true.! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R15W "A 16bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ R15W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R11 "A 64bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ R11! ! !AJx64Assembler methodsFor: 'register' stamp: ''! data ^ RDX! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'MartinMcClure 1/27/2013 20:54'! SPL ^ SPL! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R11D "A 32bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ R11D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12D "A 32bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ R12D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10W "A 16bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ R10W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RDX "A 64bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ RDX! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM13 "An SSE register" ^ XMM13! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8B "A 8bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ R8B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8 "A 64bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ R8! ! !AJx64Assembler methodsFor: 'register' stamp: ''! instructionPointer ^ RIP! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RDI "A 64bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ RDI! ! !AJx64Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 18:17'! instructionDesciptions ^ AJx64InstructionDescription instructions! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM8 "An SSE register" ^ XMM8! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! IP "A 16bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ IP! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM12 "An SSE register" ^ XMM12! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12 "A 64bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ R12! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8D "A 32bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ R8D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10D "A 32bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ R10D! ! !AJx64Assembler methodsFor: 'register' stamp: ''! destinationIndex ^ RDI! ! !AJx64Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/18/2012 15:25'! newInstruction ^ AJx64Instruction new! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8W "A 16bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ R8W! ! !AJx64Assembler methodsFor: 'register' stamp: ''! stackPointer ^ RSP! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM14 "An SSE register" ^ XMM14! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RSP "A 64bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ RSP! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RBX "A 64bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ RBX! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RSI "A 64bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ RSI! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R15D "A 32bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ R15D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM15 "An SSE register" ^ XMM15! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9W "A 16bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ R9W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R13B "A 8bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ R13B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14 "A 64bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ R14! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! EIP "A 32bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ EIP! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14W "A 16bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ R14W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'MartinMcClure 1/27/2013 20:55'! BPL ^ BPL! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R15 "A 64bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ R15! ! !AJx64Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/18/2012 15:24'! newJumpInstruction ^ AJx64JumpInstruction new! ! !AJx64Assembler methodsFor: 'register' stamp: ''! sourceIndex ^ RSI! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM11 "An SSE register" ^ XMM11! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14D "A 32bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ R14D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12B "A 8bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ R12B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13D "A 32bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ R13D! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10 "A 64bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ R10! ! !AJx64Assembler methodsFor: 'register' stamp: ''! counter ^ RCX! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'MartinMcClure 1/27/2013 20:55'! DIL ^ DIL! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13W "A 16bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ R13W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R11W "A 16bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ R11W! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R11B "A 8bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ R11B! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13 "A 64bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ R13! ! !AJx64Assembler methodsFor: 'register' stamp: ''! accumulator ^ RAX! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RAX "A 64bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ RAX! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R15B "A 8bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ R15B! ! !AJx64Assembler methodsFor: 'accessing' stamp: ''! pointerSize "see AJx86Assembler >> #pointerSize" ^ 8! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R9B "A 8bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ R9B! ! !AJx64Assembler methodsFor: 'testing' stamp: ''! is32 ^ false! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM10 "An SSE register" ^ XMM10! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RBP "A 64bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ RBP! ! !AJx64AssemblerTests commentStamp: 'TorstenBergmann 2/4/2014 21:39'! SUnit tests for 64 bit assembler! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:14'! testAssemblyMemBaseDisp asm mov: RAX ptr + 1 -> EAX; mov: RBX ptr + ECX -> EAX. self assert: asm bytes = #(16r8B 16r40 16r01 16r8B 16r04 16r0B) asByteArray! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/25/2013 19:31'! testCallInvalid "on 64 bit .. - only 32bit relative offset are allowed - only 64bit registers for indirect addresses" "relative calls with 64bit addresses are not supported" self asmShould: [ :a | a call: 16r123456789ABCDEF ] raise: Error. AJx86Registers generalPurpose do: [ :register | register is64 ifFalse: [ self asmShould: [ :a | a call: register ] raise: Error ] ifTrue: [ self deny: (self bytes: [ :a | a call: register ]) isEmpty ] ]! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 5/15/2012 14:19'! testBitTest "8 Bit =====================================================" self asmShould: [ :a| a bt: a R8B with: 16r1. ] raise: Error. "16 bit =====================================================" "lower bank 16bit register opcode + ModR/M" self assert: [ :a| a bt: a AX with: 16r01 ] bytes: #[ "16bit mode" 16r66 "OP" 16r0f 16rba "ModRM" 2r11100000 "immediate" 16r01]. "upper bank 16bit register opcode + ModR/M" self assert: [ :a| a bt: a R8W with: 16r01 ] bytes: #[ "16bit mode" 16r66 "REX" 2r01000001 "OP" 16r0f 16rba "ModRM" 2r11100000 "immediate" 16r01]. "32 bit =====================================================" "lower bank 32bit register opcode + ModR/M" self assert: [ :a| a bt: a EAX with: 16r01 ] bytes: #[ "OP" 16r0f 16rba "ModRM" 2r11100000 "immediate" 16r01]. "upper bank 32bit register opcode + ModR/M" self assert: [ :a| a bt: a R8D with: 16r01 ] bytes: #[ "REX" 2r01000001 "OP" 16r0f 16rba "ModRM" 2r11100000 "immediate" 16r01]. "64 bit =====================================================" "lower bank 32bit register opcode + ModR/M" self assert: [ :a| a bt: a RAX with: 16r01 ] bytes: #[ "REX" 2r01001000 "OP" 16r0f 16rba "ModRM" 2r11100000 "immediate" 16r01]. "upper bank 32bit register opcode + ModR/M" self assert: [ :a| a bt: a R8 with: 16r01 ] bytes: #[ "REX" 2r01001001 "OP" 16r0f 16rba "ModRM" 2r11100000 "immediate" 16r01].! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:42'! testPush "lower bank 64bit register" self assert: [:a | a push: a RSP ] bytes: #[ 16r54 "16r50 + RSP index" ].! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:42'! testPop "lower bank 64bit register" self assert: [:a | a pop: a RSP ] bytes: #[ 16r5c ].! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:42'! testNeg "8bit ======================================================" self assert: [ :a | a neg: a AL] bytes: #[ 16rF6 "ModR/M" 2r11011000 ]. "8bit upper bank with REX" self assert: [ :a | a neg: a R8B] bytes: #[ 2r01000001 16rF6 "ModR/M" 2r11011000 ]. "16bit with fallback =======================================" self assert: [ :a | a neg: a AX] bytes: #[ 16r66 16rF7"ModR/M" 2r11011000 ]. "16bit upper bank with REX" self assert: [ :a | a neg: a R8W] bytes: #[ 16r66 2r01000001 16rF7"ModR/M" 2r11011000 ]. "word 16bit IP relative " self assert: [ :a | a neg: a IP ptr16 + 16r12345678] bytes: #[16r66 16rF7 "ModR/M"2r00011101 16r78 16r56 16r34 16r12]. "32bit ====================================================" self assert: [ :a | a neg: a EAX] bytes: #[ 16rF7"ModR/M" 2r11011000 ]. "32bit upper bank with REX" self assert: [ :a | a neg: a R8D] bytes: #[ 2r01000001 16rF7"ModR/M" 2r11011000 ]. "negate double word 32bit EIP relative " self assert: [ :a | a neg: a EIP ptr32 + 16r12345678] bytes: #[16rF7 "ModR/M"2r00011101 16r78 16r56 16r34 16r12]. "64bit with REX ==========================================" self assert: [ :a | a neg: a RAX] bytes: #[ 2r01001000 16rF7 "ModR/M"2r11011000 ]. "64bit upper bank" self assert: [ :a | a neg: a R8] bytes: #[ 2r01001001 16rF7 "ModR/M"2r11011000 ]. "negate quadword 64bit RIP relative " self assert: [ :a | a neg: a RIP ptr64 + 16r12345678] bytes: #["REX"2r01001000 16rF7 "ModR/M"2r00011101 16r78 16r56 16r34 16r12]. ! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:37'! testMovMemory "mov memory to 8bit register ==========================" self assert: [:a | a mov: a RCX ptr to: a AL ] bytes: #[16r8A 16r00000001 "ModR/M"]. ! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:37'! testMovImmediate "8bit immediate to 8bit register" self assert: [:a | a mov: 16r12 to: a AL ] bytes: #[16rB0 16r12]. "16bit immediate to 16bit register (requires 16bit fallback prefix)" self assert: [:a | a mov: 16r1234 to: a AX ] bytes: #[16r66 16rB8 16r34 16r12]. "32bit immediate to 32bit register" self assert: [:a | a mov: 16r12345678 to: a EAX ] bytes: #[16rB8 16r78 16r56 16r34 16r12]. "64bit immediate to 64bit register (requires REX prefix)" self assert: [:a | a mov: 16r123456789ABCDEF0 to: a RAX ] bytes: #[2r01001000 16rB8 16rF0 16rDE 16rBC 16r9A 16r78 16r56 16r34 16r12]. "32bit immediate sign-extended to 64bit register (REX prefix)" self assert: [:a | a mov: 16r12345678 to: a RAX] bytes: #[ 2r01001000 16rc7 "ModR/M"16rc0 16r78 16r56 16r34 16r12 ]! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/25/2013 20:53'! testInvalidTest "In 64-bit mode, r/m8 cannot be encoded to access the following byte registers if an REX prefix is used: AH, BH, CH, DH." {AH. CH. DH. BH} do: [ :reg | self deny: (self bytes: [ :a | a test: reg with: AL ]) isEmpty. self deny: (self bytes: [ :a | a test: AL with: reg ]) isEmpty. self deny: (self bytes: [ :a | a test: reg with: 16r12 ]) isEmpty. "with an upper bank byte register => requires REX prefix" self asmShould: [ :a | a test: reg with: R8B ] raise: Error. self asmShould: [ :a | a test: R8B with: reg ] raise: Error. "with a 64bit register requring again an REX prefix" self asmShould: [ :a | a test: reg with: RAX ] raise: Error. self asmShould: [ :a | a test: RAX with: reg ] raise: Error ]! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:32'! testAssemblyMemBase self assert: [ :a | a mov: a RAX ptr to: a EAX ] bytes: #[ 16r8B 2r00000000 ]. self assert: [ :a | a mov: a RSP ptr to: a EAX] bytes: #[ 16r8B 16r04 16r24 ]. self assert: [ :a | a mov: a RBP ptr to: a EAX ] bytes: #[ 16r8B 16r45 16r00 ].! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 12/15/2012 13:13'! testSyscall self assert: [ :a | a syscall ] bytes: #[16r0F 16r05]! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:45'! testXorFastCode self "shortcut for AL + 8bit immedidate" assert: [ :a | a xor: a AL with: 16r12] bytes: #[ 16r34 16r12]. self "shortcut for AX + 16bit immedidate" assert: [ :a | a xor: a AX with: 16r1234] bytes: #[ 16r66 16r35 16r34 16r12]. self "shortcut for EAX + 16bit immedidate" assert: [ :a | a xor: a EAX with: 16r12345678] bytes: #[ 16r35 16r78 16r56 16r34 16r12]. self "shortcut for RAX + 32bit immedidate" assert: [ :a | a xor: a RAX with: 16r12345678] bytes: #[ 2r01001000 16r35 16r78 16r56 16r34 16r12].! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:30'! testAssembly0 self assert: [ :a | a mov: 16rfeedface -> RAX ] bytes: #[72 184 206 250 237 254 0 0 0 0]! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/26/2013 15:50'! testHighByteRegistersInvalid "Can't access AH, BH, CH, DH if a REX byte is required. This test attempts to test every instruction supported by AsmJit that can access an 8-bit general-purpose register AND also require a REX prefix." | legacyHRegs op2codes opBothCodes mixedWidthOpCodes byteOperandsRequiringRex wideRegistersRequiringRex | legacyHRegs := {AH. CH. DH. BH}. opBothCodes := #(#adc:with: #add:with: #mov:to: #cmp:with: #or:with: #sbb:with: #sub:with #xchg:with: #xor:with:). op2codes := #(#cmpxchg:with: #test:with: #xadd:with:). mixedWidthOpCodes := #(#crc32:with: #movsx:to: #movzx:to:). wideRegistersRequiringRex := {RAX. R8D}. "RAX requires REX.W, R8D requires REX.R or REX.B" byteOperandsRequiringRex := {SPL. BPL. SIL. DIL. R8B. (R8 ptr). (R8 ptr + 16r12). (R8 ptr + 16r1234). ((RAX ptr + R8) * 2). ((RAX ptr + R8) * 4 + 16r12). ((RAX ptr + R8) * 8 + 16r1234)}. legacyHRegs do: [ :hreg | byteOperandsRequiringRex do: [ :operand | opBothCodes do: [ :opcode | self asmShould: [ :a | a perform: opcode with: hreg with: operand ] raise: Error. self asmShould: [ :a | a perform: opcode with: operand with: hreg ] raise: Error ]. op2codes do: [ :opcode | self asmShould: [ :a | a perform: opcode with: operand with: hreg ] raise: Error ] ]. mixedWidthOpCodes do: [ :opcode | wideRegistersRequiringRex do: [ :wideReg | self asmShould: [ :a | a perform: opcode with: wideReg with: hreg ] raise: Error ] ] ]! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:12'! testAssembly3 " instructions without operands. (AJInstructionDescription instructions select: [:each | each group = #emit]) keys asSortedCollection " | str | str := #( #cbw 16r66 16r98 #cdq 16r99 #cdqe 16r48 16r98 #clc 16rF8 #cld 16rFC #cmc 16rF5 #cpuid 16r0F 16rA2 #cqo 16r48 16r99 "64 bit " #cwd 16r66 16r99 #cwde 16r98 "#daa 16r27 32 bit" "#das 16r2F 32 bit" #emms 16r0F 16r77 #f2xm1 16rD9 16rF0 #fabs 16rD9 16rE1 #fchs 16rD9 16rE0 #fclex 16r9B 16rDB 16rE2 #fcompp 16rDE 16rD9 #fcos 16rD9 16rFF #fdecstp 16rD9 16rF6 #fincstp 16rD9 16rF7 #finit 16r9B 16rDB 16rE3 #fld1 16rD9 16rE8 #fldl2e 16rD9 16rEA #fldl2t 16rD9 16rE9 #fldlg2 16rD9 16rEC #fldln2 16rD9 16rED #fldpi 16rD9 16rEB #fldz 16rD9 16rEE #fnclex 16rDB 16rE2 #fninit 16rDB 16rE3 #fnop 16rD9 16rD0 #fpatan 16rD9 16rF3 #fprem 16rD9 16rF8 #fprem1 16rD9 16rF5 #fptan 16rD9 16rF2 #frndint 16rD9 16rFC #fscale 16rD9 16rFD #fsin 16rD9 16rFE #fsincos 16rD9 16rFB #fsqrt 16rD9 16rFA #ftst 16rD9 16rE4 #fucompp 16rDA 16rE9 #fwait 16r9B #fxam 16rD9 16rE5 #fxtract 16rD9 16rF4 #fyl2x 16rD9 16rF1 #fyl2xp1 16rD9 16rF9 #int3 16rCC #leave 16rC9 #lfence 16r0F 16rAE 16rE8 #lock 16rF0 "prefix" #mfence 16r0F 16rAE 16rF0 #monitor 16r0F 16r01 16rC8 #mwait 16r0F 16r01 16rC9 #nop 16r90 #pause 16rF3 16r90 "#popad 16r61 32 bit" #popfd 16r9D #popfq 16r48 16r9D "- 64 bit " "#pushad 16r60 32 bit" #pushf 16r66 16r9C "#pushfd 16r9C 32 bit" #pushfq 16r9c" -64 bit" #rdtsc 16r0F 16r31 #rdtscp 16r0F 16r01 16rF9 #sahf 16r9E #sfence 16r0F 16rAE 16rF8 #stc 16rF9 #std 16rFD #ud2 16r0F 16r0B #std 16rFD "dummy" ) readStream. [ str atEnd ] whileFalse: [ | instr tst bytes | instr := str next. tst := OrderedCollection new. [ str peek isInteger ] whileTrue: [ tst add: str next ]. asm reset noStackFrame. asm perform: instr. bytes := asm bytes. self assert: (bytes = tst asByteArray ) description: instr, ' failed. expected ', tst asByteArray printString, ' but got ', bytes asByteArray printString. ]. ! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/27/2013 21:32'! testByteRegs4through7 "Test valid uses of byte registers SPL BPL SIL DIL, only available in 64-bit mode, and when using a REX prefix. Can't be used in the same instruction with AH, CH, DH, or BH -- this is tested in testHighByteRegistersInvalid." | byteRegs op2codes opBothCodes mixedWidthOpCodes byteRMOperands wideRegisters | "byteRegs -- register -> contribution to ModRM byte when used as the reg operand" byteRegs := {(SPL -> 16r20). (BPL -> 16r28). (SIL -> 16r30). (DIL -> 16r38)}. "opBothCodes -- #selector -> #(opcode when byteReg second arg, opcode when byteReg first arg)" opBothCodes := {(#adc:with: -> #(16r10 16r12)). (#add:with: -> #(16r00 16r02)). (#mov:with: -> #(16r88 16r8A)). (#cmp:with: -> #(16r38 16r3A)). (#or:with: -> #(16r08 16r0A)). (#sbb:with: -> #(16r18 16r1A)). (#sub:with -> #(16r28 16r2A)). (#xor:with: -> #(16r30 16r32))}. "op2Codes -- #selector -> multiByteBytecode. ByteReg is always the second arg" op2codes := {(#cmpxchg:with: -> #[16r0F 16rB0]). (#test:with: -> #[16r84]). (#xadd:with: -> #[16r0F 16rC0]) "xchg is not actually supported at this time (#xchg:with: -> #[16r86])"}. "mixedWidthOpCodes -- #selector -> multiByteBytecode. ByteReg is always the second arg" mixedWidthOpCodes := {(#movsx:with: -> #[16r0F 16rBE]). (#movzx:with: -> #[16r0F 16rB6])}. "**** Handle #crc32:with: separately due to its legacy prefix ****" "wideRegisters -- register -> #[REX prefix, contribution to ModRM byte when used as r/m operand]" wideRegisters := {(EAX -> #[16r40 16rC0]). (RAX -> #[16r48 16rC0]). (R8D -> #[16r44 16rC0]). (R8 -> #[16r4C 16rC0])}. "byteRMOperands -- operand -> #(REX prefix, #[modRMContribution, SIB and displacement bytes if any])" byteRMOperands := {(SPL -> #(16r40 #[16rC4])). (BPL -> #(16r40 #[16rC5])). (SIL -> #(16r40 #[16rC6])). (DIL -> #(16r40 #[16rC7])). (R8B -> #(16r41 #[16rC0])). (AL -> #(16r40 #[16rC0])). (R8 ptr -> #(16r41 #[16r00])). (RAX ptr -> #(16r40 #[16r00])). (R8 ptr + 16r12 -> #(16r41 #[16r40 16r12])). (RAX ptr + 16r12 -> #(16r40 #[16r40 16r12])). (R8 ptr + 16r1234 -> #(16r41 #[16r80 16r34 16r12 16r00 16r00])). (RAX ptr + 16r1234 -> #(16r40 #[16r80 16r34 16r12 16r00 16r00])). ((RAX ptr + R8) * 2 -> #(16r42 #[16r04 16r40])). ((RAX ptr + RAX) * 2 -> #(16r40 #[16r04 16r40])). ((RAX ptr + R8) * 4 + 16r12 -> #(16r42 #[16r44 16r80 16r12])). ((RAX ptr + RAX) * 4 + 16r12 -> #(16r40 #[16r44 16r80 16r12])). ((RAX ptr + R8) * 8 + 16r1234 -> #(16r42 #[16r84 16rC0 16r34 16r12 16r00 16r00])). ((RAX ptr + RAX) * 8 + 16r1234 -> #(16r40 #[16r84 16rC0 16r34 16r12 16r00 16r00]))}. byteRegs do: [ :reg | byteRMOperands do: [ :rm | opBothCodes do: [ :opcode | | opcodeByte op1 op2 | op1 := reg key. op2 := rm key. opcodeByte := opcode value last. self assert: [ :a | a perform: opcode key with: op1 with: op2 ] bytes: (ByteArray with: rm value first with: opcodeByte with: reg value | rm value last first) , rm value last allButFirst "REX" "ModRM" "SIB and displacement" "Need to add the necessary data to allow testing the reverse order of operands." ]. op2codes do: [ :opcode | self assert: [ :a | a perform: opcode key with: rm key with: reg key ] bytes: ((ByteArray with: rm value first) , opcode value copyWith: reg value | rm value last first) , rm value last allButFirst "REX" "ModRM" "SIB and displacement" ] ]. mixedWidthOpCodes do: [ :opcode | wideRegisters do: [ :rm | self assert: [ :a | a perform: opcode key with: rm key with: reg key ] bytes: ((ByteArray with: rm value first) , opcode value copyWith: reg value >> 3 | rm value last) "REX" "ModRM" "SIB and displacement" ] ] ]! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:30'! testAssembly01 self assert: [ :a | self assert: (a reg: 8 size: 4) = R8D. "mov $0xfeedface,%r8d" a mov: 16rfeedface asUImm to: R8D ] bytes: #[65 184 206 250 237 254]! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:31'! testAssembly2 self assert: [ :a| asm push: a BP; mov: a SP -> a BP; mov: 16r400 -> a RAX; mov: a BP -> a SP; pop: a RSP; ret. ] bytes: #[ 102 85 102 139 236 72 199 192 0 4 0 0 102 139 229 92 195] ! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:31'! testAssembly1 self assert: [ :a| a push: a RBP; mov: a RSP -> a RBP; mov: 1024 -> a RAX; mov: a RBP -> a RSP; pop: a RBP; ret.] bytes: #[ 85 72 139 236 72 199 192 0 4 0 0 72 139 229 93 195]! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/25/2013 21:11'! testMovZX "byte to word ========================================" "lower bank 8bit to lower bank 16bit" self assert: [:a | a movzx: a AL to: a AX ] bytes: #[102 15 182 192 ]. "lower bank 8bit to upper bank 16bit" self assert: [:a | a movzx: a AL to: a R8W ] bytes: #[102 68 15 182 192]. "upper bank 8bit to lower bank 16bit" self assert: [:a | a movzx: a R8B to: a AX ] bytes: #[102 65 15 182 192]. "upper bank 8bit to upper bank 16bit" self assert: [:a | a movzx: a R8B to: a R8W ] bytes: #[102 69 15 182 192]. "byte to doubleword ================================" "lower bank 8bit to lower bank 32bit" self assert: [:a | a movzx: a AL to: a EAX ] bytes: #[15 182 192 ]. "lower bank 8bit to upper bank 32bit" self assert: [:a | a movzx: a AL to: a R8D ] bytes: #[68 15 182 192]. "upper bank 8bit to lower bank 32bit" self assert: [:a | a movzx: a R8B to: a EAX ] bytes: #[65 15 182 192]. "upper bank 8bit to upper bank 32bit" self assert: [:a | a movzx: a R8B to: a R8D ] bytes: #[69 15 182 192]. "byte to quadword ===================" "lower bank 8bit to lower bank 64bit" self assert: [:a | a movzx: a AL to: a RAX ] bytes: #[72 15 182 192 ]. "lower bank 8bit to upper bank 64bit" self assert: [:a | a movzx: a AL to: a R8 ] bytes: #[76 15 182 192]. "upper bank 8bit to lower bank 64bit" self assert: [:a | a movzx: a R8B to: a RAX ] bytes: #[73 15 182 192 ]. "upper bank 8bit to upper bank 64bit" self assert: [:a | a movzx: a R8B to: a R8 ] bytes: #[77 15 182 192]. "word to quadword ===================" "lower bank 16bit to lower bank 64bit" self assert: [:a | a movzx: a AX to: a RAX ] bytes: #[72 15 183 192]. "lower bank 16bit to upper bank 64bit" self assert: [:a | a movzx: a AX to: a R8 ] bytes: #[76 15 183 192]. "upper bank 16bit to lower bank 64bit" self assert: [:a| a movzx: a R8W to: a RAX ] bytes: #[73 15 183 192]. "upper bank 16bit to upper bank 64bit" self assert: [:a | a movzx: a R8W to: a R8 ] bytes: #[77 15 183 192].! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/25/2013 20:37'! testAssemblyImmAddr "This is not supported in 64-bit mode -- the ModRM value for this results in RIP-relative addressing." super testAssemblyImmAddr! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:40'! testMul "8bit unsigned multiplication ==================================" "lower bank register: AX := AL * CL" self assert: [ :a | a mul: a CL] bytes: #[ 16rF6 "ModR/M" 2r11100001 ]. "upper bank register needs an REX prefix: AX := AL * R8B" self assert: [ :a | a mul: a R9B] bytes: #[ 2r01000001 16rF6 2r11100001]. "16bit unsigned multiplication ==================================" "DX:AX := AX * CX" self assert: [ :a | a mul: a CX] bytes: #[ "16bit fallback" 16r66 16rF7 2r11100001]. "32bit unsigned multiplication ==================================" "EDX:EAX := EAX * ECX" self assert: [ :a | a mul: a ECX] bytes: #[ 16rF7 2r11100001 ]. "64bit unsigned multiplication ==================================" "RDX:RAX := RAX * RCX" self assert: [ :a| a mul: a RCX] bytes: #[ 2r01001000 16rF7 2r11100001].! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/25/2013 19:41'! testXorInvalid "xor registers with non-matching sizes" self asmShould: [ :a | a xor: AL to: RAX ] raise: Error. self asmShould: [ :a | a xor: RAX to: AL ] raise: Error. self asmShould: [ :a | a xor: R8B to: RAX ] raise: Error. self asmShould: [ :a | a xor: RAX to: R8B ] raise: Error. "in 64bit mode AH CH DH and BH cannot be encoded when an REX prefix is present" {AH. CH. DH. BH} do: [ :reg | self asmShould: [ :a | a xor: reg to: a R8B ] raise: Error ]! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/3/2013 21:36'! testIndexScales self assert: [ :a | a mov: RAX -> ((RCX ptr + RDX) * 1) ] bytes: #[16r48 16r89 16r04 16r11]; assert: [ :a | a mov: RAX -> ((RCX ptr + RDX) * 2) ] bytes: #[16r48 16r89 16r04 16r51]; assert: [ :a | a mov: RAX -> ((RCX ptr + RDX) * 4) ] bytes: #[16r48 16r89 16r04 16r91]; assert: [ :a | a mov: RAX -> ((RCX ptr + RDX) * 8) ] bytes: #[16r48 16r89 16r04 16rD1]. self assert: [ :a | a mov: (RCX ptr + RDX) * 1 -> RAX ] bytes: #[16r48 16r8B 16r04 16r11]; assert: [ :a | a mov: (RCX ptr + RDX) * 2 -> RAX ] bytes: #[16r48 16r8B 16r04 16r51]; assert: [ :a | a mov: (RCX ptr + RDX) * 4 -> RAX ] bytes: #[16r48 16r8B 16r04 16r91]; assert: [ :a | a mov: (RCX ptr + RDX) * 8 -> RAX ] bytes: #[16r48 16r8B 16r04 16rD1]! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:14'! testAssemblyMemBytes asm mov: (RSI ptr + ECX size: 1) -> BL; mov: BL -> (RSI ptr + ECX size: 1). self assert: asm bytes = #(16r8A 16r1C 16r0E 16r88 16r1C 16r0E) asByteArray! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/27/2013 16:46'! testCall "relative calls ===================================================================" "8bit offset" self assert: [:a | a call: 16r12 ] bytes: #[ 16rE8 16r12 0 0 0]. "16bit offset" self assert: [:a | a call: 16r1234 ] bytes: #[ 16rE8 16r34 16r12 0 0 ]. "32bit offset" self assert: [:a | a call: 16r12345678 ] bytes: #[ 16rE8 16r78 16r56 16r34 16r12 ]. "indirect calls ===================================================================" "lower bank register" self assert: [:a | a call: asm RAX ] bytes: #[ 16rFF 2r11010000 ]. self assert: [:a | a call: asm RDI ] bytes: #[ 16rFF 2r11010111 ]. "upper bank register (require REX prefix)" self assert: [:a | a call: asm R8 ] bytes: #[ 2r01001001 16rFF 2r11010000 ]. self assert: [:a | a call: asm R15 ] bytes: #[ 2r01001001 16rFF 2r11010111 ]. "double indirect calls (with ModR/M) ==============================================" "mod = 2r00" "lower bank register" self assert: [:a | a call: a RAX ptr ] bytes: #[ 16rFF 2r00010000 ]. self assert: [:a | a call: a RDI ptr ] bytes: #[ 16rFF 2r00010111 ]. "upper bank register (require REX prefix)" self assert: [:a | a call: a R8 ptr ] bytes: #[ 2r01000001 16rFF 2r00010000 ]. self assert: [:a | a call: a R15 ptr ] bytes: #[ 2r01000001 16rFF 2r00010111 ]. "double indirect calls with offsets ==============================================" "mod = 2r01 hence with a folllwing 8bit offset" "lower bank register" self assert: [:a | a call: a RAX ptr + 8 ] bytes: #[ 16rFF 2r01010000 8]. self assert: [:a | a call: a RDI ptr + 8 ] bytes: #[ 16rFF 2r01010111 8]. "upper bank register (require REX prefix)" self assert: [:a | a call: a R8 ptr + 8] bytes: #[ 2r01000001 16rFF 2r01010000 8]. self assert: [:a | a call: a R15 ptr + 8] bytes: #[ 2r01000001 16rFF 2r01010111 8]. "double indirect calls with offsets ==============================================" "mod = 2r10 hence with a following 32bit offset" "lower bank register" self assert: [:a | a call: a RAX ptr + 16r12345678 ] bytes: #[ 16rFF 2r10010000 16r78 16r56 16r34 16r12]. self assert: [:a | a call: a RDI ptr + 16r12345678 ] bytes: #[ 16rFF 2r10010111 16r78 16r56 16r34 16r12]. "upper bank register (require REX prefix)" self assert: [:a | a call: a R8 ptr + 16r12345678] bytes: #[ 2r01000001 16rFF 2r10010000 16r78 16r56 16r34 16r12]. self assert: [:a | a call: a R15 ptr + 16r12345678] bytes: #[ 2r01000001 16rFF 2r10010111 16r78 16r56 16r34 16r12].! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/4/2013 21:57'! testMovHighIndexRegister "Mov that use r8-r15 as an index register, therefore requiring REX.X" self assert: [ :a | a mov: RAX -> ((RCX ptr + R14) * 1) ] bytes: #[16r4A 16r89 16r04 16r31]; assert: [ :a | a mov: (RCX ptr + R14) * 1 -> RAX ] bytes: #[16r4A 16r8B 16r04 16r31]! ! !AJx64AssemblerTests methodsFor: 'utility' stamp: ''! newAssembler ^ AJx64Assembler new noStackFrame; yourself! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:36'! testJumps self assert: [:a| a label: #label1; nop; nop; nop; jz: #label1. ] bytes: #[144 144 144 16r74 251 "-5 asByte"]. asm reset; noStackFrame; label: #label1. 126 timesRepeat: [ asm nop ]. asm jz: #label1. self assert: (asm bytes size = 128). self assert: [:a | a reset; noStackFrame; label: #label1; nop; nop; nop; jmp: #label1. ] bytes: #[144 144 144 235 251 ]. self assert: [:a | a reset; noStackFrame; jmp: #label1; label: #label1. ] bytes: #[ 16rEB 0 ]. ! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:14'! testAssemblyMemBaseDisp2 asm mov: RAX ptr - 1 -> EAX; mov: (RBX ptr + ECX) * 2 - 5 -> EAX. self assert: asm bytes = #(16r8B 16r40 16rFF 16r8B 16r44 16r4B 16rFB) asByteArray! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:44'! testTest "8bit operand and lower bank 8bit register" self assert: [:a | a test: a CL with: 16r12 ] bytes: #[246 193 16r12]. "8bit operand and uppe bank 8bit register" self assert: [:a | a test: a R8B with: 16r12] bytes: #[2r01000001 2r11110110 2r11000000 16r12]. "16bit operand and lower bank 16bit register" self assert: [:a | a test: a CX with: 16r1234] bytes: #[102 247 193 16r34 16r12]. "16bit operand and uppe bank 16bit register" self assert: [:a | a test: a R8W with: 16r1234] bytes: #[102 65 247 192 16r34 16r12]. "32bit operand and lower bank 32bit register" self assert: [:a | a test: a ECX with: 16r12345678] bytes: #[247 193 16r78 16r56 16r34 16r12]. "32bit operand and uppe bank 32bit register" self assert: [:a | a test: a R8D with: 16r12345678] bytes: #[65 247 192 16r78 16r56 16r34 16r12]. "32bit operand and lower bank 64bit register" self assert: [:a| a test: a RCX with: 16r12345678] bytes: #[72 247 193 16r78 16r56 16r34 16r12]. "32bit operand and uppe bank 64bit register" self assert: [:a| a test: a R8 with: 16r12345678] bytes: #[73 247 192 16r78 16r56 16r34 16r12]. ! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:44'! testXor "8bit register xor 8bit immediate ==================================" "lower bank 8bit register opcode + ModR/M" self assert: [ :a | a xor: a CL with: 16r12] bytes: #[ 16r80 2r11110001 16r12]. "upper bank 8bit register requiring REX" self assert: [ :a | a xor: a R8B with: 16r12] bytes: #[2r01000001 16r80 2r11110000 16r12]. "16bit register xor 8bit immediate ==================================" "lower bank 16bit register" self assert: [ :a | a xor: a CX with: 16r1234] bytes: #[16r66 16r81 2r11110001 16r34 16r12]. "upper bank 16bit" self assert: [ :a | a xor: a R8W with: 16r1234] bytes: #[16r66 2r01000001 16r81 2r11110000 16r34 16r12]. "32bit register =====================================================" "lower bank 32bit register" self assert: [ :a | a xor: a ECX with: 16r12345678] bytes: #[16r81 2r11110001 16r78 16r56 16r34 16r12]. "upper bank register requiring REX prefix" self assert: [ :a | a xor: a R8D with: 16r12345678] bytes: #[2r01000001 16r81 2r11110000 16r78 16r56 16r34 16r12] ! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/1/2013 22:14'! testImmLabels "test immediates with labels" | code pos | asm mov: RAX ptr -> EAX; mov: (16rFFFFFFFF asUImm label: (asm labelNamed: #foo)) to: EAX. code := asm generatedCode. pos := code offsetAt: #foo. self assert: (code bytes at: pos + 1) = 255. self assert: (code bytes at: pos + 2) = 255. self assert: (code bytes at: pos + 3) = 255. self assert: (code bytes at: pos + 4) = 255! ! !AJx64AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 1/25/2013 19:34'! testMovZxSxInvalid {AH. CH. DH. BH} do: [ :reg | self deny: (self bytes: [ :a | a movzx: reg to: a EAX ]) isEmpty. self asmShould: [ :a | a movzx: reg to: a RAX ] raise: Error ]! ! !AJx64AssemblerTests class methodsFor: 'as yet unclassified' stamp: ''! shouldInheritSelectors ^ true! ! !AJx64Instruction commentStamp: 'TorstenBergmann 1/30/2014 09:17'! The x86 - 64 bit machine instructions! !AJx64Instruction methodsFor: 'accessing' stamp: ''! instructionDesciptions ^ AJx64InstructionDescription instructions! ! !AJx64Instruction methodsFor: 'testing' stamp: ''! is64BitMode ^ true! ! !AJx64Instruction methodsFor: 'testing' stamp: 'MartinMcClure 1/30/2013 20:59'! requiresRex "Answer true if I absolutely must have a REX prefix." ^ (operands detect: [ :rawOp | | op | op := rawOp asAJOperand. op requiresRex | op is64 ] ifNone: [ #none ]) ~~ #none! ! !AJx64Instruction methodsFor: 'testing' stamp: ''! is32BitMode ^ false! ! !AJx64InstructionDescription commentStamp: 'TorstenBergmann 1/30/2014 09:19'! X64 instruction description! !AJx64InstructionDescription methodsFor: 'code emitting' stamp: ''! emitbswap: emitter operand1: op1 operand2: op2 operand3: op3 op1 isReg ifTrue: [ emitter emitRexForSingleOperand: op1. emitter emitByte: 16r0F. ^ emitter emitModR: 1 r: op1 code ]. self invalidInstruction.! ! !AJx64InstructionDescription methodsFor: 'code emitting' stamp: ''! emitpop: emitter operand1: op1 operand2: op2 operand3: op3 op1 isReg ifTrue: [ self assert: op1 isGeneralPurpose. (op1 is32 or: [ op1 is8 ]) ifTrue: [ Error signal: 'invalid register ', op1 name, '. push/pop requires 64bit/16bit reg in 64bit mode']. ^ emitter emitX86Inl: opCode1 reg: op1 withRex: op1 isUpperBank. ]. op1 isMem ifFalse: [ self invalidInstruction ]. emitter emitX86RM: opCode2 size: op1 size regOrCode: opCodeR rm: op1 ! ! !AJx64InstructionDescription methodsFor: 'code emitting' stamp: 'CamilloBruni 4/17/2012 18:43'! emitcall: emitter operand1: op1 operand2: op2 operand3: op3 (op1 isReg and: [ op1 is64 and: [ op1 isUpperBank not ]]) ifTrue: [ "shortcut" emitter emitByte: 16rFF. op1 emitModRM: emitter code: 2 immSize: 4. ^ self]. (op1 isMem and: [op1 hasBase and: [ op1 base is64 and: [ op1 base isUpperBank not ]]]) ifTrue: [ "shortcut" emitter emitByte: 16rFF. op1 emitModRM: emitter code: 2 immSize: 4. ^ self]. (op1 isMem or: [ op1 isReg and: [ op1 is64 ] ]) ifTrue: [ ^ emitter emitX86RM: 16rFF size: 4 regOrCode: 2 rm: op1 ]. op1 isImm ifTrue: [ "call by relative offset, you should be really sure what you're' doing" emitter emitByte: 16rE8. op1 emitUsing: emitter size: 4. ^ self. ]. op1 isLabel ifTrue: [ emitter emitByte: 16rE8. emitter emitDisplacement: op1 inlinedDisp: -4. ^ self ]. self invalidInstruction. ! ! !AJx64InstructionDescription methodsFor: 'code emitting' stamp: 'MartinMcClure 1/30/2013 22:13'! emitmovSxZx: emitter operand1: dst operand2: src operand3: op3 dst isReg & src isRegMem ifFalse: [ self invalidInstruction ]. src size >= dst size ifTrue: [ self invalidInstruction ]. dst isGeneralPurpose ifFalse: [ self invalidInstruction ]. src is16 ifTrue: [ ^ emitter emitX86RM: opCode1 + 1 size: dst size regOrCode: dst rm: src ]. src is32 ifTrue: [ self invalidInstruction ]. "64 bit source" emitter emitX86RM: opCode1 size: dst size regOrCode: dst rm: src! ! !AJx64InstructionDescription methodsFor: 'code emitting' stamp: 'IgorStasenko 5/28/2012 03:01'! emitmov: emitter operand1: dst operand2: src operand3: op3 src isReg & dst isReg ifTrue: [ self assert: (src isRegTypeGPB | src isRegTypeGPW | src isRegTypeGPD | src isRegTypeGPQ ). ]. " reg <- mem " dst isReg & src isRegMem ifTrue: [ self assert: (dst isRegTypeGPB | dst isRegTypeGPW | dst isRegTypeGPD | dst isRegTypeGPQ ). src isMem ifTrue: [ (src base notNil and: [ src base is64 not ]) ifTrue: [ Error signal: 'use a 64bit base register instead of ', src base asString, '(', (src base size * 8) asString, 'bit) for memory access on a 64bit CPU' ]] ifFalse:[ (src size = dst size) ifFalse: [ Error signal: 'source ',src asString,' and destination ',dst asString,' need to have the same size' ]]. ^ emitter emitX86RM: 16r0000008A + dst isRegTypeGPB not asBit size: dst size regOrCode: dst rm: src ]. " reg <- imm " dst isReg & src isImm ifTrue: [ | immSize | immSize := dst size. "Optimize instruction size by using 32 bit immediate if value can fit to it" emitter is64BitMode & immSize = 8 & src isInt32 & (src relocMode == #RelocNone) ifTrue: [ emitter emitX86RM: 16rC7 size: dst size regOrCode: 0 rm: dst. immSize := 4 ] ifFalse: [ emitter emitX86Inl: (immSize=1 ifTrue: [16rB0] ifFalse: [16rB8]) reg: dst. ]. ^ emitter emitImmediate: src size: immSize ]. "mem <- reg" dst isMem & src isReg ifTrue: [ self assert: (src isRegTypeGPB | src isRegTypeGPW | src isRegTypeGPD | src isRegTypeGPQ ). ^ emitter emitX86RM: 16r88 + src isRegTypeGPB not asBit size: src size regOrCode: src rm: dst ]. "mem <- imm" dst isMem & src isImm ifTrue: [ | immSize | immSize := dst size <= 4 ifTrue: [ dst size ] ifFalse: [4]. emitter emitX86RM: 16rC6 + ((dst size = 1) not) asBit size: dst size regOrCode: 0 rm: dst immSize: immSize. ^ emitter emitImmediate: src size: immSize ]. self invalidInstruction ! ! !AJx64InstructionDescription methodsFor: 'code emitting' stamp: 'MartinMcClure 1/30/2013 22:14'! emitalu: emitter operand1: op1 operand2: op2 operand3: op3 | opCode opReg | opCode := opCode1. opReg := opCodeR. " Mem <- Reg " (op1 isMem and: [ op2 isReg ]) ifTrue: [ ^ emitter emitX86RM: opCode + op2 isRegTypeGPB not asBit size: op2 size regOrCode: op2 rm: op1 ]. "Reg <- Reg|Mem" (op1 isReg and: [ op2 isRegMem ]) ifTrue: [ (op2 isReg and: [ op1 size ~= op2 size ]) ifTrue: [ self invalidInstruction ]. ^ emitter emitX86RM: opCode + 2 + op1 isRegTypeGPB not asBit size: op1 size regOrCode: op1 rm: op2 ]. op2 isImm ifFalse: [ self invalidInstruction ]. " AL, AX, EAX, RAX register shortcuts" (op1 isRegIndex: 0) ifTrue: [ op1 is16 ifTrue: [ emitter emitByte: 16r66 " 16 bit " ]. op1 is64 ifTrue: [ emitter emitByte: 16r48 " REX.W" ]. emitter emitByte: (opReg << 3 bitOr: 16r04 + op1 isRegTypeGPB not asBit). ^ emitter emitImmediate: op2 size: (op1 size min: 4) ]. "short constant" op2 isInt8 ifTrue: [ | szBits | szBits := op1 size = 1 ifTrue: [ 0 ] ifFalse: [ 3 ]. emitter emitX86RM: opCode2 + szBits size: op1 size regOrCode: opReg rm: op1 immSize: 1. ^ emitter emitImmediate: op2 size: 1 ]. op1 isRegMem ifTrue: [ | immSize szBits | immSize := op2 isInt8 ifTrue: [ 1 ] ifFalse: [ op1 size min: 4 ]. szBits := op1 size ~= 1 ifTrue: [ immSize ~= 1 ifTrue: [ 1 ] ifFalse: [ 3 ] ] ifFalse: [ 0 ]. emitter emitX86RM: opCode2 + szBits size: op1 size regOrCode: opReg rm: op1 immSize: immSize. ^ emitter emitImmediate: op2 size: immSize ]. self invalidInstruction! ! !AJx64InstructionDescription methodsFor: 'code emitting' stamp: ''! emitmovPtr: emitter operand1: op1 operand2: op2 operand3: op3 | reg imm opCode | (op1 isReg & op2 isImm) | (op1 isImm & op2 isReg) ifFalse: [ self invalidInstruction ]. opCode := op1 isReg ifTrue: [reg := op1. imm := op2. 16rA0] ifFalse: [reg := op2. imm := op1. 16rA2]. reg index ~= 0 ifTrue: [ self invalidInstruction ]. reg isRegTypeGPW ifTrue: [ emitter emitByte: 16r66 ]. emitter emitRexForSingleOperand: reg. emitter emitByte: opCode + (reg size ~=1) asBit. emitter emitImmediate: imm size: reg size ! ! !AJx64JumpInstruction commentStamp: 'TorstenBergmann 1/30/2014 09:18'! Jump instruction for X64! !AJx64JumpInstruction methodsFor: 'accessing' stamp: ''! instructionDesciptions ^ AJx64InstructionDescription instructions! ! !AJx64RipRegister commentStamp: ''! Virtual registers used for relative instruction pointer addressing in 64Bit mode In IA-32 architecture and compatibility mode, addressing relative to the instruction pointer is available only with control-transfer instructions. In 64-bit mode, instruc- tions that use ModR/M addressing can use RIP-relative addressing. Without RIP-rela- tive addressing, all ModR/M instruction modes address memory relative to zero.! !AJx64RipRegister methodsFor: 'converting' stamp: ''! as64 ^ AJx86Registers at: #RIP! ! !AJx64RipRegister methodsFor: 'accessing' stamp: ''! code self ripAccessError! ! !AJx64RipRegister methodsFor: 'converting' stamp: ''! as32 ^ AJx86Registers at: #EIP! ! !AJx64RipRegister methodsFor: 'testing' stamp: ''! isRip ^ true! ! !AJx64RipRegister methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 12:48'! influencingRegisters self is16 ifFalse: [ ^ self as16 influencingRegisters ]. ^ { self as16. self as32. self as64 }! ! !AJx64RipRegister methodsFor: 'error' stamp: ''! ripAccessError self error: 'RIP register ', self name, ' cannot be used only for relative addressing'! ! !AJx64RipRegister methodsFor: 'converting' stamp: ''! as8 self error: 'No 8bit register available for instruction pointer relative addressing'! ! !AJx64RipRegister methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:08'! descriptionOn: s s nextPutAll: 'A '; print: self size * 8; nextPutAll: 'bit instruction pointer register'.! ! !AJx64RipRegister methodsFor: 'testing' stamp: ''! isGeneralPurpose ^ false! ! !AJx64RipRegister methodsFor: 'testing' stamp: ''! isUpperBank ^ false! ! !AJx64RipRegister methodsFor: 'converting' stamp: ''! as16 ^ AJx86Registers at: #IP! ! !AJx64RipRegister methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2012 11:01'! isX86 ^ false! ! !AJx64RipRegister methodsFor: 'accessing' stamp: ''! index self ripAccessError! ! !AJx86Assembler commentStamp: ''! I am an Assmbler for the Intel x86 (32Bit) architecture. Example: asm := AJx64Assembler new. "by default the assembler will set up a stack frame" asm noStackFrame. "load the constant 16r12 into the RAX register" asm mov: 16r12 to: asm RAX. "output the bytes for this instruction" asm bytes ! !AJx86Assembler methodsFor: 'alignment' stamp: ''! alignDouble self addInstruction: AJAlignmentInstruction alignDouble! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fldenv: aMemoryOperand "Load x87 FPU Environment Pseudo Code ----------- FPUControlWord = SRC[FPUControlWord]; FPUStatusWord = SRC[FPUStatusWord]; FPUTagWord = SRC[FPUTagWord]; FPUDataPointer = SRC[FPUDataPointer]; FPUInstructionPointer = SRC[FPUInstructionPointer]; FPULastInstructionOpcode = SRC[FPULastInstructionOpcode]; Description ----------- Loads the complete x87 FPU operating environment from memory into the FPU registers. The source operand specifies the first byte of the operating-environment data in memory. This data is typically written to the specified memory location by a FSTENV or FNSTENV instruction. The FPU operating environment consists of the FPU control word, status word, tag word, instruction pointer, data pointer, and last opcode. Figures 8-9 through 8-12 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, show the layout in memory of the loaded environment, depending on the operating mode of the processor (protected or real) and the current operand-size attribute (16-bit or 32-bit). In virtual-8086 mode, the real mode layouts are used. The FLDENV instruction should be executed in the same operating mode as the corresponding FSTENV/FNSTENV instruction. If one or more unmasked exception flags are set in the new FPU status word, a floating-point exception will be generated upon execution of the next floating-point instruction (except for the no-wait floating-point instructions, see the section titled 'Software Exception Handling' in Chapter 8 of the Intel®64 and IA-32 ArchitecturesSoftware Developer's Manual, Volume 1). To avoid generating exceptions when loading a new environment, clear all the exception flags in the FPU status word that is being loaded. If a page or limit fault occurs during the execution of this instruction, the state of the x87 FPU registers as seen by the fault handler may be different than the state being loaded from memory. In such situations, the fault handler should ignore the status of the x87 FPU registers, handle the fault, and return. The FLDENV instruction will then complete the loading of the x87 FPU registers with no resulting context inconsistency. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fldenv operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movzx: aDestinationRegister with: aSourceRegisterOrMemory "Move with Zero-Extend Pseudo Code ----------- DEST = ZeroExtend(SRC); Description ----------- Copies the contents of the source operand (register or memory location) to the destination operand (register) and zero extends the value. The size of the converted value depends on the operand-size attribute. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bit operands. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #movzx operands: { aDestinationRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! amdprefetch: aMemoryOperand " " ^ self addInstruction: #amdprefetch operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM5 "An MMX register" ^ MM5! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ESP "A 32bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ ESP! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnae: targetLabel " " ^ self addInstruction: #jnae operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fxsave: aMemoryOperand "Save x87 FPU, MMX, XMM, and MXCSR State Description ----------- Saves the current state of the x87 FPU, MMX technology, XMM, and MXCSR registers to a 512-byte memory location specified in the destination operand. The content layout of the 512 byte region depends on whether the processor is operating in non-64-bit operating modes or 64-bit sub-mode of IA-32e mode. Bytes 464:511 are available to software use. The processor does not write to bytes 464:511 of an FXSAVE area. The operation of FXSAVE in non-64-bit modes is described first. ### Non-64-Bit Mode Operation The following table shows the layout of the state information in memory when the processoris operating in legacy modes. ------------- --------- -------- ----- -------- ----- ----- ----- --- --- --- --- --- --- --- --- -- 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 Rsrvd CS FPU IP FOP Rs rvd FTW FSW FCW 0 MXCSR\_MASK MXCSR Rsrvd DS FPU DP 16 Reserved ST0/MM0 32 Reserved ST1/MM1 48 Reserved ST2/MM2 64 Reserved ST3/MM3 80 Reserved ST4/MM4 96 Reserved ST5/MM5 112 Reserved ST6/MM6 128 Reserved ST7/MM7 144 XMM0 160 XMM1 176 XMM2 192 XMM3 208 XMM4 224 XMM5 240 XMM6 256 XMM7 272 Reserved 288 Reserved 304 Reserved 320 Reserved 336 Reserved 352 Reserved 368 Reserved 384 Reserved 400 Reserved 416 Reserved 432 Reserved 448 Available 464 Available 480 Available 496 ------------- --------- -------- ----- -------- ----- ----- ----- --- --- --- --- --- --- --- --- -- : Non-64-bit-Mode Layout of FXSAVE and FXRSTOR Memory Region The destination operand contains the first byte of the memory image, and it must be aligned on a 16-byte boundary. A misaligned destination operand will result in a general-protection (\#GP) exception being generated (or in some cases, an alignment check exception [\#AC]). The FXSAVE instruction is used when an operating system needs to perform a context switch or when an exception handler needs to save and examine the current state of the x87 FPU, MMX technology, and/or XMM and MXCSR registers. The fields used in the previous table are defined in the following table. Field Definitions Field Definition FCW x87 FPU Control Word (16 bits). See Figure 8-6 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for the layout of the x87 FPU control word. FSW x87 FPU Status Word (16 bits). See Figure 8-4 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for the layout of the x87 FPU status word. Abridged FTW x87 FPU Tag Word (8 bits). The tag information saved here is abridged, as described in the following paragraphs. FOP x87 FPU Opcode (16 bits). The lower 11 bits of this field contain the opcode, upper 5 bits are reserved. See Figure 8-8 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for the layout of the x87 FPU opcode field. FPU IP x87 FPU Instruction Pointer Offset (32 bits). The contents of this field differ depending on the current addressing mode (32-bit or 16-bit) of the processor when the FXSAVE instruction was executed: - 32-bit mode — 32-bit IP offset. - 16-bit mode — low 16 bits are IP offset; high 16 bits are reserved. See 'x87 FPU Instruction and Operand (Data) Pointers' in Chapter 8 of the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for a description of the x87 FPU instruction pointer. CS x87 FPU Instruction Pointer Selector (16 bits). FPU DP x87 FPU Instruction Operand (Data) Pointer Offset (32 bits). The contents of this field differ depending on the current addressing mode (32-bit or 16bit) of the processor when the FXSAVE instruction was executed: - 32-bit mode — 32-bit DP offset. - 16-bit mode — low 16 bits are DP offset; high 16 bits are reserved. See 'x87 FPU Instruction and Operand (Data) Pointers' in Chapter 8 of the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for a description of the x87 FPU operand pointer. DS x87 FPU Instruction Operand (Data) Pointer Selector (16 bits). MXCSR MXCSR Register State (32 bits). See Figure 10-3 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for the layout of the MXCSR register. If the OSFXSR bit in control register CR4 is not set, the FXSAVE instruction may not save this register. This behavior is implementation dependent. MXCSR\_ MXCSR\_MASK (32 bits). This mask can be used to adjust values written to MASK the MXCSR register, ensuring that reserved bits are set to 0. Set the mask bits and flags in MXCSR to the mode of operation desired for SSE and SSE2 SIMD floating-point instructions. See 'Guidelines for Writing to the MXCSR Register' in Chapter 11 of the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, for instructions for how to determine and use the MXCSR\_MASK value. ST0/MM0 through x87 FPU or MMX technology registers. These 80-bit fields contain the x87 ST7/MM7 FPU data registers or the MMX technology registers, depending on the state of the processor prior to the execution of the FXSAVE instruction. If the processor had been executing x87 FPU instruction prior to the FXSAVE instruction, the x87 FPU data registers are saved; if it had been executing MMX instructions (or SSE or SSE2 instructions that operated on the MMX technology registers), the MMX technology registers are saved. When the MMX technology registers are saved, the high 16 bits of the field are reserved. XMM0 through XMM7 XMM registers (128 bits per field). If the OSFXSR bit in control register CR4 is not set, the FXSAVE instruction may not save these registers. This behavior is implementation dependent. The FXSAVE instruction saves an abridged version of the x87 FPU tag word in the FTW field (unlike the FSAVE instruction, which saves the complete tag word). The tag information is saved in physical register order (R0 through R7), rather than in top-ofstack (TOS) order. With the FXSAVE instruction, however, only a single bit (1 for valid or 0 for empty) is saved for each tag. For example, assume that the tag word is currently set as follows: ---- ---- ---- ---- ---- ---- ---- ---- R7 R6 R5 R4 R3 R2 R1 R0 11 xx xx xx 11 11 11 11 ---- ---- ---- ---- ---- ---- ---- ---- Here, 11B indicates empty stack elements and 'xx' indicates valid (00B), zero (01B), or special (10B). For this example, the FXSAVE instruction saves only the following 8 bits of information: ---- ---- ---- ---- ---- ---- ---- ---- R7 R6 R5 R4 R3 R2 R1 R0 0 1 1 1 0 0 0 0 ---- ---- ---- ---- ---- ---- ---- ---- Here, a 1 is saved for any valid, zero, or special tag, and a 0 is saved for any empty tag. The operation of the FXSAVE instruction differs from that of the FSAVE instruction, the as follows: - FXSAVE instruction does not check for pending unmasked floating-point exceptions. (The FXSAVE operation in this regard is similar to the operation of the FNSAVE instruction). - After the FXSAVE instruction has saved the state of the x87 FPU, MMX technology, XMM, and MXCSR registers, the processor retains the contents of the registers. Because of this behavior, the FXSAVE instruction cannot be used by an application program to pass a 'clean' x87 FPU state to a procedure, since it retains the current state. To clean the x87 FPU state, an application must explicitly execute an FINIT instruction after an FXSAVE instruction to reinitialize the x87 FPU state. - The format of the memory image saved with the FXSAVE instruction is the same regardless of the current addressing mode (32-bit or 16-bit) and operating mode (protected, real address, or system management). This behavior differs from the FSAVE instructions, where the memory image format is different depending on the addressing mode and operating mode. Because of the different image formats, the memory image saved with the FXSAVE instruction cannot be restored correctly with the FRSTOR instruction, and likewise the state saved with the FSAVE instruction cannot be restored correctly with the FXRSTOR instruction. The FSAVE format for FTW can be recreated from the FTW valid bits and the stored 80-bit FP data (assuming the stored data was not the contents of MMX technology registers) using Table 3-50. Exponent all 1's Exponent all 0's Fraction all 0's J and M bits FTW valid bit x87 FTW ----------------------------------- ------------------ ------------------ -------------- --------------- --------- ---- 0 0 0 0x 1 Special 10 0 0 0 1x 1 Valid 00 0 0 1 00 1 Special 10 0 0 1 10 1 Valid 00 0 1 0 0x 1 Special 10 0 1 0 1x 1 Special 10 0 1 1 00 1 Zero 01 0 1 1 10 1 Special 10 1 0 0 1x 1 Special 10 1 0 0 1x 1 Special 10 1 0 1 00 1 Special 10 1 0 1 10 1 Special 10 For all legal combinations above. 0 Empty 11 : Recreating FSAVE Format The J-bit is defined to be the 1-bit binary integer to the left of the decimal place in the significand. The M-bit is defined to be the most significant bit of the fractional portion of the significand (i.e., the bit immediately to the right of the decimal place). When the M-bit is the most significant bit of the fractional portion of the significand, it must be 0 if the fraction is all 0's. ### IA-32e Mode Operation In compatibility sub-mode of IA-32e mode, legacy SSE registers, XMM0 through XMM7, are saved according to the legacy FXSAVE map. In 64-bit mode, all of the SSE registers, XMM0 through XMM15, are saved. Additionally, there are two different layouts of the FXSAVE map in 64-bit mode, corresponding to FXSAVE64 (which requires REX.W=1) and FXSAVE (REX.W=0). In the FXSAVE64 map (following table), theFPU IP and FPU DP pointers are 64-bit wide. In the FXSAVE map for 64-bit mode (see the following tables), the FPU IP and FPU DP pointers are 32-bits. ------------- --------- ---------- ----- ----- ----- --- --- --- --- --- --- --- --- --- --- -- 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 FPU IP FOP Reserved FTW FSW FCW 0 MXCSR\_MASK MXCSR FPU DP 16 Reserved ST0/MM0 32 Reserved ST1/MM1 48 Reserved ST2/MM2 64 Reserved ST3/MM3 80 Reserved ST4/MM4 96 Reserved ST5/MM5 112 Reserved ST6/MM6 128 Reserved ST7/MM7 144 XMM0 160 XMM1 176 XMM2 192 XMM3 208 XMM4 224 XMM5 240 XMM6 256 XMM7 272 XMM8 288 XMM9 304 XMM10 320 XMM11 336 XMM12 352 XMM13 368 XMM14 384 XMM15 400 Reserved 416 Reserved 432 Reserved 448 Available 464 Available 480 Available 496 ------------- --------- ---------- ----- ----- ----- --- --- --- --- --- --- --- --- --- --- -- : Layout of the 64-bit-mode FXSAVE64 Map (requires REX.W = 1) ------------- --------- ---------- -------- ---------- ----- ----- ----- --- --- --- --- --- --- --- --- -- 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 Reserved CS FPU IP FOP Reserved FTW FSW FCW 0 MXCSR\_MASK MXCSR Reserved FPU DP 16 Reserved ST0/MM0 32 Reserved ST1/MM1 48 Reserved ST2/MM2 64 Reserved ST3/MM3 80 ------------- --------- ---------- -------- ---------- ----- ----- ----- --- --- --- --- --- --- --- --- -- : Layout of the 64-bit-mode FXSAVE Map (REX.W = 0) Reserved ST4/MM4 96 Reserved ST5/MM5 112 Reserved ST6/MM6 128 Reserved ST7/MM7 144 XMM0 160 XMM1 176 XMM2 192 XMM3 208 XMM4 224 XMM5 240 XMM6 256 XMM7 272 XMM8 288 XMM9 304 XMM10 320 XMM11 336 XMM12 352 XMM13 368 XMM14 384 XMM15 400 Reserved 416 Reserved 432 Reserved 448 Available 464 Available 480 Available 496 " ^ self addInstruction: #fxsave operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! mov: aDestinationRegisterOrMemory with: aSource "Move Description ----------- Copies the second operand (source operand) to the first operand (destination operand). The source operand can be an immediate value, general-purpose register, segment register, or memory location; the destination register can be a general-purpose register, segment register, or memory location. Both operands must be the same size, which can be a byte, a word, a doubleword, or a quadword. The MOV instruction cannot be used to load the CS register. Attempting to do so results in an invalid opcode exception (\#UD). To load the CS register, use the far JMP, CALL, or RET instruction. If the destination operand is a segment register (DS, ES, FS, GS, or SS), the source operand must be a valid segment selector. In protected mode, moving a segment selector into a segment register automatically causes the segment descriptor information associated with that segment selector to be loaded into the hidden (shadow) part of the segment register. While loading this information, the segment selector and segment descriptor information is validated (see the 'Operation' algorithm below). The segment descriptor data is obtained from the GDT or LDT entry for the specified segment selector. A NULL segment selector (values 0000-0003) can be loaded into the DS, ES, FS, and GS registers without causing a protection exception. However, any subsequent attempt to reference a segment whose corresponding segment register is loaded with a NULL value causes a general protection exception (\#GP) and no memory reference occurs. Loading the SS register with a MOV instruction inhibits all interrupts until after the execution of the next instruction. This operation allows a stack pointer to be loaded into the ESP register with the next instruction (MOV ESP, stack-pointer value) before an interrupt occurs1. Be aware that the LSS instruction offers a more efficient method of loading the SS and ESP registers. When operating in 32-bit mode and moving data between a segment register and a general-purpose register, the 32-bit IA-32 processors do not require the use of the 16-bit operand-size prefix (a byte with the value 66H) with this instruction, but most assemblers will insert it if the standard form of the instruction is used (for example, MOV DS, AX). The processor will execute this instruction correctly, but it will usually require an extra clock. With most assemblers, using the instruction form MOV DS, EAX will avoid this unneeded 66H prefix. When the processor executes the instruction with a 32-bit general-purpose register, it assumes that the 16 least-significant bits of the general-purpose register are the destination or source operand. If the register is a destination operand, the resulting value in the two high-order bytes of the register is implementation dependent. For the Pentium 4, Intel Xeon, and P6 family processors, the two high-order bytes are filled with zeros; for earlier 32-bit IA-32 processors, the two high order bytes are undefined. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #mov operands: { aDestinationRegisterOrMemory . aSource }! ! !AJx86Assembler methodsFor: 'initialization' stamp: 'CamilloBruni 3/30/2012 16:20'! initialize is64 := false. self reset.! ! !AJx86Assembler methodsFor: 'register' stamp: ''! data ^ self is32BitMode ifTrue: [ EDX ] ifFalse: [ DX ]! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovbe: aRegister with: aSourceRegisterOrMemory "Conditional Move - below or equal/not above (CF=1 AND ZF=1) " ^ self addInstruction: #cmovbe operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! imul: aRegister with: aRegisterOrMemory with: anImmediate " see #imul" ^ self addInstruction: #imul operands: { aRegister . aRegisterOrMemory . anImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnc: targetLabel " " ^ self addInstruction: #jnc operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movmskpd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Extract Packed Double-FP Sign Mask Pseudo Code ----------- DEST[0] = SRC[63]; DEST[1] = SRC[127]; IF DEST = r32 DEST[31:2] = ZeroExtend; ELSE DEST[63:2] = ZeroExtend; FI; Description ----------- Extracts the sign bits from the packed double-precision floating-point values in the source operand (second operand), formats them into a 2-bit mask, and stores the mask in the destination operand (first operand). The source operand is an XMM register, and the destination operand is a general-purpose register. The mask is stored in the 2 low-order bits of the destination operand. Zero-extend the upper bits of the destination. In 64-bit mode, the instruction can access additional registers (XMM8-XMM15, R8-R15) when used with a REX.R prefix. The default operand size is 64-bit in 64-bit mode. " ^ self addInstruction: #movmskpd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'function calls' stamp: ''! newCdeclCall "answer an instance of CallInfo" ^ stackManager newCdeclCall asm: self.! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovae: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovae operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'converting' stamp: ''! imm: value ^ value asImm ! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnle: targetLabel "Jump short if not less nor equal/greater ((ZF=0) AND (SF=OF)) " ^ self addInstruction: #jnle operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! adc: aRegisterOrMemoryOperand with: aSource "Add with Carry " ^ self addInstruction: #adc operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 8/23/2012 16:01'! instructionDesciptions ^ AJx86InstructionDescription instructions! ! !AJx86Assembler methodsFor: 'register' stamp: 'CamilloBruni 1/10/2013 18:58'! stackPointer ^ self is32 ifTrue: [ ESP ] ifFalse: [ RSP ]! ! !AJx86Assembler methodsFor: 'options' stamp: ''! noStackFrame stackManager noStackFrame.! ! !AJx86Assembler methodsFor: 'initialize-release' stamp: ''! reset instructions := last := nil. labels := Dictionary new. stackManager ifNil: [stackManager := AJRoutineStackManager new.] ifNotNil: #reset. level := 0. self addInstruction: AJRoutinePrologue new. ! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM1 "An SSE register" ^ XMM1! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fstcw: aMemoryOperand "Store x87 FPU Control Word " ^ self addInstruction: #fstcw operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ficom: aMemoryOperand "Compare Integer " ^ self addInstruction: #ficom operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM4 "An MMX register" ^ MM4! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovp: aRegister with: aSourceRegisterOrMemory "Conditional Move - parity/parity even (PF=1) " ^ self addInstruction: #cmovp operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fmul: aMemoryOperand "Multiply " ^ self addInstruction: #fmul operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsubp: aX87Register "Subtract and Pop " ^ self addInstruction: #fsubp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fucomp: aX87Register "Unordered Compare Floating Point Values and Pop " ^ self addInstruction: #fucomp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! dec: aRegisterOrMemory "Decrement by 1 Pseudo Code ----------- DEST = DEST - 1; Description ----------- Subtracts 1 from the destination operand, while preserving the state of the CF flag. The destination operand can be a register or a memory location. This instruction allows a loop counter to be updated without disturbing the CF flag. (To perform a decrement operation that updates the CF flag, use a SUB instruction with an immediate operand of 1.) This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, DEC r16 and DEC r32 are not encodable (because opcodes 48H through 4FH are REX prefixes). Otherwise, the instruction's 64-bit mode default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #dec operands: { aRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'stack management' stamp: ''! releaseTemps: count ^ self addInstruction: (AJReleaseTemps new count: count).! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmove: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmove operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmpxchg16b: aMemoryOperand "... " ^ self addInstruction: #cmpxchg16b operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fbld: aMemoryOperand "Load Binary Coded Decimal Pseudo Code ----------- TOP = TOP - 1; ST(0) = ConvertToDoubleExtendedPrecisionFP(SRC); Description ----------- Converts the BCD source operand into double extended-precision floating-point format and pushes the value onto the FPU stack. The source operand is loaded without rounding errors. The sign of the source operand is preserved, including that of -0. The packed BCD digits are assumed to be in the range 0 through 9; the instruction does not check for invalid digits (AH through FH). Attempting to load an invalid encoding produces an undefined result. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fbld operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fldcw: aMemoryOperand "Load x87 FPU Control Word " ^ self addInstruction: #fldcw operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! and: aRegisterOrMemoryOperand with: aSource "Logical AND " ^ self addInstruction: #and operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movsxd: aDestinationRegister with: aSourceRegisterOrMemory "Move with Sign-Extension " ^ self addInstruction: #movsxd operands: { aDestinationRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovna: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovna operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovo: aRegister with: aSourceRegisterOrMemory "Conditional Move - overflow (OF=1) " ^ self addInstruction: #cmovo operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcomip: aX87Register "Compare Floating Point Values and Set EFLAGS and Pop " ^ self addInstruction: #fcomip operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! AH "A 8bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ AH! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'CamilloBruni 4/25/2012 14:23'! addInstruction: sel operands: operands ^ self addInstruction: sel description: (self instructionDesciptions at: sel) operands: operands ! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovne: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovne operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fild: aMemoryOperand "Load Integer Pseudo Code ----------- TOP = TOP - 1; ST(0) = ConvertToDoubleExtendedPrecisionFP(SRC); Description ----------- Converts the signed-integer source operand into double extended-precision floating-point format and pushes the value onto the FPU register stack. The source operand can be a word, doubleword, or quadword integer. It is loaded without rounding errors. The sign of the source operand is preserved. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fild operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! bts: aDestinationRegisterOrMemory with: aSourceRegisterOrImmediate "Bit Test and Set Pseudo Code ----------- CF = Bit(BitBase, BitOffset); Bit(BitBase, BitOffset) = 1; Description ----------- Selects the bit in a bit string (specified with the first operand, called the bit base) at the bit-position designated by the bit offset operand (second operand), stores the value of the bit in the CF flag, and sets the selected bit in the bit string to 1. The bit base operand can be a register or a memory location; the bit offset operand can be a register or an immediate value: - If the bit base operand specifies a register, the instruction takes the modulo 16, 32, or 64 of the bit offset operand (modulo size depends on the mode and register size; 64-bit operands are available only in 64-bit mode). This allows any bit position to be selected. - If the bit base operand specifies a memory location, the operand represents the address of the byte in memory that contains the bit base (bit 0 of the specified byte) of the bit string. The range of the bit position that can be referenced by the offset operand depends on the operand size. See also: Bit(BitBase, BitOffset) on page 3-11. Some assemblers support immediate bit offsets larger than 31 by using the immediate bit offset field in combination with the displacement field of the memory operand. See 'BT—Bit Test' in this chapter for more information on this addressingmechanism. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #bts operands: { aDestinationRegisterOrMemory . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovb: aRegister with: aSourceRegisterOrMemory "Conditional Move - below/not above or equal/carry (CF=1) " ^ self addInstruction: #cmovb operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'testing' stamp: ''! isLabelUsed: aLabel | used | used := false. instructions do: [:instr | used := used or: [instr isLabelUsed: aLabel ] ]. ^ used! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM3 "An SSE register" ^ XMM3! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! pop: aRegisterOrMemoryDestination "Pop a Value from the Stack Description ----------- Loads the value from the top of the stack to the location specified with the destination operand (or explicit opcode) and then increments the stack pointer. The destination operand can be a general-purpose register, memory location, or segment register. The address-size attribute of the stack segment determines the stack pointer size (16, 32, 64 bits) and the operand-size attribute of the current code segment determines the amount the stack pointer is incremented (2, 4, 8 bytes). For example, if the address- and operand-size attributes are 32, the 32-bit ESP register (stack pointer) is incremented by 4; if they are 16, the 16-bit SP register is incremented by 2. (The B flag in the stack segment's segment descriptor determines the stack's address-size attribute, and the D flag in the current code segment's segment descriptor, along with prefixes, determines the operand-size attribute and also the address-size attribute of the destination operand.) If the destination operand is one of the segment registers DS, ES, FS, GS, or SS, the value loaded into the register must be a valid segment selector. In protected mode, popping a segment selector into a segment register automatically causes the descriptor information associated with that segment selector to be loaded into the hidden (shadow) part of the segment register and causes the selector and the descriptor information to be validated (see the 'Operation' section below). A NULL value (0000-0003) may be popped into the DS, ES, FS, or GS register without causing a general protection fault. However, any subsequent attempt to reference a segment whose corresponding segment register is loaded with a NULL value causes a general protection exception (\#GP). In this situation, no memory reference occurs and the saved value of the segment register is NULL. The POP instruction cannot pop a value into the CS register. To load the CS register from the stack, use the RET instruction. If the ESP register is used as a base register for addressing a destination operand in memory, the POP instruction computes the effective address of the operand after it increments the ESP register. For the case of a 16-bit stack where ESP wraps to 0H as a result of the POP instruction, the resulting location of the memory write is processor-family-specific. The POP ESP instruction increments the stack pointer (ESP) before data at the old top of stack is written into the destination. A POP SS instruction inhibits all interrupts, including the NMI interrupt, until after execution of the next instruction. This action allows sequential execution of POP SS and MOV ESP, EBP instructions without the danger of having an invalid stack during an interrupt1. However, use of the LSS instruction is the preferred method of loading the SS and ESP registers. In 64-bit mode, using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). When in 64-bit mode, POPs using 32-bit operands are not encodable and POPs to DS, ES, SS are not valid. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #pop operands: { aRegisterOrMemoryDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! rcl: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Rotate " ^ self addInstruction: #rcl operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnc: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovnc operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! shld: aDestinationRegisterOrMemory with: aSourceRegister with: aSourceRegisterOrImmediate "Double Precision Shift Left Description ----------- The SHLD instruction is used for multi-precision shifts of 64 bits or more. The instruction shifts the first operand (destination operand) to the left the number of bits specified by the third operand (count operand). The second operand (source operand) provides bits to shift in from the right (starting with bit 0 of the destination operand). The destination operand can be a register or a memory location; the source operand is a register. The count operand is an unsigned integer that can be stored in an immediate byte or in the CL register. If the count operand is CL, the shift count is the logical AND of CL and a count mask. In non-64-bit modes and default 64-bit mode; only bits 0 through 4 of the count are used. This masks the count to a value between 0 and 31. If a count is greater than the operand size, the result is undefined. If the count is 1 or greater, the CF flag is filled with the last bit shifted out of the destination operand. For a 1-bit shift, the OF flag is set if a sign change occurred; otherwise, it is cleared. If the count operand is 0, flags are not affected. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits (upgrading the count mask to 6 bits). See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #shld operands: { aDestinationRegisterOrMemory . aSourceRegister . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 3/28/2012 14:43'! reg8: index "answer one of 8bit general-purpose registers, based on index" index < 0 ifTrue: [ self invalidRegisterIndex ]. (index >= self numGPRegisters) ifTrue: [ self invalidRegisterIndex ]. ^ AJx86Registers code: index! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jle: targetLabel "Jump short if less or equal/not greater ((ZF=1) OR (SF!!=OF)) " ^ self addInstruction: #jle operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'accessing' stamp: ''! reg: index size: nBytes nBytes = 1 ifTrue: [ ^ self reg8: index ]. nBytes = 2 ifTrue: [ ^ self reg16: index ]. nBytes = 4 ifTrue: [ ^ self reg32: index ]. nBytes = 8 ifTrue: [ ^ self reg64: index ]. self error: 'invalid register size'.! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movntpd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Store Packed Double-FP Values Using Non-Temporal Hint Pseudo Code ----------- DEST = SRC; Description ----------- Moves the double quadword in the source operand (second operand) to the destination operand (first operand) using a non-temporal hint to minimize cache pollution during the write to memory. The source operand is an XMM register, which is assumed to contain two packed double-precision floating-point values. The destination operand is a 128-bit memory location. The non-temporal hint is implemented by using a write combining (WC) memory type protocol when writing the data to memory. Using this protocol, the processor does not write the data into the cache hierarchy, nor does it fetch the corresponding cache line from memory into the cache hierarchy. The memory type of the region being written to can override the non-temporal hint, if the memory address specified for the non-temporal store is in an uncacheable (UC) or write protected (WP) memory region. For more information on non-temporal stores, see 'Caching of Temporal vs. Non-Temporal Data' in Chapter 10 in theIntel®64 and IA-32 Architectures Software Developer's Manual, Volume 1. Because the WC protocol uses a weakly-ordered memory consistency model, a fencing operation implemented with the SFENCE or MFENCE instruction should be used in conjunction with MOVNTPD instructions if multiple processors might use different memory types to read/write the destination memory locations. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movntpd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! SP "A 16bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ SP! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! btr: aDestinationRegisterOrMemory with: aSourceRegisterOrImmediate "Bit Test and Reset Pseudo Code ----------- CF = Bit(BitBase, BitOffset); Bit(BitBase, BitOffset) = 0; Description ----------- Selects the bit in a bit string (specified with the first operand, called the bit base) at the bit-position designated by the bit offset operand (second operand), stores the value of the bit in the CF flag, and clears the selected bit in the bit string to 0. The bit base operand can be a register or a memory location; the bit offset operand can be a register or an immediate value: - If the bit base operand specifies a register, the instruction takes the modulo 16, 32, or 64 of the bit offset operand (modulo size depends on the mode and register size; 64-bit operands are available only in 64-bit mode). This allows any bit position to be selected. - If the bit base operand specifies a memory location, the operand represents the address of the byte in memory that contains the bit base (bit 0 of the specified byte) of the bit string. The range of the bit position that can be referenced by the offset operand depends on the operand size. See also: Bit(BitBase, BitOffset) on page 3-11. Some assemblers support immediate bit offsets larger than 31 by using the immediate bit offset field in combination with the displacement field of the memory operand. See 'BT—Bit Test' in this chapter for more information on this addressingmechanism. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #btr operands: { aDestinationRegisterOrMemory . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcom: aX87Register1 with: aX87Register2 " see #fcom" ^ self addInstruction: #fcom operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fucomi: aX87Register "Unordered Compare Floating Point Values and Set EFLAGS " ^ self addInstruction: #fucomi operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movdq2q: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Quadword from XMM to MMX Technology Register Pseudo Code ----------- DEST = SRC[63:0]; Description ----------- Moves the low quadword from the source operand (second operand) to the destination operand (first operand). The source operand is an XMM register and the destination operand is an MMX technology register. This instruction causes a transition from x87 FPU to MMX technology operation (that is, the x87 FPU top-of-stack pointer is set to 0 and the x87 FPU tag word is set to all 0s [valid]). If this instruction is executed while an x87 FPU floating-point exception is pending, the exception is handled before the MOVDQ2Q instruction is executed. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movdq2q operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovs: aRegister with: aSourceRegisterOrMemory "Conditional Move - sign (SF=1) " ^ self addInstruction: #cmovs operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'function calls' stamp: ''! performingCall: ci in: aBlock ci asm: self; alignmentInsertionPoint: last. aBlock value: ci. self callCleanup: ci.! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movlhps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Packed Single-FP Values Low to High Pseudo Code ----------- DEST[127:64] = SRC[63:0]; (* DEST[63:0] unchanged *) Description ----------- Moves two packed single-precision floating-point values from the low quadword of the source operand (second operand) to the high quadword of the destination operand (first operand). The low quadword of the destination operand is left unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movlhps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST5 "A floating point register" ^ ST5! ! !AJx86Assembler methodsFor: 'instruction list' stamp: ''! insert: newInstruction before: anInstruction "insert one or more instructions before an instruction" ^ instructions := instructions insert: newInstruction before: anInstruction! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movPtr: aRegisterOrImmedate1 with: aRegisterOrImmedate2 " " ^ self addInstruction: #movPtr operands: { aRegisterOrImmedate1 . aRegisterOrImmedate2 }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST3 "A floating point register" ^ ST3! ! !AJx86Assembler methodsFor: 'alignment' stamp: ''! alignQuad self addInstruction: AJAlignmentInstruction alignQuad! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcomp: aX87Register1 with: aX87Register2 " see #fcomp" ^ self addInstruction: #fcomp operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! shrd: aDestinationRegisterOrMemory with: aSourceRegister with: aSourceRegisterOrImmediate "Double Precision Shift Right Description ----------- The SHRD instruction is useful for multi-precision shifts of 64 bits or more. The instruction shifts the first operand (destination operand) to the right the number of bits specified by the third operand (count operand). The second operand (source operand) provides bits to shift in from the left (starting with the most significant bit of the destination operand). The destination operand can be a register or a memory location; the source operand is a register. The count operand is an unsigned integer that can be stored in an immediate byte or the CL register. If the count operand is CL, the shift count is the logical AND of CL and a count mask. In non-64-bit modes and default 64-bit mode, the width of the count mask is 5 bits. Only bits 0 through 4 of the count register are used (masking the count to a value between 0 and 31). If the count is greater than the operand size, the result is undefined. If the count is 1 or greater, the CF flag is filled with the last bit shifted out of the destination operand. For a 1-bit shift, the OF flag is set if a sign change occurred; otherwise, it is cleared. If the count operand is 0, flags are not affected. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits (upgrading the count mask to 6 bits). See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #shrd operands: { aDestinationRegisterOrMemory . aSourceRegister . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fist: aMemoryOperand "Store Integer " ^ self addInstruction: #fist operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CX "A 16bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ CX! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ret: anImmediate " " ^ self addInstruction: #ret operands: { anImmediate }! ! !AJx86Assembler methodsFor: 'stack management' stamp: 'MartinMcClure 2/9/2013 14:25'! stackFrameValueAtOffset: offset ^ EBP ptr32 - offset! ! !AJx86Assembler methodsFor: 'function calls' stamp: ''! callCleanup: anAJCdeclCallInfo ^ self addInstruction: (AJCallCleanup new callInfo: anAJCdeclCallInfo )! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jl: targetLabel "Jump short if less/not greater (SF!!=OF) " ^ self addInstruction: #jl operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ficomp: aMemoryOperand "Compare Integer and Pop " ^ self addInstruction: #ficomp operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fld: aMemoryOrX87Register "Load Floating Point Value Description ----------- Pushes the source operand onto the FPU register stack. The source operand can be in single-precision, double-precision, or double extended-precision floating-point format. If the source operand is in single-precision or double-precision floating-point format, it is automatically converted to the double extended-precision floating-point format before being pushed on the stack. The FLD instruction can also push the value in a selected FPU register [ST(i)] onto the stack. Here, pushing register ST(0) duplicates the stack top. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fld operands: { aMemoryOrX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fbstp: aMemoryOperand "Store BCD Integer and Pop Pseudo Code ----------- DEST = BCD(ST(0)); PopRegisterStack; Description ----------- Converts the value in the ST(0) register to an 18-digit packed BCD integer, stores the result in the destination operand, and pops the register stack. If the source value is a non-integral value, it is rounded to an integer value, according to rounding mode specified by the RC field of the FPU control word. To pop the register stack, the processor marks the ST(0) register as empty and increments the stack pointer (TOP) by 1. The destination operand specifies the address where the first byte destination value is to be stored. The BCD value (including its sign bit) requires 10 bytes of space in memory. The following table shows the results obtained when storing various classes of numbers in packed BCD format. ST(0) DEST ---------------------------------------- ------ - = or Value Too Large for DEST Format \* F \<= - 1 - D -1 \< F \< -0 \*\* - 0 - 0 + 0 + 0 + 0 \< F \< +1 \*\* F \>= +1 + D + = or Value Too Large for DEST Format \* NaN \* : FBSTP Results - Notes: - F refers to a finite floating-point value. - D refers to packed-BCD number. - \* Indicates floating-point invalid-operation (\#IA) exception. - \*\* ±0 or ±1, depending on the rounding mode. If the converted value is too large for the destination format, or if the source operand is an ∞, SNaN, QNAN, or is in an unsupported format, an invalid-arithmetic-operand condition is signaled. If the invalid-operation exception is not masked, an invalidarithmetic-operand exception (\#IA) is generated and no value is stored in the desti-nation operand. If the invalid-operation exception is masked, the packed BCD indefinite value is stored in memory. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fbstp operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jpe: targetLabel " " ^ self addInstruction: #jpe operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ECX "A 32bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ ECX! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movnti: aRegisterOrMemory1 with: aRegisterOrMemory2 "Store Doubleword Using Non-Temporal Hint Pseudo Code ----------- DEST = SRC; Description ----------- Moves the doubleword integer in the source operand (second operand) to the destination operand (first operand) using a non-temporal hint to minimize cache pollution during the write to memory. The source operand is a general-purpose register. The destination operand is a 32-bit memory location. The non-temporal hint is implemented by using a write combining (WC) memory type protocol when writing the data to memory. Using this protocol, the processor does not write the data into the cache hierarchy, nor does it fetch the corresponding cache line from memory into the cache hierarchy. The memory type of the region being written to can override the non-temporal hint, if the memory address specified for the non-temporal store is in an uncacheable (UC) or write protected (WP) memory region. For more information on non-temporal stores, see 'Caching of Temporal vs. Non-Temporal Data' in Chapter 10 in theIntel®64 and IA-32 Architectures Software Developer's Manual, Volume 1. Because the WC protocol uses a weakly-ordered memory consistency model, a fencing operation implemented with the SFENCE or MFENCE instruction should be used in conjunction with MOVNTI instructions if multiple processors might use different memory types to read/write the destination memory locations. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #movnti operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'convenience' stamp: ''! movsx: src to: dest "Ensure right src/dest order" ^ self movsx: dest with: src! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 3/28/2012 14:43'! reg32: index "answer one of 32bit general-purpose registers, based on index" | code | index < 0 ifTrue: [ self invalidRegisterIndex ]. (index >= self numGPRegisters) ifTrue: [ self invalidRegisterIndex ]. code := 16r20 + index. ^ AJx86Registers code: code! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! sub: aRegisterOrMemoryOperand with: aSource "Subtract Pseudo Code ----------- DEST = (DEST - SRC); Description ----------- Subtracts the second operand (source operand) from the first operand (destination operand) and stores the result in the destination operand. The destination operand can be a register or a memory location; the source operand can be an immediate, register, or memory location. (However, two memory operands cannot be used in one instruction.) When an immediate value is used as an operand, it is sign-extended to the length of the destination operand format. The SUB instruction performs integer subtraction. It evaluates the result for both signed and unsigned integer operands and sets the OF and CF flags to indicate an overflow in the signed or unsigned result, respectively. The SF flag indicates the sign of the signed result. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. " ^ self addInstruction: #sub operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! div: aDestination "Unsigned Divide Description ----------- Divides unsigned the value in the AX, DX:AX, EDX:EAX, or RDX:RAX registers (dividend) by the source operand (divisor) and stores the result in the AX (AH:AL), DX:AX, EDX:EAX, or RDX:RAX registers. The source operand can be a general-purpose register or a memory location. The action of this instruction depends on the operand size (dividend/divisor). Division using 64-bit operand is available only in 64-bit mode. Non-integral results are truncated (chopped) towards 0. The remainder is always less than the divisor in magnitude. Overflow is indicated with the \#DE (divide error) exception rather than with the CF flag. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. In 64-bit mode when REX.W is applied, the instruction divides the unsigned value in RDX:RAX by the source operand and stores the quotient in RAX, the remainder in RDX. See the summary chart at the beginning of this section for encoding data and limits. See the following table. DIV Action Maximum Operand Size Dividend Divisor Quotient Remainder Quotient Word/byte AX r/m8 AL AH 255 Doubleword/word DX:AX r/m16 AX DX 65,535 Quadword/doubleword EDX:EAX r/m32 EAX EDX 2^32^ - 1 Doublequadword/quadword RDX:RAX r/m64 RAX RDX 2^64^ - 1 " ^ self addInstruction: #div operands: { aDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! frstor: aMemoryOperand "Restore x87 FPU State Description ----------- Loads the FPU state (operating environment and register stack) from the memory area specified with the source operand. This state data is typically written to the specified memory location by a previous FSAVE/FNSAVE instruction. The FPU operating environment consists of the FPU control word, status word, tag word, instruction pointer, data pointer, and last opcode. Figures 8-9 through 8-12 in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, show the layout in memory of the stored environment, depending on the operating mode of the processor (protected or real) and the current operand-size attribute (16-bit or 32-bit). In virtual-8086 mode, the real mode layouts are used. The contents of the FPU register stack are stored in the 80 bytes immediately following the operating environment image. The FRSTOR instruction should be executed in the same operating mode as the corresponding FSAVE/FNSAVE instruction. If one or more unmasked exception bits are set in the new FPU status word, a floating-point exception will be generated. To avoid raising exceptions when loading a new operating environment, clear all the exception flags in the FPU status word that is being loaded. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #frstor operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jge: targetLabel " " ^ self addInstruction: #jge operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdivp: aX87Register "Divide and Pop " ^ self addInstruction: #fdivp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jng: targetLabel " " ^ self addInstruction: #jng operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdivr: aX87Register1 with: aX87Register2 " see #fdivr" ^ self addInstruction: #fdivr operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'debugging' stamp: 'IgorStasenko 5/28/2012 02:25'! writeCodeToFile: aFileName aFileName asReference asReference delete writeStreamDo: [:s| s nextPutAll: self bytes ] ! ! !AJx86Assembler methodsFor: 'accessing' stamp: ''! stackManager: aStackManager stackManager := aStackManager ! ! !AJx86Assembler methodsFor: 'convenience' stamp: ''! db: aByteValue ^ self addInstruction: (AJData byte: aByteValue)! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! imul: aRegister with: aRegisterOrMemoryOrImmediate " see #imul" ^ self addInstruction: #imul operands: { aRegister . aRegisterOrMemoryOrImmediate }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EDI "A 32bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ EDI! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jns: targetLabel "Jump short if not sign (SF=0) " ^ self addInstruction: #jns operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'register' stamp: ''! instructionPointer "not available on 32bit x86 CPUs" self notYetImplemented ! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovb: aX87Register "FP Conditional Move - below (CF=1) " ^ self addInstruction: #fcmovb operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'labels' stamp: 'CamilloBruni 5/29/2012 13:15'! label: aNameOrLabel ^ self label: aNameOrLabel ifPresent: [ self error: 'label ', aNameOrLabel asString, ' already set' ].! ! !AJx86Assembler methodsFor: 'instruction list' stamp: ''! insert: i after: instruction | next | i ifNil: [ "nothing to insert" ^ self ]. i do: [:each | each increaseLevel: instruction level ]. next := instruction next. instruction next: i. i last next: next! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movdqa: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Aligned Double Quadword Pseudo Code ----------- DEST = SRC; (* #GP if SRC or DEST unaligned memory operand *) Description ----------- Moves a double quadword from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, to store the contents of an XMM register into a 128-bit memory location, or to move data between two XMM registers. When the source or destination operand is a memory operand, the operand must be aligned on a 16-byte boundary or a general-protection exception (\#GP) will be generated. To move a double quadword to or from unaligned memory locations, use the MOVDQU instruction. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movdqa operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'code generation' stamp: ''! prepareInstructions "A final step before generating machine code: prepare instructions by injecting a stack alignment and reifying jump labels. Prepared instructions will contain machine code, ready for use " instructions := stackManager analyzeInstructions: instructions assembler: self. instructions emitCodeAtOffset: 0 assembler: self. ^ instructions! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movlps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Low Packed Single-FP Values Pseudo Code ----------- (* MOVLPD instruction for memory to XMM move *) DEST[63:0] = SRC; (* DEST[127:64] unchanged *) (* MOVLPD instruction for XMM to memory move *) DEST = SRC[63:0]; Description ----------- Moves two packed single-precision floating-point values from the source operand (second operand) and the destination operand (first operand). The source and destination operands can be an XMM register or a 64-bit memory location. This instruction allows two single-precision floating-point values to be moved to and from the low quadword of an XMM register and memory. It cannot be used for register to register or memory to memory moves. When the destination operand is an XMM register, the high quadword of the register remains unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movlps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jp: targetLabel "Jump short if parity/parity even (PF=1) " ^ self addInstruction: #jp operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'IgorStasenko 8/13/2013 13:39'! newInstruction: name description: description operands: operands "check if name is jump " description isJump ifTrue: [ ^ self newJumpInstruction: name description: description operands: operands ]. ^ self newInstruction name: name; description: description; operands: operands; checkOperandsForConflict "Cannot check that at construction stage. Some operands may not be resolved yet (as AJReserveTemp) checkOperandsForConflict "! ! !AJx86Assembler methodsFor: 'register' stamp: ''! destinationIndex ^ self is32BitMode ifTrue: [ EDI ] ifFalse: [ DI ]! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movntq: aRegisterOrMemory1 with: aRegisterOrMemory2 "Store of Quadword Using Non-Temporal Hint Pseudo Code ----------- DEST = SRC; Description ----------- Moves the quadword in the source operand (second operand) to the destination operand (first operand) using a non-temporal hint to minimize cache pollution during the write to memory. The source operand is an MMX technology register, which is assumed to contain packed integer data (packed bytes, words, or doublewords). The destination operand is a 64-bit memory location. The non-temporal hint is implemented by using a write combining (WC) memory type protocol when writing the data to memory. Using this protocol, the processor does not write the data into the cache hierarchy, nor does it fetch the corresponding cache line from memory into the cache hierarchy. The memory type of the region being written to can override the non-temporal hint, if the memory address specified for the non-temporal store is in an uncacheable (UC) or write protected (WP) memory region. For more information on non-temporal stores, see 'Caching of Temporal vs. Non-Temporal Data' in Chapter 10 in theIntel®64 and IA-32 Architectures Software Developer's Manual, Volume 1. Because the WC protocol uses a weakly-ordered memory consistency model, a fencing operation implemented with the SFENCE or MFENCE instruction should be used in conjunction with MOVNTQ instructions if multiple processors might use different memory types to read/write the destination memory locations. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #movntq operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmp: aRegisterOrMemoryOperand with: aSource "Compare Two Operands Pseudo Code ----------- temp = SRC1 - SignExtend(SRC2); ModifyStatusFlags; (* Modify status flags in the same manner as the SUB instruction *) Description ----------- Compares the first source operand with the second source operand and sets the status flags in the EFLAGS register according to the results. The comparison is performed by subtracting the second operand from the first operand and then setting the status flags in the same manner as the SUB instruction. When an immediate value is used as an operand, it is sign-extended to the length of the first operand. The condition codes used by the Jcc, CMOVcc, and SETcc instructions are based on the results of a CMP instruction. Appendix B, 'EFLAGS Condition Codes,' in theIntel® 64 and IA-32 Architectures Software Developer's Manual, Volume 1, shows the relationship of the status flags and the condition codes. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #cmp operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! or: aRegisterOrMemoryOperand with: aSource "Logical Inclusive OR Pseudo Code ----------- DEST = DEST OR SRC; Description ----------- Performs a bitwise inclusive OR operation between the destination (first) and source (second) operands and stores the result in the destination operand location. The source operand can be an immediate, a register, or a memory location; the destination operand can be a register or a memory location. (However, two memory operands cannot be used in one instruction.) Each bit of the result of the OR instruction is set to 0 if both corresponding bits of the first and second operands are 0; otherwise, each bit is set to 1. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #or operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movsx: aDestinationRegister with: aSourceRegisterOrMemory "Move with Sign-Extension " ^ self addInstruction: #movsx operands: { aDestinationRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fiadd: aMemoryOperand "Add " ^ self addInstruction: #fiadd operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! BP "A 16bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ BP! ! !AJx86Assembler methodsFor: 'function calls' stamp: ''! pushArgument: anArgument forCall: call | arg argSize | arg := anArgument. anArgument isInteger ifTrue: [ arg := anArgument asImm size: call defaultArgumentSize. ]. self addInstruction: (AJCallArgument new size: arg stackSize; callInfo: call ). arg emitPushOnStack: self! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM5 "An SSE register" ^ XMM5! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ja: targetLabel " " ^ self addInstruction: #ja operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM0 "An MMX register" ^ MM0! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM6 "An SSE register" ^ XMM6! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fadd: aX87Register1 with: aX87Register2 " see #fadd" ^ self addInstruction: #fadd operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fnstcw: aMemoryOperand "Store x87 FPU Control Word " ^ self addInstruction: #fnstcw operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovno: aRegister with: aSourceRegisterOrMemory "Conditional Move - not overflow (OF=0) " ^ self addInstruction: #cmovno operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fxch: aX87Register "Exchange Register Contents Description ----------- Exchanges the contents of registers ST(0) and ST(i). If no source operand is specified, the contents of ST(0) and ST(1) are exchanged. This instruction provides a simple means of moving values in the FPU register stack to the top of the stack [ST(0)], so that they can be operated on by those floating-point instructions that can only operate on values in ST(0). For example, the following instruction sequence takes the square root of the third register from the top of the register stack: FXCH ST(3); FSQRT; FXCH ST(3); This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fxch operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! bsr: aRegister with: aSourceRegisterOrMemory "Bit Scan Reverse Description ----------- Searches the source operand (second operand) for the most significant set bit (1 bit). If a most significant 1 bit is found, its bit index is stored in the destination operand (first operand). The source operand can be a register or a memory location; the destination operand is a register. The bit index is an unsigned offset from bit 0 of the source operand. If the content source operand is 0, the content of the destination operand is undefined. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #bsr operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! inc: aRegisterOrMemory "Increment by 1 Pseudo Code ----------- DEST = DEST + 1; AFlags Affected The CF flag is not affected. The OF, SF, ZF, AF, and PF flags are set according to the result. Description ----------- Adds 1 to the destination operand, while preserving the state of the CF flag. The destination operand can be a register or a memory location. This instruction allows a loop counter to be updated without disturbing the CF flag. (Use a ADD instruction with an immediate operand of 1 to perform an increment operation that does updates the CF flag.) This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, INC r16 and INC r32 are not encodable (because opcodes 40H through 47H are REX prefixes). Otherwise, the instruction's 64-bit mode default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. " ^ self addInstruction: #inc operands: { aRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 3/28/2012 14:43'! reg16: index "answer one of 16bit general-purpose registers, based on index" | code | index < 0 ifTrue: [ self invalidRegisterIndex ]. (index >= self numGPRegisters) ifTrue: [ self invalidRegisterIndex ]. code := 16r10 + index. ^ AJx86Registers code: code! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnl: aRegister with: aSourceRegisterOrMemory "Conditional Move - not less/greater or equal (SF=OF) " ^ self addInstruction: #cmovnl operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! enter: stackFrameSize with: lexicalNesting "Make Stack Frame for Procedure Parameters Description ----------- Creates a stack frame for a procedure. The first operand (size operand) specifies the size of the stack frame (that is, the number of bytes of dynamic storage allocated on the stack for the procedure). The second operand (nesting level operand) gives the lexical nesting level (0 to 31) of the procedure. The nesting level determines the number of stack frame pointers that are copied into the 'display area' of the new stack frame from the preceding frame. Both of these operands are immediate values. The stack-size attribute determines whether the BP (16 bits), EBP (32 bits), or RBP (64 bits) register specifies the current frame pointer and whether SP (16 bits), ESP (32 bits), or RSP (64 bits) specifies the stack pointer. In 64-bit mode, stack-size attribute is always 64-bits. The ENTER and companion LEAVE instructions are provided to support block structured languages. The ENTER instruction (when used) is typically the first instruction in a procedure and is used to set up a new stack frame for a procedure. The LEAVE instruction is then used at the end of the procedure (just before the RET instruction) to release the stack frame. If the nesting level is 0, the processor pushes the frame pointer from the BP/EBP/RBP register onto the stack, copies the current stack pointer from the SP/ESP/RSP register into the BP/EBP/RBP register, and loads the SP/ESP/RSP register with the current stack-pointer value minus the value in the size operand. For nesting levels of 1 or greater, the processor pushes additional frame pointers on the stack before adjusting the stack pointer. These additional frame pointers provide the called procedure with access points to other nested frames on the stack. See 'Procedure Calls for Block-Structured Languages' in Chapter 6 of theIntel®64 and IA-32 ArchitecturesSoftware Developer's Manual, Volume 1, for more information about the actions of the ENTER instruction. The ENTER instruction causes a page fault whenever a write using the final value of the stack pointer (within the current stack segment) would do so. In 64-bit mode, default operation size is 64 bits; 32-bit operation size cannot be encoded. " ^ self addInstruction: #enter operands: { stackFrameSize . lexicalNesting }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EDX "A 32bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ EDX! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CH "A 8bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ CH! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movlpd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Low Packed Double-FP Value Pseudo Code ----------- (* MOVLPD instruction for memory to XMM move *) DEST[63:0] = SRC; (* DEST[127:64] unchanged *) (* MOVLPD instruction for XMM to memory move *) DEST = SRC[63:0]; Description ----------- Moves a double-precision floating-point value from the source operand (second operand) to the destination operand (first operand). The source and destination operands can be an XMM register or a 64-bit memory location. This instruction allows a double-precision floating-point value to be moved to and from the low quadword of an XMM register and memory. It cannot be used for register to register or memory to memory moves. When the destination operand is an XMM register, the high quad-word of the register remains unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movlpd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 8/22/2012 14:26'! newJumpInstruction ^ AJx86JumpInstruction new! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movss: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Scalar Single-FP Values Description ----------- Moves a scalar single-precision floating-point value from the source operand (second operand) to the destination operand (first operand). The source and destination operands can be XMM registers or 32-bit memory locations. This instruction can be used to move a single-precision floating-point value to and from the low doubleword of an XMM register and a 32-bit memory location, or to move a single-precision floating-point value between the low doublewords of two XMM registers. The instruction cannot be used to transfer data between memory locations. When the source and destination operands are XMM registers, the three high-order doublewords of the destination operand remain unchanged. When the source operand is a memory location and destination operand is an XMM registers, the three high-order doublewords of the destination operand are cleared to all 0s. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movss operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EBP "A 32bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ EBP! ! !AJx86Assembler methodsFor: 'register' stamp: ''! sourceIndex ^ self is32BitMode ifTrue: [ RSI ] ifFalse: [ SI ]! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! xor: aRegisterOrMemoryOperand with: aSource "Logical Exclusive OR Pseudo Code ----------- DEST = DEST XOR SRC; Description ----------- Performs a bitwise exclusive OR (XOR) operation on the destination (first) and source (second) operands and stores the result in the destination operand location. The source operand can be an immediate, a register, or a memory location; the destination operand can be a register or a memory location. (However, two memory operands cannot be used in one instruction.) Each bit of the result is 1 if the corresponding bits of the operands are different; each bit is 0 if the corresponding bits are the same. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #xor operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fstenv: aMemoryOperand "Store x87 FPU Environment " ^ self addInstruction: #fstenv operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM1 "An MMX register" ^ MM1! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jb: targetLabel "Jump short if below/not above or equal/carry (CF=1) " ^ self addInstruction: #jb operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM2 "An MMX register" ^ MM2! ! !AJx86Assembler methodsFor: 'convenience' stamp: 'IgorStasenko 5/26/2012 15:14'! mov: src to: dest "Ensure right src/dest order" src = dest ifTrue: [ ^ self ]. "do not if source and dest are same " ^ self mov: dest with: src! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jna: targetLabel " " ^ self addInstruction: #jna operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! mul: aDestination "Unsigned Multiply Description ----------- Performs an unsigned multiplication of the first operand (destination operand) and the second operand (source operand) and stores the result in the destination operand. The destination operand is an implied operand located in register AL, AX or EAX (depending on the size of the operand); the source operand is located in a general-purpose register or a memory location. The action of this instruction and the location of the result depends on the opcode and the operand size as shown in the following table. The result is stored in register AX, register pair DX:AX, or register pair EDX:EAX (depending on the operand size), with the high-order bits of the product contained in register AH, DX, or EDX, respectively. If the high-order bits of the product are 0, the CF and OF flags are cleared; otherwise, the flags are set. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8 - R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. Operand Size Source 1 Source 2 Destination -------------- ---------- ---------- ------------- Byte AL r/m8 AX Word AX r/m16 DX:AX Doubleword EAX r/m32 EDX:EAX Quadword RAX r/m64 RDX:RAX : MUL Results " ^ self addInstruction: #mul operands: { aDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsub: aX87Register1 with: aX87Register2 " see #fsub" ^ self addInstruction: #fsub operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! push: aSource "Push Word, Doubleword or Quadword Onto the Stack " ^ self addInstruction: #push operands: { aSource }! ! !AJx86Assembler methodsFor: 'stack management' stamp: ''! reserveExtraBytesOnStack: numBytes ^ stackManager reserveExtraBytesOnStack: numBytes ! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fstp: aMemoryOrX87Register "Store Floating Point Value and Pop " ^ self addInstruction: #fstp operands: { aMemoryOrX87Register }! ! !AJx86Assembler methodsFor: 'stack management' stamp: ''! reserveTemp ^ self addInstruction: (AJReserveTemp new size: self wordSize). ! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! crc32: aRegister with: aSourceRegisterOrMemory "Accumulate CRC32 Value Description ----------- Starting with an initial value in the first operand (destination operand), accumulates a CRC32 (polynomial 0x11EDC6F41) value for the second operand (source operand) and stores the result in the destination operand. The source operand can be a register or a memory location. The destination operand must be an r32 or r64 register. If the destination is an r64 register, then the 32-bit result is stored in the least significant double word and 00000000H is stored in the most significant double word of the r64 register. The initial value supplied in the destination operand is a double word integer stored in the r32 register or the least significant double word of the r64 register. To incrementally accumulate a CRC32 value, software retains the result of the previous CRC32 operation in the destination operand, then executes the CRC32 instruction again with new input data in the source operand. Data contained in the source operand is processed in reflected bit order. This means that the most significant bit of the source operand is treated as the least significant bit of the quotient, and so on, for all the bits of the source operand. Likewise, the result of the CRC operation is stored in the destination operand in reflected bit order. This means that the most significant bit of the resulting CRC (bit 31) is stored in the least significant bit of the destination operand (bit 0), and so on, for all the bits of the CRC. " ^ self addInstruction: #crc32 operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! stmxcsr: aMemoryOperand "Store MXCSR Register State Pseudo Code ----------- m32 = MXCSR; Description ----------- Stores the contents of the MXCSR control and status register to the destination operand. The destination operand is a 32-bit memory location. The reserved bits in the MXCSR register are stored as 0s. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #stmxcsr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! xadd: aDestinationRegisterOrMemory with: aSourceRegister "Exchange and Add Pseudo Code ----------- TEMP = SRC + DEST; SRC = DEST; DEST = TEMP; Description ----------- Exchanges the first operand (destination operand) with the second operand (source operand), then loads the sum of the two values into the destination operand. The destination operand can be a register or a memory location; the source operand is a register. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. " ^ self addInstruction: #xadd operands: { aDestinationRegisterOrMemory . aSourceRegister }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! bswap: aDestinationRegister "Byte Swap Description ----------- Reverses the byte order of a 32-bit or 64-bit (destination) register. This instruction is provided for converting little-endian values to big-endian format and vice versa. To swap bytes in a word value (16-bit register), use the XCHG instruction. When the BSWAP instruction references a 16-bit register, the result is undefined. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. IA-32 Architecture Legacy Compatibility The BSWAP instruction is not supported on IA-32 processors earlier than the Intel486™ processor family. For compatibility with this instruction, software should include functionally equivalent code for execution on Intel processors earlier than the Intel486 processor family. " ^ self addInstruction: #bswap operands: { aDestinationRegister }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnp: aRegister with: aSourceRegisterOrMemory "Conditional Move - not parity/parity odd " ^ self addInstruction: #cmovnp operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsave: aMemoryOperand "Store x87 FPU State " ^ self addInstruction: #fsave operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ldmxcsr: aMemoryOperand "Load MXCSR Register Pseudo Code ----------- MXCSR = m32; C/C++ Compiler Intrinsic Equivalent _mm_setcsr(unsigned int i) Description ----------- Loads the source operand into the MXCSR control/status register. The source operand is a 32-bit memory location. See 'MXCSR Control and Status Register' in Chapter 10, of theIntel®64 and IA-32 Architectures Software Developer's Manual,Volume 1, for a description of the MXCSR register and its contents. The LDMXCSR instruction is typically used in conjunction with the STMXCSR instruction, which stores the contents of the MXCSR register in memory. The default MXCSR value at reset is 1F80H. If a LDMXCSR instruction clears a SIMD floating-point exception mask bit and sets the corresponding exception flag bit, a SIMD floating-point exception will not be immediately generated. The exception will be generated only upon the execution of the next SSE or SSE2 instruction that causes that particular SIMD floating-point exception to be reported. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #ldmxcsr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcom: aMemoryOperand "Compare Real " ^ self addInstruction: #fcom operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcomp: aMemoryOperand "Compare Real and Pop " ^ self addInstruction: #fcomp operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movaps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Aligned Packed Single-FP Values Pseudo Code ----------- DEST = SRC; (* #GP if SRC or DEST unaligned memory operand *) Description ----------- Moves a double quadword containing four packed single-precision floating-point values from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, to store the contents of an XMM register into a 128-bit memory location, or to move data between two XMM registers. When the source or destination operand is a memory operand, the operand must be aligned on a 16-byte boundary or a general-protection exception (\#GP) is generated. To move packed single-precision floating-point values to or from unaligned memory locations, use the MOVUPS instruction. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movaps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'function calls' stamp: ''! noticePush: numBytes forCall: aCallInfo self addInstruction: (AJCallArgument new size: numBytes; callInfo: aCallInfo ). ! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! xchg: aDestinationRegisterOrMemory with: aSourceRegister "Exchange Register/Memory with Register Pseudo Code ----------- TEMP = DEST; DEST = SRC; SRC = TEMP; Description ----------- Exchanges the contents of the destination (first) and source (second) operands. The operands can be two general-purpose registers or a register and a memory location. If a memory operand is referenced, the processor's locking protocol is automatically implemented for the duration of the exchange operation, regardless of the presence or absence of the LOCK prefix or of the value of the IOPL. (See the LOCK prefix description in this chapter for more information on the locking protocol.) This instruction is useful for implementing semaphores or similar data structures for process synchronization. (See 'Bus Locking' in Chapter 8 of theIntel® 64 and IA-32Architectures Software Developer's Manual, Volume 3A, for more information on bus locking.) The XCHG instruction can also be used instead of the BSWAP instruction for 16-bit operands. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #xchg operands: { aDestinationRegisterOrMemory . aSourceRegister }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! je: targetLabel " " ^ self addInstruction: #je operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fidivr: aMemoryOperand "Reverse Divide " ^ self addInstruction: #fidivr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movhpd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move High Packed Double-FP Value Pseudo Code ----------- (* MOVHPD instruction for memory to XMM move *) DEST[127:64] = SRC; (* DEST[63:0] unchanged *) (* MOVHPD instruction for XMM to memory move *) DEST = SRC[127:64]; Description ----------- Moves a double-precision floating-point value from the source operand (second operand) to the destination operand (first operand). The source and destination operands can be an XMM register or a 64-bit memory location. This instruction allows a double-precision floating-point value to be moved to and from the high quadword of an XMM register and memory. It cannot be used for register to register or memory to memory moves. When the destination operand is an XMM register, the low quad-word of the register remains unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movhpd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! SI "A 16bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ SI! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movntps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Store Packed Single-FP Values Using Non-Temporal Hint Pseudo Code ----------- DEST = SRC; Description ----------- Moves the double quadword in the source operand (second operand) to the destination operand (first operand) using a non-temporal hint to minimize cache pollution during the write to memory. The source operand is an XMM register, which is assumed to contain four packed single-precision floating-point values. The destination operand is a 128-bit memory location. The non-temporal hint is implemented by using a write combining (WC) memory type protocol when writing the data to memory. Using this protocol, the processor does not write the data into the cache hierarchy, nor does it fetch the corresponding cache line from memory into the cache hierarchy. The memory type of the region being written to can override the non-temporal hint, if the memory address specified for the non-temporal store is in an uncacheable (UC) or write protected (WP) memory region. For more information on non-temporal stores, see 'Caching of Temporal vs. Non-Temporal Data' in Chapter 10 in theIntel®64 and IA-32 Architectures Software Developer's Manual, Volume 1. Because the WC protocol uses a weakly-ordered memory consistency model, a fencing operation implemented with the SFENCE or MFENCE instruction should be used in conjunction with MOVNTPS instructions if multiple processors might use different memory types to read/write the destination memory locations. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movntps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DX "A 16bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ DX! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovge: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovge operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fisubr: aMemoryOperand "Reverse Subtract " ^ self addInstruction: #fisubr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'MartinMcClure 2/9/2013 14:29'! newJumpInstruction: name description: description operands: operands | jumpInstruction destination | jumpInstruction := self newJumpInstruction name: name; description: description. operands size ~= 1 ifTrue: [ Error signal: 'Jump instruction only takes one argument!!' ]. destination := operands first. destination isString ifTrue: [ ^ jumpInstruction label: (self labelNamed: destination) ]. destination isLabel ifTrue: [ ^ jumpInstruction label: destination ]. ^ self newInstruction name: name; description: description; operands: operands; checkOperandsForConflict! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! faddp: aX87Register "Add and Pop " ^ self addInstruction: #faddp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovle: aRegister with: aSourceRegisterOrMemory "Conditional Move - less or equal/not greater ((ZF=1) OR (SF!!=OF)) " ^ self addInstruction: #cmovle operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'testing' stamp: ''! is32 ^ true! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jbe: targetLabel "Jump short if below or equal/not above (CF=1 AND ZF=1) " ^ self addInstruction: #jbe operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM4 "An SSE register" ^ XMM4! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DL "A 8bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ DL! ! !AJx86Assembler methodsFor: 'code generation' stamp: ''! bytes ^ self generatedCode bytes.! ! !AJx86Assembler methodsFor: 'labels' stamp: ''! uniqueLabelName: aName ^ self labelNamed: aName, labels size asString! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movntdqa: aRegisterOrMemory1 with: aRegisterOrMemory2 "Load Double Quadword Non-Temporal Aligned Hint Pseudo Code ----------- DST = SRC; Description ----------- MOVNTDQA loads a double quadword from the source operand (second operand) to the destination operand (first operand) using a non-temporal hint. A processor implementation may make use of the non-temporal hint associated with this instruction if the memory source is WC (write combining) memory type. An implementation may also make use of the non-temporal hint associated with this instruction if the memory source is WB (write back) memory type. A processor's implementation of the non-temporal hint does not override the effective memory type semantics, but the implementation of the hint is processor dependent. For example, a processor implementation may choose to ignore the hint and process the instruction as a normal MOVDQA for any memory type. Another implementation of the hint for WC memory type may optimize data transfer throughput of WC reads. A third implementation may optimize cache reads generated by MOVNTDQA on WB memory type to reduce cache evictions. WC Streaming Load Hint For WC memory type in particular, the processor never appears to read the data into the cache hierarchy. Instead, the non-temporal hint may be implemented by loading a temporary internal buffer with the equivalent of an aligned cache line without filling this data to the cache. Any memory-type aliased lines in the cache will be snooped and flushed. Subsequent MOVNTDQA reads to unread portions of the WC cache line will receive data from the temporary internal buffer if data is available. The temporary internal buffer may be flushed by the processor at any time for any reason, for example: - A load operation other than a MOVNTDQA which references memory already resident in a temporary internal buffer. - A non-WC reference to memory already resident in a temporary internal buffer. - Interleaving of reads and writes to memory currently residing in a single temporary internal buffer. - Repeated MOVNTDQA loads of a particular 16-byte item in a streaming line. - Certain micro-architectural conditions including resource shortages, detection of a mis-speculation condition, and various fault conditions The memory type of the region being read can override the non-temporal hint, if the memory address specified for the non-temporal read is not a WC memory region. Information on non-temporal reads and writes can be found in Chapter 11, 'MemoryCache Control' ofIntel® 64 and IA-32 Architectures Software Developer's Manual,Volume 3A. Because the WC protocol uses a weakly-ordered memory consistency model, an MFENCE or locked instruction should be used in conjunction with MOVNTDQA instructions if multiple processors might reference the same WC memory locations or in order to synchronize reads of a processor with writes by other agents in the system. Because of the speculative nature of fetching due to MOVNTDQA, Streaming loads must not be used to reference memory addresses that are mapped to I/O devices having side effects or when reads to these devices are destructive. For additional information on MOVNTDQA usages, see Section 12.10.3 in Chapter 12, 'Programming with SSE3, SSSE3 and SSE4' ofIntel®64 and IA-32 Architectures SoftwareDeveloper's Manual, Volume 1. " ^ self addInstruction: #movntdqa operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM7 "An MMX register" ^ MM7! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jpo: targetLabel " " ^ self addInstruction: #jpo operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'convenience' stamp: ''! movzx: src to: dest "Ensure right src/dest order" ^ self movzx: dest with: src! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'CamilloBruni 7/23/2012 13:29'! decorateWith: annotation during: aBlock self addInstruction: (AJInstructionDecoration new start annotation: annotation). level := level + 1. aBlock ensure: [ level := level - 1. self addInstruction: (AJInstructionDecoration new end annotation: annotation) ] ! ! !AJx86Assembler methodsFor: 'alignment' stamp: ''! alignWord self addInstruction: AJAlignmentInstruction alignWord! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ESI "A 32bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ ESI! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CL "A 8bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ CL! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnbe: aRegister with: aSourceRegisterOrMemory "Conditional Move - not below or equal/above (CF=0 AND ZF=0) " ^ self addInstruction: #cmovnbe operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnbe: targetLabel "Jump short if not below or equal/above (CF=0 AND ZF=0) " ^ self addInstruction: #jnbe operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'convenience' stamp: ''! dw: aByteArray self assert: aByteArray size == SizeWord. ^ self addInstruction: (AJData data: aByteArray)! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovbe: aX87Register "FP Conditional Move - below or equal (CF=1 or ZF=1) " ^ self addInstruction: #fcmovbe operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movapd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Aligned Packed Double-FP Values Pseudo Code ----------- DEST = SRC; (* #GP if SRC or DEST unaligned memory operand *) Description ----------- Moves a double quadword containing two packed double-precision floating-point values from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, to store the contents of an XMM register into a 128-bit memory location, or to move data between two XMM registers. When the source or destination operand is a memory operand, the operand must be aligned on a 16-byte boundary or a general-protection exception (\#GP) will be generated. To move double-precision floating-point values to and from unaligned memory locations, use the MOVUPD instruction. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movapd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'convenience' stamp: ''! mov: assoc "convenience" ^ self mov: assoc key to: assoc value! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovnb: aX87Register "FP Conditional Move - not below (CF=0) " ^ self addInstruction: #fcmovnb operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnle: aRegister with: aSourceRegisterOrMemory "Conditional Move - not less nor equal/greater ((ZF=0) AND (SF=OF)) " ^ self addInstruction: #cmovnle operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jmp: aLabelOrRegisterOrMemory "Jump Description ----------- Transfers program control to a different point in the instruction stream without recording return information. The destination (target) operand specifies the address of the instruction being jumped to. This operand can be an immediate value, a general-purpose register, or a memory location. This instruction can be used to execute four different types of jumps: - Near jump—A jump to an instruction within the current code segment (the segment currently pointed to by the CS register), sometimes referred to as an intrasegment jump. - Short jump—A near jump where the jump range is limited to -128 to +127 from the current EIP value. - Far jump—A jump to an instruction located in a different segment than the current code segment but at the same privilege level, sometimes referred to as an intersegment jump. - Task switch—A jump to an instruction located in a different task. A task switch can only be executed in protected mode (see Chapter 7, in theIntel® 64 and IA-32 Architectures Software Developer's Manual, Volume 3A, for information on performing task switches with the JMP instruction). Near and Short Jumps. When executing a near jump, the processor jumps to the address (within the current code segment) that is specified with the target operand. The target operand specifies either an absolute offset (that is an offset from the base of the code segment) or a relative offset (a signed displacement relative to the current value of the instruction pointer in the EIP register). A near jump to a relative offset of 8-bits (rel8) is referred to as a short jump. The CS register is not changed on near and short jumps. An absolute offset is specified indirectly in a general-purpose register or a memory location (r/m16 or r/m32). The operand-size attribute determines the size of the target operand (16 or 32 bits). Absolute offsets are loaded directly into the EIP register. If the operand-size attribute is 16, the upper two bytes of the EIP register are cleared, resulting in a maximum instruction pointer size of 16 bits. A relative offset (rel8, rel16, or rel32) is generally specified as a label in assembly code, but at the machine code level, it is encoded as a signed 8-, 16-, or 32-bit immediate value. This value is added to the value in the EIP register. (Here, the EIP register contains the address of the instruction following the JMP instruction). When using relative offsets, the opcode (for short vs. near jumps) and the operand-size attribute (for near relative jumps) determines the size of the target operand (8, 16, or 32 bits). Far Jumps in Real-Address or Virtual-8086 Mode. When executing a far jump in real-address or virtual-8086 mode, the processor jumps to the code segment and offset specified with the target operand. Here the target operand specifies an absolute far address either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). With the pointer method, the segment and address of the called procedure is encoded in the instruction, using a 4-byte (16-bit operand size) or 6-byte (32-bit operand size) far address immediate. With the indirect method, the target operand specifies a memory location that contains a 4-byte (16-bit operand size) or 6-byte (32-bit operand size) far address. The far address is loaded directly into the CS and EIP registers. If the operand-size attribute is 16, the upper two bytes of the EIP register are cleared. Far Jumps in Protected Mode. When the processor is operating in protected mode, the JMP instruction can be used to perform the following three types of far jumps: - A far jump to a conforming or non-conforming code segment. - A far jump through a call gate. - A task switch. (The JMP instruction cannot be used to perform inter-privilege-level far jumps.) In protected mode, the processor always uses the segment selector part of the far address to access the corresponding descriptor in the GDT or LDT. The descriptor type (code segment, call gate, task gate, or TSS) and access rights determine the type of jump to be performed. If the selected descriptor is for a code segment, a far jump to a code segment at the same privilege level is performed. (If the selected code segment is at a different privilege level and the code segment is non-conforming, a general-protection exception is generated.) A far jump to the same privilege level in protected mode is very similar to one carried out in real-address or virtual-8086 mode. The target operand specifies an absolute far address either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). The operand-size attribute determines the size of the offset (16 or 32 bits) in the far address. The new code segment selector and its descriptor are loaded into CS register, and the offset from the instruction is loaded into the EIP register. Note that a call gate (described in the next paragraph) can also be used to perform far call to a code segment at the same privilege level. Using this mechanism provides an extra level of indirection and is the preferred method of making jumps between 16-bit and 32-bit code segments. When executing a far jump through a call gate, the segment selector specified by the target operand identifies the call gate. (The offset part of the target operand is ignored.) The processor then jumps to the code segment specified in the call gate descriptor and begins executing the instruction at the offset specified in the call gate. No stack switch occurs. Here again, the target operand can specify the far address of the call gate either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). Executing a task switch with the JMP instruction is somewhat similar to executing a jump through a call gate. Here the target operand specifies the segment selector of the task gate for the task being switched to (and the offset part of the target operand is ignored). The task gate in turn points to the TSS for the task, which contains the segment selectors for the task's code and stack segments. The TSS also contains the EIP value for the next instruction that was to be executed before the task was suspended. This instruction pointer value is loaded into the EIP register so that the task begins executing again at this next instruction. The JMP instruction can also specify the segment selector of the TSS directly, which eliminates the indirection of the task gate. See Chapter 7 inIntel® 64 and IA-32Architectures Software Developer's Manual, Volume 3A, for detailed information on the mechanics of a task switch. Note that when you execute at task switch with a JMP instruction, the nested task flag (NT) is not set in the EFLAGS register and the new TSS's previous task link field is not loaded with the old task's TSS selector. A return to the previous task can thus not be carried out by executing the IRET instruction. Switching tasks with the JMP instruction differs in this regard from the CALL instruction which does set the NT flag and save the previous task link information, allowing a return to the calling task with an IRET instruction. In 64-Bit Mode — The instruction's operation size is fixed at 64 bits. If a selector points to a gate, then RIP equals the 64-bit displacement taken from gate; else RIP equals the zero-extended offset from the far pointer referenced in the instruction. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #jmp operands: { aLabelOrRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'stack management' stamp: ''! emitEpilogue: popExtraBytes ^ stackManager emitEpilogue: popExtraBytes assembler: self! ! !AJx86Assembler methodsFor: 'code generation' stamp: ''! generatedCode ^ AJGeneratedCode new fromInstructions: self prepareInstructions. ! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsubr: aX87Register1 with: aX87Register2 " see #fsubr" ^ self addInstruction: #fsubr operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovnbe: aX87Register "FP Conditional Move - below or equal (CF=0 and ZF=0) " ^ self addInstruction: #fcmovnbe operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! imul: aRegisterOrMemory "Signed Multiply Description ----------- Performs a signed multiplication of two operands. This instruction has three forms, depending on the number of operands. - One-operand form — This form is identical to that used by the MUL instruction. Here, the source operand (in a general-purpose register or memory location) is multiplied by the value in the AL, AX, EAX, or RAX register (depending on the operand size) and the product is stored in the AX, DX:AX, EDX:EAX, or RDX:RAX registers, respectively. - Two-operand form — With this form the destination operand (the first operand) is multiplied by the source operand (second operand). The destination operand is a general-purpose register and the source operand is an immediate value, a general-purpose register, or a memory location. The product is then stored in the destination operand location. - Three-operand form — This form requires a destination operand (the first operand) and two source operands (the second and the third operands). Here, the first source operand (which can be a general-purpose register or a memory location) is multiplied by the second source operand (an immediate value). The product is then stored in the destination operand (a general-purpose register). When an immediate value is used as an operand, it is sign-extended to the length of the destination operand format. The CF and OF flags are set when significant bit (including the sign bit) are carried into the upper half of the result. The CF and OF flags are cleared when the result (including the sign bit) fits exactly in the lower half of the result. The three forms of the IMUL instruction are similar in that the length of the product is calculated to twice the length of the operands. With the one-operand form, the product is stored exactly in the destination. With the two- and three- operand forms, however, the result is truncated to the length of the destination before it is stored in the destination register. Because of this truncation, the CF or OF flag should be tested to ensure that no significant bits are lost. The two- and three-operand forms may also be used with unsigned operands because the lower half of the product is the same regardless if the operands are signed or unsigned. The CF and OF flags, however, cannot be used to determine if the upper half of the result is non-zero. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. Use of REX.W modifies the three forms of the instruction as follows. - One-operand form —The source operand (in a 64-bit general-purpose register or memory location) is multiplied by the value in the RAX register and the product is stored in the RDX:RAX registers. - Two-operand form — The source operand is promoted to 64 bits if it is a register or a memory location. If the source operand is an immediate, it is sign extended to 64 bits. The destination operand is promoted to 64 bits. - Three-operand form — The first source operand (either a register or a memory location) and destination operand are promoted to 64 bits. " ^ self addInstruction: #imul operands: { aRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instruction list' stamp: ''! instructionsFor: aBlockWithCode | old new | old := instructions. instructions := nil. [ aBlockWithCode value. ] ensure: [ new := instructions. instructions := old ]. ^ new! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movhlps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Packed Single-FP Values High to Low Pseudo Code ----------- DEST[63:0] = SRC[127:64]; (* DEST[127:64] unchanged *) Description ----------- Moves two packed single-precision floating-point values from the high quadword of the source operand (second operand) to the low quadword of the destination operand (first operand). The high quadword of the destination operand is left unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movhlps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdivrp: aX87Register "Reverse Divide and Pop " ^ self addInstruction: #fdivrp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! call: anAddressSource "Call Procedure Description ----------- Saves procedure linking information on the stack and branches to the called procedure specified using the target operand. The target operand specifies the address of the first instruction in the called procedure. The operand can be an immediate value, a general-purpose register, or a memory location. This instruction can be used to execute four types of calls: - Near Call — A call to a procedure in the current code segment (the segment currently pointed to by the CS register), sometimes referred to as an intrasegment call. - Far Call — A call to a procedure located in a different segment than the current code segment, sometimes referred to as an inter-segment call. - Inter-privilege-level far call — A far call to a procedure in a segment at a different privilege level than that of the currently executing program or procedure. - Task switch — A call to a procedure located in a different task. The latter two call types (inter-privilege-level call and task switch) can only be executed in protected mode. See 'Calling Procedures Using Call and RET' in Chapter6 of the Intel®64 and IA-32 Architectures Software Developer's Manual, Volume 1, for additional information on near, far, and inter-privilege-level calls. See Chapter 7,'Task Management,' in theIntel® 64 and IA-32 Architectures Software Developer'sManual, Volume 3A, for information on performing task switches with the CALL instruction. Near Call. When executing a near call, the processor pushes the value of the EIP register (which contains the offset of the instruction following the CALL instruction) on the stack (for use later as a return-instruction pointer). The processor then branches to the address in the current code segment specified by the target operand. The target operand specifies either an absolute offset in the code segment (an offset from the base of the code segment) or a relative offset (a signed displacement relative to the current value of the instruction pointer in the EIP register; this value points to the instruction following the CALL instruction). The CS register is not changed on near calls. For a near call absolute, an absolute offset is specified indirectly in a general-purpose register or a memory location (r/m16, r/m32, or r/m64). The operand-size attribute determines the size of the target operand (16, 32 or 64 bits). When in 64-bit mode, the operand size for near call (and all near branches) is forced to 64-bits. Absolute offsets are loaded directly into the EIP(RIP) register. If the operand size attribute is 16, the upper two bytes of the EIP register are cleared, resulting in a maximum instruction pointer size of 16 bits. When accessing an absolute offset indirectly using the stack pointer [ESP] as the base register, the base value used is the value of the ESP before the instruction executes. A relative offset (rel16 or rel32) is generally specified as a label in assembly code. But at the machine code level, it is encoded as a signed, 16- or 32-bit immediate value. This value is added to the value in the EIP(RIP) register. In 64-bit mode the relative offset is always a 32-bit immediate value which is sign extended to 64-bits before it is added to the value in the RIP register for the target calculation. As with absolute offsets, the operand-size attribute determines the size of the target operand (16, 32, or 64 bits). In 64-bit mode the target operand will always be 64-bits because the operand size is forced to 64-bits for near branches. Far Calls in Real-Address or Virtual-8086 Mode. When executing a far call in real- address or virtual-8086 mode, the processor pushes the current value of both the CS and EIP registers on the stack for use as a return-instruction pointer. The processor then performs a 'far branch' to the code segment and offset specified with the target operand for the called procedure. The target operand specifies an absolute far address either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). With the pointer method, the segment and offset of the called procedure is encoded in the instruction using a 4-byte (16-bit operand size) or 6-byte (32-bit operand size) far address immediate. With the indirect method, the target operand specifies a memory location that contains a 4-byte (16-bit operand size) or 6-byte (32-bit operand size) far address. The operand-size attribute determines the size of the offset (16 or 32 bits) in the far address. The far address is loaded directly into the CS and EIP registers. If the operand-size attribute is 16, the upper two bytes of the EIP register are cleared. Far Calls in Protected Mode. When the processor is operating in protected mode, the CALL instruction can be used to perform the following types of far calls: - Far call to the same privilege level - Far call to a different privilege level (inter-privilege level call) - Task switch (far call to another task) In protected mode, the processor always uses the segment selector part of the far address to access the corresponding descriptor in the GDT or LDT. The descriptor type (code segment, call gate, task gate, or TSS) and access rights determine the type of call operation to be performed. If the selected descriptor is for a code segment, a far call to a code segment at the same privilege level is performed. (If the selected code segment is at a different privilege level and the code segment is non-conforming, a general-protection exception is generated.) A far call to the same privilege level in protected mode is very similar to one carried out in real-address or virtual-8086 mode. The target operand specifies an absolute far address either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). The operand- size attribute determines the size of the offset (16 or 32 bits) in the far address. The new code segment selector and its descriptor are loaded into CS register; the offset from the instruction is loaded into the EIP register. A call gate (described in the next paragraph) can also be used to perform a far call to a code segment at the same privilege level. Using this mechanism provides an extra level of indirection and is the preferred method of making calls between 16-bit and 32-bit code segments. When executing an inter-privilege-level far call, the code segment for the procedure being called must be accessed through a call gate. The segment selector specified by the target operand identifies the call gate. The target operand can specify the call gate segment selector either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). The processor obtains the segment selector for the new code segment and the new instruction pointer (offset) from the call gate descriptor. (The offset from the target operand is ignored when a call gate is used.) On inter-privilege-level calls, the processor switches to the stack for the privilege level of the called procedure. The segment selector for the new stack segment is specified in the TSS for the currently running task. The branch to the new code segment occurs after the stack switch. (Note that when using a call gate to perform a far call to a segment at the same privilege level, no stack switch occurs.) On the new stack, the processor pushes the segment selector and stack pointer for the calling procedure's stack, an optional set of parameters from the calling procedures stack, and the segment selector and instruction pointer for the calling procedure's code segment. (A value in the call gate descriptor determines how many parameters to copy to the new stack.) Finally, the processor branches to the address of the procedure being called within the new code segment. Executing a task switch with the CALL instruction is similar to executing a call through a call gate. The target operand specifies the segment selector of the task gate for the new task activated by the switch (the offset in the target operand is ignored). The task gate in turn points to the TSS for the new task, which contains the segment selectors for the task's code and stack segments. Note that the TSS also contains the EIP value for the next instruction that was to be executed before the calling task was suspended. This instruction pointer value is loaded into the EIP register to re-start the calling task. The CALL instruction can also specify the segment selector of the TSS directly, which eliminates the indirection of the task gate. See Chapter 7, 'Task Management,' in the Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 3A, for information on the mechanics of a task switch. When you execute at task switch with a CALL instruction, the nested task flag (NT) is set in the EFLAGS register and the new TSS's previous task link field is loaded with the old task's TSS selector. Code is expected to suspend this nested task by executing an IRET instruction which, because the NT flag is set, automatically uses the previous task link to return to the calling task. (See 'Task Linking' in Chapter 7 ofthe Intel® 64 and IA-32 Architectures Software Developer's Manual, Volume 3A, for information on nested tasks.) Switching tasks with the CALL instruction differs in this regard from JMP instruction. JMP does not set the NT flag and therefore does not expect an IRET instruction to suspend the task. Mixing 16-Bit and 32-Bit Calls. When making far calls between 16-bit and 32-bit code segments, use a call gate. If the far call is from a 32-bit code segment to a 16-bit code segment, the call should be made from the first 64 KBytes of the 32-bit code segment. This is because the operand-size attribute of the instruction is set to 16, so only a 16-bit return address offset can be saved. Also, the call should be made using a 16-bit call gate so that 16-bit values can be pushed on the stack. See Chapter 18,'Mixing 16-Bit and 32-Bit Code,' in theIntel® 64 and IA-32 Architectures SoftwareDeveloper's Manual, Volume 3A, for more information. Far Calls in Compatibility Mode. When the processor is operating in compatibility mode, the CALL instruction can be used to perform the following types of far calls: - Far call to the same privilege level, remaining in compatibility mode - Far call to the same privilege level, transitioning to 64-bit mode - Far call to a different privilege level (inter-privilege level call), transitioning to 64bit mode Note that a CALL instruction can not be used to cause a task switch in compatibility mode since task switches are not supported in IA-32e mode. In compatibility mode, the processor always uses the segment selector part of the far address to access the corresponding descriptor in the GDT or LDT. The descriptor type (code segment, call gate) and access rights determine the type of call operation to be performed. If the selected descriptor is for a code segment, a far call to a code segment at the same privilege level is performed. (If the selected code segment is at a different privilege level and the code segment is non-conforming, a general-protection exception is generated.) A far call to the same privilege level in compatibility mode is very similar to one carried out in protected mode. The target operand specifies an absolute far address either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). The operand-size attribute determines the size of the offset (16 or 32 bits) in the far address. The new code segment selector and its descriptor are loaded into CS register and the offset from the instruction is loaded into the EIP register. The difference is that 64-bit mode may be entered. This specified by the L bit in the new code segment descriptor. Note that a 64-bit call gate (described in the next paragraph) can also be used to perform a far call to a code segment at the same privilege level. However, using this mechanism requires that the target code segment descriptor have the L bit set, causing an entry to 64-bit mode. When executing an inter-privilege-level far call, the code segment for the procedure being called must be accessed through a 64-bit call gate. The segment selector specified by the target operand identifies the call gate. The target operand can specify the call gate segment selector either directly with a pointer (ptr16:16 or ptr16:32) or indirectly with a memory location (m16:16 or m16:32). The processor obtains the segment selector for the new code segment and the new instruction pointer (offset) from the 16-byte call gate descriptor. (The offset from the target operand is ignored when a call gate is used.) On inter-privilege-level calls, the processor switches to the stack for the privilege level of the called procedure. The segment selector for the new stack segment is set to NULL. The new stack pointer is specified in the TSS for the currently running task. The branch to the new code segment occurs after the stack switch. (Note that when using a call gate to perform a far call to a segment at the same privilege level, an implicit stack switch occurs as a result of entering 64-bit mode. The SS selector is unchanged, but stack segment accesses use a segment base of 0x0, the limit is ignored, and the default stack size is 64-bits. The full value of RSP is used for the offset, of which the upper 32-bits are undefined.) On the new stack, the processor pushes the segment selector and stack pointer for the calling procedure's stack and the segment selector and instruction pointer for the calling procedure's code segment. (Parameter copy is not supported in IA-32e mode.) Finally, the processor branches to the address of the procedure being called within the new code segment. Near/(Far) Calls in 64-bit Mode. When the processor is operating in 64-bit mode, the CALL instruction can be used to perform the following types of far calls: - Far call to the same privilege level, transitioning to compatibility mode - Far call to the same privilege level, remaining in 64-bit mode - Far call to a different privilege level (inter-privilege level call), remaining in 64-bit mode Note that in this mode the CALL instruction can not be used to cause a task switch in 64-bit mode since task switches are not supported in IA-32e mode. In 64-bit mode, the processor always uses the segment selector part of the far address to access the corresponding descriptor in the GDT or LDT. The descriptor type (code segment, call gate) and access rights determine the type of call operation to be performed. If the selected descriptor is for a code segment, a far call to a code segment at the same privilege level is performed. (If the selected code segment is at a different privilege level and the code segment is non-conforming, a general-protection exception is generated.) A far call to the same privilege level in 64-bit mode is very similar to one carried out in compatibility mode. The target operand specifies an absolute far address indirectly with a memory location (m16:16, m16:32 or m16:64). The form of CALL with a direct specification of absolute far address is not defined in 64-bit mode. The operand-size attribute determines the size of the offset (16, 32, or 64 bits) in the far address. The new code segment selector and its descriptor are loaded into the CS register; the offset from the instruction is loaded into the EIP register. The new code segment may specify entry either into compatibility or 64-bit mode, based on the L bit value. A 64-bit call gate (described in the next paragraph) can also be used to perform a far call to a code segment at the same privilege level. However, using this mechanism requires that the target code segment descriptor have the L bit set. When executing an inter-privilege-level far call, the code segment for the procedure being called must be accessed through a 64-bit call gate. The segment selector specified by the target operand identifies the call gate. The target operand can only specify the call gate segment selector indirectly with a memory location (m16:16, m16:32 or m16:64). The processor obtains the segment selector for the new code segment and the new instruction pointer (offset) from the 16-byte call gate descriptor. (The offset from the target operand is ignored when a call gate is used.) On inter-privilege-level calls, the processor switches to the stack for the privilege level of the called procedure. The segment selector for the new stack segment is set to NULL. The new stack pointer is specified in the TSS for the currently running task. The branch to the new code segment occurs after the stack switch. Note that when using a call gate to perform a far call to a segment at the same privilege level, an implicit stack switch occurs as a result of entering 64-bit mode. The SS selector is unchanged, but stack segment accesses use a segment base of 0x0, the limit is ignored, and the default stack size is 64-bits. (The full value of RSP is used for the offset.) On the new stack, the processor pushes the segment selector and stack pointer for the calling procedure's stack and the segment selector and instruction pointer for the calling procedure's code segment. (Parameter copy is not supported in IA-32e mode.) Finally, the processor branches to the address of the procedure being called within the new code segment. " ^ self addInstruction: #call operands: { anAddressSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmove: aX87Register "FP Conditional Move - equal (ZF=1) " ^ self addInstruction: #fcmove operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fnsave: aMemoryOperand "Store x87 FPU State " ^ self addInstruction: #fnsave operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ffree: aX87Register "Free Floating-Point Register " ^ self addInstruction: #ffree operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fmul: aX87Register1 with: aX87Register2 " see #fmul" ^ self addInstruction: #fmul operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fmulp: aX87Register "Multiply and Pop " ^ self addInstruction: #fmulp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fnstenv: aMemoryOperand "Store x87 FPU Environment " ^ self addInstruction: #fnstenv operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovng: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovng operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! bsf: aRegister with: aSourceRegisterOrMemory "Bit Scan Forward Description ----------- Searches the source operand (second operand) for the least significant set bit (1 bit). If a least significant 1 bit is found, its bit index is stored in the destination operand (first operand). The source operand can be a register or a memory location; the destination operand is a register. The bit index is an unsigned offset from bit 0 of the source operand. If the content of the source operand is 0, the content of the destination operand is undefined. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #bsf operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! bt: aDestinationRegisterOrMemory with: aSourceRegisterOrImmediate "Bit Test Pseudo Code ----------- CF = Bit(BitBase, BitOffset); Description ----------- Selects the bit in a bit string (specified with the first operand, called the bit base) at the bit-position designated by the bit offset (specified by the second operand) and stores the value of the bit in the CF flag. The bit base operand can be a register or a memory location; the bit offset operand can be a register or an immediate value: - If the bit base operand specifies a register, the instruction takes the modulo 16, 32, or 64 of the bit offset operand (modulo size depends on the mode and register size; 64-bit operands are available only in 64-bit mode). - If the bit base operand specifies a memory location, the operand represents the address of the byte in memory that contains the bit base (bit 0 of the specified byte) of the bit string. The range of the bit position that can be referenced by the offset operand depends on the operand size. See also: Bit(BitBase, BitOffset) on page 3-11. Some assemblers support immediate bit offsets larger than 31 by using the immediate bit offset field in combination with the displacement field of the memory operand. In this case, the low-order 3 or 5 bits (3 for 16-bit operands, 5 for 32-bit operands) of the immediate bit offset are stored in the immediate bit offset field, and the high-order bits are shifted and combined with the byte displacement in the addressing mode by the assembler. The processor will ignore the high order bits if they are not zero. When accessing a bit in memory, the processor may access 4 bytes starting from the memory address for a 32-bit operand size, using by the following relationship: Effective Address + (4 \* (BitOffset DIV 32)) Or, it may access 2 bytes starting from the memory address for a 16-bit operand, using this relationship: Effective Address + (2 \* (BitOffset DIV 16)) It may do so even when only a single byte needs to be accessed to reach the given bit. When using this bit addressing mechanism, software should avoid referencing areas of memory close to address space holes. In particular, it should avoid references to memory-mapped I/O registers. Instead, software should use the MOV instructions to load from or store to these addresses, and use the register form of these instructions to manipulate the data. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bit operands. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #bt operands: { aDestinationRegisterOrMemory . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmpxchg8b: aMemoryOperand "Compare and Exchange Bytes " ^ self addInstruction: #cmpxchg8b operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'labels' stamp: 'CamilloBruni 7/18/2012 16:27'! label: aNameOrLabel ifPresent: anExceptionBlock | label | label := aNameOrLabel. label isString ifTrue: [ label := self labelNamed: label ]. label isSet ifTrue: [ ^ anExceptionBlock cull: label ]. label isSet: true. ^ self addInstruction: label. ! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DH "A 8bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ DH! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdiv: aX87Register1 with: aX87Register2 " see #fdiv" ^ self addInstruction: #fdiv operands: { aX87Register1 . aX87Register2 }! ! !AJx86Assembler methodsFor: 'dnu' stamp: 'CamilloBruni 4/17/2012 17:51'! doesNotUnderstand: aMessage "try to dispatch a message based on instruction name" | sel pos | sel := aMessage selector. sel isBinary ifTrue: [ "binary selectors" ^ super doesNotUnderstand: aMessage ]. "use the first keyword to find the instruction" pos := sel indexOf: $:. pos > 0 ifTrue: [ sel := (sel first: pos - 1) asSymbol ]. self instructionDesciptions at: sel ifPresent: [ :description| ^ self addInstruction: sel description: description operands: aMessage arguments ]. ^ super doesNotUnderstand: aMessage! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! btc: aDestinationRegisterOrMemory with: aSourceRegisterOrImmediate "Bit Test and Complement Pseudo Code ----------- CF = Bit(BitBase, BitOffset); Bit(BitBase, BitOffset) = NOT Bit(BitBase, BitOffset); Description ----------- Selects the bit in a bit string (specified with the first operand, called the bit base) at the bit-position designated by the bit offset operand (second operand), stores the value of the bit in the CF flag, and complements the selected bit in the bit string. The bit base operand can be a register or a memory location; the bit offset operand can be a register or an immediate value: - If the bit base operand specifies a register, the instruction takes the modulo 16, 32, or 64 of the bit offset operand (modulo size depends on the mode and register size; 64-bit operands are available only in 64-bit mode). This allows any bit position to be selected. - If the bit base operand specifies a memory location, the operand represents the address of the byte in memory that contains the bit base (bit 0 of the specified byte) of the bit string. The range of the bit position that can be referenced by the offset operand depends on the operand size. See also: Bit(BitBase, BitOffset) on page 3-11. Some assemblers support immediate bit offsets larger than 31 by using the immediate bit offset field in combination with the displacement field of the memory operand. See 'BT—Bit Test' in this chapter for more information on this addressingmechanism. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #btc operands: { aDestinationRegisterOrMemory . aSourceRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! add: aRegisterOrMemoryOperand with: aSource "Add Pseudo Code ----------- DEST = DEST + SRC; Description ----------- Adds the destination operand (first operand) and the source operand (second operand) and then stores the result in the destination operand. The destination operand can be a register or a memory location; the source operand can be an immediate, a register, or a memory location. (However, two memory operands cannot be used in one instruction.) When an immediate value is used as an operand, it is sign-extended to the length of the destination operand format. The ADD instruction performs integer addition. It evaluates the result for both signed and unsigned integer operands and sets the OF and CF flags to indicate a carry (overflow) in the signed or unsigned result, respectively. The SF flag indicates the sign of the signed result. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #add operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jg: targetLabel " " ^ self addInstruction: #jg operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! test: aRegisterOrMemory with: aRegisterOrImmediate "Logical Compare Description ----------- Computes the bit-wise logical AND of first operand (source 1 operand) and the second operand (source 2 operand) and sets the SF, ZF, and PF status flags according to the result. The result is then discarded. In 64-bit mode, using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #test operands: { aRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST4 "A floating point register" ^ ST4! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdivr: aMemoryOperand "Reverse Divide " ^ self addInstruction: #fdivr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fdiv: aMemoryOperand "Divide " ^ self addInstruction: #fdiv operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovpo: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovpo operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST7 "A floating point register" ^ ST7! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM2 "An SSE register" ^ XMM2! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BX "A 16bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ BX! ! !AJx86Assembler methodsFor: 'function calls' stamp: ''! cdeclCall: aBlock alignment: align ^ self performingCall: (self newCdeclCall alignment: align) in: aBlock ! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fucom: aX87Register "Unordered Compare Floating Point Values " ^ self addInstruction: #fucom operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovpe: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovpe operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! clflush: aMemoryOperand "Flush Cache Line Pseudo Code ----------- Flush_Cache_Line(SRC); Description ----------- Invalidates the cache line that contains the linear address specified with the source operand from all levels of the processor cache hierarchy (data and instruction). The invalidation is broadcast throughout the cache coherence domain. If, at any level of the cache hierarchy, the line is inconsistent with memory (dirty) it is written to memory before invalidation. The source operand is a byte memory location. The availability of CLFLUSH is indicated by the presence of the CPUID feature flag CLFSH (bit 19 of the EDX register, see 'CPUID—CPU Identification' in this chapter).The aligned cache line size affected is also indicated with the CPUID instruction (bits 8 through 15 of the EBX register when the initial value in the EAX register is 1). The memory attribute of the page containing the affected line has no effect on the behavior of this instruction. It should be noted that processors are free to speculatively fetch and cache data from system memory regions assigned a memory-type allowing for speculative reads (such as, the WB, WC, and WT memory types). PREFETCHh instructions can be used to provide the processor with hints for this speculative behavior. Because this speculative fetching can occur at any time and is not tied to instruction execution, the CLFLUSH instruction is not ordered with respect to PREFETCHh instructions or any of the speculative fetching mechanisms (that is, data can be speculatively loaded into a cache line just before, during, or after the execution of a CLFLUSH instruction that references the cache line). CLFLUSH is only ordered by the MFENCE instruction. It is not guaranteed to be ordered by any other fencing or serializing instructions or by another CLFLUSH instruction. For example, software can use an MFENCE instruction to ensure that previous stores are included in the write-back. The CLFLUSH instruction can be used at all privilege levels and is subject to all permission checking and faults associated with a byte load (and in addition, a CLFLUSH instruction is allowed to flush a linear address in an execute-only segment). Like a load, the CLFLUSH instruction sets the A bit but not the D bit in the page tables. The CLFLUSH instruction was introduced with the SSE2 extensions; however, because it has its own CPUID feature flag, it can be implemented in IA-32 processors that do not include the SSE2 extensions. Also, detecting the presence of the SSE2 extensions with the CPUID instruction does not guarantee that the CLFLUSH instruction is implemented in the processor. CLFLUSH operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #clflush operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! idiv: aDestination "Signed Divide Description ----------- Divides the (signed) value in the AX, DX:AX, or EDX:EAX (dividend) by the source operand (divisor) and stores the result in the AX (AH:AL), DX:AX, or EDX:EAX registers. The source operand can be a general-purpose register or a memory location. The action of this instruction depends on the operand size (dividend/divisor). Non-integral results are truncated (chopped) towards 0. The remainder is always less than the divisor in magnitude. Overflow is indicated with the \#DE (divide error) exception rather than with the CF flag. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. In 64-bit mode when REX.W is applied, the instruction divides the signed value in RDX:RAX by the source operand. RAX contains a 64-bit quotient; RDX contains a 64-bit remainder. See the summary chart at the beginning of this section for encoding data and limits. See the following. Operand Size Dividend Divisor Quotient Remainder Quotient Range ------------------------- ---------- --------- ---------- ----------- --------------------- Word/byte AX r/m8 AL AH -128 to +127 Doubleword/word DX:AX r/m16 AX DX -32,768 to +32,767 Quadword/doubleword EDX:EAX r/m32 EAX EDX -2^31^ to 2^32^ - 1 Doublequadword/quadword RDX:RAX r/m64 RAX RDX -2^63^ to 2^64^ - 1 : IDIV Results " ^ self addInstruction: #idiv operands: { aDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnl: targetLabel "Jump short if not less/greater or equal (SF=OF) " ^ self addInstruction: #jnl operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fxrstor: aMemoryOperand "Restore x87 FPU, MMX, XMM, and MXCSR State Pseudo Code ----------- (x87 FPU, MMX, XMM7-XMM0, MXCSR) = Load(SRC); Description ----------- Reloads the x87 FPU, MMX technology, XMM, and MXCSR registers from the 512-byte memory image specified in the source operand. This data should have been written to memory previously using the FXSAVE instruction, and in the same format as required by the operating modes. The first byte of the data should be located on a 16-byte boundary. There are three distinct layouts of the FXSAVE state map: one for legacy and compatibility mode, a second format for 64-bit mode FXSAVE/FXRSTOR with REX.W=0, and the third format is for 64-bit mode with FXSAVE64/FXRSTOR64. Table 3-48 ('Non-64-bit-Mode Layout of FXSAVE and FXRSTOR Memory Region') shows the layout of the legacy/compatibility mode state information inmemory and describes the fields in the memory image for the FXRSTOR and FXSAVE instructions.Table 3-51 shows the layout of the 64-bit mode state information whenREX.W is set (FXSAVE64/FXRSTOR64). Table 3-52 shows the layout of the 64-bitmode state information when REX.W is clear (FXSAVE/FXRSTOR). The state image referenced with an FXRSTOR instruction must have been saved using an FXSAVE instruction or be in the same format as required by Table 3-48, Table 3-51, or Table 3-52. Referencing a state image saved with an FSAVE, FNSAVEinstruction or incompatible field layout will result in an incorrect state restoration. The FXRSTOR instruction does not flush pending x87 FPU exceptions. To check and raise exceptions when loading x87 FPU state information with the FXRSTOR instruction, use an FWAIT instruction after the FXRSTOR instruction. If the OSFXSR bit in control register CR4 is not set, the FXRSTOR instruction may not restore the states of the XMM and MXCSR registers. This behavior is implementation dependent. If the MXCSR state contains an unmasked exception with a corresponding status flag also set, loading the register with the FXRSTOR instruction will not result in a SIMD floating-point error condition being generated. Only the next occurrence of this unmasked exception will result in the exception being generated. Bits 16 through 32 of the MXCSR register are defined as reserved and should be set to 0. Attempting to write a 1 in any of these bits from the saved state image will result in a general protection exception (\#GP) being generated. Bytes 464:511 of an FXSAVE image are available for software use. FXRSTOR ignores the content of bytes 464:511 in an FXSAVE state image. " ^ self addInstruction: #fxrstor operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnz: targetLabel "Jump short if not zero/not equal (ZF=1) " ^ self addInstruction: #jnz operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovc: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovc operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jne: targetLabel " " ^ self addInstruction: #jne operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movmskps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Extract Packed Single-FP Sign Mask Description ----------- Extracts the sign bits from the packed single-precision floating-point values in the source operand (second operand), formats them into a 4-bit mask, and stores the mask in the destination operand (first operand). The source operand is an XMM register, and the destination operand is a general-purpose register. The mask is stored in the 4 low-order bits of the destination operand. Zero-extend the upper bits of the destination operand. In 64-bit mode, the instruction can access additional registers (XMM8-XMM15, R8-R15) when used with a REX.R prefix. The default operand size is 64-bit in 64-bit mode. " ^ self addInstruction: #movmskps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movntdq: aRegisterOrMemory1 with: aRegisterOrMemory2 "Store Double Quadword Using Non-Temporal Hint Pseudo Code ----------- DEST = SRC; Description ----------- Moves the double quadword in the source operand (second operand) to the destination operand (first operand) using a non-temporal hint to prevent caching of the data during the write to memory. The source operand is an XMM register, which is assumed to contain integer data (packed bytes, words, doublewords, or quadwords). The destination operand is a 128-bit memory location. The non-temporal hint is implemented by using a write combining (WC) memory type protocol when writing the data to memory. Using this protocol, the processor does not write the data into the cache hierarchy, nor does it fetch the corresponding cache line from memory into the cache hierarchy. The memory type of the region being written to can override the non-temporal hint, if the memory address specified for the non-temporal store is in an uncacheable (UC) or write protected (WP) memory region. For more information on non-temporal stores, see 'Caching of Temporal vs. Non-Temporal Data' in Chapter 10 in theIntel®64 and IA-32 Architectures Software Developer's Manual, Volume 1. Because the WC protocol uses a weakly-ordered memory consistency model, a fencing operation implemented with the SFENCE or MFENCE instruction should be used in conjunction with MOVNTDQ instructions if multiple processors might use different memory types to read/write the destination memory locations. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movntdq operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! neg: aDestination "Two's Complement Negation Pseudo Code ----------- IF DEST = 0 CF = 0; ELSE CF = 1; FI; DEST = [- (DEST)] Description ----------- Replaces the value of operand (the destination operand) with its two's complement. (This operation is equivalent to subtracting the operand from 0.) The destination operand is located in a general-purpose register or a memory location. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #neg operands: { aDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! sal: aDestinationRegisterOrMemory with: aRegisterOrImmediate " " ^ self addInstruction: #sal operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsub: aMemoryOperand "Subtract " ^ self addInstruction: #fsub operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BL "A 8bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ BL! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! AL "A 8bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ AL! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fisub: aMemoryOperand "Subtract " ^ self addInstruction: #fisub operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BH "A 8bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ BH! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsubrp: aX87Register "Reverse Subtract and Pop " ^ self addInstruction: #fsubrp operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'MartinMcClure 12/15/2012 13:37'! syscall "SYSCALL saves the RIP of the instruction following SYSCALL to RCX and loads a new RIP from the IA32_LSTAR (64-bit mode). Upon return, SYSRET copies the value saved in RCX to the RIP. SYSCALL saves RFLAGS (lower 32 bit only) in R11. It then masks RFLAGS with an OS-defined value using the IA32_FMASK (MSR C000_0084). The actual mask value used by the OS is the complement of the value written to the IA32_FMASK MSR. None of the bits in RFLAGS are automatically cleared (except for RF). SYSRET restores RFLAGS from R11 (the lower 32 bits only). Software should not alter the CS or SS descriptors in a manner that violates the following assumptions made by SYSCALL/SYSRET: * The CS and SS base and limit remain the same for all processes, including the operating system (the base is 0H and the limit is 0FFFFFFFFH). * The CS of the SYSCALL target has a privilege level of 0. * The CS of the SYSRET target has a privilege level of 3. SYSCALL/SYSRET do not check for violations of these assumptions. Operation IF (CS.L ~= 1 ) or (IA32_EFER.LMA ~= 1) or (IA32_EFER.SCE ~= 1) (* Not in 64-Bit Mode or SYSCALL/SYSRET not enabled in IA32_EFER *) THEN #UD; FI; RCX := RIP; RIP := LSTAR_MSR; R11 := EFLAGS; EFLAGS := (EFLAGS MASKED BY IA32_FMASK); CPL := 0; CS(SEL) := IA32_STAR_MSR[47:32]; CS(DPL) := 0; CS(BASE) := 0; CS(LIMIT) := 0xFFFFF; CS(GRANULAR) := 1; SS(SEL) := IA32_STAR_MSR[47:32] + 8; SS(DPL) := 0; SS(BASE) := 0; SS(LIMIT) := 0xFFFFF; SS(GRANULAR) := 1; SS(LIMIT) := 0xFFFFF; SS(GRANULAR) := 1; " ^ self addInstruction: #syscall operands: #()! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST1 "A floating point register" ^ ST1! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! sbb: aRegisterOrMemoryOperand with: aSource "Integer Subtraction with Borrow " ^ self addInstruction: #sbb operands: { aRegisterOrMemoryOperand . aSource }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovg: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovg operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fucomip: aX87Register "Unordered Compare Floating Point Values and Set EFLAGS and Pop " ^ self addInstruction: #fucomip operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ror: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Rotate " ^ self addInstruction: #ror operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! AX "A 16bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ AX! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM7 "An SSE register" ^ XMM7! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnb: aRegister with: aSourceRegisterOrMemory "Conditional Move - not below/above or equal/not carry (CF=0) " ^ self addInstruction: #cmovnb operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'register' stamp: ''! basePointer ^ self is32BitMode ifTrue: [ EBP ] ifFalse: [ BP ]! ! !AJx86Assembler methodsFor: 'accessing' stamp: ''! numGPRegisters "answer the total number of general-purpose registers for target platform" ^ 8 ! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fst: aMemoryOrX87Register "Store Floating Point Value " ^ self addInstruction: #fst operands: { aMemoryOrX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! rcr: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Rotate " ^ self addInstruction: #rcr operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DI "A 16bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ DI! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnb: targetLabel "Jump short if not below/above or equal/not carry (CF=0) " ^ self addInstruction: #jnb operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movddup: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move One Double-FP and Duplicate Description ----------- The linear address corresponds to the address of the least-significant byte of the referenced memory data. When a memory address is indicated, the 8 bytes of data at memory location m64 are loaded. When the register-register form of this operation is used, the lower half of the 128-bit source register is duplicated and copied into the 128-bit destination register. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movddup operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovu: aX87Register "FP Conditional Move - unordered (PF=1) " ^ self addInstruction: #fcmovu operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! rol: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Rotate " ^ self addInstruction: #rol operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jc: targetLabel " " ^ self addInstruction: #jc operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jo: targetLabel "Jump short if overflow (OF=1) " ^ self addInstruction: #jo operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! sar: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Shift " ^ self addInstruction: #sar operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'accessing' stamp: ''! undefinedLabels "answer a collection of labels, which having no defined position " | lbls | lbls := OrderedCollection new. labels keysAndValuesDo: [:key :value | value ifNil: [ lbls add: key] ]. ^ lbls! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnz: aRegister with: aSourceRegisterOrMemory "Conditional Move - not zero/not equal (ZF=1) " ^ self addInstruction: #cmovnz operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/18/2012 15:26'! newInstruction ^ AJx86Instruction new! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovne: aX87Register "FP Conditional Move - not equal (ZF=0) " ^ self addInstruction: #fcmovne operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST6 "A floating point register" ^ ST6! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! shr: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Shift " ^ self addInstruction: #shr operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM0 "An SSE register" ^ XMM0! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsubr: aMemoryOperand "Reverse Subtract " ^ self addInstruction: #fsubr operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcomi: aX87Register "Compare Floating Point Values and Set EFLAGS " ^ self addInstruction: #fcomi operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnae: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovnae operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'convenience' stamp: 'CamilloBruni 4/19/2012 13:20'! dd: aByteArray self assert: aByteArray size == SizeDWord. ^ self addInstruction: (AJData data: aByteArray)! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fcmovnu: aX87Register "FP Conditional Move - not unordered (PF=0) " ^ self addInstruction: #fcmovnu operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmova: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmova operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovns: aRegister with: aSourceRegisterOrMemory "Conditional Move - not sign (SF=0) " ^ self addInstruction: #cmovns operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fimul: aMemoryOperand "Multiply " ^ self addInstruction: #fimul operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! lea: aDestinationRegister with: aSourceMemory "Load Effective Address " ^ self addInstruction: #lea operands: { aDestinationRegister . aSourceMemory }! ! !AJx86Assembler methodsFor: 'function calls' stamp: ''! newStdCall ^ stackManager newStdCall asm: self ! ! !AJx86Assembler methodsFor: 'instruction list' stamp: ''! replace: anInstruction with: otherInstructions "replace a single instruction with one or more other instructions" ^ instructions := instructions replace: anInstruction with: otherInstructions.! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EBX "A 32bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ EBX! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnp: targetLabel "Jump short if not parity/parity odd " ^ self addInstruction: #jnp operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST0 "A floating point register" ^ ST0! ! !AJx86Assembler methodsFor: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:52'! align: aByteSize self addInstruction: (AJAlignmentInstruction align: aByteSize)! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fadd: aMemoryOperand "Add " ^ self addInstruction: #fadd operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! js: targetLabel "Jump short if sign (SF=1) " ^ self addInstruction: #js operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instruction list' stamp: ''! addInstruction: anInstruction "add one or multiple instructions to the tail" instructions ifNil: [ instructions := anInstruction. ] ifNotNil: [ last := last last next: anInstruction. ]. anInstruction level: level. last := anInstruction last. ^ anInstruction ! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jz: targetLabel "Jump short if zero/equal (ZF=0) " ^ self addInstruction: #jz operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'labels' stamp: 'CamilloBruni 5/29/2012 13:06'! labelNamed: aNameOrLabel "directly use an object as label" aNameOrLabel isString ifFalse: [ self assert: (labels at: aNameOrLabel name ) = aNameOrLabel. ^ aNameOrLabel ]. ^ labels at: aNameOrLabel ifAbsentPut: [ AJJumpLabel new name: aNameOrLabel ]! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovl: aRegister with: aSourceRegisterOrMemory "Conditional Move - less/not greater (SF!!=OF) " ^ self addInstruction: #cmovl operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movups: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Unaligned Packed Single-FP Values Pseudo Code ----------- DEST = SRC; Description ----------- Moves a double quadword containing four packed single-precision floating-point values from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, store the contents of an XMM register into a 128-bit memory location, or move data between two XMM registers. When the source or destination operand is a memory operand, the operand may be unaligned on a 16-byte boundary without causing a general-protection exception (\#GP) to be generated.1 To move packed single-precision floating-point values to and from memory locations that are known to be aligned on 16-byte boundaries, use the MOVAPS instruction. While executing in 16-bit addressing mode, a linear address for a 128-bit data access that overlaps the end of a 16-bit segment is not allowed and is defined as reserved behavior. A specific processor implementation may or may not generate a general-protection exception (\#GP) in this situation, and the address that spans the end of the segment may or may not wrap around to the beginning of the segment. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). ​1. If alignment checking is enabled (CR0.AM = 1, RFLAGS.AC = 1, and CPL = 3), an alignment-check exception (\#AC) may or may not be generated (depending on processor implementation) when the operand is not aligned on an 8-byte boundary. " ^ self addInstruction: #movups operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! EAX "A 32bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ EAX! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnge: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovnge operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'converting' stamp: ''! operand: anObject anObject isInteger ifTrue: [ ^ anObject asImm ]. anObject isString ifTrue: [ ^ anObject ]. ^ anObject! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! amdprefetchw: aMemoryOperand " " ^ self addInstruction: #amdprefetchw operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovz: aRegister with: aSourceRegisterOrMemory "Conditional Move - zero/equal (ZF=0) " ^ self addInstruction: #cmovz operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'register' stamp: ''! counter ^ self is32BitMode ifTrue: [ ECX ] ifFalse: [ CX ]! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM3 "An MMX register" ^ MM3! ! !AJx86Assembler methodsFor: 'testing' stamp: ''! hasLabelNamed: aName ^ labels includesKey: aName ! ! !AJx86Assembler methodsFor: 'debugging' stamp: ''! gccDisassemble ^ self gccDisassemble: self bytes.! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movupd: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Unaligned Packed Double-FP Value Pseudo Code ----------- DEST = SRC; Description ----------- Moves a double quadword containing two packed double-precision floating-point values from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, store the contents of an XMM register into a 128-bit memory location, or move data between two XMM registers. When the source or destination operand is a memory operand, the operand may be unaligned on a 16-byte boundary without causing a general-protection exception (\#GP) to be generated.1 To move double-precision floating-point values to and from memory locations that are known to be aligned on 16-byte boundaries, use the MOVAPD instruction. While executing in 16-bit addressing mode, a linear address for a 128-bit data access that overlaps the end of a 16-bit segment is not allowed and is defined as reserved behavior. A specific processor implementation may or may not generate a general-protection exception (\#GP) in this situation, and the address that spans the end of the segment may or may not wrap around to the beginning of the segment. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). ​1. If alignment checking is enabled (CR0.AM = 1, RFLAGS.AC = 1, and CPL = 3), an alignment-check exception (\#AC) may or may not be generated (depending on processor implementation) when the operand is not aligned on an 8-byte boundary. " ^ self addInstruction: #movupd operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movdqu: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move Unaligned Double Quadword Pseudo Code ----------- DEST = SRC; 1. If alignment checking is enabled (CR0.AM = 1, RFLAGS.AC = 1, and CPL = 3), an alignment-check exception (#AC) may or may not be generated (depending on processor implementation) when the operand is not aligned on an 8-byte boundary. Description ----------- Moves a double quadword from the source operand (second operand) to the destination operand (first operand). This instruction can be used to load an XMM register from a 128-bit memory location, to store the contents of an XMM register into a 128-bit memory location, or to move data between two XMM registers. When the source or destination operand is a memory operand, the operand may be unaligned on a 16-byte boundary without causing a general-protection exception (\#GP) to be generated.1 To move a double quadword to or from memory locations that are known to be aligned on 16-byte boundaries, use the MOVDQA instruction. While executing in 16-bit addressing mode, a linear address for a 128-bit data access that overlaps the end of a 16-bit segment is not allowed and is defined as reserved behavior. A specific processor implementation may or may not generate a general-protection exception (\#GP) in this situation, and the address that spans the end of the segment may or may not wrap around to the beginning of the segment. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movdqu operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movhps: aRegisterOrMemory1 with: aRegisterOrMemory2 "Move High Packed Single-FP Values Pseudo Code ----------- (* MOVHPS instruction for memory to XMM move *) DEST[127:64] = SRC; (* DEST[63:0] unchanged *) (* MOVHPS instruction for XMM to memory move *) DEST = SRC[127:64]; Description ----------- Moves two packed single-precision floating-point values from the source operand (second operand) to the destination operand (first operand). The source and destination operands can be an XMM register or a 64-bit memory location. This instruction allows two single-precision floating-point values to be moved to and from the high quadword of an XMM register and memory. It cannot be used for register to register or memory to memory moves. When the destination operand is an XMM register, the low quadword of the register remains unchanged. In 64-bit mode, use of the REX.R prefix permits this instruction to access additional registers (XMM8-XMM15). " ^ self addInstruction: #movhps operands: { aRegisterOrMemory1 . aRegisterOrMemory2 }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fistp: aMemoryOperand "Store Integer and Pop " ^ self addInstruction: #fistp operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'register' stamp: ''! accumulator ^ self is32BitMode ifTrue: [ EAX ] ifFalse: [ AX ]! ! !AJx86Assembler methodsFor: 'accessing' stamp: ''! wordSize ^ 4! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jnge: targetLabel " " ^ self addInstruction: #jnge operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'accessing' stamp: ''! pointerSize "the default pointer size in bytes on this CPU" ^ 4! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jae: targetLabel " " ^ self addInstruction: #jae operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'CamilloBruni 4/17/2012 17:51'! addInstruction: sel description: description operands: operands ^ self addInstruction: (self newInstruction: sel description: description operands: operands)! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! popcnt: aRegister with: aSourceRegisterOrMemory "Bit Population Count Description ----------- This instruction calculates of number of bits set to 1 in the second operand (source) and returns the count in the first operand (a destination register). " ^ self addInstruction: #popcnt operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'debugging' stamp: 'CamilloBruni 7/23/2012 15:25'! gccDisassemble: bytes 'disas.sh' asFileReference delete writeStreamDo: [:s| s nextPutAll: '#!!/bin/bash'; lf; nextPutAll: 'gcc -g -O0 '; nextPutAll: (self is32 ifTrue: ['-m32'] ifFalse: [ '-m64' ]); nextPutAll: ' disas.test.c >> /dev/null 2>&1'; lf; nextPutAll: 'gdb -q -x gdb.commands a.out | grep "^0x" > disas.output'; lf]. 'gdb.commands' asFileReference delete writeStreamDo: [:s| s nextPutAll: 'b 4'; lf; nextPutAll: 'r'; lf; nextPutAll: 'x /'; print: bytes size; nextPutAll: 'xb &instructions'; lf; nextPutAll: 'x /'; print: bytes size; nextPutAll: 'ub &instructions'; lf; nextPutAll: 'disas &instructions &instructions+1'; lf; nextPutAll: 'q']. 'disas.test.c' asFileReference delete writeStreamDo: [ :f| { '#include '. 'void main() {' . 'const char instructions[]= {'. String streamContents: [:s| bytes do: [:b | s print: b] separatedBy: [ s << ', ']]. '};'. 'printf("%d", instructions);'. '}' } do: [:x | f nextPutAll: x value asString; lf ]]. Smalltalk at: #OSProcess ifPresent: [ :cls| cls waitForCommand: 'cd "', Smalltalk imagePath, '"; chmod a+x ./disas.sh; sh ./disas.sh'. ^ 'disas.output' asFileReference readStream contents asString]. self inform: 'OSProcess has to be installed to run gccDisassemble'.! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! shl: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Shift " ^ self addInstruction: #shl operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST2 "A floating point register" ^ ST2! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fisttp: aMemoryOperand "Store Integer with Truncation and Pop Pseudo Code ----------- DEST = ST; pop ST; Description ----------- FISTTP converts the value in ST into a signed integer using truncation (chop) as rounding mode, transfers the result to the destination, and pop ST. FISTTP accepts word, short integer, and long integer destinations. The following table shows the results obtained when storing various classes of numbers in integer format. ST(0) DEST --------------------------------------- ------ -∞ or Value Too Large for DEST Format \* F ≤ - 1 - I - 1 \< F \< + 1 0 F ≥ + 1 + I +∞ or Value Too Large for DEST Format \* NaN \* : FISTTP Results - Notes - F means finite floating-point value. - I means integer. - Indicates floating-point invalid-operation (\#IA) exception. This instruction's operation is the same in non-64-bit modes and 64-bit mode. " ^ self addInstruction: #fisttp operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmpxchg: aDestinationRegisterOrMemory with: aSourceRegister "Compare and Exchange Pseudo Code ----------- (* Accumulator = AL, AX, EAX, or RAX depending on whether a byte, word, doubleword, or quadword comparison is being performed *) IF accumulator = DEST ZF = 1; DEST = SRC; ELSE ZF = 0; accumulator = DEST; FI; Description ----------- Compares the value in the AL, AX, EAX, or RAX register with the first operand (destination operand). If the two values are equal, the second operand (source operand) is loaded into the destination operand. Otherwise, the destination operand is loaded into the AL, AX, EAX or RAX register. RAX register is available only in 64-bit mode. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. To simplify the interface to the processor's bus, the destination operand receives a write cycle without regard to the result of the comparison. The destination operand is written back if the comparison fails; otherwise, the source operand is written into the destination. (The processor never produces a locked read without also producing a locked write.) In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.R prefix permits access to additional registers (R8-R15). Use of the REX.W prefix promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #cmpxchg operands: { aDestinationRegisterOrMemory . aSourceRegister }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! not: aDestination "One's Complement Negation Pseudo Code ----------- DEST = NOT DEST; Description ----------- Performs a bitwise NOT operation (each 1 is set to 0, and each 0 is set to 1) on the destination operand and stores the result in the destination operand location. The destination operand can be a register or a memory location. This instruction can be used with a LOCK prefix to allow the instruction to be executed atomically. In 64-bit mode, the instruction's default operation size is 32 bits. Using a REX prefix in the form of REX.R permits access to additional registers (R8-R15). Using a REX prefix in the form of REX.W promotes operation to 64 bits. See the summary chart at the beginning of this section for encoding data and limits. " ^ self addInstruction: #not operands: { aDestination }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jno: targetLabel "Jump short if not overflow (OF=0) " ^ self addInstruction: #jno operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM6 "An MMX register" ^ MM6! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fidiv: aMemoryOperand "Divide " ^ self addInstruction: #fidiv operands: { aMemoryOperand }! ! !AJx86Assembler class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/19/2012 11:46'! noStackFrame ^ self new noStackFrame! ! !AJx86Assembler class methodsFor: 'debugging' stamp: ''! gccDisassemble: bytesArray "compile the given bytes to a C binary and disassemble it using gdb" ^ self new gccDisassemble: bytesArray! ! !AJx86AssemblerTests commentStamp: 'TorstenBergmann 2/4/2014 21:39'! SUnit tests for x86 assembler! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:22'! testAssemblyMemBaseDisp asm mov: EAX ptr + 1 -> EAX; mov: EBX ptr + ECX -> EAX. self assert: asm bytes = #(16r8B 16r40 16r01 16r8B 16r04 16r0B) asByteArray! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:22'! testBitTest asm bt: EAX with: 0. self assert: asm bytes = #(16r0F 16rBA 16rE0 16r00) asByteArray! ! !AJx86AssemblerTests methodsFor: 'utility' stamp: 'MartinMcClure 1/1/2013 22:19'! bytes: aBlock asm := self newAssembler. aBlock value: asm. ^ asm bytes! ! !AJx86AssemblerTests methodsFor: 'tests-FPU' stamp: 'CamilloBruni 7/23/2012 15:03'! testFXCH self assert: [ :a| a fxch "the same as: asm fxch: asm ST1" ] bytes: #[ 2r11011001 2r11001001 ] ! ! !AJx86AssemblerTests methodsFor: 'utility' stamp: 'CamilloBruni 8/22/2012 14:47'! assert: aBlock bytes: aByteArray self assert: (self bytes: aBlock) equals: aByteArray .! ! !AJx86AssemblerTests methodsFor: 'tests-data' stamp: 'CamilloBruni 4/12/2012 14:25'! testDataBytesAlignWord |data| data := self setUpDataBytesAlign: 2. self assert: asm bytes equals: #[144 0 16r12].! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:22'! testAssemblyMemBase asm mov: EAX ptr -> EAX; mov: ESP ptr -> EAX; mov: EBP ptr -> EAX. self assert: asm bytes = #(16r8B 0 16r8B 16r04 16r24 16r8B 16r45 16r00) asByteArray! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'MartinMcClure 12/15/2012 13:39'! testSyscall "Syscall instruction is only valid in 64-bit mode" self asmShould: [ :a | a syscall ] raise: Error! ! !AJx86AssemblerTests methodsFor: 'tests-data' stamp: ''! setUpDataBytesAlign: alignToBytes asm nop. asm align: alignToBytes. ^ asm db: 16r12.! ! !AJx86AssemblerTests methodsFor: 'tests-FPU' stamp: 'CamilloBruni 7/23/2012 15:15'! testFXCHST1 self assert: [ :a| a fxch: asm ST1 ] bytes: #[ 2r11011001 2r11001001 ] ! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:23'! testForwardJumps asm jmp: #label1; label: #label1. self assert: asm bytes = #(16rEB 0 ) asByteArray. ! ! !AJx86AssemblerTests methodsFor: 'tests-data' stamp: ''! testDataWord | data| asm nop. data := asm dw: #[16r34 16r12]. self assert: asm bytes equals: #[144 16r34 16r12]. ! ! !AJx86AssemblerTests methodsFor: 'tests-data' stamp: 'CamilloBruni 4/12/2012 14:24'! testDataBytesAlignDouble |data| data := self setUpDataBytesAlign: 4. self assert: asm bytes equals: #[144 0 0 0 16r12].! ! !AJx86AssemblerTests methodsFor: 'tests-data' stamp: 'CamilloBruni 4/12/2012 14:24'! testDataBytesAlignQuad |data| data := self setUpDataBytesAlign: 8. self assert: asm bytes equals: #[144 0 0 0 0 0 0 0 16r12].! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:22'! testAssembly3 " instructions without operands. (AJInstructionDescription instructions select: [:each | each group = #emit]) keys asSortedCollection " | str | str := #( #cbw 16r66 16r98 #cdq 16r99 "#cdqe 64 bit " #clc 16rF8 #cld 16rFC #cmc 16rF5 #cpuid 16r0F 16rA2 "#cqo 64 bit " #cwd 16r66 16r99 #cwde 16r98 #daa 16r27 #das 16r2F #emms 16r0F 16r77 #f2xm1 16rD9 16rF0 #fabs 16rD9 16rE1 #fchs 16rD9 16rE0 #fclex 16r9B 16rDB 16rE2 #fcompp 16rDE 16rD9 #fcos 16rD9 16rFF #fdecstp 16rD9 16rF6 #fincstp 16rD9 16rF7 #finit 16r9B 16rDB 16rE3 #fld1 16rD9 16rE8 #fldl2e 16rD9 16rEA #fldl2t 16rD9 16rE9 #fldlg2 16rD9 16rEC #fldln2 16rD9 16rED #fldpi 16rD9 16rEB #fldz 16rD9 16rEE #fnclex 16rDB 16rE2 #fninit 16rDB 16rE3 #fnop 16rD9 16rD0 #fpatan 16rD9 16rF3 #fprem 16rD9 16rF8 #fprem1 16rD9 16rF5 #fptan 16rD9 16rF2 #frndint 16rD9 16rFC #fscale 16rD9 16rFD #fsin 16rD9 16rFE #fsincos 16rD9 16rFB #fsqrt 16rD9 16rFA #ftst 16rD9 16rE4 #fucompp 16rDA 16rE9 #fwait 16r9B #fxam 16rD9 16rE5 #fxtract 16rD9 16rF4 #fyl2x 16rD9 16rF1 #fyl2xp1 16rD9 16rF9 #int3 16rCC #leave 16rC9 #lfence 16r0F 16rAE 16rE8 #lock 16rF0 "prefix" #mfence 16r0F 16rAE 16rF0 #monitor 16r0F 16r01 16rC8 #mwait 16r0F 16r01 16rC9 #nop 16r90 #pause 16rF3 16r90 #popad 16r61 #popfd 16r9D " #popfq 16r48 16r9D - 64 bit " #pushad 16r60 #pushf 16r66 16r9C #pushfd 16r9C " #pushfq -64 bit" #rdtsc 16r0F 16r31 #rdtscp 16r0F 16r01 16rF9 #sahf 16r9E #sfence 16r0F 16rAE 16rF8 #stc 16rF9 #std 16rFD #ud2 16r0F 16r0B #std 16rFD "dummy" ) readStream. [ str atEnd ] whileFalse: [ | instr tst | instr := str next. tst := OrderedCollection new. [ str peek isInteger ] whileTrue: [ tst add: str next ]. asm reset noStackFrame. asm perform: instr. self assert: (asm bytes = tst asByteArray ) ]. ! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:23'! testMovSxZx asm movsx: asm AX to: asm EAX; movzx: asm AX to: asm EAX; movsx: asm AL to: asm EAX; movzx: asm AH to: asm EAX. self assert: asm bytes = #[ 16r0F 16rBF 16rC0 16r0F 16rB7 16rC0 16r0F 16rBE 16rC0 16r0F 16rB6 16rC4 ] ! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:22'! testAssembly1 asm push: EBP; mov: ESP -> EBP; mov: 1024 -> EAX; mov: EBP -> ESP; pop: EBP; ret. self assert: asm bytes = #(85 139 236 184 0 4 0 0 139 229 93 195) asByteArray! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 8/22/2012 14:50'! testJMPRegister self assert: [ :assembler | assembler jmp: assembler EAX ] bytes: #[ 16rFF 2r11100000 ]. self assert: [ :assembler | assembler jmp: assembler ECX ] bytes: #[ 16rFF 2r11100001 ]. self assert: [ :assembler | assembler jmp: assembler EDX ] bytes: #[ 16rFF 2r11100010 ]! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'IgorStasenko 5/28/2012 02:58'! testAssemblyImmAddr "test generating immediate address, note GDB disassembling it to: 0x1fab : 0x8b 0x05 0xef 0xbe 0xad 0xde 0x00001fab : mov 0xdeadbeef,%eax which is WRONG!! " asm mov: 16rdeadbeef asUImm ptr32 to: asm EAX. " 8b05efbeadde mov eax, [deadbeef] " self assert: asm bytes = #[139 5 239 190 173 222] ! ! !AJx86AssemblerTests methodsFor: 'running' stamp: ''! setUp super setUp. asm := self newAssembler.! ! !AJx86AssemblerTests methodsFor: 'tests-data' stamp: 'CamilloBruni 4/19/2012 11:51'! testDataDouble | data| asm nop. data := asm dd: #[16r78 16r56 16r34 16r12]. self assert: asm bytes equals: #[144 16r78 16r56 16r34 16r12].! ! !AJx86AssemblerTests methodsFor: 'tests-data' stamp: 'CamilloBruni 4/12/2012 14:25'! setUpDataBytes ^ self setUpDataBytesAlign: 1! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:22'! testAssemblyMemBytes asm mov: ((ESI ptr + ECX) size: 1) -> BL; mov: BL -> ((ESI ptr + ECX) size:1). self assert: asm bytes = #(16r8A 16r1C 16r0E 16r88 16r1C 16r0E ) asByteArray! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:22'! testCall asm call: EAX; call: EAX ptr - 4; call: EAX ptr. self assert: asm bytes = #(255 208 255 80 252 255 16) asByteArray! ! !AJx86AssemblerTests methodsFor: 'tests-data' stamp: ''! testDataBytes |data| data := self setUpDataBytes. self assert: asm bytes equals: #[144 16r12].! ! !AJx86AssemblerTests methodsFor: 'utility' stamp: ''! asmShould: aBlock raise: anError self should: [self bytes: aBlock] raise: anError.! ! !AJx86AssemblerTests methodsFor: 'utility' stamp: 'CamilloBruni 4/3/2012 09:56'! newAssembler ^ AJx86Assembler new noStackFrame; yourself! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:23'! testJumps asm label: #label1; nop; nop; nop; jz: #label1. self assert: asm bytes = #(144 144 144 116 251) asByteArray. asm reset; noStackFrame; label: #label1. 126 timesRepeat: [ asm nop ]. asm jz: #label1. self assert: (asm bytes size = 128). asm reset; noStackFrame; label: #label1; nop; nop; nop; jmp: #label1. self assert: asm bytes = #(144 144 144 235 251) asByteArray. asm reset; noStackFrame; jmp: #label1; label: #label1. self assert: asm bytes = #(16rEB 0 ) asByteArray. ! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:22'! testAssemblyMemBaseDisp2 asm mov: EAX ptr - 1 -> EAX; mov: EBX ptr + ECX * 2 - 5 -> EAX. self assert: asm bytes = #(16r8B 16r40 16rFF 16r8B 16r44 16r4B 16rFB) asByteArray! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:23'! testTest "Special RAX opcodes" "8bit operand opcode" asm test: AL with: 5. self assert: asm bytes = #[16rA8 05]. asm reset; test: AX with: 5. "16bit operand Prefix byte, 16bit immediate (LSB)" self assert: asm bytes = #[16r66 16rA9 05 0]. "32bit operand " asm reset; test: EAX with: 1. self assert: asm bytes = #[16rA9 01 00 00 00]. "Need more assert for non-EAX receiver, non-immediate operands" ! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: 'CamilloBruni 4/3/2012 10:23'! testImmLabels "test immediates with labels" | code pos | asm mov: EAX ptr -> EAX; mov: (16rFFFFFFFF asUImm label: (asm labelNamed: #foo) ) to: EAX. code := asm generatedCode. pos := code offsetAt: #foo. self assert: (code bytes at: pos+1) = 255. self assert: (code bytes at: pos+2) = 255. self assert: (code bytes at: pos+3) = 255. self assert: (code bytes at: pos+4) = 255. ! ! !AJx86AssemblerTests methodsFor: 'tests' stamp: ''! testRegistersOf: asm | numRegs | numRegs := asm numGPRegisters. 0 to: numRegs-1 do: [:i | self assert: (asm reg8: i) size = 1. self assert: (asm reg8: i) index = i. self assert: (asm reg16: i) size = 2. self assert: (asm reg16: i) index = i. self assert: (asm reg32: i) size = 4. self assert: (asm reg32: i) index = i. self assert: (asm isGPNRegister: (asm nReg: i)). asm is64BitMode ifTrue: [ self assert: (asm reg64: i) size = 8. self assert: (asm reg64: i) index = i. ] ]. ! ! !AJx86GPRegister commentStamp: 'sig 12/7/2009 03:22'! A general purpose x86 & x64 registers! !AJx86GPRegister methodsFor: 'converting' stamp: 'MartinMcClure 1/30/2013 21:44'! as64 ^ self isHighByte ifTrue: [ self asLowByte as64 ] ifFalse: [ AJx86Registers generalPurposeWithIndex: self index size: 8 requiresRex: self index > 7 prohibitsRex: false ]! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'MartinMcClure 1/30/2013 21:43'! as32 ^ self isHighByte ifTrue: [ self asLowByte as32 ] ifFalse: [ AJx86Registers generalPurposeWithIndex: self index size: 4 requiresRex: self index > 7 prohibitsRex: false ]! ! !AJx86GPRegister methodsFor: 'testing' stamp: 'MartinMcClure 1/30/2013 21:55'! isLowByte "return true for 8bit low-byte register (AL - DL)" "Note that this does *not* answer true for all byte registers -- send #is8 for that." ^ self code <= 3! ! !AJx86GPRegister methodsFor: 'printing' stamp: 'MartinMcClure 1/1/2013 18:55'! printAsMemBaseOn: aStream aStream nextPutAll: self registerName ! ! !AJx86GPRegister methodsFor: 'converting' stamp: ''! ptr "turn receiver into a memory operand with receiver as base" ^ AJMem new base: self! ! !AJx86GPRegister methodsFor: 'accessing' stamp: 'CamilloBruni 3/20/2012 18:48'! registerName ^ name asString.! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'MartinMcClure 1/30/2013 21:46'! asLowByte self isLowByte ifTrue: [ ^ self ]. self isHighByte ifFalse: [ Error signal: 'Can only convert high byte 8bit register to low byte' ]. ^ AJx86Registers generalPurposeWithIndex: self index - 2r100 size: 1 requiresRex: false prohibitsRex: false! ! !AJx86GPRegister methodsFor: 'emitting' stamp: ''! emitModRM: emitter code: rCode immSize: immSize "Receiver is register, hence mod = 3 immSize is ignored" ^ emitter emitMod: 3 reg: rCode rm: self code! ! !AJx86GPRegister methodsFor: 'accessing' stamp: ''! stackSize ^ self size! ! !AJx86GPRegister methodsFor: 'testing' stamp: 'MartinMcClure 1/30/2013 21:33'! isHighByte "return true for 8bit high-byte registers (AH - DH)" ^ self prohibitsRex! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'MartinMcClure 1/30/2013 21:40'! as8 "8-bit low-byte registers require REX if they have a high index (>7), or if they are one of BPL, SIL, DIL, SPL (indices 4-7). The only way to get AH, BH, CH, or DH out of this method is to send it to one of those registers." ^ self is8 ifTrue: [ self ] ifFalse: [ AJx86Registers generalPurposeWithIndex: self index size: 1 requiresRex: self index > 3 prohibitsRex: false ]! ! !AJx86GPRegister methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 11:07'! descriptionOn: s s nextPutAll: 'A '; print: self size * 8; nextPutAll: 'bit general purpose register'.! ! !AJx86GPRegister methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: self registerName ! ! !AJx86GPRegister methodsFor: 'testing' stamp: ''! isGeneralPurpose ^ true! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'MartinMcClure 1/30/2013 21:42'! as16 ^ self isHighByte ifTrue: [ self asLowByte as16 ] ifFalse: [ AJx86Registers generalPurposeWithIndex: self index size: 2 requiresRex: self index > 7 prohibitsRex: false ]! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'MartinMcClure 1/30/2013 21:53'! asHighByte self isHighByte ifTrue: [ ^ self ]. self isLowByte ifFalse: [ Error signal: 'Can only convert AH, BH, CH, or DH to high byte' ]. ^ AJx86Registers generalPurposeWithIndex: self index + 2r100 size: 1 requiresRex: false prohibitsRex: true! ! !AJx86Instruction commentStamp: 'TorstenBergmann 1/30/2014 09:17'! The x86 machine instructions! !AJx86Instruction methodsFor: 'code generation' stamp: ''! emitQWord: dword "Emit a qword (8 bytes) in little-endian order (since our target it x86 anyways)" self emitByte: (dword bitAnd: 255); emitByte: (dword>>8 bitAnd: 255); emitByte: (dword>>16 bitAnd: 255); emitByte: (dword>>24 bitAnd: 255); emitByte: (dword>>32 bitAnd: 255); emitByte: (dword>>40 bitAnd: 255); emitByte: (dword>>48 bitAnd: 255); emitByte: (dword>>56 bitAnd: 255) ! ! !AJx86Instruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:55'! description ^ description! ! !AJx86Instruction methodsFor: 'code generation' stamp: ''! emitRexR: w opReg: opReg regCode: regCode "no-op in 32 bit mode" ! ! !AJx86Instruction methodsFor: 'code generation' stamp: ''! setLabelPosition: label "set label position for immediate operand(s), if any" label position: self position + machineCode size. ! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'MartinMcClure 1/4/2013 22:14'! emitRexForOp1: op1 op2: op2 "op1 is the general-purpose register argument (or a register number). op2 is the reg/mem argument. In 64-bit mode, the instruction's default operation size is 32 bits. Use of the REX.W prefix promotes operation to 64 bits. Use of the REX.R prefix permits access to additional registers (R8-R15) for the op1 (reg) register. Use of the REX.B prefix permits access to additional registers (R8-R15) for the op2 (r/m) register, or the base register of op2 if register indirect. Use of the REX.X prefix permits access to additional registers (R8-R15) for the index register of op2, if indexed. See the summary chart at the beginning of this section for encoding data and limits." | requires64Bit | "no-op in 32 bit mode" self is32BitMode ifTrue: [ ^ self ]. op1 isInteger ifTrue: [ ^ self emitRexForInteger: op1 op2: op2 ]. requires64Bit := op1 is64 or: [ op2 isReg and: [ op2 is64 ] ]. self emitRexPrefixW: requires64Bit R: op1 isUpperBank X: op2 hasUpperBankIndex B: op2 isUpperBank! ! !AJx86Instruction methodsFor: 'code generation' stamp: ''! emitOpCode: opCode | byte | "instruction prefix" (byte := (opCode bitAnd: 16rFF000000)) = 0 ifFalse: [ self emitByte: byte >> 24 ]. (byte := (opCode bitAnd: 16r00FF0000)) = 0 ifFalse: [ self emitByte: byte >> 16 ]. (byte := (opCode bitAnd: 16r0000FF00)) = 0 ifFalse: [ self emitByte: byte >> 8 ]. self emitByte: (opCode bitAnd: 16rFF). ! ! !AJx86Instruction methodsFor: 'emitting code' stamp: ''! emitWord: aWord "little-endian" self emitByte: (aWord bitAnd: 255); emitByte: ((aWord >> 8) bitAnd: 255) ! ! !AJx86Instruction methodsFor: 'testing' stamp: ''! is64BitMode ^ false! ! !AJx86Instruction methodsFor: 'visitor' stamp: ''! accept: anObject "generic instruction" ^ anObject visitInstruction: self ! ! !AJx86Instruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:55'! description: anInstructionDescription description := anInstructionDescription! ! !AJx86Instruction methodsFor: 'code generation' stamp: ''! emitRexForInteger: anInt op2: op2 self emitRexPrefixW: op2 is64 R: false X: false B: op2 isUpperBank.! ! !AJx86Instruction methodsFor: 'testing' stamp: ''! is32BitMode ^ true! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 3/30/2012 17:10'! emitX86Inl: opCode reg: reg "Emit instruction where register is inlined to opcode." ^ self emitX86Inl: opCode reg: reg withRex: true! ! !AJx86Instruction methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 15:47'! requiresRex ^false! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 4/4/2012 17:10'! emitRexRM: opRequires64Bit regCode: regCode rm: rm self emitRexPrefixW: opRequires64Bit R: (regCode > 7) X: false B: rm isUpperBank ! ! !AJx86Instruction methodsFor: 'consistency' stamp: 'MartinMcClure 2/9/2013 14:15'! checkOperandsForConflict "Signal an error if the given operands cannot be used together. Must be sent after operands are set." | prohibited required | required := self requiresRex. prohibited := false. operands do: [ :op | (op isInteger not and: [ op prohibitsRex ]) ifTrue: [ prohibited := true ] ]. prohibited & required ifTrue: [ self error: 'Mix of operands that require and prohibit a REX prefix' ]! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 3/28/2012 15:59'! emitMod: mod reg: reg rm: rm "Emit MODR/M byte. mmrrrxxx mm = mod rrr = REG (r8/r16/r32/mm/xmm xxx = r/m " ^ self emitByte: (mod & 3) << 3 + (reg & 7) << 3 + (rm & 7) ! ! !AJx86Instruction methodsFor: 'accessing' stamp: 'CamilloBruni 8/23/2012 16:01'! instructionDesciptions ^ AJx86InstructionDescription instructions! ! !AJx86Instruction methodsFor: 'code generation - prefixes' stamp: 'CamilloBruni 3/30/2012 17:07'! emitOperandSizeOverridePrefix: anOperand "If creating 64bit code, this must be called last of the prefix-generators, as the 64-bit prefixes are required to precede the opcode" "Switch to 16-bit operand mode for the next opcode if necessary" anOperand is16 ifTrue: [ self emitByte: 16r66]. self emitRexRM: anOperand is64 regCode: 0 rm: anOperand ! ! !AJx86Instruction methodsFor: 'code generation' stamp: ''! emitRexForSingleOperand: op "In 64-bit mode, the instruction’s default operation size is 32 bits. Use of the REX.W prefix promotes operation to 64 bits. Use of the REX.B prefix permits access to additional registers (R8-R15). See the summary chart at the beginning of this section for encoding data and limits." self emitRexPrefixW: op is64 R: false X: false B: op isUpperBank .! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 4/17/2012 17:56'! emitCode: asm "do not generate machine code if it is already there" machineCode ifNotNil: [ ^ self ]. "make sure all operands are converted" operands ifNotNil: [ operands := operands collect: #asAJOperand ]. machineCode := WriteStream on: (ByteArray new: 16). description emitUsing: self operands: operands. machineCode := machineCode contents.! ! !AJx86Instruction methodsFor: 'code generation' stamp: ''! emitDWord: dword "Emit dword (4 bytes) in little-endian order (since our target it x86 anyways)" self emitByte: (dword bitAnd: 255); emitByte: (dword>>8 bitAnd: 255); emitByte: (dword>>16 bitAnd: 255); emitByte: (dword>>24 bitAnd: 255) ! ! !AJx86Instruction methodsFor: 'code generation' stamp: ''! emitImmediate: imm size: size ^ imm emitUsing: self size: size! ! !AJx86Instruction methodsFor: 'code generation' stamp: ''! emitSegmentPrefix: aMem (aMem isMem and: [ aMem hasSegmentPrefix ]) ifTrue: [ self emitByte: aMem segmentPrefixCode. ] ! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 3/30/2012 16:50'! emitX86RM: opCode size: aSize regOrCode: regOrCode rm: regOrMem immSize: immSize "Emit instruction with reg/memory operand." | byte code | code := regOrCode isInteger ifTrue: [ regOrCode ] ifFalse: [ regOrCode code ]. "16 bit prefix" aSize == 2 ifTrue: [ self emitByte: 16r66 ]. "segment prefix" self emitSegmentPrefix: regOrMem. "instruction prefix" (byte := (opCode bitAnd: 16rFF000000)) = 0 ifFalse: [ self emitByte: byte >> 24 ]. self emitRexForOp1: regOrCode op2: regOrMem. (byte := (opCode bitAnd: 16r00FF0000)) = 0 ifFalse: [ self emitByte: byte >> 16 ]. (byte := (opCode bitAnd: 16r0000FF00)) = 0 ifFalse: [ self emitByte: byte >> 8 ]. self emitByte: (opCode bitAnd: 16rFF). "ModR/M" ^ regOrMem emitModRM: self code: code immSize: immSize ! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'MartinMcClure 1/27/2013 16:24'! emitRexPrefixW: w R: r X: x B: b " field bit def - 7-4 2r0100 REX prefix identifier W 3 0 = Operand size determined by CS.D 1 = 64 Bit Operand Size R 2 Extension of the ModR/M reg field X 1 Extension of the SIB index field B 0 Extension of the ModR/M r/m field. SIB base field, or Opcode reg field " self requiresRex ifTrue: [ self is32BitMode ifTrue: [ self error: 'Attempt to use a 64-bit-specific instruction or operand in 32-bit mode' ] ifFalse: [ self emitByte: 2r0100 << 4 | (w asBit << 3) | (r asBit << 2) | (x asBit << 1) | b asBit ] ]! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'CamilloBruni 3/29/2012 13:54'! emitByte: byte self assert: byte isByte. machineCode nextPut: byte ! ! !AJx86Instruction methodsFor: 'code generation' stamp: ''! emitX86Inl: opCode reg: reg withRex: useREX "Emit instruction where register is inlined to opcode." | byte | "16 bit prefix" reg size == 2 ifTrue: [ self emitByte: 16r66 ]. "instruction prefix" (byte := (opCode bitAnd: 16rFF000000)) = 0 ifFalse: [ self emitByte: byte >> 24 ]. useREX ifTrue: [ self emitRexForSingleOperand: reg ]. (byte := (opCode bitAnd: 16r00FF0000)) = 0 ifFalse: [ self emitByte: byte >> 16 ]. (byte := (opCode bitAnd: 16r0000FF00)) = 0 ifFalse: [ self emitByte: byte >> 8 ]. self emitByte: (opCode bitAnd: 16rFF) + (reg code bitAnd: 7). ! ! !AJx86Instruction methodsFor: 'code generation' stamp: ''! emitX86RM: opCode size: aSize regOrCode: regOrCode rm: regOrMem "Emit instruction with reg/memory operand." ^ self emitX86RM: opCode size: aSize regOrCode: regOrCode rm: regOrMem immSize: 0 ! ! !AJx86Instruction methodsFor: 'code generation' stamp: 'MartinMcClure 1/4/2013 22:27'! emitScale: shift index: indexCode base: baseCode self emitByte: ((shift << 3) + (indexCode bitAnd: 7) << 3) + (baseCode bitAnd: 7)! ! !AJx86Instruction methodsFor: 'testing' stamp: ''! isGPNRegister: reg "answer true if given register is native general purpose register, matching the target native size i.e. 32 bits for x86 or 64 bits for x64" ^ reg isGeneralPurpose and: [ reg size = 4 ]! ! !AJx86InstructionDescription commentStamp: 'sig 12/7/2009 10:36'! name: an instruction mnemonic group: an instruction encoding group o1Flags: operand1 flags o2Flags: operand2 flags opCode1: opcode 1 opCode2: opcode 2 opCodeR: code for inlining in MR field as register Operand flags: bit: 9 | 8 | 7 | 6 | 5 | 4 | 3 | 2 | 1 | 0 | ______________________________________________ *86| *64 | XMM | MM | IMM | MEM | 64 | 32 | 16 | 8| - *64 , set on o1Flags, meaning that instruction available only for x64 processor mode - *86 , set on o1Flags, meaning that instruction available only for x86 processor mode ! !AJx86InstructionDescription methodsFor: 'emitting-dispatch' stamp: 'CamilloBruni 3/30/2012 17:05'! emitUsing: emitter operands: operands |args| (self is64BitOnly and: [ emitter is64BitMode not ]) ifTrue: [ self error: 'instruction ', self name asUppercase,' is only for 64 bit mode' ]. (self is32BitOnly and: [ emitter is32BitMode not ]) ifTrue: [ self error: 'instruction ', self name asUppercase,' is only for 32 bit mode' ]. "manually create the arguments array" args := Array new: 4. args at: 1 put: emitter. args replaceFrom: 2 to: (operands size + 1 min: 4) with: operands startingAt: 1. ^ self perform: groupEmitSelector withArguments: args! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: 'CamilloBruni 4/13/2012 15:44'! comment: aString comment := aString! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! opCode2 "Answer the value of opCode2" ^ opCode2! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: 'CamilloBruni 4/13/2012 14:51'! description ^ description! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmmuMov: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented. self assert: o1Flags ~= 0. self assert: o2Flags ~= 0. "Check parameters (X)MM|GP32_64 <- (X)MM|GP32_64|Mem|Imm" (op1 isMem & ((o1Flags bitAnd: OMEM) = 0)) | (op1 isRegTypeMM & ((o1Flags bitAnd: OMM) = 0)) | (op1 isRegTypeXMM & ((o1Flags bitAnd: OXMM) = 0)) | (op1 isRegTypeGPD & ((o1Flags bitAnd: OG32) = 0)) | (op1 isRegTypeGPQ & ((o1Flags bitAnd: OG64) = 0)) | (op2 isRegTypeMM & ((o2Flags bitAnd: OMM) = 0)) | (op2 isRegTypeXMM & ((o2Flags bitAnd: OXMM) = 0)) | (op2 isRegTypeGPD & ((o2Flags bitAnd: OG32) = 0)) | (op2 isRegTypeGPQ & ((o2Flags bitAnd: OG64) = 0)) | (op2 isMem & ((o2Flags bitAnd: OMEM) = 0)) | (op1 isMem & op2 isMem) ifTrue: [ self invalidInstruction ]. ! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmmuPextr: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmovbe: anAJx86Assembler operand1: anUndefinedObject operand2: anUndefinedObject3 operand3: anUndefinedObject4 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmovSxZx: emitter operand1: dst operand2: src operand3: op3 dst isReg & src isRegMem ifFalse: [ self invalidInstruction ]. dst isRegTypeGPB ifTrue: [ self invalidInstruction ]. (src size ~= 2 and: [src size ~= 1 ]) ifTrue: [ self invalidInstruction ]. (src size = 2 and: [dst isRegTypeGPW ]) ifTrue: [ self invalidInstruction ]. src size = 2 ifTrue: [ ^ emitter emitX86RM: opCode1 + 1 size: dst size regOrCode: dst rm: src ]. emitter emitX86RM: opCode1 size: dst size regOrCode: dst rm: src ! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitshldShrd: emitter operand1: dst operand2: src1 operand3: src2 (src2 isImm or: [ src2 isRegTypeGPB and: [ src2 index = 1 "cl"]]) ifFalse: [ self invalidInstruction ]. dst isRegMem & src1 isReg ifFalse: [ self invalidInstruction ]. self assert: (dst size = src1 size). emitter emitX86RM: opCode1 + src2 isReg asBit size: src1 size regOrCode: src1 rm: dst immSize: src2 isImm asBit. src2 isImm ifTrue: [ emitter emitImmediate: src2 size: 1 ]! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitx87mem: emitter operand1: m operand2: op2 operand3: op3 | opCode mod | m isMem ifFalse: [ ^ self invalidInstruction ]. opCode := mod := 0. (m is16 and: [ (o1Flags bitAnd: OFM2) ~= 0 ]) ifTrue: [ opCode := (opCode1 bitAnd: 16rFF000000) >> 24. mod := opCodeR ]. (m is32 and: [ (o1Flags bitAnd: OFM4) ~= 0 ]) ifTrue: [ opCode := (opCode1 bitAnd: 16r00FF0000) >> 16. mod := opCodeR ]. (m is64 and: [ (o1Flags bitAnd: OFM8) ~= 0 ]) ifTrue: [ opCode := (opCode1 bitAnd: 16r0000FF00) >> 8. mod := (opCode1 bitAnd: 16r000000FF) ]. opCode = 0 ifTrue: [ self invalidInstruction ]. emitter emitSegmentPrefix: m; emitByte: opCode. m emitModRM: emitter code: mod immSize: 0. ! ! !AJx86InstructionDescription methodsFor: 'testing' stamp: ''! is32BitOnly ^ (o1Flags bitAnd: 2r1000000000) ~= 0! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmovPtr: emitter operand1: op1 operand2: op2 operand3: op3 | reg imm opCode | (op1 isReg & op2 isImm) | (op1 isImm & op2 isReg) ifFalse: [ self invalidInstruction ]. opCode := op1 isReg ifTrue: [reg := op1. imm := op2. 16rA0] ifFalse: [reg := op2. imm := op1. 16rA2]. reg index ~= 0 ifTrue: [ self invalidInstruction ]. reg isRegTypeGPW ifTrue: [ emitter emitByte: 16r66 ]. emitter emitRexR: (reg size=8) opReg: 0 regCode: 0. emitter emitByte: opCode + (reg size ~=1) asBit. emitter emitImmediate: imm size: reg size ! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: 'CamilloBruni 4/13/2012 15:44'! comment ^ comment! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitjmp: emitter operand1: target operand2: op2 operand3: op3 target isString ifTrue: [ "jump on label" ^ emitter addJump: target condition: nil hint: nil ]. target isRegMem ifTrue: [ ^ emitter emitX86RM: 16rFF size: 0 regOrCode: 4 rm: target ]. emitter emitByte: 16rE9. emitter emitDisplacement: target inlinedDisp: -4 ! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! opCode1: anObject "Set the value of opCode1" opCode1 := anObject! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitcrc32: emitter operand1: dst operand2: src operand3: op3 (dst isReg and: [ src isRegMem ]) ifTrue: [ self assert: (dst isRegTypeGPD | dst isRegTypeGPQ). ^ emitter emitX86RM: opCode1 + (src size ~= 1) asBit size: src size regOrCode: dst rm: src ]. self invalidInstruction. ! ! !AJx86InstructionDescription methodsFor: 'testing' stamp: ''! is64BitOnly ^ (o1Flags bitAnd: 2r100000000) ~= 0! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! o2Flags: anObject "Set the value of o2Flags" o2Flags := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: 'CamilloBruni 4/13/2012 14:51'! description: aString description := aString! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmem: emitter operand1: op1 operand2: op2 operand3: op3 op1 isMem ifFalse: [ self invalidInstruction ]. self assert: (opCode2 = 0 or: [ opCode2 = 1 ]). emitter emitX86RM: opCode1 size: opCode2 << 3 regOrCode: opCodeR rm: op1 ! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! opCodeR: anObject "Set the value of opCodeR" opCodeR := anObject! ! !AJx86InstructionDescription methodsFor: 'initialize-release' stamp: ''! fromArray: arr | tmp | name := arr at: 1. group := arr at: 2. groupEmitSelector := ('emit', group,':operand1:operand2:operand3:') asSymbol. tmp := arr at: 3. tmp isSymbol ifTrue: [ tmp := self translateSymFlag: tmp ]. o1Flags := tmp. o2Flags := arr at: 4. opCodeR := arr at: 5. opCode1 := arr at: 6. opCode2 := arr at: 7.! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! o1Flags "Answer the value of o1Flags" ^ o1Flags! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! group ^ group! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitalu: emitter operand1: op1 operand2: op2 operand3: op3 | opCode opReg | opCode := opCode1. opReg := opCodeR. " Mem <- Reg " (op1 isMem and: [ op2 isReg ]) ifTrue: [ ^ emitter emitX86RM: opCode + op2 isRegTypeGPB not asBit size: op2 size regOrCode: op2 rm: op1 ]. "Reg <- Reg|Mem" (op1 isReg and: [op2 isRegMem]) ifTrue: [ ^ emitter emitX86RM: opCode + 2 + op1 isRegTypeGPB not asBit size: op1 size regOrCode: op1 rm: op2 ]. op2 isImm ifFalse: [ self invalidInstruction ]. "short constant" op2 isInt8 ifTrue: [ | szBits | szBits := op1 size = 1 ifTrue: [ 0 ] ifFalse: [ 3 ]. emitter emitX86RM: opCode2 + szBits size: op1 size regOrCode: opReg rm: op1 immSize: 1. ^ emitter emitImmediate: op2 size: 1. ]. " AL, AX, EAX, RAX register shortcuts" (op1 isRegIndex: 0) ifTrue: [ op1 isRegTypeGPW ifTrue: [ emitter emitByte: 16r66 " 16 bit " ]. op1 isRegTypeGPQ ifTrue: [ emitter emitByte: 16r48 " REX.W" ]. emitter emitByte: (opReg << 3 bitOr: (16r04 + op1 isRegTypeGPB not asBit)). ^ emitter emitImmediate: op2 size: (op1 size min: 4) ]. (op1 isRegMem) ifTrue: [ | immSize szBits | immSize := op2 isInt8 ifTrue: [1] ifFalse: [ op1 size min: 4]. szBits := op1 size ~= 1 ifTrue: [ immSize ~= 1 ifTrue: [1] ifFalse: [3]] ifFalse: [ 0]. emitter emitX86RM: opCode2 + szBits size: op1 size regOrCode: opReg rm: op1 immSize: immSize. ^ emitter emitImmediate: op2 size: immSize. ]. self invalidInstruction. ! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! o2Flags "Answer the value of o2Flags" ^ o2Flags! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 4/17/2012 19:02'! emitimul: emitter operand1: op1 operand2: op2 operand3: op3 | immSize | op1 isRegMem ifFalse: [ ^ self invalidInstruction ]. " 1 operand " (op2 isNil and: [ op3 isNil ]) ifTrue: [ ^ emitter emitX86RM: 16rF6 + (op1 size ~= 1) asBit size: op1 size regOrCode: 5 rm: op1 ]. op1 isReg ifFalse: [ ^ self invalidInstruction ]. "2 operands" op3 isNil ifTrue: [ " self assert: op1 isRegTypeGPW." op2 isRegMem ifTrue: [ ^ emitter emitX86RM: 16r0FAF size: op1 size regOrCode: op1 code rm: op2 ]. op2 isImm ifFalse: [ ^ self invalidInstruction ]. (op2 isInt8 and: [ op2 relocMode == #RelocNone ]) ifTrue: [ emitter emitX86RM: 16r6B size: op1 size regOrCode: op1 code rm: op1 immSize: 1. ^ emitter emitImmediate: op2 size: 1. ]. immSize := op1 isRegTypeGPW ifTrue: [ 2 ] ifFalse: [ 4 ]. emitter emitX86RM: 16r69 size: op1 size regOrCode: op1 code rm: op1 immSize: immSize. ^ emitter emitImmediate: op2 size: immSize. ]. " 3 operands " (op2 isRegMem and: [op3 isImm ]) ifFalse: [ ^ self invalidInstruction ]. (op3 isInt8 and: [ op3 relocMode == #RelocNone ]) ifTrue: [ emitter emitX86RM: 16r6B size: op1 size regOrCode: op1 rm: op2 immSize: 1. ^ emitter emitImmediate: op3 size: 1. ]. immSize := op1 isRegTypeGPW ifTrue: [2] ifFalse: [4]. emitter emitX86RM: 16r69 size: op1 size regOrCode: op1 rm: op2 immSize: immSize. emitter emitImmediate: op3 size: immSize. ! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmmuMovD: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'code emitting' stamp: 'MartinMcClure 1/30/2013 22:13'! emittest: emitter operand1: op1 operand2: op2 operand3: op3 | immSize | op1 isRegMem & op2 isReg ifTrue: [ op1 size notNil & (op1 size ~= op2 size) ifTrue: [ self error: 'Operands ' , op1 asString , ' and ' , op2 asString , ' don''t match in size: ' , op1 size asString , ' !!= ' , op2 size asString ]. ^ emitter emitX86RM: 16r84 + op2 isRegTypeGPB not asBit size: op2 size regOrCode: op2 rm: op1 ]. (op1 isReg and: [ op1 index = 0 and: [ op2 isImm ] ]) ifTrue: [ immSize := op1 size min: 4. op1 is16 ifTrue: [ emitter emitByte: 16r66 "16bit" ]. emitter emitRexRM: op1 is64 regCode: 0 rm: op1. emitter emitByte: 16rA8 + (op1 size ~= 1) asBit. ^ emitter emitImmediate: op2 size: immSize ]. (op1 isRegMem and: [ op2 isImm ]) ifFalse: [ self invalidInstruction ]. immSize := op1 size min: 4. (op2 fitsInSize: immSize) ifFalse: [ self invalidInstruction ]. emitter emitSegmentPrefix: op1. emitter emitOperandSizeOverridePrefix: op1. emitter emitByte: 16rF6 + (op1 size ~= 1) asBit. op1 emitModRM: emitter code: 0 immSize: immSize. emitter emitImmediate: op2 size: immSize! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmmuPrefetch: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitx87fstsw: anAJx86Assembler operand1: anUndefinedObject operand2: anUndefinedObject3 operand3: anUndefinedObject4 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitret: emitter operand1: op1 operand2: op2 operand3: op3 op1 ifNil: [ ^ emitter emitByte: 16rC3 ]. op1 isImm ifFalse: [ self invalidInstruction ]. self assert: (op1 isUnsigned and: [op1 fitsInSize: 2]). (op1 value = 0 and: [ op1 relocMode == #RelocNone ]) ifTrue: [ ^ emitter emitByte: 16rC3 ]. emitter emitByte: 16rC2. emitter emitImmediate: op1 size: 2! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitx87memSti: emitter operand1: op1 operand2: op2 operand3: op3 op1 isRegTypeX87 ifTrue: [ emitter emitByte: (opCode2 bitAnd: 16rFF000000)>>24. emitter emitByte: (opCode2 bitAnd: 16r00FF0000)>>16 + op1 index. ^ self ]. " ... fall through to I_X87_MEM ... " ^ self emitx87mem: emitter operand1: op1 operand2: op2 operand3: op3 ! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! name: anObject "Set the value of name" name := anObject! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitcjmp: emitter operand1: target operand2: hint operand3: op3 "Conditional jump. Use only symbols as labels" target isString ifTrue: [ "jump on label" ^ emitter addJump: target condition: opCode1 hint: hint ]. "we could check if label is bound , and emit short jump, instead of 32-bit relative jump address" self invalidInstruction. emitter emitByte: 16r0F; emitByte: (16r80 bitOr: opCode1); emitDisplacement: target inlinedDisp: -4 ! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmmuRm3DNow: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmmurmi: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitrm: emitter operand1: dst operand2: src operand3: op3 emitter emitX86RM: opCode1 + (dst isRegTypeGPB not) asBit size: dst size regOrCode: opCodeR rm: dst! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitcall: emitter operand1: op1 operand2: op2 operand3: op3 (op1 isMem or: [ op1 isReg and: [ op1 index = 0 "EAX" ] ]) ifTrue: [ ^ emitter emitX86RM: 16rFF size: 4 regOrCode: 2 rm: op1 ]. op1 isImm ifTrue: [ "call by relative offset, you should be really sure what you're' doing" emitter emitByte: 16rE8. op1 emitUsing: emitter size: 4. ^ self. ]. op1 isLabel ifTrue: [ emitter emitByte: 16rE8. emitter emitDisplacement: op1 inlinedDisp: -4. ^ self ]. self invalidInstruction. ! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! name ^ name! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitrrm: emitter operand1: dst operand2: src operand3: op3 dst isReg & src isRegMem ifFalse: [ self invalidInstruction ]. self assert: (dst isRegTypeGPB not). emitter emitX86RM: opCode1 size: dst size regOrCode: dst rm: src! ! !AJx86InstructionDescription methodsFor: 'emitting-dispatch' stamp: ''! emitUsing: emitter operand1: op1 operand2: op2 operand3: op3 (self is64BitOnly and: [ emitter is64BitMode not ]) ifTrue: [ self error: 'instruction is only for 64 bit mode' ]. (self is32BitOnly and: [ emitter is32BitMode not ]) ifTrue: [ self error: 'instruction is only for 32 bit mode' ]. ^ self perform: groupEmitSelector withArguments: { emitter. op1. op2. op3 }! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitbswap: emitter operand1: op1 operand2: op2 operand3: op3 op1 isReg ifTrue: [ emitter emitRexR: op1 isRegTypeGPQ opReg: 1 regCode: op1 code. emitter emitByte: 16r0F. ^ emitter emitModR: 1 r: op1 code ]. self invalidInstruction.! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! opCode2: anObject "Set the value of opCode2" opCode2 := anObject! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'IgorStasenko 3/20/2012 16:08'! emitmov: emitter operand1: dst operand2: src operand3: op3 src isReg & dst isReg ifTrue: [ self assert: (src isRegTypeGPB | src isRegTypeGPW | src isRegTypeGPD | src isRegTypeGPQ ). ]. " reg <- mem " dst isReg & src isRegMem ifTrue: [ self assert: (dst isRegTypeGPB | dst isRegTypeGPW | dst isRegTypeGPD | dst isRegTypeGPQ ). " (src size = dst size) ifFalse: [ self invalidInstruction ]. " ^ emitter emitX86RM: 16r0000008A + dst isRegTypeGPB not asBit size: dst size regOrCode: dst rm: src ]. " reg <- imm " dst isReg & src isImm ifTrue: [ | immSize | immSize := dst size. emitter is64BitMode & immSize = 8 & src isInt32 & (src relocMode == #RelocNone) ifTrue: [ "Optimize instruction size by using 32 bit immediate if value can fit to it" emitter emitX86RM: 16rC7 size: dst size regOrCode: 0 rm: dst. immSize := 4 ] ifFalse: [ emitter emitX86Inl: (immSize=1 ifTrue: [16rB0] ifFalse: [16rB8]) reg: dst ]. ^ emitter emitImmediate: src size: immSize ]. "mem <- reg" dst isMem & src isReg ifTrue: [ self assert: (src isRegTypeGPB | src isRegTypeGPW | src isRegTypeGPD | src isRegTypeGPQ ). ^ emitter emitX86RM: 16r88 + src isRegTypeGPB not asBit size: src size regOrCode: src rm: dst ]. "mem <- imm" dst isMem & src isImm ifTrue: [ | immSize | immSize := dst size <= 4 ifTrue: [ dst size ] ifFalse: [4]. emitter emitX86RM: 16rC6 + ((dst size = 1) not) asBit size: dst size regOrCode: 0 rm: dst immSize: immSize. ^ emitter emitImmediate: src size: immSize ]. self invalidInstruction ! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 7/17/2012 11:10'! emitx87addp: emitter operand1: op1 operand2: op2 operand3: op3 | opp | opp := op1 ifNil: [ AJx87Register new code: 1 ]. opp isRegTypeX87 ifTrue: [ emitter emitByte: (opCode1 bitAnd: 16rFF00)>>8. emitter emitByte: (opCode1 bitAnd: 16rFF) + opp index. ^ self ]. ^self emitx87sti: emitter operand1: opp operand2: op2 operand3: op3 ! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitpush: emitter operand1: op1 operand2: op2 operand3: op3 "This section is only for immediates, memory/register operands are handled in emitpop:..." op1 isImm ifTrue: [ op1 isInt8 & (op1 relocMode == #RelocNone) ifTrue: [ emitter emitByte: 16r6A. ^ emitter emitImmediate: op1 size: 1 ]. emitter emitByte: 16r68. ^ emitter emitImmediate: op1 size: 4 ]. ^ self emitpop: emitter operand1: op1 operand2: op2 operand3: op3 ! ! !AJx86InstructionDescription methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: '('; nextPutAll: name printString; space; nextPutAll: group printString; space. "print o1Flags" o1Flags > 0 ifTrue: [ aStream nextPutAll: '"op1" 2r' , (o1Flags printStringBase: 2) ] ifFalse: [ aStream nextPutAll: '0']. aStream space. "print o2Flags" o2Flags > 0 ifTrue: [ aStream nextPutAll: '"op2" 2r' , (o2Flags printStringBase: 2) ] ifFalse: [ aStream nextPutAll: '0']. aStream space. "print opCodeR" aStream nextPutAll: '"R" '. opCodeR printOn: aStream. aStream space. "print opCode1" opCode1 > 0 ifTrue: [ aStream nextPutAll: '"C1" '. aStream nextPutAll: (self printDWord: opCode1 ) ] ifFalse: [ aStream nextPutAll: '0']. aStream space. "print opCode2" opCode2 > 0 ifTrue: [ aStream nextPutAll: '"C2" '. aStream nextPutAll: (self printDWord: opCode2 ) ] ifFalse: [ aStream nextPutAll: '0']. aStream space; nextPut: $) ! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! o1Flags: anObject "Set the value of o1Flags" o1Flags := anObject! ! !AJx86InstructionDescription methodsFor: 'initialize-release' stamp: ''! translateSymFlag: aflag " 64-bit mode only instruction " aflag == #x64 ifTrue: [ ^ 2r100000000 ]. " 32-bit mode only instruction " aflag == #x86 ifTrue: [ ^ 2r1000000000 ]. self error: 'unknown flag'.! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitx87fpu: emitter operand1: op1 operand2: op2 operand3: op3 "Either we are in memory, and carry out by using D8 / DC followed by modRM where reg indicates the operation" op1 isMem ifTrue: [ (op2 notNil or: [op3]) notNil ifTrue: [self error: 'Invalid arguments!!']. emitter emitByte: (opCode1 >> (32 - (op1 size* 2)) bitAnd: 16rFF). ^op1 emitModRM: emitter code: opCodeR immSize: nil]. "Or both my arguments are X87 registers, one of which is ST0. Store in op1 register." (op1 isRegTypeX87 and: [op2 isRegTypeX87]) ifTrue: [|shift offset| op1 index = 0 ifTrue: [shift := 24. offset := op2 index] ifFalse: [ op2 index = 0 ifTrue: [shift = 16. offset := op1 index] ifFalse: [self error: 'ST0 must be one of arguments']]. "D8 if Storing in ST0, DC if storing in other" emitter emitByte: (opCode1 >> shift bitAnd: 16rFF). emitter emitByte: (opCode1 >> (shift - 16) bitAnd: 16rFF) + offset ] ifFalse: [self error: 'Invalid arguments!!'] ! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 5/15/2012 14:18'! emitbt: emitter operand1: dst operand2: src operand3: op3 dst isRegMem ifFalse: [ self error: 'Expected register or memory but got ', dst asString ]. (dst isReg and: [ dst is8 ]) ifTrue: [ self error: '8 bit register ', dst asString, ' not supported for bit test operations']. src isReg ifTrue: [ ^ emitter emitX86RM: opCode1 size: src size regOrCode: src rm: dst ]. src isImm ifTrue: [ src isInt8 ifFalse: [ self error: 'Expected imm8 but got ', src size asString, ' immediate.' ]. emitter emitX86RM: opCode2 size: dst size regOrCode: opCodeR rm: dst immSize: 1. ^ emitter emitImmediate: src size: 1 ]. self invalidInstruction ! ! !AJx86InstructionDescription methodsFor: 'errors' stamp: ''! invalidInstruction self error: 'invalid instruction'! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitemit: emitter operand1: op1 operand2: op2 operand3: op3 ^ emitter emitOpCode: opCode1! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitxchg: emitter operand1: dst operand2: src operand3: op3 dst isRegMem & src isReg ifFalse: [ self invalidInstruction ]. emitter emitSizePrefix: src segment: dst. "Special opcode for index 0 registers (AX, EAX, RAX vs register)" dst isReg & (dst size > 1) & (dst index =0 or: [ src index = 0 ] ) ifTrue: [ | index | index := dst index + src index. ^ emitter emitByte: 16r90 + index. ]. emitter emitByte: 16r86 + src isRegTypeGPB not asBit. dst emitModRM: emitter code: src code immSize: 0! ! !AJx86InstructionDescription methodsFor: 'printing' stamp: ''! printDWord: value | str | str := value printStringBase: 16. [str size < 8] whileTrue: [ str:= '0',str ]. ^ '16r', str! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmovsxd: emitter operand1: dst operand2: src operand3: op3 emitter is64BitMode ifFalse: [ self invalidInstruction ]. dst isReg & src isRegMem ifFalse: [ self invalidInstruction ]. emitter emitX86RM: 16r63 size: dst size regOrCode: dst rm: src! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! group: anObject "Set the value of group" group := anObject! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitenter: emitter operand1: op1 operand2: op2 operand3: op3 (op1 isImm and: [ op2 isImm ]) ifFalse: [ self invalidInstruction ]. emitter emitByte: 16rC8. emitter emitImmediate: op1 size: 2. emitter emitImmediate: op2 size: 1. ! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! opCodeR "Answer the value of opCodeR" ^ opCodeR! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitrmr: emitter operand1: dst operand2: src operand3: op3 dst isRegMem & src isReg ifFalse: [ self invalidInstruction ]. emitter emitX86RM: opCode1 + (src isRegTypeGPB not) asBit size: src size regOrCode: src rm: dst! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 4/17/2012 17:41'! emitlea: emitter operand1: op1 operand2: op2 operand3: op3 (op1 isReg and: [ op2 isMem ]) ifFalse: [ self error: 'LEA: Expected Reg and Mem but got ', op1 asString, ' and ', op2 asString ]. emitter emitX86RM: 16r8D size: op1 size regOrCode: op1 rm: op2! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmmuMovQ: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 7/23/2012 15:21'! emitx87sti: emitter operand1: op1 operand2: op2 operand3: op3 (op1 isNil and: [ op2 isNil and: [ op3 isNil ]]) ifTrue: [ "Convenience fallback for ST1 " ^ self emitx87sti: emitter operand1: AJx86Registers ST1 operand2: nil operand3: nil ]. op1 isRegTypeX87 ifTrue: [ emitter emitByte: (opCode1 bitAnd: 16rFF00)>>8. emitter emitByte: (opCode1 bitAnd: 16rFF) + op1 index. ^ self ]. self invalidInstruction! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: 'CamilloBruni 4/25/2012 15:15'! emitpop: emitter operand1: op1 operand2: op2 operand3: op3 op1 isReg ifTrue: [ (op1 isRegTypeGPW | (emitter isGPNRegister: op1)) ifFalse: [ self error: 'Invalid register given: ', op1 asString]. ^ emitter emitX86Inl: opCode1 reg: op1. ]. op1 isMem ifFalse: [ self invalidInstruction ]. emitter emitX86RM: opCode2 size: op1 size regOrCode: opCodeR rm: op1 ! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitincdec: emitter operand1: dst operand2: op2 operand3: op3 dst isRegMem ifFalse: [ ^ self invalidInstruction ]. "INC [r16|r32] in 64 bit mode is not encodable." emitter is32BitMode ifTrue: [ (dst isReg & dst isRegTypeGPW & dst isRegTypeGPD) ifTrue: [ ^ emitter emitX86Inl: opCode1 reg: dst ]]. emitter emitX86RM: opCode2 + (dst size ~= 1) asBit size: dst size regOrCode: opCodeR rm: dst ! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: ''! opCode1 "Answer the value of opCode1" ^ opCode1! ! !AJx86InstructionDescription methodsFor: 'testing' stamp: ''! isJump ^ group == #cjmp or: [ group == #jmp ]! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitmmuRmImm8: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting' stamp: ''! emitrot: emitter operand1: op1 operand2: op2 operand3: op3 | useImm8 opCode | op1 isRegMem & ((op2 isRegTypeGPB and: [ op2 index = 1 "cl" ]) | op2 isImm) ifFalse: [ self invalidInstruction ]. useImm8 := op2 isImm and: [ (op2 value ~= 1) | (op2 relocMode ~~ #RelocNone) ]. opCode := useImm8 ifTrue: [ 16rC0 ] ifFalse: [ 16rD0 ]. op1 size ~= 1 ifTrue: [ opCode := opCode bitOr: 1 ]. op2 isReg ifTrue: [ opCode := opCode bitOr: 2 ]. emitter emitX86RM: opCode size: op1 size regOrCode: opCodeR rm: op1 immSize: useImm8 asBit. useImm8 ifTrue: [ emitter emitImmediate: op2 size: 1 ] ! ! !AJx86InstructionDescription class methodsFor: 'initialization' stamp: ''! initialize self initInstructions.! ! !AJx86InstructionDescription class methodsFor: 'initialization' stamp: 'CamilloBruni 4/13/2012 14:47'! initInstructions " self initInstructions " | data | instructions := IdentityDictionary new. data := OrderedCollection new. data addAll: self instructionData; addAll: self instructionsCDQ; addAll: self instructionsOther. data do: [:dt | instructions at: dt first put: (self fromArray: dt) ]. ^ instructions! ! !AJx86InstructionDescription class methodsFor: 'initialization' stamp: 'IgorStasenko 9/18/2012 17:23'! instructionsOther ^ #( (#femms #emit 0 0 "R" 0 "C1" 16r00000F0E 0 ) " looks like invalid one " (#movsb #emit 0 0 "R" 0 "C1" 16r000000A4 0 ) (#movsd #emit 0 0 "R" 0 "C1" 16r000000A5 0 ) "in 64bit mode - moves 64bits" (#rep #emit 0 0 "R" 0 "C1" 16r000000F3 0 ) "repeat prefix" (#repe #emit 0 0 "R" 0 "C1" 16r000000F3 0 ) "repeat prefix" (#repz #emit 0 0 "R" 0 "C1" 16r000000F3 0 ) "repeat prefix" (#repne #emit 0 0 "R" 0 "C1" 16r000000F2 0 ) "repeat prefix" (#repnz #emit 0 0 "R" 0 "C1" 16r000000F2 0 ) "repeat prefix" (#cmpsb #emit 0 0 "R" 0 "C1" 16r000000A6 0 ) "(#cmpsw #emit 0 0 0 16r000000A7 0 ) " (#cmpsd #emit 0 0 "R" 0 "C1" 16r000000A7 0 ) )! ! !AJx86InstructionDescription class methodsFor: 'printing' stamp: ''! printInstructionsOn: aStream " AJInstructionDescription printInstructionsOn: (FileStream newFileNamed: 'asm.st'). " aStream nextPutAll: '#(' ; cr. self instructions keys asSortedCollection do: [:aname | | instr | instr := instructions at: aname. instr printOn: aStream. aStream cr. ]. aStream cr; nextPut: $); cr ! ! !AJx86InstructionDescription class methodsFor: 'initialization' stamp: 'CamilloBruni 4/17/2012 17:39'! at: instructionName ^ instructions at: instructionName ! ! !AJx86InstructionDescription class methodsFor: 'initialization' stamp: 'MartinMcClure 12/15/2012 13:35'! instructionData ^ #( (#adc #alu 0 0 "R" 2 "C1" 16r00000010 "C2" 16r00000080 ) (#add #alu 0 0 "R" 0 0 "C2" 16r00000080 ) (#addpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F58 0 ) (#addps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F58 0 ) (#addsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F58 0 ) (#addss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F58 0 ) (#addsubpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000FD0 0 ) (#addsubps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000FD0 0 ) (#amdprefetch #mem "op1" 2r1000000 0 "R" 0 "C1" 16r00000F0D 0 ) (#amdprefetchw #mem "op1" 2r1000000 0 "R" 1 "C1" 16r00000F0D 0 ) (#and #alu 0 0 "R" 4 "C1" 16r00000020 "C2" 16r00000080 ) (#andnpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F55 0 ) (#andnps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F55 0 ) (#andpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F54 0 ) (#andps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F54 0 ) (#blendpd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A0D 0 ) (#blendps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A0C 0 ) (#blendvpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3815 0 ) (#blendvps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3814 0 ) (#bsf #rrm 0 0 "R" 0 "C1" 16r00000FBC 0 ) (#bsr #rrm 0 0 "R" 0 "C1" 16r00000FBD 0 ) (#bswap #bswap 0 0 "R" 0 0 0 ) (#bt #bt "op1" 2r1001110 "op2" 2r10001110 "R" 4 "C1" 16r00000FA3 "C2" 16r00000FBA ) (#btc #bt "op1" 2r1001110 "op2" 2r10001110 "R" 7 "C1" 16r00000FBB "C2" 16r00000FBA ) (#btr #bt "op1" 2r1001110 "op2" 2r10001110 "R" 6 "C1" 16r00000FB3 "C2" 16r00000FBA ) (#bts #bt "op1" 2r1001110 "op2" 2r10001110 "R" 5 "C1" 16r00000FAB "C2" 16r00000FBA ) (#call #call 0 0 "R" 0 0 0 ) (#clc #emit 0 0 "R" 0 "C1" 16r000000F8 0 ) (#cld #emit 0 0 "R" 0 "C1" 16r000000FC 0 ) (#clflush #mem "op1" 2r1000000 0 "R" 7 "C1" 16r00000FAE 0 ) (#cmc #emit 0 0 "R" 0 "C1" 16r000000F5 0 ) (#cmova #rrm 0 0 "R" 0 "C1" 16r00000F47 0 ) (#cmovae #rrm 0 0 "R" 0 "C1" 16r00000F43 0 ) (#cmovb #rrm 0 0 "R" 0 "C1" 16r00000F42 0 ) (#cmovbe #rrm 0 0 "R" 0 "C1" 16r00000F46 0 ) (#cmovc #rrm 0 0 "R" 0 "C1" 16r00000F42 0 ) (#cmove #rrm 0 0 "R" 0 "C1" 16r00000F44 0 ) (#cmovg #rrm 0 0 "R" 0 "C1" 16r00000F4F 0 ) (#cmovge #rrm 0 0 "R" 0 "C1" 16r00000F4D 0 ) (#cmovl #rrm 0 0 "R" 0 "C1" 16r00000F4C 0 ) (#cmovle #rrm 0 0 "R" 0 "C1" 16r00000F4E 0 ) (#cmovna #rrm 0 0 "R" 0 "C1" 16r00000F46 0 ) (#cmovnae #rrm 0 0 "R" 0 "C1" 16r00000F42 0 ) (#cmovnb #rrm 0 0 "R" 0 "C1" 16r00000F43 0 ) (#cmovnbe #rrm 0 0 "R" 0 "C1" 16r00000F47 0 ) (#cmovnc #rrm 0 0 "R" 0 "C1" 16r00000F43 0 ) (#cmovne #rrm 0 0 "R" 0 "C1" 16r00000F45 0 ) (#cmovng #rrm 0 0 "R" 0 "C1" 16r00000F4E 0 ) (#cmovnge #rrm 0 0 "R" 0 "C1" 16r00000F4C 0 ) (#cmovnl #rrm 0 0 "R" 0 "C1" 16r00000F4D 0 ) (#cmovnle #rrm 0 0 "R" 0 "C1" 16r00000F4F 0 ) (#cmovno #rrm 0 0 "R" 0 "C1" 16r00000F41 0 ) (#cmovnp #rrm 0 0 "R" 0 "C1" 16r00000F4B 0 ) (#cmovns #rrm 0 0 "R" 0 "C1" 16r00000F49 0 ) (#cmovnz #rrm 0 0 "R" 0 "C1" 16r00000F45 0 ) (#cmovo #rrm 0 0 "R" 0 "C1" 16r00000F40 0 ) (#cmovp #rrm 0 0 "R" 0 "C1" 16r00000F4A 0 ) (#cmovpe #rrm 0 0 "R" 0 "C1" 16r00000F4A 0 ) (#cmovpo #rrm 0 0 "R" 0 "C1" 16r00000F4B 0 ) (#cmovs #rrm 0 0 "R" 0 "C1" 16r00000F48 0 ) (#cmovz #rrm 0 0 "R" 0 "C1" 16r00000F44 0 ) (#cmp #alu 0 0 "R" 7 "C1" 16r00000038 "C2" 16r00000080 ) (#cmppd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000FC2 0 ) (#cmpps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000FC2 0 ) (#cmpsd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000FC2 0 ) (#cmpss #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000FC2 0 ) (#cmpxchg #rmr 0 0 "R" 0 "C1" 16r00000FB0 0 ) (#cmpxchg16b #mem "op1" 2r1000000 0 "R" 1 "C1" 16r00000FC7 "C2" 16r00000001 ) (#cmpxchg8b #mem "op1" 2r1000000 0 "R" 1 "C1" 16r00000FC7 0 ) (#comisd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F2F 0 ) (#comiss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F2F 0 ) (#cpuid #emit 0 0 "R" 0 "C1" 16r00000FA2 0 ) (#crc32 #crc32 0 0 "R" 0 "C1" 16rF20F38F0 0 ) (#cvtdq2pd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000FE6 0 ) (#cvtdq2ps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5B 0 ) (#cvtpd2dq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000FE6 0 ) (#cvtpd2pi #mmurmi "op1" 2r10000 "op2" 2r1100000 "R" 0 "C1" 16r66000F2D 0 ) (#cvtpd2ps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5A 0 ) (#cvtpi2pd #mmurmi "op1" 2r100000 "op2" 2r1010000 "R" 0 "C1" 16r66000F2A 0 ) (#cvtpi2ps #mmurmi "op1" 2r100000 "op2" 2r1010000 "R" 0 "C1" 16r00000F2A 0 ) (#cvtps2dq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5B 0 ) (#cvtps2pd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5A 0 ) (#cvtps2pi #mmurmi "op1" 2r10000 "op2" 2r1100000 "R" 0 "C1" 16r00000F2D 0 ) (#cvtsd2si #mmurmi "op1" 2r1100 "op2" 2r1100000 "R" 0 "C1" 16rF2000F2D 0 ) (#cvtsd2ss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F5A 0 ) (#cvtsi2sd #mmurmi "op1" 2r100000 "op2" 2r1001100 "R" 0 "C1" 16rF2000F2A 0 ) (#cvtsi2ss #mmurmi "op1" 2r100000 "op2" 2r1001100 "R" 0 "C1" 16rF3000F2A 0 ) (#cvtss2sd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5A 0 ) (#cvtss2si #mmurmi "op1" 2r1100 "op2" 2r1100000 "R" 0 "C1" 16rF3000F2D 0 ) (#cvttpd2dq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000FE6 0 ) (#cvttpd2pi #mmurmi "op1" 2r10000 "op2" 2r1100000 "R" 0 "C1" 16r66000F2C 0 ) (#cvttps2dq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5B 0 ) (#cvttps2pi #mmurmi "op1" 2r10000 "op2" 2r1100000 "R" 0 "C1" 16r00000F2C 0 ) (#cvttsd2si #mmurmi "op1" 2r1100 "op2" 2r1100000 "R" 0 "C1" 16rF2000F2C 0 ) (#cvttss2si #mmurmi "op1" 2r1100 "op2" 2r1100000 "R" 0 "C1" 16rF3000F2C 0 ) (#daa #emit #x86 0 "R" 0 "C1" 16r00000027 0 ) (#das #emit #x86 0 "R" 0 "C1" 16r0000002F 0 ) (#dec #incdec 0 0 "R" 1 "C1" 16r00000048 "C2" 16r000000FE ) (#div #rm 0 0 "R" 6 "C1" 16r000000F6 0 ) (#divpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5E 0 ) (#divps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5E 0 ) (#divsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F5E 0 ) (#divss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5E 0 ) (#dppd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A41 0 ) (#dpps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A40 0 ) (#emms #emit 0 0 "R" 0 "C1" 16r00000F77 0 ) (#enter #enter 0 0 "R" 0 "C1" 16r000000C8 0 ) (#extractps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A17 0 ) (#f2xm1 #emit 0 0 "R" 0 "C1" 16r0000D9F0 0 ) (#fabs #emit 0 0 "R" 0 "C1" 16r0000D9E1 0 ) (#fadd #x87fpu 0 0 "R" 0 "C1" 16rD8DCC0C0 0 ) (#faddp #x87sti 0 0 "R" 0 "C1" 16r0000DEC0 0 ) (#fbld #mem "op1" 2r1000000 0 "R" 4 "C1" 16r000000DF 0 ) (#fbstp #mem "op1" 2r1000000 0 "R" 6 "C1" 16r000000DF 0 ) (#fchs #emit 0 0 "R" 0 "C1" 16r0000D9E0 0 ) (#fclex #emit 0 0 "R" 0 "C1" 16r9B00DBE2 0 ) (#fcmovb #x87sti 0 0 "R" 0 "C1" 16r0000DAC0 0 ) (#fcmovbe #x87sti 0 0 "R" 0 "C1" 16r0000DAD0 0 ) (#fcmove #x87sti 0 0 "R" 0 "C1" 16r0000DAC8 0 ) (#fcmovnb #x87sti 0 0 "R" 0 "C1" 16r0000DBC0 0 ) (#fcmovnbe #x87sti 0 0 "R" 0 "C1" 16r0000DBD0 0 ) (#fcmovne #x87sti 0 0 "R" 0 "C1" 16r0000DBC8 0 ) (#fcmovnu #x87sti 0 0 "R" 0 "C1" 16r0000DBD8 0 ) (#fcmovu #x87sti 0 0 "R" 0 "C1" 16r0000DAD8 0 ) (#fcom #x87fpu 0 0 "R" 2 "C1" 16rD8DCD0D0 0 ) (#fcomi #x87sti 0 0 "R" 0 "C1" 16r0000DBF0 0 ) (#fcomip #x87sti 0 0 "R" 0 "C1" 16r0000DFF0 0 ) (#fcomp #x87fpu 0 0 "R" 3 "C1" 16rD8DCD8D8 0 ) (#fcompp #emit 0 0 "R" 0 "C1" 16r0000DED9 0 ) (#fcos #emit 0 0 "R" 0 "C1" 16r0000D9FF 0 ) (#fdecstp #emit 0 0 "R" 0 "C1" 16r0000D9F6 0 ) (#fdiv #x87fpu 0 0 "R" 6 "C1" 16rD8DCF0F8 0 ) (#fdivp #x87sti 0 0 "R" 0 "C1" 16r0000DEF8 0 ) (#fdivr #x87fpu 0 0 "R" 7 "C1" 16rD8DCF8F0 0 ) (#fdivrp #x87sti 0 0 "R" 0 "C1" 16r0000DEF0 0 ) (#ffree #x87sti 0 0 "R" 0 "C1" 16r0000DDC0 0 ) (#fiadd #x87mem "op1" 2r110 0 "R" 0 "C1" 16rDEDA0000 0 ) (#ficom #x87mem "op1" 2r110 0 "R" 2 "C1" 16rDEDA0000 0 ) (#ficomp #x87mem "op1" 2r110 0 "R" 3 "C1" 16rDEDA0000 0 ) (#fidiv #x87mem "op1" 2r110 0 "R" 6 "C1" 16rDEDA0000 0 ) (#fidivr #x87mem "op1" 2r110 0 "R" 7 "C1" 16rDEDA0000 0 ) (#fild #x87mem "op1" 2r1110 0 "R" 0 "C1" 16rDFDBDF05 0 ) (#fimul #x87mem "op1" 2r110 0 "R" 1 "C1" 16rDEDA0000 0 ) (#fincstp #emit 0 0 "R" 0 "C1" 16r0000D9F7 0 ) (#finit #emit 0 0 "R" 0 "C1" 16r9B00DBE3 0 ) (#fist #x87mem "op1" 2r110 0 "R" 2 "C1" 16rDFDB0000 0 ) (#fistp #x87mem "op1" 2r1110 0 "R" 3 "C1" 16rDFDBDF07 0 ) (#fisttp #x87mem "op1" 2r1110 0 "R" 1 "C1" 16rDFDBDD01 0 ) (#fisub #x87mem "op1" 2r110 0 "R" 4 "C1" 16rDEDA0000 0 ) (#fisubr #x87mem "op1" 2r110 0 "R" 5 "C1" 16rDEDA0000 0 ) (#fld #x87memSti "op1" 2r11100 0 "R" 0 "C1" 16r00D9DD00 "C2" 16rD9C0DB05 ) (#fld1 #emit 0 0 "R" 0 "C1" 16r0000D9E8 0 ) (#fldcw #mem "op1" 2r1000000 0 "R" 5 "C1" 16r000000D9 0 ) (#fldenv #mem "op1" 2r1000000 0 "R" 4 "C1" 16r000000D9 0 ) (#fldl2e #emit 0 0 "R" 0 "C1" 16r0000D9EA 0 ) (#fldl2t #emit 0 0 "R" 0 "C1" 16r0000D9E9 0 ) (#fldlg2 #emit 0 0 "R" 0 "C1" 16r0000D9EC 0 ) (#fldln2 #emit 0 0 "R" 0 "C1" 16r0000D9ED 0 ) (#fldpi #emit 0 0 "R" 0 "C1" 16r0000D9EB 0 ) (#fldz #emit 0 0 "R" 0 "C1" 16r0000D9EE 0 ) (#fmul #x87fpu 0 0 "R" 1 "C1" 16rD8DCC8C8 0 ) (#fmulp #x87sti 0 0 "R" 0 "C1" 16r0000DEC8 0 ) (#fnclex #emit 0 0 "R" 0 "C1" 16r0000DBE2 0 ) (#fninit #emit 0 0 "R" 0 "C1" 16r0000DBE3 0 ) (#fnop #emit 0 0 "R" 0 "C1" 16r0000D9D0 0 ) (#fnsave #mem "op1" 2r1000000 0 "R" 6 "C1" 16r000000DD 0 ) (#fnstcw #mem "op1" 2r1000000 0 "R" 7 "C1" 16r000000D9 0 ) (#fnstenv #mem "op1" 2r1000000 0 "R" 6 "C1" 16r000000D9 0 ) (#fnstsw #x87fstsw "op1" 2r1000000 0 "R" 7 "C1" 16r000000DD "C2" 16r0000DFE0 ) (#fpatan #emit 0 0 "R" 0 "C1" 16r0000D9F3 0 ) (#fprem #emit 0 0 "R" 0 "C1" 16r0000D9F8 0 ) (#fprem1 #emit 0 0 "R" 0 "C1" 16r0000D9F5 0 ) (#fptan #emit 0 0 "R" 0 "C1" 16r0000D9F2 0 ) (#frndint #emit 0 0 "R" 0 "C1" 16r0000D9FC 0 ) (#frstor #mem "op1" 2r1000000 0 "R" 4 "C1" 16r000000DD 0 ) (#fsave #mem "op1" 2r1000000 0 "R" 6 "C1" 16r9B0000DD 0 ) (#fscale #emit 0 0 "R" 0 "C1" 16r0000D9FD 0 ) (#fsin #emit 0 0 "R" 0 "C1" 16r0000D9FE 0 ) (#fsincos #emit 0 0 "R" 0 "C1" 16r0000D9FB 0 ) (#fsqrt #emit 0 0 "R" 0 "C1" 16r0000D9FA 0 ) (#fst #x87memSti "op1" 2r1100 0 "R" 2 "C1" 16r00D9DD02 "C2" 16rDDD00000 ) (#fstcw #mem "op1" 2r1000000 0 "R" 7 "C1" 16r9B0000D9 0 ) (#fstenv #mem "op1" 2r1000000 0 "R" 6 "C1" 16r9B0000D9 0 ) (#fstp #x87memSti "op1" 2r11100 0 "R" 3 "C1" 16r00D9DD03 "C2" 16rDDD8DB07 ) (#fstsw #x87fstsw "op1" 2r1000000 0 "R" 7 "C1" 16r9B0000DD "C2" 16r9B00DFE0 ) (#fsub #x87fpu 0 0 "R" 4 "C1" 16rD8DCE0E8 0 ) (#fsubp #x87sti 0 0 "R" 0 "C1" 16r0000DEE8 0 ) (#fsubr #x87fpu 0 0 "R" 5 "C1" 16rD8DCE8E0 0 ) (#fsubrp #x87sti 0 0 "R" 0 "C1" 16r0000DEE0 0 ) (#ftst #emit 0 0 "R" 0 "C1" 16r0000D9E4 0 ) (#fucom #x87sti 0 0 "R" 0 "C1" 16r0000DDE0 0 ) (#fucomi #x87sti 0 0 "R" 0 "C1" 16r0000DBE8 0 ) (#fucomip #x87sti 0 0 "R" 0 "C1" 16r0000DFE8 0 ) (#fucomp #x87sti 0 0 "R" 0 "C1" 16r0000DDE8 0 ) (#fucompp #emit 0 0 "R" 0 "C1" 16r0000DAE9 0 ) (#fwait #emit 0 0 "R" 0 "C1" 16r0000009B 0 ) (#fxam #emit 0 0 "R" 0 "C1" 16r0000D9E5 0 ) (#fxch #x87sti 0 0 "R" 0 "C1" 16r0000D9C8 0 ) (#fxrstor #mem 0 0 "R" 1 "C1" 16r00000FAE 0 ) (#fxsave #mem 0 0 "R" 0 "C1" 16r00000FAE 0 ) (#fxtract #emit 0 0 "R" 0 "C1" 16r0000D9F4 0 ) (#fyl2x #emit 0 0 "R" 0 "C1" 16r0000D9F1 0 ) (#fyl2xp1 #emit 0 0 "R" 0 "C1" 16r0000D9F9 0 ) (#haddpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F7C 0 ) (#haddps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F7C 0 ) (#hsubpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F7D 0 ) (#hsubps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F7D 0 ) (#idiv #rm 0 0 "R" 7 "C1" 16r000000F6 0 ) (#imul #imul 0 0 "R" 0 0 0 ) (#inc #incdec 0 0 "R" 0 "C1" 16r00000040 "C2" 16r000000FE ) (#int3 #emit 0 0 "R" 0 "C1" 16r000000CC 0 ) (#ja #cjmp 0 0 "R" 0 "C1" 16r00000007 0 ) (#jae #cjmp 0 0 "R" 0 "C1" 16r00000003 0 ) (#jb #cjmp 0 0 "R" 0 "C1" 16r00000002 0 ) (#jbe #cjmp 0 0 "R" 0 "C1" 16r00000006 0 ) (#jc #cjmp 0 0 "R" 0 "C1" 16r00000002 0 ) (#je #cjmp 0 0 "R" 0 "C1" 16r00000004 0 ) (#jg #cjmp 0 0 "R" 0 "C1" 16r0000000F 0 ) (#jge #cjmp 0 0 "R" 0 "C1" 16r0000000D 0 ) (#jl #cjmp 0 0 "R" 0 "C1" 16r0000000C 0 ) (#jle #cjmp 0 0 "R" 0 "C1" 16r0000000E 0 ) (#jmp #jmp 0 0 "R" 0 0 0 ) (#jna #cjmp 0 0 "R" 0 "C1" 16r00000006 0 ) (#jnae #cjmp 0 0 "R" 0 "C1" 16r00000002 0 ) (#jnb #cjmp 0 0 "R" 0 "C1" 16r00000003 0 ) (#jnbe #cjmp 0 0 "R" 0 "C1" 16r00000007 0 ) (#jnc #cjmp 0 0 "R" 0 "C1" 16r00000003 0 ) (#jne #cjmp 0 0 "R" 0 "C1" 16r00000005 0 ) (#jng #cjmp 0 0 "R" 0 "C1" 16r0000000E 0 ) (#jnge #cjmp 0 0 "R" 0 "C1" 16r0000000C 0 ) (#jnl #cjmp 0 0 "R" 0 "C1" 16r0000000D 0 ) (#jnle #cjmp 0 0 "R" 0 "C1" 16r0000000F 0 ) (#jno #cjmp 0 0 "R" 0 "C1" 16r00000001 0 ) (#jnp #cjmp 0 0 "R" 0 "C1" 16r0000000B 0 ) (#jns #cjmp 0 0 "R" 0 "C1" 16r00000009 0 ) (#jnz #cjmp 0 0 "R" 0 "C1" 16r00000005 0 ) (#jo #cjmp 0 0 "R" 0 0 0 ) (#jp #cjmp 0 0 "R" 0 "C1" 16r0000000A 0 ) (#jpe #cjmp 0 0 "R" 0 "C1" 16r0000000A 0 ) (#jpo #cjmp 0 0 "R" 0 "C1" 16r0000000B 0 ) (#js #cjmp 0 0 "R" 0 "C1" 16r00000008 0 ) (#jz #cjmp 0 0 "R" 0 "C1" 16r00000004 0 ) (#lddqu #mmurmi "op1" 2r100000 "op2" 2r1000000 "R" 0 "C1" 16rF2000FF0 0 ) (#ldmxcsr #mem "op1" 2r1000000 0 "R" 2 "C1" 16r00000FAE 0 ) (#lea #lea 0 0 "R" 0 0 0 ) (#leave #emit 0 0 "R" 0 "C1" 16r000000C9 0 ) (#lfence #emit 0 0 "R" 0 "C1" 16r000FAEE8 0 ) (#lock #emit 0 0 "R" 0 "C1" 16r000000F0 0 ) (#maskmovdqu #mmurmi "op1" 2r100000 "op2" 2r100000 "R" 0 "C1" 16r66000F57 0 ) (#maskmovq #mmurmi "op1" 2r10000 "op2" 2r10000 "R" 0 "C1" 16r00000FF7 0 ) (#maxpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5F 0 ) (#maxps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5F 0 ) (#maxsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F5F 0 ) (#maxss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5F 0 ) (#mfence #emit 0 0 "R" 0 "C1" 16r000FAEF0 0 ) (#minpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5D 0 ) (#minps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5D 0 ) (#minsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F5D 0 ) (#minss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5D 0 ) (#monitor #emit 0 0 "R" 0 "C1" 16r000F01C8 0 ) (#mov #mov 0 0 "R" 0 0 0 ) (#movPtr #movPtr 0 0 "R" 0 0 0 ) (#movapd #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F28 "C2" 16r66000F29 ) (#movaps #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F28 "C2" 16r00000F29 ) (#movbe #movbe "op1" 2r1001110 "op2" 2r1001110 "R" 0 "C1" 16r000F38F0 "C2" 16r000F38F1 ) (#movd #mmuMovD 0 0 "R" 0 0 0 ) (#movddup #mmuMov "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F12 0 ) (#movdq2q #mmuMov "op1" 2r10000 "op2" 2r100000 "R" 0 "C1" 16rF2000FD6 0 ) (#movdqa #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F6F "C2" 16r66000F7F ) (#movdqu #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F6F "C2" 16rF3000F7F ) (#movhlps #mmuMov "op1" 2r100000 "op2" 2r100000 "R" 0 "C1" 16r00000F12 0 ) (#movhpd #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F16 "C2" 16r66000F17 ) (#movhps #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F16 "C2" 16r00000F17 ) (#movlhps #mmuMov "op1" 2r100000 "op2" 2r100000 "R" 0 "C1" 16r00000F16 0 ) (#movlpd #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F12 "C2" 16r66000F13 ) (#movlps #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F12 "C2" 16r00000F13 ) (#movmskpd #mmuMov "op1" 2r1101 "op2" 2r100000 "R" 0 "C1" 16r66000F50 0 ) (#movmskps #mmuMov "op1" 2r1101 "op2" 2r100000 "R" 0 "C1" 16r00000F50 0 ) (#movntdq #mmuMov "op1" 2r1000000 "op2" 2r100000 "R" 0 0 "C2" 16r66000FE7 ) (#movntdqa #mmuMov "op1" 2r100000 "op2" 2r1000000 "R" 0 "C1" 16r660F382A 0 ) (#movnti #mmuMov "op1" 2r1000000 "op2" 2r1100 "R" 0 0 "C2" 16r00000FC3 ) (#movntpd #mmuMov "op1" 2r1000000 "op2" 2r100000 "R" 0 0 "C2" 16r66000F2B ) (#movntps #mmuMov "op1" 2r1000000 "op2" 2r100000 "R" 0 0 "C2" 16r00000F2B ) (#movntq #mmuMov "op1" 2r1000000 "op2" 2r10000 "R" 0 0 "C2" 16r00000FE7 ) (#movq #mmuMovQ 0 0 "R" 0 0 0 ) (#movq2dq #mmurmi "op1" 2r100000 "op2" 2r10000 "R" 0 "C1" 16rF3000FD6 0 ) (#movsd #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F10 "C2" 16rF2000F11 ) (#movshdup #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F16 0 ) (#movsldup #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F12 0 ) (#movss #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F10 "C2" 16rF3000F11 ) (#movsx #movSxZx 0 0 "R" 0 "C1" 16r00000FBE 0 ) (#movsxd #movsxd 0 0 "R" 0 0 0 ) (#movupd #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F10 "C2" 16r66000F11 ) (#movups #mmuMov "op1" 2r1100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F10 "C2" 16r00000F11 ) (#movzx #movSxZx 0 0 "R" 0 "C1" 16r00000FB6 0 ) (#mpsadbw #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A42 0 ) (#mul #rm 0 0 "R" 4 "C1" 16r000000F6 0 ) (#mulpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F59 0 ) (#mulps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F59 0 ) (#mulsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F59 0 ) (#mulss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F59 0 ) (#mwait #emit 0 0 "R" 0 "C1" 16r000F01C9 0 ) (#neg #rm 0 0 "R" 3 "C1" 16r000000F6 0 ) (#nop #emit 0 0 "R" 0 "C1" 16r00000090 0 ) (#not #rm 0 0 "R" 2 "C1" 16r000000F6 0 ) (#or #alu 0 0 "R" 1 "C1" 16r00000008 "C2" 16r00000080 ) (#orpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F56 0 ) (#orps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F56 0 ) (#pabsb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F381C 0 ) (#pabsd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F381E 0 ) (#pabsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F381D 0 ) (#packssdw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F6B 0 ) (#packsswb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F63 0 ) (#packusdw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F382B 0 ) (#packuswb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F67 0 ) (#paddb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FFC 0 ) (#paddd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FFE 0 ) (#paddq #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FD4 0 ) (#paddsb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FEC 0 ) (#paddsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FED 0 ) (#paddusb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDC 0 ) (#paddusw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDD 0 ) (#paddw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FFD 0 ) (#palignr #mmuRmImm8 "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3A0F 0 ) (#pand #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDB 0 ) (#pandn #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDF 0 ) (#pause #emit 0 0 "R" 0 "C1" 16rF3000090 0 ) (#pavgb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE0 0 ) (#pavgw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE3 0 ) (#pblendvb #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3810 0 ) (#pblendw #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A0E 0 ) (#pcmpeqb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F74 0 ) (#pcmpeqd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F76 0 ) (#pcmpeqq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3829 0 ) (#pcmpeqw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F75 0 ) (#pcmpestri #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A61 0 ) (#pcmpestrm #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A60 0 ) (#pcmpgtb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F64 0 ) (#pcmpgtd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F66 0 ) (#pcmpgtq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3837 0 ) (#pcmpgtw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F65 0 ) (#pcmpistri #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A63 0 ) (#pcmpistrm #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A62 0 ) (#pextrb #mmuPextr "op1" 2r1000101 "op2" 2r100000 "R" 0 "C1" 16r000F3A14 0 ) (#pextrd #mmuPextr "op1" 2r1000100 "op2" 2r100000 "R" 0 "C1" 16r000F3A16 0 ) (#pextrq #mmuPextr "op1" 2r1001100 "op2" 2r100000 "R" 1 "C1" 16r000F3A16 0 ) (#pextrw #mmuPextr "op1" 2r1000100 "op2" 2r110000 "R" 0 "C1" 16r000F3A16 0 ) (#pf2id #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000001D ) (#pf2iw #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000001C ) (#pfacc #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000AE ) (#pfadd #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000009E ) (#pfcmpeq #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000B0 ) (#pfcmpge #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r00000090 ) (#pfcmpgt #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000A0 ) (#pfmax #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000A4 ) (#pfmin #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r00000094 ) (#pfmul #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000B4 ) (#pfnacc #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000008A ) (#pfpnacc #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000008E ) (#pfrcp #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r00000096 ) (#pfrcpit1 #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000A6 ) (#pfrcpit2 #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000B6 ) (#pfrsqit1 #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000A7 ) (#pfrsqrt #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r00000097 ) (#pfsub #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000009A ) (#pfsubr #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000AA ) (#phaddd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3802 0 ) (#phaddsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3803 0 ) (#phaddw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3801 0 ) (#phminposuw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3841 0 ) (#phsubd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3806 0 ) (#phsubsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3807 0 ) (#phsubw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3805 0 ) (#pi2fd #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000000D ) (#pi2fw #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r0000000C ) (#pinsrb #mmuRmImm8 "op1" 2r100000 "op2" 2r1000100 "R" 0 "C1" 16r660F3A20 0 ) (#pinsrd #mmuRmImm8 "op1" 2r100000 "op2" 2r1000100 "R" 0 "C1" 16r660F3A22 0 ) (#pinsrq #mmuRmImm8 "op1" 2r100000 "op2" 2r1001000 "R" 0 "C1" 16r660F3A22 0 ) (#pinsrw #mmuRmImm8 "op1" 2r110000 "op2" 2r1000100 "R" 0 "C1" 16r00000FC4 0 ) (#pmaddubsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3804 0 ) (#pmaddwd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FF5 0 ) (#pmaxsb #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383C 0 ) (#pmaxsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383D 0 ) (#pmaxsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FEE 0 ) (#pmaxub #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDE 0 ) (#pmaxud #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383F 0 ) (#pmaxuw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383E 0 ) (#pminsb #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3838 0 ) (#pminsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3839 0 ) (#pminsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FEA 0 ) (#pminub #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FDA 0 ) (#pminud #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383B 0 ) (#pminuw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F383A 0 ) (#pmovmskb #mmurmi "op1" 2r1100 "op2" 2r110000 "R" 0 "C1" 16r00000FD7 0 ) (#pmovsxbd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3821 0 ) (#pmovsxbq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3822 0 ) (#pmovsxbw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3820 0 ) (#pmovsxdq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3825 0 ) (#pmovsxwd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3823 0 ) (#pmovsxwq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3824 0 ) (#pmovzxbd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3831 0 ) (#pmovzxbq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3832 0 ) (#pmovzxbw #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3830 0 ) (#pmovzxdq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3835 0 ) (#pmovzxwd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3833 0 ) (#pmovzxwq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3834 0 ) (#pmuldq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3828 0 ) (#pmulhrsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F380B 0 ) (#pmulhuw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE4 0 ) (#pmulhw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE5 0 ) (#pmulld #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3840 0 ) (#pmullw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FD5 0 ) (#pmuludq #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FF4 0 ) (#pop #pop 0 0 "R" 0 "C1" 16r00000058 "C2" 16r0000008F ) (#popad #emit #x86 0 "R" 0 "C1" 16r00000061 0 ) (#popcnt #rrm 0 0 "R" 0 "C1" 16rF3000FB8 0 ) (#popfd #emit 0 0 "R" 0 "C1" 16r0000009D 0 ) (#popfq #emit 0 0 "R" 0 "C1" 16r4800009D 0 ) (#por #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FEB 0 ) (#prefetch #mmuPrefetch "op1" 2r1000000 "op2" 2r10000000 "R" 0 0 0 ) (#psadbw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FF6 0 ) (#pshufb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3800 0 ) (#pshufd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F70 0 ) (#pshufhw #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F70 0 ) (#pshuflw #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F70 0 ) (#pshufw #mmuRmImm8 "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F70 0 ) (#psignb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3808 0 ) (#psignd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F380A 0 ) (#psignw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r000F3809 0 ) (#pslld #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 6 "C1" 16r00000FF2 "C2" 16r00000F72 ) (#pslldq #mmurmi "op1" 2r100000 "op2" 2r10000000 "R" 7 0 "C2" 16r66000F73 ) (#psllq #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 6 "C1" 16r00000FF3 "C2" 16r00000F73 ) (#psllw #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 6 "C1" 16r00000FF1 "C2" 16r00000F71 ) (#psrad #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 4 "C1" 16r00000FE2 "C2" 16r00000F72 ) (#psraw #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 4 "C1" 16r00000FE1 "C2" 16r00000F71 ) (#psrld #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 2 "C1" 16r00000FD2 "C2" 16r00000F72 ) (#psrldq #mmurmi "op1" 2r100000 "op2" 2r10000000 "R" 3 0 "C2" 16r66000F73 ) (#psrlq #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 2 "C1" 16r00000FD3 "C2" 16r00000F73 ) (#psrlw #mmurmi "op1" 2r110000 "op2" 2r11110000 "R" 2 "C1" 16r00000FD1 "C2" 16r00000F71 ) (#psubb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FF8 0 ) (#psubd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FFA 0 ) (#psubq #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FFB 0 ) (#psubsb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE8 0 ) (#psubsw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FE9 0 ) (#psubusb #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FD8 0 ) (#psubusw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FD9 0 ) (#psubw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FF9 0 ) (#pswapd #mmuRm3DNow "op1" 2r10000 "op2" 2r1010000 "R" 0 "C1" 16r00000F0F "C2" 16r000000BB ) (#ptest #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3817 0 ) (#punpckhbw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F68 0 ) (#punpckhdq #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F6A 0 ) (#punpckhqdq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F6D 0 ) (#punpckhwd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F69 0 ) (#punpcklbw #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F60 0 ) (#punpckldq #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F62 0 ) (#punpcklqdq #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F6C 0 ) (#punpcklwd #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000F61 0 ) (#push #push 0 0 "R" 6 "C1" 16r00000050 "C2" 16r000000FF ) (#pushad #emit #x86 0 "R" 0 "C1" 16r00000060 0 ) (#pushf #emit 0 0 "R" 0 "C1" 16r6600009C 0 ) (#pushfd #emit #x86 0 "R" 0 "C1" 16r0000009C 0 ) (#pushfq #emit #x64 0 "R" 0 "C1" 16r0000009C 0 ) (#pxor #mmurmi "op1" 2r110000 "op2" 2r1110000 "R" 0 "C1" 16r00000FEF 0 ) (#rcl #rot 0 0 "R" 2 0 0 ) (#rcpps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F53 0 ) (#rcpss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F53 0 ) (#rcr #rot 0 0 "R" 3 0 0 ) (#rdtsc #emit 0 0 "R" 0 "C1" 16r00000F31 0 ) (#rdtscp #emit 0 0 "R" 0 "C1" 16r000F01F9 0 ) (#ret #ret 0 0 "R" 0 0 0 ) (#rol #rot 0 0 "R" 0 0 0 ) (#ror #rot 0 0 "R" 1 0 0 ) (#roundpd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A09 0 ) (#roundps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A08 0 ) (#roundsd #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A0B 0 ) (#roundss #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r660F3A0A 0 ) (#rsqrtps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F52 0 ) (#rsqrtss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F52 0 ) (#sahf #emit 0 0 "R" 0 "C1" 16r0000009E 0 ) (#sal #rot 0 0 "R" 4 0 0 ) (#sar #rot 0 0 "R" 7 0 0 ) (#sbb #alu 0 0 "R" 3 "C1" 16r00000018 "C2" 16r00000080 ) (#sfence #emit 0 0 "R" 0 "C1" 16r000FAEF8 0 ) (#shl #rot 0 0 "R" 4 0 0 ) (#shld #shldShrd 0 0 "R" 0 "C1" 16r00000FA4 0 ) (#shr #rot 0 0 "R" 5 0 0 ) (#shrd #shldShrd 0 0 "R" 0 "C1" 16r00000FAC 0 ) (#shufps #mmuRmImm8 "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000FC6 0 ) (#sqrtpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F51 0 ) (#sqrtps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F51 0 ) (#sqrtsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F51 0 ) (#sqrtss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F51 0 ) (#stc #emit 0 0 "R" 0 "C1" 16r000000F9 0 ) (#std #emit 0 0 "R" 0 "C1" 16r000000FD 0 ) (#stmxcsr #mem "op1" 2r1000000 0 "R" 3 "C1" 16r00000FAE 0 ) (#sub #alu 0 0 "R" 5 "C1" 16r00000028 "C2" 16r00000080 ) (#subpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F5C 0 ) (#subps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F5C 0 ) (#subsd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF2000F5C 0 ) (#subss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16rF3000F5C 0 ) (#syscall #emit "op1" 2r100000000 0 "R" 0 "C1" 16r00000F05 0 ) (#test #test 0 0 "R" 0 0 0 ) (#ucomisd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F2E 0 ) (#ucomiss #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F2E 0 ) (#ud2 #emit 0 0 "R" 0 "C1" 16r00000F0B 0 ) (#unpckhpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F15 0 ) (#unpckhps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F15 0 ) (#unpcklpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F14 0 ) (#unpcklps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F14 0 ) (#xadd #rmr 0 0 "R" 0 "C1" 16r00000FC0 0 ) (#xchg #xchg 0 0 "R" 0 0 0 ) (#xor #alu 0 0 "R" 6 "C1" 16r00000030 "C2" 16r00000080 ) (#xorpd #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r66000F57 0 ) (#xorps #mmurmi "op1" 2r100000 "op2" 2r1100000 "R" 0 "C1" 16r00000F57 0 ) ) ! ! !AJx86InstructionDescription class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/13/2012 14:30'! fromArray: aSpecArray ^ self basicNew fromArray: aSpecArray! ! !AJx86InstructionDescription class methodsFor: 'initialization' stamp: ''! instructionsCDQ "CBW/CWDE/CDQE Convert Byte to Word/Convert Word to Doubleword/Convert Doubleword to Quadword" ^#( (#cbw #emit 0 0 "R" 0 "C1" 16r66000098 0 ) (#cwde #emit 0 0 "R" 0 "C1" 16r00000098 0 ) (#cdqe #emit #x64 0 "R" 0 "C1" 16r48000098 0 ) "CWD/CDQ/CQO Convert Word to Doubleword/Convert Doubleword to Quadword" (#cwd #emit 0 0 "R" 0 "C1" 16r66000099 0 ) (#cdq #emit 0 0 "R" 0 "C1" 16r00000099 0 ) (#cqo #emit #x64 0 "R" 0 "C1" 16r48000099 0 ) )! ! !AJx86InstructionDescription class methodsFor: 'printing' stamp: ''! printInstructions " AJInstructionDescription printInstructions. AJInstructionDescription printInstructions openInWorkspaceWithTitle: 'x86 instructions' " ^ String streamContents: [:str | self printInstructionsOn: str ] ! ! !AJx86InstructionDescription class methodsFor: 'accessing' stamp: ''! instructions ^ instructions ifNil: [ self initInstructions ]! ! !AJx86InstructionDescription class methodsFor: 'testing' stamp: ''! checkInstructionsIntegrity " self checkInstructionsIntegrity" | data | data := self instructionData. data do: [:dt | | instr | instr := instructions at: dt first. self assert: [ (instr name = (dt at: 1)) & (instr group = (dt at: 2)) & (instr o1Flags = (dt at:3)) & (instr o2Flags = (dt at:4)) & (instr opCodeR = (dt at:5)) & (instr opCode1 = (dt at:6)) & (instr opCode2 = (dt at:7)) ]. ]. ! ! !AJx86JumpInstruction commentStamp: 'TorstenBergmann 1/30/2014 09:18'! Jump instruction for X86! !AJx86JumpInstruction methodsFor: 'emitting code' stamp: ''! emitLongJump: desc target: target | addr sz nextInstruction | sz := self isConditional ifTrue: [ 2 ] ifFalse: [ 1 ]. nextInstruction := position + 4 + sz. addr := (AJImmediate ivalue: target - nextInstruction) asDWord. ^ self isConditional ifFalse: [ self emitUnconditionalJumpTo: addr ] ifTrue: [ self emitConditionalJump: addr to: desc ]! ! !AJx86JumpInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 8/23/2012 16:01'! instructionDesciptions ^ AJx86InstructionDescription instructions! ! !AJx86JumpInstruction methodsFor: 'emitting code' stamp: ''! emitShortJump: desc offset: delta "short jump" ^ self isConditional ifTrue: [ {(16r70 + desc opCode1). (delta asByte)} asByteArray ] ifFalse: [ {16rEB. (delta asByte)} asByteArray ]! ! !AJx86JumpInstruction methodsFor: 'testing' stamp: ''! isConditional ^ name ~~ #jmp! ! !AJx86JumpInstruction methodsFor: 'emitting code' stamp: ''! emitConditionalJump: addr to: desc ^ {16r0F. (16r80 + desc opCode1). (addr bitAnd: 255). (addr >> 8 bitAnd: 255). (addr >> 16 bitAnd: 255). (addr >> 24 bitAnd: 255)} asByteArray! ! !AJx86JumpInstruction methodsFor: 'emitting code' stamp: 'CamilloBruni 8/22/2012 14:34'! emitCode: asm "generate opcodes" | delta code nextInstruction target desc | target := label position. target ifNil: [ ^ machineCode := nil ]. nextInstruction := position + 2. delta := (target - nextInstruction) asImm. desc := self instructionDesciptions at: name. "can we use 8bit offset?" machineCode := delta isInt8 ifTrue: [ self emitShortJump: desc offset: delta ] ifFalse: [ self emitLongJump: desc target: target ]! ! !AJx86JumpInstruction methodsFor: 'accessing' stamp: ''! machineCodeSize machineCode ifNil: [ ^ 2 ]. ^ machineCode size! ! !AJx86JumpInstruction methodsFor: 'emitting code' stamp: 'CamilloBruni 8/22/2012 18:07'! emitCodeAtOffset: offset assembler: asm position := offset. [ | labelPos | labelPos := label position. labelPos ifNotNil: [ self emitCode: asm ]. next ifNotNil: [ next emitCodeAtOffset: offset + self machineCodeSize assembler: asm ]. label position ~= labelPos ] whileTrue. label position ifNil: [ self errorUndefinedLabel: label ]! ! !AJx86JumpInstruction methodsFor: 'convenience' stamp: 'CamilloBruni 8/22/2012 18:07'! errorUndefinedLabel: aLabel ^ self error: 'undefined label: ', aLabel name! ! !AJx86JumpInstruction methodsFor: 'emitting code' stamp: ''! emitUnconditionalJumpTo: addr ^ { 16rE9. (addr bitAnd: 255). (addr >> 8 bitAnd: 255). (addr >> 16 bitAnd: 255). (addr >> 24 bitAnd: 255)} asByteArray! ! !AJx86JumpInstruction methodsFor: 'accessing' stamp: ''! codeSize machineCode ifNil: [ ^ 2 ]. ^ machineCode size! ! !AJx86RegisterTests commentStamp: 'TorstenBergmann 2/4/2014 21:38'! SUnit tests for x86 registers! !AJx86RegisterTests methodsFor: 'as yet unclassified' stamp: 'MartinMcClure 1/30/2013 19:40'! testRegisterWidthConversions "Test the generalPurpose register methods #as8, #as16, #as32, #as64. Some resulting registers are not valid except in 64-bit mode, but that is not checked until you try to use the register in an instruction." | regs8 regs16 regs32 regs64 highByteRegs | regs8 := {AL. CL. DL. BL. SPL. BPL. SIL. DIL. R8B. R9B. R10B. R11B. R12B. R13B. R14B. R15B}. regs16 := {AX. CX. DX. BX. SP. BP. SI. DI. R8W. R9W. R10W. R11W. R12W. R13W. R14W. R15W}. regs32 := {EAX. ECX. EDX. EBX. ESP. EBP. ESI. EDI. R8D. R9D. R10D. R11D. R12D. R13D. R14D. R15D}. regs64 := {RAX. RCX. RDX. RBX. RSP. RBP. RSI. RDI. R8. R9. R10. R11. R12. R13. R14. R15}. highByteRegs := {AH. CH. DH. BH}. self assert: (regs8 collect: [ :r | r as8 ]) equals: regs8; assert: (regs16 collect: [ :r | r as8 ]) equals: regs8; assert: (regs32 collect: [ :r | r as8 ]) equals: regs8; assert: (regs64 collect: [ :r | r as8 ]) equals: regs8. self assert: (regs8 collect: [ :r | r as16 ]) equals: regs16; assert: (regs16 collect: [ :r | r as16 ]) equals: regs16; assert: (regs32 collect: [ :r | r as16 ]) equals: regs16; assert: (regs64 collect: [ :r | r as16 ]) equals: regs16. self assert: (regs8 collect: [ :r | r as32 ]) equals: regs32; assert: (regs16 collect: [ :r | r as32 ]) equals: regs32; assert: (regs32 collect: [ :r | r as32 ]) equals: regs32; assert: (regs64 collect: [ :r | r as32 ]) equals: regs32. self assert: (regs8 collect: [ :r | r as64 ]) equals: regs64; assert: (regs16 collect: [ :r | r as64 ]) equals: regs64; assert: (regs32 collect: [ :r | r as64 ]) equals: regs64; assert: (regs64 collect: [ :r | r as64 ]) equals: regs64. self assert: (highByteRegs collect: [ :r | r as8 ]) equals: highByteRegs; assert: (highByteRegs collect: [ :r | r as16 ]) equals: {AX. CX. DX. BX}; assert: (highByteRegs collect: [ :r | r as32 ]) equals: {EAX. ECX. EDX. EBX}; assert: (highByteRegs collect: [ :r | r as64 ]) equals: {RAX. RCX. RDX. RBX}! ! !AJx86RegisterTests methodsFor: 'as yet unclassified' stamp: 'MartinMcClure 1/30/2013 21:57'! testAsLowByte | highByteRegs lowByteRegs otherGPRegs | highByteRegs := {AH. CH. DH. BH}. lowByteRegs := {AL. CL. DL. BL}. otherGPRegs := AJx86Registers generalPurpose reject: [ :r | r isHighByte | r isLowByte ]. self assert: (highByteRegs collect: [ :r | r asLowByte ]) equals: lowByteRegs. self assert: (lowByteRegs collect: [ :r | r asLowByte ]) equals: lowByteRegs. self assert: otherGPRegs size equals: 60. "16 of each size, less the lowByteRegs" otherGPRegs do: [ :r | self should: [ r asLowByte ] raise: Error ]! ! !AJx86RegisterTests methodsFor: 'as yet unclassified' stamp: 'MartinMcClure 1/30/2013 21:56'! testAsHighByte | highByteRegs lowByteRegs otherGPRegs | highByteRegs := {AH. CH. DH. BH}. lowByteRegs := {AL. CL. DL. BL}. otherGPRegs := AJx86Registers generalPurpose reject: [ :r | r isHighByte | r isLowByte ]. self assert: (highByteRegs collect: [ :r | r asHighByte ]) equals: highByteRegs. self assert: (lowByteRegs collect: [ :r | r asHighByte ]) equals: highByteRegs. self assert: otherGPRegs size equals: 60. "16 of each size, less the lowByteRegs" otherGPRegs do: [ :r | self should: [ r asHighByte ] raise: Error ]! ! !AJx86Registers commentStamp: ''! I am a SHaredPool which initializes all the registers needed by the Assmbler.! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM7 "An MMX register" ^ self at: #MM7! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 3/20/2012 18:45'! registerBase: base class: regClass values: names | val | val := base. names do: [ :regName | | reg | reg := regClass code: val name: regName. self classPool at: regName put: reg. Codes at: val put: regName. val := val + 1]. ! ! !AJx86Registers class methodsFor: 'accessing' stamp: ''! all8 ^ self all select: [:reg| reg is8 ]! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ESP "A 32bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ self at: #ESP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ESI "A 32bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ self at: #ESI! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CL "A 8bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ self at: #CL! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14B "A 8bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ self at: #R14B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9D "A 32bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ self at: #R9D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM9 "An SSE register" ^ self at: #XMM9! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'MartinMcClure 1/27/2013 14:46'! initialize "AJx86Registers initialize" self classPool at: #Codes put: IdentityDictionary new. self initializeGeneralPurpose8BitRegisters. self initializeGeneralPurpose16BitRegisters. self initializeGeneralPurpose32BitRegisters. self initializeGeneralPurpose64BitRegisters. self initializeInstructionPointerRegisters. self initializeX87Registers. self initializeMMXRegisters. self initializeSSERegisters.! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R11 "A 64bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ self at: #R11! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12D "A 32bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ self at: #R12D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10W "A 16bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ self at: #R10W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RDX "A 64bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ self at: #RDX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM13 "An SSE register" ^ self at: #XMM13! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8B "A 8bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ self at: #R8B! ! !AJx86Registers class methodsFor: 'accessing' stamp: ''! all16 ^ self all select: [:reg| reg is16 ]! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RDI "A 64bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #RDI! ! !AJx86Registers class methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 15:27'! code: registerCode "Access a register by its code. Example: RBP == (self code: RBP code)" | registerName | self flag: 'XXX now this is some ugly code... add an instance variable for the requiresRex boolean instead of encoding it in #code'. registerName := Codes at: registerCode ifAbsent: [ Codes at: registerCode + 16r100 ifAbsent: [ Codes at: registerCode + 16r200 ifAbsent: [ KeyNotFound signalFor: registerCode ] ] ]. ^ self classPool at: registerName! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM8 "An SSE register" ^ self at: #XMM8! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! IP "A 16bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ self at: #IP! ! !AJx86Registers class methodsFor: 'method compilation' stamp: 'CamilloBruni 7/17/2012 11:27'! printRegister: register descriptionOn: s s nextPut: $". register descriptionOn: s. register influencingRegisters ifNotEmpty: [ :registers| s crtab nextPutAll: 'This register overlaps with '. registers do: [ :reg| s nextPutAll: reg name ] separatedBy: [ s nextPutAll: ', ']]. s nextPut: $"! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM1 "An SSE register" ^ self at: #XMM1! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM4 "An MMX register" ^ self at: #MM4! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM14 "An SSE register" ^ self at: #XMM14! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:04'! initializeInstructionPointerRegisters | ip eip rip | ip := AJx64RipRegister code: SI code name: #IP. eip := AJx64RipRegister code: ESI code name: #EIP. rip := AJx64RipRegister code: RSI code name: #RIP. Codes at: SI code negated put: #IP; at: ESI code negated put: #EIP; at: RSI code negated put: #RIP. self classPool at: #IP put: ip; at: #EIP put: eip; at: #RIP put: rip.! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM15 "An SSE register" ^ self at: #XMM15! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R13B "A 8bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ self at: #R13B! ! !AJx86Registers class methodsFor: 'accessing' stamp: ''! generalPurpose ^ self all select: [ :reg| reg isGeneralPurpose ]! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14W "A 16bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ self at: #R14W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DH "A 8bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ self at: #DH! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! AH "A 8bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ self at: #AH! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R15 "A 64bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ self at: #R15! ! !AJx86Registers class methodsFor: 'method compilation' stamp: 'CamilloBruni 7/17/2012 11:14'! installRegisterAccessors "this method creates simple accessors for all registers" | registerAccessorsCategory | registerAccessorsCategory := 'accessing registers'. "remove all methods in the 'accessing register' category" self class methodDict values select: [ :method | method category = registerAccessorsCategory ] thenDo: [ :method | self class removeSelector: method selector ]. self all do: [ :register | | method | "install the direct accessor on this class" self installRegister: register accessorCategory: registerAccessorsCategory. "install the accessor on the assembler" self installRegister: register accessorCategory: registerAccessorsCategory on: (register isX86 ifTrue: [ AJx86Assembler ] ifFalse: [ AJx64Assembler ])] displayingProgress: [ :each| each name ].! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM3 "An SSE register" ^ self at: #XMM3! ! !AJx86Registers class methodsFor: 'accessing' stamp: ''! doesNotUnderstand: aMessage self classPool at: aMessage selector ifPresent: [:val| ^ val ]. ^ super doesNotUnderstand: aMessage! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14D "A 32bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ self at: #R14D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13D "A 32bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ self at: #R13D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! SP "A 16bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ self at: #SP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10 "A 64bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ self at: #R10! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST4 "A floating point register" ^ self at: #ST4! ! !AJx86Registers class methodsFor: 'accessing' stamp: ''! generalPurpose8 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is8 ])! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST7 "A floating point register" ^ self at: #ST7! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM2 "An SSE register" ^ self at: #XMM2! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BX "A 16bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ self at: #BX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST5 "A floating point register" ^ self at: #ST5! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13 "A 64bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ self at: #R13! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST3 "A floating point register" ^ self at: #ST3! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R15B "A 8bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ self at: #R15B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R9B "A 8bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ self at: #R9B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BL "A 8bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ self at: #BL! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! AL "A 8bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ self at: #AL! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CX "A 16bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ self at: #CX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BH "A 8bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #BH! ! !AJx86Registers class methodsFor: 'method compilation' stamp: 'CamilloBruni 7/17/2012 11:28'! installRegister: register accessorCategory: registerAccessorsCategory ^ self class compile:(String streamContents: [ :s | s nextPutAll: register name; crtab. self printRegister: register descriptionOn: s. s crtab; nextPutAll: '^ self at: #'; nextPutAll: register name ]) classified: registerAccessorsCategory! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12W "A 16bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ self at: #R12W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9 "A 64bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ self at: #R9! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RCX "A 64bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ self at: #RCX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RIP "A 64bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ self at: #RIP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST1 "A floating point register" ^ self at: #ST1! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10B "A 8bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ self at: #R10B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! AX "A 16bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ self at: #AX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ECX "A 32bit general purpose register This register overlaps with CL, CX, ECX, RCX" ^ self at: #ECX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM7 "An SSE register" ^ self at: #XMM7! ! !AJx86Registers class methodsFor: 'accessing' stamp: ''! all64 ^ self all select: [:reg| reg is64 ]! ! !AJx86Registers class methodsFor: 'initialization' stamp: ''! initializeMMXRegisters " MMX registers " self registerBase: 16r60 class: AJMMRegister values: #( #MM0 #MM1 #MM2 #MM3 #MM4 #MM5 #MM6 #MM7 ).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'MartinMcClure 1/27/2013 10:06'! initializeGeneralPurpose8BitRegisters "general purpose 8 bit registers " self registerBase: 0 class: AJx86GPRegister rex: #dontCare values: #(#AL #CL #DL #BL); registerBase: 4 class: AJx86GPRegister rex: #prohibited values: #(#AH #CH #DH #BH); registerBase: 4 class: AJx86GPRegister rex: #required values: #(#SPL #BPL #SIL #DIL #R8B #R9B #R10B #R11B #R12B #R13B #R14B #R15B)! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DI "A 16bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #DI! ! !AJx86Registers class methodsFor: 'accessing' stamp: ''! generalPurpose16 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is16 ])! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:10'! initializeSSERegisters " SSE registers " self registerBase: 16r70 class: AJxMMRegister values: #( #XMM0 #XMM1 #XMM2 #XMM3 #XMM4 #XMM5 #XMM6 #XMM7 #XMM8 #XMM9 #XMM10 #XMM11 #XMM12 #XMM13 #XMM14 #XMM15).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'MartinMcClure 1/27/2013 09:56'! registerBase: base class: regClass rex: rexSymbol values: names | val | val := 0. rexSymbol == #required ifTrue: [ val := 16r100 ]. rexSymbol == #prohibited ifTrue: [ val := 16r200 ]. val := val + base. names do: [ :regName | | reg | reg := regClass code: val name: regName. self classPool at: regName put: reg. Codes at: val put: regName. val := val + 1 ]! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R15W "A 16bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ self at: #R15W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EDI "A 32bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #EDI! ! !AJx86Registers class methodsFor: 'accessing' stamp: ''! generalPurpose32 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is32 ])! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R11D "A 32bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ self at: #R11D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8 "A 64bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ self at: #R8! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST6 "A floating point register" ^ self at: #ST6! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM12 "An SSE register" ^ self at: #XMM12! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12 "A 64bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ self at: #R12! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8D "A 32bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ self at: #R8D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R10D "A 32bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ self at: #R10D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM0 "An SSE register" ^ self at: #XMM0! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R8W "A 16bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ self at: #R8W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! BP "A 16bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ self at: #BP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RBX "A 64bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ self at: #RBX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RSP "A 64bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ self at: #RSP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM5 "An SSE register" ^ self at: #XMM5! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EBX "A 32bit general purpose register This register overlaps with BL, BX, EBX, RBX" ^ self at: #EBX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RSI "A 64bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ self at: #RSI! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM0 "An MMX register" ^ self at: #MM0! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R15D "A 32bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ self at: #R15D! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST0 "A floating point register" ^ self at: #ST0! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R9W "A 16bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ self at: #R9W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM6 "An SSE register" ^ self at: #XMM6! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R14 "A 64bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ self at: #R14! ! !AJx86Registers class methodsFor: 'accessing' stamp: ''! all32 ^ self all select: [:reg| reg is32 ]! ! !AJx86Registers class methodsFor: 'accessing' stamp: ''! generalPurpose64 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is64 ])! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! EIP "A 32bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ self at: #EIP! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 5/21/2013 17:28'! initializeGeneralPurpose64BitRegisters "initialize general purpose 64 bit registers" self registerBase: 16r30 class: AJx86GPRegister rex: #dontCare values: #(#RAX #RCX #RDX #RBX #RSP #RBP #RSI #RDI); registerBase: 16r38 class: AJx86GPRegister rex: #required values: #(#R8 #R9 #R10 #R11 #R12 #R13 #R14 #R15)! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'MartinMcClure 1/27/2013 09:57'! initializeGeneralPurpose16BitRegisters "initialize general purpose 16 bit registers " self registerBase: 16r10 class: AJx86GPRegister rex: #dontCare values: #(#AX #CX #DX #BX #SP #BP #SI #DI); registerBase: 16r18 class: AJx86GPRegister rex: #required values: #(#R8W #R9W #R10W #R11W #R12W #R13W #R14W #R15W)! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EDX "A 32bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ self at: #EDX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! CH "A 8bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ self at: #CH! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! EAX "A 32bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ self at: #EAX! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! EBP "A 32bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ self at: #EBP! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM11 "An SSE register" ^ self at: #XMM11! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM1 "An MMX register" ^ self at: #MM1! ! !AJx86Registers class methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 10:54'! at: aRegisterIdentifierSymbol ^ self classPool at: aRegisterIdentifierSymbol! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM2 "An MMX register" ^ self at: #MM2! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! R12B "A 8bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ self at: #R12B! ! !AJx86Registers class methodsFor: 'accessing' stamp: ''! all ^ Codes values collect: [ :each| self classPool at: each ]! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM3 "An MMX register" ^ self at: #MM3! ! !AJx86Registers class methodsFor: 'accessing' stamp: 'MartinMcClure 1/30/2013 21:13'! generalPurposeWithIndex: index size: numBytes requiresRex: requiresRex prohibitsRex: prohibitsRex "Access a register by its properties. Example: RBP == (self generalPurposeWithIndex: RBP index size: RBP size requiresRex: RBP requiresRex prohibitsRex: RBP prohibitsRex )" | type code | type := numBytes = 1 ifTrue: [ 0 ] ifFalse: [ numBytes = 2 ifTrue: [ 16r10 ] ifFalse: [ numBytes = 4 ifTrue: [ 16r20 ] ifFalse: [ numBytes = 8 ifTrue: [ 16r30 ] ifFalse: [ self error: 'Size must be 1, 2, 4, or 8 bytes' ] ] ] ]. code := type + index. requiresRex ifTrue: [ code := code + RegRequiresRexMask ]. prohibitsRex ifTrue: [ code := code + RegProhibitsRexMask ]. ^ self classPool at: (Codes at: code)! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:10'! initializeX87Registers "X87 registers" self registerBase: 16r50 class: AJx87Register values: #( #ST0 #ST1 #ST2 #ST3 #ST4 #ST5 #ST6 #ST7 ).! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R13W "A 16bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ self at: #R13W! ! !AJx86Registers class methodsFor: 'initialization' stamp: ''! sortRegistersByIndex: aRegisterCollection ^ aRegisterCollection sort: [ :regA :regB| regA index < regB index ].! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R11W "A 16bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ self at: #R11W! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! R11B "A 8bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ self at: #R11B! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! SI "A 16bit general purpose register This register overlaps with DH, DX, EDX, RDX" ^ self at: #SI! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DX "A 16bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ self at: #DX! ! !AJx86Registers class methodsFor: 'method compilation' stamp: 'CamilloBruni 7/17/2012 11:18'! installRegister: register accessorCategory: registerAccessorsCategory on: aClass aClass compile: (String streamContents: [ :s | s nextPutAll: register name; crtab. self printRegister: register descriptionOn: s. s crtab; nextPutAll: '^ '; nextPutAll: register name ]) classified: registerAccessorsCategory ! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! RAX "A 64bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ self at: #RAX! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'MartinMcClure 1/27/2013 09:58'! initializeGeneralPurpose32BitRegisters "initialize general purpose 32 bit registers " self registerBase: 16r20 class: AJx86GPRegister rex: #dontCare values: #(#EAX #ECX #EDX #EBX #ESP #EBP #ESI #EDI); registerBase: 16r28 class: AJx86GPRegister rex: #required values: #(#R8D #R9D #R10D #R11D #R12D #R13D #R14D #R15D)! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST2 "A floating point register" ^ self at: #ST2! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM4 "An SSE register" ^ self at: #XMM4! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! DL "A 8bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ self at: #DL! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM6 "An MMX register" ^ self at: #MM6! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM5 "An MMX register" ^ self at: #MM5! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM10 "An SSE register" ^ self at: #XMM10! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! RBP "A 64bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ self at: #RBP! ! !AJx87Register commentStamp: ''! I am an x87 Floating Point register (ST0 - ST7) used in the FPU stack. The lower 64bit of the floating point ST registers are shared with the MMX registers.! !AJx87Register methodsFor: 'testing' stamp: ''! isGeneralPurpose ^ false! ! !AJx87Register methodsFor: 'accessing' stamp: ''! code: aCode code := aCode bitOr: RegX87. size := 10.! ! !AJx87Register methodsFor: 'testing' stamp: ''! isRegTypeX87 ^ true! ! !AJx87Register methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:12'! descriptionOn: s s nextPutAll: 'A floating point register'.! ! !AJx87Register methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2013 11:32'! influencingRegisters "ST registers overlap with the MMX register" self shouldBeImplemented.! ! !AJx87Register methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 15:31'! isX86 ^ true! ! !AJxMMRegister commentStamp: ''! I am a register used by the SSE (Streaming SIMD Extensions) for the x86 instruction set. The independent XMM registers are 128bit wide and do not overlap with any other existing registers. Depending on the instructions used the XMM registers represent different data types: SSE: 4 x 32bit single precision floats SSE2: 2 x 64bit double prexision floats 2 x 64bit integers 4 x 32bit integers 8 x 16bit short integers 16 x 8bit bytes/characters! !AJxMMRegister methodsFor: 'testing' stamp: ''! isGeneralPurpose ^ false! ! !AJxMMRegister methodsFor: 'accessing' stamp: ''! code: aCode code := aCode. size := 16! ! !AJxMMRegister methodsFor: 'testing' stamp: ''! isRegTypeXMM ^ true! ! !AJxMMRegister methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:15'! descriptionOn: s s nextPutAll: 'An SSE register'.! ! !AJxMMRegister methodsFor: 'testing' stamp: 'MartinMcClure 1/27/2013 15:33'! isX86 ^ self index < 8! ! !ASTBlockClosure commentStamp: ''! I am a specific class to the ASTInterpreter. I represent a BlockClosure in Pharo. Instance Variables homeContext: homeContext - is the homeContext of the BlockClosure ! !ASTBlockClosure methodsFor: 'evaluating' stamp: 'CamilloBruni 12/5/2011 16:13'! value: anArg value: otherArg value: anotherArg ^ self valueWithArguments: (Array with: anArg with: otherArg with: anotherArg)! ! !ASTBlockClosure methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 14:53'! homeContext: aContext homeContext := aContext! ! !ASTBlockClosure methodsFor: 'controlling' stamp: 'CamilloBruni 10/5/2011 17:50'! whileTrue self value ifTrue: [ self whileTrue ]! ! !ASTBlockClosure methodsFor: 'exception' stamp: 'CamilloBruni 12/13/2011 15:31'! ensure: aBlock "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." PrimitiveFailed signal! ! !ASTBlockClosure methodsFor: 'evaluating' stamp: 'CamilloBruni 12/5/2011 16:16'! value ^ self valueWithArguments: (Array new: 0)! ! !ASTBlockClosure methodsFor: 'evaluating' stamp: 'CamilloBruni 12/5/2011 16:13'! value: anArg ^ self valueWithArguments: (Array with: anArg)! ! !ASTBlockClosure methodsFor: 'exception' stamp: 'ClementBEra 3/6/2013 16:55'! valueNoContextSwitch ^ self value! ! !ASTBlockClosure methodsFor: 'visiting' stamp: 'CamilloBruni 10/5/2011 17:47'! accept: visitor ^ visitor visitBlockClosure: self! ! !ASTBlockClosure methodsFor: 'printing' stamp: 'ClementBera 12/7/2012 10:59'! printOn: aStream aStream nextPutAll: 'ASTBlockClosure: '. aStream nextPutAll: self code formattedCode! ! !ASTBlockClosure methodsFor: 'controlling' stamp: 'CamilloBruni 10/5/2011 17:50'! whileFalse self value ifFalse: [ self whileFalse ]! ! !ASTBlockClosure methodsFor: 'evaluating' stamp: 'CamilloBruni 12/12/2011 14:12'! cull: firstArg cull: secondArg cull: thirdArg cull: fourthArg "Execute the receiver with four or less arguments. Check cull:cull: for examples" ^ self numArgs < 4 ifTrue: [self cull: firstArg cull: secondArg cull: thirdArg] ifFalse: [self value: firstArg value: secondArg value: thirdArg value: fourthArg] ! ! !ASTBlockClosure methodsFor: 'controlling' stamp: 'ClementBera 1/21/2013 10:07'! whileFalse: aBlock self value ifFalse: [ aBlock value. self whileFalse: aBlock ]! ! !ASTBlockClosure methodsFor: 'controlling' stamp: 'ClementBera 1/21/2013 10:08'! whileTrue: aBlock self value ifTrue: [ aBlock value. self whileTrue: aBlock ]! ! !ASTBlockClosure methodsFor: 'accessing' stamp: 'ClementBera 12/3/2012 13:48'! code ^ code! ! !ASTBlockClosure methodsFor: 'evaluating' stamp: 'CamilloBruni 12/12/2011 14:12'! cull: firstArg cull: secondArg ^ self numArgs < 2 ifTrue: [self cull: firstArg] ifFalse: [self value: firstArg value: secondArg] ! ! !ASTBlockClosure methodsFor: 'accessing' stamp: 'ClementBera 12/3/2012 13:48'! code: anObject code := anObject! ! !ASTBlockClosure methodsFor: 'evaluating' stamp: 'CamilloBruni 12/5/2011 16:13'! value: anArg value: otherArg ^ self valueWithArguments: (Array with: anArg with: otherArg)! ! !ASTBlockClosure methodsFor: 'evaluating' stamp: 'CamilloBruni 12/12/2011 14:12'! cull: anArg ^ self numArgs = 0 ifTrue: [self value] ifFalse: [self value: anArg] ! ! !ASTBlockClosure methodsFor: 'evaluating' stamp: 'CamilloBruni 12/12/2011 14:12'! cull: firstArg cull: secondArg cull: thirdArg ^ self numArgs < 3 ifTrue: [self cull: firstArg cull: secondArg] ifFalse: [self value: firstArg value: secondArg value: thirdArg] ! ! !ASTBlockClosure methodsFor: 'exception' stamp: 'CamilloBruni 12/12/2011 16:13'! on: exception do: aBlock PrimitiveFailed signal! ! !ASTBlockClosure methodsFor: 'evaluating' stamp: 'CamilloBruni 12/5/2011 16:13'! value: anArg value: otherArg value: anotherArg value: yetAnotherArg ^ self valueWithArguments: (Array with: anArg with: otherArg with: anotherArg with: yetAnotherArg)! ! !ASTBlockClosure methodsFor: 'evaluating' stamp: 'ClementBEra 3/6/2013 17:44'! valueWithArguments: anArray | newContext ncv | self numArgs ~= anArray size ifTrue: [self numArgsError: anArray size]. ^PrimitiveFailed signal! ! !ASTBlockClosure methodsFor: 'evaluating' stamp: 'MarcusDenker 6/24/2013 11:03'! valueWithPossibleArgs: anArray | numberOfArgs | numberOfArgs := self numArgs. numberOfArgs = 0 ifTrue: [ ^ self value ]. numberOfArgs = anArray size ifTrue: [ ^ self valueWithArguments: anArray ]. numberOfArgs > anArray size ifTrue: [ ^ self valueWithArguments: anArray , (Array new: numberOfArgs - anArray size) ]. ^ self valueWithArguments: (anArray copyFrom: 1 to: numberOfArgs)! ! !ASTBlockClosure methodsFor: 'testing' stamp: 'ClementBera 12/3/2012 13:48'! = anASTBlockClosure (anASTBlockClosure class == self class)ifFalse: [^false]. (self homeContext = anASTBlockClosure homeContext)ifFalse: [^false]. ^true! ! !ASTBlockClosure methodsFor: 'accessing' stamp: 'ClementBera 12/3/2012 13:48'! numArgs ^ self code arguments size! ! !ASTBlockClosure methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 14:53'! returnContext ^ homeContext returnContext! ! !ASTBlockClosure methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 14:53'! homeContext ^ homeContext! ! !ASTCache commentStamp: ''! I am a simple cache for AST nodes corresponding to CompiledMethods in the image. The cache is emptied when the image is saved.! !ASTCache methodsFor: 'accessing' stamp: 'GuillermoPolito 5/14/2013 10:52'! at: aCompiledMethod ^ self at: aCompiledMethod ifAbsentPut: [ aCompiledMethod parseTree doSemanticAnalysisIn: aCompiledMethod methodClass ]! ! !ASTCache methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:29'! reset self removeAll! ! !ASTCache class methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:27'! reset default reset.! ! !ASTCache class methodsFor: 'class initialization' stamp: 'CamilloBruni 2/20/2012 18:54'! initialize default := self new. Smalltalk addToShutDownList: self.! ! !ASTCache class methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:30'! default ^ default! ! !ASTCache class methodsFor: 'system startup' stamp: 'CamilloBruni 2/17/2012 15:10'! shutDown self reset.! ! !ASTCache class methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:30'! default: anASTCache default := anASTCache.! ! !ASTCache class methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:22'! at: aCompiledMethod ^ default at: aCompiledMethod! ! !ASTCacheTest commentStamp: 'TorstenBergmann 2/4/2014 21:55'! SUnit tests for ASTCache! !ASTCacheTest methodsFor: 'tests' stamp: 'CamilloBruni 2/27/2012 23:16'! testRecompile compiledMethod ast. self assert: (ASTCache default includesKey: compiledMethod). "recompile the test method and avoid referring to the old method" compiledMethod := compiledMethod recompile. "trigger garbage collection to free the ASTCache" Smalltalk garbageCollect. self deny: (ASTCache default includesKey: compiledMethod).! ! !ASTCacheTest methodsFor: 'tests' stamp: 'CamilloBruni 2/17/2012 14:26'! testInCache self deny: (ASTCache default includesKey: compiledMethod). compiledMethod ast. self assert: (ASTCache default includesKey: compiledMethod).! ! !ASTCacheTest methodsFor: 'tests' stamp: 'CamilloBruni 2/17/2012 14:27'! testReset compiledMethod ast. self assert: (ASTCache default includesKey: compiledMethod). ASTCache reset. self deny: (ASTCache default includesKey: compiledMethod).! ! !ASTCacheTest methodsFor: 'running' stamp: 'CamilloBruni 2/17/2012 14:29'! setUp ASTCache reset. compiledMethod := ASTCacheTest >> #setUp.! ! !ASTInterpreter commentStamp: ''! I interpret AST. I run methods in my method-evalluation protocol, called through acceptMessageNode:receiver: Instance Variables context: currentNode: gotoContext: primitiveFailed: context - is the current context being interpreted currentNode - is the current node being interpreted gotoContext - In the case of non local return or exception it is used to return to the right context after executing the unwinded blocks. primitiveFailed - primitiveFail token ! !ASTInterpreter methodsFor: 'reflective' stamp: 'ClementBera 3/6/2013 16:24'! blockClosureValue: aBlockClosure message: aMessage |newMessage| newMessage := Message selector: #valueWithArguments: arguments: (Array with: aMessage arguments). ^self blockClosureValueWithArguments: aBlockClosure message: newMessage! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'ClementBera 3/18/2013 14:18'! acceptMessageNode: aMessageNode receiver: receiver | arguments message lookUpClass| context currentExecutedNode: aMessageNode. arguments := (aMessageNode arguments collect: [ :argument| |arg| arg := (self interpret: argument). self ifSkip: [ ^ arg ]. arg ]) asArray. message := Message selector: aMessageNode selector arguments: arguments. lookUpClass := aMessageNode isSuperSend ifFalse: [ self classOf: receiver ] ifTrue: [ self currentMethodClass superclass ]. ^ self send: message to: receiver class: lookUpClass! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitCascadeNode: aCascadeNode | receiver lastResult | receiver := self interpret: aCascadeNode receiver. aCascadeNode messages do: [ :aMessageNode| lastResult := self visitMessageNode: aMessageNode receiver: receiver. self ifSkip: [ ^ lastResult ]]. ^ lastResult! ! !ASTInterpreter methodsFor: 'testing' stamp: 'CamilloBruni 12/8/2011 18:27'! isExplicitelyReturning ^ gotoContext ~= false! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'ClementBera 4/6/2013 10:31'! acceptSequenceNode: aSequenceNode | lastResult | aSequenceNode statements do: [ :statement| lastResult := self interpret: statement. self ifSkip: [ ^ lastResult ]]. self updateGotoContext. ^ lastResult! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 10/23/2012 13:53'! updateGotoContext gotoContext == context ifTrue: [ gotoContext := false ].! ! !ASTInterpreter methodsFor: 'reflective' stamp: 'ClementBera 11/21/2012 10:46'! blockClosureOnDo: aBlockClosure message: aMessage | block result | block := aBlockClosure code. self assert: aMessage numArgs = 2. self blockContextFor: aBlockClosure message: aMessage. context exceptionHandler: (ExceptionHandler forMessage: aMessage). result := self interpretBlock: block. self popContext. ^ result! ! !ASTInterpreter methodsFor: 'reflective' stamp: 'ClementBera 4/21/2013 15:08'! object: receiver performMessageInSuperclass: aMessage "Check if the message to perform is valid and if so, execute it" | selector arguments lookupClass message| selector := aMessage arguments first. arguments := aMessage arguments second. lookupClass := aMessage arguments third. selector isSymbol ifFalse: [^self reflectiveFailedToken]. selector numArgs = arguments size ifFalse: [^self reflectiveFailedToken]. (receiver isKindOf: lookupClass) ifFalse: [^self reflectiveFailedToken]. message := Message selector: selector arguments: arguments. ^self send: message to: receiver class: lookupClass ! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'MarcusDenker 5/22/2013 16:48'! acceptAssignmentNode: anAssignmentNode | value variable | value := self interpret: anAssignmentNode value. variable := anAssignmentNode variable. variable binding accept: self assign: value. ^ value! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitArrayNode: anArrayNode | array | array := Array new: anArrayNode statements size. anArrayNode statements doWithIndex: [ :statement :i| array at: i put: (self interpret: statement)]. self updateGotoContext. ^ array! ! !ASTInterpreter methodsFor: 'context' stamp: 'ClementBera 4/2/2013 11:15'! blockContextFor: aBlockClosure message: aMessage | block | block := aBlockClosure code. context := AIBlockContext new homeContext: aBlockClosure homeContext; outerContext: context; closure: aBlockClosure; arguments: aMessage arguments; temporaries: block temporaryNames.! ! !ASTInterpreter methodsFor: 'slots' stamp: 'CamilloBruni 12/5/2011 15:23'! write: aValue at: index named: name ^ self currentSelf instVarAt: index put: aValue! ! !ASTInterpreter methodsFor: 'initialization' stamp: 'ClementBera 10/22/2012 10:57'! initialize super initialize. gotoContext := false.! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'ClementBera 10/19/2012 13:49'! acceptCascadeNode: aCascadeNode | receiver lastResult | receiver := self interpret: aCascadeNode receiver. aCascadeNode messages do: [ :aMessageNode| lastResult := self acceptMessageNode: aMessageNode receiver: receiver. self ifSkip: [ ^ lastResult ]]. ^ lastResult! ! !ASTInterpreter methodsFor: 'message - sending' stamp: 'CamilloBruni 12/5/2011 19:54'! send: aMessage to: receiver class: class | method | method := self lookupSelector: aMessage selector in: class. method ifNil: [ ^ self sendDoesNotUnderstandFor: aMessage to: receiver ]. ^ method accept: self on: receiver message: aMessage! ! !ASTInterpreter methodsFor: 'interpretation' stamp: 'GuillermoPolito 5/14/2013 12:03'! compile: aString | ast | ast := RBExplicitVariableParser parseExpression: aString. [ ast method doSemanticAnalysisIn: ProtoObject ] on: OCUndeclaredVariableWarning do: [ :e | self error: 'Undeclared variable', e variableNode name ]. ^ ast! ! !ASTInterpreter methodsFor: 'slots' stamp: 'CamilloBruni 12/5/2011 18:45'! write: aValue temporaryAt: index named: name ^ context tempNamed: name put: aValue! ! !ASTInterpreter methodsFor: 'interpretation' stamp: 'CamilloBruni 12/13/2011 16:14'! interpretBlock: block ^ self interpret: block body! ! !ASTInterpreter methodsFor: 'reflective' stamp: 'ClementBera 4/21/2013 15:04'! object: receiver performMessageWith: aMessage "transform the perform:[with:with:with:] methods in perform:withArguments: understood by ast-interpreter" | arguments oldArgs newMessage| oldArgs := aMessage arguments. arguments := Array with: oldArgs first with: (Array withAll: (oldArgs copyFrom: 2 to: oldArgs size)). newMessage := Message selector: aMessage selector arguments: arguments. ^ self object: receiver performMessageWithArgs: newMessage ! ! !ASTInterpreter methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 20:44'! resetContext: aContext context := aContext. gotoContext := false.! ! !ASTInterpreter methodsFor: 'context' stamp: 'CamilloBruni 12/13/2011 15:03'! methodContextFor: aCompiledMethod receiver: receiver message: aMessage context := AIMethodContext new receiver: receiver; outerContext: context; closure: aCompiledMethod; arguments: aMessage arguments; temporaries: aCompiledMethod code temporaryNames; yourself.! ! !ASTInterpreter methodsFor: 'message - sending' stamp: 'CamilloBruni 10/5/2011 17:24'! send: aMessage to: receiver ^ self send: aMessage to: receiver class: (self classOf: receiver)! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'ClementBera 4/2/2013 16:52'! acceptLiteralNode: aLiteralNode ^ aLiteralNode value ! ! !ASTInterpreter methodsFor: 'reflective' stamp: 'ClementBera 11/21/2012 10:46'! contextTerminateTo: aContext message: aMessage gotoContext := aMessage arguments first. ^ aMessage arguments second ! ! !ASTInterpreter methodsFor: 'reflective' stamp: 'ClementBera 12/3/2012 09:43'! blockClosureEnsure: aBlockClosure message: aMessage | result ensureBlockReturnValue firstGotoContext | "evaluate the block without arguments" result := self blockClosureValue: aBlockClosure. firstGotoContext := gotoContext. gotoContext := false. "evluate the passed in ensure block" ensureBlockReturnValue := self blockClosureValue: aMessage arguments first. self isExplicitelyReturning ifTrue: [ ^ ensureBlockReturnValue ] ifFalse: [ gotoContext := firstGotoContext ]. ^ result! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'ClementBera 12/5/2012 10:31'! acceptArrayNode: anArrayNode | array | array := Array new: anArrayNode statements size. anArrayNode statements doWithIndex: [ :statement :i| array at: i put: (self interpret: statement)]. self updateGotoContext. ^ array! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'ClementBera 12/4/2012 17:42'! acceptArgumentNode: aRBArgumentNode ^ self acceptVariableNode: aRBArgumentNode! ! !ASTInterpreter methodsFor: 'message - sending' stamp: 'ClementBEra 3/6/2013 17:45'! sendDoesNotUnderstandFor: aMessage to: receiver | dnu | dnu := Message selector: #doesNotUnderstand: argument: aMessage. ^ self send: dnu to: receiver! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitSequenceNode: aSequenceNode | lastResult | aSequenceNode statements do: [ :statement| lastResult := self interpret: statement. self ifSkip: [ ^ lastResult ]]. self updateGotoContext. ^ lastResult! ! !ASTInterpreter methodsFor: 'slots' stamp: 'CamilloBruni 12/5/2011 15:29'! readArgumentNamed: aName ^ self context tempNamed: aName! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'CamilloBruni 10/5/2011 17:38'! acceptLiteralArrayNode: aNode ^ aNode value! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'ClementBera 10/19/2012 10:36'! acceptReturnNode: aReturnNode | returnValue | returnValue := self interpret: aReturnNode value. self ifSkip: [ ^ returnValue ]. self assert: gotoContext == false. gotoContext := context returnContext. ^ returnValue! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'ClementBera 6/4/2013 14:55'! acceptBlockNode: aBlockNode ^ ASTBlockClosure new homeContext: self context; code: aBlockNode! ! !ASTInterpreter methodsFor: 'reflective' stamp: 'ClementBera 4/21/2013 15:08'! object: receiver performMessageWithArgs: aMessage "transform the perform:withArguments: method in perform:withArguments:inSuperclass: understood by ast-interpreter" | arguments newMessage| arguments := Array new: 3. arguments at: 1 put: aMessage arguments first. "selector" arguments at: 2 put: aMessage arguments second. "arguments" arguments at: 3 put: (self classOf: receiver). "lookup class" newMessage := Message selector: aMessage selector arguments: arguments. ^ self object: receiver performMessageInSuperclass: newMessage ! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'MarcusDenker 5/22/2013 16:49'! visitAssignmentNode: anAssignmentNode | value variable | value := self interpret: anAssignmentNode value. variable := anAssignmentNode variable. variable binding accept: self assign: value inNode: variable. ^ value! ! !ASTInterpreter methodsFor: 'reflective' stamp: 'ClementBera 3/4/2013 15:53'! unhandledErrorDefaultAction: anUnhandledError message: aMessage ^ InterpretationError signalFor: anUnhandledError exception.! ! !ASTInterpreter methodsFor: 'message - sending' stamp: 'ClementBera 3/7/2013 09:52'! sendCannotReturn: result from: returnContext | cannotReturn | gotoContext := false. self popContext. cannotReturn := Message selector: #cannotReturn: argument: result. ^ self send: cannotReturn to: returnContext! ! !ASTInterpreter methodsFor: 'accessing' stamp: 'CamilloBruni 12/8/2011 16:02'! currentSelf ^ self context receiver! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitLiteralNode: aLiteralNode ^ aLiteralNode value ! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitReturnNode: aReturnNode | returnValue | returnValue := self interpret: aReturnNode value. self ifSkip: [ ^ returnValue ]. self assert: gotoContext == false. gotoContext := context returnContext. ^ returnValue! ! !ASTInterpreter methodsFor: 'method evaluation' stamp: 'ClementBera 3/5/2013 17:32'! hasPrimitiveFailed: result "A primitive that fails doesn't always return ContextPart primitiveFailToken but returns ContextPart primitiveFailTokenFor: errorCode. A possible errorCode is nil, which corresponds to ContextPart primitiveFailToken. Here we loop over the errorCodes to know if the primitive has failed." |errorCodes| (self classOf: result) = ContextPart primitiveFailToken class ifFalse: [ ^ false ]. errorCodes := SmalltalkImage current specialObjectsArray at: 52. errorCodes do: [ :errorCode | result = (ContextPart primitiveFailTokenFor: errorCode) ifTrue: [ ^true ] ]. ^false! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'ClementBera 2/26/2013 09:59'! acceptMessageNode: aMessageNode | receiver | receiver := self interpret: aMessageNode receiver. self ifSkip: [^receiver ]. ^ self acceptMessageNode: aMessageNode receiver: receiver.! ! !ASTInterpreter methodsFor: 'method evaluation' stamp: 'ClementBera 4/6/2013 17:23'! invokePrimitiveMethod: aCompiledMethod on: receiver message: aMessage | result | result := receiver tryPrimitive: aCompiledMethod primitive withArgs: aMessage arguments. (self hasPrimitiveFailed: result) ifFalse: [ ^ result]. "primitive failed" ^ self invokeMethod: aCompiledMethod on: receiver message: aMessage! ! !ASTInterpreter methodsFor: 'accessing' stamp: 'CamilloBruni 10/6/2011 15:53'! context ^ context! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'MarcusDenker 5/22/2013 16:49'! acceptVariableNode: aVariableNode ^ aVariableNode binding readWith: self ! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'CamilloBruni 10/6/2011 15:51'! acceptSelfNode: aSelf ^ self currentSelf! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitSuperNode: aSelf ^ self currentSelf! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitSelfNode: aSelf ^ self currentSelf! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitMessageNode: aMessageNode | receiver | receiver := self interpret: aMessageNode receiver. self ifSkip: [^receiver ]. ^ self visitMessageNode: aMessageNode receiver: receiver.! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitThisContextNode: thisContextNode ^ self context! ! !ASTInterpreter methodsFor: 'interpretation' stamp: 'ClementBEra 3/6/2013 17:19'! reflectiveFailedToken ^#primitiveFailedASTInterpreterToken! ! !ASTInterpreter methodsFor: 'method evaluation' stamp: 'ClementBEra 3/6/2013 17:26'! invokeReflectiveMethod: aClosure on: receiver message: aMessage | annotation selector result | annotation := aClosure pragmaAt: #reflective:. selector := annotation arguments first. result := self perform: selector withArguments: (Array with: receiver with: aMessage). (self classOf: result) = ByteSymbol ifFalse: [ ^result ]. result = self reflectiveFailedToken ifFalse: [ ^ result ]. "primitive failed" ^self invokeMethod: aClosure on: receiver message: aMessage! ! !ASTInterpreter methodsFor: 'interpretation' stamp: 'CamilloBruni 12/13/2011 16:16'! interpret: anASTNode currentNode := anASTNode. ^ anASTNode acceptVisitor: self.! ! !ASTInterpreter methodsFor: 'interpretation' stamp: 'CamilloBruni 12/13/2011 16:14'! interpretMethod: method ^ self interpret: method body! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitBlockNode: aBlockNode ^ ASTBlockClosure new homeContext: self context; code: aBlockNode! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitTemporaryNode: aRBTemporaryNode ^ self visitVariableNode: aRBTemporaryNode! ! !ASTInterpreter methodsFor: 'slots' stamp: 'ClementBera 4/12/2013 13:52'! classOf: anObject ^ anObject class! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'MarcusDenker 5/22/2013 16:50'! visitVariableNode: aVariableNode ^ aVariableNode binding readWith: self inNode: aVariableNode! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitLiteralArrayNode: aNode ^ aNode value! ! !ASTInterpreter methodsFor: 'accessing' stamp: 'CamilloBruni 12/8/2011 00:23'! currentMethodClass ^ context methodClass! ! !ASTInterpreter methodsFor: 'accessing' stamp: 'ClementBera 10/23/2012 14:10'! currentNode ^currentNode! ! !ASTInterpreter methodsFor: 'reflective' stamp: 'CamilloBruni 12/13/2011 15:42'! blockClosureValue: aBlockClosure ^ self blockClosureValue: aBlockClosure message: (Message selector: #value)! ! !ASTInterpreter methodsFor: 'interpretation' stamp: 'ClementBera 3/18/2013 11:16'! interpretDoIt: ast | result | "set the source of the root context to the doIt code" self context method: ast source. [result := self interpret: ast] on: VariableNotDefined do: [ :e| e context isRootContext ifFalse: [ e pass ] ifTrue: [ e createTemp; resume: true]]. ^ result! ! !ASTInterpreter methodsFor: 'slots' stamp: 'MarcusDenker 5/22/2013 16:49'! readArgumentAt: index node: aVariableNode | variableContext | variableContext := self context. [ variableContext code = aVariableNode binding definingScope node ] whileFalse: [ variableContext := variableContext homeContext. self assert: variableContext isNil not ]. ^ variableContext arguments at: index! ! !ASTInterpreter methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 20:14'! context: aContext context := aContext! ! !ASTInterpreter methodsFor: 'slots' stamp: 'CamilloBruni 12/5/2011 15:22'! readInstVarAt: index named: name ^ self currentSelf instVarAt: index! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'ClementBera 12/4/2012 17:40'! acceptTemporaryNode: aRBTemporaryNode ^ self acceptVariableNode: aRBTemporaryNode! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitMessageNode: aMessageNode receiver: receiver | arguments message lookUpClass| context currentExecutedNode: aMessageNode. arguments := (aMessageNode arguments collect: [ :argument| |arg| arg := (self interpret: argument). self ifSkip: [ ^ arg ]. arg ]) asArray. message := Message selector: aMessageNode selector arguments: arguments. lookUpClass := aMessageNode isSuperSend ifFalse: [ self classOf: receiver ] ifTrue: [ self currentMethodClass superclass ]. ^ self send: message to: receiver class: lookUpClass! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'CamilloBruni 12/5/2011 19:31'! acceptSuperNode: aSelf ^ self currentSelf! ! !ASTInterpreter methodsFor: 'slots' stamp: 'CamilloBruni 12/5/2011 18:46'! readTemporaryAt: index named: name ^ context tempNamed: name! ! !ASTInterpreter methodsFor: 'visiting' stamp: 'ClementBera 4/12/2013 13:57'! visitArgumentNode: aRBArgumentNode ^ self visitVariableNode: aRBArgumentNode! ! !ASTInterpreter methodsFor: 'reflective' stamp: 'ClementBera 3/4/2013 15:04'! rootContextHandleSignal: aRootContext message: aMessage | exception | exception := aMessage arguments first. exception class = Halt ifTrue: [ ^ InterpretationError signalFor: exception ]. "run the normal excpetion handling procedures if there is no Halt" self invokeMethod: (AIRootContext >> #handleSignal:) on: aRootContext message: aMessage! ! !ASTInterpreter methodsFor: 'slots' stamp: 'CamilloBruni 12/5/2011 18:23'! readArgumentAt: index named: aName ^ self context arguments at: index! ! !ASTInterpreter methodsFor: 'message - sending' stamp: 'ClementBera 4/2/2013 16:53'! lookupSelector: selector in: class | currentClass | currentClass := class. [ currentClass isNil ] whileFalse: [ currentClass methodDict at: selector ifPresent: [ :method | ^ method ]. currentClass := currentClass superclass ]. ^ nil! ! !ASTInterpreter methodsFor: 'reflective' stamp: 'ClementBera 3/18/2013 16:21'! blockClosureValueWithArguments: aBlockClosure message: aMessage | block result arguments| block := aBlockClosure code. arguments := aMessage arguments at: 1. (aBlockClosure numArgs = arguments size) ifFalse: [ ^self reflectiveFailedToken ]. block size = 0 ifTrue: [ ^ nil ]. self blockContextFor: aBlockClosure message: (Message selector: nil arguments: arguments). result := self interpretBlock: block. self isExplicitelyReturning ifTrue: [ self context homeContext isDead ifTrue: [ ^self sendCannotReturn: result from: context]]. self popContext. ^ result! ! !ASTInterpreter methodsFor: 'context' stamp: 'ClementBera 3/18/2013 16:21'! popContext context die. context := context outerContext. self updateGotoContext.! ! !ASTInterpreter methodsFor: 'method evaluation' stamp: 'ClementBEra 3/6/2013 17:33'! invokeMethod: aClosure on: receiver message: aMessage | result | self assert: aClosure numArgs = aMessage numArgs. self methodContextFor: aClosure receiver: receiver message: aMessage. result := self interpretMethod: aClosure ast. self isExplicitelyReturning ifFalse: [ result := self currentSelf ]. self popContext. ^ result! ! !ASTInterpreter methodsFor: 'interpretation' stamp: 'ClementBera 10/22/2012 19:57'! ifSkip: aReturnBlock gotoContext == false ifTrue: [ ^ self ]. aReturnBlock value.! ! !ASTInterpreter methodsFor: 'deprecated' stamp: 'CamilloBruni 12/5/2011 15:14'! acceptThisContextNode: thisContextNode ^ self context! ! !ASTInterpreter class methodsFor: 'interpreting' stamp: 'MarcusDenker 5/9/2013 22:32'! interpretVMContext: aContext | interpreter | self flag: #TODO. "not implemented yet" interpreter := self new. interpreter resetContext: aContext asASTInterpreterContext. ^interpreter interpret: aContext sourceNode. ! ! !ASTInterpreter class methodsFor: 'interpreting' stamp: 'ClementBera 10/19/2012 13:45'! interpretMethod: anASTNode ^ self new resetContext: AIRootContext new; interpretMethod: anASTNode! ! !ASTInterpreterTest commentStamp: 'TorstenBergmann 2/4/2014 21:54'! SUnit tests for ASTInterpreter! !ASTInterpreterTest methodsFor: 'testing - exceptions' stamp: 'ClementBera 10/19/2012 12:35'! testExceptionReturn self assert: (self interpret: '[ Error signal ] on: Error do: [ :err| err return: 5 + 1 ].') = 6. self assert: (self interpret: '[ Error signal ] on: Error do: [ :err| err return: 5 + 1 ]. true') = true.! ! !ASTInterpreterTest methodsFor: 'testing - message sent' stamp: 'CamilloBruni 12/12/2011 16:39'! testSend self assert: (self interpret: '#(1 2) at: 1') = 1. self assert: (self interpret: '1 + 2') = 3. "this is for future use :)" self assert: (self interpret: '123 asString') = '123'.! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 3/6/2013 13:12'! testLookUp self assert: (self interpret: '(ASTInterpreterTest selector: #foo) superSendInNestedBlock') equals: #foo. ! ! !ASTInterpreterTest methodsFor: 'testing - exceptions' stamp: 'ClementBera 3/4/2013 15:06'! testSignalException [ self interpret: 'Exception signal' ] on: InterpretationError do: [ :error | self assert: (error cause isKindOf: SubclassResponsibility). ^ self ]. self fail.! ! !ASTInterpreterTest methodsFor: 'helper' stamp: 'ClementBera 12/6/2012 13:07'! compile: aString ^interpreter compile: aString! ! !ASTInterpreterTest methodsFor: 'testing - message sent' stamp: 'CamilloBruni 10/5/2011 17:39'! testBinarySend self assert: (self interpret: '1 + 2') = 3. self assert: (self interpret: '1 < 2') = true.! ! !ASTInterpreterTest methodsFor: 'testing - message sent' stamp: 'CamilloBruni 12/8/2011 00:21'! testPrimitive self assert: (self interpret: '1 + 1') = 2. "simple" self assert: (self interpret: '1 + 1.5') = 2.5. "with fallback"! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 12/5/2011 09:56'! testConstant self assert: (self interpret: '1') = 1. self assert: (self interpret: 'nil') = nil. self assert: (self interpret: 'false') = false. self assert: (self interpret: '''asdf''') = 'asdf'. self assert: (self interpret: '#symbol') = #symbol.! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testAssert self should: [ self interpret: 'ASTInterpreterTest new assert: false ' ] raise: InterpretationError. self interpret: 'ASTInterpreterTest new assert: true '! ! !ASTInterpreterTest methodsFor: 'testing - message sent' stamp: 'CamilloBruni 3/6/2013 12:59'! testDNU | interpretationError dnu | [ self interpret: '1 aMessageNotUnderstoodBySmallInteger' ] on: InterpretationError do: [ :err| interpretationError := err ]. dnu := interpretationError cause. self assert: dnu message selector equals: #aMessageNotUnderstoodBySmallInteger. self assert: dnu receiver equals: 1. [ self interpret: '1 aMessageNotUnderstoodBySmallInteger: #someArgument' ] on: InterpretationError do: [ :err| interpretationError := err ]. dnu := interpretationError cause. self assert: dnu message selector equals: #aMessageNotUnderstoodBySmallInteger:. self assert: dnu message arguments equals: {#someArgument}. self assert: dnu receiver equals: 1.! ! !ASTInterpreterTest methodsFor: 'testing - blocks' stamp: 'ClementBera 3/7/2013 09:38'! testBlockOutOfHomeContext self should: [ self interpret: 'ASTInterpreterTest new errorBlock value' ] raise: InterpretationError. self assert: (self interpret: 'ASTInterpreterTest new block value') equals: 2. self assert: (self interpret: 'ASTInterpreterTest new blockTemp value') equals: 5. self assert: (self interpret: 'ASTInterpreterTest new blockTempWrite value') equals: 5.! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 3/5/2013 13:43'! testLazyInitialization self assert: (self interpret: ' ASTInterpreterTest new lazyInitialization ') equals: 5. ! ! !ASTInterpreterTest methodsFor: 'testing - message sent' stamp: 'CamilloBruni 12/9/2011 19:55'! testMethodArguments self assert: (self interpret: 'ASTInterpreterTest testMethodArguments: 1') = 1. ! ! !ASTInterpreterTest methodsFor: 'testing - message sent' stamp: 'ClementBera 12/11/2012 09:51'! testDNUCatched |message| message := self interpret: 'DoesNotUnderstandCatcher new someUnknownMessage'. self assert: message selector equals: #someUnknownMessage. self assert: message arguments equals: #(). message := self interpret: 'DoesNotUnderstandCatcher new someUnknownMessage: #someUnknownArg'. self assert: message selector equals: #someUnknownMessage:. self assert: message arguments equals: {#someUnknownArg}.! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 3/6/2013 12:54'! testThisContext self assert: ((self interpret: 'thisContext') isKindOf: AIRootContext). "The home context of a AIRootContext is nil" self assert: (self interpret: 'thisContext home') equals: nil. self assert: (self interpret: 'thisContext homeContext') equals: nil. self assert: ((self interpret: 'ASTInterpreterTest new thisContextMethod') isKindOf: AIContext). self assert: ((self interpret: 'ASTInterpreterTest new thisContextCopyMethod') isKindOf: AIContext). ! ! !ASTInterpreterTest methodsFor: 'testing - message sent' stamp: 'CamilloBruni 3/6/2013 13:01'! testDNUInNestedBlock | interpretationError dnu | [ self interpret: '[[ #someReceiver aMessageNotUnderstoodBySmallInteger: #someArgument ] value ] value' ] on: InterpretationError do: [ :err| interpretationError := err ]. dnu := interpretationError cause. self assert: dnu message selector equals: #aMessageNotUnderstoodBySmallInteger:. self assert: dnu message arguments equals: {#someArgument}. self assert: dnu receiver equals: #someReceiver.! ! !ASTInterpreterTest methodsFor: 'testing - exceptions' stamp: 'ClementBera 12/11/2012 09:31'! testEnsureTricky self assert: (self interpret: '(String streamContents: [:s | [ [s nextPutAll: 1 printString. 1/0] ensure: [s nextPutAll: 2 printString] ] on: Error do: [s nextPutAll: 3 printString] ]) asInteger') equals: 132. "not fixed yet" self assert: (self interpret: '[[Error signal] ensure: [1].3]on: Error do: [2]') equals: 2. ! ! !ASTInterpreterTest methodsFor: 'testing - blocks' stamp: 'ClementBera 1/14/2013 11:01'! testBlockVar self assert: (self interpret: '[ |a| a := 1. a ] value') = 1. self assert: (self interpret: '[ |a| a := 1 + 2. a + 3 ] value') = 6. self assert: (self interpret: '[ |a| [ a := 1 ] value ] value') = 1. self assert: (self interpret: '[ |a| a := 1. [ a := 2 ] value ] value') = 2. self assert: (self interpret: '[ |a| a := 1. [ a := a + 1 ] value ] value') = 2. self assert: (self interpret: '[ :b ||a| a := 1. [ :c| a := a + 1 + c ] value: b ] value: 3') = 5. self assert: (self interpret: '|b| b := 2. [ |a| a := 1. a ] value') = 1. self assert: (self interpret: '|b| b := 2. [ |a| a := 1. a ] value. b') = 2.! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 4/21/2013 15:09'! testPerform self should: [self interpret: '#de perform: #negated'] raise: InterpretationError. self assert: (self interpret: '1 perform: #negated') equals: 1 negated. self assert: (self interpret: '1 perform: #+ with: 2') equals: 3. self assert: (self interpret: '1 perform: #+ withArguments: #(2)') equals: 3.! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 2/26/2013 10:32'! testLoop self assert: (self interpret: ' |index| index := 1. [index := index + 1. index = 10 ] whileFalse. index ') equals: 10. self assert: (self interpret: ' ASTInterpreterTest new returningBlockInsideLoop ') equals: ASTInterpreterTest new returningBlockInsideLoop. self assert: (self interpret: ' ASTInterpreterTest new returningLoop ') equals: ASTInterpreterTest new returningLoop. ! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 12/3/2012 15:12'! testBasicCode self assert: (self interpret: '[ true ifTrue: [ nil ] ifFalse: [ 1 ]] value') equals: nil. self assert: (self interpret: '[ false ifTrue: [ nil ] ifFalse: [ 1 ]] value') = 1. self assert: (self interpret: '[ |a| a :=1. [ a < 10 ] whileTrue: [ a := a + 1]. a] value') = 10.! ! !ASTInterpreterTest methodsFor: 'testing - blocks' stamp: 'ClementBera 3/6/2013 10:57'! testBlockArgument self assert: (self interpret: '[ :a| a ] value: 1') = 1. self assert: (self interpret: '[ :a| a + 3 ] value: 3 ') = 6. self assert: (self interpret: '[ :a :b | a + b ] value: 3 value: 5 ') = 8. self assert: (self interpret: '[ :a| a ] valueWithArguments: #(1)') equals: 1. self should: [self interpret: '[ :a| a ] valueWithArguments: #(1 3)'] raise: InterpretationError. self assert: (self interpret: '[ :a| a + 3 ] valueWithArguments: #(3) ') equals: 6.! ! !ASTInterpreterTest methodsFor: 'testing - blocks' stamp: 'ClementBera 2/26/2013 10:05'! testExternalBlock self assert: (self interpret: 'ASTInterpreterTest new returningTempBlock') equals: ASTInterpreterTest new returningTempBlock. ! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 12/11/2012 09:26'! testInstanceCreation self assert: ((self interpret: 'Array new') isKindOf: Array). self assert: ((self interpret: 'Array new: 10') isKindOf: Array). self assert: ((self interpret: 'OrderedCollection new') isKindOf: OrderedCollection). self assert: ((self interpret: 'Error new') isKindOf: Error). self assert: ((self interpret: 'MessageNotUnderstood new') isKindOf: MessageNotUnderstood)! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testProtoObjectMethod "This test works in you move Object>>#class to ProtoObject>>#class I proposed the fix in the bug issue tracker " self interpret: 'ProtoObject new flag: #hallo'! ! !ASTInterpreterTest methodsFor: 'testing - message sent' stamp: 'CamilloBruni 3/6/2013 13:05'! testSuperDNU | interpretationError dnu | [ self interpret: 'InterpreterTest new unknownSuperSend' ] on: InterpretationError do: [ :err| interpretationError := err ]. dnu := interpretationError cause. self assert: dnu message selector equals: #aSelectorThatDoesNotExist. self assert: dnu message arguments isEmpty. self assert: (dnu receiver isKindOf: InterpreterTest). [ self interpret: 'InterpreterTest new unknownSuperSendInNestedBlock' ] on: InterpretationError do: [ :err| interpretationError := err ]. dnu := interpretationError cause. self assert: dnu message selector equals: #aSelectorThatDoesNotExist. self assert: dnu message arguments isEmpty. self assert: (dnu receiver isKindOf: InterpreterTest).! ! !ASTInterpreterTest methodsFor: 'testing - exceptions' stamp: 'ClementBera 12/7/2012 11:21'! testExceptionHandling self assert: (self interpret: '[ ] on: Error do: [ :err| false ].') = nil. self assert: (self interpret: '[ ] on: Error do: [ :err| false ]. true') = true. self assert: (self interpret: '[ ] on: Error do: [ :err| ^ false ]. true') = true. self assert: (self interpret: '[ Error signal ] on: Error do: [ :err| false ]') = false. self assert: (self interpret: '[ Error signal ] on: Error do: [ :err| false ]. true') equals: true. self assert: (self interpret: '[ Error signal ] on: Error do: [ :err| ^ false ]. true') = false. self assert: (self interpret: '[[ Error signal ] value ] on: Error do: [ :err| false ]') = false. self assert: (self interpret: '[[ Error signal ] value ] on: Error do: [ :err| false ]. true') = true. self assert: (self interpret: '[[ Error signal ] value ] on: Error do: [ :err| ^ false ]. true') = false. self assert: (self interpret: '[self errorBlock value] on: Error do: [:err | false]') equals: false. self assert: (self interpret: '[self errorBlock value ] on: Error do: [ :err| false ]. true') = true. self assert: (self interpret: '[self errorBlock value ] on: Error do: [ :err| ^ false ]. true') = false.! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 12/7/2012 10:45'! testAsInteger self assert: (self interpret: '#123 asInteger') equals: 123. self assert: (self interpret: '(String withAll: #($1 $2 $3)) asInteger') equals: 123. ! ! !ASTInterpreterTest methodsFor: 'testing - message sent' stamp: 'CamilloBruni 12/5/2011 11:24'! testUnarySend self assert: (self interpret: '1 asInteger') = 1. self assert: (self interpret: '1 class') = SmallInteger.! ! !ASTInterpreterTest methodsFor: 'helper' stamp: 'ClementBera 1/14/2013 13:20'! interpret: aString | result | "context homeContext: thisContext". interpreter resetContext: context. result := interpreter interpretDoIt: (self compile: aString). self assert: interpreter context = context. ^ result! ! !ASTInterpreterTest methodsFor: 'testing - exceptions' stamp: 'ClementBera 12/3/2012 15:43'! testEnsureBasic self assert: (self interpret: '[ ] ensure: [ 2 ].') = nil. self assert: (self interpret: '[ 1 ] ensure: [ 2 ].') = 1. self assert: (self interpret: '[ 1 ] ensure: [ 2 ]. 3') = 3. self assert: (self interpret: '[ 1 ] ensure: [ ^ 2 ]. 3') = 2. self assert: (self interpret: '[ ^ 1 ] ensure: [ ^ 2 ]. 3') = 2. self should: [self interpret: '[ Error signal ] ensure: [ ^ 2 ]. 3'] raise: InterpretationError. self should: [self interpret: '[ [Error signal] value ] ensure: [ ^ 2 ]. 3' ] raise: InterpretationError. ! ! !ASTInterpreterTest methodsFor: 'testing - blocks' stamp: 'CamilloBruni 8/31/2013 20:23'! testBlockCannotReturn self should: [ self interpret: 'ASTInterpreterTest new returningBlock value' ] raise: InterpretationError. self should: [ self interpret: 'ASTInterpreterTest new returningBlockArg value: 1' ] raise: InterpretationError. self interpret: 'ASTInterpreterTest new returningBlockNonRootContext2 '. self interpret: 'ASTInterpreterTest new returningBlockNonRootContext '! ! !ASTInterpreterTest methodsFor: 'testing - exceptions' stamp: 'CamilloBruni 8/31/2013 20:23'! testNotification self interpret: 'Notification signal'! ! !ASTInterpreterTest methodsFor: 'testing - exceptions' stamp: 'ClementBera 10/19/2012 12:39'! testExceptionResume self assert: (self interpret: '[ 1 + Exception signal ] on: Exception do: [ :err| err resume: 5 ].') = 6. self assert: (self interpret: '[ 1 + Exception signal ] on: Exception do: [ :err| err resume: 5 ]. true') = true.! ! !ASTInterpreterTest methodsFor: 'helper' stamp: 'ClementBera 12/11/2012 11:41'! interpretTest: aTest | result | "context homeContext: thisContext". interpreter resetContext: context. result := interpreter interpret: (aTest ast body). self assert: interpreter context = context. ^ result! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 12/11/2012 09:49'! testArrayNonLiteral |x y| x := 5 + 2. y := #aSymbol. self assert: (self interpret: '|x y| x := 5 + 2. y := #aSymbol. {x . y}') equals: {x . y}.! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 1/14/2013 11:11'! testString self assert: (self interpret: 'String withAll: #($h $e $l $l $o)') equals: 'hello'. self assert: (self interpret: '$a asSymbol') equals: #a. self assert: (self interpret: '''a''') equals: 'a'. self assert: (self interpret: '''a'' asSymbol') equals: #a. self assert: (self interpret: '(String withAll: #($h $e $l $l $o)) asSymbol') equals: #hello.! ! !ASTInterpreterTest methodsFor: 'testing - exceptions' stamp: 'CamilloBruni 8/31/2013 20:53'! testExceptionCull (self interpret: 'ASTInterpreterTest new should: [ [:x :y | ] cull: 1] raise: Error'). ! ! !ASTInterpreterTest methodsFor: 'testing - blocks' stamp: 'ClementBera 10/17/2012 14:02'! testBlock self assert: ((self interpret: '[ 1 ]') isKindOf: ASTBlockClosure). self assert: (self interpret: '[ 1 ] value') = 1. self assert: (self interpret: '[^1] value') = 1. self assert: (self interpret: '[ 1 + 2 ] value') = 3. self assert: (self interpret: 'true ifTrue: [ 1 ] ifFalse: [ 0 ]') = 1. self assert: (self interpret: 'false ifTrue: [ 1 ] ifFalse: [ 0 ]') = 0. ! ! !ASTInterpreterTest methodsFor: 'testing - exceptions' stamp: 'CamilloBruni 7/15/2013 21:49'! testSignalHalt [ self interpret: '[1 halt] value' ] on: InterpretationError do: [ :error | self assert: error cause class equals: Halt. ^ self ]. self fail.! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 12/5/2011 14:56'! testGlobals self assert: (self interpret: 'Array') = Array! ! !ASTInterpreterTest methodsFor: 'testing - exceptions' stamp: 'ClementBera 2/28/2013 18:05'! testException1 [ (self interpret: 'Error signal: #anErrorHappened') ] on: InterpretationError do: [ :err | | originalError | originalError := err cause. self assert: (originalError isKindOf: Error). self assert: originalError messageText equals: #anErrorHappened. ^ #success ]. self fail.! ! !ASTInterpreterTest methodsFor: 'helper' stamp: 'CamilloBruni 12/9/2011 22:21'! setUp "for now we use an ast cache to speed up the ast lookup" ASTCache initialize. interpreter := ASTInterpreter new. context := AIRootContext new.! ! !ASTInterpreterTest methodsFor: 'testing - blocks' stamp: 'ClementBera 3/7/2013 09:40'! testCull self should: [self interpret: '[ :x :y | x + y ] cull: 1'] raise: InterpretationError. self assert: (self interpret: '[:x | x] cull: 1') = 1. self assert: (self interpret: '[2] cull: 1') = 2. self should: [self interpret: '[ :x :y :z | x + y + z ] cull: 1 cull: 2'] raise: InterpretationError. self assert: (self interpret: '[:x :y | x + y] cull: 1 cull: 2') = 3. self assert: (self interpret: '[:x | x] cull: 1 cull: 2') = 1. self assert: (self interpret: '[5] cull: 1 cull: 2') = 5. ! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 2/26/2013 10:29'! testRepeat self assert: (self interpret: '[^5] repeat') equals: 5.! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 1/14/2013 11:11'! testWeakSet self assert: (self interpret: ' | index start | index := start := 4 hash \\ 7 + 1. index ') equals: 4 hash \\ 7 + 1. self assert: (self interpret: ' | index start | index := start := 4 hash \\ 7 + 1. start ') equals: 4 hash \\ 7 + 1. self assert: (self interpret: 'WeakSet new add: 1') equals: (WeakSet new add: 1). self assert: (self interpret: 'WeakSet new add: 1; scanFor: 1') equals: (WeakSet new add: 1; scanFor: 1) ! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 12/5/2012 10:16'! testArrayBasic self assert: (self interpret: '#(12 #de 1.2)') equals: #(12 #de 1.2). self assert: (self interpret: '{12 . #de . 1.2}') equals: {12 . #de . 1.2}. ! ! !ASTInterpreterTest methodsFor: 'testing - blocks' stamp: 'ClementBera 1/14/2013 13:14'! testNonLocalReturnExternal self assert: (self interpret: 'ASTInterpreterTest new returningBlockValue') equals: ASTInterpreterTest new returningBlockValue ! ! !ASTInterpreterTest methodsFor: 'testing' stamp: 'ClementBera 1/14/2013 10:45'! testAssignTemp self assert: (self interpret: '[ |x| x:=4. x] value') equals: 4. self should: [self interpret: '[ |x| x:=4. y] value'] raise: Error. self assert: (self interpret: 'ASTInterpreterTest new methodWithTemp') equals: 7. self assert: (self interpret: '|x| x:=4. x') equals: 4. self assert: (self interpret: '|x y| x:=4. y') equals: nil. self assert: (self interpret: '|x y| y:=x:=4. y') equals: 4. self assert: (self interpret: '|x y| y:=1. y:=x:=4. y') equals: 4.! ! !ASTInterpreterTest methodsFor: 'testing - exceptions' stamp: 'ClementBera 12/11/2012 09:51'! testEnsureNonLocalReturn "does not work" "self assert: false." self assert: (self interpret: ' |x aCol| aCol := OrderedCollection new. x := ASTInterpreterTest new setUp ensureNonLocalReturn: aCol. x + aCol first ') equals: 7 ! ! !ASTInterpreterTest methodsFor: 'testing - blocks' stamp: 'CamilloBruni 12/8/2011 18:21'! testNonLocalReturn self assert: (self interpret: 'false ifTrue: [ ^ 1 ]. ^ 1 + 1') = 2. self assert: (self interpret: 'true ifTrue: [ ^ 1 ]. ^ 1 + 1') = 1. self assert: (self interpret: 'false ifTrue: [ ^ 1 ] ifFalse: [^ 2]. 1 + 1 + 1') = 2.! ! !ASTInterpreterTest class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 12/9/2011 19:56'! testMethodArguments: anObject ^ [ anObject ] value! ! !ASTStackMappingTest commentStamp: 'TorstenBergmann 2/4/2014 21:54'! SUnit tests for stack mapping! !ASTStackMappingTest methodsFor: 'methods' stamp: 'ClementBera 10/21/2012 16:38'! fooAdd2: foo ^foo + 2! ! !ASTStackMappingTest methodsFor: 'testing' stamp: 'ClementBera 10/23/2012 10:27'! testConvertBlockContext | aSTBlockContext | aSTBlockContext := self blockContext asASTInterpreterContext. self assert: self blockContext home asASTInterpreterContext = aSTBlockContext homeContext. self assert: self blockContext outerContext asASTInterpreterContext equals: aSTBlockContext outerContext. self assert: self blockContext closure asASTBlockClosure equals: aSTBlockContext closure. self assert: self blockContext tempNames equals: aSTBlockContext temporaries keys. self assert: self blockContext arguments equals: aSTBlockContext arguments. ! ! !ASTStackMappingTest methodsFor: 'methods' stamp: 'ClementBera 10/18/2012 15:20'! foo: anArg |a| a := anArg. ^thisContext copy asASTInterpreterContext.! ! !ASTStackMappingTest methodsFor: 'accessing' stamp: 'ClementBera 10/18/2012 10:20'! methodContext ^ methodContext! ! !ASTStackMappingTest methodsFor: 'as yet unclassified' stamp: 'ClementBera 10/18/2012 10:47'! setUp blockContext := [] asContext. methodContext := thisContext copy.! ! !ASTStackMappingTest methodsFor: 'testing' stamp: 'ClementBera 10/18/2012 18:19'! testException |exceptionBlock blockCtx astBlockCtx| exceptionBlock := [ Transcript show: 'banana' ]. [ blockCtx := thisContext copy. astBlockCtx := blockCtx asASTInterpreterContext. Error signal] on: Error do: exceptionBlock. self assert: astBlockCtx exceptionHandler exception equals: Error. self assert: astBlockCtx exceptionHandler block equals: exceptionBlock.! ! !ASTStackMappingTest methodsFor: 'testing' stamp: 'ClementBera 10/18/2012 15:23'! testBlockTemporaries |blockCtx| [ :x :y | x+y. blockCtx := thisContext copy asASTInterpreterContext ] value: 5 value: 7. self assert: (blockCtx temporaries at: 'x') = 5. self assert: (blockCtx temporaries at: 'y') = 7. ! ! !ASTStackMappingTest methodsFor: 'testing' stamp: 'ClementBera 3/7/2013 09:59'! testInterpret |foo bar| "will fail : goal" foo := 1. foo := foo + 1. self assert: foo = 2. self assert: (thisContext copy isKindOf: ContextPart). Smalltalk switchInterpreterTo: thisContext copy asASTInterpreterContext. foo := foo + 2. self assert: foo = 4. self assert: (thisContext copy isKindOf: AIContext).! ! !ASTStackMappingTest methodsFor: 'testing' stamp: 'ClementBera 10/18/2012 15:13'! testTemporaries | a b c ctx blockCtx| a := 1. b := True . c := 'guineaPig'. ctx := thisContext copy asASTInterpreterContext. self assert: (ctx temporaries at: 'a') = 1. self assert: (ctx temporaries at: 'b') = True. self assert: (ctx temporaries at: 'c') = 'guineaPig'. ! ! !ASTStackMappingTest methodsFor: 'accessing' stamp: 'ClementBera 10/18/2012 10:20'! blockContext ^ blockContext! ! !ASTStackMappingTest methodsFor: 'testing' stamp: 'ClementBera 10/18/2012 14:38'! testConvertMethodContext | aSTMethodContext | aSTMethodContext := self methodContext asASTInterpreterContext. self assert: self methodContext outerContext asASTInterpreterContext equals: aSTMethodContext outerContext. self assert: self methodContext method = aSTMethodContext closure. self assert: self methodContext tempNames = aSTMethodContext temporaries keys. self assert: self methodContext arguments = aSTMethodContext arguments. self assert: self methodContext receiver = aSTMethodContext receiver.! ! !ASTStackMappingTest methodsFor: 'testing' stamp: 'ClementBera 3/7/2013 09:59'! testInterpretBasic |ctx result block | block := [ctx := thisContext copy.self fooAdd2: 4 ]. block value. result := ASTInterpreter interpretVMContext: ctx. "self assert: (result isKindOf: ASTBlockClosure). self assert: (result homeContext tempNamed: #tmp) equals: block value." self assert: result equals: 6.! ! !ASTStackMappingTest methodsFor: 'testing' stamp: 'ClementBera 10/18/2012 15:22'! testMethodArgs |methodCtx| "foo: anArg |a| a := anArg. ^thisContext copy asASTInterpreterContext." methodCtx := self foo: 'bar'. self assert: (methodCtx arguments includes: 'bar'). self assert: (methodCtx temporaries at: 'a') = 'bar'. self assert: (methodCtx temporaries at: 'anArg') = 'bar'.! ! !Abort commentStamp: 'TorstenBergmann 2/4/2014 21:42'! Notify to abort a task! !Abort methodsFor: 'accessing' stamp: 'ajh 3/24/2003 00:55'! defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ! !AboutDialogWindow commentStamp: 'gvc 5/18/2007 13:53'! Default superclass for application about dialogs.! !AboutDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 16:32'! newButtons "Answer new buttons as appropriate." ^{self newCloseButton isDefault: true}! ! !AbsolutePath commentStamp: ''! I represent an absolute path (a position starting from Path root)! !AbsolutePath methodsFor: 'testing' stamp: 'cwp 2/26/2011 11:03'! isRoot ^ self size = 0! ! !AbsolutePath methodsFor: 'enumerating' stamp: 'EstebanLorenzano 4/2/2012 11:42'! withParents ^ super withParents addFirst: (Path root); yourself! ! !AbsolutePath methodsFor: '*zinc-resource-meta-filesystem' stamp: 'SvenVanCaekenberghe 1/14/2013 10:03'! asZnUrl "Convert the receiver in a file:// ZnUrl" | fileUrl | fileUrl := ZnUrl new. fileUrl scheme: #file. self do: [ :each | fileUrl addPathSegment: each ]. ^ fileUrl! ! !AbsolutePath methodsFor: 'printing' stamp: 'EstebanLorenzano 4/3/2012 11:15'! printOn: aStream aStream nextPutAll: 'Path'. self isRoot ifTrue: [aStream nextPutAll: ' root'] ifFalse: [1 to: self size do: [:i | aStream nextPutAll: ' / '''; nextPutAll: (self at: i); nextPut: $']]! ! !AbsolutePath methodsFor: 'testing' stamp: 'cwp 2/26/2011 10:58'! isAbsolute ^ true! ! !AbsolutePath class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 1/19/2012 15:12'! addEmptyElementTo: result! ! !AbsolutePath class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 1/19/2012 15:02'! from: aString delimiter: aDelimiterCharater aString = '/' ifTrue: [ ^ self root ]. ^ super from: aString delimiter: aDelimiterCharater! ! !AbstractAcceptor commentStamp: ''! I am an abstract acceptor. The goal of my children is to properly dispatch the behavior when text is accepted. Depending of the context, different actions could be triggered! !AbstractAcceptor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/16/2013 16:45'! model ^ model! ! !AbstractAcceptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/16/2013 16:43'! accept: aText notifying: aController self subclassResponsibility! ! !AbstractAcceptor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/16/2013 16:41'! model: anObject model := anObject! ! !AbstractAcceptor class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/16/2013 16:41'! model: model ^ self new model: model; yourself! ! !AbstractAdapter commentStamp: ''! I am an abstrat class. Iam the superclass of all the adapters used to link a Spec widget model to a framework specific widget (by example ButtonModel <-> PluggableButtonMorph)! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:42'! hSpaceFill self subclassResponsibility! ! !AbstractAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/29/2013 14:16'! selector ^ selector! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:41'! layout: aLayout self subclassResponsibility! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:42'! vShrinkWrap self subclassResponsibility! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:42'! hRigid self subclassResponsibility! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:42'! hShrinkWrap self subclassResponsibility! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/1/2013 13:14'! when: anAnnouncement do: aBlock self subclassResponsibility! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:42'! vSpaceFill self subclassResponsibility! ! !AbstractAdapter methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 9/25/2013 16:18'! update: aSymbol with: anArray self perform: aSymbol withArguments: anArray! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:42'! removeSubWidgets self subclassResponsibility! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:41'! add: aWidget self subclassResponsibility! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 13:42'! asWidget ^ self widget! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 14:40'! takeKeyboardFocus self widget ifNotNil: [:w | w takeKeyboardFocus ]! ! !AbstractAdapter methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 9/25/2013 14:46'! adapt: aComposableModel model := aComposableModel. aComposableModel addDependent: self. widget := self buildWidget.! ! !AbstractAdapter methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/26/2013 17:19'! isSpecAdapter ^ true! ! !AbstractAdapter methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 9/25/2013 14:44'! update: aSymbol self changed: aSymbol! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:42'! vRigid self subclassResponsibility! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:42'! useProportionalLayout self subclassResponsibility! ! !AbstractAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/25/2013 13:57'! widget ^ widget! ! !AbstractAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/29/2013 14:16'! selector: anObject selector := anObject! ! !AbstractAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/25/2013 13:48'! model ^ model! ! !AbstractAdapter methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/10/2013 12:15'! isMorphicAdapter ^ false! ! !AbstractAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/1/2013 13:32'! isRedrawable "This must be overriden in the adapter representing your container" ^ false! ! !AbstractAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/22/2014 14:26'! buildWidget ^ SpecInterpreter private_interpretASpec: self class defaultSpec model: self selector: nil! ! !AbstractAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/10/2014 12:35'! widgetDo: aBlock ^ self widget ifNotNil: aBlock! ! !AbstractAdapter class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 9/25/2013 14:17'! adapt: aComposableModel ^ self new adapt: aComposableModel; yourself! ! !AbstractApiSetter commentStamp: 'TorstenBergmann 2/5/2014 09:18'! Abstract Widget setter API! !AbstractApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:46'! initialExtent ^ 450@25! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! method: anObject method value: anObject! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! selector ^ selector! ! !AbstractApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:59'! updateWith: aValue self isSetting ifFalse: [ self isSetting: true. self internUpdateWith: aValue. self isSetting: false ]! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 19:45'! registerEvents self registerRetrievingMethodEvent. self registerModelEvent. self registerMethodEvents! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/13/2012 02:41'! registerMethodEvents method whenChangedDo: [ :s | selector text: s asString. self model ifNotNil: [ :m | choice help: (m class lookupSelector: s) comment ] ]! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! method ^ method value! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 20:41'! setValueTo: anObject self model ifNil: [ ^ self ]. self method ifNil: [ ^ self ]. self isSetting ifFalse: [ self isSetting: true. self model perform: (self method) with: anObject. self isSetting: false ].! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! initializeWidgets self instantiateModels: #( selector LabelModel choice DropListModel ). self selector text: ''. self choice items: (#(true false) collect: [:b | DropListItem named: b printString do: [ self setValueTo: b ]]).! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 20:34'! registerRetrievingMethodEvent retrievingMethod whenChangedDo: [ :meth | self model ifNotNil: [ :m || value | value := m perform: meth. self internUpdateWith: value ]]! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! choice ^ choice! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 20:35'! isSetting: aBoolean isSetting := aBoolean ! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 20:34'! registerModelEvent model whenChangedDo: [ :m | self retrievingMethod ifNotNil: [ :meth || value | value := m perform: meth. self internUpdateWith: value ]]! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! retrievingMethod ^ retrievingMethod value! ! !AbstractApiSetter methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize method := nil asReactiveVariable. model := nil asReactiveVariable. retrievingMethod := nil asReactiveVariable. isSetting := false. super initialize. self registerEvents! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! model ^ model value! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 20:35'! isSetting ^ isSetting! ! !AbstractApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 19:25'! selectorWidth: aNumber | layout | layout := SpecLayout composed newRow: [:r | r newColumn: [:c | c add: #selector ] width: aNumber; add: #choice ] height: 25; yourself. self needRebuild: false. selector needRebuild: false. choice needRebuild: false. self buildWithSpecLayout: layout.! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! model: anObject model value: anObject! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! retrievingMethod: anObject retrievingMethod value: anObject! ! !AbstractApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 20:34'! internUpdateWith: aValue self subclassResponsibility! ! !AbstractApiSetter class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! spec ^ SpecLayout composed newRow: [:r | r add: #selector; newColumn: [:c | c add: #choice ] width: 75] height: 25; yourself! ! !AbstractCategoryWidget commentStamp: ''! AbstractCategoryWidget is an abstraction describing a widget used to manage categories! !AbstractCategoryWidget methodsFor: 'protocol' stamp: ''! vScrollValue ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: ''! selectedCategory ^ self model selectedCategory! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: ''! searchedElement: index ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:35'! wantsDroppedMorph: transferMorph event: anEvent inMorph: destinationLM "We are only interested in TransferMorphs as wrappers for informations. If their content is really interesting for us, will determined later in >>acceptDroppingMorph:event:." | srcType dstType | "only want drops on lists (not, for example, on pluggable texts)" (destinationLM isKindOf: PluggableListMorph) ifFalse: [ ^ false ]. srcType := transferMorph dragTransferType. dstType := self dragTransferTypeForMorph: destinationLM. ^ srcType == #getMethodItem: and: [ dstType == #getCategoryItem:]! ! !AbstractCategoryWidget methodsFor: 'drag and drop' stamp: ''! dropMethod: aCollectionOfMethods inARow: aRow self model dropMethod: aCollectionOfMethods inARow: aRow! ! !AbstractCategoryWidget methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:34'! dragPassengersFor: item inMorph: dragSource | transferType object | (dragSource isKindOf: PluggableListMorph) ifFalse: [^ nil ]. transferType := self dragTransferTypeForMorph: dragSource. object := item originalObject. transferType == #getCategoryItem: ifTrue: [ ^ self selectedCategories ifEmpty: [ { object } ] ]. ^ nil! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: ''! categoriesMenu: aMenuMorph shifted: aBoolean ^ self model categoriesMenu: aMenuMorph shifted: aBoolean ! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: ''! showInstance ^ self model showInstance! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: ''! vScrollValue: aNumber ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'item creation' stamp: ''! buildCategoriesList ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: ''! categoriesSelection ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: ''! keyPressedOnCategory: anEvent ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/17/2012 16:57'! okToChange ^ self model okToChange! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: ''! selectedCategories ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'icon' stamp: 'EstebanLorenzano 5/14/2013 17:35'! categoryIconFor: aString self flag: #todo. "this would work better with the new class organizer" "((aString beginsWith: '---') or: [ aString = 'no messages' ]) ifTrue: [ ^ Smalltalk ui icons protocolNoneIcon ]." (aString beginsWith: '*') ifTrue: [ ^ Smalltalk ui icons protocolExtensionIcon ]. (aString beginsWith: 'private') ifTrue: [ ^ Smalltalk ui icons protocolPrivateIcon ]. ((aString = 'initialization' or: [ aString = 'initialize-release' ]) or: [ aString = 'finalization' ]) ifTrue: [ ^ Smalltalk ui icons protocolProtectedIcon ]. ^ Smalltalk ui icons protocolNoneIcon ! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: ''! label: aString ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: ''! takeKeyboardFocus ^ self subclassResponsibility! ! !AbstractClassInstaller commentStamp: ''! I take a ready class and install it in a given environment. My sublcasses implement custom strategies.! !AbstractClassInstaller methodsFor: 'notifications' stamp: 'ToonVerwaest 3/22/2011 17:43'! classAdded: aClass inCategory: aCategory self subclassResponsibility! ! !AbstractClassInstaller methodsFor: 'traits' stamp: 'MartinDias 7/1/2013 14:54'! copyTraitCompositionFrom: oldClass to: newClass self installTraitComposition: oldClass traitComposition copyTraitExpression on: newClass. "We have to manually unsubcribe the newClass from its traits. Later in the class-building phase newClass becomeForward: oldClass and hence we can no longer distinguish the two. Which would leave `newClass trait users`, an IdetitySet, in an invalid state, as it's elements have been modified (the becomeForward:) without a proper rehash." newClass traitComposition traits do: [ :trait | trait removeUser: newClass ]. ! ! !AbstractClassInstaller methodsFor: 'initialization' stamp: 'MartinDias 1/28/2014 15:13'! initialize builder := SlotClassBuilder new. builder installer: self! ! !AbstractClassInstaller methodsFor: 'notifications' stamp: 'ToonVerwaest 3/22/2011 18:38'! classDefinitionDeeplyChangedFrom: oldClass to: newClass by: classModification self subclassResponsibility! ! !AbstractClassInstaller methodsFor: 'accessing' stamp: 'ToonVerwaest 3/22/2011 17:42'! builder ^ builder! ! !AbstractClassInstaller methodsFor: 'accessing' stamp: 'ToonVerwaest 3/22/2011 17:45'! environment: anEnvironment self subclassResponsibility! ! !AbstractClassInstaller methodsFor: 'traits' stamp: 'MartinDias 6/24/2013 18:25'! installTraitComposition: aTraitComposition on: aClass self flag: 'Should probably send something else to test'. aClass setTraitComposition: aTraitComposition! ! !AbstractClassInstaller methodsFor: 'notifications' stamp: 'ToonVerwaest 3/22/2011 18:38'! classDefinitionShallowChangedFrom: oldClass to: newClass by: classModification self subclassResponsibility! ! !AbstractClassInstaller methodsFor: 'migrating' stamp: 'ToonVerwaest 3/22/2011 18:30'! migrateClasses: old to: new using: anInstanceModification self subclassResponsibility! ! !AbstractClassInstaller methodsFor: 'accessing' stamp: 'ToonVerwaest 3/22/2011 17:44'! classAt: aName ifAbsent: aBlock self subclassResponsibility! ! !AbstractClassInstaller methodsFor: 'notifications' stamp: 'ToonVerwaest 3/22/2011 17:44'! recategorize: aClass to: aCategory self subclassResponsibility! ! !AbstractClassInstaller methodsFor: 'accessing' stamp: 'CamilloBruni 6/28/2013 14:03'! environment self subclassResponsibility! ! !AbstractClassInstaller class methodsFor: 'building' stamp: 'ToonVerwaest 3/22/2011 19:12'! make: aBlock | builder | builder := self new builder. aBlock value: builder. ^ builder build! ! !AbstractClassModification commentStamp: ''! I represent a class modification. I content field modifications.! !AbstractClassModification methodsFor: 'accessing' stamp: 'MartinDias 4/12/2013 13:01'! layout: aLayout layout := aLayout. layout host: target. layout finalize. layout = target layout ifFalse: [ self computeChange ]! ! !AbstractClassModification methodsFor: 'private' stamp: 'MartinDias 7/11/2013 15:30'! propagate target subclassesDo: [ :subclass | propagations add: (ClassModificationPropagation propagate: self to: subclass) ]. "recursively propagate this change down" propagations do: [ :propagation | propagation propagate ] ! ! !AbstractClassModification methodsFor: 'accessing' stamp: 'MartinDias 7/11/2013 15:39'! allPropagationsDo: aBlock propagations do: [ :aPropagation | aBlock value: aPropagation. aPropagation allPropagationsDo: aBlock ]! ! !AbstractClassModification methodsFor: 'testing' stamp: 'MartinDias 1/28/2014 16:17'! isPropagation ^ self subclassResponsibility ! ! !AbstractClassModification methodsFor: 'public' stamp: 'ToonVerwaest 4/1/2011 17:49'! apply ^ newClass := target shallowCopy superclass: self superclass layout: layout! ! !AbstractClassModification methodsFor: 'private' stamp: 'ToonVerwaest 3/21/2011 01:20'! computeChange self checkSanity.! ! !AbstractClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/31/2011 19:53'! result ^ target! ! !AbstractClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/20/2011 13:50'! layout ^ layout! ! !AbstractClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 17:49'! newClass ^ newClass! ! !AbstractClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 17:24'! newLayout ^ layout! ! !AbstractClassModification methodsFor: 'initialization' stamp: 'ToonVerwaest 4/1/2011 03:31'! initialize propagations := OrderedCollection new.! ! !AbstractClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 17:38'! oldLayout ^ target layout! ! !AbstractClassModification methodsFor: 'accessing' stamp: 'CamilloBruni 3/30/2011 19:27'! checkSanity layout checkSanity.! ! !AbstractClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/20/2011 19:40'! target ^ target! ! !AbstractClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/19/2011 15:57'! target: aTarget target := aTarget! ! !AbstractCompiler commentStamp: ''! I define the public API of compilers that can be used as system compilers (e.g. overriding #compiler on the class side).! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! evaluate: aString in: aContext to: aReceiver ^self source: aString; context: aContext; receiver: aReceiver; failBlock: [^ #failedDoit]; evaluate! ! !AbstractCompiler methodsFor: 'public access' stamp: 'MarcusDenker 7/27/2013 19:34'! translate self subclassResponsibility! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:09'! compiledMethodTrailer: aClass self subclassResponsibility! ! !AbstractCompiler methodsFor: 'old - decompiler' stamp: 'MarcusDenker 7/27/2013 19:25'! decompileMethod: aCompiledMethod self subclassResponsibility! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:10'! logged: aBoolean self subclassResponsibility! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! compileNoPattern: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: aFailBlock ^self source: textOrStream; class: aClass; context: aContext; requestor: aRequestor; noPattern: true; failBlock: aFailBlock; translate! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:10'! useFaultyForParsing: anObject self subclassResponsibility! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! format: textOrStream in: aClass notifying: aRequestor ^self source: textOrStream; class: aClass; requestor: aRequestor; format ! ! !AbstractCompiler methodsFor: 'public access' stamp: 'MarcusDenker 7/27/2013 19:33'! compile self subclassResponsibility! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! evaluate: textOrString logged: logFlag ^ self source: textOrString; logged: logFlag; evaluate ! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! evaluate: textOrString notifying: aController logged: logFlag ^ self source: textOrString; logged: logFlag; requestor: aController; evaluate ! ! !AbstractCompiler methodsFor: '*Deprecated30' stamp: 'MarcusDenker 7/27/2013 19:25'! decompile: aSelector in: aClass method: aCompiledMethod self deprecated: 'use #decompileMethod:' on: '09 May 2013' in: 'Pharo 3.0'. ^self decompileMethod: aCompiledMethod! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:09'! environment: anSmallTalkImage self subclassResponsibility! ! !AbstractCompiler methodsFor: 'public access' stamp: 'MarcusDenker 7/27/2013 19:32'! evaluate: textOrString ^self source: textOrString; evaluate! ! !AbstractCompiler methodsFor: '*Deprecated30' stamp: 'MarcusDenker 7/27/2013 19:25'! decompile: aSelector in: aClass self deprecated: 'use #decompileMethod:' on: '09 May 2013' in: 'Pharo 3.0'. ^self decompileMethod: (aClass compiledMethodAt: aSelector)! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! evaluate: textOrStream in: aContext to: aReceiver notifying: aRequestor ifFail: aFailBlock ^self source: textOrStream; context: aContext; receiver: aReceiver; requestor: aRequestor; failBlock: aFailBlock; evaluate! ! !AbstractCompiler methodsFor: 'public access' stamp: 'MarcusDenker 7/27/2013 19:33'! options: anArray self subclassResponsibility! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:09'! failBlock: aBlock self subclassResponsibility! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! compile: textOrStream in: aClass notifying: aRequestor ifFail: aFailBlock ^self source: textOrStream; class: aClass; requestor: aRequestor; failBlock: aFailBlock; translate ! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! parse: aString class: aClass ^self source: aString; class: aClass; parse! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:09'! compilationContextClass: aClass self subclassResponsibility! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:10'! requestor: aRequestor self subclassResponsibility! ! !AbstractCompiler methodsFor: 'public access' stamp: 'MarcusDenker 7/27/2013 19:34'! parse self subclassResponsibility! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! parse: textOrStream in: aClass notifying: req ^self source: textOrStream; class: aClass; requestor: req; translate.! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! parse: aString class: aClass noPattern: aBoolean context: aContext notifying: req ifFail: aBlock "Backwards compatibilty" ^self source: aString; class: aClass; noPattern: aBoolean; context: aContext; requestor: req; failBlock: aBlock; translate.! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:09'! context: aContext self subclassResponsibility! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:10'! noPattern: aBoolean self subclassResponsibility! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! evaluate: textOrStream in: aContext to: aReceiver notifying: aRequestor ifFail: aFailBlock logged: logFlag ^self source: textOrStream; context: aContext; receiver: aReceiver; requestor: aRequestor; failBlock: aFailBlock; logged: logFlag; evaluate! ! !AbstractCompiler methodsFor: 'public access' stamp: 'MarcusDenker 7/27/2013 19:34'! parseLiterals: aString self subclassResponsibility! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:10'! receiver: anObject self subclassResponsibility! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:08'! compilationContext self subclassResponsibility! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:08'! class: aClass self subclassResponsibility! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! evaluate: textOrString for: anObject notifying: aController logged: logFlag ^ self source: textOrString; logged: logFlag; receiver: anObject; requestor: aController; evaluate ! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:09'! compilationContextClass self subclassResponsibility! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! compile: textOrStream in: aClass classified: aCategory notifying: aRequestor ifFail: aFailBlock ^self source: textOrStream; class: aClass; requestor: aRequestor; category: aCategory; failBlock: aFailBlock; translate! ! !AbstractCompiler methodsFor: 'public access' stamp: 'MarcusDenker 7/27/2013 19:33'! evaluate self subclassResponsibility! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:09'! compilationContext: anObject self subclassResponsibility! ! !AbstractCompiler methodsFor: 'public access' stamp: 'MarcusDenker 7/27/2013 19:33'! format self subclassResponsibility! ! !AbstractCompiler methodsFor: 'old - public' stamp: 'MarcusDenker 7/28/2013 15:06'! evaluate: textOrString for: anObject logged: logFlag ^self source: textOrString; logged: logFlag; receiver: anObject; evaluate! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:10'! source: aString self subclassResponsibility! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:10'! useFaultyForParsing self subclassResponsibility! ! !AbstractCompiler methodsFor: 'public access' stamp: 'MarcusDenker 7/27/2013 19:34'! parseSelector: aString self subclassResponsibility! ! !AbstractCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/28/2013 15:08'! category: aCategory self subclassResponsibility! ! !AbstractEcryptor commentStamp: ''! An AbstractEcryptor is an interface for encryptor. It's basically just an algorithm to encrypt a string, without ensuring it can be decrypted! !AbstractEcryptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/6/2012 22:08'! encrypt: aString ^ self subclassResponsibility! ! !AbstractEcryptorDecryptor commentStamp: ''! An AbstractEcryptorDecryptor is an interface providing the method for encrypting/decrypting a string! !AbstractEcryptorDecryptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/6/2012 22:07'! decrypt: aString base: aBase ^ self subclassResponsibility! ! !AbstractEcryptorDecryptor methodsFor: 'protocol' stamp: 'Camillo 5/15/2012 11:21'! encrypt: aString base: aBase ^ self subclassResponsibility! ! !AbstractEnumerationVisitor commentStamp: ''! I'm an abstract superclass for enumeration operations on directory entries. ! !AbstractEnumerationVisitor methodsFor: 'initialization' stamp: 'CamilloBruni 8/9/2011 15:46'! initializeWithBlock: aBlock self initialize. block := aBlock! ! !AbstractEnumerationVisitor methodsFor: 'visiting' stamp: 'CamilloBruni 8/9/2011 15:48'! visitReference: anEntry self subclassResponsibility! ! !AbstractEnumerationVisitor methodsFor: 'visiting' stamp: 'CamilloBruni 8/9/2011 15:46'! visit: aReference with: aGuide out := (Array new: 10) writeStream. aGuide show: aReference. ^ out contents! ! !AbstractEnumerationVisitor methodsFor: 'visiting' stamp: 'EstebanLorenzano 4/2/2012 11:38'! preorder: aReference ^ self visit: aReference with: (PreorderGuide for: self)! ! !AbstractEnumerationVisitor methodsFor: 'visiting' stamp: 'EstebanLorenzano 4/2/2012 11:38'! postorder: aReference ^ self visit: aReference with: (PostorderGuide for: self)! ! !AbstractEnumerationVisitor methodsFor: 'visiting' stamp: 'EstebanLorenzano 4/2/2012 11:37'! breadthFirst: aReference ^ self visit: aReference with: (BreadthFirstGuide for: self)! ! !AbstractEnumerationVisitorTest commentStamp: 'TorstenBergmann 1/31/2014 11:41'! SUnit tests for AbstractEnumerationVisitor! !AbstractEnumerationVisitorTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/12/2011 15:45'! root ^ filesystem / 'alpha'! ! !AbstractEnumerationVisitorTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/9/2011 16:01'! setUp super setUp. self setUpGreek.! ! !AbstractEnumerationVisitorTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 4/10/2013 12:38'! assertEntries: references are: expected | strings | self assert: references isArray. references do: [ :ea | self assert: ea class = FileSystemDirectoryEntry ]. strings := references collect: [ :ea | ea reference pathString ]. self assert: strings equals: expected! ! !AbstractEnumerationVisitorTest class methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 4/3/2012 09:42'! isAbstract ^ self name = #AbstractEnumerationVisitorTest! ! !AbstractEyeElement commentStamp: ''! I represent an abstract inspection element. In an EyeInspector, a eye element corresponds to a wrapper around a field element. Public API : label: display on left list panel of the eye inspector description: printed on the right panel of the eye inspector host: object inspected in the eye inspector value: object represented by this eye element ! !AbstractEyeElement methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 3/14/2014 10:29'! shouldShowInTree ^ true! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 4/30/2013 10:48'! description ^ self value printStringLimitedTo: 2000! ! !AbstractEyeElement methodsFor: 'action' stamp: 'CamilloBruni 4/30/2013 10:43'! browseValue ^ self value browse! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 2/25/2014 18:23'! errorWhileAccessing: selector do: aBlock [ self perform: selector ] on: Error do: [ :error | aBlock cull: error cull: selector ].! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 2/25/2014 18:29'! withErrorsDo: aBlock self errorPropertySelectors do: [ :selector | self errorWhileAccessing: selector do: aBlock ].! ! !AbstractEyeElement methodsFor: 'menu' stamp: 'CamilloBruni 4/30/2013 10:58'! customSubMenu: aMenu "Subclasse may add more menu items here"! ! !AbstractEyeElement methodsFor: 'action' stamp: 'CamilloBruni 4/30/2013 10:16'! exploreValue ^ self value explore! ! !AbstractEyeElement methodsFor: 'actions' stamp: ''! inspectInNewWindow: anObject anObject inspect! ! !AbstractEyeElement methodsFor: 'actions' stamp: ''! browseSelectedObjectClass self selectedObjectDo: [ :anObject | Smalltalk tools browser newOnClass: anObject class ]! ! !AbstractEyeElement methodsFor: 'testing' stamp: 'CamilloBruni 10/15/2013 17:14'! hasSelectedObject ^ true! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 10/15/2013 17:14'! selectedObject ^ self value! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 4/30/2013 10:58'! hostClass ^ host class! ! !AbstractEyeElement methodsFor: 'action' stamp: 'CamilloBruni 4/30/2013 10:35'! explorePointers ^ Smalltalk tools strongPointerExplorer openOn: self value! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 4/30/2013 10:44'! value "Answers the object associated with this EyeElement." self subclassResponsibility! ! !AbstractEyeElement methodsFor: 'printing' stamp: 'CamilloBruni 4/30/2013 10:46'! printOn: aStream aStream print: self label; << '->'; << (self value printStringLimitedTo: 50)! ! !AbstractEyeElement methodsFor: 'menu' stamp: 'CamilloBruni 2/25/2014 18:16'! endSubMenu: aMenu aMenu addGroup: [ :aGroup | aGroup addItem: [ :anItem | anItem name: 'Copy Name'; action: [ self copyAccessorCode ]; shortcut: $c command mac | $c alt win | $c alt unix ] ]! ! !AbstractEyeElement methodsFor: 'actions' stamp: ''! browseSelectedObject self selectedObjectDo: [ :anObject | anObject browse ]! ! !AbstractEyeElement methodsFor: 'action' stamp: 'CamilloBruni 4/30/2013 10:20'! copyAccessorCode "Copy the name of the current variable, so the user can paste it into the window below and work with is." Clipboard clipboardText: self accessorCode asText! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 4/30/2013 10:32'! valueClass ^ self value class! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 4/30/2013 10:51'! host: anObject host := anObject! ! !AbstractEyeElement methodsFor: 'menu' stamp: 'CamilloBruni 2/25/2014 18:49'! errorSubMenu: aMenu "Add debug menu entries for the failing #errorPropertySelectors of this eye element" self hasError ifFalse: [ ^ self ]. aMenu addGroup: [ :aGroup | self withErrorsDo: [ :accessError :itemSelector | aGroup addItem: [ :anItem | anItem name: 'Debug Accessing ', itemSelector printString, ' of ', self accessorCode ; icon: Smalltalk ui icons smallWarningIcon; action: [ [ self perform: itemSelector] fork ]]]]! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 4/30/2013 10:52'! host "Answers the object currently inspected by the outer inspector. See #value for the object represented by this EyeElement." ^ host! ! !AbstractEyeElement methodsFor: 'action' stamp: 'CamilloBruni 10/15/2013 17:03'! inspectValue "Bring up a non-special inspector" ^ self value inspect! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'abc 10/18/2013 14:55'! selectedObjectDo: aBlock aBlock value: self selectedObject ! ! !AbstractEyeElement methodsFor: 'action' stamp: 'ClementBera 4/30/2013 11:37'! save: aValue "Subclasse may override this"! ! !AbstractEyeElement methodsFor: 'comparing' stamp: 'SvenVanCaekenberghe 3/30/2014 22:51'! hash ^ host hash! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 2/25/2014 18:30'! errorPropertySelectors "Return a collection of selectors on this eye-element that are checked against errors. See #withErrorsDo: and #errorSubMenu:" ^ #(icon label longLabel description)! ! !AbstractEyeElement methodsFor: 'menu' stamp: 'CamilloBruni 2/25/2014 18:15'! exploreSubMenu: aMenu aMenu addGroup: [ :aGroup | aGroup addItem: [ :anItem | anItem name: 'Explore Pointers'; action: [ self explorePointers ] ] ]! ! !AbstractEyeElement methodsFor: 'menu' stamp: 'CamilloBruni 2/25/2014 18:16'! browseSubMenu: aMenu aMenu addGroup: [ :aGroup | aGroup addItem: [ :anItem | anItem name: 'Browse Full'; action: [ self browseSelectedObject ]; shortcut: $b command mac | $b alt win | $b alt unix ]. aGroup addItem: [ :anItem | anItem name: 'Browse Class'; action: [ self browseSelectedObjectClass ] ]. aGroup addItem: [ :anItem | anItem name: 'Browse Hierarchy'; action: [ self browseSelectedObjectClassHierarchy ]; shortcut: $h command mac | $h alt win | $h alt unix ] ]! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 3/7/2014 13:21'! longLabel "This is used by EyeTreeInspector" | description | description := self description. description size > 150 ifTrue: [ description := description first: 150 ]. ^ self label ifNotNil: [ :label | label , ': ' , description ] ifNil: [ description ]! ! !AbstractEyeElement methodsFor: 'action' stamp: 'CamilloBruni 10/15/2013 17:03'! browseValueClassHierarchy "Create and schedule a class list browser on the receiver's hierarchy." ^ self valueClass browseHierarchy! ! !AbstractEyeElement methodsFor: 'menu' stamp: 'CamilloBruni 2/25/2014 18:14'! inspectionMenu: aMenu "specific menu for the current element" self exploreSubMenu: aMenu; browseSubMenu: aMenu; customSubMenu: aMenu; endSubMenu: aMenu; errorSubMenu: aMenu.! ! !AbstractEyeElement methodsFor: 'action' stamp: 'CamilloBruni 10/15/2013 17:03'! browseValueClass "Open an class browser on the selectObject (class side)" ^ self valueClass browse! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 4/30/2013 10:21'! accessorCode "Answers a code string to access the value from the inspector" self subclassResponsibility! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 4/30/2013 10:45'! label "Answers the label associated with this EyeElement" self subclassResponsibility! ! !AbstractEyeElement methodsFor: 'menu' stamp: 'CamilloBruni 2/25/2014 18:15'! mainInspectSubMenu: aMenu aMenu add: 'Inspect (i)' translated target: self selector: #inspectSelectedObjectInNewWindow. aMenu add: 'Explore (I)' translated target: self selector: #exploreSelectedObject.! ! !AbstractEyeElement methodsFor: 'comparing' stamp: 'SvenVanCaekenberghe 3/30/2014 13:08'! = anObject self == anObject ifTrue: [ ^ true ]. self class = anObject class ifFalse: [ ^ false ]. ^ host = anObject host! ! !AbstractEyeElement methodsFor: 'actions' stamp: ''! browseSelectedObjectClassHierarchy self selectedObjectDo: [ :anObject | anObject class browseHierarchy ]! ! !AbstractEyeElement methodsFor: 'testing' stamp: 'CamilloBruni 2/25/2014 18:24'! hasError self withErrorsDo: [ ^ true ]. ^ false! ! !AbstractEyeElement methodsFor: 'actions' stamp: ''! exploreSelectedObject self selectedObjectDo: [ :anObject | anObject explore ].! ! !AbstractEyeElement methodsFor: 'actions' stamp: ''! inspectSelectedObjectInNewWindow self selectedObjectDo: [ :anObject | self inspectInNewWindow: anObject ].! ! !AbstractEyeElement methodsFor: 'accessing' stamp: 'YuriyTymchuk 12/20/2013 11:32'! icon ^ (self value iconOrThumbnailOfSize: 16) ifNil: [ self value class systemIcon ]! ! !AbstractEyeElement class methodsFor: 'instance creation' stamp: 'ClementBera 4/30/2013 11:20'! host: anObject ^ self new host: anObject; yourself! ! !AbstractFieldModification commentStamp: ''! I am an abstract field modification. Field modifications encapsulate the changes required to migrated instances.! !AbstractFieldModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:07'! installOn: aModification self subclassResponsibility! ! !AbstractFieldModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 17:19'! fieldIndex: anObject fieldIndex := anObject! ! !AbstractFieldModification methodsFor: 'migrating' stamp: 'ToonVerwaest 3/28/2011 20:31'! migrateAt: index to: newInstance from: oldInstance! ! !AbstractFieldModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 17:19'! fieldIndex ^ fieldIndex! ! !AbstractFileReference commentStamp: ''! I am an abstract superclass for FileLocator and FileReference. By implementing most of the methods on myself most code duplucation between the locator and the reference can be avoided! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isRoot ^ self resolve isRoot! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:05'! hasFiles ^self resolve hasFiles! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:05'! resolve: anObject ^ anObject asResolvedBy: self! ! !AbstractFileReference methodsFor: 'streams-compatibility' stamp: 'MaxLeske 1/26/2014 20:49'! binaryReadStream ^ self subclassResponsibility! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 9/5/2012 18:07'! isContainedBy: anObject "DoubleDispatch helper for #contains:" ^ anObject containsReference: self resolve! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:35'! filesMatching: patterns " FileSystem disk workingDirectory filesMatching: '*' FileSystem disk workingDirectory filesMatching: '*.image;*.changes' " ^ self childGeneratorBlock: [:reference : aBlock| reference fileSystem fileNamesAt: reference path do: aBlock ] matching: patterns ! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:37'! children "Answer an array containing references to the direct children of this reference." | reference | reference := self resolve. ^ (reference fileSystem childNamesAt: reference path) collect: [ :aName | self / aName ]! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:35'! allEntries ^ CollectVisitor breadthFirst: self resolve! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! mimeTypes ^ self resolve mimeTypes! ! !AbstractFileReference methodsFor: 'operations' stamp: 'S 6/17/2013 13:24'! ensureCreateFile "Create if necessary a file for the receiver." self writeStream close. ! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! parent ^ self withPath: self path parent! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:46'! allDirectories "Return all the directories recursively nested in the receiver." ^ (SelectVisitor breadthFirst: self resolve select: [:entry | entry isDirectory ]) collect: [ :each| each reference ]! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 20:16'! openWritable: aBoolean ^ self resolve openWritable: aBoolean! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 20:51'! modificationTime ^ self resolve modificationTime ! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:30'! extension ^ self fullPath extension.! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! macTypeAndCreator ^ self resolve macTypeAndCreator! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:51'! relativeToReference: landmarkReference "Return the path of the receiver relative to landmarkReference." ^ self fullPath relativeTo: landmarkReference path! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 9/5/2012 11:26'! relativeTo: landmark "Answer a new path relative to landmark." "parent/child/grandChild relativeTo: parent returns child/grandChild (Filesystem disk / 'griffle' / 'plonk' / 'nurp') relativeTo: (Filesystem disk / 'griffle') returns plonk/nurp" ^ landmark makeRelative: self resolve! ! !AbstractFileReference methodsFor: '*Network-Url' stamp: 'SvenVanCaekenberghe 10/25/2013 17:12'! asUrl ^ self asZnUrl! ! !AbstractFileReference methodsFor: '*Deprecated30' stamp: 'S 6/17/2013 13:24'! ensureDeleted "Delete the file and does not raise exception if it does not exist contrary to delete" self deprecated: 'Use ensureDelete' on: '21/06/2013' in: #Pharo30. self ensureDelete.! ! !AbstractFileReference methodsFor: 'operations' stamp: 'S 6/17/2013 13:30'! moveTo: aReference "Move the receiver in the location passed as argument. (FileSystem disk workingDirectory / 'paf' ) ensureCreateFile. (FileSystem disk workingDirectory / 'fooFolder') ensureCreateDirectory. (FileSystem disk workingDirectory / 'paf' ) moveTo: (FileSystem disk workingDirectory / 'fooFolder' / 'paf') " ^ self resolve moveTo: aReference! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:43'! allChildren "Return all the files and folders recursively nested in the receiver" ^ CollectVisitor breadthFirst: self resolve collect: [:entry | entry reference]! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'PavelKrivanek 11/23/2012 12:21'! fullPath "Returns the absolute path, better use absolutePath" ^ self subclassResponsibility! ! !AbstractFileReference methodsFor: 'testing' stamp: 'PavelKrivanek 11/23/2012 12:21'! isRelative self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'operations' stamp: 'S 6/17/2013 13:17'! delete "Delete the receiver, does raise an error if it is not present." ^ self resolve delete! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:50'! relativeToPath: landmarkPath ^ self fullPath relativeTo: landmarkPath! ! !AbstractFileReference methodsFor: '*codeimport' stamp: 'CamilloBruni 7/10/2012 20:14'! fileIn self readStreamDo: [ :stream | CodeImporter evaluateFileStream: stream ]! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:47'! files "Return all the files (as opposed to folders) contained in the receiver" | reference | reference := self resolve. ^ (reference fileSystem fileNamesAt: reference path) collect: [ :aName | self withPath: self path / aName ]! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 9/5/2012 18:02'! contains: anObject "Return true if anObject is in a subfolder of me" ^ anObject isContainedBy: self resolve! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! readStreamDo: doBlock ifAbsent: absentBlock ^ self isFile ifTrue: [ self readStreamDo: doBlock ] ifFalse: absentBlock! ! !AbstractFileReference methodsFor: 'operations' stamp: 'StephaneDucasse 5/22/2013 17:24'! createDirectory "Create a new repository and raise an error if the directory already exist." self resolve createDirectory! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 20:19'! isWritable ^ self resolve isWritable! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:35'! childrenMatching: patterns " FileSystem disk workingDirectory childrenMatching: '*' FileSystem disk workingDirectory childrenMatching: '*.image;*.changes' " ^ self childGeneratorBlock: [:reference : aBlock| reference fileSystem childNamesAt: reference path do: aBlock ] matching: patterns ! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! asPathWith: anObject ^ self resolve asPathWith: anObject! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 20:17'! isChildOf: anObject ^ self parent = anObject! ! !AbstractFileReference methodsFor: 'operations' stamp: 'S 6/17/2013 13:20'! copyAllTo: aResolvable "Performs a deep copy of the receiver, to a location specified by the argument. If the receiver is a file, the file will be copied; if a directory, the directory and its contents will be copied recursively. The argument must be a reference that doesn't exist; it will be created by the copy." CopyVisitor copy: self resolve asAbsolute to: aResolvable resolve! ! !AbstractFileReference methodsFor: '*Deprecated30' stamp: 'S 6/17/2013 13:26'! ensureDirectory "Verifies that the directory does not exist and only creates if necessary. Do not remove files contained if they exist." self deprecated: 'Use ensureCreateDirectory' on: '21/06/2013' in: #Pharo30. ^ self ensureCreateDirectory! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 22:34'! streamWritable: writable do: aBlock ^ writable ifTrue: [ self writeStreamDo: aBlock ] ifFalse: [ self readStreamDo: aBlock ]! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 8/9/2012 11:38'! directoryNames ^ self directories collect: #basename! ! !AbstractFileReference methodsFor: 'streams-compatibility' stamp: 'MaxLeske 1/25/2014 22:48'! binaryReadStreamDo: doBlock ifAbsent: absentBlock ^ self isFile ifTrue: [ self binaryReadStreamDo: doBlock ] ifFalse: absentBlock! ! !AbstractFileReference methodsFor: 'utility' stamp: 'CamilloBruni 7/10/2012 15:04'! nextVersion ^ self resolve nextVersion! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:04'! entries ^ self resolve entries! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 22:05'! size ^ self resolve size! ! !AbstractFileReference methodsFor: 'printing' stamp: 'CamilloBruni 7/10/2012 20:15'! indicator "Returns a string indicating the type of reference: - '?' for a non existing reference', - '/' for a directory, - the empty string for a file." "When this framework gets more complete, it is possible to extend this behavior with the following indicators (taken from unix ls utility): - '*' for a regular file that is executable - '@' for a symbolic link - '|' for FIFOs - '=' for sockets - '>' for doors" ^ self exists ifTrue: [self isDirectory ifTrue: ['/'] ifFalse: [''] ] ifFalse: ['?']! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:05'! withExtension: aString ^ self withPath: (self path withExtension: aString)! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:27'! extensions "#('foo' 'foo.tar' 'foo.tar.gz' 'foo.1.tar' 'foo.1.tar.gz') collect: [:thing| thing extensions] => #(#() #('tar') #('tar' 'gz') #('1' 'tar') #('1' 'tar' 'gz'))" ^ self fullPath extensions! ! !AbstractFileReference methodsFor: 'copying' stamp: 'PavelKrivanek 11/23/2012 12:21'! copyWithPath: newPath self subclassResponsibility! ! !AbstractFileReference methodsFor: 'testing' stamp: 'PavelKrivanek 11/23/2012 12:21'! isAbsolute self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'resolving' stamp: 'CamilloBruni 7/10/2012 15:20'! asResolvedBy: anObject ^ anObject resolveReference: self! ! !AbstractFileReference methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 20:36'! childGeneratorBlock: doBlock matching: patterns " FileDirectory default fileNamesMatching: '*' FileDirectory default fileNamesMatching: '*.image;*.changes' " | files reference| files := Set new. reference := self resolve. (patterns findTokens: ';', String crlf) do: [ :pattern | doBlock value: reference value: [ :basename| (pattern match: basename) ifTrue: [ files add: (self / basename) ]]]. ^files asOrderedCollection! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! readStreamDo: aBlock | stream | stream := self readStream. ^ [ aBlock value: stream ] ensure: [ stream close ]! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 8/21/2013 17:51'! <= other ^ self path <= other path! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! readStreamIfAbsent: absentBlock ^ self isFile ifTrue: [ self readStream ] ifFalse: absentBlock! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isReadable ^ self resolve isReadable! ! !AbstractFileReference methodsFor: 'operations' stamp: 'S 6/17/2013 13:29'! ensureDeleteAll "Delete this directory and all children of it, and does not raise an error if the file does not exist." self exists ifFalse: [ ^ self ]. self deleteAll ! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 20:17'! ifFile: fBlock ifDirectory: dBlock ifAbsent: aBlock ^ self isFile ifTrue: fBlock ifFalse: [ self isDirectory ifTrue: dBlock ifFalse: aBlock ]! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 10/27/2013 11:43'! uri "Convert my path into a file:// type url. For odd characters use %20 notation." ^ self asUrl! ! !AbstractFileReference methodsFor: 'operations' stamp: 'StephaneDucasse 5/22/2013 17:07'! deleteIfAbsent: aBlock "Delete the receiver, when it does not exist evaluate the block" self resolve deleteIfAbsent: aBlock! ! !AbstractFileReference methodsFor: 'converting' stamp: 'PavelKrivanek 11/23/2012 12:21'! asAbsolute self subclassResponsibility! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:04'! entry ^ self resolve entry! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'PavelKrivanek 11/23/2012 12:21'! absolutePath "Returns the absolute path" ^ self subclassResponsibility! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'PavelKrivanek 11/23/2012 12:21'! resolveString: aString self subclassResponsibility! ! !AbstractFileReference methodsFor: '*zinc-resource-meta-filesystem' stamp: 'SvenVanCaekenberghe 1/14/2013 10:01'! asZnUrl "Convert the receiver in a file:// ZnUrl. Only an absolute path can be represented as a file:// URL" ^ self asAbsolute path asZnUrl! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:45'! allFiles "Return all the files (not directories) recursively nested in the receiver." ^ (SelectVisitor breadthFirst: self resolve select: [:entry | entry isFile ]) collect: [ :each| each reference ]! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:05'! hasDirectories ^self resolve hasDirectories! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! exists ^ self resolve exists! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! copyTo: aReference ^ self resolve copyTo: aReference resolve! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:30'! fullNameWithIndicator "Returns the basename with the indicator appended, i.e. /foo/gloops.taz basenameWithIndicator is '/foo/gloops.taz', whereras /foo basenameWithIndicator is '/foo/'" ^ self fullName, self indicator ! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! fullName ^ self resolve fullName! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:49'! makeRelative: anObject ^ anObject relativeToReference: self resolve! ! !AbstractFileReference methodsFor: 'operations' stamp: 'S 6/17/2013 13:26'! ensureCreateDirectory "Verifies that the directory does not exist and only creates if necessary. Do not remove files contained if they exist." ^ self resolve ensureCreateDirectory! ! !AbstractFileReference methodsFor: 'copying' stamp: 'CamilloBruni 2/21/2014 22:32'! , extension ^ self resolve, extension! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:47'! directories "Return all the directories (by opposition to files) contained in the receiver" | reference | reference := self resolve. ^ (reference fileSystem directoryNamesAt: reference path) collect: [ :aName | self withPath: self path / aName ]! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:01'! fileSystem ^ self resolve fileSystem! ! !AbstractFileReference methodsFor: '*Deprecated30' stamp: 'S 6/17/2013 13:25'! ensureFile "Create if necessary a file for the receiver." self deprecated: 'Use ensureCreateFile' on: '21/06/2013' in: #Pharo30. self ensureCreateFile.! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:24'! writeStreamDo: aBlock | stream | stream := self writeStream. ^ [ aBlock value: stream ] ensure: [ stream close ]! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:27'! base "Returns the base of the basename, i.e. /foo/gloops.taz base is 'gloops'" ^ self fullPath base! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:05'! hasChildren ^self resolve hasChildren! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:18'! resolvePath: aPath ^ self withPath: (self path resolvePath: aPath)! ! !AbstractFileReference methodsFor: 'streams' stamp: 'PavelKrivanek 11/23/2012 12:21'! writeStream self subclassResponsibility! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isFile ^ self resolve isFile! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:28'! basenameWithoutExtension "Returns the basename, i.e. /foo/gloops.taz basenameWithoutExtension is 'gloops'" ^ self fullPath basenameWithoutExtension! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:28'! basename "Returns the basename, i.e. /foo/gloops.taz basename is 'gloops.taz'" ^ self fullPath basename! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 20:36'! / aString ^ self withPath: self path / aString! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:24'! writeStreamDo: doBlock ifPresent: presentBlock ^ self isFile ifTrue: presentBlock ifFalse: [ self writeStreamDo: doBlock ]! ! !AbstractFileReference methodsFor: 'operations' stamp: 'StephaneDucasse 5/22/2013 17:16'! deleteAllChildren "delete all children of the receiver, raise an error if the receiver does not exist" self children do: [:aReference | aReference deleteAll ]! ! !AbstractFileReference methodsFor: 'operations' stamp: 'S 6/17/2013 13:17'! ensureDelete "Delete the file and does not raise exception if it does not exist contrary to delete" self deleteIfAbsent: [].! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 20:51'! creationTime ^ self resolve creationTime ! ! !AbstractFileReference methodsFor: 'streams-compatibility' stamp: 'MaxLeske 1/25/2014 22:48'! binaryReadStreamDo: aBlock | stream | stream := self binaryReadStream. ^ [ aBlock value: stream ] ensure: [ stream close ]! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isDirectory ^ self resolve isDirectory! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 22:12'! humanReadableSize ^ self size humanReadableSIByteSize! ! !AbstractFileReference methodsFor: 'streams-compatibility' stamp: 'MaxLeske 1/25/2014 22:49'! binaryReadStreamIfAbsent: absentBlock ^ self isFile ifTrue: [ self binaryReadStream ] ifFalse: absentBlock! ! !AbstractFileReference methodsFor: 'operations' stamp: 'S 6/17/2013 13:21'! deleteAll "Delete this directory and all children of it, raise an error if the file does not exist." DeleteVisitor delete: self resolve! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:35'! glob: aBlock ^ SelectVisitor breadthFirst: self resolve select: aBlock! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 7/10/2012 15:32'! containsPath: aPath ^ self fullPath containsPath: aPath! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:24'! writeStreamIfPresent: presentBlock ^ self isFile ifTrue: presentBlock ifFalse: [ self writeStream ]! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 7/10/2012 15:18'! resolveReference: aReference ^ aReference isAbsolute ifTrue: [ aReference ] ifFalse: [ self withPath: aReference path ]! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 8/9/2012 12:31'! hash "Hash is reimplemented because #= is reimplemented" ^ self path hash! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:07'! basenameWithIndicator "Returns the basename with the indicator appended, i.e. /foo/gloops.taz basenameWithIndicator is 'gloops.taz', whereras /foo basenameWithIndicator is 'foo/'" ^ self basename, self indicator ! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 20:35'! directoriesMatching: patterns " FileSystem disk workingDirectory directoriesMatching: '*' FileSystem disk workingDirectory directoriesMatching: 'package-cache' " ^ self childGeneratorBlock: [:reference : aBlock| reference fileSystem directoryNamesAt: reference path do: aBlock ] matching: patterns ! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:30'! fileNames ^ self files collect: #basename! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! pathString ^ self resolve pathString! ! !AbstractFileReference methodsFor: 'streams' stamp: 'PavelKrivanek 11/23/2012 12:21'! readStream self subclassResponsibility! ! !AbstractFileReference methodsFor: 'converting' stamp: 'PavelKrivanek 11/23/2012 12:21'! asFileReference self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 8/9/2012 11:38'! childNames ^ self children collect: #basename! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 21:29'! permissions "Return the FileSystemPermission for this node" ^ self resolve permissions! ! !AbstractFileReference methodsFor: '*Polymorph-Widgets' stamp: 'CamilloBruni 1/23/2013 12:41'! item ^ self! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:31'! pathSegments ^ self fullPath segments! ! !AbstractFileReference methodsFor: 'operations' stamp: 'PavelKrivanek 11/23/2012 12:21'! renameTo: newBasename self subclassResponsibility! ! !AbstractFileReference methodsFor: 'operations' stamp: 'S 6/17/2013 13:30'! ensureDeleteAllChildren "delete all children of the receiver and does not raise an error if the receiver does not exist" self exists ifFalse: [ ^ self ]. self deleteAllChildren! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'PavelKrivanek 11/23/2012 12:21'! resolve ^ self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:18'! withPath: newPath ^ self path == newPath ifTrue: [ self ] ifFalse: [ self copyWithPath: newPath ]! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 6/13/2013 16:02'! contents self readStreamDo: [ :stream | ^ stream contents ]! ! !AbstractFont commentStamp: ''! AbstractFont defines the generic interface that all fonts need to implement.! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 8/10/2006 07:13'! emphasisStringFor: emphasisCode "Answer a translated string that represents the attributes given in emphasisCode." ^self class emphasisStringFor: emphasisCode! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! ascent self subclassResponsibility. ! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 7/29/2006 13:51'! displayUnderlineOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint "display the underline if appropriate for the receiver"! ! !AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta "Draw the given string from startIndex to stopIndex at aPoint on the (already prepared) display context." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/22/2004 15:15'! textStyleName "Answer the name to be used as a key in the TextConstants dictionary." ^self familyName! ! !AbstractFont methodsFor: 'measuring' stamp: 'StephaneDucasse 5/28/2011 13:17'! widthOfString: aString aString ifNil: [^0]. ^self widthOfString: aString from: 1 to: aString size. " TextStyle default defaultFont widthOfString: 'zort' 21 "! ! !AbstractFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:47'! releaseCachedState ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 5/26/2003 09:45'! isRegular ^false! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'! height "Answer the height of the receiver, total of maximum extents of characters above and below the baseline." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'! installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor "Install the receiver on the given DisplayContext (either BitBlt or Canvas) for further drawing operations." ^self subclassResponsibility! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/10/2007 13:08'! kerningLeft: leftChar right: rightChar ^0! ! !AbstractFont methodsFor: 'measuring' stamp: 'StephaneDucasse 5/28/2011 13:17'! approxWidthOfText: aText "Return the width of aText -- quickly, and a little bit dirty. Used by lists morphs containing Text objects to get a quick, fairly accurate measure of the width of a list item." | w | (aText isNil or: [ aText size = 0 ]) ifTrue: [ ^ 0 ]. w := self widthOfString: aText asString. "If the text has no emphasis, just return the string size. If it is empasized, just approximate the width by adding about 20% to the width" ((aText runLengthFor: 1) = aText size and: [ (aText emphasisAt: 1) = 0 ]) ifTrue: [ ^ w ] ifFalse: [ ^ w * 6 // 5 ]! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! descentOf: aCharacter ^ self descent. ! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 8/10/2006 07:16'! emphasisString "Answer a translated string that represents the receiver's emphasis." ^self emphasisStringFor: self emphasis! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'! lineGrid "Answer the relative space between lines" ^self subclassResponsibility! ! !AbstractFont methodsFor: 'notifications' stamp: 'nk 4/2/2004 11:25'! pixelsPerInchChanged "The definition of TextStyle class>>pixelsPerInch has changed. Do whatever is necessary."! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/15/2004 18:57'! derivativeFonts ^#()! ! !AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:57'! xTable "Return the xTable for the font. The xTable defines the left x-value for each individual glyph in the receiver. If such a table is not provided, the character scanner will ask the font directly for the appropriate width of each individual character." ^nil! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:33'! pixelSize "Make sure that we don't return a Fraction" ^ TextStyle pointsToPixels: self pointSize! ! !AbstractFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:36'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY "Draw the given string from startIndex to stopIndex at aPoint on the (already prepared) display context." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 7/11/2004 21:15'! textStyle ^ TextStyle actualTextStyles detect: [:aStyle | aStyle fontArray includes: self] ifNone: [ TextStyle fontArray: { self } ]! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:43'! hasDistinctGlyphsForAll: asciiString "Answer true if the receiver has glyphs for all the characters in asciiString and no single glyph is shared by more than one character, false otherwise. The default behaviour is to answer true, but subclasses may reimplement" ^true! ! !AbstractFont methodsFor: 'measuring' stamp: 'StephaneDucasse 5/28/2011 13:17'! widthOfStringOrText: aStringOrText aStringOrText ifNil: [^0]. ^aStringOrText isText ifTrue:[self approxWidthOfText: aStringOrText ] ifFalse:[self widthOfString: aStringOrText ] ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! ascentOf: aCharacter ^ self ascent. ! ! !AbstractFont methodsFor: '*Text-Scanning' stamp: 'tpr 10/3/2013 12:42'! scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX "scan a multibyte character string" ^aCharacterScanner scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString rightX: rightX ! ! !AbstractFont methodsFor: 'testing' stamp: 'yo 2/12/2007 19:34'! isFontSet ^ false. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:15'! familyName "Answer the name to be used as a key in the TextConstants dictionary." ^self subclassResponsibility! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 7/29/2006 14:36'! displayStrikeoutOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint "display the strikeout if appropriate for the receiver"! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/31/2007 20:17'! linearWidthOf: aCharacter "This is the scaled, unrounded advance width." ^self widthOf: aCharacter! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:32'! isSymbolFont "Answer true if the receiver is a Symbol font, false otherwise. The default is to answer false, subclasses can reimplement" ^false! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:06'! baseKern ^0! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'ClementBera 7/26/2013 15:55'! widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray "Set the first element of aTwoElementArray to the width of leftCharacter and the second element to the width of left character when kerned with rightCharacterOrNil. Answer aTwoElementArray" | w k | w := self widthOf: leftCharacter. rightCharacterOrNil ifNil: [ aTwoElementArray at: 1 put: w; at: 2 put: w] ifNotNil: [ k := self kerningLeft: leftCharacter right: rightCharacterOrNil. aTwoElementArray at: 1 put: w; at: 2 put: w+k]. ^ aTwoElementArray ! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 3/29/2007 13:25'! hasGlyphsForAll: asciiString "Answer true if the receiver has glyphs for all the characters in asciiString, false otherwise. The default behaviour is to answer true, but subclasses may reimplement" ^true! ! !AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:56'! characterToGlyphMap "Return the character to glyph mapping table. If the table is not provided the character scanner will query the font directly for the width of each individual character." ^nil! ! !AbstractFont methodsFor: '*Multilingual-OtherLanguages' stamp: 'tpr 10/3/2013 12:57'! scanMultibyteJapaneseCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX "scan a multibyte Japanese character string" ^aCharacterScanner scanJapaneseCharactersFrom: startIndex to: stopIndex in: aWideString rightX: rightX ! ! !AbstractFont methodsFor: 'measuring' stamp: 'ar 5/19/2000 14:58'! widthOf: aCharacter "Return the width of the given character" ^self subclassResponsibility! ! !AbstractFont methodsFor: 'measuring' stamp: 'StephaneDucasse 12/29/2009 22:42'! widthOfString: aString from: firstIndex to: lastIndex "Measure the length of the given string between start and stop index" | resultX | resultX := 0. firstIndex to: lastIndex do: [ :i | resultX := resultX + (self widthOf: (aString at: i)) ]. ^ resultX! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! descent self subclassResponsibility. ! ! !AbstractFont methodsFor: '*FreeType-addition' stamp: 'tween 4/6/2007 12:58'! isSubPixelPositioned "Answer true if the receiver is currently using subpixel positioned glyphs, false otherwise. This affects how padded space sizes are calculated when composing text. Currently, only FreeTypeFonts are subPixelPositioned, and only when not Hinted" ^false ! ! !AbstractFont methodsFor: '*Text-Scanning' stamp: 'tpr 10/3/2013 12:42'! scanByteCharactersFrom: startIndex to: stopIndex in: aByteString with: aCharacterScanner rightX: rightX "scan a single byte character string" ^aCharacterScanner scanByteCharactersFrom: startIndex to: stopIndex in: aByteString rightX: rightX! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! basicDescentOf: aCharacter ^ self descent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/1/2004 10:48'! pointSize self subclassResponsibility.! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! basicAscentOf: aCharacter ^ self ascent. ! ! !AbstractFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:54'! isTTCFont ^false! ! !AbstractFont class methodsFor: 'as yet unclassified' stamp: 'eem 6/11/2008 12:35'! emphasisStringFor: emphasisCode "Answer a translated string that represents the attributes given in emphasisCode." | emphases | emphasisCode = 0 ifTrue: [ ^'Normal' translated ]. emphases := (IdentityDictionary new) at: 1 put: 'Bold' translated; at: 2 put: 'Italic' translated; at: 4 put: 'Underlined' translated; at: 8 put: 'Narrow' translated; at: 16 put: 'StruckOut' translated; yourself. ^String streamContents: [ :s | | bit | bit := 1. [ bit < 32 ] whileTrue: [ | code | code := emphasisCode bitAnd: bit. code isZero ifFalse: [ s nextPutAll: (emphases at: code); space ]. bit := bit bitShift: 1 ]. s position isZero ifFalse: [ s skip: -1 ]. ]! ! !AbstractFont class methodsFor: 'class initialization' stamp: 'PavelKrivanek 6/1/2011 12:47'! initialize TextStyle addDependent: self.! ! !AbstractFont class methodsFor: 'updating' stamp: 'StephaneDucasse 6/2/2011 20:24'! update: anAspect anAspect == #textDPIChanged ifTrue: [ AbstractFont allSubInstancesDo: [ :font | font pixelsPerInchChanged ]].! ! !AbstractFont class methodsFor: '*system-settings-browser' stamp: 'alain.plantec 3/18/2009 14:49'! settingInputWidgetForNode: aSettingNode ^ aSettingNode inputWidgetForFont! ! !AbstractFontSelectorDialogWindow commentStamp: 'gvc 5/18/2007 13:04'! Dialog based font chooser with preview.! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isBold: anObject "Set the value of isBold" isBold := anObject. self changed: #isBold! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isUnderlined: anObject "Set the value of isUnderlined" isUnderlined := anObject. self changed: #isUnderlined! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:21'! updateFromSelectedFont "Update our state based on the selected font." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:35'! matchingFont "Answer the font that matches the selections." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:48'! newContentMorph "Answer a new content morph." self textPreviewMorph: self newTextPreviewMorph. ^(self newColumn: { (self newRow: { self newGroupbox: 'Family' translated for: self newFontFamilyMorph. (self newColumn: { (self newGroupbox: 'Style' translated for: self newFontStyleButtonRowMorph) vResizing: #shrinkWrap. self newGroupbox: 'Point size' translated for: self newFontSizeMorph}) hResizing: #shrinkWrap}) vResizing: #spaceFill. (self newGroupbox: 'Preview' translated for: self textPreviewMorph) vResizing: #shrinkWrap}) minWidth: 350; minHeight: 400! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:19'! fontSizeIndex: anObject "Set the value of fontSizeIndex" fontSizeIndex := anObject. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:33'! textEmphasisCode "Answer the current bitmask for the text emphasis." ^(((self isBold ifTrue: [1] ifFalse: [0]) bitOr: (self isItalic ifTrue: [2] ifFalse: [0])) bitOr: (self isUnderlined ifTrue: [4] ifFalse: [0])) bitOr: (self isStruckOut ifTrue: [16] ifFalse: [0])! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:49'! newFontSizeMorph "Answer a list for the font size of the font." ^self newListFor: self list: #fontSizes selected: #fontSizeIndex changeSelected: #fontSizeIndex: help: nil! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! textPreviewMorph "Answer the value of textPreviewMorph" ^ textPreviewMorph! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 16:31'! newTextPreviewMorph "Answer a text entry morph for the preview of the font." ^(self newTextEditorFor: self getText: #previewText setText: nil getEnabled: nil) vResizing: #rigid; enabled: false; extent: 20@90! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 14:30'! fontSizeIndex "Answer the value of fontSizeIndex" ^ fontSizeIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'initialization' stamp: 'gvc 4/21/2009 17:22'! initialize "Initialize the receiver." self isBold: false; isItalic: false; isUnderlined: false; isStruckOut: false; previewText: self defaultPreviewText; fontFamilyIndex: 0; fontSizeIndex: 0. super initialize! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:19'! fontFamilyIndex: anObject "Set the value of fontFamilyIndex" fontFamilyIndex := anObject. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isStruckOut "Answer the value of isStruckOut" ^ isStruckOut! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleStruckOut "Toggle the font struck out emphasis." self isStruckOut: self isStruckOut not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:49'! defaultFontFamilies "Answer the set of available fonts families that are supported in the font that they represent." self subclassResponsibility! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:30'! previewText "Answer the value of previewText" ^previewText asText addAttribute: (TextEmphasis new emphasisCode: self textEmphasisCode)! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isItalic "Answer the value of isItalic" ^ isItalic! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! newStruckOutButtonMorph "Answer a button for the struck out emphasis of the font." ^self newButtonFor: self getState: #isStruckOut action: #toggleStruckOut arguments: nil getEnabled: nil labelForm: Smalltalk ui icons smallStrikeOutIcon help: 'Toggle struck-out font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleItalic "Toggle the font italic emphasis." self isItalic: self isItalic not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:40'! fontFamilies "Answer the set of available fonts families that are supported as Text objects in the font that they represent." ^fontFamilies ifNil: [ self fontFamilies: self defaultFontFamilies. fontFamilies]! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 16:03'! fontSize "Answer the selected font size or nil if none." (self fontSizeIndex between: 1 and: self fontSizes size) ifFalse: [^nil]. ^self fontSizes at: self fontSizeIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! newItalicButtonMorph "Answer a button for the italic emphasis of the font." ^self newButtonFor: self getState: #isItalic action: #toggleItalic arguments: nil getEnabled: nil labelForm: Smalltalk ui icons smallItalicIcon help: 'Toggle italic font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! selectedFont "Answer the value of selectedFont" ^ selectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! newBoldButtonMorph "Answer a button for the boldness of the font." ^self newButtonFor: self getState: #isBold action: #toggleBold arguments: nil getEnabled: nil labelForm: Smalltalk ui icons smallBoldIcon help: 'Toggle bold font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/9/2007 14:19'! selectedFont: anObject "Set the value of selectedFont" selectedFont := anObject ifNil: [TextStyle defaultFont]. self updateFromSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 14:30'! fontFamilyIndex "Answer the value of fontFamilyIndex" ^ fontFamilyIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isStruckOut: anObject "Set the value of isStruckOut" isStruckOut := anObject. self changed: #isStruckOut! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 11:49'! newFontFamilyMorph "Answer a list for the font family of the font." |highestFont| highestFont := self fontFamilies first fontAt: 1 withStyle: TextStyle default. self fontFamilies do: [:ff | |f| f := ff fontAt: 1 withStyle: TextStyle default. f height > highestFont height ifTrue: [highestFont := f]]. ^(self newListFor: self list: #fontFamilies selected: #fontFamilyIndex changeSelected: #fontFamilyIndex: help: nil) font: highestFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleBold "Toggle the font bold emphasis." self isBold: self isBold not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:47'! familyName "Answer the selected family name or nil if none." (self fontFamilyIndex between: 1 and: self fontFamilies size) ifFalse: [^nil]. ^(self fontFamilies at: self fontFamilyIndex) asString! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isItalic: anObject "Set the value of isItalic" isItalic := anObject. self changed: #isItalic! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2008 15:31'! defaultPreviewText "Answer the default text to use for the preview of the font." ^(33 to: 127) asByteArray asString! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! newUnderlinedButtonMorph "Answer a button for the italic emphasis of the font." ^self newButtonFor: self getState: #isUnderlined action: #toggleUnderlined arguments: nil getEnabled: nil labelForm: Smalltalk ui icons smallUnderlineIcon help: 'Toggle underlined font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 14:31'! fontSizes "Answer the set of available fonts sizes that are supported." ^#(6 7 8 9 10 11 12 13 14 15 16 18 20 21 22 24 26 28 32 36 48)! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:02'! fontFamilies: anObject "Set the value of fontFamilies" fontFamilies := anObject! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! textPreviewMorph: anObject "Set the value of textPreviewMorph" textPreviewMorph := anObject! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:48'! newFontStyleButtonRowMorph "Answer a new font style button row morph." ^self newRow: { self newBoldButtonMorph. self newItalicButtonMorph. self newUnderlinedButtonMorph. self newStruckOutButtonMorph}! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isBold "Answer the value of isBold" ^ isBold! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isUnderlined "Answer the value of isUnderlined" ^ isUnderlined! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2007 15:31'! toggleUnderlined "Toggle the font underlined emphasis." self isUnderlined: self isUnderlined not. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/4/2007 10:25'! updateSelectedFont "Update the selected font to reflect the choices." self selectedFont: self matchingFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/18/2007 13:07'! previewText: anObject "Set the value of previewText" previewText := anObject. self changed: #previewText! ! !AbstractFontSelectorDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallFontsIcon! ! !AbstractGroup commentStamp: ''! AbstractGroup is an abstraction of what a group is.! !AbstractGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/18/2011 14:00'! beReadOnly readOnly := true! ! !AbstractGroup methodsFor: 'polymorphism' stamp: 'BenjaminVanRyseghem 3/28/2011 13:50'! blocks ^ { [ self elements ] }! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:32'! protocolsFor: aClass ^ aClass protocols select: [:e | self methods anySatisfy: [:m | m category = e ]].! ! !AbstractGroup methodsFor: 'announcements registration' stamp: 'EstebanLorenzano 8/3/2012 13:57'! registerToMethodAnnouncements SystemAnnouncer uniqueInstance weak on: MethodModified send: #methodModified: to: self; on: MethodRemoved send: #methodRemoved: to: self.! ! !AbstractGroup methodsFor: '*Nautilus' stamp: 'EstebanLorenzano 10/10/2013 16:10'! asNautilusSelection ^ PackageTreeGroupSelection group: self! ! !AbstractGroup methodsFor: 'announcements registration' stamp: 'EstebanLorenzano 8/3/2012 13:57'! registerToClassAnnouncements SystemAnnouncer uniqueInstance weak on: ClassRemoved send: #classRemoved: to: self! ! !AbstractGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/2/2012 17:07'! isFillable: aBoolean isFillable := aBoolean! ! !AbstractGroup methodsFor: 'queries' stamp: 'EstebanLorenzano 10/9/2013 17:23'! packages ^ (self classes collect: #package as: Set) asArray! ! !AbstractGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 12:22'! methodRemoved: anAnnouncement self subclassResponsibility! ! !AbstractGroup methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 4/14/2012 12:17'! initialize super initialize. readOnly := false. self registerToAnnouncements.! ! !AbstractGroup methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 3/29/2011 11:20'! printOn: aStream | className article | className := self class name. article := className first isVowel ifTrue: ['an'] ifFalse: ['a']. aStream nextPutAll: article; nextPut: Character space; nextPutAll: className; nextPutAll: ' ( '; nextPutAll: self name asString; nextPutAll: ' )'.! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 16:57'! methodsFor: aClass categorised: aSymbol aSymbol ifNil: [ "all" ^ self methodsFor: aClass ]. ^ self methods select: [:e | e methodClass = aClass and: [ e category = aSymbol ]].! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/18/2011 16:57'! ifAllowed: aBlock ^ self ifAllowed: aBlock ifNot: []! ! !AbstractGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/2/2012 17:14'! isFillable ^ isFillable ifNil: [ isFillable := false ]! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/24/2011 13:16'! sortBlock: aBlock sortBlock := aBlock! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:26'! methods ^ self elements! ! !AbstractGroup methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 3/24/2011 13:41'! removable ^ removable ifNil: [ removable := true ]! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:28'! classes ^ self subclassResponsibility! ! !AbstractGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 12:22'! methodModified: anAnnouncement self subclassResponsibility! ! !AbstractGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/24/2011 13:39'! removable: aBoolean removable := aBoolean! ! !AbstractGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/18/2011 14:22'! elements ^ self subclassResponsibility! ! !AbstractGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/18/2011 14:04'! name: aString self ifAllowed: [ name := aString ]! ! !AbstractGroup methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 4/14/2011 21:55'! isReadOnly ^ readOnly == true! ! !AbstractGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 12:22'! classRemoved: anAnnouncement self subclassResponsibility! ! !AbstractGroup methodsFor: 'announcements registration' stamp: 'BenjaminVanRyseghem 4/14/2012 12:38'! registerToAnnouncements self registerToClassAnnouncements; registerToMethodAnnouncements! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:38'! methodsFor: aClass ^ self methods select: [:e | e methodClass = aClass ].! ! !AbstractGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/18/2011 14:03'! name ^ name! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/18/2011 16:57'! ifAllowed: aBlock ifNot: anotherBlock ^ self isReadOnly ifTrue: anotherBlock ifFalse: aBlock! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/24/2011 13:20'! sortBlock ^ sortBlock ifNil: [ sortBlock := [:a :b | a printString <= b printString ]]! ! !AbstractGroup class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 3/18/2011 14:06'! named: aString ^ self new name: aString! ! !AbstractGroup class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 8/5/2012 15:56'! new | instance | instance := self basicNew initialize. GroupAnnouncer uniqueInstance announce: (AGroupHasBeenCreated group: instance). ^ instance! ! !AbstractGroup class methodsFor: 'instance creation' stamp: 'StephaneDucasse 11/30/2013 17:24'! unsubscribeExistingGroups "self unsubscribeExistingGroups" self allSubInstances do: [ :each | SystemAnnouncer uniqueInstance unsubscribe: each ]. ! ! !AbstractGroup class methodsFor: 'instance creation' stamp: 'StephaneDucasse 11/30/2013 17:23'! cleanUp self unsubscribeExistingGroups.! ! !AbstractGroupAnnouncement commentStamp: 'TorstenBergmann 2/4/2014 21:09'! Common superclass for group announcements! !AbstractGroupAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 16:31'! holder ^ holder! ! !AbstractGroupAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 16:31'! group ^ group! ! !AbstractGroupAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 16:31'! group: anObject group := anObject! ! !AbstractGroupAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 16:31'! holder: anObject holder := anObject! ! !AbstractGroupAnnouncement class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 22:40'! group: aGroup ^ self new group: aGroup; yourself! ! !AbstractGroupAnnouncement class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 16:32'! group: aGroup from: anHolder ^ self new group: aGroup; holder: anHolder; yourself! ! !AbstractKeyPressedPlugin commentStamp: ''! AbstractKeyPressedPlugin is an abstraction of plugin which react to key strokes ! !AbstractKeyPressedPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/4/2011 15:05'! keyPressed: anAnnouncement self subclassResponsibility! ! !AbstractKeyPressedPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 5/4/2011 15:12'! registerTo: aModel aModel announcer on: NautilusKeyPressed send: #keyPressed: to: self! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:51'! eventKey: character ^ self eventKey: character alt: false ctrl: false command: false shift: false! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 2/19/2011 18:44'! tearDown KMRepository default: default! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:52'! eventKey: character shift: aBoolean ^ self eventKey: character alt: false ctrl: false command: false shift: aBoolean! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:52'! eventKey: character command: aBoolean ^ self eventKey: character alt: false ctrl: false command: aBoolean shift: false! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:51'! eventKey: character ctrl: aBoolean ^ self eventKey: character alt: false ctrl: aBoolean command: false shift: false! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:51'! eventKey: character alt: aBoolean ^ self eventKey: character alt: aBoolean ctrl: false command: false shift: false! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 2/19/2011 18:44'! setUp default := KMRepository default. KMRepository default: KMRepository new! ! !AbstractKeymappingTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:51'! eventKey: character alt: useAlt ctrl: useCtrl command: useCommand shift: useShift | event modifier code | event := KeyboardEvent new. modifier := 0. useShift ifTrue: [ modifier := modifier + 8]. useCtrl ifTrue: [ modifier := modifier + 16]. useAlt ifTrue: [ modifier := modifier + 32]. useCommand ifTrue: [ modifier := modifier + 64]. code := character asInteger. event setType: #keystroke buttons: modifier position: 0@0 keyValue: code charCode: code hand: nil stamp: Time now. ^ event ! ! !AbstractLayout commentStamp: ''! I'm a container for slots. There are special cases of layouts without slots, like NilLayout or BitsLayout.! !AbstractLayout methodsFor: 'comparing' stamp: 'MartinDias 4/12/2013 13:20'! hash ^ self class hash! ! !AbstractLayout methodsFor: 'finalization' stamp: 'ToonVerwaest 4/7/2011 12:08'! finalize self allSlotsDo: [ :aSlot | aSlot finalize: self ]! ! !AbstractLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/7/2011 12:10'! resolveSlot: aName self flag: 'Signal rather than error'. self error: 'No slots found'! ! !AbstractLayout methodsFor: 'enumerating' stamp: 'MartinDias 8/7/2012 00:42'! allSlotsDo: aBlock self slotScope allSlotsDo: aBlock! ! !AbstractLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 03:38'! instanceVariables ^ {}! ! !AbstractLayout methodsFor: 'testing' stamp: 'ToonVerwaest 4/1/2011 03:37'! hasFields ^ false! ! !AbstractLayout methodsFor: 'accessing' stamp: 'MartinDias 8/6/2012 22:31'! slotScope ^ LayoutEmptyScope instance! ! !AbstractLayout methodsFor: 'printing' stamp: 'ToonVerwaest 4/1/2011 03:39'! printSlotDefinitionOn: aStream aStream << '{}'! ! !AbstractLayout methodsFor: 'testing' stamp: 'ToonVerwaest 4/1/2011 03:37'! isBits ^ false! ! !AbstractLayout methodsFor: 'testing' stamp: 'ToonVerwaest 4/1/2011 03:37'! hasSlots ^ false! ! !AbstractLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/3/2011 22:58'! allSlots ^ {}! ! !AbstractLayout methodsFor: 'comparing' stamp: 'MartinDias 4/12/2013 13:15'! = other ^ self class = other class! ! !AbstractLayout methodsFor: 'validation' stamp: 'ToonVerwaest 4/1/2011 03:38'! checkSanity host ifNil: [ self error: 'Host should not be nil' ].! ! !AbstractLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 03:37'! fieldSize ^ 0! ! !AbstractLayout methodsFor: 'validation' stamp: 'MartinDias 7/8/2013 17:22'! checkIntegrity self checkSanity! ! !AbstractLayout methodsFor: 'testing' stamp: 'ToonVerwaest 4/1/2011 03:37'! isVariable ^ false! ! !AbstractLayout methodsFor: 'accessing' stamp: 'MartinDias 8/7/2013 17:56'! host: aClass host := aClass! ! !AbstractLayout methodsFor: 'testing' stamp: 'ToonVerwaest 4/1/2011 03:37'! isWeak ^ false! ! !AbstractLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/2/2011 19:07'! allVisibleSlots ^ {}! ! !AbstractLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 01:52'! host ^ host! ! !AbstractMethodConverter commentStamp: ''! An AbstractMessageConverter is a wrapper used to switch which information to retrieve from a method. This way, you can avoid switch case, you just have to use set the correct filter! !AbstractMethodConverter methodsFor: 'accessing' stamp: ''! method: aMessage method := aMessage! ! !AbstractMethodConverter methodsFor: 'initialization' stamp: ''! canCompile ^ false! ! !AbstractMethodConverter methodsFor: 'protocol' stamp: ''! getText method ifNil: [ ^ '' ]. ^ self internalGetText! ! !AbstractMethodConverter methodsFor: 'accessing' stamp: ''! method ^ method! ! !AbstractMethodConverter methodsFor: 'protocol' stamp: ''! getTextFor: aMethod method := aMethod. method ifNil: [ ^ '' ]. ^ self internalGetText! ! !AbstractMethodConverter methodsFor: 'initialization' stamp: ''! shouldShout ^ false! ! !AbstractMethodConverter methodsFor: 'initialization' stamp: ''! handleStringSearch ^ true! ! !AbstractMethodConverter methodsFor: 'private' stamp: ''! internalGetText ^ self subclassResponsibility! ! !AbstractMethodConverter class methodsFor: 'instance creation' stamp: ''! method: aMessage ^ self new method: aMessage; yourself! ! !AbstractMethodIconAction commentStamp: ''! AbstractMethodIconAction is the common super class for all the method icon actions. A method icon action is used to retrieve the correct icon the method in nautilus lists! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:50'! actionIcon "Return the icon for this action" ^ icon := self privateActionIcon! ! !AbstractMethodIconAction methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:16'! method: aMethod method := aMethod! ! !AbstractMethodIconAction methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:33'! browser: aBrowser browser := aBrowser! ! !AbstractMethodIconAction methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:33'! browser ^ browser! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:53'! actionStateToCache "Return the state of the icon for caching purpose" ^ IconicButtonStateHolder forNautilus: icon! ! !AbstractMethodIconAction methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:34'! method ^ method! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:50'! privateActionIcon ^ self subclassResponsibility! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:24'! actionOrder "Return the priority of this action" ^ self subclassResponsibility! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:41'! isActionHandled "Return true if the provided method fits this action requirement" ^ self subclassResponsibility! ! !AbstractMethodIconAction class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 1/2/2013 12:34'! for: aMethod in: aBrowser ^ self new method: aMethod; browser: aBrowser; yourself! ! !AbstractMethodReferenceConverter commentStamp: 'TorstenBergmann 2/20/2014 13:48'! Abstract wrapper for method references! !AbstractMethodReferenceConverter methodsFor: 'private' stamp: ''! priorVersionOfAMethod: aMethodReference | tempList | tempList := referencesList select:[:each | (each className = aMethodReference className) & (each name = aMethodReference name)]. ^ tempList detect: [:each | (self versionOfAMethod: each) = ((self versionOfAMethod: aMethodReference) -1)] ifNone: [aMethodReference].! ! !AbstractMethodReferenceConverter methodsFor: 'accessing' stamp: ''! referencesList: aListOfReferences referencesList := aListOfReferences! ! !AbstractMethodReferenceConverter methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 22:52'! initialize super initialize. referencesList := #()! ! !AbstractMethodReferenceConverter methodsFor: 'private' stamp: ''! versionOfAMethod: aMethodReference | tempList | tempList := referencesList select: [:each | (each className = aMethodReference className) & (each name = aMethodReference name)]. tempList := tempList sort: [:m1 :m2 | m1 timeStamp < m2 timeStamp]. ^ tempList identityIndexOf: aMethodReference ifAbsent: [0]! ! !AbstractMethodReferenceConverter class methodsFor: 'as yet unclassified' stamp: ''! methodReference: aMessage referencesList: aListOfReferences ^ (super method: aMessage) referencesList: aListOfReferences; yourself! ! !AbstractMethodUpdateStrategy commentStamp: ''! I am used to update compiled methods in response to class modifications. My sublcasses implement different strategies to update affected methods.! !AbstractMethodUpdateStrategy methodsFor: 'updating' stamp: 'MartinDias 7/30/2012 00:08'! transform: oldClass to: newClass using: aMethodModification self subclassResponsibility ! ! !AbstractMethodWidget commentStamp: ''! AbstractMethodWidget is an abstraction describing a widget used to manage methods! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! vScrollValue ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! selectedMethod ^ self model selectedMethod! ! !AbstractMethodWidget methodsFor: 'icon' stamp: 'EstebanLorenzano 5/14/2013 09:44'! buildUpAndDownArrowIcon: aMethod | container up down | container := Morph new. container extent: 12@12; color: Color transparent. up := IconicButton new target: self model; actionSelector: #arrowUp:; arguments: { aMethod }; labelGraphic: (Smalltalk ui icons iconNamed: #arrowDoubleUpIcon); color: Color transparent; extent: 12 @ 6; helpText: 'Browse overriden message'; borderWidth: 0. down := IconicButton new target: self model; actionSelector: #arrowDown:; arguments: { aMethod }; labelGraphic: (Smalltalk ui icons iconNamed: #arrowDoubleDownIcon); color: Color transparent; extent: 12 @ 6; helpText: 'Browse overriding messages'; borderWidth: 0. ^ (container changeTableLayout; listDirection: #topToBottom; addMorph: down; addMorph: up; yourself) -> {up. down}.! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/14/2012 11:57'! selectMethod: aMethod self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'icon' stamp: ''! rebuildUpAndDownArrowIconFrom: array | container up down | container := Morph new. container extent: 12@12; color: Color transparent. up := array first asIconTargetting: self model. down := array second asIconTargetting: self model. ^ container changeTableLayout; listDirection: #topToBottom; addMorph: down; addMorph: up; yourself! ! !AbstractMethodWidget methodsFor: 'items creation' stamp: ''! buildMethodsList ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 19:41'! selectedMethod: aMethod "I check if it's ok here to work better with the drag/drop mechanism" self model selectedMethod: aMethod! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! selectedMethods ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'initialization' stamp: ''! initialize super initialize. MethodsIconsCache ifNil: [ MethodsIconsCache := WeakIdentityKeyDictionary new ]! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! getMethods ^ self model getMethods! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! label: aString ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! takeKeyboardFocus ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! elementsMenu: aMenuMorph shifted: aBoolean ^ self model elementsMenu: aMenuMorph shifted: aBoolean ! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/14/2012 11:56'! deselectMethod: aMethod self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/4/2012 16:05'! setIcon: icon for: method MethodsIconsCache at: method put: icon! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! keyPressedOnElement: anEvent ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! removeAllFromMethodsIconsCache: aMethod ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:33'! dragPassengersFor: item inMorph: dragSource | transferType object | (dragSource isKindOf: PluggableListMorph) ifFalse: [^ nil ]. transferType := self dragTransferTypeForMorph: dragSource. transferType == #getMethodItem: ifFalse: [ ^ nil ]. object := item originalObject. ^ self selectedMethods ifEmpty: [ (self getMethods includes: object) ifTrue: [ { object } ] ifFalse: [ "to test" self halt. ] ]! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! methodsSelection ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'icon' stamp: ''! methodsIconsCache ^ MethodsIconsCache! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! showInstance ^ self model showInstance! ! !AbstractMethodWidget methodsFor: 'icon' stamp: 'CamilloBruni 5/9/2013 21:32'! methodIconFor: aMethod | actions button action | button := nil. MethodsIconsCache at: aMethod ifPresent: [:icon | icon isArray ifTrue: [ ^ self rebuildUpAndDownArrowIconFrom: icon]. icon class == IconicButtonStateHolder ifFalse: [ ^ icon ]. ^ icon asIcon ]. actions := AbstractMethodIconAction allSubclasses collect: [:class | class for: aMethod in: self model ]. actions sort: [:a :b | a actionOrder < b actionOrder ]. action := actions detect: [:each | each isActionHandled ] ifNone: [ self flag: 'should never happend' ]. "actionIcon need to be invoked before actionStateToCache" button := action actionIcon. MethodsIconsCache at: aMethod put: action actionStateToCache. ^ button! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: ''! vScrollValue: aNumber ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/17/2012 17:13'! okToChange ^ self model okToChange. ! ! !AbstractMethodWidget methodsFor: 'icon' stamp: ''! rebuildIconicButtonFrom: icon ^ IconicButton new target: self model; actionSelector: icon actionSelector; arguments: icon arguments; labelGraphic: icon labelGraphic; color: icon color; helpText: icon helpText; extent: icon extent; borderWidth: icon borderWidth! ! !AbstractMethodWidget class methodsFor: 'icon' stamp: 'CamilloBruni 5/7/2013 23:34'! resetMethodIconCache MethodsIconsCache removeAll! ! !AbstractMethodWidget class methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 6/18/2013 15:57'! methodsIconsCache ^ MethodsIconsCache! ! !AbstractModification commentStamp: ''! Modifications to a high-level class have an impact on the related low-level structures. There are two modification models that transform the high-level model into concrete low-level modifications models, the method modification model and the instance modification model. Both models list for every field, whether it was added, removed, or shifted to a new position. Instance Variables: slotShift modificationMap <(Collection of: AbstractFieldModification)>! !AbstractModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/24/2011 12:18'! size ^ modificationMap size.! ! !AbstractModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/24/2011 11:37'! slotShift: aShift slotShift := aShift! ! !AbstractModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:12'! installAddedSlot: addedSlot self subclassResponsibility! ! !AbstractModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:12'! installRemovedSlot: removedSlot self subclassResponsibility! ! !AbstractModification methodsFor: 'initialize-release' stamp: 'ToonVerwaest 3/28/2011 19:46'! initialize: anInteger self initialize. modificationMap := Array new: anInteger.! ! !AbstractModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:12'! installModifiedSlot: modifiedSlot self subclassResponsibility! ! !AbstractModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/30/2011 13:52'! modificationAt: idx idx > modificationMap size ifTrue: [ ^ slotShift ]. ^ modificationMap at: idx! ! !AbstractModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:29'! installUnmodifiedSlot: unmodifiedSlot modificationMap at: unmodifiedSlot fieldIndex put: unmodifiedSlot! ! !AbstractModification class methodsFor: 'instance creation' stamp: 'ToonVerwaest 3/24/2011 12:17'! new: anInteger ^ self new initialize: anInteger ! ! !AbstractMorphicAdapter commentStamp: ''! I am an abstract class providing all the properties shared amongs all the morphic specific adapters! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:45'! hSpaceFill self widgetDo: [ :w | w hResizing: #spaceFill ]! ! !AbstractMorphicAdapter methodsFor: 'drag and drop - private' stamp: 'BenjaminVanRyseghem 9/25/2013 14:09'! acceptDroppingMorph: draggedMorph event: event inMorph: source ^ self acceptDropBlock cull: draggedMorph cull: event cull: source! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 15:28'! enabled ^ self model enabled! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:44'! hRigid self widgetDo: [ :w | w hResizing: #rigid ]! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:46'! vShrinkWrap self widgetDo: [ :w | w vResizing: #shrinkWrap ]! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 15:20'! layout: aLayout | layout | layout := aLayout asMorphicLayout. self widgetDo: [ :w | w layoutFrame: layout ]! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:45'! hShrinkWrap self widgetDo: [ :w | w hResizing: #shrinkWrap ]! ! !AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 9/25/2013 16:22'! dropEnabled: aBoolean self widget ifNotNil: [ :w | w dropEnabled: aBoolean ]! ! !AbstractMorphicAdapter methodsFor: 'protocol-shortcuts' stamp: 'BenjaminVanRyseghem 11/12/2013 16:15'! removeKeyCombination: aShortcut self widget ifNotNil: [ :w | w removeKeyCombination: aShortcut ]! ! !AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 9/25/2013 16:22'! dragEnabled: aBoolean self widget ifNotNil: [ :w | w dragEnabled: aBoolean ]! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/23/2014 16:12'! color: color self widgetDo: [ :w | w color: color ]! ! !AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 9/25/2013 15:28'! dropEnabled ^ self model dropEnabled! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:45'! removeSubWidgets self widgetDo: [ :w | w removeAllMorphs ]! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 15:28'! enable self model enabled: true! ! !AbstractMorphicAdapter methodsFor: 'protocol-shortcuts' stamp: 'BenjaminVanRyseghem 11/12/2013 10:47'! bindKeyCombination: aShortcut toAction: aBlock self widget ifNotNil: [ :w | w bindKeyCombination: aShortcut toAction: aBlock ]! ! !AbstractMorphicAdapter methodsFor: 'dispatch' stamp: 'BenjaminVanRyseghem 9/25/2013 18:19'! treeRenderOn: aCanvas bounds: drawBounds color: drawColor font: aFont from: aMorph "Specify how this object as a list item should be drawn" self widget ifNil: [ self buildWithSpec ]. self widget treeRenderOn: aCanvas bounds: drawBounds color: drawColor font: aFont from: aMorph! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 15:27'! disable self model enabled: false! ! !AbstractMorphicAdapter methodsFor: 'dispatch' stamp: 'BenjaminVanRyseghem 9/25/2013 18:19'! heightToDisplayInTree: aTree "Return the width of my representation as a list item" self extent ifNotNil: [:ex | ^ ex y ]. self initialExtent ifNotNil: [:ex | ^ ex y ]. self widget ifNil: [ self buildWithSpec ]. ^ self widget heightToDisplayInTree: aTree! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:46'! useProportionalLayout self widgetDo: [ :w | w changeProportionalLayout ]! ! !AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 9/25/2013 15:24'! acceptDropBlock ^ self model acceptDropBlock! ! !AbstractMorphicAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 12/1/2013 01:10'! setModal: aWindow self widgetDo: [ :w | w setModal: aWindow ]! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'CamilloBruni 10/15/2013 20:56'! extent ^ self widget extent! ! !AbstractMorphicAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 10:20'! delete self widgetDo: [ :w | w delete ]! ! !AbstractMorphicAdapter methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 10/10/2013 12:15'! isMorphicAdapter ^ true! ! !AbstractMorphicAdapter methodsFor: 'protocol-shortcuts' stamp: 'BenjaminVanRyseghem 11/12/2013 10:54'! bindMenuKeyCombination: aShortcut toAction: aBlock self widget ifNotNil: [ :w | w bindKeyCombination: aShortcut toAction: aBlock ]! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 15:29'! help ^ self model help! ! !AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 9/25/2013 15:29'! transferBlock ^ self model transferBlock! ! !AbstractMorphicAdapter methodsFor: 'dispatch' stamp: 'BenjaminVanRyseghem 9/25/2013 18:19'! widthToDisplayInTree: aTree "Return the width of my representation as a list item" self extent ifNotNil: [:ex | ^ ex x ]. self initialExtent ifNotNil: [:ex | ^ ex x ]. self widget ifNil: [ self buildWithSpec ]. ^ self widget widthToDisplayInTree: aTree! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/1/2013 13:14'! when: anAnnouncement do: aBlock self widgetDo: [ :w | w announcer when: anAnnouncement do: aBlock ]! ! !AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 9/25/2013 15:28'! dragTransformationBlock ^ self model dragTransformationBlock! ! !AbstractMorphicAdapter methodsFor: 'drag and drop - private' stamp: 'BenjaminVanRyseghem 9/25/2013 14:09'! wantsDroppedMorph: draggedMorph event: anEvent inMorph: source ^ self wantDropBlock cull: draggedMorph cull: anEvent cull:source! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 16:21'! setBalloonText: aString self widget ifNotNil: [ :w | w setBalloonText: aString ]! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:47'! vSpaceFill self widgetDo: [ :w | w vResizing: #spaceFill ]! ! !AbstractMorphicAdapter methodsFor: 'dispatch' stamp: 'BenjaminVanRyseghem 3/4/2014 17:25:06'! listRenderOn: aCanvas atRow: aRow bounds: drawBounds color: drawColor backgroundColor: backgroundColor from: aMorph "Specify how this object as a list item should be drawn" self widget ifNil: [ self buildWithSpec ]. self widget vResizing: #rigid; hResizing: #rigid. self widget listRenderOn: aCanvas atRow: aRow bounds: drawBounds color: drawColor backgroundColor: backgroundColor from: aMorph! ! !AbstractMorphicAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 14:56'! changed ^ self widgetDo: [ :w | w changed ]! ! !AbstractMorphicAdapter methodsFor: 'drag and drop - private' stamp: 'BenjaminVanRyseghem 9/25/2013 15:29'! transferFor: passenger from: source ^ self transferBlock cull:passenger cull: source! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 16:21'! borderWidth: width self widget ifNotNil: [ :w | w borderWidth: width ]! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 13:42'! add: aWidget self widgetDo: [ :w | w ensureLayoutAndAddMorph: aWidget asWidget ]! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 15:24'! borderColor ^ self model borderColor! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 15:24'! borderWidth ^ self model borderWidth! ! !AbstractMorphicAdapter methodsFor: 'drag and drop - private' stamp: 'BenjaminVanRyseghem 9/25/2013 14:09'! dragPassengerFor: item inMorph: dragSource ^ self dragTransformationBlock cull: item cull: dragSource! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 16:21'! enabled: aBoolean self widget ifNotNil: [ :w | w enabled: aBoolean ]! ! !AbstractMorphicAdapter methodsFor: 'dispatch' stamp: 'BenjaminVanRyseghem 3/4/2014 17:25:06'! widthToDisplayInList: aList "Return the width of my representation as a list item" self model extent ifNotNil: [:ex | ^ ex x ]. self model initialExtent ifNotNil: [:ex | ^ ex x ]. self widget ifNil: [ self buildWithSpec ]. self widget vResizing: #rigid; hResizing: #rigid. ^ self widget widthToDisplayInList: aList! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 12:46'! vRigid self widgetDo: [ :w | w vResizing: #rigid ]! ! !AbstractMorphicAdapter methodsFor: 'drag and drop - private' stamp: 'BenjaminVanRyseghem 9/25/2013 14:09'! dragPassengersFor: item inMorph: dragSource ^ { self dragTransformationBlock cull: item cull: dragSource }! ! !AbstractMorphicAdapter methodsFor: 'protocol-shortcuts' stamp: 'BenjaminVanRyseghem 11/12/2013 16:15'! removeMenuKeyCombination: aShortcut self widget ifNotNil: [ :w | w removeKeyCombination: aShortcut ]! ! !AbstractMorphicAdapter methodsFor: 'dispatch' stamp: 'BenjaminVanRyseghem 9/25/2013 18:19'! beginsWith: aString fromList: aMorph "This method is used bu the list for the search of elements when you are typing directly in the list" ^ false! ! !AbstractMorphicAdapter methodsFor: 'dispatch' stamp: 'BenjaminVanRyseghem 3/4/2014 17:25:06'! heightToDisplayInList: aList "Return the width of my representation as a list item" self model extent ifNotNil: [:ex | ^ ex y ]. self model initialExtent ifNotNil: [:ex | ^ ex y ]. self widget ifNil: [ self buildWithSpec ]. self widget vResizing: #rigid; hResizing: #rigid. ^ self widget heightToDisplayInList: aList! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/23/2014 16:12'! color ^ self model color! ! !AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 9/25/2013 15:29'! wantDropBlock ^ self model wantDropBlock! ! !AbstractMorphicAdapter methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 9/25/2013 15:27'! dragEnabled ^ self model dragEnabled! ! !AbstractMorphicAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 16:21'! borderColor: color self widget ifNotNil: [ :w | w borderColor: color ]! ! !AbstractMorphicAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 9/25/2013 14:10'! defaultSpec ^ SpecLayout composed! ! !AbstractNautilusPlugin commentStamp: ''! AbstractNautilusPlugin is an abstraction of what a plugin for Nautilus is. Mainly, it defines the protocol! !AbstractNautilusPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 5/4/2011 14:45'! registerTo: aModel self subclassResponsibility! ! !AbstractNautilusPlugin methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:43'! model ^ model! ! !AbstractNautilusPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 8/25/2011 10:03'! position ^ position ifNil: [ position := self class defaultPosition ]! ! !AbstractNautilusPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 8/25/2011 09:49'! position: aPosition position := aPosition! ! !AbstractNautilusPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/2/2012 13:18'! name ^ self class name! ! !AbstractNautilusPlugin methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:44'! model: anObject model := anObject. self registerTo: anObject! ! !AbstractNautilusPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/10/2011 16:13'! display " should answer a morphic object ready to be integrated into a NautilusWindow " ^ nil! ! !AbstractNautilusPlugin class methodsFor: 'display' stamp: 'BenjaminVanRyseghem 8/25/2011 14:18'! pluginName ^ self name! ! !AbstractNautilusPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 8/25/2011 09:39'! possiblePositions ^ { #top. #middle. #bottom. #none. }! ! !AbstractNautilusPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 2/17/2012 16:26'! description ^ 'No description available'! ! !AbstractNautilusPlugin class methodsFor: 'position' stamp: 'SeanDeNigris 2/6/2013 12:04'! defaultPosition "Tells where in the Nautilus UI this plugin will appear. Pick an answer from #possiblePositions" ^ #none! ! !AbstractNautilusPlugin class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/4/2011 14:43'! model: aModel ^ self new model: aModel! ! !AbstractNautilusUI commentStamp: ''! An AbstractNautilusUI is an abstraction of the UI handling packages and classes. Instance Variables cachedHierarchy: classesSelection: commentButton: commentTextArea: currentDisplayChoice: firstColumn: groupsSelection: hierarchyClass: list: list2: model: packagesSelection: secondColumn: sourceCodeContainer: sourceCodePanel: sourceTextArea: sourceTextAreaLimit: window: ! !AbstractNautilusUI methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 18:01'! giveFocusToSourceCode self giveFocusTo: sourceTextArea ! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: 'EstebanLorenzano 1/31/2013 19:24'! groupsMenu: aMenu shifted: aBoolean " Morphic's menus are filled up when pragma's one are returned from a method, so I have to substitute the morphic menu by the pragma one " ^ aMenu addAllFrom: (self groupMenuBuilder menu)! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'MarcusDenker 9/27/2013 18:01'! findPackage "Search for a package from a pattern or from the recent list" | foundPackage | self okToChange ifFalse: [^ self ]. "packagesList := (self model recentClasses elements collect: [:each | each package name]) asSet asArray sort. foundPackage := self findPackageIn: packagesList. foundPackage ifNil: [ ^ self ]. self selectedPackage = foundPackage ifTrue: [ ^ self ]." foundPackage := SearchFacade rPackageSearch chooseFromOwner: self window. self selectedPackage: foundPackage. self updatePackageViewAndMove. ! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/14/2012 17:33'! sourceCodePanel ^ sourceCodePanel! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 1/24/2013 18:06'! addPackageAsGroup ^ [ self addPackagesAsGroup: self selectedPackages ] on: GroupAlreadyExists do: [:ex | self alertGroupExisting: ex groupName. ^ nil ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: ''! methodRemoved: anAnnouncement ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'SebastianTleye 8/1/2013 15:38'! classReorganized: anAnnouncement window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. (self selectedClass = anAnnouncement classReorganized or: [ anAnnouncement classReorganized users includes: self selectedClass ]) ifTrue: [ self updateBothView ]! ! !AbstractNautilusUI methodsFor: 'protocol' stamp: ''! title: aString shouldUpdateTitle := false. window title: aString! ! !AbstractNautilusUI methodsFor: 'annotation pane' stamp: ''! annotationSeparator "Answer the separator to be used between annotations" ^ ' · '! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'StephaneDucass 2/2/2014 09:02'! addFullClass self selectedPackage ifNotNil: [:package | self addFullClassIn: package ]! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: ''! groupMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self groupFixPragma. self groupPragma} model: self! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 3/23/2012 19:20'! doubleClick self ifGroups: [ self doubleClickOnGroup ] ifNot: [ self doubleClickOnPackage ]! ! !AbstractNautilusUI methodsFor: 'item creation' stamp: 'BenjaminVanRyseghem 8/6/2012 00:52'! buildCodePane "The following method fills up sourceTextArea variable" self buildNewSourceTextArea. multipleMethodsEditor := MultipleMethodsEditor new. multipleMethodsEditor hResizing: #spaceFill; vResizing: #spaceFill; addEditor: sourceTextArea. ^ multipleMethodsEditor! ! !AbstractNautilusUI methodsFor: 'Shout' stamp: ''! shoutAboutToStyle: aPluggableShoutMorphOrView ^ aPluggableShoutMorphOrView == sourceTextArea! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updateClassView list2Elements := nil. self changed: #listElement2: ! ! !AbstractNautilusUI methodsFor: 'list selections' stamp: 'BenjaminVanRyseghem 3/23/2012 19:57'! listSelection ^ self showGroups ifTrue: [ groupsSelection ] ifFalse: [ packagesSelection ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'ClementBera 7/26/2013 15:58'! lockTextArea self selectedMethod ifNil: [ ^ self ]. sourceTextArea lockFrom: self selectedMethod. self buildNewSourceTextArea. multipleMethodsEditor addEditor: sourceTextArea. self changed: #sourceCodeFrom:.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/16/2013 17:05'! selectedPackage: aPackage " Force package selection, not used by the lists " self okToChange ifTrue: [ acceptor := ClassDefinitionAcceptor model: self. packagesSelection removeAll. packagesSelection at: aPackage put: true. aPackage ifNotNil: [ self giveFocusTo: list ]. self selectedPackageWithoutChangingSelection: aPackage]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 01:49'! findSubclass "Search for a subclass of the selected class from a pattern or from the recent list" self selectedClass ifNotNil: [ :class| self findClass: (SearchFacade subclassSearchFor: class theNonMetaClass)].! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'MarcusDenker 9/27/2013 18:08'! packageChanged: anAnnouncement window isDisplayed ifFalse: [ ^ self ]. self showGroups ifFalse: [ self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! showGroupsSilently: aBoolean self model showGroups: aBoolean! ! !AbstractNautilusUI methodsFor: 'icons behavior' stamp: 'MarcusDenker 5/4/2013 10:12'! arrowDown: aMethod | methods methodsNames index | methods := aMethod methodClass allSubclasses gather: [:each | each methods ]. methods := methods select: [:each | each selector = aMethod selector ]. methods size = 1 ifTrue: [ ^ self model class openOnMethod: methods first ]. methodsNames := methods collect: [:each | each methodClass name, '>>#', each selector ]. index := UIManager default chooseFrom: methodsNames. index = 0 ifTrue: [ ^ self ]. ^ self model class openOnMethod: (methods at: index) ! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! showComment ^ self model showComment! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: ''! doubleClickOnPackage self selectedPackage ifNil: [ ^ self ] ifNotNil:[:package | self model class openOnPackage: package ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! browseMessages self browseMessagesFrom: self selectedMethod selector! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! resetListSelection2 self listSelection2 removeAll.! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'EstebanLorenzano 5/14/2013 09:44'! groupIconFor: aGroup | icon | GroupsIconsCache at: aGroup ifPresent: [:ic | ic class == IconicButtonStateHolder ifFalse: [ ^ ic ]. ^ ic asIconTargetting: self ]. icon := IconicButton new target: self; actionSelector: #restrictedBrowseGroups:; arguments: {{aGroup}}; labelGraphic: (Smalltalk ui icons iconNamed: #groupIcon); color: Color transparent; extent: 15 @ 16; helpText: 'Browse restricted environment'; borderWidth: 0. GroupsIconsCache at: aGroup put: (IconicButtonStateHolder forNautilus: icon). ^ icon! ! !AbstractNautilusUI methodsFor: 'item creation' stamp: 'BenjaminVanRyseghem 3/23/2012 18:45'! buildToggleButton ^ (PluggableButtonMorph on: self getState: #toggleButtonState action: #toggleButtonAction label: #toggleButtonLabel) getEnabledSelector: #toggleButtonEnabled; hResizing: #spaceFill; vResizing: #shrinkWrap; enabled: (self model selectedClass notNil); yourself! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! selectedClassComments ^ self selectedClass ifNil: [''] ifNotNil: [:class| class comment]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! fullBrowse ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: 'EstebanLorenzano 11/2/2012 17:19'! registerToMCAnnouncements SystemAnnouncer uniqueInstance weak on: MCVersionCreated send: #newMCVersion: to: self; on: MCPackageModified send: #mcPackageModified: to: self; on: MCWorkingCopyCreated send: #mcWorkingCopyCreated: to: self; on: MCWorkingCopyDeleted send: #mcWorkingCopyDeleted: to: self. ! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/9/2013 16:18'! parentOfClass: aClass ^ aClass package.! ! !AbstractNautilusUI methodsFor: 'item creation' stamp: 'BenjaminVanRyseghem 8/1/2012 19:13'! buildCommentPane commentTextArea := PluggableTextMorph on: self text: #getComments accept: #addComment:notifying: readSelection: nil menu: #codePaneMenu:shifted:. commentTextArea color: Color white. commentTextArea askBeforeDiscardingEdits: true; vResizing: #spaceFill; hResizing: #spaceFill. self setCommentShorcutsTo: commentTextArea. commentTextArea spaceFillWeight: 1. ^ commentTextArea! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: ''! unregisterAllPlugins self announcer subscriptions reset! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! removeClassFromGroup self selectedClasses do: [:class | [ self groupsManager removeClass: class theNonMetaClass from: self selectedGroup. self updateClassView ] fork ]. self selectedClass: nil; updateClassView.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! selectedPackage ^ self model selectedPackage! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: ''! toggleButtonState ^ self showPackages not! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'SebastianTleye 4/19/2013 15:57'! restrictedBrowseTraitUsers self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self restrictedBrowseTraitUsers: class users ]! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'BenjaminVanRyseghem 8/3/2012 16:18'! setWindowTitle | title | shouldUpdateTitle ifFalse: [ ^ self ]. title := self selectedClass ifNil: [ self selectedPackage ifNil: [ self title ] ifNotNil: [: p | p name ]] ifNotNil: [:class | self selectedMethod ifNil: [ class name asString ] ifNotNil: [:method | String streamContents: [:s | s << method methodClass name asString<< '>>#'<< method selector ]]]. self browsedEnvironment isSystem ifFalse: [ title := String streamContents: [:s | s << '--- ' << title << ' ---']]. window title: title.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'StephaneDucasse 8/29/2013 22:17'! classifier: aClassifier classifier := aClassifier! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/6/2012 00:53'! unlockTextArea: source multipleMethodsEditor removeEditor: source! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! mergeGroups | group | group := self mergeGroups: self selectedGroups. group ifNotNil: [ self groupsManager addAGroup: group. self selectedGroup: group. self updateBothView] ! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/4/2013 21:16'! categorizeAllUncategorizedMethods "Categorize methods by looking in parent classes for a method category." self selectedClass ifNotNil: [ :aClass | | methods | methods := aClass uncategorizedSelectors collect: [ :selector| aClass >> selector ]. self classifier classifyAll: methods ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! setStylerClass: aClass sourceTextArea ifNotNil: [ sourceTextArea classOrMetaClass: aClass ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! groupsLabel ^ 'Groups'! ! !AbstractNautilusUI methodsFor: 'monticello announcements' stamp: 'MarcusDenker 9/27/2013 17:59'! mcWorkingCopyCreated: anAnnouncement | package rpackage | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. package := anAnnouncement package. package ifNil: [ ^ self ]. rpackage := RPackageOrganizer default packageNamed: package name. (self model packages includes: rpackage) ifTrue: [ PackagesIconsCache removeKey: rpackage ifAbsent: []. self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! compileAMethodFromCategory: aCategory withSource: aString notifying: aController ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! listSize ^ self getList size.! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'NicolaiHess 3/14/2014 14:06'! classDefinitionModified: anAnnouncement | class | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement oldClassDefinition. ((self showGroups and: [ self selectedGroup notNil and: [ self selectedGroup elements includes: class ]]) or: [ self getList2 includes: class ]) ifTrue: [ (model selectedClass = anAnnouncement oldClassDefinition) ifTrue: [ model selectedClass: anAnnouncement newClassDefinition ]. "Minimal change to fix Case13006. Further investigation required in Pharo 4 on Case13020" self updateClassView. self removeFromPackagesIconsCache: class package. sourceTextArea hasUnacceptedEdits ifFalse: [ self changed: #sourceCodeFrom: ]].! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 1/15/2013 17:07'! renameClass self okToChange ifFalse: [ ^ self ]. self selectedClass ifNil: [ ^ self ]. self basicRenameClass: self selectedClass theNonMetaClass. self changed: #sourceCodeFrom:.! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'EstebanLorenzano 2/19/2013 14:43'! removeShortcuts: groupSymbol from: aMorph Nautilus useOldStyleKeys ifFalse: [ ^self ]. (aMorph kmDispatcher includesKeymapCategory: groupSymbol) ifTrue: [ aMorph detachKeymapCategory: groupSymbol targetting: self ] ! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! toggleShowPackages self showPackages: self showPackages not.! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'MarcusDenker 10/17/2013 12:08'! dropInList: aCollection inARow: aRow | receiver | (aRow = 0) ifTrue: [ ^ self ]. receiver := self getList at: aRow. receiver isClass ifTrue: [ self selectedClass isMeta ifTrue: [ receiver := receiver theMetaClass ] ifFalse: [ receiver := receiver theNonMetaClass ]]. self dropInAPackage: aCollection into: receiver! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! doItContext ^ nil! ! !AbstractNautilusUI methodsFor: 'widget - class' stamp: ''! classWidget ^ list2! ! !AbstractNautilusUI methodsFor: 'code panel' stamp: 'StephaneDucasse 12/19/2012 15:54'! buildCodePanelWithCommentOnTop | splitter delta | splitter := ProportionalSplitterMorph new beSplitsTopAndBottom. delta := 2. splitter addLeftOrTop: commentTextArea. splitter addRightOrBottom: multipleMethodsEditor. sourceCodePanel addMorph: commentTextArea fullFrame: ( (0@0 corner: 1@0.5) asLayoutFrame bottomRightOffset: 0@(delta negated)). sourceCodePanel addMorph: splitter fullFrame: ( (0@0.5 corner: 1@0.5) asLayoutFrame topLeftOffset: 0@(delta negated) ; bottomRightOffset: 0@delta). sourceCodePanel addMorph: multipleMethodsEditor fullFrame: ((0@0.5 corner: 1@1) asLayoutFrame topLeftOffset: (0@delta )).! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'EstebanLorenzano 10/10/2013 13:14'! addPackageAsGroupAndBrowse self addPackageAsGroup ifNotNil: [:group | self selectedGroup: group. self showGroups: true] ifNil: [ | group | group := self model groupsManager groupNamed: self selectedPackage name. group ifNotNil: [ self selectedGroup: group. self showGroups: true ]]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! systemNavigation ^ SystemNavigation new browsedEnvironment: self browsedEnvironment; yourself! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! browseInstVarRefs self browseInstVarRefsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'NicolaiHess 1/2/2014 22:37'! restrictedBrowseGroups: aCollection aCollection ifNotEmpty: [:groups || classes newEnvironment | classes := groups gather: [:group | group classes]. newEnvironment := self browsedEnvironment forClasses: classes. self model class openOnGroup: groups first inEnvironment: newEnvironment ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! getClassesList ^ self model classes! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! okToChangeComment commentTextArea canDiscardEdits ifTrue: [^ true]. commentTextArea update: #wantToChange. "Solicit cancel from view" ^ commentTextArea canDiscardEdits ! ! !AbstractNautilusUI methodsFor: 'group announcements' stamp: 'NicolaiHess 1/19/2014 12:13'! aGroupHasBeenRenamed: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" | group | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self groupsAreVisible ifFalse: [ ^ self ]. group := anAnnouncement group. (self groupsManager includes: group) ifTrue: [ self updateGroupView ]! ! !AbstractNautilusUI methodsFor: 'menus' stamp: 'MarcusDenker 5/5/2013 09:16'! addModelItemsToWindowMenu: aMenu "Add model-related items to the window menu" aMenu addLine; add: 'Nautilus Plugins Manager' target: NautilusPluginManager new action: #openInWorld. aMenu add: 'Shortcuts description' target: self action: #openShortcutDescription.! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: 'StephanEggermont 3/26/2014 18:03'! showSourceCodeButtonLabel ^' S'! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! showHierarchy ^ self model showHierarchy! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! createInitializerWithInstVars "Create a default initializer on the class side for a chosen list of instance variables" self createInitializerWithInstVarsOf: (self showInstance ifTrue: [ self selectedClass theNonMetaClass ] ifFalse: [ self selectedClass theMetaClass ])! ! !AbstractNautilusUI methodsFor: 'browser compatibility' stamp: ''! codeTextMorph ^ sourceTextArea! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: ''! groupsButtonState ^ false! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'DamienCassou 3/26/2013 16:28'! loadList2 ^ self ifGroups: [ self showHierarchy ifTrue: [ self getGroupHierarchy ] ifFalse: [ self getGroupsValuesList ]] ifNot: [ self showPackages ifTrue: [ self showHierarchy ifTrue: [ self getClassHierarchy2 ] ifFalse: [ self getPackagesList2 ]] ifFalse: [ cachedHierarchy ifNil: [ self getClassHierarchy ] ifNotNil: [:col | col sortedElements ]]]! ! !AbstractNautilusUI methodsFor: 'icon caches' stamp: ''! removeFromClassesIconsCache: aClass " not used since the class's icons are always the same " ClassesIconsCache removeKey: aClass ifAbsent: []. self updateClassView.! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'StephanEggermont 3/26/2014 17:11'! buildTextAreaButtonsColumn: aWindow | column | column := PanelMorph new. column changeTableLayout; listDirection: #topToBottom. { self buildSwitchToSourceCodeButton. self buildSwitchToByteCodeButton. self buildSeparator. self buildSeparator. self buildBrowseInstVarsButton. self buildBrowseClassVarsButton} reverse do: [:each | column addMorph: each ]. column vResizing: #spaceFill; width: 24; hResizing: #rigid. ^ column! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:00'! restrictedBrowsePackages: packages | newEnvironment | newEnvironment := self browsedEnvironment forPackages: packages. self model class openOnPackage: self selectedPackage inEnvironment: newEnvironment! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/6/2013 17:43'! showGroups: aBoolean self okToChange ifFalse: [ ^ self ]. self setShortcuts: #NautilusClassShortcuts to: list2. aBoolean ifTrue: [ list enabled: true. self removeShortcuts: #NautilusPackageShortcuts from: list. self setShortcuts: #NautilusGroupShortcuts to: list ] ifFalse: [ self removeShortcuts: #NautilusGroupShortcuts from: list. self setShortcuts: #NautilusPackageShortcuts to: list ]. listElements := nil. self showPackages ifFalse: [ self showPackagesSilently: true ]. self selectedGroup ifNil: [ self selectedClass: nil ] ifNotNil: [:group | (group elements includes: self selectedClass) ifFalse: [ list2Elements := nil. self selectedClass: nil ]. aBoolean ifTrue: [ groupsSelection at: group put: true ] ifFalse: [ packagesSelection at: self selectedPackage put: true ]]. self model showGroups: aBoolean. self changed: #groupsButtonLabel. self changed: #toggleButtonLabel. self changedLabels. self updateBothView! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:23'! packageFixPragma ^ 'nautilusGlobalPackageFixMenu'! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'GuillermoPolito 8/3/2012 13:21'! classCommented: anAnnouncement " announcement handled when a class has been commented " | aClass | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. aClass := anAnnouncement classCommented. (self getList2 includes: aClass) ifTrue: [ self removeFromClassesIconsCache: aClass ]. ((self selectedClass = aClass) and: [ self showComment ]) ifTrue: [ self changed: #getComments ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/3/2013 14:51'! buildTabbedNameOf: anElement | tab result size | tab := ' '. size := cachedHierarchy indentationFor: anElement. result := String new: (size * (tab size)) streamContents: [ :s| 1 to: size do: [:i | s nextPutAll: tab ]]. ^ self selectedPackage ifNil: [result, anElement name] ifNotNil: [:package | (package includesClass: anElement) ifTrue: [ (result, anElement name) asStringMorph ] ifFalse: [ (result , anElement name",' (', anElement package name,')'")asStringMorph color: self extensionColor;yourself]]! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'EstebanLorenzano 2/6/2013 14:00'! setGroupShorcutsTo: aList aList attachKeymapCategory: #NautilusGroupShortcuts targetting: self! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'EstebanLorenzano 1/16/2014 11:09'! dropInAPackage: aCollection into: receiver aCollection do:[:aClass | self showGroups ifTrue: [ receiver addClasses: { aClass }. ActiveHand shiftPressed ifFalse: [ self selectedGroup removeClass: aClass. self updateClassView ]] ifFalse: [ receiver addClass: aClass theNonMetaClass. ActiveHand shiftPressed ifTrue: [ self selectedClass: nil. self updateClassView ] ifFalse:[ self selectedPackage: receiver. self selectedClass: aClass. self updateBothView ]]]! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: 'EstebanLorenzano 11/2/2012 17:19'! registerToAnnouncements self registerToSystemAnnouncements. (Smalltalk at: #TestAnnouncer ifPresent: [ self registerToTestAnnouncements ]). self registerToMCAnnouncements. self registerToGroupAnnouncements. ! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'NicolaiHess 4/8/2014 21:00'! restrictedBrowseClasses: classes | newEnvironment | newEnvironment := self browsedEnvironment forClasses: (classes collect:#theNonMetaClass). self model class openOnClass:self selectedClass inEnvironment: newEnvironment ! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/20/2012 15:04'! model: anObject model := anObject. self registerToAnnouncements. model when: #historyChanged send: #historyChanged to: self. anObject selectedPackage ifNotNil: [:e | packagesSelection at: e put: true ]. anObject selectedGroup ifNotNil: [:p | groupsSelection at: p put: true ]. anObject selectedClass ifNotNil: [:p | classesSelection at: p put: true ].! ! !AbstractNautilusUI methodsFor: 'code panel' stamp: 'StephaneDucasse 12/19/2012 15:56'! buildCodePanelWithoutComment sourceCodePanel addMorph: multipleMethodsEditor fullFrame: LayoutFrame identity! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! putSourceTextAreaLimit sourceTextArea ifNotNil: [ sourceTextArea warningLimit: sourceTextAreaLimit ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! popUpTestsResult: aClass! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 6/28/2012 14:45'! restrictedBrowse self showGroups ifTrue: [ ^ self restrictedBrowseGroup ]. self selectedClass ifNil: [ self restrictedBrowsePackage ] ifNotNil: [ self restrictedBrowseClass ].! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 4/6/2012 16:33'! copyClasses | association | self okToChange ifFalse: [^ self]. association := self copyClasses: (self selectedClasses collect: [:e | e theNonMetaClass ]). association key ifTrue: [ self selectedClass: association value. self updateClassView]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:48'! showComment: aBoolean self okToChangeComment ifFalse: [ ^ self ]. self model showComment: aBoolean. self updateCodePanel! ! !AbstractNautilusUI methodsFor: 'widget needed methods' stamp: ''! selectedCategory ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'group announcements' stamp: 'NicolaiHess 1/19/2014 12:06'! aGroupHasBeenAdded: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" | group | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self groupsAreVisible ifFalse: [ ^ self ]. group := anAnnouncement group. (self groupsManager includes: group) ifTrue: [ self updateGroupView ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 3/23/2012 19:59'! removeClasses "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." | result scroll | self okToChange ifFalse: [^ false]. scroll := list2 scrollValue y. result := self removeClasses: (self selectedClasses collect: #theNonMetaClass). result ifTrue: [ classesSelection removeAll. self selectedClass: nil ]. list2 vScrollValue: scroll. ^ result! ! !AbstractNautilusUI methodsFor: 'source text events' stamp: ''! keyStroke: anEvent fromSourceCodeMorph: aMorph ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 4/6/2012 16:45'! addPackagesInGroup self addPackagesInGroup: self selectedPackages! ! !AbstractNautilusUI methodsFor: 'icons behavior' stamp: ''! runTestForAMethod: aMethod notifying: anObject ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:48'! updateCodePanel commentTextArea ifNil: [ self buildCommentPane ]. sourceCodePanel removeAllMorphs. self model showComment ifTrue: [ self buildCodePanelWithComment ] ifFalse: [ self buildCodePanelWithoutComment ]! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: 'EstebanLorenzano 11/2/2012 17:20'! registerToTestAnnouncements "Since Test classes can be absent (in production, for instance, I use non-global references)" (Smalltalk at: #TestAnnouncer) uniqueInstance weak on: (Smalltalk at: #TestCaseStarted) send: #testCaseStarted: to: self; on: (Smalltalk at: #TestSuiteEnded) send: #testRunned: to: self.! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: ''! methodRecategorized: anAnnouncement ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! runTestsOfGroups: aCollection notifying: aBoolean | classes label | label := 'Group: '. aCollection size >1 ifTrue: [ label := 'Groups: ']. classes := aCollection gather:[:each | each elements ]. classes := classes select: [:class | class inheritsFrom: TestCase ]. self runClassTests: classes notifying: false. aBoolean ifFalse: [ self notifyTitle: 'Test Finished' contents: label,((aCollection collect: #name) joinUsing: ', ') ]! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: ''! doubleClickOnGroup self selectedGroup ifNil: [ ^self ] ifNotNil:[:group | self model class openOnGroup: group ]! ! !AbstractNautilusUI methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 3/23/2012 19:58'! menu: aMenu shifted: aBoolean self showGroups ifTrue: [self groupsMenu: aMenu shifted: aBoolean] ifFalse: [self packagesMenu: aMenu shifted: aBoolean]. ^ aMenu! ! !AbstractNautilusUI methodsFor: 'group announcements' stamp: 'NicolaiHess 1/19/2014 12:16'! aGroupHasBeenRemoved: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self groupsAreVisible ifFalse: [ ^ self ]. (self groupsManager = anAnnouncement holder) ifTrue: [ self selectedGroup = anAnnouncement group ifTrue: [ self selectedGroup: nil ]. self updateGroupView. self update ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'EstebanLorenzano 1/31/2013 19:24'! codePaneMenu: aMenu shifted: shifted "Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items in a text pane" | donorMenu | donorMenu := shifted ifTrue: [SmalltalkEditor shiftedYellowButtonMenu] ifFalse: [SmalltalkEditor yellowButtonMenu]. ^ aMenu addAllFrom: donorMenu! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updateGroupView listElements := nil. self changed: #listElement:! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! selectedPackages | associations | associations := packagesSelection associations select: [:assoc | assoc value ]. associations := associations collect: [:assoc | assoc key ]. ^ associations select: [:each | each notNil ]! ! !AbstractNautilusUI methodsFor: 'code panel' stamp: 'StephaneDucasse 12/19/2012 15:47'! buildCodePanelWithCommentOnBottom | splitter delta | splitter := ProportionalSplitterMorph new beSplitsTopAndBottom. delta := 2. splitter addLeftOrTop: multipleMethodsEditor. splitter addRightOrBottom: commentTextArea. sourceCodePanel addMorph: multipleMethodsEditor fullFrame: ( (0@0 corner: 1@0.5) asLayoutFrame bottomOffset: delta negated). sourceCodePanel addMorph: splitter fullFrame: ( (0@0.5 corner: 1@0.5) asLayoutFrame topLeftOffset: 0@(delta negated) ; bottomRightOffset: 0@delta). sourceCodePanel addMorph: commentTextArea fullFrame: ( (0@0.5 corner: 1@1) asLayoutFrame topLeftOffset: (0@delta)).! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: 'EstebanLorenzano 1/31/2013 19:24'! classesMenu: aMenu shifted: aBoolean ^ aMenu addAllFrom: self classMenuBuilder menu.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/23/2012 19:59'! selected | item | item := self ifGroups: [ self selectedGroup ] ifNot: [ self selectedPackage ]. ^self getList indexOf: item.! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! browseUnusedMethods self browseUnusedMethodsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! sourceTextArea ^ sourceTextArea! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'NicolaiHess 1/19/2014 12:05'! addNewGroup [ self groupsManager createAnEmptyStaticGroup ] on: GroupAlreadyExists do:[ :ex | self alertGroupExisting: ex groupName ]. ! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 14:12'! openClass: aClass aClass ifNil: [ ^ self ]. self open browseClass: aClass! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! renameCategory ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'widget needed methods' stamp: ''! forceSelectedMethod: aMethod ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! window: anObject window := anObject! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! browseClassVarRefs self browseClassVarRefsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updateBothView listElements := nil. list2Elements := nil. self changed: #listElement:. self changed: #listElement2:! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:02'! restrictedBrowseSubclasses self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self restrictedBrowseClasses: class withAllSubclasses]! ! !AbstractNautilusUI methodsFor: 'icons behavior' stamp: 'EstebanLorenzano 5/14/2013 09:43'! openCommentEditor: aClass | newComment | newComment := Smalltalk ui theme textEditorIn: window text: 'Enter a comment for the class ', aClass theNonMetaClass name,':' title: 'Comment Editor' entryText: aClass theNonMetaClass comment entryHeight: 300. newComment ifNotNil: [ aClass theNonMetaClass comment: newComment asString ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/20/2012 00:03'! runTestForMethods: aCollection notifying: aBoolean aCollection do: [ :each | each isTestMethod ifTrue: [ self runTestForAMethod: each notifying: aBoolean ]]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:03'! restrictedBrowseHierarchy self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self restrictedBrowseClasses: (class withAllSuperclasses, class allSubclasses) ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: ''! methodAdded: anAnnouncement ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: 'EstebanLorenzano 1/31/2013 19:24'! packagesMenu: aMenu shifted: aBoolean ^ aMenu addAllFrom: (self packageMenuBuilder menu)! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/6/2012 01:23'! canChangeLockFor: source ^ source locked or: [ self selectedMethod isNil not ]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/22/2012 17:32'! showPackages: aBoolean self okToChange ifTrue: [ listElements := nil. list2Elements := nil. list enabled: aBoolean. aBoolean ifFalse: [| class | class := self selectedClass theNonMetaClass. classesSelection at: class put: true. self hierarchyClass: class . listElements := nil. list2Elements := nil. self showGroups ifTrue: [self showGroupsSilently: false]]. listElements := nil. list2Elements := nil. self model showPackages: aBoolean. self changed: #groupsButtonLabel. self updateBothView. self changed: #toggleButtonState. self changed: #toggleButtonLabel. self changedLabels ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! getComments ^ self selectedClass ifNil: [ self selectedPackage ifNil: [ '' ] ifNotNil: [:package | '' "package comment" ]] ifNotNil: [:class | class comment ]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! toggleShowGroups self showGroups: self showGroups not.! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: ''! packageMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self packageFixPragma. self packagePragma} model: self! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'DamienCassou 3/26/2013 16:28'! getGroupHierarchy ^ self selectedGroup ifNil: [ {} ] ifNotNil: [:group | cachedHierarchy := self buildGroupHierarchyFor: group. cachedHierarchy sortedElements]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/26/2013 17:58'! noMethodsString ^ Protocol nullCategory! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! fileOutMethods ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'MarcusDenker 10/24/2013 11:15'! packageRenamed: anAnnouncement window isDisplayed ifFalse: [ ^ self ]. self showGroups ifFalse: [ self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! sourceCodeSymbol ^ #SourceCode! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! open window := NautilusWindow new model: self. self addAll: window. window openInWorld. self changed:#sourceCodeFrom:. self setWindowTitle.! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! getGroupsValuesList ^ self selectedGroup ifNil: [{}] ifNotNil: [:group | group classes ]! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: 'EstebanLorenzano 11/2/2012 17:19'! registerToGroupAnnouncements GroupAnnouncer uniqueInstance weak on: AGroupHasBeenRegistered send: #aGroupHasBeenRegistered: to: self; on: AGroupHasBeenUnregistered send: #aGroupHasBeenUnregistered to: self; on: AGroupHasBeenAdded send: #aGroupHasBeenAdded: to: self; on: AGroupHasBeenRemoved send: #aGroupHasBeenRemoved: to: self; on: AGroupHasBeenRenamed send: #aGroupHasBeenRenamed: to: self! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: 'StephanEggermont 3/26/2014 18:08'! showInstanceVarsButtonLabel ^' I' ! ! !AbstractNautilusUI methodsFor: 'group announcements' stamp: 'NicolaiHess 1/19/2014 12:11'! aGroupHasBeenRegistered: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" | group | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self groupsAreVisible ifFalse: [ ^ self ]. group := anAnnouncement group. (self groupsManager includes: group) ifTrue: [ self updateGroupView ]! ! !AbstractNautilusUI methodsFor: 'test creation' stamp: ''! buildTestClassNameFrom: aClass ^ (aClass name asString,'Test') asSymbol! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! createInstVarAccessors self createInstVarAccessorsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'protocol' stamp: ''! resetSelections! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! selectedClasses | associations | associations := classesSelection associations select: [:assoc | assoc value ]. associations := associations collect: [:assoc | assoc key ]. ^ associations select: [:each | each notNil ]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'StephaneDucasse 8/29/2013 22:15'! classifier ^ classifier! ! !AbstractNautilusUI methodsFor: 'list selections' stamp: ''! listSelectionAt: anIndex put: aBoolean | elt | elt := self getList at: anIndex ifAbsent: [ ^ self ]. self listSelection at: elt put: aBoolean. self changed: #hasSelectedSelections! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/16/2013 14:57'! renamePackage: aPackage | isCurrent | isCurrent := self isSelectedPackage: aPackage. super renamePackage: aPackage. isCurrent ifTrue: [ self selectedPackage: aPackage ]. packagesSelection at: aPackage put: true.! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! getList ^ listElements ifNil: [ listElements := self loadList ].! ! !AbstractNautilusUI methodsFor: 'item creation' stamp: 'EstebanLorenzano 1/30/2013 14:45'! buildList2 list2 := PluggableIconListMorph new basicWrapSelector: #listWrapper2:; keystrokeSelector: #keyPressedOnList2:shifted:; getIconSelector: #listIcon2:; getListSizeSelector: #listSize2; resetListSelector: #resetListSelection2; autoDeselect: true; dropEnabled: true; dropItemSelector: #dropInList2:inARow:; doubleClickSelector: #doubleClick2; dragEnabled: true; hResizing: #spaceFill; vResizing: #spaceFill; model: self; getIndexSelector: #selected2; setIndexSelector: #selected2:; getSelectionListSelector: #listSelection2At:; setSelectionListSelector: #listSelection2At:put:; getMenuSelector: #menu2:shifted:; beMultipleSelection; getListElementSelector: #listElement2:. self setShortcuts: #NautilusClassShortcuts to: list2. ^ list2! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: ''! announcer ^ self model announcer! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'StephaneDucasse 12/19/2012 16:04'! toggleShowFullComment self showComment ifFalse: [ ^ self ]. sourceCodePanel removeAllMorphs. sourceCodePanel addMorph: self commentTextArea fullFrame: LayoutFrame identity! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/22/2012 16:42'! showHierarchy: aBoolean self model showHierarchy: aBoolean. listElements := nil. list2Elements := nil. aBoolean ifTrue: [ self hierarchyClass: self selectedClass ]. self updateBothView! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: ''! keyPressedOnElement: anEvent ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/1/2012 19:10'! commentTextArea ^ commentTextArea! ! !AbstractNautilusUI methodsFor: 'test creation' stamp: 'EstebanLorenzano 10/9/2013 16:19'! createTestForClass: aClass | definition testClass className | aClass ifNil: [ ^ nil ]. (aClass inheritsFrom: TestCase) ifTrue: [ ^ nil ]. aClass isMeta ifTrue: [ ^ nil ]. className := self buildTestClassNameFrom: aClass. testClass := self class environment at: className ifPresent: [:class | class ] ifAbsent: [ definition := self buildTestClassDefinitionFrom: aClass. testClass := self compileANewClassFrom: definition notifying: nil startingFrom: self selectedClass. self class environment at: className. testClass comment: (self generateCommentForTestClass: testClass from: aClass)]. self showGroups: false. self selectedPackage: (self parentOfClass: testClass). self selectedClass: testClass. self updateBothView. ^ testClass! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! buildInitializerFor: aVariableList ^ String streamContents: [ :stream| aVariableList do: [ :varName| stream << varName << ': ' << varName] separatedBy: [ stream << ' ' ]. stream cr cr tab << '^ self new'; cr. aVariableList do: [ :varName| stream tab tab << varName << ': ' << varName << ';'; cr]. stream tab tab << 'yourself']! ! !AbstractNautilusUI methodsFor: 'annotation pane' stamp: ''! defaultAnnotationInfo "see annotationRequests comment" ^ #(timeStamp messageCategory sendersCount implementorsCount allChangeSets)! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! browseInstVars | cls | cls := self selectedClass. (cls notNil and: [cls isTrait not]) ifTrue: [ self systemNavigation browseInstVarRefs: cls ]. self changed: #isAClassSelected! ! !AbstractNautilusUI methodsFor: 'item creation' stamp: 'BenjaminVanRyseghem 2/26/2013 18:46'! buildList list := PluggableIconListMorph new basicWrapSelector: #listWrapper:; keystrokeSelector: #keyPressedOnList:shifted:; getIconSelector: #listIcon:; getListSizeSelector: #listSize; resetListSelector: #resetListSelection; autoDeselect: true; dropEnabled: true; doubleClickSelector: #doubleClick; dropItemSelector: #dropInList:inARow:; dragEnabled: true; hResizing: #spaceFill; vResizing: #spaceFill; model: self; getIndexSelector: #selected; setIndexSelector: #selected:; getSelectionListSelector: #listSelectionAt:; setSelectionListSelector: #listSelectionAt:put:; getMenuSelector: #menu:shifted:; beMultipleSelection; basicGetListElementSelector: #listElement:. self setShortcuts: #NautilusPackageShortcuts to: list. list on: #mouseDown send: #listMouseDown: to: self. list hResizing: #spaceFill; vResizing: #spaceFill. ^ list! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: ''! switchToSourceCodeButton self okToChange ifTrue: [ self currentDisplayChoice: self sourceCodeSymbol ]! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! categoryPragma ^'nautilusGlobalProtocolMenu'! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 3/23/2012 19:17'! listWrapper: anElement anElement = 0 ifTrue: [^'']. ^ self ifGroups: [ anElement name ] ifNot: [ anElement name "self ifPackages: [ anElement name ] ifClasses: [ self buildTabbedNameOf: anElement ]"]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! removeSourceTextAreaLimit sourceTextArea ifNotNil: [ sourceTextArea warningLimit: -1 ]! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! methodPragma ^'nautilusGlobalMethodMenu'! ! !AbstractNautilusUI methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 3/23/2012 19:58'! menu2: aMenu shifted: aBoolean self classesMenu: aMenu shifted: aBoolean. ^ aMenu! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updatePackageViewContent | vScrollValue | vScrollValue := list scrollValue y. listElements := nil. self changed: #listElement:. list vScrollValue: vScrollValue! ! !AbstractNautilusUI methodsFor: 'code panel' stamp: ''! buildCodePanelWithComment self model commentPosition == #right ifTrue: [ self buildCodePanelWithCommentOnRight ]. self model commentPosition == #bottom ifTrue: [ self buildCodePanelWithCommentOnBottom ]. self model commentPosition == #left ifTrue: [ self buildCodePanelWithCommentOnLeft ]. self model commentPosition == #top ifTrue: [ self buildCodePanelWithCommentOnTop ].! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'ClementBera 7/26/2013 15:57'! contentSelectionFor: aTextMorph aTextMorph ifLocked: [ ^ (1 to: 0) ]. self selectedClass ifNotNil: [ self selectedMethod ifNil: [ self selectedCategory ifNotNil: [^ (1 to: self defaultMethodSource size) ]]]. ^ (1 to: 0) ! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! buildSetUpCodeFor: aClass ^ String streamContents: [:str | str << 'setUp';cr. str tab << '"Setting up code for '<>#setUp) ] ifFalse: [ index := 62. (class includesSelector: #initialize) ifFalse: [ code := self buildInitializeCodeFor: class. class compile: code classified: category ]. self selectedMethod: (class>>#initialize) ]. self update. self giveFocusTo: sourceTextArea. sourceTextArea selectFrom: index+class name size to: index-1+class name size ].! ! !AbstractNautilusUI methodsFor: 'code panel' stamp: 'StephaneDucasse 12/19/2012 15:49'! buildCodePanelWithCommentOnLeft | splitter delta | splitter := ProportionalSplitterMorph new. delta := 2. splitter addLeftOrTop: commentTextArea. splitter addRightOrBottom: multipleMethodsEditor. sourceCodePanel addMorph: commentTextArea fullFrame: ( (0@0 corner: 0.5@1) asLayoutFrame bottomRightOffset: (delta negated)@0). sourceCodePanel addMorph: splitter fullFrame: ((0.5@0 corner: 0.5@1) asLayoutFrame topLeftOffset: (delta negated)@0; bottomRightOffset: delta@0). sourceCodePanel addMorph: multipleMethodsEditor fullFrame: ( (0.5@0 corner: 1@1) asLayoutFrame topLeftOffset: (delta@0)).! ! !AbstractNautilusUI methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 4/18/2012 13:16'! receiverClass ^ self selectedClass! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! selectedGroups | associations | associations := groupsSelection associations select: [:assoc | assoc value ]. associations := associations collect: [:assoc | assoc key ]. ^ associations select: [:each | each notNil ]! ! !AbstractNautilusUI methodsFor: 'item creation' stamp: 'EstebanLorenzano 1/30/2013 14:40'! buildCommentButton | button | button := (PluggableButtonMorph on: self getState: #commentButtonState action: #commentButtonAction label: #commentButtonLabel) hResizing: #spaceFill; vResizing: #shrinkWrap. self setShortcuts: #NautilusCommentShortcuts to: button. button submorphs first on: #doubleClick send: #toggleShowFullComment to: self; on: #mouseDown send: #mouseDown: to: button; on: #mouseMove send: #mouseMove: to: button; on: #mouseEnter send: #mouseEnter: to: button; on: #mouseLeave send: #mouseLeave: to: button; on: #mouseUp send: #mouseUp: to: button. ^ button! ! !AbstractNautilusUI methodsFor: 'test creation' stamp: ''! buildTestClassDefinitionFrom: aClass ^ 'TestCase subclass: ', (self buildTestClassNameFrom: aClass) printString, ' instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''',(self buildTestPackageNameFrom:aClass),''''! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: ''! commentButtonAction self toggleShowComment.! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! compileSource: aText notifying: aController ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! methodsForCategories: aCollection ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'EstebanLorenzano 10/14/2013 16:23'! classAdded: anAnnouncement | class | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement classAdded. ((self showGroups and: [ self selectedGroup ifNil: [ ^ self ] ifNotNil: [:gp | gp elements includes: class ]]) or: [ self selectedPackage = (self parentOfClass: class)]) ifTrue: [ self updateClassView. self removeFromPackagesIconsCache: class package ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'johanfabry 11/14/2013 14:41'! defaultClassDescriptor | string | string := 'Object subclass: #NameOfSubclass instanceVariableNames: '''' classVariableNames: '''' category: '''. ^ self selectedPackage ifNil: [string, '''' ] ifNotNil: [:package | string, package name, '''' ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! selectedItems | associations | associations := self listSelection associations select: [:assoc | assoc value ]. ^ associations collect: [:assoc | assoc key ].! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/25/2012 18:00'! instanceLabel ^'Instance' asMorph! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! copyCategory: anObject toTheClass: aClass | originClass methods | originClass := self selectedClass. methods := originClass methodsInProtocol: anObject. methods do: [:meth | self copyMethod: meth toTheClass: aClass ].! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'MarcusDenker 9/27/2013 18:03'! moveMethod: aMethod toTheClass: aClass autoRemove: autoRemove aMethod realClass = aClass ifTrue: [ ^ self ]. aClass methodDict at: aMethod selector ifPresent: [:sel | " here I have to fork to release the drag & drop " [ (self openDialogWouldYouInstall: sel into: aClass) ifTrue: [ | originClass oldCategory | oldCategory := aMethod category. originClass := aMethod realClass. aClass compile: aMethod sourceCode classified: oldCategory. self selectedMethod: nil. originClass removeSelector: aMethod selector. autoRemove ifTrue: [ (originClass selectorsInProtocol: oldCategory ) ifEmpty: [ originClass removeProtocol: oldCategory ]]]] fork] ifAbsent: [ | originClass oldCategory | oldCategory := aMethod category. originClass := aMethod realClass. aClass compile: aMethod sourceCode classified: oldCategory. self selectedMethod: nil. originClass removeSelector: aMethod selector. autoRemove ifTrue: [ ( originClass selectorsInProtocol: oldCategory ) ifEmpty: [ originClass removeProtocol: oldCategory ]]]! ! !AbstractNautilusUI methodsFor: 'list selections' stamp: 'BenjaminVanRyseghem 3/23/2012 19:57'! listSelection2 ^ classesSelection! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! showUnreferencedClassVars "Search for all class variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each class variable in order to determine whether it is unreferenced" self showUnreferencedClassVarsOf: self selectedClass.! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/6/2012 00:49'! lockTextArea: aBoolean from: source aBoolean ifTrue: [ self lockTextArea ] ifFalse: [ self unlockTextArea: source ].! ! !AbstractNautilusUI methodsFor: 'test creation' stamp: ''! createTestForSelectedClass self createTestForClass: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! browseInstVarDefs self browseInstVarDefsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'MarcusDenker 10/24/2013 11:15'! rootsOfGroup: aGroup | classes | self browsedEnvironment isSystem ifTrue: [ classes := aGroup elements ] ifFalse: [ classes := aGroup elements intersection: self model classes ]. ^ classes reject: [ :each | classes includes: each superclass ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 6/26/2012 23:52'! browseSendersOfMessages "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen." self selectedMethod ifNotNil: [:met | self browseSendersOfMessagesFrom: met selector ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'SebastianTleye 4/23/2013 13:09'! getPackagesWithoutExtensionsList ^ self model packagesWithoutExtensions sort: [:a :b | a name <= b name ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! addSubclassesOf: aClass in: result withIndex: index | classes | classes := aClass subclasses "self selectedPackage ifNil: [ {} ] ifNotNil: [:p | aClass subclasses intersection: p classes ]". classes do: [:each | result at: each put: index. self addSubclassesOf: each theNonMetaClass in: result withIndex: index + 1 ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! browseClassVars | cls | self selectedClass ifNil: [ self changed: #isAClassSelected. ^ self ]. cls := self selectedClass theNonMetaClass. (cls notNil and: [cls isTrait not]) ifTrue: [ self systemNavigation browseClassVarRefs: cls ]. ! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:33'! wantsDroppedMorph: transferMorph event: anEvent inMorph: destinationLM "We are only interested in TransferMorphs as wrappers for informations. If their content is really interesting for us, will determined later in >>acceptDroppingMorph:event:." | srcType dstType | "only want drops on lists (not, for example, on pluggable texts)" (destinationLM isKindOf: PluggableListMorph) ifFalse: [^ false]. srcType := transferMorph dragTransferType. dstType := self dragTransferTypeForMorph: destinationLM. srcType == #getMethodItem: ifTrue: [ ^ (dstType == #getCategoryItem: or: [ dstType == #listElement2: ])]. srcType == #getCategoryItem: ifTrue: [ ^ dstType == #listElement2: ]. (srcType == #listElement2: and: [ dstType = #listElement: ]) ifTrue: [ (destinationLM potentialDropItem isKindOf: PluggableListMorph) ifTrue: [ ^ true ]. self showGroups ifTrue: [ | receiver | receiver := destinationLM potentialDropItem originalObject. ^ receiver isFillable ] ifFalse: [ ^ true ]] ifFalse:[ ^ false ]. ^ false! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! textMorphClass ^ PluggableTextMorphWithLimits! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'MarcusDenker 9/27/2013 18:07'! buildGroupHierarchyFor: aGroup | coll1 | aGroup ifNil: [ ^ SortHierarchically new ]. coll1 := self browsedEnvironment isSystem ifTrue: [ aGroup classes ] ifFalse: [ aGroup classes intersection: self model classes ]. ^ SortHierarchically buildHierarchyForClasses: coll1! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/18/2012 09:28'! selectedClass: aClass self okToChangeBoth ifTrue: [ classesSelection removeAll. aClass ifNotNil: [ self giveFocusTo: list2 ]. self selectedClassWithoutChangingSelection: aClass. ]! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: ''! methodMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self commonPragma. self methodPragma} model: self! ! !AbstractNautilusUI methodsFor: 'icons behavior' stamp: ''! runClassTests self runClassTests: self selectedClasses notifying: true! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! groupPragma ^'nautilusGlobalGroupMenu'! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: ''! commentButtonState ^ self showComment! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! browsedEnvironment ^ self model browsedEnvironment! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 13:35'! browseSuperclass self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self browseSuperclassOf: class ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! flashPackage ^ nil! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 7/17/2013 22:53'! buildInitializeCodeFor: aClass ^ String streamContents: [:str | str << 'initialize';cr. str cr tab << 'super initialize.';cr. aClass instVarNames sort do: [ :name | str cr tab << name << ' := nil.' ]]. ! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'IgorStasenko 10/13/2013 18:28'! runPackagesTestsNotifying: aBoolean self selectedPackages ifNotNil: [:packages || classes label | packages size > 1 ifTrue: [ label := 'Packages: ' ] ifFalse: [ label := 'Package: ' ]. classes := packages gather: [:package | package definedClasses ]. classes := classes select: [:class | class inheritsFrom: TestCase ]. self runClassTests: classes notifying: false. aBoolean ifTrue: [ | color | (classes anySatisfy:[:e | e hasPassedTest ]) ifTrue: [ color := Color green ]. (classes anySatisfy:[:e | e hasFailedTest ]) ifTrue: [ color := Color yellow ]. (classes anySatisfy:[:e | e hasErrorTest ]) ifTrue: [ color := Color red ]. self notifyTitle: 'Test Finished' contents: label , ((packages collect: #name) joinUsing: ', ') color: color ]].! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 7/13/2012 14:32'! dragPassengersFor: item inMorph: dragSource | transferType object | object := item originalObject. (dragSource isKindOf: PluggableListMorph) ifFalse: [^ nil ]. transferType := self dragTransferTypeForMorph: dragSource. transferType == #getCategoryItem: ifTrue: [ ^ self selectedCategories ifEmpty: [ { object } ] ]. transferType == #listElement2: ifTrue: [ self showGroups ifTrue: [ self selectedGroup ifNil: [ ^ nil ] ifNotNil: [:g | g isFillable ifFalse: [ ^ nil ]]]. ^ self selectedClasses ifEmpty: [ { object } ]]. transferType == #getMethodItem: ifFalse: [ ^ nil ]. ^ self selectedMethods ifEmpty: [ (self getMethods includes: object) ifTrue: [{ object }] ifFalse: [ nil ]]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! getPackagesList2 ^ self model classesInTheSelectedPackage! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! addCategory ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'EstebanLorenzano 4/14/2014 17:39'! packageIconFor: aPackage | mcpackage | PackagesIconsCache at: aPackage ifPresent: [:icon | icon class == IconicButtonStateHolder ifFalse: [ ^ icon ]. ^ icon asIconTargetting: self ]. aPackage classes isEmpty ifTrue: [^ PackagesIconsCache at: aPackage put: (Smalltalk ui icons iconNamed: #emptyPackageIcon) ]. mcpackage := aPackage correspondingMcPackage. (mcpackage notNil and: [ mcpackage isDirty ]) ifTrue: [ | icon | icon := IconicButton new target: self; actionSelector: #saveDirtyPackages:; arguments: {{ aPackage }}; labelGraphic: (aPackage definedClasses ifEmpty: [ (Smalltalk ui icons iconNamed: #dirtyMonticelloPackageIcon) ] ifNotEmpty: [ (Smalltalk ui icons iconNamed: #dirtyPackageIcon) ]); color: Color transparent; extent: 15 @ 16; helpText: 'Save the package'; borderWidth: 0. PackagesIconsCache at: aPackage put: (IconicButtonStateHolder forNautilus: icon). ^ icon ]. (mcpackage notNil and: [(mcpackage name = aPackage name ) and: [ aPackage definedClasses isEmpty]]) ifTrue: [ ^ PackagesIconsCache at: aPackage put: (Smalltalk ui icons iconNamed: #monticelloPackageIcon) ]. ^ PackagesIconsCache at: aPackage put: (Smalltalk ui icons iconNamed: #packageIcon)! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! selectedClassWithoutChangingSelection: aClass ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! extensionColor ^ Color gray darker! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'EstebanLorenzano 1/30/2013 14:37'! setSourceCodeShorcutsTo: aList aList attachKeymapCategory: #NautilusSourceCodeShortcuts targetting: self! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! showInstance ^ self model showInstance! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'EstebanLorenzano 10/9/2013 16:18'! browseClass: aClass self showGroups: false. self selectedPackage: (self parentOfClass: aClass). self selectedClass: aClass. self updateBothView! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'DamienCassou 3/26/2013 16:28'! getClassHierarchy2 ^ self selectedPackage ifNil: [{}] ifNotNil:[:package | cachedHierarchy := self buildPackageHierarchyFor: package. cachedHierarchy sortedElements]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! currentDisplayChoice ^ currentDisplayChoice ifNil: [ currentDisplayChoice := self sourceCodeSymbol ]! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: ''! announce: anAnnouncement ^ self model announce: anAnnouncement! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! defaultMethodSource ^ 'message selector and argument names "comment stating purpose of message" | temporary variable names | statements'! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! ifGroups: aBlock ifNot: anotherBlock ^self showGroups ifTrue: aBlock ifFalse: anotherBlock! ! !AbstractNautilusUI methodsFor: 'initialization' stamp: 'StephaneDucasse 8/29/2013 22:18'! initialize super initialize. cachedHierarchy := SortHierarchically new. groupsSelection := Dictionary new. packagesSelection := Dictionary new. classesSelection := Dictionary new. shouldUpdateTitle := true. testSemaphore := Semaphore new. sourceTextAreas := OrderedCollection new. contentSelection := nil. acceptor := ClassDefinitionAcceptor model: self. classifier := MethodClassifier new. ! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! buildTearDownCodeFor: aClass ^ String streamContents: [:str | str << 'tearDown';cr. str tab << '"Tearing down code for '< nil). ^ sourceTextArea ! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'GuillermoPolito 8/3/2012 13:22'! classRenamed: anAnnouncement | class | class := anAnnouncement classRenamed. window ifNil: [ ^ self]. window isDisplayed ifFalse: [ ^ self ]. ((self showGroups and: [ self selectedGroup elements includes: class ]) or: [ self getList2 includes: class ]) ifTrue: [ self updateClassView ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 02:13'! findClass "Search for a class from a pattern or from the recent list" self findClass: (SearchFacade classSearchInEnvironment: self browsedEnvironment).! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/23/2012 19:59'! selected2 | item | item := self selectedClass. self showInstance ifFalse: [ item ifNotNil: [item := item theNonMetaClass]]. ^self getList2 indexOf: item.! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! moveInNewPackage "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | item | self okToChange ifFalse: [^ self]. item := self moveInNewPackage: (self selectedClasses collect: [:e | e theNonMetaClass ]). item ifNotNil: [ self selectedPackage: item ]. self updateBothView! ! !AbstractNautilusUI methodsFor: 'protocol' stamp: ''! forceSelection: anObject! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'MarcusDenker 5/4/2013 10:12'! runTestsOfClass: aClass notifying: aBoolean | methods blockToEvaluate | methods := aClass methods select: [ :method | method isTestMethod ] thenCollect: [:e | e selector ]. blockToEvaluate := [ |result | aClass resetHistory. result := (aClass addToSuite: TestSuite new fromMethods: methods) run. result updateResultsInHistory. ClassesIconsCache removeKey: aClass ifAbsent: []. testSemaphore signal. ]. aBoolean ifTrue: [ blockToEvaluate forkAt: Processor userBackgroundPriority ] ifFalse: [ blockToEvaluate value ]. testSemaphore wait. aBoolean ifTrue: [ | color | aClass hasPassedTest ifTrue: [ color := Color green ]. aClass hasFailedTest ifTrue: [ color := Color yellow ]. aClass hasErrorTest ifTrue: [ color := Color red ]. self notifyTitle: 'Test Finished' contents: 'Class: ', aClass name color: color ]! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 3/23/2012 19:21'! doubleClick2 self doubleClickOnClass! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'BenjaminVanRyseghem 11/28/2013 16:43'! buildSecondColumn: aWindow | buttons | buttons := PanelMorph new. buttons changeProportionalLayout; addMorph: self buildInstanceButton fullFrame: ( (0@0 corner: 0.5@0 ) asLayoutFrame bottomRightOffset: -2@25 ); addMorph: self buildCommentButton fullFrame: (( 0.5@0 corner: 1@0 ) asLayoutFrame topLeftOffset: 2@0 ; bottomRightOffset: 0@25 ); hResizing: #spaceFill; vResizing: #rigid; height: 25. ^PanelMorph new changeProportionalLayout; addMorph: self buildList2 fullFrame: (LayoutFrame identity bottomOffset: -29); addMorph: buttons fullFrame: ( (0@1 corner: 1@1 ) asLayoutFrame topOffset: -25); hResizing: #spaceFill; vResizing: #spaceFill; yourself.! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 5/28/2013 14:13'! asYetUnclassifiedString ^ Protocol unclassified.! ! !AbstractNautilusUI methodsFor: 'list selections' stamp: 'BenjaminVanRyseghem 4/17/2012 16:44'! listSelectionAt: anIndex | elt | elt := self getList at: anIndex ifAbsent: [ ^ false ]. ^ (self listSelection at: elt ifAbsent: [ false ]) == true! ! !AbstractNautilusUI methodsFor: 'icons behavior' stamp: 'MarcusDenker 9/27/2013 18:05'! saveDirtyPackages: aCollection aCollection isEmptyOrNil ifTrue: [ ^ self ]. aCollection do: [:package || workCopy browser | workCopy := MCWorkingCopy forPackage: (MCPackage named: package name). browser :=MCWorkingCopyBrowser new. browser show; workingCopy: workCopy. "wrap := MCDependentsWrapper with: workCopy model: browser. self halt. index := browser workingCopySelectionWrapper: wrap. browser workingCopyTreeMorph selectionIndex: index"] ! ! !AbstractNautilusUI methodsFor: 'item creation' stamp: 'EstebanLorenzano 5/14/2013 09:44'! buildSwitchToByteCodeButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: # switchToByteCodeButton; stateSelector: #showByteCode ; onImage: (Smalltalk ui icons iconNamed: #byteCodeSelectedIcon); offImage: (Smalltalk ui icons iconNamed: #byteCodeUnselectedIcon); pressedImage: (Smalltalk ui icons iconNamed: #byteCodePressedIcon); extent: 24@24; helpText: 'Show byteCode'; yourself.! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'MarcusDenker 9/27/2013 18:08'! packageCreated: anAnnouncement window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. self showGroups ifFalse: [ self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: ''! setClassShorcutsTo: aList aList attachKeymapCategory: #NautilusClassShortcuts targetting: self! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updatePackageViewAndMove listElements := nil. self changed: #listElement:! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! showSource ^ self currentDisplayChoice = self sourceCodeSymbol! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! byteCodeSymbol ^ #ByteCode! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! packageLabel ^'Packages'! ! !AbstractNautilusUI methodsFor: 'monticello announcements' stamp: 'EstebanLorenzano 4/14/2014 17:40'! mcPackageModified: anAnnouncement " handled when a package become dirty " | rpackages | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. rpackages := anAnnouncement package packageSet packages. rpackages isEmptyOrNil ifTrue: [ ^ self ]. (self model packages includesAnyOf: rpackages ) ifTrue: [ rpackages do: [:rpackage | PackagesIconsCache removeKey: rpackage ifAbsent: []]. self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/1/2012 19:46'! toggleShowComment self showComment: self showComment not. self changed: #commentButtonState! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'MarcusDenker 9/27/2013 18:08'! getGroupsKeyList | env | env := self browsedEnvironment. ^ env isSystem ifTrue: [ self groupsManager groups ] ifFalse: [ self groupsManager groups reject: [ :g | (g classes intersection: self model classes) isEmpty ] ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 4/14/2012 12:05'! addClass self selectedPackage ifNotNil: [:package | self addClassIn: package ]! ! !AbstractNautilusUI methodsFor: 'item creation' stamp: 'EstebanLorenzano 5/14/2013 09:44'! buildBrowseClassVarsButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: #browseClassVars; stateSelector: #isAClassSelected ; onImage: (Smalltalk ui icons iconNamed: #classVarsSelectedIcon); offImage: (Smalltalk ui icons iconNamed: #classVarsUnselectedIcon); pressedImage: (Smalltalk ui icons iconNamed: #classVarsPressedIcon); extent: 24@24; helpText: 'Show class variables'; yourself.! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:02'! restrictedBrowseSuperclasses self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self restrictedBrowseClasses: class withAllSuperclasses ]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'GiselaDecuzzi 6/28/2013 12:24'! showInstance: aBoolean self okToChange ifTrue:[ self model showInstance: aBoolean. classesSelection removeAll. self selectedClass ifNotNil: [:class | aBoolean ifTrue: [self selectedClass: class theNonMetaClass. acceptor := ClassOrMethodDefinitionAcceptor model: self ] ifFalse: [self selectedClass: class theMetaClass. acceptor := ClassDefinitionAcceptor model: self ]]. self update. self changed: #instanceButtonState. self changed: #instanceButtonLabel ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! forceGenerateInitialize self selectedClass ifNotNil: [:class || code index | (class isMeta not and: [class inheritsFrom: TestCase]) ifTrue: [ index := 34. code := self buildSetUpCodeFor: class. class compile: code classified: 'initialization'. code := self buildTearDownCodeFor: class. class compile: code classified: 'initialization'. self selectedMethod: (class>>#setUp) ] ifFalse: [ index := 62. code := self buildInitializeCodeFor: class. class compile: code classified: 'initialization' . self selectedMethod: (class>>#initialize) ]. self update. self giveFocusTo: sourceTextArea. sourceTextArea selectFrom: index+class name size to: index-1+class name size ].! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: ''! toggleButtonAction self toggleButtonEnabled ifTrue: [ self toggleShowPackages. self changed: #toggleButtonEnabled. ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'MarcusDenker 9/27/2013 18:01'! testCaseStarted: anAnnouncement | class selector | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement testCase class. selector := anAnnouncement testSelector. self selectedClass = class ifTrue: [| method icon | icon := Smalltalk ui icons iconNamed: #testNotRunIcon. method := class methodNamed: selector. self methodWidget setIcon: icon for: method; updateList ]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! window ^ window! ! !AbstractNautilusUI methodsFor: 'item creation' stamp: 'EstebanLorenzano 5/14/2013 09:44'! buildBrowseInstVarsButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: #browseInstVars; stateSelector: #isAClassSelected ; onImage: (Smalltalk ui icons iconNamed: #instVarsSelectedIcon); offImage: (Smalltalk ui icons iconNamed: #instVarsUnselectedIcon); pressedImage: (Smalltalk ui icons iconNamed: #instVarsPressedIcon); extent: 24@24; helpText: 'Show instance variables'; yourself.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! showPackagesSilently: aBoolean self model showPackages: aBoolean.! ! !AbstractNautilusUI methodsFor: 'group' stamp: ''! addPackagesInGroup: aCollection aCollection ifNotEmpty: [:packages || classes | classes := packages gather: [:package | package classes ]. (DialogGroupAdder new groups: self groupsManager; elementsToAdd: (self model classes intersection: classes)) open]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! listSize2 ^ self getList2 size.! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! selectedMethodComments ^ self selectedMethod comment! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 10/10/2013 16:52'! findClass: aSearchInstance "select the class returned by the search block" | aClass | self okToChange ifFalse: [^ self flashPackage ]. aClass := aSearchInstance chooseFromOwner: self window. aClass ifNil: [^ self flashPackage]. self showGroups: false. self selectedPackage: (self parentOfClass: aClass). self selectedClass: aClass. self updateBothView! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'NicolaiHess 12/18/2013 22:11'! renameGroup | group | group := self selectedGroup. group ifNil: [ ^ self ]. [self groupsManager renameAGroup: group ] on: GroupAlreadyExists do:[ :ex | self alertGroupExisting: ex groupName ]. self updateBothView! ! !AbstractNautilusUI methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 4/18/2012 13:16'! selectedClassOrMetaClass ^ self selectedClass! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updatePackageView | scroll | listElements := nil. scroll := list scrollValue y. self changed: #listElement:. list vScrollValue: scroll! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! methodHierarchy "Create and schedule a method browser on the hierarchy of implementors." self methodHierarchyFrom: self selectedMethod! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: ''! unregisterAPlugin: aPlugin self announcer unsubscribe: aPlugin! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! selectedGroup ^ self model selectedGroup! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/8/2013 16:35'! highlight: autoSelectString | first | first := sourceTextArea getText findString: autoSelectString. contentSelection := first to: first+autoSelectString size-1. self changed: #sourceCodeFrom:! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/23/2012 18:57'! changedLabels "firstColumn label: self labelText." "secondColumn label: self labelText2."! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'YuriyTymchuk 12/20/2013 11:15'! classIconFor: aClass ClassesIconsCache at: aClass ifPresent: [:icon | icon class == IconicButtonStateHolder ifFalse: [ ^ icon ]. ^ icon asIconTargetting: self ]. ((aClass includesBehavior: (Smalltalk globals at: #TestCase ifAbsent: [ false ])) and: [ aClass isAbstract not ]) ifTrue: [ | icon button | icon := Smalltalk ui icons iconNamed: #testNotRunIcon. aClass hasPassedTest ifTrue: [ icon := Smalltalk ui icons iconNamed: #testGreenIcon ]. aClass hasFailedTest ifTrue: [ icon := Smalltalk ui icons iconNamed: #testYellowIcon ]. aClass hasErrorTest ifTrue: [ icon := Smalltalk ui icons iconNamed: #testRedIcon ]. button := IconicButton new target: self; actionSelector: #runTestsOfClass:notifying:; arguments: { aClass. true }; labelGraphic: icon ; color: Color transparent; extent: 12 @ 12; helpText: 'Run the tests'; borderWidth: 0. ClassesIconsCache at: aClass put: (IconicButtonStateHolder forNautilus: button). ^ button ] ifFalse: [ (aClass organization classComment isEmpty and: [ Nautilus emptyCommentWarning ]) ifTrue: [| button | button := IconicButton new target: self; actionSelector: #openCommentEditor:; arguments: { aClass }; labelGraphic: (Smalltalk ui icons iconNamed: #uncommentedClassIcon) ; color: Color transparent; extent: 12 @ 12; helpText:'Edit the comment'; borderWidth: 0. ClassesIconsCache at: aClass put: (IconicButtonStateHolder forNautilus: button). ^ button ]]. ^ ClassesIconsCache at: aClass put: (aClass systemIcon)! ! !AbstractNautilusUI methodsFor: 'icon caches' stamp: ''! methodsIconsCache ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: ''! clearUserEditFlag self changed: #clearUserEdits! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! listElement2: anIndex ^ self getList2 at: anIndex! ! !AbstractNautilusUI methodsFor: 'item creation' stamp: 'EstebanLorenzano 5/14/2013 09:44'! buildSwitchToSourceCodeButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: # switchToSourceCodeButton; stateSelector: #showSource ; onImage: (Smalltalk ui icons iconNamed: #sourceSelectedIcon); offImage: (Smalltalk ui icons iconNamed: #sourceUnselectedIcon); pressedImage: (Smalltalk ui icons iconNamed: #sourcePressedIcon); extent: 24@24; state: #on; helpText: 'Show source code'; yourself.! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! listElement: anIndex ^ self getList at: anIndex! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/13/2012 21:36'! changed: aSymbol super changed: aSymbol. self announce: (NautilusChanged symbol: aSymbol)! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! commonPragma ^'nautilusGlobalCommonMenu'! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: ''! sourceCodeMenuBuilder ^ PragmaMenuBuilder pragmaKeyword: self sourceCodePragma model: self! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 11/27/2013 14:05'! restrictedBrowsePackage self selectedPackages ifEmpty: [ ^ self ] ifNotEmpty: [ :packages | ^ self restrictedBrowsePackages: packages ]! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'CamilleTeruel 5/13/2013 17:26'! rebuildIconicButtonFrom: icon ^ IconicButton new target: icon target; actionSelector: icon actionSelector; arguments: icon arguments; labelGraphic: icon labelGraphic; color: icon color; helpText: icon helpText; extent: icon extent; borderWidth: icon borderWidth! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'NicolaiHess 12/26/2013 12:02'! addComment: aText notifying: aController self selectedClass ifNil: [ self selectedPackage ifNotNil: [:package | "commentTextArea update: #clearUserEdits. package comment: aText"]] ifNotNil: [:class | commentTextArea update: #clearUserEdits. class comment: aText stamp: Author changeStamp]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! browseClassRefs self browseClassRefsOf: self selectedClass.! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'CamilloBruni 9/21/2012 13:47'! close window close! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! toggleShowInstance ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/4/2012 01:07'! sourceCodeFrom: aTextMorph aTextMorph ifLocked: [ ^ aTextMorph textMorph text ]. ^ self sourceCode! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! getPackagesList ^ self model packages sort: [:a :b | a name <= b name ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! getClassesList2 ^ self model packagesUsedByTheSelectedClass! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! groupFixPragma ^'nautilusGlobalGroupFixMenu'! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! warningLimit ^ self model ifNil: [ 350 ] ifNotNil: [:mod | model warningLimit ]! ! !AbstractNautilusUI methodsFor: 'monticello announcements' stamp: 'EstebanLorenzano 4/14/2014 17:40'! mcWorkingCopyDeleted: anAnnouncement | package rpackages | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. package := anAnnouncement package. package ifNil: [ ^ self ]. rpackages := package packageSet packages. rpackages isEmptyOrNil ifTrue: [ ^ self ]. rpackages do: [:rpackage | PackagesIconsCache removeKey: rpackage ifAbsent: []]. self updatePackageView! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: ''! dropInAClass: aCollection into: aClass aCollection do: [:anObject | (anObject isBehavior) ifFalse: [ (anObject isString or: [ anObject isSymbol ]) ifTrue: ["category" ActiveHand shiftPressed ifTrue: [ self copyCategory: anObject toTheClass: aClass ] ifFalse: [ self moveCategory: anObject toTheClass: aClass ]] ifFalse: [ "a method" ActiveHand shiftPressed ifTrue: [ self copyMethod: anObject toTheClass: aClass ] ifFalse: [ self moveMethod: anObject toTheClass: aClass autoRemove: false ]]]]! ! !AbstractNautilusUI methodsFor: 'group' stamp: ''! addMatchingPackagesInGroupsAndBrowse ( self addMatchingPackagesInGroups ) ifNotNil: [:group | self selectedGroup: group. self showGroups: true]! ! !AbstractNautilusUI methodsFor: 'test creation' stamp: ''! generateCommentForTestClass: testClass from: aClass ^ String streamContents: [:stream || name | name := testClass name. name first isVowel ifTrue: [ stream << 'An '] ifFalse:[ stream <<'A ']. stream << name << ' is a test class for testing the behavior of '<< aClass name ]! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/28/2012 15:18'! openShortcutDescription KMDescription new categories: #(NautilusGlobalShortcuts "NautilusClassShortcuts NautilusSourceCodeShortcuts NautilusPackageShortcuts NautilusProtocolShortcuts NautilusMethodShortcuts") sort; openWithSpec! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: 'MarcusDenker 11/21/2013 13:36'! toggleButtonEnabled ^ self selectedClass notNil or: [ self showPackages not ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! commentLabel ^ 'Comments'! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'StephaneDucasse 9/7/2013 13:10'! newGroupBoxMorph | morph | morph := GroupboxMorph new. morph contentMorph layoutInset: (Margin left: 0 top: 0 right: 0 bottom: 0); cellInset: 0. ^ morph! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/18/2012 09:43'! selectedClass | class | class := self model selectedClass. (self model selectedCategory isNil and: [ self model selectedMethod isNil ]) ifTrue: [ self setStylerClass: nil ] ifFalse: [ self setStylerClass: class ]. ^ class! ! !AbstractNautilusUI methodsFor: 'menu-packages' stamp: 'EstebanLorenzano 2/21/2014 12:42'! demoteSelectedPackageAsPackageWithTag self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'SeanDeNigris 2/5/2013 10:12'! renamePackage self renamePackages: self selectedPackages. cachedHierarchy := self buildPackageHierarchyFor: self selectedPackage. self updatePackageView. ! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: ''! groupsButtonAction self toggleShowGroups! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:24'! packagePragma ^ 'nautilusGlobalPackageMenu'! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'EstebanLorenzano 2/6/2013 17:30'! setShortcuts: groupSymbol to: aMorph aMorph attachKeymapCategory: ( Nautilus useOldStyleKeys ifTrue: [ groupSymbol ] ifFalse: [ #NautilusGlobalShortcuts ]) targetting: self ! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 14:07'! openSuperclass "Search for a superclass of the selected class from a pattern or from the recent list" self selectedClass ifNotNil: [ :class| self openClass: class superclass ].! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:04'! restrictedBrowseGroup self restrictedBrowseGroups: self selectedGroups! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! model ^ model! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 10/18/2013 16:43'! okToChangeBoth ^ self okToChange and: [ self okToChangeComment ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: ''! toggleButtonLabel ^ self showPackages ifTrue: [ 'Hierarchy' ] ifFalse: [ 'Flat' ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'BenjaminVanRyseghem 2/16/2013 15:27'! testRunned: anAnnouncement | collection class correspondingClass | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement testResult. correspondingClass := anAnnouncement testResult correspondingClass. collection := self getList2. (collection includesAnyOf: {class. correspondingClass}) ifTrue: [ self removeClassFromMethodsIconsCache: class. self removeClassFromMethodsIconsCache: correspondingClass. self updateClassView. self update ].! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 4/6/2012 16:02'! removeGroups self okToChange ifFalse: [ ^ self ]. self selectedGroups ifNotEmpty:[:groups | groupsSelection removeAll. groups do: [:group | self groupsManager removeAGroupSilently: group ]. self selectedGroup: nil]. ! ! !AbstractNautilusUI methodsFor: 'icon caches' stamp: ''! removeFromPackagesIconsCache: aPackage PackagesIconsCache removeKey: aPackage ifAbsent: [].! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 8/1/2012 19:13'! setCommentShorcutsTo: aList aList attachKeymapCategory: #NautilusCommentShortcuts targetting: self! ! !AbstractNautilusUI methodsFor: 'monticello announcements' stamp: ''! newMCVersion: anAnnouncement | rpackage | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. rpackage := anAnnouncement version package correspondingRPackage. rpackage ifNil: [ ^ self ]. ( self model packages includes: rpackage ) ifTrue: [ self removeFromPackagesIconsCache: rpackage. self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'icon caches' stamp: 'MarcusDenker 10/2/2013 20:16'! removeClassFromMethodsIconsCache: aClass self methodsIconsCache keysDo: [:method | " for overrides " method methodClass = aClass ifTrue: [ self removeFromClassesIconsCache: aClass. self methodsIconsCache removeKey: method ifAbsent: [ ]]].! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! buildSetterFor: aString ^ aString withFirstCharacterDownshifted, ': anObject ', aString, ' := anObject'! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! runClassTests: aCollection notifying: aBoolean (aCollection allSatisfy: [:each | each inheritsFrom: TestCase ]) ifFalse: [ ^ self ]. aCollection ifNotEmpty:[:classes | classes do: [:class | self runTestsOfClass: class notifying: aBoolean ]]! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:28'! dragTransferTypeForMorph: dragSource ^(dragSource isKindOf: PluggableListMorph) ifTrue: [ dragSource getListElementSelector ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/17/2012 15:44'! openDialogWouldYouInstall: aMethod into: aClass "open a dialog to ask user if he wants to override the existing method or not" ^ UIManager default confirm: 'Are you sure you want to override the method ', aMethod selector, ' in ', aClass name label: 'Override' ! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenComan 12/28/2013 11:48'! setCachedHierarchyClass: aClass | classesToBuild | model showInstance ifTrue: [ classesToBuild := (aClass withAllSuperclasses, aClass allSubclasses) select: [ :class | class isClassSide not ] ] ifFalse: [ classesToBuild := (aClass class withAllSuperclasses, aClass class allSubclasses) select: [ :class | class isClassSide ] ]. cachedHierarchy := SortHierarchically buildHierarchyForClasses: classesToBuild.! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/8/2013 16:22'! resetContentsSelectionFrom: aTextMorph contentSelection at: aTextMorph put: (self contentSelectionFor: aTextMorph)! ! !AbstractNautilusUI methodsFor: 'icon caches' stamp: ''! removeFromMethodsIconsCache: aMethod " if a test method has changed, we should reset the correspondng method " | corresponding | corresponding := aMethod correspondingMethods. corresponding do: [:each | self methodsIconsCache removeKey: each ifAbsent: []]. self removeFromClassesIconsCache: aMethod methodClass. self methodsIconsCache removeKey: aMethod ifAbsent: [ ].! ! !AbstractNautilusUI methodsFor: 'announcement registration' stamp: 'EstebanLorenzano 5/3/2013 12:01'! registerToSystemAnnouncements self browsedEnvironment packageOrganizer announcer weak on: RPackageCreated send: #packageCreated: to: self; on: RPackageUnregistered send: #packageUnregistred: to: self; on: RPackageRenamed send: #packageRenamed: to: self. SystemAnnouncer uniqueInstance weak on: ClassAdded send: #classAdded: to: self; on: ClassCommented send: #classCommented: to: self; on: ClassRecategorized send: #classRecategorized: to: self; on: ClassModifiedClassDefinition send: #classDefinitionModified: to: self; on: ClassRemoved send: #classRemoved: to: self; on: ClassRenamed send: #classRenamed: to: self; on: ClassReorganized send: #classReorganized: to: self; on: MethodAdded send: #methodAdded: to: self; on: MethodModified send: #methodModified: to: self; on: MethodRecategorized send: #methodRecategorized: to: self; on: MethodRemoved send: #methodRemoved: to: self; on: ProtocolAdded send: #classReorganized: to: self; on: ProtocolRemoved send: #classReorganized: to: self. ! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! addTrait self selectedPackage ifNotNil: [:package | self addTraitIn: package ] " No need of update, announcements will do the job "! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 2/26/2013 18:59'! listMouseDown: anEvent self showPackages ifFalse: [ self showPackages: true. list mouseDown: anEvent ]. ! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! giveFocusTo: aMorph self hasFocus ifTrue: [aMorph takeKeyboardFocus]! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! isAClassSelected ^ self selectedClass notNil! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 4/6/2012 16:45'! addPackagesAsGroupsAndBrowse (self addPackagesAsGroups: self selectedPackages) ifNotNil: [:group | self selectedGroup: group. self showGroups: true]! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! sourceCodePragma ^ 'nautilusGlobalSourceCodeMenu'! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! showPackages ^ self model showPackages! ! !AbstractNautilusUI methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 17:57'! giveFocusToPackage self giveFocusTo: list! ! !AbstractNautilusUI methodsFor: 'dispatch' stamp: 'CamilloBruni 10/7/2012 23:27'! basicRenameClass: aClass self renameClass: aClass! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:56'! selectedPackageWithoutChangingSelectionInternally: aPackage | class | class := self selectedClass. (self showPackages and: [class notNil and: [class package ~= aPackage]]) ifTrue: [ self selectedClass: nil ]. packagesSelection at: aPackage put: true. aPackage ifNotNil: [ self giveFocusTo: list ]. self updateClassView. self update. self changed: #getComments. self changed: #sourceCodeFrom:! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: ''! doubleClickOnClass self selectedClass ifNil: [ ^ self ] ifNotNil: [:class | self showGroups ifTrue: [ self model class openOnClass: class onGroup: self selectedGroup ] ifFalse: [ self model class openOnClass: class ]]! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'StephaneDucasse 8/29/2013 20:58'! moveCategory: anObject toTheClass: aClass | originClass methods | originClass := self selectedClass. methods := originClass methodsInProtocol: anObject. methods do: [:meth | self moveMethod: meth toTheClass: aClass autoRemove: true ]. (originClass methodsInProtocol: anObject) ifEmpty: [ originClass removeProtocol: anObject. self selectedCategory: nil ].! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'MarcusDenker 10/24/2013 11:20'! packageUnregistred: anAnnouncement | package | self showGroups ifTrue: [ ^ self ]. package := anAnnouncement package. self selectedPackage = package ifTrue: [ self selectedPackage: nil ]. packagesSelection at: package put: false. window isDisplayed ifFalse: [ ^ self ]. self updatePackageView! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! showGroups ^ self model showGroups! ! !AbstractNautilusUI methodsFor: 'list selections' stamp: ''! listSelection2At: anIndex | elt | elt := self getList2 at: anIndex ifAbsent: [ ^false ]. ^ self listSelection2 at: elt ifAbsent: [ false ]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! groupsManager ^ self model groupsManager! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: ''! removeEmptyCategories self okToChange ifFalse: [^ self]. (self methodsForCategory: self selectedCategory) ifEmpty: [ self selectedCategory: nil ]. self removeEmptyCategoriesFrom: self selectedClass. self update.! ! !AbstractNautilusUI methodsFor: 'test creation' stamp: ''! buildTestPackageNameFrom:aClass ^ aClass package name asString, '-Tests' ! ! !AbstractNautilusUI methodsFor: 'widget needed methods' stamp: ''! selectedMethod: aMethod ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menu-packages' stamp: 'EstebanLorenzano 2/19/2014 16:32'! promoteSelectedPackageTagAsPackage self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'private' stamp: ''! title ^'Nautilus'! ! !AbstractNautilusUI methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 4/14/2012 13:31'! dropInList2: aCollection inARow: aRow | receiver | receiver := self getList2 at: aRow. self showInstance not ifTrue: [ receiver := receiver theMetaClass ] ifFalse: [ receiver := receiver theNonMetaClass ]. self dropInAClass: aCollection into: receiver! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'MarcusDenker 11/21/2013 13:36'! removePackages | names | self selectedPackages ifNotEmpty: [:packages | names := packages collect: [:package | package name ]. names := names joinUsing: String cr. (UIManager default confirm: ('Are you sure you want to delete the package(s) named ', String cr, names, ' and their classes ?')) ifTrue: [| scroll | packages do: [:package | package definedClasses do:[: classToRemove | classToRemove subclasses notEmpty ifTrue: [ | message | message := 'Are you certain that you want to REMOVE the class ', classToRemove name, ' from the system?'. (self confirm: 'class has subclasses: ' , message) ifFalse: [^ false]]. classToRemove removeFromSystem ]. self browsedEnvironment packageOrganizer unregisterPackage: package ]. scroll := list scrollValue y . self selectedPackage: nil. self updatePackageView. list vScrollValue: scroll ]]! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 13:35'! browseSuperclassOf: class ^ self browseClass: class superclass! ! !AbstractNautilusUI methodsFor: 'widget needed methods' stamp: ''! selectedCategory: anObject ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: 'NicolaiHess 1/19/2014 12:21'! groupsButtonLabel ^ ((self showGroups) and:[self groupsAreVisible]) ifTrue: [ self packageLabel ] ifFalse: [ self groupsLabel ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'johanfabry 1/20/2014 11:29'! selectedClassDescription ^ self selectedClass definitionForNautilus ! ! !AbstractNautilusUI methodsFor: 'item creation' stamp: 'BenjaminVanRyseghem 4/3/2014 13:46'! buildSeparator ^ Morph new height: 8; width: 0; color: Color transparent.! ! !AbstractNautilusUI methodsFor: 'group' stamp: ''! addClassesInGroup self selectedClasses ifNotNil: [:classes | self addClassesInGroup: classes ].! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/3/2013 14:52'! listWrapper2: anElement "anElement is a Class" ^ self showHierarchy ifTrue: [ self buildTabbedNameOf: anElement ] ifFalse: [ self selectedPackage ifNil: [anElement name] ifNotNil: [ :package | (package includesClass: anElement) ifTrue: [ anElement name asStringMorph ] ifFalse: [ anElement name asStringMorph color: self extensionColor;yourself]]]! ! !AbstractNautilusUI methodsFor: 'icons behavior' stamp: ''! arrowUp: aMethod | newMethod | newMethod := aMethod methodClass superclass lookupSelector: aMethod selector. self model class openOnMethod: newMethod! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: 'StephanEggermont 3/26/2014 18:05'! showClassVarsButtonLabel ^' C' ! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 01:48'! findSuperclass "Search for a superclass of the selected class from a pattern or from the recent list" self selectedClass ifNotNil: [ :class| self findClass: (SearchFacade superclassSearchFor: class theNonMetaClass)].! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: ''! selectedGroupWithoutChangingSelection: anObject self okToChange ifTrue: [ anObject ifNil: [ groupsSelection removeAll ]. self model selectedGroup: anObject. groupsSelection at: anObject put: true. self selectedClass: nil. self updateClassView ]! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'CamilloBruni 5/7/2013 23:35'! debugMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #DebugMenu) order: 9999; label: 'DEBUG'. (aBuilder item: #'Reset icon cache') order: 0; action: [ AbstractNautilusUI resetIconCaches. AbstractMethodWidget resetMethodIconCache ]; parent: #DebugMenu. (aBuilder item: #'Inspect me') order: 100; action: [ target inspect ]; parent: #DebugMenu. (aBuilder item: #'Inspect my model ') order: 200; action: [ target model inspect]; parent: #DebugMenu.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 15:20'! sourceCodeMenuExtra: aBuilder | target method | target := aBuilder model. target selectedClass ifNil: [ ^ self ]. method := target selectedMethod. ((target selectedClass inheritsFrom: TestCase) and: [ method notNil and: [ method selector beginsWith: 'test' ]]) ifTrue: [ (aBuilder item: #'Run Test') order: 1; keyText: 'j, m' if: Nautilus useOldStyleKeys not; action: #runTestForAMethod:notifying:; arguments: { target selectedMethod. true }; enabledBlock: [ target sourceTextArea hasUnacceptedEdits not ]; withSeparatorAfter ].! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'StephaneDucass 2/2/2014 09:01'! classesFixMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Find Method...') keyText: 'f, m' if: Nautilus useOldStyleKeys not; keyText: 'f' if: Nautilus useOldStyleKeys; action: [target findMethod]; order: 100; help: 'Search for a method by selector'. (aBuilder item: #'Find Class...') keyText: 'f, c' if: Nautilus useOldStyleKeys not; keyText: 'F' if: Nautilus useOldStyleKeys; action: [ target findClass ]; order: 200; help: 'Search for a method by selector'. (aBuilder item: #'Add Class...') keyText: 'n, c' if: Nautilus useOldStyleKeys not; keyText: 'n' if: Nautilus useOldStyleKeys; action: [ target addClass ]; order: 400; help: 'Create a new class'. (aBuilder item: #'Add full Class...') action: [ target addFullClass ]; order: 400; help: 'Propose full class definition'. (aBuilder item: #'Add Trait...') action: [ target addTrait ]; order: 500; withSeparatorAfter. (aBuilder item: #'Browse full') keyText: 'b, f' if: Nautilus useOldStyleKeys not; keyText: 'b' if: Nautilus useOldStyleKeys; action: [target fullBrowse]; order: 999; help: 'Open the same browser'.! ! !AbstractNautilusUI class methodsFor: 'icon' stamp: 'EstebanLorenzano 5/14/2013 12:00'! resetIconCaches ClassesIconsCache removeAll. GroupsIconsCache removeAll. PackagesIconsCache removeAll. MethodWidget resetMethodIconCache.! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/18/2013 17:40'! classesIconsCache: anObject ClassesIconsCache := anObject! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: ''! groupsIconsCache ^ GroupsIconsCache! ! !AbstractNautilusUI class methodsFor: 'icon' stamp: 'EstebanLorenzano 5/10/2013 13:04'! resetClassesIconsCache ClassesIconsCache removeAll. ! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'StephaneDucasse 2/11/2014 10:58'! buildEditorCommentKeymappingsOn: aBuilder (aBuilder shortcut: #selectAll) category: #NautilusCommentShortcuts default: $a command do: [ :target | target commentTextArea handleEdit: [ target commentTextArea selectAll ] ]. (aBuilder shortcut: #copySelection) category: #NautilusCommentShortcuts default: $c command do: [ :target | target commentTextArea copySelection ]. (aBuilder shortcut: #find) category: #NautilusCommentShortcuts default: $f command, $f command do: [ :target | target commentTextArea find ]. (aBuilder shortcut: #findAgain) category: #NautilusCommentShortcuts default: $f command, $g command do: [ :target | target commentTextArea findAgain ]. (aBuilder shortcut: #setSearchString) category: #NautilusCommentShortcuts default: $h command do: [ :target | target commentTextArea setSearchString ]. (aBuilder shortcut: #cancel) category: #NautilusCommentShortcuts default: $l command do: [ :target | target commentTextArea cancelWithoutConfirmation ]. (aBuilder shortcut: #paste) category: #NautilusCommentShortcuts default: $v command do: [ :target | target commentTextArea paste ]. (aBuilder shortcut: #cut) category: #NautilusCommentShortcuts default: $x command do: [ :target | target commentTextArea cut ]. (aBuilder shortcut: #undo) category: #NautilusCommentShortcuts default: $z command do: [ :target | target commentTextArea undo ]. (aBuilder shortcut: #redo) category: #NautilusCommentShortcuts default: $z command shift do: [ :target | target commentTextArea redo ]. (aBuilder shortcut: #cursorHome) category: #NautilusCommentShortcuts default: Character home command do: [ :target :morph :event | target commentTextArea cursorHome: event ]. (aBuilder shortcut: #cursorEnd) category: #NautilusCommentShortcuts default: Character end command do: [ :target :morph :event | target commentTextArea cursorEnd: event ]. (aBuilder shortcut: #browseIt) category: #NautilusCommentShortcuts default: $b command do: [ :target | target commentTextArea browseIt ]. (aBuilder shortcut: #doIt) category: #NautilusCommentShortcuts default: $d command do: [ :target | target commentTextArea doIt ]. (aBuilder shortcut: #inspectIt) category: #NautilusCommentShortcuts default: $i command do: [ :target | target commentTextArea inspectIt ]. (aBuilder shortcut: #implementorsOfIt) category: #NautilusCommentShortcuts default: $m command do: [ :target | target commentTextArea implementorsOfIt ]. (aBuilder shortcut: #sendersOfIt) category: #NautilusCommentShortcuts default: $n command do: [ :target | target commentTextArea sendersOfIt ]. (aBuilder shortcut: #printIt) category: #NautilusCommentShortcuts default: $p command do: [ :target | target commentTextArea printIt ].! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'StephaneDucasse 2/11/2014 10:58'! buildEditorCommentKeymappingsOldOn: aBuilder (aBuilder shortcut: #selectAll) category: #NautilusCommentShortcuts default: $a command do: [ :target | target commentTextArea handleEdit: [ target commentTextArea selectAll ] ]. (aBuilder shortcut: #copySelection) category: #NautilusCommentShortcuts default: $c command do: [ :target | target commentTextArea copySelection ]. (aBuilder shortcut: #find) category: #NautilusCommentShortcuts default: $f command do: [ :target | target commentTextArea find ]. (aBuilder shortcut: #findAgain) category: #NautilusCommentShortcuts default: $g command do: [ :target | target commentTextArea findAgain ]. (aBuilder shortcut: #setSearchString) category: #NautilusCommentShortcuts default: $h command do: [ :target | target commentTextArea setSearchString ]. (aBuilder shortcut: #cancel) category: #NautilusCommentShortcuts default: $l command do: [ :target | target commentTextArea cancelWithoutConfirmation ]. (aBuilder shortcut: #paste) category: #NautilusCommentShortcuts default: $v command do: [ :target | target commentTextArea paste ]. (aBuilder shortcut: #cut) category: #NautilusCommentShortcuts default: $x command do: [ :target | target commentTextArea cut ]. (aBuilder shortcut: #undo) category: #NautilusCommentShortcuts default: $z command do: [ :target | target commentTextArea undo ]. (aBuilder shortcut: #redo) category: #NautilusCommentShortcuts default: $z command shift do: [ :target | target commentTextArea redo ]. (aBuilder shortcut: #cursorHome) category: #NautilusCommentShortcuts default: Character home command do: [ :target :morph :event | target commentTextArea cursorHome: event ]. (aBuilder shortcut: #cursorEnd) category: #NautilusCommentShortcuts default: Character end command do: [ :target :morph :event | target commentTextArea cursorEnd: event ]. (aBuilder shortcut: #browseIt) category: #NautilusCommentShortcuts default: $b command do: [ :target | target commentTextArea browseIt ]. (aBuilder shortcut: #doIt) category: #NautilusCommentShortcuts default: $d command do: [ :target | target commentTextArea doIt ]. (aBuilder shortcut: #inspectIt) category: #NautilusCommentShortcuts default: $i command do: [ :target | target commentTextArea inspectIt ]. (aBuilder shortcut: #implementorsOfIt) category: #NautilusCommentShortcuts default: $m command do: [ :target | target commentTextArea implementorsOfIt ]. (aBuilder shortcut: #sendersOfIt) category: #NautilusCommentShortcuts default: $n command do: [ :target | target commentTextArea sendersOfIt ]. (aBuilder shortcut: #printIt) category: #NautilusCommentShortcuts default: $p command do: [ :target | target commentTextArea printIt ].! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/28/2012 14:52'! buildAddShortcutsOn: aBuilder (aBuilder shortcut: #newClass) category: #NautilusGlobalShortcuts default: $n command ,$c command do: [ :target | target addClass ] description: 'Create a new class'. (aBuilder shortcut: #newPackage) category: #NautilusGlobalShortcuts default: $n command , $p command do: [ :target | target addPackage ] description: 'Create a new package'. (aBuilder shortcut: #newProtocol) category: #NautilusGlobalShortcuts default: $n command , $t command do: [ :target | target addCategory ] description: 'Create a new protocol'. (aBuilder shortcut: #newGroup) category: #NautilusGlobalShortcuts default: $n command , $g command do: [ :target | target addNewGroup ] description: 'Create a new group'. " (aBuilder shortcut: #newMethod) category: #NautilusGlobalShortcuts default: $n command , $m command do: [ :target | target addMethod ] description: 'Create a new method'."! ! !AbstractNautilusUI class methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 10/15/2013 18:36'! packageFixPragma ^ 'nautilusGlobalPackageFixMenu'! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: ''! groupsIconsCache: anObject GroupsIconsCache := anObject! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 10/9/2013 17:34'! groupsMenu: aBuilder | target | target := aBuilder model. target selectedGroup ifNil: [ ^ target ]. (aBuilder item: #'Browse scoped') keyText: 'b, s' if: Nautilus useOldStyleKeys not; action: [ target restrictedBrowseGroups: target selectedGroups ]; order: 1000; withSeparatorAfter. (aBuilder item: #'Run tests') keyText: 'j, g' if: Nautilus useOldStyleKeys not; keyText: 't' if: Nautilus useOldStyleKeys; action: [ target runTestsOfGroups: target selectedGroups notifying: true ]; order: 1100. (aBuilder item: #'Merge groups') action: [target mergeGroups]; enabledBlock: [ target selectedGroups size > 1]; order: 1200. target selectedGroup ifNotNil: [ target selectedGroup isReadOnly ifFalse: [ (aBuilder item: #'Rename...') keyText: 'r, g' if: Nautilus useOldStyleKeys not; keyText: 'r' if: Nautilus useOldStyleKeys; action: [ target renameGroup ]; enabledBlock: [ target selectedGroups size <= 1]; order: 1300 ]. target selectedGroup removable ifTrue: [ (aBuilder item: #'Remove groups') keyText: 'x, g' if: Nautilus useOldStyleKeys not; keyText: 'x' if: Nautilus useOldStyleKeys; icon: (Smalltalk ui icons iconNamed: #removeIcon); action: [target removeGroups]; order: 1400 ] ]! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: ''! packagesIconsCache: anObject PackagesIconsCache := anObject! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'CamilloBruni 10/4/2012 10:39'! buildGotoNavigationShortcutsOn: aBuilder (aBuilder shortcut: #jumpToClass) category: #NautilusGlobalShortcuts default: $g command , $c command do: [ :target | target giveFocusToClass ] description: 'Jump to the selected class'. (aBuilder shortcut: #jumpToPackage) category: #NautilusGlobalShortcuts default: $g command, $p command do: [ :target | target giveFocusToPackage ] description: 'Jump to the selected package'. (aBuilder shortcut: #jumpToProtocol) category: #NautilusGlobalShortcuts default: $g command , $t command do: [ :target | target giveFocusToProtocol ] description: 'Jump to the selected protocol'. (aBuilder shortcut: #jumpToMethod) category: #NautilusGlobalShortcuts default: $g command , $m command do: [ :target | target giveFocusToMethod ] description: 'Jump to the selected method'. (aBuilder shortcut: #jumpToSourceCode) category: #NautilusGlobalShortcuts default: $g command , $s command do: [ :target | target giveFocusToSourceCode ] description: 'Jump to the selected method'. (aBuilder shortcut: #jumpToTestClass) category: #NautilusGlobalShortcuts default: $g command , $j command , $c command do: [ :target | target createTestForSelectedClass ] description: 'Jump to test class'.! ! !AbstractNautilusUI class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 10/17/2013 13:55'! initialize " self initialize " ClassesIconsCache := WeakIdentityKeyDictionary new. GroupsIconsCache := WeakIdentityKeyDictionary new. PackagesIconsCache := WeakIdentityKeyDictionary new. NextFocusKey := Character arrowRight. PreviousFocusKey := Character arrowLeft. self registerSystemAnnouncements.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 14:48'! groupsFixMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Find Class...') keyText: 'f, c' if: Nautilus useOldStyleKeys not; keyText: 'f' if: Nautilus useOldStyleKeys; action: [target findClass]; order: 0; help: 'Search for a class by name'. (aBuilder item: #'New group...') keyText: 'n, g' if: Nautilus useOldStyleKeys not; keyText: 'n' if: Nautilus useOldStyleKeys; action: [target addNewGroup]; order: 100; withSeparatorAfter. (aBuilder item: #'Browse full') keyText: 'b, f' if: Nautilus useOldStyleKeys not; keyText: 'b' if: Nautilus useOldStyleKeys; action: [target fullBrowse]; order: 999.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/28/2012 14:54'! buildRemoveShortcutsOn: aBuilder (aBuilder shortcut: #removeClass) category: #NautilusGlobalShortcuts default: $x command ,$c command do: [ :target | target removeClasses ] description: 'Remove the selected classes'. (aBuilder shortcut: #removePackage) category: #NautilusGlobalShortcuts default: $x command , $p command do: [ :target | target removePackages ] description: 'Remove the selected packages'. (aBuilder shortcut: #removeProtocol) category: #NautilusGlobalShortcuts default: $x command , $t command do: [ :target | target removeCategories ] description: 'Remove the selected protocols'. (aBuilder shortcut: #removeMethod) category: #NautilusGlobalShortcuts default: $x command , $m command do: [ :target | target removeMethods ] description: 'Remove the selected methods'. (aBuilder shortcut: #removeGroups) category: #NautilusGlobalShortcuts default: $x command , $g command do: [ :target | target removeGroups ] description: 'Remove the selected groups'.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'SebastianTleye 8/30/2013 14:13'! buildRenameShortcutsOn: aBuilder (aBuilder shortcut: #renameClass) category: #NautilusGlobalShortcuts default: $r command ,$c command do: [ :target | target renameClass ] description: 'Rename the selected class'. (aBuilder shortcut: #renamePackage) category: #NautilusGlobalShortcuts default: $r command , $p command do: [ :target | target renamePackage ] description: 'Rename the selected package'. (aBuilder shortcut: #renameProtocol) category: #NautilusGlobalShortcuts default: $r command , $t command do: [ :target | target renameCategory ] description: 'Rename the selected protocol'. (aBuilder shortcut: #renameGroup) category: #NautilusGlobalShortcuts default: $r command , $g command do: [ :target | target renameGroup ] description: 'Rename the selected group'.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 14:39'! packagesFixMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Find Class...') keyText: 'f, c' if: Nautilus useOldStyleKeys not; keyText: 'f' if: Nautilus useOldStyleKeys; action: [target findClass]; order: 0; help: 'Search for a class by name'. (aBuilder item: #'Find Package...') keyText: 'f, p' if: Nautilus useOldStyleKeys not; keyText: 'F' if: Nautilus useOldStyleKeys; action: [ target findPackage ]; order: 100; help: 'Search for a package by name'; withSeparatorAfter. (aBuilder item: #'Add package...') keyText: 'n, p' if: Nautilus useOldStyleKeys not; keyText: 'n' if: Nautilus useOldStyleKeys; action: [target addPackage]; order: 200; help: 'Add a package'; withSeparatorAfter. (aBuilder item: #'Browse full') keyText: 'b, f' if: Nautilus useOldStyleKeys not; keyText: 'b' if: Nautilus useOldStyleKeys; action: [target fullBrowse]; order: 999; help: 'Open the same browser'.! ! !AbstractNautilusUI class methodsFor: 'instance creation' stamp: ''! on: aNautilus ^ self new model: aNautilus! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'SebastianTleye 8/30/2013 10:43'! analyzeSubMenu: aBuilder | target | target := aBuilder model. target selectedClass ifNil: [^target]. target selectedClass buildAnalyzeSubMenu: aBuilder.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'SebastianTleue 8/28/2013 10:53'! buildBrowseShortcutsOn: aBuilder (aBuilder shortcut: #browseSenders) category: #NautilusGlobalShortcuts default: $b command , $n command do: [:target | target browseSendersOfMessages ] description: 'Browse senders of the selected method'. (aBuilder shortcut: #browseClassRefs) category: #NautilusGlobalShortcuts default: $b command, $n command shift do: [ :target | target browseClassRefs ] description: 'Browse class references'. (aBuilder shortcut: #browseImplementors) category: #NautilusGlobalShortcuts default: $b command , $m command do: [:target | target browseMessages ] description: 'Browse implementors of the selected method'. (aBuilder shortcut: #browseRestricted) category: #NautilusGlobalShortcuts default: $b command , $s command do: [:target | target restrictedBrowse ] description: 'Open a restricted browser'. (aBuilder shortcut: #browseRestrictedClass) category: #NautilusGlobalShortcuts default: $b command , $r command , $c command do: [:target | target restrictedBrowseClass ] description: 'Open a restricted browser on the selected class'. (aBuilder shortcut: #browseSuperclass) category: #NautilusGlobalShortcuts default: $b command , $s command shift do: [:target | target browseSuperclass ] description: 'Open a browser on the superclass of the selected class'. (aBuilder shortcut: #browseRestrictedPackage) category: #NautilusGlobalShortcuts default: $b command , $r command , $p command do: [:target | target restrictedBrowsePackage ] description: 'Open a restricted browser on the selected package'. (aBuilder shortcut: #browseRestrictedRegex) category: #NautilusGlobalShortcuts default: $b command , $r command , $r command do: [:target | target restrictedBrowsePackageRegex ] description: 'Open a restricted browser on a package regex'. (aBuilder shortcut: #browseRestrictedSuperclasses) category: #NautilusGlobalShortcuts default: $b command , $r command , $S shift command do: [:target | target restrictedBrowseSuperclasses ] description: 'Open a restricted browser the superclasses'. (aBuilder shortcut: #browseRestrictedSubclasses) category: #NautilusGlobalShortcuts default: $b command , $r command , $s command do: [:target | target restrictedBrowseSubclasses ] description: 'Open a restricted browser the subclasses'. (aBuilder shortcut: #browseInheritance) category: #NautilusGlobalShortcuts default: $b command , $i command do: [:target | target methodHierarchy ] description: 'Open a restricted browser'. (aBuilder shortcut: #browseFull) category: #NautilusGlobalShortcuts default: $b command , $f command do: [:target | target fullBrowse ] description: 'Open the same browser'. (aBuilder shortcut: #browseVersion) category: #NautilusGlobalShortcuts default: $b command , $v command do: [:target | target browseVersions ] description: 'Browse senders of the selected method'. ! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/21/2014 12:42'! packagesMenu: aBuilder | package target | target := aBuilder model. (package := target selectedPackage) ifNil: [ ^ target ]. (aBuilder item: #'Browse scoped') keyText: 'b, s' if: Nautilus useOldStyleKeys not; action: [ target restrictedBrowsePackage ]; order: 1000; help: 'Open a browser on a restricted view'; withSeparatorAfter. (aBuilder item: #'Rename...') keyText: 'r, p' if: Nautilus useOldStyleKeys not; keyText: 'r' if: Nautilus useOldStyleKeys; action: [target renamePackage]; order: 1100; help: 'Rename a package'; enabledBlock: [ target selectedPackages size < 2 ]. (aBuilder item: #'Remove...') keyText: 'x, p' if: Nautilus useOldStyleKeys not; keyText: 'x' if: Nautilus useOldStyleKeys; action: [target removePackages ]; order: 1200; help: 'Remove a package'; icon: (Smalltalk ui icons iconNamed: #removeIcon). (aBuilder item: #'Run tests...') keyText: 'j, p' if: Nautilus useOldStyleKeys not; keyText: 't' if: Nautilus useOldStyleKeys; action: [target runPackagesTestsNotifying: true ]; enabled: (package classes anySatisfy: [:e | e inheritsFrom: TestCase ]); order: 1250; help: 'Run tests'; withSeparatorAfter. (aBuilder item: #'Promote as package') action: [ target promoteSelectedPackageTagAsPackage ]; enabled: package isPackageTag; order: 1260; help: 'Promote this package tag as one package'. (aBuilder item: #'Demote to package with tag') action: [ target demoteSelectedPackageAsPackageWithTag ]; enabled: (package isPackageTag not and: [ package name includes: $- ]); order: 1261; help: 'Downgrade this package as one package with a tag'; withSeparatorAfter. (aBuilder item: #'File Out') action: [target fileOutPackage]; order: 1300; help: 'File out a package'; withSeparatorAfter. target selectedPackages size > 1 ifTrue: [ (aBuilder item: #'Add as Groups & Browse') keyText: 'n, g' if: Nautilus useOldStyleKeys not; action: [ target addPackagesAsGroupsAndBrowse ]; order: 1400; help: 'Create a group based on the current package and browse it'. (aBuilder item: #'Add as Groups') keyText: 'n, G' if: Nautilus useOldStyleKeys not; action: [ target addPackagesAsGroups ]; order: 1600; help: 'Create a group based on the current package'. (aBuilder item: #'Add as Group') action: [target addPackageAsGroup]; order: 1700; help: 'Create a group based on the current package'. ] ifFalse: [ (aBuilder item: #'Add as Group & Browse') keyText: 'n, g' if: Nautilus useOldStyleKeys not; keyText: 'G' if: Nautilus useOldStyleKeys; action: [ target addPackageAsGroupAndBrowse ]; order: 1500; help: 'Create a group based on the current package and browse it'. (aBuilder item: #'Add as Group') keyText: 'n, G' if: Nautilus useOldStyleKeys not; action: [target addPackageAsGroup]; order: 1700; help: 'Create a group based on the current package' ]. (aBuilder item: #'Add Matching Packages as Groups and Browse') keyText: 'n, m' if: Nautilus useOldStyleKeys not; keyText: 'M' if: Nautilus useOldStyleKeys; action: [ target addMatchingPackagesInGroupsAndBrowse ]; order: 1800. (aBuilder item: #'Add in Group...') keyText: 'n, e, p' if: Nautilus useOldStyleKeys not; action: [target addPackagesInGroup]; order: 1900; help: 'Add current package in a group'; withSeparatorAfter.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'MarcusDenker 2/15/2013 14:03'! sourceCodeMenu: aBuilder | donorMenu items | items := OrderedCollection new. donorMenu := SmalltalkEditor yellowButtonMenu. donorMenu submorphs doWithIndex: [:each :index | (each isKindOf: MenuLineMorph) ifTrue: [ items last withSeparatorAfter ] ifFalse: [ items add: ((aBuilder item: each contents asSymbol) keyText: each keyText; selector: each selector; target: each target; arguments: each arguments; order: (index*100)). each icon ifNotNil: [:ic | items last icon: ic ]]]. (items last: 2) doWithIndex: [:e :i | e order: (9998 + i) ]. (aBuilder item: #'Lock this text area') selector: #lockTextArea; target: aBuilder model; order: 0.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'SebastianTleue 8/28/2013 11:40'! buildAddGroupsShortcutsOn: aBuilder (aBuilder shortcut: #newGroupAndBrowseForPackage) category: #NautilusGlobalShortcuts default: $n command ,$g command do: [ :target | target addPackagesAsGroupsAndBrowse ] description: 'Create a new group and browse'. (aBuilder shortcut: #newGroupForPackage) category: #NautilusGlobalShortcuts default: $n command , $g shift command do: [ :target | target addPackagesAsGroups ] description: 'Create a new group'. (aBuilder shortcut: #addInGroupPackage) category: #NautilusGlobalShortcuts default: $n command , $e command, $p command do: [ :target | target addPackagesInGroup ] description: 'Add the selected packages in a group'. (aBuilder shortcut: #addMethodsInGroup) category: #NautilusGlobalShortcuts default: $n command , $e command, $m command do: [ :target | target addMethodsInGroup ] description: 'Add the selected methods in a group'. "This shortcut was removed because this shortcut is the same for packages" "(aBuilder shortcut: #addProtocolsInGroup) category: #NautilusGlobalShortcuts default: $n command , $e command, $p command do: [ :target | target addProtocolsInGroup ] description: 'Add the selected protocols in a group'." (aBuilder shortcut: #addInGroupClass) category: #NautilusGlobalShortcuts default: $n command , $e command, $c command do: [ :target | target addClassesInGroup ] description: 'Add the selected classes in a group'. (aBuilder shortcut: #addMatchingAndBrowse) category: #NautilusGlobalShortcuts default: $n command , $m command do: [ :target | target addMatchingPackagesInGroupsAndBrowse ] description: 'Add packages matching the selected package as groups and browse'. (aBuilder shortcut: #addInGroupMethod) category: #NautilusGlobalShortcuts default: $n command , $m command shift do: [ :target | target addMatchingPackagesInGroups ] description: 'Add packages matching the selected package as groups'.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'CamilloBruni 1/11/2013 14:07'! buildExtraShortcutsOn: aBuilder (aBuilder shortcut: #openBrowser) category: #NautilusGlobalShortcuts default: $o command, $o command do: [:target| target fullBrowse ] description: 'Open a new browser'. (aBuilder shortcut: #openBrowserOnSubclass) category: #NautilusGlobalShortcuts default: $o command, $s command do: [:target| target openSubclass ] description: 'Open a new browser on a subclass'. (aBuilder shortcut: #openBrowserOnSuperclass) category: #NautilusGlobalShortcuts default: $o command, $s command shift do: [:target| target openSuperclass ] description: 'Open a new browser on a superclass'. (aBuilder shortcut: #openBrowserOnClass) category: #NautilusGlobalShortcuts default: $o command, $c command do: [:target| target openClass ] description: 'Open a new browser on a class'. ! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/24/2012 19:06'! buildCopyShortcutsOn: aBuilder (aBuilder shortcut: #copyClass) category: #NautilusGlobalShortcuts default: $c command , $c command do: [ :target | target copyClasses ] description: 'Copy the selected classes'.! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/24/2012 19:02'! buildRecategorizeShortcutsOn: aBuilder (aBuilder shortcut: #recategorizeMethod) category: #NautilusGlobalShortcuts default: $m command , $m command do: [ :target | target categorizeMethod ] description: 'Categorize the selected method'. (aBuilder shortcut: #recategorizeClass) category: #NautilusGlobalShortcuts default: $m command , $c command do: [ :target | target moveInNewPackage ] description: 'Categorize the selected class'.! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/25/2012 11:08'! previousFocusKey ^ PreviousFocusKey! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/1/2013 10:59'! shiftedSourceCodeMenu: aBuilder | donorMenu items | items := OrderedCollection new. donorMenu := SmalltalkEditor shiftedYellowButtonMenu. donorMenu submorphs doWithIndex: [:each :index | (each isKindOf: MenuLineMorph) ifTrue: [ items last withSeparatorAfter ] ifFalse: [ items add: ((aBuilder item: each contents asSymbol) keyText: each keyText; selector: each selector; target: each target; parent: #'Extended search...'; arguments: each arguments; order: (index*100)). each icon ifNotNil: [:ic | items last icon: ic ]]]. (items last: 2) doWithIndex: [:e :i | e order: (9998 + i) ]! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'BenjaminVanRyseghem 4/6/2012 16:43'! buildClassShortcutsOn: aBuilder (aBuilder shortcut: #fullBrowse) category: #NautilusClassShortcuts default: $b command do: [ :target | target fullBrowse ] description: 'Open a new browser on the selection'. (aBuilder shortcut: #restrictedBrowseClass) category: #NautilusClassShortcuts default: $b command shift do: [ :target | target restrictedBrowseClass ] description: 'Open a restricted browser'. (aBuilder shortcut: #copyClasses) category: #NautilusClassShortcuts default: $c command do: [ :target | target copyClasses ] description: 'Copy the selected classes'. (aBuilder shortcut: #addClassesInGroup) category: #NautilusClassShortcuts default: $e command do: [ :target | target addClassesInGroup ] description: 'Add the selected classes in a group'. (aBuilder shortcut: #findMethod) category: #NautilusClassShortcuts default: $f command do: [ :target | target findMethod ] description: 'Find a method'. (aBuilder shortcut: #findClass) category: #NautilusClassShortcuts default: $f command shift do: [ :target | target findClass ] description: 'Find a class'. (aBuilder shortcut: #generateInitialize) category: #NautilusClassShortcuts default: $i command shift do: [ :target | target generateInitialize ] description: 'Generate the initialize method'. (aBuilder shortcut: #createTestForSelectedClass) category: #NautilusClassShortcuts default: $j command do: [ :target | target enableSingleClassSelection ifTrue: [ target createTestForSelectedClass ]] description: 'Generate a test class for the selected class'. (aBuilder shortcut: #forceGenerateInitialize) category: #NautilusClassShortcuts default: $k command shift do: [ :target | target forceGenerateInitialize ] description: 'Regenerate the initialize method'. (aBuilder shortcut: #browseClassRefs) category: #NautilusClassShortcuts default: $n command shift do: [ :target | target browseClassRefs ] description: 'Browse class references'. (aBuilder shortcut: #addClass) category: #NautilusClassShortcuts default: $n command do: [ :target | target addClass ] description: 'Add a class'. (aBuilder shortcut: #renameClass) category: #NautilusClassShortcuts default: $r command do: [ :target | target enableSingleClassSelection ifTrue: [ target renameClass ]] description: 'Rename the selected class'. (aBuilder shortcut: #runClassTests) category: #NautilusClassShortcuts default: $t command do: [ :target | target runClassTests ] description: 'Run the tests for the selected class'. (aBuilder shortcut: #removeClasses) category: #NautilusClassShortcuts default: $x command do: [ :target | target removeClasses ] description: 'Remove the selected classes'. (aBuilder shortcut: #removeClassesFromGroup) category: #NautilusClassShortcuts default: $x command shift do: [ :target | (target showGroups and: [ target selectedGroup isReadOnly not ]) ifTrue: [ target removeClassFromGroup ]] description: 'Remove the selected classes from the selected group'! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'CamilloBruni 9/14/2012 01:31'! buildFindShortcutsOn: aBuilder (aBuilder shortcut: #findClass) category: #NautilusGlobalShortcuts default: $f command , $c command do: [ :target | target findClass ] description: 'Find a class'. (aBuilder shortcut: #findClassInHierarchy) category: #NautilusGlobalShortcuts default: $f command , $h command do: [ :target | target findClassInHierarchy ] description: 'Find a class in the hierarchy'. (aBuilder shortcut: #findSuperclass) category: #NautilusGlobalShortcuts default: $f command , $S shift command do: [ :target | target findSuperclass] description: 'Find a superclass'. (aBuilder shortcut: #findSubclass) category: #NautilusGlobalShortcuts default: $f command , $s command do: [ :target | target findSubclass] description: 'Find a subclass'. (aBuilder shortcut: #findPackage) category: #NautilusGlobalShortcuts default: $f command , $p command do: [ :target | target findPackage ] description: 'Find a package'. (aBuilder shortcut: #findProtocol) category: #NautilusGlobalShortcuts default: $f command , $t command do: [ :target | target findProtocol ] description: 'Find a protocol'. (aBuilder shortcut: #findMethod) category: #NautilusGlobalShortcuts default: $f command , $m command do: [ :target | target findMethod ] description: 'Find a method'. (aBuilder shortcut: #findRespondingMethod) category: #NautilusGlobalShortcuts default: $f command, $M shift command do: [ :target | target findAllMethod ] description: 'Find methods instances of this class may respond to'.! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/24/2012 17:55'! nextFocusKey ^ NextFocusKey! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/18/2013 17:40'! classesIconsCache ^ ClassesIconsCache! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/24/2012 18:05'! buildRunTestKeymappingsOn: aBuilder (aBuilder shortcut: #runTestForClasses) category: #NautilusGlobalShortcuts default: $j command ,$c command do: [ :target | target runClassTests ] description: 'runTestFor the selected classes'. (aBuilder shortcut: #runTestForPackages) category: #NautilusGlobalShortcuts default: $j command , $p command do: [ :target | target runPackagesTestsNotifying: true ] description: 'runTestFor the selected packages'. (aBuilder shortcut: #runTestForGroups) category: #NautilusGlobalShortcuts default: $j command , $g command do: [ :target | target runTestsOfGroups: target selectedGroups notifying: true ] description: 'runTestFor the selected groups'. (aBuilder shortcut: #runTestForMethods) category: #NautilusGlobalShortcuts default: $j command , $m command do: [ :target | target runTestForMethods: target selectedMethods notifying: true ] description: 'runTestFor the selected methods'.! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'EstebanLorenzano 2/6/2013 15:19'! buildSourceCodeShortcutsOn: aBuilder self buildEditorKeymappingsOn: aBuilder. (aBuilder shortcut: #runTest) category: #NautilusSourceCodeShortcuts default: $j command, $m command do: [:target | (target selectedMethod isTestMethod and: [ target sourceTextArea hasUnacceptedEdits not ]) ifTrue: [ target runTestForAMethod: target selectedMethod notifying: true ]] description: 'Run the current test method'. "This is not working anyway" "(aBuilder shortcut: #findClass) category: #NautilusSourceCodeShortcuts default: $f command, $c command do: [:target | target findClass ] description: 'Find class'."! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 5/14/2013 09:44'! classesMenu: aBuilder | target | target := aBuilder model. target selectedClass ifNil: [^target]. (aBuilder item: #'Rename...') keyText: 'r,c' if: Nautilus useOldStyleKeys not; keyText: 'r' if: Nautilus useOldStyleKeys; action: [ target renameClass ]; enabledBlock: [ target selectedClasses size <= 1 ]; order: -99; withSeparatorAfter. (aBuilder item: #'Browse scoped') keyText: 'b, s' if: Nautilus useOldStyleKeys not; keyText: 'B' if: Nautilus useOldStyleKeys; action: [target restrictedBrowseClass]; order: 1000; help: 'Open a browser on a restricted view'. (target selectedClass isTrait) ifTrue: [ (aBuilder item: #'Browse users') action: [ target restrictedBrowseTraitUsers ]; order: 1050]. (aBuilder item: #'Add in Group...') keyText: 'n, e, c' if: Nautilus useOldStyleKeys not; keyText: 'e' if: Nautilus useOldStyleKeys; action: [ target addClassesInGroup ]; order: 1100; withSeparatorAfter. (target selectedClasses allSatisfy: [:each | each inheritsFrom: TestCase ]) ifTrue:[ (aBuilder item:#'Run tests') keyText: 'j, c' if: Nautilus useOldStyleKeys not; keyText: 't' if: Nautilus useOldStyleKeys; action: [ target runClassTests ]; order: 1200]. (aBuilder item: #Analyze) enabledBlock: [ target selectedClasses size <= 1 ]; order: 0; withSeparatorAfter. (aBuilder item: #'Jump to test class') keyText: 'g, j' if: Nautilus useOldStyleKeys not; keyText: 'j' if: Nautilus useOldStyleKeys; action: [ target createTestForSelectedClass ]; enabledBlock: [ target selectedClasses size <= 1 ]; order: 300; withSeparatorAfter. (aBuilder item: #'Move to package...') keyText: 'm, c' if: Nautilus useOldStyleKeys not; action: [ target moveInNewPackage ]; order: 1400. (aBuilder item: #'Copy...') keyText: 'c, c' if: Nautilus useOldStyleKeys not; keyText: 'c' if: Nautilus useOldStyleKeys; action: [ target copyClasses ]; order: 1600. (aBuilder item: #'Remove...') keyText: 'x, c' if: Nautilus useOldStyleKeys not; keyText: 'x' if: Nautilus useOldStyleKeys; action: [ target removeClasses ]; icon: (Smalltalk ui icons iconNamed: #removeIcon); order: 1700; withSeparatorAfter. (aBuilder item: #'File Out') action: [ target fileOutClass ]; withSeparatorAfter; order: 1800. target showGroups ifTrue: [ target selectedGroup isReadOnly ifFalse: [ (aBuilder item: #'Remove from Group') keyText: 'X' if: Nautilus useOldStyleKeys not; action: [ target removeClassFromGroup ]; order: 1900] ].! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'StephaneDucasse 2/11/2014 10:59'! buildEditorKeymappingsOn: aBuilder (aBuilder shortcut: #selectAll) category: #NautilusSourceCodeShortcuts default: $a command do: [ :target | target sourceTextArea handleEdit: [ target sourceTextArea selectAll ] ]. (aBuilder shortcut: #copySelection) category: #NautilusSourceCodeShortcuts default: $c command do: [ :target | target sourceTextArea copySelection ]. (aBuilder shortcut: #find) category: #NautilusSourceCodeShortcuts default: $f command, $f command do: [ :target | target sourceTextArea find ]. (aBuilder shortcut: #findAgain) category: #NautilusSourceCodeShortcuts default: $f command, $g command do: [ :target | target sourceTextArea findAgain ]. (aBuilder shortcut: #setSearchString) category: #NautilusSourceCodeShortcuts default: $h command do: [ :target | target sourceTextArea setSearchString ]. (aBuilder shortcut: #cancel) category: #NautilusSourceCodeShortcuts default: $l command do: [ :target | target sourceTextArea cancelWithoutConfirmation ]. (aBuilder shortcut: #paste) category: #NautilusSourceCodeShortcuts default: $v command do: [ :target | target sourceTextArea paste ]. (aBuilder shortcut: #cut) category: #NautilusSourceCodeShortcuts default: $x command do: [ :target | target sourceTextArea cut ]. (aBuilder shortcut: #undo) category: #NautilusSourceCodeShortcuts default: $z command do: [ :target | target sourceTextArea undo ]. (aBuilder shortcut: #redo) category: #NautilusSourceCodeShortcuts default: $z command shift do: [ :target | target sourceTextArea redo ]. (aBuilder shortcut: #cursorHome) category: #NautilusSourceCodeShortcuts default: Character home command do: [ :target :morph :event | target sourceTextArea cursorHome: event ]. (aBuilder shortcut: #cursorEnd) category: #NautilusSourceCodeShortcuts default: Character end command do: [ :target :morph :event | target sourceTextArea cursorEnd: event ]. (aBuilder shortcut: #browseIt) category: #NautilusSourceCodeShortcuts default: $b command do: [ :target | target sourceTextArea browseIt ]. (aBuilder shortcut: #doIt) category: #NautilusSourceCodeShortcuts default: $d command do: [ :target | target sourceTextArea doIt ]. (aBuilder shortcut: #inspectIt) category: #NautilusSourceCodeShortcuts default: $i command do: [ :target | target sourceTextArea inspectIt ]. (aBuilder shortcut: #implementorsOfIt) category: #NautilusSourceCodeShortcuts default: $m command do: [ :target | target sourceTextArea implementorsOfIt ]. (aBuilder shortcut: #sendersOfIt) category: #NautilusSourceCodeShortcuts default: $n command do: [ :target | target sourceTextArea sendersOfIt ]. (aBuilder shortcut: #printIt) category: #NautilusSourceCodeShortcuts default: $p command do: [ :target | target sourceTextArea printIt ].! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'CamilloBruni 9/14/2012 01:28'! buildButtonsShortcutsOn: aBuilder (aBuilder shortcut: #showPackage) category: #NautilusGlobalShortcuts default: $t command ,$p command do: [ :target | target showGroups: false ] description: 'Find a class'. (aBuilder shortcut: #showGroup) category: #NautilusGlobalShortcuts default: $t command , $g command do: [ :target | target showGroups: true ] description: 'Find a package'. (aBuilder shortcut: #showInstanceSide) category: #NautilusGlobalShortcuts default: $t command ,$i command do: [ :target | target showInstance: true ] description: 'Show instance side'. (aBuilder shortcut: #showClassSide) category: #NautilusGlobalShortcuts default: $t command ,$c command do: [ :target | target showInstance: false ] description: 'Show class side'. (aBuilder shortcut: #showHierarchy) category: #NautilusGlobalShortcuts default: $t command ,$h command do: [ :target | target showPackages: false ] description: 'Show Hierarchy'. (aBuilder shortcut: #showFlat) category: #NautilusGlobalShortcuts default: $t command ,$f command do: [ :target | target showPackages: true ] description: 'Show normal view'. ! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'EstebanLorenzano 2/6/2013 16:41'! buildCommentShortcutsOn: aBuilder self buildEditorCommentKeymappingsOldOn: aBuilder. (aBuilder shortcut: #runTest) category: #NautilusCommentShortcuts default: $t command do: [:target | (target selectedMethod isTestMethod and: [ target commentTextArea hasUnacceptedEdits not ]) ifTrue: [ target runTestForAMethod: target selectedMethod notifying: true ]] description: 'Run the current test method'.! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'EstebanLorenzano 2/6/2013 17:58'! buildPackageShortcutsOn: aBuilder (aBuilder shortcut: #fullBrowse) category: #NautilusPackageShortcuts default: $b command do: [ :target | target fullBrowse ] description: 'Open a new browser on the selection'. (aBuilder shortcut: #addPackagesInGroup) category: #NautilusPackageShortcuts default: $e command do: [ :target | target addPackagesInGroup ] description: 'Add the selected package in a group'. (aBuilder shortcut: #findClass) category: #NautilusPackageShortcuts default: $f command do: [ :target | target findClass ] description: 'Find a class'. (aBuilder shortcut: #findPackage) category: #NautilusPackageShortcuts default: $f command shift do: [ :target | target findPackage ] description: 'Find a package'. (aBuilder shortcut: #addPackagesAsGroupsAndBrowse) category: #NautilusPackageShortcuts default: $g command do: [ :target | target addPackagesAsGroupsAndBrowse ] description: 'Add the selected packages as groups and browse'. (aBuilder shortcut: #addPackagesAsGroups) category: #NautilusPackageShortcuts default: $g command shift do: [ :target | target addPackageAsGroupAndBrowse ] description: 'Add the selected packages as groups'. (aBuilder shortcut: #addMatchingPackagesInGroupsAndBrowse) category: #NautilusPackageShortcuts default: $m command shift do: [ :target | target addMatchingPackagesInGroupsAndBrowse ] description: 'Add packages matching the selected package as groups and browse'. (aBuilder shortcut: #addMatchingPackagesInGroups) category: #NautilusPackageShortcuts default: $m command do: [ :target | target addMatchingPackagesInGroups ] description: 'Add packages matching the selected package as groups'. (aBuilder shortcut: #addPackage) category: #NautilusPackageShortcuts default: $n command do: [ :target | target addPackage ] description: 'Add a new package'. (aBuilder shortcut: #renamePackage) category: #NautilusPackageShortcuts default: $r command do: [ :target | target enableSingleMenuItems ifTrue: [ target renamePackage ]] description: 'Rename the selected package'. (aBuilder shortcut: #runPackagesTests) category: #NautilusPackageShortcuts default: $t command do: [ :target | target runPackagesTestsNotifying: true ] description: 'Run the tests for the selected packages'. (aBuilder shortcut: #removePackages) category: #NautilusPackageShortcuts default: $x command do: [ :target | target removePackages ] description: 'Remove the selected packages'.! ! !AbstractNautilusUI class methodsFor: 'shortcut-old' stamp: 'CamilloBruni 10/7/2012 22:04'! buildGroupShortcutsOn: aBuilder (aBuilder shortcut: #fullBrowse) category: #NautilusGroupShortcuts default: $b command do: [ :target | target fullBrowse ] description: 'Open a new browser on the current selection'. (aBuilder shortcut: #restrictedBrowseGroup) category: #NautilusGroupShortcuts default: $b command shift do: [ :target | target restrictedBrowseGroups: target selectedGroups ] description: 'Open a browser on a restricted view'. (aBuilder shortcut: #findClass) category: #NautilusGroupShortcuts default: $f command do: [ :target | target findClass ] description: 'Find a class'. (aBuilder shortcut: #addNewGroup) category: #NautilusGroupShortcuts default: $n command do: [ :target | target addNewGroup ] description: 'Create a new group'. (aBuilder shortcut: #renameGroup) category: #NautilusGroupShortcuts default: $r command do: [ :target | target enableSingleMenuItems ifTrue:[ target renameGroup ]] description: 'Rename the selected group'. (aBuilder shortcut: #runTestsOfGroups) category: #NautilusGroupShortcuts default: $t command do: [ :target | target runTestsOfGroups: target selectedGroups notifying: true ] description: 'Run the tests of the selected groups'. (aBuilder shortcut: #removeGroups) category: #NautilusGroupShortcuts default: $x command do: [ :target | target removeGroups ] description: 'Remove the selected groups'.! ! !AbstractNautilusUI class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 10/17/2013 13:55'! registerSystemAnnouncements SystemAnnouncer uniqueInstance unsubscribe: self. SystemAnnouncer uniqueInstance weak when: IconSetChanged send: #resetIconCaches to: self! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: ''! packagesIconsCache ^ PackagesIconsCache! ! !AbstractNautilusUI class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/28/2012 15:16'! buildRefactoringShortcutsOn: aBuilder (aBuilder shortcut: #generateInitialize) category: #NautilusGlobalShortcuts default: $h command, $i command do: [ :target | target generateInitialize ] description: 'Generate the initialize method'. (aBuilder shortcut: #forceGenerateInitialize) category: #NautilusGlobalShortcuts default: $h command, $k command do: [ :target | target forceGenerateInitialize ] description: 'Regenerate the initialize method'. (aBuilder shortcut: #createTestForSelectedClass) category: #NautilusGlobalShortcuts default: $n command, $j command, $c command do: [ :target | target enableSingleClassSelection ifTrue: [ target createTestForSelectedClass ]] description: 'Generate a test class for the selected class'. (aBuilder shortcut: #generateTestAndJump) category: #NautilusGlobalShortcuts default: $h command, $j command do: [ :target | target generateTestMethodsAndFocus: true ] description: 'Generate test and jump'. (aBuilder shortcut: #generateTest) category: #NautilusGlobalShortcuts default: $h command, $j command shift do: [ :target | target generateTestMethodsAndFocus: false ] description: 'Generate test'. (aBuilder shortcut: #categorizeAllUncategorized) category: #NautilusGlobalShortcuts default: $h command, $c command shift do: [ :target | target categorizeAllUncategorizedMethods ] description: 'Categorize all uncategorized'.! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon ^ Smalltalk ui icons nautilusIcon ! ! !AbstractNautilusUITest commentStamp: ''! An AbstractNautilusUITest is a test class for testing the behavior of AbstractNautilusUI! !AbstractNautilusUITest methodsFor: 'initialization' stamp: ''! setUp "Setting up code for AbstractNautilusUITest" model := AbstractNautilusUI new.! ! !AbstractNautilusUITest methodsFor: 'tests' stamp: ''! testSortClassesInCachedHierarchyB! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'MarcusDenker 2/11/2013 15:34'! pragmas ^#()! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'md 3/1/2006 14:23'! methodClass: aMethodClass! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'md 3/1/2006 14:23'! selector: aSymbol! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'md 3/1/2006 14:25'! flushCache! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'MarcusDenker 2/11/2013 16:06'! origin ^self class! ! !AbstractPackageSelectedPlugin commentStamp: ''! AbstractKeyPressedPlugin is an abstraction of plugin which react when a package is selected! !AbstractPackageSelectedPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 5/10/2011 12:35'! registerTo: aModel aModel announcer on: NautilusPackageSelected send: #packageSelected: to: self! ! !AbstractPackageSelectedPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/10/2011 14:39'! packageSelected: anAnnouncement ^ self subclassResponsibility! ! !AbstractPackageWidget commentStamp: ''! AbstractPackageWidget is an abstraction describing a widget used to manage packages! !AbstractResizerMorph commentStamp: 'jmv 1/29/2006 17:15'! I am the superclass of a hierarchy of morph specialized in allowing the user to resize or rearrange windows and panes.! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/12/2007 10:59'! mouseUp: anEvent "Change the cursor back to normal if necessary." (self bounds containsPoint: anEvent cursorPoint) ifFalse: [ anEvent hand showTemporaryCursor: nil. self setDefaultColors; changed]! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:20'! shouldDraw "Answer whether the resizer should be drawn." ^self fillStyle isTransparent not! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/5/2005 21:37'! resizeCursor self subclassResponsibility! ! !AbstractResizerMorph methodsFor: 'event handling' stamp: 'jrp 7/5/2005 21:37'! handlesMouseDown: anEvent ^ true! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/27/2008 21:34'! adoptPaneColor: paneColor "Just get the resizer fill style for the theme." paneColor ifNil: [^super adoptPaneColor: paneColor]. self fillStyle: (self theme resizerGripNormalFillStyleFor: self)! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:35'! shouldInvalidateOnMouseTransition "Answer whether the resizer should be invalidated when the mouse enters or leaves." ^false! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'jrp 7/5/2005 21:37'! handlesMouseOver: anEvent ^ true ! ! !AbstractResizerMorph methodsFor: 'initialization' stamp: 'md 2/24/2006 23:01'! initialize super initialize. self color: Color transparent! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:36'! mouseEnter: anEvent self isCursorOverHandle ifTrue: [self setInverseColors. self shouldInvalidateOnMouseTransition ifTrue: [self changed]. "avoid unnecessary invalidation" anEvent hand showTemporaryCursor: self resizeCursor]! ! !AbstractResizerMorph methodsFor: 'testing' stamp: 'jrp 7/5/2005 21:40'! isCursorOverHandle ^ true! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/5/2005 21:36'! dotColor ^ dotColor ifNil: [self setDefaultColors. dotColor]! ! !AbstractResizerMorph methodsFor: 'event handling' stamp: 'jrp 7/5/2005 21:42'! mouseDown: anEvent lastMouse := anEvent cursorPoint! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/5/2005 21:35'! handleColor ^ handleColor ifNil: [self setDefaultColors. handleColor]! ! !AbstractResizerMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:36'! mouseLeave: anEvent anEvent hand showTemporaryCursor: nil. self setDefaultColors. self shouldInvalidateOnMouseTransition ifTrue: [self changed]. "avoid unnecessary invalidation"! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/30/2005 21:30'! setInverseColors handleColor := Color lightGray. dotColor := Color white! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/29/2005 13:25'! setDefaultColors handleColor := Color lightGray lighter lighter. dotColor := Color gray lighter! ! !AbstractSpecLayoutAction commentStamp: ''! AbstractSpecLayoutAction is an abstract class representing a spec layout action.! !AbstractSpecLayoutAction methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/31/2012 15:10'! generateArguments ! ! !AbstractSpecLayoutAction methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/18/2012 04:47'! asSpecElements self subclassResponsibility ! ! !AbstractTextChangedPlugin commentStamp: ''! An AbstractTextChangedPlugin is a plugin which simply log each time the method displayer changed! !AbstractTextChangedPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 6/13/2012 21:18'! registerTo: aModel aModel announcer on: NautilusTextDisplayerChanged send: #displayerChanged: to: self! ! !AbstractTextChangedPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/13/2012 21:18'! displayerChanged: anAnnouncement self logCr: anAnnouncement displayerSymbol! ! !AbstractTimeZone commentStamp: ''! I am an abstract superclass for timezones. See my subclasses for specific implementations. Timezones are used to encapsulate the offset from the Coordinated Univeral Time (UTC) used for proper Date and Time display and manipulations.! !AbstractTimeZone methodsFor: 'accessing' stamp: 'CamilloBruni 8/24/2013 00:15'! abbreviation ^ self subclassResponsibility! ! !AbstractTimeZone methodsFor: 'printing' stamp: 'CamilloBruni 10/16/2013 18:21'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self abbreviation; nextPut: $).! ! !AbstractTimeZone methodsFor: 'accessing' stamp: 'CamilloBruni 8/24/2013 00:15'! offset "Return a duration representing the offset from UTC for this timezone" self subclassResponsibility! ! !AbstractTimeZone methodsFor: 'accessing' stamp: 'CamilloBruni 8/24/2013 00:15'! name ^ self subclassResponsibility! ! !AbstractTool commentStamp: ''! I'm an abstract class grouping generic methods for managing packages/classes/groups/methods from a browser! !AbstractTool methodsFor: 'package' stamp: 'BenjaminVanRyseghem 2/5/2013 14:06'! addPackageBasedOn: aPackage | name initialAnswer package | initialAnswer := aPackage ifNil: [''] ifNotNil: [:p | p name]. name := UIManager default request: 'Name of the new package:' initialAnswer: initialAnswer title: 'Create a new package'. (self isValidPackageName: name) ifTrue: [ package := self browsedEnvironment packageOrganizer createPackageNamed: name ] ifFalse: [ self alertInvalidPackageName:name ]. ^ package! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 3/16/2012 01:36'! moveInNewPackage: aCollection | labels reject lines oldIndex newName item aPackage | aCollection ifEmpty: [^ nil ]. aPackage := aCollection first package. labels := self model packages collect: [:each | each name]. lines := {0}. newName := UIManager default chooseOrRequestFrom: labels lines: lines title: ('Change Package (current: ', aPackage name,')'). newName ifNil: [ ^ nil ]. newName := newName asSymbol. item := self browsedEnvironment packageOrganizer packageNamed: newName. aCollection do: [:aClass | aPackage removeClass: aClass. item addClassDefinition: aClass. aClass category: item name ]. ^ item! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 4/13/2011 13:13'! removeNonLocalSelector: aSymbol from: aClass | traits isAlias | traits := aClass traitsProvidingSelector: aSymbol. isAlias := aClass isLocalAliasSelector: aSymbol. isAlias ifTrue: [ [traits size = 1] assert. aClass removeAlias: aSymbol of: traits first] ifFalse: [ traits do: [:each | aClass addExclusionOf: aSymbol to: each ]]! ! !AbstractTool methodsFor: 'package' stamp: 'NicolaiHess 4/7/2014 22:46'! addPackagesAsGroup: aCollection aCollection ifNotEmpty: [| packages blocks name | packages := aCollection sort: [:a :b | a name <= b name ]. blocks := OrderedCollection new. packages do: [:package | blocks add: (self class groupBlockFor: package)]. name := ( packages collect: [:package | package name]) joinUsing: ' + '. ^ (self groupsManager addADynamicClassGroupNamed: name blocks: blocks)]! ! !AbstractTool methodsFor: 'method' stamp: 'StephaneDucass 5/18/2012 19:20'! browseVersionsFrom: aMethod "Create and schedule a Versions Browser, showing all versions of the currently selected message. Answer the browser or nil." | selector class | (selector := aMethod selector) ifNil: [ self inform: 'Sorry, only actual methods have retrievable versions.'. ^nil ] ifNotNil: [ class := aMethod methodClass. (Smalltalk tools versionBrowser browseVersionsOf: (RGMethodDefinition new selector: selector; className: aMethod methodClass name; asHistorical) class: class theNonMetaClass meta: class isMeta category: aMethod category selector: selector)]! ! !AbstractTool methodsFor: 'group' stamp: 'BenjaminVanRyseghem 1/24/2013 15:17'! alertGroupExisting: name UIManager default alert: 'The group named ', name, ' already exists' title: 'Already exists'! ! !AbstractTool methodsFor: 'package' stamp: 'BenjaminVanRyseghem 2/5/2013 14:04'! isValidPackageName: name ^ (name isNil or: [ name isEmpty or: [ name first = $* ]]) not! ! !AbstractTool methodsFor: 'class' stamp: 'EstebanLorenzano 12/12/2013 21:37'! addTraitIn: aPackage " add a new class in the provided package. A dialog will be opened to let the user set the class definition " | systemCategory classDefinition | systemCategory := aPackage ifNotNil: [ aPackage categoryName ] ifNil: [ 'Unknown' ]. classDefinition := self class defineTraitTemplate format: { #TNameOfTrait. '{}'. systemCategory }. classDefinition := UIManager default multiLineRequest: 'Define class definition:' initialAnswer: classDefinition answerHeight: 250. (classDefinition isNil or: [ classDefinition isEmpty ]) ifTrue: [ ^ self ]. self class evaluate: classDefinition.! ! !AbstractTool methodsFor: 'package' stamp: 'SeanDeNigris 2/5/2013 10:54'! renamePackages: aCollection | name | aCollection ifNotEmpty: [ :packages | packages do: [ :selectedPackage | self renamePackage: selectedPackage ] ].! ! !AbstractTool methodsFor: 'method' stamp: 'StephaneDucasse 5/28/2011 13:19'! moveMethodsToPackage: aCollection in: packagesList from: aPackage "Search for a package from a pattern or from the recent list" | pattern foundPackage | aCollection ifEmpty: [^ self ]. packagesList size = 0 ifTrue: [pattern := UIManager default request: 'Package name or fragment?'] ifFalse: [pattern := UIManager default enterOrRequestFrom: packagesList lines: #() title: 'Package name or fragment?']. pattern isEmptyOrNil ifTrue: [^ self flashPackage ]. foundPackage := self systemNavigation packageFromPattern: pattern withCaption: ''. foundPackage ifNil: [^ self flashPackage]. aPackage = foundPackage ifTrue: [ ^ self ]. aCollection do: [:each | self moveMethod: each inPackage: foundPackage ]. ! ! !AbstractTool methodsFor: 'class' stamp: 'StephaneDucass 2/2/2014 09:03'! addFullClassIn: aPackage " add a new class in the provided package. A dialog will be opened to let the user set the class definition " | classSymbol systemCategory classDefinition | classSymbol := #NameOfSubclass. systemCategory := aPackage ifNotNil: [ aPackage categoryName ] ifNil: [ 'Unknown' ]. classDefinition := self class defineFullClassTemplate format: { classSymbol. systemCategory } . classDefinition := UIManager default multiLineRequest: 'Define class definition:' initialAnswer: classDefinition answerHeight: 250. classDefinition isEmptyOrNil ifTrue: [ ^ self ]. self class evaluate: classDefinition.! ! !AbstractTool methodsFor: 'class' stamp: 'MarcusDenker 10/15/2013 18:07'! browseUnusedMethodsOf: aClass | classes unsent messageList | aClass ifNil: [^ self]. classes := Array with: aClass with: aClass class. unsent := Set new. classes do: [:c | unsent addAll: c selectors ]. unsent := self systemNavigation allUnsentMessagesIn: unsent. messageList := OrderedCollection new. classes do: [:c | (c selectors select: [:s | unsent includes: s]) asSortedCollection do: [:sel | messageList add: ((c compiledMethodAt: sel) methodReference) ]]. self systemNavigation browseMessageList: messageList name: 'Unsent Methods in ' , aClass name! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 1/10/2014 15:24'! addCategoryIn: aClass ^ self addCategoryIn: aClass before: nil! ! !AbstractTool methodsFor: 'group' stamp: 'BenjaminVanRyseghem 4/13/2011 12:59'! mergeGroups: aCollection aCollection ifNotEmpty: [:groups || group | group := groups reduce: [:a :b | a or: b]. groups do: [:gp | gp removable ifTrue: [self groupsManager removeAGroupSilently: gp]]. ^ group]. ^ nil! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 12:26'! browseClassVarRefsOf: aClass | cls | cls := aClass theNonMetaClass. (cls notNil and: [cls isTrait not]) ifTrue: [self systemNavigation browseClassVarRefs: cls]! ! !AbstractTool methodsFor: 'class' stamp: 'onierstrasz 11/11/2013 12:11'! removeClass: aClass "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." | message className classToRemove result | "This should probably be an assertion, but since this is a tool, we give user feedback." classToRemove := aClass ifNil: [self inform: 'Argument to #removeClass: is nil'. ^ false]. classToRemove := classToRemove theNonMetaClass. className := classToRemove name. message := 'Are you certain that you want to REMOVE the class ', className, ' from the system?'. (result := self confirm: message) ifTrue: [classToRemove subclasses size > 0 ifTrue: [(self confirm: 'class has subclasses: ' , message) ifFalse: [^ false]]. classToRemove removeFromSystem ]. ^ result! ! !AbstractTool methodsFor: 'method' stamp: 'MarcusDenker 10/13/2013 07:57'! selectThenBrowseSendersOfMessagesFrom: aSelector "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen." self selectThenGetSelectorAndSendQuery: #browseAllSendersOf: to: self systemNavigation with: {} selector: aSelector! ! !AbstractTool methodsFor: 'method' stamp: 'SeanDeNigris 6/13/2013 09:12'! fileOutMethods: aCollection self do: [ :method | method methodClass fileOutMethod: method selector ] on: aCollection displaying: 'Filing out methods...'.! ! !AbstractTool methodsFor: 'class' stamp: 'MarcusDenker 8/28/2013 10:51'! defineTrait: defString notifying: aController | defTokens keywdIx envt oldTrait newTraitName trait | self selectedClassOrMetaClass isTrait ifTrue:[oldTrait := self selectedClassOrMetaClass]. defTokens := defString findTokens: Character separators. keywdIx := defTokens findFirst: [:x | x = 'category']. envt := self class environment. keywdIx := defTokens findFirst: [:x | x = 'named:']. newTraitName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldTrait isNil or: [oldTrait baseTrait name asString ~= newTraitName]) and: [envt includesKey: newTraitName asSymbol]) ifTrue: ["Attempting to define new class/trait over existing one when not looking at the original one in this browser..." (self confirm: ((newTraitName , ' is an existing class/trait in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newTraitName size)) ifFalse: [^ nil ]]. trait := self class compiler source: defString; requestor: aController; logged: true; evaluate. ^ trait! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 4/13/2011 13:06'! moveMethod: aMethod inPackage: aPackage aMethod methodClass organization classify: aMethod selector under: '*', aPackage name suppressIfDefault: true.! ! !AbstractTool methodsFor: 'category' stamp: 'EstebanLorenzano 1/16/2014 11:20'! renameCategory: aCategory from: aClass "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldName newName | aClass ifNil: [^ nil]. aCategory ifNil: [^ nil]. oldName := aCategory. newName := self class requestProtocolNameFor: aClass initialAnswer: oldName. newName isEmptyOrNil ifTrue: [^ nil ] ifFalse: [newName := newName asSymbol]. newName = oldName ifTrue: [^ nil ]. aClass organization renameCategory: oldName toBe: newName. ^ newName! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 2/7/2012 09:20'! browseMessagesFrom: aSelector " badly named, it browses implementors " self getSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation with: {} selector: aSelector! ! !AbstractTool methodsFor: 'class' stamp: 'StephaneDucasse 5/28/2011 13:20'! showUnreferencedClassVarsOf: aClass "Search for all class variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each class variable in order to determine whether it is unreferenced" | aList aReport | ( aClass isNil or: [aClass isTrait]) ifTrue: [^ self]. aList := self systemNavigation allUnreferencedClassVariablesOf: aClass. aList size = 0 ifTrue: [^ UIManager default inform: 'There are no unreferenced class variables in ' , aClass name]. aReport := String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced class variable(s) in ' translated, aClass name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. UIManager default inform: aReport! ! !AbstractTool methodsFor: 'method' stamp: ''! selectThenGetSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs selector: aSelector "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments. If no message is currently selected, then obtain a method name from a user type-in" | strm array | strm := (array := Array new: queryArgs size + 1) writeStream. strm nextPut: nil. strm nextPutAll: queryArgs. aSelector ifNil: [ ^ self defaultGetSelectorAndSendQuery: querySelector to: queryPerformer with: array ]. self selectMessageAndEvaluate: [ :selector | array at: 1 put: selector. queryPerformer perform: querySelector withArguments: array ] defaultValue: aSelector! ! !AbstractTool methodsFor: 'class' stamp: 'EstebanLorenzano 12/12/2013 21:38'! addClassIn: aPackage " add a new class in the provided package. A dialog will be opened to let the user set the class definition " | classSymbol systemCategory classDefinition | classSymbol := #NameOfSubclass. systemCategory := aPackage ifNotNil: [ aPackage categoryName ] ifNil: [ 'Unknown' ]. classDefinition := self class defineClassTemplate format: { classSymbol. systemCategory } . classDefinition := UIManager default multiLineRequest: 'Define class definition:' initialAnswer: classDefinition answerHeight: 250. classDefinition isEmptyOrNil ifTrue: [ ^ self ]. self class evaluate: classDefinition.! ! !AbstractTool methodsFor: 'method' stamp: 'MarcusDenker 10/15/2013 18:09'! categorizeMethods: aCollection of: aClass from: aCategory "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | labels lines oldIndex newName | aCollection ifEmpty: [^ self]. aClass ifNil: [^self]. labels := OrderedCollection new. labels addAll: aClass organization categories copy sort; add: Protocol unclassified. lines := OrderedCollection new. lines add: labels size -1. newName := UIManager default chooseOrRequestFrom: labels lines: lines title: ('Change Protocol (current: ', aCategory, ')'). newName ifNil: [ ^self ]. newName := newName asSymbol. aCollection do: [:item | item methodClass organization classify: item selector under: newName suppressIfDefault: true ].! ! !AbstractTool methodsFor: 'method' stamp: 'StephaneDucasse 5/28/2011 13:19'! findMethodIn: aClass | recentList pattern foundMethod | aClass ifNil: [^ nil ]. recentList := aClass selectors. recentList size = 0 ifTrue: [pattern := UIManager default request: 'Message name or fragment?'] ifFalse: [pattern := UIManager default enterOrRequestFrom: recentList lines: #() title: 'Message name or fragment?']. pattern isEmptyOrNil ifTrue: [^ nil ]. foundMethod := self systemNavigation selectorFromPattern: pattern withCaption: '' startingFrom: self selectedClass. foundMethod ifNil: [^ nil ]. ^ foundMethod! ! !AbstractTool methodsFor: 'method' stamp: 'MarcusDenker 10/13/2013 07:57'! browseSendersOfMessagesFrom: aSelector "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen." self getSelectorAndSendQuery: #browseAllSendersOf: to: self systemNavigation with: {} selector: aSelector! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 2/19/2012 19:25'! toggleBreakOnEntryIn: aMethod "Install or uninstall a halt-on-entry breakpoint" aMethod ifNil: [^self]. aMethod hasBreakpoint ifTrue: [BreakpointManager unInstall: aMethod] ifFalse: [BreakpointManager installInClass: aMethod methodClass selector: aMethod selector ].! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 2/21/2012 18:20'! browseClassRefsOf: aClass | class | aClass ifNil: [ ^false ]. class := aClass theNonMetaClass ifNil: [^self]. class isTrait ifTrue: [self systemNavigation browseAllUsersOfTrait: class] ifFalse: [self systemNavigation browseAllCallsOnClass: class] ! ! !AbstractTool methodsFor: 'package' stamp: 'MarcusDenker 7/17/2013 15:08'! addPackagesAsGroups: aCollection | name | name := WriteStream on: ''. aCollection ifNotEmpty: [| packages firstGroup | packages := aCollection sort: [:a :b | a name <= b name ]. packages do: [:package || group | [ group := self addPackagesAsGroup: {package}. ] on: GroupAlreadyExists do: [:ex | name nextPutAll: ex groupName; nextPut: Character cr. group := nil ]. firstGroup ifNil: [ group ifNotNil: [ firstGroup := group ]]]. name := name contents. name isEmpty ifFalse: [ (GroupsAlreadyExist groupName: name) signal ]. ^ firstGroup ]. ^ nil ! ! !AbstractTool methodsFor: 'package' stamp: 'StephaneDucasse 11/11/2013 18:56'! fileOutPackages: aCollection self do: [ :package | package item package fileOut ] on: aCollection displaying: 'Filing out packages...'.! ! !AbstractTool methodsFor: 'method' stamp: 'ChristopheDemarey 10/18/2013 17:39'! removeMethod: aMethod inClass: aClass "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. " | messageName confirmation | aMethod ifNil: [^ false]. messageName := aMethod selector. confirmation := self systemNavigation confirmRemovalOf: messageName on: aClass. confirmation = 3 ifTrue: [^ false]. (aClass includesLocalSelector: messageName) ifTrue: [ aClass removeSelector: messageName ] ifFalse: [ self removeNonLocalSelector: messageName ]. "In case organization not cached" confirmation = 2 ifTrue: [self systemNavigation browseAllSendersOf: messageName]. self removeEmptyUnclassifiedCategoryFrom: aClass. ^ true! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 3/25/2012 20:58'! selectThenBrowseMessagesFrom: aSelector " badly named, it browses implementors " self selectThenGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation with: {} selector: aSelector! ! !AbstractTool methodsFor: 'class' stamp: 'SvenVanCaekenberghe 2/1/2014 20:24'! addCategoryIn: aClass before: aCategory "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | newName | newName := self class requestProtocolNameFor: aClass initialAnswer: ''. (newName isEmptyOrNil) ifTrue: [ ^ nil ]. newName := newName asSymbol. aClass organization addCategory: newName before: aCategory. ^ newName! ! !AbstractTool methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/17/2013 10:01'! browseAllStoresInto: aVariableName from: aClass ^self systemNavigation browseAllStoresInto: aVariableName from: aClass ! ! !AbstractTool methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/18/2013 15:19'! browseSendersOf: target name: windowName autoSelect: isAutoSelect ^self systemNavigation browseSendersOf: target name: windowName autoSelect: isAutoSelect ! ! !AbstractTool methodsFor: 'class' stamp: 'SeanDeNigris 6/13/2013 09:12'! fileOutClasses: aCollection "Print a description of the selected class onto a file whose name is the category name followed by .st." self do: [ :class | class theNonMetaClass fileOut ] on: aCollection displaying: 'Filing out classes...'.! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 12:29'! browseInstVarRefsOf: aClass (aClass notNil and: [aClass isTrait not]) ifTrue: [self systemNavigation browseInstVarRefs: aClass]! ! !AbstractTool methodsFor: 'method' stamp: 'CamilloBruni 9/22/2012 21:44'! compileANewMethodInClass: aClass categorized: aCategory from: aString notifyng: aController | selector existingMethod targetClass | targetClass := aClass. "try to guess the selector form the first line XXX hack" selector := aString lines first findSelector. "Warn the user if a Trait method would be overridden" (aClass includesSelector: selector) ifTrue: [ existingMethod := aClass methodNamed: selector. existingMethod isFromTrait ifTrue: [ targetClass := UIManager default chooseFrom: {'Create copy in ', aClass name. 'Compile Trait method in ', existingMethod origin name} values: { aClass. existingMethod origin} title: 'Where do you want to compile this trait method?'. targetClass ifNil: [ ^ nil ]]]. "Run the normal compilation either on aClass or the Trait" ^ targetClass compile: aString classified: aCategory notifying: aController.! ! !AbstractTool methodsFor: 'class' stamp: 'onierstrasz 11/11/2013 12:12'! removeClasses: aCollection "Remove the selected classes from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." | message classesName classesToRemove result | "This should probably be an assertion, but since this is a tool, we give user feedback." aCollection isEmptyOrNil ifTrue: [ self inform: 'Argument to #removeClasses: is empty or nil'. ^ false ]. classesToRemove := aCollection collect: #theNonMetaClass. classesName := (classesToRemove collect: #name) joinUsing: ', '. message := 'Are you certain that you want to REMOVE the classes ', classesName, ' from the system ?'. (result := self confirm: message) ifTrue: [ classesToRemove do: [:classToRemove | message := classToRemove name, ' has subclasses. Do you really want to REMOVE it from the system ?'. classToRemove subclasses size > 0 ifTrue: [ (self confirm: message) ifTrue: [ classToRemove removeFromSystem ]] ifFalse: [ classToRemove removeFromSystem ]]]. ^ result! ! !AbstractTool methodsFor: '*necompletion-extensions' stamp: 'EstebanLorenzano 4/12/2012 13:20'! isCodeCompletionAllowed ^true! ! !AbstractTool methodsFor: '*necompletion-extensions' stamp: 'EstebanLorenzano 4/23/2012 13:48'! guessTypeForName: aString ^nil! ! !AbstractTool methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/18/2013 15:19'! browseImplementorsOf: target name: windowName autoSelect: isAutoSelect ^self systemNavigation browseImplementorsOf: target name: windowName autoSelect: isAutoSelect ! ! !AbstractTool methodsFor: 'private' stamp: 'EstebanLorenzano 10/16/2013 15:05'! renamePackage: anRPackage | newName | newName := UIManager default request: 'New name of the package' initialAnswer: anRPackage name title: 'Rename a package'. newName = anRPackage name ifTrue: [ ^ self ]. (self isValidPackageName: newName) ifTrue: [ self browsedEnvironment packageOrganizer renamePackage: anRPackage in: newName ] ifFalse: [ self alertInvalidPackageName:newName ].! ! !AbstractTool methodsFor: 'package' stamp: 'BenjaminVanRyseghem 4/13/2011 12:21'! addPackagesAsGroup: aCollection named: aString aCollection ifNotEmpty: [:packages || blocks | blocks := OrderedCollection new. packages do: [:package | blocks add: [ package orderedClasses]]. ^ (self groupsManager addADynamicGroupSilentlyNamed: aString blocks: blocks)]! ! !AbstractTool methodsFor: 'category' stamp: 'BenjaminVanRyseghem 2/18/2012 21:05'! fileOutCategories: aCollection from: aClass aCollection do: [:name | aClass fileOutCategory: name ]! ! !AbstractTool methodsFor: 'category' stamp: 'BenjaminVanRyseghem 4/13/2011 13:10'! removeEmptyCategoriesFrom: aClass aClass organization removeEmptyCategories.! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 1/24/2013 13:54'! createInitializerWithInstVarsOf: aClass "Create a default initializer on the class side for a chosen list of instance variables" | newMessage instVars| aClass ifNil: [ ^ self ]. instVars := (TickDialogWindow itemsList: aClass instVarNames sort itemsHeaderName: 'Inst Var Names' wrapBlockOrSelector: [:e | e ] title: 'Create entry point' defaultValue: true) chooseFromOwner: self window. instVars ifNil: [ ^ self ]. instVars do: [ :aVariable| (aClass canUnderstand: (aVariable, ':') asSymbol) ifFalse: [ newMessage :=self buildSetterFor: aVariable. aClass compile: newMessage classified: 'accessing' notifying: nil ]]. (aClass theMetaClass canUnderstand: (($: join: instVars), ':') asSymbol) ifFalse: [ newMessage := self buildInitializerFor: instVars. aClass theMetaClass compile: newMessage classified: 'instance creation' notifying: nil ]! ! !AbstractTool methodsFor: 'package' stamp: 'BenjaminVanRyseghem 2/5/2013 14:09'! alertInvalidPackageName:name | errorMessage | (name isNil or: [ name isEmpty ]) ifTrue: [ ^ self ]. "User cancelled the action" errorMessage := String streamContents: [:stream | stream << name << ' is not a valid package name. A package name can not begin with a *' ]. UIManager default inform: errorMessage! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 12:28'! browseInstVarDefsOf: aClass (aClass notNil and: [aClass isTrait not]) ifTrue: [self systemNavigation browseInstVarDefs: aClass]! ! !AbstractTool methodsFor: 'class' stamp: 'CamilloBruni 9/12/2011 15:06'! copyClasses: aCollection | needsRefresh lastDuplicate | aCollection ifEmpty: [ ^ false -> nil ]. needsRefresh := false. aCollection do: [:class || copysName | copysName := UIManager default request: 'Please type new class name' initialAnswer: class name. copysName isEmptyOrNil ifFalse: [ needsRefresh ifFalse: [ needsRefresh := true ]. lastDuplicate := class duplicateClassWithNewName: copysName ]]. ^(needsRefresh -> lastDuplicate)! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 3/25/2012 20:54'! defaultGetSelectorAndSendQuery: array to: queryPerformer with: querySelector | selector | selector := UIManager default request: 'Type selector:' initialAnswer: 'flag:'. selector ifNil: [ selector := String new ]. selector := selector copyWithout: Character space. ^ selector isEmptyOrNil ifFalse: [ (Symbol hasInterned: selector ifTrue: [ :aSymbol | array at: 1 put: aSymbol. queryPerformer perform: querySelector withArguments: array ]) ifFalse: [ self inform: 'no such selector' ] ]! ! !AbstractTool methodsFor: 'category' stamp: 'StephaneDucasse 8/29/2013 20:58'! removeCategory: aCategory inClass: aClass aCategory ifNil: [ ^ self ]. self okToChange ifFalse: [ ^ self ]. (aClass organization listAtCategoryNamed: aCategory) isEmpty ifTrue: [ aClass removeProtocol: aCategory. ^ true ]. (self confirm: 'Are you sure you want to remove the protocol ', aCategory,' and all its methods?') ifTrue: [ aClass removeProtocol: aCategory. ^ true ]. ^ false! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 2/8/2013 16:11'! getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs selector: aSelector "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments. If no message is currently selected, then obtain a method name from a user type-in" | strm array | array := Array new: queryArgs size + 1. strm := array writeStream. strm nextPut: nil. strm nextPutAll: queryArgs. aSelector ifNil: [ ^ self defaultGetSelectorAndSendQuery: querySelector to: queryPerformer with: array ]. array at: 1 put: aSelector. queryPerformer perform: querySelector withArguments: array.! ! !AbstractTool methodsFor: 'private' stamp: 'SeanDeNigris 6/13/2013 08:52'! do: aBlock on: aCollection displaying: aString | job | aCollection ifEmpty: [ ^ self ]. job := [ :bar | aCollection do: [ :element | aBlock value: element. bar increment ] ] asJob. job title: aString; min: 0; max: aCollection size; run.! ! !AbstractTool methodsFor: 'method' stamp: ''! selectMessageAndEvaluate: aBlock defaultValue: aSelector "Subclass may override me to allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any" aBlock value: aSelector! ! !AbstractTool methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/17/2013 09:58'! browseAllAccessesTo: variableName from: aClass ^self systemNavigation browseAllAccessesTo: variableName from: aClass ! ! !AbstractTool methodsFor: 'method' stamp: 'MarcusDenker 10/13/2013 07:57'! removeMethods: aCollection inClass: aClass "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. " | messagesName confirmation | aCollection isEmptyOrNil ifTrue: [^ false]. aCollection size = 1 ifTrue: [ ^ self removeMethod: aCollection first inClass: aClass ]. messagesName := aCollection collect: #selector. confirmation := self systemNavigation confirmRemovalOfSelectors: messagesName on: aClass. confirmation = 3 ifTrue: [ ^ false ]. aCollection do: [:message|| messageName | messageName := message selector. (aClass includesLocalSelector: messageName) ifTrue: [ aClass removeSelector: messageName ] ifFalse: [ self removeNonLocalSelector: messageName ]]. "In case organization not cached" confirmation = 2 ifTrue: [ aCollection do: [:message || messageName | messageName := message selector. ((self systemNavigation allCallsOn: messageName) size > 0) ifTrue: [ self systemNavigation browseAllSendersOf: messageName ]]]. ^ true! ! !AbstractTool methodsFor: 'category' stamp: 'GabrielOmarCotelli 11/30/2013 16:09'! removeEmptyUnclassifiedCategoryFrom: aClass "Remove the 'as yet unclassified' category from the class if empty" | protocolOrganizer | protocolOrganizer := aClass organization protocolOrganizer. protocolOrganizer protocols detect: [ :protocol | protocol name = Protocol unclassified and: [ protocol isEmpty ] ] ifFound: [ :unclassifiedProtocol | protocolOrganizer removeProtocol: unclassifiedProtocol ]! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 16:06'! renameClass: aClass | oldName newName obs | aClass ifNil: [ ^ self ]. oldName := aClass name. newName := UIManager default request: 'Please type new class name' initialAnswer: oldName. newName isEmptyOrNil ifTrue: [ ^ self ]. "Cancel returns" newName := newName asSymbol. newName = oldName ifTrue: [ ^ self ]. (self class environment includesKey: newName) ifTrue: [ ^ self error: newName , ' already exists' ]. aClass rename: newName. obs := self systemNavigation allReferencesTo: (aClass environment associationAt: newName). obs isEmpty ifFalse: [ self systemNavigation browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName ]. ^ newName! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 6/28/2012 15:11'! methodHierarchyFrom: aMethod "Create and schedule a method browser on the hierarchy of implementors." aMethod ifNil: [ ^ self ]. self systemNavigation methodHierarchyBrowserForClass: aMethod methodClass selector: aMethod selector! ! !AbstractTool methodsFor: 'package' stamp: 'StephaneDucasse 5/28/2011 13:19'! findPackageIn: aPackageNamesList | pattern foundPackage | aPackageNamesList size = 0 ifTrue: [pattern := UIManager default request: 'Package name or fragment?'] ifFalse: [pattern := UIManager default enterOrRequestFrom: aPackageNamesList lines: #() title: 'Package name or fragment?']. pattern isEmptyOrNil ifTrue: [^ self flashPackage ]. foundPackage := self systemNavigation packageFromPattern: pattern withCaption: ''. foundPackage ifNil: [^ self flashPackage]. ^ foundPackage! ! !AbstractTool methodsFor: 'class' stamp: 'StephaneDucasse 5/28/2011 13:20'! showUnreferencedInstVarsOf: aClass "Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced" | aList aReport | (aClass isNil or: [aClass isTrait]) ifTrue: [^ self]. aList := aClass allUnreferencedInstanceVariables. aList size = 0 ifTrue: [^ UIManager default inform: 'There are no unreferenced instance variables in ', aClass name]. aReport := String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced instance variable(s) in ' translated, aClass name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. UIManager default inform: aReport! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 1/24/2013 13:58'! createInstVarAccessorsOf: aClass "Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class" | instVars | aClass ifNil: [ ^ self ]. instVars := (TickDialogWindow itemsList: aClass instVarNames copy sort itemsHeaderName: 'Inst Var Names' wrapBlockOrSelector: [:e | e ] title: 'Getter/Setter Creator' defaultValue: true) chooseFromOwner: self window. instVars ifNil: [ ^ self ]. instVars do: [:aName || setter newMessage | (aClass canUnderstand: aName asSymbol) ifFalse: [ newMessage := self buildGetterFor: aName. aClass compile: newMessage classified: 'accessing' notifying: nil]. (aClass canUnderstand: (aName, ':') asSymbol) ifFalse:[ newMessage :=self buildSetterFor: aName. aClass compile: newMessage classified: 'accessing' notifying: nil]]! ! !AbstractTool methodsFor: 'class' stamp: 'MarcusDenker 8/28/2013 16:05'! compileANewClassFrom: aString notifying: aController startingFrom: aClass " Copied from Browser " "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class newClassName defTokens keywdIx envt | oldClass := aClass. defTokens := aString findTokens: Character separators. ((defTokens first = 'Trait' and: [defTokens second = 'named:']) or: [defTokens second = 'classTrait']) ifTrue: [^ self defineTrait: aString notifying: aController ]. keywdIx := defTokens findFirst: [:x | x beginsWith: 'category']. envt := Smalltalk globals. keywdIx := defTokens findFirst: [:x | '*subclass*' match: x]. newClassName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName]) and: [envt includesKey: newClassName asSymbol]) ifTrue: ["Attempting to define new class over existing one when not looking at the original one in this browser..." (self confirm: ((newClassName , ' is an existing class in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) ifFalse: [^ nil]]. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass := oldClass superclass]. class := oldClass subclassDefinerClass new source: aString; requestor: aController; logged: true; evaluate. ^ (class isKindOf: Behavior) ifTrue: [ class ] ifFalse: [ nil ]! ! !AbstractTool class methodsFor: 'private' stamp: 'StephaneDucass 2/2/2014 09:03'! defineFullClassTemplate ^ 'Object subclass: #{1} instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''{2}'''! ! !AbstractTool class methodsFor: 'world menu' stamp: 'EstebanLorenzano 5/14/2013 09:44'! menuCommandOn: aBuilder (aBuilder item: #Tools) order: 1.0; target: self; icon: (Smalltalk ui icons iconNamed: #toolsIcon). ! ! !AbstractTool class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/8/2013 16:27'! protocolSuggestionsFor: aClass | allExistingProtocols interestingProtocols reject | reject := Set new. reject addAll: aClass organization categories; add: AllProtocol defaultName; add: Protocol nullCategory; add: Protocol unclassified. allExistingProtocols := Smalltalk allClassesAndTraits inject: Set new into: [ :col :e | col addAll: e protocols; yourself ]. interestingProtocols := allExistingProtocols reject: [ :e | reject includes: e ]. ^ interestingProtocols asOrderedCollection sort: [ :a :b | a asLowercase < b asLowercase ].! ! !AbstractTool class methodsFor: 'private' stamp: 'NicolaiHess 4/7/2014 22:46'! groupBlockFor: aPackage ^ [ aPackage orderedClasses ]! ! !AbstractTool class methodsFor: 'private' stamp: 'EstebanLorenzano 10/14/2013 16:17'! defineClassTemplate ^ 'Object subclass: #{1} instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''{2}'''! ! !AbstractTool class methodsFor: 'private' stamp: 'EstebanLorenzano 10/14/2013 16:53'! defineTraitTemplate ^ 'Trait named: #{1} uses: {2} category: ''{3}'''! ! !AbstractTool class methodsFor: 'world menu' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme ^ Smalltalk ui theme ! ! !AbstractTool class methodsFor: 'private' stamp: 'SvenVanCaekenberghe 2/1/2014 20:24'! requestProtocolNameFor: aClass initialAnswer: aString | ui | ui := ListDialogWindow new getList: [ :r | (AbstractTool protocolSuggestionsFor: aClass) select: [ :e | r search: e name ] ]; displayBlock: [ :e | e ]; initialAnswer: aString; acceptNewEntry: true; title: 'New Protocol'; yourself. ^ ui chooseFromOwner: World! ! !AbstractTreeFilter commentStamp: ''! I am an abstract class for tree filters. My children should propose a filter for tree nodes! !AbstractTreeFilter methodsFor: 'filtering' stamp: 'BenjaminVanRyseghem 4/18/2013 17:12'! keepTreeNode: aNode ^ false! ! !AbstractTutorial commentStamp: 'CamilloBruni 2/22/2014 19:03'! Parent class of all Pharo tutorials. To create your own tutorial: - subclass AbstractTutorial - implement a few methods which returns a Lesson instance - implement tutorial which returns a Collection of selectors to the methods you've created. For example, see MockTutorial (minimalist) and PharoySntaxTutorial (default PharoTutorial one). See the PharoTutorial class comment to execute your own tutorial.! !AbstractTutorial methodsFor: 'tutorial' stamp: 'LaurentLaffont 1/21/2010 13:51'! lessonAt: anInteger | lessonSelector | lessonSelector := self tutorial at: anInteger. ^ self perform: lessonSelector.! ! !AbstractTutorial methodsFor: 'accessing' stamp: 'LaurentLaffont 9/19/2010 16:35'! lessons ^ self tutorial collect: [:aSelector| self perform: aSelector]! ! !AbstractTutorial methodsFor: 'tutorial' stamp: 'DannyChan 2/1/2010 21:21'! indexOfLesson: aSelector ^self tutorial indexOf: aSelector.! ! !AbstractTutorial methodsFor: 'accessing' stamp: 'LaurentLaffont 1/21/2010 13:49'! size ^ self tutorial size! ! !AbstractTutorial methodsFor: 'printing' stamp: 'CamilloBruni 2/22/2014 18:44'! printOn: aStream aStream nextPutAll: 'a Pharo Tutorial ('; nextPutAll: self class title; nextPutAll: ')'. ! ! !AbstractTutorial methodsFor: 'tutorial' stamp: 'LaurentLaffont 1/21/2010 13:44'! tutorial "Should return an Array of selectors which returns Lesson instances. See SmalltalkSyntaxTutorial." ^ self shouldBeImplemented.! ! !AbstractTutorial class methodsFor: 'tutorial metainfo' stamp: 'LaurentLaffont 1/27/2010 21:02'! title "Return the title of the tutorial by parsing the class name like a Wiki link and interspersing whitespaces between the tokens" | className separators groups | className := self name. separators := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'. groups := className findTokens: separators keep: separators. ^' ' join: (groups pairsCollect: [ :sep :rest | sep , rest ]). ! ! !AbstractTutorial class methodsFor: 'tutorial metainfo' stamp: 'CamilloBruni 2/22/2014 19:08'! tutorials ^ (self subclasses sort: [:a :b | a name < b name]) select: [:aTutorial | (aTutorial category = 'ProfStef-Tests') not ]. ! ! !AbstractTutorialTest commentStamp: 'TorstenBergmann 2/12/2014 22:51'! SUnit tests for AbstractTutorial! !AbstractTutorialTest methodsFor: 'tests' stamp: 'LaurentLaffont 9/21/2010 20:32'! testLessonsReturnsAllLessonInstances |lessons| lessons := MockTutorial new lessons. self assert:3 equals:lessons size. self assert: 'first' equals: lessons first title. self assert: 'second' equals: (lessons at:2 ) title. self assert: 'third' equals: lessons last title.! ! !AbstractTutorialTest methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 19:10'! testTitleHumanizeClassName self assert: 'How To Make Your Own Tutorial' equals: HowToMakeYourOwnTutorial title. self assert: 'Pharo Syntax Tutorial' equals: PharoSyntaxTutorial title.! ! !AbstractTutorialTest methodsFor: 'tests' stamp: 'LaurentLaffont 4/26/2011 12:46'! testTutorialRaisesShouldBeImplemented | tutorial | tutorial := AbstractTutorial new. self should: [tutorial tutorial] raise: Error withExceptionDo: [:anException | self assert: ShouldBeImplemented equals: anException class ]. ! ! !AbstractTutorialTest methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:48'! testTutorialsReturnsAllButMockTutorial | tutorials | tutorials := AbstractTutorial tutorials. self assert: (tutorials includes: PharoSyntaxTutorial). self assert: (tutorials includes: HowToMakeYourOwnTutorial). self deny: (tutorials includes: MockTutorial).! ! !AbstractWidget commentStamp: ''! AbstractWidget is an abstraction for the different widget which could be used to compose the Nautilus UI! !AbstractWidget methodsFor: 'accessing' stamp: ''! model ^ model! ! !AbstractWidget methodsFor: 'update' stamp: ''! update: aSymbol self changed: aSymbol! ! !AbstractWidget methodsFor: 'accessing' stamp: ''! model: anObject model := anObject. anObject addDependent: self.! ! !AbstractWidget methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:34'! dragTransferTypeForMorph: dragSource ^(dragSource isKindOf: PluggableListMorph) ifTrue: [ dragSource getListElementSelector ]! ! !AbstractWidget class methodsFor: 'instance creation' stamp: ''! model: model ^ self new model: model; yourself! ! !AbstractWidgetModel commentStamp: ''! AbstractBasicWidget is an abstract class for basic widgets! !AbstractWidgetModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 5/4/2013 22:42'! eventKeyStrokesForPreviousFocus "String describing the keystroke to perform to jump to the next widget" ^ { Character arrowLeft asKeyCombination. Character tab shift asKeyCombination}! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! enabled ^ enabledHolder value! ! !AbstractWidgetModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 17:58'! defaultColor ^ Color white! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! dragTransformationBlock ^ dragTransformationBlock value! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! dropEnabled: aBoolean dropEnabled value: aBoolean! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! dragEnabled: anObject dragEnabled value: anObject! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/24/2014 17:56'! color: aColor ^ color value: aColor! ! !AbstractWidgetModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 17:58'! initialize super initialize. helpHolder := nil asReactiveVariable. borderWidth := 0 asReactiveVariable. borderColor := Color transparent asReactiveVariable. enabledHolder := true asReactiveVariable. dragEnabled := false asReactiveVariable. dropEnabled := false asReactiveVariable. dragTransformationBlock := [ :item :source | item ] asReactiveVariable. wantDropBlock := [ :draggedItem :event :source | self dropEnabled ] asReactiveVariable. acceptDropBlock := [ :draggedItem :event :source | ] asReactiveVariable. transferBlock := [:passenger :source | super transferFor: passenger from: source ] asReactiveVariable. color := self defaultColor asReactiveVariable. helpHolder whenChangedDo: [:string | self widget ifNotNil: [:w | w update: #setBalloonText: with: { string } ] ]. borderWidth whenChangedDo: [:int | self widget ifNotNil: [:w | w update: #borderWidth: with: { int } ] ]. borderColor whenChangedDo: [:newColor | self widget ifNotNil: [:w | w update: #borderColor: with: { newColor } ] ]. color whenChangedDo: [:newColor | self widget ifNotNil: [:w | w update: #color: with: { newColor } ] ]. enabledHolder whenChangedDo: [:b | self widget ifNotNil: [:w | w update: #enabled: with: { b } ] ]. dragEnabled whenChangedDo: [:b | self widget ifNotNil: [:w | w update: #dragEnabled: with: { b } ] ]. dropEnabled whenChangedDo: [:b | self widget ifNotNil: [:w | w update: #dropEnabled: with: { b } ] ].! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! dropEnabled ^ dropEnabled value! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! borderColor "Return the border color" ^ borderColor value! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! borderWidth: anInteger "Set the border width" borderWidth value: anInteger! ! !AbstractWidgetModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 17:36'! whenHelpChanged: aBlock "Set a block to be performed when the help changed" helpHolder whenChangedDo: aBlock! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! borderWidth "Return the border width" ^ borderWidth value! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:06'! enable "Enable the label" self enabled: true! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! enabled: aBoolean "Set if the button is enabled (clickable)" enabledHolder value: aBoolean! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! help: aString "Set the help string" helpHolder value: aString! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! acceptDropBlock: aBlock acceptDropBlock value: aBlock! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! dragTransformationBlock: aBlock dragTransformationBlock value: aBlock! ! !AbstractWidgetModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 5/4/2013 22:42'! eventKeyStrokesForNextFocus "String describing the keystroke to perform to jump to the next widget" ^ { Character arrowRight asKeyCombination. Character tab asKeyCombination}! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:06'! disable "Disable the label" self enabled: false! ! !AbstractWidgetModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:10'! initializeWidgets "ignore this method since there is no composition in basic widgets"! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! acceptDropBlock ^ acceptDropBlock value! ! !AbstractWidgetModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 17:36'! whenBorderWidthChanged: aBlock "Set a block to be performed when the brder width changed" borderWidth whenChangedDo: aBlock! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! transferBlock: aBlock transferBlock value: aBlock! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/24/2014 17:56'! color ^ color value! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! wantDropBlock: aBlock wantDropBlock value: aBlock! ! !AbstractWidgetModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 17:36'! whenBorderColorChanged: aBlock "Set a block to be performed when the brder width changed" borderColor whenChangedDo: aBlock! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! help "Return the ballon text" ^ helpHolder value! ! !AbstractWidgetModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! borderColor: aColor "Set the border width" borderColor value: aColor ! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! dragEnabled ^ dragEnabled value! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! transferBlock ^ transferBlock value! ! !AbstractWidgetModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 18:03'! whenEnabledChanged: aBlock "Set a block to performed when the widget is enabled or disabled" enabledHolder whenChangedDo: aBlock! ! !AbstractWidgetModel methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! wantDropBlock ^ wantDropBlock value! ! !AbstractWidgetModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:31'! defaultSpec ^ { self adapterName. #adapt:. #model }! ! !AbstractWidgetModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:31'! adapterName ^ self subclassResponsibility! ! !AbtractCache commentStamp: ''! I am Cache. I am an abstract class. I am a limited cache holding onto key/value pairs. My primary interface is #at:ifAbsentPut: which takes two arguments: a key and a block. Either the key is found (cache hit) and its value is returned, or the key is not found (cache miss). If the latter case, block should compute a new value to cache. Because block takes the key as optional argument, you can specify a factory style argument as well. With an explicit factory specified, you can also use #at: to access me. For each addition to the cache, a weight is computed by #computeWeight (a selector or block) and added to #totalWeight. When #totalWeight is no longer below #maximumWeight, the least recently used item of the cache is evicted (removed) to make room. The default #computeWeight returns 1 for each value, effectively counting the number of entries. The default #maximumWeight is 16. I count hits and misses and can return my #hitRatio. Optionally, but not by default, I can be configured so that it is safe to access me from different threads/processess during my important operations. See #beThreadSafe.! !AbtractCache methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/9/2013 22:01'! at: key ifAbsentPut: block "If key is present in the cache, return the associated value. This is a hit and makes that key/value pair the most recently used. If key is absent, use block to compute a new value and cache it. Block can optionally take one argument, the key. This is a miss and will create a new key/value pair entry. Furthermore this could result in the least recently used key/value pair being removed when the specified maximum cache weight is exceeded." self subclassResponsibility ! ! !AbtractCache methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/9/2013 22:02'! maximumWeight: limit "Set my maximum allowed total weight of all cached values to limit. If the total weight is no longer below limit, the least recently used key/value pair will be removed. The default maximum weight limit is 16." weight maximum: limit! ! !AbtractCache methodsFor: 'accessing - statistics' stamp: 'SvenVanCaekenberghe 12/9/2013 21:59'! misses "Return how many misses, requests for keys not present I received." ^ statistics misses! ! !AbtractCache methodsFor: 'accessing - statistics' stamp: 'SvenVanCaekenberghe 12/9/2013 22:00'! size "Return the count of items currently present." self subclassResponsibility ! ! !AbtractCache methodsFor: 'private' stamp: 'SvenVanCaekenberghe 12/9/2013 22:21'! critical: block ^ access ifNil: block ifNotNil: [ access critical: block ]! ! !AbtractCache methodsFor: 'removing' stamp: 'SvenVanCaekenberghe 12/9/2013 22:03'! removeKey: key "If I currently cache key, remove the entry. Signal a KeyNotFound when I currently do not cache key. Return the removed value." ^ self removeKey: key ifAbsent: [ KeyNotFound signalFor: key in: self ]! ! !AbtractCache methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/11/2013 15:36'! beThreadSafe "Configure me so that I can be safely used from multiple threads/processes during important operations. Note that this slows down these operations." access := Monitor new! ! !AbtractCache methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! initialize super initialize. weight := CacheWeight new. statistics := CacheStatistics new! ! !AbtractCache methodsFor: 'removing' stamp: 'SvenVanCaekenberghe 12/9/2013 22:04'! removeKey: key ifAbsent: block "If I currently cache key, remove the entry. Execute block when key is currently absent. Return the removed value." self subclassResponsibility ! ! !AbtractCache methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/9/2013 22:00'! at: key "If key is present in the cache, return the associated value. This is a hit and makes that key/value pair the most recently used. If key is absent, use the factory to compute a new value and cache it. This is a miss and will create a new key/value pair entry. Furthermore this could result in the least recently used key/value pair being removed when the specified maximum cache weight is exceeded. A factory is required for this behavior." ^ self at: key ifAbsentPut: (factory ifNil: [ self error: 'No factory specified' ])! ! !AbtractCache methodsFor: 'accessing - statistics' stamp: 'SvenVanCaekenberghe 12/9/2013 21:59'! hits "Return how many hits, requests for keys present I received." ^ statistics hits! ! !AbtractCache methodsFor: 'accessing - statistics' stamp: 'SvenVanCaekenberghe 12/9/2013 21:59'! hitRatio "Return the ratio of hits against total calls I received. This will be a number between 0 and 1. When I am empty, return 0." ^ statistics hitRatio! ! !AbtractCache methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 12/9/2013 22:02'! printOn: stream super printOn: stream. stream nextPut: $(. self printElementsOn: stream. stream nextPut: $)! ! !AbtractCache methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/9/2013 22:02'! factory: block "Set the factory to compute values from keys to block. The factory will be evaluated for each key not present. Only my #at: message will use the factory." factory := block! ! !AbtractCache methodsFor: 'accessing - statistics' stamp: 'SvenVanCaekenberghe 12/9/2013 22:00'! totalWeight "Return the total weight of all cached values currently present." ^ weight total! ! !AbtractCache methodsFor: 'enumerating' stamp: 'SvenVanCaekenberghe 12/9/2013 22:06'! keysAndValuesDo: block "Execute block with each key and value present in me. This will be from least to most recently used." self subclassResponsibility ! ! !AbtractCache methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 12/9/2013 22:03'! printElementsOn: stream stream nextPut: $#; print: self size. stream space; print: weight total; nextPut: $/; print: weight maximum. stream space; print: weight compute. factory ifNotNil: [ stream space; print: factory ]. stream space; print: (self hitRatio * 100.0) rounded ; nextPut: $%! ! !AbtractCache methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/9/2013 22:02'! computeWeight: valuable "Set the way to compute the weight of each cached value. This can be either a Symbol or one argument block. When the total weight is no longer below the maximum weight, the least recently used key/value pair will be removed. The default way to compute the weight returns 1 for each value, effectively counting the number of cached values." weight compute: valuable! ! !AbtractCache methodsFor: 'removing' stamp: 'SvenVanCaekenberghe 12/9/2013 22:03'! removeAll "Remove all key/value pairs that I currently hold, effectiley resetting me, but not my statistics." self subclassResponsibility ! ! !AddedField commentStamp: ''! I represent the change of a newly added field on an instance.! !AddedField methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:07'! installOn: aModification aModification installAddedSlot: self! ! !AddedField methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 17:19'! newFieldIndex ^ newSlot index + fieldIndex! ! !AddedField methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 19:48'! name ^ newSlot name! ! !AddedField methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 16:35'! newSlot ^ newSlot! ! !AddedField methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 16:35'! newSlot: anObject newSlot := anObject! ! !AdditionalMethodState commentStamp: ''! I am class holding state for compiled methods. All my instance variables should be actually part of the CompiledMethod itself, but the current implementation of the VM doesn't allow this. Currently I hold the selector and any pragmas or properties the compiled method has. Pragmas and properties are stored in indexable fields; pragmas as instances of Pragma, properties as instances of Association. I am a reimplementation of much of MethodProperties, but eliminating the explicit properties and pragmas dictionaries. Hence I answer true to isMethodProperties.! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/3/2013 11:42'! analogousCodeTo: aMethodProperties | bs | self class == aMethodProperties class ifFalse: [^false]. (bs := self basicSize) = aMethodProperties basicSize ifFalse: [^false]. 1 to: bs do: [:i| ((self basicAt: i) analogousCodeTo: (aMethodProperties basicAt: i)) ifFalse: [^false]]. ^true! ! !AdditionalMethodState methodsFor: 'decompiling' stamp: 'eem 6/11/2009 17:06'! method: aMethodNodeOrNil "For decompilation" method := aMethodNodeOrNil! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! selector ^selector! ! !AdditionalMethodState methodsFor: 'copying' stamp: 'eem 9/16/2011 11:27'! copyWithout: aPropertyOrPragma "" "Answer a copy of the receiver which no longer includes aPropertyOrPragma" | bs copy offset | "no need to initialize here; we're copying all inst vars" copy := self class basicNew: (bs := self basicSize) - ((self includes: aPropertyOrPragma) ifTrue: [1] ifFalse: [0]). offset := 0. 1 to: bs do: [:i| (self basicAt: i) = aPropertyOrPragma ifTrue: [offset := 1] ifFalse: [copy basicAt: i - offset put: (self basicAt: i) shallowCopy]]. 1 to: self class instSize do: [:i| copy instVarAt: i put: (self instVarAt: i)]. ^copy! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 14:11'! pragmas "Answer the raw messages comprising my pragmas." | pragmaStream | pragmaStream := WriteStream on: (Array new: self basicSize). 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: [pragmaStream nextPut: propertyOrPragma]]. ^pragmaStream contents! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 19:32'! removeKey: aKey ifAbsent: aBlock "Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma key] ifFalse: [propertyOrPragma keyword]) == aKey ifTrue: [^method removeProperty: aKey]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'CamilloBruni 4/27/2012 17:47'! at: aKey ifPresent: aBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer self." ^ aBlock value: (self at: aKey ifAbsent: [ ^ self ])! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 10:19'! at: aKey "Answer the property value or pragma associated with aKey." ^self at: aKey ifAbsent: [self error: 'not found']! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'nice 11/8/2009 12:27'! hasAtLeastTheSamePropertiesAs: aMethodProperties "Answer if the recever has at least the same properties as the argument. N.B. The receiver may have additional properties and still answer true." aMethodProperties keysAndValuesDo: [:k :v| (v isKindOf: Pragma) "ifTrue: [Pragmas have already been checked]" ifFalse: [ (self includes: k->v) ifFalse: [^false]]]. ^true! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:55'! at: aKey ifAbsent: aBlock "Answer the property value or pragma associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [^propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value] ifFalse: [propertyOrPragma]]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'printing' stamp: 'eem 9/14/2011 17:18'! printOn: aStream super printOn: aStream. aStream space; nextPut: $(; print: self identityHash; nextPut: $)! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 10:53'! includesKey: aKey "Test if the property aKey or pragma with selector aKey is present." 1 to: self basicSize do: [:i | (self basicAt: i) key == aKey ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 11:46'! propertyValueAt: aKey "Answer the property value associated with aKey." ^ self propertyValueAt: aKey ifAbsent: [ self error: 'Property not found' ].! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 12/1/2008 10:54'! at: aKey ifAbsentPut: aBlock "Answer the property value or pragma associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [^propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value] ifFalse: [propertyOrPragma]]]. ^method propertyValueAt: aKey put: aBlock value! ! !AdditionalMethodState methodsFor: 'copying' stamp: 'eem 9/16/2011 11:26'! copyWith: aPropertyOrPragma "" "Answer a copy of the receiver which includes aPropertyOrPragma" | bs copy | (Association == aPropertyOrPragma class or: [Pragma == aPropertyOrPragma class]) ifFalse: [self error: self class name, ' instances should hold only Associations or Pragmas.']. "no need to initialize here; we're copying all inst vars" copy := self class basicNew: (bs := self basicSize) + 1. 1 to: bs do: [:i| copy basicAt: i put: (self basicAt: i) shallowCopy]. copy basicAt: bs + 1 put: aPropertyOrPragma. 1 to: self class instSize do: [:i| copy instVarAt: i put: (self instVarAt: i)]. ^copy! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 18:28'! setMethod: aMethod method := aMethod. 1 to: self basicSize do: [:i| | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifFalse: [propertyOrPragma setMethod: aMethod]]! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/29/2008 13:47'! isEmpty ^self basicSize = 0! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 10:28'! includesProperty: aKey "Test if the property aKey is present." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding and: [propertyOrPragma key == aKey]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 10:25'! properties | propertyStream | propertyStream := WriteStream on: (Array new: self basicSize * 2). 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [propertyStream nextPut: propertyOrPragma key; nextPut: propertyOrPragma value]]. ^IdentityDictionary newFromPairs: propertyStream contents! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 10:18'! propertyKeysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value]]! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'GabrielBarbuto 11/30/2010 11:30'! method ^method.! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'lr 2/6/2006 20:48'! removeKey: aKey "Remove the property with aKey. Answer the property or raise an error if aKey isn't found." ^ self removeKey: aKey ifAbsent: [ self error: 'Property not found' ].! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'! isMethodProperties ^true! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! selector: aSymbol selector := aSymbol! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 10:53'! includes: aPropertyOrPragma "" "Test if the property or pragma is present." 1 to: self basicSize do: [:i | (self basicAt: i) = aPropertyOrPragma ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 16:49'! notEmpty ^self basicSize > 0! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'Alexandre Bergel 12/21/2009 23:53'! at: aKey put: aValue "Replace the property value or pragma associated with aKey." | keyAlreadyExists | keyAlreadyExists := false. 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) key == aKey ifTrue: [ keyAlreadyExists := true. propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma value: aValue] ifFalse: [self basicAt: i put: aValue]]]. keyAlreadyExists ifFalse: [ method propertyValueAt: aKey put: aValue ]. ^ aValue ! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'JohanBrichau 10/7/2009 20:07'! refersToLiteral: aLiteral ^ self pragmas anySatisfy: [ :pragma | pragma hasLiteral: aLiteral ]! ! !AdditionalMethodState methodsFor: 'copying' stamp: 'eem 9/14/2011 17:50'! postCopy "After copying we must duplicate any associations and pragmas so they don't end up being shared." 1 to: self basicSize do: [:i| self basicAt: i put: (self basicAt: i) shallowCopy]! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'eem 11/29/2008 18:36'! keysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values." 1 to: self basicSize do: [:i | | propertyOrPragma "" | (propertyOrPragma := self basicAt: i) isVariableBinding ifTrue: [aBlock value: propertyOrPragma key value: propertyOrPragma value] ifFalse: [aBlock value: propertyOrPragma keyword value: propertyOrPragma]]! ! !AdditionalMethodState methodsFor: 'properties' stamp: 'eem 11/29/2008 11:45'! propertyValueAt: aKey ifAbsent: aBlock "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding and: [propertyOrPragma key == aKey]) ifTrue: [^propertyOrPragma value]]. ^aBlock value! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 11/29/2008 16:40'! hasLiteralThorough: literal "Answer true if any literal in these properties is literal, even if embedded in array structure." 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [propertyOrPragma key == literal or: [propertyOrPragma value == literal or: [propertyOrPragma value isArray and: [propertyOrPragma value hasLiteral: literal]]]] ifFalse: [propertyOrPragma hasLiteral: literal]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'bgf 12/6/2008 12:15'! hasLiteralSuchThat: aBlock "Answer true if litBlock returns true for any literal in this array, even if embedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" 1 to: self basicSize do: [:i | | propertyOrPragma "" | propertyOrPragma := self basicAt: i. (propertyOrPragma isVariableBinding ifTrue: [(aBlock value: propertyOrPragma key) or: [(aBlock value: propertyOrPragma value) or: [propertyOrPragma value isArray and: [propertyOrPragma value hasLiteralSuchThat: aBlock]]]] ifFalse: [propertyOrPragma hasLiteralSuchThat: aBlock]) ifTrue: [^true]]. ^false! ! !AdditionalMethodState class methodsFor: 'instance creation' stamp: 'eem 9/16/2011 11:26'! selector: aSelector with: aPropertyOrPragma ^(self new: 1) selector: aSelector; basicAt: 1 put: aPropertyOrPragma; yourself! ! !AdditionalMethodState class methodsFor: 'instance creation' stamp: 'eem 9/16/2011 11:25'! forMethod: aMethod selector: aSelector ^(self new: 0) selector: aSelector; setMethod: aMethod; yourself! ! !AdditionalMethodStateTest commentStamp: 'TorstenBergmann 2/5/2014 08:30'! SUnit tests for AdditionalMethodState! !AdditionalMethodStateTest methodsFor: 'tests' stamp: 'MaxLeske 1/25/2014 22:14'! testAnalogousCodeTo "create a fake traitSource association property" | state | state := AdditionalMethodState new: 1. state basicAt: 1 put: #traitSource -> (TBehavior methodNamed: #>>). self shouldnt: [ state analogousCodeTo: state ] raise: MessageNotUnderstood! ! !AdditionalMethodStateTest methodsFor: 'tests' stamp: 'GabrielBarbuto 11/30/2010 11:29'! testCopy | copy | copy := atState copy. self deny: atState == copy. self assert: atState method == copy method. self assert: atState selector == copy selector. self assert: atState pragmas = copy pragmas. self assert: atState properties = copy properties. 1 to: atState pragmas size do: [:index | self deny: (atState pragmas at: index) == (copy pragmas at: index)].! ! !AdditionalMethodStateTest methodsFor: 'running' stamp: 'MarcusDenker 12/6/2013 13:00'! setUp | pragma | pragma := (Object compiledMethodAt: #at:) penultimateLiteral at: #primitive:. atState := AdditionalMethodState selector: #at: with: pragma copy. ! ! !Adler32 commentStamp: ''! The Adler32 checksum algorithm was developed by Mark Adler for his ZLib algorithm. It is defined in IETF RFC 1950: http://tools.ietf.org/html/rfc1950#page-10. The purpose of this class is mainly grouping as the ZipPlugin already implements Adler32. See also the comment in #update:from:to:in: Note that Adler32 is not a CRC, strictly speaking.! !Adler32 class methodsFor: 'primitives' stamp: 'MaxLeske 7/8/2013 21:20'! update: adler from: start to: stop in: aCollection "Update crc using the Adler32 checksum technique from RFC1950" " unsigned long s1 = adler & 0xffff; unsigned long s2 = (adler >> 16) & 0xffff; int n; for (n = 0; n < len; n++) { s1 = (s1 + buf[n]) % BASE; s2 = (s2 + s1) % BASE; } return (s2 << 16) + s1; " | s1 s2 | s1 := adler bitAnd: 16rFFFF. s2 := (adler bitShift: -16) bitAnd: 16rFFFF. start to: stop do: [ :n | | b | b := aCollection byteAt: n. s1 := (s1 + b) \\ 65521. s2 := (s2 + s1) \\ 65521. ]. ^(s2 bitShift: 16) + s1! ! !AdvancedHelpBrowserDummy commentStamp: 'tbn 5/3/2010 19:30'! This is a dummy for a custom Help browser that can be registered as a replacement for the HelpBrowser class. Instance Variables rootTopic: rootTopic - The root help topic ! !AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: 'tbn 5/3/2010 19:32'! open isOpen := true! ! !AdvancedHelpBrowserDummy methodsFor: 'initialization' stamp: 'tbn 5/3/2010 19:34'! initialize isOpen := false! ! !AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: 'tbn 5/3/2010 19:33'! rootTopic ^rootTopic! ! !AdvancedHelpBrowserDummy methodsFor: 'testing' stamp: 'tbn 5/3/2010 19:32'! isOpen ^isOpen! ! !AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: 'tbn 5/3/2010 19:33'! rootTopic: aTopic rootTopic := aTopic! ! !AlertDialogWindow commentStamp: 'gvc 5/18/2007 13:52'! Message dialog with a warning icon.! !AlertDialogWindow methodsFor: 'visual properties' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon "Answer an icon for the receiver." ^ Smalltalk ui icons warningIcon! ! !AlertDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallWarningIcon! ! !AlexPlugin commentStamp: ''! An AlexPlugin is a plugin which show the setUp when a test method is selected! !AlexPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 8/21/2011 11:49'! registerTo: aModel aModel announcer on: NautilusMethodSelected send: #methodSelected: to: self.! ! !AlexPlugin methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 8/21/2011 12:08'! initialize text := ''. container := PanelMorph new color: Color transparent; changeTableLayout; cellInset: 8; listDirection: #topToBottom; cellPositioning: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap. self buildTextMorph! ! !AlexPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/21/2011 12:03'! updateContainer ^ text isEmpty ifTrue: [ container removeMorph: textMorph. container hide ] ifFalse: [ container addMorph: textMorph. container show ]! ! !AlexPlugin methodsFor: 'updating' stamp: 'MarcusDenker 4/29/2012 10:32'! methodSelected: anAnnouncement anAnnouncement method ifNotNil: [:method | ( method methodClass inheritsFrom: TestCase ) ifTrue: [ text := (method methodClass lookupSelector: #setUp) sourceCode ]] ifNil: [ text := ''] . self changed: #getText. self updateContainer! ! !AlexPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/21/2011 11:43'! getText ^ text! ! !AlexPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/21/2011 11:54'! buildTextMorph textMorph := PluggableTextMorph on: self text: #getText accept: nil! ! !AlexPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 8/21/2011 11:52'! display ^ container! ! !AlexPlugin class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 8/25/2011 10:02'! defaultPosition ^ #middle! ! !AlexPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 2/17/2012 16:42'! description ^ 'Display the setUp of test methods'! ! !AlignmentMorph commentStamp: 'kfr 10/27/2003 10:25'! Used for layout. Since all morphs now support layoutPolicy the main use of this class is no longer needed. Kept around for compability. Supports a few methods not found elsewhere that can be convenient, eg. newRow ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARowCentered: aCollectionOfMorphs cellInset: cellInsetInteger ^(self addARow: aCollectionOfMorphs) hResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter; cellInset: cellInsetInteger! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 1.0 b: 0.8! ! !AlignmentMorph methodsFor: 't-rotating' stamp: ''! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:54'! inARightColumn: aCollectionOfMorphs | col | col := self class newColumn color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #bottomRight; cellPositioning: #topCenter. aCollectionOfMorphs do: [:each | col addMorphBack: each]. ^ col! ! !AlignmentMorph methodsFor: 't-rotating' stamp: ''! heading "Return the receiver's heading" ^ self owner ifNil: [self forwardDirection] ifNotNil: [self forwardDirection + self owner degreesOfFlex]! ! !AlignmentMorph methodsFor: 't-rotating' stamp: ''! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:53'! inAColumn: aCollectionOfMorphs | col | col := self class newColumn color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [ :each | col addMorphBack: each]. ^col! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARowCentered: aCollectionOfMorphs ^(self addARow: aCollectionOfMorphs) hResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'stephane.ducasse 1/15/2009 15:58'! initialize super initialize. self layoutPolicy: TableLayout new; listDirection: #leftToRight; wrapCentering: #topLeft; hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 2; rubberBandCells: true "from AlignmentMorphBob1which was merged in this class, in an effort to remove alignementBob1 and still preserving the addInRow behavior" " self listDirection: #topToBottom. self layoutInset: 0. self hResizing: #rigid. self vResizing: #rigid"! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addAColumn: aCollectionOfMorphs | col | col := self inAColumn: aCollectionOfMorphs. self addMorphBack: col. ^col! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'stephane.ducasse 1/15/2009 15:55'! inARow: aCollectionOfMorphs | row | row := self class newRow color: Color transparent; vResizing: #shrinkWrap; layoutInset: 2; wrapCentering: #center; cellPositioning: #leftCenter. aCollectionOfMorphs do: [:each | row addMorphBack: each]. ^ row! ! !AlignmentMorph methodsFor: 'classification' stamp: 'di 5/7/1998 01:20'! isAlignmentMorph ^ true ! ! !AlignmentMorph methodsFor: 't-rotating' stamp: ''! prepareForRotating "If I require a flex shell to rotate, then wrap it in one and return it. Polygons, eg, may override to do nothing." ^ self addFlexShell! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:34'! openInWindowLabeled: aString inWorld: aWorld self layoutInset: 0. ^super openInWindowLabeled: aString inWorld: aWorld.! ! !AlignmentMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 15:58'! wantsKeyboardFocusFor: aSubmorph aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true]. ^ super wantsKeyboardFocusFor: aSubmorph! ! !AlignmentMorph methodsFor: 't-rotating' stamp: ''! setDirectionFrom: aPoint | delta degrees | delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition. degrees := delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! !AlignmentMorph methodsFor: 't-rotating' stamp: ''! rotationDegrees: degrees "redefined in all morphs which are using myself"! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARow: aCollectionOfMorphs | row | row := self inARow: aCollectionOfMorphs. self addMorphBack: row. ^row! ! !AlignmentMorph methodsFor: 't-rotating' stamp: ''! rotationDegrees "Default implementation." ^ 0.0 ! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:37'! newVariableTransparentSpacer "Answer a space-filling instance of me of the given color." ^ self new hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 0; extent: 1@1; color: Color transparent ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:50'! newRow ^ self new listDirection: #leftToRight; hResizing: #spaceFill; vResizing: #spaceFill; extent: 1@1; borderWidth: 0 ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:37'! newSpacer: aColor "Answer a space-filling instance of me of the given color." ^ self new hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 0; extent: 1@1; color: aColor. ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/5/2001 15:11'! inARow: aCollectionOfMorphs "Answer a row-oriented AlignmentMorph holding the given collection" | aRow | aRow := self newRow color: Color transparent; vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 1; borderColor: Color black; borderWidth: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [ :each | aRow addMorphBack: each]. ^ aRow! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:51'! newColumn ^ self new listDirection: #topToBottom; hResizing: #spaceFill; extent: 1@1; vResizing: #spaceFill ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'! rowPrototype "Answer a prototypical row" | sampleMorphs aRow | sampleMorphs := (1 to: (2 + 3 atRandom)) collect: [:integer | EllipseMorph new extent: ((60 + (20 atRandom)) @ (80 + ((20 atRandom)))); color: Color random; setNameTo: ('egg', integer asString); yourself]. aRow := self inARow: sampleMorphs. aRow setNameTo: 'Row'. aRow enableDragNDrop. aRow cellInset: 6. aRow layoutInset: 8. aRow setBalloonText: 'Things dropped into here will automatically be organized into a row. Once you have added your own items here, you will want to remove the sample colored eggs that this started with, and you will want to change this balloon help message to one of your own!!' translated. aRow color: Color veryVeryLightGray. ^ aRow "AlignmentMorph rowPrototype openInHand"! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/2/2001 04:45'! inAColumn: aCollectionOfMorphs "Answer a columnar AlignmentMorph holding the given collection" | col | col := self newColumn color: Color transparent; vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 1; borderColor: Color black; borderWidth: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [:each | col addMorphBack: each]. ^ col! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'! columnPrototype "Answer a prototypical column" | sampleMorphs aColumn | sampleMorphs := #(red yellow green) collect: [:aColor | Morph new extent: 130 @ 38; color: (Color perform: aColor); setNameTo: aColor asString; yourself]. aColumn := self inAColumn: sampleMorphs. aColumn setNameTo: 'Column'. aColumn color: Color veryVeryLightGray. aColumn cellInset: 4; layoutInset: 6. aColumn enableDragNDrop. aColumn setBalloonText: 'Things dropped into here will automatically be organized into a column. Once you have added your own items here, you will want to remove the sample colored rectangles that this started with, and you will want to change this balloon help message to one of your own!!' translated. ^ aColumn! ! !AllInstVarsEyeElement commentStamp: ''! I am an eye element for all inst vars, printing a description of all the instance vriables (usually second field in the inspector)! !AllInstVarsEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 11:36'! label ^ 'all inst vars'! ! !AllInstVarsEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2013 17:30'! description ^ self host longPrintStringLimitedTo: 2000! ! !AllProtocol commentStamp: ''! An AllProtocol is a special protocol to hanlde the "all" case! !AllProtocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:15'! protocolOrganizer: anObject protocolOrganizer := anObject.! ! !AllProtocol methodsFor: 'testing' stamp: 'EstebanLorenzano 11/29/2013 16:11'! canBeRenamed ^ false! ! !AllProtocol methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/29/2013 15:57'! name: aString self error: 'You cannot change my name'.! ! !AllProtocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:15'! methods ^ self protocolOrganizer allMethods! ! !AllProtocol methodsFor: 'testing' stamp: 'EstebanLorenzano 11/29/2013 16:04'! canBeRemoved ^ false! ! !AllProtocol methodsFor: 'testing' stamp: 'EstebanLorenzano 6/27/2013 15:53'! isVirtualProtocol ^ true! ! !AllProtocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 14:50'! name ^ (self methods isEmpty and: [ protocolOrganizer protocols isEmpty]) ifTrue: [ self class nullCategory ] ifFalse: [ name ]! ! !AllProtocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:15'! protocolOrganizer ^ protocolOrganizer! ! !AllProtocol class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/12/2012 14:14'! protocolOrganizer: protocolOrganizer ^ self new protocolOrganizer: protocolOrganizer; yourself! ! !AllProtocol class methodsFor: 'data' stamp: 'MarcusDenker 4/11/2014 15:15'! defaultName ^ #'-- all --'! ! !AllocationTest commentStamp: 'StephaneDucasse 12/18/2009 12:03'! Test originally from Andreas Raab! !AllocationTest methodsFor: 'testing' stamp: 'StephaneDucasse 4/23/2010 16:12'! testOneMegAllocation "Documentating a weird bug in the allocator" | sz array failed | failed := false. sz := 1024*1024. array := [Array new: sz] on: OutOfMemory do: [:ex| failed := true]. self assert: (failed or:[array size = sz]). ! ! !AllocationTest methodsFor: 'testing' stamp: 'StephaneDucasse 4/23/2010 16:11'! testOneGigAllocation "Documentating a weird bug in the allocator" | sz array failed | failed := false. sz := 1024*1024*1024. array := [Array new: sz] on: OutOfMemory do: [:ex| failed := true]. self assert: (failed or:[array size = sz]). ! ! !AllocationTest methodsFor: 'testing' stamp: 'MarcusDenker 8/20/2011 13:38'! testOutOfMemorySignal "Ensure that OOM is signaled eventually" | sz | sz := 512*1024*1024. "work around the 1GB alloc bug" self should: [(1 to: 2000) collect: [:i| Array new: sz]] raise: OutOfMemory. "Call me when this test fails, I want your machine" sz := 1024*1024*1024*1024. self should:[Array new: sz] raise: OutOfMemory. ! ! !AlphaBlendingCanvas commentStamp: 'LaurentLaffont 2/23/2011 20:17'! see ColorMappingCanvas comment.! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha: newAlpha alpha := newAlpha.! ! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha ^alpha! ! !AlphaBlendingCanvas methodsFor: 'drawing-images' stamp: 'gvc 9/1/2008 16:31'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle. Do a blendAlpha if the rule is blend to cope with translucent images being drawn (via translucentImage:...)." rule = Form paint ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form paintAlpha alpha: alpha. ]. rule = Form over ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form blendAlpha alpha: alpha. ]. rule = Form blend ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form blendAlpha alpha: alpha. ].! ! !AlphaBlendingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:18'! on: aCanvas myCanvas := aCanvas. alpha := 1.0.! ! !AlphaBlendingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:23'! mapColor: aColor aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..." aColor isTransparent ifTrue:[^aColor]. aColor isOpaque ifTrue:[^aColor alpha: alpha]. ^aColor alpha: (aColor alpha * alpha)! ! !AlphaImageMorph commentStamp: 'gvc 5/18/2007 13:52'! Displays an image with the specified alpha value (translucency) and optional scale and layout (scaled, top-right etc.).! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/4/2011 13:04'! layout: aSymbol "Set the value of layout" |old| (old := layout) = aSymbol ifTrue: [^self]. layout := aSymbol. ((old = #scaled or: [old = #scaledAspect]) or: [aSymbol = #scaled or: [aSymbol = #scaledAspect]]) ifTrue: [self cachedForm: nil]. self changed! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 12:40'! defaultColor "Answer the default color for the receiver." ^Color transparent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:56'! enabled "Answer the value of enabled" ^enabled! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'GaryChambers 10/5/2011 15:14'! displayBounds "Answer a rectangle in display coordinates that bounds the image (may be larger/smaller than visible area). Just one rep for the tiled case." ^self layoutPosition extent: self cachedForm extent ! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/27/2006 15:02'! cachedForm: anObject "Set the value of cachedForm" cachedForm := anObject! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 3/5/2012 13:28'! image: aForm size: aPoint "Set the image to be the form scaled to the given size and padded if neccesary." |f| "Convert color forms etc. to 32 bit before resizing since scaling of ColorForm introduces degraded color resolution. Most noticable with grayscale forms." (aForm depth < 32 and: [aForm depth > 4]) ifTrue: [f := Form extent: aPoint depth: 32. f fillColor: (Color white alpha: 0.003922). f getCanvas translucentImage: aForm at: 0@0. f fixAlpha] ifFalse: [f := aForm]. f := f scaledToSize: aPoint. self autoSize ifTrue: [super image: f] ifFalse: [image := f. self changed]. self cachedForm: nil. self changed: #imageExtent! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 2/3/2010 17:55'! initialize "Initialize the receiver. Use the 32 bit depth default image to avoid unnecessary conversions." enabled := true. autoSize := true. scale := 1.0. layout := #topLeft. alpha := 1.0. super initialize! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/26/2006 09:40'! alpha "Answer the value of alpha" ^ alpha! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:43'! scale "Answer the value of scale" ^ scale! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'StephaneDucasse 5/23/2013 18:06'! imageRectangleFromDisplayRectangle: aRectangle "Answer a rectangle in (original) image coordinates that corresponds to the given rectangle (in relative display coordinates)." |db| db := self displayBounds . db area = 0 ifTrue: [^db]. self layout == #scaledAspect ifTrue: [ ^((aRectangle translateBy: self layoutPosition negated) scaleBy: self form width / db width) rounded]. self layout == #scaled ifTrue: [ ^((aRectangle translateBy: self layoutPosition negated) scaleBy: (self form width / db width) @ (self form height / db height)) rounded]. ^self scale = 1 ifTrue: [aRectangle translateBy: self layoutPosition negated] ifFalse: [((aRectangle translateBy: self layoutPosition negated) scaleBy: 1 / self scale) rounded]! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'StephaneDucasse 5/23/2013 18:07'! optimalExtent "Answer the optimal extent for the receiver." ^self form extent * self scale + (self borderWidth * 2)! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:34'! alpha: anObject "Set the value of alpha" alpha := anObject. self cachedForm: nil; changed; changed: #alpha! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:57'! enabled: anObject "Set the value of enabled" enabled := anObject. self cachedForm: nil; changed! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/28/2006 14:15'! image: anImage "Clear the cached form." ^self image: anImage size: anImage extent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/4/2011 13:04'! layoutSymbols "Answer the available layout options." ^#(#center #tiled #scaled #scaledAspect #topLeft #topCenter #topRight #rightCenter #bottomRight #bottomCenter #bottomLeft #leftCenter)! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 18:07'! scaledImage "Answer the image scaled as required." |i| i := self form. i boundingBox area = 0 ifTrue: [^i]. (self layout == #scaled and: [self extent ~= i extent]) ifTrue: [ ^i magnify: i boundingBox by: (self extent / i extent) smoothing: 2]. (self layout == #scaledAspect and: [self extent ~= i extent]) ifTrue: [ ^self width / i width > (self height / i height) ifTrue: [i magnify: i boundingBox by: (self height / i height) smoothing: 2] ifFalse: [i magnify: i boundingBox by: (self width / i width) smoothing: 2]]. self scale ~= 1 ifTrue: [ ^i magnify: i boundingBox by: self scale smoothing: 2]. ^i! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'GaryChambers 8/4/2011 13:06'! extent: aPoint "Allow as normal." self perform: #extent: withArguments: {aPoint} inSuperclass: Morph. (self layout = #scaled or: [self layout = #scaledAspect]) ifTrue: [self cachedForm: nil] ! ! !AlphaImageMorph methodsFor: 'drawing' stamp: 'gvc 8/8/2007 16:25'! drawOn: aCanvas "Draw with the current alpha Can't do simple way since BitBlt rules are dodgy!!." aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle. (self cachedForm width = 0 or: [self cachedForm height = 0]) ifTrue: [^self]. self layout == #tiled ifTrue: [aCanvas fillRectangle: self innerBounds fillStyle: (AlphaInfiniteForm with: self cachedForm)] ifFalse: [aCanvas clipBy: self innerBounds during: [:c | c translucentImage: self cachedForm at: self layoutPosition]]! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 18:06'! imageExtent "Answer the extent of the original form." ^self form extent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:22'! getImageSelector ^ getImageSelector! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:23'! update: aSymbol "Update the image if changed." super update: aSymbol. aSymbol = self getImageSelector ifTrue: [ self updateImage]! ! !AlphaImageMorph methodsFor: 'geometry' stamp: 'GaryChambers 8/4/2011 13:07'! layoutPosition "Answer the position that the cached form should be drawn based on the layout" self layout == #topCenter ifTrue: [^self innerBounds topCenter - (self cachedForm width // 2 @ 0)]. self layout == #topRight ifTrue: [^self innerBounds topRight - (self cachedForm width @ 0)]. self layout == #rightCenter ifTrue: [^self innerBounds rightCenter - (self cachedForm width @ (self cachedForm height // 2))]. self layout == #bottomRight ifTrue: [^self innerBounds bottomRight - self cachedForm extent]. self layout == #bottomCenter ifTrue: [^self innerBounds bottomCenter - (self cachedForm width // 2 @ self cachedForm height)]. self layout == #bottomLeft ifTrue: [^self innerBounds bottomLeft - (0 @ self cachedForm height)]. self layout == #leftCenter ifTrue: [^self innerBounds leftCenter - (0 @ (self cachedForm height // 2))]. (self layout == #center or: [self layout == #scaledAspect]) ifTrue: [^self innerBounds center - (self cachedForm extent // 2)]. ^self innerBounds topLeft! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:00'! layout "Answer the value of layout" ^ layout! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:32'! model ^ model! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:35'! updateImage "Get the image from the model." (self model notNil and: [self getImageSelector notNil]) ifTrue: [ (self model perform: self getImageSelector) ifNotNil: [:i | self image: i]]! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:22'! getImageSelector: anObject getImageSelector := anObject! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/4/2011 12:59'! cachedForm "Answer the value of cachedForm" |form i effectiveAlpha| cachedForm ifNil: [ i := self scaledImage. effectiveAlpha := self enabled ifTrue: [self alpha] ifFalse: [self alpha / 2]. effectiveAlpha = 1.0 ifTrue: [self cachedForm: i] ifFalse: [form := Form extent: i extent depth: 32. form fillColor: (Color white alpha: 0.003922). (form getCanvas asAlphaBlendingCanvas: effectiveAlpha) drawImage: i at: 0@0. self cachedForm: form]]. ^cachedForm! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 2/3/2010 17:46'! autoSize: anObject "Set the value of autoSize" autoSize := anObject! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:34'! scale: aNumber "Set the value of scale" scale = aNumber ifTrue: [^self]. scale := aNumber. self cachedForm: nil; changed; changed: #scale! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 12/3/2007 11:37'! defaultImage "Answer the default image for the receiver." ^DefaultImage ifNil: [DefaultImage := DefaultForm asFormOfDepth: 32]! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 2/3/2010 17:46'! autoSize "Answer the value of autoSize" ^ autoSize! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:33'! model: anObject "Set my model and make me me a dependent of the given object." model ifNotNil: [model removeDependent: self]. anObject ifNotNil: [anObject addDependent: self]. model := anObject ! ! !AlphaImageMorph class methodsFor: 'as yet unclassified' stamp: 'GaryChambers 9/8/2011 10:35'! defaultImage: aForm "Set the default image used for new instances of the receiver." DefaultImage := aForm! ! !AlphaInfiniteForm commentStamp: 'gvc 5/18/2007 13:49'! Alpha aware InfiniteForm.! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/7/2008 14:00'! extent "Answer the extent of the repeating area." ^extent ifNil: [SmallInteger maxVal @ SmallInteger maxVal]! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:48'! extent: anObject "Set the value of extent" extent := anObject! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:42'! origin "Answer the origin." ^origin ifNil: [0@0]! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 12/3/2008 17:09'! direction: aPoint "Ignore" ! ! !AlphaInfiniteForm methodsFor: 'displaying' stamp: 'gvc 10/7/2008 13:59'! computeBoundingBox "Refer to the comment in DisplayObject|computeBoundingBox." ^self origin extent: self extent! ! !AlphaInfiniteForm methodsFor: 'displaying' stamp: 'gvc 8/10/2009 11:42'! displayOnPort: aPort offsetBy: offset | targetBox patternBox savedMap top left | aPort destForm depth < 32 ifTrue: [^super displayOnPort: aPort offsetBy: offset]. "this version tries to get the form aligned where the user wants it and not just aligned with the cliprect" (patternForm isForm) ifFalse: [ "patternForm is a Pattern or Color; just use it as a mask for BitBlt" ^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over]. "do it iteratively" targetBox := aPort clipRect. patternBox := patternForm boundingBox. savedMap := aPort colorMap. aPort sourceForm: patternForm; fillColor: nil; combinationRule: Form blend; sourceRect: (0@0 extent: patternBox extent); colorMap: (patternForm colormapIfNeededFor: aPort destForm). top := (targetBox top truncateTo: patternBox height) + offset y. left := (targetBox left truncateTo: patternBox width) + offset x. left to: (targetBox right - 1) by: patternBox width do: [:x | top to: (targetBox bottom - 1) by: patternBox height do: [:y | aPort destOrigin: x@y; copyBits]]. aPort colorMap: savedMap. ! ! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 10/3/2008 12:42'! origin: aPoint "Set the origin." origin := aPoint! ! !AmbiguousSelector commentStamp: 'nice 2/23/2010 15:40'! An AmbiguousSelector is a notification produced by the Scanner/Parser/Compiler when encountering this ambiguous construct: 1@-2 Upper expression can be interpreted both 1 @ -2 (regular st-80 and former Squeak syntax, the minus is attached to the literal number) 1 @- 2 (extended binary selector, the minus sign is allowed at any position and thus part of the binary selector) ! !AmbiguousSelector methodsFor: 'private' stamp: 'nice 2/23/2010 16:51'! setName: aString range: anInterval name := aString. interval := anInterval! ! !AmbiguousSelector methodsFor: 'handling' stamp: 'nice 3/5/2010 22:54'! openMenuIn: aBlock "Ask the user which selector to choose. Answer the choosen selector or nil if cancellation is requested." | labels actions lines caption choice | labels := { 'Yes I want selector ' , name , ' with positive argument'. 'Oops, I want ' , (name copyFrom: 1 to: name size - 1) , ' with negative argument'. 'cancel, I must think twice'}. actions := { name. name copyReplaceFrom: name size to: name size - 1 with: ' '. nil. }. lines := {2}. caption := 'Ambiguous selector: ' , name , ' please correct, or cancel:'. choice := aBlock value: labels value: lines value: caption. self resume: (actions at: choice ifAbsent: [nil])! ! !AmbiguousSelector class methodsFor: 'instance creation' stamp: 'nice 2/23/2010 16:52'! signalName: aString inRange: anInterval ^ (self new setName: aString range: anInterval) signal! ! !AndreasSystemProfiler commentStamp: ''! AndreasSystemProfiler uses sub-msec VM supported PC sampling. In Memory of Andreas Raab. Author, Friend, Colleague. http://forum.world.st/In-Memory-of-Andreas-Raab-td4663424.html Released by Ron, Julie and David Example: AndreasSystemProfiler spyOn: [ 10000 timesRepeat: [ 3.14159 printString ] ] -=-=-=-=-=-=-= Apparently, the time taken to run the provided block is as twice as long as run without the profiler. -=-=-=-=-=-=-= Both AndreasSystemProfiler and MessageTally are periodic sampling profilers. The essential difference between AndreasSystemProfiler and MessageTally is in how the current method is sampled. MessageTally is driven from a high-priority process in a loop waiting on a delay. When the delay fires the lower-priority process being profiled is interrupted, its stack is walked to determine the methods along the call chain, and that data is recorded. But since the sampling occurs when the high-priority process preempts the lower-priority process, a sample is only taken at a preemption point. In particular, primitives are *not* profiled because they are not suspension points. A process can only be suspended on method activation (a non-primitive method activation, or primitive failure) or on backward branch. The cost of primitives is charged to a caller and is inferred by subtracting the cost of children of the caller from the caller itself (subtracting the number of samples in children of the caller form the number of samples in the caller itself). Another problem is that using the clock that underlies Delay, which is typically the clock used by processes being profiled, causes sampling errors due to the sampling and sampled processes cohering. Delays are limited in resolution (at best 1 millisecond) so if the profiled process waits on a delay it'll fire immediately after the profiling process (because the profiling process is at higher priority) and so the sampling process may only ever see the sampled process in a wait state. If MessageTally is used to profile multiple processes then a third problem is that if a primitive causes a process switch then its cost will end up being charged to the process switched-to, not switched from. This is again because sampling can only occur after a primitive has completed (successfully or not). AndreasSystemProfiler is driven from a high-priority process in a loop waiting on a Semaphore known to the VM. The profiling process uses a primitive to schedule a sample some number of ticks of the VM's high-performance clock in the future. When the time is reached the VM samples the current method and the current process, *before any process preemption takes place*, and independently of the standard clock, and signals the semaphore. The profiling process then collects the method,process pair via primitives. So AndreasSystemProfiler provides much more accurate results. That said there are still limitations with primitives and Cog. Currently Cog only samples "interpreter" primitives. Those primitives it implements in machine code (integer and float arithmetic, closure evaluation, at:, identityHash) are not sampled and won't show up; they will be charged to the calling method. This is fixable, since Cog actually compiles the sampling direct into interpreter primitive invocation when profiling is in effect and not at other times, but sampling could be a significant cost in these simple and performance-critical primitives.! !AndreasSystemProfiler methodsFor: 'profiling' stamp: 'AlexandreBergel 1/29/2013 10:31'! spyOn: aBlock "Profile system activity during execution of aBlock. The argument is the desired samples per *milli* second. Mostly for polymorphism with MessageTally." self startProfiling. aBlock ensure: [ self stopProfiling ] ! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'RJT 1/23/2013 15:28'! doReport "Report the results of this profiler run" UIManager default edit: self report label: 'Spy Results'.! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'AlexandreBergel 1/29/2013 10:30'! report "Answer a report, with cutoff percentage of each element of the tree" ^String streamContents: [ :s | self report: s ]! ! !AndreasSystemProfiler methodsFor: 'profiling' stamp: 'AlexandreBergel 1/29/2013 10:32'! stopProfiling "Stop the profiler process" Smalltalk profileSemaphore: nil. Smalltalk profileStart: 0. "<- profile stops now" totalTime := Time millisecondClockValue - startTime. Smalltalk vm getParameters keysAndValuesDo: [ :idx :value | value isInteger ifTrue: [ vmStats at: idx put: (value - ((vmStats at: idx) ifNil: [ 0 ])) ]. ]. profilerProcess ifNotNil: [ profilerProcess suspend. profilerProcess := nil. ]. ! ! !AndreasSystemProfiler methodsFor: 'profiling' stamp: 'AlexandreBergel 1/29/2013 10:31'! runProfilerProcess "Run the profiler process" | process tallyStart tallyTicks tallyStop method leaf | tallyRoot := QSystemTally new class: nil method: nil. totalTally := 0. Smalltalk profileSemaphore: semaphore. totalTicks := 0. tallyStart := tallyStop := Smalltalk highResClock. [ true ] whileTrue: [ tallyStart := tallyStop. tallyStart := Smalltalk highResClock. Smalltalk profileStart: ticks. "run for n ticks" semaphore wait. tallyStop := Smalltalk highResClock. tallyTicks := tallyStop - tallyStart. totalTicks := totalTicks + tallyTicks. process := Smalltalk profileSample. method := Smalltalk profilePrimitive. totalTally := totalTally + 1. process ifNotNil:[ leaf := tallyRoot tally: (process suspendedContext ifNil: [ thisContext ] ) by: tallyTicks. method ifNotNil: [ leaf tallyMethod: method by: tallyTicks ]. ]. ]. ! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'AlexandreBergel 1/29/2013 10:12'! reportProcessStatsOn: str | totalSwitches pageOverflows pageDivorces actualSwitches | vmStats size >= 61 ifFalse: [ ^ self ]. "don't try this on the closure VM" totalSwitches := vmStats at: 56. actualSwitches := totalSwitches - (2*totalTally). "exclude to/from profiler" pageOverflows := vmStats at: 60. pageDivorces := vmStats at: 61. str cr. str nextPutAll: '**Processes**'; cr. str tab; nextPutAll: 'Total process switches: ', totalSwitches printString; cr. str tab; nextPutAll: 'Without Profiler: ', actualSwitches printString; cr. str tab; nextPutAll: 'Stack page overflows: ', pageOverflows printString; cr. str tab; nextPutAll: 'Stack page divorces: ', pageDivorces printString; cr. ! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'ClementBera 7/26/2013 16:01'! report: strm cutoff: threshold tallyRoot ifNil: [ strm nextPutAll: 'The profiler has not been run'. ^ self ]. tallyRoot tally isZero ifTrue: [ strm nextPutAll: ' - no tallies obtained' ] ifFalse: [ strm nextPutAll: 'Reporting - ', totalTally asStringWithCommas,' tallies, ', totalTime asStringWithCommas, ' msec.'; cr; cr. tallyRoot fullPrintOn: strm tallyExact: false orThreshold: threshold time: totalTime. ]. totalTime isZero ifFalse: [ self reportGCStatsOn: strm. self reportProcessStatsOn: strm. ].! ! !AndreasSystemProfiler methodsFor: 'profiling' stamp: 'AlexandreBergel 1/29/2013 10:31'! startProfiling "Start the profiler process taking samplesPerMsec samples per *milli* second" | t0 | semaphore := Semaphore new. "Run a 100 msec busy loop to figure out the ticks per msec" t0 := Time millisecondClockValue + 2. [Time millisecondClockValue >= t0] whileFalse. ticksPerMSec := Smalltalk highResClock. [Time millisecondClockValue >= (t0 + 100)] whileFalse. ticksPerMSec := (Smalltalk highResClock - ticksPerMSec) // (Time millisecondClockValue - t0). "Try to get 10 samples per msec" ticks := ticksPerMSec // 10. startTime := Time millisecondClockValue. vmStats := Smalltalk vm getParameters. profilerProcess := [ self runProfilerProcess ] forkAt: Processor timingPriority - 1. ! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'RJT 1/23/2013 15:28'! report: strm "Print a report, with cutoff percentage of each element of the tree (leaves, roots, tree)=2, on the stream, strm." self report: strm cutoff: 1! ! !AndreasSystemProfiler methodsFor: 'reporting' stamp: 'RJT 1/23/2013 15:28'! reportGCStatsOn: str | oldSpaceEnd youngSpaceEnd memoryEnd fullGCs fullGCTime incrGCs incrGCTime tenureCount upTime rootOverflows | upTime := totalTime. oldSpaceEnd := vmStats at: 1. youngSpaceEnd := vmStats at: 2. memoryEnd := vmStats at: 3. fullGCs := vmStats at: 7. fullGCTime := vmStats at: 8. incrGCs := vmStats at: 9. incrGCTime := vmStats at: 10. tenureCount := vmStats at: 11. rootOverflows := vmStats at: 22. str cr. str nextPutAll: '**Memory**'; cr. str nextPutAll: ' old '; nextPutAll: oldSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str nextPutAll: ' young '; nextPutAll: (youngSpaceEnd - oldSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str nextPutAll: ' used '; nextPutAll: youngSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str nextPutAll: ' free '; nextPutAll: (memoryEnd - youngSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str cr. str nextPutAll: '**GCs**'; cr. str nextPutAll: ' full '; print: fullGCs; nextPutAll: ' totalling '; nextPutAll: fullGCTime asStringWithCommas; nextPutAll: 'ms ('; print: ((fullGCTime / upTime * 100) roundTo: 1.0); nextPutAll: '% uptime)'. fullGCs = 0 ifFalse: [str nextPutAll: ', avg '; print: ((fullGCTime / fullGCs) roundTo: 1.0); nextPutAll: 'ms']. str cr. str nextPutAll: ' incr '; print: incrGCs; nextPutAll: ' totalling '; nextPutAll: incrGCTime asStringWithCommas; nextPutAll: 'ms ('; print: ((incrGCTime / upTime * 100) roundTo: 1.0); nextPutAll: '% uptime)'. incrGCs = 0 ifFalse: [str nextPutAll:', avg '; print: ((incrGCTime / incrGCs) roundTo: 1.0); nextPutAll: 'ms']. str cr. str nextPutAll: ' tenures '; nextPutAll: tenureCount asStringWithCommas. tenureCount = 0 ifFalse: [str nextPutAll: ' (avg '; print: (incrGCs / tenureCount) asInteger; nextPutAll: ' GCs/tenure)']. str cr. str nextPutAll: ' root table '; nextPutAll: rootOverflows asStringWithCommas; nextPutAll:' overflows'. str cr. ! ! !AndreasSystemProfiler class methodsFor: 'spying' stamp: 'AlexandreBergel 1/29/2013 10:21'! spyFor: seconds "Run the system profiler for the specified number of seconds" "self spyFor: 5" ^self spyOn: [ (Delay forSeconds: seconds) wait ].! ! !AndreasSystemProfiler class methodsFor: 'spying' stamp: 'AlexandreBergel 1/29/2013 10:23'! spyOn: aBlock "The main method for profiling and showing the report " "self spyOn: [ 10000 timesRepeat: [ 3.14159 printString ] ]" | profiler | profiler := self new. [ ^ profiler spyOn: aBlock ] ensure: [ profiler doReport ]. ! ! !AndreasSystemProfiler class methodsFor: 'spying' stamp: 'RJT 1/23/2013 15:28'! default ^self new! ! !AndreasSystemProfiler class methodsFor: 'spying' stamp: 'RJT 1/23/2013 15:28'! spyOnWorldFor: seconds "Run the system profiler for the specified number of seconds, spying on the morphic world in which it was launched. Handy for running Workspace do-its." ^self spyOn: [ | deadline | deadline := Time totalSeconds + seconds. [Time totalSeconds < deadline] whileTrue: [ World doOneCycle ]].! ! !AndreasSystemProfiler class methodsFor: 'LICENSE' stamp: 'RJT 1/23/2013 15:34'! LICENSE ^'Project Squeak In Memory of Andreas Raab. Author, Friend, Colleague. http://forum.world.st/In-Memory-of-Andreas-Raab-td4663424.html Copyright (c) 2005-2013, 3D Immersive Collaboration Consulting, LLC., All Rights Reserved Redistributions in source code form must reproduce the above copyright and this condition. Licensed under MIT License (MIT) Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.'! ! !AndreasSystemProfilerTest commentStamp: 'TorstenBergmann 2/4/2014 20:45'! SUnit tests for AndreasSystemProfiler! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 11:10'! testTallyTreePrintWithTab | stream | stream := WriteStream on: String new. tally treePrintOn: stream tabs: #(' ') thisTab: nil total: 50 totalTime: 100 tallyExact: true orThreshold: 1. self assert: stream contents = ' 0 AndreasSystemProfilerTest testPrintingTally '! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 10:40'! testPrintingTallyUninitialized self assert: QSystemTally new printString = 'nil>>nil -- nil'! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 11:43'! testFullPrintOn | stream | stream := WriteStream on: String new. tally fullPrintOn: stream tallyExact: false orThreshold: 0 time: 10. self assert: stream contents = '**Tree** **Leaves** '! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 11:16'! testGetNewTab | tabs | self assert: (tally getNewTabsFor: #()) = #(). self assert: (tally getNewTabsFor: #(' ')) = #(' '). tabs := OrderedCollection new. tabs add: '['. (tally maxTabs + 1) timesRepeat: [ tabs add: ' ' ]. self assert: (tally getNewTabsFor: tabs) asArray = #('[' '[').! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 11:08'! testTallyTreePrint | stream | stream := WriteStream on: String new. tally treePrintOn: stream tabs: #() thisTab: nil total: 50 totalTime: 100 tallyExact: true orThreshold: 1. "Nothing is printed since there is no tab" self assert: stream contents isEmpty! ! !AndreasSystemProfilerTest methodsFor: 'tests profiler' stamp: 'CamilloBruni 8/31/2013 20:23'! testSimpleReport AndreasSystemProfiler new report! ! !AndreasSystemProfilerTest methodsFor: 'tests profiler' stamp: 'CamilloBruni 8/31/2013 20:23'! testSimple AndreasSystemProfiler new spyOn: [ 200 timesRepeat: [ 1.23 printString ] ]! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 10:45'! setUp tally := QSystemTally new. tally class: self class method: self class >> #testPrintingTally "tally class: Object method: Object >> #printString."! ! !AndreasSystemProfilerTest methodsFor: 'tests tally' stamp: 'AlexandreBergel 1/29/2013 10:48'! testPrintingTally self assert: tally printString = 'AndreasSystemProfilerTest>>#testPrintingTally -- 0'! ! !AnimatedGIFReadWriter commentStamp: 'LaurentLaffont 5/4/2011 21:27'! Read an animated GIF file. Example: open all images of an animated GIF file in a Morphic window gifPath := '/path/to/my_animated.gif'. forms := (AnimatedGIFReadWriter formsFromFileNamed: gifPath) forms. content := UITheme builder newRow: (forms collect: [:aForm| UITheme builder newImage: aForm]). content openInWindowLabeled: 'Content of ', gifPath.! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! forms ^ forms! ! !AnimatedGIFReadWriter methodsFor: 'private' stamp: 'mir 11/19/2003 12:25'! comment: aString comments add: aString! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! delays ^ delays! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! allImages | body colorTable | stream class == ReadWriteStream ifFalse: [ stream binary. self on: (ReadWriteStream with: stream contentsOfEntireFile) ]. localColorTable := nil. forms := OrderedCollection new. delays := OrderedCollection new. comments := OrderedCollection new. self readHeader. [ (body := self readBody) isNil ] whileFalse: [ colorTable := localColorTable ifNil: [ colorPalette ]. transparentIndex ifNotNil: [ transparentIndex + 1 > colorTable size ifTrue: [ colorTable := colorTable forceTo: transparentIndex + 1 paddingWith: Color white ]. colorTable at: transparentIndex + 1 put: Color transparent ]. body colors: colorTable. forms add: body. delays add: delay ]. ^ forms! ! !AnimatedGIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:21'! readBitData | form | form := super readBitData. form offset: offset. ^form! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! wantsToHandleGIFs ^true! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! formsFromStream: stream | reader | reader := self new on: stream reset. Cursor read showWhile: [ reader allImages. reader close ]. ^ reader! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! formsFromFileNamed: fileName | stream | stream := FileStream readOnlyFileNamed: fileName. ^ self formsFromStream: stream! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 6/12/2004 13:12'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('gif')! ! !AnimationSettings commentStamp: 'TorstenBergmann 2/5/2014 10:31'! Animation settings! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:21'! animateClosing ^ animateClosing ifNil: [animateClosing := false]! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:23'! numberOfSteps: anInteger numberOfSteps := anInteger! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:23'! numberOfSteps ^ numberOfSteps ifNil: [numberOfSteps := 20]! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:20'! useAnimation ^ useAnimation ifNil: [useAnimation := false]! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:22'! delay: anInteger delay := anInteger! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:21'! animateClosing: aBoolean animateClosing := aBoolean! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:21'! useAnimation: aBoolean useAnimation := aBoolean! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:24'! delay ^ delay ifNil: [delay := 8]! ! !AnnotationPanePlugin commentStamp: ''! An IgorsPlugin is a plugin which displays info about the current selection! !AnnotationPanePlugin methodsFor: 'private' stamp: 'MarianoMartinezPeck 4/24/2012 23:25'! buildString | mdl stringBuilder | mdl := self model. stringBuilder := WriteStream on: ''. mdl selectedClass ifNil: [ '' ] ifNotNil: [:class | mdl selectedMethod ifNil: [ stringBuilder nextPutAll: (RGCommentDefinition realClass: class) timeStamp asTimeStamp asString. ] ifNotNil: [:method | stringBuilder nextPutAll: (AnnotationRequest onClass: class selector: method selector) getAnnotations. ]]. ^ stringBuilder contents! ! !AnnotationPanePlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 2/17/2012 16:39'! description ^ 'Display the information of the selected class/method'! ! !AnnotationRequest methodsFor: 'initialization' stamp: 'MAD 1/14/2009 11:44'! onClass: aClass selector: aSelector class := aClass. selector := aSelector. separator := ' - '.! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:10'! firstComment "The first comment in the method, if any." ^ class firstCommentAt: selector! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:11'! masterComment "The comment at the beginning of the supermost implementor of the method if any." ^ class supermostPrecodeCommentFor: selector! ! !AnnotationRequest methodsFor: 'accessing' stamp: 'dc 5/2/2007 18:14'! separator: aString separator := aString! ! !AnnotationRequest methodsFor: 'accessing' stamp: 'dc 6/18/2007 18:55'! method ^ class compiledMethodAt: selector ifAbsent: [nil]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:13'! allChangeSets "A list of all change sets bearing the method." | changeSets | changeSets := ChangeSet allChangeSetsWithClass: class selector: selector. ^ changeSets isEmpty ifFalse: [ String streamContents: [ :aStream | changeSets size = 1 ifTrue: [ aStream nextPutAll: 'only in change set ' ] ifFalse: [ aStream nextPutAll: 'in change sets: ' ]. changeSets do: [ :aChangeSet | aStream nextPutAll: aChangeSet name; nextPutAll: ' ' ] ] ] ifTrue: [ 'in no change set' ]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'ClementBera 7/26/2013 16:02'! priorTimeStamp "The time stamp of the penultimate submission of the method, if any." | stamp | ^ (stamp := VersionsBrowser timeStampFor: selector class: class reverseOrdinal: 2) ifNotNil: [ 'prior time stamp: ' , stamp ]! ! !AnnotationRequest methodsFor: 'actions' stamp: 'MarianoMartinezPeck 4/24/2012 23:38'! annotationRequests ^ CodeHolder annotationRequests copyWithout: #sendersCount ! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:11'! documentation "Comment at beginning of the method or, if it has none, comment at the beginning of a superclass's implementation of the method." ^ class precodeCommentOrInheritedCommentFor: selector! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:14'! priorVersionsCount "A report of how many previous versions there are of the method." | versionsCount | versionsCount := VersionsBrowser versionCountForSelector: selector class: class. ^ versionsCount > 1 ifTrue: [ versionsCount = 2 ifTrue: [ '1 prior version' ] ifFalse: [ versionsCount printString, ' prior versions' ] ] ifFalse: [ 'no prior versions' ]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:12'! sendersCount "A report of how many senders there of the message." | sendersCount | sendersCount := (self systemNavigation allCallsOn: selector) size. ^ sendersCount = 1 ifTrue: [ '1 sender' ] ifFalse: [ sendersCount printString , ' senders' ]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'ClementBera 7/26/2013 16:02'! timeStamp "The time stamp of the last submission of the method." ^ self method ifNotNil: [ self method timeStamp ]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:15'! messageCategory "Which method category the method lies in." ^ class organization categoryOfElement: selector! ! !AnnotationRequest methodsFor: 'actions' stamp: 'lr 8/15/2010 17:10'! getAnnotations ^ String streamContents: [ :aStream | ((self annotationRequests collect: [ :request | self perform: request ]) reject: [ :stringOrNil | stringOrNil isEmptyOrNil ]) do: [ :each | aStream nextPutAll: each ] separatedBy: [ aStream nextPutAll: separator ] ]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:13'! implementorsCount "A report of how many implementors there are of the message." | implementorsCount | implementorsCount := self systemNavigation numberOfImplementorsOf: selector. ^ implementorsCount = 1 ifTrue: [ '1 implementor' ] ifFalse: [ implementorsCount printString , ' implementors' ]! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:13'! recentChangeSet "The most recent change set bearing the method." ^ ChangeSet mostRecentChangeSetWithChangeForClass: class selector: selector! ! !AnnotationRequest class methodsFor: 'instance-creation' stamp: 'PDC 6/25/2007 22:01'! onClass: aClass selector: aSelector ^ self new onClass: aClass selector: aSelector; yourself! ! !Announcement commentStamp: 'Tbn 11/12/2010 10:57'! This class is the superclass for events that someone might want to announce, such as a button click or an attribute change. Typically you create subclasses for your own events you want to announce. ! !Announcement methodsFor: 'converting' stamp: 'lr 10/3/2006 14:32'! asAnnouncement ^ self! ! !Announcement methodsFor: '*Announcements-View' stamp: 'lr 9/3/2006 16:17'! open self inspect! ! !Announcement class methodsFor: 'testing' stamp: 'StephaneDucasse 2/22/2013 17:35'! handlesAnnouncement: anAnnouncement "The receiver acts as a filter to determine whether subscribers who used the receiver as signaling tag (event identifier class or symbol) should receive incoming announcement. In particular, registering to a superclass will receive the announcements from all subclasses." ^ anAnnouncement class == self or: [ anAnnouncement class inheritsFrom: self ]! ! !Announcement class methodsFor: 'public' stamp: 'lr 9/20/2006 08:18'! , anAnnouncementClass ^ AnnouncementSet with: self with: anAnnouncementClass! ! !Announcement class methodsFor: 'converting' stamp: 'lr 10/3/2006 14:31'! asAnnouncement ^ self new! ! !Announcement class methodsFor: '*Polymorph-Widgets-Themes' stamp: 'YuriyTymchuk 12/20/2013 11:16'! systemIcon ^ Smalltalk ui icons iconNamed: #announcementIcon! ! !AnnouncementLogger commentStamp: 'StephaneDucasse 5/9/2011 17:17'! Use me to debug and log to the transcript annoncements. AnnouncementLogger new subscribeTo: SystemAnnouncer announcer To unsubscribe AnnouncementLogger allInstancesDo: [:each | SystemAnnouncer announcer unsubscribe: each ]! !AnnouncementLogger methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 5/9/2011 17:15'! subscribeTo: anAnnouncer anAnnouncer "weak" on: Announcement send: #logAnnouncement: to: self! ! !AnnouncementLogger methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 5/9/2011 17:11'! logAnnouncement: ann Transcript show: ann printString ; cr! ! !AnnouncementMockA commentStamp: 'Tbn 11/12/2010 10:54'! This is a simple test mock.! !AnnouncementMockB commentStamp: 'Tbn 11/12/2010 10:54'! This is a simple test mock! !AnnouncementMockC commentStamp: 'Tbn 11/12/2010 10:54'! This is a simple test mock! !AnnouncementSet commentStamp: ''! If you want to register the same action for multiple events, simply create an AnnouncementSet using a comma: Parent>>initialize super initialize. self session announcer on: AddChild, RemoveChild do: [:it | self changeChild: it child] Motivation example: Often the UI is built after/independently from the model. You want to have the model raise fine-grained announcements to enable the layers on top, but sometimes it is easier in the UI to refresh everything whenever something happens.! !AnnouncementSet methodsFor: 'adding' stamp: 'lr 6/13/2006 08:13'! , anAnnouncementClass self add: anAnnouncementClass! ! !AnnouncementSet methodsFor: 'testing' stamp: 'StephaneDucasse 2/22/2013 17:36'! handlesAnnouncement: anAnnouncement "If any of the set handles the announcements, subscribers should receive it." ^ self anySatisfy: [ :each | each handlesAnnouncement: anAnnouncement ]! ! !AnnouncementSetTest commentStamp: 'TorstenBergmann 2/20/2014 15:16'! SUnit tests for announcement sets! !AnnouncementSetTest methodsFor: 'testing' stamp: 'Sd 11/26/2010 17:31'! testInstanceCreation |set| set := AnnouncementMockA, AnnouncementMockB. self assert: set size = 2 ! ! !AnnouncementSetTest methodsFor: 'testing' stamp: 'Tbn 11/12/2010 11:07'! testIncludeOnlyOnce |set| set := AnnouncementMockA, AnnouncementMockB, AnnouncementMockA. self assert: set size = 2! ! !AnnouncementSpy commentStamp: ''! I am a tool to inspect live events . If you want to inspect events generated by an announcer without a priori knowledge about the kind and frequency of events, you can always open a spy on an announcer to track its events. announcer open or AnnouncementSpy openOn: announcer This opens a window which displays the sequence of events emitted by the announcer (after the spy has been launched). You can open/inspect each event individually using the contextual menu. you can also clear the list view. Try it on World announcer open (in Pharo 1.1 or later), then add and close windows to see events generated.! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:02'! announcements ^ announcements! ! !AnnouncementSpy methodsFor: 'building' stamp: 'lr 9/3/2006 16:21'! buildMenu: aMenuMorph ^ aMenuMorph defaultTarget: self; add: 'open' action: #open; add: 'clear' action: #clear; yourself! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:04'! announcer ^ announcer! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/3/2006 16:21'! clear self announcements: OrderedCollection new! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/25/2006 09:19'! close self announcer: nil! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'StephaneDucasse 5/1/2011 14:27'! initialExtent ^ 300 @ 400! ! !AnnouncementSpy methodsFor: 'updating' stamp: 'NicolaiHess 1/18/2014 22:03'! windowIsClosing self close! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 9/25/2006 09:26'! announcer: anAnnouncer announcer ifNotNil: [ announcer unsubscribe: self ]. announcer := anAnnouncer. announcer ifNotNil: [ announcer subscribe: Announcement send: #announce: to: self ]! ! !AnnouncementSpy methodsFor: 'building' stamp: 'StephaneDucasse 5/1/2011 14:47'! buildList ^ (PluggableListMorph new) on: self list: #announcements selected: #index changeSelected: #index: menu: #buildMenu: keystroke: nil. ! ! !AnnouncementSpy methodsFor: 'private' stamp: 'lr 9/3/2006 14:09'! announce: anAnnouncement self announcements add: anAnnouncement. self index: self announcements size. self changed: #announcements! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 9/3/2006 14:08'! announcements: aCollection announcements := aCollection. self changed: #announcements! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'lr 9/3/2006 14:08'! extent ^ 250 @ 400! ! !AnnouncementSpy methodsFor: 'initialization' stamp: 'lr 6/14/2006 17:03'! initialize super initialize. self announcements: OrderedCollection new. self index: 0! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'StephaneDucasse 5/1/2011 14:22'! label ^ 'Spy: ', (self announcer ifNil: ['no announcer'] ifNotNil: [ self announcer printString ]) ! ! !AnnouncementSpy methodsFor: 'private' stamp: 'AlainPlantec 7/9/2013 11:07'! changed: aSymbol UIManager default defer: [ super changed: aSymbol ]! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:20'! index: anInteger index := anInteger. self changed: #index! ! !AnnouncementSpy methodsFor: 'building' stamp: 'StephaneDucasse 5/1/2011 14:47'! build "self new build openInWorld" |window list| window := (SystemWindow labelled: self label) model: self. window addMorph: self buildList frame: (0 @ 0 corner: 1 @ 1). ^ window ! ! !AnnouncementSpy methodsFor: 'actions' stamp: 'lr 9/25/2006 09:25'! open (self announcements at: self index ifAbsent: [ ^ self ]) open! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:02'! index ^ index ! ! !AnnouncementSpy class methodsFor: 'instance-creation' stamp: 'StephaneDucasse 5/1/2011 14:49'! openOn: anAnnouncer "Schedule a new window and open a new AnnouncementSpy on the announcer passed as argument" (self on: anAnnouncer) build openInWorld ! ! !AnnouncementSpy class methodsFor: 'instance-creation' stamp: 'lr 6/14/2006 17:05'! on: anAnnouncer ^ self new announcer: anAnnouncer; yourself! ! !AnnouncementSubscription commentStamp: 'IgorStasenko 3/12/2011 20:23'! The subscription is a single entry in a SubscriptionRegistry. Several subscriptions by the same object is possible. I know how to make myself weak or strong, only use this capability if it can't be determined at subscribe time though, as it uses become: (for thread-safety), which is quite slow.! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:15'! announcer ^ announcer! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:14'! subscriber ^ subscriber! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:16'! valuable: aValuable "Used when subscriber should be extracted from valuable object" self action: aValuable. self subscriber: aValuable receiver.! ! !AnnouncementSubscription methodsFor: 'converting' stamp: 'IgorStasenko 3/12/2011 17:37'! makeStrong " i am already strong. Do nothing "! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:14'! subscriber: aSubscriber subscriber := aSubscriber! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:15'! action: anObject action := anObject! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:13'! announcer: anAnnouncer announcer := anAnnouncer! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:18'! announcementClass ^ announcementClass! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:15'! action ^ action! ! !AnnouncementSubscription methodsFor: 'announcing' stamp: 'IgorStasenko 1/3/2012 12:22'! deliver: anAnnouncement " deliver an announcement to receiver. In case of failure, it will be handled in separate process" ^ (self handlesAnnouncement: anAnnouncement ) ifTrue: [ [action cull: anAnnouncement cull: announcer] on: UnhandledError fork: [:ex | ex pass ]]! ! !AnnouncementSubscription methodsFor: 'testing' stamp: 'IgorStasenko 1/3/2012 12:19'! handlesAnnouncement: anAnnouncement ^ announcementClass handlesAnnouncement: anAnnouncement! ! !AnnouncementSubscription methodsFor: 'converting' stamp: 'IgorStasenko 3/22/2011 15:41'! makeWeak action isBlock ifTrue: [ self error: 'Not currently available due to missing ephemerons support' ]. ^ announcer replace: self with: (WeakAnnouncementSubscription new announcer: announcer; action: action asWeakMessageSend; subscriber: subscriber; announcementClass: announcementClass)! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:18'! announcementClass: anObject announcementClass := anObject! ! !AnnouncementsAPIDocumentation commentStamp: 'Tbn 11/12/2010 11:17'! This is a custom help book providing the API documentation for the announcements framework. ! !AnnouncementsAPIDocumentation class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 10:41'! bookName ^'API Documentation'! ! !AnnouncementsAPIDocumentation class methodsFor: 'defaults' stamp: 'Tbn 11/12/2010 10:41'! builder ^PackageAPIHelpBuilder! ! !AnnouncementsAPIDocumentation class methodsFor: 'accessing' stamp: 'StephanEggermont 12/9/2013 19:48'! helpPackages ^#('Announcements-Core' 'Announcements-View' 'Announcements-Tests-Core')! ! !AnnouncementsHelp commentStamp: 'Tbn 11/12/2010 11:17'! This is a custom help book for the announcements framework. ! !AnnouncementsHelp class methodsFor: 'pages' stamp: 'MarianoMartinezPeck 4/30/2011 15:42'! links "This method was automatically generated. Edit it using:" "AnnouncementsHelp edit: #links" ^HelpTopic title: 'Links' contents: 'You can get more informations on the framework on the following websites: http://book.pharo-project.org/book/announcements http://www.cincomsmalltalk.com/userblogs/vbykov/blogView?searchCategory=Announcements%20Framework http://www.cincomsmalltalk.com/userblogs/vbykov/blogView?entry=3310034894 http://dougedmunds.com/pmwiki.php?n=Pharo.AnnouncementsTutorial '! ! !AnnouncementsHelp class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 10:35'! bookName ^'Announcements framework'! ! !AnnouncementsHelp class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 11:30'! pages ^#(introduction AnnouncementsTutorial AnnouncementsAPIDocumentation links)! ! !AnnouncementsHelp class methodsFor: 'pages' stamp: 'Tbn 11/12/2010 11:18'! introduction "This method was automatically generated. Edit it using:" "AnnouncementsHelp edit: #introduction" ^HelpTopic title: 'Introduction' contents: 'The announcement framwork is an event notification framework. Compared to "traditional" Smalltalk event systems in this new framework, an event is a real object rather than a symbol. An event someone might want to announce, such as a button click or an attribute change, is defined as a subclass of the abstract superclass Announcement. The subclass can have instance variables for additional information to pass along, such as a timestamp, or mouse coordinates at the time of the event, or the old value of the parameter that has changed. To signal the actual occurrence of an event, the "announcer" creates and configures an instance of an appropriate announcement, then broadcasts that instance. Objects subscribed to receive such broadcasts from the announcer receive a broadcast notification together with the instance. They can talk to the instance to find out any additional information about the event that has occurred.!!' ! ! !AnnouncementsTutorial commentStamp: 'Tbn 11/12/2010 11:17'! This is a custom help book providing a tutorial for the announcements framework. ! !AnnouncementsTutorial class methodsFor: 'pages' stamp: 'Tbn 11/12/2010 13:55'! step2 "This method was automatically generated. Edit it using:" "AnnouncementsTutorial edit: #step2" ^HelpTopic title: 'Step 2 - Publishers and subscribers' contents: 'If an object wants to announce an event it needs someone to make the announcement to. This is typically an instance of class Announcer which acts as the mediator between the object that has to announce something (publisher) and one or many (anonymous) subscribers who are interested in the event. | announcer | announcer := Announcer new. announcer announce: MyInterestingAnnouncement new Using #announce: we can make an announcement - but since nobody is interested yet nothing will happen. Lets add some consumers/subscribers. Subscribers just register on the Announcer instance to note that they are interested on a particular event/announcement: | announcer | announcer := Announcer new. announcer on: MyInterestingAnnouncement send: #open to: Browser. announcer on: MyInterestingAnnouncement send: #inspect to: Smalltalk. So anytime an interesting announcement is made we want to inform the two consumers with a specific message. Still nothing happens - we have to additionally make the announcement: | announcer | announcer := Announcer new. announcer on: MyInterestingAnnouncement send: #open to: Browser. announcer on: MyInterestingAnnouncement send: #inspect to: Smalltalk. announcer announce: MyInterestingAnnouncement new Note that the subscribers are decoupled from the orginal announcement publisher. They dont have to know each other. Decoupling is the key thing here ... subscribers can register for particular events/announcements and remain anonymous to the original publisher. !!' readStream nextChunkText! ! !AnnouncementsTutorial class methodsFor: 'pages' stamp: 'Tbn 11/12/2010 12:59'! step1 "This method was automatically generated. Edit it using:" "AnnouncementsTutorial edit: #step1" ^HelpTopic title: 'Step 1 - Define an announcememt' contents: 'To define an announcement you just have to subclass the Announcement class: Announcement subclass: #MyInterestingAnnouncement instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''MyApp-Core'' If required you can add instance variables to hold data that should be transferred when an announcement is made: Announcement subclass: #GameLostAnnouncement instanceVariableNames: ''score'' classVariableNames: '''' poolDictionaries: '''' category: ''MyGame-Core''!!' readStream nextChunkText! ! !AnnouncementsTutorial class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 11:16'! bookName ^'Tutorial'! ! !AnnouncementsTutorial class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 13:54'! pages ^#(step1 step2 step3)! ! !AnnouncementsTutorial class methodsFor: 'pages' stamp: 'Tbn 11/12/2010 14:06'! step3 "This method was automatically generated. Edit it using:" "AnnouncementsTutorial edit: #step3" ^HelpTopic title: 'Step 3 - More examples' contents: 'In Pharo there is a global called "World" pointing to the desktop morph. This world also has an announcer we can use to demonstrate the features of the framework: | announcer | World announcer on: WindowOpened send: #value to: [ Transcript show: ''A new window was opened'';cr]. So anytime a window is opened in the system a message is shown in the transcript: Transcript open. | announcer | World announcer on: WindowOpened send: #value to: [:ea | ea inspect. Transcript show: ''A new window was opened'';cr]. !!' readStream nextChunkText! ! !Announcer commentStamp: 'IgorStasenko 3/12/2011 18:45'! The code is based on the announcements as described by Vassili Bykov in . The implementation uses a threadsafe subscription registry, in the sense that registering, unregistering, and announcing from an announcer at the same time in different threads should never cause failures. For security reasons, registry is kept private, and has no accessor like in other implementations! !Announcer methodsFor: 'convenience' stamp: 'StephaneDucasse 8/27/2013 21:52'! when: anAnnouncementClass do: aValuable "Declare that when anAnnouncementClass is raised, aValuable is executed. Pay attention that ushc method as well as when:do: should not be used on weak announcer since the block holds the receiver and more strongly." ^ self subscribe: anAnnouncementClass do: aValuable! ! !Announcer methodsFor: 'private' stamp: 'IgorStasenko 3/12/2011 20:30'! basicSubscribe: subscription ^ registry add: subscription! ! !Announcer methodsFor: 'deprecated' stamp: 'StephaneDucasse 8/27/2013 21:52'! on: anAnnouncementClass do: aValuable "This method is deprecated!! Declare that when anAnnouncementClass is raised, aValuable is executed. In addition pay attention that ushc method as well as when:do: should not be used on weak announcer since the block holds the receiver and more strongly." ^ self when: anAnnouncementClass do: aValuable! ! !Announcer methodsFor: 'deprecated' stamp: 'StephaneDucasse 8/22/2013 23:01'! on: anAnnouncementClass send: aSelector to: anObject "This method is deprecated!! Use when:send:to:. Declare that when anAnnouncementClass is raised, anObject should receive the message aSelector. When the message expects one argument (eg #fooAnnouncement:) the announcement is passed as argument. When the message expects two arguments (eg #fooAnnouncement:announcer:) both the announcement and the announcer are passed as argument" ^ self when: anAnnouncementClass send: aSelector to: anObject! ! !Announcer methodsFor: 'statistics' stamp: 'IgorStasenko 3/12/2011 21:02'! numberOfSubscriptions ^ registry numberOfSubscriptions ! ! !Announcer methodsFor: 'announce' stamp: 'StephaneDucasse 4/24/2011 11:06'! announce: anAnnouncement | announcement | announcement := anAnnouncement asAnnouncement. registry ifNotNil: [ registry deliver: announcement ]. ^ announcement! ! !Announcer methodsFor: 'convenience' stamp: 'StephaneDucasse 8/27/2013 21:47'! when: anAnnouncementClass do: aValuable for: aSubscriber "Declare that when anAnnouncementClass is raised, aValuable is executed and define the subscriber." ^ (self subscribe: anAnnouncementClass do: aValuable) subscriber: aSubscriber; yourself! ! !Announcer methodsFor: 'subscription' stamp: 'StephaneDucasse 4/24/2011 12:16'! subscribe: anAnnouncementClass send: aSelector to: anObject "Declare that when anAnnouncementClass is raised, anObject should receive the message aSelector." ^ self subscribe: anAnnouncementClass do: (MessageSend receiver: anObject selector: aSelector)! ! !Announcer methodsFor: 'initialization' stamp: 'IgorStasenko 3/12/2011 16:50'! initialize super initialize. registry := SubscriptionRegistry new.! ! !Announcer methodsFor: 'private' stamp: 'IgorStasenko 3/22/2011 15:27'! replace: subscription with: newOne ^ registry replace: subscription with: newOne ! ! !Announcer methodsFor: '*RPackage-core' stamp: 'EstebanLorenzano 8/3/2012 15:01'! hasSubscriber: anObject registry subscriptionsOf: anObject do: [:each | ^ true]. ^ false! ! !Announcer methodsFor: '*announcements-view' stamp: 'lr 9/20/2006 08:18'! open AnnouncementSpy openOn: self! ! !Announcer methodsFor: '*RPackage-core' stamp: 'StephaneDucasse 4/23/2011 12:43'! subscriptions ^ registry! ! !Announcer methodsFor: 'subscription' stamp: 'StephaneDucasse 4/24/2011 11:09'! removeSubscription: subscription "Remove the given subscription from the receiver" ^ registry remove: subscription ! ! !Announcer methodsFor: 'subscription' stamp: 'StephaneDucasse 4/24/2011 12:17'! subscribe: anAnnouncementClass do: aValuable "Declare that when anAnnouncementClass is raised, aValuable is executed." ^ registry add: ( AnnouncementSubscription new announcer: self; announcementClass: anAnnouncementClass; valuable: aValuable)! ! !Announcer methodsFor: 'weak' stamp: 'IgorStasenko 3/12/2011 20:26'! weak "announcer weak subscribe: foo" ^ WeakSubscriptionBuilder on: self! ! !Announcer methodsFor: 'subscription' stamp: 'StephaneDucasse 4/24/2011 12:15'! unsubscribe: anObject "Unsubscribe all subscriptions of anObject from the receiver" registry removeSubscriber: anObject! ! !Announcer methodsFor: 'convenience' stamp: 'StephaneDucasse 8/22/2013 22:59'! when: anAnnouncementClass send: aSelector to: anObject "Declare that when anAnnouncementClass is raised, anObject should receive the message aSelector. When the message expects one argument (eg #fooAnnouncement:) the announcement is passed as argument. When the message expects two arguments (eg #fooAnnouncement:announcer:) both the announcement and the announcer are passed as argument" ^ self subscribe: anAnnouncementClass send: aSelector to: anObject! ! !AnnouncerTest commentStamp: 'Tbn 11/12/2010 10:55'! An AnnouncerTest is a test class used to test Announcer. Instance Variables announcer: the announcer to test announcer - the announcer that is tested ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:10'! testUnsubscribeBlock | announcement | announcer subscribe: AnnouncementMockA do: [ :ann | announcement := ann ]. announcer unsubscribe: self. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testNoArgBlock "we are supposed to accept zero-argument blocks as actions " | announcement counter | counter := nil. announcer subscribe: AnnouncementMockA do: [ counter := 1 ]. announcer announce: AnnouncementMockA new. self assert: counter = 1! ! !AnnouncerTest methodsFor: 'testing' stamp: 'StephaneDucasse 2/22/2013 18:26'! testSymbolIdentifier | passed | passed := false. [announcer on: #FOO send: #bar to: nil; announce: #FOO ] on: MessageNotUnderstood do: [ :ex | passed := (ex message selector = #bar). ]. self assert: passed ! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:07'! testSubscribeSet | announcement instance | announcer subscribe: AnnouncementMockA , AnnouncementMockC do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement isNil. announcement := nil. instance := announcer announce: AnnouncementMockC. self assert: announcement = instance! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:13'! testUnsubscribeSet | announcement | announcer subscribe: AnnouncementMockA , AnnouncementMockB do: [ :ann | announcement := ann ]. announcer unsubscribe: self. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil. announcement := nil. announcer announce: AnnouncementMockB new. self assert: announcement isNil.! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:06'! testSubscribeSubclass | announcement instance | announcer subscribe: AnnouncementMockB do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement isNil. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockC. self assert: announcement = instance.! ! !AnnouncerTest methodsFor: 'running' stamp: 'lr 2/26/2011 11:34'! setUp super setUp. announcer := self newAnnouncer! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 9/25/2006 09:13'! testUnsubscribeSend | announcement receiver | announcer subscribe: AnnouncementMockA send: #value: to: (receiver := [ :ann | announcement := ann ]). announcer unsubscribe: receiver. announcement := nil. announcer announce: AnnouncementMockA new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'private' stamp: 'lr 2/26/2011 11:34'! newAnnouncer ^ Announcer new! ! !AnnouncerTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testTwoArgBlock "we are supposed to accept two-argument blocks as actions " | announcement flag | announcer subscribe: AnnouncementMockA do: [ :ann :announcer2 | flag := announcer2 == announcer ]. announcer announce: AnnouncementMockA new. self assert: flag! ! !AnnouncerTest methodsFor: 'testing' stamp: 'IgorStasenko 1/2/2012 15:54'! testAnnouncingReentrant " Test that it is safe to announce when handling announcement, so announcer are reentrant " " self run: #testAnnouncingReentrant " | bool ok | ok := bool := false. announcer on: Announcement do: [ bool ifFalse: [ bool := true. announcer announce: Announcement new. ] ifTrue: [ ok := true ] ]. self should: [ announcer announce: Announcement new. ] notTakeMoreThan: 1 second. self assert: ok ! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:07'! testSubscribeSend | announcement instance | announcer subscribe: AnnouncementMockA send: #value: to: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB new. self assert: announcement isNil! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:11'! testAnnounceClass self assert: (announcer announce: AnnouncementMockA) class = AnnouncementMockA! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:10'! testAnnounceInstance | instance | instance := AnnouncementMockA new. self assert: (announcer announce: instance) = instance! ! !AnnouncerTest methodsFor: 'testing' stamp: 'lr 3/2/2009 10:08'! testSubscribeBlock | announcement instance | announcer subscribe: AnnouncementMockA do: [ :ann | announcement := ann ]. announcement := nil. instance := announcer announce: AnnouncementMockA. self assert: announcement = instance. announcement := nil. instance := announcer announce: AnnouncementMockB. self assert: announcement isNil! ! !AnnouncerTest class methodsFor: 'testing' stamp: 'lr 2/26/2011 11:35'! shouldInheritSelectors ^ true! ! !AnonymousClassInstaller commentStamp: ''! I am a class installer that does not expose the class to the global environment nor announces that a new class has been created. As it's name suggest it is used for anonymous classes, for instance in Tests.! !AnonymousClassInstaller methodsFor: 'notifications' stamp: 'ToonVerwaest 3/22/2011 17:45'! classAdded: aClass inCategory: aCategory! ! !AnonymousClassInstaller methodsFor: 'notifications' stamp: 'ToonVerwaest 3/22/2011 18:38'! classDefinitionDeeplyChangedFrom: oldClass to: newClass by: classModification! ! !AnonymousClassInstaller methodsFor: 'accessing' stamp: 'ToonVerwaest 3/22/2011 17:46'! environment: anEnvironment! ! !AnonymousClassInstaller methodsFor: 'notifications' stamp: 'ToonVerwaest 3/22/2011 18:38'! classDefinitionShallowChangedFrom: oldClass to: newClass by: classModification! ! !AnonymousClassInstaller methodsFor: 'migrating' stamp: 'ToonVerwaest 3/22/2011 18:30'! migrateClasses: old to: new using: anInstanceModification! ! !AnonymousClassInstaller methodsFor: 'accessing' stamp: 'ToonVerwaest 3/22/2011 17:46'! classAt: aName ifAbsent: aBlock ^ aBlock value! ! !AnonymousClassInstaller methodsFor: 'notifications' stamp: 'ToonVerwaest 3/22/2011 17:46'! recategorize: aClass to: aCategory! ! !AppRegistry commentStamp: 'ads 4/2/2003 15:30'! AppRegistry is a simple little class, not much more than a wrapper around a collection. It's intended to help break dependencies between packages. For example, if you'd like to be able to send e-mail, you could use the bare-bones MailComposition class, or you could use the full-blown Celeste e-mail client. Instead of choosing one or the other, you can call "MailSender default" (where MailSender is a subclass of AppRegistry), and thus avoid creating a hard-coded dependency on either of the two mail senders. This will only really be useful, of course, for applications that have a very simple, general, well-defined interface. Most of the time, you're probably better off just marking your package as being dependent on a specific other package, and avoiding the hassle of this whole AppRegistry thing. But for simple things like e-mail senders or web browsers, it might be useful. ! !AppRegistry methodsFor: 'notes' stamp: 'ads 4/2/2003 15:04'! seeClassSide "All the code for AppRegistry is on the class side."! ! !AppRegistry class methodsFor: 'registering' stamp: 'SeanDeNigris 9/15/2010 01:25'! register: aProviderClass (self registeredClasses includes: aProviderClass) ifTrue: [ ^ self ]. self askForNewDefaultOnNextRequest. "if you're registering a new app you probably want to use it" self registeredClasses add: aProviderClass.! ! !AppRegistry class methodsFor: 'registering' stamp: 'ads 3/29/2003 13:36'! appName "Defaults to the class name, which is probably good enough, but you could override this in subclasses if you want to." ^ self name! ! !AppRegistry class methodsFor: 'cleanup' stamp: 'StephaneDucasse 1/30/2011 21:35'! removeObsolete "AppRegistry removeObsolete" self registeredClasses copy do:[:cls| (cls class isObsolete or:[cls isBehavior and:[cls isObsolete]]) ifTrue:[self unregister: cls]]. self subclasses do:[:cls| cls removeObsolete].! ! !AppRegistry class methodsFor: 'registering' stamp: 'ads 3/29/2003 13:03'! unregister: aProviderClass (default = aProviderClass) ifTrue: [default := nil]. self registeredClasses remove: aProviderClass ifAbsent: [].! ! !AppRegistry class methodsFor: 'cleanup' stamp: 'StephaneDucasse 1/30/2011 21:38'! reset "AppRegistry reset" registeredClasses := nil.! ! !AppRegistry class methodsFor: 'registering' stamp: 'ads 3/29/2003 13:01'! registeredClasses ^ registeredClasses ifNil: [registeredClasses := OrderedCollection new]! ! !AppRegistry class methodsFor: 'singleton' stamp: 'BenjaminVanRyseghem 2/24/2012 15:51'! default: aClassOrNil "Sets my default to aClassOrNil. Answers the old default." | oldDefault | oldDefault := default. aClassOrNil ifNotNil: [ self register: aClassOrNil ]. default := aClassOrNil. ^ oldDefault! ! !AppRegistry class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:16'! cleanUp "AppRegistry cleanUp" self removeObsolete.! ! !AppRegistry class methodsFor: 'singleton' stamp: 'ads 3/29/2003 13:11'! default ^ default ifNil: [self askForDefault]! ! !AppRegistry class methodsFor: 'private' stamp: 'SeanDeNigris 9/15/2010 01:24'! askForNewDefaultOnNextRequest default := nil.! ! !AppRegistry class methodsFor: 'private' stamp: 'StephaneDucasse 1/28/2011 15:16'! chooseApp: anIndex ^default := self registeredClasses at: anIndex ifAbsent: [nil]! ! !AppRegistry class methodsFor: 'singleton' stamp: 'StephaneDucasse 1/28/2011 15:16'! askForDefault "self askForDefault" self registeredClasses isEmpty ifTrue: [self inform: 'There are no ', self appName, ' applications registered.'. ^ default := nil]. self registeredClasses size = 1 ifTrue: [^ default := self registeredClasses anyOne]. ^Smalltalk globals at: #UIManager ifPresent: [:class | self chooseAppWithUI] ifAbsent: [| stream | stream := WriteStream with: 'You have to choose a Class by using ''#chooseApp: index:'''. stream nextPut: Character cr. self registeredClasses doWithIndex: [:class :index | stream nextPutAll: index asString; nextPutAll: ' - '; nextPutAll: class name asString; nextPut: Character cr]. self inform: stream contents. default := nil]! ! !AppRegistry class methodsFor: 'ui' stamp: 'BenjaminVanRyseghem 2/22/2012 14:41'! chooseAppWithUI default := UIManager default chooseFrom: (self registeredClasses collect: [:c | c name]) values: self registeredClasses title: ('Which ' , self appName, ' would you prefer?') translated. default ifNil: [default := self registeredClasses first]. WorldState defaultWorldMenu. ^ default.! ! !AppRegistry class methodsFor: 'singleton' stamp: 'nk 3/9/2004 12:35'! defaultOrNil ^ default! ! !ApplicationWithToolbar commentStamp: 'BenjaminVanRyseghem 2/18/2014 23:30'! I am a simple example showing how to use a menu model to have a menu toolbar. ApplicationWithToolbar new openWithSpec! !ApplicationWithToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/18/2014 23:51'! initializeWidgets menu := MenuModel new addGroup: [ :group | group addItem: [ :item | item name: 'File'; icon: Smalltalk ui icons openIcon; subMenu: self subMenu ]. group addItem: [ :item | item name: nil; description: 'Open file'; icon: Smalltalk ui icons openIcon; action: [ self inform: 'Open File' ] ]. group addItem: [ :item | item name: nil; description: 'Save File'; icon: Smalltalk ui icons smallSaveIcon; action: [ self inform: 'Save File' ] ]. group addItem: [ :item | item name: nil; description: 'Print file'; icon: Smalltalk ui icons smallPrintIcon; action: [ self inform: 'Print file' ] ] ]; addGroup: [ :group | group addItem: [ :item | item name: nil; description: 'Undo'; icon: Smalltalk ui icons smallUndoIcon; action: [ self inform: 'Undo' ] ]. group addItem: [ :item | item name: nil; description: 'Redo'; icon: Smalltalk ui icons smallRedoIcon; action: [ self inform: 'Redo' ] ] ]. menu applyTo: self. text := self newText. self focusOrder add: text! ! !ApplicationWithToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/18/2014 23:52'! subMenu ^ MenuModel new addGroup: [ :group | group addItem: [ :item | item name: 'Open'; icon: Smalltalk ui icons openIcon; shortcut: $o command; action: [ self inform: 'Open' ] ]. group addItem: [ :item | item name: 'Save'; icon: Smalltalk ui icons smallSaveIcon; shortcut: $s command; action: [ self inform: 'Save' ] ]. group addItem: [ :item | item name: 'Print'; shortcut: $p command; icon: Smalltalk ui icons smallPrintIcon; action: [ self inform: 'Print' ] ]. group addItem: [ :item | item name: 'Kill'; shortcut: $k command; icon: Smalltalk ui icons smallCancelIcon; action: [ self inform: 'Kill' ] ] ]! ! !ApplicationWithToolbar methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/18/2014 23:20'! menu ^ menu! ! !ApplicationWithToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/18/2014 23:47'! title ^ 'Text editor'! ! !ApplicationWithToolbar methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/18/2014 23:20'! text ^ text! ! !ApplicationWithToolbar class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/18/2014 23:21'! defaultSpec ^ SpecLayout composed newColumn: [ :c | c add: #menu height: self toolbarHeight; add: #text ]; yourself! ! !Archive commentStamp: ''! This is the abstract superclass for file archives. Archives can be read from or written to files, and contain members that represent files and directories.! !Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:00'! addTree: aFileNameOrDirectory removingFirstCharacters: n ^ self addTree: aFileNameOrDirectory removingFirstCharacters: n match: [:e | true]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! membersMatching: aString ^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]! ! !Archive methodsFor: 'archive operations' stamp: 'StephaneDucasse 6/22/2012 19:01'! addTree: aFileNameOrDirectory match: aBlock | nameSize | nameSize := aFileNameOrDirectory isString ifTrue: [aFileNameOrDirectory size] ifFalse: [aFileNameOrDirectory fullName size]. ^ self addTree: aFileNameOrDirectory removingFirstCharacters: nameSize + 1 match: aBlock! ! !Archive methodsFor: 'private' stamp: 'nk 2/21/2001 18:14'! memberClass self subclassResponsibility! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:29'! addFile: aFileName ^self addFile: aFileName as: aFileName! ! !Archive methodsFor: 'archive operations' stamp: 'CamilloBruni 5/4/2012 21:18'! extractMember: aMemberOrName | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: member localFileName inDirectory: FileSystem workingDirectory.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:59'! numberOfMembers ^members size! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 20:58'! writeTo: aStream self subclassResponsibility! ! !Archive methodsFor: 'archive operations' stamp: 'CamilloBruni 5/4/2012 21:18'! extractMemberWithoutPath: aMemberOrName self extractMemberWithoutPath: aMemberOrName inDirectory: FileSystem workingDirectory.! ! !Archive methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! initialize super initialize. members := OrderedCollection new.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! addDirectory: aFileName ^self addDirectory: aFileName as: aFileName ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! addMember: aMember ^members addLast: aMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! extractMember: aMemberOrName toFileNamed: aFileName | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: aFileName! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! addString: aString as: aFileName | newMember | newMember := self memberClass newFromString: aString named: aFileName. self addMember: newMember. newMember localFileName: aFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! memberNamed: aString "Return the first member whose zip name or local file name matches aString, or nil" ^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: [ ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! contentsOf: aMemberOrName | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. ^member contents! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! removeMember: aMemberOrName | member | member := self member: aMemberOrName. member ifNotNil: [ members remove: member ]. ^member! ! !Archive methodsFor: 'private' stamp: 'nk 2/22/2001 07:56'! member: aMemberOrName ^(members includes: aMemberOrName) ifTrue: [ aMemberOrName ] ifFalse: [ self memberNamed: aMemberOrName ].! ! !Archive methodsFor: 'archive operations' stamp: 'SeanDeNigris 2/5/2013 15:14'! addTree: aFileNameOrDirectory removingFirstCharacters: n match: aBlock | dir relativePath matches | dir := aFileNameOrDirectory asFileReference. relativePath := (dir fullName allButFirst: n) asFileReference. matches := dir entries select: [ :entry | aBlock value: entry ]. matches do: [ :e | | newMember | newMember := e isDirectory ifTrue: [ self memberClass newFromDirectory: e fullName ] ifFalse: [ self memberClass newFromFile: e fullName ]. newMember localFileName: (relativePath / e name) fullName. self addMember: newMember. e isDirectory ifTrue: [ self addTree: e fullName removingFirstCharacters: n match: aBlock ]. ]. ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 17:24'! setContentsOf: aMemberOrName to: aString | newMember oldMember | oldMember := self member: aMemberOrName. newMember := (self memberClass newFromString: aString named: oldMember fileName) copyFrom: oldMember. self replaceMember: oldMember with: newMember.! ! !Archive methodsFor: 'archive operations' stamp: 'StephaneDucasse 2/25/2010 18:02'! writeToFileNamed: aFileName "Catch attempts to overwrite existing zip file" (self canWriteToFileNamed: aFileName) ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ]. StandardFileStream forceNewFileNamed: aFileName do: [:stream | self writeTo: stream ] ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:57'! addDirectory: aFileName as: anotherFileName | newMember | newMember := self memberClass newFromDirectory: aFileName. self addMember: newMember. newMember localFileName: anotherFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'CamilloBruni 5/7/2012 02:03'! extractMemberWithoutPath: aMemberOrName inDirectory: dir | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: (member asFileReference basename) inDirectory: dir! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:00'! memberNames ^members collect: [ :ea | ea fileName ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! replaceMember: aMemberOrName with: newMember | member | member := self member: aMemberOrName. member ifNotNil: [ members replaceAll: member with: newMember ]. ^member! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:12'! canWriteToFileNamed: aFileName "Catch attempts to overwrite existing zip file" ^(members anySatisfy: [ :ea | ea usesFileNamed: aFileName ]) not. ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:58'! members ^members! ! !Archive methodsFor: 'archive operations' stamp: 'SeanDeNigris 5/18/2012 22:16'! addFile: aFileName as: anotherFileName | newMember | newMember := self memberClass newFromFile: aFileName. newMember localFileName: anotherFileName. self addMember: newMember. ^newMember! ! !ArchiveMember commentStamp: ''! This is the abstract superclass for archive members, which are files or directories stored in archives.! !ArchiveMember methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! initialize super initialize. fileName := ''. isCorrupt := false.! ! !ArchiveMember methodsFor: 'accessing' stamp: 'SeanDeNigris 6/19/2012 09:23'! localFileName: aString "Set my internal filename. Returns the (possibly new) filename" ^fileName := aString copyReplaceAll: FileSystem disk delimiter asString with: UnixStore delimiter asString.! ! !ArchiveMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'! close ! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! fileName ^fileName! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! fileName: aName fileName := aName! ! !ArchiveMember methodsFor: 'printing' stamp: 'nk 12/20/2002 15:11'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self fileName; nextPut: $)! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:06'! isCorrupt: aBoolean "Mark this member as being corrupt." isCorrupt := aBoolean! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:16'! isCorrupt ^isCorrupt ifNil: [ isCorrupt := false ]! ! !ArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 19:43'! usesFileNamed: aFileName "Do I require aFileName? That is, do I care if it's clobbered?" ^false! ! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! newFromFile: aFileName self subclassResponsibility! ! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! newFromString: aString self subclassResponsibility! ! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:33'! newDirectoryNamed: aString self subclassResponsibility! ! !ArgumentNamesTest commentStamp: 'TorstenBergmann 2/4/2014 20:45'! SUnit tests for generating argument names! !ArgumentNamesTest methodsFor: 'asserting' stamp: 'SeanDeNigris 5/28/2013 18:12'! argumentNameFor: anObject shouldBe: aString self assert: anObject class canonicalArgumentName equals: aString.! ! !ArgumentNamesTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/28/2013 18:01'! testString self argumentNameForInstanceOf: String shouldBe: 'aString'. self argumentNameForInstanceOf: ByteString shouldBe: 'aString'.! ! !ArgumentNamesTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/28/2013 18:01'! testDefault self argumentNameForInstanceOf: Object shouldBe: 'anObject'.! ! !ArgumentNamesTest methodsFor: 'asserting' stamp: 'SeanDeNigris 5/28/2013 18:10'! argumentNameForInstanceOf: aClass shouldBe: aString self assert: aClass canonicalArgumentName equals: aString.! ! !ArgumentNamesTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/28/2013 18:01'! testInteger self argumentNameForInstanceOf: Integer shouldBe: 'anInteger'.! ! !ArgumentNamesTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/28/2013 18:01'! testNumber self argumentNameForInstanceOf: Number shouldBe: 'aNumber'. self argumentNameForInstanceOf: Float shouldBe: 'aNumber'.! ! !ArgumentNamesTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/28/2013 18:01'! testCollection self argumentNameForInstanceOf: Collection shouldBe: 'aCollection'.! ! !ArgumentNamesTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/28/2013 18:29'! testAnPrefixForClassNameStartingWithVowel self testInteger.! ! !ArgumentNamesTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/28/2013 18:29'! testAPrefixForClassNameStartingWithConsonant self testCollection.! ! !ArgumentNamesTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/28/2013 18:45'! testClass self argumentNameForInstanceOf: Class shouldBe: 'aClass'. self argumentNameFor: Integer shouldBe: 'aClass'. self argumentNameFor: Collection shouldBe: 'aClass'.! ! !ArithmeticError commentStamp: ''! I am ArithmeticError, the superclass of all exceptions related to arithmetic.! !Array commentStamp: ''! I present an ArrayedCollection whose elements are objects.! !Array methodsFor: 'testing' stamp: 'eem 5/8/2008 11:13'! isArray ^true! ! !Array methodsFor: 'private' stamp: 'nice 7/20/2011 09:03'! hasLiteral: literal "Answer true if literal is identical to any literal in this array, even if imbedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralSymbol:" | lit | 1 to: self size do: [:index | ((lit := self at: index) literalEqual: literal) ifTrue: [^true]. (Array == lit class and: [lit hasLiteral: literal]) ifTrue: [^true]]. ^false! ! !Array methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:12'! fuelAccept: aGeneralMapper "This IF is because there are subclasses of Array that are weak. If we do not put this IF, all subclasses fuel be using the #visitVariableObject:, loosing the capability of the weak However, this method is just to optimize the method lookup of the message #fuelAccept:. If this method is removed, the default behavior of Object shuld work as well. If the performance is not that different, then we can remove this method which has an ugly if." ^ self class isWeak ifTrue: [ aGeneralMapper visitWeakObject: self ] ifFalse: [ aGeneralMapper visitVariableObject: self ] ! ! !Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! printAsLiteralFormOn: aStream aStream nextPut: $#. self printElementsOn: aStream ! ! !Array methodsFor: '*Collections-arithmetic' stamp: 'eem 6/11/2008 12:49'! preMultiplyByMatrix: m "Answer m+*self where m is a Matrix." m columnCount = self size ifFalse: [self error: 'dimensions do not conform']. ^(1 to: m rowCount) collect: [:row | | s | s := 0. 1 to: self size do: [:k | s := (m at: row at: k) * (self at: k) + s]. s]! ! !Array methodsFor: '*Collections-arithmetic' stamp: 'raok 10/22/2002 20:10'! preMultiplyByArray: a "Answer a+*self where a is an Array. Arrays are always understood as column vectors, so an n element Array is an n*1 Array. This multiplication is legal iff self size = 1." self size = 1 ifFalse: [self error: 'dimensions do not conform']. ^a * self first! ! !Array methodsFor: '*Collections-arithmetic' stamp: 'raok 10/22/2002 20:09'! +* aCollection "Premultiply aCollection by self. aCollection should be an Array or Matrix. The name of this method is APL's +.x squished into Smalltalk syntax." ^aCollection preMultiplyByArray: self ! ! !Array methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/15/2013 14:29'! generateSpecFormatArray | str symbols | str := self readStream. symbols := #( leftFraction: topFraction: rightFraction: bottomFraction: leftOffset: topOffset: rightOffset: bottomOffset: ). ^ String streamContents: [:s | s << '{#FrameLayout.' ; cr. self first asInteger== 0 ifFalse: [ s tab << ('#','leftFraction:.') << ' ' << self first asString <<'.'; cr ]. self second asInteger == 0 ifFalse: [ s tab << ('#','topFraction:.') << ' ' << self second asString <<'.'; cr]. self third asInteger == 1 ifFalse: [ s tab << ('#','rightFraction:.') << ' ' << self third asString <<'.';cr]. self fourth asInteger == 1 ifFalse: [ s tab << ('#','bottomFraction:.') << ' ' << self fourth asString <<'.';cr]. self size = 8 ifTrue: [ 5 to: 8 do: [:i | (self at: i) asInteger == 0 ifFalse: [ s tab << ('#',(symbols at: i) asString) <<'.' << ' ' << (self at:i) asString <<'.'. s cr ]]]. s skip: -1. s << '}']. ! ! !Array methodsFor: 'printing' stamp: 'BernardoContreras 11/6/2011 02:47'! printOn: aStream self shouldBePrintedAsLiteral ifTrue: [self printAsLiteralFormOn: aStream. ^ self]. self isSelfEvaluating ifTrue: [self printAsSelfEvaluatingFormOn: aStream. ^ self]. super printOn: aStream! ! !Array methodsFor: 'filter streaming' stamp: 'BernardoContreras 11/6/2011 17:04'! storeOnStream: aStream self shouldBePrintedAsLiteral ifTrue: [ super storeOnStream: aStream ] ifFalse: [ aStream writeCollection: self ] ! ! !Array methodsFor: '*Morphic-Base' stamp: 'StephaneDucasse 12/21/2012 13:53'! asLayoutFrame ^ LayoutFrame new fromArray: self! ! !Array methodsFor: '*monticellofiletree-core' stamp: 'dkh 4/6/2012 15:56:14'! writeCypressJsonOn: aStream forHtml: forHtml indent: startIndent "by default ignore ... is used for Dictionary and Array, i.e., container objects and String which actually encodes itself differently for HTML" | indent | aStream nextPutAll: '['; lf. indent := startIndent + 1. 1 to: self size do: [ :index | | item | item := self at: index. aStream tab: indent. item writeCypressJsonOn: aStream forHtml: forHtml indent: indent. index < self size ifTrue: [ aStream nextPutAll: ','; lf ] ]. self size = 0 ifTrue: [ aStream tab: indent ]. aStream nextPutAll: ' ]'! ! !Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:03'! atWrap: index put: anObject "Optimized to go through the primitive if possible" ^ self at: index - 1 \\ self size + 1 put: anObject! ! !Array methodsFor: 'converting' stamp: 'tpr 11/2/2004 11:31'! elementsExchangeIdentityWith: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array. The identityHashes remain with the pointers rather than with the objects so that objects in hashed structures should still be properly indexed after the mutation." otherArray class == Array ifFalse: [^ self error: 'arg must be array']. self size = otherArray size ifFalse: [^ self error: 'arrays must be same size']. (self anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. (otherArray anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. self with: otherArray do:[:a :b| a == b ifTrue:[^self error:'can''t become yourself']]. "Must have failed because not enough space in forwarding table (see ObjectMemory-prepareForwardingTableForBecoming:with:twoWay:). Do GC and try again only once" (Smalltalk bytesLeft: true) = Smalltalk primitiveGarbageCollect ifTrue: [^ self primitiveFailed]. ^ self elementsExchangeIdentityWith: otherArray! ! !Array methodsFor: 'self evaluating' stamp: 'StephaneDucasse 10/8/2011 12:07'! printAsSelfEvaluatingFormOn: aStream aStream nextPut: ${. self do: [:el | el printOn: aStream] separatedBy: [ aStream nextPutAll: '. ']. aStream nextPut: $}! ! !Array methodsFor: '*System-Settings-Browser' stamp: 'AlainPlantec 1/31/2010 10:35'! settingStoreOn: aStream "Use the literal form if possible." self isLiteral ifTrue: [aStream nextPut: $#; nextPut: $(. self do: [:element | element settingStoreOn: aStream. aStream space]. aStream nextPut: $)] ifFalse: [super settingStoreOn: aStream]! ! !Array methodsFor: 'converting' stamp: 'sma 5/12/2000 17:32'! asArray "Answer with the receiver itself." ^ self! ! !Array methodsFor: 'printing' stamp: 'ul 11/23/2010 13:28'! storeOn: aStream "Use the literal form if possible." self shouldBePrintedAsLiteral ifTrue: [aStream nextPut: $#; nextPut: $(. self do: [:element | element storeOn: aStream. aStream space]. aStream nextPut: $)] ifFalse: [super storeOn: aStream]! ! !Array methodsFor: 'testing' stamp: 'nice 11/2/2009 19:06'! isLiteral ^self class == Array and: [self allSatisfy: [:each | each isLiteral]]! ! !Array methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:03'! literalEqual: other self class == other class ifFalse: [^ false]. self size = other size ifFalse: [^ false]. self with: other do: [:e1 :e2 | (e1 literalEqual: e2) ifFalse: [^ false]]. ^ true! ! !Array methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/15/2014 17:14'! generateSpec | str spec | str := self readStream. spec := OrderedCollection with: #SpecLayoutFrame. #( leftFraction: topFraction: rightFraction: bottomFraction: leftOffset: topOffset: rightOffset: bottomOffset: ) do: [:sel | spec add: sel. str next ifNil: [ spec add: 0 ] ifNotNil: [:value | spec add: value ]]. ^ spec asArray! ! !Array methodsFor: 'testing' stamp: 'ul 11/23/2010 13:28'! shouldBePrintedAsLiteral ^self class == Array and: [ self allSatisfy: [ :each | each shouldBePrintedAsLiteral ] ]! ! !Array methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! copyWithDependent: newElement self size = 0 ifTrue:[^DependentsArray with: newElement]. ^self copyWith: newElement! ! !Array methodsFor: 'converting' stamp: 'MartinDias 7/1/2013 15:11'! elementsForwardIdentityTo: otherArray copyHash: copyHash "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. If copyHash is true, the identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation. That means that the identityHashes of the elements in otherArray are modified to be the ones of the corresponding elements in this array. If copyHash is false, then identityHashes stay with the objects and thus the elements in otherArray are not modified. In this case only the pointers to the elements in this array are forwarded." self primitiveFailed! ! !Array methodsFor: 'private' stamp: 'nice 7/20/2011 18:01'! refersToLiteral: literal "Answer true if literal is identical to any literal in this array, even if imbedded in further array structures or closure methods" 1 to: self size do: [ :index | | lit | (literal literalEqual: (lit := self at: index)) ifTrue: [ ^ true ]. (lit refersToLiteral: literal) ifTrue: [ ^ true ] ]. ^ false! ! !Array methodsFor: 'converting' stamp: 'di 3/28/1999 10:23'! elementsForwardIdentityTo: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." self primitiveFailed! ! !Array methodsFor: 'private' stamp: ''! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! isSelfEvaluating ^ (self allSatisfy: [:each | each isSelfEvaluating]) and: [self class == Array]! ! !Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:02'! atWrap: index "Optimized to go through the primitive if possible" ^ self at: index - 1 \\ self size + 1! ! !Array methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/15/2013 14:03'! generateSpecFormat | str symbols | str := self readStream. symbols := #( leftFraction: topFraction: rightFraction: bottomFraction: leftOffset: topOffset: rightOffset: bottomOffset: ). ^ String streamContents: [:s | s << '#(FrameLayout' ; cr. self first == 0 ifFalse: [ s tab << #leftFraction: << ' ' << self first asString; cr ]. self second == 0 ifFalse: [ s tab << #topFraction: << ' ' << self second asString; cr]. self third == 1 ifFalse: [ s tab << #rightFraction: << ' ' << self third asString ;cr]. self fourth == 1 ifFalse: [ s tab << #bottomFraction: << ' ' << self fourth asString ;cr]. self size = 8 ifTrue: [ 5 to: 8 do: [:i | (self at: i) == 0 ifFalse: [ s tab << (symbols at: i) << ' ' << (self at:i) asString. s cr ]]]. s skip: -1 s << ')']. ! ! !Array methodsFor: 'private' stamp: 'md 3/1/2006 21:09'! hasLiteralSuchThat: testBlock "Answer true if testBlock returns true for any literal in this array, even if imbedded in further Arrays or CompiledMethods. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" | lit | 1 to: self size do: [:index | (testBlock value: (lit := self at: index)) ifTrue: [^ true]. (lit hasLiteralSuchThat: testBlock) ifTrue: [^ true]]. ^ false! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'! braceWith: a with: b with: c with: d "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 4. array at: 1 put: a. array at: 2 put: b. array at: 3 put: c. array at: 4 put: d. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'! braceWith: a "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 1. array at: 1 put: a. ^ array! ! !Array class methodsFor: 'instance creation' stamp: 'md 7/19/2004 12:34'! new: sizeRequested "Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. This is a shortcut (direct call of primitive, no #initialize, for performance" "This method runs primitively if successful" ^ self basicNew: sizeRequested "Exceptional conditions will be handled in basicNew:" ! ! !Array class methodsFor: 'brace support' stamp: 'di 11/18/1999 22:53'! braceStream: nElements "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." ^ WriteStream basicNew braceArray: (self new: nElements) ! ! !Array class methodsFor: 'instance creation' stamp: 'StephaneDucasse 2/13/2010 12:18'! empty "A canonicalized empty Array instance." ^ #()! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'! braceWith: a with: b with: c "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 3. array at: 1 put: a. array at: 2 put: b. array at: 3 put: c. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'! braceWithNone "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." ^ self new: 0! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:15'! braceWith: a with: b "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array := self new: 2. array at: 1 put: a. array at: 2 put: b. ^ array! ! !ArrayLiteralTest commentStamp: 'TorstenBergmann 1/31/2014 11:22'! SUnit tests for array literals! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:35'! testByteArrayEmpty self class compile: 'array ^ #[]'. self assert: (self array isKindOf: ByteArray). self assert: (self array isEmpty)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:32'! testByteArrayRange self class compile: 'array ^ #[ 0 255 ]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 2). self assert: (self array first = 0). self assert: (self array last = 255)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:45'! testByteArrayLong self class compile: 'array ^ #[ ' , ((0 to: 255) inject: ' ' into: [ :r :e | r , ' ' , e asString ]) , ' ]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 256). 0 to: 255 do: [ :index | self assert: (self array at: index + 1) = index ]! ! !ArrayLiteralTest methodsFor: 'initialization' stamp: 'avi 2/16/2004 21:09'! tearDown self class removeSelector: #array! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'Henrik Sperre Johansen 3/23/2009 13:55'! testByteArrayWithinArray self class compile: 'array ^ #( #[1] #[2] )'. self assert: (self array isKindOf: Array). self assert: (self array size = 2). self assert: (self array first isKindOf: ByteArray). self assert: (self array first first = 1). self assert: (self array last isKindOf: ByteArray). self assert: (self array last first = 2) ! ! !ArrayLiteralTest methodsFor: 'running' stamp: 'EstebanLorenzano 8/3/2012 13:59'! runCase SystemAnnouncer uniqueInstance suspendAllWhile: [ super runCase ] ! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:36'! testByteArrayLiteral self class compile: 'array ^ #[ 1 2 3 4 ]'. self assert: (self array = self array). self assert: (self array == self array)! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:34'! testByteArrayBase self class compile: 'array ^ #[2r1010 8r333 16rFF]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 3). self assert: (self array first = 10). self assert: (self array second = 219). self assert: (self array last = 255) ! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:09'! testSymbols self class compile: 'array ^ #(#nil #true #false #''nil'' #''true'' #''false'')'. self assert: self array = {#nil. #true. #false. #nil. #true. #false}.! ! !ArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:08'! testReservedIdentifiers self class compile: 'array ^ #(nil true false)'. self assert: self array = {nil. true. false}.! ! !ArrayTest commentStamp: ''! This is the unit test for the class Array. 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 - there is a chapter in the PharoByExample book (http://pharobyexample.org/) - the sunit class category! !ArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButLast "self debug: #testAllButLast" | abf col | col := self moreThan3Elements. abf := col allButLast. self deny: abf last = col last. self assert: abf size + 1 = col size! ! !ArrayTest methodsFor: 'requirements' stamp: 'SebastianTleye 6/28/2013 14:36'! simpleCollection ^simpleCollection.! ! !ArrayTest methodsFor: 'tests - begins ends with' stamp: ''! testsEndsWith self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst). self assert: (self nonEmpty endsWith: self nonEmpty). self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first)).! ! !ArrayTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceAllWith1Occurence | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . index:= firstIndexesOfOccurrence at: 1. "verify content of 'result' : " "first part of 'result'' : '" 1 to: (index -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " index to: (index + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) ]. " end part :" endPartIndexResult := index + self replacementCollection size . endPartIndexCollection := index + self oldSubCollection size . 1 to: (result size - endPartIndexResult - 1 ) do: [ :i | self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). ]. ! ! !ArrayTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElementsOfIdenticalCollectionObjects "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" self assert: (self empty hasEqualElements: self empty). self assert: (self nonEmpty hasEqualElements: self nonEmpty). ! ! !ArrayTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOf "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyWithReplacementTest self replacementCollection. self oldSubCollection. self collectionWith1TimeSubcollection. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:53'! moreThan4Elements " return a collection including at leat 4 elements" ^ example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! secondIndex ^ secondIndex ! ! !ArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testFirstNElements "self debug: #testFirstNElements" | result | result := self moreThan3Elements first: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: Error! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:29'! collectionWith2TimeSubcollection ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst),self oldSubCollection .! ! !ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testFromToPut | collection index | index := self indexArray anyOne. collection := self nonEmpty copy. collection from: 1 to: index put: self aValue.. 1 to: index do: [:i | self assert: (collection at: i)= self aValue]. (index +1) to: collection size do: [:i | self assert: (collection at:i)= (self nonEmpty at:i)].! ! !ArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithoutFirst | result | result := self nonEmpty copyWithoutFirst. self assert: result size = (self nonEmpty size - 1). 1 to: result size do: [:i | self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0TStructuralEqualityTest self empty. self nonEmpty. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty! ! !ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !ArrayTest methodsFor: 'testing' stamp: 'nice 11/3/2009 21:28'! testIsLiteral "We work with a copy of literalArray, to avoid corrupting the code." | aLiteralArray | aLiteralArray := literalArray copy. self assert: aLiteralArray isLiteral. aLiteralArray at: 1 put: self class. self deny: aLiteralArray isLiteral. self deny: (literalArray as: WeakArray) isLiteral description: 'instances of Array subclasses are not literal'.! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testBefore "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). self should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] raise: Error. self should: [ self moreThan4Elements before: 66 ] raise: Error! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testLastIndexOfDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! unsortedCollection ^unsortedCollection .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! collectionOfFloat ^ collectionOfCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:09'! collectionWithoutEqualElements ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'test - creation' stamp: ''! testWith "self debug: #testWith" | aCol anElement | anElement := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: anElement. self assert: (aCol includes: anElement).! ! !ArrayTest methodsFor: 'tests - sequence isempty' stamp: ''! testSequenceIfNotEmptyifEmpty self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! ! !ArrayTest methodsFor: 'tests - converting' stamp: ''! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !ArrayTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asArray sort. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !ArrayTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !ArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyNotSame "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self nonEmpty copy. self deny: copy == self nonEmpty.! ! !ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindFirst | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. self assert: result=1. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyUpToWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpTo:' should copy until the first occurence :" result := collection copyUpTo: (element ). "verifying content: " self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! firstOdd "Returns the first odd number of #collection" ^ 1! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithIndexCollect | result index collection | index := 0. collection := self nonEmptyMoreThan1Element . result := collection withIndexCollect: [:each :i | self assert: i = (index := index + 1). self assert: i = (collection indexOf: each) . each] . 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. self assert: result size = collection size.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! firstIndex ^ firstIndex ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! testOFixtureReplacementSequencedTest self nonEmpty. self deny: self nonEmpty isEmpty. self elementInForReplacement. self assert: (self nonEmpty includes: self elementInForReplacement ) . self newElement. self firstIndex. self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). self secondIndex. self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). self assert: self firstIndex <=self secondIndex . self replacementCollection. self replacementCollectionSameSize. self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size ! ! !ArrayTest methodsFor: 'tests - printing' stamp: ''! testPrintElementsOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !ArrayTest methodsFor: 'tests - begins ends with' stamp: ''! testsEndsWithEmpty self deny: (self nonEmpty endsWith: self empty). self deny: (self empty endsWith: self nonEmpty). ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIterateSequencedReadableTest | res | self nonEmptyMoreThan1Element. self assert: self nonEmptyMoreThan1Element size > 1. self empty. self assert: self empty isEmpty . res := true. self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false.! ! !ArrayTest methodsFor: 'tests - concatenation' stamp: ''! testConcatenationWithEmpty | result | result:= self empty,self secondCollection . 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:i). ]. "size : " self assert: result size = ( self secondCollection size).! ! !ArrayTest methodsFor: 'tests - accessing' stamp: 'delaunay 4/10/2009 16:19'! testAtWrap2 | tabTest | tabTest := #(5 6 8 ). self assert: (tabTest atWrap: 2) = 6. self assert: (tabTest atWrap: 7) = 5. self assert: (tabTest atWrap: 5) = 6. self assert: (tabTest atWrap: 0) = 8. self assert: (tabTest atWrap: 1) = 5. self assert: (tabTest atWrap: -2) = 5! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyUpToLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpToLast:' should copy until the last occurence :" result := collection copyUpToLast: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (result at: i ) = ( collection at: i ) ]. self assert: result size = (collection size - 1). ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! anotherElementNotIn ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtAllIndexesPut self nonEmpty atAllPut: self aValue. self nonEmpty do:[ :each| self assert: each = self aValue]. ! ! !ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testSwapWith "self debug: #testSwapWith" | result index | index := self indexArray anyOne. result:= self nonEmpty copy . result swap: index with: 1. self assert: (result at: index) = (self nonEmpty at:1). self assert: (result at: 1) = (self nonEmpty at: index). ! ! !ArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithSequenceable | result index element | index := self indexInNonEmpty . element := self nonEmpty at: index. result := self nonEmpty copyWith: (element ). self assert: result size = (self nonEmpty size + 1). self assert: result last = element . 1 to: (result size - 1) do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! !ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:28'! collectionWith1TimeSubcollection ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst). ! ! !ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtAllPut | | self nonEmpty atAll: self indexArray put: self aValue.. self indexArray do: [:i | self assert: (self nonEmpty at: i)=self aValue ]. ! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtOutOfBounds "self debug: #testAtOutOfBounds" self should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] raise: Error. self should: [ self moreThan4Elements at: -1 ] raise: Error! ! !ArrayTest methodsFor: 'test - creation' stamp: ''! testOfSize "self debug: #testOfSize" | aCol | aCol := self collectionClass ofSize: 3. self assert: (aCol size = 3). ! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:52'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: self elementInForOccurrences. self assert: result = 0! ! !ArrayTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithCollect | result firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := 0. result := firstCollection with: secondCollection collect: [:a :b | ( index := index + 1). self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b. b]. 1 to: result size do:[: i | self assert: (result at:i)= (secondCollection at: i)]. self assert: result size = secondCollection size.! ! !ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSetAritmeticTest self collection. self deny: self collection isEmpty. self nonEmpty. self deny: self nonEmpty isEmpty. self anotherElementOrAssociationNotIn. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self collectionClass! ! !ArrayTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiter | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:22'! elementInCollectionOfFloat ^ collectionOfCollection atRandom! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:39'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ collectionWithoutNil ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePutTest self aValue. self anotherValue. self anIndex. self nonEmpty isDictionary ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. self empty. self assert: self empty isEmpty . self nonEmpty. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeWithIdentityTest | anElement | self collectionWithCopyNonIdentical. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self collectionWithoutEqualElements. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !ArrayTest methodsFor: 'tests - replacing' stamp: ''! testReplaceFromToWithStartingAt | result repStart collection replacementCollec firstInd secondInd | collection := self nonEmpty . result := collection copy. replacementCollec := self replacementCollectionSameSize . firstInd := self firstIndex . secondInd := self secondIndex . repStart := replacementCollec size - ( secondInd - firstInd + 1 ) + 1. result replaceFrom: firstInd to: secondInd with: replacementCollec startingAt: repStart . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstInd - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstInd ) to: ( replacementCollec size - repStart +1 ) do: [:i| self assert: (result at: i)=( replacementCollec at: ( repStart + ( i - firstInd ) ) ) ]. " end part :" ( firstInd + replacementCollec size ) to: ( result size ) do: [ :i | self assert: ( result at: i ) = ( collection at: ( secondInd + 1 - ( firstInd + replacementCollec size ) + i ) ) ].! ! !ArrayTest methodsFor: 'requirements' stamp: ''! valueArray " return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty' at indexes in 'indexArray' " | result | result := Array new: self indexArray size. 1 to: result size do: [:i | result at:i put: (self aValue ). ]. ^ result.! ! !ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterMore | delim multiItemStream result index | "delim := ', '. multiItemStream := '' readWrite. self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. self assert: multiItemStream contents = '1, 2, 3'." delim := ', '. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. index:=1. (result findBetweenSubStrs: ', ' )do: [:each | self assert: each= ((self nonEmpty at:index)asString). index:=index+1 ].! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! anIndex ^ 2! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:01'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^ collection5Elements ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testDetectSequenced " testing that detect keep the first element returning true for sequenceable collections " | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. self assert: result = element. ! ! !ArrayTest methodsFor: 'tests - includes' stamp: ''! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'delaunay 4/14/2009 14:13'! testDo2 | res | res := OrderedCollection new. self collection do: [:each | res add: each class]. self assert: res asArray = self result. ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureAsStringCommaAndDelimiterTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty. self nonEmpty1Element. self assert: self nonEmpty1Element size = 1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:16'! collectionMoreThan1NoDuplicates " return a collection of size 5 without equal elements" ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'tests - sorting' stamp: ''! testSorted | result tmp unsorted | unsorted := self unsortedCollection. result := unsorted sorted. self deny: unsorted == result. tmp := result at: 1. result do: [ :each | self assert: each >= tmp. tmp := each ]! ! !ArrayTest methodsFor: 'tests - enumerating' stamp: ''! testFlattened self assert: self simpleCollection flattened equals: #(1 8 3). self assert: self collectionOfCollectionsOfInts flattened equals: #( 1 2 3 4 5 6 ). self assert: self collectionWithCharacters flattened equals: #($a $x $d $c $m). self assert: self collectionOfCollectionsOfStrings flattened equals: #('foo' 'bar' 'zorg').! ! !ArrayTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAny: self empty). self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAny: self nonEmpty).! ! !ArrayTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! elementToAdd ^ 55! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testPairsDo | index | index:=1. self nonEmptyMoreThan1Element pairsDo: [:each1 :each2 | self assert:(self nonEmptyMoreThan1Element at:index)=each1. self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. index:=index+2]. self nonEmptyMoreThan1Element size odd ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! !ArrayTest methodsFor: 'requirements' stamp: ''! collectionWithCopy "return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals ( with identity equality) but 2 elements only equals with classic equality" | result collection | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. collection add: collection first copy. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !ArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testLastNElements "self debug: #testLastNElements" | result | result := self moreThan3Elements last: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] raise: Error! ! !ArrayTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/30/2008 19:02'! accessCollection ^ example1! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testCollectFromTo | result | result:=self nonEmptyMoreThan1Element collect: [ :each | each ] from: 1 to: (self nonEmptyMoreThan1Element size - 1). 1 to: result size do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! !ArrayTest methodsFor: 'tests - enumerating' stamp: ''! testFlatCollect self assert: (self simpleCollection flatCollect: [ :x | { x } ]) equals: self simpleCollection. self assert: (self simpleCollection flatCollect: [ :x | { x } ]) species = self simpleCollection species. self assert: (self collectionOfCollectionsOfInts flatCollect: [ :x | { x } ]) equals: self collectionOfCollectionsOfInts. self assert: (self collectionWithCharacters flatCollect: [ :x | { x } ]) equals: self collectionWithCharacters. self assert: (self collectionOfCollectionsOfStrings flatCollect: [ :x | { x } ]) equals: self collectionOfCollectionsOfStrings! ! !ArrayTest methodsFor: 'tests - printing' stamp: ''! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream . Transcript show: result asString. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0SortingArrayedTest | tmp sorted | " an unsorted collection of number " self unsortedCollection. self unsortedCollection do: [ :each | each isNumber ]. sorted := true. self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ]. self assert: sorted = false. " a collection of number sorted in an ascending order" self sortedInAscendingOrderCollection. self sortedInAscendingOrderCollection do: [ :each | each isNumber ]. tmp := self sortedInAscendingOrderCollection at: 1. self sortedInAscendingOrderCollection do: [ :each | self assert: each >= tmp. tmp := each ]! ! !ArrayTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceAllWithManyOccurence | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | " testing fixture here as this method may be not used for collection that can't contain equals element :" self collectionWith2TimeSubcollection. self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection) = 2. " test :" diff := self replacementCollection size - self oldSubCollection size. result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection. "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection. " verifying that replacementCollection has been put in places of oldSubCollections " firstIndexesOfOccurrence do: [ :each | (firstIndexesOfOccurrence indexOf: each) = 1 ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ifFalse: [ each + diff to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ]. " verifying that the 'between' parts correspond to the initial collection : " 1 to: firstIndexesOfOccurrence size do: [ :i | i = 1 ifTrue: [ 1 to: (firstIndexesOfOccurrence at: i) - 1 do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ] ifFalse: [ resultBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self replacementCollection size. collectionBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self oldSubCollection size. 1 to: (firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | self assert: (result at: resultBetweenPartIndex + i - 1) = (self collectionWith2TimeSubcollection at: collectionBetweenPartIndex + i - 1) ] ] " specific comportement for the begining of the collection :" " between parts till the end : " ]. "final part :" 1 to: self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size) do: [ :i | self assert: (result at: firstIndexesOfOccurrence last + self replacementCollection size - 1 + i) = (self collectionWith2TimeSubcollection at: firstIndexesOfOccurrence last + self oldSubCollection size - 1 + i) ]! ! !ArrayTest methodsFor: 'test - equality' stamp: ''! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! elementInForElementAccessing " return an element inculded in 'accessCollection '" ^ self accessCollection anyOne! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 55 ]) = 1. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 55 ]) = collection size! ! !ArrayTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceFromToWithInsertion | result indexOfSubcollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . "verify content of 'result' : " "first part of 'result'' : '" 1 to: (indexOfSubcollection -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) ]. " end part :" (indexOfSubcollection + self replacementCollection size) to: (result size) do: [:i| self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. " verify size: " self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). ! ! !ArrayTest methodsFor: 'tests - replacing' stamp: ''! testReplaceFromToWith | result collection replacementCollec firstInd secondInd | collection := self nonEmpty . replacementCollec := self replacementCollectionSameSize . firstInd := self firstIndex . secondInd := self secondIndex . result := collection copy. result replaceFrom: firstInd to: secondInd with: replacementCollec . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstInd - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstInd ) to: ( firstInd + replacementCollec size - 1 ) do: [ :i | self assert: ( result at: i ) = ( replacementCollec at: ( i - firstInd +1 ) ) ]. " end part :" ( firstInd + replacementCollec size) to: (result size) do: [:i| self assert: ( result at: i ) = ( collection at: ( secondInd + 1 - ( firstInd + replacementCollec size ) + i ) ) ]. ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:16'! newElement ^999! ! !ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringMore "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' " | result resultAnd index allElementsAsString | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . index := 1. (result findBetweenSubStrs: ',' )do: [:each | index = 1 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. index:=index+1 ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size ) ifTrue: [ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] ]. i=(allElementsAsString size) ifTrue:[ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ]. ].! ! !ArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res anElement | anElement := self elementToAdd . res := self nonEmpty copyWith: anElement. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: (anElement value)). self nonEmpty do: [ :each | res includes: each ]! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! testCopyNonEmptyWithoutAllNotIncluded ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyEmptyMethod | result | result := self collectionWithoutEqualElements copyEmpty . self assert: result isEmpty . self assert: result class= self nonEmpty class.! ! !ArrayTest methodsFor: 'tests - index access' stamp: ''! testIdentityIndexOfIAbsent | collection element | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = 1. self assert: (collection identityIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 55 ]) = 55! ! !ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtAllPutAll | aValueArray | aValueArray := self valueArray . self nonEmpty atAll: self indexArray putAll: aValueArray . 1 to: self indexArray size do: [:i | self assert: (self nonEmpty at:(self indexArray at: i))= (aValueArray at:i) ]! ! !ArrayTest methodsFor: 'tests - find binary' stamp: 'SvenVanCaekenberghe 3/8/2012 14:17'! testFindBinary self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 1 - arg ]) = 1. self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 23 - arg ]) = 23. self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 11 - arg ]) = 11. self should: [ #(1 3 5 7 11 15 23) findBinary: [ :arg | 8 - arg ] ] raise: NotFound! ! !ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:57'! collectionWithEqualElements ^ withEqualElements.! ! !ArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOfSubCollectionStartingAt "self debug: #testIndexOfIfAbsent" | subcollection index collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. index := collection indexOfSubCollection: subcollection startingAt: 1. self assert: index = 1. index := collection indexOfSubCollection: subcollection startingAt: 2. self assert: index = 0! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:27'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyAfterWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the first occurence :" result := collection copyAfter: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (collection at:(i + 1 )) = (result at: (i)) ]. "verify size: " self assert: result size = (collection size - 1).! ! !ArrayTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !ArrayTest methodsFor: 'tests - enumerating' stamp: ''! testFlatCollectAs self assert: (self simpleCollection flatCollect: [ :x | { x }, { x } ] as: IdentitySet) equals: self simpleCollection asIdentitySet! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 8/31/2013 20:23'! test0FixtureTConvertAsSetForMultiplinessTest "a collection ofFloat with equal elements:" | res | self withEqualElements. self withEqualElements do: [ :each | self assert: each class = Float ]. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true. "a collection of Float without equal elements:" self elementsCopyNonIdenticalWithoutEqualElements. self elementsCopyNonIdenticalWithoutEqualElements do: [ :each | self assert: each class = Float ]. res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !ArrayTest methodsFor: 'tests - sorting' stamp: ''! testSortedUsingBlock | result tmp | result := self unsortedCollection sorted: [:a :b | a>b].. tmp := result at: 1. result do: [:each | self assert: each<=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/15/2009 14:22'! testIdentityIndexOf "self debug: #testIdentityIndexOf" | collection element | element := self elementInCollectionOfFloat copy. self deny: self elementInCollectionOfFloat == element. collection := self collectionOfFloat copyWith: element. self assert: (collection identityIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'testing' stamp: 'dc 5/24/2007 10:56'! testNewWithSize |array| array := Array new: 5. self assert: array size = 5. 1 to: 5 do: [:index | self assert: (array at: index) isNil]! ! !ArrayTest methodsFor: 'test - creation' stamp: ''! testWithAll "self debug: #testWithAll" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection . aCol := self collectionClass withAll: collection . collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. self assert: (aCol size = collection size ).! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 8/31/2013 20:53'! test0FixtureOccurrencesTest self empty. self assert: self empty isEmpty. self nonEmpty. self deny: self nonEmpty isEmpty. self elementInForOccurrences. self assert: (self nonEmpty includes: self elementInForOccurrences). self elementNotInForOccurrences. self deny: (self nonEmpty includes: self elementNotInForOccurrences)! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIndexAccessTest | res collection element | self collectionMoreThan1NoDuplicates. self assert: self collectionMoreThan1NoDuplicates size > 1. res := true. self collectionMoreThan1NoDuplicates detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self elementInForIndexAccessing. self assert: ((collection := self collectionMoreThan1NoDuplicates) includes: (element := self elementInForIndexAccessing)). self elementNotInForIndexAccessing. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !ArrayTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testComplexIsSelfEvaluating "self run: #testComplexIsSelfEvaluating" | complexArray restoredArray | complexArray := {1. true. false. nil. #a. 'a'. $a. (Float pi). (Float halfPi). (4 / 5). (Float infinity negated). (Color red). (1 @ 2). (0 @ 0 extent: 1 @ 1). ('hola' -> 0). Object. (Object class)}. complexArray := complexArray copyWith: complexArray. self assert: complexArray isSelfEvaluating. restoredArray := self class evaluate: complexArray printString. self assert: restoredArray = complexArray! ! !ArrayTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! sortedInAscendingOrderCollection ^sortedInAscendingOrderCollection . ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := 0. firstCollection with: secondCollection do: [:a :b | ( index := index + 1). self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b.] ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! secondCollection ^example2 ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testAllButFirstDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/13/2009 16:28'! testAnySatisfy self assert: ( self collection anySatisfy: [:each | each = -2]). self deny: (self collection anySatisfy: [:each | each isString]).! ! !ArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !ArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtWrap "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! !ArrayTest methodsFor: 'tests - concatenation' stamp: ''! testConcatenation | result index | result:= self firstCollection,self secondCollection . "first part : " index := 1. self firstCollection do: [:each | self assert: (self firstCollection at: index)=each. index := index+1.]. "second part : " 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:index). index:=index+1]. "size : " self assert: result size = (self firstCollection size + self secondCollection size).! ! !ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionItself "self debug: #testIntersectionItself" | result | result := (self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements). self assert: result size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (result includes: each) ]. ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! elementNotInForCopy ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:52'! testOccurrencesOf | result expected | result := self nonEmpty occurrencesOf: self elementInForOccurrences. expected := 0. self nonEmpty do: [ :each | self elementInForOccurrences = each ifTrue: [ expected := expected + 1 ] ]. self assert: result = expected! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testKeysAndValuesDo "| result | result:= OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| result add: (value+i)]. 1 to: result size do: [:i| self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !ArrayTest methodsFor: 'tests - converting' stamp: ''! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 8/31/2013 20:53'! test0CopyTest self empty. self assert: self empty size = 0. self nonEmpty. self assert: (self nonEmpty size = 0) not. self collectionWithElementsToRemove. self assert: (self collectionWithElementsToRemove size = 0) not. self elementToAdd! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:13'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ duplicateElement ! ! !ArrayTest methodsFor: 'tests - streaming' stamp: ''! testStreamContentsProtocol | result index | result:= self collectionClass << [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 16:56'! indexInNonEmpty ^ 2 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:17'! collectionWithNonIdentitySameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSequencedConcatenationTest self empty. self assert: self empty isEmpty. self firstCollection. self secondCollection! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIdentityIndexOfDuplicate "self debug: #testIdentityIndexOf" | collection element | "testing fixture here as this method may not be used by some collections testClass" self collectionWithNonIdentitySameAtEndAndBegining. collection := self collectionWithNonIdentitySameAtEndAndBegining. self assert: collection first = collection last. self deny: collection first == collection last. 1 to: collection size do: [ :i | i > 1 & (i < collection size) ifTrue: [ self deny: (collection at: i) = collection first ] ]. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals but are not the same object" self assert: (collection identityIndexOf: element) = collection size! ! !ArrayTest methodsFor: 'initialization' stamp: 'cyrille.delaunay 12/18/2009 11:59'! result ^ collectResult! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ collectionOfCollection! ! !ArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !ArrayTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !ArrayTest methodsFor: 'tests - begins ends with' stamp: ''! testsBeginsWith self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty last)). self assert: (self nonEmpty beginsWith:(self nonEmpty )). self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! !ArrayTest methodsFor: 'test - creation' stamp: 'stephane.ducasse 12/9/2008 22:00'! collectionClass ^ Array! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/8/2009 11:40'! nonEmpty1Element ^ nonEmpty1Element ! ! !ArrayTest methodsFor: 'tests - begins ends with' stamp: ''! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !ArrayTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceFromToWith | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . "verify content of 'result' : " "first part of 'result' " 1 to: (indexOfSubcollection - 1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) ]. " middle part containing replacementCollection : " (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) ]. " end part :" 1 to: (result size - lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). ]. ! ! !ArrayTest methodsFor: 'testing' stamp: 'MarcusDenker 5/2/2013 11:26'! testPrinting "self debug: #testPrinting" self assert: literalArray printString = '#(1 true 3 #four)'. self assert: (literalArray = (self class compiler evaluate: literalArray printString)). self assert: (selfEvaluatingArray = (self class compiler evaluate: selfEvaluatingArray printString)). self assert: nonSEArray1 printString = 'an Array(1 a Set(1))'. self assert: nonSEarray2 printString = '{#Array->Array}' ! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'delaunay 4/14/2009 14:12'! testDo | res | res := OrderedCollection new. self collection do: [:each | res add: each class]. self assert: res asArray = self result.! ! !ArrayTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElements "self debug: #testHasEqualElements" self deny: (self empty hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! !ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! firstEven "Returns the first even number of #collection" ^ -2! ! !ArrayTest methodsFor: 'tests - copying same contents' stamp: ''! testShuffled | result | result := self nonEmpty shuffled . "verify content of 'result: '" result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/5/2008 15:12'! selectorToAccessValuePutIn "return the selector of the method that should be invoked to access an element" ^ #second! ! !ArrayTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElementsIsTrueForNonIdenticalButEqualCollections "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" self assert: (self empty hasEqualElements: self empty copy). self assert: (self empty copy hasEqualElements: self empty). self assert: (self empty copy hasEqualElements: self empty copy). self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! !ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:18'! testIsSelfEvaluating self assert: example1 isSelfEvaluating. example1 at: 1 put: Bag new. self deny: example1 isSelfEvaluating. example1 at: 1 put: 1.! ! !ArrayTest methodsFor: 'tests - as identity set' stamp: ''! testAsIdentitySetWithIdentityEqualsElements | result | result := self collectionWithIdentical asIdentitySet. " Only one element should have been removed as two elements are equals with Identity equality" self assert: result size = (self collectionWithIdentical size - 1). self collectionWithIdentical do: [ :each | (self collectionWithIdentical occurrencesOf: each) > 1 ifTrue: [ "the two elements equals only with classic equality shouldn't 'have been removed" self assert: (result asOrderedCollection occurrencesOf: each) = 1 " the other elements are still here" ] ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ]. self assert: result class = IdentitySet! ! !ArrayTest methodsFor: 'test - equality' stamp: ''! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0TSequencedStructuralEqualityTest self nonEmpty at: 1 "Ensures #nonEmpty is sequenceable"! ! !ArrayTest methodsFor: 'tests - copy' stamp: ''! testCopySameClass "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self empty copy. self assert: copy class == self empty class.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:28'! elementInForCopy ^ elementInForCopy ! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAfter "self debug: #testAfter" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). self should: [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] raise: Error. self should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] raise: Error! ! !ArrayTest methodsFor: 'tests - sorting' stamp: ''! testIsSortedBy self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | ab]). ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 11:41'! oldSubCollection ^oldSubCollection ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureAsSetForIdentityMultiplinessTest "a collection (of elements for which copy is not identical ) without equal elements:" | anElement res | self elementsCopyNonIdenticalWithoutEqualElements. anElement := self elementsCopyNonIdenticalWithoutEqualElements anyOne. self deny: anElement copy == anElement. res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePrintTest self nonEmpty! ! !ArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButFirstNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. self assert: abf size + 2 = col size! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfter | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfter: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := firstCollection size. firstCollection reverseWith: secondCollection do: [:a :b | self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b. ( index := index - 1).] ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyFromTo | result index collection | collection := self collectionWithoutEqualElements . index :=self indexInForCollectionWithoutDuplicates . result := collection copyFrom: index to: collection size . "verify content of 'result' : " 1 to: result size do: [:i | self assert: (result at:i)=(collection at: (i + index - 1))]. "verify size of 'result' : " self assert: result size = (collection size - index + 1).! ! !ArrayTest methodsFor: 'tests - arithmetic' stamp: 'stephane.ducasse 10/6/2008 16:53'! testPremultiply self assert: example1 +* #(2 ) = #(2 4 6 8 10 ) ! ! !ArrayTest methodsFor: 'tests - includes' stamp: ''! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !ArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !ArrayTest methodsFor: 'requirements' stamp: 'SebastianTleye 6/26/2013 11:15'! collectionOfCollectionsOfInts ^collectionOfCollectionsOfInts.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! elementNotInForElementAccessing " return an element not included in 'accessCollection' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'tests - as set tests' stamp: ''! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !ArrayTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiterLast | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ].! ! !ArrayTest methodsFor: 'tests - converting' stamp: ''! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !ArrayTest methodsFor: 'tests - enumerating' stamp: ''! testFlatCollectAsSet self assert: (self simpleCollection flatCollectAsSet: [ :x | { x }, { x } ]) equals: self simpleCollection asSet! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyAfterLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the last occurence of element :" result := collection copyAfterLast: (element ). "verifying content: " self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWith "self debug: #testCopyWith" | res anElement | anElement := self elementToAdd. res := self empty copyWith: anElement. self assert: res size = (self empty size + 1). self assert: (res includes: (anElement value))! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 15:59'! indexInForCollectionWithoutDuplicates ^ 2.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! howMany: aSubCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp := collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: aSubCollection) ifTrue: [ nTime := nTime + 1. 1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureConverAsSortedTest self collectionWithSortableElements. self deny: self collectionWithSortableElements isEmpty! ! !ArrayTest methodsFor: 'tests - printing' stamp: ''! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !ArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOfStartingAtIfAbsent "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'requirements' stamp: 'SebastianTleye 6/26/2013 11:00'! collectionOfCollectionsOfStrings ^ collectionOfCollectionsOfStrings.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 15:53'! integerCollection ^example1 .! ! !ArrayTest methodsFor: 'tests - replacing' stamp: ''! testReplaceAllWith | result collection oldElement newElement oldOccurrences | collection := self nonEmpty . result := collection copy. oldElement := self elementInForReplacement . newElement := self newElement . oldOccurrences := (result occurrencesOf: oldElement) + (result occurrencesOf: newElement). result replaceAll: oldElement with: newElement . self assert: oldOccurrences = (result occurrencesOf: newElement)! ! !ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !ArrayTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''! testOccurrencesOfForMultipliness | collection elem | collection := self collectionWithEqualElements . elem := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: elem ) = 2. ! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtAll "self debug: #testAtAll" " self flag: #theCollectionshouldbe102030intheFixture. self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." | result | result := self moreThan4Elements atAll: #(2 1 2 ). self assert: (result at: 1) = (self moreThan4Elements at: 2). self assert: (result at: 2) = (self moreThan4Elements at: 1). self assert: (result at: 3) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! !ArrayTest methodsFor: 'tests - converting' stamp: ''! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !ArrayTest methodsFor: 'tests - copying same contents' stamp: ''! testShallowCopy | result | result := self nonEmpty shallowCopy . "verify content of 'result: '" 1 to: self nonEmpty size do: [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | collection | collection := self collectionMoreThan1NoDuplicates. self assert: (collection indexOf: collection first ifAbsent: [ 33 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing ifAbsent: [ 33 ]) = 33! ! !ArrayTest methodsFor: 'tests - streaming' stamp: ''! testStreamContentsSized | result | result:= self collectionClass new: 1 streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection. result:= self collectionClass new: 1000 streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyPartOfSequenceableTest self collectionWithoutEqualElements. self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ]. self indexInForCollectionWithoutDuplicates. self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size. self empty. self assert: self empty isEmpty! ! !ArrayTest methodsFor: 'test - creation' stamp: ''! testWithWithWith "self debug: #testWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'tests - converting' stamp: ''! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !ArrayTest methodsFor: 'tests - converting' stamp: ''! testAsByteArray | res | self integerCollectionWithoutEqualElements. self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ]. res := true. self integerCollectionWithoutEqualElements detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! !ArrayTest methodsFor: 'tests - converting' stamp: ''! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyWithOrWithoutSpecificElementsTest self nonEmpty. self deny: self nonEmpty isEmpty. self indexInNonEmpty. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/7/2009 11:18'! elementNotInForIndexAccessing ^elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! firstCollection ^example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 11:11'! collectionInForIncluding ^ self nonEmpty copyWithoutFirst.! ! !ArrayTest methodsFor: 'parameters' stamp: ''! accessValuePutIn "return access the element put in the non-empty collection" ^ self perform: self selectorToAccessValuePutIn! ! !ArrayTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/9/2008 18:49'! valuePutIn "the value that we will put in the non empty collection" ^ 2! ! !ArrayTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !ArrayTest methodsFor: 'tests - sorting' stamp: ''! testSortUsingSortBlock | result tmp | result := self unsortedCollection sort: [:a :b | a>b]. tmp := result at: 1. result do: [:each | self assert: each<=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collectionWithoutEqualElements difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res size equals: self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (res includes: each)]. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res equals: separateCol! ! !ArrayTest methodsFor: 'testing' stamp: 'StephaneDucasse 1/16/2010 10:07'! testLiteralEqual self deny: (example1 literalEqual: example1 asIntegerArray)! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureEmptySequenceableTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !ArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOfSubCollectionStartingAtIfAbsent "self debug: #testIndexOfIfAbsent" | index absent subcollection collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ]. self assert: absent = false. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ]. self assert: absent = true! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:11'! withEqualElements " return a collection of float including equal elements (classic equality)" ^ collectionOfFloatWithEqualElements! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpToLast: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1).! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/10/2009 14:49'! elementInForIndexAccess ^ elementInForCopy ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCloneTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !ArrayTest methodsFor: 'tests - printing' stamp: ''! testPrintOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. ].! ! !ArrayTest methodsFor: 'tests - at put' stamp: ''! testAtPutTwoValues "self debug: #testAtPutTwoValues" self nonEmpty at: self anIndex put: self aValue. self nonEmpty at: self anIndex put: self anotherValue. self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! !ArrayTest methodsFor: 'tests - find binary' stamp: 'SvenVanCaekenberghe 3/8/2012 14:10'! testFindBinaryIfNone self assert: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 11 - arg ] ifNone: [ #none ]) = 11. self should: (#(1 3 5 7 11 15 23) findBinary: [ :arg | 8 - arg ] ifNone: [ #none ]) = #none! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpTo | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpTo: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1). ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! collectionWithElementsToRemove ^ removedCollection! ! !ArrayTest methodsFor: 'tests - copying same contents' stamp: ''! testReversed | result | result := self nonEmpty reversed . "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString | delim := ', '. last := 'and'. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ]. ! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testLast "self debug: #testLast" self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'luc.fabresse 11/29/2008 23:10'! expectedSizeAfterReject ^1! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 8/31/2013 20:23'! test0FixtureIncludeTest | anElementIn | self nonEmpty. self deny: self nonEmpty isEmpty. self elementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self anotherElementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self collection. self empty. self assert: self empty isEmpty. self collectionOfFloat. self collectionOfFloat do: [ :each | self assert: each class = Float ]. self elementInForIncludesTest. anElementIn := true. self nonEmpty detect: [ :each | each = self elementInForIncludesTest ] ifNone: [ anElementIn := false ]. self assert: anElementIn = true! ! !ArrayTest methodsFor: 'tests - includes' stamp: 'CamilloBruni 8/31/2013 20:23'! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection element | self collectionWithCopyNonIdentical. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIndexAccessFotMultipliness self collectionWithSameAtEndAndBegining. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [ :i | i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! !ArrayTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotIn). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotIn)! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! replacementCollection ^replacementCollection .! ! !ArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithoutIndex | result index | index := self indexInNonEmpty . result := self nonEmpty copyWithoutIndex: index . "verify content of 'result:'" 1 to: result size do: [:i | i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. "verify size of result : " self assert: result size=(self nonEmpty size -1).! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 11:15'! collectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals . (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testLastIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 55 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 55 ]) = 1! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:28'! integerCollectionWithoutEqualElements ^{1. 2. 6. 5.}! ! !ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtWrapPut "self debug: #testAtWrapPut" | index | index := self indexArray anyOne. self nonEmpty atWrap: 0 put: self aValue. self assert: (self nonEmpty at:(self nonEmpty size))=self aValue. self nonEmpty atWrap: (self nonEmpty size+1) put: self aValue. self assert: (self nonEmpty at:(1))=self aValue. self nonEmpty atWrap: (index ) put: self aValue. self assert: (self nonEmpty at: index ) = self aValue. self nonEmpty atWrap: (self nonEmpty size+index ) put: self aValue . self assert: (self nonEmpty at:(index ))=self aValue .! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseDo | result | result:= OrderedCollection new. self nonEmpty reverseDo: [: each | result add: each]. 1 to: result size do: [:i| self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! !ArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyEquals "self debug: #testCopySameClass" "A copy should be equivalent to the things it's a copy of" | copy | copy := self nonEmpty copy. self assert: copy = self nonEmpty.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:54'! elementInForOccurrences ^ elementInForCopy ! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIndexOfDuplicate "self debug: #testIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf: should return the position of the first occurrence :'" self assert: (collection indexOf: element) = 1! ! !ArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtPin "self debug: #testAtPin" self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! !ArrayTest methodsFor: 'tests - sequence isempty' stamp: ''! testSequenceIfNotEmpty self assert: (self nonEmpty ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! ! !ArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:46'! elementsCopyNonIdenticalWithoutEqualElements " return a collection that does niot include equal elements ( classic equality )" ^ collectionOfCollection! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtLastIfAbsent "self debug: #testAtLastIfAbsent" self assert: (self moreThan4Elements atLast: 1 ifAbsent: [ nil ]) = self moreThan4Elements last. self assert: (self moreThan4Elements atLast: self moreThan4Elements size + 1 ifAbsent: [ 222 ]) = 222! ! !ArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButLastNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButLast: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i) ]. self assert: abf size + 2 = col size! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfterLast: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAfterIfAbsent "self debug: #testAfterIfAbsent" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1) ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ifAbsent: [ 33 ]) = 33. self assert: (self moreThan4Elements after: self elementNotInForElementAccessing ifAbsent: [ 33 ]) = 33! ! !ArrayTest methodsFor: 'tests - converting' stamp: ''! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureOccurrencesForMultiplinessTest | cpt anElement collection | self collectionWithEqualElements. self collectionWithEqualElements. self elementTwiceInForOccurrences. anElement := self elementTwiceInForOccurrences. collection := self collectionWithEqualElements. cpt := 0. " testing with identity check ( == ) so that identy collections can use this trait : " self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. self assert: cpt = 2! ! !ArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testForceToPaddingWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). "verify content of 'result' : " 1 to: self nonEmpty size do: [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. (result size - 1) to: result size do: [:i | self assert: ( result at:i ) = ( element ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! nonEmpty ^ example1! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindLast | element result | element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. self assert: result=self nonEmptyMoreThan1Element size. ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCreationWithTest self collectionMoreThan5Elements. self assert: self collectionMoreThan5Elements size >= 5! ! !ArrayTest methodsFor: 'test - equality' stamp: ''! testEqualSignIsTrueForEmptyButNonIdenticalCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). ! ! !ArrayTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyNonEmpty "self debug: #testCopyNonEmpty" | copy | copy := self nonEmpty copy. self deny: copy isEmpty. self assert: copy size = self nonEmpty size. self nonEmpty do: [:each | copy includes: each]! ! !ArrayTest methodsFor: 'tests - at put' stamp: ''! testAtPut "self debug: #testAtPut" self nonEmpty at: self anIndex put: self aValue. self assert: (self nonEmpty at: self anIndex) = self aValue. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !ArrayTest methodsFor: 'test - creation' stamp: ''! testWithWith "self debug: #testWithWith" | aCol collection element1 element2 | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . element1 := collection at: 1. element2 := collection at:2. aCol := self collectionClass with: element1 with: element2 . self assert: (aCol occurrencesOf: element1 ) = ( collection occurrencesOf: element1). self assert: (aCol occurrencesOf: element2 ) = ( collection occurrencesOf: element2). ! ! !ArrayTest methodsFor: 'requirements' stamp: ''! collectionWithIdentical "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" | result collection anElement | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. anElement := collection first. collection add: anElement. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testFirstSecondThird "self debug: #testFirstSecondThird" self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! !ArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testForceToPaddingStartWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). "verify content of 'result' : " 1 to: 2 do: [:i | self assert: ( element ) = ( result at:(i) ) ]. 3 to: result size do: [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !ArrayTest methodsFor: 'requirements' stamp: 'damienpollet 1/13/2009 16:59'! sizeCollection ^ self collection! ! !ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:58'! collectionWithCharacters ^ withCharacters.! ! !ArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithFirst | index element result | index:= self indexInNonEmpty . element:= self nonEmpty at: index. result := self nonEmpty copyWithFirst: element. self assert: result size = (self nonEmpty size + 1). self assert: result first = element . 2 to: result size do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:12'! aValue ^ 33! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! empty ^ empty! ! !ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:12'! testIsArray self assert: example1 isArray! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtLast "self debug: #testAtLast" | index | self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. "tmp:=1. self do: [:each | each =self elementInForIndexAccessing ifTrue:[index:=tmp]. tmp:=tmp+1]." index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 16:00'! indexArray ^ indexArray .! ! !ArrayTest methodsFor: 'initialization' stamp: 'cyrille.delaunay 12/18/2009 12:59'! collection ^ collectionWith4Elements ! ! !ArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtLastPut | result index | index := self indexArray anyOne. result := self nonEmpty atLast: index put: self aValue. self assert: (self nonEmpty at: (self nonEmpty size +1 - index)) = self aValue .! ! !ArrayTest methodsFor: 'tests - sorting' stamp: ''! testSort | result tmp | result := self unsortedCollection sort. tmp := result at: 1. result do: [:each | self assert: each>=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:05'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne.! ! !ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !ArrayTest methodsFor: 'tests - sorting' stamp: ''! testIsSorted self assert: self sortedInAscendingOrderCollection isSorted. self deny: self unsortedCollection isSorted! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !ArrayTest methodsFor: 'tests - converting' stamp: 'cyrille.delaunay 3/26/2009 12:35'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIdentityIndexOfIAbsentDuplicate "self debug: #testIdentityIndexOfIfAbsent" | collection element elementCopy | collection := self collectionWithNonIdentitySameAtEndAndBegining . element := collection last. elementCopy := element copy. self deny: element == elementCopy . self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = collection size. self assert: (collection identityIndexOf: elementCopy ifAbsent: [ 55 ]) = 55! ! !ArrayTest methodsFor: 'tests - equality' stamp: ''! testEqualSignForSequenceableCollections "self debug: #testEqualSign" self deny: (self nonEmpty = self nonEmpty asSet). self deny: (self nonEmpty reversed = self nonEmpty). self deny: (self nonEmpty = self nonEmpty reversed).! ! !ArrayTest methodsFor: 'tests - streaming' stamp: ''! testStreamContents | result index | result:= self collectionClass streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !ArrayTest methodsFor: 'tests - occurrencesOf' stamp: 'delaunay 4/2/2009 11:53'! testOccurrencesOfNotIn | result | result := self empty occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureBeginsEndsWithTest self nonEmpty. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size > 1. self empty. self assert: self empty isEmpty! ! !ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtIfAbsent "self debug: #testAt" | absent | absent := false. self moreThan4Elements at: self moreThan4Elements size + 1 ifAbsent: [ absent := true ]. self assert: absent = true. absent := false. self moreThan4Elements at: self moreThan4Elements size ifAbsent: [ absent := true ]. self assert: absent = false! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/30/2009 10:51'! collectionNotIncluded ^ collectionNotIncluded.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! elementNotInForOccurrences ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'test - equality' stamp: ''! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !ArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOf "self debug: #testIndexOf" | tmp index collection | collection := self collectionMoreThan1NoDuplicates. tmp := collection size. collection reverseDo: [ :each | each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. tmp := tmp - 1 ]. self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSubcollectionAccessTest self moreThan3Elements. self assert: self moreThan3Elements size > 2! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:05'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:18'! elementInForIndexAccessing ^ withoutEqualElements anyOne! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 14:08'! smallerIndex ^ firstIndex -1! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSequencedElementAccessTest self moreThan4Elements. self assert: self moreThan4Elements size >= 4. self subCollectionNotIn. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self elementNotInForElementAccessing. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self elementInForElementAccessing. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" | difference | self assert: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements) isEmpty. self assert: (self empty difference: self collectionWithoutEqualElements) isEmpty. difference := (self collectionWithoutEqualElements difference: self empty). self assert: difference size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each)]. ! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:19'! anotherValue ^ 66! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testLastIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element ifAbsent: [ 55 ]) = collection size! ! !ArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButFirst "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst. self deny: abf first = col first. self assert: abf size + 1 = col size! ! !ArrayTest methodsFor: 'tests - as set tests' stamp: ''! testAsIdentitySetWithEqualsElements | result collection | collection := self withEqualElements . result := collection asIdentitySet. collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = IdentitySet.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testAllButLastDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyPartOfForMultipliness self collectionWithSameAtEndAndBegining. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [ :i | i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testPairsCollect | index result | index:=0. result:=self nonEmptyMoreThan1Element pairsCollect: [:each1 :each2 | self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). ]. result do: [:each | self assert: each = true]. ! ! !ArrayTest methodsFor: 'tests - copying same contents' stamp: ''! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !ArrayTest methodsFor: 'parameters' stamp: ''! accessValuePutInOn: s "return access the element put in the non-empty collection" ^ s perform: self selectorToAccessValuePutIn! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/3/2009 11:35'! subCollectionNotIn ^subCollectionNotIn ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithIndexDo "| result | result:=Array new: self nonEmptyMoreThan1Element size. self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element withIndexDo: [:value :i | indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !ArrayTest methodsFor: 'tests - copying same contents' stamp: ''! testReverse | result | result := self nonEmpty reversed. "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at: i) = (self nonEmpty at: (self nonEmpty size - i + 1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !ArrayTest methodsFor: 'test - creation' stamp: ''! testWithWithWithWith "self debug: #testWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testBeforeIfAbsent "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 1) ifAbsent: [ 99 ]) = 99. self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2) ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! !ArrayTest methodsFor: 'tests - as identity set' stamp: ''! testAsIdentitySetWithoutIdentityEqualsElements | result collection | collection := self collectionWithCopy. result := collection asIdentitySet. " no elements should have been removed as no elements are equels with Identity equality" self assert: result size = collection size. collection do: [ :each | (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. self assert: result class = IdentitySet! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePutOneOrMoreElementsTest self aValue. self indexArray. self indexArray do: [ :each| self assert: each class = SmallInteger. self assert: (each>=1 & each<= self nonEmpty size). ]. self assert: self indexArray size = self valueArray size. self empty. self assert: self empty isEmpty . self nonEmpty. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'stephane.ducasse 10/6/2008 17:39'! speciesClass ^ Array! ! !ArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringOne "self assert: self oneItemCol asCommaString = '1'. self assert: self oneItemCol asCommaStringAnd = '1'." self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopySameContentsTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFromToDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 1 to: (self nonEmptyMoreThan1Element size -1) do: [:i| self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 14:00'! floatCollectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingAnEnd ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:32'! replacementCollectionSameSize ^replacementCollectionSameSize ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! elementNotIn "return an element not included in 'nonEmpty' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'initialization' stamp: 'SebastianTleye 6/28/2013 14:46'! setUp literalArray := #(1 true 3 #four). selfEvaluatingArray := { 1. true. (3/4). Color black. (2 to: 4) . 5 }. nonSEArray1 := { 1 . Set with: 1 }. nonSEarray2 := { Smalltalk globals associationAt: #Array }. example1 := #(1 2 3 4 5) copy. indexArray:= {2. 3. 4.}. valueArray:={0. 0. 0.}. oldSubCollection:= {2. 3. 4.}. nonEmptyMoreThan1Element:= example1. subCollectionNotIn:= {1. 8. 3.}. collectionNotIncluded:= {7. 8. 9.}. removedCollection:= { 2. 4. }. example2 := {1. 2. 3/4. 4. 5}. collectionWith4Elements := #(1 -2 3 1). collectionWithoutNil := #( 1 2 3 4). simpleCollection := #( 1 8 3). collectionOfCollectionsOfInts := { 1. { 2. 3 }. { 4. { 5. 6} } }. collectionOfCollectionsOfStrings:= {{{'foo'}. {'bar'}}. 'zorg'}. collectResult := {SmallInteger. SmallInteger. SmallInteger. SmallInteger.}. empty := #(). duplicateElement := 5.2. withEqualElements := {1.5. duplicateElement . 6.1. 2.0. duplicateElement .} . withoutEqualElements := {1.1. 4.4. 6.5. 2.4. 3.1.}. withCharacters := {$a. $x. $d. $c. $m.}. unsortedCollection := {1. 2. 8. 5. 6. 7.}. sortedInAscendingOrderCollection := {1. 2. 3. 4. 5. 6.}. elementInForCopy:= 2. elementNotInForCopy:= 9. firstIndex:= 2. secondIndex:= 4. replacementCollection:= {4. 3. 2. 1.}. replacementCollectionSameSize := {5. 4. 3.}. nonEmpty1Element:={ 5.}. collectionOfCollection:={1.5. 5.5. 6.5.}. collectionOfFloatWithEqualElements:={1.5. 5.5. 6.5. 1.5}. floatCollectionWithSameBeginingAnEnd := {1.5. 5.5. 1.5 copy}. collection5Elements := { 1. 2. 5. 3. 4.}.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:16'! elementInForReplacement ^ elementInForCopy ! ! !ArrayTest methodsFor: 'test - creation' stamp: ''! testWithWithWithWithWith "self debug: #testWithWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:53'! moreThan3Elements " return a collection including atLeast 3 elements" ^ example1 ! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 15:20'! nonEmptyMoreThan1Element ^nonEmptyMoreThan1Element .! ! !ArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAt "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! !ArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent: should return the position of the first occurrence :'" self assert: (collection indexOf: element ifAbsent: [ 55 ]) = 1! ! !ArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterOne | delim oneItemStream result | "delim := ', '. oneItemStream := '' readWrite. self oneItemCol asStringOn: oneItemStream delimiter: delim. self assert: oneItemStream contents = '1'." delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !ArrayTest methodsFor: 'tests - at put' stamp: ''! testAtPutOutOfBounds "self debug: #testAtPutOutOfBounds" self should: [self empty at: self anIndex put: self aValue] raise: Error ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:55'! elementInForIncludesTest ^ elementInForCopy ! ! !ArrayTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element ifAbsent: [ 99 ]) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection last. self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 99 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 99 ]) = 99. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing startingAt: collection size ifAbsent: [ 99 ]) = 99! ! !ArrayTest methodsFor: 'tests - copying with replacement' stamp: ''! firstIndexesOf: aSubCollection in: collection " return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " | tmp result currentIndex | tmp:= collection. result:= OrderedCollection new. currentIndex := 1. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: aSubCollection) ifTrue: [ result add: currentIndex. 1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !ArrayedCollection commentStamp: ''! I am an abstract collection of elements with a fixed range of integers (from 1 to n>=0) as external keys.! !ArrayedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:36'! size "Answer how many elements the receiver contains." ^ self basicSize! ! !ArrayedCollection methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' new: '. aStream store: self size. aStream nextPut: $). (self storeElementsFrom: 1 to: self size on: aStream) ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'jb 4/30/2010 17:26'! writeOn: aStream "Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed). Always store in Big Endian (Mac) byte order. Do the writing at BitBlt speeds. We only intend this for non-pointer arrays. Do nothing if I contain pointers." (self class isPointers or: [ self class isWords not ]) ifTrue: [^ self ]. aStream nextInt32Put: self basicSize. aStream nextWordsPutAll: self.! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:22'! byteSize ^self basicSize * self bytesPerBasicElement ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'CamilloBruni 11/2/2012 14:26'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Reverse the byte order if the current machine is Little Endian. We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^self]. Smalltalk isLittleEndian ifTrue: [Bitmap swapBytesIn: self from: 1 to: self basicSize]! ! !ArrayedCollection methodsFor: 'private' stamp: 'ul 11/21/2009 01:15'! fillFrom: aCollection with: aBlock "Evaluate aBlock with each of aCollections's elements as the argument. Collect the resulting values into self. Answer self." | index | index := 0. aCollection do: [ :each | self at: (index := index + 1) put: (aBlock value: each) ]! ! !ArrayedCollection methodsFor: 'private' stamp: ''! defaultElement ^nil! ! !ArrayedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 14:09'! add: newObject self shouldNotImplement! ! !ArrayedCollection methodsFor: 'private' stamp: ''! storeElementsFrom: firstIndex to: lastIndex on: aStream | noneYet defaultElement arrayElement | noneYet := true. defaultElement := self defaultElement. firstIndex to: lastIndex do: [:index | arrayElement := self at: index. arrayElement = defaultElement ifFalse: [noneYet ifTrue: [noneYet := false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' at: '. aStream store: index. aStream nextPutAll: ' put: '. aStream store: arrayElement]]. ^noneYet! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:28'! bytesPerBasicElement "Answer the number of bytes that each of my basic elements requires. In other words: self basicSize * self bytesPerBasicElement should equal the space required on disk by my variable sized representation." ^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'CamilloBruni 11/2/2012 14:26'! swapHalves "A normal switch in endianness (byte order in words) reverses the order of 4 bytes. That is not correct for SoundBuffers, which use 2-bytes units. If a normal switch has be done, this method corrects it further by swapping the two halves of the long word. This method is only used for 16-bit quanities in SoundBuffer, ShortIntegerArray, etc." | hack blt | "The implementation is a hack, but fast for large ranges" hack := Form new hackBits: self. blt := (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: 0; destY: 0; height: self size; width: 2. blt sourceX: 0; destX: 2; copyBits. "Exchange bytes 0&1 with 2&3" blt sourceX: 2; destX: 0; copyBits. blt sourceX: 0; destX: 2; copyBits. ! ! !ArrayedCollection methodsFor: '*NativeBoost-Core' stamp: 'Igor.Stasenko 5/2/2010 20:32'! hexDump "Utility method, for inspecting the native code" ^ String streamContents: [:str | self do: [:each | str nextPutAll: (each printStringBase: 16) ] separatedBy: [ str space ] ]! ! !ArrayedCollection methodsFor: '*Compression' stamp: 'tk 3/7/2001 18:07'! writeOnGZIPByteStream: aStream "We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^ super writeOnGZIPByteStream: aStream]. "super may cause an error, but will not be called." aStream nextPutAllWordArray: self! ! !ArrayedCollection methodsFor: 'removing' stamp: 'klub 9/14/2009 16:27'! removeAll self shouldNotImplement! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'sw 10/24/1998 22:22'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject "Answer a new instance of me, containing only the 6 arguments as elements." | newCollection | newCollection := self new: 6. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. newCollection at: 5 put: fifthObject. newCollection at: 6 put: sixthObject. ^ newCollection! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: ''! with: firstObject with: secondObject with: thirdObject with: fourthObject "Answer a new instance of me, containing only the three arguments as elements." | newCollection | newCollection := self new: 4. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: ''! with: firstObject with: secondObject with: thirdObject "Answer a new instance of me, containing only the three arguments as elements." | newCollection | newCollection := self new: 3. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: ''! new "Answer a new instance of me, with size = 0." ^self new: 0! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: ''! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." | newArray | newArray := self new: aCollection size. 1 to: aCollection size do: [:i | newArray at: i put: (aCollection at: i)]. ^ newArray " Array newFrom: {1. 2. 3} {1. 2. 3} as: Array {1. 2. 3} as: ByteArray {$c. $h. $r} as: String {$c. $h. $r} as: Text "! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: ''! new: size withAll: value "Answer an instance of me, with number of elements equal to size, each of which refers to the argument, value." ^(self new: size) atAllPut: value! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: ''! with: anObject "Answer a new instance of me, containing only anObject." | newCollection | newCollection := self new: 1. newCollection at: 1 put: anObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 10/30/2011 15:53'! newFromStream: s "Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk." | len | (self isPointers not & self isWords) ifFalse: [ self error: 'This method is only meant for raw bits and word-like subclasses ']. s next = 16r80 ifTrue: ["A compressed format. Could copy what BitMap does, or use a special sound compression format. Callers normally compress their own way." ^ self error: 'not implemented']. s skip: -1. len := s nextInt32. ^ s nextWordsInto: (self basicNew: len)! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:37'! withAll: aCollection "Create a new collection containing all the elements from aCollection." ^ (self new: aCollection size) replaceFrom: 1 to: aCollection size with: aCollection! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: ''! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject "Answer a new instance of me, containing only the five arguments as elements." | newCollection | newCollection := self new: 5. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. newCollection at: 5 put: fifthObject. ^newCollection! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: ''! with: firstObject with: secondObject "Answer a new instance of me, containing firstObject and secondObject." | newCollection | newCollection := self new: 2. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. ^newCollection! ! !AssertionFailure commentStamp: 'gh 5/2/2002 20:29'! AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.! !AssignmentNode commentStamp: ''! AssignmentNode comment: 'I represent a (var_expr) construct.'! !AssignmentNode methodsFor: 'initialize-release' stamp: 'di 3/22/1999 12:00'! variable: aVariable value: expression from: encoder (aVariable isMemberOf: MessageAsTempNode) ifTrue: ["Case of remote temp vars" ^ aVariable store: expression from: encoder]. variable := aVariable. value := expression! ! !AssignmentNode methodsFor: 'initialize-release' stamp: 'hmm 7/15/2001 21:17'! variable: aVariable value: expression from: encoder sourceRange: range encoder noteSourceRange: range forNode: self. ^self variable: aVariable value: expression from: encoder! ! !AssignmentNode methodsFor: 'initialize-release' stamp: ''! toDoIncrement: var var = variable ifFalse: [^ nil]. (value isMemberOf: MessageNode) ifTrue: [^ value toDoIncrement: var] ifFalse: [^ nil]! ! !AssignmentNode methodsFor: 'code generation (closures)' stamp: 'eem 5/30/2008 09:37'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" "N.B. since assigment happens _after_ the value is evaluated the value is sent the message _first_." value analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools. variable beingAssignedToAnalyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools! ! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:27'! emitCodeForEffect: stack encoder: encoder variable emitCodeForLoad: stack encoder: encoder. value emitCodeForValue: stack encoder: encoder. pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". variable emitCodeForStorePop: stack encoder: encoder! ! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 15:16'! sizeCodeForValue: encoder ^(variable sizeCodeForLoad: encoder) + (value sizeCodeForValue: encoder) + (variable sizeCodeForStore: encoder)! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 5/9/2008 18:44'! printOn: aStream indent: level precedence: p aStream nextPut: $(. self printOn: aStream indent: level. aStream nextPut: $)! ! !AssignmentNode methodsFor: 'initialize-release' stamp: ''! value ^ value! ! !AssignmentNode methodsFor: 'equation translation' stamp: ''! variable ^variable! ! !AssignmentNode methodsFor: 'initialize-release' stamp: ''! variable: aVariable value: expression variable := aVariable. value := expression! ! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 6/4/2008 11:27'! emitCodeForValue: stack encoder: encoder variable emitCodeForLoad: stack encoder: encoder. value emitCodeForValue: stack encoder: encoder. pc := encoder methodStreamPosition + 1. "debug pc is first byte of the store, i.e. the next byte". variable emitCodeForStore: stack encoder: encoder! ! !AssignmentNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:33'! accept: aVisitor ^aVisitor visitAssignmentNode: self! ! !AssignmentNode methodsFor: 'testing' stamp: 'eem 6/16/2008 09:37'! isAssignmentNode ^true! ! !AssignmentNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 15:16'! sizeCodeForEffect: encoder ^(variable sizeCodeForLoad: encoder) + (value sizeCodeForValue: encoder) + (variable sizeCodeForStorePop: encoder)! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 5/6/2008 13:48'! printOn: aStream indent: level variable printOn: aStream indent: level. aStream nextPutAll: ' := '. value printOn: aStream indent: level + 2! ! !Association commentStamp: 'StephaneDucasse 2/13/2010 15:13'! I represent a pair of associated objects--a key and a value. My instances can serve as entries in a dictionary. Implementation notes: Note that hash is not redefined even if the = was redefined because Association>>hash may cause extreme slowdowns in compiling Unicode methods. Association>>hash does not need to hash the value; it's slow and useless. ! !Association methodsFor: 'testing' stamp: 'MaxLeske 1/25/2014 22:13'! analogousCodeTo: anAssociation ^ self = anAssociation! ! !Association methodsFor: '*System-Settings-Browser' stamp: 'alain.plantec 3/24/2009 23:20'! settingFixedDomainValueNodeFrom: aSettingNode ^ aSettingNode fixedDomainValueNodeForAssociation: self! ! !Association methodsFor: 'accessing' stamp: ''! value "Answer the value of the receiver." ^value! ! !Association methodsFor: 'accessing' stamp: ''! value: anObject "Store the argument, anObject, as the value of the receiver." value := anObject! ! !Association methodsFor: 'printing' stamp: ''! storeOn: aStream "Store in the format (key->value)" aStream nextPut: $(. key storeOn: aStream. aStream nextPutAll: '->'. value storeOn: aStream. aStream nextPut: $)! ! !Association methodsFor: 'printing' stamp: ''! printOn: aStream super printOn: aStream. aStream nextPutAll: '->'. value printOn: aStream! ! !Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:27'! = anAssociation ^ super = anAssociation and: [value = anAssociation value]! ! !Association methodsFor: 'testing' stamp: 'nice 7/20/2011 09:00'! literalEqual: otherLiteral "Answer true if the receiver and otherLiteral represent the same literal. Variable bindings are literally equals only if identical. This is how variable sharing works, by preserving identity and changing only the value." ^self == otherLiteral! ! !Association methodsFor: '*Morphic-Base' stamp: 'BenjaminVanRyseghem 10/11/2013 15:17'! head ^ (key isKindOf: Association) ifTrue: [ key head ] ifFalse: [ key ]! ! !Association methodsFor: '*Morphic-Base' stamp: 'BenjaminVanRyseghem 10/11/2013 15:20'! tail ^ (key isKindOf: Association) ifTrue: [ key tail -> value ] ifFalse: [ value ]! ! !Association methodsFor: 'self evaluating' stamp: 'nice 10/30/2009 20:24'! isSelfEvaluating ^ self class == Association and: [self key isSelfEvaluating and: [self value isSelfEvaluating]]! ! !Association methodsFor: 'accessing' stamp: ''! key: aKey value: anObject "Store the arguments as the variables of the receiver." key := aKey. value := anObject! ! !Association class methodsFor: 'instance creation' stamp: ''! key: newKey value: newValue "Answer an instance of me with the arguments as the key and value of the association." ^(super key: newKey) value: newValue! ! !AssociationTest commentStamp: 'TorstenBergmann 2/20/2014 15:19'! SUnit tests for Associations! !AssociationTest methodsFor: 'tests' stamp: 'al 10/13/2008 20:32'! testHash self assert: (a hash = a copy hash); assert: (a hash = b hash)! ! !AssociationTest methodsFor: 'tests' stamp: 'md 3/8/2004 16:37'! testEquality self assert: (a key = b key); deny: (a value = b value); deny: (a = b) ! ! !AssociationTest methodsFor: 'tests' stamp: 'ab 12/29/2008 07:59'! testComparison self assert: ((#a -> 'foo') < (#b -> 'zork'))! ! !AssociationTest methodsFor: 'setup' stamp: 'zz 12/5/2005 18:33'! setUp a := 1 -> 'one'. b := 1 -> 'een'.! ! !AssociationTest methodsFor: 'tests' stamp: 'MarcusDenker 5/2/2013 11:24'! testIsSelfEvaluating | anotherAssociation | self assert: (a isSelfEvaluating). self assert: (a printString = '1->''one'''). anotherAssociation := Object new -> Object new. anotherAssociation isSelfEvaluating ifTrue: [self assert: (self class compiler evaluate: anotherAssociation printString) = anotherAssociation description: 'a self evaluating should evaluate as self']. ! ! !AsyncFile commentStamp: 'HenrikSperreJohansen 2/16/2012 11:40'! An asynchronous file allows simple file read and write operations to be performed in parallel with other processing. This is useful in multimedia applications that need to stream large amounts of sound or image data from or to a file while doing other work. Closing the file after its use is currently required to not leak external semaphores. ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'nice 4/16/2009 10:02'! writeBuffer: buffer atFilePosition: fPosition onCompletionDo: aBlock "Start an operation to write the contents of the buffer at given position in this file, and fork a process to await its completion. When the write completes, evaluate the given block. Note that, since the completion block runs asynchronously, the client may need to use a SharedQueue or a semaphore for synchronization." self primWriteStart: fileHandle fPosition: fPosition fromBuffer: buffer at: 1 count: buffer size. "here's the process that awaits the results:" [| n | [ semaphore wait. n := self primWriteResult: fileHandle. n = Busy. ] whileTrue. "loop while busy in case the semaphore had excess signals" n = ErrorCode ifTrue: [^ self error: 'asynchronous write operation failed']. n = buffer size ifFalse: [^ self error: 'did not write the entire buffer']. aBlock value. ] forkAt: Processor userInterruptPriority. ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primOpen: fileName forWrite: openForWrite semaIndex: semaIndex "Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise." ^ nil ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'! fileHandle ^ fileHandle! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'! waitForCompletion semaphore wait! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:31'! close fileHandle ifNil: [^ self]. "already closed" self primClose: fileHandle. Smalltalk unregisterExternalObject: semaphore. semaphore := nil. fileHandle := nil. ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primReadStart: fHandle fPosition: fPosition count: count "Start a read operation of count bytes starting at the given offset in the given file." self error: 'READ THE COMMENT FOR THIS METHOD.' "NOTE: This method will fail if there is insufficient C heap to allocate an internal buffer of the required size (the value of count). If you are trying to read a movie file, then the buffer size will be height*width*2 bytes. Each Squeak image retains a value to be used for this allocation, and it it initially set to 0. If you are wish to play a 640x480 movie, you need room for a buffer of 640*480*2 = 614400 bytes. You should execute the following... Smalltalk extraVMMemory 2555000. Then save-and-quit, restart, and try to open the movie file again. If you are using Async files in another way, find out the value of count when this failure occurs (call it NNNN), and instead of the above, execute... Smalltalk extraVMMemory: Smalltalk extraVMMemory + NNNN then save-and-quit, restart, and try again. " ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primClose: fHandle "Close this file. Do nothing if primitive fails." ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 5/4/2012 21:16'! test: byteCount fileName: fileName "AsyncFile new test: 10000 fileName: 'testData'" | buf1 buf2 bytesWritten bytesRead | buf1 := String new: byteCount withAll: $x. buf2 := String new: byteCount. self open: fileName asFileReference fullName forWrite: true. self primWriteStart: fileHandle fPosition: 0 fromBuffer: buf1 at: 1 count: byteCount. semaphore wait. bytesWritten := self primWriteResult: fileHandle. self close. self open: fileName asFileReference fullName forWrite: false. self primReadStart: fileHandle fPosition: 0 count: byteCount. semaphore wait. bytesRead := self primReadResult: fileHandle intoBuffer: buf2 at: 1 count: byteCount. self close. buf1 = buf2 ifFalse: [self error: 'buffers do not match']. ^ 'wrote ', bytesWritten printString, ' bytes; ', 'read ', bytesRead printString, ' bytes' ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primWriteResult: fHandle "Answer the number of bytes written. A negative result means: -1 the last operation is still in progress -2 the last operation encountered an error" self primitiveFailed ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primWriteStart: fHandle fPosition: fPosition fromBuffer: buffer at: startIndex count: count "Start a write operation of count bytes starting at the given index in the given buffer. The buffer may be any sort of bytes or words object, excluding CompiledMethods. The contents of the buffer are copied into an internal buffer immediately, so the buffer can be reused after the write operation has been started. Fail if there is insufficient C heap to allocate an internal buffer of the requested size." writeable ifFalse: [^ self error: 'attempt to write a file opened read-only']. self primitiveFailed ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'nice 4/16/2009 10:02'! readByteCount: byteCount fromFilePosition: fPosition onCompletionDo: aBlock "Start a read operation to read byteCount's from the given position in this file. and fork a process to await its completion. When the operation completes, evaluate the given block. Note that, since the completion block may run asynchronous, the client may need to use a SharedQueue or a semaphore for synchronization." | buffer | buffer := String new: byteCount. self primReadStart: fileHandle fPosition: fPosition count: byteCount. "here's the process that awaits the results:" [| n | [ semaphore wait. n := self primReadResult: fileHandle intoBuffer: buffer at: 1 count: byteCount. n = Busy. ] whileTrue. "loop while busy in case the semaphore had excess signals" n = ErrorCode ifTrue: [^ self error: 'asynchronous read operation failed']. aBlock value: buffer. ] forkAt: Processor userInterruptPriority. ! ! !AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primReadResult: fHandle intoBuffer: buffer at: startIndex count: count "Copy the result of the last read operation into the given buffer starting at the given index. The buffer may be any sort of bytes or words object, excluding CompiledMethods. Answer the number of bytes read. A negative result means: -1 the last operation is still in progress -2 the last operation encountered an error" self primitiveFailed ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'ar 6/3/2007 22:13'! open: fullFileName forWrite: aBoolean "Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise. If openForWrite is true, then: if there is no existing file with this name, then create one else open the existing file in read-write mode otherwise: if there is an existing file with this name, then open it read-only else answer nil." "Note: if an exisiting file is opened for writing, it is NOT truncated. If truncation is desired, the file should be deleted before being opened as an asynchronous file." "Note: On some platforms (e.g., Mac), a file can only have one writer at a time." | semaIndex | name := fullFileName. writeable := aBoolean. semaphore := Semaphore new. semaIndex := Smalltalk registerExternalObject: semaphore. fileHandle := self primOpen: name asVmPathName forWrite: writeable semaIndex: semaIndex. fileHandle ifNil: [ Smalltalk unregisterExternalObject: semaphore. semaphore := nil. ^ nil]. ! ! !AsyncFile class methodsFor: 'initialization' stamp: 'bootstrap 5/31/2006 20:45'! initialize "AsyncFile initialize" "Possible abnormal I/O completion results." Busy := -1. ErrorCode := -2. ! ! !AthensAbstractPaint commentStamp: 'FernandoOlivero 3/9/2012 14:03'! I am an abstract paint, which should be converted before it can be used by Athens. I am backend agnostic, as opposed to concrete paint(s). Also, any other object can play the role of paint, as long as it implements the conversion method, #asAthensPaintOn: See other implementors of #asAthensPaintOn:, such as Color and Form.! !AthensAbstractPaint methodsFor: 'converting' stamp: 'IgorStasenko 9/3/2013 14:23'! asAthensPaintOn: aCanvas ^ self! ! !AthensAbstractShape commentStamp: ''! In Athens, any object can play role of a shape. I demonstrating the minimal protocol which should be supported by "shape" role, to be used with Athens canvas. See my methods comments for more details. ! !AthensAbstractShape methodsFor: 'converting' stamp: 'IgorStasenko 5/6/2013 05:40'! asAthensShapeOn: canvas "Note: The answered object of this message should conform with AthensShape protocol. " self subclassResponsibility.! ! !AthensAffineTransform commentStamp: ''! I support the same protocol than AthensTransform, but in addition I store a plain 2x3 matrix with state accessible at any moment. This is different to AthensTransform because it does not expose its internal storage, because it can be backend specific.! !AthensAffineTransform methodsFor: 'accessing' stamp: ''! translation ^ x@y! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 10/20/2011 18:48'! x ^ x! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 4/24/2012 14:04'! shy: number shy := number! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 10/21/2011 12:55'! clearTranslation "reset a translation from matrix, leaving only scale and rotation" x := y := 0.0! ! !AthensAffineTransform methodsFor: 'vector-transform' stamp: 'IgorStasenko 4/18/2013 15:53'! inverseTransform: aPoint | px py y0 x0 | px := aPoint x. py := aPoint y. " (we assume matrix is never degenerate) Given straight transformation formulae: px := x0*sx + y0*shx + x. py := x0*shy + y0*sy + y. we doing inverse one, trying to find x0,y0 for rest of given variables (px,py,x,y,sx,sy,shx,shy). x0 := px - x - (shx*y0) / sx. y0 := py - y - (shy*x0) / sy. y0 := py - y - (shy*(px - x - (shx*y0) / sx)) / sy. sy * y0 == py - y - (shy*(px - x - (shx*y0) / sx)). sx * sy * y0 == (sx*(py - y)) - (shy*(px - x - (shx*y0))). sx * sy * y0 == sx*py - (sx*y) - (shy*px) + (shy*x) + (shy*shx*y0). (sx * sy * y0) - (shy*shx*y0) == sx*py - (sx*y) - (shy*px) + (shy*x) . y0* ((sx * sy) - (shy*shx)) == sx*py - (sx*y) - (shy*px) + (shy*x) . " y0 := sx*py - (sx*y) - (shy*px) + (shy*x) / ((sx * sy) - (shy*shx)). x0 := px - x - (shx*y0) / sx. ^ x0@y0 ! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 10/20/2011 18:48'! y ^ y! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/26/2011 01:46'! rotateByDegrees: angle ^ self rotateByRadians: angle degreesToRadians! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 10/20/2011 18:48'! sx ^ sx! ! !AthensAffineTransform methodsFor: 'initialize-release' stamp: 'IgorStasenko 3/26/2011 02:09'! initialize self loadIdentity! ! !AthensAffineTransform methodsFor: 'accessing' stamp: ''! scale ^ sx@sy! ! !AthensAffineTransform methodsFor: 'accessing' stamp: ''! translation: aPoint x := aPoint x. y := aPoint y.! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 4/24/2012 14:04'! sx: number sx := number! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/7/2012 14:02'! loadAffineTransform: m x := m x. y := m y. sx := m sx. sy := m sy. shx := m shx. shy := m shy.! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 4/24/2012 14:47'! multiplyBy: m "multiply receiver by given affine matrix" " | sx shx x | | sx' shx' x' | | shy sy y | * | shy' sy' y' | | 0 0 1 | | 0 0 1 | " | nsx nshx nx nshy nsy ny | nsx := sx * m sx + (shx * m shy). nshx := sx * m shx + (shx * m sy). nx := sx * m x + (shx * m y) + x. nshy := shy * m sx + (sy * m shy). nsy := shy * m shx + (sy * m sy). ny := shy* m x + (sy * m y) + y. sx := nsx. sy := nsy. shx := nshx. shy := nshy. x := nx. y := ny. ! ! !AthensAffineTransform methodsFor: 'vector-transform' stamp: 'IgorStasenko 3/26/2011 03:02'! transform: aPoint | px py | px := aPoint x. py := aPoint y. ^ Point x: (sx*px +(shx*py) + x) y: (shy*px + (sy*py) + y) ! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 10/24/2011 17:24'! translateX: px y: py " multiply receiver by translation matrix : | sx shx x | | 1 0 px | | sx shx (sx*px + shx*py + x) | | shy sy y | * | 0 1 py | ===> | shy sy (shy*px + sy*py + y) | | 0 0 1 | | 0 0 1 | | 0 0 1 | " x := (sx*px) + (shx*py) + x. y := (shy*px) + (sy*py) + y. ! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 4/24/2012 14:04'! sy: number sy := number! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 10/20/2011 18:48'! sy ^ sy! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/7/2012 14:01'! restoreAfter: aBlock |previous| previous := self copy. aBlock ensure: [ self loadAffineTransform: previous ]! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 10/25/2011 13:20'! transposed | s | s := shx. shx := shy. shy := s.! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/26/2011 03:17'! translateBy: aPoint ^ self translateX: aPoint x Y: aPoint y! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'JochenRick 1/24/2014 10:37'! inverted "answer an inverse transformation of receiver" | det | det := sx * sy - (shx * shy). ^ self class new sx: sy / det; sy: shy * -1 / det; shx: shx * -1 / det; shy: sx / det; x: shx * y - (x * sy) / det; y: shy * x - (sx * y) / det; yourself! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 4/24/2012 14:04'! y: number y := number! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 10/20/2011 18:48'! shx ^ shx! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/26/2011 01:52'! scaleX: fx Y: fy "multiply receiver by scale matrix | sx shx x | | fx 0 0 | | sx*fx shx*fx x | | shy sy y | * | 0 fy 0 | ===> | shy*fy sy*fy y | | 0 0 1 | | 0 0 1 | | 0 0 1 | " sx := sx*fx. shx := shx*fx. sy := sy*fy. shy := shy*fy. ! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 4/24/2012 14:03'! x: number x := number! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/21/2012 18:26'! scaleBy: factor "multiply receiver by uniform scale matrix | sx shx x | | (f x) 0 0 | | sx*(f x) shx*(f y) x | | shy sy y | * | 0 (f y) 0 | ===> | shy*(f x) sy*(f y) y | | 0 0 1 | | 0 0 1 | | 0 0 1 | " factor isPoint ifTrue: [ sx := sx*factor x. shx := shx*factor y. sy := sy*factor y. shy := shy*factor x. ] ifFalse: [ sx := sx*factor. shx := shx*factor. sy := sy*factor. shy := shy*factor. ] ! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/21/2012 18:23'! translateX: px Y: py " multiply receiver by translation matrix : | sx shx x | | 1 0 px | | sx shx (sx*px + shx*py + x) | | shy sy y | * | 0 1 py | ===> | shy sy (shy*px + sy*py + y) | | 0 0 1 | | 0 0 1 | | 0 0 1 | " x := (sx*px) + (shx*py) + x. y := (shy*px) + (sy*py) + y. ! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/26/2011 03:21'! rotateByRadians: angle "multiply receiver by rotation matrix | sx shx x | | cos -sin 0 | | (sx*cos)+(shx*sin) (-sx*sin+shx*cos) x | | shy sy y | * | sin cos 0 | ===> | (shy*cos)+(sy*sin) (-shy*sin)+sy*cos) y | | 0 0 1 | | 0 0 1 | | 0 0 1 | " | cos sin newSx newSy | cos := angle cos. sin := angle sin. newSx := sx*cos + (shx*sin). newSy := sy*cos - (shy*sin). shx := shx*cos - (sx*sin). shy := shy*cos + (sy*sin). sx := newSx. sy := newSy.! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 4/24/2012 14:04'! shx: number shx := number! ! !AthensAffineTransform methodsFor: 'accessing' stamp: 'IgorStasenko 10/20/2011 18:48'! shy ^ shy! ! !AthensAffineTransform methodsFor: 'vector-transform' stamp: 'IgorStasenko 3/27/2011 18:40'! transformX: px Y: py " transform x and y coordinates by receiver. Answer a Point" ^ Point x: (sx*px +(shx*py) + x) y: (shy*px + (sy*py) + y) ! ! !AthensAffineTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/26/2011 02:09'! loadIdentity "initialize with identity transform" sx := sy := 1.0. shx := shy := x := y := 0.0. ! ! !AthensArcSegment commentStamp: 'IgorStasenko 3/7/2012 13:41'! i am abstract class , representing an arc segment! !AthensArcSegment methodsFor: 'accessors' stamp: 'IgorStasenko 3/7/2012 13:44'! angle ^ angle! ! !AthensArcSegment methodsFor: 'accessors' stamp: 'IgorStasenko 3/7/2012 13:30'! endPoint: pt angle: a endPoint := pt. angle := a! ! !AthensArcSegment methodsFor: 'accessors' stamp: 'IgorStasenko 3/7/2012 13:31'! endPoint ^ endPoint! ! !AthensBackgroundChange commentStamp: 'IgorStasenko 2/6/2012 16:16'! Text display command for changing the background color! !AthensBackgroundChange methodsFor: 'initialize-release' stamp: 'IgorStasenko 10/28/2011 14:45'! initialize width :=0. color := Color transparent.! ! !AthensBackgroundChange methodsFor: 'accessing' stamp: 'IgorStasenko 10/28/2011 14:33'! width: anObject width := anObject! ! !AthensBackgroundChange methodsFor: 'accessing' stamp: 'IgorStasenko 10/28/2011 14:33'! width ^ width! ! !AthensBackgroundChange methodsFor: 'accessing' stamp: 'IgorStasenko 11/7/2011 13:41'! start ^ start! ! !AthensBackgroundChange methodsFor: 'accessing' stamp: 'IgorStasenko 10/28/2011 14:33'! color ^ color! ! !AthensBackgroundChange methodsFor: 'rendering' stamp: 'IgorStasenko 11/7/2011 13:42'! renderOn: renderer color isTransparent ifFalse: [ renderer renderBackground: self ]! ! !AthensBackgroundChange methodsFor: 'accessing' stamp: 'IgorStasenko 11/7/2011 13:41'! start: aStart start := aStart! ! !AthensBackgroundChange methodsFor: 'adding' stamp: 'IgorStasenko 10/28/2011 14:44'! addWidth: aWidth width := width + aWidth! ! !AthensBackgroundChange methodsFor: 'accessing' stamp: 'IgorStasenko 10/28/2011 14:33'! color: anObject color := anObject! ! !AthensBalloonEngine commentStamp: 'IgorStasenko 3/29/2011 01:04'! - balloon engine using only first 4 variables of receiver instance: - work buffer - span - bitBlt (Bitblt object) - forms ! !AthensBalloonEngine methodsFor: 'paints' stamp: 'IgorStasenko 4/1/2011 16:01'! registerLinearGradient: colorRamp origin: origin corner: corner | pixelRamp direction normal | pixelRamp := GradientFillStyle pixelRampCache at: colorRamp. direction := corner - origin. normal := direction y negated @ direction x. currentFill := self primAddGradientFill: pixelRamp from: origin along: direction normal: normal radial: false.! ! !AthensBalloonEngine methodsFor: 'drawing' stamp: 'IgorStasenko 4/21/2011 16:20'! copyBits (bitBlt notNil and:[bitBlt destForm notNil]) ifTrue:[bitBlt destForm unhibernate]. self copyLoopFastest.! ! !AthensBalloonEngine methodsFor: 'registering fills' stamp: 'IgorStasenko 4/22/2011 18:52'! registerFormFill: form origin: orig direction: dir normal: norm forms := forms copyWith: form. form unhibernate. currentFill := self primAddBitmapFill: form colormap: (form colormapIfNeededForDepth: 32) tile: true "shall we always tile? " from: orig along: dir normal: norm xIndex: forms size. ! ! !AthensBalloonEngine methodsFor: 'paints' stamp: 'IgorStasenko 4/14/2011 16:26'! registerRadialGradient: colorRamp center: aCenter radius: r | pixelRamp | pixelRamp := GradientFillStyle pixelRampCache at: colorRamp. currentFill := self primAddGradientFill: pixelRamp from: aCenter along: (aCenter x + r @ aCenter y) normal: (aCenter x @ aCenter y - r) radial: true.! ! !AthensBalloonEngine methodsFor: 'initialize' stamp: 'IgorStasenko 4/22/2011 14:00'! reset workBuffer ifNil:[workBuffer := self class allocateOrRecycleBuffer: 10000]. self primInitializeBuffer: workBuffer. self primSetAALevel: 4. self primSetOffset: 0@0. self primSetClipRect: clipRect. self primSetEdgeTransform: edgeTransform. self primSetColorTransform: colorTransform. forms := #().! ! !AthensBalloonEngine methodsFor: 'drawing' stamp: 'IgorStasenko 5/2/2011 04:36'! strokeRectangle: rect borderWidth: width currentFill = 0 ifTrue: [ ^ self ]. "no fill " self primAddRectFrom: rect origin to: rect corner fillIndex: 0 borderWidth: width borderColor: currentFill. self copyBits. ! ! !AthensBalloonEngine methodsFor: 'drawing' stamp: 'IgorStasenko 4/22/2011 13:56'! drawImage: aForm transform: m | orig dir normal tr corner rect | rect := aForm boundingBox. orig := 0@0. dir := aForm width @ 0. normal := 0 @ aForm height. tr := edgeTransform. edgeTransform := m. self prepareForRendering. self registerFormFill: aForm origin: orig direction: dir normal: normal. self fillRectangle: rect. edgeTransform := tr. ! ! !AthensBalloonEngine methodsFor: 'drawing' stamp: 'IgorStasenko 9/19/2011 15:38'! strokeRectangle: rect width: aWidth currentFill = 0 ifTrue: [ ^ self ]. "no fill " self primAddRectFrom: rect origin to: rect corner fillIndex: 0 borderWidth: aWidth asInteger borderColor: currentFill. self copyBits. ! ! !AthensBalloonEngine methodsFor: 'paints' stamp: 'IgorStasenko 4/14/2011 17:15'! registerRadialGradient: colorRamp center: aCenter direction: dir normal: n | pixelRamp | pixelRamp := GradientFillStyle pixelRampCache at: colorRamp. currentFill := self primAddGradientFill: pixelRamp from: aCenter along: dir normal: n radial: true.! ! !AthensBalloonEngine methodsFor: 'accessing' stamp: 'IgorStasenko 4/1/2011 09:03'! setFill: aFill currentFill := aFill! ! !AthensBalloonEngine methodsFor: 'private' stamp: 'IgorStasenko 9/19/2011 16:37'! fastReset workBuffer ifNil: [ ^ self reset ]. workBuffer at: (1+GWState) put: GEStateUnlocked; at: (1+GWObjUsed) put: 4; at: (1+GWNeedsFlush) put: 0; at: (1+GWCurrentZ) put: 0; at: (1+GWGETStart) put: 0"; at: (1+GWGETUsed) put: 0; at: (1+GWAETStart) put: 0; at: (1+GWAETUsed) put: 0". self primSetEdgeTransform: edgeTransform. self primSetClipRect: clipRect. self primSetColorTransform: colorTransform. self primSetDepth: self primGetDepth + 1. postFlushNeeded := false. forms := #(). " - self magicNumberPut: GWMagicNumber. - self wbSizePut: size. + self wbTopPut: size. + self statePut: GEStateUnlocked. - self objStartPut: GWHeaderSize. + self objUsedPut: 4. - self objectTypeOf: 0 put: GEPrimitiveFill. - self objectLengthOf: 0 put: 4. - self objectIndexOf: 0 put: 0. self getStartPut: 0. self getUsedPut: 0. self aetStartPut: 0. self aetUsedPut: 0. self stopReasonPut: 0. + self needsFlushPut: 0. - self clipMinXPut: 0. - self clipMaxXPut: 0. - self clipMinYPut: 0. - self clipMaxYPut: 0. + self currentZPut: 0. self resetGraphicsEngineStats. self initEdgeTransform. self initColorTransform. "! ! !AthensBalloonEngine methodsFor: 'private' stamp: 'IgorStasenko 4/13/2011 12:15'! prepareForRendering self fastReset! ! !AthensBalloonEngine methodsFor: 'drawing' stamp: 'IgorStasenko 4/21/2011 15:04'! fillRectangle: rect currentFill = 0 ifTrue: [ ^ self ]. "no fill " self primAddRectFrom: rect origin to: rect corner fillIndex: currentFill borderWidth: 0 borderColor: 0. self copyBits. ! ! !AthensBalloonEngine methodsFor: 'private' stamp: 'IgorStasenko 9/14/2011 15:12'! strokeBezierShape: contours width: aWidth contours do:[ :points | self primAddBezierShape: points segments: (points size // 3) fill: 0 lineWidth: aWidth lineFill: currentFill. "Note: To avoid premature flushing of the pipeline we need to reset the flush bit within the engine." self primFlushNeeded: false. ]. self copyBits. ! ! !AthensBalloonEngine methodsFor: 'drawing' stamp: 'IgorStasenko 4/1/2011 09:26'! fillBezierShape: contours contours do:[ :points | self primAddBezierShape: points segments: (points size // 3) fill: currentFill lineWidth: 0 lineFill: 0. "Note: To avoid premature flushing of the pipeline we need to reset the flush bit within the engine." self primFlushNeeded: false. ]. self copyBits.! ! !AthensBalloonEngine methodsFor: 'registering fills' stamp: 'IgorStasenko 4/1/2011 09:16'! registerColorFill: aColor currentFill := aColor scaledPixelValue32. ! ! !AthensBalloonGradientPaint commentStamp: ''! my subclasses used internally in balloon backend for Athens to represenet gradient paints.! !AthensBalloonGradientPaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/14/2011 16:27'! colorRamp ^ colorRamp! ! !AthensBalloonGradientPaint methodsFor: 'rendering' stamp: 'IgorStasenko 9/19/2011 15:34'! strokeRect: aRectangle on: anAthensCanvas stroke: anAthensBalloonStrokePaint self shouldBeImplemented.! ! !AthensBalloonGradientPaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/14/2011 16:27'! colorRamp: anObject colorRamp := anObject! ! !AthensBalloonImagePaint commentStamp: ''! i representing an image (form) paint ! !AthensBalloonImagePaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/21/2011 15:30'! form ^ form! ! !AthensBalloonImagePaint methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2013 16:32'! athensFillPath: aPath on: anAthensCanvas anAthensCanvas surface engine prepareForRendering; registerFormFill: form origin: origin direction: direction normal: self normal; fillBezierShape: aPath contoursForFilling! ! !AthensBalloonImagePaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/21/2011 15:45'! direction ^ direction! ! !AthensBalloonImagePaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/21/2011 15:45'! direction: anObject direction := anObject! ! !AthensBalloonImagePaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/21/2011 15:45'! origin ^ origin! ! !AthensBalloonImagePaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/21/2011 15:47'! normal ^ ((direction y negated @ direction x) * form height / form width ) rounded! ! !AthensBalloonImagePaint methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2013 16:35'! athensFillRectangle: aRect on: anAthensCanvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " anAthensCanvas surface engine reset prepareForRendering; registerFormFill: form origin: origin direction: direction normal: self normal; fillRectangle: aRect ! ! !AthensBalloonImagePaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/21/2011 15:49'! form: anObject form := anObject. origin := 0@0. direction := form extent x @0.! ! !AthensBalloonImagePaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/21/2011 15:45'! origin: anObject origin := anObject! ! !AthensBalloonLinearGradient commentStamp: ''! i represent a linear gradient paint in balloon backend.! !AthensBalloonLinearGradient methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2013 16:32'! athensFillPath: aPath on: anAthensCanvas | torigin tcorner | "A gradient fill coordinates are first transformed by paintTransform matrix, then by pathTransform matrix" torigin := anAthensCanvas paintTransform transform: origin. tcorner := anAthensCanvas paintTransform transform: corner. ^ anAthensCanvas surface engine prepareForRendering; registerLinearGradient: colorRamp origin: torigin corner: tcorner; fillBezierShape: aPath contoursForFilling! ! !AthensBalloonLinearGradient methodsFor: 'accessing' stamp: 'IgorStasenko 4/1/2011 10:47'! corner ^ corner! ! !AthensBalloonLinearGradient methodsFor: 'accessing' stamp: 'IgorStasenko 4/1/2011 10:47'! origin ^ origin! ! !AthensBalloonLinearGradient methodsFor: 'accessing' stamp: 'IgorStasenko 4/1/2011 10:47'! corner: anObject corner := anObject! ! !AthensBalloonLinearGradient methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2013 16:35'! athensFillRectangle: aRect on: anAthensCanvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " | torigin tcorner | "A gradient fill coordinates are first transformed by paintTransform matrix, then by pathTransform matrix" torigin := anAthensCanvas paintTransform transform: origin. tcorner := anAthensCanvas paintTransform transform: corner. ^ anAthensCanvas surface engine prepareForRendering; registerLinearGradient: colorRamp origin: torigin corner: tcorner; fillRectangle: aRect! ! !AthensBalloonLinearGradient methodsFor: 'accessing' stamp: 'IgorStasenko 4/1/2011 10:47'! origin: anObject origin := anObject! ! !AthensBalloonLinearGradient methodsFor: 'rendering' stamp: 'IgorStasenko 3/8/2012 13:59'! strokeRect: rect on: canvas stroke: strokePaint | torigin tcorner | "A gradient fill coordinates are first transformed by paintTransform matrix, then by pathTransform matrix" torigin := canvas paintTransform transform: origin. tcorner := canvas paintTransform transform: corner. ^ canvas surface engine prepareForRendering; registerLinearGradient: colorRamp origin: torigin corner: tcorner; strokeRectangle: rect width: strokePaint width! ! !AthensBalloonPaint commentStamp: ''! i am an abstract root of many balloon-specific paints! !AthensBalloonPaint methodsFor: 'converting' stamp: 'IgorStasenko 4/27/2012 11:18'! asStrokePaintOn: aCanvas ^ AthensBalloonStrokePaint new fillPaint: self! ! !AthensBalloonPaint methodsFor: 'converting' stamp: 'IgorStasenko 3/21/2012 19:11'! asAthensPaintOn: surf ^ self ! ! !AthensBalloonPath commentStamp: ''! i represent a path shape in balloon backend! !AthensBalloonPath methodsFor: 'converting' stamp: 'IgorStasenko 9/14/2011 15:08'! contoursForStroke "answer a collection of contours, ready for stroking by balloon engine" ^ contours collect: [:contour | contour asArray ]! ! !AthensBalloonPath methodsFor: 'private' stamp: 'IgorStasenko 3/27/2011 17:40'! duplicateLastPoint contours last size < 2 ifFalse: [ "duplicate last contour point" contours last add: (contours last last). ]. ! ! !AthensBalloonPath methodsFor: 'converting' stamp: 'IgorStasenko 3/27/2011 17:40'! visitLineSegment: line self duplicateLastPoint. contours last add: line endPoint; add: line endPoint.! ! !AthensBalloonPath methodsFor: 'drawing' stamp: 'IgorStasenko 9/13/2011 16:21'! paintStrokeUsing: paint on: anAthensCanvas ^ paint strokePath: self on: anAthensCanvas ! ! !AthensBalloonPath methodsFor: 'accessing' stamp: 'IgorStasenko 3/27/2011 00:23'! contours ^ contours! ! !AthensBalloonPath methodsFor: 'converting' stamp: 'IgorStasenko 3/29/2011 14:53'! contoursForFilling "answer a collection of contours, ready for filling by balloon engine" ^ contours collect: [:contour | contour last = contour first ifTrue: [contour asArray] ifFalse: [ (contour , { contour last. contour last. contour first }) ] ]! ! !AthensBalloonPath methodsFor: 'converting' stamp: 'IgorStasenko 3/27/2011 00:05'! visitMoveSegment: seg contours ifNil: [ contours := OrderedCollection new ]. contours add: OrderedCollection new. contours last add: seg endPoint.! ! !AthensBalloonPath methodsFor: 'converting' stamp: 'IgorStasenko 3/29/2011 14:55'! convertFromBuilder: aBuilder | segment cContours | bounds := aBuilder pathBounds. segment := aBuilder pathStart. [ segment notNil ] whileTrue: [ segment visitWith: self. segment := segment next ]. " finally make all OrderedColllections ==> Array " cContours := Array new: contours size. 1 to: cContours size do: [:i | cContours at: i put: (contours at: i) asArray. ]. contours := cContours.! ! !AthensBalloonPath methodsFor: 'converting' stamp: 'IgorStasenko 3/27/2011 17:40'! visitQuadSegment: quadSegment self duplicateLastPoint. contours last add: quadSegment via; add: quadSegment to! ! !AthensBalloonPath methodsFor: 'drawing' stamp: 'IgorStasenko 8/30/2013 16:32'! paintFillsUsing: aPaint on: anAthensCanvas "This method is a part of rendering dispatch Canvas->receiver->paint" ^ aPaint athensFillPath: self on: anAthensCanvas! ! !AthensBalloonPath methodsFor: 'accessing' stamp: 'IgorStasenko 3/27/2011 13:54'! numContours ^ contours size! ! !AthensBalloonPath methodsFor: 'converting' stamp: 'IgorStasenko 3/27/2011 17:31'! visitCloseSegment: closeSegment "see if its alredy closed" contours last last = contours last first ifFalse: [ contours last add: (contours last last); add: closeSegment endPoint; add: closeSegment endPoint ]! ! !AthensBalloonRadialGradient commentStamp: ''! i represent a radial gradient paint in balloon backend.! !AthensBalloonRadialGradient methodsFor: 'accessing' stamp: 'IgorStasenko 4/14/2011 16:27'! radius: anObject radius := anObject! ! !AthensBalloonRadialGradient methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2013 16:32'! athensFillPath: aPath on: anAthensCanvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " | c | c := anAthensCanvas paintTransform transform: center. ^ anAthensCanvas surface engine prepareForRendering; registerRadialGradient: colorRamp center: c radius: radius; fillBezierShape: aPath contoursForFilling ! ! !AthensBalloonRadialGradient methodsFor: 'accessing' stamp: 'IgorStasenko 4/14/2011 16:27'! center: anObject center := anObject! ! !AthensBalloonRadialGradient methodsFor: 'accessing' stamp: 'IgorStasenko 4/14/2011 16:27'! radius ^ radius! ! !AthensBalloonRadialGradient methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2013 16:35'! athensFillRectangle: aRect on: anAthensCanvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " | c dir n | c := anAthensCanvas paintTransform transform: center. dir := (radius@0). n := (0@radius). ^ anAthensCanvas surface engine prepareForRendering; registerRadialGradient: colorRamp center: c direction: dir normal: n; fillRectangle: aRect! ! !AthensBalloonRadialGradient methodsFor: 'accessing' stamp: 'IgorStasenko 4/14/2011 16:27'! center ^ center! ! !AthensBalloonSolidColorPaint commentStamp: 'IgorStasenko 12/20/2011 15:27'! maybe Color could act as a AthensPaint by itself by implementing a corresponding protocol! !AthensBalloonSolidColorPaint methodsFor: 'rendering' stamp: 'IgorStasenko 9/14/2011 15:10'! strokePath: aPath on: anAthensCanvas stroke: strokePaint anAthensCanvas surface strokeBezierShape: aPath contoursForStroke color: color width: strokePaint width. ! ! !AthensBalloonSolidColorPaint methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2013 16:32'! athensFillPath: athensBalloonPath on: anAthensCanvas ^ anAthensCanvas surface fillBezierShape: athensBalloonPath contoursForFilling color: color. ! ! !AthensBalloonSolidColorPaint methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2013 16:35'! athensFillRectangle: aRect on: canvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " ^ canvas surface fillRectangle: aRect color: color! ! !AthensBalloonSolidColorPaint methodsFor: 'accessing' stamp: 'IgorStasenko 3/22/2011 21:59'! color: anObject color := anObject! ! !AthensBalloonSolidColorPaint methodsFor: 'rendering' stamp: 'IgorStasenko 9/14/2011 15:17'! strokeRect: rect on: canvas stroke: strokePaint ^ canvas surface strokeRectangle: rect color: color width: strokePaint width! ! !AthensBalloonSolidColorPaint methodsFor: 'accessing' stamp: 'IgorStasenko 3/22/2011 21:59'! color ^ color! ! !AthensBalloonStrokePaint commentStamp: ''! i represent stroke paint for balloon backend! !AthensBalloonStrokePaint methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2013 16:35'! athensFillRectangle: aRect on: aCanvas ^ fillPaint strokeRect: aRect on: aCanvas stroke: self! ! !AthensBalloonStrokePaint methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2013 16:32'! athensFillPath: aPath on: aCanvas ^ fillPaint strokePath: aPath on: aCanvas stroke: self! ! !AthensBalloonSurface commentStamp: ''! I am concrete implementation of Athens surface which using balloon engine for rendering. ! !AthensBalloonSurface methodsFor: 'accessing matrices' stamp: 'IgorStasenko 3/26/2011 02:12'! pathTransform ^ pathTransform! ! !AthensBalloonSurface methodsFor: 'drawing' stamp: 'IgorStasenko 4/1/2011 09:24'! fillRectangle: rect color: aColor engine prepareForRendering; registerColorFill: aColor ; fillRectangle: rect ! ! !AthensBalloonSurface methodsFor: 'converting' stamp: 'sig 2/29/2012 21:52'! asForm ^ form! ! !AthensBalloonSurface methodsFor: 'paints' stamp: 'IgorStasenko 4/14/2011 17:12'! createCircularGradient: colorRamp center: aCenter radius: aRadius ^ AthensBalloonRadialGradient new colorRamp: colorRamp; center: aCenter; radius: aRadius; yourself! ! !AthensBalloonSurface methodsFor: 'accessing matrices' stamp: 'IgorStasenko 10/17/2011 13:52'! pathTransform: anObject pathTransform := anObject copy. engine edgeTransform: pathTransform.! ! !AthensBalloonSurface methodsFor: 'initialize-release' stamp: 'IgorStasenko 3/21/2012 19:12'! initialize pathTransform := AthensAffineTransform new. paintTransform := AthensAffineTransform new. imageTransform := AthensAffineTransform new " AthensGenericTransform new". fillTransform := AthensAffineTransform new. strokeTransform := AthensAffineTransform new. maskEnabled := false.! ! !AthensBalloonSurface methodsFor: 'paints' stamp: 'IgorStasenko 4/12/2013 10:00'! createLinearGradient: colorRamp start: pt1 stop: pt2 ^ AthensBalloonLinearGradient new colorRamp: colorRamp; start: pt1; stop: pt2; yourself! ! !AthensBalloonSurface methodsFor: 'accessing' stamp: 'IgorStasenko 11/21/2011 16:33'! clipRect ^ engine clipRect! ! !AthensBalloonSurface methodsFor: 'paints' stamp: 'IgorStasenko 4/27/2012 11:22'! createStrokePaintFor: aPaint ^ AthensBalloonStrokePaint new fillPaint: aPaint! ! !AthensBalloonSurface methodsFor: 'accessing matrices' stamp: 'IgorStasenko 3/26/2011 02:12'! strokeTransform ^ strokeTransform! ! !AthensBalloonSurface methodsFor: 'masking' stamp: 'IgorStasenko 3/27/2011 18:16'! enableMask maskEnabled := true! ! !AthensBalloonSurface methodsFor: 'drawing' stamp: 'IgorStasenko 9/14/2011 15:24'! strokeRectangle: rect color: aColor width: aWidth engine prepareForRendering; registerColorFill: aColor ; strokeRectangle: rect width: aWidth! ! !AthensBalloonSurface methodsFor: 'paths' stamp: 'IgorStasenko 4/18/2013 04:46'! createPath: aPathCreatingBlock "Create a path from provided path builder instance" | builder | builder := AthensSimplePathBuilder new. aPathCreatingBlock value: builder. ^ AthensBalloonPath new convertFromBuilder: builder. ! ! !AthensBalloonSurface methodsFor: 'drawing' stamp: 'IgorStasenko 9/14/2011 15:08'! fillBezierShape: anArray color: aColor width: aSmallInteger self shouldBeImplemented.! ! !AthensBalloonSurface methodsFor: 'masking' stamp: 'IgorStasenko 3/27/2011 18:16'! disableMask maskEnabled := false.! ! !AthensBalloonSurface methodsFor: 'testing' stamp: 'IgorStasenko 4/1/2011 09:36'! clearForm form bits: ( Bitmap new: form bits size). ! ! !AthensBalloonSurface methodsFor: 'drawing' stamp: 'IgorStasenko 4/1/2011 09:25'! fillBezierShape: contours color: aColor engine prepareForRendering; registerColorFill: aColor ; fillBezierShape: contours! ! !AthensBalloonSurface methodsFor: 'drawing' stamp: 'sig 2/29/2012 21:49'! clear ^ self clearForm! ! !AthensBalloonSurface methodsFor: 'accessing matrices' stamp: 'IgorStasenko 3/26/2011 02:12'! fillTransform ^ fillTransform! ! !AthensBalloonSurface methodsFor: 'paints' stamp: 'IgorStasenko 3/8/2012 13:48'! createFormPaint: aForm ^ AthensBalloonImagePaint new form: aForm! ! !AthensBalloonSurface methodsFor: 'accessing' stamp: 'IgorStasenko 3/21/2011 15:10'! form ^ form! ! !AthensBalloonSurface methodsFor: 'drawing' stamp: 'IgorStasenko 4/21/2011 16:35'! drawImage: aForm engine drawImage: aForm transform: imageTransform! ! !AthensBalloonSurface methodsFor: 'masking' stamp: 'IgorStasenko 3/27/2011 18:17'! maskEnabled ^ maskEnabled! ! !AthensBalloonSurface methodsFor: 'accessing' stamp: 'IgorStasenko 4/21/2011 16:17'! form: aForm form := aForm. mask := Form extent: form extent depth: 1. engine := AthensBalloonEngine new. engine bitBlt: (GrafPort toForm: form) . engine clipRect: (0@0 extent: form extent). engine edgeTransform: pathTransform. engine destOffset: 0@0. engine reset.! ! !AthensBalloonSurface methodsFor: 'paints' stamp: 'IgorStasenko 3/22/2011 21:59'! createSolidColorPaint: aColor ^ AthensBalloonSolidColorPaint new color: aColor! ! !AthensBalloonSurface methodsFor: 'paints' stamp: 'IgorStasenko 11/30/2013 08:22'! createLinearGradient: colorRamp origin: pt1 corner: pt2 self deprecated: 'Use #createLinearGradient:start:stop: instead' on: '12 April 2013' in: 'ConfigurationOfAthens 2.0'. ^ self createLinearGradient: colorRamp origin: pt1 corner: pt2 ! ! !AthensBalloonSurface methodsFor: 'accessing matrices' stamp: 'IgorStasenko 3/26/2011 02:12'! imageTransform ^ imageTransform! ! !AthensBalloonSurface methodsFor: 'drawing' stamp: 'IgorStasenko 9/14/2011 15:12'! strokeBezierShape: contours color: aColor width: aWidth engine prepareForRendering; registerColorFill: aColor ; strokeBezierShape: contours width: aWidth! ! !AthensBalloonSurface methodsFor: 'accessing' stamp: 'IgorStasenko 3/21/2012 19:12'! paintTransform ^ paintTransform ! ! !AthensBalloonSurface methodsFor: 'accessing' stamp: 'IgorStasenko 3/27/2011 20:30'! engine ^ engine! ! !AthensBalloonSurface methodsFor: 'fonts' stamp: 'IgorStasenko 10/20/2011 10:03'! getFreetypeFontRendererFor: aFreeTypeFont ^ (FT2GlyphRenderer forFont: aFreeTypeFont surface: self)! ! !AthensBalloonSurface methodsFor: 'accessing matrices' stamp: 'IgorStasenko 3/26/2011 02:12'! fillTransform: anObject fillTransform := anObject! ! !AthensBalloonSurface methodsFor: 'accessing matrices' stamp: 'IgorStasenko 3/26/2011 02:12'! strokeTransform: anObject strokeTransform := anObject! ! !AthensBalloonSurface methodsFor: 'clipping' stamp: 'IgorStasenko 4/21/2011 14:55'! clipBy: aRectangle during: aBlock | oldRect | oldRect := engine clipRect. engine clipRect: (oldRect intersect: aRectangle). aBlock ensure: [ engine clipRect: oldRect ]! ! !AthensBalloonSurface class methodsFor: 'as yet unclassified' stamp: 'sig 2/29/2012 21:45'! extent: aPoint "Create a new surface with given extent." ^ self new form: (Form extent: aPoint depth: 32)! ! !AthensBalloonSurfaceExamples commentStamp: 'TorstenBergmann 2/12/2014 22:18'! Athens example using Ballon as surface ! !AthensBalloonSurfaceExamples class methodsFor: 'instance creation' stamp: 'sig 2/29/2012 21:37'! newSurface: extent ^ AthensBalloonSurface extent: extent! ! !AthensBezier3Scene commentStamp: ''! I just a helper class used to debug & visualize rendering of bezier segment. This class is subject of changes or complete removal! !AthensBezier3Scene methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/2/2013 18:25'! renderOn: canvas | path pathBlock polygonizedPath | canvas surface clear: Color black. pathBlock := [ :builder | builder absolute; moveTo: pt1; curveVia: pt2 and: pt3 to: pt4 ]. "First , we draw the curve using Cairo" (canvas setStrokePaint: Color green). canvas drawShape: (canvas createPath: pathBlock). "draw a polygon, connecting control points" (canvas setStrokePaint: Color blue) width: 0.5. canvas drawShape: (canvas createPath: [ :builder | builder absolute; moveTo: pt1; lineTo: pt2; lineTo: pt3; lineTo: pt4 ]). canvas setPaint: Color red. path := AthensSimplePathBuilder createPath: pathBlock. " polygonizedPath := path asPolygon: canvas pathTransform. " canvas drawShape: ( canvas createPath: [ :builder | | flattener | builder absolute. flattener := AthensCurveFlattener new dest: builder. flattener transform: (canvas pathTransform). flattener convert:path. ]).! ! !AthensBezier3Scene methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/29/2013 21:51'! curvePathBlock ^ [ :builder | builder absolute; moveTo: pt1; curveVia: pt2 and: pt3 to: pt4 ]. ! ! !AthensBezier3Scene methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/26/2013 17:54'! initFromArray: aControlPointsArray pt1 := aControlPointsArray at: 1. pt2 := aControlPointsArray at: 2. pt3 := aControlPointsArray at: 3. pt4 := aControlPointsArray at: 4. ! ! !AthensBezier3Scene class methodsFor: 'instance creation' stamp: 'IgorStasenko 4/26/2013 17:51'! on: anControlPointArray ^ self basicNew initFromArray: anControlPointArray! ! !AthensBezier3Scene class methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 4/26/2013 17:53'! openViewOn: aControlPointsArray ^ AthensSceneView new scene: (self on: aControlPointsArray ); openInWindow! ! !AthensBezierConverter commentStamp: 'IgorStasenko 5/1/2011 21:50'! I converting all bezier segments to a sequence of line segments, by approximating the curve along its path. This classs is used for generating strokes.! !AthensBezierConverter methodsFor: 'helpers' stamp: 'IgorStasenko 5/1/2011 21:45'! angleBetween: p1 and: p2 ifDegenerate: aBlock " Calculate an angle (in radians) between two vectors. Evaluate a block, in case if calculation not possible because one of the vectors has zero length " | x1 y1 x2 y2 dot2 n2 | x1 := p1 x. y1 := p1 y. x2 := p2 x. y2 := p2 y. dot2 := x1 * x2 + (y1 * y2). dot2 := dot2 * dot2. n2 := (x1*x1 + (y1*y1)) * (x2*x2 + (y2*y2)). n2 = 0 ifTrue: [ ^ aBlock value ]. ^ (dot2 / n2) arcCos! ! !AthensBezierConverter methodsFor: 'initialize-release' stamp: 'IgorStasenko 4/29/2011 18:11'! initialize distanceTolerance := 0.5. angleTolerance := 0.1 . ! ! !AthensBezierConverter methodsFor: 'testing' stamp: 'IgorStasenko 4/29/2011 18:09'! isFlatBezier2_x1: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3 | dx dy d da angle | dx := x3-x1. dy := y3-y1. d := (((x2 - x3) * dy) - ((y2 - y3) * dx)) abs. d > CollinearityEps ifTrue: [ "regular case" d*d <= (distanceTolerance * ( dx*dx + (dy*dy))) ifTrue: [ angleTolerance < CurveAngleTolerance ifTrue: [ ^ true ]. angle := self angleBetween: x2-x1 @ (y2-y1) and: x3-x2 @ (y3-y2) ifDegenerate: [ 0.0 ]. "parallel. no need to proceed further" angle <= angleTolerance ifTrue: [ ^ true ] ] ] ifFalse: [ "collinear" da := dx*dx + (dy*dy). da = 0 ifTrue: [ d := (x1-x2) squared + (y1-y2) squared ] ifFalse: [ d = ((x2 - x1)*dx + ((y2 - y1)*dy)) / da. (d > 0.0 and: [ d < 1.0 ] ) ifTrue: [ "Simple collinear case, 1---2---3" ^ true ]. d <= 0.0 ifTrue: [ d := (x1-x2) squared + (y1-y2) squared ] ifFalse: [ d >= 1.0 ifTrue: [ d:= (x2-x3) squared + (y2-y3) squared ] ifFalse: [ d:= (x2 - x1 - (d*dx)) squared + (y2 - y1 - (d*dy)) squared ] ]. ]. d < self distanceToleranceSquared ifTrue: [ ^ true ] ]. ^ false! ! !AthensBezierConverter methodsFor: 'converting path commands' stamp: 'IgorStasenko 5/1/2011 22:03'! curveVia: pt1 to: pt2 self recursiveBezier2_x1: endPoint x y1: endPoint y x2: pt1 x y2: pt1 y x3: pt2 x y3: pt2 y! ! !AthensBezierConverter methodsFor: 'helpers' stamp: 'IgorStasenko 5/1/2011 21:47'! recursiveBezier2_x1: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3 "recursively subdive bezier curve as long as #isFlatBezier2.. answers false " (self isFlatBezier2_x1: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3) ifTrue: [ dest lineTo: x2 @ y2; lineTo: x3 @ y3 ] ifFalse: [ | x12 y12 x23 y23 x123 y123 | "calculate midpoints of line segments " x12 := (x1 + x2) * 0.5. y12 := (y1 + y2) * 0.5 . x23 := (x2 + x3) * 0.5 . y23 := (y2 + y3) * 0.5 . x123 := (x12 + x23) * 0.5. y123 := (y12 + y23) * 0.5. self recursiveBezier2_x1: x1 y1: y1 x2: x12 y2: y12 x3: x123 y3: y123. self recursiveBezier2_x1: x123 y1: y123 x2: x23 y2: y23 x3: x3 y3: y3. ] ! ! !AthensBezierConverter class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/29/2011 18:10'! initialize CollinearityEps := 1e-30. DistanceEps := 1e-30. CurveAngleTolerance := 0.01.! ! !AthensCCWArcSegment commentStamp: ''! i represent a circular arc, connecting previous segment endpoint and my endpoing of given angle, passing in counter-clockwise direction.! !AthensCCWArcSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 04:39'! accept: aVisitor ^ aVisitor ccwArcSegment: self! ! !AthensCCWArcSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 05:21'! sendCommandTo: aBuilder ^ aBuilder ccwArcTo: endPoint angle: angle! ! !AthensCWArcSegment commentStamp: ''! i represent a circular arc, connecting previous segment endpoint and my endpoing of given angle, passing in clockwise direction.! !AthensCWArcSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 04:39'! accept: aVisitor ^ aVisitor cwArcSegment: self! ! !AthensCWArcSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 05:21'! sendCommandTo: aBuilder ^ aBuilder cwArcTo: endPoint angle: angle! ! !AthensCairoCanvas commentStamp: 'IgorStasenko 12/20/2011 15:58'! my instances representing a low-level cairo context and mapped to cairo_t * C type! !AthensCairoCanvas methodsFor: 'initialize-release' stamp: 'IgorStasenko 10/11/2012 18:45'! initializeWithSurface: anAthensSurface super initializeWithSurface: anAthensSurface. self paintMode default.! ! !AthensCairoCanvas methodsFor: 'path segments visitor' stamp: 'FernandoOlivero 2/14/2012 08:16'! visitCubicSegment: anAthensCubicSegment | destination controlPoint controlPoint2 | destination := anAthensCubicSegment to. controlPoint := anAthensCubicSegment via1. controlPoint2 := anAthensCubicSegment via2. self curveToX: destination x Y: destination y viaX: controlPoint x Y: controlPoint y andX: controlPoint2 x Y: controlPoint2 y ! ! !AthensCairoCanvas methodsFor: 'accessing' stamp: 'IgorStasenko 12/20/2011 16:48'! pathTransform ^ pathTransform! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 4/3/2013 06:23'! primSetLineWidth: width self nbCall: #(void cairo_set_line_width ( self, double width) ) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 12/20/2011 16:05'! rectangleX: x y: y width: aWidth height: aHeight ^ self nbCall: #(void cairo_rectangle (self, double x, double y, double aWidth, double aHeight) ) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 3/30/2012 17:59'! primGetSource self nbCall: #( cairo_pattern_t cairo_get_source ( self ) )! ! !AthensCairoCanvas methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 19:06'! surface: aCairoSurface "initialize for given surface" surface := aCairoSurface. pathTransform := AthensCairoMatrix new. paintTransform := AthensCairoMatrix new. paintMode := AthensCairoPaintMode new canvas: self. self setAA: CAIRO_ANTIALIAS_SUBPIXEL.! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 6/3/2012 04:02'! primPaint "A drawing operator that paints the current source everywhere within the current clip region." ^ self nbCall: #(void cairo_paint (self)) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 8/19/2013 15:04'! showGlyphs: glyphs size: numGlyphs "A drawing operator that generates the shape from a string of UTF-8 characters, rendered according to the current font_face, font_size (font_matrix), and font_options. " ^ self nbCall: #( void cairo_show_glyphs ( self , void * glyphs, int numGlyphs) ) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 8/28/2012 13:56'! showText: anUTF8String "A drawing operator that generates the shape from a string of UTF-8 characters, rendered according to the current font_face, font_size (font_matrix), and font_options. " ^ self nbCall: #(void cairo_show_text (self, char * anUTF8String )) ! ! !AthensCairoCanvas methodsFor: 'path segments visitor' stamp: 'FernandoOlivero 2/14/2012 08:17'! visitQuadSegment: anAthensCubicSegment | destination controlPoint | destination := anAthensCubicSegment to. controlPoint := anAthensCubicSegment via. self curveToX: destination x Y: destination y viaX: controlPoint x Y: controlPoint y ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 9/1/2012 18:43'! setPathMatrix: aMatrix ^ self nbCall: #(void cairo_set_matrix (self, AthensCairoMatrix * aMatrix) ) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 9/1/2012 19:45'! getCurrentPoint | x y | "since we use pointers to floats we must create a copy of original values to not scratch them" x := 0.0 shallowCopy. y := 0.0 shallowCopy. self primGetCurrentPointX: x Y: y. ^ x @ y ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 12/20/2011 16:10'! fill ^ self nbCall: #(void cairo_fill (self)) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 9/2/2012 22:18'! setClipRect: aRectOrNil aRectOrNil ifNil: [ self resetClip ] ifNotNil: [ self newPath; rectangleX: aRectOrNil left y: aRectOrNil top width: aRectOrNil width height: aRectOrNil height; primClip ]! ! !AthensCairoCanvas methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 01:47'! handle ^ handle value! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 9/1/2012 19:44'! primGetCurrentPointX: x Y: y ^self nbCall: #( void cairo_get_current_point (self, double * x, double * y))! ! !AthensCairoCanvas methodsFor: 'library path' stamp: 'IgorStasenko 12/20/2011 16:11'! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 5/31/2012 01:53'! setPathMatrix ^ self nbCall: #(void cairo_set_matrix (self, AthensCairoMatrix * pathTransform) ) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 4/3/2013 06:23'! primSetLineCap: capStyle ^ self nbCall: #(void cairo_set_line_cap ( self, cairo_line_cap_t capStyle) )! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 12/20/2011 16:17'! setSourceR: red g: green b: blue a: alpha ^ self nbCall: #( void cairo_set_source_rgba ( self , double red, double green, double blue, double alpha) )! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 9/3/2013 13:04'! stroke ^ self nbCall: #(void cairo_stroke (self)) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 8/28/2012 14:01'! setScaledFont: aFont "Replaces the current font face, font matrix, and font options in the cairo_t with those of the cairo_scaled_font_t. Except for some translation, the current CTM of the cairo_t should be the same as that of the cairo_scaled_font_t, which can be accessed using cairo_scaled_font_get_ctm(). " ^ self nbCall: #( void cairo_set_scaled_font (self , CairoScaledFont aFont)) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 9/1/2012 19:39'! text: utf8String extents: extentsObj "cairo_text_extents () void cairo_text_extents (cairo_t *cr, const char *utf8, cairo_text_extents_t *extents); " ^ self nbCall: #( void cairo_text_extents (self, char * utf8String, cairo_text_extents_t * extentsObj) ) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 9/1/2012 22:45'! setFontSize: aSize " void cairo_set_font_size (cairo_t *cr, double size); " ^ self nbCall: #( void cairo_set_font_size (self , double aSize )) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 9/2/2012 19:05'! setAA: antiAlias "cairo_set_antialias () void cairo_set_antialias (cairo_t *cr, cairo_antialias_t antialias); Set the antialiasing mode of the rasterizer used for drawing shapes. This value is a hint, and a particular backend may or may not support a particular value. At the current time, no backend supports CAIRO_ANTIALIAS_SUBPIXEL when drawing shapes. Note that this option does not affect text rendering, instead see cairo_font_options_set_antialias(). "! ! !AthensCairoCanvas methodsFor: 'path segments visitor' stamp: 'IgorStasenko 12/20/2011 18:49'! visitLineSegment: line ^ self lineToX: line endPoint x Y: line endPoint y! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 12/20/2011 15:56'! destroy ^self nbCall: #( void cairo_destroy (self) )! ! !AthensCairoCanvas methodsFor: 'path segments visitor' stamp: 'IgorStasenko 12/20/2011 18:46'! visitMoveSegment: mov ^ self moveToX: mov endPoint x Y: mov endPoint y! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 8/22/2013 13:51'! setFontMatrix: aMatrix " void cairo_set_font_matrix (cairo_t *cr, const cairo_matrix_t *matrix); " ^ self nbCall: #( void cairo_set_font_matrix (self , AthensCairoMatrix * aMatrix )) ! ! !AthensCairoCanvas methodsFor: 'drawing text' stamp: 'IgorStasenko 8/30/2013 16:14'! setFont: aFont ^ fontRenderer := aFont glyphRendererOn: surface. ! ! !AthensCairoCanvas methodsFor: 'private' stamp: ''! newPath ^ self nbCall: #( void cairo_new_path ( self ) )! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 3/8/2012 17:32'! loadPath: aPath ^ self nbCall: #( void cairo_append_path (self , AthensCairoPath aPath)) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 9/2/2012 20:55'! primClip ^ self nbCall: #(void cairo_clip (self)) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 4/3/2013 05:55'! resetDash self primResetDashes: 0.0! ! !AthensCairoCanvas methodsFor: 'drawing' stamp: 'IgorStasenko 10/11/2012 18:42'! draw "Fill the shape (anObject) using currently selected paint an object should implement double-dispatch to currently selected paint" "set the trasformation matrix" self setPathMatrix. ^ shape paintFillsUsing: paint on: self ! ! !AthensCairoCanvas methodsFor: 'accessing' stamp: ''! paintTransform ^ paintTransform ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 4/3/2013 05:42'! primResetDashes: anOffset " void cairo_set_dash (cairo_t *cr, double *dashes, int num_dashes, double offset);" self nbCall: #(void cairo_set_dash ( self, 0, 0, double anOffset) ) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 8/28/2012 18:19'! moveToX: x Y: y " move command always starts a new contour " ^ self nbCall: #(void cairo_move_to (self, double x, double y ) ) ! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'IgorStasenko 4/3/2013 06:21'! primSetLineJoin: joinStyle self nbCall: #(void cairo_set_line_join ( self, cairo_line_join_t joinStyle) )! ! !AthensCairoCanvas methodsFor: 'private' stamp: 'FernandoOlivero 1/17/2012 11:22'! resetClip ^ self nbCall: #(void cairo_reset_clip (self)) ! ! !AthensCairoCanvas methodsFor: 'path segments visitor' stamp: 'FernandoOlivero 1/15/2012 14:58'! visitCloseSegment: closeSegment self closePath! ! !AthensCairoCanvas methodsFor: 'clipping' stamp: 'IgorStasenko 10/7/2012 23:06'! clipBy: aRectangle during: aBlock | oldClip newClip | oldClip := currentClipRect. newClip := oldClip ifNil: [ aRectangle ] ifNotNil: [ oldClip intersect: aRectangle]. self setPathMatrix; resetClip; setClipRect: newClip. currentClipRect := newClip. [aBlock value] ensure: [ self setPathMatrix; resetClip; setClipRect: oldClip. currentClipRect := oldClip. ]. ! ! !AthensCairoCanvas class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/20/2011 15:45'! asNBExternalType: gen "use handle ivar to hold my instance (cairo_t)" ^ NBExternalObjectType objectClass: self! ! !AthensCairoCanvas class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/20/2011 16:14'! on: cairoSurface ^ (self primCreate: cairoSurface) surface: cairoSurface! ! !AthensCairoCanvas class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/20/2011 16:14'! primCreate: cairoSurface ^self nbCall: #( AthensCairoCanvas cairo_create (AthensCairoSurface cairoSurface) )! ! !AthensCairoCanvas class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/20/2011 16:12'! nbLibraryNameOrHandle ^ AthensCairoSurface nbLibraryNameOrHandle! ! !AthensCairoDefs commentStamp: 'TorstenBergmann 2/12/2014 22:22'! I hold a lot of different constants needed to work with cairo library! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: ''! initialize_cairo_status_t " typedef enum _cairo_status {" CAIRO_STATUS_SUCCESS := 0. CAIRO_STATUS_NO_MEMORY:=1. CAIRO_STATUS_INVALID_RESTORE:=2. CAIRO_STATUS_INVALID_POP_GROUP:=3. CAIRO_STATUS_NO_CURRENT_POINT:=4. CAIRO_STATUS_INVALID_MATRIX:=5. CAIRO_STATUS_INVALID_STATUS:=6. CAIRO_STATUS_NULL_POINTER:=7. CAIRO_STATUS_INVALID_STRING:=8. CAIRO_STATUS_INVALID_PATH_DATA:=9. CAIRO_STATUS_READ_ERROR:= 10. CAIRO_STATUS_WRITE_ERROR:=11. CAIRO_STATUS_SURFACE_FINISHED:=12. CAIRO_STATUS_SURFACE_TYPE_MISMATCH:=13. CAIRO_STATUS_PATTERN_TYPE_MISMATCH:=14. CAIRO_STATUS_INVALID_CONTENT:=15. CAIRO_STATUS_INVALID_FORMAT:=16. CAIRO_STATUS_INVALID_VISUAL:=17. CAIRO_STATUS_FILE_NOT_FOUND:=18. CAIRO_STATUS_INVALID_DASH:=19. CAIRO_STATUS_INVALID_DSC_COMMENT:=20. CAIRO_STATUS_INVALID_INDEX:=21. CAIRO_STATUS_CLIP_NOT_REPRESENTABLE:=22. CAIRO_STATUS_TEMP_FILE_ERROR:=23. CAIRO_STATUS_INVALID_STRIDE:=24. CAIRO_STATUS_FONT_TYPE_MISMATCH:=25. CAIRO_STATUS_USER_FONT_IMMUTABLE:=26. CAIRO_STATUS_USER_FONT_ERROR:=27. CAIRO_STATUS_NEGATIVE_COUNT:=28. CAIRO_STATUS_INVALID_CLUSTERS:=29. CAIRO_STATUS_INVALID_SLANT:=30. CAIRO_STATUS_INVALID_WEIGHT:=31. CAIRO_STATUS_INVALID_SIZE:=32. CAIRO_STATUS_USER_FONT_NOT_IMPLEMENTED:=33. CAIRO_STATUS_DEVICE_TYPE_MISMATCH:=34. CAIRO_STATUS_DEVICE_ERROR:=35. ! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/2/2012 01:11'! initialize_cairo_hint_style_t "typedef enum { " CAIRO_HINT_STYLE_DEFAULT := 0. CAIRO_HINT_STYLE_NONE := 1. CAIRO_HINT_STYLE_SLIGHT := 2. CAIRO_HINT_STYLE_MEDIUM := 3. CAIRO_HINT_STYLE_FULL := 4. "} cairo_hint_style_t; " ! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: ''! initialize_cairo_font_slant_t "typedef enum _cairo_font_slant {" CAIRO_FONT_SLANT_NORMAL := 0. CAIRO_FONT_SLANT_ITALIC := 1. CAIRO_FONT_SLANT_OBLIQUE := 2 ! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: ''! initialize_cairo_font_type_t "typedef enum _cairo_font_type {" CAIRO_FONT_TYPE_TOY := 0. CAIRO_FONT_TYPE_FT := 1. CAIRO_FONT_TYPE_WIN32 := 2. CAIRO_FONT_TYPE_QUARTZ := 3. CAIRO_FONT_TYPE_USER := 4. ! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 4/19/2012 13:33'! initialize_cairo_extend_t "typedef enum {" CAIRO_EXTEND_NONE := 0 . CAIRO_EXTEND_REPEAT := 1. CAIRO_EXTEND_REFLECT :=2. CAIRO_EXTEND_PAD := 3. "} cairo_extend_t" ! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/2/2012 01:22'! initialize_cairo_antialias_t "typedef enum {" CAIRO_ANTIALIAS_DEFAULT := 0. " method " CAIRO_ANTIALIAS_NONE := 1. CAIRO_ANTIALIAS_GRAY := 2. CAIRO_ANTIALIAS_SUBPIXEL := 3. " hints " CAIRO_ANTIALIAS_FAST := 4. CAIRO_ANTIALIAS_GOOD := 5. CAIRO_ANTIALIAS_BEST := 6. "} cairo_antialias_t; " ! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: ''! initialize_cairo_font_weight_t "typedef enum _cairo_font_weight {" CAIRO_FONT_WEIGHT_NORMAL := 0. CAIRO_FONT_WEIGHT_BOLD := 1. ! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/1/2012 19:40'! initialize_types cairo_status_t := cairo_font_type_t := cairo_line_join_t := cairo_line_cap_t := cairo_status_t := cairo_font_slant_t := cairo_font_weight_t := cairo_operator_t := #int. cairo_pattern_t := #AthensCairoPatternPaint. cairo_t := #AthensCairoCanvas. cairo_surface_t := #AthensCairoSurface . cairo_text_extents_t := #CairoTextExtents.! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: ''! initialize_cairo_operator_t " typedef enum _cairo_operator {" CAIRO_OPERATOR_CLEAR := 0. CAIRO_OPERATOR_SOURCE:= 1. CAIRO_OPERATOR_OVER:= 2. CAIRO_OPERATOR_IN:= 3. CAIRO_OPERATOR_OUT:= 4. CAIRO_OPERATOR_ATOP:= 5. CAIRO_OPERATOR_DEST:= 6. CAIRO_OPERATOR_DEST_OVER:= 7. CAIRO_OPERATOR_DEST_IN:= 8. CAIRO_OPERATOR_DEST_OUT:= 9. CAIRO_OPERATOR_DEST_ATOP:= 10. CAIRO_OPERATOR_XOR:= 11. CAIRO_OPERATOR_ADD:= 12. CAIRO_OPERATOR_SATURATE:= 13. CAIRO_OPERATOR_MULTIPLY:= 14. CAIRO_OPERATOR_SCREEN:= 15. CAIRO_OPERATOR_OVERLAY:= 16. CAIRO_OPERATOR_DARKEN := 17. CAIRO_OPERATOR_LIGHTEN := 18. CAIRO_OPERATOR_COLOR_DODGE := 19. CAIRO_OPERATOR_COLOR_BURN := 20. CAIRO_OPERATOR_HARD_LIGHT := 21. CAIRO_OPERATOR_SOFT_LIGHT := 22. CAIRO_OPERATOR_DIFFERENCE := 23. CAIRO_OPERATOR_EXCLUSION := 24. CAIRO_OPERATOR_HSL_HUE := 25. CAIRO_OPERATOR_HSL_SATURATION := 26. CAIRO_OPERATOR_HSL_COLOR := 27. CAIRO_OPERATOR_HSL_LUMINOSITY := 28. "} cairo_operator_t;"! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2013 18:32'! initialize " self initialize " self initialize_types; initialize_cairo_format_t; initialize_cairo_font_slant_t; initialize_cairo_font_weight_t; initialize_cairo_font_type_t ; initialize_cairo_operator_t ; initialize_cairo_line_cap_t ; initialize_cairo_line_join_t; initialize_cairo_status_t; initialize_cairo_extend_t; initialize_cairo_hint_style_t; initialize_cairo_antialias_t; init_cairo_subpixel_order_t; initialize_cairo_hint_metrics_t. ! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: ''! initialize_cairo_format_t "enum cairo_format_t" CAIRO_FORMAT_INVALID := -1. CAIRO_FORMAT_ARGB32 := 0. CAIRO_FORMAT_RGB24 := 1. CAIRO_FORMAT_A8 := 2. CAIRO_FORMAT_A1 := 3. CAIRO_FORMAT_RGB16_565 := 4! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: ''! initialize_cairo_line_join_t " typedef enum _cairo_line_join {" CAIRO_LINE_JOIN_MITER := 0. CAIRO_LINE_JOIN_ROUND := 1. CAIRO_LINE_JOIN_BEVEL := 2. ! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: ''! initialize_cairo_line_cap_t "typedef enum _cairo_line_cap { " CAIRO_LINE_CAP_BUTT := 0. CAIRO_LINE_CAP_ROUND := 1. CAIRO_LINE_CAP_SQUARE := 2. ! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/2/2012 19:52'! init_cairo_subpixel_order_t "typedef enum {" CAIRO_SUBPIXEL_ORDER_DEFAULT := 0. CAIRO_SUBPIXEL_ORDER_RGB := 1. CAIRO_SUBPIXEL_ORDER_BGR := 2. CAIRO_SUBPIXEL_ORDER_VRGB := 3. CAIRO_SUBPIXEL_ORDER_VBGR := 4. "} cairo_subpixel_order_t;" ! ! !AthensCairoDefs class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2013 18:32'! initialize_cairo_hint_metrics_t "typedef enum {" CAIRO_HINT_METRICS_DEFAULT := 0. CAIRO_HINT_METRICS_OFF := 1. CAIRO_HINT_METRICS_ON := 2. ! ! !AthensCairoGradientPaint commentStamp: ''! i used to represent gradient paints (both radial and linear) in cairo backend! !AthensCairoGradientPaint methodsFor: 'primitives' stamp: 'IgorStasenko 4/12/2013 10:21'! primAddColorStopOffset: offset R: red G: green B: blue A: alpha ^ self nbCall:#( void cairo_pattern_add_color_stop_rgba ( cairo_pattern_t self, double offset, double red, double green, double blue, double alpha )) ! ! !AthensCairoGradientPaint methodsFor: 'initialize-release' stamp: 'FernandoOlivero 4/19/2012 14:13'! defaultExtend "The default extend mode is CAIRO_EXTEND_NONE for surface patterns and CAIRO_EXTEND_PAD for gradient patterns. " ^ CAIRO_EXTEND_PAD! ! !AthensCairoGradientPaint methodsFor: 'private' stamp: 'IgorStasenko 4/12/2013 10:19'! addColorStopAt: anOffset colored: aColor self primAddColorStopOffset: anOffset R: aColor red G: aColor green B: aColor blue A: aColor alpha ! ! !AthensCairoGradientPaint methodsFor: 'private' stamp: 'IgorStasenko 4/12/2013 10:17'! populateRamp: aRamp aRamp do: [ :each | self addColorStopAt: each key colored: each value ] ! ! !AthensCairoGradientPaint methodsFor: 'initialize-release' stamp: 'FernandoOlivero 4/19/2012 13:56'! initializeRadialBetween: origin extending: innerRadius and: outerOrigin extending: outerRadius withColorRamp: aRamp self initialize. aRamp do:[:each| self addColorStopAt: each key colored: each value ] ! ! !AthensCairoGradientPaint class methodsFor: 'primitives' stamp: 'IgorStasenko 4/12/2013 10:23'! primCreateLinearX0: x0 y0: y0 x1: x1 y1: y1 ^self nbCall: #(AthensCairoGradientPaint cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ) ! ! !AthensCairoGradientPaint class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 4/19/2012 13:56'! radialBetween: origin extending: innerRadius and: outerOrigin extending: outerRadius withColorRamp: colorRamp | paint | paint := self primCreateRadialXo: origin x yo: origin y radiuso: innerRadius x1: outerOrigin x y1: outerOrigin y radius1: outerRadius. paint initializeRadialBetween: origin extending: innerRadius and: outerOrigin extending: outerRadius withColorRamp: colorRamp. ^ paint.! ! !AthensCairoGradientPaint class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/12/2013 10:25'! createLinearGradient: aColorRamp start: aStartPoint stop: aStopPoint | paint | paint := self primCreateLinearX0: aStartPoint x asFloat y0: aStartPoint y asFloat x1: aStopPoint x asFloat y1: aStopPoint y asFloat. "note, we do #initialize here because instance was created by primitive" paint initialize; populateRamp: aColorRamp. ^ paint ! ! !AthensCairoGradientPaint class methodsFor: 'primitives' stamp: 'FernandoOlivero 4/19/2012 13:55'! primCreateRadialXo: xo yo: yo radiuso: radiuso x1: x1 y1: y1 radius1: radius1 ^self nbCall: #(AthensCairoGradientPaint cairo_pattern_create_radial ( double xo, double yo, double radiuso, double x1, double y1, double radius1 ) ) ! ! !AthensCairoMatrix commentStamp: ''! I implement an AthensAffineTransform interface.! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'IgorStasenko 5/31/2012 01:43'! setScaleX: x Y: y ^self nbCall: #( void cairo_matrix_init_scale (AthensCairoMatrix * self, double x, double y)) ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: ''! clearTranslation "reset a translation from matrix, leaving only scale and rotation" self x: 0. self y: 0.! ! !AthensCairoMatrix methodsFor: 'private' stamp: 'IgorStasenko 8/14/2013 13:39'! initx: x y: y sx: sx sy: sy shx: shx shy: shy ^self nbCall: #( void cairo_matrix_init (AthensCairoMatrix * self, double sx, double shy, double shx, double sy, double x, double y)) ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: ''! inverseTransform: aPoint ^ self inverted transform: aPoint! ! !AthensCairoMatrix methodsFor: 'private' stamp: 'jb 8/9/2013 16:16'! copyFromMatrix: m NativeBoost memCopy: m address to: self address size: self class instanceSize.! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: ''! rotateByDegrees: angle ^ self rotateByRadians: angle degreesToRadians! ! !AthensCairoMatrix methodsFor: 'initialize-release' stamp: ''! initialize self loadIdentity.! ! !AthensCairoMatrix methodsFor: 'accessing' stamp: 'IgorStasenko 8/31/2012 22:31'! getMatrix "Shall we answer an AthensAffineMatrix instead? ^ AthensAffineMatrix new loadAffineTransform: self " ^ self copy! ! !AthensCairoMatrix methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'IgorStasenko 8/14/2013 13:38'! loadAffineTransform: m self initx: m x y: m y sx: m sx sy: m sy shx: m shx shy: m shy! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'IgorStasenko 3/28/2012 16:32'! multiplyBy: anAthensAffineTransform self primMultiplyBy: ( self class new loadAffineTransform: anAthensAffineTransform)! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: ''! transform: aPoint | x y | "since we use pointers to floats we must create a copy of original values to not scratch them" x := aPoint x asFloat shallowCopy. y := aPoint y asFloat shallowCopy. self primTransformX: x Y: y. ^ x @ y! ! !AthensCairoMatrix methodsFor: 'private' stamp: 'IgorStasenko 5/31/2012 01:42'! primLoadIdentity "initialize with identity transform" ^ self nbCall: #( void cairo_matrix_init_identity (AthensCairoMatrix * self ) )! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'IgorStasenko 5/31/2012 01:57'! primMultiplyBy: m ^self nbCall: #(void cairo_matrix_multiply (AthensCairoMatrix * self, AthensCairoMatrix * m , AthensCairoMatrix * self ) ) ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'IgorStasenko 6/3/2012 04:07'! restoreAfter: aBlock |previous| previous := self copy. aBlock ensure: [ self copyFromMatrix: previous. "just copy the memory" "self loadAffineTransform: previous" ]! ! !AthensCairoMatrix methodsFor: 'private' stamp: 'IgorStasenko 5/31/2012 01:42'! primTransformX: x Y: y ^self nbCall: #( void cairo_matrix_transform_point (AthensCairoMatrix * self, double * x, double * y)) ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'IgorStasenko 5/31/2012 01:43'! setTranslateX: x Y: y ^self nbCall: #( void cairo_matrix_init_translate (AthensCairoMatrix * self, double x, double y)) ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: ''! translateBy: aPoint self translateX: aPoint x Y: aPoint y ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'FernandoOlivero 4/21/2012 02:35'! inverted | m | m := self copy. m invert. ^ m! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'IgorStasenko 5/31/2012 01:41'! invert ^self nbCall: #( cairo_status_t cairo_matrix_invert (AthensCairoMatrix * self)) ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'IgorStasenko 5/31/2012 01:43'! scaleX: fx Y: fy ^self nbCall: #( void cairo_matrix_scale (AthensCairoMatrix * self, double fx, double fy)) ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'FernandoOlivero 3/22/2012 13:35'! scaleBy: factor "if factor is number, do a uniform scale, if not, then factor is assument to be an instance of Point containing non-uniform scale for each axis" factor isPoint ifTrue: [ self scaleX: factor x asFloat Y: factor y asFloat ] ifFalse: [ self scaleX: factor asFloat Y: factor asFloat ] ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'IgorStasenko 5/31/2012 01:43'! setRotationInRadians: radians ^self nbCall: #( void cairo_matrix_init_rotate (AthensCairoMatrix * self, double radians)) ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'IgorStasenko 5/31/2012 01:43'! rotateByRadians: angle ^self nbCall: #( void cairo_matrix_rotate (AthensCairoMatrix * self, double angle)) ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: 'IgorStasenko 5/31/2012 01:44'! translateX: px Y: py ^self nbCall: #( void cairo_matrix_translate (AthensCairoMatrix * self, double px, double py)) ! ! !AthensCairoMatrix methodsFor: 'transformations' stamp: ''! loadIdentity "initialize with identity transform" self primLoadIdentity ! ! !AthensCairoMatrix class methodsFor: 'as yet unclassified' stamp: ''! fieldsDesc ^ #( double sx; double shx; double shy; double sy; double x; double y; )! ! !AthensCairoMatrix class methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !AthensCairoPDFSurface commentStamp: ''! i am a concrete implementation of Athens surface which using cairo graphics library for rendering for generating PDF files as output. ! !AthensCairoPDFSurface methodsFor: 'private' stamp: 'IgorStasenko 5/4/2012 18:29'! showPage ^self nbCall: #( void cairo_surface_show_page (self) )! ! !AthensCairoPDFSurface methodsFor: 'initialize-release' stamp: 'IgorStasenko 5/4/2012 18:15'! resourceData ^ handle value ! ! !AthensCairoPDFSurface methodsFor: 'private' stamp: 'IgorStasenko 5/4/2012 18:22'! newCanvas ^ self primCreateCanvas surface: self! ! !AthensCairoPDFSurface class methodsFor: 'private' stamp: 'IgorStasenko 5/4/2012 18:12'! createPDF: fileName width: width_in_points height: height_in_points ^self nbCall: #(AthensCairoPDFSurface cairo_pdf_surface_create (String fileName, double width_in_points, double height_in_points) ) ! ! !AthensCairoPDFSurface class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/4/2012 18:14'! registerSurface: surface "do not register my instances with SurfacePlugin"! ! !AthensCairoPDFSurface class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/4/2012 18:13'! extent: anExtent fileName: fileName ^ (self createPDF: fileName width: anExtent x height: anExtent y) initialize! ! !AthensCairoPDFSurface class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/4/2012 18:34'! finalizeResourceData: handle self destroySurfaceHandle: handle. ! ! !AthensCairoPaintMode commentStamp: ''! I control the paint modes supported by Cairo backend. for the list and description of paint modes supported by Cairo library, see http://cairographics.org/operators/! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 16:01'! dest "Set 'dest' drawing mode. Drawing under this mode will ignore the source, as if nothing drawn" ^ self setOperator: CAIRO_OPERATOR_DEST! ! !AthensCairoPaintMode methodsFor: 'private' stamp: 'IgorStasenko 9/1/2012 15:40'! getOperator ^ self nbCall: #( cairo_operator_t cairo_get_operator (AthensCairoCanvas canvas) ) ! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:11'! atop ^ self setOperator: CAIRO_OPERATOR_ATOP! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:11'! destOver ^ self setOperator: CAIRO_OPERATOR_DEST_OVER! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 16:01'! over "Set 'over' drawing mode. This is default paint mode. Drawing under this mode will blend source with destination color using source alpha component" ^ self setOperator: CAIRO_OPERATOR_OVER! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:11'! in ^ self setOperator: CAIRO_OPERATOR_IN! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:12'! destAtop ^ self setOperator: CAIRO_OPERATOR_DEST_ATOP! ! !AthensCairoPaintMode methodsFor: 'initialize-release' stamp: 'IgorStasenko 9/1/2012 15:32'! canvas: aCanvas canvas := aCanvas! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:13'! multiply ^ self setOperator: CAIRO_OPERATOR_MULTIPLY! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:11'! out ^ self setOperator: CAIRO_OPERATOR_OUT! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:13'! overlay ^ self setOperator: CAIRO_OPERATOR_OVERLAY! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 16:01'! source "Set 'source' drawing mode. Drawing under this mode will replace the content with incoming source under the shape boundaries" ^ self setOperator: CAIRO_OPERATOR_SOURCE! ! !AthensCairoPaintMode methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:15'! hslSaturation ^ self setOperator: CAIRO_OPERATOR_HSL_SATURATION! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:12'! destOut ^ self setOperator: CAIRO_OPERATOR_DEST_OUT! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:15'! hslColor ^ self setOperator: CAIRO_OPERATOR_HSL_COLOR! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 16:00'! clear "Set 'clear' drawing mode. Drawing under this mode will clear the surface under the shape boundaries" ^ self setOperator: CAIRO_OPERATOR_CLEAR! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:13'! screen ^ self setOperator: CAIRO_OPERATOR_SCREEN! ! !AthensCairoPaintMode methodsFor: 'private' stamp: 'IgorStasenko 9/1/2012 15:37'! setOperator: aCairoOperatorT ^ self nbCall: #(void cairo_set_operator (AthensCairoCanvas canvas, cairo_operator_t aCairoOperatorT) ) ! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:14'! colorBurn ^ self setOperator: CAIRO_OPERATOR_COLOR_BURN! ! !AthensCairoPaintMode methodsFor: 'convenience' stamp: 'IgorStasenko 9/1/2012 15:36'! restoreAfter: aBlock | op | op := self getOperator. aBlock ensure: [ self setOperator: op ]! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:13'! darken ^ self setOperator: CAIRO_OPERATOR_DARKEN! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:15'! difference ^ self setOperator: CAIRO_OPERATOR_DIFFERENCE! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:12'! add ^ self setOperator: CAIRO_OPERATOR_ADD! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:14'! colorDodge ^ self setOperator: CAIRO_OPERATOR_COLOR_DODGE! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:12'! destIn ^ self setOperator: CAIRO_OPERATOR_DEST_IN! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:16'! hslLuminosity ^ self setOperator: CAIRO_OPERATOR_HSL_LUMINOSITY! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:14'! lighten ^ self setOperator: CAIRO_OPERATOR_LIGHTEN! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:12'! xor ^ self setOperator: CAIRO_OPERATOR_XOR! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:14'! softLight ^ self setOperator: CAIRO_OPERATOR_SOFT_LIGHT! ! !AthensCairoPaintMode methodsFor: 'capabilities' stamp: 'IgorStasenko 9/1/2012 17:18'! availableModes ^ #( clear source over in out atop dest destOver destIn destOut destAtop xor add saturate multiply screen overlay darken lighten colorDodge colorBurn hardLight softLight difference exclusion hslHue hslSaturation hslColor hslLuminosity )! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:13'! saturate ^ self setOperator: CAIRO_OPERATOR_SATURATE! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:15'! hslHue ^ self setOperator: CAIRO_OPERATOR_HSL_HUE! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:14'! hardLight ^ self setOperator: CAIRO_OPERATOR_HARD_LIGHT! ! !AthensCairoPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:15'! exclusion ^ self setOperator: CAIRO_OPERATOR_EXCLUSION! ! !AthensCairoPaintMode class methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !AthensCairoPath commentStamp: ''! i used to hold shapes built by path builder in cairo backend! !AthensCairoPath methodsFor: 'instance creation' stamp: 'FernandoOlivero 3/28/2012 19:12'! primDestroyPath: aHandle ^ self nbCall: #(void cairo_path_destroy ( ulong aHandle )) ! ! !AthensCairoPath methodsFor: 'initialize-release' stamp: 'FernandoOlivero 3/28/2012 19:10'! initialize handle value = 0 ifTrue: [ self error: 'Error creating new path' ]. NBExternalResourceManager addResource: self data: handle! ! !AthensCairoPath methodsFor: 'drawing' stamp: 'IgorStasenko 8/30/2013 16:32'! paintFillsUsing: aPaint on: anAthensCanvas "This method is a part of rendering dispatch Canvas->receiver->paint" ^ aPaint athensFillPath: self on: anAthensCanvas! ! !AthensCairoPath methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !AthensCairoPath methodsFor: 'converting' stamp: 'IgorStasenko 5/6/2013 05:44'! asAthensShapeOn: anAthensCanvas ^ self! ! !AthensCairoPath class methodsFor: 'instance creation' stamp: ''! primDestroyPath: aHandle ^ self nbCall: #(void cairo_path_destroy ( ulong aHandle )) ! ! !AthensCairoPath class methodsFor: 'instance creation' stamp: ''! finalizeResourceData: aHandle self primDestroyPath: aHandle value ! ! !AthensCairoPath class methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !AthensCairoPathBuilder commentStamp: ''! i implement cairo-specific path builder. see my superclass for more details.! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'JochenRick 1/8/2014 08:24'! lineTo: aPoint endPoint := self toAbsolute: aPoint. lastControlPoint := nil. ^ self lineToX: endPoint x asFloat Y: endPoint y asFloat! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'JochenRick 1/7/2014 19:14'! hLineTo: x ^ self lineTo: (absolute ifTrue: [ x @ endPoint y] ifFalse: [ x @ 0 ])! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'JochenRick 1/8/2014 08:23'! close self closePath. endPoint := self getCurrentPoint. lastControlPoint := nil! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'JochenRick 1/8/2014 08:28'! reflectedCurveVia: p2 to: aPoint | pt1 | pt1 := lastControlPoint ifNil: [ endPoint ] ifNotNil: [ endPoint * 2 - lastControlPoint]. lastControlPoint := self toAbsolute: p2. endPoint := self toAbsolute: aPoint. self curveViaX: pt1 x Y: pt1 y viaX: lastControlPoint x Y: lastControlPoint y toX: endPoint x Y: endPoint y ! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'IgorStasenko 9/3/2012 02:40'! getCurrentPoint ^ context getCurrentPoint! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'JochenRick 1/8/2014 08:25'! curveVia: p1 and: p2 to: aPoint | pt1 | pt1 := self toAbsolute: p1. lastControlPoint := self toAbsolute: p2. endPoint := self toAbsolute: aPoint. self curveViaX: pt1 x Y: pt1 y viaX: lastControlPoint x Y: lastControlPoint y toX: endPoint x Y: endPoint y ! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'IgorStasenko 3/8/2012 16:47'! arcCenterX: xc centerY: yc radius: radius startAngle: angle1 endAngle: angle2 self nbCall: #(void cairo_arc (AthensCairoCanvas context, double xc, double yc, double radius, double angle1, double angle2) ) ! ! !AthensCairoPathBuilder methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'FernandoOlivero 3/9/2012 14:43'! closePath self nbCall: #(void cairo_close_path (AthensCairoCanvas context))! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 16:45'! relative absolute := false! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 16:45'! absolute absolute := true! ! !AthensCairoPathBuilder methodsFor: 'accessing' stamp: 'IgorStasenko 3/7/2012 17:15'! createPath: aBlock self newPath. "set default to relative" absolute := false. endPoint := ZeroPoint. "set the implicit path origin" self moveToX: 0 Y: 0. aBlock value: self. ^ self copyPath initialize ! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/8/2012 17:06'! ccwArcTo: newEndPoint angle: angle " Add a counter-clockwise arc segment, starting from current path endpoint and ending at andPt. Angle should be specified in radians " ^ self arcTo: newEndPoint angle: angle cw: false! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'IgorStasenko 3/8/2012 16:54'! calcCenter: start end: end angle: angle | v rot center radius len sina cosa m | v := end - start. m := AthensAffineTransform new rotateByRadians: (Float pi - angle /2). v := m transform: v. len := v r. radius := len / 2 / (angle /2) sin. center := v * (radius/len) + start. ^ center! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 16:20'! toAbsolute: aPoint ^ absolute ifTrue: [ aPoint ] ifFalse: [ endPoint + aPoint ]! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'JochenRick 1/7/2014 19:14'! vLineTo: y ^ self lineTo: (absolute ifTrue: [ endPoint x @ y] ifFalse: [ 0 @ y ])! ! !AthensCairoPathBuilder methodsFor: 'accessing' stamp: 'IgorStasenko 3/7/2012 15:15'! context: anObject context := anObject! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'JochenRick 1/8/2014 08:24'! curveVia: p1 to: aPoint | pt0 pt1 cp1 cp2 twoThirds | "Quad bezier curve" pt0 := endPoint. pt1 := self toAbsolute: p1. endPoint := self toAbsolute: aPoint. lastControlPoint := nil. "Any quadratic spline can be expressed as a cubic (where the cubic term is zero). The end points of the cubic will be the same as the quadratic's. CP0 = QP0 CP3 = QP2 The two control points for the cubic are: CP1 = QP0 + 2/3 *(QP1-QP0) CP2 = QP2 + 2/3 *(QP1-QP2)" twoThirds := (2/3) asFloat. cp1 := pt1 - pt0 * twoThirds + pt0. cp2 := pt1 - endPoint * twoThirds + endPoint. self curveViaX: cp1 x Y: cp1 y viaX: cp2 x Y: cp2 y toX: endPoint x Y: endPoint y ! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'IgorStasenko 3/8/2012 16:36'! angleOfVector: v | n acos | n := v normalized. acos := n x arcCos. ^ v y < 0 ifTrue: [ Float pi * 2 - acos ] ifFalse: [ acos ]! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'IgorStasenko 3/7/2012 16:04'! newPath ^ self nbCall: #( void cairo_new_path ( AthensCairoCanvas context ) )! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'JochenRick 1/8/2014 08:24'! moveTo: aPoint endPoint := self toAbsolute: aPoint. lastControlPoint := nil. ^ self moveToX: endPoint x asFloat Y: endPoint y asFloat ! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'IgorStasenko 3/7/2012 17:39'! curveViaX: x1 Y: y1 viaX: x2 Y: y2 toX: x3 Y: y3 ^ self nbCall: #(void cairo_curve_to(AthensCairoCanvas context, double x1, double y1, double x2, double y2, double x3, double y3)) ! ! !AthensCairoPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/8/2012 17:05'! cwArcTo: newEndPoint angle: angle " Add a clockwise arc segment, starting from current path endpoint and ending at andPt. Angle should be specified in radians " ^ self arcTo: newEndPoint angle: angle cw: true! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'IgorStasenko 3/7/2012 16:08'! lineToX: x Y: y ^ self nbCall: #(void cairo_line_to (AthensCairoCanvas context, double x, double y ) ) ! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'IgorStasenko 3/8/2012 17:01'! arcNegativeCenterX: xc centerY: yc radius: radius startAngle: angle1 endAngle: angle2 self nbCall: #(void cairo_arc_negative (AthensCairoCanvas context, double xc, double yc, double radius, double angle1, double angle2) ) ! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'IgorStasenko 3/7/2012 16:47'! copyPath ^ self nbCall: #( AthensCairoPath cairo_copy_path (AthensCairoCanvas context) ) ! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'JochenRick 1/8/2014 08:23'! arcTo: newEndPoint angle: angle cw: aBool " Add a clockwise arc segment, starting from current path endpoint and ending at andPt. Angle should be specified in radians " | start end center v radius startAngle endAngle cwAngle | lastControlPoint := nil. angle isZero ifTrue: [ ^ self lineTo: newEndPoint ]. start := endPoint. endPoint := end := self toAbsolute: newEndPoint. start = end ifTrue: [ ^ self ]. "we have to transform the input. because Cario expects the center , radius, starting and ending angle, and we have the starting point, the ending point , and the angle. " aBool ifTrue: [cwAngle := angle] ifFalse: [cwAngle := angle negated]. center := self calcCenter: start end: end angle: cwAngle. v := (start - center). radius := v r. startAngle := self angleOfVector: v. endAngle := self angleOfVector: (end-center). aBool ifTrue: [ self arcCenterX: center x centerY: center y radius: radius startAngle: startAngle endAngle: endAngle ] ifFalse: [ self arcNegativeCenterX: center x centerY: center y radius: radius startAngle: startAngle endAngle: endAngle ] ! ! !AthensCairoPathBuilder methodsFor: 'private' stamp: 'IgorStasenko 3/7/2012 16:07'! moveToX: x Y: y " move command always starts a new contour " ^ self nbCall: #(void cairo_move_to (AthensCairoCanvas context, double x, double y ) ) ! ! !AthensCairoPathBuilder class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 3/7/2012 14:53'! buildPathFrom: aPathCreatingBlock ! ! !AthensCairoPathBuilder class methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !AthensCairoPatternPaint commentStamp: ''! i am abstract class for different kinds of paints in cairo backend.! !AthensCairoPatternPaint methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 01:53'! setMatrix: m self nbCall: #( void cairo_pattern_set_matrix ( self, AthensCairoMatrix * m) ) ! ! !AthensCairoPatternPaint methodsFor: 'drawing' stamp: 'IgorStasenko 9/3/2013 15:00'! athensFillPath: path on: aCanvas aCanvas newPath; loadPath: path. self setMatrix: aCanvas paintTransform inverted. self loadOnCairoCanvas: aCanvas. aCanvas fill.! ! !AthensCairoPatternPaint methodsFor: 'testing' stamp: 'IgorStasenko 3/28/2012 18:50'! isPatternTypeMismatch ^ self status = CAIRO_STATUS_PATTERN_TYPE_MISMATCH.! ! !AthensCairoPatternPaint methodsFor: 'testing' stamp: ''! isSuccess ^ self status = CAIRO_STATUS_SUCCESS! ! !AthensCairoPatternPaint methodsFor: 'accessing' stamp: 'IgorStasenko 8/31/2012 01:12'! noRepeat self primSetExtend: CAIRO_EXTEND_NONE. ! ! !AthensCairoPatternPaint methodsFor: 'drawing' stamp: 'IgorStasenko 9/3/2013 12:40'! athensLoadOn: anAthensCanvas " Note: The pattern's transformation matrix will be locked to the user space in effect at the time of cairo_set_source(). This means that further modifications of the current transformation matrix will not affect the source pattern. See cairo_pattern_set_matrix(). " self isSuccess ifTrue:[ self primSetSourceOn: anAthensCanvas.] ifFalse:[ anAthensCanvas setSourceR: 1.0 g: 0.0 b: 0.0 a: 1.0]. ! ! !AthensCairoPatternPaint methodsFor: 'drawing' stamp: 'IgorStasenko 9/3/2013 15:00'! athensFillRectangle: aRectangle on: aCanvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " aCanvas rectangleX: aRectangle left y: aRectangle top width: aRectangle width height: aRectangle height. self setMatrix: aCanvas paintTransform inverted. self loadOnCairoCanvas: aCanvas. aCanvas fill! ! !AthensCairoPatternPaint methodsFor: 'accessing' stamp: 'IgorStasenko 8/31/2012 01:13'! reflect self primSetExtend: CAIRO_EXTEND_REFLECT.! ! !AthensCairoPatternPaint methodsFor: 'drawing' stamp: 'FernandoOlivero 4/19/2012 15:01'! maskOn: anAthensCanvas " A drawing operator that paints the current source using the alpha channel of pattern as a mask. (Opaque areas of pattern are painted with the source, transparent areas are not painted.) " ^ self nbCall: #(void cairo_mask(cairo_t anAthensCanvas, self))! ! !AthensCairoPatternPaint methodsFor: 'drawing' stamp: 'IgorStasenko 9/3/2013 14:58'! loadOnCairoCanvas: aCanvas " Note: The pattern's transformation matrix will be locked to the user space in effect at the time of cairo_set_source(). This means that further modifications of the current transformation matrix will not affect the source pattern. See cairo_pattern_set_matrix(). " self isSuccess ifTrue:[ self primSetSourceOn: aCanvas.] ifFalse:[ aCanvas setSourceR: 1.0 g: 0.0 b: 0.0 a: 1.0]. ! ! !AthensCairoPatternPaint methodsFor: 'initialize-release' stamp: ''! initialize handle value = 0 ifTrue: [ self error: 'Error creating new paint' ]. "register to be finalized" NBExternalResourceManager addResource: self data: handle.! ! !AthensCairoPatternPaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/12/2013 10:29'! setExtend: aSymbol " typedef enum { CAIRO_EXTEND_NONE, CAIRO_EXTEND_REPEAT, CAIRO_EXTEND_REFLECT, CAIRO_EXTEND_PAD } cairo_extend_t; " | enum | enum := self defaultExtend. aSymbol = #None ifTrue: [ enum := CAIRO_EXTEND_NONE ]. aSymbol = #Repeat ifTrue: [ enum := CAIRO_EXTEND_REPEAT ]. aSymbol = #Reflect ifTrue: [ enum := CAIRO_EXTEND_REFLECT ]. aSymbol = #Pad ifTrue: [ enum := CAIRO_EXTEND_PAD ]. self primSetExtend: enum.! ! !AthensCairoPatternPaint methodsFor: 'accessing' stamp: 'IgorStasenko 8/31/2012 01:14'! repeat self primSetExtend: CAIRO_EXTEND_REPEAT.! ! !AthensCairoPatternPaint methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !AthensCairoPatternPaint methodsFor: 'primitives' stamp: 'IgorStasenko 3/30/2012 18:13'! primSetExtend: extend ^ self nbCall:#( void cairo_pattern_set_extend ( self , ulong extend) ) ! ! !AthensCairoPatternPaint methodsFor: 'accessing' stamp: 'FernandoOlivero 1/13/2012 20:15'! status ^ self nbCall: #(int cairo_pattern_status (cairo_pattern_t self)) ! ! !AthensCairoPatternPaint methodsFor: 'converting' stamp: 'IgorStasenko 4/27/2012 11:30'! asStrokePaintOn: aCanvas ^ aCanvas surface createStrokePaintFor: self! ! !AthensCairoPatternPaint methodsFor: 'initialize-release' stamp: 'FernandoOlivero 4/19/2012 14:14'! defaultExtend "The default extend mode is CAIRO_EXTEND_NONE for surface patterns and CAIRO_EXTEND_PAD for gradient patterns. " ^ CAIRO_EXTEND_NONE! ! !AthensCairoPatternPaint methodsFor: 'primitives' stamp: 'FernandoOlivero 4/19/2012 14:00'! primSetSourceOn: aCanvas ^ self nbCall: #(void cairo_set_source ( cairo_t aCanvas, self)) ! ! !AthensCairoPatternPaint methodsFor: 'converting' stamp: ''! asAthensPaintOn: anAthensCanvas ^ self! ! !AthensCairoPatternPaint class methodsFor: 'private' stamp: ''! finalizeResourceData: handle self primDestroyPattern: handle value ! ! !AthensCairoPatternPaint class methodsFor: 'private' stamp: ''! primDestroyPattern: aHandle self nbCall: #(void cairo_pattern_destroy (ulong aHandle) ) ! ! !AthensCairoPatternPaint class methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !AthensCairoPatternSurfacePaint commentStamp: ''! i represent texture/image/form/surface paints in cairo backend.! !AthensCairoPatternSurfacePaint methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/3/2013 16:17'! setMatrix: aMatrix aMatrix restoreAfter: [ origin ifNotNil: [ aMatrix translateBy: origin negated ]. super setMatrix: aMatrix. ]! ! !AthensCairoPatternSurfacePaint methodsFor: 'accessing' stamp: 'FernandoOlivero 4/22/2012 23:39'! extent ^ surface extent ! ! !AthensCairoPatternSurfacePaint methodsFor: 'initialize-release' stamp: 'FernandoOlivero 4/19/2012 13:58'! initializeFor: anAthensCairoSurface self initialize. surface := anAthensCairoSurface . ! ! !AthensCairoPatternSurfacePaint methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2012 17:29'! direction: aPoint direction := aPoint.! ! !AthensCairoPatternSurfacePaint methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2012 17:15'! origin: aPoint origin := aPoint.! ! !AthensCairoPatternSurfacePaint class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 4/19/2012 13:57'! primCreateForSurface: anAthensCairoSurface " pattern = cairo_pattern_create_for_surface (image);" ^self nbCall: #(AthensCairoPatternSurfacePaint cairo_pattern_create_for_surface( cairo_surface_t anAthensCairoSurface ) ) ! ! !AthensCairoPatternSurfacePaint class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 4/19/2012 13:57'! createForSurface: anAthensCairoSurface |pat| pat := self primCreateForSurface: anAthensCairoSurface . pat initializeFor: anAthensCairoSurface . ^ pat! ! !AthensCairoSolidPaint commentStamp: ''! i represent solid color paint in cairo backend! !AthensCairoSolidPaint methodsFor: 'drawing' stamp: 'IgorStasenko 9/3/2013 12:56'! athensFillPath: path on: aCanvas aCanvas setSourceR: r g: g b: b a: a; newPath; loadPath: path; fill. ! ! !AthensCairoSolidPaint methodsFor: 'drawing' stamp: 'IgorStasenko 9/3/2013 12:56'! athensFillRectangle: aRect on: aCanvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " aCanvas setSourceR: r g: g b: b a: a; newPath; rectangleX: aRect left y: aRect top width: aRect width height: aRect height; fill.! ! !AthensCairoSolidPaint methodsFor: 'accessing' stamp: 'IgorStasenko 3/28/2012 18:27'! color: aColor r := aColor red. g := aColor green. b := aColor blue. a := aColor alpha.! ! !AthensCairoSolidPaint methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !AthensCairoSolidPaint methodsFor: 'drawing' stamp: 'IgorStasenko 9/3/2013 14:56'! loadOnCairoCanvas: aCanvas aCanvas setSourceR: r g: g b: b a: a! ! !AthensCairoSolidPaint class methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !AthensCairoStrokePaint commentStamp: ''! i represent stroke paint in cairo backend! !AthensCairoStrokePaint methodsFor: 'drawing' stamp: 'IgorStasenko 9/3/2013 13:05'! athensFillPath: aPath on: aCanvas self prepareForDrawingOn: aCanvas. aCanvas newPath; loadPath: aPath; stroke! ! !AthensCairoStrokePaint methodsFor: 'private' stamp: 'FernandoOlivero 1/12/2012 23:20'! primSetLineCapOn: aCanvas ^ self nbCall: #(void cairo_set_line_cap ( AthensCairoCanvas aCanvas, cairo_line_cap_t capStyle) )! ! !AthensCairoStrokePaint methodsFor: 'private' stamp: 'FernandoOlivero 1/12/2012 23:51'! primSetDashesOn: aCanvas lengths: dashesLengths count: dashesCount offset: anOffset " void cairo_set_dash (cairo_t *cr, double *dashes, int num_dashes, double offset);" self nbCall: #(void cairo_set_dash ( AthensCairoCanvas aCanvas, double* dashesLengths, int dashesCount, double anOffset) ) ! ! !AthensCairoStrokePaint methodsFor: 'private' stamp: 'IgorStasenko 4/3/2013 05:53'! setDashesOn: aCanvas | buf | buf := ByteArray new: 8*dashLenghts size. dashLenghts withIndexDo: [:len :i | buf nbFloat64AtOffset: (i-1)*8 put: len asFloat ]. self primSetDashesOn: aCanvas lengths: buf count: dashLenghts size offset: dashOffset ! ! !AthensCairoStrokePaint methodsFor: 'drawing' stamp: 'IgorStasenko 9/3/2013 13:06'! athensFillRectangle: aRect on: aCanvas self prepareForDrawingOn: aCanvas. aCanvas newPath; rectangleX: aRect left y: aRect top width: aRect width height: aRect height; stroke. ! ! !AthensCairoStrokePaint methodsFor: 'setting join styles' stamp: 'IgorStasenko 9/3/2013 14:44'! joinMiter joinStyle := CAIRO_LINE_JOIN_MITER! ! !AthensCairoStrokePaint methodsFor: 'setting join styles' stamp: 'IgorStasenko 9/3/2013 14:44'! joinBevel joinStyle := CAIRO_LINE_JOIN_BEVEL! ! !AthensCairoStrokePaint methodsFor: 'initialize-release' stamp: 'IgorStasenko 9/3/2013 12:32'! initialize super initialize. self setDefaults! ! !AthensCairoStrokePaint methodsFor: 'setting cap styles' stamp: 'IgorStasenko 9/3/2013 14:14'! capSquare capStyle := CAIRO_LINE_CAP_SQUARE! ! !AthensCairoStrokePaint methodsFor: 'setting join styles' stamp: 'IgorStasenko 9/3/2013 14:44'! joinRound joinStyle := CAIRO_LINE_JOIN_ROUND ! ! !AthensCairoStrokePaint methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !AthensCairoStrokePaint methodsFor: 'setting dashes' stamp: 'IgorStasenko 4/3/2013 05:54'! dashes: anAlternateCollectionOfLenghts offset: anOffset dashLenghts := anAlternateCollectionOfLenghts. dashOffset := anOffset asFloat.! ! !AthensCairoStrokePaint methodsFor: 'private' stamp: 'FernandoOlivero 1/12/2012 23:19'! primSetLineWidthOn: aCanvas self nbCall: #(void cairo_set_line_width ( AthensCairoCanvas aCanvas, double width) ) ! ! !AthensCairoStrokePaint methodsFor: 'private' stamp: 'IgorStasenko 9/3/2013 13:02'! prepareForDrawingOn: aCanvas fillPaint loadOnCairoCanvas: aCanvas. self primSetLineWidthOn: aCanvas; primSetLineJoinOn: aCanvas; primSetLineCapOn: aCanvas. dashLenghts ifNil: [ aCanvas resetDash ] ifNotNil: [ self setDashesOn: aCanvas ].! ! !AthensCairoStrokePaint methodsFor: 'setting cap styles' stamp: 'IgorStasenko 9/3/2013 14:14'! capRound capStyle := CAIRO_LINE_CAP_ROUND! ! !AthensCairoStrokePaint methodsFor: 'setting cap styles' stamp: 'IgorStasenko 9/3/2013 14:44'! capButt capStyle := CAIRO_LINE_CAP_BUTT.! ! !AthensCairoStrokePaint methodsFor: 'private' stamp: 'FernandoOlivero 1/12/2012 23:21'! primSetLineJoinOn: aCanvas self nbCall: #(void cairo_set_line_join ( AthensCairoCanvas aCanvas, cairo_line_join_t joinStyle) )! ! !AthensCairoStrokePaint class methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !AthensCairoSurface commentStamp: ''! i am a concrete implementation of Athens surface which using cairo graphics library for rendering. Cairo library, by itself can have multiple surface types. This class uses image surface (a bitmap located in system memory) and maps to cairo_image_surface_t* C type.! !AthensCairoSurface methodsFor: 'private' stamp: 'FernandoOlivero 1/12/2012 12:00'! statusToString: aCairoStatusT ^ self nbCall: #(String cairo_status_to_string (cairo_status_t aCairoStatusT))! ! !AthensCairoSurface methodsFor: 'converting' stamp: 'IgorStasenko 4/26/2013 15:20'! asForm "create a form and copy an image data there" self checkSession. self flush. ^ Form extent: (self width@self height) depth: 32 bits: id! ! !AthensCairoSurface methodsFor: 'private' stamp: 'IgorStasenko 4/26/2013 15:21'! checkSession session == Smalltalk session ifFalse: [ self error: 'Attempt to use invalid external resource (left from previous session)' ]! ! !AthensCairoSurface methodsFor: 'testing' stamp: 'FernandoOlivero 1/12/2012 11:59'! isSuccess ^ self status = CAIRO_STATUS_SUCCESS! ! !AthensCairoSurface methodsFor: 'initialize-release' stamp: 'IgorStasenko 5/31/2012 01:48'! resourceData ^ { handle value. id. context handle }! ! !AthensCairoSurface methodsFor: 'private' stamp: 'IgorStasenko 8/31/2012 00:37'! markDirty ^self nbCall: #( void cairo_surface_mark_dirty (self) )! ! !AthensCairoSurface methodsFor: 'accessing' stamp: 'IgorStasenko 12/20/2011 15:12'! height ^self nbCall: #( int cairo_image_surface_get_height ( self ) ) ! ! !AthensCairoSurface methodsFor: 'accessing' stamp: ''! handle ^ handle value! ! !AthensCairoSurface methodsFor: 'initialize-release' stamp: 'IgorStasenko 4/26/2013 15:19'! initialize "the handle should be set already since we using an NB callout to create an instance" handle value = 0 ifTrue: [ self error: 'Error creating new surface' ]. session := Smalltalk session. id := self class registerSurface: self. context := self newCanvas. builder := AthensCairoPathBuilder new. builder context: context. ftFontRenderer := CairoFreetypeFontRenderer new canvas: context. NBExternalResourceManager addResource: self.! ! !AthensCairoSurface methodsFor: 'paints' stamp: 'IgorStasenko 4/12/2013 10:01'! createLinearGradient: aColorRamp start: aStartPoint stop: aStopPoint ^ AthensCairoGradientPaint createLinearGradient: aColorRamp start: aStartPoint stop: aStopPoint ! ! !AthensCairoSurface methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !AthensCairoSurface methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2012 18:05'! clear: clearPaint currentCanvas pathTransform restoreAfter: [ currentCanvas pathTransform loadIdentity. currentCanvas paintMode restoreAfter: [ currentCanvas paintMode source. currentCanvas setPaint: clearPaint; drawShape: (0@0 extent: self extent). ]]. ! ! !AthensCairoSurface methodsFor: 'paints' stamp: 'IgorStasenko 4/27/2012 11:22'! createStrokePaintFor: aPaint ^ AthensCairoStrokePaint new fillPaint: aPaint! ! !AthensCairoSurface methodsFor: 'accessing' stamp: 'FernandoOlivero 1/12/2012 11:55'! status ^ self nbCall: #(int cairo_surface_status (self) ) ! ! !AthensCairoSurface methodsFor: 'private' stamp: 'IgorStasenko 10/17/2012 17:15'! newCanvas "Answer a preinitialized instance of AthensCanvas. Private to receiver and its subclasses, override seldom" ^ self primCreateCanvas surface: self ! ! !AthensCairoSurface methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 12/21/2013 02:17'! displayOnMorphicCanvas: canvas at: aPoint canvas image: self asForm at: aPoint sourceRect: (0@0 extent: self extent ) rule: 34. ! ! !AthensCairoSurface methodsFor: 'creation' stamp: 'FernandoOlivero 3/26/2012 18:47'! createPath: aPathCreatingBlock ^ builder createPath: aPathCreatingBlock ! ! !AthensCairoSurface methodsFor: 'converting' stamp: 'FernandoOlivero 4/19/2012 14:03'! asAthensPaintOn: aCanvas ^ AthensCairoPatternSurfacePaint createForSurface: self. ! ! !AthensCairoSurface methodsFor: 'paints' stamp: 'IgorStasenko 4/27/2012 12:25'! createRadialGradient: colorRamp center: aCenter radius: aRadius focalPoint: fp ^AthensCairoGradientPaint radialBetween: fp extending: 0 and: aCenter extending: aRadius withColorRamp: colorRamp! ! !AthensCairoSurface methodsFor: 'private' stamp: 'IgorStasenko 10/17/2012 17:15'! primCreateCanvas ^self nbCall: #( AthensCairoCanvas cairo_create (self) )! ! !AthensCairoSurface methodsFor: 'rendering dispatch' stamp: 'IgorStasenko 8/30/2013 16:58'! fillRectangle: aRectangle withSolidColor: aColor self loadSolidColor: aColor. currentCanvas newPath; rectangleX: aRectangle left y: aRectangle top width: aRectangle width height: aRectangle height; fill ! ! !AthensCairoSurface methodsFor: 'accessing' stamp: 'IgorStasenko 10/9/2012 19:22'! clear ^ self clear: Color transparent! ! !AthensCairoSurface methodsFor: 'paints' stamp: 'BenjaminVanRyseghem 7/3/2013 13:29'! createFormPaint: aForm "here we should convert form to cairo surface" | newSurface | newSurface := self class fromForm: (aForm asFormOfDepth: 32). ^ newSurface asAthensPaintOn: context ! ! !AthensCairoSurface methodsFor: 'accessing' stamp: 'IgorStasenko 12/20/2011 15:12'! width ^self nbCall: #( int cairo_image_surface_get_width ( self ) ) ! ! !AthensCairoSurface methodsFor: 'caching' stamp: 'IgorStasenko 10/12/2012 03:24'! cacheAt: anObject ifAbsentPut: aBlock "Answer an object from surface's cache identified by anObject, if there is no cached object under such identifier, evaluate a block and put it into cache. Then answer the result of evaluation. A surface using identity comparison for object identifiers. " ^ CairoBackendCache soleInstance at: anObject ifAbsentPut: aBlock! ! !AthensCairoSurface methodsFor: 'accessing' stamp: 'IgorStasenko 12/20/2011 15:19'! getDataPtr "get a pointer to surface bitmap data" ^self nbCall: #( void* cairo_image_surface_get_data ( self ) ) ! ! !AthensCairoSurface methodsFor: 'rendering dispatch' stamp: 'IgorStasenko 8/30/2013 16:58'! loadSolidColor: aColor currentCanvas setSourceR: aColor red g: aColor green b: aColor blue a: aColor alpha; resetDash! ! !AthensCairoSurface methodsFor: 'accessing' stamp: 'IgorStasenko 12/20/2011 15:10'! stride ^self nbCall: #( int cairo_image_surface_get_stride ( self ) ) ! ! !AthensCairoSurface methodsFor: 'caching' stamp: 'IgorStasenko 10/12/2012 03:54'! flushCacheAt: anObject "Flush (delete) any cached value(s) identified by given object, anObject. Do nothing if there's no cached values stored for given object. Answer receiver. A surface using identity comparison for object identifiers. " CairoBackendCache soleInstance removeAt: anObject! ! !AthensCairoSurface methodsFor: 'paints' stamp: 'FernandoOlivero 1/13/2012 20:12'! createSolidColorPaint: aColor ^ AthensCairoSolidPaint new color: aColor! ! !AthensCairoSurface methodsFor: 'paints' stamp: 'IgorStasenko 4/12/2013 10:05'! createLinearGradient: aColorRamp origin: aStart corner: aStop self deprecated: 'Use #createLinearGradient:start:stop: instead' on: '12 April 2013' in: 'ConfigurationOfAthens 2.0'. ^self createLinearGradient: aColorRamp start: aStart stop: aStop! ! !AthensCairoSurface methodsFor: 'accessing' stamp: 'IgorStasenko 12/20/2011 15:18'! extent ^ self width @ self height! ! !AthensCairoSurface methodsFor: 'drawing' stamp: 'IgorStasenko 4/26/2013 15:19'! drawDuring: aBlock "You may draw on receiver only when inside a block and only using provided canvas object. This ensures releasing system resources used after finishing drawing" self checkSession. currentCanvas ifNotNil: [ self attemptToRecurseDrawing ]. [ currentCanvas := context. self privSetDefaults. aBlock value: currentCanvas. self flush. ] ensure: [ currentCanvas := nil. ].! ! !AthensCairoSurface methodsFor: 'private' stamp: 'IgorStasenko 9/3/2013 14:13'! privSetDefaults "reset matrices" currentCanvas pathTransform loadIdentity. currentCanvas paintTransform loadIdentity. currentCanvas paintMode over. ! ! !AthensCairoSurface methodsFor: 'rendering dispatch' stamp: 'IgorStasenko 9/3/2013 12:19'! fillPath: aPath withSolidColor: aColor self loadSolidColor: aColor. currentCanvas newPath; loadPath: aPath; fill ! ! !AthensCairoSurface methodsFor: 'private' stamp: 'IgorStasenko 5/4/2012 18:32'! flush ^self nbCall: #( void cairo_surface_flush (self) )! ! !AthensCairoSurface methodsFor: 'drawing' stamp: ''! attemptToRecurseDrawing ^ self ! ! !AthensCairoSurface methodsFor: 'text support' stamp: 'IgorStasenko 9/2/2012 00:50'! getFreetypeFontRendererFor: aFreetypeFont "answer the same instance, just reset it's font and advance" ^ ftFontRenderer font: aFreetypeFont; advance: 0@0; yourself! ! !AthensCairoSurface methodsFor: 'converting' stamp: 'FernandoOlivero 1/12/2012 12:54'! writeToPng: aFileName self nbCall: #(void cairo_surface_write_to_png (self, String aFileName) ) ! ! !AthensCairoSurface class methodsFor: 'instance creation' stamp: 'IgorStasenko 4/12/2013 09:05'! createFromFile: aFileName ifFailed: aBlock "Right now, this protocol is Cairo backend only. " | surface cstring | cstring := aFileName , (Character value: 0) asString. surface := self primCreateFromFile: cstring. surface isSuccess not ifTrue: [ self destroySurfaceHandle: surface handle value. ^ aBlock cull: surface status ] ifFalse: [ surface initialize ]. ^ surface .! ! !AthensCairoSurface class methodsFor: 'private' stamp: ''! unregisterSurfaceWithId: anAthensCairoSurfaceId self ioUnregisterSurface: anAthensCairoSurfaceId! ! !AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''! createUnlockSurfaceFn " int unlockSurface(int handle, int x, int y, int w, int h); Unlock the bits of a (possibly modified) surface after BitBlt completed. The return value is ignored. The arguments provided specify the dirty region of the surface. If the surface is unmodified all arguments are set to zero. " | fn | fn := NBNativeFunctionGen cdecl: #(int (int handle, int x, int y, int w, int h) ) emit: [:gen :proxy :asm | "do nothing" ]. fn install. ^ fn address! ! !AthensCairoSurface class methodsFor: 'session management' stamp: ''! checkSession uniqueSession == NativeBoost uniqueSessionObject ifFalse: [ self initializeForNewSession ].! ! !AthensCairoSurface class methodsFor: 'private' stamp: ''! ioUnregisterSurface: aCairoSurfaceId " ioUnregisterSurface: Unregister the surface with the given id. Returns true if successful, false otherwise. " self nbCall: #( int ioUnregisterSurface(ulong aCairoSurfaceId) ) module: #SurfacePlugin! ! !AthensCairoSurface class methodsFor: 'private' stamp: ''! testGetSurfaceFormat: handle width: wBuf height: hBuf depth: depthBuf isMSB: isMSBBuf NBFFICallout cdecl: #( int (ulong handle, int* wBuf, int* hBuf, int* depthBuf, int* isMSBBuf) ) emitCall: [:gen :proxy :asm | asm mov: (self dispatchStruct getSurfaceFormatFn) asUImm32 to: asm EAX; call: asm EAX ] ! ! !AthensCairoSurface class methodsFor: 'private' stamp: ''! ioFindSurface: id dispatch: dispPtr handle: handlePtr " int ioFindSurface(int surfaceID, sqSurfaceDispatch *fn, int *surfaceHandle); Find the surface with the given ID, and, optionally, the given set of surface functions. The registered handle is returned in surfaceHandle. Return true if successful (e.g., the surface has been found), false otherwise. " self nbCall: #( bool ioFindSurface(int id, void * dispPtr, int *handlePtr) ) module: #SurfacePlugin! ! !AthensCairoSurface class methodsFor: 'private' stamp: 'FernandoOlivero 1/12/2012 13:02'! primImage: aFormat width: aWidth height: aHeight ^self nbCall: #(AthensCairoSurface cairo_image_surface_create (int aFormat, int aWidth, int aHeight) ) ! ! !AthensCairoSurface class methodsFor: 'private' stamp: ''! destroySurfaceHandle: handle ^self nbCall: #( void cairo_surface_destroy ( ulong handle ) ) ! ! !AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: 'jb 8/9/2013 16:03'! createGetSurfaceFormatFn " int getSurfaceFormat(int handle, int* width, int* height, int* depth, int* isMSB); Return general information about the OS drawing surface. Return true if successful, false otherwise. The returned values describe the basic properties such as width, height, depth and LSB vs. MSB pixels. " | fn | fn := NBNativeFunctionGen cdecl: #( int (int handle, int* width, int* height, int* depth, int* isMSB) ) emit: [:gen :proxy :asm | | callInfo fnPtr | " the handle is a handle to cairo image surface (cairo_surface_t *) " "*width = cairo_image_surface_get_width ( handle )" asm cdeclCall: [:call | call push: (gen arg: #handle). asm mov: (self fnPtr: 'cairo_image_surface_get_width') asUImm32 to: asm EAX; call: asm EAX ] alignment: gen stackAlignment; mov: (gen arg: #width) to: asm EDX; mov: asm EAX to: asm EDX ptr. "*height = cairo_image_surface_get_height ( handle )" asm cdeclCall: [:call | call push: (gen arg: #handle). asm mov: (self fnPtr: 'cairo_image_surface_get_height') asUImm32 to: asm EAX; call: asm EAX ] alignment: gen stackAlignment; mov: (gen arg: #height) to: asm EDX; "work around the bitblt bug which tries to access past the buffer size designated by width*height*depth " dec: asm EAX; mov: asm EAX to: asm EDX ptr. "*depth = 32" asm mov: (gen arg: #depth) to: asm EAX; mov: 32 to: asm EAX ptr32. " *isMSB = false " asm mov: (gen arg: #isMSB) to: asm EAX; mov: 0 to: asm EAX ptr32; "return true" mov: 1 to: asm EAX ]. fn install. ^ fn address! ! !AthensCairoSurface class methodsFor: 'instance creation' stamp: 'IgorStasenko 10/11/2012 18:41'! fromForm: aForm | form surface newBits | form := aForm unhibernate; asFormOfDepth: 32. surface := self extent: aForm extent. "we should convert form bits with premultiplied alpha" newBits := form bits collect:[:pixel | | alpha r g b| alpha := (pixel >> 24) / 255. r := ( (pixel bitAnd: 255) * alpha ) asInteger. g := ( (pixel >>8 bitAnd: 255) * alpha ) asInteger. b := ( (pixel >>16 bitAnd: 255) * alpha ) asInteger. (pixel bitAnd: 16rFF000000) + (b<<16) + (g<<8) + r ]. NativeBoost memCopy: newBits to: surface getDataPtr size: (form width * form height *4). surface markDirty. ^ surface.! ! !AthensCairoSurface class methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !AthensCairoSurface class methodsFor: 'private' stamp: 'IgorStasenko 12/20/2011 15:01'! primWidth: aWidth height: aHeight ^self nbCall: #( AthensCairoSurface cairo_image_surface_create ( CAIRO_FORMAT_ARGB32, int aWidth, int aHeight) )! ! !AthensCairoSurface class methodsFor: 'private' stamp: ''! testSurfacePluginCallbacks | surface wb hb db mb ptr | surface := AthensCairoSurface extent: 800@800. wb := ByteArray new: 4. hb := ByteArray new: 4. db := ByteArray new: 4. mb := ByteArray new: 4. self testGetSurfaceFormat: surface handle width: wb height: hb depth: db isMSB: mb. self assert: (surface width = (wb nbUlongAt: 1)). self assert: (surface height = (hb nbUlongAt: 1)). self assert: (32 = (db nbUlongAt: 1)). self assert: (0 = (mb nbUlongAt: 1)). ptr := self testLockSurface: surface handle pitch: wb x: 0 y: 0 w: 100 h: 100. self assert: (wb nbUlongAt: 1) = surface stride. self assert: ptr = surface getDataPtr! ! !AthensCairoSurface class methodsFor: 'private' stamp: ''! ioRegisterSurface: aCairoSurfaceHandle dispatch: sqSurfaceDispatchPtr surfaceId: idHolder " int ioRegisterSurface(int surfaceHandle, sqSurfaceDispatch *fn, int *surfaceID); Register a new surface with the given handle and the set of surface functions. The new ID is returned in surfaceID. Returns true if successful, false otherwise. " self nbCall: #( bool ioRegisterSurface(ulong aCairoSurfaceHandle, void * sqSurfaceDispatchPtr, int *idHolder) ) module: #SurfacePlugin! ! !AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''! fnPtr: anFnName ^ NativeBoost loadSymbol: anFnName fromModule: self nbLibraryNameOrHandle. ! ! !AthensCairoSurface class methodsFor: 'private' stamp: 'IgorStasenko 5/31/2012 01:50'! destroyContextHandle: aHandle ^self nbCall: #( void cairo_destroy (size_t aHandle) )! ! !AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''! createShowSurfaceFn " int showSurface(int handle, int x, int y, int w, int h); Display the contents of the surface on the actual screen. If ioShowSurface() is called the surface in question represents a Squeak DisplayScreen. " | fn | fn := NBNativeFunctionGen cdecl: #(int (int handle, int x, int y, int w, int h)) emit: [:gen :proxy :asm | "do nothing" asm mov: 1 to: asm EAX ]. fn install. ^ fn address! ! !AthensCairoSurface class methodsFor: 'instance creation' stamp: 'IgorStasenko 3/7/2012 15:32'! extent: anExtent ^ self extent: anExtent format: CAIRO_FORMAT_ARGB32 ! ! !AthensCairoSurface class methodsFor: 'instance creation' stamp: 'IgorStasenko 3/7/2012 15:32'! extent: anExtent format: aFormat ^ ( self primImage: aFormat width: anExtent x height: anExtent y ) initialize ! ! !AthensCairoSurface class methodsFor: 'private' stamp: 'FernandoOlivero 3/29/2012 12:04'! primCreateFromFile: aFileName ^self nbCall: #(AthensCairoSurface cairo_image_surface_create_from_png (char* aFileName)) ! ! !AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''! createLockSurfaceFn " int lockSurface(int handle, int *pitch, int x, int y, int w, int h); Lock the bits of the surface. Return a pointer to the actual surface bits, or NULL on failure. If successful, store the pitch of the surface (e.g., the bytes per scan line). For equal source/dest handles only one locking operation is performed. This is to prevent locking of overlapping areas which does not work with certain APIs (e.g., DirectDraw prevents locking of overlapping areas). A special case for non-overlapping but equal source/dest handle would be possible but we would have to transfer this information over to unlockSurfaces somehow (currently, only one unlock operation is performed for equal source and dest handles). Also, this would require a change in the notion of ioLockSurface() which is right now interpreted as a hint and not as a requirement to lock only the specific portion of the surface. The arguments in ioLockSurface() provide the implementation with an explicit hint what area is affected. It can be very useful to know the max. affected area beforehand if getting the bits requires expensive copy operations (e.g., like a roundtrip to the X server or a glReadPixel op). However, the returned pointer *MUST* point to the virtual origin of the surface and not to the beginning of the rectangle. The promise made by BitBlt is to never access data outside the given rectangle (aligned to 4byte boundaries!!) so it is okay to return a pointer to the virtual origin that is actually outside the valid memory area. The area provided in ioLockSurface() is already clipped (e.g., it will always be inside the source and dest boundingBox) but it is not aligned to word boundaries yet. It is up to the support code to compute accurate alignment if necessary. " | fn | fn := NBNativeFunctionGen cdecl: #(int (int handle, int *pitch, int x, int y, int w, int h) ) emit: [:gen :proxy :asm | | callInfo fnPtr | " the handle is a handle to cairo image surface (cairo_surface_t *) " "*pitch = cairo_image_surface_get_stride ( handle )" asm cdeclCall: [:call | call push: (gen arg: #handle). asm mov: (self fnPtr: 'cairo_image_surface_get_stride') asUImm32 to: asm EAX; call: asm EAX ] alignment: gen stackAlignment; mov: (gen arg: #pitch) to: asm EDX; mov: asm EAX to: asm EDX ptr. " return cairo_image_surface_get_data ()" asm cdeclCall: [:call | call push: (gen arg: #handle). asm mov: (self fnPtr: 'cairo_image_surface_get_data') asUImm32 to: asm EAX; call: asm EAX ] alignment: gen stackAlignment ]. fn install. ^ fn address! ! !AthensCairoSurface class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/20/2011 14:49'! asNBExternalType: gen "use handle ivar to hold my instance (cairo_surface_t)" ^ NBExternalObjectType objectClass: self! ! !AthensCairoSurface class methodsFor: 'private' stamp: ''! findSurface: surfaceId | buf | buf := ByteArray new: 4. "sizeof(int)" (self ioFindSurface: surfaceId handle: buf) ifTrue: [ ^ buf nbUlongAt: 1 ]. ^ nil. ! ! !AthensCairoSurface class methodsFor: 'surface plugin callbacks' stamp: ''! dispatchStruct self checkSession. ^ dispatchStruct! ! !AthensCairoSurface class methodsFor: 'session management' stamp: 'jb 8/9/2013 16:11'! initializeForNewSession | ptr | uniqueSession := NativeBoost uniqueSessionObject. "create a dispatch structure" dispatchStruct := dispatch := SQSurfaceDispatch new. dispatch getSurfaceFormatFn: self createGetSurfaceFormatFn; lockSurfaceFn: self createLockSurfaceFn; unlockSurfaceFn: self createUnlockSurfaceFn; showSurfaceFn: self createShowSurfaceFn. "now we should place this structure to external memory" ptr := NativeBoost allocate: (SQSurfaceDispatch instanceSize). NativeBoost memCopy: dispatch address to: ptr size: (SQSurfaceDispatch instanceSize). dispatch := ptr.! ! !AthensCairoSurface class methodsFor: 'private' stamp: 'IgorStasenko 10/12/2012 03:37'! registerSurface: anAthensCairoSurface "register the cairo surface with surface plugin, so, it can be used directly by bitblt operations. Answer an id and unique session object " | id | self checkSession. id := ByteArray new: 8 "we need 4, but put some more (NBExternalType sizeOf: #int)". (self ioRegisterSurface: anAthensCairoSurface handle value dispatch: dispatch surfaceId: id) ifFalse: [ self error: 'Unable to register surface with SurfacePlugin']. id := id nbLongAt: 1. ^ id! ! !AthensCairoSurface class methodsFor: 'private' stamp: ''! ioFindSurface: id handle: handlePtr " int ioFindSurface(int surfaceID, sqSurfaceDispatch *fn, int *surfaceHandle); Find the surface with the given ID, and, optionally, the given set of surface functions. The registered handle is returned in surfaceHandle. Return true if successful (e.g., the surface has been found), false otherwise. " self nbCall: #( bool ioFindSurface(int id, 0 , int *handlePtr) ) module: #SurfacePlugin! ! !AthensCairoSurface class methodsFor: 'private' stamp: ''! testLockSurface: handle pitch: pBuf x: x y: y w: w h: h NBFFICallout cdecl: #( void * (int handle, int *pBuf, int x, int y, int w, int h) ) emitCall: [:gen :proxy :asm | asm mov: (self dispatchStruct lockSurfaceFn) asUImm32 to: asm EAX; call: asm EAX ] ! ! !AthensCairoSurface class methodsFor: 'instance creation' stamp: 'IgorStasenko 12/20/2011 15:02'! width: aWidth height: aHeight ^ (self primWidth: aWidth height: aHeight) initialize! ! !AthensCairoSurface class methodsFor: 'finalize resources' stamp: 'IgorStasenko 5/31/2012 01:49'! finalizeResourceData: data | handle id contextHandle | handle := data first. id := data second. contextHandle := data third. (self findSurface: id) = handle ifFalse: [ self error: 'surface is not registered with surface plugin'. ]. self unregisterSurfaceWithId: id. self destroyContextHandle: contextHandle. self destroySurfaceHandle: handle. ! ! !AthensCairoSurfaceExamples commentStamp: 'FernandoOlivero 4/18/2012 13:59'! self example1! !AthensCairoSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/31/2012 01:02'! exampleInterop " self exampleInterop Test the interoperability with bitblt. A cairo image surface bits are exposed to bitblt operations via surface plugin. " | surf | surf := self newSurface: 100@100. surf asForm getCanvas fillRectangle: (0@0 corner: 50@50) color: Color red. surf markDirty. surf drawDuring: [:can | can pathTransform loadIdentity. can pathTransform translateX: 30 Y: 30. can pathTransform rotateByDegrees: 35. can setPaint: (Color red). can setShape: (-20@ -20 corner: 20@ 20). 2 timesRepeat: [ can draw. can setPaint: (Color green alpha:0.5)] ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensCairoSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 2/6/2012 15:29'! newSurface: extent ^ AthensCairoSurface extent: extent! ! !AthensCairoText commentStamp: ''! do not use this class. this is subject of change or removal! !AthensCairoText methodsFor: 'drawing' stamp: 'FernandoOlivero 4/7/2012 12:12'! showOn: aCanvas | cString| aCanvas setPathMatrix. cString := self asString copyWith: (Character value: 0). self primShowText: cString on: aCanvas! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/14/2012 18:23'! fontFamily ^ fontFamily! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/14/2012 19:40'! beNormal self fontWeight: CAIRO_FONT_WEIGHT_NORMAL! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/14/2012 18:23'! beBold self fontWeight: CAIRO_FONT_WEIGHT_BOLD! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/14/2012 20:10'! readFrom: aFontDescription self fontFamily: aFontDescription fontFamily. self fontSlant: aFontDescription fontSlant. self fontWeight: aFontDescription fontWeight. self fontSize: aFontDescription fontSize.! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/14/2012 18:23'! beSlantNormal self fontSlant: CAIRO_FONT_SLANT_NORMAL! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/14/2012 18:24'! fontWeight ^ fontWeight! ! !AthensCairoText methodsFor: 'accessing' stamp: 'FernandoOlivero 1/14/2012 18:24'! text ^ text! ! !AthensCairoText methodsFor: 'initialization' stamp: 'FernandoOlivero 3/30/2012 14:49'! initialize super initialize. self beNormal; beSlantNormal. fontSize := 10.! ! !AthensCairoText methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !AthensCairoText methodsFor: 'private' stamp: 'FernandoOlivero 1/25/2012 00:59'! primShowText: aString on: aCanvas self nbCall: #(void cairo_show_text ( cairo_t aCanvas, char * aString) ) ! ! !AthensCairoText methodsFor: 'drawing' stamp: 'FernandoOlivero 3/30/2012 14:49'! loadOn: aCanvas fontFamily notNil ifTrue:[ self primSelectFont: fontFamily slant: fontSlant weight: fontWeight on: aCanvas] . fontSize notNil ifTrue:[ self primSetFontSize: fontSize on: aCanvas ]! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/14/2012 18:23'! fontSize ^ fontSize! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/14/2012 20:00'! fontSlant: anObject anObject isSymbol ifTrue:[ fontSlant := self slantFrom: anObject ] ifFalse:[ fontSlant := anObject ]! ! !AthensCairoText methodsFor: 'private' stamp: 'FernandoOlivero 1/25/2012 01:02'! slantFrom: aSymbol ^ aSymbol caseOf: { [#normal]->[ CAIRO_FONT_SLANT_NORMAL ]. [#italic]->[ CAIRO_FONT_SLANT_ITALIC ]. [#oblique]->[ CAIRO_FONT_SLANT_OBLIQUE ] }! ! !AthensCairoText methodsFor: 'accessing' stamp: 'FernandoOlivero 1/14/2012 18:35'! asString ^ text asString! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/14/2012 18:23'! fontSize: anObject fontSize := anObject! ! !AthensCairoText methodsFor: 'private' stamp: 'FernandoOlivero 1/25/2012 01:03'! weightFrom: aSymbol ^ aSymbol caseOf: { [#normal]->[ CAIRO_FONT_WEIGHT_NORMAL ]. [#bold]->[ CAIRO_FONT_WEIGHT_BOLD ] } ! ! !AthensCairoText methodsFor: 'drawing' stamp: 'FernandoOlivero 4/7/2012 12:12'! drawOn: aCanvas self loadOn: aCanvas. self showOn: aCanvas! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/25/2012 01:03'! fontWeight: anObject anObject isSymbol ifTrue:[ fontWeight := self weightFrom: anObject ] ifFalse:[ fontWeight := anObject ] ! ! !AthensCairoText methodsFor: 'accessing' stamp: 'FernandoOlivero 1/14/2012 18:24'! text: anObject text := anObject! ! !AthensCairoText methodsFor: 'private' stamp: 'FernandoOlivero 1/25/2012 01:00'! primSelectFont: aFontFamily slant: aFontSlant weight: aFontWeight on: aCanvas self nbCall: #(void cairo_select_font_face ( cairo_t aCanvas, char * aFontFamily, cairo_font_slant_t aFontSlant, cairo_font_weight_t aFontWeight) ) ! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/14/2012 19:42'! fontFamily: anObject "CSS2 generic family names: serif, sans-serif, cursive, fantasy, monospace" fontFamily := anObject! ! !AthensCairoText methodsFor: 'private' stamp: 'FernandoOlivero 1/14/2012 18:31'! primSetFontSize: aFontSize on: aCanvas self nbCall: #(void cairo_set_font_size ( cairo_t aCanvas, double aFontSize) ) ! ! !AthensCairoText methodsFor: 'font description' stamp: 'FernandoOlivero 1/14/2012 18:24'! fontSlant ^ fontSlant! ! !AthensCairoText class methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !AthensCairoTransform commentStamp: ''! i implement AthensTransform protocol using cairo-specific functions.! !AthensCairoTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/7/2012 13:55'! restoreAfter: aBlock self save. aBlock ensure: [ self restore ].! ! !AthensCairoTransform methodsFor: 'primitives' stamp: 'IgorStasenko 12/21/2011 13:43'! primTransformX: x Y: y ^self nbCall: #( void cairo_user_to_device (AthensCairoCanvas canvas, NBFloatPtr x, NBFloatPtr y) ) ! ! !AthensCairoTransform methodsFor: 'primitives' stamp: 'FernandoOlivero 1/14/2012 00:32'! restore ^ self nbCall: #(void cairo_restore(AthensCairoCanvas canvas)) ! ! !AthensCairoTransform methodsFor: 'transformations' stamp: 'FernandoOlivero 1/14/2012 00:38'! translateBy: aPoint self translateX: aPoint x Y: aPoint y ! ! !AthensCairoTransform methodsFor: 'transformations' stamp: 'FernandoOlivero 1/15/2012 19:39'! moveTo: aPoint self moveToX: aPoint x asFloat Y: aPoint y asFloat! ! !AthensCairoTransform methodsFor: 'transformations' stamp: 'IgorStasenko 12/20/2011 16:45'! rotateByDegrees: angle ^ self rotateByRadians: angle degreesToRadians! ! !AthensCairoTransform methodsFor: 'initializing' stamp: 'IgorStasenko 12/20/2011 16:43'! canvas: aCairoCanvas canvas := aCairoCanvas! ! !AthensCairoTransform methodsFor: 'primitives' stamp: 'IgorStasenko 12/20/2011 16:44'! scaleX: fx Y: fy ^self nbCall: #( void cairo_scale (AthensCairoCanvas canvas, double fx, double fy)) ! ! !AthensCairoTransform methodsFor: 'transformations' stamp: 'FernandoOlivero 1/15/2012 16:49'! scaleBy: aScalarOrPoint | double | aScalarOrPoint isPoint ifTrue:[ self scaleX: aScalarOrPoint x asFloat Y: aScalarOrPoint y asFloat ] ifFalse:[ double := aScalarOrPoint asFloat. self scaleX: double Y: double ]. ! ! !AthensCairoTransform methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !AthensCairoTransform methodsFor: 'primitives' stamp: 'IgorStasenko 12/20/2011 16:45'! rotateByRadians: angle ^self nbCall: #( void cairo_rotate (AthensCairoCanvas canvas, double angle)) ! ! !AthensCairoTransform methodsFor: 'primitives' stamp: 'FernandoOlivero 1/14/2012 00:32'! save ^ self nbCall: #(void cairo_save (AthensCairoCanvas canvas)) ! ! !AthensCairoTransform methodsFor: 'vector-transform' stamp: 'IgorStasenko 12/21/2011 13:42'! transform: aPoint | x y | "since we use pointers to floats we must create a copy of original values to not scratch them" x := aPoint x asFloat shallowCopy. y := aPoint y asFloat shallowCopy. self primTransformX: x Y: y. ^ x @ y! ! !AthensCairoTransform methodsFor: 'primitives' stamp: 'IgorStasenko 12/20/2011 16:54'! translateX: px Y: py ^self nbCall: #( void cairo_translate (AthensCairoCanvas canvas, double px, double py)) ! ! !AthensCairoTransform methodsFor: 'primitives' stamp: 'FernandoOlivero 1/14/2012 20:31'! moveToX: px Y: py ^self nbCall: #( void cairo_move_to (AthensCairoCanvas canvas, double px, double py)) ! ! !AthensCairoTransform methodsFor: 'primitives' stamp: 'IgorStasenko 12/20/2011 16:47'! loadIdentity ^self nbCall: #( void cairo_identity_matrix (AthensCairoCanvas canvas) ) ! ! !AthensCairoTransform class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/20/2011 16:49'! for: cairoCanvas ^ self new canvas: cairoCanvas! ! !AthensCairoTransform class methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !AthensCanvas commentStamp: ''! The Athens canvas is a central object which is used to performs drawings on a surface. Please note, that Athens does not allows you to instantiate canvas directly, instead you obtain a ready for use instance as an argument in #drawDuring: message, sent to athens surface: surface drawDuring: [:canvas | .... ] Using canvas outside a #drawDuring: method is highly discouraged. Doing so may lead to unpredicted behavior/data corruption/image crash.! !AthensCanvas methodsFor: 'initialization' stamp: 'IgorStasenko 3/22/2011 11:13'! initializeWithSurface: anAthensSurface surface := anAthensSurface! ! !AthensCanvas methodsFor: 'transformation matrices' stamp: 'IgorStasenko 11/19/2012 05:14'! pathTransform "Answer the path transformation matrix controller. The answered object should conform to AthensTransform public protocol." ^ surface pathTransform ! ! !AthensCanvas methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/11/2012 15:23'! morphicDrawString: string in: rect font: aFont color: aColor self pathTransform restoreAfter: [ self pathTransform translateX: rect left Y: rect top. self clipBy: (0@0 corner: rect extent) during: [ self setFont: aFont. self pathTransform translateX: 0 Y: aFont getPreciseAscent. self setPaint: aColor; drawString: string. ] ]! ! !AthensCanvas methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 4/21/2011 14:27'! fullDrawMorph: aMorph "Hook method for potential other canvases. In the core, this method looks supefluous but PostscriptCanvases and other canvases can specialized it for Morph rendering. Therefore it should not be merged with fullDraw:." aMorph fullDrawOnAthensCanvas: self! ! !AthensCanvas methodsFor: 'accessing' stamp: 'FernandoOlivero 2/14/2012 12:12'! paint ^ paint ! ! !AthensCanvas methodsFor: 'accessing' stamp: 'IgorStasenko 5/6/2013 05:41'! setShape: anObject "Set the current shape of receiver" shape := anObject asAthensShapeOn: self.! ! !AthensCanvas methodsFor: 'accessing' stamp: 'IgorStasenko 11/19/2012 05:14'! paintMode "Answer the current paint mode controller. The answered object should conform to AthensPaintMode public protocol." ^ paintMode! ! !AthensCanvas methodsFor: 'paint' stamp: 'IgorStasenko 11/19/2012 05:11'! setStrokePaint: aPaint "use paint as stroke paint, note conversion to #asStrokePaintOn:" paint := (aPaint asAthensPaintOn: self) asStrokePaintOn: self. ^ paint! ! !AthensCanvas methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/11/2012 15:25'! morphicDrawString: string at: position font: aFont color: aColor self pathTransform restoreAfter: [ self pathTransform translateX: position x Y: position y + aFont getPreciseAscent. self setFont: aFont; setPaint: aColor; drawString: string. ] ! ! !AthensCanvas methodsFor: 'masking' stamp: 'IgorStasenko 3/27/2011 18:06'! enableMask ^ surface enableMask! ! !AthensCanvas methodsFor: 'paths' stamp: 'IgorStasenko 11/19/2012 05:21'! createPath: aPathCreatingBlock "Create new path. A path creating block should be a monadic block, which will get a path builder instance as argument. See AthensPathBuilder for available protocol. The resulting path object can be later used for drawing. " ^ surface createPath: aPathCreatingBlock! ! !AthensCanvas methodsFor: 'masking' stamp: 'IgorStasenko 3/27/2011 18:06'! disableMask ^ surface disableMask! ! !AthensCanvas methodsFor: 'drawing' stamp: 'IgorStasenko 11/19/2012 05:18'! draw: anObject "A generic dispatch method to draw anObject on receiver. the object should understand #drawOnAthensCanvas: message" ^ anObject drawOnAthensCanvas: self! ! !AthensCanvas methodsFor: 'caching' stamp: 'IgorStasenko 10/12/2012 03:20'! cacheAt: anObject ifAbsentPut: aBlock ^ surface cacheAt: anObject ifAbsentPut: aBlock! ! !AthensCanvas methodsFor: 'accessing' stamp: 'IgorStasenko 11/19/2012 05:10'! surface "Answer an Athens surface, to which receiver is bound to" ^ surface! ! !AthensCanvas methodsFor: 'drawing text' stamp: 'IgorStasenko 8/30/2013 16:14'! setFont: aFont "Set the current font of receiver. Font object should answer a glyph renderer instance, compatible with glyph renderer protocol" ^ fontRenderer := aFont glyphRendererOn: surface.! ! !AthensCanvas methodsFor: 'clipping' stamp: 'IgorStasenko 4/21/2011 14:40'! isVisible: aRectangle "check if rectangle are not fully clipped by current clipping coordinates" ^ true! ! !AthensCanvas methodsFor: 'caching' stamp: 'IgorStasenko 10/12/2012 03:56'! flushCacheAt: anObject "Flush (delete) any cached value(s) identified by given object, anObject. A surface using identity comparison for object identifiers. Answer receiver. " surface removeCacheAt: anObject! ! !AthensCanvas methodsFor: 'paths' stamp: 'IgorStasenko 3/22/2011 22:04'! createRectanglePath: aRectangle ^ surface createRectanglePath: aRectangle ! ! !AthensCanvas methodsFor: 'drawing' stamp: 'IgorStasenko 11/19/2012 05:17'! drawShape: anObject "A convenience method, which sets the current shape to anObject and then fills it with currently selected paint" self setShape: anObject. self draw. ! ! !AthensCanvas methodsFor: 'masking' stamp: 'IgorStasenko 3/27/2011 18:31'! clearMask: aShape "set mask pixels to 0 for all pixels covered by shape, aShape" ^ aShape paintFillsUsing: surface clearMaskPaint on: self ! ! !AthensCanvas methodsFor: 'drawing' stamp: 'IgorStasenko 7/3/2013 16:28'! draw "Fill the currently selected shape with currently selected paint" ^ shape paintFillsUsing: paint on: self ! ! !AthensCanvas methodsFor: 'drawing text' stamp: 'IgorStasenko 9/1/2012 22:08'! drawString: aString from: start to: end "Draw a portion of string using currently selected font. Answer a total advance of rendered portion" ^ fontRenderer renderCharacters: aString from: start to: end! ! !AthensCanvas methodsFor: 'masking' stamp: 'IgorStasenko 3/27/2011 18:35'! setMask: aShape "set mask pixels to 1 for all pixels covered by shape, aShape" ^ aShape paintFillsUsing: surface setMaskPaint on: self ! ! !AthensCanvas methodsFor: 'transformation matrices' stamp: 'IgorStasenko 11/19/2012 05:14'! paintTransform "Answer the paint transformation matrix controller. The answered object should conform to AthensTransform public protocol." ^ surface paintTransform ! ! !AthensCanvas methodsFor: 'drawing text' stamp: 'IgorStasenko 9/1/2012 22:08'! drawString: aString "Draw a string using currently selected font. Answer a total advance of rendered string " ^ fontRenderer renderCharacters: aString from: 1 to: aString size.! ! !AthensCanvas methodsFor: 'paint' stamp: 'IgorStasenko 11/19/2012 05:11'! setPaint: aPaint "set the current paint of receiver" paint = aPaint ifTrue:[ ^ paint ]. paint := aPaint asAthensPaintOn: self. ^ paint.! ! !AthensCanvas methodsFor: 'clipping' stamp: 'IgorStasenko 4/21/2011 14:47'! clipBy: aRectangle during: aBlock " Set a clipping rectangle during drawing operations performed in a block. Note that clipping rectangle are intetersected with currently active clipping rectangle " ^surface clipBy: aRectangle during: aBlock! ! !AthensCanvas class methodsFor: 'private' stamp: 'IgorStasenko 3/21/2011 00:17'! on: aSurface ^ self basicNew initializeWithSurface: aSurface! ! !AthensCanvas class methodsFor: 'private' stamp: 'IgorStasenko 3/21/2011 00:19'! new "use #on: instead" self shouldNotImplement! ! !AthensCharacterSpan commentStamp: 'IgorStasenko 2/6/2012 16:17'! A text command to render a character span containing the range of characters for with same attributes! !AthensCharacterSpan methodsFor: 'rendering' stamp: 'IgorStasenko 10/17/2011 12:52'! renderOn: renderer renderer renderCharactersFrom: start to: stop! ! !AthensCharacterSpan methodsFor: 'accessing' stamp: 'IgorStasenko 11/10/2011 10:31'! splitAt: position | newSpan | "split receiver on two character spans " " position points to first character which should be included in newly created span " position == start ifTrue: [ ^ self ]. (position < start or: [ position > stop ]) ifTrue: [ self error: 'invalid position' ]. newSpan := self class new start: position; stop: stop. stop := position - 1. self insert: newSpan.! ! !AthensCharacterSpan methodsFor: 'accessing' stamp: 'IgorStasenko 10/17/2011 12:02'! stop ^ stop! ! !AthensCharacterSpan methodsFor: 'accessing' stamp: 'IgorStasenko 10/17/2011 12:02'! stop: anObject stop := anObject! ! !AthensCharacterSpan methodsFor: 'accessing' stamp: 'IgorStasenko 10/17/2011 12:02'! start: anObject start := anObject! ! !AthensCharacterSpan methodsFor: 'accessing' stamp: 'IgorStasenko 10/17/2011 12:02'! start ^ start! ! !AthensCloseSegment commentStamp: ''! i represent close segment (when user issuing #close command to path builder)! !AthensCloseSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 04:40'! accept: aVisitor ^ aVisitor closeSegment: self! ! !AthensCloseSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 05:22'! sendCommandTo: aBuilder ^ aBuilder close ! ! !AthensColorChange commentStamp: 'IgorStasenko 2/6/2012 16:17'! A command to change the current font color! !AthensColorChange methodsFor: 'rendering' stamp: 'IgorStasenko 10/17/2011 12:51'! renderOn: renderer renderer setCurrentColor: color! ! !AthensColorChange methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2011 16:58'! color: anObject color := anObject! ! !AthensColorChange methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2011 16:58'! color ^ color! ! !AthensCompositePaint commentStamp: ''! i am used to convert CompositeFillStyle into paint, used in Morphic.! !AthensCompositePaint methodsFor: 'drawing' stamp: 'IgorStasenko 8/30/2013 16:35'! athensFillRectangle: aRect on: anAthensCanvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " paints do: [:paint | paint athensFillRectangle: aRect on: anAthensCanvas ] ! ! !AthensCompositePaint methodsFor: 'drawing' stamp: 'IgorStasenko 8/30/2013 16:32'! athensFillPath: athensPath on: anAthensCanvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " paints do: [:paint | paint athensFillPath: athensPath on: anAthensCanvas ] ! ! !AthensCompositePaint methodsFor: 'initialize-release' stamp: 'IgorStasenko 10/9/2012 19:07'! fromFillStyles: fillStyles on: aCanvas paints := fillStyles collect: [:each | each asAthensPaintOn: aCanvas ]! ! !AthensCubicBezier commentStamp: ''! Cubic bezier with 4 control points encapsulation. Main purpose of this class is to keep subdivision logic in clean and separate place! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! x4: anObject x4 := anObject! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! x3 ^ x3! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! x4 ^ x4! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! x3: anObject x3 := anObject! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! y2 ^ y2! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! y3 ^ y3! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! x1 ^ x1! ! !AthensCubicBezier methodsFor: 'subdivision' stamp: 'IgorStasenko 4/24/2013 16:21'! subdivideAt: t do: aBinaryBlock | x12 y12 x23 y23 x34 y34 x1223 y1223 x2334 y2334 xsplit ysplit | x12 := x1 interpolateTo: x2 at: t. y12 := y1 interpolateTo: y2 at: t. x23 := x2 interpolateTo: x3 at: t. y23 := y2 interpolateTo: y3 at: t. x34 := x3 interpolateTo: x4 at: t. y34 := y3 interpolateTo: y4 at: t. x1223 := x12 interpolateTo: x23 at: t. x2334 := x23 interpolateTo: x34 at: t. y1223 := y12 interpolateTo: y23 at: t. y2334 := y23 interpolateTo: y34 at: t. xsplit := x1223 interpolateTo: x2334 at: t. ysplit := y1223 interpolateTo: y2334 at: t. ^ aBinaryBlock value: "p1 - p12 - p1223 - psplit" (self copy x2: x12; y2: y12; x3: x1223; y3: y1223; x4: xsplit; y4: ysplit ) value: "psplit - p2334 - p34 - p4" (self copy x1: xsplit; y1: ysplit; x2: x2334; y2: y2334; x3: x34; y3: y34 ) ! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! y3: anObject y3 := anObject! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! y4 ^ y4! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! y1 ^ y1! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! x2: anObject x2 := anObject! ! !AthensCubicBezier methodsFor: 'subdivision' stamp: 'IgorStasenko 4/29/2013 21:42'! recursiveSubDiv: flattener level: level | dx dy d2 d3 da1 da2 k f1 f2 | " Try to approximate the full cubic curve by a single straight line " level > flattener subdivisionLimit ifTrue: [ ^ self ]. dx := x4-x1. dy := y4-y1. d2 := ((x2 - x4) * dy - ((y2 - y4) * dx)) abs. d3 := ((x3 - x4) * dy - ((y3 - y4) * dx)) abs. f1 := d2 > flattener curveCollinearityEpsilon. f2 := d3 > flattener curveCollinearityEpsilon. f1 ifTrue: [ f2 ifTrue: [ " Regular case " (d2 + d3) squared <= (flattener distanceToleranceSquared * (dx squared + dy squared)) ifTrue: [ "If the curvature doesn't exceed the distance_tolerance value we tend to finish subdivisions." " flattener accountForAngleTolerance ifFalse: [ ^ flattener lineToX: (x2 interpolateTo: x3 at: 0.5) y: (y2 interpolateTo: y3 at: 0.5) ]. " "Angle & Cusp Condition" k := (y3-y2) arcTan: (x3 - x2). da1 := (k - ((y2-y1) arcTan: (x2-x1))) abs. da2 := ((y4-y3 arcTan: x4-x3) - k) abs. da1 >= Float pi ifTrue: [ da1 := Float pi*2 - da1 ]. da2 >= Float pi ifTrue: [ da2 := Float pi*2 - da2 ]. (da1 + da2) < flattener angleTolerance ifTrue: [ " Finally we can stop the recursion " ^ flattener lineToX: (x2 interpolateTo: x3 at: 0.5) y: (y2 interpolateTo: y3 at: 0.5) ]. (flattener overCuspLimit: da1) ifTrue: [ ^ flattener lineToX: x2 y: y2 ]. (flattener overCuspLimit: da2) ifTrue: [ ^ flattener lineToX: x3 y: y3 ]. ] ] ifFalse: [ "p1,p3,p4 are collinear, p2 is significant" (d2 squared <= (flattener distanceToleranceSquared * (dx squared + dy squared) ) ) ifTrue: [ flattener accountForAngleTolerance ifFalse: [ ^ flattener lineToX: (x2 interpolateTo: x3 at: 0.5) y: (y2 interpolateTo: y3 at: 0.5) ]. "Angle Condition" da1 := ((y3-y2 arcTan: (x3-x2)) - (y2-y1 arcTan:(x2-x1))) abs. da1 >= Float pi ifTrue: [ da1 := Float pi * 2 - da1 ]. da1 < flattener angleTolerance ifTrue: [ ^ flattener lineToX: x2 y: y2; lineToX: x3 y: y3 ]. (flattener overCuspLimit: da1) ifTrue: [ ^ flattener lineToX: x2 y: y2 ] ] ] ] ifFalse: [ f2 ifTrue: [ "p1,p2,p4 are collinear, p3 is significant " (d3 squared <= (flattener distanceToleranceSquared * (dx squared + dy squared) ) ) ifTrue: [ flattener accountForAngleTolerance ifFalse: [ ^ flattener lineToX: (x2 interpolateTo: x3 at: 0.5) y: (y2 interpolateTo: y3 at: 0.5) ]. "Angle Condition" da1 := ((y4-y3 arcTan: (x4-x3)) - (y3-y2 arcTan:(x3-x2))) abs. da1 >= Float pi ifTrue: [ da1 := Float pi * 2 - da1 ]. da1 < flattener angleTolerance ifTrue: [ ^ flattener lineToX: x2 y: y2; lineToX: x3 y: y3 ]. (flattener overCuspLimit: da1) ifTrue: [ ^ flattener lineToX: x3 y: y3 ] ] ] ifFalse: [ "All collinear OR p1==p4 " k := dx*dx + (dy*dy). (k = 0.0) ifTrue: [ d2 := (x1-x2) squared + (y1-y2) squared. d3 := (x3-x4) squared + (y3-y4) squared ] ifFalse: [ k := 1 / k. da1 := x2 - x1. da2 := y2 - y1. d2 := k * (da1*dx + (da2*dy)). da1 := x3 - x1. da2 := y3 - y1. d3 := k * (da1*dx + (da2*dy)). (d2 > 0.0 and: [ d2 < 1.0 and: [d3>0.0 and: [d3 < 1.0]]]) ifTrue: [ " Simple collinear case, 1---2---3---4 We can leave just two endpoints" ^ self ]. d2 <= 0.0 ifTrue: [ d2 := (x1-x2) squared + (y1-y2) squared ] ifFalse: [ d2 >= 1.0 ifTrue: [ d2 := (x2-x4) squared + (y2-y4) squared ] ifFalse: [ d2 := (x2 - x1 - (d2*dx)) squared + (y2 - y1 - (d2*dy)) squared ]]. d3 <= 0.0 ifTrue: [ d3 := (x3-x1) squared + (y3-y1) squared ] ifFalse: [ d3 >= 1.0 ifTrue: [ d3 := (x3-x4) squared + (y3-y4) squared ] ifFalse: [ d3 := (x3 - x1 - (d3*dx)) squared + (y3-y1- (d3*dy)) squared ]]. ]. (d2 > d3) ifTrue: [ (d2 < flattener distanceToleranceSquared) ifTrue: [ ^ flattener lineToX: x2 y: y2 ] ] ifFalse: [ (d3 < flattener distanceToleranceSquared ) ifTrue: [ ^ flattener lineToX: x3 y: y3 ] ]. ] ]. self subdivideAt: 0.5 do: [ :b1 :b2 | b1 recursiveSubDiv: flattener level: level +1. b2 recursiveSubDiv: flattener level: level +1. ]. ! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! x1: anObject x1 := anObject! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! x2 ^ x2! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! y1: anObject y1 := anObject! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! y4: anObject y4 := anObject! ! !AthensCubicBezier methodsFor: 'accessing' stamp: 'IgorStasenko 4/26/2013 17:07'! y2: anObject y2 := anObject! ! !AthensCubicSegment commentStamp: 'IgorStasenko 3/7/2012 13:32'! i represent a cubic Bezier path segment! !AthensCubicSegment methodsFor: 'accessing' stamp: 'JochenRick 1/8/2014 08:11'! via2reflected ^self endPoint * 2 - via2! ! !AthensCubicSegment methodsFor: 'accessing' stamp: 'FernandoOlivero 2/14/2012 08:17'! from: origin via: controlPoint and: secondControlPoint to: destination via1:= controlPoint. via2 := secondControlPoint. to := destination.! ! !AthensCubicSegment methodsFor: 'accessing' stamp: 'FernandoOlivero 2/14/2012 08:09'! via2 ^ via2! ! !AthensCubicSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 04:39'! accept: aVisitor ^ aVisitor cubicBezierSegment: self! ! !AthensCubicSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 05:22'! sendCommandTo: aBuilder ^ aBuilder curveVia: via1 and: via2 to: to ! ! !AthensCubicSegment methodsFor: 'accessing' stamp: 'FernandoOlivero 2/14/2012 08:09'! via1 ^ via1! ! !AthensCubicSegment methodsFor: 'accessing' stamp: 'FernandoOlivero 2/14/2012 08:05'! to ^ to! ! !AthensCubicSegment methodsFor: 'accessing' stamp: 'FernandoOlivero 2/14/2012 11:39'! endPoint ^ to! ! !AthensCubicSegment methodsFor: 'testing' stamp: 'JochenRick 1/8/2014 06:32'! isCubic ^true! ! !AthensCurveFlattener commentStamp: ''! This converter flattens all curves by converting them to series of lines. This means that path can be rendered using simple polygon rendering technique and nothing else.! !AthensCurveFlattener methodsFor: 'path commands' stamp: 'IgorStasenko 4/18/2013 21:46'! lineTo: aPoint endPoint := aPoint. ^ dest lineTo: aPoint! ! !AthensCurveFlattener methodsFor: 'accessing' stamp: 'IgorStasenko 4/18/2013 17:56'! toleranceMultiplier: aToleranceMultiplier " A tolerance multiplier is a number .. which if = 1 , the default error tolerance is used, if > 1 you will get more coarse approximation if < 1 you will get more finer approximation " lengthTolerance := aToleranceMultiplier. lengthToleranceSquared := lengthTolerance squared. ! ! !AthensCurveFlattener methodsFor: 'path commands' stamp: 'IgorStasenko 4/18/2013 21:47'! curveVia: via to: end | pt1 pt2 pt3 | pt1 := transform transform: endPoint. pt2 := transform transform: via. pt3 := transform transform: end. endPoint := end. self flattenQuadBezier: pt1 x y1: pt1 y x2: pt2 x y2: pt2 y x3: pt3 x y3: pt3 y. ! ! !AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: 'IgorStasenko 4/29/2013 21:32'! overCuspLimit: angleInRadians "if(m_cusp_limit !!= 0.0) { if(da1 > m_cusp_limit) { ^ angleInRadians > 1.01" ^ false. ! ! !AthensCurveFlattener methodsFor: 'accessing' stamp: 'IgorStasenko 4/18/2013 21:59'! defaultTolerance ^ 1! ! !AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: 'IgorStasenko 4/25/2013 01:14'! lineToX: trX y: trY ^ dest lineTo: (self inverseTransform: trX @ trY) ! ! !AthensCurveFlattener methodsFor: 'helpers' stamp: 'IgorStasenko 4/18/2013 18:06'! inverseTransform: aPoint ^ transform inverseTransform: aPoint! ! !AthensCurveFlattener methodsFor: 'path commands' stamp: 'IgorStasenko 4/18/2013 18:04'! moveTo: aPoint contourStartPt := endPoint := aPoint. ^ dest moveTo: aPoint! ! !AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: 'IgorStasenko 4/29/2013 21:48'! accountForAngleTolerance " It's important only when we want to draw an equidistant curve, that is, a stroke of considerable width. If we don't need to draw a stroke or the stroke width is one pixel or less, the distance criterion works quite well. " ^ false.! ! !AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: 'IgorStasenko 5/2/2013 17:43'! distanceToleranceSquared ^ self lengthToleranceSquared ! ! !AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: 'IgorStasenko 4/29/2013 21:48'! angleTolerance ^ CurveAngleToleranceEpsilon ! ! !AthensCurveFlattener methodsFor: 'initialize-release' stamp: 'IgorStasenko 4/18/2013 17:58'! initialize super initialize. transform := AthensAffineTransform new. "identity" self toleranceMultiplier: self defaultTolerance! ! !AthensCurveFlattener methodsFor: 'path commands' stamp: 'IgorStasenko 4/26/2013 17:34'! curveVia: via1 and: via2 to: end | pt1 pt2 pt3 pt4 curve | pt1 := transform transform: endPoint. pt2 := transform transform: via1. pt3 := transform transform: via2. pt4 := transform transform: end. endPoint := end. curve := AthensCubicBezier new x1: pt1 x; y1: pt1 y; x2: pt2 x; y2: pt2 y; x3: pt3 x; y3: pt3 y; x4: pt4 x; y4: pt4 y. curve recursiveSubDiv: self level: 0. self lineTo: endPoint. ! ! !AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: 'IgorStasenko 4/25/2013 00:59'! curveCollinearityEpsilon ^ CurveCollinearityEpsilon ! ! !AthensCurveFlattener methodsFor: 'public API' stamp: 'ClementBera 6/28/2013 10:29'! flattenPath: aPath transform: aTransformation "This is an entry point for flattening path. An additional argument, transform is an Affine matrix, used to map path geometry to screen, and therefore used to calculate the error tolerance for path subdivisions" ^ self flattenPath: aPath transform: aTransformation toleranceMultiplier: 1 ! ! !AthensCurveFlattener methodsFor: 'helpers' stamp: 'IgorStasenko 4/18/2013 23:34'! flattenQuadBezier: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3 "Recursively subdive quadric bezier curve as long as #isFlatBezier.. answers false " "The points here is unboxed intentionally to avoid generating extra garbage (which contributes to performance loss)" (self isFlatQuadBezier: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3) ifTrue: [ | midx midy | midx := (x2 + x1 + x2+x3) * 0.25 . "mid ( mid(pt1,pt2), mid(pt2,pt3)) " midy := (y2 + y1 + y2+y3) * 0.25 . dest lineTo: (self inverseTransform: midx @ midy); lineTo: (self inverseTransform: x3 @ y3) " dest lineTo: (self inverseTransform: x2 @ y2); lineTo: (self inverseTransform: x3 @ y3) " ] ifFalse: [ | x12 y12 x23 y23 x123 y123 | "calculate midpoints of line segments " x12 := (x1 + x2) * 0.5. y12 := (y1 + y2) * 0.5 . x23 := (x2 + x3) * 0.5 . y23 := (y2 + y3) * 0.5 . x123 := (x12 + x23) * 0.5. y123 := (y12 + y23) * 0.5. self flattenQuadBezier: x1 y1: y1 x2: x12 y2: y12 x3: x123 y3: y123. self flattenQuadBezier: x123 y1: y123 x2: x23 y2: y23 x3: x3 y3: y3. ] ! ! !AthensCurveFlattener methodsFor: 'accessing' stamp: 'IgorStasenko 4/18/2013 17:49'! lengthToleranceSquared ^ lengthToleranceSquared! ! !AthensCurveFlattener methodsFor: 'helpers' stamp: 'IgorStasenko 4/19/2013 22:17'! flattenCubicBezier: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3 x4: x4 y4: y4 ! ! !AthensCurveFlattener methodsFor: 'accessing' stamp: 'IgorStasenko 4/18/2013 17:49'! lengthTolerance ^ lengthTolerance! ! !AthensCurveFlattener methodsFor: 'visiting' stamp: 'IgorStasenko 4/18/2013 17:24'! quadricBezierSegment: segment | pt1 pt2 pt3 | pt1 := transform transform: endPoint. pt2 := transform transform: segment via. pt3 := transform transform: segment endPoint. endPoint := segment endPoint. self flattenQuadBezier: pt1 x y1: pt1 y x2: pt2 x y2: pt2 y x3: pt3 x y3: pt3 y. ! ! !AthensCurveFlattener methodsFor: 'subdivision callbacks' stamp: 'IgorStasenko 5/2/2013 17:43'! subdivisionLimit "max number of recursive subdivisions for single curve" ^ SubdivisionLimit ! ! !AthensCurveFlattener methodsFor: 'accessing' stamp: 'IgorStasenko 4/18/2013 17:56'! transform: aTransform " - transform is an Affine matrix, used to map path geometry to screen, and therefore used to calculate the error tolerance for path subdivisions - a tolerance multiplier is a number .. which if = 1 , the default error tolerance is used, if > 1 you will get more coarse approximation if < 1 you will get more finer approximation " transform := aTransform. ! ! !AthensCurveFlattener methodsFor: 'public API' stamp: 'IgorStasenko 4/18/2013 17:48'! flattenPath: aPath transform: aTransform toleranceMultiplier: aToleranceMultiplier "This is an entry point for flattening path (converting all curves into line segments by approximating them). - transform is an Affine matrix, used to map path geometry to screen, and therefore used to calculate the error tolerance for path subdivisions - a tolerance multiplier is a number .. which if = 1 , the default error tolerance is used, if > 1 you will get more coarse approximation if < 1 you will get more finer approximation " transform := aTransform. lengthTolerance := aToleranceMultiplier. lengthToleranceSquared := lengthTolerance squared. ! ! !AthensCurveFlattener methodsFor: 'helpers' stamp: 'IgorStasenko 4/18/2013 22:33'! isFlatQuadBezier: x1 y1: y1 x2: x2 y2: y2 x3: x3 y3: y3 | dx dy d da | dx := x3-x1. dy := y3-y1. "This is the area of triangle enclosing curve * 2" d := (((x2 - x3) * dy) - ((y2 - y3) * dx)) abs. d > (self lengthToleranceSquared ) ifTrue: [ "Non-collinear case (regular one)" | dot | "if dot product is close to zero, that means we having flat curve" dot := ( (x2-x1)*(x2-x3) + ((y1-y2)*(y2-y3)) ) abs. dot < (self lengthToleranceSquared * 0.5 ) ifTrue: [ ^ true ]. ] ifFalse: [ "collinear" da := dx*dx + (dy*dy). da = 0 "end points coincide" ifTrue: [ d := (x1-x2) squared + (y1-y2) squared "pointy case" ] ifFalse: [ "the control point lies on line between endpoints?" d := ((x2 - x1)*dx + ((y2 - y1)*dy)) / da. (d > 0.0 and: [ d < 1.0 ] ) ifTrue: [ "Simple collinear case, 1---2---3" ^ true ]. d <= 0.0 ifTrue: [ d := (x1-x2) squared + (y1-y2) squared ] ifFalse: [ d >= 1.0 ifTrue: [ d:= (x2-x3) squared + (y2-y3) squared ] ifFalse: [ d:= (x2 - x1 - (d*dx)) squared + (y2 - y1 - (d*dy)) squared ] ]. ]. d < (self lengthToleranceSquared) ifTrue: [ ^ true ] ]. ^ false! ! !AthensCurveFlattener class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/26/2013 17:40'! initialize CurveCollinearityEpsilon := 1e-30 asFloat. CurveDistanceEpsilon := 1e-30 asFloat. CurveAngleToleranceEpsilon := 0.01. SubdivisionLimit := 10.! ! !AthensDemoMorph commentStamp: ''! self new openInWorld inspect ---- Use self nextFigure/prevFigure in inpector to change the rendered figure. You can find an implementation of each figure in corresponding #figure<#>: method! !AthensDemoMorph methodsFor: 'accessing' stamp: ''! nextFigure current := current + 1. current > self figures size ifTrue: [ current := 1 ].! ! !AthensDemoMorph methodsFor: 'figures' stamp: 'FernandoOlivero 4/19/2012 14:38'! figure9: aCanvas | pt ellipsePath patternPaint | ellipsePath := aCanvas createPath: [ :builder | builder moveTo: 10@200; cwArcTo: 360@0 angle: Float pi ; lineTo: -100@180; lineTo: -150@ -0; lineTo: -110@ -180]. aCanvas setPaint: Color black. aCanvas drawShape: ellipsePath. aCanvas paintTransform loadIdentity. aCanvas paintTransform scaleBy: ((frame/200) sin abs)*3. patternPaint := aCanvas setPaint: esugBallon . patternPaint setExtend: #None. aCanvas draw.! ! !AthensDemoMorph methodsFor: 'drawing' stamp: 'IgorStasenko 3/30/2012 16:52'! wheelColor ^ Color brown darker! ! !AthensDemoMorph methodsFor: 'accessing' stamp: ''! defaultExtent ^ 400@400! ! !AthensDemoMorph methodsFor: 'figures' stamp: 'IgorStasenko 4/12/2013 10:06'! figure6: aCanvas | pt c linearGradient | self figure5: aCanvas. linearGradient := aCanvas surface createLinearGradient: { 0 -> self coloredCarColor . 0.25 -> self coloredCarColor muchLighter. 0.5 -> Color white. 0.75 -> (self coloredCarColor muchLighter ). 1 -> (self coloredCarColor alpha: 0) } start: 0@100 stop: 0@300. aCanvas setShape: (self roundedRectanglePathOn: aCanvas). aCanvas setPaint: linearGradient. aCanvas draw. ! ! !AthensDemoMorph methodsFor: 'initialize-release' stamp: 'IgorStasenko 8/29/2012 10:22'! initialize | ref | super initialize. self extent: self defaultExtent. self color: self backColor. surface := AthensCairoSurface extent: self extent. current := 1. frame := 0. ref := 'Pharo.png' asFileReference. pharoLogo := AthensCairoSurface createFromFile: ref fullName ifFailed: [ nil ]. ref := 'esug-balloon.png' asFileReference. esugBallon := AthensCairoSurface createFromFile: ref fullName ifFailed: [ nil ]. self startStepping. ! ! !AthensDemoMorph methodsFor: 'accessing' stamp: 'FernandoOlivero 3/30/2012 11:51'! carColor ^ Color veryVeryLightGray! ! !AthensDemoMorph methodsFor: 'figures' stamp: 'IgorStasenko 3/30/2012 16:42'! roundedRectanglePathOn: aCanvas ^ aCanvas createPath: [:builder | builder absolute; moveTo: 70@100; lineTo: 330@100; cwArcTo: 350@120 angle: 90 degreesToRadians; lineTo: 350@280; cwArcTo: 330@300 angle: 90 degreesToRadians; lineTo: 70@300; cwArcTo: 50@280 angle: 90 degreesToRadians; lineTo: 50@120; cwArcTo: 70@100 angle: 90 degreesToRadians ]. ! ! !AthensDemoMorph methodsFor: 'initialize-release' stamp: 'FernandoOlivero 4/19/2012 14:21'! figures ^ #( figure1: figure2: figure3: figure4: figure5: figure6: figure7: figure8: figure9: figure10: ). ! ! !AthensDemoMorph methodsFor: 'drawing' stamp: 'IgorStasenko 3/30/2012 18:22'! render surface drawDuring: [:canvas | surface clear. canvas pathTransform loadIdentity. canvas setPaint: Color lightGray; drawShape: (0@0 corner: self extent). self perform: (self figures at: current) with: canvas ]. ! ! !AthensDemoMorph methodsFor: 'figures' stamp: 'DamienPollet 12/22/2012 01:38'! figure7: aCanvas | pt | self drawBackgroundOn: aCanvas. pt := aCanvas pathTransform. pt restoreAfter:[ pt scaleBy: self extent . self drawCarOn: aCanvas. pt scaleBy: 0.25@0.25. self drawCarOn: aCanvas. pt translateBy: 2@0; rotateByDegrees: 35. self drawCarOn: aCanvas. ]. ! ! !AthensDemoMorph methodsFor: 'accessing' stamp: 'FernandoOlivero 3/30/2012 15:17'! stepTime ^ 0! ! !AthensDemoMorph methodsFor: 'drawing' stamp: 'FernandoOlivero 3/30/2012 15:00'! drawBackgroundOn: aCanvas aCanvas setPaint: Color veryLightGray; drawShape: (0@0 extent: 1@1)! ! !AthensDemoMorph methodsFor: 'accessing' stamp: 'FernandoOlivero 3/30/2012 14:24'! chasisLineColor ^ Color white! ! !AthensDemoMorph methodsFor: 'figures' stamp: 'IgorStasenko 3/30/2012 18:26'! figure3: aCanvas | pt path | path := aCanvas createPath: [:builder | builder relative; moveTo: 0.3@0.3 ; lineTo: 0.4@0; curveVia: 0.1@0 to: 0.1@0.1; lineTo: 0@0.2; curveVia: 0@0.1 to: -0.1@0.1; lineTo: -0.4@0; curveVia: -0.1@0 to: (-0.1@ -0.1); lineTo: 0@ -0.2 ; curveVia: 0@ -0.1 to: 0.1@ -0.1 ]. aCanvas pathTransform scaleBy: self extent. aCanvas setPaint: self carColor; drawShape: path ! ! !AthensDemoMorph methodsFor: 'drawing' stamp: 'IgorStasenko 3/30/2012 18:23'! drawOn: aCanvas self render. aCanvas drawImage: surface asForm at: self bounds origin! ! !AthensDemoMorph methodsFor: 'figures' stamp: 'IgorStasenko 3/30/2012 18:29'! figure4: aCanvas | path stroke | path := self roundedRectanglePathOn: aCanvas. aCanvas setShape: path. aCanvas setPaint: self carColor. aCanvas draw. stroke := aCanvas setStrokePaint: Color black. stroke width: 3. aCanvas draw. ! ! !AthensDemoMorph methodsFor: 'figures' stamp: 'IgorStasenko 3/30/2012 18:27'! figure8: aCanvas | pt | pt := aCanvas pathTransform. pt restoreAfter:[ | stroke p wheel decorator | pt scaleBy: self extent . self drawBackgroundOn: aCanvas. pt scaleBy: (frame/100) sin abs. self drawCarOn: aCanvas. pt scaleBy: 0.25@0.2.5. self drawCarOn: aCanvas. pt translateBy: 2@0; rotateByDegrees: 35. self drawCarOn: aCanvas. ]. ! ! !AthensDemoMorph methodsFor: 'initialize-release' stamp: ''! backColor ^ Color white.! ! !AthensDemoMorph methodsFor: 'figures' stamp: 'IgorStasenko 3/30/2012 18:25'! figure2: aCanvas | pt path | path := aCanvas createPath: [:builder | builder absolute; moveTo: 70@100; lineTo: 330@100; cwArcTo: 350@120 angle: 90 degreesToRadians; lineTo: 350@280; cwArcTo: 330@300 angle: 90 degreesToRadians; lineTo: 70@300; cwArcTo: 50@280 angle: 90 degreesToRadians; lineTo: 50@120; cwArcTo: 70@100 angle: 90 degreesToRadians ]. aCanvas setPaint: self carColor; drawShape: path ! ! !AthensDemoMorph methodsFor: 'accessing' stamp: 'FernandoOlivero 3/30/2012 15:20'! step frame := frame + 1. self changed! ! !AthensDemoMorph methodsFor: 'drawing' stamp: 'IgorStasenko 3/30/2012 17:20'! drawCarOn: aCanvas "chasis -----------------------------------------------------------------------" | p stroke wheel decorator | p := aCanvas createPath:[:b| b moveTo: 0.3@0.3 ; lineTo: 0.4@0; curveVia: 0.1@0 to: 0.1@0.1; lineTo: 0@0.2; curveVia: 0@0.1 to: -0.1@0.1; lineTo: -0.4@0; curveVia: -0.1@0 to: (0.1@0.1) negated; lineTo: 0@0.2 negated ; curveVia: 0@0.1 negated to: 0.1@0.1 negated ]. aCanvas setPaint: self coloredCarColor; drawShape: p. stroke := aCanvas setStrokePaint: self wheelColor. stroke width: 0.01. aCanvas draw. "wheels-----------------------------------------------------------------------" wheel := aCanvas createPath:[:b| b moveTo: 0.3@0.3; cwArcTo: 0.15@0 angle: Float halfPi ; moveTo: 0.1@0; cwArcTo: 0.15@0 angle: Float halfPi ; moveTo: 0.0@0.4; cwArcTo: 0.15 negated@0 angle: Float halfPi; moveTo: -0.1@0; cwArcTo: 0.15 negated@0 angle: Float halfPi ]. aCanvas setPaint: self wheelColor; drawShape: wheel. "chasis decorator-----------------------------------------------------------------------" decorator := aCanvas createPath:[:b| b moveTo: 0.2@0.45; lineTo: 0.225@0 ; cwArcTo: 0.15@0 angle: Float halfPi ; lineTo: 0.225@0; lineTo: 0@0.1 ; lineTo: -0.225@ 0; cwArcTo: -0.15@0 angle: Float halfPi ; lineTo: -0.225@ 0 ; lineTo: 0@0.1 negated]. stroke := aCanvas setStrokePaint: self chasisDecoratorColor. stroke width: 0.01. aCanvas drawShape: decorator. aCanvas setPaint: self chasisLineColor. aCanvas draw. ! ! !AthensDemoMorph methodsFor: 'figures' stamp: 'IgorStasenko 3/30/2012 18:26'! figure5: aCanvas | wheels | self figure4: aCanvas. wheels := aCanvas createPath: [:builder | builder moveTo: 100@100; cwArcTo: 60@0 angle: 90 degreesToRadians; moveTo: 80@0; cwArcTo: 60@0 angle: 90 degreesToRadians; moveTo: 0.0@200; cwArcTo: -60@0 angle: 90 degreesToRadians; moveTo: -80@0; cwArcTo: -60@0 angle: 90 degreesToRadians ]. aCanvas setPaint: self wheelColor; drawShape: wheels! ! !AthensDemoMorph methodsFor: 'accessing' stamp: ''! coloredCarColor ^ Color red! ! !AthensDemoMorph methodsFor: 'accessing' stamp: ''! prevFigure current := current - 1. current < 1 ifTrue: [ current := self figures size ].! ! !AthensDemoMorph methodsFor: 'figures' stamp: 'IgorStasenko 3/30/2012 18:25'! figure1: aCanvas aCanvas setPaint: self carColor; drawShape: (50@100 extent: 300@200) ! ! !AthensDemoMorph methodsFor: 'accessing' stamp: ''! chasisDecoratorColor ^ Color black! ! !AthensDemoMorph methodsFor: 'figures' stamp: 'FernandoOlivero 4/19/2012 14:20'! figure10: aCanvas | pt ellipsePath patternPaint rectangle | ellipsePath := aCanvas createPath: [ :builder | builder moveTo: 0@200; cwArcTo: 240@0 angle: Float pi ; cwArcTo: -240@0 angle: Float pi ]. aCanvas setPaint: Color black. aCanvas drawShape: ellipsePath. rectangle := 250@40 extent: 140@300. aCanvas drawShape: rectangle. aCanvas paintTransform loadIdentity. aCanvas paintTransform scaleBy: ((frame/100) sin abs)*5. aCanvas paintTransform rotateByDegrees: (frame/100) sin * 360. patternPaint := aCanvas setPaint: pharoLogo. patternPaint setExtend: #Repeat. aCanvas drawShape: ellipsePath. aCanvas setPaint: patternPaint. patternPaint setExtend: #Reflect. aCanvas drawShape: rectangle. ! ! !AthensEllipticalArcSegment commentStamp: ''! I representing an elliptical arc, using endpoint parametrization: - initial endpoint (x0,y0), which comes from previous segment - final endpoint (x1,y1) - rh, rv , the radii of unrotated ellipse - Large arc flag: true if more than 180 degrees of the arc is to be traversed (as measured on the unscaled circle), false otherwise - Sweep flag: true if the arc is to be traversed in the counter-clockwise direction, false otherwise (not functional yet)! !AthensEllipticalArcSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 04:42'! accept: aVisitor ^ aVisitor ellipticalArcSegment: self! ! !AthensFlakeDemo commentStamp: ''! AthensFlakeDemo new openInWindow ! !AthensFlakeDemo methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/2/2012 18:27'! circle ^ circle ! ! !AthensFlakeDemo methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/2/2012 19:31'! initialize super initialize. self extent: self defaultExtent. surface := AthensCairoSurface extent: self extent. circle := surface createPath: [:builder | builder absolute; moveTo: -1 @ 0 ; ccwArcTo: 0@ 1 angle: 90 degreesToRadians ; ccwArcTo: 1@0 angle: 90 degreesToRadians ; ccwArcTo: 0@ -1 angle: 90 degreesToRadians ; ccwArcTo: -1@0 angle: 90 degreesToRadians ]. spike := surface createPath: [:builder | builder absolute; moveTo: -0.1 @ 0; lineTo: -0.05 @ 1; lineTo: 0.05 @ 1; lineTo: 0.1 @ 0 ]. frame := 1. self startStepping. ! ! !AthensFlakeDemo methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/2/2012 19:18'! step frame := Time millisecondClockValue / 100. self changed! ! !AthensFlakeDemo methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/29/2013 15:38'! drawOn: aCanvas self render. surface displayOnMorphicCanvas: aCanvas at: bounds origin. ! ! !AthensFlakeDemo methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/2/2012 19:33'! drawSpike: canvas | dist | dist := (canvas pathTransform transform: 1@0) - (canvas pathTransform transform: 0@0). dist r < 2 ifTrue: [ ^ self ]. canvas setPaint: (Color black alpha: 0.5); drawShape: spike. canvas pathTransform restoreAfter: [ canvas pathTransform translateX: 0 Y: 1; scaleBy: 0.5 + ((frame *0.1) sin * 0.1 ). canvas pathTransform rotateByDegrees: -180. 1 to: 2 do:[ :i | canvas pathTransform rotateByDegrees: 120 + ((frame * 0.1) cos * 20). canvas pathTransform restoreAfter: [ self drawSpike: canvas. ] ]. self drawCircles: canvas ] ! ! !AthensFlakeDemo methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/2/2012 19:16'! defaultExtent ^ 800@800! ! !AthensFlakeDemo methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/3/2012 16:54'! render surface drawDuring: [:canvas | canvas pathTransform loadIdentity. surface clear. " canvas setPaint: Color white; drawShape: (0@0 corner: self extent ). " canvas pathTransform translateX: self extent x *0.5 Y: self extent y * 0.5; scaleBy: 160. canvas pathTransform rotateByDegrees: (frame * 0.5 + ((frame *0.1 + 1.7) cos * 5)). 1 to: 3 do:[ :i | canvas pathTransform rotateByDegrees: 120. self drawSpike: canvas. ]. self drawCircles: canvas ]. ! ! !AthensFlakeDemo methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/2/2012 18:21'! drawCircles: canvas canvas pathTransform restoreAfter: [ canvas pathTransform scaleBy: 0.5 . canvas setPaint: Color black; setShape: self circle; draw. canvas pathTransform scaleBy: 0.8. canvas setPaint: Color white; draw. canvas pathTransform scaleBy: 0.8. canvas setPaint: Color black; draw ]! ! !AthensFlakeDemo methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/2/2012 19:12'! stepTime ^ 0! ! !AthensFontChange commentStamp: 'IgorStasenko 2/6/2012 16:17'! A command to change the currently selected font! !AthensFontChange methodsFor: 'rendering' stamp: 'IgorStasenko 10/17/2011 12:50'! renderOn: anAthensTextRenderer anAthensTextRenderer setCurrentFont: font.! ! !AthensFontChange methodsFor: 'accessing' stamp: 'IgorStasenko 11/10/2011 11:07'! font ^ font! ! !AthensFontChange methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2011 16:55'! font: aFont font := aFont! ! !AthensFontChange class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2011 16:55'! font: aFont ^ self new font: aFont! ! !AthensFontDescription commentStamp: 'FernandoOlivero 1/24/2012 18:30'! Creates a new font description from a string representation in the form "[FAMILY-LIST] [STYLE-OPTIONS] [SIZE]", 1)FAMILY-LIST is a comma separated list of families optionally terminated by a comma, 2)STYLE_OPTIONS is a whitespace separated list of words where each WORD describes one of style, variant, weight, stretch, or gravity. If STYLE-OPTIONS is missing, then all style options will be set to the default values 3)SIZE is a decimal number (size in points) or optionally followed by the unit modifier "px" for absolute size. ! !AthensFontDescription methodsFor: 'cairo-options' stamp: 'FernandoOlivero 1/10/2012 12:12'! fontSize: aPointSize size := aPointSize! ! !AthensFontDescription methodsFor: 'cairo-options' stamp: 'FernandoOlivero 1/14/2012 20:10'! fontFamily ^ family! ! !AthensFontDescription methodsFor: 'accessing' stamp: 'FernandoOlivero 1/14/2012 20:07'! beNormal self slant: #normal ; weight: #normal.! ! !AthensFontDescription methodsFor: 'accessing' stamp: 'FernandoOlivero 1/14/2012 20:07'! beBold self weight: #bold! ! !AthensFontDescription methodsFor: 'pango-options' stamp: 'FernandoOlivero 1/17/2012 16:26'! fontGravity ^ options at: #gravity! ! !AthensFontDescription methodsFor: 'pango-options' stamp: 'FernandoOlivero 1/17/2012 16:26'! fontStretch ^ options at: #stretch! ! !AthensFontDescription methodsFor: 'pango-options' stamp: 'FernandoOlivero 1/17/2012 16:28'! gravity: aNumber options at: #gravity put: aNumber. ! ! !AthensFontDescription methodsFor: 'cairo-options' stamp: 'FernandoOlivero 1/14/2012 19:52'! weight: aNumber options at: #weight put: aNumber. ! ! !AthensFontDescription methodsFor: 'cairo-options' stamp: 'FernandoOlivero 1/14/2012 19:42'! family: aFamilyName "CSS2 generic family names: serif, sans-serif, cursive, fantasy, monospace" family := aFamilyName. ! ! !AthensFontDescription methodsFor: 'cairo-options' stamp: 'FernandoOlivero 1/14/2012 20:06'! fontWeight ^ options at: #weight ! ! !AthensFontDescription methodsFor: 'pango-options' stamp: 'FernandoOlivero 1/17/2012 16:25'! fontVariant ^ options at: #variant ! ! !AthensFontDescription methodsFor: 'cairo-options' stamp: 'FernandoOlivero 1/14/2012 19:52'! slant: aNumber options at: #slant put: aNumber. ! ! !AthensFontDescription methodsFor: 'initialize-release' stamp: 'FernandoOlivero 1/14/2012 20:08'! initialize super initialize. family := 'monospace'. options := Dictionary new. options at:#weight put: #normal; at:#slant put: #normal. size := 14. ! ! !AthensFontDescription methodsFor: 'pango-options' stamp: 'FernandoOlivero 1/17/2012 16:28'! variant: aNumber options at: #variant put: aNumber. ! ! !AthensFontDescription methodsFor: 'pango-options' stamp: 'FernandoOlivero 1/17/2012 16:28'! stretch: aNumber options at: #stretch put: aNumber. ! ! !AthensFontDescription methodsFor: 'accessing' stamp: 'FernandoOlivero 1/14/2012 20:06'! beOblique self slant: #oblique! ! !AthensFontDescription methodsFor: 'accessing' stamp: 'FernandoOlivero 1/14/2012 20:06'! beItalic self slant: #italic! ! !AthensFontDescription methodsFor: 'cairo-options' stamp: 'FernandoOlivero 1/14/2012 20:09'! fontSize ^ size ! ! !AthensFontDescription methodsFor: 'cairo-options' stamp: 'FernandoOlivero 1/25/2012 01:02'! fontSlant ^ options at: #slant ! ! !AthensFontDescription methodsFor: 'accessing' stamp: 'FernandoOlivero 1/17/2012 16:31'! asString "[FAMILY-LIST] [STYLE-OPTIONS] [SIZE]" | str | str := '' writeStream. str nextPutAll: family; space. " 2)STYLE_OPTIONS is a whitespace separated list of words where each WORD describes one of style, variant, weight, stretch, or gravity. If STYLE-OPTIONS is missing, then all style options will be set to the default values " #(slant. variant. weight. stretch. gravity) do:[:each| |val| val := options at: each ifAbsent: nil. val notNil ifTrue:[str nextPutAll: val ; space ]]. self fontSize notNil ifTrue:[ str space; nextPutAll: self fontSize asString ]. ^ str contents! ! !AthensFontDescription class methodsFor: 'examples' stamp: 'FernandoOlivero 1/24/2012 18:43'! example | fDesc | fDesc := AthensFontDescription new. fDesc family: 'monospace'; fontSize: 22. ^ fDesc! ! !AthensGenericTransform commentStamp: ''! I am an extended version of my supeclass, and I represent generic 3x3 matrix. ! !AthensGenericTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/26/2011 02:10'! loadIdentity "initialize with identity transform" super loadIdentity. w0 := w1 := 0.0. w2 := 1.0! ! !AthensInteractiveScene commentStamp: ''! i am like my superclass, can display any scene (object which understands #renderOn: message) and support free-form pan and zoom. but in addition, i expecting that scene object understands following: scene handleEvent: event in: sceneView at: position This method should answer true if scene object wants to handle event by itself , preventing default handling of view (pan & zoom). The point is coordinates of event in scene coordinate space (not screen coordinate space). The event is MorphicEvent (currently limited only to mouse move&button events). Note that if scene view enters zooming or panning state, no events will be passed to scene object as long as state is active. ! !AthensInteractiveScene methodsFor: 'event handling' stamp: 'IgorStasenko 6/1/2013 05:17'! mouseDown: evt ((self inState: #panning) or: [ self inState:#zooming ]) ifFalse: [ (self eventHandledByScene: evt) ifTrue: [ ^ self ]. ]. ^ super mouseDown: evt! ! !AthensInteractiveScene methodsFor: 'event handling' stamp: 'IgorStasenko 6/1/2013 05:08'! eventPositionInScene: evt | pt | pt := evt position - self topLeft. ^ transform transform: pt! ! !AthensInteractiveScene methodsFor: 'event handling' stamp: 'IgorStasenko 6/1/2013 05:13'! eventHandledByScene: evt ^ true == (scene handleEvent: evt in: self at: (self eventPositionInScene:evt)) ! ! !AthensInteractiveScene methodsFor: 'event handling' stamp: 'IgorStasenko 6/1/2013 05:16'! mouseUp: evt ((self inState: #panning) or: [ self inState:#zooming ]) ifFalse: [ (self eventHandledByScene: evt) ifTrue: [ ^ self ]. ]. ^ super mouseUp:evt ! ! !AthensInteractiveScene methodsFor: 'event handling' stamp: 'IgorStasenko 6/1/2013 05:12'! mouseMove: evt ((self inState: #panning) or: [ self inState:#zooming ]) ifFalse: [ (self eventHandledByScene: evt) ifTrue: [ ^ self ]. ]. ^ super mouseMove: evt! ! !AthensLineSegment commentStamp: ''! i represent a line segment, created using #lineTo: command of AthensPathBuilder! !AthensLineSegment methodsFor: 'accessing' stamp: 'IgorStasenko 3/26/2011 16:16'! point ^ point! ! !AthensLineSegment methodsFor: 'accessing' stamp: 'IgorStasenko 3/26/2011 16:21'! endPoint ^ point! ! !AthensLineSegment methodsFor: 'accessing' stamp: 'IgorStasenko 3/26/2011 16:16'! point: anObject point := anObject! ! !AthensLineSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 04:41'! accept: aVisitor ^ aVisitor lineSegment: self! ! !AthensLineSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 05:23'! sendCommandTo: aBuilder ^ aBuilder lineTo: point ! ! !AthensMorphScene commentStamp: 'TorstenBergmann 2/12/2014 22:01'! Allows to render a morph as a scene in athens! !AthensMorphScene methodsFor: 'accessing' stamp: 'IgorStasenko 5/6/2013 18:09'! renderOn:aCanvas morph fullDrawOnAthensCanvas: aCanvas! ! !AthensMorphScene methodsFor: 'accessing' stamp: 'IgorStasenko 5/6/2013 18:06'! morph: anObject morph := anObject! ! !AthensMorphScene methodsFor: 'accessing' stamp: 'IgorStasenko 5/6/2013 18:06'! morph ^ morph! ! !AthensMorphicGradientPaint commentStamp: ''! i am used to convert gradient fill style(s) used in Morphic to appropriate paint(s) in Athens.! !AthensMorphicGradientPaint methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2013 16:35'! athensFillRectangle: aRect on: canvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " | fill | fill := gradient radial ifTrue: [ canvas surface createRadialGradient: gradient colorRamp center: (canvas pathTransform inverseTransform: gradient origin ) radius: gradient direction y ] ifFalse: [ canvas surface createLinearGradient: gradient colorRamp start: (canvas pathTransform inverseTransform: gradient origin) stop: (canvas pathTransform inverseTransform: gradient origin + gradient direction ) ]. fill athensFillRectangle: aRect on: canvas. ! ! !AthensMorphicGradientPaint methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2012 16:14'! gradient: aGradient gradient := aGradient! ! !AthensMoveSegment commentStamp: 'IgorStasenko 5/2/2011 05:35'! Move segment always indicates starting of a new contour. If contour ends with close command, then my insntance will have 'closed' flag set to true. See AthensPathBuilder , which is responsible for building paths.! !AthensMoveSegment methodsFor: 'testing' stamp: 'IgorStasenko 3/27/2011 17:48'! isMove ^ true! ! !AthensMoveSegment methodsFor: 'testing' stamp: 'IgorStasenko 5/2/2011 05:37'! isClosed ^ closed == true! ! !AthensMoveSegment methodsFor: 'accessing' stamp: 'IgorStasenko 5/2/2011 05:37'! closed: aBoolean closed := aBoolean! ! !AthensMoveSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 04:40'! accept: aVisitor ^ aVisitor moveSegment: self! ! !AthensMoveSegment methodsFor: 'accessing' stamp: 'FernandoOlivero 1/15/2012 14:59'! reopen: aBoolean closed := aBoolean! ! !AthensMoveSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 05:23'! sendCommandTo: aBuilder ^ aBuilder moveTo: point ! ! !AthensPaint commentStamp: ''! I am a base class, which defines a paint. My subclasses represent a concreate paint by implementing my protocol, that actually draws a specific shapes with me. My subclasses usually backend-specific, but as long as you implement my protocol, any object can be treated as paint: - athensFillPath: aPath on: aCanvas - athensFillRectangle: aRectangle on: aCanvas - asStrokePaint ! !AthensPaint methodsFor: 'rendering' stamp: 'IgorStasenko 9/3/2013 14:23'! athensFillRectangle: aRectangle on: aCanvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " self subclassResponsibility! ! !AthensPaint methodsFor: 'converting' stamp: 'IgorStasenko 4/27/2012 11:28'! asStrokePaintOn: aCanvas "default implementation" ^ aCanvas surface createStrokePaintFor: self ! ! !AthensPaint methodsFor: 'rendering' stamp: 'IgorStasenko 9/3/2013 14:22'! athensFillPath: aPath on: aCanvas "This is a terminal method in rendering dispatch scheme canvas->shape->paint. See AthensCanvas>>fillShape: " self subclassResponsibility! ! !AthensPaintMode commentStamp: ''! A paint mode controls how the incoming color (source) will be transferred to surface (destination). To set a paint mode for canvas, send a message with corresponding mode name to my instance. My instance(s) is available via canvas protocol, i.e. 'canvas paintMode'. For example, to set an 'over' paint mode, use following: canvas paintMode over. If you want to restore original paint mode after performing drawing operations, which may change it, use #restoreAfter: method , i.e. canvas paintMode restoreAfter: [ .. perform any drawing operations here.. ]. Since different backends may support different set of paint modes, the default implementation in AthensPaintMode for all mode setters is to signal an error. To query a set of available paint modes, supported by backend, use #availableModes message. ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:02'! dest "Set 'dest' drawing mode. Drawing under this mode will ignore the source, as if nothing drawn" self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:04'! atop "Set 'atop' painting mode " self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:04'! destOver self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 16:50'! over "Set 'over' drawing mode. This is default paint mode. Drawing under this mode will blend source with destination color using source alpha component" self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 16:48'! in self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:05'! destAtop self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:05'! multiply self notAvailable! ! !AthensPaintMode methodsFor: 'errors' stamp: 'IgorStasenko 9/1/2012 16:49'! notAvailable ^ self error: 'A requested paint mode is not supported by backend'! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:04'! out "Set 'out' painting mode " self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:06'! overlay self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 16:50'! source "Set 'source' drawing mode. Drawing under this mode will replace the content with incoming source under the shape boundaries" self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:07'! hslSaturation self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:05'! destOut self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:07'! hslColor self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:02'! clear "Set 'clear' drawing mode. Drawing under this mode will clear the surface under the shape boundaries" self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:06'! screen self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:06'! colorBurn self notAvailable! ! !AthensPaintMode methodsFor: 'convenience' stamp: 'IgorStasenko 9/1/2012 14:40'! restoreAfter: aBlock "restore current paint mode after evaluating a block" self subclassResponsibility! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:06'! darken self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:07'! difference self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:05'! add self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:06'! colorDodge self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:05'! destIn self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:07'! hslLuminosity self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:06'! lighten self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:05'! xor self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:06'! softLight self notAvailable! ! !AthensPaintMode methodsFor: 'default mode' stamp: 'IgorStasenko 9/1/2012 16:41'! default "Set the default paint mode. The default paint mode in Athens, is 'over' " ^ self over! ! !AthensPaintMode methodsFor: 'capabilities' stamp: 'IgorStasenko 9/1/2012 17:01'! availableModes "Answer a collection of paint mode names, currently supported by backend. Different backends may support different sets of paint modes. You may need to structure your code depending on modes available" ^ #()! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:05'! saturate self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:07'! hslHue self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:06'! hardLight self notAvailable! ! !AthensPaintMode methodsFor: 'modes' stamp: 'IgorStasenko 9/1/2012 17:07'! exclusion self notAvailable! ! !AthensParagraph commentStamp: ''! this class is subject of changes/removal. do not use it.! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 13:07'! extraSelectionChanged " refreshExtraSelection := true " self flag: #foo! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/31/2012 01:28'! showCared ! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 13:06'! findReplaceSelectionRegex: aRegex " findReplaceSelectionRegex := aRegex. " self flag: #foo ! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 12:20'! textOwner: anUndefinedObject self shouldBeImplemented.! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 13:00'! positionWhenComposed: pos positionWhenComposed := pos! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 13:09'! selectionStart: startBlock selectionStop: stopBlock selectionStart := startBlock. selectionStop := stopBlock.! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 13:02'! selectionColor: anUndefinedObject self shouldBeImplemented.! ! !AthensParagraph methodsFor: 'drawing' stamp: 'IgorStasenko 10/7/2012 23:32'! drawOnAthensCanvas: canvas bounds: aRectangle | renderer | "self halt." " canvas clipBy: aRectangle during: [ " renderer := AthensTextRenderer new. renderer render: text lines: lines on: canvas. " ]. "! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/31/2012 01:28'! focused ^ false! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 13:08'! selectionRects ^ #()! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 13:05'! text ^ text! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 12:48'! extent ^ containerRect width @ lines last bottom! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 12:22'! compose: aText style: aTextStyle from: startingIndex in: aRectangle text := aText. textStyle := aTextStyle self shouldBeImplemented.! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/31/2012 01:29'! showCaret: abool ! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 16:08'! characterBlockForIndex: index ^ self defaultCharacterBlock! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 12:50'! compose: aText style: aTextStyle in: rect text := aText. textStyle := aTextStyle. containerRect := rect. lines := (AthensTextComposer scan: aText for: AthensTextScanner new) lines.! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 12:45'! focused: bool "why we should care?" "self flag: #ooo"! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/31/2012 01:31'! caretRect ^ (0@0 corner: 0@0) ! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 13:06'! secondarySelection: aSubString " secondarySelection := aSubString." self flag: #foo.! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/31/2012 01:29'! showCaret ! ! !AthensParagraph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 13:04'! defaultCharacterBlock ^ (CharacterBlock new stringIndex: 1 text: text topLeft: 0@0 extent: 0 @ 0) textLine: lines first! ! !AthensPath commentStamp: ''! This class represents an interface, which should be supported by all paths (special kind of shape) used for drawing with Athens framework. Path data organization is up to surface where it built, therefore paths are not interchangeable between different surfaces. ! !AthensPathBuilder commentStamp: ''! i am abstract path builder, to specify an interface protocol which is available for building paths, by using canvas or surface #createPath: method.! !AthensPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 14:27'! lineTo: aPoint "add a line segment, starting from current path endpoint to aPoint" self subclassResponsibility! ! !AthensPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 14:28'! ccwArcTo: endPt angle: rot " Add a counter-clockwise arc segment, starting from current path endpoint and ending at andPt. Angle should be specified in radians " self subclassResponsibility! ! !AthensPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 14:30'! curveVia: cp1 and: cp2 to: aPoint "Add a cubic bezier curve, starting from current path endpoint, using control points cp1, cp2 and ending at aPoint " self subclassResponsibility ! ! !AthensPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 14:30'! close "close the current path controur" self subclassResponsibility ! ! !AthensPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 14:29'! curveVia: cp1 to: aPoint "Add a quadric bezier curve, starting from current path endpoint, using control point cp1, and ending at aPoint " self subclassResponsibility ! ! !AthensPathBuilder methodsFor: 'path commands' stamp: 'JochenRick 1/8/2014 06:27'! reflectedCurveVia: cp2 to: aPoint "Add a reflected cubic bezier curve, starting from current path endpoint and ending at aPoint. The first control point is calculated as a reflection from the current point, if the last command was also a cubic bezier curve. Otherwise, the first control point is the current point. The second control point is cp2." self subclassResponsibility ! ! !AthensPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 14:27'! relative "next commands will use relative coordinates for all segment points" self subclassResponsibility! ! !AthensPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 14:26'! absolute "next commands will use absolute coordinates for all segment points" self subclassResponsibility! ! !AthensPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 14:27'! moveTo: aPoint " move command always starts a new contour " self subclassResponsibility! ! !AthensPathBuilder methodsFor: 'creating path' stamp: 'IgorStasenko 4/18/2013 17:46'! createPath: aBlock "aBlock value: self ...." self subclassResponsibility ! ! !AthensPathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 14:28'! cwArcTo: endPt angle: rot " Add a clockwise arc segment, starting from current path endpoint and ending at andPt. Angle should be specified in radians " self subclassResponsibility! ! !AthensPathBuilder class methodsFor: 'instance creation' stamp: 'IgorStasenko 4/18/2013 17:45'! createPath: aBlock ^ self new createPath: aBlock! ! !AthensPathBuilder class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 3/7/2012 15:26'! initialize ZeroPoint := 0@0! ! !AthensPathConverter commentStamp: 'IgorStasenko 5/1/2011 23:14'! i am a base class for path conversion. i take a path as input and producing a path commands as output. My default implementation just passing all path commands without changes to destination without any conversion Example of use: converter := AthensXYZConverter dest: (AthensPolygonPath new). convertedPath := converter convert: sourcePath. You can chain multiple converters: basicConverter := AthensZYXConv dest: AthensPolygonPath new. compoundConverter := AthensABCConverter dest: basicConverter. compoundConverter convert: somePath in this case, an initial conversion is performed by instance of AthensABCConverter, and then conversion results are passed down to AthensZYXConv, and then finally to instance of AthensPolygonPath. ! !AthensPathConverter methodsFor: 'converting path commands' stamp: 'IgorStasenko 4/29/2011 18:36'! lineTo: aPoint ^ dest lineTo: aPoint! ! !AthensPathConverter methodsFor: 'accessing' stamp: 'IgorStasenko 5/1/2011 22:18'! dest: anObject dest := anObject! ! !AthensPathConverter methodsFor: 'converting path commands' stamp: 'IgorStasenko 5/2/2011 05:18'! close: aPoint ^ dest close: aPoint! ! !AthensPathConverter methodsFor: 'converting path commands' stamp: 'IgorStasenko 4/29/2011 18:31'! curveVia: pt1 to: pt2 ^ dest curveVia: pt1 to: pt2 ! ! !AthensPathConverter methodsFor: 'actions' stamp: 'IgorStasenko 5/1/2011 22:16'! convert: aSourcePath " iterate over segments and do conversion " | segment | segment := aSourcePath. [ segment notNil ] whileTrue: [ segment convertWith: self. endPoint := segment endPoint. segment := segment next. ]. ^ dest finish! ! !AthensPathConverter methodsFor: 'accessing' stamp: 'IgorStasenko 4/29/2011 18:18'! source: aSource dest: aDest sourcePath := aSource. dest := aDest! ! !AthensPathConverter methodsFor: 'converting path commands' stamp: 'IgorStasenko 4/29/2011 18:28'! moveTo: aPoint ^ dest moveTo: aPoint! ! !AthensPathConverter methodsFor: 'actions' stamp: 'IgorStasenko 5/1/2011 22:13'! finish ^ dest finish! ! !AthensPathConverter class methodsFor: 'instance creation' stamp: 'IgorStasenko 5/1/2011 22:20'! source: aSource dest: aDest " answer a converted path from source to dest, using my instance as a converter" ^ self new source: aSource dest: aDest! ! !AthensPathConverter class methodsFor: 'instance creation' stamp: 'IgorStasenko 5/1/2011 22:18'! dest: aDest ^ self new dest: aDest! ! !AthensPathSegment commentStamp: ''! The path segment is path building block. Path is formed from list of connected path segments. At building stage, there is no container nor separately defined "path" object, just a linked list of segments. Later the segments are accumulated in backend-specific path object, and the way how it is organized may vary. My (sub)instances usually are not created directly by user, but instead by instance of AthensPathBuilder. Therefore, all my subclasses are considered private and implementation detail.! !AthensPathSegment methodsFor: 'accessing' stamp: 'IgorStasenko 4/18/2013 21:51'! size "answer 1 + the number of segments next to receiver" | segment count | segment := self. count := 0. [ segment notNil ] whileTrue: [ count := count + 1. segment := segment next ]. ^ count.! ! !AthensPathSegment methodsFor: 'iterating' stamp: 'IgorStasenko 4/18/2013 04:52'! do: aBlock | segment | segment := self. [ aBlock value: segment. segment := segment next. segment notNil ] whileTrue.! ! !AthensPathSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 04:38'! accept: aVisitor self subclassResponsibility ! ! !AthensPathSegment methodsFor: 'accessing' stamp: 'IgorStasenko 3/26/2011 16:14'! next ^ next! ! !AthensPathSegment methodsFor: 'iterating' stamp: 'IgorStasenko 4/18/2013 05:20'! sendCommandsTo: aBuilder self do: [ :segment | segment sendCommandTo: aBuilder ]! ! !AthensPathSegment methodsFor: 'testing' stamp: 'IgorStasenko 3/26/2011 16:44'! isMove ^ false! ! !AthensPathSegment methodsFor: 'accessing' stamp: 'IgorStasenko 3/26/2011 16:14'! next: anObject next := anObject! ! !AthensPathSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/29/2011 18:13'! convertWith: anObject self subclassResponsibility! ! !AthensPathSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/13/2013 17:33'! visitWith: visitor self subclassResponsibility! ! !AthensPathSegment methodsFor: 'testing' stamp: 'JochenRick 1/8/2014 06:31'! isCubic ^ false! ! !AthensPathSegmentConverter commentStamp: ''! this class is subject of changes/removal. do not use it.! !AthensPathSegmentConverter methodsFor: 'converting' stamp: 'IgorStasenko 4/18/2013 17:50'! convert: aPath "pipe the path segments to destination, converting segments on the way" contourStartPt := endPoint := 0@0. aPath sendCommandsTo: self. ! ! !AthensPathSegmentConverter methodsFor: 'accessing' stamp: 'IgorStasenko 4/18/2013 17:39'! dest: aDest dest := aDest! ! !AthensPluggableTextMorph commentStamp: ''! this class is subject of changes/removal. do not use it.! !AthensPluggableTextMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 12:01'! textMorphClass ^ AthensTextMorph! ! !AthensPolygon commentStamp: 'IgorStasenko 12/20/2011 18:38'! i am special kind of shape which using only straight line segments, unlike from more generic paths.! !AthensPolygon methodsFor: 'conversion' stamp: 'IgorStasenko 4/29/2011 18:32'! lineTo: aPoint currentContour add: aPoint! ! !AthensPolygon methodsFor: 'conversion' stamp: 'IgorStasenko 4/29/2011 18:30'! newContour contours ifNil: [ contours := OrderedCollection new ]. currentContour := contours add: OrderedCollection new.! ! !AthensPolygon methodsFor: 'drawing' stamp: 'IgorStasenko 5/2/2011 04:48'! paintFillsUsing: aPaint on: anAthensCanvas "This method is a part of rendering dispatch Canvas->receiver->paint" ^ aPaint fillPolygon: self on: anAthensCanvas! ! !AthensPolygon methodsFor: 'conversion' stamp: 'IgorStasenko 4/29/2011 18:29'! moveTo: aPoint " create a new contour " self newContour. currentContour add: aPoint.! ! !AthensPolygon methodsFor: 'conversion' stamp: 'IgorStasenko 5/1/2011 22:11'! finish "Finally convert contours to arrays" contours := contours collect: [:ea | ea asArray ]! ! !AthensPolygonTester commentStamp: ''! I implementing a simple and efficient algorithm to test whether given point lies withing a polygon or not. A polygon is a collection of points 1...size.! !AthensPolygonTester methodsFor: 'testing' stamp: 'IgorStasenko 4/19/2013 16:29'! includesPoint: aPoint " Thanks to Google and Randolph Franklin i don't have to reinvent this very simple algorithm. See [ 1 ] for details, copyrights etc. [1] http://www.ecse.rpi.edu/Homepages/wrf/Research/Short_Notes/pnpoly.html " | inside testX testY i j size | inside := false. i := 1. size := polygon size. j := size. testX := aPoint x. testY := aPoint y. [ i <= size ] whileTrue: [ | pi pj | pi := polygon at: i. pj := polygon at: j. (((pi y > testY) ~= (pj y > testY)) and: [ testX < ( pj x - pi x * (testY - pi y) / ( pj y - pi y ) + pi x ) ]) ifTrue: [ inside := inside not ]. j := i. i := i + 1. ]. ^ inside ! ! !AthensPolygonTester methodsFor: 'accessing' stamp: 'IgorStasenko 4/19/2013 15:56'! polygon: poly polygon := poly! ! !AthensQuadSegment commentStamp: 'IgorStasenko 3/7/2012 13:32'! i represent a quadric Bezier path segment. Any quadratic spline can be expressed as a cubic (where the cubic term is zero). The end points of the cubic will be the same as the quadratic's. CP0 = QP0 CP3 = QP2 The two control points for the cubic are: CP1 = QP0 + 2/3 *(QP1-QP0) CP2 = QP2 + 2/3 *(QP1-QP2) ! !AthensQuadSegment methodsFor: 'initialize-release' stamp: 'IgorStasenko 3/26/2011 16:52'! from: pt0 via: pt1 to: p via := pt1. to := p.! ! !AthensQuadSegment methodsFor: 'accessing' stamp: 'IgorStasenko 3/26/2011 16:52'! to ^ to! ! !AthensQuadSegment methodsFor: 'accessing' stamp: 'IgorStasenko 3/26/2011 16:52'! endPoint ^ to! ! !AthensQuadSegment methodsFor: 'accessing' stamp: 'IgorStasenko 3/26/2011 16:52'! via ^ via! ! !AthensQuadSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 04:40'! accept: aVisitor ^ aVisitor quadricBezierSegment: self! ! !AthensQuadSegment methodsFor: 'visitor' stamp: 'IgorStasenko 4/18/2013 05:22'! sendCommandTo: aBuilder ^ aBuilder curveVia: via to: to ! ! !AthensQuartzSurface commentStamp: ''! The Quartz surface is used to render cairo graphics targeting the Apple OS X Quartz rendering system. ! !AthensQuartzSurface class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/17/2012 17:33'! registerSurface: quartzSurface "we cannot use SurfacePlugin for quartz surfaces" ^ nil ! ! !AthensQuartzSurface class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/17/2012 17:36'! finalizeResourceData: data | handle contextHandle | handle := data first. " id := data second. - id is not used " contextHandle := data third. self destroyContextHandle: contextHandle. self destroySurfaceHandle: handle. ! ! !AthensQuartzSurface class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/17/2012 17:02'! primImage: aFormat width: aWidth height: aHeight "Creates a Quartz surface backed by a CGBitmap. The surface is created using the Device RGB (or Device Gray, for A8) color space. All Cairo operations, including those that require software rendering, will succeed on this surface. " ^self nbCall: #(AthensQuartzSurface cairo_quartz_surface_create (int aFormat, int aWidth, int aHeight) ) ! ! !AthensSceneView commentStamp: ''! i am simple morph for representing some scene. The scene is any object which implements #renderOn: method, or a block with single argument. (an argument passed is an Athens canvas). I implement a simple view panning and zooming with mouse drag and mouse-wheel (correspondigly). Example1: open scene view, by passing a simple rendering block. | view | view := AthensSceneView new. view scene: [:canvas | canvas surface clear: Color black. canvas setPaint: Color red. canvas drawShape: (0@0 corner:120@100) ]. view openInWindow. Example2: open scene view on imported SVG file (note you need 'Athens-SVG' package loaded): | view | view := AthensSceneView new. view scene: (AthensSVGConverter fromFile: 'lion.svg'). view openInWindow. ! !AthensSceneView methodsFor: 'session management' stamp: 'IgorStasenko 4/21/2013 04:40'! createSurface | extent | extent := self extent asIntegerPoint. (scene respondsTo: #createSurface:) ifTrue: [ surface := scene createSurface: extent. ] ifFalse: [ surface := AthensCairoSurface extent: extent]. ! ! !AthensSceneView methodsFor: 'event handling' stamp: 'IgorStasenko 4/21/2013 05:44'! mouseUp: evt "self halt." self resetState: #panning! ! !AthensSceneView methodsFor: 'accessing' stamp: 'IgorStasenko 6/3/2013 14:27'! keepRefreshing: aBoolean keepRefreshing := aBoolean. keepRefreshing ifTrue: [ self startStepping ].! ! !AthensSceneView methodsFor: 'state tracking' stamp: 'IgorStasenko 4/21/2013 05:39'! setState: stateName state at: stateName put: true. "receiver's state changed" self changed.! ! !AthensSceneView methodsFor: 'session management' stamp: 'IgorStasenko 4/21/2013 04:37'! checkSession session == Smalltalk session ifFalse: [ self initializeForNewSession ]! ! !AthensSceneView methodsFor: 'event handling' stamp: 'IgorStasenko 4/22/2013 15:00'! mouseWheel: event "Handle a mouseWheel event." | center zoom | center := transform inverseTransform: (event cursorPoint - bounds origin). zoom := 1. event direction = #up ifTrue: [ zoom := 1.25 ]. event direction = #down ifTrue: [ zoom := 1/1.25 ]. (self inState: #zooming) ifTrue: [ self updateZoom: zoom cursor: event cursorPoint. ] ifFalse: [ self startZooming: zoom center: center. ] ! ! !AthensSceneView methodsFor: 'event handling' stamp: 'IgorStasenko 4/21/2013 05:02'! handlesMouseDown: evt ^ true! ! !AthensSceneView methodsFor: 'accessing' stamp: 'IgorStasenko 4/21/2013 05:51'! scene ^ scene! ! !AthensSceneView methodsFor: 'event handling' stamp: 'IgorStasenko 4/21/2013 05:13'! handlesMouseOver: evt ^ true! ! !AthensSceneView methodsFor: 'colors' stamp: 'IgorStasenko 4/21/2013 15:01'! backgroundColor ^ Color gray! ! !AthensSceneView methodsFor: 'zoom animation' stamp: 'IgorStasenko 4/22/2013 14:41'! startZooming: zoom center: center | start end | start := Time millisecondClockValue. end := start + 250. self setState: #zooming value: { center. transform copy. zoom. start. end}. self startStepping! ! !AthensSceneView methodsFor: 'initialize-release' stamp: 'IgorStasenko 8/8/2013 18:37'! initialize super initialize. keepRefreshing := false. transform := AthensAffineTransform new. self hResizing: #spaceFill. self vResizing: #spaceFill. color := Color transparent. state := Dictionary new. self extent: self minimumExtent. ! ! !AthensSceneView methodsFor: 'state tracking' stamp: 'IgorStasenko 4/21/2013 05:37'! inState: stateName ^ (state at: stateName ifAbsent: nil) notNil! ! !AthensSceneView methodsFor: 'layout' stamp: 'IgorStasenko 4/21/2013 05:39'! layoutChanged "react on morph resize" super layoutChanged. surface ifNotNil: [ self extent asIntegerPoint ~= surface extent ifTrue: [ self createSurface ] ]. ! ! !AthensSceneView methodsFor: 'zoom animation' stamp: 'IgorStasenko 4/22/2013 14:22'! stepTime ^ 0! ! !AthensSceneView methodsFor: 'event handling' stamp: 'IgorStasenko 4/21/2013 06:15'! mouseMove: evt self inState: #panning do: [ :startPanAndPos | | delta | delta := startPanAndPos first + ( evt cursorPoint - startPanAndPos second ). transform x: delta x; y: delta y. self changed. ] ! ! !AthensSceneView methodsFor: 'drawing' stamp: 'IgorStasenko 4/26/2013 14:46'! showDebugInfo ^ true ! ! !AthensSceneView methodsFor: 'drawing' stamp: 'IgorStasenko 8/12/2013 15:18'! renderScene self checkSession. scene ifNotNil: [ surface drawDuring: [ :acanvas | surface clear. acanvas pathTransform loadAffineTransform: transform. scene isBlock ifTrue: [ scene cull: acanvas cull: self ] ifFalse: [ scene renderOn: acanvas ] ] ]! ! !AthensSceneView methodsFor: 'state tracking' stamp: 'IgorStasenko 4/21/2013 05:39'! resetState: stateName state at: stateName put: nil. "receiver's state changed" self changed.! ! !AthensSceneView methodsFor: 'drawing' stamp: 'IgorStasenko 12/21/2013 02:17'! drawOn: canvas | px py | canvas fillRectangle: bounds color: self backgroundColor. self renderScene. surface displayOnMorphicCanvas: canvas at: bounds origin. " translucentImage: surface asForm at: bounds origin." self showDebugInfo ifTrue: [ px := transform x printShowingDecimalPlaces: 3. py := transform y printShowingDecimalPlaces: 3. canvas drawString: 'zoom: ' , (transform sx printShowingDecimalPlaces: 3) , ' pan: ' , px , ' @ ' , py at: bounds origin font: nil color: Color white ]! ! !AthensSceneView methodsFor: 'accessing' stamp: 'IgorStasenko 4/25/2013 01:19'! scene: aScene scene := aScene. self changed.! ! !AthensSceneView methodsFor: 'state tracking' stamp: 'IgorStasenko 4/21/2013 05:45'! inState: stateName do: aBlock ^ (state at: stateName ifAbsent: nil) ifNotNil: aBlock ! ! !AthensSceneView methodsFor: 'session management' stamp: 'IgorStasenko 4/21/2013 04:40'! initializeForNewSession self createSurface. session := Smalltalk session. ! ! !AthensSceneView methodsFor: 'state tracking' stamp: 'IgorStasenko 4/21/2013 05:39'! setState: stateName value: aValue state at: stateName put: aValue. "receiver's state changed" self changed.! ! !AthensSceneView methodsFor: 'zoom animation' stamp: 'IgorStasenko 6/1/2013 14:09'! step self inState: #zooming do: [ :zoomState | | now start end center targetZoom factor | now := Time millisecondClockValue. start := zoomState at: 4. end := zoomState at: 5. (now between: start and:end) ifFalse: [ now := end. self resetState: #zooming. self stopStepping ]. transform := (zoomState at: 2) copy. center := zoomState at: 1. factor := (now-start)/(end - start ). targetZoom := zoomState at: 3. targetZoom := 1* (1-factor) + (targetZoom * factor). transform translateBy: center; scaleBy:targetZoom; translateBy: center negated. ]. self changed. ! ! !AthensSceneView methodsFor: 'event handling' stamp: 'IgorStasenko 4/21/2013 05:41'! mouseEnter: evt self setState: #mouseIn! ! !AthensSceneView methodsFor: 'initialize-release' stamp: 'IgorStasenko 4/21/2013 06:50'! minimumExtent ^ 300@300! ! !AthensSceneView methodsFor: 'event handling' stamp: 'IgorStasenko 4/21/2013 06:01'! handlesMouseWheel: event ^ true! ! !AthensSceneView methodsFor: 'event handling' stamp: 'IgorStasenko 4/21/2013 06:12'! mouseDown: evt | pos | pos := evt cursorPoint. "left button" evt redButtonPressed ifTrue: [ self setState: #panning value: { transform x@transform y. pos } ]. ! ! !AthensSceneView methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 6/3/2013 14:27'! stopStepping keepRefreshing ifFalse: [ ^ super stopStepping ]! ! !AthensSceneView methodsFor: 'event handling' stamp: 'IgorStasenko 4/21/2013 05:44'! mouseLeave: evt self resetState: #mouseIn; resetState: #panning.! ! !AthensSceneView methodsFor: 'zoom animation' stamp: 'IgorStasenko 4/22/2013 15:01'! updateZoom: zoom cursor: cursorPoint | zoomState targetZoom start end now fraction newCenter | zoomState := state at:#zooming. "change the target zoom and increase time a bit" targetZoom := zoomState at: 3. start := zoomState at: 4. end := zoomState at: 5. now := Time millisecondClockValue. (now > end) ifTrue: [ now := end ]. "interpolate linearly the target zoom factor over time start ... end" fraction := (now - start) / (end - start). "zoom goes from 1..target zoom" targetZoom := 1*(1-fraction) + (targetZoom * fraction). self step. "to update transform" zoomState at: 3 put: targetZoom * zoom. newCenter := transform inverseTransform: (cursorPoint - bounds origin). zoomState at: 1 put: newCenter. zoomState at: 2 put: transform copy. zoomState at: 4 put: now. zoomState at: 5 put: now + 250 . ! ! !AthensShape commentStamp: ''! This class represents an interface, which should be supported by all shapes used for drawing with Athens framework. Shapes do not have to inherit directly from me, for example Rectangle implements my protocol (via extensions), and as result can be used as a valid shape for drawing with Athens.! !AthensShape methodsFor: 'converting' stamp: 'IgorStasenko 5/6/2013 05:32'! asAthensShapeOn: canvas "Receiver is a shape, no conversion is needed." ^ self! ! !AthensShape methodsFor: 'drawing' stamp: 'IgorStasenko 12/20/2011 18:36'! paintFillsUsing: aPaint on: anAthensCanvas "This method is a part of rendering dispatch Canvas->receiver->paint" self subclassResponsibility! ! !AthensSimplePathBuilder commentStamp: ''! i building path containing from AthensPathSegment. the resulting path is backend neutral (while different backend may implement own builder which is more efficient)! !AthensSimplePathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/26/2011 16:45'! lineTo: aPoint ^ self addSegment: (AthensLineSegment new point: (self toAbsolute: aPoint)). ! ! !AthensSimplePathBuilder methodsFor: 'private' stamp: 'IgorStasenko 3/26/2011 16:43'! toAbsolute: aPoint | pt | pt := absolute ifTrue: [ aPoint ] ifFalse: [ lastSegment endPoint + aPoint ]. "note the coordinate to calculate the path's bounding box" xMin ifNil: [ xMin := xMax := pt x. yMin := yMax := pt y. ] ifNotNil: [ xMin := pt x min: xMin. yMin := pt y min: yMin. xMax := pt x max: xMax. yMax := pt y max: yMax. ]. ^ pt! ! !AthensSimplePathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/26/2011 16:47'! close "close the current contour" self addSegment: (AthensCloseSegment new point: contourStartPt). contourStartPt := nil. open := false! ! !AthensSimplePathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/26/2011 16:51'! curveVia: cp1 to: aPoint | pt1 pt2 | "Quad bezier curve" pt1 := self toAbsolute: cp1. pt2 := self toAbsolute: aPoint. ^ self addSegment: ( AthensQuadSegment new from: lastSegment endPoint via: pt1 to: pt2) ! ! !AthensSimplePathBuilder methodsFor: 'path commands' stamp: 'JochenRick 1/8/2014 08:11'! reflectedCurveVia: cp2 to: aPoint "Reflected cubic bezier curve" | pt1 pt2 pt3 | pt2 := self toAbsolute: cp2. pt1 := lastSegment isCubic ifTrue: [ lastSegment via2reflected ] ifFalse: [ lastSegment endPoint ]. pt3 := self toAbsolute: aPoint. ^ self addSegment: ( AthensCubicSegment new from: lastSegment endPoint via: pt1 and: pt2 to: pt3) ! ! !AthensSimplePathBuilder methodsFor: 'accessing' stamp: 'IgorStasenko 3/26/2011 19:50'! pathStart ^ pathStart! ! !AthensSimplePathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/26/2011 16:50'! moveTo: aPoint " move command always starts a new contour " contourStartPt := self toAbsolute: aPoint. "collapse multiple moves to a single one" lastSegment isMove ifTrue: [ lastSegment point: contourStartPt. ^ self ]. self addSegment: (AthensMoveSegment new point: contourStartPt; reopen: open). open := true.! ! !AthensSimplePathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 13:37'! cwArcTo: endPt angle: rot " angle should be specified in radians " ^ self addSegment: (AthensCWArcSegment new endPoint: (self toAbsolute: endPt) angle: rot). ! ! !AthensSimplePathBuilder methodsFor: 'initialize-release' stamp: 'IgorStasenko 4/18/2013 14:26'! initialize "A new path always starts from implicit (moveTo:0@0) segment. If next segment is moveTo: , the point of already existing move segment will be changed, avoiding creating extra move segments. " absolute := false. contourStartPt := ZeroPoint. pathStart := lastSegment := (AthensMoveSegment new point: ZeroPoint).! ! !AthensSimplePathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/26/2011 19:26'! curveVia: cp1 and: cp2 to: aPoint "Cubic bezier curve" | pt1 pt2 pt3 | "Quad bezier curve" pt1 := self toAbsolute: cp1. pt2 := self toAbsolute: cp2. pt3 := self toAbsolute: aPoint. ^ self addSegment: ( AthensCubicSegment new from: lastSegment endPoint via: pt1 and: pt2 to: pt3) ! ! !AthensSimplePathBuilder methodsFor: 'accessing' stamp: 'IgorStasenko 3/26/2011 19:40'! pathBounds ^ xMin@yMin corner: xMax@yMax! ! !AthensSimplePathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/21/2011 03:40'! relative absolute := false.! ! !AthensSimplePathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/21/2011 03:40'! absolute absolute := true.! ! !AthensSimplePathBuilder methodsFor: 'private' stamp: 'IgorStasenko 3/26/2011 16:32'! addSegment: aSegment lastSegment next: aSegment. lastSegment := aSegment. ! ! !AthensSimplePathBuilder methodsFor: 'creating path' stamp: 'IgorStasenko 4/18/2013 17:47'! createPath: aBlock "aBlock value: self ...." aBlock value: self. ^ pathStart! ! !AthensSimplePathBuilder methodsFor: 'path commands' stamp: 'IgorStasenko 3/7/2012 13:41'! ccwArcTo: endPt angle: rot " angle should be specified in radians " ^ self addSegment: (AthensCCWArcSegment new endPoint: (self toAbsolute: endPt) angle: rot). ! ! !AthensSimpleTreeNode commentStamp: 'TorstenBergmann 2/12/2014 22:17'! A node in an AthensTreeView! !AthensSimpleTreeNode methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/3/2013 23:55'! midBottom ^ originX +(extent x *0.5) @ (originY + extent y)! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 22:09'! extent: anObject extent := anObject! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 22:38'! width ^ extent x! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 22:09'! box ^ box! ! !AthensSimpleTreeNode methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/4/2013 00:32'! renderOn: aCanvas aCanvas setPaint: color. aCanvas drawShape: (originX @ originY extent: extent). " children do: [ :each | each renderOn: aCanvas ]. [ ^ self ] value. " children do: [ :each | | path | "we cache the path connecting each child and its parent, to not recreate it each time" path := aCanvas cacheAt: each ifAbsentPut: [ | midTop midBot | midTop := self midBottom. midBot := each midTop. aCanvas createPath: [:builder | builder absolute; moveTo: self midBottom; curveVia: midTop x@midBot y and: midBot x@ midTop y to: midBot "lineTo: each midTop" ]]. aCanvas setStrokePaint: (Color red alpha:0.5). aCanvas drawShape: path. each renderOn: aCanvas ]! ! !AthensSimpleTreeNode methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/3/2013 22:10'! children ^ children! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 23:47'! originY ^ originY! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 23:13'! originY: aNumber originY := aNumber! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 22:09'! subject ^ subject! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 23:29'! color: aColor color := aColor! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 22:38'! height ^ extent y! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 23:12'! layoutHorizontally: center | pos | "position ourselves in the middle X" originX := center - (self width * 0.5). "childs" pos := center - (self layoutWidth *0.5). children do: [ :each | each layoutHorizontally: pos + (each layoutWidth *0.5). pos := pos + each layoutWidth + self spacingBetweenChilds. ]! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 22:09'! box: anObject box := anObject! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 22:09'! extent ^ extent! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 23:16'! layoutWidth ^ layoutWidth ifNil: [ | childWidth | childWidth := 0. children isEmpty ifFalse: [ children do: [ :each | childWidth := childWidth + each layoutWidth ]. childWidth := childWidth + (self spacingBetweenChilds * (children size-1)). ]. layoutWidth := self width max: childWidth. ]. ! ! !AthensSimpleTreeNode methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/3/2013 23:55'! midTop ^ originX +(extent x *0.5) @ originY ! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 22:09'! subject: anObject subject := anObject! ! !AthensSimpleTreeNode methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/3/2013 22:10'! children: aCollection children := aCollection! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 23:28'! color ^ color ! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 22:37'! spacingBetweenChilds ^ 10! ! !AthensSimpleTreeNode methodsFor: 'accessing' stamp: 'IgorStasenko 5/3/2013 23:47'! originX ^ originX! ! !AthensStrokePaint commentStamp: ''! I representing a stroke paint object used by Athens. My subclasses provide backend-specific implementation. I am more serving to define the common protocols and requirements for all backends (such as defaults). IMPORTANT NOTE: a stroke paint object provides a protocol only for setting stroke properties, but not retrieving them back. This is intentionally, because the way how these properties is managed are highly backend-specific. The stroke paint has following properties: - fill paint. A paint to use for filling strokes. Can be any athens basic paint, except from stroke one. - stroke width. Can be set using #width: Default: if width is not set explicitly for stroke paint, it is assumed to be equal to 1.0. - join style. Currently there are 3 kinds of joins supported: bevel miter round To set join style for paint, use #joinBevel, #joinMiter or #joinRound methods. Default: if join style is not explicitly set for stroke paint, it will use bevel join style. - cap style supported: butt, round and square. To set cap style, use #capButt, #capRound or #capSquare methods. Default: if cap style is not explicitly set for stroke paint, it will use butt cap style. - miter limit, set with #miterLimit: accessor. (default and meaning of limit is not yet determined) Dashes: stroke can use dashing. Dash is special kind of stroke which won't draw a continuous stroke connecting path segments, but instead stroke with alternating fill-gap style , defined by provided input. Protocol: paint dashes: dashPattern offset: anOffset. The dash pattern is a simple collection of alternating lengths, like: #("fill" 50 "gap" 50) in this example , first 50 length units of path will be filled with stroke, and next 50 will be skipped, forming a gap, then again filled and again skipped, and so on until path ends. The dash pattern can contain as many length elements as needed. Just remember that each odd element represents length to fill with stroke, and each even element, length to skip, while traversing along the path. The offset controls the shift in length units, relative to path start. Default: if dash is not explicitly set for stroke paint, it will fill the path using continuous stroke (no gaps). ! !AthensStrokePaint methodsFor: 'accessing' stamp: 'IgorStasenko 9/3/2013 13:10'! width: anObject "set the stroke width" width := anObject! ! !AthensStrokePaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/29/2011 15:28'! miterLimit: anObject miterLimit := anObject! ! !AthensStrokePaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/29/2011 15:28'! fillPaint: anObject fillPaint := anObject! ! !AthensStrokePaint methodsFor: 'setting join styles' stamp: 'IgorStasenko 9/3/2013 14:19'! joinBevel "Set receiver to use bevel join style" self subclassResponsibility! ! !AthensStrokePaint methodsFor: 'setting join styles' stamp: 'IgorStasenko 9/3/2013 14:19'! joinMiter "Set receiver to use miter join style" self subclassResponsibility! ! !AthensStrokePaint methodsFor: 'initialize-release' stamp: 'IgorStasenko 9/3/2013 14:18'! initialize self setDefaults.! ! !AthensStrokePaint methodsFor: 'setting cap styles' stamp: 'IgorStasenko 9/3/2013 13:08'! capSquare "Set this paint to use square cap style" self subclassResponsibility! ! !AthensStrokePaint methodsFor: 'setting join styles' stamp: 'IgorStasenko 9/3/2013 14:19'! joinRound "Set receiver to use round join style" self subclassResponsibility! ! !AthensStrokePaint methodsFor: 'setting dashes' stamp: 'IgorStasenko 9/3/2013 13:36'! dashes: anAlternateCollectionOfLenghts offset: anOffset 'self dashes: #( "fill" 20 "gap" 10 "fill" 35 "gap" 30) offset: 0. '. self subclassResponsibility ! ! !AthensStrokePaint methodsFor: 'converting' stamp: 'IgorStasenko 4/27/2012 11:12'! asStrokePaintOn: aCanvas "receiver is stroke paint already" ^ self! ! !AthensStrokePaint methodsFor: 'setting cap styles' stamp: 'IgorStasenko 9/3/2013 13:08'! capRound "Set this paint to use round cap style" self subclassResponsibility! ! !AthensStrokePaint methodsFor: 'initialize-release' stamp: 'IgorStasenko 9/3/2013 13:13'! setDefaults "Set the default values for strokes" width := 1. self capButt; joinBevel; miterLimit: 4.0 ! ! !AthensStrokePaint methodsFor: 'setting cap styles' stamp: 'IgorStasenko 9/3/2013 13:08'! capButt "Set this paint to use butt cap style" self subclassResponsibility! ! !AthensSurface commentStamp: ''! I representing a surface, where all drawing operations will happen. I also having a number of factory methods to create paints, paths and other objects involved in drawing. AthensSurface is an abstract, while subclasses implement a specific kind of surface for one or another backend. The primary role of AthensSurface class is to define a public protocol for all Athens surfaces, which can be used by applications which using Athens framework. To get a new surface, use: extent: x@y for surfaces which don't need to have dimensions specified, it would just #new.! !AthensSurface methodsFor: 'clipping' stamp: 'IgorStasenko 4/21/2011 14:47'! clipBy: aRectangle during: aBlockClosure self subclassResponsibility.! ! !AthensSurface methodsFor: 'paints' stamp: 'IgorStasenko 4/27/2012 12:16'! createRadialGradient: colorRamp center: aCenter radius: aRadius focalPoint: fp self subclassResponsibility! ! !AthensSurface methodsFor: 'public' stamp: 'IgorStasenko 12/20/2011 15:38'! clear "clear the surface" self subclassResponsibility! ! !AthensSurface methodsFor: 'private' stamp: 'IgorStasenko 3/22/2011 22:40'! releaseCanvas currentCanvas := nil! ! !AthensSurface methodsFor: 'paints' stamp: 'IgorStasenko 3/8/2012 13:46'! createFormPaint: aForm self subclassResponsibility.! ! !AthensSurface methodsFor: 'caching' stamp: 'IgorStasenko 10/12/2012 03:22'! cacheAt: anObject ifAbsentPut: aBlock "Answer an object from surface's cache identified by anObject, if there is no cached object under such identifier, evaluate a block and put it into cache. Then answer the result of evaluation. A surface using identity comparison for object identifiers. " self subclassResponsibility! ! !AthensSurface methodsFor: 'converting' stamp: 'sig 2/29/2012 21:51'! asForm "Answer a Form , which contains a bits, converted from surface " self subclassResponsibility! ! !AthensSurface methodsFor: 'masking' stamp: 'IgorStasenko 3/27/2011 18:16'! maskEnabled self subclassResponsibility! ! !AthensSurface methodsFor: 'caching' stamp: 'IgorStasenko 10/12/2012 03:56'! flushCacheAt: anObject "Flush (delete) any cached value(s) identified by given object, anObject. A surface using identity comparison for object identifiers. Answer receiver. " self subclassResponsibility! ! !AthensSurface methodsFor: 'paints' stamp: 'IgorStasenko 4/27/2012 12:17'! createRadialGradient: colorRamp center: aCenter radius: aRadius "by default, focal point coincede with center" ^ self createRadialGradient: colorRamp center: aCenter radius: aRadius focalPoint: aCenter ! ! !AthensSurface methodsFor: 'paths' stamp: 'FernandoOlivero 1/13/2012 03:08'! createRectanglePath: aRectangle ^ aRectangle! ! !AthensSurface methodsFor: 'paints' stamp: 'IgorStasenko 12/20/2011 15:25'! createSolidColorPaint: aColor "Answer an instance of AthensPaint, valid for use with given surface" self subclassResponsibility! ! !AthensSurface methodsFor: 'paints' stamp: 'IgorStasenko 11/30/2013 08:22'! createLinearGradient: colorRamp origin: pt1 corner: pt2 self deprecated: 'Use #createLinearGradient:start:stop: instead' on: '12 April 2013' in: 'ConfigurationOfAthens 2.0'. "was subclassResponsibility"! ! !AthensSurface methodsFor: 'public' stamp: 'IgorStasenko 3/7/2012 15:06'! drawDuring: aBlock "You may draw on receiver only when inside a block and only using provided canvas object. This ensures releasing system resources used after finishing drawing" currentCanvas ifNotNil: [ self attemptToRecurseDrawing ]. [ currentCanvas := self newCanvas. aBlock value: currentCanvas. ] ensure: [ self releaseCanvas. currentCanvas := nil. ].! ! !AthensSurface methodsFor: 'paints' stamp: 'IgorStasenko 4/12/2013 09:59'! createLinearGradient: colorRamp start: pt1 stop: pt2 "This protocol is deprecated. Use #createLinearGradient: start:stop: instead" self shouldNotImplement ! ! !AthensSurface methodsFor: 'public' stamp: 'IgorStasenko 9/1/2012 20:06'! clear: clearColor "clear the surface" self subclassResponsibility! ! !AthensSurface methodsFor: 'paints' stamp: 'IgorStasenko 4/27/2012 11:20'! createStrokePaintFor: aPaint "Answer an instance of AthensPaint, valid for use as stroke paint on receiver, using an argument, paint for fills" self subclassResponsibility! ! !AthensSurface methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 12/21/2013 02:16'! displayOnMorphicCanvas: canvas at: aPoint "display receiver on morphic canvas" self subclassResponsibility! ! !AthensSurface methodsFor: 'masking' stamp: 'IgorStasenko 3/27/2011 18:15'! enableMask self subclassResponsibility! ! !AthensSurface methodsFor: 'private' stamp: 'IgorStasenko 3/21/2011 02:35'! newCanvas "Answer a preinitialized instance of AthensCanvas. Private to receiver and its subclasses, override seldom" ^ AthensCanvas on: self ! ! !AthensSurface methodsFor: 'paths' stamp: 'IgorStasenko 3/26/2011 19:32'! createPath: aPathBuilder "Create a path from provided path builder instance" self subclassResponsibility! ! !AthensSurface methodsFor: 'masking' stamp: 'IgorStasenko 3/27/2011 18:15'! disableMask self subclassResponsibility! ! !AthensSurface methodsFor: 'rendering dispatch' stamp: 'IgorStasenko 8/30/2013 16:38'! fillRectangle: aRectangle withSolidColor: aColor self subclassResponsibility! ! !AthensSurface class methodsFor: 'instance creation' stamp: 'sig 2/29/2012 21:43'! extent: aPoint "Create a new surface with given extent. Note that some surfaces may not support this method, since they may represent an infinite surface." self subclassResponsibility! ! !AthensSurfaceExamples commentStamp: 'IgorStasenko 1/17/2012 16:42'! AthensCairoSurfaceExamples example1. AthensCairoSurfaceExamples example2. AthensBalloonSurfaceExamples example6.! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/8/2014 15:56'! example1 " self example1 " self openViewOn: [ :can | can pathTransform restoreAfter: [ can pathTransform translateX: 30 Y: 30. can pathTransform rotateByDegrees: 35. can setPaint: (Color red). can setShape: (-20@ -20 corner: 20@ 20). 2 timesRepeat: [ can draw. can setPaint: (Color green alpha:0.5)]. ]. ]. ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 3/21/2012 18:58'! example10 " draw a rounded rectangle, using the arc segments AthensCairoSurfaceExamples example10. " | surf | surf := self newSurface: 440@440. surf drawDuring: [:can | | p | surf clear. can pathTransform scaleBy: 3; translateX: 10 Y: 10. p:= can createPath: [:path | |halfPi | halfPi := Float pi /2. path relative; moveTo: 10@0; lineTo: 40@0; ccwArcTo: 10@10 angle: halfPi; lineTo: 0@40; cwArcTo: -10@10 angle: halfPi; lineTo: -40@0; cwArcTo: -10@ -10 angle: halfPi; lineTo: 0@ -40; ccwArcTo: 10@ -10 angle: halfPi]. can setShape: p. can setPaint: Color white. can draw. can setStrokePaint: Color red. can draw ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 3/30/2012 11:29'! example3stroke " Draw simple stroke path, changing the transformation and colors to get some animated effects. AthensCairoSurfaceExamples example3stroke " | surf | surf := self newSurface: 400@400. surf drawDuring: [:can | | transform path | (can setStrokePaint: Color blue) width: 1. can pathTransform translateX: 200 Y: 200. can pathTransform scaleBy: 1. path := can createPath: [:pathbuilder | pathbuilder absolute; moveTo: -25 @ -25; curveVia: 25@ -25 to: 25@25; curveVia: -25@25 to: -25@ -25 ]. 1 to: 1000 do: [:i | (can setStrokePaint: Color random) width: 1. can pathTransform restoreAfter: [ can pathTransform rotateByDegrees: i*5. can pathTransform scaleBy: (1- ( i/2000)). can drawShape: path. ]. Display getCanvas drawImage: surf asForm at: 0@0. ] ]. ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/8/2014 15:57'! example2 " Draw a path on surface. self example2. " self openViewOn: [ :can | can setPaint: Color blue. can drawShape: ( can createPath: [:path | path absolute; lineTo: 50@0; lineTo: 50@50; lineTo: 0@100 ]) ]. ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/12/2013 10:13'! example6point1 "Draw two rectangles, filled by linear gradient. Note that it should produce same rectangles with exact same fills, because gradient paint coordinates are affected by pathTransform matrix. self example6 " | surf paint | surf := self newSurface: 100@200. paint := surf createLinearGradient: { 0->Color red . 1->Color green } start: 0@0 stop: 30@30. surf drawDuring: [:can | surf clear. can setPaint: paint. can drawShape: (0@0 corner: 50@50). ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/12/2013 10:14'! example6stroke " self example6stroke Draw two rectangles, stoked by linear gradient. Note that it should produce same rectangles with exact same fills, because gradient paint coordinates are affected by pathTransform matrix. " | surf paint | surf := self newSurface: 100@100. paint := surf createLinearGradient: { 0->Color red . 1->Color green } start: 0@0 stop: 50@50. surf drawDuring: [:can | | stroke | surf clear. stroke := can setStrokePaint: paint. stroke width: 4. can drawShape: (0@0 corner: 50@50). can pathTransform translateX: 50 Y: 50. can drawShape: (0@0 corner: 50@50). ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2012 18:25'! exampleDrawForm2 | surf font | surf := self newSurface: 300@300. surf drawDuring: [:can | surf clear. can pathTransform loadIdentity. can setShape: (0@0 corner: 300@300). can setPaint: Color black. can draw. can pathTransform scaleBy: 0.5; translateX: 60 Y: 60. (can setPaint: ThemeIcons helpIcon) repeat. can paintTransform scaleBy: 0.1; rotateByDegrees: 30. can draw. ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/9/2012 19:18'! exampleDrawText " self subclasses anyOne exampleDrawText " | surf font | font := LogicalFont familyName: 'Arial' pointSize: 20. surf := self newSurface: 300@100. surf drawDuring: [:can | "clear background" surf clear: Color white. "set font and color" can setFont: font. can setPaint: Color black. "translate an origin by font's ascent, otherwise we will see only things below baseline" can pathTransform translateX: 0 Y: (font getPreciseAscent). can drawString: 'Hello Athens!!'. ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/2/2012 20:15'! exampleStrokeRect " Draw a frame rectangle, rotate & transform it in a loop self exampleStrokeRect " | surf | surf := self newSurface: 400@400. surf drawDuring: [:can | | path | can pathTransform translateX: 200 Y: 200. can pathTransform scaleBy: 8. 1 to: 1000 do: [:i | (can setStrokePaint: Color random) width: 1. can pathTransform restoreAfter: [ can pathTransform rotateByDegrees: i*5. can pathTransform scaleBy: (1- ( i/2000)). surf clear. can drawShape: (0@0 corner: 25@25) ]. Display getCanvas drawImage: surf asForm at: 0@0. ] ]. ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/12/2013 10:14'! example7 "Draw two rectangles, filled by linear gradient. Rotate the gradient in a loop. Note that it should produce same rectangles with exact same fills, because gradient paint coordinates are affected by pathTransform matrix. " | surf paint | surf := self newSurface: 100@100. paint := surf createLinearGradient: { 0->Color red . 1->Color green } start: 0@0 stop: 50@50. surf drawDuring: [:can | 1 to: 10000 do: [:i | surf clear. can pathTransform loadIdentity. can paintTransform loadIdentity translateX: 15 Y: 15; rotateByDegrees: (i/10000 * 360). can setPaint: paint. can drawShape: (0@0 corner: 50@50). can pathTransform translateX: 50 Y: 50. can drawShape: (0@0 corner: 50@50). Display getCanvas drawImage: surf asForm at: 0@0 ]. ]. ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2012 18:20'! exampleDrawForm | surf surf2 font | surf2 := self newSurface: 100@100. surf2 drawDuring: [:c | c setPaint: (Color red alpha: 0.5) . c drawShape: (0@0 corner: 100@100). ]. surf := self newSurface: 300@300. surf drawDuring: [:can | surf clear. can pathTransform loadIdentity. can setShape: (0@0 corner: 300@300). can setPaint: Color black. can draw. can pathTransform translateX: 30 Y: 30. can setPaint: surf2. can draw. can pathTransform translateX: 30 Y: 30. can draw. ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/2/2012 20:09'! draw2Strings " self subclasses anyOne exampleDrawText " | surf font1 font2 ascent advance | font1 := LogicalFont familyName: 'Arial' pointSize: 10. font2 := LogicalFont familyName: 'Tahoma' pointSize: 20. ascent := font1 getPreciseAscent max: font2 getPreciseAscent. surf := self newSurface: 600@200. surf drawDuring: [:can | surf clear: Color white. can pathTransform loadIdentity. can pathTransform translateX: 30 Y: 30; scaleBy: 1.9. can setPaint: (Color black). can setFont: font1. can pathTransform translateX: 0 Y: ascent. advance := can drawString: 'Keep '. can setFont: font2. "The #drawString: method answers a cumulative advance of rendered string, so by translating origin with advance, we can draw another string on 'same' line " can pathTransform translateBy: advance. advance := can drawString: 'IT'. can setFont: font1. can pathTransform translateBy: advance. can drawString: 'in mind.'. ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 6/11/2012 02:19'! example9 " Fill the rectangle using image paint. " | surf paint f bf | surf := self newSurface: 200@200. surf form getCanvas fillRectangle: surf form boundingBox color: Color white. f := Form extent: 10@10 depth: 32. f getCanvas fillRectangle: (0@0 corner: 5@5) color: (Color red alpha: 0.1). f getCanvas fillRectangle: (5@5 corner: 10@10) color: (Color green alpha: 0.1). paint := surf createFormPaint: f. surf drawDuring: [:can | can setPaint: paint. can drawShape: (0@0 corner: 100@200). Display getCanvas drawImage: surf asForm at: 0@0 ]. ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/31/2012 00:56'! exampleUseForm | surf font form | form := Form extent: 100@100 depth: 32. form getCanvas fillRectangle: (0@0 corner: 30@30) color: (Color red). form getCanvas fillRectangle: (10@10 corner: 40@40) color: (Color green). form getCanvas fillRectangle: (20@20 corner: 50@50) color: (Color blue). surf := AthensCairoSurface fromForm: form. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/20/2011 15:35'! newSurface: extent self subclassResponsibility! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/7/2014 15:42'! drawFontMetrics " self drawFontMetrics " | font | font := LogicalFont familyName: 'Arial' pointSize: 10. self openViewOn: [ :can | can pathTransform restoreAfter: [ can pathTransform translateX: 30 Y: 30; scaleBy: 20. can setPaint: (Color r:1 g:0.9 b:0.9); drawShape: (0@0 corner: 400@ (font getPreciseHeight)). can setPaint: (Color r: 0.9 g: 0.9 b: 1); drawShape: (0@0 corner: 400@ (font getPreciseAscent+font getPreciseDescent)). (can setStrokePaint: Color green) width: 0.05. can drawShape: (can createPath: [:builder | builder moveTo: 0@0; lineTo: 0@font getPreciseAscent ] ). (can setStrokePaint: Color red) width: 0.05. can drawShape: (can createPath: [:builder | builder moveTo: 0@font getPreciseAscent; lineTo: 0@font getPreciseDescent ] ). (can setStrokePaint: Color blue) width: 0.05. can drawShape: (can createPath: [:builder | builder moveTo: 0@font getPreciseAscent; lineTo: 400@0 ] ). can setFont: font. can setPaint: (Color black). can pathTransform translateX: 0 Y: (font getPreciseAscent). can drawString: 'yh'. ] ] ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/27/2012 12:18'! example8 "Draw a rectangle filled by radial gradient. " | surf paint | surf := self newSurface: 200@200. paint := surf createRadialGradient: { 0->Color red . 1->Color green } center: 100@100 radius: 100. surf drawDuring: [:can | surf clear. can pathTransform loadIdentity. can setPaint: paint. can drawShape: (0@0 corner: 200@200). Display getCanvas drawImage: surf asForm at: 0@0 ]. ! ! !AthensSurfaceExamples class methodsFor: 'opening view' stamp: 'IgorStasenko 4/7/2014 15:37'! openViewOn: aBlock ^ AthensSceneView new scene: aBlock; openInWindow ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/7/2012 23:06'! exampleClip " self subclasses anyOne exampleClip " | surf | surf := self newSurface: 100@100. surf drawDuring: [:can | surf clear. can pathTransform loadIdentity. can setPaint: (Color blue). can drawShape: (0@0 corner: 100@ 100). can pathTransform translateX: -20 Y: -20. can clipBy: (20@20 corner: 80@80) during: [ can pathTransform translateX: 20 Y: 20. can setPaint: (Color red). can drawShape: (0@0 corner: 100@ 100). ] ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'sig 2/29/2012 22:21'! example4 " This example demostrates that same path could be reused multiple times when drawing. First, we creating a path, and later we can use it in #drawShape: command. " | surf path | surf := self newSurface: 100@100. path := surf createRectanglePath: (0@ 0 corner: 20@ 20). surf drawDuring: [:can | surf clear. can pathTransform loadIdentity. can setPaint: (Color red). can pathTransform translateX: 5 Y: 5. can drawShape: path. can setPaint: (Color blue). can pathTransform translateX: 5 Y: 5. can drawShape: path. ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 3/7/2012 17:28'! example5 " draw a hollow rectangle (frame) using lineTo/moveTo commands, with path, consisting of two contours: outer and inner one. Note how #moveTo: command implicitly starts new contour when inssued in the middle of command chain. " | surf | surf := self newSurface: 100@100. surf drawDuring: [:can | surf clear. can setPaint: Color blue. can drawShape: ( can createPath: [:path | path absolute; lineTo: 50@0; lineTo: 50@50; lineTo: 0@50; moveTo: 10@10; lineTo: 10@40; lineTo: 40@40; lineTo: 40@10 ]) ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 3/28/2012 14:03'! example3 " Draw simple filled path, changing the transformation and colors to get some animated effects. self example3 " | surf | surf := self newSurface: 800@800. surf drawDuring: [:can | | transform path | can setPaint: Color blue. can pathTransform translateX: 200 Y: 200. can pathTransform scaleBy: 6. path := can createPath: [:pathbuilder | pathbuilder absolute; moveTo: -25 @ -25; curveVia: 25@ -25 to: 25@25; curveVia: -25@25 to: -25@ -25 ]. 1 to: 1000 do: [:i | can setPaint: Color random. can pathTransform restoreAfter: [ can pathTransform rotateByDegrees: i*5. can pathTransform scaleBy: (1- ( i/2000)). can drawShape: path. ]. Display getCanvas drawImage: surf asForm at: 0@0. ] ]. ! ! !AthensSurfaceExamples class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/12/2013 10:13'! example6 "Draw two rectangles, filled by linear gradient. Note that it should produce same rectangles with exact same fills, because gradient paint coordinates are affected by pathTransform matrix. self example6 " | surf paint | surf := self newSurface: 100@200. paint := surf createLinearGradient: { 0->Color red . 1->Color green } start: 0@0 stop: 50@50. surf drawDuring: [:can | surf clear. can setPaint: paint. can drawShape: (0@0 corner: 50@50). can pathTransform translateX: 50 Y: 50; rotateByDegrees: 30. can drawShape: (0@0 corner: 50@50). ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !AthensTextBackground commentStamp: 'TorstenBergmann 2/12/2014 22:21'! Athens text background ! !AthensTextBackground methodsFor: 'accessing' stamp: 'IgorStasenko 10/28/2011 14:42'! color ^ color! ! !AthensTextBackground methodsFor: 'comparing' stamp: 'IgorStasenko 10/28/2011 14:31'! hash ^ color hash! ! !AthensTextBackground methodsFor: 'scanning' stamp: 'IgorStasenko 10/28/2011 14:31'! dominates: other ^ other class == self class! ! !AthensTextBackground methodsFor: 'accessing' stamp: 'IgorStasenko 10/28/2011 14:42'! color: anObject color := anObject! ! !AthensTextBackground methodsFor: 'printing' stamp: 'IgorStasenko 10/28/2011 14:32'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' code: '; print: color! ! !AthensTextBackground methodsFor: 'scanning' stamp: 'IgorStasenko 10/28/2011 14:31'! emphasizeScanner: scanner "Set the emphasis for text display" scanner textBackground: color! ! !AthensTextComposer commentStamp: 'TorstenBergmann 2/12/2014 22:20'! Compose text! !AthensTextComposer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 12:51'! lines ^ lines! ! !AthensTextComposer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/30/2011 19:14'! scan: aText for: scanner " scan text from starting index, answer the index of first character for potential next line" | index top | text := aText. scanner text: text. "edge case, text is empty " text isEmpty ifTrue: [ ^ scanner ]. scanner newLine: 1. index := 1. text runs withStartStopAndValueDo: [:start :stop :values | scanner setAttributes: values. start to: stop do: [:i | | ch | ch := text at: i. ch = Character cr ifTrue: [ scanner endLine: i - 1. scanner newLine: i + 1 ] ifFalse: [ scanner addCharacter: i. ] ] ]. scanner endLine: (text size). lines := scanner lines. "set the lines top offset" top := 0. lines do: [:line | line top: top. top := top + line height ]. ! ! !AthensTextComposer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/17/2011 12:42'! renderOn: aCanvas | renderer | renderer := AthensTextRenderer new. renderer render: text lines: lines on: aCanvas. ! ! !AthensTextComposer class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2011 16:07'! scan: aText for: scanner ^ self new scan: aText for: scanner! ! !AthensTextDisplayCommand commentStamp: 'IgorStasenko 2/6/2012 16:20'! An abstract base class for all text rendering commands. A text rendered takes a stream (or list) of my (sub)instances and in that way it renders the text! !AthensTextDisplayCommand methodsFor: 'accessing' stamp: 'IgorStasenko 11/10/2011 10:19'! insert: aCommands | nn | nn := next. next := aCommands. next tail next: nn! ! !AthensTextDisplayCommand methodsFor: 'accessing' stamp: 'IgorStasenko 11/10/2011 10:21'! do: aBlock | nn | nn := self. [ nn isNil ] whileFalse: [ aBlock value: nn. nn := nn next. ]! ! !AthensTextDisplayCommand methodsFor: 'copying' stamp: 'IgorStasenko 11/10/2011 10:47'! postCopy "unlink the copy by default" next := nil! ! !AthensTextDisplayCommand methodsFor: 'accessing' stamp: 'IgorStasenko 11/10/2011 10:12'! next ^ next! ! !AthensTextDisplayCommand methodsFor: 'rendering' stamp: 'IgorStasenko 10/30/2011 18:57'! renderOn: renderer self shouldBeImplemented ! ! !AthensTextDisplayCommand methodsFor: 'accessing' stamp: 'IgorStasenko 11/10/2011 10:15'! tail | nn | nn := self. [ nn next notNil ] whileTrue: [ nn := nn next ]. ^ nn! ! !AthensTextDisplayCommand methodsFor: 'accessing' stamp: 'IgorStasenko 11/10/2011 10:12'! next: anObject next := anObject! ! !AthensTextDisplayCommand methodsFor: 'accessing' stamp: 'IgorStasenko 11/10/2011 10:14'! addLast: aCommand self tail next: aCommand! ! !AthensTextLine commentStamp: 'IgorStasenko 2/6/2012 16:20'! I representing a single line of text! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2011 17:19'! endIndex ^ endIndex! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 11/7/2011 14:44'! heightAndDescent ^ height + maxDescent! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 10/5/2011 18:04'! height ^ height! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2011 17:19'! text ^ text! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2011 17:19'! height: anObject height := anObject! ! !AthensTextLine methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/10/2011 10:15'! initialize commands := tail := nil. width := height := maxAscent := maxDescent := 0.! ! !AthensTextLine methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/28/2011 12:41'! maxHeight: aHeight height := height max: aHeight! ! !AthensTextLine methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/10/2011 10:20'! addCommand: aCommand commands ifNil: [ tail := commands := aCommand. ] ifNotNil: [ tail next: aCommand ]. tail := tail tail. ! ! !AthensTextLine methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/5/2011 18:05'! top: aTop top := aTop! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 10/28/2011 11:00'! maxAscent ^ maxAscent! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2011 17:19'! width: anObject width := anObject! ! !AthensTextLine methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2011 16:10'! startIndex: index startIndex := index! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2011 17:19'! endIndex: anObject endIndex := anObject! ! !AthensTextLine methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/5/2011 18:04'! width ^ width! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 11/7/2011 14:43'! maxDescent: mascent maxDescent := mascent max: maxDescent! ! !AthensTextLine methodsFor: 'rendering' stamp: 'IgorStasenko 11/10/2011 12:23'! renderOn: aTextRenderer commands ifNil: [ ^ self ]. commands do: [ :cmd | cmd renderOn: aTextRenderer ]. ! ! !AthensTextLine methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/28/2011 12:43'! addWidth: aNumber width := width + aNumber.! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 11/21/2011 12:47'! top ^ top! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2011 17:19'! commands: anObject commands := anObject! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 11/21/2011 12:47'! bottom ^ top + self heightAndDescent! ! !AthensTextLine methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2011 16:48'! text: aText text := aText! ! !AthensTextLine methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/20/2011 10:30'! renderOn: anAthensTextRenderer x: aSmallInteger y: aSmallInteger3 self shouldBeImplemented.! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 10/28/2011 11:05'! maxAscent: mascent maxAscent := mascent max: maxAscent! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2011 17:19'! commands ^ commands! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 11/7/2011 14:36'! maxDescent ^ maxDescent! ! !AthensTextLine methodsFor: 'accessing' stamp: 'IgorStasenko 10/11/2011 17:19'! startIndex ^ startIndex! ! !AthensTextMorph commentStamp: ''! this class is subject of changes/removal. do not use it.! !AthensTextMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 12:23'! createParagraph | newParagraph | self setDefaultContentsIfNil. "...Code here to recreate the paragraph..." newParagraph := AthensParagraph new. newParagraph compose: text style: textStyle copy in: self container. wrapFlag ifFalse: ["Was given huge container at first... now adjust" newParagraph adjustRightX]. newParagraph focused: (self currentHand keyboardFocus == self). paragraph := newParagraph. self fit. ^ paragraph! ! !AthensTextMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 13:02'! selectionColor: aColor selectionColor := aColor. ! ! !AthensTextMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 12:18'! paragraph ^ paragraph ifNil: [ paragraph := self createParagraph ]. ! ! !AthensTextMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 12:42'! contents: stringOrText wrappedTo: width "Accept new text contents. Lay it out, wrapping to width. Then fit my height to the result." wrapFlag := true. super extent: width truncated@self height. self newContents: stringOrText! ! !AthensTextRenderTest commentStamp: 'TorstenBergmann 2/12/2014 22:20'! Visual tests for correct rendering of text using Athens! !AthensTextRenderTest class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/30/2012 19:01'! test5 | t c surf | "t := '12345 pi kl mn op gj the text must flow' " t := 'U' asText . t addAttribute: (TextFontReference toFont: ( LogicalFont familyName: 'Tahoma' pointSize: 10 )). c := AthensTextComposer scan: t for: AthensTextScanner new. surf := self surfaceClass extent: Display extent. surf drawDuring: [ :canvas | canvas setPaint: (Color yellow alpha: 0.5). canvas drawShape: (0@0 corner: 300@300). canvas pathTransform scaleBy: 1. 1 to: 20 do: [:i | c renderOn: canvas. canvas pathTransform translateBy: 10@0.1. ] ]. Display getCanvas translucentImage: surf form at: 100@100 ! ! !AthensTextRenderTest class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/2/2012 21:08'! testText | t | t := 'The safety Dconstraint is that the garbage collector MUST NOT collect any storage that then becomes needed to continue correct execution of the program. Should weak references be added, then garbage collection decisions become observable. Based on a suggestion from Cameron McCormack, we state the safety constraint as follows: So long as operational semantics of the remainder of the program execution includes the possibility that a reference to an object X may be dereferenced, then X MUST NOT be collected. Thus, the garbage collector is allowed to ignore any references that remain present in the semantic state, but which it can ascertain will never be dereferenced in any possible execution. This sets an upper bound on what state MAY be collected. Put another way, if the garbage collector ever reports that X has been collected, such as by nullifying a weak reference to X, if operational semantics of remaining execution requires the traversal of a strong (non-weak) reference to X, then the previous report demonstrates a safety violation. ' asText . t addAttribute: (TextFontReference toFont: ( LogicalFont familyName: 'Arial' pointSize: 8 )). t addAttribute: (TextEmphasis italic) from: 5 to: 100. t addAttribute: (TextColor new color: (Color red)) from: 10 to: 60. t addAttribute: (TextEmphasis italic) from: 100 to: 200. t addAttribute: (TextColor new color: Color green) from: 230 to: 360. t addAttribute: ( TextFontReference toFont: ( LogicalFont familyName: 'Tahoma' pointSize: 14)) from: 88 to: 200. ^ t! ! !AthensTextRenderTest class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/19/2011 14:39'! testBlitting | fnt form blt | fnt := LogicalFont familyName: 'Arial' pointSize: 24. form := fnt realFont glyphOf: $W destDepth: 8 colorValue: 1 subpixelPosition: 0. blt := BitBlt toForm: Display. blt sourceForm: form; destOrigin: 0@0; sourceOrigin: 0@0; halftoneForm: nil; combinationRule: 41; width: form width; height: form height; copyBitsColor: 0 alpha: 255 gammaTable: FreeTypeSettings current gammaTable ungammaTable: FreeTypeSettings current gammaInverseTable. " blt copyForm: form to: 100@100 rule: 41." Display forceToScreen. " Display getCanvas translucentImage: form at: 0@0. " ! ! !AthensTextRenderTest class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/30/2012 19:01'! test4 | t c surf | "t := '12345 pi kl mn op gj the text must flow' " t := 'Unfortunately this class has not been documented yet.' asText . t addAttribute: (TextFontReference toFont: ( LogicalFont familyName: 'Tahoma' pointSize: 10 )). t addAttribute: (TextColor new color: Color red) from: 3 to: 10. c := AthensTextComposer scan: t for: AthensTextScanner new. surf := self surfaceClass extent: Display extent. surf drawDuring: [ :canvas | canvas setPaint: (Color yellow alpha: 0.5). canvas drawShape: (0@0 corner: 300@300). canvas pathTransform scaleBy: 1. 1 to: 20 do: [:i | c renderOn: canvas. canvas pathTransform translateBy: 0.1@10. ] ]. Display getCanvas translucentImage: surf form at: 100@100 ! ! !AthensTextRenderTest class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/30/2012 18:59'! surfaceClass ^ AthensCairoSurface! ! !AthensTextRenderTest class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/30/2012 19:00'! test2 | t c surf | t := self testText. t addAttribute: (AthensTextBackground new color: (Color green alpha: 0.3 )) from: 1 to: 267. c := AthensTextComposer scan: t for: AthensTextScanner new. surf := self surfaceClass extent: Display extent. surf drawDuring: [ :canvas | canvas setPaint: (Color white ). canvas drawShape: (0@0 corner: 300@300). canvas pathTransform scaleBy: 1. canvas pathTransform translateX: 300 Y: 0. canvas setPaint: Color yellow. canvas pathTransform rotateByDegrees: 0. c renderOn: canvas ]. Display getCanvas translucentImage: surf form at: 0@0 ! ! !AthensTextRenderTest class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/2/2012 22:25'! testWindowRender | surf | surf := self surfaceClass extent: Display extent. surf drawDuring: [ :canvas | canvas pathTransform scaleBy: 1. canvas fullDrawMorph: self testWindow. ]. Display getCanvas translucentImage: surf asForm at: 0@0 ! ! !AthensTextRenderTest class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/30/2012 19:01'! test3 | t c surf | "t := '12345 pi kl mn op gj the text must flow' " t := 'qW' asText . t addAttribute: (TextFontReference toFont: ( LogicalFont familyName: 'Arial' pointSize: 8 )). c := AthensTextComposer scan: t for: AthensTextScanner new. surf := self surfaceClass extent: Display extent. surf drawDuring: [ :canvas | canvas setPaint: (Color yellow alpha: 0.5). canvas drawShape: (0@0 corner: 300@300). canvas pathTransform translateBy: 200@200. " canvas pathTransform rotateByDegrees: 90. " canvas pathTransform scaleBy: 4. 1 to: 10 do: [:i | canvas setPaint: (Color blue alpha: 0.5). canvas drawShape: (0@0 corner: 100@10). c renderOn: canvas. canvas pathTransform rotateByDegrees: 5. canvas pathTransform translateBy: 0 @11 . ]. ]. Display getCanvas translucentImage: surf form at: 100@100 ! ! !AthensTextRenderTest class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/21/2011 16:25'! testWindow ^ (AthensPluggableTextMorph on: self text: #testText accept: nil) embeddedInMorphicWindowLabeled: 'A fancy looking title text' ! ! !AthensTextRenderTest class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/8/2013 18:35'! test1 | t c | t := ' AthensTextRenderTest test1 leftFlush p := MultiNewParagraph new. p compose: t style: TextStyle default from: 1 in: (0@0 corner: 100@100). p MultiNewParagraph TextStyle default alignment globalBounds: toLocal: ' asText . t addAttribute: (TextColor new color: Color red) from: 3 to: 10. t addAttribute: (TextEmphasis italic) from: 5 to: 13. c := AthensTextComposer scan: t for: AthensTextScanner new. AthensSceneView new scene: [:canvas | canvas pathTransform scaleBy: 0.8. c renderOn: canvas ]; openInWindow ! ! !AthensTextRenderer commentStamp: 'IgorStasenko 10/20/2011 10:14'! This is a text renderer, which pipelining a text command(s) , produced by AthensTextComposer into a concrete calls to canvas. Its using a glyph renderer instance(s) to draw separate font glyphs on a surface in a most suitable/efficient manner for given Athens surface. ! !AthensTextRenderer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/7/2011 14:41'! renderBackground: aColor width: w "self halt." canvas setPaint: aColor. canvas drawShape: ( advance x@0 corner: advance x + w +1@ currentLine heightAndDescent) ! ! !AthensTextRenderer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/20/2011 13:07'! initialize color := Color black.! ! !AthensTextRenderer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/2/2012 19:01'! setCurrentColor: aColor color = aColor ifTrue: [ ^ self ]. color := aColor. " canvas setPaint: aColor." glyphRenderer ifNotNil: [ glyphRenderer setColor: aColor ].! ! !AthensTextRenderer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/2/2012 19:02'! renderCharactersFrom: start to: stop " accumulate advance while rendering spans" "canvas drawShape: (advance x @ advance y extent: 2 @ 2)." glyphRenderer advance: advance. advance := advance + (glyphRenderer renderCharacters: text from: start to: stop). ! ! !AthensTextRenderer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/7/2011 14:44'! renderBackground: bkObj "self halt." canvas setPaint: bkObj color. canvas drawShape: ( bkObj start@0 corner: bkObj start + bkObj width @ currentLine heightAndDescent) ! ! !AthensTextRenderer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/1/2012 21:23'! render: aText lines: lines on: aCanvas text := aText. canvas := aCanvas. canvas pathTransform restoreAfter: [ lines do: [:line | | origY | currentLine := line. maxAscent := line maxAscent. "set the origin to font's baseline position" canvas pathTransform translateX: 0 Y: maxAscent. "reset advance" advance := 0@0. line renderOn: self. "line is rendered, advance vertically by line height" canvas pathTransform translateX: 0 Y: line height * 1.2 - maxAscent. ] ]! ! !AthensTextRenderer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/1/2012 22:03'! setCurrentFont: aFont font := aFont. glyphRenderer := font glyphRendererOn: canvas surface. glyphRenderer advance: advance; setColor: color.! ! !AthensTextRenderer class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/1/2012 21:16'! textGoryDetails " Took from: http://www.freetype.org/freetype2/docs/tutorial/step2.html (Font face metrics) In this case, you can access the global design metrics as: units_per_EM This is the size of the EM square for the font face. It is used by scalable formats to scale design coordinates to device pixels, as described in the last chapter of this section. Its value usually is 2048 (for TrueType) or 1000 (for Type 1), but others are possible too. It is set to 1 for fixed-size formats like FNT/FON/PCF/BDF. bbox The global bounding box is defined as the largest rectangle that can enclose all the glyphs in a font face. ascender The ascender is the vertical distance from the horizontal baseline to the highest ‘character’ coordinate in a font face. Unfortunately, font formats define the ascender differently. For some, it represents the ascent of all capital latin characters (without accents), for others it is the ascent of the highest accented character, and finally, other formats define it as being equal to bbox.yMax. descender The descender is the vertical distance from the horizontal baseline to the lowest ‘character’ coordinate in a font face. Unfortunately, font formats define the descender differently. For some, it represents the descent of all capital latin characters (without accents), for others it is the ascent of the lowest accented character, and finally, other formats define it as being equal to bbox.yMin. This field is negative for values below the baseline. height This field is simply used to compute a default line spacing (i.e., the baseline-to-baseline distance) when writing text with this font. Note that it usually is larger than the sum of the ascender and descender taken as absolute values. There is also no guarantee that no glyphs extend above or below subsequent baselines when using this distance. max_advance_width This field gives the maximum horizontal cursor advance for all glyphs in the font. It can be used to quickly compute the maximum advance width of a string of text. It doesn't correspond to the maximum glyph image width!! max_advance_height Same as max_advance_width but for vertical text layout. underline_position When displaying or rendering underlined text, this value corresponds to the vertical position, relative to the baseline, of the underline bar's center. It is negative if it is below the baseline. underline_thickness When displaying or rendering underlined text, this value corresponds to the vertical thickness of the underline. "! ! !AthensTextScanner commentStamp: 'IgorStasenko 2/6/2012 16:22'! I responsible for scanning the Text and transforming it into a list of AthensTextLine, where each line is a list of AthensTextDisplayCommand (sub)instances! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/10/2011 11:13'! defaultFont ^ self textStyle defaultFont! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/10/2011 11:13'! defaultColor ^ Color black! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2011 16:53'! defaultTextStyle ^ TextStyle default! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/17/2011 12:45'! lines ^ lines! ! !AthensTextScanner methodsFor: 'text attributes' stamp: 'IgorStasenko 10/11/2011 16:52'! setFont: fontNumber self setActualFont: (self textStyle fontAt: fontNumber). ! ! !AthensTextScanner methodsFor: 'text attributes' stamp: 'IgorStasenko 11/10/2011 11:31'! textBackground: aColor "background is transparent by default " (currentBackground notNil and: [ currentBackground color = aColor ]) ifTrue: [ ^ self]. currentBackground ifNil: [ aColor isTransparent ifTrue: [ ^ self ] ]. currentBackground := AthensBackgroundChange new color: aColor. currentBackground start: currentLine width. currentLine addCommand: currentBackground.! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2011 16:08'! text: aText text := aText! ! !AthensTextScanner methodsFor: 'text attributes' stamp: 'IgorStasenko 11/10/2011 11:14'! addEmphasis: emphasis | fnt | fnt := currentFont ifNil: [ self defaultFont ] ifNotNil: [ currentFont font ]. self setActualFont: (fnt emphasized: emphasis)! ! !AthensTextScanner methodsFor: 'text attributes' stamp: 'IgorStasenko 11/10/2011 12:04'! setActualFont: aFont currentFont ifNil: [ currentFont := AthensFontChange new font: aFont. self addCommand: currentFont. ^ self ]. aFont = currentFont font ifFalse: [ currentFont := AthensFontChange new font: aFont. self addCommand: currentFont. ]. ! ! !AthensTextScanner methodsFor: 'text attributes' stamp: 'IgorStasenko 11/10/2011 11:15'! textColor: aColor currentColor ifNil: [ currentColor := AthensColorChange new color: aColor. self addCommand: currentColor. ^ self ]. currentColor color = aColor ifFalse: [ currentColor := AthensColorChange new color: aColor. self addCommand: currentColor. ]. ! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/10/2011 11:54'! initialize lines := OrderedCollection new. currentAttributes := #().! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/10/2011 12:21'! newLine: startingIndex currentLine := lines add: (AthensTextLine new text: text; startIndex: startingIndex; yourself). " currentStrip ifNotNil: [ currentLine addCommand: currentFont copy. currentLine addCommand: currentColor copy. currentBackground ifNotNil: [ currentBackground := currentBackground copy start: 0; width: 0. currentLine addCommand: currentBackground ]. ]. " "reset everything, to make sure all attributes will be reapplied for new line" currentColor := currentBackground := currentFont := currentStrip := nil.! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/10/2011 12:13'! setAttributes: anArray currentBackground := nil. currentAttributes := anArray. "we should reset character string here" currentStrip := nil. ! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/10/2011 12:00'! addCharacter: position | charWidth fnt | currentStrip ifNil: [ self applyAttributes. fnt := currentFont font. currentLine maxAscent: fnt getPreciseAscent. currentLine maxDescent: fnt getPreciseDescent. currentLine maxHeight: fnt getPreciseHeight. currentStrip := AthensCharacterSpan new. currentLine addCommand: currentStrip. currentStrip start: position. ]. charWidth := currentFont font getGlyphWidth: (text at: position). currentLine addWidth: charWidth. currentBackground ifNotNil: [ currentBackground addWidth: charWidth ]. currentStrip stop: position. ! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/10/2011 11:26'! addCommand: aCommand currentLine addCommand: aCommand! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/28/2011 14:58'! resetBackground self textBackground: Color transparent.! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/10/2011 11:58'! applyAttributes currentAttributes do: [:attr | attr emphasizeScanner: self ]. currentFont ifNil: [ self setActualFont: self defaultFont ]. currentColor ifNil: [ self textColor: self defaultColor ]. ! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2011 16:53'! textStyle ^ textStyle ifNil: [ textStyle := self defaultTextStyle ]! ! !AthensTextScanner methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/11/2011 17:19'! endLine: index currentLine endIndex: index! ! !AthensTigerShape commentStamp: 'TorstenBergmann 2/12/2014 22:16'! The tiger shape (see VGTigerDemo runDemo)! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! setPath: anAthensCairoPath path := anAthensCairoPath! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! fillRule ^ fillRule! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! capStyle: cap capStyle := cap.! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! miterLimit: lim miterLimit := lim.! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! renderOn: can fill ifTrue: [ can setPaint: fillPaint. can drawShape: path. ]. stroke ifTrue: [ can setStrokePaint: strokePaint. can drawShape: path. ]! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! addStroke stroke := true.! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! fillPaint: aColor fillPaint := aColor! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! initialize fill := stroke := false.! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! joinStyle: join joinStyle := join.! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! fillRule: rule fillRule := rule.! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! strokePaint: aColor strokePaint := aColor! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/27/2012 11:26'! prepareFor: surface fill ifTrue: [ fillPaint := surface createSolidColorPaint: fillPaint. ]. stroke ifTrue: [ strokePaint := surface createStrokePaintFor: (surface createSolidColorPaint: strokePaint). ]. ! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! strokeWidth: w strokeWidth := w! ! !AthensTigerShape methodsFor: 'as yet unclassified' stamp: ''! addFill fill := true.! ! !AthensTransform commentStamp: 'IgorStasenko 3/7/2012 14:41'! My instances represent an interface for coordinate system transformation defined by 3x3 matrix of following kind: | sx shx x | | shy sy y | | w0 w1 w2 | sx and sy define scaling in the x and y directions, respectively; shx and shy define shearing in the x and y directions, respectively; tx and ty define translation in the x and y directions, respectively. AthensSurface are responsible for providing specific implementation of me, which is most appropriate for backend its using. My internal representation isnt available for manipulation, for example dont assume i'm a matrix. In short, do not copy my state or modify it directly, instead use methods such as #loadAffineTransformation:, and talk to my surface. My subclasses should implement a common protocol for applying generic types of affine transformations on coordinate system: - translate - rotate - shear - scale - matrix multiply - matrix load Surface must support 4 kinds of transformations of coordinate system(s): - path-to-surface (#pathTransform) to transform path coordinates to surface space - image-to-surface (#imageTransform) to transform between user coordinates and surface pixels - fill-paint-to-user (#fillTransform) - stroke-paint-to-user (#strokeTransform) Given a (fill or stroke) paint-to-user transformation Tp and user-to-surface transformation Tu, the paint color and alpha of a pixel to be drawn with surface coordinates (x, y) is defined by mapping its center point (x + 1/2, y + 1/2) through the inverse transformation (Tu * Tp)^-1 , resulting in a sample point in the paint coordinate space. All transformations, except image-to-surface , ignoring w0 , w1 and w2 values and always assume them set to { 0 , 0 , 1 } respectively. For accessing a particular kind of transformation, send message to canvas, i.e.: canvas pathTransform translateBy: 10@10. It is safe to store transformation in temporary variable, as long as canvas is valid. ! !AthensTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/7/2012 13:52'! restoreAfter: aBlock "i should save the current transform state, evaluate the block, and then restore the saved transform state" self subclassResponsibility! ! !AthensTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/26/2011 01:55'! translateBy: aPoint self subclassResponsibility! ! !AthensTransform methodsFor: 'transformations' stamp: ''! invert "i should invert" self subclassResponsibility! ! !AthensTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/26/2011 01:56'! rotateByDegrees: angle self subclassResponsibility! ! !AthensTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/26/2011 01:55'! scaleX: fx Y: fy self subclassResponsibility! ! !AthensTransform methodsFor: 'accessing' stamp: 'IgorStasenko 8/31/2012 22:29'! getMatrix "Answer an affine transformation matrix currently used by receiver. Note, that resulting matrix should be copied from receiver's data, i.e. no future modifications of receiver should affect the answered object. The default implementation is to answer a copy of receiver" ^ self copy! ! !AthensTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/26/2011 01:55'! scaleBy: factor self subclassResponsibility! ! !AthensTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/7/2012 14:00'! loadAffineTransform: anAthenTransform self subclassResponsibility! ! !AthensTransform methodsFor: 'transformations' stamp: 'IgorStasenko 3/26/2011 01:55'! rotateByRadians: angle self subclassResponsibility! ! !AthensTransform methodsFor: 'vector-transform' stamp: 'IgorStasenko 3/27/2011 18:42'! transform: aPoint self subclassResponsibility! ! !AthensTransform methodsFor: 'vector-transform' stamp: 'IgorStasenko 3/27/2011 18:42'! transformX: px Y: py self subclassResponsibility! ! !AthensTransform methodsFor: 'transformations' stamp: 'IgorStasenko 12/21/2011 12:39'! translateX: px Y: py self subclassResponsibility! ! !AthensTransform methodsFor: 'transformations' stamp: 'IgorStasenko 12/20/2011 16:46'! loadIdentity "load the identity matrix into receiver" self subclassResponsibility! ! !AthensTreeView commentStamp: 'TorstenBergmann 2/12/2014 22:16'! A tree visualization using Athens for display! !AthensTreeView methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/3/2013 23:14'! root: aRootObject extentBlock: extBlock childsBlock: childsBlock nodeExtentBlock := extBlock. nodeChildsBlock := childsBlock. root := self buildSubtreeFor: aRootObject level: 1. self layOutGeometry! ! !AthensTreeView methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/3/2013 22:22'! root: aRootObject root := self buildSubtreeFor: aRootObject level: 1. self layOutGeometry! ! !AthensTreeView methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/3/2013 23:30'! layOutGeometry "first do a vertical layout" | origin | origin := 0. rows do: [:row | | rowHeight color | rowHeight := 0. color := Color random. row do: [ :node | node originY: origin. node color: color. rowHeight := rowHeight max: node height. ]. origin := origin + rowHeight + self spacingBetweenRows. ]. "now do a horizontal one" root layoutHorizontally: 0.! ! !AthensTreeView methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/3/2013 22:55'! rowAt: aLevel rows ifNil: [ rows := OrderedCollection new ]. [ aLevel > rows size ] whileTrue: [ rows add: OrderedCollection new ]. ^ rows at: aLevel! ! !AthensTreeView methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/4/2013 00:34'! renderOn: aCanvas aCanvas surface clear: Color white. root renderOn: aCanvas! ! !AthensTreeView methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/3/2013 22:24'! buildSubtreeFor: aNodeObject level: aLevel | node childs | node := AthensSimpleTreeNode new. node subject: aNodeObject; extent: (nodeExtentBlock value: aNodeObject). childs := (nodeChildsBlock value: aNodeObject) collect: [ :each | self buildSubtreeFor: each level: aLevel+1 ]. node children: childs. (self rowAt: aLevel) add: node. ^ node ! ! !AthensTreeView methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/3/2013 22:59'! spacingBetweenRows ^ 30! ! !AthensTreeView class methodsFor: 'examples' stamp: 'TorstenBergmann 2/12/2014 22:15'! example1 AthensTreeView openOn: Collection extentBlock: [ :each | (5 + each instVarNames size)@(5 + each methodDict size) ] childsBlock: [:el | el subclasses ] ! ! !AthensTreeView class methodsFor: 'instance creation' stamp: 'IgorStasenko 5/3/2013 23:21'! openOn: root extentBlock: extBlock childsBlock: childsBlock | scene | scene := self new root: root extentBlock: extBlock childsBlock: childsBlock. ^ AthensSceneView new scene: scene; openInWindow.! ! !AthensWrapMorph commentStamp: ''! i making sure that all my submorphs will be drawn using athens, but not balloon. For that i use separate surface.! !AthensWrapMorph methodsFor: 'accessing' stamp: 'IgorStasenko 9/6/2013 12:18'! athensSurface self checkSurface. ^ surface! ! !AthensWrapMorph methodsFor: 'surface management' stamp: 'IgorStasenko 9/6/2013 12:46'! createSurface | extent | extent := bounds extent asIntegerPoint. surface := AthensCairoSurface extent: extent. ! ! !AthensWrapMorph methodsFor: 'drawing' stamp: 'IgorStasenko 8/26/2013 11:41'! drawOn: aCanvas "do nothing"! ! !AthensWrapMorph methodsFor: 'drawing' stamp: 'IgorStasenko 8/26/2013 13:03'! drawOnAthensCanvas: aCanvas "do nothing"! ! !AthensWrapMorph methodsFor: 'drawing' stamp: 'IgorStasenko 8/26/2013 12:58'! fullDrawOnAthensCanvas: anAthensCanvas "Draw the full Morphic structure on the given Canvas" self visible ifFalse: [^ self]. (anAthensCanvas isVisible: self fullBounds) ifFalse: [^self]. (self hasProperty: #errorOnDraw) ifTrue: [^self "drawErrorOn: aCanvas" ]. (anAthensCanvas isVisible: self bounds) ifTrue: [ anAthensCanvas draw: self ]. submorphs reverseDo: [:m | anAthensCanvas fullDrawMorph: m ] ! ! !AthensWrapMorph methodsFor: 'drawing' stamp: 'JochenRick 1/10/2014 06:35'! render surface drawDuring: [ :canvas | surface clear. canvas pathTransform restoreAfter: [ "before rendering transform from a global coordinates (Morphic) to relative coordinates (Athens)" canvas pathTransform translateBy: self bounds origin negated. self fullDrawOnAthensCanvas: canvas. ]. ]. ! ! !AthensWrapMorph methodsFor: 'drawing' stamp: 'IgorStasenko 12/21/2013 02:18'! fullDrawOn: aCanvas "Draw the full Morphic structure on the given Canvas" self visible ifFalse: [^ self]. (aCanvas isVisible: self fullBounds) ifFalse:[^self]. (self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas]. self checkSurface. [ self render. surface displayOnMorphicCanvas: aCanvas at: bounds origin. ] on: Error do: [:err | self setProperty: #errorOnDraw toValue: true. self setProperty: #drawError toValue: err freeze. ^ self drawErrorOn: aCanvas ]! ! !AthensWrapMorph methodsFor: 'surface management' stamp: 'IgorStasenko 9/6/2013 12:47'! checkSurface session == Smalltalk session ifFalse: [ self initializeForNewSession ]. bounds extent ~= surface extent ifTrue: [ "recreate a surface if dimensions are changed" self createSurface ] ! ! !AthensWrapMorph methodsFor: 'events handling' stamp: 'FernandoOlivero 9/2/2013 14:53'! handlesMouseDown: evt ^ true ! ! !AthensWrapMorph methodsFor: 'surface management' stamp: 'IgorStasenko 8/26/2013 11:44'! initializeForNewSession self createSurface. session := Smalltalk session. ! ! !AtomicCollection commentStamp: 'Igor.Stasenko 10/16/2010 03:54'! I am just a base abstract class, containing common behavior for various queue types! !AtomicCollection methodsFor: 'utils' stamp: 'IgorStasenko 2/28/2011 15:58'! newItem "override in subclass, if you need to instantiate queue items of different class or initialize them in some specific way" ^ AtomicQueueItem new! ! !AtomicCollection methodsFor: 'yielding' stamp: 'Igor.Stasenko 10/15/2010 17:30'! yield "Yield the current process. Used internally by spin loops, once detected that current process can't make any progress without some external event to happen" Processor yield! ! !AtomicCollection methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/16/2010 03:54'! signalNoMoreItems "Optional, override in subclass(es) to signal that queue is currently empty. Default implementation does nothing"! ! !AtomicCollection methodsFor: 'copying' stamp: 'Igor.Stasenko 10/16/2010 04:09'! deepCopy ^ self errorDontCopy! ! !AtomicCollection methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/16/2010 03:54'! waitForNewItems "Override in subclass. By default, yield current process. If you run more than one process, which popping items from queue, then there is no guarantee, that after wait, #next won't block the queue" ^ self yield! ! !AtomicCollection methodsFor: 'copying' stamp: 'Igor.Stasenko 10/16/2010 04:11'! errorDontCopy "copying a structure, involved in concurrent operations is a bad idea" ^ self error: 'Copying not available'! ! !AtomicCollection methodsFor: 'copying' stamp: 'Igor.Stasenko 10/16/2010 04:09'! copy ^ self errorDontCopy! ! !AtomicCollection methodsFor: 'debug support' stamp: 'Igor.Stasenko 10/15/2010 17:30'! interrupt "simulate interrupt , for debugging purposes only" Processor yield! ! !AtomicCollection methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/16/2010 03:54'! signalAddedNewItem "Optional, override in subclass(es) to signal that new item available in queue. Default implementation does nothing"! ! !AtomicQueueItem commentStamp: 'Igor.Stasenko 10/16/2010 02:29'! i am a queue item , used by atomic queues. All my new instances are circular i.e. next=self! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 16:52'! object: anObject "Set the value of object" object := anObject! ! !AtomicQueueItem methodsFor: 'initialization' stamp: 'IgorStasenko 2/28/2011 16:00'! initialize "make circular" super initialize. next := self.! ! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 16:52'! object "Answer the value of object" ^ object! ! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 16:52'! next "Answer the value of next" ^ next! ! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 16:52'! next: anObject "Set the value of next" next := anObject! ! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 17:45'! makeCircular "Make a receiver circular, i.e. point to itself, answer the old value of next variable. Note, this operation should be atomic" | temp | " atomic swap here" temp := next. next := self. ^ temp! ! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 17:45'! isCircular ^ next == self! ! !AtomicSharedQueue commentStamp: 'IgorStasenko 2/28/2011 15:33'! I am using semaphore to signal/wait for new items available in queue I am introducing extra protocol - #next, which blocks the sender until it can successfully fetch next item from queue. ! !AtomicSharedQueue methodsFor: 'accessing' stamp: 'IgorStasenko 2/28/2011 15:20'! next "Fetch the next item from queue. If queue is locked or empty, block the sender until operation can complete" | result | [ | keepWaiting | keepWaiting := false. result := self nextIfNone: [ keepWaiting := true ]. keepWaiting ] whileTrue: [ self waitForNewItems ]. ^ result! ! !AtomicSharedQueue methodsFor: 'initialization' stamp: 'Igor.Stasenko 10/15/2010 16:59'! initialize super initialize. availSema := Semaphore new. ! ! !AtomicSharedQueue methodsFor: 'signaling' stamp: 'CamilloBruni 10/14/2013 22:25'! signalNoMoreItems "queue is empty, reset sema signals" availSema consumeAllSignals ! ! !AtomicSharedQueue methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/15/2010 17:00'! waitForNewItems availSema wait! ! !AtomicSharedQueue methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/15/2010 17:00'! signalAddedNewItem availSema signal! ! !Author commentStamp: 'MiguelCoba 7/25/2009 01:09'! I am responsible for the full name used to identify the current code author.! !Author methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2013 23:20'! fullNamePerSe "Answer the currently-prevailing author full name, such as it is, empty or not" #UserManager asClassIfPresent: [ :userManager | ^ userManager default currentUser userNameFor: #author ]. ^ fullName! ! !Author methodsFor: 'initialization' stamp: ''! initialize super initialize. fullName := ''.! ! !Author methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2013 23:20'! fullName: aString fullName := aString. #UserManager asClassIfPresent: [ :userManager | userManager default currentUser setUserName: aString forGroup: #author ].! ! !Author methodsFor: 'ui-requests' stamp: 'CamilloBruni 10/20/2012 21:04'! requestFullName | initialAnswer | initialAnswer := fullName isEmptyOrNil ifTrue: ['FirstnameLastname' translated] ifFalse: [fullName]. self checkAndSetFullNameWith: (AuthorNameRequest new initialAnswer: initialAnswer) signal! ! !Author methodsFor: 'accessing' stamp: ''! fullName "Answer the full name to be used to identify the current code author." [fullName isEmptyOrNil] whileTrue: [ self requestFullName. (fullName isNil or:[fullName = 'FirstnameLastname' translated]) ifTrue: [fullName := nil. ^'Anonymous']]. ^ fullName! ! !Author methodsFor: 'compatibility' stamp: ''! reset fullName := ''! ! !Author methodsFor: 'accessing' stamp: 'Lr 12/9/2010 17:34'! checkAndSetFullNameWith: aString | s allowed | aString ifNil: [^self]. s := ''. allowed := ($A to: $Z) , ($a to: $z) , ($0 to: $9). aString do: [:c | (allowed includes: c) ifTrue: [s := s , c asString]]. self fullName: s! ! !Author methodsFor: 'compatibility' stamp: 'ClementBera 4/11/2013 14:01'! ifUnknownAuthorUse: aString during: aBlock "If no author is set use the name aString while executing aBlock." "for compatibility with 1.0" fullName isEmptyOrNil ifFalse: [ ^ aBlock value ]. fullName := aString. ^ aBlock ensure: [ self reset ]! ! !Author methodsFor: 'testing-support' stamp: ''! useAuthor: aString during: aBlock | previous | previous := fullName. fullName := aString. ^ aBlock ensure: [ fullName := previous ]! ! !Author class methodsFor: 'convenience' stamp: 'Zork 10/13/2013 17:35'! fullNamePerSe ^ Author uniqueInstance fullNamePerSe ! ! !Author class methodsFor: 'utilities' stamp: ''! changeStamp "Answer a string to be pasted into source code to mark who changed it and when." ^ Author fullName , ' ' , Date today mmddyyyy, ' ', ((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! ! !Author class methodsFor: 'convenience' stamp: ''! fullName: aString ^ Author uniqueInstance checkAndSetFullNameWith: aString! ! !Author class methodsFor: 'instance creation' stamp: ''! new self error: 'Author is a singleton -- send uniqueInstance instead'! ! !Author class methodsFor: 'convenience' stamp: ''! requestFullName ^ Author uniqueInstance requestFullName! ! !Author class methodsFor: 'utilities' stamp: ''! changeStampPerSe "Answer a string to be pasted into source code to mark who changed it and when." ^ (Author fullNamePerSe ifNil: ['.']) , ' ' , Date today mmddyyyy, ' ', ((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! ! !Author class methodsFor: 'convenience' stamp: ''! fullName ^ Author uniqueInstance fullName! ! !Author class methodsFor: 'utilities' stamp: 'MarcusDenker 10/9/2013 17:05'! fixStamp: changeStamp | parts | parts := changeStamp findTokens: ' '. (parts notEmpty and: [parts last first isLetter]) ifTrue: ["Put initials first in all time stamps..." ^ String streamContents: [:s | s nextPutAll: parts last. parts allButLast do: [:p | s space; nextPutAll: p]]]. ^ changeStamp! ! !Author class methodsFor: 'instance creation' stamp: 'IgorStasenko 10/13/2013 18:09'! reset #UserManager asClassIfPresent: [ :userManager | userManager default currentUser setUserName: nil forGroup: #author ]. ^ uniqueInstance := nil! ! !Author class methodsFor: 'instance creation' stamp: ''! uniqueInstance ^ uniqueInstance ifNil: [ uniqueInstance := super new ]! ! !Author class methodsFor: 'testing-support' stamp: ''! useAuthor: aString during: aBlock ^ self uniqueInstance useAuthor: aString during: aBlock! ! !AuthorNameRequest commentStamp: ''! I am used to request a new author name.! !AuthorNameRequest methodsFor: 'accessing' stamp: 'CamilloBruni 10/20/2012 21:03'! initialAnswer: anObject initialAnswer := anObject! ! !AuthorNameRequest methodsFor: 'accessing' stamp: 'CamilloBruni 10/20/2012 21:03'! initialAnswer ^ initialAnswer! ! !AuthorNameRequest methodsFor: 'exception handling' stamp: 'CamilloBruni 10/20/2012 21:03'! defaultAction ^ UIManager default request: self messagePrompt initialAnswer: initialAnswer title: 'Author identification' translated! ! !AuthorNameRequest methodsFor: 'ui-requests' stamp: 'CamilloBruni 10/22/2012 23:21'! messagePrompt ^ self class messagePrompt! ! !AuthorNameRequest class methodsFor: 'accessing' stamp: 'CamilloBruni 10/22/2012 23:21'! messagePrompt ^ 'Please type your full name. It will be used to sign the changes you make to the image. Spaces, accents, dashes, underscore and similar characters are not allowed '! ! !AuthorTest methodsFor: 'tests' stamp: 'on 5/10/2008 13:35'! testUniqueness self should: [ Author new ] raise: Error.! ! !AverageCost commentStamp: 'StephaneDucasse 6/9/2010 20:53'! Part of an test resource to verify that super is well bound. See CompilerEvaluationTest! !AverageCost methodsFor: 'as yet unclassified' stamp: 'NikoSchwarz 6/5/2010 16:11'! total ^super total / 12! ! !BMPReadWriter commentStamp: 'LaurentLaffont 5/4/2011 21:27'! I read and write BMP files. Example to save and load a screenshot of the world in a .bmp file: BMPReadWriter putForm: (Form fromDisplay: (0@0 corner: 400@400)) onFileNamed: '/tmp/screenshot.bmp'. (ImageMorph withForm: (BMPReadWriter formFromFileNamed: '/tmp/screenshot.bmp')) openInWindow.! !BMPReadWriter methodsFor: 'writing' stamp: 'StephaneDucasse 12/22/2010 16:09'! store24BitBmpLine: pixelLine from: formBits startingAt: formBitsIndex width: width "Stores a single scanline containing 32bpp RGBA values in a 24bpp scanline. Swizzles the bytes as needed." | pixIndex rgb bitsIndex | pixIndex := 0. "pre-increment" bitsIndex := formBitsIndex-1. "pre-increment" 1 to: width do: [:j | rgb := (formBits at: (bitsIndex := bitsIndex+1)) bitAnd: 16rFFFFFF. pixelLine at: (pixIndex := pixIndex+1) put: (rgb bitAnd: 255). pixelLine at: (pixIndex := pixIndex+1) put: ((rgb bitShift: -8) bitAnd: 255). pixelLine at: (pixIndex := pixIndex+1) put: ((rgb bitShift: -16) bitAnd: 255). ]. ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:36'! nextImage | colors | stream binary. self readHeader. biBitCount = 24 ifTrue:[^self read24BmpFile]. "read the color map" colors := self readColorMap. ^self readIndexedBmpFile: colors! ! !BMPReadWriter methodsFor: 'writing' stamp: 'StephaneDucasse 12/22/2010 16:04'! nextPutImage: aForm | bhSize rowBytes rgb data colorValues depth image ppw scanLineLen pixline | depth := aForm depth. depth := #(1 4 8 32 ) detect: [ :each | each >= depth]. image := aForm asFormOfDepth: depth. image unhibernate. bhSize := 14. "# bytes in file header" biSize := 40. "info header size in bytes" biWidth := image width. biHeight := image height. biClrUsed := depth = 32 ifTrue: [0] ifFalse:[1 << depth]. "No. color table entries" bfOffBits := biSize + bhSize + (4*biClrUsed). rowBytes := ((depth min: 24) * biWidth + 31 // 32) * 4. biSizeImage := biHeight * rowBytes. "Write the file header" stream position: 0. stream nextLittleEndianNumber: 2 put: 19778. "bfType = BM" stream nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage. "Entire file size in bytes" stream nextLittleEndianNumber: 4 put: 0. "bfReserved" stream nextLittleEndianNumber: 4 put: bfOffBits. "Offset of bitmap data from start of hdr (and file)" "Write the bitmap info header" stream position: bhSize. stream nextLittleEndianNumber: 4 put: biSize. "info header size in bytes" stream nextLittleEndianNumber: 4 put: image width. "biWidth" stream nextLittleEndianNumber: 4 put: image height. "biHeight" stream nextLittleEndianNumber: 2 put: 1. "biPlanes" stream nextLittleEndianNumber: 2 put: (depth min: 24). "biBitCount" stream nextLittleEndianNumber: 4 put: 0. "biCompression" stream nextLittleEndianNumber: 4 put: biSizeImage. "size of image section in bytes" stream nextLittleEndianNumber: 4 put: 2800. "biXPelsPerMeter" stream nextLittleEndianNumber: 4 put: 2800. "biYPelsPerMeter" stream nextLittleEndianNumber: 4 put: biClrUsed. stream nextLittleEndianNumber: 4 put: 0. "biClrImportant" biClrUsed > 0 ifTrue: [ "write color map; this works for ColorForms, too" colorValues := image colormapIfNeededForDepth: 32. 1 to: biClrUsed do: [:i | rgb := colorValues at: i. 0 to: 24 by: 8 do: [:j | stream nextPut: (rgb >> j bitAnd: 16rFF)]]]. depth < 32 ifTrue: [ "depth = 1, 4 or 8." data := image bits asByteArray. ppw := 32 // depth. scanLineLen := biWidth + ppw - 1 // ppw * 4. "# of bytes in line" 1 to: biHeight do: [:i | stream next: scanLineLen putAll: data startingAt: (biHeight-i)*scanLineLen+1. ]. ] ifFalse: [ data := image bits. pixline := ByteArray new: (((biWidth * 3 + 3) // 4) * 4). 1 to: biHeight do:[:i | self store24BitBmpLine: pixline from: data startingAt: (biHeight-i)*biWidth+1 width: biWidth. stream nextPutAll: pixline. ]. ]. stream position = (bfOffBits + biSizeImage) ifFalse: [self error:'Write failure']. stream close.! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readIndexedBmpFile: colors "Read uncompressed pixel data of depth d from the given BMP stream, where d is 1, 4, 8, or 16" | form bytesPerRow pixelData pixelLine startIndex map bitBlt mask | colors ifNil: [ form := Form extent: biWidth @ biHeight depth: biBitCount ] ifNotNil: [ form := ColorForm extent: biWidth @ biHeight depth: biBitCount. form colors: colors ]. bytesPerRow := (biBitCount * biWidth + 31) // 32 * 4. pixelData := ByteArray new: bytesPerRow * biHeight. biHeight to: 1 by: -1 do: [ :y | pixelLine := stream next: bytesPerRow. startIndex := (y - 1) * bytesPerRow + 1. pixelData replaceFrom: startIndex to: startIndex + bytesPerRow - 1 with: pixelLine startingAt: 1 ]. form bits copyFromByteArray: pixelData. biBitCount = 16 ifTrue: [ map := ColorMap shifts: #(8 -8 0 0 ) masks: #(255 65280 0 0 ). mask := 2147516416 ]. biBitCount = 32 ifTrue: [ map := ColorMap shifts: #(24 8 -8 -24 ) masks: #(255 65280 16711680 4278190080 ). mask := 4278190080 ]. map ifNotNil: [ bitBlt := BitBlt toForm: form. bitBlt sourceForm: form. bitBlt colorMap: map. bitBlt combinationRule: Form over. bitBlt copyBits ]. mask ifNotNil: [ bitBlt := BitBlt toForm: form. bitBlt combinationRule: 7. "bitOr:with:" bitBlt halftoneForm: (Bitmap with: mask). bitBlt copyBits ]. ^ form! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! readHeader | reserved | bfType := stream nextLittleEndianNumber: 2. bfSize := stream nextLittleEndianNumber: 4. reserved := stream nextLittleEndianNumber: 4. bfOffBits := stream nextLittleEndianNumber: 4. biSize := stream nextLittleEndianNumber: 4. biWidth := stream nextLittleEndianNumber: 4. biHeight := stream nextLittleEndianNumber: 4. biPlanes := stream nextLittleEndianNumber: 2. biBitCount := stream nextLittleEndianNumber: 2. biCompression := stream nextLittleEndianNumber: 4. biSizeImage := stream nextLittleEndianNumber: 4. biXPelsPerMeter := stream nextLittleEndianNumber: 4. biYPelsPerMeter := stream nextLittleEndianNumber: 4. biClrUsed := stream nextLittleEndianNumber: 4. biClrImportant := stream nextLittleEndianNumber: 4! ! !BMPReadWriter methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:51'! readColorMap "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." | colorCount colors maxLevel b g r ccStream | colorCount := (bfOffBits - 54) // 4. "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" biBitCount >= 16 ifTrue: [ ^ nil ]. colorCount = 0 ifTrue: [ "this BMP file does not have a color map" "default monochrome color map" biBitCount = 1 ifTrue: [ ^ Array with: Color white with: Color black ]. "default gray-scale color map" maxLevel := (2 raisedTo: biBitCount) - 1. ^ (0 to: maxLevel) collect: [ :level | Color gray: level asFloat / maxLevel ] ]. ccStream := (stream next: colorCount * 4) readStream. colors := Array new: colorCount. 1 to: colorCount do: [ :i | b := ccStream next. g := ccStream next. r := ccStream next. ccStream next. "skip reserved" colors at: i put: (Color r: r g: g b: b range: 255) ]. ^ colors! ! !BMPReadWriter methodsFor: 'reading' stamp: 'lr 7/4/2009 10:42'! read24BmpFile "Read 24-bit pixel data from the given a BMP stream." | form formBits pixelLine bitsIndex bitBlt | form := Form extent: biWidth @ biHeight depth: 32. pixelLine := ByteArray new: (24 * biWidth + 31) // 32 * 4. bitsIndex := (form height - 1) * biWidth + 1. formBits := form bits. 1 to: biHeight do: [ :i | pixelLine := stream nextInto: pixelLine. self read24BmpLine: pixelLine into: formBits startingAt: bitsIndex width: biWidth. bitsIndex := bitsIndex - biWidth ]. bitBlt := BitBlt toForm: form. bitBlt combinationRule: 7. "bitOr:with:" bitBlt halftoneForm: (Bitmap with: 4278190080). bitBlt copyBits. ^ form! ! !BMPReadWriter methodsFor: 'reading' stamp: 'StephaneDucasse 12/22/2010 16:08'! read24BmpLine: pixelLine into: formBits startingAt: formBitsIndex width: width "Swizzles the bytes in a 24bpp scanline and fills in the given 32bpp form bits. Ensures that color black is represented as 16rFF000001 so that Form paint works properly." | pixIndex rgb bitsIndex | pixIndex := 0. "pre-increment" bitsIndex := formBitsIndex-1. "pre-increment" 1 to: width do: [:j | rgb := (pixelLine at: (pixIndex := pixIndex+1)) + ((pixelLine at: (pixIndex := pixIndex+1)) bitShift: 8) + ((pixelLine at: (pixIndex := pixIndex+1)) bitShift: 16). rgb = 0 ifTrue:[rgb := 16rFF000001] ifFalse:[rgb := rgb + 16rFF000000]. formBits at: (bitsIndex := bitsIndex+1) put: rgb]. ! ! !BMPReadWriter methodsFor: 'testing' stamp: 'ar 6/16/2002 15:27'! understandsImageFormat stream size < 54 ifTrue:[^false]. "min size = BITMAPFILEHEADER+BITMAPINFOHEADER" self readHeader. bfType = 19778 "BM" ifFalse:[^false]. biSize = 40 ifFalse:[^false]. biPlanes = 1 ifFalse:[^false]. bfSize <= stream size ifFalse:[^false]. biCompression = 0 ifFalse:[^false]. ^true! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'CamilloBruni 5/7/2012 01:06'! readAllFrom: fd "MessageTally spyOn:[BMPReadWriter readAllFrom: FileDirectory default]" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [Form fromBinaryStream: (fd readOnlyFileNamed: fName)] on: Error do:[:nix]. ]. ]. fd directoryNames do:[:fdName| self readAllFrom: (fd / fdName) ].! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'CamilloBruni 5/7/2012 01:06'! displayAllFrom: fd "BMPReadWriter displayAllFrom: FileDirectory default" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [(Form fromBinaryStream: (fd readOnlyFileNamed: fName)) display. Display forceDisplayUpdate] on: Error do:[:nix|]. ]. ]. fd directoryNames do:[:fdName| self displayAllFrom: (fd / fdName) ].! ! !BMPReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('bmp')! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'! bmpData32bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest32b.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk04AQAAAAAAADYAAAAoAAAACAAAAAgAAAABACAAAAAAAAIBAADDDgAAww4AAAAAAAAAAAAA AP8AAAD/AAAA/wAAAP8AAP8AAAD/AAAA/wAAAP8AAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8A AAD/AAAA/wAAAAD/AAAA/wAA////AP///wD///8A////AP8AAAD/AAAAAP8AAAD/AAD///8A ////AP///wD///8A/wAAAP8AAAAAAAAAAAAAAP///wD///8A////AP///wAAAP8AAAD/AAAA AAAAAAAA////AP///wD///8A////AAAA/wAAAP8AAAAAAAAAAAAAAAAAAAAAAAAA/wAAAP8A AAD/AAAA/wAAAAAAAAAAAAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAA' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'! bmpData24bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest24.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk32AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABgAAAAAAAAAAADEDgAAxA4AAAAAAAAAAAAA AP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8AAP8AAP8A/wAA/wAA/wAA/wAAAP8AAP8A /////////////////wAA/wAAAP8AAP8A/////////////////wAA/wAAAAAAAAAA//////// ////////AAD/AAD/AAAAAAAA////////////////AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/ AAD/AAD/AAAAAAAAAAAAAAAAAAD/AAD/AAD/AAD/' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'! bmpDataR5G6B5 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16-R5G6B5.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA APgAAOAHAAAfAAAAAAAAAOAH4AfgB+AHHwAfAB8AHwDgB+AH4AfgBx8AHwAfAB8A4AfgB/// ////////HwAfAOAH4Af//////////x8AHwAAAAAA//////////8A+AD4AAAAAP////////// APgA+AAAAAAAAAAAAPgA+AD4APgAAAAAAAAAAAD4APgA+AD4AAA=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 02:22'! bmpData16bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16b.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk24AAAAAAAAADYAAAAoAAAACAAAAAgAAAABABAAAAAAAIIAAADDDgAAww4AAAAAAAAAAAAA 4APgA+AD4AMfAB8AHwAfAOAD4APgA+ADHwAfAB8AHwDgA+AD/3//f/9//38fAB8A4APgA/9/ /3//f/9/HwAfAAAAAAD/f/9//3//fwB8AHwAAAAA/3//f/9//38AfAB8AAAAAAAAAAAAfAB8 AHwAfAAAAAAAAAAAAHwAfAB8AHwAAA==' readStream) contents! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp16Bit | reader form | reader := BMPReadWriter new on: self bmpData16bit readStream. form := reader nextImage. "special black here to compensate for zero-is-transparent effect" self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white. self assert: (form pixelValueAt: 1 @ 1) = 32768! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:41'! bmpData4bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest4.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg 4ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6 +vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5 AAAAAPn5+fk=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp8Bit | reader form | reader := BMPReadWriter new on: self bmpData8bit readStream. form := reader nextImage. self assert: (form colorAt: 1 @ 1) = Color black. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/24/2005 21:27'! bmpData8bit "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest8.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk12BAAAAAAAADYEAAAoAAAACAAAAAgAAAABAAgAAAAAAEAAAADEDgAAxA4AAAAAAAAAAAAA AAAAAAAAgAAAgAAAAICAAIAAAACAAIAAgIAAAMDAwADA3MAA8MqmAAAgQAAAIGAAACCAAAAg oAAAIMAAACDgAABAAAAAQCAAAEBAAABAYAAAQIAAAECgAABAwAAAQOAAAGAAAABgIAAAYEAA AGBgAABggAAAYKAAAGDAAABg4AAAgAAAAIAgAACAQAAAgGAAAICAAACAoAAAgMAAAIDgAACg AAAAoCAAAKBAAACgYAAAoIAAAKCgAACgwAAAoOAAAMAAAADAIAAAwEAAAMBgAADAgAAAwKAA AMDAAADA4AAA4AAAAOAgAADgQAAA4GAAAOCAAADgoAAA4MAAAODgAEAAAABAACAAQABAAEAA YABAAIAAQACgAEAAwABAAOAAQCAAAEAgIABAIEAAQCBgAEAggABAIKAAQCDAAEAg4ABAQAAA QEAgAEBAQABAQGAAQECAAEBAoABAQMAAQEDgAEBgAABAYCAAQGBAAEBgYABAYIAAQGCgAEBg wABAYOAAQIAAAECAIABAgEAAQIBgAECAgABAgKAAQIDAAECA4ABAoAAAQKAgAECgQABAoGAA QKCAAECgoABAoMAAQKDgAEDAAABAwCAAQMBAAEDAYABAwIAAQMCgAEDAwABAwOAAQOAAAEDg IABA4EAAQOBgAEDggABA4KAAQODAAEDg4ACAAAAAgAAgAIAAQACAAGAAgACAAIAAoACAAMAA gADgAIAgAACAICAAgCBAAIAgYACAIIAAgCCgAIAgwACAIOAAgEAAAIBAIACAQEAAgEBgAIBA gACAQKAAgEDAAIBA4ACAYAAAgGAgAIBgQACAYGAAgGCAAIBgoACAYMAAgGDgAICAAACAgCAA gIBAAICAYACAgIAAgICgAICAwACAgOAAgKAAAICgIACAoEAAgKBgAICggACAoKAAgKDAAICg 4ACAwAAAgMAgAIDAQACAwGAAgMCAAIDAoACAwMAAgMDgAIDgAACA4CAAgOBAAIDgYACA4IAA gOCgAIDgwACA4OAAwAAAAMAAIADAAEAAwABgAMAAgADAAKAAwADAAMAA4ADAIAAAwCAgAMAg QADAIGAAwCCAAMAgoADAIMAAwCDgAMBAAADAQCAAwEBAAMBAYADAQIAAwECgAMBAwADAQOAA wGAAAMBgIADAYEAAwGBgAMBggADAYKAAwGDAAMBg4ADAgAAAwIAgAMCAQADAgGAAwICAAMCA oADAgMAAwIDgAMCgAADAoCAAwKBAAMCgYADAoIAAwKCgAMCgwADAoOAAwMAAAMDAIADAwEAA wMBgAMDAgADAwKAA8Pv/AKSgoACAgIAAAAD/AAD/AAAA//8A/wAAAP8A/wD//wAA////APr6 +vr8/Pz8+vr6+vz8/Pz6+v/////8/Pr6//////z8AAD/////+fkAAP/////5+QAAAAD5+fn5 AAAAAPn5+fk=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:05'! bmpDataX8R8G8B8 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest32-X8R8G8B8.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk1IAQAAAAAAAEYAAAA4AAAACAAAAAgAAAABACAAAwAAAAIBAADDDgAAww4AAAAAAAAAAAAA AAAA/wAA/wAA/wAAAAAAAAAA/wAAAP8AAAD/AAAA/wAA/wAAAP8AAAD/AAAA/wAAAAD/AAAA /wAAAP8AAAD/AAD/AAAA/wAAAP8AAAD/AAAAAP8AAAD/AAD///8A////AP///wD///8A/wAA AP8AAAAA/wAAAP8AAP///wD///8A////AP///wD/AAAA/wAAAAAAAAAAAAAA////AP///wD/ //8A////AAAA/wAAAP8AAAAAAAAAAAD///8A////AP///wD///8AAAD/AAAA/wAAAAAAAAAA AAAAAAAAAAAAAAD/AAAA/wAAAP8AAAD/AAAAAAAAAAAAAAAAAAAAAAAAAP8AAAD/AAAA/wAA AP8AAA==' readStream) contents! ! !BMPReadWriterTest methodsFor: 'data' stamp: 'ar 10/25/2005 14:04'! bmpDataX4R4G4B4 "This is a BMP file based on BitmapV4Header which is currently unsupported." "Created via: (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: 'bmptest16-X4R4G4B4.bmp') binary) contents " ^(Base64MimeConverter mimeDecodeToBytes: 'Qk3IAAAAAAAAAEYAAAA4AAAACAAAAAgAAAABABAAAwAAAIIAAADDDgAAww4AAAAAAAAAAAAA AA8AAPAAAAAPAAAAAAAAAPAA8ADwAPAADwAPAA8ADwDwAPAA8ADwAA8ADwAPAA8A8ADwAP8P /w//D/8PDwAPAPAA8AD/D/8P/w//Dw8ADwAAAAAA/w//D/8P/w8ADwAPAAAAAP8P/w//D/8P AA8ADwAAAAAAAAAAAA8ADwAPAA8AAAAAAAAAAAAPAA8ADwAPAAA=' readStream) contents! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'tbn 12/27/2010 10:17'! testBmp24Bit | reader form | reader := BMPReadWriter new on: (ReadStream on: self bmpData24bit). form := reader nextImage. self assert: (form colorAt: 7@1) = Color red. self assert: (form colorAt: 1@7) = Color green. self assert: (form colorAt: 7@7) = Color blue. self assert: (form colorAt: 4@4) = Color white. self assert: (form pixelValueAt: 1@1) = 16rFF000001. ! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp4Bit | reader form | reader := BMPReadWriter new on: self bmpData4bit readStream. form := reader nextImage. self assert: (form colorAt: 1 @ 1) = Color black. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white! ! !BMPReadWriterTest methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 14:57'! testBmp32Bit | reader form | reader := BMPReadWriter new on: self bmpData32bit readStream. form := reader nextImage. self assert: (form colorAt: 7 @ 1) = Color red. self assert: (form colorAt: 1 @ 7) = Color green. self assert: (form colorAt: 7 @ 7) = Color blue. self assert: (form colorAt: 4 @ 4) = Color white. self assert: (form pixelValueAt: 1 @ 1) = 4278190080! ! !BadEqualer commentStamp: 'mjr 8/20/2003 13:28'! I am an object that doesn't always report #= correctly. Used for testing the EqualityTester.! !BadEqualer methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! = other self class = other class ifFalse: [^ false]. ^ 100 atRandom < 30 ! ! !BadHasher commentStamp: 'mjr 8/20/2003 13:28'! I am an object that doesn't always hash correctly. I am used for testing the HashTester.! !BadHasher methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! hash "answer with a different hash some of the time" 100 atRandom < 30 ifTrue: [^ 1]. ^ 2! ! !Bag commentStamp: ''! I represent an unordered collection of possibly duplicate elements. I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.! !Bag methodsFor: 'math functions' stamp: 'ul 11/7/2010 01:46'! sum "Faster than the superclass implementation when you hold many instances of the same value (which you probably do, otherwise you wouldn't be using a Bag)." | sum first | first := true. contents keysAndValuesDo: [ :value :count | first ifTrue: [ sum := value * count. first := false ] ifFalse: [ sum := sum + (value * count) ] ]. first ifTrue: [ self errorEmptyCollection ]. ^sum! ! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:35'! size "Answer how many elements the receiver contains." | tally | tally := 0. contents do: [:each | tally := tally + each]. ^ tally! ! !Bag methodsFor: 'testing' stamp: ''! occurrencesOf: anObject "Refer to the comment in Collection|occurrencesOf:." (self includes: anObject) ifTrue: [^contents at: anObject] ifFalse: [^0]! ! !Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:20'! add: newObject withOccurrences: anInteger "Add newObject anInteger times to the receiver. Answer newObject." contents at: newObject put: (contents at: newObject ifAbsent: [0]) + anInteger. ^ newObject! ! !Bag methodsFor: 'removing' stamp: 'sma 5/12/2000 14:32'! remove: oldObject ifAbsent: exceptionBlock "Refer to the comment in Collection|remove:ifAbsent:." | count | count := contents at: oldObject ifAbsent: [^ exceptionBlock value]. count = 1 ifTrue: [contents removeKey: oldObject] ifFalse: [contents at: oldObject put: count - 1]. ^ oldObject! ! !Bag methodsFor: 'accessing' stamp: 'tao 1/5/2000 18:25'! cumulativeCounts "Answer with a collection of cumulative percents covered by elements so far." | s n | s := self size / 100.0. n := 0. ^ self sortedCounts asArray collect: [:a | n := n + a key. (n / s roundTo: 0.1) -> a value]! ! !Bag methodsFor: 'private' stamp: 'sma 5/12/2000 14:49'! setContents: aDictionary contents := aDictionary! ! !Bag methodsFor: 'accessing' stamp: 'md 1/20/2006 15:58'! valuesAndCounts ^ contents! ! !Bag methodsFor: 'testing' stamp: ''! includes: anObject "Refer to the comment in Collection|includes:." ^contents includesKey: anObject! ! !Bag methodsFor: 'comparing' stamp: 'md 10/17/2004 16:09'! = aBag "Two bags are equal if (a) they are the same 'kind' of thing. (b) they have the same size. (c) each element occurs the same number of times in both of them" (aBag isKindOf: Bag) ifFalse: [^false]. self size = aBag size ifFalse: [^false]. contents associationsDo: [:assoc| (aBag occurrencesOf: assoc key) = assoc value ifFalse: [^false]]. ^true ! ! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'! at: index self errorNotKeyed! ! !Bag methodsFor: 'enumerating' stamp: 'StephaneDucasse 8/12/2013 15:39'! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! ! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'! at: index put: anObject self errorNotKeyed! ! !Bag methodsFor: 'converting' stamp: 'nice 10/20/2009 19:37'! asSet "Answer a set with the elements of the receiver." ^ contents keys asSet! ! !Bag methodsFor: 'accessing' stamp: 'StephaneDucasse 12/25/2009 12:32'! sortedElements "Answer with a collection of elements with counts, sorted by element." "Suggested by l. Uzonyi" ^contents associations sort; yourself! ! !Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:18'! add: newObject "Include newObject as one of the receiver's elements. Answer newObject." ^ self add: newObject withOccurrences: 1! ! !Bag methodsFor: 'copying' stamp: 'nice 10/5/2009 08:54'! postCopy super postCopy. contents := contents copy! ! !Bag methodsFor: 'accessing' stamp: 'StephaneDucasse 12/25/2009 12:11'! sortedCounts "Answer with a collection of counts with elements, sorted by decreasing count." "Suggested by l. Uzonyi" ^(Array new: contents size streamContents: [ :stream | contents associationsDo: [ :each | stream nextPut: each value -> each key ] ]) sort: [:x :y | x >= y ]; yourself! ! !Bag methodsFor: 'enumerating' stamp: 'StephaneDucasse 8/12/2013 15:39'! keysAndValuesDo: aTwoArgBlock "Iterate over the receiver and apply a two argument block on the element and its occurrences." contents associationsDo: [:assoc | aTwoArgBlock value: assoc key value: assoc value ]! ! !Bag methodsFor: 'enumerating' stamp: 'StephaneDucasse 8/12/2013 15:38'! doWithOccurrences: aTwoArgBlock "Iterate over the receiver and apply a two argument block on the element and its occurrences." contents associationsDo: [:assoc | aTwoArgBlock value: assoc key value: assoc value ]! ! !Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:34'! asBag ^ self! ! !Bag methodsFor: 'removing' stamp: 'nice 9/14/2009 20:28'! removeAll "Implementation Note: as contents will be overwritten, a shallowCopy of self would be modified. An alternative implementation preserving capacity would be to create a new contents: self setContents: (self class contentsClass new: contents size)." contents removeAll! ! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! new: nElements ^ super new setContents: (self contentsClass new: nElements)! ! !Bag class methodsFor: '*Spec-Inspector' stamp: 'ClementBera 8/12/2013 10:28'! inspectorClass ^ EyeBagInspector! ! !Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 13:31'! new ^ self new: 4! ! !Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:17'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." ^ self withAll: aCollection "Examples: Bag newFrom: {1. 2. 3. 3} {1. 2. 3. 3} as: Bag "! ! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! contentsClass ^Dictionary! ! !BagEyeElement commentStamp: ''! I am an eye element for bags, showing appropriate thing with occurrences! !BagEyeElement methodsFor: 'accessing' stamp: 'ClementBera 8/12/2013 10:35'! value ^ self host valuesAndCounts at: self index! ! !BagEyeElement methodsFor: 'actions' stamp: 'ClementBera 8/12/2013 10:36'! save: aValue self host valuesAndCounts at: self index put: aValue! ! !BagEyeElement methodsFor: 'accessing' stamp: 'ClementBera 8/12/2013 10:24'! accessorCode ^ '(self occurrencesOf: ', self label, ')'! ! !BagTest commentStamp: 'TorstenBergmann 2/20/2014 15:20'! SUnit tests for bags! !BagTest methodsFor: 'tests - set arithmetic' stamp: ''! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !BagTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''! testOccurrencesOfForMultipliness | collection elem | collection := self collectionWithEqualElements . elem := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: elem ) = 2. ! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! testCumulativeCounts "self run: #testCumulativeCounts" "self debug: #testCumulativeCounts" | bag cumulativeCounts | bag := Bag new. bag add: '1' withOccurrences: 50. bag add: '2' withOccurrences: 40. bag add: '3' withOccurrences: 10. cumulativeCounts := bag cumulativeCounts. self assert: cumulativeCounts size = 3. self assert: cumulativeCounts first = (50 -> '1'). self assert: cumulativeCounts second = (90 -> '2'). self assert: cumulativeCounts third = (100 -> '3'). ! ! !BagTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementReallyRemovesElement "self debug: #testRemoveElementReallyRemovesElement" | size | size := self nonEmptyWithoutEqualElements size. self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! !BagTest methodsFor: 'tests - converting' stamp: ''! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! testSortedElements "self run: #testSortedElements" "self debug: #testSortedElements" | bag sortedElements| bag := Bag new. bag add: '2' withOccurrences: 1. bag add: '1' withOccurrences: 10. bag add: '3' withOccurrences: 5. sortedElements := bag sortedElements. self assert: sortedElements size = 3. self assert: sortedElements first = ('1'->10). self assert: sortedElements second = ('2'->1). self assert: sortedElements third = ('3'->5). ! ! !BagTest methodsFor: 'tests - converting' stamp: ''! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:29'! testAsSet | aBag aSet | aBag := Bag new. aBag add:'a' withOccurrences: 4. aBag add:'b' withOccurrences: 2. aSet := aBag asSet. self assert: aSet size = 2. self assert: (aSet occurrencesOf: 'a') = 1 ! ! !BagTest methodsFor: 'tests - adding' stamp: ''! testTWrite | added collection elem | collection := self otherCollection . elem := self element . added := collection write: elem . self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: elem ) . self assert: (collection includes: elem ). ! ! !BagTest methodsFor: 'tests - converting' stamp: ''! testAsByteArray | res | self integerCollectionWithoutEqualElements. self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ]. res := true. self integerCollectionWithoutEqualElements detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0TStructuralEqualityTest self empty. self nonEmpty. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty! ! !BagTest methodsFor: 'test - creation' stamp: ''! testWithWithWith "self debug: #testWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !BagTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:53'! firstCollection " return a collection that will be the first part of the concatenation" ^ nonEmpty ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 12:07'! collectionInForIncluding ^ collectionIn ! ! !BagTest methodsFor: 'tests - concatenation' stamp: ''! testConcatenationWithDuplicate | collection1 collection2 result | collection1 := self firstCollection . collection2 := self firstCollection . result := collection1 , collection2. result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ]. self assert: result size = (collection1 size * 2)! ! !BagTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !BagTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! collectionOfFloat ^ collectionOfString! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'! testAdd "self run: #testAdd" "self debug: #testAdd" | aBag | aBag := Bag new. aBag add: 'a'. aBag add: 'b'. self assert: aBag size = 2. aBag add: 'a'. self assert: aBag size = 3. self assert: (aBag occurrencesOf: 'a') = 2 ! ! !BagTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collectionWithoutEqualElements difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res size equals: self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (res includes: each)]. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res equals: separateCol! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! collectionWithoutEqualElements ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'tests - converting' stamp: ''! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !BagTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asArray sort. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !BagTest methodsFor: 'requirements' stamp: 'sd 1/28/2009 16:32'! collectionWithElement "Returns a collection that already includes what is returned by #element." ^ collectionWithElement! ! !BagTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !BagTest methodsFor: 'tests - adding' stamp: ''! testTWriteTwice | added oldSize collection elem | collection := self collectionWithElement . elem := self element . oldSize := collection size. added := collection write: elem ; write: elem . self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: elem ). self assert: collection size = (oldSize + 2)! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:21'! withEqualElements " return a collection including equal elements (classic equality)" ^ nonEmpty .! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCloneTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !BagTest methodsFor: 'test - creation' stamp: ''! testWith "self debug: #testWith" | aCol anElement | anElement := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: anElement. self assert: (aCol includes: anElement).! ! !BagTest methodsFor: 'tests - copy' stamp: ''! testCopyNotSame "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self nonEmpty copy. self deny: copy == self nonEmpty.! ! !BagTest methodsFor: 'tests - adding' stamp: ''! testTAddIfNotPresentWithElementAlreadyIn | added oldSize collection anElement | collection := self collectionWithElement . oldSize := collection size. anElement := self element . self assert: (collection includes: anElement ). added := collection addIfNotPresent: anElement . self assert: added == anElement . "test for identiy because #add: has not reason to copy its parameter." self assert: collection size = oldSize! ! !BagTest methodsFor: 'tests - printing' stamp: ''! testPrintOn | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)).]. ].! ! !BagTest methodsFor: 'tests - adding' stamp: ''! testTAddAll | added collection toBeAdded | collection := self collectionWithElement . toBeAdded := self otherCollection . added := collection addAll: toBeAdded . self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." self assert: (collection includesAll: toBeAdded )! ! !BagTest methodsFor: 'tests - printing' stamp: ''! testPrintElementsOn | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)). ].! ! !BagTest methodsFor: 'tests - adding' stamp: ''! testTAddWithOccurences | added oldSize collection anElement | collection := self collectionWithElement . anElement := self element . oldSize := collection size. added := collection add: anElement withOccurrences: 5. self assert: added == anElement. "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: anElement). self assert: collection size = (oldSize + 5)! ! !BagTest methodsFor: 'tests - concatenation' stamp: ''! testConcatenationWithEmpty | result | result := self firstCollection , self empty. self assert: result = self firstCollection! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:30'! testCopy "self run: #testCopy" | aBag newBag | aBag := Bag new. aBag add:'a' withOccurrences: 4. aBag add:'b' withOccurrences: 2. newBag := aBag copy. self assert: newBag = newBag. self assert: newBag asSet size = 2.! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:28'! testAddWithOccurrences "self debug:#testAddWithOccurrences" | aBag | aBag := Bag new. aBag add: 'a' withOccurrences: 3. self assert: (aBag size = 3). ! ! !BagTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:58'! anotherElementNotIn ^ 42! ! !BagTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementFromEmpty "self debug: #testRemoveElementFromEmpty" self should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] raise: Error! ! !BagTest methodsFor: 'tests - remove' stamp: ''! testRemoveIfAbsent "self debug: #testRemoveElementThatExists" | el res | el := self elementNotIn. res := self nonEmptyWithoutEqualElements remove: el ifAbsent: [ 33 ]. self assert: res = 33! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! collectionWithElementsToRemove ^ collectionIn! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString tmp | delim := ', '. last := 'and'. result:=''. tmp := self nonEmpty collect: [:each | each asString]. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) | i= allElementsAsString size ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. ]. ! ! !BagTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/30/2009 17:37'! expectedSizeAfterReject ^ 2! ! !BagTest methodsFor: 'test - remove' stamp: 'damienpollet 1/30/2009 17:15'! elementTwiceIn ^ super elementTwiceIn! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !BagTest methodsFor: 'tests - adding' stamp: ''! testTAdd | added collection | collection :=self otherCollection . added := collection add: self element. self assert: added == self element. "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: self element) . self assert: (self collectionWithElement includes: self element). ! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeTest | anElementIn | self nonEmpty. self deny: self nonEmpty isEmpty. self elementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self anotherElementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self empty. self assert: self empty isEmpty! ! !BagTest methodsFor: 'tests - includes' stamp: 'CamilloBruni 8/31/2013 20:23'! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection anElement | self collectionWithCopyNonIdentical. collection := self collectionWithCopyNonIdentical. anElement := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: anElement)! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! testEqual "(self run: #testEqual)" "(self debug: #testEqual)" | bag1 bag2 | bag1 := Bag new. bag2 := Bag new. self assert: bag1 = bag2. bag1 add: #a; add: #b. bag2 add: #a; add: #a. self deny: bag1 = bag2. self assert: bag1 = bag1. bag1 add: #a. bag2 add: #b. self assert: bag1 = bag2. bag1 add: #c. self deny: bag1 = bag2. bag2 add: #c. self assert: bag1 = bag2! ! !BagTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotInForOccurrences). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotInForOccurrences)! ! !BagTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do: [:each1 | self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] ]. ! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSetAritmeticTest self collection. self deny: self collection isEmpty. self nonEmpty. self deny: self nonEmpty isEmpty. self anotherElementOrAssociationNotIn. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self collectionClass! ! !BagTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiter | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)) ].! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeWithIdentityTest | anElement | self collectionWithCopyNonIdentical. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy! ! !BagTest methodsFor: 'tests - adding' stamp: ''! testTAddTwice | added oldSize collection anElement | collection := self collectionWithElement . anElement := self element . oldSize := collection size. added := collection add: anElement ; add: anElement . self assert: added == anElement . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: anElement ). self assert: collection size = (oldSize + 2)! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:15'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ collectionWithoutNilMoreThan5! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! integerCollectionWithoutEqualElements ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self collectionWithoutEqualElements. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !BagTest methodsFor: 'tests - copy' stamp: ''! testCopyEquals "self debug: #testCopySameClass" "A copy should be equivalent to the things it's a copy of" | copy | copy := self nonEmpty copy. self assert: copy = self nonEmpty.! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:02'! testCreation "self run: #testCreation" "self debug: #testCreation" | bag | bag := Bag new. self assert: (bag size) = 0. self assert: (bag isEmpty). ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:32'! elementInForOccurrences " return an element included in nonEmpty" ^self nonEmpty anyOne.! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterMore | delim multiItemStream result allElementsAsString tmp | delim := ', '. result:=''. tmp:= self nonEmpty collect:[:each | each asString]. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. allElementsAsString := (result findBetweenSubStrs: ', ' ). allElementsAsString do: [:each | self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). ].! ! !BagTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementThatExists "self debug: #testRemoveElementThatExists" | el res | el := self nonEmptyWithoutEqualElements anyOne. res := self nonEmptyWithoutEqualElements remove: el. self assert: res == el! ! !BagTest methodsFor: 'tests - adding' stamp: ''! testTAddIfNotPresentWithNewElement | added oldSize collection elem | collection := self otherCollection . oldSize := collection size. elem := self element . self deny: (collection includes: elem ). added := collection addIfNotPresent: elem . self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection size = (oldSize + 1)). ! ! !BagTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !BagTest methodsFor: 'tests - iterating' stamp: 'damienpollet 1/13/2009 15:57'! testAnySastify self assert: ( self collection anySatisfy: [:each | each = self element]). self deny: (self collection anySatisfy: [:each | each isString]).! ! !BagTest methodsFor: 'tests - includes' stamp: ''! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !BagTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:16'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^ collectionWithoutNilMoreThan5 ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:19'! elementsCopyNonIdenticalWithoutEqualElements " return a collection that does niot incllude equal elements ( classic equality ) all elements included are elements for which copy is not identical to the element " ^ collectionOfString ! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureAsStringCommaAndDelimiterTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty. self nonEmpty1Element. self assert: self nonEmpty1Element size = 1! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! testRemove "self run: #testRemove" "self debug: #testRemove" | bag item | item := 'test item'. bag := Bag new. bag add: item. self assert: (bag size) = 1. bag remove: item. self assert: bag isEmpty. bag add: item withOccurrences: 2. bag remove: item. bag remove: item. self assert: (bag size) = 0. self should: [bag remove: item.] raise: Error.! ! !BagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! testSortedCounts "self run: #testSortedCounts" "self debug: #testSortedCounts" | bag sortedCounts| bag := Bag new. bag add: '1' withOccurrences: 10. bag add: '2' withOccurrences: 1. bag add: '3' withOccurrences: 5. sortedCounts := bag sortedCounts. self assert: sortedCounts size = 3. self assert: sortedCounts first = (10->'1'). self assert: sortedCounts second = (5->'3'). self assert: sortedCounts third = (1->'2'). ! ! !BagTest methodsFor: 'tests - converting' stamp: ''! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureOccurrencesForMultiplinessTest | cpt anElement collection | self collectionWithEqualElements. self collectionWithEqualElements. self elementTwiceInForOccurrences. anElement := self elementTwiceInForOccurrences. collection := self collectionWithEqualElements. cpt := 0. " testing with identity check ( == ) so that identy collections can use this trait : " self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. self assert: cpt = 2! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !BagTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAny: self empty). self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAny: self nonEmpty).! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:14'! nonEmpty ^ nonEmpty ! ! !BagTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! elementToAdd ^ 42! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCreationWithTest self collectionMoreThan5Elements. self assert: self collectionMoreThan5Elements size >= 5! ! !BagTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyNonEmpty "self debug: #testCopyNonEmpty" | copy | copy := self nonEmpty copy. self deny: copy isEmpty. self assert: copy size = self nonEmpty size. self nonEmpty do: [:each | copy includes: each]! ! !BagTest methodsFor: 'tests - remove' stamp: ''! testRemoveAllFoundIn "self debug: #testRemoveElementThatExists" | el aSubCollection res | el := self nonEmptyWithoutEqualElements anyOne. aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. res := self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureRequirementsOfTAddTest self collectionWithElement. self otherCollection. self element. self assert: (self collectionWithElement includes: self element). self deny: (self otherCollection includes: self element)! ! !BagTest methodsFor: 'tests - printing' stamp: ''! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !BagTest methodsFor: 'test - equality' stamp: ''! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !BagTest methodsFor: 'test - creation' stamp: ''! testWithWith "self debug: #testWithWith" | aCol collection element1 element2 | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . element1 := collection at: 1. element2 := collection at:2. aCol := self collectionClass with: element1 with: element2 . self assert: (aCol occurrencesOf: element1 ) = ( collection occurrencesOf: element1). self assert: (aCol occurrencesOf: element2 ) = ( collection occurrencesOf: element2). ! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTRemoveTest | duplicate | self empty. self nonEmptyWithoutEqualElements. self deny: self nonEmptyWithoutEqualElements isEmpty. duplicate := true. self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ]. self assert: duplicate = false. self elementNotIn. self assert: self empty isEmpty. self deny: self nonEmptyWithoutEqualElements isEmpty. self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! !BagTest methodsFor: 'setup' stamp: 'delaunay 5/11/2009 11:27'! sizeCollection ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:22'! collectionWithCharacters ^ collectionWithCharacters .! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsCommaStringMore | result resultAnd index allElementsAsString tmp | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . tmp :=OrderedCollection new. self nonEmpty do: [ :each | tmp add: each asString]. "verifying result :" index := 1. allElementsAsString := (result findBetweenSubStrs: ', ' ). allElementsAsString do: [:each | self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) | i= allElementsAsString size ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. ].! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:13'! empty ^ empty ! ! !BagTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res anElement | anElement := self elementToAdd . res := self nonEmpty copyWith: anElement. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: (anElement value)). self nonEmpty do: [ :each | res includes: each ]! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! testCopyNonEmptyWithoutAllNotIncluded ! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:22'! collection ^ nonEmpty. ! ! !BagTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/30/2009 17:36'! doWithoutNumber ^ 4! ! !BagTest methodsFor: 'tests' stamp: 'nice 9/14/2009 21:05'! testRemoveAll "Allows one to remove all elements of a collection" | c1 c2 s2 | c1 := #(10 9 8 7 5 4 4 2) asBag. c2 := c1 copy. s2 := c2 size. c1 removeAll. self assert: c1 size = 0. self assert: c2 size = s2 description: 'the copy has not been modified'.! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:01'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne! ! !BagTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:20'! collectionWithEqualElements ^ nonEmpty ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:31'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ nonEmpty ! ! !BagTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !BagTest methodsFor: 'tests - converting' stamp: ''! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTConvertAsSetForMultiplinessTest "a collection with equal elements:" | res | self withEqualElements. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true! ! !BagTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !BagTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !BagTest methodsFor: 'test - creation' stamp: ''! testWithAll "self debug: #testWithAll" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection . aCol := self collectionClass withAll: collection . collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. self assert: (aCol size = collection size ).! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 12:08'! collectionNotIncluded ^ collectionNotIn ! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ 666! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureOccurrencesTest | tmp | self empty. self assert: self empty isEmpty. self collectionWithoutEqualElements. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each ]. self elementNotInForOccurrences. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !BagTest methodsFor: 'test - equality' stamp: ''! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !BagTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:01'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:53'! secondCollection " return a collection that will be the second part of the concatenation" ^ collectionWithCharacters ! ! !BagTest methodsFor: 'tests - concatenation' stamp: ''! testConcatenation "| collection1 collection2 result | collection1 := self firstCollection . collection2 := self secondCollection . result := collection1 , collection2. collection1 do:[ :each | self assert: (result includes: each)]. collection2 do:[ :each | self assert: (result includes: each)]." | collection1 collection2 result | collection1 := self firstCollection . collection2 := self secondCollection . result := collection1 , collection2. result do: [ :each | self assert: (result occurrencesOf: each) = (( collection1 occurrencesOf: each ) + ( collection2 occurrencesOf: each ) ). ]. self assert: result size = (collection1 size + collection2 size)! ! !BagTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !BagTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !BagTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !BagTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" | difference | self assert: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements) isEmpty. self assert: (self empty difference: self collectionWithoutEqualElements) isEmpty. difference := (self collectionWithoutEqualElements difference: self empty). self assert: difference size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each)]. ! ! !BagTest methodsFor: 'tests - as set tests' stamp: ''! testAsIdentitySetWithEqualsElements | result collection | collection := self withEqualElements . result := collection asIdentitySet. collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = IdentitySet.! ! !BagTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionItself "self debug: #testIntersectionItself" | result | result := (self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements). self assert: result size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (result includes: each) ]. ! ! !BagTest methodsFor: 'basic tests' stamp: 'sd 3/21/2006 22:32'! testOccurrencesOf "self debug: #testOccurrencesOf" | aBag | aBag := Bag new. aBag add: 'a' withOccurrences: 3. aBag add: 'b'. aBag add: 'b'. aBag add: 'b'. aBag add: 'b'. self assert: (aBag occurrencesOf:'a') = 3. self assert: (aBag occurrencesOf:'b') = 4. self assert: (aBag occurrencesOf:'c') = 0. self assert: (aBag occurrencesOf: nil) =0. aBag add: nil. self assert: (aBag occurrencesOf: nil) =1. ! ! !BagTest methodsFor: 'tests - converting' stamp: ''! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:33'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ self elementTwiceIn ! ! !BagTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:32'! element ^ super element! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:26'! emptyButAllocatedWith20 ^ emptyButAllocatedWith20! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! otherCollection ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 8/31/2013 20:53'! test0CopyTest self empty. self assert: self empty size = 0. self nonEmpty. self assert: (self nonEmpty size = 0) not. self collectionWithElementsToRemove. self assert: (self collectionWithElementsToRemove size = 0) not. self elementToAdd! ! !BagTest methodsFor: 'tests - remove' stamp: ''! testRemoveAllSuchThat "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self nonEmptyWithoutEqualElements anyOne. aSubCollection := self nonEmptyWithoutEqualElements copyWithout: el. self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | aSubCollection includes: each ]. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !BagTest methodsFor: 'test - remove' stamp: 'damienpollet 1/30/2009 17:07'! testRemoveElementThatExistsTwice "self debug: #testRemoveElementThatDoesExistsTwice" | size | size := self nonEmpty size. self assert: (self nonEmpty includes: self elementTwiceIn). self nonEmpty remove: self elementTwiceIn. self assert: size - 1 = self nonEmpty size! ! !BagTest methodsFor: 'setup' stamp: 'cyrille.delaunay 12/18/2009 13:12'! result ^ collectResult. ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ collectionOfString! ! !BagTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !BagTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:28'! nonEmptyWithoutEqualElements " return a collection without equal elements " ^ otherCollectionWithoutEqualElements ! ! !BagTest methodsFor: 'test - set arithmetic' stamp: 'stephane.ducasse 12/20/2008 22:46'! collectionClass ^ Bag! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/30/2009 10:54'! nonEmpty1Element ^ self speciesClass new add: self element ;yourself.! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureConcatenationTest self firstCollection. self deny: self firstCollection isEmpty. self firstCollection. self deny: self firstCollection isEmpty. self empty. self assert: self empty isEmpty! ! !BagTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !BagTest methodsFor: 'test - equality' stamp: ''! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !BagTest methodsFor: 'test - creation' stamp: ''! testWithWithWithWith "self debug: #testWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !BagTest methodsFor: 'tests - copy' stamp: ''! testCopySameClass "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self empty copy. self assert: copy class == self empty class.! ! !BagTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/6/2008 17:39'! speciesClass ^ Bag! ! !BagTest methodsFor: 'tests - set arithmetic' stamp: ''! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !BagTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:40'! selectedNumber ^ 4! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsCommaStringOne self nonEmpty1Element do: [:each | self assert: each asString =self nonEmpty1Element asCommaString. self assert: each asString=self nonEmpty1Element asCommaStringAnd.]. ! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePrintTest self nonEmpty. self deny: self nonEmpty isEmpty! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:40'! elementNotIn ^elementNotIn ! ! !BagTest methodsFor: 'setup' stamp: 'cyrille.delaunay 12/18/2009 13:12'! setUp empty := self speciesClass new. nonEmpty := self speciesClass new add: 13; add: -2; add: self elementTwiceIn; add: 10; add: self elementTwiceIn; add: self element; yourself. elementNotIn := 0. collectionIn := self speciesClass new add: -2; add: self elementTwiceIn; add: 10; yourself. collectionNotIn := self speciesClass new add: self elementNotIn; add: 5; yourself. collectionOfString := self speciesClass new add: 1.5; add: 5.5; add: 7.5; yourself. otherCollectionWithoutEqualElements := self speciesClass new add: 1; add: 20; add: 30; add: 40; yourself. collectionWithoutNilMoreThan5 := self speciesClass new add: 1; add: 2; add: 3; add: 4; add: 5; add: 6; yourself. collectResult := self speciesClass new add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; add: SmallInteger; yourself. emptyButAllocatedWith20 := self speciesClass new: 20. collectionWithElement := self speciesClass new add: self element; yourself. collectionWithCharacters := self speciesClass new add: $p; add: $v; add: $i; add: $y; yourself! ! !BagTest methodsFor: 'tests - includes' stamp: ''! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !BagTest methodsFor: 'test - creation' stamp: ''! testWithWithWithWithWith "self debug: #testWithWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !BagTest methodsFor: 'tests - as set tests' stamp: ''! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !BagTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiterLast | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. ].! ! !BagTest methodsFor: 'basic tests' stamp: 'TJ 3/8/2006 08:42'! testAsBag | aBag | aBag := Bag new. self assert: aBag asBag = aBag.! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do: [:each1 | self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] ]. ! ! !BagTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWith "self debug: #testCopyWith" | res anElement | anElement := self elementToAdd. res := self empty copyWith: anElement. self assert: res size = (self empty size + 1). self assert: (res includes: (anElement value))! ! !BagTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureConverAsSortedTest self collectionWithSortableElements. self deny: self collectionWithSortableElements isEmpty! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:19'! elementInForIncludesTest ^ self element ! ! !BagTest methodsFor: 'tests - printing' stamp: ''! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !BagTest methodsFor: 'tests - remove' stamp: ''! testRemoveAllError "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self elementNotIn. aSubCollection := self nonEmptyWithoutEqualElements copyWith: el. self should: [ | res | res := self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! ! !BalloonBezierSimulation commentStamp: ''! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! end: aPoint end := aPoint! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'MarcusDenker 9/10/2013 12:07'! floatStepToNextScanLineAt: yValue in: edgeTableEntry "Float version of forward differencing" [yValue asFloat > lastY] whileTrue:[ self assert: [fwDx < -50.0 or:[fwDx > 50.0]]. self assert: [fwDy < -50.0 or:[fwDy > 50.0]]. self assert: [fwDDx < -50.0 or:[fwDDx > 50.0]]. self assert: [fwDDy < -50.0 or:[fwDDy > 50.0]]. lastY := lastY + fwDy. fwDx := fwDx + fwDDx. fwDy := fwDy + fwDDy. ]. edgeTableEntry xValue: lastX asInteger. edgeTableEntry zValue: 0.! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! initialY ^start y <= end y ifTrue:[start y] ifFalse:[end y]! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! initialX ^start y <= end y ifTrue:[start x] ifFalse:[end x]! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 22:13'! quickPrint: curve first: aBool aBool ifTrue:[Transcript cr]. Transcript nextPut:$(; print: curve start; space; print: curve via; space; print: curve end; nextPut:$). Transcript endEntry.! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 01:34'! floatStepToFirstScanLineAt: yValue in: edgeTableEntry "Float version of forward differencing" | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 steps scaledStepSize squaredStepSize | (end y) >= (start y) ifTrue:[ startX := start x. endX := end x. startY := start y. endY := end y. ] ifFalse:[ startX := end x. endX := start x. startY := end y. endY := start y. ]. deltaY := endY - startY. "Quickly check if the line is visible at all" (yValue >= endY or:[deltaY = 0]) ifTrue:[ ^edgeTableEntry lines: 0]. fwX1 := (startX + endX - (2 * via x)) asFloat. fwX2 := (via x - startX * 2) asFloat. fwY1 := (startY + endY - (2 * via y)) asFloat. fwY2 := ((via y - startY) * 2) asFloat. steps := deltaY asInteger * 2. scaledStepSize := 1.0 / steps asFloat. squaredStepSize := scaledStepSize * scaledStepSize. fwDx := fwX2 * scaledStepSize. fwDDx := 2.0 * fwX1 * squaredStepSize. fwDy := fwY2 * scaledStepSize. fwDDy := 2.0 * fwY1 * squaredStepSize. fwDx := fwDx + (fwDDx * 0.5). fwDy := fwDy + (fwDDy * 0.5). lastX := startX asFloat. lastY := startY asFloat. "self xDirection: xDir. self yDirection: yDir." edgeTableEntry xValue: startX. edgeTableEntry yValue: startY. edgeTableEntry zValue: 0. edgeTableEntry lines: deltaY. "If not at first scan line then step down to yValue" yValue = startY ifFalse:[ self stepToNextScanLineAt: yValue in: edgeTableEntry. "And adjust remainingLines" edgeTableEntry lines: deltaY - (yValue - startY). ].! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'pmm 3/13/2010 11:20'! computeSplitAt: t "Split the receiver at the parametric value t" | left right newVia1 newVia2 newPoint | left := self shallowCopy. right := self shallowCopy. "Compute new intermediate points" newVia1 := (via - start) * t + start. newVia2 := (end - via) * t + via. "Compute new point on curve" newPoint := ((newVia1 - newVia2) * t + newVia2) asIntegerPoint. left via: newVia1 asIntegerPoint. left end: newPoint. right start: newPoint. right via: newVia2 asIntegerPoint. ^Array with: left with: right! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 11/1/1998 00:31'! subdivide "Subdivide the receiver" | dy dx | "Test 1: If the bezier curve is not monoton in Y, we need a subdivision" self isMonoton ifFalse:[ MonotonSubdivisions := MonotonSubdivisions + 1. ^self subdivideToBeMonoton]. "Test 2: If the receiver is horizontal, don't do anything" (end y = start y) ifTrue:[^nil]. "Test 3: If the receiver can be represented as a straight line, make a line from the receiver and declare it invalid" ((end - start) crossProduct: (via - start)) = 0 ifTrue:[ LineConversions := LineConversions + 1. ^self subdivideToBeLine]. "Test 4: If the height of the curve exceeds 256 pixels, subdivide (forward differencing is numerically not very stable)" dy := end y - start y. dy < 0 ifTrue:[dy := dy negated]. (dy > 255) ifTrue:[ HeightSubdivisions := HeightSubdivisions + 1. ^self subdivideAt: 0.5]. "Test 5: Check if the incremental values could possibly overflow the scaled integer range" dx := end x - start x. dx < 0 ifTrue:[dx := dx negated]. dy * 32 < dx ifTrue:[ OverflowSubdivisions := OverflowSubdivisions + 1. ^self subdivideAt: 0.5]. ^nil! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/31/1998 16:36'! stepToFirstScanLineAt: yValue in: edgeTableEntry "Compute the initial x value for the scan line at yValue" ^self intStepToFirstScanLineAt: yValue in: edgeTableEntry! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:53'! stepToFirst | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 steps scaledStepSize squaredStepSize | (end y) >= (start y) ifTrue:[ startX := start x. endX := end x. startY := start y. endY := end y. ] ifFalse:[ startX := end x. endX := start x. startY := end y. endY := start y. ]. deltaY := endY - startY. "Quickly check if the line is visible at all" (deltaY = 0) ifTrue:[^self]. fwX1 := (startX + endX - (2 * via x)) asFloat. fwX2 := (via x - startX * 2) asFloat. fwY1 := (startY + endY - (2 * via y)) asFloat. fwY2 := ((via y - startY) * 2) asFloat. steps := deltaY asInteger * 2. scaledStepSize := 1.0 / steps asFloat. squaredStepSize := scaledStepSize * scaledStepSize. fwDx := fwX2 * scaledStepSize. fwDDx := 2.0 * fwX1 * squaredStepSize. fwDy := fwY2 * scaledStepSize. fwDDy := 2.0 * fwY1 * squaredStepSize. fwDx := fwDx + (fwDDx * 0.5). fwDy := fwDy + (fwDDy * 0.5). lastX := startX asFloat. lastY := startY asFloat. ! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 01:57'! inTangent "Return the tangent at the start point" ^via - start! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! via ^via! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! start ^start! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'! debugDraw2 | canvas last max t next | canvas := Display getCanvas. max := 100. last := nil. 0 to: max do:[:i| t := i asFloat / max asFloat. next := self valueAt: t. last ifNotNil:[ canvas line: last to: next rounded width: 2 color: Color blue. ]. last := next rounded. ].! ! !BalloonBezierSimulation methodsFor: 'printing' stamp: 'ar 10/30/1998 00:35'! printOn: aStream aStream nextPutAll: self class name; nextPut:$(; print: start; nextPutAll:' - '; print: via; nextPutAll:' - '; print: end; nextPut:$)! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! start: aPoint start := aPoint! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 21:56'! quickPrint: curve Transcript nextPut:$(; print: curve start; space; print: curve via; space; print: curve end; nextPut:$).! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'GuillermoPolito 5/24/2010 14:34'! stepToFirstInt "Scaled integer version of forward differencing" | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 scaledStepSize squaredStepSize | (end y) >= (start y) ifTrue:[ startX := start x. endX := end x. startY := start y. endY := end y. ] ifFalse:[ startX := end x. endX := start x. startY := end y. endY := start y. ]. deltaY := endY - startY. "Quickly check if the line is visible at all" (deltaY = 0) ifTrue:[^nil]. fwX1 := (startX + endX - (2 * via x)). fwX2 := (via x - startX * 2). fwY1 := (startY + endY - (2 * via y)). fwY2 := ((via y - startY) * 2). maxSteps := deltaY asInteger * 2. scaledStepSize := 16r1000000 // maxSteps. "@@: Okay, we need some fancy 64bit multiplication here" squaredStepSize := (scaledStepSize * scaledStepSize) bitShift: -24. fwDx := fwX2 * scaledStepSize. fwDDx := 2 * fwX1 * squaredStepSize. fwDy := fwY2 * scaledStepSize. fwDDy := 2 * fwY1 * squaredStepSize. fwDx := fwDx + (fwDDx // 2). fwDy := fwDy + (fwDDy // 2). self validateIntegerRange. lastX := startX * 256. lastY := startY * 256. ! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! initialZ ^0 "Assume no depth given"! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 00:26'! stepToNext lastX := lastX + fwDx. lastY := lastY + fwDy. fwDx := fwDx + fwDDx. fwDy := fwDy + fwDDy.! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'! debugDrawWide: n | entry minY maxY canvas curve p1 p2 entry2 y | curve := self class new. curve start: start + (0@n). curve via: via + (0@n). curve end: end + (0@n). entry := BalloonEdgeData new. entry2 := BalloonEdgeData new. canvas := Display getCanvas. minY := (start y min: end y) min: via y. maxY := (start y max: end y) max: via y. entry yValue: minY. entry2 yValue: minY + n. self stepToFirstScanLineAt: minY in: entry. curve stepToFirstScanLineAt: minY+n in: entry2. y := minY. 1 to: n do:[:i| y := y + 1. self stepToNextScanLineAt: y in: entry. p1 := entry xValue @ y. canvas line: p1 to: p1 + (n@0) width: 1 color: Color black. ]. [y < maxY] whileTrue:[ y := y + 1. self stepToNextScanLineAt: y in: entry. p2 := (entry xValue + n) @ y. curve stepToNextScanLineAt: y in: entry2. p1 := entry2 xValue @ y. canvas line: p1 to: p2 width: 1 color: Color black. ]. ! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 03:40'! stepToNextScanLineAt: yValue in: edgeTableEntry "Compute the next x value for the scan line at yValue. This message is sent during incremental updates. The yValue parameter is passed in here for edges that have more complicated computations," ^self intStepToNextScanLineAt: yValue in: edgeTableEntry! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 01:57'! outTangent "Return the tangent at the end point" ^end - via! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:46'! computeInitialStateFrom: source with: transformation "Compute the initial state in the receiver." start := (transformation localPointToGlobal: source start) asIntegerPoint. end := (transformation localPointToGlobal: source end) asIntegerPoint. via := (transformation localPointToGlobal: source via) asIntegerPoint.! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 16:37'! absoluteSquared8Dot24: value "Compute the squared value of a 8.24 number with 0.0 <= value < 1.0, e.g., compute (value * value) bitShift: -24" | halfWord1 halfWord2 result | (value >= 0 and:[value < 16r1000000]) ifFalse:[^self error:'Value out of range']. halfWord1 := value bitAnd: 16rFFFF. halfWord2 := (value bitShift: -16) bitAnd: 255. result := (halfWord1 * halfWord1) bitShift: -16. "We don't need the lower 16bits at all" result := result + ((halfWord1 * halfWord2) * 2). result := result + ((halfWord2 * halfWord2) bitShift: 16). "word1 := halfWord1 * halfWord1. word2 := (halfWord2 * halfWord1) + (word1 bitShift: -16). word1 := word1 bitAnd: 16rFFFF. word2 := word2 + (halfWord1 * halfWord2). word2 := word2 + ((halfWord2 * halfWord2) bitShift: 16)." ^result bitShift: -8! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'MarcusDenker 9/10/2013 12:09'! validateIntegerRange self assert: [fwDx class == SmallInteger]. self assert: [fwDy class == SmallInteger]. self assert: [fwDDx class == SmallInteger]. self assert: [fwDDy class == SmallInteger]. ! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! end ^end! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'! debugDraw | entry minY maxY lX lY canvas | entry := BalloonEdgeData new. canvas := Display getCanvas. minY := (start y min: end y) min: via y. maxY := (start y max: end y) max: via y. entry yValue: minY. self stepToFirstScanLineAt: minY in: entry. lX := entry xValue. lY := entry yValue. minY+1 to: maxY do:[:y| self stepToNextScanLineAt: y in: entry. canvas line: lX@lY to: entry xValue @ y width: 2 color: Color black. lX := entry xValue. lY := y. ]. ! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 16:23'! intStepToFirstScanLineAt: yValue in: edgeTableEntry "Scaled integer version of forward differencing" | startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 scaledStepSize squaredStepSize | (end y) >= (start y) ifTrue:[ startX := start x. endX := end x. startY := start y. endY := end y. ] ifFalse:[ startX := end x. endX := start x. startY := end y. endY := start y. ]. deltaY := endY - startY. "Quickly check if the line is visible at all" (yValue >= endY or:[deltaY = 0]) ifTrue:[ ^edgeTableEntry lines: 0]. fwX1 := (startX + endX - (2 * via x)). fwX2 := (via x - startX * 2). fwY1 := (startY + endY - (2 * via y)). fwY2 := ((via y - startY) * 2). maxSteps := deltaY asInteger * 2. scaledStepSize := 16r1000000 // maxSteps. "@@: Okay, we need some fancy 64bit multiplication here" squaredStepSize := self absoluteSquared8Dot24: scaledStepSize. squaredStepSize = ((scaledStepSize * scaledStepSize) bitShift: -24) ifFalse:[self error:'Bad computation']. fwDx := fwX2 * scaledStepSize. fwDDx := 2 * fwX1 * squaredStepSize. fwDy := fwY2 * scaledStepSize. fwDDy := 2 * fwY1 * squaredStepSize. fwDx := fwDx + (fwDDx // 2). fwDy := fwDy + (fwDDy // 2). self validateIntegerRange. lastX := startX * 256. lastY := startY * 256. edgeTableEntry xValue: startX. edgeTableEntry yValue: startY. edgeTableEntry zValue: 0. edgeTableEntry lines: deltaY. "If not at first scan line then step down to yValue" yValue = startY ifFalse:[ self stepToNextScanLineAt: yValue in: edgeTableEntry. "And adjust remainingLines" edgeTableEntry lines: deltaY - (yValue - startY). ].! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'MarcusDenker 9/10/2013 12:07'! subdivideAt: parameter "Subdivide the receiver at the given parameter" | both | self assert: [parameter <= 0.0 or:[parameter >= 1.0]]. both := self computeSplitAt: parameter. "Transcript cr. self quickPrint: self. Transcript space. self quickPrint: both first. Transcript space. self quickPrint: both last. Transcript endEntry." self via: both first via. self end: both first end. ^both last! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'MarcusDenker 9/10/2013 12:08'! subdivideToBeMonoton "Subdivide the receiver at it's extreme point" | v1 v2 t other | v1 := (via - start). v2 := (end - via). t := (v1 y / (v2 y - v1 y)) negated asFloat. other := self subdivideAt: t. self assert: [self isMonoton]. self assert: [other isMonoton]. ^other! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! via: aPoint via := aPoint! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 04:02'! intStepToNextScanLineAt: yValue in: edgeTableEntry "Scaled integer version of forward differencing" [maxSteps >= 0 and:[yValue * 256 > lastY]] whileTrue:[ self validateIntegerRange. lastX := lastX + ((fwDx + 16r8000) // 16r10000). lastY := lastY + ((fwDy + 16r8000) // 16r10000). fwDx := fwDx + fwDDx. fwDy := fwDy + fwDDy. maxSteps := maxSteps - 1. ]. edgeTableEntry xValue: lastX // 256. edgeTableEntry zValue: 0.! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/29/1998 22:14'! isMonoton "Return true if the receiver is monoton along the y-axis, e.g., check if the tangents have the same sign" ^(via y - start y) * (end y - via y) >= 0! ! !BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 11/11/1998 22:15'! subdivideToBeLine "Not a true subdivision. Just return a line representing the receiver and fake me to be of zero height" | line | line := BalloonLineSimulation new. line start: start. line end: end. "Make me invalid" end := start. via := start. ^line! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/29/1998 21:26'! valueAt: parameter "Return the point at the value parameter: p(t) = (1-t)^2 * p1 + 2*t*(1-t) * p2 + t^2 * p3. " | t1 t2 t3 | t1 := (1.0 - parameter) squared. t2 := 2 * parameter * (1.0 - parameter). t3 := parameter squared. ^(start * t1) + (via * t2) + (end * t3)! ! !BalloonBezierSimulation class methodsFor: 'initialization' stamp: 'MarcusDenker 9/30/2009 11:56'! initialize HeightSubdivisions := 0. LineConversions := 0. MonotonSubdivisions := 0. OverflowSubdivisions := 0.! ! !BalloonBuffer commentStamp: ''! BalloonBuffer is a repository for primitive data used by the BalloonEngine.! !BalloonBuffer methodsFor: 'accessing' stamp: 'ar 10/26/1998 21:12'! at: index put: anInteger "For simulation only" | word | anInteger < 0 ifTrue:["word := 16r100000000 + anInteger" word := (anInteger + 1) negated bitInvert32] ifFalse:[word := anInteger]. self basicAt: index put: word. ^anInteger! ! !BalloonBuffer methodsFor: 'accessing' stamp: 'ar 10/26/1998 21:12'! at: index "For simulation only" | word | word := self basicAt: index. word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" ^word >= 16r80000000 "Negative?!!" ifTrue:["word - 16r100000000" (word bitInvert32 + 1) negated] ifFalse:[word]! ! !BalloonBuffer methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! floatAt: index "For simulation only" ^Float fromIEEE32Bit: (self basicAt: index)! ! !BalloonBuffer methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! floatAt: index put: value "For simulation only" value isFloat ifTrue:[self basicAt: index put: value asIEEE32BitWord] ifFalse:[self at: index put: value asFloat]. ^value! ! !BalloonBuffer class methodsFor: 'instance creation' stamp: 'ar 10/26/1998 21:11'! new ^self new: 256.! ! !BalloonCanvas commentStamp: ''! BalloonCanvas is a canvas using the BalloonEngine for drawing wherever possible. It has various methods which other canvases do not support due to the extra features of the balloon engine.! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'DSM 10/15/1999 15:14'! drawBezier3Shape: vertices color: c borderWidth: borderWidth borderColor: borderColor self drawBezierShape: (Bezier3Segment convertBezier3ToBezier2: vertices) color: c borderWidth: borderWidth borderColor: borderColor! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'IgorStasenko 7/18/2011 18:07'! drawRectangle: r color: c borderWidth: borderWidth borderColor: borderColor "Draw a rectangle" self ensuredEngine drawRectangle: r fill: c borderWidth: borderWidth borderColor: borderColor transform: transform.! ! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:54'! deferred ^deferred! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:40'! fillRectangle: r color: c "Fill the rectangle with the given color" ^self frameAndFillRectangle: r fillColor: c borderWidth: 0 borderColor: nil! ! !BalloonCanvas methodsFor: 'todo' stamp: 'tween 3/10/2009 07:49'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc (self ifNoTransformWithIn: boundsRect) ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc]! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'StephaneDucasse 8/15/2013 18:27'! line: pt1 to: pt2 width: w color: c "Draw a line from pt1 to: pt2" (aaLevel = 1 and: [self ifNoTransformWithIn:(pt1 rectangle: pt2)]) ifTrue:[^super line: pt1 to: pt2 width: w color: c]. ^self drawPolygon: (Array with: pt1 with: pt2) color: c borderWidth: w borderColor: c! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'StephaneDucasse 2/9/2011 14:34'! fillRectangle: aRectangle basicFillStyle: aFillStyle "Fill the given rectangle with the given, non-composite, fill style." ^self drawRectangle: aRectangle color: aFillStyle borderWidth: 0 borderColor: nil ! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:51'! fillOval: r color: c borderWidth: borderWidth borderColor: borderColor "Draw a filled and outlined oval" "Note: The optimization test below should actually read: self ifNoTransformWithIn: (r insetBy: borderWidth // 2) but since borderWidth is assumed to be very small related to r we don't check it." (self ifNoTransformWithIn: r) ifTrue:[^super fillOval: r color: c borderWidth: borderWidth borderColor: borderColor]. ^self drawOval: (r insetBy: borderWidth // 2) color: c borderWidth: borderWidth borderColor: borderColor! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 11/24/1998 15:16'! drawCompressedShape: compressedShape "Draw a compressed shape" self ensuredEngine drawCompressedShape: compressedShape transform: transform.! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'IgorStasenko 7/18/2011 18:07'! drawOval: r color: c borderWidth: borderWidth borderColor: borderColor "Draw the oval defined by the given rectangle" self ensuredEngine drawOval: r fill: c borderWidth: borderWidth borderColor: borderColor transform: transform.! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'IgorStasenko 7/18/2011 18:06'! drawGeneralPolygon: contours color: c borderWidth: borderWidth borderColor: borderColor "Draw a general polygon (e.g., a polygon that can contain holes)" self ensuredEngine drawGeneralPolygon: contours fill: c borderWidth: borderWidth borderColor: borderColor transform: transform.! ! !BalloonCanvas methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:42'! initialize super initialize. aaLevel := 1. deferred := false.! ! !BalloonCanvas methodsFor: 'private' stamp: 'MarcusDenker 10/28/2010 14:02'! image: aForm at: aPoint sourceRect: sourceRect rule: rule | warp dstRect srcQuad dstOffset | (self ifNoTransformWithIn: sourceRect) & false ifTrue:[^super image: aForm at: aPoint sourceRect: sourceRect rule: rule]. dstRect := (transform localBoundsToGlobal: (aForm boundingBox translateBy: aPoint)). dstOffset := 0@0. "dstRect origin." "dstRect := 0@0 corner: dstRect extent." srcQuad := transform globalPointsToLocal: (dstRect innerCorners). srcQuad := srcQuad collect:[:pt| pt - aPoint]. warp := (WarpBlt current toForm: form) sourceForm: aForm; cellSize: 2; "installs a new colormap if cellSize > 1" combinationRule: Form over. warp copyQuad: srcQuad toRect: (dstRect translateBy: dstOffset). self frameRectangle: (aForm boundingBox translateBy: aPoint) color: Color green. "... TODO ... create a bitmap fill style from the form and use it for a simple rectangle."! ! !BalloonCanvas methodsFor: 'todo' stamp: 'ar 12/31/2001 02:27'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c (self ifNoTransformWithIn: boundsRect) ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! ! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:53'! aaLevel: newLevel "Only allow changes to aaLevel if we're working on >= 8 bit forms" form depth >= 8 ifFalse:[^self]. aaLevel = newLevel ifTrue:[^self]. self flush. "In case there are pending primitives in the engine" aaLevel := newLevel. engine ifNotNil:[engine aaLevel: aaLevel].! ! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 11/13/1998 01:02'! aaLevel ^aaLevel! ! !BalloonCanvas methodsFor: 'transforming' stamp: 'ar 11/24/1998 14:45'! colorTransformBy: aColorTransform aColorTransform ifNil:[^self]. colorTransform ifNil:[colorTransform := aColorTransform] ifNotNil:[colorTransform := colorTransform composedWithLocal: aColorTransform]! ! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:55'! deferred: aBoolean deferred == aBoolean ifTrue:[^self]. self flush. "Force pending prims on screen" deferred := aBoolean. engine ifNotNil:[engine deferred: aBoolean].! ! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 2/13/2001 21:07'! ensuredEngine engine ifNil:[ engine := BalloonEngine new. "engine := BalloonDebugEngine new" engine aaLevel: aaLevel. engine bitBlt: port. engine destOffset: origin. engine clipRect: clipRect. engine deferred: deferred. engine]. engine colorTransform: colorTransform. engine edgeTransform: transform. ^engine! ! !BalloonCanvas methodsFor: 'transforming' stamp: 'ar 12/30/1998 10:47'! preserveStateDuring: aBlock | state result | state := BalloonState new. state transform: transform. state colorTransform: colorTransform. state aaLevel: self aaLevel. result := aBlock value: self. transform := state transform. colorTransform := state colorTransform. self aaLevel: state aaLevel. ^result! ! !BalloonCanvas methodsFor: 'testing' stamp: 'ar 11/13/1998 13:19'! isBalloonCanvas ^true! ! !BalloonCanvas methodsFor: 'private' stamp: 'marcus.denker 9/14/2008 21:01'! ifNoTransformWithIn: box "Return true if the current transformation does not affect the given bounding box" | delta | transform ifNil: [^true]. delta := (transform localPointToGlobal: box origin) - box origin. ^(transform localPointToGlobal: box corner) - box corner = delta! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'DSM 10/15/1999 15:18'! drawGeneralBezier3Shape: contours color: c borderWidth: borderWidth borderColor: borderColor | b2 | b2 := contours collect: [:b3 | Bezier3Segment convertBezier3ToBezier2: b3 ]. self drawGeneralBezierShape: b2 color: c borderWidth: borderWidth borderColor: borderColor! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:40'! fillColor: c "Note: This always fills, even if the color is transparent." "Note2: To achieve the above we must make sure that c is NOT transparent" self frameAndFillRectangle: form boundingBox fillColor: (c alpha: 1.0) borderWidth: 0 borderColor: nil! ! !BalloonCanvas methodsFor: 'transforming' stamp: 'ar 11/12/1998 00:32'! transformBy: aTransform aTransform ifNil:[^self]. transform ifNil:[transform := aTransform] ifNotNil:[transform := transform composedWithLocal: aTransform]! ! !BalloonCanvas methodsFor: 'transforming' stamp: 'ar 5/29/1999 08:59'! transformBy: aDisplayTransform during: aBlock | myTransform result | myTransform := transform. self transformBy: aDisplayTransform. result := aBlock value: self. transform := myTransform. ^result! ! !BalloonCanvas methodsFor: 'testing' stamp: 'ar 11/12/1998 01:07'! isVisible: aRectangle ^transform ifNil:[super isVisible: aRectangle] ifNotNil:[super isVisible: (transform localBoundsToGlobal: aRectangle)]! ! !BalloonCanvas methodsFor: 'drawing-ovals' stamp: 'StephaneDucasse 2/9/2011 14:26'! fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc "Fill the given rectangle." ^self drawOval: (aRectangle insetBy: bw // 2) color: aFillStyle borderWidth: bw borderColor: bc ! ! !BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'ar 8/26/2001 22:14'! drawPolygon: vertices fillStyle: aFillStyle "Fill the given polygon." self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: nil! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:52'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor "Draw a beveled or raised rectangle" | bw | "Note: The optimization test below should actually read: self ifNoTransformWithIn: (r insetBy: borderWidth // 2) but since borderWidth is assumed to be very small related to r we don't check it." (self ifNoTransformWithIn: r) ifTrue:[^super frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor]. "Fill rectangle and draw top and left border" bw := borderWidth // 2. self drawRectangle: (r insetBy: bw) color: fillColor borderWidth: borderWidth borderColor: topLeftColor. "Now draw bottom right border." self drawPolygon: (Array with: r topRight + (bw negated@bw) with: r bottomRight - bw asPoint with: r bottomLeft + (bw@bw negated)) color: nil borderWidth: borderWidth borderColor: bottomRightColor.! ! !BalloonCanvas methodsFor: 'converting' stamp: 'ar 11/11/1998 22:57'! asBalloonCanvas ^self! ! !BalloonCanvas methodsFor: 'todo' stamp: 'ar 2/9/1999 05:46'! paragraph: para bounds: bounds color: c (self ifNoTransformWithIn: bounds) ifTrue:[^super paragraph: para bounds: bounds color: c].! ! !BalloonCanvas methodsFor: 'copying' stamp: 'nice 1/13/2010 21:22'! postCopy self flush. super postCopy. self resetEngine! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 06:26'! frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor "Draw a filled and outlined rectangle" "Note: The optimization test below should actually read: self ifNoTransformWithIn: (r insetBy: borderWidth // 2) but since borderWidth is assumed to be very small related to r we don't check it." (self ifNoTransformWithIn: r) ifTrue:[^super frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor]. ^self drawRectangle: (r insetBy: borderWidth // 2) color: c borderWidth: borderWidth borderColor: borderColor! ! !BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/24/1998 15:28'! flush "Force all pending primitives onscreen" engine ifNotNil:[engine flush].! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'IgorStasenko 7/18/2011 18:06'! drawGeneralBezierShape: contours color: c borderWidth: borderWidth borderColor: borderColor "Draw a general boundary shape (e.g., possibly containing holes)" self ensuredEngine drawGeneralBezierShape: contours fill: c borderWidth: borderWidth borderColor: borderColor transform: transform.! ! !BalloonCanvas methodsFor: 'balloon drawing' stamp: 'IgorStasenko 7/18/2011 18:06'! drawBezierShape: vertices color: c borderWidth: borderWidth borderColor: borderColor "Draw a boundary shape that is defined by a list of vertices. Each three subsequent vertices define a quadratic bezier segment. For lines, the control point should be set to either the start or the end of the bezier curve." self ensuredEngine drawBezierShape: vertices fill: c borderWidth: borderWidth borderColor: borderColor transform: transform.! ! !BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/11/1998 20:25'! resetEngine engine := nil.! ! !BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'IgorStasenko 7/18/2011 18:07'! drawPolygon: vertices fillStyle: aFillStyle borderWidth: borderWidth borderColor: borderColor "Draw a simple polygon defined by the list of vertices." self ensuredEngine drawPolygon: (vertices copyWith: vertices first) fill: aFillStyle borderWidth: borderWidth borderColor: borderColor transform: transform.! ! !BalloonEdgeData commentStamp: ''! BalloonEdgeData defines an entry in the internal edge table of the Balloon engine. Instance Variables: index The index into the external objects array of the associated graphics engine xValue The computed x-value of the requested operation yValue The y-value for the requested operation height The (remaining) height of the edge source The object from the external objects array! !BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'! stepToNextScanLine source stepToNextScanLineAt: yValue in: self! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! yValue ^yValue! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! xValue ^xValue! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'! lines ^lines! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! xValue: anInteger xValue := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'! lines: anInteger ^lines := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'! zValue: anInteger zValue := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! yValue: anInteger yValue := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! source ^source! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! index: anInteger index := anInteger! ! !BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'! stepToFirstScanLine source stepToFirstScanLineAt: yValue in: self! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'! zValue ^zValue! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 21:39'! source: anObject source := anObject! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! index ^index! ! !BalloonEngine commentStamp: ''! BalloonEngine is the representative for the Balloon engine inside Squeak. For most purposes it should not be used directly but via BalloonCanvas since this ensures proper initialization and is polymorphic with other canvas uses.! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'! primDisplaySpanBuffer "Display the current scan line if necessary" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 3/6/2001 12:06'! copyBits (bitBlt notNil and:[bitBlt destForm notNil]) ifTrue:[bitBlt destForm unhibernate]. self copyLoopFaster.! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:32'! copyLoop "This is the basic rendering loop using as little primitive support as possible." | finished edge fill | edge := BalloonEdgeData new. fill := BalloonFillData new. self primInitializeProcessing. "Initialize the GE for processing" [self primFinishedProcessing] whileFalse:[ "Step 1: Process the edges in the global edge table that will be added in this step" [finished := self primNextGlobalEdgeEntryInto: edge. finished] whileFalse:[ edge source: (externals at: edge index). edge stepToFirstScanLine. self primAddActiveEdgeTableEntryFrom: edge]. "Step 2: Scan the active edge table" [finished := self primNextFillEntryInto: fill. finished] whileFalse:[ fill source: (externals at: fill index). "Compute the new fill" fill computeFill. "And mix it in the out buffer" self primMergeFill: fill destForm bits from: fill]. "Step 3: Display the current span buffer if necessary" self primDisplaySpanBuffer. "Step 4: Advance and resort the active edge table" [finished := self primNextActiveEdgeEntryInto: edge. finished] whileFalse:[ "If the index is zero then the edge has been handled by the GE" edge source: (externals at: edge index). edge stepToNextScanLine. self primChangeActiveEdgeTableEntryFrom: edge]. ]. self primGetTimes: Times. self primGetCounts: Counts. self primGetBezierStats: BezierStats.! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetAALevel "Set the AA level" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! drawRectangle: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix | fills | self edgeTransform: aMatrix. self resetIfNeeded. fills := self registerFill: fillStyle and: borderColor. self primAddRectFrom: rect origin to: rect corner fillIndex: (fills at: 1) borderWidth: borderWidth borderColor: (fills at: 2). self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primSetClipRect: rect ^self primitiveFailed! ! !BalloonEngine methodsFor: 'drawing' stamp: 'bf 4/3/2004 01:36'! registerFill: aFillStyle "Register the given fill style." | theForm | aFillStyle ifNil:[^0]. aFillStyle isSolidFill ifTrue:[^aFillStyle scaledPixelValue32]. aFillStyle isGradientFill ifTrue:[ ^self primAddGradientFill: aFillStyle pixelRamp from: aFillStyle origin along: aFillStyle direction normal: aFillStyle normal radial: aFillStyle isRadialFill ]. aFillStyle isBitmapFill ifTrue:[ theForm := aFillStyle form asSourceForm. theForm unhibernate. forms := forms copyWith: theForm. ^self primAddBitmapFill: theForm colormap: (theForm colormapIfNeededForDepth: 32) tile: aFillStyle isTiled from: aFillStyle origin along: aFillStyle direction normal: aFillStyle normal xIndex: forms size]. ^0! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetTimes: statsArray ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetBezierStats: statsArray ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primSetEdgeTransform: transform ^self primitiveFailed! ! !BalloonEngine methodsFor: 'initialization' stamp: 'stephane.ducasse 6/14/2009 22:37'! initialize | w | super initialize. w := Display width > 2048 ifTrue: [ 4096 ] ifFalse: [ 2048 ]. externals := OrderedCollection new: 100. span := Bitmap new: w. bitBlt := nil. self bitBlt: ((BitBlt toForm: Display) destRect: Display boundingBox; yourself). forms := #(). deferred := false.! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primInitializeProcessing "Initialize processing in the GE. Create the active edge table and sort it." ^self primitiveFailed! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:03'! bitBlt: aBitBlt bitBlt := aBitBlt. bitBlt ifNil: [^self]. self class primitiveSetBitBltPlugin: bitBlt getPluginName. self clipRect: bitBlt clipRect. bitBlt sourceForm: (Form extent: span size @ 1 depth: 32 bits: span); sourceRect: (0@0 extent: 1@span size); colorMap: (Color colorMapIfNeededFrom: 32 to: bitBlt destForm depth); combinationRule: (bitBlt destForm depth >= 8 ifTrue:[34] ifFalse:[Form paint]).! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/11/1998 23:04'! aaLevel ^aaLevel ifNil:[1]! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetCounts: statsArray ^self primitiveFailed! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/1/1998 02:57'! clipRect ^clipRect! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'! colorTransform ^colorTransform! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:43'! preFlushIfNeeded "Force all pending primitives onscreen" workBuffer ifNil:[^self]. self primFlushNeeded ifTrue:[ self copyBits. self reset].! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primNextActiveEdgeEntryInto: edgeEntry "Store the next entry of the AET at the current y-value in edgeEntry. Return false if there is no entry, true otherwise." ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddGradientFill: colorRamp from: origin along: direction normal: normal radial: isRadial (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddGradientFill: colorRamp from: origin along: direction normal: normal radial: isRadial ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddExternalFill: index (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddExternalFill: index ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primFlushNeeded: aBoolean ^self primitiveFailed! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/11/1998 22:52'! release self class recycleBuffer: workBuffer. workBuffer := nil.! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'! edgeTransform: aTransform edgeTransform := aTransform.! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primFlushNeeded ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primSetDepth: depth ^self primitiveFailed! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:42'! postFlushIfNeeded "Force all pending primitives onscreen" workBuffer ifNil:[^self]. (deferred not or:[postFlushNeeded]) ifTrue:[ self copyBits. self release].! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primNextFillEntryInto: fillEntry "Store the next fill entry of the active edge table in fillEntry. Return false if there is no such entry, true otherwise" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:34'! reset workBuffer ifNil:[workBuffer := self class allocateOrRecycleBuffer: 10000]. self primInitializeBuffer: workBuffer. self primSetAALevel: self aaLevel. self primSetOffset: destOffset. self primSetClipRect: clipRect. self primSetEdgeTransform: edgeTransform. self primSetColorTransform: colorTransform. forms := #().! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 11/25/1998 00:45'! canProceedAfter: failureReason "Check if we can proceed after the failureReason indicated." | newBuffer | failureReason = GErrorNeedFlush ifTrue:[ "Need to flush engine before proceeding" self copyBits. self reset. ^true]. failureReason = GErrorNoMoreSpace ifTrue:[ "Work buffer is too small" newBuffer := workBuffer species new: workBuffer size * 2. self primCopyBufferFrom: workBuffer to: newBuffer. workBuffer := newBuffer. ^true]. "Not handled" ^false! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:32'! copyLoopFaster "This is a copy loop drawing one scan line at a time" | edge fill reason | edge := BalloonEdgeData new. fill := BalloonFillData new. [self primFinishedProcessing] whileFalse:[ reason := self primRenderScanline: edge with: fill. "reason ~= 0 means there has been a problem" reason = 0 ifFalse:[ self processStopReason: reason edge: edge fill: fill. ]. ]. self primGetTimes: Times. self primGetCounts: Counts. self primGetBezierStats: BezierStats.! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/12/1998 00:22'! destOffset: aPoint destOffset := aPoint asIntegerPoint. bitBlt destX: aPoint x; destY: aPoint y.! ! !BalloonEngine methodsFor: 'primitives-misc' stamp: 'ar 2/2/2001 15:49'! primInitializeBuffer: buffer ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:39'! resetIfNeeded workBuffer ifNil:[self reset]. self primSetEdgeTransform: edgeTransform. self primSetColorTransform: colorTransform. self primSetDepth: self primGetDepth + 1. postFlushNeeded := false.! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetOffset ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primSetColorTransform: transform ^self primitiveFailed! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:44'! drawCompressedShape: shape transform: aTransform | fillIndexList | self edgeTransform: aTransform. self resetIfNeeded. fillIndexList := self registerFills: shape fillStyles. self primAddCompressedShape: shape points segments: shape numSegments leftFills: shape leftFills rightFills: shape rightFills lineWidths: shape lineWidths lineFills: shape lineFills fillIndexList: fillIndexList. self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'drawing' stamp: 'di 11/21/1999 20:15'! registerFills: fills | fillIndexList index fillIndex | ((colorTransform notNil and:[colorTransform isAlphaTransform]) or:[ fills anySatisfy: [:any| any notNil and:[any isTranslucent]]]) ifTrue:[ self flush. self reset. postFlushNeeded := true]. fillIndexList := WordArray new: fills size. index := 1. [index <= fills size] whileTrue:[ fillIndex := self registerFill: (fills at: index). fillIndex == nil ifTrue:[index := 1] "Need to start over" ifFalse:[fillIndexList at: index put: fillIndex. index := index+1] ]. ^fillIndexList! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:48'! primClipRectInto: rect ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primFinishedProcessing "Return true if there are no more entries in AET and GET and the last scan line has been displayed" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/13/1998 02:44'! clipRect: aRect clipRect := aRect truncated! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetFailureReason ^0! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'! primChangeActiveEdgeTableEntryFrom: edgeEntry "Change the entry in the active edge table from edgeEntry" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primRenderImage: edge with: fill "Start/Proceed rendering the current scan line" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primGetDepth ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'! deferred ^deferred! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32 ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/13/1998 03:04'! bitBlt ^bitBlt! ! !BalloonEngine methodsFor: 'primitives-misc' stamp: 'ar 2/2/2001 15:48'! primCopyBufferFrom: oldBuffer to: newBuffer "Copy the contents of oldBuffer into the (larger) newBuffer" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:33'! copyLoopFastest "This is a copy loop drawing the entire image" | edge fill reason | edge := BalloonEdgeData new. fill := BalloonFillData new. [self primFinishedProcessing] whileFalse:[ reason := self primRenderImage: edge with: fill. "reason ~= 0 means there has been a problem" reason = 0 ifFalse:[ self processStopReason: reason edge: edge fill: fill. ]. ]. self primGetTimes: Times. self primGetCounts: Counts. self primGetBezierStats: BezierStats.! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! registerFill: fill1 and: fill2 ^self registerFills: (Array with: fill1 with: fill2)! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/11/1998 23:04'! aaLevel: anInteger aaLevel := (anInteger min: 4) max: 1.! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'! deferred: aBoolean deferred := aBoolean.! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primSetAALevel: level "Set the AA level" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primSetOffset: point ^self primitiveFailed! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! drawPolygon: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform | fills | self edgeTransform: aTransform. self resetIfNeeded. fills := self registerFill: fillStyle and: borderFill. self primAddPolygon: points segments: points size fill: (fills at: 1) lineWidth: borderWidth lineFill: (fills at: 2). self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primRenderScanline: edge with: fill "Start/Proceed rendering the current scan line" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 10/11/1999 16:49'! drawBezierShape: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform | fills | self edgeTransform: aTransform. self resetIfNeeded. fills := self registerFill: fillStyle and: borderFill. self primAddBezierShape: points segments: (points size) // 3 fill: (fills at: 1) lineWidth: borderWidth lineFill: (fills at: 2). self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'! drawOval: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix | fills | self edgeTransform: aMatrix. self resetIfNeeded. fills := self registerFill: fillStyle and: borderColor. self primAddOvalFrom: rect origin to: rect corner fillIndex: (fills at: 1) borderWidth: borderWidth borderColor: (fills at: 2). self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/1/1998 02:56'! destOffset ^destOffset! ! !BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'! primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primMergeFill: fillBitmap from: fill "Merge the filled bitmap into the current output buffer." ^self primitiveFailed! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'! colorTransform: aColorTransform colorTransform := aColorTransform! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/15/1999 03:02'! drawGeneralBezierShape: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform | fills | self edgeTransform: aTransform. self resetIfNeeded. fills := self registerFill: fillStyle and: borderFill. contours do:[:points| self primAddBezierShape: points segments: (points size // 3) fill: (fills at: 1) lineWidth: borderWidth lineFill: (fills at: 2). "Note: To avoid premature flushing of the pipeline we need to reset the flush bit within the engine." self primFlushNeeded: false. ]. "And set the flush bit afterwards" self primFlushNeeded: true. self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'! edgeTransform ^edgeTransform! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 11/11/1998 21:19'! processStopReason: reason edge: edge fill: fill "The engine has stopped because of some reason. Try to figure out how to respond and do the necessary actions." "Note: The order of operations below can affect the speed" "Process unknown fills first" reason = GErrorFillEntry ifTrue:[ fill source: (externals at: fill index). "Compute the new fill" fill computeFill. "And mix it in the out buffer" ^self primMergeFill: fill destForm bits from: fill]. "Process unknown steppings in the AET second" reason = GErrorAETEntry ifTrue:[ edge source: (externals at: edge index). edge stepToNextScanLine. ^self primChangeActiveEdgeTableEntryFrom: edge]. "Process unknown entries in the GET third" reason = GErrorGETEntry ifTrue:[ edge source: (externals at: edge index). edge stepToFirstScanLine. ^self primAddActiveEdgeTableEntryFrom: edge]. "Process generic problems last" (self canProceedAfter: reason) ifTrue:[^self]. "Okay." ^self error:'Unkown stop reason in graphics engine' ! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetClipRect: rect ^self primitiveFailed! ! !BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/15/1999 03:02'! drawGeneralPolygon: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform | fills | self edgeTransform: aTransform. self resetIfNeeded. fills := self registerFill: fillStyle and: borderFill. contours do:[:points| self primAddPolygon: points segments: points size fill: (fills at: 1) lineWidth: borderWidth lineFill: (fills at: 2). "Note: To avoid premature flushing of the pipeline we need to reset the flush bit within the engine." self primFlushNeeded: false. ]. "And set the flush bit afterwards" self primFlushNeeded: true. self postFlushIfNeeded.! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'! primAddActiveEdgeTableEntryFrom: edgeEntry "Add edge entry to the AET." (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddActiveEdgeTableEntryFrom: edgeEntry ]. ^self primitiveFailed! ! !BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:29'! flush "Force all pending primitives onscreen" workBuffer ifNil:[^self]. self copyBits. self release.! ! !BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'! primNextGlobalEdgeEntryInto: edgeEntry "Store the next entry of the GET at the current y-value in edgeEntry. Return false if there is no entry, true otherwise." ^self primitiveFailed! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/29/1998 01:51'! fullTransformFrom: aMatrix | m | m := self aaTransform composedWith: aMatrix. "m offset: m offset + destOffset." ^m! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/29/1998 01:51'! aaTransform "Return a transformation for the current anti-aliasing level" | matrix | matrix := MatrixTransform2x3 withScale: (self aaLevel) asFloat asPoint. matrix offset: (self aaLevel // 2) asFloat asPoint. ^matrix composedWith:(MatrixTransform2x3 withOffset: destOffset asFloatPoint)! ! !BalloonEngine class methodsFor: 'private' stamp: 'ar 11/11/1998 22:50'! allocateOrRecycleBuffer: initialSize "Try to recycly a buffer. If this is not possibly, create a new one." | buffer | CacheProtect critical:[ buffer := BufferCache at: 1. BufferCache at: 1 put: nil. ]. ^buffer ifNil:[BalloonBuffer new: initialSize]! ! !BalloonEngine class methodsFor: 'initialization' stamp: 'ar 11/11/1998 22:49'! initialize "BalloonEngine initialize" BufferCache := WeakArray new: 1. Smalltalk garbageCollect. "Make the cache old" CacheProtect := Semaphore forMutualExclusion. Times := WordArray new: 10. Counts := WordArray new: 10. BezierStats := WordArray new: 4. Debug ifNil:[Debug := false].! ! !BalloonEngine class methodsFor: 'private' stamp: 'eem 6/11/2008 13:00'! recycleBuffer: balloonBuffer "Try to keep the buffer for later drawing operations." CacheProtect critical:[ | buffer | buffer := BufferCache at: 1. (buffer isNil or:[buffer size < balloonBuffer size] ) ifTrue:[BufferCache at: 1 put: balloonBuffer]. ].! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/30/1998 23:57'! resetBezierStats BezierStats := WordArray new: 4.! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 1/12/1999 10:52'! printStats "BalloonEngine doProfileStats: true" "BalloonEngine printStats" "BalloonEngine resetStats" Transcript cr; nextPutAll:'/************** BalloonEngine statistics ****************/'. self printStat: (Times at: 1) count: (Counts at: 1) string: 'Initialization'. self printStat: (Times at: 2) count: (Counts at: 2) string: 'Finish test'. self printStat: (Times at: 3) count: (Counts at: 3) string: 'Fetching/Adding GET entries'. self printStat: (Times at: 4) count: (Counts at: 4) string: 'Adding AET entries'. self printStat: (Times at: 5) count: (Counts at: 5) string: 'Fetching/Computing fills'. self printStat: (Times at: 6) count: (Counts at: 6) string: 'Merging fills'. self printStat: (Times at: 7) count: (Counts at: 7) string: 'Displaying span buffer'. self printStat: (Times at: 8) count: (Counts at: 8) string: 'Fetching/Updating AET entries'. self printStat: (Times at: 9) count: (Counts at: 9) string: 'Changing AET entries'. Transcript cr; print: Times sum; nextPutAll:' mSecs for all operations'. Transcript cr; print: Counts sum; nextPutAll: ' overall operations'. Transcript endEntry.! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/28/1998 23:59'! printStat: time count: n string: aString Transcript cr; print: time; tab; nextPutAll:' mSecs -- '; print: n; tab; nextPutAll:' ops -- '; print: ((time asFloat / (n max: 1) asFloat) roundTo: 0.01); tab; nextPutAll: ' avg. mSecs/op -- '; nextPutAll: aString.! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/28/1998 23:38'! resetStats Times := WordArray new: 10. Counts := WordArray new: 10.! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/30/1998 23:57'! printBezierStats "BalloonEngine printBezierStats" "BalloonEngine resetBezierStats" Transcript cr; nextPutAll:'Bezier statistics:'; crtab; print: (BezierStats at: 1); tab; nextPutAll:' non-monoton curves splitted'; crtab; print: (BezierStats at: 2); tab; nextPutAll:' curves splitted for numerical accuracy'; crtab; print: (BezierStats at: 3); tab; nextPutAll:' curves splitted to avoid integer overflow'; crtab; print: (BezierStats at: 4); tab; nextPutAll:' curves internally converted to lines'; endEntry.! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! doProfileStats: aBool "Note: On Macintosh systems turning on profiling can significantly degrade the performance of Balloon since we're using the high accuracy timer for measuring." "BalloonEngine doProfileStats: true" "BalloonEngine doProfileStats: false" ^false! ! !BalloonEngine class methodsFor: 'private' stamp: 'ar 5/28/2000 22:17'! primitiveSetBitBltPlugin: pluginName ^nil! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/25/1998 17:37'! debug: aBoolean "BalloonEngine debug: true" "BalloonEngine debug: false" Debug := aBoolean! ! !BalloonEngineConstants commentStamp: 'TorstenBergmann 1/31/2014 11:12'! Constants for the baloon engine! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:00'! initStateConstants "Initialize the state Constants" GEStateUnlocked := 0. "Buffer is unlocked and can be modified as wanted" GEStateAddingFromGET := 1. "Adding edges from the GET" GEStateWaitingForEdge := 2. "Waiting for edges added to GET" GEStateScanningAET := 3. "Scanning the active edge table" GEStateWaitingForFill := 4. "Waiting for a fill to mix in during AET scan" GEStateBlitBuffer := 5. "Blt the current scan line" GEStateUpdateEdges := 6. "Update edges to next scan line" GEStateWaitingChange := 7. "Waiting for a changed edge" GEStateCompleted := 8. "Rendering completed" "Error constants" GErrorNoMoreSpace := 1. "No more space in collection" GErrorBadState := 2. "Tried to call a primitive while engine in bad state" GErrorNeedFlush := 3. "Tried to call a primitive that requires flushing before" "Incremental error constants" GErrorGETEntry := 4. "Unknown entry in GET" GErrorFillEntry := 5. "Unknown FILL encountered" GErrorAETEntry := 6. "Unknown entry in AET" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'! initialize "BalloonEngineConstants initialize" self initStateConstants. self initWorkBufferConstants. self initPrimitiveConstants. self initEdgeConstants. self initFillConstants. self initializeInstVarNames: BalloonEngine prefixedBy: 'BE'. self initializeInstVarNames: BalloonEdgeData prefixedBy: 'ET'. self initializeInstVarNames: BalloonFillData prefixedBy: 'FT'.! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:55'! initEdgeConstants "Initialize the edge constants" "Edge primitive types" GEPrimitiveEdge := 2. "External edge - not handled by the GE" GEPrimitiveWideEdge := 3. "Wide external edge" GEPrimitiveLine := 4. "Straight line" GEPrimitiveWideLine := 5. "Wide line" GEPrimitiveBezier := 6. "Quadratic bezier curve" GEPrimitiveWideBezier := 7. "Wide bezier curve" "Special flags" GEPrimitiveWide := 16r01. "Flag determining a wide primitive" GEPrimitiveWideMask := 16rFE. "Mask for clearing the wide flag" GEEdgeFillsInvalid := 16r10000. "Flag determining if left/right fills of an edge are invalid" GEEdgeClipFlag := 16r20000. "Flag determining if this is a clip edge" "General edge state constants" GEXValue := 4. "Current raster x" GEYValue := 5. "Current raster y" GEZValue := 6. "Current raster z" GENumLines := 7. "Number of scan lines remaining" GEFillIndexLeft := 8. "Left fill index" GEFillIndexRight := 9. "Right fill index" GEBaseEdgeSize := 10. "Basic size of each edge" "General fill state constants" GEBaseFillSize := 4. "Basic size of each fill" "General Line state constants" GLXDirection := 10. "Direction of edge (1: left-to-right; -1: right-to-left)" GLYDirection := 11. "Direction of edge (1: top-to-bottom; -1: bottom-to-top)" GLXIncrement := 12. "Increment at each scan line" GLError := 13. "Current error" GLErrorAdjUp := 14. "Error to add at each scan line" GLErrorAdjDown := 15. "Error to subtract on roll-over" "Note: The following entries are only needed before the incremental state is computed. They are therefore aliased to the error values above" GLEndX := 14. "End X of line" GLEndY := 15. "End Y of line" GLBaseSize := 16. "Basic size of each line" "Additional stuff for wide lines" GLWideFill := 16. "Current fill of line" GLWideWidth := 17. "Current width of line" GLWideEntry := 18. "Initial steps" GLWideExit := 19. "Final steps" GLWideExtent := 20. "Target width" GLWideSize := 21. "Size of wide lines" "General Bezier state constants" GBUpdateData := 10. "Incremental update data for beziers" GBUpdateX := 0. "Last computed X value (24.8)" GBUpdateY := 1. "Last computed Y value (24.8)" GBUpdateDX := 2. "Delta X forward difference step (8.24)" GBUpdateDY := 3. "Delta Y forward difference step (8.24)" GBUpdateDDX := 4. "Delta DX forward difference step (8.24)" GBUpdateDDY := 5. "Delta DY forward difference step (8.24)" "Note: The following four entries are only needed before the incremental state is computed. They are therefore aliased to the incremental values above" GBViaX := 12. "via x" GBViaY := 13. "via y" GBEndX := 14. "end x" GBEndY := 15. "end y" GBBaseSize := 16. "Basic size of each bezier. Note: MUST be greater or equal to the size of lines" "Additional stuff for wide beziers" GBWideFill := 16. "Current fill of line" GBWideWidth := 17. "Current width of line" GBWideEntry := 18. "Initial steps" GBWideExit := 19. "Final steps" GBWideExtent := 20. "Target extent" GBFinalX := 21. "Final X value" GBWideUpdateData := 22. "Update data for second curve" GBWideSize := 28. "Size of wide beziers" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'StephaneDucasse 8/27/2010 10:54'! initializeInstVarNames: aClass prefixedBy: aString | token | aClass instVarNames doWithIndex:[:instVarName :index| | value aToken | aToken := (aString, instVarName first asUppercase asString, (instVarName copyFrom: 2 to: instVarName size),'Index') asSymbol. value := index - 1. (self bindingOf: aToken) ifNil:[self addClassVarNamed: aToken]. (self bindingOf: aToken) value: value. ]. token := (aString, aClass name,'Size') asSymbol. (self bindingOf: token) ifNil:[self addClassVarNamed: token]. (self bindingOf: token) value: aClass instSize.! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'! initFillConstants "Initialize the fill constants" "Fill primitive types" GEPrimitiveFill := 16r100. GEPrimitiveLinearGradientFill := 16r200. GEPrimitiveRadialGradientFill := 16r300. GEPrimitiveClippedBitmapFill := 16r400. GEPrimitiveRepeatedBitmapFill := 16r500. "General fill state constants" GEBaseFillSize := 4. "Basic size of each fill" "Oriented fill constants" GFOriginX := 4. "X origin of fill" GFOriginY := 5. "Y origin of fill" GFDirectionX := 6. "X direction of fill" GFDirectionY := 7. "Y direction of fill" GFNormalX := 8. "X normal of fill" GFNormalY := 9. "Y normal of fill" "Gradient fill constants" GFRampLength := 10. "Length of following color ramp" GFRampOffset := 12. "Offset of first ramp entry" GGBaseSize := 12. "Bitmap fill constants" GBBitmapWidth := 10. "Width of bitmap" GBBitmapHeight := 11. "Height of bitmap" GBBitmapDepth := 12. "Depth of bitmap" GBBitmapSize := 13. "Size of bitmap words" GBBitmapRaster := 14. "Size of raster line" GBColormapSize := 15. "Size of colormap, if any" GBTileFlag := 16. "True if the bitmap is tiled" GBColormapOffset := 18. "Offset of colormap, if any" GBMBaseSize := 18. "Basic size of bitmap fill" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:04'! initWorkBufferConstants "Initialize the work buffer constants" "General work buffer constants" GWMagicNumber := 16r416E6469. "Magic number" GWHeaderSize := 128. "Size of header" GWMinimalSize := 256. "Minimal size of work buffer" "Header entries" GWMagicIndex := 0. "Index of magic number" GWSize := 1. "Size of full buffer" GWState := 2. "Current state (e.g., locked or not." "Buffer entries" GWObjStart := 8. "objStart" GWObjUsed := 9. "objUsed" GWBufferTop := 10. "wbTop" GWGETStart := 11. "getStart" GWGETUsed := 12. "getUsed" GWAETStart := 13. "aetStart" GWAETUsed := 14. "aetUsed" "Transform entries" GWHasEdgeTransform := 16. "True if we have an edge transformation" GWHasColorTransform := 17. "True if we have a color transformation" GWEdgeTransform := 18. "2x3 edge transformation" GWColorTransform := 24. "8 word RGBA color transformation" "Span entries" GWSpanStart := 32. "spStart" GWSpanSize := 33. "spSize" GWSpanEnd := 34. "spEnd" GWSpanEndAA := 35. "spEndAA" "Bounds entries" GWFillMinX := 36. "fillMinX" GWFillMaxX := 37. "fillMaxX" GWFillMinY := 38. "fillMinY" GWFillMaxY := 39. "fillMaxY" GWFillOffsetX := 40. "fillOffsetX" GWFillOffsetY := 41. "fillOffsetY" GWClipMinX := 42. GWClipMaxX := 43. GWClipMinY := 44. GWClipMaxY := 45. GWDestOffsetX := 46. GWDestOffsetY := 47. "AA entries" GWAALevel := 48. "aaLevel" GWAAShift := 49. "aaShift" GWAAColorShift := 50. "aaColorShift" GWAAColorMask := 51. "aaColorMask" GWAAScanMask := 52. "aaScanMask" GWAAHalfPixel := 53. "aaHalfPixel" "Misc entries" GWNeedsFlush := 63. "True if the engine may need a flush" GWStopReason := 64. "stopReason" GWLastExportedEdge := 65. "last exported edge" GWLastExportedFill := 66. "last exported fill" GWLastExportedLeftX := 67. "last exported leftX" GWLastExportedRightX := 68. "last exported rightX" GWClearSpanBuffer := 69. "Do we have to clear the span buffer?" GWPointListFirst := 70. "First point list in buffer" GWPoint1 := 80. GWPoint2 := 82. GWPoint3 := 84. GWPoint4 := 86. GWCurrentY := 88. "Profile stats" GWTimeInitializing := 90. GWCountInitializing := 91. GWTimeFinishTest := 92. GWCountFinishTest := 93. GWTimeNextGETEntry := 94. GWCountNextGETEntry := 95. GWTimeAddAETEntry := 96. GWCountAddAETEntry := 97. GWTimeNextFillEntry := 98. GWCountNextFillEntry := 99. GWTimeMergeFill := 100. GWCountMergeFill := 101. GWTimeDisplaySpan := 102. GWCountDisplaySpan := 103. GWTimeNextAETEntry := 104. GWCountNextAETEntry := 105. GWTimeChangeAETEntry := 106. GWCountChangeAETEntry := 107. "Bezier stats" GWBezierMonotonSubdivisions := 108. "# of subdivision due to non-monoton beziers" GWBezierHeightSubdivisions := 109. "# of subdivisions due to excessive height" GWBezierOverflowSubdivisions := 110. "# of subdivisions due to possible int overflow" GWBezierLineConversions := 111. "# of beziers converted to lines" GWHasClipShapes := 112. "True if the engine contains clip shapes" GWCurrentZ := 113. "Current z value of primitives" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:59'! initPrimitiveConstants "Initialize the primitive constants" "Primitive type constants" GEPrimitiveUnknown := 0. GEPrimitiveEdgeMask := 16rFF. GEPrimitiveFillMask := 16rFF00. GEPrimitiveTypeMask := 16rFFFF. "General state constants (Note: could be compressed later)" GEObjectType := 0. "Type of object" GEObjectLength := 1. "Length of object" GEObjectIndex := 2. "Index into external objects" GEObjectUnused := 3. "Currently unused" ! ! !BalloonFillData commentStamp: ''! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! destForm: aForm destForm := aForm! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! yValue ^yValue! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/28/1998 16:35'! width ^maxX - minX! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! maxX: anInteger maxX := anInteger! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! minX ^minX! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! yValue: anInteger yValue := anInteger! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! source ^source! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! destForm ^destForm! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! index: anInteger index := anInteger! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! maxX ^maxX! ! !BalloonFillData methodsFor: 'computing' stamp: 'ar 11/14/1998 19:32'! computeFill (destForm isNil or:[destForm width < self width]) ifTrue:[ destForm := Form extent: (self width + 10) @ 1 depth: 32. ]. source computeFillFrom: minX to: maxX at: yValue in: destForm! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! minX: anInteger minX := anInteger! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! source: anObject source := anObject! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! index ^index! ! !BalloonLineSimulation commentStamp: ''! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! end: aPoint end := aPoint! ! !BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:39'! stepToNextScanLineAt: yValue in: edgeTableEntry "Compute the next x value for the scan line at yValue. This message is sent during incremental updates. The yValue parameter is passed in here for edges that have more complicated computations," | x | x := edgeTableEntry xValue + xIncrement. error := error + errorAdjUp. error > 0 ifTrue:[ x := x + xDirection. error := error - errorAdjDown. ]. edgeTableEntry xValue: x.! ! !BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:22'! stepToFirstScanLineAt: yValue in: edgeTableEntry "Compute the initial x value for the scan line at yValue" | startX endX startY endY yDir deltaY deltaX widthX | (start y) <= (end y) ifTrue:[ startX := start x. endX := end x. startY := start y. endY := end y. yDir := 1. ] ifFalse:[ startX := end x. endX := start x. startY := end y. endY := start y. yDir := -1. ]. deltaY := endY - startY. deltaX := endX - startX. "Quickly check if the line is visible at all" (yValue >= endY or:[deltaY = 0]) ifTrue:[^edgeTableEntry lines: 0]. "Check if edge goes left to right" deltaX >= 0 ifTrue:[ xDirection := 1. widthX := deltaX. error := 0. ] ifFalse:[ xDirection := -1. widthX := 0 - deltaX. error := 1 - deltaY. ]. "Check if edge is horizontal" deltaY = 0 ifTrue:[ xIncrement := 0. errorAdjUp := 0] ifFalse:["Check if edge is y-major" deltaY > widthX ifTrue:[ xIncrement := 0. errorAdjUp := widthX] ifFalse:[ xIncrement := (widthX // deltaY) * xDirection. errorAdjUp := widthX \\ deltaY]]. errorAdjDown := deltaY. edgeTableEntry xValue: startX. edgeTableEntry lines: deltaY. "If not at first scan line then step down to yValue" yValue = startY ifFalse:[ startY to: yValue do:[:y| self stepToNextScanLineAt: y in: edgeTableEntry]. "And adjust remainingLines" edgeTableEntry lines: deltaY - (yValue - startY). ].! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'! initialY ^start y <= end y ifTrue:[start y] ifFalse:[end y]! ! !BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:52'! computeInitialStateFrom: source with: aTransformation "Compute the initial state in the receiver." start := (aTransformation localPointToGlobal: source start) asIntegerPoint. end := (aTransformation localPointToGlobal: source end) asIntegerPoint.! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'! initialX ^start y <= end y ifTrue:[start x] ifFalse:[end x]! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! start ^start! ! !BalloonLineSimulation methodsFor: 'printing' stamp: 'ar 10/27/1998 23:20'! printOn: aStream aStream nextPutAll: self class name; nextPut:$(; print: start; nextPutAll:' - '; print: end; nextPut:$)! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! end ^end! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! start: aPoint start := aPoint! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'! initialZ ^0 "Assume no depth given"! ! !BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/29/1998 23:42'! subdivide ^nil! ! !BalloonMorph commentStamp: ''! A balloon with text used for the display of explanatory information. Balloon help is integrated into Morphic as follows: If a Morph has the property #balloonText, then it will respond to #showBalloon by adding a text balloon to the world, and to #deleteBalloon by removing the balloon. Moreover, if mouseOverEnabled is true (see class msg), then the Hand will arrange to cause display of the balloon after the mouse has lingered over the morph for a while, and removal of the balloon when the mouse leaves the bounds of that morph. In any case, the Hand will attempt to remove any such balloons before handling mouseDown events, or displaying other balloons. Balloons should not be duplicated with veryDeepCopy unless their target is also duplicated at the same time.! !BalloonMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/20/2011 12:21'! defaultColor "answer the default color/fill style for the receiver" ^ self balloonColor! ! !BalloonMorph methodsFor: 'private' stamp: 'sma 12/23/1999 14:06'! setTarget: aMorph (target := aMorph) ifNotNil: [offsetFromTarget := self position - target position]! ! !BalloonMorph methodsFor: 'initialization' stamp: 'RAA 7/1/2001 18:48'! popUpForHand: aHand "Pop up the receiver as balloon help for the given hand" | worldBounds | self lock. self fullBounds. "force layout" self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber. aHand world addMorphFront: self. "So that if the translation below makes it overlap the receiver, it won't interfere with the rootMorphsAt: logic and hence cause flashing. Without this, flashing happens, believe me!!" ((worldBounds := aHand world bounds) containsRect: self bounds) ifFalse: [self bounds: (self bounds translatedToBeWithin: worldBounds)]. aHand balloonHelp: self. ! ! !BalloonMorph methodsFor: 'menus' stamp: 'wiz 12/30/2004 17:14'! adjustedCenter "Return the center of the original textMorph box within the balloon." ^ (self vertices last: 4) average rounded ! ! !BalloonMorph methodsFor: 'accessing' stamp: 'ar 10/3/2000 17:19'! balloonOwner ^balloonOwner! ! !BalloonMorph methodsFor: 'stepping and presenter' stamp: 'sma 12/23/1999 14:05'! step "Move with target." target ifNotNil: [self position: target position + offsetFromTarget]. ! ! !BalloonMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/20/2011 12:25'! initialize "initialize the state of the receiver" balloonColor := self class balloonColor. super initialize. self beSmoothCurve. offsetFromTarget := 0@0.! ! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 3/12/2006 14:27'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ self defaultColor muchDarker"Color black"! ! !BalloonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/20/2011 12:25'! balloonColor ^ balloonColor! ! !BalloonMorph methodsFor: 'testing' stamp: 'di 9/18/97 10:10'! stepTime ^ 0 "every cycle"! ! !BalloonMorph methodsFor: 'wiw support' stamp: 'RAA 6/27/2000 18:07'! morphicLayerNumber "helpful for insuring some morphs always appear in front of or behind others. smaller numbers are in front" ^5 "Balloons are very front-like things"! ! !BalloonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/20/2011 12:35'! balloonColor: aColor balloonColor := aColor. self color: aColor! ! !BalloonMorph methodsFor: 'initialization' stamp: 'ar 10/4/2000 10:13'! popUpFor: aMorph hand: aHand "Pop up the receiver as balloon help for the given hand" balloonOwner := aMorph. self popUpForHand: aHand.! ! !BalloonMorph methodsFor: 'initialization' stamp: 'AlainPlantec 10/20/2010 20:12'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !BalloonMorph class methodsFor: 'utility' stamp: 'AlainPlantec 11/30/2009 09:27'! balloonFont ^ BalloonFont ifNil: [BalloonFont := StandardFonts defaultFont]! ! !BalloonMorph class methodsFor: 'instance creation' stamp: 'HilaireFernandes 5/14/2011 16:25'! initialize "BalloonMorph initialize" self setBalloonColorTo: BalloonMorph defaultBalloonColor. self balloonFont: StandardFonts defaultFont! ! !BalloonMorph class methodsFor: 'private' stamp: 'MarcusDenker 2/24/2011 21:09'! defaultBalloonColor ^ (Color fromArray: #(0.85 0.9 1.0 )) twiceLighter alpha: 0.95! ! !BalloonMorph class methodsFor: 'instance creation' stamp: 'sma 12/23/1999 20:05'! string: str for: morph ^ self string: str for: morph corner: #bottomLeft! ! !BalloonMorph class methodsFor: 'utility' stamp: 'BenjaminVanRyseghem 1/20/2011 11:29'! balloonColor ^ BalloonColor ifNil: [BalloonColor := self defaultBalloonColor]! ! !BalloonMorph class methodsFor: 'private' stamp: 'wiz 1/8/2005 18:05'! getVertices: bounds "Construct vertices for a balloon up and to left of anchor" | corners | corners := bounds corners atAll: #(1 4 3 2). ^ (Array with: corners first + (0 - bounds width // 2 @ 0) with: corners first + (0 - bounds width // 4 @ (bounds height // 2))) , corners! ! !BalloonMorph class methodsFor: 'instance creation' stamp: 'FranciscoGarau 4/29/2012 15:23'! string: str for: morph corner: cornerName "Make up and return a balloon for morph. Find the quadrant that clips the text the least, using cornerName as a tie-breaker. tk 9/12/97" | tm vertices | tm := self getTextMorph: str for: morph. tm composeToBounds. vertices := self getVertices: tm bounds. vertices := self getBestLocation: vertices for: morph corner: cornerName. ^ self new color: self balloonColor; setVertices: vertices; addMorph: tm; setTarget: morph! ! !BalloonMorph class methodsFor: 'private' stamp: 'CamilloBruni 8/1/2012 16:07'! getBestLocation: vertices for: morph corner: cornerName | rect maxArea verts rectCorner morphPoint mbc a mp dir bestVerts result usableArea | "Choose rect independantly of vertice order or size. Would be nice it this took into account curveBounds but it does not." rect := Rectangle encompassing: vertices. maxArea := -1. verts := vertices. usableArea := (morph world ifNil: [self currentWorld]) viewBox. 1 to: 4 do: [:i | dir := #(vertical horizontal) atWrap: i. verts := verts collect: [:p | p flipBy: dir centerAt: rect center]. rectCorner := #(bottomLeft bottomRight topRight topLeft) at: i. morphPoint := #(topCenter topCenter bottomCenter bottomCenter) at: i. a := ((rect align: (rect perform: rectCorner) with: (mbc := morph boundsForBalloon perform: morphPoint)) intersect: usableArea) area. (a > maxArea or: [a = rect area and: [rectCorner = cornerName]]) ifTrue: [maxArea := a. bestVerts := verts. mp := mbc]]. result := bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:". ^ result! ! !BalloonMorph class methodsFor: '*FreeType-override' stamp: 'AlainPlantec 12/18/2009 16:45'! chooseBalloonFont "BalloonMorph chooseBalloonFont" StandardFonts chooseStandardFont: #balloonFont ! ! !BalloonMorph class methodsFor: 'private' stamp: 'AlainPlantec 11/30/2009 09:45'! getTextMorph: aStringOrMorph for: balloonOwner "Construct text morph." | m text | aStringOrMorph isMorph ifTrue: [m := aStringOrMorph] ifFalse: [balloonOwner balloonFont ifNil: [text := aStringOrMorph] ifNotNil: [text := Text string: aStringOrMorph attribute: (TextFontReference toFont: balloonOwner balloonFont)]. m := (TextMorph new contents: text) centered]. m setToAdhereToEdge: #adjustedCenter. ^ m! ! !BalloonMorph class methodsFor: 'utility' stamp: 'sma 11/11/2000 14:59'! setBalloonColorTo: aColor aColor ifNotNil: [BalloonColor := aColor]! ! !BalloonMorph class methodsFor: 'utility' stamp: 'AlainPlantec 11/30/2009 09:40'! balloonFont: aFont BalloonFont := aFont! ! !BalloonSolidFillSimulation commentStamp: ''! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonSolidFillSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:08'! computeInitialStateFrom: source with: aColorTransform color := source asColor.! ! !BalloonSolidFillSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:07'! computeFillFrom: minX to: maxX at: yValue in: form | bb | color isTransparent ifFalse:[ bb := BitBlt toForm: form. bb fillColor: color. bb destX: 0 destY: 0 width: (maxX - minX) height: 1. bb combinationRule: Form over. bb copyBits].! ! !BalloonState commentStamp: ''! This class is a repository for data which needs to be preserved during certain operations of BalloonCanvas.! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'! colorTransform ^colorTransform! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'! transform: aMatrixTransform transform := aMatrixTransform! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:41'! transform ^transform! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:47'! aaLevel: aNumber aaLevel := aNumber! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'! colorTransform: aColorTransform colorTransform := aColorTransform! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:47'! aaLevel ^aaLevel! ! !Base64MimeConverter commentStamp: ''! This class encodes and decodes data in Base64 format. This is MIME encoding. We translate a whole stream at once, taking a Stream as input and giving one as output. Returns a whole stream for the caller to use. 0 A 17 R 34 i 51 z 1 B 18 S 35 j 52 0 2 C 19 T 36 k 53 1 3 D 20 U 37 l 54 2 4 E 21 V 38 m 55 3 5 F 22 W 39 n 56 4 6 G 23 X 40 o 57 5 7 H 24 Y 41 p 58 6 8 I 25 Z 42 q 59 7 9 J 26 a 43 r 60 8 10 K 27 b 44 s 61 9 11 L 28 c 45 t 62 + 12 M 29 d 46 u 63 / 13 N 30 e 47 v 14 O 31 f 48 w (pad) = 15 P 32 g 49 x 16 Q 33 h 50 y Outbound: bytes are broken into 6 bit chunks, and the 0-63 value is converted to a character. 3 data bytes go into 4 characters. Inbound: Characters are translated in to 0-63 values and shifted into 8 bit bytes. (See: N. Borenstein, Bellcore, N. Freed, Innosoft, Network Working Group, Request for Comments: RFC 1521, September 1993, MIME (Multipurpose Internet Mail Extensions) Part One: Mechanisms for Specifying and Describing the Format of Internet Message Bodies. Sec 6.2) By Ted Kaehler, based on Tim Olson's Base64Filter.! !Base64MimeConverter methodsFor: 'initialization' stamp: 'dik 9/22/2010 18:09'! initialize super initialize. multiLine := true.! ! !Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:39'! mimeDecodeToByteArray "Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full ByteArray of 0-255 values. Reutrn a whole stream for the user to read." | nibA nibB nibC nibD | [mimeStream atEnd] whileFalse: [ (nibA := self nextValue) ifNil: [^ dataStream]. (nibB := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)). nibB := nibB bitAnd: 16rF. (nibC := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)). nibC := nibC bitAnd: 16r3. (nibD := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibC bitShift: 6) + nibD). ]. ^ dataStream! ! !Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:34'! mimeDecode "Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full byte stream of characters. Reutrn a whole stream for the user to read." | nibA nibB nibC nibD | [mimeStream atEnd] whileFalse: [ (nibA := self nextValue) ifNil: [^ dataStream]. (nibB := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)) asCharacter. nibB := nibB bitAnd: 16rF. (nibC := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)) asCharacter. nibC := nibC bitAnd: 16r3. (nibD := self nextValue) ifNil: [^ dataStream]. dataStream nextPut: ((nibC bitShift: 6) + nibD) asCharacter. ]. ^ dataStream! ! !Base64MimeConverter methodsFor: 'accessing' stamp: 'dik 9/22/2010 18:07'! multiLine: anObject multiLine := anObject! ! !Base64MimeConverter methodsFor: 'accessing' stamp: 'dik 9/22/2010 18:07'! multiLine ^ multiLine! ! !Base64MimeConverter methodsFor: 'conversion' stamp: 'dik 9/22/2010 18:07'! mimeEncode "Convert from data to 6 bit characters." | phase1 phase2 raw nib lineLength | phase1 := phase2 := false. lineLength := 0. [dataStream atEnd] whileFalse: [ (multiLine and:[lineLength >= 70]) ifTrue: [ mimeStream cr. lineLength := 0. ]. data := raw := dataStream next asInteger. nib := (data bitAnd: 16rFC) bitShift: -2. mimeStream nextPut: (ToCharTable at: nib+1). (raw := dataStream next) ifNil: [raw := 0. phase1 := true]. data := ((data bitAnd: 3) bitShift: 8) + raw asInteger. nib := (data bitAnd: 16r3F0) bitShift: -4. mimeStream nextPut: (ToCharTable at: nib+1). (raw := dataStream next) ifNil: [raw := 0. phase2 := true]. data := ((data bitAnd: 16rF) bitShift: 8) + (raw asInteger). nib := (data bitAnd: 16rFC0) bitShift: -6. mimeStream nextPut: (ToCharTable at: nib+1). nib := (data bitAnd: 16r3F). mimeStream nextPut: (ToCharTable at: nib+1). lineLength := lineLength + 4.]. phase1 ifTrue: [mimeStream skip: -2; nextPut: $=; nextPut: $=. ^ mimeStream]. phase2 ifTrue: [mimeStream skip: -1; nextPut: $=. ^ mimeStream]. ! ! !Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:21'! nextValue "The next six bits of data char from the mimeStream, or nil. Skip all other chars" | raw num | [raw := mimeStream next. raw ifNil: [^ nil]. "end of stream" raw == $= ifTrue: [^ nil]. num := FromCharTable at: raw asciiValue + 1. num ifNotNil: [^ num]. "else ignore space, return, tab, ..." true] whileTrue.! ! !Base64MimeConverter class methodsFor: 'class initialization' stamp: 'tk 12/9/97 13:53'! initialize FromCharTable := Array new: 256. "nils" ToCharTable := Array new: 64. ($A asciiValue to: $Z asciiValue) doWithIndex: [:val :ind | FromCharTable at: val+1 put: ind-1. ToCharTable at: ind put: val asCharacter]. ($a asciiValue to: $z asciiValue) doWithIndex: [:val :ind | FromCharTable at: val+1 put: ind+25. ToCharTable at: ind+26 put: val asCharacter]. ($0 asciiValue to: $9 asciiValue) doWithIndex: [:val :ind | FromCharTable at: val+1 put: ind+25+26. ToCharTable at: ind+26+26 put: val asCharacter]. FromCharTable at: $+ asciiValue + 1 put: 62. ToCharTable at: 63 put: $+. FromCharTable at: $/ asciiValue + 1 put: 63. ToCharTable at: 64 put: $/. ! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'dik 9/22/2010 18:08'! mimeEncode: aStream multiLine: aBool "Return a ReadWriteStream of characters. The data of aStream is encoded as 65 innocuous characters. (See class comment). 3 bytes in aStream goes to 4 bytes in output." | me | me := self new dataStream: aStream. me multiLine: aBool. me mimeStream: (ReadWriteStream on: (String new: aStream size + 20 * 4 // 3)). me mimeEncode. me mimeStream position: 0. ^ me mimeStream! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:01'! mimeDecodeToChars: aStream "Return a ReadWriteStream of the original String. aStream has only 65 innocuous character values. It is not binary. (See class comment). 4 bytes in aStream goes to 3 bytes in output." | me | aStream position: 0. me := self new mimeStream: aStream. me dataStream: (ReadWriteStream on: (String new: aStream size * 3 // 4)). me mimeDecode. me dataStream position: 0. ^ me dataStream! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/12/97 11:41'! mimeDecodeToBytes: aStream "Return a RWBinaryOrTextStream of the original ByteArray. aStream has only 65 innocuous character values. aStream is not binary. (See class comment). 4 bytes in aStream goes to 3 bytes in output." | me | aStream position: 0. me := self new mimeStream: aStream. me dataStream: (RWBinaryOrTextStream on: (ByteArray new: aStream size * 3 // 4)). me mimeDecodeToByteArray. me dataStream position: 0. ^ me dataStream! ! !Base64MimeConverter class methodsFor: 'convenience' stamp: 'dik 9/22/2010 18:08'! mimeEncode: aStream "Return a ReadWriteStream of characters. The data of aStream is encoded as 65 innocuous characters. (See class comment). 3 bytes in aStream goes to 4 bytes in output." ^self mimeEncode: aStream multiLine: true! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 2/21/2000 17:22'! encodeInteger: int | strm | "Encode an integer of any length and return the MIME string" strm := ReadWriteStream on: (ByteArray new: int digitLength). 1 to: int digitLength do: [:ii | strm nextPut: (int digitAt: ii)]. strm reset. ^ ((self mimeEncode: strm) contents) copyUpTo: $= "remove padding"! ! !Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'damiencassou 5/30/2008 11:45'! decodeInteger: mimeString "Decode the MIME string into an integer of any length" | bytes sum | bytes := (Base64MimeConverter mimeDecodeToBytes: mimeString readStream) contents. sum := 0. bytes reverseDo: [ :by | sum := sum * 256 + by ]. ^ sum! ! !Base64MimeConverterTest commentStamp: ''! This is the unit test for the class Base64MimeConverter. 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 - there is a chapter in the PharoByExample book (http://pharobyexample.org/) - the sunit class category! !Base64MimeConverterTest methodsFor: 'tests' stamp: 'HenrikSperreJohansen 6/25/2012 12:31'! testDecodeMimeHeader "Test MIME decoding from single-byte encoding to Unicode" "self run: #testDecodeMimeHeader" | mimeHeader expected multiStream characters| characters := #[16rBE 16rFD 16r5F 16rE1 16r2E 16rC8] asString. mimeHeader := '=?ISO-8859-2?Q?=BE=FD=5F=E1=2E=C8?=' decodeMimeHeader. expected := characters convertFromEncoding: 'ISO-8859-2'. self assert: mimeHeader = expected! ! !Base64MimeConverterTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/16/2010 12:54'! testMimeEncodeDecode "self run: #testMimeEncodeDecode" | encoded | encoded := Base64MimeConverter mimeEncode: message. self assert: (encoded contents = 'SGkgVGhlcmUh'). self assert: ((Base64MimeConverter mimeDecodeToChars: encoded) contents = message contents). "Encoding should proceed from the current stream position." message reset. message skip: 2. encoded := Base64MimeConverter mimeEncode: message. self assert: (encoded contents = 'IFRoZXJlIQ==').! ! !Base64MimeConverterTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/16/2010 12:45'! testBase64Encoded "self run: #testBase64Encoded" | encoded | encoded := (Base64MimeConverter mimeEncode: message) contents. self assert: encoded = 'Hi There!!' base64Encoded. ! ! !Base64MimeConverterTest methodsFor: 'setup' stamp: 'StephaneDucasse 1/16/2010 12:53'! setUp message := 'Hi There!!' readStream.! ! !Base64MimeConverterTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/16/2010 12:54'! testOnByteArray "self run: #testOnByteArray" self assert: ('Hi There!!' base64Encoded = 'Hi There!!' asByteArray base64Encoded)! ! !BaseStreamTest methodsFor: 'testing' stamp: 'Cami 7/9/2012 10:52'! testReadOnlyFileNamed | testString fileName file | "Given" fileName := self testFileName. testString := 'testString'. "When" [self baseStreamType fileNamed: fileName do: [:streamType | streamType nextPut: testString]. "Then" file := self baseStreamType readOnlyFileNamed: fileName. self assert: file next = testString. file close] ensure: [ fileName asFileReference delete ]! ! !BaseStreamTest methodsFor: 'accessing' stamp: 'CarloTeixeira 2/26/2012 00:19'! baseStreamType "Answer the stream type to be tested" self shouldBeImplemented.! ! !BaseStreamTest methodsFor: 'accessing' stamp: 'Cami 7/9/2012 10:51'! testFileName ^ self class name,'_', testSelector , '_test'! ! !BaseStreamTest methodsFor: 'testing' stamp: 'S 6/17/2013 13:16'! testFileNamed | testString fileName | "Given" fileName := self testFileName. testString := 'testString'. "When" [self baseStreamType fileNamed: fileName do: [:streamType | streamType nextPut: testString]. "Then" self baseStreamType fileNamed: fileName do: [:streamType | self assert: streamType next = testString]] ensure: [ (FileSystem disk workingDirectory / fileName) ensureDelete ].! ! !BaseStreamTest class methodsFor: 'as yet unclassified' stamp: 'CarloTeixeira 2/26/2012 00:23'! isAbstract ^ self = BaseStreamTest.! ! !BaseStreamTest class methodsFor: 'as yet unclassified' stamp: 'CarloTeixeira 2/26/2012 00:25'! isUnitTest ^false! ! !BaselineOf commentStamp: 'dkh 5/30/2012 16:30'! You should use a *baseline* when you are using a disk-based source code manager (SCM) like [git][1]. When using a disk-based SCM it is not necessary to use the Metacello *version* method, because it is intended for use with `.mcz` files. With a disk-based SCM you only need a single `baseline:` method. When you change the structure of your project you can change the baseline and save everything in a single commit. So multiple `baseline:` methods are no longer needed. You may still need a *configuration* when using a *baseline*. The [Sample project][3] on GitHub has a good example of a configuration used in conjunction with a *baseline*. See the [**ConfigurationOf** class comment][2] for information on creating a *configuration*. To create a new Metacello baseline: 1. Create a subclass of the **BaselineOf** class. The baseline class for your project should be named by appending the name of your project to the string `BaselineOf`. The name of the category and package should be the same as the name of the class: ```Smalltalk BaselineOf subclass: #BaselineOfExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'BaselineOfExample' ``` 2. Create a **baseline:** method where you specify the structure of your project: ```Smalltalk baseline: spec spec for: #common do: [ spec package: 'Example-Core'; package: 'Example-Tests' with: [ spec requires: 'Example-Core' ]]. ``` 3. Create a Monticello package for your **BaselineOf** class and save it in the repository where your packages are stored. [1]: http://git-scm.com/ [2]: https://github.com/dalehenrich/metacello-work/blob/master/repository/Metacello-Base.package/ConfigurationOf.class/README.md [3]: https://github.com/dalehenrich/sample/tree/configuration/ConfigurationOfSample.package/ConfigurationOfSample.class ! !BaselineOf methodsFor: 'accessing' stamp: 'dkh 6/22/2012 12:09'! versionNumberClass ^ MetacelloVersionNumber! ! !BaselineOf methodsFor: 'accessing' stamp: 'dkh 5/31/2012 17:57:13'! projectClass ^ MetacelloMCBaselineProject! ! !BasicBehaviorClassMetaclassTest commentStamp: ''! This class contains some tests regarding the classes Behavior ClassDescription Class Metaclass --- ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:12'! testMetaclassNumberOfInstances "self run: #testMetaclassNumberOfInstances" self assert: Dictionary class allInstances size = 1. self assert: OrderedCollection class allInstances size = 1.! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:21'! testObjectAllSubclasses "self run: #testObjectAllSubclasses" | n2 | n2 := Object allSubclasses size. self assert: n2 = (Object allSubclasses select: [:cls | cls class class == Metaclass or: [cls class == Metaclass]]) size! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'StephaneDucasse 5/12/2010 10:18'! testSuperclass "self debug: #testSuperclass" | s b | s := OrderedCollection new. b := [:cls | cls ifNotNil: [s add: cls. b value: cls superclass] ]. b value: OrderedCollection. self assert: OrderedCollection allSuperclasses = s allButFirst. self assert: OrderedCollection withAllSuperclasses = s.! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:12'! testMetaclassName "self run: #testMetaclassName" self assert: Dictionary class name = 'Dictionary class'. self assert: OrderedCollection class name = 'OrderedCollection class'. ! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:17'! testMetaclass "self run: #testMetaclass" self assert: OrderedCollection class class == Metaclass. self assert: Dictionary class class == Metaclass. self assert: Object class class == Metaclass. ! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:14'! testMetaclassSuperclassHierarchy "self run: #testMetaclassSuperclassHierarchy" | s | self assert: SequenceableCollection class instanceCount = 1. self assert: Collection class instanceCount = 1. self assert: Object class instanceCount = 1. self assert: ProtoObject class instanceCount = 1. s := OrderedCollection new. s add: SequenceableCollection class. s add: Collection class. s add: Object class. s add: ProtoObject class. s add: Class. s add: ClassDescription. s add: Behavior. s add: Object. s add: ProtoObject. self assert: OrderedCollection class allSuperclasses = s. ! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:19'! testBehaviorClassClassDescriptionMetaclassHierarchy "self run: #testBehaviorClassClassDescriptionMetaclassHierarchy" self assert: Class superclass == ClassDescription. self assert: Metaclass superclass == ClassDescription. self assert: ClassDescription superclass == Behavior. self assert: Behavior superclass = Object. self assert: Class class class == Metaclass. self assert: Metaclass class class == Metaclass. self assert: ClassDescription class class == Metaclass. self assert: Behavior class class == Metaclass. ! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'StephaneDucasse 5/12/2010 10:18'! testMetaclassSuperclass "self run: #testMetaclassSuperclass" self assert: Dictionary class superclass == Dictionary superclass class. self assert: OrderedCollection class superclass == OrderedCollection superclass class.! ! !BasicBehaviorClassMetaclassTest methodsFor: 'testing' stamp: 'sd 6/5/2005 08:18'! testMetaclassPointOfCircularity "self run: #testMetaclassPointOfCircularity" self assert: Metaclass class instanceCount = 1. self assert: Metaclass class someInstance == Metaclass. ! ! !BasicCommandLineHandler commentStamp: ''! I'm a command line handler who is not aware of any UI or Tools present in the system. I'm used as base handler for loading executing stripped images (kernel images, for example). My usage is the same as PharoCommandLineHandler, see his comment as better explanation.! !BasicCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 5/26/2013 14:05'! handleArgument: aString "give priority to subcommands" self handleSubcommand == self ifFalse: [ ^ self ]. "check for default options" aString ifEmpty: [ ^ self default ]. aString = '--version' ifTrue: [ ^ self version ]. aString = '--help' ifTrue: [ ^ self help ]. aString = '--list' ifTrue: [ ^ self list ]. aString = '--copyright' ifTrue: [ ^ self copyright ]. aString = '--no-quit' ifTrue: [ ^ self noQuit ]. "none of the previous options matched hence we output an error message" self error.! ! !BasicCommandLineHandler methodsFor: 'activation' stamp: 'EstebanLorenzano 5/23/2013 14:27'! activateSubCommand: aCommandLinehandler [ aCommandLinehandler activateWith: commandLine ] on: Exit do: [ :exit | ^ self handleExit: exit for: aCommandLinehandler ]. "the return value of this method is used to check if the subcommand was successfull" ^ aCommandLinehandler! ! !BasicCommandLineHandler methodsFor: 'private' stamp: 'DamienCassou 12/11/2013 15:35'! selectHandlers | handlers | handlers := (self subCommandsRoot selectHandlersFor: commandLine) copyWithout: self class. handlers := handlers sort: [ :a :b | a priority >= b priority ]. ^ handlers! ! !BasicCommandLineHandler methodsFor: 'commands' stamp: 'EstebanLorenzano 5/23/2013 14:27'! version self stdout nextPutAll: 'Image: '; print: SystemVersion current; cr; nextPutAll: 'VM: '; nextPutAll: Smalltalk vm version; cr. self quit.! ! !BasicCommandLineHandler methodsFor: 'activation' stamp: 'EstebanLorenzano 5/23/2013 15:33'! handleSubcommand "check if there is an active subcommand" | handlers | handlers := self selectHandlers. "If there is no handler, use myself" handlers ifEmpty: [ ^ self ]. ^self activateSubCommand: handlers first . ! ! !BasicCommandLineHandler methodsFor: 'private' stamp: 'DamienCassou 12/11/2013 15:35'! subCommandsRoot ^ CommandLineHandler! ! !BasicCommandLineHandler methodsFor: 'initialization' stamp: 'EstebanLorenzano 5/23/2013 14:27'! initialize super initialize. commandLine := CommandLineArguments new! ! !BasicCommandLineHandler methodsFor: 'commands' stamp: 'CamilloBruni 5/26/2013 14:08'! default ^ self help; exitSuccess! ! !BasicCommandLineHandler methodsFor: 'activation' stamp: 'EstebanLorenzano 5/23/2013 14:27'! handleExit: exit ^ self handleExit: exit for: self! ! !BasicCommandLineHandler methodsFor: 'activation' stamp: 'EstebanLorenzano 5/23/2013 14:27'! handleExit: exit for: aCommandLinehandler Smalltalk isInteractive ifFalse: [ ^ exit pass ]. exit isSuccess ifFalse: [ ^ Error signal: exit messageText ]. self inform: aCommandLinehandler name, ' successfully finished'. "for failing subcommands return self which is used to check if the subcommand failed" exit isSuccess ifTrue: [ ^ aCommandLinehandler ].! ! !BasicCommandLineHandler methodsFor: 'private' stamp: 'CamilloBruni 5/26/2013 13:59'! selectedHandler ^ self selectHandlers ifEmpty: [ nil ] ifNotEmpty: [ :handlers | handlers first ]! ! !BasicCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 5/26/2013 13:42'! handleEmptyArguments Smalltalk isHeadless ifFalse: [ ^ self ]. self help.! ! !BasicCommandLineHandler methodsFor: 'commands' stamp: 'CamilloBruni 5/26/2013 14:01'! noQuit "Nothing to be done, unlike the other commands the image continues running"! ! !BasicCommandLineHandler methodsFor: 'commands' stamp: 'EstebanLorenzano 5/23/2013 14:27'! copyright self stdout nextPutAll: Smalltalk licenseString; cr. self quit.! ! !BasicCommandLineHandler methodsFor: 'commands' stamp: 'CamilloBruni 9/4/2013 17:13'! list | handlers shortNames maxShortNameSize | self stdout nextPutAll: 'Currently installed Command Line Handlers:'; lf. handlers := self allHandlers reject: [ :cls | cls includesBehavior: BasicCommandLineHandler ]. shortNames := handlers collect: #commandName. maxShortNameSize := (shortNames detectMax: [ :name| name size ]) size. handlers do: [ :handler| self stdout nextPutAll: ' '; nextPutAll: (handler commandName padRightTo: maxShortNameSize); nextPutAll: ' '; nextPutAll: (handler description ifNil: [ '--']); lf]. self quit.! ! !BasicCommandLineHandler methodsFor: 'activation' stamp: 'StephaneDucasse 8/22/2013 23:21'! activate [ self handleArgument: (self arguments ifEmpty: [ '' ] ifNotEmpty: [ :arguments| arguments first ])] on: Exit do: [ :exit | ^ self handleExit: exit ]! ! !BasicCommandLineHandler methodsFor: 'commands' stamp: 'EstebanLorenzano 5/23/2013 14:27'! error self arguments size = 1 ifTrue: [ (self arguments first beginsWith: '-') ifTrue: [ self << 'Invalid option: '] ifFalse: [ self << 'Invalid sub command: ']] ifFalse: [ self << 'Invalid arguments: "']. (self << (' ' join: self arguments)) nextPutAll: '"'; cr. self printHelp. self exitFailure.! ! !BasicCommandLineHandler class methodsFor: 'handler selection' stamp: 'EstebanLorenzano 5/23/2013 15:10'! isResponsibleFor: aCommandLine "I do not match ever, because my activation is manual" ^ false! ! !BasicCommandLineHandler class methodsFor: 'class initialization' stamp: 'SeanDeNigris 10/4/2013 13:14'! initialize "hook into the startup list" Smalltalk addToStartUpList: self.! ! !BasicCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 5/31/2013 11:32'! priority "Lowest priority" ^ Float infinity negated! ! !BasicCommandLineHandler class methodsFor: 'handler selection' stamp: 'EstebanLorenzano 5/23/2013 14:30'! description ^ 'basic responsible for the default options and activating other commands'! ! !BasicCommandLineHandler class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 5/23/2013 14:31'! startUp: resuming "only handle when lauching a new image" resuming ifFalse: [ ^ self ]. Smalltalk addDeferredStartupAction: [ self new activate ] ! ! !BasicCommandLineHandler class methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/23/2013 14:28'! commandName ^ ''! ! !BasicIndexedEyeElement commentStamp: ''! I am an eye element for indexable fields. (basicAt:)! !BasicIndexedEyeElement methodsFor: 'action' stamp: 'ClementBera 4/30/2013 15:33'! save: aValue self host basicAt: self index put: aValue! ! !BasicIndexedEyeElement methodsFor: 'comparing' stamp: 'SvenVanCaekenberghe 3/30/2014 13:09'! = anObject ^ super = anObject and: [ index = anObject index ]! ! !BasicIndexedEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 12:59'! value ^ self host basicAt: self index! ! !BasicIndexedEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 13:04'! accessorCode ^ '(self basicAt: ', self index asString, ')'! ! !BasicIndexedEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 16:09'! label ^ self index printString! ! !BasicIndexedEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 12:56'! index: anObject index := anObject! ! !BasicIndexedEyeElement methodsFor: 'comparing' stamp: 'SvenVanCaekenberghe 4/1/2014 09:53'! hash ^ super hash bitXor: index hash! ! !BasicIndexedEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 12:56'! index ^ index! ! !BasicIndexedEyeElement class methodsFor: 'instance creation' stamp: 'ClementBera 4/30/2013 12:55'! host: anObject index: index ^ (self host: anObject) index: index! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:30'! testBecomeHash | a b c d ha hb | a := 'ab' copy. b := 'cd' copy. c := a. d := b. ha := a hash. hb := b hash. a become: b. self assert: a hash = hb; assert: b hash = ha; assert: c hash = hb; assert: d hash = ha. ! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:28'! testBecomeForward "Test the forward become." | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a becomeForward: b. self assert: a = 'cd'; assert: b = 'cd'; assert: c = 'cd'; assert: d = 'cd'. ! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:29'! testBecomeForwardHash | a b c hb | a := 'ab' copy. b := 'cd' copy. c := a. hb := b hash. a becomeForward: b. self assert: a hash = hb; assert: b hash = hb; assert: c hash = hb. ! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:27'! testBecomeForwardIdentityHash "Check that 1. the argument to becomeForward: is modified to have the receiver's identity hash. 2. the receiver's identity hash is unchanged." | a b ha | a := 'ab' copy. b := 'cd' copy. ha := a identityHash. a becomeForward: b. self assert: a identityHash = ha; assert: b identityHash = ha. ! ! !BecomeTest methodsFor: 'testing' stamp: 'MartinDias 7/1/2013 15:09'! testBecomeForwardDontCopyIdentityHash "Check that 1. the argument to becomeForward: is NOT modified to have the receiver's identity hash. 2. the receiver's identity hash is unchanged." | a b identityHashOfB | a := 'ab' copy. b := 'cd' copy. identityHashOfB := b identityHash. a becomeForward: b copyHash: false. self assert: a == b; assert: a identityHash = identityHashOfB; assert: b identityHash = identityHashOfB. ! ! !BecomeTest methodsFor: 'testing' stamp: 'MartinDias 7/1/2013 15:09'! testBecomeForwardCopyIdentityHash "Check that 1. the argument to becomeForward: IS modified to have the sender's identity hash. 2. the sender's identity hash is unchanged." | a b identityHashOfA | a := 'ab' copy. b := 'cd' copy. identityHashOfA := a identityHash. a becomeForward: b copyHash: true. self assert: a == b; assert: a identityHash = identityHashOfA; assert: b identityHash = identityHashOfA. ! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:31'! testBecomeIdentityHash "Note. The identity hash of both objects seems to change after the become:" | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a become: b. self assert: a identityHash = c identityHash; assert: b identityHash = d identityHash; deny: a identityHash = b identityHash. ! ! !BecomeTest methodsFor: 'testing' stamp: 'brp 9/19/2003 15:28'! testBecome "Test the two way become. Note. we cannot use string literals for this test" | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a become: b. self assert: a = 'cd'; assert: b = 'ab'; assert: c = 'cd'; assert: d = 'ab'. ! ! !Beeper commentStamp: 'gk 2/26/2004 22:44'! Beeper provides simple audio (or in some other way) feedback to the user. The recommended use is "Beeper beep" to give the user the equivalence of a beep. If you want to force the beep to use the primitive in the VM for beeping, then use "Beeper beepPrimitive". In either case, if sounds are disabled there will be no beep. The actual beeping, when you use "Beeper beep", is done by sending a #play message to a registered playable object. You can register your own playable object by invoking the class side method #setDefault: passing in an object that responds to the #play message. The default playable object is an instance of Beeper itself which implements #play on the instance side. That implementation delegates the playing of the beep to the default SoundService. Note that #play is introduced as a common interface between AbstractSound and Beeper. This way we can register instances of AbstractSound as playable entities, for example: Beeper setDefault: (SampledSound new setSamples: self coffeeCupClink samplingRate: 12000). Then "Beeper beep" will play the coffeeCup sound.! !Beeper methodsFor: 'play interface' stamp: 'CamilloBruni 5/8/2013 11:41'! play "This is how the default Beeper makes a beep, by sending beep to the default sound service. The sound system will check if sounds are enabled." (#SoundService asClassIfAbsent: [ ^ self ]) default new beep! ! !Beeper class methodsFor: 'customize' stamp: ''! setDefault: aPlayableEntity "Set the playable entity used when making a beep. The playable entity should implement the message #play." default := aPlayableEntity! ! !Beeper class methodsFor: 'customize' stamp: ''! clearDefault "Clear the default playable. Will be lazily initialized in Beeper class >>default." default := nil! ! !Beeper class methodsFor: 'customize' stamp: 'ClementBera 7/26/2013 16:12'! default "When the default is not defined it is initialized using #newDefault." ^ default ifNil: [default := self newDefault ] ! ! !Beeper class methodsFor: 'beeping' stamp: ''! beep "The preferred way of producing an audible feedback. The default playable entity (an instance of Beeper) also uses the pluggable SoundService mechanism, so it will use the primitive beep only if there is no other sound mechanism available." self default ifNil: [self beepPrimitive] ifNotNil: [ self default play]. ! ! !Beeper class methodsFor: 'private' stamp: ''! primitiveBeep "Make a primitive beep. Not to be called directly. It is much better to use Beeper class>>beep or Beeper class>>beepPrimitive since this method bypasses the current registered playable entity and does not check SoundSettings class>>soundEnabled." self primitiveFailed! ! !Beeper class methodsFor: 'customize' stamp: ''! newDefault "Subclasses may override me to provide a default beep. This base implementation returns an instance of Beeper which uses the pluggable sound service." ^ self new! ! !Beeper class methodsFor: 'beeping' stamp: 'NorbertHartl 2/19/2014 11:54'! beepPrimitive "Make a primitive beep. Only use this if you want to force this to be a primitive beep. Otherwise use Beeper class>>beep since this method bypasses the current registered playable entity." SoundSystem current soundEnabled ifTrue: [self primitiveBeep]! ! !Behavior commentStamp: 'al 12/8/2005 20:44'! My instances describe the behavior of other objects. I provide the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but I am a good starting point for providing instance-specific behavior (as in Metaclass).! !Behavior methodsFor: 'traits' stamp: ''! noteChangedSelectors: aCollection "Start update of my methodDict (after changes to traits in traitComposition or after a local method was removed from my methodDict). The argument is a collection of method selectors that may have been changed. Most of the time aCollection only holds one selector. But when there are aliases involved there may be several method changes that have to be propagated to users." | affectedSelectors | affectedSelectors := IdentitySet new. aCollection do: [:selector | affectedSelectors addAll: (self updateMethodDictionarySelector: selector)]. self notifyUsersOfChangedSelectors: affectedSelectors. ^ affectedSelectors! ! !Behavior methodsFor: 'enumerating' stamp: ''! allUnreferencedInstanceVariables "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" ^ self allInstVarNames reject: [:ivn | | definingClass | definingClass := self classThatDefinesInstanceVariable: ivn. definingClass withAllSubclasses anySatisfy: [:class | (class whichSelectorsAccess: ivn asSymbol) notEmpty]]! ! !Behavior methodsFor: 'private' stamp: ''! becomeCompact "Make me compact. This means: - find a free slot in 'Smalltalk compactClassArray' - add me in that array - update my format with the index - update my instances " self classBuilder becomeCompact: self! ! !Behavior methodsFor: 'testing' stamp: ''! isObsolete "Return true if the receiver is obsolete." ^self instanceCount = 0! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! methodDictionary ^self methodDict! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! compiledMethodAt: selector ifAbsent: aBlock "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock" ^ self methodDict at: selector ifAbsent: aBlock! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: ''! allSuperclassesIncluding: aClass "Answer an OrderedCollection of the receiver's and the receiver's ancestor's superclasses up to aClass included. If aClass is not part of the receiver's superclass, returns up to the root." | temp | self class == ProtoObject class ifTrue: [ ^ OrderedCollection new]. ^ self superclass == aClass ifTrue: [ OrderedCollection with: aClass] ifFalse: [temp := self superclass allSuperclassesIncluding: aClass. temp addFirst: self superclass. temp]! ! !Behavior methodsFor: 'queries' stamp: ''! copiesFromSuperclass: method "Checks whether the receiver copied the argument, method, from its superclasses" self allSuperclassesDo: [ :cls| (cls includesSelector: method selector) ifTrue: [ ^ (cls >> method selector) sourceCode = method sourceCode]]. ^ false! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! whichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal." | who | who := IdentitySet new. self selectorsAndMethodsDo: [:sel :method | ((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [((literal isVariableBinding) not or: [method literals allButLast includes: literal]) ifTrue: [who add: sel]]]. ^ who! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! supermostPrecodeCommentFor: selector "Answer a string representing the precode comment in the most distant superclass's implementation of the selector. Return nil if none found." | aSuper superComment | (self == Behavior or: [self superclass == nil or: [(aSuper := self superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: ["There is a super implementor" superComment := aSuper supermostPrecodeCommentFor: selector]. ^ superComment ifNil: [self firstPrecodeCommentFor: selector "ActorState supermostPrecodeCommentFor: #printOn:"]! ! !Behavior methodsFor: 'initialization' stamp: ''! emptyMethodDictionary ^ MethodDictionary new! ! !Behavior methodsFor: 'user interface' stamp: ''! withAllSubAndSuperclassesDo: aBlock self withAllSubclassesDo: aBlock. self allSuperclassesDo: aBlock. ! ! !Behavior methodsFor: 'queries' stamp: ''! copiedFromSuperclass: method "Returns the methods that the receiver copied with its ancestors" self allSuperclassesDo: [ :cls| (cls includesSelector: method selector) ifTrue: [ ((cls >> method selector) sourceCode = method sourceCode) ifTrue: [ ^ {cls >> method selector}] ifFalse: [ ^ #()]]]. ^ #(). ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! localSelectors: aSet self basicLocalSelectors: aSet! ! !Behavior methodsFor: 'queries' stamp: ''! whichSelectorsRead: aString | index | index := self instVarIndexFor: aString ifAbsent: [ ^ IdentitySet new ]. ^ self selectors select: [ :each | (self compiledMethodAt: each) readsField: index ]! ! !Behavior methodsFor: 'initialization' stamp: ''! initialize "moved here from the class side's #new" super initialize. self superclass: Object. "no longer sending any messages, some of them crash the VM" self methodDict: self emptyMethodDictionary. self setFormat: Object format. self traitComposition: nil. self users: IdentitySet new.! ! !Behavior methodsFor: 'system startup' stamp: ''! startUp "This message is sent to registered classes when the system is coming up." ! ! !Behavior methodsFor: 'testing' stamp: ''! isPointers "Answer whether the receiver contains just pointers (not bits)." ^self isBits not! ! !Behavior methodsFor: 'testing' stamp: 'SebastianTleye 7/16/2013 17:04'! instSize "Answer the number of named instance variables (as opposed to indexed variables) of the receiver." self flag: #instSizeChange. "Smalltalk browseAllCallsOn: #instSizeChange" " NOTE: This code supports the backward-compatible extension to 8 bits of instSize. When we revise the image format, it should become... ^ ((format bitShift: -1) bitAnd: 16rFF) - 1 Note also that every other method in this category will require 2 bits more of right shift after the change. " ^ ((self format bitShift: -10) bitAnd: 16rC0) + ((self format bitShift: -1) bitAnd: 16r3F) - 1! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: ''! evaluate: aString ^self compiler evaluate: aString! ! !Behavior methodsFor: 'traits' stamp: ''! setTraitComposition: aTraitComposition | oldComposition | (self hasTraitComposition not and: [aTraitComposition isEmpty]) ifTrue: [^self]. aTraitComposition assertValidUser: self. oldComposition := self traitComposition. self traitComposition: aTraitComposition. self applyChangesOfNewTraitCompositionReplacing: oldComposition. oldComposition traits do: [:each | each removeUser: self]. aTraitComposition traits do: [:each | each addUser: self]! ! !Behavior methodsFor: '*ast-core' stamp: ''! parseTreeFor: aSymbol ^ RBParser parseMethod: (self sourceCodeAt: aSymbol) onError: [ :msg :pos | ^ nil ]! ! !Behavior methodsFor: 'private' stamp: ''! becomeCompactSimplyAt: index "The same as #becomeCompact but without updating my instances." self classBuilder becomeCompact: self simplyAt: index! ! !Behavior methodsFor: 'adding/removing methods' stamp: ''! addSelector: selector withMethod: compiledMethod notifying: requestor ^ self addSelectorSilently: selector withMethod: compiledMethod! ! !Behavior methodsFor: '*System-Support' stamp: ''! referencedClasses "Return the set of classes that are directly referenced by my methods" | answer | answer := Set new. self methods do: [ :cm | answer addAll: ( cm literals select: [ :l | l isKindOf: Association ] thenCollect: #value ) ]. ^ answer! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: ''! allSuperclasses "Answer an OrderedCollection of the receiver's and the receiver's ancestor's superclasses. The first element is the receiver's immediate superclass, followed by its superclass; the last element is Object." | temp | ^ self superclass == nil ifTrue: [ OrderedCollection new] ifFalse: [temp := self superclass allSuperclasses. temp addFirst: self superclass. temp]! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: ''! sourceCodeTemplate "Answer an expression to be edited and evaluated in order to define methods in this class or trait." ^'message selector and argument names "comment stating purpose of message" | temporary variable names | statements'! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: ''! recompileChanges "Compile all the methods that are in the changes file. This validates sourceCode and variable references and forces methods to use the current bytecode set" self selectorsAndMethodsDo: [:sel :meth | meth fileIndex > 1 ifTrue: [self recompile: sel from: self]]! ! !Behavior methodsFor: 'testing' stamp: ''! isBits "Answer whether the receiver contains just bits (not pointers)." ^ self instSpec >= 6! ! !Behavior methodsFor: 'accessing instances and variables' stamp: ''! instanceCount "Answer the number of instances of the receiver that are currently in use." | count | count := 0. self allInstancesDo: [:x | count := count + 1]. ^count! ! !Behavior methodsFor: 'queries' stamp: ''! whichSuperclassSatisfies: aBlock (aBlock value: self) ifTrue: [^self]. ^self superclass ifNotNil: [self superclass whichSuperclassSatisfies: aBlock]! ! !Behavior methodsFor: 'traits' stamp: ''! removeFromComposition: aTrait self setTraitComposition: (self traitComposition copyTraitExpression removeFromComposition: aTrait)! ! !Behavior methodsFor: 'traits' stamp: ''! purgeLocalSelectors self basicLocalSelectors: nil! ! !Behavior methodsFor: 'accessing' stamp: ''! format "Answer an Integer that encodes the kinds and numbers of variables of instances of the receiver." ^format! ! !Behavior methodsFor: 'enumerating' stamp: ''! allSubclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's subclasses." self subclassesDo: [:cl | aBlock value: cl. cl allSubclassesDo: aBlock]! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! isDisabledSelector: selector ^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]! ! !Behavior methodsFor: 'accessing' stamp: ''! numberOfInstanceVariables ^ self instVarNames size ! ! !Behavior methodsFor: 'enumerating' stamp: ''! allSubInstancesDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver and all its subclasses." self allInstancesDo: aBlock. self allSubclassesDo: [:sub | sub allInstancesDo: aBlock]! ! !Behavior methodsFor: '*Ring-Core-Kernel' stamp: ''! methodsInProtocol: aString ^ (self organization listAtCategoryNamed: aString) collect: [ :each | (self compiledMethodAt: each) ]! ! !Behavior methodsFor: 'queries' stamp: ''! whichClassDefinesClassVar: aString Symbol hasInterned: aString ifTrue: [ :aSymbol | ^self whichSuperclassSatisfies: [:aClass | aClass classVarNames anySatisfy: [:each | each = aSymbol]]]. ^#()! ! !Behavior methodsFor: 'testing' stamp: ''! isAnonymous ^true! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! changeRecordsAt: selector "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" ^ChangeSet scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) class: self meta: self isMeta category: (self whichCategoryIncludesSelector: selector) selector: selector.! ! !Behavior methodsFor: 'instance creation' stamp: 'SebastianTleye 7/17/2013 10:06'! basicNew "Primitive. Answer an instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable. Essential. See Object documentation whatIsAPrimitive." self isVariable ifTrue: [ ^ self basicNew: 0 ]. "space must be low" OutOfMemory signal. ^ self basicNew "retry if user proceeds"! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: ''! compileAllFrom: oldClass "Compile all the methods in the receiver's method dictionary. This validates sourceCode and variable references and forces all methods to use the current bytecode set" oldClass localSelectors do: [:sel | self recompile: sel from: oldClass]. ! ! !Behavior methodsFor: 'system startup' stamp: ''! shutDown "This message is sent on system shutdown to registered classes" ! ! !Behavior methodsFor: 'adding/removing methods' stamp: ''! removeSelectorSilently: selector "Remove selector without sending system change notifications" ^ SystemAnnouncer uniqueInstance suspendAllWhile: [self removeSelector: selector].! ! !Behavior methodsFor: 'traits' stamp: ''! hasTraitComposition ^ self traitComposition notEmpty.! ! !Behavior methodsFor: 'adding/removing methods' stamp: ''! adoptInstance: anInstance "Change the class of anInstance to me. Primitive (found in Cog and new VMs) follows the same rules as primitiveChangeClassTo:, but returns the class rather than the modified instance" anInstance primitiveChangeClassTo: self basicNew. ^self! ! !Behavior methodsFor: 'accessing instances and variables' stamp: ''! allSubInstances "Answer a list of all current instances of the receiver and all of its subclasses." | aCollection | aCollection := OrderedCollection new. self allSubInstancesDo: [:x | x == aCollection ifFalse: [aCollection add: x]]. ^ aCollection! ! !Behavior methodsFor: 'printing' stamp: ''! printHierarchy "Answer a description containing the names and instance variable names of all of the subclasses and superclasses of the receiver." | aStream index | index := 0. aStream := (String new: 16) writeStream. self allSuperclasses reverseDo: [:aClass | aStream crtab: index. index := index + 1. aStream nextPutAll: aClass name. aStream space. aStream print: aClass instVarNames]. aStream cr. self printSubclassesOn: aStream level: index. ^aStream contents! ! !Behavior methodsFor: 'enumerating' stamp: ''! allSuperclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's superclasses." self superclass == nil ifFalse: [aBlock value: self superclass. self superclass allSuperclassesDo: aBlock]! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! hasMethods "Answer whether the receiver has any methods in its method dictionary." ^ self methodDict notEmpty! ! !Behavior methodsFor: '*Deprecated30' stamp: ''! parserClass self deprecated: 'use #compilerClass' on: '29 April 2013' in: 'Pharo 3.0'. ^self compilerClass! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! includesSelector: aSymbol "Answer whether the message whose selector is the argument is in the method dictionary of the receiver's class." ^ self methodDict includesKey: aSymbol! ! !Behavior methodsFor: '*System-Support' stamp: ''! allUnsentMessages "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system." ^ SystemNavigation new allUnsentMessagesIn: self selectors! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: ''! compileAll ^ self compileAllFrom: self! ! !Behavior methodsFor: 'traits' stamp: ''! addTraitSelector: aSymbol withMethod: aCompiledMethod "Add aMethod with selector aSymbol to my methodDict. aMethod must not be defined locally." | source method | [(self includesLocalSelector: aSymbol) not] assert. self ensureLocalSelectors. source := aCompiledMethod getSourceReplacingSelectorWith: aSymbol. method := self compiler source: source; category: aCompiledMethod category; failBlock: [ ^nil ]; compile. method putSource: source inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr]. self isTrait ifFalse: [ method properties at: #traitSource put: aCompiledMethod]. self basicAddSelector: aSymbol withMethod: method! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! deregisterLocalSelector: aSymbol self basicLocalSelectors notNil ifTrue: [ self basicLocalSelectors remove: aSymbol ifAbsent: []]! ! !Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:36'! traitComposition self subclassResponsibility! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! canPerform: selector "Answer whether the receiver can safely perform to the message whose selector is the argument: it is not an abstract or cancelled method" ^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].! ! !Behavior methodsFor: 'enumerating' stamp: ''! allInstancesDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver. Because aBlock might change the class of inst (for example, using become:), it is essential to compute next before aBlock value: inst." | inst next | inst := self someInstance. [inst == nil] whileFalse: [ next := inst nextInstance. aBlock value: inst. inst := next]! ! !Behavior methodsFor: 'accessing instances and variables' stamp: ''! allInstVarNames "Answer an Array of the names of the receiver's instance variables. The Array ordering is the order in which the variables are stored and accessed by the interpreter." | vars | self superclass == nil ifTrue: [vars := self instVarNames copy] "Guarantee a copy is answered." ifFalse: [vars := self superclass allInstVarNames , self instVarNames]. ^vars! ! !Behavior methodsFor: 'private' stamp: 'sd 11/19/2004 15:13'! setFormat: aFormatInstanceDescription "only use this method with extreme care since it modifies the format of the class ie a description of the number of instance variables and whether the class is compact, variable sized" format := aFormatInstanceDescription ! ! !Behavior methodsFor: 'dependencies' stamp: ''! dependentClasses "Return the list of classes used myself" "Morph dependentClasses" | cll | cll := Set new. "A class depends on its superclass" self superclass ifNotNil: [ cll add: self superclass ]. "We unify a class and its metaclass" (self methods, self class methods) do: [ :m | m literalsDo: [ :l | "We also check if the method is not an extension" ((((l isVariableBinding and: [ l value notNil ]) and: [ l value isBehavior ]) and: [ m category notEmpty ] ) and: [ m category first ~= $* ]) ifTrue: [ cll add: l value ] ] ]. ^ cll asArray! ! !Behavior methodsFor: 'queries' stamp: ''! copiesMethodsFromSuperclass "Checks whether the receiver copied some method from its superclass" self methodsDo: [ :method| (self copiesFromSuperclass: method) ifTrue: [ ^ true ]]. ^ false! ! !Behavior methodsFor: 'accessing instances and variables' stamp: ''! allSharedPools "Answer an ordered collection of the shared pools that the receiver and the receiver's ancestors share." ^self superclass allSharedPools! ! !Behavior methodsFor: 'printing' stamp: ''! literalScannedAs: scannedLiteral notifying: requestor "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). If scannedLiteral is not an association, answer it. Else, if it is of the form: nil->#NameOfMetaclass answer nil->theMetaclass, if any has that name, else report an error. Else, if it is of the form: #NameOfGlobalVariable->anythiEng answer the global, class, or pool association with that nameE, if any, else add it to Undeclared a answer the new Association." | key value | (scannedLiteral isVariableBinding) ifFalse: [^ scannedLiteral]. key := scannedLiteral key. value := scannedLiteral value. key ifNil: "###" [(self bindingOf: value) ifNotNil:[:assoc| (assoc value isKindOf: Behavior) ifTrue: [^ nil->assoc value class]]. requestor notify: 'No such metaclass'. ^false]. (key isSymbol) ifTrue: "##" [(self bindingOf: key) ifNotNil:[:assoc | ^assoc]. Undeclared at: key put: nil. ^Undeclared bindingOf: key]. requestor notify: '## must be followed by a non-local variable name'. ^false " Form literalScannedAs: 14 notifying: nil 14 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form Form literalScannedAs: ##Form notifying: nil Form->Form Form literalScannedAs: ###Form notifying: nil nilE->Form class "! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: ''! superclass "Answer the receiver's superclass, a Class." ^superclass! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! compress "Compact the method dictionary of the receiver." self methodDict rehash! ! !Behavior methodsFor: 'traits' stamp: 'SebastianTleye 7/4/2013 11:04'! users "Compatibility purposes" ^IdentitySet new.! ! !Behavior methodsFor: '*NativeBoost-Core' stamp: 'Igor.Stasenko 9/28/2010 08:03'! externalTypeAlias: aTypeName "override, if you want to introduce type aliases. Answering nil means no type alias for given type name exists" ^ nil! ! !Behavior methodsFor: 'traits' stamp: ''! classesComposedWithMe self isTrait ifTrue: [ ^self users gather: [:u | u classesComposedWithMe]] ifFalse: [ ^{self} ].! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! commentsIn: sourceString | commentStart nextQuotePos someComments aPos | ('*"*' match: sourceString) ifFalse: [^#()]. someComments:= OrderedCollection new. sourceString size = 0 ifTrue: [^ someComments]. aPos:=1. nextQuotePos:= 0. [commentStart := sourceString findString: '"' startingAt: aPos. nextQuotePos:= self nextQuotePosIn: sourceString startingFrom: commentStart. (commentStart ~= 0 and: [nextQuotePos >commentStart])] whileTrue: [ commentStart ~= nextQuotePos ifTrue: [ someComments add: ((sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"').]. aPos := nextQuotePos+1]. ^someComments! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! allSelectors "Answer all selectors understood by instances of the receiver" ^ self allSelectorsBelow: nil! ! !Behavior methodsFor: 'accessing instances and variables' stamp: ''! subclassInstVarNames "Answer a Set of the names of the receiver's subclasses' instance variables." | vars | vars := Set new. self allSubclasses do: [:aSubclass | vars addAll: aSubclass instVarNames]. ^vars! ! !Behavior methodsFor: '*System-Support' stamp: ''! allCallsOn "Answer a SortedCollection of all the methods that refer to me by name or as part of an association in a global dict." ^ (self allCallsOnIn: self systemNavigation)! ! !Behavior methodsFor: 'traits' stamp: 'SebastianTleye 7/17/2013 13:13'! traitComposition: aTraitComposition "Compatibility purposes"! ! !Behavior methodsFor: 'traits' stamp: ''! addUser: aClassOrTrait self users add: aClassOrTrait.! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! classBindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver's class" ^self bindingOf: varName! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! zapAllMethods "Remove all methods in this class which is assumed to be obsolete" self methodDict: self emptyMethodDictionary. self class isMeta ifTrue: [self class zapAllMethods]! ! !Behavior methodsFor: 'printing' stamp: ''! longPrintOn: aStream "Append to the argument, aStream, the names and values of all of the receiver's instance variables. But, not useful for a class with a method dictionary." aStream nextPutAll: '<>'; cr.! ! !Behavior methodsFor: 'accessing instances and variables' stamp: ''! allInstances "Answer a collection of all current instances of the receiver." | all inst next | all := OrderedCollection new. inst := self someInstance. [inst == nil] whileFalse: [ next := inst nextInstance. inst == all ifFalse: [all add: inst]. inst := next]. ^ all asArray! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! methodsDo: aBlock "Evaluate aBlock for all the compiled methods in my method dictionary." ^ self methodDict valuesDo: aBlock! ! !Behavior methodsFor: 'compiling' stamp: ''! instVarNamesAndOffsetsDo: aBinaryBlock "This is part of the interface between the compiler and a class's instance or field names. The class should enumerate aBinaryBlock with the instance variable name strings and their integer offsets. The order is important. Names evaluated later will override the same names occurring earlier." "Nothing to do here; ClassDescription introduces named instance variables" ^self! ! !Behavior methodsFor: 'system startup' stamp: ''! startUp: resuming "This message is sent to registered classes when the system is coming up." ^self startUp! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! commentsAt: selector "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." ^self commentsIn: (self sourceCodeAt: selector) asString. "Behavior commentsAt: #commentsAt:"! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! removeSelector: aSelector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method. If the method to remove will be replaced by a method from my trait composition, the current method does not have to be removed because we mark it as non-local. If it is not identical to the actual method from the trait it will be replaced automatically by #noteChangedSelectors:. This is useful to avoid bootstrapping problems when moving methods to a trait (e.g., from TBehavior to TMethodDictionaryBehavior). Manual moving (implementing the method in the trait and then remove it from the class) does not work if the methods themselves are used for this process (such as compiledMethodAt:, includesLocalSelector: or addTraitSelector:withMethod:)" | changeFromLocalToTraitMethod | changeFromLocalToTraitMethod := (self includesLocalSelector: aSelector) and: [self hasTraitComposition and: [self traitComposition includesMethod: aSelector]]. changeFromLocalToTraitMethod ifFalse: [self basicRemoveSelector: aSelector] ifTrue: [self ensureLocalSelectors]. self deregisterLocalSelector: aSelector. self noteChangedSelectors: (Array with: aSelector). self isTrait ifTrue: [ self notifyUsersOfChangedSelector: aSelector].! ! !Behavior methodsFor: 'initialization' stamp: ''! obsolete "Invalidate and recycle local methods, e.g., zap the method dictionary if can be done safely." self canZapMethodDictionary ifTrue: [self methodDict: self emptyMethodDictionary]. self hasTraitComposition ifTrue: [ self traitComposition traits do: [:each | each removeUser: self]]! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: ''! recompile self compileAll! ! !Behavior methodsFor: '*System-Support' stamp: ''! allCallsOnIn: aSystemNavigation "Answer a SortedCollection of all the methods that refer to me by name or as part of an association in a global dict." ^ (aSystemNavigation allReferencesTo: (self environment associationAt: self theNonMetaClass name)), (aSystemNavigation allCallsOn: self theNonMetaClass name) ! ! !Behavior methodsFor: '*Slot' stamp: 'SebastianTleye 7/17/2013 11:42'! layout ^ layout! ! !Behavior methodsFor: 'accessing' stamp: ''! classDepth self superclass ifNil: [^ 1]. ^ self superclass classDepth + 1! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! isLocalAliasSelector: aSymbol "Return true if the selector aSymbol is an alias defined in my trait composition." ^(self includesLocalSelector: aSymbol) not and: [self hasTraitComposition and: [self traitComposition isLocalAliasSelector: aSymbol]]! ! !Behavior methodsFor: 'compiling' stamp: ''! variablesAndOffsetsDo: aBinaryBlock "This is the interface between the compiler and a class's instance or field names. The class should enumerate aBinaryBlock with the field definitions (with nil offsets) followed by the instance variable name strings and their integer offsets (1-relative). The order is important; names evaluated later will override the same names occurring earlier." "Only need to do instance variables here. CProtoObject introduces field definitions." self instVarNamesAndOffsetsDo: aBinaryBlock! ! !Behavior methodsFor: 'copying' stamp: ''! postCopy super postCopy. self methodDict: self copyOfMethodDictionary! ! !Behavior methodsFor: 'testing' stamp: ''! sourceMatchesBytecodeAt: selector "Answers true if the source code at the selector compiles to the bytecode at the selector, and false otherwise. Implemented to detect an error where Monticello did not recompile sources when the class shape changed" "This code was copied from #recompile:from:, with few changes. Several methods would benefit from a method which turned a selector and class into a CompiledMethod, without installing it into the methodDictionary" | method newMethod | method := self compiledMethodAt: selector. newMethod := self compiler source: (self sourceCodeAt: selector); class: self; failBlock: [^ false]; compiledMethodTrailer: method trailer; compile. "Assume OK after proceed from SyntaxError" selector == newMethod selector ifFalse: [self error: 'selector changed!!!!']. ^ newMethod = method! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'ClementBera 9/27/2013 17:41'! superclass: aClass "Change the receiver's superclass to be aClass." "Note: Do not use 'aClass isKindOf: Behavior' here in case we recompile from Behavior itself." (aClass isNil or: [aClass isBehavior]) ifTrue: [superclass := aClass. Object flushCache] ifFalse: [self error: 'superclass must be a class-describing object']! ! !Behavior methodsFor: 'traits' stamp: 'SebastianTleye 7/4/2013 11:06'! users: aCollection "Compatibility purposes"! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! compiledMethodAt: selector ifPresent: anotherBlock ifAbsent: aBlock "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock" ^ self methodDict at: selector ifPresent: anotherBlock ifAbsent: aBlock! ! !Behavior methodsFor: 'traits' stamp: ''! traitTransformations ^ self traitComposition transformations ! ! !Behavior methodsFor: 'private' stamp: ''! checkCanBeUncompact "Certain classes cannot be uncompacted in CogVM.  If you download VMMaker and see the VM code, these are as defined by StackInterpreter>>#checkAssumedCompactClasses and the ones that can't be uncompacted are the following: " ({ Array. LargeNegativeInteger. LargePositiveInteger. Float. MethodContext } includes: self) ifTrue: [ self error: 'Class ', self name, ' cannot be uncompact. ' ] ! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! canUnderstand: selector "Answer whether the receiver can respond to the message whose selector is the argument." ^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].! ! !Behavior methodsFor: 'obsolete subclasses' stamp: ''! obsoleteSubclasses "Return all the weakly remembered obsolete subclasses of the receiver" | obs | obs := self basicObsoleteSubclasses at: self ifAbsent: [^ #()]. ^ obs copyWithout: nil! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! firstPrecodeCommentFor: selector "If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil" | method | "Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:" (#(Comment Definition Hierarchy) includes: selector) ifTrue: [^ nil]. method := self compiledMethodAt: selector asSymbol ifAbsent: [^ nil]. ^method ast firstPrecodeComment. ! ! !Behavior methodsFor: 'enumerating' stamp: ''! withAllSuperclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's superclasses." aBlock value: self. self superclass == nil ifFalse: [self superclass withAllSuperclassesDo: aBlock]! ! !Behavior methodsFor: 'traits' stamp: ''! flattenDown: aTrait | selectors | [self hasTraitComposition and: [self traitComposition allTraits includes: aTrait]] assert. selectors := (self traitComposition transformationOfTrait: aTrait) selectors. self basicLocalSelectors: self basicLocalSelectors , selectors. self removeFromComposition: aTrait.! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! allSelectorsAbove ^ self allSelectorsAboveUntil: ProtoObject ! ! !Behavior methodsFor: 'accessing instances and variables' stamp: ''! someInstance "Primitive. Answer the first instance in the enumeration of all instances of the receiver. Fails if there are none. Essential. See Object documentation whatIsAPrimitive." ^nil! ! !Behavior methodsFor: 'testing' stamp: ''! isCompact ^self indexIfCompact ~= 0! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! ultimateSourceCodeAt: selector ifAbsent: aBlock "Return the source code at selector, deferring to superclass if necessary" ^ self sourceCodeAt: selector ifAbsent: [self superclass ifNil: [aBlock value] ifNotNil: [self superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! ! !Behavior methodsFor: 'copying' stamp: ''! deepCopy "Classes should only be shallowCopied or made anew." ^ self shallowCopy! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! methodDictionary: aDictionary self methodDict: aDictionary! ! !Behavior methodsFor: 'testing' stamp: ''! isMeta ^ false! ! !Behavior methodsFor: 'enumerating' stamp: ''! withAllSuperAndSubclassesDo: aBlock self allSuperclassesDo: aBlock. aBlock value: self. self allSubclassesDo: aBlock! ! !Behavior methodsFor: 'accessing' stamp: ''! isComposedBy: aTrait "Answers if this object includes trait aTrait into its composition" aTrait isTrait ifFalse: [ ^false]. ^self hasTraitComposition ifTrue: [ self traitComposition includesTrait: aTrait ] ifFalse: [ false ]! ! !Behavior methodsFor: 'testing' stamp: ''! canZapMethodDictionary "Return true if it is safe to zap the method dictionary on #obsolete" ^true! ! !Behavior methodsFor: '*Tools-Inspector' stamp: ''! browseHierarchy self systemNavigation browseHierarchy: self! ! !Behavior methodsFor: 'traits' stamp: ''! flattenDownAllTraits self traitComposition allTraits do: [:each | self flattenDown: each]. [ self traitComposition isEmpty ] assert. self traitComposition: nil.! ! !Behavior methodsFor: '*Refactoring-Environment' stamp: ''! asEnvironment ^ RBClassEnvironment class: self! ! !Behavior methodsFor: 'instance creation' stamp: ''! new "Answer a new initialized instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable." ^ self basicNew initialize ! ! !Behavior methodsFor: 'adding/removing methods' stamp: ''! addSelectorSilently: selector withMethod: compiledMethod self methodDictAddSelectorSilently: selector withMethod: compiledMethod. self registerLocalSelector: selector. self isTrait ifTrue: [ self notifyUsersOfChangedSelector: selector].! ! !Behavior methodsFor: 'enumerating' stamp: ''! selectSubclasses: aBlock "Evaluate the argument, aBlock, with each of the receiver's (next level) subclasses as its argument. Collect into a Set only those subclasses for which aBlock evaluates to true. In addition, evaluate aBlock for the subclasses of each of these successful subclasses and collect into the set those for which aBlock evaluates true. Answer the resulting set." | aSet | aSet := Set new. self allSubclasses do: [:aSubclass | (aBlock value: aSubclass) ifTrue: [aSet add: aSubclass]]. ^aSet! ! !Behavior methodsFor: 'traits' stamp: ''! setTraitCompositionFrom: aTraitExpression ^ self setTraitComposition: aTraitExpression asTraitComposition! ! !Behavior methodsFor: 'instance creation' stamp: ''! new: sizeRequested "Answer an initialized instance of this class with the number of indexable variables specified by the argument, sizeRequested." ^ (self basicNew: sizeRequested) initialize ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! allSelectorsWithout: behaviors "Returns all the selectors of the receiver and its superclasses, except the ones define in behaviors" | selectors | selectors := IdentitySet new. self withAllSuperclassesDo: [ :class | (behaviors includes: class) ifFalse: [ selectors addAll: class selectors ] ]. ^ selectors! ! !Behavior methodsFor: '*Fuel' stamp: ''! fuelNew: sizeRequested "Answer an instance of mine in which serialized references will be injected." ^ self basicNew: sizeRequested! ! !Behavior methodsFor: '*Deprecated30' stamp: ''! compile: code classified: category notifying: requestor trailer: bytes ifFail: aBlock self deprecated: 'please use the compiler API directly' on: '5 September 2013' in: 'Pharo 3'. ^ self compiler source: code; requestor: requestor; category: category; failBlock: aBlock; compiledMethodTrailer: bytes; compile. ! ! !Behavior methodsFor: 'obsolete subclasses' stamp: ''! removeAllObsoleteSubclasses "Remove all the obsolete subclasses of the receiver" self basicObsoleteSubclasses removeKey: self ifAbsent: []. ! ! !Behavior methodsFor: 'testing class hierarchy' stamp: ''! includesBehavior: aClass self isTrait ifTrue: [ ^false ]. ^self == aClass or:[self inheritsFrom: aClass]! ! !Behavior methodsFor: 'accessing instances and variables' stamp: ''! instVarNames "Answer an Array of the instance variable names. Behaviors must make up fake local instance variable names because Behaviors have instance variables for the purpose of compiling methods, but these are not named instance variables." | mySize superSize | mySize := self instSize. superSize := self superclass == nil ifTrue: [0] ifFalse: [self superclass instSize]. mySize = superSize ifTrue: [^#()]. ^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! ! !Behavior methodsFor: 'adding/removing methods' stamp: ''! basicAddSelector: selector withMethod: compiledMethod "Add the message selector with the corresponding compiled method to the receiver's method dictionary. Do this without sending system change notifications" | oldMethodOrNil | oldMethodOrNil := self lookupSelector: selector. self methodDict at: selector put: compiledMethod. compiledMethod methodClass: self. compiledMethod selector: selector. "Now flush Pharo's method cache, either by selector or by method" oldMethodOrNil ifNotNil: [oldMethodOrNil flushCache]. selector flushCache.! ! !Behavior methodsFor: '*GroupManagerUI' stamp: ''! prettyName ^ self printString! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock "Looks up the selector aSymbol in the class chain. If it is found, binaryBlock is evaluated with the class that defines the selector and the associated method. Otherwise absentBlock is evaluated." self withAllSuperclassesDo: [:class | | method | method := class compiledMethodAt: aSymbol ifAbsent: [nil]. method ifNotNil: [^ binaryBlock value: class value: method]. ]. ^ absentBlock value.! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: ''! withAllSubclassesDo: aBlock "Evaluate the argument, aBlock, for the receiver and each of its subclasses." self withAllSubclasses do: [ :subclass | aBlock value: subclass ].! ! !Behavior methodsFor: 'instance creation' stamp: 'SebastianTleye 7/17/2013 10:06'! basicNew: sizeRequested "Primitive. Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. Fail if this class is not indexable or if the argument is not a positive Integer, or if there is not enough memory available. Essential. See Object documentation whatIsAPrimitive." self isVariable ifFalse: [self error: self printString, ' cannot have variable sized instances']. (sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue: ["arg okay; space must be low." OutOfMemory signal. ^ self basicNew: sizeRequested "retry if user proceeds"]. self primitiveFailed! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: ''! compile: code "Compile the argument, code, as source code in the context of the receiver. Create an error notification if the code can not be compiled. The argument is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string." ^self compile: code notifying: nil! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: ''! withAllSubclasses "Answer a Set of the receiver, the receiver's descendent's, and the receiver's descendent's subclasses." ^ self allSubclasses add: self; yourself! ! !Behavior methodsFor: 'queries' stamp: ''! whichSelectorsAssign: instVarName "Answer a Set of selectors whose methods store into the argument, instVarName, as a named instance variable." ^self whichSelectorsStoreInto: instVarName! ! !Behavior methodsFor: 'testing class hierarchy' stamp: ''! kindOfSubclass "Answer a String that is the keyword that describes the receiver's kind of subclass, either a regular subclass, a variableSubclass, a variableByteSubclass, a variableWordSubclass, or a weakSubclass." self isWeak ifTrue: [^ ' weakSubclass: ']. ^ self isVariable ifTrue: [self isBits ifTrue: [self isBytes ifTrue: [ ' variableByteSubclass: '] ifFalse: [ ' variableWordSubclass: ']] ifFalse: [ ' variableSubclass: ']] ifFalse: [ ' subclass: ']! ! !Behavior methodsFor: 'initialize-release' stamp: ''! superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver. Must only be sent to a new instance; else we would need Object flushCache." self superclass: aClass. self setFormat: fmt. self methodDict: mDict. self traitComposition: nil! ! !Behavior methodsFor: '*NativeBoost-Core' stamp: 'Igor.Stasenko 5/18/2010 13:02'! nbBindingOf: aName "answer a binding for a type name, by default use smalltalk name bindings" ^ self bindingOf: aName! ! !Behavior methodsFor: 'queries' stamp: ''! copiedMethodsFromSuperclass "Returns the methods that the receiver copied with its ancestors" | methods | methods := OrderedCollection new. self methodsDo: [ :method| methods addAll: (self copiedFromSuperclass: method)]. ^ methods! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: ''! compile: code notifying: requestor "Compile the argument, code, as source code in the context of the receiver and insEtall the result in the receiver's method dictionary. The second argument, requestor, is to be notified if an error occurs. The argument code is either a string or an object that converts to a string or a PositionableStream. This method also saves the source code." | method | method := self compiler source: code; requestor: requestor; failBlock: [ ^nil ]; compile. method putSource: code inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. self addSelector: method selector withMethod: method notifying: requestor. ^ method selector! ! !Behavior methodsFor: 'adding/removing methods' stamp: ''! addSelector: selector withMethod: compiledMethod ^ self addSelector: selector withMethod: compiledMethod notifying: nil! ! !Behavior methodsFor: '*System-Support' stamp: ''! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." ^ self systemNavigation allCallsOn: aSymbol from: self . ! ! !Behavior methodsFor: 'adding/removing methods' stamp: ''! methodDictAddSelectorSilently: selector withMethod: compiledMethod self basicAddSelector: selector withMethod: compiledMethod! ! !Behavior methodsFor: 'traits' stamp: ''! traitOrClassOfSelector: aSymbol "Return the trait or the class which originally defines the method aSymbol or return self if locally defined or if it is a conflict marker method. This is primarly used by Debugger to determin the behavior in which a recompiled method should be put. If a conflict method is recompiled it should be put into the class, thus return self. Also see TraitComposition>>traitProvidingSelector:" ((self includesLocalSelector: aSymbol) or: [ self hasTraitComposition not]) ifTrue: [^self]. ^(self traitComposition traitProvidingSelector: aSymbol) ifNil: [self]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! methods ^ self methodDict values! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: ''! allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level "Walk the tree of subclasses, giving the class and its level" | subclassNames | classAndLevelBlock value: self value: level. self == Class ifTrue: [^ self]. "Don't visit all the metaclasses" "Visit subclasses in alphabetical order" subclassNames := SortedCollection new. self subclassesDo: [:subC | subclassNames add: subC name]. subclassNames do: [:name | (self environment at: name) allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level+1]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! allSelectorsAboveUntil: aRootClass | coll | coll := IdentitySet new. (self allSuperclassesIncluding: aRootClass) do: [:aClass | aClass selectorsDo: [ :sel | coll add: sel ]]. ^ coll ! ! !Behavior methodsFor: 'obsolete subclasses' stamp: ''! allLocalCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." ^(SystemNavigation new allLocalCallsOn: aSymbol ofClass: (self theNonMetaClass)). ! ! !Behavior methodsFor: '*Ring-Core-Kernel' stamp: ''! protocols ^ self organization categories copy! ! !Behavior methodsFor: 'system startup' stamp: ''! shutDown: quitting "This message is sent on system shutdown to registered classes" ^self shutDown.! ! !Behavior methodsFor: 'accessing' stamp: ''! sharedPoolNames ^ self sharedPools collect: [:ea | self environment keyAtIdentityValue: ea]! ! !Behavior methodsFor: 'private' stamp: ''! flushCache "Tell the interpreter to remove the contents of its method lookup cache, if it has one. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !Behavior methodsFor: 'testing' stamp: 'SebastianTleye 7/4/2013 13:06'! isBehavior "Return true if the receiver is a behavior" ^true! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! sourceCodeAt: selector ^ (self compiledMethodAt: selector) sourceCode.! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! registerLocalSelector: aSymbol self basicLocalSelectors notNil ifTrue: [ self basicLocalSelectors add: aSymbol]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! firstCommentAt: selector "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote." |someComments| someComments := self commentsAt: selector. ^someComments isEmpty ifTrue: [''] ifFalse: [someComments first] "Behavior firstCommentAt: #firstCommentAt:"! ! !Behavior methodsFor: 'traits' stamp: ''! addToComposition: aTrait self setTraitComposition: (self traitComposition copyTraitExpression add: aTrait; yourself)! ! !Behavior methodsFor: 'traits' stamp: ''! applyChangesOfNewTraitCompositionReplacing: oldComposition | changedSelectors | changedSelectors := self traitComposition changedSelectorsComparedTo: oldComposition. changedSelectors isEmpty ifFalse: [ self noteChangedSelectors: changedSelectors]. self traitComposition isEmpty ifTrue: [ self purgeLocalSelectors]. ^changedSelectors! ! !Behavior methodsFor: '*Ring-Core-Kernel' stamp: ''! methodNamed: aSelector ^ self methodDict at: aSelector! ! !Behavior methodsFor: 'testing' stamp: ''! isFixed "Answer whether the receiver does not have a variable (indexable) part." ^self isVariable not! ! !Behavior methodsFor: 'printing' stamp: ''! printOn: aStream "Refer to the comment in Object|printOn:." aStream nextPutAll: 'a descendent of '. self superclass printOn: aStream! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: ''! compilerClass "Answer a compiler class appropriate for source methods of this class." ^Smalltalk compilerClass! ! !Behavior methodsFor: 'traits' stamp: ''! addExclusionOf: aSymbol to: aTrait self setTraitComposition: ( self traitComposition copyWithExclusionOf: aSymbol to: aTrait)! ! !Behavior methodsFor: 'traits' stamp: ''! traitsProvidingSelector: aSymbol | result | result := OrderedCollection new. self hasTraitComposition ifFalse: [^result]. (self traitComposition methodDescriptionsForSelector: aSymbol) do: [:methodDescription | methodDescription selector = aSymbol ifTrue: [ result addAll: (methodDescription locatedMethods collect: [:each | each methodClass])]]. ^result! ! !Behavior methodsFor: 'cleanup' stamp: ''! cleanUp: aggressive "Clean out any caches and other state that should be flushed when trying to get an image into a pristine state. The argument should be used to indicate how aggressive the cleanup should be. Some subclasses may act differently depending on its value - for example, ChangeSet will only delete all unused and reinitialize the current change set if we're asking it to be aggressive." ^self cleanUp! ! !Behavior methodsFor: '*Manifest-Core' stamp: ''! isManifest ^ self name beginsWith: 'Manifest'! ! !Behavior methodsFor: 'traits' stamp: ''! removeUser: aClassOrTrait self users remove: aClassOrTrait ifAbsent: []! ! !Behavior methodsFor: 'testing' stamp: ''! isWeak "Answer whether the receiver has contains weak references." ^ self instSpec = 4! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! selectorsAndMethodsDo: selectorAndMethodBlock "Evaluate selectorAndMethodBlock with two arguments for each selector/method pair in my method dictionary." ^ self methodDict keysAndValuesDo: selectorAndMethodBlock! ! !Behavior methodsFor: '*Deprecated30' stamp: ''! evaluatorClass "Answer an evaluator class appropriate for evaluating expressions in the context of this class." self deprecated: 'use #compilerClass' on: '02 May 2013' in: 'Pharo 3.0'. ^self compilerClass! ! !Behavior methodsFor: 'enumerating' stamp: ''! subclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." self subclasses do: aBlock! ! !Behavior methodsFor: 'traits' stamp: ''! ensureLocalSelectors "Ensures that the instance variable localSelectors is effectively used to maintain the set of local selectors. This method must be called before any non-local selectors are added to the method dictionary!!" self basicLocalSelectors ifNil: [self basicLocalSelectors: self selectors asSet]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! localSelectors "Return a set of selectors defined locally. The instance variable is lazily initialized. If it is nil then there are no non-local selectors" ^ self basicLocalSelectors ifNil: [self selectors asSet] ifNotNil: [self basicLocalSelectors].! ! !Behavior methodsFor: 'printing' stamp: ''! storeLiteral: aCodeLiteral on: aStream "Store aCodeLiteral on aStream, changing an Association to ##GlobalName or ###MetaclassSoleInstanceName format if appropriate" | key value | (aCodeLiteral isVariableBinding) ifFalse: [aCodeLiteral storeOn: aStream. ^self]. key := aCodeLiteral key. (key isNil and: [(value := aCodeLiteral value) isMemberOf: Metaclass]) ifTrue: [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. ^self]. (key isSymbol and: [(self bindingOf: key) notNil]) ifTrue: [aStream nextPutAll: '##'; nextPutAll: key. ^self]. aCodeLiteral storeOn: aStream! ! !Behavior methodsFor: 'accessing' stamp: ''! realClass ^ self! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal. Dives into the compact literal notation, making it slow but thorough " | selectors | selectors := IdentitySet new. self selectorsAndMethodsDo: [ :sel :method | ((self isTrait ifTrue: [method hasLiteralThorough: literal] ifFalse: [method refersToLiteral: literal]) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [selectors add: sel]]. ^ selectors! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: ''! recompile: selector "Compile the method associated with selector in the receiver's method dictionary." ^self recompile: selector from: self! ! !Behavior methodsFor: '*Fuel' stamp: ''! fuelIgnoredInstanceVariableNames "Indicates which variables have to be ignored during serialization." ^#()! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! allSelectorsBelow: topClass | coll | coll := IdentitySet new. self withAllSuperclassesDo: [:aClass | aClass = topClass ifTrue: [^ coll ] ifFalse: [aClass selectorsDo: [ :sel | coll add: sel ]]]. ^ coll ! ! !Behavior methodsFor: 'adding/removing methods' stamp: ''! basicRemoveSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." | oldMethod | oldMethod := self methodDict at: selector ifAbsent: [^ self]. self methodDict removeKey: selector. "Now flush the method cache" oldMethod flushCache. selector flushCache.! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: ''! compiler "Answer a compiler appropriate for source methods of this class." ^self compilerClass new environment: self environment; class: self! ! !Behavior methodsFor: 'user interface' stamp: ''! unreferencedInstanceVariables "Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses." ^ self instVarNames reject: [:ivn | self withAllSubclasses anySatisfy: [:class | (class whichSelectorsAccess: ivn) notEmpty]]! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! 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]]! ! !Behavior methodsFor: 'testing class hierarchy' stamp: ''! inheritsFrom: aClass "Answer whether the argument, aClass, is on the receiver's superclass chain." | aSuperclass | aSuperclass := self superclass. [aSuperclass == nil] whileFalse: [aSuperclass == aClass ifTrue: [^true]. aSuperclass := aSuperclass superclass]. ^false! ! !Behavior methodsFor: 'accessing' stamp: ''! typeOfClass "Answer a symbol uniquely describing the type of the receiver" self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]. "Very special!!" self isBytes ifTrue:[^#bytes]. (self isWords and:[self isPointers not]) ifTrue:[^#words]. self isWeak ifTrue:[^#weak]. self isVariable ifTrue:[^#variable]. ^#normal.! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! allMethods "Return the collection of compiled method I and my superclasses are defining" "asArray is used to not bump into a bug when comparing compiled methods." ^ self allSelectors asArray collect: [ :s | self lookupSelector: s ]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! sourceCodeAt: selector ifAbsent: aBlock ^ (self compiledMethodAt: selector ifAbsent: [^ aBlock value]) sourceCode.! ! !Behavior methodsFor: 'traits' stamp: ''! removeAlias: aSymbol of: aTrait self setTraitComposition: ( self traitComposition copyWithoutAlias: aSymbol of: aTrait)! ! !Behavior methodsFor: 'traits' stamp: ''! traits "Returns a collection of all traits used by the receiver" ^ self traitComposition traits! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! includesLocalSelector: aSymbol ^self basicLocalSelectors ifNil: [self includesSelector: aSymbol] ifNotNil: [self localSelectors includes: aSymbol]! ! !Behavior methodsFor: 'traits' stamp: ''! notifyUsersOfChangedSelector: aSelector self notifyUsersOfChangedSelectors: (Array with: aSelector)! ! !Behavior methodsFor: 'testing' stamp: ''! isBytes "Answer whether the receiver has 8-bit instance variables." ^ self instSpec >= 8! ! !Behavior methodsFor: '*Deprecated30' stamp: ''! decompilerClass self deprecated: 'use #compilerClass' on: '02 May 2013' in: 'Pharo 3.0'. ^ self compilerClass! ! !Behavior methodsFor: 'accessing instances and variables' stamp: ''! allClassVarNames "Answer a Set of the names of the receiver's and the receiver's ancestor's class variables." ^self superclass allClassVarNames! ! !Behavior methodsFor: 'testing' stamp: ''! isVariable "Answer whether the receiver has indexable variables." ^ self instSpec >= 2! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'SebastianTleye 7/5/2013 17:16'! bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" ^self superclass bindingOf: varName! ! !Behavior methodsFor: 'queries' stamp: ''! whichClassDefinesInstVar: aString ^self whichSuperclassSatisfies: [:aClass | aClass instVarNames includes: aString]! ! !Behavior methodsFor: 'testing' stamp: ''! isWords "Answer true if the receiver is made of 32-bit instance variables." ^self isBytes not! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! nextQuotePosIn: sourceString startingFrom: commentStart | pos nextQuotePos | pos := commentStart + 1. [((nextQuotePos := sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)) and: [nextQuotePos ~= 0]] whileTrue: [pos := nextQuotePos + 2]. ^nextQuotePos! ! !Behavior methodsFor: 'traits' stamp: ''! traitCompositionString ^self hasTraitComposition ifTrue: [self traitComposition asString] ifFalse: ['{}']! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! whichSelectorsReferTo: literal "Answer a Set of selectors whose methods access the argument as a literal." | special byte | special := Smalltalk hasSpecialSelector: literal ifTrueSetByte: [:b | byte := b]. ^self whichSelectorsReferTo: literal special: special byte: byte "Rectangle whichSelectorsReferTo: #+."! ! !Behavior methodsFor: '*Tools' stamp: ''! inspectSubInstances "Inspect all instances of the receiver and all its subclasses. CAUTION - don't do this for something as generic as Object!!" | all allSize prefix | all := self allSubInstances. (allSize := all size) isZero ifTrue: [^ self inform: 'There are no instances of ', self name, ' or any of its subclasses']. prefix := allSize = 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! ! !Behavior methodsFor: 'memory usage' stamp: ''! instancesSizeInMemory "Answers the number of bytes consumed by all its instances including their object header" | bytes | bytes := 0. self allInstancesDo: [:each | bytes := bytes + each sizeInMemory ]. ^ bytes! ! !Behavior methodsFor: 'private' stamp: ''! indexIfCompact "If these 5 bits are non-zero, then instances of this class will be compact. It is crucial that there be an entry in Smalltalk compactClassesArray for any class so optimized. See the msgs becomeCompact and becomeUncompact." ^ (self format bitShift: -11) bitAnd: 16r1F " Array indexIfCompact Verify if the compactClassesArray and indexIfCompact are coheren Smalltalk compactClassesArray doWithIndex: [:c :i | c == nil ifFalse: [c indexIfCompact = i ifFalse: [self halt]]] "! ! !Behavior methodsFor: '*Tools' stamp: ''! inspectAllInstances "Inspect all instances of the receiver." | all allSize prefix | all := self allInstances. (allSize := all size) isZero ifTrue: [^ self inform: 'There are no instances of ', self name]. prefix := allSize = 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name)! ! !Behavior methodsFor: 'cleanup' stamp: ''! cleanUp "Clean out any caches and other state that should be flushed when trying to get an image into a pristine state. Subclasses may override #cleanUp: to provide different levels of cleanliness" ! ! !Behavior methodsFor: 'private' stamp: ''! becomeUncompact "The inverse of #becomeCompact. However, some classes can not be uncompact: see #checkCanBeUncompact." self classBuilder becomeUncompact: self! ! !Behavior methodsFor: 'accessing' stamp: ''! binding ^ nil -> self! ! !Behavior methodsFor: 'obsolete subclasses' stamp: ''! addObsoleteSubclass: aClass "Weakly remember that aClass was a subclass of the receiver and is now obsolete" | obs | obs := self basicObsoleteSubclasses at: self ifAbsent:[WeakArray new]. (obs includes: aClass) ifTrue:[^self]. obs := obs copyWithout: nil. obs := obs copyWith: aClass. self basicObsoleteSubclasses at: self put: obs.! ! !Behavior methodsFor: 'testing' stamp: ''! hasAbstractMethods "Tells whether the receiver locally defines an abstract method, i.e., a method sending subclassResponsibility" ^ (self methods anySatisfy: [:cm | cm sendsSelector: #subclassResponsibility ])! ! !Behavior methodsFor: 'traits' stamp: ''! notifyUsersOfChangedSelectors: aCollection! ! !Behavior methodsFor: 'accessing' stamp: 'SebastianTleye 7/17/2013 11:31'! name "Answer a String that is the name of the receiver." ^'a subclass of ', self superclass name.! ! !Behavior methodsFor: '*Fuel' stamp: ''! fuelNew "Answer an instance of mine in which serialized references will be injected." ^ self basicNew! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! selectorsWithArgs: numberOfArgs "Return all selectors defined in this class that take this number of arguments" ^ self selectors select: [:selector | selector numArgs = numberOfArgs]! ! !Behavior methodsFor: 'testing' stamp: ''! instSpec ^ (self format bitShift: -7) bitAnd: 16rF! ! !Behavior methodsFor: 'traits' stamp: ''! traitCompositionIncludes: aTrait ^self == aTrait or: [self hasTraitComposition and: [self traitComposition allTraits includes: aTrait]]! ! !Behavior methodsFor: '*OpalCompiler-Core' stamp: 'SebastianTleye 7/16/2013 17:05'! recompile: selector from: oldClass "Compile the method associated with selector in the receiver's method dictionary." | method newMethod | method := oldClass compiledMethodAt: selector. newMethod := self compiler source: (oldClass sourceCodeAt: selector); class: self; failBlock: [^ self]; compiledMethodTrailer: method trailer; compile. "Assume OK after proceed from SyntaxError" selector == newMethod selector ifFalse: [self error: 'selector changed!!']. self basicAddSelector: selector withMethod: newMethod.! ! !Behavior methodsFor: 'copying' stamp: ''! copyOfMethodDictionary "Return a copy of the receiver's method dictionary" ^ self methodDict copy! ! !Behavior methodsFor: 'naming' stamp: ''! environment "Return the environment in which the receiver is visible" ^Smalltalk globals! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! thoroughHasSelectorReferringTo: literal special: specialFlag byte: specialByte "Answer true if any of my methods access the argument as a literal. Dives into the compact literal notation, making it slow but thorough " self methodsDo: [ :method | ((method hasLiteralThorough: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [^true]]. ^false! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! lookupSelector: selector "Look up the given selector in my methodDictionary. Return the corresponding method if found. Otherwise chase the superclass chain and try again. Return nil if no method is found." | lookupClass | lookupClass := self. [lookupClass == nil] whileFalse: [(lookupClass includesSelector: selector) ifTrue: [^ lookupClass compiledMethodAt: selector]. lookupClass := lookupClass superclass]. ^ nil! ! !Behavior methodsFor: 'traits' stamp: ''! updateMethodDictionarySelector: aSymbol "A method with selector aSymbol in myself or my traitComposition has been changed. Do the appropriate update to my methodDict (remove or update method) and return all affected selectors of me so that my useres get notified." | modifiedSelectors descriptions oldProtocol | modifiedSelectors := IdentitySet new. descriptions := self traitComposition methodDescriptionsForSelector: aSymbol. descriptions do: [:methodDescription | | effectiveMethod selector | selector := methodDescription selector. (self includesLocalSelector: selector) ifFalse: [ methodDescription isEmpty ifTrue: [ self removeTraitSelector: selector. modifiedSelectors add: selector] ifFalse: [ effectiveMethod := methodDescription effectiveMethod. self addTraitSelector: selector withMethod: effectiveMethod. "If the method was not categorized yet, we categorize it " oldProtocol := self organization categoryOfElement: selector. (oldProtocol isNil or: [ oldProtocol = Protocol unclassified ]) ifTrue: [ self organization classify: selector under: methodDescription effectiveMethodCategory. ]. modifiedSelectors add: selector]]]. ^modifiedSelectors! ! !Behavior methodsFor: 'accessing instances and variables' stamp: ''! classVarNames "Answer a collection of the receiver's class variable names." ^#()! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'ST 6/21/2013 10:12'! basicObsoleteSubclasses ^ObsoleteSubclasses.! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! whichSelectorsAccess: instVarName "Answer a set of selectors whose methods access the argument, instVarName, as a named instance variable." | instVarIndex | instVarIndex := self instVarIndexFor: instVarName ifAbsent: [^IdentitySet new]. ^ self selectors select: [:sel | ((self compiledMethodAt: sel) readsField: instVarIndex) or: [(self compiledMethodAt: sel) writesField: instVarIndex]] "Point whichSelectorsAccess: 'x'."! ! !Behavior methodsFor: 'initialize-release' stamp: ''! nonObsoleteClass "Attempt to find and return the current version of this obsolete class" | obsName | obsName := self name. [obsName beginsWith: 'AnObsolete'] whileTrue: [obsName := obsName copyFrom: 'AnObsolete' size + 1 to: obsName size]. ^ self environment at: obsName asSymbol! ! !Behavior methodsFor: 'accessing' stamp: 'ClementBera 9/27/2013 17:41'! methodDict "The method dictionary of a class can be nil when we want to use the #cannotInterpret: hook. Indeed when a class dictionary is nil, the VM sends the message cannotInterpret: to the receiver but starting the look up in the superclass of the class whose method dictionary was nil. Now the system relies that when the message methodDict is sent to a class a method dictionary is returned. In order to prevent the complaints of tools and IDE unaware of this feature, we fool them by providing an empty MethodDictionary. This will hopefully work in most cases, but the tools will loose the ability to modify the behaviour of this behavior. The user of #cannotInterpret: should be aware of this." methodDict ifNil: [^ MethodDictionary new ]. ^ methodDict! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: ''! allSubclasses "Answer an orderedCollection of the receiver's and the receiver's descendent's subclasses. " | scan scanTop | scan := OrderedCollection withAll: self subclasses. scanTop := 1. [scanTop > scan size] whileFalse: [scan addAll: (scan at: scanTop) subclasses. scanTop := scanTop + 1]. ^ scan! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: ''! withAllSuperclasses "Answer an OrderedCollection of the receiver and the receiver's superclasses. The first element is the receiver, followed by its superclass; the last element is Object." | temp | temp := self allSuperclasses. temp addFirst: self. ^ temp! ! !Behavior methodsFor: 'traits' stamp: ''! removeTraitSelector: aSymbol [(self includesLocalSelector: aSymbol) not] assert. self basicRemoveSelector: aSymbol! ! !Behavior methodsFor: 'accessing' stamp: 'SebastianTleye 7/16/2013 17:04'! subclassDefinerClass "Answer an evaluator class appropriate for evaluating definitions of new subclasses of this class." ^self compilerClass! ! !Behavior methodsFor: '*Rpackage-Core' stamp: ''! originalName ^ ((self isObsolete and: [ self name beginsWith: 'AnObsolete' ]) ifTrue: [ (self name copyFrom: 'AnObsolete' size + 1 to: self name size ) ] ifFalse: [ self name ]) asSymbol! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! precodeCommentOrInheritedCommentFor: selector "Answer a string representing the first comment in the method associated with selector, considering however only comments that occur before the beginning of the actual code. If the version recorded in the receiver is uncommented, look up the inheritance chain. Return nil if none found." | aSuper aComment | ^ (aComment := self firstPrecodeCommentFor: selector) isEmptyOrNil ifTrue: [(self == Behavior or: [self superclass == nil or: [(aSuper := self superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: [aSuper precodeCommentOrInheritedCommentFor: selector]] ifFalse: [aComment]! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! whichClassIncludesSelector: aSymbol "Answer the class on the receiver's superclass chain where the argument, aSymbol (a message selector), will be found. Answer nil if none found." "Rectangle whichClassIncludesSelector: #inspect." (self includesSelector: aSymbol) ifTrue: [^ self]. self superclass == nil ifTrue: [^ nil]. ^ self superclass whichClassIncludesSelector: aSymbol! ! !Behavior methodsFor: 'testing method dictionary' stamp: ''! whichSelectorsStoreInto: instVarName "Answer a Set of selectors whose methods access the argument, instVarName, as a named instance variable." | instVarIndex | instVarIndex := self instVarIndexFor: instVarName ifAbsent: [^IdentitySet new]. ^ self selectors select: [:sel | (self compiledMethodAt: sel) writesField: instVarIndex] "Point whichSelectorsStoreInto: 'x'."! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'dvf 9/27/2005 17:08'! methodDict: aDictionary methodDict := aDictionary! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! compiledMethodAt: selector "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification." ^ self methodDict at: selector! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! >> selector "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification." ^self compiledMethodAt: selector ! ! !Behavior methodsFor: '*NativeBoost-Core' stamp: 'Igor.Stasenko 4/30/2010 12:34'! nbFnArgument: argName generator: gen "Load the instance variable with given name" (self allInstVarNames includes: argName) ifFalse: [ ^ nil ]. ^ NBSTIvarArgument new receiverClass: self; ivarName: argName! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary." ^ self methodDict keys! ! !Behavior methodsFor: 'enumerating' stamp: ''! selectSuperclasses: aBlock "Evaluate the argument, aBlock, with the receiver's superclasses as the argument. Collect into an OrderedCollection only those superclasses for which aBlock evaluates to true. In addition, evaluate aBlock for the superclasses of each of these successful superclasses and collect into the OrderedCollection ones for which aBlock evaluates to true. Answer the resulting OrderedCollection." | aSet | aSet := Set new. self allSuperclasses do: [:aSuperclass | (aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]]. ^aSet! ! !Behavior methodsFor: 'private' stamp: ''! spaceUsed "Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables." | space | space := 0. self methodsDo: [:method | space := space + 16. "dict and org'n space" space := space + (method size + 6 "hdr + avg pad"). method literalsDo: [:lit | (lit isMemberOf: Array) ifTrue: [space := space + ((lit size + 1) * 4)]. (lit isMemberOf: Float) ifTrue: [space := space + 12]. (lit isMemberOf: ByteString) ifTrue: [space := space + (lit size + 6)]. (lit isMemberOf: LargeNegativeInteger) ifTrue: [space := space + ((lit size + 1) * 4)]. (lit isMemberOf: LargePositiveInteger) ifTrue: [space := space + ((lit size + 1) * 4)]]]. ^ space! ! !Behavior methodsFor: 'accessing method dictionary' stamp: ''! selectorsDo: selectorBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysDo: selectorBlock! ! !Behavior methodsFor: 'accessing instances and variables' stamp: ''! includesSharedPoolNamed: aSharedPoolString "Answer whether the receiver uses the shared pool named aSharedPoolString" ^ (self sharedPools anySatisfy: [:each | each name = aSharedPoolString])! ! !Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:51'! initialize "Behavior initialize" "Never called for real" ObsoleteSubclasses ifNil: [self initializeObsoleteSubclasses] ifNotNil: [| newDict | newDict := WeakKeyToCollectionDictionary newFrom: ObsoleteSubclasses. newDict rehash. ObsoleteSubclasses := newDict]! ! !Behavior class methodsFor: 'testing' stamp: 'dvf 9/27/2005 16:12'! canZapMethodDictionary "Return false since zapping the method dictionary of Behavior class or its subclasses will cause the system to fail." ^false! ! !Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:46'! initializeObsoleteSubclasses ObsoleteSubclasses := WeakKeyToCollectionDictionary new.! ! !Behavior class methodsFor: '*Collections-Abstract' stamp: 'CamilloBruni 2/22/2013 23:14'! sortBlock ^ [ :a :b | a name <= b name ]! ! !Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:23'! flushObsoleteSubclasses "Behavior flushObsoleteSubclasses" ObsoleteSubclasses finalizeValues.! ! !Behavior class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:08'! cleanUp "Flush the obsolete subclasses." self flushObsoleteSubclasses! ! !BehaviorInstallingDeclaration commentStamp: ''! I'm an abstract class grouping the behavior of the code declarations that will be instaled in a behavior, such as methods, class comments, organizations...! !BehaviorInstallingDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 20:35'! isMeta: aBoolean isMeta := aBoolean! ! !BehaviorInstallingDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 20:35'! behaviorName: aBehaviorName behaviorName := aBehaviorName! ! !BehaviorInstallingDeclaration methodsFor: 'testing' stamp: 'GuillermoPolito 5/5/2012 20:37'! existsBehavior ^self class environment includesKey: behaviorName! ! !BehaviorInstallingDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 20:36'! targetClass | target | target := self class environment at: behaviorName. ^isMeta ifTrue: [ target classSide ] ifFalse: [ target ]! ! !BehaviorTest commentStamp: 'TorstenBergmann 2/5/2014 08:31'! SUnit tests for Behavior! !BehaviorTest methodsFor: 'tests' stamp: 'sd 11/19/2004 15:38'! testBehaviornewnewShouldNotCrash Behavior new new. "still not working correctly but at least does not crash the image" ! ! !BehaviorTest methodsFor: 'tests' stamp: 'SeanDeNigris 8/29/2011 12:26'! testAllSelectorsAboveUntil "self debug: #testAllSelectorsAboveUntil" |sels | sels := Date allSelectorsAboveUntil: Object.. self deny: (sels includes: #mmddyyyy). self deny: (sels includes: #weekday). self assert: (sels includes: #at:). self deny: (sels includes: #cannotInterpret: ) ! ! !BehaviorTest methodsFor: 'tests' stamp: 'nice 12/25/2009 18:58'! sampleMessageWithFirstArgument: firstArgument "This is a comment intended to explain arg1" andInterleavedCommentBeforeSecondArgument: secondArgument "This method is here to test a few utilities like formalParametersAt:" | thisIsAnUnusedTemp | thisIsAnUnusedTemp := self. ^thisIsAnUnusedTemp! ! !BehaviorTest methodsFor: 'tests' stamp: 'marcus.denker 9/14/2008 21:14'! testBinding self assert: Object binding value = Object. self assert: Object binding key = #Object. self assert: Object class binding value = Object class. "returns nil for Metaclasses... like Encoder>>#associationFor:" self assert: Object class binding key isNil.! ! !BehaviorTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 12/16/2011 10:54'! testUncompactClassNotAllowed "As explained in Behavior >> #checkCanBeUncompact certain classes cannot be uncompact, like Array" self should: [Array becomeUncompact] raise: Error.! ! !BehaviorTest methodsFor: 'tests' stamp: 'CamilleTeruel 12/6/2013 15:47'! testCanUnderstand | c1 c2 | c1 := Object subclass: 'MySuperclass' instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self class category. c1 compile: 'method1 ^self subclassResponsibility'. c1 compile: 'method2 ^123'. self deny: (c1 canUnderstand: #method1). self assert: (c1 canUnderstand: #method2). self deny: (c1 canUnderstand: #method3). c2 := c1 subclass: 'MySubclass' instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self class category. c2 compile: 'method1 ^ 3'. c2 compile: 'method3 ^5'. self assert: (c2 canUnderstand: #method1). self assert: (c2 canUnderstand: #method3). c2 removeFromSystem. c1 removeFromSystem.! ! !BehaviorTest methodsFor: 'tests' stamp: 'MarcusDenker 5/10/2013 00:23'! testAllMethods | allMethods nonOverridenMethods | allMethods := IdentitySet new addAll: Object allMethods; yourself. self assert: (allMethods includesAllOf: Object methods). "We fetch all compiled methods that are not redefined in Object" nonOverridenMethods := OrderedCollection new. ProtoObject selectorsAndMethodsDo: [ :sel :method | (Object includesSelector: sel) ifFalse: [ nonOverridenMethods add: method ] ]. self assert: (allMethods includesAllOf: nonOverridenMethods)! ! !BehaviorTest methodsFor: 'tests' stamp: 'sd 1/28/2009 14:25'! testallSuperclassesIncluding "self debug: #testallSuperclassesIncluding" |cls | cls := ArrayedCollection allSuperclassesIncluding: Collection. self deny: (cls includes: ArrayedCollection). self deny: (cls includes: Object). self assert: (cls includes: Collection). self assert: (cls includes: SequenceableCollection). ! ! !BehaviorTest methodsFor: 'tests' stamp: 'MarcusDenker 11/3/2013 11:41'! testBehaviorRespectsPolymorphismWithTraitBehavior | repeatedMethodsThatDoNotAccessInstanceVariables differentMethodsWithSameSelector | "If the method is in Behavior and TraitBehavior it must access some instance variable, otherwise the method can be implemented in TBehavior" repeatedMethodsThatDoNotAccessInstanceVariables := self repeatedMethodsThatDoNotAccessInstanceVariablesBetween: Behavior and: TraitBehavior. self assert: repeatedMethodsThatDoNotAccessInstanceVariables size equals: 0. "If the method is in Behavior and TraitBehavior, and they have different implementations, it must be declared in TBehavior as an explicitRequirement method" differentMethodsWithSameSelector := self differentMethodsWithSameSelectorBetween: Behavior and: TraitBehavior. differentMethodsWithSameSelector do: [ :selector | (TBehavior >> selector) sourceCode. self assert: (TBehavior >> selector) isRequired ]. "Only a few methods are allowed to belong to one class and not to the other" "If you want to remove methods for this list, then go ahead. But is NOT good idea add methods to this list" "format -> the instance variable format belongs to Behavior but not to TraitBehavior, if we add the getter to TraitBehavior, what should we return? isBehavior -> returns true for all the classes but false for the traits, the implementation for traits (and the rest of the objects) is implemented in Object>>isBehavior layout -> is an instance variable of Behavior but not of TraitBehavior" self assert: (Behavior localSelectors difference: TraitBehavior localSelectors) equals: #(#externalTypeAlias: #nbBindingOf: #format #nbFnArgument:generator: #layout #isBehavior) asSet. "localSelectors, localSelectors:, basicLocalSelectors, basicLocalSelectors: -> the instance variable localSelectors belongs to TraitBehavior but not to Behavior" "browse is implemeted differently for traits, the implementation for classes is in Object" "isTrait answers true for traits, for the rest of objects answer false, the implementation is in Object" self assert: (TraitBehavior localSelectors difference: Behavior localSelectors) equals: #(#browse #basicLocalSelectors #basicLocalSelectors: #isTrait) asSet! ! !BehaviorTest methodsFor: 'tests' stamp: 'MarcusDenker 7/12/2012 17:59'! testAllReferencesTo | result | result := SystemNavigation new allReferencesTo: Point binding. result do: [ :each | self assert: (each compiledMethod hasLiteral: Point binding) ]. self assert: (result anySatisfy: [ :each | each actualClass = self class and: [ each selector = #testAllReferencesTo ] ]). result := SystemNavigation new allReferencesTo: #printOn:. result do: [ :each | self assert: (each compiledMethod hasLiteralThorough: #printOn:) ]. self assert: (result anySatisfy: [ :each | each actualClass = self class and: [ each selector = #testAllReferencesTo ] ]). result := SystemNavigation new allReferencesTo: #+. result do: [ :each | self assert: ((each compiledMethod sendsSelector: #+) or: [ each compiledMethod hasLiteralThorough: #+ ]) ]. self assert: (result anySatisfy: [ :each | each actualClass = self class and: [ each selector = #testAllReferencesTo ] ])! ! !BehaviorTest methodsFor: 'tests' stamp: 'MarcusDenker 1/15/2013 10:30'! testHasAbstractMethods self deny: Object hasAbstractMethods. self deny: Object class hasAbstractMethods. "Behavior has abstract methods, for example hasTraitComposition, basicLocalSelectors:" self assert: Behavior hasAbstractMethods. self deny: Behavior class hasAbstractMethods. self assert: DiskStore hasAbstractMethods. "DiskStore defines methods because its class side contains abstract methods" self assert: DiskStore class hasAbstractMethods. ! ! !BehaviorTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 1/9/2012 22:31'! testCompactAndUncompactClass self assert: ExampleForTest1 isCompact not. ExampleForTest1 becomeCompact. self assert: ExampleForTest1 isCompact. ExampleForTest1 becomeUncompact. self assert: ExampleForTest1 isCompact not. ! ! !BehaviorTest methodsFor: 'metrics' stamp: 'Alexandre Bergel 4/27/2010 14:06'! testNumberOfInstanceVariables self assert: Object numberOfInstanceVariables = 0. self assert: Point numberOfInstanceVariables = 2. self assert: Metaclass numberOfInstanceVariables = 3! ! !BehaviorTest methodsFor: 'tests' stamp: 'nice 12/3/2009 23:58'! testAllSelectors self assert: ProtoObject allSelectors asSet = ProtoObject selectors asSet. self assert: Object allSelectors asSet = (Object selectors asSet union: ProtoObject selectors). self assert: (Object allSelectorsBelow: ProtoObject) asSet = (Object selectors) asSet.! ! !BehaviorTest methodsFor: 'tests - testing method dictionary' stamp: 'marcus.denker 9/29/2008 15:11'! testWhichSelectorsAccess self assert: ((Point whichSelectorsAccess: 'x') includes: #x). self deny: ((Point whichSelectorsAccess: 'y') includes: #x).! ! !BehaviorTest methodsFor: 'tests' stamp: 'MarcusDenker 3/25/2013 22:07'! testComposedBy "tests the #isComposedBy: aTrait method" self deny: (Object isComposedBy: TSortable). self assert: (SequenceableCollection isComposedBy: TSortable). self assert: (Trait3 isComposedBy: Trait2). self deny: (Trait2 isComposedBy: Trait3). self deny: (Trait3 isComposedBy: Object). ! ! !BehaviorTest methodsFor: 'tests' stamp: 'SeanDeNigris 8/29/2011 12:25'! testAllSelectorsAbove "self debug: #testAllSelectorsAbove" |sels | sels := Date allSelectorsAbove. self deny: (sels includes: #mmddyyyy). self deny: (sels includes: #weekday). self assert: (sels includes: #at:). self assert: (sels includes: #cannotInterpret: ) ! ! !BehaviorTest methodsFor: 'tests' stamp: 'StephaneDucasse 8/12/2011 14:55'! testAllLocalCallsOn " self debug: #testAllLocalCallsOn" self assert: (( Point allLocalCallsOn: #asPoint ) notEmpty). self assert: (( Point allLocalCallsOn: #asPoint ) size = 4). self assert: (( Point allLocalCallsOn: #asPoint ) includes: (Point>> #roundDownTo:) asRingDefinition). self assert: (( Point allLocalCallsOn: #asPoint ) includes: (Point >> #roundUpTo:) asRingDefinition). self assert: (( Point allLocalCallsOn: #asPoint ) includes: (Point >> #roundTo:) asRingDefinition). self assert: (( Point allLocalCallsOn: #asPoint ) includes: (Point >> #truncateTo: ) asRingDefinition). ! ! !Bezier2Segment commentStamp: ''! This class represents a quadratic bezier segment between two points Instance variables: via The additional control point (OFF the curve)! !Bezier2Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:05'! asBezier3Segment "Represent the receiver as cubic bezier segment" ^Bezier3Segment from: start via: 2*via+start / 3.0 and: 2*via+end / 3.0 to: end! ! !Bezier2Segment methodsFor: 'bezier clipping' stamp: 'ar 6/7/2003 23:45'! bezierClipHeight: dir | dirX dirY uMin uMax dx dy u | dirX := dir x. dirY := dir y. uMin := 0.0. uMax := (dirX * dirX) + (dirY * dirY). dx := via x - start x. dy := via y - start y. u := (dirX * dx) + (dirY * dy). u < uMin ifTrue:[uMin := u]. u > uMax ifTrue:[uMax := u]. ^uMin@uMax! ! !Bezier2Segment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:14'! bounds "Return the bounds containing the receiver" ^super bounds encompass: via! ! !Bezier2Segment methodsFor: 'initialize' stamp: 'ar 6/6/2003 03:03'! from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter "Initialize the receiver with the pointOnCurve at the given parametric value" | t1 t2 t3 | start := startPoint. end := endPoint. "Compute via" t1 := (1.0 - parameter) squared. t2 := 1.0 / (2 * parameter * (1.0 - parameter)). t3 := parameter squared. via := (pointOnCurve - (start * t1) - (end * t3)) * t2! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'! parameterAtExtremeY "Note: Only valid for non-monoton receivers" ^self parameterAtExtreme: 1.0@0.0. ! ! !Bezier2Segment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:13'! from: startPoint to: endPoint "Initialize the receiver as straight line" start := startPoint. end := endPoint. via := (start + end) // 2.! ! !Bezier2Segment methodsFor: 'initialize' stamp: 'ar 6/7/2003 22:37'! from: startPoint to: endPoint withMidPoint: pointOnCurve "Initialize the receiver with the pointOnCurve assumed at the parametric value 0.5" start := startPoint. end := endPoint. "Compute via" via := (pointOnCurve * 2) - (start + end * 0.5).! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'! tangentAtStart "Return the tangent for the first point" ^via - start! ! !Bezier2Segment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:17'! asBezier2Segment "Represent the receiver as quadratic bezier segment" ^self! ! !Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'! isStraight "Return true if the receiver represents a straight line" ^(self tangentAtStart crossProduct: self tangentAtEnd) = 0! ! !Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'! hasZeroLength "Return true if the receiver has zero length" ^start = end and:[start = via]! ! !Bezier2Segment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:14'! via "Return the control point" ^via! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'! tangentAtEnd "Return the tangent for the last point" ^end - via! ! !Bezier2Segment methodsFor: 'printing' stamp: 'ar 11/2/1998 12:18'! printOn: aStream "Print the receiver on aStream" aStream nextPutAll: self class name; nextPutAll:' from: '; print: start; nextPutAll: ' via: '; print: via; nextPutAll: ' to: '; print: end; space.! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:08'! controlPoints ^{start. via. end}! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'! controlPointsDo: aBlock aBlock value: start; value: via; value: end! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:15'! length "Return the length of the receiver" "Note: Overestimates the length" ^(start dist: via) + (via dist: end)! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'pmm 3/13/2010 11:21'! curveFrom: param1 to: param2 "Return a new curve from param1 to param2" | newStart newEnd newVia tan1 tan2 d1 d2 | tan1 := via - start. tan2 := end - via. param1 <= 0.0 ifTrue:[ newStart := start. ] ifFalse:[ d1 := tan1 * param1 + start. d2 := tan2 * param1 + via. newStart := (d2 - d1) * param1 + d1 ]. param2 >= 1.0 ifTrue:[ newEnd := end. ] ifFalse:[ d1 := tan1 * param2 + start. d2 := tan2 * param2 + via. newEnd := (d2 - d1) * param2 + d1. ]. tan2 := (tan2 - tan1 * param1 + tan1) * (param2 - param1). newVia := newStart + tan2. ^self shallowCopy from: newStart to: newEnd via: newVia.! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/6/1998 23:39'! lineSegmentsDo: aBlock "Evaluate aBlock with the receiver's line segments" "Note: We could use forward differencing here." | steps last deltaStep t next | steps := 1 max: (self length // 10). "Assume 10 pixels per step" last := start. deltaStep := 1.0 / steps asFloat. t := deltaStep. 1 to: steps do:[:i| next := self valueAt: t. aBlock value: last value: next. last := next. t := t + deltaStep].! ! !Bezier2Segment methodsFor: 'initialize' stamp: 'ar 6/7/2003 00:09'! initializeFrom: controlPoints controlPoints size = 3 ifFalse:[self error:'Wrong number of control points']. start := controlPoints at: 1. via := controlPoints at: 2. end := controlPoints at: 3.! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'! parameterAtExtremeX "Note: Only valid for non-monoton receivers" ^self parameterAtExtreme: 0.0@1.0. ! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:54'! tangentAtMid "Return the tangent at the given parametric value along the receiver" | in out | in := self tangentAtStart. out := self tangentAtEnd. ^in + out * 0.5! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'! tangentAt: parameter "Return the tangent at the given parametric value along the receiver" | in out | in := self tangentAtStart. out := self tangentAtEnd. ^in + (out - in * parameter)! ! !Bezier2Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 20:58'! asTangentSegment ^LineSegment from: via-start to: end-via! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'nk 12/27/2003 13:00'! roundTo: quantum super roundTo: quantum. via := via roundTo: quantum. ! ! !Bezier2Segment methodsFor: 'converting' stamp: 'ar 6/8/2003 04:19'! asBezier2Points: error ^Array with: start with: via with: end! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 17:21'! lineSegments: steps do: aBlock "Evaluate aBlock with the receiver's line segments" "Note: We could use forward differencing here." | last deltaStep t next | last := start. deltaStep := 1.0 / steps asFloat. t := deltaStep. 1 to: steps do:[:i| next := self valueAt: t. aBlock value: last value: next. last := next. t := t + deltaStep].! ! !Bezier2Segment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:13'! from: startPoint to: endPoint via: viaPoint "Initialize the receiver" start := startPoint. end := endPoint. via := viaPoint.! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:04'! outlineSegment: width | delta newStart newEnd param newMid | delta := self tangentAtStart normalized * width. delta := delta y @ delta x negated. newStart := start + delta. delta := self tangentAtEnd normalized * width. delta := delta y @ delta x negated. newEnd := end + delta. param := 0.5. "self tangentAtStart r / (self tangentAtStart r + self tangentAtEnd r)." delta := (self tangentAt: param) normalized * width. delta := delta y @ delta x negated. newMid := (self valueAt: param) + delta. ^self class from: newStart to: newEnd withMidPoint: newMid at: param! ! !Bezier2Segment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:18'! asIntegerSegment "Convert the receiver into integer representation" ^self species from: start asIntegerPoint to: end asIntegerPoint via: via asIntegerPoint! ! !Bezier2Segment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'! degree ^2! ! !Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'! isBezier2Segment "Return true if the receiver is a quadratic bezier segment" ^true! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:17'! valueAt: parameter "Evaluate the receiver at the given parametric value" "Return the point at the parametric value t: p(t) = (1-t)^2 * p1 + 2*t*(1-t) * p2 + t^2 * p3. " | t1 t2 t3 | t1 := (1.0 - parameter) squared. t2 := 2 * parameter * (1.0 - parameter). t3 := parameter squared. ^(start * t1) + (via * t2) + (end * t3)! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 6/9/2003 03:43'! parameterAtExtreme: tangentDirection "Compute the parameter value at which the tangent reaches tangentDirection. We need to find the parameter value t at which the following holds ((t * dir + in) crossProduct: tangentDirection) = 0. Since this is pretty ugly we use the normal direction rather than the tangent and compute the equivalent relation using the dot product as ((t * dir + in) dotProduct: nrm) = 0. Reformulation yields ((t * dir x + in x) * nrm x) + ((t * dir y + in y) * nrm y) = 0. (t * dir x * nrm x) + (in x * nrm x) + (t * dir y * nrm y) + (in y * nrm y) = 0. (t * dir x * nrm x) + (t * dir y * nrm y) = 0 - ((in x * nrm x) + (in y * nrm y)). (in x * nrm x) + (in y * nrm y) t = 0 - --------------------------------------- (dir x * nrm x) + (dir y * nrm y) And that's that. Note that we can get rid of the negation by computing 'dir' the other way around (e.g., in the above it would read '-dir') which is trivial to do. Note also that the above does not generalize easily beyond 2D since its not clear how to express the 'normal direction' of a tangent plane. " | inX inY dirX dirY nrmX nrmY | "Compute in" inX := via x - start x. inY := via y - start y. "Compute -dir" dirX := inX - (end x - via x). dirY := inY - (end y - via y). "Compute nrm" nrmX := tangentDirection y. nrmY := 0 - tangentDirection x. "Compute result" ^((inX * nrmX) + (inY * nrmY)) / ((dirX * nrmX) + (dirY * nrmY))! ! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'! from: startPoint withMidPoint: pointOnCurve to: endPoint ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve! ! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:32'! from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter! ! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'! from: startPoint via: viaPoint to: endPoint ^self new from: startPoint to: endPoint via: viaPoint! ! !Bezier2Segment class methodsFor: 'utilities' stamp: 'ar 6/7/2003 18:33'! makeEllipseSegments: aRectangle "Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle. This method creates eight bezier segments (two for each quadrant) approximating the oval." "EXAMPLE: This example draws an oval with a red border and overlays the approximating bezier segments on top of the oval (drawn in black), thus giving an impression of how closely the bezier resembles the oval. Change the rectangle to see how accurate the approximation is for various radii of the oval. | rect | rect := 100@100 extent: 1200@500. Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. (Bezier2Segment makeEllipseSegments: rect) do:[:seg| seg lineSegmentsDo:[:last :next| Display getCanvas line: last to: next width: 1 color: Color black]]. " "EXAMPLE: | minRadius maxRadius | maxRadius := 300. minRadius := 20. maxRadius to: minRadius by: -10 do:[:rad| | rect | rect := 400@400 - rad corner: 400@400 + rad. Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. (Bezier2Segment makeEllipseSegments: rect) do:[:seg| seg lineSegmentsDo:[:last :next| Display getCanvas line: last to: next width: 1 color: Color black]]]. " | nrm topCenter leftCenter rightCenter bottomCenter dir scale seg1a topRight seg1b seg2a bottomRight seg2b center bottomLeft topLeft seg3a seg3b seg4a seg4b | dir := aRectangle width * 0.5. nrm := aRectangle height * 0.5. "Compute the eight control points on the oval" scale := 0.7071067811865475. "45 degreesToRadians cos = 45 degreesToRadians sin = 2 sqrt / 2" center := aRectangle origin + aRectangle corner * 0.5. topCenter := aRectangle topCenter. rightCenter := aRectangle rightCenter. leftCenter := aRectangle leftCenter. bottomCenter := aRectangle bottomCenter. topRight := (center x + (dir * scale)) @ (center y - (nrm * scale)). bottomRight := (center x + (dir * scale)) @ (center y + (nrm * scale)). bottomLeft := (center x - (dir * scale)) @ (center y + (nrm * scale)). topLeft := (center x - (dir * scale)) @ (center y - (nrm * scale)). scale := 0.414213562373095. "2 sqrt - 1" dir := (dir * scale) @ 0. nrm := 0 @ (nrm * scale). seg1a := self from: topCenter via: topCenter + dir to: topRight. seg1b := self from: topRight via: rightCenter - nrm to: rightCenter. seg2a := self from: rightCenter via: rightCenter + nrm to: bottomRight. seg2b := self from: bottomRight via: bottomCenter + dir to: bottomCenter. seg3a := self from: bottomCenter via: bottomCenter - dir to: bottomLeft. seg3b := self from: bottomLeft via: leftCenter + nrm to: leftCenter. seg4a := self from: leftCenter via: leftCenter - nrm to: topLeft. seg4b := self from: topLeft via: topCenter - dir to: topCenter. ^{seg1a. seg1b. seg2a. seg2b. seg3a. seg3b. seg4a. seg4b}! ! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'! from: startPoint to: endPoint withMidPoint: pointOnCurve ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve! ! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:14'! from: startPoint to: endPoint via: viaPoint ^self new from: startPoint to: endPoint via: viaPoint! ! !Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:32'! from: startPoint withMidPoint: pointOnCurve at: parameter to: endPoint ^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter! ! !Bezier3Segment commentStamp: ''! This class represents a cubic bezier segment between two points Instance variables: via1, via2 The additional control points (OFF the curve)! !Bezier3Segment methodsFor: 'initialization' stamp: 'DSM 10/14/1999 15:33'! from: aPoint1 via: aPoint2 and: aPoint3 to: aPoint4 start := aPoint1. via1 := aPoint2. via2 := aPoint3. end := aPoint4! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/15/1999 15:20'! bounds ^ ((super bounds encompassing: via1) encompassing: via2)! ! !Bezier3Segment methodsFor: 'bezier clipping' stamp: 'ar 6/7/2003 23:45'! bezierClipHeight: dir "Check if the argument overlaps the receiver somewhere along the line from start to end. Optimized for speed." | u dirX dirY dx dy uMin uMax | dirX := dir x. dirY := dir y. uMin := 0.0. uMax := (dirX * dirX) + (dirY * dirY). dx := via1 x - start x. dy := via1 y - start y. u := (dirX * dx) + (dirY * dy). u < uMin ifTrue:[uMin := u]. u > uMax ifTrue:[uMax := u]. dx := via2 x - start x. dy := via2 y - start y. u := (dirX * dx) + (dirY * dy). u < uMin ifTrue:[uMin := u]. u > uMax ifTrue:[uMax := u]. ^uMin@uMax! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 22:01'! tangentAtStart ^via1 - start! ! !Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/6/2003 22:23'! asBezierShape "Demote a cubic bezier to a set of approximating quadratic beziers." ^self asBezierShape: 0.5! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 22:02'! tangentAtEnd ^end - via2! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:56'! tangentAtMid | tan1 tan2 tan3 | tan1 := via1 - start. tan2 := via2 - via1. tan3 := end - via2. ^(tan1 + (2*tan2) + tan3) * 0.25 ! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'! controlPointsDo: aBlock aBlock value: start; value: via1; value: via2; value: end! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:08'! controlPoints ^{start. via1. via2. end}! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 21:59'! length "Answer a gross approximation of the length of the receiver" ^(start dist: via1) + (via1 dist: via2) + (via2 dist: end)! ! !Bezier3Segment methodsFor: 'private' stamp: 'DSM 10/14/1999 16:25'! bezier2SegmentCount "Compute the number of quadratic bezier segments needed to approximate this cubic with less than a 1-pixel error" ^ self bezier2SegmentCount: 1.0! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/6/2003 21:52'! lineSegmentsDo: aBlock "Evaluate aBlock with the receiver's line segments" "Note: We could use forward differencing here." | steps last deltaStep t next | steps := 1 max: (self length // 10). "Assume 10 pixels per step" last := start. deltaStep := 1.0 / steps asFloat. t := deltaStep. 1 to: steps do:[:i| next := self valueAt: t. aBlock value: last value: next. last := next. t := t + deltaStep].! ! !Bezier3Segment methodsFor: 'initialization' stamp: 'ar 6/7/2003 00:09'! initializeFrom: controlPoints controlPoints size = 4 ifFalse:[self error:'Wrong number of control points']. start := controlPoints at: 1. via1 := controlPoints at: 2. via2 := controlPoints at: 3. end := controlPoints at: 4.! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 22:37'! via1 ^via1! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 19:25'! tangentAt: parameter | tan1 tan2 tan3 t1 t2 t3 | tan1 := via1 - start. tan2 := via2 - via1. tan3 := end - via2. t1 := (1.0 - parameter) squared. t2 := 2 * parameter * (1.0 - parameter). t3 := parameter squared. ^(tan1 * t1) + (tan2 * t2) + (tan3 * t3)! ! !Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 20:58'! asTangentSegment ^Bezier2Segment from: via1-start via: via2-via1 to: end-via2! ! !Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:07'! asBezier2Points: error "Demote a cubic bezier to a set of approximating quadratic beziers. Should convert to forward differencing someday" | curves pts step prev index a b f | curves := self bezier2SegmentCount: error. pts := Array new: curves * 3. step := 1.0 / (curves * 2). prev := start. 1 to: curves do: [ :c | index := 3*c. a := pts at: index-2 put: prev. b := (self valueAt: (c*2-1)*step). f := pts at: index put: (self valueAt: (c*2)*step). pts at: index-1 put: (4 * b - a - f) / 2. prev := pts at: index. ]. ^ pts. ! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 17:21'! lineSegments: steps do: aBlock "Evaluate aBlock with the receiver's line segments" "Note: We could use forward differencing here." | last deltaStep t next | last := start. deltaStep := 1.0 / steps asFloat. t := deltaStep. 1 to: steps do:[:i| next := self valueAt: t. aBlock value: last value: next. last := next. t := t + deltaStep].! ! !Bezier3Segment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:04'! outlineSegment: width | tan1 nrm1 tan2 nrm2 newStart newVia1 newEnd newVia2 dist | tan1 := (via1 - start) normalized. nrm1 := tan1 * width. nrm1 := nrm1 y @ nrm1 x negated. tan2 := (end - via2) normalized. nrm2 := tan2 * width. nrm2 := nrm2 y @ nrm2 x negated. newStart := start + nrm1. newEnd := end + nrm2. dist := (newStart dist: newEnd) * 0.3. newVia1 := newStart + (tan1 * dist). newVia2 := newEnd - (tan2 * dist). ^self class from: newStart via: newVia1 and: newVia2 to: newEnd. ! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'! via2: aPoint via2 := aPoint! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 22:37'! via2 ^via2! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'! via1: aPoint via1 := aPoint! ! !Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:09'! asBezierShape: error "Demote a cubic bezier to a set of approximating quadratic beziers. Should convert to forward differencing someday" ^(self asBezier2Points: error) asPointArray.! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'! degree ^3! ! !Bezier3Segment methodsFor: 'converting' stamp: 'DSM 3/10/2000 12:10'! bezier2SegmentCount: pixelError "Compute the number of quadratic bezier segments needed to approximate this cubic with no more than a specified error" | a | a := (start x negated @ start y negated) + (3 * via1) - (3 * via2) + (end). ^ (((a r / (20.0 * pixelError)) raisedTo: 0.333333) ceiling) max: 1. ! ! !Bezier3Segment methodsFor: 'converting' stamp: 'ar 6/7/2003 21:07'! asBezier2Segments "Demote a cubic bezier to a set of approximating quadratic beziers." ^self asBezier2Segments: 0.5! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/15/1999 15:01'! valueAt: t | a b c d | "| p1 p2 p3 | p1 := start interpolateTo: via1 at: t. p2 := via1 interpolateTo: via2 at: t. p3 := via2 interpolateTo: end at: t. p1 := p1 interpolateTo: p2 at: t. p2 := p2 interpolateTo: p3 at: t. ^ p1 interpolateTo: p2 at: t" a := (start negated) + (3 * via1) - (3 * via2) + (end). b := (3 * start) - (6 * via1) + (3 * via2). c := (3 * start negated) + (3 * via1). d := start. ^ ((a * t + b) * t + c) * t + d ! ! !Bezier3Segment methodsFor: 'converting' stamp: 'DSM 10/15/1999 15:45'! asPointArray | p | p := PointArray new: 4. p at: 1 put: start. p at: 2 put: via1. p at: 3 put: via2. p at: 4 put: end. ^ p! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'eem 6/11/2008 16:08'! makeEllipseSegments: aRectangle count: segmentCount "Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle. This method creates segmentCount bezier segments (one for each quadrant) approximating the oval." | count angle center scale | center := aRectangle origin + aRectangle corner * 0.5. scale := aRectangle extent * 0.5. count := segmentCount max: 2. "need at least two segments" angle := 360.0 / count. ^(1 to: count) collect:[:i| | seg | seg := self makeUnitPieSegmentFrom: i-1*angle to: i*angle. self controlPoints: (seg controlPoints collect:[:pt| pt * scale + center]) ].! ! !Bezier3Segment class methodsFor: '*Morphic-Base-Balloon-examples' stamp: 'DSM 10/15/1999 15:49'! example1 | c | c := Bezier3Segment new from: 0@0 via: 0@100 and: 100@0 to: 100@100. ^ c asBezierShape! ! !Bezier3Segment class methodsFor: 'instance creation' stamp: 'DSM 10/15/1999 15:24'! from: p1 via: p2 and: p3 to: p4 ^ self new from: p1 via: p2 and: p3 to: p4! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:26'! makePieSegment: aRectangle from: angle1 to: angle2 "Create a single pie segment for the oval inscribed in aRectangle between angle1 and angle2. If angle1 is less than angle2 this method creates a CW pie segment, otherwise it creates a CCW pie segment." | seg center scale | angle1 > angle2 ifTrue:["ccw" ^(self makePieSegment: aRectangle from: angle2 to: angle1) reversed ]. "create a unit circle pie segment from angle1 to angle2" seg := self makeUnitPieSegmentFrom: angle1 to: angle2. "scale the segment to fit aRectangle" center := aRectangle origin + aRectangle corner * 0.5. scale := aRectangle extent * 0.5. ^self controlPoints: (seg controlPoints collect:[:pt| pt * scale + center])! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'DSM 10/15/1999 16:06'! convertBezier3ToBezier2: vertices | pa pts index c | pts := OrderedCollection new. 1 to: vertices size // 4 do: [:i | index := i * 4 - 3. c := Bezier3Segment new from: (vertices at: index) via: (vertices at: index + 1) and: (vertices at: index + 2) to: (vertices at: index + 3). pts addAll: c asBezierShape]. pa := PointArray new: pts size. pts withIndexDo: [:p :i | pa at: i put: p ]. ^ pa! ! !Bezier3Segment class methodsFor: '*Morphic-Base-Balloon-examples' stamp: 'DSM 10/15/1999 16:00'! example2 "draws a cubic bezier on the screen" | c canvas | c := Bezier3Segment new from: 0 @ 0 via: 0 @ 100 and: 100 @ 0 to: 100 @ 100. canvas := BalloonCanvas on: Display. canvas aaLevel: 4. canvas drawBezier3Shape: c asPointArray color: Color transparent borderWidth: 1 borderColor: Color black! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 04:45'! makeUnitPieSegmentWith: point1 and: point2 "Create a clockwise unit pie segment from point1 to point2, that is a pie segment for a circle centered at zero with radius one." | pt1 pt2 dir1 dir2 mid length scale cp1 cp2 pt3 magic | "point1 and point2 are the points on the unit circle for accuracy (or broken input), renormalize them." pt1 := point1 normalized. pt2 := point2 normalized. "compute the normal vectors - those are tangent directions for the bezier" dir1 := pt1 y negated @ pt1 x. dir2 := pt2 y negated @ pt2 x. "Okay, now that we have the points and tangents on the unit circle, let's do the magic. For fitting a cubic bezier onto a circle section we know that we want the end points be on the circle and the tangents to point towards the right direction (both of which we have in the above). What we do NOT know is how to scale the tangents so that midpoint of the bezier is exactly on the circle. The good news is that there is a linear relation between the length of the tangent vectors and the distance of the midpoint from the circle's origin. The bad news is that I don't know how to derive it analytically. So what I do here is simply sampling the bezier twice (not really - the first sample is free) and then to compute the distance from the sample." "The first sample is just between the two points on the curve" mid := pt1 + pt2 * 0.5. "The second sample will be taken from the curve with coincident control points at the intersection of dir1 and dir2, which simplifies significantly with a little understanding about trigonometry, since the angle formed between mid, pt1 and the intersection is the same as between the center, pt1 and mid." length := mid r. "length is not only the distance from the center of the unit circle but also the sine of the angle between the circle's center, pt1 and mid (since center is at zero and pt1 has unit length). Therefore, to scale dir1 to the intersection with dir2 we can use mid's distance from pt1 and simply divide it by the sine value." scale := (mid dist: pt1). length > 0.0 ifTrue:[ scale := scale / length]. "now sample the cubic bezier (optimized version for coincident control points)" cp1 := pt1 + (dir1 * (scale * 0.75)). cp2 := pt2 - (dir2 * (scale * 0.75)). pt3 := cp1 + cp2 * 0.5. "compute the magic constant" scale := (pt3 - mid) r / scale. magic := 1.0 - length / scale. "and finally answer the pie segment" ^self from: pt1 via: pt1 + (dir1 * magic) and: pt2 - (dir2 * magic) to: pt2! ! !Bezier3Segment class methodsFor: 'instance creation' stamp: 'DSM 10/15/1999 15:23'! from: p1 to: p2 ^ self new from: p1 via: (p1 interpolateTo: p2 at: 0.3333) and: (p1 interpolateTo: p2 at: 0.66667) to: p2! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:25'! makeEllipseSegments: aRectangle "Answer a set of bezier segments approximating an ellipsoid fitting the given rectangle. This method creates four bezier segments (one for each quadrant) approximating the oval." "EXAMPLE: This example draws an oval with a red border and overlays the approximating bezier segments on top of the oval (drawn in black), thus giving an impression of how closely the bezier resembles the oval. Change the rectangle to see how accurate the approximation is for various radii of the oval. | rect | rect := 100@100 extent: 500@200. Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. (Bezier3Segment makeEllipseSegments: rect) do:[:seg| seg lineSegmentsDo:[:last :next| Display getCanvas line: last to: next width: 1 color: Color black]]. " "EXAMPLE: | minRadius maxRadius | maxRadius := 300. minRadius := 20. maxRadius to: minRadius by: -10 do:[:rad| | rect | rect := 400@400 - rad corner: 400@400 + rad. Display getCanvas fillOval: rect color: Color yellow borderWidth: 1 borderColor: Color red. (Bezier3Segment makeEllipseSegments: rect) do:[:seg| seg lineSegmentsDo:[:last :next| Display getCanvas line: last to: next width: 1 color: Color black]]]. " ^self makeEllipseSegments: aRectangle count: 4! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:59'! makeUnitPieSegmentFrom: angle1 to: angle2 "Create a clockwise unit pie segment from angle1 to angle2, that is a pie segment for a circle centered at zero with radius one. Note: This method can be used to create at most a quarter circle." | pt1 pt2 rad1 rad2 | rad1 := angle1 degreesToRadians. rad2 := angle2 degreesToRadians. pt1 := rad1 sin @ rad1 cos negated. pt2 := rad2 sin @ rad2 cos negated. ^self makeUnitPieSegmentWith: pt1 and: pt2! ! !Bezier3Segment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 03:53'! makePieSegments: aRectangle from: angle1 to: angle2 "Create a series of cubic bezier segments for the oval inscribed in aRectangle between angle1 and angle2. The segments are oriented clockwise, to get counter-clockwise segments simply switch angle1 and angle2." angle2 < angle1 ifTrue:[ "ccw segments" ^(self makePieSegments: aRectangle from: angle2 to: angle1) reversed collect:[:seg| seg reversed] ]. "Split up segments if larger than 120 degrees" angle2 - angle1 > 120 ifTrue:["subdivide" | midAngle | midAngle := angle1 + angle2 * 0.5. ^(self makePieSegments: aRectangle from: angle1 to: midAngle), (self makePieSegments: aRectangle from: midAngle to: angle2). ]. "Create actual pie segment" ^self makePieSegment: aRectangle from: angle1 to: angle2 ! ! !BigCogInitialState commentStamp: ''! I am the initial state! !BigCogInitialState methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 22:28'! nextState ^ BigCogState2 new! ! !BigCogInitialState methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 22:30'! stepTime ^ 50! ! !BigCogInitialState class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2013 22:41'! imageData ^ #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 144678815 1538898361 2327559099 2679814842 2595862969 2411313593 2109389498 1740290746 1287240121 783792055 229749169 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1186642618 3904617403 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3904617403 3250240186 2545597114 1790556601 767278011 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1169799609 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3116022458 515619771 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 246855350 3904617403 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3854219962 548911031 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2025569211 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3283860411 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3552230074 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1035516088 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 279949231 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2361047738 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1203485627 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3166354106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2143009723 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3686447802 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3065690810 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4038835131 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3988437690 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 129414838 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 649442741 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 481736374 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1589164216 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 850966712 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 93952409 1538898361 2881141434 3552230074 3652959163 3065690810 1807399610 279949231 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2528885691 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1220065464 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 314095800 1706802107 2847587002 3569007290 3703290811 3183131322 1639693243 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 448445114 3585850299 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4038835131 1622850234 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3451632571 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1589164216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 75530368 2327559099 4156275643 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2830875579 75530368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 397521329 3636181947 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2881141434 196721081 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 162179754 4223384507 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1958460347 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 397521329 3267083195 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2830875579 61516458 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 364295862 3585850299 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3535518651 599176886 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1035516088 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2327559099 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 934918585 3837508539 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2763766715 41975936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 330215086 3535518651 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4005214906 1236908473 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1958460347 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2696592058 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1723447737 4189764282 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2679814842 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 297055412 3485121210 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4256873146 2143009723 16777216 0 0 0 0 0 0 0 0 0 0 0 0 2897984443 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3048913594 0 0 0 0 0 0 0 0 0 0 0 0 0 129414838 2612705978 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2595862969 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 279949231 3434789562 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3065690810 314095800 0 0 0 0 0 0 0 0 0 0 0 3837508539 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3418012346 0 0 0 0 0 0 0 0 0 0 0 0 481736374 3384457914 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2495265466 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 246855350 3384457914 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3753556666 867809721 0 0 0 0 0 0 0 0 0 481736374 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3837508539 111848106 0 0 0 0 0 0 0 0 0 0 1069202106 3921328826 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2394667963 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 229749169 3350903482 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4172987066 1723447737 0 0 0 0 0 0 0 0 1404614840 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4005214906 2595862969 1085781943 41975936 0 0 0 0 0 0 1891351483 4223384507 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2277227451 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 3132799674 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2730146490 179549107 0 0 61516458 700169147 1471789497 2260384442 3535518651 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3837508539 2361047738 850966712 0 0 179549107 2780543931 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1891351483 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1907997113 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3552230074 2629483194 3418012346 4156275643 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3619338938 2143009723 3501898426 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4122655418 414561717 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3636181947 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1991948986 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2965093307 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 4055546554 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3166354106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3032202171 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2629483194 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1287240121 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1236908473 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3267083195 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3099245242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 666351543 4139498427 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3938106042 498710969 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1740290746 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4206607291 1035516088 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2881141434 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1824242619 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 279949231 3753556666 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2730146490 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 934918585 4206607291 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3518741435 162179754 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1958460347 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4055546554 632994490 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 3032202171 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1404614840 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 330215086 3803888314 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2428156602 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 968341431 4223384507 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3384457914 93952409 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1941617338 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4005214906 532002229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2948316091 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1354348985 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 279949231 3720068027 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2444933818 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2461776827 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1354348985 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3787176891 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2730146490 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 884652730 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3904617403 3434789562 3032202171 2612705978 2713435067 3132799674 3552230074 4055546554 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4022057915 93952409 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2277227451 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4256873146 3300571834 2008726202 716617398 0 0 0 0 0 0 0 61516458 1035516088 2327559099 3636181947 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1203485627 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3652959163 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2998581946 750369209 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1270594491 3535518651 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2595862969 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 733526200 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3451632571 985250233 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 1555741370 3904617403 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3921328826 41975936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2126166714 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2780543931 144678815 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 498710969 3485121210 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1069202106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3501898426 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 2059057850 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 179549107 2897984443 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2461776827 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 129414838 783792055 1505409722 2226764217 2948316091 3686447802 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1907997113 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 2914695866 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4223384507 3569007290 2830875579 2109389498 1354348985 632994490 41975936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 162179754 817543866 1522252731 2226764217 2931473082 3652959163 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2730146490 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 212511402 3552230074 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4139498427 3451632571 2713435067 1975105977 1236908473 498710969 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 464761779 1606007225 2327559099 3015424955 3720068027 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3434789562 144678815 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 599176886 4005214906 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4055546554 3334192059 2595862969 1857665465 1169799609 464761779 0 0 0 0 0 0 0 0 330215086 2780543931 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 767278011 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1740290746 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3401300923 1169799609 0 0 0 0 0 330215086 3585850299 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2814032570 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 93952409 3720068027 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1673116089 0 0 0 0 2998581946 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 649442741 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1572518586 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4172987066 397521329 0 0 1186642618 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2914695866 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 3854219962 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1907997113 0 0 3032202171 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1639693243 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2595862969 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2512108475 0 0 3619338938 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 397521329 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1337505976 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2814032570 0 0 3652959163 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3451632571 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 196721081 4206607291 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2797255354 0 0 3669670586 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2830875579 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3770399675 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2780543931 0 0 3686447802 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2428156602 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3350903482 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2763766715 0 0 3703290811 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2025569211 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2948316091 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2763766715 0 0 3703290811 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1824242619 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2730146490 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2763766715 0 0 3703290811 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2193275578 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3082533819 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2763766715 0 0 3686447802 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2595862969 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3501898426 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2780543931 0 0 3652959163 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3015424955 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3904617403 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2797255354 0 0 3619338938 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3921328826 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 532002229 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2830875579 0 0 3518741435 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 918075576 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1773910971 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2847587002 0 0 2965093307 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2176498362 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3032202171 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2495265466 0 0 1840888249 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3602561722 41975936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 347321267 4139498427 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1320860346 0 0 162179754 3602561722 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1522252731 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2344204729 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3350903482 41975936 0 0 0 481736374 3334192059 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3669670586 75530368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 431536312 4139498427 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3451632571 397521329 0 0 0 0 0 41975936 1354348985 2830875579 3736779450 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1773910971 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2595862969 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3971726267 2981804730 1589164216 61516458 0 0 0 0 0 0 0 0 0 0 196721081 884652730 1622850234 2344204729 3065690810 3787176891 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4156275643 867809721 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1538898361 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 3669670586 2965093307 2293938874 1622850234 968341431 347321267 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 229749169 951827387 1673116089 2394667963 3132799674 3854219962 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3803888314 381270457 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 850966712 4139498427 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3770399675 3015424955 2277227451 1538898361 800635064 129414838 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 279949231 1002093242 1740290746 4022057915 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3283860411 229749169 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 532002229 3787176891 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3736779450 1773910971 1002093242 246855350 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2713435067 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3585850299 582268084 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1018936251 3921328826 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2092546489 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1304017337 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3971726267 1085781943 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1656338873 4189764282 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 683260345 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 129414838 4072389563 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4256873146 2713435067 548911031 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 850966712 3116022458 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3569007290 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2797255354 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4189764282 2428156602 700169147 0 0 0 0 0 0 0 0 0 0 0 16777216 934918585 2847587002 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2176498362 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1404614840 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3703290811 2411313593 1287240121 817543866 397521329 41975936 75530368 464761779 884652730 1438300858 2646326203 3904617403 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 767278011 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 179549107 4122655418 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3669670586 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2897984443 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2260384442 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2025569211 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1253751482 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 666351543 4072389563 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3569007290 179549107 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 212511402 3602561722 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2763766715 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2881141434 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1773910971 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1941617338 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4172987066 901232567 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1069202106 4223384507 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3770399675 314095800 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 448445114 3904617403 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3065690810 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 93952409 3300571834 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2109389498 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2428156602 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4256873146 1152956600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1438300858 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3938106042 481736374 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 666351543 4072389563 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3334192059 93952409 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 179549107 3552230074 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2444933818 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2579217339 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1304017337 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 985250233 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3501898426 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3166354106 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 850966712 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 314095800 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1991948986 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 800635064 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2612705978 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 548911031 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2545597114 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3585850299 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1639693243 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1186642618 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 2293938874 1320860346 3166354106 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4189764282 3434789562 2579217339 1723447737 918075576 2797255354 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3753556666 229749169 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1555741370 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4038835131 1337505976 0 0 0 750369209 2579217339 4139498427 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2260384442 834057910 93952409 0 0 0 0 0 2042214841 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4089166779 918075576 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1622850234 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3518741435 616085688 0 0 0 0 0 0 314095800 2008726202 3803888314 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 397521329 0 0 0 0 0 0 0 0 1270594491 4038835131 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4105878202 1035516088 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1723447737 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2713435067 162179754 0 0 0 0 0 0 0 0 0 61516458 1421457849 3283860411 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3820665530 0 0 0 0 0 0 0 0 0 0 666351543 3602561722 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4105878202 1069202106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1824242619 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4189764282 1757067962 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3870997178 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2965093307 0 0 0 0 0 0 0 0 0 0 0 229749169 2931473082 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4122655418 1085781943 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1924840122 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3787176891 901232567 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3887840187 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2092546489 0 0 0 0 0 0 0 0 0 0 0 0 16777216 2008726202 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4122655418 1102624952 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2025569211 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3099245242 330215086 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3904617403 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1236908473 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1119467961 3921328826 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4139498427 1119467961 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2109389498 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 2176498362 41975936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3904617403 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 381270457 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 431536312 3250240186 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4139498427 1136310970 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2193275578 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3988437690 1236908473 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3870997178 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3803888314 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61516458 2210118587 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4189764282 1320860346 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1975105977 4223384507 4290493371 4290493371 4290493371 4290493371 4256873146 2881141434 532002229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3837508539 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2948316091 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1052359097 3485121210 4290493371 4290493371 4290493371 4290493371 4290493371 3736779450 1035516088 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 750369209 2277227451 2864364218 2713435067 1891351483 532002229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3787176891 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2092546489 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 1404614840 2512108475 3082533819 2713435067 1555741370 144678815 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3703290811 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1220065464 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3585850299 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 364295862 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3468409787 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3787176891 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3300571834 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2931473082 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3082533819 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2075900859 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2545597114 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1337505976 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1773910971 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 515619771 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 364295862 4172987066 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3602561722 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2327559099 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1958460347 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 129414838 3216751547 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3720068027 179549107 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 162179754 2663037626 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3787176891 750369209 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 918075576 2461776827 2629483194 2663037626 2696592058 2730146490 2763766715 2780543931 2797255354 2797255354 2780543931 2763766715 2730146490 2679814842 2495265466 1673116089 229749169 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 )! ! !BigCogInitialState class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2013 22:43'! size ^ 128! ! !BigCogState2 commentStamp: ''! Another state in the loading animation! !BigCogState2 methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 22:29'! nextState ^ BigCogState3 new! ! !BigCogState2 methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 22:30'! stepTime ^ 50! ! !BigCogState2 class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2013 16:22'! imageData ^ #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 297055412 884652730 448445114 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 532002229 2897984443 4256873146 4290493371 4290493371 3652959163 2444933818 1236908473 162179754 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1002093242 3971726267 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4156275643 3116022458 1891351483 683260345 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 867809721 4089166779 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3753556666 2528885691 1304017337 196721081 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 297055412 3803888314 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4055546554 2025569211 41975936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2059057850 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2981804730 75530368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 431536312 1757067962 2344204729 2210118587 1354348985 111848106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 3720068027 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2243607226 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 111848106 1471789497 3099245242 4256873146 4290493371 4290493371 4290493371 4290493371 3870997178 1354348985 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1136310970 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4139498427 297055412 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 565819833 2310716090 3954949051 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1874508474 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2830875579 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1287240121 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 968341431 2914695866 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4256873146 1287240121 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 347321267 4189764282 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1740290746 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1002093242 3183131322 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3971726267 431536312 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1924840122 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1538898361 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 347321267 2897984443 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3065690810 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3602561722 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1052359097 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 616085688 3770399675 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1790556601 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1002093242 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 364295862 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 3384457914 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4122655418 649442741 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2696592058 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4005214906 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1136310970 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3401300923 75530368 0 0 0 0 0 0 0 0 0 0 0 0 263961531 4122655418 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3401300923 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2293938874 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2176498362 0 0 0 0 0 0 0 0 0 0 0 0 1790556601 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2797255354 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2780543931 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4223384507 934918585 0 0 0 0 0 0 0 0 0 0 0 3485121210 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2226764217 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2696592058 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3669670586 196721081 0 0 0 0 0 0 0 0 0 884652730 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1656338873 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2109389498 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2545597114 0 0 0 0 0 0 0 0 75530368 2663037626 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1102624952 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 968341431 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1253751482 0 0 263961531 1035516088 1840888249 2629483194 3434789562 4156275643 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 565819833 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 3870997178 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3904617403 2948316091 3753556666 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4256873146 75530368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2512108475 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3820665530 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1152956600 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3300571834 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 75530368 3988437690 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2797255354 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2696592058 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2310716090 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1320860346 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1975105977 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 330215086 1874508474 2948316091 3300571834 2830875579 1354348985 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 144678815 4089166779 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4089166779 1169799609 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 75530368 1304017337 2881141434 4172987066 4290493371 4290493371 4290493371 4290493371 4290493371 2814032570 61516458 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2864364218 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4189764282 1488566713 0 0 0 0 0 0 0 0 0 0 0 0 0 850966712 2428156602 3938106042 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2210118587 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1488566713 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 1857665465 0 0 0 0 0 0 0 0 0 448445114 1975105977 3569007290 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 783792055 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 246855350 4172987066 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2260384442 0 0 0 0 0 179549107 1538898361 3116022458 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3166354106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3032202171 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2663037626 61516458 16777216 1069202106 2663037626 4072389563 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1337505976 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1673116089 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3334192059 3770399675 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3703290811 111848106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 347321267 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1991948986 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3216751547 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4072389563 414561717 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1840888249 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2679814842 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1505409722 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 918075576 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1740290746 4223384507 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3367680698 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 196721081 834057910 1236908473 951827387 565819833 41975936 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 2377824954 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1488566713 0 0 0 0 0 0 0 0 0 0 0 0 649442741 2797255354 4172987066 4290493371 4290493371 4290493371 4290493371 4156275643 3518741435 2881141434 2243607226 1622850234 1018936251 431536312 0 0 0 0 0 0 196721081 2965093307 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3048913594 0 0 0 0 0 0 0 0 0 0 0 1438300858 4139498427 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4105878202 3535518651 2948316091 2377824954 1807399610 1320860346 3451632571 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3703290811 0 0 0 0 0 0 0 0 0 0 1102624952 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3535518651 0 0 0 0 0 0 0 0 0 0 3703290811 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2428156602 0 0 0 0 0 0 0 0 0 733526200 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4072389563 464761779 0 0 0 0 0 0 0 0 0 1824242619 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4156275643 1270594491 0 0 0 0 0 0 0 0 0 0 2914695866 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3971726267 1102624952 0 0 0 0 0 0 0 0 0 0 16777216 3988437690 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4206607291 3350903482 2344204729 1555741370 1371191994 1236908473 1102624952 1438300858 2176498362 2914695866 3686447802 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3434789562 532002229 0 0 0 0 0 0 0 0 0 0 0 817543866 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3317349050 1388035003 162179754 0 0 0 0 0 0 0 0 0 0 834057910 2512108475 4022057915 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2746923706 144678815 0 0 0 0 0 0 0 0 0 0 0 0 1924840122 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3082533819 968341431 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 162179754 1874508474 4089166779 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 1941617338 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3015424955 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4139498427 1773910971 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 515619771 3048913594 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4038835131 1220065464 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61516458 4055546554 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3569007290 700169147 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1790556601 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3669670586 666351543 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 934918585 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3652959163 381270457 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1572518586 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3166354106 297055412 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2042214841 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3787176891 498710969 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1404614840 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2545597114 75530368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3032202171 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4156275643 683260345 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2176498362 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 1840888249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3585850299 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2092546489 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 75530368 3350903482 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4055546554 1220065464 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3485121210 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3619338938 111848106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 582268084 4122655418 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 951827387 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2461776827 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1220065464 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2444933818 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1102624952 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 464761779 4038835131 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3803888314 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 548911031 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2008726202 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1052359097 4038835131 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2243607226 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2814032570 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2914695866 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 599176886 3199974331 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 666351543 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1287240121 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3820665530 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1236908473 3283860411 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3837508539 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 279949231 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 431536312 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 901232567 2797255354 4223384507 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3183131322 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3485121210 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1354348985 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 481736374 2277227451 3971726267 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2512108475 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2512108475 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2260384442 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 162179754 1706802107 3552230074 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1891351483 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2193275578 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3250240186 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1085781943 2914695866 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1857665465 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1991948986 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3703290811 1941617338 314095800 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 498710969 2260384442 3938106042 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2059057850 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1790556601 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4139498427 2679814842 884652730 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 129414838 3334192059 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2260384442 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1857665465 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3401300923 1622850234 144678815 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2260384442 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2595862969 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2495265466 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3988437690 2361047738 599176886 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1320860346 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3585850299 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3149642683 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 3082533819 1304017337 41975936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 397521329 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 347321267 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3820665530 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3770399675 1991948986 144678815 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3753556666 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1388035003 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 666351543 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3569007290 632994490 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2830875579 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2931473082 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2260384442 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3938106042 683260345 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1891351483 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4256873146 649442741 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 3803888314 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3652959163 129414838 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 968341431 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2579217339 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1253751482 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1824242619 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1035516088 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4172987066 700169147 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 129414838 3652959163 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3099245242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1505409722 4156275643 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3485121210 111848106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2143009723 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3418012346 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 2243607226 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2344204729 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 733526200 4172987066 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2931473082 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 212511402 2948316091 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 1589164216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 548911031 3837508539 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1907997113 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 548911031 3518741435 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 1757067962 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 431536312 3703290811 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 783792055 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1052359097 3938106042 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2008726202 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 783792055 3636181947 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3938106042 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1723447737 4206607291 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3233462970 632994490 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 1891351483 4172987066 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2847587002 0 0 0 0 0 0 0 0 0 0 0 0 0 75530368 2495265466 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4156275643 2059057850 246855350 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1102624952 3216751547 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1723447737 0 0 0 0 0 0 0 0 0 0 0 0 330215086 3199974331 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4122655418 2696592058 1018936251 0 0 0 0 0 0 0 0 0 0 263961531 1522252731 3451632571 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 582268084 0 0 0 0 0 0 0 0 0 0 0 767278011 3736779450 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3854219962 3082533819 2344204729 1606007225 1270594491 1404614840 1538898361 1706802107 2495265466 3501898426 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3753556666 0 0 0 0 0 0 0 0 0 0 0 1253751482 4105878202 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2612705978 0 0 0 0 0 0 0 0 0 0 934918585 4156275643 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1522252731 0 0 0 0 0 0 0 0 0 0 3367680698 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 548911031 0 0 0 0 0 0 0 0 0 616085688 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3350903482 0 0 0 0 0 0 0 0 0 0 1455143867 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1169799609 0 0 0 0 0 0 0 0 0 0 1757067962 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3451632571 1136310970 1723447737 2444933818 3132799674 3820665530 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2176498362 0 0 0 0 0 0 0 0 0 0 0 1572518586 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3048913594 212511402 0 0 0 0 0 212511402 850966712 1488566713 2109389498 2713435067 3300571834 3854219962 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 3753556666 1505409722 0 0 0 0 0 0 0 0 0 0 0 0 884652730 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2595862969 61516458 0 0 0 0 0 0 0 0 0 0 0 0 0 144678815 616085688 1119467961 1354348985 1253751482 817543866 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3116022458 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2075900859 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 733526200 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1941617338 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2512108475 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2210118587 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 330215086 4005214906 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3652959163 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1874508474 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 817543866 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 75530368 3602561722 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3283860411 2965093307 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2277227451 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1186642618 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3753556666 2193275578 599176886 0 0 2277227451 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3720068027 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2965093307 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4089166779 2663037626 1085781943 16777216 0 0 0 0 0 1857665465 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 884652730 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 565819833 4156275643 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4256873146 3166354106 1572518586 179549107 0 0 0 0 0 0 0 0 0 1455143867 4189764282 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2327559099 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1773910971 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3636181947 2059057850 498710969 0 0 0 0 0 0 0 0 0 0 0 0 0 1119467961 4055546554 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3770399675 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2008726202 4189764282 4290493371 4290493371 4290493371 4290493371 4005214906 2545597114 934918585 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 817543866 3887840187 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 951827387 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 498710969 1790556601 2277227451 2059057850 1236908473 129414838 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1874508474 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2394667963 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2411313593 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3820665530 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3015424955 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1002093242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3619338938 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2461776827 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 4172987066 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3870997178 41975936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 515619771 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1253751482 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1119467961 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4105878202 3619338938 3132799674 2646326203 2143009723 1656338873 1169799609 683260345 397521329 3870997178 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2646326203 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1706802107 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3418012346 314095800 0 0 0 0 0 0 0 0 0 1639693243 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3636181947 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2277227451 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1656338873 0 0 0 0 0 0 0 0 0 0 41975936 3418012346 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4206607291 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2864364218 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4038835131 179549107 0 0 0 0 0 0 0 0 0 0 0 985250233 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4223384507 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3434789562 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2461776827 0 0 0 0 0 0 0 0 0 0 0 0 0 2730146490 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3602561722 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4005214906 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 733526200 0 0 0 0 0 0 0 0 0 0 0 0 0 431536312 4055546554 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1891351483 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 263961531 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3267083195 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1891351483 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2646326203 61516458 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 817543866 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1522252731 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61516458 3501898426 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3837508539 1471789497 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1354348985 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3954949051 129414838 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 951827387 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4189764282 2277227451 212511402 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1723447737 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2327559099 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2461776827 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2965093307 599176886 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1840888249 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 616085688 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 212511402 3569007290 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3552230074 1152956600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1622850234 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3132799674 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 582268084 3854219962 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3938106042 1757067962 61516458 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 716617398 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1388035003 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 397521329 2998581946 4290493371 4290493371 4290493371 4290493371 4290493371 4189764282 2344204729 263961531 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3250240186 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3870997178 75530368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 767278011 2059057850 2763766715 2914695866 2444933818 582268084 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 649442741 3938106042 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2193275578 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 481736374 2780543931 4139498427 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4022057915 381270457 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 111848106 1136310970 2361047738 3585850299 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1455143867 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 515619771 1723447737 2948316091 4072389563 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 1891351483 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 93952409 1069202106 2277227451 3468409787 4273716155 4290493371 4290493371 3569007290 1203485627 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 297055412 817543866 532002229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 )! ! !BigCogState2 class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2013 22:43'! size ^ 128! ! !BigCogState3 commentStamp: ''! The last state of the loading animation! !BigCogState3 methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 22:28'! nextState ^ BigCogInitialState new! ! !BigCogState3 methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 22:30'! stepTime ^ 50! ! !BigCogState3 class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2013 16:23'! imageData ^ #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 498710969 1002093242 1471789497 1891351483 2260384442 2210118587 1371191994 162179754 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 464761779 1371191994 2210118587 2931473082 3619338938 4189764282 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3870997178 1388035003 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 431536312 2243607226 3669670586 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 1673116089 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1220065464 4055546554 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4172987066 733526200 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 767278011 1874508474 2126166714 1354348985 93952409 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 716617398 4139498427 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2814032570 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 918075576 3267083195 4290493371 4290493371 4290493371 4290493371 3720068027 1304017337 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3032202171 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 448445114 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 2226764217 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3032202171 599176886 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 381270457 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1958460347 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2444933818 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4172987066 2210118587 162179754 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1354348985 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3501898426 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1354348985 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3770399675 1371191994 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1824242619 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 750369209 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 515619771 4005214906 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3082533819 632994490 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1773910971 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2293938874 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 75530368 3317349050 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4189764282 2226764217 111848106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1572518586 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3803888314 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2260384442 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3132799674 129414838 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1371191994 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1085781943 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1152956600 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2377824954 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1169799609 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2629483194 0 0 0 0 0 0 0 0 0 0 0 0 0 397521329 3904617403 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4206607291 464761779 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 968341431 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4038835131 129414838 0 0 0 0 0 0 0 0 0 0 0 16777216 3132799674 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1706802107 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 767278011 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1404614840 0 0 0 0 0 0 0 0 0 0 0 2042214841 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2243607226 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 565819833 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2948316091 0 0 0 0 0 0 0 0 0 0 985250233 4223384507 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2008726202 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 364295862 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4189764282 297055412 0 0 0 0 0 0 0 0 297055412 3787176891 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 934918585 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 179549107 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2713435067 1706802107 1371191994 1035516088 700169147 364295862 61516458 0 0 2948316091 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3753556666 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 3988437690 3753556666 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1924840122 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4072389563 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4072389563 246855350 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3870997178 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2495265466 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3669670586 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 683260345 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 196721081 783792055 951827387 498710969 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3468409787 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3166354106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 750369209 2914695866 4172987066 4290493371 4290493371 4290493371 3753556666 2277227451 599176886 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3267083195 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1388035003 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1706802107 4206607291 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4256873146 2931473082 1035516088 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3065690810 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3854219962 75530368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 985250233 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3468409787 1622850234 144678815 0 0 0 0 0 0 0 0 0 0 0 0 2864364218 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2176498362 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3367680698 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3954949051 2277227451 515619771 0 0 0 0 0 0 0 0 364295862 2243607226 4072389563 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 498710969 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1488566713 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 2948316091 1136310970 0 0 0 0 498710969 2444933818 4139498427 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3015424955 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 129414838 3753556666 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3619338938 1857665465 834057910 2646326203 4206607291 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1304017337 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2008726202 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3837508539 61516458 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 364295862 4055546554 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2210118587 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2528885691 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1656338873 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 716617398 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3921328826 314095800 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3065690810 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2696592058 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1186642618 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1169799609 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3132799674 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3736779450 179549107 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 279949231 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2377824954 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 397521329 867809721 800635064 179549107 0 0 0 0 0 0 0 0 0 0 0 0 0 649442741 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 901232567 0 0 0 0 279949231 666351543 1069202106 1471789497 1874508474 2260384442 2663037626 3065690810 3468409787 3854219962 4223384507 4290493371 4290493371 4290493371 4156275643 2629483194 279949231 0 0 0 0 0 0 0 0 0 0 0 162179754 4206607291 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3720068027 2981804730 3367680698 3770399675 4172987066 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3485121210 162179754 0 0 0 0 0 0 0 0 0 0 0 2881141434 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2143009723 0 0 0 0 0 0 0 0 0 0 0 616085688 4072389563 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3820665530 41975936 0 0 0 0 0 0 0 0 0 0 0 1287240121 4206607291 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 850966712 0 0 0 0 0 0 0 0 0 0 0 0 1287240121 4105878202 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1958460347 0 0 0 0 0 0 0 0 0 0 0 0 0 834057910 3787176891 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3753556666 3032202171 2310716090 1706802107 1757067962 1874508474 2008726202 2528885691 3535518651 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3099245242 0 0 0 0 0 0 0 0 0 0 0 0 0 0 364295862 3233462970 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3803888314 2226764217 616085688 0 0 0 0 0 0 0 0 0 279949231 1320860346 3132799674 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4122655418 111848106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 75530368 2478488250 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3803888314 1404614840 41975936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 834057910 2797255354 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1069202106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1622850234 4156275643 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 2394667963 212511402 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1102624952 3854219962 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2210118587 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 884652730 3803888314 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4072389563 1102624952 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 347321267 3048913594 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3367680698 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 364295862 3183131322 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3988437690 901232567 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 2562374330 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 279949231 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61516458 2310716090 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4005214906 750369209 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 2914695866 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1404614840 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1388035003 4072389563 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1438300858 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 129414838 3233462970 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2562374330 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 649442741 3652959163 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2696592058 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 498710969 4105878202 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3585850299 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2562374330 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3787176891 229749169 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1991948986 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3837508539 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2780543931 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1857665465 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 93952409 3602561722 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3317349050 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2998581946 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4038835131 229749169 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1639693243 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1874508474 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3199974331 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2377824954 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 229749169 4122655418 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3418012346 93952409 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3418012346 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 834057910 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2746923706 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3048913594 263961531 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3619338938 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4105878202 61516458 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1354348985 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3233462970 1186642618 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3837508539 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3233462970 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 565819833 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4172987066 2663037626 783792055 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4038835131 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2327559099 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 4122655418 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3988437690 2210118587 414561717 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 548911031 2461776827 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1975105977 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3418012346 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3753556666 1840888249 196721081 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 834057910 2797255354 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1891351483 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3183131322 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3485121210 1505409722 61516458 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1186642618 3149642683 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1790556601 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3283860411 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3233462970 1220065464 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 75530368 1538898361 3501898426 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1840888249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3367680698 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 2981804730 951827387 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 229749169 1924840122 3803888314 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2512108475 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3552230074 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2780543931 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 481736374 2327559099 4038835131 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3233462970 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 162179754 4206607291 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2512108475 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 750369209 2746923706 4206607291 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3954949051 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1018936251 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2277227451 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2210118587 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 850966712 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1958460347 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2042214841 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2109389498 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2444933818 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3233462970 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1807399610 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 582268084 4206607291 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3938106042 93952409 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 817543866 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1589164216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2310716090 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1538898361 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2713435067 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1354348985 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3518741435 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3854219962 229749169 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 498710969 4189764282 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1119467961 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 4223384507 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2377824954 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 3166354106 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1354348985 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61516458 4105878202 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4223384507 951827387 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1924840122 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4172987066 1723447737 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3082533819 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3971726267 683260345 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 850966712 4172987066 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2713435067 162179754 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1958460347 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3787176891 464761779 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 918075576 4005214906 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3535518651 632994490 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 834057910 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3703290811 834057910 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1102624952 4089166779 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4055546554 1388035003 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 3971726267 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4189764282 1857665465 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 75530368 1975105977 4156275643 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2361047738 75530368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2864364218 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3065690810 850966712 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 951827387 3518741435 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3267083195 431536312 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1723447737 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3149642683 1169799609 0 0 0 0 0 0 0 0 0 0 0 129414838 1455143867 3082533819 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3904617403 1085781943 0 0 0 0 0 0 0 0 0 0 0 0 0 0 565819833 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3904617403 2897984443 1891351483 951827387 666351543 532002229 397521329 548911031 1253751482 1958460347 2730146490 4005214906 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 2008726202 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 3686447802 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2981804730 212511402 0 0 0 0 0 0 0 0 0 0 0 0 2512108475 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3116022458 41975936 0 0 0 0 0 0 0 0 0 0 0 1253751482 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1991948986 0 0 0 0 0 0 0 0 0 0 0 61516458 3753556666 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4105878202 314095800 0 0 0 0 0 0 0 0 0 0 0 1236908473 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4189764282 3837508539 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1824242619 0 0 0 0 0 0 0 0 0 0 0 0 1186642618 3669670586 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4005214906 3602561722 3183131322 2780543931 2377824954 1958460347 1555741370 1136310970 733526200 330215086 0 0 2948316091 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2797255354 0 0 0 0 0 0 0 0 0 0 0 0 0 0 850966712 1572518586 1689959098 1354348985 934918585 532002229 129414838 0 0 0 0 0 0 0 0 0 0 0 0 448445114 4038835131 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2864364218 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1689959098 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2025569211 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3199974331 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4156275643 448445114 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 599176886 4139498427 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2226764217 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1958460347 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3887840187 212511402 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61516458 3418012346 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1656338873 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3166354106 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3468409787 41975936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 700169147 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1069202106 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2512108475 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3367680698 2126166714 3787176891 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2914695866 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 246855350 4089166779 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3334192059 1203485627 0 0 75530368 1505409722 3434789562 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4172987066 582268084 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1857665465 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3300571834 1169799609 0 0 0 0 0 0 0 1069202106 2965093307 4256873146 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2361047738 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 16777216 3636181947 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2075900859 0 0 0 0 0 0 0 0 0 0 0 582268084 2394667963 4038835131 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3988437690 347321267 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1169799609 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1840888249 0 0 0 0 0 0 0 0 0 0 0 0 0 196721081 1757067962 3535518651 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 1320860346 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2965093307 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2126166714 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1018936251 2730146490 4139498427 4290493371 4290493371 4290493371 4290493371 4290493371 4038835131 1404614840 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 515619771 4240095930 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2394667963 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 279949231 1522252731 2579217339 3183131322 2965093307 1991948986 397521329 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2243607226 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2663037626 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 111848106 3921328826 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2931473082 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1505409722 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3199974331 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3267083195 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3485121210 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 716617398 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3384457914 1270594491 1907997113 2545597114 3183131322 3820665530 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3753556666 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2159655353 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4005214906 532002229 0 0 0 0 0 179549107 800635064 1438300858 2075900859 2981804730 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4022057915 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3418012346 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1320860346 0 0 0 0 0 0 0 0 0 0 196721081 4206607291 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4256873146 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4055546554 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2344204729 0 0 0 0 0 0 0 0 0 0 0 0 3283860411 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 263961531 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4172987066 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3334192059 75530368 0 0 0 0 0 0 0 0 0 0 0 0 2143009723 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 532002229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3418012346 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3971726267 498710969 0 0 0 0 0 0 0 0 0 0 0 0 0 985250233 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 817543866 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1723447737 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 1253751482 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61516458 4038835131 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1085781943 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 2881141434 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2277227451 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2914695866 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1438300858 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 1874508474 4022057915 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3267083195 61516458 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1689959098 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1807399610 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 381270457 2679814842 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3938106042 448445114 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 464761779 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1874508474 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 985250233 3485121210 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4256873146 1186642618 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3468409787 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 1572518586 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 61516458 1807399610 4005214906 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2193275578 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2176498362 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 783792055 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 364295862 2629483194 4273716155 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 2847587002 61516458 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 817543866 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3602561722 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 934918585 3401300923 4290493371 4290493371 4290493371 4290493371 4290493371 4206607291 2126166714 16777216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3501898426 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4240095930 1203485627 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 1522252731 3216751547 3870997178 3636181947 2512108475 649442741 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1538898361 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 3485121210 1203485627 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2965093307 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4139498427 3099245242 1907997113 683260345 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 212511402 3032202171 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4290493371 4273716155 3451632571 2310716090 1152956600 144678815 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41975936 1639693243 3619338938 4290493371 4290493371 4290493371 3686447802 2562374330 1438300858 330215086 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 632994490 1253751482 498710969 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 )! ! !BigCogState3 class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2013 22:43'! size ^ 128! ! !BitBlt commentStamp: ''! I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm. The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm. If both are specified, their pixel values are combined with a logical AND function prior to transfer. In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule. The combination rule whose value is 0 through 15 programs the transfer to produce 1 or 0 according to its 4-bit representation as follows: 8: if source is 0 and destination is 0 4: if source is 0 and destination is 1 2: if source is 1 and destination is 0 1: if source is 1 and destination is 1. At each pixel the corresponding bits of the source and destination pixel values determine one of these conditions; if the combination rule has a 1 in the corresponding bit position, then the new destination value will be 1, otherwise it will be zero. Forms may be of different depths, see the comment in class Form. In addition to the original 16 combination rules, this BitBlt supports 16 fails (to simulate paint bits) 17 fails (to simulate erase bits) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord. Sum of color components 21 rgbSub: sourceWord with: destinationWord. Difference of color components 22 OLDrgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 23 OLDtallyIntoMap: destinationWord. Tallies pixValues into a colorMap these old versions don't do bitwise dest clipping. Use 32 and 33 now. 24 alphaBlend: sourceWord with: destinationWord. 32-bit source and dest only 25 pixPaint: sourceWord with: destinationWord. Wherever the sourceForm is non-zero, it replaces the destination. Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor to fill the dest with that color wherever the source is 1. 26 pixMask: sourceWord with: destinationWord. Like pixPaint, but fills with 0. 27 rgbMax: sourceWord with: destinationWord. Max of each color component. 28 rgbMin: sourceWord with: destinationWord. Min of each color component. 29 rgbMin: sourceWord bitInvert32 with: destinationWord. Min with (max-source) 30 alphaBlendConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 31 alphaPaintConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 32 rgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 33 tallyIntoMap: destinationWord. Tallies pixValues into a colorMap 34 alphaBlendScaled: srcWord with: dstWord. Alpha blend of scaled srcWord and destWord. The color specified by halftoneForm may be either a Color or a Pattern. A Color is converted to a pixelValue for the depth of the destinationForm. If a Pattern, BitBlt will simply interpret its bitmap as an array of Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. Within each scan line the 32-bit value is repeated from left to right across the form. If the value repeats on pixels boudaries, the effect will be a constant color; if not, it will produce a halftone that repeats on 32-bit boundaries. Any transfer specified is further clipped by the specified rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms. To make a small Form repeat and fill a big form, use an InfiniteForm as the source. To write on a form and leave with both transparent and opapue areas, use a MaskedForm as the source. Pixels from a source to a destination whose pixels have a different depth are converted based on the optional colorMap. If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits. The colorMap, if specified, must be a either word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source, or a fully specified ColorMap which may contain a lookup table (ie Bitmap) and/or four separate masks and shifts which are applied to the pixels. For every source pixel, BitBlt will first perform masking and shifting and then index the lookup table, and select the corresponding pixelValue and mask it to the destination pixel size before storing. When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation. This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color. Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped. The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1. Two other sized of colorMaps are allowed, 4096 (4 bits per color) and 32786 (five bits per color). Normal blits between 16 and 32 bit forms truncates or pads the colors automatically to provide the best preservation of colors. Colors can be remapped at the same depth. Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file. Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of. MaskedForm will use the colorMap when copying to the display or another Form. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copyBits "Primitive. Perform the movement of bits from the source form to the destination form. Fail if any variables are not of the right type (Integer, Float, or Form) or if the combination rule is not implemented. In addition to the original 16 combination rules, this BitBlt supports 16 fail (to simulate paint) 17 fail (to simulate mask) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord 21 rgbSub: sourceWord with: destinationWord 22 rgbDiff: sourceWord with: destinationWord 23 tallyIntoMap: destinationWord 24 alphaBlend: sourceWord with: destinationWord 25 pixPaint: sourceWord with: destinationWord 26 pixMask: sourceWord with: destinationWord 27 rgbMax: sourceWord with: destinationWord 28 rgbMin: sourceWord with: destinationWord 29 rgbMin: sourceWord bitInvert32 with: destinationWord " "Check for compressed source, destination or halftone forms" (combinationRule >= 30 and: [ combinationRule <= 31 ]) ifTrue: [ "No alpha specified -- re-run with alpha = 1.0" ^ self copyBitsTranslucent: 255 ]. (sourceForm isForm and: [ sourceForm unhibernate ]) ifTrue: [ ^ self copyBits ]. (destForm isForm and: [ destForm unhibernate ]) ifTrue: [ ^ self copyBits ]. (halftoneForm isForm and: [ halftoneForm unhibernate ]) ifTrue: [ ^ self copyBits ]. "Check for unimplmented rules" combinationRule = Form oldPaint ifTrue: [ ^ self paintBits ]. combinationRule = Form oldErase1bitShape ifTrue: [ ^ self eraseBits ]. "Check if BitBlt doesn't support full color maps" (colorMap notNil and: [ colorMap isColormap ]) ifTrue: [ colorMap := colorMap colors. ^ self copyBits ]. "Check if clipping gots us way out of range" self clipRange ifTrue: [ self roundVariables. ^ self copyBitsAgain ]. self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'. "Convert all numeric parameters to integers and try again." self roundVariables. ^ self copyBitsAgain! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipX ^clipX! ! !BitBlt methodsFor: 'accessing' stamp: ''! colorMap ^ colorMap! ! !BitBlt methodsFor: 'accessing' stamp: ''! sourceForm ^ sourceForm! ! !BitBlt methodsFor: '*Graphics-Fonts' stamp: 'Henrik Sperre Johansen 9/1/2009 22:40'! displayGlyph: aForm at: aPoint left: leftX right: rightX font: aFont "Display a glyph in a multi-lingual font. Do 2 pass rendering if necessary. This happens when #installStrikeFont:foregroundColor:backgroundColor: sets rule 37 (rgbMul). the desired effect is to do two bitblt calls. The first one is with rule 37 and special colormap. The second one is rule 34, with a colormap for applying the requested foreground color. This two together do component alpha blending, i.e. alpha blend red, green and blue separatedly. This is needed for arbitrary color over abitrary background text with subpixel AA." | prevRule secondPassMap | self sourceForm: aForm. destX := aPoint x. destY := aPoint y. sourceX := leftX. sourceY := 0. width := rightX - leftX. height := aFont height. combinationRule = 37 ifTrue:[ "We need to do a second pass. The colormap set is for use in the second pass." secondPassMap := colorMap. colorMap := sourceForm depth = destForm depth ifFalse: [ self cachedFontColormapFrom: sourceForm depth to: destForm depth ]. self copyBits. prevRule := combinationRule. combinationRule := 20. "rgbAdd" colorMap := secondPassMap. self copyBits. combinationRule := prevRule. ] ifFalse:[self copyBits].! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! pixelAt: aPoint put: pixelValue "Assumes this BitBlt has been set up specially (see the init message, BitBlt bitPokerToForm:. Overwrites the pixel at aPoint." destX := aPoint x. destY := aPoint y. sourceForm unhibernate. "before poking" sourceForm bits at: 1 put: pixelValue. self copyBits " | bb | bb := (BitBlt bitPokerToForm: Display). [Sensor anyButtonPressed] whileFalse: [bb pixelAt: Sensor cursorPoint put: 55] "! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipHeight ^clipHeight! ! !BitBlt methodsFor: 'copying' stamp: 'nk 4/17/2004 19:42'! copyBitsTranslucent: factor "This entry point to BitBlt supplies an extra argument to specify translucency for operations 30 and 31. The argument must be an integer between 0 and 255." "Check for compressed source, destination or halftone forms" ((sourceForm isForm) and: [sourceForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. ((destForm isForm) and: [destForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. ((halftoneForm isForm) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. self primitiveFailed "Later do nicer error recovery -- share copyBits recovery"! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipX: anInteger "Set the receiver's clipping area top left x coordinate to be the argument, anInteger." clipX := anInteger! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! destOrigin: aPoint "Set the receiver's destination top left coordinates to be those of the argument, aPoint." destX := aPoint x. destY := aPoint y! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copyForm: srcForm to: destPt rule: rule color: color sourceForm := srcForm. halftoneForm := color. combinationRule := rule. destX := destPt x + sourceForm offset x. destY := destPt y + sourceForm offset y. sourceX := 0. sourceY := 0. width := sourceForm width. height := sourceForm height. self copyBits! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! copyBitsFrom: x0 to: x1 at: y destX := x0. destY := y. sourceX := x0. width := x1 - x0. self copyBits! ! !BitBlt methodsFor: 'accessing' stamp: ''! fillColor ^ halftoneForm! ! !BitBlt methodsFor: 'private' stamp: 'MarcusDenker 9/13/2013 14:06'! paintBits "Perform the paint operation, which requires two calls to BitBlt." | color oldMap saveRule | sourceForm depth = 1 ifFalse: [ ^ self error: 'paint operation is only defined for 1-bit deep sourceForms' ]. saveRule := combinationRule. color := halftoneForm. halftoneForm := nil. oldMap := colorMap. "Map 1's to ALL ones, not just one" self colorMap: (Bitmap with: 0 with: 4294967295). combinationRule := Form erase. self copyBits. "Erase the dest wherever the source is 1" halftoneForm := color. combinationRule := Form under. self copyBits. "then OR, with whatever color, into the hole" colorMap := oldMap. combinationRule := saveRule " | dot | dot := Form dotOfSize: 32. ((BitBlt destForm: Display sourceForm: dot fillColor: Color lightGray combinationRule: Form paint destOrigin: Sensor cursorPoint sourceOrigin: 0@0 extent: dot extent clipRect: Display boundingBox) colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) copyBits"! ! !BitBlt methodsFor: 'accessing' stamp: ''! clipRect "Answer the receiver's clipping area rectangle." ^clipX @ clipY extent: clipWidth @ clipHeight! ! !BitBlt methodsFor: 'copying' stamp: 'ar 5/14/2001 23:32'! copyForm: srcForm to: destPt rule: rule ^ self copyForm: srcForm to: destPt rule: rule colorMap: (srcForm colormapIfNeededFor: destForm)! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! sourceRect: aRectangle "Set the receiver's source form top left x and y, width and height to be the top left coordinate and extent of the argument, aRectangle." sourceX := aRectangle left. sourceY := aRectangle top. width := aRectangle width. height := aRectangle height! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! width: anInteger "Set the receiver's destination form width to be the argument, anInteger." width := anInteger! ! !BitBlt methodsFor: 'line drawing' stamp: 'lr 7/4/2009 10:42'! drawFrom: startPoint to: stopPoint withFirstPoint: drawFirstPoint "Draw a line whose end points are startPoint and stopPoint. The line is formed by repeatedly calling copyBits at every point along the line. If drawFirstPoint is false, then omit the first point so as not to overstrike at line junctions." "Always draw down, or at least left-to-right" | offset point1 point2 forwards | forwards := (startPoint y = stopPoint y and: [ startPoint x < stopPoint x ]) or: [ startPoint y < stopPoint y ]. forwards ifTrue: [ point1 := startPoint. point2 := stopPoint ] ifFalse: [ point1 := stopPoint. point2 := startPoint ]. sourceForm == nil ifTrue: [ destX := point1 x. destY := point1 y ] ifFalse: [ width := sourceForm width. height := sourceForm height. offset := sourceForm offset. destX := (point1 x + offset x) rounded. destY := (point1 y + offset y) rounded ]. "Note that if not forwards, then the first point is the last and vice versa. We agree to always paint stopPoint, and to optionally paint startPoint." (drawFirstPoint or: [ forwards == false "ie this is stopPoint" ]) ifTrue: [ self copyBits ]. self drawLoopX: (point2 x - point1 x) rounded Y: (point2 y - point1 y) rounded. (drawFirstPoint or: [ "ie this is stopPoint" forwards ]) ifTrue: [ self copyBits ]! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipY ^clipY! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! sourceX: anInteger "Set the receiver's source form top left x to be the argument, anInteger." sourceX := anInteger! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copyForm: srcForm to: destPt rule: rule colorMap: map sourceForm := srcForm. halftoneForm := nil. combinationRule := rule. destX := destPt x + sourceForm offset x. destY := destPt y + sourceForm offset y. sourceX := 0. sourceY := 0. width := sourceForm width. height := sourceForm height. colorMap := map. self copyBits! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! tallyMap: aBitmap "Install the map used for tallying pixels" colorMap := aBitmap! ! !BitBlt methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:05'! fillColor: aColorOrPattern "The destForm will be filled with this color or pattern of colors. May be an old Color, a new type Color, a Bitmap (see BitBlt comment), a Pattern, or a Form." aColorOrPattern == nil ifTrue: [ halftoneForm := nil. ^ self ]. destForm == nil ifTrue: [ self error: 'Must set destForm first' ]. halftoneForm := destForm bitPatternFor: aColorOrPattern! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipWidth ^clipWidth! ! !BitBlt methodsFor: 'accessing' stamp: 'tbn 9/14/2004 20:39'! halftoneForm: aBitmap "Sets the receivers half tone form. See class commment." halftoneForm := aBitmap ! ! !BitBlt methodsFor: 'private' stamp: 'HenrikSperreJohansen 8/31/2010 22:56'! primDisplayString: aString from: startIndex to: stopIndex map: glyphMap xTable: xTable kern: kernDelta | ascii | startIndex to: stopIndex do: [ :charIndex | ascii := (aString at: charIndex) asciiValue. glyphMap ifNotNil: [:map | ascii := map at: ascii +1]. sourceX := xTable at: ascii + 1. width := (xTable at: ascii + 2) - sourceX. self copyBits. destX := destX + width + kernDelta ]! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipWidth: anInteger "Set the receiver's clipping area width to be the argument, anInteger." clipWidth := anInteger! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setDestForm: df | bb | bb := df boundingBox. destForm := df. clipX := bb left. clipY := bb top. clipWidth := bb width. clipHeight := bb height! ! !BitBlt methodsFor: 'private' stamp: 'ClementBera 7/26/2013 16:03'! colorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix | srcIndex map mapsForSource mapsForSourceAndDest | ColorConvertingMaps class == Array ifFalse: [ ColorConvertingMaps := (1 to: 10) collect: [ :i | Array new: 32 ] ]. srcIndex := sourceDepth. sourceDepth > 8 ifTrue: [ srcIndex := keepSubPix ifTrue: [ 9 ] ifFalse: [ 10 ] ]. mapsForSource := ColorConvertingMaps at: srcIndex. (mapsForSourceAndDest := mapsForSource at: destDepth) ifNil: [ mapsForSourceAndDest := mapsForSource at: destDepth put: Dictionary new ]. map := mapsForSourceAndDest at: targetColor ifAbsentPut: [ Color computeColorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix ]. ^ map! ! !BitBlt methodsFor: '*FreeType-Addition' stamp: 'tween 7/28/2006 17:54'! copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray "This entry point to BitBlt supplies an extra argument to specify the fore color argb value for operation 41. This is split into an alpha value and an rgb value, so that both can be passed as smallIntegers to the primitive. rgbColorInteger must be a smallInteger between 0 and 16rFFFFFF. alpha must be a smallInteger between 0 and 16rFF." "Check for compressed source, destination or halftone forms" ((sourceForm isForm) and: [sourceForm unhibernate]) ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray]. ((destForm isForm) and: [destForm unhibernate ]) ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray]. ((halftoneForm isForm) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBitsColor: argbColorSmallInteger alpha: argbAlphaSmallInteger gammaTable: gammaByteArray ungammaTable: ungammaByteArray]. self primitiveFailed "Later do nicer error recovery -- share copyBits recovery"! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! destX: anInteger "Set the top left x coordinate of the receiver's destination form to be the argument, anInteger." destX := anInteger! ! !BitBlt methodsFor: '*Graphics-Fonts' stamp: 'ar 10/25/2005 01:12'! displayString: aString from: startIndex to: stopIndex at: aPoint kern: kernDelta font: aFont "Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text." ^ aFont displayString: aString on: self from: startIndex to: stopIndex at: aPoint kern: kernDelta! ! !BitBlt methodsFor: 'copying' stamp: 'CamilloBruni 8/1/2012 16:05'! fill: destRect fillColor: grayForm rule: rule "Fill with a Color, not a Form." sourceForm := nil. self fillColor: grayForm. "sets halftoneForm" combinationRule := rule. destX := destRect left. destY := destRect top. sourceX := 0. sourceY := 0. width := destRect width. height := destRect height. self copyBits! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! clipRange "clip and adjust source origin and extent appropriately" "first in x" "fill in the lazy state if needed" | sx sy dx dy bbW bbH | destX ifNil: [ destX := 0 ]. destY ifNil: [ destY := 0 ]. width ifNil: [ width := destForm width ]. height ifNil: [ height := destForm height ]. sourceX ifNil: [ sourceX := 0 ]. sourceY ifNil: [ sourceY := 0 ]. clipX ifNil: [ clipX := 0 ]. clipY ifNil: [ clipY := 0 ]. clipWidth ifNil: [ clipWidth := destForm width ]. clipHeight ifNil: [ clipHeight := destForm height ]. destX >= clipX ifTrue: [ sx := sourceX. dx := destX. bbW := width ] ifFalse: [ sx := sourceX + (clipX - destX). bbW := width - (clipX - destX). dx := clipX ]. dx + bbW > (clipX + clipWidth) ifTrue: [ bbW := bbW - (dx + bbW - (clipX + clipWidth)) ]. "then in y" destY >= clipY ifTrue: [ sy := sourceY. dy := destY. bbH := height ] ifFalse: [ sy := sourceY + clipY - destY. bbH := height - (clipY - destY). dy := clipY ]. dy + bbH > (clipY + clipHeight) ifTrue: [ bbH := bbH - (dy + bbH - (clipY + clipHeight)) ]. sourceForm ifNotNil: [ sx < 0 ifTrue: [ dx := dx - sx. bbW := bbW + sx. sx := 0 ]. sx + bbW > sourceForm width ifTrue: [ bbW := bbW - (sx + bbW - sourceForm width) ]. sy < 0 ifTrue: [ dy := dy - sy. bbH := bbH + sy. sy := 0 ]. sy + bbH > sourceForm height ifTrue: [ bbH := bbH - (sy + bbH - sourceForm height) ] ]. (bbW <= 0 or: [ bbH <= 0 ]) ifTrue: [ sourceX := sourceY := destX := destY := clipX := clipY := width := height := 0. ^ true ]. (sx = sourceX and: [ sy = sourceY and: [ dx = destX and: [ dy = destY and: [ bbW = width and: [ bbH = height ] ] ] ] ]) ifTrue: [ ^ false ]. sourceX := sx. sourceY := sy. destX := dx. destY := dy. width := bbW. height := bbH. ^ true! ! !BitBlt methodsFor: '*Graphics-Fonts' stamp: 'ar 10/24/2005 21:49'! displayString: aString from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY font: aFont "Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text." ^ aFont displayString: aString on: self from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY! ! !BitBlt methodsFor: '*Graphics-Fonts' stamp: 'ar 10/24/2005 21:48'! installFont: aFont foregroundColor: foregroundColor backgroundColor: backgroundColor "Double dispatch into the font. This method is present so that other-than-bitblt entities can be used by CharacterScanner and friends to display text." ^aFont installOn: self foregroundColor: foregroundColor backgroundColor: backgroundColor! ! !BitBlt methodsFor: '*FreeType-Addition' stamp: 'FernandoOlivero 6/10/2011 16:34'! lastFontForegroundColor ^ nil ! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipRect: aRectangle "Set the receiver's clipping area rectangle to be the argument, aRectangle." clipX := aRectangle left truncated. clipY := aRectangle top truncated. clipWidth := aRectangle right truncated - clipX. clipHeight := aRectangle bottom truncated - clipY! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copy: destRectangle from: sourcePt in: srcForm | destOrigin | sourceForm := srcForm. halftoneForm := nil. combinationRule := 3. "store" destOrigin := destRectangle origin. destX := destOrigin x. destY := destOrigin y. sourceX := sourcePt x. sourceY := sourcePt y. width := destRectangle width. height := destRectangle height. self copyBits! ! !BitBlt methodsFor: 'line drawing' stamp: ''! drawFrom: startPoint to: stopPoint ^ self drawFrom: startPoint to: stopPoint withFirstPoint: true! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipY: anInteger "Set the receiver's clipping area top left y coordinate to be the argument, anInteger." clipY := anInteger! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/25/2000 19:39'! tallyMap "Return the map used for tallying pixels" ^colorMap! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! eraseBits "Perform the erase operation, which puts 0's in the destination wherever the source (which is assumed to be just 1 bit deep) has a 1. This requires the colorMap to be set in order to AND all 1's into the destFrom pixels regardless of their size." | oldMask oldMap | oldMask := halftoneForm. halftoneForm := nil. oldMap := colorMap. self colorMap: (Bitmap with: 0 with: 4294967295). combinationRule := Form erase. self copyBits. "Erase the dest wherever the source is 1" halftoneForm := oldMask. "already converted to a Bitmap" colorMap := oldMap! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copyFrom: sourceRectangle in: srcForm to: destPt | sourceOrigin | sourceForm := srcForm. halftoneForm := nil. combinationRule := 3. "store" destX := destPt x. destY := destPt y. sourceOrigin := sourceRectangle origin. sourceX := sourceOrigin x. sourceY := sourceOrigin y. width := sourceRectangle width. height := sourceRectangle height. colorMap := srcForm colormapIfNeededFor: destForm. self copyBits! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! roundVariables | maxVal minVal | maxVal := SmallInteger maxVal. minVal := SmallInteger minVal. destX := destX asInteger min: maxVal max: minVal. destY := destY asInteger min: maxVal max: minVal. width := width asInteger min: maxVal max: minVal. height := height asInteger min: maxVal max: minVal. sourceX := sourceX asInteger min: maxVal max: minVal. sourceY := sourceY asInteger min: maxVal max: minVal. clipX := clipX asInteger min: maxVal max: minVal. clipY := clipY asInteger min: maxVal max: minVal. clipWidth := clipWidth asInteger min: maxVal max: minVal. clipHeight := clipHeight asInteger min: maxVal max: minVal! ! !BitBlt methodsFor: 'accessing' stamp: 'tbn 9/14/2004 20:38'! halftoneForm "Returns the receivers half tone form. See class commment." ^halftoneForm! ! !BitBlt methodsFor: 'copying' stamp: 'CamilloBruni 8/1/2012 16:02'! copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule "Specify a Color to fill, not a Form." | destOrigin | sourceForm := srcForm. self fillColor: hf. "sets halftoneForm" combinationRule := rule. destOrigin := destRectangle origin. destX := destOrigin x. destY := destOrigin y. sourceX := sourcePt x. sourceY := sourcePt y. width := destRectangle width. height := destRectangle height. srcForm == nil ifFalse: [ colorMap := srcForm colormapIfNeededFor: destForm ]. ^ self copyBits! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! height: anInteger "Set the receiver's destination form height to be the argument, anInteger." height := anInteger! ! !BitBlt methodsFor: 'copying' stamp: 'JuanVuletich 8/22/2009 23:39'! displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta "If required, do a second pass with new rule and colorMap. This happens when #installStrikeFont:foregroundColor:backgroundColor: sets rule 37 (rgbMul). the desired effect is to do two bitblt calls. The first one is with rule 37 and special colormap. The second one is rule 34, with a colormap for applying the requested foreground color. This two together do component alpha blending, i.e. alpha blend red, green and blue separatedly. This is needed for arbitrary color over abitrary background text with subpixel AA." | answer prevRule secondPassMap | "If combinationRule is rgbMul, we might need the special two-pass technique for component alpha blending. If not, do it simply" combinationRule = 37 "rgbMul" ifFalse: [ ^self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta ]. "We need to do a second pass. The colormap set is for use in the second pass." secondPassMap := colorMap. colorMap := sourceForm depth ~= destForm depth ifTrue: [ self cachedFontColormapFrom: sourceForm depth to: destForm depth ]. answer := self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta. colorMap := secondPassMap. secondPassMap ifNotNil: [ prevRule := combinationRule. combinationRule := 20. "rgbAdd" self basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta. combinationRule := prevRule ]. ^answer! ! !BitBlt methodsFor: '*Graphics-Fonts' stamp: 'lr 7/4/2009 10:42'! cachedFontColormapFrom: sourceDepth to: destDepth "Modified from computeColormapFrom:to:." | srcIndex map | CachedFontColorMaps class == Array ifFalse: [ CachedFontColorMaps := (1 to: 9) collect: [ :i | Array new: 32 ] ]. srcIndex := sourceDepth. sourceDepth > 8 ifTrue: [ srcIndex := 9 ]. (map := (CachedFontColorMaps at: srcIndex) at: destDepth) ~~ nil ifTrue: [ ^ map ]. map := (Color cachedColormapFrom: sourceDepth to: destDepth) copy. (CachedFontColorMaps at: srcIndex) at: destDepth put: map. ^ map! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! sourceY: anInteger "Set the receiver's source form top left y to be the argument, anInteger." sourceY := anInteger! ! !BitBlt methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect | aPoint | destForm := df. sourceForm := sf. self fillColor: hf. "sets halftoneForm" combinationRule := cr. destX := destOrigin x. destY := destOrigin y. sourceX := sourceOrigin x. sourceY := sourceOrigin y. width := extent x. height := extent y. aPoint := clipRect origin. clipX := aPoint x. clipY := aPoint y. aPoint := clipRect corner. clipWidth := aPoint x - clipX. clipHeight := aPoint y - clipY. sourceForm == nil ifFalse: [ colorMap := sourceForm colormapIfNeededFor: destForm ]! ! !BitBlt methodsFor: 'accessing' stamp: ''! destForm ^ destForm! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copy: destRectangle from: sourcePt in: srcForm halftoneForm: hf rule: rule | destOrigin | sourceForm := srcForm. self fillColor: hf. "sets halftoneForm" combinationRule := rule. destOrigin := destRectangle origin. destX := destOrigin x. destY := destOrigin y. sourceX := sourcePt x. sourceY := sourcePt y. width := destRectangle width. height := destRectangle height. self copyBits! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! destX: x destY: y width: w height: h "Combined init message saves 3 sends from DisplayScanner" destX := x. destY := y. width := w. height := h! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! destY: anInteger "Set the top left y coordinate of the receiver's destination form to be the argument, anInteger." destY := anInteger! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! destRect: aRectangle "Set the receiver's destination form top left coordinates to be the origin of the argument, aRectangle, and set the width and height of the receiver's destination form to be the width and height of aRectangle." destX := aRectangle left. destY := aRectangle top. width := aRectangle width. height := aRectangle height! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipHeight: anInteger "Set the receiver's clipping area height to be the argument, anInteger." clipHeight := anInteger! ! !BitBlt methodsFor: 'line drawing' stamp: 'lr 7/4/2009 10:42'! drawLoopX: xDelta Y: yDelta "Primitive. Implements the Bresenham plotting algorithm (IBM Systems Journal, Vol. 4 No. 1, 1965). It chooses a principal direction, and maintains a potential, P. When P's sign changes, it is time to move in the minor direction as well. This particular version does not write the first and last points, so that these can be called for as needed in client code. Optional. See Object documentation whatIsAPrimitive." | dx dy px py P | dx := xDelta sign. dy := yDelta sign. px := yDelta abs. py := xDelta abs. "self copyBits." py > px ifTrue: [ "more horizontal" P := py // 2. 1 to: py do: [ :i | destX := destX + dx. (P := P - px) < 0 ifTrue: [ destY := destY + dy. P := P + py ]. i < py ifTrue: [ self copyBits ] ] ] ifFalse: [ "more vertical" P := px // 2. 1 to: px do: [ :i | destY := destY + dy. (P := P - py) < 0 ifTrue: [ destX := destX + dx. P := P + px ]. i < px ifTrue: [ self copyBits ] ] ]! ! !BitBlt methodsFor: '*FreeType-Addition' stamp: 'tween 8/1/2006 17:52'! combinationRule "Answer the receiver's combinationRule" ^combinationRule! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipBy: aRectangle | aPoint right bottom | right := clipX + clipWidth. bottom := clipY + clipHeight. aPoint := aRectangle origin. aPoint x > clipX ifTrue: [ clipX := aPoint x ]. aPoint y > clipY ifTrue: [ clipY := aPoint y ]. aPoint := aRectangle corner. aPoint x < right ifTrue: [ right := aPoint x ]. aPoint y < bottom ifTrue: [ bottom := aPoint y ]. clipWidth := right - clipX. clipHeight := bottom - clipY. clipWidth < 0 ifTrue: [ clipWidth := 0 ]. clipHeight < 0 ifTrue: [ clipHeight := 0 ]! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! clipByX1: x1 y1: y1 x2: x2 y2: y2 | right bottom | right := clipX + clipWidth. bottom := clipY + clipHeight. x1 > clipX ifTrue: [ clipX := x1 ]. y1 > clipY ifTrue: [ clipY := y1 ]. x2 < right ifTrue: [ right := x2 ]. y2 < bottom ifTrue: [ bottom := y2 ]. clipWidth := right - clipX. clipHeight := bottom - clipY. clipWidth < 0 ifTrue: [ clipWidth := 0 ]. clipHeight < 0 ifTrue: [ clipHeight := 0 ]! ! !BitBlt methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:02'! colorMap: map "See last part of BitBlt comment." colorMap := map! ! !BitBlt methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! copyBitsAgain "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !BitBlt methodsFor: '*Graphics-Fonts' stamp: 'MarcusDenker 3/19/2012 20:45'! installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor | lastSourceDepth targetColor | sourceForm ifNotNil:[lastSourceDepth := sourceForm depth]. sourceForm := aStrikeFont glyphs. "Ignore any halftone pattern since we use a color map approach here" halftoneForm := nil. sourceY := 0. height := aStrikeFont height. sourceForm depth = 1 ifTrue: [ self combinationRule: Form paint. (colorMap notNil and:[lastSourceDepth = sourceForm depth]) ifFalse: [ "Set up color map for a different source depth (color font)" "Uses caching for reasonable efficiency" colorMap := self cachedFontColormapFrom: sourceForm depth to: destForm depth. colorMap at: 1 put: (destForm pixelValueFor: backgroundColor)]. colorMap at: 2 put: (destForm pixelValueFor: foregroundColor). ] ifFalse: [ destForm depth > 8 ifTrue: [ "rgbMul is equivalent to component alpha blend if text is black (only faster, hehe)" self combinationRule: 37. "RGBMul" colorMap := (destForm depth = 32 or: [ (foregroundColor = Color black) not ]) ifTrue: [ "rgbMul / rgbAdd IS component alpha blend for any color of text (neat trick, eh!!)" "This colorMap is to be used on the second pass with rule 20 (rgbAdd) See #displayString:from:to:at:strikeFont:kern:" "Note: In 32bpp we always need the second pass, as the source could have transparent pixels, and we need to add to the alpha channel" self colorConvertingMap: foregroundColor from: sourceForm depth to: destForm depth keepSubPixelAA: true]] ifFalse: [ self combinationRule: 25. "Paint" targetColor := foregroundColor = Color black ifFalse: [ foregroundColor ]. colorMap := self colorConvertingMap: targetColor from: sourceForm depth to: destForm depth keepSubPixelAA: true] ]! ! !BitBlt methodsFor: 'copying' stamp: 'jmv 8/4/2009 16:29'! basicDisplayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta destY := aPoint y. destX := aPoint x. "the following are not really needed, but theBitBlt primitive will fail if not set" sourceX ifNil: [sourceX := 100]. width ifNil: [width := 100]. self primDisplayString: aString from: startIndex to: stopIndex map: font characterToGlyphMap xTable: font xTable kern: kernDelta. ^ destX@destY. ! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! sourceForm: aForm "Set the receiver's source form to be the argument, aForm." sourceForm := aForm! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! copyForm: srcForm to: destPt rule: rule fillColor: color sourceForm := srcForm. self fillColor: color. "sets halftoneForm" combinationRule := rule. destX := destPt x + sourceForm offset x. destY := destPt y + sourceForm offset y. sourceX := 0. sourceY := 0. width := sourceForm width. height := sourceForm height. self copyBits! ! !BitBlt methodsFor: 'private' stamp: 'ar 5/26/2000 16:38'! getPluginName "Private. Return the name of the plugin representing BitBlt. Used for dynamically switching between different BB representations only." ^'BitBltPlugin'! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! sourceOrigin: aPoint "Set the receiver's source form coordinates to be those of the argument, aPoint." sourceX := aPoint x. sourceY := aPoint y! ! !BitBlt methodsFor: 'accessing' stamp: 'tk 8/15/2001 10:56'! color "Return the current fill color as a Color. Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." halftoneForm ifNil: [^ Color black]. ^ Color colorFromPixelValue: halftoneForm first depth: destForm depth! ! !BitBlt methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! combinationRule: anInteger "Set the receiver's combination rule to be the argument, anInteger, a number in the range 0-15." combinationRule := anInteger! ! !BitBlt methodsFor: 'copying' stamp: 'lr 7/4/2009 10:42'! pixelAt: aPoint "Assumes this BitBlt has been set up specially (see the init message, BitBlt bitPeekerFromForm:. Returns the pixel at aPoint." sourceX := aPoint x. sourceY := aPoint y. destForm unhibernate. "before poking" destForm bits at: 1 put: 0. "Just to be sure" self copyBits. ^ destForm bits at: 1! ! !BitBlt methodsFor: 'accessing' stamp: 'tk 3/19/97'! destRect "The rectangle we are about to blit to or just blitted to. " ^ destX @ destY extent: width @ height! ! !BitBlt methodsFor: '*FreeType-Addition' stamp: 'tween 4/4/2007 20:59'! installFreeTypeFont: aFreeTypeFont foregroundColor: foregroundColor backgroundColor: backgroundColor "Set up the parameters. Since the glyphs in a TTCFont is 32bit depth form, it tries to use rule=34 to get better AA result if possible." (FreeTypeSettings current bitBltSubPixelAvailable and: [destForm depth >= 8]) ifTrue:[ self combinationRule: 41. destForm depth = 8 ifTrue:[self colorMap: (self cachedFontColormapFrom: 32 to: destForm depth)] ifFalse:[self colorMap: nil]] ifFalse:[ "use combination rule 34 when rule 41 is not available in the BitBlt plugin, or the destination form depth <= 8" destForm depth <= 8 ifTrue: [ self colorMap: (self cachedFontColormapFrom: 32 to: destForm depth). self combinationRule: Form paint.] ifFalse: [ self colorMap: nil. self combinationRule: 34]]. halftoneForm := nil. sourceX := sourceY := 0. height := aFreeTypeFont height. ! ! !BitBlt class methodsFor: 'class initialization' stamp: 'jmv 9/7/2009 09:32'! initialize self recreateColorMaps! ! !BitBlt class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! bitPeekerFromForm: sourceForm "Answer an instance to be used extract individual pixels from the given Form. The destination for a 1x1 copyBits will be the low order bits of (bits at: 1)." | pixPerWord | pixPerWord := 32 // sourceForm depth. sourceForm unhibernate. ^ self destForm: (Form extent: pixPerWord @ 1 depth: sourceForm depth) sourceForm: sourceForm halftoneForm: nil combinationRule: Form over destOrigin: (pixPerWord - 1) @ 0 sourceOrigin: 0 @ 0 extent: 1 @ 1 clipRect: (0 @ 0 extent: pixPerWord @ 1)! ! !BitBlt class methodsFor: 'instance creation' stamp: ''! toForm: aForm ^ self new setDestForm: aForm! ! !BitBlt class methodsFor: 'instance creation' stamp: ''! destForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect "Answer an instance of me with values set according to the arguments." ^ self new setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect! ! !BitBlt class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! bitPokerToForm: destForm "Answer an instance to be used for valueAt: aPoint put: pixValue. The source for a 1x1 copyBits will be the low order of (bits at: 1)" | pixPerWord | pixPerWord := 32 // destForm depth. destForm unhibernate. ^ self destForm: destForm sourceForm: (Form extent: pixPerWord @ 1 depth: destForm depth) halftoneForm: nil combinationRule: Form over destOrigin: 0 @ 0 sourceOrigin: (pixPerWord - 1) @ 0 extent: 1 @ 1 clipRect: (0 @ 0 extent: destForm extent)! ! !BitBlt class methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! recreateColorMaps CachedFontColorMaps := ColorConvertingMaps := nil! ! !BitBlt class methodsFor: 'instance creation' stamp: ''! destForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect "Answer an instance of me with values set according to the arguments." ^ self new setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect! ! !BitBlt class methodsFor: 'deprecated' stamp: 'StephaneDucasse 10/25/2013 16:20'! current "Return the class currently to be used for BitBlt" "deprecated normally should be removed." ^self! ! !BitBlt class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:18'! cleanUp "Flush caches" self recreateColorMaps.! ! !BitBltClipBugs methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2013 20:23'! testFillingWayOutside | f1 bb | f1 := Form extent: 100 @ 100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. bb copyBits! ! !BitBltClipBugs methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2013 20:23'! testFillingWayOutside3 | f1 bb | f1 := Form extent: 100 @ 100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb copyBits! ! !BitBltClipBugs methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2013 20:23'! testFillingWayOutside2 | f1 bb | f1 := Form extent: 100 @ 100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: 0 @ 0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb copyBits! ! !BitBltClipBugs methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2013 20:23'! testDrawingWayOutside2 | f1 bb f2 | f1 := Form extent: 100 @ 100 depth: 1. f2 := Form extent: 100 @ 100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: 0 @ 0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb copyBits! ! !BitBltClipBugs methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2013 20:23'! testDrawingWayOutside3 | f1 bb f2 | f1 := Form extent: 100 @ 100 depth: 1. f2 := Form extent: 100 @ 100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb copyBits! ! !BitBltClipBugs methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2013 20:23'! testDrawingWayOutside4 | f1 bb f2 | f1 := Form extent: 100 @ 100 depth: 1. f2 := Form extent: 100 @ 100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. bb sourceOrigin: SmallInteger maxVal squared asPoint. bb copyBits! ! !BitBltClipBugs methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2013 20:23'! testDrawingWayOutside | f1 bb f2 | f1 := Form extent: 100 @ 100 depth: 1. f2 := Form extent: 100 @ 100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. bb copyBits! ! !BitBltClipBugs methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2013 20:23'! testDrawingWayOutside6 | f1 bb f2 | f1 := Form extent: 100 @ 100 depth: 1. f2 := Form extent: 100 @ 100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb sourceOrigin: SmallInteger maxVal squared asPoint. bb copyBits! ! !BitBltClipBugs methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2013 20:23'! testDrawingWayOutside5 | f1 bb f2 | f1 := Form extent: 100 @ 100 depth: 1. f2 := Form extent: 100 @ 100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: 0 @ 0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb sourceOrigin: SmallInteger maxVal squared asPoint. bb copyBits! ! !BitBltDisplayScanner commentStamp: 'nice 10/12/2013 01:36'! A BitBltDisplayScanner displays characters on Screen or other Form with help of a BitBlt. Instance Variables bitBlt: fillBlt: bitBlt - the object which knows how to copy bits from one Form (the font glyph data) to another (the destination Form) fillBlt - another object for copying form bits, initialized for displaying the background. ! !BitBltDisplayScanner methodsFor: 'private' stamp: 'hmm 9/16/2000 21:29'! setPort: aBitBlt "Install the BitBlt to use" bitBlt := aBitBlt. bitBlt sourceX: 0; width: 0. "Init BitBlt so that the first call to a primitive will not fail" bitBlt sourceForm: nil. "Make sure font installation won't be confused" ! ! !BitBltDisplayScanner methodsFor: 'private' stamp: 'ar 5/17/2000 19:26'! setDestForm: df bitBlt setDestForm: df.! ! !BitBltDisplayScanner methodsFor: 'displaying' stamp: 'SeanDeNigris 1/7/2014 20:59'! displayEmbeddedForm: aForm aForm displayOn: bitBlt destForm at: destX @ (lineY + line baseline - aForm height) clippingBox: bitBlt clipRect rule: Form blend fillColor: Color white! ! !BitBltDisplayScanner methodsFor: 'displaying' stamp: 'nice 10/12/2013 01:06'! displayString: string from: startIndex to: stopIndex at: aPoint font displayString: string on: bitBlt from: startIndex to: stopIndex at: aPoint kern: kern! ! !BitBltDisplayScanner methodsFor: 'displaying' stamp: 'nice 10/12/2013 01:08'! fillTextBackground fillBlt == nil ifFalse: ["Not right" fillBlt destX: line left destY: lineY width: line width left height: line lineHeight; copyBits].! ! !BitBltDisplayScanner methodsFor: 'private' stamp: 'nice 10/12/2013 01:32'! text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode text := t. textStyle := ts. foregroundColor := defaultTextColor := foreColor. (backgroundColor := backColor) isTransparent ifFalse: [fillBlt := blt. fillBlt fillColor: backgroundColor]. ignoreColorChanges := shadowMode! ! !BitBltDisplayScanner methodsFor: 'stop conditions' stamp: 'nice 10/13/2013 22:10'! plainTab | nextDestX | nextDestX := super plainTab. fillBlt == nil ifFalse: [fillBlt destX: destX destY: destY width: nextDestX - destX height: font height; copyBits]. ^nextDestX! ! !BitBltDisplayScanner methodsFor: 'private' stamp: 'nice 10/12/2013 01:29'! setFont super setFont. "Sets font and emphasis bits, and maybe foregroundColor" font installOn: bitBlt foregroundColor: foregroundColor backgroundColor: Color transparent! ! !BitBltDisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:39'! defaultFont ^ TextStyle defaultFont! ! !BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:12'! testAlphaCompositing "self run: #testAlphaCompositing" | bb f1 f2 mixColor result eps | f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color blue. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBits. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: (result blue - (1.0 - mixColor alpha)) abs < eps. self assert: result alpha = 1.0. ].! ! !BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:12'! testAlphaCompositing2 "self run: #testAlphaCompositing2" | bb f1 f2 mixColor result eps | f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color transparent. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBits. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: result alpha = mixColor alpha. ].! ! !BitBltTest methodsFor: 'bugs' stamp: 'CamilloBruni 8/31/2013 20:23'! testPeekerUnhibernateBug "self run: #testPeekerUnhibernateBug" | bitBlt | bitBlt := BitBlt bitPeekerFromForm: Display. bitBlt destForm hibernate. bitBlt pixelAt: 1 @ 1! ! !BitBltTest methodsFor: 'bugs' stamp: 'CamilloBruni 8/31/2013 20:23'! testPokerUnhibernateBug "self run: #testPokerUnhibernateBug" | bitBlt | bitBlt := BitBlt bitPokerToForm: Display. bitBlt sourceForm hibernate. bitBlt pixelAt: 1 @ 1 put: 0! ! !BitBltTest methodsFor: 'bugs' stamp: 'lr 3/14/2010 21:13'! testAlphaCompositing2Simulated "self run: #testAlphaCompositing2Simulated" Smalltalk globals at: #BitBltSimulation ifPresent: [ :bitblt | | bb f1 mixColor f2 result eps | f1 := Form extent: 1 @ 1 depth: 32. f2 := Form extent: 1 @ 1 depth: 32. eps := 0.5 / 255. 0 to: 255 do: [ :i | f1 colorAt: 0 @ 0 put: Color transparent. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0 @ 0 put: mixColor. mixColor := f2 colorAt: 0 @ 0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. result := f1 colorAt: 0 @ 0. self assert: (result red - mixColor alpha) abs < eps. self assert: result alpha = mixColor alpha ] ]! ! !BitBltTest methodsFor: 'bugs' stamp: 'lr 3/14/2010 21:13'! testAlphaCompositingSimulated "self run: #testAlphaCompositingSimulated" Smalltalk globals at: #BitBltSimulation ifPresent: [ :bitblt | | mixColor result eps f1 bb f2 | f1 := Form extent: 1 @ 1 depth: 32. f2 := Form extent: 1 @ 1 depth: 32. eps := 0.5 / 255. 0 to: 255 do: [ :i | f1 colorAt: 0 @ 0 put: Color blue. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0 @ 0 put: mixColor. mixColor := f2 colorAt: 0 @ 0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. result := f1 colorAt: 0 @ 0. self assert: (result red - mixColor alpha) abs < eps. self assert: (result blue - (1.0 - mixColor alpha)) abs < eps. self assert: result alpha = 1.0 ] ]! ! !Bitmap commentStamp: ''! My instances provide contiguous storage of bits, primarily to hold the graphical data of Forms. Forms and their subclasses provide the additional structural information as to how the bits should be interpreted in two dimensions.! !Bitmap methodsFor: 'conversion' stamp: 'CamilloBruni 11/2/2012 10:12'! restoreEndianness "nothing to do here?"! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:18'! byteSize ^self size * 4! ! !Bitmap methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:01'! bitPatternForDepth: depth "The raw call on BitBlt needs a Bitmap to represent this color. I already am Bitmap like. I am already adjusted for a specific depth. Interpret me as an array of (32/depth) Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary." ^ self! ! !Bitmap methodsFor: 'accessing' stamp: ''! primFill: aPositiveInteger "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." self errorImproperStore.! ! !Bitmap methodsFor: 'accessing' stamp: 'tk 3/15/97'! pixelValueForDepth: depth "Self is being used to represent a single color. Answer bits that appear in ONE pixel of this color in a Bitmap of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Returns an integer. First pixel only. " ^ (self at: 1) bitAnd: (1 bitShift: depth) - 1! ! !Bitmap methodsFor: 'accessing' stamp: 'StephaneDucasse 3/17/2010 20:52'! copyFromByteArray: byteArray "This method should work with either byte orderings" | myHack byteHack | myHack := Form new hackBits: self. byteHack := Form new hackBits: byteArray. Smalltalk isLittleEndian ifTrue: [byteHack swapEndianness]. byteHack displayOn: myHack! ! !Bitmap methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! integerAt: index put: anInteger "Store the integer at the given index" | word | anInteger < 0 ifTrue: [ "word := 16r100000000 + anInteger" word := (anInteger + 1) negated bitInvert32 ] ifFalse: [ word := anInteger ]. self basicAt: index put: word. ^ anInteger! ! !Bitmap methodsFor: '*Compression' stamp: 'lr 7/4/2009 10:42'! compressGZip "just hacking around to see if further compression would help Nebraska" | ba hackwa hackba blt rowsAtATime sourceOrigin rowsRemaining bufferStream gZipStream | bufferStream := RWBinaryOrTextStream on: (ByteArray new: 5000). gZipStream := GZipWriteStream on: bufferStream. ba := nil. rowsAtATime := 20000. "or 80000 bytes" hackwa := Form new hackBits: self. sourceOrigin := 0 @ 0. [ (rowsRemaining := hackwa height - sourceOrigin y) > 0 ] whileTrue: [ rowsAtATime := rowsAtATime min: rowsRemaining. (ba isNil or: [ ba size ~= (rowsAtATime * 4) ]) ifTrue: [ ba := ByteArray new: rowsAtATime * 4. hackba := Form new hackBits: ba. blt := (BitBlt toForm: hackba) sourceForm: hackwa ]. blt combinationRule: Form over; sourceOrigin: sourceOrigin; destX: 0 destY: 0 width: 4 height: rowsAtATime; copyBits. "bufferStream nextPutAll: ba." sourceOrigin := sourceOrigin x @ (sourceOrigin y + rowsAtATime) ]. gZipStream close. ^ bufferStream contents! ! !Bitmap methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! integerAt: index "Return the integer at the given index" | word | word := self basicAt: index. word < 1073741823 ifTrue: [ ^ word ]. "Avoid LargeInteger computations" ^ word >= 2147483648 ifTrue: [ "Negative?!!" "word - 16r100000000" (word bitInvert32 + 1) negated ] ifFalse: [ word ]! ! !Bitmap methodsFor: 'printing' stamp: 'sma 6/1/2000 09:42'! printOn: aStream self printNameOn: aStream. aStream nextPutAll: ' of length '; print: self size! ! !Bitmap methodsFor: 'filing' stamp: 'tk 2/19/1999 07:36'! writeUncompressedOn: aStream "Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed)." aStream nextInt32Put: self size. aStream nextPutAll: self ! ! !Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! compressToByteArray "Return a run-coded compression of this bitmap into a byteArray" "Without skip codes, it is unlikely that the compressed bitmap will be any larger than was the original. The run-code cases are... N >= 1 words of equal bytes: 4N bytes -> 2 bytes (at worst 4 -> 2) N > 1 equal words: 4N bytes -> 5 bytes (at worst 8 -> 5) N > 1 unequal words: 4N bytes -> 4N + M, where M is the number of bytes required to encode the run length. The worst that can happen is that the method begins with unequal words, and than has interspersed occurrences of a word with equal bytes. Thus we require a run-length at the beginning, and after every interspersed word of equal bytes. However, each of these saves 2 bytes, so it must be followed by a run of 1984 (7936//4) or more (for which M jumps from 2 to 5) to add any extra overhead. Therefore the worst case is a series of runs of 1984 or more, with single interspersed words of equal bytes. At each break we save 2 bytes, but add 5. Thus the overhead would be no more than 5 (encoded size) + 2 (first run len) + (S//1984*3)." "NOTE: This code is copied in Form hibernate for reasons given there." | byteArray lastByte | byteArray := ByteArray new: self size * 4 + 7 + (self size // 1984 * 3). lastByte := self compress: self toByteArray: byteArray. ^ byteArray copyFrom: 1 to: lastByte! ! !Bitmap methodsFor: 'testing' stamp: 'ar 5/25/2000 19:42'! isColormap "Bitmaps were used as color maps for BitBlt. This method allows to recognize real color maps." ^false! ! !Bitmap methodsFor: 'filing' stamp: 'nk 12/31/2003 16:02'! storeBits: startBit to: stopBit on: aStream "Store my bits as a hex string, breaking the lines every 100 bytes or so to comply with the maximum line length limits of Postscript (255 bytes). " | lineWidth | lineWidth := 0. self do: [:word | startBit to: stopBit by: -4 do: [:shift | aStream nextPut: (word >> shift bitAnd: 15) asHexDigit. lineWidth := lineWidth + 1]. (lineWidth > 100) ifTrue: [aStream cr. lineWidth := 0]]. lineWidth > 0 ifTrue: [ aStream cr ].! ! !Bitmap methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:02'! byteAt: byteAddress "Extract a byte from a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:. See Form>>#pixelAt:" | lowBits | lowBits := byteAddress - 1 bitAnd: 3. ^ ((self at: (byteAddress - 1 - lowBits) // 4 + 1) bitShift: (lowBits - 3) * 8) bitAnd: 255! ! !Bitmap methodsFor: 'filing' stamp: 'MarcusDenker 3/17/2012 09:34'! compress: bm toByteArray: ba "Store a run-coded compression of the receiver into the byteArray ba, and return the last index stored into. ba is assumed to be large enough. The encoding is as follows... S {N D}*. S is the size of the original bitmap, followed by run-coded pairs. N is a run-length * 4 + data code. D, the data, depends on the data code... 0 skip N words, D is absent 1 N words with all 4 bytes = D (1 byte) 2 N words all = D (4 bytes) 3 N words follow in D (4N bytes) S and N are encoded as follows... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes" | size k word j lowByte eqBytes i | size := bm size. i := self encodeInt: size in: ba at: 1. k := 1. [ k <= size ] whileTrue: [ word := bm at: k. lowByte := word bitAnd: 255. eqBytes := (word >> 8 bitAnd: 255) = lowByte and: [ (word >> 16 bitAnd: 255) = lowByte and: [ (word >> 24 bitAnd: 255) = lowByte ] ]. j := k. [ j < size and: [ word = (bm at: j + 1) ] "scan for = words..." ] whileTrue: [ j := j + 1 ]. j > k ifTrue: [ "We have two or more = words, ending at j" eqBytes ifTrue: [ "Actually words of = bytes" i := self encodeInt: (j - k + 1) * 4 + 1 in: ba at: i. ba at: i put: lowByte. i := i + 1 ] ifFalse: [ i := self encodeInt: (j - k + 1) * 4 + 2 in: ba at: i. i := self encodeBytesOf: word in: ba at: i ]. k := j + 1 ] ifFalse: [ "Check for word of 4 = bytes" eqBytes ifTrue: [ "Note 1 word of 4 = bytes" i := self encodeInt: 1 * 4 + 1 in: ba at: i. ba at: i put: lowByte. i := i + 1. k := k + 1 ] ifFalse: [ "Finally, check for junk" [ j < size and: [ (bm at: j) ~= (bm at: j + 1) ] "scan for ~= words..." ] whileTrue: [ j := j + 1 ]. j = size ifTrue: [ j := j + 1 ]. "We have one or more unmatching words, ending at j-1" i := self encodeInt: (j - k) * 4 + 3 in: ba at: i. k to: j - 1 do: [ :m | i := self encodeBytesOf: (bm at: m) in: ba at: i ]. k := j ] ] ]. ^ i - 1 "number of bytes actually stored"! ! !Bitmap methodsFor: 'initialize' stamp: 'ar 12/23/1999 14:35'! fromByteStream: aStream "Initialize the array of bits by reading integers from the argument, aStream." aStream nextWordsInto: self! ! !Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! writeOn: aStream "Store the array of bits onto the argument, aStream. A leading byte of 16r80 identifies this as compressed by compressToByteArray (qv)." | b | aStream nextPut: 128. b := self compressToByteArray. aStream nextPutAll: (self encodeInt: b size); nextPutAll: b! ! !Bitmap methodsFor: 'filing' stamp: 'PeterHugossonMiller 9/3/2009 00:15'! readCompressedFrom: strm "Decompress an old-style run-coded stream into this bitmap: [0 means end of runs] [n = 1..127] [(n+3) copies of next byte] [n = 128..191] [(n-127) next bytes as is] [n = 192..255] [(n-190) copies of next 4 bytes]" | n byte out outBuff bytes | out := (outBuff := ByteArray new: self size * 4) writeStream. [ (n := strm next) > 0 ] whileTrue: [ (n between: 1 and: 127) ifTrue: [ byte := strm next. 1 to: n + 3 do: [ :i | out nextPut: byte ] ]. (n between: 128 and: 191) ifTrue: [ 1 to: n - 127 do: [ :i | out nextPut: strm next ] ]. (n between: 192 and: 255) ifTrue: [ bytes := (1 to: 4) collect: [ :i | strm next ]. 1 to: n - 190 do: [ :i | bytes do: [ :b | out nextPut: b ] ] ] ]. out position = outBuff size ifFalse: [ self error: 'Decompression size error' ]. "Copy the final byteArray into self" self copyFromByteArray: outBuff! ! !Bitmap methodsFor: 'filing' stamp: 'HenrikSperreJohansen 10/25/2010 15:33'! decompress: bm fromByteArray: ba at: index "Decompress the body of a byteArray encoded by compressToByteArray (qv)... The format is simply a sequence of run-coded pairs, {N D}*. N is a run-length * 4 + data code. D, the data, depends on the data code... 0 skip N words, D is absent (could be used to skip from one raster line to the next) 1 N words with all 4 bytes = D (1 byte) 2 N words all = D (4 bytes) 3 N words follow in D (4N bytes) S and N are encoded as follows (see decodeIntFrom:)... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes" "NOTE: If fed with garbage, this routine could read past the end of ba, but it should fail before writing past the ned of bm." | i code n anInt data end k pastEnd | i := index. "byteArray read index" end := ba size. k := 1. "bitmap write index" pastEnd := bm size + 1. [ i <= end ] whileTrue: [ "Decode next run start N" anInt := ba at: i. i := i + 1. anInt <= 223 ifFalse: [ anInt <= 254 ifTrue: [ anInt := (anInt - 224) * 256 + (ba at: i). i := i + 1 ] ifFalse: [ anInt := 0. 1 to: 4 do: [ :j | anInt := (anInt bitShift: 8) + (ba at: i). i := i + 1 ] ] ]. n := anInt >> 2. k + n > pastEnd ifTrue: [ ^ self primitiveFail ]. code := anInt bitAnd: 3. code = 0 ifTrue: [ "skip" ]. code = 1 ifTrue: [ "n consecutive words of 4 bytes = the following byte" data := ba at: i. i := i + 1. data := data bitOr: (data bitShift: 8). data := data bitOr: (data bitShift: 16). 1 to: n do: [ :j | bm at: k put: data. k := k + 1 ] ]. code = 2 ifTrue: [ "n consecutive words = 4 following bytes" data := 0. 1 to: 4 do: [ :j | data := (data bitShift: 8) bitOr: (ba at: i). i := i + 1 ]. 1 to: n do: [ :j | bm at: k put: data. k := k + 1 ] ]. code = 3 ifTrue: [ "n consecutive words from the data..." 1 to: n do: [ :m | data := 0. 1 to: 4 do: [ :j | data := (data bitShift: 8) bitOr: (ba at: i). i := i + 1 ]. bm at: k put: data. k := k + 1 ] ] ]! ! !Bitmap methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:01'! byteAt: byteAddress put: byte "Insert a byte into a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:put:. See Form>>#pixelAt:put:" | longWord shift lowBits longAddr | (byte < 0 or: [ byte > 255 ]) ifTrue: [ ^ self errorImproperStore ]. lowBits := byteAddress - 1 bitAnd: 3. longWord := self at: (longAddr := (byteAddress - 1 - lowBits) // 4 + 1). shift := (3 - lowBits) * 8. longWord := longWord - (longWord bitAnd: (255 bitShift: shift)) + (byte bitShift: shift). self at: longAddr put: longWord. ^ byte! ! !Bitmap methodsFor: 'filing' stamp: 'lr 7/4/2009 10:42'! encodeInt: int "Encode the integer int as per encodeInt:in:at:, and return it as a ByteArray" | byteArray next | byteArray := ByteArray new: 5. next := self encodeInt: int in: byteArray at: 1. ^ byteArray copyFrom: 1 to: next - 1! ! !Bitmap methodsFor: 'filing' stamp: 'HenrikSperreJohansen 10/25/2010 15:29'! encodeInt: anInt in: ba at: i "Encode the integer anInt in byteArray ba at index i, and return the next index. The encoding is as follows... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes" anInt <= 223 ifTrue: [ba at: i put: anInt. ^ i+1]. anInt <= 7935 ifTrue: [ba at: i put: anInt//256+224. ba at: i+1 put: anInt\\256. ^ i+2]. ba at: i put: 255. ^ self encodeBytesOf: anInt in: ba at: i+1! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! defaultElement "Return the default element of the receiver" ^0! ! !Bitmap methodsFor: 'filing' stamp: 'HenrikSperreJohansen 10/25/2010 15:29'! encodeBytesOf: anInt in: ba at: i "Copy the integer anInt into byteArray ba at index i, and return the next index" 0 to: 3 do: [:j | ba at: i+j put: (anInt >> (3-j*8) bitAnd: 16rFF)]. ^ i+4! ! !Bitmap methodsFor: 'accessing' stamp: ''! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:11'! atAllPut: value "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." super atAllPut: value.! ! !Bitmap methodsFor: 'conversion' stamp: 'StephaneDucasse 3/17/2010 20:52'! asByteArray "Faster way to make a byte array from me. copyFromByteArray: makes equal Bitmap." | f bytes hack | f := Form extent: 4 @ self size depth: 8 bits: self. bytes := ByteArray new: self size * 4. hack := Form new hackBits: bytes. Smalltalk isLittleEndian ifTrue: [ hack swapEndianness ]. hack copyBits: f boundingBox from: f at: 0 @ 0 clippingBox: hack boundingBox rule: Form over fillColor: nil map: nil. "f displayOn: hack." ^ bytes! ! !Bitmap class methodsFor: 'utilities' stamp: 'lr 7/4/2009 10:42'! swapBytesIn: aNonPointerThing from: start to: stop "Perform a bigEndian/littleEndian byte reversal of my words. We only intend this for non-pointer arrays. Do nothing if I contain pointers." "The implementation is a hack, but fast for large ranges" | hack blt | hack := Form new hackBits: aNonPointerThing. blt := (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: start - 1; destY: start - 1; height: stop - start + 1; width: 1. blt sourceX: 0; destX: 3; copyBits. "Exchange bytes 0 and 3" blt sourceX: 3; destX: 0; copyBits. blt sourceX: 0; destX: 3; copyBits. blt sourceX: 1; destX: 2; copyBits. "Exchange bytes 1 and 2" blt sourceX: 2; destX: 1; copyBits. blt sourceX: 1; destX: 2; copyBits! ! !Bitmap class methodsFor: 'instance creation' stamp: 'damiencassou 5/30/2008 14:51'! decompressFromByteArray: byteArray | s bitmap size | s := byteArray readStream. size := self decodeIntFrom: s. bitmap := self new: size. bitmap decompress: bitmap fromByteArray: byteArray at: s position + 1. ^ bitmap! ! !Bitmap class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! decodeIntFrom: s "Decode an integer in stream s as follows... 0-223 0-223 224-254 (0-30)*256 + next byte (0-7935) 255 next 4 bytes " | int | int := s next. int <= 223 ifTrue: [ ^ int ]. int <= 254 ifTrue: [ ^ (int - 224) * 256 + s next ]. int := s next. 1 to: 3 do: [ :j | int := (int bitShift: 8) + s next ]. ^ int! ! !Bitmap class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! newFromStream: s | len | s next = 128 ifTrue: [ "New compressed format" len := self decodeIntFrom: s. ^ Bitmap decompressFromByteArray: (s nextInto: (ByteArray new: len)) ]. s skip: -1. len := s nextInt32. len <= 0 ifTrue: [ "Old compressed format" ^ (self new: len negated) readCompressedFrom: s ] ifFalse: [ "Old raw data format" ^ s nextWordsInto: (self new: len) ]! ! !BitmapFillStyle commentStamp: ''! A BitmapFillStyle fills using any kind of form. Instance variables: form
The form to be used as fill. tileFlag If true, then the form is repeatedly drawn to fill the area.! !BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/27/1998 14:37'! tileFlag ^tileFlag! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:40'! form ^form! ! !BitmapFillStyle methodsFor: 'testing' stamp: 'ar 11/11/1998 22:40'! isBitmapFill ^true! ! !BitmapFillStyle methodsFor: 'converting' stamp: 'ar 11/11/1998 22:41'! asColor ^form colorAt: 0@0! ! !BitmapFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'ar 6/25/1999 11:57'! newForm: aForm forMorph: aMorph self form: aForm. self direction: (aForm width @ 0). self normal: (0 @ aForm height). aMorph changed.! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'StephaneDucasse 3/5/2010 15:17'! direction ^direction ifNil: [direction :=( (normal y @ normal x negated) * form width / form height ) rounded]! ! !BitmapFillStyle methodsFor: 'testing' stamp: 'ar 11/27/1998 14:37'! isTiled "Return true if the receiver should be repeated if the fill shape is larger than the form" ^tileFlag == true! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'StephaneDucasse 3/5/2010 15:17'! normal ^normal ifNil: [normal := ((direction y negated @ direction x) * form height / form width ) rounded]! ! !BitmapFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'wiz 8/30/2003 16:54'! grabNewGraphicIn: aMorph event: evt "Used by any morph that can be represented by a graphic" | fill | fill := Form fromUser. fill boundingBox area = 0 ifTrue: [^ self]. self form: fill. self direction: fill width @ 0. self normal: 0 @ fill height. aMorph changed! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:40'! form: aForm form := aForm! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/27/1998 14:30'! tileFlag: aBoolean tileFlag := aBoolean! ! !BitmapFillStyle class methodsFor: 'instance creation' stamp: 'KLC 1/27/2004 13:33'! fromForm: aForm | fs | fs := self form: aForm. fs origin: 0@0. fs direction: aForm width @ 0. fs normal: 0 @ aForm height. fs tileFlag: true. ^fs! ! !BitmapFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/13/1998 20:32'! form: aForm ^self new form: aForm! ! !BitmapFillStyle class methodsFor: 'instance creation' stamp: 'ar 6/18/1999 07:09'! fromUser | fill | fill := self form: Form fromUser. fill origin: 0@0. fill direction: fill form width @ 0. fill normal: 0 @ fill form height. fill tileFlag: true. "So that we can fill arbitrary objects" ^fill! ! !BitsLayout commentStamp: ''! I am a specialized layout which does not hold slots but only raw data (bytes or words).! !BitsLayout methodsFor: 'testing' stamp: 'MartinDias 1/31/2014 16:18'! isWords ^ self isBytes not! ! !BitsLayout methodsFor: 'testing' stamp: 'MartinDias 1/31/2014 16:19'! isBytes ^ self subclassResponsibility! ! !BitsLayout methodsFor: 'initialize-release' stamp: 'ToonVerwaest 4/1/2011 01:53'! initializeInstance: anInstance! ! !BitsLayout methodsFor: 'extending' stamp: 'MartinDias 9/5/2013 15:50'! extend "Answer a default extension of me." ^ self species new ! ! !BitsLayout methodsFor: 'reshaping' stamp: 'MartinDias 9/5/2013 15:49'! extendAgain: aLayout with: aScope "Answer my default layout since any subclass of me only can have my layout type." ^ self extend host: host; yourself! ! !BitsLayout methodsFor: 'reshaping' stamp: 'MartinDias 8/28/2013 15:48'! reshapeFrom: oldScope to: newParentLayout "Answer the reshaped version of me for a new parent layout. If the new parent layout has not fields, then the new version is just a copy of me. But if it has fields, that means that the new version of me cannot be a bits layout anymore, so the answer is a new default layout. " ^ newParentLayout hasFields ifTrue: [ (newParentLayout extend) host: host; yourself ] ifFalse: [ self copy ] ! ! !BitsLayout methodsFor: 'testing' stamp: 'ToonVerwaest 4/1/2011 01:26'! isVariable ^ true! ! !BitsLayout methodsFor: 'testing' stamp: 'ToonVerwaest 4/1/2011 01:25'! isBits ^ true! ! !BlockApiSetter commentStamp: 'TorstenBergmann 2/5/2014 09:19'! Widget setter API for BlocEditor! !BlockApiSetter methodsFor: 'initialize' stamp: 'TorstenBergmann 2/5/2014 09:22'! initializeWidgets self instantiateModels: #( selector LabelModel choice #BlockEditor ). self selector text: ''. self choice whenBlockChangedDo: [:b | self setValueTo: b ]! ! !BlockApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:45'! internUpdateWith: value | string idx start end pre body | string := value printString. idx := string indexOf: $|. idx isZero ifTrue: [ pre := '['. idx := idx +1 ] ifFalse: [ pre := (string copyFrom: 1 to: idx), ' ' ]. start := idx + 1. end := string size-1. body := (string copyFrom: start to: end) trimBoth. choice pre text: pre. choice text text: body! ! !BlockCannotReturn commentStamp: ''! This class is private to the EHS implementation. Its use allows for ensured execution to survive code such as: [self doThis. ^nil] ensure: [self doThat] Signaling or handling this exception is not recommended.! !BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! deadHome: context deadHome := context! ! !BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! deadHome ^ deadHome! ! !BlockCannotReturn methodsFor: 'exceptiondescription' stamp: 'tfei 4/2/1999 15:49'! isResumable ^true! ! !BlockCannotReturn methodsFor: 'exceptiondescription' stamp: 'tfei 3/30/1999 12:55'! defaultAction self messageText: 'Block cannot return'. ^super defaultAction! ! !BlockCannotReturn methodsFor: 'accessing' stamp: 'tfei 3/30/1999 12:54'! result ^result! ! !BlockCannotReturn methodsFor: 'accessing' stamp: 'tfei 3/30/1999 12:54'! result: r result := r! ! !BlockClosure commentStamp: ''! I contain a sequence of operations. I am defined by Smalltalk expressions inside square brackets. I permit to defer the enclosed operations until I execute a variant of #value. I can have my own arguments and temporaries as a regular method, but I am also able to use external variables: my enclosing method or block temporaries, arguments and receiver. examples : [ 1 + 2 ] value [ :arg | | temp | temp := arg. temp ] value: 5 [ ^ 5 ] value My return value corresponds to my final expression. A non local return (^) has the same effect as if I did not exist: it returns from my enclosing method, even if I'm nested in other blocks. Implementation: Instance variables: outerContext context that defined me startpc: (pc = program counter) offset of my first bytecode instruction in the compiledMethod bytecode numArgs: my number of arguments I am created at runtime through a special bytecode: closureNumCopied: x numArgs: y bytes z1 to z2 On creation, the currently executed context is set to my outerContext, z1 is set as my startpc and y is set as my numArgs. After my creation, the current execution flow jumps to my last bytecode, z2, to skip the execution of my bytecode which is deferred until I execute a variant of #value. I am executed when I receive a variant of the message value. This message creates a new context, a block context , which reference me in its variable closureOrNil. This new context executes my bytecode, which correspond to a subset of the bytecode of my enclosing method, starting at startpc and ending in blockReturn/return bytecode. Accessing variables of the my enclosing context is different depending on variables because of various optimizations: - self: I access the receiver of my enclosing method by accessing my context's receiver, which is always set to the enclosing method receiver. - copied variables: If I read a variable from an outerContext but I don't write into it and the variable is not modified after the BlockClosure creation, then the variable is copied in the blockClosure to be more efficient. - full variable: If I access and edit a variable from an outerContext, then the variable is stored in an external heap allocated array (named tempVector). The tempVector is known by the method and the block so they can both read and write these variables. Optimized block closures: Common blocks (2/3 of the blocks) are optimized directly in the compiler and have special behaviors. These blocks are the arguments/receiver of control structures: #ifNil:, #ifNotNil:, #ifTrue:, #ifFalse:, #whileTrue:, #whileFalse:, #to:do:, #to:by:do: . ! !BlockClosure methodsFor: 'evaluating' stamp: 'HenrikSperreJohansen 6/28/2010 12:12'! ifError: errorHandlerBlock "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. [1 / 0] ifError: [:err :rcvr | 'ZeroDivide' = err ifTrue: [Float infinity] ifFalse: [self error: err]] " ^ self on: Error do: [:ex | errorHandlerBlock cull: ex description cull: ex receiver]! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! setBlessingInMetacelloConfig: aMetacelloConfig aMetacelloConfig setBlessingWithBlock: self! ! !BlockClosure methodsFor: 'testing' stamp: 'eem 4/26/2012 10:21'! hasMethodReturn "Answer whether the receiver has a method-return ('^') in its code." | scanner endpc | scanner := InstructionStream new method: outerContext method pc: startpc. endpc := self endPC. scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > endpc]]. ^scanner pc <= endpc! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 1/21/2003 13:16'! isBlock ^ true! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 9/29/2001 21:00'! forkAt: priority "Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process." ^ self newProcess priority: priority; resume! ! !BlockClosure methodsFor: '*Text-Core' stamp: 'stephane.ducasse 4/21/2009 11:52'! asText ^ self asString asText! ! !BlockClosure methodsFor: 'private' stamp: 'eem 5/28/2008 14:50'! copyForSaving "Answer a copy of the receiver suitable for serialization. Notionally, if the receiver's outerContext has been returned from then nothing needs to be done and we can use the receiver. But there's a race condition determining if the receiver has been returned from (it could be executing in a different process). So answer a copy anyway." ^self shallowCopy postCopy! ! !BlockClosure methodsFor: 'evaluating' stamp: 'nk 3/11/2001 11:49'! valueWithEnoughArguments: anArray "call me with enough arguments from anArray" | args | (anArray size == self numArgs) ifTrue: [ ^self valueWithArguments: anArray ]. args := Array new: self numArgs. args replaceFrom: 1 to: (anArray size min: args size) with: anArray startingAt: 1. ^ self valueWithArguments: args! ! !BlockClosure methodsFor: '*DebuggerFilters-Extension' stamp: 'AndreiChis 9/30/2013 10:52'! asFilter ^ BlockFilter forBlock: self. ! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 7/28/2008 13:58'! home ^outerContext home! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ClementBera 10/3/2013 10:21'! valueSupplyingAnswers: aListOfPairs "evaluate the block using a list of questions / answers that might be called upon to automatically respond to Object>>confirm: or FillInTheBlank requests" ^ self on: ProvideAnswerNotification do: [:notify | | answer caption | caption := notify messageText withSeparatorsCompacted. "to remove new lines" answer := aListOfPairs detect: [:each | caption = each first or: [(caption includesSubstring: each first caseSensitive: false) or: [(each first match: caption) or: [(String includesSelector: #matchesRegex:) and: [ [ caption matchesRegex: each first ] on: Error do: [:ignored | false ]]]]]] ifNone: [nil]. answer ifNotNil: [notify resume: answer second] ifNil: [ | outerAnswer | outerAnswer := ProvideAnswerNotification signal: notify messageText. outerAnswer ifNil: [notify resume] ifNotNil: [notify resume: outerAnswer]]]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'MarcusDenker 9/9/2013 14:10'! durationToRun "Answer the duration taken to execute this block." ^ self timeToRun ! ! !BlockClosure methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:39'! doWhileTrue: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is true." | result | [result := self value. conditionBlock value] whileTrue. ^ result! ! !BlockClosure methodsFor: 'exceptions' stamp: 'HenrikSperreJohansen 6/28/2010 12:12'! onDNU: selector do: handleBlock "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" ^ self on: MessageNotUnderstood do: [:exception | exception message selector = selector ifTrue: [handleBlock cull: exception] ifFalse: [exception pass] ]! ! !BlockClosure methodsFor: 'scanning' stamp: 'eem 4/26/2012 10:45'! abstractBytecodeMessagesDo: aBlock "Evaluate aBlock with the sequence of abstract bytecodes in the receiver." self method abstractBytecodeMessagesFrom: startpc to: self endPC do: aBlock "| msgs | msgs := OrderedCollection new. (SortedCollection sortBlock: [:a :b| a compare: b caseSensitive: false]) sortBlock abstractBytecodeMessagesDo: [:msg| msgs add: msg selector]. msgs"! ! !BlockClosure methodsFor: 'controlling' stamp: ''! whileFalse: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is false." ^ [self value] whileFalse: [aBlock value]! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! setProject: aString withInMetacelloConfig: aMetacelloConfig aMetacelloConfig setProject: aString withBlock: self! ! !BlockClosure methodsFor: '*Kernel-Job' stamp: 'SeanDeNigris 8/29/2012 13:41'! asJob ^ Job block: self.! ! !BlockClosure methodsFor: 'evaluating' stamp: 'HenrikSperreJohansen 8/2/2010 04:40'! value: firstArg value: secondArg "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the arguments and copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= 2 ifTrue: [self numArgsError: 2]. ^self primitiveFailed! ! !BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:24'! valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs ^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each. true}])! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 9/3/2008 14:07'! numCopiedValues "Answer the number of copied values of the receiver. Since these are stored in the receiver's indexable fields this is the receiver's basic size. Primitive. Answer the number of indexable variables in the receiver. This value is the same as the largest legal subscript." ^self basicSize! ! !BlockClosure methodsFor: 'error handing' stamp: 'eem 11/26/2008 20:03'! numArgsError: numArgsForInvocation | printNArgs | printNArgs := [:n| n printString, ' argument', (n = 1 ifTrue: [''] ifFalse:['s'])]. self error: 'This block accepts ', (printNArgs value: numArgs), ', but was called with ', (printNArgs value: numArgsForInvocation), '.'! ! !BlockClosure methodsFor: 'evaluating' stamp: 'HenrikSperreJohansen 8/2/2010 04:40'! value: firstArg value: secondArg value: thirdArg value: fourthArg "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the arguments and copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= 4 ifTrue: [self numArgsError: 4]. ^self primitiveFailed! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/3/2008 14:08'! valueWithArguments: anArray "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the arguments in an anArray and copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= anArray size ifTrue: [self numArgsError: anArray size]. newContext := self asContextWithSender: thisContext sender. ncv := self numCopiedValues. newContext stackp: ncv + numArgs. 1 to: numArgs do: [:i| newContext at: i put: (anArray at: i)]. 1 to: ncv do: [:i| newContext at: i + numArgs put: (self at: i)]. thisContext privSender: newContext! ! !BlockClosure methodsFor: 'evaluating' stamp: 'BenjaminVanRyseghem 9/9/2013 11:07'! timeToRun "Answer the number of milliseconds taken to execute this block." ^ Duration milliSeconds: (Time millisecondsToRun: self)! ! !BlockClosure methodsFor: 'accessing' stamp: 'CamilleTeruel 2/14/2014 14:52'! numLocalTemps "Answer the number of local temporaries for the receiver" ^BlockLocalTempCounter tempCountForBlockAt: startpc - 4 "size of push closure copy bytecode" in: self method! ! !BlockClosure methodsFor: '*Fuel' stamp: 'MartinDias 3/26/2012 19:21'! cleanCopy "Answer a copy of myself preserving in outerContext just the receiver and method, which are the only needed by a clean block closure." ^ self shallowCopy cleanOuterContext; yourself! ! !BlockClosure methodsFor: '*AST-Interpreter-Extension' stamp: 'MarcusDenker 5/1/2013 16:36'! asASTBlockClosure ^ASTBlockClosure new homeContext: self home asASTInterpreterContext; code: self sourceNode. ! ! !BlockClosure methodsFor: 'private' stamp: 'HenrikSperreJohansen 8/2/2010 04:15'! asContextWithSender: aContext "Inner private support method for evaluation. Do not use unless you know what you're doing." ^(MethodContext newForMethod: outerContext method) setSender: aContext receiver: outerContext receiver method: outerContext method closure: self startpc: startpc; privRefresh! ! !BlockClosure methodsFor: 'scanning' stamp: 'eem 4/26/2012 11:02'! blockCreationBytecodeMessage "Answer the abstract bytecode message that created the receiver." | blockCreationBytecodeSize | ^self method abstractBytecodeMessageAt: startpc - (blockCreationBytecodeSize := 4) "(SortedCollection sortBlock: [:a :b| a compare: b caseSensitive: false]) sortBlock blockCreationBytecodeMessage"! ! !BlockClosure methodsFor: 'evaluating' stamp: 'jrp 10/10/2004 22:28'! valueSuppressingAllMessages ^ self valueSuppressingMessages: #('*')! ! !BlockClosure methodsFor: 'scheduling' stamp: 'marcus.denker 6/10/2009 20:28'! newProcessWith: anArray "Answer a Process running the code in the receiver. The receiver's block arguments are bound to the contents of the argument, anArray. The process is not scheduled." "Simulation guard" ^Process forContext: [self valueWithArguments: anArray. Processor terminateActive] asContext priority: Processor activePriority! ! !BlockClosure methodsFor: 'controlling' stamp: ''! whileTrue "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is true." ^ [self value] whileTrue: []! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 5/25/2008 14:47'! valueWithPossibleArgument: anArg "Evaluate the block represented by the receiver. If the block requires one argument, use anArg, if it requires more than one, fill up the rest with nils." | a | numArgs = 0 ifTrue: [^self value]. numArgs = 1 ifTrue: [^self value: anArg]. a := Array new: numArgs. a at: 1 put: anArg. ^self valueWithArguments: a! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 7/15/2001 16:03'! fork "Create and schedule a Process running the code in the receiver." ^ self newProcess resume! ! !BlockClosure methodsFor: 'exceptions' stamp: 'MarcusDenker 12/9/2010 14:53'! assertWithDescription: aStringOrABlock self value ifFalse: [ |value| value := aStringOrABlock value. AssertionFailure signal: value]! ! !BlockClosure methodsFor: 'printing' stamp: 'MarcusDenker 5/27/2013 16:43'! printOn: aStream OpalCompiler isActive ifTrue: [ aStream nextPutAll: self sourceNode formattedCode ] ifFalse: [ aStream nextPutAll: '[...]']! ! !BlockClosure methodsFor: 'private' stamp: 'eem 5/28/2008 14:56'! reentrant "Answer a version of the recever that can be reentered. Closures are reentrant (unlike BlockContect) so simply answer self." ^self! ! !BlockClosure methodsFor: 'private' stamp: 'MarcusDenker 9/30/2011 16:27'! valueUnpreemptively "Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!" "Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! After you've done all that thinking, go right ahead and use it..." | activeProcess oldPriority result semaphore | activeProcess := Processor activeProcess. oldPriority := activeProcess priority. activeProcess priority: Processor highestPriority. result := self ensure: [activeProcess priority: oldPriority]. "Yield after restoring priority to give the preempted processes a chance to run. We inline the code of Processor yield here, but without the primitive. The reason: the yield primitive does not take into account a change of priority as done above" semaphore := Semaphore new. [semaphore signal] fork. semaphore wait. ^result! ! !BlockClosure methodsFor: 'controlling' stamp: ''! whileFalse "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is false." ^ [self value] whileFalse: []! ! !BlockClosure methodsFor: '*OpalCompiler-Core' stamp: 'CamilleTeruel 2/14/2014 14:44'! sourceNode ^ self asContext sourceNode! ! !BlockClosure methodsFor: 'controlling' stamp: ''! whileTrue: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is true." ^ [self value] whileTrue: [aBlock value]! ! !BlockClosure methodsFor: 'accessing' stamp: 'stephane.ducasse 5/20/2009 21:19'! argumentCount "Answer the number of arguments that must be used to evaluate this block" ^numArgs ! ! !BlockClosure methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! forkNamed: aString "Create and schedule a Process running the code in the receiver and having the given name." ^ self newProcess name: aString; resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:25'! newProcess "Answer a Process running the code in the receiver. The process is not scheduled." "Simulation guard" ^Process forContext: [self value. Processor terminateActive] asContext priority: Processor activePriority! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! setDescriptionInMetacelloConfig: aMetacelloConfig aMetacelloConfig setDescriptionWithBlock: self! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ClementBera 4/30/2013 13:45'! valueWithInterval: aDelay "Executes the block every x milliseconds specified in arguments. Answers the process, so you can terminate it" ^ [ [ self value. aDelay wait. ] repeat ] forkAt: Processor userBackgroundPriority named: (String streamContents: [ :s | s << 'every '; print: aDelay; <<' do: '; print: self ] )! ! !BlockClosure methodsFor: 'exceptions' stamp: 'CamilloBruni 10/19/2012 12:34'! on: exception do: handlerAction "Evaluate the receiver in the scope of an exception handler. " | handlerActive | "The following primitive is just a marker used to find the error handling context. see MethodContext>>#isHandlerContext " "...it will always fail and execute the following code" handlerActive := true. ^ self value! ! !BlockClosure methodsFor: 'evaluating' stamp: 'HenrikSperreJohansen 2/18/2010 14:36'! cull: firstArg cull: secondArg cull: thirdArg ^numArgs < 3 ifTrue: [self cull: firstArg cull: secondArg] ifFalse: [self value: firstArg value: secondArg value: thirdArg] ! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! setPackage: aString withInMetacelloConfig: aMetacelloConfig aMetacelloConfig setPackage: aString withBlock: self! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 6/26/2008 09:17'! receiver ^outerContext receiver! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 9/3/2008 13:57'! copiedValueAt: i ^self basicAt: i! ! !BlockClosure methodsFor: '*Tools' stamp: 'BernardoContreras 8/15/2011 20:25'! timeProfile ^Smalltalk tools timeProfiler onBlock: self! ! !BlockClosure methodsFor: '*FuelTests' stamp: 'MarianoMartinezPeck 4/20/2012 21:16'! assertWellMaterializedInto: aBlockClosure in: aTestCase aTestCase assert: self ~~ aBlockClosure. aTestCase assert: (self class == aBlockClosure class). aTestCase assert: numArgs = aBlockClosure numArgs. aTestCase assert: startpc = aBlockClosure startpc. outerContext isNil ifTrue: [ self assert: aBlockClosure outerContext isNil ] ifFalse: [ self isClean ifTrue: [ "self assert: self receiver = aBlockClosure receiver." self assert: (self method isEqualRegardlessTrailerTo: aBlockClosure method). self assert: aBlockClosure outerContext sender isNil. self assert: aBlockClosure outerContext arguments isEmpty. ] ifFalse: [outerContext assertWellMaterializedInto: aBlockClosure outerContext in: aTestCase] ] ! ! !BlockClosure methodsFor: 'exceptions' stamp: 'StephaneDucasse 8/17/2011 22:39'! on: exception fork: handlerAction "Activate the receiver. In case of exception, fork a new process, which will handle an error. An original process will continue running as if receiver evaluation finished and answered nil, i.e., an expression like: [ self error: 'some error'] on: Error fork: [:ex | 123 ] will always answer nil for original process, not 123. The context stack , starting from context which sent this message to receiver and up to the top of the stack will be transferred to forked process, with handlerAction on top. (so when the forked process will be resuming, it will enter the handlerAction) " ^ self on: exception do: [:ex | | copy onDoCtx process handler bottom thisCtx | onDoCtx := thisContext. thisCtx := onDoCtx home. "find the context on stack for which this method's is sender" [ onDoCtx sender == thisCtx] whileFalse: [ onDoCtx := onDoCtx sender. onDoCtx ifNil: [ "Can't find our home context. seems like we're already forked and handling another exception in new thread. In this case, just pass it through handler." ^ handlerAction cull: ex ] ]. bottom := [ Processor terminateActive ] asContext. onDoCtx privSender: bottom. handler := [ handlerAction cull: ex ] asContext. handler privSender: thisContext sender. (Process forContext: handler priority: Processor activePriority) resume. "cut the stack of current process" thisContext privSender: thisCtx. nil ] ! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! setConfiguration: aString withInMetacelloConfig: aMetacelloConfig aMetacelloConfig setConfiguration: aString withBlock: self! ! !BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:22'! valueAt: blockPriority "Evaluate the receiver (block), with another priority as the actual one and restore it afterwards. The caller should be careful with using higher priorities." | activeProcess result outsidePriority | activeProcess := Processor activeProcess. outsidePriority := activeProcess priority. activeProcess priority: blockPriority. result := self ensure: [activeProcess priority: outsidePriority]. "Yield after restoring lower priority to give the preempted processes a chance to run." blockPriority > outsidePriority ifTrue: [Processor yield]. ^ result! ! !BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:24'! valueSuppressingMessages: aListOfStrings ^ self valueSuppressingMessages: aListOfStrings supplyingAnswers: #()! ! !BlockClosure methodsFor: 'initialize-release' stamp: 'eem 9/3/2008 14:08'! outerContext: aContext startpc: aStartpc numArgs: argCount copiedValues: anArrayOrNil outerContext := aContext. startpc := aStartpc. numArgs := argCount. 1 to: self numCopiedValues do: [:i| self at: i put: (anArrayOrNil at: i)]! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! setBaseline: aString withInMetacelloConfig: aMetacelloConfig aMetacelloConfig setBaseline: aString withBlock: self! ! !BlockClosure methodsFor: 'evaluating' stamp: 'SvenVanCaekenberghe 11/2/2012 11:17'! bench "Return how many times the receiver can get executed in 5 seconds. Answer a meaningful description." "[3.14 printString] bench" | startTime endTime count roundTo3Digits | roundTo3Digits := [:num | | rounded lowDigit | rounded := (num * 1000) rounded. "round to 1/1000" lowDigit := (rounded numberOfDigitsInBase: 10) - 3. "keep only first 3 digits" rounded := rounded roundTo:(10 raisedTo: lowDigit). (lowDigit >= 3 or: [rounded \\ 1000 = 0]) "display fractional part only when needed" ifTrue: [(rounded // 1000) asStringWithCommas] ifFalse: [(rounded / 1000.0) printString]]. count := 0. endTime := Time millisecondClockValue + 5000. self assert: endTime < SmallInteger maxVal. startTime := Time millisecondClockValue. [ Time millisecondClockValue > endTime ] whileFalse: [ self value. count := count + 1 ]. endTime := Time millisecondClockValue. ^count = 1 ifTrue: [ (roundTo3Digits value: (endTime - startTime) / 1000) , ' seconds.' ] ifFalse: [ (roundTo3Digits value: (count * 1000) / (endTime - startTime)) , ' per second.' ]! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 7/26/2002 11:49'! valueUninterruptably "Prevent remote returns from escaping the sender. Even attempts to terminate (unwind) this process will be halted and the process will resume here. A terminate message is needed for every one of these in the sender chain to get the entire process unwound." ^ self ifCurtailed: [^ self]! ! !BlockClosure methodsFor: 'scheduling' stamp: 'eem 5/28/2008 16:16'! asContext "Create a MethodContext that is ready to execute self. Assumes self takes no args (if it does the args will be nil)" ^self asContextWithSender: nil! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 4/26/2012 10:20'! endPC ^self blockCreationBytecodeMessage arguments last + startpc - 1! ! !BlockClosure methodsFor: 'controlling' stamp: 'ls 9/24/1999 09:45'! repeatWithGCIf: testBlock | ans | "run the receiver, and if testBlock returns true, garbage collect and run the receiver again" ans := self value. (testBlock value: ans) ifTrue: [ Smalltalk garbageCollect. ans := self value ]. ^ans! ! !BlockClosure methodsFor: 'evaluating' stamp: 'HenrikSperreJohansen 8/2/2010 04:39'! value "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= 0 ifTrue: [self numArgsError: 0]. ^self primitiveFailed! ! !BlockClosure methodsFor: 'evaluating' stamp: 'HenrikSperreJohansen 8/2/2010 04:39'! value: anArg "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the argument and copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= 1 ifTrue: [self numArgsError: 1]. self primitiveFailed! ! !BlockClosure methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! forkAt: priority named: name "Create and schedule a Process running the code in the receiver at the given priority and having the given name. Answer the newly created process." | forkedProcess | forkedProcess := self newProcess. forkedProcess priority: priority. forkedProcess name: name. ^ forkedProcess resume! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 8/22/2008 14:21'! valueNoContextSwitch "An exact copy of BlockClosure>>value except that this version will not preempt the current process on block activation if a higher-priority process is runnable. Primitive. Essential." numArgs ~= 0 ifTrue: [self numArgsError: 0]. self primitiveFailed! ! !BlockClosure methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! valueSupplyingMetacelloAnswers: aListOfPairs "evaluate the block using a list of questions / answers that might be called upon to automatically respond to Object>>confirm: or FillInTheBlank requests" ^ [self value] on: ProvideAnswerNotification do: [:notify | | answer caption | caption := notify messageText withSeparatorsCompacted. "to remove new lines" answer := aListOfPairs detect: [:each | caption = each first or: [(caption includesSubstring: each first caseSensitive: false) or: [(each first match: caption) or: [(String includesSelector: #matchesRegex:) and: [ [ caption matchesRegex: each first ] on: Error do: [:ignored | false ]]]]]] ifNone: [nil]. answer ifNotNil: [notify resume: answer second] ifNil: [ | outerAnswer | outerAnswer := ProvideAnswerNotification signal: notify messageText. outerAnswer ifNil: [notify resume] ifNotNil: [notify resume: outerAnswer]]]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 8/22/2008 14:21'! valueNoContextSwitch: anArg "An exact copy of BlockClosure>>value: except that this version will not preempt the current process on block activation if a higher-priority process is runnable. Primitive. Essential." numArgs ~= 1 ifTrue: [self numArgsError: 1]. self primitiveFailed! ! !BlockClosure methodsFor: 'testing' stamp: 'eem 11/26/2008 20:27'! isDead "Has self finished" ^false! ! !BlockClosure methodsFor: 'debugger access' stamp: 'nice 4/14/2009 19:09'! sender "Answer the context that sent the message that created the receiver." ^outerContext sender! ! !BlockClosure methodsFor: '*Tools' stamp: 'IgorStasenko 8/17/2011 14:53'! timeToRunWithoutGC "Answer the number of milliseconds taken to execute this block without GC time." ^ Smalltalk vm totalGCTime + self timeToRun - Smalltalk vm totalGCTime ! ! !BlockClosure methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:45'! doWhileFalse: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is false." | result | [result := self value. conditionBlock value] whileFalse. ^ result! ! !BlockClosure methodsFor: 'evaluating' stamp: 'HenrikSperreJohansen 2/18/2010 14:35'! cull: anArg ^numArgs = 0 ifTrue: [self value] ifFalse: [self value: anArg] ! ! !BlockClosure methodsFor: 'controlling' stamp: 'sma 5/12/2000 13:22'! repeat "Evaluate the receiver repeatedly, ending only if the block explicitly returns." [self value. true] whileTrue! ! !BlockClosure methodsFor: 'evaluating' stamp: 'SeanDeNigris 1/22/2013 12:58'! valueWithin: aDuration onTimeout: timeoutBlock "Evaluate the receiver. If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead" | theProcess delay watchdog tag | aDuration <= Duration zero ifTrue: [^ timeoutBlock value ]. "the block will be executed in the current process" theProcess := Processor activeProcess. delay := aDuration asDelay. tag := self. "make a watchdog process" watchdog := [ delay wait. "wait for timeout or completion" theProcess ifNotNil:[ theProcess signalException: (TimedOut new tag: tag)] ] newProcess. "Watchdog needs to run at high priority to do its job (but not at timing priority)" watchdog priority: Processor timingPriority-1. "catch the timeout signal" ^ [ watchdog resume. "start up the watchdog" self ensure:[ "evaluate the receiver" theProcess := nil. "it has completed, so ..." delay delaySemaphore signal. "arrange for the watchdog to exit" ]] on: TimedOut do: [ :e | e tag == tag ifTrue:[ timeoutBlock value ] ifFalse:[ e pass]].! ! !BlockClosure methodsFor: 'testing' stamp: 'eem 5/23/2008 13:48'! isClosure ^true! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! setAuthorInMetacelloConfig: aMetacelloConfig aMetacelloConfig setAuthorWithBlock: self! ! !BlockClosure methodsFor: 'exceptions' stamp: 'jannik.laval 5/2/2010 06:40'! assert self value ifFalse: [AssertionFailure signal: 'Assertion failed'] ! ! !BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:23'! valueSupplyingAnswer: anObject ^ (anObject isCollection and: [anObject isString not]) ifTrue: [self valueSupplyingAnswers: {anObject}] ifFalse: [self valueSupplyingAnswers: {{'*'. anObject}}]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'HenrikSperreJohansen 8/2/2010 04:40'! value: firstArg value: secondArg value: thirdArg "Activate the receiver, creating a closure activation (MethodContext) whose closure is the receiver and whose caller is the sender of this message. Supply the arguments and copied values to the activation as its arguments and copied temps. Primitive. Optional (but you're going to want this for performance)." | newContext ncv | numArgs ~= 3 ifTrue: [self numArgsError: 3]. ^self primitiveFailed! ! !BlockClosure methodsFor: 'evaluating' stamp: 'md 3/28/2006 20:17'! valueWithExit self value: [ ^nil ]! ! !BlockClosure methodsFor: '*Fuel' stamp: 'MarianoMartinezPeck 9/24/2013 14:48'! shouldBeSubstitutedByCleanCopy ^ self isClean ! ! !BlockClosure methodsFor: '*Fuel' stamp: 'MarianoMartinezPeck 9/24/2013 14:49'! fuelAccept: aGeneralMapper ^ self shouldBeSubstitutedByCleanCopy "The 'onRecursionDo:' is just to avoid an infinitive loop for the substitution. The cleanCopy MUST be a clean copy so it can be serialized normally" ifTrue: [ aGeneralMapper visitSubstitution: self by: self cleanCopy onRecursionDo: [ aGeneralMapper visitVariableObject: self ] ] ifFalse: [ aGeneralMapper visitVariableObject: self ]! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ar 12/4/2009 18:30'! ensure: aBlock "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes. N.B. This method is *not* implemented as a primitive. Primitive 198 always fails. The VM uses prim 198 in a context's method as the mark for an ensure:/ifCurtailed: activation." | complete returnValue | returnValue := self valueNoContextSwitch. complete ifNil:[ complete := true. aBlock value. ]. ^ returnValue! ! !BlockClosure methodsFor: 'testing' stamp: 'eem 4/26/2012 10:42'! isClean "Answer if the receiver does not close-over any variables other than globals, and does not ^-return (does not close over the home context). Clean blocks are amenable to being created at compile-time." self numCopiedValues > 0 ifTrue: [^false]. self abstractBytecodeMessagesDo: [:msg| (#( pushReceiver pushReceiverVariable: popIntoReceiverVariable: storeIntoReceiverVariable: methodReturnConstant: methodReturnReceiver methodReturnTop) includes: msg selector) ifTrue: [^false]]. ^true "clean:" "[] isClean" "[:a :b| a < b] isClean" "unclean" "[^nil] isClean" "[self class] isClean" "| v | v := 0. [v class] isClean"! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:21'! outerContext ^outerContext! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 10/16/2002 11:14'! forkAndWait "Suspend current process and execute self in new process, when it completes resume current process" | semaphore | semaphore := Semaphore new. [self ensure: [semaphore signal]] fork. semaphore wait. ! ! !BlockClosure methodsFor: 'private' stamp: 'sd 3/22/2009 19:33'! isValid "Answer the receiver." ^true! ! !BlockClosure methodsFor: 'evaluating' stamp: 'StephaneDucasse 8/17/2011 22:24'! cull: firstArg cull: secondArg cull: thirdArg cull: fourthArg "Execute the receiver with four or less arguments. Check cull:cull: for examples" ^numArgs < 4 ifTrue: [self cull: firstArg cull: secondArg cull: thirdArg] ifFalse: [self value: firstArg value: secondArg value: thirdArg value: fourthArg] ! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ar 12/4/2009 18:41'! ifCurtailed: aBlock "Evaluate the receiver with an abnormal termination action. Evaluate aBlock only if execution is unwound during execution of the receiver. If execution of the receiver finishes normally do not evaluate aBlock. N.B. This method is *not* implemented as a primitive. Primitive 198 always fails. The VM uses prim 198 in a context's method as the mark for an ensure:/ifCurtailed: activation." | complete result | result := self valueNoContextSwitch. complete := true. ^result! ! !BlockClosure methodsFor: 'evaluating' stamp: 'HenrikSperreJohansen 2/18/2010 14:36'! cull: firstArg cull: secondArg ^numArgs < 2 ifTrue: [self cull: firstArg] ifFalse: [self value: firstArg value: secondArg] ! ! !BlockClosure methodsFor: 'controlling' stamp: 'jcg 7/8/2007 18:25'! whileNil: aBlock "Unlike #whileTrue/False: this is not compiled inline." ^ [self value isNil] whileTrue: [aBlock value] ! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 6/1/2008 09:39'! startpc ^startpc! ! !BlockClosure methodsFor: 'controlling' stamp: 'jcg 7/8/2007 18:25'! whileNotNil: aBlock "Unlike #whileTrue/False: this is not compiled inline." ^ [self value notNil] whileTrue: [aBlock value] ! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 5/29/2008 12:18'! method ^outerContext method! ! !BlockClosure methodsFor: '*system-announcements' stamp: 'EstebanLorenzano 8/8/2012 11:20'! valueWithoutNotifications ^SystemAnnouncer uniqueInstance suspendAllWhile: self! ! !BlockClosure methodsFor: 'private' stamp: 'sd 3/22/2009 19:33'! asMinimalRepresentation "Answer the receiver." ^self! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! setTimestampInMetacelloConfig: aMetacelloConfig aMetacelloConfig setTimestampWithBlock: self! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 5/28/2008 15:03'! valueWithPossibleArgs: anArray ^numArgs = 0 ifTrue: [self value] ifFalse: [self valueWithArguments: (numArgs = anArray size ifTrue: [anArray] ifFalse: [numArgs > anArray size ifTrue: [anArray, (Array new: numArgs - anArray size)] ifFalse: [anArray copyFrom: 1 to: numArgs]])]! ! !BlockClosure methodsFor: '*Collections-Abstract-splitjoin' stamp: 'CamilloBruni 1/19/2013 12:40'! split: aSequenceableCollection indicesDo: aBlock "Example: [ :char| char isSeparator ] split: 'aa bb cc dd'" | position | position := 1. aSequenceableCollection withIndexDo: [:element :idx | (self value: element) ifTrue: [ aBlock value: position value: idx - 1. position := idx + 1 ]]. aBlock value: position value: aSequenceableCollection size! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 5/28/2008 16:02'! numArgs "Answer the number of arguments that must be used to evaluate this block" ^numArgs! ! !BlockClosure methodsFor: '*Fuel' stamp: 'MartinDias 3/26/2012 19:22'! cleanOuterContext "Clean my outerContext preserving just the receiver and method, which are the only needed by a clean block closure." outerContext := outerContext cleanCopy! ! !BlockClosure methodsFor: 'accessing' stamp: 'CamilleTeruel 2/14/2014 14:52'! numTemps "Answer the number of temporaries for the receiver; this includes the number of arguments and the number of copied values." ^self numCopiedValues + self numArgs + self numLocalTemps! ! !BlockClosure methodsFor: '*FuelTests' stamp: 'MarianoMartinezPeck 8/19/2012 15:46'! fuelValueWithoutNotifications SystemAnnouncer uniqueInstance suspendAllWhile: self! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ClementBera 4/30/2013 13:46'! valueAfterWaiting: aDelay "Waits for a delay, then executes the block. Answers the process so you can terminate it" ^ [ aDelay wait. self value ] forkAt: Processor userBackgroundPriority named: (String streamContents: [ :s | s << 'After '; print: aDelay; <<' do: '; print: self ] )! ! !BlockClosure methodsFor: 'evaluating' stamp: 'eem 9/5/2009 13:05'! simulateValueWithArguments: anArray caller: aContext | newContext sz | (anArray class ~~ Array or: [numArgs ~= anArray size]) ifTrue: [^ContextPart primitiveFailToken]. newContext := (MethodContext newForMethod: outerContext method) setSender: aContext receiver: outerContext receiver method: outerContext method closure: self startpc: startpc. sz := self basicSize. newContext stackp: sz + numArgs. 1 to: numArgs do: [:i| newContext at: i put: (anArray at: i)]. 1 to: sz do: [:i| newContext at: i + numArgs put: (self at: i)]. ^newContext! ! !BlockClosure methodsFor: 'accessing' stamp: 'MarcusDenker 10/12/2013 08:46'! argumentNames ^ self sourceNode arguments collect: [ :each | each name ] ! ! !BlockClosure methodsFor: '*metacello-core-scripting' stamp: 'dkh 7/16/2012 10:51'! execute: projectSpecBlock against: aScriptExecutor aScriptExecutor executeBlock: self do: projectSpecBlock! ! !BlockClosure class methodsFor: 'instance creation' stamp: 'eem 9/3/2008 14:02'! outerContext: aContext startpc: aStartpc numArgs: argCount copiedValues: anArrayOrNil ^(self new: anArrayOrNil basicSize) outerContext: aContext startpc: aStartpc numArgs: argCount copiedValues: anArrayOrNil! ! !BlockClosureTest commentStamp: 'TorstenBergmann 2/5/2014 08:31'! SUnit tests for BlockClosure! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testSupplyAnswerUsingOnlySubstringOfQuestion self should: [false = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('like' false))]! ! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testSupplyAnswerUsingRegexMatchOfQuestion (String includesSelector: #matchesRegex:) ifFalse: [^ self]. self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('.*Smalltalk\?' true))]! ! !BlockClosureTest methodsFor: 'tests - on-fork' stamp: 'SvenVanCaekenberghe 3/1/2014 13:29'! testOnForkSplit "Test that when forking, the stack are split correctly (there is no any contexts referenced by both processes)" | sema timeout forkedContexts myContexts c | self flag: 'This test is too brittle, failing often on CI'; skip. sema := Semaphore new. [ 1/0 ] on: Exception fork: [ | ctx | forkedContexts := IdentitySet new. ctx := thisContext. [ ctx notNil ] whileTrue: [ forkedContexts add: ctx. ctx := ctx sender ]. sema signal ]. timeout := (sema waitTimeoutSeconds: 1). self assert: timeout == false description: 'fork lasted more than one second'. myContexts := IdentitySet new. c := thisContext. [ c notNil ] whileTrue: [ myContexts add: c. c := c sender ]. self assert: (myContexts noneSatisfy: [:b | forkedContexts includes: b ]) description: 'myContexts are not within forkedContexts'. self assert: (forkedContexts noneSatisfy: [:b | myContexts includes: b ]) description: 'forkedContexts are not within myContexts'.! ! !BlockClosureTest methodsFor: 'tests - on-fork' stamp: 'GuillermoPolito 5/28/2011 14:35'! testOnForkErrorOnSeparateProcess "Test that if code runs with error, there is fork" | result forkedProc sema | sema := Semaphore new. result := [ 1/0 ] on: Exception fork: [ forkedProc := Processor activeProcess. sema signal ]. sema wait. self assert: (forkedProc ~~ Processor activeProcess).! ! !BlockClosureTest methodsFor: 'tests - evaluating' stamp: 'CamilloBruni 8/31/2013 20:23'! testCullCullCull [ ] cull: 1 cull: 2 cull: 3. [ :x | ] cull: 1 cull: 2 cull: 3. [ :x :y | ] cull: 1 cull: 2 cull: 3. [ :x :y :z | ] cull: 1 cull: 2 cull: 3. self should: [ [ :x :y :z :a | ] cull: 1 cull: 2 cull: 3 ] raise: Error. self should: [ [ :x :y :z :a :b | ] cull: 1 cull: 2 cull: 3 ] raise: Error. self assert: ([ 0 ] cull: 1 cull: 2 cull: 3) = 0. self assert: ([ :x | x ] cull: 1 cull: 2 cull: 3) = 1. self assert: ([ :x :y | y ] cull: 1 cull: 2 cull: 3) = 2. self assert: ([ :x :y :z | z ] cull: 1 cull: 2 cull: 3) = 3! ! !BlockClosureTest methodsFor: 'tests - evaluating' stamp: 'CamilloBruni 8/31/2013 20:23'! testCullCullCullCull [ ] cull: 1 cull: 2 cull: 3 cull: 4. [ :x | ] cull: 1 cull: 2 cull: 3 cull: 4. [ :x :y | ] cull: 1 cull: 2 cull: 3 cull: 4. [ :x :y :z | ] cull: 1 cull: 2 cull: 3 cull: 4. [ :x :y :z :a | ] cull: 1 cull: 2 cull: 3 cull: 4. self should: [ [ :x :y :z :a :b | ] cull: 1 cull: 2 cull: 3 cull: 4 ] raise: Error. self assert: ([ 0 ] cull: 1 cull: 2 cull: 3 cull: 4) = 0. self assert: ([ :x | x ] cull: 1 cull: 2 cull: 3 cull: 4) = 1. self assert: ([ :x :y | y ] cull: 1 cull: 2 cull: 3 cull: 4) = 2. self assert: ([ :x :y :z | z ] cull: 1 cull: 2 cull: 3 cull: 4) = 3. self assert: ([ :x :y :z :a | a ] cull: 1 cull: 2 cull: 3 cull: 4) = 4! ! !BlockClosureTest methodsFor: 'tests - on-fork' stamp: 'GuillermoPolito 5/28/2011 14:34'! testOnForkErrorReturnsNil "Test that if code runs with error, there is fork" | result sema | sema := Semaphore new. result := [ 1/0 ] on: Exception fork: [ sema signal. ]. sema wait. "in case of error, evaluation result should be nil" self assert: result isNil.! ! !BlockClosureTest methodsFor: 'tests - evaluating' stamp: 'MarcusDenker 2/24/2010 12:28'! testValueWithPossibleArgument | block blockWithArg blockWith2Arg | block := [1]. blockWithArg := [:arg | arg]. blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. self assert: (block valueWithPossibleArgument: 1) = 1. self assert: (blockWithArg valueWithPossibleArgument: 1) = 1. self assert: (blockWith2Arg valueWithPossibleArgument: 1) = {1 . nil}. ! ! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testTrace self assert: (ContextPart trace: aBlockContext) class = Rectangle.! ! !BlockClosureTest methodsFor: 'testing' stamp: 'MarcusDenker 2/24/2010 12:28'! testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer self should: ['red' = ([UIManager default request: 'Your favorite color?' initialAnswer: 'red'] valueSupplyingAnswer: #('Your favorite color?' #default))]! ! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testSupplySpecificAnswerToQuestion self should: [false = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('You like Smalltalk?' false))]! ! !BlockClosureTest methodsFor: 'tests - evaluating' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testValueWithPossibleArgs | block blockWithArg blockWith2Arg | block := [ 1 ]. blockWithArg := [ :arg | arg ]. blockWith2Arg := [ :arg1 :arg2 | {arg1. arg2} ]. self assert: (block valueWithPossibleArgs: #()) = 1. self assert: (block valueWithPossibleArgs: #(1)) = 1. self assert: (blockWithArg valueWithPossibleArgs: #()) isNil. self assert: (blockWithArg valueWithPossibleArgs: #(1)) = 1. self assert: (blockWithArg valueWithPossibleArgs: #(1 2)) = 1. self assert: (blockWith2Arg valueWithPossibleArgs: #()) = {nil. nil}. self assert: (blockWith2Arg valueWithPossibleArgs: #(1)) = {1. nil}. self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2)) = #(1 2). self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2 3)) = #(1 2)! ! !BlockClosureTest methodsFor: 'tests - evaluating' stamp: 'MarcusDenker 2/24/2010 12:28'! testValueWithExitContinue | val last | val := 0. 1 to: 10 do: [ :i | [ :continue | i = 4 ifTrue: [continue value]. val := val + 1. last := i ] valueWithExit. ]. self assert: val = 9. self assert: last = 10. ! ! !BlockClosureTest methodsFor: 'tests' stamp: 'HenrikSperreJohansen 6/28/2010 12:18'! testOneArgument | c | c := OrderedCollection new. c add: 'hello'. [c do: [1 + 2]] ifError: [:err | self deny: err = 'This block requires 0 arguments.']. [c do: [:arg1 :arg2 | 1 + 2]] ifError: [:err | self deny: err = 'This block requires 2 arguments.'] ! ! !BlockClosureTest methodsFor: 'tests - on-fork' stamp: 'IgorStasenko 5/23/2011 12:29'! testOnFork "Test that if code runs without errors, there is no fork!! " | result1 result2 | result2 := nil. result1 := [ 1 ] on: Exception fork: [ result2 := 2 ]. Processor yield. self assert: (result1 = 1). self assert: (result2 isNil ).! ! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testSupplyAnswerThroughNestedBlocks self should: [true = ([[self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('Blub' false)] valueSupplyingAnswer: #('Smalltalk' true))]! ! !BlockClosureTest methodsFor: 'tests - evaluating' stamp: 'CamilloBruni 8/31/2013 20:23'! testCullCull [ ] cull: 1 cull: 2. [ :x | ] cull: 1 cull: 2. [ :x :y | ] cull: 1 cull: 2. self should: [ [ :x :y :z | ] cull: 1 cull: 2 ] raise: Error. self should: [ [ :x :y :z :a | ] cull: 1 cull: 2 ] raise: Error. self should: [ [ :x :y :z :a :b | ] cull: 1 cull: 2 ] raise: Error. self assert: ([ 0 ] cull: 1 cull: 2) = 0. self assert: ([ :x | x ] cull: 1 cull: 2) = 1. self assert: ([ :x :y | y ] cull: 1 cull: 2) = 2! ! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testSupplySameAnswerToAllQuestions self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: true)]. self should: [#(true true) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswer: true)].! ! !BlockClosureTest methodsFor: 'tests - evaluating' stamp: 'MarcusDenker 2/24/2010 12:28'! testValueWithExitBreak | val | [ :break | 1 to: 10 do: [ :i | val := i. i = 4 ifTrue: [break value]. ] ] valueWithExit. self assert: val = 4.! ! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testSuppressInform self should: [[nil inform: 'Should not see this message or this test failed!!'] valueSuppressingAllMessages isNil]! ! !BlockClosureTest methodsFor: 'tests - on-fork' stamp: 'GuillermoPolito 5/28/2011 14:33'! testOnForkErrorExecutesBlock "Test that if code runs with error, there is fork" | result sema | sema := Semaphore new. result := nil. [ 1/0 ] on: Exception fork: [ result := 2. sema signal]. sema wait. "and of course result should be not nil " self assert: result = 2.! ! !BlockClosureTest methodsFor: 'tests' stamp: 'HenrikSperreJohansen 6/28/2010 12:19'! testNoArguments [10 timesRepeat: [:arg | 1 + 2]] ifError: [:err | self deny: err = 'This block requires 1 arguments.']. [10 timesRepeat: [:arg1 :arg2 | 1 + 2]] ifError: [:err | self deny: err = 'This block requires 2 arguments.'] ! ! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testRunSimulated self assert: (ContextPart runSimulated: aBlockContext) class = Rectangle.! ! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testSupplySeveralAnswersToSeveralQuestions self should: [#(false true) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswers: #( ('One' false) ('Two' true) ))]. self should: [#(true false) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswers: #( ('One' true) ('Two' false) ))]! ! !BlockClosureTest methodsFor: 'setup' stamp: 'MarcusDenker 2/24/2010 12:28'! setUp super setUp. aBlockContext := [100@100 corner: 200@200]. contextOfaBlockContext := thisContext.! ! !BlockClosureTest methodsFor: 'tests - evaluating' stamp: 'CamilloBruni 8/31/2013 20:23'! testCull [ ] cull: 1. [ :x | ] cull: 1. self should: [ [ :x :y | ] cull: 1 ] raise: Error. self should: [ [ :x :y :z | ] cull: 1 ] raise: Error. self should: [ [ :x :y :z :a | ] cull: 1 ] raise: Error. self should: [ [ :x :y :z :a :b | ] cull: 1 ] raise: Error. self assert: ([ 0 ] cull: 1) = 0. self assert: ([ :x | x ] cull: 1) = 1! ! !BlockClosureTest methodsFor: 'tests' stamp: 'HenrikSperreJohansen 6/28/2010 12:18'! testNew self should: [ContextPart new: 5] raise: Error. [ContextPart new: 5] ifError: [:error | error = 'Error: Contexts must only be created with newForMethod:']. [ContextPart new] ifError: [:error | error = 'Error: Contexts must only be created with newForMethod:']. [ContextPart basicNew] ifError: [:error | error = 'Error: Contexts must only be created with newForMethod:']. ! ! !BlockClosureTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/30/2012 12:04'! testSetUp "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" self assert: aBlockContext home = contextOfaBlockContext. self assert: aBlockContext receiver = self. self assert: (aBlockContext method isKindOf: CompiledMethod).! ! !BlockClosureTest methodsFor: 'tests' stamp: 'md 6/24/2010 16:25'! testTallyMethods self assert: (ContextPart tallyMethods: aBlockContext) size = 5.! ! !BlockClosureTest methodsFor: 'tests - evaluating' stamp: 'CamilloBruni 8/31/2013 20:23'! testValueWithArguments self should: [ aBlockContext valueWithArguments: #(1) ] raise: Error. aBlockContext valueWithArguments: #(). [ aBlockContext valueWithArguments: #(1) ] ifError: [ :err | self assert: err = 'Error: This block accepts 0 arguments, but was called with 1 argument.' ]. [ [ :i | 3 + 4 ] valueWithArguments: #(1 2) ] ifError: [ :err | self assert: err = 'Error: This block accepts 1 argument, but was called with 2 arguments.' ]! ! !BlockClosureTest methodsFor: 'tests' stamp: 'md 6/24/2010 16:25'! testTallyInstructions self assert: (ContextPart tallyInstructions: aBlockContext) size = 21.! ! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testSuppressInformUsingStringMatchOptions self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('Should not see this message or this test failed!!')) isNil]. self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('not see this message')) isNil]. self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('*message*failed#')) isNil]. ! ! !BlockClosureTest methodsFor: 'testing' stamp: 'MarcusDenker 2/24/2010 12:28'! testSupplyAnswerOfFillInTheBlank self should: ['blue' = ([UIManager default request: 'Your favorite color?'] valueSupplyingAnswer: #('Your favorite color?' 'blue'))]! ! !BlockClosureTest methodsFor: 'tests - on-fork' stamp: 'SvenVanCaekenberghe 2/20/2014 23:38'! testOnForkErrorTakesLessThanOneSecond "Test that if code runs with error, there is fork" | sema timeout | self flag: 'This test is too brittle, failing often on Windows CI'; skip. self flag: 'The following line makes the test pass under headless linux. Everywhere else this test works'. Smalltalk os isUnix ifTrue: [ 1 milliSecond wait ]. sema := Semaphore new. [ 1/0 ] on: Exception fork: [ sema signal ]. timeout := (sema waitTimeoutSeconds: 1). self assert: timeout == false! ! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testSupplyAnswerUsingTraditionalMatchOfQuestion self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('*Smalltalk#' true))]! ! !BlockClosuresTestCase commentStamp: ''! This test case collects examples for block uses that require full block closures.! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:14'! constructFibonacciBlockInDeadFrame | fib | fib := [:val | (val <= 0) ifTrue: [self error: 'not a natural number']. (val <= 2) ifTrue: [1] ifFalse: [(fib value: (val - 1)) + (fib value: (val - 2))]]. ^fib ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 16:05'! testExample1 self assert: ((self example1: 5) = 5 factorial) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'StephaneDucasse 6/9/2012 22:43'! testReentrantBlockOldEnvironmentWithBlockArguement | fib | fib := self constructFibonacciBlockWithBlockArgumentInDeadFrame. self should: [fib value: 0 value: fib] raise: self classForTestResult error. self assert: ((fib value: 1 value: fib) = 1). self assert: ((fib value: 2 value: fib) = 1). self assert: ((fib value: 3 value: fib) = 2). self assert: ((fib value: 4 value: fib) = 3). self assert: ((fib value: 5 value: fib) = 5). self assert: ((fib value: 6 value: fib) = 8). ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'lr 3/31/2009 09:31'! example2: anInteger " BlockClosuresTestCase new example2: 6" " to complicate the example1, we set up a dynamic reference chain that is used to dump all calls of facorial when recursion depth is maximal. The return value is an instance of orderedCollection, the trace. " | factorial trace | trace := OrderedCollection new. factorial := [:x :dumper :trace2 | | localDumper | localDumper := [ :collection | collection add: x. dumper value: collection.]. x = 1 ifTrue: [localDumper value: trace2. 1] ifFalse: [(factorial value: x - 1 value: localDumper value: trace2)* x. ] ]. factorial value: anInteger value: [ :collection | ] value: trace. ^trace! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 16:40'! testNestedLoopsExample1 | arrays result | arrays := OrderedCollection new. arrays add: #(#a #b); add: #(1 2 3 4); add: #('w' 'x' 'y' 'z'). result := OrderedCollection new. CollectionCombinator new forArrays: arrays processWith: [:item |result addLast: item]. self assert: ((self nestedLoopsExample: arrays) = result) ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:15'! constructSharedClosureEnvironmentInDeadFrame |array result| result := 10. array := Array new: 2. array at: 1 put: [:arg | result := arg]. array at: 2 put: [result]. ^array ! ! !BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/25/2002 10:01'! comment " The Jensen device was something very sophisticated in the days of Algol 60. Essentially it was tricky use of a parameter passing policy that was called 'call by name'. In modern terminology, a call by name parameter was a pair of blocks (in a system with full block closures, of course.) For the lovers of Algol 60, here is a short example: BEGIN REAL PROCEDURE JensenSum (A, I, N); REAL A; INTEGER I, N; BEGIN REAL S; S := 0.0; FOR I := 1 STEP 1 UNTIL N DO S := S + A; JensenSum := S; END; ARRAY X [1:10], Y[1:10, 1:10]; COMMENT Do array initialization here ; JensenSum (X[I], I, 10); JensenSum (Y[I, I], I, 10); JensenSum(JensenSum(Y[I, J], J, 10), I, 10); END; The first call sums the elements of X, the second sums the diagonal elements of Y and the third call sums up all elements of Y. It is possible to reimplement all this with blocks only and that is what is done in the jensen device examples. Additional remark: The Jensen device was something for clever minds. I remember an artice written by Donald Knuth and published in the Communications of the ACM (I think in 1962, but I may err) about that programming trick. That article showed how a simple procedure (called the general problem solver) could be used to do almost anything. The problem was of course to find out the right parameters. I seached my collection of photocopies for that article, but regrettably I could not find it. Perhaps I can find it later. "! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:27'! continuationExample3: aCollection " see comment in method continuationExample1:. The block named 'processor' takes a value with contiuation and a processing block. It creates a new value with continuation. Here we set up a chain of three values with continuation: one data source and two value processors. Again we use a collector to collect all values. " | stream processor collector | stream := [:collection | | i localBlock | i := 1. localBlock := [ | current | current := collection at: i. i := i + 1. Array with: current with: (i<= collection size ifTrue: [localBlock] ifFalse: [nil]) ]. ]. processor := [:valueWithContinuation :activity | | localBlock | localBlock := [ | current | current := valueWithContinuation value. Array with: (activity value: current first) with: (current last notNil ifTrue: [localBlock])]. localBlock ]. collector := [:valueWithContinuation | | oc | oc := OrderedCollection new. [ | local | local := valueWithContinuation value. oc add: local first. local last notNil] whileTrue: []. oc. ]. ^collector value: (processor value: (processor value: (stream value: aCollection) value: [:x | x * x]) value: [:x | x - 10]).! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'VeronicaUquillas 6/11/2010 12:47'! example1: anInteger " this example is very simple. A named block recursively computes the factorial. The example tests whether the value of x is still available after the recursive call. Note that the recursive call precedes the multiplication. For the purpose of the test this is essential. (When you commute the factors, the example will work also in some system without block closures, but not in Pharo.) " | factorial | factorial := [:x | x = 1 ifTrue: [1] ifFalse: [(factorial value: x - 1)* x]]. ^ factorial value: anInteger ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/25/2002 09:57'! testGpsExample2 | result array | " integer matrix elements should be used for the purpose of this test. " array := #(#(1 2 3 4 5) #(6 7 8 9 10) #(11 12 13 14 15) #(16 17 18 19 20) #(21 22 23 24 25)). result := array inject: 0 into: [:sum :subarray | sum + (subarray inject: 0 into: [:s :elem | s + elem])]. self assert: ((self gpsExample2: array) = result) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! testContinuationExample1 | array | array := (1 to: 20) asOrderedCollection. self assert: ((self continuationExample1: array) = array) ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:44'! continuationExample2: aCollection " see comment in method continuationExample1:. The block named 'processor' takes a value with contiuation and a processing block. It creates a new value with continuation. Again we use a collector to collect all values. " | stream processor collector | stream := [:collection | | i localBlock | i := 1. localBlock := [ | current | current := collection at: i. i := i + 1. Array with: current with: (i<= collection size ifTrue: [localBlock] ifFalse: [nil]) ]. ]. processor := [:valueWithContinuation :activity | | localBlock | localBlock := [ | current | current := valueWithContinuation value. Array with: (activity value: current first) with: (current last notNil ifTrue: [localBlock])]. localBlock ]. collector := [:valueWithContinuation | | oc | oc := OrderedCollection new. [ | local | local := valueWithContinuation value. oc add: local first. local last notNil] whileTrue: []. oc. ]. ^collector value: (processor value: (stream value: aCollection) value: [:x | x * x]).! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'PeterHugossonMiller 9/2/2009 16:19'! nestedLoopsExample: arrays " A while ago, Hans Baveco asked for a way to dynamically nest loops. Better solutions than this one were proposed, but this one is a beautiful test for recursive block usage. " | result sizeOfResult streams block | "arrays := OrderedCollection new. arrays add: #(#a #b); add: #(1 2 3 4); add: #('w' 'x' 'y' 'z')." sizeOfResult := arrays inject: 1 into: [:prod :array | prod * array size]. streams := arrays collect: [:a | a readStream]. " This is an OrderedCollection of Streams " result := OrderedCollection new: sizeOfResult. block := [:r :tupel :allStreams | | innerBlock | innerBlock := [:myIdx | [myIdx = allStreams size ifTrue: [1 to: allStreams size do: [:i | tupel at: i put: (allStreams at: i) peek]. r addLast: tupel shallowCopy] ifFalse: [innerBlock value: myIdx + 1]. (allStreams at: myIdx) next. (allStreams at: myIdx) atEnd ] whileFalse: []. (allStreams at: myIdx) reset. ]. innerBlock value: 1. r ]. block value: result value: (Array new: streams size) " this is a buffer " value: streams. ^result ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'rw 1/26/2002 01:22'! testCannotReturn | blk | blk := self constructCannotReturnBlockInDeadFrame. self should: [blk value: 1] raise: Exception ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'StephaneDucasse 6/9/2012 22:42'! testReentrantBlockOldEnvironment | fib | fib := self constructFibonacciBlockInDeadFrame. self should: [fib value: 0] raise: self classForTestResult error. self assert: ((fib value: 1) = 1). self assert: ((fib value: 2) = 1). self assert: ((fib value: 3) = 2). self assert: ((fib value: 4) = 3). self assert: ((fib value: 5) = 5). self assert: ((fib value: 6) = 8). ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'StephaneDucasse 5/28/2011 13:39'! testSharedClosureEnvironment |blockArray| blockArray := self constructSharedClosureEnvironmentInDeadFrame. self assert: ((blockArray at: 2) value = 10). self assert: (((blockArray at: 1) value: 5) = 5). self assert: ((blockArray at: 2) value = 5). ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'BG 1/24/2002 17:44'! continuationExample1: aCollection " see comment below. Here we simply collect the values of a value with continuation block " | streamCreator collector | streamCreator := [:collection | | i localBlock | i := 1. localBlock := [ | current | current := collection at: i. i := i + 1. Array with: current with: (i<= collection size ifTrue: [localBlock] ifFalse: [nil]) ]. ]. collector := [:valueWithContinuation | | oc | oc := OrderedCollection new. [ | local | local := valueWithContinuation value. oc add: local first. local last notNil] whileTrue: []. oc. ]. ^collector value: (streamCreator value: aCollection). "The continuation examples are examples of a 'back to LISP' style. These examples use blocks to process the elements of a collection in a fashion that is similar to streaming. The creator block creates a blocks that act like a stream. In the following, this block is called a 'value with continuation block'. When such a value with continuation block receives the message value, it returns a Array of two elements, the value and the continuation 1. the next collection element 2. a so-called continuation, which is either nil or a block that can return the next value with continuation. To collect all elements of a value with continuation stream, use the collector block. " ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! testContinuationExample3 | array | array := (1 to: 20) asOrderedCollection. self assert: ((self continuationExample3: array) = (array collect: [:x | x * x - 10])) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'StephaneDucasse 6/9/2012 22:42'! testReentrantBlock | fib | fib := [:val | (val <= 0) ifTrue: [self error: 'not a natural number']. (val <= 2) ifTrue: [1] ifFalse: [(fib value: (val - 1)) + (fib value: (val - 2))]]. self should: [fib value: 0] raise: self classForTestResult error. self assert: ((fib value: 1) = 1). self assert: ((fib value: 2) = 1). self assert: ((fib value: 3) = 2). self assert: ((fib value: 4) = 3). self assert: ((fib value: 5) = 5). self assert: ((fib value: 6) = 8). ! ! !BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/25/2002 10:03'! gpsExample2: aCollection " BlockClosuresTestCase new gpsExample2: #(#(1 2 3 4 5) #(6 7 8 9 10) #(11 12 13 14 15) #(16 17 18 19 20) #(21 22 23 24 25))" | js i j | " js is the translation of the Algol procedure from method comment. " js := [:a :idx :n | | sum | sum := 0. idx first value: 1. [idx last value <= n last value] whileTrue: [sum := sum + a last value. idx first value: idx last value + 1.]. sum ]. " This is the most complicated call that is mentioned in method comment. Note that js is called recursively. " ^ js value: (Array with: [:val | self error: 'can not assign to procedure'] with: [ js value: (Array with: [:val | (aCollection at: i) at: j put: val] with: [ (aCollection at: i) at: j]) value: (Array with:[:val | j := val] with: [ j]) value: (Array with: [:val | self error: 'can not assign to constant'] with: [ aCollection size]) ] ) value: (Array with:[:val | i := val] with: [ i]) value: (Array with: [:val | self error: 'can not assign to constant'] with: [ aCollection size]) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:59'! testGpsExample1 | result array | array := (1 to: 100) asArray. result := array inject: 0 into: [:sum :val | sum + val]. self assert: ((self gpsExample1: array) = result) ! ! !BlockClosuresTestCase methodsFor: 'jensen device examples' stamp: 'BG 1/24/2002 18:00'! gpsExample1: aCollection " BlockClosuresTestCase new gpsExample1: (1 to: 100) asArray" | gps i s | gps := [:idx :exp :sum | | cnt | cnt := 1. sum first value: 0. [idx first value: cnt. sum first value: (sum last value + exp last value). cnt := cnt + 1. cnt <= aCollection size] whileTrue: [ ]. sum last value ]. ^gps value: (Array with: [:val | i := val] with: [ i]) value: (Array with: [:val | aCollection at: i put: val] with: [ aCollection at: i]) value: (Array with: [:val | s := val] with: [ s]) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 18:28'! testExample2 self assert: ((self example2: 5) = (1 to: 5) asOrderedCollection) ! ! !BlockClosuresTestCase methodsFor: 'testing' stamp: 'BG 1/24/2002 17:45'! testContinuationExample2 | array | array := (1 to: 20) asOrderedCollection. self assert: ((self continuationExample2: array) = (array collect: [:x | x * x])) ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:14'! constructFibonacciBlockWithBlockArgumentInDeadFrame ^ [:val :blk | (val <= 0) ifTrue: [self error: 'not a natural number']. (val <= 2) ifTrue: [1] ifFalse: [(blk value: (val - 1) value: blk) + (blk value: (val - 2) value: blk)]]. ! ! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:20'! constructCannotReturnBlockInDeadFrame ^ [:arg | ^arg]. ! ! !BlockEditor commentStamp: 'TorstenBergmann 2/5/2014 09:19'! Block Editor! !BlockEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 18:20'! ok ^ ok! ! !BlockEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! block ^ block value! ! !BlockEditor methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/12/2012 18:25'! initializeWidgets self instantiateModels: #( pre LabelModel post LabelModel text TextInputFieldModel ok ButtonModel ). pre text: '['. post text: ']'. text autoAccept: false; entryCompletion: nil; acceptBlock: [ self okAction ]; ghostText: 'body'. ok label: 'ok'; state: false; enabled: true; action: [ self okAction ]. self focusOrder add: text; add: ok! ! !BlockEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! block: aBlock block value: aBlock ! ! !BlockEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 18:09'! buildWithSpec: aSpec ^ self buildWithSpecLayout: self layout! ! !BlockEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 7/11/2012 18:58'! layout | width width2 | width := StandardFonts defaultFont widthOfStringOrText: pre getText. width2 := StandardFonts defaultFont widthOfStringOrText: post getText. ^ SpecLayout composed newRow: [:r | r newColumn: [:c | c add: #pre ] width: width; add: #text; newColumn: [:c | c add: #post ] width: width2; newColumn: [:c | c add: #ok ] width: 25 ] height: 25; yourself! ! !BlockEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 18:20'! text ^ text! ! !BlockEditor methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. block := nil asReactiveVariable! ! !BlockEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 18:05'! buildWithSpec ^ self buildWithSpecLayout: self layout! ! !BlockEditor methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! okAction text accept. block value: (Smalltalk evaluate: (String streamContents: [:s | s << '[' << text getText <<']'])).! ! !BlockEditor methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/11/2012 19:11'! whenBlockChangedDo: aBlock block whenChangedDo: aBlock ! ! !BlockEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 18:08'! post ^ post! ! !BlockEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 18:08'! pre ^ pre! ! !BlockEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 18:00'! help: aString text help: aString ! ! !BlockFilter commentStamp: 'TorstenBergmann 1/31/2014 11:30'! A filter for blocks! !BlockFilter methodsFor: 'testing' stamp: 'ClaraAllende 8/14/2013 20:25'! shouldDisplay: aContext ^self block value: aContext! ! !BlockFilter methodsFor: 'accessing' stamp: 'ClaraAllende 8/14/2013 20:24'! block: aBlockClosure block:= aBlockClosure! ! !BlockFilter methodsFor: 'accessing' stamp: 'ClaraAllende 8/14/2013 20:24'! block ^block! ! !BlockFilter class methodsFor: 'instance creation' stamp: 'AndreiChis 8/27/2013 23:31'! forBlock: aBlockClosure ^ self new block: aBlockClosure! ! !BlockLocalTempCounter commentStamp: ''! I am a support class for the decompiler that is used to find the number of local temps in a block by finding out what the stack offset is at the end of a block.! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:21'! pushConstant: value "Push Constant, value, on Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'private' stamp: 'eem 9/26/2008 13:40'! doJoin scanner pc < blockEnd ifTrue: [stackPointer := joinOffsets at: scanner pc]! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! blockReturnTop "Return Top Of Stack bytecode." stackPointer := stackPointer - 1. scanner pc < blockEnd ifTrue: [self doJoin]! ! !BlockLocalTempCounter methodsFor: 'initialize-release' stamp: 'ClementBera 7/26/2013 16:04'! tempCountForBlockAt: pc in: method "Compute the number of local temporaries in a block. If the block begins with a sequence of push: nil bytecodes then some of These could be initializing local temps. We can only reliably disambuguate them from other uses of nil by parsing the stack and seeing what the offset of the stack pointer is at the end of the block. There are short-cuts. The ones we take here are - if there is no sequence of push nils there can be no local temps - we follow forward jumps to shorten the amount of scanning" stackPointer := 0. scanner := InstructionStream new method: method pc: pc. scanner interpretNextInstructionFor: self. blockEnd ifNil: [self error: 'pc is not that of a block']. scanner nextByte = Encoder pushNilCode ifTrue: [joinOffsets := Dictionary new. [scanner pc < blockEnd] whileTrue: [scanner interpretNextInstructionFor: self]]. ^stackPointer! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:19'! popIntoLiteralVariable: anAssociation "Remove Top Of Stack And Store Into Literal Variable bytecode." stackPointer := stackPointer - 1! ! !BlockLocalTempCounter methodsFor: 'initialize-release' stamp: 'ClementBera 7/26/2013 16:04'! testTempCountForBlockAt: startPc in: method "Compute the number of local temporaries in a block. If the block begins with a sequence of push: nil bytecodes then some of These could be initializing local temps. We can only reliably disambuguate them from other uses of nil by parsing the stack and seeing what the offset of the stack pointer is at the end of the block.There are short-cuts. The only one we take here is - if there is no sequence of push nils there can be no local temps" | symbolicLines line prior thePc | symbolicLines := Dictionary new. method symbolicLinesDo: [:pc :lineForPC| symbolicLines at: pc put: lineForPC]. stackPointer := 0. scanner := InstructionStream new method: method pc: startPc. scanner interpretNextInstructionFor: self. blockEnd ifNil: [self error: 'pc is not that of a block']. scanner nextByte = Encoder pushNilCode ifTrue: [joinOffsets := Dictionary new. [scanner pc < blockEnd] whileTrue: [line := symbolicLines at: scanner pc. prior := stackPointer. thePc := scanner pc. scanner interpretNextInstructionFor: self. Transcript cr; print: prior; nextPutAll: '->'; print: stackPointer; tab; print: thePc; tab; nextPutAll: line; flush]]. ^stackPointer! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:24'! send: selector super: supered numArgs: numberArguments "Send Message With Selector, selector, bytecode. The argument, supered, indicates whether the receiver of the message is specified with 'super' in the source method. The arguments of the message are found in the top numArguments locations on the stack and the receiver just below them." stackPointer := stackPointer - numberArguments! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 13:40'! jump: offset if: condition "Conditional Jump bytecode." stackPointer := stackPointer - 1. offset > 0 ifTrue: [joinOffsets at: scanner pc + offset put: stackPointer]! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:16'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize "Push Closure bytecode. Either compute the end of the block if this is the block we're analysing, or skip it, adjusting the stack as appropriate." blockEnd ifNil: [blockEnd := scanner pc + blockSize] ifNotNil: [stackPointer := stackPointer - numCopied + 1. scanner pc: scanner pc + blockSize]! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:22'! pushNewArrayOfSize: numElements "Push New Array of size numElements bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:17'! doPop "Remove Top Of Stack bytecode." stackPointer := stackPointer - 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:23'! pushTemporaryVariable: offset "Push Contents Of Temporary Variable Whose Index Is the argument, offset, On Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! methodReturnTop "Return Top Of Stack bytecode." stackPointer := stackPointer - 1. self doJoin! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:19'! popIntoReceiverVariable: offset "Remove Top Of Stack And Store Into Instance Variable bytecode." stackPointer := stackPointer - 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:19'! popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Remove Top Of Stack And Store Into Offset of Temp Vector bytecode." stackPointer := stackPointer - 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 13:40'! jump: offset "Unconditional Jump bytecode." offset > 0 ifTrue: [joinOffsets at: scanner pc + offset put: stackPointer. self doJoin]! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:21'! pushConsArrayWithElements: numElements "Push Cons Array of size numElements popping numElements items from the stack into the array bytecode." stackPointer := stackPointer - numElements + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! methodReturnConstant: value "Return Constant bytecode." self doJoin! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:20'! pushActiveContext "Push Active Context On Top Of Its Own Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:23'! pushReceiverVariable: offset "Push Contents Of the Receiver's Instance Variable Whose Index is the argument, offset, On Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:22'! pushLiteralVariable: anAssociation "Push Contents Of anAssociation On Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:23'! pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Push Contents at Offset in Temp Vector bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:13'! doDup "Duplicate Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! methodReturnReceiver "Return Self bytecode." self doJoin! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:22'! pushReceiver "Push Active Context's Receiver on Top Of Stack bytecode." stackPointer := stackPointer + 1! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/23/2008 16:20'! popIntoTemporaryVariable: offset "Remove Top Of Stack And Store Into Temporary Variable bytecode." stackPointer := stackPointer - 1! ! !BlockLocalTempCounter class methodsFor: 'instance creation' stamp: 'eem 9/23/2008 16:07'! tempCountForBlockAt: pc in: method ^self new tempCountForBlockAt: pc in: method! ! !BlockNode commentStamp: ''! I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.! !BlockNode methodsFor: 'accessing' stamp: 'eem 6/2/2008 14:00'! addArgument: aTempVariableNode temporaries := temporaries copyWith: aTempVariableNode! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 11:42'! addHoistedTemps: additionalTemporaries "" additionalTemporaries do: [:temp| temp definingScope ifNil: [temp definingScope: self]]. temporaries := (temporaries isNil or: [temporaries isEmpty]) ifTrue: [additionalTemporaries copy] ifFalse: [temporaries last isIndirectTempVector ifTrue: [temporaries allButLast, additionalTemporaries, { temporaries last }] ifFalse: [temporaries, additionalTemporaries]]! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 8/22/2008 10:01'! closureCreationNode closureCreationNode ifNil: [closureCreationNode := LeafNode new key: #closureCreationNode code: nil]. ^closureCreationNode! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 8/4/2008 10:48'! startOfLastStatement ^startOfLastStatement! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/22/2009 10:48'! remoteTempNodeName "Answer a useful name for a RemoteTempVectorNode in the receiver." | prefix scope extent | prefix := actualScopeIfOptimized ifNil: ['<'] ifNotNil: [ '<...']. scope := self. [extent := scope blockExtent. extent == nil and: [scope actualScope ~~ scope]] whileTrue: [scope := scope actualScope]. ^extent ifNil: [prefix, '?-?>'] ifNotNil: [prefix, extent first printString, '-', (extent last isZero ifTrue: ['?'] ifFalse: [extent last printString]), '>']! ! !BlockNode methodsFor: 'code generation' stamp: 'jannik.laval 5/1/2010 15:59'! emitCodeForEvaluatedEffect: stack encoder: encoder | position | position := stack position. self returns ifTrue: [self emitCodeForEvaluatedValue: stack encoder: encoder. stack pop: 1] ifFalse: [self emitCodeExceptLast: stack encoder: encoder. statements last emitCodeForEffect: stack encoder: encoder]. [stack position = position] assert! ! !BlockNode methodsFor: 'equation translation' stamp: ''! statements: val statements := val! ! !BlockNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:33'! accept: aVisitor ^aVisitor visitBlockNode: self! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'nice 3/1/2010 23:01'! makeTemporariesRemovable "Utilities for when we want to remove some temporaries." temporaries isArray ifTrue: [temporaries := temporaries asOrderedCollection].! ! !BlockNode methodsFor: 'accessing' stamp: ''! returnLast self returns ifFalse: [returns := true. statements at: statements size put: statements last asReturnNode]! ! !BlockNode methodsFor: 'accessing' stamp: 'sma 2/27/2000 22:37'! temporaries: aCollection temporaries := aCollection! ! !BlockNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52'! sizeCodeForEvaluatedValue: encoder ^(self sizeCodeExceptLast: encoder) + (statements last sizeCodeForBlockValue: encoder)! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'nice 3/1/2010 23:13'! removeTempNode: aTempVariableNode ifAbsent: aBlock "Utilities for when we want to remove some temporaries." self makeTemporariesRemovable. ^temporaries remove: aTempVariableNode ifAbsent: aBlock ! ! !BlockNode methodsFor: 'printing' stamp: 'eem 7/21/2009 13:12'! printTemporaries: tempSequence on: aStream doPrior: aBlock "Print any in-scope temporaries. If there are any evaluate aBlock prior to printing. Answer whether any temporaries were printed." | tempStream seen | tempSequence ifNil: [^false]. tempStream := (String new: 16) writeStream. "This is for the decompiler which canmot work out which optimized block a particular temp is local to and hence may produce diplicates as in expr ifTrue: [| aTemp | ...] ifFalse: [| aTemp | ...]" seen := Set new. tempSequence do: [:tempNode | tempNode isIndirectTempVector ifTrue: [tempNode remoteTemps do: [:tempVariableNode| (tempVariableNode scope >= 0 and: [(seen includes: tempNode key) not]) ifTrue: [tempStream space; nextPutAll: (seen add: tempVariableNode key)]]] ifFalse: [(tempNode scope >= -1 and: ["This is for the decompiler which may create a block arg when converting a while into a to:do: but won't remove it form temporaries" tempNode isBlockArg not and: [(seen includes: tempNode key) not]]) ifTrue: [tempStream space; nextPutAll: (seen add: tempNode key)]]]. tempStream position = 0 ifTrue: [^false]. aBlock value. aStream nextPut: $|; nextPutAll: tempStream contents; space; nextPut: $|. ^true! ! !BlockNode methodsFor: 'printing' stamp: 'alain.plantec 5/18/2009 15:34'! decompileString "Answer a string description of the parse tree whose root is the receiver." ^ self printString ! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 7/24/2008 12:37'! optimized ^optimized! ! !BlockNode methodsFor: 'accessing' stamp: ''! firstArgument ^ arguments first! ! !BlockNode methodsFor: 'accessing' stamp: 'tk 8/4/1999 22:53'! block ^ self! ! !BlockNode methodsFor: 'accessing' stamp: 'gk 4/6/2006 11:29'! returnSelfIfNoOther: encoder self returns ifTrue:[^self]. statements last == NodeSelf ifFalse: [ statements := statements copyWith: (encoder encodeVariable: 'self'). ]. self returnLast. ! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2009 18:56'! ifHasRemoteTempNodeEnsureInitializationStatementExists: rootNode "If a remoteTempNode has been added ensure a statement exists to initialize it." remoteTempNode ~~ nil ifTrue: [(statements notEmpty and: [statements first isAssignmentNode and: [statements first variable isTemp and: [statements first variable isIndirectTempVector]]]) ifTrue: "If this is a decompiled tree, or if a temporary has been added later in the analysis then there already is a temp vector initialization node." [(statements first variable ~~ remoteTempNode) ifTrue: [statements first variable become: remoteTempNode]. statements first value numElements: remoteTempNode remoteTemps size] ifFalse: [statements addFirst: (remoteTempNode nodeToInitialize: rootNode encoder)]].! ! !BlockNode methodsFor: 'testing' stamp: ''! isQuick ^ statements size = 1 and: [statements first isVariableReference or: [statements first isSpecialConstant]]! ! !BlockNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:28'! printArgumentsOn: aStream indent: level arguments size = 0 ifTrue: [^ self]. arguments do: [:arg | aStream nextPut: $:; nextPutAll: arg key; space]. aStream nextPut: $|; space. "If >0 args and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level]! ! !BlockNode methodsFor: 'initialize-release' stamp: 'eem 5/20/2008 13:40'! statements: statementsCollection returns: returnBool "Decompile." | returnLast | returnLast := returnBool. returns := false. statements := (statementsCollection size > 1 and: [(statementsCollection at: statementsCollection size - 1) isReturningIf]) ifTrue: [returnLast := false. statementsCollection allButLast] ifFalse: [statementsCollection size = 0 ifTrue: [Array with: NodeNil] ifFalse: [statementsCollection]]. arguments := #(). temporaries := #(). optimized := false. returnLast ifTrue: [self returnLast]! ! !BlockNode methodsFor: 'testing' stamp: ''! isJustCaseError ^ statements size = 1 and: [statements first isMessage: #caseError receiver: [:r | r==NodeSelf] arguments: nil]! ! !BlockNode methodsFor: 'code generation' stamp: 'jannik.laval 5/1/2010 15:59'! emitCodeExceptLast: stack encoder: encoder | position nextToLast | position := stack position. nextToLast := statements size - 1. 1 to: nextToLast do: [:i | | statement | statement := statements at: i. statement emitCodeForEffect: stack encoder: encoder. [stack position = position] assert].! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 5/30/2008 12:12'! nArgsSlot "Private for the Encoder to use in bindArg" ^nArgsNode! ! !BlockNode methodsFor: 'testing' stamp: ''! returns ^returns or: [statements last isReturningIf]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2009 16:23'! postNumberingProcessTempsWithin: scopeBlock "" rootNode: rootNode "" "A temp can be local (and copied) if it is not written to after it is captured. A temp cannot be local if it is written to remotely. Need to enumerate a copy of the temporaries because any temps becoming remote will be removed from temporaries in analyseClosure: (and a single remote temp node will get added)" temporaries copy do: [:each| each isIndirectTempVector ifFalse: [each analyseClosure: rootNode]]. "If this is an optimized node we need to hoist temporaries up into the relevant block scope." optimized ifTrue: [self optimizedBlockHoistTempsInto: scopeBlock]. "Now we may have added a remoteTempNode. So we need a statement to initialize it." self ifHasRemoteTempNodeEnsureInitializationStatementExists: rootNode. "Now add all arguments and locals to the pool so that copiedValues can be computed during sizing." rootNode addLocalsToPool: arguments; addLocalsToPool: temporaries! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'MarcusDenker 2/25/2012 19:42'! emitCodeForValue: stack encoder: encoder "if not supportsClosureOpcodes closureCreationSupportNode is the node for thisContext closureCopy: numArgs [ copiedValues: { values } ]" encoder supportsClosureOpcodes ifTrue: [copiedValues do: [:copiedValue| copiedValue emitCodeForValue: stack encoder: encoder]. closureCreationNode pc: encoder methodStreamPosition + 1. encoder genPushClosureCopyNumCopiedValues: copiedValues size numArgs: arguments size jumpSize: size. stack pop: copiedValues size; push: 1] ifFalse: [closureCreationNode emitCodeForValue: stack encoder: encoder. encoder genJumpLong: size]. "Force a two byte jump." "Emit the body of the block" self emitCodeForEvaluatedClosureValue: stack encoder: encoder! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'jannik.laval 5/1/2010 16:58'! reindexingLocalsDo: aBlock encoder: encoderOrNil "Evaluate aBlock wih arguments, temporaries and copiedValues reindexed for their positions within the receiver's block, restoring the correct indices afterwards. If encoder is not nil remember the temps for this block's extent." | tempIndices result tempsToReindex | [copiedValues notNil] assert. tempsToReindex := arguments asArray, copiedValues, temporaries. tempIndices := tempsToReindex collect: [:temp| temp index]. tempsToReindex withIndexDo: [:temp :newIndex| temp index: newIndex - 1. [temp index + 1 = newIndex] assert]. encoderOrNil ifNotNil: [encoderOrNil noteBlockExtent: blockExtent hasLocals: tempsToReindex]. result := aBlock ensure: ["Horribly pragmatic hack. The copiedValues will have completely unrelated indices within the closure method and sub-method. Avoiding the effort of rebinding temps in the inner scope simply update the indices to their correct ones during the generation of the closure method and restore the indices immedately there-after." tempsToReindex with: tempIndices do: [:temp :oldIndex| temp index: oldIndex. [temp index = oldIndex] assert]]. ^result! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 9/3/2009 12:55'! actualScope "Answer the actual scope for the receiver. If this is an unoptimized block then it is its actual scope, but if this is an optimized block then the actual scope is some outer block." ^actualScopeIfOptimized ifNil: [self]! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 8/31/2010 12:30'! temporaries ^temporaries ifNil: [#()]! ! !BlockNode methodsFor: 'initialize-release' stamp: 'eem 8/4/2008 14:12'! noteSourceRangeStart: start end: end encoder: encoder "Note two source ranges for this node. One is for the debugger and is of the last expression, the result of the block. One is for source analysis and is for the entire block." encoder noteSourceRange: (start to: end) forNode: self closureCreationNode. startOfLastStatement ifNil: [encoder noteSourceRange: (start to: end) forNode: self] ifNotNil: [encoder noteSourceRange: (startOfLastStatement to: end - 1) forNode: self]! ! !BlockNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:13'! sizeCodeForEvaluatedEffect: encoder ^self returns ifTrue: [self sizeCodeForEvaluatedValue: encoder] ifFalse: [(self sizeCodeExceptLast: encoder) + (statements last sizeCodeForEffect: encoder)]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'jannik.laval 5/1/2010 15:59'! optimizedBlockHoistTempsInto: scopeBlock "" "This is a No-op for all nodes except non-optimized BlockNodes." "Let's assume the special > 0 guard in MessageNode>>analyseTempsWithin:forValue:encoder: is correct. Then we can simply hoist our temps up." [arguments isNil or: [arguments size <= 1]] assert. (arguments notNil and: [arguments notEmpty]) ifTrue: [scopeBlock addHoistedTemps: arguments. arguments := #()]. temporaries notEmpty ifTrue: [scopeBlock addHoistedTemps: temporaries. temporaries := #()]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 9/12/2008 10:55'! emitCodeForEvaluatedClosureValue: stack encoder: encoder | position | position := stack position. stack position: arguments size + copiedValues size. temporaries size timesRepeat: [NodeNil emitCodeForValue: stack encoder: encoder]. self reindexingLocalsDo: [self emitCodeForEvaluatedValue: stack encoder: encoder] encoder: encoder. self returns ifFalse: [encoder genReturnTopToCaller. pc := encoder methodStreamPosition]. stack position: position! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 9/6/2009 19:23'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" | effectiveScope blockStart | effectiveScope := optimized ifTrue: [actualScopeIfOptimized := scopeBlock] ifFalse: [self]. arguments ifNotNil: [arguments do: [:temp| temp definingScope: self]]. temporaries ifNotNil: [temporaries do: [:temp| temp definingScope: self]]. optimized ifFalse: "if optimized this isn't an actual scope" [rootNode noteBlockEntry: [:entryNumber| blockExtent := (blockStart := entryNumber) to: 0]]. "Need to enumerate a copy because closure analysis can add a statement via ifHasRemoteTempNodeEnsureInitializationStatementExists:." statements copy do: [:statement| statement analyseTempsWithin: effectiveScope rootNode: rootNode assignmentPools: assignmentPools]. optimized ifTrue: "if optimized loop need to add nils for any temps read before written" [optimizedMessageNode isOptimizedLoop ifTrue: [self nilReadBeforeWrittenTemps]] ifFalse: "if optimized this isn't an actual scope" [rootNode noteBlockExit: [:exitNumber| blockExtent := blockStart to: exitNumber]]. "Now that the analysis is done move any temps that need to be moved." self postNumberingProcessTempsWithin: effectiveScope rootNode: rootNode. "This is simply a nicety for compiler developers..." temporaries do: [:temp| (temp isIndirectTempVector and: [temp name includes: $?]) ifTrue: [temp name: temp definingScope remoteTempNodeName]]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 2/3/2011 09:19'! deoptimize optimized := false. optimizedMessageNode := nil! ! !BlockNode methodsFor: 'printing' stamp: 'eem 9/23/2008 15:05'! printStatementsOn: aStream indent: levelOrZero | len shown thisStatement level | level := 1 max: levelOrZero. comment == nil ifFalse: [self printCommentOn: aStream indent: level. aStream crtab: level]. len := shown := statements size. (levelOrZero = 0 "top level" and: [statements last isReturnSelf]) ifTrue: [shown := 1 max: shown - 1] ifFalse: ["should a trailing nil be printed or not? Not if it is an implicit result." (arguments size = 0 and: [len >= 1 and: [(statements at: len) == NodeNil and: [len = 1 or: [len > 1 and: [(statements at: len - 1) isMessageNode and: [(statements at: len - 1) isNilIf]]]]]]) ifTrue: [shown := shown - 1]]. 1 to: shown do: [:i | thisStatement := statements at: i. thisStatement printOn: aStream indent: level. i < shown ifTrue: [aStream nextPut: $.; crtab: level]. (thisStatement comment ~~ nil and: [thisStatement comment size > 0]) ifTrue: [i = shown ifTrue: [aStream crtab: level]. thisStatement printCommentOn: aStream indent: level. i < shown ifTrue: [aStream crtab: level]]]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'MarcusDenker 2/25/2012 19:41'! sizeCodeForValue: encoder "Compute the size for the creation of the block and its code." "If we have the closure bytecodes constructClosureCreationNode: will note the copied values in the copiedValues inst var and answer #pushCopiedValues." closureCreationNode := self constructClosureCreationNode: encoder. "Remember size of body for emit time so we know the size of the jump around it." size := self sizeCodeForEvaluatedClosureValue: encoder. ^encoder supportsClosureOpcodes ifTrue: [(copiedValues inject: 0 into: [:sum :node| sum + (node sizeCodeForValue: encoder)]) + (encoder sizePushClosureCopyNumCopiedValues: copiedValues size numArgs: arguments size jumpSize: size) + size] ifFalse: ["closureCreationSupportNode is send closureCopy:copiedValues:" (closureCreationNode sizeCodeForValue: encoder) + (encoder sizeJumpLong: size) + size]! ! !BlockNode methodsFor: 'accessing' stamp: 'ar 11/17/2002 19:57'! returnNilIfNoOther self returns ifFalse: [statements last == NodeNil ifFalse: [statements add: NodeNil]. self returnLast]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 9/6/2009 13:30'! noteOptimizedIn: anOptimizedMessageNode optimized := true. optimizedMessageNode := anOptimizedMessageNode! ! !BlockNode methodsFor: 'equation translation' stamp: ''! statements ^statements! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'nice 3/1/2010 23:14'! addTempNode: aTempVariableNode "Utilities for when we want to add some temporaries." self makeTemporariesRemovable. ^temporaries add: aTempVariableNode! ! !BlockNode methodsFor: 'accessing' stamp: ''! numberOfArguments ^arguments size! ! !BlockNode methodsFor: 'initialize-release' stamp: 'eem 5/20/2008 13:40'! arguments: argNodes statements: statementsCollection returns: returnBool from: encoder "Compile." arguments := argNodes. statements := statementsCollection size > 0 ifTrue: [statementsCollection] ifFalse: [argNodes size > 0 ifTrue: [statementsCollection copyWith: arguments last] ifFalse: [Array with: NodeNil]]. optimized := false. returns := returnBool! ! !BlockNode methodsFor: 'testing' stamp: ''! isComplex ^statements size > 1 or: [statements size = 1 and: [statements first isComplex]]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 5/31/2008 14:31'! sizeCodeForEvaluatedClosureValue: encoder "The closure value primitives push the arguments and the copied values. The compiler guarantees that any copied values come before all local temps. So on closure activation we only need to push nils for the remaining temporaries." ^temporaries size * (NodeNil sizeCodeForValue: encoder) + (self reindexingLocalsDo: [self sizeCodeForEvaluatedValue: encoder] encoder: nil "don't store temps yet") + (self returns ifTrue: [0] ifFalse: [encoder sizeReturnTopToCaller])! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 5/19/2008 17:12'! noteOptimized optimized := true! ! !BlockNode methodsFor: 'printing' stamp: 'eem 9/25/2008 12:48'! printOn: aStream indent: level "statements size <= 1 ifFalse: [aStream crtab: level]." aStream nextPut: $[. self printArgumentsOn: aStream indent: level. (self printTemporaries: temporaries on: aStream doPrior: []) ifTrue: ["If >0 temps and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level] ifFalse: [aStream space]]. self printStatementsOn: aStream indent: level. aStream nextPut: $]! ! !BlockNode methodsFor: 'code generation' stamp: ''! code ^statements first code! ! !BlockNode methodsFor: 'code generation' stamp: 'eem 5/29/2008 15:21'! sizeCodeExceptLast: encoder | codeSize | codeSize := 0. 1 to: statements size - 1 do: [:i | | statement | statement := statements at: i. codeSize := codeSize + (statement sizeCodeForEffect: encoder)]. ^codeSize! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 5/20/2008 12:16'! blockExtent "^" ^blockExtent! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 8/4/2008 10:50'! startOfLastStatement: anInteger "Note the source index of the start of the last full statement. The last full statement is the value answered by a block and hence the expression the debugger should display as the value of the block." startOfLastStatement := anInteger! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 5/30/2008 12:12'! nArgsSlot: anInteger "Private for the Encoder to use in bindArg" nArgsNode := anInteger! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 9/6/2009 13:36'! nilReadBeforeWrittenTemps | visitor readBeforeWritten | self accept: (visitor := OptimizedBlockLocalTempReadBeforeWrittenVisitor new). readBeforeWritten := visitor readBeforeWritten. temporaries reverseDo: [:temp| ((readBeforeWritten includes: temp) and: [temp isRemote not]) ifTrue: [statements addFirst: (AssignmentNode new variable: temp value: NodeNil)]]! ! !BlockNode methodsFor: 'accessing' stamp: ''! arguments: argNodes "Decompile." arguments := argNodes! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'nice 8/19/2010 16:31'! computeCopiedValues: rootNode | referencedValues | referencedValues := rootNode referencedValuesWithinBlockExtent: blockExtent. ^(referencedValues reject: [:temp| temp isDefinedWithinBlockExtent: blockExtent]) asArray sort: ParseNode tempSortBlock! ! !BlockNode methodsFor: 'testing' stamp: ''! isJust: node returns ifTrue: [^false]. ^statements size = 1 and: [statements first == node]! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'nice 3/2/2010 00:58'! addRemoteTemp: aTempVariableNode rootNode: rootNode "" "Add aTempVariableNode to my actualScope's sequence of remote temps. If I am an optimized block then the actual scope is my actualScopeIfOptimized, otherwise it is myself." remoteTempNode == nil ifTrue: [remoteTempNode := RemoteTempVectorNode new name: self remoteTempNodeName index: arguments size + temporaries size type: LdTempType scope: 0. actualScopeIfOptimized ifNil: [self addTempNode: remoteTempNode. remoteTempNode definingScope: self] ifNotNil: [actualScopeIfOptimized addHoistedTemps: { remoteTempNode }]]. remoteTempNode addRemoteTemp: aTempVariableNode encoder: rootNode encoder. "use remove:ifAbsent: because the deferred analysis for optimized loops can result in the temp has already been hoised into the root." self removeTempNode: aTempVariableNode ifAbsent: [ self actualScope removeTempNode: aTempVariableNode ifAbsent: ["should not happen"]]. ^remoteTempNode! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2008 14:10'! constructClosureCreationNode: encoder copiedValues := self computeCopiedValues: encoder rootNode. encoder supportsClosureOpcodes ifTrue: [^self closureCreationNode]. "Without the bytecode we can still get by." ^MessageNode new receiver: (encoder encodeVariable: 'thisContext') selector: #closureCopy:copiedValues: arguments: (Array with: (encoder encodeLiteral: arguments size) with: (copiedValues isEmpty ifTrue: [NodeNil] ifFalse: [BraceNode new elements: copiedValues])) precedence: 3 from: encoder! ! !BlockNode methodsFor: 'testing' stamp: 'eem 9/25/2008 12:10'! isBlockNode ^true! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 8/31/2010 12:31'! arguments ^arguments ifNil: [#()]! ! !BlockNode methodsFor: 'code generation' stamp: 'jannik.laval 5/1/2010 15:59'! emitCodeForEvaluatedValue: stack encoder: encoder | position | position := stack position. self emitCodeExceptLast: stack encoder: encoder. statements last emitCodeForBlockValue: stack encoder: encoder. [stack position - 1 = position] assert! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'jannik.laval 5/1/2010 16:58'! analyseArguments: methodArguments temporaries: methodTemporaries rootNode: rootNode "" "^>" "Top level entry-point for analysing temps within the hierarchy of blocks in the receiver's method. Answer the (possibly modified) sequence of temp vars. Need to hoist temps out of macro-optimized blocks into their actual blocks. Need to note reads and writes to temps from blocks other than their actual blocks to determine whether blocks can be local (simple slots within a block/method context) or remote (slots in indirection vectors that are shared between contexts by sharing indirection vectors). The algorithm is based on numbering temporary reads and writes and block extents. The index used for numbering starts at zero and is incremented on every block entry and block exit. So the following | a b blk r1 r2 t | a := 1. b := 2. t := 0. blk := [ | s | s := a + b. t := t + s]. r1 := blk value. b := -100. r2 := blk value. r1 -> r2 -> t is numbered as method block 0 to: 6: | a b blk r1 r2 t | a w@1 := 1. b w@1 := 2. t w@1 := 0. blk w@5 := [entry@2 | s | t w@3 := t r@3 + a r@3 + b r@3 ] exit@4. r1 w@5 := blk r@5 value. b w@5 := nil. r2 w@5 := blk r@5 value. r1 r@5 -> r2 r@5 -> t r@5 So: b and blk cannot be copied because for both there exists a write @5 that follows a read @4 within block 2 through 4 t must be remote because there exists a write @3 within block (2 to: 4) Complications are introduced by optimized blocks. In the following temp is written to after it is closed over by [ temp ] since the inlined block is executed more than once. | temp coll | coll := OrderedCollection new. 1 to: 5 do: [ :index | temp := index. coll add: [ temp ] ]. [(coll collect: [:ea| ea value]) asArray = #(5 5 5 5 5)] assert. In the following i is local to the block and must be initialized each time around the loop but if the block is inlined it must be declared at method level. | col | col := OrderedCollection new. 1 to: 3 do: [ :each | | i | i := each. col add: [ i ]. i := i + 1 ]. [(col collect: [ :each | each value ]) asArray = #(2 3 4)] assert" [arguments isEmpty or: [arguments hasEqualElements: methodArguments]] assert. arguments := methodArguments asArray. "won't change" [temporaries isNil or: [temporaries isEmpty or: [temporaries hasEqualElements: methodTemporaries]]] assert. temporaries := OrderedCollection withAll: methodTemporaries. [optimized not] assert. "the top-level block should not be optimized." self analyseTempsWithin: self rootNode: rootNode assignmentPools: Dictionary new. "The top-level block needs to reindex temporaries since analysis may have rearranged them. This happens when temps are made remote and/or a remote node is added." temporaries withIndexDo: [:temp :offsetPlusOne| temp index: arguments size + offsetPlusOne - 1]. "Answer the (possibly modified) sequence of temps." ^temporaries asArray! ! !BlockNode class methodsFor: 'instance creation' stamp: 'sma 3/3/2000 13:34'! statements: statements returns: returns ^ self new statements: statements returns: returns! ! !BlockNode class methodsFor: 'instance creation' stamp: 'eem 5/19/2008 17:10'! withJust: aNode ^ self new statements: (Array with: aNode) returns: false! ! !BlockStartLocator commentStamp: 'TorstenBergmann 1/31/2014 11:21'! Locates the start of a block! !BlockStartLocator methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:43'! initialize super initialize. nextJumpIsAroundBlock := false! ! !BlockStartLocator methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 14:16'! send: selector super: supered numArgs: numberArguments nextJumpIsAroundBlock := #closureCopy:copiedValues: == selector "Don't use nextJumpIsAroundBlock := #(blockCopy: closureCopy:copiedValues:) includes: selector since BlueBook BlockContexts do not have their own temps."! ! !BlockStartLocator methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:54'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize "Answer the size of the block" ^blockSize! ! !BlockStartLocator methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:48'! jump: offset "If this jump is around a block answer the size of that block." nextJumpIsAroundBlock ifTrue: [nextJumpIsAroundBlock := false. ^offset]! ! !Boolean commentStamp: ''! Boolean is an abstract class defining the protocol for logic testing operations and conditional control structures for the logical values represented by the instances of its subclasses True and False. Boolean redefines #new so no instances of Boolean can be created. It also redefines several messages in the 'copying' protocol to ensure that only one instance of each of its subclasses True (the global true, logical assertion) and False (the global false, logical negation) ever exist in the system.! !Boolean methodsFor: 'controlling' stamp: ''! and: alternativeBlock "Nonevaluating conjunction. If the receiver is true, answer the value of the argument, alternativeBlock; otherwise answer false without evaluating the argument." self subclassResponsibility! ! !Boolean methodsFor: 'logical operations' stamp: ''! | aBoolean "Evaluating disjunction (OR). Evaluate the argument. Then answer true if either the receiver or the argument is true." self subclassResponsibility! ! !Boolean methodsFor: 'converting' stamp: 'CamilloBruni 3/27/2012 17:20'! asBit "convert myself to an Integer representing 1 for true and 0 for false" self subclassResponsibility! ! !Boolean methodsFor: 'controlling' stamp: ''! ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock "If the receiver is true (i.e., the condition is true), then answer the value of the argument trueAlternativeBlock. If the receiver is false, answer the result of evaluating the argument falseAlternativeBlock. If the receiver is a nonBoolean then create an error notification. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! ! !Boolean methodsFor: 'printing' stamp: ''! storeOn: aStream "Refer to the comment in Object|storeOn:." self printOn: aStream! ! !Boolean methodsFor: 'copying' stamp: ''! deepCopy "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self."! ! !Boolean methodsFor: 'printing' stamp: 'apb 4/21/2006 09:22'! isLiteral ^ true! ! !Boolean methodsFor: 'logical operations' stamp: ''! not "Negation. Answer true if the receiver is false, answer false if the receiver is true." self subclassResponsibility! ! !Boolean methodsFor: '*Fuel' stamp: 'MartinDias 2/21/2013 12:49'! fuelAccept: aGeneralMapper ^aGeneralMapper visitHookPrimitive: self! ! !Boolean methodsFor: '*NativeBoost-Core' stamp: 'cb 4/22/2013 14:15'! asNBExternalType: gen "boolean value in argument description array defines a simple 0 or 1 constant #( true false ) - turned into a 1 and 0 " ^ NBFFIConst value: self asBit! ! !Boolean methodsFor: 'controlling' stamp: ''! ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock "Same as ifTrue:ifFalse:." self subclassResponsibility! ! !Boolean methodsFor: 'copying' stamp: ''! shallowCopy "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self."! ! !Boolean methodsFor: 'logical operations' stamp: 'stephane.ducasse 5/20/2009 21:28'! ==> aBlock "The material conditional, also known as the material implication or truth functional conditional. Correspond to not ... or ... and does not correspond to the English if...then... construction. known as: b if a a implies b if a then b b is a consequence of a a therefore b (but note: 'it is raining therefore it is cloudy' is implication; 'it is autumn therefore the leaves are falling' is equivalence). Here is the truth table for material implication: p | q | p ==> q -------|-------|------------- T | T | T T | F | F F | T | T F | F | T " ^self not or: [aBlock value]! ! !Boolean methodsFor: '*Fuel' stamp: 'MartinDias 2/21/2013 12:49'! serializeOn: anEncoder "Do nothing"! ! !Boolean methodsFor: 'controlling' stamp: ''! ifTrue: alternativeBlock "If the receiver is false (i.e., the condition is false), then the value is the false alternative, which is nil. Otherwise answer the result of evaluating the argument, alternativeBlock. Create an error notification if the receiver is nonBoolean. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! ! !Boolean methodsFor: 'controlling' stamp: ''! or: alternativeBlock "Nonevaluating disjunction. If the receiver is false, answer the value of the argument, alternativeBlock; otherwise answer true without evaluating the argument." self subclassResponsibility! ! !Boolean methodsFor: 'controlling' stamp: ''! ifFalse: alternativeBlock "If the receiver is true (i.e., the condition is true), then the value is the true alternative, which is nil. Otherwise answer the result of evaluating the argument, alternativeBlock. Create an error notification if the receiver is nonBoolean. Execution does not actually reach here because the expression is compiled in-line." self subclassResponsibility! ! !Boolean methodsFor: 'logical operations' stamp: ''! & aBoolean "Evaluating conjunction. Evaluate the argument. Then answer true if both the receiver and the argument are true." self subclassResponsibility! ! !Boolean methodsFor: 'copying' stamp: 'tk 8/20/1998 16:07'! veryDeepCopyWith: deepCopier "Return self. I can't be copied. Do not record me."! ! !Boolean methodsFor: '*monticellofiletree-core' stamp: 'dkh 4/6/2012 15:56:14'! writeCypressJsonOn: aStream forHtml: forHtml indent: startIndent "by default ignore ... is used for Dictionary and Array, i.e., container objects and String which actually encodes itself differently for HTML" aStream nextPutAll: self printString! ! !Boolean methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:45'! isSelfEvaluating ^ true! ! !Boolean methodsFor: 'logical operations' stamp: ''! eqv: aBoolean "Answer true if the receiver is equivalent to aBoolean." ^self == aBoolean! ! !Boolean class methodsFor: '*System-Settings-Browser' stamp: 'alain.plantec 3/18/2009 14:48'! settingInputWidgetForNode: aSettingNode ^ aSettingNode inputWidgetForBoolean! ! !Boolean class methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 8/13/2013 16:47'! asNBExternalType: gen ^ NBBool asNBExternalType: gen! ! !Boolean class methodsFor: 'instance creation' stamp: ''! new self error: 'You may not create any more Booleans - this is two-valued logic'! ! !BooleanApiSetter commentStamp: 'TorstenBergmann 2/5/2014 09:18'! Widget setter API for boolean! !BooleanApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/13/2012 02:12'! initializeWidgets self instantiateModels: #( selector LabelModel choice CheckBoxModel ). self selector text: ''. self choice label: 'true/false'; labelClickable: true; whenChangedDo: [:b | self setValueTo: b ]; state: false.! ! !BooleanApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 22:25'! internUpdateWith: value choice state: value! ! !BooleanFilter commentStamp: 'TorstenBergmann 1/31/2014 11:30'! A filter for booleans! !BooleanFilter methodsFor: 'accessing' stamp: 'AndreiChis 9/30/2013 10:53'! filters ^filters! ! !BooleanFilter methodsFor: 'accessing' stamp: 'AndreiChis 9/30/2013 10:53'! booleanOperator ^booleanOperator! ! !BooleanFilter methodsFor: 'accessing' stamp: 'AndreiChis 9/30/2013 10:53'! booleanOperator: aSymbol booleanOperator:= aSymbol! ! !BooleanFilter methodsFor: 'testing' stamp: 'ClaraAllende 8/14/2013 20:49'! shouldDisplay: aContext ^ (self filters first shouldDisplay: aContext) perform: booleanOperator with: [self filters last shouldDisplay: aContext] ! ! !BooleanFilter methodsFor: 'accessing' stamp: 'ClaraAllende 8/14/2013 20:34'! filters: theFilters filters:= theFilters! ! !BooleanFilter class methodsFor: 'instance creation' stamp: 'AndreiChis 9/30/2013 10:55'! withFilters: someFilters operator: booleanOperator ^self new filters: someFilters; booleanOperator: booleanOperator! ! !BooleanTest commentStamp: ''! This is the unit test for the class Boolean. 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 - there is a chapter in the PharoByExample book (http://pharobyexample.org/) - the sunit class category ! !BooleanTest methodsFor: 'tests' stamp: 'StephaneDucasse 6/9/2012 22:43'! testNew self should: [Boolean new] raise: self classForTestResult error. ! ! !BooleanTest methodsFor: 'tests' stamp: 'StephaneDucasse 6/9/2012 22:43'! testBooleanNew self should: [Boolean new] raise: self classForTestResult error. self should: [True new] raise: self classForTestResult error. self should: [False new] raise: self classForTestResult error. ! ! !BorderStyle commentStamp: 'kfr 10/27/2003 10:19'! See BorderedMorph BorderedMorh new borderStyle: (BorderStyle inset width: 2); openInWorld.! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 17:01'! drawLineFrom: startPoint to: stopPoint on: aCanvas ^aCanvas line: startPoint to: stopPoint width: self width color: self color! ! !BorderStyle methodsFor: 'initialize' stamp: 'ar 8/25/2001 16:06'! releaseCachedState "Release any associated cached state"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! color: aColor "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! baseColor ^Color transparent! ! !BorderStyle methodsFor: 'printing' stamp: 'gvc 2/25/2009 15:35'! printOn: aStream "Print a description of the receiver on the given stream." self storeOn: aStream! ! !BorderStyle methodsFor: 'color tracking' stamp: 'ar 8/25/2001 17:29'! trackColorFrom: aMorph "If necessary, update our color to reflect a change in aMorphs color"! ! !BorderStyle methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'! isComplex ^false! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! baseColor: aColor "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:08'! widthForRounding ^self width! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! width: aNumber "Ignored"! ! !BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 16:08'! hash "hash is implemented because #= is implemented" ^self species hash bitXor: (self width hash bitXor: self color hash)! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! width ^0! ! !BorderStyle methodsFor: 'testing' stamp: 'gvc 6/25/2008 12:09'! hasFillStyle "Answer false." ^false! ! !BorderStyle methodsFor: 'printing' stamp: 'MarcusDenker 10/21/2013 14:23'! storeOn: aStream "Store a reconstructable representation of the receiver on the given stream." aStream nextPutAll: '('; nextPutAll: self class name; nextPutAll: ' width: '; print: self width; nextPutAll: ' color: '; print: self color; nextPutAll: ')'! ! !BorderStyle methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:59'! framePolyline: vertices on: aCanvas "Frame the given rectangle on aCanvas" | prev next | prev := vertices first. 2 to: vertices size do: [:i | next := vertices at: i. self drawLineFrom: prev to: next on: aCanvas. prev := next]! ! !BorderStyle methodsFor: 'testing' stamp: 'gvc 3/14/2007 10:31'! isComposite "Answer false." ^false! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'! frameRectangle: aRectangle on: aCanvas "Frame the given rectangle on aCanvas" aCanvas frameRectangle: aRectangle width: self width color: self color! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:57'! framePolygon: vertices on: aCanvas "Frame the given rectangle on aCanvas" self framePolyline: vertices on: aCanvas. self drawLineFrom: vertices last to: vertices first on: aCanvas.! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:22'! colorsAtCorners ^Array new: 4 withAll: self color! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'! style ^#none! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'! frameOval: aRectangle on: aCanvas "Frame the given rectangle on aCanvas" aCanvas frameOval: aRectangle width: self width color: self color! ! !BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 18:38'! = aBorderStyle ^self species = aBorderStyle species and:[self style == aBorderStyle style and:[self width = aBorderStyle width and:[self color = aBorderStyle color]]].! ! !BorderStyle methodsFor: 'testing' stamp: 'ar 8/25/2001 16:08'! isBorderStyle ^true! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! color ^Color transparent! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! dotOfSize: diameter forDirection: aDirection | form | form := Form extent: diameter@diameter depth: Display depth. form getCanvas fillOval: form boundingBox color: self color. ^form! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'rr 6/21/2005 13:50'! thinGray ^ self width: 1 color: Color gray! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexRaised ^ComplexBorder style: #complexRaised! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'! width: aNumber ^self width: aNumber color: Color black! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/26/2001 16:05'! borderStyleChoices "Answer the superset of all supported borderStyle symbols" ^ #(simple inset raised complexAltFramed complexAltInset complexAltRaised complexFramed complexInset complexRaised)! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexAltRaised ^ComplexBorder style: #complexAltRaised! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'! complexAltInset ^ComplexBorder style: #complexAltInset! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/27/2001 15:22'! simple "Answer a simple border style" ^ SimpleBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexFramed ^ComplexBorder style: #complexFramed! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'! raised ^RaisedBorder new! ! !BorderStyle class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/8/2007 17:20'! dashed "Answer a dashed border style" ^DashedBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 23:52'! color: aColor width: aNumber ^self width: aNumber color: aColor! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'! complexAltFramed ^ComplexBorder style: #complexAltFramed! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 17:26'! default ^Default ifNil:[Default := self new]! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'! width: aNumber color: aColor ^SimpleBorder new color: aColor; width: aNumber; yourself! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'! inset ^InsetBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexInset ^ComplexBorder style: #complexInset! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'MarcusDenker 7/18/2010 15:43'! borderStyleForSymbol: sym "Answer a border style corresponding to the given symbol" | aSymbol | aSymbol := sym == #none ifTrue: [#simple] ifFalse: [sym]. ^ self perform: aSymbol! ! !BorderedMorph commentStamp: 'kfr 10/27/2003 11:17'! BorderedMorph introduce borders to morph. Borders have the instanceVariables borderWidth and borderColor. BorderedMorph new borderColor: Color red; borderWidth: 10; openInWorld. BorderedMorph also have a varaity of border styles: simple, inset, raised, complexAltFramed, complexAltInset, complexAltRaised, complexFramed, complexInset, complexRaised. These styles are set using the classes BorderStyle, SimpleBorder, RaisedBorder, InsetBorder and ComplexBorder. BorderedMorph new borderStyle: (SimpleBorder width: 1 color: Color white); openInWorld. BorderedMorph new borderStyle: (BorderStyle inset width: 2); openInWorld. ! !BorderedMorph methodsFor: 'geometry' stamp: 'nk 4/5/2001 14:24'! closestPointTo: aPoint "account for round corners. Still has a couple of glitches at upper left and right corners" | pt | pt := self bounds pointNearestTo: aPoint. self wantsRoundedCorners ifFalse: [ ^pt ]. self bounds corners with: (self bounds insetBy: 6) corners do: [ :out :in | (pt - out) abs < (6@6) ifTrue: [ ^(in + (Point r: 5.0 degrees: (pt - in) degrees)) asIntegerPoint ]. ]. ^pt.! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'StephaneDucasse 5/30/2013 21:34'! addCornerGrips self addMorphBack: (TopLeftGripMorph new target: self; position: self position). self addMorphBack: (TopRightGripMorph new target: self; position: self position). self addMorphBack: (BottomLeftGripMorph new target: self; position: self position). self addMorphBack: (BottomRightGripMorph new target: self; position: self position)! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:16'! linkSubmorphsToSplitters self splitters do: [:each | each splitsTopAndBottom ifTrue: [self submorphsDo: [:eachMorph | (eachMorph ~= each and: [eachMorph layoutFrame bottomFraction = each layoutFrame topFraction]) ifTrue: [each addLeftOrTop: eachMorph]. (eachMorph ~= each and: [eachMorph layoutFrame topFraction = each layoutFrame bottomFraction]) ifTrue: [each addRightOrBottom: eachMorph]]] ifFalse: [self submorphsDo: [:eachMorph | (eachMorph ~= each and: [eachMorph layoutFrame rightFraction = each layoutFrame leftFraction]) ifTrue: [each addLeftOrTop: eachMorph]. (eachMorph ~= each and: [eachMorph layoutFrame leftFraction = each layoutFrame rightFraction]) ifTrue: [each addRightOrBottom: eachMorph]]]]! ! !BorderedMorph methodsFor: 'testing' stamp: 'FernandoOlivero 9/5/2013 10:55'! isTranslucentButNotTransparent "Answer true if this any of this morph is translucent but not transparent." (color isColor and: [color isTranslucentButNotTransparent]) ifTrue: [^ true]. (borderColor isColor and: [borderColor isTranslucentButNotTransparent]) ifTrue: [^ true]. ^ false ! ! !BorderedMorph methodsFor: 'initialization' stamp: 'MarcusDenker 12/11/2009 23:56'! initialize "initialize the state of the receiver" super initialize. self borderInitialize! ! !BorderedMorph methodsFor: 'menu' stamp: 'ClementBera 10/25/2013 13:45'! addBorderStyleMenuItems: aMenu hand: aHandMorph "Add border-style menu items" | subMenu | subMenu := UIManager default newMenuIn: self for: self. subMenu addStayUpItemSpecial. subMenu addList: {{'border width...' translated. #changeBorderWidth:}}. subMenu addLine. BorderStyle borderStyleChoices do: [:sym | (self borderStyleForSymbol: sym) ifNotNil: [subMenu add: sym translated target: self selector: #setBorderStyle: argument: sym]]. aMenu add: 'border style' translated subMenu: subMenu ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/4/1999 09:42'! borderWidth: anInteger borderColor ifNil: [borderColor := Color black]. borderWidth := anInteger max: 0. self changed! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 8/6/97 14:34'! borderColor ^ borderColor! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:28'! removePaneSplitters self splitters do: [:each | each delete]! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:09'! borderWidth ^ borderWidth! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:24'! borderInset self borderColor: #inset! ! !BorderedMorph methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:16'! borderStyle: aBorderStyle "Work around the borderWidth/borderColor pair" aBorderStyle = self borderStyle ifTrue: [^self]. self assureExtension. "secure against invalid border styles" (self canDrawBorder: aBorderStyle) ifFalse: ["Replace the suggested border with a simple one" ^self borderStyle: (BorderStyle width: aBorderStyle width color: (aBorderStyle trackColorFrom: self) color)]. aBorderStyle width = self borderStyle width ifFalse: [self changed]. (aBorderStyle isNil or: [aBorderStyle == BorderStyle default]) ifTrue: [extension borderStyle: nil. borderWidth := 0. ^self changed]. extension borderStyle: aBorderStyle. borderWidth := aBorderStyle width. borderColor := aBorderStyle style == #simple ifTrue: [aBorderStyle color] ifFalse: [aBorderStyle style]. self changed! ! !BorderedMorph methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:17'! borderStyle "Work around the borderWidth/borderColor pair" | style | borderColor ifNil: [^BorderStyle default]. borderWidth isZero ifTrue: [^BorderStyle default]. self assureExtension. style := extension borderStyle ifNil: [BorderStyle default]. (borderWidth = style width and: ["Hah!! Try understanding this..." borderColor == style style or: ["#raised/#inset etc" #simple == style style and: [borderColor = style color]]]) ifFalse: [style := borderColor isColor ifTrue: [BorderStyle width: borderWidth color: borderColor] ifFalse: [(BorderStyle perform: borderColor) width: borderWidth "argh."]. extension borderStyle: style]. ^style trackColorFrom: self! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:37'! useSquareCorners self cornerStyle: #square! ! !BorderedMorph methodsFor: 'menu' stamp: 'MarcusDenker 9/13/2013 15:55'! changeBorderWidth: evt | aHand origin handle newWidth | aHand := evt ifNil: [self primaryHand] ifNotNil: [evt hand]. origin := aHand position. handle := HandleMorph new forEachPointDo: [:newPoint | handle removeAllMorphs. handle addMorph: (LineMorph from: origin to: newPoint color: Color black width: 1). newWidth := (newPoint - origin) r asInteger // 5. self borderWidth: newWidth] lastPointDo: [:newPoint | handle deleteBalloon. self halo ifNotNil: [:halo | halo addHandles]]. aHand attachMorph: handle. handle setProperty: #helpAtCenter toValue: true. handle showBalloon: 'Move cursor farther from this point to increase border width. Click when done.' translated hand: evt hand. handle startStepping! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'IgorStasenko 12/19/2012 17:23'! addPaneVSplitterBetween: leftMorph and: rightMorphs | targetX minY maxY splitter | targetX := leftMorph layoutFrame rightFraction. minY := (rightMorphs detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction. maxY := (rightMorphs detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction. splitter := ProportionalSplitterMorph new. splitter layoutFrame: ( (targetX @ minY corner: targetX @ maxY) asLayoutFrame leftOffset: leftMorph layoutFrame rightOffset; rightOffset: 4+ leftMorph layoutFrame rightOffset; topOffset: leftMorph layoutFrame topOffset; bottomOffset: leftMorph layoutFrame bottomOffset). self addMorphBack: (splitter position: self position).! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:53'! borderInitialize "initialize the receiver state related to border" borderColor:= self defaultBorderColor. borderWidth := self defaultBorderWidth! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:19'! doesBevels "To return true means that this object can show bevelled borders, and therefore can accept, eg, #raised or #inset as valid borderColors. Must be overridden by subclasses that do not support bevelled borders." ^ true! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 00:03'! removeCornerGrips | corners | corners := self submorphsSatisfying: [:each | each isKindOf: CornerGripMorph]. corners do: [:each | each delete]! ! !BorderedMorph methodsFor: 'accessing' stamp: 'gvc 5/9/2006 15:50'! colorForInsets "Return the color to be used for shading inset borders." self owner isSystemWindow ifTrue: [^self owner colorForInsets]. ^super colorForInsets! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color black! ! !BorderedMorph methodsFor: 'accessing' stamp: 'ar 8/17/2001 16:52'! borderColor: colorOrSymbolOrNil self doesBevels ifFalse:[ colorOrSymbolOrNil isColor ifFalse:[^self]]. borderColor = colorOrSymbolOrNil ifFalse: [ borderColor := colorOrSymbolOrNil. self changed]. ! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'IgorStasenko 12/19/2012 17:19'! addPaneSplitters | splitter remaining target targetX sameX minY maxY targetY sameY minX maxX | self removePaneSplitters. self removeCornerGrips. remaining := submorphs reject: [:each | each layoutFrame rightFraction = 1]. [remaining notEmpty] whileTrue: [target := remaining first. targetX := target layoutFrame rightFraction. sameX := submorphs select: [:each | each layoutFrame rightFraction = targetX]. minY := (sameX detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction. maxY := (sameX detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction. splitter := ProportionalSplitterMorph new. splitter layoutFrame: ( (targetX @ minY corner: targetX @ maxY) asLayoutFrame leftOffset: target layoutFrame rightOffset; topOffset: target layoutFrame topOffset; rightOffset: 4 + target layoutFrame rightOffset; bottomOffset: target layoutFrame bottomOffset). self addMorphBack: (splitter position: self position). remaining := remaining copyWithoutAll: sameX]. remaining := submorphs copy reject: [:each | each layoutFrame bottomFraction = 1]. [remaining notEmpty] whileTrue: [target := remaining first. targetY := target layoutFrame bottomFraction. sameY := submorphs select: [:each | each layoutFrame bottomFraction = targetY]. minX := (sameY detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction. maxX := (sameY detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction. splitter := ProportionalSplitterMorph new beSplitsTopAndBottom; yourself. splitter layoutFrame: ( (minX @ targetY corner: maxX @ targetY) asLayoutFrame leftOffset: target layoutFrame leftOffset; topOffset: target layoutFrame bottomOffset; rightOffset: target layoutFrame rightOffset; bottomOffset: 4 + target layoutFrame bottomOffset ). self addMorphBack: (splitter position: self position). remaining := remaining copyWithoutAll: sameY]. self linkSubmorphsToSplitters. self splitters do: [:each | each comeToFront]. ! ! !BorderedMorph methodsFor: 'geometry' stamp: 'StephaneDucasse 5/28/2011 13:31'! acquireBorderWidth: aBorderWidth "Gracefully acquire the new border width, keeping the interior area intact and not seeming to shift" | delta | (delta := aBorderWidth- self borderWidth) = 0 ifTrue: [^ self]. self bounds: ((self bounds origin - (delta @ delta)) corner: (self bounds corner + (delta @ delta))). self borderWidth: aBorderWidth. self layoutChanged! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:25'! borderRaised self borderColor: #raised! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:16'! splitters ^ self submorphsSatisfying: [:each | each isKindOf: ProportionalSplitterMorph]! ! !BorderedMorph class methodsFor: 'examples' stamp: 'MarcusDenker 7/8/2012 12:09'! exampleGradient "self exampleGradient" | morph fs | morph := BorderedMorph new. fs := GradientFillStyle ramp: {0.0 -> Color red. 1.0 -> Color green}. fs origin: morph bounds center. fs direction: (morph bounds width // 2) @ 0. fs radial: true. morph fillStyle: fs. World primaryHand attachMorph: morph.! ! !BottomLeftGripMorph commentStamp: 'jmv 1/29/2006 17:17'! I am the handle in the left bottom of windows used for resizing them.! !BottomLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:52'! resizeCursor ^ Cursor resizeForEdge: #bottomLeft! ! !BottomLeftGripMorph methodsFor: 'accessing' stamp: 'md 2/24/2006 22:43'! ptName ^#bottomLeft! ! !BottomLeftGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 18:06'! apply: delta | oldBounds | oldBounds := target bounds. target bounds: (oldBounds origin + (delta x @ 0) corner: oldBounds corner + (0 @ delta y))! ! !BottomLeftGripMorph methodsFor: 'drawing' stamp: 'gvc 5/13/2008 10:21'! drawOn: aCanvas "Draw the grip on the given canvas." | dotBounds alphaCanvas windowBorderWidth dotBounds2 | self shouldDraw ifFalse: [^self]. windowBorderWidth := SystemWindow borderWidth. alphaCanvas := aCanvas asAlphaBlendingCanvas: 0.7. "alphaCanvas frameRectangle: bounds color: Color blue." dotBounds := self bounds. dotBounds2 := dotBounds right: (dotBounds left + windowBorderWidth). dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds left: (dotBounds left + windowBorderWidth). dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds2 left: (dotBounds2 left + 7). dotBounds2 := dotBounds2 right: (dotBounds2 right - 7). alphaCanvas fillRectangle: dotBounds2 color: self dotColor. dotBounds2 := dotBounds right: (dotBounds left + windowBorderWidth). dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds2 top: (dotBounds2 top + 7). dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - 7). alphaCanvas fillRectangle: dotBounds2 color: self dotColor! ! !BottomLeftGripMorph methodsFor: 'accessing' stamp: 'IgorStasenko 12/19/2012 17:46'! gripLayoutFrame ^ (0 @ 1 corner: 0 @ 1) asLayoutFrame topOffset: self defaultHeight negated; rightOffset: self defaultWidth! ! !BottomLeftGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 13:47'! containsPoint: aPoint "Answer true only if on edges." |w| ^(super containsPoint: aPoint) and: [ w := SystemWindow borderWidth. ((self bounds translateBy: w@w negated) containsPoint: aPoint) not]! ! !BottomRightGripMorph commentStamp: 'jmv 1/29/2006 17:18'! I am the handle in the right bottom of windows used for resizing them.! !BottomRightGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:51'! resizeCursor ^ Cursor resizeForEdge: #bottomRight! ! !BottomRightGripMorph methodsFor: 'accessing' stamp: 'md 2/24/2006 22:43'! ptName ^#bottomRight! ! !BottomRightGripMorph methodsFor: 'target resize' stamp: 'jmv 1/29/2006 17:59'! apply: delta | oldBounds | oldBounds := target bounds. target bounds: (oldBounds origin corner: oldBounds corner + delta)! ! !BottomRightGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:21'! drawOn: aCanvas "Draw the grip on the given canvas." | dotBounds alphaCanvas windowBorderWidth dotBounds2 | self shouldDraw ifFalse: [^self]. windowBorderWidth := SystemWindow borderWidth. alphaCanvas := aCanvas asAlphaBlendingCanvas: 0.7. "alphaCanvas frameRectangle: bounds color: Color blue." dotBounds := self bounds. dotBounds2 := dotBounds left: (dotBounds right - windowBorderWidth). dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds right: (dotBounds right - windowBorderWidth). dotBounds2 := dotBounds2 top: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds2 left: (dotBounds2 left + 7). dotBounds2 := dotBounds2 right: (dotBounds2 right - 7). alphaCanvas fillRectangle: dotBounds2 color: self dotColor. dotBounds2 := dotBounds left: (dotBounds right - windowBorderWidth). dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - windowBorderWidth). alphaCanvas fillRectangle: dotBounds2 color: self handleColor. dotBounds2 := dotBounds2 top: (dotBounds2 top + 7). dotBounds2 := dotBounds2 bottom: (dotBounds2 bottom - 7). alphaCanvas fillRectangle: dotBounds2 color: self dotColor! ! !BottomRightGripMorph methodsFor: 'accessing' stamp: 'IgorStasenko 12/19/2012 17:48'! gripLayoutFrame ^ (1 @ 1 corner: 1 @ 1) asLayoutFrame topLeftOffset: (0 - self defaultWidth @ (0 - self defaultHeight)) ! ! !BottomRightGripMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/12/2007 10:52'! containsPoint: aPoint "Answer true only if on edges." |w| ^(super containsPoint: aPoint) and: [ w := SystemWindow borderWidth. ((self bounds translateBy: (w@w) negated) containsPoint: aPoint) not]! ! !BoundedGradientFillStyle commentStamp: 'gvc 3/13/2009 12:19'! Gradient fillstyle that draws with optional extent.! !BoundedGradientFillStyle methodsFor: 'accessing' stamp: 'gvc 3/13/2009 12:22'! extent "Answer the value of extent" ^ extent! ! !BoundedGradientFillStyle methodsFor: 'comparing' stamp: 'gvc 3/13/2009 12:39'! hash "Hash is implemented because #= is implemented." ^super hash bitXor: self extent hash! ! !BoundedGradientFillStyle methodsFor: 'accessing' stamp: 'gvc 3/13/2009 12:22'! extent: anObject "Set the value of extent" extent := anObject! ! !BoundedGradientFillStyle methodsFor: 'comparing' stamp: 'gvc 3/13/2009 12:39'! = aGradientFillStyle "Answer whether equal." ^super = aGradientFillStyle and: [self extent = aGradientFillStyle extent]! ! !BoundedGradientFillStyle methodsFor: '*Polymorph-Widgets' stamp: 'IgorStasenko 12/22/2012 03:41'! fillRectangle: aRectangle on: aCanvas "Fill the given rectangle on the given canvas with the receiver." self extent ifNil: [^super fillRectangle: aRectangle on: aCanvas]. aCanvas fillRectangle: ((self origin extent: self extent) intersect: aRectangle ifNone: [^ self ]) basicFillStyle: self! ! !BraceNode commentStamp: ''! Used for compiling and decompiling brace constructs. These now compile into either a fast short form for 4 elements or less: Array braceWith: a with: b ... or a long form of indefinfite length: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray. The erstwhile brace assignment form is no longer supported.! !BraceNode methodsFor: 'enumerating' stamp: ''! casesReverseDo: aBlock "For each case in reverse order, evaluate aBlock with three arguments: the key block, the value block, and whether it is the last case." | numCases case | (numCases := elements size) to: 1 by: -1 do: [:i | case := elements at: i. aBlock value: case receiver value: case arguments first value: i=numCases]! ! !BraceNode methodsFor: 'initialize-release' stamp: ''! elements: collection sourceLocations: locations "Compile." elements := collection. sourceLocations := locations! ! !BraceNode methodsFor: 'initialize-release' stamp: ''! elements: collection "Decompile." elements := collection! ! !BraceNode methodsFor: 'testing' stamp: 'eem 9/25/2008 14:48'! blockAssociationCheck: encoder "If all elements are MessageNodes of the form [block]->[block], and there is at least one element, answer true. Otherwise, notify encoder of an error." elements size = 0 ifTrue: [^encoder notify: 'At least one case required']. elements with: sourceLocations do: [:x :loc | (x isMessage: #-> receiver: [:rcvr | rcvr isBlockNode and: [rcvr numberOfArguments = 0]] arguments: [:arg | arg isBlockNode and: [arg numberOfArguments = 0]]) ifFalse: [^encoder notify: 'Association between 0-argument blocks required' at: loc]]. ^true! ! !BraceNode methodsFor: 'initialize-release' stamp: 'di 11/19/1999 11:19'! matchBraceWithReceiver: receiver selector: selector arguments: arguments selector = (self selectorForShortForm: arguments size) ifFalse: [^ nil "no match"]. "Appears to be a short form brace construct" self elements: arguments! ! !BraceNode methodsFor: 'code generation (closures)' stamp: 'eem 7/20/2009 09:33'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" elements do: [:node| node analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools]! ! !BraceNode methodsFor: 'code generation (closures)' stamp: 'eem 5/30/2008 17:22'! maxElementsForConsArray "Hack; we have no way of knowing how much stack space is available during sizing" ^8! ! !BraceNode methodsFor: 'code generation' stamp: 'eem 5/30/2008 17:22'! sizeCodeForValue: encoder (encoder supportsClosureOpcodes "Hack; we have no way of knowing how much stack space is available" and: [elements size <= self maxElementsForConsArray]) ifTrue: [^(elements inject: 0 into: [:sum :node| sum + (node sizeCodeForValue: encoder)]) + (encoder sizePushConsArray: elements size)]. emitNode := elements size <= 4 ifTrue: ["Short form: Array braceWith: a with: b ... " MessageNode new receiver: (encoder encodeVariable: #Array) selector: (self selectorForShortForm: elements size) arguments: elements precedence: 3 from: encoder] ifFalse: ["Long form: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray" CascadeNode new receiver: (MessageNode new receiver: (encoder encodeVariable: #Array) selector: #braceStream: arguments: (Array with: (encoder encodeLiteral: elements size)) precedence: 3 from: encoder) messages: ((elements collect: [:elt | MessageNode new receiver: nil selector: #nextPut: arguments: (Array with: elt) precedence: 3 from: encoder]) copyWith: (MessageNode new receiver: nil selector: #braceArray arguments: (Array new) precedence: 1 from: encoder))]. ^emitNode sizeCodeForValue: encoder! ! !BraceNode methodsFor: 'initialize-release' stamp: 'di 11/19/1999 11:06'! matchBraceStreamReceiver: receiver messages: messages ((receiver isMessage: #braceStream: receiver: nil arguments: [:arg | arg isConstantNumber]) and: [messages last isMessage: #braceArray receiver: nil arguments: nil]) ifFalse: [^ nil "no match"]. "Appears to be a long form brace construct" self elements: (messages allButLast collect: [:msg | (msg isMessage: #nextPut: receiver: nil arguments: nil) ifFalse: [^ nil "not a brace element"]. msg arguments first])! ! !BraceNode methodsFor: 'code generation' stamp: 'di 1/4/2000 11:24'! selectorForShortForm: nElements nElements > 4 ifTrue: [^ nil]. ^ #(braceWithNone braceWith: braceWith:with: braceWith:with:with: braceWith:with:with:with:) at: nElements + 1! ! !BraceNode methodsFor: 'enumerating' stamp: ''! casesForwardDo: aBlock "For each case in forward order, evaluate aBlock with three arguments: the key block, the value block, and whether it is the last case." | numCases case | 1 to: (numCases := elements size) do: [:i | case := elements at: i. aBlock value: case receiver value: case arguments first value: i=numCases]! ! !BraceNode methodsFor: 'code generation' stamp: 'eem 5/30/2008 17:40'! emitCodeForValue: stack encoder: encoder (encoder supportsClosureOpcodes "Hack; we have no way of knowing how much stack space is available" and: [elements size <= self maxElementsForConsArray]) ifTrue: [elements do: [:node| node emitCodeForValue: stack encoder: encoder]. encoder genPushConsArray: elements size. stack pop: elements size; push: 1. ^self]. ^emitNode emitCodeForValue: stack encoder: encoder! ! !BraceNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:33'! accept: aVisitor ^aVisitor visitBraceNode: self! ! !BraceNode methodsFor: 'code generation (closures)' stamp: 'eem 5/21/2008 10:40'! elements ^elements! ! !BraceNode methodsFor: 'testing' stamp: ''! numElements ^ elements size! ! !BraceNode methodsFor: 'printing' stamp: 'di 11/19/1999 09:17'! printOn: aStream indent: level aStream nextPut: ${. 1 to: elements size do: [:i | (elements at: i) printOn: aStream indent: level. i < elements size ifTrue: [aStream nextPutAll: '. ']]. aStream nextPut: $}! ! !BraceNode class methodsFor: 'examples' stamp: 'di 11/19/1999 09:05'! example "Test the {a. b. c} syntax." | x | x := {1. {2. 3}. 4}. ^ {x first. x second first. x second last. x last. 5} as: Set "BraceNode example Set (0 1 2 3 4 5 )" ! ! !BracketMorph commentStamp: 'gvc 5/18/2007 13:48'! Morph displaying opposing arrows.! !BracketMorph methodsFor: 'initialization' stamp: 'gvc 9/19/2006 15:52'! initialize "Initialize the receiver." super initialize. self orientation: #horizontal! ! !BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/21/2006 15:48'! horizontal "Answer whether horizontal or vertical." ^self orientation == #horizontal! ! !BracketMorph methodsFor: 'drawing' stamp: 'gvc 9/21/2006 16:16'! drawOn: aCanvas "Draw triangles at the edges." |r| r := self horizontal ifTrue: [self bounds insetBy: (2@1 corner: 2@1)] ifFalse: [self bounds insetBy: (1@2 corner: 1@2)]. aCanvas drawPolygon: (self leftOrTopVertices: self bounds) fillStyle: self borderColor; drawPolygon: (self leftOrTopVertices: r) fillStyle: self fillStyle; drawPolygon: (self rightOrBottomVertices: self bounds) fillStyle: self borderColor; drawPolygon: (self rightOrBottomVertices: r) fillStyle: self fillStyle! ! !BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 15:52'! orientation: anObject "Set the value of orientation" orientation := anObject. self changed! ! !BracketMorph methodsFor: 'geometry' stamp: 'gvc 9/21/2006 16:18'! rightOrBottomVertices: r "Answer the vertices for a right or bottom bracket in the given rectangle." ^self orientation == #vertical ifTrue: [{r topRight - (0@1). r right - (r height // 2 + (r height \\ 2))@(r center y - (r height + 1 \\ 2)). r right - (r height // 2 + (r height \\ 2))@(r center y). r bottomRight}] ifFalse: [{(r center x)@(r bottom - 1 - (r width // 2 + (r width \\ 2))). r center x @(r bottom - 1 - (r width // 2 + (r width \\ 2))). r bottomRight. r bottomLeft - (1@0)}]! ! !BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 15:54'! horizontal: aBoolean "Set whether horizontal or vertical." ^self orientation: (aBoolean ifTrue: [#horizontal] ifFalse: [#vertical])! ! !BracketMorph methodsFor: 'geometry' stamp: 'gvc 9/21/2006 15:45'! leftOrTopVertices: r "Answer the vertices for a left or top bracket in the given rectangle." ^self orientation == #vertical ifTrue: [{r topLeft - (0@1). r left + (r height // 2 + (r height \\ 2))@(r center y - (r height + 1 \\ 2)). r left + (r height // 2 + (r height \\ 2))@(r center y). r bottomLeft}] ifFalse: [{r topLeft. (r center x - (r width + 1 \\ 2))@(r top + (r width // 2 + (r width \\ 2))). r center x@(r top + (r width // 2 + (r width \\ 2))). r topRight}]! ! !BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 15:51'! orientation "Answer the value of orientation" ^ orientation! ! !BracketSliderMorph commentStamp: 'gvc 5/18/2007 13:39'! Abstract superclass for morphs that are used to select a component (R, G, B or A) of a colour.! !BracketSliderMorph methodsFor: 'initialization' stamp: 'gvc 9/3/2009 13:39'! initialize "Initialize the receiver." super initialize. self fillStyle: self defaultFillStyle; borderStyle: (BorderStyle inset baseColor: self paneColor; width: 1); sliderColor: Color black; clipSubmorphs: true! ! !BracketSliderMorph methodsFor: 'geometry' stamp: 'gvc 9/26/2006 12:02'! sliderThickness "Answer the thickness of the slider." ^((self bounds isWide ifTrue: [self height] ifFalse: [self width]) // 2 max: 8) // 2 * 2 + 1! ! !BracketSliderMorph methodsFor: 'geometry' stamp: 'gvc 9/3/2009 13:40'! extent: aPoint "Update the gradient directions." super extent: aPoint. self updateFillStyle! ! !BracketSliderMorph methodsFor: 'protocol' stamp: 'gvc 9/3/2009 13:41'! updateFillStyle "Update the fill style directions." |b fs| fs := self fillStyle. fs isOrientedFill ifTrue: [ b := self innerBounds. fs origin: b topLeft. fs direction: (b isWide ifTrue: [b width@0] ifFalse: [0@b height])]! ! !BracketSliderMorph methodsFor: 'protocol' stamp: 'gvc 9/3/2009 13:40'! defaultFillStyle "Answer the defauolt fill style." ^Color gray! ! !BracketSliderMorph methodsFor: 'layout' stamp: 'gvc 9/3/2009 13:41'! layoutBounds: aRectangle "Set the bounds for laying out children of the receiver. Note: written so that #layoutBounds can be changed without touching this method" super layoutBounds: aRectangle. self updateFillStyle. slider horizontal: self bounds isWide. sliderShadow horizontal: self bounds isWide! ! !BracketSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/7/2007 16:05'! fillStyleToUse "Answer the fillStyle that should be used for the receiver." ^self fillStyle! ! !BracketSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 14:06'! gradient "Answer the gradient." self subclassResponsibility! ! !BracketSliderMorph methodsFor: 'access' stamp: 'gvc 9/19/2006 15:43'! sliderShadowColor "Answer the color for the slider shadow." ^Color black alpha: 0.6! ! !BracketSliderMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/18/2012 16:16'! initializeSlider "Make the slider raised." self setSlider: (( BracketMorph newBounds: self totalSliderArea) horizontal: self bounds isWide; color: self thumbColor; borderStyle: (BorderStyle raised baseColor: Color white; width: 1)) withShadow: ((BracketMorph newBounds: self totalSliderArea) horizontal: self bounds isWide; color: self pagingArea color; borderStyle: (BorderStyle inset baseColor: (Color white alpha: 0.6); width: 1)).! ! !BracketSliderMorph methodsFor: 'access' stamp: 'gvc 9/8/2009 13:29'! sliderColor: newColor "Set the slider colour." super sliderColor: (self enabled ifTrue: [Color black] ifFalse: [self sliderShadowColor]). slider ifNotNil: [slider borderStyle baseColor: Color white]! ! !BracketSliderMorph methodsFor: 'geometry' stamp: 'gvc 9/21/2006 11:34'! roomToMove "Allow to run off the edges a bit." ^self bounds isWide ifTrue: [self totalSliderArea insetBy: ((self sliderThickness // 2@0) negated corner: (self sliderThickness // 2 + 1)@0)] ifFalse: [self totalSliderArea insetBy: (0@(self sliderThickness // 2) negated corner: 0@(self sliderThickness // 2 - (self sliderThickness \\ 2) + 1))]! ! !BreadthFirstGuide commentStamp: 'cwp 11/18/2009 12:13'! I traverse the filesystem in breadth-first order. Given this hierarchy: alpha beta gamma delta epsilon I would visit the nodes in the following order: alpha, delta, beta, gamma, epsilon. I use my work instance variable as a queue, adding nodes to be visited to the end and retrieving them from the beginning. ! !BreadthFirstGuide methodsFor: 'showing' stamp: 'CamilloBruni 4/10/2013 12:41'! visitNextEntry: entry entry isFile ifTrue: [ ^ visitor visitFile: entry ]. visitor visitDirectory: entry. (self shouldVisitChildrenOf: entry) ifTrue: [ self pushAll: entry reference entries ].! ! !BreadthFirstGuide methodsFor: 'showing' stamp: 'CamilloBruni 8/12/2011 18:23'! show: aReference self push: aReference entry. self whileNotDoneDo: [ self visitNextEntry: self top ]! ! !BreadthFirstGuideTest commentStamp: 'TorstenBergmann 1/31/2014 11:43'! SUnit tests for class BreadthFirstGuide! !BreadthFirstGuideTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:37'! testAll guide := BreadthFirstGuide for: self. guide show: (filesystem / 'alpha'). self assertVisitedIs: #( 'alpha' 'beta' 'epsilon' 'delta' 'gamma' 'zeta' )! ! !BreakPoint commentStamp: 'md 11/18/2003 09:32'! This exception is raised on executing a breakpoint. "BreakPoint signal" is called from "Object>>break".! !BreakpointManager commentStamp: 'md 10/9/2008 20:17'! This class manages methods that include breakpoints. It has several class methods to install and uninstall breakpoints. Evaluating "BreakpointManager clear" will remove all installed breakpoints in the system. Known issues: - currently, only break-on-entry type of breakpoints are supported - uninstalling the breakpoint doesn't auto-update other browsers - uninstalling a breakpoint while debugging should restart-simulate the current method Ernest Micklei, 2002 Send comments to emicklei@philemonworks.com! !BreakpointManager class methodsFor: 'intialization-release' stamp: 'marcus.denker 10/9/2008 20:35'! clear "BreakpointManager clear" self installed associations do: [:entry | self unInstall: entry key]. ! ! !BreakpointManager class methodsFor: 'private' stamp: 'ClementBera 6/28/2013 11:01'! compilePrototype: aSymbol in: aClass "Compile and return a new method containing a break statement" | source method | source := self breakpointMethodSourceFor: aSymbol in: aClass. method := aClass compiler source: source; class: aClass; failBlock: [self error: '[breakpoint] unable to install breakpoint']; compiledMethodTrailer: (aClass>>aSymbol) trailer; compile. ^method! ! !BreakpointManager class methodsFor: 'testing' stamp: 'emm 5/30/2002 09:22'! methodHasBreakpoint: aMethod ^self installed includesKey: aMethod! ! !BreakpointManager class methodsFor: 'examples' stamp: 'StephaneDucasse 11/7/2011 22:41'! testBreakpoint "In the menu of the methodList, click on -toggle break on entry- and evaluate the following:" "BreakpointManager testBreakpoint" self crTrace: 'Breakpoint test'! ! !BreakpointManager class methodsFor: 'install-uninstall' stamp: 'MarcusDenker 5/10/2013 00:24'! unInstall: breakMethod | class selector oldMethod | oldMethod := self installed at: breakMethod ifAbsent:[^self]. class := breakMethod methodClass. selector := breakMethod selector. (class>>selector) == breakMethod ifTrue:[ class methodDict at: selector put: oldMethod]. self installed removeKey: breakMethod! ! !BreakpointManager class methodsFor: 'install-uninstall' stamp: 'ClementBera 7/26/2013 16:12'! installInClass: aClass selector: aSymbol "Install a new method containing a breakpoint. The receiver will remember this for unstalling it later" | breakMethod | breakMethod := self compilePrototype: aSymbol in: aClass. breakMethod ifNil: [^ nil]. self installed at: breakMethod put: aClass >> aSymbol. "old method" aClass basicAddSelector: aSymbol withMethod: breakMethod.! ! !BreakpointManager class methodsFor: 'private' stamp: 'ClementBera 6/28/2013 10:59'! breakpointMethodSourceFor: aSymbol in: aClass "Compose new source containing a break statement (currently it will be the first, later we want to insert it in any place)" | oldSource methodNode breakOnlyMethodNode sendBreakMessageNode ast | OpalCompiler isActive ifFalse: [ oldSource := aClass sourceCodeAt: aSymbol. methodNode := aClass compiler source: oldSource; class: aClass; failBlock: [self error: '[breakpoint] unable to install breakpoint']; translate. breakOnlyMethodNode := aClass compiler source: 'temporaryMethodSelectorForBreakpoint self break. ^self'; class: aClass; failBlock: [self error: '[breakpoint] unable to install breakpoint']; translate. sendBreakMessageNode := breakOnlyMethodNode block statements first. methodNode block statements addFirst: sendBreakMessageNode. ^methodNode printString ]. sendBreakMessageNode := RBMessageNode receiver: (RBVariableNode named: 'self') selector: #break. ast := (aClass>>aSymbol) ast copy. ast body addNodeFirst: sendBreakMessageNode. ^ast formattedCode.! ! !BreakpointManager class methodsFor: 'private' stamp: 'ClementBera 7/26/2013 16:12'! installed ^ Installed ifNil: [Installed := IdentityDictionary new]! ! !BrowseDebugAction commentStamp: ''! A BrowseDebugAction is a debugging actions sending a unary message to the stack widget. ! !BrowseDebugAction methodsFor: 'initialization' stamp: 'AndreiChis 9/25/2013 17:33'! initialize super initialize. self needsUpdate: false. self needsValidation: false.! ! !BrowseDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/26/2013 19:07'! receiver ^ self debugger stack! ! !BrowseDebugAction class methodsFor: 'actions creation' stamp: 'AndreiChis 9/24/2013 16:41'! debugActionsFor: aDebugger | initilOrder | initilOrder := 60. ^ { self new id: #browseSendersOfMessages; order: initilOrder; keyText: 'n'; label: 'Senders of...'. self new id: #browseMessages; order: initilOrder + 5; keyText: 'm'; label: 'Implementors of...'. self new id: #methodHierarchy; order: initilOrder + 10; keyText: 'i'; label: 'Inheritance'. self new id: #browseVersions; order: initilOrder + 15; keyText: 'v'; label: 'Versions'. self new id: #browseInstVarRefs; order: initilOrder + 20; label: 'Inst var refs...'. self new id: #browseClassVarRefs; order: initilOrder + 25; label: 'Class var refs...'. self new id: #browseClassVariables; order: initilOrder + 30; label: 'Class variables'; withSeparatorAfter. self new id: #browseClassRefs; order: initilOrder + 35; keyText: 'N'; label: 'Class refs'. self new id: #browseMethodFull; order: initilOrder + 40; keyText: 'b'; label: 'Browse full'. self new id: #fileOutMessage; order: initilOrder + 45; label: 'File out'. self new id: #inspectInstances; order: initilOrder + 50; label: 'Inspect instances'. self new id: #inspectSubInstances; order: initilOrder + 55; label: 'Inspect subinstances'; withSeparatorAfter }! ! !Browser commentStamp: ''! I represent a query path into the class descriptions, the software of the system.! !Browser methodsFor: 'initialization' stamp: 'StephaneDucasse 12/19/2012 16:29'! openAsMorphSysCatEditing: editString "Create a pluggable version of all the views for a Browser, including views and controllers." | window hSepFrac switchHeight mySingletonList | window := (SystemWindow labelled: 'later') model: self. hSepFrac := 0.30. switchHeight := 25. mySingletonList := PluggableListMorph on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:. mySingletonList enableDragNDrop: true. mySingletonList hideScrollBarsIndefinitely. window addMorph: mySingletonList fullFrame: ( (0@0 corner: 1@0) asLayoutFrame bottomOffset: switchHeight). self addClassAndSwitchesTo: window at: (0@0 corner: 0.3333@hSepFrac) plus: switchHeight. window addMorph: self buildMorphicMessageCatList fullFrame: ( (0.3333@0 corner: 0.6666@hSepFrac) asLayoutFrame topOffset: switchHeight). window addMorph: self buildMorphicMessageList fullFrame: ( (0.6666@0 corner: 1@hSepFrac) asLayoutFrame topOffset: switchHeight). self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window setUpdatablePanesFrom: #( classList messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'drag and drop' stamp: 'nk 6/12/2004 17:43'! acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph "Here we are fetching informations from the dropped transferMorph and performing the correct action for this drop." | srcType success srcBrowser | success := false. srcType := transferMorph dragTransferType. srcBrowser := transferMorph source model. srcType == #messageList ifTrue: [ | srcClass srcSelector srcCategory | srcClass := transferMorph passenger key. srcSelector := transferMorph passenger value. srcCategory := srcBrowser selectedMessageCategoryName. srcCategory ifNil: [srcCategory := srcClass organization categoryOfElement: srcSelector]. success := self acceptMethod: srcSelector messageCategory: srcCategory class: srcClass atListMorph: dstListMorph internal: self == srcBrowser copy: transferMorph shouldCopy]. srcType == #classList ifTrue: [success := self changeCategoryForClass: transferMorph passenger srcSystemCategory: srcBrowser selectedSystemCategoryName atListMorph: dstListMorph internal: self == srcBrowser copy: transferMorph shouldCopy]. ^ success! ! !Browser methodsFor: 'message category list' stamp: 'EstebanLorenzano 6/26/2013 18:08'! recategorizeMethodSelector: sel "Categorize method named sel by looking in parent classes for a method category. Answer true if recategorized." self selectedClassOrMetaClass allSuperclasses do: [:ea | | thisCat | thisCat := ea organization categoryOfElement: sel. (thisCat ~= Protocol unclassified and: [thisCat notNil]) ifTrue: [self classOrMetaClassOrganizer classify: sel under: thisCat. self changed: #messageCategoryList. ^ true]]. ^ false! ! !Browser methodsFor: 'accessing' stamp: 'rbb 3/1/2005 10:26'! request: prompt initialAnswer: initialAnswer ^ UIManager default request: prompt initialAnswer: initialAnswer ! ! !Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! setOriginalCategoryIndexForCurrentMethod "private - Set the message category index for the currently selected method. Note: This should only be called when somebody tries to save a method that they are modifying while ALL is selected." messageCategoryListIndex := self messageCategoryList indexOf: self categoryOfCurrentMethod ! ! !Browser methodsFor: 'traits' stamp: 'BernardoContreras 2/25/2012 17:33'! spawnHierarchyForClass: aClass selector: aSelector "Create and schedule a new hierarchy browser for the given class and selector." self setClass: aClass selector: aSelector. self spawnHierarchy. ! ! !Browser methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:21'! dstCategoryDstListMorph: dstListMorph ^(dstListMorph getListSelector == #systemCategoryList) ifTrue: [dstListMorph potentialDropItem ] ifFalse: [self selectedSystemCategoryName]! ! !Browser methodsFor: 'system category functions' stamp: 'sd 11/20/2005 21:26'! buildSystemCategoryBrowserEditString: aString "Create and schedule a new system category browser with initial textual contents set to aString." | newBrowser | systemCategoryListIndex > 0 ifTrue: [newBrowser := self class new. newBrowser systemCategoryListIndex: systemCategoryListIndex. newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName. self class openBrowserView: (newBrowser openSystemCatEditString: aString) label: 'Classes in category ', newBrowser selectedSystemCategoryName]! ! !Browser methodsFor: 'message list' stamp: ''! messageListIndex "Answer the index of the selected message selector into the currently selected message category." ^messageListIndex! ! !Browser methodsFor: 'metaclass' stamp: 'md 2/18/2006 16:31'! setClassOrganizer "Install whatever organization is appropriate" | theClass | classOrganizer := nil. metaClassOrganizer := nil. classListIndex = 0 ifTrue: [^ self]. theClass := self selectedClass ifNil: [ ^self ]. classOrganizer := theClass organization. metaClassOrganizer := theClass classSide organization.! ! !Browser methodsFor: 'message category list' stamp: 'AlainPlantec 8/26/2011 17:45'! messageCategoryListIndex: anInteger "Set the selected message category to be the one indexed by anInteger." messageCategoryListIndex := anInteger. messageListIndex := 0. self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. self editSelection: (anInteger > 0 ifTrue: [#newMessage] ifFalse: [self classListIndex > 0 ifTrue: [ #editClass] ifFalse: [#newClass]]). contents := nil. self contentsChanged. self changed: #relabel.! ! !Browser methodsFor: 'message list' stamp: 'BenjaminVanRyseghem 4/24/2012 15:07'! messageList "Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range. Otherwise, answer an empty Array If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero." | sel | (sel := self messageCategoryListSelection) ifNil: [ ^ self classOrMetaClassOrganizer ifNil: [Array new] ifNotNil: [self classOrMetaClassOrganizer allMethodSelectors] ]. ^ (self classOrMetaClassOrganizer listAtCategoryNumber: messageCategoryListIndex) ifNil: [messageCategoryListIndex := 0. Array new]! ! !Browser methodsFor: 'breakpoints' stamp: 'marcus.denker 10/9/2008 20:32'! toggleBreakOnEntry "Install or uninstall a halt-on-entry breakpoint" super toggleBreakOnEntry. self changed: #messageList ! ! !Browser methodsFor: 'initialization' stamp: 'AlainPlantec 2/25/2011 12:02'! labelString self selectedClass ifNil: [ ^ self defaultBrowserTitle ]. ^ String streamContents: [ :s| self selectedClass printOn: s. self metaClassIndicated ifTrue: [ s << ' class' ]. self selectedMessageName ifNotNil: [ :name| s << '>>' << name ]] ! ! !Browser methodsFor: 'drag and drop' stamp: 'alain.plantec 2/6/2009 16:33'! overwriteDialogHierarchyChange: hierarchyChange higher: higherFlag sourceClassName: srcClassName destinationClassName: dstClassName methodSelector: methodSelector | lf | lf := Character cr asString. ^ UIManager default confirm: 'There is a conflict.' translated, ' Overwrite' translated, (hierarchyChange ifTrue: [higherFlag ifTrue: [' superclass' translated] ifFalse: [' subclass' translated]] ifFalse: ['']) , ' method' translated, lf , dstClassName , '>>' , methodSelector , lf , 'by ' translated, (hierarchyChange ifTrue: ['moving' translated] ifFalse: ['copying' translated]) , ' method' translated, lf , srcClassName name , '>>' , methodSelector , ' ?'. ! ! !Browser methodsFor: 'accessing' stamp: 'al 12/6/2005 22:36'! contents "Depending on the current selection, different information is retrieved. Answer a string description of that information. This information is the method of the currently selected class and message." | comment theClass latestCompiledMethod | latestCompiledMethod := currentCompiledMethod. currentCompiledMethod := nil. editSelection == #newTrait ifTrue: [^Trait newTemplateIn: self selectedSystemCategoryName]. editSelection == #none ifTrue: [^ '']. editSelection == #editSystemCategories ifTrue: [^ systemOrganizer printString]. editSelection == #newClass ifTrue: [^ (theClass := self selectedClass) ifNil: [Class template: self selectedSystemCategoryName] ifNotNil: [Class templateForSubclassOf: theClass category: self selectedSystemCategoryName]]. editSelection == #editClass ifTrue: [^self classDefinitionText]. editSelection == #editComment ifTrue: [(theClass := self selectedClass) ifNil: [^ '']. comment := theClass comment. currentCompiledMethod := theClass organization commentRemoteStr. ^ comment size = 0 ifTrue: ['This class has not yet been commented.'] ifFalse: [comment]]. editSelection == #hierarchy ifTrue: [ self selectedClassOrMetaClass isTrait ifTrue: [^''] ifFalse: [^self selectedClassOrMetaClass printHierarchy]]. editSelection == #editMessageCategories ifTrue: [^ self classOrMetaClassOrganizer printString]. editSelection == #newMessage ifTrue: [^ (theClass := self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass sourceCodeTemplate]]. editSelection == #editMessage ifTrue: [self showingByteCodes ifTrue: [^ self selectedBytecodes]. currentCompiledMethod := latestCompiledMethod. ^ self selectedMessage]. self error: 'Browser internal error: unknown edit selection.'! ! !Browser methodsFor: 'class list' stamp: ''! classListIndex "Answer the index of the current class selection." ^classListIndex! ! !Browser methodsFor: 'system category functions' stamp: 'MarcusDenker 10/7/2012 11:56'! systemCatSingletonMenu: aMenu ^ aMenu addList: #( ('browse' buildSystemCategoryBrowser) ('fileOut' fileOutSystemCategory) - ('update' updateSystemCategories) ('rename...' renameSystemCategory) - ('remove' removeSystemCategory))! ! !Browser methodsFor: 'metaclass' stamp: 'al 4/24/2004 11:47'! selectedClassOrMetaClass "Answer the selected class/trait or metaclass/classTrait." | cls | ^self metaClassIndicated ifTrue: [(cls := self selectedClass) ifNil: [nil] ifNotNil: [cls classSide]] ifFalse: [self selectedClass]! ! !Browser methodsFor: 'class functions' stamp: 'MarcusDenker 5/7/2012 15:12'! classListMenu: aMenu shifted: shifted "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" shifted ifTrue: [^ self shiftedClassListMenu: aMenu]. aMenu addList: #( - ('Browse full (b)' browseMethodFull) ('Browse hierarchy (h)' spawnHierarchy) - ('FileOut' fileOutClass) - ('Show hierarchy' hierarchy) ('Show definition' editClass) ('Show comment' editComment) - ('Inst var refs...' browseInstVarRefs) ('Inst var defs...' browseInstVarDefs) - ('Class var refs...' browseClassVarRefs) ('Class vars' browseClassVariables) ('Class refs (N)' browseClassRefs) - ('Rename class ...' renameClass) ('Copy class' copyClass) ('Remove class (x)' removeClass) - ('Find method...' findMethod) ('Find method wildcard...' findMethodWithWildcard) - ('More...' offerShiftedClassListMenu)). ^ aMenu ! ! !Browser methodsFor: 'message category list' stamp: 'BenjaminVanRyseghem 4/24/2012 15:00'! messageCategoryList "Answer the selected category of messages." classListIndex = 0 ifTrue: [^ Array new] ifFalse: [^ self classOrMetaClassOrganizer categoriesSorted ]! ! !Browser methodsFor: 'metaclass' stamp: 'sd 11/20/2005 21:26'! metaClassIndicated: trueOrFalse "Indicate whether browsing instance or class messages." metaClassIndicated := trueOrFalse. self setClassOrganizer. systemCategoryListIndex > 0 ifTrue: [self editSelection: (classListIndex = 0 ifTrue: [metaClassIndicated ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass])]. messageCategoryListIndex := 0. messageListIndex := 0. contents := nil. self changed: #classSelectionChanged. self changed: #messageCategoryList. self changed: #messageList. self changed: #contents. self changed: #annotation. self decorateButtons ! ! !Browser methodsFor: 'accessing' stamp: ''! editSelection ^editSelection! ! !Browser methodsFor: '*Shout-Styling' stamp: 'AlainPlantec 8/27/2011 00:52'! shoutAboutToStyle: aPluggableShoutMorphOrView | type | self shoutIsModeStyleable ifFalse: [^ false]. type := self editSelection. (#(#newMessage #editMessage #editClass #newClass ) includes: type) ifFalse: [^ false]. aPluggableShoutMorphOrView classOrMetaClass: (type = #editClass ifFalse: [self selectedClassOrMetaClass]). ^ true! ! !Browser methodsFor: 'metaclass' stamp: 'AlainPlantec 8/26/2011 17:56'! indicateInstanceMessages "Indicate that the message selection should come from the class (instance) messages." self metaClassIndicated: false! ! !Browser methodsFor: 'message category list' stamp: 'ccn 3/24/1999 11:02'! messageCategoryListSelection "Return the selected category name or nil." ^ ((self messageCategoryList size = 0 or: [self messageCategoryListIndex = 0]) or: [self messageCategoryList size < self messageCategoryListIndex]) ifTrue: [nil] ifFalse: [self messageCategoryList at: (self messageCategoryListIndex max: 1)]! ! !Browser methodsFor: 'system category list' stamp: 'AlainPlantec 8/26/2011 17:42'! systemCategoryListIndex: anInteger "Set the selected system category index to be anInteger. Update all other selections to be deselected." systemCategoryListIndex := anInteger. classListIndex := 0. messageCategoryListIndex := 0. messageListIndex := 0. self editSelection: ( anInteger = 0 ifTrue: [#none] ifFalse: [#newClass]). metaClassIndicated := false. self setClassOrganizer. contents := nil. self changed: #systemCategorySelectionChanged. self changed: #systemCategoryListIndex. "update my selection" self changed: #classList. self changed: #messageCategoryList. self changed: #messageList. self changed: #relabel. self contentsChanged! ! !Browser methodsFor: 'message functions' stamp: 'MarcusDenker 10/13/2013 11:17'! shiftedMessageListMenu: aMenu "Fill aMenu with the items appropriate when the shift key is held down" aMenu addStayUpItem. aMenu addList: #( ('Toggle diffing (D)' toggleDiffing) ('Implementors of sent messages' browseAllMessages) - ('Local senders of...' browseLocalSendersOfMessages) ('Local implementors of...' browseLocalImplementors) - ('Inspect instances' inspectInstances) ('Inspect subinstances' inspectSubInstances)). self addExtraShiftedItemsTo: aMenu. aMenu addList: #( - ('Change category...' changeCategory)). self canShowMultipleMessageCategories ifTrue: [aMenu addList: #(('Show category (C)' showHomeCategory))]. aMenu addList: #( - ('More...' unshiftedYellowButtonActivity)). ^ aMenu ! ! !Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:17'! updateSystemCategories "The class categories were changed in another browser. The receiver must reorganize its lists based on these changes." self okToChange ifFalse: [^ self]. self changed: #systemCategoryList! ! !Browser methodsFor: 'message category functions' stamp: 'MarcusDenker 10/7/2012 12:01'! messageCategoryMenu: aMenu ^ aMenu addList: #( ('Browse' buildMessageCategoryBrowser) ('FileOut' fileOutMessageCategories) ('Reorganize' editMessageCategories) - ('Alphabetize' alphabetizeMessageCategories) ('Remove empty categories' removeEmptyCategories) ('Categorize all uncategorized' categorizeAllUncategorizedMethods) ('New Category...' addCategory) ('Rename...' renameCategory) - ('Remove' removeMessageCategory)) ! ! !Browser methodsFor: 'class comment pane' stamp: 'AlainPlantec 8/26/2011 21:24'! noCommentNagString ^ 'Unfortunately this class has not been documented yet. The class comment should describe the purpose of the class, its collaborations and its variables. We encourage you to fill up the following template. Class intention I m doing the following ... Class collaborations I usually do not work in isolation but with the help of ... Class main API My main public API is ...My subclasses may want to override such specific hooks ... Implementation notes ' translated asText ! ! !Browser methodsFor: 'construction' stamp: 'AlainPlantec 11/17/2010 11:35'! addLowerPanesTo: window at: nominalFractions with: editString | commentPane | super addLowerPanesTo: window at: nominalFractions with: editString. commentPane := self buildMorphicCommentPane. window addMorph: commentPane fullFrame: commentPane defaultLayoutFrame. self changed: #editSelection.! ! !Browser methodsFor: 'system category functions' stamp: 'DamienCassou 9/29/2009 09:04'! addSystemCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex newName | self okToChange ifFalse: [^ self]. oldIndex := systemCategoryListIndex. newName := self request: 'Please type new category name' initialAnswer: 'Category-Name'. newName isEmptyOrNil ifTrue: [^ self] ifFalse: [newName := newName asSymbol]. systemOrganizer addCategory: newName before: (systemCategoryListIndex = 0 ifTrue: [nil] ifFalse: [self selectedSystemCategoryName]). self systemCategoryListIndex: (oldIndex = 0 ifTrue: [self systemCategoryList size] ifFalse: [oldIndex]). self changed: #systemCategoryList.! ! !Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'! indexIsOne "When used as a singleton list, index is always one" ^ 1! ! !Browser methodsFor: 'message category list' stamp: 'nk 6/13/2004 06:20'! selectMessageCategoryNamed: aSymbol "Given aSymbol, select the category with that name. Do nothing if aSymbol doesn't exist." self messageCategoryListIndex: (self messageCategoryList indexOf: aSymbol ifAbsent: [ 1])! ! !Browser methodsFor: 'metaclass' stamp: 'mir 9/25/2008 14:56'! classMessagesIndicated "Answer whether the messages to be presented should come from the metaclass." ^ self metaClassIndicated and: [self classCommentIndicated not]! ! !Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 12:25'! classCommentIndicated "Answer true iff we're viewing the class comment." ^ editSelection == #editComment ! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:07'! makeNewSubclass self selectedClassOrMetaClass ifNil: [^ self]. self okToChange ifFalse: [^ self]. self editSelection: #newClass. self contentsChanged! ! !Browser methodsFor: 'initialization' stamp: 'sw 9/22/1999 17:13'! methodCategoryChanged self changed: #messageCategoryList. self changed: #messageList. self changed: #annotation. self messageListIndex: 0! ! !Browser methodsFor: 'class functions' stamp: 'AlainPlantec 8/26/2011 21:23'! classCommentText "return the text to display for the comment of the currently selected class" | theClass | theClass := self selectedClassOrMetaClass. theClass ifNil: [ ^'']. ^ theClass hasComment ifTrue: [ theClass comment] ifFalse: [ self noCommentNagString ]! ! !Browser methodsFor: 'message category list' stamp: 'EstebanLorenzano 6/26/2013 18:08'! selectOriginalCategoryForCurrentMethod "private - Select the message category for the current method. Note: This should only be called when somebody tries to save a method that they are modifying while ALL is selected. Returns: true on success, false on failure." | aSymbol selectorName | aSymbol := self categoryOfCurrentMethod. selectorName := self selectedMessageName. (aSymbol notNil and: [aSymbol ~= AllProtocol defaultName ]) ifTrue: [messageCategoryListIndex := (self messageCategoryList indexOf: aSymbol). messageListIndex := (self messageList indexOf: selectorName). self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. self changed: #messageListIndex. ^ true]. ^ false! ! !Browser methodsFor: 'class comment pane' stamp: 'JB 2/12/2010 15:22'! classComment: aText notifying: aPluggableTextMorph "The user has just entered aText. It may be all red (a side-effect of replacing the default comment), so remove the color if it is." | theClass cleanedText redRange | theClass := self selectedClassOrMetaClass. theClass ifNotNil: [cleanedText := aText asText. redRange := cleanedText rangeOf: TextColor red startingAt: 1. redRange size = cleanedText size ifTrue: [cleanedText removeAttribute: TextColor red from: 1 to: redRange last ]. theClass comment: aText stamp: Author changeStamp]. self changed: #classCommentText. ^ true! ! !Browser methodsFor: 'initialization' stamp: 'rr 6/21/2005 13:24'! addMorphicSwitchesTo: window at: aLayoutFrame window addMorph: self buildMorphicSwitches fullFrame: aLayoutFrame. ! ! !Browser methodsFor: 'class list' stamp: 'sr 10/29/1999 20:28'! selectClass: classNotMeta self classListIndex: (self classList indexOf: classNotMeta name)! ! !Browser methodsFor: 'accessing' stamp: 'nice 3/31/2011 22:34'! doItReceiver "This class's classPool has been jimmied to be the classPool of the class being browsed. A doIt in the code pane will let the user see the value of the class variables." ^ self selectedClass! ! !Browser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! systemOrganizer: aSystemOrganizer "Initialize the receiver as a perspective on the system organizer, aSystemOrganizer. Typically there is only one--the system variable SystemOrganization." contents := nil. systemOrganizer := aSystemOrganizer. systemCategoryListIndex := 0. classListIndex := 0. messageCategoryListIndex := 0. messageListIndex := 0. metaClassIndicated := false. self setClassOrganizer. self editSelection: #none.! ! !Browser methodsFor: 'system category functions' stamp: 'DamienCassou 9/29/2009 09:05'! renameSystemCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex oldName newName | (oldIndex := systemCategoryListIndex) = 0 ifTrue: [^ self]. "no selection" self okToChange ifFalse: [^ self]. oldName := self selectedSystemCategoryName. newName := self request: 'Please type new category name' initialAnswer: oldName. newName isEmptyOrNil ifTrue: [^ self] ifFalse: [newName := newName asSymbol]. oldName = newName ifTrue: [^ self]. systemOrganizer renameCategory: oldName toBe: newName. self systemCategoryListIndex: oldIndex. self changed: #systemCategoryList.! ! !Browser methodsFor: 'message category list' stamp: ''! messageCategoryListIndex "Answer the index of the selected message category." ^messageCategoryListIndex! ! !Browser methodsFor: 'message functions' stamp: 'MarcusDenker 10/13/2013 07:59'! removeMessage "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. " | messageName confirmation | messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageName := self selectedMessageName. confirmation := self systemNavigation confirmRemovalOf: messageName on: self selectedClassOrMetaClass. confirmation = 3 ifTrue: [^ self]. (self selectedClassOrMetaClass includesLocalSelector: messageName) ifTrue: [self selectedClassOrMetaClass removeSelector: messageName] ifFalse: [self removeNonLocalSelector: messageName]. self messageListIndex: 0. self changed: #messageList. self setClassOrganizer. "In case organization not cached" confirmation = 2 ifTrue: [self systemNavigation browseAllSendersOf: messageName]! ! !Browser methodsFor: 'message functions' stamp: 'sw 1/11/2001 07:22'! addExtraShiftedItemsTo: aMenu "The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate. If any is added here, a line should be added first -- browse reimplementors of this message for examples." ! ! !Browser methodsFor: 'class functions' stamp: 'MarcusDenker 3/5/2010 14:30'! findMethod "Pop up a list of the current class's methods, and select the one chosen by the user" | aClass selectors reply cat messageCatIndex messageIndex choices | self classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. aClass := self selectedClassOrMetaClass. selectors := aClass selectors sort. selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.' translated. ^ self]. choices := (Array with: 'Enter Wildcard' translated), selectors. reply := UIManager default chooseFrom: choices lines: #(1). reply = 0 ifTrue: [^self]. reply = 1 ifTrue: [ reply := UIManager default request: 'Enter partial method name:' translated. (reply isNil or: [reply isEmpty]) ifTrue: [^self]. (reply includes: $*) ifFalse: [reply := '*', reply, '*']. selectors := selectors select: [:each | reply match: each]. selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.' translated. ^ self]. reply := selectors size = 1 ifTrue: [selectors first] ifFalse: [ UIManager default chooseFrom: selectors values: selectors]. reply isNil ifTrue: [^self]] ifFalse: [reply := choices at: reply]. cat := aClass whichCategoryIncludesSelector: reply. messageCatIndex := self messageCategoryList indexOf: cat. self messageCategoryListIndex: messageCatIndex. messageIndex := (self messageList indexOf: reply). self messageListIndex: messageIndex! ! !Browser methodsFor: 'class functions' stamp: 'StephaneDucasse 12/5/2009 21:25'! addAllMethodsToCurrentChangeSet "Add all the methods in the selected class or metaclass to the current change set. You ought to know what you're doing before you invoke this!!" | aClass | (aClass := self selectedClassOrMetaClass) ifNotNil: [aClass selectorsDo: [:sel | ChangeSet current adoptSelector: sel forClass: aClass]. self changed: #annotation] ! ! !Browser methodsFor: 'class functions' stamp: 'StephaneDucasse 5/13/2010 11:43'! createInstVarAccessors "Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class" | aClass | (aClass := self selectedClassOrMetaClass) ifNotNil: [aClass instVarNames do: [:aName | | setter newMessage | (aClass canUnderstand: aName asSymbol) ifFalse: [newMessage := aName, ' ^ ', aName. aClass compile: newMessage classified: 'accessing' notifying: nil]. (aClass canUnderstand: (setter := aName, ':') asSymbol) ifFalse: [newMessage := setter, ' anObject ', aName, ' := anObject'. aClass compile: newMessage classified: 'accessing' notifying: nil]]]! ! !Browser methodsFor: 'message list' stamp: 'MarcusDenker 4/28/2013 21:32'! selectedMessage "Answer a copy of the source code for the selected message." | class selector method | contents == nil ifFalse: [^ contents copy]. class := self selectedClassOrMetaClass. selector := self selectedMessageName. method := class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" currentCompiledMethod := method. ^ contents := self sourceStringPrettifiedAndDiffed ! ! !Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! selectedClassName | aClassList | "Answer the name of the current class. Answer nil if no selection exists." (classListIndex = 0 or: [classListIndex > (aClassList := self classList) size]) ifTrue: [^ nil]. ^ aClassList at: classListIndex! ! !Browser methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:26'! annotation "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." | aSelector aClass | (aClass := self selectedClassOrMetaClass) == nil ifTrue: [^ '------']. self editSelection == #editComment ifTrue: [^ self annotationForSelector: #Comment ofClass: aClass]. self editSelection == #editClass ifTrue: [^ self annotationForSelector: #Definition ofClass: aClass]. (aSelector := self selectedMessageName) ifNil: [^ '------']. ^ self annotationForSelector: aSelector ofClass: aClass! ! !Browser methodsFor: 'code pane' stamp: 'EstebanLorenzano 6/26/2013 18:08'! compileMessage: aText notifying: aController "Compile the code that was accepted by the user, placing the compiled method into an appropriate message category. Return true if the compilation succeeded, else false." | fallBackCategoryIndex fallBackMethodIndex originalSelectorName result | self selectedMessageCategoryName ifNil: [ self selectOriginalCategoryForCurrentMethod ifFalse:["Select the '--all--' category" self messageCategoryListIndex: 1]]. self selectedMessageCategoryName asSymbol = AllProtocol defaultName ifTrue: [ "User tried to save a method while the ALL category was selected" fallBackCategoryIndex := messageCategoryListIndex. fallBackMethodIndex := messageListIndex. editSelection == #newMessage ifTrue: [ "Select the 'as yet unclassified' category" messageCategoryListIndex := 0. (result := self defineMessageFrom: aText notifying: aController) ifNil: ["Compilation failure: reselect the original category & method" messageCategoryListIndex := fallBackCategoryIndex. messageListIndex := fallBackMethodIndex] ifNotNil: [self setSelector: result]] ifFalse: [originalSelectorName := self selectedMessageName. self setOriginalCategoryIndexForCurrentMethod. messageListIndex := fallBackMethodIndex := self messageList indexOf: originalSelectorName. (result := self defineMessageFrom: aText notifying: aController) ifNotNil: [self setSelector: result] ifNil: [ "Compilation failure: reselect the original category & method" messageCategoryListIndex := fallBackCategoryIndex. messageListIndex := fallBackMethodIndex. ^ result notNil]]. self changed: #messageCategoryList. ^ result notNil] ifFalse: [ "User tried to save a method while the ALL category was NOT selected" ^ (self defineMessageFrom: aText notifying: aController) notNil]! ! !Browser methodsFor: 'message category functions' stamp: ''! buildMessageCategoryBrowser "Create and schedule a message category browser for the currently selected message category." self buildMessageCategoryBrowserEditString: nil! ! !Browser methodsFor: 'message category functions' stamp: 'MarcusDenker 2/17/2012 15:52'! buildMessageCategoryBrowserEditString: aString "Create and schedule a message category browser for the currently selected message category. The initial text view contains the characters in aString." | newBrowser | messageCategoryListIndex ~= 0 ifTrue: [newBrowser := self class new. newBrowser systemCategoryListIndex: systemCategoryListIndex. newBrowser classListIndex: (newBrowser classList indexOf: self selectedClassName). newBrowser metaClassIndicated: metaClassIndicated. newBrowser messageCategoryListIndex: messageCategoryListIndex. newBrowser messageListIndex: messageListIndex. self class openBrowserView: (newBrowser openMessageCatEditString: aString) label: 'Message Category Browser (' , newBrowser selectedClassOrMetaClassName , ')']! ! !Browser methodsFor: 'drag and drop' stamp: 'MarcusDenker 9/28/2013 13:47'! changeCategoryForClass: class srcSystemCategory: srcSystemCategorySel atListMorph: dstListMorph internal: internal copy: copyFlag "only move semantic" | newClassCategory success | self flag: #stringSymbolProblem. success := copyFlag ifTrue: [ ^ false ]. newClassCategory := self dstCategoryDstListMorph: dstListMorph. (success := newClassCategory notNil & (newClassCategory ~= class category)) ifTrue: [ class category: newClassCategory. self changed: #classList. internal ifFalse: [ self selectClass: class ] ]. ^ success! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 6/10/2008 18:33'! openEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." ^ self openAsMorphEditing: aString! ! !Browser methodsFor: 'traits' stamp: 'al 4/24/2004 11:48'! newTrait self classListIndex: 0. self editClass. editSelection := #newTrait. self contentsChanged! ! !Browser methodsFor: 'drag and drop' stamp: 'StephaneDucasse 9/17/2011 11:20'! dragPassengerFor: item inMorph: dragSource | transferType smn | (dragSource isKindOf: PluggableListMorph) ifFalse: [^nil]. transferType := self dragTransferTypeForMorph: dragSource. transferType == #classList ifTrue: [^self selectedClass]. transferType == #messageList ifFalse: [ ^nil ]. smn := self selectedMessageName ifNil: [ ^nil ]. (Smalltalk tools messageList isPseudoSelector: smn) ifTrue: [ ^nil ]. ^ self selectedClassOrMetaClass -> smn. ! ! !Browser methodsFor: 'drag and drop' stamp: 'MarcusDenker 9/28/2013 13:47'! message: messageSel compileInClass: dstClassOrMeta fromClass: srcClassOrMeta dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel internal: internal copySemantic: copyFlag | source messageCategorySel tm success oldOrNoMethod newMethod | source := srcClassOrMeta sourceCodeAt: messageSel. messageCategorySel := dstMessageCategorySel ifNil: [ srcMessageCategorySel ]. self selectClass: dstClassOrMeta theNonMetaClass. (self messageCategoryList includes: messageCategorySel) ifFalse: [ "create message category" self classOrMetaClassOrganizer addCategory: messageCategorySel ]. self selectMessageCategoryNamed: messageCategorySel. tm := self codeTextMorph. tm setText: source. tm setSelection: (0 to: 0). tm hasUnacceptedEdits: true. oldOrNoMethod := srcClassOrMeta compiledMethodAt: messageSel ifAbsent: [ ]. tm accept. "compilation successful?" newMethod := dstClassOrMeta compiledMethodAt: messageSel ifAbsent: [ ]. success := newMethod ~~ nil & (newMethod ~~ oldOrNoMethod). " success ifFalse: [TransferMorph allInstances do: [:e | e delete]]. " success ifTrue: [ copyFlag ifFalse: [ "remove old method in move semantic if new exists" srcClassOrMeta removeSelector: messageSel ]. internal ifTrue: [ self selectClass: srcClassOrMeta ] ifFalse: [ self selectClass: dstClassOrMeta ]. self setSelector: messageSel ]. ^ success! ! !Browser methodsFor: 'message category list' stamp: 'sd 11/20/2005 21:26'! messageCatListSingleton | name | name := self selectedMessageCategoryName. ^ name ifNil: [Array new] ifNotNil: [Array with: name]! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/15/2009 09:36'! buildMorphicSystemCatList | dragNDropFlag myCatList | dragNDropFlag := true. (myCatList := PluggableListMorph new) on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #systemCategoryMenu: keystroke: #systemCatListKey:from:. myCatList enableDragNDrop: dragNDropFlag. ^myCatList ! ! !Browser methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! selectedMessageName: aSelector "Make the given selector be the selected message name" | anIndex | anIndex := self messageList indexOf: aSelector. anIndex > 0 ifTrue: [self messageListIndex: anIndex]! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:09'! hierarchy "Display the inheritance hierarchy of the receiver's selected class." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. self editSelection: #hierarchy. self changed: #editComment. self contentsChanged. ^ self! ! !Browser methodsFor: 'initialization' stamp: 'sw 1/13/2000 16:45'! defaultBrowserTitle ^ 'System Browser'! ! !Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! selectedClass "Answer the class that is currently selected. Answer nil if no selection exists." | name envt | (name := self selectedClassName) ifNil: [^ nil]. (envt := self selectedEnvironment) ifNil: [^ nil]. ^ envt at: name! ! !Browser methodsFor: 'class list' stamp: 'AlainPlantec 8/26/2011 17:54'! classListIndex: anInteger "Set anInteger to be the index of the current class selection." | className | classListIndex := anInteger. self setClassOrganizer. messageCategoryListIndex := 0. messageListIndex := 0. self classCommentIndicated ifTrue: [] ifFalse: [self editSelection: (anInteger = 0 ifTrue: [metaClassIndicated | (systemCategoryListIndex = 0) ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass])]. contents := nil. self selectedClass isNil ifFalse: [className := self selectedClass name. (RecentClasses includes: className) ifTrue: [RecentClasses remove: className]. RecentClasses addFirst: className. RecentClasses size > 16 ifTrue: [RecentClasses removeLast]]. self changed: #classSelectionChanged. self changed: #classCommentText. self changed: #classListIndex. "update my selection" self changed: #messageCategoryList. self changed: #messageList. self changed: #relabel. self contentsChanged! ! !Browser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:26'! classListSingleton | name | name := self selectedClassName. ^ name ifNil: [Array new] ifNotNil: [Array with: name]! ! !Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:20'! instanceMessagesIndicated "Answer whether the messages to be presented should come from the class." ^metaClassIndicated not and: [self classCommentIndicated not]! ! !Browser methodsFor: 'initialization' stamp: 'tbn 8/1/2010 14:06'! buildMorphicSwitches | instanceSwitch commentSwitch classSwitch row | instanceSwitch := PluggableButtonMorph on: self getState: #instanceMessagesIndicated action: #indicateInstanceMessages. instanceSwitch label: 'Instance'; askBeforeChanging: true; setBalloonText: 'Display instance side'; borderWidth: 1; borderColor: Color gray. commentSwitch := PluggableButtonMorph on: self getState: #classCommentIndicated action: #plusButtonHit. commentSwitch label: '?' asText allBold; askBeforeChanging: true; setBalloonText: 'Cycle among definition, comment, and hierachy'; borderWidth: 1; borderColor: Color gray. classSwitch := PluggableButtonMorph on: self getState: #classMessagesIndicated action: #indicateClassMessages. classSwitch label: 'Class'; askBeforeChanging: true; setBalloonText: 'Display class side'; borderWidth: 1; borderColor: Color gray. row := AlignmentMorph newRow hResizing: #spaceFill; vResizing: #spaceFill; cellInset: 0; borderWidth: 0; layoutInset: 0; addMorphBack: instanceSwitch; addMorphBack: commentSwitch; addMorphBack: classSwitch. row color: Color white. {instanceSwitch. commentSwitch. classSwitch} do: [:m | m color: Color transparent; hResizing: #spaceFill; vResizing: #spaceFill.]. ^OverflowRowMorph new baseMorph: row; height: row minExtent y ! ! !Browser methodsFor: 'message category list' stamp: 'GabrielOmarCotelli 11/30/2013 16:21'! categorizeAllUncategorizedMethods "Categorize methods by looking in parent classes for a method category." | organizer organizers | organizer := self classOrMetaClassOrganizer. organizers := self selectedClassOrMetaClass withAllSuperclasses collect: [ :ea | ea organization ]. (organizer listAtCategoryNamed: Protocol unclassified) do: [ :sel | (organizers collect: [ :org | org categoryOfElement: sel ]) detect: [ :ea | ea ~= Protocol unclassified and: [ ea ~= nil ] ] ifFound: [ :found | organizer classify: sel under: found ] ]. self changed: #messageCategoryList! ! !Browser methodsFor: 'system category functions' stamp: 'brp 8/4/2003 21:38'! alphabetizeSystemCategories self okToChange ifFalse: [^ false]. systemOrganizer sortCategories. self systemCategoryListIndex: 0. self changed: #systemCategoryList. ! ! !Browser methodsFor: 'drag and drop' stamp: 'EstebanLorenzano 6/26/2013 18:09'! dstMessageCategoryDstListMorph: dstListMorph | dropItem | ^dstListMorph getListSelector == #messageCategoryList ifTrue: [dropItem := dstListMorph potentialDropItem. dropItem ifNotNil: [dropItem asSymbol]] ifFalse: [self selectedMessageCategoryName ifNil: [ Protocol unclassified ]]! ! !Browser methodsFor: 'drag and drop' stamp: 'nice 10/22/2009 15:13'! acceptMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel dstClass: dstClass dstClassOrMeta: dstClassOrMeta srcClassOrMeta: srcClassOrMeta internal: internal copySemantic: copyFlag | success hierarchyChange higher checkForOverwrite | (success := dstClassOrMeta ~~ nil) ifFalse: [^false]. checkForOverwrite := dstClassOrMeta includesSelector: methodSel. hierarchyChange := (higher := srcClassOrMeta inheritsFrom: dstClassOrMeta) | (dstClassOrMeta inheritsFrom: srcClassOrMeta). success := (checkForOverwrite not or: [self overwriteDialogHierarchyChange: hierarchyChange higher: higher sourceClassName: srcClassOrMeta name destinationClassName: dstClassOrMeta name methodSelector: methodSel]) and: [self message: methodSel compileInClass: dstClassOrMeta fromClass: srcClassOrMeta dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel internal: internal copySemantic: copyFlag]. ^ success! ! !Browser methodsFor: 'class functions' stamp: 'sd 11/20/2005 21:26'! editComment "Retrieve the description of the class comment." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. metaClassIndicated := false. self editSelection: #editComment. self changed: #classSelectionChanged. self changed: #messageCategoryList. self changed: #messageList. self decorateButtons. self contentsChanged ! ! !Browser methodsFor: 'traits' stamp: 'al 4/24/2004 11:48'! newClass (self selectedClassOrMetaClass notNil and: [self selectedClassOrMetaClass isTrait]) ifTrue: [self classListIndex: 0]. self editClass. editSelection := #newClass. self contentsChanged! ! !Browser methodsFor: 'message list' stamp: 'AlainPlantec 8/26/2011 17:52'! messageListIndex: anInteger "Set the selected message selector to be the one indexed by anInteger." messageListIndex := anInteger. self editSelection: (anInteger > 0 ifTrue: [#editMessage] ifFalse: [self messageCategoryListIndex > 0 ifTrue: [#newMessage] ifFalse: [self classListIndex > 0 ifTrue: [#editClass] ifFalse: [#newClass]]]). contents := nil. self changed: #messageListIndex. "update my selection" self contentsChanged. self decorateButtons. self changed: #relabel.! ! !Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:55'! removeSystemCategory "If a class category is selected, create a Confirmer so the user can verify that the currently selected class category and all of its classes should be removed from the system. If so, remove it." systemCategoryListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (self classList size = 0 or: [self confirm: 'Are you sure you want to remove this system category and all its classes?']) ifTrue: [systemOrganizer removeSystemCategory: self selectedSystemCategoryName. self systemCategoryListIndex: 0. self changed: #systemCategoryList]! ! !Browser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! setClass: aBehavior selector: aSymbol "Set the state of a new, uninitialized Browser." | isMeta aClass messageCatIndex | aBehavior ifNil: [^ self]. (aBehavior isKindOf: Metaclass) ifTrue: [ isMeta := true. aClass := aBehavior soleInstance] ifFalse: [ isMeta := false. aClass := aBehavior]. self selectCategoryForClass: aClass. self classListIndex: ( (systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: aClass name). self metaClassIndicated: isMeta. aSymbol ifNil: [^ self]. messageCatIndex := aBehavior organization numberOfCategoryOfElement: aSymbol. self messageCategoryListIndex: (messageCatIndex > 0 ifTrue: [messageCatIndex + 1] ifFalse: [0]). messageCatIndex = 0 ifTrue: [^ self]. self messageListIndex: ( (aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol).! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/15/2004 13:23'! editClass "Retrieve the description of the class definition." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. self editSelection: #editClass. self changed: #contents. self changed: #classCommentText. ! ! !Browser methodsFor: 'class functions' stamp: 'MartinDias 6/24/2013 15:27'! renameClass | oldName newName obs okToRename | classListIndex = 0 ifTrue: [ ^ self ]. self okToChange ifFalse: [ ^ self ]. oldName := self selectedClass name. newName := self request: 'Please type new class name' initialAnswer: oldName. newName isEmptyOrNil ifTrue: [ ^ self ]. "Cancel returns ''" newName := newName asSymbol. newName = oldName ifTrue: [ ^ self ]. (Smalltalk globals includesKey: newName) ifTrue: [ ^ self inform: newName , ' already exists' ]. okToRename := [self selectedClass classBuilder validateClassName: newName] on: Error do: [ :ex | ^ self inform: ex printString]. okToRename ifTrue: [ self selectedClass rename: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). obs := self systemNavigation allReferencesTo: (self selectedClass environment associationAt: newName). obs isEmpty ifFalse: [ self systemNavigation browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName ]]! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 6/10/2008 18:34'! openMessageCatEditString: aString "Create a pluggable version of the views for a Browser that just shows one message category." ^ self openAsMorphMsgCatEditing: aString! ! !Browser methodsFor: 'initialization' stamp: 'MarcusDenker 9/30/2013 20:03'! openAsMorphEditing: editString "Create a pluggable version of all the morphs for a Browser in Morphic" | window hSepFrac | hSepFrac := 0.4. window := (SystemWindow labelled: 'later') model: self. window addMorph: self buildMorphicSystemCatList frame: (0@0 corner: 0.25@hSepFrac). self addClassAndSwitchesTo: window at: (0.25@0 corner: 0.5@hSepFrac) plus: 0. window addMorph: self buildMorphicMessageCatList frame: (0.5@0 extent: 0.25@hSepFrac). window addMorph: self buildMorphicMessageList frame: (0.75@0 extent: 0.25@hSepFrac). self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'class functions' stamp: 'MartinDias 6/24/2013 15:27'! copyClass | copysName nameOk | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. copysName := self request: 'Please type new class name' initialAnswer: self selectedClass name. copysName isEmptyOrNil ifTrue: [^ self]. nameOk := [self selectedClass classBuilder validateClassName: copysName asSymbol] on: Error do: [ :ex | ^ self inform: ex printString]. nameOk ifTrue: [ "Cancel returns ''" self selectedClass duplicateClassWithNewName: copysName. self classListIndex: 0. self changed: #classList]! ! !Browser methodsFor: 'class functions' stamp: 'AlainPlantec 11/25/2010 09:27'! fileOutClass "Print a description of the selected class onto a file whose name is the category name followed by .st." Cursor write showWhile: [classListIndex ~= 0 ifTrue: [self selectedClass fileOut]]! ! !Browser methodsFor: 'metaclass' stamp: 'AlainPlantec 8/26/2011 17:42'! indicateClassMessages "Indicate that the message selection should come from the metaclass messages." self metaClassIndicated: true! ! !Browser methodsFor: 'class functions' stamp: 'MarcusDenker 4/21/2011 22:27'! shiftedClassListMenu: aMenu "Set up the menu to apply to the receiver's class list when the shift key is down" ^ aMenu addList: #( - ('Unsent methods' browseUnusedMethods 'Browse all methods defined by this class that have no senders') ('Unreferenced inst vars' showUnreferencedInstVars 'Show a list of all instance variables that are not referenced in methods') ('Unreferenced class vars' showUnreferencedClassVars 'Show a list of all class variables that are not referenced in methods') ('Subclass template' makeNewSubclass 'Put a template into the code pane for defining of a subclass of this class') - ('Inspect instances' inspectInstances 'Open an inspector on all the extant instances of this class') ('Inspect subinstances' inspectSubInstances 'Open an inspector on all the extant instances of this class and of all of its subclasses') - ('Add all meths to current chgs' addAllMethodsToCurrentChangeSet 'Place all the methods defined by this class into the current change set') ('Create inst var accessors' createInstVarAccessors 'Compile instance-variable access methods for any instance variables that do not yet have them') - ('More...' offerUnshiftedClassListMenu 'Return to the standard class-list menu'))! ! !Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:56'! changeMessageCategories: aString "The characters in aString represent an edited version of the the message categories for the selected class. Update this information in the system and inform any dependents that the categories have been changed. This message is invoked because the user had issued the categories command and edited the message categories. Then the user issued the accept command." self classOrMetaClassOrganizer changeFromString: aString. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message functions' stamp: 'MarcusDenker 7/13/2012 23:51'! messageListMenu: aMenu shifted: shifted "Answer the message-list menu" shifted ifTrue: [^ self shiftedMessageListMenu: aMenu]. aMenu addList: #( ('What to show...' offerWhatToShowMenu) ('Toggle break on entry' toggleBreakOnEntry) - ('Browse full (b)' browseMethodFull) ('Browse hierarchy (h)' classHierarchy) - ('FileOut' fileOutMessage) - ('Senders of... (n)' browseSendersOfMessages) ('Implementors of... (m)' browseMessages) ('Inheritance (i)' methodHierarchy) ('Versions (v)' browseVersions) - ('Inst var refs...' browseInstVarRefs) ('Inst var defs...' browseInstVarDefs) ('Class var refs...' browseClassVarRefs) ('Class variables' browseClassVariables) ('Class refs (N)' browseClassRefs) - ('Remove method (x)' removeMessage) - ('More...' shiftedYellowButtonActivity)). ^ aMenu! ! !Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'! indexIsOne: value "When used as a singleton list, can't change it" ^ self! ! !Browser methodsFor: 'message category functions' stamp: 'nk 2/14/2004 15:06'! editMessageCategories "Indicate to the receiver and its dependents that the message categories of the selected class have been changed." self okToChange ifFalse: [^ self]. classListIndex ~= 0 ifTrue: [self messageCategoryListIndex: 0. self editSelection: #editMessageCategories. self changed: #editMessageCategories. self contentsChanged]! ! !Browser methodsFor: 'class functions' stamp: 'eem 5/7/2008 12:04'! classDefinitionText "return the text to display for the definition of the currently selected class" | theClass | ^(theClass := self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass definition]! ! !Browser methodsFor: 'message category list' stamp: ''! selectedMessageCategoryName "Answer the name of the selected message category, if any. Answer nil otherwise." messageCategoryListIndex = 0 ifTrue: [^nil]. ^self messageCategoryList at: messageCategoryListIndex! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/30/2008 10:16'! openSystemCatEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers. The top list view is of the currently selected system class category--a single item list." ^ self openAsMorphSysCatEditing: aString! ! !Browser methodsFor: 'initialization' stamp: 'StephaneDucasse 8/5/2013 22:39'! openAsMorphClassEditing: editString "Create a pluggable version a Browser on just a single class." | window dragNDropFlag hSepFrac switchHeight mySingletonClassList | window := (SystemWindow labelled: 'later') model: self. dragNDropFlag := true. hSepFrac := 0.3. switchHeight := 25. mySingletonClassList := PluggableListMorph on: self list: #classListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #classListMenu:shifted: keystroke: #classListKey:from:. mySingletonClassList enableDragNDrop: dragNDropFlag. self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window addMorph: mySingletonClassList fullFrame: ((0@0 corner: 0.5@0) asLayoutFrame bottomOffset: switchHeight). self addMorphicSwitchesTo: window at: ((0.5@0 corner: 1.0@0) asLayoutFrame bottomOffset: switchHeight). window addMorph: self buildMorphicMessageCatList fullFrame: ((0@0 corner: 0.5@hSepFrac) asLayoutFrame topOffset: switchHeight). window addMorph: self buildMorphicMessageList fullFrame: ((0.5@0 corner: 1.0@hSepFrac) asLayoutFrame topOffset: switchHeight). window setUpdatablePanesFrom: #(messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'class comment pane' stamp: 'AlainPlantec 1/7/2010 21:39'! buildMorphicCommentPane "Construct the pane that shows the class comment. Respect the setting StandardFonts codeFont." | commentPane | commentPane := BrowserCommentTextMorph on: self text: #classCommentText accept: #classComment:notifying: readSelection: nil menu: #codePaneMenu:shifted:. commentPane font: StandardFonts codeFont. ^ commentPane! ! !Browser methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:18'! dragTransferTypeForMorph: dragSource ^(dragSource isKindOf: PluggableListMorph) ifTrue: [dragSource getListSelector]! ! !Browser methodsFor: 'metaclass' stamp: 'StephaneDucasse 2/12/2011 14:15'! classOrMetaClassOrganizer "Answer the class organizer for the metaclass or class, depending on which (instance or class) is indicated." ^ self metaClassIndicated ifTrue: [ metaClassOrganizer] ifFalse: [ classOrganizer]! ! !Browser methodsFor: 'class list' stamp: ''! classList "Answer an array of the class names of the selected category. Answer an empty array if no selection exists." systemCategoryListIndex = 0 ifTrue: [^Array new] ifFalse: [^systemOrganizer listAtCategoryNumber: systemCategoryListIndex]! ! !Browser methodsFor: 'system category functions' stamp: ''! buildSystemCategoryBrowser "Create and schedule a new system category browser." self buildSystemCategoryBrowserEditString: nil! ! !Browser methodsFor: 'message category functions' stamp: 'StephaneDucasse 8/29/2013 21:04'! removeMessageCategory "If a message category is selected, create a Confirmer so the user can verify that the currently selected message category should be removed from the system. If so, remove it." | messageCategoryName | messageCategoryListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageCategoryName := self selectedMessageCategoryName. (self messageList isEmpty or: [self confirm: 'Are you sure you want to remove this method category and all its methods?']) ifTrue: [self selectedClassOrMetaClass removeProtocol: messageCategoryName. self messageCategoryListIndex: 0. self changed: #classSelectionChanged]. self changed: #messageCategoryList. ! ! !Browser methodsFor: 'accessing' stamp: 'JB 2/12/2010 15:22'! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | self changed: #annotation. aString := input asString. aText := input asText. editSelection == #newTrait ifTrue: [^self defineTrait: input asString notifying: aController]. editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString]. editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController]. editSelection == #editComment ifTrue: [theClass := self selectedClass. theClass ifNil: [self inform: 'You must select a class before giving it a comment.'. ^ false]. theClass comment: aText stamp: Author changeStamp. self changed: #classCommentText. ^ true]. editSelection == #hierarchy ifTrue: [^ true]. editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. editSelection == #editMessage | (editSelection == #newMessage) ifTrue: [^ self okayToAccept ifFalse: [false] ifTrue: [self compileMessage: aText notifying: aController]]. editSelection == #none ifTrue: [self inform: 'This text cannot be accepted in this part of the browser.'. ^ false]. self error: 'unacceptable accept'! ! !Browser methodsFor: 'copying' stamp: 'sd 11/20/2005 21:26'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. See DeepCopier class comment." super veryDeepInner: deepCopier. "systemOrganizer := systemOrganizer. clone has the old value. we share it" "classOrganizer := classOrganizer clone has the old value. we share it" "metaClassOrganizer := metaClassOrganizer clone has the old value. we share it" systemCategoryListIndex := systemCategoryListIndex veryDeepCopyWith: deepCopier. classListIndex := classListIndex veryDeepCopyWith: deepCopier. messageCategoryListIndex := messageCategoryListIndex veryDeepCopyWith: deepCopier. messageListIndex := messageListIndex veryDeepCopyWith: deepCopier. editSelection := editSelection veryDeepCopyWith: deepCopier. metaClassIndicated := metaClassIndicated veryDeepCopyWith: deepCopier. ! ! !Browser methodsFor: 'system category functions' stamp: 'MarcusDenker 10/7/2012 12:03'! systemCategoryMenu: aMenu ^ aMenu addList: #( ('Find Class... (f)' findClass) ('Browse' buildSystemCategoryBrowser) - ('FileOut' fileOutSystemCategory) ('Reorganize' editSystemCategories) - ('Alphabetize' alphabetizeSystemCategories) ('Update' updateSystemCategories) - ('Add Category...' addSystemCategory) ('Rename...' renameSystemCategory) - ('Remove' removeSystemCategory))! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/15/2009 09:36'! buildMorphicClassList | myClassList | (myClassList := PluggableListMorph new) on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:shifted: keystroke: #classListKey:from:. myClassList borderWidth: 0. myClassList enableDragNDrop: true. myClassList doubleClickSelector: #browseSelectionInPlace. "For doubleClick to work best disable autoDeselect" myClassList autoDeselect: false . ^myClassList ! ! !Browser methodsFor: 'message category functions' stamp: 'sd 11/20/2005 21:26'! showHomeCategory "Show the home category of the selected method. This is only really useful if one is in a tool that supports the showing of categories. Thus, it's good in browsers and hierarchy browsers but not in message-list browsers" | aSelector | self okToChange ifTrue: [(aSelector := self selectedMessageName) ifNotNil: [self selectOriginalCategoryForCurrentMethod. self selectedMessageName: aSelector]]! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/30/2008 10:13'! openOnClassWithEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." ^ self openAsMorphClassEditing: aString. ! ! !Browser methodsFor: 'traits' stamp: 'MarcusDenker 8/28/2013 10:52'! defineTrait: defString notifying: aController | defTokens keywdIx envt oldTrait newTraitName trait | oldTrait := self selectedClassOrMetaClass. defTokens := defString findTokens: Character separators. keywdIx := defTokens findFirst: [:x | x = 'category']. envt := self selectedEnvironment. keywdIx := defTokens findFirst: [:x | x = 'named:']. newTraitName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldTrait isNil or: [oldTrait baseTrait name asString ~= newTraitName]) and: [envt includesKey: newTraitName asSymbol]) ifTrue: ["Attempting to define new class/trait over existing one when not looking at the original one in this browser..." (self confirm: ((newTraitName , ' is an existing class/trait in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newTraitName size)) ifFalse: [^ false]]. trait := self class compiler source: defString; requestor: aController; logged: true; evaluate. ^(trait isKindOf: TraitBehavior) ifTrue: [ self changed: #classList. self classListIndex: (self classList indexOf: trait baseTrait name). self clearUserEditFlag; editClass. true] ifFalse: [ false ] ! ! !Browser methodsFor: 'message functions' stamp: 'EstebanLorenzano 6/26/2013 18:01'! defineMessageFrom: aString notifying: aController "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise." | selectedMessageName selector category oldMessageList | selectedMessageName := self selectedMessageName. oldMessageList := self messageList. contents := nil. selector := self selectedClassOrMetaClass compile: aString classified: (category := self selectedMessageCategoryName) notifying: aController. selector == nil ifTrue: [^ nil]. contents := aString copy. selector ~~ selectedMessageName ifTrue: [category = Protocol nullCategory ifTrue: [self changed: #classSelectionChanged. self changed: #classList. self messageCategoryListIndex: 1]. self setClassOrganizer. "In case organization not cached" (oldMessageList includes: selector) ifFalse: [self changed: #messageList]. self messageListIndex: (self messageList indexOf: selector)]. ^ selector! ! !Browser methodsFor: 'accessing' stamp: 'tak 9/25/2008 14:58'! contentsSelection "Return the interval of text in the code pane to select when I set the pane's contents" messageCategoryListIndex > 0 & (messageListIndex = 0) ifTrue: [^ 1 to: 500] "entire empty method template" ifFalse: [^ 1 to: 0] "null selection"! ! !Browser methodsFor: 'system category functions' stamp: 'MarcusDenker 10/15/2013 18:09'! findClass "Search for a class from a pattern or from the recent list" | foundClassOrTrait | self okToChange ifFalse: [^ self classNotFound]. foundClassOrTrait := SearchFacade classSearch chooseFromOwner: self dependents first. foundClassOrTrait ifNil: [^ self classNotFound]. self selectCategoryForClass: foundClassOrTrait. self selectClass: foundClassOrTrait ! ! !Browser methodsFor: 'traits' stamp: 'lr 3/14/2010 21:13'! addTrait | input trait | input := UIManager default request: 'add trait'. input isEmptyOrNil ifFalse: [ trait := Smalltalk globals classNamed: input. (trait isNil or: [ trait isTrait not ]) ifTrue: [ ^ self inform: 'Input invalid. ' , input , ' does not exist or is not a trait' ]. self selectedClass addToComposition: trait. self contentsChanged ]! ! !Browser methodsFor: 'initialization' stamp: 'StephaneDucasse 12/19/2012 16:26'! openAsMorphMsgCatEditing: editString "Create a pluggable version a Browser on just a message category." | window hSepFrac | window := (SystemWindow labelled: 'later') model: self. hSepFrac := 0.3. window addMorph: ((PluggableListMorph on: self list: #messageCatListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #messageCategoryMenu:) enableDragNDrop: true) fullFrame: ( (0@0 corner: 1@0) asLayoutFrame bottomOffset: 25). window addMorph: self buildMorphicMessageList fullFrame: ((0@0 corner: 1@hSepFrac) asLayoutFrame topOffset: 0@25). self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window setUpdatablePanesFrom: #(messageCatListSingleton messageList). ^ window! ! !Browser methodsFor: 'message functions' stamp: 'CamilloBruni 8/1/2012 16:10'! inspectSubInstances "Inspect all instances of the selected class and all its subclasses" | aClass | ((aClass := self selectedClassOrMetaClass) isNil or: [aClass isTrait]) ifFalse: [ aClass := aClass theNonMetaClass. aClass inspectSubInstances]. ! ! !Browser methodsFor: 'system category list' stamp: 'md 3/3/2006 11:02'! selectedEnvironment "Answer the name of the selected system category or nil." systemCategoryListIndex = 0 ifTrue: [^nil]. ^ Smalltalk! ! !Browser methodsFor: 'class functions' stamp: 'AlainPlantec 8/26/2011 17:55'! plusButtonHit "Cycle among definition, comment, and hierachy" editSelection == #editComment ifTrue: [self hierarchy. ^ self]. editSelection == #hierarchy ifTrue: [self editSelection: #editClass. classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self changed: #editComment. self contentsChanged. ^ self]. self editComment! ! !Browser methodsFor: 'class functions' stamp: 'MarcusDenker 8/28/2013 16:05'! defineClass: defString notifying: aController "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class newClassName defTokens keywdIx envt | oldClass := self selectedClassOrMetaClass. defTokens := defString findTokens: Character separators. ((defTokens first = 'Trait' and: [defTokens second = 'named:']) or: [defTokens second = 'classTrait']) ifTrue: [^self defineTrait: defString notifying: aController]. keywdIx := defTokens findFirst: [:x | x beginsWith: 'category']. envt := Smalltalk globals. keywdIx := defTokens findFirst: [:x | '*subclass*' match: x]. newClassName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName]) and: [envt includesKey: newClassName asSymbol]) ifTrue: ["Attempting to define new class over existing one when not looking at the original one in this browser..." (self confirm: ((newClassName , ' is an existing class in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) ifFalse: [^ false]]. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass := oldClass superclass]. class := oldClass subclassDefinerClass new source: defString; requestor: aController; logged: true; evaluate. (class isKindOf: Behavior) ifTrue: [self changed: #systemCategoryList. self changed: #classList. self clearUserEditFlag. self setClass: class selector: nil. "self clearUserEditFlag; editClass." ^ true] ifFalse: [^ false]! ! !Browser methodsFor: 'drag and drop' stamp: 'MarcusDenker 3/26/2010 16:48'! destinationClassDestinationListMorph: dstListMorph | dropItem | ^ dstListMorph getListSelector == #classList ifTrue: [ (dropItem := dstListMorph potentialDropItem) ifNotNil: [ Smalltalk globals at: dropItem withBlanksCondensed asSymbol ] ] ifFalse: [ dstListMorph model selectedClass ]! ! !Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:21'! changeSystemCategories: aString "Update the class categories by parsing the argument aString." systemOrganizer changeFromString: aString. self changed: #systemCategoryList. ^ true! ! !Browser methodsFor: 'message list' stamp: 'sd 11/20/2005 21:26'! selectedMessageName "Answer the message selector of the currently selected message, if any. Answer nil otherwise." | aList | messageListIndex = 0 ifTrue: [^ nil]. ^ (aList := self messageList) size >= messageListIndex ifTrue: [aList at: messageListIndex] ifFalse: [nil]! ! !Browser methodsFor: 'system category list' stamp: 'sd 11/20/2005 21:26'! systemCategorySingleton | cat | cat := self selectedSystemCategoryName. ^ cat ifNil: [Array new] ifNotNil: [Array with: cat]! ! !Browser methodsFor: 'system category list' stamp: ''! systemCategoryList "Answer the class categories modelled by the receiver." ^systemOrganizer categories! ! !Browser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:26'! setSelector: aSymbol "Make the receiver point at the given selector, in the currently chosen class" | aClass messageCatIndex | aSymbol ifNil: [^ self]. (aClass := self selectedClassOrMetaClass) ifNil: [^ self]. messageCatIndex := aClass organization numberOfCategoryOfElement: aSymbol. self messageCategoryListIndex: messageCatIndex + 1. messageCatIndex = 0 ifTrue: [^ self]. self messageListIndex: ((aClass organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)! ! !Browser methodsFor: 'system category list' stamp: 'stp 01/13/2000 12:25'! selectCategoryForClass: theClass self systemCategoryListIndex: (self systemCategoryList indexOf: theClass category) ! ! !Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:03'! removeMessageFromBrowser "Our list speaks the truth and can't have arbitrary things removed" ^ self changed: #flash! ! !Browser methodsFor: 'initialization' stamp: 'RAA 1/10/2001 11:46'! addClassAndSwitchesTo: window at: nominalFractions plus: verticalOffset ^self addAListPane: self buildMorphicClassList to: window at: nominalFractions plus: verticalOffset ! ! !Browser methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:10'! canShowMultipleMessageCategories "Answer whether the receiver is capable of showing multiple message categories" ^ true! ! !Browser methodsFor: 'traits' stamp: 'jannik.laval 5/1/2010 16:00'! removeNonLocalSelector: aSymbol | traits isAlias | traits := self selectedClassOrMetaClass traitsProvidingSelector: aSymbol. isAlias := self selectedClassOrMetaClass isLocalAliasSelector: aSymbol. isAlias ifTrue: [ [traits size = 1] assert. self selectedClassOrMetaClass removeAlias: aSymbol of: traits first] ifFalse: [ traits do: [:each | self selectedClassOrMetaClass addExclusionOf: aSymbol to: each ]] ! ! !Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! wantsDroppedMorph: transferMorph event: anEvent inMorph: destinationLM "We are only interested in TransferMorphs as wrappers for informations. If their content is really interesting for us, will determined later in >>acceptDroppingMorph:event:." | srcType dstType | "only want drops on lists (not, for example, on pluggable texts)" (destinationLM isKindOf: PluggableListMorph) ifFalse: [^ false]. srcType := transferMorph dragTransferType. dstType := destinationLM getListSelector. (srcType == #messageList and: [dstType == #messageCategoryList or: [dstType == #classList]]) ifTrue: [^true]. (srcType == #classList and: [dstType == #systemCategoryList]) ifTrue: [^true]. " [ srcLS == #messageList ifTrue: [^ dstLS == #messageList | (dstLS == #messageCategoryList) | (dstLS == #classList)]. srcLS == #classList ifTrue: [^ dstLS == #classList | (dstLS == #systemCategoryList)]]. " ^ false! ! !Browser methodsFor: 'message list' stamp: 'sw 12/1/2000 11:17'! reformulateList "If the receiver has a way of reformulating its message list, here is a chance for it to do so" super reformulateList. self messageListIndex: 0! ! !Browser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! editSelection: aSelection "Set the editSelection as requested." editSelection := aSelection. self changed: #editSelection.! ! !Browser methodsFor: 'class functions' stamp: 'MarcusDenker 3/5/2010 14:30'! findMethodWithWildcard "Pop up a list of the current class's methods, and select the one chosen by the user" | aClass selectors reply cat messageCatIndex messageIndex | self classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. aClass := self selectedClassOrMetaClass. selectors := aClass selectors sort. selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.' translated. ^ self]. reply := UIManager default request: 'Enter partial method name:' translated. (reply isNil or: [reply isEmpty]) ifTrue: [^self]. (reply includes: $*) ifFalse: [reply := '*', reply, '*']. selectors := selectors select: [:each | reply match: each]. selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.'. ^ self]. reply := selectors size = 1 ifTrue: [selectors first] ifFalse: [UIManager default chooseFrom: selectors values: selectors]. reply == nil ifTrue: [^ self]. cat := aClass whichCategoryIncludesSelector: reply. messageCatIndex := self messageCategoryList indexOf: cat. self messageCategoryListIndex: messageCatIndex. messageIndex := (self messageList indexOf: reply). self messageListIndex: messageIndex! ! !Browser methodsFor: 'drag and drop' stamp: 'EstebanLorenzano 6/26/2013 18:08'! changeMessageCategoryForMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel insideClassOrMeta: classOrMeta internal: internal copySemantic: copyFlag "Recategorize the method named by methodSel. If the dstMessageCategorySel is the allCategory, then recategorize it from its parents." | success messageCategorySel | copyFlag ifTrue: [^ false]. "only move semantic" messageCategorySel := dstMessageCategorySel ifNil: [srcMessageCategorySel]. (success := messageCategorySel notNil and: [messageCategorySel ~= srcMessageCategorySel]) ifTrue: [success := messageCategorySel == AllProtocol defaultName ifTrue: [self recategorizeMethodSelector: methodSel] ifFalse: [(classOrMeta organization categories includes: messageCategorySel) and: [classOrMeta organization classify: methodSel under: messageCategorySel suppressIfDefault: false. true]]]. success ifTrue: [self changed: #messageList. internal ifFalse: [self setSelector: methodSel]]. ^ success! ! !Browser methodsFor: 'class functions' stamp: 'sw 3/5/2001 18:04'! removeClass "If the user confirms the wish to delete the class, do so" super removeClass ifTrue: [self classListIndex: 0]! ! !Browser methodsFor: 'initialization' stamp: 'rww 8/18/2002 09:31'! browseSelectionInPlace "In place code - incomplete" " self systemCategoryListIndex: (self systemCategoryList indexOf: self selectedClass category). self classListIndex: (self classList indexOf: self selectedClass name)" self spawnHierarchy.! ! !Browser methodsFor: 'message category functions' stamp: 'nk 4/23/2004 09:18'! removeEmptyCategories self okToChange ifFalse: [^ self]. self selectedClassOrMetaClass organization removeEmptyCategories. self changed: #messageCategoryList ! ! !Browser methodsFor: 'initialization' stamp: 'IgorStasenko 12/20/2012 14:39'! addAListPane: aListPane to: window at: nominalFractions plus: verticalOffset | row switchHeight | row := AlignmentMorph newColumn hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 1; layoutPolicy: ProportionalLayout new. switchHeight := StandardFonts buttonFont height + 12. self addMorphicSwitchesTo: row at: ((0@1 corner: 1@1) asLayoutFrame topOffset: switchHeight negated). row addMorph: aListPane fullFrame: (LayoutFrame identity bottomOffset: switchHeight negated). window addMorph: row fullFrame: (nominalFractions asLayoutFrame topOffset: verticalOffset). row on: #mouseEnter send: #paneTransition: to: window. row on: #mouseLeave send: #paneTransition: to: window. ! ! !Browser methodsFor: 'message functions' stamp: 'CamilloBruni 8/1/2012 16:10'! inspectInstances "Inspect all instances of the selected class." | myClass | ((myClass := self selectedClassOrMetaClass) isNil or: [myClass isTrait]) ifFalse: [myClass theNonMetaClass inspectAllInstances] ! ! !Browser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 4/24/2012 15:05'! buildMorphicMessageCatList | myMessageCatList | (myMessageCatList := PluggableListMorph new) on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu: keystroke: #arrowKey:from:. myMessageCatList enableDragNDrop: true. ^myMessageCatList ! ! !Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:43'! classNotFound self changed: #flash.! ! !Browser methodsFor: 'system category functions' stamp: 'tk 3/31/98 07:52'! fileOutSystemCategory "Print a description of each class in the selected category onto a file whose name is the category name followed by .st." systemCategoryListIndex ~= 0 ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName]! ! !Browser methodsFor: 'drag and drop' stamp: 'MarcusDenker 3/26/2010 16:49'! acceptMethod: methodSel messageCategory: srcMessageCategorySel class: srcClassOrMeta atListMorph: dstListMorph internal: internal copy: copyFlag | success dstClassOrMeta dstClass dstMessageCategorySel | dstClass := self destinationClassDestinationListMorph: dstListMorph. dstClassOrMeta := dstClass ifNotNil: [self metaClassIndicated ifTrue: [dstClass classSide] ifFalse: [dstClass]]. dstMessageCategorySel := self dstMessageCategoryDstListMorph: dstListMorph. success := (dstClassOrMeta notNil and: [dstClassOrMeta == srcClassOrMeta]) ifTrue: ["one class" self changeMessageCategoryForMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel insideClassOrMeta: dstClassOrMeta internal: internal copySemantic: copyFlag] ifFalse: ["different classes" self acceptMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel dstClass: dstClass dstClassOrMeta: dstClassOrMeta srcClassOrMeta: srcClassOrMeta internal: internal copySemantic: copyFlag]. ^ success! ! !Browser methodsFor: 'initialization' stamp: 'alain.plantec 5/15/2009 09:36'! buildMorphicMessageList "Build a morphic message list, with #messageList as its list-getter" | aListMorph | (aListMorph := PluggableListMorph new) on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. aListMorph enableDragNDrop: true. aListMorph menuTitleSelector: #messageListSelectorTitle. ^aListMorph ! ! !Browser methodsFor: 'system category list' stamp: ''! systemCategoryListIndex "Answer the index of the selected class category." ^systemCategoryListIndex! ! !Browser methodsFor: 'code pane' stamp: 'AlainPlantec 1/7/2010 21:06'! codePaneMenu: aMenu shifted: shifted super codePaneMenu: aMenu shifted: shifted. ^ aMenu! ! !Browser methodsFor: 'metaclass' stamp: ''! selectedClassOrMetaClassName "Answer the selected class name or metaclass name." ^self selectedClassOrMetaClass name! ! !Browser methodsFor: 'message category functions' stamp: 'MarcusDenker 9/28/2013 13:46'! addCategory "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | labels reject lines oldIndex newName | self okToChange ifFalse: [ ^ self ]. classListIndex = 0 ifTrue: [ ^ self ]. labels := OrderedCollection new. reject := Set new. reject addAll: self selectedClassOrMetaClass organization categories; add: Protocol nullCategory; add: Protocol unclassified. lines := OrderedCollection new. self selectedClassOrMetaClass allSuperclasses do: [ :cls | | cats | cls = Object ifFalse: [ cats := cls organization categories reject: [ :cat | reject includes: cat ]. cats isEmpty ifFalse: [ lines add: labels size. labels addAll: cats. reject addAll: cats ] ] ]. newName := UIManager default chooseOrRequestFrom: labels lines: lines title: 'Add Category'. newName ifNil: [ ^ self ]. newName := newName asSymbol. oldIndex := messageCategoryListIndex. self classOrMetaClassOrganizer addCategory: newName before: (messageCategoryListIndex = 0 ifTrue: [ nil ] ifFalse: [ self selectedMessageCategoryName ]). self changed: #messageCategoryList. self messageCategoryListIndex: (oldIndex = 0 ifTrue: [ self classOrMetaClassOrganizer categories size + 1 ] ifFalse: [ oldIndex ]). self changed: #messageCategoryList! ! !Browser methodsFor: 'metaclass' stamp: 'sr 6/21/2000 17:23'! metaClassIndicated "Answer the boolean flag that indicates which of the method dictionaries, class or metaclass." ^ metaClassIndicated! ! !Browser methodsFor: 'message category functions' stamp: 'EstebanLorenzano 6/26/2013 18:08'! categoryOfCurrentMethod "Determine the method category associated with the receiver at the current moment, or nil if none" | aCategory | ^ super categoryOfCurrentMethod ifNil: [(aCategory := self messageCategoryListSelection) == AllProtocol defaultName ifTrue: [nil] ifFalse: [aCategory]]! ! !Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'! fileOutMessageCategories "Print a description of the selected message category of the selected class onto an external file." Cursor write showWhile: [messageCategoryListIndex ~= 0 ifTrue: [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]]! ! !Browser methodsFor: 'system category functions' stamp: 'nk 2/14/2004 15:09'! editSystemCategories "Retrieve the description of the class categories of the system organizer." self okToChange ifFalse: [^ self]. self systemCategoryListIndex: 0. self editSelection: #editSystemCategories. self changed: #editSystemCategories. self contentsChanged! ! !Browser methodsFor: 'system category list' stamp: ''! selectedSystemCategoryName "Answer the name of the selected system category or nil." systemCategoryListIndex = 0 ifTrue: [^nil]. ^self systemCategoryList at: systemCategoryListIndex! ! !Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:47'! alphabetizeMessageCategories classListIndex = 0 ifTrue: [^ false]. self okToChange ifFalse: [^ false]. self classOrMetaClassOrganizer sortCategories. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'initialization' stamp: 'sw 11/8/1999 13:36'! systemCatSingletonKey: aChar from: aView ^ self messageListKey: aChar from: aView! ! !Browser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! noteSelectionIndex: anInteger for: aSymbol aSymbol == #systemCategoryList ifTrue: [systemCategoryListIndex := anInteger]. aSymbol == #classList ifTrue: [classListIndex := anInteger]. aSymbol == #messageCategoryList ifTrue: [messageCategoryListIndex := anInteger]. aSymbol == #messageList ifTrue: [messageListIndex := anInteger].! ! !Browser methodsFor: 'class list' stamp: 'onierstrasz 11/11/2013 12:24'! recent "Let the user select from a list of recently visited classes. 11/96 stp. 12/96 di: use class name, not classes themselves. : dont fall into debugger in empty case" | className class recentList | recentList := RecentClasses select: [ :n | Smalltalk globals includesKey: n ]. recentList size = 0 ifTrue: [ ^ self inform: 'No recent classes found' ]. className := UIManager default chooseFrom: recentList values: recentList. className isNil ifTrue: [ ^ self ]. class := Smalltalk globals at: className. self selectCategoryForClass: class. self classListIndex: (self classList indexOf: class name)! ! !Browser methodsFor: 'message category functions' stamp: 'DamienCassou 9/29/2009 09:05'! renameCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex oldName newName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (oldIndex := messageCategoryListIndex) = 0 ifTrue: [^ self]. oldName := self selectedMessageCategoryName. newName := self request: 'Please type new category name' initialAnswer: oldName. newName isEmptyOrNil ifTrue: [^ self] ifFalse: [newName := newName asSymbol]. newName = oldName ifTrue: [^ self]. self classOrMetaClassOrganizer renameCategory: oldName toBe: newName. self classListIndex: classListIndex. self messageCategoryListIndex: oldIndex. self changed: #messageCategoryList. ! ! !Browser class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallSystemBrowserIcon! ! !Browser class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 3/19/2012 23:38'! fullOnClass: aClass "Open a new full browser set to class." ^ self newOnClass: aClass label: 'System Browser'! ! !Browser class methodsFor: 'instance creation' stamp: 'MarcusDenker 5/5/2013 09:15'! fullOnClass: aClass selector: aSelector "Open a new full browser set to class." | brower | brower := self new. brower setClass: aClass selector: aSelector. ^ self openBrowserView: (brower openEditString: nil) label: brower labelString! ! !Browser class methodsFor: 'instance creation' stamp: 'nk 6/2/2004 12:55'! systemOrganizer: anOrganizer ^(super new) systemOrganizer: anOrganizer; yourself! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:11'! openBrowser "Create and schedule a BrowserView with default browser label. The view consists of five subviews, starting with the list view of system categories of SystemOrganization. The initial text view part is empty." | br | br := self new. ^ self openBrowserView: (br openEditString: nil) label: br defaultBrowserTitle. ! ! !Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! newOnClass: aClass selector: aSymbol "Open a new class browser on this class." | newBrowser | newBrowser := self new. newBrowser setClass: aClass selector: aSymbol. ^ self openBrowserView: (newBrowser openOnClassWithEditString: nil) label: 'Class Browser: ', aClass name ! ! !Browser class methodsFor: 'window color' stamp: 'AlainPlantec 12/16/2009 22:20'! patchworkUIThemeColor "Answer a default color for UI themes that make use of different colors for Browser, MessageList etc..." ^ Color paleGreen ! ! !Browser class methodsFor: 'instance creation' stamp: 'sd 11/20/2005 21:28'! newOnClass: aClass label: aLabel "Open a new class browser on this class." | newBrowser | newBrowser := self new. newBrowser setClass: aClass selector: nil. ^ self openBrowserView: (newBrowser openOnClassWithEditString: nil) label: aLabel ! ! !Browser class methodsFor: 'cleanup' stamp: 'MarcusDenker 4/17/2011 21:46'! cleanUp self flushCaches.! ! !Browser class methodsFor: 'initialization' stamp: 'MarcusDenker 4/17/2011 21:46'! flushCaches RecentClasses := OrderedCollection new.! ! !Browser class methodsFor: 'initialization' stamp: 'MarcusDenker 5/5/2013 09:17'! initialize "Browser initialize" self flushCaches.! ! !Browser class methodsFor: 'instance creation' stamp: 'di 10/18/1999 22:03'! new ^super new systemOrganizer: SystemOrganization! ! !Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 16:28'! newOnClass: aClass "Open a new class browser on this class." ^ self newOnClass: aClass label: 'Class Browser: ', aClass name! ! !Browser class methodsFor: 'instance creation' stamp: 'alain.plantec 6/19/2008 09:43'! openBrowserView: aBrowserView label: aString "Schedule aBrowserView, labelling the view aString." (aBrowserView setLabel: aString) openInWorld. ^ aBrowserView model ! ! !Browser class methodsFor: 'instance creation' stamp: 'md 3/10/2006 21:46'! open ^self openBrowser ! ! !Browser class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/7/2012 10:39'! fullOnEnvironment: anEnvironment " I am not environment aware " self open! ! !Browser class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/8/2013 16:14'! fullOnClass: class selector: selector highlight: autoSelectString self fullOnClass: class selector: selector! ! !BrowserCommentTextMorph commentStamp: ''! I am a PluggableTextMorph that knows enough to make myself invisible when necessary.! !BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'nk 2/15/2004 14:12'! lowerPane "Answer the AlignmentMorph that I live beneath" ^self valueOfProperty: #browserLowerPane! ! !BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'nk 2/15/2004 14:07'! window ^self owner ifNil: [ self valueOfProperty: #browserWindow ].! ! !BrowserCommentTextMorph methodsFor: 'initialization' stamp: 'AlainPlantec 8/26/2011 17:53'! initialize super initialize. self styled: false ! ! !BrowserCommentTextMorph methodsFor: 'updating' stamp: 'AlainPlantec 8/26/2011 19:08'! update: anAspect super update: anAspect. anAspect == #editSelection ifFalse: [ ^self ]. self hideOrShowPane! ! !BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'IgorStasenko 12/19/2012 17:23'! defaultLayoutFrame ^ (0@0.75 corner: 1@1) asLayoutFrame. ! ! !BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'AlainPlantec 11/17/2010 11:35'! showPane "Fixed to not keep doing the splitters. If we are showing don't show again!!" | win | self owner ifNil: [ win := self window ifNil: [ ^self ]. win addMorph: self fullFrame: self defaultLayoutFrame. win updatePanesFromSubmorphs. self lowerPane ifNotNil: [ :lp | lp layoutFrame bottomFraction: self layoutFrame topFraction ]. win addPaneSplitters]! ! !BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'nk 2/15/2004 13:41'! hideOrShowPane (self model editSelection == #editClass) ifTrue: [ self showPane ] ifFalse: [ self hidePane ]! ! !BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'marcus.denker 11/10/2008 10:04'! hidePane "Fixed to not keep doing the splitters. If we are hiden don't hide again!!" | win | self owner ifNotNil: [ win := self window ifNil: [^self]. self window ifNotNil: [:window | window removePaneSplitters]. self lowerPane ifNotNil: [:lp | lp layoutFrame bottomFraction: self layoutFrame bottomFraction. lp layoutFrame bottomOffset: SystemWindow borderWidth negated]. self delete. win updatePanesFromSubmorphs. win addPaneSplitters]! ! !BrowserCommentTextMorph methodsFor: 'updating' stamp: 'stephane.ducasse 10/9/2008 18:50'! noteNewOwner: win "Dirty fix for when the 'lower pane' hasn't been reset to the bottom at the time the receiver is added" super noteNewOwner: win. self setProperty: #browserWindow toValue: win. win ifNil: [ ^self ]. win setProperty: #browserClassCommentPane toValue: self. self setProperty: #browserLowerPane toValue: (win submorphThat: [ :m | m isAlignmentMorph and: [ m layoutFrame bottomFraction = 1 or: [ m layoutFrame bottomFraction = self layoutFrame topFraction]]] ifNone: []). ! ! !BrowserUrl commentStamp: ''! URLs that instruct a browser to do something.! !BrowserUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:42'! hasContents ^true! ! !BrowserUrl class methodsFor: 'constants' stamp: 'SeanDeNigris 1/29/2011 19:33'! schemeName ^ 'browser'! ! !BuilderManifestTest commentStamp: ''! A ManifestBuilderTest is a class to test the behavior of ManifestBuilder! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testAddToDo | manifestBuilder cl mth| cl := MFClassA. mth := MFClassA >> #method. manifestBuilder := TheManifestBuilder of: MFClassA . manifestBuilder installToDoOf: 'test' version: 0. self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = cl]). self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = mth]). manifestBuilder addToDo: cl of: 'test' version: 0. manifestBuilder addToDo: mth of: 'test' version: 0. self assert: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = cl]). self assert: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = mth]). manifestBuilder removeToDo: cl of: 'test' version: 0. manifestBuilder removeToDo: mth of: 'test' version: 0. self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = cl]). self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = mth]). ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testInstallToDo | manifestBuilder | manifestBuilder := TheManifestBuilder of: MFClassA. . self deny: (manifestBuilder hasToDoOf: 'test' version: 0). manifestBuilder installToDoOf: 'test' version: 0. self assert: (manifestBuilder hasToDoOf: 'test' version: 0). self assert: (manifestBuilder toDoOf: 'test' version: 0) notNil. ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testContainsFalsePositive | manifestBuilder | manifestBuilder := TheManifestBuilder of: MFClassA . manifestBuilder installFalsePositiveOf: 'test' version: 0. manifestBuilder addFalsePositive: MFClassA of: 'test' version: 0. self assert: (manifestBuilder containsFalsePositive: MFClassA onRule: 'test' version: 0). self deny: (manifestBuilder containsFalsePositive: MFClassB onRule: 'test' version: 0). ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testAddRule | manifestBuilder| manifestBuilder := TheManifestBuilder of: MFClassA . self deny: ((manifestBuilder rejectRules) anySatisfy: [:each| each = 0]). manifestBuilder addRejectRule: 0. self assert: ((manifestBuilder rejectRules) anySatisfy: [:each| each = 0]). manifestBuilder removeRejectRule: 0. self deny: ((manifestBuilder rejectRules) anySatisfy: [:each| each = 0]). ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testCreationManifest | manifestBuilder cl | manifestBuilder := TheManifestBuilder new. cl := Smalltalk globals at: #ManifestManifestResourcesTests ifAbsent: [ nil ]. cl ifNotNil: [ cl removeFromChanges; removeFromSystemUnlogged ]. self assert: (manifestBuilder manifestOf: MFClassA ) isNil. self assert: (manifestBuilder createManifestOf: MFClassA) notNil. self assert: (manifestBuilder manifestOf: MFClassA) notNil! ! !BuilderManifestTest methodsFor: 'running' stamp: 'SimonAllier 5/29/2012 11:19'! tearDown | cl | cl := Smalltalk globals at: #ManifestManifestResourcesTests ifAbsent: [ nil ]. cl ifNotNil: [ cl removeFromChanges; removeFromSystemUnlogged ]. ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testAddFalsePositive | manifestBuilder cl mth| cl := MFClassA. mth := MFClassA >> #method. manifestBuilder := TheManifestBuilder of: MFClassA . manifestBuilder installFalsePositiveOf: 'test' version: 0. self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = cl]). self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = mth]). manifestBuilder addFalsePositive: cl of: 'test' version: 0. manifestBuilder addFalsePositive: mth of: 'test' version: 0. self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = cl]). self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = mth]). manifestBuilder removeFalsePositive: cl of: 'test' version: 0. manifestBuilder removeFalsePositive: mth of: 'test' version: 0. self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = cl]). self deny: ((manifestBuilder falsePositiveOf: 'test'version: 0) anySatisfy: [:each| each = mth]). ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testContainsToDo | manifestBuilder | manifestBuilder := TheManifestBuilder of: MFClassA . manifestBuilder installToDoOf: 'test' version: 0. manifestBuilder addToDo: MFClassA of: 'test' version: 0. self assert: (manifestBuilder containsToDo: MFClassA onRule: 'test' version: 0). self deny: (manifestBuilder containsToDo: MFClassB onRule: 'test' version: 0). ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testInstallFalsePositive | manifestBuilder | manifestBuilder := TheManifestBuilder of: MFClassA. . self deny: (manifestBuilder hasFalsePositiveOf: 'test' version: 0). manifestBuilder installFalsePositiveOf: 'test' version: 0. self assert: (manifestBuilder hasFalsePositiveOf: 'test' version: 0). self assert: (manifestBuilder falsePositiveOf: 'test' version: 0) notNil. ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testResetFalsePositive | manifestBuilder array| array := {MFClassA. MFClassB }. manifestBuilder := TheManifestBuilder of: MFClassA . manifestBuilder installFalsePositiveOf: 'test' version: 0. manifestBuilder addAllFalsePositive: array of: 'test' version: 0. self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = MFClassA]). self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = MFClassB]). manifestBuilder resetFalsePositiveOf: 'test' version: 0. self assert: (manifestBuilder manifest ruletestV0FalsePositive size = 0). ! ! !BuilderManifestTest methodsFor: 'running' stamp: 'SimonAllier 5/29/2012 11:05'! setUp | cl | cl := Smalltalk globals at: #ManifestManifestResourcesTests ifAbsent: [ nil ]. cl ifNotNil: [ cl removeFromChanges; removeFromSystemUnlogged ]. ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testAddAllFalsePositive | manifestBuilder array| array := {MFClassA. MFClassB }. manifestBuilder := TheManifestBuilder of: MFClassA . manifestBuilder installFalsePositiveOf: 'test' version: 0. self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = MFClassA]). self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = MFClassB]). manifestBuilder addAllFalsePositive: array of: 'test' version: 0. self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = MFClassA]). self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = MFClassB]). manifestBuilder addAllFalsePositive: array of: 'test' version: 0. self assert: (manifestBuilder manifest ruletestV0FalsePositive size = 2). manifestBuilder removeAllFalsePositive: array of: 'test' version: 0. self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = MFClassA]). self deny: ((manifestBuilder falsePositiveOf: 'test' version: 0) anySatisfy: [:each| each = MFClassB]). "manifestBuilder manifest class removeSelector: (manifestBuilder selectorFalsePositiveOf: 'test' version: 0)"! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testCleanUpFP | manifestBuilder | manifestBuilder := TheManifestBuilder of: MFClassA. . MFClassA compile: 'foo'. manifestBuilder installFalsePositiveOf: 'test' version: 0. manifestBuilder addFalsePositive: (MFClassA>>#foo) of: 'test' version: 0. self assert: (manifestBuilder containsFalsePositive: (MFClassA>>#foo) onRule: 'test' version: 0). MFClassA removeSelector: #foo. manifestBuilder cleanUp. self assert: ((manifestBuilder falsePositiveOf: 'test' version: 0 ) size = 0) . ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testDateOfFalsePositive | manifestBuilder date1 date2 | manifestBuilder := TheManifestBuilder of: MFClassA . manifestBuilder installFalsePositiveOf: 'test' version: 0. date1 := DateAndTime current. manifestBuilder addFalsePositive: MFClassA of: 'test' version: 0. date2 := DateAndTime current. self assert: (manifestBuilder dateOfFalsePositive: MFClassA onRule: 'test' version: 0) >= date1 . self assert: (manifestBuilder dateOfFalsePositive: MFClassA onRule: 'test' version: 0) <= date2 . ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testIsClassAManifest "self debug: #testIsClassAManifest" self deny: Point isManifest. TheManifestBuilder of: MFClassA. self assert: ( (Smalltalk at: #ManifestManifestResourcesTests) isManifest)! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testCreationManifestOn | manifestBuilder cl | manifestBuilder := TheManifestBuilder new. cl := Smalltalk globals at: #ManifestManifestResourcesTests ifAbsent: [ nil ]. cl ifNotNil: [ cl removeFromChanges; removeFromSystemUnlogged ]. self assert: (manifestBuilder manifestOf: MFClassA ) isNil. self assert: (TheManifestBuilder of: MFClassA) notNil. self assert: (manifestBuilder manifestOf: MFClassA) notNil! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testIsFalsePositive | manifestBuilder cl mth| cl := MFClassA. mth := cl >> #method. manifestBuilder := TheManifestBuilder of: MFClassA . self deny: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ). manifestBuilder addRejectClass: MFClassA. self assert: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ). manifestBuilder removeRejectClass: MFClassA. . self deny: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ). manifestBuilder addRejectRule: 'test'. self assert: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ). manifestBuilder removeRejectRule: 'test'. self deny: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ). manifestBuilder installFalsePositiveOf: 'test' version: 0. manifestBuilder addFalsePositive: mth of: 'test' version: 0. self assert: (manifestBuilder isFalsePositive: mth onRule: 'test' version:0 ). ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testCleanUpTD | manifestBuilder | manifestBuilder := TheManifestBuilder of: MFClassA. . MFClassA compile: 'foo'. manifestBuilder installToDoOf: 'test' version: 0. manifestBuilder addToDo: (MFClassA>>#foo) of: 'test' version: 0. self assert: (manifestBuilder containsToDo: (MFClassA>>#foo) onRule: 'test' version: 0). MFClassA removeSelector: #foo. manifestBuilder cleanUp. self assert: ((manifestBuilder toDoOf: 'test' version: 0 ) size = 0) . ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testAddAllToDo | manifestBuilder array| array := {MFClassA. MFClassB }. manifestBuilder := TheManifestBuilder of: MFClassA . manifestBuilder installToDoOf: 'test' version: 0. self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = MFClassA]). self deny: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = MFClassB]). manifestBuilder addAllToDo: array of: 'test' version: 0. self assert: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = MFClassA]). self assert: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = MFClassB]). manifestBuilder addAllToDo: array of: 'test' version: 0. self assert: (manifestBuilder manifest ruletestV0TODO size = 2). ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testResetToDo | manifestBuilder array| array := {MFClassA. MFClassB }. manifestBuilder := TheManifestBuilder of: MFClassA . manifestBuilder installToDoOf: 'test' version: 0. manifestBuilder addAllToDo: array of: 'test' version: 0. self assert: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = MFClassA]). self assert: ((manifestBuilder toDoOf: 'test' version: 0) anySatisfy: [:each| each = MFClassB]). manifestBuilder resetToDoOf: 'test' version: 0. self assert: (manifestBuilder manifest ruletestV0TODO size = 0). ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testAddClass | manifestBuilder| manifestBuilder := TheManifestBuilder of: MFClassA . self deny: ((manifestBuilder rejectClasses) anySatisfy: [:each| each = MFClassA]). manifestBuilder addRejectClass: MFClassA.. self assert: ((manifestBuilder rejectClasses) anySatisfy: [:each| each = MFClassA]). manifestBuilder removeRejectClass: MFClassA. . self deny: ((manifestBuilder rejectClasses) anySatisfy: [:each| each = MFClassA]). ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/6/2014 20:51'! testDateOfToDo | manifestBuilder date1 date2 | manifestBuilder := TheManifestBuilder of: MFClassA . manifestBuilder installToDoOf: 'test' version: 0. date1 := DateAndTime current. manifestBuilder addToDo: MFClassA of: 'test' version: 0. date2 := DateAndTime current. self assert: (manifestBuilder dateOfToDo: MFClassA onRule: 'test' version: 0) >= date1 . self assert: (manifestBuilder dateOfToDo: MFClassA onRule: 'test' version: 0) <= date2 . ! ! !ButtonModel commentStamp: ''! A ButtonComposableModel is an applicative model which handle a basic button. self example! !ButtonModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 9/25/2013 14:49'! whenLabelChangedDo: aBlock "set a block to perform after that the button has been aclicked, and its action performed" labelHolder whenChangedDo: aBlock! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! askBeforeChanging ^ askBeforeChangingHolder value! ! !ButtonModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! performAction actionHolder value value. " Here I set a dummy value just to make the holder raise an event " actionPerformedHolder value: nil.! ! !ButtonModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. actionHolder := [] asReactiveVariable. labelHolder := '' asReactiveVariable. iconHolder := nil asReactiveVariable. stateHolder := false asReactiveVariable. helpHolder := nil asReactiveVariable. actionPerformedHolder := nil asReactiveVariable. askBeforeChangingHolder := false asReactiveVariable. shortcut := nil asReactiveVariable. labelHolder whenChangedDo: [ self changed: #label ]. iconHolder whenChangedDo: [ self changed: #label ]. stateHolder whenChangedDo: [ self changed: #state ]. enabledHolder whenChangedDo: [ self changed: #enabled ]. askBeforeChangingHolder whenChangedDo: [:newValue | self changed: { #askBeforeChanging: . newValue} ]. shortcut whenChangedDo: [ :newShortcut :oldShortcut | self unregisterShortcut: oldShortcut. self registerShortcut: newShortcut. self changed: #label ]. menuHolder := MenuModel new asReactiveVariable. menuHolder whenChangedDo: [ :aMenuModel :oldMenu | (oldMenu isNil or: [ oldMenu isBlock ]) ifFalse: [ oldMenu neglect: self ]. (aMenuModel isNil or: [ aMenuModel isBlock ]) ifFalse: [ aMenuModel applyTo: self ] ]. self bindKeyCombination: Character space toAction: [ self action ].! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/5/2014 15:54'! menu: aMenu menuHolder value: aMenu! ! !ButtonModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/15/2014 10:15'! addShortcutTipFor: aCharacter on: aString | index text | aString isNil ifTrue: [ ^ nil ]. text := aString asText. aCharacter ifNil: [ ^ text ]. index := aString asLowercase indexOf: aCharacter asLowercase. index isZero ifTrue: [ ^ text ]. ^ text addAttribute: (TextEmphasis underlined) from: index to: index; yourself! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! action "get the block performed when the button is clicked" ^ actionHolder value! ! !ButtonModel methodsFor: 'private-focus' stamp: 'BenjaminVanRyseghem 12/11/2013 18:14'! ensureKeyBindingsFor: widget super ensureKeyBindingsFor: widget. self shortcut ifNotNil: [ :s | self registerShortcut: s ]! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! label: aStringOrImageMorph labelHolder value: aStringOrImageMorph! ! !ButtonModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 9/25/2013 14:49'! whenActionChangedDo: aBlock actionHolder whenChangedDo: aBlock! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! askBeforeChanging: aBoolean askBeforeChangingHolder value: aBoolean! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! state: aBoolean "set if the button is highlighted" ^ stateHolder value: aBoolean! ! !ButtonModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 9/25/2013 14:49'! whenActionPerformedDo: aBlock "set a block to perform after that the button has been aclicked, and its action performed" actionPerformedHolder whenChangedDo: aBlock! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/5/2014 15:54'! menu ^ menuHolder value! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/11/2013 14:56'! shortcut: aShortcut shortcut value: aShortcut! ! !ButtonModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/11/2013 18:27'! registerShortcut: newShortcut | receiver | receiver := self window. (receiver isNil or: [ newShortcut isNil ]) ifTrue: [ ^ self ]. receiver model bindKeyCombination: newShortcut toAction: [ self performAction ]! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! action: aBlock "set the block performed when the button is clicked" actionHolder value: aBlock! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/11/2013 14:56'! shortcut ^ shortcut value! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! getAction "get the block performed when the button is clicked" ^ actionHolder value! ! !ButtonModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/11/2013 18:27'! unregisterShortcut: oldShortcut | receiver | receiver := self window. (receiver isNil or: [ oldShortcut isNil ]) ifTrue: [ ^ self ]. receiver model removeKeyCombination: oldShortcut ! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! icon: anIcon iconHolder value: anIcon! ! !ButtonModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 9/25/2013 14:49'! whenStateChangedDo: aBlock "set a block to perform after that the button has been aclicked, and its action performed" stateHolder whenChangedDo: aBlock! ! !ButtonModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! state ^ stateHolder value! ! !ButtonModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 12/11/2013 14:42'! label ^ self addShortcutTipFor: labelHolder value! ! !ButtonModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/11/2013 14:56'! addShortcutTipFor: aString ^ self addShortcutTipFor: self shortcutCharacter on: aString! ! !ButtonModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/11/2013 15:05'! shortcutCharacter ^ self shortcut ifNil: [ nil ] ifNotNil: [ :s | s currentCharacter ]! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! icon ^ iconHolder value! ! !ButtonModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 13:38'! defaultSpec ^ #(ButtonAdapter adapt: #(model))! ! !ButtonModel class methodsFor: 'example' stamp: 'BenjaminVanRyseghem 9/25/2013 14:50'! example | b | b:= ButtonModel new. b openWithSpec. b label: 'Click me'.! ! !ButtonModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 9/25/2013 14:50'! title ^ 'Button'! ! !ButtonModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:19'! adapterName ^ #ButtonAdapter! ! !ButtonModelTest commentStamp: 'TorstenBergmann 2/5/2014 09:21'! SUnit tests for Button model! !ButtonModelTest methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 7/18/2013 13:48'! testAskBeforeChanging |buttonModel window state| buttonModel := ButtonModel new. self assert: buttonModel askBeforeChanging not. window := buttonModel openWithSpec. state := buttonModel widget askBeforeChanging. self assert: state not. buttonModel askBeforeChanging: true. state := buttonModel widget askBeforeChanging. window close. self assert: state ! ! !ByteArray commentStamp: ''! I represent an ArrayedCollection whose elements are integers between 0 and 255. ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:07'! nbUInt16AtOffset: zeroBasedOffset "Reads unsigned 16-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(uint16 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr16 + asm ECX to: asm AX ] ! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:07'! nbUInt64AtOffset: zeroBasedOffset "Reads unsigned 64-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(uint64 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr + asm ECX + 4 to: asm EDX; mov: asm EAX ptr + asm ECX to: asm EAX ] ! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:04'! nbFloat64AtOffset: zeroBasedOffset put: value "Store 64-bit float at ZERO-based index. Note, there is no range checking " ^self nbCallout function: #(void (self, ulong zeroBasedOffset, float64 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" add: asm EAX with: asm ECX; mov: asm ESP ptr to: asm ECX; mov: asm ECX to: asm EAX ptr; mov: asm ESP ptr +4 to: asm ECX; mov: asm ECX to: asm EAX ptr +4 ] ! ! !ByteArray methodsFor: '*System-Hashing-Core' stamp: 'StephaneDucasse 10/17/2009 17:15'! bitXor: aByteArray | answer | answer := self copy. 1 to: (self size min: aByteArray size) do: [ :each | answer at: each put: ((self at: each) bitXor: (aByteArray at: each)) ]. ^ answer! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:07'! nbUInt16AtOffset: zeroBasedOffset put: value "Store unsigned 16-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^self nbCallout function: #(void (self, ulong zeroBasedOffset, uint16 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm DX to: asm EAX ptr16 + asm ECX ] ! ! !ByteArray methodsFor: 'platform independent access' stamp: 'jmb 12/3/2004 14:54'! doubleAt: index bigEndian: bool "Return a 64 bit float starting from the given byte index" | w1 w2 dbl | w1 := self unsignedLongAt: index bigEndian: bool. w2 := self unsignedLongAt: index + 4 bigEndian: bool. dbl := Float new: 2. bool ifTrue: [dbl basicAt: 1 put: w1. dbl basicAt: 2 put: w2] ifFalse: [dbl basicAt: 1 put: w2. dbl basicAt: 2 put: w1]. ^ dbl! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:44'! longAt: index bigEndian: aBool "Return a 32bit integer quantity starting from the given byte index" | b0 b1 b2 w h | aBool ifTrue:[ b0 := self at: index. b1 := self at: index+1. b2 := self at: index+2. w := self at: index+3. ] ifFalse:[ w := self at: index. b2 := self at: index+1. b1 := self at: index+2. b0 := self at: index+3. ]. "Minimize LargeInteger arithmetic" h := ((b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80) bitShift: 8) + b1. b2 = 0 ifFalse:[w := (b2 bitShift: 8) + w]. h = 0 ifFalse:[w := (h bitShift: 16) + w]. ^w! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 8/2/2003 19:29'! longAt: index put: value bigEndian: aBool "Return a 32bit integer quantity starting from the given byte index" | b0 b1 b2 b3 | b0 := value bitShift: -24. b0 := (b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80). b0 < 0 ifTrue:[b0 := 256 + b0]. b1 := (value bitShift: -16) bitAnd: 255. b2 := (value bitShift: -8) bitAnd: 255. b3 := value bitAnd: 255. aBool ifTrue:[ self at: index put: b0. self at: index+1 put: b1. self at: index+2 put: b2. self at: index+3 put: b3. ] ifFalse:[ self at: index put: b3. self at: index+1 put: b2. self at: index+2 put: b1. self at: index+3 put: b0. ]. ^value! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:05'! nbInt64AtOffset: zeroBasedOffset put: value "Store signed 64-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, int64 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value low word" mov: asm EDX to: asm EAX ptr32 + asm ECX; pop: asm EDX; "value high word" mov: asm EDX to: asm EAX ptr32 + asm ECX + 4 ] ! ! !ByteArray methodsFor: '*Network-Mime' stamp: 'StephaneDucasse 10/3/2010 15:15'! base64Encoded "Encode the receiver as base64" "'Hello World' asByteArray base64Encoded" ^(Base64MimeConverter mimeEncode: self readStream) contents! ! !ByteArray methodsFor: '*Compression' stamp: 'nk 8/21/2004 15:23'! lastIndexOfPKSignature: aSignature "Answer the last index in me where aSignature (4 bytes long) occurs, or 0 if not found" | a b c d | a := aSignature first. b := aSignature second. c := aSignature third. d := aSignature fourth. (self size - 3) to: 1 by: -1 do: [ :i | (((self at: i) = a) and: [ ((self at: i + 1) = b) and: [ ((self at: i + 2) = c) and: [ ((self at: i + 3) = d) ]]]) ifTrue: [ ^i ] ]. ^0! ! !ByteArray methodsFor: 'accessing' stamp: 'StephaneDucasse 9/18/2010 21:24'! indexOf: anInteger startingAt: start (anInteger isInteger and: [ anInteger >= 0 and: [ anInteger <= 255 ] ]) ifFalse: [ ^0 ]. ^ByteString indexOfAscii: anInteger inString: self startingAt: start! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:06'! nbLongAt: index put: value "Store signed long at one-based index. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong index, long value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "index" add: asm EAX with: asm ECX; pop: asm ECX; "value" mov: asm ECX to: asm EAX ptr -1 ] ! ! !ByteArray methodsFor: 'converting' stamp: ''! asString "Convert to a String with Characters for each byte. Fast code uses primitive that avoids character conversion" ^ (String new: self size) replaceFrom: 1 to: self size with: self! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'! byteAt: index ^self at: index! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:08'! nbUInt8AtOffset: zeroBasedOffset "Reads unsigned 8-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(uint8 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr8 + asm ECX to: asm AL ] ! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:08'! nbUInt8AtOffset: zeroBasedOffset put: value "Store unsigned 8-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, uint8 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm DL to: asm EAX ptr8 + asm ECX ] ! ! !ByteArray methodsFor: '*System-Hashing-Core' stamp: 'cmm 2/21/2006 00:05'! destroy 1 to: self size do: [ : x | self at: x put: 0 ]! ! !ByteArray methodsFor: 'platform independent access' stamp: 'SergeStinckwich 2/19/2009 13:33'! floatAt: index bigEndian: boolean ^ Float fromIEEE32Bit: (self unsignedLongAt: index bigEndian: boolean)! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:51'! unsignedShortAt: index bigEndian: aBool "Return a 16 bit unsigned integer quantity starting from the given byte index" ^aBool ifTrue:[((self at: index) bitShift: 8) + (self at: index+1)] ifFalse:[((self at: index+1) bitShift: 8) + (self at: index)].! ! !ByteArray methodsFor: '*System-Hashing-Core' stamp: 'rww 4/11/2004 14:48'! asByteArrayOfSize: size " '34523' asByteArray asByteArrayOfSize: 100. ((( | repeats bytes | repeats := 1000000. bytes := '123456789123456789123456789123456789123456789123456789' asByteArray. [repeats timesRepeat: (bytes asByteArrayOfSize: 1024) ] timeToRun. )))" | bytes | size < self size ifTrue: [^ self error: 'bytearray bigger than ', size asString]. bytes := self asByteArray. ^ (ByteArray new: (size - bytes size)), bytes ! ! !ByteArray methodsFor: 'platform independent access' stamp: 'jmb 12/3/2004 14:54'! doubleAt: index put: value bigEndian: bool "Store a 64 bit float starting from the given byte index" | w1 w2 | bool ifTrue: [w1 := value basicAt: 1. w2 := value basicAt: 2] ifFalse: [w1 := value basicAt: 2. w2 := value basicAt: 1]. self unsignedLongAt: index put: w1 bigEndian: bool. self unsignedLongAt: index + 4 put: w2 bigEndian: bool. ^ value! ! !ByteArray methodsFor: 'private' stamp: ''! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:07'! nbUInt64AtOffset: zeroBasedOffset put: value "Store unsigned 64-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, uint64 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value low word" mov: asm EDX to: asm EAX ptr32 + asm ECX; pop: asm EDX; "value high word" mov: asm EDX to: asm EAX ptr32 + asm ECX + 4 ] ! ! !ByteArray methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:47'! atAllPut: value "Fill the receiver with the given value" super atAllPut: value! ! !ByteArray methodsFor: 'converting' stamp: 'sma 5/12/2000 17:35'! asByteArray ^ self! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:06'! nbLongAt: index "Read signed long at one-based index. Note, there is no range checking " ^ self nbCallout options: #( optCheckFailOnEveryArgument ); function: #(long (self, ulong index)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "index" mov: asm EAX ptr + asm ECX -1 to: asm EAX. ] ! ! !ByteArray methodsFor: 'converting' stamp: 'StephaneDucasse 2/28/2010 11:56'! hex " an alternate implementation was | result stream | result := String new: self size * 2. stream := result writeStream. 1 to: self size do: [ :ix | |each| each := self at: ix. stream nextPut: ('0123456789ABCDEF' at: each // 16 + 1); nextPut: ('0123456789ABCDEF' at: each \\ 16 + 1)]. ^ result" "Answer a hexa decimal representation of the receiver" | string v index map | map := '0123456789abcdef'. string := String new: self size * 2. "hex" index := 0. 1 to: self size do: [ :i | v := self at: i. string at: (index := index + 1) put: (map at: (v bitShift: -4) + 1). string at: (index := index + 1) put: (map at: (v bitAnd: 15) + 1)]. ^string! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/3/1998 14:20'! shortAt: index put: value bigEndian: aBool "Store a 16 bit integer quantity starting from the given byte index" self unsignedShortAt: index put: (value bitAnd: 16r7FFF) - (value bitAnd: -16r8000) bigEndian: aBool. ^value! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:17'! byteSize ^self size! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:03'! nbFloat32AtOffset: zeroBasedOffset put: value "Store 32-bit float at ZERO-based index. Note, there is no range checking " ^ self nbCallout function:#(void (self, ulong zeroBasedOffset, float32 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; mov: asm EDX to: asm EAX ptr + asm ECX ] ! ! !ByteArray methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitBytesObject: self! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:57'! shortAt: index bigEndian: aBool "Return a 16 bit integer quantity starting from the given byte index" | uShort | uShort := self unsignedShortAt: index bigEndian: aBool. ^(uShort bitAnd: 16r7FFF) - (uShort bitAnd: 16r8000)! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:53'! unsignedShortAt: index put: value bigEndian: aBool "Store a 16 bit unsigned integer quantity starting from the given byte index" aBool ifTrue:[ self at: index put: (value bitShift: -8). self at: index+1 put: (value bitAnd: 255). ] ifFalse:[ self at: index+1 put: (value bitShift: -8). self at: index put: (value bitAnd: 255). ]. ^value! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:35'! asWideString ^ WideString fromByteArray: self. ! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:09'! nbUlongAt: index put: value "Store unsigned long at one-based index. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong index, ulong value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "index" add: asm EAX with: asm ECX; pop: asm ECX; "value" mov: asm ECX to: asm EAX ptr -1 ] ! ! !ByteArray methodsFor: '*System-Hashing-Core' stamp: 'SvenVanCaekenberghe 4/18/2011 20:40'! asInteger "Convert me to an Integer, network byte order, most significant byte first, big endian" | integer | integer := 0. self withIndexDo: [ :each :index | integer := integer + (each bitShift: (self size - index) * 8) ]. ^ integer! ! !ByteArray methodsFor: 'printing' stamp: 'stephane.ducasse 2/1/2009 22:39'! printOn: aStream aStream nextPutAll: '#['. self do: [ :each | each printOn: aStream ] separatedBy: [ aStream nextPut: $ ]. aStream nextPut: $]! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:49'! unsignedLongAt: index put: value bigEndian: aBool "Store a 32bit unsigned integer quantity starting from the given byte index" | b0 b1 b2 b3 | b0 := value bitShift: -24. b1 := (value bitShift: -16) bitAnd: 255. b2 := (value bitShift: -8) bitAnd: 255. b3 := value bitAnd: 255. aBool ifTrue:[ self at: index put: b0. self at: index+1 put: b1. self at: index+2 put: b2. self at: index+3 put: b3. ] ifFalse:[ self at: index put: b3. self at: index+1 put: b2. self at: index+2 put: b1. self at: index+3 put: b0. ]. ^value! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:04'! nbInt32AtOffset: zeroBasedOffset "Reads signed 32-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(int32 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr32 + asm ECX to: asm EAX ] ! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:05'! nbInt32AtOffset: zeroBasedOffset put: value "Store signed 32-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, int32 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm EDX to: asm EAX ptr32 + asm ECX ] ! ! !ByteArray methodsFor: 'initialize-release' stamp: 'StephaneDucasse 2/28/2010 12:03'! readHexFrom: aStream "Initialize the receiver from a hexadecimal string representation" | map v ch value | map := '0123456789abcdefABCDEF'. 1 to: self size do: [ :i | ch := aStream next. v := (map indexOf: ch) - 1. ((v between: 0 and: 15) or: [((v:= v - 6) between: 0 and: 15)]) ifFalse:[^self error: 'Hex digit expected']. value := v bitShift: 4. ch := aStream next. v := (map indexOf: ch) - 1. ((v between: 0 and: 15) or: [((v:= v - 6) between: 0 and: 15)]) ifFalse:[^self error: 'Hex digit expected']. value := value + v. self at: i put: value].! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:05'! nbInt64AtOffset: zeroBasedOffset "Reads signed 64-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(int64 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr + asm ECX + 4 to: asm EDX; mov: asm EAX ptr + asm ECX to: asm EAX ] ! ! !ByteArray methodsFor: 'comparing' stamp: 'SqR 8/13/2002 10:52'! hash "#hash is implemented, because #= is implemented" ^self class hashBytes: self startingWith: self species hash! ! !ByteArray methodsFor: 'printing' stamp: 'stephane.ducasse 2/1/2009 22:40'! storeOn: aStream aStream nextPutAll: '#['. self do: [ :each | each storeOn: aStream ] separatedBy: [ aStream nextPut: $ ]. aStream nextPut: $]! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:49'! unsignedLongAt: index bigEndian: aBool "Return a 32bit unsigned integer quantity starting from the given byte index" | b0 b1 b2 w | aBool ifTrue:[ b0 := self at: index. b1 := self at: index+1. b2 := self at: index+2. w := self at: index+3. ] ifFalse:[ w := self at: index. b2 := self at: index+1. b1 := self at: index+2. b0 := self at: index+3. ]. "Minimize LargeInteger arithmetic" b2 = 0 ifFalse:[w := (b2 bitShift: 8) + w]. b1 = 0 ifFalse:[w := (b1 bitShift: 16) + w]. b0 = 0 ifFalse:[w := (b0 bitShift: 24) + w]. ^w! ! !ByteArray methodsFor: 'testing' stamp: 'StephaneDucasse 12/30/2010 14:29'! isLiteral "so that #(1 #[1 2 3] 5) prints itself" "" ^ self class == ByteArray! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'! byteAt: index put: value ^self at: index put: value! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:03'! nbFloat32AtOffset: zeroBasedOffset "Read 32-bit float at ZERO-based index. Note, there is no range checking " ^ self nbCallout function: #(float32 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" add: asm EAX with: asm ECX; fld: asm EAX ptr32. "load a floating point value from memory, at base address, held in EAX register into fp(0) register, we are using #ptr32, to indicate that memory operand size is 32bits long" ] ! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:04'! nbFloat64AtOffset: zeroBasedOffset "Read 64-bit float at ZERO-based index. Note, there is no range checking " ^self nbCallout function: #(float64 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "index" add: asm EAX with: asm ECX; fld: asm EAX ptr64. "load a floating point value from memory, at base address, held in EAX register into fp(0) register, we are using #ptr64, to indicate that memory operand size is 64bits long" ] ! ! !ByteArray methodsFor: '*Network-Kernel' stamp: 'mir 6/17/2007 23:12'! asSocketAddress ^SocketAddress fromOldByteAddress: self! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:04'! nbInt16AtOffset: zeroBasedOffset "Reads signed 16-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(int16 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr16 + asm ECX to: asm AX ] ! ! !ByteArray methodsFor: 'private' stamp: ''! defaultElement ^0! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:04'! nbInt16AtOffset: zeroBasedOffset put: value "Store signed 16-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, int16 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm DX to: asm EAX ptr16 + asm ECX ] ! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:05'! nbInt8AtOffset: zeroBasedOffset "Reads signed 8-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(int8 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr8 + asm ECX to: asm AL ] ! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:05'! nbInt8AtOffset: zeroBasedOffset put: value "Store signed 8-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, int8 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm DL to: asm EAX ptr8 + asm ECX ] ! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:07'! nbUInt32AtOffset: zeroBasedOffset "Reads unsigned 32-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(uint32 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr32 + asm ECX to: asm EAX ] ! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:08'! nbUlongAt: index "Read unsigned long at one-based index. Note, there is no range checking " ^ self nbCallout options: #( optCheckFailOnEveryArgument ); function: #(ulong (self, ulong index)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "index" mov: asm EAX ptr + asm ECX -1 to: asm EAX. ]! ! !ByteArray methodsFor: 'private' stamp: 'ar 1/28/2000 17:45'! asByteArrayPointer "Return a ByteArray describing a pointer to the contents of the receiver." ^self shouldNotImplement! ! !ByteArray methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/23/2012 18:07'! nbUInt32AtOffset: zeroBasedOffset put: value "Store unsigned 32-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, uint32 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm EDX to: asm EAX ptr32 + asm ECX ] ! ! !ByteArray class methodsFor: 'byte based hash' stamp: 'HenrikSperreJohansen 10/25/2010 15:33'! hashBytes: aByteArray startingWith: speciesHash "Answer the hash of a byte-indexed collection, using speciesHash as the initial value. See SmallInteger>>hashMultiply. The primitive should be renamed at a suitable point in the future" | byteArraySize hash low | byteArraySize := aByteArray size. hash := speciesHash bitAnd: 16rFFFFFFF. 1 to: byteArraySize do: [:pos | hash := hash + (aByteArray basicAt: pos). "Begin hashMultiply" low := hash bitAnd: 16383. hash := (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF. ]. ^ hash! ! !ByteArray class methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 8/3/2011 19:55'! asNBExternalType: gen ^ NBByteArrayPtr new! ! !ByteArray class methodsFor: '*Spec-Inspector' stamp: 'cb 6/25/2013 13:43'! inspectorClass ^ EyeByteArrayInspector! ! !ByteArray class methodsFor: 'instance creation' stamp: 'StephaneDucasse 2/28/2010 12:04'! readHexFrom: aString "Create a byte array from a hexadecimal representation" ^(self new: aString size // 2) readHexFrom: aString readStream! ! !ByteArrayTest commentStamp: 'TorstenBergmann 2/20/2014 15:19'! SUnit tests for ByteArray! !ByteArrayTest methodsFor: 'tests' stamp: 'jannik.laval 5/2/2010 07:23'! testFourthByteArraysReturnTheCorrectValues "self run: #testFourthByteArraysReturnTheCorrectValues" self assert: ((#[16r3F 16r80 0 0] floatAt:1 bigEndian: true) = 1.0). self assert: ((#[16rC0 0 0 0] floatAt:1 bigEndian: true) = -2.0). ! ! !ByteArrayTest methodsFor: 'tests' stamp: 'StephaneDucasse 12/30/2010 14:30'! testIsLiteral self assert: #[122 43 213 7] isLiteral description: 'ByteArray instances are literal'. self deny: thisContext method isLiteral description: 'ByteArray sub instances are not literal'! ! !ByteArrayTest methodsFor: 'tests' stamp: 'PavelKrivanek 6/4/2011 17:01'! testHex "self debug: #testHex" self assert: #[122 43 213 7] hex = '7a2bd507'. self assert: #[151 193 242 221 249 32 153 72 179 41 49 154 48 193 99 134] hex = '97c1f2ddf9209948b329319a30c16386'. self assert: (ByteArray readHexFrom: '7A2BD507') = #[122 43 213 7]. self assert: (ByteArray readHexFrom: '7a2bd507') = #[122 43 213 7]. ! ! !ByteArrayTest methodsFor: 'tests' stamp: 'StephaneDucasse 9/18/2010 21:27'! testindexOfStartingAt "self run: #testindexOfStartingAt" self assert: (#[1 2 3 4 5 6 7 8 9 10 11 1 2 3 4 5 6 7 8 0 0] indexOf: 1 startingAt: 10) = 12. self assert: (#[1 2 3 4 5 6 7 8 9 10 11 1 2 3 4 5 6 7 8 0 0] indexOf: 17 startingAt: 10) = 0. ! ! !ByteCodeMethodConverter commentStamp: ''! A ByteCodeMessageConverter is a wrapper wich display the bytecode of the provided message! !ByteCodeMethodConverter methodsFor: 'private' stamp: ''! internalGetText ^ method symbolic asText! ! !ByteLayout commentStamp: ''! I am a raw data layout that holds bytes (8 bit).! !ByteLayout methodsFor: 'format' stamp: 'ToonVerwaest 4/1/2011 01:27'! instanceSpecification ^ 8! ! !ByteLayout methodsFor: 'extending' stamp: 'MartinDias 7/24/2013 13:21'! extendWord IncompatibleLayoutConflict new layout: self; subType: #word; signal! ! !ByteLayout methodsFor: 'testing' stamp: 'MartinDias 1/31/2014 16:19'! isBytes ^ true! ! !ByteLayout class methodsFor: 'instance creation' stamp: 'MartinDias 7/11/2013 16:14'! extending: superLayout scope: aScope host: aClass ^ superLayout extendByte host: aClass; yourself! ! !ByteString commentStamp: ''! This class represents the array of 8 bit wide characters. ! !ByteString methodsFor: 'testing' stamp: 'HenrikSperreJohansen 9/1/2009 00:44'! hasWideCharacterFrom: start to: stop "Only WideStrings contain these characters" ^false! ! !ByteString methodsFor: 'testing' stamp: 'ar 4/10/2005 18:04'! isByteString "Answer whether the receiver is a ByteString" ^true! ! !ByteString methodsFor: 'comparing' stamp: 'nice 3/23/2007 00:50'! beginsWith: prefix "Answer whether the receiver begins with the given prefix string. The comparison is case-sensitive." "IMPLEMENTATION NOTE: following algorithm is optimized in primitive only in case self and prefix are bytes like. Otherwise, if self is wide, then super outperforms, Otherwise, if prefix is wide, primitive is not correct" prefix class isBytes ifFalse: [^super beginsWith: prefix]. self size < prefix size ifTrue: [^ false]. ^ (self findSubstring: prefix in: self startingAt: 1 matchTable: CaseSensitiveOrder) = 1 ! ! !ByteString methodsFor: 'testing' stamp: 'HenrikSperreJohansen 1/26/2010 15:21'! isAsciiString ^(self class findFirstInString: self inSet: NonAsciiMap startingAt: 1) = 0! ! !ByteString methodsFor: 'accessing' stamp: 'ar 12/27/1999 13:44'! byteAt: index ^(self at: index) asciiValue! ! !ByteString methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:17'! byteSize ^self size! ! !ByteString methodsFor: 'converting' stamp: 'StephaneDucasse 8/2/2013 22:39'! convertFromSystemString | readStream | readStream := self readStream. ^ self class new: self size streamContents: [ :writeStream | | converter | converter := LanguageEnvironment defaultSystemConverter. [readStream atEnd] whileFalse: [ writeStream nextPut: (converter nextFromStream: readStream)]]. ! ! !ByteString methodsFor: '*NativeBoost-Examples' stamp: 'IgorStasenko 11/24/2012 15:52'! nbBeginsWithByteString: prefix "an assembler implementation of #beginsWith: , note, works only for byte strings " ^ self nbCallout function: #( oop (oop self, oop prefix) ) emit: [:gen :proxy :asm | | string sz1 prefixStr sz2 returnFalse done | string := gen reserveTemp. sz1 := gen reserveTemp. prefixStr := gen reserveTemp. sz2 := gen reserveTemp. returnFalse := asm uniqueLabelName: 'returnFalse'. done := asm uniqueLabelName: 'done'. asm mov: asm ESP ptr to: asm EAX "self ". proxy varBytesFirstFieldOf: asm EAX. asm mov: asm EAX to: string. asm pop: asm EAX "self ". proxy byteSizeOf: asm EAX. asm mov: asm EAX to: sz1. asm mov: asm ESP ptr to: asm EAX "self ". proxy varBytesFirstFieldOf: asm EAX. asm mov: asm EAX to: prefixStr. asm pop: asm EAX "self ". proxy byteSizeOf: asm EAX. asm mov: asm EAX to: sz2. asm mov: sz1 to: asm EAX; cmp: asm EAX with: sz2; jl: returnFalse. asm mov: string to: asm ESI; mov: prefixStr to: asm EDI; mov: sz2 to: asm ECX; cld; repe; cmpsb; cmp: asm ECX with: 0; jnz: returnFalse. proxy trueObject. asm jmp: done. asm label: returnFalse. proxy falseObject. asm label: done ] ! ! !ByteString methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitHookPrimitive: self! ! !ByteString methodsFor: 'accessing' stamp: 'ar 12/27/1999 13:44'! byteAt: index put: value self at: index put: value asCharacter. ^value! ! !ByteString methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 3/19/2013 20:28'! asKeyCombination self size > 1 ifTrue: [ self error: 'Shortcuts only take a single letter']. ^ KMSingleKeyCombination from: self first! ! !ByteString methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 10:50'! serializeOn: anEncoder anEncoder encodeString: self! ! !ByteString methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:33'! at: index put: aCharacter "Primitive. Store the Character in the field of the receiver indicated by the index. Fail if the index is not an Integer or is out of bounds, or if the argument is not a Character. Essential. See Object documentation whatIsAPrimitive." aCharacter isCharacter ifFalse:[^self errorImproperStore]. aCharacter isOctetCharacter ifFalse:[ "Convert to WideString" self becomeForward: (WideString from: self). ^self at: index put: aCharacter. ]. index isInteger ifTrue: [self errorSubscriptBounds: index] ifFalse: [self errorNonIntegerIndex]! ! !ByteString methodsFor: 'accessing' stamp: 'yo 8/26/2002 20:33'! at: index "Primitive. Answer the Character stored in the field of the receiver indexed by the argument. Fail if the index argument is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." ^ Character value: (super at: index)! ! !ByteString methodsFor: 'accessing' stamp: 'nice 12/9/2009 15:40'! indexOfAnyOf: aCollection startingAt: start ifAbsent: aBlock "Use double dispatching for speed" | index | ^(index := aCollection findFirstInByteString: self startingAt: start) = 0 ifTrue: [aBlock value] ifFalse: [index]! ! !ByteString methodsFor: 'testing' stamp: 'ar 4/10/2005 17:28'! isOctetString "Answer whether the receiver can be represented as a byte string. This is different from asking whether the receiver *is* a ByteString (i.e., #isByteString)" ^ true. ! ! !ByteString methodsFor: 'accessing' stamp: 'nice 12/9/2009 15:39'! indexOfAnyOf: aCollection startingAt: start "Use double dispatching for speed" ^aCollection findFirstInByteString: self startingAt: start! ! !ByteString methodsFor: 'converting' stamp: 'yo 8/28/2002 16:52'! asOctetString ^ self. ! ! !ByteString methodsFor: '*Slot' stamp: 'ToonVerwaest 4/1/2011 03:57'! asSlot ^ self asSymbol asSlot! ! !ByteString methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:33'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." replacement class == WideString ifTrue: [ self becomeForward: (WideString from: self). ]. super replaceFrom: start to: stop with: replacement startingAt: repStart. ! ! !ByteString methodsFor: '*Text-Scanning' stamp: 'tpr 10/2/2013 17:36'! scanCharactersFrom: startIndex to: stopIndex with: aCharacterScanner rightX: rightX font: aFont "NB: strongly consider getting almost all these parameters from the scanner" "Since I'm a byte char string, I know that we have to scan single-byte characters and don't have to handle encodings etc" startIndex > stopIndex ifTrue: [^aCharacterScanner handleEndOfRunAt: stopIndex]. ^aFont scanByteCharactersFrom: startIndex to: stopIndex in: self with: aCharacterScanner rightX: rightX! ! !ByteString methodsFor: 'comparing' stamp: 'SeanDeNigris 1/24/2011 23:37'! findSubstring: key in: body startingAt: start matchTable: matchTable ^ key findIn: body startingAt: start matchTable: matchTable.! ! !ByteString methodsFor: 'converting' stamp: 'ar 4/10/2005 17:20'! asByteArray | ba sz | sz := self byteSize. ba := ByteArray new: sz. ba replaceFrom: 1 to: sz with: self startingAt: 1. ^ba! ! !ByteString class methodsFor: 'primitives' stamp: 'HenrikSperreJohansen 10/25/2010 15:31'! stringHash: aString initialHash: speciesHash | stringSize hash low | stringSize := aString size. hash := speciesHash bitAnd: 16rFFFFFFF. 1 to: stringSize do: [:pos | hash := hash + (aString at: pos) asciiValue. "Begin hashMultiply" low := hash bitAnd: 16383. hash := (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF. ]. ^ hash! ! !ByteString class methodsFor: 'primitives' stamp: 'HenrikSperreJohansen 10/25/2010 15:32'! findFirstInString: aString inSet: inclusionMap startingAt: start | i stringSize | inclusionMap size ~= 256 ifTrue: [ ^0 ]. i := start. stringSize := aString size. [ i <= stringSize and: [ (inclusionMap at: (aString at: i) asciiValue+1) = 0 ] ] whileTrue: [ i := i + 1 ]. i > stringSize ifTrue: [ ^0 ]. ^i! ! !ByteString class methodsFor: 'initialization' stamp: 'HenrikSperreJohansen 2/5/2010 20:32'! initialize "ByteString initialize" | latin1 utf8 | NonAsciiMap := ByteArray new: 256. 0 to: 255 do:[:i| i < 128 ifTrue: [ NonAsciiMap at: i +1 put: 0. "valid ascii subset"] ifFalse: [ NonAsciiMap at: i +1 put: 1. "extended charset"]].! ! !ByteString class methodsFor: 'primitives' stamp: 'HenrikSperreJohansen 10/25/2010 15:31'! indexOfAscii: anInteger inString: aString startingAt: start | stringSize | stringSize := aString size. start to: stringSize do: [:pos | (aString at: pos) asciiValue = anInteger ifTrue: [^ pos]]. ^ 0 ! ! !ByteString class methodsFor: 'primitives' stamp: 'HenrikSperreJohansen 10/25/2010 15:32'! compare: string1 with: string2 collated: order "Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array." | len1 len2 c1 c2 | len1 := string1 size. len2 := string2 size. 1 to: (len1 min: len2) do: [:i | c1 := order at: (string1 basicAt: i) + 1. c2 := order at: (string2 basicAt: i) + 1. c1 = c2 ifFalse: [c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]]]. len1 = len2 ifTrue: [^ 2]. len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3]. ! ! !ByteString class methodsFor: 'primitives' stamp: 'HenrikSperreJohansen 10/25/2010 15:32'! translate: aString from: start to: stop table: table "translate the characters in the string by the given table, in place" start to: stop do: [ :i | aString at: i put: (table at: (aString at: i) asciiValue+1) ]! ! !ByteString class methodsFor: 'contants' stamp: 'HenrikSperreJohansen 1/27/2010 17:50'! nonAsciiMap ^NonAsciiMap! ! !ByteString class methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 10:56'! materializeFrom: aDecoder ^ aDecoder nextEncodedString! ! !ByteSymbol commentStamp: ''! This class represents the symbols containing 8bit characters.! !ByteSymbol methodsFor: 'testing' stamp: 'nice 11/9/2009 22:35'! hasWideCharacterFrom: start to: stop "Always false because I only contains byte characters" ^false! ! !ByteSymbol methodsFor: 'testing' stamp: 'ar 4/10/2005 22:14'! isByteString "Answer whether the receiver is a ByteString" ^true! ! !ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:10'! byteAt: index ^(self at: index) asciiValue! ! !ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:51'! species "Answer the preferred class for reconstructing the receiver." ^ByteString ! ! !ByteSymbol methodsFor: 'private' stamp: 'CamilloBruni 9/5/2011 20:04'! string: aString 1 to: aString size do: [:j | self privateAt: j put: (aString at: j)]. ^self! ! !ByteSymbol methodsFor: 'comparing' stamp: 'nice 3/23/2007 00:50'! beginsWith: prefix "Answer whether the receiver begins with the given prefix string. The comparison is case-sensitive." "IMPLEMENTATION NOTE: following algorithm is optimized in primitive only in case self and prefix are bytes like. Otherwise, if self is wide, then super outperforms, Otherwise, if prefix is wide, primitive is not correct" prefix class isBytes ifFalse: [^super beginsWith: prefix]. self size < prefix size ifTrue: [^ false]. ^ (self findSubstring: prefix in: self startingAt: 1 matchTable: CaseSensitiveOrder) = 1 ! ! !ByteSymbol methodsFor: 'private' stamp: 'CamilloBruni 9/5/2011 18:10'! privateAt: index put: aCharacter "Primitive. Store the Character in the field of the receiver indicated by the index. Fail if the index is not an Integer or is out of bounds, or if the argument is not a Character. Essential. See Object documentation whatIsAPrimitive." aCharacter isCharacter ifFalse:[^self errorImproperStore]. index isInteger ifTrue: [self errorSubscriptBounds: index] ifFalse: [self errorNonIntegerIndex]! ! !ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:11'! byteSize ^self size! ! !ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:10'! byteAt: anInteger put: anObject "You cannot modify the receiver." self errorNoModification! ! !ByteSymbol methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitHookPrimitive: self! ! !ByteSymbol methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 10:51'! serializeOn: anEncoder anEncoder encodeString: self! ! !ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:10'! at: index "Primitive. Answer the Character stored in the field of the receiver indexed by the argument. Fail if the index argument is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." ^ Character value: (super at: index)! ! !ByteSymbol methodsFor: 'accessing' stamp: 'nice 12/9/2009 15:40'! indexOfAnyOf: aCollection startingAt: start ifAbsent: aBlock "Use double dispatching for speed" | index | ^(index := aCollection findFirstInByteString: self startingAt: start) = 0 ifTrue: [aBlock value] ifFalse: [index]! ! !ByteSymbol methodsFor: 'testing' stamp: 'ar 4/10/2005 22:14'! isOctetString "Answer whether the receiver can be represented as a byte string. This is different from asking whether the receiver *is* a ByteString (i.e., #isByteString)" ^ true. ! ! !ByteSymbol methodsFor: 'converting' stamp: 'ar 4/10/2005 22:12'! asOctetString ^ self! ! !ByteSymbol methodsFor: 'accessing' stamp: 'nice 12/9/2009 15:40'! indexOfAnyOf: aCollection startingAt: start "Use double dispatching for speed" ^aCollection findFirstInByteString: self startingAt: start! ! !ByteSymbol methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 5/3/2013 15:58'! asKmCategoryIn: aKmRepository ^aKmRepository categoryForName: self! ! !ByteSymbol methodsFor: '*Text-Scanning' stamp: 'nice 10/9/2013 01:47'! scanCharactersFrom: startIndex to: stopIndex with: aCharacterScanner rightX: rightX font: aFont "NB: strongly consider getting almost all these parameters from the scanner" "Since I'm a byte char string, I know that we have to scan single-byte characters and don't have to handle encodings etc" startIndex > stopIndex ifTrue: [^aCharacterScanner handleEndOfRunAt: stopIndex]. ^aFont scanByteCharactersFrom: startIndex to: stopIndex in: self with: aCharacterScanner rightX: rightX! ! !ByteSymbol methodsFor: 'comparing' stamp: 'ar 4/10/2005 22:14'! findSubstring: key in: body startingAt: start matchTable: matchTable "Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned." ^super findSubstring: key in: body startingAt: start matchTable: matchTable! ! !ByteSymbol methodsFor: 'converting' stamp: 'ar 4/10/2005 22:12'! asByteArray | ba sz | sz := self byteSize. ba := ByteArray new: sz. ba replaceFrom: 1 to: sz with: self startingAt: 1. ^ba! ! !ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:46'! stringHash: aString initialHash: speciesHash ^ByteString stringHash: aString initialHash: speciesHash! ! !ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:46'! findFirstInString: aString inSet: inclusionMap startingAt: start ^ByteString findFirstInString: aString inSet: inclusionMap startingAt: start! ! !ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:47'! translate: aString from: start to: stop table: table ^ByteString translate: aString from: start to: stop table: table! ! !ByteSymbol class methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 10:56'! materializeFrom: aDecoder ^ aDecoder nextEncodedString asSymbol! ! !ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:46'! indexOfAscii: anInteger inString: aString startingAt: start ^ByteString indexOfAscii: anInteger inString: aString startingAt: start! ! !ByteSymbolTest commentStamp: 'TorstenBergmann 2/20/2014 15:29'! SUnit tests for byte symbols! !ByteSymbolTest methodsFor: 'test - creation' stamp: 'SheridanMahoney 12/6/2009 17:38'! testNewFrom "self debug: #testNewFrom" | dt newFrom1 newFrom2 | dt := DateAndTime now asString . newFrom1 := ByteSymbol newFrom: dt . self assert: (Symbol allSymbols select: [:e | e asString = dt ] ) size = 1 . self assert: (ByteSymbol allInstances select: [:e | e = dt ] ) size = 1 . self assert: (Symbol allSymbols select: [:e | e asString = dt ] ) = (ByteSymbol allInstances select: [:e | e = dt ] ) . newFrom2 := ByteSymbol newFrom: dt . self assert: (Symbol allSymbols select: [:e | e asString = dt ] ) size = 1 . self assert: (ByteSymbol allInstances select: [:e | e = dt ] ) size = 1 . ! ! !ByteSymbolTest methodsFor: 'test - creation' stamp: 'SheridanMahoney 12/6/2009 17:39'! testAs "self debug: #testAs" | tStr tAs1 tAs2 | tStr := DateAndTime now asString . tAs1 := tStr as: ByteSymbol . self assert: (Symbol allSymbols select: [:e | e asString = tStr ] ) size = 1 . self assert: (ByteSymbol allInstances select: [:e | e asString = tStr] ) size = 1 . self assert: (ByteSymbol allInstances select: [:e | e asString = tStr] ) = (Symbol allSymbols select: [:e | e asString = tStr ] ) . tAs2 := tStr as: ByteSymbol . self assert: (Symbol allSymbols select: [:e | e asString = tStr ] ) size = 1 . self assert: (ByteSymbol allInstances select: [:e | e asString = tStr] ) size = 1 . ! ! !ByteSymbolTest methodsFor: 'test - non-creation' stamp: 'StephaneDucasse 6/9/2012 22:54'! testNew "self debug: #testNew" self should: [ByteSymbol new: 5 ] raise: self defaultTestError. ! ! !ByteSymbolTest methodsFor: 'test - creation' stamp: 'SheridanMahoney 12/6/2009 19:02'! testReadFromString "self debug: #testReadFromString" | str strWithPound readFrom1 readFrom2 | Smalltalk garbageCollect. str := 'notYetExisting' . self assert: (Symbol allSymbols select: [:e | e asString = str ] ) size = 0 . self assert: (ByteSymbol allInstances select: [:e | e asString = str] ) size = 0 . strWithPound := ('#' , str) . readFrom1 := ByteSymbol readFromString: strWithPound . self assert: (Symbol allSymbols select: [:e | e asString = str ] ) size = 1 . self assert: (ByteSymbol allInstances select: [:e | e = str ] ) size = 1 . self assert: (Symbol allSymbols select: [:e | e asString = str ] ) = (ByteSymbol allInstances select: [:e | e = str ] ) . readFrom2 := ByteSymbol readFromString: strWithPound . self assert: (Symbol allSymbols select: [:e | e asString = str ] ) size = 1 . self assert: (ByteSymbol allInstances select: [:e | e = str ] ) size = 1 .! ! !ByteTextConverter commentStamp: 'michael.rueger 1/27/2009 18:00'! A ByteTextConverter is the abstract class for text converters on single byte encodings.! !ByteTextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:10'! unicodeToByte: unicodeChar ^unicodeChar charCode < 128 ifTrue: [unicodeChar] ifFalse: [self class unicodeToByteTable at: unicodeChar charCode ifAbsent: [0 asCharacter]]! ! !ByteTextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:10'! nextPut: unicodeCharacter toStream: aStream "Write the unicode character to aStream." aStream isBinary ifTrue: [aStream basicNextPut: unicodeCharacter charCode] ifFalse: [aStream basicNextPut: (self unicodeToByte: unicodeCharacter)]! ! !ByteTextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:11'! byteToUnicode: char "Map from my byte based encoding to unicode. Due to the leading char encoding this is not strictly true, but hopefully at some point we can get rid of the leading char overhead." | value | value := char charCode. value < 128 ifTrue: [^ char]. value > 255 ifTrue: [^ char]. ^self class byteToUnicodeTable at: (value - 128 + 1)! ! !ByteTextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:11'! nextFromStream: aStream "Read the next byte (we are only dealing with byte based encodings here) character from aStream and return the result converted to unicode." | byteOrChar | byteOrChar := aStream basicNext. aStream isBinary ifTrue: [^byteOrChar]. ^byteOrChar ifNotNil: [self byteToUnicode: byteOrChar]! ! !ByteTextConverter class methodsFor: 'class initialization' stamp: 'michael.rueger 1/27/2009 18:40'! initialize "ByteTextConverter initialize" self allSubclassesDo: [:subclass | subclass initializeTables]! ! !ByteTextConverter class methodsFor: 'class initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 21:56'! initializeTables "Initialize the mappings to and from Unicode." byteToUnicode := Array new: 128. unicodeToByte := Dictionary new. "Mind the offset because first 128 characters are not stored into byteToUnicodeSpec" "Some entries are nil, make them pass-through for compatibility, for now" self byteToUnicodeSpec keysAndValuesDo: [ :index :unicode | | unicodeValue | unicodeValue := unicode ifNil: [ 127 + index ] ifNotNil: [ unicode ]. byteToUnicode at: index put: (Character value: unicodeValue). unicodeToByte at: unicodeValue put: (127 + index) asCharacter ]! ! !ByteTextConverter class methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 3/7/2012 21:50'! unicodeToByteTable "Return the table mapping from unicode to my byte based encoding" ^ unicodeToByte! ! !ByteTextConverter class methodsFor: '*Unicode-Initialization' stamp: 'SvenVanCaekenberghe 1/15/2013 15:03'! parseUnicodeOrgSpec: url "Parse and return a mapping from byte to unicode values from url." "self parseUnicodeOrgSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-2.TXT'." | mapping | mapping := Dictionary new: 256. url asZnUrl retrieveContents linesDo: [ :each | (each isEmpty or: [ each beginsWith: '#' ]) ifFalse: [ | tokens hexReader | hexReader := [ :string | Integer readFrom: (string readStream skip: 2; yourself) base: 16 ]. tokens := each findTokens: String tab. (tokens last = '' or: [ tokens last = '#UNDEFINED' ]) ifFalse: [ mapping at: (hexReader value: tokens first) put: (hexReader value: tokens second) ] ] ]. ^ mapping ! ! !ByteTextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 1/30/2009 11:01'! languageEnvironment self subclassResponsibility! ! !ByteTextConverter class methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 3/7/2012 21:49'! byteToUnicodeTable "Return the table mapping from my byte based encoding to unicode" ^ byteToUnicode! ! !ByteTextConverter class methodsFor: '*Unicode-Initialization' stamp: 'ClementBera 7/26/2013 16:34'! generateByteToUnicodeSpec: url "Return the formatted source code for an array mapping the top 128 byte to unicode values from a Unicode.org url" "self generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-2.TXT'." | mapping | mapping := self parseUnicodeOrgSpec: url. ^ String streamContents: [ :stream | stream tab; << '"'; << self name; << ' generateByteToUnicodeSpec: '; print: url; << '"'; cr; cr; tab; << '^ #('. 128 to: 255 do: [ :each | | unicode | each \\ 8 = 0 ifTrue: [ stream cr; tab ]. (unicode := mapping at: each ifAbsent: [ nil ]) ifNil: [ stream print: nil; space ] ifNotNil: [ stream << '16r' << (unicode printPaddedWith: $0 to: 4 base: 16); space ] ]. stream nextPut: $); cr ]! ! !ByteTextConverter class methodsFor: 'class initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 21:42'! byteToUnicodeSpec "Sepcify a table mapping the entries 0x80 to 0xFF to their unicode counterparts by returning a 128 element array.. The entries 0x00 to 0x7F map to identical values so we don't need to specify them. See #generateByteToUnicodeSpec: for an automated way to generate these mappings." self subclassResponsibility! ! !ByteTextConverterTest commentStamp: 'TorstenBergmann 2/5/2014 10:18'! SUnit tests for ByteTextConverter! !ByteTextConverterTest methodsFor: 'testing' stamp: 'HenrikSperreJohansen 6/25/2012 12:55'! testUnicodeToLatin2Conversion | latin2Bytes internalString encodingStream encodedBytes | latin2Bytes := #[16rBE 16rFD 16rE1 16rC8] . internalString := String streamContents: [:s | s nextPut: 16r017E asCharacter; nextPut: 16rFD asCharacter; nextPut: 16rE1 asCharacter; nextPut: 16r010C asCharacter]. "Converters assume that characters you want to put/get from a stream are Unicode characters" "So we use a stream with an encoder, then put the internalString to it" encodingStream := (MultiByteBinaryOrTextStream with: String new encoding: 'ISO-8859-2') reset. encodingStream nextPutAll: internalString. "the encoded string in the stream does not contain any characters > 255" encodedBytes := encodingStream binary reset contents. self assert: (encodedBytes at: 1) = (latin2Bytes at: 1) . self assert: (encodedBytes at: 2) = (latin2Bytes at: 2) . self assert: (encodedBytes at: 3) = (latin2Bytes at: 3) . self assert: (encodedBytes at: 4) = (latin2Bytes at: 4) .! ! !ByteTextConverterTest methodsFor: 'testing' stamp: 'HenrikSperreJohansen 6/25/2012 12:43'! testLatin2ToUnicodeConversion | latin2Characters utfCodePoints decodingStream unicodeString | latin2Characters := #[16rBE 16rFD 16rE1 16rC8] asString. utfCodePoints := #(16r017E 16rFD 16rE1 16r010C). "Converters assume that characters you want to put/get from a stream are Unicode characters" "So our source is a string of latin 2" decodingStream := (MultiByteBinaryOrTextStream with: latin2Characters encoding: 'ISO-8859-2') reset. unicodeString := decodingStream contents. "our sourcelatin2 string contains characters outside latin1" self assert: unicodeString isWideString. self assert: (unicodeString at: 1) charCode = (utfCodePoints at: 1) . self assert: (unicodeString at: 2) charCode = (utfCodePoints at: 2) . self assert: (unicodeString at: 3) charCode = (utfCodePoints at: 3) . self assert: (unicodeString at: 4) charCode = (utfCodePoints at: 4) .! ! !ByteTextConverterTest methodsFor: 'testing' stamp: 'nice 7/26/2009 22:44'! testConversionToFrom "Non regresson test for http://code.google.com/p/pharo/issues/detail?id=986" self assert: (('äöü' convertToEncoding: 'mac-roman') convertFromEncoding: 'mac-roman') = 'äöü'! ! !BytecodeEncoder commentStamp: ''! I am an abstract superclass for different bytecode set encoders. Subclasses inherit the literal management of Encoder and encapsulate the mapping of opcodes to specific bytecodes.! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:26'! sizePushTemp: tempIndex ^self sizeOpcodeSelector: #genPushTemp: withArguments: {tempIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 16:11'! sizeSend: selectorLiteralIndex numArgs: nArgs ^self sizeOpcodeSelector: #genSend:numArgs: withArguments: {selectorLiteralIndex. nArgs}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 6/19/2008 08:54'! sizeStorePopInstVarLong: instVarIndex ^self sizeOpcodeSelector: #genStorePopInstVarLong: withArguments: {instVarIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/24/2008 22:59'! sizePushRemoteTemp: tempIndex inVectorAt: tempVectorIndex ^self sizeOpcodeSelector: #genPushRemoteTemp:inVectorAt: withArguments: {tempIndex. tempVectorIndex}! ! !BytecodeEncoder methodsFor: 'temps' stamp: 'ClementBera 7/26/2013 16:06'! bindBlockArg: name within: aBlockNode "Read the comment in the superclass's method. If we have closures we should check the argument count against the block, not the method. (Note that this isn't entirely adequate either since optimized blocks will slip through the cracks (their arguments (i.e. ifNotNil: [:expr|) are charged against their enclosing block, not themselves))." | nArgs | self supportsClosureOpcodes ifFalse: [^super bindBlockArg: name within: aBlockNode]. (nArgs := aBlockNode nArgsSlot) ifNil: [aBlockNode nArgsSlot: (nArgs := 0)]. nArgs >= 15 ifTrue: [^self notify: 'Too many arguments']. aBlockNode nArgsSlot: nArgs + 1. ^(self bindTemp: name) beBlockArg; nowHasDef; nowHasRef; yourself! ! !BytecodeEncoder methodsFor: 'temps' stamp: 'eem 6/3/2008 12:33'! noteBlockExtent: blockExtent hasLocals: tempNodes blockExtentsToLocals ifNil: [blockExtentsToLocals := Dictionary new]. blockExtentsToLocals at: blockExtent put: tempNodes asArray! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:40'! sizeJumpLong: distance ^self sizeOpcodeSelector: #genJumpLong: withArguments: {distance}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:28'! sizePushThisContext ^self sizeOpcodeSelector: #genPushThisContext withArguments: #()! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/15/2008 09:07'! sizeReturnReceiver ^self sizeOpcodeSelector: #genReturnReceiver withArguments: #()! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/15/2008 09:06'! sizeReturnTopToCaller ^self sizeOpcodeSelector: #genReturnTopToCaller withArguments: #()! ! !BytecodeEncoder methodsFor: 'testing' stamp: 'eem 7/17/2008 12:34'! supportsClosureOpcodes "Answer if the receiver supports the genPushNewArray:/genPushConsArray: genPushRemoteTemp:inVectorAt: genStoreRemoteTemp:inVectorAt: genStorePopRemoteTemp:inVectorAt: genPushClosureCopyCopiedValues:numArgs:jumpSize: opcodes" ^false! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 18:22'! sizeBranchPopFalse: distance ^self sizeOpcodeSelector: #genBranchPopFalse: withArguments: {distance}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:44'! sizeStoreInstVar: instVarIndex ^self sizeOpcodeSelector: #genStoreInstVar: withArguments: {instVarIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:37'! sizePushSpecialLiteral: specialLiteral ^self sizeOpcodeSelector: #genPushSpecialLiteral: withArguments: {specialLiteral}! ! !BytecodeEncoder methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:52'! outOfRangeError: string index: index range: rangeStart to: rangeEnd "For now..." ^self error: thisContext sender method selector, ' ', string , ' index ', index printString , ' is out of range ', rangeStart printString, ' to ', rangeEnd printString! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:43'! sizePushLiteralVar: literalIndex ^self sizeOpcodeSelector: #genPushLiteralVar: withArguments: {literalIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:43'! sizeStoreLiteralVar: literalIndex ^self sizeOpcodeSelector: #genStoreLiteralVar: withArguments: {literalIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:40'! sizeJump: distance ^self sizeOpcodeSelector: #genJump: withArguments: {distance}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/30/2008 16:36'! sizePushConsArray: numElements ^self sizeOpcodeSelector: #genPushConsArray: withArguments: {numElements}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:45'! sizeStoreTemp: tempIndex ^self sizeOpcodeSelector: #genStoreTemp: withArguments: {tempIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/24/2008 12:35'! sizePushNewArray: size ^self sizeOpcodeSelector: #genPushNewArray: withArguments: {size}! ! !BytecodeEncoder methodsFor: 'temps' stamp: 'Alexandre Bergel 5/22/2010 12:47'! blockExtentsToTempsMap "Answer a Dictionary of blockExtent to temp locations for the current method. This is used by the debugger to locate temp vars in contexts. A temp map entry is a pair of the temp's name and its index, where an index is either an integer for a normal temp or a pair of the index of the indirect temp vector containing the temp and the index of the temp in its indirect temp vector." | blockExtentsToTempsMap | blockExtentsToLocals ifNil: [^nil]. blockExtentsToTempsMap := Dictionary new. blockExtentsToLocals keysAndValuesDo: [:blockExtent :locals| blockExtentsToTempsMap at: blockExtent put: (Array streamContents: [:str| locals withIndexDo: [:local :index| local isIndirectTempVector ifTrue: [local remoteTemps withIndexDo: [:remoteLocal :innerIndex| str nextPut: { remoteLocal key. { index. innerIndex } }]] ifFalse: [str nextPut: { local key. index }]]])]. ^blockExtentsToTempsMap! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 16:22'! sizePushInstVar: instVarIndex ^self sizeOpcodeSelector: #genPushInstVar: withArguments: {instVarIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 6/19/2008 08:54'! sizePushInstVarLong: instVarIndex ^self sizeOpcodeSelector: #genPushInstVarLong: withArguments: {instVarIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:36'! sizeStorePopTemp: tempIndex ^self sizeOpcodeSelector: #genStorePopTemp: withArguments: {tempIndex}! ! !BytecodeEncoder methodsFor: 'temps' stamp: 'ClementBera 7/26/2013 16:06'! bindBlockTemp: name within: aBlockNode "Read the comment in the superclass's bindBlockArg:within: method. If we have closures we should check the argument count against the block, not the method. (Note that this isn't entirely adequate either since optimized blocks will slip through the cracks (their arguments (i.e. ifNotNil: [:expr|) are charged against their enclosing block, not themselves))." | nArgs | self supportsClosureOpcodes ifFalse: [^super bindBlockTemp: name within: aBlockNode]. (nArgs := aBlockNode nArgsSlot) ifNil: [aBlockNode nArgsSlot: (nArgs := 0)]. nArgs >= (CompiledMethod fullFrameSize - 1) ifTrue: [^self notify: 'Too many temporaries']. aBlockNode nArgsSlot: nArgs + 1. ^self bindTemp: name! ! !BytecodeEncoder methodsFor: 'testing' stamp: 'eem 6/29/2009 11:11'! hasGeneratedMethod ^blockExtentsToLocals notNil! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 7/27/2008 00:39'! sizeOpcodeSelector: genSelector withArguments: args stream := self. position := 0. self perform: genSelector withArguments: args. ^position! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 16:21'! sizePushReceiver ^self sizeOpcodeSelector: #genPushReceiver withArguments: #()! ! !BytecodeEncoder methodsFor: 'initialize-release' stamp: 'eem 7/24/2008 17:24'! streamToMethod: aCompiledMethod stream := WriteStream with: aCompiledMethod. stream position: aCompiledMethod initialPC - 1! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:43'! sizePushLiteral: literalIndex ^self sizeOpcodeSelector: #genPushLiteral: withArguments: {literalIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:28'! sizePop ^self sizeOpcodeSelector: #genPop withArguments: #()! ! !BytecodeEncoder methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:56'! rootNode: node "" rootNode := node! ! !BytecodeEncoder methodsFor: 'temps' stamp: 'eem 6/23/2008 10:55'! bindAndJuggle: name "This is used to insert a new temp and reorcder temps on editing. It doesn't really work for closure compilation since we have multiple locations for temps. Simply signal a reparse is necessary." ReparseAfterSourceEditing signal! ! !BytecodeEncoder methodsFor: 'special literal encodings' stamp: 'eem 5/14/2008 17:49'! if: code isSpecialLiteralForReturn: aBlock "If code is that of a special literal for return then evaluate aBlock with the special literal. The special literals for return are nil true false which have special encodings in the blue book bytecode set. Answer whether it was a special literal." ^(code between: LdTrue and: LdNil) and: [aBlock value: (#(true false nil) at: code - LdSelf). true]! ! !BytecodeEncoder methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:56'! rootNode "^" ^rootNode! ! !BytecodeEncoder methodsFor: 'special literal encodings' stamp: 'eem 5/14/2008 16:02'! if: code isSpecialLiteralForPush: aBlock "If code is that of a special literal for push then evaluate aBlock with the special literal The special literals for push are nil true false -1 0 1 & 2 which have special encodings in the blue book bytecode set. Answer whether it was a special literal." ^(code between: LdTrue and: LdNil + 4) and: [aBlock value: (#(true false nil -1 0 1 2) at: code - LdSelf). true]! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/15/2008 10:00'! sizeStorePopInstVar: instVarIndex ^self sizeOpcodeSelector: #genStorePopInstVar: withArguments: {instVarIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/15/2008 10:20'! sizeStorePopLiteralVar: literalIndex ^self sizeOpcodeSelector: #genStorePopLiteralVar: withArguments: {literalIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/30/2008 16:46'! sizePushClosureCopyNumCopiedValues: numCopied numArgs: numArgs jumpSize: jumpSize ^self sizeOpcodeSelector: #genPushClosureCopyNumCopiedValues:numArgs:jumpSize: withArguments: {numCopied. numArgs. jumpSize}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 7/27/2008 00:39'! nextPut: aByte "For sizing make the encoder its own stream and keep track of position with this version of nextPut:" position := position + 1! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/24/2008 23:02'! sizeStorePopRemoteTemp: tempIndex inVectorAt: tempVectorIndex ^self sizeOpcodeSelector: #genStorePopRemoteTemp:inVectorAt: withArguments: {tempIndex. tempVectorIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 6/19/2008 08:54'! sizeStoreInstVarLong: instVarIndex ^self sizeOpcodeSelector: #genStoreInstVarLong: withArguments: {instVarIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 16:11'! sizeSendSuper: selectorLiteralIndex numArgs: nArgs ^self sizeOpcodeSelector: #genSendSuper:numArgs: withArguments: {selectorLiteralIndex. nArgs}! ! !BytecodeEncoder methodsFor: 'accessing' stamp: 'eem 5/14/2008 17:47'! methodStreamPosition ^stream position! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:34'! sizeReturnTop ^self sizeOpcodeSelector: #genReturnTop withArguments: #()! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:28'! sizeDup ^self sizeOpcodeSelector: #genDup withArguments: #()! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 18:22'! sizeBranchPopTrue: distance ^self sizeOpcodeSelector: #genBranchPopTrue: withArguments: {distance}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/24/2008 23:02'! sizeStoreRemoteTemp: tempIndex inVectorAt: tempVectorIndex ^self sizeOpcodeSelector: #genStoreRemoteTemp:inVectorAt: withArguments: {tempIndex. tempVectorIndex}! ! !BytecodeEncoder methodsFor: 'temps' stamp: 'JorgeRessia 3/13/2010 16:09'! bindTemp: name "Declare a temporary; error not if a field or class variable or out-of-scope temp. Read the comment in Encoder5>>bindBlockArg:within: and subclass implementations." self supportsClosureOpcodes ifFalse: [^super bindTemp: name]. scopeTable at: name ifPresent: [:node| (requestor interactive) ifTrue: [self evaluateShadowingInteractivelyOf: node] ifFalse: [self evaluateShadowingNotInteractivelyOf: node] ]. ^self reallyBind: name! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:38'! sizeReturnSpecialLiteral: specialLiteral ^self sizeOpcodeSelector: #genReturnSpecialLiteral: withArguments: {specialLiteral}! ! !CCompilationContext commentStamp: ''! I am a copy of the CompilationContext. It is used -> in the old Compiler so it is independed from Opal -> in the new Compiler the class CompilationContext parametrizes Opal to use this Context so it can add instance variables to the context. The second option is a workaround, we will need a copy of Opak to develop itself *or* need to add transactions to the language ;--)! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:11'! optionInlineCase ^ options includes: #optionInlineCase ! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 9/30/2013 14:42'! optionInlineTimesRepeat ^ options includes: #optionInlineTimesRepeat ! ! !CCompilationContext methodsFor: 'accessing' stamp: 'ClementBera 6/7/2013 09:56'! compiledMethodTrailer: anObject compiledMethodTrailer := anObject! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! logged ^logged ifNil: [ false ].! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! logged: anObject logged := anObject! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 15:47'! astTranslatorClass ^ astTranslatorClass ifNil: [ astTranslatorClass := OCASTTranslator ]! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:12'! optionInlineWhile ^ options includes: #optionInlineWhile ! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:12'! optionLongIvarAccessBytecodes ^ options includes: #optionLongIvarAccessBytecodes ! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! environment ^ environment! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 5/26/2013 09:29'! doesNotUnderstand: message (message selector isUnary and: [ message selector beginsWith: 'opt'] ) ifTrue: [ ^ options includes: message selector ]. ^ super doesNotUnderstand: message! ! !CCompilationContext methodsFor: 'initialization' stamp: 'MarcusDenker 5/26/2013 09:29'! initialize options := Set new! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! requestor ^ requestor! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! environment: anObject environment := anObject! ! !CCompilationContext methodsFor: 'accessing' stamp: 'ClementBera 6/7/2013 10:00'! compiledMethodTrailer ^ compiledMethodTrailer ifNil: [ compiledMethodTrailer := CompiledMethodTrailer empty ]! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 6/14/2013 15:49'! parserClass ^ parserClass ifNil: [ parserClass := RBExplicitVariableParser ]! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:11'! optionInlineAndOr ^ options includes: #optionInlineAndOr ! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:11'! optionInlineIfNil ^ options includes: #optionInlineIfNil ! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! failBlock: anObject failBlock := anObject! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! requestor: anObject requestor := anObject! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! scope | newScope | newScope := OCClassScope for: class. requestor ifNotNil: [ "the requestor is allowed to manage variables, the workspace is using it to auto-define vars" newScope := (OCRequestorScope new requestor: requestor) outerScope: newScope]. ^newScope ! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 15:48'! bytecodeGeneratorClass: anObject bytecodeGeneratorClass := anObject! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 5/26/2013 09:29'! compilerOptions: anArray self parseOptions: anArray! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 15:50'! parserClass: anObject parserClass := anObject! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:11'! optionInlineToDo ^ options includes: #optionInlineToDo ! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! category ^ category! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! noPattern: anObject noPattern := anObject! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 15:47'! astTranslatorClass: anObject astTranslatorClass := anObject! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 15:48'! bytecodeGeneratorClass ^ bytecodeGeneratorClass ifNil: [ bytecodeGeneratorClass := IRBytecodeGenerator ]! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 15:51'! semanticAnalyzerClass: anObject semanticAnalyzerClass := anObject! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! interactive: anObject interactive := anObject! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:11'! optionIlineNone ^ options includes: #optionIlineNone ! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! getClass ^ class! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 15:50'! semanticAnalyzerClass ^ semanticAnalyzerClass ifNil: [ semanticAnalyzerClass := OCASTSemanticAnalyzer ]! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:11'! optionInlineIf ^ options includes: #optionInlineIf ! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:12'! optionOptimizeIR ^ options includes: #optionOptimizeIR ! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! class: anObject class := anObject! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! interactive ^ interactive ifNil: [ false ]! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! failBlock ^ failBlock! ! !CCompilationContext methodsFor: 'options' stamp: 'MarcusDenker 5/26/2013 09:29'! parseOptions: optionsArray "parse an array, which is a sequence of options in a form of: #( + option1 option2 - option3 ... ) each time the #+ is seen, the options which follow it will be subject for inclusion and, correspondingly, if #- seen, then they will be excluded . By default, (if none of #+ or #- specified initially), all options are subject for inclusion. " | include | include := true. optionsArray do: [:option | option == #+ ifTrue: [ include := true ] ifFalse: [ option == #- ifTrue: [ include := false ] ifFalse: [ include ifTrue: [ options add: option ] ifFalse: [ options remove: option ifAbsent:[] ]]] ].! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! noPattern ^noPattern ifNil: [ false ].! ! !CCompilationContext methodsFor: 'accessing' stamp: 'ClementBera 11/26/2013 13:42'! warningAllowed ^ self class warningAllowed! ! !CCompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:29'! category: anObject category := anObject! ! !CCompilationContext class methodsFor: 'accessing' stamp: 'ClementBera 11/26/2013 13:42'! warningAllowed: aBoolean WarningAllowed := aBoolean! ! !CCompilationContext class methodsFor: 'instance creation' stamp: 'MarcusDenker 5/26/2013 09:29'! default ^ self new parseOptions: OpalCompiler defaultOptions! ! !CCompilationContext class methodsFor: 'compiler' stamp: 'MarcusDenker 5/26/2013 09:56'! compiler ^self compilerClass new compilationContextClass: CompilationContext; environment: self environment; class: self! ! !CCompilationContext class methodsFor: 'accessing' stamp: 'ClementBera 11/26/2013 13:42'! warningAllowed ^ WarningAllowed ifNil: [ WarningAllowed := true ]! ! !CNGBTextConverter commentStamp: ''! Text converter for Simplified Chinese variation of EUC. (Even though the name doesn't look so, it is what it is.)! !CNGBTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 14:42'! leadingChar ^ GB2312 leadingChar ! ! !CNGBTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'! languageEnvironment ^ SimplifiedChineseEnvironment. ! ! !CNGBTextConverter class methodsFor: 'utilities' stamp: 'yo 10/23/2002 14:42'! encodingNames ^ #('gb2312' ) copy ! ! !CP1250TextConverter commentStamp: ''! Text converter for CP1250. Windows code page used in Eastern Europe.! !CP1250TextConverter class methodsFor: 'as yet unclassified' stamp: ''! initialize self initializeTables! ! !CP1250TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 1/30/2009 11:02'! languageEnvironment ^Latin2Environment! ! !CP1250TextConverter class methodsFor: 'accessing' stamp: 'pk 1/19/2005 14:35'! encodingNames ^ #('cp-1250') copy ! ! !CP1250TextConverter class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 21:36'! byteToUnicodeSpec "ByteTextConverter generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1250.TXT'" ^ #( 16r20AC nil 16r201A nil 16r201E 16r2026 16r2020 16r2021 nil 16r2030 16r0160 16r2039 16r015A 16r0164 16r017D 16r0179 nil 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 nil 16r2122 16r0161 16r203A 16r015B 16r0165 16r017E 16r017A 16r00A0 16r02C7 16r02D8 16r0141 16r00A4 16r0104 16r00A6 16r00A7 16r00A8 16r00A9 16r015E 16r00AB 16r00AC 16r00AD 16r00AE 16r017B 16r00B0 16r00B1 16r02DB 16r0142 16r00B4 16r00B5 16r00B6 16r00B7 16r00B8 16r0105 16r015F 16r00BB 16r013D 16r02DD 16r013E 16r017C 16r0154 16r00C1 16r00C2 16r0102 16r00C4 16r0139 16r0106 16r00C7 16r010C 16r00C9 16r0118 16r00CB 16r011A 16r00CD 16r00CE 16r010E 16r0110 16r0143 16r0147 16r00D3 16r00D4 16r0150 16r00D6 16r00D7 16r0158 16r016E 16r00DA 16r0170 16r00DC 16r00DD 16r0162 16r00DF 16r0155 16r00E1 16r00E2 16r0103 16r00E4 16r013A 16r0107 16r00E7 16r010D 16r00E9 16r0119 16r00EB 16r011B 16r00ED 16r00EE 16r010F 16r0111 16r0144 16r0148 16r00F3 16r00F4 16r0151 16r00F6 16r00F7 16r0159 16r016F 16r00FA 16r0171 16r00FC 16r00FD 16r0163 16r02D9 )! ! !CP1252TextConverter commentStamp: ''! Text converter for CP1252. Windows code page used in Western Europe.! !CP1252TextConverter class methodsFor: 'initialization' stamp: 'pmm 8/16/2010 10:58'! initialize self initializeTables! ! !CP1252TextConverter class methodsFor: 'accessing' stamp: 'pmm 8/16/2010 10:30'! languageEnvironment ^Latin9Environment! ! !CP1252TextConverter class methodsFor: 'accessing' stamp: 'pmm 8/16/2010 10:59'! encodingNames ^ #('cp-1252') copy ! ! !CP1252TextConverter class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 21:37'! byteToUnicodeSpec "ByteTextConverter generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1252.TXT'" ^ #( 16r20AC nil 16r201A 16r0192 16r201E 16r2026 16r2020 16r2021 16r02C6 16r2030 16r0160 16r2039 16r0152 nil 16r017D nil nil 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 16r02DC 16r2122 16r0161 16r203A 16r0153 nil 16r017E 16r0178 16r00A0 16r00A1 16r00A2 16r00A3 16r00A4 16r00A5 16r00A6 16r00A7 16r00A8 16r00A9 16r00AA 16r00AB 16r00AC 16r00AD 16r00AE 16r00AF 16r00B0 16r00B1 16r00B2 16r00B3 16r00B4 16r00B5 16r00B6 16r00B7 16r00B8 16r00B9 16r00BA 16r00BB 16r00BC 16r00BD 16r00BE 16r00BF 16r00C0 16r00C1 16r00C2 16r00C3 16r00C4 16r00C5 16r00C6 16r00C7 16r00C8 16r00C9 16r00CA 16r00CB 16r00CC 16r00CD 16r00CE 16r00CF 16r00D0 16r00D1 16r00D2 16r00D3 16r00D4 16r00D5 16r00D6 16r00D7 16r00D8 16r00D9 16r00DA 16r00DB 16r00DC 16r00DD 16r00DE 16r00DF 16r00E0 16r00E1 16r00E2 16r00E3 16r00E4 16r00E5 16r00E6 16r00E7 16r00E8 16r00E9 16r00EA 16r00EB 16r00EC 16r00ED 16r00EE 16r00EF 16r00F0 16r00F1 16r00F2 16r00F3 16r00F4 16r00F5 16r00F6 16r00F7 16r00F8 16r00F9 16r00FA 16r00FB 16r00FC 16r00FD 16r00FE 16r00FF )! ! !CP1253TextConverter commentStamp: ''! Text converter for CP1253. Windows code page used for Greek. ! !CP1253TextConverter class methodsFor: 'as yet unclassified' stamp: ''! initialize self initializeTables! ! !CP1253TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:49'! languageEnvironment ^GreekEnvironment! ! !CP1253TextConverter class methodsFor: 'accessing' stamp: 'yo 2/19/2004 10:11'! encodingNames ^ #('cp-1253') copy ! ! !CP1253TextConverter class methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 3/7/2012 21:37'! byteToUnicodeSpec "ByteTextConverter generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1253.TXT'" ^ #( 16r20AC nil 16r201A 16r0192 16r201E 16r2026 16r2020 16r2021 nil 16r2030 nil 16r2039 nil nil nil nil nil 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 nil 16r2122 nil 16r203A nil nil nil nil 16r00A0 16r0385 16r0386 16r00A3 16r00A4 16r00A5 16r00A6 16r00A7 16r00A8 16r00A9 nil 16r00AB 16r00AC 16r00AD 16r00AE 16r2015 16r00B0 16r00B1 16r00B2 16r00B3 16r0384 16r00B5 16r00B6 16r00B7 16r0388 16r0389 16r038A 16r00BB 16r038C 16r00BD 16r038E 16r038F 16r0390 16r0391 16r0392 16r0393 16r0394 16r0395 16r0396 16r0397 16r0398 16r0399 16r039A 16r039B 16r039C 16r039D 16r039E 16r039F 16r03A0 16r03A1 nil 16r03A3 16r03A4 16r03A5 16r03A6 16r03A7 16r03A8 16r03A9 16r03AA 16r03AB 16r03AC 16r03AD 16r03AE 16r03AF 16r03B0 16r03B1 16r03B2 16r03B3 16r03B4 16r03B5 16r03B6 16r03B7 16r03B8 16r03B9 16r03BA 16r03BB 16r03BC 16r03BD 16r03BE 16r03BF 16r03C0 16r03C1 16r03C2 16r03C3 16r03C4 16r03C5 16r03C6 16r03C7 16r03C8 16r03C9 16r03CA 16r03CB 16r03CC 16r03CD 16r03CE nil )! ! !CPUWatcher commentStamp: 'VeronicaUquillas 6/11/2010 12:47'! CPUWatcher implements a simple runaway process monitoring tool that will suspend a process that is taking up too much of Pharo's time and allow user interaction. By default it watches for a Process that is taking more than 80% of the time; this threshold can be changed. CPUWatcher can also be used to show cpu percentages for each process from within the ProcessBrowser. CPUWatcher startMonitoring. "process period 20 seconds, sample rate 100 msec" CPUWatcher current monitorProcessPeriod: 10 sampleRate: 20. CPUWatcher current threshold: 0.5. "change from 80% to 50%" CPUWatcher stopMonitoring. ! !CPUWatcher methodsFor: 'startup-shutdown' stamp: 'IgorStasenko 3/6/2011 18:11'! stopMonitoring watcher ifNotNil: [ self processBrowser terminateProcess: watcher. watcher := nil. ]! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:36'! tally ^tally copy! ! !CPUWatcher methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! threshold: thresh "What fraction of the time can a process be the active process before we stop it?" threshold := (thresh max: 0.02) min: 1.0! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'GuillermoPolito 5/29/2011 14:46'! openMorphicWindowForSuspendedProcess: aProcess | menu rules | menu := UIManager default newMenuIn: self for: self. "nickname allow-stop allow-debug" rules := self processBrowser nameAndRulesFor: aProcess. menu add: 'Dismiss this menu' target: menu selector: #delete; addLine. menu add: 'Open Process Browser' target: self processBrowser selector: #open. menu add: 'Resume' target: self selector: #resumeProcess:fromMenu: argumentList: { aProcess . menu }. menu add: 'Terminate' target: self selector: #terminateProcess:fromMenu: argumentList: { aProcess . menu }. rules third ifTrue: [ menu add: 'Debug at a lower priority' target: self selector: #debugProcess:fromMenu: argumentList: { aProcess . menu }. ]. menu addTitle: aProcess identityHash asString, ' ', rules first, ' is taking too much time and has been suspended. What do you want to do with it?'. menu stayUp: true. menu popUpInWorld ! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/14/2001 07:56'! isMonitoring ^watcher notNil! ! !CPUWatcher methodsFor: 'process operations' stamp: 'IgorStasenko 3/6/2011 18:11'! resumeProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. self processBrowser resumeProcess: aProcess.! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:49'! threshold "What fraction of the time can a process be the active process before we stop it?" ^threshold! ! !CPUWatcher methodsFor: 'startup-shutdown' stamp: 'nk 3/14/2001 08:07'! startMonitoring self monitorProcessPeriod: 20 sampleRate: 100! ! !CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:27'! debugProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. self debugProcess: aProcess.! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'CamilloBruni 8/21/2013 19:22'! catchThePig: aProcess | rules | "nickname, allow-stop, allow-debug" rules := self processBrowser nameAndRulesFor: aProcess. (self processBrowser isUIProcess: aProcess) ifTrue: [ "aProcess debugWithTitle: 'Interrupted from the CPUWatcher'." ] ifFalse: [ rules second ifFalse: [ ^self ]. self processBrowser suspendProcess: aProcess. self openWindowForSuspendedProcess: aProcess ] ! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/14/2001 08:26'! watcherProcess ^watcher! ! !CPUWatcher methodsFor: 'accessing' stamp: 'IgorStasenko 3/6/2011 18:10'! processBrowser ^ Smalltalk tools processBrowser! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'MarcusDenker 9/28/2013 13:50'! findThePig "tally has been updated. Look at it to see if there is a bad process. This runs at a very high priority, so make it fast" | countAndProcess process | countAndProcess := tally sortedCounts first. countAndProcess key / tally size > self threshold ifFalse: [ ^ self ]. process := countAndProcess value. process == Processor backgroundProcess ifTrue: [ ^ self ]. "idle process? OK" self catchThePig: process! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'AlainPlantec 7/9/2013 11:09'! openWindowForSuspendedProcess: aProcess UIManager default defer: [ self openMorphicWindowForSuspendedProcess: aProcess ] ! ! !CPUWatcher methodsFor: 'process operations' stamp: 'IgorStasenko 3/6/2011 18:10'! debugProcess: aProcess | uiPriority oldPriority | uiPriority := Processor activeProcess priority. aProcess priority >= uiPriority ifTrue: [ oldPriority := self processBrowser setProcess: aProcess toPriority: uiPriority - 1 ]. self processBrowser debugProcess: aProcess.! ! !CPUWatcher methodsFor: 'startup-shutdown' stamp: 'sd 11/20/2005 21:27'! monitorProcessPeriod: secs sampleRate: msecs self stopMonitoring. watcher := [ [ | promise | promise := Processor tallyCPUUsageFor: secs every: msecs. tally := promise value. promise := nil. self findThePig. ] repeat ] forkAt: Processor highestPriority. Processor yield ! ! !CPUWatcher methodsFor: 'process operations' stamp: 'IgorStasenko 3/6/2011 18:11'! terminateProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. self processBrowser terminateProcess: aProcess.! ! !CPUWatcher class methodsFor: 'monitoring' stamp: 'sd 11/20/2005 21:28'! stopMonitoring "CPUWatcher stopMonitoring" CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher stopMonitoring. ]. CurrentCPUWatcher := nil. ! ! !CPUWatcher class methodsFor: 'system startup' stamp: 'nk 6/18/2003 07:14'! shutDown self stopMonitoring.! ! !CPUWatcher class methodsFor: 'testing' stamp: 'nk 3/14/2001 08:06'! isMonitoring ^CurrentCPUWatcher notNil and: [ CurrentCPUWatcher isMonitoring ] ! ! !CPUWatcher class methodsFor: 'setting' stamp: 'AlainPlantec 12/5/2009 19:44'! cpuWatcherEnabled: aBoolean CpuWatcherEnabled = aBoolean ifTrue: [^ self]. CpuWatcherEnabled := aBoolean. self monitorPreferenceChanged ! ! !CPUWatcher class methodsFor: 'startup-shutdown' stamp: 'nk 3/14/2001 08:17'! startMonitoring "CPUWatcher startMonitoring" ^self startMonitoringPeriod: 20 rate: 100 threshold: 0.8! ! !CPUWatcher class methodsFor: 'class initialization' stamp: 'nk 6/18/2003 07:15'! initialize "CPUWatcher initialize" Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self.! ! !CPUWatcher class methodsFor: 'system startup' stamp: 'nk 6/18/2003 07:14'! startUp self monitorPreferenceChanged.! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:28'! startMonitoringPeriod: pd rate: rt threshold: th "CPUWatcher startMonitoring" CurrentCPUWatcher ifNotNil: [ ^CurrentCPUWatcher startMonitoring. ]. CurrentCPUWatcher := (self new) monitorProcessPeriod: pd sampleRate: rt; threshold: th; yourself. ^CurrentCPUWatcher ! ! !CPUWatcher class methodsFor: 'setting' stamp: 'AlainPlantec 12/5/2009 19:43'! monitorPreferenceChanged self cpuWatcherEnabled ifTrue: [ self startMonitoring ] ifFalse: [ self stopMonitoring ]! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:28'! currentWatcherProcess ^CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher watcherProcess ] ! ! !CPUWatcher class methodsFor: 'setting' stamp: 'AlainPlantec 12/5/2009 19:42'! cpuWatcherEnabled ^ CpuWatcherEnabled ifNil: [CpuWatcherEnabled := false]! ! !CPUWatcher class methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:45'! current ^CurrentCPUWatcher ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 3/6/2011 18:11'! dumpTallyOnTranscript self current ifNotNil: [ self processBrowser dumpTallyOnTranscript: self current tally ]! ! !CRC commentStamp: ''! Parameterized implementation of the cyclic redundancy check (CRC) algorithm. INTRODUCTION ================= This implementation is based on the (awesome) paper "A Painless Guide to CRC Error Detection Algorithms" by Ross Williams. You should find a copy of the paper here: http://www.ross.net/crc/. In this paper Ross describes a parameterized implementation that enables the different variations of the CRC algorithm to be used in a consistent way, simply by adjusting the parameters. If you don't have a clue about CRC (like me) then I strongly suggest reading the paper. It will also help you to understand how to make the best use of this implementation. The "CRC RevEng" project on sourceforge implements Williams's "RockSoft" parameterized CRC program (as does this class) and comes with a handy list of parameters for various CRC algorithm: http://reveng.sourceforge.net/crc-catalogue/. For ease of use and better performance, the two defacto standard variations "CRC16" and "CRC32" have been predefined. The lookup tables for these implementations are included on the class side. For all other variations the lookup table will be generated at runtime before the first run. If you want to define your own algorithm you can do so by using the methods in the "accessing-parameters" protocol. Note that there are no default values. Here's a short overview: #width: defines the width of the register (usually 16 or 32) #polynome: defines the polynome to use for polynome division / lookup table creation #registerFill: defines the start content of the working register (usually all ones or all zeros) #reflectInput: if true every byte will be reflected before processing (e.g. 100101 -> 101001) #reflectOutpu: if true the entire register will be reflected before the final XOR stage #finallyXorWith: defines the final XOR for the entire register #lookupTable: the only OPTIONAL parameter. The lookup table will be generated at runtime if none has been supplied #message: the message to calculate the CRC on EXAMPLES ================= The simplest possible snippet uses the class side methods for "CRC16" and "CRC32": CRC crc16FromCollection: 'some message'. --> 55709 CRC crc32FromCollection: 'some message'. --> 191312361 Let's assume, you wanted to use "CRC16 reversed" (neither input nor output reflected). Then you would have to change the parameters like so (the reversed form uses a different polynome and a different start register content): crc := CRC new beCrc16; polynome: 16r1021; registerFill: 16rFFFF; reflectInput: false; reflectOutput: false; message: 'some message'; yourself. crc run. --> 46785 Using a single instance as in the code above will of course be faster than using the class side methods when performing multiple runs. But if you are really concerned about performance (see PERFORMANCE) you should use the "raw" methods (no checks!! If you forget to set parameters there will be errors....): crc := CRC new beCrc16; message: 'some message'; yourself. crc runRefInRefOut. --> 55709 crc := CRC new beCrc16; polynome: 16r1021; registerFill: 16rFFFF; message: 'some message'; yourself. crc runNonRefInNonRefOut. --> 46785 PERFORMANCE ================= The performance of this implementation (tested for crc16) is equal to the performance of String>>crc16 if executed "raw" (see EXAMPLES). For the users sake however, the implementation does a few extra checks to improve ease of use. The cost is a loss of performance of about factor 1.15 (single instance) and 1.42 (one instance per run) (note that although I took an average of 10, the results will vary quite a bit each time you run the code): crc := CRC new beCrc16; message: 'this is a test message'; yourself. "String>>crc16" times := OrderedCollection new. 10 timesRepeat: [ times add: [ 1000000 timesRepeat: [ 'this is a test message' crc16 ] ] timeToRun ]. times average floor. --> 530 "raw" times := OrderedCollection new. 10 timesRepeat: [ times add: [ 1000000 timesRepeat: [ crc runRefInRefOut ] ] timeToRun ]. times average floor. --> 535 "user friendly, one instance" times := OrderedCollection new. 10 timesRepeat: [ times add: [ 1000000 timesRepeat: [ crc run ] ] timeToRun ]. times average floor. --> 616 "user friendly, one instance per run" times := OrderedCollection new. 10 timesRepeat: [ times add: [ 1000000 timesRepeat: [ CRC crc16FromCollection: 'this is a test message' ] ] timeToRun ]. times average floor. --> 759! !CRC methodsFor: 'accessing-implementations' stamp: 'MaxLeske 3/17/2012 21:04'! beCrc16 self width: 16; lookupTable: self class crc16Table; polynome: 16r8005; registerFill: 16r0; reflectInput: true; reflectOutput: true; finallyXorWith: 16r0! ! !CRC methodsFor: 'private-bit-manipulation' stamp: 'MaxLeske 3/18/2012 10:07'! lowestByteShift ^ lowestByteShift ifNil: [ lowestByteShift := width - 8 ]! ! !CRC methodsFor: 'accessing-parameters' stamp: 'MaxLeske 3/18/2012 10:15'! width: anInteger "width of the register (on how many bits the CRC is calculated). usually 16 or 32" width := anInteger! ! !CRC methodsFor: 'accessing-implementations' stamp: 'MaxLeske 3/17/2012 21:05'! beCrc32 self width: 32; lookupTable: self class crc32Table; polynome: 16r04C11DB7; registerFill: 16rFFFFFFFF; reflectInput: true; reflectOutput: true; finallyXorWith: 16rFFFFFFFF! ! !CRC methodsFor: 'private-run-methods' stamp: 'MaxLeske 3/18/2012 10:28'! runNonRefInNonRefOut theRegister := registerFill. 1 to: message size do: [ :byteIndex | theRegister := (lookupTable at: (((theRegister bitShift: 0 - self lowestByteShift) bitXor: (message byteAt: byteIndex)) bitAnd: 255) + 1) bitXor: ((theRegister bitShift: 8) bitAnd: self widthMask) ]. ^ finalXorBytes bitXor: theRegister! ! !CRC methodsFor: 'accessing-parameters' stamp: 'MaxLeske 3/16/2012 16:50'! message: anObject message := anObject asByteArray! ! !CRC methodsFor: 'accessing-parameters' stamp: 'MaxLeske 3/18/2012 10:11'! registerFill: anInteger "The initial value of the CRC register" registerFill := anInteger! ! !CRC methodsFor: 'private-tables' stamp: 'MaxLeske 3/18/2012 10:01'! generateLookupTable "lookup tables have 256 entries" ^ Array new: 256 streamContents: [ :aStream | self printLookupTableOn: aStream ]! ! !CRC methodsFor: 'private-tables' stamp: 'MaxLeske 3/18/2012 10:06'! printLookupTableOn: aStream | topBit | topBit := self bitMaskAt: width. 0 to: 255 do: [ :index || register indexByte | indexByte := index. shouldReflectInput ifTrue: [ indexByte := self reflect: indexByte onLowerBits: 8 ]. register := indexByte << self lowestByteShift. 1 to: 8 do: [ : byteIndex | register := (register bitAnd: topBit) > 0 ifTrue: [ (register << 1) bitXor: polynome ] ifFalse: [ register << 1 ] ]. shouldReflectInput ifTrue: [ register := self reflect: register onLowerBits: width ]. register := (register bitAnd: self widthMask). aStream nextPut: register ]! ! !CRC methodsFor: 'public' stamp: 'MaxLeske 3/17/2012 21:13'! run lookupTable ifNil: [ lookupTable := self generateLookupTable ]. ^ self perform: self runMethodSelector! ! !CRC methodsFor: 'private-run-methods' stamp: 'MaxLeske 3/18/2012 10:27'! runRefInRefOut theRegister := registerFill. 1 to: message size do: [ :byteIndex | theRegister := (lookupTable at: ((theRegister bitXor: (message byteAt: byteIndex)) bitAnd: 255) + 1) bitXor: (theRegister bitShift: -8) ]. ^ finalXorBytes bitXor: theRegister! ! !CRC methodsFor: 'private-run-methods' stamp: 'MaxLeske 3/18/2012 10:57'! runRefInNonRefOut Warning signal: 'unverified implementation'. theRegister := registerFill. 1 to: message size do: [ :byteIndex | theRegister := (lookupTable at: ((theRegister bitXor: (message byteAt: byteIndex)) bitAnd: 255) + 1) bitXor: ((theRegister bitShift: 8) bitAnd: self widthMask) ]. ^ finalXorBytes bitXor: theRegister! ! !CRC methodsFor: 'accessing-parameters' stamp: 'MaxLeske 3/18/2012 10:11'! reflectOutput: aBoolean "Determines if the output is reflected before the final XOR." shouldReflectOutput := aBoolean! ! !CRC methodsFor: 'private-bit-manipulation' stamp: 'MaxLeske 3/18/2012 10:14'! widthMask "bit mask (all ones)" ^ widthMask ifNil: [ widthMask := (2 raisedTo: width) - 1 ]! ! !CRC methodsFor: 'private-bit-manipulation' stamp: 'MaxLeske 3/4/2012 19:37'! bitMaskAt: anInteger ^ 0 bitAt: anInteger put: 1! ! !CRC methodsFor: 'private-bit-manipulation' stamp: 'MaxLeske 3/18/2012 09:31'! invertedBitMaskAt: anInteger anInteger < 1 ifTrue: [ ^ 16rFFFFFFFF ]. ^ 16rFFFFFFFF bitAt: anInteger put: 0! ! !CRC methodsFor: 'accessing-parameters' stamp: 'MaxLeske 3/18/2012 09:59'! polynome: anInteger "The polynome used for polynomial division. It should be of the same length as the register width (see #width:)." polynome := anInteger! ! !CRC methodsFor: 'private-bit-manipulation' stamp: 'MaxLeske 3/16/2012 16:02'! reflect: anInteger onLowerBits: anotherInteger | register test | register := anInteger. test := anInteger. 0 to: anotherInteger - 1 do: [ :index | register := (test bitAnd: 1) = 1 ifTrue: [ register bitOr: (self bitMaskAt: anotherInteger - index) ] ifFalse: [ register bitAnd: (self invertedBitMaskAt: anotherInteger - index) ]. test := test bitShift: -1 ]. ^ register! ! !CRC methodsFor: 'accessing-parameters' stamp: 'MaxLeske 3/18/2012 10:11'! reflectInput: aBoolean "Determines if each byte should be reflected before processing. If false, bit 7 will be treated as most significant bit. If true, each byte will be reflected (bit 0 will be most significant)." shouldReflectInput := aBoolean! ! !CRC methodsFor: 'private-run-methods' stamp: 'MaxLeske 3/18/2012 09:27'! runMethodSelector ^ runMethodSelector ifNil: [ runMethodSelector := shouldReflectInput ifTrue: [ shouldReflectOutput ifTrue: [ #runRefInRefOut ] ifFalse: [ #runRefInNonRefOut ] ] ifFalse: [ shouldReflectOutput ifTrue: [ #runNonRefInRefOut ] ifFalse: [ #runNonRefInNonRefOut ] ] ]! ! !CRC methodsFor: 'private-run-methods' stamp: 'MaxLeske 3/18/2012 10:57'! runNonRefInRefOut Warning signal: 'unverified implementation'. theRegister := registerFill. 1 to: message size do: [ :byteIndex | theRegister := (lookupTable at: (((theRegister bitShift: 0 - self lowestByteShift) bitXor: (message byteAt: byteIndex)) bitAnd: 255) + 1) bitXor: (theRegister bitShift: -8) ]. ^ finalXorBytes bitXor: theRegister! ! !CRC methodsFor: 'accessing-parameters' stamp: 'MaxLeske 3/6/2012 08:25'! lookupTable: anArray lookupTable := anArray! ! !CRC methodsFor: 'accessing-parameters' stamp: 'MaxLeske 3/3/2012 22:50'! finallyXorWith: anInteger "The final XOR of the output will be performed with this value" finalXorBytes := anInteger! ! !CRC class methodsFor: 'accessing-tables' stamp: 'MaxLeske 3/6/2012 10:03'! crc32Table ^ #( 16r00000000 16r77073096 16rEE0E612C 16r990951BA 16r076DC419 16r706AF48F 16rE963A535 16r9E6495A3 16r0EDB8832 16r79DCB8A4 16rE0D5E91E 16r97D2D988 16r09B64C2B 16r7EB17CBD 16rE7B82D07 16r90BF1D91 16r1DB71064 16r6AB020F2 16rF3B97148 16r84BE41DE 16r1ADAD47D 16r6DDDE4EB 16rF4D4B551 16r83D385C7 16r136C9856 16r646BA8C0 16rFD62F97A 16r8A65C9EC 16r14015C4F 16r63066CD9 16rFA0F3D63 16r8D080DF5 16r3B6E20C8 16r4C69105E 16rD56041E4 16rA2677172 16r3C03E4D1 16r4B04D447 16rD20D85FD 16rA50AB56B 16r35B5A8FA 16r42B2986C 16rDBBBC9D6 16rACBCF940 16r32D86CE3 16r45DF5C75 16rDCD60DCF 16rABD13D59 16r26D930AC 16r51DE003A 16rC8D75180 16rBFD06116 16r21B4F4B5 16r56B3C423 16rCFBA9599 16rB8BDA50F 16r2802B89E 16r5F058808 16rC60CD9B2 16rB10BE924 16r2F6F7C87 16r58684C11 16rC1611DAB 16rB6662D3D 16r76DC4190 16r01DB7106 16r98D220BC 16rEFD5102A 16r71B18589 16r06B6B51F 16r9FBFE4A5 16rE8B8D433 16r7807C9A2 16r0F00F934 16r9609A88E 16rE10E9818 16r7F6A0DBB 16r086D3D2D 16r91646C97 16rE6635C01 16r6B6B51F4 16r1C6C6162 16r856530D8 16rF262004E 16r6C0695ED 16r1B01A57B 16r8208F4C1 16rF50FC457 16r65B0D9C6 16r12B7E950 16r8BBEB8EA 16rFCB9887C 16r62DD1DDF 16r15DA2D49 16r8CD37CF3 16rFBD44C65 16r4DB26158 16r3AB551CE 16rA3BC0074 16rD4BB30E2 16r4ADFA541 16r3DD895D7 16rA4D1C46D 16rD3D6F4FB 16r4369E96A 16r346ED9FC 16rAD678846 16rDA60B8D0 16r44042D73 16r33031DE5 16rAA0A4C5F 16rDD0D7CC9 16r5005713C 16r270241AA 16rBE0B1010 16rC90C2086 16r5768B525 16r206F85B3 16rB966D409 16rCE61E49F 16r5EDEF90E 16r29D9C998 16rB0D09822 16rC7D7A8B4 16r59B33D17 16r2EB40D81 16rB7BD5C3B 16rC0BA6CAD 16rEDB88320 16r9ABFB3B6 16r03B6E20C 16r74B1D29A 16rEAD54739 16r9DD277AF 16r04DB2615 16r73DC1683 16rE3630B12 16r94643B84 16r0D6D6A3E 16r7A6A5AA8 16rE40ECF0B 16r9309FF9D 16r0A00AE27 16r7D079EB1 16rF00F9344 16r8708A3D2 16r1E01F268 16r6906C2FE 16rF762575D 16r806567CB 16r196C3671 16r6E6B06E7 16rFED41B76 16r89D32BE0 16r10DA7A5A 16r67DD4ACC 16rF9B9DF6F 16r8EBEEFF9 16r17B7BE43 16r60B08ED5 16rD6D6A3E8 16rA1D1937E 16r38D8C2C4 16r4FDFF252 16rD1BB67F1 16rA6BC5767 16r3FB506DD 16r48B2364B 16rD80D2BDA 16rAF0A1B4C 16r36034AF6 16r41047A60 16rDF60EFC3 16rA867DF55 16r316E8EEF 16r4669BE79 16rCB61B38C 16rBC66831A 16r256FD2A0 16r5268E236 16rCC0C7795 16rBB0B4703 16r220216B9 16r5505262F 16rC5BA3BBE 16rB2BD0B28 16r2BB45A92 16r5CB36A04 16rC2D7FFA7 16rB5D0CF31 16r2CD99E8B 16r5BDEAE1D 16r9B64C2B0 16rEC63F226 16r756AA39C 16r026D930A 16r9C0906A9 16rEB0E363F 16r72076785 16r05005713 16r95BF4A82 16rE2B87A14 16r7BB12BAE 16r0CB61B38 16r92D28E9B 16rE5D5BE0D 16r7CDCEFB7 16r0BDBDF21 16r86D3D2D4 16rF1D4E242 16r68DDB3F8 16r1FDA836E 16r81BE16CD 16rF6B9265B 16r6FB077E1 16r18B74777 16r88085AE6 16rFF0F6A70 16r66063BCA 16r11010B5C 16r8F659EFF 16rF862AE69 16r616BFFD3 16r166CCF45 16rA00AE278 16rD70DD2EE 16r4E048354 16r3903B3C2 16rA7672661 16rD06016F7 16r4969474D 16r3E6E77DB 16rAED16A4A 16rD9D65ADC 16r40DF0B66 16r37D83BF0 16rA9BCAE53 16rDEBB9EC5 16r47B2CF7F 16r30B5FFE9 16rBDBDF21C 16rCABAC28A 16r53B39330 16r24B4A3A6 16rBAD03605 16rCDD70693 16r54DE5729 16r23D967BF 16rB3667A2E 16rC4614AB8 16r5D681B02 16r2A6F2B94 16rB40BBE37 16rC30C8EA1 16r5A05DF1B 16r2D02EF8D)! ! !CRC class methodsFor: 'primitives' stamp: 'MaxLeske 7/8/2013 21:41'! update: oldCrc from: start to: stop in: aCollection | newCrc | newCrc := oldCrc. start to: stop do: [ :i | newCrc := (self crc32Table at: ((newCrc bitXor: (aCollection byteAt: i)) bitAnd: 255) + 1) bitXor: (newCrc bitShift: -8) ]. ^newCrc! ! !CRC class methodsFor: 'accessing-tables' stamp: 'MaxLeske 3/6/2012 08:22'! crc16Table ^ #( 16r0000 16rC0C1 16rC181 16r0140 16rC301 16r03C0 16r0280 16rC241 16rC601 16r06C0 16r0780 16rC741 16r0500 16rC5C1 16rC481 16r0440 16rCC01 16r0CC0 16r0D80 16rCD41 16r0F00 16rCFC1 16rCE81 16r0E40 16r0A00 16rCAC1 16rCB81 16r0B40 16rC901 16r09C0 16r0880 16rC841 16rD801 16r18C0 16r1980 16rD941 16r1B00 16rDBC1 16rDA81 16r1A40 16r1E00 16rDEC1 16rDF81 16r1F40 16rDD01 16r1DC0 16r1C80 16rDC41 16r1400 16rD4C1 16rD581 16r1540 16rD701 16r17C0 16r1680 16rD641 16rD201 16r12C0 16r1380 16rD341 16r1100 16rD1C1 16rD081 16r1040 16rF001 16r30C0 16r3180 16rF141 16r3300 16rF3C1 16rF281 16r3240 16r3600 16rF6C1 16rF781 16r3740 16rF501 16r35C0 16r3480 16rF441 16r3C00 16rFCC1 16rFD81 16r3D40 16rFF01 16r3FC0 16r3E80 16rFE41 16rFA01 16r3AC0 16r3B80 16rFB41 16r3900 16rF9C1 16rF881 16r3840 16r2800 16rE8C1 16rE981 16r2940 16rEB01 16r2BC0 16r2A80 16rEA41 16rEE01 16r2EC0 16r2F80 16rEF41 16r2D00 16rEDC1 16rEC81 16r2C40 16rE401 16r24C0 16r2580 16rE541 16r2700 16rE7C1 16rE681 16r2640 16r2200 16rE2C1 16rE381 16r2340 16rE101 16r21C0 16r2080 16rE041 16rA001 16r60C0 16r6180 16rA141 16r6300 16rA3C1 16rA281 16r6240 16r6600 16rA6C1 16rA781 16r6740 16rA501 16r65C0 16r6480 16rA441 16r6C00 16rACC1 16rAD81 16r6D40 16rAF01 16r6FC0 16r6E80 16rAE41 16rAA01 16r6AC0 16r6B80 16rAB41 16r6900 16rA9C1 16rA881 16r6840 16r7800 16rB8C1 16rB981 16r7940 16rBB01 16r7BC0 16r7A80 16rBA41 16rBE01 16r7EC0 16r7F80 16rBF41 16r7D00 16rBDC1 16rBC81 16r7C40 16rB401 16r74C0 16r7580 16rB541 16r7700 16rB7C1 16rB681 16r7640 16r7200 16rB2C1 16rB381 16r7340 16rB101 16r71C0 16r7080 16rB041 16r5000 16r90C1 16r9181 16r5140 16r9301 16r53C0 16r5280 16r9241 16r9601 16r56C0 16r5780 16r9741 16r5500 16r95C1 16r9481 16r5440 16r9C01 16r5CC0 16r5D80 16r9D41 16r5F00 16r9FC1 16r9E81 16r5E40 16r5A00 16r9AC1 16r9B81 16r5B40 16r9901 16r59C0 16r5880 16r9841 16r8801 16r48C0 16r4980 16r8941 16r4B00 16r8BC1 16r8A81 16r4A40 16r4E00 16r8EC1 16r8F81 16r4F40 16r8D01 16r4DC0 16r4C80 16r8C41 16r4400 16r84C1 16r8581 16r4540 16r8701 16r47C0 16r4680 16r8641 16r8201 16r42C0 16r4380 16r8341 16r4100 16r81C1 16r8081 16r4040)! ! !CRC class methodsFor: 'instance creation' stamp: 'MaxLeske 7/8/2013 21:33'! crc16FromCollection: aCollection | instance | instance := self new beCrc16; message: aCollection; yourself. ^ instance runRefInRefOut! ! !CRC class methodsFor: 'instance creation' stamp: 'MaxLeske 3/18/2012 10:16'! crc32FromCollection: aCollection | instance | instance := self new beCrc32; message: aCollection; yourself. ^ instance runRefInRefOut! ! !CRCError commentStamp: 'TorstenBergmann 2/3/2014 23:03'! CRC failed! !CRCError methodsFor: 'testing' stamp: 'nk 3/7/2004 15:56'! isResumable ^true! ! !CacheStatistics commentStamp: ''! I am CacheStatistics. I keep track of hits and misses of a cache.! !CacheStatistics methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/2/2013 15:59'! initialize super initialize. hits := misses := 0! ! !CacheStatistics methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 15:59'! misses ^ misses! ! !CacheStatistics methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:00'! addMiss misses := misses + 1! ! !CacheStatistics methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 15:59'! hits ^ hits! ! !CacheStatistics methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:01'! addHit hits := hits + 1! ! !CacheStatistics methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:01'! hitRatio "Return the ratio of hits against total calls I received. This will be a number between 0 and 1. When I am empty, return 0." | total | total := hits + misses. total = 0 ifTrue: [ ^ 0 ]. ^ hits / total! ! !CacheStatistics methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/2/2013 16:00'! reset hits := misses := 0! ! !CacheWeight commentStamp: ''! I am CacheWeight. I keep track of the weight of a cache. The weight of a cache is the sum of the weight of all values currently present. The simplest and default weight calculation returns a constant 1 for each value, effectively counting the number of values. The default maximum is 16. Using compute, a selector or block, applied to a value, different calculation can be made. Consider for example #sizeInMemory.! !CacheWeight methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:27'! isBelowMaximum ^ total <= maximum ! ! !CacheWeight methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/2/2013 16:16'! initialize super initialize. total := 0. maximum := 16. compute := [ 1 ]! ! !CacheWeight methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:25'! compute ^ compute! ! !CacheWeight methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:17'! add: value | weight | weight := compute cull: value. total := total + weight! ! !CacheWeight methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:25'! maximum ^ maximum! ! !CacheWeight methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:19'! total ^ total! ! !CacheWeight methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:17'! remove: value | weight | weight := compute cull: value. total := total - weight! ! !CacheWeight methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/2/2013 16:19'! reset total := 0! ! !CacheWeight methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/2/2013 16:18'! compute: valuable compute := valuable! ! !CacheWeight methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/2/2013 16:18'! maximum: integer maximum := integer! ! !CachingMorph commentStamp: ''! This morph can be used to cache the picture of a morph that takes a long time to draw. It should be used with judgement, however, since heavy use of caching can consume large amounts of memory.! !CachingMorph methodsFor: 'initialization' stamp: 'MarcusDenker 12/11/2009 23:56'! initialize "initialize the state of the receiver" super initialize. damageRecorder := DamageRecorder new! ! !CachingMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color veryLightGray! ! !CachingMorph methodsFor: 'drawing' stamp: ''! drawOn: aCanvas submorphs isEmpty ifTrue: [^ super drawOn: aCanvas]. ! ! !CachingMorph methodsFor: 'drawing' stamp: 'ar 5/28/2000 17:12'! imageForm self updateCacheCanvas: Display getCanvas. ^ cacheCanvas form offset: self fullBounds topLeft ! ! !CachingMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:43'! invalidRect: damageRect from: aMorph "Record the given rectangle in the damage list." damageRecorder recordInvalidRect: (damageRect translateBy: self fullBounds origin negated). super invalidRect: damageRect from: aMorph! ! !CachingMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 23:03'! updateCacheCanvas: aCanvas "Update the cached image of the morphs being held by this hand." | myBnds rectList | myBnds := self fullBounds. (cacheCanvas isNil or: [cacheCanvas extent ~= myBnds extent]) ifTrue: [cacheCanvas := (aCanvas allocateForm: myBnds extent) getCanvas. cacheCanvas translateBy: myBnds origin negated during: [:tempCanvas | super fullDrawOn: tempCanvas]. ^self]. "incrementally update the cache canvas" rectList := damageRecorder invalidRectsFullBounds: (0 @ 0 extent: myBnds extent). damageRecorder reset. rectList do: [:r | cacheCanvas translateTo: myBnds origin negated clippingTo: r during: [:c | c fillColor: Color transparent. "clear to transparent" super fullDrawOn: c]]! ! !CachingMorph methodsFor: 'drawing' stamp: 'ar 12/30/2001 19:14'! fullDrawOn: aCanvas (aCanvas isVisible: self fullBounds) ifFalse:[^self]. self updateCacheCanvas: aCanvas. aCanvas cache: self fullBounds using: cacheCanvas form during:[:cachingCanvas| super fullDrawOn: cachingCanvas]. ! ! !CachingMorph methodsFor: 'caching' stamp: 'jm 11/13/97 16:31'! releaseCachedState super releaseCachedState. cacheCanvas := nil. ! ! !CaesarEcryptorDecryptor commentStamp: ''! A CaesarEcryptorDecryptor is a world know encryptng algorithm by rotation! !CaesarEcryptorDecryptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/6/2012 22:41'! decrypt: aString base: aBase ^ String streamContents: [:s | aString do: [:c | s nextPut: ( Character value: (c asciiValue - aBase size )) ]]! ! !CaesarEcryptorDecryptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/6/2012 22:42'! encrypt: aString base: aBase ^ String streamContents: [:s | aString do: [:c | s nextPut: ( Character value: (c asciiValue + aBase size )) ]]! ! !CairoBackendCache commentStamp: ''! I providing a simple [weak]key->value storage used to cache various objects used by Athens for Cairo backend, like fonts/forms etc. The cache is global (there's only a single instance of me used at a time) and cache is visible globally by all entities of Cairo backend. The cached objects is held weakly. The cache is flushed for a new image session.! !CairoBackendCache methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 00:31'! at: anObject ifAbsentPut: aBlock ^ cache at: anObject ifAbsentPut: aBlock! ! !CairoBackendCache methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2013 13:25'! for: anObject at: key ifAbsentPut: aBlock | subCache | subCache := cache at: anObject ifAbsentPut: [ WeakIdentityKeyDictionary new ]. ^ subCache at: key ifAbsentPut: aBlock! ! !CairoBackendCache methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 7/3/2013 13:26'! initialize self flush! ! !CairoBackendCache methodsFor: 'removing' stamp: 'IgorStasenko 10/12/2012 03:54'! removeAt: anObject ^ cache removeKey: anObject ifAbsent: nil! ! !CairoBackendCache methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 19:15'! at: anObject ^ cache at: anObject ifAbsent: nil! ! !CairoBackendCache methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/3/2013 13:26'! flush cache := WeakIdentityKeyDictionary new! ! !CairoBackendCache methodsFor: 'initialize-release' stamp: 'IgorStasenko 9/2/2012 01:54'! nbSessionChanged self initialize. ! ! !CairoBackendCache class methodsFor: 'accessing' stamp: 'IgorStasenko 9/1/2012 23:55'! soleInstance ^ soleInstance! ! !CairoBackendCache class methodsFor: 'class initialization' stamp: 'IgorStasenko 9/2/2012 01:57'! initialize "self initialize " soleInstance ifNotNil: [ NativeBoost announcer unsubscribe: soleInstance. soleInstance initialize ]. soleInstance := self new. "be notified about session change" NativeBoost notifyAboutSessionChange: soleInstance! ! !CairoBackendCache class methodsFor: 'flushing' stamp: 'IgorStasenko 8/12/2013 16:20'! flush self soleInstance flush! ! !CairoFontExtents commentStamp: ''! I represent the cairo_font_extents_t structure type The cairo_font_extents_t structure stores metric information for a font. Values are given in the current user-space coordinate system. Because font metrics are in user-space coordinates, they are mostly, but not entirely, independent of the current transformation matrix. If you call cairo_scale(cr, 2.0, 2.0), text will be drawn twice as big, but the reported text extents will not be doubled. They will change slightly due to hinting (so you can't assume that metrics are independent of the transformation matrix), but otherwise will remain unchanged. double ascent; the distance that the font extends above the baseline. Note that this is not always exactly equal to the maximum of the extents of all the glyphs in the font, but rather is picked to express the font designer's intent as to how the font should align with elements above it. double descent; the distance that the font extends below the baseline. This value is positive for typical fonts that include portions below the baseline. Note that this is not always exactly equal to the maximum of the extents of all the glyphs in the font, but rather is picked to express the font designer's intent as to how the font should align with elements below it. double height; the recommended vertical distance between baselines when setting consecutive lines of text with the font. This is greater than ascent+descent by a quantity known as the line spacing or external leading. When space is at a premium, most fonts can be set with only a distance of ascent+descent between lines. double max_x_advance; the maximum distance in the X direction that the origin is advanced for any glyph in the font. double max_y_advance; the maximum distance in the Y direction that the origin is advanced for any glyph in the font. This will be zero for normal fonts used for horizontal writing. (The scripts of East Asia are sometimes written vertically.)! !CairoFontExtents class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 6/11/2012 06:56'! fieldsDesc ^ #( double ascent; double descent; double height; double max_x_advance; double max_y_advance; )! ! !CairoFontFace commentStamp: ''! I am a private class, used to represent a 'cairo_font_face_t *' data structure of Cairo library. I am not useful for direct use nor providing any functionality. My only purpose is to keep a strong reference to original FT2Face object (so it won't be freed before a corresponding instance of mine will release it). ! !CairoFontFace methodsFor: 'external resource management' stamp: 'IgorStasenko 6/11/2012 06:00'! resourceData ^ handle value! ! !CairoFontFace methodsFor: 'initialize-release' stamp: 'IgorStasenko 6/11/2012 06:00'! initialize self registerAsExternalResource ! ! !CairoFontFace methodsFor: 'accessing' stamp: 'IgorStasenko 6/11/2012 06:29'! status ^ self nbCall: #(int cairo_font_face_status (self)) ! ! !CairoFontFace methodsFor: 'initialize-release' stamp: 'IgorStasenko 8/28/2012 11:54'! initializeWithFreetypeFace: aFace ftFace := aFace. self registerAsExternalResource.! ! !CairoFontFace methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !CairoFontFace class methodsFor: 'instance creation' stamp: 'SeanDeNigris 4/3/2014 17:50'! fromFreetypeFace: aFace | handle cairoFace | handle := aFace handle nbUlongAt: 1. cairoFace := self primFtFace: handle loadFlags: ( LoadNoHinting | LoadTargetLCD | LoadNoAutohint | LoadNoBitmap). ^ cairoFace initializeWithFreetypeFace: aFace! ! !CairoFontFace class methodsFor: 'finalizing' stamp: 'IgorStasenko 6/11/2012 06:03'! finalizeResourceData: handle " void cairo_font_face_destroy (cairo_font_face_t *font_face); " ^ self nbCall: #( void cairo_font_face_destroy (size_t handle)) ! ! !CairoFontFace class methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !CairoFontFace class methodsFor: 'instance creation' stamp: 'IgorStasenko 6/11/2012 05:30'! primFtFace: aFace loadFlags: flags " cairo_font_face_t * cairo_ft_font_face_create_for_ft_face (FT_Face face, int load_flags); " ^ self nbCall: #( CairoFontFace cairo_ft_font_face_create_for_ft_face(uint aFace , int flags )) ! ! !CairoFontMetricsProvider commentStamp: 'TorstenBergmann 2/12/2014 22:22'! Provide font metrics (Cairo)! !CairoFontMetricsProvider methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !CairoFontMetricsProvider methodsFor: 'accessing' stamp: 'IgorStasenko 4/8/2014 15:23'! getGlyphWidth: aCharacter cairoFont getExtentsOf: (utfConverter convertChar: aCharacter) into: glyphExtents. ^ glyphExtents x_advance! ! !CairoFontMetricsProvider methodsFor: 'initialization' stamp: 'IgorStasenko 8/22/2013 14:22'! initialize utfConverter := CairoUTF8Converter new. glyphExtents := CairoTextExtents new. cache := CairoBackendCache soleInstance.! ! !CairoFontMetricsProvider methodsFor: 'accessing' stamp: 'SeanDeNigris 4/4/2014 13:20'! fontHeight ^ extents height ! ! !CairoFontMetricsProvider methodsFor: 'accessing' stamp: 'IgorStasenko 8/22/2013 13:25'! fontAscent ^ extents ascent! ! !CairoFontMetricsProvider methodsFor: 'accessing' stamp: 'SeanDeNigris 4/3/2014 16:11'! font: aFont font := aFont asFreetypeFont. cairoFont := CairoScaledFont fromFreetypeFont: font. extents := cairoFont extents.! ! !CairoFontMetricsProvider class methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !CairoFontOptions commentStamp: ''! i represent various font options exposed by cairo library! !CairoFontOptions methodsFor: 'hint options' stamp: 'IgorStasenko 9/2/2012 01:15'! hintStyleNone ^ self setHintStyle: CAIRO_HINT_STYLE_NONE! ! !CairoFontOptions methodsFor: 'hint options' stamp: 'IgorStasenko 9/2/2012 01:15'! hintStyleDefault ^ self setHintStyle: CAIRO_HINT_STYLE_DEFAULT! ! !CairoFontOptions methodsFor: 'subpixel order' stamp: 'IgorStasenko 9/2/2012 19:26'! subpixelOrderBGR ^ self setSubpixelOrder: CAIRO_SUBPIXEL_ORDER_BGR! ! !CairoFontOptions methodsFor: 'initialize-release' stamp: 'IgorStasenko 8/28/2012 12:07'! resourceData ^ handle value! ! !CairoFontOptions methodsFor: 'antialiasing' stamp: 'IgorStasenko 9/2/2012 01:28'! aaFast ^ self setAA: CAIRO_ANTIALIAS_FAST.! ! !CairoFontOptions methodsFor: 'hint options' stamp: 'IgorStasenko 10/11/2013 18:34'! hintMetricsDefault ^ self setHintMetrics: CAIRO_HINT_METRICS_DEFAULT! ! !CairoFontOptions methodsFor: 'subpixel order' stamp: 'IgorStasenko 9/2/2012 19:50'! setSubpixelOrder: order "void cairo_font_options_set_subpixel_order (cairo_font_options_t *options, cairo_subpixel_order_t subpixel_order)" ^ self nbCall: #( void cairo_font_options_set_subpixel_order (self, uint order)) ! ! !CairoFontOptions methodsFor: 'subpixel order' stamp: 'IgorStasenko 9/2/2012 19:25'! subpixelOrderDefault ^ self setSubpixelOrder: CAIRO_SUBPIXEL_ORDER_DEFAULT! ! !CairoFontOptions methodsFor: 'initialize-release' stamp: 'IgorStasenko 9/2/2012 01:16'! initialize self registerAsExternalResource. self setDefaults! ! !CairoFontOptions methodsFor: 'subpixel order' stamp: 'IgorStasenko 9/2/2012 19:25'! subpixelOrderRGB ^ self setSubpixelOrder: CAIRO_SUBPIXEL_ORDER_RGB! ! !CairoFontOptions methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !CairoFontOptions methodsFor: 'antialiasing' stamp: 'IgorStasenko 9/2/2012 01:27'! aaNone ^ self setAA: CAIRO_ANTIALIAS_NONE.! ! !CairoFontOptions methodsFor: 'antialiasing' stamp: 'IgorStasenko 9/2/2012 01:29'! setAA: antialias "cairo_font_options_set_antialias () void cairo_font_options_set_antialias (cairo_font_options_t *options, cairo_antialias_t antialias); Sets the antialiasing mode for the font options object. This specifies the type of antialiasing to do when rendering text. options : a cairo_font_options_t antialias : the new antialiasing mode" ^ self nbCall: #( void cairo_font_options_set_antialias (self, uint antialias)) ! ! !CairoFontOptions methodsFor: 'hint options' stamp: 'IgorStasenko 10/11/2013 18:31'! setHintMetrics: hintMetrics " void cairo_font_options_set_hint_metrics (cairo_font_options_t *options, cairo_hint_metrics_t hint_metrics); Sets the metrics hinting mode for the font options object. This controls whether metrics are quantized to integer values in device units. See the documentation for cairo_hint_metrics_t for full details. " ^ self nbCall: #(void cairo_font_options_set_hint_metrics (self, uint hintMetrics)) ! ! !CairoFontOptions methodsFor: 'antialiasing' stamp: 'IgorStasenko 9/2/2012 01:28'! aaGood ^ self setAA: CAIRO_ANTIALIAS_GOOD.! ! !CairoFontOptions methodsFor: 'antialiasing' stamp: 'IgorStasenko 9/2/2012 01:27'! aaGray ^ self setAA: CAIRO_ANTIALIAS_GRAY.! ! !CairoFontOptions methodsFor: 'hint options' stamp: 'IgorStasenko 9/2/2012 01:14'! setHintStyle: aStyle "cairo_font_options_set_hint_style () void cairo_font_options_set_hint_style (cairo_font_options_t *options, cairo_hint_style_t hint_style); Sets the hint style for font outlines for the font options object. This controls whether to fit font outlines to the pixel grid, and if so, whether to optimize for fidelity or contrast. See the documentation for cairo_hint_style_t for full details. " ^ self nbCall: #( void cairo_font_options_set_hint_style (self, uint aStyle)) ! ! !CairoFontOptions methodsFor: 'hint options' stamp: 'IgorStasenko 9/2/2012 01:16'! hintStyleFull ^ self setHintStyle: CAIRO_HINT_STYLE_FULL! ! !CairoFontOptions methodsFor: 'hint options' stamp: 'IgorStasenko 9/2/2012 01:15'! hintStyleSlight ^ self setHintStyle: CAIRO_HINT_STYLE_SLIGHT! ! !CairoFontOptions methodsFor: 'subpixel order' stamp: 'IgorStasenko 9/2/2012 19:26'! subpixelOrderVRGB ^ self setSubpixelOrder: CAIRO_SUBPIXEL_ORDER_VRGB! ! !CairoFontOptions methodsFor: 'antialiasing' stamp: 'IgorStasenko 9/2/2012 01:27'! aaDefault ^ self setAA: CAIRO_ANTIALIAS_DEFAULT.! ! !CairoFontOptions methodsFor: 'subpixel order' stamp: 'IgorStasenko 9/2/2012 19:26'! subpixelOrderVBGR ^ self setSubpixelOrder: CAIRO_SUBPIXEL_ORDER_VBGR! ! !CairoFontOptions methodsFor: 'antialiasing' stamp: 'IgorStasenko 9/2/2012 01:28'! aaSubpixel ^ self setAA: CAIRO_ANTIALIAS_SUBPIXEL.! ! !CairoFontOptions methodsFor: 'defaults' stamp: 'IgorStasenko 10/23/2013 02:37'! setDefaults self hintStyleSlight; hintMetricsOff; subpixelOrderRGB; aaSubpixel! ! !CairoFontOptions methodsFor: 'hint options' stamp: 'IgorStasenko 10/11/2013 18:34'! hintMetricsOff ^ self setHintMetrics: CAIRO_HINT_METRICS_OFF! ! !CairoFontOptions methodsFor: 'hint options' stamp: 'IgorStasenko 10/11/2013 18:34'! hintMetricsOn ^ self setHintMetrics: CAIRO_HINT_METRICS_ON! ! !CairoFontOptions methodsFor: 'hint options' stamp: 'IgorStasenko 9/2/2012 01:15'! hintStyleMedium ^ self setHintStyle: CAIRO_HINT_STYLE_MEDIUM! ! !CairoFontOptions methodsFor: 'antialiasing' stamp: 'IgorStasenko 9/2/2012 01:28'! aaBest ^ self setAA: CAIRO_ANTIALIAS_BEST.! ! !CairoFontOptions class methodsFor: 'private' stamp: 'IgorStasenko 8/28/2012 12:09'! primDestroy: anOptions "void cairo_font_options_destroy (cairo_font_options_t *options); Destroys a cairo_font_options_t object created with cairo_font_options_create() or cairo_font_options_copy(). options : a cairo_font_options_t" ^ self nbCall: #(void cairo_font_options_destroy (size_t anOptions))! ! !CairoFontOptions class methodsFor: 'instance creation' stamp: 'IgorStasenko 8/28/2012 12:06'! new ^ self primCreate initialize! ! !CairoFontOptions class methodsFor: 'finalizing' stamp: 'IgorStasenko 8/28/2012 12:11'! finalizeResourceData: aData "finalize the external resource data, returned by #resourceData on instance side" self primDestroy: aData! ! !CairoFontOptions class methodsFor: 'private' stamp: 'IgorStasenko 8/28/2012 12:05'! primCreate "cairo_font_options_t * cairo_font_options_create (void); Allocates a new font options object with all options initialized to default values. Returns : a newly allocated cairo_font_options_t. Free with cairo_font_options_destroy(). This function always returns a valid pointer; if memory cannot be allocated, then a special error object is returned where all operations on the object do nothing. You can check for this with cairo_font_options_status(). " ^ self nbCall: #(CairoFontOptions cairo_font_options_create ())! ! !CairoFontOptions class methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !CairoFreetypeFontRenderer commentStamp: 'SeanDeNigris 4/4/2014 13:33'! I am used to render freetype font(s) with cairo library. Before start rendering, you must set: - canvas - font ! !CairoFreetypeFontRenderer methodsFor: 'accessing' stamp: 'IgorStasenko 9/1/2012 21:29'! advance ^ advance! ! !CairoFreetypeFontRenderer methodsFor: 'private' stamp: 'IgorStasenko 4/7/2014 18:08'! convertString: utf8String len: strlen ofFont: aScaledFont toGlyphs: glyphs numGlyphs: numGlyphs x: x y: y " all of this for using http://www.cairographics.org/manual/cairo-User-Fonts.html#cairo-user-scaled-font-text-to-glyphs-func-t " ^self nbCall: #( cairo_status_t cairo_scaled_font_text_to_glyphs (CairoScaledFont aScaledFont, double x, double y, void * utf8String, int strlen, NBExternalAddress * glyphs, int * numGlyphs, 0, 0, 0))! ! !CairoFreetypeFontRenderer methodsFor: 'private' stamp: 'IgorStasenko 8/19/2013 15:30'! freeGlyphs: glyphs ^self nbCall: #( void cairo_glyph_free (void *glyphs))! ! !CairoFreetypeFontRenderer methodsFor: 'accessing - font metrics' stamp: 'IgorStasenko 9/6/2013 12:51'! getGlyphWidth: aCharacter utfConverter convert: aCharacter asString from: 1 to: 1. font getExtentsOf: utfConverter buffer into: glyphExtents. ^ glyphExtents x_advance! ! !CairoFreetypeFontRenderer methodsFor: 'accessing - font metrics' stamp: 'IgorStasenko 4/8/2014 16:11'! glyphsOf: aString from: start to: end | len glyphs ptr lenValue glyphsSize utf8Len error | len := end-start+1. utf8Len := utfConverter convert: aString from: start to: end. ptr := NBExternalAddress new. lenValue := ByteArray new: 4. lenValue nbUInt32AtOffset: 0 put: len. error := self convertString: utfConverter buffer len: utf8Len ofFont: font toGlyphs: ptr numGlyphs: lenValue x: 0.0 y: 0.0 . error = CAIRO_STATUS_SUCCESS ifFalse: [ ^ CairoGlyphsArray new: 0 ]. glyphsSize := lenValue nbUInt32AtOffset: 0. glyphs := CairoGlyphsArray new: glyphsSize. NativeBoost memCopy: ptr to: glyphs address size: (glyphsSize * CairoGlyphsArray elementSize). self freeGlyphs: ptr. ^ glyphs ! ! !CairoFreetypeFontRenderer methodsFor: 'accessing - font metrics' stamp: 'IgorStasenko 9/6/2013 12:50'! fontAscent ^ fontExtents ascent! ! !CairoFreetypeFontRenderer methodsFor: 'accessing' stamp: 'SeanDeNigris 4/3/2014 16:10'! font: aFreetypeFont font := CairoScaledFont fromFreetypeFont: aFreetypeFont. fontExtents := font extents. originalFont := aFreetypeFont. ! ! !CairoFreetypeFontRenderer methodsFor: 'rendering' stamp: 'SeanDeNigris 4/4/2014 14:59'! renderCharacters: aString from: start to: end | glyphs | glyphs := self glyphsOf: aString from: start to: end. self renderGlyphs: glyphs. ! ! !CairoFreetypeFontRenderer methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 00:24'! canvas: aCairoCanvas canvas := aCairoCanvas.! ! !CairoFreetypeFontRenderer methodsFor: 'accessing' stamp: 'IgorStasenko 9/1/2012 21:30'! advance: aPoint advance := aPoint! ! !CairoFreetypeFontRenderer methodsFor: 'initialize' stamp: 'IgorStasenko 9/6/2013 12:52'! initialize utfConverter := CairoUTF8Converter new. advance := 0@0. cache := CairoBackendCache soleInstance. glyphExtents := CairoTextExtents new.! ! !CairoFreetypeFontRenderer methodsFor: 'rendering' stamp: 'SeanDeNigris 4/4/2014 13:28'! renderGlyphs: cairoGlyphs font lock. canvas setPathMatrix; setScaledFont: font. canvas paint loadOnCairoCanvas: canvas. canvas showGlyphs: cairoGlyphs address size: cairoGlyphs size. font unlock. ! ! !CairoFreetypeFontRenderer methodsFor: 'rendering' stamp: 'IgorStasenko 8/30/2012 18:27'! render: aString ^ self renderCharacters: aString from: 1 to: aString size! ! !CairoFreetypeFontRenderer methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !CairoFreetypeFontRenderer methodsFor: 'accessing - font metrics' stamp: 'SeanDeNigris 4/3/2014 15:36'! fontHeight ^ fontExtents height! ! !CairoFreetypeFontRenderer methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 01:43'! setColor: aColor (canvas setPaint: aColor )! ! !CairoFreetypeFontRenderer class methodsFor: 'library path' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !CairoGlyph commentStamp: ''! i correspond to cairo_glyph_t structure: typedef struct { unsigned long index; double x; double y; } cairo_glyph_t;! !CairoGlyph methodsFor: '*generated-code-non-existing-package' stamp: 'NativeBoost 2/4/2014 13:23'! index "This method was automatically generated" ^ self fieldAt: #index! ! !CairoGlyph methodsFor: '*generated-code-non-existing-package' stamp: 'NativeBoost 2/4/2014 13:23'! x: anObject "This method was automatically generated" ^ self fieldAt: #x put: anObject! ! !CairoGlyph methodsFor: '*generated-code-non-existing-package' stamp: 'NativeBoost 2/4/2014 13:23'! x "This method was automatically generated" ^ self fieldAt: #x! ! !CairoGlyph methodsFor: '*generated-code-non-existing-package' stamp: 'NativeBoost 2/4/2014 13:23'! index: anObject "This method was automatically generated" ^ self fieldAt: #index put: anObject! ! !CairoGlyph methodsFor: '*generated-code-non-existing-package' stamp: 'NativeBoost 2/4/2014 13:23'! y "This method was automatically generated" ^ self fieldAt: #y! ! !CairoGlyph methodsFor: '*generated-code-non-existing-package' stamp: 'NativeBoost 2/4/2014 13:23'! y: anObject "This method was automatically generated" ^ self fieldAt: #y put: anObject! ! !CairoGlyph class methodsFor: 'fields description' stamp: 'IgorStasenko 8/14/2013 16:19'! fieldsDesc ^ #( ulong index; double x; double y; )! ! !CairoGlyph class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 3/31/2014 16:17'! byteAlignment NativeBoost platformId = NativeBoostConstants win32PlatformId ifTrue: [ ^ 8 ]. ^ super byteAlignment! ! !CairoGlyphsArray commentStamp: ''! Captain obvious tells this is an array of CairoGlyph(s), corresponds to cairo_glyph_t structure: typedef struct { unsigned long index; double x; double y; } cairo_glyph_t;! !CairoGlyphsArray methodsFor: 'accessing' stamp: 'IgorStasenko 8/19/2013 15:39'! allocatedByCairo: aBoolean allocatedByCairo := aBoolean! ! !CairoGlyphsArray methodsFor: '*generated-code-non-existing-package' stamp: 'IgorStasenko 12/7/2012 16:42'! at: index put: value "Set value at 1-based index. Note, this method used as a template for my anonymous subclasses. " ^ self emitWrite ! ! !CairoGlyphsArray methodsFor: 'accessing' stamp: 'IgorStasenko 8/19/2013 15:38'! allocatedByCairo ^ allocatedByCairo ! ! !CairoGlyphsArray methodsFor: '*generated-code-non-existing-package' stamp: 'IgorStasenko 12/7/2012 16:42'! at: index "Answer an element using 1-based index. Note, this method used as a template for my anonymous subclasses. " ^ self emitRead! ! !CairoGlyphsArray class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/14/2013 16:28'! initialize self initElementType: #CairoGlyph! ! !CairoLibraryLoader commentStamp: ''! i am a service class, which responsible to finding and loading cairo dynamic library! !CairoLibraryLoader class methodsFor: 'private' stamp: 'IgorStasenko 6/10/2012 05:42'! loadCairoLibrary ^ NativeBoost forCurrentPlatform loadModule: self getLibraryPath ! ! !CairoLibraryLoader class methodsFor: 'linux' stamp: 'IgorStasenko 4/16/2013 15:56'! cantFindCairoOnLinux " Cog VM is a 32-bit process, and therefore won't link with 64-bit libraries on 64-bit OS. In case if you have problems with cairo library on linux system, try following: Installing 32-bit version of Cairo library. for Fedora it is: $ yum install cairo.i686 /usr/lib/libcairo.so.2 for Ubuntu: $ sudo apt-get install libcairo2:i386 /usr/lib/i386-linux-gnu/libcairo.so.2 If library is installed try to locate it and add path to it to #pathToCairoOnLinux method. " self error: 'Cannot locate cairo library. Please check if it installed on your system'! ! !CairoLibraryLoader class methodsFor: 'private' stamp: 'IgorStasenko 4/16/2013 15:50'! getLibraryPath (NativeBoost platformId = NativeBoostConstants linux32PlatformId) ifTrue: [ ^ self pathToCairoOnLinux. ]. (NativeBoost platformId = NativeBoostConstants mac32PlatformId) ifTrue: [ ^ 'libcairo.2.dylib' ]. (NativeBoost platformId = NativeBoostConstants win32PlatformId) ifTrue: [ ^ 'libcairo-2.dll' ]. self error: 'define your own path' ! ! !CairoLibraryLoader class methodsFor: 'public' stamp: 'IgorStasenko 6/10/2012 05:46'! getLibraryHandle (NativeBoost sessionChanged: session) ifTrue: [ libHandle := self loadCairoLibrary. session := NativeBoost uniqueSessionObject. ]. ^ libHandle ! ! !CairoLibraryLoader class methodsFor: 'linux' stamp: 'IgorStasenko 7/29/2013 10:41'! pathToCairoOnLinux "On different flavors of linux the path to library may differ depending on OS distro or whether system is 32 or 64 bit. " #( '/usr/lib/i386-linux-gnu/libcairo.so.2' '/usr/lib32/libcairo.so.2' '/usr/lib/libcairo.so.2' ) do: [ :path | path asFileReference exists ifTrue: [ ^ path ] ]. ^ self cantFindCairoOnLinux ! ! !CairoPNGPaint commentStamp: ''! I am a surface paint with lazy initialization scheme, that i loading image from .png file the first time i will be used. ! !CairoPNGPaint methodsFor: 'converting' stamp: 'IgorStasenko 4/12/2013 09:09'! asAthensPaintOn: anAthensCanvas | surface | surface := AthensCairoSurface createFromFile: fileName ifFailed: [ :status | status = CAIRO_STATUS_READ_ERROR ifTrue: [ self error: 'Cairo couldnt read the file named ', fileName ]. status = CAIRO_STATUS_FILE_NOT_FOUND ifTrue: [ self error: 'Cairo cant find the file named ', fileName ]. ^ self error: 'Cannot create surface. Cairo status code: ', status asString ]. ^ surface asAthensPaintOn: anAthensCanvas. ! ! !CairoPNGPaint methodsFor: 'initialize-release' stamp: 'FernandoOlivero 1/12/2012 12:47'! initializeOnFileNamed: aFileName fileName := aFileName.! ! !CairoPNGPaint class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 1/12/2012 12:47'! fileNamed: aFileName | image| image := self new. image initializeOnFileNamed: aFileName. ^ image! ! !CairoScaledFont commentStamp: ''! my instances map to cairo_scaled_font_t * data type! !CairoScaledFont methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/1/2012 23:33'! lock " FT_Face cairo_ft_scaled_font_lock_face (cairo_scaled_font_t *scaled_font); " ^ self nbCall: #( void cairo_ft_scaled_font_lock_face (self)) ! ! !CairoScaledFont methodsFor: 'initialize-release' stamp: 'IgorStasenko 8/28/2012 12:34'! initialize self status ~= CAIRO_STATUS_SUCCESS ifTrue: [ self error: 'Something is wrong!!' ]. self registerAsExternalResource ! ! !CairoScaledFont methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ self class nbLibraryNameOrHandle ! ! !CairoScaledFont methodsFor: 'accessing' stamp: 'IgorStasenko 8/28/2012 11:26'! extents | extents | extents := CairoFontExtents new. self getExtents: extents. ^ extents! ! !CairoScaledFont methodsFor: 'external resource management' stamp: 'IgorStasenko 6/11/2012 06:49'! resourceData ^ handle value! ! !CairoScaledFont methodsFor: 'accessing' stamp: 'IgorStasenko 6/11/2012 06:51'! status "cairo_status_t cairo_scaled_font_status (cairo_scaled_font_t *scaled_font);" ^ self nbCall: #(int cairo_scaled_font_status (self)) ! ! !CairoScaledFont methodsFor: 'accessing' stamp: 'IgorStasenko 6/11/2012 06:58'! getExtents: cairoFontExtents "void cairo_scaled_font_extents (cairo_scaled_font_t *scaled_font, cairo_font_extents_t *extents); " ^ self nbCall: #(int cairo_scaled_font_extents (self, CairoFontExtents * cairoFontExtents )) ! ! !CairoScaledFont methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/1/2012 23:33'! unlock " FT_Face cairo_ft_scaled_font_lock_face (cairo_scaled_font_t *scaled_font); " ^ self nbCall: #( void cairo_ft_scaled_font_unlock_face (self)) ! ! !CairoScaledFont methodsFor: 'accessing' stamp: 'IgorStasenko 8/22/2013 12:14'! getExtentsOf: utf8String into: extentObj "void cairo_scaled_font_extents (cairo_scaled_font_t *scaled_font, cairo_font_extents_t *extents); " ^ self nbCall: #( void cairo_scaled_font_text_extents (self, void *utf8String, cairo_text_extents_t * extentObj)) ! ! !CairoScaledFont methodsFor: 'initialize-release' stamp: 'IgorStasenko 8/28/2012 12:28'! initWithFace: cairo_face face := cairo_face. self registerAsExternalResource.! ! !CairoScaledFont class methodsFor: 'private' stamp: 'IgorStasenko 8/28/2012 12:18'! primCreate: face fontMatrix: fontMatrix userToDeviceMatrix: ctm options: options " cairo_scaled_font_t * cairo_scaled_font_create (cairo_font_face_t *font_face, const cairo_matrix_t *font_matrix, const cairo_matrix_t *ctm, const cairo_font_options_t *options); Creates a cairo_scaled_font_t object from a font face and matrices that describe the size of the font and the environment in which it will be used. font_face : a cairo_font_face_t font_matrix : font space to user space transformation matrix for the font. In the simplest case of a N point font, this matrix is just a scale by N, but it can also be used to shear the font or stretch it unequally along the two axes. See cairo_set_font_matrix(). ctm : user to device transformation matrix with which the font will be used. options : options to use when getting metrics for the font and rendering with it. Returns : a newly created cairo_scaled_font_t. Destroy with cairo_scaled_font_destroy() " ^ self nbCall: #( CairoScaledFont cairo_scaled_font_create ( CairoFontFace face, AthensCairoMatrix * fontMatrix, AthensCairoMatrix * ctm, CairoFontOptions options ) ) ! ! !CairoScaledFont class methodsFor: 'instance creation' stamp: 'SeanDeNigris 4/4/2014 02:51'! fromFreetypeFont: aFont cairoFace: face | options fontMatrix deviceMatrix font | options := CairoBackendCache soleInstance at: #AAOptions ifAbsentPut: [ CairoFontOptions new ]. fontMatrix := AthensCairoMatrix new. deviceMatrix := AthensCairoMatrix new. fontMatrix scaleBy: (TextStyle pointsToPixels: aFont pointSize). font := self primCreate: face fontMatrix: fontMatrix userToDeviceMatrix: deviceMatrix options: options. "to keep a reference to cairo face in instance" ^ font initWithFace: face. ! ! !CairoScaledFont class methodsFor: 'instance creation' stamp: 'SeanDeNigris 4/3/2014 16:09'! fromFreetypeFont: aFont | ftFace face | ^ CairoBackendCache soleInstance at: aFont ifAbsentPut: [ ftFace := aFont face. face := CairoBackendCache soleInstance at: ftFace ifAbsentPut: [ CairoFontFace fromFreetypeFace: ftFace ]. self fromFreetypeFont: aFont cairoFace: face ]. ! ! !CairoScaledFont class methodsFor: 'finalizing' stamp: 'IgorStasenko 6/11/2012 06:50'! finalizeResourceData: handle " void cairo_scaled_font_destroy (cairo_scaled_font_t *scaled_font); " ^ self nbCall: #( void cairo_scaled_font_destroy (size_t handle) )! ! !CairoScaledFont class methodsFor: 'as yet unclassified' stamp: ''! nbLibraryNameOrHandle ^ CairoLibraryLoader getLibraryHandle! ! !CairoTextExtents commentStamp: ''! I represent the cairo_text_extents_t structure type The cairo_text_extents_t structure stores the extents of a single glyph or a string of glyphs in user-space coordinates. Because text extents are in user-space coordinates, they are mostly, but not entirely, independent of the current transformation matrix. If you call cairo_scale(cr, 2.0, 2.0), text will be drawn twice as big, but the reported text extents will not be doubled. They will change slightly due to hinting (so you can't assume that metrics are independent of the transformation matrix), but otherwise will remain unchanged. double x_bearing; the horizontal distance from the origin to the leftmost part of the glyphs as drawn. Positive if the glyphs lie entirely to the right of the origin. double y_bearing; the vertical distance from the origin to the topmost part of the glyphs as drawn. Positive only if the glyphs lie completely below the origin; will usually be negative. double width; width of the glyphs as drawn double height; height of the glyphs as drawn double x_advance; distance to advance in the X direction after drawing these glyphs double y_advance; distance to advance in the Y direction after drawing these glyphs. Will typically be zero except for vertical text layout as found in East-Asian languages.! !CairoTextExtents class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 6/11/2012 07:01'! fieldsDesc ^ #( double x_bearing; double y_bearing; double width; double height; double x_advance; double y_advance; )! ! !CairoUTF8Converter commentStamp: ''! i use persistent buffer to convert strings to utf-8 strings (an input neede by cairo)! !CairoUTF8Converter methodsFor: 'initialize' stamp: 'IgorStasenko 4/8/2014 15:45'! initialize encoder := ZnUTF8Encoder new.! ! !CairoUTF8Converter methodsFor: 'accessing' stamp: 'IgorStasenko 8/28/2012 18:03'! buffer ^ buffer! ! !CairoUTF8Converter methodsFor: 'not finished yet' stamp: 'ClementBera 6/28/2013 10:30'! convertUnicode: anAsm " input: - EAX 32-bit unicode value to convert . output: - EAX - utf-8 encoded character (in little-endian byte order) max 4 bytes - EDX - number of encoded bytes " | moreThanOne moreThanTwo moreThanThree end | moreThanOne := anAsm uniqueLabelName: 'moreThanOne'. moreThanTwo := anAsm uniqueLabelName: 'moreThanTwo'. moreThanThree := anAsm uniqueLabelName: 'moreThanThree'. end := anAsm uniqueLabelName: 'end'. anAsm cmp: anAsm EAX with: 16r7F; jg: moreThanOne; "one byte" mov: 1 to: anAsm EDX; jmp: end; label: moreThanOne; cmp: anAsm EAX with: 16r7FF; jg: moreThanTwo; "two bytes 80 .. 7FF" " AH AL " "00000aaa aabbbbbb" "110aaaaa 10bbbbbb AL AH (little endian order) " shr: anAsm EAX with: 2; shl: anAsm AL with: 2; or: anAsm AX with: 2r1100000010000000; xchg: anAsm AL with: anAsm AH; mov: 2 to: anAsm EDX; jmp: end; label: moreThanTwo; cmp: anAsm EAX with: 16rFFFF; jg: moreThanThree; "three bytes 800 ... FFFF" " AH AL " "aaaabbbb bbcccccc" " => 1110aaaa 10bbbbbb 10cccccc" shl: anAsm EAX with: 4; shr: anAsm AX with: 2; shr: anAsm AL with: 2; " EAX = ...aaaa xxbbbbbb xxcccccc " or: anAsm EAX with: 2r111000001000000010000000; "16rE08080" shl: anAsm EAX with: 8; bswap: anAsm EAX; mov: 3 to: anAsm EDX; jmp: end; "four bytes 1000 ... 10FFFF" " AH AL " "000aaabb bbbbcccc ccdddddd" "=> 11110aaa 10bbbbbb 10cccccc 10dddddd" mov: anAsm EAX to: anAsm EDX; shl: anAsm EAX with: 4; shr: anAsm AX with: 2; shr: anAsm AL with: 2; " EAX = 0000000a aabbbbbb xxcccccc xxdddddd " and: anAsm EAX with: 16r3F3F3F; bswap: anAsm EAX; shr: anAsm EDX with: 18; "6*3" or: anAsm DL with: 16r11110000; mov: anAsm DL to: anAsm AL; mov: 4 to: anAsm EDX; label: end ! ! !CairoUTF8Converter methodsFor: 'not finished yet' stamp: 'IgorStasenko 6/22/2012 15:10'! store: numBytes accumulated: accumBytes | toShift left | asm label: ('write', numBytes asString , 'to' , accumBytes asString) asSymbol. (accumBytes + numBytes ) > 4 ifTrue: [ toShift := 4 - accumBytes. left := numBytes - toShift ] ifFalse: [ toShift := numBytes. left := 0 ]. (accumBytes = 0 and: [numBytes = 4]) ifTrue: [ "just store directly" asm mov: asm EAX to: asm EDI ptr. ]. asm shrd: asm EBX with: asm EAX with: toShift * 8. ! ! !CairoUTF8Converter methodsFor: 'converting' stamp: 'IgorStasenko 4/8/2014 15:46'! checkBufferSpace: minimalSize | size | size := buffer ifNil: [ 0 ] ifNotNil: [ buffer size ]. size < minimalSize ifTrue: [ buffer := ByteArray new: minimalSize. bs := buffer writeStream. ] ! ! !CairoUTF8Converter methodsFor: 'converting' stamp: 'IgorStasenko 4/8/2014 15:50'! convert: aString from: start to: end self checkBufferSpace: 4*(end-start + 2). bs reset. encoder next: end-start+1 putAll: aString startingAt: start toStream: bs . "DO NOT NULL-Terminate because its not used" ^ bs position.! ! !CairoUTF8Converter methodsFor: 'converting' stamp: 'IgorStasenko 4/8/2014 15:48'! convertChar: aCharacter self checkBufferSpace: 8. bs reset. encoder nextPut: aCharacter toStream: bs. bs nextPut: 0. ^ buffer! ! !CairoUTF8Converter methodsFor: 'not finished yet' stamp: 'IgorStasenko 6/12/2012 18:02'! convertWideString: aWideString ! ! !CairoUTF8Converter methodsFor: 'not finished yet' stamp: 'ClementBera 6/28/2013 10:30'! convertUnicode: anAsm conversionLabels: convLabels " input: - EAX 32-bit unicode value to convert . output: - EAX - utf-8 encoded character (in little-endian byte order) max 4 bytes - EDX - number of encoded bytes " | moreThanTwo moreThanThree | moreThanTwo := anAsm uniqueLabelName: 'moreThanTwo'. moreThanThree := anAsm uniqueLabelName: 'moreThanThree'. anAsm cmp: anAsm EAX with: 16r7F; jle: (convLabels at: 1); "one byte" cmp: anAsm EAX with: 16r7FF; jg: moreThanTwo; "two bytes 80 .. 7FF" " AH AL " "00000aaa aabbbbbb" "110aaaaa 10bbbbbb AL AH (little endian order) " shr: anAsm EAX with: 2; shl: anAsm AL with: 2; or: anAsm AX with: 2r1100000010000000; xchg: anAsm AL with: anAsm AH; jmp: (convLabels at: 2); label: moreThanTwo; cmp: anAsm EAX with: 16rFFFF; jg: moreThanThree; "three bytes 800 ... FFFF" " AH AL " "aaaabbbb bbcccccc" " => 1110aaaa 10bbbbbb 10cccccc" shl: anAsm EAX with: 4; shr: anAsm AX with: 2; shr: anAsm AL with: 2; " EAX = ...aaaa xxbbbbbb xxcccccc " or: anAsm EAX with: 2r111000001000000010000000; "16rE08080" shl: anAsm EAX with: 8; bswap: anAsm EAX; jmp: (convLabels at: 3); "four bytes 1000 ... 10FFFF" " AH AL " "000aaabb bbbbcccc ccdddddd" "=> 11110aaa 10bbbbbb 10cccccc 10dddddd" mov: anAsm EAX to: anAsm EDX; shl: anAsm EAX with: 4; shr: anAsm AX with: 2; shr: anAsm AL with: 2; " EAX = 0000000a aabbbbbb xxcccccc xxdddddd " and: anAsm EAX with: 16r3F3F3F; or: anAsm EAX with: 16r808080; bswap: anAsm EAX; shr: anAsm EDX with: 18; "6*3" or: anAsm DL with: 16r11110000; mov: anAsm DL to: anAsm AL; jmp: (convLabels at: 4)! ! !CairoUTF8Converter methodsFor: 'not finished yet' stamp: 'ClementBera 6/28/2013 10:31'! convertByteString: aByteString ^ NBFFICallout cdecl: #( void (void * aByteString)) emitCall: [:gen :proxy :anAsm | ]! ! !CairoUTF8ConverterTest commentStamp: ''! A CairoUTF8ConverterTest is a test class for testing the behavior of CairoUTF8Converter! !CairoUTF8ConverterTest methodsFor: 'tests' stamp: 'IgorStasenko 4/8/2014 15:21'! testUnicodencodingShouldTerminateWithNull | buf | buf := encoder convertChar: $a. self assert: (buf first:2) equals: #[97 0 ] ! ! !CairoUTF8ConverterTest methodsFor: 'tests' stamp: 'IgorStasenko 4/8/2014 16:01'! testEncodingString | pos | pos := encoder convert: 'abc' from: 1 to: 3. self assert: pos equals: 3. self assert: (encoder buffer first:3) equals: #[97 98 99] ! ! !CairoUTF8ConverterTest methodsFor: 'tests' stamp: 'IgorStasenko 4/8/2014 15:41'! testReusingConverterShouldReplaceOldData | buf | buf := encoder convertChar: 223 asCharacter. self assert: (buf first:3) equals: #[195 159 0 ]. buf := encoder convertChar: $b. self assert: (buf first:2) equals: #[98 0 ] ! ! !CairoUTF8ConverterTest methodsFor: 'running' stamp: 'IgorStasenko 4/8/2014 15:20'! setUp encoder := CairoUTF8Converter new.! ! !CalendarDayMorph commentStamp: ''! A CalendarDyaMorph represents a specific day on a monthly calendar. Instance Variables bounds: date: highlighted: owner: bounds - owner-relative bounding box date - the specific date (year/month/day) the CalendarMorph represents highlighted - flag to keep track of when a CalendarMorph has the mouse dragging over it, and is thus highlighted owner - the morph that contains the CalendarMorph, and all its siblings ! !CalendarDayMorph methodsFor: 'printing' stamp: 'Jon 11/2/2011 08:39'! debugPrint ^(WriteStream on: (String new: 10)) print: self class; nextPutAll: ' ('; print: self date; nextPutAll: ' - '; print: self bounds; nextPut: $); contents! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 21:19'! owner ^ owner! ! !CalendarDayMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 1/27/2013 12:42'! initialize super initialize. self highlighted: false! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 21:18'! bounds ^ bounds! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 08:51'! highlighted: aBoolean highlighted := aBoolean! ! !CalendarDayMorph methodsFor: 'drawing' stamp: 'Jon 11/2/2011 09:00'! drawOn: aCanvas offset: origin | box dayString textColor textTopLeft textWidth today | dayString := date dayOfMonth printString. textWidth := owner weekdayFont widthOfString: dayString. textTopLeft := bounds topCenter translateBy: (textWidth // -2) @ 3. box := ((textTopLeft extent: textWidth @ owner weekdayFont height) insetBy: -8 @ -1) translateBy: origin. today := date = Date today. textColor := date month = owner date month ifTrue: [Color black] ifFalse: [Color veryLightGray]. (date = owner date or: [self highlighted]) ifTrue: [ | lineColor fillColor | lineColor := today ifTrue: [Color red] ifFalse: [Color veryLightGray]. fillColor := self highlighted ifTrue: [Color veryVeryLightGray] ifFalse: [Color veryLightGray]. aCanvas fillOval: box color: fillColor borderWidth: 1 borderColor: lineColor]. today & (date ~= owner date) & self highlighted not ifTrue: [aCanvas fillOval: box color: Color white borderWidth: 1 borderColor: Color red]. aCanvas drawString: dayString at: textTopLeft + origin font: owner weekdayFont color: textColor.! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 21:18'! bounds: aRectangle bounds := aRectangle! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 21:18'! date ^ date! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 08:51'! highlighted ^highlighted! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 21:19'! owner: aCalendarChooserMorph owner := aCalendarChooserMorph! ! !CalendarDayMorph methodsFor: 'printing' stamp: 'Jon 11/2/2011 08:19'! printOn: aStream aStream print: self class; nextPutAll: ' ('; print: self date; nextPut: $)! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 21:18'! date: aDate date := aDate. ! ! !CalendarDayMorph class methodsFor: 'instance creation' stamp: 'Jon 11/2/2011 08:06'! on: aDate for: aCalendarChooserMorph ^self new date: aDate; owner: aCalendarChooserMorph; yourself. ! ! !CalendarMorph commentStamp: ''! A CalendarMorph is a standalone morph that represents a selectable monthly calendar. CalendarMorph openOn: Date today Instance Variables date: days: > touchPoints: value: > date - the currently selected date (always within the current month) days - all the days that are visible, including days from the previous month, the current month, and the next month touchPoints - extra hotspots that are touch-responsive (key rectangle is in world coordinates) ! !CalendarMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 1/22/2013 14:18'! weekdayFont ^ LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 9.! ! !CalendarMorph methodsFor: 'event handling' stamp: 'SeanDeNigris 1/20/2013 21:18'! mouseUp: event "Check for hotspot hits - handle them if they match. Otherwise, convert the event cursor to morph-local, and find the day under it. If there is nothing under the mouse when it goes up, nothing happens." | morphRelativeHitPoint | touchPoints keysAndValuesDo: [:eachBox :eachSelector | (eachBox containsPoint: event cursorPoint) ifTrue: [self perform: eachSelector]]. morphRelativeHitPoint := event cursorPoint translateBy: bounds origin negated. days do: [:each | each highlighted: false. (each bounds containsPoint: morphRelativeHitPoint) ifTrue: [ self date: each date. self announceDate ]]. self changed. ! ! !CalendarMorph methodsFor: 'announcing' stamp: 'SeanDeNigris 1/20/2013 21:13'! onChoiceSend: aSymbol to: anObject self announcer on: ChoseDate send: aSymbol to: anObject.! ! !CalendarMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 08:31'! date: aDate | recompute | recompute := date isNil or: [date month ~= aDate month]. date := aDate. recompute ifTrue: [self computeDays]! ! !CalendarMorph methodsFor: 'event handling' stamp: 'Jon 11/2/2011 08:46'! handlesMouseDown: event ^true! ! !CalendarMorph methodsFor: 'initialize' stamp: 'Jon 11/3/2011 10:16'! defaultBounds "Answer the default bounds for the receiver." ^0 @ 0 corner: 200 @ 160! ! !CalendarMorph methodsFor: 'drawing' stamp: 'Jon 11/2/2011 09:14'! drawTodayOn: aCanvas | text textHeight textTopLeft textWidth textBox | text := 'Today: ', (Date today printFormat: #(2 1 3 $ 3 1 1)). textWidth := self weekdayFont widthOfString: text. textHeight := self weekdayFont height. textTopLeft := self bounds bottomCenter translateBy: (textWidth // -2) @ (textHeight negated - 5). textBox := textTopLeft extent: textWidth @ textHeight. touchPoints at: textBox put: #handleTodayTouched. aCanvas drawString: text at: textTopLeft font: self weekdayFont color: Color gray! ! !CalendarMorph methodsFor: 'event handling' stamp: 'SeanDeNigris 1/26/2013 18:13'! handleNextMonthTouched self date: date onNextMonth. self changed. ! ! !CalendarMorph methodsFor: 'initialization' stamp: 'Jon 11/3/2011 10:16'! initialize super initialize. touchPoints := Dictionary new. ! ! !CalendarMorph methodsFor: 'event handling' stamp: 'SeanDeNigris 1/26/2013 18:13'! handlePreviousMonthTouched self date: date onPreviousMonth. self changed. ! ! !CalendarMorph methodsFor: 'private' stamp: 'Jon 11/2/2011 15:20'! daysForLine: aNumber "Return an array of numbers that correspond to the day-of-month numbers of the given line (row) in the calendar for the month of the receiver's date." | dayCount firstWeekday previousDayCount previousMonthDays lastDay | dayCount := date month daysInMonth. firstWeekday := Date firstWeekdayOfMonth: date monthIndex year: date year. previousDayCount := date month previous daysInMonth. "First case - handle the first line specially" aNumber = 1 ifTrue: [ "If this month's first day is Sunday, the first line is the last week from last month" firstWeekday = 1 ifTrue: [^(previousDayCount - 6 to: previousDayCount) asArray]. "Otherwise, its a mix of last month and this month" previousMonthDays := (firstWeekday - 1 to: 1 by: -1) collect: [:each | previousDayCount - each + 1]. ^previousMonthDays, ((1 to: 7) asArray copyFrom: 1 to: 7 - previousMonthDays size)]. "Recompute the last day from the previous line (I love recursion)" lastDay := (self daysForLine: aNumber - 1) last. "Second case - the first week of this month starts on Sunday" (aNumber = 2 and: [lastDay = previousDayCount]) ifTrue: [^(1 to: 7) asArray]. "Third case - the first week of next month starts on Sunday" lastDay = dayCount ifTrue: [^(1 to: 7) asArray]. "Fourth case - everything else" ^(lastDay + 1 to: lastDay + 7) collect: [:each | each <= dayCount ifTrue: [each] ifFalse: [each - dayCount]]! ! !CalendarMorph methodsFor: 'event handling' stamp: 'MarcusDenker 9/13/2013 16:18'! handleMonthNameTouched | newMonthName dayCount | newMonthName := UIManager default chooseDropList: 'Choose a month:' list: #('January' 'February' 'March' 'April' 'May' 'June' 'July' 'August' 'September' 'October' 'November' 'December'). newMonthName isNil ifTrue: [^self]. dayCount := (Month year: date year month: newMonthName) daysInMonth. self date: (Date year: date year month: newMonthName day: (date dayOfMonth min: dayCount)). self changed. ! ! !CalendarMorph methodsFor: 'event handling' stamp: 'Jon 11/2/2011 08:52'! mouseMove: event self mouseDown: event! ! !CalendarMorph methodsFor: 'private' stamp: 'SeanDeNigris 1/20/2013 21:10'! announcer ^ announcer ifNil: [ announcer := Announcer new ].! ! !CalendarMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 16:39'! extent: aPoint "Since the day objects cache their bounding box, we have to recompute them if the receiver resizes." | result | result := super extent: aPoint. date notNil ifTrue: [self computeDays]. ^result! ! !CalendarMorph methodsFor: 'drawing' stamp: 'Jon 11/2/2011 09:16'! drawOn: aCanvas touchPoints := Dictionary new. aCanvas clipBy: self bounds during: [:clippedCanvas | clippedCanvas fillRectangle: self bounds color: Color white. self drawMonthHeaderOn: clippedCanvas; drawWeekDayNamesOn: clippedCanvas; drawDaysOn: clippedCanvas; drawTodayOn: aCanvas. clippedCanvas frameRectangle: self bounds width: 1 color: Color black]. ! ! !CalendarMorph methodsFor: 'event handling' stamp: 'Jon 11/2/2011 09:21'! handleTodayTouched self date: Date today. self changed. ! ! !CalendarMorph methodsFor: 'event handling' stamp: 'CamilloBruni 8/22/2013 19:49'! handleYearTouched | newYear dayCount | newYear := UIManager default chooseOrRequestFrom: (2000 to: 2020) lines: #() title: 'Choose a year:'. newYear isNil ifTrue: [^self]. newYear := newYear asNumber. dayCount := (Month year: newYear month: date monthIndex) daysInMonth. self date: (Date year: newYear month: date monthIndex day: (date dayOfMonth min: dayCount)). self changed.! ! !CalendarMorph methodsFor: 'drawing' stamp: 'Jon 11/2/2011 08:29'! drawDaysOn: aCanvas days do: [:each | each drawOn: aCanvas offset: self bounds topLeft]! ! !CalendarMorph methodsFor: 'drawing' stamp: 'Jon 11/2/2011 15:01'! drawMonthHeaderOn: aCanvas | headerWidth headerString box textBox textTopLeft monthBox monthNameWidth yearBox previousMonthBox nextMonthBox | headerString := date asMonth printString. headerWidth := self monthNameFont widthOfString: headerString. box := self bounds topLeft extent: self bounds width @ 23. textTopLeft := self bounds topCenter translateBy: (headerWidth // -2) @ 5. textBox := textTopLeft extent: headerWidth @ self monthNameFont height. monthNameWidth := self monthNameFont widthOfString: self date monthName, ' '. monthBox := textBox topLeft extent: monthNameWidth @ textBox height. yearBox := monthBox topRight corner: textBox bottomRight. previousMonthBox := (self bounds topLeft translateBy: 10 @ 5) extent: 10 @ self monthNameFont height. nextMonthBox := (self bounds topRight translateBy: -20 @ 5) extent: 10 @ self monthNameFont height. touchPoints at: monthBox put: #handleMonthNameTouched; at: yearBox put: #handleYearTouched; at: (previousMonthBox expandBy: 10 @ 5) put: #handlePreviousMonthTouched; at: (nextMonthBox expandBy: 10 @ 5) put: #handleNextMonthTouched. aCanvas frameAndFillRectangle: box fillColor: Color veryLightGray borderWidth: 1 borderColor: Color black; line: box bottomLeft to: box bottomRight width: 2 color: Color black; drawString: '<' at: previousMonthBox origin font: self monthNameFont color: Color black; drawString: '>' at: nextMonthBox origin font: self monthNameFont color: Color black; drawString: headerString at: (self bounds topCenter translateBy: (headerWidth // -2) @ 5) font: self monthNameFont color: Color black. ! ! !CalendarMorph methodsFor: 'drawing' stamp: 'Jon 11/1/2011 21:40'! drawWeekDayNamesOn: aCanvas | cellHeight height topLeft topRight cellWidth | topLeft := self bounds topLeft translateBy: 0 @ 25. topRight := self bounds topRight translateBy: 0 @ 25. height := self bounds height - 25. cellHeight := height // 8. cellWidth := self bounds width // 7. aCanvas line: (topLeft translateBy: 0 @ cellHeight) to: (topRight translateBy: 0 @ cellHeight) width: 1 color: Color black. #('Sun' 'Mon' 'Tue' 'Wed' 'Thu' 'Fri' 'Sat') withIndexDo: [:dayName :dayIndex | | cellPosX cellTopCenter textWidth | cellPosX := cellWidth * (dayIndex - 1). cellTopCenter := topLeft translateBy: ((cellPosX + (cellWidth // 2)) + 1) @ 0. textWidth := self weekdayFont widthOfString: dayName. aCanvas drawString: dayName at: (cellTopCenter translateBy: (textWidth // -2) @ 3) font: self weekdayFont color: Color darkGray] ! ! !CalendarMorph methodsFor: 'private' stamp: 'SeanDeNigris 1/22/2013 14:57'! computeDays "Populate the days instance variable with CalendarChooserDay instances for the receiver's month." | cellHeight cellWidth height topLeft lastMonth nextMonth theDay thisMonth | topLeft := 0 @ 25. height := self bounds height - 25. cellHeight := height // 8. height := height - cellHeight. cellWidth := self bounds width // 7. lastMonth := date month previous. thisMonth := date month. nextMonth := date month next. days := OrderedCollection new. 1 to: 6 do: [:lineIndex | | yOffset | yOffset := topLeft y + (lineIndex * cellHeight). (self daysForLine: lineIndex) withIndexDo: [:day :dayIndex | | cellPosX dayDate | dayDate := thisMonth asDate addDays: day - 1. (lineIndex = 1 and: [day > 7]) ifTrue: [dayDate := lastMonth asDate addDays: day - 1]. (lineIndex > 4 and: [day < 15]) ifTrue: [dayDate := nextMonth asDate addDays: day - 1]. cellPosX := cellWidth * (dayIndex - 1). days add: (theDay := CalendarDayMorph on: dayDate for: self). theDay bounds: (cellPosX @ yOffset extent: cellWidth @ cellHeight)]]! ! !CalendarMorph methodsFor: 'private' stamp: 'SeanDeNigris 1/26/2013 17:57'! announceDate | announcement | announcement := ChoseDate of: self date from: self. announcer ifNotNil: [ announcer announce: announcement ].! ! !CalendarMorph methodsFor: 'accessing' stamp: 'Jon 11/1/2011 20:57'! date ^date! ! !CalendarMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 1/26/2013 17:56'! monthNameFont | font boldItalic | font := LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 12. boldItalic := TextEmphasis italic emphasisCode | TextEmphasis bold emphasisCode. ^ font emphasis: boldItalic.! ! !CalendarMorph methodsFor: 'event handling' stamp: 'SeanDeNigris 1/26/2013 17:22'! mouseDown: event "Handle mouse down and mouse movement. Highlight the day under the mouse." | morphRelativeHitPoint | morphRelativeHitPoint := event cursorPoint translateBy: bounds origin negated. days do: [:each | each highlighted: (each bounds containsPoint: morphRelativeHitPoint)]. self changed. ! ! !CalendarMorph class methodsFor: 'instance creation' stamp: 'Jon 11/3/2011 09:59'! openOn: aDate ^(self on: aDate) openInWorld! ! !CalendarMorph class methodsFor: 'instance creation' stamp: 'Jon 11/3/2011 10:11'! on: aDate ^self new "extent: 200 @ 160;" date: aDate; yourself. ! ! !CannotDeleteFileException commentStamp: 'TorstenBergmann 2/3/2014 23:37'! Notfify when not able to delete! !Canvas commentStamp: ''! A canvas is a two-dimensional medium on which morphs are drawn in a device-independent manner. Canvases keep track of the origin and clipping rectangle, as well as the underlying drawing medium (such as a window, pixmap, or postscript script). Subclasses must implement (at least) the following methods: * Drawing: #fillOval:color:borderWidth:borderColor: #frameAndFillRectangle:fillColor:borderWidth:borderColor: #drawPolygon:color:borderWidth:borderColor: #image:at:sourceRect:rule: #stencil:at:sourceRect:rule: #line:to:width:color: #paragraph:bounds:color: #text:bounds:font:color: * Support #clipBy:during: #translateBy:during: #translateBy:clippingTo:during: #transformBy:clippingTo:during: ! !Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 02:53'! clipBy: aRectangle during: aBlock "Set a clipping rectangle active only during the execution of aBlock. Note: In the future we may want to have more general clip shapes - not just rectangles" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:13'! drawString: s in: boundsRect font: fontOrNil color: c ^self drawString: s from: 1 to: s size in: boundsRect font: fontOrNil color: c! ! !Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'! frameOval: r color: c self fillOval: r color: Color transparent borderWidth: 1 borderColor: c. ! ! !Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:58'! drawPolygon: vertices fillStyle: aFillStyle borderWidth: bw borderColor: bc "Fill the given polygon. Note: The default implementation does not recognize any enhanced fill styles" self drawPolygon: vertices color: aFillStyle asColor borderWidth: bw borderColor: bc! ! !Canvas methodsFor: 'drawing-general' stamp: 'StephaneDucasse 2/8/2011 09:30'! fullDrawMorph: aMorph "Hook method for potential other canvases. In the core, this method looks supefluous but PostscriptCanvases and other canvases can specialized it for Morph rendering. Therefore it should not be merged with fullDraw:." self fullDraw: aMorph! ! !Canvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 16:02'! transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock "Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')." ^ self transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: 1 ! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 6/25/1999 12:17'! stencil: stencilForm at: aPoint color: aColor "Flood this canvas with aColor wherever stencilForm has non-zero pixels" ^self stencil: stencilForm at: aPoint sourceRect: stencilForm boundingBox color: aColor! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:35'! drawString: s at: pt ^ self drawString: s from: 1 to: s size at: pt font: nil color: Color black! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'gvc 9/18/2006 16:52'! frameRectangle: aRectangle width: width colors: colors dashes: dashes offset: offset "Draw a rectangle with the given width, colors and dash lengths. The offset specifies how the coordinate system is translated from the screen origin (infinite forms are 0@0 screen based)." |o s hf vf c r ds di d os l| width < 1 ifTrue: [^self]. dashes size < 2 ifTrue: [^self frameRectangle: aRectangle width: width color: colors first]. r := aRectangle. s := dashes sum * width. ds := dashes size. di := 1. d := (dashes at: di) * width. c := colors at: di. hf := Form extent: s @ 1 depth: 32. r height >= width ifTrue: [ o := r left + offset x \\ s. 0 to: s - 1 do: [:x | hf colorAt: x + o \\ s @ 0 put: c. d := d - 1. d = 0 ifTrue: [ di := di \\ ds + 1. d := (dashes at: di) * width. c := colors at: di]]. os := 0. l := r width truncateTo: width. self fillRectangle: (r topLeft + (os@0) extent: l@width) color: (InfiniteForm with: hf)]. vf := Form extent: 1 @ s depth: 32. r width >= width ifTrue: [ o := r top + offset y + width + (s - (r width \\ s)) \\ s. 0 to: s - 1 do: [:y | vf colorAt: 0 @ (y + o \\ s) put: c. d := d - 1. d = 0 ifTrue: [ di := di \\ ds + 1. d := (dashes at: di) * width. c := colors at: di]]. os := width - (r width \\ width). l := r height - os truncateTo: width. self fillRectangle: (r topRight + (width negated @ os) extent: width@l) color: (InfiniteForm with: vf)]. r height > width ifTrue: [ o := r right + offset x - (width * 2) + (r height \\ s) + (r width \\ s) \\ s. 0 to: s - 1 do: [:x | hf colorAt: o + s -1 - x \\ s @ 0 put: c. d := d - 1. d = 0 ifTrue: [ di := di \\ ds + 1. d := (dashes at: di) * width. c := colors at: di]]. os := width - (r width \\ width + (r height \\ width) \\ width). l := r width - os truncateTo: width. os := (r width - os) \\ width. self fillRectangle: (r bottomLeft + (os @ width negated) extent: l@width) color: (InfiniteForm with: hf)]. r width > width ifTrue: [ o := r top + offset y + (r height * 2 \\ s) + (r width * 2 \\ s) - (width * 3) \\ s. 0 to: s - 1 do: [:y | vf colorAt: 0 @ (o + s -1 - y \\ s) put: c. d := d - 1. d = 0 ifTrue: [ di := di \\ ds + 1. d := (dashes at: di) * width. c := colors at: di]]. l := r height - (2 * width) + os. os := width. self fillRectangle: (r topLeft + (0@os) extent: width@l) color: (InfiniteForm with: vf)]! ! !Canvas methodsFor: 'converting' stamp: 'ar 8/8/2001 14:14'! asShadowDrawingCanvas: aColor ^(ShadowDrawingCanvas on: self) shadowColor: aColor! ! !Canvas methodsFor: 'converting' stamp: 'ar 6/24/1999 17:46'! asShadowDrawingCanvas ^self asShadowDrawingCanvas: (Color black alpha: 0.5).! ! !Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:00'! translateBy: delta during: aBlock "Set a translation only during the execution of aBlock." ^self subclassResponsibility! ! !Canvas methodsFor: 'testing' stamp: 'di 9/24/2000 16:10'! seesNothingOutside: aRectangle "Return true if this canvas will not touch anything outside aRectangle" ^ aRectangle containsRect: self clipRect ! ! !Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:51'! fillOval: aRectangle fillStyle: aFillStyle "Fill the given oval." ^self fillOval: aRectangle fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:37'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'StephaneDucasse 2/9/2011 14:36'! fillRectangle: aRectangle fillStyle: aFillStyle "Fill the given rectangle. Double-dispatched via the fill style." aFillStyle fillRectangle: aRectangle on: self! ! !Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'! fillOval: r color: c self fillOval: r color: c borderWidth: 0 borderColor: Color transparent. ! ! !Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'! frameOval: r width: w color: c self fillOval: r color: Color transparent borderWidth: w borderColor: c. ! ! !Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:07'! clipRect "Return the currently active clipping rectangle" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-general' stamp: 'GaryChambers 9/8/2011 14:47'! roundShadowCornersOf: aMorph during: aBlock ^self roundShadowCornersOf: aMorph in: aMorph bounds during: aBlock! ! !Canvas methodsFor: 'testing' stamp: 'ar 11/13/1998 13:19'! isBalloonCanvas ^false! ! !Canvas methodsFor: 'accessing' stamp: 'jm 6/2/1998 06:39'! form ^ Display ! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 5/29/1999 05:14'! draw: anObject ^anObject drawOn: self! ! !Canvas methodsFor: 'testing' stamp: 'IgorStasenko 7/18/2011 18:53'! isShadowDrawing ^false! ! !Canvas methodsFor: 'accessing' stamp: 'ar 2/12/2000 18:17'! contentsOfArea: aRectangle into: aForm "Return the contents of the given area" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-images' stamp: 'IgorStasenko 7/18/2011 18:08'! translucentImage: aForm at: aPoint sourceRect: sourceRect "Draw a translucent image using the best available way of representing translucency. Note: This will be fixed in the future." (self depth < 32 or:[aForm isTranslucent not]) ifTrue:[^self paintImage: aForm at: aPoint sourceRect: sourceRect]. self image: aForm at: aPoint sourceRect: sourceRect rule: Form blend! ! !Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:18'! fillColor: aColor "Fill the receiver with the given color. Note: This method should be named differently since it is intended to fill the background and thus fills even if the color is transparent" ^self fillRectangle: self clipRect color: (aColor alpha: 1.0).! ! !Canvas methodsFor: 'initialization' stamp: 'MarcusDenker 10/21/2013 14:21'! reset "Reset the canvas." self initWithTarget:self class defaultTarget. ! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 12/28/2001 23:54'! warpImage: aForm transform: aTransform at: extraOffset "Warp the given form using aTransform. TODO: Use transform to figure out appropriate cell size" ^self warpImage: aForm transform: aTransform at: extraOffset sourceRect: aForm boundingBox cellSize: 1! ! !Canvas methodsFor: 'drawing-general' stamp: ''! fullDraw: anObject ^anObject fullDrawOn: self! ! !Canvas methodsFor: 'testing' stamp: 'ar 6/22/1999 14:10'! isVisible: aRectangle "Return true if the given rectangle is (partially) visible" ^self clipRect intersects: aRectangle ! ! !Canvas methodsFor: 'drawing-images' stamp: 'IgorStasenko 7/18/2011 18:08'! paintImage: aForm at: aPoint sourceRect: sourceRect "Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value." ^self image: aForm at: aPoint sourceRect: sourceRect rule: Form paint! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 6/25/1999 12:17'! stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor "Flood this canvas with aColor wherever stencilForm has non-zero pixels" ^self subclassResponsibility! ! !Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:15'! extent "Return the physical extent of the output device" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'gvc 9/14/2006 14:33'! frameRectangle: aRectangle width: width colors: colors dashes: dashes "Draw a rectangle with the given width, colors and dash lengths." self frameRectangle: aRectangle width: width colors: colors dashes: dashes offset: self origin! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'RAA 8/14/2000 14:22'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor "Draw the rectangle using the given attributes. Note: This is a *very* simple implementation" | bw pt | self frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: bottomRightColor. bottomRightColor = topLeftColor ifFalse: [ bw := borderWidth asPoint. pt := r topLeft + (bw // 2). self line: pt to: pt + ((r extent x - bw x)@0) width: borderWidth color: topLeftColor. self line: pt to: pt + (0@(r extent y - bw y)) width: borderWidth color: topLeftColor. ].! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'! roundCornersOf: aMorph during: aBlock ^self roundCornersOf: aMorph in: aMorph bounds during: aBlock! ! !Canvas methodsFor: 'drawing' stamp: 'sr 4/27/2000 03:31'! line: pt1 to: pt2 width: w1 color: c1 stepWidth: s1 secondWidth: w2 secondColor: c2 secondStepWidth: s2 "Draw a line using the given width, colors and steps; both steps can have different stepWidths (firstStep, secondStep), draw widths and colors." | bigSteps offsetPoint dist p1p2Vec deltaBig delta1 delta2 lastPoint bigStep | s1 = 0 & (s2 = 0) ifTrue: [^ self]. dist := pt1 dist: pt2. dist = 0 ifTrue: [^ self]. bigStep := s1 + s2. bigSteps := dist / bigStep. p1p2Vec := pt2 - pt1. deltaBig := p1p2Vec / bigSteps. delta1 := deltaBig * (s1 / bigStep). delta2 := deltaBig * (s2 / bigStep). dist <= s1 ifTrue: [self line: pt1 rounded to: pt2 rounded width: w1 color: c1. ^ self]. 0 to: bigSteps truncated - 1 do: [:bigStepIx | self line: (pt1 + (offsetPoint := deltaBig * bigStepIx)) rounded to: (pt1 + (offsetPoint := offsetPoint + delta1)) rounded width: w1 color: c1. self line: (pt1 + offsetPoint) rounded to: (pt1 + (offsetPoint + delta2)) rounded width: w2 color: c2]. "if there was no loop, offsetPoint is nil" lastPoint := pt1 + ((offsetPoint ifNil: [0 @ 0]) + delta2). (lastPoint dist: pt2) <= s1 ifTrue: [self line: lastPoint rounded to: pt2 rounded width: w1 color: c1] ifFalse: [self line: lastPoint rounded to: (lastPoint + delta1) rounded width: w1 color: c1. self line: (lastPoint + delta1) rounded to: pt2 width: w1 color: c2]! ! !Canvas methodsFor: 'copying' stamp: 'ls 3/20/2000 21:24'! copyClipRect: newClipRect ^ ClippingCanvas canvas: self clipRect: newClipRect ! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'marcus.denker 8/15/2008 17:43'! frameRectangle: r width: w color: c "Draw a frame around the given rectangle" ^self frameAndFillRectangle: r fillColor: Color transparent borderWidth: w borderColor: c! ! !Canvas methodsFor: 'drawing-general' stamp: 'GaryChambers 9/8/2011 14:47'! roundShadowCornersOf: aMorph in: bounds during: aBlock ^aBlock value! ! !Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'! line: pt1 to: pt2 color: c self line: pt1 to: pt2 width: 1 color: c. ! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'AlexandreBergel 1/29/2013 14:13'! fillRectangle: aRectangle fillStyle: aFillStyle borderStyle: aBorderStyle "Fill the given rectangle." aFillStyle isTransparent ifFalse: [ self fillRectangle: (aRectangle insetBy: aBorderStyle width) fillStyle: aFillStyle ]. (aBorderStyle notNil and: [aBorderStyle width]) >= 0 ifTrue: [ aBorderStyle frameRectangle: aRectangle on: self ]. ! ! !Canvas methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 5/4/2012 16:47'! encryptedParagraph: para bounds: bounds color: c "Draw the given paragraph" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-text' stamp: 'tween 3/10/2009 07:42'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc ^self subclassResponsibility! ! !Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:11'! origin "Return the current origin for drawing operations" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:32'! fillRectangle: r color: c "Fill the rectangle using the given color" ^self frameAndFillRectangle: r fillColor: c borderWidth: 0 borderColor: Color transparent! ! !Canvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 14:08'! translateTo: newOrigin clippingTo: aRectangle during: aBlock "Set a new origin and clipping rectangle only during the execution of aBlock." self translateBy: newOrigin - self origin clippingTo: (aRectangle translateBy: self origin negated) during: aBlock! ! !Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:31'! line: pt1 to: pt2 width: w color: c "Draw a line using the given width and color" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-images' stamp: 'IgorStasenko 7/18/2011 18:08'! drawImage: aForm at: aPoint sourceRect: sourceRect "Draw the given form." ^self image: aForm at: aPoint sourceRect: sourceRect rule: Form over! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'! roundCornersOf: aMorph in: bounds during: aBlock ^aBlock value! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'gvc 3/21/2008 16:34'! fillRectangle: aRectangle basicFillStyle: aFillStyle "Fill the given rectangle with the given, non-composite, fill style Note: The default implementation does not recognize any enhanced fill styles." self fillRectangle: aRectangle color: aFillStyle asColor.! ! !Canvas methodsFor: 'other' stamp: 'StephaneDucasse 2/9/2011 14:51'! flushDisplay "Empty hook method."! ! !Canvas methodsFor: 'drawing' stamp: 'gvc 6/17/2006 10:42'! line: pt1 to: pt2 width: width colors: colors dashes: dashes startingOffset: startingOffset "Draw a line using the given width, colors and dash lengths. Dash lengths are considered as multiples of width." |dist deltaBig segmentOffset phase segmentLength startPoint distDone endPoint segLens lens l ep| width = 0 ifTrue: [^startingOffset]. dist := pt1 dist: pt2. dist = 0 ifTrue: [^startingOffset]. (dashes allSatisfy: [:d | d = 0]) ifTrue: [^startingOffset]. deltaBig := pt2 - pt1. segLens := dashes collect: [:d | d * width]. "Figure out what phase we are in and how far, given startingOffset." segmentOffset := startingOffset \\ segLens sum. lens := segLens readStream. l := 0. [lens atEnd or: [segmentOffset <= (l := l + lens next)]] whileFalse: []. segmentLength := lens atEnd ifTrue: [phase := segLens size. segLens sum - segmentOffset] ifFalse: [phase := lens position. (segLens first: phase) sum - segmentOffset.]. startPoint := pt1. distDone := 0.0. segmentLength < (segLens at: phase) ifTrue: [startPoint := startPoint + (deltaBig * segmentLength / dist). distDone := distDone + segmentLength. phase := phase \\ segLens size + 1. segmentLength := (segLens at: phase)]. [distDone < dist] whileTrue: [segmentLength := segmentLength min: dist - distDone. endPoint := startPoint + (deltaBig * segmentLength / dist). ep := startPoint + (deltaBig * (segmentLength - width max: 0) / dist). self line: startPoint truncated to: ep truncated width: width color: (colors at: phase). distDone := distDone + segmentLength. phase := phase \\ segLens size + 1. startPoint := endPoint. segmentLength := segLens at: phase]. ^startingOffset + distDone! ! !Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'! fillOval: r color: c borderWidth: borderWidth borderColor: borderColor "Fill the given oval." ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-general' stamp: 'StephaneDucasse 2/8/2011 09:10'! drawMorph: aMorph "Draw the receiver morph on the receiver" "Changed to improve performance. Have seen a 30% improvement." (aMorph fullBounds intersects: self clipRect) ifFalse: [^self]. self draw: aMorph! ! !Canvas methodsFor: 'other' stamp: 'StephaneDucasse 2/9/2011 14:51'! forceToScreen: rect "Empty hook method" ! ! !Canvas methodsFor: 'private' stamp: 'ar 2/12/2000 18:12'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Note: The public use of this protocol is deprecated. It will become private. Nobody in the outside world must assume that a thing like a combination rule has any specific effect." ^self subclassResponsibility! ! !Canvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:46'! shadowColor "Return the current override color or nil if no such color exists" ^nil! ! !Canvas methodsFor: 'drawing' stamp: 'ar 2/5/1999 18:28'! render: anObject "Do some 3D operations with the object if possible"! ! !Canvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 15:56'! transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize "Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')." ^ self subclassResponsibility! ! !Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 01:43'! preserveStateDuring: aBlock "Preserve the full canvas state during the execution of aBlock" ^aBlock value: self copy! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 12/28/2001 23:44'! warpImage: aForm transform: aTransform "Warp the given form using aTransform" ^self warpImage: aForm transform: aTransform at: 0@0! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:39'! drawString: s in: boundsRect ^self drawString: s from: 1 to: s size in: boundsRect font: nil color: Color black! ! !Canvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:21'! image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha "Privately used for blending forms w/ constant alpha. Fall back to simpler case by defaul." ^self image: aForm at: aPoint sourceRect: sourceRect rule: rule! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:33'! frameRectangle: r color: c self frameRectangle: r width: 1 color: c. ! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:25'! drawString: s at: pt font: aFont color: aColor ^ self drawString: s from: 1 to: s size at: pt font: aFont color: aColor! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:36'! drawString: s from: firstIndex to: lastIndex at: pt font: font color: aColor self drawString: s from: firstIndex to: lastIndex in: (pt extent: 10000@10000) font: font color: aColor! ! !Canvas methodsFor: 'drawing-support' stamp: 'gm 2/22/2003 14:53'! cache: aRectangle using: aCache during: aBlock "Cache the execution of aBlock by the given cache. Note: At some point we may want to actually *create* the cache here; for now we're only using it." (aCache notNil and: [(aCache isForm) and: [aCache extent = aRectangle extent]]) ifTrue: [^self paintImage: aCache at: aRectangle origin]. aBlock value: self! ! !Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:56'! drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc "Draw the given polygon." ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-text' stamp: 'tween 3/10/2009 08:12'! drawString: s in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc ^self drawString: s from: 1 to: s size in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc! ! !Canvas methodsFor: 'converting' stamp: 'ar 8/8/2001 14:22'! asAlphaBlendingCanvas: alpha ^(AlphaBlendingCanvas on: self) alpha: alpha! ! !Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:50'! fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc "Fill the given oval. Note: The default implementation does not recognize any enhanced fill styles" self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 2/16/2000 23:48'! paintImage: aForm at: aPoint "Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value." self paintImage: aForm at: aPoint sourceRect: aForm boundingBox ! ! !Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/25/1999 12:18'! drawPolygon: vertices fillStyle: aFillStyle "Fill the given polygon." self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent! ! !Canvas methodsFor: 'testing' stamp: 'di 8/12/2000 15:04'! doesRoundedCorners ^ true! ! !Canvas methodsFor: 'accessing' stamp: 'ar 2/12/2000 18:17'! contentsOfArea: aRectangle "Return the contents of the given area" ^self contentsOfArea: aRectangle into: (Form extent: aRectangle extent depth: self depth)! ! !Canvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:46'! shadowColor: aColor "Set a shadow color. If set this color overrides any client-supplied color."! ! !Canvas methodsFor: 'other' stamp: ''! translateBy:aPoint clippingTo:aRect during:aBlock ^aBlock value:(self copyOffset:aPoint clipRect:aRect).! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 2/16/2000 23:45'! drawImage: aForm at: aPoint "Draw the given Form, which is assumed to be a Form or ColorForm" self drawImage: aForm at: aPoint sourceRect: aForm boundingBox! ! !Canvas methodsFor: 'drawing-text' stamp: 'tween 3/10/2009 08:07'! drawString: s from: firstIndex to: lastIndex at: pt font: font color: aColor underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc self drawString: s from: firstIndex to: lastIndex in: (pt extent: 10000@10000) font: font color: aColor underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc! ! !Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:31'! paragraph: paragraph bounds: bounds color: c "Draw the given paragraph" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:32'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor "Draw the rectangle using the given attributes" ^self subclassResponsibility! ! !Canvas methodsFor: 'initialization' stamp: 'ar 2/9/1999 06:29'! flush! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 12/29/2001 00:20'! warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize "Warp the given using the appropriate transform and offset." ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 14:05'! translucentImage: aForm at: aPoint "Draw a translucent image using the best available way of representing translucency." self translucentImage: aForm at: aPoint sourceRect: aForm boundingBox! ! !Canvas methodsFor: 'drawing' stamp: 'aoy 2/15/2003 21:41'! line: pt1 to: pt2 width: width color: color1 dashLength: s1 secondColor: color2 secondDashLength: s2 startingOffset: startingOffset "Draw a line using the given width, colors and dash lengths. Originally written by Stephan Rudlof; tweaked by Dan Ingalls to use startingOffset for sliding offset as in 'ants' animations. Returns the sum of the starting offset and the length of this line." | dist deltaBig colors nextPhase segmentOffset phase segmentLength startPoint distDone endPoint segLens | dist := pt1 dist: pt2. dist = 0 ifTrue: [^startingOffset]. s1 = 0 & (s2 = 0) ifTrue: [^startingOffset]. deltaBig := pt2 - pt1. colors := { color1. color2}. segLens := { s1 asFloat. s2 asFloat}. nextPhase := { 2. 1}. "Figure out what phase we are in and how far, given startingOffset." segmentOffset := startingOffset \\ (s1 + s2). segmentLength := segmentOffset < s1 ifTrue: [phase := 1. s1 - segmentOffset] ifFalse: [phase := 2. s1 + s2 - segmentOffset]. startPoint := pt1. distDone := 0.0. [distDone < dist] whileTrue: [segmentLength := segmentLength min: dist - distDone. endPoint := startPoint + (deltaBig * segmentLength / dist). self line: startPoint truncated to: endPoint truncated width: width color: (colors at: phase). distDone := distDone + segmentLength. phase := nextPhase at: phase. startPoint := endPoint. segmentLength := segLens at: phase]. ^startingOffset + dist! ! !Canvas methodsFor: 'initialization' stamp: 'ar 5/27/2000 21:50'! finish "If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect." ^self flush! ! !Canvas methodsFor: 'accessing' stamp: ''! depth ^ Display depth ! ! !CascadeNode commentStamp: ''! The first message has the common receiver, the rest have receiver == nil, which signifies cascading.! !CascadeNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 09:41'! emitCodeForValue: stack encoder: encoder receiver emitCodeForValue: stack encoder: encoder. 1 to: messages size - 1 do: [:i | encoder genDup. stack push: 1. (messages at: i) emitCodeForValue: stack encoder: encoder. encoder genPop. stack pop: 1]. messages last emitCodeForValue: stack encoder: encoder! ! !CascadeNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:33'! accept: aVisitor ^aVisitor visitCascadeNode: self! ! !CascadeNode methodsFor: 'accessing' stamp: 'eem 9/10/2008 15:15'! messages ^messages! ! !CascadeNode methodsFor: 'code generation (closures)' stamp: 'eem 5/19/2008 20:26'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" { receiver }, messages do: [:node| node analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools]! ! !CascadeNode methodsFor: 'initialize-release' stamp: ''! receiver: receivingObject messages: msgs " Transcript show: 'abc'; cr; show: 'def' " receiver := receivingObject. messages := msgs! ! !CascadeNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 09:39'! sizeCodeForValue: encoder | size | size := (receiver sizeCodeForValue: encoder) + (messages size - 1 * (encoder sizeDup + encoder sizePop)). messages do: [:aMessage | size := size + (aMessage sizeCodeForValue: encoder)]. ^size! ! !CascadeNode methodsFor: 'accessing' stamp: 'tk 10/22/2000 16:55'! receiver ^receiver! ! !CascadeNode methodsFor: 'printing' stamp: 'di 4/25/2000 19:17'! printOn: aStream indent: level precedence: p p > 0 ifTrue: [aStream nextPut: $(]. messages first printReceiver: receiver on: aStream indent: level. 1 to: messages size do: [:i | (messages at: i) printOn: aStream indent: level. i < messages size ifTrue: [aStream nextPut: $;. messages first precedence >= 2 ifTrue: [aStream crtab: level + 1]]]. p > 0 ifTrue: [aStream nextPut: $)]! ! !CascadeNode methodsFor: 'printing' stamp: ''! printOn: aStream indent: level self printOn: aStream indent: level precedence: 0! ! !Categorizer commentStamp: 'StephaneDucasse 5/9/2010 20:11'! A Categorizer is responsible to manage the class categories and method protocols. Instances consist of an Array of category names (categoryArray), each of which refers to an Array of elements (elementArray). This association is made through an Array of stop indices (categoryStops), each of which is the index in elementArray of the last element (if any) of the corresponding category. For example: categories := Array with: 'firstCat' with: 'secondCat' with: 'thirdCat'. stops := Array with: 1 with: 4 with: 4. elements := Array with: #a with: #b with: #c with: #d. This means that category firstCat has only #a, secondCat has #b, #c, and #d, and thirdCat has no elements. This means that stops at: stops size must be the same as elements size. Instance Variables categoryArray: categoryStops: elementArray: categoryArray - holds the list of categories. A category could be any Object but is generally a String or Symbol. Categories should be unique (categoryArray asSet size = categoryArray size) categoryStops - holds the index of last element belonging to each category. There should be a category stop for each category (categoryStops size = categoryArray size). The categoryStops should be sorted (categoryStops sorted = categoryStops). A category stop equal to its predecessor (= 0 for the first category stop) denotes an empty category. elementArray - holds the elements to be classified. The elements are sorted by category. Class variables Default is the default category used to classify yet unclassified methods of a class NullCategory is the category to be displayed in a Browser for a class having no method.! !Categorizer methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:06'! categories "Answer an Array of categories (names)." categoryArray ifNil: [^ nil]. (categoryArray size = 1 and: [categoryArray first = Default & (elementArray size = 0)]) ifTrue: [^Array with: NullCategory]. ^categoryArray! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'! isEmptyCategoryNamed: categoryName | i | i := categoryArray indexOf: categoryName ifAbsent: [^false]. ^self isEmptyCategoryNumber: i! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! addCategory: newCategory ^ self addCategory: newCategory before: nil ! ! !Categorizer methodsFor: 'accessing' stamp: 'GuillermoPolito 3/19/2012 00:37'! removeCategory: cat "Remove the category named, cat. Create an error notificiation if the category has any elements in it." | index lastStop | index := categoryArray indexOf: cat ifAbsent: [^self]. lastStop := index = 1 ifTrue: [0] ifFalse: [categoryStops at: index - 1]. (categoryStops at: index) - lastStop > 0 ifTrue: [^self error: 'cannot remove non-empty category ', cat]. categoryArray := categoryArray copyReplaceFrom: index to: index with: Array new. categoryStops := categoryStops copyReplaceFrom: index to: index with: Array new. categoryArray size = 0 ifTrue: [categoryArray := Array with: Default. categoryStops := Array with: 0] ! ! !Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:52'! lastIndexOfCategoryNumber: anInteger anInteger > categoryStops size ifTrue: [^ nil]. ^ categoryStops at: anInteger! ! !Categorizer methodsFor: 'file in/out' stamp: 'NS 4/5/2004 17:44'! scanFrom: aStream "Reads in the organization from the next chunk on aStream. Categories or elements not found in the definition are not affected. New elements are ignored." self changeFromString: aStream nextChunk. aStream skipStyleChunk.! ! !Categorizer methodsFor: 'accessing' stamp: 'MarcusDenker 10/10/2013 16:37'! sortCategories | privateCategories publicCategories newCategories | privateCategories := self categories select: [ :one | (one findString: 'private' startingAt: 1 caseSensitive: false) = 1 ]. publicCategories := self categories copyWithoutAll: privateCategories. newCategories := publicCategories asSortedCollection asOrderedCollection addAll: privateCategories; asArray. self categories: newCategories! ! !Categorizer methodsFor: 'accessing' stamp: 'CamilloBruni 2/28/2012 14:21'! categories: anArray "Reorder my categories to be in order of the argument, anArray. If the resulting organization does not include all elements, then give an error." | newCategories newStops newElements newElementsSet catName list runningTotal | anArray size < 2 ifTrue: [ ^ self ]. newCategories := Array new: anArray size. newStops := Array new: anArray size. newElements := OrderedCollection new: anArray size. runningTotal := 0. 1 to: anArray size do: [:i | catName := (anArray at: i) asSymbol. list := self listAtCategoryNamed: catName. newElements addAllLast: list. newCategories at: i put: catName. newStops at: i put: (runningTotal := runningTotal + list size)]. newElements := newElements asArray. "create a temporary set for super-fast includes check" newElementsSet := newElements asSet. elementArray do: [:element | "check to be sure all elements are included" (newElementsSet includes: element) ifFalse: [^self error: 'New categories must match old ones']]. "Everything is good, now update my three arrays." categoryArray := newCategories. categoryStops := newStops. elementArray := newElements! ! !Categorizer methodsFor: 'accessing' stamp: 'MarcusDenker 5/18/2013 15:44'! changeFromString: aString "Parse the argument, aString, and make this be the receiver's structure." | categorySpecs | categorySpecs := aString parseLiterals. "If nothing was scanned and I had no elements before, then default me" (categorySpecs isEmpty and: [elementArray isEmpty]) ifTrue: [^ self setDefaultList: Array new]. ^ self changeFromCategorySpecs: categorySpecs! ! !Categorizer methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 00:16'! removeEmptyCategories "Remove empty categories." | categoryIndex currentStop keptCategories keptStops | keptCategories := (Array new: 16) writeStream. keptStops := (Array new: 16) writeStream. currentStop := categoryIndex := 0. [(categoryIndex := categoryIndex + 1) <= categoryArray size] whileTrue: [(categoryStops at: categoryIndex) > currentStop ifTrue: [keptCategories nextPut: (categoryArray at: categoryIndex). keptStops nextPut: (currentStop := categoryStops at: categoryIndex)]]. categoryArray := keptCategories contents. categoryStops := keptStops contents. categoryArray size = 0 ifTrue: [categoryArray := Array with: Default. categoryStops := Array with: 0] "ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! ! !Categorizer methodsFor: 'private' stamp: 'NS 4/5/2004 17:50'! setDefaultList: aSortedCollection categoryArray := Array with: Default. categoryStops := Array with: aSortedCollection size. elementArray := aSortedCollection asArray! ! !Categorizer methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 00:15'! basicRemoveElement: element "Remove the selector, element, from all categories." | categoryIndex elementIndex nextStop newElements | categoryIndex := 1. elementIndex := 0. nextStop := 0. "nextStop keeps track of the stops in the new element array" newElements := (Array new: elementArray size) writeStream. [(elementIndex := elementIndex + 1) <= elementArray size] whileTrue: [[elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex := categoryIndex + 1]. (elementArray at: elementIndex) = element ifFalse: [nextStop := nextStop + 1. newElements nextPut: (elementArray at: elementIndex)]]. [categoryIndex <= categoryStops size] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex := categoryIndex + 1]. elementArray := newElements contents. self assertInvariant.! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! classify: element under: heading self classify: element under: heading suppressIfDefault: true! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! listAtCategoryNamed: categoryName "Answer the array of elements associated with the name, categoryName." | i | i := categoryArray indexOf: categoryName ifAbsent: [^Array new]. ^self listAtCategoryNumber: i! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/6/2004 13:51'! listAtCategoryNumber: anInteger "Answer the array of elements stored at the position indexed by anInteger. Answer nil if anInteger is larger than the number of categories." | firstIndex lastIndex | (anInteger < 1 or: [anInteger > categoryStops size]) ifTrue: [^ nil]. firstIndex := self firstIndexOfCategoryNumber: anInteger. lastIndex := self lastIndexOfCategoryNumber: anInteger. ^elementArray copyFrom: firstIndex to: lastIndex! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! allMethodSelectors "give a list of all method selectors." ^ elementArray copy sort! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/12/2004 20:50'! removeElement: element ^ self basicRemoveElement: element! ! !Categorizer methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:06'! elementCategoryDict | dict firstIndex lastIndex | elementArray ifNil: [^ nil]. dict := Dictionary new: elementArray size. 1to: categoryStops size do: [:cat | firstIndex := self firstIndexOfCategoryNumber: cat. lastIndex := self lastIndexOfCategoryNumber: cat. firstIndex to: lastIndex do: [:el | dict at: (elementArray at: el) put: (categoryArray at: cat)]. ]. ^ dict.! ! !Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:51'! firstIndexOfCategoryNumber: anInteger anInteger < 1 ifTrue: [^ nil]. ^ (anInteger > 1 ifTrue: [(categoryStops at: anInteger - 1) + 1] ifFalse: [1]).! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! categoryOfElement: element "Answer the category associated with the argument, element." | index | index := self numberOfCategoryOfElement: element. index = 0 ifTrue: [^nil] ifFalse: [^categoryArray at: index]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! numberOfCategoryOfElement: element "Answer the index of the category with which the argument, element, is associated." | categoryIndex elementIndex | categoryIndex := 1. elementIndex := 0. [(elementIndex := elementIndex + 1) <= elementArray size] whileTrue: ["point to correct category" [elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryIndex := categoryIndex + 1]. "see if this is element" element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]]. ^0! ! !Categorizer methodsFor: 'private' stamp: 'jannik.laval 5/1/2010 16:01'! assertInvariant [elementArray size = categoryStops last] assert! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! classifyAll: aCollection under: heading aCollection do: [:element | self classify: element under: heading]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! renameCategory: oldCatString toBe: newCatString "Rename a category. No action if new name already exists, or if old name does not exist." | index oldCategory newCategory | oldCategory := oldCatString asSymbol. newCategory := newCatString asSymbol. (categoryArray indexOf: newCategory) > 0 ifTrue: [^ self]. "new name exists, so no action" (index := categoryArray indexOf: oldCategory) = 0 ifTrue: [^ self]. "old name not found, so no action" categoryArray := categoryArray copy. "need to change identity so smart list update will notice the change" categoryArray at: index put: newCategory! ! !Categorizer methodsFor: 'accessing' stamp: 'al 11/28/2005 22:05'! classify: element under: heading suppressIfDefault: aBoolean "Store the argument, element, in the category named heading. If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein" | catName catIndex elemIndex realHeading | ((heading = NullCategory) or: [heading == nil]) ifTrue: [realHeading := Default] ifFalse: [realHeading := heading asSymbol]. (catName := self categoryOfElement: element) = realHeading ifTrue: [^ self]. "done if already under that category" catName ~~ nil ifTrue: [(aBoolean and: [realHeading = Default]) ifTrue: [^ self]. "return if non-Default category already assigned in memory" self basicRemoveElement: element]. "remove if in another category" (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. catIndex := categoryArray indexOf: realHeading. elemIndex := catIndex > 1 ifTrue: [categoryStops at: catIndex - 1] ifFalse: [0]. [(elemIndex := elemIndex + 1) <= (categoryStops at: catIndex) and: [element >= (elementArray at: elemIndex)]] whileTrue. "elemIndex is now the index for inserting the element. Do the insertion before it." elementArray := elementArray copyReplaceFrom: elemIndex to: elemIndex-1 with: (Array with: element). "add one to stops for this and later categories" catIndex to: categoryArray size do: [:i | categoryStops at: i put: (categoryStops at: i) + 1]. ((categoryArray includes: Default) and: [(self listAtCategoryNamed: Default) size = 0]) ifTrue: [self removeCategory: Default]. self assertInvariant.! ! !Categorizer methodsFor: 'accessing' stamp: 'MarcusDenker 10/10/2013 16:38'! changeFromCategorySpecs: categorySpecs "Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment." | newCategories newStops temp cc currentStop oldElements newElements | oldElements := elementArray asSet. newCategories := Array new: categorySpecs size. newStops := Array new: categorySpecs size. currentStop := 0. newElements := (Array new: 16) writeStream. 1 to: categorySpecs size do: [ :i | | selectors catSpec | catSpec := categorySpecs at: i. newCategories at: i put: catSpec first asSymbol. selectors := catSpec allButFirst collect: [ :each | each isSymbol ifTrue: [ each ] ifFalse: [ each printString asSymbol ] ]. selectors asSortedCollection do: [ :elem | (oldElements remove: elem ifAbsent: [ nil ]) notNil ifTrue: [ newElements nextPut: elem. currentStop := currentStop + 1 ] ]. newStops at: i put: currentStop ]. "Ignore extra elements but don't lose any existing elements!!" oldElements := oldElements collect: [ :elem | Array with: (self categoryOfElement: elem) with: elem ]. newElements := newElements contents. categoryArray := newCategories. (cc := categoryArray asSet) size = categoryArray size ifFalse: [ "has duplicate element" temp := categoryArray asOrderedCollection. temp removeAll: categoryArray asSet. temp do: [ :dup | | tmp ii | tmp := dup. ii := categoryArray indexOf: tmp. [ tmp := (tmp , ' #2') asSymbol. cc includes: tmp ] whileTrue. cc add: tmp. categoryArray at: ii put: tmp ] ]. categoryStops := newStops. elementArray := newElements. oldElements do: [ :pair | self classify: pair last under: pair first ]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! addCategory: catString before: nextCategory "Add a new category named heading. If default category exists and is empty, remove it. If nextCategory is nil, then add the new one at the end, otherwise, insert it before nextCategory." | index newCategory | newCategory := catString asSymbol. (categoryArray indexOf: newCategory) > 0 ifTrue: [^self]. "heading already exists, so done" index := categoryArray indexOf: nextCategory ifAbsent: [categoryArray size + 1]. categoryArray := categoryArray copyReplaceFrom: index to: index-1 with: (Array with: newCategory). categoryStops := categoryStops copyReplaceFrom: index to: index-1 with: (Array with: (index = 1 ifTrue: [0] ifFalse: [categoryStops at: index-1])). "remove empty default category" (newCategory ~= Default and: [(self listAtCategoryNamed: Default) isEmpty]) ifTrue: [self removeCategory: Default]! ! !Categorizer methodsFor: 'file in/out' stamp: 'BenjaminVanRyseghem 4/12/2012 17:27'! stringForFileOut ^ String streamContents: [:aStream || elementIndex | elementIndex := 1. 1 to: categoryArray size do: [:i | aStream nextPut: $(. (categoryArray at: i) asString printOn: aStream. [elementIndex <= (categoryStops at: i)] whileTrue: [aStream space; nextPutAll: (elementArray at: elementIndex). elementIndex := elementIndex + 1]. aStream nextPut: $); cr ]]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'! isEmptyCategoryNumber: anInteger | firstIndex lastIndex | (anInteger < 1 or: [anInteger > categoryStops size]) ifTrue: [^ true]. firstIndex := self firstIndexOfCategoryNumber: anInteger. lastIndex := self lastIndexOfCategoryNumber: anInteger. ^ firstIndex > lastIndex! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/6/2004 11:48'! initialize " self initialize " Default := 'as yet unclassified' asSymbol. NullCategory := 'no messages' asSymbol.! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'! default ^ Default! ! !Categorizer class methodsFor: 'instance creation' stamp: 'NS 4/5/2004 17:44'! defaultList: aSortedCollection "Answer an instance of me with initial elements from the argument, aSortedCollection." ^self new setDefaultList: aSortedCollection! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'! nullCategory ^ NullCategory! ! !Categorizer class methodsFor: 'documentation' stamp: 'NS 4/5/2004 17:44'! documentation "Instances consist of an Array of category names (categoryArray), each of which refers to an Array of elements (elementArray). This association is made through an Array of stop indices (categoryStops), each of which is the index in elementArray of the last element (if any) of the corresponding category. For example: categories := Array with: 'firstCat' with: 'secondCat' with: 'thirdCat'. stops := Array with: 1 with: 4 with: 4. elements := Array with: #a with: #b with: #c with: #d. This means that category firstCat has only #a, secondCat has #b, #c, and #d, and thirdCat has no elements. This means that stops at: stops size must be the same as elements size." ! ! !Categorizer class methodsFor: 'housekeeping' stamp: 'NS 4/6/2004 11:48'! sortAllCategories self allSubInstances do: [:x | x sortCategories]! ! !Categorizer class methodsFor: 'class initialization' stamp: 'eem 1/7/2009 16:04'! allCategory "Return a symbol that represents the virtual all methods category." ^#'-- all --'! ! !CategoryAdded commentStamp: 'cyrilledelaunay 1/18/2011 12:29'! This announcement will be emited when adding a category using: => SystemOrganizer >> addCategory:! !CategoryAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 17:58'! categoryName ^ categoryName! ! !CategoryAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 17:56'! categoryName: aCategoryName categoryName := aCategoryName! ! !CategoryAdded class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/1/2012 17:57'! categoryName: aCategoryName ^self new categoryName: aCategoryName; yourself! ! !CategoryRemoved commentStamp: 'cyrilledelaunay 1/18/2011 12:28'! This announcement will be emited when removing a category using: => SystemOrganizer >> removeCategory:! !CategoryRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:03'! categoryName ^categoryName! ! !CategoryRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:02'! categoryName: aCategoryName categoryName := aCategoryName! ! !CategoryRemoved class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:02'! categoryName: aCategoryName ^self new categoryName: aCategoryName; yourself! ! !CategoryRenamed commentStamp: 'cyrilledelaunay 1/18/2011 12:26'! This announcement will be emited when renaming a category using: => SystemOrganizer >> renameCategory:toBe:! !CategoryRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:05'! newCategoryName: aCategoryName newCategoryName := aCategoryName! ! !CategoryRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:05'! newCategoryName ^newCategoryName! ! !CategoryRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:05'! oldCategoryName ^oldCategoryName! ! !CategoryRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:05'! oldCategoryName: aCategoryName oldCategoryName := aCategoryName! ! !CategoryRenamed class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:05'! classCategoryRenamedFrom: anOldCategoryName to: aNewCategoryName ^self new newCategoryName: aNewCategoryName; oldCategoryName: anOldCategoryName; yourself! ! !CategoryWidget commentStamp: ''! CategoryWidget is the basic implementation of a wiget managing categories! !CategoryWidget methodsFor: 'selection' stamp: ''! categorySelectionAt: anIndex | elt | elt := self getCategories at: anIndex ifAbsent: [ nil ]. ^ categoriesSelection at: elt ifAbsent: [ false ].! ! !CategoryWidget methodsFor: 'private' stamp: ''! categoryWrapper: anItem | package class result | package := self model selectedPackage. class := self model selectedClass. result := anItem asMorph. anItem first == $* ifTrue: [ | item | item := anItem allButFirst asLowercase. ((item = package name asLowercase) or: [ (item beginsWith: package name asLowercase) and: [ (item at: (package name size +1)) =$-]]) ifFalse: [ result := anItem asMorph color: self model extensionColor; yourself ]] ifFalse: [ (package extendedClasses includes: class) ifTrue: [ result := anItem asMorph color: self model extensionColor; yourself ]]. self model showInstance ifFalse: [ result emphasis: 1 ]. ^ result! ! !CategoryWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/27/2012 00:34'! resetSelection self categoriesSelection removeAll! ! !CategoryWidget methodsFor: 'private' stamp: 'MarcusDenker 9/27/2013 18:04'! sortCategories: allProtocols forClass: class firstInPackage: currentPackage "List the protocols in this order: 1. the -- all -- category 2. the extension protocols of the given package 3. the extension protocols 4. the normal protocols" | sortBlock currentPackageProtocols otherProtocols | currentPackageProtocols := allProtocols reject: [ :protocolName | protocolName beginsWith: '*' ]. "Filter out the existing protocols so that we can sort them later separately" otherProtocols := allProtocols difference: currentPackageProtocols. sortBlock := [ :a :b | (a compare: b caseSensitive: false) = 1 ]. ^ (currentPackageProtocols sort: sortBlock), (otherProtocols sort: sortBlock)! ! !CategoryWidget methodsFor: 'private' stamp: ''! loadPackagesCategoriesFor: class | env | env := self model browsedEnvironment. ^env isSystem ifTrue: [ self loadPackagesCategoriesInSystemEnvironmentFor: class ] ifFalse: [ self loadPackagesCategoriesInARestrictedEnvironment: env for: class ]! ! !CategoryWidget methodsFor: 'private' stamp: ''! selectProtocol: aString categoriesSelection at: aString put: true! ! !CategoryWidget methodsFor: 'protocol' stamp: ''! vScrollValue ^ categoriesList scrollValue y! ! !CategoryWidget methodsFor: 'private' stamp: 'CamilloBruni 5/4/2013 14:23'! loadGroupsCategoriesInSytemEnvironmentFor: class | group | group := self model selectedGroup. ^ self sortCategories: (group protocolsFor: class ) forClass: class! ! !CategoryWidget methodsFor: 'protocol' stamp: ''! getCategories ^ categories ifNil: [ categories := self loadCategories ].! ! !CategoryWidget methodsFor: 'selection' stamp: 'CamilloBruni 10/4/2012 10:50'! selectedCategoryIndex: anInteger | anObject | anObject := self getCategories at: anInteger ifAbsent: [ nil ]. self model selectedCategory: anObject. self changed: #selectedCategoryIndex. self model categorySelectionChanged. self model changed: #currentHistoryIndex.! ! !CategoryWidget methodsFor: 'initialization' stamp: ''! initialize super initialize. categoriesSelection := Dictionary new.! ! !CategoryWidget methodsFor: 'private' stamp: 'MarcusDenker 9/27/2013 18:03'! loadPackagesCategoriesInSystemEnvironmentFor: class ^ self sortCategories: class protocols forClass: class! ! !CategoryWidget methodsFor: 'protocol' stamp: ''! resetCategoryCache categories := nil! ! !CategoryWidget methodsFor: 'selection' stamp: ''! resetCategoriesListSelection categoriesSelection removeAll! ! !CategoryWidget methodsFor: 'protocol' stamp: ''! selectedCategories | associations | associations := self categoriesSelection associations select: [:assoc | assoc value == true ]. associations := associations collect: [:assoc | assoc key ]. ^ associations select: [:each | each notNil ]! ! !CategoryWidget methodsFor: 'protocol' stamp: ''! categoriesSelection ^ categoriesSelection! ! !CategoryWidget methodsFor: 'private' stamp: 'EstebanLorenzano 12/20/2013 12:35'! loadPackagesCategoriesInARestrictedEnvironment: env for: class ^ self sortCategories: ((model browsedEnvironment protocolsFor: class) copyWithFirst: AllProtocol defaultName) forClass: class! ! !CategoryWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/23/2012 18:54'! label: aString "categoriesGroup label: aString"! ! !CategoryWidget methodsFor: 'protocol' stamp: ''! takeKeyboardFocus categoriesList takeKeyboardFocus! ! !CategoryWidget methodsFor: 'private' stamp: 'CamilloBruni 5/4/2013 14:25'! sortCategories: protocols forClass: class ^ self sortCategories: protocols forClass: class firstInPackage: self model selectedPackage! ! !CategoryWidget methodsFor: 'private' stamp: ''! getCategoryItem: anIndex ^ self getCategories at: anIndex! ! !CategoryWidget methodsFor: 'private' stamp: ''! loadGroupsCategoriesFor: class | env | env := model browsedEnvironment. ^ env isSystem ifTrue: [ self loadGroupsCategoriesInSytemEnvironmentFor: class ] ifFalse: [ self loadGroupsCategoriesInARestrictedEnvironment: env for: class ]! ! !CategoryWidget methodsFor: 'private' stamp: 'CamilloBruni 5/4/2013 14:23'! loadGroupsCategoriesInARestrictedEnvironment: env for: class | group | group := self model selectedGroup. ^ self sortCategories: ((group protocolsFor: class ) intersection: ( env protocolsFor: class )) forClass: class! ! !CategoryWidget methodsFor: 'protocol' stamp: ''! searchedElement: index categoriesList searchedElement: index! ! !CategoryWidget methodsFor: 'selection' stamp: ''! selectedCategoryIndex ^ self getCategories indexOf: self selectedCategory ifAbsent: [ 0 ]! ! !CategoryWidget methodsFor: 'protocol' stamp: ''! loadCategories | class | class := self model selectedClass. class ifNil: [ ^ #() ]. ^ self model showGroups ifTrue: [ self loadGroupsCategoriesFor: class ] ifFalse: [ self loadPackagesCategoriesFor: class ]! ! !CategoryWidget methodsFor: 'protocol' stamp: ''! vScrollValue: aNumber ^ categoriesList vScrollValue: aNumber! ! !CategoryWidget methodsFor: 'private' stamp: ''! hasFocus ^ categoriesList hasKeyboardFocus! ! !CategoryWidget methodsFor: 'item creation' stamp: 'EstebanLorenzano 5/14/2013 15:01'! buildCategoriesList ^ categoriesList := PluggableIconListMorph new basicWrapSelector: #categoryWrapper:; resetListSelector: #resetCategoriesListSelection; keystrokeSelector: #keyPressedOnCategory:; autoDeselect: true; getListSizeSelector: #categoryListSize; dropItemSelector: #dropMethod:inARow:; dragEnabled: true; dropEnabled: true; hResizing: #spaceFill; vResizing: #spaceFill; getIconSelector: #categoryIconFor:; "WARNING: This needs to be set before the model" model: self; getIndexSelector: #selectedCategoryIndex; setIndexSelector: #selectedCategoryIndex:; getSelectionListSelector: #categorySelectionAt:; setSelectionListSelector: #categorySelectionAt:put:; getMenuSelector: #categoriesMenu:shifted:; beMultipleSelection; getListElementSelector: #getCategoryItem:; changed ! ! !CategoryWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/25/2012 11:12'! keyPressedOnCategory: anEvent | aCharacter | aCharacter := anEvent keyCharacter. (aCharacter == self model class nextFocusKey) ifTrue: [ ^ self model giveFocusTo: self model methodWidget ]. (aCharacter == self model class previousFocusKey) ifTrue: [ ^ self model giveFocusTo: self model classWidget ]. ! ! !CategoryWidget methodsFor: 'private' stamp: ''! categoryListSize ^ self getCategories size! ! !CategoryWidget methodsFor: 'private' stamp: ''! categoriesLabel ^ self showInstance ifTrue: ['Instance protocols:' asText] ifFalse: ['Class protocols:' asText allBold ]! ! !CategoryWidget methodsFor: 'private' stamp: ''! deselectProtocol: aString categoriesSelection at: aString put: false! ! !CategoryWidget methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 5/7/2012 14:37'! categorySelectionAt: anIndex put: aBoolean | elt | elt := self getCategories at: anIndex ifAbsent: [ nil ]. categoriesSelection at: elt put: aBoolean. self model categorySelectionChanged. ^ aBoolean! ! !CategoryWidget methodsFor: 'initialize-release' stamp: ''! model: aModel super model: aModel. self selectedCategory ifNotNil: [:cat | categoriesSelection at: cat put: true ]! ! !CategoryWidget class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 4/6/2012 16:57'! buildProtocolShortcutsOn: aBuilder (aBuilder shortcut: #fullBrowse) category: #NautilusProtocolShortcuts default: $b command do: [ :target | target fullBrowse ] description: 'Open a new browser on the selection'. (aBuilder shortcut: #restrictedBrowseClass) category: #NautilusProtocolShortcuts default: $b command shift do: [ :target | target restrictedBrowseClass ] description: 'Open a restricted browser'. (aBuilder shortcut: #addProtocolsInGroup) category: #NautilusProtocolShortcuts default: $e command do: [ :target | target addProtocolsInGroup ] description: 'Add the selected protocols in a group'. (aBuilder shortcut: #findMethod) category: #NautilusProtocolShortcuts default: $f command do: [ :target | target findMethod ] description: 'Find a method'. (aBuilder shortcut: #addCategory) category: #NautilusProtocolShortcuts default: $n command do: [ :target | target addCategory ] description: 'Add a new protocol'. (aBuilder shortcut: #renameCategory) category: #NautilusProtocolShortcuts default: $r command do: [ :target | target enableCategorySingleSelection ifTrue: [target renameCategory ]] description: 'Rename the selected protocol'. (aBuilder shortcut: #removeCategories) category: #NautilusProtocolShortcuts default: $x command do: [ :target | target removeCategories ] description: 'Remove the selected protocols'.! ! !CategoryWidget class methodsFor: 'menu' stamp: 'SebastianTleye 8/30/2013 14:14'! categoriesMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Find Method...') keyText: 'f, m' if: Nautilus useOldStyleKeys not; keyText: 'f' if: Nautilus useOldStyleKeys; action: [ target findMethod ]; order: 0; help: 'Search for a method by name'. (aBuilder item: #'Add protocol...') keyText: 'n, t' if: Nautilus useOldStyleKeys not; action: [ target addCategory ]; order: 100; withSeparatorAfter. (aBuilder item: #'Browse full') keyText: 'b, f' if: Nautilus useOldStyleKeys not; keyText: 'b' if: Nautilus useOldStyleKeys; action: [ target fullBrowse ]; order: 200; withSeparatorAfter. (aBuilder item: #'Categorize all uncategorized') keyText: 'h, C' if: Nautilus useOldStyleKeys not; action: [ target categorizeAllUncategorizedMethods ]; order: 1100. (aBuilder item: #'Remove empty protocols') action: [ target removeEmptyCategories ]; order: 1200; withSeparatorAfter. target selectedCategory ifNil: [ ^ target ]. (aBuilder item: #'Rename...') keyText: 'r, t' if: Nautilus useOldStyleKeys not; keyText: 'r' if: Nautilus useOldStyleKeys; action: [ target renameCategory ]; order: 1300; enabledBlock: [ target enableCategorySingleSelection ]. (aBuilder item: #'Remove...') keyText: 'x, t' if: Nautilus useOldStyleKeys not; keyText: 'x' if: Nautilus useOldStyleKeys; action: [ target removeCategories ]; order: 1400; icon: (Smalltalk ui icons iconNamed: #removeIcon); withSeparatorAfter. (aBuilder item: #'Add in group...') action: [ target addProtocolsInGroup ]; order: 1500. (aBuilder item: #'File Out') action: [ target fileOutCategories ]; order: 1600.! ! !ChangeList commentStamp: 'StephaneDucasse 7/23/2010 21:17'! A ChangeList represents a list of changed methods that reside on a file in fileOut format. The classes and methods in my list are not necessarily in this image!! Used as the model when changes are recovered. It holds three lists: changeList - a list of ChangeRecords list - a list of one-line printable headers listSelections - a list of Booleans (true = selected, false = not selected) multiple OK. listIndex Items that are removed (removeDoits, remove an item) are removed from all three lists. Most recently clicked item is the one showing in the bottom pane.! !ChangeList methodsFor: 'accessing' stamp: ''! file ^file! ! !ChangeList methodsFor: 'scanning' stamp: 'MarcusDenker 4/28/2013 11:14'! scanCategory: category class: class meta: meta stamp: stamp | itemPosition method selector | [itemPosition := file position. method := file nextChunk. file skipStyleChunk. method size > 0] "done when double terminators" whileTrue: [self addItem: (ChangeRecord new file: file position: itemPosition type: #method class: class category: category meta: meta stamp: stamp) text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) , ((selector := (Smalltalk globals at: class ifAbsent: [Object]) compiler parseSelector: method) isNil ifTrue: ['unparsableSelector'] ifFalse: [selector]) , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! ! !ChangeList methodsFor: 'initialization-release' stamp: 'nice 4/16/2009 09:39'! optionalButtonRow "Answer a row of buttons to occur in a tool pane" | aRow | aRow := AlignmentMorph newRow. aRow hResizing: #spaceFill. aRow clipSubmorphs: true. aRow layoutInset: 2@2; cellInset: 3. aRow wrapCentering: #center; cellPositioning: #leftCenter. self changeListButtonSpecs do: [:triplet | | aButton | aButton := PluggableButtonMorph on: self getState: nil action: triplet second. aButton hResizing: #spaceFill; vResizing: #spaceFill; label: triplet first asString; askBeforeChanging: true; onColor: Color white offColor: Color white. aRow addMorphBack: aButton. aButton setBalloonText: triplet third]. aRow addMorphBack: self regularDiffButton. self wantsPrettyDiffOption ifTrue: [aRow addMorphBack: self prettyDiffButton]. ^ aRow! ! !ChangeList methodsFor: 'menu actions' stamp: 'EstebanLorenzano 1/31/2013 19:25'! changeListMenu: aMenu "Fill aMenu up so that it comprises the primary changelist-browser menu" aMenu addTitle: 'change list'. aMenu addStayUpItemSpecial. aMenu addAllFromPragma:'changeListMenu' target: self. ^aMenu ! ! !ChangeList methodsFor: 'menu actions' stamp: 'MarcusDenker 10/15/2013 18:10'! browseVersions | change browser | listIndex = 0 ifTrue: [^ nil ]. change := changeList at: listIndex. change classIncludesSelector ifFalse: [ ^nil ]. browser := super browseVersions. browser ifNotNil: [ browser addedChangeRecord: change ]. ^browser! ! !ChangeList methodsFor: 'viewing access' stamp: 'MarcusDenker 9/28/2013 13:49'! diffedVersionContents "Answer diffed version contents, maybe pretty maybe not" | change class earlier later | (listIndex = 0 or: [ changeList size < listIndex ]) ifTrue: [ ^ '' ]. change := changeList at: listIndex. later := change text. class := change methodClass. (listIndex == changeList size or: [ class isNil ]) ifTrue: [ ^ later ]. earlier := (changeList at: listIndex + 1) text. ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! ! !ChangeList methodsFor: 'menu actions' stamp: 'MarcusDenker 9/24/2013 14:16'! selectUnchangedMethods "Selects all method definitions for which there is already a method in the current image, whose source is exactly the same." Cursor read showWhile: [ | change |1 to: changeList size do: [:i | change := changeList at: i. listSelections at: i put: change isUnchangedMethod]]. self changed: #allSelections! ! !ChangeList methodsFor: 'viewing access' stamp: 'MarcusDenker 5/18/2013 15:44'! contentsDiffedFromCurrent "Answer the contents diffed forward from current (in-memory) method version" | aChange aClass | listIndex = 0 ifTrue: [^ '']. aChange := changeList at: listIndex. (aChange type == #method and: [(aClass := aChange methodClass) notNil and: [aClass includesSelector: aChange methodSelector]]) ifTrue: [^TextDiffBuilder buildDisplayPatchFrom: (aClass sourceCodeAt: aChange methodSelector) to: aChange text inClass: aClass prettyDiffs: self showingPrettyDiffs]. aChange type == #doIt ifTrue: [| tokens | tokens := aChange string parseLiterals. ((tokens select: [:substr| #(subclass: variableByteSubclass: variableWordSubclass: instanceVariableNames: classVariableNames: ) includes: substr]) asSet size >= 3 and: [(aClass := Smalltalk globals at: tokens third ifAbsent: []) notNil and: [aClass isBehavior]]) ifTrue: [^TextDiffBuilder buildDisplayPatchFrom: aClass definition to: aChange string]. (tokens size = 4 and: [tokens second == #class and: [tokens third == #instanceVariableNames: and: [(aClass := Smalltalk globals at: tokens first ifAbsent: []) notNil and: [aClass isBehavior]]]]) ifTrue: [^TextDiffBuilder buildDisplayPatchFrom: aClass class definition to: aChange string]]. (aChange type == #classComment and: [(aClass := aChange commentClass) notNil]) ifTrue: [^TextDiffBuilder buildDisplayPatchFrom: aClass comment asString to: aChange string]. ^(changeList at: listIndex) text! ! !ChangeList methodsFor: 'menu actions' stamp: 'StephaneDucasse 7/23/2010 22:16'! removeSelections "Remove the selected items from the receiver." | newChangeList newList | newChangeList := OrderedCollection new. newList := OrderedCollection new. 1 to: changeList size do: [:i | (listSelections at: i) ifFalse: [newChangeList add: (changeList at: i). newList add: (list at: i)]]. self refreshNewList: newChangeList andList: newList ! ! !ChangeList methodsFor: 'menu actions' stamp: 'nice 1/5/2010 15:59'! selectConflicts "Selects all method definitions for which there is ALSO an entry in changes" Cursor read showWhile: [ | class change |1 to: changeList size do: [:i | change := changeList at: i. listSelections at: i put: (change type = #method and: [(class := change methodClass) notNil and: [(ChangeSet current atSelector: change methodSelector class: class) ~~ #none]])]]. self changed: #allSelections! ! !ChangeList methodsFor: 'initialization' stamp: 'StephaneDucasse 7/23/2010 21:09'! initialize "Initialize a blank ChangeList. Set the contentsSymbol to reflect whether diffs will initally be shown or not" contentsSymbol := CodeHolder diffsInChangeList ifTrue: [self defaultDiffsSymbol] ifFalse: [#source]. changeList := OrderedCollection new. list := OrderedCollection new. listIndex := 0. super initialize! ! !ChangeList methodsFor: 'menu actions' stamp: 'HenrikSperreJohansen 9/12/2010 10:54'! removeOlderMethodVersions "Remove older versions of entries from the receiver." | equivalent toRemove| equivalent := Dictionary new. toRemove := Set new. changeList with: list do: [:change :displayString | (equivalent at: (displayString copyUpTo: $;) ifAbsentPut: [OrderedCollection new.]) add: change ]. equivalent do: #removeLast. equivalent do: [:each | toRemove addAll: each]. self removeRecordsWhere: [:change | toRemove includes: change]! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sd 11/20/2005 21:26'! addItem: item text: text | cr | cr := Character cr. changeList addLast: item. list addLast: (text collect: [:x | x = cr ifTrue: [$/] ifFalse: [x]])! ! !ChangeList methodsFor: 'accessing' stamp: 'sw 10/19/1999 15:11'! showsVersions ^ false! ! !ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! selectedClassOrMetaClass | c | ^ (c := self currentChange) ifNotNil: [c methodClass]! ! !ChangeList methodsFor: 'menu actions' stamp: 'StephaneDucasse 7/23/2010 22:00'! changeListKey: aChar from: view "Respond to a Command key in the list pane." aChar == $D ifTrue: [ ^self toggleDiffing ]. aChar == $a ifTrue: [ ^self selectAll ]. ^ self arrowKey: aChar from: view! ! !ChangeList methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! changes: changeRecords file: aFile file := aFile. changeList := OrderedCollection new. list := OrderedCollection new. listIndex := 0. changeRecords do: [:each | (each respondsTo: #methodClass) ifFalse: [self addItem: ChangeRecord new text: each asString] ifTrue: [self addItem: each text: ('method: ' , each methodClass name , (each isMetaClassChange ifTrue: [' class '] ifFalse: [' ']) , each methodSelector , '; ' , each stamp)]]. listSelections := Array new: list size withAll: false! ! !ChangeList methodsFor: 'menu actions' stamp: 'StephaneDucasse 7/23/2010 22:37'! selectMethodsForExtantClasses "Select methods for classes which are in the current image" ^self selectSuchThat: [ :change | Smalltalk globals hasClassNamed: change methodClassName]! ! !ChangeList methodsFor: 'menu actions' stamp: 'CamilloBruni 8/1/2012 16:15'! removeDoIts "Remove doits from the receiver, other than initializes." self removeRecordsWhere: [:record :displayString | record type = #doIt and: [(displayString endsWith: 'initialize') not]]! ! !ChangeList methodsFor: 'menu actions' stamp: 'StephaneDucasse 7/23/2010 22:12'! refreshNewList: newChangeList andList: newList newChangeList size < changeList size ifTrue: [changeList := newChangeList. list := newList. listIndex := 0. listSelections := Array new: list size withAll: false]. self changed: #list ! ! !ChangeList methodsFor: 'viewing access' stamp: ''! list ^ list! ! !ChangeList methodsFor: 'accessing' stamp: 'ls 5/12/1999 07:55'! currentChange "return the current change being viewed, or nil if none" listIndex = 0 ifTrue: [ ^nil ]. ^changeList at: listIndex! ! !ChangeList methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! setLostMethodPointer: sourcePointer lostMethodPointer := sourcePointer! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 11/13/2001 09:12'! contentsSymbolQuints "Answer a list of quintuplets representing information on the alternative views available in the code pane" ^ self sourceAndDiffsQuintsOnly! ! !ChangeList methodsFor: 'menu actions' stamp: 'MarcusDenker 9/24/2013 14:17'! selectConflicts: changeSetOrList "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList" Cursor read showWhile: [ | change class |(changeSetOrList isKindOf: ChangeSet) ifTrue: [ 1 to: changeList size do: [:i | change := changeList at: i. listSelections at: i put: (change type = #method and: [(class := change methodClass) notNil and: [(changeSetOrList atSelector: change methodSelector class: class) ~~ #none]])]] ifFalse: ["a ChangeList" 1 to: changeList size do: [:i | change := changeList at: i. listSelections at: i put: (change type = #method and: [(class := change methodClass) notNil and: [changeSetOrList list includes: (list at: i)]])]] ]. self changed: #allSelections! ! !ChangeList methodsFor: 'accessing' stamp: ''! changeList ^ changeList! ! !ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! selectSuchThat: aBlock "select all changes for which block returns true" listSelections := changeList collect: [ :change | aBlock value: change ]. self changed: #allSelections! ! !ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! selectedMessageName | c | ^ (c := self currentChange) ifNotNil: [c methodSelector]! ! !ChangeList methodsFor: 'viewing access' stamp: ''! listSelectionAt: index ^ listSelections at: index! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 1/25/1999 14:45'! undiffedContents ^ listIndex = 0 ifTrue: [''] ifFalse: [(changeList at: listIndex) text]! ! !ChangeList methodsFor: 'menu actions' stamp: 'MarcusDenker 5/2/2013 11:24'! selectSuchThat "query the user for a selection criterium. NB: the UI for invoking this from a changelist browser is currently commented out; to reenfranchise it, you'll need to mild editing to ChangeList method #changeListMenu:" | code block | code := UIManager default request: 'selection criteria for a change named aChangeRecord?\For instance, ''aChangeRecord category = ''System-Network''''' withCRs. code isEmptyOrNil ifTrue: [^ self ]. block := self class compiler evaluate: '[:aChangeRecord | ', code, ']'. self selectSuchThat: block! ! !ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! selectAll listIndex := 0. listSelections atAllPut: true. self changed: #allSelections! ! !ChangeList methodsFor: 'scanning' stamp: 'MarcusDenker 5/18/2013 15:44'! scanCategory "Scan anything that involves more than one chunk; method name is historical only" | itemPosition item tokens stamp anIndex | itemPosition := file position. item := file nextChunk. ((item includesSubstring: 'commentStamp:') or: [(item includesSubstring: 'methodsFor:') or: [item endsWith: 'reorganize']]) ifFalse: ["Maybe a preamble, but not one we recognize; bail out with the preamble trick" ^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble) text: ('preamble: ' , item contractTo: 50)]. tokens := item parseLiterals. tokens size >= 3 ifTrue: [stamp := ''. anIndex := tokens indexOf: #stamp: ifAbsent: [nil]. anIndex ifNotNil: [stamp := tokens at: (anIndex + 1)]. tokens second == #methodsFor: ifTrue: [^ self scanCategory: tokens third class: tokens first meta: false stamp: stamp]. tokens third == #methodsFor: ifTrue: [^ self scanCategory: tokens fourth class: tokens first meta: true stamp: stamp]]. tokens second == #commentStamp: ifTrue: [stamp := tokens third. self addItem: (ChangeRecord new file: file position: file position type: #classComment class: tokens first category: nil meta: false stamp: stamp) text: 'class comment for ' , tokens first, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]). file nextChunk. ^ file skipStyleChunk]. self assert: tokens last == #reorganize. self addItem: (ChangeRecord new file: file position: file position type: #reorganize class: tokens first category: nil meta: false stamp: stamp) text: 'organization for ' , tokens first, (tokens second == #class ifTrue: [' class'] ifFalse: ['']). file nextChunk! ! !ChangeList methodsFor: 'initialization-release' stamp: 'tbn 7/6/2010 16:46'! changeListButtonSpecs ^#( ('Select all' selectAll 'select all entries') ('Deselect all' deselectAll 'deselect all entries') ('Select conflicts' selectAllConflicts 'select all methods that occur in any change set') ('File in selections' fileInSelections 'file in all selected entries') )! ! !ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! invertSelections "Invert the selectedness of each item in the changelist" listSelections := listSelections collect: [ :ea | ea not]. listIndex := 0. self changed: #allSelections. self contentsChanged! ! !ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! fileInSelections | any | any := false. listSelections with: changeList do: [:selected :item | selected ifTrue: [any := true. item fileIn]]. any ifFalse: [self inform: 'nothing selected, so nothing done']! ! !ChangeList methodsFor: 'menu actions' stamp: 'StephaneDucasse 11/6/2011 12:48'! compareToCurrentVersion "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" | change class s1 s2 | listIndex = 0 ifTrue: [^ self]. change := changeList at: listIndex. ((class := change methodClass) notNil and: [ class includesSelector: change methodSelector]) ifTrue: [ s1 := (class sourceCodeAt: change methodSelector) asString. s2 := change string. s1 = s2 ifTrue: [ self inform: 'Exact Match'] ifFalse: [ UIManager default openComparisonFrom: s2 to: s1 belongingTo: class from: change labeled: (class compiledMethodAt: change methodSelector) timeStamp inWindowLabeled: 'Comparison to Current Version' ]] ifFalse: [self flash]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! annotation "Answer the string to be shown in an annotation pane. Make plain that the annotation is associated with the current in-image version of the code, not of the selected disk-based version, and if the corresponding method is missing from the in-image version, mention that fact." | annot aChange aClass | annot := super annotation. annot asString = '------' ifTrue: [^ annot]. ^ ((aChange := self currentChange) notNil and: [aChange methodSelector notNil]) ifFalse: [annot] ifTrue: [((aClass := aChange methodClass) isNil or: [(aClass includesSelector: aChange methodSelector) not]) ifTrue: [aChange methodClassName, ' >> ', aChange methodSelector, ' is not present in the current image.'] ifFalse: ['current version: ', annot]]! ! !ChangeList methodsFor: 'menu actions' stamp: 'HenrikSperreJohansen 9/12/2010 10:37'! removeRecordsWhere: aBlock "Remove records for which the block returns true." | newChangeList newList | newChangeList := OrderedCollection new. newList := OrderedCollection new. changeList with: list do: [:record :textualDescription | (aBlock cull: record cull: textualDescription) ifFalse: [newChangeList add: record. newList add: textualDescription]]. newChangeList size < changeList size ifTrue: [changeList := newChangeList. list := newList. listIndex := 0. listSelections := Array new: list size withAll: false]. self changed: #list.! ! !ChangeList methodsFor: 'menu actions' stamp: 'StephaneDucasse 5/28/2011 13:31'! browseAllVersionsOfSelections "Opens a Versions browser on all the currently selected methods, showing each alongside all of their historical versions." | oldSelection aList | oldSelection := self listIndex. aList := OrderedCollection new. Cursor read showWhile: [ 1 to: changeList size do: [:i | (listSelections at: i) ifTrue: [ listIndex := i. self browseVersions. aList add: i. ]]]. listIndex := oldSelection. aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. ! ! !ChangeList methodsFor: '*MonticelloGUI' stamp: 'stephaneducasse 2/4/2006 20:47'! changeTo: changeSubset | newList newChangeList | newChangeList := OrderedCollection new. newList := OrderedCollection new. 1 to: changeList size do: [:i | (changeSubset includes: (changeList at: i)) ifTrue: [newChangeList add: (changeList at: i). newList add: (list at: i)]]. newChangeList size < changeList size ifTrue: [changeList := newChangeList. list := newList. listIndex := 0. listSelections := Array new: list size withAll: false]. self changed: #list ! ! !ChangeList methodsFor: 'filter streaming' stamp: 'StephaneDucasse 7/23/2010 21:08'! selectAllConflicts "Selects all method definitions in the receiver which are also in any existing change set in the system. This makes no statement about whether the content of the methods differ, only whether there is a change represented." Cursor read showWhile: [ | aChange aClass | 1 to: changeList size do: [:i | aChange := changeList at: i. listSelections at: i put: (aChange type = #method and: [(aClass := aChange methodClass) notNil and: [ChangeSet doesAnyChangeSetHaveClass: aClass andSelector: aChange methodSelector]])]]. self changed: #allSelections! ! !ChangeList methodsFor: 'viewing access' stamp: 'di 1/13/1999 14:59'! listSelectionAt: index put: value ^ listSelections at: index put: value! ! !ChangeList methodsFor: 'viewing access' stamp: 'AlainPlantec 11/13/2009 23:16'! toggleListIndex: newListIndex listIndex ~= 0 ifTrue: [listSelections at: listIndex put: false]. newListIndex ~= 0 ifTrue: [listSelections at: newListIndex put: true]. listIndex := newListIndex. self changed: #listIndex. self contentsChanged! ! !ChangeList methodsFor: 'menu actions' stamp: 'MarcusDenker 5/18/2013 15:44'! selectUnchangedDefinitions "Selects all recognizable definitions for which there is already a definition in the current image, whose source is exactly the same." | change class tokens | Cursor read showWhile: [1 to: changeList size do: [:i | change := changeList at: i. listSelections at: i put: false. (change type = #method and: [(class := change methodClass) notNil and: [class includesSelector: change methodSelector]]) ifTrue: [listSelections at: i put: change string withBlanksCondensed = (class sourceCodeAt: change methodSelector) asString withBlanksCondensed]. (change type == #classComment and: [(class := change commentClass) notNil]) ifTrue: [listSelections at: i put: change string = class comment asString]. change type == #doIt ifTrue: [tokens := change string parseLiterals. ((tokens select: [:substr| #(subclass: variableSubclass: variableByteSubclass: variableWordSubclass: instanceVariableNames: classVariableNames: ) includes: substr]) asSet size >= 3 and: [(class := Smalltalk globals at: tokens third ifAbsent: []) notNil and: [class isBehavior]]) ifTrue: [listSelections at: i put: change string withBlanksCondensed = class definition withBlanksCondensed]. (tokens size = 4 and: [tokens second == #class and: [tokens third == #instanceVariableNames: and: [(class := Smalltalk globals at: tokens first ifAbsent: []) notNil and: [class isBehavior]]]]) ifTrue: [listSelections at: i put: change string withBlanksCondensed = class class definition withBlanksCondensed]. (tokens size = 3 and: [tokens second == #removeSelector: and: [(class := Smalltalk at: tokens first ifAbsent: []) isNil or: [class isBehavior and: [(class includesSelector: tokens third) not]]]]) ifTrue: [listSelections at: i put: true]. (tokens size = 4 and: [tokens second == #class and: [tokens third == #removeSelector: and: [(class := Smalltalk at: tokens first ifAbsent: []) isNil or: [class isBehavior and: [(class class includesSelector: tokens fourth) not]]]]]) ifTrue: [listSelections at: i put: true]]]]. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions' stamp: 'sd 11/20/2005 21:26'! deselectAll "Deselect all items in the list pane, and clear the code pane" listIndex := 0. listSelections atAllPut: false. self changed: #allSelections. self contentsChanged! ! !ChangeList methodsFor: 'initialization-release' stamp: 'MarcusDenker 11/2/2012 14:59'! openAsMorphName: labelString multiSelect: multiSelect "Open a morphic view for the messageSet, whose label is labelString. The listView may be either single or multiple selection type" "Open a morphic view for the messageSet, whose label is labelString. The listView may be either single or multiple selection type" | window listHeight listPane | listHeight := 0.4. window := (SystemWindow labelled: labelString) model: self. listPane := multiSelect ifTrue: [PluggableListMorph on: self list: #list primarySelection: #listIndex changePrimarySelection: #toggleListIndex: listSelection: #listSelectionAt: changeListSelection: #listSelectionAt:put: menu: (self showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:])] ifFalse: [PluggableListMorph on: self list: #list selected: #listIndex changeSelected: #toggleListIndex: menu: (self showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:])]. listPane keystrokeActionSelector: #changeListKey:from:. window addMorph: listPane frame: (0 @ 0 extent: 1 @ listHeight). self addLowerPanesTo: window at: (0 @ listHeight corner: 1 @ 1) with: nil. ^ window openInWorld ! ! !ChangeList methodsFor: 'menu actions' stamp: 'IgorStasenko 3/6/2011 18:18'! selectConflictsWith "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList chosen by the user." | aStream all index | aStream := (String new: 200) writeStream. (all := ChangeSet allChangeSets copy) do: [:sel | aStream nextPutAll: (sel name contractTo: 40); cr]. self allSubInstancesDo: [:sel | aStream nextPutAll: (sel file name); cr. all addLast: sel]. aStream skip: -1. index := (UIManager default chooseFrom: (aStream contents substrings)). index > 0 ifTrue: [ self selectConflicts: (all at: index)]. ! ! !ChangeList methodsFor: 'viewing access' stamp: 'Igor.Stasenko 12/20/2009 18:54'! restoreDeletedMethod "If lostMethodPointer is not nil, then this is a version browser for a method that has been removed. In this case we want to establish a sourceCode link to prior versions. We do this by installing a dummy method with the correct source code pointer prior to installing this version." | dummyMethod class selector | dummyMethod := CompiledMethod toReturnSelfTrailerBytes: (CompiledMethodTrailer new sourcePointer: lostMethodPointer). class := (changeList at: listIndex) methodClass. selector := (changeList at: listIndex) methodSelector. class addSelectorSilently: selector withMethod: dummyMethod. (changeList at: listIndex) fileIn. "IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails." (class compiledMethodAt: selector) == dummyMethod ifTrue: [class basicRemoveSelector: selector]. ^ true! ! !ChangeList methodsFor: 'menu actions' stamp: 'StephaneDucasse 7/23/2010 22:37'! selectMethodsForThisClass | name | self currentChange ifNil: [ ^self ]. name := self currentChange methodClassName. name ifNil: [ ^self ]. ^self selectSuchThat: [ :change | change methodClassName = name ].! ! !ChangeList methodsFor: 'menu actions' stamp: 'BenjaminVanRyseghem 11/1/2011 07:40'! browseCurrentVersionsOfSelections "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted" | aList | aList := MessageList new. Cursor read showWhile: [ 1 to: changeList size do: [:i | (listSelections at: i) ifTrue: [ | aClass aChange | aChange := changeList at: i. (aClass := aChange methodClass) notNil and: [aChange isMethodDefinedInImage ifTrue: [ aList addMethodReference: ( RGMethodDefinition realClass: aClass selector: aChange methodSelector)] ]]]]. aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. (Smalltalk tools messageList on: aList named: 'Current versions of selected methods in ', file localName) open ! ! !ChangeList methodsFor: 'scanning' stamp: 'SeanDeNigris 6/21/2012 08:41'! scanFile: aFile from: startPosition to: stopPosition file := aFile. changeList := OrderedCollection new. list := OrderedCollection new. listIndex := 0. file position: startPosition. 'Scanning ', aFile localName, '...' displayProgressFrom: startPosition to: stopPosition during: [:bar | | item prevChar itemPosition | [file position < stopPosition] whileTrue: [bar current: file position. [file atEnd not and: [file peek isSeparator]] whileTrue: [prevChar := file next]. (file peekFor: $!!) ifTrue: [(prevChar = Character cr or: [prevChar = Character lf]) ifTrue: [self scanCategory]] ifFalse: [itemPosition := file position. item := file nextChunk. file skipStyleChunk. item size > 0 ifTrue: [self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt) text: 'do it: ' , (item contractTo: 50)]]]]. listSelections := Array new: list size withAll: false! ! !ChangeList methodsFor: 'menu actions' stamp: 'PeterHugossonMiller 9/3/2009 00:17'! fileOutSelections | fileName internalStream | fileName := UIManager default request: 'Enter the base of file name' initialAnswer: 'Filename'. internalStream := (String new: 1000) writeStream. internalStream header; timeStamp. listSelections with: changeList do: [:selected :item | selected ifTrue: [item fileOutOn: internalStream]]. FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true ! ! !ChangeList methodsFor: 'viewing access' stamp: ''! listIndex ^ listIndex! ! !ChangeList methodsFor: 'menu actions' stamp: 'MarcusDenker 4/28/2013 11:13'! removeExistingMethodVersions "Remove all up to date version of entries from the receiver" | newChangeList newList | newChangeList := OrderedCollection new. newList := OrderedCollection new. changeList with: list do: [ :chRec :strNstamp | | str keep sel cls | keep := true. (cls := chRec methodClass) ifNotNil: [ str := chRec string. sel := cls compiler parseSelector: str. keep := (cls sourceCodeAt: sel ifAbsent: ['']) asString ~= str]. keep ifTrue: [ newChangeList add: chRec. newList add: strNstamp]]. self refreshNewList: newChangeList andList: newList! ! !ChangeList methodsFor: 'menu actions' stamp: 'MarcusDenker 10/15/2013 18:13'! selectNewMethods "Selects all method definitions for which there is no counterpart method in the current image" Cursor read showWhile: [ | change | 1 to: changeList size do: [:i | change := changeList at: i. listSelections at: i put: change isMethodNotDefinedInImage]]. self changed: #allSelections! ! !ChangeList methodsFor: 'viewing access' stamp: 'nk 2/26/2004 13:50'! selectedClass ^(self selectedClassOrMetaClass ifNil: [ ^nil ]) theNonMetaClass ! ! !ChangeList methodsFor: 'menu actions' stamp: 'EstebanLorenzano 8/17/2012 16:41'! selectContentsMatching | pattern | pattern := UIManager default request: 'pattern to match'. pattern isEmpty ifTrue: [^self]. ^Cursor execute showWhile: [self selectSuchThat: ((pattern includesAnyOf: '?*') ifTrue: [ [:change | pattern match: change string]] ifFalse: [ [:change | change string includesSubstring: pattern]])]! ! !ChangeList methodsFor: 'menu actions' stamp: 'MarianoMartinezPeck 4/27/2012 14:08'! buildMorphicCodePaneWith: editString | codePane | codePane := (PluggableTextMorph on: self text: #contents accept: nil readSelection: #contentsSelection menu: #codePaneMenu:shifted:) enabled: false; yourself. codePane font: StandardFonts codeFont. editString ifNotNil: [ codePane editString: editString. codePane hasUnacceptedEdits: true ]. ^codePane ! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sw 8/15/2002 22:34'! wantsPrettyDiffOption "Answer whether pretty-diffs are meaningful for this tool" ^ true! ! !ChangeList methodsFor: 'viewing access' stamp: 'tk 4/10/1998 09:25'! contents: aString listIndex = 0 ifTrue: [self changed: #flash. ^ false]. lostMethodPointer ifNotNil: [^ self restoreDeletedMethod]. self okToChange "means not dirty" ifFalse: ["is dirty" self inform: 'This is a view of a method on a file.\Please cancel your changes. You may\accept, but only when the method is untouched.' withCRs. ^ false]. "Can't accept changes here. Method text must be unchanged!!" (changeList at: listIndex) fileIn. ^ true! ! !ChangeList methodsFor: 'menu actions' stamp: 'StephaneDucasse 5/28/2011 13:32'! removeNonSelections "Remove the unselected items from the receiver." | newChangeList newList | newChangeList := OrderedCollection new. newList := OrderedCollection new. 1 to: changeList size do: [ :i | (listSelections at: i) ifTrue: [ newChangeList add: (changeList at: i). newList add: (list at: i) ]]. newChangeList size = 0 ifTrue: [^ self inform: 'That would remove everything. Why would you want to do that?']. self refreshNewList: newChangeList andList: newList. ! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 9/5/2001 13:52'! contents "Answer the contents string, obeying diffing directives if needed" ^ self showingAnyKindOfDiffs ifFalse: [self undiffedContents] ifTrue: [self showsVersions ifTrue: [self diffedVersionContents] ifFalse: [self contentsDiffedFromCurrent]]! ! !ChangeList class methodsFor: 'menu' stamp: 'MarcusDenker 10/16/2013 10:38'! changeListMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'FileIn selections') help: 'Import the selected items into the image'; target: target; selector: #fileInSelections. (aBuilder item: #'FileOut selections...') help: 'Create a new file containing the selected items'; target: target; selector: #fileOutSelections; withSeparatorAfter. (aBuilder item: #'Compare to current') help: 'Open a separate window which shows the text differences between the on-file version and the in-image version'; target: target; selector: #compareToCurrentVersion. (aBuilder item: #'Toggle diffing') keyText: 'D'; help: 'Start or stop showing diffs in the code pane'; target: target; selector: #toggleDiffing; withSeparatorAfter. (aBuilder item: #'Select conflicts with any changeset') help: 'Select methods in the file which also occur in any change-set in the system'; target: target; selector: #selectAllConflicts. (aBuilder item: #'Select conflicts with current changeset') help: 'Select methods in the file which also occur in the current change-set'; target: target; selector: #selectConflicts. (aBuilder item: #'Select conflicts with...') help: 'Allows you to designate a file or change-set against which to check for code conflicts'; target: target; selector: #selectConflictsWith; withSeparatorAfter. (aBuilder item: #'Select unchanged definitions') help: 'Select class definitions, class comments and methods in the file whose in-image versions are the same as their in-file counterparts'; target: target; selector: #selectUnchangedDefinitions. (aBuilder item: #'Select unchanged methods') help: 'Select methods in the file whose in-image versions are the same as their in-file counterparts'; target: target; selector: #selectUnchangedMethods. (aBuilder item: #'Select new methods') help: 'Select methods in the file that do not current occur in the image'; target: target; selector: #selectNewMethods. (aBuilder item: #'Select methods for this class') help: 'Select all methods in the file that belong to the currently-selected class'; target: target; selector: #selectMethodsForThisClass. (aBuilder item: #'Select methods for classes in image') help: 'Select all methods in the file that belong to a class that exists in the image'; target: target; selector: #selectMethodsForExtantClasses. (aBuilder item: #'Select changes with contents matching') help: 'Select all changes in the file whose text includes a pattern'; target: target; selector: #selectContentsMatching; withSeparatorAfter. (aBuilder item: #'Select all') keyText: 'a'; help: 'Select all the items in the list'; target: target; selector: #selectAll. (aBuilder item: #'Deselect all') help: 'Deselect all the items in the list'; target: target; selector: #deselectAll. (aBuilder item: #'Invert selections') help: 'Select every item that is not currently selected, and deselect every item that *is* currently selected'; target: target; selector: #invertSelections; withSeparatorAfter. (aBuilder item: #'Browse all versions of single selection') help: 'Open a version browser showing the versions of the currently selected method'; target: target; selector: #browseVersions. (aBuilder item: #'Browse all versions of selections') help: 'Open a version browser showing all the versions of all the selected methods'; target: target; selector: #browseAllVersionsOfSelections. (aBuilder item: #'Browse current versions of selections') help: 'Open a message-list browser showing the current (in-image) counterparts of the selected methods'; target: target; selector: #browseCurrentVersionsOfSelections. (aBuilder item: #'Remove doIts') help: 'Remove all items that are doIts rather than methods'; target: target; selector: #removeDoIts. (aBuilder item: #'Remove older versions') help: 'Remove all but the most recent versions of methods in the list'; target: target; selector: #removeOlderMethodVersions. (aBuilder item: #'Remove up-to-date versions') help: 'Remove all items whose code is the same as the counterpart in-image code'; target: target; selector: #removeExistingMethodVersions. (aBuilder item: #'Remove selected items') help: 'Remove the selected items from the change-list'; target: target; selector: #removeSelections. (aBuilder item: #'Remove unselected items') help: 'Remove all the items not currently selected from the change-list'; target: target; selector: #removeNonSelections. ! ! !ChangeList class methodsFor: 'public access' stamp: 'ClementBera 7/26/2013 16:13'! browseRecentLogOn: origChangesFile startingFrom: initialPos "Prompt with a menu of how far back to go when browsing a changes file." | end banners positions pos chunk i changesFile | changesFile := origChangesFile readOnlyCopy. banners := OrderedCollection new. positions := OrderedCollection new. end := changesFile size. changesFile setConverterForCode. pos := initialPos. [pos = 0 or: [banners size > 20]] whileFalse: [changesFile position: pos. chunk := changesFile nextChunk. i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. i > 0 ifTrue: [positions addLast: pos. banners addLast: (chunk copyFrom: 5 to: i - 2). pos := Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] ifFalse: [pos := 0]]. changesFile close. banners size = 0 ifTrue: [^ self inform: 'this image has never been saved since changes were compressed' translated]. pos := UIManager default chooseFrom: banners values: positions title: 'Browse as far back as...' translated. pos ifNil: [^ self]. self browseRecent: end - pos on: origChangesFile! ! !ChangeList class methodsFor: 'System-FileRegistry' stamp: 'tbn 8/11/2010 10:11'! serviceBrowseDotChangesFile "Answer a service for opening a changelist browser on the tail end of a .changes file" ^ SimpleServiceEntry provider: self label: 'Recent changes in file' selector: #browseRecentLogOnPath: description: 'Open a changelist tool on recent changes in file' buttonLabel: 'Recent changes'! ! !ChangeList class methodsFor: '*Tools-FileList' stamp: 'onierstrasz 11/11/2013 12:20'! browseChangesFile: fullName "Browse the selected file in fileIn format." fullName ifNotNil: [self browseStream: (FileStream readOnlyFileNamed: fullName)] ifNil: [self inform: 'Missing file name' ]! ! !ChangeList class methodsFor: 'System-FileRegistry' stamp: 'nk 12/13/2002 12:04'! services "Answer potential file services associated with this class" ^ { self serviceBrowseChangeFile. self serviceBrowseDotChangesFile. self serviceBrowseCompressedChangeFile }! ! !ChangeList class methodsFor: 'public access' stamp: 'tak 9/25/2008 16:25'! browseRecent: charCount "ChangeList browseRecent: 5000" "Opens a changeList on the end of the changes log file" "The core was moved to browserRecent:on:." ^ self browseRecent: charCount on: (SourceFiles at: 2) ! ! !ChangeList class methodsFor: 'initialize-release' stamp: 'GabrielOmarCotelli 6/4/2009 20:38'! initialize FileServices registerFileReader: self! ! !ChangeList class methodsFor: 'public access' stamp: 'StephaneDucasse 3/17/2010 20:53'! browseRecentLog "ChangeList browseRecentLog" "Prompt with a menu of how far back to go to browse the current image's changes log file" ^ self browseRecentLogOn: (SourceFiles at: 2) startingFrom: Smalltalk lastQuitLogPosition! ! !ChangeList class methodsFor: 'tool registry' stamp: 'IgorStasenko 2/20/2011 14:41'! registerToolsOn: registry registry register: self as: #changeList ! ! !ChangeList class methodsFor: 'public access' stamp: 'di 1/18/2001 15:30'! browseFile: fileName "ChangeList browseFile: 'AutoDeclareFix.st'" "Opens a changeList on the file named fileName" ^ self browseStream: (FileStream readOnlyFileNamed: fileName)! ! !ChangeList class methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:38'! unload FileServices unregisterFileReader: self ! ! !ChangeList class methodsFor: 'System-FileRegistry' stamp: 'tbn 8/11/2010 10:11'! serviceBrowseCompressedChangeFile "Answer a service for opening a changelist browser on a file" ^ SimpleServiceEntry provider: self label: 'Changelist browser' selector: #browseCompressedChangesFile: description: 'Open a changelist tool on this file' buttonLabel: 'Changes'! ! !ChangeList class methodsFor: 'instance creation' stamp: 'alain.plantec 5/30/2008 10:41'! open: aChangeList name: aString multiSelect: multiSelect "Create a standard system view for the messageSet, whose label is aString. The listView may be either single or multiple selection type" ^ self openAsMorph: aChangeList name: aString multiSelect: multiSelect. ! ! !ChangeList class methodsFor: 'public access' stamp: 'sd 11/20/2005 21:28'! browseRecent: charCount on: origChangesFile "Opens a changeList on the end of the specified changes log file" | changeList end changesFile | changesFile := origChangesFile readOnlyCopy. changesFile setConverterForCode. end := changesFile size. Cursor read showWhile: [changeList := self new scanFile: changesFile from: (0 max: end - charCount) to: end]. changesFile close. self open: changeList name: 'Recent changes' multiSelect: true! ! !ChangeList class methodsFor: 'public access' stamp: 'sd 11/20/2005 21:28'! browseRecentLogOn: origChangesFile "figure out where the last snapshot or quit was, then browse the recent entries." | end done block pos chunk changesFile positions prevBlock | changesFile := origChangesFile readOnlyCopy. positions := SortedCollection new. end := changesFile size. prevBlock := end. block := end - 1024 max: 0. done := false. [done or: [positions size > 0]] whileFalse: [changesFile position: block. "ignore first fragment" changesFile nextChunk. [changesFile position < prevBlock] whileTrue: [pos := changesFile position. chunk := changesFile nextChunk. ((chunk indexOfSubCollection: '----' startingAt: 1) = 1) ifTrue: [ ({ '----QUIT'. '----SNAPSHOT' } anySatisfy: [ :str | chunk beginsWith: str ]) ifTrue: [positions add: pos]]]. block = 0 ifTrue: [done := true] ifFalse: [prevBlock := block. block := block - 1024 max: 0]]. changesFile close. positions isEmpty ifTrue: [self inform: 'File ' , changesFile name , ' does not appear to be a changes file'] ifFalse: [self browseRecentLogOn: origChangesFile startingFrom: positions last]! ! !ChangeList class methodsFor: 'public access' stamp: 'sd 11/20/2005 21:28'! browseStream: changesFile "Opens a changeList on a fileStream" | changeList charCount | changesFile readOnly. changesFile setConverterForCode. charCount := changesFile size. charCount > 1000000 ifTrue: [(self confirm: 'The file ', changesFile name , ' is really long (' , charCount printString , ' characters). Would you prefer to view only the last million characters?') ifTrue: [charCount := 1000000]]. "changesFile setEncoderForSourceCodeNamed: changesFile name." Cursor read showWhile: [changeList := self new scanFile: changesFile from: changesFile size-charCount to: changesFile size]. changesFile close. self open: changeList name: changesFile localName , ' log' multiSelect: true! ! !ChangeList class methodsFor: 'System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:21'! fileReaderServicesForFile: fullName suffix: suffix | services | services := OrderedCollection new. (FileStream isSourceFileSuffix: suffix) | (suffix = '*') ifTrue: [ services add: self serviceBrowseChangeFile ]. (suffix = 'changes') | (suffix = '*') ifTrue: [ services add: self serviceBrowseDotChangesFile ]. (fullName asLowercase endsWith: '.cs.gz') | (suffix = '*') ifTrue: [ services add: self serviceBrowseCompressedChangeFile ]. ^services! ! !ChangeList class methodsFor: 'System-FileRegistry' stamp: 'onierstrasz 11/11/2013 12:20'! browseCompressedChangesFile: fullName "Browse the selected file in fileIn format." | unzipped stream | fullName ifNil: [^ self inform: 'Missing file name' ]. stream := FileStream readOnlyFileNamed: fullName. [ | zipped | stream converter: Latin1TextConverter new. zipped := GZipReadStream on: stream. unzipped := zipped contents asString] ensure: [stream close]. stream := (MultiByteBinaryOrTextStream with: unzipped) reset. self browseStream: stream! ! !ChangeList class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallSaveIcon! ! !ChangeList class methodsFor: 'window color' stamp: 'AlainPlantec 12/16/2009 22:08'! patchworkUIThemeColor "Answer a default color for UI themes that make use of different colors for Browser, MessageList etc..." ^ Color lightBlue ! ! !ChangeList class methodsFor: 'instance creation' stamp: 'RAA 1/11/2001 08:20'! openAsMorph: aChangeList name: labelString multiSelect: multiSelect "Open a morphic view for the messageSet, whose label is labelString. The listView may be either single or multiple selection type" ^aChangeList openAsMorphName: labelString multiSelect: multiSelect ! ! !ChangeList class methodsFor: 'public access' stamp: 'onierstrasz 11/11/2013 12:21'! browseRecentLogOnPath: fullName "figure out where the last snapshot or quit was, then browse the recent entries." fullName ifNotNil: [self browseRecentLogOn: (FileStream readOnlyFileNamed: fullName)] ifNil: [self inform: 'Missing file name' ] ! ! !ChangeList class methodsFor: '*monticellogui' stamp: 'MartinDias 1/8/2013 15:48'! recent: charCount on: origChangesFile "Opens a changeList on the end of the specified changes log file" | changeList end changesFile | changesFile := origChangesFile readOnlyCopy. end := changesFile size. changeList := Cursor read showWhile: [ self new scanFile: changesFile from: (0 max: end - charCount) to: end]. changesFile close. ^changeList! ! !ChangeList class methodsFor: '*monticellogui' stamp: 'StephaneDucasse 5/28/2011 13:32'! recentLogOn: origChangesFile startingFrom: initialPos "Prompt with a menu of how far back to go when browsing a changes file." | end banners positions pos chunk i changesFile | changesFile := origChangesFile readOnlyCopy. banners := OrderedCollection new. positions := OrderedCollection new. end := changesFile size. pos := initialPos. [pos = 0 or: [banners size > 20]] whileFalse: [changesFile position: pos. chunk := changesFile nextChunk. i := chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. i > 0 ifTrue: [positions addLast: pos. banners addLast: (chunk copyFrom: 5 to: i - 2). pos := Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] ifFalse: [pos := 0]]. changesFile close. banners size = 0 ifTrue: [^self recent: end on: origChangesFile]. pos := UIManager default chooseFrom: banners values: positions title: 'Browse as far back as...'. pos == nil ifTrue: [^ self]. ^self recent: end - pos on: origChangesFile! ! !ChangeList class methodsFor: 'System-FileRegistry' stamp: 'tbn 4/2/2012 16:56'! serviceBrowseChangeFile "Answer a service for opening a changelist browser on a file" ^ (SimpleServiceEntry provider: self label: 'Changelist browser' selector: #browseStream: description: 'Open a changelist tool on this file' buttonLabel: 'Changes') argumentGetter: [ :fileList | fileList readOnlyStream ]! ! !ChangeRecord commentStamp: ''! A ChangeRecord represents a change recorded on a file in fileOut format. It includes a type (more needs to be done here), and additional information for certain types such as method defs which need class and category.! !ChangeRecord methodsFor: 'access' stamp: 'tk 9/7/2000 15:09'! stamp: threePartString stamp := threePartString! ! !ChangeRecord methodsFor: 'access' stamp: 'di 1/13/98 16:57'! string | string | file openReadOnly. file position: position. string := file nextChunk. file close. ^ string! ! !ChangeRecord methodsFor: 'access' stamp: 'StephaneDucasse 7/23/2010 21:45'! methodClass | methodClass | type == #method ifFalse: [ ^ nil ]. (Smalltalk globals includesKey: class asSymbol) ifFalse: [ ^ nil ]. methodClass := Smalltalk globals at: class asSymbol. ^ meta ifTrue: [ methodClass class ] ifFalse: [ methodClass ]! ! !ChangeRecord methodsFor: 'access' stamp: ''! methodClassName ^class! ! !ChangeRecord methodsFor: 'access' stamp: 'tk 6/23/1999 08:20'! text | text | ^ file ifNil: [''] ifNotNil: [ file openReadOnly. file position: position. text := file nextChunkText. file close. text]! ! !ChangeRecord methodsFor: 'access' stamp: 'sumim 9/1/2003 18:27'! fileIndex ^ (SourceFiles collect: [ :sf | sf name]) indexOf: file name ifAbsent: [^ nil]. ! ! !ChangeRecord methodsFor: 'access' stamp: 'sw 10/20/2002 02:53'! fileOutOn: aFileStream "File the receiver out on the given file stream" | aString | type == #method ifTrue: [aFileStream nextPut: $!!. aString := class asString , (meta ifTrue: [' class methodsFor: '] ifFalse: [' methodsFor: ']) , category asString printString. stamp ifNotNil: [aString := aString, ' stamp: ''', stamp, '''']. aFileStream nextChunkPut: aString. aFileStream cr]. type == #preamble ifTrue: [aFileStream nextPut: $!!]. type == #classComment ifTrue: [aFileStream nextPut: $!!. aFileStream nextChunkPut: class asString, ' commentStamp: ', stamp storeString. aFileStream cr]. aFileStream nextChunkPut: self string. type == #method ifTrue: [aFileStream nextChunkPut: ' ']. aFileStream cr! ! !ChangeRecord methodsFor: 'access' stamp: 'nk 1/7/2004 10:28'! fileName ^(file ifNotNil: [ file name ]) ifNil: [ '' ]! ! !ChangeRecord methodsFor: 'initialization' stamp: '6/6/97 08:48 dhhi'! file: f position: p type: t class: c category: cat meta: m stamp: s self file: f position: p type: t. class := c. category := cat. meta := m. stamp := s! ! !ChangeRecord methodsFor: '*RecentSubmissions-Core' stamp: 'BenjaminVanRyseghem 5/6/2011 17:48'! printOn: aStream aStream nextPutAll: self type printString. self stamp ifNotNil: [ aStream nextPutAll: self stamp ]! ! !ChangeRecord methodsFor: 'access' stamp: ''! type ^ type! ! !ChangeRecord methodsFor: 'access' stamp: 'SvenVanCaekenberghe 12/22/2013 16:37'! timeStamp "Answer a TimeStamp that corresponds to my (text) stamp" | tokens | tokens := self stamp findTokens: Character separators. ^ tokens size > 2 ifTrue: [ [ | time date | date := Date fromString: (tokens at: tokens size - 1). time := Time fromString: tokens last. DateAndTime date: date time: time ] on: Error do: [ :ex | ex return: DateAndTime new ] ] ifFalse: [ DateAndTime new ]! ! !ChangeRecord methodsFor: 'testing' stamp: 'StephaneDucasse 7/23/2010 21:59'! classIncludesSelector | aClass | ^ (aClass := self methodClass) notNil and: [aClass includesSelector: self methodSelector]! ! !ChangeRecord methodsFor: '*RecentSubmissions-Core' stamp: 'BenjaminVanRyseghem 6/14/2012 11:51'! sourceCode self type= #preamble ifTrue: [ ^ #preamble printString ]. self type= #doIt ifTrue: [ ^ #preamble printString ]. self type= #classComment ifTrue: [ self commentClass ifNotNil: [ :comment | ^ comment comment ]]. ^ self string! ! !ChangeRecord methodsFor: '*Ring-Monticello' stamp: 'CamilloBruni 5/25/2012 14:28'! asMCMethodDefinition "Creates a MCMethodDefinition from the receiver when this was created for a method (type=#method)" self type == #method ifFalse: [ ^nil ]. "This case shouldn't happen" ^ MCMethodDefinition className: class classIsMeta: meta selector: self methodSelector category: category timeStamp: stamp source: self string! ! !ChangeRecord methodsFor: 'access' stamp: 'MarcusDenker 4/28/2013 11:04'! methodSelector ^ type == #method ifTrue: [ (Smalltalk globals at: class ifAbsent: [ Object ]) compiler parseSelector: self string ]! ! !ChangeRecord methodsFor: 'access' stamp: ''! category ^category! ! !ChangeRecord methodsFor: 'testing' stamp: 'StephaneDucasse 1/7/2011 17:22'! isMethodDefinedInImage "answer whether the method represented by the receiver is present in the image" ^ self type = #method and: [self classIncludesSelector]! ! !ChangeRecord methodsFor: 'access' stamp: ''! isMetaClassChange ^meta! ! !ChangeRecord methodsFor: 'access' stamp: 'HenrikSperreJohansen 9/12/2010 10:02'! commentClass | commentClass | type == #classComment ifFalse: [^ nil]. (Smalltalk includesKey: class asSymbol) ifFalse: [^ nil]. commentClass := Smalltalk at: class asSymbol. ^meta ifTrue: [commentClass class] ifFalse: [commentClass] ! ! !ChangeRecord methodsFor: 'testing' stamp: 'StephaneDucasse 7/23/2010 22:40'! isMethodNotDefinedInImage "answer whether the method represented by the receiver is not present in the image. pay attention is it not just isMethodDefinedInImage not" | aClass | ^ self type = #method and: [(aClass := self methodClass) isNil or: [(aClass includesSelector: self methodSelector) not]]! ! !ChangeRecord methodsFor: 'initialization' stamp: ''! file: f position: p type: t file := f. position := p. type := t! ! !ChangeRecord methodsFor: 'access' stamp: '6/6/97 08:56 dhhi'! stamp ^ stamp! ! !ChangeRecord methodsFor: 'access' stamp: 'sumim 9/2/2003 14:07'! position ^ position! ! !ChangeRecord methodsFor: '*Ring-Core-Kernel' stamp: 'StephaneDucasse 7/8/2011 15:31'! asRingDefinition "Retrieves a RGMethodDefinition object based on the data of the receiver" self type == #method ifTrue: [ ^self createMethodDefinition ]. self type == #classComment ifTrue: [ ^self createCommentDefinition ]. ^nil! ! !ChangeRecord methodsFor: 'initialization' stamp: 'GuillermoPolito 6/28/2013 10:37'! fileIn "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." Cursor read showWhile: [ | methodClass s | (methodClass := self methodClass) notNil ifTrue: [ methodClass compile: self text classified: category withStamp: stamp notifying: nil ]. type == #doIt ifTrue: [ ((s := self string) beginsWith: '----') ifFalse: [ self class compiler evaluate: s ] ]. type == #classComment ifTrue: [ (Smalltalk globals at: class asSymbol) comment: self text stamp: stamp ] ]! ! !ChangeRecord methodsFor: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 5/12/2011 14:32'! createCommentDefinition "Retrieves a RGCommentDefinition object based on the data of the receiver" ^(RGFactory current createCommentDefinition) parentName: self commentClass name; content: self string; stamp: stamp; yourself ! ! !ChangeRecord methodsFor: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 8/31/2011 14:09'! createMethodDefinition "Retrieves a RGMethodDefinition object based on the data of the receiver" ^(RGFactory current createMethodNamed: self methodSelector) parentName: self methodClass name; isMetaSide: meta; sourceCode: self string; protocol: category; stamp: stamp; yourself! ! !ChangeRecord methodsFor: '*RecentSubmissions-Core' stamp: 'BenjaminVanRyseghem 5/6/2011 17:39'! <= anotherOne self stamp ifNil: [ ^ false ]. anotherOne stamp ifNil: [ ^ true ]. ^ self timeStamp <= anotherOne timeStamp ! ! !ChangeRecord methodsFor: 'testing' stamp: 'StephaneDucasse 7/23/2010 22:52'! isUnchangedMethod ^ self isMethodDefinedInImage and: [self string withBlanksCondensed = (self methodClass sourceCodeAt: self methodSelector) asString withBlanksCondensed ]! ! !ChangeSet commentStamp: ''! ChangeSets keep track of the changes made to a system, so they can be written on a file as source code (a "fileOut"). --- preamble and postscript: two strings that serve as prefix (useful for documentation) and suffix (useful for doits) to the fileout of the changeSet. changeRecords - Dictionary {class name -> a ClassChangeRecord}. These classChangeRecords (qv) remember all of the system changes.! !ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 14:44'! hasPostscript ^ postscript notNil! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 17:55'! preamble "Answer the string representing the preamble" ^preamble ifNotNil:[preamble isString ifTrue:[preamble] ifFalse:[preamble contents asString]]! ! !ChangeSet methodsFor: 'filein/out' stamp: 'sd 4/16/2003 09:16'! checkForUncommentedMethods | aList | "Check to see if there are any methods in the receiver that have no comments, and open a browser on all found" (aList := self methodsWithoutComments) size > 0 ifFalse: [^ self inform: 'All methods in "', self name, '" have comments'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" that lack comments']! ! !ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 14:48'! removePostscript postscript := nil! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 11:49'! expungeEmptyClassChangeEntries changeRecords keysAndValuesRemove: [:className :classRecord | classRecord hasNoChanges]! ! !ChangeSet methodsFor: 'filein/out' stamp: 'StephaneDucasse 5/23/2011 22:45'! checkForSlips "Return a collection of method refs with possible debugging code in them." | slips | slips := OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | | method | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [method := aClass compiledMethodAt: mAssoc key ifAbsent: [nil]. method ifNotNil: [method hasReportableSlip ifTrue: [ slips add: (aClass >> mAssoc key) methodReference ]]]]]. ^ slips! ! !ChangeSet methodsFor: 'method changes' stamp: 'di 4/1/2000 12:00'! methodChangesAtClass: className "Return an old-style dictionary of method change types." ^(changeRecords at: className ifAbsent: [^ Dictionary new]) methodChangeTypes! ! !ChangeSet methodsFor: 'private' stamp: 'al 7/22/2008 21:36'! fileOutClassDefinition: class on: stream "Write out class definition for the given class on the given stream, if the class definition was added or changed." (self atClass: class includes: #rename) ifTrue: [stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; cr]. (self atClass: class includes: #change) ifTrue: [ "fat definition only needed for changes" stream nextChunkPut: (self fatDefForClass: class); cr. DeepCopier new checkClass: class. "If veryDeepCopy weakly copies some inst vars in this class, warn author when new ones are added." ] ifFalse: [ (self atClass: class includes: #add) ifTrue: [ "use current definition for add" stream nextChunkPut: class definition; cr. DeepCopier new checkClass: class. "If veryDeepCopy weakly copies some inst vars in this class, warn author when new ones are added." ]. ]. (self atClass: class includes: #comment) ifTrue: [class theNonMetaClass organization putCommentOnFile: stream numbered: 0 moveSource: false forClass: class theNonMetaClass. stream cr]. ! ! !ChangeSet methodsFor: 'filein/out' stamp: 'AlainPlantec 12/18/2009 14:11'! preambleTemplate "Answer a string that will form the default contents for a change set's preamble. Just a first stab at what the content should be." ^ String streamContents: [:strm | strm nextPutAll: '"Change Set:'. "NOTE: fileIn recognizes preambles by this string." strm tab;tab; nextPutAll: self name. strm cr; nextPutAll: 'Date:'; tab; tab; tab; nextPutAll: Date today printString. strm cr; nextPutAll: 'Author:'; tab; tab; tab; nextPutAll: Author fullName. strm cr; cr; nextPutAll: '"'] "ChangeSet current preambleTemplate"! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:29'! methodRemoved: anEvent self removeSelector: anEvent selector class: anEvent methodClass priorMethod: anEvent methodRemoved lastMethodInfo: {anEvent methodRemoved sourcePointer. anEvent protocol}! ! !ChangeSet methodsFor: 'initialization' stamp: 'MarcusDenker 8/25/2010 20:55'! initialize "Initialize the receiver to be empty." super initialize. name ifNil: [^ self error: 'All changeSets must be registered, as in ChangeSorter newChangeSet']. self clear. ! ! !ChangeSet methodsFor: 'filein/out' stamp: 'MarianoMartinezPeck 9/3/2012 12:39'! fileOutOn: stream "Write out all the changes the receiver knows about" | classList traits classes traitList list | (self isEmpty and: [stream isKindOf: FileStream]) ifTrue: [self inform: 'Warning: no changes to file out']. traits := self changedClasses reject: [:each | each isBehavior]. classes := self changedClasses select: [:each | each isBehavior]. traitList := self class traitsOrder: traits asOrderedCollection. classList := self class classesOrder: classes asOrderedCollection. list := OrderedCollection new addAll: traitList; addAll: classList; yourself. "First put out rename, max classDef and comment changes." list do: [:aClass | self fileOutClassDefinition: aClass on: stream]. "Then put out all the method changes" list do: [:aClass | self fileOutChangesFor: aClass on: stream]. "Finally put out removals, final class defs and reorganization if any" list reverseDo: [:aClass | self fileOutPSFor: aClass on: stream]. self classRemoves asSortedCollection do: [:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:26'! classReorganized: anEvent self reorganizeClass: anEvent classReorganized! ! !ChangeSet methodsFor: 'private' stamp: 'di 3/28/2000 14:40'! atClass: class add: changeType (self changeRecorderFor: class) noteChangeType: changeType fromClass: class! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:25'! classRecategorized: anEvent self changeClass: anEvent classRecategorized from: anEvent classRecategorized! ! !ChangeSet methodsFor: 'testing' stamp: 'stephane.ducasse 7/10/2009 16:44'! okayToRemoveInforming: aBoolean "Answer whether it is okay to remove the receiver. If aBoolean is true, inform the receiver if it is not okay" | aName | aName := self name. self == self class current ifTrue: [aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '" because it is the current change set.']. ^ false]. ^ true ! ! !ChangeSet methodsFor: 'change logging' stamp: 'EstebanLorenzano 2/28/2013 16:34'! addClass: class "Include indication that a new class was created." class wantsChangeSetLogging ifFalse: [^ self]. self atClass: class add: #new. self atClass: class add: #change. self addCoherency: class name! ! !ChangeSet methodsFor: 'class changes' stamp: 'lr 3/14/2010 21:13'! changedClasses "Answer an OrderedCollection of changed or edited classes. Does not include removed classes. Sort alphabetically by name." "Much faster to sort names first, then convert back to classes. Because metaclasses reconstruct their name at every comparison in the sorted collection. 8/91 sw chgd to filter out non-existent classes (triggered by problems with class-renames" ^ self changedClassNames collect: [ :className | Smalltalk globals classNamed: className ] thenSelect: [ :aClass | aClass notNil ]! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:27'! methodAdded: anEvent self noteNewMethod: anEvent method forClass: anEvent methodClass selector: anEvent selector priorMethod: nil! ! !ChangeSet methodsFor: 'private' stamp: 'MarcusDenker 12/21/2012 12:02'! changeRecorderFor: class | cname | (class isString) ifTrue: [ cname := class ] ifFalse: [ cname := class name ]. "Later this will init the changeRecords so according to whether they should be revertable." ^ changeRecords at: cname ifAbsent: [^ changeRecords at: cname put: (ClassChangeRecord new initFor: cname)]! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:02'! assurePreambleExists "Make sure there is a StringHolder holding the preamble; if it's found to have reverted to empty contents, put up the template" (preamble isEmptyOrNil) ifTrue: [preamble := self preambleTemplate]! ! !ChangeSet methodsFor: 'class changes' stamp: 'NS 1/26/2004 09:46'! commentClass: class "Include indication that a class comment has been changed." class wantsChangeSetLogging ifFalse: [^ self]. self atClass: class add: #comment! ! !ChangeSet methodsFor: 'testing' stamp: 'RAA 10/19/2000 13:17'! isEmpty "Answer whether the receiver contains any elements." changeRecords ifNil: [^true]. ^ changeRecords isEmpty ! ! !ChangeSet methodsFor: 'method changes' stamp: 'MarcusDenker 5/10/2013 00:24'! adoptSelector: aSelector forClass: aClass "Adopt the given selector/class combination as a change in the receiver" self noteNewMethod: (aClass methodDict at: aSelector) forClass: aClass selector: aSelector priorMethod: nil! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:26'! classRenamed: anEvent self renameClass: anEvent classRenamed from: anEvent oldName to: anEvent newName! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:24'! classAdded: anEvent self addClass: anEvent classAdded! ! !ChangeSet methodsFor: 'method changes' stamp: 'SqR 6/13/2000 19:16'! selectorsInClass: aClassName "Used by a ChangeSorter to access the list methods." ^ (changeRecords at: aClassName ifAbsent: [^#()]) changedSelectors! ! !ChangeSet methodsFor: 'filein/out' stamp: 'di 3/28/2000 09:35'! fileOutChangesFor: class on: stream "Write out all the method changes for this class." | changes | changes := Set new. (self methodChangesAtClass: class name) associationsDo: [:mAssoc | (mAssoc value = #remove or: [mAssoc value = #addedThenRemoved]) ifFalse: [changes add: mAssoc key]]. changes isEmpty ifFalse: [class fileOutChangedMessages: changes on: stream. stream cr]! ! !ChangeSet methodsFor: 'class changes' stamp: 'NS 1/19/2004 17:49'! noteRemovalOf: class "The class is about to be removed from the system. Adjust the receiver to reflect that fact." class wantsChangeSetLogging ifFalse: [^ self]. (self changeRecorderFor: class) noteChangeType: #remove fromClass: class. changeRecords removeKey: class class name ifAbsent: [].! ! !ChangeSet methodsFor: 'filein/out' stamp: 'nice 1/5/2010 15:59'! fileOutPSFor: class on: stream "Write out removals and initialization for this class." | dict classRecord currentDef | classRecord := changeRecords at: class name ifAbsent: [^ self]. dict := classRecord methodChangeTypes. dict keysSortedSafely do: [:key | | changeType | changeType := dict at: key. (#(remove addedThenRemoved) includes: changeType) ifTrue: [stream nextChunkPut: class name, ' removeSelector: ', key storeString; cr] ifFalse: [(key = #initialize and: [class isMeta]) ifTrue: [stream nextChunkPut: class soleInstance name, ' initialize'; cr]]]. ((classRecord includesChangeType: #change) and: [(currentDef := class definition) ~= (self fatDefForClass: class)]) ifTrue: [stream nextChunkPut: currentDef; cr ]. (classRecord includesChangeType: #reorganize) ifTrue: [class fileOutOrganizationOn: stream. stream cr]! ! !ChangeSet methodsFor: 'class changes' stamp: 'di 5/16/2000 09:03'! trimHistory "Drop non-essential history: methods added and then removed, as well as rename and reorganization of newly-added classes." changeRecords do: [:chgRecord | chgRecord trimHistory]! ! !ChangeSet methodsFor: 'moving changes' stamp: 'MarcusDenker 9/29/2013 15:33'! forgetAllChangesFoundIn: otherChangeSet "Remove from the receiver all method changes found in aChangeSet. The intention is facilitate the process of factoring a large set of changes into disjoint change sets. To use: in a change sorter, copy over all the changes you want into some new change set, then use the subtract-other-side feature to subtract those changes from the larger change set, and continue in this manner." otherChangeSet == self ifTrue: [^ self]. otherChangeSet changedClassNames do: [:className | self forgetChangesForClass: className in: otherChangeSet]. self expungeEmptyClassChangeEntries. ! ! !ChangeSet methodsFor: 'accessing' stamp: ''! name: anObject name := anObject! ! !ChangeSet methodsFor: 'testing' stamp: 'StephaneDucasse 3/30/2010 23:02'! isNumbered "Answer whether a change set is numbered" ^ self name startsWithDigit! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:27'! methodModified: anEvent self noteNewMethod: anEvent newMethod forClass: anEvent methodClass selector: anEvent selector priorMethod: anEvent oldMethod! ! !ChangeSet methodsFor: 'filein/out' stamp: 'MarcusDenker 8/25/2010 21:02'! fileOutPreambleOn: stream "If the receiver has a preamble, put it out onto the stream. " | aString | aString := self preambleString. (aString notNil and: [ aString size > 0 ]) ifTrue: [ stream nextChunkPut: aString. "surroundedBySingleQuotes" stream cr; cr ]! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:24'! classCommented: anEvent self commentClass: anEvent classCommented! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:03'! postscript "Answer the string representing the postscript. " ^postscript ifNotNil:[postscript isString ifTrue:[postscript] ifFalse:[postscript contents asString]]! ! !ChangeSet methodsFor: 'change logging' stamp: 'VeronicaUquillas 6/11/2010 11:37'! noteNewMethod: newMethod forClass: class selector: selector priorMethod: methodOrNil class wantsChangeSetLogging ifFalse: [^ self]. (self changeRecorderFor: class) noteNewMethod: newMethod selector: selector priorMethod: methodOrNil ! ! !ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'! atSelector: selector class: class ^ (changeRecords at: class name ifAbsent: [^ #none]) atSelector: selector ifAbsent: [^ #none]! ! !ChangeSet methodsFor: 'class changes' stamp: 'PeterHugossonMiller 9/3/2009 00:18'! fatDefForClass: class | newDef oldDef oldStrm newStrm outStrm oldVars newVars addedVars | class isBehavior ifFalse: [ ^ class definition ]. newDef := class definition. oldDef := (self changeRecorderFor: class) priorDefinition. oldDef ifNil: [ ^ newDef ]. oldDef = newDef ifTrue: [ ^ newDef ]. oldStrm := oldDef readStream. newStrm := newDef readStream. outStrm := (String new: newDef size * 2) writeStream. "Merge inst vars from old and new defs..." oldStrm upToAll: 'instanceVariableNames'; upTo: $'. outStrm nextPutAll: (newStrm upToAll: 'instanceVariableNames'); nextPutAll: 'instanceVariableNames:'. newStrm peek = $: ifTrue: [ newStrm next ]. "may or may not be there, but already written" outStrm nextPutAll: (newStrm upTo: $'); nextPut: $'. oldVars := (oldStrm upTo: $') findTokens: Character separators. newVars := (newStrm upTo: $') findTokens: Character separators. addedVars := oldVars asSet addAll: newVars; removeAll: oldVars; asOrderedCollection. oldVars , addedVars do: [ :var | outStrm nextPutAll: var; space ]. outStrm nextPut: $'. class isMeta ifFalse: [ "Merge class vars from old and new defs..." oldStrm upToAll: 'classVariableNames:'; upTo: $'. outStrm nextPutAll: (newStrm upToAll: 'classVariableNames:'); nextPutAll: 'classVariableNames:'; nextPutAll: (newStrm upTo: $'); nextPut: $'. oldVars := (oldStrm upTo: $') findTokens: Character separators. newVars := (newStrm upTo: $') findTokens: Character separators. addedVars := oldVars asSet addAll: newVars; removeAll: oldVars; asOrderedCollection. oldVars , addedVars do: [ :var | outStrm nextPutAll: var; space ]. outStrm nextPut: $' ]. outStrm nextPutAll: newStrm upToEnd. ^ outStrm contents! ! !ChangeSet methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:07'! name "The name of this changeSet. If name is nil, we've got garbage. Help to identify." ^ name ifNil: [ '' ] ifNotNil: [ name ]! ! !ChangeSet methodsFor: 'moving changes' stamp: 'ar 7/16/2005 18:59'! editPreamble "edit the receiver's preamble, in a separate window. " self assurePreambleExists. UIManager default edit: self preamble label: 'Preamble for ChangeSet named ', name accept:[:aString| self preamble: aString]! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:25'! classModified: anEvent self changeClass: anEvent newClassDefinition from: anEvent oldClassDefinition! ! !ChangeSet methodsFor: 'accessing' stamp: 'ar 7/16/2005 18:04'! postscriptHasDependents ^false! ! !ChangeSet methodsFor: 'change logging' stamp: 'MarcusDenker 7/22/2013 13:12'! changeClass: class from: oldClass "Remember that a class definition has been changed. Record the original structure, so that a conversion method can be built." class wantsChangeSetLogging ifFalse: [^ self]. class isMeta ifFalse: [self atClass: class add: #change] "normal" ifTrue: [((self classChangeAt: class theNonMetaClass name) includes: #add) ifTrue: [self atClass: class add: #add] "When a class is defined, the metaclass is not recorded, even though it was added. A further change is really just part of the original add." ifFalse: [self atClass: class add: #change]]. self addCoherency: class name. (self changeRecorderFor: class) notePriorDefinition: oldClass.! ! !ChangeSet methodsFor: 'change logging' stamp: 'VeronicaUquillas 6/11/2010 11:37'! removeSelector: selector class: class priorMethod: priorMethod lastMethodInfo: info "Include indication that a method has been forgotten. info is a pair of the source code pointer and message category for the method that was removed." class wantsChangeSetLogging ifFalse: [^ self]. (self changeRecorderFor: class) noteRemoveSelector: selector priorMethod: priorMethod lastMethodInfo: info ! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:00'! preambleString: aString "Establish aString as the new contents of the preamble. " self preamble: aString.! ! !ChangeSet methodsFor: 'method changes' stamp: 'sw 4/19/2001 19:45'! hasAnyChangeForSelector: aSelector "Answer whether the receiver has any change under the given selector, whether it be add, change, or remove, for any class" changeRecords do: [:aRecord | (aRecord changedSelectors includes: aSelector) ifTrue: [^ true]]. ^ false! ! !ChangeSet methodsFor: 'moving changes' stamp: 'MarcusDenker 2/20/2010 03:15'! methodsWithInitialsOtherThan: myInits "Return a collection of method refs whose author appears to be different from the given one" | slips | slips := OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | | method aTimeStamp | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [method := aClass compiledMethodAt: mAssoc key ifAbsent: [nil]. method ifNotNil: [((aTimeStamp := method timeStamp) notNil and: [(aTimeStamp beginsWith: myInits) not]) ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. ^ slips "Smalltalk browseMessageList: (ChangeSet current methodsWithInitialsOtherThan: 'sw') name: 'authoring problems'"! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:03'! postscriptString "Answer the string representing the postscript. " ^self postscript! ! !ChangeSet methodsFor: 'accessing' stamp: 'nice 1/5/2010 15:59'! methodChanges | methodChangeDict | methodChangeDict := Dictionary new. changeRecords associationsDo: [:assn | | changeTypes | changeTypes := assn value methodChangeTypes. changeTypes isEmpty ifFalse: [methodChangeDict at: assn key put: changeTypes]]. ^ methodChangeDict! ! !ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 12:00'! changedClassNames "Answer a OrderedCollection of the names of changed or edited classes. DOES include removed classes. Sort alphabetically." ^ changeRecords keysSortedSafely ! ! !ChangeSet methodsFor: 'filein/out' stamp: 'StephaneDucasse 5/28/2011 13:32'! lookForSlips "Scan the receiver for changes that the user may regard as slips to be remedied" | slips nameLine msg | nameLine := ' "', self name, '" '. (slips := self checkForSlips) size = 0 ifTrue: [^ self inform: 'No slips detected in change set', nameLine]. msg := slips size = 1 ifTrue: [ 'One method in change set', nameLine, 'has a halt, reference to the Transcript, and/or some other ''slip'' in it. Would you like to browse it? ?'] ifFalse: [ slips size printString, ' methods in change set', nameLine, 'have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?']. (UIManager default chooseFrom: #('Ignore' 'Browse slips') title: msg) = 2 ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ', name]! ! !ChangeSet methodsFor: 'class changes' stamp: 'nk 6/26/2002 12:30'! containsClass: aClass ^ self changedClasses includes: aClass! ! !ChangeSet methodsFor: 'method changes' stamp: 'sd 9/22/2011 17:55'! changedMessageList "Used by a message set browser to access the list view information." | messageList | messageList := OrderedCollection new. changeRecords associationsDo: [:clAssoc | | className classIsMeta | className := clAssoc key asSymbol. classIsMeta := (className findTokens: ' ') size > 1. (clAssoc value allChangeTypes includes: #comment) ifTrue: [messageList add: (RGCommentDefinition new parentName: className) asActive ]. clAssoc value methodChangeTypes associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [messageList add: ((RGMethodDefinition named: mAssoc key) parentName: className; isMetaSide: classIsMeta) asActive ]]]. ^ messageList asArray sort! ! !ChangeSet methodsFor: 'filein/out' stamp: 'StephaneDucasse 8/1/2011 17:15'! checkForUnsentMessages "Check the change set for unsent messages, and if any are found, open up a message-list browser on them" | nameLine allChangedSelectors augList unsent | nameLine := '"' , self name , '"'. allChangedSelectors := Set new. (augList := self changedMessageList) do: [:each | each isValid ifTrue: [allChangedSelectors add: each selector]]. unsent := self systemNavigation allUnsentMessagesIn: allChangedSelectors. unsent size = 0 ifTrue: [^ self inform: 'There are no unsent messages in change set ' , nameLine]. self systemNavigation browseMessageList: (augList select: [:each | unsent includes: each selector]) name: 'Unsent messages in ' , nameLine! ! !ChangeSet methodsFor: 'initialization' stamp: 'CamilloBruni 8/1/2012 16:10'! isMoribund "Answer whether the receiver is obsolete and about to die; part of an effort to get such guys cleared out from the change sorter." ^ name isNil! ! !ChangeSet methodsFor: 'method changes' stamp: 'Alexandre Bergel 11/21/2009 10:36'! atSelector: selector class: class put: changeType (self changeRecorderFor: class) atSelector: selector put: changeType. ! ! !ChangeSet methodsFor: 'printing' stamp: 'StephaneDucasse 5/13/2010 11:33'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' named ', self name! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:03'! postscript: aString "Answer the string representing the postscript. " postscript := aString! ! !ChangeSet methodsFor: 'testing' stamp: 'sw 8/3/1998 16:25'! okayToRemove ^ self okayToRemoveInforming: true! ! !ChangeSet methodsFor: 'initialization' stamp: 'sw 3/6/1999 09:31'! veryDeepCopyWith: deepCopier "Return self; this is NOT the way to launch new change sets!! Having this method here allows Change Sorters to be in parts bins"! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:00'! preamble: aString "Establish aString as the new contents of the preamble. " preamble := aString! ! !ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'! atClass: class includes: changeType ^(changeRecords at: class name ifAbsent: [^false]) includesChangeType: changeType! ! !ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 12:00'! classChangeAt: className "Return what we know about class changes to this class." ^ (changeRecords at: className ifAbsent: [^ Set new]) allChangeTypes! ! !ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:32'! removePreamble preamble := nil! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 14:14'! methodRecategorized: anEvent self reorganizeClass: anEvent methodClass! ! !ChangeSet methodsFor: 'change logging' stamp: 'MarcusDenker 7/22/2013 13:12'! renameClass: class from: oldName to: newName "Include indication that a class has been renamed." | recorder oldMetaClassName newMetaClassName | (recorder := self changeRecorderFor: oldName) noteChangeType: #rename; noteNewName: newName asSymbol. "store under new name (metaclass too)" changeRecords at: newName put: recorder. changeRecords removeKey: oldName. newMetaClassName := newName, ' class'. oldMetaClassName := oldName, ' class'. recorder := changeRecords at: oldMetaClassName ifAbsent: [^ nil]. changeRecords at: newMetaClassName put: recorder. changeRecords removeKey: oldMetaClassName. recorder noteNewName: newMetaClassName! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:00'! preambleString "Answer the string representing the preamble" ^self preamble! ! !ChangeSet methodsFor: 'moving changes' stamp: 'nice 10/20/2009 20:55'! methodsWithoutComments "Return a collection representing methods in the receiver which have no precode comments" | slips | slips := OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [(aClass includesSelector: mAssoc key) ifTrue: [(aClass firstPrecodeCommentFor: mAssoc key) isEmptyOrNil ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. ^ slips "Smalltalk browseMessageList: (ChangeSet current methodsWithoutComments) name: 'methods lacking comments'"! ! !ChangeSet methodsFor: 'initialization' stamp: 'di 4/1/2000 12:00'! clear "Reset the receiver to be empty. " changeRecords := Dictionary new. preamble := nil. postscript := nil! ! !ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'! oldNameFor: class ^ (changeRecords at: class name) priorName! ! !ChangeSet methodsFor: 'accessing' stamp: 'di 4/1/2000 12:00'! classRemoves ^ changeRecords keys select: [:className | (changeRecords at: className) isClassRemoval]! ! !ChangeSet methodsFor: 'moving changes' stamp: 'CamilloBruni 8/1/2012 16:15'! removeClassAndMetaClassChanges: class "Remove all memory of changes associated with this class and its metaclass." changeRecords removeKey: class name ifAbsent: []. changeRecords removeKey: class class name ifAbsent: []. ! ! !ChangeSet methodsFor: 'filein/out' stamp: 'MarcusDenker 8/25/2010 21:02'! fileOutPostscriptOn: stream "If the receiver has a postscript, put it out onto the stream. " | aString | aString := self postscriptString. (aString notNil and: [ aString size > 0 ]) ifTrue: [ stream nextChunkPut: aString. "surroundedBySingleQuotes" stream cr; cr ]! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:03'! postscriptString: aString "Establish aString as the new contents of the postscript. " self postscript: aString! ! !ChangeSet methodsFor: 'method changes' stamp: 'di 4/4/2000 11:14'! removeSelectorChanges: selector class: class "Remove all memory of changes associated with the argument, selector, in this class." | chgRecord | (chgRecord := changeRecords at: class name ifAbsent: [^ self]) removeSelector: selector. chgRecord hasNoChanges ifTrue: [changeRecords removeKey: class name]! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 3/23/2000 11:52'! absorbMethod: selector class: aClass from: aChangeSet "Absorb into the receiver all the changes for the method in the class in the other change set." | info | info := aChangeSet methodChanges at: aClass name ifAbsent: [Dictionary new]. self atSelector: selector class: aClass put: (info at: selector). ! ! !ChangeSet methodsFor: 'moving changes' stamp: 'MarcusDenker 7/22/2013 13:12'! removeClassChanges: class "Remove all memory of changes associated with this class" | cname | (class isString) ifTrue: [ cname := class ] ifFalse: [ cname := class name ]. changeRecords removeKey: cname ifAbsent: [].! ! !ChangeSet methodsFor: 'initialization' stamp: 'CamilloBruni 8/1/2012 16:18'! wither "The receiver is to be clobbered. Clear it out." self clear. name := nil! ! !ChangeSet methodsFor: 'filein/out' stamp: 'nk 10/15/2003 09:55'! defaultChangeSetDirectory ^self class defaultChangeSetDirectory! ! !ChangeSet methodsFor: 'moving changes' stamp: 'MarcusDenker 7/22/2013 13:12'! forgetChangesForClass: className in: otherChangeSet "See forgetAllChangesFoundIn:. Used in culling changeSets." (self changeRecorderFor: className) forgetChangesIn: (otherChangeSet changeRecorderFor: className). ! ! !ChangeSet methodsFor: 'accessing' stamp: 'ar 7/16/2005 18:59'! editPostscript "edit the receiver's postscript, in a separate window. " self assurePostscriptExists. UIManager default edit: self postscript label: 'Postscript for ChangeSet named ', name accept:[:aString| self postscript: aString].! ! !ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:27'! hasPreamble ^ preamble notNil! ! !ChangeSet methodsFor: 'filein/out' stamp: 'sd 4/16/2003 09:16'! checkForUnclassifiedMethods "Open a message list browser on all methods in the current change set that have not been categorized," | aList | (aList := self methodsWithoutClassifications) size > 0 ifFalse: [^ self inform: 'All methods in "', self name, '" are categorized.'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" which have not been categorized']! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ClementBera 7/26/2013 16:07'! assurePostscriptExists "Make sure there is a StringHolder holding the postscript. " "NOTE: FileIn recognizes the postscript by the line with Postscript: on it" postscript ifNil: [ postscript := '"Postscript: Leave the line above, and replace the rest of this comment by a useful one. Executable statements should follow this comment, and should be separated by periods, with no exclamation points (!!). Be sure to put any further comments in double-quotes, like this one." ' ]! ! !ChangeSet methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:42'! author | author | self assurePreambleExists. author := self preambleString lineNumber: 3. author := author copyFrom: 8 to: author size. "Strip the 'Author:' prefix. Ugly ugly." ^ author trimBoth! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 11:21'! assimilateAllChangesFoundIn: otherChangeSet "Make all changes in otherChangeSet take effect on self as if they happened just now." otherChangeSet changedClassNames do: [:className | self absorbClass: className from: otherChangeSet] ! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:25'! classRemoved: anEvent self noteRemovalOf: anEvent classRemoved.! ! !ChangeSet methodsFor: 'moving changes' stamp: 'MarcusDenker 7/22/2013 13:11'! absorbClass: className from: otherChangeSet "Absorb into the receiver all the changes found in the class in the other change set. *** Classes renamed in otherChangeSet may have problems" (self changeRecorderFor: className) assimilateAllChangesIn: (otherChangeSet changeRecorderFor: className). ! ! !ChangeSet methodsFor: 'class changes' stamp: ''! reorganizeClass: class "Include indication that a class was reorganized." self atClass: class add: #reorganize! ! !ChangeSet methodsFor: 'filein/out' stamp: 'StephaneDucasse 6/11/2012 18:09'! fileOut "File out the receiver, to a file whose name is a function of the change-set name and a unique numeric tag." | slips nameToUse | ChangeSet promptForDefaultChangeSetDirectoryIfNecessary. nameToUse := (self defaultChangeSetDirectory / self name , 'cs') nextVersion basename. Cursor write showWhile: [ | internalStream | internalStream := (String new: 10000) writeStream. internalStream header; timeStamp. self fileOutPreambleOn: internalStream. self fileOutOn: internalStream. self fileOutPostscriptOn: internalStream. internalStream trailer. FileStream writeSourceCodeFrom: internalStream baseName: (nameToUse copyFrom: 1 to: nameToUse size - 3) isSt: false. ]. self class mustCheckForSlips ifFalse: [^ self]. slips := self checkForSlips. (slips size > 0 and: [self confirm: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?' translated]) ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name]! ! !ChangeSet methodsFor: 'testing' stamp: 'nice 1/5/2010 15:59'! methodsWithoutClassifications "Return a collection representing methods in the receiver which have not been categorized" | slips notClassified | notClassified := {'as yet unclassified' asSymbol. #all}. slips := OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | | aSelector | (aClass includesSelector: (aSelector := mAssoc key)) ifTrue: [(notClassified includes: (aClass organization categoryOfElement: aSelector)) ifTrue: [slips add: aClass name , ' ' , aSelector]]]]. ^ slips "Smalltalk browseMessageList: (ChangeSet current methodsWithoutClassifications) name: 'unclassified methods'"! ! !ChangeSet methodsFor: 'private' stamp: 'di 3/23/2000 08:37'! addCoherency: className "SqR!! 19980923: If I recreate the class then don't remove it" (self changeRecorderFor: className) checkCoherence. " classRemoves remove: className ifAbsent: []. (classChanges includesKey: className) ifTrue: [(classChanges at: className) remove: #remove ifAbsent: []] "! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'StephaneDucasse 12/19/2012 10:50'! newChanges: aChangeSet "Set the system ChangeSet to be the argument, aChangeSet." "pay attention not to use newChanges in current and other methods to avoid infinite cycles." self newChanges: aChangeSet withOld: self current. ! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'CamilloBruni 8/1/2012 16:11'! named: aName "Return the change set of the given name, or nil if none found." ^ AllChangeSets detect: [:aChangeSet | aChangeSet name = aName] ifNone: [nil]! ! !ChangeSet class methodsFor: '*System-FileRegistry' stamp: 'ar 7/15/2005 21:36'! services ^ Array with: self serviceFileIntoNewChangeSet! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:22'! allChangeSetsWithClass: class selector: selector class ifNil: [^ #()]. ^ self allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]! ! !ChangeSet class methodsFor: 'filein/out' stamp: 'StephaneDucasse 3/31/2010 16:57'! fileOutChangeSetsNamed: nameList "File out the list of change sets whose names are provided" "ChangesOrganizer fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')" | notFound empty infoString | notFound := OrderedCollection new. empty := OrderedCollection new. nameList do: [:aName | | aChangeSet | (aChangeSet := self named: aName) ifNotNil: [aChangeSet isEmpty ifTrue: [empty add: aName] ifFalse: [aChangeSet fileOut]] ifNil: [notFound add: aName]]. infoString := (nameList size - notFound size) printString, ' change set(s) filed out'. notFound size > 0 ifTrue: [infoString := infoString, ' ', notFound size printString, ' change set(s) not found:'. notFound do: [:aName | infoString := infoString, ' ', aName]]. empty size > 0 ifTrue: [infoString := infoString, ' ', empty size printString, ' change set(s) were empty:'. empty do: [:aName | infoString := infoString, ' ', aName]]. self inform: infoString! ! !ChangeSet class methodsFor: 'initialization' stamp: 'ClementBera 7/26/2013 16:13'! initialize "ChangeSet initialize" AllChangeSets ifNil: [ AllChangeSets := OrderedCollection new ]. self gatherChangeSets. FileServices registerFileReader: self! ! !ChangeSet class methodsFor: 'scanning' stamp: 'MartinDias 11/6/2013 16:32'! scanVersionsOf: aMethod class: aClass meta: isMeta category: aCategory selector: aSelector | changeRecords | changeRecords := OrderedCollection new. SourceFiles changeRecordsFrom: aMethod sourcePointer className: aClass name isMeta: isMeta do: [ :changeRecord | changeRecords add: changeRecord ]. ^ changeRecords! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:29'! mostRecentChangeSetWithChangeForClass: class selector: selector | hits | hits := self allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]. hits isEmpty ifTrue: [^ 'not in any change set']. ^ 'recent cs: ', hits last name! ! !ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:31'! newChangeSet "Prompt the user for a name, and establish a new change set of that name (if ok), making it the current changeset. Return nil of not ok, else return the actual changeset." | newName newSet | newName := UIManager default request: 'Please name the new change set:' initialAnswer: ChangeSet defaultName. newName isEmptyOrNil ifTrue: [^ nil]. newSet := self basicNewChangeSet: newName. newSet ifNotNil: [self newChanges: newSet]. ^ newSet! ! !ChangeSet class methodsFor: 'settings' stamp: 'AlainPlantec 12/18/2009 14:14'! defaultChangeSetDirectoryName: aName DefaultChangeSetDirectoryName := aName! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:11'! changeSetsNamedSuchThat: nameBlock "(ChangeSet changeSetsNamedSuchThat: [:name | name first isDigit and: [name initialInteger >= 373]]) do: [:cs | AllChangeSets remove: cs wither]" ^ AllChangeSets select: [:aChangeSet | nameBlock value: aChangeSet name]! ! !ChangeSet class methodsFor: 'settings' stamp: 'AlainPlantec 12/7/2009 10:58'! mustCheckForSlips: aBoolean MustCheckForSlips := aBoolean! ! !ChangeSet class methodsFor: 'defaults' stamp: 'lr 3/12/2010 22:16'! uniqueNameLike: aString | try index | (self named: aString) ifNil: [ ^ aString ]. index := 1. [ try := aString , index printString. (self named: try) ifNil: [ ^ try ]. index := index + 1 ] repeat ! ! !ChangeSet class methodsFor: '*System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:21'! fileReaderServicesForFile: fullName suffix: suffix ^ (FileStream isSourceFileSuffix: suffix) ifTrue: [ self services] ifFalse: [#()]! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'StephaneDucasse 3/29/2010 16:06'! existingOrNewChangeSetNamed: aName | newSet | ^(self named: aName) ifNil: [ newSet := self basicNewNamed: aName. AllChangeSets add: newSet. newSet]! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:26'! removeChangeSetsNamedSuchThat: nameBlock (self changeSetsNamedSuchThat: nameBlock) do: [:cs | self removeChangeSet: cs]! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:20'! allChangeSetNames ^ self allChangeSets collect: [:c | c name]! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'StephaneDucasse 12/19/2012 10:47'! newChanges: aChangeSet withOld: old "Set the system ChangeSet to be the argument, aChangeSet." SystemAnnouncer uniqueInstance unsubscribe: old. current := aChangeSet. SystemAnnouncer uniqueInstance private weak on: ClassRemoved send: #classRemoved: to: aChangeSet; on: ClassAdded send: #classAdded: to: aChangeSet; on: ClassCommented send: #classCommented: to: aChangeSet; on: ClassRenamed send: #classRenamed: to: aChangeSet; on: ClassReorganized send: #classReorganized: to: aChangeSet; on: ClassRecategorized send: #classRecategorized: to: aChangeSet; on: ClassModifiedClassDefinition send: #classModified: to: aChangeSet. SystemAnnouncer uniqueInstance private weak on: MethodAdded send: #methodAdded: to: aChangeSet; on: MethodModified send: #methodModified: to: aChangeSet; on: MethodRemoved send: #methodRemoved: to: aChangeSet; on: MethodRecategorized send: #methodRecategorized: to: aChangeSet. SystemAnnouncer uniqueInstance announce: (CurrentChangeSetChanged new old: old; new: aChangeSet ; yourself). ! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'nice 1/5/2010 15:59'! gatherChangeSets "ChangeSet gatherChangeSets" "Collect any change sets created in other projects" | allChangeSets | allChangeSets := AllChangeSets asSet. ChangeSet allSubInstances do: [:each | | obsolete | (allChangeSets includes: each) == (obsolete := each isMoribund) ifTrue:[ obsolete ifTrue: ["Was included and is obsolete." AllChangeSets remove: each] ifFalse: ["Was not included and is not obsolete." AllChangeSets add: each]]]. ^ AllChangeSets! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'StephaneDucasse 3/23/2010 22:28'! removeEmptyUnnamedChangeSets "Remove all change sets that are empty, whose names start with Unnamed." "ChangeSet removeEmptyUnnamedChangeSets" | toGo | (toGo := (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed']) select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]]) do: [:cs | self removeChangeSet: cs]. self inform: toGo size printString, ' change set(s) removed.'! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:17'! allChangeSets: aCollection "Return the list of all current ChangeSets" AllChangeSets := aCollection.! ! !ChangeSet class methodsFor: 'filein/out' stamp: 'MarcusDenker 5/8/2013 19:28'! traitsOrder: aCollection "Arrange the traits in the collection, first who don't depend on others." | unprocessed | unprocessed := aCollection asSet. ^ Array new: unprocessed size streamContents: [ :stream | unprocessed size timesRepeat: [ | aTrait | aTrait := unprocessed detect: [ :each | self hasNoDependenciesFor: each in: unprocessed ]. stream nextPut: aTrait. unprocessed remove: aTrait] ]! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'MarcusDenker 7/16/2013 11:32'! current "return the current changeset assure first that we have a named changeset." (current isNil or: [current isMoribund]) ifTrue: [self newChanges: (self assuredChangeSetNamed: 'Unnamed') withOld: current] . ^ current! ! !ChangeSet class methodsFor: '*System-FileRegistry' stamp: 'tbn 8/11/2010 10:11'! serviceFileIntoNewChangeSet "Answer a service for installing a file into a new change set" ^ SimpleServiceEntry provider: self label: 'Install into new change set' selector: #fileIntoNewChangeSet: description: 'Install the file as a body of code in the image: create a new change set and file-in the selected file into it' buttonLabel: 'Install'! ! !ChangeSet class methodsFor: 'services' stamp: 'MarcusDenker 10/3/2013 23:44'! assuredChangeSetNamed: aName "Answer a change set of the given name. If one already exists, answer that, else create a new one and answer it." ^ (self named: aName) ifNotNil: [:existing | existing] ifNil: [self basicNewChangeSet: aName]! ! !ChangeSet class methodsFor: 'services' stamp: 'StephaneDucasse 3/30/2010 23:03'! reorderChangeSets "Change the order of the change sets to something more convenient: First come all numbered updates. Next come all remaining changesets" "self reorderChangeSets" | newMid newTail | newMid := OrderedCollection new. newTail := OrderedCollection new. self allChangeSets do: [:aChangeSet | aChangeSet isNumbered ifTrue: [newMid add: aChangeSet] ifFalse: [newTail add: aChangeSet]]. self allChangeSets: newMid, newTail. ! ! !ChangeSet class methodsFor: 'settings' stamp: 'AlainPlantec 12/7/2009 10:58'! mustCheckForSlips ^ MustCheckForSlips ifNil: [MustCheckForSlips := true]! ! !ChangeSet class methodsFor: 'defaults' stamp: 'dgd 9/6/2003 19:56'! defaultName ^ self uniqueNameLike: 'Unnamed' translated! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 22:18'! noChanges "Initialize the system ChangeSet." current initialize! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:10'! allChangeSets "Return the list of all current ChangeSets" ^ AllChangeSets! ! !ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:38'! doesAnyChangeSetHaveClass: aClass andSelector: aSelector "Answer whether any known change set bears a change for the given class and selector" ^ (self countOfChangeSetsWithClass: aClass andSelector: aSelector) > 0! ! !ChangeSet class methodsFor: 'instance creation' stamp: 'di 4/6/2001 09:43'! basicNewNamed: aName ^ (self basicNew name: aName) initialize! ! !ChangeSet class methodsFor: 'filein/out' stamp: 'MarianoMartinezPeck 9/3/2012 12:36'! hasNoDependenciesFor: aTrait in: traits "Answer if the trait does not depend on a trait in the collection." ^ traits allSatisfy: [ :another | aTrait == another or: [ "are the same" aTrait ~= another classSide and: [ "is not the classTrait of another" (aTrait traitComposition allTraits includes: another) not ] ] ]! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:14'! basicNewChangeSet: newName | newSet | newName ifNil: [^ nil]. (self named: newName) ifNotNil: [self inform: 'Sorry that name is already used'. ^ nil]. newSet := self basicNewNamed: newName. AllChangeSets add: newSet. ^ newSet! ! !ChangeSet class methodsFor: 'cleanup' stamp: 'MarcusDenker 2/22/2012 12:54'! cleanUp: aggressive "Only delete change sets when being aggressive" aggressive ifTrue: [ ChangeSet removeChangeSetsNamedSuchThat: [ :each | true ]. ChangeSet resetCurrentToNewUnnamedChangeSet.].! ! !ChangeSet class methodsFor: 'scanning' stamp: 'MarcusDenker 5/18/2013 15:44'! scanCategory: file "Scan anything that involves more than one chunk; method name is historical only" | itemPosition item tokens stamp isComment anIndex | itemPosition := file position. item := file nextChunk. isComment := (item includesSubstring: 'commentStamp:'). (isComment or: [item includesSubstring: 'methodsFor:']) ifFalse: ["Maybe a preamble, but not one we recognize; bail out with the preamble trick" ^{(ChangeRecord new file: file position: itemPosition type: #preamble)}]. tokens := item parseLiterals. tokens size >= 3 ifTrue: [stamp := ''. anIndex := tokens indexOf: #stamp: ifAbsent: [nil]. anIndex ifNotNil: [stamp := tokens at: (anIndex + 1)]. tokens second == #methodsFor: ifTrue: [^ self scanFile: file category: tokens third class: tokens first meta: false stamp: stamp]. tokens third == #methodsFor: ifTrue: [^ self scanFile: file category: tokens fourth class: tokens first meta: true stamp: stamp]]. tokens second == #commentStamp: ifTrue: [stamp := tokens third. item := (ChangeRecord new file: file position: file position type: #classComment class: tokens first category: nil meta: false stamp: stamp). file nextChunk. file skipStyleChunk. ^Array with: item]. ^#()! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:13'! promoteToTop: aChangeSet "Make aChangeSet the first in the list from now on" AllChangeSets remove: aChangeSet ifAbsent: [^ self]. AllChangeSets add: aChangeSet! ! !ChangeSet class methodsFor: 'services' stamp: 'CamilloBruni 5/4/2012 21:29'! newChangeSet: aName "Makes a new change set called aName, add author full name to try to ensure a unique change set name." | newName | newName := aName , '.' , Author fullName. ^ self basicNewChangeSet: newName! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:13'! removeChangeSet: aChangeSet "Remove the given changeSet. Caller must assure that it's cool to do this" AllChangeSets remove: aChangeSet ifAbsent: []. aChangeSet wither ! ! !ChangeSet class methodsFor: 'services' stamp: 'StephaneDucasse 8/12/2013 15:25'! newChangesFromStream: aStream named: aName "File in the code from the stream into a new change set whose name is derived from aName. Leave the 'current change set' unchanged. Return the new change set or nil on failure." | oldChanges newName newSet | oldChanges := ChangeSet current. newName := aName withoutPeriodSuffix. newSet := self basicNewChangeSet: newName. [ | newStream | newSet ifNotNil:[ (aStream respondsTo: #converter:) ifFalse: [ newStream := MultiByteBinaryOrTextStream with: (aStream contentsOfEntireFile). newStream reset.] ifTrue: [newStream := aStream]. self newChanges: newSet. newStream setConverterForCode. CodeImporter evaluateReadStream: newStream readStream]. aStream close] ensure: [self newChanges: oldChanges]. ^ newSet! ! !ChangeSet class methodsFor: 'scanning' stamp: 'SeanDeNigris 6/21/2012 08:45'! scanFile: file from: startPosition to: stopPosition | changeList | changeList := OrderedCollection new. file position: startPosition. 'Scanning ', file localName, '...' displayProgressFrom: startPosition to: stopPosition during: [:bar | | prevChar itemPosition item | [file position < stopPosition] whileTrue:[ bar current: file position. [file atEnd not and: [file peek isSeparator]] whileTrue: [prevChar := file next]. (file peekFor: $!!) ifTrue:[ (prevChar = Character cr or: [prevChar = Character lf]) ifTrue: [changeList addAll: (self scanCategory: file)]. ] ifFalse:[ itemPosition := file position. item := file nextChunk. file skipStyleChunk. item size > 0 ifTrue:[ changeList add: (ChangeRecord new file: file position: itemPosition type: #doIt). ]. ]. ]]. ^changeList! ! !ChangeSet class methodsFor: 'services' stamp: 'CamilloBruni 5/7/2012 02:10'! fileIntoNewChangeSet: fullName "File in all of the contents of the currently selected file, if any, into a new change set." | fn ff | fullName ifNil: [^ Beeper beep]. fn := (Smalltalk hasClassNamed: #GZipReadStream) ifTrue: [(Smalltalk classNamed: #GZipReadStream) uncompressedFileName: fullName] ifFalse: [fullName]. [ ff := FileStream readOnlyFileNamed: fn. self newChangesFromStream: ff named: (fn asFileReference basename)] ensure: [ff ifNotNil: [ff close]]! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'sd 9/8/2006 21:05'! resetCurrentToNewUnnamedChangeSet current := self new. self newChanges: current ! ! !ChangeSet class methodsFor: 'defaults' stamp: 'CamilloBruni 5/7/2012 01:08'! defaultChangeSetDirectory "Answer the directory in which to store ChangeSets. Answer the default directory if the preferred directory doesn't exist." | dir directoryName | directoryName := self defaultChangeSetDirectoryName. dir := directoryName isEmptyOrNil ifTrue: [ FileSystem workingDirectory ] ifFalse: [ FileSystem workingDirectory / directoryName ]. dir exists ifTrue: [^ dir]. ^ FileSystem workingDirectory! ! !ChangeSet class methodsFor: 'system-events' stamp: 'GuillermoPolito 7/31/2012 11:59'! registerInterestToSystemAnnouncer self newChanges: self current.! ! !ChangeSet class methodsFor: 'filein/out' stamp: 'MarcusDenker 5/8/2013 19:26'! classesOrder: classes "Answer a collection with the classes ordered so they can be filed in." | listInOrder | "SharedPools need to go first" listInOrder := Class superclassOrder: (classes select: [ :each | each inheritsFrom: SharedPool ]). listInOrder addAll: (Class superclassOrder: (classes reject: [ :each | each inheritsFrom: SharedPool ])). ^ listInOrder! ! !ChangeSet class methodsFor: 'defaults' stamp: 'S 6/17/2013 13:26'! promptForDefaultChangeSetDirectoryIfNecessary "Check the Preference (if any), and prompt the user to change it if necessary. The default if the Preference is unset is the current directory. Answer the directory." "ChangeSet promptForDefaultChangeSetDirectoryIfNecessary" | choice directoryPath dir message | directoryPath := self defaultChangeSetDirectoryName. [dir := directoryPath asFileReference. dir exists] whileFalse: [message := 'The preferred change set directory' translated , ' (''{1}'') ' , 'does not exist.' translated , ' ' , 'Create it or use the default directory' translated , ' ({2})?' format: {directoryPath. FileSystem workingDirectory fullName}. choice := UIManager default chooseFrom: (#('Create directory' 'Use default directory and forget preference' 'Choose another directory' ) collect: [:ea | ea translated]) message: message. choice = 1 ifTrue: [dir ensureCreateDirectory ]. choice = 3 ifTrue: [dir := UIManager default chooseDirectory. directoryPath := dir ifNil: [''] ifNotNil: [dir pathName]]]. self defaultChangeSetDirectory: directoryPath. ^ dir! ! !ChangeSet class methodsFor: 'instance creation' stamp: 'ar 7/16/2005 15:17'! new "All current changeSets must be registered in the AllChangeSets collection. Due to a quirk of history, this is maintained as class variable of ChangeSorter." ^ self basicNewChangeSet: ChangeSet defaultName! ! !ChangeSet class methodsFor: 'scanning' stamp: 'ar 7/16/2005 15:11'! scanFile: file category: cat class: class meta: meta stamp: stamp | itemPosition method items | items := OrderedCollection new. [itemPosition := file position. method := file nextChunk. file skipStyleChunk. method size > 0] whileTrue:[ items add: (ChangeRecord new file: file position: itemPosition type: #method class: class category: cat meta: meta stamp: stamp)]. ^items! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:13'! secondaryChangeSet "Answer a likely change set to use as the second initial one in a Dual Change Sorter. " AllChangeSets size = 1 ifTrue: [^ AllChangeSets first]. AllChangeSets last == ChangeSet current ifTrue: [^ AllChangeSets at: (AllChangeSets size - 1)] ifFalse: [^ AllChangeSets last]! ! !ChangeSet class methodsFor: 'defaults' stamp: 'StephaneDucasse 6/11/2012 17:53'! defaultChangeSetDirectory: dirOrName "Set the Preference for storing change sets to the given directory or name (possibly relative). Rewrite directory names below the default directory as relative names. If dirOrName is an empty string, use the default directory." "ChangeSet defaultChangeSetDirectory: 'changeSets'" | dirName defaultFullName | dirName := dirOrName isString ifTrue: [ dirOrName asFileReference fullName ] ifFalse: [dirOrName fullName]. defaultFullName := FileSystem workingDirectory fullName. dirName = defaultFullName ifTrue: [dirName := ''] ifFalse: [ (dirName beginsWith: defaultFullName , FileSystem disk delimiter asString) ifTrue: [dirName := dirName copyFrom: defaultFullName size + 2 to: dirName size]]. self defaultChangeSetDirectoryName: dirName! ! !ChangeSet class methodsFor: 'services' stamp: 'ar 7/15/2005 21:37'! countOfChangeSetsWithClass: aClass andSelector: aSelector "Answer how many change sets record a change for the given class and selector" ^ (self allChangeSetsWithClass: aClass selector: aSelector) size! ! !ChangeSet class methodsFor: 'settings' stamp: 'StephaneDucasse 6/11/2012 18:04'! defaultChangeSetDirectoryName ^ DefaultChangeSetDirectoryName ifNil: [DefaultChangeSetDirectoryName := '.']! ! !ChangeSetClassChangesTest commentStamp: 'dtl 2/19/2005 13:21'! Class category changes are not being properly added to the default changeset in Squeak 3.7. This test case will pass in Squeak 3.6, and fail in Squeak 3.[7-9]. ! !ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'lr 3/14/2010 21:13'! testChangeClassCategory "Changing the class category for a class should result in a change record being added to the current change set." | saveClassDefinition | "Define a class and save its definition" Object subclass: #JunkClass instanceVariableNames: 'zzz' classVariableNames: '' poolDictionaries: '' category: 'DeleteMe-1'. saveClassDefinition := (Smalltalk globals classNamed: #JunkClass) definition. self assert: saveClassDefinition = (ChangeSet current fatDefForClass: (Smalltalk globals classNamed: #JunkClass)). "Redefine the class, changing only the class category" Object subclass: #JunkClass instanceVariableNames: 'zzz' classVariableNames: '' poolDictionaries: '' category: 'DeleteMe-2'. "Assert that the class definition has changed" self deny: (self isDefinition: (Smalltalk globals classNamed: #JunkClass) definition equivalentTo: saveClassDefinition). self deny: (self isDefinition: saveClassDefinition equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk globals classNamed: #JunkClass))). self assert: (self isDefinition: (Smalltalk globals classNamed: #JunkClass) definition equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk globals classNamed: #JunkClass))). "Assert that the change has been recorded in the current change set" self assert: (self isDefinition: (ChangeSet current changeRecorderFor: (Smalltalk globals classNamed: #JunkClass)) priorDefinition equivalentTo: 'Object subclass: #JunkClass instanceVariableNames: ''zzz '' classVariableNames: '''' poolDictionaries: '''' category: ''DeleteMe-2''')! ! !ChangeSetClassChangesTest methodsFor: 'support' stamp: 'dtl 2/19/2005 13:08'! isDefinition: firstString equivalentTo: secondString "When a class definition is reconstructed with #fatDefForClass, it may contain extra trailing space characters in parts of the definition. This is probably a minor bug, but it should be overlooked for purposes of testing the change set update mechanism. The expedient here is to just remove spaces before comparing the definition strings." ^ firstString notNil and: [(firstString copyReplaceAll: ' ''' with: '''') = (secondString copyReplaceAll: ' ''' with: '''')]! ! !ChangeSetClassChangesTest methodsFor: 'running' stamp: 'lr 3/14/2010 21:13'! tearDown (Smalltalk globals classNamed: #JunkClass) ifNotNil: [ :c | c removeFromSystem: true ]. SystemOrganization removeCategory: #'DeleteMe-1'. SystemOrganization removeCategory: #'DeleteMe-2'. ChangeSet current removeClassChanges: 'JunkClass'! ! !ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'lr 3/14/2010 21:13'! testAddInstanceVariable "Adding an instance variable to the class should result in a change record being added to the current change set." | saveClassDefinition | "Define a class and save its definition" Object subclass: #JunkClass instanceVariableNames: 'zzz' classVariableNames: '' poolDictionaries: '' category: 'DeleteMe-1'. saveClassDefinition := (Smalltalk globals classNamed: #JunkClass) definition. self assert: (self isDefinition: saveClassDefinition equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk globals classNamed: #JunkClass))). "Redefine the class, adding one instance variable" Object subclass: #JunkClass instanceVariableNames: 'zzz aaa' classVariableNames: '' poolDictionaries: '' category: 'DeleteMe-1'. "Assert that the class definition has changed" self deny: (self isDefinition: (Smalltalk globals classNamed: #JunkClass) definition equivalentTo: saveClassDefinition). self deny: (self isDefinition: saveClassDefinition equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk globals classNamed: #JunkClass))). self assert: (self isDefinition: (Smalltalk globals classNamed: #JunkClass) definition equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk globals classNamed: #JunkClass))). "Assert that the change has been recorded in the current change set" self assert: (self isDefinition: (ChangeSet current changeRecorderFor: (Smalltalk globals classNamed: #JunkClass)) priorDefinition equivalentTo: saveClassDefinition)! ! !ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'lr 3/14/2010 21:13'! testAddInstanceVariableAddsNewChangeRecord "Changing the class category for a class should result in a change record being updated in the current change set." "At the start of this test, JunkClass should not exist, and there should be no change records pertaining to it in the change set." self deny: (Smalltalk hasClassNamed: 'JunkClass'). self assert: (ChangeSet current changeRecorderFor: (Smalltalk globals classNamed: #JunkClass)) thisName = 'nil'. "Remove bogus change records created as side effect of preceding assert" ChangeSet current removeClassChanges: 'nil'. "Define a class and save its definition" Object subclass: #JunkClass instanceVariableNames: 'zzz' classVariableNames: '' poolDictionaries: '' category: 'DeleteMe-1'. "Forget about JunkClass in the change set" ChangeSet current removeClassChanges: 'JunkClass'. "Redefine the class, adding one instance variable" Object subclass: #JunkClass instanceVariableNames: 'zzz aaa' classVariableNames: '' poolDictionaries: '' category: 'DeleteMe-1'. "A change record should now exist in the change set" self assert: (self isDefinition: (ChangeSet current changeRecorderFor: (Smalltalk globals classNamed: #JunkClass)) priorDefinition equivalentTo: 'Object subclass: #JunkClass instanceVariableNames: ''zzz '' classVariableNames: '''' poolDictionaries: '''' category: ''DeleteMe-1''')! ! !ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'lr 3/14/2010 21:13'! testChangeClassCategoryAddsNewChangeRecord "Changing the class category for a class should result in a change record being updated in the current change set." "At the start of this test, JunkClass should not exist, and there should be no change records pertaining to it in the change set." self deny: (Smalltalk hasClassNamed: 'JunkClass'). self assert: (ChangeSet current changeRecorderFor: (Smalltalk globals classNamed: #JunkClass)) thisName = 'nil'. "Remove bogus change records created as side effect of preceding assert" ChangeSet current removeClassChanges: 'nil'. "Define a class and save its definition" Object subclass: #JunkClass instanceVariableNames: 'zzz' classVariableNames: '' poolDictionaries: '' category: 'DeleteMe-1'. "Forget about JunkClass in the change set" ChangeSet current removeClassChanges: 'JunkClass'. "Redefine the class, changing only the class category" Object subclass: #JunkClass instanceVariableNames: 'zzz' classVariableNames: '' poolDictionaries: '' category: 'DeleteMe-2'. "A change record should now exist in the change set" self assert: (self isDefinition: (ChangeSet current changeRecorderFor: (Smalltalk globals classNamed: #JunkClass)) priorDefinition equivalentTo: 'Object subclass: #JunkClass instanceVariableNames: ''zzz '' classVariableNames: '''' poolDictionaries: '''' category: ''DeleteMe-2''')! ! !ChangeSetClassChangesTest methodsFor: 'testing' stamp: 'wiz 8/13/2006 17:55'! testInitialChangeSet "Run this to assure the initial changeset is named. Checks bug found in 3.9 7052." "self new testInitialChangeSet" "self run: #testInitialChangeSet" self deny: (ChangeSet current printString = 'a ChangeSet named ') . ^true! ! !ChangeSorterApplication commentStamp: ''! A ChangeSorterApplication is spec version of the dual sorter. ChangeSorterApplication new openWithSpec! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! setSelectedClass: aClass ^ classesListModel setSelectedItem: aClass! ! !ChangeSorterApplication methodsFor: 'menu - class' stamp: ''! fileOutClass self model fileOutClass: self selectedClass from: self selectedChangeSet! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: 'StephaneDucasse 11/2/2012 16:06'! updateChangesList | sel | sel := self selectedChangeSet. changesListModel items: self model allChanges. changesListModel setSelectedItem: sel.! ! !ChangeSorterApplication methodsFor: 'accessing' stamp: ''! methodsListModel ^ methodsListModel! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! removePostscript self model removePostscriptFrom: self selectedChangeSet. changesListModel setSelectedItem: self selectedChangeSet! ! !ChangeSorterApplication methodsFor: 'menu - message' stamp: ''! browseVersions "Create and schedule a changelist browser on the versions of the selected message." self selectedClass ifNotNil: [:class | self selectedSelector ifNotNil: [:selector || method | method := class methodDict at: selector ifAbsent: [ ^ self inform: 'Sorry, only actual methods have retrievable versions.' ]. self model browseVersionsFrom: method ]]! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! methodsMenu: aBlock methodsListModel menu: aBlock! ! !ChangeSorterApplication methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 13:10'! changeSetMenu2: aMenu shifted: isShifted "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" aMenu addAllFromPragma: 'changeSorterChangeSetList2Menu' target: self. ^aMenu ! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! selectedClassIndex ^ classesListModel selectedIndex! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! rename | set | set := self model rename: self selectedChangeSet. changesListModel updateList; setSelectedItem: set! ! !ChangeSorterApplication methodsFor: 'initialization' stamp: 'EstebanLorenzano 9/8/2013 16:06'! initialize prettyPrint := false. showDiff := false. model := ChangeSorterModel new. SystemAnnouncer uniqueInstance weak when: CurrentChangeSetChanged send: #updateTitle to: self. super initialize. self initializeAnnouncements. ! ! !ChangeSorterApplication methodsFor: 'initialization' stamp: 'StephaneDucasse 5/17/2012 19:32'! registerSelectorActions methodsListModel whenSelectedItemChanged: [:selector | self updateTextContents ]! ! !ChangeSorterApplication methodsFor: 'protocol-events' stamp: 'StephaneDucasse 5/17/2012 19:31'! whenChangesListChanges: aBlock changesListModel whenListChanged: aBlock! ! !ChangeSorterApplication methodsFor: 'initialization' stamp: 'StephaneDucasse 11/2/2012 16:05'! initializeAnnouncements SystemAnnouncer uniqueInstance weak on: ClassAdded , ClassCommented , ClassRecategorized , ClassModifiedClassDefinition , ClassRemoved , ClassRenamed , ClassReorganized , MethodAdded , MethodModified , MethodRecategorized , MethodRemoved , ProtocolAdded , ProtocolRemoved send: #updateClassesList to: self! ! !ChangeSorterApplication methodsFor: 'accessing' stamp: ''! textModel ^ textModel! ! !ChangeSorterApplication methodsFor: 'initialization' stamp: 'StephaneDucasse 11/2/2012 14:44'! registerChangeActions changesListModel whenSelectedItemChanged: [:change | classesListModel resetSelection. self updateTextContents. change ifNil: [ classesListModel items: {}. methodsListModel items: {}. ] ifNotNil: [ classesListModel items: (change changedClasses sort: [:a :b | a name < b name ]). ]]. ! ! !ChangeSorterApplication methodsFor: 'shortcuts' stamp: 'GuillermoPolito 8/5/2013 10:21'! registerMethodShortcuts: aWidget aWidget bindKeyCombination: $b command toAction: [ self selectedSelector ifNotNil:[ self browseMethodFull ]]. aWidget bindKeyCombination: $d command toAction: [ self selectedSelector ifNotNil:[ self forgetMessage ]]. aWidget bindKeyCombination: $m command toAction: [ self selectedSelector ifNotNil:[ self browseImplementorsOfMessages ]]. aWidget bindKeyCombination: $n command toAction: [ self selectedSelector ifNotNil:[ self browseSendersOfMessages ]]. aWidget bindKeyCombination: $v command toAction: [ self selectedSelector ifNotNil:[ self browseVersions ]]. aWidget bindKeyCombination: $x command toAction: [ self selectedSelector ifNotNil:[ self removeMessage ]].! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! newSet | aSet | self okToChange ifFalse: [ ^ self ]. aSet := self model createNewSet. aSet ifNotNil: [ self updateChangesList. changesListModel setSelectedItem: aSet ]! ! !ChangeSorterApplication methodsFor: 'menu - message' stamp: ''! browseImplementorsOfMessages self model browseMessagesFrom: self selectedSelector! ! !ChangeSorterApplication methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 13:10'! classMenu: aMenu shifted: shifted "Fill aMenu with items appropriate for the class list" self selectedClass ifNil: [ ^ nil ]. aMenu title: 'Class list'. aMenu addAllFromPragma: 'changeSorterClassListMenu' target: self. ^aMenu! ! !ChangeSorterApplication methodsFor: 'menu - class' stamp: ''! forgetClass "Remove all mention of this class from the changeSet" self okToChange ifFalse: [^ self]. self selectedClass ifNotNil: [:class | self model removeClass: class from: self selectedChangeSet. self setSelectedChangeSet: self selectedChangeSet ]. ! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! selectorsMenu: aBlock methodsListModel menu: aBlock! ! !ChangeSorterApplication methodsFor: 'shortcuts' stamp: ''! methodShortcuts: event from: aMorph self selectedSelector ifNotNil:[ event keyString = '' ifTrue: [ ^ self browseMethodFull ]. event keyString = '' ifTrue: [ ^ self forgetMessage ]. event keyString = '' ifTrue: [ ^ self browseImplementorsOfMessages ]. event keyString = '' ifTrue: [ ^ self browseSendersOfMessages ]. event keyString = '' ifTrue: [ ^ self browseVersions ]. event keyString = '' ifTrue: [ ^ self removeMessage ]].! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! addPreamble self model addPreambleTo: self selectedChangeSet. changesListModel setSelectedItem: self selectedChangeSet! ! !ChangeSorterApplication methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 5/1/2013 10:33'! initializeWidgets self instantiateModels: #( methodsListModel NewListModel classesListModel NewListModel changesListModel NewListModel prettyButton CheckBoxModel diffButton CheckBoxModel textModel TextModel ). self setFocus. methodsListModel menu: [:menu :shifted | self messageMenu: menu shifted: shifted ]. changesListModel menu: [:aMenu :shifted | self changeSetMenu: aMenu shifted: shifted ]. classesListModel menu: [:aMenu :shifted | self classMenu: aMenu shifted: shifted ]. changesListModel items: self model allChanges. changesListModel displayBlock: [:item | item name ]. textModel aboutToStyle: true. ! ! !ChangeSorterApplication methodsFor: 'accessing' stamp: ''! changesListModel ^ changesListModel! ! !ChangeSorterApplication methodsFor: 'menu - message' stamp: ''! fileOutMessage "Put a description of the selected message on a file" self selectedSelector ifNotNil: [:selector | Cursor write showWhile: [ self model fileOutSelector: selector from: self selectedClass ]]! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! remove "Completely destroy my change set. Check if it's OK first" self okToChange ifFalse: [^ self]. self model removeChangeSet: self selectedChangeSet prompting: true. self updateChangesList. changesListModel resetSelection! ! !ChangeSorterApplication methodsFor: 'private' stamp: ''! forceChangesListRefresh | sel | sel := self selectedChangeSet. changesListModel items: self model allChanges. changesListModel setSelectedItem: sel.! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! setCurrentChangeSet self model setCurrentChangeSet: self selectedChangeSet.! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! selectedSelector ^ methodsListModel selectedItem! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: 'GuillermoPolito 8/5/2013 10:21'! methodsOn: aShortcut do: aBlock methodsListModel bindKeyCombination: aShortcut toAction: aBlock! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: 'MarcusDenker 10/26/2012 13:05'! openChangeSetBrowser | cs | cs := self selectedChangeSet ifNil: [^self]. ^Smalltalk tools browser fullOnEnvironment: (RBBrowserEnvironment new forClasses: cs changedClasses)! ! !ChangeSorterApplication methodsFor: 'menu - message' stamp: ''! browseSendersOfMessages self model browseSendersOfMessagesFrom: self selectedSelector! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! selectedChangeSet ^ changesListModel selectedItem! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: 'StephaneDucasse 11/2/2012 16:30'! updateClassesList | sel | sel := self selectedClass. self selectedChangeSet ifNil: [ classesListModel items: {} ] ifNotNil: [:change | classesListModel items: (change changedClasses sort: [:a :b | a name < b name ])]. classesListModel setSelectedItem: sel! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! updateMessagesList | sel | sel := methodsListModel selectedItem. self selectedClass ifNil: [ methodsListModel items: {} ] ifNotNil: [:class | methodsListModel items: (self selectedChangeSet selectorsInClass: class name) sort]. methodsListModel setSelectedItem: sel! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! setSelectedClassIndex: anIndex ^ classesListModel setSelectedIndex: anIndex! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! selectedChangeSetIndex ^ changesListModel selectedIndex! ! !ChangeSorterApplication methodsFor: 'menu - message' stamp: ''! removeMessage "Remove the selected message from the system." self okToChange ifFalse: [^ self]. self selectedSelector ifNotNil: [:selector | (self model removeMethod: selector inClass: self selectedClass) ifTrue: [ self updateMessagesList ]]! ! !ChangeSorterApplication methodsFor: 'private' stamp: ''! updateTextContents | text | text := (self model setContentsOfChangeSet: self selectedChangeSet forClass: self selectedClass andSelector: self selectedSelector prettyPrint: prettyPrint showDiff: showDiff). ({'Method was added, but cannot be found!!'. 'Added then removed (see versions)'. 'Method has been removed (see versions)'} includes: text) ifTrue: [ textModel aboutToStyle: false ] ifFalse: [ textModel aboutToStyle: true ] . textModel text: text.! ! !ChangeSorterApplication methodsFor: 'shortcuts' stamp: 'GuillermoPolito 8/5/2013 10:21'! registerChangeSetShortcuts: aWidget aWidget bindKeyCombination: $b command toAction: [ self selectedChangeSet ifNotNil:[ self browseChangeSet ]]. aWidget bindKeyCombination: $b shift command toAction: [ self selectedChangeSet ifNotNil:[ self openChangeSetBrowser ]]. aWidget bindKeyCombination: $m command toAction: [ self selectedChangeSet ifNotNil:[ self setCurrentChangeSet ]]. aWidget bindKeyCombination: $n command toAction: [ self selectedChangeSet ifNotNil:[ self newSet ]]. aWidget bindKeyCombination: $o command toAction: [ self selectedChangeSet ifNotNil:[ self fileOut ]]. aWidget bindKeyCombination: $r command toAction: [ self selectedChangeSet ifNotNil:[ self rename ]]. aWidget bindKeyCombination: $p command toAction: [ self selectedChangeSet ifNotNil:[ self addPreamble ]]. aWidget bindKeyCombination: $x command toAction: [ self selectedChangeSet ifNotNil:[ self remove ]]. aWidget bindKeyCombination: $f command toAction: [ self findChangeSet ]. ! ! !ChangeSorterApplication methodsFor: 'initialization' stamp: 'StephaneDucasse 5/17/2012 19:32'! registerClassActions classesListModel whenSelectedItemChanged: [:class | methodsListModel resetSelection. self updateTextContents. textModel behavior: class. textModel aboutToStyle: false. class ifNil: [ methodsListModel items: {} ] ifNotNil: [ methodsListModel items: (self selectedChangeSet selectorsInClass: class name) sort ]].! ! !ChangeSorterApplication methodsFor: 'menu - class' stamp: ''! removeClass "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." (self model removeClass: self selectedClass) ifTrue: [ self setSelectedChangeSet: self selectedChangeSet ]! ! !ChangeSorterApplication methodsFor: 'menu - message' stamp: ''! browseMethodFull "Create and schedule a full Browser and then select the current class and message." self selectedClass ifNotNil: [:myClass | Smalltalk tools browser fullOnClass: myClass selector: self selectedSelector ]! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! setSelectedChangeSet: aChangeSet ^ changesListModel setSelectedItem: aChangeSet! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: 'StephaneDucasse 11/2/2012 14:44'! title ^ super title, ' on: ', self model currentChangeSet name. ! ! !ChangeSorterApplication methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:22'! initializePresenter prettyButton activationAction: [ prettyPrint := true. self updateTextContents ]. prettyButton desactivationAction: [ prettyPrint := false. self updateTextContents ]. diffButton activationAction: [ showDiff := true. self updateTextContents ]. diffButton desactivationAction: [ showDiff := false. self updateTextContents ]. self registerChangeActions. self registerClassActions. self registerSelectorActions.! ! !ChangeSorterApplication methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 2/8/2013 14:09'! ensureKeyBindingsFor: aWidget super ensureKeyBindingsFor: aWidget. self registerChangeSetShortcuts: changesListModel. self registerClassShortcuts: classesListModel. self registerMethodShortcuts: methodsListModel.! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! changesMenu: aBlock changesListModel menu: aBlock! ! !ChangeSorterApplication methodsFor: 'accessing' stamp: ''! classesListModel ^ classesListModel! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! removePreamble self selectedChangeSet removePreamble. changesListModel setSelectedItem: self selectedChangeSet! ! !ChangeSorterApplication methodsFor: 'menu - message' stamp: ''! forgetMessage self okToChange ifFalse: [^ self]. self selectedSelector ifNotNil: [:selector | self model forgetSelector: selector inClass: self selectedClass fromChangeSet: self selectedChangeSet. self updateClassesList. self setSelectedClassIndex: self selectedClassIndex ]! ! !ChangeSorterApplication methodsFor: 'shortcuts' stamp: ''! classShortcuts: event from: aMorph self selectedClass ifNotNil:[ event keyString = '' ifTrue: [ ^ self browseMethodFull ]. event keyString = '' ifTrue: [ ^ self forgetClass ]. event keyString = '' ifTrue: [ ^ self removeClass ]].! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! selectedClass ^ classesListModel selectedItem! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! findChangeSet | set | set := self model findChangeSetIn: self changeSets. changesListModel setSelectedItem: set.! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! setSelectedChangeSetIndex: anIndex ^ changesListModel setSelectedIndex: anIndex! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! updateClassesListAndMessagesList | sel | sel := methodsListModel selectedItem. self updateClassesList. methodsListModel setSelectedItem: sel. self updateMessagesList.! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: 'GuillermoPolito 8/5/2013 10:21'! classesOn: aShortcut do: aBlock classesListModel bindKeyCombination: aShortcut toAction: aBlock! ! !ChangeSorterApplication methodsFor: 'shortcuts' stamp: ''! changeSetShortcuts: event from: aMorph self selectedChangeSet ifNotNil:[ event keyString = '' ifTrue: [ ^ self browseChangeSet ]. event keyString = '' ifTrue: [ ^ self openChangeSetBrowser ]. event keyString = '' ifTrue: [ ^ self setCurrentChangeSet ]. event keyString = '' ifTrue: [ ^ self newSet ]. event keyString = '' ifTrue: [ ^ self fileOut ]. event keyString = '' ifTrue: [ ^ self rename ]. event keyString = '' ifTrue: [ ^ self addPreamble ]. event keyString = '' ifTrue: [ ^ self remove ]]. event keyString = '' ifTrue: [ ^ self findChangeSet ]. ! ! !ChangeSorterApplication methodsFor: 'private' stamp: ''! defaultTitle ^ 'Change Sorter'! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: 'GuillermoPolito 8/5/2013 10:21'! changesModelOn: aShortcut do: aBlock changesListModel bindKeyCombination: aShortcut toAction: aBlock! ! !ChangeSorterApplication methodsFor: 'shortcuts' stamp: 'GuillermoPolito 8/5/2013 10:21'! registerClassShortcuts: aWidget aWidget bindKeyCombination: $b command toAction: [ self selectedClass ifNotNil:[ self browseMethodFull ]]. aWidget bindKeyCombination: $d command toAction: [ self selectedClass ifNotNil:[ self forgetClass ]]. aWidget bindKeyCombination: $x command toAction: [ self selectedClass ifNotNil:[ self removeClass ]].! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! editPostscript self selectedChangeSet editPostscript! ! !ChangeSorterApplication methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 13:10'! messageMenu: aMenu shifted: shifted "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" self selectedSelector ifNil: [ ^ nil ]. aMenu title: 'Message list'. aMenu addAllFromPragma:'changeSorterMessageListMenu' target: self. ^aMenu ! ! !ChangeSorterApplication methodsFor: 'accessing' stamp: ''! model ^ model! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! browseChangeSet "Open a message list browser on methods in the current change set" | messages | messages := self selectedChangeSet changedMessageList select: [ :each | each isValid]. Smalltalk tools messageList openMessageList: messages name: 'Methods in Change Set ', self selectedChangeSet name autoSelect: ''! ! !ChangeSorterApplication methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 12:53'! changeSetMenu: aMenu shifted: isShifted "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" aMenu title: 'Change Set'. self changeSetMenu1: aMenu shifted: isShifted. self changeSetMenu2: aMenu shifted: isShifted. ^ aMenu! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! classesMenu: aBlock classesListModel menu: aBlock! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/19/2012 20:39'! changeSets ^ self changesListModel listItems! ! !ChangeSorterApplication methodsFor: 'initialization' stamp: ''! setFocus self focusOrder add: changesListModel; add: classesListModel; add: methodsListModel; add: textModel.! ! !ChangeSorterApplication methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 13:10'! changeSetMenu1: aMenu shifted: isShifted "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" aMenu addAllFromPragma: 'changeSorterChangeSetList1Menu' target: self. ! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: ''! currentText ^ textModel getText! ! !ChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! fileOut self selectedChangeSet fileOut! ! !ChangeSorterApplication class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 7/31/2012 16:09'! defaultSpec ^ SpecLayout composed newColumn: [:c | c newRow: [:r | r add: #changesListModel; addSplitter; add: #classesListModel ]; addSplitter; add: #methodsListModel; addSplitter; add: #textModel ].! ! !ChangeSorterApplication class methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 13:03'! changeSetMenu2: aBuilder | target cs | target := aBuilder model. cs := target selectedChangeSet. cs ifNil: [ ^self ]. cs hasPreamble ifTrue: [ (aBuilder item: #'Edit preamble') keyText: 'p'; selector: #addPreamble. (aBuilder item: #'Remove preamble') selector: #removePreamble ] ifFalse: [ (aBuilder item: #'Add preamble') keyText: 'p'; selector: #addPreamble ]. cs hasPreamble ifTrue: [ (aBuilder item: #'Edit postscript...') selector: #editPostscript. (aBuilder item: #'Remove postscript') selector: #removePostscript ] ifFalse: [ (aBuilder item: #'Add postscript...') selector: #editPostscript ]. aBuilder withSeparatorAfter. (aBuilder item: #'Destroy change set') keyText: 'x'; selector: #remove. ! ! !ChangeSorterApplication class methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 13:11'! messageListMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Delete method from changeSet') keyText: 'd'; selector: #forgetMessage. (aBuilder item: #'Remove method from system') keyText: 'x'; selector: #removeMessage; withSeparatorAfter. (aBuilder item: #'Browse full') keyText: 'b'; selector: #browseMethodFull; withSeparatorAfter. (aBuilder item: #'FileOut') selector: #fileOutMessage. (aBuilder item: #'Senders of...') keyText: 'n'; selector: #browseSendersOfMessages. (aBuilder item: #'Implementors of...') keyText: 'm'; selector: #browseImplementorsOfMessages. (aBuilder item: #'Versions') keyText: 'v'; selector: #browseVersions. ! ! !ChangeSorterApplication class methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 13:03'! changeSetMenu1: aBuilder | target | target := aBuilder model. target selectedChangeSet ifNotNil: [ (aBuilder item: #'Make changes go to me') keyText: 'm'; selector: #setCurrentChangeSet. (aBuilder item: #'New change set...') keyText: 'n'; selector: #newSet ]. (aBuilder item: #'Find...') keyText: 'f'; selector: #findChangeSet. target selectedChangeSet ifNotNil: [ aBuilder withSeparatorAfter. (aBuilder item: #'Rename change set') keyText: 'r'; selector: #rename. (aBuilder item: #'File out') keyText: 'o'; selector: #fileOut. (aBuilder item: #'Browse methods') keyText: 'b'; selector: #browseChangeSet. (aBuilder item: #'Browse change set') keyText: 'B'; selector: #openChangeSetBrowser ]. ! ! !ChangeSorterApplication class methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 13:07'! classListMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Delete class from change set') keyText: 'd'; selector: #forgetClass. (aBuilder item: #'Remove class from system') keyText: 'x'; selector: #removeClass; withSeparatorAfter. (aBuilder item: #'Browse full') keyText: 'b'; selector: #browseMethodFull; withSeparatorAfter. (aBuilder item: #'FileOut') selector: #fileOutClass. ! ! !ChangeSorterModel commentStamp: ''! A ChangeSorterModel is a model used by Change Sorter UIs for computation! !ChangeSorterModel methodsFor: 'message' stamp: ''! forgetSelector: selector inClass: aClass fromChangeSet: aChangeSet aChangeSet removeSelectorChanges: selector class: aClass! ! !ChangeSorterModel methodsFor: 'change set' stamp: ''! createNewSet ^ ChangeSet newChangeSet.! ! !ChangeSorterModel methodsFor: 'change set' stamp: 'AlejandroInfante 11/11/2013 14:59'! rename: aChangeSet "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" | newName | newName := UIManager default request: 'New name for this change set' initialAnswer: aChangeSet name. (newName = aChangeSet name or: [newName isEmptyOrNil]) ifTrue: [ ^ UIManager default inform: 'Please give a new name' ]. (ChangeSet named: newName) ifNotNil: [ ^ UIManager default inform: 'Sorry that name is already used' ]. aChangeSet name: newName. ^ aChangeSet! ! !ChangeSorterModel methodsFor: 'change set' stamp: ''! addPreambleTo: aChangeSet aChangeSet assurePreambleExists! ! !ChangeSorterModel methodsFor: 'change set' stamp: ''! removeChangeSet: aChangeSet prompting: doPrompt "Completely destroy my change set. Check if it's OK first, and if doPrompt is true, get the user to confirm his intentions first." | message aName changeSetNumber msg | aName := aChangeSet name. aChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project" (aChangeSet isEmpty or: [doPrompt not]) ifFalse: [message := 'Are you certain that you want to remove (destroy) the change set named "', aName, '" ?'. (self confirm: message) ifFalse: [^ self]]. doPrompt ifTrue: [msg := aChangeSet hasPreamble ifTrue: [aChangeSet hasPostscript ifTrue: ['a preamble and a postscript'] ifFalse: ['a preamble']] ifFalse: [aChangeSet hasPostscript ifTrue: ['a postscript'] ifFalse: ['']]. msg isEmpty ifFalse: [(self confirm: 'Caution!! This change set has ', msg, ' which will be lost if you destroy the change set. Do you really want to go ahead with this?') ifFalse: [^ self]]]. "Go ahead and remove the change set" changeSetNumber := aChangeSet name initialIntegerOrNil. changeSetNumber ifNotNil: [SystemVersion current unregisterUpdate: changeSetNumber]. ChangeSet removeChangeSet: aChangeSet.! ! !ChangeSorterModel methodsFor: 'environment' stamp: ''! allChanges ^ ChangeSet allChangeSets reverse! ! !ChangeSorterModel methodsFor: 'text' stamp: ''! buildChangeSetDescriptionFor: changeSet ^ changeSet ifNil: [ '' ] ifNotNil: [ changeSet preambleString ifNil: ['']]! ! !ChangeSorterModel methodsFor: 'change set' stamp: 'AlejandroInfante 11/11/2013 14:56'! findChangeSetIn: aCollectionOfChangeSets "Search for a changeSet by name. Pop up a menu of all changeSets whose name contains the string entered by the user. If only one matches, then the pop-up menu is bypassed" | index pattern candidates nameList | self okToChange ifFalse: [^ self]. pattern := UIManager default request: 'ChangeSet name or fragment?'. pattern isEmptyOrNil ifTrue: [^ self]. nameList := aCollectionOfChangeSets collect: #name. candidates := aCollectionOfChangeSets select: [:c | (nameList includes: c name) and: [c name includesSubstring: pattern caseSensitive: false]]. candidates size = 0 ifTrue: [ ^ self inform: 'No matching change sets.' ]. candidates size = 1 ifTrue: [ ^ candidates first ]. index := UIManager default chooseFrom: (candidates collect: [:each | each name]). index = 0 ifFalse: [ ^ (candidates at: index) ].! ! !ChangeSorterModel methodsFor: 'change set' stamp: ''! submerge: source into: destination "Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well." | message | source == destination ifTrue: [ ^ false ]. source isEmpty ifTrue: [ self inform: 'Nothing to copy. To remove, simply choose "remove".'. ^ false ]. source okayToRemove ifFalse: [^ false]. message := 'Please confirm: copy all changes in "', source name, '" into "', destination name, '" and then destroy the change set named "', source name, '"?'. (self confirm: message) ifFalse: [^ false]. (source hasPreamble or: [source hasPostscript]) ifTrue: [(self confirm: 'Caution!! This change set has a preamble or a postscript or both. If you submerge it into the other side, these will be lost. Do you really want to go ahead with this?') ifFalse: [^ false]]. self copyAllChangesFrom: source to: destination. self removeChangeSet: source prompting: false. ^ true! ! !ChangeSorterModel methodsFor: 'text' stamp: ''! buildClassDescriptionFor: changeSet class: class | stream | stream := (String new: 100) writeStream. (changeSet classChangeAt: class name) do: [:each | each = #remove ifTrue: [ stream nextPutAll: 'Entire class was removed.'; cr ]. each = #addedThenRemoved ifTrue: [ stream nextPutAll: 'Class was added then removed.'; cr ]. each = #rename ifTrue: [ stream nextPutAll: 'Class name was changed.'; cr ]. each = #add ifTrue: [ stream nextPutAll: 'Class definition was added.'; cr ]. each = #change ifTrue: [ stream nextPutAll: 'Class definition was changed.'; cr ]. each = #reorganize ifTrue: [ stream nextPutAll: 'Class organization was changed.'; cr ]. each = #comment ifTrue: [ stream nextPutAll: 'New class comment.'; cr ]]. ^ stream contents! ! !ChangeSorterModel methodsFor: 'text' stamp: 'NicolaiHess 1/31/2014 12:07'! buildSelectorDescriptionFor: changeSet class: class selector: selector prettyPrint: prettyPrint showDiff: showDiff | changeType code | changeType := changeSet atSelector: selector class: class. changeType == #remove ifTrue: [^ 'Method has been removed (see versions)']. changeType == #addedThenRemoved ifTrue: [^ 'Added then removed (see versions)']. class ifNil: [^ 'Method was added, but cannot be found!!']. (class includesSelector: selector) ifFalse: [^ 'Method was added, but cannot be found!!']. code := class sourceCodeAt: selector. prettyPrint ifTrue: [ code := class compiler format: code]. showDiff ifTrue: [ code := self diffFromPriorSourceFor: code ]. ^ code asText! ! !ChangeSorterModel methodsFor: 'class' stamp: ''! copyClass: aClass from: source to: destination destination absorbClass: aClass name from: source.! ! !ChangeSorterModel methodsFor: 'message' stamp: ''! copySelector: selector inClass: class from: source to: destination destination absorbMethod: selector class: class from:source! ! !ChangeSorterModel methodsFor: 'class' stamp: 'StephaneDucasse 11/2/2012 16:03'! fileOutClass: aClass from: aChangeSet "this is a hack!!!! makes a new change set, called the class name, adds author initials to try to make a unique change set name, files it out and removes it. kfr 16 june 2000" "Method copied from ChangeSorter" | aSet | aSet := ChangeSet newChangeSet: aClass name. aSet ifNil:[ ^self ]. aSet absorbClass: aClass name from: aChangeSet. aSet fileOut. ChangeSet removeChangeSet: aSet.! ! !ChangeSorterModel methodsFor: 'message' stamp: ''! fileOutSelector: selector from: aClass aClass fileOutMethod: selector! ! !ChangeSorterModel methodsFor: 'class' stamp: ''! removeClass: class from: changeSet changeSet removeClassChanges: class.! ! !ChangeSorterModel methodsFor: 'text' stamp: 'ClementBera 7/26/2013 16:01'! setContentsOfChangeSet: changeSet forClass: class andSelector: selector prettyPrint: prettyPrint showDiff: showDiff "return the source code that shows in the bottom pane" class ifNil: [ "Only the change set is currently selected" ^ self buildChangeSetDescriptionFor: changeSet ]. selector ifNil: [ "class is selected but not the selector" ^ self buildClassDescriptionFor: changeSet class: class ] ifNotNil: [ "a class and a selector are selected" ^ self buildSelectorDescriptionFor: changeSet class: class selector: selector prettyPrint: prettyPrint showDiff: showDiff ]! ! !ChangeSorterModel methodsFor: 'change set' stamp: 'StephaneDucasse 11/2/2012 16:37'! setCurrentChangeSet: aChangeSet ChangeSet newChanges: aChangeSet. ! ! !ChangeSorterModel methodsFor: 'change set' stamp: 'MartinDias 10/23/2013 14:42'! subtractFrom: source to: destination source forgetAllChangesFoundIn: destination.! ! !ChangeSorterModel methodsFor: 'change set' stamp: 'StephaneDucasse 11/2/2012 14:17'! currentChangeSet ^ ChangeSet current ! ! !ChangeSorterModel methodsFor: 'change set' stamp: ''! removePostscriptFrom: aChange (aChange hasPostscript and: [ aChange postscriptHasDependents ]) ifTrue: [^ self inform: 'Cannot remove the postscript right now because there is at least one window open on that postscript. Close that window and try again.']. aChange removePostscript.! ! !ChangeSorterModel methodsFor: 'change set' stamp: ''! copyAllChangesFrom: source to: destination destination assimilateAllChangesFoundIn: source! ! !ChangesBrowser commentStamp: ''! A ChangesBrowser is a browser used to browse a composite change wich gather all the wanted changes! !ChangesBrowser methodsFor: 'initialization' stamp: 'GuillermoPolito 8/5/2013 10:21'! initializeTextArea textArea enabled: false; "make sure we can cycle over the text field" bindKeyCombination: Character tab shift toAction: [ self giveFocusToNextFrom: textArea ]; bindKeyCombination: Character tab toAction: [ self giveFocusToPreviousFrom: textArea ].! ! !ChangesBrowser methodsFor: 'private' stamp: 'CamilloBruni 11/18/2013 21:00'! updateChanges "Filter the shown changes depending on the selected environment" self flag: 'todo'.! ! !ChangesBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! cancel window value delete! ! !ChangesBrowser methodsFor: 'accessing' stamp: ''! textArea ^ textArea! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/11/2012 10:52'! initializeCancelButton cancelButton state: true; enabled: true; action: [ self cancel ]; label: 'Cancel'! ! !ChangesBrowser methodsFor: 'private' stamp: 'CD 11/29/2013 16:19'! pickedChanges ^ changesTree selectedItems! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'CD 11/29/2013 16:20'! initializeWidgets cancelButton := self newButton. acceptButton := self newButton. changesTree := self newTree. textArea := self newText. self initializeAcceptButton. self initializeCancelButton. self initializeChangesTree. self initializeTextArea. self setFocus. self bindKeyCombination: $s command toAction: [ self accept ]; bindKeyCombination: Character escape toAction: [ self cancel ]! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/11/2012 10:51'! initializeAcceptButton acceptButton state: true; enabled: true; action: [ self accept ]; label: 'Accept'! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'CD 11/29/2013 16:24'! initializeChangesTree changesTree beCheckList; removeOnlyLastSelected: true; autoMultiSelection: true; rootNodeHolder: [ :item | TreeNodeModel new content: item; hasContentToShow: true; children: [ changesTree childrenFor: item ] ]; displayBlock: [ :item | item nameToDisplay ]. self whenBuiltDo: [ changesTree selectAll ]! ! !ChangesBrowser methodsFor: 'protocol' stamp: 'CD 11/29/2013 16:18'! accept self okToChange ifFalse: [ ^self ]. self pickedChanges do: [ :change | RBRefactoryChangeManager instance performChange: change content ]. window value delete! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 12/5/2013 12:48'! initializePresenter changesTree whenHighlightedItemChanged: [ :item | item ifNotNil: [ textArea text: (self buildDiffFor: item content) ] ]! ! !ChangesBrowser methodsFor: 'accessing' stamp: ''! cancelButton ^ cancelButton! ! !ChangesBrowser methodsFor: 'protocol' stamp: 'CD 11/29/2013 16:19'! change: aCompositeChange changesTree roots: (aCompositeChange whatToDisplayIn: self)! ! !ChangesBrowser methodsFor: 'protocol' stamp: ''! buildDiffFor: aChange ^ aChange ifNil: [ '' ] ifNotNil: [ TextDiffBuilder buildDisplayPatchFrom: aChange oldVersionTextToDisplay to: aChange textToDisplay ].! ! !ChangesBrowser methodsFor: 'accessing' stamp: 'CamilloBruni 11/20/2013 17:02'! scopeChooser ^ scopeChooser ifNil: [ scopeChooser := self instantiate: EnvironmentChooser. scopeChooser whenEnvironmentChanged: [ self updateChanges ]; label: 'Scope:'. scopeChooser]! ! !ChangesBrowser methodsFor: 'private' stamp: 'CamilloBruni 10/8/2012 22:21'! changes: aCollection | composite | composite := RBCompositeRefactoryChange new. aCollection do: [:change | composite addChange: change ]. self change: composite.! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'CD 11/29/2013 16:21'! setShortcuts self changesTree attachKeymapCategory: #ChangesBrowserGlobalShortcuts targetting: self! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'CD 11/29/2013 16:19'! setFocus self focusOrder add: changesTree; add: textArea; add: acceptButton; add: cancelButton.! ! !ChangesBrowser methodsFor: 'accessing' stamp: ''! acceptButton ^ acceptButton! ! !ChangesBrowser methodsFor: 'accessing' stamp: 'CD 11/29/2013 16:21'! changesTree ^ changesTree! ! !ChangesBrowser class methodsFor: 'specs' stamp: 'MartinDias 4/7/2014 15:12'! defaultSpec ^ SpecLayout composed newColumn: [:c | c newColumn: [:c2 | c2 add: #changesTree ]; addSplitter; add: #textArea; newRow: [:r | r add: #acceptButton; add: #cancelButton] height: self toolbarHeight ]! ! !ChangesBrowser class methodsFor: 'instance creation' stamp: ''! changes: aCollection ^ self new changes: aCollection; yourself! ! !ChangesBrowser class methodsFor: 'shortcuts' stamp: 'GuillermoPolito 3/19/2013 19:12'! buildShortcutsOn: aBuilder (aBuilder shortcut: #close) category: #ChangesBrowserGlobalShortcuts default: Character escape asKeyCombination do: [ :target | target cancel ] description: 'Close this dialog'. (aBuilder shortcut: #accept) category: #ChangesBrowserGlobalShortcuts default: $s command do: [ :target | target accept ] description: 'Accept the proposed changes'.! ! !ChangesBrowser class methodsFor: 'specs' stamp: ''! title ^ 'Changes Browser'! ! !ChangesLog commentStamp: ''! I represent the changes file and give access to him. If you want to log a change, look at my #logChange: method. I have a default instance that is hearing SystemAnnouncements and logging the change logs in there. But you can have your own instance and log whatever you want.! !ChangesLog methodsFor: 'logging' stamp: 'MartinDias 11/5/2013 14:44'! logChange: aStringOrText "Write the argument, aString, onto the changes file." | aString changesFile | (SourceFiles at: 2) ifNil: [ ^ self ]. self assureStartupStampLogged. aString := aStringOrText asString. (aString findFirst: [ :char | char isSeparator not ]) = 0 ifTrue: [ ^ self ]. "null doits confuse replay" changesFile := SourceFiles at: 2. changesFile isReadOnly ifTrue: [ ^ self ]. changesFile setToEnd; cr; cr. changesFile nextChunkPut: aString. "If want style changes in DoIt, use nextChunkPutWithStyle:, and allow Texts to get here" self forceChangesToDisk! ! !ChangesLog methodsFor: 'logging' stamp: 'YuriyTymchuk 12/20/2013 14:27'! logSnapshot: save andQuit: quit "Log into the changes file the fact that the session will be either snapshoted, quit, or both." | message | (SourceFiles at: 2) ifNil: [ ^ self ]. message := String streamContents: [ :s | s nextPutAll: '----'; nextPutAll: (save ifTrue: [ quit ifTrue: [ 'QUIT' ] ifFalse: [ 'SNAPSHOT' ] ] ifFalse: [ quit ifTrue: [ 'QUIT/NOSAVE' ] ifFalse: [ 'NOP' ] ]); nextPutAll: '----'; print: DateAndTime now; space; nextPutAll: (Smalltalk imageFile basename); nextPutAll: ' priorSource: '; print: Smalltalk lastQuitLogPosition ]. self assureStartupStampLogged. save ifTrue: [ Smalltalk lastQuitLogPosition: ( (SourceFiles at: 2) setToEnd; position) ]. self logChange: message! ! !ChangesLog methodsFor: 'accessing' stamp: 'CamilloBruni 11/5/2013 16:55'! recordStartupStamp startupStamp := '----STARTUP----', DateAndTime now printString, ' as ', Smalltalk imagePath. ! ! !ChangesLog methodsFor: 'private' stamp: 'MartinDias 11/5/2013 14:45'! assureStartupStampLogged "If there is a startup stamp not yet actually logged to disk, do it now." | changesFile | startupStamp ifNil: [ ^ self ]. (changesFile := SourceFiles at: 2) ifNil: [ ^ self ]. changesFile isReadOnly ifTrue: [ ^ self ]. changesFile setToEnd; cr; cr. changesFile nextChunkPut: startupStamp asString; cr. startupStamp := nil. self forceChangesToDisk! ! !ChangesLog methodsFor: 'private' stamp: 'MarcusDenker 10/9/2013 17:05'! forceChangesToDisk "Ensure that the changes file has been fully written to disk by closing and re-opening it. This makes the system more robust in the face of a power failure or hard-reboot." | changesFile | changesFile := SourceFiles at: 2. (changesFile isKindOf: FileStream) ifFalse: [ ^ self ]. changesFile flush. changesFile close. changesFile open: changesFile name forWrite: true. changesFile setToEnd! ! !ChangesLog methodsFor: 'event-listening' stamp: 'GuillermoPolito 8/3/2012 14:42'! logClassRemoved: annoucement annoucement classRemoved acceptsLoggingOfCompilation ifTrue: [ self logChange: 'Smalltalk globals removeClassNamed: #', annoucement classRemoved name ]. ! ! !ChangesLog methodsFor: 'event-listening' stamp: 'EstebanLorenzano 2/28/2013 16:45'! registerToAnnouncements SystemAnnouncer uniqueInstance on: ClassRemoved send: #logClassRemoved: to: self; on: ClassRenamed send: #logClassRenamed: to: self; on: MethodRemoved send: #logMethodRemoved: to: self; on: ExpressionEvaluated send: #logExpressionEvaluated: to: self.! ! !ChangesLog methodsFor: 'event-listening' stamp: 'CamilleTeruel 7/29/2012 19:46'! logMethodRemoved: announcement announcement methodClass acceptsLoggingOfCompilation ifTrue: [ self logChange: announcement methodClass name, ' removeSelector: #', announcement selector ] ! ! !ChangesLog methodsFor: 'event-listening' stamp: 'GuillermoPolito 8/3/2012 14:43'! logExpressionEvaluated: announcement self logChange: announcement expressionEvaluated.! ! !ChangesLog methodsFor: 'event-listening' stamp: 'EstebanLorenzano 2/28/2013 16:49'! logClassRenamed: annoucement annoucement classRenamed acceptsLoggingOfCompilation ifTrue: [ self logChange: '(Smalltalk globals at: #', annoucement oldName, ') rename: #', annoucement newName. ]. ! ! !ChangesLog class methodsFor: 'accessing' stamp: 'EstebanLorenzano 8/3/2012 14:07'! reset SystemAnnouncer uniqueInstance unsubscribe: DefaultInstance. DefaultInstance := nil.! ! !ChangesLog class methodsFor: 'accessing' stamp: 'CamilleTeruel 7/30/2012 00:45'! default ^DefaultInstance ifNil: [ DefaultInstance := self new. DefaultInstance registerToAnnouncements ].! ! !Character commentStamp: 'ar 4/9/2005 22:35'! I represent a character by storing its associated Unicode. The first 256 characters are created uniquely, so that all instances of latin1 characters ($R, for example) are identical. The code point is based on Unicode. Since Unicode is 21-bit wide character set, we have several bits available for other information. As the Unicode Standard states, a Unicode code point doesn't carry the language information. This is going to be a problem with the languages so called CJK (Chinese, Japanese, Korean. Or often CJKV including Vietnamese). Since the characters of those languages are unified and given the same code point, it is impossible to display a bare Unicode code point in an inspector or such tools. To utilize the extra available bits, we use them for identifying the languages. Since the old implementation uses the bits to identify the character encoding, the bits are sometimes called "encoding tag" or neutrally "leading char", but the bits rigidly denotes the concept of languages. The other languages can have the language tag if you like. This will help to break the large default font (font set) into separately loadable chunk of fonts. However, it is open to the each native speakers and writers to decide how to define the character equality, since the same Unicode code point may have different language tag thus simple #= comparison may return false. I represent a character by storing its associated ASCII code (extended to 256 codes). My instances are created uniquely, so that all instances of a character ($R, for example) are identical.! !Character methodsFor: '*Keymapping-KeyCombinations' stamp: 'CamilloBruni 9/15/2013 19:49'! meta ^ KMModifier meta + self! ! !Character methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! isDigit ^ self characterSet isDigit: self. ! ! !Character methodsFor: 'converting' stamp: 'CamilloBruni 8/31/2011 12:28'! asUppercase "If the receiver is lowercase, answer its matching uppercase Character." ^ self characterSet toUppercase: self ! ! !Character methodsFor: 'comparing' stamp: ''! < aCharacter "Answer true if the receiver's value < aCharacter's value." ^self asciiValue < aCharacter asciiValue! ! !Character methodsFor: 'testing' stamp: 'di 4/3/1999 00:38'! isSpecial "Answer whether the receiver is one of the special characters" ^'+-/\*~<>=@,%|&?!!' includes: self! ! !Character methodsFor: '*Text-Core' stamp: 'tk 9/4/2000 12:05'! asText ^ self asString asText! ! !Character methodsFor: '*Multilingual-TextConversion' stamp: 'michael.rueger 2/5/2009 17:02'! macRomanToUnicode "Convert the receiver from MacRoman Unicode." ^MacRomanTextConverter new unicodeToByte: self! ! !Character methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 6/28/2013 13:02'! asShortcut ^ self asKeyCombination! ! !Character methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! isLowercase ^ self characterSet isLowercase: self. ! ! !Character methodsFor: 'converting' stamp: 'sma 3/11/2000 17:21'! asString ^ String with: self! ! !Character methodsFor: 'converting' stamp: 'CamilloBruni 9/5/2011 20:06'! asCharacter "Answer the receiver itself." ^ self! ! !Character methodsFor: 'converting' stamp: 'CamilloBruni 8/31/2011 12:16'! uppercase ^ self asUppercase! ! !Character methodsFor: 'converting' stamp: ''! to: other "Answer with a collection in ascii order -- $a to: $z" ^ (self asciiValue to: other asciiValue) collect: [:ascii | Character value: ascii]! ! !Character methodsFor: '*Monticello-Storing' stamp: 'tk 1/17/2000 11:27'! comeFullyUpOnReload: smartRefStream "Use existing an Character. Don't use the new copy." ^ self class value: value! ! !Character methodsFor: '*Multilingual-TextConversion' stamp: 'michael.rueger 2/5/2009 17:01'! unicodeToMacRoman "Convert the receiver from Unicode to MacRoman encoding." ^MacRomanTextConverter new byteToUnicode: self! ! !Character methodsFor: 'testing' stamp: 'ul 11/23/2010 13:28'! shouldBePrintedAsLiteral ^value between: 33 and: 255! ! !Character methodsFor: 'converting' stamp: 'raa 5/26/2001 09:54'! asSymbol "Answer a Symbol consisting of the receiver as the only element." ^Symbol internCharacter: self! ! !Character methodsFor: '*Keymapping-KeyCombinations' stamp: 'CamilloBruni 3/18/2011 22:57'! shift ^ KMModifier shift + self! ! !Character methodsFor: '*NECompletion' stamp: 'EstebanLorenzano 2/4/2013 18:37'! isCompletionCharacter ^ self isAlphaNumeric or: [ self = $: ]! ! !Character methodsFor: 'converting' stamp: 'CamilloBruni 9/5/2011 20:05'! asHTMLString "substitute the < & > into HTML compliant elements" #($< '<' $> '>' $& '&') pairsDo: [:k :v | self = k ifTrue: [^ v]]. ^ String with: self! ! !Character methodsFor: '*Keymapping-KeyCombinations' stamp: 'CamilloBruni 3/18/2011 22:57'! ctrl ^ KMModifier ctrl + self! ! !Character methodsFor: 'testing' stamp: 'yo 8/27/2002 15:18'! isOctetCharacter ^ value < 256. ! ! !Character methodsFor: 'accessing' stamp: 'StephaneDucasse 3/28/2010 19:13'! digitValue2 "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 otherwise. This is used to parse literal numbers of radix 2-36." | digitValue | (digitValue := ('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ' indexOf: self) - 1) >= 0 ifTrue: [ ^digitValue ]. ^ (EncodedCharSet charsetAt: self leadingChar) digitValueOf: self. ! ! !Character methodsFor: 'converting' stamp: 'CamilloBruni 8/31/2011 12:16'! lowercase ^ self asLowercase! ! !Character methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 5/31/2011 18:25'! command ^ KMModifier command + self! ! !Character methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! canBeGlobalVarInitial ^ self characterSet canBeGlobalVarInitial: self. ! ! !Character methodsFor: 'printing' stamp: 'StephaneDucasse 7/31/2010 19:45'! hex "return an headecimal representation of the receiver in the form 16rXX.." ^value hex! ! !Character methodsFor: 'converting' stamp: 'ClementBera 7/26/2013 16:08'! asUnicode | table charset v | self leadingChar = 0 ifTrue: [^ value]. charset := self characterSet. charset isCharset ifFalse: [^ self charCode]. table := charset ucsTable. table ifNil: [^ 16rFFFD]. v := table at: self charCode + 1. v = -1 ifTrue: [^ 16rFFFD]. ^ v. ! ! !Character methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 3/19/2013 20:26'! control ^ KMModifier control + self! ! !Character methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! canBeNonGlobalVarInitial ^ self characterSet canBeNonGlobalVarInitial: self. ! ! !Character methodsFor: '*multilingual-encodings' stamp: 'pmm 9/12/2009 20:39'! asUnicodeChar "Answer a copy of the receiver with Unicode as the leadingChar" ^ Unicode charFromUnicode: self asUnicode! ! !Character methodsFor: '*Keymapping-KeyCombinations' stamp: 'CamilloBruni 3/18/2011 23:13'! alt ^ KMModifier alt + self! ! !Character methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitCharacter: self! ! !Character methodsFor: 'testing' stamp: 'yo 8/28/2002 13:42'! isCharacter ^ true. ! ! !Character methodsFor: 'converting' stamp: 'CamilloBruni 9/5/2011 20:06'! asInteger "Answer the value of the receiver." ^ value! ! !Character methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! isUppercase ^ self characterSet isUppercase: self. ! ! !Character methodsFor: 'accessing' stamp: 'yo 12/29/2002 10:11'! charCode ^ (value bitAnd: 16r3FFFFF). ! ! !Character methodsFor: 'printing' stamp: 'CamilloBruni 10/20/2012 23:52'! printOn: aStream | name | (value > 32 and: [ value ~= 127]) ifTrue: [ aStream nextPut: $$; nextPut: self ] ifFalse: [ name := self class constantNameFor: self. aStream nextPutAll: self class name. name notNil ifTrue: [ aStream space; nextPutAll: name ] ifFalse: [ aStream nextPutAll: ' value: '; print: value ] ].! ! !Character methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! isLetter ^ self characterSet isLetter: self. ! ! !Character methodsFor: 'copying' stamp: 'tk 1/7/1999 16:50'! veryDeepCopyWith: deepCopier "Return self. I can't be copied."! ! !Character methodsFor: 'testing' stamp: 'yo 7/29/2005 15:21'! isSafeForHTTP "whether a character is 'safe', or needs to be escaped when used, eg, in a URL" "[GG] See http://www.faqs.org/rfcs/rfc1738.html. ~ is unsafe and has been removed" ^ self charCode < 128 and: [self isAlphaNumeric or: ['.-_' includes: (Character value: self charCode)]]! ! !Character methodsFor: 'printing' stamp: 'StephaneDucasse 7/31/2010 19:45'! printStringHex "returns the hex digit part of the character value $A printStringHex '41' $A hex '16r41' " ^value printStringBase: 16! ! !Character methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2011 12:41'! codePoint "Just for ANSI Compliance" ^value! ! !Character methodsFor: 'converting' stamp: 'yo 8/11/2003 21:18'! basicSqueakToIso | asciiValue | value < 128 ifTrue: [^ self]. value > 255 ifTrue: [^ self]. asciiValue := #(196 197 199 201 209 214 220 225 224 226 228 227 229 231 233 232 234 235 237 236 238 239 241 243 242 244 246 245 250 249 251 252 134 176 162 163 167 149 182 223 174 169 153 180 168 128 198 216 129 177 138 141 165 181 142 143 144 154 157 170 186 158 230 248 191 161 172 166 131 173 178 171 187 133 160 192 195 213 140 156 150 151 147 148 145 146 247 179 253 159 185 164 139 155 188 189 135 183 130 132 137 194 202 193 203 200 205 206 207 204 211 212 190 210 218 219 217 208 136 152 175 215 221 222 184 240 254 255 256 ) at: self asciiValue - 127. ^ Character value: asciiValue. ! ! !Character methodsFor: 'converting' stamp: 'CamilloBruni 8/31/2011 12:29'! asLowercase "If the receiver is uppercase, answer its matching lowercase Character." ^ self characterSet toLowercase: self! ! !Character methodsFor: 'comparing' stamp: ''! hash "Hash is reimplemented because = is implemented." ^value! ! !Character methodsFor: 'comparing' stamp: ''! > aCharacter "Answer true if the receiver's value > aCharacter's value." ^self asciiValue > aCharacter asciiValue! ! !Character methodsFor: 'copying' stamp: 'ul 4/26/2011 02:33'! deepCopy "Characters from 0 to 255 are unique, copy only the rest." value < 256 ifTrue: [ ^self ]. ^super deepCopy! ! !Character methodsFor: 'testing' stamp: ''! isLiteral ^true! ! !Character methodsFor: 'printing' stamp: 'ul 11/23/2010 13:28'! storeOn: aStream "Common character literals are preceded by '$', however special need to be encoded differently: for some this might be done by using one of the shortcut constructor methods for the rest we have to create them by ascii-value." | name | self shouldBePrintedAsLiteral ifTrue: [ aStream nextPut: $$; nextPut: self ] ifFalse: [ name := self class constantNameFor: self. name notNil ifTrue: [ aStream nextPutAll: self class name; space; nextPutAll: name ] ifFalse: [ aStream nextPut: $(; nextPutAll: self class name; nextPutAll: ' value: '; print: value; nextPut: $) ] ].! ! !Character methodsFor: 'accessing' stamp: ''! asciiValue "Answer the value of the receiver that represents its ascii encoding." ^value! ! !Character methodsFor: 'copying' stamp: 'ul 4/26/2011 02:33'! copy "Characters from 0 to 255 are unique, copy only the rest." value < 256 ifTrue: [ ^self ]. ^super copy! ! !Character methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 3/19/2013 20:28'! asKeyCombination ^ KMSingleKeyCombination from: self! ! !Character methodsFor: 'accessing' stamp: 'yo 12/29/2002 10:14'! leadingChar ^ (value bitAnd: (16r3FC00000)) bitShift: -22. ! ! !Character methodsFor: 'testing' stamp: 'LukasRenggli 8/22/2010 17:21'! tokenish "Answer whether the receiver is a valid token-character -- letter, digit, underscore, or colon." ^ self isLetter or: [ self isDigit or: [ self = $_ or: [ self = $: ] ] ]! ! !Character methodsFor: 'copying' stamp: 'ul 4/26/2011 02:35'! shallowCopy "Characters from 0 to 255 are unique, copy only the rest." value < 256 ifTrue: [ ^self ]. ^super shallowCopy! ! !Character methodsFor: 'printing' stamp: 'pmm 5/22/2010 10:33'! storeBinaryOn: aStream "Store the receiver on a binary (file) stream" value < 256 ifTrue:[aStream basicNextPut: value] ifFalse:[aStream nextInt32Put: value].! ! !Character methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 10:51'! serializeOn: anEncoder anEncoder encodeByte: value! ! !Character methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2011 12:22'! characterSet ^ EncodedCharSet charsetAt: self leadingChar! ! !Character methodsFor: 'testing' stamp: ''! isAlphaNumeric "Answer whether the receiver is a letter or a digit." ^self isLetter or: [self isDigit]! ! !Character methodsFor: 'comparing' stamp: 'ar 4/9/2005 21:48'! = aCharacter "Primitive. Answer true if the receiver and the argument are the same object (have the same object pointer) and false otherwise. Optional. See Object documentation whatIsAPrimitive." ^ self == aCharacter or:[ aCharacter isCharacter and: [self asciiValue = aCharacter asciiValue]]! ! !Character methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2011 12:23'! digitValue "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 otherwise. This is used to parse literal numbers of radix 2-36." "slow version | digitValue | (digitValue := ('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ' indexOf: self) - 1) >= 0 ifTrue: [ ^digitValue ]. ^ (EncodedCharSet charsetAt: self leadingChar) digitValueOf: self. " value > 16rFF ifTrue: [^ self characterSet digitValueOf: self]. ^DigitValues at: 1 + value! ! !Character methodsFor: 'testing' stamp: ''! isVowel "Answer whether the receiver is one of the vowels, AEIOU, in upper or lower case." ^'AEIOU' includes: self asUppercase! ! !Character methodsFor: 'comparing' stamp: 'md 8/2/2005 18:21'! sameAs: aCharacter "Answer whether the receiver is equal to aCharacter, ignoring case" ^ (self asLowercase = aCharacter asLowercase) ! ! !Character methodsFor: 'testing' stamp: ''! isSeparator "Answer whether the receiver is one of the separator characters--space, cr, tab, line feed, or form feed." value = 32 ifTrue: [^true]. "space" value = 13 ifTrue: [^true]. "cr" value = 9 ifTrue: [^true]. "tab" value = 10 ifTrue: [^true]. "line feed" value = 12 ifTrue: [^true]. "form feed" ^false! ! !Character methodsFor: '*Collections-Abstract-splitjoin' stamp: 'onierstrasz 4/10/2009 22:51'! join: aSequenceableCollection ^ self asString join: aSequenceableCollection ! ! !Character methodsFor: 'private' stamp: 'ar 4/9/2005 22:18'! setValue: newValue value ifNotNil:[^self error:'Characters are immutable']. value := newValue.! ! !Character class methodsFor: 'initialization' stamp: 'StephaneDucasse 3/28/2010 19:06'! initializeDigitValues "Initialize the well known digit value of ascii characters. Note that the DigitValues table is 1-based while ascii values are 0-based, thus the offset+1." DigitValues := Array new: 256 withAll: -1. "the digits" 0 to: 9 do: [:i | DigitValues at: 48 + i + 1 put: i]. "the uppercase letters" 10 to: 35 do: [:i | DigitValues at: 55 + i + 1 put: i]. "the lowercase letters" 10 to: 35 do: [:i | DigitValues at: 87 + i + 1 put: i].! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'ls 9/2/1999 08:06'! escape "Answer the ASCII ESC character" ^self value: 27! ! !Character class methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 10:56'! materializeFrom: aDecoder ^self value: aDecoder nextEncodedByte! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'! insert ^ self value: 5! ! !Character class methodsFor: 'initialization' stamp: 'StephaneDucasse 3/28/2010 19:15'! initialize "Create the table of DigitsValues." "self initialize" CharacterTable ifNil: [ "Initialize only once to ensure that byte characters are unique" CharacterTable := Array new: 256. 1 to: 256 do: [:i | CharacterTable at: i put: (self basicNew setValue: i - 1)]]. self initializeDigitValues! ! !Character class methodsFor: 'instance creation' stamp: 'GabrielOmarCotelli 5/29/2009 23:42'! value: anInteger "Answer the Character whose value is anInteger." anInteger negative ifTrue:[self error: 'Characters expects a positive value.']. anInteger > 255 ifTrue: [^self basicNew setValue: anInteger]. ^ CharacterTable at: anInteger + 1. ! ! !Character class methodsFor: 'accessing untypeable characters' stamp: ''! linefeed "Answer the Character representing a linefeed." ^self value: 10! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! home ^ self value: 1! ! !Character class methodsFor: 'instance creation' stamp: 'ar 4/9/2005 22:37'! allCharacters "This name is obsolete since only the characters that will fit in a byte can be queried" ^self allByteCharacters ! ! !Character class methodsFor: 'instance creation' stamp: 'ar 10/25/2010 19:00'! allByteCharacters "Answer all the characters that can be encoded in a byte" ^ (0 to: 255) collect: [:v | Character value: v] as: String ! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! pageDown ^ self value: 12! ! !Character class methodsFor: 'instance creation' stamp: 'ul 4/26/2011 02:29'! leadingChar: leadChar code: code code >= 16r400000 ifTrue: [ self error: 'code is out of range'. ]. leadChar >= 256 ifTrue: [ self error: 'lead is out of range'. ]. code < 256 ifTrue: [ ^self value: code ]. ^self value: (leadChar bitShift: 22) + code.! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'wiz 4/9/2006 20:30'! nbsp "non-breakable space. Latin1 encoding common usage." ^ Character value: 160! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowRight ^ self value: 29! ! !Character class methodsFor: 'accessing untypeable characters' stamp: ''! newPage "Answer the Character representing a form feed." ^self value: 12! ! !Character class methodsFor: 'accessing untypeable characters' stamp: ''! tab "Answer the Character representing a tab." ^self value: 9! ! !Character class methodsFor: 'instance creation' stamp: 'ar 10/25/2010 18:54'! separators "Answer a collection of the standard ASCII separator characters." ^ #(32 "space" 13 "cr" 9 "tab" 10 "line feed" 12 "form feed") collect: [:v | Character value: v] as: String! ! !Character class methodsFor: 'accessing untypeable characters' stamp: ''! cr "Answer the Character representing a carriage return." ^self value: 13! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'ls 9/8/1998 22:15'! lf "Answer the Character representing a linefeed." ^self value: 10! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'StephaneDucasse 4/4/2010 15:12'! euro "The Euro currency sign, that E with two dashes. The code point is a official unicode ISO/IEC-10646-1" ^ Unicode value: 16r20AC! ! !Character class methodsFor: 'private' stamp: 'CamilloBruni 10/20/2012 23:52'! constantNames "Added the rest of them!!" ^#(backspace cr delete escape lf newPage space tab arrowDown arrowLeft arrowRight arrowUp enter end home insert nbsp pageDown pageUp null).! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowDown ^ self value: 31! ! !Character class methodsFor: 'constants' stamp: 'rhi 9/8/2000 14:57'! alphabet "($a to: $z) as: String" ^ 'abcdefghijklmnopqrstuvwxyz' copy! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! end ^ self value: 4! ! !Character class methodsFor: 'accessing untypeable characters' stamp: ''! space "Answer the Character representing a space." ^self value: 32! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! pageUp ^ self value: 11! ! !Character class methodsFor: '*Spec-Inspector' stamp: 'SvenVanCaekenberghe 2/24/2014 14:35'! inspectorClass ^ EyeCharacterInspector! ! !Character class methodsFor: 'constants' stamp: ''! characterTable "Answer the class variable in which unique Characters are stored." ^CharacterTable! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowLeft ^ self value: 28! ! !Character class methodsFor: 'instance creation' stamp: 'StephaneDucasse 3/28/2010 17:41'! codePoint: anInteger "Just for ANSI Compliance" ^self value: anInteger ! ! !Character class methodsFor: 'private' stamp: 'lr 11/21/2005 17:24'! constantNameFor: aCharacter ^ self constantNames detect: [ :each | (self perform: each) = aCharacter ] ifNone: [ nil ].! ! !Character class methodsFor: 'instance creation' stamp: ''! new "Creating new characters is not allowed." self error: 'cannot create new characters'! ! !Character class methodsFor: 'instance creation' stamp: ''! digitValue: x "Answer the Character whose digit value is x. For example, answer $9 for x=9, $0 for x=0, $A for x=10, $Z for x=35." | index | index := x asInteger. ^CharacterTable at: (index < 10 ifTrue: [48 + index] ifFalse: [55 + index]) + 1! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowUp ^ self value: 30! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'! delete ^ self value: 127! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'CamilloBruni 10/20/2012 23:51'! null ^ self value: 0! ! !Character class methodsFor: 'accessing untypeable characters' stamp: ''! backspace "Answer the Character representing a backspace." ^self value: 8! ! !Character class methodsFor: 'accessing untypeable characters' stamp: ''! enter "Answer the Character representing enter." ^self value: 3! ! !CharacterBlock commentStamp: 'StephaneDucasse 5/18/2010 16:00'! I describe the location of one character displayed on the screen. My instances are used to return the results of methods: Paragraph characterBlockAtPoint: aPoint and Paragraph characterBlockForIndex: stringIndex. Any recomposition or movement of a Paragraph can make the information I store stale. text (Text): The text where my character is from stringIndex (Integer): The index of my character in the text, starting from 1 textLine (TextLine): The displayed line my character is on origin (Point): The top-left corner of the area allocated for displaying my character's glyph, in pixels, counting right then down from the top-left corner of the text display area, and starting from 0@0 corner (Point): The bottom-right corner of the area allocated for displaying my character's glyph, in pixels, counting right then down from the top-left corner of the text display area, and starting from 0@0 ! !CharacterBlock methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! stringIndex: anInteger text: aText topLeft: topLeft extent: extent stringIndex := anInteger. text := aText. super setOrigin: topLeft corner: topLeft + extent! ! !CharacterBlock methodsFor: 'comparing' stamp: ''! > aCharacterBlock "Answer whether the string index of the receiver comes after that of aCharacterBlock." ^aCharacterBlock < self! ! !CharacterBlock methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! moveBy: aPoint "Change the corner positions of the receiver so that its area translates by the amount defined by the argument, aPoint." origin := origin + aPoint. corner := corner + aPoint! ! !CharacterBlock methodsFor: 'comparing' stamp: ''! >= aCharacterBlock "Answer whether the string index of the receiver does not precede that of aCharacterBlock." ^(self < aCharacterBlock) not! ! !CharacterBlock methodsFor: 'comparing' stamp: 'th 9/17/2002 11:54'! min: aCharacterBlock aCharacterBlock ifNil:[^self]. ^aCharacterBlock < self ifTrue:[ aCharacterBlock] ifFalse:[self].! ! !CharacterBlock methodsFor: 'comparing' stamp: ''! < aCharacterBlock "Answer whether the string index of the receiver precedes that of aCharacterBlock." ^stringIndex < aCharacterBlock stringIndex! ! !CharacterBlock methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! textLine: aLine textLine := aLine! ! !CharacterBlock methodsFor: 'accessing' stamp: ''! stringIndex "Answer the position of the receiver in the string it indexes." ^stringIndex! ! !CharacterBlock methodsFor: 'comparing' stamp: 'th 9/17/2002 11:54'! max: aCharacterBlock aCharacterBlock ifNil:[^self]. ^aCharacterBlock > self ifTrue:[ aCharacterBlock] ifFalse:[self].! ! !CharacterBlock methodsFor: 'accessing' stamp: 'di 12/2/97 14:33'! textLine ^ textLine! ! !CharacterBlock methodsFor: 'comparing' stamp: ''! = aCharacterBlock self species = aCharacterBlock species ifTrue: [^stringIndex = aCharacterBlock stringIndex] ifFalse: [^false]! ! !CharacterBlock methodsFor: 'printing' stamp: 'di 12/2/97 19:15'! printOn: aStream aStream nextPutAll: 'a CharacterBlock with index '. stringIndex printOn: aStream. (text ~~ nil and: [text size> 0 and: [stringIndex between: 1 and: text size]]) ifTrue: [aStream nextPutAll: ' and character '. (text at: stringIndex) printOn: aStream]. aStream nextPutAll: ' and rectangle '. super printOn: aStream. textLine ifNotNil: [aStream cr; nextPutAll: ' in '. textLine printOn: aStream]. ! ! !CharacterBlock methodsFor: 'comparing' stamp: ''! <= aCharacterBlock "Answer whether the string index of the receiver does not come after that of aCharacterBlock." ^(self > aCharacterBlock) not! ! !CharacterBlockScanner commentStamp: 'nice 10/6/2013 22:04'! A CharacterScanner does scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location. The CharacterBlock stores information both about character layout and character index in the text. This class is essential for selecting text with the mouse or with arrow keys. Instance Variables characterIndex: characterPoint: lastCharacterWidth: nextLeftMargin: specialWidth: characterIndex - the index of character for which the layout information is searched, or nil when the layout is searched by cursor location characterPoint - the cursor location for which nearest character index and layout are searched. lastCharacterWidth - a number indicating the width of last character being processed. Note that this variable is left to nil during the inner scan loop, and only set on stopConditions. nextLeftMargin - a number specifying the distance between left of composition zone and left of first character for the next line. specialWidth - a number holding the width of an embedded object if any, or nil if none. ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'nice 10/13/2013 22:13'! tab | nextDestX | nextDestX := self plainTab. lastCharacterWidth := nextDestX - destX max: 0. nextDestX >= characterPoint x ifTrue: [^ self crossedX]. destX := nextDestX. lastIndex := lastIndex + 1. ^false! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'nice 10/1/2013 01:45'! endOfRun "Before arriving at the cursor location, the selection has encountered an end of run. Answer false if the selection continues, true otherwise. Set up indexes for building the appropriate CharacterBlock." | runLength lineStop | (((characterIndex ~~ nil and: [runStopIndex < characterIndex and: [runStopIndex < text size]]) or: [characterIndex == nil and: [lastIndex < line last]]) or: [ ((lastIndex < line last) and: [((text at: lastIndex) leadingChar ~= (text at: lastIndex+1) leadingChar) and: [lastIndex ~= characterIndex]])]) ifTrue: ["We're really at the end of a real run." runLength := text runLengthFor: (lastIndex := lastIndex + 1). lineStop := characterIndex "scanning for index" ifNil: [line last]. "scanning for point". (runStopIndex := lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex := lineStop]. self setStopConditions. ^false]. self retrieveLastCharacterWidth. (characterIndex == nil and: [lastIndex = line last]) ifTrue: [characterPoint x > (destX + (lastCharacterWidth // 2)) ifTrue: [ "Correct for clicking right half of last character in line means selecting AFTER the char" lastIndex := lastIndex + 1. lastCharacterWidth := 0. characterPoint := destX + lastCharacterWidth @ destY. ^true]]. characterPoint := destX @ destY. characterIndex ~~ nil ifTrue: ["If scanning for an index and we've stopped on that index, then we back destX off by the width of the character stopped on (it will be pointing at the right side of the character) and return" runStopIndex = characterIndex ifTrue: [characterPoint := destX - lastCharacterWidth @ destY. ^true]. "Otherwise the requested index was greater than the length of the string. Return string size + 1 as index, indicate further that off the string by setting character to nil and the extent to 0." lastIndex := lastIndex + 1. lastCharacterWidth := 0. ^true]. "Scanning for a point and either off the end of the line or off the end of the string." runStopIndex = text size ifTrue: ["off end of string" lastIndex := lastIndex + 1. lastCharacterWidth := 0. ^true]. "just off end of line without crossing x" lastIndex := lastIndex + 1. ^true! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'nice 10/22/2013 20:50'! characterBlockAtPoint: aPoint index: index in: textLine "This method is the Morphic characterBlock finder. It combines MVC's characterBlockAtPoint:, -ForIndex:, and buildCharacterBlockIn:" | runLength lineStop stopCondition | line := textLine. rightMargin := line rightMargin. lastIndex := line first. self setStopConditions. "also sets font" characterIndex := index. " == nil means scanning for point" characterPoint := aPoint. (characterPoint isNil or: [characterPoint y > line bottom]) ifTrue: [characterPoint := line bottomRight]. destX := leftMargin := line leftMarginForAlignment: alignment. destY := line top. (text isEmpty or: [(characterPoint y < destY or: [characterPoint x < destX]) or: [characterIndex notNil and: [characterIndex < line first]]]) ifTrue: [^ (CharacterBlock new stringIndex: line first text: text topLeft: destX@destY extent: 0 @ textStyle lineGrid) textLine: line]. runLength := text runLengthFor: line first. lineStop := characterIndex "scanning for index" ifNil: [ line last ]. "scanning for point" runStopIndex := lastIndex + (runLength - 1) min: lineStop. lastCharacterWidth := 0. spaceCount := 0. [ stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x. "see setStopConditions for stopping conditions for character block operations." self perform: stopCondition ] whileFalse. characterIndex ifNil: ["Result for characterBlockAtPoint: " ^ (CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + (font descentKern @ 0) extent: lastCharacterWidth @ line lineHeight - (font baseKern @ 0)) textLine: line] ifNotNil: ["Result for characterBlockForIndex: " ^ (CharacterBlock new stringIndex: characterIndex text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) extent: lastCharacterWidth @ line lineHeight) textLine: line]! ! !CharacterBlockScanner methodsFor: 'private' stamp: 'nice 10/3/2013 14:57'! retrieveLastCharacterWidth | lastCharacter | lastIndex > text size ifTrue: [^lastCharacterWidth := 0]. specialWidth ifNotNil: [^lastCharacterWidth := specialWidth]. lastCharacter := text at: lastIndex. (lastCharacter charCode >= 256 or: [(stopConditions at: lastCharacter charCode + 1) isNil]) ifTrue: [lastCharacterWidth := font widthOf: (text at: lastIndex)]. "if last character was a stop condition, then the width is already set" ^lastCharacterWidth! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'nice 10/8/2013 22:40'! paddedSpace "When the line is justified, the spaces will not be the same as the font's space character. A padding of extra space must be considered in trying to find which character the cursor is pointing at. Answer whether the scanning has crossed the cursor." | pad | spaceCount := spaceCount + 1. pad := line justifiedPadFor: spaceCount font: font. lastCharacterWidth := spaceWidth + pad. (destX + lastCharacterWidth) >= characterPoint x ifTrue: [^self crossedX]. lastIndex := lastIndex + 1. destX := destX + lastCharacterWidth + kern. pendingKernX := 0. ^ false ! ! !CharacterBlockScanner methodsFor: 'private' stamp: 'nice 10/6/2013 14:55'! placeEmbeddedObject: anchoredMorph "Workaround: The following should really use #textAnchorType" | w | anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. w := anchoredMorph width. specialWidth := w. (destX + w > characterPoint x) ifTrue: [^false]. destX := destX + w + kern. ^ true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'nice 10/2/2013 02:07'! crossedX "Text display has wrapping. The scanner just found a character past the x location of the cursor. We know that the cursor is pointing at a character or before one." self retrieveLastCharacterWidth. characterPoint x <= (destX + (lastCharacterWidth // 2)) ifTrue: [characterPoint := destX @ destY. ^true]. lastIndex >= line last ifTrue: [characterPoint := destX @ destY. ^true]. "Pointing past middle of a character, return the next character." lastIndex := lastIndex + 1. characterPoint := destX + lastCharacterWidth + kern @ destY. ^ true! ! !CharacterBlockScanner methodsFor: 'text attributes' stamp: 'hmm 2/2/2001 15:07'! indentationLevel: anInteger super indentationLevel: anInteger. nextLeftMargin := leftMargin. indentationLevel timesRepeat: [ nextLeftMargin := textStyle nextTabXFrom: nextLeftMargin leftMargin: leftMargin rightMargin: rightMargin]! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:32'! setFont specialWidth := nil. super setFont! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'nice 10/1/2013 01:12'! cr "Answer a CharacterBlock that specifies the current location of the mouse relative to a carriage return stop condition that has just been encountered. The ParagraphEditor convention is to denote selections by CharacterBlocks, sometimes including the carriage return (cursor is at the end) and sometimes not (cursor is in the middle of the text)." ((characterIndex ~= nil and: [characterIndex > text size]) or: [(line last = text size) and: [(destY + line lineHeight) < characterPoint y]]) ifTrue: ["When off end of string, give data for next character" destY := destY + line lineHeight. characterPoint := (nextLeftMargin ifNil: [leftMargin]) @ destY. (lastIndex < text size and: [(text at: lastIndex) = CR and: [(text at: lastIndex+1) = Character lf]]) ifTrue: [lastIndex := lastIndex + 2] ifFalse: [lastIndex := lastIndex + 1]. lastCharacterWidth := 0. ^ true]. characterPoint := destX @ destY. lastCharacterWidth := rightMargin - destX. ^true! ! !CharacterScanner commentStamp: 'nice 10/22/2013 20:04'! A CharacterScanner holds the state associated with scanning text. Subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms. Instance Variables alignment: destX: destY: emphasisCode: font: indentationLevel: kern: lastIndex: leftMargin: line: map: pendingKernX: rightMargin: runStopIndex: spaceCount: spaceWidth: stopConditions: text: textStyle: wantsColumnBreaks: xTable: alignment - an Integer encoding the alignment of text destX - horizontal position for next character (distance from left of composition area) destY - vertical position for next character (distance from top of composition area) emphasisCode - an Integer encoding the current text emphasis to use (bold, italic, ...) font - the current font used for measuring/composing/displaying characters indentationLevel - an Integer specifying a number of leading tabs to be inserted at beginning of new lines kern - a Number specifying additional horizontal spacing to place between characters (spacing is reduced when kern is negative) lastIndex - the Integer index of next character to be processed in the text leftMargin - a Number specifying the distance between left of composition zone and left of first character in the line. line - an object holding information about the line currently being displayed (like first and last index in text). Note: this is either a TextLine in Morphic, or TextLineInterval for ST80 compatibility map - an array mapping character code to glyph position. This is used by primitive 103 only, in case of ByteString. pendingKernX - a Number to be added to horizontal spacing of next char if ever it is in the same font than previous one. The inner scan loop is interrupted by a change of text run. But some changes won't change the font, so the kerning must be remembered and applied later. rightMargin - a Number specifying the distance between right of composition zone and right of last character in the line. runStopIndex - the Integer index of last character in current text run. spaceCount - the number of spaces encoutered so far in current line. This is useful for adjusting the spacing in cas of Justified alignment. spaceWidth - the width of space character in current font. stopConditions - an Array mapping a table of characters codes for which special actions are to be taken. These are typically control characters like carriage return or horizontal tab. text - the text to be measured/composed/displayed textStyle - an object holding a context for the text style (which set of font to use, which margins, etc...) wantsColumnBreaks - a Boolean indicating whether some special handling for multiple columns is requested. THIS ONLY MAKES SENSE IN CompositionScanner AND SHOULD BE MOVED TO THE SUBCLASS xTable - an array mapping character code to glyph x coordinate in form. This is used by primitive 103 only, in case of ByteString. Implementation note: accelerated Character scanning with primitive 103 requires following order for 5 first instance variables, please don't alter: destX lastIndex xTable map destY ! !CharacterScanner methodsFor: 'stop conditions' stamp: 'nice 10/6/2013 15:06'! embeddedObject pendingKernX := 0. text attributesAt: lastIndex do:[:attr| attr anchoredMorph ifNotNil:[ "Try to placeEmbeddedObject: - if it answers false, then there's no place left" (self placeEmbeddedObject: attr anchoredMorph) ifFalse:[^self crossedX]]]. "Note: if ever several objects are embedded on same character, only indent lastIndex once" lastIndex := lastIndex + 1. ^false! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 5/17/2000 18:20'! indentationLevel "return the number of tabs that are currently being placed at the beginning of each line" ^indentationLevel ifNil:[0]! ! !CharacterScanner methodsFor: 'scanning' stamp: 'nice 10/10/2013 02:17'! scanKernableMultibyteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX "this is a scanning method for multibyte characters in a WideString a font that does do character-pair kerning via widthAndKernedWidthOfLeft:right:into:" | ascii encoding nextDestX startEncoding floatDestX widthAndKernedWidth nextChar atEndOfRun char | lastIndex := startIndex. lastIndex > stopIndex ifTrue: [^self handleEndOfRunAt: stopIndex]. startEncoding := (sourceString at: startIndex) leadingChar. floatDestX := destX. widthAndKernedWidth := Array new: 2. atEndOfRun := false. [lastIndex <= stopIndex] whileTrue: [ char := sourceString at: lastIndex. encoding := char leadingChar. encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^#endOfRun]. ascii := char charCode. (ascii < 256 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stopConditions at: ascii + 1]. nextChar := (lastIndex + 1 <= stopIndex) ifTrue:[sourceString at: lastIndex + 1] ifFalse:[ atEndOfRun := true. "if there is a next char in sourceString, then get the kern and store it in pendingKernX" lastIndex + 1 <= sourceString size ifTrue:[sourceString at: lastIndex + 1] ifFalse:[ nil]]. font widthAndKernedWidthOfLeft: char right: nextChar into: widthAndKernedWidth. nextDestX := floatDestX + (widthAndKernedWidth at: 1). nextDestX > rightX ifTrue: [^#crossedX]. floatDestX := floatDestX + kern + (widthAndKernedWidth at: 2). atEndOfRun ifTrue:[ pendingKernX := (widthAndKernedWidth at: 2) - (widthAndKernedWidth at: 1). floatDestX := floatDestX - pendingKernX]. destX := floatDestX . lastIndex := lastIndex + 1. ]. ^self handleEndOfRunAt: stopIndex! ! !CharacterScanner methodsFor: 'scanning' stamp: 'nice 10/21/2013 22:39'! primScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta "Primitive. This is the inner loop of text display--but see scanCharactersFrom: to:rightX: which would get the string, stopConditions and displaying from the instance. March through source String from startIndex to stopIndex. If any character is flagged with a non-nil entry in stops, then return the corresponding value. Determine width of each character from xTable, indexed by map. If dextX would exceed rightX, then return stops at: 258. Advance destX by the width of the character. If stopIndex has been reached, then return stops at: 257. Optional. See Object documentation whatIsAPrimitive. Historical note: this primitive has been unusable since about Squeak 2.8 when the shape of the CharracterScanner class changed. It is left here as a reminder that the actual primitive still needs supporting in the VM to keep old images such as Scratch1.4 alive - tpr" ^self basicScanByteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX ! ! !CharacterScanner methodsFor: 'scanning' stamp: 'nice 10/21/2013 22:40'! scanByteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX "this is a scanning method for single byte characters in a ByteString a font that does not do character-pair kerning" ^self primScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stopConditions kern: kern ! ! !CharacterScanner methodsFor: 'scanning' stamp: 'nice 10/10/2013 02:16'! scanMultibyteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX "this is a scanning method for multibyte characters in a WideString a font that does not do character-pair kerning" | char ascii encoding nextDestX startEncoding | lastIndex := startIndex. startEncoding := (sourceString at: startIndex) leadingChar. [lastIndex <= stopIndex] whileTrue: [ char := sourceString at: lastIndex. encoding := char leadingChar. encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^#endOfRun]. ascii := char charCode. (ascii < 256 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stopConditions at: ascii + 1]. "bump nextDestX by the width of the current character" nextDestX := destX + (font widthOf: char). nextDestX > rightX ifTrue: [^#crossedX]. destX := nextDestX + kern . lastIndex := lastIndex + 1. ]. ^self handleEndOfRunAt: stopIndex! ! !CharacterScanner methodsFor: 'text attributes' stamp: 'nice 10/21/2013 22:36'! setActualFont: aFont "Set the basal font to an isolated font reference." xTable := aFont xTable. map := aFont characterToGlyphMap. font := aFont.! ! !CharacterScanner methodsFor: 'text attributes' stamp: 'ar 1/8/2000 14:28'! textColor: ignored "Overridden in DisplayScanner"! ! !CharacterScanner methodsFor: 'initialize' stamp: 'ls 1/14/2002 21:26'! initialize destX := destY := leftMargin := 0.! ! !CharacterScanner methodsFor: 'scanning' stamp: 'nice 10/22/2013 20:49'! scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX ^sourceString scanCharactersFrom: startIndex to: stopIndex with: self rightX: rightX font: font! ! !CharacterScanner methodsFor: 'text attributes' stamp: 'ar 12/15/2001 23:31'! setAlignment: style alignment := style. ! ! !CharacterScanner methodsFor: 'private' stamp: 'nice 10/5/2013 21:03'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. stopConditions := alignment = Justified ifTrue: [PaddedSpaceCondition] ifFalse: [DefaultStopConditions]! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:23'! leadingTab "return true if only tabs lie to the left" line first to: lastIndex do: [:i | (text at: i) == Tab ifFalse: [^ false]]. ^ true! ! !CharacterScanner methodsFor: 'scanning' stamp: 'nice 10/22/2013 20:50'! measureString: aString inFont: aFont from: startIndex to: stopIndex "Measure aString width in given font aFont. The string shall not include line breaking, tab or other control character." destX := destY := lastIndex := 0. pendingKernX := 0. font := aFont. kern := 0 - font baseKern. spaceWidth := font widthOf: Space. stopConditions := MeasuringStopConditions. self scanCharactersFrom: startIndex to: stopIndex in: aString rightX: 999999. ^destX! ! !CharacterScanner methodsFor: '*Multilingual-OtherLanguages' stamp: 'tpr 10/3/2013 12:25'! isBreakableAt: index in: sourceString in: encodingClass "check with the encoding whether the character at index is a breakable character. Only the JISX0208 & JapaneseEnvironments ever return true, so only the scanJapaneseCharacters... method calls this" ^ encodingClass isBreakableAt: index in: sourceString. ! ! !CharacterScanner methodsFor: 'text attributes' stamp: 'ar 1/8/2000 14:23'! indentationLevel: anInteger "set the number of tabs to put at the beginning of each line" indentationLevel := anInteger! ! !CharacterScanner methodsFor: 'text attributes' stamp: 'ar 1/8/2000 14:27'! addKern: kernDelta "Set the current kern amount." kern := kern + kernDelta! ! !CharacterScanner methodsFor: 'private' stamp: 'nice 10/8/2013 22:49'! advanceIfFirstCharOfLine lastIndex = line first ifTrue: [destX := destX + pendingKernX + (font widthOf: (text at: line first)). lastIndex := lastIndex + 1. pendingKernX := 0].! ! !CharacterScanner methodsFor: 'text attributes' stamp: 'ar 1/8/2000 14:28'! setFont: fontNumber "Set the font by number from the textStyle." self setActualFont: (textStyle fontAt: fontNumber)! ! !CharacterScanner methodsFor: 'stop conditions' stamp: 'tween 4/6/2007 11:16'! columnBreak pendingKernX := 0. ^true! ! !CharacterScanner methodsFor: 'stop conditions' stamp: 'nice 10/10/2013 01:49'! handleEndOfRunAt: stopIndex " make sure the lastIndex is set to stopIndex and then return the stopCondition for endOfRun; important for a couple of outside users" lastIndex := stopIndex. ^#endOfRun! ! !CharacterScanner methodsFor: 'text attributes' stamp: 'ar 1/8/2000 14:27'! addEmphasis: code "Set the bold-ital-under-strike emphasis." emphasisCode := emphasisCode bitOr: code! ! !CharacterScanner methodsFor: 'scanning' stamp: 'nice 10/21/2013 22:38'! basicScanByteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX "this is a scanning method for single byte characters in a ByteString a font that does not do character-pair kerning" | ascii nextDestX char | lastIndex := startIndex. [lastIndex <= stopIndex] whileTrue: [ "get the character value" char := sourceString at: lastIndex. ascii := char asciiValue + 1. "if there is an entry in 'stops' for this value, return it" (stopConditions at: ascii) ifNotNil: [^ stopConditions at: ascii]. "bump nextDestX by the width of the current character" nextDestX := destX + (font widthOf: char). "if the next x is past the right edge, return crossedX" nextDestX > rightX ifTrue: [^#crossedX]. "update destX and incorporate thr kernDelta" destX := nextDestX + kern. lastIndex := lastIndex + 1]. ^self handleEndOfRunAt: stopIndex ! ! !CharacterScanner methodsFor: 'scanning' stamp: 'tpr 10/3/2013 12:58'! scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta ^sourceString scanCharactersFrom: startIndex to: stopIndex with: self rightX: rightX font: font! ! !CharacterScanner methodsFor: 'private' stamp: 'nice 10/13/2013 22:10'! handleIndentation self indentationLevel timesRepeat: [ destX := self plainTab]! ! !CharacterScanner methodsFor: '*Multilingual-OtherLanguages' stamp: 'nice 10/10/2013 02:17'! scanJapaneseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX "this is a scanning method for multibyte Japanese characters in a WideString - hence the isBreakable:in:in: a font that does not do character-pair kerning " | ascii encoding nextDestX startEncoding char charset | lastIndex := startIndex. lastIndex > stopIndex ifTrue: [^self handleEndOfRunAt: stopIndex]. startEncoding := (sourceString at: startIndex) leadingChar. charset := EncodedCharSet charsetAt: startEncoding. [lastIndex <= stopIndex] whileTrue: [ char := sourceString at: lastIndex. encoding := char leadingChar. encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^#endOfRun]. ascii := char charCode. (encoding = 0 and: [ascii < 256 and:[(stopConditions at: ascii + 1) ~~ nil]]) ifTrue: [^ stopConditions at: ascii + 1]. (self isBreakableAt: lastIndex in: sourceString in: charset) ifTrue: [ self registerBreakableIndex]. nextDestX := destX + (font widthOf: char). nextDestX > rightX ifTrue: [^#crossedX]. destX := nextDestX + kern. lastIndex := lastIndex + 1. ]. ^self handleEndOfRunAt: stopIndex! ! !CharacterScanner methodsFor: 'private' stamp: 'nice 10/6/2013 14:46'! placeEmbeddedObject: anchoredMorph "Place the anchoredMorph or return false if it cannot be placed" ^ true! ! !CharacterScanner methodsFor: '*Multilingual-OtherLanguages' stamp: 'yo 12/20/2002 16:15'! registerBreakableIndex "Record left x and character index of the line-wrappable point. The default implementation here does nothing." ^ false. ! ! !CharacterScanner methodsFor: 'private' stamp: 'nice 10/13/2013 22:07'! plainTab "This is the basic method of adjusting destX for a tab. Answer the next destX" pendingKernX := 0. ^(alignment = Justified and: [self leadingTab not]) ifTrue: "embedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin].! ! !CharacterScanner methodsFor: 'private' stamp: 'nice 10/22/2013 20:07'! setFont | priorFont | "Set the font and other emphasis." priorFont := font. text ifNotNil:[ emphasisCode := 0. kern := 0. indentationLevel := 0. alignment := textStyle alignment. font := nil. (text attributesAt: lastIndex forStyle: textStyle) do: [:att | att emphasizeScanner: self]]. font ifNil: [self setFont: textStyle defaultFontIndex]. self setActualFont: (font emphasized: emphasisCode). priorFont ifNotNil: [ font = priorFont ifTrue:[ "font is the same, perhaps the color has changed? We still want kerning between chars of the same font, but of different color. So add any pending kern to destX" destX := destX + (pendingKernX ifNil:[0])]. destX := destX + priorFont descentKern]. pendingKernX := 0. "clear any pending kern so there is no danger of it being added twice" destX := destX - font descentKern. "NOTE: next statement should be removed when clipping works" leftMargin ifNotNil: [destX := destX max: leftMargin]. kern := kern - font baseKern. "Install various parameters from the font." spaceWidth := font widthOf: Space.! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'! text: t textStyle: ts text := t. textStyle := ts! ! !CharacterScanner methodsFor: 'scanning' stamp: 'nice 10/10/2013 02:19'! scanKernableByteCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX "this is a scanning method for single byte characters in a ByteString a font that does do character-pair kerning via widthAndKernedWidthOfLeft:right:into:" | ascii nextDestX char floatDestX widthAndKernedWidth nextCharOrNil atEndOfRun | lastIndex := startIndex. floatDestX := destX. widthAndKernedWidth := Array new: 2. atEndOfRun := false. [lastIndex <= stopIndex] whileTrue: [ "get the character value" char := sourceString at: lastIndex. ascii := char asciiValue + 1. "if there is an entry in 'stops' for this value, return it" (stopConditions at: ascii) ifNotNil: [^ stopConditions at: ascii]. "get the next character..." nextCharOrNil := lastIndex + 1 <= stopIndex ifTrue: [sourceString at: lastIndex + 1] ifFalse: ["if we're at or past the stopIndex, see if there is anything in the full string" atEndOfRun := true. lastIndex + 1 <= sourceString size ifTrue: [sourceString at: lastIndex + 1]]. "get the font's kerning info for the pair of current character and next character" "for almost all fonts in common use this is a waste of time since they don't support pair kerning and both values are #widthOf: char" font widthAndKernedWidthOfLeft: char right: nextCharOrNil into: widthAndKernedWidth. "bump nextDestX by the width of the current character" nextDestX := floatDestX + (widthAndKernedWidth at: 1). "if the next x is past the right edge, return crossedX" nextDestX > rightX ifTrue: [^ #crossedX]. "bump floatDestX by the *kerned* width of the current character, which is where the *next* char will go" floatDestX := floatDestX + kern + (widthAndKernedWidth at: 2). "if we are at the end of this run we keep track of the character-kern-delta for possible later use and then rather insanely remove that character-kern-delta from floatDestX, making it equivalent to (old floatDestX) + kernDelta + width-of-character - no idea why" atEndOfRun ifTrue: [pendingKernX := (widthAndKernedWidth at: 2) - (widthAndKernedWidth at: 1). floatDestX := floatDestX - pendingKernX]. "save the next x for next time around the loop" destX := floatDestX. lastIndex := lastIndex + 1]. ^self handleEndOfRunAt: stopIndex ! ! !CharacterScanner class methodsFor: 'class initialization' stamp: 'nice 10/29/2013 02:26'! initialize " CharacterScanner initialize " | a | a := Array new: 258. a at: 1 + 1 put: #embeddedObject. a at: Tab asciiValue + 1 put: #tab. a at: CR asciiValue + 1 put: #cr. a at: Character lf asciiValue + 1 put: #cr. "Note: following two codes are used only by primitive 103 for accelerated Character scanning" a at: 257 put: #endOfRun. a at: 258 put: #crossedX. DefaultStopConditions := a copy. CompositionStopConditions := a copy. CompositionStopConditions at: Space asciiValue + 1 put: #space. ColumnBreakStopConditions := CompositionStopConditions copy. ColumnBreakStopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak. PaddedSpaceCondition := a copy. PaddedSpaceCondition at: Space asciiValue + 1 put: #paddedSpace. MeasuringStopConditions := (Array new: 258) at: 257 put: #endOfRun; at: 258 put: #crossedX; yourself! ! !CharacterSet commentStamp: ''! A set of characters. Lookups for inclusion are very fast.! !CharacterSet methodsFor: 'conversion' stamp: 'StephaneDucasse 11/4/2011 09:54'! asString "Convert the receiver into a String" ^String new: self size streamContents: [ :s | self do: [ :ch | s nextPut: ch]].! ! !CharacterSet methodsFor: 'conversion' stamp: 'nice 3/23/2007 02:28'! byteComplement "return a character set containing precisely the single byte characters the receiver does not" | set | set := CharacterSet allCharacters. self do: [ :c | set remove: c ]. ^set! ! !CharacterSet methodsFor: 'comparison' stamp: 'ls 8/17/1998 20:46'! hash ^self byteArrayMap hash! ! !CharacterSet methodsFor: 'collection ops' stamp: 'nice 5/9/2006 23:02'! size ^map sum! ! !CharacterSet methodsFor: 'conversion' stamp: 'nice 11/20/2007 00:19'! complement "return a character set containing precisely the characters the receiver does not" ^CharacterSetComplement of: self copy! ! !CharacterSet methodsFor: 'collection ops' stamp: 'nice 12/10/2009 19:20'! remove: aCharacter ifAbsent: aBlock (self includes: aCharacter) ifFalse: [^aBlock value]. ^self remove: aCharacter! ! !CharacterSet methodsFor: 'collection ops' stamp: 'nice 12/9/2009 15:29'! findFirstInByteString: aByteString startingAt: startIndex "Double dispatching: since we know this is a ByteString, we can use a superfast primitive using a ByteArray map with 0 slots for byte characters not included and 1 for byte characters included in the receiver." ^ByteString findFirstInString: aByteString inSet: self byteArrayMap startingAt: startIndex! ! !CharacterSet methodsFor: 'private' stamp: 'ls 8/17/1998 20:35'! byteArrayMap "return a ByteArray mapping each ascii value to a 1 if that ascii value is in the set, and a 0 if it isn't. Intended for use by primitives only" ^map! ! !CharacterSet methodsFor: 'private' stamp: 'nice 5/9/2006 23:22'! wideCharacterMap "used for comparing with WideCharacterSet" | wide | wide := WideCharacterSet new. wide addAll: self. ^wide wideCharacterMap! ! !CharacterSet methodsFor: 'collection ops' stamp: 'nice 5/9/2006 23:09'! includes: aCharacter aCharacter asciiValue >= 256 ifTrue: ["Guard against wide characters" ^false]. ^(map at: aCharacter asciiValue + 1) > 0! ! !CharacterSet methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:44'! initialize super initialize. map := ByteArray new: 256 withAll: 0.! ! !CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:58'! = anObject ^self species == anObject species and: [ self byteArrayMap = anObject byteArrayMap ]! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ar 4/9/2005 22:37'! do: aBlock "evaluate aBlock with each character in the set" Character allByteCharacters do: [ :c | (self includes: c) ifTrue: [ aBlock value: c ] ] ! ! !CharacterSet methodsFor: 'collection ops' stamp: 'MarianoMartinezPeck 9/22/2011 17:12'! add: aCharacter "I automatically become a WideCharacterSet if you add a wide character to myself" aCharacter asciiValue >= 256 ifTrue: [| wide | wide := WideCharacterSet new. wide addAll: self. wide add: aCharacter. self becomeForward: wide. ^aCharacter]. map at: aCharacter asciiValue + 1 put: 1. ^aCharacter! ! !CharacterSet methodsFor: 'collection ops' stamp: 'nice 5/9/2006 23:20'! remove: aCharacter aCharacter asciiValue >= 256 ifFalse: ["Guard against wide characters" map at: aCharacter asciiValue + 1 put: 0]. ^aCharacter! ! !CharacterSet methodsFor: 'testing' stamp: 'nice 5/9/2006 23:23'! hasWideCharacters ^false! ! !CharacterSet methodsFor: 'copying' stamp: 'nice 10/5/2009 08:52'! postCopy super postCopy. map := map copy! ! !CharacterSet methodsFor: 'removing' stamp: 'klub 9/14/2009 19:07'! removeAll map atAllPut: 0! ! !CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/18/1998 00:40'! separators "return a set containing just the whitespace characters" | set | set := self empty. set addAll: Character separators. ^set! ! !CharacterSet class methodsFor: 'instance creation' stamp: 'nk 8/3/2004 06:54'! empty "return an empty set of characters" ^self new! ! !CharacterSet class methodsFor: 'instance creation' stamp: 'ls 1/3/1999 12:52'! newFrom: aCollection | newCollection | newCollection := self new. newCollection addAll: aCollection. ^newCollection! ! !CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/17/1998 20:42'! allCharacters "return a set containing all characters" | set | set := self empty. 0 to: 255 do: [ :ascii | set add: (Character value: ascii) ]. ^set! ! !CharacterSet class methodsFor: 'accessing' stamp: 'nice 11/16/2009 11:22'! crlf CrLf ifNil: [CrLf := self with: Character cr with: Character lf]. ^CrLf! ! !CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/18/1998 00:40'! nonSeparators "return a set containing everything but the whitespace characters" ^self separators complement! ! !CharacterSetComplement commentStamp: 'nice 8/31/2008 14:53'! CharacterSetComplement is a space efficient implementation of (CharacterSet complement) taking care of WideCharacter (code > 255) However, it will maintain a byteArrayMap for character <= 255 in a cache keeping instance variables: absent contains character that are not in the set (i.e. my complement) byteArrayMapCache cache this information because it has to be used in tight loops where efficiency matters! !CharacterSetComplement methodsFor: 'comparing' stamp: 'marcus.denker 8/11/2008 20:45'! hash ^absent hash bitXor: self class hash! ! !CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 3/23/2007 02:10'! size "Is this 2**32-absent size ?" ^self shouldNotImplement! ! !CharacterSetComplement methodsFor: 'printing' stamp: 'nice 11/19/2007 23:55'! storeOn: aStream "Store a description of the elements of the complement rather than self." aStream nextPut: $(. absent storeOn: aStream. aStream nextPut: $); space; nextPutAll: #complement.! ! !CharacterSetComplement methodsFor: 'initialization' stamp: 'nice 8/31/2008 14:56'! complement: aCharacterSet "initialize with the complement" byteArrayMapCache := nil. absent := aCharacterSet. ! ! !CharacterSetComplement methodsFor: 'converting' stamp: 'nice 3/23/2007 02:08'! complement "return a character set containing precisely the characters the receiver does not" ^absent copy! ! !CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 12/10/2009 19:20'! remove: aCharacter ifAbsent: aBlock (self includes: aCharacter) ifFalse: [^aBlock value]. ^self remove: aCharacter! ! !CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 3/23/2007 02:15'! reject: aBlock "Implementation note: rejecting present is selecting absent" ^(absent select: aBlock) complement! ! !CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 12/11/2009 09:03'! findFirstInByteString: aByteString startingAt: startIndex "Double dispatching: since we know this is a ByteString, we can use a superfast primitive using a ByteArray map with 0 slots for byte characters not included and 1 for byte characters included in the receiver." ^ByteString findFirstInString: aByteString inSet: self byteArrayMap startingAt: startIndex! ! !CharacterSetComplement methodsFor: 'private' stamp: 'nice 8/31/2008 14:28'! byteArrayMap "return a ByteArray mapping each ascii value to a 1 if that ascii value is in the set, and a 0 if it isn't. Intended for use by primitives only" ^byteArrayMapCache ifNil: [byteArrayMapCache := absent byteArrayMap collect: [:i | 1 - i]]! ! !CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 3/23/2007 02:07'! includes: aCharacter ^(absent includes: aCharacter) not! ! !CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 3/23/2007 02:15'! select: aBlock "Implementation note: selecting present is rejecting absent" ^(absent reject: aBlock) complement! ! !CharacterSetComplement methodsFor: 'comparing' stamp: 'nice 3/23/2007 02:19'! = anObject "Implementation note: we do not test if equal to a WideCharacterSet, because it is unlikely that WideCharacterSet is as complete as self" ^self class == anObject class and: [ absent = anObject complement ]! ! !CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 3/23/2007 02:11'! do: aBlock "evaluate aBlock with each character in the set. don't do it, there are too many..." self shouldNotImplement! ! !CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 8/31/2008 14:56'! add: aCharacter "a character is present if not absent, so adding a character is removing it from the absent" (absent includes: aCharacter) ifTrue: [byteArrayMapCache := nil. absent remove: aCharacter]. ^ aCharacter! ! !CharacterSetComplement methodsFor: 'testing' stamp: 'nice 3/23/2007 02:12'! hasWideCharacters "This is a guess that absent is not holding each and every possible wideCharacter..." ^true! ! !CharacterSetComplement methodsFor: 'copying' stamp: 'nice 10/5/2009 08:52'! postCopy super postCopy. absent := absent copy! ! !CharacterSetComplement methodsFor: 'printing' stamp: 'nice 11/19/2007 23:54'! printOn: aStream "Print a description of the complement rather than self. Rationale: self would be too long to print." aStream nextPut: $(. absent printOn: aStream. aStream nextPut: $); space; nextPutAll: #complement.! ! !CharacterSetComplement methodsFor: 'collection ops' stamp: 'nice 8/31/2008 14:54'! remove: aCharacter "This means aCharacter is now absent from myself. It must be added to my absent." byteArrayMapCache := nil. ^absent add: aCharacter! ! !CharacterSetComplement methodsFor: 'collection ops' stamp: 'MarianoMartinezPeck 9/22/2011 17:16'! removeAll self becomeForward: CharacterSet new! ! !CharacterSetComplement class methodsFor: 'instance creation' stamp: 'nice 3/23/2007 02:25'! of: aCharacterSet "answer the complement of aCharacterSet" ^ super new complement: aCharacterSet! ! !CharacterSetTest commentStamp: 'nice 11/20/2007 00:35'! CharacterSetTest holds tests for CharacterSet! !CharacterSetTest methodsFor: 'testing' stamp: 'nice 11/20/2007 00:38'! testCopy | theOriginal theCopy | theOriginal := CharacterSet newFrom: 'abc'. theCopy := theOriginal copy. theCopy remove: $a. ^self should: [theOriginal includes: $a] description: 'Changing the copy should not change the original'.! ! !CharacterTest commentStamp: ''! This is the unit test for the class Character. 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 - there is a chapter in the PharoByExample book (http://pharobyexample.org/) - the sunit class category! !CharacterTest methodsFor: 'tests' stamp: 'StephaneDucasse 3/28/2010 19:19'! testDigitValue "self debug: #testDigitValue" '0123456789ABCDEF' with: #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) do: [:char :value | self assert: char digitValue = value]. '0123456789' with: #(0 1 2 3 4 5 6 7 8 9) do: [:char :value | self assert: char digitValue = value]. ! ! !CharacterTest methodsFor: 'tests instance creation' stamp: 'CamilloBruni 8/31/2013 20:23'! testInstanceCreation self should: [ Character value: -1 ] raise: Error. Character value: 0. Character value: 256! ! !CharacterTest methodsFor: 'tests' stamp: 'MarcusDenker 4/30/2013 11:21'! testPrintStringAll Character allCharacters do: [ :each | self assert: (self class compiler evaluate: each printString) = each ].! ! !CharacterTest methodsFor: 'tests' stamp: 'CamilloBruni 10/21/2012 00:15'! testStoreString self assert: $a storeString = '$a'. self assert: $5 storeString = '$5'. self assert: $@ storeString = '$@'. self assert: Character cr storeString equals: 'Character cr'. self assert: Character lf storeString equals: 'Character lf'. self assert: Character space storeString equals: 'Character space'. self assert: (Character value: 0) storeString equals: 'Character null'. self assert: (Character value: 17) storeString equals: '(Character value: 17)'.! ! !CharacterTest methodsFor: 'tests instance creation' stamp: 'sd 6/5/2005 09:25'! testNew self should: [Character new] raise: Error.! ! !CharacterTest methodsFor: 'tests conversion' stamp: 'CamilloBruni 9/28/2012 14:50'! testAsUppercaseBasicAsciiRange | lowercase uppercase | lowercase := 'abcdefghijklmnopqrstuvwxyz123456789'. uppercase := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789'. lowercase withIndexDo: [ :char :index | self assert: char asUppercase equals: (uppercase at: index)]! ! !CharacterTest methodsFor: 'tests' stamp: 'StephaneDucasse 3/30/2010 18:34'! testCodePoint self assert: $A codePoint = 65. self assert: (Character codePoint: $a codePoint) = $a. self assert: (Character codePoint: 97) codePoint = 97.! ! !CharacterTest methodsFor: 'tests' stamp: 'MarcusDenker 4/30/2013 11:18'! testStoreStringAll Character allCharacters do: [ :each | self assert: (self class compiler evaluate: each storeString) = each ].! ! !CharacterTest methodsFor: 'tests conversion' stamp: 'CamilloBruni 9/28/2012 14:53'! testAsLowercaseBasicAsciiRange | lowercase uppercase | lowercase := 'abcdefghijklmnopqrstuvwxyz123456789'. uppercase := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ123456789'. uppercase withIndexDo: [ :char :index | self assert: char asLowercase equals: (lowercase at: index)]! ! !CharacterTest methodsFor: 'tests' stamp: 'StephaneDucasse 7/31/2010 19:47'! testPrintStringHex self assert: $a printStringHex = '61'. self assert: Character space printStringHex = '20'! ! !CharacterTest methodsFor: 'tests' stamp: 'CamilloBruni 10/21/2012 00:14'! testPrintString self assert: $a printString = '$a'. self assert: $5 printString = '$5'. self assert: $@ printString = '$@'. self assert: Character cr printString = 'Character cr'. self assert: Character lf printString = 'Character lf'. self assert: Character space printString = 'Character space'. self assert: (Character value: 0) printString = 'Character null'. self assert: (Character value: 17) printString = 'Character value: 17'.! ! !CharacterTest methodsFor: 'tests - various' stamp: 'CamilloBruni 8/31/2013 20:23'! testCharacterSeparators "Regression test" | result | result := '/' , Character separators. self assert: result size = (Character separators size + 1)! ! !CharacterTest methodsFor: 'tests' stamp: 'StephaneDucasse 7/31/2010 19:40'! testHex self assert: $a hex = '16r61'. self assert: Character space hex = '16r20'! ! !CheckBoxExample commentStamp: ''! A CheckBoxExample is a simple example of how to use CheckBoxes. CheckBoxExample new openWithSpec! !CheckBoxExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/1/2013 15:00'! container ^ container asSpecAdapter! ! !CheckBoxExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/1/2013 14:59'! button1 ^ button1! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/2/2012 01:01'! setActionsForButton3 button3 whenActivatedDo: [ container addMorph: morph3 ]. button3 whenDesactivatedDo: [ container removeMorph: morph3 ]! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/2/2012 01:01'! setActionsForButton2 button2 whenActivatedDo: [ container addMorph: morph2 ]. button2 whenDesactivatedDo: [ container removeMorph: morph2 ]! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/2/2012 01:01'! instantiateMorphs morph1 := Morph new color: Color red; width: 60; height: 20. morph2 := Morph new color: Color blue; width: 20; height: 60. morph3 := Morph new color: Color green; width: 50; height: 50.! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'CamilloBruni 9/22/2013 21:35'! initializeWidgets button1 := self newCheckBox. button2 := self newCheckBox. button3 := self newCheckBox. button1 label: 'Button 1'. button2 label: 'Button 2'. button3 label: 'Button 3'. self setFocus.! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/2/2012 01:01'! setGroup RadioButtonGroup new addRadioButton: button1; addRadioButton: button2; addRadioButton: button3; default: button1. ! ! !CheckBoxExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/1/2013 14:59'! button2 ^ button2! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 22:55'! initialize container := PanelMorph new. container changeTableLayout; listDirection: #bottomToLeft. self instantiateMorphs. super initialize.! ! !CheckBoxExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/2/2012 01:01'! button3 ^ button3! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:23'! initializePresenter self setActionsForButton1. self setActionsForButton2. self setActionsForButton3. ! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/2/2012 01:01'! setFocus self focusOrder add: button1; add: button2; add: button3. ! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/2/2012 01:01'! setActionsForButton1 button1 whenActivatedDo: [ container addMorph: morph1 ]. button1 whenDesactivatedDo: [ container removeMorph: morph1 ]! ! !CheckBoxExample class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2014 17:14'! defaultSpec ^ { #ContainerModel. #add:. { self topSpec. #layout:. #(#SpecLayoutFrame bottomFraction: 0 bottomOffset: 20) }. #add:. {{#model . #container } . #layout: . #(#SpecLayoutFrame topOffset: 22) } }! ! !CheckBoxExample class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/5/2012 17:17'! title ^ 'CheckBox Example'! ! !CheckBoxExample class methodsFor: 'example' stamp: 'HernanMoralesDurand 2/3/2014 00:07'! example "self example" CheckBoxExample new openWithSpec. ! ! !CheckBoxExample class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2014 17:14'! topSpec ^ { #ContainerModel. #add:. {{#model . #button1 } . #layout:. #(#SpecLayoutFrame rightFraction: 0.33 bottomFraction: 0 bottomOffset: 25)}. #add:. {{#model . #button2 } . #layout:. #(#SpecLayoutFrame leftFraction: 0.33 rightFraction: 0.66 bottomFraction: 0 bottomOffset: 25)}. #add:. {{#model . #button3 } . #layout:. #(#SpecLayoutFrame leftFraction: 0.66 bottomFraction: 0 bottomOffset: 25)}}! ! !CheckBoxExample class methodsFor: 'specs' stamp: 'bvr 6/4/2012 17:27'! defaultSpec2 ^ { #Panel. #changeTableLayout. #listDirection:. #rightToLeft. #addMorph:. {#model. #button1.}. #addMorph:. {#model. #button2.}. #addMorph:. {#model. #button3.}. #hResizing:. #shrinkWrap. #vResizing:. #shrinkWrap. }! ! !CheckBoxModel commentStamp: ''! A CheckboxModel is a spec model for Checkbox You can also have a look at CheckBoxExample for a full example of how to use them with a group. ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! state: aBoolean "Set if the checkbox is activated or not" stateHolder value: aBoolean! ! !CheckBoxModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 17:02'! whenLabelClickableChanged: aBlock "A block performed when the label click is activated or descativated" labelClickableHolder whenChangedDo: aBlock ! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! labelClickable: aBoolean "Set if the label can be clicked to select the checkbox" labelClickableHolder value: aBoolean! ! !CheckBoxModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 01:40'! whenChangedDo: aBlock "This method is used to propagate the event that I have changed" stateHolder whenChangedDo: aBlock! ! !CheckBoxModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 16:59'! whenDesactivationActionChanged: aBlock "A block performed when the desactivation action changed" actionWhenDesactivatedHolder whenChangedDo: aBlock ! ! !CheckBoxModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/12/2012 17:51'! whenDesactivatedDo: aBlock "This method is used to propagate the event that I have been desactivated" stateHolder whenChangedDo: [:bool | bool ifFalse: aBlock ]! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! labelClickable "Return true if the label can be clicked to select the checkbox" ^ labelClickableHolder value! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 17:33'! labelOnLeft ^ self changed: #labelOnLeft with: #()! ! !CheckBoxModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. actionWhenActivatedHolder := [] asReactiveVariable. actionWhenDesactivatedHolder := [] asReactiveVariable. enabledHolder := true asReactiveVariable. stateHolder := false asReactiveVariable. labelClickableHolder := true asReactiveVariable. labelHolder := '' asReactiveVariable. stateHolder whenChangedDo: [:bool | bool ifTrue: actionWhenActivatedHolder value ifFalse: actionWhenDesactivatedHolder value. self changed: #state ]. labelClickableHolder whenChangedDo: [:aBoolean | self changed: { #labelClickable: . aBoolean } ]. labelHolder whenChangedDo: [:label | self changed: { #label: . label } ].! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! state "Return the current state of the checkBox" ^ stateHolder value! ! !CheckBoxModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 17:01'! whenLabelChanged: aBlock "A block performed when the label changed" labelHolder whenChangedDo: aBlock ! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! label ^ labelHolder value! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 17:33'! labelOnRight ^ self changed: #labelOnRight with: #()! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! desactivationAction: aBlock "This method is used to set the action to perform when I am desactivated" actionWhenDesactivatedHolder value: aBlock! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! activationAction: aBlock "This method is used to set the action to perform when I am activated" actionWhenActivatedHolder value: aBlock! ! !CheckBoxModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 16:52'! whenActivationActionChanged: aBlock "A block performed when the activation action changed" actionWhenActivatedHolder whenChangedDo: aBlock ! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 17:50'! click "Simulate a click on the checkbox Used when the checkboc is a list item" self toggleState! ! !CheckBoxModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/12/2012 17:51'! whenActivatedDo: aBlock "This method is used to propagate the event that I have been activated" stateHolder whenChangedDo: [:bool | bool ifTrue: aBlock ]! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! label: aString "Set the label of the checkbox" labelHolder value: aString.! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 17:51'! toggleState "Toogle the current state of the checkbox" self state: self state not! ! !CheckBoxModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 13:38'! defaultSpec ^ #(CheckBoxAdapter adapt: #(model))! ! !CheckBoxModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 7/13/2012 02:00'! title ^ 'Checkbox Button'! ! !CheckBoxModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:20'! adapterName ^ #CheckBoxAdapter! ! !CheckboxButtonMorph commentStamp: 'gvc 5/23/2007 12:19'! Checkbox/radio - button only.! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'DamienCassou 4/27/2012 14:28'! imageFromName: aSymbol ^ self images at: aSymbol ifPresent: [:block | block value] ifAbsent: []! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 19:17'! themeChanged "Update the on image." self onImage: (self isRadioButton ifTrue: [self theme radioButtonMarkerForm] ifFalse: [self theme checkboxMarkerForm]). self adoptPaneColor: self paneColor. super themeChanged! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 16:04'! enabled "Answer the value of enabled" ^ enabled! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 11:38'! colorToUse "Answer the color we should use." ^self paneColor! ! !CheckboxButtonMorph methodsFor: 'event handling' stamp: 'MarcusDenker 2/15/2013 13:28'! mouseUp: evt "Allow on:send:to: to set the response to events other than actWhen" self enabled ifFalse: [^self perform: #mouseUp: withArguments: {evt} inSuperclass: Morph]. actWhen == #buttonUp ifFalse: [^self perform: #mouseUp: withArguments: {evt} inSuperclass: Morph]. (self containsPoint: evt cursorPoint) ifTrue: [state == #repressed ifTrue: [self state: #off] ifFalse: [self state: #on]. self doButtonAction: evt]. ^self perform: #mouseUp: withArguments: {evt} inSuperclass: Morph! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:18'! repressedImage: anObject "Set the value of repressedImage. This is shown when pressed after being off." repressedImage := anObject. self invalidRect: self bounds! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: ''! enabledString "Answer the string to be shown in a menu to represent the 'enabled' status" ^ (self enabled) -> 'enabled' translated! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: ''! addToggleItemsToHaloMenu: aCustomMenu "Add toggle-items to the halo menu" super addToggleItemsToHaloMenu: aCustomMenu. aCustomMenu addUpdating: #enabledString target: self action: #toggleEnabled! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 12/8/2008 19:17'! adoptPaneColor: paneColor "Pass on to the border too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self fillStyle: self fillStyleToUse. self borderStyle: self borderStyleToUse. self cornerStyle: (self isRadioButton ifTrue: [self theme radioButtonCornerStyleFor: self] ifFalse: [self theme checkboxCornerStyleFor: self])! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/29/2008 22:04'! checkboxFillStyleToUse "Answer the fillStyle that should be used for the receiver when it is a checkbox." ^self selected ifTrue: [self enabled ifTrue: [self theme checkboxButtonSelectedFillStyleFor: self] ifFalse: [self theme checkboxButtonSelectedDisabledFillStyleFor: self]] ifFalse: [self enabled ifTrue: [self theme checkboxButtonNormalFillStyleFor: self] ifFalse: [self theme checkboxButtonDisabledFillStyleFor: self]]! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/29/2008 22:05'! checkboxBorderStyleToUse "Answer the borderStyle that should be used for the receiver when it is a checkbox." ^self selected ifTrue: [self enabled ifTrue: [self theme checkboxButtonSelectedBorderStyleFor: self] ifFalse: [self theme checkboxButtonSelectedDisabledBorderStyleFor: self]] ifFalse: [self enabled ifTrue: [self theme checkboxButtonNormalBorderStyleFor: self] ifFalse: [self theme checkboxButtonDisabledBorderStyleFor: self]]! ! !CheckboxButtonMorph methodsFor: 'initialization' stamp: 'gvc 10/25/2007 17:36'! initialize "Initialize the receiver." super initialize. self isRadioButton: false; enabled: true; onImage: self theme checkboxMarkerForm; fillStyle: self fillStyleToUse; borderStyle: self borderStyleToUse! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 11/5/2007 15:34'! borderWidth: bw "Use narrowest image dimension." | newExtent | super borderWidth: bw. newExtent := 2 * bw + image extent min asPoint. bounds extent = newExtent ifFalse: [super extent: newExtent]! ! !CheckboxButtonMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 14:16'! enable "Enable the receiver." self enabled: true! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: ''! toggleEnabled "Toggle the enabled state." self enabled: self enabled not! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/29/2008 21:58'! radioFillStyleToUse "Answer the fillStyle that should be used for the receiver when it is a radio button." ^self selected ifTrue: [self enabled ifTrue: [self theme radioButtonSelectedFillStyleFor: self] ifFalse: [self theme radioButtonSelectedDisabledFillStyleFor: self]] ifFalse: [self enabled ifTrue: [self theme radioButtonNormalFillStyleFor: self] ifFalse: [self theme radioButtonDisabledFillStyleFor: self]]! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2009 14:11'! enabled: anObject "Set the value of enabled" enabled = anObject ifTrue: [^self]. enabled := anObject. self changed: #enabled. self adoptPaneColor: self paneColor; changed! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/27/2009 11:54'! borderStyle: newStyle "Use narrowest image dimension." | newExtent | self borderStyle = newStyle ifTrue: [^self]. super borderStyle: newStyle. newExtent := 2 * newStyle width + image extent min asPoint. bounds extent = newExtent ifFalse: [self extent: newExtent]! ! !CheckboxButtonMorph methodsFor: 'event handling' stamp: 'GaryChambers 10/17/2011 16:29'! mouseMove: evt "Check for straying." self perform: #mouseMove: withArguments: {evt} inSuperclass: Morph. self enabled ifFalse: [^self]. (self containsPoint: evt cursorPoint) ifTrue: [state == #on ifTrue: [self state: #repressed]. state == #off ifTrue: [self state: #pressed]] ifFalse: [state == #repressed ifTrue: [self state: #on]. state == #pressed ifTrue: [self state: #off]]! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 11/5/2007 15:28'! image: anImage "Fixed to take account of border width. Use narrowest dimanesion of image to allow a little flexibility." image := anImage depth = 1 ifTrue: [ColorForm mappingWhiteToTransparentFrom: anImage] ifFalse: [anImage]. self extent: 2 * self borderWidth + image extent min asPoint. self changed! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 2/29/2008 21:53'! state: newState "Change the image and invalidate the rect." newState == state ifTrue: [^ self]. state := newState. self adoptPaneColor: self paneColor; changed! ! !CheckboxButtonMorph methodsFor: 'protocol' stamp: 'gvc 12/8/2008 19:16'! beRadioButton "Change the images and round the border to be a radio button." self isRadioButton: true; onImage: self theme radioButtonMarkerForm; cornerStyle: (self theme radioButtonCornerStyleFor: self); borderStyle: self borderStyleToUse! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 18:00'! selected: aBoolean "Set the state taking account of the intermediate states." (self state == #pressed or: [self state == #repressed]) ifTrue: [self state: (aBoolean ifTrue: [#repressed] ifFalse: [#pressed])] ifFalse: [self state: (aBoolean ifTrue: [#on] ifFalse: [#off])]! ! !CheckboxButtonMorph methodsFor: 'drawing' stamp: 'GaryChambers 11/16/2011 15:39'! drawOn: aCanvas "Draw the image for the current state." |img| aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle. img := self imageToUse. img ifNotNil: [ aCanvas translucentImage: img at: self innerBounds center - (img extent // 2)]. ((self state == #pressed or: [self state == #repressed]) and: [image isNil]) ifTrue: [ aCanvas fillRectangle: self innerBounds fillStyle: (self paneColor alpha: 0.3)]. (self enabled not and: [self theme fadeCheckboxWhenDisabled]) ifTrue: [ aCanvas fillRectangle: self innerBounds fillStyle: (self paneColor alpha: 0.4)]! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'DamienCassou 4/27/2012 14:21'! imageToUse "Answer the image we should use." ^ self imageFromName: state! ! !CheckboxButtonMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 14:16'! disable "Disable the receiver." self enabled: false! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/25/2007 17:34'! isRadioButton: anObject "Set the value of isRadioButton" isRadioButton := anObject! ! !CheckboxButtonMorph methodsFor: 'protocol' stamp: 'gvc 12/8/2008 19:16'! beCheckbox "Change the images and square the border to be a checkbox." self isRadioButton: false; onImage: self theme checkboxMarkerForm; cornerStyle: (self theme checkboxCornerStyleFor: self); borderStyle: self borderStyleToUse! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/25/2006 17:46'! selected "Answer the state taking account of the intermediate states." ^self state == #repressed or: [self state == #on]! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/25/2007 17:34'! isRadioButton "Answer the value of isRadioButton" ^ isRadioButton! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 16:41'! state "Answer the state." ^state! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/29/2008 22:04'! radioBorderStyleToUse "Answer the borderStyle that should be used for the receiver when it is a radio button." ^self selected ifTrue: [self enabled ifTrue: [self theme radioButtonSelectedBorderStyleFor: self] ifFalse: [self theme radioButtonSelectedDisabledBorderStyleFor: self]] ifFalse: [self enabled ifTrue: [self theme radioButtonNormalBorderStyleFor: self] ifFalse: [self theme radioButtonDisabledBorderStyleFor: self]]! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 2/29/2008 21:56'! fillStyleToUse "Answer the fillStyle that should be used for the receiver." ^self isRadioButton ifTrue: [self radioFillStyleToUse] ifFalse: [self checkboxFillStyleToUse]! ! !CheckboxButtonMorph methodsFor: 'event handling' stamp: 'GaryChambers 10/17/2011 16:24'! mouseDown: evt "Handle the transitions." self perform: #mouseDown: withArguments: {evt} inSuperclass: Morph. self enabled ifFalse: [^self]. self isOn ifTrue: [self state: #repressed] ifFalse: [self state: #pressed]. actWhen == #buttonDown ifTrue: [self doButtonAction]. self mouseStillDown: evt.! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'GuillermoPolito 5/1/2012 12:29'! images ^ images ifNil: [images := Dictionary newFromPairs: { #off . [self offImage] . #pressed . [self pressedImage] . #on . [self onImage] . #repressed . [self repressedImage ifNil: [self onImage]] }]! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:17'! repressedImage "Answer the value of repressedImage" ^ repressedImage! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 2/29/2008 22:05'! borderStyleToUse "Answer the borderStyle that should be used for the receiver." ^self isRadioButton ifTrue: [self radioBorderStyleToUse] ifFalse: [self checkboxBorderStyleToUse]! ! !CheckboxButtonMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 15:21'! radioButton "Answer a button pre-initialized with radio button images." ^self new beRadioButton! ! !CheckboxButtonMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 5/22/2007 15:21'! checkBox "Answer a button pre-initialized with checkbox images." ^self new beCheckbox! ! !CheckboxMorph commentStamp: 'gvc 5/18/2007 13:47'! Checkbox with box button and label with enablement support.! !CheckboxMorph methodsFor: 'updating' stamp: 'GaryChambers 12/2/2011 10:22'! updateLabel "Update the label." self model ifNotNil: [ self getLabelSelector ifNotNil: [ self label: (self model perform: self getLabelSelector)]]! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 14:49'! enabled "Answer the value of enabled" ^ enabled! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/18/2013 23:10'! labelMorph: aMorph "Set the value of labelMorph" labelMorph ifNotNil: [labelMorph delete]. labelMorph := aMorph. labelMorph color: (self theme checkboxButtonLabelNormalFillStyleFor: self label: labelMorph). self addMorphBack: aMorph. self enabled: self enabled.! ! !CheckboxMorph methodsFor: 'protocol' stamp: 'gvc 8/17/2006 15:14'! isSelected "Answer whether the receiver is selected." self model ifNil: [^false]. ^self model perform: (self getStateSelector ifNil: [^false])! ! !CheckboxMorph methodsFor: 'event handling' stamp: 'gvc 5/22/2007 16:11'! keyStroke: event "Process keys navigation and space to toggle." (self navigationKey: event) ifTrue: [^self]. event keyCharacter = Character space ifTrue: [self toggleSelected]! ! !CheckboxMorph methodsFor: 'as yet unclassified' stamp: ''! addToggleItemsToHaloMenu: aCustomMenu "Add toggle-items to the halo menu" super addToggleItemsToHaloMenu: aCustomMenu. aCustomMenu addUpdating: #enabledString target: self action: #toggleEnabled! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 18:02'! getStateSelector: anObject "Set the value of getStateSelector" getStateSelector := anObject. self updateSelection! ! !CheckboxMorph methodsFor: 'private' stamp: 'GaryChambers 10/17/2011 16:30'! newButtonMorph "Answer a new button morph" ^(CheckboxButtonMorph new target: self; actionSelector: #toggleSelected; vResizing: #shrinkWrap; hResizing: #shrinkWrap) on: #mouseDown send: #buttonMouseDown: to: self! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:58'! font: aFont "Set the label font" self labelMorph font: aFont! ! !CheckboxMorph methodsFor: 'initialization' stamp: 'NicolaiHess 1/14/2014 08:56'! initialize "Initialize the receiver." super initialize. labelClickable := true. self borderWidth: 2; "space for focus" borderColor: Color transparent; enabled: true; changeTableLayout; listDirection: #leftToRight; wrapCentering: #center; cellInset: 4; labelMorph: self newLabelMorph; buttonMorph: self newButtonMorph; on: #click send: #updateButton: to: self; on: #mouseMove send: #updateButton: to: self; on: #mouseUp send: #updateButton: to: self! ! !CheckboxMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 11:38'! enable "Enable the receiver." self enabled: true! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:00'! setStateSelector: anObject "Set the value of setStateSelector" setStateSelector := anObject! ! !CheckboxMorph methodsFor: 'as yet unclassified' stamp: ''! toggleEnabled "Toggle the enabled state." self enabled: self enabled not! ! !CheckboxMorph methodsFor: 'updating' stamp: 'GaryChambers 10/17/2011 16:37'! updateButtonDown: evt "Check for keyboard focus." self wantsKeyboardFocusOnMouseDown ifTrue: [ self takeKeyboardFocus]. self updateButton: evt! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'GaryChambers 12/2/2011 10:20'! getLabelSelector ^ getLabelSelector! ! !CheckboxMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 2/21/2013 23:31'! labelClicked labelClickable ifTrue: [ self toggleSelected ]. self announcer announce: (LabelClicked source: self stateChanged: labelClickable).! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'GaryChambers 12/2/2011 10:24'! label: aStringOrMorph "Set the label morph or label morph contents." self labelMorph: (aStringOrMorph isMorph ifTrue: [aStringOrMorph] ifFalse: [self labelMorph contents: aStringOrMorph. self newLabel])! ! !CheckboxMorph methodsFor: 'protocol' stamp: 'gvc 5/22/2007 15:38'! beRadioButton "Change the button to be a radio button." self buttonMorph beRadioButton! ! !CheckboxMorph methodsFor: 'event handling' stamp: 'gvc 1/16/2007 15:20'! handlesKeyboard: evt "Yes, we do it here." ^true! ! !CheckboxMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 11:38'! disable "Disable the receiver." self enabled: false! ! !CheckboxMorph methodsFor: 'updating' stamp: 'gvc 9/8/2009 13:25'! updateEnabled "Update the enablement state." self model ifNotNil: [ self getEnabledSelector ifNotNil: [ self enabled: (self model perform: self getEnabledSelector)]]! ! !CheckboxMorph methodsFor: 'focus handling' stamp: 'gvc 1/11/2007 12:28'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !CheckboxMorph methodsFor: 'focus handling' stamp: 'GaryChambers 10/17/2011 16:05'! wantsKeyboardFocusOnMouseDown "Answer whether the receiver would like keyboard focus on a mouse down event. use a property here for apps that want to take keyboard focus when the button is pressed (so that other morphs can, e.g. accept on focus change)." ^self wantsKeyboardFocus and: [self valueOfProperty: #wantsKeyboardFocusOnMouseDown ifAbsent: [false]]! ! !CheckboxMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/21/2013 23:31'! labelClickable: aBoolean labelClickable := aBoolean.! ! !CheckboxMorph methodsFor: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:06'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/20/2012 12:29'! getLabelSelector: anObject getLabelSelector := anObject. self updateLabel.! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/20/2012 12:36'! buttonMorph: aMorph "Set the value of buttonMorph" buttonMorph ifNotNil: [ self removeDependent: buttonMorph. buttonMorph delete]. buttonMorph := aMorph. self addDependent: aMorph; addMorphFront: aMorph! ! !CheckboxMorph methodsFor: 'event handling' stamp: 'StephaneDucasse 5/23/2013 18:25'! keyboardFocusChange: aBoolean "The message is sent to a morph when its keyboard focus changes. Update for focus feedback." super keyboardFocusChange: aBoolean. self focusChanged! ! !CheckboxMorph methodsFor: 'initialization' stamp: 'gvc 8/17/2006 18:01'! on: anObject selected: getSelectionSel changeSelected: setSelectionSel "Set the receiver to the given model parameterized by the given message selectors." self model: anObject; getStateSelector: getSelectionSel; setStateSelector: setSelectionSel; updateSelection! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:58'! font "Answer the label font" ^self labelMorph font! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 14:49'! buttonMorph "Answer the value of buttonMorph" ^ buttonMorph! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 14:49'! getStateSelector "Answer the value of getStateSelector" ^ getStateSelector! ! !CheckboxMorph methodsFor: 'event handling' stamp: 'GaryChambers 10/17/2011 16:31'! buttonMouseDown: evt "Sent from the checkbox button to handle focus." self wantsKeyboardFocusOnMouseDown ifTrue: [ self takeKeyboardFocus]! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 18:01'! getEnabledSelector: anObject "Set the value of getEnabledSelector" getEnabledSelector := anObject. self updateEnabled! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:00'! setStateSelector "Answer the value of setStateSelector" ^ setStateSelector! ! !CheckboxMorph methodsFor: 'drawing' stamp: 'gvc 5/22/2007 16:04'! drawSubmorphsOn: aCanvas "Display submorphs back to front. Draw the focus here since we are using inset bounds for the focus rectangle." super drawSubmorphsOn: aCanvas. self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]! ! !CheckboxMorph methodsFor: 'updating' stamp: 'GaryChambers 10/17/2011 16:36'! updateButton: evt "Update the button due to mouse activity in the receiver." self enabled ifFalse: [^self]. evt isMouseDown ifTrue: [ self buttonMorph state == #on ifTrue: [^self buttonMorph state: #repressed]. self buttonMorph state == #off ifTrue: [^self buttonMorph state: #pressed]]. evt isMouseUp ifTrue: [ self buttonMorph state == #repressed ifTrue: [ ^self buttonMorph state: #off; doButtonAction]. self buttonMorph state == #pressed ifTrue: [ ^self buttonMorph state: #on; doButtonAction]]. evt isMove ifTrue: [ (self containsPoint: evt cursorPoint) ifTrue: [self buttonMorph state == #on ifTrue: [^self buttonMorph state: #repressed]. self buttonMorph state == #off ifTrue: [^self buttonMorph state: #pressed]] ifFalse: [self buttonMorph state == #repressed ifTrue: [^self buttonMorph state: #on]. self buttonMorph state == #pressed ifTrue: [^self buttonMorph state: #off]]]! ! !CheckboxMorph methodsFor: 'as yet unclassified' stamp: ''! enabledString "Answer the string to be shown in a menu to represent the 'enabled' status" ^ (self enabled) -> 'enabled' translated! ! !CheckboxMorph methodsFor: '*Morphic-Base-Widgets' stamp: 'BenjaminVanRyseghem 2/21/2013 23:25'! listRenderOn: aCanvas atRow: aRow bounds: drawBounds color: drawColor backgroundColor: backgroundColor from: aMorph self color: backgroundColor. self bounds: drawBounds. self fullDrawOn: aCanvas. aMorph addMorph: self! ! !CheckboxMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/4/2013 16:32'! newLabelMorph "Answer a new label morph" ^ (LabelMorph contents: self label) on: #mouseDown send: #toggleSelected to: self; yourself! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/31/2013 17:47'! enabled: aBoolean "Set the value of enabled" enabled := aBoolean. self labelMorph ifNotNil: [:m | m enabled: aBoolean]. self buttonMorph ifNotNil: [:m | m enabled: aBoolean]. self changed: #enabled! ! !CheckboxMorph methodsFor: 'private' stamp: 'gvc 8/2/2007 16:13'! newLabel "Answer a new label morph" ^self theme checkboxLabelFor: self! ! !CheckboxMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 7/18/2013 14:16'! update: aParameter "Refer to the comment in View|update:." aParameter == self getStateSelector ifTrue: [self updateSelection. ^ self]. aParameter == self getEnabledSelector ifTrue: [self updateEnabled. ^ self]. aParameter == self getLabelSelector ifTrue: [self updateLabel. ^ self]. aParameter isArray ifFalse: [ ^ self ]. aParameter size == 2 ifFalse: [ ^ self ]. aParameter first = #labelClickable: ifTrue: [ self labelClickable: aParameter second ]. aParameter first = #label: ifTrue: [ self label: aParameter second ]! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:05'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !CheckboxMorph methodsFor: 'protocol' stamp: 'gvc 5/22/2007 15:38'! beCheckbox "Change the button to be a checkbox." self buttonMorph beCheckbox! ! !CheckboxMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/4/2013 16:33'! toggleSelected "Toggle the selection state." self takeKeyboardFocus. self enabled ifFalse: [^self]. self model ifNil: [^self]. (self setStateSelector ifNil: [^self]) numArgs = 0 ifTrue: [self model perform: self setStateSelector]. self setStateSelector numArgs = 1 ifTrue: [ self model perform: self setStateSelector with: self isSelected not]. self updateSelection.! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 14:49'! labelMorph "Answer the value of labelMorph" ^ labelMorph! ! !CheckboxMorph methodsFor: 'updating' stamp: 'MarcusDenker 12/11/2009 07:38'! updateSelection "Update the selection state." self buttonMorph ifNotNil: [:m | m selected: self isSelected]. self changed: #isSelected! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:14'! label "Answer the contents of the label morph." ^(self labelMorph ifNil: [^'']) contents! ! !CheckboxMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 8/17/2006 16:50'! on: anObject selected: getSelectionSel changeSelected: setSelectionSel "Answer a new instance of the receiver on the given model using the given selectors as the interface." ^self new on: anObject selected: getSelectionSel changeSelected: setSelectionSel! ! !Checksum commentStamp: ''! I represent the abstact superclass of all checksum algorithms.! !ChooseDropListDialogWindow commentStamp: 'gvc 5/18/2007 13:46'! Message dialog containing a drop list for selection of an item.! !ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon "Answer an icon for the receiver." ^ Smalltalk ui icons questionIcon! ! !ChooseDropListDialogWindow methodsFor: 'initialization' stamp: 'gvc 1/12/2007 14:35'! initialize "Initialize the receiver." self list: #(). super initialize! ! !ChooseDropListDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/12/2007 15:21'! list: anObject "Set the value of list" list := anObject. self changed: #list; changed: #selectionIndex! ! !ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/29/2007 13:32'! newContentMorph "Answer a new content morph." self iconMorph: self newIconMorph. self textMorph: self newTextMorph. self listMorph: self newListMorph. ^self newGroupboxForAll: { self newRow: {self iconMorph. self textMorph}. self listMorph}! ! !ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 14:15'! selectionIndex "Answer the initial selection index for the list." ^self list ifEmpty: [0] ifNotEmpty: [1]! ! !ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 14:17'! newListMorph "Answer a new drop-list morph." ^self newDropListFor: self list: #list getSelected: #selectionIndex setSelected: nil getEnabled: nil help: nil! ! !ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 14:22'! selectedItem "Answer the selected list item or nil if cancelled." ^self cancelled ifFalse: [self listMorph selectedItem]! ! !ChooseDropListDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/12/2007 14:15'! list "Answer the value of list" ^ list! ! !ChooseDropListDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/12/2007 14:17'! listMorph: anObject "Set the value of listMorph" listMorph := anObject! ! !ChooseDropListDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/12/2007 14:17'! listMorph "Answer the value of listMorph" ^ listMorph! ! !ChooseDropListDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallQuestionIcon! ! !ChoseDate commentStamp: ''! A ChoseDate is an announcement raised by the CalendarMorph! !ChoseDate methodsFor: 'private' stamp: 'SeanDeNigris 1/20/2013 21:16'! calendar: aCalendarChooserMorph calendar := aCalendarChooserMorph.! ! !ChoseDate methodsFor: 'private' stamp: 'SeanDeNigris 1/20/2013 21:14'! date: aDate date := aDate.! ! !ChoseDate methodsFor: 'accessing' stamp: 'SeanDeNigris 1/20/2013 21:17'! date ^ date.! ! !ChoseDate methodsFor: 'accessing' stamp: 'SeanDeNigris 1/20/2013 21:17'! calendar ^ calendar.! ! !ChoseDate class methodsFor: 'instance creation' stamp: 'SeanDeNigris 1/20/2013 21:15'! of: aDate from: aCalendarChooserMorph ^ self new date: aDate; calendar: aCalendarChooserMorph.! ! !ChronologyConstants commentStamp: 'brp 3/12/2004 14:34'! ChronologyConstants is a SharedPool for the constants used by the Kernel-Chronology classes.! !ChronologyConstants class methodsFor: 'class initialization' stamp: 'SvenVanCaekenberghe 5/3/2013 15:49'! initialize "ChronologyConstants initialize" SqueakEpoch := 2415386. "Julian day number of 1 Jan 1901" SecondsInDay := 86400. MicrosecondsInDay := SecondsInDay * 1e6. SecondsInHour := 3600. SecondsInMinute := 60. NanosInSecond := 10 raisedTo: 9. NanosInMillisecond := 10 raisedTo: 6. DayNames := #(Sunday Monday Tuesday Wednesday Thursday Friday Saturday). MonthNames := #(January February March April May June July August September October November December). DaysInMonth := #(31 28 31 30 31 30 31 31 30 31 30 31). ! ! !ChunkFileFormatParser commentStamp: ''! I represent the chunk file format. Right now I know how to parse chunks from a readStream, but not how to write them.! !ChunkFileFormatParser methodsFor: 'parsing' stamp: 'MarcusDenker 10/5/2013 18:22'! parseMethodDeclarations: methodsPreamble | behaviorName isMeta category stamp methodSource | "The method preable is an array with the following structure: If instance side method: #(#CodeImportTestCaseTestClass #methodsFor: 'some protocol' #stamp: 'GuillermoPolito 5/2/2012 13:35') if class side: #(#CodeImportTestCaseTestClass #class #methodsFor: 'some protocol' #stamp: 'GuillermoPolito 5/2/2012 13:35') Sometimes there is no timestamp: #(#CodeImportTestCaseTestClass #methodsFor: 'some protocol') " behaviorName := methodsPreamble first. isMeta := methodsPreamble second ~= #methodsFor:. category := isMeta ifTrue: [ methodsPreamble at: 4 ] ifFalse: [ methodsPreamble at: 3 ]. stamp := ''. methodsPreamble size > 4 ifTrue: [ stamp := isMeta ifTrue: [ methodsPreamble at: 6 ] ifFalse: [ methodsPreamble at: 5 ] ]. [ methodSource := self nextChunk. methodSource notEmpty ] whileTrue: [ self addDeclaration: (MethodDeclaration contents: methodSource behaviorName: behaviorName asSymbol isMeta: isMeta category: category stamp: stamp) ]! ! !ChunkFileFormatParser methodsFor: 'parsing' stamp: 'MarcusDenker 10/5/2013 18:22'! parseCommentDeclaration: commentPreamble "The comment preable is an array with the following structure: If instance side method: #(#CodeImportTestCaseTestClass #commentStamp: '' #prior: 0) if class side: #(#CodeImportTestCaseTestClass #class #commentStamp: '' #prior: 0) allButFirst: " | behaviorName isMeta stamp | behaviorName := commentPreamble first asSymbol. isMeta := commentPreamble second ~= #commentStamp:. stamp := isMeta ifTrue: [ commentPreamble at: 4 ] ifFalse: [ commentPreamble at: 3 ]. self addDeclaration: (ClassCommentDeclaration contents: self nextChunk behaviorName: behaviorName isMeta: isMeta stamp: stamp)! ! !ChunkFileFormatParser methodsFor: 'testing' stamp: 'GuillermoPolito 5/5/2012 22:05'! next "If the char we read previously is a terminator mark, it is scaping the next one, so we skip it" nextChar = self terminatorMark ifTrue: [ readStream next ]. ^nextChar! ! !ChunkFileFormatParser methodsFor: 'testing' stamp: 'GuillermoPolito 5/5/2012 17:09'! isNextStyleChunk "Style chunks are between $] and $[" ^readStream peek == $]! ! !ChunkFileFormatParser methodsFor: 'testing' stamp: 'MarcusDenker 10/5/2013 18:22'! nextChunk | out | out := (String new: 1000) writeStream. readStream skipSeparators. [ self isChunkEnd ] whileFalse: [ out nextPut: self next. ]. ^out contents! ! !ChunkFileFormatParser methodsFor: 'parsing' stamp: 'MarcusDenker 10/5/2013 18:22'! parseClassOrganization: classOrganizationPreamble "The comment preable is an array with the following structure: If instance side method: #(#CodeImportTestCaseTestClass #reorganize) if class side: #(#CodeImportTestCaseTestClass #class #reorganize) " | behaviorName isMeta | behaviorName := classOrganizationPreamble first. isMeta := classOrganizationPreamble second ~= #reorganize. self addDeclaration: (ClassOrganizationDeclaration contents: self nextChunk behaviorName: behaviorName isMeta: isMeta)! ! !ChunkFileFormatParser methodsFor: 'initialization' stamp: 'GuillermoPolito 5/5/2012 22:06'! initialize parsedDeclarations := OrderedCollection new.! ! !ChunkFileFormatParser methodsFor: 'testing' stamp: 'GuillermoPolito 5/5/2012 17:09'! isNextChunkMetaData "If the next chunk starts with $!!, it will be an expression that after evaluation returns an object who knows how to read some metadata. I.e. A chunk for comment reading should be something like: !!SomeClass commentStamp: '' prior: 0!! The object returned by the expression of that tag must understand #scanFrom: " ^readStream peekFor: $!!! ! !ChunkFileFormatParser methodsFor: 'parsing' stamp: 'GuillermoPolito 5/5/2012 17:08'! readUpToEndOfStyleChunk "Style chunks are between $] and $[" ^readStream upTo: $[! ! !ChunkFileFormatParser methodsFor: 'parsing' stamp: 'GuillermoPolito 5/5/2012 21:32'! terminatorMark ^$!!! ! !ChunkFileFormatParser methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 17:19'! addDeclaration: aDeclaration parsedDeclarations add: aDeclaration ! ! !ChunkFileFormatParser methodsFor: 'testing' stamp: 'MarcusDenker 10/5/2013 18:23'! isChunkEnd nextChar := readStream next. ^ nextChar isNil or: [ nextChar = self terminatorMark and: [ readStream peek ~= self terminatorMark ] ]! ! !ChunkFileFormatParser methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 17:07'! readStream: aReadStream readStream := aReadStream! ! !ChunkFileFormatParser methodsFor: 'parsing' stamp: 'GuillermoPolito 5/5/2012 17:17'! parseDeclarations [ readStream atEnd ] whileFalse: [ self parseNextDeclaration. ]. ^parsedDeclarations! ! !ChunkFileFormatParser methodsFor: 'parsing' stamp: 'MarcusDenker 5/18/2013 15:44'! parseNextDeclaration | isMetadata nextChunk | readStream skipSeparators. (self isNextStyleChunk) ifTrue: [ self addDeclaration: (StyleDeclaration contents: (self readUpToEndOfStyleChunk)). ^self ]. isMetadata := self isNextChunkMetaData. nextChunk := self nextChunk. isMetadata ifFalse: [ self addDeclaration: (DoItDeclaration contents: nextChunk). ] ifTrue: [ | substrings | substrings := nextChunk parseLiterals. (substrings includes: 'methodsFor:') ifTrue: [ ^self parseMethodDeclarations: substrings ]. (substrings includes: 'commentStamp:') ifTrue: [ ^self parseCommentDeclaration: substrings ]. (substrings includes: 'reorganize') ifTrue: [ ^self parseClassOrganization: substrings ]. ]! ! !ChunkFileFormatParser class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 17:06'! for: aReadStream ^self new readStream: aReadStream; yourself! ! !ChunkImportTestCase methodsFor: 'auxiliar' stamp: 'GuillermoPolito 5/5/2012 17:26'! importAClass ^CodeImporter evaluateString: 'Object subclass: #CodeImportTestCaseTestClass instanceVariableNames: ''var1 var2 var3'' classVariableNames: '''' poolDictionaries: '''' category: ''CodeImporter-Tests-Garbage''!!'.! ! !ChunkImportTestCase methodsFor: 'importing-code' stamp: 'EstebanLorenzano 8/3/2012 15:13'! testImportAClassCommentWithExclamationMarks | class comment commentToWrite | comment := 'I''m a nice comment!!, treat me well :).'. commentToWrite := 'I''m a nice comment!!!!, treat me well :).' replaceAll: '!!' with: '!!!!'. SystemAnnouncer uniqueInstance suspendAllWhile: [[ class := self importAClass. CodeImporter evaluateString: ('!!{1} commentStamp: '''' prior: 0!!{2}!!' format: { class name asString . commentToWrite }). self assert: comment equals: class comment. ] ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! ! !ChunkImportTestCase methodsFor: 'importing-code' stamp: 'CamilloBruni 10/15/2013 01:17'! testImportAClassCategory | class classOrganizationString chunk | classOrganizationString := '(#testing testImportAMethod testImportAClass) (#auxiliar importAClass)'. chunk := '!!{1} reorganize!!'. SystemAnnouncer uniqueInstance suspendAllWhile: [ [ class := self importAClass. "we write the methods we will categorize" class compileSilently: 'testImportAClass'. class compileSilently: 'testImportAMethod'. class compileSilently: 'importAClass'. CodeImporter evaluateString: (chunk format: { class name asString }), classOrganizationString. "we do not care about the order of the output just that all the elements are present" self assertCollection: (classOrganizationString trimBoth findTokens: String cr, ' ') sorted equals: (class organization stringForFileOut findTokens: String cr, ' ') sorted. ] ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! ! !ChunkImportTestCase methodsFor: 'importing-code' stamp: 'EstebanLorenzano 8/3/2012 15:11'! testImportAClass | class | SystemAnnouncer uniqueInstance suspendAllWhile: [ [ class := self importAClass. self assert: #CodeImportTestCaseTestClass equals: class name. self assert: (class instVarNames includes: 'var1'). self assert: (class instVarNames includes: 'var2'). self assert: (class instVarNames includes: 'var3'). self assert: class category equals: 'CodeImporter-Tests-Garbage'. ] ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! ! !ChunkImportTestCase methodsFor: 'importing-methods' stamp: 'GuillermoPolito 5/5/2012 17:26'! testImportFromReadStream self assert: 4 equals: (CodeImporter evaluateReadStream: '2+2!!' readStream)! ! !ChunkImportTestCase methodsFor: 'importing-code' stamp: 'EstebanLorenzano 8/3/2012 15:13'! testImportAMethodWithSpacesInItsCategory | class comment | SystemAnnouncer uniqueInstance suspendAllWhile: [[ class := self importAClass. CodeImporter evaluateString: ('!!{1} methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!someMethod ^true' format: { class name asString }). self assert: (class >> #someMethod) category equals: 'some protocol'. ] ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! ! !ChunkImportTestCase methodsFor: 'importing-code' stamp: 'EstebanLorenzano 8/3/2012 15:13'! testImportAMethod | class comment | SystemAnnouncer uniqueInstance suspendAllWhile: [[ class := self importAClass. CodeImporter evaluateString: ('!!{1} methodsFor: ''some protocol'' stamp: ''GuillermoPolito 5/2/2012 13:35''!!someMethod ^true' format: { class name asString }). self assert: class new someMethod. ] ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! ! !ChunkImportTestCase methodsFor: 'importing-code' stamp: 'EstebanLorenzano 8/3/2012 15:13'! testImportAMethodWithNoTimestamp | class comment | SystemAnnouncer uniqueInstance suspendAllWhile: [[ class := self importAClass. CodeImporter evaluateString: ('!!{1} methodsFor: ''some protocol''!!someMethod ^true' format: { class name asString }). self assert: class new someMethod. ] ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! ! !ChunkImportTestCase methodsFor: 'importing-code' stamp: 'EstebanLorenzano 8/3/2012 15:11'! testImportAClassComment | class comment | comment := 'I''m a nice comment, treat me well :).'. SystemAnnouncer uniqueInstance suspendAllWhile: [[ class := self importAClass. CodeImporter evaluateString: ('!!{1} commentStamp: '''' prior: 0!!{2}!!' format: { class name asString . comment }). self assert: comment equals: class comment. ] ensure: [ class ifNotNil: [ class removeFromSystem ] ] ]! ! !ChunkImportTestCase methodsFor: 'importing-methods' stamp: 'GuillermoPolito 5/5/2012 17:26'! testImportString self assert: 4 equals: (CodeImporter evaluateString: '2+2!!')! ! !CircleMorph commentStamp: ''! I am a specialization of EllipseMorph that knows enough to remain circular. ! !CircleMorph methodsFor: 'geometry' stamp: 'AlainPlantec 5/7/2010 22:07'! extent: aPoint | size oldRotationCenter | oldRotationCenter := self rotationCenter. size := aPoint x min: aPoint y. super extent: size @ size. self rotationCenter: oldRotationCenter.! ! !CircleMorph methodsFor: 'geometry' stamp: 'nk 7/1/2002 08:49'! transformedBy: aTransform aTransform isIdentity ifTrue:[^self]. ^self center: (aTransform localPointToGlobal: self center). ! ! !CircleMorph methodsFor: 'geometry' stamp: 'nk 7/1/2002 07:01'! bounds: aRectangle | size | size := aRectangle width min: aRectangle height. super bounds: (Rectangle origin: aRectangle origin extent: size @ size).! ! !CircleMorph methodsFor: 'menus' stamp: 'AlainPlantec 5/7/2010 23:34'! setRotationCenterFrom: aPoint "Called by halo rotation code. Circles store their referencePosition." self setProperty: #referencePosition toValue: aPoint. self setProperty: #originalCenter toValue: self center. self setProperty: #originalAngle toValue: self heading.! ! !CircleMorph methodsFor: 'geometry etoy' stamp: 'nk 7/1/2002 13:48'! rotationCenter: aPointOrNil "Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." | newRef box | aPointOrNil isNil ifTrue: [self removeProperty: #referencePosition. self removeProperty: #originalCenter. self removeProperty: #originalAngle. ] ifFalse: [ box := self bounds. newRef := box origin + (aPointOrNil * box extent). self setRotationCenterFrom: newRef ]. ! ! !CircleMorph methodsFor: 'rotate scale and flex' stamp: 'AlainPlantec 5/7/2010 21:25'! prepareForScaling "When scaling from a halo, I can do this without a flex shell" ^ self ! ! !CircleMorph methodsFor: 'rotate scale and flex' stamp: 'nk 7/1/2002 16:29'! privateMoveBy: delta self setProperty: #referencePosition toValue: self referencePosition + delta. self setProperty: #originalCenter toValue: (self valueOfProperty: #originalCenter ifAbsent: [ self center ]) + delta. super privateMoveBy: delta. ! ! !CircleMorph methodsFor: 'initialization' stamp: 'MarcusDenker 9/13/2013 15:50'! initialize super initialize. self extent: 40@40; color: Color green lighter! ! !CircleMorph methodsFor: 'geometry etoy' stamp: 'nk 7/1/2002 07:31'! referencePosition "Return the current reference position of the receiver" ^ self valueOfProperty: #referencePosition ifAbsent: [ self center ] ! ! !CircleMorph methodsFor: 'geometry etoy' stamp: 'nk 7/1/2002 11:16'! rotationCenter "Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." | refPos | refPos := self referencePosition. ^ (refPos - self bounds origin) / self bounds extent asFloatPoint! ! !CircleMorph methodsFor: 'rotate scale and flex' stamp: 'AlainPlantec 5/8/2010 00:03'! rotationDegrees: degrees | ref newPos flex origAngle origCenter | ref := self referencePosition. origAngle := self valueOfProperty: #originalAngle ifAbsentPut: [ self heading ]. origCenter := self valueOfProperty: #originalCenter ifAbsentPut: [ self center ]. flex := (MorphicTransform offset: ref negated) withAngle: (degrees - origAngle) degreesToRadians. newPos := (flex transform: origCenter) - flex offset. self position: (self position + newPos - self center) asIntegerPoint. self setProperty: #referencePosition toValue: ref. self setProperty: #originalAngle toValue: origAngle. self setProperty: #originalCenter toValue: origCenter. self forwardDirection: degrees. self changed. ! ! !CircleMorph methodsFor: 'rotate scale and flex' stamp: 'AlainPlantec 5/7/2010 21:26'! prepareForRotating "When rotating from a halo, I can do this without a flex shell" ^ self ! ! !CircleMorph methodsFor: 'rotate scale and flex' stamp: 'AlainPlantec 5/7/2010 23:54'! rotationDegrees ^ self forwardDirection! ! !CircleMorphTest commentStamp: 'tlk 5/21/2006 14:16'! 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. ! !CircleMorphTest methodsFor: 'initialization' stamp: 'tlk 5/21/2006 14:17'! setUp morph := CircleMorph new! ! !CircularHierarchyError commentStamp: ''! I am signaled if a new class introduces a circular class hierarchy.! !CircularHierarchyError class methodsFor: 'signalling' stamp: 'MartinDias 7/25/2013 14:12'! signalFor: aClass self signal: aClass name asString, ': Trying to build a circular hierarchy'! ! !Class commentStamp: ''! I add a number of facilities to those in ClassDescription: A set of all my subclasses (defined in ClassDescription, but only used here and below) A name by which I can be found in a SystemDictionary A classPool for class variables shared between this class and its metaclass A list of sharedPools which probably should be supplanted by some better mechanism. My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription. The slot 'subclasses' is a redundant structure. It is never used during execution, but is used by the development system to simplify or speed certain operations. ! !Class methodsFor: 'class variables' stamp: ''! ensureClassPool ^self classPool.! ! !Class methodsFor: 'testing' stamp: ''! isObsolete "Return true if the receiver is obsolete." ^(self environment at: self name ifAbsent: [nil]) ~~ self! ! !Class methodsFor: 'accessing' stamp: ''! classPoolFrom: aClass "share the classPool with aClass." self classPool: aClass classPool.! ! !Class methodsFor: 'initialize-release' stamp: ''! name: aString traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization "Used by copy" self name: aString. self localSelectors: aSet. self methodDict: aMethodDict. self traitComposition: aComposition. self organization: aClassOrganization! ! !Class methodsFor: 'viewer' stamp: ''! externalName "Answer a name by which the receiver can be known." ^ self name! ! !Class methodsFor: '*FuelTests' stamp: ''! renameSilently: aName [ self rename: aName] fuelValueWithoutNotifications! ! !Class methodsFor: 'organization' stamp: 'di 12/23/1999 11:42'! environment: anEnvironment environment := anEnvironment! ! !Class methodsFor: 'subclass creation' stamp: ''! weakSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory "Creates a new class as a subclass of an existing class (the receiver) in which the subclass is to have weak indexable pointer variables." ^ self subclass: aName uses: aTraitComposition with: [ self weakSubclass: aName instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory ]! ! !Class methodsFor: '*Ring-Core-Kernel' stamp: ''! asFullRingDefinition "A behavior is converted to a ring class including its variables, methods, direct superclass, direct subclasses and the package in which is loaded. Active methods are generated and each knows its package as well. Note that for its direct superclass and subclasses no full definitions are requested. If you need to traverse hierarchies use #asRingDefinitionWithMethods:withSuperclasses:withSubclasses:withPackages:" | rgClass rgSuper rgSub rgMethod packageKeys | rgClass:= self asRingDefinition. rgClass package: (RGContainer packageOfClass: rgClass). self superclass notNil ifTrue: [ rgSuper := self superclass asRingDefinition. rgClass superclass: rgSuper ] ifFalse: [ self isTrait ifTrue: [ rgSuper := Trait asRingDefinition. rgClass superclass: rgSuper. ] ]. self subclasses do:[ :each | rgSub := each asRingDefinition. rgSub superclass: rgClass ]. packageKeys := RGContainer packageKeys. self methodsDo:[ :mth| rgMethod := mth asActiveRingDefinition. rgClass addMethod: rgMethod. rgMethod package: (RGContainer packageOfMethod: rgMethod using: packageKeys) ]. self theMetaClass methodsDo:[ :mth| rgMethod := mth asActiveRingDefinition. rgClass theMetaClass addMethod: rgMethod. rgMethod package: (RGContainer packageOfMethod: rgMethod using: packageKeys) ]. ^ rgClass! ! !Class methodsFor: 'initialize-release' stamp: ''! superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver" super superclass: aClass methodDictionary: mDict format: fmt. self subclasses: nil. ! ! !Class methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'! basicCategory ^category! ! !Class methodsFor: 'subclass creation' stamp: ''! subclass: t uses: aTraitComposition | cls | cls := self subclass: t instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Unclassified'. cls setTraitComposition: aTraitComposition asTraitComposition. ^ cls! ! !Class methodsFor: 'subclass creation' stamp: 'IgorStasenko 12/3/2013 13:35'! newAnonymousSubclass ^ AnonymousClassInstaller make: [ :builder | builder superclass: self ].! ! !Class methodsFor: 'initialize-release' stamp: ''! removeFromSystemUnlogged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver. Do not log the removal either to the current change set nor to the system changes log" ^self removeFromSystem: false! ! !Class methodsFor: 'subclass creation' stamp: ''! variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable byte-sized nonpointer variables." ^self classBuilder superclass: self variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !Class methodsFor: 'initialize-release' stamp: ''! superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet "Answer an instance of me, a new class, using the arguments of the message as the needed information. Must only be sent to a new instance; else we would need Object flushCache." self superclass: sup. self methodDict: md. self setFormat: ft. self setName: nm. self instanceVariables: nilOrArray. self classPool: pool. self sharedPools: poolSet. self organization: org.! ! !Class methodsFor: 'instance variables' stamp: 'SebastianTleye 7/12/2013 16:03'! addInstVarNamed: aString "Add the argument, aString, as one of the receiver's instance variables." ^self classBuilder name: self name inEnvironment: self environment subclassOf: self superclass type: self typeOfClass instanceVariableNames: self instanceVariablesString, ' ', aString classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category! ! !Class methodsFor: '*Monticello' stamp: 'MartinDias 11/7/2013 18:11'! asClassDefinition ^ MCClassDefinition name: self name superclassName: self superclass name traitComposition: self traitCompositionString classTraitComposition: self class traitCompositionString category: self category instVarNames: self instVarNames classVarNames: self classVarNames poolDictionaryNames: self sharedPoolNames classInstVarNames: self class instVarNames type: self typeOfClass comment: self organization classComment asString commentStamp: self organization commentStamp ! ! !Class methodsFor: 'private' stamp: 'SebastianTleye 7/4/2013 17:18'! name: aSymbol name := aSymbol! ! !Class methodsFor: 'subclass creation' stamp: 'SebastianTleye 7/12/2013 14:19'! subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver)." | class | class := self classBuilder superclass: self subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. class ifNotNil: [ class setTraitComposition: {} asTraitComposition ]. ^ class ! ! !Class methodsFor: 'pool variables' stamp: 'ClementBera 9/27/2013 17:44'! sharedPools "Answer an orderedCollection of the shared pools declared in the receiver." ^ sharedPools ifNil: [ sharedPools := OrderedCollection new ]! ! !Class methodsFor: 'organization' stamp: ''! category: aString "Categorize the receiver under the system category, aString, removing it from any previous categorization." | oldCategory | oldCategory := self basicCategory. aString isString ifTrue: [ self basicCategory: aString asSymbol. self environment organization classify: self name under: self basicCategory ] ifFalse: [self errorCategoryName]. SystemAnnouncer uniqueInstance class: self recategorizedFrom: oldCategory to: self basicCategory! ! !Class methodsFor: 'class variables' stamp: ''! usesClassVarNamed: aString "Return whether the receiver or its superclasses have a class variable named: aString" ^ self allClassVarNames includes: aString! ! !Class methodsFor: 'pool variables' stamp: ''! removeSharedPool: aDictionary "Remove the pool dictionary, aDictionary, as one of the receiver's pool dictionaries. Create an error notification if the dictionary is not one of the pools. : Note that it removes the wrong one if there are two empty Dictionaries in the list." | satisfiedSet workingSet aSubclass | (self sharedPools includes: aDictionary) ifFalse: [^self error: 'the dictionary is not in my pool']. "first see if it is declared in a superclass in which case we can remove it." (self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty ifFalse: [self sharedPools remove: aDictionary. self sharedPools isEmpty ifTrue: [self sharedPools: nil]. ^self]. "second get all the subclasses that reference aDictionary through me rather than a superclass that is one of my subclasses." workingSet := self subclasses asOrderedCollection. satisfiedSet := Set new. [workingSet isEmpty] whileFalse: [aSubclass := workingSet removeFirst. (aSubclass sharedPools includes: aDictionary) ifFalse: [satisfiedSet add: aSubclass. workingSet addAll: aSubclass subclasses]]. "for each of these, see if they refer to any of the variables in aDictionary because if they do, we can not remove the dictionary." satisfiedSet add: self. satisfiedSet do: [:sub | aDictionary associationsDo: [:aGlobal | (sub whichSelectorsReferTo: aGlobal) isEmpty ifFalse: [^self error: aGlobal key , ' is still used in code of class ' , sub name]]]. self sharedPools remove: aDictionary. self sharedPools isEmpty ifTrue: [self sharedPools: nil]! ! !Class methodsFor: 'testing' stamp: ''! isAnonymous ^self getName isNil! ! !Class methodsFor: 'testing' stamp: 'MarcusDenker 10/17/2013 12:04'! isClass ^ true! ! !Class methodsFor: 'class name' stamp: ''! rename: aString "The new name of the receiver is the argument, aString." | oldName newName | (newName := aString asSymbol) = (oldName := self name) ifTrue: [^ self]. (self environment includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. self setName: newName. self environment renameClass: self from: oldName. (Undeclared includesKey: newName) ifTrue: [self inform: 'There are references to, ' , aString printString , ' from Undeclared. Check them after this change.'].! ! !Class methodsFor: 'fileIn/Out' stamp: ''! shouldFileOutPool: aPoolName "respond with true if the user wants to file out aPoolName" ^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! ! !Class methodsFor: 'compiling' stamp: ''! compileAllFrom: oldClass "Recompile all the methods in the receiver's method dictionary (not the subclasses). Also recompile the methods in the metaclass." super compileAllFrom: oldClass. self class compileAllFrom: oldClass class! ! !Class methodsFor: 'traits' stamp: ''! applyChangesOfNewTraitCompositionReplacing: oldComposition | changedSelectors | changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. self classSide noteNewBaseTraitCompositionApplied: self traitComposition. ^ changedSelectors! ! !Class methodsFor: 'testing' stamp: ''! hasMethods "Answer a Boolean according to whether any methods are defined for the receiver (includes whether there are methods defined in the receiver's metaclass)." ^super hasMethods or: [self class hasMethods]! ! !Class methodsFor: 'pool variables' stamp: 'al 9/3/2004 13:41'! sharedPools: aCollection sharedPools := aCollection! ! !Class methodsFor: 'subclass creation' stamp: ''! classBuilder "Answer the object responsible of creating subclasses of myself in the system." ^ Smalltalk classBuilder! ! !Class methodsFor: 'initialize-release' stamp: ''! declare: varString "Declare class variables common to all instances. Answer whether recompilation is advisable." | newVars conflicts | newVars := (varString subStrings: ' ') collect: [:x | x asSymbol]. conflicts := false. (self classPool keys reject: [:x | newVars includes: x]) do: [:var | self removeClassVarNamed: var]. (newVars reject: [:var | self classPool includesKey: var]) do: [:var | "adding" "check if new vars defined elsewhere" (self innerBindingOf: var) ifNotNil: [(DuplicatedVariableError new) variable: var; signal: var , ' is defined elsewhere'. conflicts := true]]. newVars notEmpty ifTrue: [self classPool: self classPool. "in case it was nil" newVars do: [:var | self classPool declare: var from: Undeclared]]. ^conflicts! ! !Class methodsFor: '*Ring-Core-Kernel' stamp: ''! asRingDefinitionWithMethods: methodsBoolean withSuperclasses: supersBoolean withSubclasses: subsBoolean withPackages: packsBoolean "Retrieves a ring class/trait based on the receiver. The data loaded in the class/trait (active methods, superclasses, subclasses and packages) is requested by the users. As it may need to traverse hierarchies for retrieving super and subclasses a ring slice is created as the container for every class, method and package. To retrieve the slice: aRGClass environment " | rgClass rgSlice rgPackageKeys | rgSlice := RGSlice named: #fromImage. packsBoolean ifTrue: [ rgPackageKeys := rgSlice loadPackagesFromImage ]. rgClass := self asRingDefinitionWithMethods: methodsBoolean withSuperclasses: supersBoolean withSubclasses: subsBoolean withPackageKeys: rgPackageKeys in: rgSlice. rgSlice cleanEmptyPackages. rgSlice loadTraitUsers. ^ rgClass! ! !Class methodsFor: 'compiling' stamp: ''! compileAll super compileAll. self class compileAll.! ! !Class methodsFor: 'subclass creation' stamp: ''! variableSubclass: className instanceVariableNames: instVarNames classVariableNames: classVarNames category: cat "Added to allow for a simplified subclass creation experience. " ^ self variableSubclass: className instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: '' category: cat ! ! !Class methodsFor: 'accessing class hierarchy' stamp: ''! subclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." self subclasses size == 0 ifFalse:[self subclasses do: aBlock]! ! !Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:35'! traitComposition traitComposition ifNil: [traitComposition := TraitComposition new]. ^traitComposition! ! !Class methodsFor: 'private' stamp: ''! setName: aSymbol andRegisterInCategory: categorySymbol environment: aSystemDictionary (self isValidTraitName: aSymbol) ifFalse: [TraitException signal: 'Invalid trait name']. (self environment == aSystemDictionary and: [self name = aSymbol and: [self category = categorySymbol]]) ifTrue: [^self]. ((aSystemDictionary includes: aSymbol) and: [(aSystemDictionary at: aSymbol) ~~ self]) ifTrue: [TraitException signal: '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. self environment organization classify: self name under: categorySymbol. ^ true! ! !Class methodsFor: 'subclass creation' stamp: ''! variableWordSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory "Creates a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable word-sized nonpointer variables." ^ self subclass: aName uses: aTraitComposition with: [ self variableWordSubclass: aName instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory ]! ! !Class methodsFor: 'fileIn/Out' stamp: 'SebastianTleye 7/12/2013 15:20'! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool "File a description of the receiver on aFileStream. If the boolean argument, moveSource, is true, then set the trailing bytes to the position of aFileStream and to fileIndex in order to indicate where to find the source code." self crTrace: self name. super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. self class nonTrivial ifTrue: [aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr. self class fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool]! ! !Class methodsFor: 'compiling' stamp: ''! possibleVariablesFor: misspelled continuedFrom: oldResults | results | results := misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults. self sharedPools do: [:pool | results := misspelled correctAgainstDictionary: pool continuedFrom: results ]. self superclass == nil ifTrue: [ ^ misspelled correctAgainstDictionary: self environment continuedFrom: results ] ifFalse: [ ^ self superclass possibleVariablesFor: misspelled continuedFrom: results ]! ! !Class methodsFor: 'private' stamp: 'CamilloBruni 9/5/2013 09:46'! setName: aSymbol name := aSymbol.! ! !Class methodsFor: 'pool variables' stamp: ''! allSharedPools "Answer an ordered collection of the pools the receiver shares, including those defined in the superclasses of the receiver." | aSet | ^self superclass == nil ifTrue: [self sharedPools copy] ifFalse: [aSet := self superclass allSharedPools. aSet addAll: self sharedPools. aSet]! ! !Class methodsFor: 'subclass creation' stamp: ''! variableSubclass: aClassName uses: aTraitCompositionOrArray instanceVariableNames: instVarNames classVariableNames: classVarNames category: cat "Added to allow for a simplified subclass creation experience. " ^ self variableSubclass: aClassName uses: aTraitCompositionOrArray instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: '' category: cat! ! !Class methodsFor: 'subclass creation' stamp: ''! newSubclass | i className | i := 1. [className := (self name , i printString) asSymbol. self environment includesKey: className] whileTrue: [i := i + 1]. ^ self subclass: className instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Unclassified' "Point newSubclass new"! ! !Class methodsFor: 'accessing class hierarchy' stamp: 'ClementBera 9/27/2013 17:44'! subclasses "Answer a Set containing the receiver's subclasses." ^subclasses ifNil: [ #() ] ifNotNil: [ subclasses copy ]! ! !Class methodsFor: 'copying' stamp: ''! duplicateClassWithNewName: aSymbol | copysName class newDefinition | copysName := aSymbol asSymbol. copysName = self name ifTrue: [ ^ self ]. (Smalltalk globals includesKey: copysName) ifTrue: [ ^ self error: copysName , ' already exists' ]. newDefinition := self definition copyReplaceAll: '#' , self name asString with: '#' , copysName asString. class := self class compiler source: newDefinition; logged: true; evaluate. class classSide instanceVariableNames: self classSide instanceVariablesString. class copyAllCategoriesFrom: self. class class copyAllCategoriesFrom: self class. self hasComment ifTrue: [ class comment: self comment stamp: self organization commentStamp ]. ^ class! ! !Class methodsFor: 'subclass creation' stamp: ''! variableSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory "Creates a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable pointer variables." ^ self subclass: aName uses: aTraitComposition with: [ self variableSubclass: aName instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory ]! ! !Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:37'! traitComposition: aTraitComposition traitComposition := aTraitComposition! ! !Class methodsFor: 'subclass creation' stamp: ''! subclass: aSubclassSymbol instanceVariableNames: instVarNames classVariableNames: classVarNames category: aCategorySymbol "Added to allow for a simplified subclass creation experience. " ^ self subclass: aSubclassSymbol instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: '' category: aCategorySymbol! ! !Class methodsFor: 'pool variables' stamp: ''! usesLocalPoolVarNamed: aString "Return whether the receiver uses a pool variable named: aString which is defined locally" self hasSharedPools ifTrue: [ self sharedPools do: [:each | (each usesClassVarNamed: aString) ifTrue: [ ^true ]]] ifFalse: [ ^false ]. ^false! ! !Class methodsFor: 'private' stamp: 'CamilloBruni 11/21/2013 19:20'! getName ^ name! ! !Class methodsFor: 'class variables' stamp: ''! hasClassVarNamed: aString "Return whether the receiver has a class variables (shared variables among its class and subclasses) named: aString" ^ self classVarNames includes: aString! ! !Class methodsFor: 'subclass creation' stamp: ''! weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have weak indexable pointer variables." ^self classBuilder superclass: self weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !Class methodsFor: 'class variables' stamp: ''! removeClassVarNamed: aString "Remove the class variable whose name is the argument, aString, from the names defined in the receiver, a class. Create an error notification if aString is not a class variable or if it is still being used in the code of the class." | aSymbol | aSymbol := aString asSymbol. (self classPool includesKey: aSymbol) ifFalse: [ ^ self error: aString , ' is not a class variable' ]. self withAllSubclasses do: [ :subclass | (Array with: subclass with: subclass class) do: [ :classOrMeta | (classOrMeta whichSelectorsReferTo: (self classPool associationAt: aSymbol)) isEmpty ifFalse: [ InMidstOfFileinNotification signal ifTrue: [ self crTrace: self name , ' (' , aString , ' is Undeclared) '. ^ Undeclared declare: aSymbol from: self classPool ] ifFalse: [ (self confirm: (aString , ' is still used in code of class ' , classOrMeta name , '.\Is it okay to move it to Undeclared?') withCRs) ifTrue: [ ^ Undeclared declare: aSymbol from: self classPool ] ifFalse: [ ^ self ] ] ] ] ]. self classPool removeKey: aSymbol. self classPool isEmpty ifTrue: [ self classPool: nil ]! ! !Class methodsFor: 'class variables' stamp: ''! addClassVarNamed: aString "Add the argument, aString, as a class variable of the receiver. Signal an error if the first character of aString is not capitalized, or if it is already a variable named in the class." | symbol oldState | oldState := self copy. aString first canBeGlobalVarInitial ifFalse: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. symbol := aString asSymbol. self withAllSubclasses do: [:subclass | (subclass bindingOf: symbol) ifNotNil:[ ^ self error: aString , ' is already used as a variable name in class ' , subclass name]]. (self classPool includesKey: symbol) ifFalse: ["Pick up any refs in Undeclared" self classPool declare: symbol from: Undeclared. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: oldState to: self]! ! !Class methodsFor: 'class variables' stamp: ''! allClassVarNames "Answer a Set of the names of the receiver's class variables, including those defined in the superclasses of the receiver." | aSet | self superclass == nil ifTrue: [^self classVarNames asSet] "This is the keys so it is a new Set." ifFalse: [aSet := self superclass allClassVarNames. aSet addAll: self classVarNames. ^aSet]! ! !Class methodsFor: '*Manifest-Core' stamp: ''! criticTheNonMetaclassClass "Return the class of the receiver for the critic browser. This behavior may be folded later by changing the name of this method or using another one." ^ self ! ! !Class methodsFor: 'compiling' stamp: ''! bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver, or nil if variable with such name is not defined" "The lookup recurses up to superclasses looking inside their class and shared pools, but not the environment, since two classes, even if they have ancestry relationship, could use different environments. That's why we doing an environment lookup only as a last step of symbol lookup and taking only the environment of receiver only, not any of it's superclass(es) " | aSymbol | aSymbol := varName asSymbol. ^ (self innerBindingOf: aSymbol) ifNil: [ self environment bindingOf: aSymbol ]! ! !Class methodsFor: 'subclass creation' stamp: ''! variableWordSubclass: className instanceVariableNames: instVarNames classVariableNames: classVarNames category: cat "Added to allow for a simplified subclass creation experience. " ^ self variableWordSubclass: className instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: '' category: cat! ! !Class methodsFor: 'accessing class hierarchy' stamp: 'EstebanLorenzano 4/11/2014 15:52'! addSubclass: aSubclass "Make the argument, aSubclass, be one of the subclasses of the receiver. Create an error notification if the argument's superclass is not the receiver." aSubclass superclass ~~ self ifTrue: [^self error: aSubclass name , ' is not my subclass']. subclasses ifNil: [ self subclasses: (Array with: aSubclass). ^ self ]. self subclasses do:[:cl| cl == aSubclass ifTrue:[^self]]. "Already my subclass" self subclasses: (subclasses copyWith: aSubclass).! ! !Class methodsFor: 'initialize-release' stamp: ''! obsolete "Change the receiver and all of its subclasses to an obsolete class." self == Object ifTrue: [^self error: 'Object is NOT obsolete']. self setName: 'AnObsolete' , self name. Object class instSize + 1 to: self classSide instSize do: [:i | self instVarAt: i put: nil]. "Store nil over class instVars." self classPool: nil. self sharedPools: nil. self hasClassSide ifTrue: [ self theMetaClass obsolete]. super obsolete.! ! !Class methodsFor: '*Nautilus' stamp: 'johanfabry 1/30/2014 15:34'! definitionForNautilus "Answer a String that defines the receiver." | aStream poolString| poolString := self sharedPoolsString. aStream := (String new: 800) writeStream. superclass ifNil: [aStream nextPutAll: 'ProtoObject'] ifNotNil: [aStream nextPutAll: superclass name]. aStream nextPutAll: self kindOfSubclass; store: self name. (self hasTraitComposition) ifTrue: [ aStream cr; tab; nextPutAll: 'uses: '; nextPutAll: self traitCompositionString]. aStream cr; tab; nextPutAll: 'instanceVariableNames: '; store: self instanceVariablesString. aStream cr; tab; nextPutAll: 'classVariableNames: '; store: self classVariablesString. poolString = '' ifFalse: [ aStream cr; tab; nextPutAll: 'poolDictionaries: '; store: poolString]. aStream cr; tab; nextPutAll: 'category: '; store: self category asString. superclass ifNil: [ aStream nextPutAll: '.'; cr. aStream nextPutAll: self name. aStream space; nextPutAll: 'superclass: nil'. ]. ^ aStream contents! ! !Class methodsFor: 'organization' stamp: ''! 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 | self basicCategory ifNotNil: [ :symbol | ((self environment organization listAtCategoryNamed: symbol) includes: self name) ifTrue: [ ^symbol ] ]. self basicCategory: (result := self environment organization categoryOfElement: self name). ^result! ! !Class methodsFor: 'accessing parallel hierarchy' stamp: 'SebastianTleye 7/12/2013 14:42'! classClass ^self class.! ! !Class methodsFor: 'initialize-release' stamp: ''! sharing: poolString "Set up sharedPools. Answer whether recompilation is advisable." | oldPools | oldPools := self sharedPools. self sharedPools: OrderedCollection new. (poolString subStrings: ' ') do: [:poolName | self sharedPools add: (self environment at: poolName asSymbol ifAbsent:[ (self confirm: 'The pool dictionary ', poolName,' does not exist.', '\Do you want it automatically created?' withCRs) ifTrue:[self environment at: poolName asSymbol put: Dictionary new] ifFalse:[^self error: poolName,' does not exist']])]. self sharedPools isEmpty ifTrue: [self sharedPools: nil]. oldPools do: [:pool | | found | found := self sharedPools anySatisfy: [:p | p == pool]. found ifFalse: [^ true "A pool got deleted"]]. ^ false! ! !Class methodsFor: 'initialize-release' stamp: ''! removeFromSystem "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." self removeFromSystem: true.! ! !Class methodsFor: 'private' stamp: ''! isValidTraitName: aSymbol ^(aSymbol isEmptyOrNil or: [aSymbol first isLetter not or: [aSymbol anySatisfy: [:character | character isAlphaNumeric not]]]) not! ! !Class methodsFor: '*HelpSystem-Core' stamp: ''! asHelpTopic ^SystemReference forClass: self! ! !Class methodsFor: 'accessing parallel hierarchy' stamp: 'SebastianTleye 7/12/2013 14:42'! baseClass ^ self! ! !Class methodsFor: 'compiling' stamp: ''! innerBindingOf: aSymbol "Answer the binding of some variable resolved in the scope of the receiver, or one of its superclass but do not look up binding in receiver's environment. Use #bindingOf: for looking up the variable binding in a full scope, including receiver's environment" "First look in classVar dictionary." (self classPool bindingOf: aSymbol) ifNotNil: [:binding | ^binding]. "Next look in shared pools." self sharedPools do: [:pool | (pool bindingOf: aSymbol) ifNotNil: [:binding | ^binding]]. self superclass ifNotNil: [:supercl | ^ supercl innerBindingOf: aSymbol]. ^ nil! ! !Class methodsFor: 'subclass creation' stamp: ''! weakSubclass: className uses: aTraitCompositionOrArray instanceVariableNames: instVarNames classVariableNames: classVarNames category: cat "Added to allow for a simplified subclass creation experience. " ^ self weakSubclass: className uses: aTraitCompositionOrArray instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: '' category: cat ! ! !Class methodsFor: 'initialize-release' stamp: ''! removeFromSystem: logged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." "keep the class name and category for triggering the system change message. If we wait to long, then we get obsolete information which is not what we want." "tell class to deactivate and unload itself-- two separate events in the module system" self unload. self users do: [ :user | user removeFromComposition: self ]. self superclass ifNotNil: ["If we have no superclass there's nothing to be remembered" self superclass addObsoleteSubclass: self]. self environment forgetClass: self logged: logged. self obsolete.! ! !Class methodsFor: 'compiling' stamp: ''! binding "Answer a binding for the receiver, sharing if possible" | binding | binding := self environment associationAt: self name ifAbsent: [nil -> self]. ^binding value == self ifTrue: [binding] ifFalse: [nil -> self]! ! !Class methodsFor: 'subclass creation' stamp: ''! subclass: t ^ self subclass: t instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Unclassified' ! ! !Class methodsFor: 'pool variables' stamp: ''! usesPoolVarNamed: aString "Return whether the receiver has a pool variable named: aString, taking into account superclasses too" self allSharedPools do: [:each | (each usesClassVarNamed: aString) ifTrue: [^true]]. ^false! ! !Class methodsFor: '*Ring-Core-Kernel' stamp: 'MartinDias 11/7/2013 18:11'! asRingDefinition "A behavior is converted to a ring class. Only the receiver and its variables (instance, class, pools) are converted. Methods, superclasses, subclasses are not generated" | ring | ring := (RGFactory current createClassNamed: self name) category: self category; superclassName: self superclass name; traitCompositionSource: self traitCompositionString; addInstanceVariables: self instVarNames; addClassVariables: self classVarNames; addSharedPools: self sharedPoolNames; comment: self organization classComment; stamp: self organization commentStamp; definitionSource: self definition; package: self package asRingDefinition; withMetaclass. ring theMetaClass traitCompositionSource: self theMetaClass traitCompositionString; definitionSource: self theMetaClass definition; addInstanceVariables: self theMetaClass instVarNames. ^ ring! ! !Class methodsFor: 'testing' stamp: ''! hasAbstractMethods "Tells whether the receiver locally defines an abstract method, i.e., a method sending subclassResponsibility" ^ super hasAbstractMethods or: [self class hasAbstractMethods] ! ! !Class methodsFor: 'subclass creation - private' stamp: ''! subclass: aName uses: aTraitComposition with: aBlock "Define (or redefine) a subclass by evaluating a block closure. Note (MartinDias): This is a workaround for the subclass creation API when a trait is specified. To fix it well, in Pharo 4, a bit deeper refactoring is required, delegating this responsibility to SlotClassBuilder." ^ self environment at: aName ifPresent: [ :old | | copyOfOld newClass | copyOfOld := old copy. "Modify the class and set the new trait composition" newClass := aBlock value. newClass setTraitComposition: aTraitComposition asTraitComposition. "Announce that the definition changed when there is a new trait composution. Note: It may be a re-announce if there was other change in the class definition, e.g. an instace variable added." (newClass traitComposition syntacticallyEquals: copyOfOld traitComposition) ifFalse: [ SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfOld to: newClass ]. newClass ] ifAbsent: [ "Create the class and set the trait composition" aBlock value setTraitComposition: aTraitComposition asTraitComposition; yourself ].! ! !Class methodsFor: 'accessing' stamp: 'ClementBera 9/27/2013 17:43'! name "Answer the name of the receiver." ^ name ifNil: [ super name ]! ! !Class methodsFor: 'accessing' stamp: 'al 9/3/2004 13:37'! classPool: aDictionary classPool := aDictionary! ! !Class methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'! basicLocalSelectors: aSetOrNil localSelectors := aSetOrNil! ! !Class methodsFor: 'fileIn/Out' stamp: ''! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the receiver on aFileStream. If the boolean argument, moveSource, is true, then set the trailing bytes to the position of aFileStream and to fileIndex in order to indicate where to find the source code." ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! ! !Class methodsFor: 'instance variables' stamp: ''! removeInstVarNamed: aString "Remove the argument, aString, as one of the receiver's instance variables." | newInstVarString | (self instVarNames includes: aString) ifFalse: [self error: aString , ' is not one of my instance variables']. newInstVarString := ''. (self instVarNames copyWithout: aString) do: [:varName | newInstVarString := newInstVarString , ' ' , varName]. ^self classBuilder name: self name inEnvironment: self environment subclassOf: self superclass type: self typeOfClass instanceVariableNames: newInstVarString classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category! ! !Class methodsFor: 'accessing class hierarchy' stamp: ''! removeSubclass: aSubclass "If the argument, aSubclass, is one of the receiver's subclasses, remove it." self subclasses == nil ifFalse: [self subclasses: (self subclasses copyWithout: aSubclass). self subclasses isEmpty ifTrue: [self subclasses: nil]].! ! !Class methodsFor: 'pool variables' stamp: ''! sharedPoolOfVarNamed: aString "Returns the SharedPool or nil from which the pool variable named aString is coming from." ^ self sharedPools detect: [:each | each usesClassVarNamed: aString ] ifNone: [ self superclass == nil ifTrue: [nil] ifFalse: [self superclass sharedPoolOfVarNamed: aString] ]! ! !Class methodsFor: 'fileIn/Out' stamp: ''! fileOutPool: aPool onFileStream: aFileStream | aPoolName | (aPool isKindOf: SharedPool class) ifTrue:[^self notify: 'we do not fileout SharedPool type shared pools for now']. aPoolName := self environment keyAtIdentityValue: aPool. self crTrace: aPoolName. aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr. aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr. aPool keys asSortedCollection do: [ :aKey | | aValue | aValue := aPool at: aKey. aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put: '. (aValue isKindOf: Number) ifTrue: [aValue printOn: aFileStream] ifFalse: [aFileStream nextPutAll: '('. aValue printOn: aFileStream. aFileStream nextPutAll: ')']. aFileStream nextPutAll: '!!'; cr]. aFileStream cr! ! !Class methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'! basicCategory: aSymbol category := aSymbol! ! !Class methodsFor: 'accessing class hierarchy' stamp: 'ST 6/18/2013 16:28'! subclasses: aCollection subclasses := aCollection.! ! !Class methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitClass: self! ! !Class methodsFor: 'testing' stamp: ''! isClassOrTrait ^true! ! !Class methodsFor: 'organization' stamp: 'ClementBera 9/27/2013 17:42'! environment environment ifNil: [^ super environment]. ^ environment! ! !Class methodsFor: 'fileIn/Out' stamp: ''! fileOutInitializerOn: aStream ^self class fileOutInitializerOn: aStream! ! !Class methodsFor: 'fileIn/Out' stamp: ''! shouldFileOutPools "respond with true if the user wants to file out the shared pools" ^self confirm: 'FileOut selected sharedPools?'! ! !Class methodsFor: 'fileIn/Out' stamp: ''! removeFromChanges "References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet." ChangeSet current removeClassAndMetaClassChanges: self! ! !Class methodsFor: 'class variables' stamp: ''! classVarNames "Answer a collection of the names of the class variables defined in the receiver." ^self classPool keys asArray sort! ! !Class methodsFor: 'subclass creation' stamp: ''! variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable word-sized nonpointer variables." ^self classBuilder superclass: self variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat ! ! !Class methodsFor: 'initialize-release' stamp: ''! unload "Sent when a the class is removed. Does nothing, but may be overridden by (class-side) subclasses."! ! !Class methodsFor: 'compiling' stamp: ''! reformatAll "Reformat all methods in this class. Leaves old code accessible to version browsing" super reformatAll. "me..." self class reformatAll "...and my metaclass"! ! !Class methodsFor: 'class variables' stamp: ''! classVarNamed: aString "Answer the content of the Class Variable" ^self classPool at: aString asSymbol ifAbsent: [self error: 'no such lass var']! ! !Class methodsFor: '*Monticello' stamp: 'avi 3/10/2004 13:32'! classDefinitions ^ Array with: self asClassDefinition! ! !Class methodsFor: 'accessing parallel hierarchy' stamp: ''! hasClassSide ^self classSide notNil.! ! !Class methodsFor: 'subclass creation' stamp: ''! subclass: aName uses: aTraitCompositionOrArray instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory ^ self subclass: aName uses: aTraitCompositionOrArray with: [ self subclass: aName instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory ]! ! !Class methodsFor: 'subclass creation' stamp: ''! variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable pointer variables." ^self classBuilder superclass: self variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat ! ! !Class methodsFor: 'fileIn/Out' stamp: ''! hasSharedPools "Returns whether the receiver uses shared pools directly (Does not take into account that it may inherit shared pool uses." ^ self sharedPools notEmpty! ! !Class methodsFor: 'class variables' stamp: ''! classVarNamed: aString put: anObject "Store anObject in the class variable." | symbol | symbol := aString asSymbol. (self classPool includesKey: symbol) ifFalse: [^self error: 'no such lass var']. self classPool at: symbol put: anObject.! ! !Class methodsFor: 'pool variables' stamp: ''! addSharedPool: aSharedPool "Add the argument, aSharedPool, as one of the receiver's shared pools. Create an error if the shared pool is already one of the pools. This method will work with shared pools that are plain Dictionaries or thenewer SharedPool subclasses" (self sharedPools includes: aSharedPool) ifTrue: [^self error: 'This is already in my shared pool list']. self sharedPools == nil ifTrue: [self sharedPools: (OrderedCollection with: aSharedPool)] ifFalse: [self sharedPools add: aSharedPool]! ! !Class methodsFor: 'subclass creation' stamp: ''! weakSubclass: className instanceVariableNames: instVarNames classVariableNames: classVarNames category: cat "Added to allow for a simplified subclass creation experience. " ^ self weakSubclass: className instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: '' category: cat! ! !Class methodsFor: 'subclass creation' stamp: ''! subclass: t instanceVariableNames: ins ^ self subclass: t instanceVariableNames: ins classVariableNames: '' poolDictionaries: '' category: 'Unclassified' ! ! !Class methodsFor: 'subclass creation' stamp: ''! variableByteSubclass: aName uses: aTraitComposition instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory "Creates a new class as a subclass of an existing class (the receiver) in which the subclass is to have indexable byte-sized nonpointer variables." ^ self subclass: aName uses: aTraitComposition with: [ self variableByteSubclass: aName instanceVariableNames: someInstanceVariableNames classVariableNames: someClassVariableNames poolDictionaries: someSharedPoolNames category: aCategory ]! ! !Class methodsFor: 'copying' stamp: 'eem 5/15/2012 09:43'! copy "Answer a copy of the receiver without a list of subclasses. This copy is used by the ClassBuilder when mutating classes on redefinition. (SystemNavigation new browseAllCallsOn: #copy localTo: ClassBuilder)" | newClass | newClass := self class copy new superclass: superclass methodDict: self methodDict copy format: format name: name organization: self organization copy instVarNames: instanceVariables copy classPool: classPool copy sharedPools: sharedPools copy. Class instSize+1 to: self class instSize do: [:offset | newClass instVarAt: offset put: (self instVarAt: offset)]. ^ newClass! ! !Class methodsFor: 'subclass creation' stamp: ''! variableByteSubclass: className instanceVariableNames: instvarNames classVariableNames: classVarNames category: cat "Added to allow for a simplified subclass creation experience. " ^self variableByteSubclass: className instanceVariableNames: instvarNames classVariableNames: classVarNames poolDictionaries: '' category: cat! ! !Class methodsFor: 'accessing' stamp: 'ClementBera 9/27/2013 17:42'! classPool "Answer the dictionary of class variables." classPool ifNil: [ classPool := Dictionary new ]. ^ classPool! ! !Class methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'! basicLocalSelectors "Direct accessor for the instance variable localSelectors. Since localSelectors is lazily initialized, this may return nil, which means that all selectors are local." ^ localSelectors! ! !Class methodsFor: 'fileIn/Out' stamp: ''! fileOutSharedPoolsOn: aFileStream "file out the shared pools of this class after prompting the user about each pool" | poolsToFileOut | poolsToFileOut := self sharedPools select: [:aPool | (self shouldFileOutPool: (self environment keyAtIdentityValue: aPool))]. poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream]. ! ! !Class methodsFor: 'subclass creation' stamp: ''! subclass: aTraitName uses: aTraitCompositionOrArray instanceVariableNames: instVarNames classVariableNames: classVarNames category: cat ^ self subclass: aTraitName uses: aTraitCompositionOrArray instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: '' category: cat ! ! !Class methodsFor: 'subclass creation' stamp: ''! variableByteSubclass: className uses: aTraitCompositionOrArray instanceVariableNames: instVarNames classVariableNames: classVarNames category: cat "Added to allow for a simplified subclass creation experience. " ^ self variableByteSubclass: className uses: aTraitCompositionOrArray instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: '' category: cat! ! !Class methodsFor: 'subclass creation' stamp: ''! variableWordSubclass: className uses: aTraitCompositionOrArray instanceVariableNames: instVarNames classVariableNames: classVarNames category: cat "Added to allow for a simplified subclass creation experience. " ^ self variableWordSubclass: className uses: aTraitCompositionOrArray instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: '' category: cat! ! !Class methodsFor: 'self evaluating' stamp: ''! isSelfEvaluating ^self isObsolete not! ! !Class methodsFor: 'fileIn/Out' stamp: ''! 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." | internalStream | internalStream := (String new: 100) writeStream. internalStream header; timeStamp. self hasSharedPools ifTrue: [ self shouldFileOutPools ifTrue: [self fileOutSharedPoolsOn: internalStream]]. self fileOutOn: internalStream moveSource: false toFile: 0. internalStream trailer. FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true! ! !Class methodsFor: '*Ring-Core-Kernel' stamp: 'ClementBera 7/26/2013 16:10'! asRingDefinitionWithMethods: methodsBoolean withSuperclasses: supersBoolean withSubclasses: subsBoolean withPackageKeys: packageKeys in: aRGSlice | rgClass rgMethod rgSuper rgSub subs | rgClass := self asRingDefinition. aRGSlice loadClass: rgClass using: packageKeys. methodsBoolean ifTrue: [ self methodsDo:[ :mth| rgMethod := mth asActiveRingDefinition. aRGSlice loadMethod: rgMethod inClass: rgClass using: packageKeys ]. self theMetaClass methodsDo:[ :mth| rgMethod := mth asActiveRingDefinition. aRGSlice loadMethod: rgMethod inClass: rgClass theMetaClass using: packageKeys ] ]. supersBoolean ifTrue: [ self superclass ifNotNil:[ rgSuper := aRGSlice classNamed: self superclass name. rgSuper ifNil: [ rgSuper := self superclass asRingDefinitionWithMethods: methodsBoolean withSuperclasses: supersBoolean withSubclasses: subsBoolean withPackageKeys: packageKeys in: aRGSlice ]. rgClass superclass: rgSuper ] ]. subsBoolean ifTrue: [ subs := self subclasses select:[ :sub| sub isMeta not ]. rgClass name = #Trait ifTrue: [ subs := aRGSlice environment allTraits ]. subs do:[ :each| rgSub := aRGSlice classNamed: each name. rgSub ifNil: [ rgSub := each asRingDefinitionWithMethods: methodsBoolean withSuperclasses: supersBoolean withSubclasses: subsBoolean withPackageKeys: packageKeys in: aRGSlice ]. rgSub superclass: rgClass ] ]. ^rgClass! ! !Class class methodsFor: 'inquiries' stamp: ''! rootsOfTheWorld "return all classes that have a nil superclass" ^(Smalltalk globals select: [:each | each isBehavior and: [each superclass isNil]]) asOrderedCollection! ! !Class class methodsFor: 'private' stamp: ''! hasNoDependenciesFor: aClass in: unprocessedClasses cache: cache ^ (self hasNoSuperclassesOf: aClass in: unprocessedClasses cache: cache) and: [ aClass isMeta not or: [ self hasNoDependenciesForMetaclass: aClass in: unprocessedClasses cache: cache]] ! ! !Class class methodsFor: 'instance creation' stamp: ''! template: aSystemCategoryName "Answer an expression that can be edited and evaluated in order to define a new class." ^ self templateForSubclassOf: Object name category: aSystemCategoryName ! ! !Class class methodsFor: 'fileIn/Out' stamp: ''! doesNotIncludeInstanceOrSuperclassesFor: aClass in: unprocessedClasses cache: cache | soleInstance | soleInstance := aClass soleInstance. ^ (unprocessedClasses includes: soleInstance) not and: [ self hasNoSuperclassesOf: soleInstance in: unprocessedClasses cache: cache]! ! !Class class methodsFor: 'instance creation' stamp: ''! templateForSubclassOf: priorClassName category: systemCategoryName "Answer an expression that can be edited and evaluated in order to define a new class, given that the class previously looked at was as given" ^priorClassName asString, ' subclass: #NameOfSubclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''' , systemCategoryName asString , ''''! ! !Class class methodsFor: 'fileIn/Out' stamp: ''! superclassOrder: classes "Arrange the classes in the collection, classes, in superclass order so the classes can be properly filed in. Do it in sets instead of ordered collections." | all unprocessedClasses cache | unprocessedClasses := classes asSet. cache := Dictionary new. all := OrderedCollection new: unprocessedClasses size. unprocessedClasses size timesRepeat: [ |nextClass| nextClass := unprocessedClasses detect: [:aClass | self hasNoDependenciesFor: aClass in: unprocessedClasses cache: cache]. all add: nextClass. unprocessedClasses remove: nextClass]. ^all! ! !Class class methodsFor: 'fileIn/Out' stamp: ''! hasNoSuperclassesOf: aClass in: unprocessedClasses cache: cache ^ (unprocessedClasses includesAnyOf: (self allSuperclassesFor: aClass cache: cache)) not ! ! !Class class methodsFor: 'fileIn/Out' stamp: ''! fileOutPool: aString "file out the global pool named aString" | internalStream | internalStream := (String new: 1000) writeStream. self new fileOutPool: (self environment at: aString asSymbol) onFileStream: internalStream. FileStream writeSourceCodeFrom: internalStream baseName: aString isSt: true.! ! !Class class methodsFor: 'fileIn/Out' stamp: ''! hasNoDependenciesForMetaclass: aClass in: unprocessedClasses cache: cache | soleInstance | soleInstance := aClass soleInstance. ^ (unprocessedClasses includes: soleInstance) not and: [ self hasNoSuperclassesOf: soleInstance in: unprocessedClasses cache: cache]! ! !Class class methodsFor: 'fileIn/Out' stamp: ''! allSuperclassesFor: aClass cache: cache ^ cache at: aClass ifAbsentPut: [aClass allSuperclasses asArray]! ! !ClassAPIHelpBuilder commentStamp: 'tbn 4/30/2010 15:37'! A builder to build the API Help for a class Instance Variables addMethods: addSubclasses: subclassesAsSeparateTopic: addMethods - When true the builder will include method help addSubclasses - When true the builder will recursively go through and add subclasses subclassesAsSeparateTopic - xxxxx ! !ClassAPIHelpBuilder methodsFor: 'initialization' stamp: 'tbn 3/8/2010 16:37'! initialize "Initializes the receiver" super initialize. addSubclasses := false. addMethods := true. subclassesAsSeparateTopic := true.! ! !ClassAPIHelpBuilder methodsFor: 'accessing' stamp: 'tbn 3/8/2010 16:02'! addSubclasses ^ addSubclasses! ! !ClassAPIHelpBuilder methodsFor: 'building' stamp: 'tbn 3/23/2010 21:39'! build | instanceSide classSide | topicToBuild := (HelpTopic named: rootToBuildFrom name). topicToBuild icon: (HelpIcons iconNamed: #pageIcon). topicToBuild contents: rootToBuildFrom comment. addMethods ifTrue: [ self buildSubnodesForMethods ]. addSubclasses ifTrue: [ self buildSubnodesForSubclasses ]. ! ! !ClassAPIHelpBuilder methodsFor: 'private building' stamp: 'tbn 3/8/2010 16:56'! buildSubclassTopicFor: aSubclass ^(self class new) rootToBuildFrom: aSubclass; addSubclasses: addSubclasses; addMethods: addMethods; subclassesAsSeparateTopic: subclassesAsSeparateTopic; build; topicToBuild ! ! !ClassAPIHelpBuilder methodsFor: 'accessing' stamp: 'tbn 3/8/2010 16:02'! addSubclasses: anObject addSubclasses := anObject! ! !ClassAPIHelpBuilder methodsFor: 'accessing' stamp: 'tbn 3/8/2010 16:45'! subclassesAsSeparateTopic: anObject subclassesAsSeparateTopic := anObject! ! !ClassAPIHelpBuilder methodsFor: 'private building' stamp: 'LaurentLaffont 9/2/2010 15:44'! buildMethodTopicsOn: topic for: aClass |stream comments methodComment| stream := String new writeStream. aClass selectors asSortedCollection do: [:selector | stream nextPutAll: aClass name; nextPutAll: '>>'; nextPutAll: selector asString; cr. (methodComment := (aClass>>selector) comment) ifNil: [methodComment := 'Method has no comment.' ]. stream nextPutAll: methodComment;cr;cr. ]. topic contents: stream contents. ! ! !ClassAPIHelpBuilder methodsFor: 'accessing' stamp: 'tbn 3/8/2010 16:26'! addMethods ^ addMethods! ! !ClassAPIHelpBuilder methodsFor: 'accessing' stamp: 'tbn 3/8/2010 16:26'! addMethods: anObject addMethods := anObject! ! !ClassAPIHelpBuilder methodsFor: 'private building' stamp: 'tbn 3/23/2010 21:40'! buildSubnodesForSubclasses | topic | rootToBuildFrom subclasses isEmpty ifTrue: [^self]. topicToBuild icon: (HelpIcons iconNamed: #bookIcon). topic := subclassesAsSeparateTopic ifTrue: [topicToBuild addSubtopic: (HelpTopic named: 'Subclasses')] ifFalse: [topicToBuild ]. rootToBuildFrom subclasses do: [:subclass | topic addSubtopic: (self buildSubclassTopicFor: subclass)]. topic sortSubtopicsByTitle. ! ! !ClassAPIHelpBuilder methodsFor: 'private building' stamp: 'tbn 3/23/2010 21:40'! buildSubnodesForMethods | instanceSide classSide | instanceSide := HelpTopic named: 'Instance side'. classSide := HelpTopic named: 'Class side'. topicToBuild icon: (HelpIcons iconNamed: #bookIcon). topicToBuild addSubtopic: instanceSide; addSubtopic: classSide. self buildMethodTopicsOn: instanceSide for: rootToBuildFrom. self buildMethodTopicsOn: classSide for: rootToBuildFrom class. ! ! !ClassAPIHelpBuilder methodsFor: 'accessing' stamp: 'tbn 3/8/2010 16:45'! subclassesAsSeparateTopic ^ subclassesAsSeparateTopic! ! !ClassAPIHelpBuilder class methodsFor: 'building' stamp: 'tbn 3/11/2010 23:39'! buildHierarchicalHelpTopicFrom: aClass withSubclasses: aBoolean withMethods: anotherBoolean "Start building from the given class" ^(self new) addSubclasses: aBoolean; addMethods: anotherBoolean; rootToBuildFrom: aClass; build; topicToBuild ! ! !ClassAPIHelpBuilderTest commentStamp: 'TorstenBergmann 2/4/2014 21:18'! SUnit tests for ClassAPIHelpBuilder! !ClassAPIHelpBuilderTest methodsFor: 'testing' stamp: 'tbn 3/8/2010 16:33'! testDefaultBuilding |topic| topic := 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' ! ! !ClassAPIHelpBuilderTest methodsFor: 'testing' stamp: 'tbn 3/8/2010 16:32'! testMethodsButNoSubclasses |topic| topic := 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' ! ! !ClassAPIHelpBuilderTest methodsFor: 'testing' stamp: 'LaurentLaffont 9/2/2010 15:55'! testBuildingTraits |topic| topic := ClassAPIHelpBuilder buildHelpTopicFrom: TSortable . self assert: topic subtopics size = 2. self assert: topic subtopics first title = 'Instance side'. self assert: topic subtopics last title = 'Class side' ! ! !ClassAdded commentStamp: 'cyrilledelaunay 1/18/2011 11:56'! This announcement will be emitted when a class or a trait is added, using: => Trait >> named: (the notification is done in Trait >> named:uses:category:env:) => Class >> subclass: ! !ClassAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 17:47'! classAdded: aClass classAdded := aClass! ! !ClassAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 17:51'! classCategory ^classCategory! ! !ClassAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 17:46'! classAdded ^classAdded! ! !ClassAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 17:51'! classCategory: aClassCategoryName classCategory := aClassCategoryName! ! !ClassAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 13:50'! classAffected ^self classAdded! ! !ClassAdded class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/1/2012 17:52'! class: aClass category: aClassCategoryName ^self new classAdded: aClass; classCategory: aClassCategoryName; yourself! ! !ClassAnnouncement commentStamp: 'BenjaminVanRyseghem 1/23/2014 11:53'! I am an abstract class used to gather all the announcements related to class modifications.! !ClassCategoryReader commentStamp: ''! I represent a mechanism for retrieving class descriptions stored on a file.! !ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'al 11/28/2005 22:10'! scanFrom: aStream "File in methods from the stream, aStream." | methodText | [methodText := aStream nextChunkText. methodText size > 0] whileTrue: [class compile: methodText classified: category withStamp: changeStamp notifying: nil]! ! !ClassCategoryReader methodsFor: 'private' stamp: 'ajh 1/18/2002 01:14'! theClass ^ class! ! !ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'! setClass: aClass category: aCategory ^ self setClass: aClass category: aCategory changeStamp: String new ! ! !ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'! setClass: aClass category: aCategory changeStamp: aString class := aClass. category := aCategory. changeStamp := aString ! ! !ClassChangeRecord commentStamp: ''! A ClassChangeRecorder keeps track of most substantive changes premissible in a project, isolated or not. Structure: inForce a boolean Tells whether these changes are in effect. true for all changeSets in and above the current project. It should be sufficient only to record this for the changeSet as a whole, but this redundancy could help in error recovery. classIsLocal a boolean True if and only if this class is defined in this layer of the project structure. changeTypes an identitySet Summarizes which changes have been made in this class. Values include #comment, #reorganize, #rename, and the four more summarized below. thisName a string Retains the class name for this layer. priorName a string Preserves the prior name. thisComment a text Retains the class comment for this layer. priorComment a text Preserves the prior comment. thisOrganization a classOrganizer Retains the class organization for this layer. priorOrganization a classOrganizer Preserves the prior organization. thisMD a methodDictionary Used to prepare changes for nearly atomic invocation of this layer (see below). priorMD a methodDictionary Preserves the state of an altered class as it exists in the next outer layer of the project structure. methodChanges a dictionary of classChangeRecords Retains all the method changes for this layer. Four of the possible changeTypes are maintained in a mutually exclusive set, analogously to MethodChangeRecords. Here is a simple summary of the relationship between these four changeType symbols and the recording of prior state | prior == nil | prior not nil --------- |---------------------------- |-------------------- add | add | change --------- |---------------------------- |-------------------- remove | addedThenRemoved | remove A classChangeRecorder is notified of changes by the method noteMethodChange: . ClassChangeRecorders are designed to invoke a set of changes relative to the definition of a class in an prior layer. It is important that both invocation and revocation of these changes take place in a nearly atomic fashion so that interdependent changes will be adopted as a whole, and so that only one flush of the method cache should be necessary. A further reason for revocation to be simple is that it may be requested as an attempt to recover from an error in a project that is failing.! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 4/1/2000 23:49'! methodChanges ^ methodChanges! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 10:07'! changedSelectors "Return a set of the changed or removed selectors." ^ methodChanges keys! ! !ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/27/2000 22:06'! checkCoherence "If I recreate the class then don't remove it" (changeTypes includes: #remove) ifTrue: [changeTypes remove: #remove. changeTypes add: #change]. (changeTypes includes: #addedThenRemoved) ifTrue: [changeTypes remove: #addedThenRemoved. changeTypes add: #add]. ! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'nice 1/5/2010 15:59'! assimilateAllChangesIn: otherRecord otherRecord isClassRemoval ifTrue: [^ self noteChangeType: #remove]. otherRecord allChangeTypes do: [:chg | self noteChangeType: chg fromClass: self realClass]. otherRecord methodChanges associationsDo: [:assn | | changeType selector changeRecord | selector := assn key. changeRecord := assn value. changeType := changeRecord changeType. (changeType == #remove or: [changeType == #addedThenRemoved]) ifTrue: [changeType == #addedThenRemoved ifTrue: [self atSelector: selector put: #add]. self noteRemoveSelector: selector priorMethod: nil lastMethodInfo: changeRecord methodInfoFromRemoval] ifFalse: [self atSelector: selector put: changeType]]. ! ! !ClassChangeRecord methodsFor: 'rename' stamp: 'di 3/24/2000 09:38'! priorName ^ priorName! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'ClementBera 7/26/2013 16:09'! noteNewMethod: newMethod selector: selector priorMethod: methodOrNil | methodChange | methodChange := self findOrMakeMethodChangeAt: selector priorMethod: methodOrNil. methodOrNil ifNil: [ methodChange noteChangeType: #add ] ifNotNil: [ methodChange noteChangeType: #change ].! ! !ClassChangeRecord methodsFor: 'initialization' stamp: 'MarcusDenker 12/21/2012 12:01'! initFor: className changeTypes := IdentitySet new. methodChanges := IdentityDictionary new. priorName := thisName := className.! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'MarcusDenker 8/25/2010 20:59'! noteChangeType: changeSymbol fromClass: class (changeSymbol = #new or: [changeSymbol = #add]) ifTrue: [changeTypes add: #add. changeTypes remove: #change ifAbsent: []. ^ self]. changeSymbol = #change ifTrue: [(changeTypes includes: #add) ifTrue: [^ self]. ^ changeTypes add: changeSymbol]. changeSymbol == #addedThenRemoved ifTrue: [^ self]. "An entire class was added but then removed" changeSymbol = #comment ifTrue: [^ changeTypes add: changeSymbol]. changeSymbol = #reorganize ifTrue: [^ changeTypes add: changeSymbol]. changeSymbol = #rename ifTrue: [^ changeTypes add: changeSymbol]. (changeSymbol beginsWith: 'oldName: ') ifTrue: ["Must only be used when assimilating other changeSets" (changeTypes includes: #add) ifTrue: [^ self]. priorName := changeSymbol copyFrom: 'oldName: ' size + 1 to: changeSymbol size. ^ changeTypes add: #rename]. changeSymbol = #remove ifTrue: [(changeTypes includes: #add) ifTrue: [changeTypes add: #addedThenRemoved] ifFalse: [changeTypes add: #remove]. ^ changeTypes removeAllFoundIn: #(add change comment reorganize)]. self error: 'Unrecognized changeType'! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 11:01'! atSelector: selector put: changeType (self findOrMakeMethodChangeAt: selector priorMethod: nil) noteChangeType: changeType! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'sw 8/14/2002 11:11'! removeSelector: selector "Remove all memory of changes associated with the argument, selector, in this class." selector == #Comment ifTrue: [changeTypes remove: #comment ifAbsent: []] ifFalse: [methodChanges removeKey: selector ifAbsent: []]! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'eem 6/11/2008 16:53'! methodChangeTypes "Return an old-style dictionary of method change types." | dict | dict := IdentityDictionary new. methodChanges associationsDo: [:assn | | selector record | selector := assn key. record := assn value. dict at: selector put: record changeType]. ^ dict! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'MarcusDenker 8/25/2010 21:02'! allChangeTypes | chgs | (priorName notNil and: [ changeTypes includes: #rename ]) ifTrue: [ (chgs := changeTypes copy) add: 'oldName: ' , priorName. ^ chgs ]. ^ changeTypes! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/23/2000 23:00'! noteRemoveSelector: selector priorMethod: priorMethod lastMethodInfo: infoOrNil | methodChange | methodChange := self findOrMakeMethodChangeAt: selector priorMethod: priorMethod. methodChange changeType == #add ifTrue: [methodChange noteChangeType: #addedThenRemoved] ifFalse: [methodChange noteChangeType: #remove]. infoOrNil ifNotNil: ["Save the source code pointer and category so can still browse old versions" methodChange noteMethodInfoFromRemoval: infoOrNil] ! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/24/2000 09:36'! includesChangeType: changeType changeType == #new ifTrue: [^ changeTypes includes: #add]. "Backwd compat" ^ changeTypes includes: changeType! ! !ClassChangeRecord methodsFor: 'rename' stamp: 'di 5/8/2000 20:39'! noteNewName: newName thisName := newName! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/28/2000 15:14'! noteChangeType: changeSymbol ^ self noteChangeType: changeSymbol fromClass: nil! ! !ClassChangeRecord methodsFor: 'isolation layers' stamp: 'lr 3/14/2010 21:13'! realClass "Return the actual class (or meta), as determined from my name." thisName ifNil: [ ^ nil ]. (thisName endsWith: ' class') ifTrue: [ ^ (Smalltalk globals at: (thisName copyFrom: 1 to: thisName size - 6) asSymbol ifAbsent: [ ^ nil ]) class ] ifFalse: [ ^ Smalltalk globals at: thisName ifAbsent: [ ^ nil ] ]! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 10:38'! atSelector: selector ifAbsent: absentBlock ^ (methodChanges at: selector ifAbsent: absentBlock) changeType! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'MarcusDenker 8/25/2010 20:54'! findOrMakeMethodChangeAt: selector priorMethod: priorMethod ^methodChanges at: selector ifAbsentPut: [MethodChangeRecord new]! ! !ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/27/2000 22:08'! notePriorDefinition: oldClass oldClass ifNil: [^ self]. priorDefinition ifNil: [priorDefinition := oldClass definition]! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'di 5/16/2000 08:43'! trimHistory "Drop non-essential history." "Forget methods added and later removed" methodChanges keysAndValuesRemove: [:sel :chgRecord | chgRecord changeType == #addedThenRemoved]. "Forget renaming and reorganization of newly-added classes." (changeTypes includes: #add) ifTrue: [changeTypes removeAllFoundIn: #(rename reorganize)]. ! ! !ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/28/2000 09:12'! priorDefinition ^ priorDefinition! ! !ClassChangeRecord methodsFor: 'removal' stamp: 'ClementBera 7/26/2013 16:08'! forgetChangesIn: otherRecord "See forgetAllChangesFoundIn:. Used in culling changeSets." | cls otherMethodChanges | (cls := self realClass) ifNil: [ ^ self ]. "We can do better now, though..." otherMethodChanges := otherRecord methodChangeTypes. otherMethodChanges associationsDo: [ :assoc | | selector actionToSubtract | selector := assoc key. actionToSubtract := assoc value. (cls includesSelector: selector) ifTrue: [ (#(#add #change) includes: actionToSubtract) ifTrue: [ methodChanges removeKey: selector ifAbsent: [ ] ] ] ifFalse: [ (#(#remove #addedThenRemoved) includes: actionToSubtract) ifTrue: [ methodChanges removeKey: selector ifAbsent: [ ] ] ] ]. changeTypes isEmpty ifFalse: [ changeTypes removeAllFoundIn: otherRecord allChangeTypes. (changeTypes includes: #rename) ifFalse: [ changeTypes removeAllSuchThat: [ :x | x beginsWith: 'oldName: ' ] ] ]! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/28/2000 10:59'! hasNoChanges ^ changeTypes isEmpty and: [methodChanges isEmpty]! ! !ClassChangeRecord methodsFor: 'rename' stamp: 'tk 6/8/2001 09:11'! thisName ^ thisName! ! !ClassChangeRecord methodsFor: 'removal' stamp: 'di 4/1/2000 23:05'! isClassRemoval "NOTE: there are other removals with changeType #addedThenRemoved, but this message is used to write out removals in fileOut, and those cases should not be written out." ^ (changeTypes includes: #remove) or: [changeTypes includes: #removeClass]! ! !ClassCommentDeclaration commentStamp: ''! I represent the declaration of a class comment in a file. My contents are the class comment to import, and the comment reader is the object who knows the class where to put the class comment. Sending me the message #import makes me install the comment into the class.! !ClassCommentDeclaration methodsFor: 'importing' stamp: 'GuillermoPolito 5/5/2012 20:41'! import (self existsBehavior) ifFalse: [ self error: ('Cannot install comment in unexistent behavior {1}' format: { behaviorName asString } ) ]. ^self targetClass theNonMetaClass classComment: contents stamp: stamp! ! !ClassCommentDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 20:37'! stamp: classCommentStamp stamp := classCommentStamp! ! !ClassCommentDeclaration class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 21:04'! contents: someContents behaviorName: behaviorName isMeta: aBoolean stamp: stamp ^self new contents: someContents; behaviorName: behaviorName; isMeta: aBoolean; stamp: stamp; yourself! ! !ClassCommentReader commentStamp: 'TorstenBergmann 2/4/2014 21:42'! I represent a mechanism for retrieving class comment stored on a file.! !ClassCommentReader methodsFor: 'fileIn/Out' stamp: 'sw 7/31/2002 10:40'! scanFrom: aStream "File in the class comment from aStream. Not string-i-fied, just a text, exactly as it is in the browser. Move to changes file." class theNonMetaClass classComment: (aStream nextChunkText) stamp: changeStamp "Writes it on the disk and saves a RemoteString ref"! ! !ClassCommentReader class methodsFor: 'instance creation' stamp: 'AndrewBlack 9/1/2009 06:42'! forClass: aClass ^ self new setClass: aClass category: #Comment ! ! !ClassCommented commentStamp: ''! This announcement will be emitted when a class or a trait comment changes! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:55'! oldComment: andOldComment oldComment := andOldComment! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:13'! newComment ^newComment! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:13'! classCommented ^classCommented! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:55'! classCommented: aClass classCommented := aClass! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:13'! newStamp ^newStamp! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:55'! oldStamp: anOldStamp oldStamp := anOldStamp! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:55'! newComment: aNewComment newComment := aNewComment! ! !ClassCommented methodsFor: 'accessing' stamp: 'MartinDias 11/8/2013 12:58'! oldComment ^ oldComment! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 13:51'! classAffected ^self classCommented! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:54'! newStamp: aNewStamp newStamp := aNewStamp! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:14'! oldStamp oldStamp! ! !ClassCommented class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/1/2012 23:51'! class: aClass oldComment: oldComment newComment: newComment oldStamp: oldStamp newStamp: newStamp ^self new classCommented: aClass; oldComment: oldComment; oldStamp: oldStamp; newComment: newComment; newStamp: newStamp; yourself! ! !ClassCommented class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/1/2012 23:53'! classCommented: aClass self flag: #fixMePlease. "nils? no way!! " ^self class: aClass oldComment: nil newComment: nil oldStamp: nil newStamp: nil! ! !ClassDefinitionAcceptor commentStamp: ''! I am an acceptor in the case a class definition has been entered. My action is then to compile the definition as a class object! !ClassDefinitionAcceptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/16/2013 16:45'! accept: aText notifying: aController self model compileAClassFrom: aText notifying: aController! ! !ClassDescription commentStamp: ''! I add a number of facilities to basic Behaviors: Named instance variables Category organization for methods The notion of a name of this class (implemented as subclass responsibility) The maintenance of a ChangeSet, and logging changes on a file Most of the mechanism for fileOut. I am an abstract class, in particular, my facilities are intended for inheritance by two subclasses, Class and Metaclass.! !ClassDescription methodsFor: 'printing' stamp: ''! instanceVariablesString "Answer a string of my instance variable names separated by spaces." ^String streamContents: [ :stream | self instVarNames do: [ :each | stream nextPutAll: each ] separatedBy: [ stream space ] ]! ! !ClassDescription methodsFor: 'accessing comment' stamp: ''! comment: aStringOrText "Set the receiver's comment to be the argument, aStringOrText." self instanceSide classComment: aStringOrText.! ! !ClassDescription methodsFor: 'organization updating' stamp: ''! notifyOfRecategorizedSelector: element from: oldCategory to: newCategory SystemAnnouncer uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self. SystemAnnouncer uniqueInstance suspendAllWhile: [self notifyUsersOfRecategorizedSelector: element from: oldCategory to: newCategory].! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! fileOutCategory: catName | internalStream | internalStream := (String new: 1000) writeStream. internalStream header; timeStamp. self fileOutCategory: catName on: internalStream moveSource: false toFile: 0. internalStream trailer. ^ FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , catName) isSt: true.! ! !ClassDescription methodsFor: 'initialize-release' stamp: ''! updateInstancesFrom: oldClass "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)." "ar 7/15/1999: The updating below is possibly dangerous. If there are any contexts having an old instance as receiver it might crash the system if the new receiver in which the context is executed has a different layout. See bottom below for a simple example:" | oldInstances | oldInstances := oldClass allInstances asArray. oldInstances := self updateInstances: oldInstances from: oldClass isMeta: self isMeta. ^oldInstances " | crashingBlock class | class := Object subclass: #CrashTestDummy instanceVariableNames: 'instVar' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. class compile:'instVar: value instVar := value'. class compile:'crashingBlock ^[instVar]'. crashingBlock := (class new) instVar: 42; crashingBlock. Object subclass: #CrashTestDummy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. crashingBlock. crashingBlock value. " ! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! fileOutCategory: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the receiver's category, aString, onto aFileStream. If moveSource, is true, then set the method source pointer to the new file position. Note when this method is called with moveSource=true, it is condensing the .sources file, and should only write one preamble per method category." | selectors | aFileStream cr. selectors := self selectorsToFileOutCategory: aSymbol. "Overridden to preserve author stamps in sources file regardless" selectors do: [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]. ^ self! ! !ClassDescription methodsFor: 'instance variables' stamp: ''! instVarNames "Answer an Array of the receiver's instance variable names." self instanceVariables == nil ifTrue: [^#()] ifFalse: [^self instanceVariables]! ! !ClassDescription methodsFor: '*FuelTests' stamp: ''! duringTestCompileSilently: code ^ self duringTestCompileSilently: code storeSource: true! ! !ClassDescription methodsFor: '*rpackage-core' stamp: ''! packageOrganizer "Returns the organizer of this class" ^ RPackage organizer ! ! !ClassDescription methodsFor: 'accessing' stamp: 'ST 6/18/2013 16:34'! instanceVariables ^instanceVariables.! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod "Print a method category preamble. This must have a category name. It may have an author/date stamp, and it may have a prior source link. If it has a prior source link, it MUST have a stamp, even if it is empty." "The current design is that changeStamps and prior source links are preserved in the changes file. All fileOuts include changeStamps. Condensing sources, however, eliminates all stamps (and links, natch)." aFileStream cr; nextPut: $!!. aFileStream nextChunkPut: (String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString. (changeStamp ~~ nil and: [changeStamp size > 0 or: [priorMethod ~~ nil]]) ifTrue: [strm nextPutAll: ' stamp: '; print: changeStamp]. priorMethod ~~ nil ifTrue: [strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]). ! ! !ClassDescription methodsFor: 'testing' stamp: ''! isTestCase ^false! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: ''! classesThatImplementAllOf: selectorSet "Return an array of any classes that implement all the messages in selectorSet." | found remaining | found := OrderedCollection new. selectorSet do: [:sel | (self includesSelector: sel) ifTrue: [found add: sel]]. found isEmpty ifTrue: [^ self subclasses inject: Array new into: [:subsThatDo :sub | subsThatDo , (sub classesThatImplementAllOf: selectorSet)]] ifFalse: [remaining := selectorSet copyWithoutAll: found. remaining isEmpty ifTrue: [^ Array with: self]. ^ self subclasses inject: Array new into: [:subsThatDo :sub | subsThatDo , (sub classesThatImplementAllOf: remaining)]]! ! !ClassDescription methodsFor: 'compiling' stamp: ''! compileSilently: code classified: category "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." ^ self compileSilently: code classified: category notifying: nil.! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: ''! codeRewritingClass: aBuilder | target | target := aBuilder model. (aBuilder item: #'Rewrite Code') action: [ target refactor rewriteCode ]; parent: #'Code Rewriting'; order: 0. (aBuilder item: #'Search Code') action: [ target refactor searchCode ]; parent: #'Code Rewriting'; order: 100. (aBuilder item: #'Type class') action: [ target refactor typeClass ]; parent: #'Code Rewriting'; order: 200; withSeparatorAfter. (aBuilder item: #'Category Regex') action: [ target refactor categoryRegex ]; parent: #'Code Rewriting'; order: 300. (aBuilder item: #'Class Regex') action: [ target refactor classRegex ]; parent: #'Code Rewriting'; order: 400. (aBuilder item: #'Protocol Regex') action: [ target refactor protocolRegex ]; parent: #'Code Rewriting'; order: 500. (aBuilder item: #'Source Regex') action: [ target refactor sourceRegex ]; parent: #'Code Rewriting'; order: 600; withSeparatorAfter.! ! !ClassDescription methodsFor: '*Deprecated30' stamp: ''! methodsInCategory: aName "Answer a list of the methods of the receiver that are in category named aName" self deprecated: 'Use selectorsInProtocol: instead' on: '28 August 2013' in: #'Pharo3.0'. ^ self selectorsInProtocol: aName! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! fileOutOn: aFileStream "File a description of the receiver on aFileStream." self fileOutOn: aFileStream moveSource: false toFile: 0! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: ''! renameMethodAllItem: aBuilder ^ (aBuilder item: #'Rename method (all)') keyText: 'r, m' if: Nautilus useOldStyleKeys not; keyText: 'r' if: Nautilus useOldStyleKeys; action: [ | scroll target | target := aBuilder model. scroll := target methodWidget vScrollValue. target refactor renameMethodFor: target selectedMethod originMethod. target methodWidget vScrollValue: scroll ].! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'SebastianTleye 7/12/2013 14:45'! theNonMetaClass ^self baseClass! ! !ClassDescription methodsFor: 'initialize-release' stamp: ''! updateInstances: oldInstances from: oldClass isMeta: isMeta "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)." "If there are any contexts having an old instance as receiver it might crash the system because the layout has changed, and the method only knows about the old layout." | map variable instSize newInstances | oldInstances isEmpty ifTrue:[^#()]. "no instances to convert" isMeta ifTrue: [ oldInstances size = 1 ifFalse:[^self error:'Metaclasses can only have one instance']. self soleInstance class == self ifTrue:[ ^self error:'Metaclasses can only have one instance']]. map := self instVarMappingFrom: oldClass. variable := self isVariable. instSize := self instSize. newInstances := Array new: oldInstances size. 1 to: oldInstances size do:[:i| newInstances at: i put: ( self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)]. "Now perform a bulk mutation of old instances into new ones" oldInstances elementsExchangeIdentityWith: newInstances. ^newInstances "which are now old"! ! !ClassDescription methodsFor: 'organization' stamp: ''! zapOrganization "Remove the organization of this class by message categories. This is typically done to save space in small systems. Classes and methods created or filed in subsequently will, nonetheless, be organized" self organization: nil. self isClassSide ifFalse: [self classSide zapOrganization]! ! !ClassDescription methodsFor: '*Deprecated30' stamp: ''! allMethodsInCategory: aName "Answer a list of all the methods of the receiver and all its superclasses that are in the category named aName" self deprecated: 'Use allSelectorsInProtocol: ' on: '28 August 2013' in: #'Pharo3.0'. ^ self allSelectorsInProtocol: aName! ! !ClassDescription methodsFor: 'initialize-release' stamp: ''! superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver" super superclass: aClass methodDictionary: mDict format: fmt. self instanceVariables: nil. self organization: nil.! ! !ClassDescription methodsFor: 'organization' stamp: ''! organization "Answer the instance of ClassOrganizer that represents the organization of the messages of the receiver." self basicOrganization ifNil: [ self basicOrganization: (self isTrait ifTrue: [ ClassOrganization new ] ifFalse: [ ClassOrganization forClass: self ]) ]. ^self basicOrganization setSubject: self. "Making sure that subject is set correctly. It should not be necessary." ! ! !ClassDescription methodsFor: '*Nautilus' stamp: 'StephaneDucasse 8/12/2013 15:28'! buildAnalyzeSubMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Inst var references...') action: [target browseInstVarRefs]; parent: #Analyze; order: 0. (aBuilder item: #'Inst var assignments...') action: [target browseInstVarDefs]; parent: #Analyze; order: 100. (aBuilder item: #'Create inst var accessors') action: [target createInstVarAccessors]; parent: #Analyze; enabledBlock: [ target selectedClass instVarNames isEmpty not ]; order: 200; withSeparatorAfter. (aBuilder item: #'Create initializer with inst vars...') action: [ target createInitializerWithInstVars ]; parent: #Analyze; order: 300; enabledBlock: [ target showInstance ]. (aBuilder item: #'Generate initialize method') keyText: 'h, i' if: Nautilus useOldStyleKeys not; keyText: 'I' if: Nautilus useOldStyleKeys; action: [ target generateInitialize ]; parent: #Analyze; order: 350. (aBuilder item: #'Force the generaton of the initialize method') keyText: 'h, k' if: Nautilus useOldStyleKeys not; keyText: 'K' if: Nautilus useOldStyleKeys; action: [ target forceGenerateInitialize ]; parent: #Analyze; order: 375; enabledBlock: [ target showInstance ]; withSeparatorAfter. (aBuilder item: #'Class var refs...') action: [target browseClassVarRefs]; parent: #Analyze; order: 400. (aBuilder item: #'Class refs...') keyText: 'b, N' if: Nautilus useOldStyleKeys not; keyText: 'N' if: Nautilus useOldStyleKeys; action: [target browseClassRefs]; parent: #Analyze; order: 500. (target selectedClass inheritsFrom: SharedPool ) ifTrue: [ (aBuilder item: #'Shared Pool Users') action: [ target systemNavigation browseSharedPoolUsersOf: target selectedClass ]; parent: #Analyze; enabledBlock: [ target enableSingleClassSelection ]; order: 700]. (aBuilder item: #'Unsent methods...') action: [target browseUnusedMethods.]; parent: #Analyze; order: 800. (aBuilder item: #'Unreferenced inst vars...') action: [target showUnreferencedInstVars.]; parent: #Analyze; order: 900. (aBuilder item: #'Unreferenced class vars...') action: [target showUnreferencedClassVars.]; parent: #Analyze; order: 1000. ! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: ''! addSelector: selector withMethod: compiledMethod notifying: requestor | priorMethodOrNil | priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. priorMethodOrNil ifNil: [SystemAnnouncer uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor] ifNotNil: [SystemAnnouncer uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! ! !ClassDescription methodsFor: 'accessing' stamp: 'ST 6/18/2013 16:34'! instanceVariables: anObject instanceVariables := anObject! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: ''! isClassSide ^self == self classSide! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: ''! allProtocolsUpTo: mostGenericClass "Answer a list of all the method protocols of the receiver and all its superclasses, up through mostGenericClass" | otherClassCategories thisClassCategories lowercaseSortBlock | otherClassCategories := OrderedCollection new. lowercaseSortBlock := [ :a :b | a asLowercase <= b asLowercase ]. (self allSuperclassesIncluding: mostGenericClass) do: [ :aClass | otherClassCategories addAll: aClass organization categories ]. otherClassCategories remove: 'no messages' ifAbsent: [ ]. thisClassCategories := self organization categories sorted: lowercaseSortBlock. ^ thisClassCategories , ((otherClassCategories asSet removeAllSuchThat: [ :each | thisClassCategories includes: each ]) sorted: lowercaseSortBlock)! ! !ClassDescription methodsFor: 'compiling' stamp: ''! compile: code notifying: requestor "Refer to the comment in Behavior|compile:notifying:." ^self compile: code classified: Protocol unclassified notifying: requestor! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: ''! noteAddedSelector: aSelector meta: isMeta "A hook allowing some classes to react to adding of certain selectors"! ! !ClassDescription methodsFor: '*System-Support' stamp: ''! allUnreferencedClassVariables "Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses" ^ self systemNavigation allUnreferencedClassVariablesOf: self! ! !ClassDescription methodsFor: 'organization updating' stamp: ''! updateOrganizationDescription: each oldCategory: newCategoryOrNil newCategory: oldCategoryOrNil changed: changedCategories | sel effectiveCategory currentCategory | sel := each selector. (self includesLocalSelector: sel) ifTrue: [ ^ self ]. currentCategory := self organization categoryOfElement: sel. effectiveCategory := each effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil. effectiveCategory ifNil: [ currentCategory ifNotNil: [ changedCategories add: currentCategory ]. self organization removeElement: sel. ^ self ]. (currentCategory isNil or: [ currentCategory == Protocol ambiguous or: [ currentCategory == oldCategoryOrNil ] ]) ifFalse: [ ^ self ]. (currentCategory ~~ effectiveCategory) ifTrue: [ currentCategory ifNotNil: [ changedCategories add: currentCategory ]. self organization classify: sel under: effectiveCategory suppressIfDefault: false ]! ! !ClassDescription methodsFor: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:04'! addInstVarNamed: aString "Add the argument, aString, as one of the receiver's instance variables." self subclassResponsibility! ! !ClassDescription methodsFor: '*Slot' stamp: 'MartinDias 7/11/2013 16:01'! superclass: aSuperclass withLayoutType: layoutType slots: slotArray | superLayout newScope newLayout | superLayout := aSuperclass ifNil: [ EmptyLayout instance ] ifNotNil: [ aSuperclass layout ]. newScope := superLayout slotScope extend: slotArray. newLayout := layoutType extending: superLayout scope: newScope host: self. newLayout checkSanity. self superclass: aSuperclass layout: newLayout! ! !ClassDescription methodsFor: 'copying' stamp: ''! copyCategory: cat from: class "Specify that one of the categories of messages for the receiver is cat, as found in the class, class. Copy each message found in this category." self copyCategory: cat from: class classified: cat! ! !ClassDescription methodsFor: 'accessing comment' stamp: ''! classCommentBlank | existingComment stream | existingComment := self theNonMetaClass organization classComment. existingComment isEmpty ifFalse: [^existingComment]. stream := (String new: 100) writeStream. stream nextPutAll: 'A'; nextPutAll: (self name first isVowel ifTrue: ['n '] ifFalse: [' ']); nextPutAll: self name; nextPutAll: ' is xxxxxxxxx.'. (self instVarNames size > 0) ifTrue: [stream cr; cr; nextPutAll: 'Instance Variables'. ]. self instVarNames asSortedCollection do: [:each | stream cr; tab; nextPutAll: each; nextPut: $:; tab; tab; nextPutAll: '']. stream cr. self instVarNames asSortedCollection do: [:each | stream cr; nextPutAll: each; cr; tab; nextPutAll: '- xxxxx'; cr]. ^stream contents! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: 'SebastianTleye 8/13/2013 14:25'! methodRefactoring: aBuilder | target selectedMethod selectedMethods | target := aBuilder model. selectedMethod := target selectedMethod. selectedMethods := target selectedMethods. selectedMethod ifNil:[ ^ target ]. (aBuilder item: #'Add a parameter') action: [ target refactor addAParameterFor: selectedMethod ]; order: 50; parent: #'Refactoring'. (aBuilder item: #'Inline parameter') action: [ target refactor inlineParameterFor: selectedMethod ]; order: 100; parent: #'Refactoring'. (aBuilder item: #'Inline target sends') action: [ target refactor inlineAllSendersFor: selectedMethod ]; order: 200; parent: #'Refactoring'. (aBuilder item: #'Move') action: [ target refactor moveMethodFor: selectedMethod ]; order: 300; parent: #'Refactoring'. (aBuilder item: #'Swap') action: [ target refactor swapMethodFor: selectedMethods ]; order: 400; label: (target selectedClass isMeta ifTrue: [ 'Move to instance side' ] ifFalse:[ 'Move to class side']); parent: #'Refactoring'. (aBuilder item: #'Push up') action: [ target refactor pullUpMethodsFor: selectedMethods ]; order: 500; parent: #'Refactoring'. (aBuilder item: #'Push down') action: [ target refactor pushDownMethodsFor: selectedMethods ]; order: 600; parent: #'Refactoring'. (aBuilder item: #'Remove') action: [ target refactor removeMethodsFor: selectedMethods ]; order: 700; parent: #'Refactoring'. (aBuilder item: #'Remove parameter') action: [ target refactor removeParameterFor: selectedMethod ]; order: 800; enabledBlock: [ selectedMethods size < 2 ]; parent: #'Refactoring'. (self renameMethodAllItem: aBuilder) order: 850; parent: #'Refactoring'; withSeparatorAfter. (aBuilder item: #'Undo') order: 900; label: target refactor undoLabel; action: [ target refactor undoOperation ]; enabled: target refactor undoEnabled; parent: #'Refactoring'. (aBuilder item: #'Redo') order: 1000; label: target refactor redoLabel; action: [ target refactor redoOperation ]; enabled: target refactor redoEnabled; parent: #'Refactoring'; withSeparatorAfter.! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: 'SebastianTleye 8/13/2013 14:25'! refactoringMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Refactoring') order: -100. (aBuilder item: #'Rename inst var') action: [ target refactor renameInstVarFrom: self ]; order: -98. (aBuilder item: #'Rename class var') action: [ target refactor renameClassVarFrom: self ]; order: -97. (aBuilder item: #'Code Rewriting') order: 0; parent: #'Refactoring'. (aBuilder item: #'Class Refactoring') order: 100; parent: #'Refactoring'; withSeparatorAfter. (aBuilder item: #'Class Var Refactoring') order: 200; parent: #'Refactoring'. (aBuilder item: #'Inst Var Refactoring') order: 300; parent: #'Refactoring'; withSeparatorAfter. (aBuilder item: #'Undo') order: 400; label: target refactor undoLabel; action: [ target refactor undoOperation ]; enabled: target refactor undoEnabled; parent: #'Refactoring'. (aBuilder item: #'Redo') order: 500; label: target refactor redoLabel; action: [ target refactor redoOperation ]; enabled: target refactor redoEnabled; parent: #'Refactoring'; withSeparatorAfter.! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: ''! groupRefactoring: aBuilder | target | target := aBuilder model. (aBuilder item: #'Rewrite Code') order: 100; withSeparatorAfter. (aBuilder item: #'Rewrite Code') action: [ target refactor rewriteCode ]; parent: #'Rewrite Code'; order: 0. (aBuilder item: #'Search Code') action: [ target refactor searchCode ]; parent: #'Rewrite Code'; order: 100.! ! !ClassDescription methodsFor: 'organization updating' stamp: ''! noteMethodChanged: oldMethod to: newMethod SystemAnnouncer uniqueInstance methodChangedFrom: oldMethod to: newMethod ! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! methodsFor: categoryName "Answer a ClassCategoryReader for compiling the messages in the category, categoryName, of the receiver." ^ ClassCategoryReader new setClass: self category: categoryName asSymbol "(False methodsFor: 'logical operations') inspect"! ! !ClassDescription methodsFor: 'instance variables' stamp: ''! classThatDefinesInstanceVariable: instVarName (self instVarNames notNil and: [self instVarNames includes: instVarName asString]) ifTrue: [^ self]. ^self superclass ifNotNil: [self superclass classThatDefinesInstanceVariable: instVarName]! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! fileOutChangedMessages: aSet on: aFileStream "File a description of the messages of the receiver that have been changed (i.e., are entered into the argument, aSet) onto aFileStream." self fileOutChangedMessages: aSet on: aFileStream moveSource: false toFile: 0! ! !ClassDescription methodsFor: 'accessing comment' stamp: ''! hasComment "return whether this class truly has a comment other than the default" | org | org := self instanceSide organization. ^org classComment isEmptyOrNil not! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: ''! sourceCodeRefactoring: aBuilder | target | target := aBuilder model. (aBuilder item: #'Create cascade') action: [ target okToChange ifFalse: [ ^ target ]. target refactor createCascadeBetween: target sourceTextArea selectionInterval from: target selectedMethod ]; parent: #'Source code refactoring'; order: 0. (aBuilder item: #'Extract method') action: [ target okToChange ifFalse: [ ^ target ]. target refactor extractBetween: target sourceTextArea selectionInterval from: target selectedMethod ]; parent: #'Source code refactoring'; order: 100. (aBuilder item: #'Extract method to component') action: [ target okToChange ifFalse: [ ^ target ]. target refactor extractToComponentBetween: target sourceTextArea selectionInterval from: target selectedMethod ]; parent: #'Source code refactoring'; order: 200. (aBuilder item: #'Extract to temporary') action: [ target okToChange ifFalse: [ ^ target ]. target refactor extractToTemporaryBetween: target sourceTextArea selectionInterval from: target selectedMethod ]; parent: #'Source code refactoring'; order: 300. (aBuilder item: #'Inline method') action: [ target okToChange ifFalse: [ ^ target ]. target refactor inlineMethodBetween: target sourceTextArea selectionInterval from: target selectedMethod ]; parent: #'Source code refactoring'; order: 400. (aBuilder item: #'Inline method from component') action: [ target okToChange ifFalse: [ ^ target ]. target refactor inlineMethodFromComponentBetween: target sourceTextArea selectionInterval from: target selectedMethod ]; parent: #'Source code refactoring'; order: 500. (aBuilder item: #'Inline temporary') action: [ target okToChange ifFalse: [ ^ target ]. target refactor inlineTemporaryBetween: target sourceTextArea selectionInterval from: target selectedMethod ]; parent: #'Source code refactoring'; order: 600. (aBuilder item: #'Move variable definition') action: [ target okToChange ifFalse: [ ^ target ]. target refactor moveVariableDefinitionBetween: target sourceTextArea selectionInterval from: target selectedMethod ]; parent: #'Source code refactoring'; order: 700. (aBuilder item: #'Rename temporary') action: [ target okToChange ifFalse: [ ^ target ]. target refactor renameTemporaryNamed: target sourceTextArea selectedContents Between: target sourceTextArea selectionInterval from: target selectedMethod ]; parent: #'Source code refactoring'; order: 800. (aBuilder item: #'Split cascade') action: [ target okToChange ifFalse: [ ^ target ]. target refactor splitCascadeBetween: target sourceTextArea selectionInterval from: target selectedMethod ]; parent: #'Source code refactoring'; order: 900. (aBuilder item: #'Temporary to instvar') action: [ target okToChange ifFalse: [ ^ target ]. target refactor temporaryToInstanceVariableNamed: target sourceTextArea selectedContents asString Between: target sourceTextArea selectionInterval from: target selectedMethod ]; parent: #'Source code refactoring'; order: 1000; withSeparatorAfter. (aBuilder item: #'Undo') order: 1100; label: target refactor undoLabel; action: [ target refactor undoOperation ]; enabled: target refactor undoEnabled; parent: #'Source code refactoring'. (aBuilder item: #'Redo') order: 1200; label: target refactor redoLabel; action: [ target refactor redoOperation ]; enabled: target refactor redoEnabled; parent: #'Source code refactoring'; withSeparatorAfter.! ! !ClassDescription methodsFor: 'printing' stamp: ''! classVariablesString "Answer a string of my class variable names separated by spaces." ^String streamContents: [ :stream | self classVarNames do: [ :each | stream nextPutAll: each ] separatedBy: [ stream space ] ]! ! !ClassDescription methodsFor: 'instance variables' stamp: ''! hasInstVarNamed: aString "Return true whether the receiver defines an instance variable named aString." ^ self instVarNames includes: aString! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'SebastianTleye 7/12/2013 16:47'! addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor | priorMethodOrNil priorOriginOrNil oldProtocol newProtocol | priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [ nil ]. priorMethodOrNil ifNotNil: [ priorOriginOrNil := priorMethodOrNil origin ]. self addSelectorSilently: selector withMethod: compiledMethod. oldProtocol := self organization categoryOfElement: selector. SystemAnnouncer uniqueInstance suspendAllWhile: [ self organization classify: selector under: (category = Protocol unclassified ifTrue: [ oldProtocol ] ifFalse: [ category ]) ]. newProtocol := self organization categoryOfElement: selector. (priorMethodOrNil isNil or: [ priorOriginOrNil ~= compiledMethod origin ]) ifTrue: [ SystemAnnouncer uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: self requestor: requestor ] ifFalse: [ "If protocol changed and someone is from different package, I need to throw a method recategorized" self notifyRepackage: selector method: compiledMethod oldProtocol: oldProtocol newProtocol: newProtocol. SystemAnnouncer uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self oldProtocol: oldProtocol newProtocol: newProtocol requestor: requestor ]! ! !ClassDescription methodsFor: '*rpackage-core' stamp: ''! isExtended ^ self extendingPackages isEmpty! ! !ClassDescription methodsFor: 'organization updating' stamp: ''! applyChangesOfNewTraitCompositionReplacing: oldComposition | changedSelectors oldMethodDict | oldMethodDict := self methodDict copy. changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition. self noteChangesFrom: oldMethodDict. ^ changedSelectors.! ! !ClassDescription methodsFor: '*rpackage-core' stamp: ''! packages "the extending packages of a class are the packages that extend it." ^ self extendingPackages asSet copy add: self package; yourself! ! !ClassDescription methodsFor: '*Manifest-Core' stamp: ''! manifestBuilderForRuleChecker: aRuleChecker "Return the manifestsince the rulechecker is keeping a cache, we ask it back" ^ aRuleChecker manifestBuilderOfClass: self! ! !ClassDescription methodsFor: 'organization' stamp: 'EstebanLorenzano 6/27/2013 17:10'! basicOrganization: aClassOrg organization := aClassOrg! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: 'SebastianTleye 8/13/2013 14:17'! instVarRefactoring: aBuilder | target | target := aBuilder model. (aBuilder item: #'Add') action: [ target refactor addInstVarFrom: self ]; parent: #'Inst Var Refactoring'; order: 0. (aBuilder item: #'Rename') action: [ target refactor renameInstVarFrom: self ]; parent: #'Inst Var Refactoring'; order: 100. (aBuilder item: #'Remove') action: [ target refactor removeInstVarFrom: self ]; parent: #'Inst Var Refactoring'; icon: (Smalltalk ui icons iconNamed: #removeIcon); order: 200; withSeparatorAfter. (aBuilder item: #'Abstract') action: [ target refactor abstractInstVarFrom: self ]; parent: #'Inst Var Refactoring'; order: 300. (aBuilder item: #'Accessors') action: [ target refactor accessorsInstVarFrom: self ]; parent: #'Inst Var Refactoring'; order: 400. (aBuilder item: #'Pull up') action: [ target refactor pullUpInstVarFrom: self ]; parent: #'Inst Var Refactoring'; order: 500. (aBuilder item: #'Push down') action: [ target refactor pushDownInstVarFrom: self ]; parent: #'Inst Var Refactoring'; order: 600.! ! !ClassDescription methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: self name! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! putClassCommentToCondensedChangesFile: aFileStream "Called when condensing changes. If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2. Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday." | header aStamp aCommentRemoteStr | self isMeta ifTrue: [^ self]. "bulletproofing only" ((aCommentRemoteStr := self organization commentRemoteStr) isNil or: [aCommentRemoteStr sourceFileNumber = 1]) ifTrue: [^ self]. aFileStream cr; nextPut: $!!. header := String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. (aStamp := self organization commentStamp ifNil: ['']) storeOn: strm. strm nextPutAll: ' prior: 0']. aFileStream nextChunkPut: header. aFileStream cr. self organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp! ! !ClassDescription methodsFor: 'compiling' stamp: ''! compileSilently: code classified: category notifying: requestor "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." ^ SystemAnnouncer uniqueInstance suspendAllWhile: [self compile: code classified: category notifying: requestor].! ! !ClassDescription methodsFor: 'organization updating' stamp: ''! noteRecategorizedSelectors: aCollection oldComposition: aTraitComposition aCollection do: [:each | | oldCategory newCategory | oldCategory := self organization categoryOfElement: each. newCategory := (self traitComposition methodDescriptionForSelector: each) effectiveMethodCategory. self noteRecategorizedSelector: each from: oldCategory to: newCategory]! ! !ClassDescription methodsFor: 'organization updating' stamp: ''! noteMethodAdded: aMethod SystemAnnouncer uniqueInstance methodAdded: aMethod! ! !ClassDescription methodsFor: 'instance variables' stamp: ''! checkForInstVarsOK: instVarString "Return true if instVarString does no include any names used in a subclass" | instVarArray | instVarArray := instVarString subStrings: ' '. self allSubclasses do: [:cl | cl instVarNames do: [:n | (instVarArray includes: n) ifTrue: [self error: n , ' is already used in ' , cl name. ^ false]]]. ^ true! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: ''! subclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." ^self subclasses do: aBlock! ! !ClassDescription methodsFor: 'filein/out' stamp: 'ClementBera 9/27/2013 17:45'! definition "Answer a String that defines the receiver." | aStream | aStream := (String new: 800) writeStream. superclass ifNil: [aStream nextPutAll: 'ProtoObject'] ifNotNil: [aStream nextPutAll: superclass name]. aStream nextPutAll: self kindOfSubclass; store: self name. (self hasTraitComposition) ifTrue: [ aStream cr; tab; nextPutAll: 'uses: '; nextPutAll: self traitCompositionString]. aStream cr; tab; nextPutAll: 'instanceVariableNames: '; store: self instanceVariablesString. aStream cr; tab; nextPutAll: 'classVariableNames: '; store: self classVariablesString. aStream cr; tab; nextPutAll: 'poolDictionaries: '; store: self sharedPoolsString. aStream cr; tab; nextPutAll: 'category: '; store: self category asString. superclass ifNil: [ aStream nextPutAll: '.'; cr. aStream nextPutAll: self name. aStream space; nextPutAll: 'superclass: nil'. ]. ^ aStream contents! ! !ClassDescription methodsFor: 'instance variables' stamp: ''! forceNewFrom: anArray "Create a new instance of the class and fill its instance variables up with the array." | object max | object := self new. max := self instSize. anArray doWithIndex: [:each :index | index > max ifFalse: [object instVarAt: index put: each]]. ^ object! ! !ClassDescription methodsFor: 'printing' stamp: ''! storeOn: aStream "Classes and Metaclasses have global names." aStream nextPutAll: self name! ! !ClassDescription methodsFor: 'organization updating' stamp: ''! noteMethodRemoved: oldMethod SystemAnnouncer uniqueInstance methodRemoved: oldMethod! ! !ClassDescription methodsFor: 'instance variables' stamp: ''! instVarNameForIndex: index "Answer the named instance variable with index index or nil if none." | superInstSize | index > self instSize ifTrue: [^nil]. superInstSize := self superclass ifNil: [0] ifNotNil: [self superclass instSize]. index > superInstSize ifTrue: [^self instanceVariables at: index - superInstSize]. self superclass ifNil: [^nil]. ^self superclass instVarNameForIndex: index "(Object allSubclasses select: [:cls| cls instSize > cls superclass instSize and: [cls subclasses isEmpty and: [cls superclass instSize > 0]]]) collect: [:cls| (1 to: cls instSize) collect: [:i| cls instVarNameForIndex: i]]"! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: ''! commentInventory "Answer a string with a count of the classes with and without comments for all the classes in the package of which this class is a member." "Morph commentInventory" ^ self environment organization commentInventory: (self category copyUpTo: $-), '*'! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: ''! removeProtocol: aString "Remove each of the messages categorized under aString in the method dictionary of the receiver. Then remove the category aString." | categoryName | categoryName := aString asSymbol. (self organization listAtCategoryNamed: categoryName) do: [:sel | self removeSelector: sel]. self organization removeCategory: categoryName! ! !ClassDescription methodsFor: 'compiling' stamp: ''! compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource | method | method := self compiler source: text; requestor: requestor; category: category; failBlock: [ ^nil ]; compile. logSource ifTrue: [ self logMethodSource: (requestor ifNotNil: [ :r | r text ] ifNil: [ text ]) "the requestor text might have been changed by the compiler and may be different thant text argument" forMethod: method inCategory: category withStamp: changeStamp]. self addAndClassifySelector: method selector withMethod: method inProtocol: category notifying: requestor. self instanceSide noteCompilationOf: method selector meta: self isClassSide. ^ method selector! ! !ClassDescription methodsFor: '*FuelTests' stamp: ''! duringTestCompileSilently: code storeSource: storeSource ^ self duringTestCompileSilently: code storeSource: storeSource classified: ''! ! !ClassDescription methodsFor: 'private' stamp: ''! newInstanceFrom: oldInstance variable: variable size: instSize map: map "Create a new instance of the receiver based on the given old instance. The supplied map contains a mapping of the old instVar names into the receiver's instVars" | new | variable ifTrue: [new := self basicNew: oldInstance basicSize] ifFalse: [new := self basicNew]. 1 to: instSize do: [:offset | (map at: offset) > 0 ifTrue: [new instVarAt: offset put: (oldInstance instVarAt: (map at: offset))]]. variable ifTrue: [1 to: oldInstance basicSize do: [:offset | new basicAt: offset put: (oldInstance basicAt: offset)]]. ^new! ! !ClassDescription methodsFor: 'pool variable' stamp: ''! allSharedPools "Answer an ordered collection of the shared pools the receiver shares, including those defined in the superclasses of the receiver." ^ OrderedCollection new! ! !ClassDescription methodsFor: 'compiling' stamp: ''! wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism." ^ true! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! moveChangesTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile." | changes | changes := self selectors select: [:sel | (self compiledMethodAt: sel) fileIndex > 1 ]. self fileOutChangedMessages: changes on: newFile moveSource: true toFile: 2! ! !ClassDescription methodsFor: 'private' stamp: ''! linesOfCode "An approximate measure of lines of code. Includes comments, but excludes blank lines." | lines | lines := self localMethods inject: 0 into: [:sum :each | sum + each linesOfCode]. ^ self isMeta ifTrue: [lines] ifFalse: [lines + self class linesOfCode]! ! !ClassDescription methodsFor: 'compiling' stamp: ''! compile: text classified: category notifying: requestor | stamp | stamp := self acceptsLoggingOfCompilation ifTrue: [ Author changeStamp ] ifFalse: [ nil ]. ^ self compile: text classified: category withStamp: stamp notifying: requestor! ! !ClassDescription methodsFor: 'printing' stamp: ''! sharedPoolsString "Answer a string of my shared pool names separated by spaces." ^String streamContents: [ :stream | self sharedPools do: [ :each | stream nextPutAll: (self environment keyAtIdentityValue: each ifAbsent: [ 'private' ]) ] separatedBy: [ stream space ] ]! ! !ClassDescription methodsFor: '*Deprecated30' stamp: ''! allMethodCategoriesIntegratedThrough: mostGenericClass "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" self deprecated: 'Use allProtocolsUpTo:' on: '28 August 2013' in: #'Pharo3.0'. ^ self allProtocolsUpTo: mostGenericClass! ! !ClassDescription methodsFor: 'organization updating' stamp: 'SebastianTleye 7/12/2013 16:46'! updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil | changedCategories composition | changedCategories := IdentitySet new. composition := self hasTraitComposition ifTrue: [ self traitComposition ] ifFalse: [ TraitComposition new ]. (composition methodDescriptionsForSelector: aSymbol) do: [ :each | self updateOrganizationDescription: each oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil changedCategories: changedCategories ]. ^ changedCategories! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! selectorsToFileOutCategory: aSymbol ^ self organization listAtCategoryNamed: aSymbol! ! !ClassDescription methodsFor: 'users notification' stamp: ''! notifyUsersOfRecategorizedSelector: element from: oldCategory to: newCategory self users do: [:each | each noteRecategorizedSelector: element from: oldCategory to: newCategory]! ! !ClassDescription methodsFor: 'organization' stamp: ''! addCategory: newName before: aCategory ^ self organization addCategory: newName before: aCategory ! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: 'SebastianTleye 8/13/2013 14:20'! varRefactoringSubMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Add') action: [ target refactor addClassVarFrom: self ]; parent: #'Class Var Refactoring'; order: 0. (aBuilder item: #'Rename') action: [ target refactor renameClassVarFrom: self ]; parent: #'Class Var Refactoring'; order: 100. (aBuilder item: #'Remove') action: [ target refactor removeClassVarFrom: self ]; parent: #'Class Var Refactoring'; icon: (Smalltalk ui icons iconNamed: #removeIcon); order: 200; withSeparatorAfter. (aBuilder item: #'Abstract') action: [ target refactor abstractClassVarFrom: self ]; parent: #'Class Var Refactoring'; order: 300. (aBuilder item: #'Accessors') action: [ target refactor accessorsClassVarFrom: self ]; parent: #'Class Var Refactoring'; order: 400. (aBuilder item: #'Pull up') action: [ target refactor pullUpClassVarFrom: self ]; parent: #'Class Var Refactoring'; order: 500. (aBuilder item: #'Push down') action: [ target refactor pushDownClassVarFrom: self ]; parent: #'Class Var Refactoring'; order: 600.! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: ''! refactoringMethod: aBuilder (aBuilder item: #'Refactoring') order: -100. (self renameMethodAllItem: aBuilder) order: -90; withSeparatorAfter! ! !ClassDescription methodsFor: 'compiling' stamp: ''! noteCompilationOf: aSelector meta: isMeta "A hook allowing some classes to react to recompilation of certain selectors"! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: ''! sourceCodeRefactoringMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Format') order: 1100; keyText: 'Ctrl Shift f'; action: [ target refactor formatSourceCode ]. (aBuilder item: #'Source code refactoring') order: 1101; arguments: {}; withSeparatorAfter.! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: ''! allSelectorsInProtocol: aName "Answer a list of all the methods of the receiver and all its superclasses that are in the protocol named aName" | aColl | aColl := OrderedCollection new. self withAllSuperclasses do: [:aClass | aColl addAll: (aClass organization listAtCategoryNamed: aName) ]. ^ aColl asSet asArray sort! ! !ClassDescription methodsFor: '*Deprecated30' stamp: ''! removeCategory: aString "Remove each of the messages categorized under aString in the method dictionary of the receiver. Then remove the category aString." self deprecated: 'Use removeProtocol:' on: '28 August 2013' in: #'Pharo3.0'. self removeProtocol: aString! ! !ClassDescription methodsFor: '*rpackage-core' stamp: ''! packagesWithoutExtensions ^ Set new add: self package; yourself.! ! !ClassDescription methodsFor: 'instance variables' stamp: ''! instVarIndexFor: instVarName ifAbsent: aBlock "Answer the index of the named instance variable." | index | index := self instanceVariables == nil ifTrue: [0] ifFalse: [self instanceVariables indexOf: instVarName ifAbsent: [0]]. index = 0 ifTrue: [^self superclass == nil ifTrue: [aBlock value] ifFalse: [self superclass instVarIndexFor: instVarName ifAbsent: aBlock]]. ^self superclass == nil ifTrue: [index] ifFalse: [index + self superclass instSize]! ! !ClassDescription methodsFor: 'copying' stamp: ''! copyCategory: cat from: aClass classified: newCat "Specify that one of the categories of messages for the receiver is the third argument, newCat. Copy each message found in the category cat in class aClass into this new category." self copyAll: (aClass organization listAtCategoryNamed: cat) from: aClass classified: newCat! ! !ClassDescription methodsFor: 'organization' stamp: ''! whichCategoryIncludesSelector: aSelector "Answer the category of the argument, aSelector, in the organization of the receiver, or answer nil if the receiver does not inlcude this selector." (self includesSelector: aSelector) ifTrue: [^ self organization categoryOfElement: aSelector] ifFalse: [^nil]! ! !ClassDescription methodsFor: 'accessing comment' stamp: ''! comment "Answer the receiver's comment. (If missing, supply a template) " | aString | aString := self instanceSide organization classComment. aString isEmpty ifFalse: [^ aString]. ^self classCommentBlank! ! !ClassDescription methodsFor: 'pool variable' stamp: ''! usesLocalPoolVarNamed: aString ^false.! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." | pointer header file oldCommentRemoteString oldComment oldStamp | oldComment := self organization classComment. oldStamp := self organization commentStamp. (aString isKindOf: RemoteString) ifTrue: [ SystemAnnouncer uniqueInstance class: self oldComment: oldComment newComment: aString string oldStamp: oldStamp newStamp: aStamp. ^ self organization classComment: aString stamp: aStamp]. oldCommentRemoteString := self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteString isNil) ifTrue: [^ self organization classComment: nil]. "never had a class comment, no need to write empty string out" pointer := oldCommentRemoteString ifNil: [0] ifNotNil: [oldCommentRemoteString sourcePointer]. (file := SourceFiles at: 2) ifNotNil: [ file setToEnd; cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header := String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. aStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: pointer printString]. file nextChunkPut: header]. self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. SystemAnnouncer uniqueInstance class: self oldComment: oldComment newComment: aString oldStamp: oldStamp newStamp: aStamp! ! !ClassDescription methodsFor: '*rpackage-core' stamp: ''! package ^ RPackage organizer packageOf: self. ! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: ''! printSubclassesOn: aStream level: level "As part of the algorithm for printing a description of the receiver, print the subclass on the file stream, aStream, indenting level times." | subclassNames | aStream crtab: level. aStream nextPutAll: self name. aStream space; print: self instVarNames. self == Class ifTrue: [aStream crtab: level + 1; nextPutAll: '[ ... all the Metaclasses ... ]'. ^self]. subclassNames := self subclasses asSortedCollection:[:c1 :c2| c1 name <= c2 name]. "Print subclasses in alphabetical order" subclassNames do: [:subclass | subclass printSubclassesOn: aStream level: level + 1]! ! !ClassDescription methodsFor: 'copying' stamp: ''! copyAll: selArray from: class "Install all the methods found in the method dictionary of the second argument, class, as the receiver's methods. Classify the messages under -As yet not classified-." self copyAll: selArray from: class classified: nil! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: ''! uncategorizedSelectors ^ self selectorsInProtocol: Protocol unclassified! ! !ClassDescription methodsFor: 'compiling' stamp: ''! compile: code classified: heading "Compile the argument, code, as source code in the context of the receiver and install the result in the receiver's method dictionary under the classification indicated by the second argument, heading. nil is to be notified if an error occurs. The argument code is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string." ^self compile: code classified: heading notifying: nil! ! !ClassDescription methodsFor: 'compiling' stamp: ''! instVarNamesAndOffsetsDo: aBinaryBlock "This is part of the interface between the compiler and a class's instance or field names. The class should enumerate aBinaryBlock with the instance variable name strings and their integer offsets. The order is important. Names evaluated later will override the same names occurring earlier." | superInstSize | (superInstSize := self superclass notNil ifTrue: [self superclass instSize] ifFalse: [0]) > 0 ifTrue: [self superclass instVarNamesAndOffsetsDo: aBinaryBlock]. 1 to: self instSize - superInstSize do: [:i| aBinaryBlock value: (self instanceVariables at: i) value: i + superInstSize]! ! !ClassDescription methodsFor: 'accessing comment' stamp: ''! comment: aStringOrText stamp: aStamp "Set the receiver's comment to be the argument, aStringOrText." self instanceSide classComment: aStringOrText stamp: aStamp.! ! !ClassDescription methodsFor: 'private' stamp: ''! instVarMappingFrom: oldClass "Return the mapping from instVars of oldClass to new class that is used for converting old instances of oldClass." | oldInstVarNames | oldInstVarNames := oldClass allInstVarNames. ^self allInstVarNames collect: [:instVarName | oldInstVarNames indexOf: instVarName].! ! !ClassDescription methodsFor: '*NautilusCommon' stamp: ''! correspondingForTest "Return the unit test that correspond to me. If it does not exist, it returns myself. Return the tested class if sent to a class" | className | className := (self inheritsFrom: TestCase) ifTrue: [ self name copyReplaceAll: 'Test' with: '' ] ifFalse: [ self name, 'Test' ]. ^ Smalltalk at: className asSymbol ifAbsent: [ self ] ! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: ''! removeSelector: selector "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." | priorMethod priorProtocol origin | priorMethod := self compiledMethodAt: selector ifAbsent: [^ nil]. origin := priorMethod origin. priorProtocol := self whichCategoryIncludesSelector: selector. super removeSelector: selector. SystemAnnouncer uniqueInstance suspendAllWhile: [self updateOrganizationSelector: selector oldCategory: priorProtocol newCategory: nil]. SystemAnnouncer uniqueInstance methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self origin: origin.! ! !ClassDescription methodsFor: 'initialize-release' stamp: ''! obsolete "Make the receiver obsolete." self superclass removeSubclass: self. self organization: nil. super obsolete.! ! !ClassDescription methodsFor: 'private' stamp: ''! errorCategoryName self error: 'Category name must be a String'! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: ''! packageRefactoringMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Rewrite Code') order: 100; withSeparatorAfter. (aBuilder item: #'Rewrite Code') action: [ target refactor rewriteCode ]; parent: #'Rewrite Code'; order: 0. (aBuilder item: #'Search Code') action: [ target refactor searchCode ]; parent: #'Rewrite Code'; order: 100.! ! !ClassDescription methodsFor: 'organization updating' stamp: ''! noteRecategorizedSelector: aSymbol from: oldCategoryOrNil to: newCategoryOrNil | changedCategories | changedCategories := self updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil. changedCategories do: [:each | (self organization isEmptyCategoryNamed: each) ifTrue: [self organization removeCategory: each]]! ! !ClassDescription methodsFor: 'organization' stamp: ''! organization: aClassOrg "Install an instance of ClassOrganizer that represents the organization of the messages of the receiver." aClassOrg ifNotNil: [aClassOrg setSubject: self]. self basicOrganization: aClassOrg.! ! !ClassDescription methodsFor: 'instance variables' stamp: ''! instVarIndexFor: instVarName "Answer the index of the named instance variable." | index | index := self instanceVariables == nil ifTrue: [0] ifFalse: [self instanceVariables indexOf: instVarName]. index = 0 ifTrue: [^self superclass == nil ifTrue: [0] ifFalse: [self superclass instVarIndexFor: instVarName]]. ^self superclass == nil ifTrue: [index] ifFalse: [index + self superclass instSize]! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'MarcusDenker 9/9/2013 09:27'! baseClass ^self subclassResponsibility.! ! !ClassDescription methodsFor: '*Manifest-Core' stamp: ''! criticClass "Return the class of the receiver for the critic browser. This behavior may be folded later by changing the name of this method or using another one." ^ self! ! !ClassDescription methodsFor: '*Slot' stamp: 'MartinDias 12/9/2013 11:38'! layoutSized: size |layoutInstance layoutClass| layoutClass := FixedLayout. self isBits ifTrue: [ self isBytes ifTrue: [ layoutClass := ByteLayout ]. self isWords ifTrue: [ layoutClass := WordLayout ]] ifFalse: [ self isVariable ifTrue: [ layoutClass := VariableLayout ]. self isWeak ifTrue: [ layoutClass := WeakLayout ]]. layoutInstance := layoutClass new: size. layoutInstance host: self. ^ layoutInstance! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'SebastianTleye 7/17/2013 13:16'! classClass ^self subclassResponsibility.! ! !ClassDescription methodsFor: '*Nautilus' stamp: ''! definitionForNautilus ^ self definition! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: ''! selectorsInCategory: aName "Answer a list of the selectors of the receiver that are in category named aName" | aColl | aColl := Set withAll: (self organization listAtCategoryNamed: aName). ^ aColl asArray sort! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! fileOutMethod: selector on: aStream (selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.']. (self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found']. aStream header; timeStamp. self printMethodChunk: selector withPreamble: true on: aStream moveSource: false toFile: 0.! ! !ClassDescription methodsFor: '*Manifest-Core' stamp: ''! mcWorkingCopy MCWorkingCopy managersForClass: self do: [: package | ^ package ]! ! !ClassDescription methodsFor: 'authors' stamp: ''! authors "Returns a bag representing the author frequency based on the latest version of the methods of the receiver." ^(self methods, self class methods) collect: [ :each | each author ] as: Bag . ! ! !ClassDescription methodsFor: 'organization' stamp: ''! reorganize "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" ^self organization! ! !ClassDescription methodsFor: 'copying' stamp: ''! copyAllCategoriesFrom: aClass "Specify that the categories of messages for the receiver include all of those found in the class, aClass. Install each of the messages found in these categories into the method dictionary of the receiver, classified under the appropriate categories." aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! ! !ClassDescription methodsFor: 'instance variables' stamp: ''! allInstVarNamesEverywhere "Answer the set of inst var names used by the receiver, all superclasses, and all subclasses" | aList | aList := OrderedCollection new. (self allSuperclasses , self withAllSubclasses asOrderedCollection) do: [:cls | aList addAll: cls instVarNames]. ^ aList asSet "BorderedMorph allInstVarNamesEverywhere"! ! !ClassDescription methodsFor: 'copying' stamp: ''! copy: sel from: class "Install the method associated with the first argument, sel, a message selector, found in the method dictionary of the second argument, class, as one of the receiver's methods. Classify the message under -As yet not classified-." self copy: sel from: class classified: nil! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! commentStamp: changeStamp prior: indexAndOffset "Prior source link ignored when filing in." ^ ClassCommentReader new setClass: self category: #Comment changeStamp: changeStamp! ! !ClassDescription methodsFor: 'pool variable' stamp: ''! usesPoolVarNamed: aString "Only classes may use a pool variable named: aString" ^ false! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! fileOutMethod: selector "Write source code of a single method on a file. Make up a name for the file." | internalStream | internalStream := (String new: 1000) writeStream. self fileOutMethod: selector on: internalStream. FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true.! ! !ClassDescription methodsFor: '*rpackage-core' stamp: ''! isDefinedInPackage: aPackage "returns true if aPackage contains the definitino of this class" ^ aPackage includesClass: self.! ! !ClassDescription methodsFor: 'instance variables' stamp: ''! classThatDefinesClassVariable: classVarName "Answer the class that defines the given class variable" (self classPool includesKey: classVarName asSymbol) ifTrue: [^ self]. ^self superclass ifNotNil: [self superclass classThatDefinesClassVariable: classVarName]! ! !ClassDescription methodsFor: 'compiling' stamp: ''! logMethodSource: aText forMethod: aCompiledMethod inCategory: category withStamp: changeStamp aCompiledMethod putSource: aText class: self category: category withStamp: changeStamp inFile: 2 priorMethod: (self compiledMethodAt: aCompiledMethod selector ifAbsent: [])! ! !ClassDescription methodsFor: 'organization' stamp: 'EstebanLorenzano 6/27/2013 17:10'! basicOrganization ^ organization ! ! !ClassDescription methodsFor: 'copying' stamp: ''! copyAll: selArray from: class classified: cat "Install all the methods found in the method dictionary of the second argument, class, as the receiver's methods. Classify the messages under the third argument, cat." selArray do: [:s | (class includesLocalSelector: s) ifTrue: [ self copy: s from: class classified: cat ] ]! ! !ClassDescription methodsFor: 'compiling' stamp: ''! acceptsLoggingOfCompilation "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself Weird name is so that it will come lexically before #compile, so that a clean build can make it through." ^ true! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the receiver on aFileStream. If the boolean argument, moveSource, is true, then set the trailing bytes to the position of aFileStream and to fileIndex in order to indicate where to find the source code." aFileStream nextChunkPut: self definition. self organization putCommentOnFile: aFileStream numbered: fileIndex moveSource: moveSource forClass: self. self organization realCategories do: [:heading | self fileOutCategory: heading on: aFileStream moveSource: moveSource toFile: fileIndex]! ! !ClassDescription methodsFor: 'pool variable' stamp: ''! sharedPoolOfVarNamed: aString "Only classes may have shared pools" ^ nil! ! !ClassDescription methodsFor: '*Deprecated30' stamp: ''! uncategorizedMethods self deprecated: 'Use uncategorizedSelectors' on: '28 August 2013' in: #'Pharo3.0'. ^ self uncategorizedSelectors ! ! !ClassDescription methodsFor: '*Slot' stamp: 'CAmi 3/15/2011 18:33'! initializeLayoutWithSlots: slots | offset superlayout| superlayout := superclass layout. offset := superlayout size. "create the new layout and copy in the super slots" layout := self layoutSized: slots size + offset. layout replaceFrom: 1 to: offset with: superlayout. "create new slots" slots withIndexDo: [ :slot :index| layout at: offset + index put: slot asSlot]. layout finalize. "backup solution to create instvar names" instanceVariables := Array new: slots size. 1 to: slots size do: [ :index| instanceVariables at: index put: (layout at: index + offset) name].! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the messages of this class that have been changed (i.e., are entered into the argument, aSet) onto aFileStream. If moveSource, is true, then set the method source pointer to the new file position. Note when this method is called with moveSource=true, it is condensing the .changes file, and should only write a preamble for every method." | org | (org := self organization) realCategories do: [:cat | | sels | sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. sels do: [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]]! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! classComment: aString "Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing. Empty string gets stored only if had a non-empty one before." ^ self classComment: aString stamp: ''! ! !ClassDescription methodsFor: 'private' stamp: ''! notifyRepackage: selector method: compiledMethod oldProtocol: oldProtocol newProtocol: newProtocol | oldPackage newPackage | (newProtocol = oldProtocol) ifTrue: [ ^ self ]. "This indirection is because we need to abstract RPackage from the kernel" #RPackage asClassIfPresent: [ :rPackageClass | newPackage := rPackageClass organizer packageForProtocol: newProtocol inClass: self. oldPackage := rPackageClass organizer packageForProtocol: oldProtocol inClass: self. "Announce recategorization" newPackage = oldPackage ifFalse: [ SystemAnnouncer uniqueInstance methodRepackaged: compiledMethod from: oldPackage to: newPackage ] ]. SystemAnnouncer uniqueInstance selector: selector recategorizedFrom: oldProtocol to: newProtocol inClass: self! ! !ClassDescription methodsFor: 'users notification' stamp: ''! notifyUsersOfChangedSelectors: aCollection self users do: [:each | each noteChangedSelectors: aCollection]! ! !ClassDescription methodsFor: 'copying' stamp: ''! copy: sel from: class classified: cat "Install the method associated with the first arugment, sel, a message selector, found in the method dictionary of the second argument, class, as one of the receiver's methods. Classify the message under the third argument, cat." | code category | "Useful when modifying an existing class" code := class sourceCodeAt: sel. code ifNotNil: [cat ifNil: [category := class organization categoryOfElement: sel] ifNotNil: [category := cat]. (self includesLocalSelector: sel) ifTrue: [code asString = (self sourceCodeAt: sel) asString ifFalse: [self error: self name , ' ' , sel , ' will be redefined if you proceed.']]. self compile: code classified: category]! ! !ClassDescription methodsFor: '*rpackage-core' stamp: ''! compileSilently: code "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." ^ self compileSilently: code classified: 'not defined category' notifying: nil.! ! !ClassDescription methodsFor: 'instance variables' stamp: ''! removeInstVarNamed: aString "Remove the argument, aString, as one of the receiver's instance variables. Create an error notification if the argument is not found." ^self subclassResponsibility! ! !ClassDescription methodsFor: '*NautilusRefactoring' stamp: 'SebastianTleye 8/13/2013 14:25'! refactoringSubmenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Rename...') keyText: 'r, c' if: Nautilus useOldStyleKeys not; keyText: 'r' if: Nautilus useOldStyleKeys; action: [ target renameClassWithRefactoringEngine: target selectedClass theNonMetaClass ]; parent: #'Class Refactoring'; order: 0. (aBuilder item: #'Remove...') action: [ target removeClassWithRefactoringEngine: target selectedClasses ]; icon: (Smalltalk ui icons iconNamed: #removeIcon); parent: #'Class Refactoring'; order: 100; withSeparatorAfter. (aBuilder item: #'Generate Accessors') keyText: 'h, a' if: Nautilus useOldStyleKeys not; action: [ target refactor generateAccessors ]; parent: #'Class Refactoring'; order: 200. (aBuilder item: #'Generate Superclass...') action: [ target refactor generateSuperClass ]; parent: #'Class Refactoring'; order: 300. (aBuilder item: #'Generate Subclass...') action: [ target refactor generateSubclass ]; parent: #'Class Refactoring'; order: 400. (aBuilder item: #'Realize') action: [ target refactor realizeClass ]; parent: #'Class Refactoring'; order: 500. (aBuilder item: #'Split') action: [ target refactor splitClass: target selectedClass ]; parent: #'Class Refactoring'; order: 600.! ! !ClassDescription methodsFor: '*rpackage-core' stamp: ''! extendingPackages "the extending packages of a class are the packages that extend it." ^ RPackage organizer extendingPackagesOf: self! ! !ClassDescription methodsFor: '*Manifest-Core' stamp: ''! criticNameOn: aStream "This behavior may be folded later by changing the name of this method or using another one." aStream << self name << ' (' << self category << ')' ! ! !ClassDescription methodsFor: 'organization updating' stamp: ''! updateOrganizationDescription: aTraitMethodDescription oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil changedCategories: changedCategories | sel effectiveCategory currentCategory | sel := aTraitMethodDescription selector. (self includesLocalSelector: sel) ifTrue: [ ^ self ]. currentCategory := self organization categoryOfElement: sel. effectiveCategory := aTraitMethodDescription effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil. effectiveCategory ifNil: [ currentCategory ifNotNil: [ changedCategories add: currentCategory ]. ^ self organization removeElement: sel ]. ((currentCategory isNil or: [ currentCategory == Protocol ambiguous or: [ currentCategory == oldCategoryOrNil ] ]) and: [ currentCategory ~~ effectiveCategory ]) ifTrue: [ currentCategory ifNotNil: [ changedCategories add: currentCategory ]. self organization classify: sel under: effectiveCategory suppressIfDefault: false ]! ! !ClassDescription methodsFor: '*Fuel' stamp: ''! instanceVariableNamesDo: anUnaryBlock "This is part of the interface between the compiler and a class's instance or field names. The class should enumerate anUnaryBlock with the instance variable name strings. The order is important. Names evaluated later will override the same names occurring earlier." | superInstSize | (superInstSize := self superclass notNil ifTrue: [self superclass instSize] ifFalse: [0]) > 0 ifTrue: [self superclass instanceVariableNamesDo: anUnaryBlock]. 1 to: self instSize - superInstSize do: [:i| anUnaryBlock value: (self instanceVariables at: i)]! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'SebastianTleye 7/12/2013 14:44'! theMetaClass ^self classClass! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: ''! selectorsInProtocol: aName "Answer a list of the selectors of the receiver that are in category named aName" | aColl | aColl := Set withAll: (self organization listAtCategoryNamed: aName). ^ aColl asArray sort! ! !ClassDescription methodsFor: 'compiling' stamp: ''! reformatAll "Reformat all methods in this class" self methods do: [:method | method reformat]! ! !ClassDescription methodsFor: '*FuelTests' stamp: ''! duringTestCompileSilently: code classified: aCategory ^ self duringTestCompileSilently: code storeSource: true classified: aCategory! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: ''! isInstanceSide ^self isClassSide not! ! !ClassDescription methodsFor: '*FuelTests' stamp: ''! duringTestCompileSilently: code storeSource: storeSource classified: aCategory ^ Author useAuthor: 'TestsAuthor' during: [ [ self compile: code classified: (aCategory ifNil: [ '' ]) withStamp: nil notifying: nil logSource: storeSource ] fuelValueWithoutNotifications ]! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: ''! hasClassSide ^self subclassResponsibility.! ! !ClassDescription methodsFor: 'pool variable' stamp: ''! hasSharedPools "Only a class may have shared pools" ^ false! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: ''! instanceSide ^ self theNonMetaClass! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: ''! isMeta ^self isClassSide! ! !ClassDescription methodsFor: '*Slot' stamp: 'MartinDias 7/30/2012 01:49'! superclass: aSuperclass layout: aLayout layout := aLayout. " layout host: self. --> this is done in #buildFrom:scope:host:" self superclass: aSuperclass methodDictionary: MethodDictionary new format: aLayout format. instanceVariables := layout instanceVariables asArray! ! !ClassDescription methodsFor: 'compiling' stamp: ''! compile: text classified: category withStamp: changeStamp notifying: requestor ^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! commentStamp: changeStamp self organization commentStamp: changeStamp. ^ self commentStamp: changeStamp prior: 0! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! printMethodChunk: selector withPreamble: doPreamble on: outStream moveSource: moveSource toFile: fileIndex "Copy the source code for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." | preamble method oldPos newPos sourceFile endPos | doPreamble ifTrue: [ preamble := self name , ' methodsFor: ' , (self organization categoryOfElement: selector) asString printString ] ifFalse: [ preamble := '' ]. method := self methodDict at: selector ifAbsent: [ outStream nextPutAll: selector; cr. outStream tab; nextPutAll: '** ERROR!! THIS SCRIPT IS MISSING ** ' translated; cr; cr. outStream nextPutAll: ' '. ^ outStream ]. oldPos := method filePosition. sourceFile := SourceFiles at: method fileIndex. preamble size > 0 ifTrue: [ "Copy the preamble" outStream copyPreamble: preamble from: sourceFile at: oldPos ] ifFalse: [ sourceFile position: oldPos ]. "Copy the method chunk" newPos := outStream position. outStream copyMethodChunkFrom: sourceFile. sourceFile skipSeparators. "The following chunk may have ]style[" sourceFile peek == $] ifTrue: [ outStream cr; copyMethodChunkFrom: sourceFile ]. moveSource ifTrue: [ "Set the new method source pointer" endPos := outStream position. method setSourcePosition: newPos inFile: fileIndex ]. preamble size > 0 ifTrue: [ outStream nextChunkPut: ' ' ]. ^ outStream cr! ! !ClassDescription methodsFor: 'copying' stamp: ''! copyMethodDictionaryFrom: donorClass "Copy the method dictionary of the donor class over to the receiver" self methodDict: donorClass copyOfMethodDictionary. self organization: donorClass organization deepCopy.! ! !ClassDescription methodsFor: '*rpackage-core' stamp: ''! packageFromOrganizer: anOrganizer "returns the package that defines this class" ^ anOrganizer packageOf: self.! ! !ClassDescription methodsFor: 'organization updating' stamp: 'SebastianTleye 7/12/2013 16:49'! noteChangesFrom: oldMethodDict "create notifications about the changes made to the method dictionary" "additions have already been notified in #addTraitSelector:withMethod:" " deal with removal / updates relative to the old method dictionary" oldMethodDict keysAndValuesDo: [ :selector :oldMethod| self methodDict at: selector ifPresent: [ :currentMethod| currentMethod == oldMethod ifFalse: [ self noteMethodChanged: oldMethod to: currentMethod]] ifAbsent: [ self noteMethodRemoved: oldMethod ]]. ! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! localMethods "returns the methods of classes including the ones of the traits that the class uses" ^ self methods select: [:each | self includesLocalSelector: each selector].! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: ''! classSide ^self theMetaClass.! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: ''! addSelectorSilently: selector withMethod: compiledMethod super addSelectorSilently: selector withMethod: compiledMethod. self instanceSide noteAddedSelector: selector meta: self isMeta.! ! !ClassDescription methodsFor: 'compiling' stamp: ''! wantsRecompilationProgressReported "Answer whether the receiver would like progress of its recompilation reported interactively to the user." ^ true! ! !ClassDescription methodsFor: 'filein/out' stamp: ''! fileOutOrganizationOn: aFileStream "File a description of the receiver's organization on aFileStream." aFileStream cr; nextPut: $!!. aFileStream nextChunkPut: self name, ' reorganize'; cr. aFileStream nextChunkPut: self organization stringForFileOut ; cr! ! !ClassDescription methodsFor: 'private' stamp: ''! spaceUsed ^super spaceUsed + (self hasClassSide ifTrue: [self classSide spaceUsed] ifFalse: [0])! ! !ClassDescription methodsFor: 'private' stamp: ''! numberOfMethods "count all methods that are local (not comming from a trait)" | num | num := self localMethods size. ^ self isMeta ifTrue: [ num ] ifFalse: [ num + self class numberOfMethods ] ! ! !ClassDescription methodsFor: '*rpackage-core' stamp: ''! isExtendedInPackage: aPackage "returns true if aPackage defines an extension to this class" ^ aPackage extendsClass: self.! ! !ClassDescriptionTest commentStamp: ''! This is the unit test for the class ClassDescription. 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 - there is a chapter in the PharoByExample book (http://pharobyexample.org) - the sunit class category! !ClassDescriptionTest methodsFor: 'tests' stamp: 'StephaneDucasse 8/29/2013 20:55'! testAllMethodCategoriesIntegratedThrough "If this test fails, it may be because method protocols are sorted in #allMethodCategoriesIntegratedThrough. Take care that if the protocols of the class under test are already sorted, you won't see any problem." self assert: ((CompiledMethod selectorsInProtocol: 'testing') includes: #isAbstract). CompiledMethod allProtocolsUpTo: Object. self assert: ((CompiledMethod selectorsInProtocol: 'testing') includes: #isAbstract)! ! !ClassDescriptionTest methodsFor: 'tests' stamp: 'MarcusDenker 1/29/2014 16:23'! testClassDescriptionRespectsPolymorphismWithTraitDescription | repeatedMethodsThatDoNotAccessInstanceVariables differentMethodsWithSameSelector | "If the method is in ClassDescription and TraitDescription it must access some instance variable, otherwise the method can be implemented in TClassDescription" repeatedMethodsThatDoNotAccessInstanceVariables := self repeatedMethodsThatDoNotAccessInstanceVariablesBetween: ClassDescription and: TraitDescription. self assert: repeatedMethodsThatDoNotAccessInstanceVariables size = 0. "If the method is in ClassDescription and TraitDescription, and they have different implementations, it must be declared in TClassDescription as an explicitRequirement method" differentMethodsWithSameSelector := self differentMethodsWithSameSelectorBetween: ClassDescription and: TraitDescription. differentMethodsWithSameSelector do: [ :selector | (TClassDescription >> selector) sourceCode. self assert: (TClassDescription >> selector) isRequired ]. "Only a few methods are allowed to belong to one class and not to the other If you want to remove methods for this list, then go ahead. But is NOT good idea add methods to this list #superclass:layout, #initializeLayoutWithSlots: abd #layoutSized -> the access instance variables that are in ClassDescription but not in TraitDescription #layout is the getter of the instance variable layout (which is in ClassDescription but not in TraitDescription) #baseClass and #classClass have their equivalens in TraitDescription (baseTrait classTrait )" self assertCollection: (ClassDescription localSelectors difference: TraitDescription localSelectors) equals: #(#superclass:layout: #baseClass #superclass:withLayoutType:slots: #classClass #initializeLayoutWithSlots: #layoutSized: ) asSet. "#isClassTrait, #baseTrait, #isBaseTrait and #classTrait have their equivalents in ClassDescription but with different name, the problem comes from the name of the selector, they are not good names #copyTraitExpresion and #addExclusionOf: have no equivalent in classes" self assertCollection: (TraitDescription localSelectors difference: ClassDescription localSelectors) equals: #(#isClassTrait #addExclusionOf: #copyTraitExpression #baseTrait #- #isBaseTrait #classTrait syntacticallyEquals:) asSet! ! !ClassDescriptionTest methodsFor: 'tests' stamp: 'EstebanLorenzano 5/28/2013 13:22'! testOrganization | aClassOrganizer | aClassOrganizer := ClassDescription organization. self assert: (aClassOrganizer isKindOf: ClassOrganization).! ! !ClassDescriptionTest methodsFor: 'tests' stamp: 'Alexandre Bergel 4/27/2010 14:17'! testNumberOfMethods self assert: (Point numberOfMethods = (Point localMethods size + Point class localMethods size)). ! ! !ClassDescriptionTest methodsFor: 'tests' stamp: 'sd 5/10/2008 12:34'! testMethods self assert: Object methods = Object methodDict values. ! ! !ClassDiffBuilder commentStamp: 'HenrikSperreJohansen 5/21/2010 02:06'! I'm like TextDiffBuilder, but I split the input text by Character >> #separators, instead of new lines. I'm probably ment to create diffs of class definitions.! !ClassDiffBuilder methodsFor: 'private' stamp: 'HenrikSperreJohansen 5/21/2010 02:05'! print: aString withAttributes: attributes on: stream stream withAttributes: attributes do: [ stream nextPutAll: aString ]! ! !ClassDiffBuilder methodsFor: 'private' stamp: 'HenrikSperreJohansen 5/21/2010 02:04'! split: aString "I return an array with aString splitted by Character >> #separators." ^Array streamContents: [ :stream | | out | out := aString copy writeStream. aString do: [ :c | out nextPut: c. c isSeparator ifTrue:[ stream nextPut: out contents. out reset ] ]. out position = 0 ifFalse: [ stream nextPut: out contents ] ]! ! !ClassEyeElement commentStamp: ''! I am an eye element for the class of an inspected element.! !ClassEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 16:03'! value ^ self host class! ! !ClassEyeElement methodsFor: 'accessing' stamp: 'abc 10/18/2013 14:57'! accessorCode ^ 'self class'! ! !ClassEyeElement methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 16:02'! label ^ 'class'! ! !ClassEyeElement methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 3/14/2014 10:29'! shouldShowInTree ^ false! ! !ClassFactoryForTestCase commentStamp: 'LaurentLaffont 4/15/2011 20:20'! I'm useful when classes needs to be created during the execution of the test. This avoid polluting your unit tests with dummy and mock classes. A typical usage of it is: TestCase subclass: #YourTest instanceVariableNames: 'classFactory' YourTest>>setUp classFactory := ClassFactoryForTestCase new YourTest>>tearDown classFactory deleteClasses. YourTest>>testIsBehavior | cls | cls := classFactory newClass. self assert: cls isBehavior ! !ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 14:20'! cleanUpChangeSetForClassNames: classeNames | changeSet | changeSet := ChangeSet current. classeNames do: [:name| changeSet removeClassChanges: name; removeClassChanges: name, ' class']. ! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'SebastianTleye 8/9/2013 12:47'! newSubclassOf: aClass using: aTraitComposition ^self newSubclassOf: aClass uses: aTraitComposition instanceVariableNames: '' classVariableNames: '' category: self defaultCategoryPostfix.! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'SebastianTleye 8/9/2013 11:46'! newClassUsing: aTraitComposition ^self newSubclassOf: self defaultSuperclass uses: aTraitComposition instanceVariableNames: '' classVariableNames: '' category: self defaultCategoryPostfix.! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'ChristopheDemarey 11/28/2013 22:13'! withNotificationsNewClassWithInstanceVariableNames: instanceVariableNames ^ self newSubclassOf: Object instanceVariableNames: instanceVariableNames classVariableNames: '' category: self defaultCategoryPostfix! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'SebastianTleye 8/9/2013 11:14'! createdTraits ^createdTraits! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'ChristopheDemarey 11/28/2013 22:12'! newTraitInCategory: category ^ self newTraitNamed: self newTraitName uses: Array new category: category asSymbol.! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'SebastianTleye 8/9/2013 11:14'! createdTraitNames ^self createdTraits collect: [:trait | trait name]! ! !ClassFactoryForTestCase methodsFor: 'initialization' stamp: 'ChristopheDemarey 11/28/2013 22:14'! initialize super initialize. createdClasses := IdentitySet new. createdTraits := IdentitySet new. createdSilently := IdentitySet new.! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 16:37'! defaultCategory ^ (self packageName , '-', self defaultCategoryPostfix) asSymbol! ! !ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: 'ChristopheDemarey 11/29/2013 16:51'! silentlyNewClassInCategory: category ^ self silentlyNewSubclassOf: self defaultSuperclass instanceVariableNames: '' classVariableNames: '' category: category! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 16:20'! packageName ^#CategoryForTestToBeDeleted! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'ChristopheDemarey 11/28/2013 22:12'! newTrait ^ self newTraitNamed: self newTraitName uses: Array new category: self defaultCategoryPostfix! ! !ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 16:33'! deletePackage | categoriesMatchString | categoriesMatchString := self packageName, '-*'. SystemOrganization removeCategoriesMatching: categoriesMatchString! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'SebastianTleye 8/9/2013 11:42'! newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString ^self newSubclassOf: aClass uses: { } instanceVariableNames: ivNamesString classVariableNames: classVarsString category: self defaultCategoryPostfix! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'MarianoMartinezPeck 4/19/2012 19:06'! withNotificationsNewClass ^ self withNotificationsNewClassWithInstanceVariableNames: ''! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'SebastianTleye 8/9/2013 11:50'! newTraitName | postFix | postFix := (self createdTraits size + 1) printString. ^(#TraitForTestToBeDeleted, postFix) asSymbol! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'SebastianTleye 8/9/2013 11:42'! newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category ^self newSubclassOf: aClass uses: { } instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category.! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'NouryBouraqadi 12/18/2010 18:46'! defaultSuperclass ^Object! ! !ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'ChristopheDemarey 11/28/2013 22:09'! delete: aBehavior aBehavior isObsolete ifTrue: [ ^ self ]. aBehavior removeFromChanges. (createdSilently includes: aBehavior) ifTrue: [ aBehavior removeFromSystemUnlogged ] ifFalse: [ aBehavior removeFromSystem ].! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 14:21'! createdClassNames ^self createdClasses collect: [:class| class name]! ! !ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: 'ChristopheDemarey 11/29/2013 16:51'! silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString ^ self silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: self defaultCategoryPostfix! ! !ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: 'ChristopheDemarey 11/29/2013 16:53'! silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString package: packageName | newClass | SystemAnnouncer uniqueInstance suspendAllWhile: [ newClass := aClass subclass: self newClassName instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: '' category: packageName asSymbol. ]. self createdClasses add: newClass. createdSilently add: newClass. ^newClass ! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 13:59'! createdClasses ^createdClasses! ! !ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: 'ChristopheDemarey 11/29/2013 16:53'! silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category | newClass | SystemAnnouncer uniqueInstance suspendAllWhile: [ newClass := aClass subclass: self newClassName instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: '' category: (self packageName, '-', category) asSymbol. ]. self createdClasses add: newClass. createdSilently add: newClass. ^newClass ! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'ChristopheDemarey 11/28/2013 22:11'! newClassInCategory: category ^ self newSubclassOf: self defaultSuperclass instanceVariableNames: '' classVariableNames: '' category: category! ! !ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'SebastianTleye 8/9/2013 11:15'! deleteTraits self createdTraits do: [:trait| self delete: trait]! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'SebastianTleye 8/9/2013 13:47'! newTraitNamed: aTraitName uses: aTraitComposition category: aCategory | newTrait | newTrait := Trait named: aTraitName uses: aTraitComposition category: (self packageName, '-', aCategory) asSymbol.. self createdTraits add: newTrait. ^newTrait.! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'ChristopheDemarey 11/28/2013 22:11'! newClass ^ self newSubclassOf: self defaultSuperclass instanceVariableNames: '' classVariableNames: ''! ! !ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'SebastianTleye 8/9/2013 12:06'! cleanUp | createdClassNames createdTraitNames | createdClassNames := self createdClassNames. createdTraitNames := self createdTraitNames. self deleteClasses. self deleteTraits. self deletePackage. self cleanUpChangeSetForClassNames: createdClassNames. self cleanUpChangeSetForClassNames: createdTraitNames! ! !ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 12:46'! deleteClasses self createdClasses do: [:class| self delete: class]! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'SebastianTleye 8/9/2013 11:40'! newSubclassOf: aClass uses: aTraitComposition instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category | newClass | newClass := aClass subclass: self newClassName uses: aTraitComposition instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: '' category: (self packageName, '-', category) asSymbol. self createdClasses add: newClass. ^newClass! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'SebastianTleye 8/9/2013 11:03'! newClassName | postFix | postFix := (self createdClasses size + 1) printString. ^(#ClassForTestToBeDeleted, postFix) asSymbol! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'SebastianTleye 8/9/2013 11:48'! newTraitUsing: aTraitComposition. ^self newTraitNamed: self newTraitName uses: aTraitComposition category: self defaultCategoryPostfix.! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 16:23'! defaultCategoryPostfix ^ #Default! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'JenkinsCI 11/27/2013 08:48'! duplicateClass: aClass withNewName: name | newClass | newClass := aClass duplicateClassWithNewName: name. self createdClasses add: newClass. ^newClass ! ! !ClassFactoryForTestCaseTest commentStamp: 'TorstenBergmann 2/12/2014 23:17'! SUnit tests for ClassFactoryForTestCase ! !ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'nice 12/3/2009 23:47'! testSingleClassCreation |class elementsInCategoryForTest | class := factory newSubclassOf: Object instanceVariableNames: 'a b c' classVariableNames: 'X Y'. self assert: (SystemNavigation new allClasses includes: class). elementsInCategoryForTest := SystemOrganization listAtCategoryNamed: factory defaultCategory. self assert: elementsInCategoryForTest = {class name}. self assert: class instVarNames = #(a b c). self assert: class classPool keys asSet = #(X Y) asSet! ! !ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'SebastianTleye 8/9/2013 13:49'! testDefaultCategoryCleanUp | createdClassNames createdTraitNames allClasses allTraits | 3 timesRepeat: [ factory newClass. factory newTrait]. createdClassNames := factory createdClassNames. createdTraitNames := factory createdTraitNames. factory cleanUp. self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). self assert: (factory createdTraits allSatisfy: [:trait| trait isObsolete]). allClasses := SystemNavigation new allClasses. allTraits := Smalltalk globals allTraits. self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]). self assert: (factory createdTraits noneSatisfy: [:trait| allTraits includes: trait]). self deny: (SystemOrganization categories includes: factory defaultCategory). self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames) ! ! !ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:37'! testSingleClassFastCreation |class elementsInCategoryForTest | class := factory newClass. self assert: (SystemNavigation new allClasses includes: class). elementsInCategoryForTest := SystemOrganization listAtCategoryNamed: factory defaultCategory. self assert: elementsInCategoryForTest = {class name}. self assert: class instVarNames isEmpty. self assert: class classPool isEmpty! ! !ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:38'! testMultipleClassCreation 5 timesRepeat: [ factory newClass]. self assert: (SystemNavigation new allClasses includesAllOf: factory createdClasses). self assert: factory createdClassNames asSet size = 5. self assert: (SystemOrganization listAtCategoryNamed: factory defaultCategory) asSet = factory createdClassNames asSet! ! !ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'SebastianTleye 8/9/2013 13:43'! testTraitCreationInDifferentCategories | firstThreeTraits lastTwoTraits | 3 timesRepeat: [ factory newTraitInCategory: #One]. firstThreeTraits := factory createdTraits copy. 2 timesRepeat: [ factory newTraitInCategory: #Two]. lastTwoTraits := factory createdTraits copyWithoutAll: firstThreeTraits. self assert: (firstThreeTraits allSatisfy: [:trait| trait category = (factory packageName, '-', #One) asSymbol]). self assert: (lastTwoTraits allSatisfy: [:trait| trait category = (factory packageName, '-', #Two) asSymbol]).! ! !ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:43'! testClassCreationInDifferentCategories | firstThreeClasses lastTwoClasses | 3 timesRepeat: [ factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #One]. firstThreeClasses := factory createdClasses copy. 2 timesRepeat: [ factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #Two]. lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses. self assert: (firstThreeClasses allSatisfy: [:class| class category = (factory packageName, '-', #One) asSymbol]). self assert: (lastTwoClasses allSatisfy: [:class| class category = (factory packageName, '-', #Two) asSymbol]).! ! !ClassFactoryForTestCaseTest methodsFor: 'setUp-tearDown' stamp: 'Noury 10/26/2008 14:53'! tearDown super tearDown. factory cleanUp! ! !ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:47'! testPackageCleanUp | createdClassNames allClasses | 3 timesRepeat: [ factory newClassInCategory: #One]. 2 timesRepeat: [ factory newClassInCategory: #Two]. createdClassNames := factory createdClassNames. factory cleanUp. self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). allClasses := SystemNavigation new allClasses. self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]). self assert: (SystemOrganization categoriesMatching: factory packageName, '*') isEmpty. self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames) ! ! !ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'ChristopheDemarey 11/28/2013 22:04'! testDuplicateClassWithNewName | createdClass | createdClass := factory duplicateClass: TestCase withNewName: #MyTestClass. self assert: (factory createdClasses allSatisfy: [:class| self class environment includesKey: class name ]). factory cleanUp. self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). self deny: (ChangeSet current changedClassNames includes: createdClass).! ! !ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'SebastianTleye 8/9/2013 13:37'! testSingleTraitCreation |trait | trait := factory newTrait. self assert: (Smalltalk globals allTraits includes: trait). self assert: trait users size = 0. self assert: trait traits size = 0.! ! !ClassFactoryForTestCaseTest methodsFor: 'testing' stamp: 'Noury 10/26/2008 16:42'! testClassFastCreationInDifferentCategories | firstThreeClasses lastTwoClasses | 3 timesRepeat: [ factory newClassInCategory: #One]. firstThreeClasses := factory createdClasses copy. 2 timesRepeat: [ factory newClassInCategory: #Two]. lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses. self assert: (firstThreeClasses allSatisfy: [:class| class category = (factory packageName, '-', #One) asSymbol]). self assert: (lastTwoClasses allSatisfy: [:class| class category = (factory packageName, '-', #Two) asSymbol]).! ! !ClassFactoryForTestCaseTest methodsFor: 'setUp-tearDown' stamp: 'Noury 10/26/2008 12:19'! setUp super setUp. factory := ClassFactoryForTestCase new! ! !ClassFactoryForTestCaseTest class methodsFor: 'history' stamp: 'simon.denier 11/22/2008 22:13'! lastStoredRun ^ ((Dictionary new) add: (#passed->((Set new) add: #testDefaultCategoryCleanUp; add: #testPackageCleanUp; add: #testSingleClassCreation; add: #testClassCreationInDifferentCategories; add: #testClassFastCreationInDifferentCategories; add: #testMultipleClassCreation; add: #testSingleClassFastCreation; yourself)); add: (#timeStamp->'22 November 2008 10:11:35 pm'); add: (#failures->((Set new))); add: (#errors->((Set new))); yourself)! ! !ClassFactoryWithOrganization commentStamp: 'LaurentLaffont 5/4/2011 21:25'! I'm a class to create classes with a category. I'm only used by Tests. I am similar to ClassFactoryForTestCase (i.e., I can be used in place of a ClassFactoryForTestCase), expect that classes may be created on a specific class category.! !ClassFactoryWithOrganization methodsFor: 'creating' stamp: 'LucFabresse 10/29/2010 08:04'! newClassNamed: aString subclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString ^self newClassNamed: aString subclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: (self packageName, '-', self defaultCategoryPostfix) asSymbol.! ! !ClassFactoryWithOrganization methodsFor: 'accessing' stamp: 'LucFabresse 10/24/2010 20:31'! organization: aSystemOrganizer organization := aSystemOrganizer! ! !ClassFactoryWithOrganization methodsFor: 'creating' stamp: 'MartinDias 6/24/2013 15:26'! newClassNamed: aString subclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category | newClass | newClass := self class classBuilder name: aString inEnvironment: self organization environment subclassOf: aClass type: aClass typeOfClass instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: '' category: category asSymbol. self createdClasses add: newClass. ^newClass! ! !ClassFactoryWithOrganization methodsFor: 'cleaning' stamp: 'LucFabresse 10/24/2010 22:01'! deletePackage | categoriesMatchString | categoriesMatchString := self packageName, '-*'. self organization removeCategoriesMatching: categoriesMatchString ; removeEmptyCategories ! ! !ClassFactoryWithOrganization methodsFor: 'creating' stamp: 'LucFabresse 10/24/2010 21:41'! newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString ^self newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: (self packageName, '-', self defaultCategoryPostfix) asSymbol.! ! !ClassFactoryWithOrganization methodsFor: 'accessing' stamp: 'LucFabresse 10/24/2010 20:31'! organization ^organization! ! !ClassFactoryWithOrganization methodsFor: 'creating' stamp: 'SebastianTleye 8/9/2013 11:04'! newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category | newClass | newClass := self class classBuilder name: self newClassName inEnvironment: self organization environment subclassOf: aClass type: aClass typeOfClass instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: '' category: category asSymbol. self createdClasses add: newClass. ^newClass! ! !ClassFactoryWithOrganization class methodsFor: 'instance creation' stamp: 'LucFabresse 10/24/2010 20:33'! newWithOrganization: aSystemOrganizer ^self new organization: aSystemOrganizer; yourself! ! !ClassFactoryWithOrganizationTest commentStamp: 'TorstenBergmann 2/12/2014 23:16'! SUnit tests for ClassFactoryWithOrganization! !ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: 'LucFabresse 10/24/2010 19:48'! assertEnvironmentOf: aBehavior self assert: aBehavior environment = self testedEnvironment! ! !ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: 'LucFabresse 10/24/2010 19:41'! testDefaultCategoryCleanUp | createdClassNames allClasses | 3 timesRepeat: [ factory newClass]. createdClassNames := factory createdClassNames. factory cleanUp. self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). allClasses := self testedEnvironment allClasses. self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]). self deny: (self testedOrganization categories includes: factory defaultCategory). self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames) ! ! !ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: 'LucFabresse 10/24/2010 19:51'! testSingleClassCreation |class elementsInCategoryForTest | class := factory newSubclassOf: Object instanceVariableNames: 'a b c' classVariableNames: 'X Y'. self assert: (self testedEnvironment allClasses includes: class). factory createdClasses do: [ :aClass | self assertEnvironmentOf: aClass ]. elementsInCategoryForTest := self testedOrganization listAtCategoryNamed: factory defaultCategory. self assert: elementsInCategoryForTest = {class name}. self assert: class instVarNames = #(a b c). self assert: class classPool keys asSet = #(X Y) asSet! ! !ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: 'LucFabresse 10/24/2010 19:51'! testSingleClassFastCreation |class elementsInCategoryForTest | class := factory newClass. self assert: (self testedEnvironment allClasses includes: class). elementsInCategoryForTest := self testedOrganization listAtCategoryNamed: factory defaultCategory. factory createdClasses do: [ :aClass | self assertEnvironmentOf: aClass ]. self assert: elementsInCategoryForTest = {class name}. self assert: class instVarNames isEmpty. self assert: class classPool isEmpty! ! !ClassFactoryWithOrganizationTest methodsFor: 'accessing' stamp: 'LucFabresse 10/24/2010 20:31'! testedOrganization ^factory organization! ! !ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: 'LucFabresse 10/29/2010 09:09'! testClassCreationInDifferentCategories | firstThreeClasses lastTwoClasses | 3 timesRepeat: [ factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #One]. firstThreeClasses := factory createdClasses copy. 2 timesRepeat: [ factory newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' category: #Two]. lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses. self assert: (firstThreeClasses allSatisfy: [:class| class category = #One]). self assert: (lastTwoClasses allSatisfy: [:class| class category = #Two]). factory createdClasses do: [ :aClass | self assertEnvironmentOf: aClass ]! ! !ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: 'LucFabresse 10/24/2010 19:50'! testMultipleClassCreation 5 timesRepeat: [ factory newClass]. self assert: (self testedEnvironment allClasses includesAllOf: factory createdClasses). self assert: factory createdClassNames asSet size = 5. self assert: (self testedOrganization listAtCategoryNamed: factory defaultCategory) asSet = factory createdClassNames asSet. factory createdClasses do: [ :aClass | self assertEnvironmentOf: aClass ]! ! !ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: 'LucFabresse 10/24/2010 19:50'! testPackageCleanUp | createdClassNames allClasses | 3 timesRepeat: [ factory newClassInCategory: #One]. 2 timesRepeat: [ factory newClassInCategory: #Two]. createdClassNames := factory createdClassNames. factory cleanUp. self assert: (factory createdClasses allSatisfy: [:class| class isObsolete]). allClasses := self testedEnvironment allClasses. self assert: (factory createdClasses noneSatisfy: [:class| allClasses includes: class]). self assert: (self testedOrganization categoriesMatching: factory packageName, '*') isEmpty. self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames). ! ! !ClassFactoryWithOrganizationTest methodsFor: 'testing' stamp: 'LucFabresse 10/29/2010 09:14'! testClassFastCreationInDifferentCategories | firstThreeClasses lastTwoClasses | 3 timesRepeat: [ factory newClassInCategory: #One]. firstThreeClasses := factory createdClasses copy. 2 timesRepeat: [ factory newClassInCategory: #Two]. lastTwoClasses := factory createdClasses copyWithoutAll: firstThreeClasses. self assert: (firstThreeClasses allSatisfy: [:class| class category = #One]). self assert: (lastTwoClasses allSatisfy: [:class| class category = #Two]). factory createdClasses do: [ :aClass | self assertEnvironmentOf: aClass ]! ! !ClassFactoryWithOrganizationTest methodsFor: 'setUp-tearDown' stamp: 'LucFabresse 12/19/2010 12:42'! setUp | environment | super setUp. environment := SystemDictionary withOrganizer: SystemOrganizer new. factory := ClassFactoryWithOrganization newWithOrganization: environment organization. ! ! !ClassFactoryWithOrganizationTest methodsFor: 'accessing' stamp: 'LucFabresse 10/24/2010 19:57'! testedEnvironment ^self testedOrganization environment! ! !ClassHierarchyTest commentStamp: 'TorstenBergmann 2/5/2014 08:31'! SUnit tests for the class hierarchy! !ClassHierarchyTest methodsFor: 'tests' stamp: 'MarcusDenker 7/12/2012 18:00'! testSubclassInstVar | subclasses | SystemNavigation new allClassesDo: [ :cls| subclasses := cls subclasses. self assert: subclasses isNil not. subclasses do: [:subclass| self assert: (subclasses occurrencesOf: subclass) = 1. self assert: subclass superclass == cls. "cls removeSubclass: subclass. cls addSubclass: subclass."]]! ! !ClassHierarchyTest methodsFor: 'tests' stamp: 'CamilloBruni 1/30/2013 15:48'! testSubclasses " self class fixSubclasses " | subclasses | SystemNavigation new allClassesDo: [ :cls| self assert: (cls superclass subclasses includes: cls) description: cls name, ' is not in ', cls superclass name, '''s subclasses' ]! ! !ClassHierarchyTest class methodsFor: 'fixing' stamp: 'MarcusDenker 4/14/2014 16:15'! fixSubclasses "Fix all the missing subclasses" "ClassHierarchyTest fixSubclasses " SystemNavigation new allClassesDo: [ :cls| (cls superclass subclasses includes: cls) ifFalse: [ cls superclass addSubclass: cls ]]! ! !ClassHierarchyTest class methodsFor: 'fixing' stamp: 'MarcusDenker 4/24/2014 15:41'! fixSlotScope "postscript for issue 11596" | ivName all candidates toRebuild | ivName := 'anIVNameImPrettySureNobodyUses'. all := Smalltalk allClasses flatCollect: [ :e | { e . e class } ]. candidates := all reject: [ :e | e superclass isNil or: [e layout slotScope isKindOf: LayoutEmptyScope ] ]. toRebuild := candidates reject: [ :e | e superclass layout slotScope == e layout slotScope parentScope ]. toRebuild do: [ :e | e addInstVarNamed: ivName ]. toRebuild do: [ :e | (e isClassSide ifTrue: [ (Smalltalk at: e instanceSide name) classSide ] ifFalse: [ Smalltalk at: e name ]) removeInstVarNamed: ivName ]! ! !ClassListExample commentStamp: 'AlainPlantec 1/22/2010 15:10'! ClassListExample new openOn: Object ! !ClassListExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/7/2010 22:44'! rootNodeClassFromItem: anItem ^ClassListNodeExample! ! !ClassListExample methodsFor: 'user interface' stamp: 'EstebanLorenzano 5/14/2013 09:44'! treeMorph | treeMorph baseColor oddColor evenColor | baseColor := Color lightBlue lighter. oddColor := (GradientFillStyle ramp: { 0.0->baseColor whiter. 0.2->baseColor. 0.8->baseColor darker. 1.0->baseColor blacker}) radial: false. baseColor := Color veryLightGray muchLighter. evenColor := (GradientFillStyle ramp: { 0.0->baseColor lighter lighter. 0.2->baseColor lighter. 0.8->baseColor. 1.0->baseColor blacker}) radial: false. treeMorph := self treeMorphClass new model: self; beMultiple; columns: {MorphTreeColumn new startWidth: 100; rowMorphGetSelector: #classButton; headerButtonLabel: 'Class' font: nil icon: Smalltalk ui icons smallOpenIcon target: nil actionSelector: nil arguments: #(). MorphTreeColumn new rowMorphGetSelector: #commentText; headerButtonLabel: 'Comments' font: nil icon: Smalltalk ui icons smallPrintIcon target: nil actionSelector: nil arguments: #()}; makeLastColumnUnbounded; withHLines: true; allowColumnDrop; useSquareCorners; hResizing: #spaceFill; vResizing: #spaceFill; rowInset: 5; columnInset: 5; resizerWidth: 2; preferedPaneColor: Color white; getMenuSelector: #menu:shifted:; columnColorForEven: evenColor odd: oddColor. ^ treeMorph buildContents! ! !ClassListExample methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/19/2012 16:12'! openOn: aClass | window | self rootClass: aClass. window := StandardWindow new model: self. window title: aClass name, ' hierarchy'. window addMorph: self treeMorph fullFrame: LayoutFrame identity. window themeChanged. window openInWorld. ^ window! ! !ClassListExample methodsFor: 'instance creation' stamp: 'AlainPlantec 1/16/2010 09:50'! open ^ self openOn: Object ! ! !ClassListExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/25/2011 17:03'! keyStroke: anEvent from: aTreeMorph self selectedNode ifNotNil: [:current | current keyStroke: anEvent from: aTreeMorph]! ! !ClassListExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:50'! rootClass: aClass rootClass := aClass! ! !ClassListExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:50'! rootClass ^ rootClass ifNil: [rootClass := Object]! ! !ClassListExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/15/2010 13:56'! rootItems ^ self rootClass allSubclasses asArray sort: [:a :b | a name < b name ]! ! !ClassListExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/18/2010 16:43'! menu: menu shifted: b "Set up the menu to apply to the receiver's, honoring the #shifted boolean" super menu: menu shifted: b. menu addLine. self selectedNode ifNotNil: [:current | current menu: menu shifted: b]. ^ menu! ! !ClassListNodeExample commentStamp: 'TorstenBergmann 2/3/2014 23:56'! Example for a class list node! !ClassListNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:50'! menu: menu shifted: b menu add: 'Browse (b)' translated target: self selector: #browseItem. menu add: 'Inspect (i)' translated target: self selector: #inspectItem. menu add: 'Explore (I)' translated target: self selector: #exploreItem. ! ! !ClassListNodeExample methodsFor: 'menu' stamp: 'FernandoOlivero 4/12/2011 09:41'! commentText ^ ( self theme newTextIn: World text: self item comment) unlock; wrapFlag: true; yourself! ! !ClassListNodeExample methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2011 20:53'! browseItem Smalltalk tools browser fullOnClass: self item selector: nil ! ! !ClassListNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:50'! inspectItem self inspect! ! !ClassListNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/25/2011 17:04'! keyStroke: anEvent from: aTreeMorph | c | c := anEvent keyCharacter. c = $b ifTrue: [self browseItem. ^ true]. c = $i ifTrue: [self inspectItem. ^ true]. c = $I ifTrue: [self exploreItem. ^ true]. ^ false ! ! !ClassListNodeExample methodsFor: 'menu' stamp: 'FernandoOlivero 4/12/2011 10:10'! classButton ^ ( self theme newButtonIn: World for: self getState: nil action: #browseItem arguments: {} getEnabled: #enabled getLabel: nil help: 'Open a browser on ' translated , self item name) label: (self theme windowLabelForText: (self item name) , '...'); yourself! ! !ClassListNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:50'! exploreItem self explore! ! !ClassListNodeExample methodsFor: 'menu' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon ^ Smalltalk ui icons smallExpertIcon! ! !ClassMethodBrowser commentStamp: ''! A ClassMethodBrowser is a simple browser using spec and reusing MethodBrowser to browse classes>>methods>>sourceCode. | cb | cb := ClassMethodBrowser new. cb openWithSpec. cb classes: Smalltalk allClasses.! !ClassMethodBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/14/2011 18:03'! methodModel ^ methodModel! ! !ClassMethodBrowser methodsFor: 'initialization' stamp: 'CamilloBruni 9/22/2013 21:28'! initializeWidgets listModel := self newList. methodModel := self instantiate: MethodBrowser. self focusOrder add: listModel; add: methodModel. methodModel displayBlock: [:method | method selector ].! ! !ClassMethodBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/14/2011 18:03'! listModel ^ listModel! ! !ClassMethodBrowser methodsFor: 'initialization' stamp: 'MarcusDenker 5/4/2013 10:15'! initializePresenter listModel whenSelectedItemChanged: [:selection | selection ifNotNil: [:class | methodModel methods: (class methods sort: [:a :b | a selector < b selector]). methodModel listModel resetSelection ]].! ! !ClassMethodBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/22/2012 19:16'! classes: aList self listModel items: aList! ! !ClassMethodBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 6/22/2012 19:19'! defaultSpec ^ SpecLayout composed newRow: [:row | row add: #listModel; add: #methodModel ]; yourself! ! !ClassMethodBrowser class methodsFor: 'example' stamp: 'BenjaminVanRyseghem 2/2/2012 13:39'! example "self example" | cb | cb := ClassMethodBrowser new. cb openWithSpec. cb classes: Smalltalk allClasses.! ! !ClassMethodBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 12/14/2011 18:12'! title ^ 'Class Method Browser'! ! !ClassMethodBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 4/3/2013 17:32'! defaultSpec2 ^ SpecLayout composed newRow: [:r | r newColumn: #listModel right: 0.5; addVSplitter; newColumn: #(methodModel listModel) left: 0.5 ] bottom: 0.5; addHSplitter; newRow: #(methodModel textModel) top: 0.5; yourself! ! !ClassModification commentStamp: ''! I represent a modification in a class. ! !ClassModification methodsFor: 'testing' stamp: 'MartinDias 2/7/2014 16:43'! modifiesSuperclass ^ (target superclass == superclass) not! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/20/2011 15:49'! changes ^ changes! ! !ClassModification methodsFor: 'testing' stamp: 'MartinDias 4/28/2014 18:17'! modifiesSharedVariables "Note: The meta class has the same shared variables as it's non-meta class" ^ target isInstanceSide and: [ (target classVariablesString = sharedVariables) not ] ! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/20/2011 14:30'! removals: aCollection removals := aCollection! ! !ClassModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 20:02'! installSlotRemoval: slot on: aModification 0 to: slot size - 1 do: [ :idx | (RemovedField new originalSlot: slot; fieldIndex: idx) installOn: aModification ]! ! !ClassModification methodsFor: 'testing' stamp: 'MartinDias 2/7/2014 17:16'! modifiesSharedPools ^ (target sharedPoolsString = sharedPools) not! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 4/2/2011 20:54'! traitComposition: aTraitComposition " We copy the trait composition since we might want " " to update the slot indices if the composition is partly stateful " traitComposition := aTraitComposition copyTraitExpression! ! !ClassModification methodsFor: 'initialization' stamp: 'ToonVerwaest 4/1/2011 03:31'! initialize super initialize. changes := IdentityDictionary new. copies := IdentityDictionary new. removals := {}. additions := {}.! ! !ClassModification methodsFor: 'accessing' stamp: 'MartinDias 2/7/2014 16:30'! sharedPools: anObject sharedPools := anObject! ! !ClassModification methodsFor: 'accessing' stamp: 'MartinDias 6/24/2013 16:54'! superLayout ^ superclass ifNil: [ EmptyLayout instance ] ifNotNil: [ superclass layout ]! ! !ClassModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/30/2011 13:41'! installSlotCopiedFrom: oldSlot to: newSlot on: aModification 0 to: newSlot size - 1 do: [ :idx | (UnmodifiedField new slot: newSlot; fieldIndex: idx) installOn: aModification ]! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 17:45'! copies ^ copies! ! !ClassModification methodsFor: 'accessing' stamp: 'MartinDias 2/7/2014 16:30'! sharedVariables: anObject sharedVariables := anObject! ! !ClassModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 20:02'! installSlotChangeFrom: oldSlot to: newSlot on: aModification 0 to: newSlot size - 1 do: [ :idx | (ModifiedField new newSlot: newSlot; originalSlot: oldSlot; fieldIndex: idx) installOn: aModification ]! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/31/2011 19:48'! traitComposition ^ traitComposition! ! !ClassModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 20:02'! installSlotAddition: slot on: aModification 0 to: slot size - 1 do: [ :idx | (AddedField new newSlot: slot; fieldIndex: idx) installOn: aModification ]! ! !ClassModification methodsFor: 'testing' stamp: 'MartinDias 2/7/2014 16:44'! isPropagation ^ false! ! !ClassModification methodsFor: 'private' stamp: 'ToonVerwaest 4/3/2011 11:21'! computeChange super computeChange. layout computeChangesFrom: target layout in: self. slotShift := layout fieldSize - target layout fieldSize. self propagate.! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/20/2011 23:32'! slotShift ^ slotShift! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 02:27'! methodModification ^ methodModification ifNil: [ methodModification := MethodModification new: target layout fieldSize. self buildModificationMapFor: methodModification ]! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/20/2011 14:30'! additions: aCollection additions := aCollection! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 03:03'! originalScope ^ target layout slotScope! ! !ClassModification methodsFor: 'testing' stamp: 'MartinDias 2/7/2014 16:43'! modifiesSlots ^ (changes isEmpty and: [ removals isEmpty and: [ additions isEmpty ]]) not! ! !ClassModification methodsFor: 'accessing' stamp: 'MartinDias 2/7/2014 16:30'! sharedVariables ^ sharedVariables! ! !ClassModification methodsFor: 'accessing' stamp: 'MartinDias 8/7/2013 18:06'! layoutClass: layoutClass slots: slotArray compactClassIndex: compactClassIndex | parentLayout newScope newLayout | parentLayout := self superLayout. newScope := parentLayout slotScope extend: slotArray. newLayout := layoutClass extending: parentLayout scope: newScope host: self target. newLayout compactClassIndex: compactClassIndex. self layout: newLayout! ! !ClassModification methodsFor: 'testing' stamp: 'MartinDias 2/7/2014 16:44'! modifiesFormat ^ (layout format = target layout format) not! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/20/2011 19:34'! superclass ^ superclass! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/20/2011 14:32'! superclass: aClass superclass := aClass! ! !ClassModification methodsFor: 'private' stamp: 'CamilloBruni 3/29/2011 19:00'! buildModificationMapFor: aModification aModification slotShift: (ShiftedField new shift: slotShift). aModification size = 0 ifTrue: [ ^ aModification ]. additions do: [ :slot | self installSlotAddition: slot on: aModification]. changes keysAndValuesDo: [ :newSlot :oldSlot | self installSlotChangeFrom: oldSlot to: newSlot on: aModification ]. removals do: [ :slot | self installSlotRemoval: slot on: aModification]. copies keysAndValuesDo: [ :newSlot :oldSlot | self installSlotCopiedFrom: oldSlot to: newSlot on: aModification ]. ^ aModification! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/20/2011 15:25'! subclassSlotOffset ^ subclassSlotOffset! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 03:04'! newScope ^ layout slotScope! ! !ClassModification methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 02:45'! instanceModification | map | map := InstanceModification new: layout fieldSize. ^ self buildModificationMapFor: map! ! !ClassModification methodsFor: 'accessing' stamp: 'MartinDias 2/7/2014 16:30'! sharedPools ^ sharedPools! ! !ClassModification class methodsFor: 'instance creation' stamp: 'MartinDias 2/7/2014 16:29'! modify: aClass extend: aSuperclass withLayoutType: layoutClass slots: someSlots sharedVariables: someSharedVariables sharedPools: someSharedPools traitComposition: aTraitComposition compactClassIndex: compactClassIndex ^ self new target: aClass; superclass: aSuperclass; traitComposition: aTraitComposition; sharedVariables: someSharedVariables; sharedPools: someSharedPools; layoutClass: layoutClass slots: someSlots compactClassIndex: compactClassIndex; yourself! ! !ClassModificationPropagation commentStamp: 'MartinDias 1/28/2014 16:22'! I represent a modification in a class that is produced because of a change in one of its superclasses. This is called a propagation.! !ClassModificationPropagation methodsFor: 'testing' stamp: 'MartinDias 1/28/2014 16:22'! isPropagation ^true! ! !ClassModificationPropagation methodsFor: 'migrating' stamp: 'ToonVerwaest 3/27/2011 21:14'! methodModification ^ origin methodModification! ! !ClassModificationPropagation methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 17:50'! superclass ^ origin newClass! ! !ClassModificationPropagation methodsFor: 'public' stamp: 'CamilloBruni 7/17/2013 13:46'! propagate: aModification to: aTarget origin := aModification. target := aTarget. self layout: (target layout reshapeFrom: origin oldLayout slotScope to: origin newLayout).! ! !ClassModificationPropagation class methodsFor: 'instance creation' stamp: 'ToonVerwaest 3/20/2011 14:51'! propagate: aModification to: aClass ^ self new propagate: aModification to: aClass! ! !ClassModifiedClassDefinition commentStamp: 'MartinDias 1/31/2014 16:31'! This announcement will be emitted when a class or a trait definition changes. For example, when an instance variable is added or when the trait composition is modified in a class definition.! !ClassModifiedClassDefinition methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:10'! oldClassDefinition ^oldClassDefinition! ! !ClassModifiedClassDefinition methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:10'! newClassDefinition ^newClassDefinition! ! !ClassModifiedClassDefinition methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 13:51'! classAffected ^self newClassDefinition! ! !ClassModifiedClassDefinition methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:10'! oldClassDefinition: aClass oldClassDefinition := aClass! ! !ClassModifiedClassDefinition methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:09'! newClassDefinition: aClass newClassDefinition := aClass! ! !ClassModifiedClassDefinition class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:09'! classDefinitionChangedFrom: oldClass to: newClass ^self new oldClassDefinition: oldClass; newClassDefinition: newClass; yourself! ! !ClassMultiplePoolUser commentStamp: 'StephaneDucasse 12/13/2011 15:59'! I'm a class using two shared pools. ! !ClassMultiplePoolUser class methodsFor: 'accessing' stamp: 'StephaneDucasse 12/13/2011 15:59'! author ^ Author! ! !ClassMultiplePoolUser class methodsFor: 'accessing' stamp: 'StephaneDucasse 12/13/2011 16:00'! variableInPoolDefiner2 ^ VariableInPoolDefiner2! ! !ClassMultiplePoolUser class methodsFor: 'accessing' stamp: 'StephaneDucasse 12/13/2011 15:59'! gloups ^ Gloups! ! !ClassOrMethodDefinitionAcceptor commentStamp: ''! I am an acceptor in the "weird" context when the text entered could be a class definition or a method definition.! !ClassOrMethodDefinitionAcceptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/9/2013 09:24'! acceptInstanceSide: source notifying: aController | isClassDefinition | isClassDefinition := false. "Try to parse the source. If it succeed, it means the source represents a message send aka a class definition. On error, we switch to method definition mode" [ RBParser parseMethod: source ] on: Error do: [ isClassDefinition := true ]. isClassDefinition ifTrue: [ self model compileAClassFrom: source notifying: aController ] ifFalse: [ self model compileAMethodFromCategory: Protocol unclassified withSource: source notifying: aController ]! ! !ClassOrMethodDefinitionAcceptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/9/2013 09:27'! accept: source notifying: aController self model selectedClass isMeta ifTrue: [ self acceptClassSide: source notifying: aController ] ifFalse: [ self acceptInstanceSide: source notifying: aController ]! ! !ClassOrMethodDefinitionAcceptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/9/2013 09:29'! acceptClassSide: source notifying: aController | isClassDefinition | isClassDefinition := (' ' split: source) first = self model selectedClass theNonMetaClass name. isClassDefinition ifTrue: [ self model compileAClassFrom: source notifying: aController ] ifFalse: [ self model compileAMethodFromCategory: Protocol unclassified withSource: source notifying: aController ]! ! !ClassOrganization commentStamp: ''! This object is in charge of system notifications. It manages the class comment, the class comment stamp and a protocol organizer! !ClassOrganization methodsFor: 'accessing' stamp: 'MarcusDenker 10/5/2013 21:19'! comment: aString "Store the comment, aString, associated with the object that refers to the receiver." comment := (aString isKindOf: RemoteString) ifTrue: [ aString ] ifFalse: [ aString isEmptyOrNil ifTrue: [ nil ] ifFalse: [ RemoteString newString: aString onFileNumber: 2 ] ] "Later add priorSource and date and initials?"! ! !ClassOrganization methodsFor: 'notifications' stamp: 'MarcusDenker 9/18/2012 13:50'! notifyOfChangedCategoryFrom: oldNameOrNil to: newNameOrNil (self hasSubject and: [oldNameOrNil ~= newNameOrNil]) ifTrue: [SystemAnnouncer uniqueInstance classReorganized: self subject].! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 16:15'! hasSubject ^ organizedClass notNil! ! !ClassOrganization methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/11/2014 23:09'! removeCategory: protocolName (self protocolOrganizer hasProtocolNamed: protocolName) ifFalse: [ ^ self ]. self removeProtocol: (self protocolNamed: protocolName)! ! !ClassOrganization methodsFor: 'initialization' stamp: 'EstebanLorenzano 5/28/2013 16:35'! initializeClass: aClass self initialize. organizedClass := aClass. organizedClass selectors do: [ :each | self classify: each under: Protocol unclassified ]! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'EstebanLorenzano 6/21/2013 14:42'! sortCategories "Do nothing"! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 16:18'! subject ^organizedClass! ! !ClassOrganization methodsFor: 'backward compatibility - file in/out' stamp: 'MarcusDenker 5/18/2013 15:44'! changeFromString: aString "Parse the argument, aString, and make this be the receiver's structure." | categorySpecs | categorySpecs := aString parseLiterals. "If nothing was scanned and I had no elements before, then default me" (categorySpecs isEmpty and: [ self protocolOrganizer isEmpty ]) ifTrue: [ ^ self protocolOrganizer reset ]. ^ self changeFromCategorySpecs: categorySpecs! ! !ClassOrganization methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 18:39'! comment comment ifNil: [^ '']. ^ comment string ifNil: ['']! ! !ClassOrganization methodsFor: 'initialization' stamp: 'EstebanLorenzano 5/28/2013 16:34'! initialize super initialize. protocolOrganizer := ProtocolOrganizer new.! ! !ClassOrganization methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 16:45'! categoriesSorted ^ self protocolOrganizer protocolsSorted! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 18:36'! classComment: aString stamp: aStamp self comment: aString; commentStamp: aStamp! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 15:51'! classify: aSymbol under: aProtocolName ^ self classify: aSymbol under: aProtocolName suppressIfDefault: true! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/24/2012 14:18'! listAtCategoryNumber: aSmallInteger ^ (protocolOrganizer allProtocols at: aSmallInteger ifAbsent: [ ^ {} ]) methods asArray! ! !ClassOrganization methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/27/2013 18:01'! realCategories ^ self protocolOrganizer protocolsNames ! ! !ClassOrganization methodsFor: 'backward compatibility - file in/out' stamp: 'CamilloBruni 6/29/2013 20:27'! putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass "Store the comment about the class onto file, aFileStream." | header | self classComment ifNil: [ ^ self ]. aFileStream cr; nextPut: $!!. header := String streamContents: [:strm | strm nextPutAll: aClass name; nextPutAll: ' commentStamp: '. commentStamp ifNil: [commentStamp := '']. commentStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: '0']. aFileStream nextChunkPut: header. aClass organization fileOutCommentOn: aFileStream moveSource: moveSource toFile: sourceIndex. aFileStream cr! ! !ClassOrganization methodsFor: 'notifications' stamp: 'EstebanLorenzano 6/26/2013 16:59'! notifyOfAddedCategory: protocolName self hasSubject ifFalse: [ ^ self ]. SystemAnnouncer uniqueInstance protocolAdded: protocolName inClass: self subject! ! !ClassOrganization methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 16:21'! protocols ^ self protocolOrganizer protocols.! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 16:15'! setSubject: anObject organizedClass := anObject! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'EstebanLorenzano 11/29/2013 16:09'! renameCategory: oldName toBe: newName self silentlyRenameCategory: oldName toBe: newName. self notifyOfChangedCategoryFrom: oldName to: newName. "I need to notify also the selector changes, otherwise RPackage will not notice" (self protocolOrganizer protocolNamed: newName) methods do: [ :each | self notifyOfChangedSelector: each from: oldName to: newName ]! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'MarcusDenker 10/5/2013 21:20'! classify: selector under: aProtocolName suppressIfDefault: aBoolean | oldProtocol forceNotify | forceNotify := (self protocolOrganizer includesSelector: selector) not. oldProtocol := self categoryOfElement: selector. (forceNotify or: [ oldProtocol ~= aProtocolName or: [ aBoolean not or: [ aProtocolName ~= Protocol unclassified ] ] ]) ifFalse: [ ^ self ]. self protocolOrganizer classify: selector inProtocolNamed: aProtocolName suppressIfDefault: aBoolean. self notifyOfChangedSelector: selector from: oldProtocol to: aProtocolName! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 18:41'! commentRemoteStr ^ comment! ! !ClassOrganization methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 15:52'! organizedClass ^ organizedClass! ! !ClassOrganization methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/26/2013 16:57'! addCategory: aString | oldCategories | (self protocolOrganizer hasProtocolNamed: aString) ifTrue: [ ^self ]. oldCategories := self categories copy. self protocolOrganizer addProtocolNamed: aString. self notifyOfAddedCategory: aString. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganization methodsFor: 'testing' stamp: 'EstebanLorenzano 11/29/2013 16:09'! isEmptyCategoryNamed: categoryName ^ (self protocolOrganizer protocolNamed: categoryName) isEmpty! ! !ClassOrganization methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/27/2013 18:01'! categories ^ self protocolOrganizer allProtocolsNames! ! !ClassOrganization methodsFor: 'testing' stamp: 'MarcusDenker 7/17/2013 14:29'! hasComment ^ self comment isEmptyOrNil not ! ! !ClassOrganization methodsFor: 'importing' stamp: 'BenjaminVanRyseghem 4/12/2012 18:29'! importFrom: aClassOrganizer organizedClass := aClassOrganizer subject. self comment: aClassOrganizer classComment. self commentStamp: aClassOrganizer commentStamp. protocolOrganizer := (ProtocolOrganizer importFrom: aClassOrganizer)! ! !ClassOrganization methodsFor: 'private' stamp: 'EstebanLorenzano 5/28/2013 18:05'! silentlyRenameCategory: oldName toBe: newName self protocolOrganizer renameProtocol: oldName into: newName. ! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 15:03'! classComment: aString self comment: aString! ! !ClassOrganization methodsFor: 'backward compatibility - file in/out' stamp: 'BenjaminVanRyseghem 4/12/2012 18:29'! scanFrom: aStream "Reads in the organization from the next chunk on aStream. Categories or elements not found in the definition are not affected. New elements are ignored." self changeFromString: aStream nextChunk. aStream skipStyleChunk.! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'PavelKrivanek 9/24/2013 14:19'! ownCategories "get all categories that are not obtained from traits. Order is random" | traitsCategories | traitsCategories := self subject traits inject: Set new into: [:set :trait | set addAll: (trait organization protocolOrganizer protocols reject: [ :eachProtocol | self subject methods anySatisfy: [ :eachMethod | eachMethod origin = self subject and: [ eachMethod protocol = eachProtocol name ] ] ]). set ]. ^ ((self protocolOrganizer protocols collect: #name) copyWithoutAll: (traitsCategories collect: #name)) asArray.! ! !ClassOrganization methodsFor: 'backward compatibility - file in/out' stamp: 'BenjaminVanRyseghem 4/13/2012 13:46'! internalChangeFromString: categorySpecs "Parse the argument, aString, and make this be the receiver's structure." protocolOrganizer := ProtocolOrganizer fromSpec: categorySpecs! ! !ClassOrganization methodsFor: 'notifications' stamp: 'EstebanLorenzano 6/21/2013 14:20'! notifyOfChangedSelector: element from: oldCategory to: newCategory (self hasSubject and: [(oldCategory ~= newCategory)]) ifTrue: [ self subject notifyOfRecategorizedSelector: element from: oldCategory to: newCategory ].! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/24/2012 14:38'! removeEmptyCategories | oldCategories | oldCategories := self protocolOrganizer allProtocolsNames copy. self protocolOrganizer removeEmptyProtocols. self notifyOfChangedCategoriesFrom: oldCategories to: self protocolOrganizer allProtocolsNames.! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 15:02'! classComment ^ self comment! ! !ClassOrganization methodsFor: 'notifications' stamp: 'EstebanLorenzano 6/26/2013 16:59'! notifyOfRemovedCategory: protocolName self hasSubject ifFalse: [ ^ self ]. SystemAnnouncer uniqueInstance protocolRemoved: protocolName inClass: self subject! ! !ClassOrganization methodsFor: 'backward compatibility - file in/out' stamp: 'CamilloBruni 6/29/2013 20:23'! fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." | fileComment | self classComment ifNil: [ ^ self ]. aFileStream cr. fileComment := RemoteString newString: self classComment string onFileNumber: fileIndex toFile: aFileStream. moveSource ifTrue: [ self classComment: fileComment ]! ! !ClassOrganization methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/28/2013 14:52'! listAtCategoryNamed: aName ^ (self protocolOrganizer methodsInProtocolNamed: aName) asArray! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/24/2012 14:17'! allMethodSelectors ^ protocolOrganizer allMethods! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'EstebanLorenzano 6/21/2013 14:41'! removeElement: aSymbol | oldProtocol | oldProtocol := self categoryOfElement: aSymbol. self protocolOrganizer removeMethod: aSymbol. self notifyOfChangedSelector: aSymbol from: oldProtocol to: (self categoryOfElement: aSymbol).! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'EstebanLorenzano 5/28/2013 14:09'! categoryOfElement: aSelector ^ (self protocolOrganizer protocolsOfSelector: aSelector) ifEmpty: [ Protocol unclassified ] ifNotEmpty: [:col | col first name ]! ! !ClassOrganization methodsFor: 'notifications' stamp: 'EstebanLorenzano 6/21/2013 14:35'! notifyOfChangedCategoriesFrom: oldCollectionOrNil to: newCollectionOrNil (self hasSubject and: [ oldCollectionOrNil ~= newCollectionOrNil ]) ifTrue: [ SystemAnnouncer uniqueInstance classReorganized: self subject ].! ! !ClassOrganization methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/11/2014 23:10'! removeProtocol: aProtocol | oldCategories | oldCategories := self protocolOrganizer allProtocolsNames copy. self protocolOrganizer removeProtocol: aProtocol. self notifyOfRemovedCategory: aProtocol name. self notifyOfChangedCategoriesFrom: oldCategories to: self protocolOrganizer allProtocolsNames.! ! !ClassOrganization methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 15:04'! commentStamp: anObject commentStamp := anObject! ! !ClassOrganization methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/29/2013 16:08'! protocolNamed: aString ^ self protocolOrganizer protocolNamed: aString ifAbsent: [ nil ] ! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'CamilloBruni 2/21/2014 23:35'! commentRemoteString ^ comment! ! !ClassOrganization methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 15:04'! commentStamp ^ commentStamp! ! !ClassOrganization methodsFor: 'backward compatibility - file in/out' stamp: 'BenjaminVanRyseghem 4/12/2012 18:11'! changeFromCategorySpecs: categorySpecs "notification" self internalChangeFromString: categorySpecs! ! !ClassOrganization methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 16:22'! extensionProtocols ^ self protocolOrganizer extensionProtocols.! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'EstebanLorenzano 6/21/2013 14:38'! addCategory: aProtocolName before: aUselessArgument self addCategory: aProtocolName! ! !ClassOrganization methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/12/2012 15:01'! protocolOrganizer ^ protocolOrganizer! ! !ClassOrganization methodsFor: 'backward compatibility - file in/out' stamp: 'BenjaminVanRyseghem 4/12/2012 18:10'! stringForFileOut ^ self protocolOrganizer stringForFileOut! ! !ClassOrganization methodsFor: 'accessing' stamp: 'ThierryGoubier 1/13/2014 20:50'! removeProtocolIfEmpty: protocolName "The protocol may already have been removed, be non empty or a special protocol which can't be removed, such as 'all'." (self protocolNamed: protocolName) ifNotNil: [ :protocol | (protocol isEmpty and: [ protocol canBeRemoved ]) ifTrue: [ self removeProtocol: protocol ] ]! ! !ClassOrganization class methodsFor: 'import' stamp: 'BenjaminVanRyseghem 4/24/2012 14:11'! importFrom: aClassOrganizer aClassOrganizer class = self ifTrue: [ ^ aClassOrganizer ]. ^ self new importFrom: aClassOrganizer; yourself! ! !ClassOrganization class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 5/28/2013 16:35'! forClass: aClass ^ self basicNew initializeClass: aClass; yourself! ! !ClassOrganizationDeclaration commentStamp: ''! I represent the declaration of a class organization in a file. My contents is the class organization string to import, and the class organizer is the one of the changed class. Sending me the message #import makes me install the class organization I carry into the class.! !ClassOrganizationDeclaration methodsFor: 'importing' stamp: 'GuillermoPolito 5/5/2012 20:44'! import (self existsBehavior) ifFalse: [ self error: ('Cannot change organization of unexistent behavior {1}' format: { behaviorName asString } ) ]. self targetClass organization changeFromString: contents! ! !ClassOrganizationDeclaration class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 16:31'! contents: someContents organizer: aClassOrganizer ^self new contents: someContents; organizer: aClassOrganizer; yourself! ! !ClassOrganizationDeclaration class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 20:48'! contents: someContents behaviorName: behaviorName isMeta: aBoolean ^self new contents: someContents; behaviorName: behaviorName; isMeta: aBoolean; yourself! ! !ClassOrganizationTest commentStamp: 'TorstenBergmann 2/4/2014 22:00'! SUnit tests for class organization! !ClassOrganizationTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testRemoveNonExistingProtocol self organization removeCategory: 'non-existent'! ! !ClassOrganizationTest methodsFor: 'tests' stamp: 'EstebanLorenzano 6/21/2013 15:06'! testAddCategory self organization addCategory: 'test-protocol'. self assert: (self organization categories includes: 'test-protocol')! ! !ClassOrganizationTest methodsFor: 'running' stamp: 'EstebanLorenzano 6/21/2013 14:47'! runCase SystemAnnouncer uniqueInstance suspendAllWhile: [ super runCase ]! ! !ClassOrganizationTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testRemoveCategory self assert: self organization categories size = 3. self should: [ self organization removeCategory: 'one' ] raise: Error. self organization removeCategory: 'empty'. self assert: self organization categories size = 2. self assert: self organization categories first = AllProtocol defaultName. self assert: self organization categories second = 'one'! ! !ClassOrganizationTest methodsFor: 'tests' stamp: 'EstebanLorenzano 6/21/2013 15:06'! testCategories | categories | categories := self organization categories. self assert: categories notEmpty.! ! !ClassOrganizationTest methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/21/2013 15:06'! organization ^ organization! ! !ClassOrganizationTest methodsFor: 'running' stamp: 'PavelKrivanek 8/5/2013 13:40'! setUp organization := ClassOrganization new. organization addCategory: 'empty'. organization addCategory: 'one'. organization classify: #one under: 'one' suppressIfDefault: true. ! ! !ClassOrganizationTest methodsFor: 'tests' stamp: 'EstebanLorenzano 6/21/2013 15:06'! testListAtCategoryNamed | methods | methods := self organization listAtCategoryNamed: 'empty'. self assert: methods isEmpty. methods := self organization listAtCategoryNamed: 'one'. self assert: methods size = 1. self assert: methods first = #one.! ! !ClassQueryTest methodsFor: 'tests' stamp: 'CamilleTeruel 12/6/2013 15:19'! testAllCallsOn | calls | calls := ClassQueryTest allCallsOn. self assert: calls size equals: 1. self assert: calls first compiledMethod equals: ClassQueryTest>>#testAllCallsOn! ! !ClassQueryTest methodsFor: 'tests' stamp: 'CamilleTeruel 12/6/2013 14:54'! testAllCallsOnASymbol | set cm | set := Object allCallsOn: #shallowCopy. cm := (set detect: [ :rgMethod | rgMethod selector == #copy ]) compiledMethod. self assert: (cm methodClass == Object). self assert: (cm literals includes: #shallowCopy)! ! !ClassQueryTest methodsFor: 'dependencies' stamp: 'StephaneDucasse 8/4/2013 11:20'! testReferencedClasses "self debug: #testReferencedClasses" | refs | refs := Metaclass referencedClasses. self assert: (refs includes: SystemAnnouncer). refs := self class referencedClasses. self assert: (refs includesAllOf: {SystemAnnouncer . Metaclass})! ! !ClassRecategorized commentStamp: 'cyrilledelaunay 1/18/2011 10:42'! This announcement will be raised when: - we set a category to a class (see 'Class >>category:') - we set a category to a Trait (see Trait>>category:) It corresponds to the RecategorizedEvent! !ClassRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:59'! classRecategorized ^classRecategorized! ! !ClassRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:59'! classRecategorized: aClass classRecategorized := aClass! ! !ClassRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:58'! oldCategory: anOldCategory oldCategory := anOldCategory! ! !ClassRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:25'! newCategory ^newCategory! ! !ClassRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:58'! newCategory: aNewCategory newCategory := aNewCategory! ! !ClassRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 13:50'! classAffected ^self classRecategorized! ! !ClassRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:25'! oldCategory ^oldCategory! ! !ClassRecategorized class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/1/2012 23:58'! class: aClass recategorizedFrom: oldCategory to: newCategory ^self new classRecategorized: aClass; oldCategory: oldCategory; newCategory: newCategory; yourself! ! !ClassRemoved commentStamp: 'cyrilledelaunay 1/18/2011 11:43'! the annoucement will be emitted when removing a class or a trait using: => removeFromSystem! !ClassRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:29'! classRemoved: anObject classRemoved := anObject! ! !ClassRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:29'! categoryName: anObject categoryName := anObject! ! !ClassRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 13:50'! classAffected ^self classRemoved! ! !ClassRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:29'! categoryName ^ categoryName! ! !ClassRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:29'! classRemoved ^ classRemoved! ! !ClassRemoved class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:29'! class: aClass category: aCategoryName ^self new classRemoved: aClass; categoryName: aCategoryName; yourself.! ! !ClassRenameFixTest methodsFor: 'running' stamp: 'GuillermoPolito 8/3/2012 13:29'! verifyRenameEvent: aRenamedEvent | renamedClass | renamedClass := aRenamedEvent classRenamed. self assert: (Smalltalk globals classNamed: newClassName) name = newClassName. self assert: renamedClass name = newClassName! ! !ClassRenameFixTest methodsFor: 'private' stamp: 'md 9/6/2005 18:30'! newUniqueClassName "Return a class name that is not used in the system." "self new newClassName" | baseName newName | baseName := 'AutoGeneratedClassForTestingSystemChanges'. 1 to: 9999 do: [:number | newName := baseName , number printString. (Smalltalk hasClassNamed: newName) ifFalse: [^newName asSymbol]]. ^self error: 'Can no longer find a new and unique class name for the SystemChangeTest !!'! ! !ClassRenameFixTest methodsFor: 'running' stamp: 'CamilleTeruel 7/29/2012 18:45'! tearDown self removeEverythingInSetFromSystem: testsChangeSet. ChangeSet newChanges: previousChangeSet. ChangeSet removeChangeSet: testsChangeSet. previousChangeSet := nil. testsChangeSet := nil. SystemAnnouncer uniqueInstance unsubscribe: self. super tearDown.! ! !ClassRenameFixTest methodsFor: 'private' stamp: 'StephaneDucasse 8/9/2011 17:57'! removeEverythingInSetFromSystem: aChangeSet aChangeSet changedMessageList do: [:methodRef | methodRef actualClass removeSelector: methodRef selector]. aChangeSet changedClasses do: [:each | each isMeta ifFalse: [each removeFromSystemUnlogged]]! ! !ClassRenameFixTest methodsFor: 'tests' stamp: 'StephaneDucasse 3/29/2010 17:36'! renameClassUsing: aBlock | createdClass foundClasses | originalName := self newUniqueClassName. createdClass := Object subclass: originalName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ClassRenameFix-GeneradClass'. newClassName := self newUniqueClassName. aBlock value: createdClass value: newClassName. self assert: (Smalltalk globals classNamed: originalName) isNil. self assert: (Smalltalk globals classNamed: newClassName) notNil. foundClasses := Smalltalk globals organization listAtCategoryNamed: 'ClassRenameFix-GeneradClass'. self assert: foundClasses notEmpty. self assert: (foundClasses includes: newClassName). self assert: createdClass name = newClassName! ! !ClassRenameFixTest methodsFor: 'running' stamp: 'EstebanLorenzano 7/27/2012 12:17'! setUp previousChangeSet := ChangeSet current. testsChangeSet := ChangeSet new. ChangeSet newChanges: testsChangeSet. SystemAnnouncer uniqueInstance weak on: ClassRenamed send: #verifyRenameEvent: to: self. super setUp! ! !ClassRenameFixTest methodsFor: 'tests' stamp: 'md 9/6/2005 18:30'! testRenameClassUsingClass "self run: #testRenameClassUsingClass" self renameClassUsing: [:class :newName | class rename: newName].! ! !ClassRenamed commentStamp: 'cyrilledelaunay 1/18/2011 11:44'! the annoucement will be emitted when renaming a class or a trait using: => RenameClassRefactoring >> rename:to: => class>>rename: The corresponding event is raised in: SystemDictionary>>renameClass:from:to:! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:33'! newName ^newName! ! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:33'! oldName ^oldName! ! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:33'! category ^ category! ! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:33'! classRenamed: anObject classRenamed := anObject! ! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:33'! newName: anObject newName := anObject! ! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:33'! oldName: anObject oldName := anObject! ! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 13:51'! classAffected ^self classRenamed! ! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:33'! classRenamed ^ classRenamed! ! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:33'! category: anObject category := anObject! ! !ClassRenamed class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:33'! class: aClass category: aCategoryName oldName: anOldClassName newName: aNewClassName ^self new classRenamed: aClass; category: aCategoryName; oldName: anOldClassName; newName: aNewClassName; yourself! ! !ClassReorganized commentStamp: 'cyrilledelaunay 1/18/2011 15:03'! This announcement corresponds to the ReorganizedEvent, which seems to (by looking at the references of ReorganizedEvent) be raised when: - we rename a protocol (see 'renameCategory:toBe: '). if The category is not empty, SystemMethodRecategorizedAnnouncement will also be emitted - we sort (modify the order of) protocols (see 'sortCategories') - we add a protocol (see 'addCategory:before:') - we remove a protocol (see 'removeCategory:' 'removeEmptyCategories')! !ClassReorganized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 13:51'! classAffected ^self classReorganized! ! !ClassReorganized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:36'! classReorganized ^ classReorganized! ! !ClassReorganized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:36'! classReorganized: anObject classReorganized := anObject! ! !ClassReorganized class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:36'! class: aClass ^self new classReorganized: aClass; yourself! ! !ClassRepackaged commentStamp: 'TorstenBergmann 2/12/2014 22:56'! Notify about repackaging of a class! !ClassRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! classRepackaged: anObject classRepackaged := anObject! ! !ClassRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! oldPackage: anObject oldPackage := anObject! ! !ClassRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! oldPackage ^ oldPackage! ! !ClassRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! classRepackaged ^ classRepackaged! ! !ClassRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! newPackage ^ newPackage! ! !ClassRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! newPackage: anObject newPackage := anObject! ! !ClassRepackaged class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/17/2012 17:20'! classRepackaged: aClass oldPackage: oldPackage newPackage: newPackage ^self new classRepackaged: aClass; oldPackage: oldPackage; newPackage: newPackage; yourself.! ! !ClassTest commentStamp: 'TorstenBergmann 2/5/2014 08:31'! SUnit tests for classes! !ClassTest methodsFor: 'testing - access' stamp: 'CamilloBruni 8/31/2013 20:23'! testSharedPools "self run: #testSharedPools" self assert: Point sharedPools = OrderedCollection new. self assert: Date sharedPools first = ChronologyConstants. self assert: Date sharedPools size = 1. "a metaclass does not have shared pools since only classes have shared pools" Date class sharedPools. self assert: RootClassPoolUser sharedPools size = 1. self assert: ClassMultiplePoolUser sharedPools size = 2. "has shared pools does not take into account the fact that a superclass may use some shared pools" self assert: SubclassPoolUser sharedPools isEmpty! ! !ClassTest methodsFor: 'testing - access' stamp: 'StephaneDucasse 12/13/2011 17:42'! testSharedPoolOfVarNamed "self debug: #testSharedPoolOfVarNamed" self assert: (Date sharedPoolOfVarNamed: 'DayNames') = ChronologyConstants. "a metaclass does not have shared pools since only classes have shared pools" self assert: (Date class sharedPoolOfVarNamed: 'DayNames') isNil. self assert: (RootClassPoolUser sharedPoolOfVarNamed: 'Author') = PoolDefiner. self assert: (RootClassPoolUser sharedPoolOfVarNamed: 'Gloups') = PoolDefiner. self assert: (SubclassPoolUser sharedPoolOfVarNamed: 'Author') = PoolDefiner. self assert: (ClassMultiplePoolUser sharedPoolOfVarNamed: 'Author') = PoolDefiner. self assert: (ClassMultiplePoolUser sharedPoolOfVarNamed: 'VariableInPoolDefiner2') = PoolDefiner2. self assert: (ClassMultiplePoolUser sharedPoolOfVarNamed: 'Gloups') = PoolDefiner.! ! !ClassTest methodsFor: 'testing - class variables' stamp: 'marcus.denker 12/4/2008 11:12'! testClassVarNames self assert: (Object classVarNames includes: #DependentsFields). "A class and it's meta-class share the class variables" self assert: (Object classVarNames = Object class classVarNames).! ! !ClassTest methodsFor: 'testing' stamp: 'lr 3/14/2010 21:13'! testRenaming "self debug: #testRenaming" "self run: #testRenaming" | oldName newMetaclassName class | oldName := className. newMetaclassName := (renamedName , #' class') asSymbol. class := Smalltalk globals at: oldName. class class compile: 'dummyMeth'. class rename: renamedName. self assert: class name = renamedName. self assert: (ChangeSet current changedClassNames includes: renamedName). self assert: (ChangeSet current changedClassNames includes: newMetaclassName)! ! !ClassTest methodsFor: 'testing' stamp: 'MarcusDenker 1/21/2014 13:36'! testClassRespectsPolymorphismWithTrait | repeatedMethodsThatDoNotAccessInstanceVariables differentMethodsWithSameSelector | "If the method is in Class and Trait it must access some instance variable, otherwise the method can be implemented in TClass" repeatedMethodsThatDoNotAccessInstanceVariables := self repeatedMethodsThatDoNotAccessInstanceVariablesBetween: Class and: Trait. self assert: repeatedMethodsThatDoNotAccessInstanceVariables size equals: 0. "If the method is in Class and Trait, and they have different implementations, it must be declared in TClass as an explicitRequirement method" differentMethodsWithSameSelector := self differentMethodsWithSameSelectorBetween: Class and: Trait. differentMethodsWithSameSelector do: [ :selector | (TClass >> selector) sourceCode. self assert: (TClass >> selector) isRequired ]. "Only a few methods are allowed to belong to one class and not to the other. It would be excelent to remove these methods somehow, but is NOT good idea add methods to this list. Accessors to instance variables that do not belong to Trait: #setName: #getName #traitComposition #traitComposition: #localSelectors #localSelectors: #basicLocalSelectors #basicLocalSelectors #baseClass and #classClass have their equivalent in Trait, but the problem is the name of the selector, they are bad names. #addInstVarNamed: for traits is implemeted in TraitDescription" self assertCollection: (Class localSelectors difference: Trait localSelectors) equals: #( #traitComposition: #setName: #getName #baseClass #basicLocalSelectors #classClass isClass #basicLocalSelectors: #traitComposition #addInstVarNamed: #newAnonymousSubclass #definitionForNautilus ) asSet. "#classTrait:, #isClassTrait, #classTrait, #isBaseTrait and #baseTrait have their equivalent for classes but with different name #nautilusIcon and #initialize are implemented differently for traits, classes have their implentation in Object" self assertCollection: (Trait localSelectors difference: Class localSelectors) equals: #( #classTrait: #isClassTrait #classTrait #systemIcon #isBaseTrait #initialize #baseTrait ) asSet.! ! !ClassTest methodsFor: 'testing - dependencies' stamp: 'AlexandreBergel 1/4/2014 21:14'! testDependencies self assert: (ClassTest dependentClasses includes: ClassTest superclass). self assert: (ClassTest dependentClasses includes: Date)! ! !ClassTest methodsFor: 'testing' stamp: 'CamilleTeruel 1/14/2013 15:12'! testChangingShapeDoesNotPutNilInMethodsLastLiteralKey "Test that when the shape of a class changes, the key of the last literal of the methods is not nil" | tutu | tutu := Smalltalk globals at: #TUTU. tutu compile: 'foo'. self deny: (tutu >> #foo) allLiterals last key isNil. tutu addInstVarNamed: 'x'. self deny: (tutu >> #foo) allLiterals last key isNil.! ! !ClassTest methodsFor: 'testing - file in/out' stamp: 'GuillermoPolito 6/26/2012 15:58'! testOrdersACollectionOfClassesBySuperclass "self debug: #testOrdersACollectionOfClassesBySuperclass" | ordered | ordered := (Class superclassOrder: (OrderedCollection with: ExampleForTest11 class with: ExampleForTest111 class with: ExampleForTest12 class with: ExampleForTest1 class with: ExampleForTest12 class with: ExampleForTest112 class)). self assert: (ordered indexOf: ExampleForTest1 class) < (ordered indexOf: ExampleForTest11 class). self assert: (ordered indexOf: ExampleForTest11 class) < (ordered indexOf: ExampleForTest111 class). self assert: (ordered indexOf: ExampleForTest11 class) < (ordered indexOf: ExampleForTest112 class). self assert: (ordered indexOf: ExampleForTest1 class) < (ordered indexOf: ExampleForTest12 class). ! ! !ClassTest methodsFor: 'testing - access' stamp: 'StephaneDucasse 12/13/2011 16:13'! testHasSharedPools "self run: #testHasSharedPools" self deny: Point hasSharedPools. self assert: Date hasSharedPools. "a metaclass does not have shared pools since only classes have shared pools" self deny: Date class hasSharedPools. self assert: RootClassPoolUser hasSharedPools. "has shared pools does not take into account the fact that a superclass may use some shared pools" self deny: SubclassPoolUser hasSharedPools.! ! !ClassTest methodsFor: 'setup' stamp: 'lr 3/14/2010 21:13'! deleteClass | cl | cl := Smalltalk globals at: className ifAbsent: [ ^ self ]. cl removeFromChanges; removeFromSystemUnlogged! ! !ClassTest methodsFor: 'setup' stamp: 'lr 3/14/2010 21:13'! deleteRenamedClass | cl | cl := Smalltalk globals at: renamedName ifAbsent: [ ^ self ]. cl removeFromChanges; removeFromSystemUnlogged! ! !ClassTest methodsFor: 'setup' stamp: 'BenComan 3/2/2014 09:38'! categoryNameForTemporaryClasses "Answer the category where to classify temporarily created classes" ^'Dummy-Tests-Class' ! ! !ClassTest methodsFor: 'testing - access' stamp: 'CamilloBruni 8/31/2013 20:23'! testAllSharedPools "self run: #testAllSharedPools" self assert: Point allSharedPools = OrderedCollection new. self assert: Date sharedPools first = ChronologyConstants. self assert: Date sharedPools size = 1. "a metaclass does not have shared pools since only classes have shared pools" Date class sharedPools. self assert: RootClassPoolUser sharedPools size = 1. self assert: ClassMultiplePoolUser sharedPools size = 2. "has shared pools does not take into account the fact that a superclass may use some shared pools" self assert: SubclassPoolUser sharedPools isEmpty! ! !ClassTest methodsFor: 'testing - access' stamp: 'MarianoMartinezPeck 12/16/2011 11:55'! testHasPoolVarNamed "self debug: #testHasPoolVarNamed" self assert: (Date usesLocalPoolVarNamed: 'DayNames'). "a metaclass does not have shared pools since only classes have shared pools" self deny: (Date class usesLocalPoolVarNamed: 'DayNames'). self assert: (RootClassPoolUser usesLocalPoolVarNamed: 'Author'). "a subclass does not have the one of its superclass - but it would be good to change that" self deny: (SubclassPoolUser usesLocalPoolVarNamed: 'Author').! ! !ClassTest methodsFor: 'testing - file in/out' stamp: 'GuillermoPolito 6/26/2012 15:58'! testOrdersMetaClassAfterItsClassInstance | ordered | ordered := (Class superclassOrder: (OrderedCollection with: Boolean class with: True with: Boolean with: True class)). self assert: (ordered indexOf: Boolean) < (ordered indexOf: Boolean class). self assert: (ordered indexOf: True) < (ordered indexOf: True class). self assert: (ordered indexOf: Boolean class) < (ordered indexOf: True class). self assert: (ordered indexOf: Boolean) < (ordered indexOf: True). ! ! !ClassTest methodsFor: 'setup' stamp: 'BenComan 3/2/2014 20:54'! tearDown self deleteClass. self deleteRenamedClass. {self unclassifiedCategory. self categoryNameForTemporaryClasses} do: [:category| RPackage organizer unregisterPackageNamed: category]! ! !ClassTest methodsFor: 'classcreation' stamp: 'NouryBouraqadi 12/16/2011 15:13'! testNewSubclass | cls | cls := Point newSubclass. self assert: (cls isBehavior). self assert: (cls superclass == Point). self assert: (Point allSubclasses includes: cls). self assert: (cls instVarNames = #()). self assert: (cls category = self unclassifiedCategory). self assert: (cls classVarNames = #()). cls removeFromSystem.! ! !ClassTest methodsFor: 'testing - access' stamp: 'StephaneDucasse 12/13/2011 17:17'! testUsesPoolVarNamed "self debug: #testUsesPoolVarNamed" self assert: (Date usesPoolVarNamed: 'DayNames'). "a metaclass does not have shared pools since only classes have shared pools" self deny: (Date class usesPoolVarNamed: 'DayNames'). self assert: (RootClassPoolUser usesPoolVarNamed: 'Author'). "a subclass has the one of its superclass" self assert: (SubclassPoolUser usesPoolVarNamed: 'Author').! ! !ClassTest methodsFor: 'testing' stamp: 'StephaneDucasse 12/13/2011 16:03'! testPoolVariableAccessibleInSubclassOfClassUser "This test shows that a Pool Variable is not accessible from a subclass that declare the Pool usage: here SubFlop subclass of Flop and this is a bug. " "self debug: #testInSubclassOfClassUser" PoolDefiner initialize. SubclassPoolUser compileAll. self assert: SubclassPoolUser gloups = 42. self assert: SubclassPoolUser author = 'Ducasse'! ! !ClassTest methodsFor: 'setup' stamp: 'Janniklaval 10/23/2010 13:35'! setUp className := #TUTU. renamedName := #RenamedTUTU. self deleteClass. self deleteRenamedClass. Object subclass: className instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses! ! !ClassTest methodsFor: 'classcreation' stamp: 'Alexandre Bergel 6/3/2010 08:35'! testSubclass | cls | (Smalltalk globals includesKey: #SubclassExample) ifTrue: [ (Smalltalk at: #SubclassExample) removeFromSystem ]. self deny: (Smalltalk globals includesKey: #SubclassExample). cls := Object subclass: #SubclassExample. self assert: (Smalltalk globals includesKey: #SubclassExample). self assert: (Smalltalk at: #SubclassExample) == cls. self assert: cls category = #Unclassified. self assert: cls instVarNames = #(). cls removeFromSystem! ! !ClassTest methodsFor: 'classcreation' stamp: 'NouryBouraqadi 12/16/2011 15:13'! unclassifiedCategory ^#Unclassified! ! !ClassTest methodsFor: 'testing' stamp: 'StephaneDucasse 12/13/2011 16:02'! testPoolVariableAccessibleInClassUser "This test shows that a Pool Variable is accessible from the class that declare the Pool usage: here the superclass" "self debug: #testInClassUser" PoolDefiner initialize. RootClassPoolUser compileAll. self assert: RootClassPoolUser gloups = 42. self assert: RootClassPoolUser author = 'Ducasse'! ! !ClassTest methodsFor: 'testing - compiling' stamp: 'CamilloBruni 8/31/2013 20:23'! testCompileAll ClassTest compileAll! ! !ClassTest methodsFor: 'testing' stamp: 'StephaneDucasse 8/27/2010 11:33'! testAddInstVarName "self run: #testAddInstVarName" | tutu | tutu := Smalltalk globals at: #TUTU. tutu addInstVarNamed: 'x'. self assert: tutu instVarNames = #('x'). tutu addInstVarNamed: 'y'. self assert: tutu instVarNames = #('x' 'y')! ! !ClassTest methodsFor: 'classcreation' stamp: 'AdrianLienhard 11/27/2010 00:31'! testSubclassInstanceVariableNames | cls | (Smalltalk globals includesKey: #SubclassExample) ifTrue: [ (Smalltalk at: #SubclassExample) removeFromSystem ]. self deny: (Smalltalk globals includesKey: #SubclassExample). cls := Object subclass: #SubclassExample instanceVariableNames: 'x y'. self assert: (Smalltalk globals includesKey: #SubclassExample). self assert: (Smalltalk at: #SubclassExample) == cls. self assert: cls category = #Unclassified. self assert: cls instVarNames = #('x' 'y'). cls removeFromSystem! ! !ClassTestCase commentStamp: 'brp 7/26/2003 16:57'! This class is intended for unit tests of individual classes and their metaclasses. It provides methods to determine the coverage of the unit tests. Subclasses are expected to re-implement #classesToBeTested and #selectorsToBeIgnored. They should also implement to confirm that all methods have been tested. #testCoverage super testCoverage. ! !ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/26/2003 17:22'! selectorsToBeIgnored ^ #(#DoIt #DoItIn:)! ! !ClassTestCase methodsFor: 'utils' stamp: 'SebastianTleye 7/19/2013 15:30'! repeatedMethodsThatDoNotAccessInstanceVariablesBetween: firstClass and: secondClass | repeatedSelectors repeatedMethodsThatDoNotAccessInstanceVariables | repeatedSelectors := firstClass localSelectors intersection: secondClass localSelectors. repeatedMethodsThatDoNotAccessInstanceVariables := repeatedSelectors select: [ :selector | | m1 m2| m1 := firstClass>>selector. m2 := secondClass>>selector. ((m1 sourceCode = m2 sourceCode) and: [ m1 hasInstVarRef not ]) and: [ m2 hasInstVarRef not ]]. ^repeatedMethodsThatDoNotAccessInstanceVariables.! ! !ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/27/2003 12:40'! selectorsToBeTested ^ ( { self classToBeTested. self classToBeTested class } gather: [:c | c selectors]) difference: self selectorsToBeIgnored! ! !ClassTestCase methodsFor: 'private' stamp: 'GuillermoPolito 6/27/2012 12:33'! targetClass [ ^ self classToBeTested ] on: Error do: [ | className | className := self class name asString copyFrom: 1 to: self class name size - 4. ^ Smalltalk globals at: className asString asSymbol ]! ! !ClassTestCase methodsFor: 'tests' stamp: 'brp 12/14/2003 15:51'! testCoverage | untested | self class mustTestCoverage ifTrue: [ untested := self selectorsNotTested. self assert: untested isEmpty description: untested size asString, ' selectors are not covered' ]! ! !ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/27/2003 12:39'! classToBeTested self subclassResponsibility! ! !ClassTestCase methodsFor: '*Manifest-Core' stamp: 'CamilloBruni 8/22/2013 11:58'! assertValidLintRule: aLintRule | checker | checker := SmalllintManifestChecker new rule: aLintRule; environment: self targetClassEnvironment; run. self assert: aLintRule result isEmpty description: [ aLintRule rationale ]! ! !ClassTestCase methodsFor: '*Refactoring-Critics' stamp: 'SebastianTleye 7/19/2013 12:50'! testTraitExplicitRequirementMethodsMustBeImplementedInTheClassOrInASuperclass self assertValidLintRule: RBExplicitRequirementMethodsRule new! ! !ClassTestCase methodsFor: '*Refactoring-Critics' stamp: 'SebastianTleye 7/19/2013 14:30'! testMethodsOfTheClassShouldNotBeRepeatedInItsSuperclasses self assertValidLintRule: RBRepeteadMethodsInTheSuperclassRule new! ! !ClassTestCase methodsFor: 'coverage' stamp: 'MarcusDenker 3/5/2010 14:33'! selectorsTested | literals | literals := Set new. self class selectorsAndMethodsDo: [ :s :m | (s beginsWith: 'test') ifTrue: [ literals addAll: (m messages)] ]. ^ literals asArray sort! ! !ClassTestCase methodsFor: 'tests' stamp: 'StephaneDucasse 8/29/2013 20:54'! testUnCategorizedMethods | uncategorizedMethods | uncategorizedMethods := self targetClass selectorsInProtocol: Protocol unclassified. self assert: uncategorizedMethods isEmpty description: uncategorizedMethods asString ! ! !ClassTestCase methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testNew self targetClass new! ! !ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/26/2003 16:35'! selectorsNotTested ^ self selectorsToBeTested difference: self selectorsTested. ! ! !ClassTestCase methodsFor: '*Manifest-Core' stamp: 'SebastianTleye 7/19/2013 11:25'! targetClassEnvironment ^RBClassEnvironment class: self targetClass.! ! !ClassTestCase methodsFor: 'tests' stamp: 'CamilloBruni 5/1/2013 18:27'! testClassComment self assert: self targetClass organization hasComment.! ! !ClassTestCase methodsFor: '*Refactoring-Critics' stamp: 'SebastianTleye 7/19/2013 13:45'! testLocalMethodsOfTheClassShouldNotBeRepeatedInItsTraits self assertValidLintRule: RBLocalMethodsOfAClassNotInItsTraitComposition new! ! !ClassTestCase methodsFor: 'utils' stamp: 'SebastianTleye 7/19/2013 15:29'! differentMethodsWithSameSelectorBetween: firstClass and: secondClass | repeatedSelectors differentMethodsWithSameSelector | repeatedSelectors := firstClass localSelectors intersection: secondClass localSelectors. differentMethodsWithSameSelector := repeatedSelectors select: [ :selector | | m1 m2| m1 := firstClass>>selector. m2 := secondClass>>selector. m1 sourceCode ~= m2 sourceCode]. ^differentMethodsWithSameSelector.! ! !ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:32'! categoriesForClass: aClass ^ aClass organization allMethodSelectors collect: [:each | aClass organization categoryOfElement: each]. ! ! !ClassTestCase class methodsFor: 'testing' stamp: 'brp 12/14/2003 15:50'! mustTestCoverage ^ false! ! !ClassTestCase class methodsFor: 'testing' stamp: 'md 2/22/2006 14:21'! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self name = #ClassTestCase ! ! !ClassTrait commentStamp: ''! While every class has an associated metaclass, a trait can have an associated classtrait, an instance of me. To preserve metaclass compatibility, the associated classtrait (if there is one) is automatically applied to the metaclass, whenever a trait is applied to a class. Consequently, a trait with an associated classtrait can only be applied to classes, whereas a trait without a classtrait can be applied to both classes and metaclasses.! !ClassTrait methodsFor: 'testing' stamp: ''! isObsolete "Return true if the receiver is obsolete" ^self soleInstance == nil "Either no thisClass" or:[self soleInstance classSide ~~ self "or I am not the class of thisClass" or:[self soleInstance isObsolete]] "or my instance is obsolete"! ! !ClassTrait methodsFor: 'composition' stamp: ''! assertConsistantCompositionsForNew: aTraitComposition "Applying or modifying a trait composition on the class side of a behavior has some restrictions." | baseTraits notAddable message | baseTraits := aTraitComposition traits select: [:each | each isBaseTrait]. baseTraits isEmpty ifFalse: [ notAddable := (baseTraits reject: [:each | each classSide methodDict isEmpty]). notAddable isEmpty ifFalse: [ message := String streamContents: [:stream | stream nextPutAll: 'You can not add the base trait(s)'; cr. notAddable do: [:each | stream nextPutAll: each name] separatedBy: [ stream nextPutAll: ', ']. stream cr; nextPutAll: 'to this composition because it/they define(s) methods on the class side.']. ^TraitCompositionException signal: message]]. (self instanceSide traitComposition traits asSet = (aTraitComposition traits select: [:each | each isClassTrait] thenCollect: [:each | each baseTrait]) asSet) ifFalse: [ ^TraitCompositionException signal: 'You can not add or remove class side traits on the class side of a composition. (But you can specify aliases or exclusions for existing traits or add a trait which does not have any methods on the class side.)']! ! !ClassTrait methodsFor: 'accessing' stamp: 'md 3/14/2006 16:37'! soleInstance ^baseTrait! ! !ClassTrait methodsFor: '*Monticello' stamp: 'damiencassou 7/30/2009 12:10'! asMCDefinition ^MCClassTraitDefinition baseTraitName: self baseTrait name classTraitComposition: self traitCompositionString category: self category ! ! !ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:38'! baseTrait ^baseTrait! ! !ClassTrait methodsFor: 'initialize-release' stamp: 'SebastianTleye 7/17/2013 13:39'! adoptInstance: oldInstance from: oldMetaClass ^self error: 'Traits cannot adopt instances'.! ! !ClassTrait methodsFor: '*Manifest-Core' stamp: ''! criticTheNonMetaclassClass ^self theNonMetaClass ! ! !ClassTrait methodsFor: 'initialize' stamp: ''! initializeFrom: anotherClassTrait self traitComposition: self traitComposition copyTraitExpression. self methodDict: self methodDict copy. self localSelectors: self localSelectors copy. self basicOrganization: self organization copy.! ! !ClassTrait methodsFor: 'initialize' stamp: 'al 3/24/2004 20:37'! initializeWithBaseTrait: aTrait self baseTrait: aTrait. self noteNewBaseTraitCompositionApplied: aTrait traitComposition. aTrait users do: [:each | self addUser: each classSide]. ! ! !ClassTrait methodsFor: '*Ring-Core-Kernel' stamp: ''! asFullRingDefinition ^ self theNonMetaClass asFullRingDefinition theMetaClass! ! !ClassTrait methodsFor: 'compiling' stamp: ''! bindingOf: varName ^self theNonMetaClass classBindingOf: varName! ! !ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'jannik.laval 5/1/2010 16:02'! baseTrait: aTrait [aTrait isBaseTrait] assert. baseTrait := aTrait ! ! !ClassTrait methodsFor: 'class hierarchy' stamp: ''! addSubclass: aClass "Do nothing."! ! !ClassTrait methodsFor: 'accessing' stamp: ''! category ^ self theNonMetaClass category! ! !ClassTrait methodsFor: '*Tools-Debugger' stamp: 'SebastianTleye 7/17/2013 14:19'! canonicalArgumentName ^ 'aTrait'.! ! !ClassTrait methodsFor: 'composition' stamp: ''! uses: aTraitCompositionOrArray | copyOfOldTrait newComposition | copyOfOldTrait := self copy. newComposition := aTraitCompositionOrArray asTraitComposition. self assertConsistantCompositionsForNew: newComposition. self setTraitComposition: newComposition. SystemAnnouncer uniqueInstance traitDefinitionChangedFrom: copyOfOldTrait to: self.! ! !ClassTrait methodsFor: 'instance variables' stamp: ''! addInstVarNamed: aString "Add the argument, aString, as one of the receiver's instance variables." | fullString | fullString := String streamContents: [:strm | self instVarNames do: [:aString2 | strm nextPutAll: aString2; space]. strm nextPutAll: aString]. self instanceVariableNames: fullString! ! !ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:38'! classTrait ^self! ! !ClassTrait methodsFor: 'compiling' stamp: ''! binding "return an association that can be used as the binding To share it between methods, reuse an existing one if possible" ^self methodDict ifEmpty: [nil -> self] ifNotEmpty: [:dict | dict anyOne classBinding]! ! !ClassTrait methodsFor: 'class hierarchy' stamp: ''! addObsoleteSubclass: aClass "Do nothing."! ! !ClassTrait methodsFor: '*Ring-Core-Kernel' stamp: ''! asRingDefinition ^ self theNonMetaClass asRingDefinition theMetaClass! ! !ClassTrait methodsFor: 'initialize-release' stamp: ''! uses: aTraitCompositionOrArray instanceVariableNames: instVarString | newComposition newMetaClass copyOfOldMetaClass | copyOfOldMetaClass := self copy. newMetaClass := self instanceVariableNames: instVarString. newComposition := aTraitCompositionOrArray asTraitComposition. newMetaClass assertConsistantCompositionsForNew: newComposition. newMetaClass setTraitComposition: newComposition. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfOldMetaClass to: newMetaClass! ! !ClassTrait methodsFor: 'accessing' stamp: 'al 4/21/2004 09:38'! name ^self baseTrait name , ' classTrait'! ! !ClassTrait methodsFor: 'pool variables' stamp: ''! sharedPools ^OrderedCollection new.! ! !ClassTrait methodsFor: 'testing' stamp: ''! isAnonymous ^self soleInstance isAnonymous ! ! !ClassTrait methodsFor: 'instance variables' stamp: ''! removeInstVarNamed: aString "Remove the argument, aString, as one of the receiver's instance variables." | newArray newString | (self instVarNames includes: aString) ifFalse: [self error: aString , ' is not one of my instance variables']. newArray := self instVarNames copyWithout: aString. newString := ''. newArray do: [:aString2 | newString := aString2 , ' ' , newString]. self instanceVariableNames: newString! ! !ClassTrait methodsFor: 'class hierarchy' stamp: ''! removeSubclass: aClass "Do nothing."! ! !ClassTrait methodsFor: 'compiling' stamp: ''! acceptsLoggingOfCompilation "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself." ^ self theNonMetaClass acceptsLoggingOfCompilation! ! !ClassTrait methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitClassTrait: self ! ! !ClassTrait methodsFor: 'class hierarchy' stamp: ''! obsoleteSubclasses "Answer the receiver's subclasses." self theNonMetaClass == nil ifTrue:[^#()]. ^self theNonMetaClass obsoleteSubclasses select:[:aSubclass| aSubclass isMeta not] thenCollect:[:aSubclass| aSubclass class] "Metaclass allInstancesDo: [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! ! !ClassTrait methodsFor: 'fileIn/Out' stamp: ''! fileOutInitializerOn: aStream (self includesSelector: #initialize) ifTrue: [aStream cr. aStream nextChunkPut: self soleInstance name , ' initialize'].! ! !ClassTrait methodsFor: 'initialize-release' stamp: 'SebastianTleye 7/12/2013 17:23'! instanceVariableNames: instVarString "Compatibility purposes"! ! !ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 4/20/2004 09:44'! classTrait: aClassTrait self error: 'Trait is already a class trait!!' ! ! !ClassTrait methodsFor: 'accessing instances and variables' stamp: ''! classVarNames "Answer a set of the names of the class variables defined in the receiver's instance." self theNonMetaClass ifNil: [ ^ Set new ]. ^self theNonMetaClass classVarNames! ! !ClassTrait methodsFor: 'composition' stamp: ''! noteNewBaseTraitCompositionApplied: aTraitComposition "The argument is the new trait composition of my base trait - add the new traits or remove non existing traits on my class side composition. (Each class trait in my composition has its base trait on the instance side of the composition - manually added traits to the class side are always base traits.)" | newComposition traitsFromInstanceSide | traitsFromInstanceSide := self traitComposition traits select: [:each | each isClassTrait] thenCollect: [:each | each baseTrait]. newComposition := self traitComposition copyTraitExpression. (traitsFromInstanceSide copyWithoutAll: aTraitComposition traits) do: [:each | newComposition removeFromComposition: each classTrait]. (aTraitComposition traits copyWithoutAll: traitsFromInstanceSide) do: [:each | newComposition add: (each classTrait)]. self setTraitComposition: newComposition! ! !ClassTrait methodsFor: 'accessing hierarchy protocol' stamp: ''! hasClassSide ^false! ! !ClassTrait methodsFor: 'class hierarchy' stamp: ''! subclassesDo: aBlock "Evaluate aBlock for each of the receiver's immediate subclasses." self theNonMetaClass subclassesDo:[:aSubclass| "The following test is for Class class which has to exclude the Metaclasses being subclasses of Class." aSubclass isMeta ifFalse:[aBlock value: aSubclass class]].! ! !ClassTrait methodsFor: 'fileIn/Out' stamp: 'MarcusDenker 2/14/2010 22:18'! definition ^String streamContents: [:stream | stream nextPutAll: self name; crtab; nextPutAll: 'uses: '; nextPutAll: self traitCompositionString]! ! !ClassTrait methodsFor: 'fileIn/Out' stamp: ''! nonTrivial "Answer whether the receiver has any methods or instance variables." ^ self instVarNames notEmpty or: [self hasMethods or: [self hasTraitComposition]]! ! !ClassTrait methodsFor: 'testing' stamp: ''! isMeta ^ true! ! !ClassTrait methodsFor: 'copying' stamp: 'dvf 8/30/2005 16:51'! copy "Make a copy of the receiver. Share the reference to the base trait." ^(self class new) baseTrait: self baseTrait; initializeFrom: self; yourself! ! !ClassTrait methodsFor: 'compiling' stamp: ''! possibleVariablesFor: misspelled continuedFrom: oldResults ^ self theNonMetaClass possibleVariablesFor: misspelled continuedFrom: oldResults ! ! !ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:48'! isClassTrait ^true! ! !ClassTrait methodsFor: 'compiling' stamp: 'CamilloBruni 5/30/2012 12:41'! compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource | classSideUsersOfBaseTrait message | classSideUsersOfBaseTrait := self baseTrait users select: [:each | each isClassSide]. classSideUsersOfBaseTrait isEmpty ifFalse: [ message := String streamContents: [ :stream | stream nextPutAll: 'The instance side of this trait is used on '; cr. classSideUsersOfBaseTrait do: [:each | stream nextPutAll: each name ] separatedBy: [ stream nextPutAll: ', ' ]. stream cr; nextPutAll: ' You can not add methods to the class side of this trait!!']. ^ TraitException signal: message ]. ^ super compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource! ! !ClassTrait methodsFor: 'testing' stamp: ''! canZapMethodDictionary "Return true if it is safe to zap the method dictionary on #obsolete" self soleInstance == nil ifTrue:[^true] ifFalse:[^self soleInstance canZapMethodDictionary]! ! !ClassTrait methodsFor: 'pool variables' stamp: ''! classPool "Answer the dictionary of class variables." ^self theNonMetaClass classPool! ! !ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:48'! isBaseTrait ^false! ! !ClassTrait methodsFor: 'compiling' stamp: ''! wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself." ^ self theNonMetaClass wantsChangeSetLogging! ! !ClassTrait methodsFor: 'instance creation' stamp: 'SebastianTleye 7/17/2013 14:39'! new self error: 'Traits have no instances'! ! !ClassTrait methodsFor: 'compiling' stamp: ''! wantsRecompilationProgressReported "The metaclass follows the rule of the class itself." ^ self theNonMetaClass wantsRecompilationProgressReported! ! !ClassTrait methodsFor: 'testing' stamp: ''! isSelfEvaluating ^self isObsolete not! ! !ClassTrait methodsFor: 'class hierarchy' stamp: ''! subclasses "Answer the receiver's subclasses." self theNonMetaClass == nil ifTrue:[^#()]. ^self theNonMetaClass subclasses select:[:aSubclass| aSubclass isMeta not] thenCollect:[:aSubclass| aSubclass class] "Metaclass allInstancesDo: [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! ! !ClassTrait class methodsFor: 'instance creation' stamp: 'al 3/23/2004 19:41'! for: aTrait ^self new initializeWithBaseTrait: aTrait; yourself! ! !ClassTraitTest methodsFor: 'testing' stamp: 'SebastianTleye 7/12/2013 16:18'! testInitialization "self run: #testInitialization" | classTrait | classTrait := self t1 classTrait. self assert: self t1 hasClassSide. self assert: self t1 classTrait == classTrait. self assert: classTrait isClassTrait. self assert: classTrait classSide == classTrait. self deny: classTrait isBaseTrait. self assert: classTrait baseTrait == self t1. "assert classtrait methods are propagated to users when setting traitComposition" self assert: self t4 hasClassSide. self assert: self t5 hasClassSide. self assert: (self t2 classSide includesLocalSelector: #m2ClassSide:). self assert: (self t4 classSide includesSelector: #m2ClassSide:). self assert: (self t5 classSide includesSelector: #m2ClassSide:). self assert: (self c2 m2ClassSide: 17) = 17! ! !ClassTraitTest methodsFor: 'testing' stamp: 'CamilloBruni 4/27/2012 17:51'! testUsers self assert: self t2 classSide users size = 3. self assert: (self t2 classSide users includesAllOf: { (self t4 classTrait). (self t5 classTrait). (self t6 classTrait) }). self assert: self t5 classSide users size = 1. self assert: self t5 classSide users anyOne = self c2 class. self c2 setTraitCompositionFrom: self t1 + self t5. self assert: self t5 classSide users size = 1. self assert: self t5 classSide users anyOne = self c2 class. self c2 setTraitComposition: self t2 asTraitComposition. self assert: self t5 classSide users isEmpty! ! !ClassTraitTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testChanges "Test the most important features to ensure that general functionality of class traits are working." "self run: #testChanges" | classTrait | classTrait := self t1 classTrait. self deny: (self t5 classSide includesSelector: #m1ClassSide). classTrait compile: 'm1ClassSide ^17' classified: 'mycategory'. "local selectors" self assert: (classTrait includesLocalSelector: #m1ClassSide). self deny: (classTrait includesLocalSelector: #otherSelector). "propagation" self assert: (self t5 classSide methodDict includesKey: #m1ClassSide). self assert: (self c2 class methodDict includesKey: #m1ClassSide). self c2 m1ClassSide. self assert: self c2 m1ClassSide equals: 17. "category" self assert: (self c2 class organization categoryOfElement: #m1ClassSide) equals: 'mycategory'. "conflicts" self t2 classSide compile: 'm1ClassSide' classified: 'mycategory'. self assert: (self c2 class methodDict includesKey: #m1ClassSide). self deny: (self c2 class includesLocalSelector: #m1ClassSide). self should: [ self c2 m1ClassSide ] raise: Error. "conflict category" self assert: (self c2 class organization categoryOfElement: #m1ClassSide) equals: #mycategory! ! !ClassTraitTest methodsFor: 'testing' stamp: 'ST 6/5/2013 17:16'! testConflictsAliasesAndExclusions "conflict" self t1 classTrait compile: 'm2ClassSide: x ^99' classified: 'mycategory'. self assert: (self t1 classTrait includesLocalSelector: #m2ClassSide:). self assert: (self t5 classTrait >> #m2ClassSide:) isConflict. self assert: (self c2 class >> #m2ClassSide:) isConflict. "exclusion and alias" self assert: self t5 classSide traitComposition asString = 'T1 classTrait + T2 classTrait'. self t5 classSide setTraitCompositionFrom: (self t1 classTrait @ { (#m2ClassSideAlias1: -> #m2ClassSide:) } + ((self t2 classTrait) @ { (#m2ClassSideAlias2: -> #m2ClassSide:) } - { #m2ClassSide: })). self deny: (self t5 classTrait >> #m2ClassSide:) isConflict. self deny: (self c2 class >> #m2ClassSide:) isConflict. self assert: (self c2 m2ClassSideAlias1: 13) = 99. self assert: (self c2 m2ClassSideAlias2: 13) = 13! ! !ClassTreeExample commentStamp: 'AlainPlantec 1/18/2010 16:20'! ClassTreeExample new openOn: Object ! !ClassTreeExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/7/2010 22:44'! rootNodeClassFromItem: anItem ^ ClassTreeNodeExample! ! !ClassTreeExample methodsFor: 'user interface' stamp: 'AlainPlantec 10/18/2013 10:38'! treeMorph | treeMorph | treeMorph := (MorphTreeMorph on: self) beMultiple; columns: { MorphTreeColumn new startWidth: 300; rowMorphGetSelector: #classButton; headerButtonLabel: 'Class' font: nil. MorphTreeColumn new startWidth: 500; rowMorphGetSelector: #commentText; headerButtonLabel: 'Comment' font: nil }; rowInset: 4; treeLineWidth: 1; columnInset: 4; getMenuSelector: #menu:shifted:; rowColorForEven: Color lightGray muchLighter. ^ treeMorph buildContents! ! !ClassTreeExample methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/19/2012 16:13'! openOn: aClass | window | self rootClass: aClass. window := StandardWindow new model: self. window title: aClass name, ' hierarchy'. window addMorph: self treeMorph fullFrame: LayoutFrame identity. window themeChanged. window openInWorld. ^ window! ! !ClassTreeExample methodsFor: 'instance creation' stamp: 'AlainPlantec 1/16/2010 09:50'! open ^ self openOn: Object ! ! !ClassTreeExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/25/2011 17:04'! keyStroke: anEvent from: aTreeMorph self selectedNode ifNotNil: [:current | current keyStroke: anEvent from: aTreeMorph]! ! !ClassTreeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:50'! rootClass: aClass rootClass := aClass! ! !ClassTreeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:50'! rootClass ^ rootClass ifNil: [rootClass := Object]! ! !ClassTreeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/15/2010 13:53'! rootItems ^ OrderedCollection with: self rootClass! ! !ClassTreeExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 08:38'! menu: menu shifted: b "Set up the menu to apply to the receiver's, honoring the #shifted boolean" super menu: menu shifted: b. menu addLine. self selectedNode ifNotNil: [:current | current menu: menu shifted: b. menu addLine. menu add: 'Expand all from here' translated target: self selector: #expandAllFromNode: argument: current]. ^ menu! ! !ClassTreeNodeExample commentStamp: 'TorstenBergmann 2/3/2014 23:56'! Example for class tree nodes! !ClassTreeNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:51'! menu: menu shifted: b menu add: 'Browse (b)' translated target: self selector: #browseItem. menu add: 'Inspect (i)' translated target: self selector: #inspectItem. menu add: 'Explore (I)' translated target: self selector: #exploreItem. ! ! !ClassTreeNodeExample methodsFor: 'menu' stamp: 'FernandoOlivero 4/12/2011 09:41'! commentText ^ ( self theme newTextIn: World text: self item comment) unlock; wrapFlag: true; yourself! ! !ClassTreeNodeExample methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2011 20:54'! browseItem Smalltalk tools browser fullOnClass: self item selector: nil ! ! !ClassTreeNodeExample methodsFor: 'menu' stamp: 'AlainPlantec 1/15/2010 13:44'! childrenItems ^ (self item subclasses asArray sort: [:a :b | a name < b name]) asOrderedCollection ! ! !ClassTreeNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:51'! inspectItem self inspect! ! !ClassTreeNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/25/2011 17:05'! keyStroke: anEvent from: aTreeMorph | c | c := anEvent keyCharacter. c = $b ifTrue: [self browseItem. ^ true]. c = $i ifTrue: [self inspectItem. ^ true]. c = $I ifTrue: [self exploreItem. ^ true]. ^ false ! ! !ClassTreeNodeExample methodsFor: 'menu' stamp: 'FernandoOlivero 4/12/2011 10:10'! classButton ^ ( self theme newButtonIn: World for: self getState: nil action: #browseItem arguments: {} getEnabled: #enabled getLabel: nil help: 'Open a browser on ' translated , self item name) label: (self theme windowLabelForText: (self item name) , '...'); yourself! ! !ClassTreeNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:51'! exploreItem self explore! ! !ClassTreeNodeExample methodsFor: 'menu' stamp: 'AlainPlantec 1/15/2010 13:43'! contents ^ contents ifNil: [contents := super contents]! ! !ClassTreeNodeExample methodsFor: 'menu' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon ^ Smalltalk ui icons smallExpertIcon! ! !Clipboard commentStamp: 'AlainPlantec 1/15/2010 11:42'! The Clipboard class is the abstract superclass for the concrete platform specific clipboard. The legacy clipboard support using the VM supplied primitives is implemented by Clipboard/ExternalClipboard. The Clipboard implements a basic buffering scheme for text. The currently selected text is also exported to the OS so that text can be copied from and to other applications. Commonly only a single instance is used (the default clipboard) but applications are free to use other than the default clipboard if necessary.! !Clipboard methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:47'! initialize super initialize. contents := '' asText. recent := OrderedCollection new! ! !Clipboard methodsFor: 'accessing' stamp: 'StephaneDucasse 1/29/2010 21:42'! chooseRecentClipping "Choose by menu from among the recent clippings" "Clipboard chooseRecentClipping" recent ifNil: [^ nil]. ^ UIManager default chooseFrom: (recent collect: [:txt | ((txt asString contractTo: 50) copyReplaceAll: Character cr asString with: '\') copyReplaceAll: Character tab asString with: '|']) values: recent! ! !Clipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/25/2009 14:23'! primitiveClipboardText "Get the current clipboard text. Return the empty string if the primitive fails." ^ ''! ! !Clipboard methodsFor: 'private' stamp: 'ar 1/15/2001 18:34'! noteRecentClipping: text "Keep most recent clippings in a queue for pasteRecent (paste... command)" text isEmpty ifTrue: [^ self]. text size > 50000 ifTrue: [^ self]. (recent includes: text) ifTrue: [^ self]. recent addFirst: text. [recent size > 5] whileTrue: [recent removeLast]. ! ! !Clipboard methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 1/28/2011 15:19'! clipboardText: text | string | string := text asString. self noteRecentClipping: text asText. contents := text asText. string := string convertToWithConverter: UTF8TextConverter new. self primitiveClipboardText: string.! ! !Clipboard methodsFor: 'accessing' stamp: 'michael.rueger 6/10/2009 13:42'! clipboardText "Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard." | string decodedString | string := self primitiveClipboardText. (string isEmpty or: [string = contents asString]) ifTrue: [^ contents]. decodedString := string convertFromWithConverter: UTF8TextConverter new. decodedString := decodedString replaceAll: 10 asCharacter with: 13 asCharacter. ^ decodedString = contents asString ifTrue: [contents] ifFalse: [decodedString asText]. ! ! !Clipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/25/2009 14:23'! primitiveClipboardText: aString "Set the current clipboard text to the given string." "don't fail if the primitive is not implemented"! ! !Clipboard class methodsFor: 'initialization' stamp: 'michael.rueger 3/2/2009 11:11'! initialize "Clipboard initialize" Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self. self startUp: true.! ! !Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:45'! chooseRecentClipping "Clipboard chooseRecentClipping" "Choose by menu from among the recent clippings" ^self default chooseRecentClipping! ! !Clipboard class methodsFor: 'accessing' stamp: 'cami 7/22/2013 18:26'! default ^Default ifNil: [Default := Smalltalk os clipboardClass new].! ! !Clipboard class methodsFor: 'initialization' stamp: 'VeronicaUquillas 6/11/2010 13:53'! shutDown: quitting "Pharo is shutting down. If this platform requires specific shutdown code, this is a great place to put it." ! ! !Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:35'! clipboardText: aText ^self default clipboardText: aText! ! !Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:35'! clipboardText "Clipboard clipboardText" ^self default clipboardText.! ! !Clipboard class methodsFor: 'initialization' stamp: 'VeronicaUquillas 6/11/2010 13:53'! startUp: resuming "Pharo is starting up. If this platform requires specific intialization, this is a great place to put it." resuming ifTrue: [Default := nil]! ! !ClippingCanvas commentStamp: ''! A modified canvas which clips all drawing commands.! !ClippingCanvas methodsFor: 'accessing' stamp: 'StephaneDucasse 2/10/2011 11:02'! contentsOfArea: aRectangle into: aForm self flag: #hack. "ignore the clipping specification for this command. This is purely so that CachingCanvas will work properly when clipped. There *has* to be a clean way to do this...." ^canvas contentsOfArea: aRectangle into: aForm! ! !ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:17'! form ^canvas form! ! !ClippingCanvas methodsFor: 'testing' stamp: 'ls 3/20/2000 21:17'! isBalloonCanvas ^canvas isBalloonCanvas! ! !ClippingCanvas methodsFor: 'testing' stamp: 'ls 3/20/2000 21:18'! isShadowDrawing ^canvas isShadowDrawing! ! !ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:15'! shadowColor ^canvas shadowColor! ! !ClippingCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 20:44'! apply: aBlock "apply the given block to the inner canvas with clipRect as the clipping rectangle" canvas clipBy: clipRect during: aBlock! ! !ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/25/2000 22:56'! clipRect ^clipRect! ! !ClippingCanvas methodsFor: 'initialization' stamp: 'ls 3/20/2000 20:44'! canvas: aCanvas clipRect: aRectangle canvas := aCanvas. clipRect := aRectangle.! ! !ClippingCanvas class methodsFor: 'instance creation' stamp: 'ls 3/20/2000 20:45'! canvas: aCanvas clipRect: aRectangle ^self new canvas: aCanvas clipRect: aRectangle! ! !ClosureCompilerTest commentStamp: 'TorstenBergmann 1/31/2014 11:23'! SUnit tests for the closure compiler! !ClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 8/20/2011 13:41'! testDebuggerTempAccess self doTestDebuggerTempAccessWith: 1 with: 2! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 15:20'! testSourceRangeAccessForClosureLongFormBytecodeInjectInto "Test debugger source range selection for inject:into: for a version compiled with closures" "self new testSourceRangeAccessForClosureLongFormBytecodeInjectInto" | source method | source := (Collection sourceCodeAt: #inject:into:) asString. method := (Parser new encoderClass: EncoderForLongFormV3PlusClosures; parse: source class: Collection) generate: (Collection compiledMethodAt: #inject:into:) trailer. self supportTestSourceRangeAccessForInjectInto: method source: source! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/9/2013 11:26'! testBlockNumbering "Test that the compiler and CompiledMethod agree on the block numbering of a substantial doit." "self new testBlockNumbering" | methodNode method tempRefs | methodNode := Parser new encoderClass: EncoderForV3PlusClosures; parse: 'foo | numCopiedValuesCounts classToRemove | numCopiedValuesCounts := Dictionary new. 0 to: 32 do: [:i| numCopiedValuesCounts at: i put: 0]. Transcript clear. Smalltalk allClasses remove: classToRemove; do: [:c| {c. c class} do: [:b| Transcript nextPut: b name first; endEntry. b selectorsAndMethodsDo: [:s :m| | pn | m isQuick not ifTrue: [pn := b parserClass new encoderClass: EncoderForV3PlusClosures; parse: (b sourceCodeAt: s) class: b. pn generate. [pn accept: nil] on: MessageNotUnderstood do: [:ex| | msg numCopied | msg := ex message. (msg selector == #visitBlockNode: and: [(msg argument instVarNamed: ''optimized'') not]) ifTrue: [numCopied := (msg argument computeCopiedValues: pn) size. numCopiedValuesCounts at: numCopied put: (numCopiedValuesCounts at: numCopied) + 1]. msg setSelector: #==. ex resume: nil]]]]]. numCopiedValuesCounts' class: Object. method := methodNode generate. tempRefs := methodNode encoder blockExtentsToTempsMap. self assert: tempRefs keys asSet = (method debuggerMap startpcsToBlockExtents: method) values asSet! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/18/2013 15:44'! supportTestSourceRangeAccessForInjectInto: method source: source selectionSequence: selections "Test debugger source range selection for inject:into:" | evaluationCount sourceMap debugTokenSequence debugCount | evaluationCount := 0. sourceMap := method debuggerMap abstractSourceMap. debugTokenSequence := selections collect: [:string| string parseLiterals]. debugCount := 0. thisContext runSimulated: [(1 to: 2) withArgs: { 0. [:sum :each| evaluationCount := evaluationCount + 1. sum + each]} executeMethod: method] contextAtEachStep: [:ctxt| | range debugTokens | (ctxt method == method and: ["Exclude the send of #closureCopy:copiedValues: and braceWith:with: to create the block, and the #new: and #at:'s for the indirect temp vector. This for compilation without closure bytecodes. (Note that at:put:'s correspond to stores)" (ctxt willSend and: [(#(closureCopy:copiedValues: new: at: braceWith:with:) includes: ctxt selectorToSendOrSelf) not]) "Exclude the store of the argument into the home context (for BlueBook blocks) and the store of an indirection vector into an initial temp" or: [(ctxt willStore and: [(ctxt isBlock and: [ctxt pc = ctxt startpc]) not and: [(ctxt isBlock not and: [((self abstractPCForContext: ctxt) = 2)]) not]]) or: [ctxt willReturn]]]) ifTrue: [debugTokens := debugTokenSequence at: (debugCount := debugCount + 1) ifAbsent: [#(bogusToken)]. self assert: (sourceMap includesKey: (self abstractPCForContext: ctxt)). range := sourceMap at: (self abstractPCForContext: ctxt) ifAbsent: [(1 to: 0)]. self assert: (source copyFrom: range first to: range last) parseLiterals = debugTokens]]. self assert: evaluationCount = 2! ! !ClosureCompilerTest methodsFor: 'running' stamp: 'MarcusDenker 5/20/2013 13:08'! tearDown SmalltalkImage compilerClass: currentCompiler.! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 3/9/2009 11:00'! testInlineBlockCollectionLR3 | col | col := OrderedCollection new. 1 to: 11 do: [ :each | | i | i := each. col add: [ i ]. i := i + 1 ]. self assert: (col collect: [ :each | each value ]) asArray = (2 to: 12) asArray! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 7/22/2009 16:55'! testInlineBlockCollectionSD1 | a1 b1 a2 b2 | b1 := OrderedCollection new. 1 to: 3 do: [:i | a1 := i. b1 add: [a1]]. b1 := b1 asArray collect: [:b | b value]. b2 := OrderedCollection new. 1 to: 3 do: [:i | a2 := i. b2 add: [a2]] yourself. "defeat optimization" b2 := b2 asArray collect: [:b | b value]. self assert: b1 = b2! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 11:40'! testSourceRangeAccessForInjectInto "Test debugger source range selection for inject:into: for the current version of the method" "self new testSourceRangeAccessForInjectInto" self supportTestSourceRangeAccessForInjectInto: (Collection compiledMethodAt: #inject:into:) source: (Collection sourceCodeAt: #inject:into:) asString! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 3/7/2009 11:25'! testInlineBlockCollectionLR1 "Test case from Lukas Renggli" | col | col := OrderedCollection new. 1 to: 11 do: [ :each | col add: [ each ] ]. self assert: (col collect: [ :each | each value ]) asArray = (1 to: 11) asArray! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 3/7/2009 11:39'! testInlineBlockCollectionLR2 "Test case from Lukas Renggli" | col | col := OrderedCollection new. 1 to: 11 do: [ :each | #(1) do: [:ignored| col add: [ each ]] ]. self assert: (col collect: [ :each | each value ]) asArray = (1 to: 11) asArray! ! !ClosureCompilerTest methodsFor: 'running' stamp: 'MarcusDenker 5/20/2013 13:08'! setUp currentCompiler := SmalltalkImage compilerClass. SmalltalkImage compilerClass: Compiler.! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/2/2013 11:25'! doTestDebuggerTempAccessWith: one with: two "Test debugger access for temps" | outerContext local1 remote1 | outerContext := thisContext. local1 := 3. remote1 := 1/2. self assert: (self class compiler evaluate: 'one' in: thisContext to: self) == one. self assert: (self class compiler evaluate: 'two' in: thisContext to: self) == two. self assert: (self class compiler evaluate: 'local1' in: thisContext to: self) == local1. self assert: (self class compiler evaluate: 'remote1' in: thisContext to: self) == remote1. self class compiler evaluate: 'local1 := -3.0' in: thisContext to: self. self assert: local1 = -3.0. (1 to: 2) do: [:i| | local2 r1 r2 r3 r4 | local2 := i * 3. remote1 := local2 / 7. self assert: thisContext ~~ outerContext. self assert: (r1 := self class compiler evaluate: 'one' in: thisContext to: self) == one. self assert: (r2 := self new evaluate: 'two' in: thisContext to: self) == two. self assert: (r3 := self class compiler evaluate: 'i' in: thisContext to: self) == i. self assert: (r4 := self class compiler evaluate: 'local2' in: thisContext to: self) == local2. self assert: (r4 := self class compiler evaluate: 'remote1' in: thisContext to: self) == remote1. self assert: (r4 := self class compiler evaluate: 'remote1' in: outerContext to: self) == remote1. self class compiler evaluate: 'local2 := 15' in: thisContext to: self. self assert: local2 = 15. self class compiler evaluate: 'local1 := 25' in: thisContext to: self. self assert: local1 = 25. { r1. r2. r3. r4 } "placate the compiler"]. self assert: local1 = 25. self assert: remote1 = (6/7)! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 10/9/2012 18:05'! testTempNameAccessForInjectInto "self new testTempNameAccessForInjectInto" | methodNode method evaluationCount block debuggerMap | methodNode := Parser new encoderClass: EncoderForV3PlusClosures; parse: (Collection sourceCodeAt: #inject:into:) class: Collection. method := methodNode generate. debuggerMap := DebuggerMethodMap new forMethod: method methodNode: methodNode. evaluationCount := 0. block := [:prev :each| | theContext tempNames | evaluationCount := evaluationCount + 1. theContext := thisContext sender. tempNames := debuggerMap tempNamesForContext: theContext. self assert: (tempNames hasEqualElements: tempNames). #('thisValue' 'each' 'binaryBlock' 'nextValue') with: { 0. each. block. prev} do: [:tempName :value| self assert: (debuggerMap namedTempAt: (tempNames indexOf: tempName) in: theContext) == value. tempName ~= 'each' ifTrue: [self assert: (debuggerMap namedTempAt: (tempNames indexOf: tempName) in: theContext home) == value]]]. (1 to: 10) withArgs: { 0. block } executeMethod: method. self assert: evaluationCount = 10! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 9/5/2009 17:32'! testOptimizedBlockLocalNilling2 "Whether a block is optimized or not a block-local temp should be nil at the start of each evaluation of the block." 1 to: 6 do: [:i| | j k | self assert: j isNil. self assert: k isNil. i even ifTrue: [j := i + 2] ifFalse: [k := i + 1]. self assert: (j isNil or: [k isNil]). self assert: (j isNil not or: [k isNil not])]! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 7/24/2009 11:51'! testInlineBlockCollectionEM1 | a1 b1 i1 a2 b2 i2 we wb | b1 := OrderedCollection new. i1 := 1. [a1 := i1. i1 <= 3] whileTrue: [b1 add: [a1]. i1 := i1 + 1]. b1 := b1 asArray collect: [:b | b value]. b2 := OrderedCollection new. i2 := 1. we := [a2 := i2. i2 <= 3]. wb := [b2 add: [a2]. i2 := i2 + 1]. we whileTrue: wb. "defeat optimization" b2 := b2 asArray collect: [:b | b value]. self assert: b1 = b2! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 19:44'! supportTestSourceRangeAccessForDecompiledNoBytecodeInjectInto: method source: source "Test debugger source range selection for inject:into:" ^self supportTestSourceRangeAccessForInjectInto: method source: source selectionSequence: #( 'at: 1 put: t1' 'do: [:t4 | t3 at: 1 put: (t2 value: (t3 at: 1) value: t4)]' 'value: (t3 at: 1) value: t4' 'at: 1 put: (t2 value: (t3 at: 1) value: t4)' ']' 'value: (t3 at: 1) value: t4' 'at: 1 put: (t2 value: (t3 at: 1) value: t4)' ']' '^t3 at: 1')! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 9/5/2009 17:33'! testOptimizedBlockLocalNilling1 "Whether a block is optimized or not a block-local temp should be nil at the start of each evaluation of the block." 1 to: 3 do: [:i| | j | self assert: j isNil. j := i + 1. self assert: j isNil not]! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 10/16/2013 10:36'! testBlockNumberingForInjectInto "Test that the compiler and CompiledMethod agree on the block numbering of Collection>>inject:into: and that temp names for inject:into: are recorded." "self new testBlockNumberingForInjectInto" | methodNode method tempRefs | methodNode := Parser new encoderClass: EncoderForV3PlusClosures; parse: (Collection sourceCodeAt: #inject:into:) class: Collection. method := methodNode generateWithSource. tempRefs := methodNode encoder blockExtentsToTempsMap. self assert: tempRefs keys asSet = (method debuggerMap startpcsToBlockExtents: method) values asSet. self assert: ((tempRefs includesKey: (0 to: 6)) and: [((tempRefs at: (0 to: 6)) collect: [:e | e first]) hasEqualElements: {'thisValue'. 'binaryBlock'. 'nextValue'}]). self assert: ((tempRefs includesKey: (2 to: 4)) and: [((tempRefs at: (2 to: 4)) collect: [:e | e first]) hasEqualElements: {'each'. 'binaryBlock'. 'nextValue'}])! ! !ClosureCompilerTest methodsFor: 'source' stamp: 'MarcusDenke 4/29/2012 20:40'! closureCases ^#( '| n | n := 1. ^n + n' '[:c :s| | mn | mn := Compiler new compile: (c sourceCodeAt: s) in: c notifying: nil ifFail: [self halt]. mn generate: #(0 0 0 0). {mn blockExtentsToTempsMap. mn encoder schematicTempNames}] value: AbstractInstructionTests value: #runBinaryConditionalJumps:' 'inject: thisValue into: binaryBlock | nextValue | nextValue := thisValue. self do: [:each | nextValue := binaryBlock value: nextValue value: each]. ^nextValue' 'mapFromBlockStartsIn: aMethod toTempVarsFrom: schematicTempNamesString constructor: aDecompilerConstructor | map | map := aMethod mapFromBlockKeys: aMethod startpcsToBlockExtents keys asSortedCollection toSchematicTemps: schematicTempNamesString. map keysAndValuesDo: [:startpc :tempNameTupleVector| | subMap tempVector numTemps | subMap := Dictionary new. tempNameTupleVector do: [:tuple| tuple last isArray ifTrue: [subMap at: tuple last first put: tuple last last. numTemps := tuple last first] ifFalse: [numTemps := tuple last]]. tempVector := Array new: numTemps. subMap keysAndValuesDo: [:index :size| tempVector at: index put: (Array new: size)]. tempNameTupleVector do: [:tuple| | itv | tuple last isArray ifTrue: [itv := tempVector at: tuple last first. itv at: tuple last last put: (aDecompilerConstructor codeTemp: tuple last last - 1 named: tuple first)] ifFalse: [tempVector at: tuple last put: (aDecompilerConstructor codeTemp: tuple last - 1 named: tuple first)]]. subMap keysAndValuesDo: [:index :size| tempVector at: index put: (aDecompilerConstructor codeRemoteTemp: index remoteTemps: (tempVector at: index))]. map at: startpc put: tempVector]. ^map' 'gnuifyFrom: inFileStream to: outFileStream | inData beforeInterpret inInterpret inInterpretVars beforePrimitiveResponse inPrimitiveResponse | inData := inFileStream upToEnd withSqueakLineEndings. inFileStream close. outFileStream nextPutAll: ''/* This file has been post-processed for GNU C */''; cr; cr; cr. beforeInterpret := true. "whether we are before the beginning of interpret()" inInterpret := false. "whether we are in the middle of interpret" inInterpretVars := false. "whether we are in the variables of interpret" beforePrimitiveResponse := true. "whether we are before the beginning of primitiveResponse()" inPrimitiveResponse := false. "whether we are inside of primitiveResponse" ''Gnuifying'' displayProgressAt: Sensor cursorPoint from: 1 to: (inData occurrencesOf: Character cr) during: [:bar | | lineNumber | lineNumber := 0. inData linesDo: [ :inLine | | outLine extraOutLine caseLabel | bar value: (lineNumber := lineNumber + 1). outLine := inLine. "print out one line for each input line; by default, print out the line that was input, but some rules modify it" extraOutLine := nil. "occasionally print a second output line..." beforeInterpret ifTrue: [ inLine = ''#include "sq.h"'' ifTrue: [ outLine := ''#include "sqGnu.h"'' ]. inLine = ''interpret(void) {'' ifTrue: [ "reached the beginning of interpret" beforeInterpret := false. inInterpret := true. inInterpretVars := true ] ] ifFalse: [ inInterpretVars ifTrue: [ (inLine findString: ''register struct foo * foo = &fum;'') > 0 ifTrue: [ outLine := ''register struct foo * foo FOO_REG = &fum;'' ]. (inLine findString: '' localIP;'') > 0 ifTrue: [ outLine := '' char* localIP IP_REG;'' ]. (inLine findString: '' localFP;'') > 0 ifTrue: [ outLine := '' char* localFP FP_REG;'' ]. (inLine findString: '' localSP;'') > 0 ifTrue: [ outLine := '' char* localSP SP_REG;'' ]. (inLine findString: '' currentBytecode;'') > 0 ifTrue: [ outLine := '' sqInt currentBytecode CB_REG;'' ]. inLine isEmpty ifTrue: [ "reached end of variables" inInterpretVars := false. outLine := '' JUMP_TABLE;''. extraOutLine := inLine ] ] ifFalse: [ inInterpret ifTrue: [ "working inside interpret(); translate the switch statement" (inLine beginsWith: '' case '') ifTrue: [ caseLabel := (inLine findTokens: '' :'') second. outLine := '' CASE('', caseLabel, '')'' ]. inLine = '' break;'' ifTrue: [ outLine := '' BREAK;'' ]. inLine = ''}'' ifTrue: [ "all finished with interpret()" inInterpret := false ] ] ifFalse: [ beforePrimitiveResponse ifTrue: [ (inLine beginsWith: ''primitiveResponse('') ifTrue: [ "into primitiveResponse we go" beforePrimitiveResponse := false. inPrimitiveResponse := true. extraOutLine := '' PRIM_TABLE;'' ] ] ifFalse: [ inPrimitiveResponse ifTrue: [ inLine = '' switch (primitiveIndex) {'' ifTrue: [ extraOutLine := outLine. outLine := '' PRIM_DISPATCH;'' ]. inLine = '' switch (GIV(primitiveIndex)) {'' ifTrue: [ extraOutLine := outLine. outLine := '' PRIM_DISPATCH;'' ]. (inLine beginsWith: '' case '') ifTrue: [ caseLabel := (inLine findTokens: '' :'') second. outLine := '' CASE('', caseLabel, '')'' ]. inLine = ''}'' ifTrue: [ inPrimitiveResponse := false ] ] ] ] ] ]. outFileStream nextPutAll: outLine; cr. extraOutLine ifNotNil: [ outFileStream nextPutAll: extraOutLine; cr ]]]. outFileStream close' )! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 16:58'! supportTestSourceRangeAccessForDecompiledInjectInto: method source: source "Test debugger source range selection for inject:into:" ^self supportTestSourceRangeAccessForInjectInto: method source: source selectionSequence: #( ':= t1' 'do: [:t4 | t3 := t2 value: t3 value: t4]' 'value: t3 value: t4' ':= t2 value: t3 value: t4' ']' 'value: t3 value: t4' ':= t2 value: t3 value: t4' ']' '^t3')! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'eem 6/4/2008 15:20'! testSourceRangeAccessForClosureBytecodeInjectInto "Test debugger source range selection for inject:into: for a version compiled with closures" "self new testSourceRangeAccessForClosureBytecodeInjectInto" | source method | source := (Collection sourceCodeAt: #inject:into:) asString. method := (Parser new encoderClass: EncoderForV3PlusClosures; parse: source class: Collection) generate: (Collection compiledMethodAt: #inject:into:) trailer. self supportTestSourceRangeAccessForInjectInto: method source: source! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'StephaneDucasse 3/15/2010 21:24'! supportTestSourceRangeAccessForInjectInto: method source: source "Test debugger source range selection for inject:into:" ^self supportTestSourceRangeAccessForInjectInto: method source: source selectionSequence: #( ':= thisValue' 'do: [:each | nextValue := binaryBlock value: nextValue value: each]' 'value: nextValue value: each' ':= binaryBlock value: nextValue value: each' 'nextValue := binaryBlock value: nextValue value: each' 'value: nextValue value: each' ':= binaryBlock value: nextValue value: each' 'nextValue := binaryBlock value: nextValue value: each' '^nextValue')! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/9/2013 23:56'! abstractPCForContext: aContext ^aContext debuggerMap abstractPCForConcretePC: aContext pc method: aContext method.! ! !ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/19/2008 20:10'! methodWithCopiedTemps | a b c r | a := 1. b := 2. c := 4. r := [a + b + c] value. b := nil. r "Parser new parse: (self class sourceCodeAt: #methodWithCopiedTemps) class: self class" "(Parser new encoderClass: EncoderForV3; parse: (self class sourceCodeAt: #methodWithCopiedTemps) class: self class) generateUsingClosures: #(0 0 0 0)"! ! !ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/20/2008 09:40'! methodWithCopiedAndAssignedTemps | blk "0w" a "0w" b "0w" c "0w" t "0w" r1 "0w" r2 "0w" | a := 1. "1w" b := 2. "1w" c := 4. "1w" t := 0. "1w" blk "5w" := ["2" t "3w" := t "3r" + a "3r" + b "3r" + c "3r" ] "4". r1 "5w" := blk "5r" value. b "5w" := -100. r2 "5w" := blk "5r" value. ^r1 "5r" -> r2 "5r" -> t "5r" "a: main(read(),write(0,1)), block(read(3),write()) => copy; no writes follow read b: main(read(),write(0,1,5)), block(read(3),write()) => remote; write follows contained read blk: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5 c: main(read(),write(0,1)), block(read(3),write()) => copy; no writes follow read r1: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5 r2: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5 t: main(read(5),write(0,1)), block(read(3),write(3)) => remote; read follows contained write" "(Parser new encoderClass: EncoderForV3; parse: (self class sourceCodeAt: #methodWithCopiedAndAssignedTemps) class: self class) generateUsingClosures: #(0 0 0 0)"! ! !ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/19/2008 14:24'! methodWithOptimizedBlocks | s c | s := self isNil ifTrue: [| a | a := 'isNil'. a] ifFalse: [| b | b := 'notNil'. b]. c := String new: s size. 1 to: s size do: [:i| c at: i put: (s at: i)]. ^c "Parser new parse: (self class sourceCodeAt: #methodWithOptimizedBlocks) class: self class"! ! !ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/19/2008 14:12'! methodWithVariousTemps | classes total totalLength | classes := self withAllSuperclasses. total := totalLength := 0. classes do: [:class| | className | className := class name. total := total + 1. totalLength := totalLength + className size]. ^total -> totalLength "Parser new parse: (self class sourceCodeAt: #methodWithVariousTemps) class: self class"! ! !ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/19/2008 14:24'! methodWithOptimizedBlocksA | s c | s := self isNil ifTrue: [| a | a := 'isNil'. a] ifFalse: [| a | a := 'notNil'. a]. c := String new: s size. 1 to: s size do: [:i| c at: i put: (s at: i)]. ^c "Parser new parse: (self class sourceCodeAt: #methodWithOptimizedBlocksA) class: self class"! ! !ClosureCompilerTest class methodsFor: 'code examples' stamp: 'eem 5/19/2008 20:45'! methodWithCopiedAndPostClosedOverAssignedTemps | blk a b c r1 r2 | a := 1. b := 2. c := 4. blk := [a + b + c]. r1 := blk value. b := nil. r2 := blk value. r1 -> r2 "(Parser new encoderClass: EncoderForV3; parse: (self class sourceCodeAt: #methodWithCopiedAndPostClosedOverAssignedTemps) class: self class) generateUsingClosures: #(0 0 0 0)"! ! !ClosureTests commentStamp: 'TorstenBergmann 1/31/2014 11:23'! SUnit tests for closures! !ClosureTests methodsFor: 'testing-empty' stamp: 'MarcusDenker 5/2/2013 11:25'! testEmptyBlockTwoArguments self assert: (self class compiler evaluate: '[ :a :b ] value: 1 value: 2') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class compiler evaluate: '[ :a :b | ] value: 1 value: 2') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class compiler evaluate: '[ :a :b | | t | ] value: 1 value: 2') isNil description: 'Empty blocks in ST-80 should return nil'! ! !ClosureTests methodsFor: 'testing-while' stamp: 'StephaneDucasse 7/3/2010 22:21'! testWhileWithTempIsNil "self debug: #testWhileWithTempIsNil" | index | index := 0. [ index < 5 ] whileTrue: [ | temp | collection add: temp. temp := index := index + 1. collection add: temp]. self assertValues: #(nil 1 nil 2 nil 3 nil 4 nil 5)! ! !ClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:36'! testMethodTemp | block1 block2 | block1 := self methodArgument: 1. block2 := self methodArgument: 2. self assert: block1 value = 1. self assert: block2 value = 2! ! !ClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:33'! testBlockTemp | block block1 block2 | block := [ :arg | [ arg ] ]. block1 := block value: 1. block2 := block value: 2. self assert: block1 value = 1. self assert: block2 value = 2! ! !ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! testWhileModificationAfter | index | index := 0. [ index < 5 ] whileTrue: [ collection add: [ index ]. index := index + 1 ]. self assertValues: #(5 5 5 5 5)! ! !ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoOutsideTempNotInlined | block temp | block := [ :index | temp := index. collection add: [ temp ] ]. 1 to: 5 do: block. self assertValues: #(5 5 5 5 5)! ! !ClosureTests methodsFor: 'utilities' stamp: 'StefanMarr 3/16/2012 01:36'! assertValues: anArray | values | values := collection collect: [ :each | each value ]. self assert: anArray asArray = values asArray description: ['Expected: ' , anArray asArray printString , ', but got ' , values asArray printString]! ! !ClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:35'! methodArgument: anObject ^ [ anObject ] ! ! !ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoOutsideTemp | temp | 1 to: 5 do: [ :index | temp := index. collection add: [ temp ] ]. self assertValues: #(5 5 5 5 5)! ! !ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! testWhileModificationAfterNotInlined | index block | index := 0. block := [ collection add: [ index ]. index := index + 1 ]. [ index < 5 ] whileTrue: block. self assertValues: #(5 5 5 5 5)! ! !ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! testWhileModificationBefore | index | index := 0. [ index < 5 ] whileTrue: [ index := index + 1. collection add: [ index ] ]. self assertValues: #(5 5 5 5 5)! ! !ClosureTests methodsFor: 'running' stamp: 'lr 3/9/2009 16:48'! setUp super setUp. collection := OrderedCollection new! ! !ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoInsideTempNotInlined | block | block := [ :index | | temp | temp := index. collection add: [ temp ] ]. 1 to: 5 do: block. self assertValues: #(1 2 3 4 5)! ! !ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! testWhileModificationBeforeNotInlined | index block | index := 0. block := [ index := index + 1. collection add: [ index ] ]. [ index < 5 ] whileTrue: block. self assertValues: #(5 5 5 5 5)! ! !ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:52'! testWhileWithTemp | index | index := 0. [ index < 5 ] whileTrue: [ | temp | temp := index := index + 1. collection add: [ temp ] ]. self assertValues: #(1 2 3 4 5)! ! !ClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:53'! testWhileWithTempNotInlined | index block | index := 0. block := [ | temp | temp := index := index + 1. collection add: [ temp ] ]. [ index < 5 ] whileTrue: block. self assertValues: #(1 2 3 4 5)! ! !ClosureTests methodsFor: 'testing' stamp: 'sd 6/8/2012 23:31'! testIsClean | local | local := #testIsClean. self assert: [] isClean. "closes over nothing at all" self assert: [:a :b| a < b] isClean. "accesses only arguments" self assert: [:a :b| | s | s := a + b. s even] isClean. "accesses only local variables" self deny: [^nil] isClean. "closes over home (^-return)" self deny: [self] isClean. "closes over the receiver" self deny: [collection] isClean. "closes over the receiver (to access the inst var collection)" self deny: [local] isClean. "closes over local variable of outer context"! ! !ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoArgumentNotInlined | block | block := [ :index | collection add: [ index ] ]. 1 to: 5 do: block. self assertValues: #(1 2 3 4 5)! ! !ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoArgument 1 to: 5 do: [ :index | collection add: [ index ] ]. self assertValues: #(1 2 3 4 5)! ! !ClosureTests methodsFor: 'testing-empty' stamp: 'MarcusDenker 5/2/2013 11:25'! testEmptyBlockOneArgument self assert: (self class compiler evaluate: '[ :a ] value: 1') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class compiler evaluate: '[ :a | ] value: 1') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class compiler evaluate: '[ :a | | t | ] value: 1') isNil description: 'Empty blocks in ST-80 should return nil'! ! !ClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:33'! testBlockArgument | block block1 block2 | block := [ :arg | | temp | temp := arg. [ temp ] ]. block1 := block value: 1. block2 := block value: 2. self assert: block1 value = 1. self assert: block2 value = 2! ! !ClosureTests methodsFor: 'testing-empty' stamp: 'MarcusDenker 5/2/2013 11:25'! testEmptyBlockZeroArguments self assert: (self class compiler evaluate: '[ ] value') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class compiler evaluate: '[ | t | ] value') isNil description: 'Empty blocks in ST-80 should return nil'! ! !ClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:36'! testMethodArgument | temp block | temp := 0. block := [ [ temp ] ]. temp := 1. block := block value. temp := 2. self assert: block value = 2! ! !ClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoInsideTemp 1 to: 5 do: [ :index | | temp | temp := index. collection add: [ temp ] ]. self assertValues: #(1 2 3 4 5)! ! !CodeAnnotationMorph commentStamp: 'LaurentLaffont 2/13/2011 16:46'! I display code annotations that can be embedded in a browser (basic core image browser) to show useful informations about the current method or class. In order to show me in your browser, the "show annotation pane" setting must be set to true (search for 'annotation' in the setting browser). This setting is set to false by default. The informations to show are given by CodeHolder>>annotation. A methods annotation is built according to a list of requests which consists in a list of symbols. These symbols are interpreted by CodeHolder>>#annotationForSelector: ofClass:. See CodeHolder class >>#annotationRequests for more details about this list of requests. By default, the author, the time stamp, the message category, the senders and implementors count and the list of change sets in which the method is referenced are shown. Because the building of an annotation can be very time consuming (especially the implementors count),an annotation is built in background. So, I am also a good example of how a process can be used in order to build some data in background. Instance Variables codeHolder: process: codeHolder - The CodeHolder (a Browser, a MessageList ..) in which I'm embedded process - The process which is building the annotation in background COTDC - A.Plantec! !CodeAnnotationMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/14/2009 00:03'! initialize super initialize. self borderWidth: 0. self contents: ''. ! ! !CodeAnnotationMorph methodsFor: 'updating' stamp: 'Igor.Stasenko 10/12/2010 23:29'! update: anAspect super update: anAspect. anAspect == #contents ifFalse: [ ^self ]. self syncContents. ! ! !CodeAnnotationMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/13/2009 23:42'! codeHolder: aCodeHolder codeHolder := aCodeHolder. aCodeHolder ifNotNil: [aCodeHolder addDependent: self]! ! !CodeAnnotationMorph methodsFor: 'updating' stamp: 'AlainPlantec 7/9/2013 12:35'! syncContents | ch | process ifNotNil: [ process terminate ]. process := nil. ch := codeHolder ifNil: [ ^ self contents: '' ]. process := [ | ann | ann := ch annotation ifNil: ['']. self defer: [ self contents: ann ]. ] newProcess. process priority: Processor userBackgroundPriority. process resume. ! ! !CodeAnnotationMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 11/13/2009 23:34'! on: aCodeHolder ^ self new codeHolder: aCodeHolder! ! !CodeCriticBrowser commentStamp: ''! A CodeCriticBrowser is a UI made to browse code critics refactor! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! listModel3 ^ listModel3! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! listModel1 ^ listModel1! ! !CodeCriticBrowser methodsFor: 'processing' stamp: ''! basicSearch: aRule | numberSelectors precentIncrement percent checker | aRule resetResult. self status: 'Searching'; refresh. numberSelectors := self environment numberSelectors. precentIncrement := numberSelectors isZero ifFalse: [ 100.0 / numberSelectors ] ifTrue: [ 100.0 ]. percent := 0.0. checker := (Smalltalk at: #SmalllintChecker) new. checker rule: aRule; context: (Smalltalk at: #SmalllintChecker) new; environment: self environment; methodBlock: [ percent := percent + precentIncrement min: 100. self status: percent truncated asString , '%' ]. [ checker run ] ensure: [ self refresh. self status: (self root problemCount > 0 ifTrue: [ self root problemCount asString , ' problems' ]). checker release. process := nil ]! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! listModel3: anObject listModel3 := anObject! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! listModel2: anObject listModel2 := anObject! ! !CodeCriticBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 9/25/2013 18:24'! initializeWidgets self instantiateModels: #( listModel1 #ListModel listModel2 #ListModel listModel3 #ListModel textModel TextModel ). listModel1 displayBlock: [:rule | rule name ]. listModel2 displayBlock: [:rule | rule name ]. listModel3 displayBlock: [:rule | rule name ].! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! status: anObject status := anObject! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! environment ^ environment! ! !CodeCriticBrowser methodsFor: 'protocol' stamp: ''! rules: aCollection listModel1 items: aCollection! ! !CodeCriticBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 17:54'! initializePresenter listModel1 whenSelectedItemChanged: [:selection | listModel2 resetSelection. listModel2 items: (selection ifNil: [ {} ] ifNotNil: [ selection rules ])]. listModel2 whenSelectedItemChanged: [:selection | listModel3 resetSelection. listModel3 items: (selection ifNil: [ {} ] ifNotNil: [ selection rules ])]. listModel3 whenSelectedItemChanged: [:selection | selection ifNil: [ textModel text: '' ] ifNotNil: [ textModel text: selection result label ]]! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! environment: anObject environment := anObject! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! process: anObject process := anObject! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! listModel2 ^ listModel2! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! textModel ^ textModel! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! status ^ status! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! textModel: anObject textModel := anObject! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! listModel1: anObject listModel1 := anObject! ! !CodeCriticBrowser methodsFor: 'accessing' stamp: ''! process ^ process! ! !CodeCriticBrowser class methodsFor: 'specs' stamp: 'bvr 6/4/2012 14:41'! defaultSpec ^ { #PanelMorph. #changeTableLayout. #listDirection:. #bottomToTop. #addMorph:. self topSpec. #hResizing:. #spaceFill. #vResizing:. #spaceFill. #addMorph:. { #model. #textModel. }}! ! !CodeCriticBrowser class methodsFor: 'specs' stamp: ''! title ^ 'Code critics'! ! !CodeCriticBrowser class methodsFor: 'specs' stamp: 'bvr 6/4/2012 14:42'! topSpec ^ { #PanelMorph. #changeTableLayout. #listDirection:. #rightToLeft. #hResizing:. #spaceFill. #vResizing:. #spaceFill. #addMorph:. { #model. #listModel1. }. #addMorph:. { #model. #listModel2. }. #addMorph:. { #model. #listModel3. }}! ! !CodeDeclaration commentStamp: ''! I'm the abstract superclass of all the code declarations that should exist in an exported file.! !CodeDeclaration methodsFor: 'importing' stamp: 'CamilloBruni 7/10/2013 20:58'! importFor: aRequestor self import! ! !CodeDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 16:02'! contents: anObject contents := anObject! ! !CodeDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 16:02'! contents ^ contents! ! !CodeDeclaration methodsFor: 'importing' stamp: 'CamilloBruni 7/10/2013 20:58'! import self subclassResponsibility! ! !CodeDeclaration methodsFor: 'printing' stamp: 'GuillermoPolito 5/5/2012 20:21'! printOn: aStream super printOn: aStream. aStream nextPut: $(. aStream nextPutAll: contents. aStream nextPut: $).! ! !CodeDeclaration class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 16:02'! contents: someContents ^self new contents: someContents; yourself! ! !CodeHolder commentStamp: ''! An ancestor class for all models which can show code. Eventually, much of the code that currently resides in StringHolder which only applies to code-holding StringHolders might get moved down here.! !CodeHolder methodsFor: 'diffs' stamp: 'gvc 6/21/2010 11:51'! showDiffs: aBoolean "Set whether I'm showing diffs as indicated" self showingAnyKindOfDiffs ifFalse: [aBoolean ifTrue: [self contentsSymbol: self defaultDiffsSymbol]] ifTrue: [aBoolean ifFalse: [self contentsSymbol: #source]]. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'misc' stamp: 'StephaneDucasse 10/15/2009 18:01'! getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments. If no message is currently selected, then obtain a method name from a user type-in" | strm array | strm := (array := Array new: queryArgs size + 1) writeStream. strm nextPut: nil. strm nextPutAll: queryArgs. self selectedMessageName ifNil: [ | selector | selector := UIManager default request: 'Type selector:' initialAnswer: 'flag:'. selector ifNil: [selector := String new]. selector := selector copyWithout: Character space. ^ selector isEmptyOrNil ifFalse: [ (Symbol hasInterned: selector ifTrue: [ :aSymbol | array at: 1 put: aSymbol. queryPerformer perform: querySelector withArguments: array]) ifFalse: [ self inform: 'no such selector'] ] ]. self selectMessageAndEvaluate: [:selector | array at: 1 put: selector. queryPerformer perform: querySelector withArguments: array ]! ! !CodeHolder methodsFor: 'construction' stamp: 'FernandoOlivero 4/12/2011 09:43'! codePaneProvenanceButton "Answer a button that reports on, and allow the user to modify, the code-pane-provenance setting" ^(self theme builder newDropListFor: self list: #codePaneProvenanceList getSelected: #codePaneProvenanceIndex setSelected: #codePaneProvenanceIndex: help: 'Select what is shown in the code pane' translated) cornerStyle: (self theme buttonCornerStyleIn: nil); hResizing: #spaceFill; vResizing: #spaceFill; minWidth: 88! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 16:36'! prettyPrintString "Answer whether the receiver is showing pretty-print" ^ ((contentsSymbol == #prettyPrint) ifTrue: [''] ifFalse: ['']), 'prettyPrint'! ! !CodeHolder methodsFor: 'breakpoints' stamp: 'marcus.denker 10/9/2008 20:31'! toggleBreakOnEntry "Install or uninstall a halt-on-entry breakpoint" | selectedMethod | self selectedClassOrMetaClass isNil ifTrue:[^self]. selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName. selectedMethod hasBreakpoint ifTrue: [BreakpointManager unInstall: selectedMethod] ifFalse: [BreakpointManager installInClass: self selectedClassOrMetaClass selector: self selectedMessageName].! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:43'! showingRegularDiffsString "Answer a string representing whether I'm showing regular diffs" ^ (self showingRegularDiffs ifTrue: [''] ifFalse: ['']), 'showDiffs'! ! !CodeHolder methodsFor: 'diffs' stamp: 'marcus.denker 9/20/2008 20:31'! toggleRegularDiffing "Toggle whether regular-diffing should be shown in the code pane" | wasShowingDiffs | self okToChange ifTrue: [wasShowingDiffs := self showingRegularDiffs. self showRegularDiffs: wasShowingDiffs not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 2/27/2001 12:15'! offerUnshiftedClassListMenu "Offer the shifted class-list menu." ^ self offerMenuFrom: #classListMenu:shifted: shifted: false! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:19'! annotationForClassDefinitionFor: aClass "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." ^ 'Class definition for ', aClass name! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:02'! annotationSeparator "Answer the separator to be used between annotations" ^ ' · '! ! !CodeHolder methodsFor: 'annotation' stamp: 'StephaneDucasse 12/19/2012 16:16'! addOptionalAnnotationsTo: window at: fractions plus: verticalOffset "Add an annotation pane to the window if desired, and return the incoming verticalOffset plus the height of the added pane, if any" | aTextMorph delta | self showAnnotationPane ifFalse: [^ verticalOffset]. aTextMorph := CodeAnnotationMorph on: self. delta := StandardFonts defaultFont height+2. window addMorph: aTextMorph fullFrame: ( fractions asLayoutFrame topOffset: verticalOffset; bottomOffset: (verticalOffset + delta)). ^ verticalOffset + delta! ! !CodeHolder methodsFor: 'diffs' stamp: 'gvc 6/21/2010 11:52'! showRegularDiffs: aBoolean "Set whether I'm showing regular diffs as indicated" self showingRegularDiffs ifFalse: [aBoolean ifTrue: [self contentsSymbol: #showDiffs]] ifTrue: [aBoolean ifFalse: [self contentsSymbol: #source]]. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/19/1999 08:37'! stepIn: aSystemWindow self updateListsAndCodeIn: aSystemWindow! ! !CodeHolder methodsFor: 'controls' stamp: 'tbn 7/29/2010 22:18'! optionalButtonPairs "Answer a tuple (formerly pairs) defining buttons, in the format: button label selector to send help message" | aList | aList := #( ('Browse' browseMethodFull 'View this method in a browser') ('Senders' browseSendersOfMessages 'Browse senders of...') ('Implementors' browseMessages 'Browse implementors of...') ('Versions' browseVersions 'Browse versions')), (self class decorateBrowserButtons ifTrue: [{#('Inheritance' methodHierarchy 'Browse method inheritance green: sends to super tan: has override(s) mauve: both of the above pink: is an override but doesn''t call super pinkish tan: has override(s), also is an override but doesn''t call super' )}] ifFalse: [{#('Inheritance' methodHierarchy 'Browse method inheritance')}]), #( ('Hierarchy' classHierarchy 'Browse class hierarchy') ('Inst vars' browseInstVarRefs 'Inst var refs...') ('Class vars' browseClassVarRefs 'Class var refs...')). ^ aList! ! !CodeHolder methodsFor: 'controls' stamp: 'tbn 7/6/2010 16:22'! sourceAndDiffsQuintsOnly "Answer a list of quintuplets representing information on the alternative views available in the code pane for the case where the only plausible choices are showing source or either of the two kinds of diffs" ^ #( (source togglePlainSource showingPlainSourceString 'Source' 'the textual source code as writen') (showDiffs toggleRegularDiffing showingRegularDiffsString 'ShowDiffs' 'the textual source diffed from its prior version') (prettyDiffs togglePrettyDiffing showingPrettyDiffsString 'PrettyDiffs' 'formatted textual source diffed from formatted form of prior version'))! ! !CodeHolder methodsFor: 'misc' stamp: 'GabrielOmarCotelli 11/30/2013 16:19'! refreshAnnotation "If the receiver has an annotation pane that does not bear unaccepted edits, refresh it" self dependents detect: [ :m | (m isKindOf: PluggableTextMorph) and: [ m getTextSelector == #annotation ] ] ifFound: [ :aPane | aPane hasUnacceptedEdits ifFalse: [ aPane update: #annotation ] ]! ! !CodeHolder methodsFor: 'setting' stamp: 'AlainPlantec 11/24/2009 16:59'! showAnnotationPane ^ self class showAnnotationPane! ! !CodeHolder methodsFor: 'contents' stamp: 'gvc 6/21/2010 11:42'! contentsSymbol: aSymbol "Set the contentsSymbol as indicated. #source means to show source code, #comment means to show the first comment found in the source code" contentsSymbol := aSymbol. self contentsSymbolChanged! ! !CodeHolder methodsFor: 'construction' stamp: 'StephaneDucasse 12/19/2012 16:14'! addLowerPanesTo: window at: nominalFractions with: editString | verticalOffset row innerFractions tm | tm := self buildMorphicCodePaneWith: editString. row := AlignmentMorph newColumn hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 1; borderColor: Color black; layoutPolicy: ProportionalLayout new. verticalOffset := 0. innerFractions := 0@0 corner: 1@0. verticalOffset := self addOptionalAnnotationsTo: row at: innerFractions plus: verticalOffset. verticalOffset := self addOptionalButtonsTo: row at: innerFractions plus: verticalOffset. row addMorph: (tm borderWidth: 0) fullFrame: ((innerFractions withBottom: 1) asLayoutFrame topOffset: verticalOffset). window addMorph: row frame: nominalFractions. row on: #mouseEnter send: #paneTransition: to: window. row on: #mouseLeave send: #paneTransition: to: window.! ! !CodeHolder methodsFor: 'diffs' stamp: 'sd 11/20/2005 21:27'! diffFromPriorSourceFor: sourceCode "If there is a prior version of source for the selected method, return a diff, else just return the source code" | prior | ^ (prior := self priorSourceOrNil) ifNil: [sourceCode] ifNotNil: [TextDiffBuilder buildDisplayPatchFrom: prior to: sourceCode inClass: self selectedClass prettyDiffs: self showingPrettyDiffs]! ! !CodeHolder methodsFor: 'controls' stamp: 'gm 2/16/2003 20:37'! buttonWithSelector: aSelector "If receiver has a control button with the given action selector answer it, else answer nil. morphic only at this point" | aWindow aPane | ((aWindow := self containingWindow) isSystemWindow) ifFalse: [^nil]. (aPane := aWindow submorphNamed: 'buttonPane') ifNil: [^nil]. ^aPane submorphThat: [:m | (m isKindOf: PluggableButtonMorph) and: [m actionSelector == aSelector]] ifNone: [^nil]! ! !CodeHolder methodsFor: 'message list' stamp: 'sw 8/16/2002 23:23'! selectedBytecodes "Answer text to show in a code pane when in showing-byte-codes mode" ^ (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName ifAbsent: [^ '' asText]) symbolic asText! ! !CodeHolder methodsFor: 'what to show' stamp: 'sd 11/20/2005 21:27'! setContentsToForceRefetch "Set the receiver's contents such that on the next update the contents will be formulated afresh. This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty. By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more" contents := nil! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 18:05'! showingByteCodes "Answer whether the receiver is showing bytecodes" ^ contentsSymbol == #byteCodes! ! !CodeHolder methodsFor: 'categories' stamp: 'sd 11/20/2005 21:27'! letUserReclassify: anElement in: aClass "Put up a list of categories and solicit one from the user. Answer true if user indeed made a change, else false" | currentCat newCat | currentCat := aClass organization categoryOfElement: anElement. newCat := self categoryFromUserWithPrompt: 'choose category (currently "', currentCat, '")' for: aClass. (newCat ~~ nil and: [newCat ~= currentCat]) ifTrue: [aClass organization classify: anElement under: newCat suppressIfDefault: false. ^ true] ifFalse: [^ false]! ! !CodeHolder methodsFor: 'categories' stamp: 'sw 9/27/1999 14:11'! methodCategoryChanged self changed: #annotation! ! !CodeHolder methodsFor: 'contents' stamp: 'MarcusDenker 4/28/2013 21:32'! contentsSymbolChanged "Inform any dependents of a change in the contents symbol." self changed: #showingAnyKindOfDiffs; changed: #showingBytecodes; changed: #showingDiffs; changed: #showingPlainSource; changed: #showingPrettyDiffs; changed: #showingPrettyPrint; changed: #showingRegularDiffs! ! !CodeHolder methodsFor: 'diffs' stamp: 'gvc 6/21/2010 11:52'! showPrettyDiffs: aBoolean "Set whether I'm showing pretty diffs as indicated" self showingPrettyDiffs ifFalse: [aBoolean ifTrue: [self contentsSymbol: #prettyDiffs]] ifTrue: [aBoolean ifFalse: [self contentsSymbol: #source]]. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'what to show' stamp: 'marcus.denker 9/20/2008 20:32'! toggleShowingByteCodes "Toggle whether the receiver is showing bytecodes" self showByteCodes: self showingByteCodes not. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'misc' stamp: 'MarcusDenker 10/3/2013 23:45'! useSelector: incomingSelector orGetSelectorAndSendQuery: querySelector to: queryPerformer "If incomingSelector is not nil, use it, else obtain a selector from user type-in. Using the determined selector, send the query to the performer provided." incomingSelector ifNotNil: [queryPerformer perform: querySelector with: incomingSelector] ifNil: [| aSelector | aSelector :=UIManager default request: 'Type selector:' initialAnswer: 'flag:'. aSelector isEmptyOrNil ifFalse: [(Symbol hasInterned: aSelector ifTrue: [:aSymbol | queryPerformer perform: querySelector with: aSymbol]) ifFalse: [self inform: 'no such selector']]]! ! !CodeHolder methodsFor: 'annotation' stamp: 'StephaneDucasse 5/28/2011 13:44'! addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream "add an annotation detailing the prior versions count" | versionsCount | versionsCount := Smalltalk tools versionBrowser versionCountForSelector: aSelector class: aClass. aStream nextPutAll: ((versionsCount > 1 ifTrue: [versionsCount = 2 ifTrue: ['1 prior version'] ifFalse: [versionsCount printString, ' prior versions']] ifFalse: ['no prior versions']), self annotationSeparator)! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 09:31'! showingPlainSourceString "Answer a string telling whether the receiver is showing plain source" ^ (self showingPlainSource ifTrue: [''] ifFalse: ['']), 'source'! ! !CodeHolder methodsFor: '*Shout-Styling' stamp: ''! shoutIsModeStyleable ^ self showingSource or: [self showingPrettyPrint]! ! !CodeHolder methodsFor: 'misc' stamp: 'MarcusDenker 4/26/2013 15:26'! okayToAccept "Answer whether it is okay to accept the receiver's input" self showingAnyKindOfDiffs ifFalse: [^ true]. ^ self confirm: 'Caution!! You are "showing diffs" here, so there is a danger that some of the text in the code pane is contaminated by the "diff" display' translated ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:49'! showDiffs "Answer whether the receiver is showing diffs of source code. The preferred protocol here is #showingRegularDiffs, but this message is still sent by some preexisting buttons so is retained." ^ contentsSymbol == #showDiffs ! ! !CodeHolder methodsFor: 'diffs' stamp: 'FernandoOlivero 4/12/2011 09:43'! regularDiffButton "Return a checkbox that lets the user decide whether regular diffs should be shown or not" ^self theme builder newCheckboxFor: self getSelected: #showingRegularDiffs setSelected: #toggleRegularDiffing label: 'diffs' translated help: 'If checked, then code differences from the previous version, if any, will be shown.' translated ! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/6/2001 15:18'! shiftedYellowButtonActivity "Offer the shifted selector-list menu" ^ self offerMenuFrom: #messageListMenu:shifted: shifted: true! ! !CodeHolder methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:27'! annotation "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." | aSelector aClass | ((aSelector := self selectedMessageName) == nil or: [(aClass := self selectedClassOrMetaClass) == nil]) ifTrue: [^ '------']. ^ self annotationForSelector: aSelector ofClass: aClass! ! !CodeHolder methodsFor: 'annotation' stamp: 'StephaneDucasse 5/28/2011 13:39'! annotationForSelector: aSelector ofClass: aClass "Provide a line of content for an annotation pane, representing information about the given selector and class" | separator aStream requestList | aSelector == #Comment ifTrue: [^ self annotationForClassCommentFor: aClass]. aSelector == #Definition ifTrue: [^ self annotationForClassDefinitionFor: aClass]. aSelector == #Hierarchy ifTrue: [^ self annotationForHierarchyFor: aClass]. aStream := ReadWriteStream on: ''. requestList := self annotationRequests. separator := requestList size > 1 ifTrue: [self annotationSeparator] ifFalse: ['']. requestList do: [:aRequest | | sendersCount aComment implementorsCount aString aList stamp aCategory | aRequest == #firstComment ifTrue: [aComment := aClass firstCommentAt: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #masterComment ifTrue: [aComment := aClass supermostPrecodeCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #documentation ifTrue: [aComment := aClass precodeCommentOrInheritedCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #timeStamp ifTrue: [stamp := self timeStamp. aStream nextPutAll: (stamp size > 0 ifTrue: [stamp , separator] ifFalse: ['no timeStamp' , separator])]. aRequest == #messageCategory ifTrue: [aCategory := aClass organization categoryOfElement: aSelector. aCategory ifNotNil: ["woud be nil for a method no longer present, e.g. in a recent-submissions browser" aStream nextPutAll: aCategory , separator]]. aRequest == #sendersCount ifTrue: [sendersCount := (self systemNavigation allCallsOn: aSelector) size. sendersCount := sendersCount = 1 ifTrue: ['1 sender'] ifFalse: [sendersCount printString , ' senders']. aStream nextPutAll: sendersCount , separator]. aRequest == #implementorsCount ifTrue: [implementorsCount := self systemNavigation numberOfImplementorsOf: aSelector. implementorsCount := implementorsCount = 1 ifTrue: ['1 implementor'] ifFalse: [implementorsCount printString , ' implementors']. aStream nextPutAll: implementorsCount , separator]. aRequest == #priorVersionsCount ifTrue: [self addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. aRequest == #priorTimeStamp ifTrue: [stamp := Smalltalk tools versionBrowser timeStampFor: aSelector class: aClass reverseOrdinal: 2. stamp ifNotNil: [aStream nextPutAll: 'prior time stamp: ' , stamp , separator]]. aRequest == #recentChangeSet ifTrue: [aString := ChangeSet mostRecentChangeSetWithChangeForClass: aClass selector: aSelector. aString size > 0 ifTrue: [aStream nextPutAll: aString , separator]]. aRequest == #allChangeSets ifTrue: [aList := ChangeSet allChangeSetsWithClass: aClass selector: aSelector. aList size > 0 ifTrue: [aList size = 1 ifTrue: [aStream nextPutAll: 'only in change set '] ifFalse: [aStream nextPutAll: 'in change sets: ']. aList do: [:aChangeSet | aStream nextPutAll: aChangeSet name , ' ']] ifFalse: [aStream nextPutAll: 'in no change set']. aStream nextPutAll: separator]]. ^ aStream contents! ! !CodeHolder methodsFor: 'message list' stamp: 'MarcusDenker 4/28/2013 21:32'! selectedMessage "Answer a copy of the source code for the selected message. This generic version is probably actually never reached, since every subclass probably reimplements and does not send to super. In time, ideally, most, or all, reimplementors would vanish and all would defer instead to a universal version right here. Everything in good time." | class selector method | contents ifNotNil: [^ contents copy]. class := self selectedClassOrMetaClass. (class isNil or: [(selector := self selectedMessageName) isNil]) ifTrue: [^ '']. method := class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" currentCompiledMethod := method. ^ contents := (self sourceStringPrettifiedAndDiffed) copy! ! !CodeHolder methodsFor: 'categories' stamp: 'EstebanLorenzano 6/26/2013 17:59'! categoryFromUserWithPrompt: aPrompt for: aClass "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" | labels myCategories reject lines newName | labels := OrderedCollection new. labels addAll: (myCategories := aClass organization categories asSortedCollection: [:a :b | a asLowercase < b asLowercase]). reject := myCategories asSet. reject add: Protocol nullCategory; add: Protocol unclassified. lines := OrderedCollection with: 1 with: (myCategories size + 1). aClass allSuperclasses do: [:cls | | cats | cats := cls organization categories reject: [:cat | reject includes: cat]. cats isEmpty ifFalse: [lines add: labels size. labels addAll: (cats asSortedCollection: [:a :b | a asLowercase < b asLowercase]). reject addAll: cats]]. newName := UIManager default chooseOrRequestFrom: labels lines: lines title: aPrompt. ^ newName ifNotNil: [newName asSymbol]! ! !CodeHolder methodsFor: 'controls' stamp: 'gvc 1/20/2009 15:34'! codePaneProvenanceIndex "Answer the selected code provenance index." ^((self contentsSymbolQuints select: [:e | e ~= #-]) collect: [:e | e first]) indexOf: self contentsSymbol ifAbsent: [0]! ! !CodeHolder methodsFor: 'commands' stamp: 'MarcusDenker 10/13/2013 07:58'! browseSenders "Create and schedule a message set browser on all senders of the currently selected message selector. Of there is no message currently selected, offer a type-in" self sendQuery: #browseAllSendersOf: to: self systemNavigation! ! !CodeHolder methodsFor: 'annotation' stamp: 'sd 11/20/2005 21:27'! annotationForClassCommentFor: aClass "Provide a line of content for an annotation pane, given that the receiver is pointing at the clas comment of the given class." | aStamp nonMeta | aStamp := (nonMeta := aClass theNonMetaClass) organization commentStamp. ^ aStamp ifNil: [nonMeta name, ' has no class comment'] ifNotNil: ['class comment for ', nonMeta name, (aStamp = '' ifFalse: [' - ', aStamp] ifTrue: [''])]! ! !CodeHolder methodsFor: 'contents' stamp: 'AlainPlantec 11/24/2009 17:20'! contentsSymbol "Answer a symbol indicating what kind of content should be shown for the method; for normal showing of source code, this symbol is #source. A nil value in the contentsSymbol slot will be set to #source by this method" ^ contentsSymbol ifNil: [contentsSymbol := self browseWithPrettyPrint ifTrue: [#prettyPrint] ifFalse: [#source]]! ! !CodeHolder methodsFor: 'setting' stamp: 'AlainPlantec 11/27/2009 09:24'! browseWithPrettyPrint ^ self class browseWithPrettyPrint ! ! !CodeHolder methodsFor: 'message list menu' stamp: 'MarcusDenker 10/13/2013 07:59'! messageListKey: aChar from: view "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." | sel class | aChar == $D ifTrue: [^ self toggleDiffing]. sel := self selectedMessageName. aChar == $m ifTrue: "These next two put up a type in if no message selected" [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation]. aChar == $n ifTrue: [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllSendersOf: to: self systemNavigation]. "The following require a class selection" (class := self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view]. aChar == $b ifTrue: [^ Smalltalk tools browser fullOnClass: class selector: sel]. aChar == $N ifTrue: [^ self browseClassRefs]. aChar == $i ifTrue: [^ self methodHierarchy]. aChar == $h ifTrue: [^ self classHierarchy]. "The following require a method selection" sel ifNotNil: [aChar == $o ifTrue: [^ self fileOutMessage]. aChar == $c ifTrue: [^ self copySelector]. aChar == $v ifTrue: [^ self browseVersions]. aChar == $x ifTrue: [^ self removeMessage]. aChar == $d ifTrue: [^ self removeMessageFromBrowser]. (aChar == $C and: [self canShowMultipleMessageCategories]) ifTrue: [^ self showHomeCategory]]. ^ self arrowKey: aChar from: view! ! !CodeHolder methodsFor: 'misc' stamp: 'md 2/24/2006 15:28'! isThereAnOverride "Answer whether any subclass of my selected class implements my selected selector" | aName aClass | aName := self selectedMessageName ifNil: [^ false]. aClass := self selectedClassOrMetaClass ifNil: [^ false]. aClass allSubclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]]. ^ false! ! !CodeHolder methodsFor: 'diffs' stamp: 'gvc 6/21/2010 11:52'! togglePrettyPrint "Toggle whether pretty-print is in effectin the code pane" self okToChange ifTrue: [self showingPrettyPrint ifTrue: [self contentsSymbol: #source] ifFalse: [self contentsSymbol: #prettyPrint]. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'misc' stamp: 'StephaneDucasse 1/13/2010 14:22'! initialExtent ^ 700@500! ! !CodeHolder methodsFor: 'controls' stamp: 'ar 2/12/2005 14:28'! decorateButtons "Change screen feedback for any buttons in the UI of the receiver that may wish it. Initially, it is only the Inheritance button that is decorated, but one can imagine others." self changed: #inheritanceButtonColor. self decorateForInheritance ! ! !CodeHolder methodsFor: 'construction' stamp: 'MarcusDenker 10/15/2013 18:16'! addOptionalButtonsTo: window at: fractions plus: verticalOffset "If the receiver wishes it, add a button pane to the window, and answer the verticalOffset plus the height added" | delta buttons | self wantsOptionalButtons ifFalse: [^ verticalOffset]. buttons := self optionalButtonRow color: Color white. buttons layoutInset: (0@0 corner: 0@4). buttons := OverflowRowMorph new baseMorph: buttons; height: buttons minExtent y; setNameTo: buttons assureExtension externalName. delta := buttons minExtent y. window addMorph: buttons fullFrame: (fractions asLayoutFrame topOffset: verticalOffset; bottomOffset: (verticalOffset + delta)). ^ verticalOffset + delta! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/22/2001 16:41'! showingPrettyDiffsString "Answer a string representing whether I'm showing pretty diffs" ^ (self showingPrettyDiffs ifTrue: [''] ifFalse: ['']), 'prettyDiffs'! ! !CodeHolder methodsFor: '*necompletion-override' stamp: 'EstebanLorenzano 4/11/2012 17:11'! contentsChanged super contentsChanged. self changed: #annotation.! ! !CodeHolder methodsFor: 'diffs' stamp: 'FernandoOlivero 4/12/2011 09:43'! prettyDiffButton "Return a checkbox that lets the user decide whether prettyDiffs should be shown or not" ^self theme builder newCheckboxFor: self getSelected: #showingPrettyDiffs setSelected: #togglePrettyDiffing label: 'prettyDiffs' translated help: 'If checked, then pretty-printed code differences from the previous version, if any, will be shown.' translated ! ! !CodeHolder methodsFor: 'toolbuilder' stamp: 'marcus.denker 8/17/2008 21:02'! color | flags aColor | flags := 0. self isThisAnOverride ifTrue: [ flags := flags bitOr: 4 ]. currentCompiledMethod sendsToSuper ifTrue: [ flags := flags bitOr: 2 ]. self isThereAnOverride ifTrue: [ flags := flags bitOr: 1 ]. aColor := { Color transparent. Color tan lighter. Color green muchLighter. Color blue muchLighter. Color red muchLighter. "has super but doesn't call it" (Color r: 0.94 g: 0.823 b: 0.673). "has sub; has super but doesn't call it" Color green muchLighter. Color blue muchLighter. } at: flags + 1. ^aColor! ! !CodeHolder methodsFor: 'traits' stamp: 'StephaneDucasse 11/7/2011 22:43'! showUnreferencedInstVars "Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced" | cls aList aReport | ((cls := self selectedClassOrMetaClass) isNil or: [cls isTrait]) ifTrue: [^ self]. aList := cls allUnreferencedInstanceVariables. aList size = 0 ifTrue: [^ self inform: 'There are no unreferenced instance variables in ', cls name]. aReport := String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced instance variable(s) in ' translated, cls name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. self crTrace: aReport. self inform: aReport! ! !CodeHolder methodsFor: 'self-updating' stamp: 'nk 4/29/2004 12:25'! didCodeChangeElsewhere "Determine whether the code for the currently selected method and class has been changed somewhere else." | aClass aSelector aCompiledMethod | currentCompiledMethod ifNil: [^ false]. (aClass := self selectedClassOrMetaClass) ifNil: [^ false]. (aSelector := self selectedMessageName) ifNil: [^ false]. self classCommentIndicated ifTrue: [^ currentCompiledMethod ~~ aClass organization commentRemoteStr]. ^ (aCompiledMethod := aClass compiledMethodAt: aSelector ifAbsent: [^ false]) ~~ currentCompiledMethod and: [aCompiledMethod last ~= 0 "either not yet installed" or: [ currentCompiledMethod last = 0 "or these methods don't have source pointers"]]! ! !CodeHolder methodsFor: 'self-updating' stamp: 'sw 2/14/2001 15:34'! updateCodePaneIfNeeded "If the code for the currently selected method has changed underneath me, then update the contents of my code pane unless it holds unaccepted edits" self didCodeChangeElsewhere ifTrue: [self hasUnacceptedEdits ifFalse: [self setContentsToForceRefetch. self contentsChanged] ifTrue: [self changed: #codeChangedElsewhere]]! ! !CodeHolder methodsFor: 'construction' stamp: 'FernandoOlivero 4/12/2011 10:10'! optionalButtonRow "Answer a row of control buttons" | buttons | buttons := OrderedCollection new. self optionalButtonPairs do: [:tuple | buttons add: ((PluggableButtonMorph on: self getState: nil action: tuple second) onColor: self class patchworkUIThemeColor offColor: self class patchworkUIThemeColor darker darker; hResizing: #spaceFill; vResizing: #spaceFill; label: tuple first asString; setBalloonText: (tuple size > 2 ifTrue: [tuple third]); triggerOnMouseDown: (tuple size > 3 ifTrue: [tuple fourth] ifFalse: [false]))]. buttons add: self codePaneProvenanceButton. ^(self theme builder newRow: buttons) setNameTo: 'buttonPane'; cellInset: 2! ! !CodeHolder methodsFor: 'setting' stamp: 'AlainPlantec 1/7/2010 21:48'! wantsOptionalButtons "Answer whether the receiver, seen in some browser window, would like to have the so-called optional button pane included. By default, various browsers defer to the optionalButtons class accessor -- but individual subclasses can insist to the contrary." ^ self class optionalButtons! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 9/27/2001 01:26'! modelWakeUpIn: aWindow "The window has been activated. Respond to possible changes that may have taken place while it was inactive" self updateListsAndCodeIn: aWindow. self decorateButtons. self refreshAnnotation. super modelWakeUpIn: aWindow! ! !CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'! priorSourceOrNil "If the currently-selected method has a previous version, return its source, else return nil" | aClass aSelector changeRecords | (aClass := self selectedClassOrMetaClass) ifNil: [^ nil]. (aSelector := self selectedMessageName) ifNil: [^ nil]. changeRecords := aClass changeRecordsAt: aSelector. (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil]. ^ (changeRecords at: 2) string ! ! !CodeHolder methodsFor: 'what to show' stamp: 'gvc 6/21/2010 11:52'! showByteCodes: aBoolean "Get into or out of bytecode-showoing mode" self okToChange ifFalse: [^ self changed: #flash]. aBoolean ifTrue: [self contentsSymbol: #byteCodes] ifFalse: [contentsSymbol == #byteCodes ifTrue: [self contentsSymbol: #source]]. self contentsChanged! ! !CodeHolder methodsFor: 'controls' stamp: 'gvc 1/20/2009 15:33'! codePaneProvenanceIndex: anInteger "Set the code provenance to the item with the given index." self perform: ((self contentsSymbolQuints select: [:e | e ~= #-]) at: anInteger) second! ! !CodeHolder methodsFor: 'categories' stamp: 'sw 3/22/2000 23:04'! selectedMessageCategoryName "Answer the name of the message category of the message of the currently selected context." ^ self selectedClass organization categoryOfElement: self selectedMessageName! ! !CodeHolder methodsFor: 'tiles' stamp: 'tbn 7/6/2010 16:36'! addModelItemsToWindowMenu: aMenu "Add model-related item to the window menu" super addModelItemsToWindowMenu: aMenu. aMenu addLine. aMenu add: 'What to show...' translated target: self action: #offerWhatToShowMenu! ! !CodeHolder methodsFor: 'traits' stamp: 'MarcusDenker 3/26/2013 08:28'! spawnHierarchy "Create and schedule a new hierarchy browser on the currently selected class or meta." | aSymbol selectedClassOrMetaClass browser | (selectedClassOrMetaClass := self selectedClassOrMetaClass) ifNil: [^ self]. selectedClassOrMetaClass isTrait ifTrue: [^ self]. ((aSymbol := self selectedMessageName) notNil and: [(Smalltalk tools messageList isPseudoSelector: aSymbol) not]) ifTrue: [browser := Smalltalk tools browser newOnClass: selectedClassOrMetaClass selector: aSymbol ] ifFalse: [ browser := Smalltalk tools browser newOnClass: selectedClassOrMetaClass ]. browser spawnHierarchy ! ! !CodeHolder methodsFor: 'what to show' stamp: 'alain.plantec 5/30/2008 11:22'! addContentsTogglesTo: aMenu "Add updating menu toggles governing contents to aMenu." self contentsSymbolQuints do: [:aQuint | aQuint == #- ifTrue: [aMenu addLine] ifFalse: [aMenu addUpdating: aQuint third target: self action: aQuint second. aMenu balloonTextForLastItem: aQuint fifth]]! ! !CodeHolder methodsFor: 'accessing' stamp: 'StephaneDucasse 2/23/2012 14:24'! receiverClass ^ self selectedClassOrMetaClass! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/19/2001 00:07'! showingPrettyDiffs "Answer whether the receiver is showing pretty diffs of source code" ^ contentsSymbol == #prettyDiffs ! ! !CodeHolder methodsFor: 'what to show' stamp: 'GuillermoPolito 5/29/2011 15:19'! offerWhatToShowMenu "Offer a menu governing what to show" | aMenu | aMenu := UIManager default newMenuIn: self for: self. aMenu addTitle: 'What to show' translated. aMenu addStayUpItem. self addContentsTogglesTo: aMenu. aMenu popUpInWorld! ! !CodeHolder methodsFor: 'misc' stamp: 'nk 4/10/2001 07:52'! getSelectorAndSendQuery: querySelector to: queryPerformer "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained as its argument. If no message is currently selected, then obtain a method name from a user type-in" self getSelectorAndSendQuery: querySelector to: queryPerformer with: { }. ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 18:36'! showingPrettyPrint "Answer whether the receiver is showing pretty-print" ^ contentsSymbol == #prettyPrint! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 12/5/2000 11:48'! showingSource "Answer whether the receiver is currently showing source code" ^ self contentsSymbol == #source ! ! !CodeHolder methodsFor: 'controls' stamp: 'MarcusDenker 4/28/2013 21:31'! contentsSymbolQuints "Answer a list of quintuplets representing information on the alternative views available in the code pane first element: the contentsSymbol used second element: the selector to call when this item is chosen. third element: the selector to call to obtain the wording of the menu item. fourth element: the wording to represent this view fifth element: balloon help A hypen indicates a need for a seperator line in a menu of such choices" ^ #( (source togglePlainSource showingPlainSourceString 'Source' 'The textual source code as writen') - (prettyPrint togglePrettyPrint prettyPrintString 'PrettyPrint' 'The method source presented in a standard text format') - (showDiffs toggleRegularDiffing showingRegularDiffsString 'ShowDiffs' 'The textual source diffed from its prior version') (prettyDiffs togglePrettyDiffing showingPrettyDiffsString 'PrettyDiffs' 'Formatted textual source diffed from formatted form of prior version') - (byteCodes toggleShowingByteCodes showingByteCodesString 'ByteCodes' 'The bytecodes that comprise the compiled method'))! ! !CodeHolder methodsFor: 'misc' stamp: 'rbb 3/1/2005 10:31'! sendQuery: querySelector to: queryPerformer "Apply a query to the primary selector associated with the current context. If no such selection exists, obtain one by user type-in. Then send querySelector to queryPerformer with the selector as its argument." | aSelector aString | aSelector := self selectedMessageName ifNil: [aString :=UIManager default request: 'Type selector:' initialAnswer: 'flag:'. ^ aString isEmptyOrNil ifFalse: [(Symbol hasInterned: aString ifTrue: [:aSymbol | queryPerformer perform: querySelector with: aSymbol]) ifFalse: [self inform: 'no such selector']]]. queryPerformer perform: querySelector with: aSelector! ! !CodeHolder methodsFor: 'builder' stamp: 'AlainPlantec 8/26/2011 17:51'! buildTextMorph ^( PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) font: StandardFonts codeFont; yourself! ! !CodeHolder methodsFor: 'toolbuilder' stamp: 'AlainPlantec 12/1/2009 22:56'! inheritanceButtonColor "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." ((currentCompiledMethod isKindOf: CompiledMethod) and: [self class decorateBrowserButtons]) ifFalse: [^Color transparent]. "This table duplicates the old logic, but adds two new colors for the cases where there is a superclass definition, but this method doesn't call it." ^ self color ! ! !CodeHolder methodsFor: 'traits' stamp: 'StephaneDucasse 11/7/2011 22:43'! showUnreferencedClassVars "Search for all class variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each class variable in order to determine whether it is unreferenced" | cls aList aReport | ((cls := self selectedClass) isNil or: [cls isTrait]) ifTrue: [^ self]. aList := self systemNavigation allUnreferencedClassVariablesOf: cls. aList size = 0 ifTrue: [^ self inform: 'There are no unreferenced class variables in ' , cls name]. aReport := String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced class variable(s) in ' translated, cls name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. self crTrace: aReport. self inform: aReport! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 12/5/2000 12:25'! showDocumentation: aBoolean "Set the showDocumentation toggle as indicated" self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#documentation])! ! !CodeHolder methodsFor: 'categories' stamp: 'sd 11/20/2005 21:26'! changeCategory "Present a menu of the categories of messages for the current class, and let the user choose a new category for the current message" | aClass aSelector | (aClass := self selectedClassOrMetaClass) ifNotNil: [(aSelector := self selectedMessageName) ifNotNil: [(self letUserReclassify: aSelector in: aClass) ifTrue: ["ChangeSet current reorganizeClass: aClass." "Decided on further review that the above, when present, could cause more unexpected harm than good" self methodCategoryChanged]]]! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:07'! showingRegularDiffs "Answer whether the receiver is showing regular diffs of source code" ^ contentsSymbol == #showDiffs ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:24'! wantsDiffFeedback "Answer whether the receiver is showing diffs of source code" ^ self showingAnyKindOfDiffs! ! !CodeHolder methodsFor: 'message list' stamp: 'MarcusDenker 4/28/2013 11:13'! validateMessageSource: sourceString forSelector: aSelector "Check whether there is evidence that method source is invalid" | sourcesName | (self selectedClass compiler parseSelector: sourceString asString) = aSelector ifFalse: [ sourcesName := Smalltalk sourcesName asFileReference basename. self inform: 'There may be a problem with your sources file!! The source code for every method should (usually) start with the method selector but this is not the case with this method!! You may proceed with caution but it is recommended that you get a new source file. This can happen if you download the "' , sourcesName , '" file, or the ".changes" file you use, as TEXT. It must be transfered in BINARY mode, even if it looks like a text file, to preserve the CR line ends. Mac users: This may have been caused by Stuffit Expander. To prevent the files above to be converted to Mac line ends when they are expanded, do this: Start the program, then from Preferences... in the File menu, choose the Cross Platform panel, then select "Never" and press OK. Then expand the compressed archive again. (Occasionally, the source code for a method may legitimately start with a non-alphabetic character -- for example, Behavior method #formalHeaderPartsFor:. In such rare cases, you can happily disregard this warning.)'].! ! !CodeHolder methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:19'! canShowMultipleMessageCategories "Answer whether the receiver is capable of showing multiple message categories" ^ false! ! !CodeHolder methodsFor: 'misc' stamp: 'sd 11/20/2005 21:27'! releaseCachedState "Can always be found again. Don't write on a file." currentCompiledMethod := nil.! ! !CodeHolder methodsFor: 'message list' stamp: 'MarcusDenker 8/28/2013 10:34'! sourceStringPrettifiedAndDiffed "Answer a copy of the source code for the selected message, transformed by diffing and pretty-printing exigencies" | class selector sourceString | class := self selectedClassOrMetaClass. selector := self selectedMessageName. (class isNil or: [selector isNil]) ifTrue: [^'missing']. sourceString := class ultimateSourceCodeAt: selector ifAbsent: [^'error']. self validateMessageSource: sourceString forSelector: selector. (#(#prettyPrint #prettyDiffs) includes: contentsSymbol) ifTrue: [sourceString := class compiler format: sourceString]. self showingAnyKindOfDiffs ifTrue: [sourceString := self diffFromPriorSourceFor: sourceString]. ^sourceString! ! !CodeHolder methodsFor: 'commands' stamp: 'onierstrasz 11/11/2013 12:23'! removeClass "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." | message className classToRemove result | self okToChange ifFalse: [^ false]. classToRemove := self selectedClassOrMetaClass ifNil: [self inform: 'Selected class or metaclass is nil'. ^ false]. classToRemove := classToRemove theNonMetaClass. className := classToRemove name. message := 'Are you certain that you want to REMOVE the class ', className, ' from the system?'. (result := self confirm: message) ifTrue: [classToRemove subclasses size > 0 ifTrue: [(self confirm: 'class has subclasses: ' , message) ifFalse: [^ false]]. classToRemove removeFromSystem. self changed: #classList. true]. ^ result! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 9/5/2001 13:32'! showingAnyKindOfDiffs "Answer whether the receiver is currently set to show any kind of diffs" ^ #(showDiffs prettyDiffs) includes: contentsSymbol! ! !CodeHolder methodsFor: 'diffs' stamp: 'marcus.denker 9/20/2008 20:31'! toggleDiffing "Toggle whether diffs should be shown in the code pane. If any kind of diffs were being shown, stop showing diffs. If no kind of diffs were being shown, start showing whatever kind of diffs are called for by default." | wasShowingDiffs | self okToChange ifTrue: [wasShowingDiffs := self showingAnyKindOfDiffs. self showDiffs: wasShowingDiffs not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/19/1999 14:14'! updateListsAndCodeIn: aWindow super updateListsAndCodeIn: aWindow. self updateCodePaneIfNeeded! ! !CodeHolder methodsFor: 'annotation' stamp: 'AlainPlantec 12/21/2009 22:23'! annotationRequests ^ self class annotationRequests! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 18:28'! showingByteCodesString "Answer whether the receiver is showing bytecodes" ^ (self showingByteCodes ifTrue: [''] ifFalse: ['']), 'byteCodes'! ! !CodeHolder methodsFor: 'diffs' stamp: 'gvc 6/21/2010 11:52'! togglePlainSource "Toggle whether plain source shown in the code pane" | wasShowingPlainSource | self okToChange ifTrue: [wasShowingPlainSource := self showingPlainSource. wasShowingPlainSource ifTrue: [self showDocumentation: true] ifFalse: [self contentsSymbol: #source]. self setContentsToForceRefetch. self changed: #contents] ! ! !CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'! browseImplementors "Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected." | aMessageName | (aMessageName := self selectedMessageName) ifNotNil: [self systemNavigation browseAllImplementorsOf: aMessageName]! ! !CodeHolder methodsFor: 'misc' stamp: 'md 2/24/2006 15:28'! isThisAnOverride "Answer whether any superclass of my selected class implements my selected selector" | aName aClass | aName := self selectedMessageName ifNil: [^ false]. aClass := self selectedClassOrMetaClass ifNil: [^ false]. aClass allSuperclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]]. ^ false! ! !CodeHolder methodsFor: 'diffs' stamp: 'AlainPlantec 12/1/2009 22:03'! defaultDiffsSymbol "Answer the code symbol to use when generically switching to diffing" ^ self class diffsWithPrettyPrint ifTrue: [#prettyDiffs] ifFalse: [#showDiffs]! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 2/27/2001 12:14'! offerShiftedClassListMenu "Offer the shifted class-list menu." ^ self offerMenuFrom: #classListMenu:shifted: shifted: true! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/6/2001 15:19'! unshiftedYellowButtonActivity "Offer the unshifted shifted selector-list menu" ^ self offerMenuFrom: #messageListMenu:shifted: shifted: false! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:19'! annotationForHierarchyFor: aClass "Provide a line of content for an annotation pane, given that the receiver is pointing at the hierarchy of the given class." ^ 'Hierarchy for ', aClass name! ! !CodeHolder methodsFor: 'categories' stamp: 'sd 11/20/2005 21:27'! categoryOfCurrentMethod "Answer the category that owns the current method. If unable to determine a category, answer nil." | aClass aSelector | ^ (aClass := self selectedClassOrMetaClass) ifNotNil: [(aSelector := self selectedMessageName) ifNotNil: [aClass whichCategoryIncludesSelector: aSelector]]! ! !CodeHolder methodsFor: 'controls' stamp: 'gvc 1/20/2009 15:31'! codePaneProvenanceList "Answer a list of the display strings for code provenance." ^(self contentsSymbolQuints select: [:e | e ~= #-]) collect: [:e | e fourth]! ! !CodeHolder methodsFor: 'construction' stamp: 'StephaneDucasse 2/14/2011 12:41'! buildMorphicCodePaneWith: editString "Construct the pane that shows the code. Respect StandardFonts codeFont." | codePane | codePane := self buildTextMorph.. editString ifNotNil: [codePane editString: editString. codePane hasUnacceptedEdits: true]. ^ codePane! ! !CodeHolder methodsFor: 'controls' stamp: 'AlainPlantec 12/1/2009 22:56'! decorateForInheritance "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." | aButton | (aButton := self inheritanceButton) ifNil: [^ self]. ((currentCompiledMethod isKindOf: CompiledMethod) and: [self class decorateBrowserButtons]) ifFalse: [^aButton offColor: Color transparent]. "This table duplicates the old logic, but adds two new colors for the cases where there is a superclass definition, but this method doesn't call it." aButton offColor: self color! ! !CodeHolder methodsFor: 'controls' stamp: 'sw 1/25/2001 14:44'! inheritanceButton "If receiver has an Inheritance button, answer it, else answer nil. morphic only at this point" ^ self buttonWithSelector: #methodHierarchy! ! !CodeHolder methodsFor: 'diffs' stamp: 'marcus.denker 9/20/2008 20:31'! togglePrettyDiffing "Toggle whether pretty-diffing should be shown in the code pane" | wasShowingDiffs | self okToChange ifTrue: [wasShowingDiffs := self showingPrettyDiffs. self showPrettyDiffs: wasShowingDiffs not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 19:43'! showingPlainSource "Answer whether the receiver is showing plain source" ^ contentsSymbol == #source! ! !CodeHolder methodsFor: 'self-updating' stamp: 'AlainPlantec 12/1/2009 22:36'! wantsStepsIn: aWindow ^ self class smartUpdating! ! !CodeHolder methodsFor: 'contents' stamp: 'MarcusDenker 4/26/2013 15:26'! contents "Answer the source code or documentation for the selected method" self showingByteCodes ifTrue: [^ self selectedBytecodes]. ^ self selectedMessage! ! !CodeHolder class methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/1/2009 22:55'! decorateBrowserButtons ^ DecorateBrowserButtons ifNil: [DecorateBrowserButtons := false]! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 11/24/2009 17:01'! showAnnotationPane: aBoolean ShowAnnotationPane := aBoolean! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 21:51'! diffsInChangeList: aBoolean DiffsInChangeList := aBoolean! ! !CodeHolder class methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/1/2009 22:55'! decorateBrowserButtons: aBoolean DecorateBrowserButtons := aBoolean! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 1/7/2010 21:49'! showAnnotationPane "Answer whether the receiver, seen in some browser window, would like to have the so-called annotationpane included. see also annotationRequests comment" ^ ShowAnnotationPane ifNil: [ShowAnnotationPane := false]! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 21:50'! diffsInChangeList ^ DiffsInChangeList ifNil: [DiffsInChangeList := true]! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/21/2009 22:21'! annotationRequests: aList "see annotationRequests comment" AnnotationRequests := aList! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/21/2009 22:21'! defaultAnnotationInfo "see annotationRequests comment" ^ #(timeStamp messageCategory sendersCount implementorsCount allChangeSets)! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 21:58'! diffsWithPrettyPrint: aBoolean DiffsWithPrettyPrint := aBoolean! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 11/24/2009 17:18'! browseWithPrettyPrint ^ BrowseWithPrettyPrint ifNil: [BrowseWithPrettyPrint := false]! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 11/24/2009 17:19'! browseWithPrettyPrint: aBoolean BrowseWithPrettyPrint := aBoolean! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 22:45'! optionalButtons: aBoolean OptionalButtons := aBoolean! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 21:59'! diffsWithPrettyPrint ^ DiffsWithPrettyPrint ifNil: [DiffsWithPrettyPrint := false]! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 22:34'! smartUpdating: aBoolean SmartUpdating := aBoolean! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/21/2009 22:20'! annotationRequests "Answer a list of symbol characterizing all the available kinds of annotations; Each symbol represents the info type: #timeStamp : The time stamp of the last submission of the method. #firstComment: The first comment in the method, if any. #masterComment: The comment at the beginning of the supermost implementor of the method if any. #documentation: Comment at beginning of the method or, if it has none, comment at the beginning of a superclass's implementation of the method. #messageCategory: Which method category the method lies in. #sendersCount: A report of how many senders there of the message. #implementorsCount: A report of how many implementors there are of the message. #recentChangeSet : The most recent change set bearing the method. #allChangeSets : A list of all change sets bearing the method. #priorVersionsCount: A report of how many previous versions there are of the method. #priorTimeStamp: The time stamp of the penultimate submission of the method, if any. " ^ AnnotationRequests ifNil: [AnnotationRequests := self defaultAnnotationInfo]! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 22:45'! optionalButtons ^ OptionalButtons ifNil: [OptionalButtons := true]! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 22:34'! smartUpdating ^ SmartUpdating ifNil: [SmartUpdating := true]! ! !CodeHolderSystemSettings commentStamp: 'TorstenBergmann 2/12/2014 23:30'! Settings for code holder! !CodeHolderSystemSettings class methodsFor: 'settings' stamp: 'FedericoScarpa 5/28/2011 13:46'! codeBrowsingSettingsOn: aBuilder (aBuilder group: #codeBrowsing) label: 'Code browsing' translated; target: CodeHolder; description: 'All settings concerned with code browsing look''n feel' translated; with: [ (aBuilder setting: #browseWithPrettyPrint) order: 1; label: 'Pretty print' translated; description: 'If checked then browsers automatically format their code' translated. (aBuilder setting: #showAnnotationPane) label: 'Show annotation pane' translated; description: 'If checked then the annotation pane is shown in browsers; it is dynamically updated with useful informations about the code which is currently browsed' translated. (aBuilder group: #ChangeSorter) label: 'Change sorter' translated; description: 'Change sorter specific settings' translated; with: [ (aBuilder setting: #mustCheckForSlips) target: ChangeSet; label: 'Check for slips' translated; description: 'If true, then whenever you file out a change set, it is checked for ''slips'' and if any are found, you are so informed and given a chance to open a browser on them' translated. (aBuilder setting: #diffsInChangeList) label: 'Exhibits differences' translated; description: 'If true, ChangeList browsers and Versions browsers will open up by default showing differences, i.e. revealing the differences between successive versions or between the in-memory code and the code on disk' translated; with: [ (aBuilder setting: #diffsWithPrettyPrint) label: 'Pretty print differences' translated; description: 'If true, displays of source code differences will be pretty-printed first' translated]]]! ! !CodeHolderSystemSettings class methodsFor: 'settings' stamp: 'IgorStasenko 10/7/2013 11:25'! codeEditingSettingsOn: aBuilder (aBuilder group: #codeEditing) label: 'Editing' translated; parent: #codeBrowsing; noOrdering; description: 'All settings concerned with text editing' translated; with: [ (aBuilder setting: #selectionColor) target: UITheme; targetSelector: #currentSettings; label: 'Selection color' translated. (aBuilder setting: #unfocusedSelectionColor) target: UITheme; targetSelector: #currentSettings; description: 'The color of the selection for unfocused windows' translated; label: 'Unfocused selection color' translated. (aBuilder setting: #selectionTextColor) target: UITheme; targetSelector: #currentSettings; label: 'Selection text color' translated; description: 'The color of the selection text' translated. (aBuilder setting: #useSelectionBar) target: TextEditor; label: 'Show the colored bar on the current line' translated; with: [ (aBuilder setting: #selectionBarColor) target: UITheme; targetSelector: #currentSettings; label: 'Selection bar color' translated]. (aBuilder setting: #useSecondarySelection) target: TextEditor; label: 'Use the secondary selection' translated; with: [ (aBuilder setting: #secondarySelectionColor) target: UITheme; targetSelector: #currentSettings; label: 'Secondary selection color' translated. (aBuilder setting: #secondarySelectionTextColor) target: UITheme; targetSelector: #currentSettings; label: 'Secondary selection text color' translated]. (aBuilder setting: #useFindReplaceSelection) target: TextEditor; label: 'Use the find and replace selection' translated; with: [ (aBuilder setting: #findReplaceSelectionColor) target: UITheme; targetSelector: #currentSettings; label: 'Find replace selection color' translated. (aBuilder setting: #findReplaceSelectionTextColor) target: UITheme; targetSelector: #currentSettings; label: 'Find replace selection text color' translated]. (aBuilder setting: #caseSensitiveFinds) label: 'Case sensitive search' translated; target: TextEditor; description: 'If true, then the "find" command in text will always make its searches in a case-sensitive fashion' translated. (aBuilder setting: #blinkingCursor) label: 'Blinking text cursor' translated; target: Editor; description: 'When true, the text cursor will blink.' translated. (aBuilder setting: #dumbbellCursor) label: 'Dumbbell-shaped text cursor' translated; target: Editor; description: 'When true, the text cursor assumes the shape of a dumbbell, otherwise a vertical bar.' translated. (aBuilder setting: #skipOverMultipleSpaces) label: 'Skip over white space' translated; target: Editor; description: 'When true, the text cursor treats multiple white-space characters as a single space for navigating (moving left/right).' translated. (aBuilder setting: #walkAlongDisplayedLine) label: 'Walk along displayed line' translated; target: TextEditor; description: 'If set to true cursor movement will move along displayed lines rather than logical lines' translated. (aBuilder setting: #smartUpdating) label: 'Smart updating' translated; target: CodeHolder; description: 'If true, then morphic tools such as browsers and inspectors will keep their contents up to date automatically, so that if something changes anywhere, the change will be reflected everywhere' translated. ] ! ! !CodeImporter commentStamp: ''! I'm an object in charge of import source files. I know a format object that knows how to parse the files, and I import the parsed results into the image. I handle doIts normally, but some special cases like class organization, class comment or methods are handled via a double dispatch (See my method extensions for that). =-=-=- How to use me -=-=-= If you want to fileIn the code -aka compile/evaluate it: CodeImporter evaluateReadStream: '2+2!!' readStream. or CodeImporter evaluateString: '2+2!!' or CodeImporter evaluateFileNamed: 'something.st' or CodeImporter evaluateFileStream: (FileStream readOnlyFileNamed: 'something.st') Now, you can also generate a model of code declarations inside a file by just creating an instance: CodeImporter fileStream: (FileStream readOnlyFileNamed: 'something.st'). And then query me sending the message #codeDeclarations Instances of me can be created through #fromString: #readStream: #fileNamed: #fileStream:! !CodeImporter methodsFor: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 01:12'! flushChangesFile "Yes, we need to do this in order to flush the file, puaj" Smalltalk logChange: '----End fileIn----'.! ! !CodeImporter methodsFor: '*System-CommandLine' stamp: 'CamilloBruni 3/23/2013 11:54'! shebang readStream position: 0. (readStream next: 2) = '#!!' ifFalse: [ readStream position: 0. ^ self ]. "here we found the shebang, so skip the first line" ^ readStream nextLine. ! ! !CodeImporter methodsFor: '*System-CommandLine' stamp: 'CamilloBruni 3/23/2013 11:54'! skipShebang "Skip the shebang sequnce #!! at the beginning of a bash file" readStream position = 0 ifFalse: [ ^ self "#!! can only be skipped at the beginning" ]. self shebang. ! ! !CodeImporter methodsFor: 'fileHandling' stamp: 'GuillermoPolito 5/5/2012 01:38'! selectTextConverterForCode self flag: #fix. "This should not be here probably." "We need to see the first three bytes in order to see the origin of the file" readStream binary. ((readStream next: 3) = #[ 16rEF 16rBB 16rBF ]) ifTrue: [ readStream converter: UTF8TextConverter new ] ifFalse: [ readStream converter: MacRomanTextConverter new. ]. "we restore the position to the start of the file again" readStream position: 0. "We put the file in text mode for the file in" readStream text.! ! !CodeImporter methodsFor: 'initialization' stamp: 'GuillermoPolito 5/5/2012 17:06'! initialize codeDeclarations := OrderedCollection new. parserClass := ChunkFileFormatParser.! ! !CodeImporter methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2013 16:13'! requestor ^ requestor! ! !CodeImporter methodsFor: '*System-CommandLine' stamp: 'CamilloBruni 7/10/2013 16:16'! evaluate " stripped down version of evaluateDeclarations" | value | self codeDeclarations do: [ :declaration | requestor ifNotNil: [ requestor contents: declaration contents ]. value := declaration importFor: requestor ]. self flushChangesFile. ^value! ! !CodeImporter methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 16:12'! codeDeclarations ^codeDeclarations! ! !CodeImporter methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 01:39'! readStream: aReadStream readStream := aReadStream.! ! !CodeImporter methodsFor: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 17:17'! parseDeclarations codeDeclarations := (parserClass for: readStream) parseDeclarations.! ! !CodeImporter methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2013 16:13'! requestor: anObject requestor := anObject! ! !CodeImporter methodsFor: 'evaluating' stamp: 'CamilloBruni 7/10/2013 18:44'! evaluateDeclarations "Evaluates the declarations from the text in the file and answers the last result" | value | self parseDeclarations. self codeDeclarations do: [ :declaration | requestor ifNotNil: [ requestor contents: declaration contents ]. value := declaration importFor: requestor ]. self flushChangesFile. ^value! ! !CodeImporter methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2013 16:03'! file: aFileStream self readStream: aFileStream. self selectTextConverterForCode. self requestor: (FileCompilerRequestor fileStream: aFileStream).! ! !CodeImporter class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 17:23'! fileNamed: aFileName ^self file: (FileStream readOnlyFileNamed: aFileName). ! ! !CodeImporter class methodsFor: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 17:23'! evaluateFileStream: aFileStream ^(self fileStream: aFileStream) evaluateDeclarations! ! !CodeImporter class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 17:23'! fileStream: aFileStream ^self new file: aFileStream; yourself! ! !CodeImporter class methodsFor: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 17:25'! evaluateString: aString ^(self fromString: aString) evaluateDeclarations! ! !CodeImporter class methodsFor: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 17:23'! evaluateFileNamed: aFileName ^(self fileNamed: aFileName) evaluateDeclarations! ! !CodeImporter class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 17:24'! readStream: aReadStream ^self new readStream: aReadStream; yourself! ! !CodeImporter class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 17:25'! fromString: aByteString ^self readStream: aByteString readStream! ! !CodeImporter class methodsFor: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 17:25'! evaluateReadStream: aReadStream ^(self readStream: aReadStream) evaluateDeclarations! ! !CodeRewritingAcceptor commentStamp: ''! I am an acceptor in the context of code rewriting using RBTreeRewriting! !CodeRewritingAcceptor methodsFor: 'protocol' stamp: 'MarcusDenker 5/21/2013 07:38'! accept: aText notifying: aController | environment tree rule result | self model sourceTextArea update: #clearUserEdits. environment := self model browsedEnvironment. tree := self class compiler evaluate: aText. rule := CodeRewritingRule new rewriteRule: tree; yourself. result := RBSmalllintChecker runRule: rule onEnvironment: environment. (ChangesBrowser changes: result builder changes) openWithSpec ! ! !CodeRewritingRule commentStamp: ''! I am a lint rule for Code Rewrinting! !CodeRewritingRule methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/16/2013 17:48'! name ^ 'Code Rewriting'! ! !CodeRewritingRule methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/16/2013 17:48'! rewriteRule: aRule rewriteRule := aRule! ! !CodeSimulationTests commentStamp: 'TorstenBergmann 2/5/2014 08:31'! SUnit tests for code simulation! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/8/2010 00:39'! testDNU self should: [ self runSimulated: [self absentMethod] ] raise: MessageNotUnderstood! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'dik 5/23/2010 18:00'! methodWithError self error: 'my error'! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/7/2010 22:30'! testTranscriptPrintingWithOpenedTranscriptExists self runSimulated: [self methodWithTranscript] ! ! !CodeSimulationTests methodsFor: 'tests - primitives' stamp: ''! testErrorCodeNotFound | ctx result resultSimu | Smalltalk vm isRunningCog ifFalse: [^self]. result := self veryBasicAt: 1. ctx := MethodContext sender: nil receiver: nil method: (Object>>#at: ) arguments: #(10). resultSimu := ctx push: nil; push: 500; doPrimitive: 117 method: (self class>>#veryBasicAt:) receiver: self args: #(999). self assert: resultSimu isArray. self assert: ContextPart primitiveFailToken first == resultSimu first. self assert: result = resultSimu second.! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/7/2010 22:30'! testTranscriptPrinting self runSimulated: [self methodWithTranscript] ! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'dik 5/23/2010 17:58'! methodWithHalt self halt! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/8/2010 00:35'! testError self should: [ self runSimulated: [self methodWithError] ] raise: Error! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'dik 5/23/2010 18:03'! methodWithTranscript Transcript show: 'something'! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'dik 5/23/2010 17:57'! runSimulated: aBlock thisContext runSimulated: aBlock contextAtEachStep: [ :current | ]! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/8/2010 00:35'! testHalt self should: [ self runSimulated: [self methodWithHalt] ] raise: Halt! ! !CodeSimulationTests methodsFor: 'private' stamp: ''! indexedBasicAt: index ^ code ! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/7/2010 22:30'! testGoodSimulation self runSimulated: [ 1 + 2 ].! ! !CodeSimulationTests methodsFor: 'tests - primitives' stamp: ''! testErrorToken | token1 token2 | token1 := ContextPart primitiveFailToken. token2 := ContextPart primitiveFailTokenFor: 100. self assert: token1 first == token2 first. self assert: token1 second == nil. self assert: token2 second == 100.! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/7/2010 22:30'! testErrorWithErrorHandler self runSimulated: [[self methodWithError] on: Error do: [:err | ]] ! ! !CodeSimulationTests methodsFor: 'tests - primitives' stamp: ''! testErrorCodeNotFoundIndexed | ctx result resultSimu | Smalltalk vm isRunningCog ifFalse: [^self]. result := self indexedBasicAt: 100. ctx := MethodContext sender: nil receiver: nil method: (Object>>#at: ) arguments: #(10). resultSimu := ctx push: nil; push: 500; doPrimitive: 60 method: (self class>>#indexedBasicAt:) receiver: self args: #(100). self assert: resultSimu isArray. self assert: resultSimu size = 2. self assert: ContextPart primitiveFailToken first == resultSimu first. self assert: result = resultSimu second.! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/7/2010 22:30'! testHaltWithHaltHandler self runSimulated: [[self methodWithHalt] on: Halt do: [:err |]] ! ! !CodeSimulationTests methodsFor: 'private' stamp: ''! veryBasicAt: index ^ code ! ! !CollapsedMorph methodsFor: 'resize/collapse' stamp: 'sw 6/5/2001 22:55'! wantsExpandBox "Answer whether I'd like an expand box" ^ false! ! !CollapsedMorph methodsFor: 'resize/collapse' stamp: 'sw 9/1/2000 11:07'! collapseOrExpand "Toggle the expand/collapsd state of the receiver. If expanding, copy the window title back to the name of the expanded morph" | aWorld | isCollapsed ifTrue: [uncollapsedMorph setProperty: #collapsedPosition toValue: self position. labelString ifNotNil: [uncollapsedMorph setNameTo: labelString]. mustNotClose := false. "We're not closing but expanding" self delete. (aWorld := self currentWorld) addMorphFront: uncollapsedMorph. aWorld startSteppingSubmorphsOf: uncollapsedMorph] ifFalse: [super collapseOrExpand]! ! !CollapsedMorph methodsFor: 'collapse/expand' stamp: 'sw 5/9/2000 00:18'! beReplacementFor: aMorph | itsWorld priorPosition | (itsWorld := aMorph world) ifNil: [^self]. uncollapsedMorph := aMorph. self setLabel: aMorph externalName. aMorph delete. itsWorld addMorphFront: self. self collapseOrExpand. (priorPosition := aMorph valueOfProperty: #collapsedPosition ifAbsent: [nil]) ifNotNil: [self position: priorPosition]. ! ! !CollapsedMorph methodsFor: 'menu' stamp: 'StephaneDucasse 2/25/2011 18:42'! buildWindowMenu "Answer the menu to be put up in response to the user's clicking on the window-menu control in the window title. Specialized for CollapsedMorphs." | aMenu | aMenu := UIManager default newMenuIn: self for: self. aMenu add: 'Change name...' translated action: #relabel. aMenu addLine. aMenu add: 'Send to back' translated action: #sendToBack. aMenu add: 'Make next-to-topmost' translated action: #makeSecondTopmost. aMenu addLine. self mustNotClose ifFalse: [aMenu add: 'Make unclosable' translated action: #makeUnclosable] ifTrue: [aMenu add: 'Make closable' translated action: #makeClosable]. aMenu add: (self isSticky ifTrue: ['Make draggable'] ifFalse: ['Make undraggable']) translated action: #toggleStickiness. ^aMenu! ! !CollapsedMorph methodsFor: 'collapse/expand' stamp: 'sw 4/9/2001 14:23'! uncollapseToHand "Hand the uncollapsedMorph to the user, placing it in her hand, after remembering appropriate state for possible future use" | nakedMorph | nakedMorph := uncollapsedMorph. uncollapsedMorph := nil. nakedMorph setProperty: #collapsedPosition toValue: self position. mustNotClose := false. "so the delete will succeed" self delete. ActiveHand attachMorph: nakedMorph! ! !CollectVisitor commentStamp: 'cwp 11/18/2009 12:32'! I am a visitor that collects objects from the nodes I visit. I take a block similar to those passed to Collection>>collect:. I evaluate the block with DirectoryEntries for the nodes I visit, and collect the objects answered into an array. I can use any guide, and the objects in the array I produce will reflect the order imposed by the guide.! !CollectVisitor methodsFor: 'visiting' stamp: 'cwp 11/16/2009 10:38'! visitReference: anEntry out nextPut: (block value: anEntry)! ! !CollectVisitor class methodsFor: 'instance creation' stamp: 'cwp 11/16/2009 10:35'! preorder: aReference ^ self preorder: aReference collect: [:entry | entry]! ! !CollectVisitor class methodsFor: 'instance creation' stamp: 'cwp 11/16/2009 10:39'! collect: aBlock ^ self basicNew initializeWithBlock: aBlock! ! !CollectVisitor class methodsFor: 'instance creation' stamp: 'cwp 11/16/2009 10:36'! postorder: aReference ^ self postorder: aReference collect: [:entry | entry]! ! !CollectVisitor class methodsFor: 'instance creation' stamp: 'cwp 11/16/2009 10:32'! breadthFirst: aReference collect: aBlock ^ (self collect: aBlock) breadthFirst: aReference! ! !CollectVisitor class methodsFor: 'instance creation' stamp: 'cwp 11/16/2009 10:36'! preorder: aReference collect: aBlock ^ (self collect: aBlock) preorder: aReference! ! !CollectVisitor class methodsFor: 'instance creation' stamp: 'cwp 11/16/2009 10:35'! postorder: aReference collect: aBlock ^ (self collect: aBlock) postorder: aReference! ! !CollectVisitor class methodsFor: 'instance creation' stamp: 'cwp 11/16/2009 10:33'! breadthFirst: aReference ^ self breadthFirst: aReference collect: [:entry | entry]! ! !CollectVisitorTest commentStamp: 'TorstenBergmann 1/31/2014 11:41'! SUnit tests for class CollectVisitor! !CollectVisitorTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:40'! testPostorder | entries | entries := CollectVisitor postorder: self root. self assertEntries: entries are: #( '/alpha/beta/delta' '/alpha/beta/gamma' '/alpha/beta' '/alpha/epsilon/zeta' '/alpha/epsilon' '/alpha' )! ! !CollectVisitorTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:40'! testBreadthFirst | entries | entries := CollectVisitor breadthFirst: self root. self assertEntries: entries are: #( '/alpha' '/alpha/beta' '/alpha/epsilon' '/alpha/beta/delta' '/alpha/beta/gamma' '/alpha/epsilon/zeta' )! ! !CollectVisitorTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:40'! testPreorder | entries | entries := CollectVisitor preorder: self root. self assertEntries: entries are: #( '/alpha' '/alpha/beta' '/alpha/beta/delta' '/alpha/beta/gamma' '/alpha/epsilon' '/alpha/epsilon/zeta' )! ! !Collection commentStamp: ''! I am the abstract superclass of all classes that represent a group of elements.! !Collection methodsFor: 'testing' stamp: 'bf 3/10/2000 09:29'! isEmptyOrNil "Answer whether the receiver contains any elements, or is nil. Useful in numerous situations where one wishes the same reaction to an empty collection or to nil" ^ self isEmpty! ! !Collection methodsFor: 'enumerating' stamp: 'nice 1/5/2010 15:59'! detectMin: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the element for which aBlock evaluates to the lowest number. If collection empty, return nil." | minElement minValue | self do: [:each | | val | minValue == nil ifFalse: [ (val := aBlock value: each) < minValue ifTrue: [ minElement := each. minValue := val]] ifTrue: ["first element" minElement := each. minValue := aBlock value: each]. "Note that there is no way to get the first element that works for all kinds of Collections. Must test every one."]. ^ minElement! ! !Collection methodsFor: 'enumerating' stamp: 'GabrielOmarCotelli 11/26/2013 17:15'! detect: aBlock ifNone: exceptionBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the first element for which aBlock evaluates to true. If none evaluate to true, then evaluate the argument, exceptionBlock." ^ self detect: aBlock ifFound: [ :element | element ] ifNone: exceptionBlock! ! !Collection methodsFor: '*metacello-core-scripting' stamp: 'dkh 9/5/2012 06:26:03.064'! execute: projectSpecBlock against: aScriptExecutor aScriptExecutor executeCollection: self do: projectSpecBlock! ! !Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:21'! add: newObject withOccurrences: anInteger "Add newObject anInteger times to the receiver. Answer newObject." anInteger timesRepeat: [self add: newObject]. ^ newObject! ! !Collection methodsFor: 'enumerating' stamp: 'CamilloBruni 3/22/2013 22:32'! reject: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Collect into a new collection like the receiver only those elements for which aBlock evaluates to false. Answer the new collection." ^self select: [ :element | (aBlock value: element) == false ]! ! !Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:43'! asOrderedCollection "Answer an OrderedCollection whose elements are the elements of the receiver. The order in which elements are added depends on the order in which the receiver enumerates its elements. In the case of unordered collections, the ordering is not necessarily the same for multiple requests for the conversion." ^ self as: OrderedCollection! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:20'! degreeCos ^self collect: [:each | each degreeCos]! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'di 11/6/1998 13:54'! \\ arg ^ arg adaptToCollection: self andSend: #\\! ! !Collection methodsFor: 'testing' stamp: 'ls 3/27/2000 17:25'! identityIncludes: anObject "Answer whether anObject is one of the receiver's elements." self do: [:each | anObject == each ifTrue: [^true]]. ^false! ! !Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:00'! median ^ self asSortedCollection median! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'di 11/6/1998 13:54'! // arg ^ arg adaptToCollection: self andSend: #//! ! !Collection methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 6/28/2013 13:02'! asShortcut ^ self asKeyCombination! ! !Collection methodsFor: 'private' stamp: ''! emptyCheck self isEmpty ifTrue: [self errorEmptyCollection]! ! !Collection methodsFor: 'testing' stamp: 'CamilloBruni 9/8/2011 14:18'! includesAll: aCollection "Answer whether all the elements of aCollection are in the receiver." aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]]. ^ true! ! !Collection methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! loadRequiredForMetacelloMCVersion: aMetacelloMCVersion ^aMetacelloMCVersion doLoadRequiredFromArray: self.! ! !Collection methodsFor: 'enumerating' stamp: 'StephaneDucasse 3/14/2014 20:54'! difference: aCollection "Answer the set theoretic difference of two collections." "#(a b c d e f) difference: #(a b z k) => #(#f #d #e #c) #(a b z k) difference: #(a b c d e f) => #(#k #z) " | set | set := self asSet. aCollection do: [ :each | set remove: each ifAbsent: [ ] ]. ^ self species withAll: set asArray! ! !Collection methodsFor: 'enumerating' stamp: 'CamilloBruni 3/23/2013 10:46'! reject: rejectBlock thenDo: doBlock "Utility method to improve readability." (self reject: rejectBlock) do: doBlock! ! !Collection methodsFor: 'testing' stamp: 'ul 11/11/2009 16:24'! ifEmpty: emptyBlock ifNotEmptyDo: notEmptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" "Evaluate the notEmptyBlock with the receiver as its argument" self isEmpty ifTrue: [ ^emptyBlock value ]. ^notEmptyBlock value: self! ! !Collection methodsFor: 'sorting' stamp: 'StephaneDucasse 3/28/2010 22:42'! sorted: aSortBlockOrNil "Return a new sequenceable collection which contains the same elements as self but its elements are sorted by aSortBlockOrNil. The block should take two arguments and return true if the first element should preceed the second one. If aSortBlock is nil then <= is used for comparison." ^self asArray sort: aSortBlockOrNil! ! !Collection methodsFor: 'testing' stamp: 'MarcusDenker 7/17/2013 13:15'! isNotEmpty "Answer whether the receiver contains any elements." ^ self isEmpty not! ! !Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:22'! asArray "Answer an Array whose elements are the elements of the receiver. Implementation note: Cannot use ''Array withAll: self'' as that only works for SequenceableCollections which support the replacement primitive." | array index | array := Array new: self size. index := 0. self do: [:each | array at: (index := index + 1) put: each]. ^ array! ! !Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:41'! capacity "Answer the current capacity of the receiver." ^ self size! ! !Collection methodsFor: 'accessing' stamp: 'sd 11/4/2003 22:05'! atRandom "Answer a random element of the receiver. Uses a shared random number generator owned by class Collection. If you use this a lot, define your own instance of Random and use #atRandom:. Causes an error if self has no elements." ^ self class mutexForPicking critical: [ self atRandom: self class randomForPicking ] "Examples: #('one' 'or' 'the' 'other') atRandom (1 to: 10) atRandom 'Just pick one of these letters at random' atRandom #(3 7 4 9 21) asSet atRandom (just to show it also works for Sets) "! ! !Collection methodsFor: 'enumerating' stamp: 'nice 1/5/2010 15:59'! detectMax: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the element for which aBlock evaluates to the highest magnitude. If collection empty, return nil. This method might also be called elect:." | maxElement maxValue | self do: [:each | | val | maxValue == nil ifFalse: [ (val := aBlock value: each) > maxValue ifTrue: [ maxElement := each. maxValue := val]] ifTrue: ["first element" maxElement := each. maxValue := aBlock value: each]. "Note that there is no way to get the first element that works for all kinds of Collections. Must test every one."]. ^ maxElement! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:52'! negated "Negated value of all elements in the collection" ^ self collect: [:a | a negated]! ! !Collection methodsFor: 'math functions' stamp: 'MarcusDenker 8/15/2010 11:01'! stdev | avg sample sum | avg := self average. "see comment in self sum" sample := self anyOne. sum := self inject: sample into: [:accum :each | accum + (each - avg) squared]. sum := sum - sample. ^ (sum / (self size - 1)) sqrt! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:21'! exp ^self collect: [:each | each exp]! ! !Collection methodsFor: 'enumerating' stamp: 'CamilloBruni 3/22/2013 22:09'! reject: rejectBlock thenCollect: collectBlock "Utility method to improve readability." ^ (self reject: rejectBlock) collect: collectBlock! ! !Collection methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! copyWithDependent: newElement "Answer a new collection with newElement added (as last element if sequenceable)." ^self copyWith: newElement! ! !Collection methodsFor: 'converting' stamp: 'ar 9/22/2000 10:12'! asIdentitySet ^(IdentitySet new: self size) addAll: self; yourself! ! !Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:52'! count: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the number of elements that answered true." | sum | sum := 0. self do: [:each | (aBlock value: each) ifTrue: [sum := sum + 1]]. ^ sum! ! !Collection methodsFor: 'enumerating' stamp: 'CamilloBruni 3/22/2013 22:30'! collect: collectBlock thenReject: selectBlock "Utility method to improve readability." ^ (self collect: collectBlock) reject: selectBlock! ! !Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:26'! asCharacterSet "Answer a CharacterSet whose elements are the unique elements of the receiver. The reciever should only contain characters." ^ CharacterSet newFrom: self! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 6/6/2009 10:08'! setRequiresInMetacelloPackage: aMetacelloPackageSpec aMetacelloPackageSpec setRequires: self asArray.! ! !Collection methodsFor: 'enumerating' stamp: 'AdrianKuhn 12/30/2009 09:37'! groupedBy: aBlock having: aSelectionBlock "Like in SQL operation - Split the recievers contents into collections of elements for which keyBlock returns the same results, and return those collections allowed by selectBlock." ^ (self groupedBy: aBlock) select: aSelectionBlock ! ! !Collection methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/18/2011 14:59'! errorEmptyCollection "Signal a CollectionIsEmpty exception" CollectionIsEmpty signalWith: self! ! !Collection methodsFor: 'enumerating' stamp: 'TudorGirba 11/3/2013 12:12'! flatCollect: aBlock "Evaluate aBlock for each of the receiver's elements and answer the list of all resulting values flatten one level. Assumes that aBlock returns some kind of collection for each element. Equivalent to the lisp's mapcan" | stream | self isEmpty ifTrue: [ ^ self copy ]. stream := (self species new: 0) writeStream. self do: [ :each | stream nextPutAll: (aBlock value: each) ]. ^ stream contents! ! !Collection methodsFor: 'enumerating' stamp: 'GabrielOmarCotelli 11/26/2013 16:53'! detect: aBlock ifFound: foundBlock ifNone: exceptionBlock "Evaluate aBlock with each of the receiver's elements as the argument. If some element evaluates aBlock to true, then cull this element into foundBlock and answer the result of this evaluation. If none evaluate to true, then evaluate exceptionBlock." self do: [ :each | (aBlock value: each) ifTrue: [ ^ foundBlock cull: each ] ]. ^ exceptionBlock value ! ! !Collection methodsFor: 'adapting' stamp: 'di 11/9/1998 12:16'! adaptToNumber: rcvr andSend: selector "If I am involved in arithmetic with a scalar, return a Collection of the results of each element combined with the scalar in that expression." ^ self collect: [:element | rcvr perform: selector with: element]! ! !Collection methodsFor: 'printing' stamp: 'fbs 1/14/2005 10:54'! printOn: aStream delimiter: delimString last: lastDelimString "Print elements on a stream separated with a delimiter between all the elements and with a special one before the last like: 'a, b and c' Note: Feel free to improve the code to detect the last element." | n sz | n := 1. sz := self size. self do: [:elem | n := n + 1. aStream print: elem] separatedBy: [ n = sz ifTrue: [aStream print: lastDelimString] ifFalse: [aStream print: delimString]]! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 9/23/2009 08:46'! setIncludesInMetacelloPackage: aMetacelloPackageSpec aMetacelloPackageSpec setIncludes: self asArray.! ! !Collection methodsFor: 'enumerating' stamp: 'StephaneDucasse 5/20/2012 18:50'! piecesCutWhere: binaryBlock do: pieceBlock "Evaluate pieceBlock with substrings of the receiver derived from cutting the receiver at points where binaryBlock answers true for adjacent elements." | size lastCut this next | (size := self size) <= 1 ifTrue: [size = 1 ifTrue: [pieceBlock value: self]. ^self]. lastCut := 1. this := self at: 1. 2 to: size do: [:i| next := self at: i. (binaryBlock value: this value: next) ifTrue: [pieceBlock value: (self copyFrom: lastCut to: i - 1). lastCut := i]. this := next]. pieceBlock value: (self copyFrom: lastCut to: size)! ! !Collection methodsFor: 'testing' stamp: 'ar 8/17/1999 19:43'! isCollection "Return true if the receiver is some sort of Collection and responds to basic collection messages such as #size and #do:" ^true! ! !Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:22'! asByteArray "Answer a ByteArray whose elements are the elements of the receiver. Implementation note: Cannot use ''ByteArray withAll: self'' as that only works for SequenceableCollections which support the replacement primitive." | array index | array := ByteArray new: self size. index := 0. self do: [:each | array at: (index := index + 1) put: each]. ^ array! ! !Collection methodsFor: 'testing' stamp: ''! contains: aBlock "VW compatibility" ^self anySatisfy: aBlock! ! !Collection methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! addToMetacelloRepositories: aMetacelloRepositoriesSpec self do: [:each | each addToMetacelloRepositories: aMetacelloRepositoriesSpec ] ! ! !Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:20'! asCommaStringAnd "Return collection printed as 'a, b and c' " ^String streamContents: [:s | self asStringOn: s delimiter: ', ' last: ' and '] ! ! !Collection methodsFor: 'adapting' stamp: 'di 11/6/1998 13:37'! adaptToString: rcvr andSend: selector "If I am involved in arithmetic with a String, convert it to a Number." ^ rcvr asNumber perform: selector with: self! ! !Collection methodsFor: 'testing' stamp: ''! occurrencesOf: anObject "Answer how many of the receiver's elements are equal to anObject." | tally | tally := 0. self do: [:each | anObject = each ifTrue: [tally := tally + 1]]. ^tally! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:23'! sign ^self collect: [:each | each sign]! ! !Collection methodsFor: 'enumerating' stamp: 'SebastianTleye 6/25/2013 18:41'! flattened "Flattens a collection of collections (no matter how many levels of collections exist). Strings are considered atoms and, as such, won't be flattened Examples: #(1 #(2 3) #(4 (#5))) flattened returns #(1 2 3 4 5) #('string1' #('string2' 'string3')) flattened returns #('string1' 'string2' 'string3')" ^ Array streamContents: [ :stream | self flattenOn: stream].! ! !Collection methodsFor: 'testing' stamp: 'StephaneDucasse 7/3/2010 22:15'! ifEmpty: aBlock "Evaluate the given block with the receiver as argument, answering its value if the receiver is empty, otherwise answer the receiver." "Note that the fact that this method returns its argument in case the receiver is not empty allows one to write expressions like the following ones: self classifyMethodAs: (myProtocol ifEmpty: ['As yet unclassified'])" ^ self isEmpty ifTrue: [ ^aBlock value ] ifFalse: [ self ]! ! !Collection methodsFor: 'enumerating' stamp: 'nice 12/9/2009 15:37'! findFirstInByteString: aByteString startingAt: start "Find the index of first character starting at start in aByteString that is included in the receiver. Default is to use a naive algorithm. Subclasses might want to implement a more efficient scheme" start to: aByteString size do: [:index | (self includes: (aByteString at: index)) ifTrue: [^ index]]. ^ 0! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'di 11/6/1998 13:53'! + arg ^ arg adaptToCollection: self andSend: #+! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:22'! tan ^self collect: [:each | each tan]! ! !Collection methodsFor: 'enumerating' stamp: 'StephaneDucasse 1/3/2010 20:15'! groupBy: keyBlock having: selectBlock "This message is deprecated. Please use groupedBy:having:. But we let it right now without warning because we are not sure to remove in the next iteration." ^ self groupedBy: keyBlock having: selectBlock ! ! !Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:41'! printOn: aStream "Append a sequence of characters that identify the receiver to aStream." self printNameOn: aStream. self printElementsOn: aStream! ! !Collection methodsFor: 'private' stamp: ''! toBraceStack: itsSize "Push receiver's elements onto the stack of thisContext sender. Error if receiver does not have itsSize elements or if receiver is unordered. Do not call directly: this is called by {a. b} := ... constructs." self size ~= itsSize ifTrue: [self error: 'Trying to store ', self size printString, ' values into ', itsSize printString, ' variables.']. thisContext sender push: itsSize fromIndexable: self! ! !Collection methodsFor: 'enumerating' stamp: 'jannik.laval 8/27/2010 15:54'! flatCollect: aBlock as: aCollectionClass "Evaluate aBlock for each of the receiver's elements and answer the list of all resulting values flatten one level. Assumes that aBlock returns some kind of collection for each element. Equivalent to the lisp's mapcan" | col | self isEmpty ifTrue: [^self copy ]. col := aCollectionClass new: self size. self do: [ :each | col addAll: (aBlock value: each) ]. ^col! ! !Collection methodsFor: '*Fuel' stamp: 'MartinDias 5/19/2011 23:41'! addIfNotPresent: anObject ifPresentDo: aBlock "Include anObject as one of the receiver's elements and then value aBlock, but only if there is no such element already. Anwser anObject." (self includes: anObject) ifFalse: [ self add: anObject ] ifTrue: [ aBlock value ]. ^ anObject! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'TAG 11/6/1998 16:02'! sum "This is implemented using a variant of the normal inject:into: pattern. The reason for this is that it is not known whether we're in the normal number line, i.e. whether 0 is a good initial value for the sum. Consider a collection of measurement objects, 0 would be the unitless value and would not be appropriate to add with the unit-ed objects." | sum sample | sample := self anyOne. sum := self inject: sample into: [:accum :each | accum + each]. ^ sum - sample! ! !Collection methodsFor: 'converting' stamp: 'MarcusDenker 11/28/2009 11:40'! asDictionary ^ self as: Dictionary! ! !Collection methodsFor: 'adapting' stamp: 'di 11/6/1998 13:37'! adaptToPoint: rcvr andSend: selector "If I am involved in arithmetic with a scalar, return a Collection of the results of each element combined with the scalar in that expression." ^ self collect: [:element | rcvr perform: selector with: element]! ! !Collection methodsFor: 'enumerating' stamp: 'hfm 2/12/2009 13:38'! select: selectBlock thenDo: doBlock "Utility method to improve readability. Do not create the intermediate collection." self do: [: each | ( selectBlock value: each ) ifTrue: [ doBlock value: each ] ].! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'nk 12/30/2003 15:47'! roundTo: quantum ^self collect: [ :ea | ea roundTo: quantum ]! ! !Collection methodsFor: 'enumerating' stamp: 'CamilloBruni 3/22/2013 22:20'! piecesCutWhere: binaryBlock "Answer substrings of the receiver derived from cutting the receiver at points where binaryBlock answers true for adjacent elements." | pieces | pieces := OrderedCollection new. self piecesCutWhere: binaryBlock do: [ :piece | pieces add: piece ]. ^pieces "'Now is the time for all good people to come to the aid of the cause of world peace. It is just fine, even desirable, to love your country, if that means wanting it to play a beneficial role in the course of world events and be the best possible example of a good society. But if it means wanting dominion over the rest of the world, it is not love but defensiveness or self-glorification, and will lead only to oblivion.' piecesCutWhere: [:a :b| a = $. and: [b isSeparator]]"! ! !Collection methodsFor: 'enumerating' stamp: 'CamilloBruni 9/7/2011 19:24'! | aCollection ^ self union: aCollection! ! !Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:19'! asCommaString "Return collection printed as 'a, b, c' " ^String streamContents: [:s | self asStringOn: s delimiter: ', '] ! ! !Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:34'! size "Answer how many elements the receiver contains." | tally | tally := 0. self do: [:each | tally := tally + 1]. ^ tally! ! !Collection methodsFor: 'private' stamp: 'yo 6/29/2004 13:14'! errorNotKeyed self error: ('Instances of {1} do not respond to keyed accessing messages.' translated format: {self class name}) ! ! !Collection methodsFor: 'printing' stamp: ''! storeOn: aStream "Refer to the comment in Object|storeOn:." | noneYet | aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' new)'. noneYet := true. self do: [:each | noneYet ifTrue: [noneYet := false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' add: '. aStream store: each]. noneYet ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !Collection methodsFor: 'testing' stamp: 'EstebanLorenzano 8/17/2012 16:40'! includesSubstringAnywhere: testString "Answer whether the receiver includes, anywhere in its nested structure, a string that has testString as a substring" self do: [:element | (element isString) ifTrue: [(element includesSubstring: testString) ifTrue: [^ true]]. (element isCollection) ifTrue: [(element includesSubstringAnywhere: testString) ifTrue: [^ true]]]. ^ false "#(first (second third) ((allSentMessages ('Elvis' includes:)))) includesSubstringAnywhere: 'lvi'"! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:21'! degreeSin ^self collect: [:each | each degreeSin]! ! !Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:14'! remove: oldObject ifAbsent: anExceptionBlock "Remove oldObject from the receiver's elements. If several of the elements are equal to oldObject, only one is removed. If no element is equal to oldObject, answer the result of evaluating anExceptionBlock. Otherwise, answer the argument, oldObject. ArrayedCollections cannot respond to this message." self subclassResponsibility! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:53'! sqrt ^ self collect: [:each | each sqrt]! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'TAG 11/6/1998 16:00'! min ^ self inject: self anyOne into: [:min :each | min min: each]! ! !Collection methodsFor: 'copying' stamp: 'CamilloBruni 10/20/2012 21:49'! copyEmpty ^ self species new! ! !Collection methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 3/19/2013 19:12'! asKeyCombination | shortcut | self size = 1 ifTrue: [ ^self first asKeyCombination ]. shortcut := KMKeyCombinationSequence new. self do: [ :each | shortcut addShortcut: each asKeyCombination ]. ^shortcut.! ! !Collection methodsFor: 'enumerating' stamp: 'TudorGirba 11/3/2013 12:12'! flatCollectAsSet: aBlock "Evaluate aBlock for each of the receiver's elements and answer the list of all resulting values flatten one level. Assumes that aBlock returns some kind of collection for each element. Equivalent to the lisp's mapcan" ^ self flatCollect: aBlock as: Set! ! !Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:27'! asStringOn: aStream delimiter: delimString "Print elements on a stream separated with a delimiter String like: 'a, b, c' Uses #asString instead of #print:." self do: [:elem | aStream nextPutAll: elem asString] separatedBy: [aStream nextPutAll: delimString]! ! !Collection methodsFor: 'testing' stamp: 'sma 5/12/2000 14:07'! includes: anObject "Answer whether anObject is one of the receiver's elements." ^ self anySatisfy: [:each | each = anObject]! ! !Collection methodsFor: 'enumerating' stamp: 'TudorGirba 3/20/2012 09:07'! intersection: aCollection "Answer the set theoretic intersection of two collections." | set outputSet | set := self asSet. outputSet := Set new. aCollection do: [ :each| ((set includes: each) and: [(outputSet includes: each) not]) ifTrue: [ outputSet add: each]]. ^ self species withAll: outputSet asArray! ! !Collection methodsFor: 'testing' stamp: 'StephaneDucasse 7/3/2010 22:10'! ifNotEmpty: aBlock "Evaluate the given block with the receiver as argument, answering its value unless the receiver is empty, in which case answer the receiver If the block has an argument, eval with the receiver as its argument, but it might be better to use ifNotEmptyDo: to make the code easier to understand" "Note that the fact that this method returns its argument in case the receiver is empty allows one to write expressions like the following ones: self classifyMethodAs: (myProtocol ifEmpty: ['As yet unclassified']" ^self isEmpty ifTrue: [self] ifFalse: [aBlock cull: self] ! ! !Collection methodsFor: 'private' stamp: 'ul 11/21/2009 01:14'! fillFrom: aCollection with: aBlock "Evaluate aBlock with each of aCollections's elements as the argument. Collect the resulting values into self. Answer self." aCollection do: [ :each | self add: (aBlock value: each) ]! ! !Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:29'! asSet "Answer a Set whose elements are the unique elements of the receiver." ^ Set withAll: self! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'raok 10/22/2002 00:17'! raisedTo: arg ^ arg adaptToCollection: self andSend: #raisedTo:! ! !Collection methodsFor: 'testing' stamp: 'ClementBera 12/2/2013 12:41'! includesAllOf: aCollection self flag: 'use includesAll: instead'. ^ self includesAll: aCollection.! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 9/8/2012 05:30'! asMetacelloAttributePath ^ MetacelloMethodSectionPath withAll: self! ! !Collection methodsFor: 'enumerating' stamp: 'sma 4/30/2000 11:17'! allSatisfy: aBlock "Evaluate aBlock with the elements of the receiver. If aBlock returns false for any element return false. Otherwise return true." self do: [:each | (aBlock value: each) ifFalse: [^ false]]. ^ true! ! !Collection methodsFor: 'testing' stamp: 'CamilloBruni 9/8/2011 14:18'! includesAny: aCollection "Answer whether any element of aCollection is one of the receiver's elements." aCollection do: [:elem | (self includes: elem) ifTrue: [^ true]]. ^ false! ! !Collection methodsFor: 'enumerating' stamp: 'StephaneDucasse 2/1/2011 07:34'! fold: binaryBlock "Evaluate the block with the first two elements of the receiver, then with the result of the first evaluation and the next element, and so on. Answer the result of the final evaluation. If the receiver is empty, raise an error. If the receiver has a single element, answer that element." "#('if' 'it' 'is' 'to' 'be' 'it' 'is' 'up' 'to' 'me') fold: [:a :b | a, ' ', b]" ^self reduce: binaryBlock! ! !Collection methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! recordRequiredForMetacelloMCVersion: aMetacelloMCVersion ^aMetacelloMCVersion doRecordRequiredFromArray: self.! ! !Collection methodsFor: '*zinc-resource-meta-core' stamp: 'SvenVanCaekenberghe 3/16/2013 20:24'! addedToZnUrl: url ^ url withPathSegments: self! ! !Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:59'! do: aBlock without: anItem "Enumerate all elements in the receiver. Execute aBlock for those elements that are not equal to the given item" ^ self do: [:each | anItem = each ifFalse: [aBlock value: each]]! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'G.C 10/23/2008 10:12'! * arg ^ arg adaptToCollection: self andSend: #*! ! !Collection methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/18/2011 14:58'! errorNoMatch "Signal a SizeMismatch exception" SizeMismatch signal! ! !Collection methodsFor: 'converting' stamp: 'StephaneDucasse 3/28/2010 22:41'! asSortedCollection: aSortBlock "Answer a SortedCollection whose elements are the elements of the receiver. The sort order is defined by the argument, aSortBlock. Note that this is better to use #sorted: if you don't really need a SortedCollection, but a sorted collection!!!!" | aSortedCollection | aSortedCollection := SortedCollection new: self size. aSortedCollection sortBlock: aSortBlock. aSortedCollection addAll: self. ^ aSortedCollection! ! !Collection methodsFor: 'testing' stamp: 'di 11/6/1998 09:16'! isSequenceable ^ false! ! !Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:19'! removeAllSuchThat: aBlock "Evaluate aBlock for each element and remove all that elements from the receiver for that aBlock evaluates to true. Use a copy to enumerate collections whose order changes when an element is removed (i.e. Sets)." self copy do: [:each | (aBlock value: each) ifTrue: [self remove: each]]! ! !Collection methodsFor: 'testing' stamp: 'ar 11/21/2009 00:36'! ifNotEmptyDo: aBlock "Evaluate the given block with the receiver as its argument." self isEmpty ifFalse: [^ aBlock value: self]. ! ! !Collection methodsFor: 'adapting' stamp: 'ClementBera 9/30/2013 10:59'! adaptToCollection: rcvr andSend: selector "If I am involved in arithmetic with another Collection, return a Collection of the results of each element combined with the scalar in that expression." (rcvr isSequenceable and: [ self isSequenceable ]) ifFalse: [self error: 'Only sequenceable collections may be combined arithmetically']. ^ rcvr with: self collect: [:rcvrElement :myElement | rcvrElement perform: selector with: myElement]! ! !Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:26'! addAll: aCollection "Include all the elements of aCollection as the receiver's elements. Answer aCollection. Actually, any object responding to #do: can be used as argument." aCollection do: [:each | self add: each]. ^ aCollection! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 6/8/2009 19:02'! setLoadsInMetacelloProject: aMetacelloPackageSpec aMetacelloPackageSpec setLoads: self asArray.! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'TAG 11/6/1998 15:58'! max ^ self inject: self anyOne into: [:max :each | max max: each]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:51'! ceiling ^ self collect: [:a | a ceiling]! ! !Collection methodsFor: '*Tools-Explorer' stamp: 'yo 8/27/2008 23:45'! explorerContents ^self explorerContentsWithIndexCollect: [:value :index | ObjectExplorerWrapper with: value name: index printString model: self]! ! !Collection methodsFor: 'accessing' stamp: 'nice 4/19/2011 00:26'! atRandom: aGenerator "Answer a random element of the receiver. Uses aGenerator which     should be kept by the user in a variable and used every time. Use     this instead of #atRandom for better uniformity of random numbers because only you use the generator. Causes an error if self has no elements." | rand index | self emptyCheck. rand := aGenerator nextInt: self size. index := 1. self do: [:each | index = rand ifTrue: [^each]. index := index + 1]. ^ self errorEmptyCollection ! ! !Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 18:08'! copyWithoutAll: aCollection "Answer a copy of the receiver that does not contain any elements equal to those in aCollection." ^ self reject: [:each | aCollection includes: each]! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 6/6/2009 11:42'! removeFromMetacelloPackages: aMetacelloPackagesSpec self do: [:each | each removeFromMetacelloPackages: aMetacelloPackagesSpec ] ! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 9/5/2012 06:26:03.064'! setForDo: aBlock withInMetacelloConfig: aMetacelloConstructore aMetacelloConstructore setFor: self do: aBlock! ! !Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:23'! addIfNotPresent: anObject "Include anObject as one of the receiver's elements, but only if there is no such element already. Anwser anObject." (self includes: anObject) ifFalse: [self add: anObject]. ^ anObject! ! !Collection methodsFor: 'enumerating' stamp: 'StephaneDucasse 2/4/2010 15:34'! do: aBlock displayingProgress: aStringOrBlock "Enumerate aBlock displaying progress information. If the argument is a string, use a static label for the process. If the argument is a block, evaluate it with the element to retrieve the label. Smalltalk allClasses do:[:aClass| (Delay forMilliseconds: 1) wait] displayingProgress: 'Processing...'. Smalltalk allClasses do:[:aClass| (Delay forMilliseconds: 1) wait] displayingProgress:[:aClass| 'Processing ', aClass name]. " ^self do: aBlock displayingProgress: aStringOrBlock every: 20! ! !Collection methodsFor: 'enumerating' stamp: 'CamilloBruni 3/22/2013 22:18'! collect: collectBlock thenDo: doBlock "Utility method to improve readability." ^ self do: [ :each| doBlock value: (collectBlock value: each)]! ! !Collection methodsFor: 'enumerating' stamp: 'CamilloBruni 9/7/2011 19:23'! & aCollection ^ self intersection: aCollection! ! !Collection methodsFor: 'enumerating' stamp: 'ul 11/21/2009 01:16'! collect: aBlock as: aClass "Evaluate aBlock with each of the receiver's elements as the argument. Collect the resulting values into an instance of aClass. Answer the resulting collection." ^(aClass new: self size) fillFrom: self with: aBlock! ! !Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:01'! printOn: aStream delimiter: delimString "Print elements on a stream separated with a delimiter String like: 'a, b, c' " self do: [:elem | aStream print: elem] separatedBy: [aStream print: delimString] ! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:51'! abs "Absolute value of all elements in the collection" ^ self collect: [:a | a abs]! ! !Collection methodsFor: 'printing' stamp: 'apb 4/21/2006 09:37'! printElementsOn: aStream "The original code used #skip:, but some streams do not support that, and we don't really need it." aStream nextPut: $(. self do: [:element | aStream print: element] separatedBy: [aStream space]. aStream nextPut: $)! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:20'! arcTan ^self collect: [:each | each arcTan]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:22'! sin ^self collect: [:each | each sin]! ! !Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:41'! printNameOn: aStream super printOn: aStream! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:53'! squared ^ self collect: [:each | each * each]! ! !Collection methodsFor: 'testing' stamp: ''! isEmpty "Answer whether the receiver contains any elements." ^self size = 0! ! !Collection methodsFor: 'testing' stamp: 'CamilloBruni 9/8/2011 14:20'! includesAnyOf: aCollection self flag: 'use includesAny: instead'. ^ self includesAny: aCollection. ! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:52'! log ^ self collect: [:each | each log]! ! !Collection methodsFor: 'enumerating' stamp: 'GabrielOmarCotelli 11/26/2013 16:53'! detect: aBlock ifFound: foundBlock "Evaluate aBlock with each of the receiver's elements as the argument. If some element evaluates aBlock to true, then cull this element into foundBlock. If no element matches the criteria then do nothing. Always returns self to avoid misuse and a potential isNil check on the sender." self detect: aBlock ifFound: foundBlock ifNone: [ "Do nothing on purpose" ]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:53'! reciprocal "Return the reciever full of reciprocated elements" ^ self collect: [:a | a reciprocal]! ! !Collection methodsFor: 'copying' stamp: 'al 12/12/2003 14:31'! , aCollection ^self copy addAll: aCollection; yourself! ! !Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:45'! collect: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Collect the resulting values into a collection like the receiver. Answer the new collection." | newCollection | newCollection := self species new. self do: [:each | newCollection add: (aBlock value: each)]. ^ newCollection! ! !Collection methodsFor: 'testing' stamp: 'ul 11/11/2009 16:25'! ifNotEmptyDo: notEmptyBlock ifEmpty: emptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise Evaluate the notEmptyBlock with the receiver as its argument" self isEmpty ifFalse: [ ^notEmptyBlock value: self ]. ^emptyBlock value! ! !Collection methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! removeFromMetacelloRepositories: aMetacelloRepositoriesSpec self do: [:each | each removeFromMetacelloRepositories: aMetacelloRepositoriesSpec ] ! ! !Collection methodsFor: '*Tools-Explorer' stamp: 'yo 8/27/2008 23:29'! explorerContentsWithIndexCollect: twoArgBlock ^ self asOrderedCollection withIndexCollect: twoArgBlock ! ! !Collection methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolvePackageSpecsNamedForMetacelloMCVersion: aMetacelloMCVersion visited: visited ifAbsent: aBlock ^ aMetacelloMCVersion allPackagesForSpecs: (self collect: [ :ea | aMetacelloMCVersion packageNamed: ea ifAbsent: aBlock ]) visited: visited! ! !Collection methodsFor: 'math functions' stamp: 'JuanVuletich 10/11/2010 20:15'! sum: aBlock "This is implemented using a variant of the normal inject:into: pattern. The reason for this is that it is not known whether we're in the normal number line, i.e. whether 0 is a good initial value for the sum. Consider a collection of measurement objects, 0 would be the unitless value and would not be appropriate to add with the unit-ed objects." | sum sample | sample := aBlock value: self anyOne. sum := self inject: sample into: [ :previousValue :each | previousValue + (aBlock value: each) ]. ^ sum - sample! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:53'! rounded ^ self collect: [:a | a rounded]! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'di 11/6/1998 13:53'! / arg ^ arg adaptToCollection: self andSend: #/! ! !Collection methodsFor: 'removing' stamp: 'nice 9/14/2009 20:30'! removeAll "Remove each element from the receiver and leave it empty. ArrayedCollections cannot respond to this message. There are two good reasons why a subclass should override this message: 1) the subclass does not support being modified while being iterated 2) the subclass provides a much faster way than iterating through each element" self do: [:each | self remove: each].! ! !Collection methodsFor: 'enumerating' stamp: 'StephaneDucasse 1/2/2012 21:08'! reduce: aBlock "Fold the result of the receiver into aBlock. The argument aBlock must take two or more arguments. It applies the argument, binaryBlock cumulatively to the elements of the receiver. For sequenceable collections the elements will be used in order, for unordered collections the order is unspecified." "#(1 2 3) asSet reduce: [ :a :b | a + b ] --> 1 + 2 + 3 = 6 #(1 2 3 4 5) asSet reduce: [ :a :b :c | a + b + c ] --> 1 + 2 + 3 + 4 + 5 = 15" ^self asOrderedCollection reduce: aBlock! ! !Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:20'! detect: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the first element for which aBlock evaluates to true." ^ self detect: aBlock ifNone: [self errorNotFound: aBlock]! ! !Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:07'! write: anObject ^ self add: anObject! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 6/6/2009 11:45'! addToMetacelloPackages: aMetacelloPackagesSpec self do: [:each | each addToMetacelloPackages: aMetacelloPackagesSpec ] ! ! !Collection methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! fetchRequiredForMetacelloMCVersion: aMetacelloMCVersion ^aMetacelloMCVersion doFetchRequiredFromArray: self.! ! !Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 14:43'! copyWithout: oldElement "Answer a copy of the receiver that does not contain any elements equal to oldElement." ^ self reject: [:each | each = oldElement] "Examples: 'fred the bear' copyWithout: $e #(2 3 4 5 5 6) copyWithout: 5 "! ! !Collection methodsFor: 'enumerating' stamp: ''! detectSum: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Return the sum of the answers." | sum | sum := 0. self do: [:each | sum := (aBlock value: each) + sum]. ^ sum! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:20'! arcCos ^self collect: [:each | each arcCos]! ! !Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:33'! anyOne "Answer a representative sample of the receiver. This method can be helpful when needing to preinfer the nature of the contents of semi-homogeneous collections." self emptyCheck. self do: [:each | ^ each]! ! !Collection methodsFor: 'enumerating' stamp: 'ST 6/19/2013 18:29'! flattenOn: aStream self do: [ :each | (each isCollection and: [each isString not]) ifTrue: [each flattenOn: aStream] ifFalse: [aStream nextPut: each]].! ! !Collection methodsFor: 'enumerating' stamp: 'BenComan 3/20/2014 00:00'! do: aBlock displayingProgress: aStringOrBlock every: msecs "Enumerate aBlock displaying progress information. If the argument is a string, use a static label for the process. If the argument is a block, evaluate it with the element to retrieve the label. The msecs argument ensures that updates happen at most every msecs. Example: Smalltalk allClasses do:[:aClass| (Delay forMilliseconds: 1) wait] displayingProgress:[:aClass| 'Processing ', aClass name] every: 0." | size labelBlock count oldLabel lastUpdate | self isEmpty ifTrue: [ ^ self ]. oldLabel := nil. count := lastUpdate := 0. size := self size. '' displayProgressFrom: 0 to: size during: [:bar | labelBlock := aStringOrBlock isString ifTrue: [ bar label: aStringOrBlock. [ :dummyItem | aStringOrBlock]] ifFalse: [aStringOrBlock]. self do: [:each| | newLabel | "Special handling for first and last element" (count = 0 or: [count+1 = size or: [(Time millisecondsSince: lastUpdate) >= msecs]]) ifTrue: [ bar current: count. oldLabel = (newLabel := (labelBlock cull: each) ifNil: [oldLabel]) ifFalse: [ bar label: newLabel. ProgressNotification signal: '' extra: (oldLabel := newLabel) ]. lastUpdate := Time millisecondClockValue ]. aBlock value: each. count := count + 1]]! ! !Collection methodsFor: 'enumerating' stamp: ''! associationsDo: aBlock "Evaluate aBlock for each of the receiver's elements (key/value associations). If any non-association is within, the error is not caught now, but later, when a key or value message is sent to it." self do: aBlock! ! !Collection methodsFor: 'enumerating' stamp: 'TudorGirba 3/20/2012 09:06'! union: aCollection "Answer the set theoretic union of two collections." | set | set := self asSet addAll: aCollection; yourself. ^ self species withAll: set asArray! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'di 11/6/1998 13:53'! - arg ^ arg adaptToCollection: self andSend: #-! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:51'! floor ^ self collect: [:a | a floor]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:20'! cos ^self collect: [:each | each cos]! ! !Collection methodsFor: 'adding' stamp: ''! add: newObject "Include newObject as one of the receiver's elements. Answer newObject. ArrayedCollections cannot respond to this message." self subclassResponsibility! ! !Collection methodsFor: 'sorting' stamp: 'LucFabresse 6/28/2013 12:58'! sorted "Return a new sequenceable collection which contains the same elements as self but its elements are sorted" ^self asArray sorted! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:54'! truncated ^ self collect: [:a | a truncated]! ! !Collection methodsFor: 'removing' stamp: 'nice 1/10/2009 00:01'! removeAll: aCollection "Remove each element of aCollection from the receiver. If successful for each, answer aCollection. Otherwise create an error notification. ArrayedCollections cannot respond to this message." aCollection == self ifTrue: [^self removeAll]. aCollection do: [:each | self remove: each]. ^ aCollection! ! !Collection methodsFor: 'converting' stamp: 'StephaneDucasse 3/28/2010 22:39'! asSortedCollection "Answer a SortedCollection whose elements are the elements of the receiver. The sort order is the default less than or equal. Note that you should use #sorted: if you don't really need a SortedCollection, but a sorted collection." ^ self as: SortedCollection! ! !Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:51'! collect: collectBlock thenSelect: selectBlock "Utility method to improve readability." ^ (self collect: collectBlock) select: selectBlock! ! !Collection methodsFor: 'enumerating' stamp: 'sma 4/30/2000 11:17'! anySatisfy: aBlock "Evaluate aBlock with the elements of the receiver. If aBlock returns true for any element return true. Otherwise return false." self do: [:each | (aBlock value: each) ifTrue: [^ true]]. ^ false! ! !Collection methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/18/2011 14:37'! errorNotFound: anObject "Raise a NotFound exception." NotFound signalFor: anObject! ! !Collection methodsFor: '*Morphic-Base-Basic' stamp: 'CamilloBruni 10/21/2012 23:39'! asDraggableMorph ^ (String streamContents: [ :s| self do: [ :each | s print: each ] separatedBy: [ s space ]]) asStringMorph! ! !Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 14:41'! copyWith: newElement "Answer a new collection with newElement added (as last element if sequenceable)." ^ self copy add: newElement; yourself! ! !Collection methodsFor: 'enumerating' stamp: 'gh 9/18/2001 15:59'! noneSatisfy: aBlock "Evaluate aBlock with the elements of the receiver. If aBlock returns false for all elements return true. Otherwise return false" self do: [:item | (aBlock value: item) ifTrue: [^ false]]. ^ true! ! !Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:59'! select: selectBlock thenCollect: collectBlock "Utility method to improve readability." ^ (self select: selectBlock) collect: collectBlock! ! !Collection methodsFor: 'comparing' stamp: 'SqR 8/3/2000 13:36'! hash "Answer an integer hash value for the receiver such that, -- the hash value of an unchanged object is constant over time, and -- two equal objects have equal hash values" | hash | hash := self species hash. self size <= 10 ifTrue: [self do: [:elem | hash := hash bitXor: elem hash]]. ^hash bitXor: self size hash! ! !Collection methodsFor: 'printing' stamp: 'gk 1/14/2005 08:27'! asStringOn: aStream delimiter: delimString last: lastDelimString "Print elements on a stream separated with a delimiter between all the elements and with a special one before the last like: 'a, b and c'. Uses #asString instead of #print: Note: Feel free to improve the code to detect the last element." | n sz | n := 1. sz := self size. self do: [:elem | n := n + 1. aStream nextPutAll: elem asString] separatedBy: [ aStream nextPutAll: (n = sz ifTrue: [lastDelimString] ifFalse: [delimString])]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:21'! ln ^self collect: [:each | each ln]! ! !Collection methodsFor: 'testing' stamp: 'HenrikSperreJohansen 6/28/2010 12:14'! ifNotEmpty: notEmptyBlock ifEmpty: emptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise If the notEmptyBlock has an argument, eval with the receiver as its argument" self isEmpty ifFalse: [ ^notEmptyBlock cull: self ]. ^emptyBlock value! ! !Collection methodsFor: 'enumerating' stamp: 'ST 6/23/2013 11:33'! gather: aBlock "This method is kept for compatibility reasons, use flatCollect instead." ^ self flatCollect: aBlock.! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 9/5/2012 06:26:03.064'! setForVersion: aString withInMetacelloConfig: aMetacelloConstructore aMetacelloConstructore setFor: self version: aString! ! !Collection methodsFor: 'math functions' stamp: 'TudorGirba 11/19/2013 21:37'! sumNumbers: aBlock "This is implemented using a variant of the normal inject:into: pattern that is specific to handling numbers. aBlock is expected to return a number for every element in the collection. Different from the sum: implementation, the default value is zero. While sum: is more general, sumNumbers: is meant to support the most often encountered use case of dealing with numbers." ^ self inject: 0 into: [ :sum :each | sum + (aBlock value: each) ]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:20'! arcSin ^self collect: [:each | each arcSin]! ! !Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:16'! removeAllFoundIn: aCollection "Remove each element of aCollection which is present in the receiver from the receiver. Answer aCollection. No error is raised if an element isn't found. ArrayedCollections cannot respond to this message." aCollection do: [:each | self remove: each ifAbsent: []]. ^ aCollection! ! !Collection methodsFor: 'enumerating' stamp: 'CamilloBruni 9/7/2011 19:24'! \ aCollection ^ self difference: aCollection! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'TAG 11/6/1998 16:00'! range ^ self max - self min! ! !Collection methodsFor: 'testing' stamp: 'MarcusDenker 7/17/2013 13:16'! notEmpty "Answer whether the receiver contains any elements." "use isNotEmpty for consistency with isEmpty" ^ self isEmpty not! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'TAG 11/6/1998 15:57'! average ^ self sum / self size! ! !Collection methodsFor: 'enumerating' stamp: 'CamilloBruni 10/20/2012 21:50'! select: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Collect into a new collection like the receiver, only those elements for which aBlock evaluates to true. Answer the new collection." | newCollection | newCollection := self copyEmpty. self do: [ :each | (aBlock value: each) ifTrue: [ newCollection add: each ]]. ^newCollection! ! !Collection methodsFor: 'enumerating' stamp: 'AdrianKuhn 12/30/2009 09:36'! groupedBy: aBlock "Answer a dictionary whose keys are the result of evaluating aBlock for all my elements, and the value for each key is the selection of my elements that evaluated to that key. Uses species." | groups | groups := PluggableDictionary integerDictionary. self do: [ :each | (groups at: (aBlock value: each) ifAbsentPut: [ OrderedCollection new ]) add: each ]. self species ~~ OrderedCollection ifTrue: [ groups associationsDo: [ :association | association value: (self species withAll: association value) ]]. ^ groups ! ! !Collection methodsFor: 'enumerating' stamp: ''! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." self subclassResponsibility! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 9/7/2012 13:10'! asMetacelloAttributeList ^ self! ! !Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:22'! remove: oldObject "Remove oldObject from the receiver's elements. Answer oldObject unless no element is equal to oldObject, in which case, raise an error. ArrayedCollections cannot respond to this message." ^ self remove: oldObject ifAbsent: [self errorNotFound: oldObject]! ! !Collection methodsFor: 'enumerating' stamp: ''! inject: thisValue into: binaryBlock "Accumulate a running value associated with evaluating the argument, binaryBlock, with the current value of the argument, thisValue, and the receiver as block arguments. For instance, to sum the numeric elements of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + next]." | nextValue | nextValue := thisValue. self do: [:each | nextValue := binaryBlock value: nextValue value: each]. ^nextValue! ! !Collection methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec self do: [:each | each mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec ] ! ! !Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:10'! asBag "Answer a Bag whose elements are the elements of the receiver." ^ Bag withAll: self! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 6/6/2009 11:46'! mergeIntoMetacelloPackages: aMetacelloPackagesSpec self do: [:each | each mergeIntoMetacelloPackages: aMetacelloPackagesSpec ] ! ! !Collection methodsFor: 'testing' stamp: 'HenrikSperreJohansen 6/28/2010 12:13'! ifEmpty: emptyBlock ifNotEmpty: notEmptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" " If the notEmptyBlock has an argument, eval with the receiver as its argument" self isEmpty ifTrue: [ ^emptyBlock value ]. ^notEmptyBlock cull: self! ! !Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:07'! contents ^ self! ! !Collection methodsFor: 'enumerating' stamp: 'ul 11/21/2009 01:16'! collect: aBlock into: aCollection "Evaluate aBlock with each of the receiver's elements as the argument. Collect the resulting values into aCollection. Answer aCollection." ^aCollection fillFrom: self with: aBlock! ! !Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:57'! do: elementBlock separatedBy: separatorBlock "Evaluate the elementBlock for all elements in the receiver, and evaluate the separatorBlock between." | beforeFirst | beforeFirst := true. self do: [:each | beforeFirst ifTrue: [beforeFirst := false] ifFalse: [separatorBlock value]. elementBlock value: each]! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'! with: firstObject with: secondObject with: thirdObject with: fourthObject "Answer an instance of me, containing the four arguments as the elements." ^ self new add: firstObject; add: secondObject; add: thirdObject; add: fourthObject; yourself! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:03'! with: firstObject with: secondObject with: thirdObject "Answer an instance of me containing the three arguments as elements." ^ self new add: firstObject; add: secondObject; add: thirdObject; yourself! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 19:58'! with: anObject "Answer an instance of me containing anObject." ^ self new add: anObject; yourself! ! !Collection class methodsFor: '*Tools-Debugger' stamp: 'SeanDeNigris 5/28/2013 17:47'! canonicalArgumentName ^ 'aCollection'.! ! !Collection class methodsFor: '*Spec-Inspector' stamp: 'cb 6/25/2013 13:43'! inspectorClass ^ EyeCollectionInspector! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject "Answer an instance of me, containing the five arguments as the elements." ^ self new add: firstObject; add: secondObject; add: thirdObject; add: fourthObject; add: fifthObject; yourself! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject "Answer an instance of me, containing the six arguments as the elements." ^ self new add: firstObject; add: secondObject; add: thirdObject; add: fourthObject; add: fifthObject; add: sixthObject; yourself! ! !Collection class methodsFor: 'private' stamp: 'lr 11/4/2003 12:07'! initialize "Set up a Random number generator to be used by atRandom when the user does not feel like creating his own Random generator." RandomForPicking := Random new. MutexForPicking := Semaphore forMutualExclusion! ! !Collection class methodsFor: 'private' stamp: 'sma 5/12/2000 12:31'! randomForPicking ^ RandomForPicking! ! !Collection class methodsFor: '*Polymorph-Widgets-Themes' stamp: 'YuriyTymchuk 12/20/2013 11:17'! systemIcon ^ Smalltalk ui icons iconNamed: #collectionIcon! ! !Collection class methodsFor: 'private' stamp: 'lr 11/4/2003 12:08'! mutexForPicking ^ MutexForPicking! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:07'! withAll: aCollection "Create a new collection containing all the elements from aCollection." ^ (self new: aCollection size) addAll: aCollection; yourself! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:01'! with: firstObject with: secondObject "Answer an instance of me containing the two arguments as elements." ^ self new add: firstObject; add: secondObject; yourself! ! !CollectionCombinator commentStamp: ''! For a collection of collections, enumerate all elements of the cartesian product. The code shows how recursion is used to implement variable nesting of loops. The cartesian product is usually a huge collection, that should not be kept in memory. Therefore the user of the class has to provide a block with one argument that is called each time a tuple is constructed. When possible, that block should not build a collection of all these tuples, but should immediately drop unsuitable tuples. To get a first impression, try this with 'inspect it': | result | result := OrderedCollection new. CollectionCombinator new forArrays: (OrderedCollection with: #(#a #b #c) with: #(1 2 3 4 5) with: #('v' 'w' 'x' 'y' 'z') with: #('one' 'two' 'three') ) processWith: [:item |result addLast: item]. result ! !CollectionCombinator methodsFor: 'operating' stamp: 'BG 12/20/2001 21:32'! forArrays: anArray processWith: aBlock " anArray is a kind of a sequenceable collection of arrays. aBlock is a block with one argument, that is used to process a tuple immediately after it is constructed. " collectionOfArrays := anArray. resultProcessingBlock := aBlock. buffer := Array new: anArray size. self combineFromIdx: 1 ! ! !CollectionCombinator methodsFor: 'operating' stamp: 'BG 12/20/2001 21:33'! combineFromIdx: myIdx " this method is recursive. Recursion runs from values 1 to collectionOfArrays size of parameter myIdx. Each time it is called, this method has the responsiblity to provide all possible values for one index position of the result tuples. That index position is given by the value of myIdx." (collectionOfArrays at: myIdx) do: [:item | buffer at: myIdx put: item. myIdx = collectionOfArrays size ifTrue: [resultProcessingBlock value: buffer shallowCopy] ifFalse: [self combineFromIdx: myIdx + 1] ]. " The buffer is a shared object and its contents are later changed. It is therefore necessary to make a copy. "! ! !CollectionIsEmpty commentStamp: 'SvenVanCaekenberghe 4/18/2011 14:53'! I am CollectionIsEmpty, an exception indicating that an operation was attempted on an empty collection where that does not make sense. I am an Error and thus an Exception. The collection that is empty is in my inherited signaler instance variable. ! !CollectionIsEmpty methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/18/2011 14:49'! collection "Return the collection where something is not found in" ^ self signaler! ! !CollectionIsEmpty methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/18/2011 14:54'! standardMessageText "Generate a standard textual description" ^ String streamContents: [ :stream | stream print: self collection. stream << ' is empty' ]! ! !CollectionIsEmpty methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 14:49'! collection: aCollection "Set the collection where something is not found in" self signaler: aCollection! ! !CollectionIsEmpty methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 14:49'! messageText "Overwritten to initialiaze the message text to a standard text if it has not yet been set" ^ messageText ifNil: [ messageText := self standardMessageText ]! ! !CollectionIsEmpty class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 4/18/2011 14:53'! signalWith: aCollection ^ self new collection: aCollection; signal! ! !CollectionRootTest commentStamp: 'stephane.ducasse 1/12/2009 17:41'! I'm the root of the hierarchy of the collection tests. ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testRejectThenDo | result index rejectIndex | index := 0. rejectIndex := 0. result := self collectionWithoutNilElements reject: [ :each | rejectIndex := rejectIndex + 1. "reject the first element" rejectIndex = 1 ] thenDo: [ :each | self assert: each notNil. index := index + 1] . self assert: result equals: self collectionWithoutNilElements. self assert: rejectIndex equals: self collectionWithoutNilElements size. self assert: index equals: self collectionWithoutNilElements size - 1. ! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testSelectOnEmpty self assert: (self empty select: [:e | self fail]) isEmpty ! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testCollectOnEmpty self assert: (self empty collect: [:e | self fail]) isEmpty! ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testSelectThenCollectOnEmpty self assert: (self empty select: [:e | self fail ] thenCollect: [ self fail ]) isEmpty! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testReject | res element | res := self collectionWithoutNilElements reject: [:each | each notNil not]. self assert: res size = self collectionWithoutNilElements size. element := self collectionWithoutNilElements anyOne. res := self collectionWithoutNilElements reject: [:each | each = element]. self assert: res size = (self collectionWithoutNilElements size - 1). ! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'MarcusDenker 9/9/2013 09:27'! sizeCollection "Answers a collection not empty" ^ self subclassResponsibility! ! !CollectionRootTest methodsFor: 'tests - iterate' stamp: 'GabrielOmarCotelli 11/26/2013 17:09'! testDetectIfFoundWhenSomethingIsFoundIgnoringTheFoundObject "The foundBlock can be a zero argument block ignoring the object found" | wasFound | wasFound := false. self collectionWithoutNilElements detect: [ :each | each notNil ] ifFound: [ wasFound := true ]. self assert: wasFound! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:36'! empty self subclassResponsibility! ! !CollectionRootTest methodsFor: 'tests - empty' stamp: ''! testIfNotEmpty self empty ifNotEmpty: [self assert: false]. self nonEmpty ifNotEmpty: [self assert: true]. self assert: (self nonEmpty ifNotEmpty: [:s | s ]) = self nonEmpty ! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:20'! doWithoutNumber ^ 2! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testBasicCollect | res index | index := 0. res := self collectionWithoutNilElements collect: [ :each | index := index + 1. each ]. res do: [ :each | self assert: (self collectionWithoutNilElements occurrencesOf: each) = (res occurrencesOf: each)]. self assert: index equals: self collectionWithoutNilElements size. ! ! !CollectionRootTest methodsFor: 'tests - iterate' stamp: 'GabrielOmarCotelli 11/26/2013 17:11'! testDetectIfFoundIfNoneWhenSomethingIsFound | wasFound foundObject | foundObject := nil. wasFound := self collectionWithoutNilElements detect: [ :each | each notNil ] ifFound: [ :element | foundObject := element. true ] ifNone: [ false ]. self assert: wasFound; assert: (self collectionWithoutNilElements includes: foundObject)! ! !CollectionRootTest methodsFor: 'tests - empty' stamp: ''! testIsEmptyOrNil self assert: (self empty isEmptyOrNil). self deny: (self nonEmpty isEmptyOrNil).! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testAllSatisfyEmpty self assert: ( self empty allSatisfy: [:each | false]). ! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testInjectInto |result| result:= self collectionWithoutNilElements inject: 0 into: [:inj :ele | ele notNil ifTrue: [ inj + 1 ]]. self assert: self collectionWithoutNilElements size = result .! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testBasicCollectEmpty | res | res := self empty collect: [:each | each class]. self assert: res isEmpty ! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testRejectThenCollect | result index selectIndex pivot | index := 0. selectIndex := 0. pivot := self collectionWithoutNilElements anyOne. result := self collectionWithoutNilElements reject: [ :each | selectIndex := selectIndex + 1. "reject the first element" selectIndex = 1 ] thenCollect: [ :each | self assert: each notNil. index := index + 1. pivot ]. self assert: result ~= self collectionWithoutNilElements. self assert: selectIndex equals: self collectionWithoutNilElements size. self assert: index equals: self collectionWithoutNilElements size - 1. self assert: (self collectionWithoutNilElements occurrencesOf: pivot) equals: 1. "should be > 1 for standard collection and = 1 for those that do not allow exact duplicates" self assert: (result occurrencesOf: pivot) >= 1. ! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testRejectEmpty | res | res := self empty reject: [:each | each odd]. self assert: res size = self empty size ! ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testCollectThenDoOnEmpty self assert: (self empty collect: [:e | self fail] thenDo: [ self fail ]) isEmpty! ! !CollectionRootTest methodsFor: 'tests - size capacity' stamp: ''! testSize | size | self assert: self empty size = 0. size := 0. self sizeCollection do: [ :each | size := size + 1]. self assert: self sizeCollection size = size.! ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testRejectThenCollectEmpty self assert: (self empty reject: [:e | self fail ] thenCollect: [ :each| self fail ]) isEmpty! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testDoSeparatedBy | string expectedString beforeFirst | string := ''. self collectionWithoutNilElements do: [ :each | string := string , each asString ] separatedBy: [ string := string , '|' ]. expectedString := ''. beforeFirst := true. self collectionWithoutNilElements do: [ :each | beforeFirst = true ifTrue: [ beforeFirst := false ] ifFalse: [ expectedString := expectedString , '|' ]. expectedString := expectedString , each asString ]. self assert: expectedString = string! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testSelectThenCollect | result index selectIndex pivot | index := 0. selectIndex := 0. pivot := self collectionWithoutNilElements anyOne. result := self collectionWithoutNilElements select: [ :each | selectIndex := selectIndex + 1. "reject the first element" selectIndex > 1 ] thenCollect: [ :each | self assert: each notNil. index := index + 1. pivot ]. self assert: result ~= self collectionWithoutNilElements. self assert: selectIndex equals: self collectionWithoutNilElements size. self assert: index equals: self collectionWithoutNilElements size - 1. self assert: (self collectionWithoutNilElements occurrencesOf: pivot) equals: 1. "should be > 1 for standard collection and = 1 for those that do not allow exact duplicates" self assert: (result occurrencesOf: pivot) >= 1. ! ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testRejectThenDoOnEmpty self assert: (self empty reject: [:e | self fail ] thenDo: [ self fail ]) isEmpty! ! !CollectionRootTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureEmptyTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testSelectThenDoOnEmpty self assert: (self empty select: [:e | self fail ] thenDo: [ self fail ]) isEmpty! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testDoWithout "self debug: #testDoWithout" | res element collection | collection := self collectionWithoutNilElements . res := OrderedCollection new. element := self collectionWithoutNilElements anyOne . collection do: [:each | res add: each] without: element . " verifying result :" self assert: res size = (collection size - (collection occurrencesOf: element)). res do: [:each | self assert: (collection occurrencesOf: each) = ( res occurrencesOf: each ) ]. ! ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testSelectThenDo | result index selectIndex | index := 0. selectIndex := 0. result := self collectionWithoutNilElements select: [ :each | selectIndex := selectIndex + 1. "reject the first element" selectIndex > 1 ] thenDo: [ :each | self assert: each notNil. index := index + 1] . self assert: result equals: self collectionWithoutNilElements. self assert: selectIndex equals: self collectionWithoutNilElements size. self assert: index equals: self collectionWithoutNilElements size - 1. ! ! !CollectionRootTest methodsFor: 'tests - iterate' stamp: 'GabrielOmarCotelli 11/26/2013 16:54'! testDetectIfFoundWhenNobodyIsFound | wasFound | wasFound := false. self collectionWithoutNilElements detect: [ :each | each isNil ] ifFound: [ wasFound := true ]. self deny: wasFound! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:14'! elementTwiceIn ^ 1 "12332312322"! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:32'! element ^ 3! ! !CollectionRootTest methodsFor: 'tests - empty' stamp: ''! testNotEmpty self assert: (self nonEmpty notEmpty). self deny: (self empty notEmpty).! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testSumNumbers |result| result:= self collectionWithoutNilElements sumNumbers: [ :ele | ele notNil ifTrue: [ 1 ] ifFalse: [ 0 ]]. self assert: self collectionWithoutNilElements size = result! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testAllSatisfy | element | " when all element satisfy the condition, should return true : " self assert: ( self collectionWithoutNilElements allSatisfy: [:each | (each notNil) ] ). " when all element don't satisfy the condition, should return false : " self deny: ( self collectionWithoutNilElements allSatisfy: [:each | (each notNil) not ] ). " when only one element doesn't satisfy the condition' should return false'" element := self collectionWithoutNilElements anyOne. self deny: ( self collectionWithoutNilElements allSatisfy: [:each | (each = element) not] ).! ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testSelectNoneThenDo | result | result := self collectionWithoutNilElements select: [ :each | each isNil ] thenDo: [ self fail ]. self assert: result equals: self collectionWithoutNilElements! ! !CollectionRootTest methodsFor: 'tests - empty' stamp: ''! testIsEmpty self assert: (self empty isEmpty). self deny: (self nonEmpty isEmpty).! ! !CollectionRootTest methodsFor: 'tests - empty' stamp: ''! testIfNotEmptyifEmpty self assert: (self empty ifNotEmpty: [false] ifEmpty: [true]). self assert: (self nonEmpty ifNotEmpty: [true] ifEmpty: [false]). ! ! !CollectionRootTest methodsFor: 'accessing' stamp: 'CamilloBruni 7/3/2013 13:03'! collectionClass " return the class to be used to create instances of the class tested" ^ self classToBeTested! ! !CollectionRootTest methodsFor: 'tests - iterate' stamp: 'delaunay 5/14/2009 11:08'! testRejectNoReject | res collection | collection := self collectionWithoutNilElements . res := collection reject: [ :each | each isNil ]. self assert: res size = collection size! ! !CollectionRootTest methodsFor: 'tests - empty' stamp: ''! testIfEmpty self nonEmpty ifEmpty: [ self assert: false] . self empty ifEmpty: [ self assert: true] . ! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testDetect | res element | element := self collectionWithoutNilElements anyOne . res := self collectionWithoutNilElements detect: [:each | each = element]. self assert: (res = element). ! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:36'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" self subclassResponsibility! ! !CollectionRootTest methodsFor: 'tests - iterate' stamp: 'GabrielOmarCotelli 11/26/2013 16:54'! testDetectIfFoundWhenSomethingIsFound | wasFound foundObject | wasFound := false. foundObject := nil. self collectionWithoutNilElements detect: [ :each | each notNil ] ifFound: [ :element | foundObject := element. wasFound := true ]. self assert: wasFound; assert: (self collectionWithoutNilElements includes: foundObject) ! ! !CollectionRootTest methodsFor: 'tests - fixture' stamp: ''! test0TSizeTest self empty. self sizeCollection. self assert: self empty isEmpty. self deny: self sizeCollection isEmpty! ! !CollectionRootTest methodsFor: 'tests - iterate' stamp: 'GabrielOmarCotelli 11/26/2013 17:10'! testDetectIfFoundIfNoneWhenSomethingIsFoundIgnoringTheFoundObject "The foundBlock can be a zero argument block ignoring the object found" | wasFound | wasFound := self collectionWithoutNilElements detect: [ :each | each notNil ] ifFound: [ true ] ifNone: [ false ]. self assert: wasFound! ! !CollectionRootTest methodsFor: 'tests - iterate' stamp: 'GabrielOmarCotelli 11/26/2013 17:11'! testDetectIfFoundIfNoneWhenNobodyIsFound | wasFound | wasFound := self collectionWithoutNilElements detect: [ :each | each isNil ] ifFound: [ true ] ifNone: [ false ]. self deny: wasFound! ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testSelectNoneThenCollect | result | result := self collectionWithoutNilElements select: [ :each | each isNil ] thenCollect: [ :each| self fail ]. self assert: result isEmpty! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testAnySastify | element | " when all elements satisty the condition, should return true :" self assert: ( self collectionWithoutNilElements anySatisfy: [:each | each notNil ]). " when only one element satisfy the condition, should return true :" element := self collectionWithoutNilElements anyOne. self assert: ( self collectionWithoutNilElements anySatisfy: [:each | (each = element) ] ). " when all elements don't satisty the condition, should return false :" self deny: ( self collectionWithoutNilElements anySatisfy: [:each | (each notNil) not ]). ! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testCollectThenSelectOnEmpty self assert: (self empty collect: [:e | self fail] thenSelect: [:e | self fail ]) isEmpty! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'damienpollet 1/21/2009 18:25'! expectedElementByDetect ^ -2! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testDo2 "dc: Bad test, it assumes that a new instance of #speciesClass allows addition with #add:. This is not the case of Interval for which species is Array." "res := self speciesClass new. self collection do: [:each | res add: each class]. self assert: res = self result. " | collection cptElementsViewed cptElementsIn | collection := self collectionWithoutNilElements. cptElementsViewed := 0. cptElementsIn := OrderedCollection new. collection do: [ :each | cptElementsViewed := cptElementsViewed + 1. " #do doesn't iterate with the same objects than those in the collection for FloatArray( I don' t know why ) . That's why I use #includes: and not #identityIncludes: '" (collection includes: each) ifTrue: [ " the collection used doesn't include equal elements. Therefore each element viewed should not have been viewed before " ( cptElementsIn includes: each ) ifFalse: [ cptElementsIn add: each ] . ]. ]. self assert: cptElementsViewed = collection size. self assert: cptElementsIn size = collection size. ! ! !CollectionRootTest methodsFor: 'tests - empty' stamp: ''! testIfEmptyifNotEmpty self assert: (self empty ifEmpty: [true] ifNotEmpty: [false]). self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [true]). ! ! !CollectionRootTest methodsFor: 'test - fixture' stamp: ''! test0FixtureIterateTest | res | self collectionWithoutNilElements. self assert: (self collectionWithoutNilElements occurrencesOf: nil) = 0. res := true. self collectionWithoutNilElements detect: [ :each | (self collectionWithoutNilElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testDetectIfNone | res element | res := self collectionWithoutNilElements detect: [:each | each notNil not] ifNone: [100]. self assert: res = 100. element := self collectionWithoutNilElements anyOne. res := self collectionWithoutNilElements detect: [:each | each = element] ifNone: [100]. self assert: res = element. ! ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testRejectAllThenCollect | result | result := self collectionWithoutNilElements reject: [ :each | each notNil ] thenCollect: [ :each| self fail ]. self assert: result isEmpty! ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testRejectAllThenDo | result | result := self collectionWithoutNilElements reject: [ :each | each notNil ] thenDo: [ :each | self fail ]. self assert: result equals: self collectionWithoutNilElements! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testNoneSatisfy | element | self assert: ( self collectionWithoutNilElements noneSatisfy: [:each | each notNil not ] ). element := self collectionWithoutNilElements anyOne. self deny: ( self collectionWithoutNilElements noneSatisfy: [:each | (each = element)not ] ).! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testNoneSatisfyEmpty self assert: ( self empty noneSatisfy: [:each | false]). ! ! !CollectionRootTest methodsFor: 'tests - iterating' stamp: ''! testSelect | result element | result := self collectionWithoutNilElements select: [ :each | each notNil]. self assert: result size equals: self collectionWithoutNilElements size. element := self collectionWithoutNilElements anyOne. result := self collectionWithoutNilElements select: [ :each | (each = element) not]. self assert: result size equals: (self collectionWithoutNilElements size - 1). ! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:35'! nonEmpty self subclassResponsibility! ! !CollectionRootTest methodsFor: 'as yet unclassified' stamp: ''! testBasicCollectThenDo | result index | index := 0. result := self collectionWithoutNilElements collect: [ :each | nil ] thenDo: [ :each | self assert: each isNil. index := index + 1] . self assert: result equals: self collectionWithoutNilElements. self assert: index equals: self collectionWithoutNilElements size. ! ! !CollectionRootTest class methodsFor: 'as yet unclassified' stamp: 'damienpollet 1/13/2009 15:28'! isAbstract ^ self name = #CollectionRootTest! ! !CollectionValueHolder commentStamp: 'BenjaminVanRyseghem 1/23/2014 15:18'! I am designed specifically for collections.! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! removeIndex: removedIndex | result | result := value removeIndex: removedIndex. self valueChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! addAll: aCollection | result | result := value addAll: aCollection. self valueChanged: aCollection. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! resetTo: index value resetTo: index. self valueChanged! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! addAllFirstUnlessAlreadyPresent: anOrderedCollection | result | result := value addAllFirstUnlessAlreadyPresent: anOrderedCollection. self valueChanged: anOrderedCollection. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! add: newObject beforeIndex: index | result | result := value add: newObject beforeIndex: index. self valueChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! addLast: newObject | result | result := value addLast: newObject . self valueChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! atLast: indexFromEnd put: obj | result | result := value atLast: indexFromEnd put: obj. self valueChanged: obj. ^ result! ! !CollectionValueHolder methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! doesNotUnderstand: aMessage ^ (value respondsTo: aMessage selector) ifTrue: [ value perform: aMessage selector withEnoughArguments: aMessage arguments ] ifFalse: [ super doesNotUnderstand: aMessage ]! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! replace: aBlock value replace: aBlock . self valueChanged! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! add: newObject after: oldObject | result | result := value add: newObject after: oldObject. self valueChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'override' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! at: anObject ^ value at: anObject! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! add: newObject | result | result := value add: newObject. self valueChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! addAllLast: aCollection | result | result := value addAllLast: aCollection. self valueChanged: aCollection. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! removeAt: index | result | result := value removeAt: index. self valueChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! add: newObject before: oldObject | result | result := value add: newObject before: oldObject. self valueChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'CamilloBruni 11/18/2013 18:08'! atWrap: index put: anObject | result | result := value atWrap: index put: anObject. self valueChanged: value. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! atAll: aCollection put: anObject | result | result := value atAll: aCollection put: anObject . self valueChanged: anObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! at: index ifAbsentPut: block | result | result := value at: index ifAbsentPut: block. self valueChanged: block value. ^ result! ! !CollectionValueHolder methodsFor: 'override' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! size ^ value size! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! removeFirst | result | result := value removeFirst. self valueChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! remove: oldObject ifAbsent: absentBlock | result | result := value remove: oldObject ifAbsent: absentBlock. self valueChanged: oldObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! addFirst: newObject | result | result := value addFirst: newObject . self valueChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! insert: anObject before: spot | result | result := value insert: anObject before: spot. self valueChanged: anObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! replaceAll: oldObject with: newObject value replaceAll: oldObject with: newObject . self valueChanged: oldObject! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! removeFirst: n | result | result := value removeFirst: n . self valueChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! addAllFirst: anOrderedCollection | result | result := value addAllFirst: anOrderedCollection. self valueChanged: anOrderedCollection. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! reset value reset. self valueChanged! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! add: newObject afterIndex: index | result | result := value add: newObject afterIndex: index. self valueChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'override' stamp: 'BenjaminVanRyseghem 10/17/2013 17:11'! at: key put: anObject value at: key put: anObject. self valueChanged: value. ^ anObject! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! atAll: indexArray putAll: valueArray | result | result := value atAll: indexArray putAll: valueArray. self valueChanged: valueArray. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! removeLast | result | result := value removeLast. self valueChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! sort: aSortBlock value sort: aSortBlock . self valueChanged! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! atAllPut: anObject | result | result := value atAllPut: anObject. self valueChanged: anObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! removeLast: n | result | result := value removeLast: n. self valueChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! removeAll value removeAll. self valueChanged! ! !CollectionsArithmeticReadme commentStamp: ''! This package only makes extensions to existing collection classes by adding the arithmetic protocols. Such protocols allow one to perform in particular vector-operations on collection! !Color commentStamp: ''! This class represents abstract color, regardless of the depth of bitmap it will be shown in. At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. (See comment in BitBlt.) To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8). (See comment in DisplayMedium) Color is represented as the amount of light in red, green, and blue. White is (1.0, 1.0, 1.0) and black is (0, 0, 0). Pure red is (1.0, 0, 0). These colors are "additive". Think of Color's instance variables as: r amount of red, a Float between 0.0 and 1.0. g amount of green, a Float between 0.0 and 1.0. b amount of blue, a Float between 0.0 and 1.0. (But, in fact, the three are encoded as values from 0 to 1023 and combined in a single integer, rgb. The user does not need to know this.) Many colors are named. You find a color by name by sending a message to class Color, for example (Color lightBlue). Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below) A color is essentially immutable. Once you set red, green, and blue, you cannot change them. Instead, create a new Color and use it. Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number. Convert the range of this number to an integer from 1 to N. Then call (Color green lightShades: N) to get an Array of colors from white to green. Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array. atPin: gives the first (or last) color if the index is out of range. atWrap: wraps around to the other end if the index is out of range. Here are some fun things to run in when your screen has color: Pen new mandala: 30 diameter: Display height-100. Pen new web "Draw with the mouse, opt-click to end" Display fillWhite. Pen new hilberts: 5. Form toothpaste: 30 "Draw with mouse, opt-click to end" You might also want to try the comment in Form>class>examples>tinyText... Messages: mixed: proportion with: aColor Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. + add two colors - subtract two colors * multiply the values of r, g, b by a number or an Array of factors. ((Color named: #white) * 0.3) gives a darkish gray. (aColor * #(0 0 0.9)) gives a color with slightly less blue. / divide a color by a factor or an array of three factors. errorForDepth: d How close the nearest color at this depth is to this abstract color. Sum of the squares of the RGB differences, square rooted and normalized to 1.0. Multiply by 100 to get percent. hue Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360. saturation Returns the saturation of the color. 0.0 to 1.0 brightness Returns the brightness of the color. 0.0 to 1.0 name Look to see if this Color has a name. display Show a swatch of this color tracking the cursor. lightShades: thisMany An array of thisMany colors from white to the receiver. darkShades: thisMany An array of thisMany colors from black to the receiver. Array is of length num. mix: color2 shades: thisMany An array of thisMany colors from the receiver to color2. wheel: thisMany An array of thisMany colors around the color wheel starting and ending at the receiver. pixelValueForDepth: d Returns the bits that appear be in a Bitmap of this depth for this color. Represents the nearest available color at this depth. Normal users do not need to know which pixelValue is used for which color. Messages to Class Color. red: r green: g blue: b Return a color with the given r, g, and b components. r: g: b: Same as above, for fast typing. hue: h saturation: s brightness: b Create a color with the given hue, saturation, and brightness. pink blue red ... Many colors have messages that return an instance of Color. canUnderstand: #brown Returns true if #brown is a defined color. names An OrderedCollection of the names of the colors. named: #notAllThatGray put: aColor Add a new color to the list and create an access message and a class variable for it. fromUser Shows the palette of colors available at this display depth. Click anywhere to return the color you clicked on. hotColdShades: thisMany An array of thisMany colors showing temperature from blue to red to white hot. stdColorsForDepth: d An Array of colors available at this depth. For 16 bit and 32 bits, returns a ColorGenerator. It responds to at: with a Color for that index, simulating a very big Array. colorFromPixelValue: value depth: d Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified. Normal users do not need to use this. (See also comments in these classes: Form, Bitmap, BitBlt, Pattern, MaskedForm.)! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! twiceLighter "Answer a significantly lighter shade of this color." ^ self adjustSaturation: -0.06 brightness: 0.15! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/15/2013 22:13'! setRed: r green: g blue: b range: range "Initialize this color's r, g, and b components to the given values in the range [0..r]." rgb == nil ifFalse: [ self attemptToMutateError ]. rgb := ((r * ComponentMask // range bitAnd: ComponentMask) bitShift: RedShift) + ((g * ComponentMask // range bitAnd: ComponentMask) bitShift: GreenShift) + (b * ComponentMask // range bitAnd: ComponentMask). cachedDepth := nil. cachedBitPattern := nil! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/15/2013 22:13'! isBitmapFill ^false! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/16/2013 15:08'! whiter ^ self alphaMixed: 0.8333 with: (ColorRegistry at: #white) ! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:42'! bitPatternForDepth: depth "Return a Bitmap, possibly containing a stipple pattern, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps. The resulting Bitmap may be multiple words to represent a stipple pattern of several lines. " "See also: pixelValueAtDepth: -- value for single pixel pixelWordAtDepth: -- a 32-bit word filled with the pixel value" "Details: The pattern for the most recently requested depth is cached." "Note for depths > 2, there are stippled and non-stippled versions (generated with #balancedPatternForDepth: and #bitPatternForDepth:, respectively). The stippled versions don't work with the window bit caching of StandardSystemView, so we make sure that for these depths, only unstippled patterns are returned" (depth = cachedDepth and: [ depth <= 2 or: [ cachedBitPattern size = 1 ] ]) ifTrue: [ ^ cachedBitPattern ]. ( self isTransparent and: [ cachedBitPattern isNil] ) ifTrue: [ cachedBitPattern := Bitmap with: 0 . ^ cachedBitPattern ]. cachedDepth := depth. depth > 2 ifTrue: [ ^ cachedBitPattern := Bitmap with: (self pixelWordForDepth: depth) ]. depth = 1 ifTrue: [ ^ cachedBitPattern := self halfTonePattern1 ]. depth = 2 ifTrue: [ ^ cachedBitPattern := self halfTonePattern2 ]! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/15/2013 22:13'! isTranslucentButNotTransparent "Answer true if this any of this morph is translucent but not transparent." ^ self isTranslucent and: [ self isTransparent not ]! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/16/2013 14:38'! isGray "Return true if the receiver represents a shade of gray" ^(self privateRed = self privateGreen) and: [self privateRed = self privateBlue]! ! !Color methodsFor: 'other' stamp: 'StephaneDucasse 10/15/2013 22:13'! rgbTriplet "Color fromUser rgbTriplet" ^ Array with: (self red roundTo: 0.01) with: (self green roundTo: 0.01) with: (self blue roundTo: 0.01) ! ! !Color methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2013 22:13'! green "Return the green component of this color, a float in the range [0.0..1.0]." ^ self privateGreen asFloat / ComponentMax! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/16/2013 14:41'! isTransparent ^ alpha = 0! ! !Color methodsFor: '*System-CommandLine' stamp: 'StephaneDucasse 10/15/2013 22:13'! closestXTermPixelValue | index | "Return the nearest approximation to this color for 256 xterm color." self saturation < 0.2 ifTrue: [ "colors 232-255 are a grayscale ramp, intentionally leaving out black and white" index := (self green * 25) asInteger. index = 0 ifTrue: [ ^ 0 ]. index = 25 ifTrue: [ ^ 16 ]. ^ index + 232 ]. "compute nearest entry in the 6*6*6 color cube" ^ 16 + (self red * 6*6*5) asInteger + (self green * 6*5) asInteger + (self blue * 5) asInteger ! ! !Color methodsFor: '*Athens-Core' stamp: 'IgorStasenko 9/3/2013 12:11'! athensFillPath: aPath on: aCanvas ^ aCanvas surface fillPath: aPath withSolidColor:self! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! negated "Return an RGB inverted color" ^Color r: 1.0 - self red g: 1.0 - self green b: 1.0 - self blue! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/15/2013 22:13'! privateRed "Private!! Return the internal representation of my red component." ^ (rgb bitShift: 0 - RedShift) bitAnd: ComponentMask! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! dominantColor ^ self! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/15/2013 22:13'! isOrientedFill "Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)" ^false! ! !Color methodsFor: 'other' stamp: 'StephaneDucasse 10/15/2013 22:13'! raisedColor ^ self! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/15/2013 22:13'! setRed: r green: g blue: b "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]. Encoded in a single variable as 3 integers in [0..1023]." rgb == nil ifFalse: [ self attemptToMutateError ]. rgb := (((r * ComponentMax) rounded bitAnd: ComponentMask) bitShift: RedShift) + (((g * ComponentMax) rounded bitAnd: ComponentMask) bitShift: GreenShift) + ((b * ComponentMax) rounded bitAnd: ComponentMask). cachedDepth := nil. cachedBitPattern := nil! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! slightlyDarker ^ self adjustBrightness: -0.03 ! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/15/2013 22:13'! flushCache "Flush my cached bit pattern." cachedDepth := nil. cachedBitPattern := nil! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! atMostAsLuminentAs: aFloat | revisedColor | revisedColor := self. [ revisedColor luminance > aFloat ] whileTrue: [ revisedColor := revisedColor slightlyDarker ]. ^ revisedColor! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/16/2013 14:37'! initializeRed: r green: g blue: b range: range "Initialize this color's r, g, and b components to the given values in the range [0..r]." rgb == nil ifFalse: [ self attemptToMutateError ]. rgb := ((r * ComponentMask // range bitAnd: ComponentMask) bitShift: RedShift) + ((g * ComponentMask // range bitAnd: ComponentMask) bitShift: GreenShift) + (b * ComponentMask // range bitAnd: ComponentMask). cachedDepth := nil. cachedBitPattern := nil. self setAlpha: 1.0.! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/15/2013 22:13'! isGradientFill ^false! ! !Color methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2013 22:13'! hue "Return the hue of this color, an angle in the range [0.0..360.0]." | r g b max min span h | r := self privateRed. g := self privateGreen. b := self privateBlue. max := (r max: g) max: b. min := (r min: g) min: b. span := (max - min) asFloat. span = 0.0 ifTrue: [ ^ 0.0 ]. r = max ifTrue: [ h := (g - b) asFloat / span * 60.0 ] ifFalse: [ g = max ifTrue: [ h := 120.0 + ((b - r) asFloat / span * 60.0) ] ifFalse: [ h := 240.0 + ((r - g) asFloat / span * 60.0) ] ]. h < 0.0 ifTrue: [ h := 360.0 + h ]. ^ h! ! !Color methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2013 22:13'! red "Return the red component of this color, a float in the range [0.0..1.0]." ^ self privateRed asFloat / ComponentMax! ! !Color methodsFor: 'groups of shades' stamp: 'StephaneDucasse 10/16/2013 15:08'! wheel: thisMany "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self. Array is of length thisMany. Very useful for displaying color based on a variable in your program. " | sat bri step hue | sat := self saturation. bri := self brightness. hue := self hue. step := 360.0 / (thisMany max: 1). ^ (1 to: thisMany) collect: [ :num | | c | c := self class h: hue s: sat v: bri. "hue is taken mod 360" hue := hue + step. c ] " (Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c] "! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/16/2013 15:00'! quiteWhiter ^ self alphaMixed: 0.6 with: (ColorRegistry at: #white)! ! !Color methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2013 22:13'! brightness "Return the brightness of this color, a float in the range [0.0..1.0]." ^ ((self privateRed max: self privateGreen) max: self privateBlue) asFloat / ComponentMax! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! paler "Answer a paler shade of this color." ^ self adjustSaturation: -0.09 brightness: 0.09 ! ! !Color methodsFor: '*Morphic-Base' stamp: 'StephaneDucasse 10/15/2013 22:13'! iconOrThumbnailOfSize: aNumberOrPoint "Answer an appropiate form to represent the receiver" | form | form := Form extent: aNumberOrPoint asPoint asPoint depth: 32. form fillColor: self. ^ form! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/16/2013 14:55'! pixelValueForDepth: d "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." | basicPixelWord | ( d < 32 and:[ self isTransparent ] ) ifTrue: [ ^ 0 ]. basicPixelWord := self basicPixelValueForDepth: d. ^ d < 32 ifTrue: [ basicPixelWord ] ifFalse: [ (basicPixelWord bitAnd: 16777215) bitOr: (alpha bitShift: 24) ]! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/16/2013 14:43'! muchDarker ^ self alphaMixed: 0.5 with: (ColorRegistry at: #black) ! ! !Color methodsFor: 'printing' stamp: 'StephaneDucasse 10/16/2013 15:05'! storeArrayValuesOn: aStream self isTransparent ifTrue: [ ^ aStream space. ]. (self red roundTo: 0.001) storeOn: aStream. aStream space. (self green roundTo: 0.001) storeOn: aStream. aStream space. (self blue roundTo: 0.001) storeOn: aStream. aStream space. (self alpha roundTo: 0.001) storeOn: aStream. ! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/16/2013 15:01'! setAlpha: aFloat alpha := ((255.0 * aFloat) asInteger min: 255) max: 0. ! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! indexInMap: aColorMap "Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap. " aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1]. aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1]. aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1]. aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1]. aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1]. aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1]. aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 16) + 1]. self error: 'unknown pixel depth'. ! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:28'! + aColor "Answer this color mixed with the given color in an additive color space. " ^ self class basicNew setPrivateRed: self privateRed + aColor privateRed green: self privateGreen + aColor privateGreen blue: self privateBlue + aColor privateBlue ! ! !Color methodsFor: '*Morphic-Base' stamp: 'StephaneDucasse 10/15/2013 22:29'! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" aMenu add: 'change color...' translated target: self selector: #changeColorIn:event: argument: aMorph! ! !Color methodsFor: 'equality' stamp: 'StephaneDucasse 10/15/2013 22:13'! diff: theOther "Returns a number between 0.0 and 1.0" ^ ((self privateRed - theOther privateRed) abs + (self privateGreen - theOther privateGreen) abs + (self privateBlue - theOther privateBlue) abs) / 3.0 / ComponentMax! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/15/2013 22:13'! isBlack "Return true if the receiver represents black" ^rgb = 0! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/15/2013 22:13'! privateRGB "Private!! Return the internal representation of my RGB components." ^ rgb ! ! !Color methodsFor: 'printing' stamp: 'MarcusDenker 3/27/2014 11:03'! printOn: aStream | name | (name := self name). name = #unnamed ifFalse: [ ^ aStream nextPutAll: 'Color '; nextPutAll: name ]. self storeOn: aStream! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/15/2013 22:13'! setPrivateRed: r green: g blue: b "Initialize this color's r, g, and b components to the given values in the range [0..ComponentMax]. Encoded in a single variable as 3 integers in [0..1023]." rgb == nil ifFalse: [ self attemptToMutateError ]. rgb := ((r min: ComponentMask max: 0) bitShift: RedShift) + ((g min: ComponentMask max: 0) bitShift: GreenShift) + (b min: ComponentMask max: 0). cachedDepth := nil. cachedBitPattern := nil! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:32'! alpha: aFloat "Answer a new Color with the given amount of opacity ('alpha')." ^ self class r: self red g: self green b: self blue alpha: aFloat ! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:33'! asNontranslucentColor ^ self alpha: 1.0.! ! !Color methodsFor: '*Athens-Core' stamp: 'IgorStasenko 9/3/2013 12:17'! asStrokePaintOn: aCanvas ^ aCanvas surface createStrokePaintFor: self! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/16/2013 14:39'! isOpaque ^ alpha = 255 ! ! !Color methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2013 22:13'! blue "Return the blue component of this color, a float in the range [0.0..1.0]." ^ self privateBlue asFloat / ComponentMax! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! closestPixelValue1 "Return the nearest approximation to this color for a monochrome Form." "fast special cases" rgb = 0 ifTrue: [^ 1]. "black" rgb = 16r3FFFFFFF ifTrue: [^ 0]. "white" self luminance > 0.5 ifTrue: [^ 0] "white" ifFalse: [^ 1]. "black" ! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! atLeastAsLuminentAs: aFloat | revisedColor | revisedColor := self. [ revisedColor luminance < aFloat ] whileTrue: [ revisedColor := revisedColor slightlyLighter ]. ^ revisedColor! ! !Color methodsFor: 'printing' stamp: 'StephaneDucasse 10/16/2013 15:05'! storeOn: aStream self isTransparent ifTrue: [^ aStream nextPutAll: '(Color transparent)']. aStream nextPutAll: '(' , self class name; nextPutAll: ' r: '; print: (self red roundTo: 0.001); nextPutAll: ' g: '; print: (self green roundTo: 0.001); nextPutAll: ' b: '; print: (self blue roundTo: 0.001); nextPutAll: ' alpha: '; print: (self alpha roundTo: 0.001); nextPutAll: ')'. ! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/16/2013 14:37'! initializeRed: r green: g blue: b alpha: anAlpha "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0]. Encoded in a single variable as 3 integers in [0..1023]." rgb == nil ifFalse: [ self attemptToMutateError ]. rgb := (((r * ComponentMax) rounded bitAnd: ComponentMask) bitShift: RedShift) + (((g * ComponentMax) rounded bitAnd: ComponentMask) bitShift: GreenShift) + ((b * ComponentMax) rounded bitAnd: ComponentMask). cachedDepth := nil. cachedBitPattern := nil. self setAlpha: anAlpha.! ! !Color methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2013 22:13'! luminance "Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity." ^ ((299 * self privateRed) + (587 * self privateGreen) + (114 * self privateBlue)) / (1000 * ComponentMax) ! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:44'! contrastingColor "Answer black or white depending on the luminance." self isTransparent ifTrue: [ ^ self class black]. ^self luminance > 0.5 ifTrue: [self class black] ifFalse: [self class white]! ! !Color methodsFor: '*Athens-Cairo' stamp: 'IgorStasenko 9/3/2013 13:31'! loadOnCairoCanvas: aCairoCanvas aCairoCanvas setSourceR: self red g: self green b: self blue a: self alpha! ! !Color methodsFor: 'comparing' stamp: 'StephaneDucasse 10/15/2013 22:29'! = aColor "Return true if the receiver equals the given color. This method handles translucent colors, too." aColor isColor ifFalse: [^ false]. ^ aColor privateRGB = rgb and: [aColor privateAlpha = self privateAlpha] ! ! !Color methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2013 22:13'! saturation "Return the saturation of this color, a value between 0.0 and 1.0." | r g b max min | r := self privateRed. g := self privateGreen. b := self privateBlue. max := min := r. g > max ifTrue: [ max := g ]. b > max ifTrue: [ max := b ]. g < min ifTrue: [ min := g ]. b < min ifTrue: [ min := b ]. max = 0 ifTrue: [ ^ 0.0 ] ifFalse: [ ^ (max - min) asFloat / max asFloat ]! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! closestPixelValue4 "Return the nearest approximation to this color for a 4-bit deep Form." "fast special cases" | bIndex | rgb = 0 ifTrue: [ ^ 1 ]. "black" rgb = 1073741823 ifTrue: [ ^ 2 ]. "opaque white" rgb = self class red privateRGB ifTrue: [ ^ 4 ]. rgb = self class green privateRGB ifTrue: [ ^ 5 ]. rgb = self class blue privateRGB ifTrue: [ ^ 6 ]. rgb = self class cyan privateRGB ifTrue: [ ^ 7 ]. rgb = self class yellow privateRGB ifTrue: [ ^ 8 ]. rgb = self class magenta privateRGB ifTrue: [ ^ 9 ]. bIndex := (self luminance * 8.0) rounded. "bIndex in [0..8]" ^ #(1 10 11 12 3 13 14 15 2 ) at: bIndex + 1 "black" "1/8 gray" "2/8 gray" "3/8 gray" "4/8 gray" "5/8 gray" "6/8 gray" "7/8 gray" "opaque white"! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/15/2013 22:13'! attemptToMutateError "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it." self error: 'Color objects are immutable once created' ! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/16/2013 14:36'! initializePrivateRed: r green: g blue: b "Initialize this color's r, g, and b components to the given values in the range [0..ComponentMax]. Encoded in a single variable as 3 integers in [0..1023]." rgb == nil ifFalse: [ self attemptToMutateError ]. rgb := ((r min: ComponentMask max: 0) bitShift: RedShift) + ((g min: ComponentMask max: 0) bitShift: GreenShift) + (b min: ComponentMask max: 0). cachedDepth := nil. cachedBitPattern := nil! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:43'! blacker ^ self alphaMixed: 0.8333 with: self class black ! ! !Color methodsFor: '*Polymorph-Widgets' stamp: 'StephaneDucasse 10/15/2013 22:13'! fillRectangle: aRectangle on: aCanvas "Fill the given rectangle on the given canvas with the receiver." aCanvas fillRectangle: aRectangle basicFillStyle: self! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:27'! * aNumberOrArray "Answer this color with its RGB multiplied by the given number, or multiply this color's RGB values by the corresponding entries in the given array." "(self brown * 2) display" "(self brown * #(1 0 1)) display" | multipliers | multipliers := aNumberOrArray isCollection ifTrue: [aNumberOrArray] ifFalse: [Array with: aNumberOrArray with: aNumberOrArray with: aNumberOrArray]. ^ self class basicNew setPrivateRed: (self privateRed * multipliers first) asInteger green: (self privateGreen * multipliers second) asInteger blue: (self privateBlue * multipliers third) asInteger.! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/16/2013 14:59'! quiteBlacker ^ self alphaMixed: 0.8 with: (ColorRegistry at: #black)! ! !Color methodsFor: 'groups of shades' stamp: 'StephaneDucasse 10/15/2013 22:13'! darkShades: thisMany "An array of thisMany colors from black to the receiver. Array is of length num. Very useful for displaying color based on a variable in your program. " "Color showColors: (Color red darkShades: 12)" ^ self class black mix: self shades: thisMany ! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/15/2013 22:13'! privateBlue "Private!! Return the internal representation of my blue component." ^ rgb bitAnd: ComponentMask! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/16/2013 14:58'! pixelWordForDepth: depth "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." | pixelValue basicPixelWord | self isTransparent ifTrue: [ ^ 0 ]. pixelValue := self pixelValueForDepth: depth. basicPixelWord := self pixelWordFor: depth filledWith: pixelValue. ^ depth < 32 ifTrue: [ basicPixelWord ] ifFalse: [ (basicPixelWord bitAnd: 16777215) bitOr: (alpha bitShift: 24) ]! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! darker "Answer a darker shade of this color." ^ self adjustBrightness: -0.08! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! closestPixelValue8 "Return the nearest approximation to this color for an 8-bit deep Form." "fast special cases" rgb = 0 ifTrue: [^ 1]. "black" rgb = 16r3FFFFFFF ifTrue: [^ 255]. "white" self saturation < 0.2 ifTrue: [ ^ GrayToIndexMap at: (self privateGreen >> 2) + 1. "nearest gray" ] ifFalse: [ "compute nearest entry in the color cube" ^ 40 + ((((self privateRed * 5) + HalfComponentMask) // ComponentMask) * 36) + ((((self privateBlue * 5) + HalfComponentMask) // ComponentMask) * 6) + (((self privateGreen * 5) + HalfComponentMask) // ComponentMask)]. ! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! closestPixelValue2 "Return the nearest approximation to this color for a 2-bit deep Form." "fast special cases" | lum | rgb = 0 ifTrue: [ ^ 1 ]. "black" rgb = 1073741823 ifTrue: [ ^ 2 ]. "opaque white" lum := self luminance. lum < 0.2 ifTrue: [ ^ 1 ]. "black" lum > 0.6 ifTrue: [ ^ 2 ]. "opaque white" ^ 3 "50% gray"! ! !Color methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2013 22:30'! alpha "Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque." ^ alpha asFloat / 255.0! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:30'! adjustSaturation: saturation brightness: brightness "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" ^ self class h: self hue s: (self saturation + saturation min: 1.0 max: 0.005) v: (self brightness + brightness min: 1.0 max: 0.005) alpha: self alpha! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/16/2013 14:37'! intializeHue: hue saturation: saturation brightness: brightness alpha: anAlpha "Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details." | s v hf i f p q t | rgb == nil ifFalse: [ self attemptToMutateError ]. s := (saturation asFloat max: 0.0) min: 1.0. v := (brightness asFloat max: 0.0) min: 1.0. "zero saturation yields gray with the given brightness" s = 0.0 ifTrue: [ ^ self initializeRed: v green: v blue: v alpha: anAlpha ]. hf := hue asFloat. (hf < 0.0 or: [ hf >= 360.0 ]) ifTrue: [ hf := hf - ((hf quo: 360.0) asFloat * 360.0) ]. hf := hf / 60.0. i := hf asInteger. "integer part of hue" f := hf fractionPart. "fractional part of hue" p := (1.0 - s) * v. q := (1.0 - (s * f)) * v. t := (1.0 - (s * (1.0 - f))) * v. 0 = i ifTrue: [ ^ self initializeRed: v green: t blue: p alpha: anAlpha ]. 1 = i ifTrue: [ ^ self initializeRed: q green: v blue: p alpha: anAlpha ]. 2 = i ifTrue: [ ^ self initializeRed: p green: v blue: t alpha: anAlpha ] . 3 = i ifTrue: [ ^ self initializeRed: p green: q blue: v alpha: anAlpha ]. 4 = i ifTrue: [ ^ self initializeRed: t green: p blue: v alpha: anAlpha ]. 5 = i ifTrue: [ ^ self initializeRed: v green: p blue: q alpha: anAlpha ]. self error: 'implementation error'! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/15/2013 22:13'! isSolidFill ^true! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! slightlyLighter ^ self adjustSaturation: -0.01 brightness: 0.03! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:45'! contrastingForegroundColor "Make a foreground color contrasting with me" ^self luminance >= 0.5 ifTrue: [self class black] ifFalse: [self class white]! ! !Color methodsFor: 'printing' stamp: 'StephaneDucasse 10/15/2013 22:13'! shortPrintString "Return a short (but less precise) print string for use where space is tight." | s | s := String new writeStream. s nextPutAll: '(' , self class name; nextPutAll: ' r: '; nextPutAll: (self red roundTo: 0.01) printString; nextPutAll: ' g: '; nextPutAll: (self green roundTo: 0.01) printString; nextPutAll: ' b: '; nextPutAll: (self blue roundTo: 0.01) printString; nextPutAll: ')'. ^ s contents! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:30'! adjustBrightness: brightness "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" ^ self class h: self hue s: self saturation v: (self brightness + brightness min: 1.0 max: 0.005) alpha: self alpha! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/16/2013 15:01'! scaledPixelValue32 "Return the alpha scaled pixel value for depth 32" | pv32 a b g r | pv32 := self pixelWordForDepth: 32 . a := (self alpha * 255.0) rounded. b := (pv32 bitAnd: 255) * a // 256. g := ((pv32 bitShift: -8) bitAnd: 255) * a // 256. r := ((pv32 bitShift: -16) bitAnd: 255) * a // 256. ^ b + (g bitShift: 8) + (r bitShift: 16) + (a bitShift: 24)! ! !Color methodsFor: 'groups of shades' stamp: 'StephaneDucasse 10/15/2013 22:13'! lightShades: thisMany "An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program. " "Color showColors: (Color red lightShades: 12)" ^ self class white mix: self shades: thisMany ! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! pixelWordFor: depth filledWith: pixelValue "Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1." | halfword | depth = 32 ifTrue: [ ^ pixelValue ]. depth = 16 ifTrue: [ halfword := pixelValue ] ifFalse: [ halfword := pixelValue * (#( 65535 21845 #- 4369 #- #- #- 257 ) at: depth) "replicates at every bit" "replicates every 2 bits" "replicates every 4 bits" "replicates every 8 bits" ]. ^ halfword bitOr: (halfword bitShift: 16)! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! twiceDarker "Answer a significantly darker shade of this color." ^ self adjustBrightness: -0.15! ! !Color methodsFor: 'other' stamp: 'StephaneDucasse 10/15/2013 22:13'! colorForInsets ^ self! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/16/2013 14:41'! isTranslucentColor "This means: self isTranslucent, but isTransparent not" self flag: #toremove. ^ false! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/15/2013 22:13'! setRGB: rgb0 rgb == nil ifFalse: [ self attemptToMutateError ]. rgb := rgb0! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/15/2013 22:13'! isColor ^ true ! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! orColorUnlike: theOther "If this color is a lot like theOther, then return its complement, otherwide, return self" ^ (self diff: theOther) < 0.3 ifTrue: [ theOther negated ] ifFalse: [ self ]! ! !Color methodsFor: 'groups of shades' stamp: 'StephaneDucasse 10/16/2013 14:42'! mix: color2 shades: thisMany "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program. " "Color showColors: (Color red mix: Color green shades: 12)" | redInc greenInc blueInc out rr gg bb | thisMany = 1 ifTrue: [ ^ Array with: color2 ]. redInc := (color2 red - self red) / (thisMany - 1). greenInc := (color2 green - self green) / (thisMany - 1). blueInc := (color2 blue - self blue) / (thisMany - 1). rr := self red. gg := self green. bb := self blue. out := (1 to: thisMany) collect: [ :num | | c | c := self class r: rr g: gg b: bb. rr := rr + redInc. gg := gg + greenInc. bb := bb + blueInc. c ]. out at: out size put: color2. "hide roundoff errors" ^ out! ! !Color methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2013 22:13'! name ^ self class registeredNameOf: self ! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:28'! / aNumber "Answer this color with its RGB divided by the given number. " "(Color red / 2) display" ^ self class basicNew setPrivateRed: (self privateRed / aNumber) asInteger green: (self privateGreen / aNumber) asInteger blue: (self privateBlue / aNumber) asInteger ! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/16/2013 15:06'! veryMuchLighter ^ self alphaMixed: 0.1165 with: (ColorRegistry at: #white) ! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! asColor "Convert the receiver into a color" ^self! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! muchLighter ^ self alphaMixed: 0.233 with: Color white ! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! duller "Answer a darker, desaturated color. If the original color isn't very saturated, desaturate it by less (otherwise will just end up with grey)." | sat adjust | (sat := self saturation) > 0.3 ifTrue: [adjust := -0.1] ifFalse: [adjust := 0.1 - sat max: 0.0]. ^ self adjustSaturation: adjust brightness: -0.1 "^ self adjustSaturation: -0.03 brightness: -0.2"! ! !Color methodsFor: 'queries' stamp: 'StephaneDucasse 10/16/2013 14:39'! isTranslucent ^ alpha < 255 ! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:13'! lighter "Answer a lighter shade of this color." ^ self adjustSaturation: -0.03 brightness: 0.08! ! !Color methodsFor: 'printing' stamp: 'StephaneDucasse 10/15/2013 22:13'! storeArrayOn: aStream aStream nextPutAll: '#('. self storeArrayValuesOn: aStream. aStream nextPutAll: ') ' ! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:28'! - aColor "Answer aColor is subtracted from the given color in an additive color space. " "(Color white - Color red) display" ^ self class basicNew setPrivateRed: self privateRed - aColor privateRed green: self privateGreen - aColor privateGreen blue: self privateBlue - aColor privateBlue ! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:32'! alphaMixed: proportion with: aColor "Answer this color mixed with the given color. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. For example, 0.9 would yield a color close to the receiver. This method uses RGB interpolation; HSV interpolation can lead to surprises. Mixes the alphas (for transparency) also." | frac1 frac2 | frac1 := proportion asFloat min: 1.0 max: 0.0. frac2 := 1.0 - frac1. ^ self class r: self red * frac1 + (aColor red * frac2) g: self green * frac1 + (aColor green * frac2) b: self blue * frac1 + (aColor blue * frac2) alpha: self alpha * frac1 + (aColor alpha * frac2)! ! !Color methodsFor: 'html' stamp: 'StephaneDucasse 10/15/2013 22:13'! printHtmlString "answer a string whose characters are the html representation of the receiver" ^ ((self red * 255) asInteger printStringBase: 16 length: 2 padded: true) , ((self green * 255) asInteger printStringBase: 16 length: 2 padded: true) , ((self blue * 255) asInteger printStringBase: 16 length: 2 padded: true)! ! !Color methodsFor: 'copying' stamp: 'StephaneDucasse 10/15/2013 22:13'! veryDeepCopyWith: deepCopier "Return self. I am immutable in the Morphic world. Do not record me."! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/16/2013 14:59'! privateAlpha "Private!! Return the raw alpha value for opaque. Used only for equality testing." ^ alpha ! ! !Color methodsFor: '*Athens-Core' stamp: 'IgorStasenko 8/30/2013 16:23'! asAthensPaintOn: anAthensCanvas ^ self "^ anAthensCanvas surface createSolidColorPaint: self"! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/15/2013 22:13'! setHue: hue saturation: saturation brightness: brightness "Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details." | s v hf i f p q t | s := (saturation asFloat max: 0.0) min: 1.0. v := (brightness asFloat max: 0.0) min: 1.0. "zero saturation yields gray with the given brightness" s = 0.0 ifTrue: [ ^ self setRed: v green: v blue: v ]. hf := hue asFloat. (hf < 0.0 or: [ hf >= 360.0 ]) ifTrue: [ hf := hf - ((hf quo: 360.0) asFloat * 360.0) ]. hf := hf / 60.0. i := hf asInteger. "integer part of hue" f := hf fractionPart. "fractional part of hue" p := (1.0 - s) * v. q := (1.0 - (s * f)) * v. t := (1.0 - (s * (1.0 - f))) * v. 0 = i ifTrue: [ ^ self setRed: v green: t blue: p ]. 1 = i ifTrue: [ ^ self setRed: q green: v blue: p ]. 2 = i ifTrue: [ ^ self setRed: p green: v blue: t ]. 3 = i ifTrue: [ ^ self setRed: p green: q blue: v ]. 4 = i ifTrue: [ ^ self setRed: t green: p blue: v ]. 5 = i ifTrue: [ ^ self setRed: v green: p blue: q ]. self error: 'implementation error'! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/16/2013 14:42'! mixed: proportion with: aColor "Mix with another color and do not preserve transpareny. Only use this for extracting the RGB value and mixing it. All other callers should use instead: aColor alphaMixed: proportion with: anotherColor " | frac1 frac2 | frac1 := proportion asFloat min: 1.0 max: 0.0. frac2 := 1.0 - frac1. ^ self class r: self red * frac1 + (aColor red * frac2) g: self green * frac1 + (aColor green * frac2) b: self blue * frac1 + (aColor blue * frac2)! ! !Color methodsFor: 'comparing' stamp: 'StephaneDucasse 10/15/2013 22:46'! hash ^ rgb bitXor: alpha ! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! asColorref "Convert the receiver into a colorref" ^(self red * 255) asInteger + ((self green * 255) asInteger << 8) + ((self green * 255) asInteger << 16)! ! !Color methodsFor: '*Morphic-Base' stamp: 'StephaneDucasse 10/15/2013 22:13'! changeColorIn: aMorph event: evt "Note: This is just a workaround to make sure we don't use the old color inst var" aMorph changeColorTarget: aMorph selector: #fillStyle: originalColor: self hand: evt hand! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! asHTMLColor | s | s := '#000000' copy. s at: 2 put: (Character digitValue: ((rgb bitShift: -6 - RedShift) bitAnd: 15)). s at: 3 put: (Character digitValue: ((rgb bitShift: -2 - RedShift) bitAnd: 15)). s at: 4 put: (Character digitValue: ((rgb bitShift: -6 - GreenShift) bitAnd: 15)). s at: 5 put: (Character digitValue: ((rgb bitShift: -2 - GreenShift) bitAnd: 15)). s at: 6 put: (Character digitValue: ((rgb bitShift: -6 - BlueShift) bitAnd: 15)). s at: 7 put: (Character digitValue: ((rgb bitShift: -2 - BlueShift) bitAnd: 15)). ^ s! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! halfTonePattern2 "Return a halftone-pattern to approximate luminance levels on 2-bit deep Forms." | lum | lum := self luminance. lum < 0.125 ifTrue: [ ^ Bitmap with: 1431655765 ]. "black" lum < 0.25 ifTrue: [ ^ Bitmap with: 1431655765 with: 3722304989 ]. "1/8 gray" lum < 0.375 ifTrue: [ ^ Bitmap with: 3722304989 with: 2004318071 ]. "2/8 gray" lum < 0.5 ifTrue: [ ^ Bitmap with: 4294967295 with: 2004318071 ]. "3/8 gray" lum < 0.625 ifTrue: [ ^ Bitmap with: 4294967295 ]. "4/8 gray" lum < 0.75 ifTrue: [ ^ Bitmap with: 4294967295 with: 3149642683 ]. "5/8 gray" lum < 0.875 ifTrue: [ ^ Bitmap with: 4008636142 with: 3149642683 ]. "6/8 gray" lum < 1.0 ifTrue: [ ^ Bitmap with: 2863311530 with: 3149642683 ]. "7/8 gray" ^ Bitmap with: 2863311530 "opaque white" "handy expression for computing patterns for 2x2 tiles; set p to a string of 4 letters (e.g., 'wggw' for a gray-and- white checkerboard) and print the result of evaluating: | p d w1 w2 | p := 'wggw'. d := Dictionary new. d at: $b put: '01'. d at: $w put: '10'. d at: $g put: '11'. w1 := (d at: (p at: 1)), (d at: (p at: 2)). w1 := '2r', w1, w1, w1, w1, w1, w1, w1, w1, ' hex'. w2 := (d at: (p at: 3)), (d at: (p at: 4)). w2 := '2r', w2, w2, w2, w2, w2, w2, w2, w2, ' hex'. Array with: (Compiler evaluate: w1) with: (Compiler evaluate: w2) "! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/16/2013 14:54'! basicPixelValueForDepth: d "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue." | rgbBlack val | d = 8 ifTrue: [ ^ self closestPixelValue8 ]. "common case" d < 8 ifTrue: [ d = 4 ifTrue: [ ^ self closestPixelValue4 ]. d = 2 ifTrue: [ ^ self closestPixelValue2 ]. d = 1 ifTrue: [ ^ self closestPixelValue1 ] ]. rgbBlack := 1. "closest black that is not transparent in RGB" d = 16 ifTrue: [ "five bits per component; top bits ignored" val := (((rgb bitShift: -15) bitAnd: 31744) bitOr: ((rgb bitShift: -10) bitAnd: 992)) bitOr: ((rgb bitShift: -5) bitAnd: 31). ^ val = 0 ifTrue: [ rgbBlack ] ifFalse: [ val ] ]. d = 32 ifTrue: [ "eight bits per component; top 8 bits set to all ones (opaque alpha)" val := LargePositiveInteger new: 4. val at: 3 put: ((rgb bitShift: -22) bitAnd: 255). val at: 2 put: ((rgb bitShift: -12) bitAnd: 255). val at: 1 put: ((rgb bitShift: -2) bitAnd: 255). val at: 4 put: 255. "opaque alpha" ^ val ]. d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" val := (((rgb bitShift: -18) bitAnd: 3840) bitOr: ((rgb bitShift: -12) bitAnd: 240)) bitOr: ((rgb bitShift: -6) bitAnd: 15). ^ val = 0 ifTrue: [ rgbBlack ] ifFalse: [ val ] ]. d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" val := (((rgb bitShift: -21) bitAnd: 448) bitOr: ((rgb bitShift: -14) bitAnd: 56)) bitOr: ((rgb bitShift: -7) bitAnd: 7). ^ val = 0 ifTrue: [ rgbBlack ] ifFalse: [ val ] ]. self error: 'unknown pixel depth: ' , d printString! ! !Color methodsFor: 'private' stamp: 'StephaneDucasse 10/15/2013 22:13'! privateGreen "Private!! Return the internal representation of my green component." ^ (rgb bitShift: 0 - GreenShift) bitAnd: ComponentMask! ! !Color methodsFor: '*Athens-Core' stamp: 'IgorStasenko 8/30/2013 16:49'! athensFillRectangle: aRect on: anAthensCanvas ^ anAthensCanvas surface fillRectangle: aRect withSolidColor:self! ! !Color methodsFor: 'conversions' stamp: 'StephaneDucasse 10/15/2013 22:13'! halfTonePattern1 "Return a halftone-pattern to approximate luminance levels on 1-bit deep Forms." | lum | lum := self luminance. lum < 0.1 ifTrue: [ ^ Bitmap with: 4294967295 ]. "black" lum < 0.4 ifTrue: [ ^ Bitmap with: 3149642683 with: 4008636142 ]. "dark gray" lum < 0.6 ifTrue: [ ^ Bitmap with: 1431655765 with: 2863311530 ]. "medium gray" lum < 0.9 ifTrue: [ ^ Bitmap with: 1145324612 with: 286331153 ]. "light gray" ^ Bitmap with: 0 "1-bit white"! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/16/2013 15:04'! slightlyWhiter ^ self alphaMixed: 0.85 with: (ColorRegistry at: #white) ! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 10/15/2013 22:46'! dansDarker "Return a darker shade of the same color. An attempt to do better than the current darker method. (now obsolete, since darker has been changed to do this. -dew)" ^ self class h: self hue s: self saturation v: (self brightness - 0.16 max: 0.0)! ! !Color methodsFor: 'self evaluating' stamp: 'StephaneDucasse 10/15/2013 22:13'! isSelfEvaluating ^ true! ! !Color class methodsFor: 'other' stamp: 'FernandoOlivero 9/17/2013 21:35'! indexedColors ^ IndexedColors! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:35'! darkGray ^ ColorRegistry at: #darkGray! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! lightYellow ^ ColorRegistry at: #lightYellow! ! !Color class methodsFor: 'accesing' stamp: 'FernandoOlivero 9/17/2013 21:35'! named: aColorName ^ ColorRegistry at: aColorName asSymbol ifAbsent: nil ! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! paleRed ^ ColorRegistry at: #paleRed! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:35'! brown ^ ColorRegistry at: #brown! ! !Color class methodsFor: 'other' stamp: 'FernandoOlivero 9/17/2013 21:35'! maskingMap: depth "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map." | sizeNeeded | depth <= 8 ifTrue: [ sizeNeeded := 1 bitShift: depth ] ifFalse: [ sizeNeeded := 4096 ]. (MaskingMap == nil or: [ MaskingMap size ~= sizeNeeded ]) ifTrue: [ MaskingMap := Bitmap new: sizeNeeded withAll: 4294967295. MaskingMap at: 1 put: 0 "transparent" ]. ^ MaskingMap! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! palePeach ^ ColorRegistry at: #palePeach ! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! paleTan ^ ColorRegistry at: #paleTan! ! !Color class methodsFor: 'initialization' stamp: 'StephaneDucasse 10/16/2013 15:20'! initialize "self initialize Details: Externally, the red, green, and blue components of color are floats in the range [0.0..1.0]. Internally, they are represented as integers in the range [0..ComponentMask] packing into a small integer to save space and to allow fast hashing and equality testing. For a general description of color representations for computer graphics, including the relationship between the RGB and HSV color models used here, see Chapter 17 of Foley and van Dam, Fundamentals of Interactive Computer Graphics, Addison-Wesley, 1982." ComponentMask := 1023. HalfComponentMask := 512. "used to round up in integer calculations" ComponentMax := 1023.0. "a Float used to normalize components" RedShift := 20. GreenShift := 10. BlueShift := 0. RandomStream := Random new. self initializeIndexedColors. self initializeColorRegistry. self initializeGrayToIndexMap. ! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:37'! veryPaleRed ^ ColorRegistry at: #veryPaleRed! ! !Color class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/16/2013 15:19'! gray: brightness "Return a gray shade with the given brightness in the range [0.0..1.0]." ^ self r: brightness g: brightness b: brightness ! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:37'! veryDarkGray ^ ColorRegistry at: #veryDarkGray! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:37'! yellow ^ ColorRegistry at: #yellow! ! !Color class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/16/2013 15:20'! h: hue s: saturation v: brightness alpha: alpha ^ self basicNew intializeHue: hue saturation: saturation brightness: brightness alpha: alpha ; yourself ! ! !Color class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/16/2013 15:12'! colorFromPixelValue: p depth: d "Convert a pixel value for the given display depth into a color." "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." | r g b alpha | d = 8 ifTrue: [ ^ IndexedColors at: (p bitAnd: 255) + 1 ]. d = 4 ifTrue: [ ^ IndexedColors at: (p bitAnd: 15) + 1 ]. d = 2 ifTrue: [ ^ IndexedColors at: (p bitAnd: 3) + 1 ]. d = 1 ifTrue: [ ^ IndexedColors at: (p bitAnd: 1) + 1 ]. d = 16 | (d = 15) ifTrue: [ "five bits per component" r := (p bitShift: -10) bitAnd: 31. g := (p bitShift: -5) bitAnd: 31. b := p bitAnd: 31. (r = 0 and: [ g = 0 ]) ifTrue: [ b = 0 ifTrue: [ ^ self transparent ]. b = 1 ifTrue: [ ^ self black ] ]. ^ self r: r g: g b: b range: 31 ]. d = 32 ifTrue: [ "eight bits per component; 8 bits of alpha" r := (p bitShift: -16) bitAnd: 255. g := (p bitShift: -8) bitAnd: 255. b := p bitAnd: 255. alpha := p bitShift: -24. alpha = 0 ifTrue: [ ^ self transparent ]. (r = 0 and: [ g = 0 and: [ b = 0 ] ]) ifTrue: [ ^ self transparent ]. alpha < 255 ifTrue: [ ^ (self r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] ifFalse: [ ^ self r: r g: g b: b range: 255 ] ]. d = 12 ifTrue: [ "four bits per component" r := (p bitShift: -8) bitAnd: 15. g := (p bitShift: -4) bitAnd: 15. b := p bitAnd: 15. ^ self r: r g: g b: b range: 15 ]. d = 9 ifTrue: [ "three bits per component" r := (p bitShift: -6) bitAnd: 7. g := (p bitShift: -3) bitAnd: 7. b := p bitAnd: 7. ^ self r: r g: g b: b range: 7 ]. self error: 'unknown pixel depth: ' , d printString! ! !Color class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/16/2013 15:18'! fromArray: colorDef colorDef size = 3 ifTrue: [^self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)]. colorDef size = 0 ifTrue: [^self transparent]. colorDef size = 4 ifTrue: [^(self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)) alpha: (colorDef at: 4)]. self error: 'Undefined color definition'! ! !Color class methodsFor: 'initialization' stamp: 'StephaneDucasse 10/16/2013 15:21'! initializeColorRegistry | values| ColorRegistry := IdentityDictionary new. values := self defaultColors, self defaultColors2, self defaultColors3, self defaultColors4. 1 to: values size by: #(name r g b) size do:[:index| | colorName red green blue color | colorName := values at: index. red := values at: index + 1. green := values at: index + 2. blue := values at: index +3. color := self r: red g: green b: blue . self registerColor: color named: colorName ]. self registerColor: (self r: 0 g: 0 b: 0 alpha: 0.0) named: #transparent. ! ! !Color class methodsFor: 'colormaps' stamp: 'FernandoOlivero 9/17/2013 21:35'! computeColormapFrom: sourceDepth to: destDepth "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead." | map bitsPerColor | sourceDepth < 16 ifTrue: [ "source is 1-, 2-, 4-, or 8-bit indexed color" map := (IndexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :c | c pixelValueForDepth: destDepth ]. map := map as: Bitmap ] ifFalse: [ "source is 16-bit or 32-bit RGB" destDepth > 8 ifTrue: [ bitsPerColor := 5 "retain maximum color resolution" ] ifFalse: [ bitsPerColor := 4 ]. map := self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor ]. "Note: zero is transparent except when source depth is one-bit deep" sourceDepth > 1 ifTrue: [ map at: 1 put: 0 ]. ^ map! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:35'! green ^ ColorRegistry at: #green! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! paleYellow ^ ColorRegistry at: #paleYellow.! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:34'! black ^ ColorRegistry at: #black! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! magenta ^ ColorRegistry at: #magenta! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:37'! veryVeryLightGray ^ ColorRegistry at: #veryVeryLightGray! ! !Color class methodsFor: 'examples' stamp: 'StephaneDucasse 10/16/2013 15:27'! wheel: thisMany saturation: s brightness: v "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness." "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)" "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)" ^ (self h: 0.0 s: s v: v) wheel: thisMany ! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! paleOrange ^ ColorRegistry at: #paleOrange! ! !Color class methodsFor: 'accessing' stamp: 'StephaneDucasse 10/16/2013 15:25'! registeredColorNames ^ ColorRegistry keys collect: #asString ! ! !Color class methodsFor: 'colormaps' stamp: 'StephaneDucasse 10/16/2013 15:15'! computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth | map | map := (IndexedColors copyFrom: 1 to: (1 bitShift: sourceDepth)) collect: [ :cc | | f c | f := 1.0 - ((cc red + cc green + cc blue) / 3.0). c := targetColor notNil ifTrue: [ destDepth = 32 ifTrue: [ targetColor * f alpha: f ] ifFalse: [ targetColor alphaMixed: f * 1.5 with: self white ] ] ifFalse: [ cc ]. destDepth = 32 ifTrue: [ c pixelValueForDepth: destDepth ] ifFalse: [ f = 0.0 ifTrue: [ 0 ] ifFalse: [ c pixelValueForDepth: destDepth ] ] ]. map := map as: Bitmap. ^ map! ! !Color class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/16/2013 15:24'! r: r g: g b: b alpha: alpha "Return a color with the given r, g, and b components in the range [0.0..1.0]." ^ self basicNew initializeRed: r green: g blue: b alpha: alpha ; yourself.! ! !Color class methodsFor: 'colormaps' stamp: 'FernandoOlivero 9/17/2013 21:35'! computeColorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix sourceDepth < 16 ifTrue: [ "source is 1-, 2-, 4-, or 8-bit indexed color. Assumed not to include subpixelAA" ^ self computeIndexedColorConvertingMap: targetColor from: sourceDepth to: destDepth ] ifFalse: [ "source is 16-bit or 32-bit RGB. Might include subpixelAA" ^ self computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix ]! ! !Color class methodsFor: 'instance creation' stamp: 'FernandoOlivero 9/17/2013 21:35'! fromHexString: aColorHex | green red blue | red := (Integer readFrom: (aColorHex first: 2) base: 16) / 255. green := (Integer readFrom: (aColorHex copyFrom: 3 to: 4) base: 16) / 255. blue := (Integer readFrom: (aColorHex last: 2) base: 16) / 255. ^self r: red g: green b: blue! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:35'! lightCyan ^ ColorRegistry at: #lightCyan! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:57'! transparent ^ ColorRegistry at: #transparent ! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! paleMagenta ^ ColorRegistry at: #paleMagenta! ! !Color class methodsFor: 'instance creation' stamp: 'MarcusDenker 3/27/2014 11:02'! colorFrom: parm "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" | aColor firstParm | (parm isKindOf: Color) ifTrue: [^ parm]. (parm isSymbol) ifTrue: [^ self perform: parm]. (parm isString) ifTrue: [^ self fromString: parm]. ((parm isKindOf: SequenceableCollection) and: [parm size > 0]) ifTrue: [firstParm := parm first. (firstParm isKindOf: Number) ifTrue: [^ self fromRgbTriplet: parm]. aColor := self colorFrom: firstParm. parm doWithIndex: [:sym :ind | ind > 1 ifTrue: [aColor := aColor perform: sym]]. ^ aColor]. ^ parm " Color colorFrom: #(blue darker) Color colorFrom: Color blue darker Color colorFrom: #blue Color colorFrom: #(0.0 0.0 1.0) "! ! !Color class methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 10/18/2013 14:33'! aaFontsColormapDepth "Adjust balance between colored AA text quality (especially if subpixel AA is used) and space / performance. 5 is optimal quality. Each colorMap takes 128kB of RAM, and takes several seconds to build. 4 is a reasonable balance. Each colorMap takes 16kB of RAM and builds fast on a fast machine. 3 is good for slow hardware or memory restrictions. Each colorMap takes 2 kb of RAM." ^ 4! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:27'! defaultColors4 ^{ #paleRed. 1.0. 0.901. 0.901. #palePeach. 1.0. 0.929. 0.835. #paleOrange. 0.991. 0.929. 0.843. #paleMagenta. 1.0. 0.901. 1.0. #paleGreen. 0.874. 1.0. 0.835. #paleBuff. 0.995. 0.979. 0.921. #paleBlue. 0.87. 0.976. 0.995. }! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! lightGreen ^ ColorRegistry at: #lightGreen! ! !Color class methodsFor: 'other' stamp: 'FernandoOlivero 9/17/2013 21:35'! pixelScreenForDepth: depth "Return a 50% stipple containing alternating pixels of all-zeros and all-ones to be used as a mask at the given depth." | mask bits | mask := (1 bitShift: depth) - 1. bits := 2 * depth. [ bits >= 32 ] whileFalse: [ mask := mask bitOr: (mask bitShift: bits). "double the length of mask" bits := bits + bits ]. ^ Bitmap with: mask with: mask bitInvert32! ! !Color class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/16/2013 15:25'! random "Return a random color that isn't too dark or under-saturated." ^ self h: (360.0 * RandomStream next) s: (0.3 + (RandomStream next * 0.7)) v: (0.4 + (RandomStream next * 0.6)) alpha: 1.0! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! orange ^ ColorRegistry at: #orange! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! paleBuff ^ ColorRegistry at: #paleBuff! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:37'! red ^ ColorRegistry at: #red! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:27'! defaultColors2 ^{ #red. 1.0. 0. 0. #yellow. 1.0. 1.0. 0. #green. 0. 1.0. 0. #cyan. 0. 1.0. 1.0. #blue. 0. 0. 1.0. #magenta. 1.0. 0. 1.0. #brown. 0.6. 0.2. 0. #orange. 1.0. 0.6. 0. #lightRed. 1.0. 0.8. 0.8. } ! ! !Color class methodsFor: 'examples' stamp: 'StephaneDucasse 10/16/2013 15:27'! wheel: thisMany "Return a collection of thisMany colors evenly spaced around the color wheel." "Color showColors: (Color wheel: 12)" ^ self wheel: thisMany saturation: 0.9 brightness: 0.7 ! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:27'! defaultColors3 ^{ #lightYellow. 1.0. 1.0. 0.8. #lightGreen. 0.8. 1.0. 0.6. #lightCyan. 0.4. 1.0. 1.0. #lightBlue. 0.8. 1.0. 1.0. #lightMagenta. 1.0. 0.8. 1.0. #lightBrown. 1.0. 0.6. 0.2. #lightOrange. 1.0. 0.8. 0.4. #pink. 1.0. 0.752899. 0.796118. #purple. 0.4. 0.0. 0.6. #tan. 0.8. 0.8. 0.5. #veryPaleRed. 1.0. 0.948. 0.948. #paleYellow. 1.0. 1.0. 0.85. #paleTan. 0.921. 0.878. 0.78. }! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:35'! gray ^ ColorRegistry at: #gray! ! !Color class methodsFor: 'other' stamp: 'MarcusDenker 3/27/2014 11:04'! shutDown "Color shutDown" CachedColormaps := nil. "Maps to translate between color depths" MaskingMap := nil "Maps all colors except transparent to black for creating a mask"! ! !Color class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/16/2013 15:24'! r: r g: g b: b range: range "Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)." ^ self basicNew initializeRed: r green: g blue: b range: range; yourself ! ! !Color class methodsFor: 'instance creation' stamp: 'MarcusDenker 3/27/2014 11:04'! h: hue s: saturation v: brightness "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red." "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue." ^ self h: hue s: saturation v: brightness alpha: 1.0! ! !Color class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/16/2013 15:18'! fromRgbTriplet: list ^ self r: list first g: list second b: list last! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! lightOrange ^ ColorRegistry at: #lightOrange! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:37'! purple ^ ColorRegistry at: #purple! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:37'! white ^ ColorRegistry at: #white! ! !Color class methodsFor: 'other' stamp: 'FernandoOlivero 9/17/2013 21:35'! hex: aFloat "Return an hexadecimal two-digits string between 00 and FF for a float between 0.0 and 1.0" | str | str := ((aFloat * 255) asInteger printStringHex) asLowercase. str size = 1 ifTrue: [^'0',str] ifFalse: [^str]! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:47'! tan ^ ColorRegistry at: #tan! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:35'! lightBrown ^ ColorRegistry at: #lightBrown! ! !Color class methodsFor: 'colormaps' stamp: 'StephaneDucasse 10/16/2013 15:16'! computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component." | mask map c | (#(3 4 5 ) includes: bitsPerColor) ifFalse: [ self error: 'BitBlt only supports 3, 4, or 5 bits per color component' ]. mask := (1 bitShift: bitsPerColor) - 1. map := Bitmap new: (1 bitShift: 3 * bitsPerColor). 0 to: map size - 1 do: [ :i | c := self r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask) g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask) b: ((i bitShift: 0) bitAnd: mask) range: mask. map at: i + 1 put: (c pixelValueForDepth: destDepth) ]. map at: 1 put: (self transparent pixelWordForDepth: destDepth). "zero always transparent" ^ map! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:37'! veryLightGray ^ ColorRegistry at: #veryLightGray! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:35'! lightGray ^ ColorRegistry at: #lightGray! ! !Color class methodsFor: '*System-Settings-Browser' stamp: 'StephaneDucasse 10/18/2013 15:04'! settingInputWidgetForNode: aSettingNode ^ aSettingNode inputWidgetForColor! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:27'! defaultColors ^{ #black. 0. 0. 0. #veryVeryDarkGray. 0.125. 0.125. 0.125. #veryDarkGray. 0.25. 0.25. 0.25. #darkGray. 0.375. 0.375. 0.375. #gray. 0.5. 0.5. 0.5. #lightGray. 0.625. 0.625. 0.625. #veryLightGray. 0.75. 0.75. 0.75. #veryVeryLightGray. 0.875. 0.875. 0.875. #white. 1.0. 1.0. 1.0. } ! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! paleGreen ^ ColorRegistry at: #paleGreen! ! !Color class methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 3/27/2014 11:03'! cachedColormapFrom: sourceDepth to: destDepth "Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations." "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" "Note: The colormap cache may be cleared by evaluating 'Color shutDown'." | srcIndex map | CachedColormaps class == Array ifFalse: [ CachedColormaps := (1 to: 9) collect: [ :i | Array new: 32 ] ]. srcIndex := sourceDepth. sourceDepth > 8 ifTrue: [ srcIndex := 9 ]. (map := (CachedColormaps at: srcIndex) at: destDepth) ~~ nil ifTrue: [ ^ map ]. map := self computeColormapFrom: sourceDepth to: destDepth. (CachedColormaps at: srcIndex) at: destDepth put: map. ^ map! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! lightRed ^ ColorRegistry at: #lightRed! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:35'! blue ^ ColorRegistry at: #blue! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:37'! veryVeryDarkGray ^ ColorRegistry at: #veryVeryDarkGray ! ! !Color class methodsFor: 'initialization' stamp: 'StephaneDucasse 10/18/2013 11:09'! initializeGrayToIndexMap "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level." "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors." "Color initializeGrayToIndexMap" "record the level and index of each gray in the 8-bit color table" | grayLevels grayIndices c distToClosest dist indexOfClosest | grayLevels := OrderedCollection new. grayIndices := OrderedCollection new. "Note: skip the first entry, which is reserved for transparent" 2 to: IndexedColors size do: [ :i | c := IndexedColors at: i. c saturation = 0.0 ifTrue: [ "c is a gray" grayLevels add: c privateBlue >> 2. "top 8 bits; R, G, and B are the same" grayIndices add: i - 1 ] ]. "pixel values are zero-based" grayLevels := grayLevels asArray. grayIndices := grayIndices asArray. "for each gray level in [0..255], select the closest match" GrayToIndexMap := ByteArray new: 256. 0 to: 255 do: [ :level | distToClosest := 10000. "greater than distance to any real gray" 1 to: grayLevels size do: [ :i | dist := (level - (grayLevels at: i)) abs. dist < distToClosest ifTrue: [ distToClosest := dist. indexOfClosest := grayIndices at: i ] ]. GrayToIndexMap at: level + 1 put: indexOfClosest ]! ! !Color class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/16/2013 15:24'! r: r g: g b: b "Return a color with the given r, g, and b components in the range [0.0..1.0]." ^ self r: r g: g b: b alpha: 1.0! ! !Color class methodsFor: 'colormaps' stamp: 'StephaneDucasse 10/16/2013 15:16'! computeRGBColorConvertingMap: targetColor to: destDepth keepSubPixelAA: keepSubPix "Builds a colormap intended to convert from subpixelAA black values to targetColor values. keepSubPix ifTrue: [ Answer colors that also include subpixelAA ] ifFalse: [ Take fullpixel luminance level. Apply it to targetColor. I.e. answer colors with NO subpixelAA ]" | mask map c bitsPerColor r g b f v | destDepth > 8 ifTrue: [ bitsPerColor := 5 "retain maximum color resolution" ] ifFalse: [ bitsPerColor := 4 ]. "Usually a bit less is enough, but make it configurable" bitsPerColor := bitsPerColor min: self aaFontsColormapDepth. mask := (1 bitShift: bitsPerColor) - 1. map := Bitmap new: (1 bitShift: 3 * bitsPerColor). 0 to: map size - 1 do: [ :i | r := (i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask. g := (i bitShift: 0 - bitsPerColor) bitAnd: mask. b := (i bitShift: 0) bitAnd: mask. f := 1.0 - ((r + g + b) / 3.0 / mask). c := targetColor notNil ifTrue: [ (keepSubPix and: [ destDepth > 8 ]) ifTrue: [ self r: (1.0 - (r / mask)) * targetColor red g: (1.0 - (g / mask)) * targetColor green b: (1.0 - (b / mask)) * targetColor blue alpha: f * targetColor alpha "alpha will be ignored below, in #pixelValueForDepth: if destDepth ~= 32" ] ifFalse: [ destDepth = 32 ifTrue: [ targetColor * f alpha: f * targetColor alpha ] ifFalse: [ targetColor alphaMixed: f * 1.5 with: self white ] ] ] ifFalse: [ self r: r g: g b: b range: mask ]. "This is currently used only to keep some SubPixelAA on destDepth = 8, using a single pass of rule 25" v := destDepth = 32 ifTrue: [ c pixelValueForDepth: destDepth ] ifFalse: [ f < 0.1 ifTrue: [ 0 ] ifFalse: [ c pixelValueForDepth: destDepth ] ]. map at: i + 1 put: v ]. ^ map! ! !Color class methodsFor: 'color from user' stamp: 'StephaneDucasse 10/16/2013 15:13'! colorPaletteForDepth: depth extent: chartExtent "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." "Note: It is slow to build this palette, so it should be cached for quick access." "(Color colorPaletteForDepth: 16 extent: 190@60) display" | basicHue x y startHue palette transHt vSteps transCaption grayWidth hSteps | palette := Form extent: chartExtent depth: depth. transCaption := (Form extent: 34@9 depth: 1 fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0) offset: 0@0). transHt := transCaption height. palette fillWhite: (0@0 extent: palette width@transHt). palette fillBlack: (0@transHt extent: palette width@1). transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). grayWidth := 10. startHue := 338.0. vSteps := palette height - transHt // 2. hSteps := palette width - grayWidth. x := 0. startHue to: startHue + 360.0 by: 360.0/hSteps do: [ :h | basicHue := Color h: h asFloat s: 1.0 v: 1.0. y := transHt+1. 0 to: vSteps do: [ :n | | c | c := basicHue mixed: (n asFloat / vSteps asFloat) with: self white. palette fill: (x@y extent: 1@1) fillColor: c. y := y + 1]. 1 to: vSteps do: [ :n | | c | c := self black mixed: (n asFloat / vSteps asFloat) with: basicHue. palette fill: (x@y extent: 1@1) fillColor: c. y := y + 1]. x := x + 1]. y := transHt + 1. 1 to: vSteps * 2 do: [ :n | | c | c := self black mixed: (n asFloat / (vSteps*2) asFloat) with: self white. palette fill: (x@y extent: 10@1) fillColor: c. y := y + 1]. ^ palette! ! !Color class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/16/2013 15:23'! new ^ self r: 0.0 g: 0.0 b: 0.0! ! !Color class methodsFor: 'accesing' stamp: 'FernandoOlivero 9/17/2013 21:35'! unregisterColorNamed: aName ColorRegistry removeKey: aName ifAbsent: nil! ! !Color class methodsFor: 'initialization' stamp: 'StephaneDucasse 10/16/2013 15:22'! initializeIndexedColors "Build an array of colors corresponding to the fixed colormap used for display depths of 1, 2, 4, or 8 bits." "Color initializeIndexedColors" | a index grayVal | a := Array new: 256. "1-bit colors (monochrome)" a at: 1 put: (self r: 1.0 g: 1.0 b: 1.0). "white or transparent" a at: 2 put: (self r: 0.0 g: 0.0 b: 0.0). "black" "additional colors for 2-bit color" a at: 3 put: (self r: 1.0 g: 1.0 b: 1.0). "opaque white" a at: 4 put: (self r: 0.5 g: 0.5 b: 0.5). "1/2 gray" "additional colors for 4-bit color" a at: 5 put: (self r: 1.0 g: 0.0 b: 0.0). "red" a at: 6 put: (self r: 0.0 g: 1.0 b: 0.0). "green" a at: 7 put: (self r: 0.0 g: 0.0 b: 1.0). "blue" a at: 8 put: (self r: 0.0 g: 1.0 b: 1.0). "cyan" a at: 9 put: (self r: 1.0 g: 1.0 b: 0.0). "yellow" a at: 10 put: (self r: 1.0 g: 0.0 b: 1.0). "magenta" a at: 11 put: (self r: 0.125 g: 0.125 b: 0.125). "1/8 gray" a at: 12 put: (self r: 0.25 g: 0.25 b: 0.25). "2/8 gray" a at: 13 put: (self r: 0.375 g: 0.375 b: 0.375). "3/8 gray" a at: 14 put: (self r: 0.625 g: 0.625 b: 0.625). "5/8 gray" a at: 15 put: (self r: 0.75 g: 0.75 b: 0.75). "6/8 gray" a at: 16 put: (self r: 0.875 g: 0.875 b: 0.875). "7/8 gray" "additional colors for 8-bit color" "24 more shades of gray (1/32 increments but not repeating 1/8 increments)" index := 17. 1 to: 31 do: [ :v | v \\ 4 = 0 ifFalse: [ grayVal := v / 32.0. a at: index put: (Color r: grayVal g: grayVal b: grayVal). index := index + 1 ] ]. "The remainder of color table defines a color cube with six steps for each primary color. Note that the corners of this cube repeat previous colors, but this simplifies the mapping between RGB colors and color map indices. This color cube spans indices 40 through 255 (indices 41-256 in this 1-based array)." 0 to: 5 do: [ :r | 0 to: 5 do: [ :g | 0 to: 5 do: [ :b | index := 41 + (36 * r + (6 * b) + g). index > 256 ifTrue: [ self error: 'index out of range in color table compuation' ]. a at: index put: (self r: r g: g b: b range: 5) ] ] ]. IndexedColors := a! ! !Color class methodsFor: 'initialization' stamp: 'StephaneDucasse 10/18/2013 11:07'! registerColor: aColor named: aName ColorRegistry at: aName put: aColor. ! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:35'! cyan ^ ColorRegistry at: #cyan! ! !Color class methodsFor: 'colormaps' stamp: 'StephaneDucasse 10/16/2013 15:12'! colorMapIfNeededFrom: sourceDepth to: destDepth "Return a colormap for mapping between the given depths, or nil if no colormap is needed." "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!" sourceDepth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [ "mapping is done in BitBlt by zero-filling or truncating each color component" ^ nil]. ^ self cachedColormapFrom: sourceDepth to: destDepth ! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! lightMagenta ^ ColorRegistry at: #lightMagenta! ! !Color class methodsFor: 'instance creation' stamp: 'MarcusDenker 3/27/2014 11:04'! fromString: aString "for HTML color spec: #FFCCAA or white/black" "Color fromString: '#FFCCAA'. Color fromString: 'orange'" | aColorHex | aString isEmptyOrNil ifTrue: [ ^ self white ]. aColorHex := aString first = $# ifTrue: [ aString allButFirst ] ifFalse: [ aString ]. "Try to match aColorHex with known named colors, case insensitive." ^ self registeredColorNames detect: [ :each | each sameAs: aColorHex ] ifFound: [ :namedColor | self named: namedColor ] ifNone: [ (aColorHex size = 6 and: [ aColorHex allSatisfy: [ :character | '0123456789ABCDEFabcdef' includes: character ] ]) ifTrue: [ self fromHexString: aColorHex ] ifFalse: [ self white ] ]! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:35'! lightBlue ^ ColorRegistry at: #lightBlue! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! paleBlue ^ ColorRegistry at: #paleBlue ! ! !Color class methodsFor: 'defaults' stamp: 'FernandoOlivero 8/24/2013 19:36'! pink ^ ColorRegistry at: #pink.! ! !Color class methodsFor: 'accessing' stamp: 'StephaneDucasse 10/16/2013 15:26'! registeredNameOf: aColor | colorName | colorName := #unnamed. ColorRegistry keysAndValuesDo: [:key :value| value = aColor ifTrue: [ colorName := key ] ]. ^ colorName ! ! !ColorApiSetter commentStamp: 'TorstenBergmann 2/5/2014 09:18'! Widget setter API for colors! !ColorApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/16/2012 19:29'! initializeWidgets self instantiateModels: #( selector LabelModel choice ColorEditor ). self selector text: ''. self choice whenColorChangedDo: [:c | self setValueTo: c ]! ! !ColorApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 19:26'! internUpdateWith: aColor choice setAbsoluteRed: aColor red. choice setAbsoluteBlue: aColor blue. choice setAbsoluteGreen: aColor green. choice setAbsoluteAlpha: aColor alpha.! ! !ColorArray commentStamp: 'TorstenBergmann 2/12/2014 15:40'! An array of colors! !ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:03'! at: index ^(super at: index) asColorOfDepth: 32! ! !ColorArray methodsFor: 'converting' stamp: 'ar 3/3/2001 20:06'! asColorArray ^self! ! !ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:04'! at: index put: aColor ^super at: index put: (aColor pixelWordForDepth: 32).! ! !ColorChanged commentStamp: 'LaurentLaffont 4/15/2011 20:19'! I'm a Announcement used to indicate a color has changed. Example: (ColorSelectorDialogWindow new title: 'Choose a color'; open; announcer) on: ColorChanged do: [:ann| UIManager inform: 'Selected color: ', ann newColor asString].! !ColorChanged methodsFor: 'accessing' stamp: 'dik 6/27/2010 16:26'! newColor ^ newColor! ! !ColorChanged methodsFor: 'accessing' stamp: 'dik 6/27/2010 16:26'! newColor: anObject newColor := anObject! ! !ColorChanged class methodsFor: 'instance creation' stamp: 'dik 6/27/2010 16:26'! to: aColor ^self new newColor: aColor! ! !ColorChooserMorph commentStamp: 'gvc 5/18/2007 13:45'! ColorPresenter that opens a colour selector when clicked.! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 13:46'! enabled "Answer the enabled state of the receiver." ^enabled! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/12/2006 13:51'! update: aSymbol "Refer to the comment in View|update:." super update: aSymbol. aSymbol == self getEnabledSelector ifTrue: [self updateEnabled. ^ self]! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 19:40'! newContentMorph "Answer a new button morph" |b| b := (self theme newButtonIn: self for: self getState: nil action: #chooseColor arguments: #() getEnabled: #enabled label: (self newHatchMorph layoutInset: 2) help: nil) hResizing: #spaceFill. b contentHolder hResizing: #spaceFill. ^b! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:25'! updateEnabled "Update the enablement state." self model ifNotNil: [ self getEnabledSelector ifNotNil: [ self enabled: (self model perform: self getEnabledSelector)]]! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: ''! enabledString "Answer the string to be shown in a menu to represent the 'enabled' status" ^ (self enabled) -> 'enabled' translated! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: ''! addToggleItemsToHaloMenu: aCustomMenu "Add toggle-items to the halo menu" super addToggleItemsToHaloMenu: aCustomMenu. aCustomMenu addUpdating: #enabledString target: self action: #toggleEnabled! ! !ColorChooserMorph methodsFor: 'accessing' stamp: 'gvc 10/12/2006 13:47'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/14/2009 18:41'! setColorSelector: anObject "Set the value of setColorSelector" setColorSelector := anObject! ! !ColorChooserMorph methodsFor: 'initialization' stamp: 'gvc 5/22/2007 11:44'! initialize "Initialize the receiver." enabled := true. super initialize! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 6/28/2012 10:18'! chooseColor "Popup the color picker for now." |newColor| newColor := self theme chooseColorIn: ((self ownerThatIsA: SystemWindow) ifNil: [self]) title: 'Choose Color' translated color: self labelMorph color. newColor ifNil: [^self]. self labelMorph color: newColor. self solidLabelMorph color: newColor asNontranslucentColor. self setColorSelector ifNotNil: [self model perform: self setColorSelector with: newColor]! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/14/2009 18:41'! setColorSelector "Answer the value of setColorSelector" ^ setColorSelector! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: ''! toggleEnabled "Toggle the enabled state." self enabled: self enabled not! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 12/11/2009 07:38'! enabled: aBoolean "Set the enabled state of the receiver." enabled := aBoolean. self contentMorph ifNotNil: [:m | m enabled: aBoolean]. self changed: #enabled! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:46'! on: anObject color: getColSel changeColor: setColSel "Set the receiver to the given model parameterized by the given message selectors." self on: anObject color: getColSel; setColorSelector: setColSel! ! !ColorChooserMorph methodsFor: 'accessing' stamp: 'gvc 10/12/2006 13:51'! getEnabledSelector: anObject "Set the value of getEnabledSelector" getEnabledSelector := anObject. self updateEnabled! ! !ColorChooserMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 3/3/2010 16:14'! on: anObject color: getSel changeColor: setSel "Answer a new instance of the receiver on the given model using the given selectors as the interface." "(ColorChooserMorph on: (BorderedMorph new) color: #color changeColor: #color:) openInWorld" ^self new on: anObject color: getSel changeColor: setSel! ! !ColorEditor commentStamp: 'TorstenBergmann 2/5/2014 09:19'! Color editor! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:18'! r ^ r! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:05'! morph: anObject morph := anObject! ! !ColorEditor methodsFor: 'initialization' stamp: 'StephaneDucasse 10/13/2013 21:42'! updateColor | newColor | newColor := Color r: r value g: g value b: b value range: 256. newColor := newColor alpha: (a value) / 256. r color: (Color r: r value g: 0 b: 0 range: 256). g color: (Color r: 0 g: g value b: 0 range: 256). b color: (Color r: 0 g: 0 b: b value range: 256). self color: newColor. morph color: newColor! ! !ColorEditor methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 19:08'! whenColorChangedDo: aBlock color whenChangedDo: aBlock ! ! !ColorEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 19:27'! setAbsoluteGreen: aFloat g absoluteValue: aFloat ! ! !ColorEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 19:27'! setAbsoluteBlue: aFloat b absoluteValue: aFloat ! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:18'! b ^ b! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:18'! g ^ g! ! !ColorEditor methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/18/2012 16:48'! initializeWidgets self instantiateModels: #( r SliderModel g SliderModel b SliderModel a SliderModel ). r min: 0; max: 255; label: 'red'; quantum: 1; value: 0; whenValueChangedDo: [ self updateColor ]. g min: 0; max: 255; label: 'green'; quantum: 1; value: 0; whenValueChangedDo: [ self updateColor ]. b min: 0; max: 255; label: 'blue'; quantum: 1; value: 0; whenValueChangedDo: [ self updateColor ]. a min: 0; max: 255; label: 'alpha'; quantum: 1; value: 255; whenValueChangedDo: [ self updateColor ]. ! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! color: anObject color value: anObject! ! !ColorEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 19:27'! setAbsoluteAlpha: aFloat a absoluteValue: aFloat ! ! !ColorEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 19:27'! setAbsoluteRed: aFloat r absoluteValue: aFloat ! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:06'! morph ^ morph! ! !ColorEditor methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. color := Color black asReactiveVariable. morph := Morph new color: self color; extent: 25@25; yourself! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! color ^ color value! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:18'! a ^ a! ! !ColorEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 19:19'! help: aString r help: aString. g help: aString. b help: aString. a help: aString.! ! !ColorEditor class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 7/16/2012 19:19'! spec ^ SpecLayout composed newRow: [:r | r add: #r; add: #g; add: #b; add: #a; newColumn: [:c | c add: #morph ] width: 25 ] height: 25; yourself! ! !ColorFillStyle commentStamp: 'gvc 12/8/2008 13:05'! Simple fillstyle that draws a color at the specified origin with option extent.! !ColorFillStyle methodsFor: 'accessing' stamp: 'gvc 12/8/2008 13:05'! extent "Answer the value of extent" ^ extent! ! !ColorFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 13:14'! isOrientedFill "Answer true if origin is not nil so that morph movement adjusts origin." ^self origin notNil! ! !ColorFillStyle methodsFor: 'accessing' stamp: 'gvc 12/8/2008 13:05'! extent: anObject "Set the value of extent" extent := anObject! ! !ColorFillStyle methodsFor: 'accessing' stamp: 'gvc 12/8/2008 13:05'! origin "Answer the value of origin" ^ origin! ! !ColorFillStyle methodsFor: 'accessing' stamp: 'gvc 12/8/2008 13:05'! origin: anObject "Set the value of origin" origin := anObject! ! !ColorFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 13:11'! fillRectangle: aRectangle on: aCanvas "Fill the given rectangle on the given canvas with the receiver." |o c| o := self origin ifNil: [aRectangle origin] ifNotNil: [self origin]. c := self extent ifNil: [aRectangle corner] ifNotNil: [o + self extent]. aCanvas fillRectangle: (o corner: c) basicFillStyle: self! ! !ColorForm commentStamp: ''! ColorForm is a normal Form plus a color map of up to 2^depth Colors. Typically, one reserves one entry in the color map for transparent. This allows 1, 3, 15, or 255 non-transparent colors in ColorForms of depths 1, 2, 4, and 8 bits per pixel. ColorForms don't support depths greater than 8 bits because that would require excessively large color maps with little real benefit, since 16-bit and 32-bit depths already support thousands and millions of colors. ColorForms have several uses: 1) Precise colors. You can have up to 256 true colors, instead being limited to the 8-bit color palette. 2) Easy transparency. Just store (Color transparent) at the desired position in the color map. 3) Cheap color remapping by changing the color map. A color map is an Array of up to 2^depth Color objects. A Bitmap colorMap is automatically computed and cached for rapid display. Note that if you change the color map, you must resubmit it via the colors: method to flush this cache. ColorForms can be a bit tricky. Note that: a) When you BitBlt from one ColorForm to another, you must remember to copy the color map of the source ColorForm to the destination ColorForm. b) A ColorForm's color map is an array of depth-independent Color objects. BitBlt requires a BitMap of actual pixel values, adjusted to the destination depth. These are different things!! ColorForms automatically maintain a cache of the BitBlt-style color map corresponding to the colors array for the last depth on which the ColorForm was displayed, so there should be little need for clients to work with BitBlt-style color maps. c) The default map for 8 bit depth has black in the first entry, not transparent. Say (cform colors at: 1 put: Color transparent). ! !ColorForm methodsFor: 'accessing' stamp: 'mir 7/21/1999 11:51'! colorsFromArray: colorArray | colorList | colorList := colorArray collect: [:colorDef | Color fromArray: colorDef]. self colors: colorList! ! !ColorForm methodsFor: 'color manipulation' stamp: 'jm 4/18/98 20:34'! colorsUsed "Return a list of the colors actually used by this ColorForm." | myColor list | myColor := self colors. list := OrderedCollection new. self tallyPixelValues doWithIndex: [:count :i | count > 0 ifTrue: [list add: (myColor at: i)]]. ^ list asArray ! ! !ColorForm methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:44'! colormapIfNeededFor: destForm | newMap color pv | (self hasNonStandardPalette or:[destForm hasNonStandardPalette]) ifFalse:[ ^self colormapIfNeededForDepth: destForm depth. ]. colors == nil ifTrue: [ "use the standard colormap" ^ super colormapIfNeededFor: destForm]. (destForm depth = cachedDepth and:[cachedColormap isColormap]) ifTrue: [^ cachedColormap]. newMap := WordArray new: (1 bitShift: self depth). 1 to: colors size do: [:i | color := colors at: i. pv := destForm pixelValueFor: color. (pv = 0 and:[color isTransparent not]) ifTrue:[pv := 1]. newMap at: i put: pv]. cachedDepth := destForm depth. ^cachedColormap := ColorMap shifts: nil masks: nil colors: newMap.! ! !ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/14/97 17:25'! colorAt: aPoint "Return the color of the pixel at aPoint." ^ self colors at: (self pixelValueAt: aPoint) + 1 ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 09:08'! replaceColor: oldColor with: newColor "Replace all occurances of the given color with the given new color in my color map." self ensureColorArrayExists. 1 to: colors size do: [:i | (colors at: i) = oldColor ifTrue: [colors at: i put: newColor]]. self clearColormapCache. ! ! !ColorForm methodsFor: 'testing' stamp: 'ar 2/10/2004 17:18'! isTranslucent "Answer whether this form may be translucent" ^true! ! !ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/14/97 17:25'! colorAt: aPoint put: aColor "Store the given color into the pixel at aPoint. The given color must match one of the colors in the receiver's colormap." | i | i := self colors indexOf: aColor ifAbsent: [^ self error: 'trying to use a color that is not in my colormap']. self pixelValueAt: aPoint put: i - 1. ! ! !ColorForm methodsFor: 'copying' stamp: 'ar 10/24/2005 22:25'! blankCopyOf: aRectangle scaledBy: scale ^Form extent: (aRectangle extent * scale) truncated depth: 32! ! !ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 08:37'! setExtent: extent depth: bitsPerPixel "Create a virtual bit map with the given extent and bitsPerPixel." bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits']. super setExtent: extent depth: bitsPerPixel. ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'di 11/11/1998 13:20'! asGrayScale "Return a grayscale ColorForm computed by mapping each color into its grayscale equivalent" ^ self copy colors: (colors collect: [:c | c isTransparent ifTrue: [c] ifFalse: [Color gray: c luminance]])! ! !ColorForm methodsFor: 'filein/out' stamp: 'ar 3/3/2001 20:07'! hibernate "Make myself take up less space. See comment in Form>hibernate." super hibernate. self clearColormapCache. colors ifNotNil:[colors := colors asColorArray].! ! !ColorForm methodsFor: 'private' stamp: 'ar 5/17/2001 15:44'! ensureColorArrayExists "Return my color palette." colors ifNil: [ self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: self depth))]. ! ! !ColorForm methodsFor: 'pixel accessing' stamp: 'StephaneDucasse 10/25/2013 16:16'! pixelValueAt: aPoint "Return the raw pixel value at the given point. Typical clients use colorAt: to get a Color." "Details: To get the raw pixel value, be sure the peeker's colorMap is nil." ^ (BitBlt bitPeekerFromForm: self) colorMap: nil; pixelAt: aPoint ! ! !ColorForm methodsFor: 'copying' stamp: 'StephaneDucasse 10/25/2013 16:16'! copy: aRect "Return a new ColorForm containing the portion of the receiver delineated by aRect." | newForm | newForm := self class extent: aRect extent depth: depth. ((BitBlt destForm: newForm sourceForm: self fillColor: nil combinationRule: Form over destOrigin: 0@0 sourceOrigin: aRect origin extent: aRect extent clipRect: newForm boundingBox) colorMap: nil) copyBits. colors ifNotNil: [newForm colors: colors copy]. ^ newForm ! ! !ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:12'! depth: bitsPerPixel bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits']. super depth: bitsPerPixel. ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:27'! transparentColor: aColor "Make all occurances of the given color transparent. Note: for colors like black and white, which have two entries in the colorMap, this changes BOTH of them. Not always what you want." self replaceColor: aColor with: Color transparent. ! ! !ColorForm methodsFor: 'testing' stamp: 'ar 5/27/2001 16:34'! isColorForm ^true! ! !ColorForm methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45'! colors: colorList "Set my color palette to the given collection." | colorArray colorCount newColors | colorList ifNil: [ colors := cachedDepth := cachedColormap := nil. ^ self]. colorArray := colorList asArray. colorCount := colorArray size. newColors := Array new: (1 bitShift: self depth). 1 to: newColors size do: [:i | i <= colorCount ifTrue: [newColors at: i put: (colorArray at: i)] ifFalse: [newColors at: i put: Color transparent]]. colors := newColors. cachedDepth := nil. cachedColormap := nil. ! ! !ColorForm methodsFor: 'private' stamp: 'jm 2/24/98 18:53'! unusedColormapEntry "Return the index of an unused color map entry, or zero if there isn't one." | tallies | tallies := self tallyPixelValues. 1 to: tallies size do: [:i | (tallies at: i) = 0 ifTrue: [^ i]]. ^ 0 ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'jm 10/19/1998 10:52'! mapColor: oldColor to: newColor "Replace all occurances of the given color with the given new color in my color map." self ensureColorArrayExists. 1 to: colors size do: [:i | (colors at: i) = oldColor ifTrue: [colors at: i put: newColor]]. self clearColormapCache. ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'di 8/28/1998 15:48'! indexOfColor: aColor "Return the index of aColor in my color array" self ensureColorArrayExists. ^ colors indexOf: aColor ifAbsent: [0]! ! !ColorForm methodsFor: 'testing' stamp: 'JuanVuletich 10/12/2010 12:44'! mightBeTranslucent "Answer whether this form may be translucent" ^true! ! !ColorForm methodsFor: 'pixel accessing' stamp: 'tk 10/21/97 12:27'! isTransparentAt: aPoint "Return true if the receiver is transparent at the given point." ^ (self colorAt: aPoint) isTransparent ! ! !ColorForm methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:46'! readAttributesFrom: aBinaryStream super readAttributesFrom: aBinaryStream. colors := ColorArray new: (2 raisedTo: depth). 1 to: colors size do: [:idx | colors basicAt: idx put: (aBinaryStream nextLittleEndianNumber: 4). ]. ! ! !ColorForm methodsFor: 'copying' stamp: 'jm 2/27/98 09:38'! deepCopy ^ self shallowCopy bits: bits copy; offset: offset copy; colors: colors ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 11:18'! ensureTransparentColor "Ensure that the receiver (a) includes Color transparent in its color map and (b) that the entry for Color transparent is the first entry in its color map." | i | self error: 'not yet implemented'. (colors includes: Color transparent) ifTrue: [ (colors indexOf: Color transparent) = 1 ifTrue: [^ self]. "shift the entry for color transparent"] ifFalse: [ i := self unusedColormapEntry. i = 0 ifTrue: [self error: 'no color map entry is available']. colors at: i put: Color transparent. "shift the entry for color transparent"]. ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:26'! transparentAllPixelsLike: aPoint "Make all occurances of the given pixel value transparent. Very useful when two entries in the colorMap have the same value. This only changes ONE." self replaceColorAt: aPoint with: Color transparent. ! ! !ColorForm methodsFor: 'filein/out' stamp: 'bf 5/25/2000 16:31'! storeOn: aStream aStream nextPut: $(. super storeOn: aStream. aStream cr; tab; nextPutAll: 'colorsFromArray: #('. self colors do: [:color | color storeArrayOn: aStream]. aStream nextPutAll: ' ))'.! ! !ColorForm methodsFor: 'scaling, rotation' stamp: 'RAA 8/5/2000 18:12'! scaledToSize: newExtent "super method did not seem to work so well on ColorForms" ^(self asFormOfDepth: 16) scaledToSize: newExtent! ! !ColorForm methodsFor: 'accessing' stamp: 'jm 11/14/97 17:39'! colors "Return my color palette." self ensureColorArrayExists. ^ colors ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'ar 5/17/2001 15:44'! colormapIfNeededForDepth: destDepth "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." | newMap | colors == nil ifTrue: [ "use the standard colormap" ^ Color colorMapIfNeededFrom: self depth to: destDepth]. (destDepth = cachedDepth and:[cachedColormap isColormap not]) ifTrue: [^ cachedColormap]. newMap := Bitmap new: colors size. 1 to: colors size do: [:i | newMap at: i put: ((colors at: i) pixelValueForDepth: destDepth)]. cachedDepth := destDepth. ^ cachedColormap := newMap. ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'di 8/28/1998 15:49'! replaceColorAtIndex: index with: newColor "Replace a color map entry with newColor." self ensureColorArrayExists. colors at: index put: newColor. cachedColormap == nil ifFalse: [cachedColormap at: index put: (newColor pixelValueForDepth: cachedDepth)]! ! !ColorForm methodsFor: 'private' stamp: 'jm 4/5/1999 10:11'! setColors: colorArray cachedColormap: aBitmap depth: anInteger "Semi-private. Set the color array, cached colormap, and cached colormap depth to avoid having to recompute the colormap when switching color palettes in animations." colors := colorArray. cachedDepth := anInteger. cachedColormap := aBitmap. ! ! !ColorForm methodsFor: 'scaling, rotation' stamp: 'ar 3/15/1999 14:28'! flipBy: direction centerAt: aPoint | oldColors newForm | oldColors := colors. self colors: nil. newForm := super flipBy: direction centerAt: aPoint. self colors: oldColors. newForm colors: oldColors. ^newForm ! ! !ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 15:42'! replaceColorAt: aPoint with: newColor "Replace a color map entry with newColor. The entry replaced is the one used by aPoint. If there are are two entries in the colorMap for the oldColor, just replace ONE!!!! There are often two whites or two blacks, and this is what you want, when replacing one." | oldIndex | self ensureColorArrayExists. oldIndex := self pixelValueAt: aPoint. colors at: oldIndex+1 put: newColor. self clearColormapCache. ! ! !ColorForm methodsFor: 'displaying' stamp: 'di 7/17/97 10:04'! displayOnPort: port at: location port copyForm: self to: location rule: Form paint! ! !ColorForm methodsFor: 'copying' stamp: 'MarcusDenker 4/10/2011 09:45'! asCursorForm ^ (self asFormOfDepth: 32) offset: offset! ! !ColorForm methodsFor: 'filein/out' stamp: 'ar 3/3/2001 20:07'! unhibernate colors ifNotNil:[colors := colors asArray]. ^super unhibernate. ! ! !ColorForm methodsFor: 'displaying' stamp: 'ar 12/14/2001 18:14'! maskingMap "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." | maskingMap | maskingMap := Bitmap new: (1 bitShift: depth) withAll: 16rFFFFFFFF. 1 to: colors size do:[:i| (colors at: i) isTransparent ifTrue:[maskingMap at: i put: 0]. ]. colors size+1 to: maskingMap size do:[:i| maskingMap at: i put: 0]. ^maskingMap! ! !ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:07'! clearColormapCache cachedDepth := nil. cachedColormap := nil. ! ! !ColorForm methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:42'! writeAttributesOn: file | colorArray | super writeAttributesOn: file. colorArray := self colors asColorArray. 1 to: (2 raisedTo: depth) do: [:idx | file nextLittleEndianNumber: 4 put: (colorArray basicAt: idx). ] ! ! !ColorForm class methodsFor: 'instance creation' stamp: 'StephaneDucasse 8/19/2009 23:24'! extent: extentPoint depth: bitsPerPixel "Answer an instance of me with blank bitmap of the given dimensions and depth max 8." ^ bitsPerPixel > 8 ifTrue: [ self basicNew setExtent: extentPoint depth: 8] ifFalse: [ self basicNew setExtent: extentPoint depth: bitsPerPixel] ! ! !ColorForm class methodsFor: 'as yet unclassified' stamp: 'nk 4/17/2004 19:44'! mappingWhiteToTransparentFrom: aFormOrCursor "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." | f map | aFormOrCursor depth <= 8 ifFalse: [ ^ self error: 'argument depth must be 8-bits per pixel or less']. (aFormOrCursor isColorForm) ifTrue: [ f := aFormOrCursor deepCopy. map := aFormOrCursor colors. ] ifFalse: [ f := ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. f copyBits: aFormOrCursor boundingBox from: aFormOrCursor at: 0@0 clippingBox: aFormOrCursor boundingBox rule: Form over fillColor: nil. map := Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. map := map collect: [:c | c = Color white ifTrue: [Color transparent] ifFalse: [c]]. f colors: map. ^ f ! ! !ColorMap commentStamp: 'LaurentLaffont 5/4/2011 21:28'! I'm a transformation of pixel values. I apply up to four masks and shits to compute the transformed pixel value. I'm used when applying a BitBlt transfer, whenever pixels from a source to a destination have diferent depths. For further information refer to BitBlt class comments. To see me in action evaluate: BitBlt exampleColorMap! !ColorMap methodsFor: 'pixel mapping' stamp: 'lr 7/4/2009 10:42'! mappingTo: aColorMap "Compute a new color map through the receiver and aColorMap. Both maps are assumed to be mappings into canonical ARGB space" | fixedMap | self = aColorMap ifTrue: [ ^ nil ]. "No mapping needed" aColorMap isIndexed ifTrue: [ ^ nil ]. "We can't compute mappings to an indexed map yet" fixedMap := self class mappingFrom: self rgbaBitMasks to: aColorMap rgbaBitMasks. self isIndexed ifFalse: [ ^ fixedMap ]. "If the receiver is indexed then we need to map the colors as well" self flag: #untested. ^ ColorMap shifts: fixedMap shifts masks: fixedMap masks colors: (colors collect: [ :pv | aColorMap pixelMap: pv ])! ! !ColorMap methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setShifts: shiftArray masks: maskArray colors: colorArray shiftArray ifNotNil: [ shifts := shiftArray asIntegerArray ]. maskArray ifNotNil: [ masks := maskArray asWordArray ]. colorArray ifNotNil: [ colors := colorArray asWordArray ]! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:36'! greenShift: value shifts at: 2 put: value.! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:39'! at: index ^colors at: index! ! !ColorMap methodsFor: 'testing' stamp: 'ar 5/27/2000 19:06'! isFixed "Return true if the receiver does not use a lookup mechanism for pixel mapping" ^self isIndexed not! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:36'! redMask ^masks at: 1! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'! redMask: value masks at: 1 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! alphaShift ^shifts at: 4! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! greenShift ^shifts at: 2! ! !ColorMap methodsFor: 'testing' stamp: 'ar 5/25/2000 19:41'! isColormap ^true! ! !ColorMap methodsFor: 'pixel mapping' stamp: 'lr 7/4/2009 10:42'! pixelMap: pixelValue "Perform a reverse pixel mapping operation" | pv | colors == nil ifTrue: [ pv := pixelValue ] ifFalse: [ pv := colors at: pixelValue ]. (shifts == nil and: [ masks == nil ]) ifFalse: [ pv := (((pv bitAnd: self redMask) bitShift: self redShift) bitOr: ((pv bitAnd: self greenMask) bitShift: self greenShift)) bitOr: (((pv bitAnd: self blueMask) bitShift: self blueShift) bitOr: ((pv bitAnd: self alphaMask) bitShift: self alphaShift)) ]. "Need to check for translucency else Form>>paint goes gaga" pv = 0 ifTrue: [ pixelValue = 0 ifFalse: [ pv := 1 ] ]. ^ pv! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! greenMask: value masks at: 2 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:55'! alphaMask: value masks at: 4 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! alphaShift: value shifts at: 4 put: value! ! !ColorMap methodsFor: 'comparing' stamp: 'ar 5/27/2000 19:29'! hash "Hash is re-implemented because #= is re-implemented" ^colors hash bitXor: (shifts hash bitXor: masks hash)! ! !ColorMap methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 00:57'! inverseMap "Return the inverse map of the receiver" | newMasks newShifts | colors ifNotNil: [ ^ self error: 'Not yet implemented' ]. newMasks := (Array new: 4) writeStream. newShifts := (Array new: 4) writeStream. masks with: shifts do: [ :mask :shift | newMasks nextPut: (mask bitShift: shift). newShifts nextPut: shift negated ]. ^ ColorMap shifts: newShifts contents masks: newMasks contents! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! blueMask ^masks at: 3! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 2/10/2000 17:12'! colors ^colors! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'! redShift ^shifts at: 1! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:54'! alphaMask ^masks at: 4! ! !ColorMap methodsFor: 'pixel mapping' stamp: 'lr 7/4/2009 10:42'! mapPixel: pixelValue "Perform a forward pixel mapping operation" | pv | (shifts == nil and: [ masks == nil ]) ifFalse: [ pv := (((pixelValue bitAnd: self redMask) bitShift: self redShift) bitOr: ((pixelValue bitAnd: self greenMask) bitShift: self greenShift)) bitOr: (((pixelValue bitAnd: self blueMask) bitShift: self blueShift) bitOr: ((pixelValue bitAnd: self alphaMask) bitShift: self alphaShift)) ] ifTrue: [ pv := pixelValue ]. colors ifNotNil: [ pv := colors at: pv ]. "Need to check for translucency else Form>>paint goes gaga" pv = 0 ifTrue: [ pixelValue = 0 ifFalse: [ pv := 1 ] ]. ^ pv! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! blueShift ^shifts at: 3! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 19:16'! masks ^masks! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:39'! at: index put: value ^colors at: index put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'! redShift: value shifts at: 1 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 19:16'! shifts ^shifts! ! !ColorMap methodsFor: 'comparing' stamp: 'tk 7/5/2001 21:59'! = aColorMap "Return true if the receiver is equal to aColorMap" self species == aColorMap species ifFalse:[^false]. self isIndexed == aColorMap isIndexed ifFalse:[^false]. ^self colors = aColorMap colors and:[ self shifts = aColorMap shifts and:[ self masks = aColorMap masks]]! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! blueShift: value shifts at: 3 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! greenMask ^masks at: 2! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! blueMask: value masks at: 3 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 20:48'! rgbaBitMasks "Return the rgba bit masks for the receiver" ^masks asArray with: shifts collect:[:m :s| m bitShift: s]! ! !ColorMap methodsFor: 'testing' stamp: 'ar 5/27/2000 19:06'! isIndexed "Return true if the receiver uses a lookup mechanism for pixel mapping" ^colors notNil! ! !ColorMap class methodsFor: 'instance creation' stamp: 'ar 1/16/2000 16:02'! shifts: shiftArray masks: maskArray colors: colorArray ^self new setShifts: shiftArray masks: maskArray colors: colorArray! ! !ColorMap class methodsFor: 'instance creation' stamp: 'ar 1/16/2000 16:02'! shifts: shiftArray masks: maskArray ^self shifts: shiftArray masks: maskArray colors: nil.! ! !ColorMap class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! mapBitsFrom: srcBitMask to: dstBitMask "Return an array consisting of the shift and the mask for mapping component values out of srcBitMask and into dstBitMask. While this computation is somewhat complicated it eases the batch conversion of all the pixels in BitBlt." | srcBits dstBits srcLow srcHigh dstLow dstHigh bits mask shift | (srcBitMask = 0 or: [ dstBitMask = 0 ]) ifTrue: [ ^ #(0 0 ) ]. "Zero mask and shift" "Compute low and high bit position for source and dest bit mask" srcLow := srcBitMask lowBit - 1. srcHigh := srcBitMask highBit. dstLow := dstBitMask lowBit - 1. dstHigh := dstBitMask highBit. "Compute the number of bits in source and dest bit mask" srcBits := srcHigh - srcLow. dstBits := dstHigh - dstLow. "Compute the maximum number of bits we can transfer inbetween" bits := srcBits min: dstBits. "Compute the (unshifted) transfer mask" mask := (1 bitShift: bits) - 1. "Shift the transfer mask to the mask the highest n bits of srcBitMask" mask := mask bitShift: srcHigh - bits. "Compute the delta shift so that the most significant bit of the source bit mask falls on the most significant bit of the dest bit mask. Note that delta is used for #bitShift: so shift > 0 : shift right shift < 0 : shift left e.g., if dstHigh > srcHigh we need to shift left and if dstHigh < srcHigh we need to shift right. This leads to:" shift := dstHigh - srcHigh. "And that's all we need" ^ Array with: shift with: mask! ! !ColorMap class methodsFor: 'instance creation' stamp: 'ar 2/22/2000 14:08'! colors: colorArray ^self new setShifts: nil masks: nil colors: colorArray! ! !ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/4/2001 15:59'! masks: maskArray shifts: shiftArray ^self shifts: shiftArray masks: maskArray colors: nil.! ! !ColorMap class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! mappingFrom: srcBitMasks to: dstBitMasks "Return a color map mapping from the array of source bit masks to the array of dest bit masks." | shifts masks shiftAndMask | shifts := IntegerArray new: 4. masks := WordArray new: 4. 1 to: 4 do: [ :i | shiftAndMask := self mapBitsFrom: (srcBitMasks at: i) to: (dstBitMasks at: i). shifts at: i put: (shiftAndMask at: 1). masks at: i put: (shiftAndMask at: 2) ]. ^ self shifts: shifts masks: masks! ! !ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:08'! mappingFromARGB: dstBitMasks "Return a ColorMap mapping from canonical ARGB space into dstBitMasks" ^self mappingFrom: #(16rFF0000 16rFF00 16rFF 16rFF000000) to: dstBitMasks! ! !ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:08'! mappingToARGB: srcBitMasks "Return a ColorMap mapping from srcBitMasks into canonical ARGB space" ^self mappingFrom: srcBitMasks to: #(16rFF0000 16rFF00 16rFF 16rFF000000)! ! !ColorMappingCanvas commentStamp: 'LaurentLaffont 2/23/2011 20:17'! I'm an abstract class which introduce a filter between a drawing request and the final output, handled by #mapColor: For each potential pixel operation like: source -> op -> output it introducing a color mapping stage: source -> op -> mapping -> output Then #mapColor: can be redefined in subclasses to implement more specific behavior. For example: - ShadowDrawingCanvas will replace the rendered color with the color of shadow (if not transparent). - AlphaBlendingCanvas will add or intensify alpha of rendered color. For an easy to understand example see #drawPolygon:color:borderWidth:borderColor:! !ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:19'! clipBy: aRectangle during: aBlock "Set a clipping rectangle active only during the execution of aBlock. Note: In the future we may want to have more general clip shapes - not just rectangles" | oldCanvas | oldCanvas := myCanvas. myCanvas clipBy: aRectangle during:[:newCanvas| myCanvas := newCanvas. aBlock value: self]. myCanvas := oldCanvas! ! !ColorMappingCanvas methodsFor: 'drawing-text' stamp: 'tween 3/10/2009 07:45'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc "Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used." myCanvas drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: (self mapColor: c) underline: underline underlineColor: (self mapColor: uc) strikethrough: strikethrough strikethroughColor: (self mapColor: sc)! ! !ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'! origin ^myCanvas origin! ! !ColorMappingCanvas methodsFor: 'drawing-images' stamp: 'ar 6/24/1999 18:26'! stencil: aForm at: aPoint color: aColor myCanvas stencil: aForm at: aPoint color: (self mapColor: aColor)! ! !ColorMappingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 18:15'! line: pt1 to: pt2 width: w color: c "Draw a line using the given width and color" myCanvas line: pt1 to: pt2 width: w color: (self mapColor: c).! ! !ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:22'! translateTo: newOrigin clippingTo: aRectangle during: aBlock "Set a new origin and clipping rectangle only during the execution of aBlock." | oldCanvas | oldCanvas := myCanvas. myCanvas translateTo: newOrigin clippingTo: aRectangle during:[:newCanvas| myCanvas := newCanvas. aBlock value: self]. myCanvas := oldCanvas.! ! !ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:22'! translateBy: delta during: aBlock "Set a translation only during the execution of aBlock." | oldCanvas | oldCanvas := myCanvas. myCanvas translateBy: delta during:[:newCanvas| myCanvas := newCanvas. aBlock value: self]. myCanvas := oldCanvas.! ! !ColorMappingCanvas methodsFor: 'drawing-ovals' stamp: 'ar 6/22/1999 17:59'! fillOval: r color: c borderWidth: borderWidth borderColor: borderColor "Fill the given oval." myCanvas fillOval: r color: (self mapColor: c) borderWidth: borderWidth borderColor: (self mapColor: borderColor)! ! !ColorMappingCanvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:28'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c "Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used." myCanvas drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: (self mapColor: c)! ! !ColorMappingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:15'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle." ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: rule.! ! !ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 16:01'! transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize "Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')." | oldCanvas | oldCanvas := myCanvas. myCanvas transformBy: aDisplayTransform clippingTo: aClipRect during: [:newCanvas | myCanvas := newCanvas. aBlock value: self] smoothing: cellSize. myCanvas := oldCanvas.! ! !ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:40'! clipRect ^myCanvas clipRect! ! !ColorMappingCanvas methodsFor: 'drawing-support' stamp: 'nice 12/26/2009 19:22'! preserveStateDuring: aBlock "Preserve the full canvas state during the execution of aBlock" | oldCanvas result | oldCanvas := myCanvas. result := myCanvas preserveStateDuring:[:newCanvas| myCanvas := newCanvas. aBlock value: self]. myCanvas := oldCanvas. ^result! ! !ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:14'! on: aCanvas myCanvas := aCanvas.! ! !ColorMappingCanvas methodsFor: 'testing' stamp: 'ar 8/8/2001 14:16'! isShadowDrawing ^myCanvas isShadowDrawing! ! !ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/24/1999 17:54'! form ^myCanvas form! ! !ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 18:23'! reset myCanvas reset.! ! !ColorMappingCanvas methodsFor: 'drawing-polygons' stamp: 'mir 9/12/2001 14:24'! drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc "Draw the given polygon." ^myCanvas drawPolygon: vertices color: aColor borderWidth: bw borderColor: (self mapColor: bc)! ! !ColorMappingCanvas methodsFor: 'drawing-images' stamp: 'ar 6/24/1999 18:26'! stencil: aForm at: aPoint sourceRect: aRect color: aColor myCanvas stencil: aForm at: aPoint sourceRect: aRect color: (self mapColor: aColor)! ! !ColorMappingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:15'! mapColor: aColor ^aColor! ! !ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'! extent ^myCanvas extent! ! !ColorMappingCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/22/1999 18:01'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor "Draw the rectangle using the given attributes" myCanvas frameAndFillRectangle: r fillColor: (self mapColor: fillColor) borderWidth: borderWidth topLeftColor: (self mapColor: topLeftColor) bottomRightColor: (self mapColor: bottomRightColor)! ! !ColorMappingCanvas methodsFor: 'other' stamp: 'ar 6/22/1999 18:21'! translateBy: delta clippingTo: aRectangle during: aBlock "Set a translation and clipping rectangle only during the execution of aBlock." | oldCanvas | oldCanvas := myCanvas. myCanvas translateBy: delta clippingTo: aRectangle during:[:newCanvas| myCanvas := newCanvas. aBlock value: self]. myCanvas := oldCanvas.! ! !ColorMappingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 18:16'! paragraph: paragraph bounds: bounds color: c "Draw the given paragraph" myCanvas paragraph: paragraph bounds: bounds color: (self mapColor: c)! ! !ColorMappingCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/22/1999 17:59'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor "Draw the rectangle using the given attributes" myCanvas frameAndFillRectangle: r fillColor: (self mapColor: fillColor) borderWidth: borderWidth borderColor: (self mapColor: borderColor)! ! !ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 18:24'! flush myCanvas flush.! ! !ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'! depth ^myCanvas depth! ! !ColorMappingCanvas class methodsFor: 'instance creation' stamp: 'ar 6/22/1999 18:23'! on: aCanvas ^self new on: aCanvas! ! !ColorPresenterMorph commentStamp: 'gvc 5/18/2007 13:38'! Displays a colour with alpha against a white, hatched and black background.! !ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:45'! on: anObject color: getColSel "Set the receiver to the given model parameterized by the given message selectors." self model: anObject; getColorSelector: getColSel; updateColor! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:48'! labelMorph: anObject "Set the value of labelMorph" labelMorph := anObject! ! !ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:34'! update: aSymbol "Refer to the comment in View|update:." aSymbol == self getColorSelector ifTrue: [self updateColor. ^ self]! ! !ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 18:36'! updateColor "Update the color state." |col| self getColorSelector ifNotNil: [ col := (self model perform: self getColorSelector) ifNil: [Color transparent]. self setColor: col]! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/22/2006 09:25'! contentMorph: anObject "Set the value of contentMorph" contentMorph := anObject! ! !ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:23'! newContentMorph "Answer a new content morph" ^Morph new color: Color transparent; changeTableLayout; borderStyle: (BorderStyle inset width: 1); vResizing: #spaceFill; hResizing: #spaceFill; addMorph: self newHatchMorph; yourself! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/22/2006 09:25'! contentMorph "Answer the value of contentMorph" ^ contentMorph! ! !ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 16:04'! hatchForm "Answer a form showing a grid hatch pattern." ^self class hatchForm! ! !ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/19/2012 17:24'! newHatchMorph "Answer a new morph showing a grid hatch pattern." ^Morph new color: Color transparent; changeProportionalLayout; vResizing: #spaceFill; hResizing: #spaceFill; minWidth: 48; minHeight: 12; addMorph: (Morph new color: Color white) fullFrame: (0@0 corner: 0.3@1) asLayoutFrame ; addMorph: (Morph new fillStyle: (InfiniteForm with: self hatchForm)) fullFrame: (0.3@0 corner: 0.7@1) asLayoutFrame; addMorph: self solidLabelMorph fullFrame: (0.7@0 corner: 1@1) asLayoutFrame; addMorph: self labelMorph fullFrame: (0@0 corner: 1@1) asLayoutFrame ! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:48'! getColorSelector: anObject "Set the value of getColorSelector" getColorSelector := anObject! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:48'! getColorSelector "Answer the value of getColorSelector" ^ getColorSelector! ! !ColorPresenterMorph methodsFor: 'initialization' stamp: 'gvc 9/22/2006 09:34'! initialize "Initialize the receiver." super initialize. self borderWidth: 0; changeTableLayout; labelMorph: self newLabelMorph; solidLabelMorph: self newLabelMorph; contentMorph: self newContentMorph; addMorphBack: self contentMorph! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:48'! labelMorph "Answer the value of labelMorph" ^ labelMorph! ! !ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 16:20'! newLabelMorph "Answer a new label morph" ^Morph new! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 16:17'! solidLabelMorph: anObject "Set the value of solidLabelMorph" solidLabelMorph := anObject! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 16:17'! solidLabelMorph "Answer the value of solidLabelMorph" ^ solidLabelMorph! ! !ColorPresenterMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/3/2009 18:14'! setColor: aColor "Update the colour of the labels." self labelMorph color: aColor. self solidLabelMorph color: aColor asNontranslucentColor! ! !ColorPresenterMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 3/3/2010 16:12'! on: anObject color: getSel "Answer a new instance of the receiver on the given model using the given selectors as the interface." "(ColorPresenterMorph on: (BorderedMorph new) color: #color) openInWorld" ^self new on: anObject color: getSel! ! !ColorPresenterMorph class methodsFor: 'graphics constants' stamp: 'gvc 9/18/2006 16:05'! hatchForm "Answer a form showing a grid hatch pattern." ^HatchForm ifNil: [HatchForm := self newHatchForm]! ! !ColorPresenterMorph class methodsFor: 'graphics constants' stamp: 'gvc 9/18/2006 16:24'! newHatchForm "Answer a new hatch form." ^(Form extent: 8@8 depth: 1 fromArray: #( 4026531840 4026531840 4026531840 4026531840 251658240 251658240 251658240 251658240) offset: 0@0)! ! !ColorSelectorDialogWindow commentStamp: 'gvc 5/18/2007 13:35'! Standard dialog for selecting a colour by HSVA colour selector, picking from the screen or editing of values.! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/26/2006 13:11'! newHSVAColorSelectorMorph "Answer a hsva color selector." ^HSVAColorSelectorMorph new extent: (40@28) + 152; when: #selectedColor send: #colorSelected: to: self! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! pickColor "Pick a colour from the screen." |p d c h| h := self activeHand. h showTemporaryCursor: Smalltalk ui icons eyedropperIcon hotSpotOffset: 6 @ 31. h captureEventsUntil: [:evt | evt isMove ifTrue: [ p := evt position. (self hsvaMorph containsPoint: p) ifFalse: ["deal with the fact that 32 bit displays may have garbage in the alpha bits" c := Display depth = 32 ifTrue: [Color colorFromPixelValue: ((Display pixelValueAt: p) bitOr: 16rFF000000) depth: 32] ifFalse: [Display colorAt: p]]. h position: p. self selectedColor ~= c ifTrue: [ self selectedColor: c]]. " self world displayWorldSafely. " h anyButtonPressed ]. h showTemporaryCursor: nil! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'HenrikSperreJohansen 5/21/2010 14:17'! newContentMorph "Answer a new content morph." self hsvaMorph: self newHSVAColorSelectorMorph. ^self newRow: { self newGroupbox: 'Color' translated forAll: { self hsvaMorph. (self newRow: { (self newLabelGroup: { 'Selected color' translated -> self newColorPresenterMorph}) vResizing: #shrinkWrap. self newColorPickerButtonMorph}) cellPositioning: #leftCenter}. (self newGroupbox: 'Values' translated for: (self newLabelGroup: { 'Red' translated -> (self newColorComponentFieldMorph: #red). 'Green' translated -> (self newColorComponentFieldMorph: #green). 'Blue' translated -> (self newColorComponentFieldMorph: #blue). 'Hue' translated -> (self newColorComponentFieldMorph: #hue). 'Saturation' translated -> (self newColorComponentFieldMorph: #saturation). 'Brightness' translated -> (self newColorComponentFieldMorph: #brightness). 'Alpha' translated -> (self newColorComponentFieldMorph: #alpha)})) hResizing: #shrinkWrap}! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:36'! saturation: anInteger "Set the saturation value of the selected color." |c| c := self selectedColor. self selectedColor: ((Color h: c hue s: anInteger / 255 v: c brightness) alpha: c alpha)! ! !ColorSelectorDialogWindow methodsFor: 'initialization' stamp: 'gvc 9/22/2006 10:06'! initialize "Initialize the receiver." self basicSelectedColor: Color blue. super initialize. self selectedColor: self selectedColor! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:30'! alpha "Answer the alpha value of the selected color." ^(self selectedColor alpha * 255) asInteger! ! !ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/22/2006 10:04'! hsvaMorph "Answer the value of hsvaMorph" ^ hsvaMorph! ! !ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/22/2006 09:49'! selectedColor "Answer the value of selectedColor" ^ selectedColor! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:14'! green: anInteger "Set the green value of the selected color." |c| c := self selectedColor. self selectedColor: ((Color r: c red * 255 g: anInteger b: c blue * 255 range: 255) alpha: c alpha)! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:21'! alpha: anInteger "Set the alpha value of the selected color." |c| c := self selectedColor. self selectedColor: (c alpha: anInteger / 255)! ! !ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'dik 6/27/2010 16:56'! basicSelectedColor: anObject "Set the value of selectedColor" selectedColor := anObject. self changed: #selectedColor; changed: #red; changed: #green; changed: #blue; changed: #hue; changed: #saturation; changed: #brightness; changed: #alpha. self announcer announce: (ColorChanged to: selectedColor).! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:11'! newColorComponentFieldMorph: aspect "Answer a text entry for the specified aspect of the color." ^(self newTextEntryFor: self get: aspect set: (aspect, ':') asSymbol class: Integer getEnabled: nil help: nil) acceptOnFocusChange: true; minWidth: 40! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! newColorPickerButtonMorph "Answer a button to enable picking of colour." ^self newButtonFor: self getState: nil action: #pickColor arguments: nil getEnabled: nil labelForm: ((Smalltalk ui icons eyedropperIcon) scaledIntoFormOfSize: 16) help: 'Pick a color from the screen' translated! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:30'! green "Answer the green value of the selected color." ^(self selectedColor green * 255) asInteger! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:30'! blue "Answer the blue value of the selected color." ^(self selectedColor blue * 255) asInteger! ! !ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/22/2006 10:03'! selectedColor: aColor "Set the value of selectedColor. Update the color selectors." self basicSelectedColor: aColor. self hsvaMorph selectedColor: aColor! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:14'! blue: anInteger "Set the blue value of the selected color." |c| c := self selectedColor. self selectedColor: ((Color r: c red * 255 g: c green * 255 b: anInteger range: 255) alpha: c alpha)! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 11:13'! colorSelected: aColor "A color has been selected.." self basicSelectedColor: aColor! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:37'! brightness: anInteger "Set the brightness value of the selected color." |c| c := self selectedColor. self selectedColor: ((Color h: c hue s: c saturation v: anInteger / 255) alpha: c alpha)! ! !ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/22/2006 10:04'! hsvaMorph: anObject "Set the value of hsvaMorph" hsvaMorph := anObject! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:16'! hue: anInteger "Set the hue value of the selected color." |c| c := self selectedColor. self selectedColor: ((Color h: (anInteger / 255 * 359) rounded s: c saturation v: c brightness) alpha: c alpha)! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:38'! saturation "Answer the saturation value of the selected color." ^(self selectedColor saturation * 255) asInteger! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:29'! red "Answer the red value of the selected color." ^(self selectedColor red * 255) asInteger! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'HenrikSperreJohansen 5/21/2010 14:11'! defaultLabel "Answer the default label for the receiver." ^'Color Selector' translated! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:38'! hue "Answer the hue value of the selected color." ^(self selectedColor hue / 359 * 255) asInteger! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/28/2006 12:14'! red: anInteger "Set the red value of the selected color." |c| c := self selectedColor. self selectedColor: ((Color r: anInteger g: c green * 255 b: c blue * 255 range: 255) alpha: c alpha)! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'HenrikSperreJohansen 5/21/2010 14:16'! newColorPresenterMorph "Answer a color presenter." ^self newColorPresenterFor: self getColor: #selectedColor help: 'Shows the selected color' translated! ! !ColorSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 16:38'! brightness "Answer the brightness value of the selected color." ^(self selectedColor brightness * 255) asInteger! ! !ColorTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testPrintHtmlString "self debug: #testPrintHtmlString" Color white printHtmlString. self assert: Color white printHtmlString = 'FFFFFF'. self assert: Color red printHtmlString = 'FF0000'. self assert: Color black printHtmlString = '000000'! ! !ColorTest methodsFor: 'testing' stamp: 'dg 2/19/2008 13:19'! testAsHTMLColor | table aColorString | table := #('0' '1' '2' '3' '4' '5' '6' '7' '8' '9' 'A' 'B' 'C' 'D' 'E' 'F'). table do: [ :each | aColorString := '#', each, each, '0000'. self assert: ((Color fromString: aColorString) asHTMLColor sameAs: aColorString)]. table do: [ :each | aColorString := '#', '00', each, each, '00'. self assert: ((Color fromString: aColorString) asHTMLColor sameAs: aColorString)]. table do: [ :each | aColorString := '#', '0000', each, each. self assert: ((Color fromString: aColorString) asHTMLColor sameAs: aColorString)]. table do: [ :each | aColorString := '#', each, each, each, each, each, each. self assert: ((Color fromString: aColorString) asHTMLColor sameAs: aColorString)].! ! !ColorTest methodsFor: 'testing' stamp: 'fbs 2/3/2005 12:56'! testMultiplyByNumber | newColor oldColor tolerance | tolerance := 0.001. oldColor := Color r: 0.75 g: 0.5 b: 0.25. newColor := oldColor * 2. self assert: (1 - newColor red) abs < tolerance. self assert: (1 - newColor green) abs < tolerance. self assert: (0.5 - newColor blue) abs < tolerance.! ! !ColorTest methodsFor: 'testing' stamp: 'dg 2/19/2008 12:43'! testColorFrom self assert: ((Color colorFrom: #white) asHTMLColor sameAs: '#ffffff'). self assert: ((Color colorFrom: #(1.0 0.5 0.0)) asHTMLColor sameAs: '#ff8000'). self assert: ((Color colorFrom: (Color white)) asHTMLColor sameAs: '#ffffff'). self assert: ((Color colorFrom: '#FF8800') asHTMLColor sameAs: '#ff8800'). self assert: ((Color colorFrom: '#222222') asHTMLColor sameAs: '#222222').! ! !ColorTest methodsFor: 'testing' stamp: 'nice 2/20/2012 18:46'! testFromString self assert: ((Color fromString: '#FF8800') asHTMLColor sameAs: '#ff8800'); assert: ((Color fromString: 'FF8800') asHTMLColor sameAs: '#ff8800'); assert: ((Color fromString: 'white') asHTMLColor sameAs: '#ffffff'); assert: ((Color fromString: 'black') asHTMLColor sameAs: '#000000'); assert: ((Color fromString: nil) asHTMLColor sameAs: '#ffffff'); assert: ((Color fromString: 'inexistent color') asHTMLColor sameAs: '#ffffff'); "should return white" assert: ((Color fromString: 'XXXXXX') asHTMLColor sameAs: '#ffffff'); "not alphanumeric" assert: ((Color fromString: '00000000') asHTMLColor sameAs: '#ffffff'). "too many digits" self assert: (Color fromString: 'DARKGRAY') = Color darkGray description: 'Color can be specified with a case insensitive color name'; assert: (Color fromString: '#blue') = Color blue description: 'Color can be specified with a leading literal sharp'.! ! !ColorTest methodsFor: 'testing' stamp: 'fbs 2/3/2005 13:13'! testMultiplyByArray | newColor oldColor tolerance | tolerance := 0.001. oldColor := Color r: 0.75 g: 0.5 b: 0.25. newColor := oldColor * #(0.1 2 3). self assert: (0.075 - newColor red) abs < tolerance. self assert: (1 - newColor green) abs < tolerance. self assert: (0.75 - newColor blue) abs < tolerance.! ! !ColorTest methodsFor: 'testing' stamp: 'HenrikSperreJohansen 5/27/2010 23:36'! test32BitOpaqueBlackIsTotallyBlack "The pixel value of a black at depth32 should really be black..." "At the time of this test, it returned 16rFF000001 ...." self assert: 16rFF000000 equals: (Color black pixelValueForDepth: 32)! ! !ColorTest methodsFor: 'testing' stamp: 'HenrikSperreJohansen 5/27/2010 23:37'! test32BitTranslucentPixelValueKeepsRGB "The pixel value of a translucent color at depth32 should keep the RGB component irrespective of alpha. At the time of this test, setting an alpha of zero made the entire pixel 0 irrespective of depth..." self assert: 16rFFFFFF equals: ((Color white alpha: 0) pixelValueForDepth: 32)! ! !ColorTest methodsFor: 'testing' stamp: 'fbs 2/3/2005 12:57'! testMultiplyByArrayIdentityTransform | newColor oldColor tolerance | tolerance := 0.001. oldColor := Color r: 0.75 g: 0.5 b: 0.25. newColor := oldColor * 2. self assert: (1 - newColor red) abs < tolerance. self assert: (1 - newColor green) abs < tolerance. self assert: (0.5 - newColor blue) abs < tolerance.! ! !CombinedChar commentStamp: 'StephaneDucasse 3/27/2010 21:50'! Compositions classVar is a: combined instVar is a ! !CombinedChar methodsFor: 'accessing' stamp: 'StephaneDucasse 3/27/2010 21:51'! combined ^ combined ! ! !CombinedChar methodsFor: 'accessing' stamp: 'StephaneDucasse 3/27/2010 21:51'! base ^ codes first ! ! !CombinedChar methodsFor: 'composition' stamp: 'StephaneDucasse 4/4/2010 15:04'! add: char | dict elem | codes ifNil: [ codes := Array with: char. combined := char. ^ true]. dict := Compositions at: combined charCode ifAbsent: [^ false]. elem := dict at: char charCode ifAbsent: [^ false]. codes := codes copyWith: char. combined := Character leadingChar: self base leadingChar code: elem. ^ true ! ! !CombinedChar methodsFor: 'composition' stamp: 'StephaneDucasse 3/27/2010 21:57'! combinesWith: char | dict | codes ifNil: [^false]. dict := Compositions at: combined charCode ifAbsent: [^false]. dict at: char charCode ifAbsent: [^false]. ^true ! ! !CombinedChar methodsFor: 'composition' stamp: 'StephaneDucasse 3/27/2010 21:56'! simpleAdd: char | dict elem | codes ifNil: [codes := Array with: char. combined := char. ^ true]. dict := Compositions at: combined charCode ifAbsent: [^ false]. elem := dict at: char charCode ifAbsent: [^ false]. combined := Character leadingChar: self base leadingChar code: elem. codes at: 1 put: combined. ^ true ! ! !CombinedChar class methodsFor: '*Unicode-Initialization' stamp: 'PavelKrivanek 3/9/2012 09:33'! parseCompositionMappingFrom: stream " self halt. self parseCompositionMapping " | line fieldEnd point fieldStart compositions toNumber diacritical result | toNumber := [:quad | ('16r', quad) asNumber]. Compositions := IdentityDictionary new: 2048. Decompositions := IdentityDictionary new: 2048. Diacriticals := IdentitySet new: 2048. [(line := stream nextLine) notNil] whileTrue: [ fieldEnd := line indexOf: $; startingAt: 1. point := ('16r', (line copyFrom: 1 to: fieldEnd - 1)) asNumber. 2 to: 6 do: [:i | fieldStart := fieldEnd + 1. fieldEnd := line indexOf: $; startingAt: fieldStart. ]. compositions := line copyFrom: fieldStart to: fieldEnd - 1. (compositions size > 0 and: [compositions first ~= $<]) ifTrue: [ compositions := compositions substrings collect: toNumber. compositions size > 1 ifTrue: [ diacritical := compositions first. Diacriticals add: diacritical. result := compositions second. (Decompositions includesKey: point) ifTrue: [ self error: 'should not happen'. ] ifFalse: [ Decompositions at: point put: (Array with: diacritical with: result). ]. (Compositions includesKey: diacritical) ifTrue: [ (Compositions at: diacritical) at: result put: point. ] ifFalse: [ Compositions at: diacritical put: (IdentityDictionary new at: result put: point; yourself). ]. ]. ]. ]. ! ! !CombinedChar class methodsFor: '*Unicode-Initialization' stamp: 'SvenVanCaekenberghe 1/15/2013 15:02'! loadCompositionMapping | url | url := 'http://unicode.org/Public/UNIDATA/UnicodeData.txt' asZnUrl. self parseCompositionMappingFrom: url retrieveContents readStream! ! !CombinedChar class methodsFor: 'testing' stamp: 'michael.rueger 3/2/2009 10:13'! isCompositionCharacter: charCode ^Compositions includesKey: charCode! ! !CombinedChar class methodsFor: 'testing' stamp: 'yo 12/31/2002 19:21'! isDiacriticals: unicode ^ Diacriticals includes: unicode. ! ! !CommandLineArguments commentStamp: ''! The CommandLineArguments represents the arguments passed to the image. In the following case, $PHARO_VM myImage.image --foo bar `CommandLineArguments default` contains {'--foo'. 'bar'}.! !CommandLineArguments methodsFor: 'accessing' stamp: 'CamilloBruni 12/4/2012 19:48'! optionAt: aString ^ self optionAt: aString ifAbsent: [ Error signal: 'Could not find option ', aString ]! ! !CommandLineArguments methodsFor: 'accessing' stamp: 'DamienCassou 12/11/2013 15:46'! optionAt: aString ifPresent: presentBlock ifAbsent: absentBlock | option | option := self optionAt: aString ifAbsent: [ ^ absentBlock value ]. ^ presentBlock value: option! ! !CommandLineArguments methodsFor: 'copying' stamp: 'CamilloBruni 5/1/2012 20:07'! copySubcommand "return a new copy of this CommandLine without the first arguments" ^ self class withArguments: arguments allButFirst! ! !CommandLineArguments methodsFor: 'testing' stamp: 'CamilloBruni 5/2/2012 14:07'! includesSubCommand: aName self withFirstArgument: [ :arg| arg = aName ifTrue: [ ^ true ]]. ^ false! ! !CommandLineArguments methodsFor: 'accessing' stamp: 'CamilloBruni 5/1/2012 19:57'! argumentAt: index ^ arguments at: index ! ! !CommandLineArguments methodsFor: 'testing' stamp: 'CamilloBruni 12/4/2012 20:25'! shortOptionAt: aString ifAbsent: absentBlock | index | index := (arguments indexOf: '-', aString) + 1. ^ (index <= 1 or: [ index > arguments size ]) ifFalse: [ arguments at: index ] ifTrue: absentBlock! ! !CommandLineArguments methodsFor: 'testing' stamp: 'CamilloBruni 4/28/2012 19:54'! withFirstArgument: aBlock self arguments ifEmpty: [ ^ self ]. ^ aBlock value: self arguments first! ! !CommandLineArguments methodsFor: 'initialization' stamp: 'CamilloBruni 5/13/2012 19:47'! initialize | documentPath | arguments := OrderedCollection withAll: Smalltalk arguments. documentPath := Smalltalk vm documentPath. documentPath isEmptyOrNil ifFalse: [ arguments addFirst: documentPath ].! ! !CommandLineArguments methodsFor: 'testing' stamp: 'CamilloBruni 5/1/2012 20:50'! hasArguments ^ arguments size > 0! ! !CommandLineArguments methodsFor: 'testing' stamp: 'CamilloBruni 10/13/2012 15:13'! hasOption: aString | option | option := (aString size = 1 ifTrue: [ '-'] ifFalse: [ '--']), aString. (self arguments includes: option) ifTrue: [ ^ true ]. option := option,'='. ^ self arguments anySatisfy: [ :arg| arg beginsWith: option ].! ! !CommandLineArguments methodsFor: 'testing' stamp: 'CamilloBruni 5/13/2012 19:47'! commandLineArguments "self commandLineArguments" | documentPath args | args := OrderedCollection withAll: Smalltalk arguments. documentPath := Smalltalk vm documentPath. documentPath isEmptyOrNil ifFalse: [ args addFirst: documentPath ]. ^ args.! ! !CommandLineArguments methodsFor: 'testing' stamp: 'CamilloBruni 12/4/2012 19:49'! shortOptionAt: aString ^ self shortOptionAt: aString ifAbsent: [ Error signal: 'Could not find short-form option: ', aString ]! ! !CommandLineArguments methodsFor: 'testing' stamp: 'CamilloBruni 5/2/2012 12:55'! hasFileWithExtension: aFileExtension "return true if the first argument has the given file extension" ^ self arguments anySatisfy: [ :arg| arg endsWith: aFileExtension].! ! !CommandLineArguments methodsFor: 'accessing' stamp: 'CamilloBruni 12/4/2012 19:47'! optionAt: aString ifAbsent: absentBlock ^ (aString size = 1) ifTrue: [ self shortOptionAt: aString ifAbsent: absentBlock ] ifFalse: [ self longOptionAt: aString ifAbsent: absentBlock ]! ! !CommandLineArguments methodsFor: 'testing' stamp: 'CamilloBruni 12/4/2012 19:49'! longOptionAt: aString ^ self longOptionAt: aString ifAbsent: [ Error signal: 'Could not find long-form option: ', aString ]! ! !CommandLineArguments methodsFor: 'accessing' stamp: 'CamilloBruni 4/28/2012 19:42'! arguments ^ arguments! ! !CommandLineArguments methodsFor: 'accessing' stamp: 'CamilloBruni 5/2/2012 12:33'! allFilesWithExtension: anExtension ^ self arguments select: [ :arg| arg endsWith: anExtension ]! ! !CommandLineArguments methodsFor: 'testing' stamp: 'GabrielOmarCotelli 12/3/2013 17:13'! longOptionAt: aString ifAbsent: absentBlock | optionStart | optionStart := '--' , aString , '='. ^ self arguments detect: [ :arg | arg beginsWith: optionStart ] ifFound: [ :option | (option splitOn: '=') second ] ifNone: absentBlock! ! !CommandLineArguments methodsFor: 'initialize-release' stamp: 'CamilloBruni 5/1/2012 20:01'! initializeWithArguments: aCollection super initialize. arguments := aCollection.! ! !CommandLineArguments methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/22/2013 18:56'! optionAt: aString ifPresent: presentBlock | option | option := self optionAt: aString ifAbsent: [ ^ self ]. ^ presentBlock value: option! ! !CommandLineArguments class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/1/2012 20:00'! withArguments: aCollection ^ self basicNew initializeWithArguments: aCollection; yourself! ! !CommandLineArguments class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/2/2012 11:41'! default ^ singleton ifNil: [singleton := self new initialize]! ! !CommandLineArgumentsTest commentStamp: 'AdrienBarreau 2/12/2011 15:55'! That class tests the API given by AbstractUserInput. Since that class is obviously abstract, it can't be instantiated, the tests are running on CommandLine (which inherits from AbstractUserInput)! !CommandLineArgumentsTest methodsFor: 'accessing' stamp: 'CamilloBruni 5/1/2012 14:10'! commandLine ^ commandLine! ! !CommandLineArgumentsTest methodsFor: 'tests' stamp: 'CamilloBruni 5/2/2012 12:50'! testHasFilesTyped self assert: (self commandLine hasFileWithExtension: #txt). self deny: (self commandLine hasFileWithExtension: #foo).! ! !CommandLineArgumentsTest methodsFor: 'tests' stamp: 'CamilloBruni 10/13/2012 15:17'! testHasOption self assert: (self commandLine hasOption: #option1). self assert: (self commandLine hasOption: #option4). self assert: (self commandLine hasOption: #option5). self assert: (self commandLine hasOption: #o). self deny: (self commandLine hasOption: #foo). self deny: (self commandLine hasOption: #option5Value).! ! !CommandLineArgumentsTest methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 15:17'! parameters ^ #('noOpt1' 'noOpt2.txt' 'noOpt3.avi' '--option1' 'opt11' 'opt12.txt' 'opt13.avi' '--option2' '--option3' 'opt31.st' 'opt32' '--option4' '--option5=option5Value' '-o' 'oValue')! ! !CommandLineArgumentsTest methodsFor: 'tests' stamp: 'CamilloBruni 10/13/2012 15:18'! tesOptionAt self assert: (self commandLine optionAt: #option1) equals: nil. self assert: (self commandLine optionAt: #option4) equals: nil. self assert: (self commandLine optionAt: #option5) equals: 'option5Value'. self assert: (self commandLine optionAt: #foo) equals: nil. self assert: (self commandLine optionAt: #o) equals: 'oValue'.! ! !CommandLineArgumentsTest methodsFor: 'tests' stamp: 'CamilloBruni 10/15/2013 01:19'! testAllParameters self assertCollection: self commandLine arguments equals: self parameters! ! !CommandLineArgumentsTest methodsFor: 'tests' stamp: 'CamilloBruni 5/2/2012 12:50'! testParameterAt self assert: (self commandLine argumentAt: 1) = 'noOpt1'. self assert: (self commandLine argumentAt: 4) = '--option1'. self deny: (self commandLine argumentAt: 5) = 'foo'. self deny: (self commandLine argumentAt: 1) isNil.! ! !CommandLineArgumentsTest methodsFor: 'tests' stamp: 'CamilloBruni 12/4/2012 20:24'! testOptionAt self should: [ self commandLine optionAt: #option1 ] raise: Error. self should: [ self commandLine optionAt: #option4 ] raise: Error. self assert: (self commandLine optionAt: #option5) equals: 'option5Value'. self should: [ self commandLine optionAt: #foo ] raise: Error. self assert: (self commandLine optionAt: #o) equals: 'oValue'. self should: [ self commandLine optionAt: #x ] raise: Error.! ! !CommandLineArgumentsTest methodsFor: 'tests' stamp: 'CamilloBruni 12/4/2012 20:24'! testOptionAtifAbsent self assert: (self commandLine optionAt: #option1 ifAbsent: [ nil ]) equals: nil. self assert: (self commandLine optionAt: #option4 ifAbsent: [ nil ]) equals: nil. self assert: (self commandLine optionAt: #option5) equals: 'option5Value'. self assert: (self commandLine optionAt: #foo ifAbsent: [ nil ]) equals: nil. self assert: (self commandLine optionAt: #o) equals: 'oValue'. self assert: (self commandLine optionAt: #x ifAbsent: [ nil ]) equals: nil.! ! !CommandLineArgumentsTest methodsFor: 'tests' stamp: 'CamilloBruni 5/2/2012 12:34'! testAllFileTyped self assert: (self commandLine allFilesWithExtension: #txt) = #('noOpt2.txt' 'opt12.txt'). self assert: (self commandLine allFilesWithExtension: #foo) isEmpty.! ! !CommandLineArgumentsTest methodsFor: 'tests' stamp: 'CamilloBruni 5/1/2012 20:50'! testHasParameters self assert: (self commandLine hasArguments)! ! !CommandLineArgumentsTest methodsFor: 'running' stamp: 'CamilloBruni 5/2/2012 12:31'! setUp commandLine := CommandLineArguments withArguments: self parameters.! ! !CommandLineHandler commentStamp: ''! A CommandLineHandler is activated by the CommandLine. The responsible handler with the highest priority is selected and its instance-side method #activate is invoked. By default the handlers are selected by their class name. In the following shell invocation the FooHandler is chosen: pharo Pharo.image FooHandler A handler may provide a short name with the class-side #commandName method. If the FooHandler defined #commandName returning 'foo' it would be activated with the following shell invocation: pharo Pharo.image foo For more sophisticated handler selection the CommandLineHandler should implement the #isResponsibleFor: class-side method. An instance of the current command line options is passed to this method which should then return a boolean. Between all the responsible handlers the one with the highes #priority is chosen. To change the priority overwrite the class-side accessor. ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 5/1/2012 13:52'! description ^ self class description! ! !CommandLineHandler methodsFor: 'utility' stamp: 'CamilloBruni 5/9/2013 19:58'! exitFailure ^ self exitFailure: 'Command line handler failed'! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'CamilloBruni 10/13/2012 13:13'! argumentAt: anInteger ^ self commandLine argumentAt: anInteger! ! !CommandLineHandler methodsFor: 'utility' stamp: 'CamilloBruni 4/29/2012 16:33'! << aString ^ self stdout nextPutAll: aString; yourself! ! !CommandLineHandler methodsFor: 'initialization' stamp: 'CamilloBruni 5/9/2013 19:44'! initialize super initialize. session := Smalltalk session. self initializeStdout; initializeStderr. ! ! !CommandLineHandler methodsFor: 'utility' stamp: 'CamilloBruni 5/9/2013 20:18'! quit self exitSuccess! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 4/28/2012 19:28'! commandLine: aCommandLine commandLine := aCommandLine! ! !CommandLineHandler methodsFor: 'testing' stamp: 'CamilloBruni 10/13/2012 15:39'! hasArguments ^ self commandLine hasArguments! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'CamilloBruni 10/13/2012 13:13'! hasOption: aString ^ self commandLine hasOption: aString! ! !CommandLineHandler methodsFor: 'printing' stamp: 'CamilloBruni 12/5/2012 21:24'! printHelp self stderr nextPutAll: self class comment; lf! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 5/1/2012 13:42'! commandName ^ self class commandName! ! !CommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 4/28/2012 19:46'! activate self subclassResponsibility! ! !CommandLineHandler methodsFor: 'utility' stamp: 'CamilloBruni 5/9/2013 19:53'! exitSuccess self hasSessionChanged ifTrue: [ ^ self ]. Exit signalSuccess ! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 5/1/2012 13:43'! allHandlers ^ CommandLineHandler allHandlers ! ! !CommandLineHandler methodsFor: 'testing' stamp: 'MarcusDenker 9/30/2013 22:47'! hasSessionChanged "check whether the session has changed since the commandline handler as been created" ^ session ~~ Smalltalk session! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'CamilloBruni 10/13/2012 14:07'! optionAt: aString ^ self commandLine optionAt: aString! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'DamienCassou 12/11/2013 15:46'! optionAt: aString ifPresent: presentBlock ifAbsent: absentBlock ^ self commandLine optionAt: aString ifPresent: presentBlock ifAbsent: absentBlock! ! !CommandLineHandler methodsFor: 'initialize-release' stamp: 'CamilloBruni 2/6/2013 18:08'! initializeStderr "install the line end conversion and initialize the converter" FileStream stderr wantsLineEndConversion: true; converter. stderr := VTermOutputDriver stderr.! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 4/28/2012 19:28'! commandLine ^ commandLine! ! !CommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 3/22/2013 21:42'! activateHelpWithoutArguments "Default help implementation, running #help if the there is no argument or a single one which is --help " ((self hasOption: 'help') or: [ self arguments isEmpty ]) ifTrue: [ self help. ^ true ]. ^ false! ! !CommandLineHandler methodsFor: 'utility' stamp: 'CamilloBruni 5/9/2013 19:52'! exitFailure: aMessage self hasSessionChanged ifTrue: [ ^ self ]. Exit signalFailure: aMessage ! ! !CommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 3/22/2013 21:46'! help "This is a crude default help implementation." self printHelp. Smalltalk isInteractive ifFalse: [ self exitSuccess ]! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'CamilloBruni 12/4/2012 19:52'! optionAt: aString ifAbsent: absentBlock ^ self commandLine optionAt: aString ifAbsent: absentBlock! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'CamilloBruni 10/13/2012 13:13'! arguments ^ self commandLine arguments! ! !CommandLineHandler methodsFor: 'initialize-release' stamp: 'CamilloBruni 2/3/2013 16:35'! initializeStdout "install the line end conversion and initialize the converter" FileStream stdout wantsLineEndConversion: true; converter. stdout := VTermOutputDriver stdout.! ! !CommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 1/12/2013 20:08'! activateHelp "Default help implementation, running #help if the only argument is --help " ((self hasOption: 'help') and: [ self arguments size = 1 ]) ifTrue: [ self help. ^ true ]. ^ false! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 13:31'! stderr ^ stderr! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'BenjaminVanRyseghem 3/22/2013 18:55'! optionAt: aString ifPresent: absentBlock ^ self commandLine optionAt: aString ifPresent: absentBlock! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 4/28/2012 19:47'! stdout ^ stdout! ! !CommandLineHandler class methodsFor: 'private' stamp: 'CamilloBruni 5/2/2012 11:28'! prepareSubcommand: commandLineArguments "strip the subcommand name from the arguments" commandLineArguments withFirstArgument: [ :arg| arg = self commandName ifTrue: [ ^ commandLineArguments copySubcommand ]]. "not a subcommand hence we keep the same args" ^ commandLineArguments! ! !CommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 5/1/2012 13:53'! description "This method should return a short one-line description of the command" ^ nil! ! !CommandLineHandler class methodsFor: 'instance creation' stamp: 'CamilloBruni 10/13/2012 13:18'! commandLine: aCommandLine ^ self new commandLine: aCommandLine; yourself! ! !CommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 4/29/2012 17:38'! allHandlers ^ self allSubclasses reject: [ :handler| handler isAbstract ]! ! !CommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 4/29/2012 17:39'! isAbstract ^ self = CommandLineHandler! ! !CommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 5/1/2012 13:56'! commandName " Overwrite this method to provide a short name for this command handler. You may pass the commandName as first argument to the image to select this handler" ^ self name! ! !CommandLineHandler class methodsFor: 'handler selection' stamp: 'CamilloBruni 5/2/2012 14:06'! isResponsibleFor: aCommandLineArguments ^ aCommandLineArguments includesSubCommand: self commandName! ! !CommandLineHandler class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/2/2012 11:25'! activateWith: aCommandLine ^ self new commandLine: (self prepareSubcommand: aCommandLine); activate! ! !CommandLineHandler class methodsFor: 'handler selection' stamp: 'CamilloBruni 5/2/2012 11:30'! selectHandlersFor: aCommandLine ^ self allHandlers select: [ :handlerClass| handlerClass isResponsibleFor: aCommandLine ]! ! !CommandLineHandler class methodsFor: 'handler selection' stamp: 'CamilloBruni 4/28/2012 01:51'! priority ^ 0! ! !CommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 7/3/2013 15:45'! testSelectHandlersCodeLoader | args handlers | args := self argumentsWith: #('/foo/bar/myScript.st'). handlers := CommandLineHandler selectHandlersFor: args. self assert: handlers first = STCommandLineHandler. args := self argumentsWith: #('/foo/bar/myScript.st' '--verbose'). handlers := CommandLineHandler selectHandlersFor: args. self assert: handlers first = STCommandLineHandler.! ! !CommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 7/3/2013 15:45'! testResponsibilityEval | args | args := self argumentsWith: #('eval' '1+2'). self assert: (PharoCommandLineHandler isResponsibleFor: args). self deny: (STCommandLineHandler isResponsibleFor: args). self assert: (EvaluateCommandLineHandler isResponsibleFor: args). args := self argumentsWith: #('-e' '1+2'). self assert: (PharoCommandLineHandler isResponsibleFor: args). self deny: (STCommandLineHandler isResponsibleFor: args). self assert: (EvaluateCommandLineHandler isResponsibleFor: args). args := self argumentsWith: #('--evaluate' '1+2'). self assert: (PharoCommandLineHandler isResponsibleFor: args). self deny: (STCommandLineHandler isResponsibleFor: args). self assert: (EvaluateCommandLineHandler isResponsibleFor: args).! ! !CommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 7/3/2013 15:45'! testResponsibilitySt | args | args := self argumentsWith: #('/foo/bar/myScript.st'). self assert: (PharoCommandLineHandler isResponsibleFor: args). self assert: (STCommandLineHandler isResponsibleFor: args). self deny: (EvaluateCommandLineHandler isResponsibleFor: args). args := self argumentsWith: #('st' '/foo/bar/myScript.st'). self assert: (PharoCommandLineHandler isResponsibleFor: args). self assert: (STCommandLineHandler isResponsibleFor: args). self deny: (EvaluateCommandLineHandler isResponsibleFor: args).! ! !CommandLineHandlerTest methodsFor: 'utility' stamp: 'CamilloBruni 5/2/2012 14:01'! argumentsWith: aCollection ^ CommandLineArguments withArguments: aCollection! ! !CommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 7/3/2013 15:45'! testResponsibilityDefault | args | args := self argumentsWith: #('--help'). self assert: (PharoCommandLineHandler isResponsibleFor: args). self deny: (STCommandLineHandler isResponsibleFor: args). self deny: (EvaluateCommandLineHandler isResponsibleFor: args).! ! !CommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 5/26/2013 13:58'! testBasicCommandlineHandler | args | args := self argumentsWith: #(). "BasicCommandLineHandler gets activated by default on image startup, so there is no need to activate it in a nother case" self deny: (BasicCommandLineHandler isResponsibleFor: args). "The BasicCommandLineHandler should always delegate to the PharoCommandLineHandler if it is present" self assert: BasicCommandLineHandler new selectedHandler equals: PharoCommandLineHandler! ! !CommandLineTestRunner commentStamp: ''! I am command line test runner. I run a TestSuite and outpout the progress in a terminal friendly way.! !CommandLineTestRunner methodsFor: 'accessing' stamp: 'CamilloBruni 5/30/2013 22:55'! stdout (stdout isNil or: [ stdout closed ]) ifTrue: [ stdout := VTermOutputDriver stdout ]. ^ stdout! ! !CommandLineTestRunner methodsFor: 'running' stamp: 'abc 10/19/2012 15:45'! done ! ! !CommandLineTestRunner methodsFor: 'printing' stamp: 'CamilloBruni 2/10/2013 14:49'! printProgress | string | string := '[',currentTest asString, '/', maxTest asString,']'. self stderr startOfLine; right: (80 - string size); nextPutAll: string.! ! !CommandLineTestRunner methodsFor: 'running' stamp: 'abc 10/19/2012 15:36'! tearDown self printReport! ! !CommandLineTestRunner methodsFor: 'helper' stamp: 'CamilloBruni 2/10/2013 14:48'! printFailure: anError of: aTestCase self stderr red. self print: anError printString short: ' [FAIL]' of: aTestCase ! ! !CommandLineTestRunner methodsFor: 'accessing' stamp: 'abc 10/20/2012 13:03'! shouldSerializeError: aBoolean shouldSerializeError := aBoolean.! ! !CommandLineTestRunner methodsFor: 'running' stamp: 'abc 10/19/2012 15:20'! setUp currentTest := 0. maxTest := suite tests size.! ! !CommandLineTestRunner methodsFor: 'initialization' stamp: 'CamilloBruni 2/10/2013 14:48'! initialize super initialize. shouldSerializeError := false.! ! !CommandLineTestRunner methodsFor: 'helper' stamp: 'abc 10/20/2012 13:02'! handleFailure: anError of: aTestCase self printFailure: anError of: aTestCase. self shouldSerializeError ifTrue: [ self serializeError: anError of: aTestCase ]! ! !CommandLineTestRunner methodsFor: 'running' stamp: 'CamilloBruni 10/20/2012 22:31'! runCase: aTestCase self increaseTestCount. self printTestCase: aTestCase. [[ aTestCase runCase ] on: Halt , Error, TestFailure do: [ :err | self handleFailure: err of: aTestCase ]] on: TestSkip do: [ :skip| self handleSkip: skip of: aTestCase ]! ! !CommandLineTestRunner methodsFor: 'printing' stamp: 'CamilloBruni 2/10/2013 14:49'! printTestCase: aTestCase self stderr startOfLine; clearToEnd; green; print: aTestCase; clear. self printProgress.! ! !CommandLineTestRunner methodsFor: 'printing' stamp: 'CamilloBruni 2/10/2013 14:49'! printReport self stderr lf; nextPutAll: 'Finished running '; print: maxTest; nextPutAll: ' Test'; nextPutAll: (maxTest = 1 ifTrue: [''] ifFalse: ['s']); lf! ! !CommandLineTestRunner methodsFor: 'helper' stamp: 'CamilloBruni 10/20/2012 22:40'! handleSkip: aTestSkip of: aTestCase self print: aTestSkip printString short: ' [SKIPPED]' of: aTestCase! ! !CommandLineTestRunner methodsFor: 'helper' stamp: 'abc 10/19/2012 15:17'! increaseTestCount currentTest := currentTest + 1.! ! !CommandLineTestRunner methodsFor: 'helper' stamp: 'CamilloBruni 2/10/2013 14:49'! print: anLongErrorMesssage short: aShortString of: aTestCase | testCaseString offset | testCaseString := aTestCase printString. self stdout startOfLine; clearToEnd; nextPutAll: testCaseString. "Let's see if we have enough space to print the error" offset := 80 - testCaseString size - anLongErrorMesssage size. offset < 1 ifTrue: [ self stdout startOfLine; right: (80 - aShortString size); nextPutAll: aShortString ] ifFalse: [ self stdout right: offset; nextPutAll: anLongErrorMesssage ]. self stdout clear; lf.! ! !CommandLineTestRunner methodsFor: 'accessing' stamp: 'CamilloBruni 5/30/2013 22:55'! stderr (stderr isNil or: [ stderr closed ]) ifTrue: [ stderr := VTermOutputDriver stderr ]. ^ stderr ! ! !CommandLineTestRunner methodsFor: 'accessing' stamp: 'abc 10/20/2012 13:03'! shouldSerializeError ^ shouldSerializeError! ! !CommandLineUIManager commentStamp: ''! I am UI manager for a headless setup. I block all UI manager API that uses Morphs and will trow an error instead.! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 2/14/2012 09:51'! confirm: queryString trueChoice: trueLabel falseChoice: falseLabel ^self confirm: queryString trueChoice: trueLabel falseChoice: falseLabel cancelChoice: nil default: nil ! ! !CommandLineUIManager methodsFor: 'private' stamp: 'CamilloBruni 2/9/2012 12:02'! replacing: aUIManager " save the aUIManager to restore it later, when we become interactive again " uiManager := aUIManager. self beDefault.! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:43'! questionWithoutCancel: aStringOrText "Open a question dialog."! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'SeanDeNigris 1/23/2014 14:41'! merge: merger informing: aString! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'SeanDeNigris 1/29/2013 15:48'! abort: aStringOrText title: aString self logTitle: aString andDescription: aStringOrText to: self stderr.! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:42'! deny: aStringOrText "Open a denial dialog."! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/10/2013 15:41'! syntaxErrorNotificationDefaultAction: aSyntaxErrorNotification "log the syntax notificaiton and print a nicely formatted and colored syntax error on stderr" Smalltalk logDuring: [ :logger | logger print: aSyntaxErrorNotification; cr. aSyntaxErrorNotification signalerContext errorReportOn: logger ]. STCommandLineHandler printCompilerWarning: aSyntaxErrorNotification. "in noninteractive mode simply quit" ^ self exitFailure! ! !CommandLineUIManager methodsFor: 'default actions' stamp: 'CamilloBruni 2/13/2012 19:12'! unhandledErrorDefaultAction: anException self quitFrom: anException signalerContext withMessage: anException description. UIManager default == self ifFalse: [ ^ UIManager default unhandledErrorDefaultAction: anException ]! ! !CommandLineUIManager methodsFor: 'initialization' stamp: 'CamilloBruni 2/9/2012 00:22'! initialize doNotQuitOnRestart := false.! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 2/14/2012 09:59'! confirm: queryString trueChoice: trueLabel falseChoice: falseLabel cancelChoice: cancelLabel default: trueFalseNil | questions | questions := Dictionary new. trueLabel ifNotNil: [ questions at: 'y' put: trueLabel ]. falseLabel ifNotNil: [ questions at: 'n' put: falseLabel ]. cancelLabel ifNotNil: [ questions at: 'c' put: cancelLabel ]. ^ self choose: questions title: queryString ! ! !CommandLineUIManager methodsFor: 'utils' stamp: 'CamilloBruni 2/9/2012 12:55'! logGreenDuring: aBlock ^ self logColored: '32' during: aBlock! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:43'! textEntry: aStringOrText title: aString entryText: defaultEntryText "Open a text entry dialog." ! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 8/30/2012 16:19'! informUserDuring: aBlock self displayProgress: '' from: 1 to: 100 during: aBlock! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'SeanDeNigris 1/29/2013 15:40'! alert: aStringOrText self abort: aStringOrText title: 'Alert'.! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'SeanDeNigris 1/29/2013 15:48'! alert: aStringOrText title: aString self logTitle: aString andDescription: aStringOrText to: self stdout.! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:43'! proceed: aStringOrText title: aString "Open a proceed dialog and answer true if not cancelled, false otherwise."! ! !CommandLineUIManager methodsFor: 'private' stamp: 'CamilloBruni 9/14/2013 10:51'! activate NonInteractiveTranscript stderr install! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 5/26/2012 13:07'! chooseFrom: aList lines: linesArray title: aString | maxPad | maxPad := aList size asString size. self stdout nextPutAll: aString; nextPut: $:; cr. aList withIndexDo: [ :item :index | self stdout nextPutAll: ' ['; nextPutAll: (index asString padLeftTo: maxPad); nextPutAll: '] '; print: item; cr]. self stdout nextPutAll: '> '. ^ aList at: (self stdin upToAnyOf: String crlf do: [ :chr| ]) asInteger.! ! !CommandLineUIManager methodsFor: 'accessing' stamp: 'CamilloBruni 2/13/2012 18:40'! stdin ^ FileStream stdin! ! !CommandLineUIManager methodsFor: 'utils' stamp: 'IgorStasenko 3/12/2012 17:49'! logDuring: aBlock Smalltalk logStdErrorDuring: [ :stderr | aBlock value: stderr ] ! ! !CommandLineUIManager methodsFor: 'utils' stamp: 'CamilloBruni 2/21/2012 02:05'! quitFrom: aContext withMessage: aString " log error and quit " [ Smalltalk logError: aString inContext: aContext. " Print stacks of all current processes " Smalltalk logDuring: [:logger | logger nextPutAll: 'Processes and their stacks: ';cr. Process allInstances do: [:each | | ctx | logger nextPutAll: 'Process: '; print: each; cr; nextPutAll: ' stack:'; cr; cr. ctx := each isActiveProcess ifTrue: [ thisContext sender ] ifFalse: [ each suspendedContext ]. ctx ifNotNil: [ (ctx stackOfSize: 20) do: [:s | logger print: s; cr ]]. logger nextPutAll: '------------------------------'; cr; cr. ]]. ] ensure: [ self exitFailure ]! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'SeanDeNigris 1/29/2013 15:40'! abort: aStringOrText self abort: aStringOrText title: 'Error'.! ! !CommandLineUIManager methodsFor: 'accessing' stamp: 'CamilloBruni 2/13/2012 21:23'! headlessManager self class == CommandLineUIManager ifFalse: [ ^ self ]. ^ CommandLineUIManager replacing: uiManager! ! !CommandLineUIManager methodsFor: 'private' stamp: 'SeanDeNigris 1/29/2013 15:51'! logTitle: aString andDescription: aStringOrText to: aStream aStream nextPutAll: aString; nextPutAll: ': '; nextPutAll: aStringOrText asString; cr.! ! !CommandLineUIManager methodsFor: 'accessing' stamp: 'CamilloBruni 2/13/2012 17:06'! stderr "install the line end conversion and initialize the converter" FileStream stderr wantsLineEndConversion: true; converter. ^ FileStream stderr! ! !CommandLineUIManager methodsFor: 'non-interactive' stamp: 'CamilloBruni 2/13/2012 19:14'! nonInteractiveManager " Answer an instance of non-interactive manager, which will be used when image runs headless. We put it here, so subclasses can override it. " ^ NonInteractiveUIManager replacing: uiManager! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 2/13/2012 19:12'! uiProcess " receiver don't have a ui process, associated with it, client should check explicitly if #uiProcess answers nil or not" ^ nil! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 2/14/2012 09:59'! choose: questionsAnswerDict title: queryString ! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:43'! question: aStringOrText title: aString "Open a question dialog and answer true if yes, false if no and nil if cancelled."! ! !CommandLineUIManager methodsFor: 'events' stamp: 'FernandoOlivero 3/16/2012 16:24'! onSnapshot: resuming "The resuming argument is true when image boots from disk, and false, if user just did an image snapshot." resuming ifTrue: [ Smalltalk isInteractive ifFalse: [ ^ self nonInteractiveManager onSnapshot: resuming ]. Smalltalk isHeadless ifFalse: [ uiManager beDefault. "restore old, or nil, so it will be set in #default " UIManager default onSnapshot: resuming]. ^ self]. " this flag set to true only if we are saving a snapshot before quitting " doNotQuitOnRestart ifTrue: [ Smalltalk snapshot: false andQuit: true].! ! !CommandLineUIManager methodsFor: 'utils' stamp: 'CamilloBruni 2/21/2012 02:05'! exitFailure [ self class snapshotErrorImage ifTrue: [ doNotQuitOnRestart := true. "make a new image version snapshot before leaving" Smalltalk saveAsNewVersion ]. ] ensure: [ doNotQuitOnRestart ifFalse: [ Smalltalk exitFailure ]. doNotQuitOnRestart := false. ]. ! ! !CommandLineUIManager methodsFor: 'utils' stamp: 'IgorStasenko 3/12/2012 17:49'! logColored: anAnsiiColorCode during: aBlock Smalltalk logStdErrorDuring: [:stderr | stderr nextPut: Character escape; nextPut: $[; nextPutAll: anAnsiiColorCode; nextPut: $m. aBlock value: stderr. stderr nextPut: Character escape; nextPutAll: '[0m' ]! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:43'! textEntry: aStringOrText title: aString "Open a text entry dialog."! ! !CommandLineUIManager methodsFor: 'display' stamp: 'CamilloBruni 2/9/2012 00:21'! checkForNewDisplaySize "do nothing"! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:43'! question: aStringOrText "Open a question dialog."! ! !CommandLineUIManager methodsFor: 'display' stamp: 'CamilloBruni 2/9/2012 00:21'! newDisplayDepthNoRestore: pixelSize "do nothing" ! ! !CommandLineUIManager methodsFor: 'utils' stamp: 'CamilloBruni 2/9/2012 12:53'! logRedDuring: aBlock ^ self logColored: '31' during: aBlock! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:43'! textEntry: aStringOrText "Open a text entry dialog."! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:43'! questionWithoutCancel: aStringOrText title: aString "Open a question dialog and answer true if yes, false if no and nil if cancelled."! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 2/13/2012 19:09'! warningDefaultAction: aWarning | logBlock | "Pass all warnings, but log them" logBlock := [:logger | logger cr; nextPutAll: '*** Warning: '; nextPutAll: aWarning description; cr ]. Smalltalk logDuring: logBlock. self logYellowDuring: logBlock. aWarning resume. ! ! !CommandLineUIManager methodsFor: 'utils' stamp: 'CamilloBruni 2/9/2012 12:55'! logYellowDuring: aBlock ^ self logColored: '33' during: aBlock! ! !CommandLineUIManager methodsFor: 'events' stamp: 'CamilloBruni 2/13/2012 19:11'! onPrimitiveError: aString " log error and quit " ^ self quitFrom: thisContext sender withMessage: aString! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 2/22/2014 20:50'! inform: aString | logBlock | "Just log notifications" (ProvideAnswerNotification signal: aString) ifNotNil: [:answer | ^true]. logBlock := [:logger | logger cr; nextPutAll: (String new: 79 withAll: $= ); cr; nextPutAll: 'Notice: '; nextPutAll: aString; cr; nextPutAll: (String new: 79 withAll: $= ); cr]. Smalltalk logDuring: logBlock. aString logCr.! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:43'! proceed: aStringOrText "Open a proceed dialog."! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:42'! deny: aStringOrText title: aString "Open a denial dialog."! ! !CommandLineUIManager methodsFor: 'ui TEasilyThemed' stamp: 'SeanDeNigris 1/29/2013 15:44'! alert: aStringOrText title: aString configure: aBlock "Ignore the block, because we don't create a dialog, so there is nothing to configure." self alert: aStringOrText title: aString.! ! !CommandLineUIManager methodsFor: 'display' stamp: 'CamilloBruni 2/9/2012 00:21'! restoreDisplay "do nothing"! ! !CommandLineUIManager methodsFor: 'display' stamp: 'CamilloBruni 2/9/2012 00:21'! restoreDisplayAfter: aBlock "do nothing"! ! !CommandLineUIManager methodsFor: 'accessing' stamp: 'CamilloBruni 2/13/2012 18:37'! stdout "install the line end conversion and initialize the converter" FileStream stdout wantsLineEndConversion: true; converter. ^ FileStream stdout! ! !CommandLineUIManager class methodsFor: 'settings' stamp: 'CamilloBruni 2/13/2012 21:27'! uiSettingsOn: aBuilder (aBuilder group: #nonInteractive) label: 'Headless mode'; with: [ (aBuilder setting: #snapshotErrorImage) label: 'Make a snapshot of new version before quit' translated; target: CommandLineUIManager; description: 'On unhandled exception, save a new version of image before quit' translated]! ! !CommandLineUIManager class methodsFor: 'instance creation' stamp: 'CamilloBruni 2/9/2012 12:02'! replacing: aUIManager "Replace the current UI manager with instance of myself. Keep a backup reference to old manager, and then restore it, when image will be interactive again. " ^ self new replacing: aUIManager! ! !CommandLineUIManager class methodsFor: 'accessing' stamp: 'CamilloBruni 2/13/2012 21:25'! snapshotErrorImage: aBoolean SnapshotErrorImage := aBoolean! ! !CommandLineUIManager class methodsFor: 'accessing' stamp: 'CamilloBruni 2/13/2012 21:25'! snapshotErrorImage ^ SnapshotErrorImage == true! ! !CompilationContext commentStamp: ''! The compilationContext holds all information that is needed in the whole compiler chain. ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:13'! optionInlineCase ^ options includes: #optionInlineCase ! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 9/30/2013 14:43'! optionInlineTimesRepeat ^ options includes: #optionInlineTimesRepeat ! ! !CompilationContext methodsFor: 'accessing' stamp: 'ClementBera 6/7/2013 09:57'! compiledMethodTrailer: anObject compiledMethodTrailer := anObject! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/12/2013 11:04'! logged ^logged ifNil: [ false ].! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 08:50'! logged: anObject logged := anObject! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 11:28'! astTranslatorClass ^ astTranslatorClass ifNil: [ astTranslatorClass := OCASTTranslator ]! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:13'! optionInlineWhile ^ options includes: #optionInlineWhile ! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:13'! optionLongIvarAccessBytecodes ^ options includes: #optionLongIvarAccessBytecodes ! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/13/2013 14:12'! environment ^ environment! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 5/10/2013 10:54'! doesNotUnderstand: message (message selector isUnary and: [ message selector beginsWith: 'opt'] ) ifTrue: [ ^ options includes: message selector ]. ^ super doesNotUnderstand: message! ! !CompilationContext methodsFor: 'initialization' stamp: 'MarcusDenker 5/10/2013 10:59'! initialize options := Set new! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 08:50'! requestor ^ requestor! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/13/2013 14:12'! environment: anObject environment := anObject! ! !CompilationContext methodsFor: 'accessing' stamp: 'ClementBera 6/7/2013 10:00'! compiledMethodTrailer ^ compiledMethodTrailer ifNil: [ compiledMethodTrailer := CompiledMethodTrailer empty ]! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 6/14/2013 15:49'! parserClass ^ parserClass ifNil: [ parserClass := RBExplicitVariableParser ]! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:12'! optionInlineAndOr ^ options includes: #optionInlineAndOr ! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:13'! optionInlineIfNil ^ options includes: #optionInlineIfNil ! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 08:50'! failBlock: anObject failBlock := anObject! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 08:50'! requestor: anObject requestor := anObject! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/23/2013 08:07'! scope | newScope | newScope := OCClassScope for: class. requestor ifNotNil: [ "the requestor is allowed to manage variables, the workspace is using it to auto-define vars" newScope := (OCRequestorScope new requestor: requestor) outerScope: newScope]. ^newScope ! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 11:27'! bytecodeGeneratorClass: anObject bytecodeGeneratorClass := anObject! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 5/14/2013 13:52'! compilerOptions: anArray self parseOptions: anArray! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 11:27'! parserClass: anObject parserClass := anObject! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:13'! optionInlineToDo ^ options includes: #optionInlineToDo ! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 08:50'! category ^ category! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 08:50'! noPattern: anObject noPattern := anObject! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 11:27'! astTranslatorClass: anObject astTranslatorClass := anObject! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 11:28'! bytecodeGeneratorClass ^ bytecodeGeneratorClass ifNil: [ bytecodeGeneratorClass := IRBytecodeGenerator ]! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 11:27'! semanticAnalyzerClass: anObject semanticAnalyzerClass := anObject! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 10:01'! interactive: anObject interactive := anObject! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:12'! optionIlineNone ^ options includes: #optionIlineNone ! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/12/2013 11:25'! getClass ^ class! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 11:30'! semanticAnalyzerClass ^ semanticAnalyzerClass ifNil: [ semanticAnalyzerClass := OCASTSemanticAnalyzer ]! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:13'! optionInlineIf ^ options includes: #optionInlineIf ! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 7/22/2013 16:13'! optionOptimizeIR ^ options includes: #optionOptimizeIR ! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 08:50'! class: anObject class := anObject! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/13/2013 14:54'! interactive ^ interactive ifNil: [ false ]! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 08:50'! failBlock ^ failBlock! ! !CompilationContext methodsFor: 'options' stamp: 'MarcusDenker 5/10/2013 10:49'! parseOptions: optionsArray "parse an array, which is a sequence of options in a form of: #( + option1 option2 - option3 ... ) each time the #+ is seen, the options which follow it will be subject for inclusion and, correspondingly, if #- seen, then they will be excluded . By default, (if none of #+ or #- specified initially), all options are subject for inclusion. " | include | include := true. optionsArray do: [:option | option == #+ ifTrue: [ include := true ] ifFalse: [ option == #- ifTrue: [ include := false ] ifFalse: [ include ifTrue: [ options add: option ] ifFalse: [ options remove: option ifAbsent:[] ]]] ].! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/12/2013 11:00'! noPattern ^noPattern ifNil: [ false ].! ! !CompilationContext methodsFor: 'accessing' stamp: 'ClementBera 11/26/2013 13:30'! warningAllowed ^ self class warningAllowed! ! !CompilationContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 08:50'! category: anObject category := anObject! ! !CompilationContext class methodsFor: 'accessing' stamp: 'ClementBera 11/26/2013 13:30'! warningAllowed: aBoolean WarningAllowed := aBoolean! ! !CompilationContext class methodsFor: 'instance creation' stamp: 'MarcusDenker 5/13/2013 14:33'! default ^ self new parseOptions: OpalCompiler defaultOptions! ! !CompilationContext class methodsFor: 'compiler' stamp: 'MarcusDenker 5/26/2013 09:52'! compiler ^self compilerClass new compilationContextClass: CCompilationContext; environment: self environment; class: self! ! !CompilationContext class methodsFor: 'accessing' stamp: 'ClementBera 11/26/2013 13:30'! warningAllowed ^ WarningAllowed ifNil: [ WarningAllowed := true ]! ! !CompiledMethod commentStamp: 'ls 7/5/2003 13:48'! My instances are methods suitable for interpretation by the virtual machine. This is the only class in the system whose instances intermix both indexable pointer fields and indexable integer fields. The current format of a CompiledMethod is as follows: header (4 bytes) literals (4 bytes each) bytecodes (variable) trailer (variable) The header is a 30-bit integer with the following format: (index 0) 9 bits: main part of primitive number (#primitive) (index 9) 8 bits: number of literals (#numLiterals) (index 17) 1 bit: whether a large frame size is needed (#frameSize) (index 18) 6 bits: number of temporary variables (#numTemps) (index 24) 4 bits: number of arguments to the method (#numArgs) (index 28) 1 bit: high-bit of primitive number (#primitive) (index 29) 1 bit: flag bit, ignored by the VM (#flag) The trailer has two variant formats. In the first variant, the last byte is at least 252 and the last four bytes represent a source pointer into one of the sources files (see #sourcePointer). In the second variant, the last byte is less than 252, and the last several bytes are a compressed version of the names of the method's temporary variables. The number of bytes used for this purpose is the value of the last byte in the method. ! !CompiledMethod methodsFor: 'comparing' stamp: 'GuillermoPolito 4/26/2012 11:18'! sameLiteralsAs: method "Compare my literals to those of method. This is needed to compare compiled methods." | numLits literal1 literal2 | (numLits := self numLiterals) ~= method numLiterals ifTrue: [ ^ false ]. "The last literal requires special checking instead of using #literalEqual:" 1 to: numLits - 1 do: [ :index | literal1 := self literalAt: index. literal2 := method literalAt: index. (literal1 == literal2 or: [ literal1 literalEqual: literal2 ]) ifFalse: [ (index = 1 and: [ self isNamedPrimitive | self isExternalCallPrimitive ]) ifTrue: [ literal1 isArray ifTrue: [ (literal2 isArray and: [ literal1 allButLast = literal2 allButLast ]) ifFalse: [ ^ false ] ] ifFalse: [ "ExternalLibraryFunction" (literal1 analogousCodeTo: literal2) ifFalse: [ ^ false ] ] ] ifFalse: [ index = (numLits - 1) ifTrue: [ "properties" (self properties analogousCodeTo: method properties) ifFalse: [ ^ false ] ] ifFalse: [ ^ false ] ] ] ]. "Class side methods have non unique (nil -> a Metaclass) as literal and cannot be compared equal" literal1 := self literalAt: numLits. literal2 := method literalAt: numLits. ^literal1 class == literal2 class and: [literal1 isVariableBinding ifTrue: [literal1 key = literal2 key and: [literal1 value = literal2 value]] ifFalse: [literal1 = literal2]]! ! !CompiledMethod methodsFor: '*Fuel' stamp: 'MarianoMartinezPeck 12/3/2011 19:39'! abstractBytecodeMessagesFrom: startpc to: endpc "Answer an OrderedCollection of the abstract bytecodes sent in the receiver." | scanner abstractBytecodes | scanner := InstructionStream new method: self pc: startpc. "now collect all the bytecode messages in the block." abstractBytecodes := OrderedCollection new. [scanner pc <= endpc] whileTrue: [[scanner interpretNextInstructionFor: nil] on: MessageNotUnderstood do: [:ex| abstractBytecodes add: ex message]]. ^abstractBytecodes "| m | (m := CompiledMethod >> #abstractBytecodeMessagesFrom:to:) abstractBytecodeMessagesFrom: m initialPC to: m endPC"! ! !CompiledMethod methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/20/2009 19:02'! trailer "Answer the receiver's trailer" ^ CompiledMethodTrailer new method: self ! ! !CompiledMethod methodsFor: 'testing' stamp: 'ar 6/2/1998 16:11'! isReturnField "Answer whether the receiver is a quick return of an instance variable." ^ self primitive between: 264 and: 519! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'CamilloBruni 9/14/2012 00:41'! isOverride | selector | selector := self selector. self methodClass allSuperclassesDo: [:each | (each includesSelector: selector) ifTrue: [ ^ true ]]. ^ false! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! isExplicitlyRequired: marker ^ marker == self class explicitRequirementMarker! ! !CompiledMethod methodsFor: 'accessing' stamp: 'eem 11/29/2008 17:23'! properties: aMethodProperties "Set the method-properties of the receiver to aMethodProperties." self literalAt: self numLiterals - 1 put: (aMethodProperties isEmpty ifTrue: [aMethodProperties selector] ifFalse: [aMethodProperties setMethod: self; yourself])! ! !CompiledMethod methodsFor: 'accessing' stamp: 'MarcusDenker 5/16/2013 13:46'! classBinding: aBinding "sets the association to the class that I am installed in" ^self literalAt: self numLiterals put: aBinding.! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 4/29/2012 13:44'! embeddSourceInTrailer "When receiver is deinstalled from its class, its not managed anymore by development tools and it's hard to predict, how long a method could stay in the image, because if it contains blocks, they could still reference it. Therefore we trying to preserve as much as we can , actually by embedding the method's source code into its trailer " self trailer hasSourcePointer ifTrue: [ ^self becomeForward: (self copyWithSource: self sourceCode)] ! ! !CompiledMethod methodsFor: 'printing' stamp: 'CamilloBruni 2/28/2012 14:06'! timeStamp "Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available." "(CompiledMethod compiledMethodAt: #timeStamp) timeStamp" | stamp file | file := self sourceFileStreamIfAbsent: [ ^ String new ]. stamp := self timeStampFromFile: file. file close. ^ stamp! ! !CompiledMethod methodsFor: 'debugger support' stamp: 'MarcusDenker 11/16/2012 13:45'! debuggerMap ^self compilerClass debuggerMethodMapForMethod: self.! ! !CompiledMethod methodsFor: 'printing' stamp: 'MarcusDenker 6/11/2013 14:38'! timeStampFromFile: file "return the timestamp of this method for a given source filestream" | preamble stamp tokens tokenCount| preamble := self getPreambleFrom: file at: (0 max: self filePosition - 3). stamp := String new. tokens := (preamble includesSubstring: 'methodsFor:') ifTrue: [preamble parseLiterals] ifFalse: [Array new "ie cant be back ref"]. (((tokenCount := tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) == #methodsFor:]) ifTrue: [(tokens at: tokenCount - 3) == #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp := tokens at: tokenCount - 2]]. ((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) == #methodsFor:]) ifTrue: [(tokens at: tokenCount - 1) == #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp := tokens at: tokenCount]]. ^ stamp ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'eem 9/15/2011 17:04'! properties "Answer the method properties of the receiver." | propertiesOrSelector | ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties ifTrue: [propertiesOrSelector] ifFalse: [self class methodPropertiesClass forMethod: self selector: propertiesOrSelector]! ! !CompiledMethod methodsFor: '*AST-Core' stamp: 'CamilloBruni 12/9/2011 13:59'! ast ^ ASTCache at: self! ! !CompiledMethod methodsFor: '*Ring-Core-Kernel' stamp: 'MarcusDenker 4/29/2012 10:33'! asPassiveRingDefinition "Retrieves a passive RGMethodDefinition object based on the data of the receiver. Source, protocol and stamp are retrieved from value assigned in creation" | ring | ring := (RGFactory current createMethodNamed: self selector) parentName: self methodClass name; isMetaSide: self methodClass isMeta; protocol: self category; sourceCode: self sourceCode; stamp: self timeStamp; asPassive. ^ ring! ! !CompiledMethod methodsFor: 'accessing' stamp: 'nice 1/5/2010 15:59'! searchForSelector "search me in all classes, if found, return my selector. Slow!!" self systemNavigation allBehaviorsDo: [:class | | selector | (selector := class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^selector]]. ^nil.! ! !CompiledMethod methodsFor: 'testing' stamp: 'di 12/26/1998 21:31'! isQuick "Answer whether the receiver is a quick return (of self or of an instance variable)." ^ self primitive between: 256 and: 519! ! !CompiledMethod methodsFor: 'accessing' stamp: 'eem 11/28/2008 12:58'! selector: aSelector "Set a method's selector. This is either the penultimate literal, or, if the method has any properties or pragmas, the selector of the MethodProperties stored in the penultimate literal." | penultimateLiteral nl | (penultimateLiteral := self penultimateLiteral) isMethodProperties ifTrue: [penultimateLiteral selector: aSelector] ifFalse: [(nl := self numLiterals) < 2 ifTrue: [self error: 'insufficient literals to hold selector']. self literalAt: nl - 1 put: aSelector]! ! !CompiledMethod methodsFor: 'testing' stamp: 'GuillermoPolito 4/26/2012 10:54'! isPrimitive ^self primitive > 0! ! !CompiledMethod methodsFor: 'literals' stamp: 'nice 7/20/2011 18:01'! refersToLiteral: aLiteral "Answer true if any literal in this method is literal, even if embedded in array structure or within its pragmas." "only iterate to numLiterals - 1, as the last has the classBinding and the last-but-one needs special treatment" 2 to: self numLiterals - 1 do: [ :index | | literal | literal := self objectAt: index. (aLiteral literalEqual: literal) ifTrue: [ ^ true ]. (literal refersToLiteral: aLiteral) ifTrue: [ ^ true ] ]. "last-but-one has the additional method state -or- the method's own selector!!" ^ (self objectAt: self numLiterals) refersToLiteral: aLiteral. ! ! !CompiledMethod methodsFor: '*RecentSubmissions' stamp: ''! stamp ^ self timeStamp! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'MarcusDenker 5/4/2013 10:15'! correspondingTestMethod self isTestMethod ifTrue: [ ^ self ] ifFalse: [| sel testClass | (self selector endsWith: ':') ifTrue: [ sel := (self selector copyReplaceAll: ':' with:'') asLowercase ] ifFalse:[ sel := self selector asLowercase ]. (sel beginsWith: 'test') ifFalse: [ sel := 'test', sel]. ^ ((testClass := self methodClass correspondingForTest) = self methodClass) ifTrue: [ nil ] ifFalse:[ testClass methods detect: [:each | each selector asLowercase = sel ] ifNone: [ nil ]]]! ! !CompiledMethod methodsFor: 'literals' stamp: 'eem 11/29/2008 11:38'! indexOfLiteral: literal "Answer the literal index of the argument, literal, or zero if none." 2 to: self numLiterals - 1 "exclude superclass + selector/properties" do: [:index | literal == (self objectAt: index) ifTrue: [^index - 1]]. ^0! ! !CompiledMethod methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 7/16/2012 16:05'! ir ^ IRBytecodeDecompiler new decompile: self! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MartinDias 11/5/2013 14:44'! putSource: sourceStr inFile: fileIndex withPreamble: preambleBlock "Store the source code for the receiver on an external file. If no sources are available, i.e., SourceFile is nil, then store temp names for decompilation at the end of the method. If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, in each case, storing a 4-byte source code pointer at the method end." | file remoteString | (file := SourceFiles at: fileIndex) ifNil: [ ^ self becomeForward: (self copyWithSource: sourceStr) ]. Smalltalk assureStartupStampLogged. file setToEnd. preambleBlock value: file. "Write the preamble" remoteString := RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. file nextChunkPut: ' '. InMidstOfFileinNotification signal ifFalse: [ file flush ]. self setSourcePosition: remoteString position inFile: fileIndex! ! !CompiledMethod methodsFor: 'literals' stamp: 'AlexandreBergel 1/4/2014 20:13'! literalStrings "Return a list of strings or symbols corresponding to the class references and message sent. The result also contains the name of the class" | litStrs | litStrs := OrderedCollection new: self numLiterals. self literalsDo: [:lit | (lit isVariableBinding) ifTrue: [litStrs addLast: lit key] ifFalse: [(lit isSymbol) ifTrue: [litStrs addAll: lit keywords] ifFalse: [litStrs addLast: lit printString]]]. ^ litStrs! ! !CompiledMethod methodsFor: 'testing' stamp: 'MarcusDenker 4/29/2011 00:40'! isDeprecated ^ (self sendsSelector: #deprecated:) or: [self sendsSelector: #deprecated:on:in:]! ! !CompiledMethod methodsFor: 'literals' stamp: 'eem 5/6/2008 11:28'! allLiterals ^self literals! ! !CompiledMethod methodsFor: 'accessing' stamp: 'eem 5/7/2012 11:26'! referredInstVars | allInstVarNames instVarNames | allInstVarNames := self methodClass allInstVarNames. self isReturnField ifTrue: [^Set with: (allInstVarNames at: self returnField + 1)]. instVarNames := Set new. self abstractBytecodeMessagesDo: [:msg| (#(#popIntoReceiverVariable: #pushReceiverVariable: #storeIntoReceiverVariable:) includes: msg selector) ifTrue: [instVarNames add: (allInstVarNames at: msg argument + 1)]]. ^instVarNames "Dictionary fromPairs: (Point selectors collect: [:s| { s. (Point >> s) referredInstVars}])".! ! !CompiledMethod methodsFor: '*Tools' stamp: 'CamilloBruni 1/30/2013 21:26'! senders ^ SystemNavigation default allSendersOf: self selector! ! !CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 9/15/2011 17:04'! propertyValueAt: propName put: propValue "Set or add the property with key propName and value propValue. If the receiver does not yet have a method properties create one and replace the selector with it. Otherwise, either relace propValue in the method properties or replace method properties with one containing the new property." | propertiesOrSelector | (propertiesOrSelector := self penultimateLiteral) isMethodProperties ifFalse: [self penultimateLiteral: ((self class methodPropertiesClass selector: propertiesOrSelector with: (Association key: propName asSymbol value: propValue)) setMethod: self; yourself). ^propValue]. (propertiesOrSelector includesProperty: propName) ifTrue: [^propertiesOrSelector at: propName put: propValue]. self penultimateLiteral: (propertiesOrSelector copyWith: (Association key: propName asSymbol value: propValue)). ^propValue! ! !CompiledMethod methodsFor: '*NativeBoost-Core' stamp: 'Igor.Stasenko 5/18/2010 08:19'! trailerKind "a shortcut accessor to check the trailer kind, without instantiating the trailer" | flagByte index | flagByte := self at: self size. index := flagByte >> 2 + 1. ^ CompiledMethodTrailer trailerKinds at: index. ! ! !CompiledMethod methodsFor: '*Deprecated30' stamp: 'MarcusDenker 10/11/2013 10:30'! decompile self deprecated: 'decompiling bc->text is not supported'. ^self class compiler decompileMethod: self.! ! !CompiledMethod methodsFor: '*Deprecated30' stamp: 'MarcusDenker 4/29/2013 17:11'! parserClass self deprecated: 'use #compilerClass' on: '29 April 2013' in: 'Pharo 3.0'. ^self compilerClass! ! !CompiledMethod methodsFor: 'accessing' stamp: 'MarcusDenker 10/11/2013 10:29'! sourceCode "Retrieve or reconstruct the source code for this method." | trailer source | trailer := self trailer. trailer sourceCode ifNotNil: [:code | ^ code ]. trailer hasSourcePointer ifFalse: [^ self codeForNoSource]. "Situation normal; read the sourceCode from the file" source := [self getSourceFromFile] on: Error do: [ :ex | ex return: nil]. source isEmptyOrNil ifTrue: [^ self codeForNoSource]. ^source! ! !CompiledMethod methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 4/19/2013 08:33'! sourceNode ^self ast! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! isImplicitlyRequired: marker ^ marker == self class implicitRequirementMarker! ! !CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 11/29/2008 11:45'! propertyValueAt: propName | propertiesOrSelector | ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties ifTrue: [propertiesOrSelector propertyValueAt: propName ifAbsent: [nil]] ifFalse: [nil]! ! !CompiledMethod methodsFor: 'testing' stamp: ''! isReturnSelf "Answer whether the receiver is a quick return of self." ^ self primitive = 256! ! !CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 11/29/2008 17:33'! propertyKeysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values." | propertiesOrSelector | (propertiesOrSelector := self penultimateLiteral) isMethodProperties ifTrue: [propertiesOrSelector propertyKeysAndValuesDo: aBlock]! ! !CompiledMethod methodsFor: 'scanning' stamp: ''! sendsToSuper "Answer whether the receiver sends any message to super." | scanner | scanner := InstructionStream on: self. ^ scanner scanFor: [:instr | instr = 16r85 or: [instr = 16r84 and: [scanner followingByte between: 16r20 and: 16r3F]]]! ! !CompiledMethod methodsFor: 'testing' stamp: 'al 1/23/2004 13:12'! isConflict ^ self markerOrNil == self class conflictMarker! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'! isRequired ^ self isRequired: self markerOrNil! ! !CompiledMethod methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 4/19/2013 08:34'! sourceNodeForPC: aPC ^self sourceNode sourceNodeForPC: aPC! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 4/29/2012 10:33'! linesOfCode "An approximate measure of lines of code. Includes comments, but excludes empty lines." | lines | lines := 0. self sourceCode lineIndicesDo: [:start :endWithoutDelimiters :end | endWithoutDelimiters > start ifTrue: [lines := lines+1]]. ^lines! ! !CompiledMethod methodsFor: 'printing' stamp: 'GuillermoPolito 4/26/2012 10:55'! longPrintRelativeOn: aStream indent: tabs "List of all the byte codes in a method with a short description of each" self isQuick ifTrue: [^self longPrintOn: aStream indent: tabs]. self isPrimitive ifTrue: [aStream tab: tabs. self printPrimitiveOn: aStream]. (RelativeInstructionPrinter on: self) indent: tabs; printCode: false; printInstructionsOn: aStream. ! ! !CompiledMethod methodsFor: 'printing' stamp: 'GuillermoPolito 4/26/2012 11:19'! symbolicLinesDo: aBlock "Evaluate aBlock with each of the lines in the symbolic output." | aStream pc | aStream := ReadWriteStream on: (String new: 64). self isQuick ifTrue: [self longPrintOn: aStream. aBlock value: 0 value: aStream contents. ^self]. self isPrimitive ifTrue: [self printPrimitiveOn: aStream. aBlock value: 1 value: aStream contents. aStream resetContents]. pc := self initialPC. (InstructionPrinter on: self) indent: 0; printPC: false; "explorer provides pc anyway" printInstructionsOn: aStream do: [:printer :scanner :stream| | line index | line := stream contents allButLast. (line includes: Character cr) ifTrue: [line := (line copyUpTo: Character cr), '...'' (continues)']. (index := line indexOf: $>) > 0 ifTrue: [[(line at: index + 1) isSeparator] whileTrue: [index := index + 1]. line := ((line copyFrom: 1 to: index) copyReplaceAll: (String with: Character tab) with: (String new: 8 withAll: Character space)), (line copyFrom: index + 1 to: line size)]. aBlock value: pc value: line. pc := scanner pc. stream resetContents]! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 4/7/2011 18:11'! hasPassedTest ^ self methodClass methodPassed: (self selector)! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 4/21/2013 18:04'! tempNames ^self methodNode tempNames.! ! !CompiledMethod methodsFor: 'literals' stamp: 'nice 7/20/2011 09:10'! hasLiteralThorough: literal "Answer true if any literal in this method is literal, even if embedded in array structure." (self penultimateLiteral isMethodProperties and: [self penultimateLiteral hasLiteralThorough: literal]) ifTrue:[^true]. 2 to: self numLiterals - 1 "exclude superclass + selector/properties" do:[:index | | lit | (((lit := self objectAt: index) literalEqual: literal) or: [(lit isVariableBinding and: [lit key == literal]) or: [lit isArray and: [lit hasLiteral: literal]]]) ifTrue: [^ true]]. ^ false ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'StephaneDucasse 3/17/2010 20:53'! initialPC "Answer the program counter for the receiver's first bytecode." ^ (self numLiterals + 1) * Smalltalk wordSize + 1! ! !CompiledMethod methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/20/2009 19:04'! endPC "Answer the index of the last bytecode." ^ self trailer endPC ! ! !CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:44'! fileIndex ^SourceFiles fileIndexFromSourcePointer: self sourcePointer! ! !CompiledMethod methodsFor: 'accessing' stamp: 'StephaneDucasse 3/6/2010 09:27'! comment "Return the first comment of the receiver" "(self>>#comment) comment" ^ self methodClass firstPrecodeCommentFor: self selector! ! !CompiledMethod methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 8/28/2013 10:45'! methodNode "Return the parse tree that represents self" | aClass source methodNode | aClass := self methodClass. source := self sourceCode. methodNode := aClass compiler parse: source. methodNode source: source. ^methodNode. ! ! !CompiledMethod methodsFor: 'printing' stamp: 'ajh 2/9/2003 14:17'! longPrintOn: aStream "List of all the byte codes in a method with a short description of each" self longPrintOn: aStream indent: 0! ! !CompiledMethod methodsFor: '*Fuel' stamp: 'MartinDias 2/18/2013 19:54'! fuelPrepare "Prepare for Fuel serialization." self isNamedPrimitive ifTrue: [self literals first at: 4 put: 0]. "When the method is a named primitive, the first literal is an array that works as an argument for the VM. The first and second elements represent the module and the name of the primivite. The third element of the array is ignored, it used to be a session ID. The forth element is the primitive index in a externalPrimitiveTable and it is IMPORTANT to put it in zero, otherwise there can be errors. Putting a zero means that the VM will not try to directly execute the primitive from the table and it will always try to load the module. It is the safer thing to do. For more details, read the method #primitiveExternalCall in VMMaker."! ! !CompiledMethod methodsFor: 'testing' stamp: 'GuillermoPolito 4/26/2012 10:54'! isNamedPrimitive ^self primitive = 117! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! isDisabled: marker ^ marker == self class disabledMarker! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:40'! isProvided ^ self isProvided: self markerOrNil! ! !CompiledMethod methodsFor: '*opalcompiler-core' stamp: 'CamilloBruni 2/17/2012 14:33'! recompile ^ self methodClass recompile: self selector! ! !CompiledMethod methodsFor: 'accessing' stamp: 'MarcusDenker 7/18/2013 17:10'! bytecode "Answer an ByteArray of the btyecode of the method." | start stop bytecode | start := self initialPC. stop := self endPC. bytecode := ByteArray new: (stop - start + 1). start to: stop do: [:index | bytecode byteAt: index - start + 1 put: (self byteAt: index)]. ^bytecode! ! !CompiledMethod methodsFor: 'literals' stamp: ''! literalAt: index put: value "Replace the literal indexed by the first argument with the second argument. Answer the second argument." ^self objectAt: index + 1 put: value! ! !CompiledMethod methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 3/21/2013 12:38'! criticClass "Return the class of the receiver for the critic browser. This behavior may be folded later by changing the name of this method or using another one." ^ self methodClass! ! !CompiledMethod methodsFor: 'scanning' stamp: 'CamilloBruni 8/1/2012 16:19'! writesRef: literalAssociation "Answer whether the receiver stores into the argument." | litIndex scanner | (litIndex := self indexOfLiteral: literalAssociation) = 0 ifTrue: [^false]. litIndex := litIndex - 1. ^(scanner := InstructionStream on: self) scanFor: [:b| (b = 129 or: [b = 130]) ifTrue: [scanner followingByte - 192 = litIndex] ifFalse: [b = 132 and: [scanner followingByte >= 224 and: [scanner thirdByte = litIndex]]]]! ! !CompiledMethod methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 00:59'! abstractSymbolic "Answer a String that contains a list of all the byte codes in a method with a short description of each, using relative addresses and not including code bytes." | aStream | aStream := (String new: 1000) writeStream. self longPrintRelativeOn: aStream indent: 0. ^aStream contents! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'MarcusDenker 10/19/2012 09:50'! correspondingMethods " retrieve methods that could be the corresponding method " self isTestMethod ifTrue: [| className selector selectors | selector := self selector. className := self methodClass name. (self methodClass inheritsFrom: TestCase) ifTrue: [| classSymbol correspondingClass tempSel correspondingSel result | (selector beginsWith: 'test') ifFalse: [ ^ {}]. (className endsWith: 'Test') ifTrue: [ classSymbol := className copyFrom: 1 to: (className size - 4) ] ifFalse: [ classSymbol := className ]. correspondingClass := self class environment at: classSymbol asSymbol ifAbsent: [ ^ {} ]. tempSel := selector copyFrom: 5 to: selector size. correspondingSel := String streamContents: [:stream | tempSel doWithIndex: [:c :i| (c isUppercase and: [ i > 1 ]) ifTrue: [ stream << $: ]. stream << c ]]. correspondingSel := correspondingSel contents. selectors := correspondingClass selectors. result := selectors select: [:each | (each asLowercase = correspondingSel asLowercase) or: [ each asLowercase = (correspondingSel,':') asLowercase]]. ^ result collect: [:each| correspondingClass >> each ]] ifFalse: [^ {}]] ifFalse: [ ^ { self } ]! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'NicolaiHess 12/29/2013 23:00'! isTestMethod ^ (self methodClass inheritsFrom: TestCase) and: [ ((self selector beginsWith: 'test') or: [ (self selector beginsWith: 'should')]) and: [ self numArgs isZero ] ]! ! !CompiledMethod methodsFor: '*Manifest-Core' stamp: 'SimonAllier 3/21/2013 15:18'! mcWorkingCopy MCWorkingCopy managersForClass: self methodClass selector: self selector do: [ :package | ^ package ]! ! !CompiledMethod methodsFor: 'copying' stamp: 'MarianoMartinezPeck 7/24/2012 09:39'! postCopy | penultimateLiteral | (penultimateLiteral := self penultimateLiteral) isMethodProperties ifTrue: [self penultimateLiteral: (penultimateLiteral copy setMethod: self; yourself). self penultimateLiteral pragmas do: [:p| p setMethod: self]] ! ! !CompiledMethod methodsFor: '*Keymapping-Core' stamp: 'MarcusDenker 9/11/2013 13:20'! isShortcutDeclaration ^self pragmas anySatisfy: [ :p | p keyword = #shortcut ]! ! !CompiledMethod methodsFor: '*rpackage-core' stamp: 'tg 3/13/2010 15:13'! isDefinedInPackage: anRPackage ^ anRPackage includesDefinedSelector: self selector ofClass: self methodClass! ! !CompiledMethod methodsFor: 'accessing' stamp: 'md 1/20/2006 16:09'! scanner ^ InstructionStream on: self! ! !CompiledMethod methodsFor: 'cleaning' stamp: 'MarianoMartinezPeck 4/27/2012 19:59'! voidCogVMState "Tell the VM to remove all references to any machine code form of the method. This primitive must be called whenever a method is in use and modified. This is more aggressive (and *much* more costly) than flushCache since it must search through all context objects, making sure that none have a (hidden) machine code pc in the receiver. Since modifying a method will likely change the generated machine code, modifying a method (rather than redefining it) requires this more aggressive flush." ^self flushCache! ! !CompiledMethod methodsFor: 'accessing' stamp: 'CamilloBruni 4/27/2012 17:44'! origin self properties at: #traitSource ifPresent: [ :traitMethod| ^ traitMethod methodClass ]. ^ self methodClass traitOrClassOfSelector: self selector! ! !CompiledMethod methodsFor: 'testing' stamp: 'md 11/21/2003 12:15'! isCompiledMethod ^ true! ! !CompiledMethod methodsFor: 'literals' stamp: 'AlexandreBergel 1/4/2014 20:16'! sendsSelector: aSymbol " Answer whether the method sends a particular selector (CompiledMethod >> #sendsSelector:) sendsSelector: #includes: => true (CompiledMethod >> #sendsSelector:) sendsSelector: #doBreakfastForMe => false " ^ self messages includes: aSymbol! ! !CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 11/29/2008 16:36'! pragmas | selectorOrProperties | ^(selectorOrProperties := self penultimateLiteral) isMethodProperties ifTrue: [selectorOrProperties pragmas] ifFalse: [#()]! ! !CompiledMethod methodsFor: 'accessing' stamp: 'md 2/15/2006 20:51'! searchForClass "search me in all classes, if found, return my class. Slow!!" self systemNavigation allBehaviorsDo: [:class | (class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^class]]. ^nil.! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'CamilloBruni 10/21/2012 23:56'! dragAndDropPrint ^ self printString! ! !CompiledMethod methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitCompiledMethod: self! ! !CompiledMethod methodsFor: '*Ring-Core-Kernel' stamp: 'MarcusDenker 4/29/2012 10:33'! asHistoricalRingDefinition "Retrieves a historical RGMethodDefinition object based on the data of the receiver. Source, protocol and stamp are retrieved from the source file method" | ring | ring := (RGFactory current createMethodNamed: self selector) parentName: self methodClass name; isMetaSide: self methodClass isMeta. self sourcePointer isZero ifTrue: [ "this should not happen but sometimes the system looks corrupted" ring protocol: self category; sourceCode: self sourceCode; stamp: self timeStamp ] ifFalse: [ ring sourcePointer: self sourcePointer ]. ring asHistorical. ^ ring! ! !CompiledMethod methodsFor: 'source code management' stamp: 'EstebanLorenzano 3/8/2013 15:04'! setSourcePointer: srcPointer "We can't change the trailer of existing method, since it could have completely different format. Therefore we need to generate a copy with new trailer, containing scrPointer, and then become it." | trailer copy | trailer := CompiledMethodTrailer new sourcePointer: srcPointer. copy := self copyWithTrailerBytes: trailer. "If possible do a replace in place as an optimization" (self trailer class == trailer class and: [ self size = copy size ]) ifTrue: [ | start | start := self endPC + 1. self replaceFrom: start to: self size with: copy startingAt: start ] ifFalse: [ self becomeForward: copy ]. ^ self ! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MartinDias 10/28/2013 15:11'! getPreambleFrom: aFileStream at: position ^ SourceFiles getPreambleFrom: aFileStream at: position! ! !CompiledMethod methodsFor: 'copying' stamp: 'tk 8/19/1998 16:20'! veryDeepCopyWith: deepCopier "Return self. I am always shared. Do not record me. Only use this for blocks. Normally methodDictionaries should not be copied this way."! ! !CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'CamilloBruni 2/20/2012 15:34'! hasPragmaNamed: aSymbol ^ self pragmas anySatisfy: [ :pragma | pragma keyword = aSymbol ]! ! !CompiledMethod methodsFor: 'accessing' stamp: 'AdrianKuhn 12/22/2009 07:26'! methodClass: aClass "set the class binding in the last literal to aClass" ^self numLiterals > 0 ifTrue: [ self literalAt: self numLiterals put: aClass binding ] ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'CamilloBruni 1/30/2013 21:09'! protocol: aString ^ self methodClass organization classify: self selector under: aString! ! !CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 12/1/2008 11:02'! removeProperty: propName ifAbsent: aBlock "Remove the property propName if it exists. Answer the evaluation of aBlock if the property is missing." | value | value := self propertyValueAt: propName ifAbsent: [^aBlock value]. self penultimateLiteral: (self penultimateLiteral copyWithout: (Association key: propName value: value)). ^value! ! !CompiledMethod methodsFor: 'printing' stamp: 'GuillermoPolito 4/26/2012 11:07'! primitiveErrorVariableName "Answer the primitive error code temp name, or nil if none." self isPrimitive ifTrue: [self pragmas do: [:pragma| | kwds ecIndex | ((kwds := pragma keyword keywords) first = 'primitive:' and: [(ecIndex := kwds indexOf: 'error:') > 0]) ifTrue: [^pragma argumentAt: ecIndex]]]. ^nil! ! !CompiledMethod methodsFor: 'source code management' stamp: 'CamilloBruni 5/21/2012 15:25'! sourceFileStream "Answer the sources file stream with position set at the beginning of my source string" | pos | (pos := self filePosition) = 0 ifTrue: [^ nil]. ^ (RemoteString newFileNumber: self fileIndex position: pos) fileStream! ! !CompiledMethod methodsFor: '*AST-Interpreter-Extension' stamp: 'ClementBera 10/18/2012 10:42'! code ^ self ast! ! !CompiledMethod methodsFor: '*Deprecated30' stamp: 'MarcusDenker 5/4/2013 08:29'! who "Answer an Array of the class in which the receiver is defined and the selector to which it corresponds." self deprecated: 'use #methodClass and #selector ' on: '04 May 2013' in: 'Pharo 3.0'. ^{self methodClass. self selector}. ! ! !CompiledMethod methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 4/27/2013 00:11'! reformat self methodClass compile: self ast formattedCode classified: self category.! ! !CompiledMethod methodsFor: 'accessing' stamp: 'CamilloBruni 2/22/2014 15:40'! hasSourceCode "Retrieve or reconstruct the source code for this method." | trailer source | trailer := self trailer. trailer sourceCode ifNotNil: [:code | ^ true ]. trailer hasSourcePointer ifFalse: [^ false]. "Situation normal; read the sourceCode from the file" source := [self getSourceFromFile] on: Error do: [ :ex | ex return: nil]. source isEmptyOrNil ifTrue: [^ false]. ^ true! ! !CompiledMethod methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/9/2012 04:13'! forceJIT ^ self primitiveFailed! ! !CompiledMethod methodsFor: '*rpackage-core' stamp: 'CamilloBruni 10/17/2012 11:22'! packageFromOrganizer: anRPackageOrganizer "This method returns the package this method belongs to. It takes into account classes and traits. If the method is in no package, returns nil by now" self flag: 'TODO: use anRPackageOrganizer, or better delegate to anRPackageOrganizer'. ^self origin packages detect: [ :each | (each includesSelector: self selector ofClassName: self origin theNonMetaClass originalName) or: [ each includesSelector: self selector ofMetaclassName: self origin theNonMetaClass originalName]] ifNone: [ nil ]! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 4/7/2011 18:51'! containsFlag ^ self literals includesAnyOf: #( flag flag: ).! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ar 6/2/1998 16:26'! numArgs "Answer the number of arguments the receiver takes." ^ (self header bitShift: -24) bitAnd: 16r0F! ! !CompiledMethod methodsFor: 'accessing' stamp: 'MarcusDenker 5/16/2013 13:46'! classBinding "answer the association to the class that I am installed in, or nil if none." ^self literalAt: self numLiterals! ! !CompiledMethod methodsFor: '*Tools' stamp: 'CamilloBruni 1/30/2013 21:26'! callers ^ SystemNavigation default allCallsOn: self selector! ! !CompiledMethod methodsFor: 'initialize-release' stamp: 'eem 9/14/2011 17:33'! copyWithTrailerBytes: trailer "Testing: (CompiledMethod compiledMethodAt: #copyWithTrailerBytes:) tempNamesPut: 'copy end ' " | copy end start penultimateLiteral | start := self initialPC. end := self endPC. copy := trailer createMethod: end - start + 1 class: self class header: self header. 1 to: self numLiterals do: [:i | copy literalAt: i put: (self literalAt: i)]. (penultimateLiteral := self penultimateLiteral) isMethodProperties ifTrue: [copy penultimateLiteral: (penultimateLiteral copy setMethod: copy; yourself)]. start to: end do: [:i | copy at: i put: (self at: i)]. ^copy! ! !CompiledMethod methodsFor: 'scanning' stamp: 'md 4/27/2006 15:12'! hasInstVarRef "Answer whether the method references an instance variable." | scanner end printer | scanner := InstructionStream on: self. printer := InstVarRefLocator new. end := self endPC. [scanner pc <= end] whileTrue: [ (printer interpretNextInstructionUsing: scanner) ifTrue: [^true]. ]. ^false! ! !CompiledMethod methodsFor: 'accessing' stamp: 'eem 8/20/2009 11:43'! clearFlag "Clear the user-level flag bit" self objectAt: 1 put: (self header bitAnd: (1 << 29) bitInvert)! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 4/21/2013 17:48'! argumentNames ^self ast argumentNames! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 12/21/2012 12:15'! getSourceFromFile "PLEASE Note: clients should always call #sourceCode" "Read the source code from file, determining source file index and file position from the last 3 bytes of this method." | position | (position := self filePosition) = 0 ifTrue: [^ nil]. ^ (RemoteString newFileNumber: self fileIndex position: position) string! ! !CompiledMethod methodsFor: 'private' stamp: 'eem 11/29/2008 11:10'! penultimateLiteral "Answer the penultimate literal of the receiver, which holds either the receiver's selector or its properties (which will hold the selector)." | pIndex | ^(pIndex := self numLiterals - 1) > 0 ifTrue: [self literalAt: pIndex] ifFalse: [nil]! ! !CompiledMethod methodsFor: 'testing' stamp: 'CamilloBruni 9/13/2012 14:16'! isOverridden | selector| selector := self selector. self methodClass allSubclassesDo: [:each | (each includesSelector: selector) ifTrue: [ ^ true ]]. ^ false ! ! !CompiledMethod methodsFor: 'debugger support' stamp: 'MarcusDenker 5/9/2013 11:28'! pcPreviousTo: pc | scanner client prevPc | pc > self endPC ifTrue: [^self endPC]. scanner := InstructionStream on: self. client := InstructionClient new. [scanner pc < pc] whileTrue: [prevPc := scanner pc. scanner interpretNextInstructionFor: client]. ^prevPc! ! !CompiledMethod methodsFor: 'literals' stamp: 'MarcusDenker 2/26/2012 10:46'! headerDescription "Answer a description containing the information about the form of the receiver and the form of the context needed to run the receiver." | s | s := '' writeStream. self header printOn: s. s cr; nextPutAll: '"primitive: '. self primitive printOn: s. s cr; nextPutAll: ' numArgs: '. self numArgs printOn: s. s cr; nextPutAll: ' numTemps: '. self numTemps printOn: s. s cr; nextPutAll: ' numLiterals: '. self numLiterals printOn: s. s cr; nextPutAll: ' frameSize: '. self frameSize printOn: s. s nextPut: $"; cr. ^ s contents! ! !CompiledMethod methodsFor: 'source code management' stamp: 'Igor.Stasenko 12/20/2009 19:12'! sourcePointer "Answer the integer which can be used to find the source file and position for this method. The actual interpretation of this number is up to the SourceFileArray stored in the global variable SourceFiles." ^ self trailer sourcePointer ! ! !CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'jannik.laval 1/8/2010 20:04'! removeProperty: propName "Remove the property propName if it exists. Do _not_ raise an error if the property is missing." | value | value := self propertyValueAt: propName ifAbsent: [^nil]. self penultimateLiteral: (self penultimateLiteral copyWithout: (Association key: propName value: value)). ^value! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'! isRequired: marker marker ifNil: [^ false]. (self isImplicitlyRequired: marker) ifTrue: [^ true]. (self isExplicitlyRequired: marker) ifTrue: [^ true]. (self isSubclassResponsibility: marker) ifTrue: [^ true]. ^ false! ! !CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:45'! filePosition ^SourceFiles filePositionFromSourcePointer: self sourcePointer! ! !CompiledMethod methodsFor: 'accessing' stamp: 'di 10/23/1999 22:00'! frameSize "Answer the size of temporary frame needed to run the receiver." "NOTE: Versions 2.7 and later use two sizes of contexts." (self header noMask: 16r20000) ifTrue: [^ SmallFrame] ifFalse: [^ LargeFrame] ! ! !CompiledMethod methodsFor: '*GroupManagerUI' stamp: 'BenjaminVanRyseghem 2/25/2012 16:36'! prettyName ^ self methodClass printString, '>>#', self selector! ! !CompiledMethod methodsFor: 'literals' stamp: ''! objectAt: index "Primitive. Answer the method header (if index=1) or a literal (if index >1) from the receiver. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !CompiledMethod methodsFor: '*Ring-Core-Kernel' stamp: 'NicolaiHess 1/17/2014 15:03'! asFullRingDefinition "Retrieves an active RGMethodDefinition which knows its parent . Note that the full conversion does not happen at the level of the class. If you need that request asFullRingDefinition to the class" | rgClass rgMethod | rgClass := self realClass asRingDefinition. rgMethod := self asActiveRingDefinition. rgClass addMethod: rgMethod. rgMethod package: (RGContainer packageOfMethod: rgMethod). ^ rgMethod! ! !CompiledMethod methodsFor: 'private' stamp: 'al 2/13/2006 17:44'! markerOrNil "If I am a marker method, answer the symbol used to mark me. Otherwise answer nil. What is a marker method? It is method with body like 'self subclassResponsibility' or '^ self subclassResponsibility' used to indicate ('mark') a special property. Marker methods compile to bytecode like: 9 <70> self 10 send: 11 <87> pop 12 <78> returnSelf for the first form, or 9 <70> self 10 send: 11 <7C> returnTop for the second form." | e | ((e := self endPC) = 19 or: [e = 20]) ifFalse: [^ nil]. (self numLiterals = 3) ifFalse:[^ nil]. (self at: 17) = 16r70 ifFalse:[^ nil]. "push self" (self at: 18) = 16rD0 ifFalse:[^ nil]. "send " "If we reach this point, we have a marker method that sends self " ^ self literalAt: 1 ! ! !CompiledMethod methodsFor: 'scanning' stamp: 'eem 12/6/2011 13:35'! abstractBytecodeMessagesDo: aBlock "Evaluate aBlock with the sequence of abstract bytecodes in the receiver" self abstractBytecodeMessagesFrom: self initialPC to: self endPC do: aBlock "| msgs | msgs := OrderedCollection new. CompiledMethod >> #abstractBytecodeMessagesFrom:to: abstractBytecodeMessagesDo: [:msg| msgs add: msg selector]. msgs"! ! !CompiledMethod methodsFor: 'accessing' stamp: 'eem 8/20/2009 11:42'! flag "Answer the user-level flag bit" ^((self header bitShift: -29) bitAnd: 1) = 1! ! !CompiledMethod methodsFor: '*Deprecated30' stamp: 'MarcusDenker 10/11/2013 10:30'! decompileString self deprecated: 'decompiling bc->text is not supported'. ^self codeForNoSource.! ! !CompiledMethod methodsFor: 'literals' stamp: 'eem 10/28/2008 10:47'! literalsDo: aBlock "Evaluate aBlock for each of the literals referenced by the receiver." 1 to: self numLiterals do: [:index | aBlock value: (self objectAt: index + 1)]! ! !CompiledMethod methodsFor: 'testing' stamp: 'MarcusDenker 4/29/2012 14:59'! isDoIt ^self selector isDoIt.! ! !CompiledMethod methodsFor: 'accessing' stamp: 'md 2/18/2006 13:11'! defaultSelector "Invent and answer an appropriate message selector (a Symbol) for me, that is, one that will parse with the correct number of arguments." ^#DoIt numArgs: self numArgs! ! !CompiledMethod methodsFor: 'testing' stamp: 'CamilloBruni 2/23/2014 21:52'! hasSourcePointer ^ self trailer hasSourcePointer! ! !CompiledMethod methodsFor: 'accessing' stamp: 'MarcusDenker 2/29/2012 11:18'! flushCache "Tell the interpreter to remove all references to this method from its method lookup cache, if it has one. This primitive must be called whenever a method is redefined or removed. NOTE: Only one of two selective flush methods (Symbol or CompiledMethod) needs to be used." ! ! !CompiledMethod methodsFor: 'source code management' stamp: 'CamilloBruni 2/28/2012 14:06'! sourceFileStreamIfAbsent: aBlock ^ self sourceFileStream ifNil: aBlock! ! !CompiledMethod methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 01:00'! symbolic "Answer a String that contains a list of all the byte codes in a method with a short description of each." | aStream | aStream := (String new: 1000) writeStream. self longPrintOn: aStream. ^aStream contents! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! isExplicitlyRequired ^ self isExplicitlyRequired: self markerOrNil! ! !CompiledMethod methodsFor: '*Fuel' stamp: 'MaxLeske 7/8/2013 21:17'! bytecodesHash "Answer a 16-bit checksum of the bytecodes." ^ CRC crc16FromCollection: (ByteArray new: self size streamContents: [ :stream | self from: self initialPC to: self endPC do: [ :byte | stream nextPut: byte ] ])! ! !CompiledMethod methodsFor: 'testing' stamp: 'mada 5/5/2012 11:29'! isBinarySelector ^self selector allSatisfy: [:each | each isSpecial]! ! !CompiledMethod methodsFor: '*AST-Interpreter-Extension' stamp: 'CamilloBruni 2/3/2012 15:44'! isReflective ^ (self hasPragmaNamed: #reflective:)! ! !CompiledMethod methodsFor: 'literals' stamp: 'nice 7/20/2011 09:05'! hasLiteral: literal "Answer whether the receiver references the argument, literal." 2 to: self numLiterals - 1 do: "exclude superclass + selector/properties" [:index | ((self objectAt: index) literalEqual: literal) ifTrue: [^true]]. ^false! ! !CompiledMethod methodsFor: '*Ring-Core-Kernel' stamp: 'StephaneDucasse 8/21/2011 17:49'! methodReference | class selector | class := self methodClass ifNil: [^nil]. selector := self selector ifNil: [^nil]. ^RGMethodDefinition realClass: class selector: selector. ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'MarcusDenker 5/16/2013 09:12'! methodClass "answer the class that I am installed in" ^self classBinding value! ! !CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 12/1/2008 16:58'! pragmaAt: aKey "Answer the pragma with selector aKey, or nil if none." | propertiesOrSelector | ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties ifTrue: [propertiesOrSelector at: aKey ifAbsent: [nil]] ifFalse: [nil]! ! !CompiledMethod methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 3/21/2013 13:25'! manifestBuilderForRuleChecker: aRuleChecker "Return the manifestsince the rulechecker is keeping a cache, we ask it back" ^ aRuleChecker manifestBuilderOfMethod: self! ! !CompiledMethod methodsFor: '*Deprecated30' stamp: 'MarcusDenker 5/16/2013 13:48'! methodClassAssociation: aBinding self deprecated: 'use classBinding:' on: '16 May 2013' in: 'Pharo3'. self classBinding: aBinding! ! !CompiledMethod methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 23:36'! printOn: aStream "Overrides method inherited from the byte arrayed collection." aStream print: self methodClass; nextPutAll: '>>'; store: self selector.! ! !CompiledMethod methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 2/4/2013 16:01'! compilerClass ^self methodClass ifNil: [Smalltalk compilerClass] ifNotNil: [:class | class compilerClass].! ! !CompiledMethod methodsFor: '*tools-debugger' stamp: 'emm 5/30/2002 09:22'! hasBreakpoint ^BreakpointManager methodHasBreakpoint: self! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'! isSubclassResponsibility: marker ^ marker == self class subclassResponsibilityMarker! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 4/7/2011 18:10'! hasErrorTest ^ self methodClass methodRaisedError: (self selector)! ! !CompiledMethod methodsFor: 'testing' stamp: ''! isReturnSpecial "Answer whether the receiver is a quick return of self or constant." ^ self primitive between: 256 and: 263! ! !CompiledMethod methodsFor: '*rpackage-core' stamp: 'tg 3/13/2010 13:50'! isExtensionInPackage: anRPackage ^ anRPackage includesExtensionSelector: self selector ofClass: self methodClass! ! !CompiledMethod methodsFor: 'testing' stamp: 'CamilloBruni 9/22/2012 21:12'! isFromTrait "Return true for methods that have been included from Traits" ^ self origin isTrait and: [ self origin ~= self methodClass ]! ! !CompiledMethod methodsFor: 'scanning' stamp: 'dvf 11/12/2002 00:44'! messagesDo: aBlock ^ self messages do:aBlock.! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 4/29/2012 10:33'! definition "Polymorphic to class definition" ^ self sourceCode! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 5/2/2013 19:14'! getSourceReplacingSelectorWith: newSelector | oldKeywords newKeywords args newSelectorWithArgs source oldSelector s | source := self sourceCode. oldSelector := self ast selector. oldSelector = newSelector ifTrue: [ ^ source ]. oldKeywords := oldSelector keywords. newKeywords := (newSelector ifNil: [self defaultSelector]) keywords. [oldKeywords size = newKeywords size] assert. args := self ast argumentNames. newSelectorWithArgs := String streamContents: [:stream | newKeywords withIndexDo: [:keyword :index | stream nextPutAll: keyword. stream space. args size >= index ifTrue: [ stream nextPutAll: (args at: index); space]]]. s := source string readStream. oldKeywords do: [ :each | s match: each ]. args isEmpty ifFalse: [ s match: args last ]. ^newSelectorWithArgs trimBoth, s upToEnd! ! !CompiledMethod methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/12/2011 11:28'! protocol " start to migrate to RING API " ^ self category! ! !CompiledMethod methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 5/19/2010 00:46'! needsFrameSize: newFrameSize "Set the largeFrameBit to accomodate the newFrameSize" | largeFrameBit header | largeFrameBit := 16r20000. (self numTemps + newFrameSize) > LargeFrame ifTrue: [^ self error: 'Cannot compile -- stack including temps is too deep']. header := self objectAt: 1. (header bitAnd: largeFrameBit) ~= 0 ifTrue: [header := header - largeFrameBit]. self objectAt: 1 put: header + ( ((self numTemps + newFrameSize) > SmallFrame or: [ self primitive = 84 "perform:withArguments:"]) ifTrue: [largeFrameBit] ifFalse: [0])! ! !CompiledMethod methodsFor: 'printing' stamp: ''! storeOn: aStream | noneYet | aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' newMethod: '. aStream store: self size - self initialPC + 1. aStream nextPutAll: ' header: '. aStream store: self header. aStream nextPut: $). noneYet := self storeElementsFrom: self initialPC to: self endPC on: aStream. 1 to: self numLiterals do: [:index | noneYet ifTrue: [noneYet := false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' literalAt: '. aStream store: index. aStream nextPutAll: ' put: '. aStream store: (self literalAt: index)]. noneYet ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !CompiledMethod methodsFor: 'printing' stamp: 'GuillermoPolito 4/26/2012 10:55'! longPrintOn: aStream indent: tabs "List of all the byte codes in a method with a short description of each" self isQuick ifTrue: [self isReturnSpecial ifTrue: [^ aStream tab: tabs; nextPutAll: 'Quick return ' , (#('self' 'true' 'false' 'nil' '-1' '0' '1' '2') at: self primitive - 255)]. ^ aStream nextPutAll: 'Quick return field ' , self returnField printString , ' (0-based)']. self isPrimitive ifTrue: [ aStream tab: tabs. self printPrimitiveOn: aStream. ]. (InstructionPrinter on: self) indent: tabs; printInstructionsOn: aStream. ! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 12/22/2012 17:45'! getSource "use #sourceCode instead" ^self sourceCode.! ! !CompiledMethod methodsFor: 'testing' stamp: 'AlexandreBergel 9/14/2011 08:31'! isAbstract "Answer true if I am abstract" ^ self markerOrNil == self class abstractMarker! ! !CompiledMethod methodsFor: '*FuelTests' stamp: 'MarianoMartinezPeck 4/20/2012 21:18'! isEqualRegardlessTrailerTo: aCompiledMethod ^ (self copyWithTrailerBytes: CompiledMethodTrailer empty) = (aCompiledMethod copyWithTrailerBytes: CompiledMethodTrailer empty)! ! !CompiledMethod methodsFor: '*Ring-Core-Kernel' stamp: 'MarianoMartinezPeck 6/26/2012 10:41'! realClass "answer the class that I am installed in" ^ self methodClass! ! !CompiledMethod methodsFor: 'scanning' stamp: 'CamilloBruni 8/1/2012 16:19'! writesField: varIndex "Answer whether the receiver stores into the instance variable indexed by the argument." | varIndexCode scanner | self isQuick ifTrue: [^false]. varIndexCode := varIndex - 1. ^(scanner := InstructionStream on: self) scanFor: [:b| b >= 96 and: [b <= 103 ifTrue: [b - 96 = varIndexCode] ifFalse: [(b = 129 or: [b = 130]) ifTrue: [scanner followingByte = varIndexCode and: [varIndexCode <= 63]] ifFalse: [b = 132 and: [(scanner followingByte between: 160 and: 223) and: [scanner thirdByte = varIndexCode]]]]]]! ! !CompiledMethod methodsFor: 'accessing' stamp: 'MarcusDenker 10/10/2013 16:35'! originMethod | selector | self properties at: #traitSource ifPresent: [ :traitMethod | ^ traitMethod ]. "Use the method dictionary because traits do not have method for accesing methods by selector" selector := self methodClass traitComposition originSelectorOf: self selector. ^ (self methodClass traitOrClassOfSelector: selector)>>selector. ! ! !CompiledMethod methodsFor: 'testing' stamp: 'MarcusDenker 9/14/2013 10:29'! hasReportableSlip "Answer whether the receiver contains anything that should be brought to the attention of the author when filing out. Customize the lists here to suit your preferences. If slips do not get reported in spite of your best efforts here, make certain that the Preference 'checkForSlips' is set to true." #(#doOnlyOnce: #halt #halt: #printDirectlyToDisplay #toRemove #urgent #haltOnce #haltOnce: #haltIf:) do: [ :aLit | (self hasLiteral: aLit) ifTrue: [ ^ true ] ]. #(#Transcript #AA #BB #CC #DD #EE) do: [ :aSymbol | (Smalltalk globals associationAt: aSymbol ifAbsent: [ ]) ifNotNil: [ :assoc | (self hasLiteral: assoc) ifTrue: [ ^ true ] ] ]. ^ false! ! !CompiledMethod methodsFor: 'comparing' stamp: 'LukasRenggli 5/8/2010 19:37'! = aCompiledMethod "Answer whether the receiver implements the same code as aCompiledMethod." | numLits | self == aCompiledMethod ifTrue: [ ^ true ]. self class = aCompiledMethod class ifFalse: [ ^ false ]. self size = aCompiledMethod size ifFalse: [ ^ false ]. self header = aCompiledMethod header ifFalse: [ ^ false ]. self initialPC to: self endPC do: [ :i | (self at: i) = (aCompiledMethod at: i) ifFalse: [ ^ false ] ]. (self sameLiteralsAs: aCompiledMethod) ifFalse: [ ^ false ]. ^ true! ! !CompiledMethod methodsFor: '*NativeBoost-Core' stamp: 'Igor.Stasenko 5/18/2010 08:20'! hasNativeCode ^ self trailerKind == #NativeCodeTrailer! ! !CompiledMethod methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 5/12/2013 11:46'! compiler ^self methodClass ifNil: [Smalltalk compiler] ifNotNil: [:class | class compiler].! ! !CompiledMethod methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 7/12/2013 16:29'! nbArgumentNames "Answer the method's argument names. We using a separate method, to get arg names not from source code directly, but from method properties, collected at compile time. Useful, when there is no source code available (for some reason)" ^ self propertyValueAt: #nbArgumentNames ifAbsent: [ self propertyValueAt: #nbArgumentNames put: self argumentNames ] ! ! !CompiledMethod methodsFor: 'scanning' stamp: 'CamilloBruni 8/1/2012 16:15'! readsRef: literalAssociation "Answer whether the receiver loads the argument." | litIndex scanner | (litIndex := self indexOfLiteral: literalAssociation) = 0 ifTrue: [^false]. litIndex := litIndex - 1. ^(scanner := InstructionStream on: self) scanFor: [:b| b >= 64 and: [b <= 95 ifTrue: [b - 64 = litIndex] ifFalse: [b = 128 ifTrue: [scanner followingByte - 192 = litIndex] ifFalse: [b = 132 and: [(scanner followingByte between: 128 and: 159) and: [scanner thirdByte = litIndex]]]]]]! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! isImplicitlyRequired ^ self isImplicitlyRequired: self markerOrNil! ! !CompiledMethod methodsFor: '*Tools' stamp: 'CamilloBruni 1/30/2013 21:26'! implementors ^ SystemNavigation default allImplementorsOf: self selector! ! !CompiledMethod methodsFor: '*AST-Core' stamp: 'MarcusDenker 5/17/2013 15:39'! parseTree ^(RBExplicitVariableParser parseMethod: self sourceCode onError: [ :msg :pos | ^ nil ]) methodClass: self methodClass. ! ! !CompiledMethod methodsFor: 'scanning' stamp: 'CamilloBruni 8/1/2012 16:14'! readsField: varIndex "Answer whether the receiver loads the instance variable indexed by the argument." | varIndexCode scanner | varIndexCode := varIndex - 1. self isReturnField ifTrue: [^self returnField = varIndexCode]. ^(scanner := InstructionStream on: self) scanFor: [:b| b < 16 ifTrue: [b = varIndexCode] ifFalse: [b = 128 ifTrue: [scanner followingByte = varIndexCode and: [varIndexCode <= 63]] ifFalse: [b = 132 and: [(scanner followingByte between: 64 and: 95) and: [scanner thirdByte = varIndexCode]]]]]! ! !CompiledMethod methodsFor: '*Tools' stamp: 'MarcusDenker 9/22/2013 21:02'! explorerContents "(CompiledMethod compiledMethodAt: #explorerContents) explore" ^Array streamContents: [:s| | tokens | tokens := (self headerDescription readStream skipTo: $"; upTo: $") parseLiterals. s nextPut: (ObjectExplorerWrapper with: ((0 to: tokens size by: 2) collect: [:i| i = 0 ifTrue: [self header] ifFalse: [{tokens at: i - 1. tokens at: i}]]) name: 'header' model: self). 1 to: self numLiterals do: [:key| s nextPut: (ObjectExplorerWrapper with: (self literalAt: key) name: ('literal', key printString contractTo: 32) model: self)]. self isQuick ifTrue: [s nextPut: (ObjectExplorerWrapper with: self symbolic name: #symbolic model: self)] ifFalse: [self symbolicLinesDo: [:pc :line| pc <= 1 ifTrue: [s nextPut: (ObjectExplorerWrapper with: line name: 'pragma' model: self)] ifFalse: [s nextPut: (ObjectExplorerWrapper with: line name: pc printString model: self)]]]. "should be self numLiterals + 1 * Smalltalk wordSize + 1" self endPC + 1 to: self basicSize do: [:key| s nextPut: (ObjectExplorerWrapper with: (self basicAt: key) name: key printString model: self)]]! ! !CompiledMethod methodsFor: 'testing' stamp: 'MarcusDenker 10/10/2013 16:35'! isInstalled self methodClass ifNotNil: [:class| self selector ifNotNil: [:selector| ^self == (class compiledMethodAt: selector ifAbsent: [])]]. ^false! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'! isSubclassResponsibility ^ self isSubclassResponsibility: self markerOrNil! ! !CompiledMethod methodsFor: '*Tools' stamp: 'BenjaminVanRyseghem 1/23/2012 19:57'! browse ^ Smalltalk tools browser fullOnClass: self methodClass selector: self selector! ! !CompiledMethod methodsFor: 'scanning' stamp: 'eem 12/6/2011 13:47'! abstractBytecodeMessageAt: pc "Answer the abstract bytecode message at pc in the receiver." ^[(InstructionStream new method: self pc: pc) interpretNextInstructionFor: nil] on: MessageNotUnderstood do: [:ex| ex message]! ! !CompiledMethod methodsFor: '*Deprecated30' stamp: 'MarcusDenker 5/2/2013 17:14'! decompilerClass self deprecated: 'use #compilerClass' on: '02 May 2013' in: 'Pharo 3.0'. ^self compilerClass! ! !CompiledMethod methodsFor: '*rpackage-core' stamp: 'CamilloBruni 4/27/2012 17:07'! package ^ self packageFromOrganizer: RPackage organizer! ! !CompiledMethod methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 3/21/2013 12:55'! criticTheNonMetaclassClass "Return the class of the receiver for the critic browser. This behavior may be folded later by changing the name of this method or using another one." ^ self methodClass theNonMetaClass! ! !CompiledMethod methodsFor: 'literals' stamp: ''! literalAt: index "Answer the literal indexed by the argument." ^self objectAt: index + 1! ! !CompiledMethod methodsFor: 'comparing' stamp: 'MarcusDenker 5/2/2013 10:33'! equivalentTo: aCompiledMethod ^self = aCompiledMethod or: [self class == aCompiledMethod class and: [self numArgs = aCompiledMethod numArgs and: [self numLiterals = aCompiledMethod numLiterals and: [self methodNode = aCompiledMethod methodNode ]]]]! ! !CompiledMethod methodsFor: 'printing' stamp: 'MarcusDenker 4/29/2012 10:33'! asString ^self sourceCode! ! !CompiledMethod methodsFor: 'accessing' stamp: 'MarcusDenker 10/11/2013 10:28'! codeForNoSource "this is the marker we use for method that have no source" ^String streamContents: [:str | str nextPutAll: self selector asMethodPreamble; cr;tab; nextPutAll: 'self methodHasNoSourceCode'].! ! !CompiledMethod methodsFor: 'testing' stamp: 'GuillermoPolito 4/26/2012 11:11'! isExternalCallPrimitive ^self primitive = 120! ! !CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 21:02'! setSourcePosition: position inFile: fileIndex self setSourcePointer: (SourceFiles sourcePointerFromFileIndex: fileIndex andPosition: position)! ! !CompiledMethod methodsFor: 'accessing' stamp: 'MarcusDenker 10/16/2013 21:59'! category ^self methodClass organization categoryOfElement: self selector! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'CAMILLETERUEL 3/29/2013 11:52'! containsHalt ^ self literals includesAnyOf: #( halt halt: halt:onCount: haltIf: haltIfNil haltIfShiftPressed haltOnCount: haltOnce).! ! !CompiledMethod methodsFor: 'initialize-release' stamp: 'CamilloBruni 8/31/2013 20:55'! removeFromSystem ^ self methodClass removeSelector: self selector! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! isDisabled ^ self isDisabled: self markerOrNil! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:40'! isProvided: marker marker ifNil: [^ true]. ^ (self isRequired: marker) not and: [(self isDisabled: marker) not]! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ls 6/22/2000 14:35'! primitive "Answer the primitive index associated with the receiver. Zero indicates that this is not a primitive method. We currently allow 10 bits of primitive index, but they are in two places for backward compatibility. The time to unpack is negligible, since the reconstituted full index is stored in the method cache." | primBits | primBits := self header bitAnd: 16r100001FF. ^ (primBits bitAnd: 16r1FF) + (primBits bitShift: -19) ! ! !CompiledMethod methodsFor: '*Deprecated30' stamp: 'MarcusDenker 5/16/2013 13:48'! methodClassAssociation self deprecated: 'use classBinding:' on: '16 May 2013' in: 'Pharo3'. ^self classBinding! ! !CompiledMethod methodsFor: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 9/19/2011 16:09'! asRingDefinition "Retrieves an active RGMethodDefinition object based on the receiver. Note that its class is not converted." ^ self asActiveRingDefinition! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 4/24/2013 16:15'! putSource: sourceStr class: class category: catName withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod ^ self putSource: sourceStr inFile: fileIndex withPreamble: [:file | class printCategoryChunk: catName on: file withStamp: changeStamp priorMethod: priorMethod. file cr]! ! !CompiledMethod methodsFor: 'private' stamp: 'eem 11/29/2008 11:52'! penultimateLiteral: anObject "Answer the penultimate literal of the receiver, which holds either the receiver's selector or its properties (which will hold the selector)." | pIndex | (pIndex := self numLiterals - 1) > 0 ifTrue: [self literalAt: pIndex put: anObject] ifFalse: [self error: 'insufficient literals']! ! !CompiledMethod methodsFor: 'scanning' stamp: 'eem 12/6/2011 13:23'! abstractBytecodeMessagesFrom: startpc to: endpc do: aBlock "Evaluate aBlock with the sequence of abstract bytecodes from startpc through endpc in the receiver" | scanner | scanner := InstructionStream new method: self pc: startpc. [scanner pc <= endpc] whileTrue: [[scanner interpretNextInstructionFor: nil] on: MessageNotUnderstood do: [:ex| aBlock value: ex message]] "| m msgs | msgs := OrderedCollection new. (m := CompiledMethod >> #abstractBytecodeMessagesFrom:to:) abstractBytecodeMessagesFrom: m initialPC to: m endPC do: [:msg| msgs add: msg selector]. msgs"! ! !CompiledMethod methodsFor: 'literals' stamp: 'marcus.denker 9/29/2008 08:44'! literals "Answer an Array of the literals referenced by the receiver." | literals numberLiterals | literals := Array new: (numberLiterals := self numLiterals). 1 to: numberLiterals do: [:index | literals at: index put: (self objectAt: index + 1)]. ^literals! ! !CompiledMethod methodsFor: 'accessing-pragmas & properties' stamp: 'eem 11/29/2008 11:50'! propertyValueAt: propName ifAbsent: aBlock | propertiesOrSelector | ^(propertiesOrSelector := self penultimateLiteral) isMethodProperties ifTrue: [propertiesOrSelector propertyValueAt: propName ifAbsent: aBlock] ifFalse: [aBlock value]! ! !CompiledMethod methodsFor: 'accessing' stamp: 'eem 11/28/2008 12:54'! selector "Answer a method's selector. This is either the penultimate literal, or, if the method has any properties or pragmas, the selector of the MethodProperties stored in the penultimate literal." | penultimateLiteral | ^(penultimateLiteral := self penultimateLiteral) isMethodProperties ifTrue: [penultimateLiteral selector] ifFalse: [penultimateLiteral]! ! !CompiledMethod methodsFor: 'source code management' stamp: 'mf 4/29/2012 13:11'! copyWithSource: aString ^self copyWithTrailerBytes: (CompiledMethodTrailer new sourceCode: aString) ! ! !CompiledMethod methodsFor: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 9/19/2011 16:08'! asActiveRingDefinition "Retrieves an active RGMethodDefinition object based on the data of the receiver. Source, protocol and stamp are retrieved from the compiled method" | ring | ring := (RGFactory current createMethodNamed: self selector) parentName: self methodClass name; isMetaSide: self methodClass isMeta; asActive. ^ ring! ! !CompiledMethod methodsFor: 'literals' stamp: ''! header "Answer the word containing the information about the form of the receiver and the form of the context needed to run the receiver." ^self objectAt: 1! ! !CompiledMethod methodsFor: 'scanning' stamp: ''! scanFor: byte "Answer whether the receiver contains the argument as a bytecode." ^ (InstructionStream on: self) scanFor: [:instr | instr = byte] " Smalltalk browseAllSelect: [:m | m scanFor: 134] "! ! !CompiledMethod methodsFor: '*Ring-Core-Kernel' stamp: 'CamilloBruni 5/21/2012 15:29'! getSourceFromFile: file "Read the source code from file, determining source file index and file position from the last 3 bytes of this method." | position | (position := self filePosition) = 0 ifTrue: [^ nil]. "assime this is a valid file" file position: position. ^ file nextChunk! ! !CompiledMethod methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 3/21/2013 12:44'! criticNameOn: aStream "This behavior may be folded later by changing the name of this method or using another one." aStream << self methodClass name << '>>#' << self selector << ' (' << self methodClass theNonMetaClass category << ')'! ! !CompiledMethod methodsFor: 'scanning' stamp: 'marcus.denker 9/29/2008 08:50'! messages "Answer a Set of all the message selectors sent by this method." | scanner aSet | aSet := Set new. scanner := InstructionStream on: self. scanner scanFor: [:x | scanner addSelectorTo: aSet. false "keep scanning"]. ^aSet! ! !CompiledMethod methodsFor: 'accessing' stamp: ''! numLiterals "Answer the number of literals used by the receiver." ^ (self header bitShift: -9) bitAnd: 16rFF! ! !CompiledMethod methodsFor: 'source code management' stamp: 'CamilloBruni 2/23/2014 20:26'! hasSourceCodeInChangesFile ^ self fileIndex == 2! ! !CompiledMethod methodsFor: '*AST-Interpreter-Extension' stamp: 'ClementBera 2/26/2013 10:55'! accept: visitor on: receiver message: aMessage self isReflective ifTrue: [ ^ visitor invokeReflectiveMethod: self on: receiver message: aMessage]. self isPrimitive ifTrue: [ ^ visitor invokePrimitiveMethod: self on: receiver message: aMessage ]. ^ visitor invokeMethod: self on: receiver message: aMessage! ! !CompiledMethod methodsFor: '*rpackage-core' stamp: 'ClementBera 7/26/2013 16:57'! handleUnpackaged: anRPackageOrganizer | tmpTrait | tmpTrait := self methodClass traitComposition traitProvidingSelector: self selector. tmpTrait ifNotNil: [ (tmpTrait packages select: [ :aRPackage | aRPackage includesSelector: self selector ofClass: tmpTrait ]) isEmpty ifFalse: [ ^ self ]]. self error: 'Yes... method is unpackaged and I don''t know what to do with this.'. " self halt. self category isNil ifTrue: [ Error signal ]. anRPackageOrganizer systemMethodAddedActionFrom: (AddedEvent method: self selector: self selector protocol: self category class: self methodClass) asSystemAnnouncement"! ! !CompiledMethod methodsFor: 'comparing' stamp: 'MarianoMartinezPeck 7/24/2012 09:42'! hash "CompiledMethod>>#= compares code, i.e. same literals and same bytecode. So we look at the header, methodClass and some bytes between initialPC and endPC, but /not/ the selector because the equal method does not compare selectors. Note that we must override ByteArray>hash which looks at all bytes of the receiver. Using bytes from the pointer part of a COmpiledmethod can lead to a variable hash if and when when the GC moves literals in the receiver." | initialPC endPC hash | initialPC := self initialPC. endPC := self endPC. hash := self species hash + self header + initialPC + endPC + self methodClass hash bitAnd: 16rFFFFFFF. "sample approximately 20 bytes" initialPC to: endPC by: (endPC - initialPC // 20 max: 1) do: [:i| hash := hash + (self at: i)]. ^hash "(CompiledMethod>>#hash) hash" ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'md 1/20/2006 16:09'! method "polymorphic with closure" ^ self! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 4/7/2011 18:11'! hasFailedTest ^ self methodClass methodFailed: (self selector)! ! !CompiledMethod methodsFor: 'accessing' stamp: ''! returnField "Answer the index of the instance variable returned by a quick return method." | prim | prim := self primitive. prim < 264 ifTrue: [self error: 'only meaningful for quick-return'] ifFalse: [^ prim - 264]! ! !CompiledMethod methodsFor: '*FuelTests' stamp: 'MarianoMartinezPeck 4/20/2012 21:23'! sizeWithoutTrailer ^ self trailer endPC! ! !CompiledMethod methodsFor: 'literals' stamp: ''! objectAt: index put: value "Primitive. Store the value argument into a literal in the receiver. An index of 2 corresponds to the first literal. Fails if the index is less than 2 or greater than the number of literals. Answer the value as the result. Normally only the compiler sends this message, because only the compiler stores values in CompiledMethods. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !CompiledMethod methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 5/14/2013 17:06'! irPrimitive | primNode n | primNode := IRPrimitive new num: (n := self primitive). (n = 117 or: [n = 120]) ifTrue: [ primNode spec: (self literalAt: 1)]. ^ primNode! ! !CompiledMethod methodsFor: 'evaluating' stamp: 'StephaneDucasse 6/24/2011 18:09'! valueWithReceiver: aReceiver arguments: anArray "This should be changed when all the VM will support passign of extra arguments ^self receiver: aReceiver withArguments: anArray executeMethod: self" ^ aReceiver withArgs: anArray executeMethod: self! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 8/22/2012 16:24'! author "Answer the author of the current version of the receiver. retrieved from the sources or changes file. Answer the empty string if no time stamp is available." "(CompiledMethod compiledMethodAt: #author) author" self timeStamp ifNotEmpty: [:s | |subS| subS := s substrings first. subS first isLetter ifTrue:[^subS]]. ^''! ! !CompiledMethod methodsFor: 'accessing' stamp: ''! numTemps "Answer the number of temporary variables used by the receiver." ^ (self header bitShift: -18) bitAnd: 16r3F! ! !CompiledMethod methodsFor: 'printing' stamp: 'nice 11/1/2009 22:09'! isSelfEvaluating ^self methodClass notNil and: [(#(#DoIt #DoItIn: nil) includes: self selector) not]! ! !CompiledMethod methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 7/12/2013 16:39'! hasNativeCallPrimitive "Answer true if receiver has following primitive: " ^ ((self primitive = 117) and: [ | lit | lit := self literalAt: 1. lit first = #NativeBoostPlugin and: [ lit second == #primitiveNativeCall]])! ! !CompiledMethod methodsFor: 'printing' stamp: 'MarcusDenker 6/5/2012 14:09'! printPrimitiveOn: aStream "Print the primitive on aStream" | primDecl | self isPrimitive ifFalse: [ ^self ]. self isExternalCallPrimitive ifTrue: [^aStream print: (self literalAt: 1); cr]. aStream nextPutAll: '; cr! ! !CompiledMethod methodsFor: 'literals' stamp: 'eem 11/29/2008 17:01'! hasLiteralSuchThat: litBlock "Answer true if litBlock returns true for any literal in this method, even if embedded in array structure." (self penultimateLiteral isMethodProperties and: [self penultimateLiteral hasLiteralSuchThat: litBlock]) ifTrue: [^true]. 2 to: self numLiterals + 1 do: [:index | | lit | lit := self objectAt: index. ((litBlock value: lit) or: [lit isArray and: [lit hasLiteralSuchThat: litBlock]]) ifTrue: [^true]]. ^false! ! !CompiledMethod class methodsFor: 'accessing class hierarchy' stamp: 'eem 9/16/2011 11:12'! methodPropertiesClass "Answer the class to use to create a method's properties, which can be a poor man's way to add instance variables to subclassses of CompiledMethod. Subclasses of CompiledMethod should define a corresponding subclass of AdditionalMethodState that adds any instance variables required, and override this method to answer that class." ^AdditionalMethodState! ! !CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! explicitRequirementMarker ^ #explicitRequirement! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'MarcusDenker 3/13/2011 20:23'! basicNew self error: 'CompiledMethods may only be created with newMethod:header:' ! ! !CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! subclassResponsibilityMarker ^ #subclassResponsibility! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/18/2009 11:59'! newMethod: numberOfBytes header: headerWord "Primitive. Answer an instance of me. The number of literals (and other information) is specified the headerWord. The first argument specifies the number of fields for bytecodes in the method. Fail if either argument is not a SmallInteger, or if numberOfBytes is negative. Once the header of a method is set by this primitive, it cannot be changed in any way. Essential. See Object documentation whatIsAPrimitive." (numberOfBytes isInteger and: [headerWord isInteger and: [numberOfBytes >= 0]]) ifTrue: [ "args okay; space must be low" OutOfMemory signal. "retry if user proceeds" ^ self newMethod: numberOfBytes header: headerWord ]. ^self primitiveFailed! ! !CompiledMethod class methodsFor: 'class initialization' stamp: 'eem 6/5/2008 09:05'! initialize "CompiledMethod initialize" "Initialize class variables specifying the size of the temporary frame needed to run instances of me." SmallFrame := 16. "Context range for temps+stack" LargeFrame := 56! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 12/20/2009 04:32'! toReturnSelf "Answer an instance of me that is a quick return of the instance (^self)." ^ self toReturnSelfTrailerBytes: CompiledMethodTrailer empty! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'NS 12/12/2003 15:03'! newFrom: aCompiledMethod | inst | inst := super basicNew: aCompiledMethod size. 1 to: aCompiledMethod size do: [:index | inst at: index put: (aCompiledMethod at: index)]. ^ inst.! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'tk 9/9/2000 20:36'! basicNew: size self error: 'CompiledMethods may only be created with newMethod:header:' ! ! !CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! disabledMarker ^ #shouldNotImplement! ! !CompiledMethod class methodsFor: 'constants' stamp: 'AlexandreBergel 9/14/2011 08:30'! abstractMarker ^ #subclassResponsibility! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'eem 9/13/2011 15:16'! newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex "Answer an instance of me. The header is specified by the message arguments. The remaining parts are not as yet determined." | largeBit primBits | nTemps > 63 ifTrue: [^ self error: 'Cannot compile -- too many temporary variables']. nLits > 255 ifTrue: [^ self error: 'Cannot compile -- too many literals variables']. largeBit := (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0]. primBits := primitiveIndex <= 16r1FF ifTrue: [primitiveIndex] ifFalse: ["For now the high bit of primitive no. is in the 29th bit of header" primitiveIndex > 16r3FF ifTrue: [self error: 'prim num too large']. (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19)]. ^trailer createMethod: numberOfBytes class: self header: (nArgs bitShift: 24) + (nTemps bitShift: 18) + (largeBit bitShift: 17) + (nLits bitShift: 9) + primBits! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'md 8/5/2005 17:06'! toReturnConstant: index trailerBytes: trailer "Answer an instance of me that is a quick return of the constant indexed in (true false nil -1 0 1 2)." ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 + index ! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'md 8/5/2005 17:05'! toReturnSelfTrailerBytes: trailer "Answer an instance of me that is a quick return of the instance (^self)." ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 ! ! !CompiledMethod class methodsFor: '*Spec-Inspector' stamp: 'CamilloBruni 9/21/2013 19:59'! additionalInspectorClasses ^ super additionalInspectorClasses, { EyeMethodEditor }! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'eem 9/13/2011 15:18'! newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag "Answer an instance of me. The header is specified by the message arguments. The remaining parts are not as yet determined." | largeBit primBits flagBit | nTemps > 63 ifTrue: [^ self error: 'Cannot compile -- too many temporary variables']. nLits > 255 ifTrue: [^ self error: 'Cannot compile -- too many literals variables']. largeBit := (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0]. "For now the high bit of the primitive no. is in a high bit of the header" primBits := (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19). flagBit := flag ifTrue: [ 1 ] ifFalse: [ 0 ]. "Copy the source code trailer to the end" ^trailer createMethod: numberOfBytes class: self header: (nArgs bitShift: 24) + (nTemps bitShift: 18) + (largeBit bitShift: 17) + (nLits bitShift: 9) + primBits + (flagBit bitShift: 29)! ! !CompiledMethod class methodsFor: '*Spec-Inspector' stamp: 'cb 6/25/2013 13:43'! inspectorClass ^ EyeCompiledMethodInspector! ! !CompiledMethod class methodsFor: 'class initialization' stamp: 'ajh 7/18/2001 02:04'! smallFrameSize ^ SmallFrame! ! !CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! conflictMarker ^ #traitConflict! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'MarcusDenker 6/27/2013 15:46'! cleanUp self allInstances do: [:e | e isInstalled ifFalse: [e embeddSourceInTrailer]]. "pay attention since embeddSourceInTrailer creates a new compiled method. So iterating while changing it is a bad idea. This is why we use allInstances do and not allInstancesDo:"! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'NS 12/12/2003 15:08'! newInstanceFrom: oldInstance variable: variable size: instSize map: map "Create a new instance of the receiver based on the given old instance. The supplied map contains a mapping of the old instVar names into the receiver's instVars" | new | new := self newFrom: oldInstance. 1 to: instSize do: [:offset | (map at: offset) > 0 ifTrue: [new instVarAt: offset put: (oldInstance instVarAt: (map at: offset))]]. ^new! ! !CompiledMethod class methodsFor: 'class initialization' stamp: 'di 1/11/1999 22:13'! fullFrameSize "CompiledMethod fullFrameSize" ^ LargeFrame! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'eem 9/14/2011 10:53'! new "This will not make a meaningful method, but it could be used to invoke some otherwise useful method in this class." ^self newMethod: 2 header: 1024! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'MarcusDenker 6/19/2012 10:10'! primitive: primNum numArgs: numArgs numTemps: numTemps stackSize: stackSize literals: literals bytecodes: bytecodes trailer: trailerBytes "Create method with given attributes. numTemps includes numArgs. stackSize does not include numTemps." | compiledMethod | compiledMethod := self newBytes: bytecodes size trailerBytes: trailerBytes nArgs: numArgs nTemps: numTemps nStack: 0 nLits: literals size primitive: primNum. (WriteStream with: compiledMethod) position: compiledMethod initialPC - 1; nextPutAll: bytecodes. literals withIndexDo: [:obj :i | compiledMethod literalAt: i put: obj]. compiledMethod needsFrameSize: stackSize. ^ compiledMethod! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'md 8/5/2005 17:06'! toReturnField: field trailerBytes: trailer "Answer an instance of me that is a quick return of the instance variable indexed by the argument, field." ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 264 + field ! ! !CompiledMethod class methodsFor: '*Collections-Abstract' stamp: 'CamilloBruni 2/22/2013 22:46'! sortBlock "Return a sort block that orders methods by class name and then by selector" ^ [ :a :b| a methodClass = b methodClass ifTrue: [ a selector <= b selector ] ifFalse: [ a methodClass name <= b methodClass name ]]! ! !CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! implicitRequirementMarker ^ #requirement! ! !CompiledMethodLayout commentStamp: ''! I am a special layout version for CompiledMethods. Unlike default Object layouts, CompiledMethods define a custom format integer since they mix bytes and pointer types. See CompiledMethod for more details.! !CompiledMethodLayout methodsFor: 'format' stamp: 'MartinDias 7/4/2013 12:52'! format ^ 1538 bitOr: (compactClassIndex bitShift: 11)! ! !CompiledMethodLayout class methodsFor: 'instance creation' stamp: 'MartinDias 7/11/2013 16:01'! extending: superLayout scope: aScope host: aClass ^ superLayout extendCompiledMethod host: aClass; yourself! ! !CompiledMethodTest commentStamp: ''! This is the unit test for the class CompiledMethod. 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 - there is a chapter in the PharoByExample book (http://pharobyexample.org) - the sunit class category! !CompiledMethodTest methodsFor: 'examples' stamp: 'Alexandre Bergel 5/6/2010 12:17'! deprecatedMethod self deprecated: 'example of a deprecated method'! ! !CompiledMethodTest methodsFor: 'tests - testing' stamp: 'BenComan 3/2/2014 02:40'! testIsInstalled | method cls | method := (self class)>>#returnTrue. self assert: method isInstalled. "now make an orphaned method by just deleting the class." Smalltalk removeClassNamed: #TUTU. cls := Object subclass: #TUTU instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. cls compile: 'foo ^ 10'. method := cls >> #foo. Smalltalk removeClassNamed: #TUTU. self deny: method isInstalled. ! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'sd 4/6/2009 21:27'! readX | tmp | tmp := x. ^ tmp! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'sd 4/6/2009 21:23'! writeX x := 33 ! ! !CompiledMethodTest methodsFor: 'tests - instance variable' stamp: 'MarcusDenker 8/2/2011 17:34'! testReadsField "self debug: #testReadsField" | method | method := self class compiledMethodAt: #readX. self assert: (method readsField: 3). method := self class compiledMethodAt: #readXandY. self assert: (method readsField: 4). "read is not write" method := self class compiledMethodAt: #writeX. self deny: (method readsField: 3). method := self class compiledMethodAt: #writeXandY. self deny: (method readsField: 3). method := self class compiledMethodAt: #writeXandY. self deny: (method readsField: 4)! ! !CompiledMethodTest methodsFor: 'coverage' stamp: 'nice 4/8/2011 08:55'! classToBeTested ^CompiledMethod! ! !CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'EstebanLorenzano 1/15/2013 18:37'! testOrigin | regularMethod methodFromTrait aliasedMethod | "Regular method" regularMethod := Behavior>>#name. "Method from a trait without alias " methodFromTrait := Behavior>>#addToComposition:. "Method from a trait with an alias" aliasedMethod := MOPTestClassD >>#c3. self assert: regularMethod origin == regularMethod originMethod methodClass. self assert: methodFromTrait origin == methodFromTrait originMethod methodClass. self assert: aliasedMethod origin == aliasedMethod originMethod methodClass.! ! !CompiledMethodTest methodsFor: 'tests - evaluating' stamp: 'md 4/16/2003 15:30'! testValueWithReceiverArguments | method value | method := self class compiledMethodAt: #returnTrue. value := method valueWithReceiver: nil arguments: #(). self assert: (value = true). method := self class compiledMethodAt: #returnPlusOne:. value := method valueWithReceiver: nil arguments: #(1). self assert: (value = 2). ! ! !CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'CamilloBruni 10/15/2013 01:20'! testBytecode self assertCollection: (Object>>#halt) bytecode equals: #[64 209 135 120]! ! !CompiledMethodTest methodsFor: 'tests - testing' stamp: 'MarcusDenker 4/29/2011 00:41'! testIsDeprecated | method cls | method := (self class)>>#deprecatedMethod. self assert: method isDeprecated. method := (self class)>>#deprecatedMethod2. self assert: method isDeprecated. method := (self class)>>#testIsDeprecated. self deny: method isDeprecated. ! ! !CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'BenComan 3/2/2014 02:36'! testSelector | method cls | method := (self class)>>#returnTrue. self assert: (method selector = #returnTrue). "now make an orphaned method. new semantics: return corrent name" Smalltalk removeClassNamed: #TUTU. cls := Object subclass: #TUTU instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. cls compile: 'foo ^ 10'. method := cls >> #foo. Smalltalk removeClassNamed: #TUTU. self assert: method selector = #foo. ! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'md 2/18/2006 20:09'! returnTrue ^true ! ! !CompiledMethodTest methodsFor: 'tests - instance variable' stamp: 'sd 4/6/2009 21:30'! testHasInstVarRef "self debug: #testHasInstVarRef" | method | method := self class compiledMethodAt: #readX. self assert: (method hasInstVarRef). method := self class compiledMethodAt: #readXandY. self assert: (method hasInstVarRef). method := self class compiledMethodAt: #writeX. self assert: (method hasInstVarRef). method := self class compiledMethodAt: #writeXandY. self assert: (method hasInstVarRef). ! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'md 2/18/2006 20:09'! returnPlusOne: anInteger ^anInteger + 1. ! ! !CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'LukasRenggli 5/8/2010 19:47'! testComparison | method1 method2 | method1 := Float class >> #nan. method2 := thisContext method. self assert: method1 = method1. self assert: method2 = method2. self deny: method1 = method2. self deny: method2 = method1. Object methods do: [ :each | self deny: method1 = each. self deny: each = method1. self deny: method2 = each. self deny: each = method2 ]! ! !CompiledMethodTest methodsFor: 'running' stamp: 'BenComan 3/2/2014 02:38'! categoryNameForTemporaryClasses "Answer the category where to classify temporarily created classes" ^'Dummy-Tests-Class'! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'AlexandreBergel 9/14/2011 08:27'! abstractMethod "I am an abstract method" ^ self subclassResponsibility! ! !CompiledMethodTest methodsFor: 'tests - performing' stamp: 'StephaneDucasse 12/20/2010 16:01'! testPerformInSuperclassCanExecutelongMethodWithTemps "self debug: #testPerformInSuperclassCanExecutelongMethodWithTemps" "the perform: primitive reuses the context of the method calling it. The primitive adds performed selector arguments to the context variables list. So this means that you can execute some methods but not performed them if the calling methods defined too many temps " | temp1 temp2 temp3 | temp1 := 33. temp2 := 666. temp3 := 42. self assert: (self perform: #a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: withArguments: #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) inSuperclass: self class) = 1! ! !CompiledMethodTest methodsFor: 'tests - testing' stamp: 'md 4/16/2003 15:32'! testIsQuick | method | method := self class compiledMethodAt: #returnTrue. self assert: (method isQuick). method := self class compiledMethodAt: #returnPlusOne:. self deny: (method isQuick). ! ! !CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'BenComan 3/2/2014 02:39'! testMethodClass | method cls | method := self class >> #returnTrue. self assert: method selector = #returnTrue. "now make an orphaned method by just deleting the class. old: #unknown new semantics: return Absolete class" Smalltalk removeClassNamed: #TUTU. cls := Object subclass: #TUTU instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. cls compile: 'foo ^ 10'. method := cls >> #foo. Smalltalk removeClassNamed: #TUTU. self assert: method methodClass = cls! ! !CompiledMethodTest methodsFor: 'tests - conversion' stamp: 'CamilloBruni 8/31/2013 20:23'! testCompiledMethodAsString "self debug: #testCompiledMethodAsString" thisContext method asString! ! !CompiledMethodTest methodsFor: 'tests - performing' stamp: 'StephaneDucasse 12/20/2010 16:07'! a1: a1 a2: a2 a3: a3 a4: a4 a5: a5 a6: a6 a7: a7 a8: a8 a9: a9 a10: a10 a11: a11 a12: a12 a13: a13 a14: a14 a15: a15 "I'm a method with the maximum size of arguments that can be executed via normal send but crash on perform :)" ^ a1 + a2 - a2! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'MarcusDenker 4/29/2011 00:41'! deprecatedMethod2 self deprecated: 'example of a deprecated method' on: 'date' in: 'someversion'.! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'AlexandreBergel 9/14/2011 08:27'! nonAbstractMethod "I am not an abstract method" ^ 4 + 5! ! !CompiledMethodTest methodsFor: 'tests - abstract' stamp: 'AlexandreBergel 9/14/2011 08:28'! testIsAbstract self assert: (self class >> #abstractMethod) isAbstract.. self deny: (self class >> #nonAbstractMethod) isAbstract.. self deny: (self class >> #shouldNotImplementMethod) isAbstract..! ! !CompiledMethodTest methodsFor: 'tests - performing' stamp: 'StephaneDucasse 12/20/2010 16:10'! testPerformCanExecutelongMethodWithTemps "self debug: #testPerformCanExecutelongMethodWithTemps" "the perform: primitive reuses the context of the method calling it. The primitive adds performed selector arguments to the context variables list. So this means that you can execute some methods but not performed them if the calling methods defined too many temps " | temp1 temp2 temp3 | temp1 := 33. temp2 := 666. temp3 := 42. self assert: (self perform: #a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: withArguments: #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) = 1. self assert: (self class>>#testPerformCanExecutelongMethodWithTemps) frameSize = CompiledMethod smallFrameSize. self assert: (self class>>#a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15:) frameSize = CompiledMethod fullFrameSize.! ! !CompiledMethodTest methodsFor: 'tests - comparing' stamp: 'MarcusDenker 9/5/2013 15:37'! testEqualityInstanceSideMethod | method1 method2 | method1 := TestCase compiler compile: 'aMethod'. method2 := TestCase compiler compile: 'aMethod'. self assert: (method1 literalAt: method1 numLiterals) == (method2 literalAt: method2 numLiterals). self assert: method1 = method2. ! ! !CompiledMethodTest methodsFor: 'running' stamp: 'BenComan 3/2/2014 20:37'! tearDown RPackage organizer unregisterPackageNamed: self categoryNameForTemporaryClasses.! ! !CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'BenComan 3/2/2014 02:39'! testSearchForSelector | method cls | method := self class >> #returnTrue. self assert: method searchForSelector = #returnTrue. "now make an orphaned method. we want to get nil as the selector" Smalltalk removeClassNamed: #TUTU. cls := Object subclass: #TUTU instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. cls compile: 'foo ^ 10'. method := cls >> #foo. Smalltalk removeClassNamed: #TUTU. self assert: method searchForSelector isNil! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'sd 4/6/2009 21:23'! readXandY ^ x + y ! ! !CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'BenComan 3/2/2014 02:39'! testSearchForClass | method cls | method := self class >> #returnTrue. self assert: method searchForClass = self class. "now make an orphaned method. we want to get nil as the class" Smalltalk removeClassNamed: #TUTU. cls := Object subclass: #TUTU instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. cls compile: 'foo ^ 10'. method := cls >> #foo. Smalltalk removeClassNamed: #TUTU. self assert: method searchForClass isNil! ! !CompiledMethodTest methodsFor: 'tests - comparing' stamp: 'MarianoMartinezPeck 7/25/2012 14:25'! testCopy | method copy | method := thisContext method. self assert: method pragmas notEmpty. copy := method copy. self assert: (method equivalentTo: copy). self assert: method header = copy header. self assert: method = copy. self assert: method ~~ copy. self assert: copy penultimateLiteral method == copy. self assert: method penultimateLiteral method == method. method pragmas do: [:p| self assert: p method == method]. copy pragmas do: [:p| self assert: p method == copy] ! ! !CompiledMethodTest methodsFor: 'tests - comparing' stamp: 'MarcusDenker 9/5/2013 15:34'! testEqualityClassSideMethod | method1 method2 | method1 := TestCase class compiler compile: 'aMethod'. method2 := TestCase class compiler compile: 'aMethod'. self assert: method1 = method2. ! ! !CompiledMethodTest methodsFor: 'tests - instance variable' stamp: 'MarcusDenker 8/2/2011 17:35'! testWritesField "self debug: #testWritesField" | method | method := self class compiledMethodAt: #writeX. self assert: (method writesField: 3). method := self class compiledMethodAt: #writeXandY. self assert: (method writesField: 3). method := self class compiledMethodAt: #writeXandY. self assert: (method writesField: 4). "write is not read" method := self class compiledMethodAt: #readX. self deny: (method writesField: 3). method := self class compiledMethodAt: #readXandY. self deny: (method writesField: 3). method := self class compiledMethodAt: #readXandY. self deny: (method writesField: 4).! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'sd 4/6/2009 21:23'! writeXandY x := 33. y := 66 ! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'AlexandreBergel 9/14/2011 08:28'! shouldNotImplementMethod "I am not an abstract method" ^ self shouldNotImplement! ! !CompiledMethodTest methodsFor: 'tests - comparing' stamp: 'MarcusDenker 5/2/2013 12:59'! testCopyWithTrailerBytes | method copy | method := thisContext method. self assert: method pragmas notEmpty. copy := method copyWithTrailerBytes: method trailer. self assert: (method equivalentTo: copy). self deny: method == copy. self assert: method symbolic = copy symbolic. "but their bytecode should be the same" self assert: method ~~ copy. self assert: copy penultimateLiteral method == copy. self assert: method penultimateLiteral method == method. method pragmas do: [:p| self assert: p method == method]. copy pragmas do: [:p| self assert: p method == copy] ! ! !CompiledMethodTrailer commentStamp: ''! I am responsible for encoding and decoding various kinds of compiled method trailer data. I should not expose any binary data outside of myself, so all tools which working with compiled methods should ask me to encode the meta-data, they want to be added to the compiled method trailer, as well as retrieve it. To add a new kind of trailer, you should give it a proper name and define it in the #trailerKinds method at my class side. Then you need to implement a corresponding #encode and #decode methods at instance side. Then add any public accessor methods, which will use a newly introduced trailer kind for communicating with outer layer(s). An encodeXXX methods should store result (byte array) into encodedData instance variable. A decodeXXX methods should read the data from compiled method instance, held by 'method' ivar, and always set 'size' ivar (denoting a total length of trailer in compiled method) and optionally 'data' ivar which should keep a decoded data, ready to be used by outer layer(s) using accessor method(s) you providing. The kind of compiled method trailer is determined by the last byte of compiled method. The byte format used is following: "2rkkkkkkdd" where 'k' bits stands for 'kind' , allowing totally 64 different kinds of method trailer and 'd' bits is data. Following is the list of currently defined trailer kinds: NoTrailer , k = 000000, dd unused method has no trailer, and total trailer size bytes is always 1 ClearedTrailer, k = 000001, method has cleared trailer (it was set to something else, but then cleared) dd+1 determines the number of bytes for size field, and size is a total length of trailer bytes So a total length of trailer is: 1 + (dd + 1) + size TempsNamesQCompress, k = 000010 the trailer contains a list of method temp names, compressed using qCompress: method. dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed buffer. So a total length of trailer is: 1 + (dd + 1) + size TempsNamesZip, k = 000011 the trailer contains a list of method temp names, compressed using GZIP compression method. dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed buffer So a total length of trailer is: 1 + (dd + 1) + size SourceBySelector, k = 000100 the trailer indicates , that method source is determined by a class + selector where it is installed to. Trailer size = 1. SourceByStringIdentifier, k = 000101 the trailer indicates , that method source is determined by a class + some ByteString identifier. dd+1 determines the number of bytes for size of ByteString identifier, and size is number of bytes of string. A total length of trailer is: 1 + (dd + 1) + size EmbeddedSourceQCompress, k = 000110 the trailer contains an utf-8 encoded method source code, compressed using qCompress method dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed source code A total length of trailer is: 1 + (dd + 1) + size EmbeddedSourceZip, k = 000111 the trailer contains an utf-8 encoded method source code, comressed using GZIP dd+1 determines the number of bytes for size field, and size is a number of bytes of compressed buffer A total length of trailer is: 1 + (dd + 1) + size VarLengthSourcePointer, k = 001000 the trailer is variable-length encoded source pointer. dd bits is unused. ExtendedKind, k = 001001 the next byte of trailer (one that prepends the last byte of compiled method) denotes an extended kind of trailer, allowing to use additional 256 kinds of encoding method's trailer in future. SourcePointer, k = 111111 the trailer is encoded source pointer. Total trailer size is 4-bytes (this kind of encoding is backwards compatible with most of existing compiled methods) ! !CompiledMethodTrailer methodsFor: 'decoding' stamp: 'Igor.Stasenko 12/20/2009 21:36'! decodeSourceByStringIdentifier "A method source is determined by a class + string identifier" | len | len := self decodeLengthField. data := (ReadStream on: method from: method size - size+1 to: method size - size + len) contents asString convertFromEncoding: 'utf8'! ! !CompiledMethodTrailer methodsFor: 'private' stamp: 'jannik.laval 5/1/2010 17:00'! encodeLengthField: integer | bytes value | [integer > 0] assert. value := integer. bytes := ByteArray streamContents: [:str | [ value > 0 ] whileTrue: [ str nextPut: (value bitAnd: 255). value := value >> 8 ]]. "no more than 4 bytes for length field" [bytes size <=4] assert. ^ bytes! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/9/2010 00:28'! sourcePointer kind == #NativeCodeTrailer ifTrue: [ ^ data at: 3]. ^ (kind == #SourcePointer or: [ kind == #VarLengthSourcePointer ] ) ifTrue: [ data ] ifFalse: [ 0 ] ! ! !CompiledMethodTrailer methodsFor: '*Compression-Streams' stamp: 'StephaneDucasse 2/3/2010 22:11'! decodeZip "data := unzip utf8ToSqueak" | len bytes | len := self decodeLengthField. bytes := ByteArray new: len. 1 to: len do: [ :i | bytes at: i put: (method at: method size - size + i) ]. data := (ZipReadStream on: bytes) contents asString convertFromEncoding: 'utf8'! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/13/2009 15:50'! endPC "Answer the index of the last bytecode." method ifNil: [ self error: 'Cannot determine the endPC without compiled method' ]. "if method set, then size should be set as well" ^ method size - size! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/5/2010 13:49'! platformId kind = #NativeCodeTrailer ifFalse: [ ^ nil ]. ^ data at: 1 ! ! !CompiledMethodTrailer methodsFor: 'initialization' stamp: 'Igor.Stasenko 12/13/2009 11:51'! initialize self clear! ! !CompiledMethodTrailer methodsFor: 'decoding' stamp: 'Igor.Stasenko 12/13/2009 11:25'! decodeSourcePointer "Trailer is a source pointer" | msz | size := 4. msz := method size. data := (method at: msz) - 251 << 8 + (method at: msz-1) << 8 + (method at: msz-2) << 8 + (method at: msz-3). ! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/9/2010 00:29'! nativeCode: aByteArray platformId: aPlatformCode sourcePointer: srcPtr "Embed the native code into compiled method trailer. The resulting trailer format is following: " self clear. kind := #NativeCodeTrailer. data := Array with: aPlatformCode with: aByteArray with: srcPtr. self encode. ! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/13/2009 19:15'! kind "Answer a symbolic name of trailer kind. See #trailerKinds on class side and class comment for details" ^ kind! ! !CompiledMethodTrailer methodsFor: '*Compression-Streams' stamp: 'jannik.laval 5/1/2010 16:05'! encodeUsingZip "data is string, encode it using gzip compression" | utf8str stream length encodedLength | [data isString] assert. utf8str := data convertToEncoding: 'utf8'. stream := ((ZipWriteStream on: (ByteArray new: utf8str size)) nextPutAll: utf8str asByteArray; close; encodedStream). length := stream position. encodedLength := self encodeLengthField: length. stream nextPutAll: encodedLength. "trailing byte" stream nextPut: (self kindAsByte + encodedLength size - 1). encodedData := stream contents ! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/13/2009 21:03'! sourceIdentifier "Trailer is used to indicate that method's source code can be retrieved by sending #getSourceCodeByIdentifier: message to method's class" ^ (kind == #SourceByStringIdentifier) ifTrue: [ data ] ifFalse: [ nil ]. ! ! !CompiledMethodTrailer methodsFor: 'testing' stamp: 'Igor.Stasenko 12/13/2009 16:54'! isEmpty ^ kind == #NoTrailer or: [ kind == #ClearedTrailer ]! ! !CompiledMethodTrailer methodsFor: 'decoding' stamp: 'Igor.Stasenko 12/13/2009 15:31'! decodeClearedTrailer "Size is set in #decodeLengthField" self decodeLengthField. ! ! !CompiledMethodTrailer methodsFor: 'decoding' stamp: 'Igor.Stasenko 12/13/2009 11:56'! decodeNoTrailer "Not much to decode here" size := 1. ! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'StephaneDucasse 2/3/2010 22:12'! encodeSourcePointer encodedData := ByteArray new: 4. encodedData at: 4 put: (data >> 24) + 251. 1 to: 3 do: [:i | encodedData at: 4-i put: ((data bitShift: (i-3)*8) bitAnd: 16rFF)]! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'Igor.Stasenko 12/13/2009 15:16'! encodeClearedTrailer "A cleared trailer is replaced by #NoTrailer, when used for encoding" self clear. kind := #NoTrailer. ^ self encode! ! !CompiledMethodTrailer methodsFor: 'private' stamp: 'jannik.laval 5/1/2010 16:07'! kindAsByte | index | index := self class trailerKinds indexOf: kind. [index ~~ 0] assert. ^ (index - 1) << 2! ! !CompiledMethodTrailer methodsFor: 'testing' stamp: 'Igor.Stasenko 4/11/2010 13:15'! hasSourcePointer ^ kind == #SourcePointer or: [ kind == #VarLengthSourcePointer or: [ kind == #NativeCodeTrailer ] ] ! ! !CompiledMethodTrailer methodsFor: 'decoding' stamp: 'Igor.Stasenko 12/13/2009 15:57'! decodeEmbeddedSourceQCompress "data is string with method's source code, encoded using qCompress method" self qDecompress.! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'Igor.Stasenko 12/13/2009 14:38'! encodeUndefined self error: 'use of an undefined kind of trailer encoding'! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/13/2009 21:03'! sourceIdentifier: aString "Trailer is used to indicate that method's source code can be retrieved by sending #getSourceCodeByIdentifier: message to method's class" self clear. data := aString. kind := #SourceByStringIdentifier. self encode. ! ! !CompiledMethodTrailer methodsFor: '*Compression-Streams' stamp: 'Igor.Stasenko 12/13/2009 16:33'! decodeEmbeddedSourceZip "data is string with method's source code, compressed using zip compression" self decodeZip.! ! !CompiledMethodTrailer methodsFor: 'initialize-release' stamp: 'CamilloBruni 3/4/2013 17:29'! method: aMethod | flagByte | data := size := nil. method := aMethod. flagByte := method at: (method size). "trailer kind encoded in 6 high bits of last byte" kind := self class trailerKinds at: 1+(flagByte>>2). "decode the trailer bytes, inline some common types to speed up decoding" kind = 'SourcePointer' ifTrue: [ self decodeSourcePointer ] ifFalse: [ kind = 'VarLengthSourcePointer' ifTrue: [ self decodeVarLengthSourcePointer ] ifFalse: [ kind = 'NoTrailer' ifTrue: [ self decodeNoTrailer ] ifFalse: [ "slow but general decoding using perform" self perform: ('decode' , kind) asSymbol ]]]. "after decoding the trailer, size must be set" [size notNil] assert. ! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'StephaneDucasse 2/3/2010 22:12'! encodeSourceBySelector "A method source is determined by a class + selector where it is installed to" encodedData := ByteArray with: self kindAsByte! ! !CompiledMethodTrailer methodsFor: '*Compression-Streams' stamp: 'Igor.Stasenko 12/13/2009 14:29'! encodeEmbeddedSourceZip "data is string with method's source code, encode it using Zip compression method" self encodeUsingZip ! ! !CompiledMethodTrailer methodsFor: 'decoding' stamp: 'Igor.Stasenko 12/20/2009 21:33'! qDecompress "Trailer is compressed string using qCompress method + length field + 1 byte Decompress strings compressed by qCompress:. Most common 11 chars get values 0-10 packed in one 4-bit nibble; next most common 52 get values 12-15 (2 bits) * 16 plus next nibble; escaped chars get three nibbles" | len str input | len := self decodeLengthField. input := (ReadStream on: method from: method size - size+1 to: method size - size + len). str := String streamContents: [:strm | | nextNibble nibble peek charTable | charTable := "Character encoding table must match qCompress:" 'ear tonsilcmbdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345[]()'. peek := true. nextNibble := [peek ifTrue: [peek := false. input peek ifNil: [0] ifNotNil: [:b| b // 16]] ifFalse: [peek := true. input next ifNil: [0] ifNotNil: [:b| b \\ 16]]]. [input atEnd] whileFalse: [(nibble := nextNibble value) = 0 ifTrue: [input atEnd ifFalse: [strm nextPut: (Character value: nextNibble value * 16 + nextNibble value)]] ifFalse: [nibble <= 11 ifTrue: [strm nextPut: (charTable at: nibble)] ifFalse: [strm nextPut: (charTable at: nibble-12 * 16 + nextNibble value)]]]]. data := str convertFromEncoding: 'utf8'! ! !CompiledMethodTrailer methodsFor: 'creating a method' stamp: 'IgorStasenko 5/24/2010 21:35'! createMethod: numberOfBytesForAllButTrailer header: headerWord methodClass: aCompiledMethodClass | meth | encodedData ifNil: [ self encode ]. meth := aCompiledMethodClass newMethod: numberOfBytesForAllButTrailer + size header: headerWord. "copy the encoded trailer data" 1 to: size do: [:i | meth at: meth size - size + i put: (encodedData at: i)]. ^ meth! ! !CompiledMethodTrailer methodsFor: 'testing' stamp: 'MarcusDenker 4/29/2012 09:51'! hasSource ^ kind == #EmbeddedSourceQCompress or: [ kind == #EmbeddedSourceZip ]! ! !CompiledMethodTrailer methodsFor: 'decoding' stamp: 'Igor.Stasenko 4/9/2010 00:27'! decodeNativeCodeTrailer | bytes platformId msz pos shift srcPtr | msz := method size. platformId := (method at: msz - 1) + ((method at: msz - 2)<<8). size := (method at: msz - 3) + ((method at: msz - 4)<<8). pos := method size-5. shift := srcPtr := 0. [ | value | value := method at: pos. srcPtr := (value bitAnd: 16r7F) << shift + srcPtr. pos := pos - 1. shift := shift + 7. value > 127 ] whileTrue. bytes := ByteArray new: size - (msz - pos). 1 to: bytes size do: [:i | bytes at: i put: (method at: msz-size+i) ]. data := Array with: platformId with: bytes with: srcPtr. ! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'jannik.laval 5/1/2010 16:05'! encodeSourceByStringIdentifier "A method source is determined by a class + string identifier" [data isString] assert. encodedData := ByteArray streamContents: [:str | | utf8str len | utf8str := (data convertToEncoding: 'utf8') asByteArray. str nextPutAll: utf8str. len := self encodeLengthField: utf8str size. str nextPutAll: len. str nextPut: self kindAsByte + (len size -1)]! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'IgorStasenko 5/10/2011 13:21'! encodeVarLengthSourcePointer "source pointer must be >=0" [data >= 0] assert. encodedData := data = 0 ifTrue: [ #[0] ] ifFalse: [ ByteArray streamContents: [:str | | value | value := data. [value > 0] whileTrue: [ value > 127 ifTrue: [ str nextPut: 128 + (value bitAnd: 16r7F) ] ifFalse: [ str nextPut: value. ]. value := value >> 7. ]. ]]. encodedData := encodedData reversed copyWith: (self kindAsByte)! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'Igor.Stasenko 12/13/2009 14:29'! encodeEmbeddedSourceQCompress "data is string with method's source code, encode it using qCompress method" self encodeUsingQCompress ! ! !CompiledMethodTrailer methodsFor: 'decoding' stamp: 'Igor.Stasenko 12/13/2009 16:35'! decodeSourceBySelector "no data, size = 1" size := 1.! ! !CompiledMethodTrailer methodsFor: 'decoding' stamp: 'Igor.Stasenko 12/13/2009 16:34'! decodeUndefined self error: 'undefined method encoding'! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/13/2009 21:47'! sourceCode "Answer the source code of compiled method. Note: it does not attempts to read from source files using sourcePointer, nor reconstruct the source code using temp names" (kind == #EmbeddedSourceQCompress or: [ kind == #EmbeddedSourceZip ]) ifTrue: [ ^ data ]. kind == #SourceBySelector ifTrue: [ ^ method methodClass getSourceCodeBySelector: method selector ]. kind == #SourceByStringIdentifier ifTrue: [ ^ method methodClass getSourceCodeByIdentifier: data ]. ^ nil! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'jannik.laval 5/1/2010 16:05'! encodeUsingQCompress "data is string, encode it using qCompress method" | str length encodedLength | [data isString] assert. str := self qCompress: data. length := str position. encodedLength := self encodeLengthField: length. str nextPutAll: encodedLength. "trailing byte" str nextPut: (self kindAsByte + encodedLength size - 1). encodedData := str contents ! ! !CompiledMethodTrailer methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 12/13/2009 11:38'! clear kind := #NoTrailer. size := 1. data := encodedData := method := nil! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/13/2009 16:45'! size "Answer the size of method's trailer , in bytes" ^ size! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'jannik.laval 5/1/2010 16:04'! encode encodedData := nil. "encode the trailer into byte array" self perform: ('encode' , kind) asSymbol. [encodedData notNil and: [encodedData size > 0 ]] assert. "set the size" size := encodedData size.! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'Igor.Stasenko 12/13/2009 15:02'! encodeExtendedKind "reserved for future use" self error: 'Not yet implemented'. ! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/22/2009 22:23'! sourceCode: aString "Embed the source code into compiled method trailer, pick best compression method" | temp | self clear. kind := #EmbeddedSourceQCompress. data := aString asString. "add Text support in future?" self encode. temp := encodedData. kind := #EmbeddedSourceZip. self encode. encodedData size > temp size ifTrue: [ encodedData := temp. kind := #EmbeddedSourceQCompress. size := encodedData size. ]! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'Igor.Stasenko 4/9/2010 00:22'! encodeNativeCodeTrailer " encode trailer in a form: " | bytes platformId sourcePointer ptrBytes | platformId := data at: 1. bytes := data at: 2. sourcePointer := data at: 3. ptrBytes := ByteArray streamContents: [:str | | value | value := sourcePointer. [value > 0] whileTrue: [ value > 127 ifTrue: [ str nextPut: 128 + (value bitAnd: 16r7F) ] ifFalse: [ str nextPut: value. ]. value := value >> 7. ]. ]. ptrBytes := ptrBytes reversed. size := bytes size + ptrBytes size + 2 + 2 + 1. self assert: (size < 65536). self assert: (platformId < 65536). encodedData := ByteArray streamContents: [:str | str nextPutAll: bytes; nextPutAll: ptrBytes; nextPut: (size >> 8); nextPut: (size bitAnd: 255); nextPut: (platformId >> 8); nextPut: (platformId bitAnd: 255); nextPut: self kindAsByte ]. ! ! !CompiledMethodTrailer methodsFor: 'private' stamp: 'nice 1/5/2010 15:59'! qCompress: string "A very simple text compression routine designed for method temp names. Most common 11 chars get values 1-11 packed in one 4-bit nibble; the next most common get values 12-15 (2 bits) * 16 plus next nibble; unusual ones get three nibbles, the first being the escape nibble 0. Answer the write stream with compressed data inside" | utf8str stream oddNibble | string isEmpty ifTrue: [^self qCompress: ' ']. utf8str := string convertToEncoding: 'utf8'. stream := WriteStream on: (ByteArray new: utf8str size). oddNibble := nil. utf8str do: [:char | | ix | ix := 'ear tonsilcmbdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345[]()' indexOf: char ifAbsent: 0. (ix = 0 ifTrue: [{ 0. char asInteger // 16. char asInteger \\ 16 }] ifFalse: [ix <= 11 ifTrue: [{ ix }] ifFalse: [{ ix//16+12. ix\\16 }]]) do: [:nibble | oddNibble ifNotNil: [stream nextPut: oddNibble*16 + nibble. oddNibble := nil] ifNil: [oddNibble := nibble]]]. oddNibble ifNotNil: "4 = 'ear tonsil' indexOf: Character space" [stream nextPut: oddNibble * 16 + 4]. ^ stream ! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/13/2009 21:49'! setSourceBySelector "Trailer is used to indicate that method's source code can be retrieved by sending #getSourceCodeBySelector: message to method's class" self clear. kind := #SourceBySelector! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/13/2009 11:39'! sourcePointer: ptr self clear. data := ptr. "see if we can encode pointer using 4-byte trailer" kind := (ptr between: 16r1000000 and: 16r4FFFFFF) ifTrue: [ #SourcePointer ] ifFalse: [ #VarLengthSourcePointer ]. ! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'Igor.Stasenko 12/13/2009 11:55'! encodeNoTrailer encodedData := ByteArray with: self kindAsByte! ! !CompiledMethodTrailer methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/5/2010 13:48'! nativeCode kind = #NativeCodeTrailer ifFalse: [ ^ nil ]. ^ data at: 2 ! ! !CompiledMethodTrailer methodsFor: 'testing' stamp: 'Igor.Stasenko 12/13/2009 20:12'! testEncoding "Since we are using basic protocol (#at:, #at:put: , #size) for accessing compiled method data, we can pass the ByteArray instance into #method: accessor and check if encoding/decoding operations is symmetrical. Use this method only for unit-testing purposes" encodedData ifNil: [ self encode ]. ^ CompiledMethodTrailer new method: encodedData! ! !CompiledMethodTrailer methodsFor: 'decoding' stamp: 'Igor.Stasenko 12/13/2009 19:34'! decodeVarLengthSourcePointer | pos shift | pos := method size-1. shift := data := 0. [ | value | value := method at: pos. data := (value bitAnd: 16r7F) << shift + data. pos := pos - 1. shift := shift + 7. value > 127 ] whileTrue. size := method size - pos.! ! !CompiledMethodTrailer methodsFor: 'creating a method' stamp: 'eem 9/13/2011 15:14'! createMethod: numberOfBytesForAllButTrailer class: aCompiledMethodClass header: headerWord | meth | encodedData ifNil: [self encode]. meth := aCompiledMethodClass newMethod: numberOfBytesForAllButTrailer + size header: headerWord. "copy the encoded trailer data" 1 to: size do: [:i | meth at: meth size - size + i put: (encodedData at: i)]. ^meth! ! !CompiledMethodTrailer methodsFor: 'private' stamp: 'Igor.Stasenko 12/13/2009 15:29'! decodeLengthField "used in various encodings, where length field is preceeding the last trailer byte. Two least significant bits in last byte denoting the number of bytes for length field" | numBytes pos length | pos := method size. numBytes := ((method at: pos) bitAnd: 3) + 1. length := 0. 1 to: numBytes do: [:i | length := length << 8 + (method at: pos - i ). ]. size := 1 + numBytes + length. ^ length! ! !CompiledMethodTrailer methodsFor: 'encoding' stamp: 'Igor.Stasenko 12/13/2009 14:30'! decodeExtendedKind "reserved for future use" self shouldBeImplemented. ! ! !CompiledMethodTrailer class methodsFor: 'generated' stamp: 'Igor.Stasenko 4/5/2010 13:15'! trailerKindDecoders ^#(#decodeNoTrailer #decodeClearedTrailer #decodeTempsNamesQCompress #decodeTempsNamesZip #decodeSourceBySelector #decodeSourceByStringIdentifier #decodeEmbeddedSourceQCompress #decodeEmbeddedSourceZip #decodeVarLengthSourcePointer #decodeExtendedKind #decodeNativeCodeTrailer #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeUndefined #decodeSourcePointer)! ! !CompiledMethodTrailer class methodsFor: 'kinds' stamp: 'Igor.Stasenko 4/5/2010 13:15'! trailerKinds " see class comment for description. If you change this method, evaluate this: self generateTrailerKindDecoders" ^#( "000000" #NoTrailer "000001" #ClearedTrailer "000010" #TempsNamesQCompress "000011" #TempsNamesZip "000100" #SourceBySelector "000101" #SourceByStringIdentifier "000110" #EmbeddedSourceQCompress "000111" #EmbeddedSourceZip "001000" #VarLengthSourcePointer "001001" #ExtendedKind "001010" #NativeCodeTrailer "this number is hardcoded in VM" "001011" #Undefined "001100" #Undefined "001101" #Undefined "001110" #Undefined "001111" #Undefined "010000" #Undefined "010001" #Undefined "010010" #Undefined "010011" #Undefined "010100" #Undefined "010101" #Undefined "010110" #Undefined "010111" #Undefined "011000" #Undefined "011001" #Undefined "011010" #Undefined "011011" #Undefined "011100" #Undefined "011101" #Undefined "011110" #Undefined "011111" #Undefined "100000" #Undefined "100001" #Undefined "100010" #Undefined "100011" #Undefined "100100" #Undefined "100101" #Undefined "100110" #Undefined "100111" #Undefined "101000" #Undefined "101001" #Undefined "101010" #Undefined "101011" #Undefined "101100" #Undefined "101101" #Undefined "101110" #Undefined "101111" #Undefined "110000" #Undefined "110001" #Undefined "110010" #Undefined "110011" #Undefined "110100" #Undefined "110101" #Undefined "110110" #Undefined "110111" #Undefined "111000" #Undefined "111001" #Undefined "111010" #Undefined "111011" #Undefined "111100" #Undefined "111101" #Undefined "111110" #Undefined "111111" #SourcePointer )! ! !CompiledMethodTrailer class methodsFor: 'kinds' stamp: 'Igor.Stasenko 12/14/2009 10:08'! empty "answer the empty trailer" ^ self new! ! !CompiledMethodTrailerTest commentStamp: 'TorstenBergmann 2/5/2014 08:32'! SUnit tests for CompiledMethodTrailer! !CompiledMethodTrailerTest methodsFor: 'tests' stamp: 'Igor.Stasenko 12/13/2009 21:13'! testEmbeddingSourceCode | trailer newTrailer code | trailer := CompiledMethodTrailer new. code := 'foo'. trailer sourceCode: code. newTrailer := trailer testEncoding. self assert: (trailer kind == #EmbeddedSourceQCompress ). self assert: (newTrailer sourceCode = code). "the last bytecode index must be at 0" self assert: (newTrailer endPC = 0). code := 'testEmbeddingSourceCode | trailer newTrailer code | trailer := CompiledMethodTrailer new. trailer sourceCode: code. newTrailer := trailer testEncoding. self assert: (newTrailer sourceCode = code).'. trailer sourceCode: code. self assert: (trailer kind == #EmbeddedSourceZip ). newTrailer := trailer testEncoding. self assert: (newTrailer sourceCode = code). "the last bytecode index must be at 0" self assert: (newTrailer endPC = 0). ! ! !CompiledMethodTrailerTest methodsFor: 'tests' stamp: 'Igor.Stasenko 12/13/2009 21:17'! testEncodingNoTrailer | trailer | trailer := CompiledMethodTrailer new. "by default it should be a no-trailer" self assert: (trailer kind == #NoTrailer ). self assert: (trailer size = 1). trailer := trailer testEncoding. self assert: (trailer kind == #NoTrailer ). self assert: (trailer size = 1). "the last bytecode index must be at 0" self assert: (trailer endPC = 0). ! ! !CompiledMethodTrailerTest methodsFor: 'tests' stamp: 'Igor.Stasenko 12/13/2009 21:49'! testSourceBySelectorEncoding | trailer | trailer := CompiledMethodTrailer new. trailer setSourceBySelector. self assert: (trailer kind == #SourceBySelector ). self assert: (trailer size = 1). trailer := trailer testEncoding. self assert: (trailer kind == #SourceBySelector ). self assert: (trailer size = 1). "the last bytecode index must be at 0" self assert: (trailer endPC = 0). ! ! !CompiledMethodTrailerTest methodsFor: 'tests' stamp: 'Igor.Stasenko 12/13/2009 21:14'! testEncodingSourcePointer | trailer | trailer := CompiledMethodTrailer new. CompiledMethod allInstancesDo: [:method | | ptr | trailer method: method. self assert: ( (ptr := method sourcePointer) == trailer sourcePointer). "the last bytecode index must be at 0" ptr ~= 0 ifTrue: [ self assert: (method endPC = trailer endPC) ]. ].! ! !CompiledMethodTrailerTest methodsFor: 'tests' stamp: 'IgorStasenko 5/10/2011 13:33'! testEncodingZeroSourcePointer | trailer | trailer := CompiledMethodTrailer new. self assert: (trailer sourcePointer: 0) testEncoding sourcePointer = 0 ! ! !CompiledMethodTrailerTest methodsFor: 'tests' stamp: 'PavelKrivanek 11/24/2011 11:30'! testSourceByIdentifierEncoding | trailer id | trailer := CompiledMethodTrailer new. id := 'e51b3b55-d5aa-48fa-a008-e674dbdd4abe'. trailer sourceIdentifier: id. self assert: (trailer kind == #SourceByStringIdentifier ). trailer := trailer testEncoding. self assert: (trailer kind == #SourceByStringIdentifier ). self assert: (trailer sourceIdentifier = id). "the last bytecode index must be at 0" self assert: (trailer endPC = 0). ! ! !CompiledMethodTrailerTest methodsFor: 'tests' stamp: 'Igor.Stasenko 12/13/2009 21:15'! testEncodingVarLengthSourcePointer | trailer newTrailer | trailer := CompiledMethodTrailer new. trailer sourcePointer: 1. newTrailer := trailer testEncoding. self assert: (newTrailer sourcePointer = 1). trailer sourcePointer: 16r100000000000000. newTrailer := trailer testEncoding. self assert: (newTrailer sourcePointer = 16r100000000000000). "the last bytecode index must be at 0" self assert: (newTrailer endPC = 0). ! ! !Compiler commentStamp: ''! The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor (usually a kind of StringHolderController) is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode.! !Compiler methodsFor: 'public access' stamp: 'ClementBera 6/7/2013 10:24'! translate "once we will have change all the sender of MethodNode>>#generate: to use compile, we can remove the methodNode encoder requestor: requestor." | methodNode | methodNode := self parser parse: sourceStream class: class category: category noPattern: self compilationContext noPattern context: context notifying: requestor ifFail: [^ self compilationContext failBlock value]. methodNode encoder requestor: requestor. ^ methodNode! ! !Compiler methodsFor: 'error handling' stamp: 'CamilloBruni 2/9/2012 12:07'! notify: aString at: location "Refer to the comment in Object|notify:." ^requestor == nil ifTrue: [SyntaxErrorNotification inClass: class category: category withCode: sourceStream contents doitFlag: false errorMessage: aString location: location] ifFalse: [requestor notify: aString at: location in: sourceStream]! ! !Compiler methodsFor: 'public - old' stamp: 'MarcusDenker 5/10/2013 12:53'! format: textOrStream in: aClass notifying: aRequestor "Compile a parse tree from the argument, textOrStream. Answer a string containing the original code, formatted nicely. If aBoolean is true, then decorate the resulting text with color and hypertext actions" | aNode | self from: textOrStream class: aClass context: nil notifying: aRequestor. aNode := self format: sourceStream noPattern: false ifFail: [^ nil]. ^ aNode formattedCode.! ! !Compiler methodsFor: 'public access' stamp: 'ClementBera 6/7/2013 10:56'! compile | methodNode | methodNode := self compile: sourceStream in: class classified: category notifying: requestor ifFail: self compilationContext failBlock. ^ methodNode generate: self compilationContext compiledMethodTrailer ! ! !Compiler methodsFor: 'public - old' stamp: 'MarcusDenker 4/30/2013 10:37'! evaluate: textOrString notifying: aController logged: logFlag "See Compiler|evaluate:for:notifying:logged:. Compilation is carried out with respect to nil, i.e., no object." ^self evaluate: textOrString for: nil notifying: aController logged: logFlag! ! !Compiler methodsFor: 'private' stamp: 'marcus.denker 8/17/2008 21:14'! from: textOrStream class: aClass classified: aCategory context: aContext notifying: req self from: textOrStream class: aClass context: aContext notifying: req. category := aCategory ! ! !Compiler methodsFor: '*Deprecated30' stamp: 'MarcusDenker 5/9/2013 11:07'! decompile: aSelector in: aClass method: aMethod self deprecated: 'use #decompileMethod:' on: '09 May 2013' in: 'Pharo 3.0'. ^Decompiler new decompile: aSelector in: aClass method: aMethod ! ! !Compiler methodsFor: 'public access' stamp: 'ClementBera 5/22/2013 16:04'! options: anArray "This is used for compatibility with Opal" self compilationContext compilerOptions: anArray! ! !Compiler methodsFor: 'public access' stamp: 'ClementBera 6/7/2013 11:11'! evaluate: textOrString "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor. Compilation is carried out with respect to nil, i.e., no object, and the invocation is not logged." ^self evaluate: textOrString in: context to: receiver notifying: requestor ifFail: self compilationContext failBlock logged: self compilationContext logged! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'ClementBera 5/22/2013 16:04'! environment: anEnvironment "This is used for compatibility with Opal" self compilationContext environment: anEnvironment! ! !Compiler methodsFor: 'public - old' stamp: 'ClementBera 6/28/2013 10:32'! evaluate: textOrStream in: aContext to: aReceiver notifying: aRequestor ifFail: failBlock ^ self evaluate: textOrStream in: aContext to: aReceiver notifying: aRequestor ifFail: failBlock logged: false.! ! !Compiler methodsFor: 'private' stamp: 'eem 5/15/2008 15:11'! translate: aStream noPattern: noPattern ifFail: failBlock ^self parser parse: aStream class: class category: category noPattern: noPattern context: context notifying: requestor ifFail: [^failBlock value]! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'ClementBera 6/7/2013 10:04'! requestor: aRequestor requestor := aRequestor. self compilationContext requestor: aRequestor. self compilationContext interactive: (UIManager default interactiveParserFor: self compilationContext requestor).! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'MarcusDenker 5/26/2013 09:42'! compilationContextClass: aClass compilationContextClass := aClass! ! !Compiler methodsFor: 'private' stamp: 'MarcusDenker 4/27/2013 08:48'! from: textOrStream class: aClass context: aContext notifying: req sourceStream := textOrStream readStream. class := aClass. context := aContext. requestor := req! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'ClementBera 6/7/2013 10:14'! noPattern: aBoolean self compilationContext noPattern: aBoolean. ! ! !Compiler methodsFor: 'error handling' stamp: ''! notify: aString "Refer to the comment in Object|notify:." ^self notify: aString at: sourceStream position + 1! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'ClementBera 6/7/2013 10:16'! receiver: anObject receiver := anObject! ! !Compiler methodsFor: 'public access' stamp: 'MarcusDenker 8/28/2013 15:31'! parse: aString ^self parse: aString class: class! ! !Compiler methodsFor: 'public - old' stamp: 'MarcusDenker 4/30/2013 10:35'! evaluate: textOrString for: anObject notifying: aController logged: logFlag "Compile and execute the argument, textOrString with respect to the class of anObject. If a compilation error occurs, notify aController. If both compilation and execution are successful then, if logFlag is true, log (write) the text onto a system changes file so that it can be replayed if necessary." ^ self evaluate: textOrString in: nil to: anObject notifying: aController ifFail: [^nil] logged: logFlag.! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'MarcusDenker 5/26/2013 09:36'! compilationContextClass ^ compilationContextClass ifNil: [ CCompilationContext ]! ! !Compiler methodsFor: 'public access' stamp: 'ClementBera 6/7/2013 10:25'! format ^ self format: sourceStream in: class notifying: requestor! ! !Compiler methodsFor: 'public access' stamp: 'MarcusDenker 4/28/2013 11:04'! parseSelector: aString "Answer the message selector for the argument, aString, which should parse successfully up to the temporary declaration or the end of the method header." ^self parser parseSelector: aString! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'ClementBera 6/7/2013 10:04'! category: aCategory category := aCategory. self compilationContext category: aCategory.! ! !Compiler methodsFor: 'public - old' stamp: 'CamilloBruni 8/1/2012 16:05'! evaluate: aString in: aContext to: aReceiver "evaluate aString in the given context, and return the result." | result | result := self evaluate: aString in: aContext to: aReceiver notifying: nil ifFail: [^ #failedDoit]. ^ result! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'ClementBera 6/7/2013 09:58'! compiledMethodTrailer: bytes self compilationContext compiledMethodTrailer: bytes! ! !Compiler methodsFor: 'public - decompiler' stamp: 'MarcusDenker 5/1/2013 12:06'! decompileMethod: aCompiledMethod ^Decompiler new decompileMethod: aCompiledMethod ! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'ClementBera 6/7/2013 10:15'! logged: aBoolean self compilationContext logged: aBoolean.! ! !Compiler methodsFor: 'public - old' stamp: 'vb 8/13/2001 23:11'! compileNoPattern: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock "Similar to #compile:in:notifying:ifFail:, but the compiled code is expected to be a do-it expression, with no message pattern." self from: textOrStream class: aClass context: aContext notifying: aRequestor. ^self translate: sourceStream noPattern: true ifFail: failBlock! ! !Compiler methodsFor: 'public - old' stamp: 'MarcusDenker 4/30/2013 10:36'! evaluate: textOrString logged: logFlag "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor. Compilation is carried out with respect to nil, i.e., no object." ^self evaluate: textOrString for: nil logged: logFlag! ! !Compiler methodsFor: 'public - old' stamp: 'MarcusDenker 4/28/2013 21:50'! parse: aString class: aClass ^self parser parse: aString class: aClass! ! !Compiler methodsFor: 'private' stamp: 'ClementBera 6/7/2013 10:54'! parser ^ parser ifNil: [parser := Parser new]! ! !Compiler methodsFor: '*Deprecated30' stamp: 'ClementBera 6/7/2013 09:50'! decompile: aSelector in: aClass self deprecated: 'use #decompileMethod:' on: '09 May 2013' in: 'Pharo 3.0'. ^Decompiler new decompile: aSelector in: aClass! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'ClementBera 6/7/2013 10:05'! failBlock: aBlock self compilationContext failBlock: aBlock.! ! !Compiler methodsFor: 'public - old' stamp: 'md 2/28/2006 10:45'! compile: textOrStream in: aClass notifying: aRequestor ifFail: failBlock ^self compile: textOrStream in: aClass classified: nil notifying: aRequestor ifFail: failBlock ! ! !Compiler methodsFor: 'public access' stamp: 'ClementBera 6/7/2013 10:50'! parse ^self parse: sourceStream class: class! ! !Compiler methodsFor: 'public - old' stamp: 'eem 5/15/2008 15:11'! parse: textOrStream in: aClass notifying: req "Compile the argument, textOrStream, with respect to the class, aClass, and answer the MethodNode that is the root of the resulting parse tree. Notify the argument, req, if an error occurs. The failBlock is defaulted to an empty block." self from: textOrStream class: aClass context: nil notifying: req. ^self parser parse: sourceStream class: class noPattern: false context: context notifying: requestor ifFail: []! ! !Compiler methodsFor: 'public - old' stamp: 'MarcusDenker 4/28/2013 21:50'! parse: aString class: aClass noPattern: noPattern context: ctxt notifying: req ifFail: aBlock ^self parser parse: aString class: aClass noPattern: noPattern context: ctxt notifying: req ifFail: aBlock ! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'ClementBera 6/7/2013 10:15'! context: aContext context := aContext! ! !Compiler methodsFor: 'public access' stamp: 'MarcusDenker 5/17/2013 10:44'! parseLiterals: aString ^ Scanner new scanTokens: aString! ! !Compiler methodsFor: 'public - old' stamp: 'ClementBera 6/28/2013 10:32'! evaluate: textOrStream in: aContext to: aReceiver notifying: aRequestor ifFail: failBlock logged: logFlag "Compiles the sourceStream into a parse tree, then generates code into a method. If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is invoked from here via withArgs:executeMethod:, hence the system no longer creates Doit method litter on errors." | methodNode method value toLog itsSelection itsSelectionString | class := aContext == nil ifTrue: [aReceiver class ] ifFalse: [aContext method methodClass]. self from: textOrStream class: class context: aContext notifying: aRequestor. methodNode := self translate: sourceStream noPattern: true ifFail: [^failBlock value]. method := self interactive ifTrue: [methodNode generateWithSource] ifFalse: [methodNode generate]. value := aReceiver withArgs: (context ifNil: [#()] ifNotNil: [{context}]) executeMethod: method. logFlag ifTrue: [toLog := ((requestor respondsTo: #selection) and:[(itsSelection := requestor selection) notNil and:[(itsSelectionString := itsSelection asString) isEmptyOrNil not]]) ifTrue:[itsSelectionString] ifFalse:[sourceStream contents]. SystemAnnouncer uniqueInstance evaluated: toLog context: aContext]. ^ value! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'MarcusDenker 5/26/2013 09:37'! compilationContext ^ compilationContext ifNil: [ compilationContext := self compilationContextClass default requestor: requestor; class: class; category: category ] ! ! !Compiler methodsFor: 'public access' stamp: 'MarcusDenker 8/28/2013 15:31'! format: aString ^ self format: aString in: class notifying: requestor! ! !Compiler methodsFor: 'error handling' stamp: 'pavel.krivanek 11/21/2008 16:50'! interactive ^ UIManager default interactiveParserFor: requestor! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'ClementBera 5/22/2013 16:04'! class: aClass "This is used for compatibility with Opal" class := aClass. self compilationContext class: aClass! ! !Compiler methodsFor: 'private' stamp: 'eem 8/30/2010 17:57'! format: aStream noPattern: noPattern ifFail: failBlock ^(self parser parse: aStream class: class noPattern: noPattern context: context notifying: requestor ifFail: [^failBlock value]) preen! ! !Compiler methodsFor: 'public - old' stamp: 'md 2/28/2006 10:04'! compile: textOrStream in: aClass classified: aCategory notifying: aRequestor ifFail: failBlock "Answer a MethodNode for the argument, textOrStream. If the MethodNode can not be created, notify the argument, aRequestor; if aRequestor is nil, evaluate failBlock instead. The MethodNode is the root of a parse tree. It can be told to generate a CompiledMethod to be installed in the method dictionary of the argument, aClass." | methodNode | self from: textOrStream class: aClass classified: aCategory context: nil notifying: aRequestor. methodNode := self translate: sourceStream noPattern: false ifFail: failBlock. methodNode encoder requestor: requestor. ^methodNode. ! ! !Compiler methodsFor: 'public access' stamp: 'ClementBera 6/7/2013 10:26'! evaluate "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor. Compilation is carried out with respect to nil, i.e., no object, and the invocation is not logged." ^self evaluate: sourceStream! ! !Compiler methodsFor: 'public - old' stamp: 'MarcusDenker 4/30/2013 10:36'! evaluate: textOrString for: anObject logged: logFlag "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor." ^self evaluate: textOrString for: anObject notifying: nil logged: logFlag! ! !Compiler methodsFor: 'public - opal compatibility' stamp: 'ClementBera 6/7/2013 10:03'! source: aString sourceStream := aString readStream.! ! !Compiler class methodsFor: 'evaluating' stamp: ''! evaluate: textOrString logged: logFlag "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor. Compilation is carried out with respect to nil, i.e., no object." ^self evaluate: textOrString for: nil logged: logFlag! ! !Compiler class methodsFor: 'evaluating' stamp: ''! evaluate: textOrString notifying: aController logged: logFlag "See Compiler|evaluate:for:notifying:logged:. Compilation is carried out with respect to nil, i.e., no object." ^self evaluate: textOrString for: nil notifying: aController logged: logFlag! ! !Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 09:50'! evaluate: textOrString for: anObject notifying: aController logged: logFlag "Compile and execute the argument, textOrString with respect to the class of anObject. If a compilation error occurs, notify aController. If both compilation and execution are successful then, if logFlag is true, log (write) the text onto a system changes file so that it can be replayed if necessary." ^ self new evaluate: textOrString in: nil to: anObject notifying: aController ifFail: [^nil] logged: logFlag.! ! !Compiler class methodsFor: 'utilities' stamp: 'MarcusDenker 10/1/2013 14:20'! recompileAll "Recompile all classes and traits in the system." Smalltalk image recompile ! ! !Compiler class methodsFor: '*Deprecated30' stamp: 'MarcusDenker 5/2/2013 17:14'! decompilerClass self deprecated: 'use #compilerClass' on: '02 May 2013' in: 'Pharo 3.0'. ^self! ! !Compiler class methodsFor: 'accessing' stamp: 'MarcusDenker 11/16/2012 13:46'! debuggerMethodMapForMethod: aMethod ^ DebuggerMethodMap forMethod: aMethod! ! !Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 10:07'! evaluate: textOrString "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor. Compilation is carried out with respect to nil, i.e., no object, and the invocation is not logged." ^self evaluate: textOrString for: nil logged: false! ! !Compiler class methodsFor: '*Deprecated30' stamp: 'MarcusDenker 5/9/2013 11:08'! decompile: aSelector in: aClass self deprecated: 'use #decompileMethod:' on: '09 May 2013' in: 'Pharo 3.0'. ^Decompiler new decompile: aSelector in: aClass ! ! !Compiler class methodsFor: '*Deprecated30' stamp: 'MarcusDenker 5/9/2013 11:08'! decompile: aSelector in: aClass method: aMethod self deprecated: 'use #decompileMethod:' on: '09 May 2013' in: 'Pharo 3.0'. ^Decompiler new decompile: aSelector in: aClass method: aMethod ! ! !Compiler class methodsFor: 'utilities' stamp: 'MarcusDenker 5/1/2013 12:06'! decompileMethod: aCompiledMethod ^Decompiler new decompileMethod: aCompiledMethod ! ! !Compiler class methodsFor: 'evaluating' stamp: ''! evaluate: textOrString for: anObject logged: logFlag "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor." ^self evaluate: textOrString for: anObject notifying: nil logged: logFlag! ! !Compiler class methodsFor: 'evaluating' stamp: 'alain.plantec 5/18/2009 15:53'! format: textOrStream in: aClass notifying: aRequestor ^self new format: textOrStream in: aClass notifying: aRequestor! ! !CompilerEvaluationTest commentStamp: 'StephaneDucasse 6/9/2010 20:54'! This test is important since it covers a bug of during the debugging of super binding. It uses the class AverageCost/TotalCost and WeightedAverageCost.! !CompilerEvaluationTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 12:57'! testEvaluationOfSelfSend "Tests the evaluation of an inherited method that uses super send and self send" "self debug: #testEvaluationOfSelfSend" | result | result := Compiler new evaluate: (self method copyFrom: 6 to: self method size) in: self methodContext to: nil notifying: nil ifFail: [^ self] logged: true. self assert: result = (6250 / 3)! ! !CompilerEvaluationTest methodsFor: 'helper methods' stamp: 'carlaGriggio 5/23/2010 20:18'! weightedAverage ^weightedAverage ! ! !CompilerEvaluationTest methodsFor: 'setup' stamp: 'MarcusDenker 5/20/2013 15:34'! tearDown SmalltalkImage compilerClass: currentCompiler.! ! !CompilerEvaluationTest methodsFor: 'helper methods' stamp: 'carlaGriggio 5/22/2010 21:24'! method ^self methodContext method asString ! ! !CompilerEvaluationTest methodsFor: 'helper methods' stamp: 'StephaneDucasse 6/9/2010 20:55'! methodContext | process | process := [ self weightedAverage total ] newProcess. [ process step ] doWhileTrue: [ process suspendedContext method selector ~= #total ]. ^ process suspendedContext! ! !CompilerEvaluationTest methodsFor: 'setup' stamp: 'MarcusDenker 5/20/2013 15:33'! setUp weightedAverage := WeightedAverageCost new. currentCompiler := SmalltalkImage compilerClass. SmalltalkImage compilerClass: Compiler.! ! !CompilerEvaluationTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 12:57'! testEvaluationOfInlinedToDo "Whether inlined or not, #to:do: should return the same value" | inlinedResult notInlinedResult | inlinedResult := Compiler new evaluate: '1+1 to: 0 do: [:i | ]' in: nil to: nil notifying: nil ifFail: [^ self] logged: false. notInlinedResult := Compiler new evaluate: '| aBlock | aBlock := [:i | ]. 1+1 to: 0 do: aBlock' in: nil to: nil notifying: nil ifFail: [^ self] logged: false. self assert: inlinedResult = notInlinedResult! ! !CompilerExceptionsTest commentStamp: 'TorstenBergmann 1/31/2014 11:23'! SUnit tests for compiler exceptions! !CompilerExceptionsTest methodsFor: 'tests' stamp: 'StephaneDucasse 2/10/2011 17:30'! testUnknownSelector self compiling: 'griffle self reallyHopeThisIsntImplementedAnywhere' shouldRaise: UnknownSelector; compiling: 'griffle [ self reallyHopeThisIsntImplementedAnywhere ] value' shouldRaise: UnknownSelector! ! !CompilerExceptionsTest methodsFor: 'setUp' stamp: 'MarcusDenker 5/20/2013 13:09'! tearDown SmalltalkImage compilerClass: currentCompiler.! ! !CompilerExceptionsTest methodsFor: 'tests' stamp: 'StephaneDucasse 2/10/2011 17:30'! testUndefinedVariable self compiling: 'griffle | goo | ^ goo' shouldRaise: UndefinedVariable; compiling: 'griffle [ | goo | ^ goo ] value' shouldRaise: UndefinedVariable! ! !CompilerExceptionsTest methodsFor: 'emulating' stamp: 'cwp 8/25/2009 20:22'! selectionInterval ^ 1 to: 0! ! !CompilerExceptionsTest methodsFor: 'tests' stamp: 'StephaneDucasse 2/10/2011 17:29'! testUndeclaredVariable self compiling: 'griffle ^ goo' shouldRaise: UndeclaredVariable; compiling: 'griffle ^ [ goo ] value' shouldRaise: UndeclaredVariable! ! !CompilerExceptionsTest methodsFor: 'setUp' stamp: 'MarcusDenker 5/20/2013 13:09'! setUp currentCompiler := SmalltalkImage compilerClass. SmalltalkImage compilerClass: Compiler. self removeGeneratedMethods.! ! !CompilerExceptionsTest methodsFor: 'compiling' stamp: 'StephaneDucasse 8/29/2013 21:06'! removeGeneratedMethods self class removeProtocol: 'generated'! ! !CompilerExceptionsTest methodsFor: 'tests' stamp: 'JohanBrichau 4/15/2011 15:58'! testAmbiguousSelector self compiling: 'griffle ^1--1' shouldRaise: AmbiguousSelector; compiling: 'griffle ^1@-1' shouldRaise: AmbiguousSelector; compiling: 'griffle ^1+-1' shouldRaise: AmbiguousSelector! ! !CompilerExceptionsTest methodsFor: 'compiling' stamp: 'JohanBrichau 4/15/2011 15:56'! interactive ^ true! ! !CompilerExceptionsTest methodsFor: 'emulating' stamp: 'cwp 8/25/2009 20:23'! selectFrom: start to: end ! ! !CompilerExceptionsTest methodsFor: 'emulating' stamp: 'StephaneDucasse 2/10/2011 17:36'! text ^ text! ! !CompilerExceptionsTest methodsFor: 'compiling' stamp: 'StephaneDucasse 2/10/2011 17:00'! compiling: sourceCode shouldRaise: exceptionClass self should: [ self compile: sourceCode ] raise: exceptionClass! ! !CompilerExceptionsTest methodsFor: 'compiling' stamp: 'StephaneDucasse 2/10/2011 16:59'! compile: sourceString text := sourceString. self class compileSilently: text classified: 'generated' notifying: self! ! !CompilerExceptionsTest methodsFor: 'tests' stamp: 'MarcusDenker 5/1/2013 10:03'! testUnusedVariable self compiling: 'griffle | goo | ^nil' shouldRaise: UnusedVariable.! ! !CompilerExceptionsTest methodsFor: 'emulating' stamp: 'cwp 8/25/2009 20:23'! select ! ! !CompilerNotifyingTest commentStamp: 'nice 2/23/2012 22:09'! A CompilerNotifyingTest is a TestCase for checking that Compiler/Parser notifications are inserted at the right place in a TextEditor. Instance Variables expectedErrorPositions: expectedErrors: failure: morph: text: errorPositions - the position where error text should be inserted for each chunk of text evaluated errors - the error text that should be inserted on evaluation of each chunk of text evaluated failure - an object returned in case of evaluation error and whose identity can be uniquely recognized as a failure morph - the Morph holding the text text - the string containing all the chunks to be evaluated (separated by %) and the expected error messages (`enclosed in back quotes`) this text will be stripped of the error messages before being evaluated. ! !CompilerNotifyingTest methodsFor: 'testing-byteCode limits' stamp: 'nice 2/22/2012 01:34'! testTooManyArguments self setUpForErrorsIn: '^[:x1 :x2 :x3 :x4 :x5 :x6 :x7 :x8 :x9 :x10 :x11 :x12 :x13 :x14 :x15 ` Too many arguments ->`:x16 :x17 | ]'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testExtraneousStatementAfterAReturnInABlock self setUpForErrorsIn: '[ ^1 ` End of block expected ->`2]'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'private' stamp: 'nice 2/21/2012 22:23'! numberOfSelections ^(text occurrencesOf: $%) + 1! ! !CompilerNotifyingTest methodsFor: 'testing-byteCode limits' stamp: 'nice 2/22/2012 21:52'! testTooManyTemporaries "Nope, with Closure Compiler, an Error is raised before the Encoder has a chance to notify"! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 21:32'! testAlltogether "Initialize for all known error conditions. Note that the chunk to be evaluated are separated by %, and expected errors enclosed in back quotes." self setUpForErrorsIn: ' "First, the senders of #offEnd:" #` Unmatched bracket ->`[ 1 2 % #[ 1 2 ` 8-bit integer or right bracket expected ->`256 4]% $` A Character was expected ->`% 1+2 ` Unmatched comment quote ->`"unfinished comment% #` Unmatched parenthesis ->`( 1 2% #` Unmatched parenthesis ->`( 1 2 % ^nil printString , ` Unmatched string quote ->`''unfinished string% "Then, the senders of #expected:" 2r` a digit between 0 and 1 expected ->`3% | x | x := ` Expression expected ->`% [ :x : ` Argument name expected ->`1]% [ :x ` Vertical bar expected ->`x + 1 ]% [:x | 1 ` Period or right bracket expected ->`( 1 ) ]% { 1. 2` Period or right brace expected ->`% { 1. 2 ` Period or right brace expected ->`% { 1. 2 ` Period or right brace expected ->`3 % { 1. 2. ` Variable or expression expected ->`| x | % super yourself` Cascading not expected ->`; yourself% nil yourself; ` Cascade expected ->`^ 2% "#externalFunctionDeclaration is skipped, this cannot be evaluated" 1 to: ` Argument expected ->`:=% 1 +` Argument expected ->`% 1 + ` Argument expected ->`* 2 + 3% 1+(2 ` right parenthesis expected ->`. % 1 + 2 ` Nothing more expected ->`^nil% "#pattern:inContext: skipped, cannot be evaluated" "#pragmaLiteral: #pragmaSequence #pragmaStatement skipped, cannot be evaluated" ( ` expression expected ->`. 2 . )% ( 1 ` right parenthesis expected ->`. 2 . )% "#primitive:error: #primitive:module:error: skipped, cannot be evaluated" ^ ` Expression to return expected ->`. 1 + 2% [ ^1 ` End of block expected ->`2]% | x y ` Vertical bar expected ->`% [:z | | x y ` Vertical bar expected ->`]% 1` an integer greater than 1 as valid radix expected ->`r0'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 01:44'! testATempShadowingAnotherTemp self setUpForErrorsIn: '| x | x := 1. ^[ | ` Name is already defined ->`x | x ]'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testMissingExpressionAfterAReturn self setUpForErrorsIn: '^ ` Expression to return expected ->`. 1 + 2'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'private' stamp: 'MarcusDenker 4/22/2013 11:08'! evaluateSelection ^Compiler new evaluate: morph editor selectionAsStream in: nil to: nil notifying: morph editor ifFail: [^failure] logged: false ! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testMissingBlockArgumentName self setUpForErrorsIn: '[ :x : ` Argument name expected ->`1]'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'accessing' stamp: 'nice 2/23/2012 22:32'! expectedFailures "For these tests, the Compiler does not insert the notification where it would be most informative." ^#( "Notifying before the literal (which can be a message send) would be more informative" testTooManyLiterals "Notifying right before the 16th argument would be informative" testTooManyArguments "Notifying before the extraneous argument in the right block woul be useful" testifTrueBlockWithArgument testCaseOtherwiseBlockWithArgument "Pharo still accept the non standard unichar symbol syntax #) while every other Smalltalk would require quotes #')'" testInvalidLiteralCharacter )! ! !CompilerNotifyingTest methodsFor: 'initialize-release' stamp: 'nice 2/21/2012 23:52'! initializeTextWithoutError "Remove the errors from the text to be compiled and answer the text without errors. Meanwhile, collect the expected error messages and their expected position." | input output errorStream positionStream | input := text readStream. output := (String new: text size) writeStream. errorStream := (Array new: self numberOfSelections) writeStream. positionStream := (Array new: self numberOfSelections) writeStream. [output nextPutAll: (input upTo: $`). input atEnd] whileFalse: [positionStream nextPut: output position + 1. errorStream nextPut: (input upTo: $`)]. expectedErrors := errorStream contents. expectedErrorPositions := positionStream contents. ^output contents! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testExpectedExpressionInBraceArray self setUpForErrorsIn: '{ 1. 2 ` Period or right brace expected ->`3 }'. self enumerateAllSelections. self setUpForErrorsIn: '{ 1. 2. ` Variable or expression expected ->`| x | x}'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testMissingSeparatorBetweenBlockArgumentAndStatements self setUpForErrorsIn: '[ :x ` Vertical bar expected ->`x + 1 ]'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testUnmatchedByteArrayBracket self setUpForErrorsIn: '#` Unmatched bracket ->`[ 1 2 '. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 02:41'! testUnmatchedExpressionParenthesis self setUpForErrorsIn: '1+(2 ` right parenthesis expected ->`. '. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testUnmatchedLocalTempDeclarationInABlock self setUpForErrorsIn: '[:z | | x y ` Vertical bar expected ->`]'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 01:57'! testUnmatchedBlockBracket self setUpForErrorsIn: 'nil yourself. [` Period or right bracket expected ->`'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testInvalidRadix self setUpForErrorsIn: '1` an integer greater than 1 as valid radix expected ->`r0'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 01:08'! testInvalidLiteralCharacter self setUpForErrorsIn: '^ #yourself , #` Invalid literal character ->`) , #end'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testLiteralCharacterMissing self setUpForErrorsIn: '$` A Character was expected ->`'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'private' stamp: 'nice 2/21/2012 23:58'! evaluateSelectionNumber: n | i start stop | i := start := 1. [stop := morph text indexOf: $% startingAt: start + 1 ifAbsent: morph text size + 1. i = n] whileFalse: [i := i + 1. start := stop + 1]. morph editor selectFrom: start to: stop - 1. ^self evaluateSelection ! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testMissingMessageAfterACascade self setUpForErrorsIn: 'nil yourself; ` Cascade expected ->`^ 2'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 02:06'! testMissingPeriodSeparatorBetweenStatements self setUpForErrorsIn: '1 + 2 ` Nothing more expected ->`^nil'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testDigitTooLargeForARadix self setUpForErrorsIn: '2r` a digit between 0 and 1 expected ->`3'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing-block arguments' stamp: 'nice 2/22/2012 01:15'! testCaseOtherwiseBlockWithArgument self setUpForErrorsIn: 'nil caseOf: { [nil] -> [1] } otherwise: [:x` <- otherwise arg of caseOf:otherwise: has too many arguments ->` | 2 ]. ^nil '. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testUnmatchedLiteralParenthesis self setUpForErrorsIn: '#` Unmatched parenthesis ->`( 1 2'. self enumerateAllSelections. self setUpForErrorsIn: '#` Unmatched parenthesis ->`( 1 2 '. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testMissingArgumentAfterABinaryMessage self setUpForErrorsIn: '1 +` Argument expected ->`'. self enumerateAllSelections. self setUpForErrorsIn: '1 + ` Argument expected ->`* 2 + 3'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testUnmatchedStringQuote self setUpForErrorsIn: '^nil printString , ` Unmatched string quote ->`''unfinished string'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testUnmatchedBraceArray self setUpForErrorsIn: '{ 1. 2` Period or right brace expected ->`'. self enumerateAllSelections. self setUpForErrorsIn: '{ 1. 2 ` Period or right brace expected ->`'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'initialize-release' stamp: 'PavelKrivanek 11/8/2012 12:47'! setUpForErrorsIn: aTextWithErrorsEnclosedInBackQuote "Extract the expectedErrors, the expectedErrorPositions and set up a TextMorph containing the text without errors. each section separated by % in aTextWithErrorsEnclosedInBackQuote will be evaluated separately. The expected error message should lie in aTextWithErrorsEnclosedInBackQuote at the expected position, and enclosed in back quotes." text := aTextWithErrorsEnclosedInBackQuote. morph := MockSourceEditor new contents: self initializeTextWithoutError asText.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testMissingExpression self setUpForErrorsIn: '| x | x := ` Expression expected ->'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:31'! testInvalidPrimitive "Not implemented yet. ##primitive:error: #primitive:module:error: skipped, cannot be evaluated"! ! !CompilerNotifyingTest methodsFor: 'initialize-release' stamp: 'nice 2/22/2012 00:54'! setUp failure := Object new.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 01:53'! testInvalidPragma "Not implemented yet. #pragmaLiteral: #pragmaSequence #pragmaStatement #pragmaPrimitives skipped, cannot be evaluated"! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:54'! testCascadeInASuperSend self setUpForErrorsIn: 'super yourself` Cascading not expected ->`; yourself'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 01:06'! testAssignmentOfSelf self setUpForErrorsIn: '` Cannot store into ->`self := 1. ^self'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:31'! testInvalidExternalFunctionDeclaration "Not implemented yet. #externalFunctionDeclaration skipped, cannot be evaluated"! ! !CompilerNotifyingTest methodsFor: 'private' stamp: 'nice 2/22/2012 00:56'! enumerateAllSelections 1 to: self numberOfSelections do: [:n | self assert: (self evaluateSelectionNumber: n) == failure. self assert: ((expectedErrors at: n) = morph editor selection asString). self assert: ((expectedErrorPositions at: n) = morph editor startIndex). morph editor cut].! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 01:10'! testEmptyCaseStatement self setUpForErrorsIn: '^ nil caseOf: { ` At least one case required ->`} '. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 01:40'! testTempDoubledDefined self setUpForErrorsIn: '| x ` Name is already defined ->`x | x := 1. ^x'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testUnmatchedCommentQuote self setUpForErrorsIn: '1+2 ` Unmatched comment quote ->`"unfinished comment'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testTooLargeAnIntegerInALiteralByteArray self setUpForErrorsIn: '#[ 1 2 ` 8-bit integer or right bracket expected ->`256 4 5]'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testMissingArgumentAfterAMessageKey self setUpForErrorsIn: '1 to: ` Argument expected ->`:='. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing-byteCode limits' stamp: 'nice 2/22/2012 01:49'! testTooManyLiterals self setUpForErrorsIn: '{#(1). #(2). #(3). #(4). #(5). #(6). #(7). #(8). #(9). #(10). #(11). #(12). #(13). #(14). #(15). #(16). #(17). #(18). #(19). #(20). #(21). #(22). #(23). #(24). #(25). #(26). #(27). #(28). #(29). #(30). #(31). #(32). #(33). #(34). #(35). #(36). #(37). #(38). #(39). #(40). #(41). #(42). #(43). #(44). #(45). #(46). #(47). #(48). #(49). #(50). #(51). #(52). #(53). #(54). #(55). #(56). #(57). #(58). #(59). #(60). #(61). #(62). #(63). #(64). #(65). #(66). #(67). #(68). #(69). #(70). #(71). #(72). #(73). #(74). #(75). #(76). #(77). #(78). #(79). #(80). #(81). #(82). #(83). #(84). #(85). #(86). #(87). #(88). #(89). #(90). #(91). #(92). #(93). #(94). #(95). #(96). #(97). #(98). #(99). #(100). #(101). #(102). #(103). #(104). #(105). #(106). #(107). #(108). #(109). #(110). #(111). #(112). #(113). #(114). #(115). #(116). #(117). #(118). #(119). #(120). #(121). #(122). #(123). #(124). #(125). #(126). #(127). #(128). #(129). #(130). #(131). #(132). #(133). #(134). #(135). #(136). #(137). #(138). #(139). #(140). #(141). #(142). #(143). #(144). #(145). #(146). #(147). #(148). #(149). #(150). #(151). #(152). #(153). #(154). #(155). #(156). #(157). #(158). #(159). #(160). #(161). #(162). #(163). #(164). #(165). #(166). #(167). #(168). #(169). #(170). #(171). #(172). #(173). #(174). #(175). #(176). #(177). #(178). #(179). #(180). #(181). #(182). #(183). #(184). #(185). #(186). #(187). #(188). #(189). #(190). #(191). #(192). #(193). #(194). #(195). #(196). #(197). #(198). #(199). #(200). #(201). #(202). #(203). #(204). #(205). #(206). #(207). #(208). #(209). #(210). #(211). #(212). #(213). #(214). #(215). #(216). #(217). #(218). #(219). #(220). #(221). #(222). #(223). #(224). #(225). #(226). #(227). #(228). #(229). #(230). #(231). #(232). #(233). #(234). #(235). #(236). #(237). #(238). #(239). #(240). #(241). #(242). #(243). #(244). #(245). #(246). #(247). #(248). #(249). #(250). #(251). #(252). #(253). #(254). #(255). #(256). `More than 256 literals referenced. You must split or otherwise simplify this method. The 257th literal is: ->`#(257)}'. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testUnmatchedLocalTempDeclaration self setUpForErrorsIn: '| x y ` Vertical bar expected ->`'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing-block arguments' stamp: 'nice 2/22/2012 01:23'! testifTrueBlockWithArgument self setUpForErrorsIn: 'true ifTrue: [:x` <- argument of ifTrue: has too many arguments ->` | 1 + 1 ]'. self enumerateAllSelections. self setUpForErrorsIn: 'true ifTrue: [:x` <- argument of ifTrue: has too many arguments ->` :y | 1 + 1 ]'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:31'! testInvalidPattern "Not implemented yet. #pattern:inContext: skipped, cannot be evaluated"! ! !CompilerSyntaxErrorNotifyingTest commentStamp: 'nice 2/23/2012 22:09'! A CompilerSyntaxErrorNotifyingTest is a specialization for testing correct handling of non interactive compiler notification. Non interactive is a very relative notion in Smalltalk... Here it means that user interaction will not happen directly in the TextEditor holding source code, but rather thru a SyntaxError window that will pop-up. This test intercept the Notification before the pop-up is raised. ! !CompilerSyntaxErrorNotifyingTest methodsFor: 'private' stamp: 'nice 2/23/2012 22:34'! enumerateAllSelections "This method intercepts the SyntaxErrorNotification and prevent the SyntaxError morph to open. The notification errorCode hold the source of evaluated sub-selection with inserted error message. This can be compared to expected error notification." | syntaxErrorProbe | syntaxErrorProbe := Object new. 1 to: self numberOfSelections do: [:n | | result | result := [self evaluateSelectionNumber: n] on: SyntaxErrorNotification do: [:exc | | expectedNotification expectedNotificationLocation | expectedNotification := (expectedErrors at: n) allButFirst. (expectedNotification endsWith: ' ->') ifTrue: [expectedNotification := expectedNotification allButLast: 3]. expectedNotificationLocation := (expectedErrorPositions at: n) - (morph editor startIndex - 1). self assert: expectedNotificationLocation = exc location. self assert: expectedNotification = exc errorMessage asString. exc return: syntaxErrorProbe]. self assert: result == syntaxErrorProbe].! ! !CompilerSyntaxErrorNotifyingTest methodsFor: 'private' stamp: 'MarcusDenker 5/7/2013 08:40'! evaluateSelection ^Compiler new evaluate: morph editor selection readStream "Note subtle difference versus (morph editor selectionAsStream). The later does not answer the same contents and would raise a SyntaxErrorNotification with wrong sub-selection" in: nil to: nil notifying: nil ifFail: [^failure] logged: false! ! !CompilerSyntaxErrorNotifyingTest class methodsFor: 'testing' stamp: 'nice 2/22/2012 22:54'! shouldInheritSelectors "This class can recycle all of super tests, it just has to refine internal Compiler evaluation machinery" ^true! ! !CompilerSystemSettings commentStamp: 'TorstenBergmann 2/12/2014 23:26'! System settings for the compiler! !CompilerSystemSettings class methodsFor: 'settings' stamp: 'ClementBera 11/26/2013 13:35'! compilerSettingsOn: aBuilder (aBuilder group: #compiler) label: 'Compiler'; with: [ (aBuilder pickOne: #compilerClass) target: SmalltalkImage; label: 'Default Compiler'; domainValues: {Compiler. OpalCompiler}. (aBuilder setting: #warningAllowed) target: CompilationContext; label: 'Allow Warnings'; default: true]! ! !CompilerTest commentStamp: 'nice 12/3/2007 22:15'! CompilerTest is a holder for SUnit test of Compiler! !CompilerTest methodsFor: 'test shadowing' stamp: 'jb 7/1/2011 10:45'! testInBlockTempShadowing interactive := true. self initializeErrorMessage. (Compiler new compile: 'temp |var2| [:temp| |var2|]' in: MockForCompilation classified: nil notifying: self ifFail: [ self assert: (errorMessage = 'Name is already defined ->'). self assert: (errorLocation = 22). self assert: (errorSource contents = 'temp |var2| [:temp| |var2|]'). ^nil]). ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'jb 7/1/2011 10:44'! testNotInteractiveInBlockArgumentInstanceVariableShadowing self initializeErrorMessage. (Compiler new compile: 'temp [:var1 | ]' in: MockForCompilation classified: nil notifying: nil ifFail: [self fail. ^nil]). self assert: ( newTranscript contents = ' MockForCompilation>>temp(var1 is shadowed)'). ! ! !CompilerTest methodsFor: 'running' stamp: 'EstebanLorenzano 8/3/2012 15:28'! runCase SystemAnnouncer uniqueInstance suspendAllWhile: [ super runCase ] ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'JorgeRessia 3/4/2010 21:51'! testNotInteractiveSiblingBlocksTempShadowing self initializeErrorMessage. (Compiler new compile: 'temp [:temp | ]. [:temp | ]' in: MockForCompilation classified: nil notifying: nil ifFail: [self fail. ^nil]). self assert: ( newTranscript contents = ''). ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'JorgeRessia 3/4/2010 12:55'! testSiblingBlocksInstanceVariableShadowing interactive := true. self initializeErrorMessage. (Compiler new compile: 'temp [:temp | ].[:temp | |var1|]' in: MockForCompilation classified: nil notifying: self ifFail: [ self assert: (errorMessage = 'Name is already defined ->'). self assert: (errorLocation = 27). self assert: (errorSource contents = 'temp [:temp | ].[:temp | |var1|]'). ^nil]). self fail. ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'jb 7/1/2011 10:44'! testNotInteractiveInBlockTempInstanceVariableShadowing self initializeErrorMessage. (Compiler new compile: 'temp [:temp | |var1|]' in: MockForCompilation classified: nil notifying: nil ifFail: [self fail. ^nil]). self assert: ( newTranscript contents = ' MockForCompilation>>temp(var1 is shadowed)'). ! ! !CompilerTest methodsFor: 'mocking' stamp: 'JorgeRessia 3/4/2010 12:48'! initializeErrorMessage errorMessage := nil. errorLocation := nil. errorSource := nil! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'CamilleTeruel 1/10/2013 14:42'! testSiblingBlocksTempShadowing interactive := true. self initializeErrorMessage. (Compiler new compile: 'temp [:temp | ]. [:temp | ]' in: MockForCompilation classified: nil notifying: nil ifFail: [self fail. ^nil]). ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'CamilloBruni 1/20/2012 14:32'! testEmptyCharacterFail interactive := true. self initializeErrorMessage. (Compiler new compile: 'test $' in: MockForCompilation classified: nil notifying: self ifFail: [^nil]). self fail. ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'jb 7/1/2011 10:44'! testNotInteractiveInBlockTempShadowing "This test is not completely correct in the sense that it is still interactive. I have to introduce self ( then is interactive) in order to be able to test it" interactive := true. self initializeErrorMessage. (Compiler new compile: 'temp |var2| [:temp| |var2|]' in: MockForCompilation classified: nil notifying: self ifFail: [ self assert: (errorMessage = 'Name is already defined ->'). self assert: (errorLocation = 22). self assert: (errorSource contents = 'temp |var2| [:temp| |var2|]'). ^nil]). ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'CamilleTeruel 1/10/2013 14:42'! testNoShadowing interactive := true. self initializeErrorMessage. (Compiler new compile: 'temp |var2|' in: MockForCompilation classified: nil notifying: nil ifFail: [self fail. ^nil]). ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'jb 7/1/2011 10:45'! testInBlockArgumentInstanceVariableShadowing interactive := true. self initializeErrorMessage. (Compiler new compile: 'temp [:var1 | ]' in: MockForCompilation classified: nil notifying: self ifFail: [ self assert: (errorMessage = 'Name is already defined ->'). self assert: (errorLocation = 8). self assert: (errorSource contents = 'temp [:var1 | ]'). ^nil]). self fail. ! ! !CompilerTest methodsFor: 'mocking' stamp: 'JorgeRessia 3/4/2010 12:49'! notify: aString at: aSmallInteger in: aReadStream errorMessage := aString. errorLocation := aSmallInteger. errorSource := aReadStream. ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'jb 7/1/2011 10:44'! testNotInteractiveNoShadowing self initializeErrorMessage. (Compiler new compile: 'temp |var2|' in: MockForCompilation classified: nil notifying: nil ifFail: [self fail. ^nil]). self assert: ( newTranscript contents = ''). ! ! !CompilerTest methodsFor: 'literals' stamp: 'nice 12/3/2007 22:20'! testScaledDecimalLiterals "Equal ScaledDecimal with different scales should use different slots This is related to http://bugs.squeak.org/view.php?id=6797" "This correctly works when evaluated separately" self deny: (Compiler evaluate: '0.5s1') scale = (Compiler evaluate: '0.5s2') scale. "But not when evaluated together if literal reduction is too agressive" self deny: (Compiler evaluate: '0.5s1 scale = 0.5s2 scale').! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'lr 3/8/2010 15:11'! testReservedNameAsBlockArgumentShadowing interactive := true. #( 'self' 'super' 'thisContext' 'true' 'false' 'nil' ) do: [ :each | self initializeErrorMessage. [ :exit | Compiler new compile: 'temp ^ [ :' , each , ' | ^ ' , each , ' ]' in: MockForCompilation classified: nil notifying: self ifFail: [ exit value ]. self fail ] valueWithExit. self assert: errorMessage = 'Name is already defined ->'. self assert: errorLocation = 11 ]! ! !CompilerTest methodsFor: 'running' stamp: 'simon.denier 6/11/2010 14:24'! tearDown Smalltalk globals at: #Transcript put: originalTranscript. ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'lr 3/8/2010 15:10'! testReservedNameAsMethodArgumentShadowing interactive := true. #( 'self' 'super' 'thisContext' 'true' 'false' 'nil' ) do: [ :each | self initializeErrorMessage. [ :exit | Compiler new compile: 'temp: ' , each , ' ^ ' , each in: MockForCompilation classified: nil notifying: self ifFail: [ exit value ]. self fail ] valueWithExit. self assert: errorMessage = 'Name is already defined ->'. self assert: errorLocation = 7 ]! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'JorgeRessia 3/13/2010 16:16'! testTraitTempShadowing self initializeErrorMessage. Compiler new compile: 'testReplaceFromToWithStartingAt | result repStart collection replacementCollection firstIndex secondIndex | replacementCollection := 1.' in: ArrayTest classified: nil notifying: nil ifFail: [self fail.]. self assert: ( newTranscript contents = '').! ! !CompilerTest methodsFor: 'running' stamp: 'simon.denier 6/11/2010 14:24'! setUp originalTranscript := Transcript. newTranscript := MockTranscript new. Smalltalk globals at: #Transcript put: newTranscript. ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'jb 7/1/2011 10:45'! testInBlockTempInstanceVariableShadowing interactive := true. self initializeErrorMessage. (Compiler new compile: 'temp [:temp | |var1|]' in: MockForCompilation classified: nil notifying: self ifFail: [ self assert: (errorMessage = 'Name is already defined ->'). self assert: (errorLocation = 16). self assert: (errorSource contents = 'temp [:temp | |var1|]'). ^nil]). self fail. ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'JorgeRessia 3/4/2010 21:46'! testNotInteractiveShadowingOfTemp "This test is not completely correct in the sense that it is still interactive. I have to introduce self ( then is interactive) in order to be able to test it" self initializeErrorMessage. interactive := false. (Compiler new compile: 'temp |temp1 temp1| ' in: MockForCompilation classified: nil notifying: self ifFail: [ self assert: (errorMessage = 'Name is already defined ->'). self assert: (errorLocation = 13). self assert: (errorSource contents = 'temp |temp1 temp1| '). ^nil]). ! ! !CompilerTest methodsFor: 'mocking' stamp: 'JorgeRessia 3/4/2010 12:49'! interactive ^interactive! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'jb 7/1/2011 10:45'! testInBlockTempArgumentShadowing interactive := true. self initializeErrorMessage. (Compiler new compile: 'temp [:temp | |temp|]' in: MockForCompilation classified: nil notifying: self ifFail: [ self assert: (errorMessage = 'Name is already defined ->'). self assert: (errorLocation = 16). self assert: (errorSource contents = 'temp [:temp | |temp|]'). ^nil]). ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'jb 7/1/2011 10:44'! testNotInteractiveInBlockTempArgumentShadowing "This test is not completely correct in the sense that it is still interactive. I have to introduce self ( then is interactive) in order to be able to test it" interactive := true. self initializeErrorMessage. (Compiler new compile: 'temp [:temp | |temp|]' in: MockForCompilation classified: nil notifying: self ifFail: [ self assert: (errorMessage = 'Name is already defined ->'). self assert: (errorLocation = 16). self assert: (errorSource contents = 'temp [:temp | |temp|]'). ^nil]). self fail. ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'TestRunner 3/8/2010 15:10'! testReservedNameAsTempShadowing interactive := true. #( 'self' 'super' 'thisContext' 'true' 'false' 'nil' ) do: [ :each | self initializeErrorMessage. [ :exit | Compiler new compile: 'temp | ' , each , ' | ^ ' , each in: MockForCompilation classified: nil notifying: self ifFail: [ exit value ]. self fail ] valueWithExit. self assert: errorMessage = 'Name is already defined ->'. self assert: errorLocation = 8 ]! ! !CompilerTest methodsFor: 'literals' stamp: 'nice 12/20/2012 23:37'! testNegativeZero self assert: (Compiler evaluate: '-0.0') hex = Float negativeZero hex.! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'jb 7/1/2011 10:45'! testInstanceVariableShadowing interactive := true. self initializeErrorMessage. Compiler new compile: 'var1 |var1|' in: MockForCompilation classified: nil notifying: self ifFail: [ self assert: (errorMessage = 'Name is already defined ->'). self assert: (errorLocation = 7). self assert: (errorSource contents = 'var1 |var1|'). ^nil]. self fail. ! ! !CompilerTest methodsFor: 'test shadowing' stamp: 'JorgeRessia 3/4/2010 21:51'! testNotInteractiveSiblingBlocksInstanceVariableShadowing self initializeErrorMessage. (Compiler new compile: 'temp [:temp | ].[:temp | |var1|]' in: MockForCompilation classified: nil notifying: nil ifFail: [self fail. ^nil]). self assert: ( newTranscript contents = ' MockForCompilation>>temp(var1 is shadowed)'). ! ! !ComplexBorder commentStamp: 'MarcusDenker 2/14/2010 22:32'! see BorderedMorph. poly := polygon250 baseColor := Color blue twiceLighter. border := (ComplexBorder framed: 10) baseColor: poly color. border frameRectangle: ((100@100 extent: 200@200) insetBy: -5) on: Display getCanvas. baseColor := Color red twiceLighter. border := (ComplexBorder framed: 10) baseColor: baseColor. border drawPolygon: {100@100. 300@100. 300@300. 100@300} on: Display getCanvas. border drawPolyPatchFrom: 100@200 via: 100@100 via: 200@100 to: 200@200 on: Display getCanvas. border drawPolyPatchFrom: 100@100 via: 200@100 via: 200@200 to: 100@200 on: Display getCanvas. border drawPolyPatchFrom: 200@100 via: 200@200 via: 100@200 to: 100@100 on: Display getCanvas. border drawPolyPatchFrom: 200@200 via: 100@200 via: 100@100 to: 200@100 on: Display getCanvas. border := (ComplexBorder raised: 10) baseColor: poly color. border drawPolygon: poly getVertices on: Display getCanvas 360 / 16.0 22.5 points := (0 to: 15) collect:[:i| (Point r: 100 degrees: i*22.5) + 200]. Display getCanvas fillOval: (100@100 extent: 200@200) color: baseColor. border drawPolygon: points on: Display getCanvas. -1 to: points size + 1 do:[:i| border drawPolyPatchFrom: (points atWrap: i) via: (points atWrap: i+1) via: (points atWrap: i+2) to: (points atWrap: i+3) on: Display getCanvas. ]. Display getCanvas fillOval: (100@100 extent: 200@200) color: baseColor. 0 to: 36 do:[:i| border drawLineFrom: (Point r: 100 degrees: i*10) + 200 to: (Point r: 100 degrees: i+1*10) + 200 on: Display getCanvas. ]. drawPolygon: Point r: 1.0 degrees: 10 MessageTally spyOn:[ Display deferUpdates: true. t1 := [1 to: 1000 do:[:i| border drawLineFrom: (100@100) to: (300@100) on: Display getCanvas. border drawLineFrom: (300@100) to: (300@300) on: Display getCanvas. border drawLineFrom: (300@300) to: (100@300) on: Display getCanvas. border drawLineFrom: (100@300) to: (100@100) on: Display getCanvas]] timeToRun. Display deferUpdates: false. ]. MessageTally spyOn:[ Display deferUpdates: true. t2 := [1 to: 1000 do:[:i| border drawLine2From: (100@100) to: (300@100) on: Display getCanvas. border drawLine2From: (300@100) to: (300@300) on: Display getCanvas. border drawLine2From: (300@300) to: (100@300) on: Display getCanvas. border drawLine2From: (100@300) to: (100@100) on: Display getCanvas]] timeToRun. Display deferUpdates: false. ]. ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:14'! widthForRounding ^0! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 9/4/2001 19:51'! fillStyleForDirection: direction "Fill the given form describing the receiver's look at a particular direction" | index fill dir | index := direction degrees truncated // 10 + 1. lineStyles ifNotNil:[ fill := lineStyles at: index. fill ifNotNil:[^fill]. ]. dir := Point r: 1.0 degrees: index - 1 * 10 + 5. fill := GradientFillStyle colors: (self colorsForDirection: dir). fill direction: 0 @ width asPoint y; radial: false. fill origin: ((width asPoint x // 2) @ (width asPoint y // 2)) negated. fill pixelRamp: (fill computePixelRampOfSize: 16). fill isTranslucent. "precompute" lineStyles ifNil:[lineStyles := Array new: 37]. lineStyles at: index put: fill. ^fill! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:16'! computeAltFramedColors | base light dark w hw colorArray param | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. w := w asInteger. w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}]. colorArray := Array new: w. hw := w // 2. "brighten" 0 to: hw-1 do:[:i| param := 0.5 + (i asFloat / hw * 0.5). colorArray at: i+1 put: (base mixed: param with: dark). "brighten" colorArray at: w-i put: (base mixed: param with: light). "darken" ]. w odd ifTrue:[colorArray at: hw+1 put: base]. ^colorArray, colorArray! ! !ComplexBorder methodsFor: 'drawing' stamp: 'aoy 2/17/2003 01:08'! drawLineFrom: startPoint to: stopPoint on: aCanvas "Here we're using the balloon engine since this is much faster than BitBlt w/ brushes." | delta length dir cos sin tfm w h w1 w2 h1 h2 fill | width isPoint ifTrue: [w := width x. h := width y] ifFalse: [w := h := width]. w1 := w // 2. w2 := w - w1. h1 := h // 2. h2 := h - h1. "Compute the rotational transform from (0@0) -> (1@0) to startPoint -> stopPoint" delta := stopPoint - startPoint. length := delta r. dir := length > 1.0e-10 ifTrue: [delta / length] ifFalse: [ 1 @ 0]. cos := dir dotProduct: 1 @ 0. sin := dir crossProduct: 1 @ 0. tfm := (MatrixTransform2x3 new) a11: cos; a12: sin; a21: sin negated; a22: cos. "Install the start point offset" tfm offset: startPoint. "Now get the fill style appropriate for the given direction" fill := self fillStyleForDirection: dir. "And draw..." aCanvas asBalloonCanvas transformBy: tfm during: [:cc | cc drawPolygon: { (0 - w1) @ (0 - h1). "top left" (length + w2) @ (0 - h1). "top right" (length + w2) @ h2. "bottom right" (0 - w1) @ h2 "bottom left"} fillStyle: fill]! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:03'! computeAltInsetColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | param := false ifTrue: ["whats this ???!! false ifTrue:[]" 0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: dark). "darken" colorArray at: colorArray size - i put: (base mixed: param with: light) "brighten"]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:05'! computeAltRaisedColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | "again !! false ifTrue:[] ?!!" param := false ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: light). "brighten" colorArray at: colorArray size - i put: (base mixed: param with: dark) "darken"]. ^colorArray! ! !ComplexBorder methodsFor: 'drawing' stamp: 'ar 8/26/2001 19:01'! frameRectangle: aRectangle on: aCanvas "Note: This uses BitBlt since it's roughly a factor of two faster for rectangles" | w h r | self colors ifNil:[^super frameRectangle: aRectangle on: aCanvas]. w := self width. w isPoint ifTrue:[h := w y. w := w x] ifFalse:[h := w]. 1 to: h do:[:i| "top/bottom" r := (aRectangle topLeft + (i-1)) extent: (aRectangle width - (i-1*2))@1. "top" aCanvas fillRectangle: r color: (colors at: i). r := (aRectangle bottomLeft + (i @ (0-i))) extent: (aRectangle width - (i-1*2) - 1)@1. "bottom" aCanvas fillRectangle: r color: (colors at: colors size - i + 1). ]. 1 to: w do:[:i| "left/right" r := (aRectangle topLeft + (i-1)) extent: 1@(aRectangle height - (i-1*2)). "left" aCanvas fillRectangle: r color: (colors at: i). r := aRectangle topRight + ((0-i)@i) extent: 1@(aRectangle height - (i-1*2) - 1). "right" aCanvas fillRectangle: r color: (colors at: colors size - i + 1). ].! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:13'! colors ^colors ifNil:[colors := self computeColors].! ! !ComplexBorder methodsFor: 'initialize' stamp: 'ar 11/26/2001 14:43'! releaseCachedState colors := nil. lineStyles := nil.! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 11/26/2001 15:00'! computeColors width = 0 ifTrue:[^colors := #()]. style == #complexFramed ifTrue:[^self computeFramedColors]. style == #complexAltFramed ifTrue:[^self computeAltFramedColors]. style == #complexRaised ifTrue:[^self computeRaisedColors]. style == #complexAltRaised ifTrue:[^self computeAltRaisedColors]. style == #complexInset ifTrue:[^self computeInsetColors]. style == #complexAltInset ifTrue:[^self computeAltInsetColors]. self error:'Unknown border style: ', style printString.! ! !ComplexBorder methodsFor: 'drawing' stamp: 'ar 9/4/2001 19:50'! framePolygon: vertices on: aCanvas | dir1 dir2 dir3 nrm1 nrm2 nrm3 point1 point2 point3 cross1 cross2 pointA pointB pointC pointD w p1 p2 p3 p4 balloon ends pointE pointF | balloon := aCanvas asBalloonCanvas. balloon == aCanvas ifFalse:[balloon deferred: true]. ends := Array new: 6. w := width * 0.5. pointA := nil. 1 to: vertices size do:[:i| p1 := vertices atWrap: i. p2 := vertices atWrap: i+1. p3 := vertices atWrap: i+2. p4 := vertices atWrap: i+3. dir1 := p2 - p1. dir2 := p3 - p2. dir3 := p4 - p3. (i = 1 | true) ifTrue:[ "Compute the merge points of p1->p2 with p2->p3" cross1 := dir2 crossProduct: dir1. nrm1 := dir1 normalized. nrm1 := (nrm1 y * w) @ (0 - nrm1 x * w). nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w). cross1 < 0 ifTrue:[nrm1 := nrm1 negated. nrm2 := nrm2 negated]. point1 := (p1 x + nrm1 x) @ (p1 y + nrm1 y). point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y). pointA := self intersectFrom: point1 with: dir1 to: point2 with: dir2. point1 := (p1 x - nrm1 x) @ (p1 y - nrm1 y). point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y). pointB := point1 + dir1 + point2 * 0.5. pointB := p2 + ((pointB - p2) normalized * w). pointC := point2. ]. "Compute the merge points of p2->p3 with p3->p4" cross2 := dir3 crossProduct: dir2. nrm2 := dir2 normalized. nrm2 := (nrm2 y * w) @ (0 - nrm2 x * w). nrm3 := dir3 normalized. nrm3 := (nrm3 y * w) @ (0 - nrm3 x * w). cross2 < 0 ifTrue:[nrm2 := nrm2 negated. nrm3 := nrm3 negated]. point2 := (p2 x + nrm2 x) @ (p2 y + nrm2 y). point3 := (p3 x + nrm3 x) @ (p3 y + nrm3 y). pointD := self intersectFrom: point2 with: dir2 to: point3 with: dir3. point2 := (p2 x - nrm2 x) @ (p2 y - nrm2 y). point3 := (p3 x - nrm3 x) @ (p3 y - nrm3 y). pointF := point2 + dir2. pointE := pointF + point3 * 0.5. pointE := p3 + ((pointE - p3) normalized * w). cross1 * cross2 < 0.0 ifTrue:[ ends at: 1 put: pointA; at: 2 put: pointB; at: 3 put: pointC; at: 4 put: pointD; at: 5 put: pointE; at: 6 put: pointF. ] ifFalse:[ ends at: 1 put: pointA; at: 2 put: pointB; at: 3 put: pointC; at: 4 put: pointF; at: 5 put: pointE; at: 6 put: pointD. ]. self drawPolyPatchFrom: p2 to: p3 on: balloon usingEnds: ends. pointA := pointD. pointB := pointE. pointC := pointF. cross1 := cross2. ]. balloon == aCanvas ifFalse:[balloon flush].! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'! style ^style! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:35'! computeFramedColors | base light dark w hw colorArray param | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. w := w asInteger. w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}]. colorArray := Array new: w. hw := w // 2. "brighten" 0 to: hw-1 do:[:i| param := 0.5 + (i asFloat / hw * 0.5). colorArray at: i+1 put: (base mixed: param with: light). "brighten" colorArray at: w-i put: (base mixed: param with: dark). "darken" ]. w odd ifTrue:[colorArray at: hw+1 put: base]. ^colorArray, colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:02'! colorsForDirection: direction "Return an array of colors describing the receiver in the given direction" | colorArray dT cc | cc := self colors. direction x * direction y <= 0 ifTrue: ["within up->right or down->left transition; no color blend needed" colorArray := (direction x > 0 or: [direction y < 0]) ifTrue: ["up->right" cc copyFrom: 1 to: width] ifFalse: ["down->left" "colors are stored in reverse direction when following a line" (cc copyFrom: width + 1 to: cc size) reversed]] ifFalse: ["right->down or left->up transition; need color blend" colorArray := Array new: width. dT := direction x asFloat / (direction x + direction y). (direction x > 0 or: [direction y >= 0]) ifTrue: ["top-right" 1 to: width do: [:i | colorArray at: i put: ((cc at: i) mixed: dT with: (cc at: cc size - i + 1))]] ifFalse: ["bottom-left" 1 to: width do: [:i | colorArray at: i put: ((cc at: cc size - i + 1) mixed: dT with: (cc at: i))]]]. ^colorArray! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'! style: newStyle style == newStyle ifTrue:[^self]. style := newStyle. self releaseCachedState.! ! !ComplexBorder methodsFor: 'drawing' stamp: 'pmm 3/13/2010 11:21'! drawPolyPatchFrom: startPoint to: stopPoint on: aCanvas usingEnds: endsArray | cos sin tfm fill dir fsOrigin fsDirection points x y | dir := (stopPoint - startPoint) normalized. "Compute the rotational transform from (0@0) -> (1@0) to startPoint -> stopPoint" cos := dir dotProduct: (1@0). sin := dir crossProduct: (1@0). "Now get the fill style appropriate for the given direction" fill := self fillStyleForDirection: dir. false ifTrue:[ "Transform the fill appropriately" fill := fill shallowCopy. "Note: Code below is inlined from tfm transformPoint:/transformDirection:" x := fill origin x. y := fill origin y. fsOrigin := ((x * cos) + (y * sin) + startPoint x) @ ((y * cos) - (x * sin) + startPoint y). x := fill direction x. y := fill direction y. fsDirection := ((x * cos) + (y * sin)) @ ((y * cos) - (x * sin)). fill origin: fsOrigin; direction: fsDirection rounded; "NOTE: This is a bug in the balloon engine!!!!!!" normal: nil. aCanvas asBalloonCanvas drawPolygon: endsArray fillStyle: fill. ] ifFalse:[ "Transform the points rather than the fills" tfm := (MatrixTransform2x3 new) a11: cos; a12: sin; a21: sin negated; a22: cos. "Install the start point offset" tfm offset: startPoint. points := endsArray collect:[:pt| tfm invertPoint: pt]. aCanvas asBalloonCanvas transformBy: tfm during:[:cc| cc drawPolygon: points fillStyle: fill. ]. ].! ! !ComplexBorder methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'! isComplex ^true! ! !ComplexBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'! trackColorFrom: aMorph baseColor ifNil:[self color: aMorph raisedColor].! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:06'! computeInsetColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | param := true ifTrue: [ 0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: dark). "darken" colorArray at: colorArray size - i put: (base mixed: param with: light) "brighten"]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/26/2001 23:39'! intersectFrom: startPt with: startDir to: endPt with: endDir "Compute the intersection of two lines. Return nil if either * the intersection does not exist, or * the intersection is 'before' startPt, or * the intersection is 'after' endPt " | det deltaPt alpha beta | det := (startDir x * endDir y) - (startDir y * endDir x). det = 0.0 ifTrue:[^nil]. "There's no solution for it" deltaPt := endPt - startPt. alpha := (deltaPt x * endDir y) - (deltaPt y * endDir x). beta := (deltaPt x * startDir y) - (deltaPt y * startDir x). alpha := alpha / det. beta := beta / det. alpha < 0 ifTrue:[^nil]. beta > 1.0 ifTrue:[^nil]. "And compute intersection" ^(startPt x + (alpha * startDir x)) @ (startPt y + (alpha * startDir y))! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:07'! computeRaisedColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | param := true ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: light). "brighten" colorArray at: colorArray size - i put: (base mixed: param with: dark) "darken"]. ^colorArray! ! !ComplexBorder class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:22'! style: aSymbol ^self new style: aSymbol! ! !ComposableModel commentStamp: ''! ComposableModel is an abstract class which represent a applicative model made to be composed with other ComposableModel! !ComposableModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! eventKeyStrokesForPreviousFocus "String describing the keystroke to perform to jump to the previous widget" ^ keyStrokesForPreviousFocusHolder value! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! window ^ window value ifNil: [ owner ifNil: [ nil ] ifNotNil: [:o | o window ]]! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! askOkToClose ^ askOkToClose value! ! !ComposableModel methodsFor: 'private-focus' stamp: 'BenjaminVanRyseghem 10/4/2013 15:27'! registerKeyStrokesForPreviousFor: aWidget aWidget ifNil: [ ^ self ]. self eventKeyStrokesForPreviousFocus do: [:each | aWidget bindKeyCombination: each toAction: [ self giveFocusToPreviousFrom: self ] ]! ! !ComposableModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! keyStrokesForNextFocus: aCollection keyStrokesForNextFocusHolder value: aCollection! ! !ComposableModel methodsFor: 'widgets' stamp: 'CamilloBruni 9/22/2013 21:32'! newMultiColumnList ^ self instantiate: MultiColumnListModel! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/3/2014 17:42'! aboutText ^ aboutText value ifNil: [ aboutText value: self class comment ]! ! !ComposableModel methodsFor: 'widgets' stamp: 'CamilloBruni 9/22/2013 21:31'! newTextInput ^ self instantiate: TextInputFieldModel! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/22/2013 00:18'! announce: anAnnouncement self announcer announce: anAnnouncement! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/12/2012 14:57'! openWithSpec "Build the widget using the default spec and display it into a window" ^ self openWithSpec: self defaultSpecSelector.! ! !ComposableModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/19/2014 20:38'! initialize super initialize. extentHolder := nil asReactiveVariable. needRebuild := true asReactiveVariable. keyStrokesForNextFocusHolder := { KMNoShortcut new } asReactiveVariable. keyStrokesForPreviousFocusHolder := { KMNoShortcut new } asReactiveVariable. additionalKeyBindings := Dictionary new. announcer := Announcer new asReactiveVariable. aboutText := nil asReactiveVariable. windowIcon := nil asReactiveVariable. window := nil asReactiveVariable. askOkToClose := false asReactiveVariable. titleHolder := self class title asReactiveVariable. self initializeWidgets. self initializePresenter. keyStrokesForNextFocusHolder whenChangedDo: [ self registerKeyStrokesForNextFor: self widget ]. keyStrokesForPreviousFocusHolder whenChangedDo: [ self registerKeyStrokesForPreviousFor: self widget ]. titleHolder whenChangedDo: [ self updateTitle ]! ! !ComposableModel methodsFor: 'testing' stamp: 'ClementBera 9/26/2013 17:36'! hasWindow "Answers true if there is an open window using this model." self owner ifNil: [ ^ self window ifNotNil: [ :w | w isClosed not ] ifNil: [ false ] ]. ^ self owner hasWindow! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 1/10/2014 12:29'! detectMorphicAdapterDo: aBlock ^ self dependents detect: [:e | e isMorphicAdapter ] ifFound: aBlock! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! title: aString titleHolder value: aString! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/19/2013 16:16'! openDialogWithSpec: aSpec "Build the widget using the spec name provided as argument and display it into a window" ^ self openDialogWithSpecLayout: (self retrieveSpec: aSpec)! ! !ComposableModel methodsFor: 'protocol-shortcuts' stamp: 'BenjaminVanRyseghem 11/12/2013 09:40'! bindKeyCombination: aShortcut toAction: aBlock additionalKeyBindings at: aShortcut put: aBlock. self changed: #bindKeyCombination:toAction: with: {aShortcut . aBlock}! ! !ComposableModel methodsFor: 'private-focus' stamp: 'BenjaminVanRyseghem 1/12/2014 16:41'! takeKeyboardFocus self focusOrder ifNotEmpty:[:focus | ^ focus first takeKeyboardFocus ]. ^ self changed: #takeKeyboardFocus with: #()! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! windowIcon ^ windowIcon value! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! aboutText: aString aboutText value: aString! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! needRebuild: aBoolean needRebuild value: aBoolean! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/10/2013 12:22'! heightToDisplayInTree: aTree "Return the width of my representation as a list item" ^ self ensureMorphicAdapterDo: [ :adapter | adapter heightToDisplayInTree: aTree ]! ! !ComposableModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/10/2012 23:21'! initializeWidgets self subclassResponsibility! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/7/2012 12:25'! widget ^ spec ifNil: [ nil ] ifNotNil: [:s | s instance ]! ! !ComposableModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/10/2012 14:58'! initializeDialogWindow: aWindow "used to initialize the model in the case of the use into a dialog window"! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/1/2013 01:10'! setModal: aWindow self changed: #setModal: with: { aWindow }! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! extent ^ extentHolder value! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! openDialogWithSpecLayout: aSpec "Build the widget using the spec name provided as argument and display it into a window" (window value notNil and: [ self needRebuild not ]) ifTrue: [ window value rebuildWithSpec: aSpec ] ifFalse: [ window value: (DialogWindowModel new model: self). window value openWithSpecLayout: aSpec. self initializeDialogWindow: window value. window value updateTitle. self takeKeyboardFocus ]. ^ window value! ! !ComposableModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/21/2013 10:19'! delete window value ifNil: [ self changed: #delete with: #() ] ifNotNil: [ :w | w delete ]! ! !ComposableModel methodsFor: 'protocol-shortcuts' stamp: 'BenjaminVanRyseghem 11/12/2013 10:48'! bindMenuKeyCombination: aShortcut toAction: aBlock additionalKeyBindings at: aShortcut put: aBlock. self changed: #bindMenuKeyCombination:toAction: with: {aShortcut . aBlock}! ! !ComposableModel methodsFor: 'widgets' stamp: 'BenjaminVanRyseghem 10/1/2013 13:50'! newTabManager ^ self instantiate: TabManagerModel! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/20/2013 12:04'! openWithSpec: aSpec "Build the widget using the spec name provided as argument and display it into a window" ^ self openWithSpecLayout: (self retrieveSpec: aSpec)! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/6/2012 18:25'! spec ^ spec! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! askOkToClose: aBoolean askOkToClose value: aBoolean! ! !ComposableModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/12/2012 15:41'! private_buildWithSpec "Build the widget using the default spec" ^ self private_buildWithSpec: self defaultSpecSelector! ! !ComposableModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 2/8/2013 14:21'! whenShortcutsChanged: aBlock "Set a block to value when the shortcuts block has changed" additionalKeyBindings whenChangedDo: aBlock! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 6/5/2013 22:38'! openWorldWithSpec: aSpec "Build the widget using the spec name provided as argument and display it into the world" ^ self openWorldWithSpecLayout: (self retrieveSpec: aSpec)! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/12/2012 14:58'! specSelectors "Return all the spec names" ^ self class specSelectors! ! !ComposableModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 9/29/2013 14:59'! whenBuiltDo: aBlock self announcer on: WidgetBuilt do: aBlock! ! !ComposableModel methodsFor: 'protocol-shortcuts' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! additionalKeyBindings ^ additionalKeyBindings value! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/12/2012 17:43'! isDisplayed "Return true if the widget is currently displayed on screen" ^ self window notNil and: [ self window isDisplayed ]! ! !ComposableModel methodsFor: 'private-focus' stamp: 'BenjaminVanRyseghem 10/4/2013 15:11'! giveFocusToPreviousFrom: aModel | focus | focus := self focusOrder. (focus includes: aModel) ifTrue: [ | index previous | index := (focus indexOf: aModel) - 1. (index > 0) ifTrue: [ previous := focus at: index. previous takeLastKeyboardFocus. ^ true ]]. ^ owner ifNil: [ " I loop " | next | next := focus at: focus size ifAbsent: [ ^ false ]. next takeLastKeyboardFocus. true] ifNotNil: [ owner giveFocusToPreviousFrom: self. true ]! ! !ComposableModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! keyStrokeForNextFocus: aKMShortcut keyStrokesForNextFocusHolder value: { aKMShortcut }! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/10/2012 15:07'! initialExtent ^ nil! ! !ComposableModel methodsFor: 'widgets' stamp: 'CamilloBruni 9/22/2013 21:30'! newLabel ^ self instantiate: LabelModel! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! announcer ^ announcer value! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/10/2013 12:22'! widthToDisplayInList: aList "Return the width of my representation as a list item" ^ self ensureMorphicAdapterDo: [ :adapter | adapter widthToDisplayInList: aList ]! ! !ComposableModel methodsFor: 'widgets' stamp: 'BenjaminVanRyseghem 1/11/2014 22:18'! newImage ^ self instantiate: ImageModel! ! !ComposableModel methodsFor: 'protocol-shortcuts' stamp: 'GuillermoPolito 8/5/2013 10:22'! on: aShortcut do: aBlock self bindKeyCombination: aShortcut toAction: aBlock! ! !ComposableModel methodsFor: 'protocol-shortcuts' stamp: 'BenjaminVanRyseghem 11/12/2013 10:49'! removeMenuKeyCombination: aShortcut additionalKeyBindings removeKey: aShortcut ifAbsent: [ ^ self ]. self changed: #removeMenuKeyCombination: with: { aShortcut }! ! !ComposableModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 5/14/2013 19:25'! whenWindowChanged: aBlock window whenChangedDo: aBlock! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/19/2013 16:15'! buildWithSpec: aSpec "Build the widget using the spec name provided as argument" ^ self buildWithSpecLayout: (self retrieveSpec: aSpec)! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/28/2013 17:12'! centeredRelativeTo: aModel window value ifNotNil: [ :w | w centeredRelativeTo: aModel ]! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/12/2012 14:56'! buildWithSpec "Build the widget using the default spec" ^ self buildWithSpec: self defaultSpecSelector! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/28/2013 17:07'! cancelled ^ self window ifNil: [ false ] ifNotNil: [ :w | w cancelled ]! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 16:14'! apiSelectors ^ self class apiSelectors! ! !ComposableModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/28/2012 11:07'! okToChange ^ owner ifNil: [ self canDiscardEdits ifTrue: [^ true]. self changed: #wantToChange. "Solicit cancel from view" ^ self canDiscardEdits] ifNotNil: [ owner okToChange ]! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! windowIcon: aForm windowIcon value: aForm! ! !ComposableModel methodsFor: 'accessing' stamp: 'StephaneDucasse 3/7/2014 10:50'! defaultWindowModelClass ^ WindowModel! ! !ComposableModel methodsFor: 'protocol-shortcuts' stamp: 'BenjaminVanRyseghem 11/12/2013 10:45'! removeKeyCombination: aShortcut additionalKeyBindings removeKey: aShortcut ifAbsent: [ ^ self ]. self changed: #removeKeyCombination: with: { aShortcut }! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/6/2012 18:26'! spec: aSpec spec := aSpec! ! !ComposableModel methodsFor: 'protocol' stamp: 'StephaneDucasse 3/7/2014 11:10'! openWithSpecLayout: aSpec "Build the widget using the spec name provided as argument and display it into a window" (window value notNil and: [ self needRebuild not ]) ifTrue: [ window value rebuildWithSpecLayout: aSpec ] ifFalse: [ window value: (self defaultWindowModelClass new model: self). window value openWithSpecLayout: aSpec. self takeKeyboardFocus ]. ^ window value! ! !ComposableModel methodsFor: 'private-focus' stamp: 'BenjaminVanRyseghem 10/4/2013 15:17'! registerKeyStrokesForNextFor: aWidget aWidget ifNil: [ ^ self ]. self eventKeyStrokesForNextFocus do: [:each | aWidget bindKeyCombination: each toAction: [ self giveFocusToNextFrom: self ] ]! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/10/2012 15:35'! updateTitle "Update the window title" self window ifNotNil: [:w | w updateTitle ]! ! !ComposableModel methodsFor: 'widgets' stamp: 'CamilloBruni 9/22/2013 21:30'! newRadioButton ^ self instantiate: RadioButtonModel! ! !ComposableModel methodsFor: 'specs' stamp: 'bvr 6/1/2012 17:12'! defaultSpec ^ self class perform: self defaultSpecSelector! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/13/2014 09:17'! ensureExtentFor: widget self extent ifNil: [ self initialExtent ifNotNil: [ :ex | (widget respondsTo: #extent:) ifTrue: [ widget extent: ex ] ] ] ifNotNil: [ :ex | (widget respondsTo: #extent:) ifTrue: [ widget extent: ex ] ]. ! ! !ComposableModel methodsFor: 'private-focus' stamp: ''! handlesKeyboard: evt ^ true! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/10/2013 12:22'! treeRenderOn: aCanvas bounds: drawBounds color: drawColor font: aFont from: aMorph "Specify how this object as a list item should be drawn" ^ self ensureMorphicAdapterDo: [ :adapter | adapter treeRenderOn: aCanvas bounds: drawBounds color: drawColor font: aFont from: aMorph ]! ! !ComposableModel methodsFor: '*Spec-Tools-Editor' stamp: 'BenjaminVanRyseghem 7/11/2012 17:41'! edit WidgetSetter new model: self; openWithSpec.! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/10/2013 12:22'! ensureMorphicAdapterDo: aBlock ^ aBlock value: self ensureMorphicAdapter! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! openWorldWithSpecLayout: aSpec "Build the widget using the spec name provided as argument and display it into the world" (window value notNil and: [ self needRebuild not ]) ifTrue: [ window value rebuildWithSpecLayout: aSpec ] ifFalse: [ window value: (WorldModel new model: self). window value openWithSpecLayout: aSpec. self takeKeyboardFocus ]. ^ window value! ! !ComposableModel methodsFor: 'private' stamp: 'CamilloBruni 5/1/2013 23:30'! defaultSpecSelector self class class withAllSuperclassesDo: [ :class | (((SpecPragmaCollector behavior: class) filter: [ :pragma | pragma keyword = 'spec:' and: [ pragma arguments includes: #default ]]) reset; collected) ifNotEmpty: [ :pragmas | ^ pragmas first method selector ]]. self specSelectors ifNotEmpty: [:col | col size = 1 ifTrue: [ ^ col first ]]. "should use pragmas" ^ #defaultSpec ! ! !ComposableModel methodsFor: 'protocol-announcements' stamp: 'EstebanLorenzano 9/8/2013 16:06'! on: anAnnouncement send: aSelector to: aTarget self announcer on: anAnnouncement send: aSelector to: aTarget! ! !ComposableModel methodsFor: 'widgets' stamp: 'CamilloBruni 9/22/2013 21:30'! newCheckBox ^ self instantiate: CheckBoxModel! ! !ComposableModel methodsFor: 'widgets' stamp: 'BenjaminVanRyseghem 10/1/2013 13:50'! newTab ^ self instantiate: TabModel! ! !ComposableModel methodsFor: 'widgets' stamp: 'CamilloBruni 9/22/2013 21:31'! newSlider ^ self instantiate: SliderModel! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/28/2013 17:17'! centerWidget: aWindow self changed: #centerWidget: with: { aWindow }! ! !ComposableModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! keyStrokeForPreviousFocus: aKMShortcut keyStrokesForPreviousFocusHolder value: { aKMShortcut }! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/10/2013 12:22'! widthToDisplayInTree: aTree "Return the width of my representation as a list item" ^ self ensureMorphicAdapterDo: [ :adapter | adapter widthToDisplayInTree: aTree ]! ! !ComposableModel methodsFor: 'widgets' stamp: 'BenjaminVanRyseghem 10/1/2013 15:01'! newDropList ^ self instantiate: DropListModel! ! !ComposableModel methodsFor: 'widgets' stamp: 'CamilloBruni 9/22/2013 21:31'! newText ^ self instantiate: TextModel! ! !ComposableModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! keyStrokesForPreviousFocus: aCollection keyStrokesForPreviousFocusHolder value: aCollection ! ! !ComposableModel methodsFor: 'widgets' stamp: 'BenjaminVanRyseghem 10/1/2013 13:49'! newList ^ self instantiate: ListModel! ! !ComposableModel methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/11/2012 10:00'! resolveSymbol: aSymbol ^ Smalltalk at: aSymbol! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/26/2012 02:09'! openDialogWithSpec "Build the widget using the default spec and display it into a window" ^ self openDialogWithSpec: self defaultSpecSelector.! ! !ComposableModel methodsFor: 'widgets' stamp: 'CamilloBruni 9/22/2013 21:31'! newTree ^ self instantiate: TreeModel! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/10/2013 12:22'! listRenderOn: aCanvas atRow: aRow bounds: drawBounds color: drawColor backgroundColor: backgroundColor from: aMorph "Specify how this object as a list item should be drawn" ^ self ensureMorphicAdapterDo: [ :adapter | adapter listRenderOn: aCanvas atRow: aRow bounds: drawBounds color: drawColor backgroundColor: backgroundColor from: aMorph ]! ! !ComposableModel methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 7/10/2012 14:59'! createInstanceFor: aClassSymbol "Retrieve the class corresponding to aClassSymbol using the bindings, then create a new instance of theis class" | class | class := self resolveSymbol: aClassSymbol. ^ self instantiate: class.! ! !ComposableModel methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 7/10/2012 15:00'! instantiate: aComposableModelClass "Instantiate a ComposableModel subclass and set its instance owner" ^ aComposableModelClass owner: self! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/19/2013 16:17'! retrieveSpec: aSelector | layout | layout := self class perform: aSelector. layout isSpecLayout ifTrue: [ layout selector: aSelector ]. ^ layout! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! title "Return the window's title" ^ titleHolder value! ! !ComposableModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/26/2012 00:19'! initializePresenter "Used to specify the subwidgets, and/or to bind them together" "By default, do not do anything" extentHolder whenChangedDo: [:ex | self widget ifNotNil: [:widget | (widget respondsTo: #extent:) ifTrue: [ widget extent: ex ]]].! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/26/2012 00:47'! show self widget ifNotNil: [:widget | (widget respondsTo: #show) ifTrue: [ widget show ]].! ! !ComposableModel methodsFor: 'instance creation' stamp: 'PavelKrivanek 8/21/2012 11:05'! instantiateModels: aCollectionOfPairs "Used to instantiate multiple sub widget at once. Take aCollectionOfPairs where each odd element is an inst var name and each even element is a class name, create an instance from the class name and store it into the inst var" (aCollectionOfPairs anySatisfy: [:e | e isKindOf: Association ]) ifTrue: [ aCollectionOfPairs do: [ :a || k v | k := a key. v := a value. self instVarNamed: k asString put: (self createInstanceFor: v) ]] ifFalse: [ aCollectionOfPairs pairsDo: [ :k :v | self instVarNamed: k asString put: (self createInstanceFor: v) ]]! ! !ComposableModel methodsFor: 'window menu' stamp: 'BenjaminVanRyseghem 10/19/2013 15:18'! addMenuItemsToWindowMenu: aMenu "Do nothing"! ! !ComposableModel methodsFor: 'private-focus' stamp: 'GuillermoPolito 8/5/2013 10:21'! ensureKeyBindingsFor: aWidget self registerKeyStrokesForNextFor: aWidget. self registerKeyStrokesForPreviousFor: aWidget. additionalKeyBindings associationsDo: [:association | aWidget bindKeyCombination: association key toAction: association value ]! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/12/2013 10:49'! neglectMenuModel: aMenuModel aMenuModel menuGroups do: [ :group | group menuItems do: [ :item | item shortcut ifNotNil: [ :shortcut | self removeMenuKeyCombination: shortcut ]. item subMenu ifNotNil: [ :subMenu | subMenu neglect: self ] ] ]! ! !ComposableModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! eventKeyStrokesForNextFocus "String describing the keystroke to perform to jump to the next widget" ^ keyStrokesForNextFocusHolder value! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! needRebuild ^ needRebuild value! ! !ComposableModel methodsFor: 'private' stamp: ''! addAll: aWindow withSpec: aSpec aWindow addMorph: (self buildWithSpec: aSpec) frame: (0@0 corner: 1@1).! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 16:13'! apiMethods ^ self class apiMethods! ! !ComposableModel methodsFor: 'private' stamp: ''! update: aParameter self changed: aParameter! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! extent: aPoint ^ extentHolder value: aPoint! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 13:53'! buildWithSpecLayout: aSpecLayout "Build the widget using the spec name provided as argument" | widget | widget := SpecInterpreter interpretASpec: aSpecLayout model: self. widget := widget asWidget. self ensureExtentFor: widget. self ensureKeyBindingsFor: widget. self announce: (WidgetBuilt model: self widget: widget). ^ widget! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 5/14/2013 16:29'! openWorldWithSpec "Build the widget using the default spec and display it into the world" ^ self openWorldWithSpec: self defaultSpecSelector.! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/12/2013 10:49'! applyMenuModel: aMenuModel aMenuModel menuGroups do: [ :group | group menuItems do: [ :item | item shortcut ifNotNil: [ :shortcut | self bindMenuKeyCombination: shortcut toAction: [ item performMenuActionWith: {} ] ]. item subMenu ifNotNil: [ :subMenu | subMenu applyTo: self ] ] ]! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/26/2012 00:47'! hide self widget ifNotNil: [:widget | (widget respondsTo: #hide) ifTrue: [ widget hide ]].! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/28/2013 17:08'! centered window value ifNotNil: [ :w | w centered ]! ! !ComposableModel methodsFor: 'widgets' stamp: 'CamilloBruni 9/22/2013 21:30'! newButton ^ self instantiate: ButtonModel! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/2/2013 14:27'! owner ^ owner! ! !ComposableModel methodsFor: 'accessing' stamp: ''! focusOrder ^ focusOrder ifNil: [ focusOrder := OrderedCollection new ].! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/10/2013 12:22'! beginsWith: aString fromList: aMorph "This method is used bu the list for the search of elements when you are typing directly in the list" ^ self ensureMorphicAdapterDo: [ :adapter | adapter beginsWith: aString fromList: aMorph ]! ! !ComposableModel methodsFor: 'widgets' stamp: 'CamilloBruni 9/22/2013 21:32'! newIconList ^ self instantiate: IconListModel! ! !ComposableModel methodsFor: 'private' stamp: 'CamilloBruni 5/2/2013 00:44'! private_buildWithSpec: aSpec "Build the widget using the spec name provided as argument" | widget | widget := SpecInterpreter private_buildWidgetFor: self withSpec: aSpec. self ensureExtentFor: widget. self ensureKeyBindingsFor: widget. self announce: (WidgetBuilt model: self widget: widget). ^ widget! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/10/2013 12:22'! heightToDisplayInList: aList "Return the width of my representation as a list item" ^ self ensureMorphicAdapterDo: [ :adapter | adapter heightToDisplayInList: aList ]! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/4/2014 17:18:07'! owner: anObject owner := anObject.! ! !ComposableModel methodsFor: 'private-focus' stamp: 'BenjaminVanRyseghem 10/4/2013 15:21'! giveFocusToNextFrom: aModel | focus | focus := self focusOrder. (focus includes: aModel) ifTrue: [ | index next | index := (focus indexOf: aModel) + 1. (index <= focus size) ifTrue: [ next := focus at: index. next takeKeyboardFocus. ^ true ]]. ^ owner ifNil: [ " I loop " | next | next := focus at: 1 ifAbsent: [ ^ false ]. next takeKeyboardFocus. true ] ifNotNil: [ owner giveFocusToNextFrom: self. true ]! ! !ComposableModel methodsFor: 'private-focus' stamp: ''! takeLastKeyboardFocus self focusOrder ifEmpty: [ self takeKeyboardFocus ] ifNotEmpty: [:focus | focus last takeKeyboardFocus ].! ! !ComposableModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 7/9/2012 16:13'! addAll: aWindow withSpecLayout: aSpec aWindow addMorph: (self buildWithSpecLayout: aSpec) frame: (0@0 corner: 1@1).! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/10/2013 12:22'! ensureMorphicAdapter ^ self dependents detect: [:e | e isMorphicAdapter ] ifNone: [ self buildWithSpec ]! ! !ComposableModel methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 1/10/2014 12:29'! detectMorphicAdapterDo: doBlock ifNone: aBlock ^ self dependents detect: [:e | e isMorphicAdapter ] ifFound: doBlock ifNone: aBlock! ! !ComposableModel class methodsFor: 'specs' stamp: 'bvr 6/4/2012 14:35'! defaultSpec ^ self subclassResponsibility! ! !ComposableModel class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:54'! apiMethods | methods class | methods := OrderedCollection new. class := self. [ class = ComposableModel ] whileFalse: [| newMethods | newMethods := ((SpecPragmaCollector behavior: class) filter: [:prg | prg keyword beginsWith: 'api:' ]; reset; collected) collect: [:e | e method ]. newMethods do: [:m | (methods noneSatisfy: [:m2 | m2 selector = m selector ]) ifTrue: [ methods add: m ]]. class := class superclass ]. ^ methods! ! !ComposableModel class methodsFor: 'defaults' stamp: 'BenjaminVanRyseghem 2/7/2014 17:30'! buttonHeight ^ StandardFonts defaultFont height + 12! ! !ComposableModel class methodsFor: 'specs' stamp: ''! title ^ 'Untitled window'! ! !ComposableModel class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 16:13'! apiSelectors ^ self apiMethods collect: #selector! ! !ComposableModel class methodsFor: 'defaults' stamp: 'BenjaminVanRyseghem 2/7/2014 17:31'! buttonWidth ^ (StandardFonts defaultFont widthOfString: 'eilwp') + 44! ! !ComposableModel class methodsFor: 'instance creation' stamp: ''! owner: owner ^ self new owner: owner; yourself! ! !ComposableModel class methodsFor: 'defaults' stamp: 'BenjaminVanRyseghem 2/7/2014 17:31'! toolbarHeight ^ StandardFonts defaultFont height + 12! ! !ComposableModel class methodsFor: 'protocol' stamp: 'CamilloBruni 5/1/2013 23:34'! specSelectors ^ self class withAllSuperclasses gather: [ :class | (((SpecPragmaCollector behavior: class) filter: [ :pragma | pragma keyword = #spec]) reset; collected) collect: [ :pragmas | pragmas method selector ]]! ! !ComposableModel class methodsFor: 'defaults' stamp: 'BenjaminVanRyseghem 2/7/2014 17:30'! inputTextHeight ^ StandardFonts defaultFont height + 12! ! !ComposableMorph commentStamp: 'gvc 5/18/2007 13:32'! Morph with an inset border by default and theme access.! !ComposableMorph methodsFor: 'services' stamp: ''! questionWithoutCancel: aStringOrText "Open a question dialog." ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText "Answer a color chooser with the given selectors." ^self theme newColorChooserIn: self for: aModel getColor: getSel setColor: setSel getEnabled: nil help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newWindowFor: aModel title: titleString "Answer a new window morph." ^self theme newWindowIn: self for: aModel title: titleString! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newGroupbox "Answer a plain groupbox." ^self theme newGroupboxIn: self! ! !ComposableMorph methodsFor: 'services' stamp: ''! deny: aStringOrText "Open a denial dialog." ^self deny: aStringOrText title: 'Access Denied' translated! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText "Answer a color chooser with the given selectors." ^self theme newColorChooserIn: self for: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText "Answer an inremental slider with the given selectors." ^self theme newIncrementalSliderIn: self for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newLabelGroup: labelsAndControls font: aFont labelColor: aColor "Answer a morph laid out with a column of labels and a column of associated controls. Controls having a vResizing value of #spaceFill will cause their row to use #spaceFill also, otherwise #shrinkWrap." ^self theme newLabelGroupIn: self for: labelsAndControls font: aFont labelColor: aColor ! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newCloseButton "Answer a new close button." ^self newCloseButtonFor: self ! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newGroupbox: aString "Answer a groupbox with the given label." ^self theme newGroupboxIn: self label: aString! ! !ComposableMorph methodsFor: 'theme' stamp: ''! theme "Answer the ui theme that provides controls." ^ Smalltalk ui theme! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel getEnabled: enabledSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: 0 max: 1 quantum: nil getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts path: path "Answer the result of a file open dialog with the given title, extensions to show and path." ^self fileOpen: title extensions: exts path: path preview: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: (AlphaImageMorph new image: aForm) help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newPanel "Answer a new panel." ^self theme newPanelIn: self! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newPluggableDialogWindow: title "Answer a new pluggable dialog with the given content." ^self newPluggableDialogWindow: title for: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newSVSelector: aColor help: helpText "Answer a saturation-volume selector with the given color." ^self theme newSVSelectorIn: self color: aColor help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText "Answer a list for the given model." ^self newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: nil help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newMenu "Answer a new menu." ^self theme newMenuIn: self for: self! ! !ComposableMorph methodsFor: 'services' stamp: ''! centeredAlert: aStringOrText title: aString configure: aBlock "Open an alert dialog. Configure the dialog with the 1 argument block before opening modally." ^self theme centeredAlertIn: self text: aStringOrText title: aString configure: aBlock! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newMenuFor: aModel "Answer a new menu." ^self theme newMenuIn: self for: aModel! ! !ComposableMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 09:39'! defaultBorderWidth "Answer the default border width for the receiver." ^ 1! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText "Answer a morph drop list for the given model." ^self theme newMorphDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newAlphaImage: aForm help: helpText "Answer an alpha image morph." ^self theme newAlphaImageIn: self image: aForm help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a checkbox (radio button appearance) with the given label." ^self theme newRadioButtonIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newStack: controls "Answer a morph laid out with a stack of controls." ^self theme newStackIn: self for: controls! ! !ComposableMorph methodsFor: 'services' stamp: ''! chooseFont "Answer the result of a font selector dialog." ^self chooseFont: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector "Answer a text editor for the given model." ^self theme newBasicTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector! ! !ComposableMorph methodsFor: 'services' stamp: ''! message: aStringOrText "Open a message dialog." ^self message: aStringOrText title: 'Information' translated! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a new button." ^self newButtonFor: aModel getState: nil action: actionSel arguments: nil getEnabled: enabledSel label: stringOrText help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText "Answer an alpha channel selector with the given selectors." ^self theme newAlphaSelectorIn: self for: aModel getAlpha: getSel setAlpha: setSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol "Answer a new balloon help with the given contents for aMorph at a given corner." ^self theme newBalloonHelpIn: self contents: aTextStringOrMorph for: aMorph corner: cornerSymbol! ! !ComposableMorph methodsFor: 'services' stamp: ''! chooseDirectory: title path: path "Answer the result of a file dialog with the given title, answer a directory." ^self theme chooseDirectoryIn: self title: title path: path! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector "Answer a text editor for the given model." ^self theme newTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector! ! !ComposableMorph methodsFor: 'services' stamp: ''! longMessage: aStringOrText title: aString "Open a (long) message dialog." ^self theme longMessageIn: self text: aStringOrText title: aString! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newDialogPanel "Answer a new main dialog panel." ^self theme newDialogPanelIn: self! ! !ComposableMorph methodsFor: 'services' stamp: ''! chooseColor: aColor title: title "Answer the result of a color selector dialog with the given title and initial colour." ^self theme chooseColorIn: self title: title color: aColor! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: nil label: stringOrText help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newCancelButtonFor: aModel "Answer a new cancel button." ^self theme newCancelButtonIn: self for: aModel! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newPluggableDialogWindow: title for: contentMorph "Answer a new pluggable dialog with the given content." ^self theme newPluggableDialogWindowIn: self title: title for: contentMorph! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newGroupbox: aString for: control "Answer a groupbox with the given label and control." ^self theme newGroupboxIn: self label: aString for: control! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newOKButton "Answer a new OK button." ^self newOKButtonFor: self! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: aModel label: aString offset: 1 alpha: 0.5 getEnabled: enabledSel! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newYesButton "Answer a new Yes button." ^self newYesButtonFor: self! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText "Answer an editable drop list for the given model." ^self theme newEditableDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText! ! !ComposableMorph methodsFor: 'services' stamp: ''! chooseColor "Answer the result of a color selector dialog ." ^self chooseColor: Color black! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText "Answer a morph drop list for the given model." ^self newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: nil useIndex: true help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText "Answer a list for the given model." ^self theme newListIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newString: aStringOrText font: aFont style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: aFont style: aStyle! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText "Answer a morph drop list for the given model." ^self newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: true help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText "Answer a drop list for the given model." ^self theme newDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newToolbar "Answer a toolbar." ^self theme newToolbarIn: self! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText "Answer a drop list for the given model." ^self newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: nil useIndex: true help: helpText! ! !ComposableMorph methodsFor: 'services' stamp: ''! chooseFont: aFont "Answer the result of a font selector dialog with the given initial font." ^self theme chooseFontIn: self title: 'Font Selector' translated font: aFont! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newCloseButtonFor: aModel "Answer a new close button." ^self theme newCloseButtonIn: self for: aModel! ! !ComposableMorph methodsFor: 'services' stamp: ''! fileSave: title path: path "Answer the result of a file save open dialog with the given title." ^self fileSave: title extensions: nil path: path! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newVerticalSeparator "Answer a vertical separator." ^self theme newVerticalSeparatorIn: self! ! !ComposableMorph methodsFor: 'services' stamp: ''! proceed: aStringOrText "Open a proceed dialog." ^self proceed: aStringOrText title: 'Proceed' translated! ! !ComposableMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/29/2006 18:25'! defaultTitle "Answer the default title label for the receiver." ^'Composite' translated! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newHSVASelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVASelectorIn: self color: aColor help: helpText! ! !ComposableMorph methodsFor: 'services' stamp: ''! chooseColor: aColor "Answer the result of a color selector dialog with the given color." ^self theme chooseColorIn: self title: 'Colour Selector' translated color: aColor! ! !ComposableMorph methodsFor: 'services' stamp: ''! deny: aStringOrText title: aString "Open a denial dialog." ^self theme denyIn: self text: aStringOrText title: aString! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newButtonLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new button text label." ^self theme newButtonLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newPluggableDialogWindow "Answer a new pluggable dialog." ^self newPluggableDialogWindow: 'Dialog'! ! !ComposableMorph methodsFor: 'services' stamp: ''! alert: aStringOrText title: aString configure: aBlock "Open an alert dialog. Configure the dialog with the 1 argument block before opening modally." ^self theme alertIn: self text: aStringOrText title: aString configure: aBlock! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newScrollPaneFor: aMorph "Answer a new scroll pane morph to scroll the given morph." ^self theme newScrollPaneIn: self for: aMorph! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newOKButtonFor: aModel "Answer a new OK button." ^self newOKButtonFor: aModel getEnabled: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newCancelButton "Answer a new cancel button." ^self newCancelButtonFor: self! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newString: aStringOrText style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: aStyle! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newHueSelector: aModel getHue: getSel setHue: setSel help: helpText "Answer a hue selector with the given selectors." ^self theme newHueSelectorIn: self for: aModel getHue: getSel setHue: setSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel ghostText: ghostText getEnabled: enabledSel help: helpText "Answer an editable drop list for the given model." ^self theme newEditableDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: String default: '' ghostText: ghostText getEnabled: enabledSel useIndex: false help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newGroupboxFor: control "Answer a plain groupbox with the given control." ^self theme newGroupboxIn: self for: control! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newOverflowRowForAll: aCollectionOfMorphs "Answer a new overflow row morph that provides a drop down for the given contents that are unable to fit the bounds." ^self theme newOverflowRowIn: self forAll: aCollectionOfMorphs! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newEmbeddedMenu "Answer a new menu." ^self theme newEmbeddedMenuIn: self for: self! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: 0 max: 1 quantum: nil getEnabled: nil help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText! ! !ComposableMorph methodsFor: 'services' stamp: ''! fileOpen: title "Answer the result of a file open dialog with the given title." ^self fileOpen: title extensions: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText "Answer a morph list for the given model." ^self theme newMorphListIn: self for: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'services' stamp: ''! message: aStringOrText title: aString "Open a message dialog." ^self theme messageIn: self text: aStringOrText title: aString! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newTabGroup: labelsAndPages "Answer a tab group with the given tab labels associated with pages." ^self theme newTabGroupIn: self for: labelsAndPages! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newNoButtonFor: aModel "Answer a new No button." ^self theme newNoButtonIn: self for: aModel! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion ! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newImage: aForm size: aPoint "Answer a new image." ^self theme newImageIn: self form: aForm size: aPoint! ! !ComposableMorph methodsFor: 'services' stamp: ''! chooseDropList: aStringOrText list: aList "Open a drop list chooser dialog." ^self chooseDropList: aStringOrText title: 'Choose' translated list: aList! ! !ComposableMorph methodsFor: 'services' stamp: ''! textEntry: aStringOrText title: aString entryText: defaultEntryText "Open a text entry dialog." ^self theme textEntryIn: self text: aStringOrText title: aString entryText: defaultEntryText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newImage: aForm "Answer a new image." ^self theme newImageIn: self form: aForm! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel "Answer a text editor for the given model." ^self newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newImageFor: aModel get: getSel help: helpText "Answer a text entry for the given model." ^self theme newImageIn: self for: aModel get: getSel help: helpText! ! !ComposableMorph methodsFor: 'services' stamp: ''! alert: aStringOrText title: aString "Open an alert dialog." ^self alert: aStringOrText title: aString configure: [:d | ]! ! !ComposableMorph methodsFor: 'services' stamp: ''! alert: aStringOrText "Open an alert dialog." ^self alert: aStringOrText title: 'Alert' translated! ! !ComposableMorph methodsFor: 'services' stamp: ''! proceed: aStringOrText title: aString "Open a proceed dialog and answer true if not cancelled, false otherwise." ^self theme proceedIn: self text: aStringOrText title: aString! ! !ComposableMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/19/2012 17:25'! newWindow "Answer a new window with the receiver as model, except when the receiver is a morph." |w| w := StandardWindow new model: (self isMorph ifFalse: [self]); title: self defaultTitle; addMorph: self fullFrame: LayoutFrame identity; yourself. self borderWidth: 0. ^w! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self theme newAutoAcceptTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newBalloonHelp: aTextStringOrMorph for: aMorph "Answer a new balloon help with the given contents for aMorph at a given corner." ^self theme newBalloonHelpIn: self contents: aTextStringOrMorph for: aMorph corner: #bottomLeft! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector "Answer a new tree morph." ^self theme newTreeIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector! ! !ComposableMorph methodsFor: 'services' stamp: ''! abort: aStringOrText "Open an error dialog." ^self abort: aStringOrText title: 'Error' translated! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newColorPresenterFor: aModel getColor: getSel help: helpText "Answer a color presenter with the given selectors." ^self theme newColorPresenterIn: self for: aModel getColor: getSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText "Answer a bracket slider with the given selectors." ^self theme newBracketSliderIn: self for: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newOKButtonFor: aModel getEnabled: enabledSel "Answer a new OK button." ^self theme newOKButtonIn: self for: aModel getEnabled: enabledSel! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel action: actionSel label: stringOrText help: helpText "Answer a new button." ^self newButtonFor: aModel getState: nil action: actionSel arguments: nil getEnabled: nil label: stringOrText help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText "Answer a morph list for the given model." ^self newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: nil help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newText: aStringOrText "Answer a new text." ^self theme newTextIn: self text: aStringOrText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newNoButton "Answer a new No button." ^self newNoButtonFor: self! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel font: aFont help: helpText ! ! !ComposableMorph methodsFor: 'services' stamp: ''! fileSave: title extensions: exts path: path "Answer the result of a file save dialog with the given title, extensions to show and path." ^self theme fileSaveIn: self title: title extensions: exts path: path! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText "Answer a drop list for the given model." ^self theme newDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: true help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newLabel: aString "Answer a new text label." ^self newLabelFor: nil label: aString getEnabled: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newHSVSelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVSelectorIn: self color: aColor help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newLabelGroup: labelsAndControls "Answer a morph laid out with a column of labels and a column of associated controls. Controls having a vResizing value of #spaceFill will cause their row to use #spaceFill also, otherwise #shrinkWrap." ^self theme newLabelGroupIn: self for: labelsAndControls! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newRow: controls "Answer a morph laid out with a row of controls." ^self theme newRowIn: self for: controls! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newExpander: aString "Answer an expander with the given label." ^self theme newExpanderIn: self label: aString forAll: #()! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel "Answer a text editor for the given model." ^self newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newExpander: aString for: aControl "Answer an expander with the given label and control." ^self theme newExpanderIn: self label: aString forAll: {aControl}! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newTitle: aString for: control "Answer a morph laid out with a column with a title." ^self theme newTitleIn: self label: aString for: control! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newColumn: controls "Answer a morph laid out with a column of controls." ^self theme newColumnIn: self for: controls! ! !ComposableMorph methodsFor: 'services' stamp: ''! question: aStringOrText title: aString "Open a question dialog and answer true if yes, false if no and nil if cancelled." ^self theme questionIn: self text: aStringOrText title: aString! ! !ComposableMorph methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts path: path preview: preview "Answer the result of a file open dialog with the given title, extensions to show, path and preview type." ^self theme fileOpenIn: self title: title extensions: exts path: path preview: preview! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newGroupboxForAll: controls "Answer a plain groupbox with the given controls." ^self theme newGroupboxIn: self forAll: controls! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText "Answer a bracket slider with the given selectors." ^self newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: nil help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newToolDockingBar "Answer a tool docking bar." ^self theme newToolDockingBarIn: self! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newMultistateButton "Answer a new multistate button morph. To be usable it needs to have fill styles assigned to various states along with mouse-up/down actions." ^self theme newMultistateButtonIn: self! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: nil! ! !ComposableMorph methodsFor: 'services' stamp: ''! textEntry: aStringOrText title: aString "Open a text entry dialog." ^self textEntry: aStringOrText title: aString entryText: ''! ! !ComposableMorph methodsFor: 'services' stamp: ''! chooseDirectory: title "Answer the result of a file dialog with the given title, answer a directory." ^self chooseDirectory: title path: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel help: helpText "Answer a text entry for the given model." ^self newTextEntryFor: aModel get: getSel set: setSel class: String getEnabled: nil help: helpText! ! !ComposableMorph methodsFor: 'services' stamp: ''! fileSave: title extensions: exts "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: exts path: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel getLabel: labelSel getEnabled: enabledSel! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newSeparator "Answer an horizontal separator." ^self theme newSeparatorIn: self! ! !ComposableMorph methodsFor: 'services' stamp: ''! fileSave: title "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: nil path: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newWorkArea "Answer a new work area morph." ^self theme newWorkAreaIn: self! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newCloseControlFor: aModel action: aValuable help: helpText "Answer a new cancel button." ^self theme newCloseControlIn: self for: aModel action: aValuable help: helpText! ! !ComposableMorph methodsFor: 'services' stamp: ''! chooseDropList: aStringOrText title: aString list: aList "Open a drop list chooser dialog." ^self theme chooseDropListIn: self text: aStringOrText title: aString list: aList! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion! ! !ComposableMorph methodsFor: 'services' stamp: ''! question: aStringOrText "Open a question dialog." ^self question: aStringOrText title: 'Question' translated! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'services' stamp: ''! textEntry: aStringOrText "Open a text entry dialog." ^self textEntry: aStringOrText title: 'Entry' translated! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText "Answer a list for the given model." ^self theme newListIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newGroupbox: aString forAll: controls "Answer a groupbox with the given label and controls." ^self theme newGroupboxIn: self label: aString forAll: controls! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newExpander: aString forAll: controls "Answer an expander with the given label and controls." ^self theme newExpanderIn: self label: aString forAll: controls! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newString: aStringOrText "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: #plain! ! !ComposableMorph methodsFor: 'services' stamp: ''! questionWithoutCancel: aStringOrText title: aString "Open a question dialog and answer true if yes, false if no and nil if cancelled." ^self theme questionWithoutCancelIn: self text: aStringOrText title: aString! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newButtonLabel: aString "Answer a new button text label." ^self newButtonLabelFor: nil label: aString getEnabled: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newToolbar: controls "Answer a toolbar with the given controls." ^self theme newToolbarIn: self for: controls! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newToolSpacer "Answer a tool spacer." ^self theme newToolSpacerIn: self! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newFuzzyLabel: aString "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: nil label: aString offset: 1 alpha: 0.5 getEnabled: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newRow "Answer a morph laid out as a row." ^self theme newRowIn: self for: #()! ! !ComposableMorph methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts "Answer the result of a file open dialog with the given title and extensions to show." ^self fileOpen: title extensions: exts path: nil! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newStack "Answer a morph laid out as a stack." ^self theme newStackIn: self for: #()! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel! ! !ComposableMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 09:39'! defaultBorderColor "Answer the default border color/fill style for the receiver" ^#inset! ! !ComposableMorph methodsFor: 'services' stamp: ''! chooseFileName: title extensions: exts path: path preview: preview "Answer the result of a file name chooser dialog with the given title, extensions to show, path and preview type." ^self theme chooseFileNameIn: self title: title extensions: exts path: path preview: preview! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText "Answer a checkbox (radio button appearance) with the given label." ^self newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: nil label: stringOrText help: helpText! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newYesButtonFor: aModel "Answer a new yes button." ^self theme newYesButtonIn: self for: aModel! ! !ComposableMorph methodsFor: 'controls' stamp: ''! newToolbarHandle "Answer a toolbar handle." ^self theme newToolbarHandleIn: self! ! !ComposableMorph methodsFor: 'services' stamp: ''! abort: aStringOrText title: aString "Open an error dialog." ^self theme abortIn: self text: aStringOrText title: aString! ! !CompositeBorder commentStamp: 'gvc 5/18/2007 13:28'! Border supporting multiple "sub-borders".! !CompositeBorder methodsFor: 'comparing' stamp: 'gvc 5/18/2007 13:29'! hash "Since #= is overridden." ^super hash bitXor: self borders hash! ! !CompositeBorder methodsFor: 'comparing' stamp: 'gvc 3/29/2007 17:32'! = aBorderStyle "Check the sub-borders too" ^super = aBorderStyle and: [ self borders = aBorderStyle borders]! ! !CompositeBorder methodsFor: 'accessing' stamp: 'gvc 3/12/2007 11:15'! borders "Answer the value of borders" ^ borders! ! !CompositeBorder methodsFor: 'testing' stamp: 'gvc 3/14/2007 10:32'! isComposite "Answer true." ^true! ! !CompositeBorder methodsFor: 'accessing' stamp: 'gvc 3/12/2007 11:15'! borders: anObject "Set the value of borders" borders := anObject! ! !CompositeBorder methodsFor: 'drawing' stamp: 'gvc 3/14/2007 10:47'! frameRectangle: aRectangle on: aCanvas "Draw each border in turn." |r| r := aRectangle. self borders do: [:b | b frameRectangle: r on: aCanvas. r := r insetBy: b width]! ! !CompositeBorder methodsFor: 'accessing' stamp: 'gvc 3/12/2007 12:13'! colorsAtCorners "Return the colors of the first border." ^self borders first colorsAtCorners! ! !CompositeFillStyle commentStamp: 'gvc 9/23/2008 12:05'! Fillstyle supporting compositing of multiple sub-fillstyles.! !CompositeFillStyle methodsFor: 'testing' stamp: 'gvc 3/20/2008 23:07'! isTransparent "Answer whether all of the composited fill styles are transparent." ^self fillStyles allSatisfy: [:fs | fs isTransparent]! ! !CompositeFillStyle methodsFor: 'converting' stamp: 'gvc 5/27/2008 21:02'! asColor "Answer a colour that is a best match to the receiver. Simple approach for the moment." ^self fillStyles ifEmpty: [Color transparent] ifNotEmpty: [self fillStyles last asColor]! ! !CompositeFillStyle methodsFor: 'accessing' stamp: 'gvc 5/27/2008 21:01'! direction "Answer an effective direction of any oriented fill styles. Answer the bottom-right maxima." |dir| dir := nil. self fillStyles reverseDo: [:fs | fs isOrientedFill ifTrue: [ dir := dir ifNil: [fs direction] ifNotNil: [dir max: fs direction]]]. ^dir ifNil: [0@0] "just in case"! ! !CompositeFillStyle methodsFor: 'action' stamp: 'gvc 3/21/2008 17:25'! changeOriginIn: aMorph event: evt "Interactively change the origin of the receiver" | handle | handle := HandleMorph new forEachPointDo:[:pt| self origin: pt. aMorph changed]. evt hand attachMorph: handle. handle startStepping.! ! !CompositeFillStyle methodsFor: 'accessing' stamp: 'gvc 5/27/2008 21:01'! direction: aPoint "Change the effective direction of any oriented fill styles." |delta| delta := aPoint - self direction. self fillStyles reverseDo: [:fs | fs isOrientedFill ifTrue: [ fs direction: fs direction + delta]]! ! !CompositeFillStyle methodsFor: 'accessing' stamp: 'gvc 5/27/2008 21:01'! origin "Answer an effective origin of any oriented fill styles. Answer the top-left minima." |origin| origin := nil. self fillStyles reverseDo: [:fs | fs isOrientedFill ifTrue: [ origin := origin ifNil: [fs origin] ifNotNil: [origin min: fs origin]]]. ^origin ifNil: [0@0] "just in case"! ! !CompositeFillStyle methodsFor: 'testing' stamp: 'gvc 3/20/2008 23:07'! isTranslucent "Answer whether all of the composited fill styles are transparent." ^self fillStyles allSatisfy: [:fs | fs isTranslucent]! ! !CompositeFillStyle methodsFor: 'accessing' stamp: 'gvc 5/27/2008 21:00'! normal "Answer an effective normal of any oriented fill styles. Answer the top-left minima (probably not an accurate assumption)." |normal| normal := nil. self fillStyles reverseDo: [:fs | fs isOrientedFill ifTrue: [ normal := normal ifNil: [fs normal] ifNotNil: [normal min: fs normal]]]. ^normal ifNil: [0@0] "just in case"! ! !CompositeFillStyle methodsFor: 'accessing' stamp: 'gvc 5/27/2008 21:01'! normal: aPoint "Change the effective normal of any oriented fill styles." |delta| aPoint ifNil: [ self fillStyles reverseDo: [:fs | fs isOrientedFill ifTrue: [ fs normal: nil]]. ^self]. delta := aPoint - self normal. self fillStyles reverseDo: [:fs | fs isOrientedFill ifTrue: [ fs normal: fs normal + delta]]! ! !CompositeFillStyle methodsFor: 'accessing' stamp: 'gvc 5/27/2008 21:01'! origin: aPoint "Change the effective origin of any oriented fill styles." |delta| delta := aPoint - self origin. self fillStyles reverseDo: [:fs | fs isOrientedFill ifTrue: [ fs origin: fs origin + delta]] ! ! !CompositeFillStyle methodsFor: 'adding' stamp: 'gvc 3/21/2008 17:25'! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" aMenu add: 'change origin' translated target: self selector: #changeOriginIn:event: argument: aMorph. aMenu add: 'change orientation' translated target: self selector: #changeOrientationIn:event: argument: aMorph.! ! !CompositeFillStyle methodsFor: 'accessing' stamp: 'gvc 3/20/2008 23:05'! fillStyles "Answer the value of fillStyles. The first item in the collection is considered to be topmost when rendered." ^ fillStyles! ! !CompositeFillStyle methodsFor: 'initialization' stamp: 'gvc 3/20/2008 23:02'! initialize "Initialize the receiver." super initialize. self fillStyles: OrderedCollection new! ! !CompositeFillStyle methodsFor: 'testing' stamp: 'gvc 3/20/2008 23:04'! isCompositeFill "Answer whether the receiver is a composite fill. True for kinds of the receiver's class." ^true! ! !CompositeFillStyle methodsFor: 'testing' stamp: 'gvc 5/27/2008 20:38'! isOrientedFill "Answer whether any of the composited fill styles are oriented." self fillStyles reverseDo: [:fs | fs isOrientedFill ifTrue: [^true]]. ^false! ! !CompositeFillStyle methodsFor: 'action' stamp: 'gvc 3/21/2008 17:25'! changeOrientationIn: aMorph event: evt "Interactively change the origin of the receiver" | handle | handle := HandleMorph new forEachPointDo:[:pt| self direction: pt - self origin. self normal: nil. aMorph changed]. evt hand attachMorph: handle. handle startStepping.! ! !CompositeFillStyle methodsFor: 'accessing' stamp: 'gvc 3/21/2008 16:24'! fillStyles: aCollection "Set the value of fillStyles. The first item in the collection is considered to be topmost when rendering." fillStyles := aCollection! ! !CompositeFillStyle methodsFor: 'testing' stamp: 'gvc 5/27/2008 20:37'! isGradientFill "Answer whether any of the composited fill styles are gradients." self fillStyles reverseDo: [:fs | fs isGradientFill ifTrue: [^true]]. ^false! ! !CompositeFillStyle methodsFor: 'action' stamp: 'gvc 5/27/2008 20:32'! fillRectangle: aRectangle on: aCanvas "Fill the given rectangle on the given canvas with the receiver. Render from bottom to top." self fillStyles do: [:fs | fs fillRectangle: aRectangle on: aCanvas]! ! !CompositeFillStyle methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/9/2012 19:10'! asAthensPaintOn: aCanvas ^ AthensCompositePaint new fromFillStyles: fillStyles on: aCanvas! ! !CompositeFillStyle class methodsFor: 'build' stamp: 'gvc 3/21/2008 16:49'! fillStyles: aCollection "Answer a new instance of the receiver with the specfied fill styles." ^self new fillStyles: aCollection! ! !CompositeTransform commentStamp: ''! A composite transform provides the effect of several levels of coordinate transformations.! !CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'! isIdentity ^ globalTransform isIdentity and: [localTransform isIdentity]! ! !CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:00'! asCompositeTransform ^self! ! !CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 17:06'! angle ^ localTransform angle + globalTransform angle! ! !CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 15:40'! offset ^ (self localPointToGlobal: 0@0) negated! ! !CompositeTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:39'! localPointToGlobal: aPoint "Transform aPoint from global coordinates into local coordinates" ^globalTransform localPointToGlobal: (localTransform localPointToGlobal: aPoint)! ! !CompositeTransform methodsFor: 'initialization' stamp: 'di 10/26/1999 17:08'! composedWith: aTransform "Return a new transform that has the effect of transforming points first by the receiver and then by the argument." self isIdentity ifTrue: [^ aTransform]. aTransform isIdentity ifTrue: [^ self]. ^ CompositeTransform new globalTransform: self localTransform: aTransform! ! !CompositeTransform methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! globalTransform: gt localTransform: lt globalTransform := gt. localTransform := lt! ! !CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'! isPureTranslation ^ globalTransform isPureTranslation and: [localTransform isPureTranslation]! ! !CompositeTransform methodsFor: 'transformations' stamp: 'di 10/1/1998 13:51'! invert: aPoint ^ globalTransform invert: (localTransform invert: aPoint)! ! !CompositeTransform methodsFor: 'converting' stamp: 'di 10/26/1999 17:03'! asMorphicTransform "Squash a composite transform down to a simple one" ^ MorphicTransform offset: self offset angle: self angle scale: self scale! ! !CompositeTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:00'! isCompositeTransform ^true! ! !CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 15:39'! scale ^ localTransform scale * globalTransform scale! ! !CompositeTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:20'! transform: aPoint ^ localTransform transform: (globalTransform transform: aPoint)! ! !CompositeTransform methodsFor: 'accessing' stamp: 'ar 11/2/1998 19:45'! inverseTransformation "Return the inverse transformation of the receiver" ^self species new globalTransform: localTransform inverseTransformation localTransform: globalTransform inverseTransformation! ! !CompositeTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:39'! globalPointToLocal: aPoint "Transform aPoint from global coordinates into local coordinates" ^localTransform globalPointToLocal: (globalTransform globalPointToLocal: aPoint)! ! !CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 19:56'! asMatrixTransform2x3 ^globalTransform asMatrixTransform2x3 composedWithLocal: localTransform asMatrixTransform2x3! ! !CompositeTransform class methodsFor: 'instance creation' stamp: 'ls 3/19/2000 16:44'! globalTransform: gt localTransform: lt ^self new globalTransform: gt localTransform: lt! ! !CompositionScanner commentStamp: 'nice 10/6/2013 23:24'! A CompositionScanner measures text and determines where line breaks. Given a rectangular zone on input, it is used to split text in horizontal lines, and produce information about those lines on output (at which index a line starts/stops, which vertical space does the line require, which horizontal space if left for adjusting inter-word spacing, etc...) Instance Variables baseline: baselineAtSpace: lastBreakIsNotASpace: lineHeight: lineHeightAtSpace: nextIndexAfterLineBreak: spaceIndex: spaceX: baseline - the distance between top of line and the base line (that is the bottom of latin characters abcdehiklmnorstuvwx in most fonts) baselineAtSpace - memorize the baseline at last encountered space or other breakable character. This is necessary because the CompositionScanner wants to break line at a breakable character. If a word layout overflows the right margin, the scanner has to roll back and restore the line state to last encountered breakable character. lastBreakIsNotASpace - indicates that the last breakable character was not a space. This is necessary because handling a line break at a space differs from non space. If line break occurs on space, the space won't be displayed in next line. If it's another breakable character, it has to be displayed on next line. lineHeight - the total line height from top to bottom, including inter-line spacing. lineHeightAtSpace - the line height at last encountered space or other breakable character. See baselineAtSpace for explanation. nextIndexAfterLineBreak - the index of character after the last line break that was encountered. spaceIndex - the index of last space or other breakable character that was encountered spaceX - the distance from left of composition zone to left of last encountered space or other breakable character See baselineAtSpace for explanation. Note: if a line breaks on a space, a linefeed or a carriage return, then the space, linefeed or carriage return is integrated in the line. If there is a carriage return - linefeed pair, the pair is integrated to the line as if it were a single line break for compatibility with legacy software.! !CompositionScanner methodsFor: 'testing' stamp: 'cmm 6/13/2010 20:50'! canComputeDefaultLineHeight ^ rightMargin notNil! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'nice 10/2/2013 02:21'! cr "Answer true. Set up values for the text line interval currently being composed." pendingKernX := 0. (lastIndex < text size and: [(text at: lastIndex) = CR and: [(text at: lastIndex+1) = Character lf]]) ifTrue: [lastIndex := lastIndex + 1]. line stop: lastIndex. nextIndexAfterLineBreak := lastIndex + 1. spaceX := destX. lastBreakIsNotASpace := false. line paddingWidth: rightMargin - spaceX. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'nice 10/8/2013 22:32'! wrapAtLastBreakable "Wrap the line before last encountered breakable character." pendingKernX := 0. nextIndexAfterLineBreak := spaceIndex. line stop: spaceIndex - 1. lineHeight := lineHeightAtSpace. baseline := baselineAtSpace. line paddingWidth: rightMargin - spaceX. line internalSpaces: spaceCount. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'nice 9/29/2013 16:12'! columnBreak "Answer true. Set up values for the text line interval currently being composed." pendingKernX := 0. line stop: lastIndex. spaceX := destX. lastBreakIsNotASpace := false. line paddingWidth: rightMargin - spaceX. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'nice 10/6/2013 21:20'! space "Record left x and character index of the space character just encountered. Used for wrap-around. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." spaceX := destX. spaceIndex := lastIndex. lineHeightAtSpace := lineHeight. baselineAtSpace := baseline. spaceCount := spaceCount + 1. lastBreakIsNotASpace := false. destX + spaceWidth > rightMargin ifTrue:[^self crossedX]. destX := spaceX + spaceWidth + kern. lastIndex := lastIndex + 1. ^false ! ! !CompositionScanner methodsFor: 'scanning' stamp: 'nice 10/22/2013 20:50'! composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide "Answer an instance of TextLineInterval that represents the next line in the paragraph." | runLength stopCondition | "Set up margins" leftMargin := lineRectangle left. leftSide ifTrue: [leftMargin := leftMargin + (firstLine ifTrue: [textStyle firstIndent] ifFalse: [textStyle restIndent])]. destX := spaceX := leftMargin. rightMargin := lineRectangle right. rightSide ifTrue: [rightMargin := rightMargin - textStyle rightIndent]. lastIndex := startIndex. "scanning sets last index" destY := lineRectangle top. lineHeight := baseline := 0. "Will be increased by setFont" line := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) rectangle: lineRectangle. self setStopConditions. "also sets font" runLength := text runLengthFor: startIndex. runStopIndex := (lastIndex := startIndex) + (runLength - 1). nextIndexAfterLineBreak := spaceCount := 0. lastBreakIsNotASpace := false. self handleIndentation. leftMargin := destX. line leftMargin: leftMargin. [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin. "See setStopConditions for stopping conditions for composing." self perform: stopCondition] whileFalse. ^ line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading! ! !CompositionScanner methodsFor: 'scanning' stamp: 'tpr 9/25/2013 13:41'! computeDefaultLineHeight "Compute the default line height for a potentially empty text" rightMargin notNil ifTrue: [lastIndex := 1. self setFont. ^ lineHeight + textStyle leading] ifFalse: [^textStyle lineGrid]! ! !CompositionScanner methodsFor: 'accessing' stamp: 'nice 10/2/2013 02:23'! doesTheLineBreaksAfterLastChar ^nextIndexAfterLineBreak > text size! ! !CompositionScanner methodsFor: 'initialize' stamp: 'nice 10/6/2013 21:41'! initialize wantsColumnBreaks := false. super initialize! ! !CompositionScanner methodsFor: 'accessing' stamp: 'ar 1/8/2000 14:35'! rightX "Meaningful only when a line has just been composed -- refers to the line most recently composed. This is a subtrefuge to allow for easy resizing of a composition rectangle to the width of the maximum line. Useful only when there is only one line in the form or when each line is terminated by a carriage return. Handy for sizing menus and lists." ^spaceX! ! !CompositionScanner methodsFor: 'text attributes' stamp: 'ar 1/8/2000 14:36'! setActualFont: aFont "Keep track of max height and ascent for auto lineheight" | descent | super setActualFont: aFont. lineHeight == nil ifTrue: [descent := font descent. baseline := font ascent. lineHeight := baseline + descent] ifFalse: [descent := lineHeight - baseline max: font descent. baseline := baseline max: font ascent. lineHeight := lineHeight max: baseline + descent]! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:54'! endOfRun "Answer true if scanning has reached the end of the paragraph. Otherwise step conditions (mostly install potential new font) and answer false." | runLength | lastIndex = text size ifTrue: [line stop: lastIndex. spaceX := destX. line paddingWidth: rightMargin - destX. ^true] ifFalse: [runLength := (text runLengthFor: (lastIndex := lastIndex + 1)). runStopIndex := lastIndex + (runLength - 1). self setStopConditions. ^false] ! ! !CompositionScanner methodsFor: 'private' stamp: 'nice 10/5/2013 21:02'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. stopConditions := wantsColumnBreaks == true ifTrue: [ColumnBreakStopConditions] ifFalse: [CompositionStopConditions]! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'nice 10/8/2013 22:32'! wrapAtLastSpace "Wrap the line before last encountered space" pendingKernX := 0. nextIndexAfterLineBreak := spaceIndex + 1. alignment = Justified ifTrue: [ "gobble all subsequent spaces" [nextIndexAfterLineBreak <= text size and: [(text at: nextIndexAfterLineBreak) == Space]] whileTrue: [nextIndexAfterLineBreak := nextIndexAfterLineBreak + 1]]. line stop: nextIndexAfterLineBreak - 1. lineHeight := lineHeightAtSpace. baseline := baselineAtSpace. ["remove the space at which we break..." spaceCount := spaceCount - 1. spaceIndex := spaceIndex - 1. "...and every other spaces preceding the one at which we wrap. Double space after punctuation, most likely." spaceCount >= 1 and: [(text at: spaceIndex) = Space]] whileTrue: ["Account for backing over a run which might change width of space." font := text fontAt: spaceIndex withStyle: textStyle. spaceX := spaceX - (font widthOf: Space)]. line paddingWidth: rightMargin - spaceX. line internalSpaces: spaceCount. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'nice 10/8/2013 22:43'! wrapHere "Wrap the line before current character." pendingKernX := 0. nextIndexAfterLineBreak := lastIndex. lastIndex := lastIndex - 1. spaceX := destX. line paddingWidth: rightMargin - destX. line stop: (lastIndex max: line first). ^true! ! !CompositionScanner methodsFor: 'private' stamp: 'nice 10/21/2013 23:22'! placeEmbeddedObject: anchoredMorph | w descent | "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. w := anchoredMorph width. (destX + w > rightMargin and: [(leftMargin + w) <= rightMargin or: [lastIndex > line first]]) ifTrue: ["Won't fit, but would on next line" ^ false]. destX := destX + w + kern. descent := lineHeight - baseline. baseline := baseline max: anchoredMorph height. lineHeight := baseline + descent. ^ true! ! !CompositionScanner methodsFor: '*Multilingual-OtherLanguages' stamp: 'nice 9/29/2013 16:12'! registerBreakableIndex "Record left x and character index of the line-wrappable point. Used for wrap-around in eastern Asian languages." spaceX := destX. lineHeightAtSpace := lineHeight. baselineAtSpace := baseline. spaceIndex := lastIndex. lastBreakIsNotASpace := true.! ! !CompositionScanner methodsFor: 'initialize' stamp: 'RAA 5/7/2001 10:11'! wantsColumnBreaks: aBoolean wantsColumnBreaks := aBoolean! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'nice 10/8/2013 22:42'! crossedX "There is a word that has fallen across the right edge of the composition rectangle. This signals the need for wrapping which is done to the last space that was encountered, as recorded by the space stop condition, or any other breakable character if the language permits so." pendingKernX := 0. lastBreakIsNotASpace ifTrue: ["In some languages line break is possible before a non space." ^self wrapAtLastBreakable]. spaceCount >= 1 ifTrue: ["The common case. there is a space on the line." ^self wrapAtLastSpace]. "Neither internal nor trailing spaces -- almost never happens." self advanceIfFirstCharOfLine. ^self wrapHere! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'tween 4/6/2007 11:15'! tab "Advance destination x according to tab settings in the paragraph's textStyle. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." pendingKernX := 0. destX := textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin. destX > rightMargin ifTrue: [^self crossedX]. lastIndex := lastIndex + 1. ^false ! ! !CompoundTextConverterState commentStamp: ''! This represents the state of CompoundTextConverter.! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'! g1Size ^ g1Size ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'! g1Leading ^ g1Leading ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 14:37'! g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos g0Size := g0. g1Size := g1. g0Leading := g0l. g1Leading := g1l. charSize := cSize. streamPosition := pos. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'! charSize ^ charSize ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:40'! streamPosition: pos streamPosition := pos. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! g0Leading: l g0Leading := l. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! charSize: s charSize := s. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'! g0Size ^ g0Size ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! g0Size: s g0Size := s. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! g1Size: s g1Size := s. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'! g0Leading ^ g0Leading ! ! !CompoundTextConverterState methodsFor: 'printing' stamp: 'yo 11/4/2002 12:31'! printOn: aStream aStream nextPut: $(; nextPutAll: g0Size printString; space; nextPutAll: g1Size printString; space; nextPutAll: g0Leading printString; space; nextPutAll: g1Leading printString; space; nextPutAll: charSize printString; space; nextPutAll: streamPosition printString. aStream nextPut: $). ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'! streamPosition ^ streamPosition ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! g1Leading: l g1Leading := l. ! ! !CompoundTextConverterState class methodsFor: 'instance creation' stamp: 'yo 8/19/2002 17:04'! g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos ^ (self new) g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos ; yourself. ! ! !CompressedBoundaryShape commentStamp: ''! This class represents a very compact representation of a boundary shape. It consists of a number of compressed arrays that can be handled by the balloon engine directly. Due to this, there are certain restrictions (see below). Boundaries are always represented by three subsequent points that define a quadratic bezier segment. It is recommended that for straight line segments the control point is set either to the previous or the next point. Instance variables: points Point storage area leftFills Containing the "left" fill index of each segment rightFills Containing the "right" fill index of each segment lineWidths Containing the line width of each segment lineFills Containing the line fill (e.g., line color) of each segment fillStyles Contains the actual fill styles referenced by the indexes RESTRICTIONS: None of the ShortRunArrays may contain a run of length Zero. Also, due to the use of ShortRunArrays a) you cannot have more than 32768 different fill styles b) you cannot have a line width that exceeds 32768 In case you have trouble with a), try to merge some of the fills into one. You might do so by converting colors to 32bit pixel values. In case you have trouble with b) you might change the general resolution of the compressed shape to have less accuracy. ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! leftFills ^leftFills! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ls 10/10/1999 13:52'! bounds | min max width | points isEmpty ifTrue:[^0@0 corner: 1@1]. min := max := points first. points do:[:pt| min := min min: pt. max := max max: pt ]. width := 0. lineWidths valuesDo:[:w| width := width max: w]. ^(min corner: max) insetBy: (width negated asPoint)! ! !CompressedBoundaryShape methodsFor: 'enumerating' stamp: 'ar 11/9/1998 14:10'! segmentsDo: aBlock "Enumerate all segments in the receiver and execute aBlock" | p1 p2 p3 | 1 to: points size by: 3 do:[:i| p1 := points at: i. p2 := points at: i+1. p3 := points at: i+2. (p1 = p2 or:[p2 = p3]) ifTrue:[ aBlock value: (LineSegment from: p1 to: p3). ] ifFalse:[ aBlock value: (Bezier2Segment from: p1 via: p2 to: p3). ]. ].! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! fillStyles ^fillStyles! ! !CompressedBoundaryShape methodsFor: 'editing' stamp: 'ar 11/12/1998 21:12'! collectFills: aBlock fillStyles := fillStyles collect: aBlock.! ! !CompressedBoundaryShape methodsFor: 'editing' stamp: 'ar 11/12/1998 21:11'! copyAndCollectFills: aBlock ^self copy collectFills: aBlock! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 01:01'! segments "Return all the segments in the receiver" | out | out := Array new writeStream. self segmentsDo:[:seg| out nextPut: seg]. ^out contents! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/4/1998 13:50'! numSegments ^points size // 3! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! lineFills ^lineFills! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! lineWidths ^lineWidths! ! !CompressedBoundaryShape methodsFor: 'private' stamp: 'ar 11/3/1998 18:03'! setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList points := pointList. leftFills := leftFillList. rightFills := rightFillList. lineWidths := lineWidthList. lineFills := lineFillList. fillStyles := fillStyleList.! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! rightFills ^rightFills! ! !CompressedBoundaryShape methodsFor: 'morphing' stamp: 'ar 9/3/1999 17:19'! morphFrom: srcShape to: dstShape at: ratio | scale unscale srcPoints dstPoints pt1 pt2 x y | scale := (ratio * 1024) asInteger. scale < 0 ifTrue:[scale := 0]. scale > 1024 ifTrue:[scale := 1024]. unscale := 1024 - scale. srcPoints := srcShape points. dstPoints := dstShape points. 1 to: points size do:[:i| pt1 := srcPoints at: i. pt2 := dstPoints at: i. x := ((pt1 x * unscale) + (pt2 x * scale)) bitShift: -10. y := ((pt1 y * unscale) + (pt2 y * scale)) bitShift: -10. points at: i put: x@y].! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 20:42'! points ^points! ! !CompressedBoundaryShape class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 18:02'! points: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList ^self new setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList! ! !ConfigurationCommandLineHandler commentStamp: 'TorstenBergmann 2/6/2014 08:17'! Command line handler for dealing with Metacello configurations from the command line Usage: config [--help] [] [--install[=]] [--group=] [--username=] [--password=] --help show this help message A Monticello repository name A valid Metacello Configuration name A valid version for the given configuration A valid Metacello group name An optional username to access the configuration's repository An optional password to access the configuration's repository Examples: # display this help message pharo Pharo.image config # list all configurations of a repository pharo Pharo.image config $MC_REPOS_URL # list all the available versions of a confgurtation pharo Pharo.image config $MC_REPOS_URL ConfigurationOfFoo # install the stable version pharo Pharo.image config $MC_REPOS_URL ConfigurationOfFoo --install #install a specific version '1.5' pharo Pharo.image config $MC_REPOS_URL ConfigurationOfFoo --install=1.5 #install a specific version '1.5' and only a specific group 'Tests' pharo Pharo.image config $MC_REPOS_URL ConfigurationOfFoo --install=1.5 --group=Tests ! !ConfigurationCommandLineHandler methodsFor: 'printing' stamp: 'CamilloBruni 4/6/2013 23:22'! printMetacelloProjectDetails: metacelloProject | versions | self inform: 'Available versions for ', self configurationName. versions := metacelloProject symbolicVersionMap keys asSet. versions addAll: metacelloProject map keys. versions add: #last. "print the found version sorted alphabetically" versions asArray sorted do:[ :key| self stdout nextPutAll: key; lf ]! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 4/6/2013 22:48'! configurationVersion ^ (self hasOption: 'install') ifFalse: [ #stable ] ifTrue: [ self optionAt: 'install' ]! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'DamienCassou 10/2/2013 15:29'! installVersion: aVersionName | metacelloVersion | self inform: 'Installing ', self configurationName, ' ', aVersionName. metacelloVersion := (self metacelloVersion: aVersionName). self handleMergeConflictDuring: [ (self hasOption: 'group') ifTrue: [ metacelloVersion load: self groups ] ifFalse: [ metacelloVersion load ]]. Smalltalk snapshot: true andQuit: true.! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 4/6/2013 23:25'! repositoryUrl ^ repositoryURL ifNil: [ self hasRepositoryUrl ifFalse: [ ^ self defaultRepositoryUrl ]. repositoryURL := self loadRepositoryUrl ]! ! !ConfigurationCommandLineHandler methodsFor: 'testing' stamp: 'CamilloBruni 11/13/2013 17:01'! hasRepositoryUrl ^ self arguments size > 0 and: [ | possibleUrl | possibleUrl := self arguments first. "check if the first argument is some sort of a URL" (possibleUrl includesSubstring: '://') or: [ possibleUrl first = $. ]]! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 4/6/2013 22:56'! configuration | gofer | gofer := self gofer. self hasConfiguration ifTrue: [ gofer package: self configurationName ] ifFalse: [ gofer configuration ]. gofer load. ^ Smalltalk globals at: self configurationName asSymbol! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 10/13/2012 15:46'! errorNoConfigurationsFound self exitFailure: 'No Configurations found in ', repositoryURL asString! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 9/4/2013 16:16'! defaultRepositoryUrl ^ MetacelloConfigurationBrowserPane pharoDistributionRepository! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 14:02'! project ^ self configuration project! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 4/6/2013 22:47'! installConfiguration self installVersion: self configurationVersion! ! !ConfigurationCommandLineHandler methodsFor: 'testing' stamp: 'CamilloBruni 10/13/2012 13:20'! hasConfiguration self flag: 'TODO: should use proper cli parser Coral??'. ^ (self arguments size > 1) and: [ ((self argumentAt: 2) beginsWith: '-') not ]! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 4/6/2013 23:25'! listConfigurations "List possible configurations of the given repository" | configurations | self inform: 'All Configurations found in ', self repositoryUrl. configurations := self loadConfigurationNames. configurations ifEmpty: [ ^ self errorNoConfigurationsFound ]. self printConfigurations: configurations. ^ self exitSuccess! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 10/25/2012 19:24'! metacelloVersion: aVersionName | project | project := self project. ^ [ project version: aVersionName ] on: MetacelloVersionDoesNotExistError do: [ :error | aVersionName = 'last' ifTrue: [ "manual fallback since there is no symbolic name for lastVersion" project lastVersion ] ifFalse: [ "symbols and strings are not equal in Meteacello..." project version: aVersionName asSymbol ]].! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 11/13/2013 17:04'! loadRepositoryUrl | possibleUrl | possibleUrl := self argumentAt: 1. (possibleUrl includesSubstring: '://') ifTrue: [ ^ possibleUrl asUrl ]. ^ possibleUrl asFileReference! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 4/6/2013 23:25'! gofer | username password | username := (self hasOption: 'username') ifTrue: [ self optionAt: 'username' ] ifFalse: [ String new ]. password := (self hasOption: 'password') ifTrue: [ self optionAt: 'password' ] ifFalse: [ String new ]. ^ Gofer new url: self repositoryUrl username: username password: password; yourself! ! !ConfigurationCommandLineHandler methodsFor: 'printing' stamp: 'CamilloBruni 11/2/2012 15:26'! printConfigurations: configurations self inform: (String streamContents: [ :s| s nextPutAll: 'Found '; print: configurations size; nextPutAll: ' Configuration'; nextPutAll: (configurations size = 1 ifTrue: ':' ifFalse: 's:') ]). configurations do: [ :name | self << name. self stdout lf ]. ! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 9/15/2013 17:54'! handleMergeConflictDuring: aLoadBlock [aLoadBlock on: MCMergeOrLoadWarning do: [ :mergeConflict | mergeConflict merge ]] on: MCMergeResolutionRequest do: [ :request | request autoMerge ].! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 10/13/2012 14:02'! listConfigurationDetails "List possible configurations of the given repository" self printMetacelloProjectDetails: self project. ^ self exitSuccess! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 4/6/2013 23:19'! configurationName ^ configurationName ifNil: [ self hasConfiguration ifFalse: [ "Demeters favourite line :(" ^ self gofer configuration references last name ]. configurationName := self argumentAt: 2 ]! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 4/6/2013 22:52'! list (self hasConfiguration or: [ self hasRepositoryUrl ]) ifTrue: [ self listConfigurationDetails ] ifFalse: [ self listConfigurations ]! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 10/13/2012 13:53'! loadConfigurationNames | references configurations | references := self gofer allResolved. references := references collect: #packageName thenSelect: [ :name| name beginsWith: 'ConfigurationOf' ]. ^ references asSet asSortedCollection ! ! !ConfigurationCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 4/6/2013 23:13'! activate self activateHelpWithoutArguments ifTrue: [ ^ self ]. (self hasOption: 'install') ifFalse: [ ^ self list ]. self installConfiguration. ! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'DamienCassou 10/2/2013 15:27'! groups ^ (self optionAt: 'group') subStrings: {$,}! ! !ConfigurationCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 12:51'! description ^ 'Install and inspect Metacello Configurations from the command line'! ! !ConfigurationCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 12:51'! commandName ^ 'config'! ! !ConfigurationCommandLineHandlerTest commentStamp: 'TorstenBergmann 2/6/2014 08:16'! SUnit tests for class ConfigurationCommandLineHandler! !ConfigurationCommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 10/13/2012 13:21'! testHasConfiguration | cli | cli := self command: #('http://ss3.gemstone.com/ss/MetaRepoForPharo20'). self deny: cli hasConfiguration. cli := self command: #('http://ss3.gemstone.com/ss/MetaRepoForPharo20' '--install'). self deny: cli hasConfiguration. cli := self command: #('http://ss3.gemstone.com/ss/MetaRepoForPharo20' 'ConfigurationOfFoo'). self assert: cli hasConfiguration.! ! !ConfigurationCommandLineHandlerTest methodsFor: 'convenience' stamp: 'CamilloBruni 10/13/2012 13:03'! argumentsWith: aCollection ^ CommandLineArguments withArguments: aCollection! ! !ConfigurationCommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 10/13/2012 13:04'! testResponsibility | args | args := self argumentsWith: #('config'). self assert: (ConfigurationCommandLineHandler isResponsibleFor: args).! ! !ConfigurationCommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 10/15/2013 01:20'! testGroups | cli | cli := self command: #('http://ss3.gemstone.com/ss/MetaRepoForPharo20' '--group=foo'). self assertCollection: cli groups equals: {'foo'}. cli := self command: #('http://ss3.gemstone.com/ss/MetaRepoForPharo20' '--group=foo,boo'). self assertCollection: cli groups equals: {'foo' . 'boo'}.! ! !ConfigurationCommandLineHandlerTest methodsFor: 'convenience' stamp: 'CamilloBruni 10/13/2012 13:17'! command: arguments ^ ConfigurationCommandLineHandler commandLine: (self argumentsWith: arguments)! ! !ConfigurationCommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 10/16/2012 12:23'! testListConfigurations self skip: 'Currently quits the image when in non-interactive mode'. self activate: #('config' 'http://ss3.gemstone.com/ss/MetaRepoForPharo20').! ! !ConfigurationCommandLineHandlerTest methodsFor: 'convenience' stamp: 'EstebanLorenzano 5/23/2013 14:37'! activate: arguments ^ PharoCommandLineHandler activateWith: (self argumentsWith: arguments)! ! !ConfigurationGenerator commentStamp: ''! Probably to be removed to use metacello toolbox! !ConfigurationGenerator methodsFor: 'metacello' stamp: 'StephaneDucasse 4/19/2012 18:01'! createDevelopmentVersion self hasAnyBaseline ifFalse: [ UIManager default inform: 'Please, define a baseline first'. ^ self ]. ^ self createVersionForBlessing: #development! ! !ConfigurationGenerator methodsFor: 'metacello' stamp: 'StephaneDucasse 4/19/2012 18:01'! baseLines | existingBaselines | existingBaselines := self configurationClass methods select: [:cm | cm selector beginsWith: 'baseline']. existingBaselines := (existingBaselines collect: [:m | m pragmas first argumentAt: 1]) asSortedCollection. ^ existingBaselines! ! !ConfigurationGenerator methodsFor: 'metacello' stamp: 'StephaneDucasse 4/19/2012 18:01'! createReleaseVersion self hasAnyBaseline ifFalse: [ UIManager default inform: 'Please, define a baseline first'. ^ self ]. ^ self createVersionForBlessing: #release! ! !ConfigurationGenerator methodsFor: 'metacello' stamp: 'StephaneDucasse 4/19/2012 18:01'! configurationClass ^ Smalltalk globals at: workingCopy package name asSymbol ! ! !ConfigurationGenerator methodsFor: 'metacello' stamp: 'StephaneDucasse 4/19/2012 18:01'! createVersionForBlessing: blessingSelector "blessingSelector = #release or #development" | existingVersions msg initialAnswer newVersionNumber selectorName stream dependentPackages mcWorkingCopy | existingVersions := self configurationClass methods select: [:cm | cm selector beginsWith: 'version']. existingVersions := (existingVersions collect: [:m | m pragmas first argumentAt: 1]) asSortedCollection. msg := ''. existingVersions size > 4 ifTrue: [ msg := 'Last 4 versions: ', (existingVersions copyFrom: (existingVersions size - 4) to: existingVersions size) asArray printString, String cr ]. existingVersions size > 0 ifTrue: [ initialAnswer := existingVersions last, '.1' ] ifFalse: [ initialAnswer := '1.0' ]. newVersionNumber := UIManager default request: msg initialAnswer: initialAnswer. newVersionNumber ifNil: [ ^ self ]. selectorName := newVersionNumber copyWithoutAll: '.-'. stream := WriteStream on: String new. stream nextPutAll: 'version'. stream nextPutAll: selectorName. stream nextPutAll: ': spec spec for: #common do: [ spec blessing: ',blessingSelector printString,'. '. self dependentPackages do: [:pName | stream nextPutAll: ' spec package: ''', pName, ''' with: '''. mcWorkingCopy := (MCPackage named: pName) workingCopy. mcWorkingCopy needsSaving ifTrue: [ self inform: 'The configuration you want to save depends on the package ', pName, '. You first need to save this package in order to create the version'. ^ self ]. stream nextPutAll: (mcWorkingCopy ancestry ancestors first name). stream nextPutAll: '''.', String cr ]. stream nextPutAll: ' ].'. self configurationClass compile: stream contents classified: 'versions'. ! ! !ConfigurationGenerator methodsFor: 'metacello' stamp: 'StephaneDucasse 4/19/2012 18:01'! hasAnyBaseline ^ self baseLines notEmpty! ! !ConfigurationGenerator methodsFor: 'metacello' stamp: 'StephaneDucasse 4/19/2012 18:01'! dependentPackages "Return the list of dependent packages for the last baseline" "This method must be rewritten. It is a shame..." | lastBaseLineName lastBaseLineMethod versionConstructor versionSpec possiblePackageNames packageInfos packageNames | lastBaseLineName := self lastBaseLine. packageNames := OrderedCollection new. (self configurationClass project version: lastBaseLineName) record loadDirective packageDirectivesDo: [:directive | packageNames add: directive file ]. ^ packageNames collect: [:p | (p includes: $.) ifTrue: [ (p includes: $-) ifTrue: [ (p copyUpToLast: $-) ] ifFalse: [ (p copyUpTo: $.) ] ] ifFalse: [ p ] ] " lastBaseLineMethod := (self configurationClass methods select: [:cm | cm selector beginsWith: 'baseline']) select: [:cm | cm pragmas first arguments first = lastBaseLineName]. lastBaseLineMethod := lastBaseLineMethod first. " "This does not work!! No idea why!!" " versionConstructor := (Smalltalk at: #MetacelloVersionConstructor) new. self configurationClass new perform: lastBaseLineMethod selector with: versionConstructor. versionSpec := (Smalltalk at: #MetacelloVersionSpec) new. versionConstructor root: versionSpec " "This is probably the ugliest piece of code I ever wrote. There is really nothing to be proud of." " possiblePackageNames := ((lastBaseLineMethod literals select: [ :l | l class == ByteString ]) reject: [:l | l beginsWith: 'http']). packageInfos := PackageInfo allPackages select: [ :pi | possiblePackageNames includes: pi packageName ]. " "packageInfos now contains the package that the lastest baseline depends on" "^ packageInfos collect: #packageName" ! ! !ConfigurationGenerator methodsFor: 'metacello' stamp: 'StephaneDucasse 4/19/2012 18:00'! addMetacelloBaseline | baselineNumber existingBaselines msg selectorName addedPackages package stream packagePattern | "0 -- must have a repository selected" repository isNil ifTrue: [ UIManager default inform: 'Please select a repository and try again'. ^self ]. "1 -- Selecting baseline name" existingBaselines := self baseLines. existingBaselines size > 0 ifTrue: [msg := 'Current baselines:', String cr, (existingBaselines inject: '' into: [:sum :el | sum, el, String cr]), 'Enter a new baseline number'] ifFalse: [msg := 'Enter a new baseline number ("-baseline" will be automatically added)']. baselineNumber := UIManager default request: msg initialAnswer: '1.0'. baselineNumber ifNil: [ ^ self ]. "2 -- add package names" addedPackages := OrderedCollection new. packagePattern := UIManager default request: 'Please enter a pattern to filter package names' initialAnswer: '*'. [ | packageNames workingCopies | packageNames := OrderedCollection new. workingCopies := OrderedCollection new. self workingCopies do: [:pkg | ((packagePattern match: pkg package name) and: [ (addedPackages includes: pkg package name) not ]) ifTrue: [ packageNames add: pkg package name. workingCopies add: pkg ]]. package := UIManager default chooseFrom: packageNames values: workingCopies title: 'Add dependent package (cancel to stop)'. package ifNotNil: [addedPackages add: package package name ] ] doWhileTrue: [ package notNil ]. "3 -- Creating baseline" selectorName := baselineNumber copyWithoutAll: '.-'. stream := WriteStream on: String new. stream nextPutAll: 'baseline'. stream nextPutAll: selectorName. stream nextPutAll: ': spec spec for: #common do: [ spec blessing: #baseline. spec repository: '''. stream nextPutAll: repository description. stream nextPutAll: '''. "spec package: ''Example-Core''; package: ''Example-Tests'' with: [ spec requires: ''Example-Core'' ]" '. addedPackages do: [:pName | stream nextPutAll: ' spec package: ''', pName, '''.', String cr]. stream nextPutAll: ' ].'. self configurationClass compile: stream contents classified: 'baselines'. ! ! !ConfigurationGenerator methodsFor: 'metacello' stamp: 'StephaneDucasse 4/19/2012 18:01'! lastBaseLine ^ self baseLines last! ! !ConfigurationGenerator methodsFor: 'metacello' stamp: 'StephaneDucasse 4/19/2012 18:01'! browseConfiguration self configurationClass browse! ! !ConfigurationNotFound commentStamp: 'ChristopheDemarey 2/24/2014 16:36'! Error raised when a configuration class for a project is not loaded and / or cannot be found!!! !ConfigurationOf commentStamp: 'dkh 5/30/2012 16:31'! You must use a *configuration* when your project is stored in a repository using `.mcz` files. If you are using a source code manager (SCM) like [git][1] and have created a *baseline* (see the [**BaselineOf** class comment][3] for more info) you may use a *configuration* to associate a specific git commit (SHA, branch name, tag name) with a [Metacello version][2]. To create a new Metacello configuration: 1. Create a subclass of the **ConfigurationOf** class. The configuration class for your project should be names by appending the name of your project to the string `ConfigurationOf`. The name of the category and package should be the same as the name of the class: ```Smalltalk ConfigurationOf subclass: #ConfigurationOfExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ConfigurationOfExample' ``` 2. Create a **baselineXXXX:** method where you specify the structure of your project: ```Smalltalk baseline0100: spec spec for: #common do: [ spec repository: 'http://ss3.gemstone.com/ss/Example'. spec package: 'Example-Core'; package: 'Example-Tests' with: [ spec requires: 'Example-Core' ]]. ``` 3. Create a **versionXXXX:** method where you specify the specific versions of the packages to be loaded for this version: ```Smalltalk version01000: spec spec for: #common do: [ spec blessing: #release. spec package: 'Example-Core' with: 'Example-Core'; package: 'Example-Tests' with: 'Example-Tests' ]. ``` 4. Create a Monticello package for your **ConfigurationOf** class and save it in the repository where your packages are stored. [1]: http://git-scm.com/ [2]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#metacello-version-numbers [3]: https://github.com/dalehenrich/metacello-work/blob/master/repository/Metacello-Base.package/BaselineOf.class/README.md ! !ConfigurationOf methodsFor: 'accessing' stamp: 'dkh 5/31/2012 17:57:13'! customProjectAttributes "Edit to return a collection of any custom attributes e.g. for conditional loading: Array with: #'Condition1' with: #'Condition2. For more information see: http://code.google.com/p/metacello/wiki/CustomProjectAttrributes " ^ #()! ! !ConfigurationOf methodsFor: 'accessing' stamp: 'dkh 5/31/2012 17:57:13'! project: aProject project ifNil: [ self class ensureMetacello ]. project := aProject! ! !ConfigurationOf methodsFor: 'private' stamp: 'dkh 5/31/2012 17:57:13'! versionDoesNotExistError: versionStringOrSymbol ((Smalltalk at: #MetacelloSymbolicVersionDoesNotExistError) project: self project versionString: versionStringOrSymbol) signal! ! !ConfigurationOf methodsFor: 'accessing' stamp: 'dkh 5/31/2012 17:57:13'! projectClass ^ MetacelloMCProject! ! !ConfigurationOf methodsFor: 'accessing' stamp: 'dkh 6/22/2012 12:09'! versionNumberClass ^ MetacelloSemanticVersionNumber! ! !ConfigurationOf methodsFor: 'accessing' stamp: 'dkh 6/22/2012 14:31'! project ^ project ifNil: [ "Bootstrap Metacello if it is not already loaded" self class ensureMetacello. project := self projectClass new projectAttributes: self customProjectAttributes. "Create the Metacello project" project versionNumberClass: self versionNumberClass. project class versionConstructorClass on: self project: project. "Construct the project" project loadType: #'linear'. "change to #atomic if desired" project ]! ! !ConfigurationOf methodsFor: 'defaults' stamp: 'dkh 5/31/2012 17:57:13'! bleedingEdge "override if different behavior desired. Use: self versionDoesNotExistError: #bleedingEdge if #bleedingEdge version is disallowed." ^self defaultBleedingEdgeVersion! ! !ConfigurationOf methodsFor: 'defaults' stamp: 'dkh 5/31/2012 17:57:13'! defaultBleedingEdgeVersion | bleedingEdgeVersion | bleedingEdgeVersion := (self project map values select: [ :version | version blessing == #baseline ]) detectMax: [ :version | version ]. bleedingEdgeVersion ifNil: [ ^#'notDefined' ]. ^ bleedingEdgeVersion versionString! ! !ConfigurationOf class methodsFor: 'private' stamp: 'dkh 6/10/2012 22:01'! ensureGoferVersion: goferVersion repositoryUrl: repositoryUrl "load the p=file goferVersion if Gofer isn't loaded or an earlier version of Gofer is currently loaded" | goferVersionNumber wc pName | (Smalltalk at: #'Gofer' ifAbsent: [ ]) == nil ifTrue: [ ^ self bootstrapPackage: goferVersion from: repositoryUrl ]. goferVersionNumber := (goferVersion copyAfterLast: $.) asNumber. wc := [ ((Smalltalk at: #'GoferPackageReference') name: 'Gofer') workingCopy ] on: Error do: [ :ex | ex return: ((Smalltalk at: #'GoferPackageReference') name: 'Gofer-Core') workingCopy ]. pName := wc ancestry ancestors first name. (pName copyAfterLast: $.) asNumber <= goferVersionNumber ifTrue: [ self bootstrapPackage: goferVersion from: repositoryUrl ]! ! !ConfigurationOf class methodsFor: 'private' stamp: 'dkh 9/4/2012 20:50'! retry: aBlock retryCount: retryCount | count | count := 1. [ true ] whileTrue: [ [ aBlock value. ^ self ] on: Error do: [ :ex | count < retryCount ifTrue: [ Transcript cr; show: 'RETRYING AFTER:'; cr; show: ex description printString. (Delay forSeconds: 5) wait ] ifFalse: [ Transcript cr; show: 'FAILED RETRYING:'; cr; show: ex description printString. ex pass ] ]. count := count + 1 ]! ! !ConfigurationOf class methodsFor: 'private' stamp: 'dkh 05/08/2013 11:39'! bootstrapMetacelloFrom: repositoryUrl "Corresponds to version 1.0.0-beta.32.6" "KEEP MetacelloConfigTemplate class>>ensureMetacelloBaseConfiguration in synch!!" | platformPkg | self ensureGoferVersion: 'Gofer-Core-lr.115' repositoryUrl: repositoryUrl. #('Metacello-Core-dkh.678' 'Metacello-MC-dkh.674') do: [ :pkg | self bootstrapPackage: pkg from: repositoryUrl ]. platformPkg := Smalltalk at: #'SystemVersion' ifPresent: [ :cl | | versionString | versionString := cl current version. (versionString beginsWith: 'Squeak') ifTrue: [ (versionString beginsWith: 'Squeak3') ifTrue: [ 'Metacello-Platform.squeak-dkh.5' ] ifFalse: [ 'Metacello-Platform.squeak-dkh.22' ] ] ifFalse: [ (versionString beginsWith: 'Pharo') ifTrue: [ self bootstrapPackage: 'Metacello-PharoCommonPlatform-dkh.2' from: repositoryUrl. (versionString beginsWith: 'Pharo2') ifTrue: [ 'Metacello-Platform.pharo20-dkh.33' ] ifFalse: [ 'Metacello-Platform.pharo-dkh.34' ] ] ] ]. self bootstrapPackage: platformPkg from: repositoryUrl! ! !ConfigurationOf class methodsFor: 'accessing' stamp: 'dkh 5/31/2012 17:57:13'! validate "Check the configuration for Errors, Critical Warnings, and Warnings (see class comment for MetacelloMCVersionValidator for more information). Errors identify specification issues that will result in unexpected behaviour when you load the configuration. Critical Warnings identify specification issues that may result in unexpected behavior when you load the configuration. Warnings identify specification issues that are technically correct, but are worth take a look at." "self validate" self ensureMetacello. ^ ((Smalltalk at: #MetacelloToolBox) validateConfiguration: self debug: #() recurse: false) explore! ! !ConfigurationOf class methodsFor: 'private' stamp: 'dkh 06/28/2013 16:07'! ensureMetacello: loadList "Bootstrap Metacello, retry using alternate repository, if primary repository is not accessible" Smalltalk at: #'MetacelloProject' ifAbsent: [ | version error gofer | (Array with: 'http://smalltalkhub.com/mc/dkh/metacello/main' with: 'http://seaside.gemtalksystems.com/ss/metacello') do: [ :repositoryUrl | "bootstrap Metacello" [ self bootstrapMetacelloFrom: repositoryUrl. Smalltalk at: #'ConfigurationOfMetacello' ifAbsent: [ self retry: [ gofer := (Smalltalk at: #'Gofer') new. gofer perform: #'url:' with: repositoryUrl; perform: #'package:' with: 'ConfigurationOfMetacello'; perform: #'load' ] ]. version := (Smalltalk at: #'ConfigurationOfMetacello') project version: #'previewBootstrap'. version load: loadList. self retry: [ gofer := (Smalltalk at: #'Gofer') new. Smalltalk at: #'ConfigurationOfMetacelloPreview' ifAbsent: [ gofer perform: #'url:' with: repositoryUrl; perform: #'package:' with: 'ConfigurationOfMetacelloPreview'; perform: #'load' ] ]. version := (Smalltalk at: #'ConfigurationOfMetacelloPreview') project version: #'stable'. "load latest from GitHub" version load: loadList. ^ self ] on: Error do: [ :ex | error := ex. Transcript cr; show: 'failed ensureMetacello using '; show: repositoryUrl printString; show: ' : '; show: ex description printString; show: '...retrying'. "try again" ex return: nil ] ]. "shouldn't get here unless the load failed ... throw an error" self error: 'retry with alternate repository failed: ' , error description printString ]! ! !ConfigurationOf class methodsFor: 'private' stamp: 'dkh 9/4/2012 17:09'! retry: aBlock self retry: aBlock retryCount: 3! ! !ConfigurationOf class methodsFor: 'accessing' stamp: 'dkh 5/31/2012 17:57:13'! project ^self new project! ! !ConfigurationOf class methodsFor: 'private' stamp: 'dkh 6/11/2012 11:05'! ensureMetacello "Bootstrap Metacello and load the 'botstrap' group" self ensureMetacello: #('batch')! ! !ConfigurationOf class methodsFor: 'private' stamp: 'dkh 9/4/2012 17:09'! bootstrapPackage: aString from: aPath | repository version | repository := (MCCacheRepository default includesVersionNamed: aString) ifTrue: [ MCCacheRepository default ] ifFalse: [ MCHttpRepository location: aPath user: '' password: '' ]. self retry: [ repository versionReaderForFileNamed: aString , '.mcz' do: [ :reader | version := reader version. version load. version workingCopy repositoryGroup addRepository: repository ] ]! ! !ConfigurationOf class methodsFor: 'unloading Metacello' stamp: 'dkh 5/31/2012 17:57:13'! unloadMetacello "Unload the classes that implement Metacello. Metacello is not needed once a project has been loaded, so it can safely be unloaded." "self unloadMetacello" | gofer | gofer := (Smalltalk at: #Gofer) new. MCWorkingCopy allManagers do: [:wc | ((wc packageName beginsWith: 'Metacello') or: [ wc packageName beginsWith: 'OB-Metacello' ]) ifTrue: [ gofer package: wc packageName ]]. gofer unload.! ! !ConfigurationOfVersionnerTestBitmapCharacterSet commentStamp: ''! Simple Configuration class used to test Versionner behavior. This class is a rename of ConfigurationOfVersionnerTestBitmapCharacterSet-StephaneDucasse.2. ! !ConfigurationOfVersionnerTestBitmapCharacterSet methodsFor: 'baselines' stamp: 'ChristopheDemarey 6/7/2013 14:19'! baseline100: spec spec for: #common do: [ spec blessing: #baseline. spec repository: 'http://smalltalkhub.com/mc/PharoExtras/BitmapCharacterSet/main'. spec description: 'Imported from SqueakSource'. spec package: 'Collections-BitmapCharacterSet'. spec package: 'Collections-Tests-BitmapCharacterSet' with: [spec requires: 'Collections-BitmapCharacterSet']. spec group: 'default' with: #('Core'); group: 'Core' with: #('Collections-BitmapCharacterSet'); group: 'Tests' with: #('Collections-Tests-BitmapCharacterSet'). ].! ! !ConfigurationOfVersionnerTestBitmapCharacterSet methodsFor: 'accessing' stamp: 'ChristopheDemarey 5/24/2013 10:29'! project ^ project ifNil: [ | constructor | "Bootstrap Metacello if it is not already loaded" self class ensureMetacello. "Construct Metacello project" constructor := (Smalltalk at: #MetacelloVersionConstructor) on: self. project := constructor project. project loadType: #linear. "change to #atomic if desired" project ]! ! !ConfigurationOfVersionnerTestBitmapCharacterSet methodsFor: 'symbolic versions' stamp: 'ChristopheDemarey 5/24/2013 10:29'! stable: spec spec for: #'common' version: '1.0'. ! ! !ConfigurationOfVersionnerTestBitmapCharacterSet methodsFor: 'symbolic versions' stamp: 'ChristopheDemarey 5/24/2013 10:28'! development: spec spec for: #'common' version: '1.0' ! ! !ConfigurationOfVersionnerTestBitmapCharacterSet methodsFor: 'versions' stamp: 'ChristopheDemarey 6/7/2013 14:39'! version100: spec spec for: #common do: [ spec blessing: #release. spec description: 'Latest versions from Squeaksource'. spec package: 'Collections-BitmapCharacterSet' with: ' Collections-BitmapCharacterSet-JAA.5'. spec package: 'Collections-Tests-BitmapCharacterSet' with: 'Collections-Tests-BitmapCharacterSet-JAA.5' ] ! ! !ConfigurationOfVersionnerTestBitmapCharacterSet class methodsFor: 'loading' stamp: 'ChristopheDemarey 3/27/2013 16:55'! loadDefault "self loadDefault" ^ self loadMostRecentCoreWithTests! ! !ConfigurationOfVersionnerTestBitmapCharacterSet class methodsFor: 'metacello tool support' stamp: 'ChristopheDemarey 3/27/2013 16:55'! isMetacelloConfig "Answer true and the Metacello tools will operate on you" ^true! ! !ConfigurationOfVersionnerTestBitmapCharacterSet class methodsFor: 'metacello tool support' stamp: 'ChristopheDemarey 3/27/2013 16:55'! metacelloVersion: versionString loads: anArrayOrString "Stash the last version loaded and the list of packages loaded for that version. The list of packages will be used by the tools when doing 'Load Package Version'" LastVersionLoad := versionString -> anArrayOrString! ! !ConfigurationOfVersionnerTestBitmapCharacterSet class methodsFor: 'metacello tool support' stamp: 'ChristopheDemarey 3/27/2013 16:55'! lastMetacelloVersionLoad "Answer the last version loaded and the list of packages loaded for that version." LastVersionLoad == nil ifTrue: [ LastVersionLoad := nil -> 'default' ]. ^LastVersionLoad! ! !ConfigurationOfVersionnerTestBitmapCharacterSet class methodsFor: 'loading' stamp: 'ChristopheDemarey 3/27/2013 16:55'! loadMostRecentCoreWithTests ^self project lastVersion load: #('Core' 'Tests')! ! !ConfigurationOfVersionnerTestBitmapCharacterSet class methodsFor: 'loading' stamp: 'ChristopheDemarey 3/27/2013 16:55'! load "self load" ^self project latestVersion load! ! !ConfigurationOfVersionnerTestBitmapCharacterSet class methodsFor: 'accessing' stamp: 'ChristopheDemarey 3/27/2013 16:55'! project ^self new project! ! !ConfigurationOfVersionnerTestBitmapCharacterSet class methodsFor: 'private' stamp: 'ChristopheDemarey 3/27/2013 16:55'! ensureMetacello "Bootstrap Gofer (if necessary), bootstrap ConfigurationOfMetacello (using old Gofer API), then load the latest version of Metacello itself." Smalltalk at: #MetacelloProject ifAbsent: [ Smalltalk at: #Gofer ifAbsent: [ "Current version of Gofer from which to bootstrap - as of 1.0-beta.21" self bootstrapPackage: 'Gofer-Core-lr.115' from: 'http://seaside.gemstone.com/ss/metacello' ]. Smalltalk at: #Gofer ifPresent: [:goferClass | | gofer | gofer := goferClass new url: 'http://seaside.gemstone.com/ss/metacello'; yourself. [ gofer addPackage: 'ConfigurationOfMetacello' ] on: Warning do: [:ex | ex resume ]. gofer load ]. "load 'default' group of Metacello" (Smalltalk at: #ConfigurationOfMetacello) perform: #load ]! ! !ConfigurationOfVersionnerTestBitmapCharacterSet class methodsFor: 'private' stamp: 'ChristopheDemarey 3/27/2013 16:55'! bootstrapPackage: aString from: aPath | repository version | repository := MCHttpRepository location: aPath user: '' password: ''. repository versionReaderForFileNamed: aString , '.mcz' do: [:reader | version := reader version. version load. version workingCopy repositoryGroup addRepository: repository]! ! !ConfigurationOfVersionnerTestBitmapCharacterSet class methodsFor: 'unloading Metacello' stamp: 'ChristopheDemarey 3/27/2013 16:55'! unloadMetacello Smalltalk at: #ConfigurationOfMetacello ifPresent: [:cls | cls unloadMetacello ]! ! !ConfigurationOfVersionnerTestXMLParserTemplate commentStamp: ''! Simple Configuration class used to test Versionner behavior. This class is a rename of ConfigurationOfXMLParser-StephaneDucasse.11. ! !ConfigurationOfVersionnerTestXMLParserTemplate methodsFor: 'baselines' stamp: 'ChristopheDemarey 6/7/2013 13:57'! baseline10: spec spec for: #common do: [ spec blessing: #baseline; description: 'Copy of ConfigurationOfXMLParser used with Versionner tests.'; author: 'ChristopheDemarey'; timestamp: '27/03/2013'; repository: 'http://www.smalltalkhub.com/mc/PharoExtras/XMLParser/main'. spec project: 'XMLWriter' with: [ spec className: 'ConfigurationOfVersionnerTestXMLWriter'; versionString: #stable; file: 'Versionner-Tests-Resources'; repository: 'http://www.smalltalkhub.com/mc/demarey/Versionner/main'.]. spec project: 'BitmapCharacterSet' with: [ spec className: 'ConfigurationOfVersionnerTestBitmapCharacterSet'; versionString: #stable; file: 'Versionner-Tests-Resources'; repository: 'http://www.smalltalkhub.com/mc/demarey/Versionner/main'.]. spec package: 'VersionnerTestXML-Parser' with: [spec requires: #('BitmapCharacterSet' 'XMLWriter')]. spec package: 'VersionnerTestXML-Tests-Parser' with: [ spec requires: 'VersionnerTestXML-Parser' ]. spec group: 'default' with: #('Core' 'Tests'); "default by default is equivalent to loading 'ALL' the packages still we added explicitly Tests to be loaded" group: 'Core' with: #('VersionnerTestXML-Parser'); group: 'Tests' with: #('VersionnerTestXML-Tests-Parser') ]. ! ! !ConfigurationOfVersionnerTestXMLParserTemplate methodsFor: 'baselines' stamp: 'ChristopheDemarey 2/25/2014 15:20'! baseline20: spec spec for: #common do: [ spec blessing: #baseline; description: 'New baseline to test use of baselines in numbered versions'; author: 'ChristopheDemarey'; timestamp: '25/02/2014'; repository: 'http://www.smalltalkhub.com/mc/PharoExtras/XMLParser/main'. spec project: 'XMLWriter' with: [ spec className: 'ConfigurationOfVersionnerTestXMLWriter'; versionString: #stable; file: 'Versionner-Tests-Resources'; repository: 'http://www.smalltalkhub.com/mc/demarey/Versionner/main'.]. spec project: 'BitmapCharacterSet' with: [ spec className: 'ConfigurationOfVersionnerTestBitmapCharacterSet'; versionString: #stable; file: 'Versionner-Tests-Resources'; repository: 'http://www.smalltalkhub.com/mc/demarey/Versionner/main'.]. spec package: 'VersionnerTestXML-Parser' with: [spec requires: #('BitmapCharacterSet' 'XMLWriter')]. spec package: 'VersionnerTestXML-Tests-Parser' with: [ spec requires: 'VersionnerTestXML-Parser' ]. spec group: 'default' with: #('Core' 'Tests'); "default by default is equivalent to loading 'ALL' the packages still we added explicitly Tests to be loaded" group: 'Core' with: #('VersionnerTestXML-Parser'); group: 'Tests' with: #('VersionnerTestXML-Tests-Parser') ]. ! ! !ConfigurationOfVersionnerTestXMLParserTemplate methodsFor: 'symbolic versions' stamp: 'ChristopheDemarey 3/27/2013 16:28'! stable: spec spec for: #'common' version: '1.1'. ! ! !ConfigurationOfVersionnerTestXMLParserTemplate methodsFor: 'versions' stamp: 'ChristopheDemarey 6/7/2013 14:03'! version101: spec spec for: #common do: [ spec blessing: #release. spec package: 'VersionnerTestXML-Parser' with: 'VersionnerTestXML-Parser-StephaneDucasse.142'; package: 'VersionnerTestXML-Tests-Parser' with: 'VersionnerTestXML-Tests-Parser-StephaneDucasse.15'. ]. ! ! !ConfigurationOfVersionnerTestXMLParserTemplate methodsFor: 'versions' stamp: 'ChristopheDemarey 6/6/2013 12:58'! version100: spec spec for: #common do: [ spec blessing: #release. spec package: 'VersionnerTestXML-Parser' with: 'XML-Parser-NorbertHartl.141'; package: 'VersionnerTestXML-Tests-Parser' with: 'XML-Tests-Parser-JAA.14' ]. ! ! !ConfigurationOfVersionnerTestXMLParserTemplate methodsFor: 'symbolic versions' stamp: 'ChristopheDemarey 3/27/2013 16:28'! development: spec spec for: #'common' version: '1.1'. ! ! !ConfigurationOfVersionnerTestXMLParserTemplate methodsFor: 'accessing' stamp: 'ChristopheDemarey 3/27/2013 16:28'! project ^ project ifNil: [ | constructor | "Bootstrap Metacello if it is not already loaded" self class ensureMetacello. "Construct Metacello project" constructor := (Smalltalk at: #MetacelloVersionConstructor) on: self. project := constructor project. project loadType: #linear. "change to #atomic if desired" project ]! ! !ConfigurationOfVersionnerTestXMLParserTemplate class methodsFor: 'loading' stamp: 'ChristopheDemarey 5/24/2013 10:31'! loadDefault "self loadDefault" ^ self loadMostRecentCoreWithTests! ! !ConfigurationOfVersionnerTestXMLParserTemplate class methodsFor: 'testing' stamp: 'ChristopheDemarey 5/24/2013 10:31'! isMetacelloConfig "Answer true and the Metacello tools will operate on you" ^true! ! !ConfigurationOfVersionnerTestXMLParserTemplate class methodsFor: 'metacello tool support' stamp: 'ChristopheDemarey 5/24/2013 10:32'! metacelloVersion: versionString loads: anArrayOrString "Stash the last version loaded and the list of packages loaded for that version. The list of packages will be used by the tools when doing 'Load Package Version'" LastVersionLoad := versionString -> anArrayOrString! ! !ConfigurationOfVersionnerTestXMLParserTemplate class methodsFor: 'metacello tool support' stamp: 'ChristopheDemarey 5/24/2013 10:31'! lastMetacelloVersionLoad "Answer the last version loaded and the list of packages loaded for that version." LastVersionLoad == nil ifTrue: [ LastVersionLoad := nil -> 'default' ]. ^LastVersionLoad! ! !ConfigurationOfVersionnerTestXMLParserTemplate class methodsFor: 'loading' stamp: 'ChristopheDemarey 5/24/2013 10:31'! loadMostRecentCoreWithTests ^self project lastVersion load: #('Core' 'Tests')! ! !ConfigurationOfVersionnerTestXMLParserTemplate class methodsFor: 'loading' stamp: 'ChristopheDemarey 5/24/2013 10:31'! load "self load" ^self project latestVersion load! ! !ConfigurationOfVersionnerTestXMLParserTemplate class methodsFor: 'accessing' stamp: 'ChristopheDemarey 5/24/2013 10:32'! project ^self new project! ! !ConfigurationOfVersionnerTestXMLParserTemplate class methodsFor: 'private' stamp: 'ChristopheDemarey 5/24/2013 10:31'! ensureMetacello "Bootstrap Gofer (if necessary), bootstrap ConfigurationOfMetacello (using old Gofer API), then load the latest version of Metacello itself." Smalltalk at: #MetacelloProject ifAbsent: [ Smalltalk at: #Gofer ifAbsent: [ "Current version of Gofer from which to bootstrap - as of 1.0-beta.21" self bootstrapPackage: 'Gofer-Core-lr.115' from: 'http://seaside.gemstone.com/ss/metacello' ]. Smalltalk at: #Gofer ifPresent: [:goferClass | | gofer | gofer := goferClass new url: 'http://seaside.gemstone.com/ss/metacello'; yourself. [ gofer addPackage: 'ConfigurationOfMetacello' ] on: Warning do: [:ex | ex resume ]. gofer load ]. "load 'default' group of Metacello" (Smalltalk at: #ConfigurationOfMetacello) perform: #load ]! ! !ConfigurationOfVersionnerTestXMLParserTemplate class methodsFor: 'private' stamp: 'ChristopheDemarey 5/24/2013 10:31'! bootstrapPackage: aString from: aPath | repository version | repository := MCHttpRepository location: aPath user: '' password: ''. repository versionReaderForFileNamed: aString , '.mcz' do: [:reader | version := reader version. version load. version workingCopy repositoryGroup addRepository: repository]! ! !ConfigurationOfVersionnerTestXMLParserTemplate class methodsFor: 'unloading Metacello' stamp: 'ChristopheDemarey 5/24/2013 10:32'! unloadMetacello Smalltalk at: #ConfigurationOfMetacello ifPresent: [:cls | cls unloadMetacello ]! ! !ConfigurationOfVersionnerTestXMLWriter commentStamp: ''! Simple Configuration class used to test Versionner behavior. This class is a rename of ConfigurationOfXMLWriter-StephaneDucasse.29. ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'baselines' stamp: 'ChristopheDemarey 3/27/2013 16:51'! baseline101: spec spec for: #common do: [ spec blessing: #baseline; repository: 'http://www.squeaksource.com/XMLWriter'. spec package: 'Collections-OrderPreservingDictionary' with: [ spec repository: 'http://www.squeaksource.com/OrderPreservingDict']; package: 'Collections-CharacterMap' with: [ spec repository: 'http://www.squeaksource.com/CharacterMap']; package: 'XML-Writer' with: [ spec requires: #('Collections-OrderPreservingDictionary' 'Collections-CharacterMap')]. spec group: 'default' with: #('Core'); group: 'Core' with: #('XML-Writer')].! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'baselines' stamp: 'ChristopheDemarey 3/27/2013 16:51'! baseline200: spec spec for: #common do: [ spec blessing: #baseline; description: 'Migrated to SmalltalkHub and taking into account new configurations of subcomponents'; repository: 'http://smalltalkhub.com/mc/Pharo/XMLWriter/main'. "Does not work without a className: specification spec project: 'OrderPreservingDictionary' with: [ spec versionString: #stable; loads: #('Core'); repository: 'http://smalltalkhub.com/mc/Pharo/OrderPreservingDictionary/main']. spec package: 'XML-Writer' with: [ spec requires: #('OrderPreservingDictionary') ]." spec project: 'OrderPreservingDictionary' with: [ spec className: 'ConfigurationOfOrderPreservingDictionary'; versionString: #stable; loads: #('Core'); repository: 'http://smalltalkhub.com/mc/Pharo/OrderPreservingDictionary/main']. spec package: 'XML-Writer' with: [spec requires: 'OrderPreservingDictionary']. spec group: 'default' with: #('Core'); group: 'Core' with: #('XML-Writer'); group: 'Tests' with: #() ]. "I removed it because it loads an old version of the pckage and this is a nonsense" spec for: #squeakCommon do: [ spec package: 'Collections-Support' with: [ spec repository: 'http://ss3.gemstone.com/ss/Pharo20' ] ]. spec for: #gemstone do: [ spec package: 'Collections-Support' with: [ spec file: 'Collections-Support.g'; repository: 'http://seaside.gemstone.com/ss/XMLSupport' ]; package: 'Collections-Tests-Support' with: [ spec file: 'Collections-Tests-Support.g'; requires: 'Collections-Support'; repository: 'http://seaside.gemstone.com/ss/XMLSupport' ]. spec group: 'Tests' with: #('Collections-Tests-Support') ]! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'symbolic' stamp: 'ChristopheDemarey 3/27/2013 16:51'! stable: spec spec for: #'pharo' version: '2.1.0'. ! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'versions' stamp: 'ChristopheDemarey 3/27/2013 16:51'! version102: spec spec for: #common do: [ spec blessing: #release. spec package: 'Collections-OrderPreservingDictionary' with: 'Collections-OrderPreservingDictionary-JAAyer.1'; package: 'Collections-CharacterMap' with: 'Collections-CharacterMap-JAAyer.1'; package: 'XML-Writer' with: 'XML-Writer-JAAyer.3'].! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'baselines' stamp: 'ChristopheDemarey 3/27/2013 16:51'! baseline104: spec spec for: #common do: [ spec blessing: #baseline; repository: 'http://www.squeaksource.com/XMLWriter'. spec package: 'Collections-OrderPreservingDictionary' with: [ spec repository: 'http://www.squeaksource.com/OrderPreservingDict']; package: 'XML-Writer' with: [ spec requires: #('Collections-OrderPreservingDictionary')]. spec group: 'default' with: #('Core'); group: 'Core' with: #('XML-Writer')]. spec for: #gemstone do: [ spec package: 'Collections-CharacterSet'. spec package: 'XML-Writer' with:[spec requires: #('Collections-CharacterSet')]]! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'symbolic' stamp: 'ChristopheDemarey 3/27/2013 16:51'! development: spec spec for: #'pharo' version: '2.1.0'. ! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'versions' stamp: 'ChristopheDemarey 3/27/2013 16:51'! version100: spec spec for: #common do: [ spec blessing: #release. spec package: 'Collections-CharacterMap' with: 'Collections-CharacterMap-JAAyer.1'; package: 'XML-Writer' with: 'XML-Writer-JAAyer.1'].! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'versions' stamp: 'ChristopheDemarey 3/27/2013 16:51'! version103: spec spec for: #common do: [ spec blessing: #release. spec package: 'Collections-OrderPreservingDictionary' with: 'Collections-OrderPreservingDictionary-JAAyer.5'; package: 'Collections-CharacterMap' with: 'Collections-CharacterMap-JAAyer.1'; package: 'XML-Writer' with: 'XML-Writer-JAAyer.4'].! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'baselines' stamp: 'ChristopheDemarey 3/27/2013 16:51'! baseline100: spec spec for: #common do: [ spec blessing: #baseline; repository: 'http://www.squeaksource.com/XMLWriter'. spec package: 'Collections-CharacterMap' with: [ spec repository: 'http://www.squeaksource.com/CharacterMap']; package: 'XML-Writer' with: [spec requires: 'Collections-CharacterMap']. spec group: 'default' with: #('Core'); group: 'Core' with: #('XML-Writer'); group: 'Tests' with: #()].! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'accessing' stamp: 'ChristopheDemarey 3/27/2013 16:51'! project ^ project ifNil: [ | constructor | "Bootstrap Metacello if it is not already loaded" self class ensureMetacello. "Construct Metacello project" constructor := (Smalltalk at: #MetacelloVersionConstructor) on: self. project := constructor project. project loadType: #linear. "change to #atomic if desired" project ]! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'versions' stamp: 'ChristopheDemarey 3/27/2013 16:51'! version104: spec spec for: #common do: [ spec blessing: #release. spec package: 'Collections-OrderPreservingDictionary' with: 'Collections-OrderPreservingDictionary-JAAyer.6'; package: 'XML-Writer' with: 'XML-Writer-JAAyer.5']. spec for: #gemstone do: [ spec package: 'Collections-CharacterSet' with: 'Collections-CharacterSet-JohanBrichau.1']! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'versions' stamp: 'ChristopheDemarey 3/27/2013 16:51'! version101: spec spec for: #common do: [ spec blessing: #release. spec package: 'Collections-OrderPreservingDictionary' with: 'Collections-OrderPreservingDictionary-JAAyer.1'; package: 'Collections-CharacterMap' with: 'Collections-CharacterMap-JAAyer.1'; package: 'XML-Writer' with: 'XML-Writer-JAAyer.2'].! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'baselines' stamp: 'ChristopheDemarey 3/27/2013 16:51'! baseline210: spec spec for: #common do: [ spec blessing: #baseline; description: 'Adding a test package'; repository: 'http://smalltalkhub.com/mc/Pharo/XMLWriter/main'. spec project: 'OrderPreservingDictionary' with: [ spec className: 'ConfigurationOfOrderPreservingDictionary'; versionString: #stable; loads: #('Core'); repository: 'http://smalltalkhub.com/mc/Pharo/OrderPreservingDictionary/main']. spec package: 'XML-Writer-Core' with: [spec requires: 'OrderPreservingDictionary']. spec package: 'XML-Writer-Tests' with: [spec requires: 'XML-Writer-Core']. spec group: 'default' with: #('Core'); group: 'Core' with: #('XML-Writer-Core'); group: 'Tests' with: #('XML-Writer-Tests')]. "Can only work for Pharo1.4 and 2.0. To be changed when pharo will be managed on SmalltalkHub" spec for: #squeakCommon do: [ spec package: 'Collections-Support' with: [ spec repository: 'http://ss3.gemstone.com/ss/Pharo20' ] ]. "I did not touch this part because Ido not know it. On Pharo XMLWriter has its own repository" spec for: #gemstone do: [ spec package: 'Collections-Support' with: [ spec file: 'Collections-Support.g'; repository: 'http://seaside.gemstone.com/ss/XMLSupport' ]; package: 'Collections-Tests-Support' with: [ spec file: 'Collections-Tests-Support.g'; requires: 'Collections-Support'; repository: 'http://seaside.gemstone.com/ss/XMLSupport' ]. spec group: 'Tests' with: #('Collections-Tests-Support') ]! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'versions' stamp: 'ChristopheDemarey 3/27/2013 16:51'! version105: spec spec for: #common do: [ spec blessing: #release; package: 'Collections-OrderPreservingDictionary' with: 'Collections-OrderPreservingDictionary-JAAyer.6'; package: 'XML-Writer' with: 'XML-Writer-JAAyer.5' ]; for: #squeakCommon do: [ spec package: 'Collections-Support' with: 'Collections-Support-StephaneDucasse.35' ]; for: #gemstone do: [ spec package: 'Collections-Support' with: 'Collections-Support.g-OttoBehrens.45'; package: 'Collections-Tests-Support' with: 'Collections-Tests-Support.g-OttoBehrens.3' ]! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'baselines' stamp: 'ChristopheDemarey 3/27/2013 16:51'! baseline105: spec spec for: #common do: [ spec blessing: #baseline; repository: 'http://www.squeaksource.com/XMLWriter'. spec package: 'Collections-OrderPreservingDictionary' with: [ spec repository: 'http://www.squeaksource.com/OrderPreservingDict' ]; package: 'Collections-Support'; package: 'XML-Writer' with: [ spec requires: #('Collections-Support' 'Collections-OrderPreservingDictionary') ]. spec group: 'default' with: #('Core'); group: 'Core' with: #('XML-Writer'); group: 'Tests' with: #() ]. spec for: #squeakCommon do: [ spec package: 'Collections-Support' with: [ spec repository: 'http://www.squeaksource.com/Pharo' ] ]. spec for: #gemstone do: [ spec package: 'Collections-Support' with: [ spec file: 'Collections-Support.g'; repository: 'http://seaside.gemstone.com/ss/XMLSupport' ]; package: 'Collections-Tests-Support' with: [ spec file: 'Collections-Tests-Support.g'; requires: 'Collections-Support'; repository: 'http://seaside.gemstone.com/ss/XMLSupport' ]. spec group: 'Tests' with: #('Collections-Tests-Support') ]! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'versions' stamp: 'ChristopheDemarey 3/27/2013 16:51'! version210: spec spec for: #common do: [ spec blessing: #release; package: 'XML-Writer-Core' with: 'XML-Writer-Core-StephaneDucasse.1' ; package: 'XML-Writer-Tests' with: 'XML-Writer-Tests-StephaneDucasse.1' ]; " I do not understand the following line because it means that we would load an older version than the one currently in Pharo. Clearly the best way to introduce bugs and losing hours trying to understand why. for: #squeakCommon do: [ spec package: 'Collections-Support' with: 'Collections-Support-StephaneDucasse.35' ];" for: #gemstone do: [ spec package: 'Collections-Support' with: 'Collections-Support.g-OttoBehrens.45'; package: 'Collections-Tests-Support' with: 'Collections-Tests-Support.g-OttoBehrens.3' ]! ! !ConfigurationOfVersionnerTestXMLWriter methodsFor: 'versions' stamp: 'ChristopheDemarey 3/27/2013 16:51'! version200: spec spec for: #common do: [ spec blessing: #release; package: 'XML-Writer' with: 'XML-Writer-JAAyer.5' ]; " I do not understand the following line because it means that we would load an older version than the one currently in Pharo. Clearly the best way to introduce bugs and losing hours trying to understand why. for: #squeakCommon do: [ spec package: 'Collections-Support' with: 'Collections-Support-StephaneDucasse.35' ];" for: #gemstone do: [ spec package: 'Collections-Support' with: 'Collections-Support.g-OttoBehrens.45'; package: 'Collections-Tests-Support' with: 'Collections-Tests-Support.g-OttoBehrens.3' ]! ! !ConfigurationOfVersionnerTestXMLWriter class methodsFor: 'testing' stamp: 'ChristopheDemarey 5/24/2013 10:34'! isMetacelloConfig "Answer true and the Metacello tools will operate on you" ^true! ! !ConfigurationOfVersionnerTestXMLWriter class methodsFor: 'metacello tool support' stamp: 'ChristopheDemarey 5/24/2013 10:34'! metacelloVersion: versionString loads: anArrayOrString "Stash the last version loaded and the list of packages loaded for that version. The list of packages will be used by the tools when doing 'Load Package Version'" LastVersionLoad := versionString -> anArrayOrString! ! !ConfigurationOfVersionnerTestXMLWriter class methodsFor: 'metacello tool support' stamp: 'ChristopheDemarey 5/24/2013 10:34'! lastMetacelloVersionLoad "Answer the last version loaded and the list of packages loaded for that version." LastVersionLoad == nil ifTrue: [ LastVersionLoad := nil -> 'default' ]. ^LastVersionLoad! ! !ConfigurationOfVersionnerTestXMLWriter class methodsFor: 'loading' stamp: 'ChristopheDemarey 5/24/2013 10:34'! load "self load" ^self project latestVersion load! ! !ConfigurationOfVersionnerTestXMLWriter class methodsFor: 'accessing' stamp: 'ChristopheDemarey 5/24/2013 10:34'! project ^self new project! ! !ConfigurationOfVersionnerTestXMLWriter class methodsFor: 'private' stamp: 'ChristopheDemarey 5/24/2013 10:34'! ensureMetacello "Bootstrap Gofer (if necessary), load latest mcz file for ConfigurationOfMetacello (using old Gofer API), then load the latest version of Metacello itself." Smalltalk at: #MetacelloProject ifAbsent: [ | error | "list of repositories to try, in case primary repository is not accessible" (Array with: 'http://www.squeaksource.com/MetacelloRepository' with: 'http://seaside.gemstone.com/ss/metacello') do: [:repositoryUrl | ([ Smalltalk at: #Gofer ifAbsent: [ "Current version of Gofer from which to bootstrap - as of 1.0-beta.21" self bootstrapPackage: 'Gofer-Core-lr.115' from: repositoryUrl ]. Smalltalk at: #Gofer ifPresent: [:goferClass | | gofer | gofer := goferClass new url: repositoryUrl; yourself. [ gofer addPackage: 'ConfigurationOfMetacello' ] on: Warning do: [:ex | ex resume ]. gofer load ]] on: Error do: [ :ex | error := ex. Transcript cr; show: 'failed ensureMetacello: '; show: ex description printString; show: '...retrying'. "try again" ex return: nil ]) ~~ nil ifTrue: [ "load 'default' group of Metacello" (Smalltalk at: #ConfigurationOfMetacello) perform: #load. ^self ]]. "shouldn't get here unless the load failed ... throw an error" self error: 'retry with alternate repository failed: ', error description printString ]! ! !ConfigurationOfVersionnerTestXMLWriter class methodsFor: 'private' stamp: 'ChristopheDemarey 5/24/2013 10:34'! bootstrapPackage: aString from: aPath | repository version | repository := MCHttpRepository location: aPath user: '' password: ''. repository versionReaderForFileNamed: aString , '.mcz' do: [:reader | version := reader version. version load. version workingCopy repositoryGroup addRepository: repository]! ! !ConfigurationOfVersionnerTestXMLWriter class methodsFor: 'unloading Metacello' stamp: 'ChristopheDemarey 5/24/2013 10:35'! unloadMetacello Smalltalk at: #ConfigurationOfMetacello ifPresent: [:cls | cls unloadMetacello ]! ! !ConnectionClosed commentStamp: 'mir 5/12/2003 18:12'! Signals a prematurely closed connection. ! !ConnectionQueue commentStamp: ''! A ConnectionQueue listens on a given port number and collects a queue of client connections. In order to handle state changes quickly, a ConnectionQueue has its own process that: (a) tries to keep a socket listening on the port whenever the queue isn't already full of connections and (b) prunes stale connections out of the queue to make room for fresh ones. ! !ConnectionQueue methodsFor: 'private' stamp: 'SvenVanCaekenberghe 1/16/2012 11:41'! listenLoop "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." "Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms. Fixed to not accept the connection if the queue is full (gvc)." | newConnection | socket := Socket newTCP. "We'll accept four simultanous connections at the same time" socket listenOn: portNumber backlogSize: 4. "If the listener is not valid then the we cannot use the BSD style accept() mechanism." socket isValid ifFalse: [^self oldStyleListenLoop]. [true] whileTrue: [ socket isValid ifFalse: [ "socket has stopped listening for some reason" socket destroy. (Delay forMilliseconds: 10) wait. ^self listenLoop ]. [newConnection := socket waitForAcceptFor: 10] on: ConnectionTimedOut do: [:ex | newConnection := nil]. (newConnection notNil and: [newConnection isConnected]) ifTrue: [(accessSema critical: [connections size < maxQueueLength]) ifFalse: [newConnection close. newConnection := nil]] ifFalse: [newConnection := nil]. (newConnection notNil and: [newConnection isConnected]) ifTrue: [ accessSema critical: [connections addLast: newConnection]. newConnection := nil. self changed]. self pruneStaleConnections]. ! ! !ConnectionQueue methodsFor: 'private' stamp: 'jm 3/10/98 11:07'! initPortNumber: anInteger queueLength: queueLength "Private!! Initialize the receiver to listen on the given port number. Up to queueLength connections will be queued." portNumber := anInteger. maxQueueLength := queueLength. connections := OrderedCollection new. accessSema := Semaphore forMutualExclusion. socket := nil. process := [self listenLoop] newProcess. process priority: Processor highIOPriority. process resume. ! ! !ConnectionQueue methodsFor: 'public' stamp: 'nice 12/26/2009 01:23'! connectionCount "Return an estimate of the number of currently queued connections. This is only an estimate since a new connection could be made, or an existing one aborted, at any moment." self pruneStaleConnections. ^accessSema critical: [connections size]! ! !ConnectionQueue methodsFor: 'public' stamp: 'jm 3/9/98 14:34'! destroy "Terminate the listener process and destroy all sockets in my possesion." process ifNotNil: [ process terminate. process := nil]. socket ifNotNil: [ socket destroy. socket := nil]. connections do: [:s | s destroy]. connections := OrderedCollection new. ! ! !ConnectionQueue methodsFor: 'public' stamp: 'nice 12/26/2009 01:24'! getConnectionOrNil "Return a connected socket, or nil if no connection has been established." ^accessSema critical: [ | result | connections isEmpty ifTrue: [result := nil] ifFalse: [ result := connections removeFirst. ((result isValid) and: [result isConnected]) ifFalse: [ "stale connection" result destroy. result := nil]]. result]! ! !ConnectionQueue methodsFor: 'public' stamp: 'ls 9/26/1999 15:34'! isValid ^process notNil! ! !ConnectionQueue methodsFor: 'private' stamp: 'nice 12/26/2009 01:25'! pruneStaleConnections "Private!! The client may establish a connection and then disconnect while it is still in the connection queue. This method is called periodically to prune such sockets out of the connection queue and make room for fresh connections." accessSema critical: [ | foundStaleConnection | foundStaleConnection := false. connections do: [:s | s isUnconnected ifTrue: [ s destroy. foundStaleConnection := true]]. foundStaleConnection ifTrue: [ connections := connections select: [:s | s isValid]]]. ! ! !ConnectionQueue methodsFor: 'public' stamp: 'nice 12/26/2009 01:25'! getConnectionOrNilLenient "Return a connected socket, or nil if no connection has been established." ^accessSema critical: [ | result | connections isEmpty ifTrue: [ result := nil ] ifFalse: [ result := connections removeFirst. (result isValid and: [result isConnected or: [result isOtherEndClosed]]) ifFalse: [ "stale connection" result destroy. result := nil ] ]. result ]. ! ! !ConnectionQueue methodsFor: 'private' stamp: 'mir 5/15/2003 18:28'! oldStyleListenLoop "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." "Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms." [true] whileTrue: [ ((socket == nil) and: [connections size < maxQueueLength]) ifTrue: [ "try to create a new socket for listening" socket := Socket createIfFail: [nil]]. socket == nil ifTrue: [(Delay forMilliseconds: 100) wait] ifFalse: [ socket isUnconnected ifTrue: [socket listenOn: portNumber]. [socket waitForConnectionFor: 10] on: ConnectionTimedOut do: [:ex | socket isConnected ifTrue: [ "connection established" accessSema critical: [connections addLast: socket]. socket := nil] ifFalse: [ socket isWaitingForConnection ifFalse: [socket destroy. socket := nil]]]]. "broken socket; start over" self pruneStaleConnections]. ! ! !ConnectionQueue class methodsFor: 'instance creation' stamp: 'jm 3/9/98 14:09'! portNumber: anInteger queueLength: queueLength ^ self new initPortNumber: anInteger queueLength: queueLength ! ! !ConnectionRefused commentStamp: 'mir 5/12/2003 18:14'! Signals that a connection to the specified host and port was refused. host host which refused the connection port prot to which the connection was refused ! !ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:58'! port ^ port! ! !ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:39'! host: addressOrHostName port: portNumber host := addressOrHostName. port := portNumber! ! !ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:58'! host ^ host! ! !ConnectionRefused class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:39'! host: addressOrHostName port: portNumber ^ self new host: addressOrHostName port: portNumber! ! !ConnectionTimedOut commentStamp: 'mir 5/12/2003 18:14'! Signals that a connection attempt timed out. ! !ContainerModel commentStamp: ''! I am a model for a container. My purpose is to hold multiple subwidgets to glue them together. I should not be used directly! !ContainerModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! eventKeyStrokesForPreviousFocus "String describing the keystroke to perform to jump to the previous widget" ^ keyStrokesForPreviousFocusHolder value! ! !ContainerModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/24/2014 14:56'! buildAdapterWithSpec "Build the widget using the spec name provided as argument" | adapter widget aSpecLayout | aSpecLayout := (self retrieveSpec: self defaultSpecSelector). adapter := SpecInterpreter private_interpretASpec: aSpecLayout model: self selector: self defaultSpecSelector. widget := adapter widget. self ensureExtentFor: widget. self ensureKeyBindingsFor: widget. self announce: (WidgetBuilt model: self widget: widget). ^ adapter! ! !ContainerModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! eventKeyStrokesForNextFocus "String describing the keystroke to perform to jump to the next widget" ^ keyStrokesForNextFocusHolder value! ! !ContainerModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 13:38'! defaultSpec ^ #(ContainerAdapter adapt: #(model))! ! !ContainerModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:20'! adapterName ^ #ContainerAdapter! ! !ContextCompilationTest commentStamp: 'TorstenBergmann 1/31/2014 11:24'! SUnit tests for context compilation ! !ContextCompilationTest methodsFor: 'tests' stamp: 'eem 6/19/2008 10:11'! testVariablesAndOffsetsDo "ContextCompilationTest new testVariablesAndOffsetsDo" | contextClasses | contextClasses := ContextPart withAllSuperclasses, ContextPart allSubclasses asArray. contextClasses do: [:class| class variablesAndOffsetsDo: [:var :offset| self assert: offset < 0. self assert: (class instVarNameForIndex: offset negated) == var]]. InstructionStream withAllSuperclasses, InstructionStream allSubclasses asArray do: [:class| (contextClasses includes: class) ifFalse: [class variablesAndOffsetsDo: [:var :offset| (InstructionStream instVarNames includes: var) ifFalse: [self assert: offset > 0. self assert: (class instVarNameForIndex: offset) == var]]]]! ! !ContextPart commentStamp: ''! Instance variables: stackp: amount of stack that is occupied To the instruction parsing ability of InstructionStream I add the actual semantics for execution. The execution state is stored in the indexable fields of my subclasses. This includes temporary variables and a stack of values used in evaluating expressions. The actual semantics of execution can be found in my category "system simulation" and "instruction decode". These methods exactly parallel the operation of the Smalltalk machine itself. The simulator is a group of my methods that do what the Smalltalk interpreter does: execute Smalltalk bytecodes. By adding code to the simulator, you may take statistics on the running of Smalltalk methods. For example, Transcript show: (ContextPart runSimulated: [3 factorial]) printString. --------------------- A mechanism for registering a custom primitive simulators added. To register own simulator use: #simulatePrimitiveNumber: num with: simulator for numbered primitives , and #simulatePrimitive: primName module: moduleName with: simulator for named primitives. During (re)initialization, a ContextPart class sends a #registerPrimitiveSimulators to all classes in system, which implementing it (but not to implementor's subclasses). This can be used to make sure that your custom simulator is present. Hence, it is recommended to place registration code in #registerPrimitiveSimulators implementation for one of your classes. In order to make sure that simulator(s) registered during package loading, make sure that one of your classes registering them (via class initialization mechanism). A simulator can be any object which implements the: #simulatePrimitiveFor:receiver:arguments:context: and should simulate the invocation of corresponding primitive. If simulated primitive fails, a simulator should answer PrimitiveFailToken. If primitive succeeds, it should answer a primitive return value. ! !ContextPart methodsFor: 'mirror primitives' stamp: 'CamilloBruni 7/17/2013 21:40'! objectSize: anObject "Answer the number of indexable variables in the argument anObject without sending it a message. This mimics the action of the VM when it fetches an object's variable size. Used to simulate the execution machinery by, for example, the debugger. Primitive. See Object documentation whatIsAPrimitive." "The number of indexable fields of fixed-length objects is 0" ^ 0! ! !ContextPart methodsFor: 'debugger access' stamp: 'CamilloBruni 7/17/2013 21:56'! tempsAndValues "Return a string of the temporary variabls and their current values" ^ String streamContents: [ :aStream | self tempNames doWithIndex: [ :title :index | aStream nextPutAll: title; nextPut: $:; space; tab. self print: (self namedTempAt: index) on: aStream. aStream cr ]].! ! !ContextPart methodsFor: 'special context access' stamp: 'CamilloBruni 7/17/2013 21:28'! unwindBlock "unwindContext only. access temporaries from BlockClosure>>#ensure: and BlockClosure>>#ifCurtailed:" ^self tempAt: 1 ! ! !ContextPart methodsFor: 'system simulation' stamp: 'CamilloBruni 7/17/2013 21:27'! quickStep "If the next instruction is a send, just perform it. Otherwise, do a normal step." self willSend ifTrue: [ QuickStep := self ]. ^self step! ! !ContextPart methodsFor: 'debugger access' stamp: 'ajh 9/25/2001 00:12'! contextStack "Answer an Array of the contexts on the receiver's sender chain." ^self stackOfSize: 100000! ! !ContextPart methodsFor: 'debugger access' stamp: 'eem 7/17/2008 14:49'! namedTempAt: index "Answer the value of the temp at index in the receiver's sequence of tempNames." ^self debuggerMap namedTempAt: index in: self! ! !ContextPart methodsFor: 'query' stamp: 'eem 11/26/2008 20:21'! isContext ^true! ! !ContextPart methodsFor: 'printing' stamp: 'CamilloBruni 2/13/2012 18:08'! debugStackOn: aStream "print the top ten contexts on my sender chain." ^ self debugStack: 100 on: aStream! ! !ContextPart methodsFor: 'system simulation' stamp: 'MarcusDenker 11/18/2013 16:10'! stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." | context | [ self willSend or: [ self willReturn or: [ self willStore or: [self willCreateBlock ] ] ] ] whileFalse: [ context := self step. context == self ifFalse: [ "Caused by mustBeBoolean handling" ^context ]]! ! !ContextPart methodsFor: 'printing' stamp: 'MarianoMartinezPeck 8/23/2012 09:56'! shortDebugStackOn: aStream "print the top 30 contexts on my sender chain." ^ self debugStack: 30 on: aStream! ! !ContextPart methodsFor: 'accessing' stamp: ''! home "Answer the context in which the receiver was defined." self subclassResponsibility! ! !ContextPart methodsFor: 'private' stamp: 'ajh 6/29/2003 15:32'! cannotReturn: result to: homeContext "The receiver tried to return result to homeContext that no longer exists." ^ BlockCannotReturn new result: result; deadHome: homeContext; signal! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 21:29'! isHandlerContext ^false! ! !ContextPart methodsFor: 'controlling' stamp: 'ClementBera 10/29/2013 13:33'! resume: value "Unwind thisContext to self and resume with value as result of last send. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" self resume: value through: (thisContext findNextUnwindContextUpTo: self) ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 1/21/2003 19:27'! return "Unwind until my sender is on top" self return: self receiver! ! !ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 15:57'! basicAt: index put: value "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to the VM in context management." index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self at: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'eem 5/27/2008 11:32'! pushNewArrayOfSize: arraySize self push: (Array new: arraySize)! ! !ContextPart methodsFor: 'debugger access' stamp: ''! release "Remove information from the receiver and all of the contexts on its sender chain in order to break circularities." self releaseTo: nil! ! !ContextPart methodsFor: 'query' stamp: 'CamilloBruni 7/17/2013 21:30'! findSimilarSender "Return the closest sender with the same method, return nil if none found" | method | method := self method. ^ self sender findContextSuchThat: [ :context | context method == method ]! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:35'! push: numObjects fromIndexable: anIndexableCollection "Push the elements of anIndexableCollection onto the receiver's stack. Do not call directly. Called indirectly by {1. 2. 3} constructs." 1 to: numObjects do: [ :i | self push: (anIndexableCollection at: i)]! ! !ContextPart methodsFor: 'special context access' stamp: 'CamilloBruni 7/17/2013 21:28'! unwindComplete "unwindContext only. access temporaries from BlockClosure>>#ensure: and BlockClosure>>#ifCurtailed:" ^self tempAt: 2 ! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! popIntoReceiverVariable: offset "Simulate the action of bytecode that removes the top of the stack and stores it into an instance variable of my receiver." self receiver instVarAt: offset + 1 put: self pop! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'eem 5/27/2008 11:38'! popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Simulate the action of bytecode that removes the top of the stack and stores it into an offset in one of my local variables being used as a remote temp vector." (self at: tempVectorIndex + 1) at: remoteTempIndex + 1 put: self pop! ! !ContextPart methodsFor: 'private' stamp: ''! isFailToken: anObject ^ anObject class == Array and: [ anObject size = 2 and: [(anObject at: 1) == PrimitiveFailToken]]! ! !ContextPart methodsFor: 'controlling' stamp: ''! top "Answer the top of the receiver's stack." ^self at: stackp! ! !ContextPart methodsFor: 'debugger access' stamp: 'CamilloBruni 7/17/2013 21:46'! releaseTo: caller "Remove information from the receiver and the contexts on its sender chain up to caller in order to break circularities." | contex senderContext | contex := self. [ contex == nil or: [ contex == caller ]] whileFalse: [ senderContext := contex sender. contex singleRelease. contex := senderContext ]! ! !ContextPart methodsFor: 'system simulation' stamp: ''! step "Simulate the execution of the receiver's next bytecode. Answer the context that would be the active context after this bytecode." ^self interpretNextInstructionFor: self! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'CamilloBruni 7/17/2013 21:31'! findNextHandlerContextStarting "Return the next handler marked context, returning nil if there is none. Search starts with self and proceeds up to nil." | context | context := self. [ context isHandlerContext ifTrue: [ ^ context ]. (context := context sender) == nil ] whileFalse. ^ nil! ! !ContextPart methodsFor: 'private' stamp: 'ajh 1/23/2003 22:35'! privSender: aContext sender := aContext! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'CamilloBruni 7/17/2013 21:33'! handleSignal: exception "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then execute my handle block (second arg), otherwise forward this message to the next handler context. If none left, execute exception's defaultAction (see nil>>handleSignal:)." | value | ((self exceptionClass handles: exception) and: [self exceptionHandlerIsActive]) ifFalse: [ ^ self nextHandlerContext handleSignal: exception ]. exception privHandlerContext: self contextTag. "disable self while executing handle block" self exceptionHandlerIsActive: false. value := [ self exceptionHandlerBlock cull: exception ] ensure: [ self exceptionHandlerIsActive: true ]. "return from self if not otherwise directed in handle block" self return: value. ! ! !ContextPart methodsFor: 'accessing' stamp: ''! client "Answer the client, that is, the object that sent the message that created this context." ^sender receiver! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! pushReceiver "Simulate the action of bytecode that pushes the active context's receiver on the top of the stack." self push: self receiver! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! storeIntoReceiverVariable: offset "Simulate the action of bytecode that stores the top of the stack into an instance variable of my receiver." self receiver instVarAt: offset + 1 put: self top! ! !ContextPart methodsFor: 'debugger access' stamp: 'CamilloBruni 7/17/2013 21:46'! shortStack "Answer a String showing the top ten contexts on my sender chain." ^ String streamContents: [ :stream | (self stackOfSize: 10) do: [ :item | stream print: item; cr]]! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'MarcusDenker 4/19/2012 14:15'! popIntoTemporaryVariable: offset "Simulate the action of bytecode that removes the top of the stack and stores it into one of my temporary variables." self at: offset + 1 put: self pop! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'CamilloBruni 7/17/2013 21:34'! unwindTo: aContext | context unwindBlock | context := self. [ (context := context findNextUnwindContextUpTo: aContext) isNil ] whileFalse: [ (context unwindComplete) ifNil: [ context unwindComplete: true. unwindBlock := context unwindBlock. unwindBlock value ]]. ! ! !ContextPart methodsFor: 'accessing' stamp: ''! tempAt: index "Answer the value of the temporary variable whose index is the argument, index." self subclassResponsibility! ! !ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 10:45'! basicSize "Primitive. Answer the number of indexable variables in the receiver. This value is the same as the largest legal subscript. Essential. Do not override in any subclass. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to the VM in context management." "The number of indexable fields of fixed-length objects is 0" ^self primitiveFail! ! !ContextPart methodsFor: 'special context access' stamp: 'CamilloBruni 7/17/2013 21:28'! exceptionClass "handlercontext only. access temporaries from BlockClosure>>#on:do:" ^self tempAt: 1 ! ! !ContextPart methodsFor: 'controlling' stamp: 'nice 12/27/2009 05:06'! quickSend: selector to: receiver with: arguments super: superFlag "Send the given selector with arguments in an environment which closely resembles the non-simulating environment, with an interjected unwind-protected block to catch nonlocal returns. Attention: don't get lost!!" | lookupClass contextToReturnTo result | contextToReturnTo := self. lookupClass := superFlag ifTrue: [(self method literalAt: self method numLiterals) value superclass] ifFalse: [receiver class]. [ | oldSender | oldSender := thisContext sender swapSender: self. result := receiver perform: selector withArguments: arguments inSuperclass: lookupClass. thisContext sender swapSender: oldSender] ifCurtailed: [ contextToReturnTo := thisContext sender receiver. "The block context returning nonlocally" contextToReturnTo jump: -1. "skip to front of return bytecode causing this unwind" contextToReturnTo nextByte = 16r7C ifTrue: [ "If it was a returnTop, push the value to be returned. Otherwise the value is implicit in the bytecode" contextToReturnTo push: (thisContext sender tempAt: 1)]. thisContext swapSender: thisContext home sender. "Make this block return to the method's sender" contextToReturnTo]. contextToReturnTo push: result. ^contextToReturnTo! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 2/1/2003 00:20'! nextHandlerContext ^ self sender findNextHandlerContextStarting! ! !ContextPart methodsFor: 'debugger access' stamp: 'md 2/17/2006 18:41'! methodClass "Answer the class in which the receiver's method was found." ^self method methodClass ifNil:[self receiver class].! ! !ContextPart methodsFor: 'special context access' stamp: 'CamilloBruni 7/17/2013 21:56'! unwindComplete: aBoolean "unwindContext only. access temporaries from BlockClosure>>#ensure: and BlockClosure>>#ifCurtailed:" self tempAt: 2 put: aBoolean ! ! !ContextPart methodsFor: 'system simulation' stamp: 'CamilloBruni 7/17/2013 21:25'! stepToCallee "Step to callee or sender" | context | context := self. [ (context := context step) == self ] whileTrue. ^ context! ! !ContextPart methodsFor: 'printing' stamp: 'md 2/17/2006 15:41'! printOn: aStream | selector class mclass | self method == nil ifTrue: [^ super printOn: aStream]. class := self receiver class. mclass := self methodClass. selector := self selector ifNil:[self method defaultSelector]. aStream nextPutAll: class name. mclass == class ifFalse: [aStream nextPut: $(. aStream nextPutAll: mclass name. aStream nextPut: $)]. aStream nextPutAll: '>>'. aStream nextPutAll: selector. selector = #doesNotUnderstand: ifTrue: [ aStream space. (self tempAt: 1) selector printOn: aStream. ]. ! ! !ContextPart methodsFor: 'printing' stamp: 'CamilloBruni 2/13/2012 18:08'! debugStack: stackSize on: aStream "print a condensed version of the stack up to stackSize on aStream" (self stackOfSize: stackSize) do: [:item | item printDebugOn: aStream. aStream cr]! ! !ContextPart methodsFor: 'special context access' stamp: 'CamilloBruni 7/17/2013 21:28'! exceptionHandlerBlock "handlercontext only. access temporaries from BlockClosure>>#on:do:" ^self tempAt: 2 ! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'CamilloBruni 7/17/2013 21:32'! findNextUnwindContextUpTo: aContext "Return the next unwind marked above the receiver, returning nil if there is none. Search proceeds up to but not including aContext." | context | context := self. [ (context := context sender) == nil or: [ context == aContext ] ] whileFalse: [ context isUnwindContext ifTrue: [ ^context ]]. ^nil! ! !ContextPart methodsFor: 'controlling' stamp: 'BenComan 4/14/2014 22:30'! return: value "Unwind thisContext to self and return value to self's sender. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext" sender ifNil: [^self cannotReturn: value to: sender]. sender resume: value! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'CamilloBruni 7/17/2013 21:31'! canHandleSignal: exception "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then return true, otherwise forward this message to the next handler context. If none left, return false (see nil>>canHandleSignal:)" ^ ((self exceptionClass handles: exception) and: [ self exceptionHandlerIsActive ]) or: [ self nextHandlerContext canHandleSignal: exception ]. ! ! !ContextPart methodsFor: 'debugger access' stamp: 'MarcusDenker 12/22/2012 17:45'! sourceCode ^self method sourceCode.! ! !ContextPart methodsFor: 'special context access' stamp: 'CamilloBruni 7/17/2013 21:28'! exceptionHandlerIsActive "handlercontext only. access temporaries from BlockClosure>>#on:do:" ^self tempAt: 3 ! ! !ContextPart methodsFor: 'debugger access' stamp: 'CamilloBruni 7/17/2013 21:45'! longStack "Answer a String showing the top 100 contexts on my sender chain." ^ String streamContents: [ :stream | (self stackOfSize: 100) do: [ :item | stream print: item; cr ]]! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'MarcusDenker 4/19/2012 14:15'! pushTemporaryVariable: offset "Simulate the action of bytecode that pushes the contents of the temporary variable whose index is the argument, index, on the top of the stack." self push: (self at: offset + 1)! ! !ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 15:56'! basicAt: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to the VM in context management." index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self at: index asInteger] ifFalse: [self errorNonIntegerIndex]! ! !ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 10:46'! size "Primitive. Answer the number of indexable variables in the receiver. This value is the same as the largest legal subscript. Essential. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to the VM in context management." "The number of indexable fields of fixed-length objects is 0" ^self primitiveFail! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 6/27/2003 22:17'! resume "Roll back thisContext to self and resume. Execute unwind blocks when rolling back. ASSUMES self is a sender of thisContext" self resume: nil! ! !ContextPart methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2013 21:53'! printDetails: stream "Put my class>>selector and arguments and temporaries on the stream. Protect against errors during printing." | string | self printOn: stream. stream cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. string := [ self tempsAndValuesLimitedTo: 80 indent: 2] ifError: [ '<>' ]. stream nextPutAll: string. stream peekLast == Character cr ifFalse: [ stream cr ].! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! jump: distance "Simulate the action of a 'unconditional jump' bytecode whose offset is the argument, distance." pc := pc + distance! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:37'! simulatePrimitive: primitiveIndex in: method receiver: receiver arguments: arguments | key simulator | key := primitiveIndex = 117 ifTrue: [ | literal | literal := method literalAt: 1. "primitive name, module name" {literal second. literal first}] ifFalse: [ primitiveIndex ]. simulator := self class specialPrimitiveSimulators at: key ifAbsent: [ "named primitives" ^ primitiveIndex = 117 ifTrue:[ self withoutPrimitiveTryNamedPrimitiveIn: method for: receiver withArgs: arguments. "this uses primitive 218, which doesn't works as expected... self tryNamedPrimitiveIn: method for: receiver withArgs: arguments " ] ifFalse:[ receiver tryPrimitive: primitiveIndex withArgs: arguments ]]. ^ simulator simulatePrimitiveFor: method receiver: receiver arguments: arguments context: self! ! !ContextPart methodsFor: 'system simulation' stamp: 'CamilloBruni 7/17/2013 21:26'! runSimulated: aBlock contextAtEachStep: block2 "Simulate the execution of the argument, aBlock, until it ends. aBlock MUST NOT contain an '^'. Evaluate block2 with the current context prior to each instruction executed. Answer the simulated value of aBlock." | current returnContext exception | aBlock hasMethodReturn ifTrue: [ self error: 'simulation of blocks with ^ can run loose' ]. current := [ aBlock on: Exception do: [ :ex | SimulationExceptionWrapper signalForException: ex ] ] asContext. returnContext := MethodContext sender: nil receiver: self home receiver method: self home method arguments: self home arguments. current pushArgs: Array new from: returnContext. [current == returnContext] whileFalse: [ block2 value: current. current := current step ]. exception := returnContext pop. exception class == SimulationExceptionWrapper ifTrue: [ ^ exception exception signal ]. ^ exception ! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:27'! methodReturnConstant: value "Simulate the action of a 'return constant' bytecode whose value is the argument, value. This corresponds to a source expression like '^0'." ^self return: value from: self methodReturnContext! ! !ContextPart methodsFor: 'accessing' stamp: ''! receiver "Answer the receiver of the message that created this context." self subclassResponsibility! ! !ContextPart methodsFor: 'controlling' stamp: 'ClementBera 10/29/2013 13:33'! resume: value through: firstUnwindContext "Unwind thisContext to self and resume with value as result of last send. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext." | context unwindBlock | self isDead ifTrue: [ self cannotReturn: value to: self ]. context := firstUnwindContext. [ context isNil ] whileFalse: [ context unwindComplete ifNil:[ context unwindComplete: true. unwindBlock := context unwindBlock. thisContext terminateTo: context. unwindBlock value]. context := context findNextUnwindContextUpTo: self]. thisContext terminateTo: self. ^value ! ! !ContextPart methodsFor: 'query' stamp: 'eem 12/31/2008 11:28'! isBottomContext "Answer if this is the last context (the first context invoked) in my sender chain" ^sender isNil! ! !ContextPart methodsFor: 'debugger access' stamp: 'CamilloBruni 7/17/2013 21:45'! print: anObject on: aStream "Safely print anObject in the face of direct ProtoObject subclasses" | title | (anObject class canUnderstand: #printOn:) ifTrue: [ ^ anObject printOn: aStream ]. title := anObject class name. aStream nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); nextPutAll: title! ! !ContextPart methodsFor: 'accessing' stamp: 'eem 6/15/2008 11:27'! methodReturnContext "Answer the context from which an ^-return should return from." self subclassResponsibility! ! !ContextPart methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2013 21:51'! arguments "returns the arguments of a message invocation" | arguments numargs | numargs := self method numArgs. arguments := Array new: numargs. 1 to: numargs do: [ :i | arguments at: i put: (self tempAt: i) ]. ^ arguments! ! !ContextPart methodsFor: 'query' stamp: 'CamilloBruni 7/17/2013 21:30'! findSecondToOldestSimilarSender "Search the stack for the second-to-oldest occurance of self's method. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning." | secondContext context lastContext | secondContext := self. context := self. [ lastContext := context findSimilarSender. lastContext isNil ] whileFalse: [ secondContext := context. context := lastContext. ]. ^ secondContext ! ! !ContextPart methodsFor: 'private' stamp: 'ajh 5/20/2004 16:27'! activateReturn: aContext value: value "Activate 'aContext return: value' in place of self, so execution will return to aContext's sender" ^ self activateMethod: ContextPart theReturnMethod withArgs: {value} receiver: aContext class: aContext class! ! !ContextPart methodsFor: 'debugger access' stamp: 'eem 6/10/2008 09:42'! tempNames "Answer a SequenceableCollection of the names of the receiver's temporary variables, which are strings." ^ self debuggerMap tempNamesForContext: self! ! !ContextPart methodsFor: 'debugging' stamp: 'CamilloBruni 8/30/2012 17:20'! debug ^ Smalltalk tools debugger openContext: self label: self printString contents: nil ! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! pushConstant: value "Simulate the action of bytecode that pushes the constant, value, on the top of the stack." self push: value! ! !ContextPart methodsFor: 'controlling' stamp: 'CamilloBruni 7/17/2013 21:51'! terminateTo: previousContext "Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender." | currentContext sendingContext | (self hasSender: previousContext) ifTrue: [ currentContext := sender. [currentContext == previousContext] whileFalse: [ sendingContext := currentContext sender. currentContext terminate. currentContext := sendingContext ]]. sender := previousContext! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/27/2003 18:35'! copyStack ^ self copyTo: nil! ! !ContextPart methodsFor: 'private' stamp: 'MarianoMartinezPeck 1/26/2012 19:52'! setNamedPrimitiveInformationFrom: fromMethod toMethod: toMethod "For named primitives, the first literal contains a special object that has information of the primitive. Example: (StandardFileStream >> #primOpen:writable:) literalAt: 1 ----->>>> #(#FilePlugin #primitiveFileOpen 0 147). In this method we cope such information from one to another one." | spec | spec := toMethod literalAt: 1. spec replaceFrom: 1 to: spec size with: (fromMethod literalAt: 1) startingAt: 1. ! ! !ContextPart methodsFor: 'query' stamp: 'CamilloBruni 7/17/2013 21:31'! hasContext: aContext "Answer whether aContext is me or one of my senders" ^ (self findContextSuchThat: [ :context | context == aContext ]) notNil! ! !ContextPart methodsFor: 'debugger access' stamp: 'CamilloBruni 7/17/2013 21:56'! tempsAndValuesLimitedTo: sizeLimit indent: indent "Return a string of the temporary variabls and their current values" ^ String streamContents: [ :aStream | self tempNames doWithIndex: [ :title :index | indent timesRepeat: [ aStream tab ]. aStream nextPutAll: title; nextPut: $:; space; tab. aStream nextPutAll: ((self namedTempAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)). aStream cr ]].! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 3/25/2004 00:07'! jump "Abandon thisContext and resume self instead (using the same current process). You may want to save thisContext's sender before calling this so you can jump back to it. Self MUST BE a top context (ie. a suspended context or a abandoned context that was jumped out of). A top context already has its return value on its stack (see Interpreter>>primitiveSuspend and other suspending primitives). thisContext's sender is converted to a top context (by pushing a nil return value on its stack) so it can be jump back to." | top | "Make abandoned context a top context (has return value (nil)) so it can be jumped back to" thisContext sender push: nil. "Pop self return value then return it to self (since we jump to self by returning to it)" stackp = 0 ifTrue: [self stepToSendOrReturn]. stackp = 0 ifTrue: [self push: nil]. "must be quick return self/constant" top := self pop. thisContext privSender: self. ^ top! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:34'! insertSender: aContext "Insert aContext and its sender chain between me and my sender. Return new callee of my original sender." | context | context := aContext bottomContext. context privSender: self sender. self privSender: aContext. ^ context! ! !ContextPart methodsFor: 'debugger access' stamp: ''! swapSender: coroutine "Replace the receiver's sender with coroutine and answer the receiver's previous sender. For use in coroutining." | oldSender | oldSender := sender. sender := coroutine. ^oldSender! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'CamilloBruni 7/17/2013 21:41'! send: selector super: superFlag numArgs: numArgs "Simulate the action of bytecodes that send a message with selector, selector. The argument, superFlag, tells whether the receiver of the message was specified with 'super' in the source method. The arguments of the message are found in the top numArgs locations on the stack and the receiver just below them." | receiver arguments | arguments := Array new: numArgs. numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop ]. receiver := self pop. " selector == #doPrimitive:method:receiver:args: ifTrue: [answer := receiver doPrimitive: (arguments at: 1) method: (arguments at: 2) receiver: (arguments at: 3) args: (arguments at: 4). self push: answer. ^self]. " QuickStep == self ifTrue: [ QuickStep := nil. ^ self quickSend: selector to: receiver with: arguments super: superFlag]. ^ self send: selector to: receiver with: arguments super: superFlag! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 7/6/2003 20:38'! jump: distance if: condition "Simulate the action of a 'conditional jump' bytecode whose offset is the argument, distance, and whose condition is the argument, condition." | bool | bool := self pop. (bool == true or: [bool == false]) ifFalse: [ ^self send: #mustBeBooleanIn: to: bool with: {self} super: false]. (bool eqv: condition) ifTrue: [self jump: distance]! ! !ContextPart methodsFor: 'controlling' stamp: 'CamilloBruni 7/17/2013 21:47'! pop "Answer the top of the receiver's stack and remove the top of the stack." | value | value := self at: stackp. self stackp: stackp - 1. ^ value! ! !ContextPart methodsFor: 'accessing' stamp: 'ar 4/11/2006 01:49'! methodNode ^ self method methodNode.! ! !ContextPart methodsFor: 'query' stamp: 'CamilloBruni 7/17/2013 21:29'! findContextSuchThat: testBlock "Search self and my sender chain for first one that satisfies testBlock. Return nil if none satisfy" | context | context := self. [ context isNil ] whileFalse: [ (testBlock value: context) ifTrue: [ ^ context ]. context := context sender ]. ^ nil! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'CamilloBruni 7/17/2013 21:41'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize "Simulate the action of a 'closure copy' bytecode whose result is the new BlockClosure for the following code" | copiedValues | numCopied > 0 ifTrue: [ copiedValues := Array new: numCopied. numCopied to: 1 by: -1 do: [ :i | copiedValues at: i put: self pop ]] ifFalse: [ copiedValues := nil ]. self push: (BlockClosure outerContext: self startpc: pc numArgs: numArgs copiedValues: copiedValues). self jump: blockSize! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:36'! setNumArgs: numArgs toMethod: theMethod "All that line is to change the argument count of a CompiledMethod header. The argument count is 4 bits starting in the 24 and finishign in 27. 16r787FFFFF is the hexa representation of a number that is all 1 and only those 4 bits in 0. Hence, when doing (theMethod header bitAnd: 16r787FFFFF) what we do is just to put zeros in those 4 bits. Now with the new argument size, we do bitShift: 24 and we obtain a 32 bits number with all zeros and just our 4 bits with the value we want. Since in the previous step we cleaned those 4 bits doing now a bitOr: with the second step, we have the result. " | xpc | theMethod objectAt: 1 put: (((theMethod header bitAnd: 2r01110000000000111111111111111111) bitOr: (numArgs bitShift: 24)) bitOr: (numArgs + 1 bitShift: 18)). xpc := theMethod initialPC. "long store temp" (theMethod at: xpc) = 129 ifTrue: [ theMethod at: xpc + 1 put: (16r40 + numArgs). theMethod at: xpc + 3 put: (16r10 + numArgs)]! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! storeIntoLiteralVariable: value "Simulate the action of bytecode that stores the top of the stack into a literal variable of my method." value value: self top! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:34'! cut: aContext "Cut aContext and its senders from my sender chain" | context callee | context := self. [ context == aContext ] whileFalse: [ callee := context. context := context sender. context ifNil: [ aContext ifNotNil: [ self error: 'aContext not a sender' ]]]. callee privSender: nil. ! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:39'! withoutPrimitiveTryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments "When using the debugger we want to run a method step by step. What what happens when we do a step into a CompiledMethod which has a primitive? If such a method is executed form outside the Debugger (normal scenario) the VM knows that such CompiledMethod has a primitive declaration and hence executes it. If it fails then it continues executing all the bytecode of the method. Otherwise, it just returns. Now, what is the problem with the Debugger? The problem is that if the primitive fail, we don't want that the VM directly executes all the remaining bytecodes of the method. Instead, we would like to go step by step witht he Debugger, just as happens with normal methods. To solve the mentioned problem, we use the following trick: We have the orignal compiled method (the one that has a primitive invokation), the receiver and the arguments. So the idea is to use a template compiled method that ONLY contains the primitive delcaration (it doesn't include all the smalltalk code after the primitive). #tryNamedPrimitiveTemplateMethod answers such a template method which looks like: tryNamedPrimitive ^ ContextPart primitiveFailToken' Since this method does not change its bytecodes for every invokation, we can reuse it for all methods with primitives. There are only 2 things we have to change in the template: the number of arguments and the primitive declaration (to use the correct primitive name and module name). Then what we do is to run that compiled method with the receiver and arguments we have. The result is that we will be invoking almost the same original method but a slighly different version that does not have the smalltalk part after the primitive and that in contrast is sends #primitiveFailToken. If this method invokation does not fail, then the Debugger continues debugging the sender of the primitive method. In this case, the step in is the same as step over. If the primitive fails, then the debugger continues executing the smalltalk part after the primitive method. In this case, step in is a real step in. " | theMethod | arguments size > 8 ifTrue: [ ^ self class primitiveFailToken ]. theMethod := self class tryNamedPrimitiveTemplateMethod. self setNumArgs: arguments size toMethod: theMethod. theMethod == nil ifTrue: [ ^ self class primitiveFailToken ]. self setNamedPrimitiveInformationFrom: aCompiledMethod toMethod: theMethod. theMethod flushCache. ^ theMethod valueWithReceiver: aReceiver arguments: arguments! ! !ContextPart methodsFor: 'private' stamp: 'di 10/23/1999 17:31'! stackp: newStackp "Storing into the stack pointer is a potentially dangerous thing. This primitive stores nil into any cells that become accessible as a result, and it performs the entire operation atomically." "Once this primitive is implemented, failure code should cause an error" self error: 'stackp store failure'. " stackp == nil ifTrue: [stackp := 0]. newStackp > stackp 'effectively checks that it is a number' ifTrue: [oldStackp := stackp. stackp := newStackp. 'Nil any newly accessible cells' oldStackp + 1 to: stackp do: [:i | self at: i put: nil]] ifFalse: [stackp := newStackp] "! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/27/2003 21:20'! copyTo: aContext "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home. It is best to use BlockClosures instead. They only hold a ContextTag, which will work for all copies of the original home context." ^ self copyTo: aContext blocks: IdentityDictionary new! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 00:04'! isDead "Has self finished" ^ pc isNil! ! !ContextPart methodsFor: 'debugger access' stamp: ''! sender "Answer the context that sent the message that created the receiver." ^sender! ! !ContextPart methodsFor: 'printing' stamp: 'CamilloBruni 2/13/2012 23:22'! printDebugOn: aStream "print a condensed for of the stack. For methods simply print Class >> selector For blocks only print the first line" self printOn: aStream! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:27'! methodReturnTop "Simulate the action of a 'return top of stack' bytecode. This corresponds to source expressions like '^something'." ^self return: self pop from: self methodReturnContext! ! !ContextPart methodsFor: 'accessing' stamp: 'lr 3/22/2009 19:15'! methodSelector ^ self method selector! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! pushActiveContext "Simulate the action of bytecode that pushes the the active context on the top of its own stack." self push: self! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:52'! doPrimitive: primitiveIndex method: method receiver: receiver args: arguments "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and arguments are given as arguments to this message. Any primitive which provikes execution needs to be intercepted and simulated to avoid execution running away." | value | "Simulation guard" "If successful, push result and return resuming context, else ^ PrimitiveFailToken" " (primitiveIndex = 19) ifTrue: [Smalltalk tools debugger openContext: self label:'Code simulation error' contents: nil]. " primitiveIndex = 83 "Object>>perform:[with:...]" ifTrue: [^self send: arguments first to: receiver with: arguments allButFirst super: false]. primitiveIndex = 84 "Object>>perform:withArguments:" ifTrue: [^self send: arguments first to: receiver with: (arguments at: 2) super: false]. primitiveIndex = 188 ifTrue: [ arguments size = 2 ifTrue: [ "Object>>withArgs:executeMethod:" ^MethodContext sender: self receiver: receiver method: (arguments at: 2) arguments: (arguments at: 1) ]. arguments size = 3 ifTrue: [ "CompiledMethod class >> #receiver:withArguments:executeMethod:" ^MethodContext sender: self receiver: (arguments at: 1) method: (arguments at: 3) arguments: (arguments at: 2) ] ]. primitiveIndex = 189 ifTrue: [ "Object >> (#with:)*executeMethod" ^MethodContext sender: self receiver: receiver method: arguments last arguments: arguments allButLast ]. "Closure primitives" (primitiveIndex = 200 and: [receiver == self]) ifTrue: "ContextPart>>closureCopy:copiedValues:; simulated to get startpc right" [^self push: (BlockClosure outerContext: receiver startpc: pc + 2 numArgs: arguments first copiedValues: arguments last)]. ((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]" or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]" [^receiver simulateValueWithArguments: arguments caller: self]. primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:" [^receiver simulateValueWithArguments: arguments first caller: self]. primitiveIndex = 120 ifTrue:[ "FFI method" value := method literals first tryInvokeWithArguments: arguments. ] ifFalse:[ value := self simulatePrimitive: primitiveIndex in: method receiver: receiver arguments: arguments ]. ^ (self isFailToken: value) ifTrue: [value] ifFalse: [self push: value] ! ! !ContextPart methodsFor: 'special context access' stamp: 'CamilloBruni 7/17/2013 21:52'! exceptionHandlerIsActive: aBoolean "handlercontext only. access temporaries from BlockClosure>>#on:do:" self tempAt: 3 put: aBoolean ! ! !ContextPart methodsFor: 'query' stamp: 'CamilloBruni 7/17/2013 21:31'! secondFromBottom "Return the second from bottom of my sender chain" self sender ifNil: [ ^ nil ]. ^ self findContextSuchThat: [ :context | context sender sender isNil]! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! pushReceiverVariable: offset "Simulate the action of bytecode that pushes the contents of the receiver's instance variable whose index is the argument, index, on the top of the stack." self push: (self receiver instVarAt: offset + 1)! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:37'! stackPtr "For use only by the SystemTracer and the Debugger, Inspectors etc" ^ stackp! ! !ContextPart methodsFor: 'accessing' stamp: ''! tempAt: index put: value "Store the argument, value, as the temporary variable whose index is the argument, index." self subclassResponsibility! ! !ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 15:57'! at: index put: value "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to the VM in context management." index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self at: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ! !ContextPart methodsFor: 'controlling' stamp: 'ClementBera 10/29/2013 13:31'! restart "Unwind thisContext to self and resume from beginning. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" | context unwindBlock | self isDead ifTrue: [self cannotReturn: nil to: self]. self privRefresh. context := thisContext. [ context := context findNextUnwindContextUpTo: self. context isNil ] whileFalse: [ context unwindComplete ifNil:[ context unwindComplete: true. unwindBlock := context unwindBlock. thisContext terminateTo: context. unwindBlock value ]]. thisContext terminateTo: self. self jump. ! ! !ContextPart methodsFor: 'query' stamp: 'CamilloBruni 7/17/2013 21:29'! bottomContext "Return the last context (the first context invoked) in my sender chain" ^ self findContextSuchThat: [ :context | context sender isNil]! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'eem 5/27/2008 11:44'! pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Simulate the action of bytecode that pushes the value at remoteTempIndex in one of my local variables being used as a remote temp vector." self push: ((self at: tempVectorIndex + 1) at: remoteTempIndex + 1)! ! !ContextPart methodsFor: 'debugger access' stamp: ''! stack "Answer an Array of the contexts on the receiver's sender chain." ^self stackOfSize: 9999! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'MarcusDenker 4/19/2012 14:15'! storeIntoTemporaryVariable: offset "Simulate the action of bytecode that stores the top of the stack into one of my temporary variables." self at: offset + 1 put: self top! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'eem 6/15/2008 11:27'! methodReturnReceiver "Simulate the action of a 'return receiver' bytecode. This corresponds to the source expression '^self'." ^self return: self receiver from: self methodReturnContext! ! !ContextPart methodsFor: 'debugger access' stamp: 'CamilloBruni 7/17/2013 21:42'! depthBelow: aContext "Answer how many calls there are between this and aContext." | context depth | context := self. depth := 0. [ context == aContext or: [ context == nil ]] whileFalse: [ context := context sender. depth := depth + 1 ]. ^ depth! ! !ContextPart methodsFor: 'accessing' stamp: 'md 2/9/2007 17:34'! tempNamed: aName "Answer the value of the temporary variable whose name is the argument, aName." self subclassResponsibility! ! !ContextPart methodsFor: 'debugger access' stamp: 'CamilloBruni 7/17/2013 21:46'! stackOfSize: limit "Answer an OrderedCollection of the top 'limit' contexts on the receiver's sender chain." | stack context | stack := OrderedCollection new. stack addLast: (context := self). [(context := context sender) ~~ nil and: [stack size < limit]] whileTrue: [ stack addLast: context ]. ^ stack! ! !ContextPart methodsFor: 'debugger access' stamp: 'md 2/17/2006 18:47'! selector "Answer the selector of the method that created the receiver." ^self method selector ifNil: [self method defaultSelector].! ! !ContextPart methodsFor: 'controlling' stamp: 'CamilloBruni 7/17/2013 21:47'! closureCopy: numArgs copiedValues: anArray "Distinguish a block of code from its enclosing method by creating a BlockClosure for that block. The compiler inserts into all methods that contain blocks the bytecodes to send the message closureCopy:copiedValues:. Do not use closureCopy:copiedValues: in code that you write!! Only the compiler can decide to send the message closureCopy:copiedValues:. Fail if numArgs is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^BlockClosure outerContext: self startpc: pc + 2 numArgs: numArgs copiedValues: anArray! ! !ContextPart methodsFor: 'controlling' stamp: 'eem 4/25/2012 10:47'! return: value through: firstUnwindContext "Unwind thisContext to self and return value to self's sender. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext." sender ifNil: [self cannotReturn: value to: sender]. sender resume: value through: firstUnwindContext! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 1/24/2003 00:56'! terminate "Make myself unresumable." sender := nil. pc := nil. ! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:51'! copyTo: aContext blocks: dict "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home." | copy | self == aContext ifTrue: [^ nil]. copy := self copy. dict at: self ifPresent: [ :blocks | blocks do: [ :block | block privHome: copy ]]. self sender ifNotNil: [ copy privSender: (self sender copyTo: aContext blocks: dict)]. ^ copy! ! !ContextPart methodsFor: 'accessing' stamp: 'md 2/9/2007 17:34'! tempNamed: aName put: value "Store the argument, value, as the temporary variable whose name is the argument, aName." self subclassResponsibility! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! popIntoLiteralVariable: value "Simulate the action of bytecode that removes the top of the stack and stores it into a literal variable of my method." value value: self pop! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'CamilloBruni 7/17/2013 21:41'! return: value from: aSender "For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self" | newTop context | aSender isDead ifTrue: [ ^ self send: #cannotReturn: to: self with: {value} super: false ]. newTop := aSender sender. context := self findNextUnwindContextUpTo: newTop. context ifNotNil: [ ^ self send: #aboutToReturn:through: to: self with: {value. context} super: false] . self releaseTo: newTop. newTop ifNotNil: [ newTop push: value ]. ^ newTop ! ! !ContextPart methodsFor: 'controlling' stamp: ''! activateMethod: newMethod withArgs: args receiver: rcvr class: class "Answer a ContextPart initialized with the arguments." ^MethodContext sender: self receiver: rcvr method: newMethod arguments: args! ! !ContextPart methodsFor: 'accessing' stamp: 'eem 6/27/2008 15:55'! at: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to the VM in context management." index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self at: index asInteger] ifFalse: [self errorNonIntegerIndex]! ! !ContextPart methodsFor: 'debugger access' stamp: 'eem 6/24/2008 12:24'! namedTempAt: index put: aValue "Set the value of the temp at index in the receiver's sequence of tempNames. (Note that if the value is a copied value it is also set out along the lexical chain, but alas not in along the lexical chain.)." ^self debuggerMap namedTempAt: index put: aValue in: self! ! !ContextPart methodsFor: 'controlling' stamp: 'CamilloBruni 7/17/2013 21:48'! push: value "Push value on the receiver's stack." self stackp: stackp + 1. self at: stackp put: value! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! doPop "Simulate the action of a 'remove top of stack' bytecode." self pop! ! !ContextPart methodsFor: 'debugger access' stamp: 'AndreiChis 7/25/2013 11:10'! errorReportOn: stream "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." | stackDepth aContext startPos | stream print: Date today; space; print: Time now; cr. stream cr. stream nextPutAll: 'VM: '; nextPutAll: Smalltalk os name asString; nextPutAll: ' - '; nextPutAll: Smalltalk os subtype asString; nextPutAll: ' - '; nextPutAll: Smalltalk os version asString; nextPutAll: ' - '; nextPutAll: Smalltalk vm version asString; cr. stream nextPutAll: 'Image: '; nextPutAll: SystemVersion current version asString; nextPutAll: ' ['; nextPutAll: Smalltalk lastUpdateString asString; nextPutAll: ']'; cr. stream cr. "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." stackDepth := 0. startPos := stream position. aContext := self. [ aContext notNil and: [ (stackDepth := stackDepth + 1) < 40 ]] whileTrue: [ "variable values" aContext printDetails: stream. stream cr. aContext := aContext sender ]. stream cr; nextPutAll: '--- The full stack ---'; cr. aContext := self. stackDepth := 0. [ aContext == nil ] whileFalse: [ stackDepth := stackDepth + 1. stackDepth = 40 ifTrue: [ stream nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr ]. "just class>>selector" stream print: aContext; cr. stream position > (startPos+150000) ifTrue: [ stream nextPutAll: '...etc...'. "exit early" ^ self]. stackDepth > 200 ifTrue: [ stream nextPutAll: '-- and more not shown --'. ^ self ]. aContext := aContext sender ].! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:39'! tryPrimitiveFor: method receiver: receiver args: arguments "If this method has a primitive index, then run the primitive and return its result. Otherwise (and also if the primitive fails) return PrimitiveFailToken, as an indication that the method should be activated and run as bytecodes." | primIndex | (primIndex := method primitive) = 0 ifTrue: [ ^ self class primitiveFailToken ]. ^ self doPrimitive: primIndex method: method receiver: receiver args: arguments! ! !ContextPart methodsFor: 'system simulation' stamp: 'ClementBera 9/27/2013 17:19'! completeCallee: aContext "Simulate the execution of bytecodes until a return to the receiver." | context current nextContext | context := aContext. [ context == current or: [ context hasSender: self ] ] whileTrue: [ current := context. nextContext := context quickStep. nextContext ifNil: [ self halt ]. context := nextContext ]. ^ self stepToSendOrReturn! ! !ContextPart methodsFor: 'controlling' stamp: 'CamilloBruni 7/17/2013 21:54'! send: selector to: receiver with: arguments super: superFlag "Simulate the action of sending a message with selector, selector, and arguments, args, to receiver. The argument, superFlag, tells whether the receiver of the message was specified with 'super' in the source method." | class method value context | class := superFlag ifTrue: [(self method literalAt: self method numLiterals) value superclass] ifFalse: [receiver class]. method := class lookupSelector: selector. method == nil ifTrue: [ ^ self send: #doesNotUnderstand: to: receiver with: (Array with: (Message selector: selector arguments: arguments)) super: superFlag ]. value := self tryPrimitiveFor: method receiver: receiver args: arguments. "primitive runs without failure?" (self isFailToken: value) ifFalse: [^ value]. (selector == #doesNotUnderstand: and: [ (class canUnderstand: #doesNotUnderstand: ) not ]) ifTrue: [ ^self error: 'Simulated message ', (arguments at: 1) selector, ' not understood']. "failure.. lets activate the method" context := self activateMethod: method withArgs: arguments receiver: receiver class: class. "check if activated method handles the error code (a first bytecode will be store into temp)" "long store temp" (context method at: context pc ) = 129 ifTrue: [ context at: context stackPtr put: value last ]. ^ context! ! !ContextPart methodsFor: 'accessing' stamp: ''! method "Answer the method of this context." self subclassResponsibility! ! !ContextPart methodsFor: 'controlling' stamp: 'CamilloBruni 7/17/2013 21:54'! return: value to: aSender "Simulate the return of value to aSender." self releaseTo: aSender. aSender ifNil: [^ nil]. ^ aSender push: value! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:39'! tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments errorCode ifNotNil: [ "If errorCode is an integer other than -1 there was a problem with primitive 218, not with the external primitive itself. -1 indicates a generic failure (where errorCode should be nil) but errorCode = nil means primitive 218 is not implemented. So interpret -1 to mean the external primitive failed with a nil error code." errorCode isInteger ifTrue: [ errorCode = -1 ifTrue: [ errorCode := nil ] ifFalse: [ self primitiveFailed ]]. ^ self class primitiveFailTokenFor: errorCode ]. "Assume a nil error code implies the primitive is not implemented and fall back on the old code." "The primitive doesn't exist or there was an error. Hence, we follow another solution without the primitive" ^ self withoutPrimitiveTryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments ! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'eem 5/27/2008 11:53'! storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Simulate the action of bytecode that stores the top of the stack at an offset in one of my local variables being used as a remote temp vector." (self at: tempVectorIndex + 1) at: remoteTempIndex + 1 put: self top! ! !ContextPart methodsFor: 'debugger access' stamp: 'ClementBera 9/27/2013 17:47'! singleRelease "Remove information from the receiver in order to break circularities." stackp ifNotNil: [ 1 to: stackp do: [ :i | self at: i put: nil ]]. sender := nil. pc := nil. ! ! !ContextPart methodsFor: 'controlling' stamp: 'CamilloBruni 7/17/2013 21:47'! hasSender: context "Answer whether the receiver is strictly above context on the stack." | senderContext | self == context ifTrue: [^false]. senderContext := sender. [senderContext == nil] whileFalse: [ senderContext == context ifTrue: [^true]. senderContext := senderContext sender]. ^false! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! pushLiteralVariable: value "Simulate the action of bytecode that pushes the contents of the literal variable whose index is the argument, index, on the top of the stack." self push: value value! ! !ContextPart methodsFor: 'controlling' stamp: 'CamilloBruni 2/13/2012 18:05'! shortDebugStack "Answer a String showing the top ten contexts on my sender chain." ^ String streamContents: [:stream | self debugStack: 10 on: stream]! ! !ContextPart methodsFor: 'instruction decoding' stamp: ''! doDup "Simulate the action of a 'duplicate top of stack' bytecode." self push: self top! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/28/2000 15:45'! isUnwindContext ^false! ! !ContextPart methodsFor: '*AST-Interpreter-Extension' stamp: 'CamilloBruni 12/12/2011 14:33'! returnContext ^ self methodReturnContext! ! !ContextPart methodsFor: 'controlling' stamp: 'cb 3/7/2014 13:51'! runUntilErrorOrReturnFrom: aSender "ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it." "Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext." | error context here topContext aSendersSender | here := thisContext. aSendersSender := aSender sender. "Insert ensure and exception handler contexts under aSender" error := nil. context := aSender insertSender: (ContextPart contextOn: UnhandledError, Halt do: [:ex | error ifNil: [ "this is ugly but it fixes the side-effects of not sending an Unhandled error on Halt" error := (ex isKindOf: Halt) ifTrue: [ ex ] ifFalse: [ ex exception ]. topContext := thisContext. ex resumeUnchecked: here jump ] ifNotNil: [ ex pass ]]). context := context insertSender: (ContextPart contextEnsure: [error ifNil: [ topContext := thisContext. here jump] ]). self jump. "Control jumps to self" "Control resumes here once above ensure block or exception handler is executed" ^ error ifNil: [ "No error was raised, remove ensure context by stepping until popped" [context isDead or: [aSender isDead]] whileFalse: [topContext := topContext stepToCallee]. {aSender isDead ifTrue: [| retValue | retValue := (context method == (BlockClosure >> #ensure:) or: [context method == (BlockClosure >> #ifCurtailed:)]) ifTrue: [context tempAt: 3]. "returnValue in ensure: and result in ifCurtailed:" aSendersSender push: retValue. aSendersSender] ifFalse: [topContext]. nil} ] ifNotNil: [ "Error was raised, remove inserted above contexts then return signaler context" aSender terminateTo: context sender. "remove above ensure and handler contexts" {topContext. error} ]. ! ! !ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'! new: size self error: 'Contexts must only be created with newForMethod:'! ! !ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:55'! newForMethod: aMethod "This is the only method for creating new contexts, other than primitive cloning. Any other attempts, such as inherited methods like shallowCopy, should be avoided or must at least be rewritten to determine the proper size from the method being activated. This is because asking a context its size (even basicSize!!) will not return the real object size but only the number of fields currently accessible, as determined by stackp." ^ super basicNew: aMethod frameSize! ! !ContextPart class methodsFor: 'examples' stamp: ''! tallyInstructions: aBlock "This method uses the simulator to count the number of occurrences of each of the Smalltalk instructions executed during evaluation of aBlock. Results appear in order of the byteCode set." | tallies | tallies := Bag new. thisContext sender runSimulated: aBlock contextAtEachStep: [:current | tallies add: current nextByte]. ^tallies sortedElements "ContextPart tallyInstructions: [3.14159 printString]"! ! !ContextPart class methodsFor: 'accessing' stamp: ''! specialPrimitiveSimulators SpecialPrimitiveSimulators ifNil: [ self initializePrimitiveSimulators ]. ^ SpecialPrimitiveSimulators! ! !ContextPart class methodsFor: 'simulation' stamp: ''! runSimulated: aBlock "Simulate the execution of the argument, current. Answer the result it returns." ^ thisContext sender runSimulated: aBlock contextAtEachStep: [:ignored] "ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]"! ! !ContextPart class methodsFor: '*Compiler-Kernel' stamp: 'eem 6/19/2008 10:00'! isContextClass ^true! ! !ContextPart class methodsFor: 'examples' stamp: 'ClementBera 9/27/2013 18:05'! tallyMethods: aBlock "This method uses the simulator to count the number of calls on each method invoked in evaluating aBlock. Results are given in order of decreasing counts." | prev tallies | tallies := Bag new. prev := aBlock. thisContext sender runSimulated: aBlock contextAtEachStep: [:current | current == prev ifFalse: "call or return" [prev sender ifNotNil: "call only" [tallies add: current printString]. prev := current]]. ^ tallies sortedCounts "ContextPart tallyMethods: [3.14159 printString]"! ! !ContextPart class methodsFor: 'simulation' stamp: 'GuillermoPolito 5/21/2012 01:56'! initialize "A unique object to be returned when a primitive fails during simulation" PrimitiveFailToken := Object new. self initializeTryNamedPrimitiveTemplateMethod. SpecialPrimitiveSimulators := nil. QuickStep := nil.! ! !ContextPart class methodsFor: '*Fuel' stamp: 'MarianoMartinezPeck 5/22/2011 23:44'! newFromFrameSize: aFrameSize ^ super basicNew: aFrameSize! ! !ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'! basicNew: size self error: 'Contexts must only be created with newForMethod:'! ! !ContextPart class methodsFor: 'special context creation' stamp: 'ajh 1/24/2003 14:31'! contextEnsure: block "Create an #ensure: context that is ready to return from executing its receiver" | ctxt chain | ctxt := thisContext. [chain := thisContext sender cut: ctxt. ctxt jump] ensure: block. "jump above will resume here without unwinding chain" ^ chain! ! !ContextPart class methodsFor: 'special context creation' stamp: 'GuillermoPolito 4/26/2012 11:19'! theReturnMethod | meth | meth := self lookupSelector: #return:. meth isPrimitive ifTrue: [^ self error: 'expected #return: to not be a primitive']. ^ meth! ! !ContextPart class methodsFor: 'private' stamp: 'sma 4/22/2000 17:01'! carefullyPrint: anObject on: aStream aStream nextPutAll: ([anObject printString] on: Error do: ['unprintable ' , anObject class name])! ! !ContextPart class methodsFor: 'special context creation' stamp: 'ajh 1/24/2003 14:31'! contextOn: exceptionClass do: block "Create an #on:do: context that is ready to return from executing its receiver" | ctxt chain | ctxt := thisContext. [chain := thisContext sender cut: ctxt. ctxt jump] on: exceptionClass do: block. "jump above will resume here without unwinding chain" ^ chain! ! !ContextPart class methodsFor: 'registering simulated primitives' stamp: ''! simulatePrimitive: primName module: moduleName with: simulator ^ self specialPrimitiveSimulators at: {primName. moduleName} put: simulator! ! !ContextPart class methodsFor: 'simulation' stamp: ''! primitiveFailTokenFor: errorCode ^ { PrimitiveFailToken. errorCode } ! ! !ContextPart class methodsFor: 'simulation' stamp: 'IgorStasenko 3/16/2012 20:06'! primitiveFailToken ^ self primitiveFailTokenFor: nil! ! !ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:05'! trace: aBlock onFileNamed: fileName "ContextPart trace: [3 factorial] onFileNamed: 'trace'" "This method uses the simulator to print calls to a file." | aStream | ^ [aStream := FileStream fileNamed: fileName. self trace: aBlock on: aStream] ensure: [aStream close]! ! !ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'! new self error: 'Contexts must only be created with newForMethod:'! ! !ContextPart class methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 1/25/2012 10:54'! tryNamedPrimitiveTemplateMethod ^ TryNamedPrimitiveTemplateMethod! ! !ContextPart class methodsFor: 'simulation' stamp: 'MarcusDenker 5/7/2013 23:32'! initializePrimitiveSimulators "extra primitive simulators can be registered by implementing #registerPrimitiveSimulators method in class side of your class. " SpecialPrimitiveSimulators := Dictionary new. Class allSubclassesDo: [:metaclass | (metaclass includesSelector: #registerPrimitiveSimulators) ifTrue: [ metaclass theNonMetaClass registerPrimitiveSimulators. ] ].! ! !ContextPart class methodsFor: 'examples' stamp: 'AdrianLienhard 10/11/2009 19:39'! trace: aBlock on: aStream "ContextPart trace: [3 factorial]" "This method uses the simulator to print calls to a file." | prev | prev := aBlock. ^ thisContext sender runSimulated: aBlock contextAtEachStep: [:current | Sensor anyButtonPressed ifTrue: [^ nil]. current == prev ifFalse: [prev sender ifNil: [ "Following does not work anymore due to closures?" " aStream space; nextPut: $^. self carefullyPrint: current top on: aStream "]. aStream cr. (current depthBelow: aBlock) timesRepeat: [aStream space]. self carefullyPrint: current receiver on: aStream. aStream space; nextPutAll: current selector; flush. prev := current]]! ! !ContextPart class methodsFor: 'registering simulated primitives' stamp: ''! simulatePrimitiveNumber: num with: simulator ^ self specialPrimitiveSimulators at: num put: simulator! ! !ContextPart class methodsFor: 'simulation' stamp: 'MarcusDenker 10/11/2013 13:13'! initializeTryNamedPrimitiveTemplateMethod | source method | source := 'tryNamedPrimitive "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailTokenFor: errorCode'. method := Smalltalk compiler class: UndefinedObject; source: source; compile. TryNamedPrimitiveTemplateMethod := method copyWithSource: source. ! ! !ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:03'! trace: aBlock "ContextPart trace: [3 factorial]" "This method uses the simulator to print calls and returned values in the Transcript." Transcript clear. ^ self trace: aBlock on: Transcript! ! !ContextTempEyeElement commentStamp: ''! I am an eye element for temporaries in context! !ContextTempEyeElement methodsFor: 'accessing' stamp: 'ClementBera 8/5/2013 10:45'! tempIndex: anObject tempIndex := anObject! ! !ContextTempEyeElement methodsFor: 'accessing' stamp: 'ClementBera 8/5/2013 10:46'! save: aValue self host namedTempAt: self tempIndex put: aValue! ! !ContextTempEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 14:36'! tempName ^ tempName! ! !ContextTempEyeElement methodsFor: 'accessing' stamp: 'ClementBera 8/5/2013 10:46'! value ^ self host namedTempAt: self tempIndex! ! !ContextTempEyeElement methodsFor: 'accessing' stamp: 'ClementBera 8/5/2013 10:45'! accessorCode ^ '(self namedTempAt: ', self tempIndex printString, ')'! ! !ContextTempEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 14:36'! label ^ self tempName! ! !ContextTempEyeElement methodsFor: 'accessing' stamp: 'ClementBera 8/5/2013 10:45'! tempIndex ^ tempIndex! ! !ContextTempEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 14:36'! tempName: anObject tempName := anObject! ! !ContextTempEyeElement class methodsFor: 'as yet unclassified' stamp: 'ClementBera 8/5/2013 10:45'! host: anObject tempName: aString tempIndex: int ^ (self host: anObject) tempName: aString; tempIndex: int; yourself! ! !Continuation commentStamp: ''! I permit to save the execution flow and to restart it later. I was originally used in seaside. Example : You have an object with the instance variable executionFlow. You save the current execution flow with : Continuation currentDo: [ :cc | executionFlow := cc] You restart the execution flow with : executionFlow value: true ! !Continuation methodsFor: 'evaluating' stamp: 'lr 10/28/2007 14:42'! valueWithArguments: anArray anArray size = 1 ifFalse: [ ^ self error: 'continuations can only be resumed with one argument' ]. self value: anArray first! ! !Continuation methodsFor: 'private' stamp: 'CamilleTeruel 4/4/2013 11:58'! initializeFromContext: aContext | valueStream context | valueStream := WriteStream on: (Array new: 20). context := aContext. [context notNil] whileTrue: [valueStream nextPut: context. 1 to: context class instSize do: [:i | valueStream nextPut: (context instVarAt: i)]. 1 to: context size do: [:i | valueStream nextPut: (context at: i)]. context := context sender]. values := valueStream contents! ! !Continuation methodsFor: 'evaluating' stamp: 'ab 6/15/2003 19:13'! value self value: nil! ! !Continuation methodsFor: 'evaluating' stamp: 'lr 10/28/2007 14:42'! value: anObject "Invoke the continuation and answer anObject as return value." self terminate: thisContext. self restoreValues. thisContext swapSender: values first. ^ anObject! ! !Continuation methodsFor: 'accessing' stamp: 'ab 6/15/2003 19:18'! numArgs ^ 1! ! !Continuation methodsFor: 'private' stamp: 'ClementBera 4/3/2013 10:16'! terminate: aContext | context | context := aContext. [context notNil] whileTrue: [context := context swapSender: nil]! ! !Continuation methodsFor: 'private' stamp: 'CamilleTeruel 4/4/2013 11:59'! restoreValues | valueStream context | valueStream := values readStream. [valueStream atEnd] whileFalse: [context := valueStream next. 1 to: context class instSize do: [:i | context instVarAt: i put: valueStream next]. 1 to: context size do: [:i | context at: i put: valueStream next]]! ! !Continuation class methodsFor: 'instance creation' stamp: 'ab 6/15/2003 19:13'! fromContext: aStack ^self new initializeFromContext: aStack! ! !Continuation class methodsFor: 'instance creation' stamp: 'ab 6/15/2003 19:13'! currentDo: aBlock ^ aBlock value: (self fromContext: thisContext sender)! ! !Continuation class methodsFor: 'instance creation' stamp: 'ab 6/15/2003 19:13'! current ^ self fromContext: thisContext sender! ! !ContinuationTest commentStamp: ''! I represent intentend to provide complete coverage for the Continuation class.! !ContinuationTest methodsFor: 'tests' stamp: 'lr 1/5/2007 17:28'! testSimpleCallCC | x continuation | x := self callcc: [ :cc | continuation := cc. false ]. x ifFalse: [ continuation value: true ]. self assert: x! ! !ContinuationTest methodsFor: 'tests' stamp: 'lr 1/5/2007 17:26'! testBlockEscape | x | tmp := 0. x := [ tmp := tmp + 1. tmp2 value ]. self callcc: [ :cc | tmp2 := cc. x value ]. tmp2 := [ ]. x value. self assert: tmp = 2! ! !ContinuationTest methodsFor: 'utilities' stamp: 'ab 6/15/2003 19:23'! callcc: aBlock ^ Continuation currentDo: aBlock! ! !ContinuationTest methodsFor: 'tests' stamp: 'dkh 7/5/2007 12:27'! testBlockTemps | y | #(1 2 3) do: [ :i | | x | x := i. tmp ifNil: [ tmp2 := (self callcc: [ :cc | tmp := cc. [ :q | ] ]) ]. tmp2 value: x. x := 17 ]. y := (self callcc: [ :cc | tmp value: cc. 42 ]). self assert: y = 1! ! !ContinuationTest methodsFor: 'tests' stamp: 'lr 10/28/2007 14:42'! testBlockVars | continuation | tmp := 0. tmp := (self callcc: [ :cc | continuation := cc. 0 ]) + tmp. tmp2 ifNotNil: [ tmp2 value ] ifNil: [ #(1 2 3) do: [ :i | self callcc: [ :cc | tmp2 := cc. continuation value: i ] ] ]. self assert: tmp = 6! ! !ContinuationTest methodsFor: 'tests' stamp: 'lr 1/5/2007 18:22'! testReentrant | assoc | assoc := self callcc: [ :cc | cc -> 0 ]. assoc value: assoc value + 1. self assert: assoc value ~= 5. assoc value = 4 ifFalse: [ assoc key value: assoc ]! ! !ContinuationTest methodsFor: 'tests' stamp: 'lr 1/5/2007 17:28'! testSimplestCallCC | x | x := self callcc: [ :cc | cc value: true ]. self assert: x! ! !ContinuationTest methodsFor: 'tests' stamp: 'lr 1/5/2007 17:27'! testMethodTemps | i continuation | i := 0. i := i + (self callcc: [:cc | continuation := cc. 1]). self assert: i ~= 3. i = 2 ifFalse: [ continuation value: 2 ]! ! !ControlButtonMorph commentStamp: 'gvc 9/23/2008 12:04'! Specially themed "control" button. Used for drop-lists, expanders etc.! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:24'! selectedMouseOverBorderStyle "Return the selected mouse over borderStyle of the receiver." ^self theme controlButtonSelectedMouseOverBorderStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:23'! normalBorderStyle "Return the normal borderStyle of the receiver." ^self theme controlButtonNormalBorderStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/9/2008 13:04'! selectedFillStyle "Return the selected fillStyle of the receiver." ^self theme controlButtonSelectedFillStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:23'! disabledBorderStyle "Return the disabled borderStyle of the receiver." ^self theme controlButtonDisabledBorderStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:58'! pressedBorderStyle "Return the pressed borderStyle of the receiver." ^self theme controlButtonPressedBorderStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:23'! mouseOverFillStyle "Return the mouse over fillStyle of the receiver." ^self theme controlButtonMouseOverFillStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/28/2007 16:52'! normalFillStyle "Return the normal fillStyle of the receiver." ^self theme controlButtonNormalFillStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:24'! selectedPressedBorderStyle "Return the selected pressed borderStyle of the receiver." ^self theme controlButtonSelectedPressedBorderStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:24'! selectedMouseOverFillStyle "Return the selected mouse over fillStyle of the receiver." ^self theme controlButtonSelectedMouseOverFillStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:59'! pressedFillStyle "Return the pressed fillStyle of the receiver." ^self theme controlButtonPressedFillStyleFor: self! ! !ControlButtonMorph methodsFor: 'initialization' stamp: 'gvc 12/5/2008 14:58'! initialize "Initialize the receiver." super initialize. self layoutInset: (self theme controlButtonLabelInsetFor: self)! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:25'! selectedDisabledFillStyle "Return the selected disabled fillStyle of the receiver." ^self theme controlButtonSelectedDisabledFillStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:23'! mouseOverBorderStyle "Return the mouse over borderStyle of the receiver." ^self theme controlButtonMouseOverBorderStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:25'! selectedDisabledBorderStyle "Return the selected disabled borderStyle of the receiver." ^self theme controlButtonSelectedDisabledBorderStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/28/2009 17:12'! minWidth "Consult the theme also." ^self perform: #minWidth withArguments: #() inSuperclass: Morph! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:25'! selectedPressedFillStyle "Return the selected pressed fillStyle of the receiver." ^self theme controlButtonSelectedPressedFillStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/13/2007 11:24'! disabledFillStyle "Return the disabled fillStyle of the receiver." ^self theme controlButtonDisabledFillStyleFor: self! ! !Cookie commentStamp: ''! A Cookie is a simple object which kept a value during a defined amount of time.! !Cookie methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/6/2012 23:22'! defaultTimeToLive ^ Duration minutes: 2! ! !Cookie methodsFor: 'initialization' stamp: 'CamilloBruni 7/19/2013 17:35'! initialize super initialize. timeToLive := self defaultTimeToLive. defaultValue := nil. contents := defaultValue.! ! !Cookie methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/6/2012 23:31'! timeToLive: aDuration timeToLive := aDuration! ! !Cookie methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/6/2012 23:32'! defaultValue: anObject contents = defaultValue ifTrue: [ contents := anObject ]. defaultValue := anObject! ! !Cookie methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/9/2012 16:31'! contents: anObject contents := anObject. hourGlass ifNotNil: [ hourGlass terminate ]. hourGlass := [ (Delay forMilliseconds: timeToLive asMilliSeconds) wait. contents := defaultValue ] fork.! ! !Cookie methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/6/2012 23:18'! contents ^ contents! ! !Cookie methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 12:59'! timeToLive ^ timeToLive! ! !CopyToClipboardDebugAction commentStamp: ''! A CopyToClipboardDebugAction copies a short debugging stack to the clipboard. ! !CopyToClipboardDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 16:49'! id ^ #copyToClipboard! ! !CopyToClipboardDebugAction methodsFor: 'actions' stamp: 'AndreiChis 9/24/2013 16:48'! executeAction Clipboard clipboardText: (String streamContents: [ :s| self debugger interruptedContext shortDebugStackOn: s ])! ! !CopyToClipboardDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 16:47'! defaultLabel ^ 'Copy to clipboard'! ! !CopyToClipboardDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 16:48'! defaultOrder ^ 120! ! !CopyToClipboardDebugAction class methodsFor: 'registration' stamp: 'AndreiChis 9/24/2013 16:47'! actionType ! ! !CopyVisitor commentStamp: 'cwp 11/18/2009 12:30'! I create a copy of the directory tree that I visit. I use the PreorderGuide so that I can create directories before creating their contents. ! !CopyVisitor methodsFor: 'visiting' stamp: 'cwp 11/16/2009 10:52'! visitFile: anEntry | reference | reference := anEntry reference. reference = source ifTrue: [source copyTo: dest] ifFalse: [self copyFile: reference]! ! !CopyVisitor methodsFor: 'initialize-release' stamp: 'cwp 10/30/2009 13:42'! initializeWithSource: srcReference dest: dstReference self initialize. source := srcReference. dest := dstReference! ! !CopyVisitor methodsFor: 'visiting' stamp: 'cwp 11/15/2009 00:31'! copyFile: aReference | copy | copy := dest resolve: (aReference relativeTo: source). aReference copyTo: copy! ! !CopyVisitor methodsFor: 'visiting' stamp: 'cwp 11/17/2009 21:06'! copyDirectory: aReference | directory | directory := dest resolve: (aReference relativeTo: source). directory createDirectory! ! !CopyVisitor methodsFor: 'visiting' stamp: 'EstebanLorenzano 4/2/2012 11:38'! visit (PreorderGuide for: self) show: source! ! !CopyVisitor methodsFor: 'visiting' stamp: 'S 6/17/2013 13:26'! visitDirectory: anEntry | reference | reference := anEntry reference. reference = source ifTrue: [dest ensureCreateDirectory] ifFalse: [self copyDirectory: reference]! ! !CopyVisitor class methodsFor: 'instance creation' stamp: 'cwp 10/30/2009 13:44'! copy: source to: dest (self from: source to: dest) visit! ! !CopyVisitor class methodsFor: 'instance creation' stamp: 'cwp 10/30/2009 13:41'! from: srcReference to: dstReference ^ self basicNew initializeWithSource: srcReference dest: dstReference! ! !CopyVisitorTest commentStamp: 'TorstenBergmann 1/31/2014 11:39'! SUnit tests for CopyVisitor! !CopyVisitorTest methodsFor: 'running' stamp: 'cwp 2/18/2011 16:40'! createFile: aString source store createFile: (source store pathFromString: aString)! ! !CopyVisitorTest methodsFor: 'running' stamp: 'cwp 2/18/2011 16:40'! createDirectory: aString source createDirectory: (source store pathFromString: aString)! ! !CopyVisitorTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/2/2012 11:43'! setUp source := FileSystem memory. dest := FileSystem memory. ! ! !CopyVisitorTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:40'! testAll self setUpGreek. CopyVisitor copy: (source / 'alpha') to: (dest / 'alpha'). self assert: (dest isDirectory: '/alpha'). self assert: (dest isFile: '/alpha/beta/gamma').! ! !CornerGripMorph commentStamp: 'jmv 1/29/2006 17:15'! I am the superclass of a hierarchy of morph specialized in allowing the user to resize windows.! !CornerGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:24'! defaultHeight ^ 22! ! !CornerGripMorph methodsFor: 'initialization' stamp: 'gvc 4/26/2007 12:08'! initialize super initialize. self extent: self defaultWidth @ self defaultHeight. self layoutFrame: self gripLayoutFrame! ! !CornerGripMorph methodsFor: 'accessing' stamp: 'jmv 2/2/2006 14:24'! defaultWidth ^ 22! ! !CornerGripMorph methodsFor: 'accessing' stamp: 'gvc 2/12/2007 16:36'! targetPoint "Answer the reference point of the target." ^self target bounds pointAtSideOrCorner: self ptName! ! !CornerGripMorph methodsFor: 'event' stamp: 'gvc 7/30/2009 14:06'! mouseDown: anEvent "Remember the receiver and target offsets too." |cp| cp := anEvent cursorPoint. lastMouse := {cp. cp - self position. cp - self targetPoint}! ! !CornerGripMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2009 14:07'! targetPoint: aPoint "Set the reference point of the target." |minExt rect| rect := self target bounds withSideOrCorner: self ptName setToPoint: aPoint. minExt := self target minimumExtent. rect width <= minExt x ifTrue: [ (self ptName = #topLeft or: [self ptName = #bottomLeft]) ifTrue: [rect := rect withSideOrCorner: #left setToPoint: self target bounds bottomRight - minExt] ifFalse: [rect := rect withSideOrCorner: #right setToPoint: self target bounds topLeft + minExt]]. rect height <= minExt y ifTrue: [ (self ptName = #topLeft or: [self ptName = #topRight]) ifTrue: [rect := rect withSideOrCorner: #top setToPoint: self target bounds bottomRight - minExt] ifFalse: [rect := rect withSideOrCorner: #bottom setToPoint: self target bounds topLeft + minExt]]. self target bounds: rect! ! !CornerGripMorph methodsFor: 'event' stamp: 'gvc 2/12/2007 16:36'! mouseMove: anEvent "Track the mouse for resizing." target ifNil: [^ self]. target fastFramingOn ifTrue: [target doFastWindowReframe: self ptName] ifFalse: [ lastMouse at: 1 put: anEvent cursorPoint. self targetPoint: lastMouse first - lastMouse last. self position: (lastMouse first - lastMouse second)].! ! !CornerGripMorph methodsFor: 'accessing' stamp: 'gvc 2/12/2007 16:28'! target "Answer the target." ^target! ! !CornerGripMorph methodsFor: 'accessing' stamp: 'gvc 3/27/2008 21:50'! target: aMorph target := aMorph. aMorph ifNotNil: [ self fillStyle: (aMorph theme resizerGripNormalFillStyleFor: self)]! ! !CornerRounder commentStamp: ''! This class is a quick hack to support rounded corners in morphic. Rather than produce rounded rectangles, it tweaks the display of corners. Rather than work for any radius, it only supports a radius of 6. Rather than work for any border width, it only supports widths 0, 1 and 2. The corners, while apparently transparent, still behave opaquely to mouse clicks. Worse than this, the approach relies on the ability to extract underlying bits from the canvas prior to display. This ran afoul of top-down display, it seems, in SystemWindow spawnReframeHandle: (qv). It will also make a postscript printer very unhappy. But, hey, it's cute.! !CornerRounder methodsFor: 'all' stamp: 'di 6/24/1999 09:35'! masterMask: maskForm masterOverlay: overlayForm cornerMasks := #(none left pi right) collect: [:dir | (maskForm rotateBy: dir centerAt: 0@0) offset: 0@0]. cornerOverlays := #(none left pi right) collect: [:dir | (overlayForm rotateBy: dir centerAt: 0@0) offset: 0@0]. ! ! !CornerRounder methodsFor: 'all' stamp: 'IgorStasenko 7/18/2011 18:11'! tweakCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: cornerList "This variant has a cornerList argument, to allow some corners to be rounded and others not" | fourColors mask corners | w > 0 ifTrue:[ fourColors := aMorph borderStyle colorsAtCorners ]. mask := Form extent: cornerMasks first extent depth: aCanvas depth. corners := bounds corners. cornerList do:[:i| | offset corner saveBits outBits | corner := corners at: i. saveBits := underBits at: i. saveBits ifNotNil:[ i = 1 ifTrue: [offset := 0@0]. i = 2 ifTrue: [offset := 0@saveBits height negated]. i = 3 ifTrue: [offset := saveBits extent negated]. i = 4 ifTrue: [offset := saveBits width negated@0]. "Mask out corner area (painting saveBits won't clear if transparent)." mask copyBits: mask boundingBox from: (cornerMasks at: i) at: 0@0 clippingBox: mask boundingBox rule: Form over fillColor: nil map: (Bitmap with: 0 with: 16rFFFFFFFF). outBits := aCanvas contentsOfArea: (corner + offset extent: mask extent). mask displayOn: outBits at: 0@0 rule: Form and. "Paint back corner bits." saveBits displayOn: outBits at: 0@0 rule: Form paint. "Paint back corner bits." aCanvas drawImage: outBits at: corner + offset. w > 0 ifTrue:[ aCanvas stencil: (cornerOverlays at: i) at: corner + offset color: (fourColors at: i)]]]. ! ! !CornerRounder methodsFor: 'all' stamp: 'nice 12/26/2009 01:26'! saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: cornerList | corners | underBits := Array new: 4. corners := bounds corners. cornerList do:[:i| | offset corner mask form rect | mask := cornerMasks at: i. corner := corners at: i. i = 1 ifTrue: [offset := 0@0]. i = 2 ifTrue: [offset := 0@mask height negated]. i = 3 ifTrue: [offset := mask extent negated]. i = 4 ifTrue: [offset := mask width negated@0]. rect := corner + offset extent: mask extent. (aCanvas isVisible: rect) ifTrue:[ form := aCanvas contentsOfArea: rect. form copyBits: form boundingBox from: mask at: 0@0 clippingBox: form boundingBox rule: Form and fillColor: nil map: (Bitmap with: 16rFFFFFFFF with: 0). underBits at: i put: form]]. ! ! !CornerRounder methodsFor: 'all' stamp: 'GaryChambers 9/8/2011 14:46'! tweakShadowCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: cornerList "This variant has a cornerList argument, to allow some corners to be rounded and others not" | fourColors mask corners | w > 0 ifTrue: [fourColors := Array new: 4 withAll: Color transparent]. mask := Form extent: cornerMasks first extent depth: aCanvas depth. corners := bounds corners. cornerList do:[:i| | offset corner saveBits outBits | corner := corners at: i. saveBits := underBits at: i. saveBits ifNotNil:[ i = 1 ifTrue: [offset := 0@0]. i = 2 ifTrue: [offset := 0@saveBits height negated]. i = 3 ifTrue: [offset := saveBits extent negated]. i = 4 ifTrue: [offset := saveBits width negated@0]. "Mask out corner area (painting saveBits won't clear if transparent)." mask copyBits: mask boundingBox from: (cornerMasks at: i) at: 0@0 clippingBox: mask boundingBox rule: Form over fillColor: nil map: (Bitmap with: 0 with: 16rFFFFFFFF). outBits := aCanvas contentsOfArea: (corner + offset extent: mask extent). mask displayOn: outBits at: 0@0 rule: Form and. "Paint back corner bits." saveBits displayOn: outBits at: 0@0 rule: Form paint. "Paint back corner bits." aCanvas drawImage: outBits at: corner + offset. w > 0 ifTrue:[ aCanvas stencil: (cornerOverlays at: i) at: corner + offset color: (fourColors at: i)]]]. ! ! !CornerRounder class methodsFor: 'all' stamp: 'di 6/28/1999 15:51'! initialize "CornerRounder initialize" CR0 := CR1 := self new masterMask: (Form extent: 6@6 fromArray: #(2r1e26 2r111e26 2r1111e26 2r11111e26 2r11111e26 2r111111e26) offset: 0@0) masterOverlay: (Form extent: 6@6 fromArray: #(2r1e26 2r110e26 2r1000e26 2r10000e26 2r10000e26 2r100000e26) offset: 0@0). CR2 := self new masterMask: (Form extent: 6@6 fromArray: #(2r1e26 2r111e26 2r1111e26 2r11111e26 2r11111e26 2r111111e26) offset: 0@0) masterOverlay: (Form extent: 6@6 fromArray: #(2r1e26 2r111e26 2r1111e26 2r11100e26 2r11000e26 2r111000e26) offset: 0@0). ! ! !CornerRounder class methodsFor: 'all' stamp: 'di 3/25/2000 11:12'! rectWithinCornersOf: aRectangle "Return a single sub-rectangle that lies entirely inside corners that are made by me. Used to identify large regions of window that do not need to be redrawn." ^ aRectangle insetBy: 0@6! ! !CornerRounder class methodsFor: 'all' stamp: 'GaryChambers 9/8/2011 14:46'! roundShadowCornersOf: aMorph on: aCanvas in: bounds displayBlock: displayBlock borderWidth: w corners: aList | rounder | rounder := CR0. w = 1 ifTrue: [rounder := CR1]. w = 2 ifTrue: [rounder := CR2]. rounder := rounder copy. rounder saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: aList. displayBlock value. rounder tweakShadowCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: aList! ! !CornerRounder class methodsFor: 'all' stamp: 'ar 1/5/2002 17:24'! roundCornersOf: aMorph on: aCanvas in: bounds displayBlock: displayBlock borderWidth: w corners: aList | rounder | rounder := CR0. w = 1 ifTrue: [rounder := CR1]. w = 2 ifTrue: [rounder := CR2]. rounder := rounder copy. rounder saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: aList. displayBlock value. rounder tweakCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: aList! ! !CredentialEditor commentStamp: ''! I am a simple UI used to set the credentials of a remote! !CredentialEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 13:04'! getPassword ^ password text! ! !CredentialEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 13:03'! getUsername ^ username text! ! !CredentialEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/4/2013 12:41'! usernameLabel ^ usernameLabel! ! !CredentialEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 12:51'! setUsername: aName username text: aName! ! !CredentialEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 12:51'! setPassword: aPassword password text: aPassword! ! !CredentialEditor methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 12/4/2013 14:31'! initializeWidgets username := self newTextInput. usernameLabel := self newLabel. password := self newTextInput. passwordLabel := self newLabel. showPassword := self newCheckBox. usernameLabel text: 'Username'. passwordLabel text: 'Password'. password ghostText: '*****'; autoAccept: true; beEncrypted. username ghostText: 'John Doe'; autoAccept: true. showPassword label: 'Show password'. self focusOrder add: username; add: password; add: showPassword.! ! !CredentialEditor methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 12/4/2013 13:24'! initializeDialogWindow: aWindow self bindKeyCombination: $m control toAction: [ aWindow triggerOkAction ]! ! !CredentialEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/4/2013 12:41'! password ^ password! ! !CredentialEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/4/2013 12:41'! username ^ username! ! !CredentialEditor methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 12/4/2013 14:34'! initializePresenter showPassword whenActivatedDo: [ password beDecrypted ]; whenDesactivatedDo: [ password beEncrypted ]! ! !CredentialEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 12:47'! title ^ 'Edit credentials'! ! !CredentialEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/4/2013 14:31'! showPasswordWidget ^ showPassword! ! !CredentialEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/4/2013 12:41'! passwordLabel ^ passwordLabel! ! !CredentialEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 14:31'! initialExtent ^ 400@160! ! !CredentialEditor class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 12/4/2013 14:33'! defaultSpec ^ SpecLayout composed newColumn: [ :col | col newRow: [ :r | r add: #usernameLabel width: 80; add: #username ] height: self inputTextHeight; newRow: [ :r | r add: #passwordLabel width: 80; add: #password ] height: self inputTextHeight + 4; newRow: [ :r | r add: #showPasswordWidget width: 120; newColumn: [ :c | ] ] height: self inputTextHeight + 4; newRow: [ :r | ] ]; yourself! ! !CriticBrowser commentStamp: ''! I display code critics, the results obtained when running a lint rule. Example: | rule env | rule := RBExcessiveArgumentsRule new. env := (RBPackageEnvironment packageName: 'Manifest-Core'). (CriticBrowser openOnRule: rule onEnvironment: env).! !CriticBrowser methodsFor: 'protocol' stamp: 'CamilleTeruel 9/18/2013 11:21'! onWindowClosed cache cacheChange ifTrue: [ (MorphicUIManager new confirm: 'Do you want log all wrong violations in the Manifests before closing the Critics Browser ?') ifTrue: [ cache logInManifest ]]. ! ! !CriticBrowser methodsFor: 'private' stamp: 'StephaneDucasse 3/20/2013 22:33'! addRuleToFalsePositive rulesModel selectedItem ifNotNil: [ :rule | rule leaves do: [ :r | rbEnvironment packages do: [ :package | cache addFalsePositiveRule: r forPackage: package ]]]. ! ! !CriticBrowser methodsFor: 'private' stamp: 'StephaneDucasse 9/13/2013 20:07'! stringMorphForRule: rule | unclassified falsePositives toDos text total | falsePositives := (cache falsePositiveOf: rule) size. toDos := (cache toDosOf: rule) size. total := (cache criticsOf: rule) size. unclassified := total - falsePositives - toDos. text := String streamContents: [ :s | s << rule name; << ' (To sort: '; print: unclassified; << ', ToDo: '; print: toDos; << ', Wrong: '; print: falsePositives; << ')' ]. ^ text asMorph color: (self colorForRule: rule); yourself ! ! !CriticBrowser methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/7/2013 10:45'! reapplyThisRule | rule | rulesModel selectedItem ifNil: [ ^ self ]. rule := rulesModel selectedItem content. rule leaves do: [ :each | self reapplyRule: each ]. ! ! !CriticBrowser methodsFor: 'initialization' stamp: 'StephaneDucasse 3/20/2013 22:32'! setActionLogButtom ^ [(MorphicUIManager new confirm: 'Do you want to save all false positive and toDo in the Manifests ? (this action may generate new manifest classes and make dirty your package)') ifTrue: [ cache logInManifest] ]! ! !CriticBrowser methodsFor: 'initialization' stamp: 'SimonAllier 2/8/2013 15:32'! setLogButton logButton state: false; label: 'Save Critics'; action: self setActionLogButtom ! ! !CriticBrowser methodsFor: 'private' stamp: 'NicolaiHess 12/18/2013 21:53'! browseRule rulesModel selectedItem ifNotNil: [ :item | item content browse ]! ! !CriticBrowser methodsFor: 'system annoucements' stamp: 'CamilleTeruel 11/14/2013 13:43'! methodRemoved: anAnnouncement | classes | classes := rbEnvironment packages flatCollect: [ :package | package classes]. (classes anySatisfy: [ :cl | anAnnouncement methodClass = cl ]) ifFalse: [ ^ self ]. cache itemRemoved: anAnnouncement methodRemoved! ! !CriticBrowser methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 22:55'! initialize super initialize. cache := CriticsCache new. checker := SmalllintManifestChecker new. cache checker: checker. cache browser: self. criticModel cache: cache. ! ! !CriticBrowser methodsFor: 'private' stamp: 'CamilleTeruel 11/14/2013 14:13'! reapplyRule: aRule | oldCritics | oldCritics := aRule critics. aRule resetResult. rbEnvironment packages do: [ :package | checker runRules: aRule onPackage: package withoutTestCase: removeTestCase ]. (oldCritics \ (aRule critics)) do: [ :each | cache removeCritic: each forRule: aRule. cache removeFalsePositive: each forRule: aRule. cache removeToDo: each forRule: aRule ]. checker rule: aRule. ! ! !CriticBrowser methodsFor: 'user interface' stamp: 'StephaneDucasse 3/20/2013 22:37'! addModelItemsToWindowMenu: aMenu "Add model-related items to the window menu" aMenu addLine; add: 'Clean all manifest' translated target: checker action: #cleanAllManifest; add: 'Reapply all rules' translated target: self action: #reapplyAllRules! ! !CriticBrowser methodsFor: 'initialization' stamp: 'CamilleTeruel 9/18/2013 14:58'! initializePresenter rulesModel whenSelectedItemChanged: [ :rule | (rule isNil or: [ rule isComposite ]) ifFalse: [ criticModel resetSelection. criticModel rule: rule. criticModel setTextModelForNil]. self setTitle: rule name] ! ! !CriticBrowser methodsFor: 'protocol' stamp: 'SimonAllier 7/27/2012 11:08'! title ^ title! ! !CriticBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 12/22/2012 19:41'! environment: aEnv rbEnvironment := aEnv ! ! !CriticBrowser methodsFor: 'accessing' stamp: ''! criticModel ^ criticModel! ! !CriticBrowser methodsFor: 'accessing' stamp: 'SimonAllier 5/22/2012 16:00'! rules: aCompositeRule self rulesModel roots: {aCompositeRule} ! ! !CriticBrowser methodsFor: 'thread' stamp: 'CamilleTeruel 9/18/2013 15:03'! updateTree criticModel updateList. rulesModel updateTree! ! !CriticBrowser methodsFor: 'accessing' stamp: 'SimonAllier 1/24/2013 12:55'! environment ^ rbEnvironment ! ! !CriticBrowser methodsFor: 'accessing' stamp: 'SimonAllier 1/29/2013 15:27'! logButton ^ logButton ! ! !CriticBrowser methodsFor: 'system annoucements' stamp: 'CamilleTeruel 9/18/2013 14:58'! methodAdded: anAnnouncement anAnnouncement methodClass isManifest ifFalse: [ ^ self ]. self updateCountOf: rulesModel selectedItem.! ! !CriticBrowser methodsFor: 'private' stamp: 'CamilleTeruel 11/13/2013 07:42'! applyRules | packageCount nbPackage process rules | rules := rulesModel roots first. rules resetResult. nbPackage := rbEnvironment packages size. packageCount := 0. self updateTree. process := [ rbEnvironment packages do: [ :package | | windowTitle | packageCount := packageCount + 1. windowTitle := String streamContents: [ :s | s << 'run rules on ' << package packageName << ' (' << packageCount asString << '/' << nbPackage asString << ')' ]. self setTitle: windowTitle. checker runRules: rules onPackage: package withoutTestCase: removeTestCase ]. checker rule: rules. self setTitle: 'Critics Browser'. cache packages: rbEnvironment. cache initCache. self updateTree. self registerToAnnouncements ] newProcess. process name: 'SmallLint'. process resume. ! ! !CriticBrowser methodsFor: 'private' stamp: 'SimonAllier 1/25/2013 16:23'! logInManifest cache logInManifest! ! !CriticBrowser methodsFor: 'menu' stamp: 'BenjaminVanRyseghem 12/7/2013 10:45'! menu: aMenu shifted: aBoolean aMenu addGroup:[ :g | g addItem: [ :i | i name: 'Browse rule' translated; action: [ self browseRule ]]. g addItem: [ :i | i name: 'Reapply this rule' translated; action: [ self reapplyThisRule ] ] ]; addGroup:[ :g | g addItem: [ :i | i name: 'Ban from selected packages' translated; action: [ self addRuleToFalsePositive ]]. g addItem: [ :i | i name: 'Unban from selected packages' translated; action: [ self removeRuleToFalsePositive ] ] ]. ^ aMenu! ! !CriticBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2012 17:18'! initialExtent ^ 760@370! ! !CriticBrowser methodsFor: 'protocol' stamp: 'Sd 11/30/2012 17:32'! setTitle: aTitle title := aTitle. self window updateTitle ! ! !CriticBrowser methodsFor: 'private' stamp: 'StephaneDucasse 3/20/2013 22:34'! removeRuleToFalsePositive rulesModel selectedItem ifNotNil: [ :rule | rule leaves do: [ :r | rbEnvironment packages do: [ :package | cache removeFalsePositiveRule: r forPackage: package ]]]. ! ! !CriticBrowser methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/24/2012 17:29'! taskbarIcon ^ self class icon! ! !CriticBrowser methodsFor: 'accessing' stamp: 'SimonAllier 1/21/2013 17:03'! removeTestCase: aBoolean removeTestCase := aBoolean! ! !CriticBrowser methodsFor: 'initialization' stamp: 'StephaneDucasse 3/20/2013 22:31'! setActionResetButtom ^ [(MorphicUIManager new confirm: 'Do you want to delete the current configuration and create a new configuration ?') ifTrue: [ self delete. SelectPackageBrowser open.] ]! ! !CriticBrowser methodsFor: 'initialization' stamp: 'SimonAllier 2/8/2013 15:31'! setResetButton resetButton state: false; label: 'Run new configuration'; action: self setActionResetButtom.! ! !CriticBrowser methodsFor: 'private' stamp: 'CamilleTeruel 8/28/2013 15:18'! colorForRule: aRule | total | ^ (total := cache criticsOf: aRule) ifEmpty: [ Color black ] ifNotEmpty: [ (cache falsePositiveOf: aRule) = total ifTrue: [ criticModel falsePositiveColor ] ifFalse: [ criticModel defaultColor ] ]! ! !CriticBrowser methodsFor: 'initialization' stamp: 'CamilloBruni 2/25/2014 19:40'! initializeWidgets title := 'Critic Browser'. self instantiateModels: #( rulesModel TreeModel resetButton ButtonModel logButton ButtonModel ). self setLogButton. self setResetButton. criticModel := SingleCodeCriticResultList new. rulesModel childrenBlock: [ :rule | rule isComposite ifTrue: [ rule rules ] ifFalse: [ #() ]]. rulesModel displayBlock: [ :rule | self stringMorphForRule: rule ]. rulesModel menu: [ :aMenu :shifted | self menu: aMenu shifted: shifted ]. self focusOrder add: rulesModel; add: criticModel! ! !CriticBrowser methodsFor: 'system annoucements' stamp: 'StephaneDucasse 3/20/2013 22:36'! methodModified: anAnnouncement "checks if a modification of a method fixes a warning. if true, the true positives in the browser are update" "checks if a method of a manifest class is modified and update false positive in the browser" (criticModel criticsModelContains: anAnnouncement oldMethod) ifFalse: [ ^ self ]. cache replaceAll: anAnnouncement oldMethod by: anAnnouncement newMethod. self reapplyThisRule ! ! !CriticBrowser methodsFor: 'accessing' stamp: 'SimonAllier 1/29/2013 15:27'! resetButton ^ resetButton ! ! !CriticBrowser methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/14/2013 18:56'! open ^ self openWithSpec! ! !CriticBrowser methodsFor: 'system annoucements' stamp: 'CamilleTeruel 9/18/2013 10:47'! registerToAnnouncements SystemAnnouncer uniqueInstance weak on: ClassModifiedClassDefinition send: #classModified: to: self; on: MethodModified send: #methodModified: to: self; on: MethodRemoved send: #methodRemoved: to: self. self window window announcer on: WindowClosed send: #onWindowClosed to: self. ! ! !CriticBrowser methodsFor: 'private' stamp: 'CamilleTeruel 9/18/2013 14:58'! reapplyAllRules | ruleCount total rule | ruleCount := 0. rule := rulesModel roots first. total := rule leaves size. rule leaves do: [ :r | ruleCount := ruleCount + 1. self setTitle: (String streamContents: [:s | s << 'run rules: ' << r name << ' (' << ruleCount asString << '/' << total asString <<')']). self reapplyRule: r ]. self setTitle: 'Critics Browser'.! ! !CriticBrowser methodsFor: 'system annoucements' stamp: 'StephaneDucasse 3/20/2013 22:35'! classModified: anAnnouncement "checks if a modification of a class fixes a warning. if true, the true/false positives in the browser are update" | class | class := anAnnouncement class. class isManifest ifTrue: [ ^ self ]. (criticModel criticsModelContains: anAnnouncement classAffected) ifFalse: [^ self]. self reapplyThisRule ! ! !CriticBrowser methodsFor: 'accessing' stamp: ''! rulesModel ^ rulesModel! ! !CriticBrowser class methodsFor: 'specs' stamp: 'SimonAllier 2/8/2013 16:11'! defaultSpec ^ SpecLayout composed newColumn: [:c | c newRow: [:r | r newColumn: [:c1 | c1 add: #rulesModel. c1 newRow: [:c2 | c2 add: #resetButton. c2 add: #logButton ] height: 25 ]; newColumn: [:c1 | c1 add: #(criticModel textInputFieldModel) height: 20; add: #(criticModel criticsModel); add: #(criticModel toolbarModel) height: 25 ]]; addSplitter; add: #(criticModel textModel) ]! ! !CriticBrowser class methodsFor: 'instance creation' stamp: 'CamilleTeruel 11/14/2013 14:38'! packagesMenu: aBuilder (aBuilder item: #'Critic Browser') action: [ self openOnRule: (RBCompositeLintRule allGoodRules) onEnvironment: (RBPackageEnvironment new packages: aBuilder model selectedPackages; yourself) ]; help: 'Running critics rules on this package'! ! !CriticBrowser class methodsFor: 'instance creation' stamp: 'CamilleTeruel 11/12/2013 19:36'! openOnWorkingConfiguration: aWorkingConfiguration | cbr | cbr := self new rules: aWorkingConfiguration rule; environment: aWorkingConfiguration environment; removeTestCase: aWorkingConfiguration removeTestCase; yourself. cbr openWithSpec. cbr applyRules. cbr rulesModel changed: #listElementAt:.! ! !CriticBrowser class methodsFor: 'menu' stamp: 'SimonAllier 2/1/2013 15:31'! openOnCurrentWorkingConfiguration CriticWorkingConfiguration exists ifTrue: [ ResetWindow new openWithSpec ] ifFalse: [ SelectPackageBrowser open]! ! !CriticBrowser class methodsFor: 'instance creation' stamp: 'CamilleTeruel 11/12/2013 19:31'! open | env rules | rules := RBCompositeLintRule allGoodRules rules. env := RBBrowserEnvironment default. self openOnRule: rules onEnvironment: env! ! !CriticBrowser class methodsFor: 'instance creation' stamp: 'SimonAllier 1/30/2013 10:43'! openOnRule: aRule onEnvironment: aEnv | cbr | cbr := self new rules: aRule; environment: aEnv; removeTestCase: false; yourself. cbr openWithSpec. cbr applyRules. cbr rulesModel changed: #listElementAt:.! ! !CriticBrowser class methodsFor: 'menu' stamp: 'TorstenBergmann 2/12/2014 09:25'! criticsBrowserMenuOn: aBuilder "I build a menu" (aBuilder item: 'Critic Browser') action: [ self openOnCurrentWorkingConfiguration]; order: 0.41; parent: #Tools; help: 'To manage rule checks'; icon: self icon! ! !CriticBrowser class methodsFor: 'menu' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme ^ Smalltalk ui theme ! ! !CriticBrowser class methodsFor: 'menu' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon "Answer an icon for the receiver." ^ Smalltalk ui icons smallWarningIcon! ! !CriticToolbar commentStamp: ''! I am the toolbar for a selected SmallLint Critic in the critic browser. Instance Variables browseModel: criticHolder: falsepositiveModel: ruleHolder: transformModel: browseModel - xxxxx criticHolder - xxxxx falsepositiveModel - xxxxx ruleHolder - xxxxx transformModel - xxxxx ! !CriticToolbar methodsFor: 'initialization' stamp: 'StephaneDucasse 3/21/2013 09:21'! registerForChanges criticHolder whenChangedDo: [ :contents | | boolean | boolean := contents notNil. browseModel state: (boolean and: [ browseModel enabled ]). transformModel state: (boolean and: [ transformModel enabled ]). falsepositiveModel state: (boolean and: [ falsepositiveModel enabled ]) ] ! ! !CriticToolbar methodsFor: 'initialization' stamp: ''! setFocusOrder self focusOrder add: browseModel; add: transformModel; add: falsepositiveModel. ! ! !CriticToolbar methodsFor: 'initialization' stamp: 'SimonAllier 7/24/2012 14:07'! initializeWidgets! ! !CriticToolbar methodsFor: 'accessing' stamp: ''! browseModel ^ browseModel! ! !CriticToolbar methodsFor: 'initialization' stamp: 'CamilleTeruel 9/18/2013 11:25'! setFalsepositiveModel falsepositiveModel state: false; label: 'Mark as wrong'; action: [ ]. ! ! !CriticToolbar methodsFor: 'initialization' stamp: ''! setTransformModel transformModel state: false; label: 'Transform'; action: [ self transformCritic ]. ! ! !CriticToolbar methodsFor: 'initialization' stamp: ''! whenFalsePositiveClickedDo: aBlock self falsepositiveModel whenActionPerformedDo: aBlock! ! !CriticToolbar methodsFor: 'accessing' stamp: ''! falsepositiveModel ^ falsepositiveModel! ! !CriticToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize super initialize. criticHolder := nil asValueHolder. ruleHolder := nil asValueHolder. browseModel := self instantiate: ButtonModel. transformModel := self instantiate: ButtonModel. falsepositiveModel := self instantiate: ButtonModel. self setFocusOrder. self setBrowseModel. self setTransformModel. self setFalsepositiveModel. self registerForChanges.! ! !CriticToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! rule: aRule ruleHolder value: aRule. transformModel enabled: aRule isTransformationRule ! ! !CriticToolbar methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! transformCritic criticHolder value ifNotNil: [:critic | ruleHolder value transform: critic ] ! ! !CriticToolbar methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! browseCritic criticHolder value ifNotNil: [ :elem | elem browse ] ! ! !CriticToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! critic: aCritic criticHolder value: aCritic! ! !CriticToolbar methodsFor: 'initialization' stamp: ''! setBrowseModel browseModel state: false; label: 'Browse'; action: [ self browseCritic ]. ! ! !CriticToolbar methodsFor: 'accessing' stamp: ''! transformModel ^ transformModel! ! !CriticToolbar class methodsFor: 'specs' stamp: 'SimonAllier 9/28/2012 13:55'! defaultSpec ^SpecLayout composed newRow: [:r | r add: #browseModel; add: #transformModel; add: #falsepositiveModel ] height: 25! ! !CriticWorkingConfiguration commentStamp: ''! A CriticWorkspace holds the current worspace for the CriticBrowser. It's composed of the set of rules to check (as a composite rule) and the environment to work in.! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'StephaneDucasse 3/21/2013 09:24'! removeTestCase: aBoolean removeTestCase := aBoolean! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 18:04'! rule: anObject rule := anObject! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 18:04'! environment: anObject environment := anObject! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 18:04'! rule ^ rule! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'StephaneDucasse 3/21/2013 09:24'! logInManifest ^ logInManifest! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'StephaneDucasse 3/21/2013 09:24'! logInManifest: anObject logInManifest := anObject! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'StephaneDucasse 3/21/2013 09:24'! removeTestCase ^ removeTestCase! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 18:04'! environment ^ environment! ! !CriticWorkingConfiguration class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/24/2012 18:05'! reset Current := nil! ! !CriticWorkingConfiguration class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/24/2012 18:05'! new ^ self shouldNotImplement! ! !CriticWorkingConfiguration class methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/24/2012 18:11'! exists ^ Current notNil! ! !CriticWorkingConfiguration class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/24/2012 18:05'! current ^ Current ifNil: [ Current := self basicNew initialize ].! ! !CriticsCache commentStamp: ''! I am a cache for the critics and false positives critics Instance Variables browser: checker: critics: falsePositiveClasses: falsePositiveRules: falsePositives: packages: toDos: browser - xxxxx checker - xxxxx critics - xxxxx falsePositiveClasses - xxxxx falsePositiveRules - xxxxx falsePositives - xxxxx packages - xxxxx toDos - xxxxx ! !CriticsCache methodsFor: 'add/remove' stamp: 'StephaneDucasse 3/20/2013 22:40'! addToDo: aCritic forRule: aRule (toDos includesKey: aRule) ifFalse: [ toDos at:aRule put: IdentitySet new ]. (toDos at:aRule) add: aCritic. self updateBrowser! ! !CriticsCache methodsFor: 'testing' stamp: 'SimonAllier 1/23/2013 11:27'! isFalsePositive: aCritic forRule: aRule ^ (self falsePositiveOf: aRule) includes: aCritic! ! !CriticsCache methodsFor: 'testing' stamp: 'SimonAllier 1/23/2013 11:50'! isToDo: aCritic forRule: aRule ^ (self toDosOf: aRule) includes: aCritic! ! !CriticsCache methodsFor: 'protocol' stamp: 'StephaneDucasse 3/21/2013 09:19'! toDosOf: aRule aRule ifNil: [ ^ {}]. ^ aRule isComposite ifTrue: [ aRule leaves gather: [:rule | self toDosOf: rule]] ifFalse: [toDos at: aRule ifAbsent: [{}]]! ! !CriticsCache methodsFor: 'add/remove' stamp: 'CamilleTeruel 9/18/2013 14:59'! addFalsePositiveRule: aRule forPackage: aPackage | fp | (falsePositiveRules includesKey: aPackage) ifFalse: [ falsePositiveRules at: aPackage put: Set new ]. (falsePositiveRules at: aPackage) add: (aRule class uniqueIdentifierName). fp := (critics at: aRule ifAbsent: [^ self]) select: [ :c | (self packageOf: c) package name = aPackage packageName ]. fp do: [ :c | self addFalsePositive: c forRule: aRule ]! ! !CriticsCache methodsFor: 'private' stamp: 'StephaneDucasse 3/20/2013 22:37'! addAllCriticToToDo: aCollectionOfCritic forRule: aRule on: aManifestBuilder | ruleId versionId | ruleId := aRule class uniqueIdentifierName. versionId := aRule class identifierMinorVersionNumber. (aManifestBuilder hasToDoOf: ruleId version: versionId) ifFalse: [ aManifestBuilder installToDoOf: ruleId version: versionId ]. aManifestBuilder addAllToDo: aCollectionOfCritic of: ruleId version: versionId. ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'StephaneDucasse 3/20/2013 22:38'! addFalsePositive: aCritic forRule: aRule (falsePositives includesKey: aRule) ifFalse: [ falsePositives at: aRule put: IdentitySet new ]. (falsePositives at:aRule) add: aCritic. self updateBrowser ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'StephaneDucasse 3/20/2013 22:38'! addCritic: aCritic forRule: aRule (critics includesKey: aRule) ifFalse: [ critics at:aRule put: IdentitySet new ]. (critics at:aRule) add: aCritic. self updateBrowser! ! !CriticsCache methodsFor: 'private' stamp: 'SimonAllier 2/5/2013 11:11'! cacheNotChanged change := false! ! !CriticsCache methodsFor: 'initialize-release' stamp: 'StephaneDucasse 3/20/2013 22:41'! initCache checker rule leaves do: [ :rule | falsePositives at: rule put: (IdentitySet newFrom: (checker falsePositiveOf: rule)). toDos at: rule put: (IdentitySet newFrom: (checker toDoOf: rule)). critics at: rule put: (IdentitySet newFrom: rule critics) ]. packages do: [ :package | falsePositiveRules at: package put: (checker rejectRulesOf: package) asSet. falsePositiveClasses addAll: (checker rejectClassesOf: package) asIdentitySet. ]! ! !CriticsCache methodsFor: 'private' stamp: 'StephaneDucasse 3/21/2013 13:13'! logFalsePositiveClassInManifest | manifestBuilder | packages do: [ :package | manifestBuilder := self builderManifestClass ofPackageNamed: package packageName. manifestBuilder rejectClasses \ falsePositiveClasses do: [ :cl | manifestBuilder removeRejectClass: cl ]. falsePositiveClasses \ manifestBuilder rejectClasses do: [ :cl | manifestBuilder addRejectClass: cl ] ]! ! !CriticsCache methodsFor: 'protocol' stamp: 'ClementBera 7/26/2013 16:36'! criticsOf: aRule aRule ifNil: [ ^ {} ]. ^ aRule isComposite ifTrue: [ aRule leaves gather: [ :rule | self criticsOf: rule ]] ifFalse: [ critics at: aRule ifAbsent: [{}]]! ! !CriticsCache methodsFor: 'initialization' stamp: 'StephaneDucasse 3/20/2013 22:41'! initialize super initialize. falsePositives := Dictionary new. toDos := Dictionary new. critics := Dictionary new. falsePositiveRules := Dictionary new. falsePositiveClasses := IdentitySet new. change := false ! ! !CriticsCache methodsFor: 'private' stamp: 'StephaneDucasse 3/20/2013 22:46'! removeAllCriticToToDo: aCollectionOfCritic forRule: aRule on: aManifestBuilder | ruleId versionId | ruleId := aRule class uniqueIdentifierName. versionId := aRule class identifierMinorVersionNumber. (aManifestBuilder hasToDoOf: ruleId version: versionId) ifTrue: [ aManifestBuilder removeAllToDo: aCollectionOfCritic of: ruleId version: versionId]. ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'StephaneDucasse 3/21/2013 13:01'! removeFalsePositive: aCritic forRule: aRule (falsePositives includesKey: aRule) ifFalse: [^ self]. (falsePositiveClasses includes: aCritic criticTheNonMetaclassClass) ifTrue: [^ self]. (falsePositives at: aRule) remove: aCritic ifAbsent: [^ self]. self updateBrowser ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'SimonAllier 2/5/2013 11:16'! removeToDo: aCritic forRule: aRule (toDos includesKey: aRule) ifFalse: [^ self]. (toDos at:aRule) remove: aCritic ifAbsent: [^ self]. self updateBrowser ! ! !CriticsCache methodsFor: 'protocol' stamp: 'StephaneDucasse 3/20/2013 22:44'! logInManifest self cacheChange ifFalse: [^ self]. self logFalsePositiveRulesInManifest. self logFalsePositiveClassInManifest. self logFalsePositiveInManifest. self logToDosInManifest. self cacheNotChanged. self initCache ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'CamilleTeruel 9/18/2013 14:59'! removeFalsePositiveClass: aClass | fp | falsePositiveClasses remove: aClass ifAbsent: [^ self]. critics keysAndValuesDo: [ :rule :criticss | fp := criticss select: [ :critic | aClass = critic criticTheNonMetaclassClass]. fp do: [ :each | self removeFalsePositive: each forRule: rule ]].! ! !CriticsCache methodsFor: 'private' stamp: 'MarcusDenker 10/3/2013 22:32'! logFalsePositiveInManifest | removeFp addFp | falsePositives keysAndValuesDo: [ :rule :criticss | removeFp := (checker falsePositiveOf: rule) \ criticss. addFp := criticss \ (checker falsePositiveOf: rule). (removeFp groupedBy: [ :each | self builderManifestClass of: each ]) keysAndValuesDo: [ :manifestBuilder :value | self removeAllCriticToFalsePositive: value forRule: rule on: manifestBuilder ]. (addFp groupedBy: [ :each | self builderManifestClass of: each ]) keysAndValuesDo: [ :manifestBuilder :value | (manifestBuilder rejectRules includes: rule class uniqueIdentifierName) ifFalse: [ self addAllCriticToFalsePositive: value forRule: rule on: manifestBuilder ] ] ]! ! !CriticsCache methodsFor: 'protocol' stamp: 'MarcusDenker 10/2/2013 20:13'! replaceAll: oldMethod by: newMethod critics valuesDo: [:each | (each includes: oldMethod) ifTrue: [ each remove: oldMethod. each add: newMethod ]]. falsePositives valuesDo: [:each | (each includes: oldMethod) ifTrue: [ each remove: oldMethod. each add: newMethod ]]. toDos valuesDo: [:each | (each includes: oldMethod) ifTrue: [ each remove: oldMethod. each add: newMethod ]] ! ! !CriticsCache methodsFor: 'accessing' stamp: 'SimonAllier 1/23/2013 13:48'! browser: aCodeCritiicBrowser browser := aCodeCritiicBrowser ! ! !CriticsCache methodsFor: 'private' stamp: 'SimonAllier 2/5/2013 11:11'! cacheChanged change := true! ! !CriticsCache methodsFor: 'protocol' stamp: 'StephaneDucasse 3/20/2013 22:40'! falsePositiveOf: aRule aRule ifNil: [ ^ {}]. ^ aRule isComposite ifTrue: [ aRule leaves gather: [ :rule | self falsePositiveOf: rule ]] ifFalse: [falsePositives at: aRule ifAbsent: [{}]] ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'StephaneDucasse 3/21/2013 12:59'! addFalsePositiveClass: aClass | fp | falsePositiveClasses add: aClass theNonMetaClass. critics keysAndValuesDo: [ :rule :criticss | fp := criticss select: [ :critic | aClass = critic criticTheNonMetaclassClass ]. fp do: [ :each | self addFalsePositive: each forRule: rule] ]. self updateBrowser ! ! !CriticsCache methodsFor: 'private' stamp: 'StephaneDucasse 3/21/2013 12:59'! addAllCriticToFalsePositive: aCollectionOfCritic forRule: aRule on: aManifestBuilder | ruleId versionId criticss | criticss := aCollectionOfCritic reject: [ :c | falsePositiveClasses includes: c criticTheNonMetaclassClass ]. ruleId := aRule class uniqueIdentifierName. versionId := aRule class identifierMinorVersionNumber. (aManifestBuilder hasFalsePositiveOf: ruleId version: versionId) ifFalse: [ aManifestBuilder installFalsePositiveOf: ruleId version: versionId ]. aManifestBuilder addAllFalsePositive: criticss of: ruleId version: versionId. ! ! !CriticsCache methodsFor: 'private' stamp: 'StephaneDucasse 3/21/2013 13:13'! logFalsePositiveRulesInManifest | manifestBuilder | falsePositiveRules keysAndValuesDo: [ :package :rules | manifestBuilder := self builderManifestClass ofPackageNamed: package packageName. manifestBuilder rejectRules \ rules do: [ :rule | manifestBuilder removeRejectRule: rule ]. rules \ manifestBuilder rejectRules do: [ :rule | manifestBuilder addRejectRule: rule ] ]! ! !CriticsCache methodsFor: 'accessing' stamp: 'SimonAllier 1/31/2013 13:50'! packages: aPackageEnv packages := aPackageEnv packages! ! !CriticsCache methodsFor: 'private' stamp: 'StephaneDucasse 3/20/2013 22:46'! removeAllCriticToFalsePositive: aCollectionOfCritic forRule: aRule on: aManifestBuilder | ruleId versionId | ruleId := aRule class uniqueIdentifierName. versionId := aRule class identifierMinorVersionNumber. (aManifestBuilder hasFalsePositiveOf: ruleId version: versionId) ifTrue: [ aManifestBuilder removeAllFalsePositive: aCollectionOfCritic of: ruleId version: versionId ]. ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'StephaneDucasse 3/20/2013 22:46'! removeCritic: aCritic forRule: aRule (critics includesKey: aRule) ifFalse: [^ self]. (critics at: aRule) remove: aCritic ifAbsent: [^ self]. self updateBrowser ! ! !CriticsCache methodsFor: 'private' stamp: 'StephaneDucasse 1/6/2014 20:51'! builderManifestClass ^ TheManifestBuilder! ! !CriticsCache methodsFor: 'add/remove' stamp: 'StephaneDucasse 3/21/2013 13:03'! removeFalsePositiveRule: aRule forPackage: aPackage | fp | (falsePositiveRules includesKey: aPackage) ifFalse: [^ self]. (falsePositiveRules at:aPackage) remove: (aRule class uniqueIdentifierName) ifAbsent: [^ self]. fp := (critics at: aRule ifAbsent: [^ self]) select: [:c | ((self packageOf: c) package name) = (aPackage packageName) and: [ (falsePositiveClasses includes: c criticTheNonMetaclassClass) not]]. fp do: [:c | self removeFalsePositive: c forRule: aRule]. self updateBrowser ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'MarcusDenker 10/2/2013 20:12'! itemRemoved: aItem critics valuesDo: [ :each | each remove: aItem ifAbsent: []]. toDos valuesDo: [ :each | each remove: aItem ifAbsent: []]. falsePositives valuesDo: [ :each | each remove: aItem ifAbsent: []]. self updateBrowser ! ! !CriticsCache methodsFor: 'private' stamp: 'MarcusDenker 10/3/2013 22:31'! logToDosInManifest | removeFp addFp | toDos keysAndValuesDo: [ :rule :criticss | removeFp := (checker toDoOf: rule) \ criticss. addFp := criticss \ (checker toDoOf: rule). (removeFp groupedBy: [ :each | self builderManifestClass of: each ]) keysAndValuesDo: [ :manifestBuilder :value | self removeAllCriticToToDo: value forRule: rule on: manifestBuilder ]. (addFp groupedBy: [ :each | self builderManifestClass of: each ]) keysAndValuesDo: [ :manifestBuilder :value | (manifestBuilder rejectRules includes: rule class uniqueIdentifierName) ifFalse: [ self addAllCriticToToDo: value forRule: rule on: manifestBuilder ] ] ]! ! !CriticsCache methodsFor: 'private' stamp: 'SimonAllier 2/5/2013 11:19'! updateBrowser self cacheChanged. browser updateTree ! ! !CriticsCache methodsFor: 'accessing' stamp: 'SimonAllier 1/23/2013 10:28'! checker: aSmallLintChercker checker := aSmallLintChercker! ! !CriticsCache methodsFor: 'private' stamp: 'SimonAllier 3/21/2013 15:18'! packageOf: aCritc ^ aCritc mcWorkingCopy "aCritc isCompiledMethod ifTrue: [MCWorkingCopy managersForClass: aCritc methodClass selector: aCritc selector do: [ :package | ^ package ]] ifFalse: [MCWorkingCopy managersForClass: aCritc do: [: package | ^ package ]] "! ! !CriticsCache methodsFor: 'accessing' stamp: 'SimonAllier 2/5/2013 11:11'! cacheChange ^ change! ! !Cubic commentStamp: 'wiz 6/17/2004 20:31'! I am a segment between to points. In the form of a cubic polynomial that can be evaluated between 0..1 to obtain the end points and intermediate values. ! !Cubic methodsFor: 'cubic support' stamp: 'StephaneDucasse 6/5/2011 16:13'! bestSegments "Return the smallest integer number of segments that give the best curve." ^ self honeIn: self calcEnoughSegments! ! !Cubic methodsFor: 'cubic support' stamp: 'StephaneDucasse 6/5/2011 16:14'! leeway "How close can measure be" ^ 0.1! ! !Cubic methodsFor: 'cubic support' stamp: 'StephaneDucasse 6/5/2011 16:14'! honeIn: centerN step: step measure: measure withIn: closeEnough "Pick the best n by binary search." | nTry | step < 1 ifTrue: [^ centerN]. nTry := centerN - step. ^ measure > (closeEnough + (self measureFor: nTry)) ifTrue: [self honeIn: centerN step: step // 2 measure: measure withIn: closeEnough] ifFalse: [self honeIn: nTry step: step // 2 measure: measure withIn: closeEnough]! ! !Cubic methodsFor: 'cubic support' stamp: 'StephaneDucasse 6/5/2011 16:15'! measureFor: n "Return a distance measure for cubic curve with n segments. For convienence and accuracy we use the sum of the distances. " "The first point is poly of 0." | p1 measure | p1 := self first. measure := 0. 1 to: n do: [:i | | p2 | p2 := self polynomialEval: i / n asFloat. measure := measure + (p2 dist: p1). p1 := p2]. ^ measure! ! !Cubic methodsFor: 'cubic support' stamp: 'StephaneDucasse 6/5/2011 16:14'! calcEnoughSegments "Find the power of two that represents a sufficient number of segments for this cubic. The measure is the sum of distances for the segments. We want this to be close enough not affect the straightness of the drawn lines. Which means within one pixel." ^ self enough: 4 withMeasure: (self measureFor: 2) withIn: self leeway! ! !Cubic methodsFor: 'cubic support' stamp: 'StephaneDucasse 6/5/2011 16:14'! enough: nTry withMeasure: lastMeasure withIn: closeEnough "See comment in calcEnoughSegments for which I am a helper" | measure | measure := self measureFor: nTry. measure > (lastMeasure + closeEnough) ifFalse: [^ nTry // 2]. ^ self enough: 2 * nTry withMeasure: measure withIn: closeEnough! ! !Cubic methodsFor: 'cubic support' stamp: 'StephaneDucasse 6/5/2011 16:14'! honeIn: enough "Find if there is a smaller n than enough that give the same measure for n." [enough isPowerOfTwo] assert. enough < 2 ifTrue: [^ enough]. ^ self honeIn: enough step: enough // 2 measure: (self measureFor: enough) withIn: self leeway! ! !Cubic class methodsFor: 'instance creation' stamp: 'stephane.ducasse 12/21/2008 11:00'! with: pt1 with: pt2 with: pt3 with: pt4 "a cubic object is composed of 4 points" ^ self withAll: {pt1 . pt2 . pt3 . pt4}! ! !CurrentChangeSetChanged commentStamp: 'TorstenBergmann 1/31/2014 10:28'! Announce that the current change set has changed! !CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'StephaneDucasse 11/2/2012 14:22'! new: anObject new := anObject! ! !CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'StephaneDucasse 11/2/2012 16:37'! old: anObject old := anObject ! ! !CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'StephaneDucasse 11/2/2012 14:23'! old ^ old! ! !CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'StephaneDucasse 11/2/2012 14:22'! new ^ new! ! !Cursor commentStamp: ''! I am a Form that is a possible appearance for a mouse cursor. My size is always 16x16, ever since the original implementation on the Alto. There are many examples available in the "current cursor" category of class methods. For example, "Cursor normal" and "Cursor wait". For example: Cursor wait show ! !Cursor methodsFor: 'converting' stamp: 'bf 2/2/1999 19:32'! withMask ^CursorWithMask derivedFrom: self! ! !Cursor methodsFor: 'testing' stamp: 'bf 2/2/1999 19:34'! hasMask ^false! ! !Cursor methodsFor: 'testing' stamp: 'FernandoOlivero 3/6/2011 22:05'! isCurrent ^ self class currentCursor == self ! ! !Cursor methodsFor: 'primitives' stamp: ''! beCursor "Primitive. Tell the interpreter to use the receiver as the current cursor image. Fail if the receiver does not match the size expected by the hardware. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !Cursor methodsFor: 'printing' stamp: ''! printOn: aStream self storeOn: aStream base: 2! ! !Cursor methodsFor: 'displaying' stamp: 'StephaneDucasse 3/3/2011 17:44'! show "Make the hardware's mouse cursor look like the receiver" self class currentCursor: self! ! !Cursor methodsFor: 'primitives' stamp: 'jm 9/22/1998 23:33'! beCursorWithMask: maskForm "Primitive. Tell the interpreter to use the receiver as the current cursor image with the given mask Form. Both the receiver and the mask should have extent 16@16 and a depth of one. The mask and cursor bits are combined as follow: mask cursor effect 0 0 transparent (underlying pixel shows through) 1 1 opaque black 1 0 opaque white 0 1 invert the underlying pixel" "Essential. See Object documentation whatIsAPrimitive." self primitiveFailed ! ! !Cursor methodsFor: 'updating' stamp: 'ls 6/17/2002 12:00'! changed: aParameter "overriden to reinstall the cursor if it is the active cursor, in case the appearance has changed. (Is this used anywhere? Do cursors really change in place these days?)" self == CurrentCursor ifTrue: [self beCursor]. super changed: aParameter! ! !Cursor methodsFor: 'displaying' stamp: 'MarcusDenker 12/2/2011 16:22'! showWhile: aBlock "While evaluating the argument, aBlock, make the receiver be the cursor shape." | oldcursor | oldcursor := self class currentCursor. self show. ^aBlock ensure: [oldcursor show] ! ! !Cursor methodsFor: 'converting' stamp: 'MarcusDenker 4/10/2011 09:45'! asCursorForm | form | form := Form extent: self extent depth: 8. form fillShape: self fillColor: Color black at: offset negated. ^ form offset: offset! ! !Cursor class methodsFor: 'constants' stamp: 'ar 9/26/2001 22:37'! webLink "Return a cursor that can be used for emphasizing web links" "Cursor webLink showWhile: [Sensor waitButton]" ^WebLinkCursor ifNil:[ WebLinkCursor := (CursorWithMask extent: 16@16 fromArray: #(3072 4608 4608 4608 4608 5046 4681 29257 37449 37449 32769 32769 49155 16386 24582 16380 ) offset: -5@0) setMaskForm: (Form extent: 16@16 fromArray: (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 ) collect: [:bits | bits bitShift: 16]) offset: 0@0)].! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 18:58'! resizeLeft "Cursor resizeLeft showWhile: [Sensor waitButton]" ^ResizeLeftCursor! ! !Cursor class methodsFor: 'initialization' stamp: 'nice 3/5/2010 22:21'! initBottomRight BottomRightCursor := (Cursor extent: 16 @ 16 fromArray: #( 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r1111111111111111 2r1111111111111111) offset: -16 @ -16). ! ! !Cursor class methodsFor: 'initialization' stamp: 'nice 3/5/2010 22:21'! initResizeLeft ResizeLeftCursor := (Cursor extent: 16 @ 16 fromArray: #( 2r0000000000000000 2r0000000000000000 2r0000000000000000 2r0000000000000000 2r0000100000010000 2r0001100000011000 2r0011100000011100 2r0111111111111110 2r0011100000011100 2r0001100000011000 2r0000100000010000 2r0000000000000000 2r0000000000000000 2r0000000000000000 2r0000000000000000 2r0000000000000000 ) offset: -7 @ -7 ) withMask! ! !Cursor class methodsFor: 'initialization' stamp: ''! initDown DownCursor := (Cursor extent: 16@16 fromArray: #( 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r1111110000000000 2r111100000000000 2r11000000000000 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0). ! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:48'! resizeBottom "Cursor resizeBottom showWhile: [Sensor waitButton]" ^self resizeTop! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'! resizeBottomRight "Cursor resizeBottomRight showWhile: [Sensor waitButton]" ^self resizeTopLeft! ! !Cursor class methodsFor: 'initialization' stamp: 'JMM 10/21/2003 19:02'! initTopRight TopRightCursor := (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011) offset: -16@0). ! ! !Cursor class methodsFor: 'constants' stamp: ''! normal "Answer the instance of me that is the shape of an arrow slanted left." ^NormalCursor! ! !Cursor class methodsFor: 'initialization' stamp: ''! initRightArrow RightArrowCursor := (Cursor extent: 16@16 fromArray: #( 2r100000000000 2r111000000000 2r1111111110000000 2r111000000000 2r100000000000 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0). "Cursor initRightArrow"! ! !Cursor class methodsFor: 'initialization' stamp: 'kfr 7/12/2003 22:52'! initWrite WriteCursor := (Cursor extent: 16@16 fromArray: #( 2r0000000000011000 2r0000000000111100 2r0000000001001000 2r0000000010010000 2r0000000100100000 2r0000001001000100 2r0000010010000100 2r0000100100001100 2r0001001000010000 2r0010010000010000 2r0111100000001000 2r0101000011111000 2r1110000110000000 2r0111111100000000 2r0 2r0) offset: 0@0). ! ! !Cursor class methodsFor: 'initialization' stamp: 'nice 3/5/2010 22:22'! initNormalWithMask "Cursor initNormalWithMask. Cursor normal show" "Next two lines work simply for any cursor..." self initNormal. NormalCursor := CursorWithMask derivedFrom: NormalCursor. "But for a good looking cursor, you have to tweak things..." NormalCursor := (CursorWithMask extent: 16 @ 16 depth: 1 fromArray: #( 0 1073741824 1610612736 1879048192 2013265920 2080374784 2113929216 2130706432 2080374784 2080374784 1275068416 100663296 100663296 50331648 50331648 0) offset: -1 @ -1) setMaskForm: (Form extent: 16@16 depth: 1 fromArray: #( 3221225472 3758096384 4026531840 4160749568 4227858432 4261412864 4278190080 4286578688 4278190080 4261412864 4261412864 3472883712 251658240 125829120 125829120 50331648) offset: 0 @ 0).! ! !Cursor class methodsFor: 'initialization' stamp: 'AlainPlantec 2/1/2011 14:31'! initialize "Create all the standard cursors..." self initOrigin. self initRightArrow. self initMenu. self initCorner. self initRead. self initWrite. self initWait. BlankCursor := Cursor new. self initXeq. self initSquare. self initNormalWithMask. self initCrossHair. self initMarker. self initUp. self initDown. self initMove. self initBottomLeft. self initBottomRight. self initResizeLeft. self initResizeTop. self initResizeTopLeft. self initResizeTopRight. self initTopLeft. self initTopRight. self initTarget. self initOverEditableText. self makeCursorsWithMask. "Cursor initialize" ! ! !Cursor class methodsFor: 'initialization' stamp: ''! startUp self currentCursor: self currentCursor! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:46'! resizeBottomLeft "Cursor resizeBottomLeft showWhile: [Sensor waitButton]" ^self resizeTopRight! ! !Cursor class methodsFor: 'constants' stamp: ''! write "Answer the instance of me that is the shape of a pen writing." ^WriteCursor! ! !Cursor class methodsFor: 'initialization' stamp: 'AlainPlantec 12/27/2010 13:07'! initOverEditableText OverEditableText := (Cursor extent: 16@16 fromArray: #( 2r0 2r000111011100000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000111011100000 2r0) offset: (-7@ -8)) ! ! !Cursor class methodsFor: 'initialization' stamp: ''! initMarker MarkerCursor := Cursor extent: 16@16 fromArray: #( 2r0111000000000000 2r1111100000000000 2r1111100000000000 2r0111000000000000 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0. ! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:19'! resizeTop "Cursor resizeTop showWhile: [Sensor waitButton]" ^ResizeTopCursor! ! !Cursor class methodsFor: 'initialization' stamp: 'JMM 10/21/2003 19:01'! initTopLeft TopLeftCursor := (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000) offset: 0@0). ! ! !Cursor class methodsFor: 'initialization' stamp: 'nice 3/5/2010 22:22'! initResizeTopLeft ResizeTopLeftCursor := (Cursor extent: 16 @ 16 fromArray: #( 2r0000000000000000 2r0111110000000000 2r0111100000000000 2r0111000000000000 2r0110100000000000 2r0100010000000000 2r0000001000000000 2r0000000100000000 2r0000000010000000 2r0000000001000100 2r0000000000101100 2r0000000000011100 2r0000000000111100 2r0000000001111100 2r0000000000000000 2r0000000000000000) offset: -7 @ -7) withMask! ! !Cursor class methodsFor: 'constants' stamp: ''! crossHair "Answer the instance of me that is the shape of a cross." ^CrossHairCursor! ! !Cursor class methodsFor: 'current cursor' stamp: 'md 5/26/2011 14:33'! currentCursor: aCursor "Make the instance of cursor, aCursor, be the current cursor. Display it." CurrentCursor := aCursor. aCursor beCursor! ! !Cursor class methodsFor: 'constants' stamp: ''! square "Answer the instance of me that is the shape of a square." ^SquareCursor! ! !Cursor class methodsFor: 'constants' stamp: ''! down "Answer the instance of me that is the shape of an arrow facing downward." ^DownCursor! ! !Cursor class methodsFor: 'initialization' stamp: ''! initOrigin OriginCursor := (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000) offset: 0@0). ! ! !Cursor class methodsFor: 'initialization' stamp: 'nice 3/5/2010 22:22'! initCorner CornerCursor := (Cursor extent: 16 @ 16 fromArray: #( 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r1111111111111111 2r1111111111111111) offset: -16 @ -16). ! ! !Cursor class methodsFor: 'initialization' stamp: ''! initUp UpCursor := (Cursor extent: 16@16 fromArray: #( 2r11000000000000 2r111100000000000 2r1111110000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r11000000000000 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0). ! ! !Cursor class methodsFor: 'initialization' stamp: 'nice 3/5/2010 22:22'! initCrossHair CrossHairCursor := (Cursor extent: 16 @ 16 fromArray: #( 2r0000000000000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0111111111111100 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000000000000 2r0) offset: -7 @ -7). ! ! !Cursor class methodsFor: 'initialization' stamp: ''! initXeq XeqCursor := (Cursor extent: 16@16 fromArray: #( 2r1000000000010000 2r1100000000010000 2r1110000000111000 2r1111000111111111 2r1111100011000110 2r1111110001000100 2r1111111001111100 2r1111000001101100 2r1101100011000110 2r1001100010000010 2r0000110000000000 2r0000110000000000 2r0000011000000000 2r0000011000000000 2r0000001100000000 2r0000001100000000) offset: 0@0). ! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00'! resizeTopRight "Cursor resizeTopRight showWhile: [Sensor waitButton]" ^ResizeTopRightCursor! ! !Cursor class methodsFor: 'constants' stamp: 'AlainPlantec 12/22/2010 18:15'! overEditableText ^ OverEditableText ! ! !Cursor class methodsFor: 'constants' stamp: ''! origin "Answer the instance of me that is the shape of the top left corner of a rectangle." ^OriginCursor! ! !Cursor class methodsFor: 'constants' stamp: ''! blank "Answer the instance of me that is all white." ^BlankCursor! ! !Cursor class methodsFor: 'initialization' stamp: 'bf 2/2/1999 19:33'! makeCursorsWithMask "Cursor initialize;makeCursorsWithMask" self classPool associationsDo: [:var | var value hasMask ifFalse: [var value: var value withMask]] ! ! !Cursor class methodsFor: 'initialization' stamp: 'di 7/30/2001 10:32'! initMenu MenuCursor := (Cursor extent: 16@16 fromArray: #( 2r1111111111100000 2r1000000000100000 2r1010011000100000 2r1000000000100000 2r1101001101100000 2r1111111111100000 2r1000000000100000 2r1011001010100000 2r1000000000100000 2r1010110010100000 2r1000000000100000 2r1010010100100000 2r1000000000100000 2r1111111111100000 0) offset: 0@0). ! ! !Cursor class methodsFor: 'constants' stamp: ''! move "Answer the instance of me that is the shape of a cross inside a square." ^MoveCursor! ! !Cursor class methodsFor: 'constants' stamp: ''! read "Answer the instance of me that is the shape of eyeglasses." ^ReadCursor! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00'! resizeTopLeft "Cursor resizeTopLeft showWhile: [Sensor waitButton]" ^ ResizeTopLeftCursor! ! !Cursor class methodsFor: 'instance creation' stamp: 'ar 8/16/2001 15:52'! resizeForEdge: aSymbol "Cursor resizeForEdge: #top" "Cursor resizeForEdge: #bottomLeft" ^self perform: ('resize', aSymbol first asString asUppercase, (aSymbol copyFrom: 2 to: aSymbol size)) asSymbol.! ! !Cursor class methodsFor: 'initialization' stamp: ''! initNormal NormalCursor := (Cursor extent: 16@16 fromArray: #( 2r1000000000000000 2r1100000000000000 2r1110000000000000 2r1111000000000000 2r1111100000000000 2r1111110000000000 2r1111111000000000 2r1111100000000000 2r1111100000000000 2r1001100000000000 2r0000110000000000 2r0000110000000000 2r0000011000000000 2r0000011000000000 2r0000001100000000 2r0000001100000000) offset: 0@0). ! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13'! bottomRight "Cursor bottomRight showWhile: [Sensor waitButton]" ^BottomRightCursor ! ! !Cursor class methodsFor: 'initialization' stamp: 'kfr 7/12/2003 21:10'! initMove MoveCursor := Cursor extent: 16@16 fromArray: #( 2r1111111111111100 2r1111111111111100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1111111111111100 2r1111111111111100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1111111111111100 2r1111111111111100 0) offset: 0@0. ! ! !Cursor class methodsFor: 'constants' stamp: ''! menu "Answer the instance of me that is the shape of a menu." ^MenuCursor! ! !Cursor class methodsFor: 'constants' stamp: ''! rightArrow "Answer the instance of me that is the shape of an arrow pointing to the right." ^RightArrowCursor! ! !Cursor class methodsFor: 'constants' stamp: ''! corner "Answer the instance of me that is the shape of the bottom right corner of a rectangle." ^CornerCursor! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'! resizeRight "Cursor resizeRight showWhile: [Sensor waitButton]" ^self resizeLeft! ! !Cursor class methodsFor: 'constants' stamp: ''! up "Answer the instance of me that is the shape of an arrow facing upward." ^UpCursor! ! !Cursor class methodsFor: 'initialization' stamp: 'nice 3/5/2010 22:22'! initSquare SquareCursor := (Cursor extent: 16 @ 16 fromArray: #( 2r0 2r0 2r0 2r0 2r0 2r0000001111000000 2r0000001111000000 2r0000001111000000 2r0000001111000000 2r0 2r0 2r0 2r0 2r0 2r0 2r0) offset: -8 @ -8). ! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:01'! topLeft "Cursor topLeft showWhile: [Sensor waitButton]" ^ TopLeftCursor! ! !Cursor class methodsFor: 'initialization' stamp: 'ar 3/1/2006 22:42'! initTarget ^TargetCursor := Cursor extent: 16 @ 16 fromArray: #(1984 6448 8456 16644 17284 33026 35106 65278 35106 33026 17284 16644 8456 6448 1984 0) offset: -7 @ -7! ! !Cursor class methodsFor: 'initialization' stamp: 'kfr 7/12/2003 22:55'! initRead ReadCursor := (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000000000000000 2r0001000000001000 2r0010100000010100 2r0100000000100000 2r1111101111100000 2r1000010000100000 2r1000010000100000 2r1011010110100000 2r0111101111000000 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0). ! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13'! bottomLeft "Cursor bottomLeft showWhile: [Sensor waitButton]" ^BottomLeftCursor ! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:02'! topRight "Cursor topRight showWhile: [Sensor waitButton]" ^ TopRightCursor! ! !Cursor class methodsFor: 'constants' stamp: ''! marker "Answer the instance of me that is the shape of a small ball." ^MarkerCursor! ! !Cursor class methodsFor: 'initialization' stamp: 'nice 3/5/2010 22:23'! initResizeTop "Cursor initResizeTop" ResizeTopCursor := (Cursor extent: 16 @ 16 fromArray: #( 2r000000100000000 2r000001110000000 2r000011111000000 2r000111111100000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000000100000000 2r000111111100000 2r000011111000000 2r000001110000000 2r000000100000000 2r000000000000000) offset: -7 @ -7) withMask! ! !Cursor class methodsFor: 'instance creation' stamp: 'di 10/6/1998 13:53'! new ^ self extent: 16 @ 16 fromArray: (Array new: 16 withAll: 0) offset: 0 @ 0 "Cursor new bitEdit show"! ! !Cursor class methodsFor: 'initialization' stamp: 'kfr 7/12/2003 21:27'! initWait WaitCursor := (Cursor extent: 16@16 fromArray: #( 2r1111111111111100 2r1000000000000100 2r0100000000001000 2r0010000000010000 2r0001110011100000 2r0000111111000000 2r0000011110000000 2r0000011110000000 2r0000100101000000 2r0001000100100000 2r0010000110010000 2r0100001111001000 2r1000111111110100 2r1111111111111100 0) offset: 0@0). ! ! !Cursor class methodsFor: 'constants' stamp: ''! execute "Answer the instance of me that is the shape of an arrow slanted left with a star next to it." ^XeqCursor! ! !Cursor class methodsFor: 'initialization' stamp: 'nice 3/5/2010 22:30'! initResizeTopRight ResizeTopRightCursor := (Cursor extent: 16 @ 16 fromArray: #( 2r0000000000000000 2r0000000001111100 2r0000000000111100 2r0000000000011100 2r0000000000101100 2r0000000001000100 2r0000000010000000 2r0000000100000000 2r0000001000000000 2r0100010000000000 2r0110100000000000 2r0111000000000000 2r0111100000000000 2r0111110000000000 2r0000000000000000 2r0000000000000000) offset: -7 @ -7) withMask! ! !Cursor class methodsFor: 'constants' stamp: 'sw 8/15/97 13:28'! wait "Answer the instance of me that is the shape of an Hourglass (was in the shape of three small balls)." ^WaitCursor! ! !Cursor class methodsFor: 'instance creation' stamp: ''! extent: extentPoint fromArray: anArray offset: offsetPoint "Answer a new instance of me with width and height specified by extentPoint, offset by offsetPoint, and bits from anArray. NOTE: This has been kluged to take an array of 16-bit constants, and shift them over so they are left-justified in a 32-bit bitmap" extentPoint = (16 @ 16) ifTrue: [^ super extent: extentPoint fromArray: (anArray collect: [:bits | bits bitShift: 16]) offset: offsetPoint] ifFalse: [self error: 'cursors must be 16@16']! ! !Cursor class methodsFor: 'class initialization' stamp: 'nice 3/5/2010 22:31'! initBottomLeft BottomLeftCursor := (Cursor extent: 16 @ 16 fromArray: #( 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1111111111111111 2r1111111111111111) offset: 0 @ -16). ! ! !Cursor class methodsFor: 'constants' stamp: 'ar 3/1/2006 22:42'! target "Answer the instance of me that is the shape of a gunsight." "Cursor target show" ^TargetCursor ifNil:[self initTarget]! ! !Cursor class methodsFor: 'current cursor' stamp: ''! currentCursor "Answer the instance of Cursor that is the one currently displayed." ^CurrentCursor! ! !CursorWithAlpha commentStamp: ''! A 32-bit ARGB Cursor of arbitrary extent (some platforms may limit the size). Compositing assumes alpha is pre-multiplied.! !CursorWithAlpha methodsFor: 'accessing' stamp: 'bf 3/30/2007 18:58'! fallback: aCursor fallback := aCursor! ! !CursorWithAlpha methodsFor: 'primitives' stamp: 'yo 5/11/2007 16:20'! primBeCursor self fallback primBeCursor! ! !CursorWithAlpha methodsFor: 'converting' stamp: 'MarcusDenker 4/10/2011 10:14'! asCursorForm ^ Form newFrom: self! ! !CursorWithAlpha methodsFor: 'accessing' stamp: 'bf 3/30/2007 18:57'! fallback ^fallback ifNil: [NormalCursor]! ! !CursorWithMask commentStamp: ''! A Cursor which additionally has a 16x16 transparency bitmap called a "mask". See the comment of beCursorWithMask: for details on how the mask is treated.! !CursorWithMask methodsFor: 'mask' stamp: 'bf 2/2/1999 19:31'! withMask ^self! ! !CursorWithMask methodsFor: 'mask' stamp: 'bf 2/2/1999 19:34'! hasMask ^true! ! !CursorWithMask methodsFor: 'primitives' stamp: 'di 10/6/1998 15:16'! beCursor maskForm unhibernate. ^ self beCursorWithMask: maskForm! ! !CursorWithMask methodsFor: 'mask' stamp: 'di 10/8/1998 16:46'! maskForm ^ maskForm! ! !CursorWithMask methodsFor: 'converting' stamp: 'MarcusDenker 4/10/2011 09:46'! asCursorForm | form | form := Form extent: self extent depth: 8. form fillShape: maskForm fillColor: Color white. form fillShape: self fillColor: Color black at: offset negated. ^ form offset: offset! ! !CursorWithMask methodsFor: 'mask' stamp: 'di 10/8/1998 16:46'! setMaskForm: aForm maskForm := aForm! ! !CursorWithMask methodsFor: 'mask' stamp: 'bf 2/2/1999 19:30'! storeOn: aStream base: anInteger aStream nextPut: $(. super storeOn: aStream base: anInteger. aStream nextPutAll: ' setMaskForm: '. maskForm storeOn: aStream base: anInteger. aStream nextPut: $)! ! !CursorWithMask class methodsFor: 'as yet unclassified' stamp: 'di 2/18/1999 08:56'! derivedFrom: aForm "Cursor initNormalWithMask. Cursor normal show" "aForm is presumably a cursor" | cursor mask ext | ext := aForm extent. cursor := self extent: ext. cursor copy: (1@1 extent: ext) from: 0@0 in: aForm rule: Form over. mask := Form extent: ext. (1@1) eightNeighbors do: [:p | mask copy: (p extent: ext) from: 0@0 in: aForm rule: Form under]. cursor setMaskForm: mask. cursor offset: ((aForm offset - (1@1)) max: ext negated). ^ cursor! ! !CurveMorph commentStamp: ''! This is really only a shell for creating Shapes with smooth outlines.! !CurveMorph methodsFor: 'initialization' stamp: 'di 9/10/2000 14:28'! initialize super initialize. self beSmoothCurve. ! ! !CurveMorph methodsFor: 'testing' stamp: 'FernandoOlivero 9/10/2013 11:03'! isCurvier "Test used by smoothing routines. If true use true closed curve splines for closed curves. If not mimic old stodgy curveMorph curves with one sharp bend. Curve overrides this test for backward compatability.." ^ false! ! !CurveMorph class methodsFor: 'instance creation' stamp: 'tk 11/14/2001 17:47'! arrowPrototype | aa | aa := PolygonMorph vertices: (Array with: 5@40 with: 5@8 with: 35@8 with: 35@40) color: Color black borderWidth: 2 borderColor: Color black. aa beSmoothCurve; makeOpen; makeForwardArrow. "is already open" aa dashedBorder: {10. 10. Color red}. "A dash spec is a 3- or 5-element array with { length of normal border color. length of alternate border color. alternate border color}" aa computeBounds. ^ aa! ! !CurveWorkshop commentStamp: 'TorstenBergmann 2/12/2014 22:19'! An example from a workshop! !CurveWorkshop methodsFor: 'colors' stamp: 'IgorStasenko 4/18/2013 12:35'! triangleColor ^ Color green! ! !CurveWorkshop methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/18/2013 17:48'! drawQuadFrom: pt1 via: pt2 to: pt3 on: canvas | curve triangle middleRay curveBlock | curveBlock := [ :builder | builder absolute; moveTo: pt1; curveVia: pt2 to: pt3 ]. curve := canvas createPath: curveBlock. canvas setStrokePaint: self curveColor. canvas drawShape: curve. triangle := canvas createPath: [ :builder | builder absolute; moveTo: pt1; lineTo: pt2; lineTo: pt3; lineTo: pt1. ]. canvas setStrokePaint: self triangleColor. canvas drawShape: triangle. middleRay := canvas createPath: [ :builder | builder absolute; moveTo: pt2; lineTo: (pt1 + pt3)/2 ]. canvas setStrokePaint: self middleRayColor. canvas drawShape: middleRay. triangle := AthensSimplePathBuilder createPath: curveBlock. triangle := canvas surface createPath: [ :builder | AthensCurveFlattener new dest: builder; flattenPath: triangle transform: (canvas pathTransform). ]. canvas setStrokePaint: Color yellow; drawShape: triangle. ! ! !CurveWorkshop methodsFor: 'colors' stamp: 'IgorStasenko 4/18/2013 12:35'! curveColor ^ Color red! ! !CurveWorkshop methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/18/2013 12:36'! drawOn: canvas self drawQuadFrom: 10@200 via: 50@50 to: 200@200 on: canvas! ! !CurveWorkshop methodsFor: 'colors' stamp: 'IgorStasenko 4/18/2013 12:35'! middleRayColor ^ Color blue! ! !CurveWorkshop methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/18/2013 06:08'! draw ! ! !CustomHelp commentStamp: 'tbn 3/29/2010 13:23'! This is a common superclass for custom help. Subclasses of this class are automatically included into the system help. By default the informations provided on the receiver class are converted into help topics by a specific builder - here the CustomHelpHelpBuilder. Note that you can provide an own custom builder by overriding the #builder method ! !CustomHelp class methodsFor: 'editing' stamp: 'StephaneDucasse 9/12/2010 09:45'! accept: aSelector title: title contents: text "Accept edited text. Compile it into a HelpTopic" | code | code := String streamContents:[:s| s nextPutAll: aSelector. s crtab; nextPutAll: '"This method was automatically generated. Edit it using:"'. s crtab; nextPutAll: '"', self name,' edit: ', aSelector storeString,'"'. s crtab; nextPutAll: '^HelpTopic'. s crtab: 2; nextPutAll: 'title: ', title storeString. s crtab: 2; nextPutAll: 'contents: '. s cr; nextPutAll: (String streamContents:[:c| c nextChunkPut: text]) storeString. s nextPutAll:' readStream nextChunkText'. ]. self class compile: code classified: ((self class organization categoryOfElement: aSelector) ifNil:['pages']). ! ! !CustomHelp class methodsFor: 'accessing' stamp: 'tbn 3/29/2010 13:20'! bookName "Returns the name of the custom help book" ^'Help'! ! !CustomHelp class methodsFor: 'defaults' stamp: 'tbn 3/29/2010 13:24'! builder "Returns the builder that is used to build the given help book from the receiver. You can override this method in a subclass to provide an own builder". ^CustomHelpHelpBuilder! ! !CustomHelp class methodsFor: 'editing' stamp: 'Tbn 11/12/2010 11:33'! edit: aSelector "Open a Workspace on the text in the given selector. When accepted, compile the result as a help topic." | topic workspace | topic := (self respondsTo: aSelector) ifTrue:[self perform: aSelector] ifFalse:[HelpTopic title: 'Untitled' contents: 'Please edit this topic. To change the topic title, edit the window label.']. workspace := UIManager default edit: topic contents label: topic title accept: [:text| self accept: aSelector title: workspace containingWindow label contents: text]. ! ! !CustomHelp class methodsFor: 'accessing' stamp: 'tbn 3/29/2010 13:20'! pages "Returns a collection of method selectors to return the pages of the custom help book" ^#()! ! !CustomHelp class methodsFor: 'converting' stamp: 'tbn 1/7/2011 13:03'! asHelpTopic "Convert the receiver to a help topic" ^self builder buildHelpTopicFrom: self! ! !CustomHelp class methodsFor: 'accessing' stamp: 'tbn 3/29/2010 13:18'! key "Returns a unique key identifying the receiver in the help system" ^''! ! !CustomHelp class methodsFor: 'accessing' stamp: 'tbn 3/29/2010 13:20'! icon "Returns an icon used for displaying the custom help book" ^HelpIcons iconNamed: #bookIcon! ! !CustomHelpHelpBuilder commentStamp: 'tbn 3/29/2010 13:30'! This builder builds help topics from a help topic description (which is typically stored in a class). The help topic description object has to understand the following messages: #bookName - should return the name of the help book #icon - should return the icon of the help book #key - should return a unique key to identify the book #pages - should return an array of method selectors to call to get the books pages ! !CustomHelpHelpBuilder methodsFor: 'building' stamp: 'tbn 3/6/2010 00:28'! build "Start building a help topic from a code description" topicToBuild := self createTopicFrom: rootToBuildFrom ! ! !CustomHelpHelpBuilder methodsFor: 'private' stamp: 'tbn 9/30/2010 23:31'! createTopicFrom: aDescription "Create a topic from a description stored on a class. aDescription can specify (via #pages) the name of a class and not only a selector. This allows for hierarchies with 'subtrees in the middle'" |topic page pageClasses | topic := HelpTopic named: aDescription bookName. topic key: aDescription key. topic icon: aDescription icon. pageClasses := Set new. aDescription pages do: [:pageSelectorOrClass| page:= (Smalltalk hasClassNamed: pageSelectorOrClass asString) ifFalse: [aDescription perform: pageSelectorOrClass] ifTrue: [pageClasses add: (Smalltalk classNamed: pageSelectorOrClass asString). (Smalltalk classNamed: pageSelectorOrClass asString) asHelpTopic]. topic addSubtopic: page. ]. ((aDescription subclasses asSet) removeAllFoundIn: pageClasses; yourself) do: [:subclass | topic subtopics add: subclass asHelpTopic ]. ^topic! ! !CustomHelpTest commentStamp: 'TorstenBergmann 2/4/2014 21:18'! SUnit tests for class CustomHelp ! !CustomHelpTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:26'! testOpenBrowserOnThisHelpType |browser| browser := HelpBrowser openOn: CustomHelp. World doOneCycleNow. browser close! ! !CustomQuestionDialogWindow commentStamp: 'gvc 9/23/2008 11:59'! QuestionDialog supporting custom text/buttons for yes/no choices.! !CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2008 11:30'! yesButton "Answer the value of yesButton" ^ yesButton! ! !CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 8/23/2010 11:50'! noText: aStringOrText help: helpString "Set the no button label. if the text is nil, remove the button." aStringOrText ifNil: [self noButton delete] ifNotNil: [self noButton hResizing: #shrinkWrap; label: aStringOrText; setBalloonText: helpString]! ! !CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2008 11:30'! yesButton: anObject "Set the value of yesButton" yesButton := anObject! ! !CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 8/23/2010 12:16'! defaultCancelButton "Answer a default cancel button." ^self newCancelButton! ! !CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2008 11:30'! noButton: anObject "Set the value of noButton" noButton := anObject! ! !CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 8/23/2010 12:16'! default: defaultOption "Set the default button." defaultOption ifNil: [self cancelButton isDefault: true] ifNotNil: [defaultOption ifTrue: [self yesButton isDefault: true] ifFalse: [self noButton isDefault: true]]! ! !CustomQuestionDialogWindow methodsFor: 'initialization' stamp: 'GaryChambers 8/23/2010 11:36'! initialize "Initialize the receiver." self yesButton: self defaultYesButton; noButton: self defaultNoButton; cancelButton: self defaultCancelButton. super initialize! ! !CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2008 11:30'! noButton "Answer the value of noButton" ^ noButton! ! !CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'GaryChambers 8/23/2010 11:36'! cancelButton ^ cancelButton! ! !CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2008 11:31'! defaultNoButton "Answer a default no button." ^self newNoButton! ! !CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 8/23/2010 12:05'! defaultYesButton "Answer a default yes button." ^self newYesButton! ! !CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 8/23/2010 12:05'! newButtons "Answer new buttons as appropriate." ^{self yesButton. self noButton. self cancelButton}! ! !CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 8/23/2010 11:50'! yesText: aStringOrText help: helpString "Set the yes button label. if the text is nil, remove the button." aStringOrText ifNil: [self cancelButton delete] ifNotNil: [self yesButton hResizing: #shrinkWrap; label: aStringOrText; setBalloonText: helpString]! ! !CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'GaryChambers 8/23/2010 11:36'! cancelButton: anObject cancelButton := anObject! ! !CustomQuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 8/23/2010 11:50'! cancelText: aStringOrText help: helpString "Set the cancel button label. if the text is nil, remove the button." aStringOrText ifNil: [self cancelButton delete] ifNotNil: [self cancelButton hResizing: #shrinkWrap; label: aStringOrText; setBalloonText: helpString]! ! !DamageRecorder commentStamp: 'TorstenBergmann 2/20/2014 18:27'! Recording damages to repair by repainting! !DamageRecorder methodsFor: 'recording' stamp: 'IgorStasenko 12/22/2012 03:41'! recordInvalidRect: newRect "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle." | mergeRect zeroRect | totalRepaint ifTrue: [^ self]. "planning full repaint; don't bother collecting damage" zeroRect := 0@0 corner: 0@0. invalidRects do: [:rect | | a | ((a := (rect intersect: newRect ifNone: [ zeroRect ]) area) > 40 and: ["Avoid combining a vertical and horizontal rects. Can make a big diff and we only test when likely." a > (newRect area // 4) or: [a > (rect area // 4)]]) ifTrue: ["merge rectangle in place (see note below) if there is significant overlap" rect setOrigin: (rect origin min: newRect origin) truncated corner: (rect corner max: newRect corner) truncated. ^ self]]. invalidRects size >= 50 ifTrue: ["if there are too many separate areas, merge them all" mergeRect := Rectangle merging: invalidRects. self reset. invalidRects addLast: mergeRect]. "add the given rectangle to the damage list" "Note: We make a deep copy of all rectangles added to the damage list, since rectangles in this list may be extended in place." newRect hasPositiveExtent ifTrue: [ invalidRects addLast: (newRect topLeft truncated corner: newRect bottomRight truncated). ].! ! !DamageRecorder methodsFor: 'recording' stamp: ''! doFullRepaint "Record that a full redisplay is needed. No further damage rectangles will be recorded until after the next reset." ^ totalRepaint := true. ! ! !DamageRecorder methodsFor: 'initialization' stamp: 'sma 6/5/2000 11:55'! reset "Clear the damage list." invalidRects := OrderedCollection new: 15. totalRepaint := false ! ! !DamageRecorder methodsFor: 'testing' stamp: 'dgd 2/22/2003 14:43'! updateIsNeeded "Return true if the display needs to be updated." ^totalRepaint or: [invalidRects notEmpty]! ! !DamageRecorder methodsFor: 'recording' stamp: 'StephaneDucasse 2/7/2011 22:25'! invalidRectsFullBounds: aRectangle "Return a collection of damaged rectangles for the given canvas. If a total repaint has been requested, return the given rectangle." ^ totalRepaint ifTrue: [ Array with: aRectangle] ifFalse: [ invalidRects copy]. ! ! !DamageRecorder class methodsFor: 'instance creation' stamp: ''! new ^ super new reset ! ! !DangerousClassNotifier commentStamp: 'BenComan 2/18/2014 01:44'! Some classes have special importance to the core system. DangerousClassNotifier notifies users which class defiitions should not be modified. This class is refactored from the following Pharo2 methods: * Behaviour>>shouldNotBeRedefined * ClassBuilder>>tooDangerousClasses * ClassBuilder>>name: inEnvironment: subclassOf: type: instanceVariableNames: classVariableNames: poolDictionaries: category: unsafe: Instance Variables enabled: restoreState: enabled - Specifies whether this checking is performed. Some system tests that check "dangerous" behaviour need this turned off. restoreState - After disabling for testing, need to restore the previous state. ! !DangerousClassNotifier class methodsFor: 'accessing' stamp: 'BenComan 2/18/2014 01:19'! initialize enabled := true.! ! !DangerousClassNotifier class methodsFor: 'accessing' stamp: 'BenComan 2/19/2014 01:36'! enabled ^enabled ifNil: [ enabled := false ] ! ! !DangerousClassNotifier class methodsFor: 'accessing' stamp: 'BenComan 2/15/2014 22:01'! restoreAfterTesting restoreState ifNil: [ self error: 'Cannot nest disable for testing' ]. enabled := restoreState. restoreState := nil.! ! !DangerousClassNotifier class methodsFor: 'accessing' stamp: 'BenComan 2/15/2014 22:02'! shouldNotBeRedefined: classSymbol Smalltalk at: classSymbol ifPresent: [ :class | ^(Smalltalk compactClassesArray includes: class) or: [ (Smalltalk specialObjectsArray includes: class) or: [class isKindOf: class] ] ]. ^false. ! ! !DangerousClassNotifier class methodsFor: 'accessing' stamp: 'BenComan 2/19/2014 01:38'! tooDangerousClasses "Return a list of class names which will not be modified in the public interface" ^#( "Object will break immediately" #ProtoObject #Object "Contexts and their superclasses" #InstructionStream #ContextPart #MethodContext #BlockClosure "Superclasses of basic collections" #Collection #SequenceableCollection #ArrayedCollection "Collections known to the VM" #Array #Bitmap #String #Symbol #ByteArray #CompiledMethod "Basic Numbers and logic" #Magnitude #Number #SmallInteger #Float #Boolean #True #False "Misc other" #LookupKey #Association #Link #Point #Rectangle #Behavior #PositionableStream #UndefinedObject )! ! !DangerousClassNotifier class methodsFor: 'accessing' stamp: 'BenComan 2/15/2014 22:01'! disable enabled := false. ! ! !DangerousClassNotifier class methodsFor: 'accessing' stamp: 'BenComan 2/15/2014 22:01'! enable enabled := true. ! ! !DangerousClassNotifier class methodsFor: 'validation' stamp: 'BenComan 2/15/2014 22:02'! check: classSymbol self enabled ifTrue: [ (self tooDangerousClasses includes: classSymbol) ifTrue: [ self error: classSymbol name , ' cannot be changed' ]. "Check if the receiver should not be redefined" (self shouldNotBeRedefined: classSymbol) ifTrue: [ self notify: classSymbol asText allBold , ' should not be redefined. \Proceed to store over it.' withCRs ]. ]. ^true "Just to keep some tests happy"! ! !DangerousClassNotifier class methodsFor: 'accessing' stamp: 'BenComan 2/15/2014 22:01'! disableForTesting restoreState ifNotNil: [ self error: 'Cannot nest disable for testing' ]. restoreState := enabled. enabled := false.! ! !DashedBorder commentStamp: 'gvc 5/18/2007 13:28'! Border style supporting dashed lines of configurable patterns and colours.! !DashedBorder methodsFor: 'accessing' stamp: 'gvc 8/8/2007 17:21'! style "Answer #dashed." ^#dashed! ! !DashedBorder methodsFor: 'accessing' stamp: 'gvc 4/24/2007 15:48'! dashColors "Answer the value of dashColors" ^ dashColors! ! !DashedBorder methodsFor: 'initialization' stamp: 'gvc 4/24/2007 15:50'! initialize "Initialize the receiver." super initialize. self dashColors: {Color black. Color white}; dashLengths: #(1 1)! ! !DashedBorder methodsFor: 'accessing' stamp: 'gvc 4/24/2007 15:48'! dashLengths "Answer the value of dashLengths" ^ dashLengths! ! !DashedBorder methodsFor: 'accessing' stamp: 'gvc 4/24/2007 15:48'! dashLengths: anObject "Set the value of dashLengths" dashLengths := anObject! ! !DashedBorder methodsFor: 'drawing' stamp: 'gvc 4/24/2007 15:51'! frameRectangle: aRectangle on: aCanvas "Frame the given rectangle on aCanvas" (aRectangle width < self width or: [aRectangle height < self width]) ifTrue: [^self]." don't do if too small" aCanvas frameRectangle: aRectangle width: self width colors: self dashColors dashes: self dashLengths! ! !DashedBorder methodsFor: 'accessing' stamp: 'gvc 4/24/2007 15:48'! dashColors: anObject "Set the value of dashColors" dashColors := anObject! ! !DashedBorder methodsFor: 'accessing' stamp: 'gvc 4/24/2007 15:59'! dashColors: cols dashLengths: lens "Set the colours and lengths." cols size = lens size ifFalse: [self error: 'Colors and Lengths must have the same size']. self dashColors: cols; dashLengths: lens! ! !DashedBorder class methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 16:39'! width: width dashColors: cols dashLengths: lens "Answer a new instance of the receiver with the given width, colours and lengths." ^self new width: width; dashColors: cols dashLengths: lens! ! !DataRetriever commentStamp: ''! I am a simple object used when a UI blocking query is needed but: - you do not want to block the UI thread - you want to cache the result - you want to block the access to the data until the end of the query. Even if Imay be reused to retrieve multiple times data, it is safer to dispose me and use a new sibling of me. In case I am released before Ican fetch the data, a `nullObject` will be returned.! !DataRetriever methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/9/2013 18:48'! signalDataIsReady "Since mupltiple clients may have tried to access my data (and be trapped in a wait waiting for the end of the query), I need to signal as long as I have a client waiting" [ semaphore isSignaled ] whileFalse: [ semaphore signal ]. semaphore consumeAllSignals.! ! !DataRetriever methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 12/9/2013 18:38'! initialize super initialize. block := []. semaphore := Semaphore new. semaphoreIsValid := true. nullObject := nil.! ! !DataRetriever methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/9/2013 18:35'! nullObject: anObject nullObject := anObject! ! !DataRetriever methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/9/2013 18:48'! data "If data is nil, it means the query is not yet done. Then the client is frozen until the end of the query (or until I am released). Then if it is release, `nullObject` is returned instead of the query result" data ifNil: [ semaphore wait ]. semaphoreIsValid ifFalse: [ ^ nullObject ]. ^ data! ! !DataRetriever methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/9/2013 18:31'! retrieveData fork ifNotNil: [ fork terminate ]. fork := [ data := nil. semaphore consumeAllSignals. data := block value. self signalDataIsReady ] forkAt: Processor userBackgroundPriority + 5! ! !DataRetriever methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/9/2013 18:48'! block: aBlock "The query starts as soon as the retrieval block is set" block := aBlock. self retrieveData! ! !DataRetriever methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/9/2013 18:48'! release "If I am released while some clients are waiting, I need to free them. In the getter, the value of semaphoreIsValid is checked to know if it was a release or the end of the query" | oldSemaphoreIsValid | oldSemaphoreIsValid := semaphoreIsValid. semaphoreIsValid := false. self signalDataIsReady. semaphoreIsValid := oldSemaphoreIsValid.! ! !DataRetriever class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 12/9/2013 18:37'! for: aBlock ^ self new block: aBlock; yourself! ! !Date commentStamp: ''! Instances of Date are Timespans with duration of 1 day. Their default creation assumes a start of midnight in the local time zone.! !Date methodsFor: 'accessing' stamp: 'brp 8/24/2003 12:04'! weekday "Answer the name of the day of the week on which the receiver falls." ^ self dayOfWeekName! ! !Date methodsFor: 'accessing' stamp: 'avi 2/21/2004 18:12'! month ^ self asMonth! ! !Date methodsFor: 'printing' stamp: 'BP 3/23/2001 12:27'! storeOn: aStream aStream print: self printString; nextPutAll: ' asDate'! ! !Date methodsFor: 'adding' stamp: 'brp 8/23/2003 22:05'! subtractDays: dayCount ^ (self asDateAndTime - (dayCount days)) asDate! ! !Date methodsFor: 'printing' stamp: 'StephaneDucasse 12/25/2011 22:50'! ddmmyyyy "Print the receiver in standard French format dd/mm/yyyy." ^ self printFormat: #(1 2 3 $/ 1 1) ! ! !Date methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 12/20/2011 22:18'! printFormat: formatArray "Answer a String describing the receiver using the argument formatArray." ^ String new: 16 streamContents: [ :aStream | self printOn: aStream format: formatArray ]! ! !Date methodsFor: 'printing' stamp: 'StephaneDucasse 12/25/2011 22:51'! mmddyyyy "Print the receiver in standard U.S.A format mm/dd/yyyy. Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, so that for example February 1 1996 is 2/1/96" ^ self printFormat: #(2 1 3 $/ 1 1)! ! !Date methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitHookPrimitive: self ! ! !Date methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 12/20/2011 22:21'! yyyymmdd "Format the date in ISO 8601 standard like '2002-10-22' The result is of fixed size 10 characters long.." ^ String new: 10 streamContents: [ :aStream | self printOn: aStream format: #(3 2 1 $- 1 1 2) ]! ! !Date methodsFor: 'utils' stamp: 'CamilloBruni 8/22/2013 19:48'! addMonths: monthCount |year month maxDaysInMonth day | year := self year + (monthCount + self monthIndex - 1 // 12). month := self monthIndex + monthCount - 1 \\ 12 + 1. maxDaysInMonth := Month daysInMonth: month forYear: year. day := self dayOfMonth > maxDaysInMonth ifTrue: [maxDaysInMonth] ifFalse: [self dayOfMonth]. ^ Date year: year month: month day: day! ! !Date methodsFor: 'accessing' stamp: 'brp 1/16/2004 14:30'! previous: dayName "Answer the previous date whose weekday name is dayName." | days | days := 7 + self weekdayIndex - (self class dayOfWeek: dayName) \\ 7. days = 0 ifTrue: [ days := 7 ]. ^ self subtractDays: days ! ! !Date methodsFor: 'accessing' stamp: 'brp 8/24/2003 12:04'! weekdayIndex "Sunday=1, ... , Saturday=7" ^ self dayOfWeek! ! !Date methodsFor: 'utils' stamp: 'spfa 3/8/2004 13:52'! onNextMonth ^ self addMonths: 1 ! ! !Date methodsFor: '*Fuel' stamp: 'MaxLeske 2/18/2013 22:36'! serializeOn: anEncoder start serializeOn: anEncoder! ! !Date methodsFor: 'adding' stamp: 'brp 8/23/2003 22:09'! addDays: dayCount ^ (self asDateAndTime + (dayCount days)) asDate! ! !Date methodsFor: 'accessing' stamp: 'avi 2/29/2004 13:10'! monthIndex ^ super month! ! !Date methodsFor: 'accessing' stamp: 'sd 3/16/2008 14:43'! asDate ^ self! ! !Date methodsFor: 'printing' stamp: 'BP 3/23/2001 12:27'! printOn: aStream self printOn: aStream format: #(1 2 3 $ 3 1 )! ! !Date methodsFor: 'deprecated' stamp: 'brp 7/27/2003 16:08'! leap "Answer whether the receiver's year is a leap year." ^ start isLeapYear ifTrue: [1] ifFalse: [0].! ! !Date methodsFor: 'enumerating' stamp: 'brp 7/27/2003 16:10'! dayMonthYearDo: aBlock "Supply integers for day, month and year to aBlock and return the result" ^ start dayMonthYearDo: aBlock! ! !Date methodsFor: 'adding' stamp: 'brp 7/27/2003 16:09'! subtractDate: aDate "Answer the number of days between self and aDate" ^ (self start - aDate asDateAndTime) days! ! !Date methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 10/26/2012 15:44'! printOn: aStream format: formatArray "Print a description of the receiver on aStream using the format denoted the argument, formatArray: #(item item item sep monthfmt yearfmt twoDigits) items: 1=day 2=month 3=year will appear in the order given, separated by sep which is eaither an ascii code or character. monthFmt: 1=09 2=Sep 3=September yearFmt: 1=1996 2=96 digits: (missing or)1=9 2=09. See the examples in printOn: and mmddyy" | day month year twoDigits element monthFormat | self dayMonthYearDo: [ :d :m :y | day := d. month := m. year := y ]. twoDigits := formatArray size > 6 and: [ (formatArray at: 7) > 1 ]. 1 to: 3 do: [ :i | element := formatArray at: i. element = 1 ifTrue: [ twoDigits ifTrue: [ day printOn: aStream base: 10 length: 2 padded: true ] ifFalse: [ day printOn: aStream ] ]. element = 2 ifTrue: [ monthFormat := formatArray at: 5. monthFormat = 1 ifTrue: [ twoDigits ifTrue: [ month printOn: aStream base: 10 length: 2 padded: true ] ifFalse: [ month printOn: aStream]]. monthFormat = 2 ifTrue: [ (Month nameOfMonth: month) from: 1 to: 3 do: [ :each | aStream nextPut: each ] ]. monthFormat = 3 ifTrue: [ aStream nextPutAll: (Month nameOfMonth: month) ] ]. element = 3 ifTrue: [ (formatArray at: 6) = 1 ifTrue: [ year printOn: aStream base: 10 length: 4 padded: true ] ifFalse: [ (year \\ 100) printOn: aStream base: 10 length: 2 padded: true ] ]. i < 3 ifTrue: [ (formatArray at: 4) ~= 0 ifTrue: [ aStream nextPut: (formatArray at: 4) asCharacter ] ] ]! ! !Date methodsFor: 'utils' stamp: 'spfa 3/8/2004 13:52'! onPreviousMonth ^ self addMonths: -1 ! ! !Date class methodsFor: 'instance creation' stamp: 'brp 7/27/2003 18:25'! julianDayNumber: aJulianDayNumber ^ self starting: (DateAndTime julianDayNumber: aJulianDayNumber)! ! !Date class methodsFor: 'accessing' stamp: 'brp 7/1/2003 13:35'! dayOfWeek: dayName ^ Week indexOfDay: dayName! ! !Date class methodsFor: 'importing' stamp: 'HernanWilkinson 11/7/2013 11:09'! readFrom: aStream "Read a Date from the stream in any of the forms: (15 April 1982; 15-APR-82; 15.4.82; 15APR82) (April 15, 1982; 4/15/82) -- (1982-04-15) (ISO8601)" | day month year parsedNumber prefix | aStream peek = $- ifTrue: [prefix := -1] ifFalse: [prefix := 1]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. aStream peek isDigit ifTrue: [ parsedNumber := (Integer readFrom: aStream) * prefix. (parsedNumber < 0 or: [parsedNumber > 31]) ifTrue: [year := parsedNumber]]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. aStream peek isLetter ifTrue: ["MM-DD-YY or DD-MM-YY or YY-MM-DD" month := (String new: 10) writeStream. [aStream peek isLetter] whileTrue: [month nextPut: aStream next]. month := month contents. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. parsedNumber ifNil: ["MM DD YY" day := Integer readFrom: aStream] ifNotNil: [ year ifNil: ["DD MM YY" day := parsedNumber]]] ifFalse: ["MM-DD-YY or DD-MM-YY or YY-MM-DD" year ifNil: ["MM-DD-YY or DD-MM-YY" parsedNumber > 12 ifTrue: ["DD-MM-YY" Error signal: 'Month out of bounds: ', parsedNumber asString, '.'. day := parsedNumber. month := Month nameOfMonth: (Integer readFrom: aStream) ] ifFalse: ["MM-DD-YY" month := Month nameOfMonth: parsedNumber. day := Integer readFrom: aStream]] ifNotNil: ["YY-MM-DD" month := Month nameOfMonth: (Integer readFrom: aStream)]]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. year ifNil: [year := Integer readFrom: aStream] ifNotNil: [day := Integer readFrom: aStream]. (year < 100 and: [year >= 0]) ifTrue: [ year < 69 ifTrue: [year := 2000 + year] ifFalse: [year := 1900 + year]]. ^ self year: year month: month day: day ! ! !Date class methodsFor: 'instance creation' stamp: 'sd 3/16/2008 14:57'! newDay: day month: month year: year ^ self year: year month: month day: day! ! !Date class methodsFor: '*Fuel' stamp: 'MaxLeske 2/18/2013 22:36'! materializeFrom: aDecoder ^ self starting: (DateAndTime materializeFrom: aDecoder) midnight duration: (Duration days: 1)! ! !Date class methodsFor: 'instance creation' stamp: 'sd 3/16/2008 14:58'! starting: aDateAndTime ^ super starting: (aDateAndTime midnight) duration: (Duration days: 1) ! ! !Date class methodsFor: 'accessing' stamp: 'brp 7/1/2003 13:40'! nameOfMonth: anIndex ^ Month nameOfMonth: anIndex. ! ! !Date class methodsFor: 'instance creation' stamp: 'brp 7/1/2003 18:09'! tomorrow ^ self today next! ! !Date class methodsFor: 'instance creation' stamp: 'brp 7/27/2003 16:01'! newDay: dayCount year: yearInteger ^ self year: yearInteger day: dayCount! ! !Date class methodsFor: 'instance creation' stamp: 'brp 7/27/2003 22:03'! year: year day: dayOfYear ^ self starting: (DateAndTime year: year day: dayOfYear) ! ! !Date class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/17/2012 17:10'! fromDays: dayCount "Days since 1 January 1901" ^ self julianDayNumber: SqueakEpoch + dayCount! ! !Date class methodsFor: 'instance creation' stamp: 'brp 7/1/2003 18:09'! yesterday ^ self today previous! ! !Date class methodsFor: 'accessing' stamp: 'brp 7/1/2003 13:53'! daysInYear: yearInteger ^ Year daysInYear: yearInteger.! ! !Date class methodsFor: 'instance creation' stamp: 'sd 3/16/2008 14:58'! year: year month: month day: day ^ self starting: (DateAndTime year: year month: month day: day) ! ! !Date class methodsFor: 'accessing' stamp: 'CamilloBruni 8/22/2013 19:47'! firstWeekdayOfMonth: month year: year "Answer the weekday index of the first day in in the ." ^ (self year: year month: month day: 1) weekdayIndex ! ! !Date class methodsFor: 'instance creation' stamp: 'sd 3/16/2008 14:57'! today ^ self current! ! !Date class methodsFor: 'accessing' stamp: 'brp 7/1/2003 13:59'! daysInMonth: monthName forYear: yearInteger ^ Month daysInMonth: monthName forYear: yearInteger. ! ! !Date class methodsFor: 'accessing' stamp: 'brp 7/1/2003 13:37'! nameOfDay: dayIndex ^ Week nameOfDay: dayIndex ! ! !Date class methodsFor: 'specific inquiries' stamp: 'CamilloBruni 8/22/2013 19:47'! orthodoxEasterDateFor: year " compute the easter date according to the rules of the orthodox calendar. source: http://www.smart.net/~mmontes/ortheast.html " | r1 r2 r3 r4 ra rb r5 rc date | r1 := year \\ 19. r2 := year \\ 4. r3 := year \\ 7. ra := 19*r1 + 16. r4 := ra \\ 30. rb := r2 + r2 + (4*r3) + (6*r4). r5 := rb \\ 7. rc := r4 + r5. date := Date year: year month: 4 day: 3. ^date addDays: rc.! ! !Date class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/17/2012 17:13'! julianDayNumber: aJulianDayNumber offset: aTimeZoneOffset ^ self starting: (DateAndTime julianDayNumber: aJulianDayNumber offset: aTimeZoneOffset)! ! !Date class methodsFor: 'importing' stamp: 'HernanWilkinson 11/7/2013 14:24'! readFrom: inputStream pattern: pattern "See DateParser comment" ^ (DateParser readingFrom: inputStream pattern: pattern) parse ! ! !Date class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/22/2013 19:32'! year: year week: week day: dayOfWeek ^ self starting: (Week year: year week: week) start + (dayOfWeek - 1) days! ! !Date class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/22/2013 19:32'! week: week day: dayOfWeek ^ self starting: (Week week: week) start + (dayOfWeek - 1) days! ! !Date class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/13/2012 21:16'! fromSeconds: seconds "Answer an instance of me which is 'seconds' seconds after January 1, 1901." ^ self starting: (DateAndTime fromSeconds: seconds)! ! !Date class methodsFor: 'importing' stamp: 'md 7/15/2006 18:06'! fromString: aString "Answer an instance of created from a string with format mm.dd.yyyy." ^ self readFrom: aString readStream.! ! !Date class methodsFor: 'accessing' stamp: 'brp 7/1/2003 13:39'! indexOfMonth: aMonthName ^ Month indexOfMonth: aMonthName. ! ! !Date class methodsFor: 'specific inquiries' stamp: 'CamilloBruni 8/22/2013 19:48'! easterDateFor: year " compute the easter date. source: Physikalisch-Technische Bundesanstalt Braunschweig. Lichtenberg, H.: Zur Interpretation der Gaussschen Osterformel und ihrer Ausnahmeregeln, Historia Mathematica 24 (1997), pp. 441-444 http://www.ptb.de/de/org/4/44/441/oste.htm " | k m s a d r og sz oe day | k := year // 100. m := 15 + (3*k + 3//4) - (8*k + 13//25). s := 2 - (3*k + 3// 4). a := year \\ 19. d := 19*a + m \\ 30. r := d//29 + ((d//28) - (d//29)* (a// 11)). og := 21 + d - r. sz := 7 - (year//4 + year + s\\7). oe := 7 - (og - sz\\7). day := og + oe. ^day <= 31 ifTrue: [ Date year: year month: 3 day: day ] ifFalse: [ Date year: year month: 4 day: day - 31 ].! ! !DateAndTime commentStamp: 'SvenVanCaekenberghe 1/10/2014 11:04'! I am DateAndTime. I represent a point in time or timestamp as defined by ISO 8601. I am a Magnitude. I have nanosecond precision. I am TimeZone aware. I have zero duration. DateAndTime now. DateAndTime now asUTC rounded. DateAndTime fromString: '1969-07-20T20:17:40.123+02:00'. DateAndTime fromString: '1969-07-20T20:17:40Z'. My implementation uses three SmallIntegers and a Duration: julianDayNumber - julian day number (starting at midnight UTC rather than noon GMT). seconds - number of seconds since midnight UTC. Always positive, between 0 and 86399. nanos - the number of nanoseconds since the second. Always positive, between 0 and 999999999. offset - duration from UTC. The offset is used to print the date and time in a local time zone, but the date and time are handled in UTC internally. The nanosecond attribute is often zero but it defined for full ISO compliance and is suitable for timestamping. ! !DateAndTime methodsFor: 'converting' stamp: 'CamilloBruni 7/13/2012 17:15'! asSeconds "Return the number of seconds since the Squeak epoch" ^ (self - (self class epoch)) asSeconds! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:04'! hour ^ self hour24 ! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 16:44'! timeZone ^ TimeZone offset: self offset! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:02'! nanoSecond ^ nanos ! ! !DateAndTime methodsFor: 'enumerating' stamp: 'sd 3/16/2008 15:03'! to: anEnd by: aDuration do: aBlock "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" ^ (self to: anEnd by: aDuration) scheduleDo: aBlock ! ! !DateAndTime methodsFor: 'converting' stamp: 'nice 4/27/2013 23:41'! asDuration "Answer the duration since midnight." ^ Duration seconds: self secondsSinceMidnightLocalTime nanoSeconds: nanos ! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/12/2012 18:52'! julianDayNumber ^ julianDayNumber + self julianDayOffset! ! !DateAndTime methodsFor: 'arithmetic' stamp: 'SvenVanCaekenberghe 3/27/2014 22:26'! < comparand "comparand conforms to protocol DateAndTime, or can be converted into something that conforms." | other | other := comparand asDateAndTime. ^ julianDayNumber = other julianDayNumberUTC ifTrue: [ seconds = other secondsSinceMidnightUTC ifTrue: [ nanos < other nanoSecond ] ifFalse: [ seconds < other secondsSinceMidnightUTC ] ] ifFalse: [ julianDayNumber < other julianDayNumberUTC ]! ! !DateAndTime methodsFor: 'converting' stamp: 'CamilloBruni 6/7/2013 23:37'! asTimeUTC ^ Time seconds: self secondsSinceMidnightUTC nanoSeconds: nanos! ! !DateAndTime methodsFor: 'enumerating' stamp: 'sd 3/16/2008 15:03'! to: anEnd by: aDuration "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" ^ (Schedule starting: self ending: (anEnd asDateAndTime)) schedule: (Array with: aDuration asDuration); yourself. ! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 7/27/2003 15:44'! daysLeftInYear "Answer the number of days in the year after the date of the receiver." ^ self daysInYear - self dayOfYear ! ! !DateAndTime methodsFor: 'private' stamp: 'nice 4/27/2013 22:19'! ticks: ticks offset: utcOffset "ticks is {julianDayNumber. secondCount. nanoSeconds}" self setJdn: (ticks at: 1) seconds: (ticks at: 2) nano: (ticks at: 3) offset: utcOffset! ! !DateAndTime methodsFor: '*Fuel' stamp: 'nice 4/27/2013 22:18'! fuelSet: julianDay nanoSecond: nanoSeconds seconds: numberOfSeconds offset: anOffset self setJdn: julianDay seconds: numberOfSeconds nano: nanoSeconds offset: anOffset! ! !DateAndTime methodsFor: 'converting' stamp: 'NickAger 7/6/2010 11:22'! asUnixTime "answer number of seconds since unix epoch (midnight Jan 1, 1970, UTC)" ^((self offset: Duration zero) - self class unixEpoch) asSeconds! ! !DateAndTime methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 12/20/2011 22:26'! printMSOn: aStream "Print just mm:ss" self minute printOn: aStream base: 10 length: 2 padded: true. aStream nextPut: $:. self second printOn: aStream base: 10 length: 2 padded: true! ! !DateAndTime methodsFor: 'accessing' stamp: 'AndyKellens 4/3/2013 18:09'! dayOfWeek "Sunday=1, ... , Saturday=7" ^ (self julianDayNumber + 1 rem: 7) + 1! ! !DateAndTime methodsFor: 'accessing' stamp: 'nice 4/27/2013 23:43'! second "Answer a number that represents the number of complete seconds in the receiver's time part, after the number of complete minutes has been removed." ^ self localSeconds \\ 60! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 7/1/2003 18:30'! hours ^ self hour! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:05'! month ^ self dayMonthYearDo: [ :d :m :y | m ].! ! !DateAndTime methodsFor: 'private' stamp: 'nice 4/27/2013 22:09'! hasEqualTicks: aDateAndTime ^ (self julianDayNumberUTC = aDateAndTime julianDayNumberUTC) and: [ (seconds = aDateAndTime secondsSinceMidnightUTC) and: [ nanos = aDateAndTime nanoSecond ] ] ! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 16:43'! timeZoneAbbreviation ^ self timeZone abbreviation ! ! !DateAndTime methodsFor: 'enumerating' stamp: 'sd 3/16/2008 15:03'! to: anEnd "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" ^ Timespan starting: self ending: (anEnd asDateAndTime). ! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 5/13/2003 07:48'! daysInYear "Answer the number of days in the year represented by the receiver." ^ self asYear daysInYear ! ! !DateAndTime methodsFor: '*Network-Mail' stamp: 'SeanDeNigris 12/8/2011 15:09'! asEmailString "Format per RFC5322 e.g. 'Thu, 18 Feb 1999 20:38:51 -0500'" | timeString | timeString := (self asTime print24 first: 8). ^ '{1}, {2} {3} {4} {5} {6}' format: { self dayOfWeekAbbreviation. self dayOfMonth asString. self monthAbbreviation. self year asString. timeString. self offset asEmailTimeOffsetString }.! ! !DateAndTime methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! setTimestampInMetacelloVersion: aMetacelloVersionSpec aMetacelloVersionSpec setTimestamp: (aMetacelloVersionSpec project valueHolderSpec value: self printString; yourself)! ! !DateAndTime methodsFor: 'converting' stamp: 'CamilloBruni 7/13/2012 19:57'! asUTC ^ offset isZero ifTrue: [ self ] ifFalse: [ self offset: 0 ] ! ! !DateAndTime methodsFor: 'converting' stamp: 'sd 3/16/2008 15:01'! asYear ^ Year starting: self! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 7/27/2003 15:44'! firstDayOfMonth ^ self asMonth start day! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 08:31'! noon "Answer a DateAndTime starting at noon" ^ self dayMonthYearDo: [ :d :m :y | self class year: y month: m day: d hour: 12 minute: 0 second: 0 offset: offset]! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 18:27'! julianDayNumberUTC ^ julianDayNumber! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 7/1/2003 17:53'! day ^ self dayOfYear! ! !DateAndTime methodsFor: 'converting' stamp: 'sd 3/16/2008 15:00'! asDateAndTime ^ self ! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:05'! hour12 "Answer an between 1 and 12, inclusive, representing the hour of the day in the 12-hour clock of the local time of the receiver." ^ self hour24 - 1 \\ 12 + 1! ! !DateAndTime methodsFor: 'enumerating' stamp: 'CamilloBruni 7/13/2012 18:32'! dayMonthYearDo: aBlock "Return the value of executing block with the Gregorian Calender day, month and year as arguments, as computed from my Julian Day Number, julianDayNumber. See http://en.wikipedia.org/wiki/Julian_date#Gregorian_calendar_from_Julian_day_number A short Description for the Constants used below: - 400 years span 146097 days in gregorian calendar. - 100 years span 36524 days, except every 400 years. - 4 years span 1461 days, except every 100 years. - 1 year spans 365 days, except every four years " | l n i j monthDay month fullYear | l := self julianDayNumber + 68569. n := 4 * l // 146097. l := l - (146097 * n + 3 // 4). i := 4000 * (l + 1) // 1461001. l := l - (1461 * i // 4) + 31. j := 80 * l // 2447. monthDay := l - (2447 * j // 80). l := j // 11. month := j + 2 - (12 * l). fullYear := 100 * (n - 49) + i + l. ^ aBlock value: monthDay value: month value: fullYear.! ! !DateAndTime methodsFor: 'maintime' stamp: 'sd 3/16/2008 15:02'! middleOf: aDuration "Return a Timespan where the receiver is the middle of the Duration" | duration | duration := aDuration asDuration. ^ Timespan starting: (self - (duration / 2)) duration: duration. ! ! !DateAndTime methodsFor: 'converting' stamp: 'brp 8/24/2003 00:02'! asTimeStamp ^ self as: TimeStamp! ! !DateAndTime methodsFor: 'truncation' stamp: 'nice 4/27/2013 22:16'! rounded "Answer a date and time to the nearest whole second" ^ self species basicNew ticks: { julianDayNumber. nanos *2 >= NanosInSecond ifTrue: [seconds + 1] ifFalse: [seconds]. 0 } offset: offset! ! !DateAndTime methodsFor: 'private' stamp: 'nice 4/27/2013 23:24'! secondsSinceMidnightLocalTime ^ self localSeconds \\ SecondsInDay! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 1/7/2004 15:45'! minutes ^ self minute! ! !DateAndTime methodsFor: 'converting' stamp: 'sd 3/16/2008 15:01'! asMonth ^ Month starting: self ! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 7/1/2003 18:31'! seconds ^ self second! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 18:58'! julianDayOffset "Return the offset in julian days possibly introduced by the timezone offset" ^ ((seconds + self offset asSeconds) / SecondsInDay) floor! ! !DateAndTime methodsFor: 'private' stamp: 'nice 4/28/2013 01:17'! normalizeSecondsAndNanos (NanosInSecond <= nanos or: [ nanos < 0 ]) ifTrue: [ seconds := seconds + (nanos // NanosInSecond). nanos := nanos \\ NanosInSecond]. (SecondsInDay <= seconds or: [ seconds < 0 ]) ifTrue: [ julianDayNumber := julianDayNumber + (seconds // SecondsInDay). seconds := seconds \\ SecondsInDay]. ! ! !DateAndTime methodsFor: 'offset' stamp: 'CamilloBruni 6/8/2013 00:10'! translateTo: anOffset "Keep myself's representation and move it to another timezone offset. Note that unlike #offset: this WILL change the absolute time in UTC |t| t := DateAndTime now. t = (t offset: 2 hours). t = (t translateTo: 2 hours). " self dayMonthYearDo: [ :day :month :year| ^ self class year: year month: month day: day hour: self hour minute: self minute second: self second nanoSecond: self nanoSecond offset: anOffset asDuration ]! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:05'! meridianAbbreviation ^ self asTime meridianAbbreviation! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:06'! offset ^ offset ! ! !DateAndTime methodsFor: 'converting' stamp: 'SeanDeNigris 5/21/2012 17:34'! asDosTimestamp ^ (DosTimestamp fromDateAndTime: self) value. ! ! !DateAndTime methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitHookPrimitive: self ! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:04'! dayOfMonth "Answer which day of the month is represented by the receiver." ^ self dayMonthYearDo: [ :d :m :y | d ]! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:05'! monthAbbreviation ^ self monthName copyFrom: 1 to: 3 ! ! !DateAndTime methodsFor: 'converting' stamp: 'sd 3/16/2008 15:01'! asWeek ^ Week starting: self ! ! !DateAndTime methodsFor: 'arithmetic' stamp: 'SvenVanCaekenberghe 3/27/2014 22:25'! + operand "operand conforms to protocol Duration" | durationTicks | durationTicks := operand asDuration ticks. ^ self class basicNew setJdn: julianDayNumber + durationTicks first seconds: seconds + durationTicks second nano: nanos + durationTicks third offset: self offset; yourself! ! !DateAndTime methodsFor: 'arithmetic' stamp: 'SvenVanCaekenberghe 3/27/2014 22:26'! - operand "operand conforms to protocol DateAndTime or protocol Duration" ^ (operand respondsTo: #asDateAndTime) ifTrue: [ | other | other := operand asDateAndTime. Duration seconds: (SecondsInDay * (julianDayNumber - other julianDayNumberUTC)) + (seconds - other secondsSinceMidnightUTC) nanoSeconds: nanos - other nanoSecond ] ifFalse: [ self + operand negated ]! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:05'! monthName ^ Month nameOfMonth: self month ! ! !DateAndTime methodsFor: 'accessing' stamp: 'nice 1/5/2010 15:59'! dayOfYear "This code was contributed by Dan Ingalls. It is equivalent to the terser ^ jdn - (Year year: self year) start julianDayNumber + 1 but much quicker." ^ self dayMonthYearDo: [ :d :m :y | | monthStart | monthStart := #(1 32 60 91 121 152 182 213 244 274 305 335) at: m. (m > 2 and: [ Year isLeapYear: y ]) ifTrue: [ monthStart + d ] ifFalse: [ monthStart + d - 1 ]]! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 16:43'! timeZoneName ^ self timeZone name ! ! !DateAndTime methodsFor: 'converting' stamp: 'sd 3/16/2008 15:00'! asDate ^ Date starting: self! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:04'! dayOfWeekAbbreviation ^ self dayOfWeekName copyFrom: 1 to: 3! ! !DateAndTime methodsFor: 'printing' stamp: 'StephaneDucasse 4/24/2010 16:26'! printOn: aStream "Print as per ISO 8601 sections 5.3.3 and 5.4.1. Prints either: 'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years)" ^self printOn: aStream withLeadingSpace: false ! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:05'! isLeapYear ^ Year isLeapYear: self year. ! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 5/13/2003 07:48'! daysInMonth "Answer the number of days in the month represented by the receiver." ^ self asMonth daysInMonth! ! !DateAndTime methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 12/20/2011 22:34'! printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo "Print just the year, month, and day on aStream. If printLeadingSpaceToo is true, then print as: ' YYYY-MM-DD' (if the year is positive) or '-YYYY-MM-DD' (if the year is negative) otherwise print as: 'YYYY-MM-DD' or '-YYYY-MM-DD' " | year month day | self dayMonthYearDo: [ :d :m :y | year := y. month := m. day := d ]. year negative ifTrue: [ aStream nextPut: $- ] ifFalse: [ printLeadingSpaceToo ifTrue: [ aStream space ] ]. year abs printOn: aStream base: 10 length: 4 padded: true. aStream nextPut: $-. month printOn: aStream base: 10 length: 2 padded: true. aStream nextPut: $-. day printOn: aStream base: 10 length: 2 padded: true! ! !DateAndTime methodsFor: 'accessing' stamp: 'nice 4/27/2013 23:43'! hour24 "Answer a number that represents the number of complete hours in the receiver's time part, after the number of complete days has been removed." ^ self localSeconds // SecondsInHour \\ 24! ! !DateAndTime methodsFor: 'accessing' stamp: 'nice 4/27/2013 23:44'! minute "Answer a number that represents the number of complete minutes in the receiver' time part, after the number of complete hours has been removed." ^ self localSeconds // SecondsInMinute \\ 60! ! !DateAndTime methodsFor: 'truncation' stamp: 'nice 4/27/2013 22:13'! truncated "Answer a date and time to the nearest preceding whole second" ^ self species basicNew ticks: { julianDayNumber. seconds. 0 } offset: offset! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 19:01'! localSeconds " Return the seconds since the epoch in local time." ^ seconds + self offset asSeconds! ! !DateAndTime methodsFor: 'private' stamp: 'nice 4/27/2013 22:09'! secondsSinceMidnightUTC ^ seconds! ! !DateAndTime methodsFor: 'offset' stamp: 'CamilloBruni 11/4/2013 08:21'! translateToUTC " Move this represenation to UTC" ^ self translateTo: 0 asDuration ! ! !DateAndTime methodsFor: 'private' stamp: 'nice 4/28/2013 01:17'! setJdn: julDays seconds: secs nano: nanoSecs offset: anOffset julianDayNumber := julDays. seconds := secs. nanos := nanoSecs. offset := anOffset. self normalizeSecondsAndNanos! ! !DateAndTime methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 11/18/2013 16:18'! printSeparateDateAndTimeOn: stream "Print the receiver as separate Date and Time to stream. See also #readSeparateDateAndTimeFrom:" stream print: self asDate; space; print: self asTime! ! !DateAndTime methodsFor: 'private' stamp: 'nice 4/27/2013 22:08'! hash ^ (julianDayNumber hashMultiply bitXor: seconds) bitXor: nanos! ! !DateAndTime methodsFor: 'converting' stamp: 'nice 4/27/2013 23:41'! asTime ^ Time seconds: self secondsSinceMidnightLocalTime nanoSeconds: nanos! ! !DateAndTime methodsFor: 'converting' stamp: 'CamilloBruni 7/13/2012 16:35'! asLocal ^ (self offset = self class localOffset) ifTrue: [self] ifFalse: [self offset: self class localOffset] ! ! !DateAndTime methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 12/20/2011 22:54'! printOn: aStream withLeadingSpace: printLeadingSpaceToo "Print as per ISO 8601 sections 5.3.3 and 5.4.1. If printLeadingSpaceToo is false, prints either: 'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years) If printLeadingSpaceToo is true, prints either: ' YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years) " self printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo. aStream nextPut: $T. self printHMSOn: aStream. nanos ~= 0 ifTrue: [ | n len | n := nanos. len := 9. [ n \\ 10 = 0 ] whileTrue: [ n := n / 10. len := len - 1 ]. aStream nextPut: $.. n printOn: aStream base: 10 length: len padded: true ]. aStream nextPut: (offset positive ifTrue: [ $+ ] ifFalse: [ $- ]). offset hours abs printOn: aStream base: 10 length: 2 padded: true. aStream nextPut: $:. offset minutes abs printOn: aStream base: 10 length: 2 padded: true. offset seconds = 0 ifFalse:[ aStream nextPut: $:; print: offset seconds abs truncated ]! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:04'! dayOfWeekName ^ Week nameOfDay: self dayOfWeek ! ! !DateAndTime methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! setTimestampInMetacelloConfig: aMetacelloConfig aMetacelloConfig setTimestampWithString: self printString! ! !DateAndTime methodsFor: '*Fuel' stamp: 'nice 4/27/2013 22:10'! serializeOn: anEncoder anEncoder encodeUint32: self julianDayNumberUTC; encodeUint32: self nanoSecond; encodeInt24: self secondsSinceMidnightUTC; encodeInt24: self offset asSeconds; encodeInt32: self offset nanoSeconds.! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 5/13/2003 07:50'! monthIndex ^ self month ! ! !DateAndTime methodsFor: 'arithmetic' stamp: 'nice 4/27/2013 22:06'! = other self == other ifTrue: [ ^ true ]. (self species = other species) ifFalse: [ ^ false ]. ^ self hasEqualTicks: other! ! !DateAndTime methodsFor: '*Deprecated30' stamp: 'nice 4/27/2013 22:21'! secondsSinceMidnight self deprecated: 'Use secondsSinceMidnightUTC' on: ' 2013-04-27T20:20:00Z' in: 'Pharo 3.0'. ^ self secondsSinceMidnightUTC! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 6/8/2013 00:10'! offset: anOffset "Answer a equivalent to the receiver but with its local time being offset from UTC by offset. Unlike #translateTo: this will NOT change the absolute in UTC " ^ self class basicNew ticks: self ticks offset: anOffset asDuration; yourself ! ! !DateAndTime methodsFor: 'converting' stamp: 'sd 3/16/2008 15:01'! asNanoSeconds "Answer the number of nanoseconds since midnight" ^ self asDuration asNanoSeconds ! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:06'! year ^ self dayMonthYearDo: [:d :m :y | y ]! ! !DateAndTime methodsFor: 'maintime' stamp: 'CamilloBruni 11/4/2013 08:14'! midnight "Answer a DateAndTime starting at midnight (towards the end of the day) local time" self dayMonthYearDo: [ :day :month :year| ^self class year: year month: month day: day offset: offset ].! ! !DateAndTime methodsFor: 'private' stamp: 'CamilloBruni 3/30/2032 18:26'! ticks "Private - answer an array with our instance variables. Assumed to be UTC " ^ Array with: julianDayNumber with: seconds with: nanos.! ! !DateAndTime methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 12/20/2011 22:30'! printYMDOn: aStream "Print just YYYY-MM-DD part. If the year is negative, prints out '-YYYY-MM-DD'." ^ self printYMDOn: aStream withLeadingSpace: false. ! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:01'! duration ^ Duration zero! ! !DateAndTime methodsFor: 'offset' stamp: 'CamilloBruni 7/13/2012 16:37'! withoutOffset ^ self offset: 0 ! ! !DateAndTime methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 12/20/2011 22:26'! printHMSOn: aStream "Print just hh:mm:ss" self hour printOn: aStream base: 10 length: 2 padded: true. aStream nextPut: $:. self minute printOn: aStream base: 10 length: 2 padded: true. aStream nextPut: $:. self second printOn: aStream base: 10 length: 2 padded: true! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/13/2012 19:15'! year: year month: month day: day hour: hour minute: minute second: second nanoSecond: nanoCount offset: utcOffset "Return a DateAndTime with the values in the given TimeZone (UTCOffset)" | monthIndex daysInMonth p q r s julianDayNumber localSeconds utcSeconds| monthIndex := month isInteger ifTrue: [ month ] ifFalse: [ Month indexOfMonth: month ]. daysInMonth := Month daysInMonth: monthIndex forYear: year. day < 1 ifTrue: [ self error: 'day may not be zero or negative' ]. day > daysInMonth ifTrue: [ self error: 'day is after month ends' ]. p := (monthIndex - 14) quo: 12. q := year + 4800 + p. r := monthIndex - 2 - (12 * p). s := (year + 4900 + p) quo: 100. julianDayNumber := ((1461 * q) quo: 4) + ((367 * r) quo: 12) - ((3 * s) quo: 4) + (day - 32075). localSeconds := hour * 60 + minute * 60 + second. utcSeconds := localSeconds - utcOffset asSeconds. ^self basicNew setJdn: julianDayNumber seconds: utcSeconds nano: nanoCount offset: utcOffset; yourself! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/17/2012 17:08'! julianDayNumber: aJulianDayNumber ^ self basicNew ticks: aJulianDayNumber days ticks offset: Duration new; yourself! ! !DateAndTime class methodsFor: 'time zones' stamp: 'brp 9/4/2003 06:39'! localTimeZone "Answer the local time zone" ^ LocalTimeZone ifNil: [ LocalTimeZone := TimeZone default ] ! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/17/2012 17:02'! fromUnixTime: anInteger ^ self fromSeconds: anInteger + 2177452800 "unix epoch constant"! ! !DateAndTime class methodsFor: 'input' stamp: 'SvenVanCaekenberghe 2/19/2014 19:37'! readFrom: aStream "Parse and return a new DateAndTime instance from stream, as a Date, an optional Time and an optional TimeZone offset. The time defaults to midnight, the timezone to the local offset" "self readFrom: '2013-03-04T23:47:52.876+01:00' readStream" | date time offset | date := Date readFrom: aStream. [ aStream atEnd or: [ '0123456789Z+-' includes: aStream peek ] ] whileFalse: [ aStream next ]. ('0123456789' includes: aStream peek) ifTrue: [ time := Time readFrom: aStream ] ifFalse: [ time := Time midnight ]. aStream skipSeparators. offset := self readTimezoneOffsetFrom: aStream. ^ self year: date year month: date monthIndex day: date dayOfMonth hour: time hour minute: time minute second: time second nanoSecond: time nanoSecond offset: offset! ! !DateAndTime class methodsFor: 'primitives' stamp: 'kph 12/11/2006 21:13'! millisecondClockValue ^ self clock millisecondClockValue! ! !DateAndTime class methodsFor: 'system queries' stamp: 'gk 8/31/2006 00:49'! clockPrecision "One nanosecond precision" ^ Duration seconds: 0 nanoSeconds: 1 ! ! !DateAndTime class methodsFor: 'clock provider' stamp: 'kph 12/11/2006 20:14'! clock "the provider of real time seconds/milliseconds." ^ ClockProvider ! ! !DateAndTime class methodsFor: 'input' stamp: 'SvenVanCaekenberghe 3/6/2013 16:34'! readTwoDigitIntegerFrom: stream "Parse and return a decimal number of 2 digits from stream. Fail if that is not possible" | integer | integer := 0. 2 timesRepeat: [ | char | char := stream next. ('0123456789' includes: char) ifFalse: [ self error: 'Decimal digit expected' ]. integer := (integer * 10) + char digitValue ]. ^ integer! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'SeanDeNigris 11/29/2013 14:30'! date: aDate time: aTime ^ self year: aDate year month: aDate monthName day: aDate dayOfMonth hour: aTime hour minute: aTime minute second: aTime second nanoSecond: aTime nanoSecond offset: self localOffset.! ! !DateAndTime class methodsFor: 'time zones' stamp: 'nk 3/30/2004 09:53'! localTimeZone: aTimeZone "Set the local time zone" " DateAndTime localTimeZone: (TimeZone offset: 0 hours name: 'Universal Time' abbreviation: 'UTC'). DateAndTime localTimeZone: (TimeZone offset: -8 hours name: 'Pacific Standard Time' abbreviation: 'PST'). " LocalTimeZone := aTimeZone ! ! !DateAndTime class methodsFor: 'input' stamp: 'StephaneDucasse 4/24/2010 11:46'! fuzzyReadFrom: aStream | bc year month day hour minute second nanos offset buffer ch | aStream peek = $- ifTrue: [ aStream next. bc := -1] ifFalse: [bc := 1]. year := (aStream upTo: $-) asInteger * bc. month := (aStream upTo: $-) asInteger ifNil: [1]. day := (aStream upTo: $T) asInteger ifNil: [1]. hour := (aStream upTo: $:) asInteger ifNil: [0]. buffer := '00:' copy. ch := nil. minute := buffer writeStream. [ aStream atEnd | (ch = $:) | (ch = $+) | (ch = $-) ] whileFalse: [ ch := minute nextPut: aStream next. ]. (ch isNil or: [ch isDigit]) ifTrue: [ ch := $: ]. minute := (buffer readStream upTo: ch) asInteger. buffer := '00.' copy. second := buffer writeStream. [ aStream atEnd | (ch = $.) | (ch = $+) | (ch = $-) ] whileFalse: [ ch := second nextPut: aStream next. ]. (ch isNil or: [ch isDigit]) ifTrue: [ ch := $. ]. second := (buffer readStream upTo: ch) asInteger. buffer := '000000000' copy. (ch = $.) ifTrue: [ nanos := buffer writeStream. [ aStream atEnd | ((ch := aStream next) = $+) | (ch = $-) ] whileFalse: [ nanos nextPut: ch. ]. (ch isNil or: [ch isDigit]) ifTrue: [ ch := $+ ]. ]. nanos := buffer asInteger. aStream atEnd ifTrue: [ offset := Duration zero ] ifFalse: [ch := aStream next. ch = $+ ifTrue: [ch := Character space]. offset := Duration fromString: ch asString, '0:', aStream upToEnd, ':0']. ^ self year: year month: month day: day hour: hour minute: minute second: second nanoSecond: nanos offset: offset. ! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'sd 3/16/2008 15:00'! year: year month: month day: day hour: hour minute: minute second: second offset: offset ^ self year: year month: month day: day hour: hour minute: minute second: second nanoSecond: 0 offset: offset ! ! !DateAndTime class methodsFor: 'system queries' stamp: 'sd 3/16/2008 15:07'! localOffset "Answer the duration we are offset from UTC" ^ self localTimeZone offset ! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'GabrielBarbuto 9/27/2010 10:10'! dosEpoch "Answer a DateAndTime representing the DOS epoch (1 January 1980, midnight UTC)" ^ self basicNew ticks: #(2444240 0 0) offset: Duration zero; yourself.! ! !DateAndTime class methodsFor: '*Fuel' stamp: 'MaxLeske 2/18/2013 22:36'! materializeFrom: aDecoder ^ self basicNew fuelSet: aDecoder nextEncodedUint32 nanoSecond: aDecoder nextEncodedUint32 seconds: aDecoder nextEncodedInt24 offset: (Duration seconds: aDecoder nextEncodedInt24 nanoSeconds: aDecoder nextEncodedInt32); yourself.! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'sd 3/16/2008 14:59'! year: year day: dayOfYear hour: hour minute: minute second: second offset: offset "Return a DataAndTime" | y d | y := self year: year month: 1 day: 1 hour: hour minute: minute second: second nanoSecond: 0 offset: offset. d := Duration days: (dayOfYear - 1). ^ y + d! ! !DateAndTime class methodsFor: 'initialize-release' stamp: 'SvenVanCaekenberghe 5/3/2013 15:24'! initialize ClockProvider := Time! ! !DateAndTime class methodsFor: 'input' stamp: 'SvenVanCaekenberghe 3/6/2013 16:33'! readTimezoneOffsetFrom: stream "Read and return an optional timezone offset in the form of [+|-]hh[[separator]mm[[separator]ss]] or Z from stream as a duration. If there is no offset, return the local offset." | sign hour minute second | (stream peekFor: $Z) ifTrue: [ ^ Duration zero ]. hour := minute := second := 0. ^ ('+-' includes: stream peek) ifTrue: [ sign := stream next = $- ifTrue: [ -1 ] ifFalse: [ 1 ]. hour := self readTwoDigitIntegerFrom: stream. (self readOptionalSeparatorFrom: stream) ifNotNil: [ minute := self readTwoDigitIntegerFrom: stream. (self readOptionalSeparatorFrom: stream) ifNotNil: [ second := Integer readFrom: stream ] ]. Duration seconds: sign * ((hour * 3600) + (minute * 60) + second) ] ifFalse: [ self localOffset ]! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'sd 3/16/2008 15:08'! tomorrow ^ self today asDate next asDateAndTime! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 5/3/2013 15:38'! now "Answer the current date and time expressed in local time. [ 10000 timesRepeat: [ self now. ] ] timeToRun / 10000.0 . " | nanoTicks | nanoTicks := self clock microsecondClockValue * 1e3. ^ self basicNew setJdn: SqueakEpoch seconds: 0 nano: nanoTicks offset: self localOffset! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'sd 3/16/2008 15:08'! year: year day: dayOfYear "Return a DateAndTime" ^ self year: year day: dayOfYear hour: 0 minute: 0 second: 0! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 12/22/2013 16:29'! fromMethodTimeStamp: aString | stream | stream := aString readStream. stream skipSeparators; skipTo: Character space. ^ self readSeparateDateAndTimeFrom: stream! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/13/2012 20:42'! year: year month: month day: day offset: anOffset "Return a DateAndTime, midnight in the timezone with the given offset" ^ self year: year month: month day: day hour: 0 minute: 0 offset: anOffset ! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'sd 3/16/2008 15:09'! yesterday ^ self today asDate previous asDateAndTime ! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'MarcusDenker 7/1/2010 14:30'! unixEpoch "Answer a DateAndTime representing the Unix epoch (1 January 1970, midnight UTC)" ^ self basicNew ticks: #(2440588 0 0) offset: Duration zero; yourself.! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'HenrikSperreJohansen 10/15/2009 14:44'! year: year month: month day: day "Return a DateAndTime, midnight local time" ^ self year: year month: month day: day hour: 0 minute: 0! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'HenrikSperreJohansen 10/15/2009 14:44'! year: year month: month day: day hour: hour minute: minute "Return a DateAndTime" ^ self year: year month: month day: day hour: hour minute: minute second: 0! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'sd 3/16/2008 15:08'! today ^ self midnight ! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'CamilloBruni 7/17/2012 17:04'! epoch "Answer a DateAndTime representing the Squeak epoch: 1 January 1901" ^ (self julianDayNumber: SqueakEpoch) offset: 0. ! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/13/2012 20:43'! year: year month: month day: day hour: hour minute: minute offset: anOffset "Return a DateAndTime" ^ self year: year month: month day: day hour: hour minute: minute second: 0 offset: anOffset! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'sd 3/16/2008 14:59'! year: year month: month day: day hour: hour minute: minute second: second "Return a DateAndTime" ^ self year: year month: month day: day hour: hour minute: minute second: second offset: self localOffset ! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/17/2012 17:16'! julianDayNumber: aJulianDayNumber offset: aTimeZoneOffset "Return a DateAndTime at midnight local time at the given julian day" | ticks | "create a ticks representation in UTC, take the given julian day in local time" ticks := aJulianDayNumber days ticks. ticks at: 2 put: aTimeZoneOffset asSeconds negated. ^ self basicNew ticks: ticks offset: aTimeZoneOffset; yourself! ! !DateAndTime class methodsFor: '*Spec-Inspector' stamp: 'SvenVanCaekenberghe 12/21/2013 21:31'! inspectorClass ^ EyeDateAndTimeInspector! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'sd 3/16/2008 15:08'! noon ^ self now noon! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/16/2012 19:24'! new "Answer a DateAndTime representing the Squeak epoch: 1 January 1901" ^ self epoch offset: self localOffset ! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'sd 3/16/2008 14:59'! year: year day: dayOfYear hour: hour minute: minute second: second ^ self year: year day: dayOfYear hour: hour minute: minute second: second offset: self localOffset. ! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/17/2012 16:59'! fromSeconds: secondsSinceEpochUTC "Answer a DateAndTime since the Squeak epoch: 1 January 1901 for the seconds in UTC time" ^ self fromSeconds: secondsSinceEpochUTC offset: self localOffset! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'sd 3/16/2008 15:07'! midnight ^ self now midnight ! ! !DateAndTime class methodsFor: 'system queries' stamp: 'SvenVanCaekenberghe 5/3/2013 15:39'! totalSeconds "Answer the total seconds ellapsed since the Squeak epoch: 1 January 1901" ^ self clock totalSeconds! ! !DateAndTime class methodsFor: 'input' stamp: 'SvenVanCaekenberghe 11/18/2013 16:19'! readSeparateDateAndTimeFrom: stream "Read a separate Date and Time from stream to instanciate the receiver. See also #printSeparateDateAndTimeOn:" | date time | stream skipSeparators. date := Date readFrom: stream. stream skipSeparators. time := Time readFrom: stream. ^ self date: date time: time! ! !DateAndTime class methodsFor: 'input' stamp: 'damiencassou 5/30/2008 10:56'! fromString: aString ^ self readFrom: aString readStream! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'SeanDeNigris 5/21/2012 17:00'! fromDosTimestamp: anInteger ^ (DosTimestamp on: anInteger) asDateAndTime.! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'sd 3/16/2008 15:07'! current ^ self now ! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/17/2012 16:57'! fromSeconds: utcSecondsSinceEpoch offset: aUTCOffset "Answer a DateAndTime since the Squeak epoch: 1 January 1901 for the given timeZone" | integerSeconds nanos | integerSeconds := utcSecondsSinceEpoch truncated. integerSeconds = utcSecondsSinceEpoch ifTrue: [nanos := 0] ifFalse: [nanos := (utcSecondsSinceEpoch - integerSeconds * NanosInSecond) asInteger]. ^ self basicNew ticks: (Array with: SqueakEpoch with: integerSeconds with: nanos) offset: aUTCOffset asDuration! ! !DateAndTime class methodsFor: 'input' stamp: 'SvenVanCaekenberghe 3/6/2013 16:22'! readOptionalSeparatorFrom: stream "Read an optional separator (non decimal digit) from stream and return it. Return nil if nothing was read" ^ (stream atEnd or: [ '0123456789' includes: stream peek]) ifTrue: [ nil ] ifFalse: [ stream next ]! ! !DateAndTimeDosEpochTest commentStamp: 'TorstenBergmann 2/5/2014 08:32'! SUnit test for dos epoch (see DateAndTime)! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:35'! testMiddleOf self assert: (aDateAndTime middleOf: '2:00:00:00' asDuration) = (Timespan starting: '12-31-1979' asDate duration: 2 days). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:34'! testHash self assert: aDateAndTime hash = (DateAndTime year: 1980 month: 1 day: 1) hash! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testMinute self assert: aDateAndTime minute = 0 ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testToByDo "self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days do: []) = " "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testDaysInMonth self assert: aDateAndTime daysInMonth = 31. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:33'! testDateTime self assert: aDateAndTime = (DateAndTime date: '01-01-1980' asDate time: '00:00:00' asTime) ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:34'! testFromSeconds self assert: aDateAndTime = (DateAndTime fromSeconds: 2492985600). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsDateAndTime self assert: aDateAndTime asDateAndTime = aDateAndTime ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:32'! testAsSeconds self assert: aDateAndTime asSeconds = 2492985600 ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testDay self assert: aDateAndTime day = DateAndTime new day ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:33'! testAsYear self assert: aDateAndTime asYear = (Year starting: '01-01-1980' asDate). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:38'! testYearDay self assert: aDateAndTime = (DateAndTime year: 1980 day: 1). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testToday self deny: aDateAndTime = (DateAndTime today). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:33'! testDayMonthYearDo |iterations| iterations := 0. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | iterations := iterations + 1]) = 1. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachYear]) = 1980. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachMonth]) = 1. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachDay]) = 1. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testCurrent self deny: aDateAndTime = (DateAndTime current). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:32'! testAsWeek self assert: aDateAndTime asWeek = (Week starting: '12-31-1979' asDate). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testMonth self assert: aDateAndTime month = 1. self assert: aDateAndTime monthAbbreviation = 'Jan'. self assert: aDateAndTime monthName = 'January'. self assert: aDateAndTime monthIndex = 1.! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:37'! testTo self assert: (aDateAndTime to: aDateAndTime) = ((DateAndTime year: 1980 month: 1 day: 1) to: (DateAndTime year: 1980 month: 1 day: 1)) "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:36'! testPrintOn | cs rw | cs := '1980-01-01T00:00:00+00:00' readStream. rw := ReadWriteStream on: ''. aDateAndTime printOn: rw. self assert: rw contents = cs contents. cs := 'a TimeZone(DTZ)' readStream. rw := ReadWriteStream on: ''. aTimeZone printOn: rw. self assert: rw contents = cs contents! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testDayOfYear self assert: aDateAndTime dayOfYear = 1. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:36'! testPlus self assert: aDateAndTime + '0:00:00:00' = aDateAndTime. self assert: aDateAndTime + 0 = aDateAndTime. self assert: aDateAndTime + aDuration = (DateAndTime year: 1980 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:37'! testYear self assert: aDateAndTime year = 1980. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:38'! testYearMonthDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1980 month: 1 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testTommorrow self assert: (DateAndTime today + 24 hours) = (DateAndTime tomorrow). self deny: aDateAndTime = (DateAndTime tomorrow). "MessageNotUnderstood: Date class>>starting:"! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testHour12 self assert: aDateAndTime hour12 = DateAndTime new hour12. self assert: aDateAndTime hour12 = 12 ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:37'! testToBy self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days) = ((DateAndTime year: 1980 month: 1 day: 1) to: (DateAndTime year: 1980 month: 1 day: 1) + 10 days by: 5 days ) "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testMinutes self assert: aDateAndTime minutes = 0 ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'AM'. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:36'! testMinus self assert: aDateAndTime - aDateAndTime = '0:00:00:00' asDuration. self assert: aDateAndTime - '0:00:00:00' asDuration = aDateAndTime. self assert: aDateAndTime - aDuration = (DateAndTime year: 1979 month: 12 day: 30 hour: 21 minute: 56 second: 55 nanoSecond: 999999995 offset: 0 hours ). " I believe this Failure is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 19:15'! testUtcOffset self assert: (aDateAndTime offset: '0:12:00:00') equals: '1980-01-01T12:00:00+12:00' asDateAndTime! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:38'! testTicks self assert: aDateAndTime ticks = (DateAndTime julianDayNumber: 2444240) ticks. self assert: aDateAndTime ticks = #(2444240 0 0)! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testFirstDayOfMonth self assert: aDateAndTime firstDayOfMonth = 1 ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testHour self assert: aDateAndTime hour = aDateAndTime hour24. self assert: aDateAndTime hour = 0. self assert: aDateAndTime hour = aDateAndTime hours ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testDuration self assert: aDateAndTime duration = 0 asDuration. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = 0 asDuration asNanoSeconds ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testMidnight self assert: aDateAndTime midnight = aDateAndTime ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsDate self assert: aDateAndTime asDate = 'January 1, 1980' asDate. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:33'! testDaysInYear self assert: aDateAndTime daysInYear = 366. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:35'! testIsLeapYear self assert: aDateAndTime isLeapYear ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:35'! testJulianDayNumber self assert: aDateAndTime = (DateAndTime julianDayNumber: 2444240). self assert: aDateAndTime julianDayNumber = 2444240.! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:37'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2444240 0 0) offset: DateAndTime localOffset). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 19:19'! testOffset self assert: aDateAndTime offset = '0:00:00:00' asDuration. self assert: (aDateAndTime offset: '-0:12:00:00') equals: '1979-12-31T12:00:00-12:00' asDateAndTime. self assert: (aDateAndTime offset: '0:12:00:00') equals: '1980-01-01T12:00:00+12:00' asDateAndTime! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testYesterday self deny: aDateAndTime = (DateAndTime yesterday). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:53'! testTimeZone self assert: aDateAndTime timeZoneName = 'Universal Time'. self assert: aDateAndTime timeZoneAbbreviation = 'UTC' ! ! !DateAndTimeDosEpochTest methodsFor: 'running' stamp: 'CamilloBruni 7/13/2012 19:12'! tearDown "wish I could remove the time zones I added earlier, but there is no method for that" DateAndTime localTimeZone: localTimeZoneToRestore. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:38'! testYearMonthDayHourMinuteSecondNanosSecondOffset self assert: aDateAndTime = (DateAndTime year: 1980 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset:0 hours ). self assert: ((DateAndTime year: 1 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset: 0 hours ) + (Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5) ) = (DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)"" I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 8/22/2013 19:44'! testAsMonth self assert: aDateAndTime asMonth equals: (Month year: 1980 month: 'January'). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:33'! testDayOfWeek self assert: aDateAndTime dayOfWeek = 3. self assert: aDateAndTime dayOfWeekAbbreviation = 'Tue'. self assert: aDateAndTime dayOfWeekName = 'Tuesday'. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsDuration self assert: aDateAndTime asDuration = 0 asDuration ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:36'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime offset: aDateAndTime class localOffset) ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsTime self assert: aDateAndTime asTime = Time midnight. ! ! !DateAndTimeDosEpochTest methodsFor: 'running' stamp: 'CamilloBruni 7/13/2012 19:11'! setUp localTimeZoneToRestore := DateAndTime localTimeZone. aDateAndTime := DateAndTime localTimeZone: TimeZone default; dosEpoch. aTimeZone := TimeZone offset: (Duration minutes: 135) name: 'DOS Epoch Test Time Zone' abbreviation: 'DTZ'. aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 1. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:34'! testFromString self assert: aDateAndTime = (DateAndTime fromString: ' 1980-01-01T00:00:00+00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1980-01-01T00:00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1980-01-01T00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1980-01-01T00:00:00+00:00'). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:38'! testYearDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1980 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testNow self deny: aDateAndTime = (DateAndTime now). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:34'! testEpoch self assert: aDateAndTime = '1980-01-01T00:00:00+00:00' asDateAndTime ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:32'! testAsTimeStamp self assert: aDateAndTime asTimeStamp = (TimeStamp fromString: '1 January 1980 12:00 am').! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:36'! testNoon self assert: aDateAndTime noon = '1980-01-01T12:00:00+00:00' asDateAndTime! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:38'! testYearMonthDay self assert: aDateAndTime = (DateAndTime year: 1980 month: 1 day: 1). ! ! !DateAndTimeDosEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:34'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 365. ! ! !DateAndTimeEpochTest commentStamp: 'tlk 1/6/2004 18:27'! I represent one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. The other Chronology sunit test cases are: DateTestCase DateAndTimeLeapTestCase, DurationTestCase, ScheduleTestCase TimeStampTestCase TimespanDoTestCase, TimespanDoSpanAYearTestCase, TimespanTestCase, YearMonthWeekTestCase. These tests attempt to exercise all public and private methods. Except, they do not explicitly depreciated methods. tlk My fixtures are: aDateAndTime = January 01, 1901 midnight (the start of the Squeak epoch) with localTimeZone = Grenwhich Meridian (local offset = 0 hours) aDuration = 1 day, 2 hours, 3, minutes, 4 seconds and 5 nano seconds. aTimeZone = 'Epoch Test Time Zone', 'ETZ' , offset: 12 hours, 15 minutes. ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/2/2004 11:07'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 12:37'! testMiddleOf self assert: (aDateAndTime middleOf: '2:00:00:00' asDuration) = (Timespan starting: '12-31-1900' asDate duration: 2 days). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'al 6/12/2008 21:56'! testHash self assert: aDateAndTime hash = DateAndTime new hash! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 19:35'! testMinute self assert: aDateAndTime minute = 0 ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 20:53'! testToByDo "self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days do: []) = " "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 14:02'! testDaysInMonth self assert: aDateAndTime daysInMonth = 31. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 09:46'! testDateTime self assert: aDateAndTime = (DateAndTime date: '01-01-1901' asDate time: '00:00:00' asTime) ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 12:25'! testFromSeconds self assert: aDateAndTime = (DateAndTime fromSeconds: 0). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 13:31'! testAsDateAndTime self assert: aDateAndTime asDateAndTime = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 14:01'! testAsSeconds self assert: aDateAndTime asSeconds = 0 asDuration asSeconds ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 14:01'! testDay self assert: aDateAndTime day = DateAndTime new day ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 09:43'! testAsYear self assert: aDateAndTime asYear = (Year starting: '01-01-1901' asDate). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 12:30'! testYearDay self assert: aDateAndTime = (DateAndTime year: 1901 day: 1). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 17:35'! testToday self deny: aDateAndTime = (DateAndTime today). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 20:22'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/2/2004 11:08'! testDayMonthYearDo |iterations| iterations := 0. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | iterations := iterations + 1]) = 1. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachYear]) = 1901. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachMonth]) = 1. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachDay]) = 1. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 12:28'! testCurrent self deny: aDateAndTime = (DateAndTime current). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'brp 1/16/2004 13:43'! testAsWeek self assert: aDateAndTime asWeek = (Week starting: '12-31-1900' asDate). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 19:46'! testMonth self assert: aDateAndTime month = 1. self assert: aDateAndTime monthAbbreviation = 'Jan'. self assert: aDateAndTime monthName = 'January'. self assert: aDateAndTime monthIndex = 1.! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/3/2004 11:42'! testTo self assert: (aDateAndTime to: aDateAndTime) = (DateAndTime new to: DateAndTime new) "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'damiencassou 5/30/2008 11:09'! testPrintOn | cs rw | cs := '1901-01-01T00:00:00+00:00' readStream. rw := ReadWriteStream on: ''. aDateAndTime printOn: rw. self assert: rw contents = cs contents. cs := 'a TimeZone(ETZ)' readStream. rw := ReadWriteStream on: ''. aTimeZone printOn: rw. self assert: rw contents = cs contents! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 14:01'! testDayOfYear self assert: aDateAndTime dayOfYear = 1. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 19:47'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 11:03'! testPlus self assert: aDateAndTime + '0:00:00:00' = aDateAndTime. self assert: aDateAndTime + 0 = aDateAndTime. self assert: aDateAndTime + aDuration = (DateAndTime year: 1901 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 21:00'! testYear self assert: aDateAndTime year = 1901. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 12:31'! testYearMonthDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/3/2004 11:45'! testTommorrow self assert: (DateAndTime today + 24 hours) = (DateAndTime tomorrow). self deny: aDateAndTime = (DateAndTime tomorrow). "MessageNotUnderstood: Date class>>starting:"! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'brp 3/12/2004 15:21'! testHour12 self assert: aDateAndTime hour12 = DateAndTime new hour12. self assert: aDateAndTime hour12 = 12 ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/3/2004 11:43'! testToBy self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days) = (DateAndTime new to: DateAndTime new + 10 days by: 5 days ) "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'brp 1/16/2004 13:41'! testMinutes self assert: aDateAndTime minutes = 0 ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 10:40'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'AM'. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 14:03'! testMinus self assert: aDateAndTime - aDateAndTime = '0:00:00:00' asDuration. self assert: aDateAndTime - '0:00:00:00' asDuration = aDateAndTime. self assert: aDateAndTime - aDuration = (DateAndTime year: 1900 month: 12 day: 30 hour: 21 minute: 56 second: 55 nanoSecond: 999999995 offset: 0 hours ). " I believe this Failure is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:36'! testUtcOffset self assert: (aDateAndTime offset: '0:12:00:00') = '1901-01-01T12:00:00+12:00' asDateAndTime! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 20:25'! testTicks self assert: aDateAndTime ticks = (DateAndTime julianDayNumber: 2415386) ticks. self assert: aDateAndTime ticks = #(2415386 0 0)! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 10:44'! testFirstDayOfMonth self assert: aDateAndTime firstDayOfMonth = 1 ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 16:59'! testHour self assert: aDateAndTime hour = aDateAndTime hour24. self assert: aDateAndTime hour = 0. self assert: aDateAndTime hour = aDateAndTime hours ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 16:24'! testDuration self assert: aDateAndTime duration = 0 asDuration. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 20:22'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 13:59'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = 0 asDuration asNanoSeconds ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 17:39'! testMidnight self assert: aDateAndTime midnight = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 14:01'! testAsDate self assert: aDateAndTime asDate = 'January 1, 1901' asDate. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 14:02'! testDaysInYear self assert: aDateAndTime daysInYear = 365. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 14:02'! testIsLeapYear self deny: aDateAndTime isLeapYear ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 17:18'! testJulianDayNumber self assert: aDateAndTime = (DateAndTime julianDayNumber: 2415386). self assert: aDateAndTime julianDayNumber = 2415386.! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 20:31'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2415386 0 0) offset: DateAndTime localOffset). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 19:21'! testOffset self assert: aDateAndTime offset = '0:00:00:00' asDuration. self assert: (aDateAndTime offset: '-0:12:00:00') equals: '1900-12-31T12:00:00-12:00' asDateAndTime. self assert: (aDateAndTime offset: '0:12:00:00') equals: '1901-01-01T12:00:00+12:00' asDateAndTime! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 09:47'! testYesterday self deny: aDateAndTime = (DateAndTime yesterday). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:52'! testTimeZone self assert: aDateAndTime timeZoneName = 'Universal Time'. self assert: aDateAndTime timeZoneAbbreviation = 'UTC' ! ! !DateAndTimeEpochTest methodsFor: 'running' stamp: 'tlk 1/2/2004 11:04'! tearDown DateAndTime localTimeZone: localTimeZoneToRestore. "wish I could remove the time zones I added earlier, tut there is no method for that" ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 12:23'! testYearMonthDayHourMinuteSecondNanosSecondOffset self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset:0 hours ). self assert: ((DateAndTime year: 1 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset: 0 hours ) + (Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5) ) = (DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)"" I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 8/22/2013 19:44'! testAsMonth self assert: aDateAndTime asMonth equals: (Month year: 1901 month: 'January'). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 10:47'! testDayOfWeek self assert: aDateAndTime dayOfWeek = 3. self assert: aDateAndTime dayOfWeekAbbreviation = 'Tue'. self assert: aDateAndTime dayOfWeekName = 'Tuesday'. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 13:34'! testAsDuration self assert: aDateAndTime asDuration = 0 asDuration ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:36'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime offset: aDateAndTime class localOffset) ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 09:32'! testAsTime self assert: aDateAndTime asTime = Time midnight. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 15:45'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 1. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 12:26'! testFromString self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00'). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 12:27'! testNew self assert: aDateAndTime = (DateAndTime new). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 12:31'! testYearDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1901 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeEpochTest methodsFor: 'running' stamp: 'tlk 1/2/2004 10:58'! setUp localTimeZoneToRestore := DateAndTime localTimeZone. aDateAndTime := DateAndTime localTimeZone: TimeZone default; epoch. aTimeZone := TimeZone offset: (Duration minutes: 135) name: 'Epoch Test Time Zone' abbreviation: 'ETZ'. aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 12:28'! testNow self deny: aDateAndTime = (DateAndTime now). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'cmm 6/14/2010 17:19'! testEpoch self assert: aDateAndTime = '1901-01-01T00:00:00+00:00' asDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 13:20'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 14:51'! testAsTimeStamp self assert: aDateAndTime asTimeStamp = TimeStamp new. ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'cmm 6/14/2010 17:19'! testNoon self assert: aDateAndTime noon = '1901-01-01T12:00:00+00:00' asDateAndTime! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/1/2004 12:31'! testYearMonthDay self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1). ! ! !DateAndTimeEpochTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 14:02'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 364. ! ! !DateAndTimeLeapTest commentStamp: 'tlk 1/6/2004 17:54'! I represent one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. tlk. My fixtures are: aDateAndTime = February 29, 2004 1:33 PM with offset: 2 hours aDuration = 15 days, 14 hours, 13 minutes, 12 seconds and 11 nano seconds. aTimeZone = Grenwhich Meridian (local offset = 0 hours) ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 13:59'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:36'! testUtcOffset self assert: (aDateAndTime offset: '0:02:00:00') = '2004-02-29T13:33:00+02:00' asDateAndTime! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 13:12'! testMiddleOf self assert: (aDateAndTime middleOf: aDuration) = (Timespan starting: (DateAndTime year: 2004 month: 2 day: 29 hour: 6 minute: 46 second: 30 offset: 2 hours) duration: (Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0 )) ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/3/2004 11:00'! testMinute self assert: aDateAndTime minute = 33 ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 13:58'! testDaysInMonth self assert: aDateAndTime daysInMonth = 29. ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/17/2012 17:05'! testTicks self assert: aDateAndTime ticks equals: ((DateAndTime julianDayNumber: 2453065) + 41580 seconds) ticks. self assert: aDateAndTime ticks equals: #(2453065 41580 0)! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/17/2012 17:09'! testAsSeconds self assert: aDuration asSeconds = 48780. self assert: aDateAndTime asSeconds = 3255507180. ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 13:23'! testDay self assert: aDateAndTime day = 60. self deny: aDateAndTime day = 29 ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 13:38'! testFirstDayOfMonth self deny: aDateAndTime firstDayOfMonth = 1. self assert: aDateAndTime firstDayOfMonth = 32 ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 8/22/2013 20:05'! testAsYear "A year always starts at January 1" self assert: aDateAndTime asYear equals: ((Year starting: '02-29-2004' asDate) translateTo: 2 hours ). self assert: aDateAndTime asYear equals: ((Year starting: '01-01-2004' asDate) translateTo: 2 hours) ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:53'! testHour self assert: aDateAndTime hour equals: aDateAndTime hour24. self assert: aDateAndTime hour equals: 13. self assert: aDateAndTime hour equals: aDateAndTime hours ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/2/2004 21:30'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/2/2004 21:59'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = aDuration asNanoSeconds. self assert: aDateAndTime asNanoSeconds = 48780000000000 ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 13:52'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2453065 48780 0) offset: DateAndTime localOffset). ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 20:56'! testMidnight self assert: aDateAndTime midnight equals: '2004-02-29T00:00:00+02:00' asDateAndTime. ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 13:58'! testDaysInYear self assert: aDateAndTime daysInYear = 366. ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 13:35'! testIsLeapYear self assert: aDateAndTime isLeapYear ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 21:08'! testAsDate self assert: aDateAndTime asDate equals: ('February 29, 2004' asDate translateTo: 2 hours).! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/2/2004 21:30'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 19:24'! testOffset self assert: aDateAndTime offset = '0:02:00:00' asDuration. self assert: (aDateAndTime offset: '-0:12:00:00') equals: '2004-02-28T23:33:00-12:00' asDateAndTime. self assert: (aDateAndTime offset: '0:12:00:00') equals: '2004-02-29T23:33:00+12:00' asDateAndTime! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 20:59'! testTimeZone aDateAndTime := '2004-02-29T13:33:00+00:00' asDateAndTime. self assert: aDateAndTime timeZone name equals: 'Universal Time'. self assert: aDateAndTime timeZone abbreviation equals: 'UTC' ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/2/2004 22:16'! testDayMonthYearDo self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachYear]) = 2004. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachMonth]) = 2. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachDay]) = 29. ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 8/22/2013 19:44'! testAsMonth self assert: aDateAndTime asMonth equals: (Month year: 2004 month: 'February'). ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 21:09'! testAsWeek self assert: aDateAndTime asWeek equals: ((Week starting: '02-29-2004' asDate) translateTo: 2 hours). ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 19:25'! testAsDuration self assert: aDateAndTime asDuration equals: aDuration ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:36'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime offset: aDateAndTime class localOffset) ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 19:26'! testAsTime self assert: aDateAndTime asTime equals: (Time hour: 13 minute: 33 second: 0) ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/2/2004 22:17'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 29. ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 13:34'! testDayOfWeek self assert: aDateAndTime dayOfWeek = 1. self assert: aDateAndTime dayOfWeekAbbreviation = 'Sun'. self assert: aDateAndTime dayOfWeekName = 'Sunday'. ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/3/2004 10:43'! testFromString self assert: aDateAndTime = (DateAndTime fromString: ' 2004-02-29T13:33:00+02:00'). ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 13:59'! testDayOfYear self assert: aDateAndTime dayOfYear = 60. ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/3/2004 11:02'! testMonth self assert: aDateAndTime month = 2. self assert: aDateAndTime monthAbbreviation = 'Feb'. self assert: aDateAndTime monthName = 'February'. self assert: aDateAndTime monthIndex = 2.! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'damiencassou 5/30/2008 11:09'! testPrintOn | cs rw | cs := '2004-02-29T13:33:00+02:00' readStream. rw := ReadWriteStream on: ''. aDateAndTime printOn: rw. self assert: rw contents = cs contents. cs := 'a TimeZone(UTC)' readStream. rw := ReadWriteStream on: ''. aTimeZone printOn: rw. self assert: rw contents = cs contents! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/2/2004 21:30'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 19:36'! testYearDayHourMinuteSecond self assert: aDateAndTime equals: (DateAndTime year: 2004 day: 60 hour: 13 minute: 33 second: 0 offset: 2 hours). ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/3/2004 11:17'! testYear self assert: aDateAndTime year = 2004. ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/2/2004 21:30'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 19:36'! testYearMonthDayHourMinuteSecond self assert: aDateAndTime equals: (DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0 offset: 2 hours). ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'brp 3/12/2004 15:19'! testHour12 self assert: aDateAndTime hour12 = 1. ! ! !DateAndTimeLeapTest methodsFor: 'running' stamp: 'CamilloBruni 7/17/2012 17:05'! setUp aDateAndTime := (DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0 offset: 2 hours). aTimeZone := TimeZone default. aDuration := Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0 ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/16/2012 19:22'! testAsTimeStamp self assert: aDateAndTime asTimeStamp "note that the timestamp string is written in UTC" equals: ((TimeStamp readFrom: '2-29-2004 1:33 pm' readStream) translateTo: 2 hours) ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'CamilloBruni 7/16/2012 19:22'! testNoon self assert: aDateAndTime noon equals: '2004-02-29T12:00:00+02:00' asDateAndTime! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'brp 1/16/2004 13:44'! testMinutes self assert: aDateAndTime minutes = 33 ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 10:42'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'PM'. ! ! !DateAndTimeLeapTest methodsFor: 'tests' stamp: 'tlk 1/4/2004 13:58'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 306. ! ! !DateAndTimeTest commentStamp: 'TorstenBergmann 2/5/2014 08:33'! SUnit tests for date and time! !DateAndTimeTest methodsFor: 'tests' stamp: 'BG 11/7/2004 12:18'! testTimeZoneEquivalence "DateAndTimeTest new testTimeZoneEquivalence" "When the clock on the wall in Detroit says 9:00am, the clock on the wall in London says 2:00pm. The Duration difference between the corresponding DateAndTime values should be zero." " Detroit is 5 hours behind UTC, this offset to UTC is therefore written with a minus sign. This example tests both the correct interpretation of the DateAndTime denotation and correct DateAndTime arithmetics. " | twoPmInLondon nineAmInDetroit durationDifference | twoPmInLondon := '2004-11-02T14:00:00+00:00' asDateAndTime. nineAmInDetroit := '2004-11-02T09:00:00-05:00' asDateAndTime. durationDifference := twoPmInLondon - nineAmInDetroit. self assert: durationDifference asSeconds = 0. self assert: twoPmInLondon = nineAmInDetroit ! ! !DateAndTimeTest methodsFor: 'tests - instance' stamp: 'brp 1/7/2004 15:37'! testInstanceCreation | t | t := DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. self assert: (t julianDayNumber = 1721427); assert: (t offset = 6 hours); assert: (t hour = 2); assert: (t minute = 3); assert: (t second = 4); assert: (t nanoSecond = 5). ! ! !DateAndTimeTest methodsFor: 'tests - arithmetic' stamp: 'StephaneDucasse 4/23/2010 21:07'! testArithmeticAcrossDateBoundary | t1 t2 | t1 := '2004-01-07T11:55:00+00:00' asDateAndTime. t2 := t1 - ( (42900+1) seconds). self assert: t2 = ('2004-01-06T23:59:59+00:00' asDateAndTime) ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 17:24'! testCreationWithOffsets | dt1 dt2 | dt1 := (DateAndTime year: 2222 month: 1 day: 22 hour: 1 minute: 22 second: 33 offset: 0 hours). dt2 := (DateAndTime year: 2222 month: 1 day: 22 hour: 1 minute: 22 second: 33 offset: 2 hours). "The timepoints are diffferent, AKA their UTC times don't correspond" self deny: dt1 = dt2. "The relative components however are equal" self assert: dt1 year equals: dt2 year. self assert: dt1 month equals: dt2 month. self assert: dt1 day equals: dt2 day. self assert: dt1 hours equals: dt2 hours. self assert: dt1 minutes equals: dt2 minutes. self assert: dt1 seconds equals: dt2 seconds.! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:36'! testDateTimeDenotation1 "DateAndTimeTest new testDateTimeDenotation1" "Detroit is 5 hours behind UTC, this offset to UTC is therefore written with a minus sign. This example tests the correct interpretation of the DateAndTime denotation. " | twoPmInLondon twoPmUTCInLocalTimeOfDetroit nineAmInDetroit | twoPmInLondon := DateAndTime year: 2004 month: 11 day: 2 hour: 14 minute: 0 second: 0 offset: 0 hours. twoPmUTCInLocalTimeOfDetroit := twoPmInLondon offset: -5 hours. nineAmInDetroit := '2004-11-02T09:00:00-05:00' asDateAndTime. self assert: twoPmUTCInLocalTimeOfDetroit = nineAmInDetroit. ! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'StephaneDucasse 4/23/2010 22:08'! testSymmetric | t1 t2 | t1 := DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. t2 := DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. self assert: (t2 = t1) = (t1 = t2). ! ! !DateAndTimeTest methodsFor: 'tests - epoch' stamp: 'SeanDeNigris 6/20/2012 00:50'! testSecondsAcrossTimeZones | dateTime seconds dateTime2 utc | dateTime := '1/15/2012 0000+00:00' asDateAndTime. utc := TimeZone abbreviated: 'UTC'. self useTimeZone: 'PDT' during: [ :pdt | "Store a DateAndTime as seconds from the epoch" seconds := dateTime asSeconds. "Now move to Greenwich" DateAndTime localTimeZone: utc. dateTime2 := DateAndTime fromSeconds: seconds. self assert: dateTime equals: dateTime2 ].! ! !DateAndTimeTest methodsFor: 'tests - epoch' stamp: 'PavelKrivanek 7/8/2012 19:46'! testDosEpoch self useNonUtcTimeZoneDuring: [ | localEpoch | localEpoch := '1 January 1980 00:00' asDateAndTime. self deny: (DateAndTime dosEpoch = localEpoch) ]. self useTimeZone: 'UTC' during: [ | localEpoch | localEpoch := '1 January 1980 00:00' asDateAndTime. self assert: DateAndTime dosEpoch equals: localEpoch ]. self assert: DateAndTime dosEpoch equals: '1980-01-01T00:00:00+00:00' asDateAndTime.! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'StephaneDucasse 4/23/2010 21:46'! testMonotonicity | t1 t2 t3 t4 | t1 := DateAndTime now. t2 := DateAndTime now. (Delay forMilliseconds: 1000) wait. t3 := DateAndTime now. t4 := DateAndTime now. self assert: (t1 <= t2); assert: (t2 < t3); assert: (t3 <= t4). ! ! !DateAndTimeTest methodsFor: 'coverage' stamp: 'brp 9/25/2003 09:25'! classToBeTested ^ DateAndTime ! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'CamilloBruni 7/13/2012 20:02'! testReadFromSecond "self debug: #testReadFromSecond" self assert: ('-1199-01-05T20:33:14.321-05:00' asDateAndTime printString = '-1199-01-05T20:33:14.321-05:00'). self assert: ('2002-05-16T17:20:45.1+01:01' asDateAndTime printString = '2002-05-16T17:20:45.1+01:01'). self assert: (' 2002-05-16T17:20:45.02+01:01' asDateAndTime printString = '2002-05-16T17:20:45.02+01:01'). self assert: ('2002-05-16T17:20:45.000000009+01:01' asDateAndTime printString = '2002-05-16T17:20:45.000000009+01:01'). self assert: (' 2002-05-16T17:20' asDateAndTime translateToUTC printString = '2002-05-16T17:20:00+00:00'). self assert: ('2002-05-16T17:20:45' asDateAndTime translateToUTC printString = '2002-05-16T17:20:45+00:00' ). self assert: (' 2002-05-16T17:20:45+01:57' asDateAndTime printString = '2002-05-16T17:20:45+01:57'). self assert: (' 2002-05-16T17:20:45-02:34' asDateAndTime printString = '2002-05-16T17:20:45-02:34'). self assert: ('2002-05-16T17:20:45+00:00' asDateAndTime printString = '2002-05-16T17:20:45+00:00'). self assert: ('1997-04-26T01:02:03+01:02:3' asDateAndTime printString = '1997-04-26T01:02:03+01:02:3'). ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 19:56'! testReadFrom self assert: '-1199-01-05T20:33:14.321-05:00' asDateAndTime printString equals: '-1199-01-05T20:33:14.321-05:00'. self assert: '2002-05-16T17:20:45.1+01:01' asDateAndTime printString equals: '2002-05-16T17:20:45.1+01:01'. self assert: ' 2002-05-16T17:20:45.02+01:01' asDateAndTime printString equals: '2002-05-16T17:20:45.02+01:01'. self assert: '2002-05-16T17:20:45.000000009+01:01' asDateAndTime printString equals: '2002-05-16T17:20:45.000000009+01:01'. self assert: ' 2002-05-16T17:20' asDateAndTime translateToUTC printString equals: '2002-05-16T17:20:00+00:00'. self assert: '2002-05-16T17:20:45' asDateAndTime translateToUTC printString equals: '2002-05-16T17:20:45+00:00' . self assert: ' 2002-05-16T17:20:45+01:57' asDateAndTime printString equals: '2002-05-16T17:20:45+01:57'. self assert: ' 2002-05-16T17:20:45-02:34' asDateAndTime equals: '2002-05-16T17:20:45-02:34' asDateAndTime. self assert: '2002-05-16T17:20:45+00:00' asDateAndTime equals: '2002-05-16T17:20:45+00:00' asDateAndTime. self assert: '1997-04-26T01:02:03+01:02:3' asDateAndTime equals: '1997-04-26T01:02:03+01:02:3' asDateAndTime! ! !DateAndTimeTest methodsFor: 'helpers' stamp: ''! restoreLocalTimeZoneAfter: aBlock | realTimeZone | realTimeZone := DateAndTime localTimeZone. aBlock ensure: [ DateAndTime localTimeZone: realTimeZone ].! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:33'! testSecondsRoundTrip | now now2 | now := DateAndTime fromSeconds: 0. now2 := DateAndTime fromSeconds: now asSeconds. self assert: now equals: now2.! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'SvenVanCaekenberghe 3/5/2013 09:27'! testAsDateAndTime "self debug: #testAsDateAndTime" #('-1199-01-05T20:33:14.321-05:00' ' 2002-05-16T17:20:45.1+01:01' ' 2002-05-16T17:20:45.02+01:01' ' 2002-05-16T17:20:45.003+01:01' ' 2002-05-16T17:20:45.0004+01:01' ' 2002-05-16T17:20:45.00005' ' 2002-05-16T17:20:45.000006+01:01' ' 2002-05-16T17:20:45.0000007+01:01' ' 2002-05-16T17:20:45.00000008-01:01' ' 2002-05-16T17:20:45.000000009+01:01' ' 2002-05-16T17:20:45.0000000001+01:01' ' 2002-05-16T17:20' ' 2002-05-16T17:20:45' ' 2002-05-16T17:20:45+01:57' ' 2002-05-16T17:20:45-02:34' ' 2002-05-16T17:20:45+00:00' ' 1997-04-26T01:02:03+01:02:3' ) do: [:each | each asDateAndTime printString = each]! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'StephaneDucasse 4/24/2010 12:05'! testReadFromOffset "self debug: #testReadFromOffset" self assert: (DateAndTime readFrom: '-1199-01-05T20:33:14.321-05:00' readStream) offset printString = '-0:05:00:00'. ! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'StephaneDucasse 4/23/2010 22:09'! testTransitive "self debug: #testTransitive" | t1 t2 t3 | t1 := DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. t2 := DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. t3 := DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. self assert: ((t1 = t2) & (t2 = t3) ==> (t1 = t3)). ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/21/2012 16:11'! testAsDos | remoteDatetime | self assert: '21 May 2012 3:02:44 pm' asDateAndTime asDosTimestamp equals: 16r40B57856. "DOS times are in local time per http://blogs.msdn.com/b/oldnewthing/archive/2003/09/05/54806.aspx" remoteDatetime := DateAndTime current offset: DateAndTime localOffset + 2 hours. self assert: remoteDatetime asDosTimestamp equals: remoteDatetime asLocal asDosTimestamp.! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'CamilloBruni 12/13/2013 05:34'! testNotSymmetricWithString "self debug: #testNotSymmetricWithString" | t1 t2 | t1 := DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. t2 := '0001-01-02T02:03:04.000000005+06:00'. self deny: t1 = t2. self deny: t2 = t1. ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'NickAger 7/6/2010 11:25'! testAsUnixTimeIndependentOfTimezone | datetimeWithOffset datetimeWithoutOffset | datetimeWithoutOffset := DateAndTime current offset: Duration zero. datetimeWithOffset := datetimeWithoutOffset offset: (Duration hours: 1). self assert: datetimeWithOffset asUnixTime equals: datetimeWithoutOffset asUnixTime! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/21/2012 16:12'! testFromDos | aDateAndTime | aDateAndTime := DateAndTime fromDosTimestamp: 16r40B57856. self assert: aDateAndTime equals: '21 May 2012 3:02:44 pm' asDateAndTime. "DOS times are in local time per http://blogs.msdn.com/b/oldnewthing/archive/2003/09/05/54806.aspx" self assert: aDateAndTime offset equals: DateAndTime localOffset! ! !DateAndTimeTest methodsFor: 'tests - bogus date' stamp: 'CamilloBruni 8/31/2013 20:23'! testErrorWhenDayIsAfterMonthEnd self should: [ DateAndTime year: 2004 month: 2 day: 30 ] raise: Error. DateAndTime year: 2004 month: 2 day: 29! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'GuillermoPolito 4/30/2012 11:50'! testPrintStringNoOffset | localOffsetHours localOffsetMinutes signString | signString := DateAndTime localOffset hours positive ifTrue: [ '+' ] ifFalse: [ '-' ]. localOffsetHours := DateAndTime localOffset hours abs printStringPadded: 2. localOffsetMinutes := DateAndTime localOffset minutes printStringPadded: 2. self assert: ('2002-05-16T17:20' asDateAndTime printString = ('2002-05-16T17:20:00{1}{2}:{3}' format: { signString . localOffsetHours. localOffsetMinutes})). self assert: ('2002-05-16T17:20:45' asDateAndTime printString = ('2002-05-16T17:20:45{1}{2}:{3}' format: { signString . localOffsetHours. localOffsetMinutes})).! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'StephaneDucasse 9/18/2010 21:40'! testPrintString "self debug: #testPrintString" | dt dtNoOffset | dt :=DateAndTime year: 2004 month: 11 day: 2 hour: 14 minute: 3 second: 5 nanoSecond: 12345 offset: (Duration seconds: (5 * 3600)). self assert: dt printString = '2004-11-02T14:03:05.000012345+05:00'. self assert: ('2002-05-16T17:20:45.1+01:01' asDateAndTime printString = '2002-05-16T17:20:45.1+01:01'). self assert: (' 2002-05-16T17:20:45.02+01:01' asDateAndTime printString = '2002-05-16T17:20:45.02+01:01'). self assert: ('2002-05-16T17:20:45.000000009+01:01' asDateAndTime printString = '2002-05-16T17:20:45.000000009+01:01'). self assert: ('2002-05-16T17:20:45+00:00' asDateAndTime printString = '2002-05-16T17:20:45+00:00' ). self assert: (' 2002-05-16T17:20:45+01:57' asDateAndTime printString = '2002-05-16T17:20:45+01:57'). self assert: (' 2002-05-16T17:20:45-02:34' asDateAndTime printString = '2002-05-16T17:20:45-02:34'). self assert: ('2002-05-16T17:20:45+00:00' asDateAndTime printString = '2002-05-16T17:20:45+00:00'). self assert: ('1997-04-26T01:02:03+01:02:3' asDateAndTime printString = '1997-04-26T01:02:03+01:02:3'). "When no offset is provided, the local one is used" dtNoOffset := '2002-05-16T17:20' asDateAndTime. self assert: (('2002-05-16T17:20:00*' match: dtNoOffset printString) and: [dtNoOffset offset = DateAndTime localOffset]). ! ! !DateAndTimeTest methodsFor: 'tests - instance' stamp: 'SeanDeNigris 11/29/2013 14:29'! testInstanceCreationFromADateAndATime | date time instance | date := Date today. time := Time now. instance := DateAndTime date: date time: time. self assert: instance asDate equals: date. self assert: instance asTime equals: time.! ! !DateAndTimeTest methodsFor: 'tests - epoch' stamp: 'SeanDeNigris 6/20/2012 00:53'! testUnixEpoch self assert: DateAndTime unixEpoch equals: '1 January 1970 00:00+00:00' asDateAndTime. ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'CamilloBruni 6/7/2013 23:55'! testOffset | dateAndTime1 dateAndTime2 | dateAndTime1 := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: 1 hours. dateAndTime2 := dateAndTime1 offset: 1 hour. self assert: dateAndTime1 equals: dateAndTime2. self assert: dateAndTime1 localSeconds equals: dateAndTime2 localSeconds. dateAndTime2 := dateAndTime1 offset: -1 hour. self assert: dateAndTime1 equals: dateAndTime2. self deny: dateAndTime1 localSeconds == dateAndTime2 localSeconds. dateAndTime2 := dateAndTime1 offset: -2 hour. self assert: dateAndTime1 equals: dateAndTime2. self deny: dateAndTime1 localSeconds == dateAndTime2 localSeconds.! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'pavel.krivanek 9/9/2010 18:05'! testPrintStringSecond "self debug: #testPrintStringSecond" self assert: ('-1199-01-05T20:33:14.321-05:00' asDateAndTime printString = '-1199-01-05T20:33:14.321-05:00'). self assert: ('2002-05-16T17:20:45.1+01:01' asDateAndTime printString = '2002-05-16T17:20:45.1+01:01'). self assert: (' 2002-05-16T17:20:45.02+01:01' asDateAndTime printString = '2002-05-16T17:20:45.02+01:01'). self assert: ('2002-05-16T17:20:45.000000009+01:01' asDateAndTime printString = '2002-05-16T17:20:45.000000009+01:01'). self assert: (' 2002-05-16T17:20:45+01:57' asDateAndTime printString = '2002-05-16T17:20:45+01:57'). self assert: (' 2002-05-16T17:20:45-02:34' asDateAndTime printString = '2002-05-16T17:20:45-02:34'). self assert: ('2002-05-16T17:20:45+00:00' asDateAndTime printString = '2002-05-16T17:20:45+00:00'). self assert: ('1997-04-26T01:02:03+01:02:3' asDateAndTime printString = '1997-04-26T01:02:03+01:02:3'). ! ! !DateAndTimeTest methodsFor: 'coverage' stamp: 'StephaneDucasse 4/23/2010 21:08'! selectorsToBeIgnored | private | private := #( #printOn: ). ^ super selectorsToBeIgnored, private ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'StephaneDucasse 4/24/2010 11:58'! testReadFromFoolProofExtension "Convenient extension without a time, only a date" "self debug: #testReadFromFoolProofExtension" self assert: (DateAndTime fuzzyReadFrom: '2008' readStream) printString = '2008-01-01T00:00:00+00:00'. self assert: (DateAndTime fuzzyReadFrom: '2008-08' readStream) printString = '2008-08-01T00:00:00+00:00'. self assert: (DateAndTime fuzzyReadFrom: '2006-08-28' readStream) printString = '2006-08-28T00:00:00+00:00'. "Regular nanoseconds" self assert: (DateAndTime fuzzyReadFrom: '2006-08-28T00:00:00.123456789' readStream) printString = '2006-08-28T00:00:00.123456789+00:00'. "Extra picoseconds precision should not spoil the DateAndTime" self assert: (DateAndTime fuzzyReadFrom: '2006-08-28T00:00:00.123456789000' readStream) printString = '2006-08-28T00:00:00.123456789+00:00'.! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:36'! testDateTimeDenotation2 "DateAndTimeTest new testDateTimeDenotation2" "Moscow is 3 hours ahead UTC, this offset to UTC is therefore positive. This example tests the correct interpretation of the DateAndTime denotation." | lateEveningInLondon lateEveningInLocalTimeOfMoscow localMoscowTimeFromDenotation | lateEveningInLondon := DateAndTime year: 2004 month: 11 day: 30 hour: 23 minute: 30 second: 0 offset: 0 hours. lateEveningInLocalTimeOfMoscow := lateEveningInLondon offset: 3 hours. localMoscowTimeFromDenotation := '2004-12-01T02:30:00+03:00' asDateAndTime. self assert: lateEveningInLocalTimeOfMoscow = localMoscowTimeFromDenotation.! ! !DateAndTimeTest methodsFor: 'helpers' stamp: ''! useTimeZone: abbreviation during: aBlock | timeZone | timeZone := TimeZone abbreviated: abbreviation. self restoreLocalTimeZoneAfter: [ DateAndTime localTimeZone: timeZone. aBlock cull: timeZone ].! ! !DateAndTimeTest methodsFor: 'helpers' stamp: ''! useNonUtcTimeZoneDuring: aBlock self useTimeZone: 'EDT' during: aBlock.! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'SeanDeNigris 8/5/2010 15:50'! testReadFromNoOffset "self debug: #testReadFromNoOffset" self assert: (DateAndTime readFrom: '2010-01-05T20:33:14.321' readStream) offset = DateAndTime localOffset.. ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'SeanDeNigris 8/5/2010 16:09'! testFromString | fromString fromStringNoOffset | fromString := DateAndTime fromString: '-1199-01-05T20:33:14.321-05:00'. self assert: (fromString printString = '-1199-01-05T20:33:14.321-05:00'). "if no offset is provided, the local offset should be used" fromStringNoOffset := DateAndTime fromString: '-1199-01-05T20:33:14.321'. self assert: (fromStringNoOffset offset = DateAndTime localOffset).! ! !DateAndTimeTest methodsFor: 'tests - instance' stamp: 'StephaneDucasse 4/23/2010 21:47'! testSimpleAccessors | t | t := DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. self assert: (t hours = t hours); assert: (t minutes = t minute); assert: (t seconds = t second). ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:36'! testTimeZoneEquivalence2 "DateAndTimeTest new testTimeZoneEquivalence2" "This example demonstates the fact that 2004-05-24T22:40:00 UTC is 2004-05-25T01:40:00 in Moscow (Moscow is 3 hours ahead of UTC) " | thisMoment thisMomentInMoscow | thisMoment := DateAndTime year: 2004 month: 5 day: 24 hour: 22 minute: 40. thisMomentInMoscow := thisMoment offset: 3 hours. self assert: (thisMoment - thisMomentInMoscow) asSeconds = 0. self assert: thisMoment = thisMomentInMoscow ! ! !DateAndTimeTest methodsFor: 'tests - bogus date' stamp: 'CamilloBruni 8/31/2013 20:23'! testErrorWhenDayIsBeforeMonthStart self should: [ DateAndTime year: 2004 month: 2 day: -1 ] raise: Error. self should: [ DateAndTime year: 2004 month: 2 day: 0 ] raise: Error. DateAndTime year: 2004 month: 2 day: 1! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'SvenVanCaekenberghe 3/6/2013 16:48'! testReadFromUTCOffset self assert: (DateAndTime readFrom: '2010-01-05T20:33:14.321Z' readStream) offset isZero. self assert: (DateAndTime readFrom: '2010-01-05T20:33:14.321+00' readStream) offset isZero. self assert: (DateAndTime readFrom: '2010-01-05T20:33:14.321+0000' readStream) offset isZero. self assert: (DateAndTime readFrom: '2010-01-05T20:33:14.321+00:00' readStream) offset isZero. ! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'SvenVanCaekenberghe 3/6/2013 16:41'! testReadFromSpaceBeforeOffset self assert: '2012-07-26 16:38:48 +0200' asDateAndTime offset equals: 2 hour. self assert: '2012-07-26 16:38:48 +02' asDateAndTime offset equals: 2 hour. ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'CamilloBruni 6/7/2013 23:40'! testAsTime | dateAndTime | dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: 0 asDuration. self assert: dateAndTime asTime equals: (Time hour: 1 minute: 2 second: 3). dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: 5 hours. self assert: dateAndTime asTime equals: (Time hour: 1 minute: 2 second: 3). dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: -5 hours. self assert: dateAndTime asTime equals: (Time hour: 1 minute: 2 second: 3).! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'CamilloBruni 6/8/2013 00:26'! testSecondsSinceMidnightLocalTimeNormalization | dateAndTime| "Check offset: changes from times defined in UTC" dateAndTime := DateAndTime year: 1001 day: 101 hour: 0 minute: 1 second: 56 offset: 0 hours. dateAndTime := dateAndTime offset: 1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: (1*3600) + (1*60) + 56. "-1 hours will switch to the previous day" dateAndTime := dateAndTime offset: -1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: (23*3600) + (1*60) + 56. dateAndTime := DateAndTime year: 1001 day: 101 hour: 23 minute: 1 second: 56 offset: 0 hours. dateAndTime := dateAndTime offset: 1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: (0*3600) + (1*60) + 56. "-1 hours will switch to the next day" dateAndTime := dateAndTime offset: -1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: 22*3600 + (1*60) + 56. "Check offset: changes from times defined in +1" dateAndTime := DateAndTime year: 1001 day: 101 hour: 0 minute: 1 second: 56 offset: 1 hours. dateAndTime := dateAndTime offset: 2 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: (1*3600) + (1*60) + 56. "0 hours will switch to the previous day" dateAndTime := dateAndTime offset: 0 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: (23*3600) + (1*60) + 56. dateAndTime := dateAndTime offset: -1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: (22*3600) + (1*60) + 56. dateAndTime := DateAndTime year: 1001 day: 101 hour: 23 minute: 1 second: 56 offset: 1 hours. "+2 hours will switch to the next day" dateAndTime := dateAndTime offset: 2 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: (0*3600) + (1*60) + 56. dateAndTime := dateAndTime offset: 0 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: (22*3600) + (1*60) + 56. dateAndTime := dateAndTime offset: -1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: (21*3600) + (1*60) + 56. ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'SvenVanCaekenberghe 2/19/2014 19:40'! testReadFromDateOnly self assert: '2014-02-19' asDateAndTime translateToUTC printString equals: '2014-02-19T00:00:00+00:00'. self assert: '2014-02-19Z' asDateAndTime printString equals: '2014-02-19T00:00:00+00:00'. self assert: '2014-02-19T+07:00' asDateAndTime printString equals: '2014-02-19T00:00:00+07:00'. self assert: '2014-02-19 -05:00' asDateAndTime printString equals: '2014-02-19T00:00:00-05:00'. ! ! !DateAndTimeTest methodsFor: 'tests - epoch' stamp: 'PavelKrivanek 7/8/2012 20:01'! testSqueakEpoch self useNonUtcTimeZoneDuring: [ | localEpoch | localEpoch := '1901-01-01T00:00:00' asDateAndTime. self deny: (DateAndTime epoch = localEpoch). self deny: (((DateAndTime fromSeconds: 0) offset: 0) = localEpoch) ]. self useTimeZone: 'UTC' during: [ | localEpoch | localEpoch := '1901-01-01T00:00:00' asDateAndTime. self assert: DateAndTime epoch equals: localEpoch. self assert: ((DateAndTime fromSeconds: 0) offset: 0) equals: localEpoch ]. self assert: DateAndTime epoch equals: '1901-01-01T00:00:00+00:00' asDateAndTime. self assert: ((DateAndTime fromSeconds: 0) offset: 0) equals: '1901-01-01T00:00:00+00:00' asDateAndTime.! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'CamilloBruni 6/8/2013 00:16'! testSecondsSinceMidnightLocalTime | dateAndTime | dateAndTime := DateAndTime year: 1000 day: 100 hour: 0 minute: 0 second: 56 offset: 0 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: 56. dateAndTime := DateAndTime year: 1000 day: 100 hour: 0 minute: 1 second: 56 offset: 0 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: 60+56. dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 0 second: 56 offset: 0 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: 3600+56. "1 hour offset" dateAndTime := DateAndTime year: 1000 day: 100 hour: 0 minute: 0 second: 56 offset: 1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: 56. dateAndTime := DateAndTime year: 1000 day: 100 hour: 0 minute: 1 second: 56 offset: 1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: 60+56. dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 0 second: 56 offset: 1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: 3600+56. "-1 hour offset" dateAndTime := DateAndTime year: 1000 day: 100 hour: 0 minute: 0 second: 56 offset: -1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: 56. dateAndTime := DateAndTime year: 1001 day: 101 hour: 0 minute: 1 second: 56 offset: -1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: 60+56. dateAndTime := DateAndTime year: 1002 day: 102 hour: 1 minute: 0 second: 56 offset: -1 hours. self assert: dateAndTime secondsSinceMidnightLocalTime equals: 3600+56.! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'StephaneDucasse 4/23/2010 22:07'! testReflexive | t | t := DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. self assert: t = t. ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'AndyKellens 4/4/2013 09:33'! testDayOfWeekWithUTC | date | "Calculating the day of week should take into account the UTC offset" date := DateAndTime julianDayNumber: 2456385 offset:(Duration hours:2). "Internally, this date gets represented as the julian day 2456384 with seconds 79200 and offset 2 hours" "When asking for the day of week, the offset should be taken into account to return the correct day of week" self assert: (date dayOfWeek = 3). ! ! !DateAndTimeTest methodsFor: 'tests' stamp: 'CamilloBruni 6/7/2013 23:40'! testAsTimeUTC | dateAndTime | dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: 0 asDuration. self assert: dateAndTime asTimeUTC equals: (Time hour: 1 minute: 2 second: 3). dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: -5 hours. self assert: dateAndTime asTimeUTC equals: (Time hour: 6 minute: 2 second: 3). dateAndTime := DateAndTime year: 1000 day: 100 hour: 1 minute: 2 second: 3 offset: 5 hours. self assert: dateAndTime asTimeUTC equals: (Time hour: 24+1-5 minute: 2 second: 3).! ! !DateAndTimeUnixEpochTest commentStamp: 'TorstenBergmann 2/5/2014 08:33'! Tests for unix epoch of DateAndTime! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:22'! testMiddleOf self assert: (aDateAndTime middleOf: '2:00:00:00' asDuration) = (Timespan starting: '12-31-1969' asDate duration: 2 days). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:20'! testHash self assert: aDateAndTime hash = (DateAndTime year: 1970 month: 1 day: 1) hash! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testMinute self assert: aDateAndTime minute = 0 ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testToByDo "self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days do: []) = " "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDaysInMonth self assert: aDateAndTime daysInMonth = 31. ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:17'! testDateTime self assert: aDateAndTime = (DateAndTime date: '01-01-1970' asDate time: '00:00:00' asTime) ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:19'! testFromSeconds self assert: aDateAndTime = (DateAndTime fromSeconds: 2177452800). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testAsDateAndTime self assert: aDateAndTime asDateAndTime = aDateAndTime ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:29'! testAsSeconds self assert: aDateAndTime asSeconds = 2177452800 ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDay self assert: aDateAndTime day = DateAndTime new day ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:17'! testAsYear self assert: aDateAndTime asYear = (Year starting: '01-01-1970' asDate). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:28'! testYearDay self assert: aDateAndTime = (DateAndTime year: 1970 day: 1). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testToday self deny: aDateAndTime = (DateAndTime today). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:18'! testDayMonthYearDo |iterations| iterations := 0. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | iterations := iterations + 1]) = 1. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachYear]) = 1970. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachMonth]) = 1. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachDay]) = 1. ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testCurrent self deny: aDateAndTime = (DateAndTime current). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:17'! testAsWeek self assert: aDateAndTime asWeek = (Week starting: '12-31-1969' asDate). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testMonth self assert: aDateAndTime month = 1. self assert: aDateAndTime monthAbbreviation = 'Jan'. self assert: aDateAndTime monthName = 'January'. self assert: aDateAndTime monthIndex = 1.! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testTo self assert: (aDateAndTime to: aDateAndTime) = ((DateAndTime year: 1970 month: 1 day: 1) to: (DateAndTime year: 1970 month: 1 day: 1)) "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:23'! testPrintOn | cs rw | cs := '1970-01-01T00:00:00+00:00' readStream. rw := ReadWriteStream on: ''. aDateAndTime printOn: rw. self assert: rw contents = cs contents. cs := 'a TimeZone(UTZ)' readStream. rw := ReadWriteStream on: ''. aTimeZone printOn: rw. self assert: rw contents = cs contents! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDayOfYear self assert: aDateAndTime dayOfYear = 1. ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:23'! testPlus self assert: aDateAndTime + '0:00:00:00' = aDateAndTime. self assert: aDateAndTime + 0 = aDateAndTime. self assert: aDateAndTime + aDuration = (DateAndTime year: 1970 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:28'! testYear self assert: aDateAndTime year = 1970. ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:28'! testYearMonthDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1970 month: 1 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testTommorrow self assert: (DateAndTime today + 24 hours) = (DateAndTime tomorrow). self deny: aDateAndTime = (DateAndTime tomorrow). "MessageNotUnderstood: Date class>>starting:"! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testHour12 self assert: aDateAndTime hour12 = DateAndTime new hour12. self assert: aDateAndTime hour12 = 12 ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:27'! testToBy self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days) = ((DateAndTime year: 1970 month: 1 day: 1) to: (DateAndTime year: 1970 month: 1 day: 1) + 10 days by: 5 days ) "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testMinutes self assert: aDateAndTime minutes = 0 ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'AM'. ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:30'! testMinus self assert: aDateAndTime - aDateAndTime = '0:00:00:00' asDuration. self assert: aDateAndTime - '0:00:00:00' asDuration = aDateAndTime. self assert: aDateAndTime - aDuration = (DateAndTime year: 1969 month: 12 day: 30 hour: 21 minute: 56 second: 55 nanoSecond: 999999995 offset: 0 hours ). " I believe this Failure is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:36'! testUtcOffset self assert: (aDateAndTime offset: '0:12:00:00') = '1970-01-01T12:00:00+12:00' asDateAndTime! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:24'! testTicks self assert: aDateAndTime ticks = (DateAndTime julianDayNumber: 2440588) ticks. self assert: aDateAndTime ticks = #(2440588 0 0)! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testFirstDayOfMonth self assert: aDateAndTime firstDayOfMonth = 1 ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testHour self assert: aDateAndTime hour = aDateAndTime hour24. self assert: aDateAndTime hour = 0. self assert: aDateAndTime hour = aDateAndTime hours ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDuration self assert: aDateAndTime duration = 0 asDuration. ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = 0 asDuration asNanoSeconds ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testMidnight self assert: aDateAndTime midnight = aDateAndTime ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:14'! testAsDate self assert: aDateAndTime asDate = 'January 1, 1970' asDate. ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDaysInYear self assert: aDateAndTime daysInYear = 365. ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testIsLeapYear self deny: aDateAndTime isLeapYear ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:21'! testJulianDayNumber self assert: aDateAndTime = (DateAndTime julianDayNumber: 2440588). self assert: aDateAndTime julianDayNumber = 2440588.! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2415386 0 0) offset: DateAndTime localOffset). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 20:30'! testOffset self assert: aDateAndTime offset = '0:00:00:00' asDuration. self assert: (aDateAndTime offset: '0:12:00:00') equals: '1970-01-01T12:00:00+12:00' asDateAndTime! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testYesterday self deny: aDateAndTime = (DateAndTime yesterday). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:51'! testTimeZone self assert: aDateAndTime timeZoneName = 'Universal Time'. self assert: aDateAndTime timeZoneAbbreviation = 'UTC' ! ! !DateAndTimeUnixEpochTest methodsFor: 'running' stamp: 'GabrielBarbuto 9/27/2010 10:13'! tearDown DateAndTime localTimeZone: localTimeZoneToRestore. "wish I could remove the time zones I added earlier, tut there is no method for that" ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:28'! testYearMonthDayHourMinuteSecondNanosSecondOffset self assert: aDateAndTime = (DateAndTime year: 1970 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset:0 hours ). self assert: ((DateAndTime year: 1 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset: 0 hours ) + (Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5) ) = (DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)"" I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 8/22/2013 19:43'! testAsMonth self assert: aDateAndTime asMonth equals: (Month year: 1970 month: 'January'). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:18'! testDayOfWeek self assert: aDateAndTime dayOfWeek = 5. self assert: aDateAndTime dayOfWeekAbbreviation = 'Thu'. self assert: aDateAndTime dayOfWeekName = 'Thursday'. ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testAsDuration self assert: aDateAndTime asDuration = 0 asDuration ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 16:36'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime offset: aDateAndTime class localOffset) ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testAsTime self assert: aDateAndTime asTime = Time midnight. ! ! !DateAndTimeUnixEpochTest methodsFor: 'running' stamp: 'GabrielBarbuto 9/27/2010 10:14'! setUp localTimeZoneToRestore := DateAndTime localTimeZone. aDateAndTime := DateAndTime localTimeZone: TimeZone default; unixEpoch. aTimeZone := TimeZone offset: (Duration minutes: 135) name: 'Unix Epoch Test Time Zone' abbreviation: 'UTZ'. aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 1. ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:19'! testFromString self assert: aDateAndTime = (DateAndTime fromString: ' 1970-01-01T00:00:00+00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1970-01-01T00:00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1970-01-01T00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1970-01-01T00:00:00+00:00'). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:28'! testYearDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1970 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testNow self deny: aDateAndTime = (DateAndTime now). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:18'! testEpoch self assert: aDateAndTime = '1970-01-01T00:00:00+00:00' asDateAndTime ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:16'! testAsTimeStamp self assert: aDateAndTime asTimeStamp = (TimeStamp fromString: '1 January 1970 12:00 am').! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:23'! testNoon self assert: aDateAndTime noon = '1970-01-01T12:00:00+00:00' asDateAndTime! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:28'! testYearMonthDay self assert: aDateAndTime = (DateAndTime year: 1970 month: 1 day: 1). ! ! !DateAndTimeUnixEpochTest methodsFor: 'tests' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 364. ! ! !DateModel commentStamp: ''! A DateModel is a widget for choosing dates. It consists of: - A text box, into which you can type any string which can be converted into a Smalltalk date - A button, which displays a calendar, from which you can select a date Usage: - the simplest way is to add a DateModel in your UI, and send #date when you want its value. - or, register to be notified when the date changes: DateModel new date: self date; whenDateChanged: [ :newDate | self date: newDate ]. As it is Spec-based, it can be easily adapted and composed into a larger UI.! !DateModel methodsFor: 'private' stamp: 'SeanDeNigris 1/28/2013 14:20'! onDateChosen: aChoseDate aChoseDate calendar delete. dateModel text: aChoseDate date asString.! ! !DateModel methodsFor: 'accessing-widgets' stamp: 'SeanDeNigris 1/28/2013 14:17'! dateModel ^ dateModel.! ! !DateModel methodsFor: 'private' stamp: 'SeanDeNigris 2/6/2013 15:46'! chooseDate | calendar | calendar := CalendarMorph openOn: Date today. calendar center: calendar cursorPoint; fitInWorld; onChoiceSend: #onDateChosen: to: self.! ! !DateModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/29/2013 16:06'! initializeWidgets | typeItems | self instantiateModels: #( dateLabel LabelModel dateModel TextInputFieldModel chooseDateButton ButtonModel). dateLabel text: 'Date'. dateModel text: Date today asString; isCodeCompletionAllowed: false. chooseDateButton label: self iconMorph; action: [ self chooseDate ]; extent: self iconMorph extent.! ! !DateModel methodsFor: 'accessing' stamp: 'SeanDeNigris 6/12/2013 08:51'! date: aDate ^ self dateModel text: aDate asString.! ! !DateModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! displayBlock: aBlock "Set the one argument block used to transfrom your date into a string" displayBlockHolder value: aBlock! ! !DateModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize displayBlockHolder := [ :object | object asStringOrText ] asReactiveVariable. displayBlockHolder whenChangedDo: [ self date: self date ]. super initialize. "do this last so default will be set after displayBlock"! ! !DateModel methodsFor: 'private' stamp: 'StephaneDucasse 5/23/2013 18:34'! iconMorph ^ ImageMorph new form: Smalltalk ui icons calendarIcon.! ! !DateModel methodsFor: 'accessing' stamp: 'SeanDeNigris 1/28/2013 14:28'! date ^ self dateModel getText asDate.! ! !DateModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! displayBlock "Return the one argument block used to wrap your domain specific items. The block should return something that can be displayed in a list - like a String or a Text" ^ displayBlockHolder value! ! !DateModel methodsFor: 'accessing-widgets' stamp: 'SeanDeNigris 1/28/2013 14:17'! chooseDateButton ^ chooseDateButton.! ! !DateModel methodsFor: 'accessing-widgets' stamp: 'SeanDeNigris 1/28/2013 14:17'! dateLabel ^ dateLabel.! ! !DateModel methodsFor: 'protocol-events' stamp: 'ClementBera 6/28/2013 10:33'! whenDateChanged: aBlock dateModel whenTextChanged: [:newText :oldText :announcement :anAnnouncer || newDate oldDate | newDate := Date readFrom: newText readStream. oldDate := Date readFrom: oldText readStream. aBlock cull: newDate cull: oldDate cull: announcement cull: anAnnouncer ]! ! !DateModel class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/29/2013 16:08'! spec ^ SpecLayout composed newRow: [ :row | row add: #dateLabel width: 60; "This is to address a not yet fixed Spec issue" newRow: [:ugly | ugly add: #dateModel; add: #chooseDateButton width: 50 ]] height: 25 yourself.! ! !DateParser commentStamp: ''! Read a Date from the stream based on the pattern which can include the tokens: y = A year with 1-n digits yy = A year with 2 digits yyyy = A year with 4 digits m = A month with 1-n digits mm = A month with 2 digits d = A day with 1-n digits dd = A day with 2 digits ...and any other Strings inbetween. Representing $y, $m and $d is done using \y, \m and \d and slash itself with \\. Simple example patterns: 'yyyy-mm-dd' 'yyyymmdd' 'yy.mm.dd' 'y-m-d' A year given using only two decimals is considered to be >2000.! !DateParser methodsFor: 'parsing - private' stamp: 'HernanWilkinson 11/7/2013 13:25'! createDate ^ Date year: year month: month day: day! ! !DateParser methodsFor: 'parsing month - private' stamp: 'HernanWilkinson 11/7/2013 13:11'! parseMonth self isTwoDigitMonthPattern ifTrue: [ ^self parseTwoDigitMonth ]. self parseVariableDigitMonth ! ! !DateParser methodsFor: 'parsing month - private' stamp: 'HernanWilkinson 11/7/2013 13:26'! parseVariableDigitMonth month := Integer readFrom: inputStream! ! !DateParser methodsFor: 'initialization' stamp: 'HernanWilkinson 11/7/2013 13:23'! initializeReadingFrom: anInputStream pattern: aPattern inputStream := anInputStream. pattern := aPattern. ! ! !DateParser methodsFor: 'parsing - private' stamp: 'HernanWilkinson 11/7/2013 13:25'! isEscape ^ char = $\! ! !DateParser methodsFor: 'parsing year - private' stamp: 'HernanWilkinson 11/7/2013 13:26'! isTwoDigitYearPattern ^ patternStream peekFor: $y! ! !DateParser methodsFor: 'parsing - private' stamp: 'HernanWilkinson 11/7/2013 13:02'! parseNextPattern self readNextChar. self isEscape ifTrue: [ ^ self parseEscapePattern ]. self isYearPattern ifTrue: [ ^ self parseYear ]. self isMonthPattern ifTrue: [ ^ self parseMonth ]. self isDayPattern ifTrue: [ ^ self parseDay ]. self parseSameChar! ! !DateParser methodsFor: 'parsing year - private' stamp: 'HernanWilkinson 11/7/2013 13:07'! parseVariableDigitYear year := Integer readFrom: inputStream! ! !DateParser methodsFor: 'parsing - private' stamp: 'HernanWilkinson 11/7/2013 13:24'! initializeParsing invalidPattern := false. patternStream := pattern readStream! ! !DateParser methodsFor: 'parsing day - private' stamp: 'HernanWilkinson 11/7/2013 13:25'! isDayPattern ^ char = $d! ! !DateParser methodsFor: 'parsing year - private' stamp: 'HernanWilkinson 11/7/2013 13:07'! parseFourDigitYear year := (inputStream next: 4) asInteger! ! !DateParser methodsFor: 'parsing month - private' stamp: 'HernanWilkinson 11/7/2013 13:26'! parseTwoDigitMonth month := (inputStream next: 2) asInteger! ! !DateParser methodsFor: 'parsing - private' stamp: 'HernanWilkinson 11/7/2013 12:29'! isDoneParsing ^ patternStream atEnd or: [ inputStream atEnd or: [ invalidPattern ]]! ! !DateParser methodsFor: 'parsing year - private' stamp: 'HernanWilkinson 11/7/2013 13:07'! parseYear self isFourDigitYearPattern ifTrue: [ ^ self parseFourDigitYear ]. self isTwoDigitYearPattern ifTrue: [ ^ self parseTwoDigitYear ]. self parseVariableDigitYear! ! !DateParser methodsFor: 'parsing day - private' stamp: 'HernanWilkinson 11/7/2013 13:25'! isTwoDigitDayPattern ^ patternStream peekFor: $d! ! !DateParser methodsFor: 'parsing' stamp: 'HernanWilkinson 11/7/2013 13:24'! parse self initializeParsing. [ self isDoneParsing ] whileFalse: [ self parseNextPattern ]. self isInvalidPattern ifTrue: [ ^ nil ]. self convertTwoDigitsYear. ^ self createDate! ! !DateParser methodsFor: 'parsing - private' stamp: 'HernanWilkinson 11/7/2013 12:32'! isInvalidPattern ^ year isNil or: [ month isNil or: [ day isNil or: [ invalidPattern ]]]! ! !DateParser methodsFor: 'parsing year - private' stamp: 'HernanWilkinson 11/7/2013 13:07'! parseTwoDigitYear year := (inputStream next: 2) asInteger! ! !DateParser methodsFor: 'parsing day - private' stamp: 'HernanWilkinson 11/7/2013 13:25'! parseVariableDigitDay day := Integer readFrom: inputStream! ! !DateParser methodsFor: 'parsing - private' stamp: 'ChristopheDemarey 11/12/2013 14:49'! convertTwoDigitsYear (year between: 0 and: 99) ifTrue: [ year := self currentMillenium + year ]! ! !DateParser methodsFor: 'parsing - private' stamp: 'ChristopheDemarey 11/12/2013 14:48'! currentMillenium ^ (Date current year / 100) asInteger * 100! ! !DateParser methodsFor: 'parsing - private' stamp: 'HernanWilkinson 11/7/2013 13:25'! parseSameChar inputStream next = char ifFalse: [ invalidPattern := true ]! ! !DateParser methodsFor: 'parsing year - private' stamp: 'HernanWilkinson 11/7/2013 13:26'! isFourDigitYearPattern ^ patternStream nextMatchAll: 'yyy'! ! !DateParser methodsFor: 'parsing - private' stamp: 'HernanWilkinson 11/7/2013 13:25'! readNextChar char := patternStream next! ! !DateParser methodsFor: 'parsing month - private' stamp: 'HernanWilkinson 11/7/2013 13:25'! isTwoDigitMonthPattern ^ patternStream peekFor: $m! ! !DateParser methodsFor: 'parsing - private' stamp: 'HernanWilkinson 11/7/2013 13:02'! parseEscapePattern inputStream next = patternStream next ifFalse: [ invalidPattern := true ]! ! !DateParser methodsFor: 'parsing day - private' stamp: 'HernanWilkinson 11/7/2013 14:26'! parseDay self isTwoDigitDayPattern ifTrue: [ ^ self parseTwoDigitDay ]. self parseVariableDigitDay! ! !DateParser methodsFor: 'parsing month - private' stamp: 'HernanWilkinson 11/7/2013 13:25'! isMonthPattern ^ char = $m! ! !DateParser methodsFor: 'parsing day - private' stamp: 'HernanWilkinson 11/7/2013 13:25'! parseTwoDigitDay day := (inputStream next: 2) asInteger! ! !DateParser methodsFor: 'parsing year - private' stamp: 'HernanWilkinson 11/7/2013 13:26'! isYearPattern ^ char = $y! ! !DateParser class methodsFor: 'instance creation' stamp: 'HernanWilkinson 11/7/2013 14:23'! readingFrom: anInputStream pattern: aPattern "See class comment for pattern description self comment" ^self new initializeReadingFrom: anInputStream pattern: aPattern ! ! !DatePrintFormatTester commentStamp: ''! I am a helper object used for validating formatted Date strings. ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! shouldnt: aBlock self deny: aBlock value ! ! !DatePrintFormatTester methodsFor: 'as yet unclassified' stamp: ''! skip: aComment "Don't run this test, and don't mark it as failure" TestSkip signal: aComment! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! shouldnt: aBlock raise: anExceptionalEvent description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! deny: aBooleanOrBlock self assert: aBooleanOrBlock value not ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! assert: aBooleanOrBlock description: aString resumable: resumableBoolean | exception | aBooleanOrBlock value ifFalse: [self classForTestResult failure new isResumable: resumableBoolean; signal: aString] ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! deny: aBooleanOrBlock description: aString self assert: aBooleanOrBlock value not description: aString ! ! !DatePrintFormatTester methodsFor: 'private' stamp: ''! comparingStringBetween: actual and: expected ^ String streamContents: [:stream | stream nextPutAll: 'Got '; nextPutAll: actual fullPrintString; nextPutAll: ' instead of '; nextPutAll: expected fullPrintString; nextPutAll: '.']! ! !DatePrintFormatTester methodsFor: 'accessing' stamp: 'SeanDeNigris 6/20/2012 03:19'! date: aDate date := aDate.! ! !DatePrintFormatTester methodsFor: 'printing' stamp: 'SeanDeNigris 6/20/2012 03:33'! printFormat ^ date printFormat: { dayPosition. monthPosition. yearPosition. delimiter. monthType. yearType }.! ! !DatePrintFormatTester methodsFor: 'accessing' stamp: 'SeanDeNigris 6/20/2012 03:25'! delimiter: aCharacter delimiter := aCharacter.! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: 'SeanDeNigris 6/20/2012 03:51'! yearType: aNumber shouldPrintAs: aString | actual tokens isMonthMissing yearTokenIndex | yearType := aNumber. tokens := self tokens. isMonthMissing := tokens size = 2. yearTokenIndex := isMonthMissing ifTrue: [ 2 ] ifFalse: [ 3 ]. actual := tokens at: yearTokenIndex. self assert: actual equals: aString.! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! executeShould: aBlock inScopeOf: anExceptionalEvent ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: true] ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: 'SeanDeNigris 6/20/2012 03:43'! monthType: aNumber shouldPrintAs: aString | actual | monthType := aNumber. actual := self tokens at: monthPosition. self assert: actual equals: aString.! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! assert: aBooleanOrBlock description: aStringOrBlock aBooleanOrBlock value ifFalse: [ | message | message := aStringOrBlock value. self classForTestResult failure signal: message] ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! should: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! should: aBlock self assert: aBlock value ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! should: aBlock raise: anException withExceptionDo: anotherBlock ^self assert: (self executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock)! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) not description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) not description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! should: aBlock raise: anExceptionalEvent ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! signalFailure: aString self classForTestResult failure signal: aString! ! !DatePrintFormatTester methodsFor: 'accessing' stamp: 'SeanDeNigris 6/20/2012 03:31'! monthType: anInteger monthType := anInteger.! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: 'SeanDeNigris 6/20/2012 03:33'! shouldEqual: expectedOutputString self assert: self printFormat equals: expectedOutputString. ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! assert: aBoolean aBoolean ifFalse: [self signalFailure: 'Assertion failed'] ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! should: aBlock raise: anExceptionalEvent description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: (ex description includesSubstring: aString) not ] ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! shouldFix: aBlock "Run the block expecting an Exception. Throw an assertion failure if the block does NOT throw an exception." ^self should: aBlock raise: Exception! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! should: aBlock description: aString self assert: aBlock value description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! shouldnt: aBlock description: aString self deny: aBlock value description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! skip "Don't run this test, and don't mark it as failure" TestSkip signal! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! shouldnt: aBlock raise: anExceptionalEvent ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! assert: actual equals: expected ^ self assert: expected = actual description: [self comparingStringBetween: actual and: expected]! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock ^[aBlock value. false] on: anException do: [:exception | anotherBlock value: exception. exception return: true]! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! classForTestResult "Returns the class of the test result" ^ TestResult! ! !DatePrintFormatTester methodsFor: 'private' stamp: ''! comparingCollectionBetween: left and: right | additionalLeft additionalRight sortBlock| "use a very slow sort block" sortBlock := [ :a :b | a asString <= b asString ]. additionalLeft := (left difference: right) sorted: sortBlock. additionalRight := (right difference: left) sorted: sortBlock. ^ String streamContents: [:stream | stream nextPutAll: 'Given Collections do not match. Got '; lf; tab; nextPutAll: 'left := '; print: left; nextPut: $.; lf; nextPutAll: ' instead of '; tab; nextPutAll: ' right :='; print: left; nextPut: $.; lf. left size = right size ifFalse: [ stream nextPutAll: 'Collection size does not match: left='; print: left size; nextPutAll: ' vs. right='; print: right size; lf ]. additionalLeft isEmpty ifFalse: [ stream nextPutAll: 'Got '; print: additionalLeft size; nextPutAll: ' additional element(s) in the left collection: '; tab; print: additionalLeft ]. additionalRight isEmpty ifFalse: [ stream nextPutAll: 'Got '; print: additionalRight size; nextPutAll: ' additional element(s) in the right collection: '; tab; print: additionalRight ]]! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! should: aBlock notTakeMoreThan: aDuration "Evaluate aBlock and if it takes more than given duration to run we report a test failure. " ^ aBlock valueWithin: aDuration onTimeout: [ self assert: false description: ['Block evaluation took more than the expected <1p>' expandMacrosWith: aDuration] ] ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! deny: aBooleanOrBlock description: aString resumable: resumableBoolean self assert: aBooleanOrBlock value not description: aString resumable: resumableBoolean ! ! !DatePrintFormatTester methodsFor: 'private' stamp: 'SeanDeNigris 6/20/2012 03:20'! dayPosition: dayPos monthPosition: moPos yearPosition: yrPos delimiter: aCharacter monthType: moType yearType: yrType dayPosition := dayPos. monthPosition := moPos. yearPosition := yrPos. delimiter := aCharacter. monthType := moType. yearType := yrType. ^ self.! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: (ex description includesSubstring: aString) ] ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! assertCollection: actual equals: expected "Specialized test method that generates a proper error message for collection" ^ self assert: expected = actual description: [ self comparingCollectionBetween: actual and: expected ]! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! should: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: 'SeanDeNigris 6/20/2012 03:42'! tokens ^ self printFormat findTokens: { delimiter }.! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! fail ^self assert: false! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! skipUnless: aBooleanOrBlock " If the assumption in aBooleanOrBlock is not true, abandon the running test and mark it as passed. " aBooleanOrBlock value ifFalse: [ TestSkip signal: 'Assumption in #skipUnless: failed' ]! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: ''! should: aBlock notTakeMoreThanMilliseconds: anInteger "For compatibility with other Smalltalks" self should: aBlock notTakeMoreThan: (Duration milliSeconds: anInteger).! ! !DatePrintFormatTester methodsFor: 'as yet unclassified' stamp: ''! fail: aDescriptionString ^self assert: false description: aDescriptionString! ! !DatePrintFormatTester class methodsFor: 'instance creation' stamp: 'SeanDeNigris 6/20/2012 03:17'! on: aDate ^ self new date: aDate.! ! !DateTest commentStamp: 'brp 7/26/2003 16:58'! This is the unit test for the class Date. ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:40'! testInquiries self assert: june2nd1973 dayOfMonth equals: 2; assert: june2nd1973 dayOfYear equals: 153; assert: june2nd1973 daysInMonth equals: 30; assert: june2nd1973 daysInYear equals: 365; assert: june2nd1973 daysLeftInYear equals: (365 - 153); assert: june2nd1973 firstDayOfMonth equals: 152. ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:35'! testLeap | dateInLeapYear dateInNonLeapYear | dateInLeapYear := january23rd2004. dateInNonLeapYear := dateInLeapYear + 365 days. self assert: dateInLeapYear leap equals: 1. self assert: dateInNonLeapYear leap equals: 0. ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 01:49'! testDaysInMonthForYear self assert: (Date daysInMonth: #February forYear: 2008) equals: 29. self assert: (Date daysInMonth: #February forYear: 2000) equals: 29. self assert: (Date daysInMonth: #February forYear: 2100) equals: 28. self assert: (Date daysInMonth: #July forYear: 2100) equals: 31. ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 03:55'! testPrintOnFormat | expected stream | expected := '04*Jan*23'. stream := ReadWriteStream on: ''. january23rd2004 printOn: stream format: #(3 2 1 $* 2 2). self assert: stream contents equals: expected.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:14'! testAddMonths self assert: (january23rd2004 addMonths: 0) equals: '2004-01-23' asDate. self assert: (january23rd2004 addMonths: 1) equals: '2004-02-23' asDate. self assert: (january23rd2004 addMonths: 12) equals: '2005-01-23' asDate.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:46'! testNext | nextDay | nextDay := june2nd1973 next. self assert: nextDay equals: '3 June, 1973' asDate.! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:54'! testReadFromPatternRecognizesCorrectlyTheYYYYPattern | pattern | pattern := 'd.m.yyyy'. self assertReading: '4.2.2345' as: pattern equals: (Date year: 2345 month: 2 day: 4). self assertReading: '4.2.234' as: pattern equals: (Date year: 234 month: 2 day: 4). self assertReading: '4.2.23' as: pattern equals: (Date year: 2023 month: 2 day: 4)! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 04:07'! testSubtractDays self assert: (january23rd2004 subtractDays: 0) equals: '2004-01-23' asDate. self assert: (january23rd2004 subtractDays: 30) equals: '2003-12-24' asDate.! ! !DateTest methodsFor: 'helpers' stamp: ''! restoreLocalTimeZoneAfter: aBlock | realTimeZone | realTimeZone := DateAndTime localTimeZone. aBlock ensure: [ DateAndTime localTimeZone: realTimeZone ].! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:47'! testPrevious | previousDay | previousDay := june2nd1973 previous. self assert: previousDay equals: '1 June, 1973' asDate.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 01:46'! testComparing | sameDate laterDate earlierDate | sameDate := june2nd1973 asString asDate. laterDate := june2nd1973 + 1 day. earlierDate := june2nd1973 - 1 day. self assert: june2nd1973 equals: sameDate; assert: june2nd1973 equals: june2nd1973 copy; assert: june2nd1973 hash equals: sameDate hash. self assert: june2nd1973 < laterDate; assert: june2nd1973 > earlierDate. ! ! !DateTest methodsFor: 'tests' stamp: 'CamilloBruni 7/17/2012 08:32'! testFromSeconds | d | d := self dateClass fromSeconds: june2nd1973 asSeconds. self assert: d equals: june2nd1973. ! ! !DateTest methodsFor: 'private' stamp: 'brp 8/24/2003 00:10'! dateClass ^ Date! ! !DateTest methodsFor: 'tests' stamp: 'CamilloBruni 7/13/2012 21:14'! testAsSeconds | secondsSinceEpoch dateUTC dateEDT datePST | self useTimeZone: 'UTC' during: [ dateUTC := Date readFrom: '01-23-2004' readStream. secondsSinceEpoch := (dateUTC start - DateAndTime epoch) asSeconds. self assert: dateUTC asSeconds equals: secondsSinceEpoch. self assert: (Date fromSeconds: dateUTC asSeconds) equals: dateUTC ]. self useTimeZone: 'EDT' during: [ dateEDT := Date readFrom: '01-23-2004' readStream. secondsSinceEpoch := (dateEDT start - DateAndTime epoch) asSeconds. self assert: dateEDT asSeconds equals: secondsSinceEpoch. self assert: (Date fromSeconds: dateEDT asSeconds) equals: dateEDT ]. self useTimeZone: 'PST' during: [ datePST := Date readFrom: '01-23-2004' readStream. secondsSinceEpoch := (datePST start - DateAndTime epoch) asSeconds. self assert: datePST asSeconds equals: secondsSinceEpoch. self assert: (Date fromSeconds: datePST asSeconds) equals: datePST ]. self assert: dateUTC asSeconds equals: dateEDT asSeconds - (4*3600). self assert: dateUTC asSeconds equals: datePST asSeconds - (8*3600). ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 01:43'! testAccessing self assert: june2nd1973 day = 153; assert: june2nd1973 julianDayNumber = 2441836; assert: june2nd1973 leap = 0; assert: june2nd1973 monthIndex = 6; assert: june2nd1973 monthName = #June; assert: june2nd1973 weekday = #Saturday; assert: june2nd1973 weekdayIndex = 7; assert: june2nd1973 year = 1973. ! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:48'! assertReading: aString as: aPattern equals: aDate self assert: (self dateClass readFrom: aString readStream pattern: aPattern) equals: aDate ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 04:00'! testStarting | aDateAndTime anyTime | anyTime := '13:12' asTime. aDateAndTime := DateAndTime date: january23rd2004 time: anyTime. self assert: (Date starting: aDateAndTime) equals: january23rd2004. ! ! !DateTest methodsFor: 'tests' stamp: 'MarcusDenker 4/25/2013 15:08'! testStoring | expected actual | expected := '''2 June 1973'' asDate'. actual := june2nd1973 storeString. self assert: actual equals: expected; assert: (Smalltalk evaluate: expected) equals: june2nd1973. "Evaluating expected to avoid surprises when evaluating" ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 04:06'! testSubtractDate self assert: (january23rd2004 subtractDate: january23rd2004 previous) equals: 1. self assert: (january23rd2004 subtractDate: january23rd2004) equals: 0. self assert: (january23rd2004 subtractDate: january23rd2004 next) equals: -1. ! ! !DateTest methodsFor: 'helpers' stamp: 'CamilloBruni 11/4/2013 08:42'! epoch ^ Date year: 1901 month: 1 day: 1! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:53'! testReadFromPatternRecognizesCorrectlyTheYPattern | pattern | pattern := 'd.m.y'. self assertReading: '4.2.3113' as: pattern equals: (Date year: 3113 month: 2 day: 4). self assertReading: '4.2.113' as: pattern equals: (Date year: 113 month: 2 day: 4). self assertReading: '4.2.13' as: pattern equals: (Date year: 2013 month: 2 day: 4)! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 01:43'! testDayMonthYearDo january23rd2004 dayMonthYearDo: [ :day :month :year | self assert: day equals: 23. self assert: month equals: 1. self assert: year equals: 2004 ].! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:50'! testReadFromPatternRecognizesCorrectlyTheDPattern | pattern | pattern := 'd.mm.yyyy'. self assertReading: '4.02.2345' as: pattern equals: (Date year: 2345 month: 2 day: 4). self assertReading: '14.12.2345' as: pattern equals: (Date year: 2345 month: 12 day: 14). ! ! !DateTest methodsFor: 'helpers' stamp: ''! useNonUtcTimeZoneDuring: aBlock self useTimeZone: 'EDT' during: aBlock.! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:48'! testEscapePatternCanBeAnywhere self assertReading: '4.b2.c2345' as: 'd.\bm.\cy' equals: (Date year: 2345 month: 2 day: 4). ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 03:54'! testPrintOn | expected stream | expected := '23 January 2004'. stream := ReadWriteStream on: ''. january23rd2004 printOn: stream. self assert: stream contents equals: expected.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 04:10'! testYyyymmdd self assert: january23rd2004 yyyymmdd equals: '2004-01-23'! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:51'! testReadFromPatternRecognizesCorrectlyTheMMPattern | pattern | pattern := 'd.mm.yyyy'. self assertReading: '4.02.2345' as: pattern equals: (Date year: 2345 month: 2 day: 4). self assertReading: '4.12.2345' as: pattern equals: (Date year: 2345 month: 12 day: 4). self assertReading: '4.2.2345' as: pattern equals: nil ! ! !DateTest methodsFor: 'tests' stamp: 'PavelKrivanek 12/19/2012 12:56'! testPrintFormat | format monthTypes | format := DatePrintFormatTester on: january23rd2004. format dayPosition: 1 monthPosition: 2 yearPosition: 3 delimiter: $/ monthType: 1 yearType: 1. format shouldEqual: '23/1/2004'. format delimiter: $-. format shouldEqual: '23-1-2004'. format monthType: 1 shouldPrintAs: 1 asString "index". format monthType: 2 shouldPrintAs: 'Jan'. format monthType: 3 shouldPrintAs: 'January'. "Out of range month types leave month blank" format monthType: 4. format shouldEqual: '23--2004' "no month". format yearType: 1 shouldPrintAs: '2004'. format yearType: 2 shouldPrintAs: '04'. "Out of range year types -> short year" format yearType: 3 shouldPrintAs: '04'. "Usage examples" self assert: june2nd1973 mmddyyyy = '6/2/1973'; assert: june2nd1973 yyyymmdd = '1973-06-02'; assert: (june2nd1973 printFormat: #(3 1 2 $!! 2 1 1)) = '1973!!2!!Jun'; assert: (june2nd1973 printFormat: #(1 2 3 0 1 1 2)) = '02061973'; assert: (june2nd1973 printFormat: #(2 1 3 0 1 1 2)) = '06021973'; assert: (june2nd1973 printFormat: #(3 2 1 0 1 1 2)) = '19730602'; assert: (june2nd1973 printFormat: #(1 2 3 0 1 1 1)) = '261973'.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:45'! testPreviousByName self assert: (january23rd2004 previous: #Friday) equals: '2004-01-16' asDate. ! ! !DateTest methodsFor: 'tests' stamp: 'CamilloBruni 7/17/2012 17:22'! testFromDays | march18th1627 epochFromDays june2nd1973FromDays march18th1627FromDays january23rd2004FromDays | epochFromDays := self dateClass fromDays: 0. self assert: epochFromDays equals: (self epoch translateTo: 0). june2nd1973FromDays := self dateClass fromDays: (june2nd1973 - self epoch) asDays. self assert: june2nd1973FromDays equals: (june2nd1973 translateTo: 0). march18th1627 := '18 March 1627' asDate. march18th1627FromDays := self dateClass fromDays: (march18th1627 - self epoch) asDays. self assert: march18th1627FromDays equals: (march18th1627 translateTo: 0). january23rd2004FromDays := self dateClass fromDays: 103*365 "years" + 22 "days since Jan 1" + 25 "leap days". self assert: january23rd2004FromDays equals: (january23rd2004 translateTo: 0). ! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:54'! testReadFromPatternRecognizesCorrectlyTheYYPattern | pattern | pattern := 'd.m.yy'. self assertReading: '4.2.3113' as: pattern equals: (Date year: 2031 month: 2 day: 4). self assertReading: '4.2.13' as: pattern equals: (Date year: 2013 month: 2 day: 4). self assertReading: '4.2.1' as: pattern equals: (Date year: 2001 month: 2 day: 4)! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:29'! testNameOfDay | dayNames firstDayName | firstDayName := self dateClass nameOfDay: 1. self assert: firstDayName equals: #Sunday. dayNames := #(#Sunday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday). (1 to: 7) do: [ :i | | dayName | dayName := self dateClass nameOfDay: i. self assert: dayName equals: (dayNames at: i) ].! ! !DateTest methodsFor: 'coverage' stamp: 'brp 7/27/2003 13:01'! classToBeTested ^ self dateClass! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 01:51'! testEqual self assert: january23rd2004 = 'January 23, 2004' asDate.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 04:09'! testTomorrow "Not a great test: could falsely fail if midnight come in between the two executions" self assert: Date tomorrow equals: Date today + 1 day.! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:55'! testReadFromPatternReturnsNilWhenScapePatternIsNotFollowed self assertReading: 'b4.2.2345' as: '\ad.m.y' equals: nil! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 03:58'! testReadFrom | s1 s2 s3 s4 s5 | s1 := '2 June 1973' readStream. s2 := '2-JUN-73' readStream. s3 := 'June 2, 1973' readStream. s4 := '6/2/73' readStream. s5 := '2JUN73' readStream. self assert: (self dateClass readFrom: s1) equals: june2nd1973; assert: (self dateClass readFrom: s2) equals: june2nd1973; assert: (self dateClass readFrom: s3) equals: june2nd1973; assert: (self dateClass readFrom: s4) equals: june2nd1973.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:42'! testMmddyyyy self assert: january23rd2004 mmddyyyy equals: '1/23/2004'! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:52'! testReadFromPatternRecognizesCorrectlyTheMPattern | pattern | pattern := 'd.m.yyyy'. self assertReading: '4.2.2345' as: pattern equals: (Date year: 2345 month: 2 day: 4). self assertReading: '4.12.2345' as: pattern equals: (Date year: 2345 month: 12 day: 4). ! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:50'! testReadFromPatternRecognizesCorrectlyTheDDPattern | pattern | pattern := 'dd.mm.yyyy'. self assertReading: '4.02.2345' as: pattern equals: nil. self assertReading: '14.12.2345' as: pattern equals: (Date year: 2345 month: 12 day: 14). ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 01:50'! testDuration self assert: january23rd2004 duration equals: 24 hours.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 01:46'! testAsDate self assert: january23rd2004 asDate equals: january23rd2004.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 01:49'! testDaysInYear self assert: (Date daysInYear: 2000) equals: 366. self assert: (Date daysInYear: 2008) equals: 366. self assert: (Date daysInYear: 2100) equals: 365 ! ! !DateTest methodsFor: 'tests' stamp: 'CamilloBruni 7/17/2012 17:18'! testJulianDayNumber self assert: (january23rd2004 translateTo: 0) equals: (Date julianDayNumber: ((4713+2004)*365 +1323) offset: 0 hour).! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 04:09'! testYesterday "Not a great test: could falsely fail if midnight come in between the two executions" self assert: Date yesterday equals: Date today - 1 day. ! ! !DateTest methodsFor: 'coverage' stamp: 'brp 1/30/2005 09:03'! selectorsToBeIgnored | deprecated private special | deprecated := #(). private := #(). special := #( #< #= #new #next #previous #printOn: #printOn:format: #storeOn: #fromString: ). ^ super selectorsToBeIgnored, deprecated, private, special! ! !DateTest methodsFor: 'tests' stamp: 'CamilloBruni 8/22/2013 19:46'! testNewDayMonthYear self assert: (Date year: 2004 month: 1 day: 23) equals: january23rd2004. ! ! !DateTest methodsFor: 'helpers' stamp: ''! useTimeZone: abbreviation during: aBlock | timeZone | timeZone := TimeZone abbreviated: abbreviation. self restoreLocalTimeZoneAfter: [ DateAndTime localTimeZone: timeZone. aBlock cull: timeZone ].! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:55'! testReadFromPatternRecognizesScapePattern self assertReading: 'a4.2.2345' as: '\ad.m.y' equals: (Date year: 2345 month: 2 day: 4). ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:27'! testDayOfWeek | dayNames sundayIndex | sundayIndex := self dateClass dayOfWeek: #Sunday. self assert: sundayIndex equals: 1. dayNames := #(#Sunday #Monday #Tuesday #Wednesday #Thursday #Friday #Saturday). dayNames doWithIndex: [ :e :i | | dayIndex | dayIndex := self dateClass dayOfWeek: e. self assert: dayIndex equals: i ].! ! !DateTest methodsFor: 'tests' stamp: 'CamilloBruni 11/4/2013 08:41'! testNew | instance epoch | instance := self dateClass new. epoch := self epoch. "We have to be careful, since #new creates a Date for midnight in the local timezone, whereas #epoch is based on a fixed time in UTC" instance offset negative ifTrue: [ epoch := epoch - 1 day ]. self assert: instance equals: epoch.! ! !DateTest methodsFor: 'running' stamp: 'CamilloBruni 8/22/2013 19:49'! setUp june2nd1973 := self dateClass year: 1973 day: 153. january23rd2004 := Date readFrom: '01-23-2004' readStream. aTime := Time readFrom: '12:34:56 pm' readStream! ! !DateTest methodsFor: 'tests' stamp: 'CamilloBruni 8/22/2013 19:49'! testNewDayYear self assert: (Date year: 2004 day: 23) equals: january23rd2004 ! ! !DateTest methodsFor: 'tests - readFrom:pattern:' stamp: 'HernanWilkinson 11/7/2013 14:49'! testReadFromPatternAcceptsSameCharsInPatternAndInput self assertReading: 'a4.2.2345' as: 'ad.m.y' equals: (Date year: 2345 month: 2 day: 4). ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 01:46'! testArithmetic | laterDate | laterDate := june2nd1973 addDays: 32. self assert: (laterDate subtractDate: june2nd1973) equals: 32; assert: (june2nd1973 subtractDate: laterDate) equals: -32; assert: (laterDate subtractDays: 32) equals: june2nd1973. ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 01:45'! testAddDays self assert: (january23rd2004 addDays: 0) equals: '2004-01-23' asDate. self assert: (january23rd2004 addDays: 31) equals: '2004-02-23' asDate. self assert: (january23rd2004 addDays: 366) equals: '2005-01-23' asDate.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 01:51'! testFirstWeekdayOfMonthYear self assert: (Date firstWeekdayOfMonth: 'January' year: 2004) equals: 5. ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:22'! testIndexOfMonth self assert: (Date indexOfMonth: #January) equals: 1. self assert: (Date indexOfMonth: #December) equals: 12. self should: [ Date indexOfMonth: #NonExistantMonth ] raise: Error.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 04:09'! testWeekday self assert: january23rd2004 weekday equals: #Friday. self assert: january23rd2004 weekdayIndex equals: 6.! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:20'! testNameOfMonth self assert: (Date nameOfMonth: 1) equals: #January. self assert: (Date nameOfMonth: 12) equals: #December. self should: [ Date nameOfMonth: 0 ] raise: SubscriptOutOfBounds. self should: [ Date nameOfMonth: 13 ] raise: SubscriptOutOfBounds. ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 04:01'! testStoreOn | expected stream | expected := '''23 January 2004'' asDate'. stream := ReadWriteStream on: ''. january23rd2004 storeOn: stream. self assert: stream contents equals: expected.! ! !DebugAction commentStamp: ''! A DebugAction is the entry point for creating debugging actions. A new debugging action is created by subclassing it and implementing, by default, the method executeAction (This can be configured by using the method actionSelector). An id must also be provided uniquely identifying the action among all the others. The initialize method should only set default values or initialize attributes that are independent of the debugger or session. The others must be initilized in the method forDebugger:. A debugging action has the following lifecycle: - the action is created using #new and #initialized is called - #appliesToDebugger:, and for contextual actions #appliesToContext: are called - if the actions applies to the current situation #forDebugger: is used to set the debugger - #execute is called when the user triggers the action. - when the debugger updates its action this process is repeated.! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 8/8/2013 12:01'! icon ^ icon ifNil: [ self defaultIcon ]! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/20/2013 15:58'! enabled ^ true! ! !DebugAction methodsFor: 'accessing-context' stamp: 'AndreiChis 9/18/2013 10:53'! currentContext ^ self debugger currentContext! ! !DebugAction methodsFor: '*spec-debugger' stamp: 'AndreiChis 9/25/2013 17:16'! specId ^ (self id, 'SpecId') asSymbol! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/18/2013 18:59'! needsUpdate ^ needsUpdate ifNil: [ true ]! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/17/2013 19:20'! defaultIcon ^ self class defaultIcon! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 6/17/2013 16:16'! debugger: anObject debugger := anObject! ! !DebugAction methodsFor: 'testing' stamp: 'AndreiChis 9/18/2013 17:25'! appliesToCurrentContext ^ self appliesToContext: self currentContext ! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 7/3/2013 17:31'! needsUpdate: aBoolean needsUpdate := aBoolean! ! !DebugAction methodsFor: 'testing' stamp: 'AndreiChis 9/20/2013 17:12'! appliesToDebugger: aDebugger ^ true! ! !DebugAction methodsFor: 'testing' stamp: 'AndreiChis 6/10/2013 18:44'! appliesToContext: aContext ^ true! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 8/7/2013 19:08'! defaultCategory ^ nil! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 6/10/2013 18:34'! debugger ^ debugger! ! !DebugAction methodsFor: 'actions' stamp: 'AndreiChis 8/26/2013 12:02'! defaultActionSelector ^ #executeAction! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 7/17/2013 22:59'! defaultOrder ^ 0! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/21/2013 21:16'! keyText ^ keyText ifNil: [ self defaultKeyText ]! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 16:31'! needsSeparatorAfter: aBoolean needsSeparatorAfter := aBoolean! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 6/10/2013 18:35'! needsValidation: anObject needsValidation := anObject! ! !DebugAction methodsFor: 'accessing-context' stamp: 'AndreiChis 6/20/2013 14:41'! interruptedContext ^ self debugger interruptedContext ! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 6/10/2013 18:40'! label: aString label := aString! ! !DebugAction methodsFor: 'accessing-context' stamp: 'AndreiChis 6/17/2013 15:51'! selectedContext ^ self debugger selectedContext ! ! !DebugAction methodsFor: '*spec-debugger' stamp: 'AndreiChis 9/25/2013 17:03'! specModel ^ #SpecDebugActionButton! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 15:57'! asDebugAction ^ self! ! !DebugAction methodsFor: 'initialization' stamp: 'AndreiChis 9/18/2013 11:45'! forDebugger: aDebugger self debugger: aDebugger! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/21/2013 21:12'! keyText: aString keyText := aString! ! !DebugAction methodsFor: '*spec-debugger' stamp: 'AndreiChis 12/20/2013 20:52'! shortcutCommand self flag: 'hacky solution to still be compatible with the GTDebugger (for the moment)'. ^ self keyText ifNotNil: [:aString | aString first isUppercase ifTrue: [ aString first command shift ] ifFalse: [ aString first command ] ]! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 8/7/2013 19:07'! category ^ category ifNil: [ self defaultCategory ]! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 6/5/2013 15:03'! session ^ self debugger session! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 16:21'! needsSeparatorAfter ^ needsSeparatorAfter ifNil: [ false ]! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/19/2013 17:20'! order ^ order ifNil: [ self defaultOrder ]! ! !DebugAction methodsFor: 'actions' stamp: 'AndreiChis 9/24/2013 17:00'! precondition ^ self needsValidation not or: [ self debugger okToChange ]! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 15:37'! id ^ nil! ! !DebugAction methodsFor: 'actions' stamp: 'AndreiChis 8/26/2013 12:04'! executeAction "By default do nothing." ! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/21/2013 21:16'! defaultKeyText ^ nil ! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 6/17/2013 11:07'! icon: anObject icon := anObject! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 7/12/2013 16:38'! label ^ label ifNil: [ self defaultLabel ]! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/18/2013 19:00'! needsValidation ^ needsValidation ifNil: [ true ]! ! !DebugAction methodsFor: '*spec-debugger' stamp: 'AndreiChis 12/20/2013 14:59'! asMenuRegistrationIn: aBuilder | item | item := (aBuilder item: self specId) label: self label, (self keyText ifNil: [ '' ] ifNotNil: [ ' (', self keyText, ')' ] ); icon: self icon; enabled: self enabled; order: self order asFloat; target: self; selector: #execute; arguments: #(). self needsSeparatorAfter ifTrue: [ item withSeparatorAfter ]. ^ item ! ! !DebugAction methodsFor: 'actions' stamp: 'AndreiChis 8/26/2013 12:03'! actionSelector ^ actionSelector ifNil: [ self defaultActionSelector ]! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 7/12/2013 16:38'! defaultLabel ^ ''! ! !DebugAction methodsFor: 'actions' stamp: 'AndreiChis 9/24/2013 17:01'! execute self precondition ifTrue: [ self perform: self actionSelector. self postAction ] ! ! !DebugAction methodsFor: 'actions' stamp: 'AndreiChis 9/24/2013 17:16'! notifyDebugger self needsUpdate ifTrue: [ self debugger announce: (DebugActionExecuted forDebuggingAction: self) ]! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 6/10/2013 18:40'! order: anInteger order := anInteger! ! !DebugAction methodsFor: 'actions' stamp: 'AndreiChis 9/24/2013 16:57'! postAction self notifyDebugger! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 16:31'! withSeparatorAfter self needsSeparatorAfter: true! ! !DebugAction methodsFor: 'accessing' stamp: 'AndreiChis 7/3/2013 17:31'! category: anObject category := anObject! ! !DebugAction class methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 15:57'! asDebugAction ^ self new! ! !DebugAction class methodsFor: 'instance creation' stamp: 'AndreiChis 6/26/2013 23:06'! forDebugger: aDebugger ^ self new forDebugger: aDebugger! ! !DebugAction class methodsFor: 'accessing' stamp: 'AndreiChis 9/17/2013 19:20'! defaultIcon ^ nil! ! !DebugActionExecuted commentStamp: ''! A DebugActionExecuted is an event send to the debugger after a debugging actions that has the flag #needsUpdate set to true is executed. Instance Variables actionId: actionId - xxxxx ! !DebugActionExecuted methodsFor: 'as yet unclassified' stamp: 'AndreiChis 9/24/2013 17:15'! actionId: aSymbol actionId := aSymbol! ! !DebugActionExecuted class methodsFor: 'as yet unclassified' stamp: 'AndreiChis 9/24/2013 17:15'! forDebuggingAction: anAction ^ self new actionId: anAction id! ! !DebugContext commentStamp: ''! A DebugContext is a helper that complements DebugSession. It is meant to be created dynamically on a context when the session wants to access the provided services. To create instances first call forContext: to set the current context, and then if the interrupted is different use topContext: Not sure if it is still a good idea to have this class. Instance Variables context: method: methodNode: ranges: topContext: context - xxxxx method - xxxxx methodNode - xxxxx ranges - xxxxx topContext - xxxxx ! !DebugContext methodsFor: 'accessing' stamp: 'AndreiChis 1/7/2013 10:29'! selectedClass "Answer the class in which the current context's method was found." ^ context methodClass! ! !DebugContext methodsFor: 'private' stamp: 'BenComan 3/15/2014 00:51'! blockNotFoundDialog: aMethod with: aText | browser message result | message := 'Method for block not found on stack, can''t edit and continue'. "shouldn't edit doits" aMethod selector isDoIt ifTrue: [ ^ self inform: message ]. result := UIManager default confirm: message trueChoice: 'Browse' translated falseChoice: 'Cancel' translated. "possible return values are true | false | nil" result == true ifFalse: [ ^ self ]. "let's browse the given method with the edited contents" browser := aMethod browse. browser contents: aText; changed: #contents. browser codeTextMorph hasUnacceptedEdits: true! ! !DebugContext methodsFor: 'initialization' stamp: 'AndreiChis 2/6/2013 14:41'! forContext: aContext context := aContext. topContext := aContext.! ! !DebugContext methodsFor: 'accessing' stamp: 'AndreiChis 1/7/2013 10:29'! receiver ^ context receiver! ! !DebugContext methodsFor: 'accessing' stamp: 'AndreiChis 7/20/2013 09:34'! selectedMessageName "Answer the message selector of the current context. If the method is unbound we can still usefully answer its old selector." ^ context messageName! ! !DebugContext methodsFor: 'accessing' stamp: 'AndreiChis 1/7/2013 10:29'! selectedMessageCategoryName "Answer the name of the message category of the message of the current context." ^ self selectedClass organization categoryOfElement: self selectedMessageName! ! !DebugContext methodsFor: 'accessing' stamp: 'AndreiChis 6/10/2013 15:54'! locateClosureHomeWithContent: aText "In case the current context is a BlockContext locate the closureHome and ask the user to validate the new context. If closureHome is not found or the user does not validate the new context, return nil. aText is the new content of the current context. If the current context is not a BlockContext return it." | closureHome | context isBlockContext ifTrue: [ closureHome := context activeHome. closureHome ifNil: [ self blockNotFoundDialog: context method with: aText. ^ nil ]. (self confirm: 'I will have to revert to the method from\which this block originated. Is that OK?' withCRs) ifFalse: [ ^ nil ]. ^ closureHome]. ^ context! ! !DebugContext methodsFor: 'private' stamp: 'AndreiChis 2/6/2013 14:42'! source "Answer the source code of the currently selected context." ^ context sourceCode! ! !DebugContext methodsFor: 'initialization' stamp: 'AndreiChis 1/7/2013 10:29'! topContext: aContext topContext := aContext ! ! !DebugContext methodsFor: 'evaluating actions' stamp: 'MarcusDenker 9/5/2013 12:50'! evaluate: expression ^ Smalltalk compiler source: expression; context: context; receiver: context receiver; evaluate! ! !DebugContext methodsFor: 'evaluating actions' stamp: 'ClementBera 7/26/2013 16:37'! recompileCurrentMethodTo: aText notifying: aNotifyer | classOfMethod selector | classOfMethod := self selectedClass. selector := classOfMethod compiler parseSelector: aText. (selector == self selectedMessageName or: [(self selectedMessageName isDoIt) and: [selector numArgs = self selectedMessageName numArgs]]) ifFalse: [ self inform: 'can''t change selector'. ^ nil]. selector := classOfMethod compile: aText classified: self selectedMessageCategoryName notifying: aNotifyer. ^ selector ifNotNil: [ classOfMethod compiledMethodAt: selector ] ! ! !DebugContext methodsFor: 'accessing' stamp: 'AndreiChis 1/7/2013 10:29'! receiverClass "Answer the class of the receiver. It may differ from 'self selectedClass' " ^ context receiver class! ! !DebugContext methodsFor: 'accessing' stamp: 'AndreiChis 1/11/2013 17:51'! context ^ context! ! !DebugContext class methodsFor: 'instance creation' stamp: 'AndreiChis 1/7/2013 10:29'! forContext: aContext ^ self new forContext: aContext ! ! !DebugSession commentStamp: ''! A DebugSession models a debuggeing session. It contains the interrupted context and process. Its main goal is to handle debugger actions such as restart or stepInto, as well as recomplilation of methods. It is the model used as an input to a ui. As it is just a model it does now contain any information related to the ui. For example, it does not know what a selection in the ui is. It is the job on the ui to maintain the selection and call this session with the propper context. To create sessions use the mehod 'process: aProcess context: aContext'. aContext must be a context belonging to aProcess, and aProcess must be an interrupted process. Instance Variables context: errorWasInUIProcess: process: context - xxxxx errorWasInUIProcess - xxxxx process - xxxxx ! !DebugSession methodsFor: 'evaluating' stamp: 'AndreiChis 7/19/2013 17:56'! rewindContextToMethod: aMethod fromContext: aContext "this method is typically to be used after a hot compilation of a method from the stack. in order to return to the context containg the compiled method." | ctxt | ctxt := interruptedProcess popTo: aContext. ctxt == aContext ifFalse: [ self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withCRs ] ifTrue: [ aMethod isQuick ifFalse: [ interruptedProcess restartTopWith: aMethod; stepToSendOrReturn ] ]. self updateContextTo: ctxt. "Issue 3015 - Hernan" self isInterruptedContextATest ifTrue: [ self prepareTestToRunAgain ].! ! !DebugSession methodsFor: 'initialization' stamp: 'ClementBera 7/26/2013 16:37'! process: aProcess context: aContext "aProcess stepToSendOrReturn ." "aProcess isSuspended ifTrue: [ aProcess stepToSendOrReturn ]." interruptedProcess := aProcess. interruptedContext := self filterTopContext: aContext. interruptedContext ifNil: [interruptedContext := aContext]. ! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/19/2013 17:57'! stepOver: aContext "Send the selected message in selectedContext, and regain control after the invoked method returns." | newContext | (self isContextPostMortem: aContext) ifTrue: [^ self]. newContext := interruptedProcess completeStep: aContext. self updateContextTo: (newContext == aContext ifTrue: [ interruptedProcess stepToSendOrReturn ] ifFalse: [ newContext ]). self triggerEvent: #stepOver ! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/22/2013 14:28'! runToSelection: selectionInterval inContext: aContext "Attempt to step over instructions in selectedContext until the execution reaches the selected instruction. This happens when the program counter passes the begining of selectionInterval. A not nill and valid interval is expected." (self pcRangeForContext: aContext) first >= selectionInterval first ifTrue: [ ^self ]. self stepOver: aContext. [ aContext == self interruptedContext and: [ (self pcRangeForContext: aContext) first < selectionInterval first ] ] whileTrue: [ self stepOver: aContext ]! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/19/2013 17:56'! stepInto self stepInto: interruptedContext! ! !DebugSession methodsFor: 'accessing' stamp: 'AndreiChis 4/2/2013 14:46'! errorWasInUIProcess ^ errorWasInUIProcess! ! !DebugSession methodsFor: 'context' stamp: 'AndreiChis 2/6/2013 14:15'! downInContext: aContext "move down the context stack to the previous (enclosing) context" self flag: 'This does not take into account (bypasses) filtering'. ^ aContext sender. ! ! !DebugSession methodsFor: 'accessing' stamp: 'AndreiChis 7/22/2013 14:14'! interruptedContext ^ interruptedContext! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 9/24/2013 13:30'! returnValue: anObject from: aContext "Force a return of a given value to the previous context!!" | previous | self flag: 'should be called only on the selected context. WHY?'. (self isContextPostMortem: aContext) ifTrue: [^ self]. previous := aContext sender. " self resetContext: previous." interruptedProcess popTo: previous value: anObject. self updateContextTo: previous. self contextChanged ! ! !DebugSession methodsFor: 'testing' stamp: 'AndreiChis 1/7/2013 11:17'! isTestObject: anObject "I'm not sure this is the best way to doit because it creates a coupling with TestCase, but due that SUnit is part of the core I think it is not bad after all - Hernan'" ^ anObject isKindOf: TestCase! ! !DebugSession methodsFor: 'context' stamp: 'AndreiChis 6/4/2013 16:16'! contextChanged self triggerEvent: #contextChanged! ! !DebugSession methodsFor: 'context' stamp: 'AndreiChis 1/13/2013 19:19'! pcRangeForContext: aContext "Answer the indices in the source code for the method corresponding to aContext's program counter value." aContext isDead ifTrue: [^1 to: 0]. ^aContext debuggerMap rangeForPC: aContext pc contextIsActiveContext: (self isLatestContext: aContext)! ! !DebugSession methodsFor: 'private' stamp: 'AndreiChis 7/19/2013 17:56'! resumeProcess "Make sure the interrupted process is restored properly and restart the low space handler" interruptedProcess isTerminated ifFalse: [errorWasInUIProcess ifTrue: [UIManager default resumeUIProcess: interruptedProcess] ifFalse: [interruptedProcess resume]]. Smalltalk installLowSpaceWatcher. "restart low space handler". ! ! !DebugSession methodsFor: 'context' stamp: 'AndreiChis 7/19/2013 17:58'! isLatestContext: aContext ^ interruptedProcess suspendedContext == aContext! ! !DebugSession methodsFor: 'private' stamp: 'AndreiChis 6/4/2013 15:24'! installAlarm: aSelector self installAlarm: aSelector withArgument: #()! ! !DebugSession methodsFor: 'context' stamp: 'AndreiChis 1/7/2013 10:29'! shouldDisplayOnTopContext: aContext ^ aContext method selector ~= #halt! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/19/2013 17:57'! stepThrough: aContext "Send messages until you return to selectedContext. Used to step into a block in the method." (self isContextPostMortem: aContext) ifTrue: [^ self]. interruptedProcess stepToHome: aContext. self updateContextTo: interruptedProcess stepToSendOrReturn. self triggerEvent: #stepThrough ! ! !DebugSession methodsFor: 'testing' stamp: 'AndreiChis 7/22/2013 14:28'! isInterruptedContextDoesNotUnderstand ^ self interruptedContext selector == #doesNotUnderstand:! ! !DebugSession methodsFor: 'context' stamp: 'AndreiChis 7/19/2013 17:57'! updateContextTo: aContext interruptedContext := aContext! ! !DebugSession methodsFor: 'private' stamp: 'AndreiChis 7/22/2013 14:28'! prepareTestToRunAgain self interruptedContext receiver prepareToRunAgain! ! !DebugSession methodsFor: 'context' stamp: 'AndreiChis 1/7/2013 10:29'! previousPC: aContext ^ (aContext method pcPreviousTo: aContext pc) ifNil: [ aContext pc ]! ! !DebugSession methodsFor: 'accessing' stamp: 'AndreiChis 9/29/2013 16:10'! stackOfSize: limit usingFilters: stackFilters "Answer an OrderedCollection of the top 'limit' contexts on the receiver's sender chain, according to the given filters. Consider the following stack: a <-- top of the stack b a c a b d e a <-- bottom of the stack If the given filters do not match context 'a' and 'b' the following stack will be returned: a <-- top of the stack b a c d e <-- bottom of the stack First all consecutive contexts starting from the top of the stack for which a filter does not match are added to the result (a b a in the example). Then from the remaining stack only the context for which all filters match are added to the result. " | stack context | stack := OrderedCollection new. context := interruptedContext. "Starting from the top of the stack add all consecutive contexts that should not be displayed." [ context ~~ nil and: [(stack size < limit) and: [ (self shouldDisplayContext: context basedOnFilters: stackFilters) not ] ] ] whileTrue: [ stack addLast: context. context := context sender ]. "Add all contexts that should be displayed. (the current context is checked again)" [context ~~ nil and: [stack size < limit ] ] whileTrue: [ (self shouldDisplayContext: context basedOnFilters: stackFilters) ifTrue: [ stack addLast: context ]. context := context sender ]. ^ stack! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/20/2013 09:26'! toggleBreakOnEntryFor: aContext "Install or uninstall a halt-on-entry breakpoint" | selectedMethod | self flag: 'should be called only on the selected context'. selectedMethod := aContext classOrMetaClass >> aContext messageName. selectedMethod hasBreakpoint ifTrue: [BreakpointManager unInstall: selectedMethod] ifFalse: [BreakpointManager installInClass: aContext classOrMetaClass selector: aContext messageName].! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/19/2013 17:48'! restart: aContext "Proceed from the initial state of selectedContext." "Closing now depends on a setting (RestartAlsoProceeds class variable) --> not supported in this version" (self isContextPostMortem: aContext) ifTrue: [^ self]. self unwindAndRestartToContext: aContext. "Issue 3015 - Hernan" self isInterruptedContextATest ifTrue: [ self prepareTestToRunAgain ]. self triggerEvent: #restart ! ! !DebugSession methodsFor: 'accessing' stamp: 'AndreiChis 7/19/2013 17:56'! stack ^ interruptedContext stack! ! !DebugSession methodsFor: 'accessing' stamp: 'AndreiChis 7/19/2013 17:53'! context ^ interruptedContext! ! !DebugSession methodsFor: 'accessing' stamp: 'AndreiChis 7/19/2013 17:56'! stackOfSize: size ^ interruptedContext stackOfSize: size! ! !DebugSession methodsFor: 'accessing' stamp: 'AndreiChis 7/19/2013 17:53'! createModelForContext: aContext ^ (DebugContext forContext: aContext) topContext: interruptedContext! ! !DebugSession methodsFor: 'debugging actions' stamp: 'ClementBera 7/26/2013 16:37'! terminate "Action that needs to be executed after the window containing this debug session is closed, in order to terminate the right process." self interruptedProcess ifNotNil: [ "Assume the user closed the debugger. Simply kill the interrupted process." self interruptedProcess terminate. self clear. Smalltalk installLowSpaceWatcher. "restart low space handler" ] ifNil: [ "Assume the interrupted process was resumed." "Kill the active process if the error was in the UI as there should be only one UI process." errorWasInUIProcess == false ifFalse: [Processor terminateActive] ] ! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/19/2013 17:57'! stepOver self stepOver: interruptedContext! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/19/2013 17:48'! recompileMethodTo: text inContext: aContext notifying: aNotifyer "The retrieved information has changed and its source must now be updated. In this case, the retrieved information is the method of the given context." | newMethod recompilationContext | (recompilationContext := (self createModelForContext: aContext) locateClosureHomeWithContent: text) ifNil: [ ^ false ]. newMethod := (self createModelForContext: recompilationContext) recompileCurrentMethodTo: text notifying: aNotifyer. newMethod ifNil: [ ^ false ]. newMethod isQuick ifTrue: [ recompilationContext := self downInContext: recompilationContext. recompilationContext jump: (recompilationContext previousPc - recompilationContext pc) ]. self rewindContextToMethod: newMethod fromContext: recompilationContext. "Use an alarm instead of triggering the notification directly, as the content of the editor can still be unaccepted. " self installAlarm: #contextChanged. ^ true! ! !DebugSession methodsFor: 'evaluating' stamp: 'AndreiChis 9/20/2013 19:05'! implement: aMessage classified: aSymbol inClass: aClass forContext: aContext aClass compile: (DynamicMessageImplementor for: aMessage in: aClass) value classified: aSymbol. aContext privRefreshWith: (aClass lookupSelector: aMessage selector). aContext method numArgs > 0 ifTrue: [aMessage arguments withIndexDo: [:arg :index| aContext tempAt: index put: arg]]. self updateContextTo: aContext. self contextChanged! ! !DebugSession methodsFor: 'testing' stamp: 'AndreiChis 1/7/2013 11:17'! isTestMethod: aCompiledMethod of: aTestCase ^ aCompiledMethod selector = aTestCase selector! ! !DebugSession methodsFor: 'testing' stamp: 'ClaraAllende 10/31/2013 16:34'! shouldDisplayContext: aContext basedOnFilters: stackFilters "Return true if all filters match the given context, or false otherwise. True is returned if there are no filters." ^stackFilters allSatisfy: [ :aFilter | aFilter shouldDisplay: aContext ]. ! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/19/2013 17:57'! stepInto: aContext "Send the selected message in selectedContext, and take control in the method invoked to allow further step or send." (self isContextPostMortem: aContext) ifTrue: [^ self]. interruptedProcess step: aContext. self updateContextTo: interruptedProcess stepToSendOrReturn. self triggerEvent: #stepInto! ! !DebugSession methodsFor: 'evaluating' stamp: 'AndreiChis 7/19/2013 17:57'! unwindAndRestartToContext: aContext |ctx| ctx := interruptedProcess popTo: aContext. ctx == aContext ifTrue: [ "Only restart the process if the stack was unwind" interruptedProcess restartTop; stepToSendOrReturn ]. self flag: 'Should a warning be displayed if the the unwind failed?'. self updateContextTo: aContext! ! !DebugSession methodsFor: 'testing' stamp: 'AndreiChis 7/22/2013 14:28'! isInterruptedContextATest ^ (self isTestObject: self interruptedContext receiver) and: [ self isTestMethod: self interruptedContext method of: self interruptedContext receiver ]! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/19/2013 17:57'! stepThrough self stepThrough: interruptedContext! ! !DebugSession methodsFor: 'context' stamp: 'AndreiChis 9/30/2013 19:00'! activePC: aContext ^ (self isLatestContext: aContext) ifTrue: [ interruptedContext pc ] ifFalse: [ self previousPC: aContext ].! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/19/2013 17:54'! clear "If after resuming the process the user does plan to reuse this session with the same process, it should call this method." interruptedProcess := nil. self updateContextTo: nil! ! !DebugSession methodsFor: 'updating' stamp: 'AndreiChis 7/19/2013 17:57'! updateWithContext: newContext fromProcess: aProcess self process: aProcess context: newContext! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/22/2013 14:28'! resume "Proceed execution of the receiver's model, starting after the expression at which an interruption occurred." "If the user of this session does not plan to reuse it, it should call 'self clean' " Smalltalk okayToProceedEvenIfSpaceIsLow ifTrue: [ (self isContextPostMortem: self interruptedContext) ifTrue: [^ self]. self resumeProcess. self triggerEvent: #resume]. ! ! !DebugSession methodsFor: 'private' stamp: 'AndreiChis 6/4/2013 14:38'! installAlarm: aSelector withArgument: args World addAlarm: aSelector withArguments: args for: self at: Time millisecondClockValue + 200! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 7/19/2013 17:55'! peelToFirstLike: aContext "Peel the stack back to the second occurance of the currently selected message. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning. Also frees a lot of space!!" | ctxt | self flag: 'should be called only on the selected context'. (self isContextPostMortem: aContext) ifTrue: [^ self]. ctxt := interruptedProcess popTo: aContext findSecondToOldestSimilarSender. self updateContextTo: ctxt. self contextChanged ! ! !DebugSession methodsFor: 'testing' stamp: 'AndreiChis 9/20/2013 17:13'! isInterruptedContextPostMortem ^ self isContextPostMortem: self interruptedContext ! ! !DebugSession methodsFor: 'debugging actions' stamp: 'AndreiChis 9/24/2013 13:30'! returnValueFrom: aContext "Force a return of a given value to the previous context!!" | previous expression value | self flag: 'should be called only on the selected context'. self flag: 'remove me'. (self isContextPostMortem: aContext) ifTrue: [^ self]. expression := UIManager default request: 'Enter expression for return value:'. value := self class compiler source: expression; context: aContext; receiver: aContext receiver; evaluate. previous := aContext sender. " self resetContext: previous." interruptedProcess popTo: previous value: value. self updateContextTo: previous. self contextChanged ! ! !DebugSession methodsFor: 'accessing' stamp: 'AndreiChis 7/22/2013 14:14'! interruptedProcess ^ interruptedProcess! ! !DebugSession methodsFor: 'testing' stamp: 'AndreiChis 7/19/2013 17:54'! isContextPostMortem: selectedContext "return whether we're inspecting a frozen exception without a process attached" | suspendedContext | suspendedContext := interruptedProcess suspendedContext. suspendedContext ifNil: [ ^ false ]. (suspendedContext == selectedContext) ifTrue: [ ^ false ]. ^ (suspendedContext findContextSuchThat: [:c | c sender == selectedContext]) isNil! ! !DebugSession methodsFor: 'accessing' stamp: 'AndreiChis 2/6/2013 14:33'! selectedCodeRangeForContext: selectedContext ^ self pcRangeForContext: selectedContext! ! !DebugSession methodsFor: 'initialization' stamp: 'AndreiChis 7/19/2013 17:53'! errorWasInUIProcess: aBoolean errorWasInUIProcess := aBoolean! ! !DebugSession methodsFor: 'accessing' stamp: 'AndreiChis 7/19/2013 17:55'! process ^ interruptedProcess! ! !DebugSession methodsFor: 'context' stamp: 'AndreiChis 1/7/2013 10:29'! filterTopContext: aContext |ctx| ctx := aContext. (self shouldDisplayOnTopContext: ctx) ifTrue: [^ ctx]. [(ctx := ctx sender) ~~ nil] whileTrue: [(self shouldDisplayOnTopContext: ctx) ifTrue: [^ ctx]]. ^ nil! ! !DebugSession class methodsFor: 'actions registration' stamp: 'AndreiChis 9/18/2013 17:21'! debuggingActionsForPragma: aSymbol for: aDebugger ^ ((DebugAction allSubclasses select: [ :each | each hasAbstractMethods not ]) inject: OrderedCollection new into: [ :currentActions :aClass | currentActions addAll: ( self debuggingActionsFromClass: aClass forPragma: aSymbol forDebugger: aDebugger); yourself ])! ! !DebugSession class methodsFor: 'instance creation' stamp: 'AndreiChis 1/7/2013 10:29'! process: aProcess context: aContext ^ self new process: aProcess context: aContext! ! !DebugSession class methodsFor: 'actions registration' stamp: 'AndreiChis 9/24/2013 15:57'! debuggingActionsFromClass: aClass forPragma: aSymbol forDebugger: aDebugger | pragmas actions | pragmas := Pragma allNamed: aSymbol from: aClass class to: aClass class. actions := OrderedCollection new. pragmas do: [ :aPragma | actions addAll: ((aPragma methodClass soleInstance perform: aPragma selector withEnoughArguments: {aDebugger}) asOrderedCollection collect: [ :each | each asDebugAction ]) ]. ^ actions ! ! !DebugSession class methodsFor: 'actions registration' stamp: 'AndreiChis 9/21/2013 18:51'! debuggingActionsForPragmas: aSymbolsCollection for: aDebugger self flag: 'split me'. ^ (((aSymbolsCollection inject: OrderedCollection new into: [ :currentActions :aSymbol | currentActions addAll: (self debuggingActionsForPragma: aSymbol for: aDebugger); yourself ]) select: [ :aDebugAction | aDebugAction appliesToDebugger: aDebugger ]) collect: [ :aDebugAction | aDebugAction forDebugger: aDebugger; yourself ]) sort: [ :action1 :action2 | action1 order < action2 order ]! ! !DebugSystemSettings commentStamp: 'TorstenBergmann 2/12/2014 23:30'! Settings for debugging! !DebugSystemSettings class methodsFor: 'private - settings' stamp: 'AndreiChis 9/29/2013 14:24'! addDebugFilterSessingsOn: aBuilder | stackWidgetClass | stackWidgetClass := Smalltalk tools debugger stackWidgetClass. (aBuilder group: #BasicFilters) label: 'Basic Filters' translated; description: 'default filtering configurations' translated; target: Smalltalk tools debugger; with: [ (aBuilder setting: #filterCommonMessageSends) label: 'Filter out common message sends' translated; target: Smalltalk tools debugger; description: 'When true, filter out uninteresting message sends in the Debugger view while debugging' translated; with: [ (aBuilder setting: #filterDoItSelectors) label: 'Filter out doIt sends' translated; target: stackWidgetClass. (aBuilder setting: #filterNilSelectors) label: 'Filter out nil message sends' translated; target: stackWidgetClass. (aBuilder setting: #filterKernelClasses) label: 'Filter out kernel classes message sends' translated; target: stackWidgetClass. ] ].! ! !DebugSystemSettings class methodsFor: 'settings' stamp: 'AndreiChis 9/29/2013 13:50'! debugSettingsOn: aBuilder (aBuilder group: #debugging) label: 'Debugging'; with: [ (aBuilder group: #deprecationHandling) label: 'Deprecation handling' translated; description: 'How deprecation are handled' translated; target: Deprecation; with: [ (aBuilder setting: #raiseWarning) label: 'Raise a blocking dialog' translated; description: 'If true, then a dialog is popup for each deprecated method invocation' translated. (aBuilder setting: #showWarning) label: 'Transcript message' translated; description: 'If true, then a message is send to the Transcript for each deprecated method invocation' translated]. (aBuilder setting: #cmdDotEnabled) label: 'Enable cmd-dot interrupt key' translated; target: UserInterruptHandler; description: 'If true, it allows the user to stop currently running process by opening-up a debugger' translated. (aBuilder setting: #cpuWatcherEnabled) label: 'Process browser monitors CPU usage' translated; target: CPUWatcher; description: 'If true, Pharo processes will be monitored for CPU usage. If they take too much CPU, you will get a notification menu that will allow you to debug, resume, or terminate the process' translated. (aBuilder setting: #debugShowDamage) label: 'Flash damaged morphic region' translated; target: WorldState; description: 'If true, every changed region of the morphic display will be flashed black before updating.' translated. (aBuilder setting: #logDebuggerStackToFile) label: 'Write message to debug log file when fall into debugger' translated; target: Smalltalk tools debugger; description: 'If true, whenever you fall into a debugger a summary of its stack will be written to a file named' translated. "(aBuilder setting: #restartAlsoProceeds) label: 'Restart also proceeds' translated; target: Debugger; description: 'If this preference is set, the debugger''s restart button and menu item will also proceed. If the preference is not set, the selected context will just be reset to its initial condition, so you may step through it again.' translated." (aBuilder setting: #alwaysOpenFullDebugger) label: 'Directly open the full Debugger' translated; target: Smalltalk tools debugger; description: 'When true, always directly open the full Debugger view when debugging instead of showing only a small popup' translated. self addDebugFilterSessingsOn: aBuilder. (aBuilder setting: #ObjectExplorerShowIcons) label: 'Icons in explorer' translated; selector: #showIcons; target: ObjectExplorer; description: 'When possible, show icon in explorer.' translated. (aBuilder setting: #logFileName) label: 'Log file name' translated; target: Smalltalk tools debugger; description: 'A name of the file, which will be used for logging all errors and notifications' ]! ! !DebuggerMethodMap commentStamp: ''! I am a place-holder for information needed by the Debugger to inspect method activations. I insulate the debugger from details of code generation such as exact bytecode offsets and temporary variable locations. My function is to abstract the source map away from actual bytecode pcs to abstract bytecode pcs. To reduce compilation time I try and defer as much computation to access time as possible as instances of me will be created after each compilation. I maintain a WeakIdentityDictionary of method to DebuggerMethodMap to cache maps. I refer to my method through a WeakArray to keep the map cache functional. If the reference from a DebuggerMethodMap to its method were strong then the method would never be dropped from the cache because the reference from its map would keep it alive.! !DebuggerMethodMap methodsFor: 'private' stamp: 'MarcusDenker 5/9/2013 12:40'! startpcsToBlockExtents: aCompiledMethod "Answer a Dictionary of startpc to Interval of blockExtent, using the identical numbering scheme described in and orchestrated by BlockNode>>analyseArguments:temporaries:rootNode:. This is used in part to find the temp names for any block in a method, as needed by the debugger. The other half is to recompile the method, obtaining the temp names for each block extent. By indirecting through the blockExtent instead of using the startpc directly we decouple the debugger's access to temp names from the exact bytecode; insulating debugging from minor changes in the compiler (e.g. changes in literal pooling, adding prefix bytecodes, adding inst vars to CompiledMethod in literals towards the end of the literal frame, etc). If the recompilation doesn't produce exactly the same bytecode at exactly the same offset no matter; the blockExtents will be the same." | index | index := 0. ^self blockExtentsInto: Dictionary new from: aCompiledMethod initialPC to: aCompiledMethod endPC scanner: (InstructionStream on: aCompiledMethod) numberer: [| value | value := index. index := index + 2. value] ! ! !DebuggerMethodMap methodsFor: 'private' stamp: 'MarcusDenker 12/7/2011 15:16'! privateTempAt: index in: aContext put: aValue startpcsToBlockExtents: theContextsStartpcsToBlockExtents | nameRefPair | nameRefPair := (self privateTempRefsForContext: aContext startpcsToBlockExtents: theContextsStartpcsToBlockExtents) at: index ifAbsent: [aContext errorSubscriptBounds: index]. ^self privateDereference: nameRefPair last in: aContext put: aValue! ! !DebuggerMethodMap methodsFor: 'private' stamp: 'MarcusDenker 12/7/2011 15:16'! privateDereference: tempReference in: aContext put: aValue "Assign the temporary with reference tempReference in aContext. tempReference can be integer - direct temp reference #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index #( outer. temp reference ) - a temp reference in an outer context." ^tempReference isInteger ifTrue: [aContext tempAt: tempReference put: aValue] ifFalse: [tempReference first == #outer ifTrue: [self privateDereference: tempReference last in: aContext outerContext put: aValue] ifFalse: [(aContext tempAt: tempReference first) at: tempReference second put: aValue]]! ! !DebuggerMethodMap methodsFor: 'accessing' stamp: 'MarcusDenker 5/9/2013 11:24'! tempNamesForContext: aContext "Answer an Array of all the temp names in scope in aContext starting with the home's first local (the first argument or first temporary if no arguments)." ^(self privateTempRefsForContext: aContext startpcsToBlockExtents: (self startpcsToBlockExtents: aContext method)) collect: [:pair| pair first]! ! !DebuggerMethodMap methodsFor: 'initialize-release' stamp: 'MarcusDenker 10/9/2012 18:06'! forMethod: aMethod ^self forMethod: aMethod methodNode: aMethod methodNode.! ! !DebuggerMethodMap methodsFor: 'accessing' stamp: 'eem 6/5/2008 09:21'! method ^methodReference at: 1! ! !DebuggerMethodMap methodsFor: 'private' stamp: 'MarcusDenker 4/29/2012 13:49'! privateTempRefsForContext: aContext startpcsToBlockExtents: theContextsStartpcsToBlockExtents "Answer the sequence of temps in scope in aContext in the natural order, outermost arguments and temporaries first, innermost last. Each temp is a pair of the temp's name followed by a reference. The reference can be integer - index of temp in aContext #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index in aContext #( outer. temp reference ) - a temp reference in an outer context." blockExtentsToTempRefs ifNil: [blockExtentsToTempRefs := methodNode blockExtentsToTempsMap. startpcsToTempRefs := Dictionary new]. ^startpcsToTempRefs at: aContext startpc ifAbsentPut: [| localRefs | localRefs := blockExtentsToTempRefs at: (theContextsStartpcsToBlockExtents at: aContext startpc). aContext outerContext ifNil: [localRefs] ifNotNil: [:outer| | outerTemps | "Present temps in the order outermost to innermost left-to-right, but replace copied outermost temps with their innermost copies" outerTemps := (self privateTempRefsForContext: outer startpcsToBlockExtents: theContextsStartpcsToBlockExtents) collect: [:outerPair| localRefs detect: [:localPair| outerPair first = localPair first] ifNone: [{ outerPair first. { #outer. outerPair last } }]]. outerTemps, (localRefs reject: [:localPair| outerTemps anySatisfy: [:outerPair| localPair first = outerPair first]])]]! ! !DebuggerMethodMap methodsFor: 'private' stamp: 'MarcusDenker 5/9/2013 11:18'! blockExtentsInto: aDictionary from: initialPC to: endPC scanner: scanner numberer: numbererBlock "Support routine for startpcsToBlockExtents" | extentStart blockSizeOrLocator | extentStart := numbererBlock value. [scanner pc <= endPC] whileTrue: [blockSizeOrLocator := scanner interpretNextInstructionFor: BlockStartLocator new. blockSizeOrLocator isInteger ifTrue: [self blockExtentsInto: aDictionary from: scanner pc to: scanner pc + blockSizeOrLocator - 1 scanner: scanner numberer: numbererBlock]]. aDictionary at: initialPC put: (extentStart to: numbererBlock value). ^aDictionary! ! !DebuggerMethodMap methodsFor: 'private' stamp: 'MarcusDenker 12/7/2011 15:16'! privateIsOuter: anObject ^anObject last isArray and: [anObject last first == #outer]! ! !DebuggerMethodMap methodsFor: 'source mapping' stamp: 'HenrikSperreJohansen 9/8/2011 20:42'! sortedSourceMap "Answer a sorted collection of associations, pcRangeStart -> pcRangeInterval " ^ sortedSourceMap ifNil: [sortedSourceMap := self abstractSourceMap associations sorted]! ! !DebuggerMethodMap methodsFor: 'source mapping' stamp: 'eem 7/29/2008 17:12'! abstractSourceMap "Answer with a Dictionary of abstractPC to sourceRange ." | theMethodToScan rawSourceRanges concreteSourceRanges abstractPC scanner client | abstractSourceRanges ifNotNil: [^abstractSourceRanges]. "If the methodNode hasn't had a method generated it doesn't have pcs set in its nodes so we must generate a new method and might as well use it for scanning." methodNode rawSourceRangesAndMethodDo: [:ranges :method| rawSourceRanges := ranges. theMethodToScan := method]. concreteSourceRanges := Dictionary new. rawSourceRanges keysAndValuesDo: [:node :range| node pc ~= 0 ifTrue: [concreteSourceRanges at: node pc put: range]]. abstractPC := 1. abstractSourceRanges := Dictionary new. scanner := InstructionStream on: theMethodToScan. client := InstructionClient new. [(concreteSourceRanges includesKey: scanner pc) ifTrue: [abstractSourceRanges at: abstractPC put: (concreteSourceRanges at: scanner pc)]. abstractPC := abstractPC + 1. scanner interpretNextInstructionFor: client. scanner atEnd] whileFalse. ^abstractSourceRanges! ! !DebuggerMethodMap methodsFor: 'initialize-release' stamp: 'MarcusDenker 10/9/2012 17:48'! forMethod: aMethod "" methodNode: theMethodNode "" methodReference := WeakArray with: aMethod. methodNode := theMethodNode.! ! !DebuggerMethodMap methodsFor: 'private' stamp: 'MarcusDenker 12/7/2011 15:16'! privateTempAt: index in: aContext startpcsToBlockExtents: theContextsStartpcsToBlockExtents | nameRefPair | nameRefPair := (self privateTempRefsForContext: aContext startpcsToBlockExtents: theContextsStartpcsToBlockExtents) at: index ifAbsent: [aContext errorSubscriptBounds: index]. ^self privateDereference: nameRefPair last in: aContext! ! !DebuggerMethodMap methodsFor: 'accessing' stamp: 'MarcusDenker 5/9/2013 11:24'! namedTempAt: index put: aValue in: aContext "Assign the value of the temp at index in aContext where index is relative to the array of temp names answered by tempNamesForContext:. If the value is a copied value we also need to set it along the lexical chain." ^self privateTempAt: index in: aContext put: aValue startpcsToBlockExtents: (self startpcsToBlockExtents: aContext method)! ! !DebuggerMethodMap methodsFor: 'source mapping' stamp: 'MarcusDenker 5/9/2013 23:51'! abstractPCFor: concretePC when: contextIsActive "If the context is the actve context (is at the hot end of the stack) then its pc is the current pc. But if the context isn't, because it is suspended sending a message, then its current pc is the previous pc" ^self abstractPCForConcretePC: (contextIsActive ifTrue: [concretePC] ifFalse: [(self method pcPreviousTo: concretePC) ifNil: [concretePC]]) method: self method! ! !DebuggerMethodMap methodsFor: 'private' stamp: 'MarcusDenker 12/7/2011 15:16'! privateDereference: tempReference in: aContext "Fetch the temporary with reference tempReference in aContext. tempReference can be integer - direct temp reference #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index #( outer. temp reference ) - a temp reference in an outer context." ^tempReference isInteger ifTrue: [aContext tempAt: tempReference] ifFalse: [tempReference first == #outer ifTrue: [self privateDereference: tempReference last in: aContext outerContext] ifFalse: [(aContext tempAt: tempReference first) at: tempReference second]]! ! !DebuggerMethodMap methodsFor: 'private' stamp: 'MarcusDenker 5/9/2013 11:19'! mapFromBlockKeys: keys toSchematicTemps: schematicTempNamesString method: aCompiledMethod "Decode a schematicTempNamesString that encodes the layout of temp names in a method and any closures/blocks within it, matching keys in keys to vectors of temp names." | map tempNames | map := Dictionary new. tempNames := schematicTempNamesString readStream. keys do: [:key| | tempSequence tempIndex | tempSequence := OrderedCollection new. tempIndex := 0. [(tempNames skipSeparators; peek) ifNil: [true] ifNotNil: [:ch| '[]' includes: ch]] whileFalse: [tempNames peek = $( ifTrue: [tempSequence addAllLast: ((self tempsSubSequenceFrom: (tempNames next; yourself)) withIndexCollect: [:temp :index| { temp. { tempIndex + 1. index } }]). tempNames peek ~= $) ifTrue: [self error: 'parse error']. tempIndex := tempIndex + 1. tempNames next] ifFalse: [tempSequence addAllLast: ((self tempsSubSequenceFrom: tempNames) withIndexCollect: [:temp :index| { temp. tempIndex := tempIndex + 1 }])]]. map at: key put: tempSequence asArray. [tempNames peek = $]] whileTrue: [tempNames next]. tempNames peek = $[ ifTrue: [tempNames next]]. ^map! ! !DebuggerMethodMap methodsFor: 'private' stamp: 'MarcusDenker 5/9/2013 11:21'! tempsSubSequenceFrom: tempNamesStream ^Array streamContents: [:tsss| [tempNamesStream skipSeparators. tempNamesStream atEnd or: ['[]()' includes: tempNamesStream peek]] whileFalse: [tsss nextPut: (String streamContents: [:s| [s nextPut: tempNamesStream next. tempNamesStream peek ifNil: [true] ifNotNil: [:peek| ' []()' includes: peek]] whileFalse])]] "thisContext method tempsSubSequenceFrom: 'les temps perdu(sont n''est pas la)' readStream" "thisContext method tempsSubSequenceFrom: ('les temps perdu(sont n''est pas la)' readStream skipTo: $(; yourself)"! ! !DebuggerMethodMap methodsFor: 'source mapping' stamp: 'EstebanLorenzano 11/15/2012 16:14'! rangeForPC: concretePC contextIsActiveContext: contextIsActive "Answer the indices in the source code for the supplied pc." | pc | self sortedSourceMap ifEmpty: [ ^(1 to: 0) ]. pc := self abstractPCFor: concretePC when: contextIsActive. (self sortedSourceMap first key > pc) ifTrue: [ ^self sortedSourceMap first value ]. ^self abstractSourceMap at: pc ifAbsent: [ (self sortedSourceMap findBinary: [:assoc | pc - assoc key ] ifNone: [ | end | end := self sortedSourceMap last value last. nil -> (end +1 to: end)]) value ]! ! !DebuggerMethodMap methodsFor: 'source mapping' stamp: 'MarcusDenker 5/9/2013 23:50'! abstractPCForConcretePC: concretePC method: aMethod "Answer the abstractPC matching concretePC." | abstractPC scanner client | abstractPC := 1. scanner := InstructionStream on: aMethod. client := InstructionClient new. [(scanner atEnd or: [scanner pc >= concretePC]) ifTrue: [^abstractPC]. abstractPC := abstractPC + 1. scanner interpretNextInstructionFor: client. true] whileTrue! ! !DebuggerMethodMap methodsFor: 'accessing' stamp: 'MarcusDenker 5/9/2013 11:24'! namedTempAt: index in: aContext "Answer the value of the temp at index in aContext where index is relative to the array of temp names answered by tempNamesForContext:" ^self privateTempAt: index in: aContext startpcsToBlockExtents: (self startpcsToBlockExtents: aContext method)! ! !DebuggerMethodMap class methodsFor: 'instance creation' stamp: 'MarcusDenker 10/9/2012 18:02'! forMethod: aMethod "" "Answer a DebuggerMethodMap suitable for debugging activations of aMethod" ^self new forMethod: aMethod ! ! !DebuggerMethodMapOpal commentStamp: ''! I provide helper methods deadling with -> pc to text mapping -> temporary variables for contexts -> reading and setting tempary variables All methods here should be moved to MethodContext.! !DebuggerMethodMapOpal methodsFor: 'public' stamp: 'MarcusDenker 12/17/2012 17:21'! namedTempAt: index put: aValue in: aContext "Assign the value of the temp at index in aContext where index is relative to the array of temp names answered by tempNamesForContext:. If the value is a copied value we also need to set it along the lexical chain." | name | name := (self tempNamesForContext: aContext) at: index. ^self tempNamed: name in: aContext put: aValue.! ! !DebuggerMethodMapOpal methodsFor: 'initialize-release' stamp: 'MarcusDenker 5/13/2013 13:21'! forMethod: aCompiledMethod methodNode := aCompiledMethod ast! ! !DebuggerMethodMapOpal methodsFor: 'public' stamp: 'MarcusDenker 4/17/2013 22:48'! tempNamed: name in: aContext put: aValue "Assign the value of the temp with name in aContext If the value is a copied value we also need to set it along the lexical chain." | scope var | scope := aContext sourceNode scope. var := scope lookupVar: name. ^var writeFromContext: aContext scope: scope value: aValue. ! ! !DebuggerMethodMapOpal methodsFor: 'public' stamp: 'MarcusDenker 4/17/2013 22:49'! tempNamesForContext: aContext "Answer an Array of all the temp names in scope in aContext starting with the home's first local (the first argument or first temporary if no arguments)." ^ aContext sourceNode scope allTempNames.! ! !DebuggerMethodMapOpal methodsFor: 'public' stamp: 'MarcusDenker 1/24/2013 14:12'! rangeForPC: aPC "return the debug highlight for aPC" ^self rangeForPC: aPC contextIsActiveContext: false ! ! !DebuggerMethodMapOpal methodsFor: 'public' stamp: 'MarcusDenker 4/19/2013 08:32'! rangeForPC: aPC contextIsActiveContext: contextIsActive "return the debug highlight for aPC" | pc | "When on the top of the stack the pc is pointing to right instruction, but deeper in the stack the pc was already advanced one bytecode, so we need to go back this one bytecode, which can consist of multiple bytes. But on IR, we record the *last* bytecode offset as the offset of the IR instruction, which means we can just go back one" pc := contextIsActive ifTrue: [aPC] ifFalse: [aPC - 1]. ^(methodNode sourceNodeForPC: pc) debugHighlightRange ! ! !DebuggerMethodMapOpal methodsFor: 'public' stamp: 'MarcusDenker 4/18/2013 15:53'! tempNamed: name in: aContext "Answer the value of the temp with name in aContext" | scope var | scope := aContext sourceNode scope. var := scope lookupVar: name. ^var readFromContext: aContext scope: scope. ! ! !DebuggerMethodMapOpal methodsFor: 'public' stamp: 'MarcusDenker 12/17/2012 17:20'! namedTempAt: index in: aContext "Answer the value of the temp at index in aContext where index is relative to the array of temp names answered by tempNamesForContext:" | name | name := (self tempNamesForContext: aContext) at: index. ^self tempNamed: name in: aContext.! ! !DebuggerMethodMapOpal class methodsFor: 'instance creation' stamp: 'MarcusDenker 11/16/2012 12:11'! forMethod: aMethod "" "Answer a DebuggerMethodMap suitable for debugging activations of aMethod" ^self new forMethod: aMethod ! ! !DebuggerModelTest commentStamp: 'TorstenBergmann 2/20/2014 15:44'! SUnit tests for the debugger model! !DebuggerModelTest methodsFor: 'tests' stamp: 'AndreiChis 9/25/2013 18:13'! testCorrectlyCreateDebugSession session := DebugSession process: process context: context. self assert: session isNotNil. self assert: process isSuspended. self assert: session interruptedContext equals: context. self assert: session interruptedContext printString equals: '[ Set new ] in DebuggerModelTest>>setUp'.! ! !DebuggerModelTest methodsFor: 'tests' stamp: 'AndreiChis 9/30/2013 18:39'! testStepInto session:= DebugSession process: process context: context. self deny: (session isContextPostMortem: context). self assert: session interruptedContext equals: context. self assert: session interruptedContext printString equals: '[ Set new ] in DebuggerModelTest>>setUp' . session stepInto; stepInto. self assert: session interruptedContext printString equals: 'Set class>>new'. ! ! !DebuggerModelTest methodsFor: 'running' stamp: 'AndreiChis 9/30/2013 18:35'! setUp context := [ Set new ] asContext. process := Process forContext: context priority: Processor userInterruptPriority! ! !DebuggerModelTest methodsFor: 'tests' stamp: 'AndreiChis 9/25/2013 18:14'! testStepOver session:= DebugSession process: process context: context. self assert: session interruptedContext equals: context. self assert: session interruptedContext printString equals: '[ Set new ] in DebuggerModelTest>>setUp' . session stepOver. self assert: session interruptedContext printString equals: '[ Set new ] in DebuggerModelTest>>setUp'.! ! !DebuggerTest commentStamp: 'TorstenBergmann 2/4/2014 20:45'! SUnit tests for Debugger! !DebuggerTest methodsFor: 'testing' stamp: 'CamilleTeruel 4/4/2014 12:48'! testBasic | context process debugger printedString | context := [ 20 factorial ] asContext. process := Process forContext: context priority: Processor userInterruptPriority. debugger := Smalltalk tools debugger new process: process controller: nil context: context. debugger stack expand. self assert: debugger stack selectedIndex = 1. printedString := OpalCompiler isActive ifTrue: [ '[ 20 factorial ] in DebuggerTest>>testBasic'] ifFalse: [ '[...] in DebuggerTest>>testBasic' ]. self assert: debugger stack selectedItem printString = printedString. debugger send. debugger send. self assert: debugger code getText = (Integer>>#factorial) sourceCode. self assert: debugger stack selectedItem printString = 'SmallInteger(Integer)>>factorial'. process terminate.! ! !Decompiler commentStamp: 'nice 2/3/2011 22:54'! I decompile a method in three phases: Reverser: postfix byte codes -> prefix symbolic codes (nodes and atoms) Parser: prefix symbolic codes -> node tree (same as the compiler) Printer: node tree -> text (done by the nodes) instance vars: constructor an auxiliary knowing how to generate Abstract Syntax Tree (node tree) method the method being decompiled instVars the instance variables of the class implementing method tempVars hold the names of temporary variables (if known) NOTE: POLYMORPHISM WILL BE RESOLVED IN #initSymbols: constTable parse node associated with byte encoded constants (nil true false 0 1 -1 etc...) stack multipurpose... statements the statements of the method being decompiled lastPc exit caseExits - stack of exit addresses that have been seen in the branches of caseOf:'s lastJumpPc lastReturnPc limit hasValue blockStackBase numLocaltemps - number of temps local to a block; also a flag indicating decompiling a block blockStartsToTempVars tempVarCount number of temp vars used by the method lastJumpIfPcStack the value of program counter just before the last encountered conditional jumps! !Decompiler methodsFor: 'instruction decoding' stamp: ''! pushConstant: value | node | node := value == true ifTrue: [constTable at: 2] ifFalse: [value == false ifTrue: [constTable at: 3] ifFalse: [value == nil ifTrue: [constTable at: 4] ifFalse: [constructor codeAnyLiteral: value]]]. stack addLast: node! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'marcusDenker 2/26/2012 20:09'! send: selector super: superFlag numArgs: numArgs | args rcvr selNode msgNode messages | args := Array new: numArgs. (numArgs to: 1 by: -1) do: [:i | args at: i put: stack removeLast]. rcvr := stack removeLast. superFlag ifTrue: [rcvr := constructor codeSuper]. ((#(closureCopy:copiedValues:) includes: selector) and: [self checkForBlock: rcvr selector: selector arguments: args]) ifFalse: [selNode := constructor codeAnySelector: selector. rcvr == CascadeFlag ifTrue: ["May actually be a cascade or an ifNil: for value." self willJumpIfFalse ifTrue: "= generated by a case macro" [selector == #= ifTrue: [" = signals a case statement..." statements addLast: args first. stack addLast: rcvr. "restore CascadeFlag" ^ self]. selector == #== ifTrue: [" == signals an ifNil: for value..." stack removeLast; removeLast. rcvr := stack removeLast. stack addLast: IfNilFlag; addLast: (constructor codeMessage: rcvr selector: selNode arguments: args). ^ self]] ifFalse: [(self willJumpIfTrue and: [selector == #==]) ifTrue: [" == signals an ifNotNil: for value..." stack removeLast; removeLast. rcvr := stack removeLast. stack addLast: IfNilFlag; addLast: (constructor codeMessage: rcvr selector: selNode arguments: args). ^ self]]. msgNode := constructor codeCascadedMessage: selNode arguments: args. stack last == CascadeFlag ifFalse: ["Last message of a cascade" statements addLast: msgNode. messages := self popTo: stack removeLast. "Depth saved by first dup" msgNode := constructor codeCascade: stack removeLast messages: messages]] ifFalse: [msgNode := constructor codeMessage: rcvr selector: selNode arguments: args]. stack addLast: msgNode]! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'nice 2/3/2011 22:57'! jump: dist if: condition | savePc sign elsePc elseStart end cond ifExpr thenBlock elseBlock thenJump elseJump condHasValue isIfNil saveStack blockBody | lastJumpIfPcStack addLast: lastPc. stack last == CascadeFlag ifTrue: [^ [self case: dist] ensure: [lastJumpIfPcStack removeLast]]. elsePc := lastPc. elseStart := pc + dist. end := limit. "Check for bfp-jmp to invert condition. Don't be fooled by a loop with a null body." sign := condition. savePc := pc. self interpretJump ifNotNil: [:elseDist| (elseDist >= 0 and: [elseStart = pc]) ifTrue: [sign := sign not. elseStart := pc + elseDist]]. pc := savePc. ifExpr := stack removeLast. (isIfNil := stack size > 0 and: [stack last == IfNilFlag]) ifTrue: [stack removeLast]. saveStack := stack. stack := OrderedCollection new. thenBlock := self blockTo: elseStart. condHasValue := hasValue or: [isIfNil]. "ensure jump is within block (in case thenExpr returns)" thenJump := exit <= end ifTrue: [exit] ifFalse: [elseStart]. "if jump goes back, then it's a loop" thenJump < elseStart ifTrue: ["Must be a while loop... thenJump will jump to the beginning of the while expr. In the case of while's with a block in the condition, the while expr should include more than just the last expression: find all the statements needed by re-decompiling." stack := saveStack. pc := thenJump. blockBody := self statementsTo: elsePc. "discard unwanted statements from block" blockBody size - 1 timesRepeat: [statements removeLast]. statements addLast: (constructor codeMessage: (constructor codeBlock: blockBody returns: false) selector: (constructor codeSelector: (sign ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]) code: #macro) arguments: { thenBlock }). pc := elseStart. self convertToDoLoop] ifFalse: ["Must be a conditional..." elseBlock := self blockTo: thenJump. elseJump := exit. "if elseJump is backwards, it is not part of the elseExpr" elseJump < elsePc ifTrue: [pc := lastPc]. cond := isIfNil ifTrue: [constructor codeMessage: ifExpr ifNilReceiver selector: (constructor codeSelector: (sign ifTrue: [#ifNotNil:] ifFalse: [#ifNil:]) code: #macro) arguments: (Array with: thenBlock)] ifFalse: [constructor codeMessage: ifExpr selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro) arguments: (sign ifTrue: [{elseBlock. thenBlock}] ifFalse: [{thenBlock. elseBlock}])]. stack := saveStack. condHasValue ifTrue: [stack addLast: cond] ifFalse: [statements addLast: cond]]. lastJumpIfPcStack removeLast.! ! !Decompiler methodsFor: 'private' stamp: 'MarcusDenker 5/9/2013 11:08'! decompile: aSelector in: aClass method: aMethod ^self decompile: aSelector in: aClass method: aMethod using: (self constructorForMethod: aMethod)! ! !Decompiler methodsFor: 'private' stamp: 'di 12/26/1998 21:29'! quickMethod | | method isReturnSpecial ifTrue: [^ constructor codeBlock: (Array with: (constTable at: method primitive - 255)) returns: true]. method isReturnField ifTrue: [^ constructor codeBlock: (Array with: (constructor codeInst: method returnField)) returns: true]. self error: 'improper short method'! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'eem 8/12/2010 13:51'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize | copiedValues | self sawClosureBytecode. copiedValues := ((1 to: numCopied) collect: [:ign| stack removeLast]) reversed. self doClosureCopyCopiedValues: copiedValues numArgs: numArgs blockSize: blockSize! ! !Decompiler methodsFor: 'instruction decoding' stamp: ''! storeIntoLiteralVariable: assoc self pushLiteralVariable: assoc; doStore: stack! ! !Decompiler methodsFor: 'initialize-release' stamp: 'MarcusDenker 5/9/2013 11:27'! mapFromBlockStartsIn: aMethod toTempVarsFrom: schematicTempNamesString constructor: aDecompilerConstructor | map | map := aMethod debuggerMap mapFromBlockKeys: (aMethod debuggerMap startpcsToBlockExtents: aMethod) keys asArray sort toSchematicTemps: schematicTempNamesString method: aMethod. map keysAndValuesDo: [:startpc :tempNameTupleVector| tempNameTupleVector isEmpty ifFalse: [| subMap numTemps tempVector | subMap := Dictionary new. "Find how many temp slots there are (direct & indirect temp vectors) and for each indirect temp vector find how big it is." tempNameTupleVector do: [:tuple| tuple last isArray ifTrue: [subMap at: tuple last first put: tuple last last. numTemps := tuple last first] ifFalse: [numTemps := tuple last]]. "create the temp vector for this scope level." tempVector := Array new: numTemps. "fill it in with any indirect temp vectors" subMap keysAndValuesDo: [:index :size| tempVector at: index put: (Array new: size)]. "fill it in with temp nodes." tempNameTupleVector do: [:tuple| | itv | tuple last isArray ifTrue: [itv := tempVector at: tuple last first. itv at: tuple last last put: (aDecompilerConstructor codeTemp: tuple last last - 1 named: tuple first)] ifFalse: [tempVector at: tuple last put: (aDecompilerConstructor codeTemp: tuple last - 1 named: tuple first)]]. "replace any indirect temp vectors with proper RemoteTempVectorNodes" subMap keysAndValuesDo: [:index :size| tempVector at: index put: (aDecompilerConstructor codeRemoteTemp: index remoteTemps: (tempVector at: index))]. "and update the entry in the map" map at: startpc put: tempVector]]. ^map! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'eem 6/4/2008 14:45'! pushNewArrayOfSize: size self sawClosureBytecode. stack addLast: #pushNewArray -> (Array new: size)! ! !Decompiler methodsFor: 'private' stamp: 'eem 9/5/2008 18:41'! convertToDoLoop "If statements contains the pattern var := startExpr. [var <= limit] whileTrue: [...statements... var := var + incConst] then replace this by startExpr to: limit by: incConst do: [:var | ...statements...]" | initStmt toDoStmt limitStmt | statements size < 2 ifTrue: [^ self]. initStmt := statements at: statements size-1. (toDoStmt := statements last toDoFromWhileWithInit: initStmt) == nil ifTrue: [^ self]. initStmt variable scope: -1. "Flag arg as block temp" statements removeLast; removeLast; addLast: toDoStmt. "Attempt further conversion of the pattern limitVar := limitExpr. startExpr to: limitVar by: incConst do: [:var | ...statements...] to startExpr to: limitExpr by: incConst do: [:var | ...statements...]" statements size < 2 ifTrue: [^ self]. limitStmt := statements at: statements size-1. ((limitStmt isMemberOf: AssignmentNode) and: [limitStmt variable isTemp and: [limitStmt variable == toDoStmt arguments first and: [self blockScopeRefersOnlyOnceToTemp: limitStmt variable fieldOffset]]]) ifFalse: [^ self]. toDoStmt arguments at: 1 put: limitStmt value. limitStmt variable scope: -2. "Flag limit var so it won't print" statements removeLast; removeLast; addLast: toDoStmt. ! ! !Decompiler methodsFor: 'private' stamp: 'eem 9/6/2008 08:45'! blockScopeRefersOnlyOnceToTemp: offset | nRefs byteCode extension scanner scan | scanner := InstructionStream on: method. nRefs := 0. scan := offset <= 15 ifTrue: [byteCode := 16 + offset. [:instr | instr = byteCode ifTrue: [nRefs := nRefs + 1]. nRefs > 1]] ifFalse: [extension := 64 + offset. [:instr | (instr = 128 and: [scanner followingByte = extension]) ifTrue: [nRefs := nRefs + 1]. nRefs > 1]]. self scanBlockScopeFor: pc from: method initialPC to: method endPC with: scan scanner: scanner. ^nRefs = 1! ! !Decompiler methodsFor: 'control' stamp: ''! statementsTo: end "Decompile the method from pc up to end and return an array of expressions. If at run time this block will leave a value on the stack, set hasValue to true. If the block ends with a jump or return, set exit to the destination of the jump, or the end of the method; otherwise, set exit = end. Leave pc = end." | blockPos stackPos t | blockPos := statements size. stackPos := stack size. [pc < end] whileTrue: [lastPc := pc. limit := end. "for performs" self interpretNextInstructionFor: self]. "If there is an additional item on the stack, it will be the value of this block." (hasValue := stack size > stackPos) ifTrue: [statements addLast: stack removeLast]. lastJumpPc = lastPc ifFalse: [exit := pc]. ^self popTo: blockPos! ! !Decompiler methodsFor: 'instruction decoding' stamp: ''! popIntoReceiverVariable: offset self pushReceiverVariable: offset; doStore: statements! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 15:43'! methodReturnTop | last | last := stack removeLast "test test" asReturnNode. stack size > blockStackBase "get effect of elided pop before return" ifTrue: [statements addLast: stack removeLast]. exit := pc. lastJumpPc := lastReturnPc := lastPc. statements addLast: last! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'eem 6/4/2008 14:44'! popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex self sawClosureBytecode. self pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex; doStore: statements! ! !Decompiler methodsFor: 'initialize-release' stamp: 'eem 7/1/2009 14:45'! initSymbols: aClass constructor method: method class: aClass literals: method literals. constTable := constructor codeConstants. instVars := Array new: aClass instSize. tempVarCount := method numTemps. "(tempVars isNil and: [method holdsTempNames]) ifTrue: [tempVars := method tempNamesString]." tempVars isString ifTrue: [blockStartsToTempVars := self mapFromBlockStartsIn: method toTempVarsFrom: tempVars constructor: constructor. tempVars := blockStartsToTempVars at: method initialPC] ifFalse: [| namedTemps | namedTemps := tempVars ifNil: [(1 to: tempVarCount) collect: [:i| 't', i printString]]. tempVars := (1 to: tempVarCount) collect: [:i | i <= namedTemps size ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)] ifFalse: [constructor codeTemp: i - 1]]]. 1 to: method numArgs do: [:i| (tempVars at: i) beMethodArg]! ! !Decompiler methodsFor: 'instruction decoding' stamp: ''! pushActiveContext stack addLast: constructor codeThisContext! ! !Decompiler methodsFor: 'private' stamp: 'GuillermoPolito 4/26/2012 11:20'! decompile: aSelector in: aClass method: aMethod using: aConstructor | block node | constructor := aConstructor. method := aMethod. self initSymbols: aClass. "create symbol tables" method isQuick ifTrue: [block := self quickMethod] ifFalse: [stack := OrderedCollection new: method frameSize. lastJumpIfPcStack := OrderedCollection new. caseExits := OrderedCollection new. statements := OrderedCollection new: 20. numLocalTemps := 0. super method: method pc: method initialPC. "skip primitive error code store if necessary" (method isPrimitive and: [self willStore]) ifTrue: [pc := pc + 2. tempVars := tempVars asOrderedCollection]. block := self blockTo: method endPC + 1. stack isEmpty ifFalse: [self error: 'stack not empty']]. node := constructor codeMethod: aSelector block: block tempVars: tempVars primitive: method primitive class: aClass. method isPrimitive ifTrue: [node removeAndRenameLastTempIfErrorCode]. ^node preen! ! !Decompiler methodsFor: 'private' stamp: 'MarcusDenker 2/26/2012 10:46'! constructorForMethod: aMethod ^DecompilerConstructorForClosures new! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'nk 2/20/2004 11:56'! pushReceiverVariable: offset | var | (var := instVars at: offset + 1 ifAbsent: []) == nil ifTrue: ["Not set up yet" var := constructor codeInst: offset. instVars size < (offset + 1) ifTrue: [ instVars := (Array new: offset + 1) replaceFrom: 1 to: instVars size with: instVars; yourself ]. instVars at: offset + 1 put: var]. stack addLast: var! ! !Decompiler methodsFor: 'control' stamp: 'ls 1/28/2004 13:29'! statementsForCaseTo: end "Decompile the method from pc up to end and return an array of expressions. If at run time this block will leave a value on the stack, set hasValue to true. If the block ends with a jump or return, set exit to the destination of the jump, or the end of the method; otherwise, set exit = end. Leave pc = end. Note that stack initially contains a CaseFlag which will be removed by a subsequent Pop instruction, so adjust the StackPos accordingly." | blockPos stackPos | blockPos := statements size. stackPos := stack size - 1. "Adjust for CaseFlag" [pc < end] whileTrue: [lastPc := pc. limit := end. "for performs" self interpretNextInstructionFor: self]. "If there is an additional item on the stack, it will be the value of this block." (hasValue := stack size > stackPos) ifTrue: [stack last == CaseFlag ifFalse: [ statements addLast: stack removeLast] ]. lastJumpPc = lastPc ifFalse: [exit := pc]. caseExits add: exit. ^self popTo: blockPos! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'eem 9/25/2008 09:48'! pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex self sawClosureBytecode. stack addLast: ((tempVars at: tempVectorIndex + 1) remoteTemps at: remoteTempIndex + 1)! ! !Decompiler methodsFor: 'instruction decoding' stamp: ''! storeIntoTemporaryVariable: offset self pushTemporaryVariable: offset; doStore: stack! ! !Decompiler methodsFor: 'instruction decoding' stamp: ''! pushReceiver stack addLast: (constTable at: 1)! ! !Decompiler methodsFor: 'instruction decoding' stamp: ''! methodReturnReceiver self pushReceiver; methodReturnTop! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'jannik.laval 5/1/2010 16:10'! popIntoTemporaryVariable: offset | maybeTVTag tempVector start | maybeTVTag := stack last. ((maybeTVTag isMemberOf: Association) and: [maybeTVTag key == #pushNewArray]) ifTrue: [blockStartsToTempVars notNil "implies we were intialized with temp names." ifTrue: "Use the provided temps" [[(tempVector := tempVars at: offset + 1 ifAbsent: [ParseNode basicNew]) isTemp and: [tempVector isIndirectTempVector and: [tempVector remoteTemps size = maybeTVTag value size]]] assert] ifFalse: "Synthesize some remote temps" [tempVector := maybeTVTag value. offset + 1 <= tempVars size ifTrue: [start := 2. tempVector at: 1 put: (tempVars at: offset + 1)] ifFalse: [tempVars := (Array new: offset + 1) replaceFrom: 1 to: tempVars size with: tempVars. start := 1]. start to: tempVector size do: [:i| tempVector at: i put: (constructor codeTemp: numLocalTemps + offset + i - 1 named: 't', (tempVarCount + i) printString)]. tempVars at: offset + 1 put: (constructor codeRemoteTemp: offset + 1 remoteTemps: tempVector)]. tempVarCount := tempVarCount + maybeTVTag value size. stack removeLast. ^self]. self pushTemporaryVariable: offset; doStore: statements! ! !Decompiler methodsFor: 'instruction decoding' stamp: ''! blockReturnTop "No action needed"! ! !Decompiler methodsFor: 'public access' stamp: ''! tempAt: offset "Needed by BraceConstructor'. 8 to: varNames size do: [:i | i <= 10 ifTrue: [Transcript cr] ifFalse: [Transcript space; space]. Transcript nextPutAll: (varNames at: i); nextPutAll: ': '; print: (self instVarAt: i)]. Transcript endEntry. ^ super interpretNextInstructionFor: client! ! !Decompiler methodsFor: 'private' stamp: 'eem 6/4/2008 14:43'! sawClosureBytecode constructor isForClosures ifFalse: [constructor primitiveChangeClassTo: DecompilerConstructorForClosures new]! ! !Decompiler methodsFor: '*Deprecated30' stamp: 'MarcusDenker 5/9/2013 11:08'! decompile: aSelector in: aClass "See Decompiler|decompile:in:method:. The method is found by looking up the message, aSelector, in the method dictionary of the class, aClass." self deprecated: 'use #decompileMethod:' on: '09 May 2013' in: 'Pharo 3.0'. ^self decompile: aSelector in: aClass method: (aClass compiledMethodAt: aSelector)! ! !Decompiler methodsFor: 'control' stamp: 'tao 8/20/97 22:51'! blockForCaseTo: end "Decompile a range of code as in statementsForCaseTo:, but return a block node." | exprs block oldBase | oldBase := blockStackBase. blockStackBase := stack size. exprs := self statementsForCaseTo: end. block := constructor codeBlock: exprs returns: lastReturnPc = lastPc. blockStackBase := oldBase. lastReturnPc := -1. "So as not to mislead outer calls" ^block! ! !Decompiler methodsFor: 'control' stamp: 'eem 8/12/2010 13:25'! doClosureCopyCopiedValues: blockCopiedValues numArgs: numArgs blockSize: blockSize | startpc savedTemps savedTempVarCount savedNumLocalTemps jump blockArgs blockTemps blockTempsOffset block | savedTemps := tempVars. savedTempVarCount := tempVarCount. savedNumLocalTemps := numLocalTemps. jump := blockSize + (startpc := pc). numLocalTemps := BlockLocalTempCounter tempCountForBlockAt: pc - 4 in: method. blockTempsOffset := numArgs + blockCopiedValues size. (blockStartsToTempVars notNil "implies we were intialized with temp names." and: [blockStartsToTempVars includesKey: pc]) ifTrue: [tempVars := blockStartsToTempVars at: pc] ifFalse: [blockArgs := (1 to: numArgs) collect: [:i| (constructor codeTemp: i - 1 named: 't', (tempVarCount + i) printString) beBlockArg]. blockTemps := (1 to: numLocalTemps) collect: [:i| constructor codeTemp: i + blockTempsOffset - 1 named: 't', (tempVarCount + i + numArgs) printString]. tempVars := blockArgs, blockCopiedValues, blockTemps]. numLocalTemps timesRepeat: [self interpretNextInstructionFor: self. stack removeLast]. tempVarCount := tempVarCount + numArgs + numLocalTemps. block := self blockTo: jump. stack addLast: ((constructor codeArguments: (tempVars copyFrom: 1 to: numArgs) temps: (tempVars copyFrom: blockTempsOffset + 1 to: blockTempsOffset + numLocalTemps) block: block) pc: startpc; yourself). tempVars := savedTemps. tempVarCount := savedTempVarCount. numLocalTemps := savedNumLocalTemps! ! !Decompiler methodsFor: 'control' stamp: ''! blockTo: end "Decompile a range of code as in statementsTo:, but return a block node." | exprs block oldBase | oldBase := blockStackBase. blockStackBase := stack size. exprs := self statementsTo: end. block := constructor codeBlock: exprs returns: lastReturnPc = lastPc. blockStackBase := oldBase. lastReturnPc := -1. "So as not to mislead outer calls" ^block! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'di 2/5/2000 09:34'! doPop stack isEmpty ifTrue: ["Ignore pop in first leg of ifNil for value" ^ self]. stack last == CaseFlag ifTrue: [stack removeLast] ifFalse: [statements addLast: stack removeLast].! ! !Decompiler methodsFor: 'instruction decoding' stamp: ''! pushTemporaryVariable: offset stack addLast: (tempVars at: offset + 1)! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'eem 6/4/2008 14:44'! pushConsArrayWithElements: numElements | array | self sawClosureBytecode. array := Array new: numElements. numElements to: 1 by: -1 do: [:i| array at: i put: stack removeLast]. stack addLast: (constructor codeBrace: array)! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'nice 2/3/2011 22:56'! jump: dist | blockBody destPc nextPC | destPc := pc + dist. (lastJumpIfPcStack isEmpty or: [dist < 0 and: [destPc > lastJumpIfPcStack last]]) ifTrue: ["Rule: aBackward jump not crossing a Bfp/Btp must be a repeat" nextPC := pc. pc := destPc. blockBody := self statementsTo: lastPc. blockBody size timesRepeat: [statements removeLast]. pc := nextPC. statements addLast: (constructor codeMessage: (constructor codeBlock: blockBody returns: false) selector: (constructor codeSelector: #repeat code: #macro) arguments: #()). ] ifFalse: [exit := destPc. lastJumpPc := lastPc]! ! !Decompiler methodsFor: 'instruction decoding' stamp: ''! methodReturnConstant: value self pushConstant: value; methodReturnTop! ! !Decompiler methodsFor: 'private' stamp: ''! popTo: oldPos | t | t := Array new: statements size - oldPos. (t size to: 1 by: -1) do: [:i | t at: i put: statements removeLast]. ^t! ! !Decompiler methodsFor: 'control' stamp: 'eem 5/29/2008 17:02'! checkForClosureCopy: receiver arguments: arguments "We just saw a closureCopy:copiedValues: message. Check for and construct a following block." | savePc jump | receiver == constructor codeThisContext ifFalse: [^false]. savePc := pc. (jump := self interpretJump) notNil ifFalse: [pc := savePc. ^nil]. "Definitely a block" self doClosureCopyCopiedValues: arguments last "" elements numArgs: arguments first key blockSize: jump. ^true! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'eem 6/4/2008 14:45'! storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex self sawClosureBytecode. self pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex; doStore: stack! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'PeterHugossonMiller 9/2/2009 16:08'! case: dist "statements = keyStmts CascadeFlag keyValueBlock ... keyStmts" | nextCase thenJump stmtStream elements b node cases otherBlock myExits | nextCase := pc + dist. "Now add CascadeFlag & keyValueBlock to statements" statements addLast: stack removeLast. stack addLast: CaseFlag. "set for next pop" statements addLast: (self blockForCaseTo: nextCase). stack last == CaseFlag ifTrue: "Last case" ["ensure jump is within block (in case thenExpr returns wierdly I guess)" stack removeLast. "get rid of CaseFlag" stmtStream := (self popTo: stack removeLast) readStream. elements := OrderedCollection new. b := OrderedCollection new. [stmtStream atEnd] whileFalse: [(node := stmtStream next) == CascadeFlag ifTrue: [elements addLast: (constructor codeMessage: (constructor codeBlock: b returns: false) selector: (constructor codeSelector: #-> code: #macro) arguments: (Array with: stmtStream next)). b := OrderedCollection new] ifFalse: [b addLast: node]]. b size > 0 ifTrue: [self error: 'Bad cases']. cases := constructor codeBrace: elements. "try find the end of the case" myExits := caseExits removeLast: elements size. myExits := myExits reject: [ :e | e isNil or: [ e < 0 or: [ e > method endPC ] ] ]. thenJump := myExits isEmpty ifTrue: [ nextCase ] ifFalse: [ myExits max ]. otherBlock := self blockTo: thenJump. stack addLast: (constructor codeMessage: stack removeLast selector: (constructor codeSelector: #caseOf:otherwise: code: #macro) arguments: (Array with: cases with: otherBlock))].! ! !Decompiler methodsFor: 'control' stamp: 'marcusDenker 2/26/2012 20:08'! checkForBlock: receiver selector: selector arguments: arguments [selector == #closureCopy:copiedValues:] assert. ^self checkForClosureCopy: receiver arguments: arguments! ! !Decompiler methodsFor: 'instruction decoding' stamp: ''! pushLiteralVariable: assoc stack addLast: (constructor codeAnyLitInd: assoc)! ! !Decompiler methodsFor: 'instruction decoding' stamp: ''! doDup stack last == CascadeFlag ifFalse: ["Save position and mark cascade" stack addLast: statements size. stack addLast: CascadeFlag]. stack addLast: CascadeFlag! ! !Decompiler methodsFor: 'private' stamp: 'eem 9/6/2008 09:27'! scanBlockScopeFor: refpc from: startpc to: endpc with: scan scanner: scanner | bsl maybeBlockSize | bsl := BlockStartLocator new. scanner pc: startpc. [scanner pc <= endpc] whileTrue: [refpc = scanner pc ifTrue: [scanner pc: startpc. [scanner pc <= endpc] whileTrue: [(scan value: scanner firstByte) ifTrue: [^endpc]. (maybeBlockSize := scanner interpretNextInstructionFor: bsl) isInteger ifTrue: [scanner pc: scanner pc + maybeBlockSize]]. ^self]. (maybeBlockSize := scanner interpretNextInstructionFor: bsl) isInteger ifTrue: [refpc <= (scanner pc + maybeBlockSize) ifTrue: [^self scanBlockScopeFor: refpc from: scanner pc to: scanner pc + maybeBlockSize with: scan scanner: scanner] ifFalse: [scanner pc: scanner pc + maybeBlockSize]]]! ! !Decompiler class methodsFor: 'initialization' stamp: 'di 1/28/2000 22:21'! initialize CascadeFlag := 'cascade'. "A unique object" CaseFlag := 'case'. "Ditto" ArgumentFlag := 'argument'. "Ditto" IfNilFlag := 'ifNil'. "Ditto" "Decompiler initialize"! ! !DecompilerConstructor commentStamp: ''! I construct the node tree for a Decompiler.! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeSelector: sel code: code ^SelectorNode new key: sel code: code! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeTemp: index named: tempName ^ TempVariableNode new name: tempName index: index type: LdTempType scope: 0! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeTemp: index ^ TempVariableNode new name: 't' , (index + 1) printString index: index type: LdTempType scope: 0! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeThisContext ^NodeThisContext! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'eem 5/21/2008 13:28'! codeArguments: args temps: temps block: block block arguments: args; temporaries: temps. ^block! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeAssignTo: variable value: expression ^AssignmentNode new variable: variable value: expression! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'jmv 3/3/2011 09:17'! decodeIfNilWithReceiver: receiver selector: selector arguments: arguments receiver ifNil: [ ^nil ]. "For instance, when cascading" selector == #ifTrue:ifFalse: ifFalse: [^ nil]. (receiver isMessage: #== receiver: nil arguments: [:argNode | argNode == NodeNil]) ifFalse: [^ nil]. ^ (MessageNode new receiver: receiver selector: (SelectorNode new key: #ifTrue:ifFalse: code: #macro) arguments: arguments precedence: 3) noteSpecialSelector: #ifNil:ifNotNil:! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeArguments: args block: block ^block arguments: args! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeSuper ^NodeSuper! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeCascadedMessage: selector arguments: arguments ^self codeMessage: nil selector: selector arguments: arguments! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeConstants "Answer with an array of the objects representing self, true, false, nil, -1, 0, 1, 2." ^(Array with: NodeSelf with: NodeTrue with: NodeFalse with: NodeNil) , ((-1 to: 2) collect: [:i | LiteralNode new key: i code: LdMinus1 + i + 1])! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeAnySelector: selector ^SelectorNode new key: selector index: 0 type: SendType! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'di 11/19/1999 11:06'! codeCascade: receiver messages: messages ^ (BraceNode new matchBraceStreamReceiver: receiver messages: messages) ifNil: [CascadeNode new receiver: receiver messages: messages]! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeAnyLitInd: association ^VariableNode new name: association key key: association index: 0 type: LdLitIndType! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeAnyLiteral: value ^LiteralNode new key: value index: 0 type: LdLitType! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'eem 8/21/2008 14:02'! codeInst: index ^InstanceVariableNode new name: (instVars at: index + 1 ifAbsent: ['unknown', index asString]) index: index + 1! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'eem 9/23/2008 22:06'! codeMethod: selector block: block tempVars: vars primitive: primitive class: class | node methodTemps arguments temporaries | node := self codeSelector: selector code: nil. tempVars := vars. methodTemps := tempVars select: [:t | t scope >= 0]. arguments := methodTemps copyFrom: 1 to: nArgs. temporaries := methodTemps copyFrom: nArgs + 1 to: methodTemps size. block arguments: arguments; temporaries: temporaries. ^MethodNode new selector: node arguments: arguments precedence: selector precedence temporaries: temporaries block: block encoder: (Encoder new initScopeAndLiteralTables temps: tempVars literals: literalValues class: class) primitive: primitive! ! !DecompilerConstructor methodsFor: 'constructor' stamp: ''! codeBrace: elements ^BraceNode new elements: elements! ! !DecompilerConstructor methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:44'! accept: aVisitor "I am not really a ParseNode. Only here to access constants defined in parseNode." self shouldNotImplement! ! !DecompilerConstructor methodsFor: 'testing' stamp: 'eem 6/4/2008 14:41'! isForClosures ^false! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 2/5/2000 12:37'! codeMessage: receiver selector: selector arguments: arguments | symbol node | symbol := selector key. (node := BraceNode new matchBraceWithReceiver: receiver selector: symbol arguments: arguments) ifNotNil: [^ node]. (node := self decodeIfNilWithReceiver: receiver selector: symbol arguments: arguments) ifNotNil: [^ node]. ^ MessageNode new receiver: receiver selector: selector arguments: arguments precedence: symbol precedence! ! !DecompilerConstructor methodsFor: 'initialize-release' stamp: ''! method: aMethod class: aClass literals: literals method := aMethod. instVars := aClass allInstVarNames. nArgs := method numArgs. literalValues := literals! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 3/3/2000 13:35'! codeEmptyBlock ^ BlockNode withJust: NodeNil! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 3/3/2000 13:34'! codeBlock: statements returns: returns ^ BlockNode statements: statements returns: returns! ! !DecompilerConstructorForClosures commentStamp: 'TorstenBergmann 1/31/2014 11:21'! Similar to superclass but for closures! !DecompilerConstructorForClosures methodsFor: 'constructor' stamp: 'eem 10/20/2008 13:01'! codeRemoteTemp: index remoteTemps: tempVector ^(RemoteTempVectorNode new name: '_r', index printString index: index type: LdTempType scope: 0) remoteTemps: tempVector; yourself! ! !DecompilerConstructorForClosures methodsFor: 'testing' stamp: 'eem 6/4/2008 14:41'! isForClosures ^true! ! !DecompilerConstructorForClosures methodsFor: 'constructor' stamp: 'eem 8/15/2010 16:56'! codeMethod: selector block: block tempVars: vars primitive: primitive class: class | blockNode selectorNode visibleTemps invisibleTemps arguments temporaries | selectorNode := self codeSelector: selector code: nil. tempVars := vars. visibleTemps := OrderedCollection new. invisibleTemps := OrderedCollection new. tempVars do: [:t| ((t isIndirectTempVector or: [t scope >= 0]) ifTrue: [visibleTemps] ifFalse: [invisibleTemps]) addLast: t]. arguments := visibleTemps copyFrom: 1 to: nArgs. temporaries := visibleTemps copyFrom: nArgs + 1 to: visibleTemps size. block arguments: arguments; temporaries: temporaries. blockNode := MethodNode new selector: selectorNode arguments: arguments precedence: selector precedence temporaries: temporaries block: block encoder: (EncoderForV3PlusClosures new initScopeAndLiteralTables temps: visibleTemps, invisibleTemps literals: literalValues class: class) primitive: primitive properties: method properties copy. blockNode properties method: blockNode. ^blockNode! ! !DeepCopier commentStamp: 'stephane.ducasse 9/25/2008 17:47'! DeepCopier does a veryDeepCopy. It is a complete tree copy using a dictionary. Any object that is in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy. See Object|veryDeepCopy which calls (self veryDeepCopyWith: aDeepCopier). When a tree of morphs points at a morph outside of itself, that morph should not be copied. Use our own kind of weak pointers for the 'potentially outside' morphs. Default is that any new class will have all of its fields deeply copied. If a field needs to be weakly copied, define veryDeepInner: and veryDeepFixupWith:. veryDeepInner: has the loop that actually copies the fields. If a class defines its own copy of veryDeepInner: (to leave some fields out), then veryDeepFixupWith: will be called on that object at the end. veryDeepInner: can compute an alternate object to put in a field. (Object veryDeepCopyWith: discovers which superclasses did not define veryDeepInner:, and very deeply copies the variables defined in those classes). To decide if a class needs veryDeepInner: and veryDeepFixupWith:, ask this about an instance: If I duplicate this object, does that mean that I also want to make duplicates of the things it holds onto? If yes, (i.e. a Paragraph does want a new copy of its Text) then do nothing. If no, (i.e. an undo command does not want to copy the objects it acts upon), then define veryDeepInner: and veryDeepFixupWith:. Here is an analysis for the specific case of a morph being held by another morph. Does field X contain a morph (or a Player whose costume is a morph)? If not, no action needed. Is the morph in field X already a submorph of the object? Is it down lower in the submorph tree? If so, no action needed. Could the morph in field X every appear on the screen (be a submorph of some other morph)? If not, no action needed. If it could, you must write the methods veryDeepFixupWith: and veryDeepInner:, and in them, refrain from sending veryDeepCopyWith: to the contents of field X. ----- Things Ted is still considering ----- Rule: If a morph stores a uniClass class (Player 57) as an object in a field, the new uniClass will not be stored there. Each uniClass instance does have a new class created for it. (fix this by putting the old class in references and allow lookup? Wrong if encounter it before seeing an instance?) Rule: If object A has object C in a field, and A says (^ C) for the copy, but object B has A in a normal field and it gets deepCopied, and A in encountered first, then there will be two copies of C. (just be aware of it) Dependents are now fixed up. Suppose a model has a dependent view. In the DependentFields dictionary, model -> (view ...). If only the model is copied, no dependents are created (no one knows about the new model). If only the view is copied, it is inserted into DependentFields on the right side. model -> (view copiedView ...). If both are copied, the new model has the new view as its dependent. If additional things depend on a model that is copied, the caller must add them to its dependents. ! !DeepCopier methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:50'! initialize super initialize. self initialize: 4096. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'MartinDias 10/25/2013 13:36'! warnInstanceVariableNotCopiedIn: aClass selector: aSelector "Warn the user to update veryDeepCopyWith: or veryDeepInner:" self inform: ('An instance variable was added to to class ', aClass name, ',\and it is not copied in the method ', aSelector, '.\Please rewrite it to handle all instance variables.\See DeepCopier class comment.') withCRs. (Smalltalk respondsTo: #tools) ifTrue: [ Smalltalk tools browser fullOnClass: aClass selector: aSelector ]! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'eem 6/11/2008 17:22'! fixDependents "They are not used much, but need to be right" DependentsFields associationsDo: [:pair | pair value do: [:dep | (references at: dep ifAbsent: [nil]) ifNotNil: [:newDep| | newModel | newModel := references at: pair key ifAbsent: [pair key]. newModel addDependent: newDep]]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 8/20/1998 22:13'! references ^ references! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'MartinDias 10/25/2013 13:35'! checkVariables "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it. DeepCopier new checkVariables " self checkBasicClasses. "Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. So check that the last one is mentioned in the copy method." (self systemNavigation allClassesImplementing: #veryDeepInner:) do: [:aClass | ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [aClass instSize > 0 ifTrue: [self warnInstanceVariableNotCopiedIn: aClass selector: #veryDeepInner:]]]. (self systemNavigation allClassesImplementing: #veryDeepCopyWith:) do: [:aClass | | meth | meth := aClass compiledMethodAt: #veryDeepCopyWith:. meth size > 20 & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [(meth writesField: aClass instSize) ifFalse: [self warnInstanceVariableNotCopiedIn: aClass selector: #veryDeepCopyWith:]]]! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'PavelKrivanek 11/15/2012 09:19'! checkBasicClasses "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it. DeepCopier new checkVariables " | str objCls morphCls | str := '|veryDeepCopyWith: or veryDeepInner: is out of date.'. Object instSize = 0 ifFalse: [self error: 'Many implementers of veryDeepCopyWith: are out of date']. ! ! !DeepCopier methodsFor: 'initialization' stamp: 'stephane.ducasse 9/25/2008 17:46'! initialize: size references := IdentityDictionary new: size. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'eem 6/11/2008 17:21'! checkDeep "Write exceptions in the Transcript. Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. This check is only run by hand once in a while to make sure nothing was forgotten. (Please do not remove this method.) DeepCopier new checkDeep " Transcript cr; show: 'Instance variables shared with the original object when it is copied'. (self systemNavigation allClassesImplementing: #veryDeepInner:) do: [:aClass | | mm | (mm := aClass instVarNames size) > 0 ifTrue: [aClass instSize - mm + 1 to: aClass instSize do: [:index | ((aClass compiledMethodAt: #veryDeepInner:) writesField: index) ifFalse: [Transcript cr; show: aClass name; space; show: (aClass allInstVarNames at: index)]]]]! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'MartinDias 10/25/2013 13:35'! checkClass: aClass | meth | "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it." self checkBasicClasses. "Unlikely, but important to catch when it does happen." "Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. So check that the last one is mentioned in the copy method." (aClass includesSelector: #veryDeepInner:) ifTrue: [ ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [ aClass instSize > 0 ifTrue: [ self warnInstanceVariableNotCopiedIn: aClass selector: #veryDeepInner:]]]. (aClass includesSelector: #veryDeepCopyWith:) ifTrue: [ meth := aClass compiledMethodAt: #veryDeepCopyWith:. (meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [ (meth writesField: aClass instSize) ifFalse: [ self warnInstanceVariableNotCopiedIn: aClass selector: #veryDeepCopyWith:]]]. ! ! !DefaultExternalDropHandler commentStamp: 'dgd 4/5/2004 19:07'! An alternative default handler that uses the file-list services to process files. ! !DefaultExternalDropHandler methodsFor: '*Morphic-Base' stamp: 'MarcusDenker 12/20/2010 15:36'! handle: dropStream in: pasteUp dropEvent: anEvent "the file was just droped, let's do our job" | fileName services theOne | fileName := dropStream name. services := self servicesForFileNamed: fileName. "no service, default behavior" services isEmpty ifTrue: [ dropStream edit. ^ self]. theOne := self chooseServiceFrom: services. theOne ifNotNil: [theOne performServiceFor: dropStream]! ! !DefaultExternalDropHandler methodsFor: 'private' stamp: ''! servicesForFileNamed: aString "private - answer a collection of file-services for the file named aString" | allServices | allServices := FileServices itemsForFile: aString. ^ allServices reject: [:svc | self unwantedSelectors includes: svc selector]! ! !DefaultExternalDropHandler methodsFor: 'private' stamp: ''! chooseServiceFrom: aCollection "private - choose a service from aCollection asking the user if needed" aCollection size = 1 ifTrue: [^ aCollection anyOne]. ^ UIManager default chooseFrom: (aCollection collect: [:each | each label]) values: aCollection. ! ! !DefaultExternalDropHandler methodsFor: 'private' stamp: ''! unwantedSelectors "private - answer a collection well known unwanted selectors " ^ #(#removeLineFeeds: #addFileToNewZip: #compressFile: #putUpdate: )! ! !DefaultExternalDropHandler class methodsFor: 'initialization' stamp: ''! unload "initialize the receiver" ExternalDropHandler defaultHandler: nil! ! !DefaultExternalDropHandler class methodsFor: 'initialization' stamp: ''! initialize "initialize the receiver" ExternalDropHandler defaultHandler: self new! ! !DeflateStream commentStamp: 'LaurentLaffont 6/8/2011 22:23'! I'm the base class for "stream compressor". For example, my subclass GZipWriteStream can compress a stream contents using gzip algorithm. Try: gzData := String streamContents: [:aStream| (GZipWriteStream on: aStream) nextPutAll: 'Some data to be gzipped'; close. ]. Transcript show: gzData; cr; show: (GZipReadStream on: gzData) upToEnd; cr. See InflateStream! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:47'! updateHashAt: here "Update the hash value at position here (one based)" ^self updateHash: (collection byteAt: here)! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:46'! insertStringAt: here "Insert the string at the given start position into the hash table. Note: The hash value is updated starting at MinMatch-1 since all strings before have already been inserted into the hash table (and the hash value is updated as well)." | prevEntry | hashValue := self updateHashAt: (here + MinMatch). prevEntry := hashHead at: hashValue+1. hashHead at: hashValue+1 put: here. hashTail at: (here bitAnd: WindowMask)+1 put: prevEntry.! ! !DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'! goodMatchLength "Return the length that is considered to be a 'good' match. Higher values will result in better compression but take more time." ^MaxMatch "Best compression"! ! !DeflateStream methodsFor: 'deflating' stamp: 'jannik.laval 5/1/2010 16:10'! deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch "Continue deflating the receiver's collection from blockPosition to lastIndex. Note that lastIndex must be at least MaxMatch away from the end of collection" | here matchResult flushNeeded hereMatch hereLength newMatch newLength hasMatch | blockPosition > lastIndex ifTrue:[^false]. "Nothing to deflate" hasMatch := false. here := blockPosition. [here <= lastIndex] whileTrue:[ hasMatch ifFalse:[ "Find the first match" matchResult := self findMatch: here lastLength: MinMatch-1 lastMatch: here chainLength: chainLength goodMatch: goodMatch. self insertStringAt: here. "update hash table" hereMatch := matchResult bitAnd: 16rFFFF. hereLength := matchResult bitShift: -16]. "Look ahead if there is a better match at the next position" matchResult := self findMatch: here+1 lastLength: hereLength lastMatch: hereMatch chainLength: chainLength goodMatch: goodMatch. newMatch := matchResult bitAnd: 16rFFFF. newLength := matchResult bitShift: -16. "Now check if the next match is better than the current one. If not, output the current match (provided that the current match is at least MinMatch long)" (hereLength >= newLength and:[hereLength >= MinMatch]) ifTrue:[ [self validateMatchAt: here from: hereMatch to: hereMatch + hereLength - 1] assert. "Encode the current match" flushNeeded := self encodeMatch: hereLength distance: here - hereMatch. "Insert all strings up to the end of the current match. Note: The first string has already been inserted." 1 to: hereLength-1 do:[:i| self insertStringAt: (here := here + 1)]. hasMatch := false. here := here + 1. ] ifFalse:[ "Either the next match is better than the current one or we didn't have a good match after all (e.g., current match length < MinMatch). Output a single literal." flushNeeded := self encodeLiteral: (collection byteAt: (here + 1)). here := here + 1. (here <= lastIndex and:[flushNeeded not]) ifTrue:[ "Cache the results for the next round" self insertStringAt: here. hasMatch := true. hereMatch := newMatch. hereLength := newLength]. ]. flushNeeded ifTrue:[blockPosition := here. ^true]. ]. blockPosition := here. ^false! ! !DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'! encodeLiteral: literal "Encode the given literal. Return true if the current block needs to be flushed." ^false! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 20:24'! compare: here with: matchPos min: minLength "Compare the two strings and return the length of matching characters. minLength is a lower bound for match lengths that will be accepted. Note: here and matchPos are zero based." | length | "First test if we can actually get longer than minLength" (collection at: here+minLength+1) = (collection at: matchPos+minLength+1) ifFalse:[^0]. (collection at: here+minLength) = (collection at: matchPos+minLength) ifFalse:[^0]. "Then test if we have an initial match at all" (collection at: here+1) = (collection at: matchPos+1) ifFalse:[^0]. (collection at: here+2) = (collection at: matchPos+2) ifFalse:[^1]. "Finally do the real comparison" length := 3. [length <= MaxMatch and:[ (collection at: here+length) = (collection at: matchPos+length)]] whileTrue:[length := length + 1]. ^length - 1! ! !DeflateStream methodsFor: 'private' stamp: 'ar 12/29/1999 17:50'! moveContentsToFront "Move the contents of the receiver to the front" | delta | delta := (blockPosition - WindowSize). delta <= 0 ifTrue:[^self]. "Move collection" collection replaceFrom: 1 to: collection size - delta with: collection startingAt: delta+1. position := position - delta. "Move hash table entries" blockPosition := blockPosition - delta. blockStart := blockStart - delta. self updateHashTable: hashHead delta: delta. self updateHashTable: hashTail delta: delta.! ! !DeflateStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 17:32'! initializeHashTables hashHead := WordArray new: 1 << HashBits. hashTail := WordArray new: WindowSize. ! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/31/1999 18:00'! deflateBlock "Deflate the current contents of the stream" | flushNeeded lastIndex | (blockStart == nil) ifTrue:[ "One time initialization for the first block" 1 to: MinMatch-1 do:[:i| self updateHashAt: i]. blockStart := 0]. [blockPosition < position] whileTrue:[ (position + MaxMatch > writeLimit) ifTrue:[lastIndex := writeLimit - MaxMatch] ifFalse:[lastIndex := position]. flushNeeded := self deflateBlock: lastIndex-1 chainLength: self hashChainLength goodMatch: self goodMatchLength. flushNeeded ifTrue:[ self flushBlock. blockStart := blockPosition]. "Make room for more data" self moveContentsToFront]. ! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:48'! updateHash: nextValue "Update the running hash value based on the next input byte. Return the new updated hash value." ^((hashValue bitShift: HashShift) bitXor: nextValue) bitAnd: HashMask.! ! !DeflateStream methodsFor: 'private' stamp: 'ar 2/2/2001 15:47'! updateHashTable: table delta: delta | pos | 1 to: table size do:[:i| "Discard entries that are out of range" (pos := table at: i) >= delta ifTrue:[table at: i put: pos - delta] ifFalse:[table at: i put: 0]].! ! !DeflateStream methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:51'! initialize super initialize. blockStart := nil. blockPosition := 0. hashValue := 0. self initializeHashTables.! ! !DeflateStream methodsFor: 'initialization' stamp: 'ar 12/28/1999 17:34'! on: aCollection from: firstIndex to: lastIndex "Not for DeflateStreams please" ^self shouldNotImplement! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:45'! findMatch: here lastLength: lastLength lastMatch: lastMatch chainLength: maxChainLength goodMatch: goodMatch "Find the longest match for the string starting at here. If there is no match longer than lastLength return lastMatch/lastLength. Traverse at most maxChainLength entries in the hash table. Stop if a match of at least goodMatch size has been found." | matchResult matchPos distance chainLength limit bestLength length | "Compute the default match result" matchResult := (lastLength bitShift: 16) bitOr: lastMatch. "There is no way to find a better match than MaxMatch" lastLength >= MaxMatch ifTrue:[^matchResult]. "Start position for searches" matchPos := hashHead at: (self updateHashAt: here + MinMatch) + 1. "Compute the distance to the (possible) match" distance := here - matchPos. "Note: It is required that 0 < distance < MaxDistance" (distance > 0 and:[distance < MaxDistance]) ifFalse:[^matchResult]. chainLength := maxChainLength. "Max. nr of match chain to search" here > MaxDistance "Limit for matches that are too old" ifTrue:[limit := here - MaxDistance] ifFalse:[limit := 0]. "Best match length so far (current match must be larger to take effect)" bestLength := lastLength. ["Compare the current string with the string at match position" length := self compare: here with: matchPos min: bestLength. "Truncate accidental matches beyound stream position" (here + length > position) ifTrue:[length := position - here]. "Ignore very small matches if they are too far away" (length = MinMatch and:[(here - matchPos) > (MaxDistance // 4)]) ifTrue:[length := MinMatch - 1]. length > bestLength ifTrue:["We have a new (better) match than before" "Compute the new match result" matchResult := (length bitShift: 16) bitOr: matchPos. bestLength := length. "There is no way to find a better match than MaxMatch" bestLength >= MaxMatch ifTrue:[^matchResult]. "But we may have a good, fast match" bestLength > goodMatch ifTrue:[^matchResult]. ]. (chainLength := chainLength - 1) > 0] whileTrue:[ "Compare with previous entry in hash chain" matchPos := hashTail at: (matchPos bitAnd: WindowMask) + 1. matchPos <= limit ifTrue:[^matchResult]. "Match position is too old" ]. ^matchResult! ! !DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'! encodeMatch: matchLength distance: matchDistance "Encode a match of the given length and distance. Return true if the current block should be flushed." ^false! ! !DeflateStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 17:30'! flush "Force compression" self deflateBlock.! ! !DeflateStream methodsFor: 'accessing' stamp: 'CamilleTeruel 11/2/2012 11:52'! nextPutAll: aCollection ^ self next: aCollection size putAll: aCollection startingAt: 1! ! !DeflateStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 17:33'! on: aCollection self initialize. super on: (aCollection species new: WindowSize * 2).! ! !DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'! hashChainLength "Return the max. number of hash chains to traverse. Higher values will result in better compression but take more time." ^4096 "Best compression"! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:37'! flushBlock "Flush a deflated block"! ! !DeflateStream methodsFor: 'accessing' stamp: 'ar 12/28/1999 17:35'! pastEndPut: anObject self deflateBlock. ^self nextPut: anObject! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:43'! validateMatchAt: pos from: startPos to: endPos | here | here := pos. startPos+1 to: endPos+1 do:[:i| (collection at: i) = (collection at: (here := here + 1)) ifFalse:[^self error:'Not a match']]. ^true! ! !DeflateStream methodsFor: 'accessing' stamp: 'CamilleTeruel 11/2/2012 11:51'! next: bytesCount putAll: aCollection startingAt: startIndex | start count max | aCollection species = collection species ifFalse:[ aCollection do:[:ch| self nextPut: ch]. ^ aCollection]. start := startIndex. count := bytesCount. [count = 0] whileFalse:[ position = writeLimit ifTrue:[self deflateBlock]. max := writeLimit - position. max > count ifTrue:[max := count]. collection replaceFrom: position+1 to: position+max with: aCollection startingAt: start. start := start + max. count := count - max. position := position + max]. ^ aCollection! ! !Delay commentStamp: 'VeronicaUquillas 6/11/2010 14:54'! I am the main way that a process may pause for some amount of time. The simplest usage is like this: (Delay forSeconds: 5) wait. An instance of Delay responds to the message 'wait' by suspending the caller's process for a certain amount of time. The duration of the pause is specified when the Delay is created with the message forMilliseconds: or forSeconds:. A Delay can be used again when the current wait has finished. For example, a clock process might repeatedly wait on a one-second Delay. The maximum delay is (SmallInteger maxVal // 2) milliseconds, or about six days. A delay in progress when an image snapshot is saved is resumed when the snapshot is re-started. Delays work across millisecond clock roll-overs. For a more complex example, see #testDelayOf:for:rect: . A word of advice: This is THE highest priority code which is run in Pharo, in other words it is time-critical. The speed of this code is critical for accurate responses, it is critical for network services, it affects every last part of the system. In short: Don't fix it if it ain't broken!! This code isn't supposed to be beautiful, it's supposed to be fast!! The reason for duplicating code is to make it fast. The reason for not using ifNil:[]ifNotNil:[] is that the compiler may not inline those. Since the effect of changes are VERY hard to predict it is best to leave things as they are for now unless there is an actual need to change anything! !Delay methodsFor: 'public' stamp: 'ar 7/10/2007 21:49'! beingWaitedOn "Answer whether this delay is currently scheduled, e.g., being waited on" ^beingWaitedOn! ! !Delay methodsFor: 'public' stamp: 'brp 10/21/2004 16:05'! delaySemaphore ^ delaySemaphore! ! !Delay methodsFor: 'private' stamp: 'GaryChambers 4/11/2011 10:07'! schedule "Schedule this delay." beingWaitedOn ifTrue: [^self error: 'This Delay has already been scheduled.']. AccessProtect critical: [ ScheduledDelay := self. TimingSemaphore signal]! ! !Delay methodsFor: 'private' stamp: 'nice 4/19/2009 21:18'! setDelay: milliseconds forSemaphore: aSemaphore "Private!! Initialize this delay to signal the given semaphore after the given number of milliseconds." delayDuration := milliseconds asInteger. delayDuration < 0 ifTrue: [self error: 'delay times cannot be negative']. delaySemaphore := aSemaphore. beingWaitedOn := false.! ! !Delay methodsFor: 'public' stamp: 'ar 7/10/2007 21:49'! beingWaitedOn: aBool "Indicate whether this delay is currently scheduled, e.g., being waited on" beingWaitedOn := aBool! ! !Delay methodsFor: 'private' stamp: 'jm 9/11/97 11:54'! resumptionTime "Answer the value of the system's millisecondClock at which the receiver's suspended Process will resume." ^ resumptionTime ! ! !Delay methodsFor: 'public' stamp: 'ar 7/10/2007 20:56'! delayDuration ^delayDuration! ! !Delay methodsFor: 'private' stamp: 'jm 9/11/97 14:49'! adjustResumptionTimeOldBase: oldBaseTime newBase: newBaseTime "Private!! Adjust the value of the system's millisecond clock at which this Delay will be awoken. Used to adjust resumption times after a snapshot or clock roll-over." resumptionTime := newBaseTime + (resumptionTime - oldBaseTime). ! ! !Delay methodsFor: 'private' stamp: 'ar 3/2/2009 14:42'! unschedule AccessProtect critical:[ FinishedDelay := self. TimingSemaphore signal. ].! ! !Delay methodsFor: 'printing' stamp: 'ar 7/10/2007 22:12'! printOn: aStream super printOn: aStream. aStream nextPutAll: '('; print: delayDuration; nextPutAll: ' msecs'. beingWaitedOn ifTrue:[ aStream nextPutAll: '; '; print: resumptionTime - Time millisecondClockValue; nextPutAll: ' msecs remaining'. ]. aStream nextPutAll: ')'.! ! !Delay methodsFor: 'private' stamp: 'JuanVuletich 10/10/2010 22:58'! setDelay: milliseconds "Private!! Initialize this delay to signal the given semaphore after the given number of milliseconds." delayDuration := milliseconds asInteger! ! !Delay methodsFor: 'private' stamp: 'GaryChambers 4/11/2011 10:04'! resumptionTime: anInteger "Private!! Set the value of the system's millisecondClock at which the receiver's suspended Process will resumed. Must only be called from the class-side #scheduleDelay:." resumptionTime := anInteger! ! !Delay methodsFor: 'delaying' stamp: 'ar 8/30/2007 19:32'! wait "Schedule this Delay, then wait on its semaphore. The current process will be suspended for the amount of time specified when this Delay was created." self schedule. [delaySemaphore wait] ifCurtailed:[self unschedule]. ! ! !Delay methodsFor: 'private' stamp: 'jm 9/11/97 11:54'! signalWaitingProcess "The delay time has elapsed; signal the waiting process." beingWaitedOn := false. delaySemaphore signal. ! ! !Delay methodsFor: 'delaying' stamp: 'nk 3/14/2001 08:52'! isExpired ^delaySemaphore isSignaled. ! ! !Delay class methodsFor: 'primitives' stamp: 'ar 3/2/2009 14:43'! primSignal: aSemaphore atMilliseconds: aSmallInteger "Signal the semaphore when the millisecond clock reaches the value of the second argument. Fail if the first argument is neither a Semaphore nor nil. Essential. See Object documentation whatIsAPrimitive." ^self primitiveFailed! ! !Delay class methodsFor: 'instance creation' stamp: 'CamilloBruni 6/23/2013 13:44'! forSeconds: aNumber "Return a new Delay for the given number of Seconds" ^ self forMilliseconds: aNumber * 1000 ! ! !Delay class methodsFor: 'snapshotting' stamp: 'CamilloBruni 10/14/2013 22:00'! shutDown "Suspend the active delay, if any, before snapshotting. It will be reactived when the snapshot is resumed." "Details: This prevents a timer interrupt from waking up the active delay in the midst snapshoting, since the active delay will be restarted when resuming the snapshot and we don't want to process the delay twice." AccessProtect consumeAllSignals. self primSignal: nil atMilliseconds: 0. self saveResumptionTimes. DelaySuspended := true.! ! !Delay class methodsFor: 'instance creation' stamp: 'laza 1/30/2005 22:10'! forMilliseconds: aNumber "Return a new Delay for the given number of milliseconds. Sending 'wait' to this Delay will cause the sender's process to be suspended for approximately that length of time." ^ self new setDelay: aNumber forSemaphore: Semaphore new ! ! !Delay class methodsFor: 'timer process' stamp: 'CamilloBruni 6/23/2013 13:48'! runTimerEventLoop "Run the timer event loop." [ RunTimerEventLoop ] whileTrue: [ self handleTimerEvent ]! ! !Delay class methodsFor: 'instance creation' stamp: 'CamilloBruni 6/23/2013 13:44'! forDuration: aDuration "Return a new Delay for the given duration." ^ self forMilliseconds: aDuration asMilliSeconds ! ! !Delay class methodsFor: 'snapshotting' stamp: 'CamilloBruni 6/23/2013 13:48'! saveResumptionTimes "Private!! Record the resumption times of all Delays relative to a base time of zero. This is done prior to snapshotting or adjusting the resumption times after a clock roll-over. This method should be called only while the AccessProtect semaphore is held." | oldBaseTime | oldBaseTime := Time millisecondClockValue. ActiveDelay == nil ifFalse: [ oldBaseTime < ActiveDelayStartTime ifTrue: [ oldBaseTime := ActiveDelayStartTime ]. "clock rolled over" ActiveDelay adjustResumptionTimeOldBase: oldBaseTime newBase: 0 ]. SuspendedDelays do: [ :delay | delay adjustResumptionTimeOldBase: oldBaseTime newBase: 0 ]. ! ! !Delay class methodsFor: 'timer process' stamp: 'CamilloBruni 6/23/2013 13:49'! scheduleDelay: aDelay "Private. Schedule this Delay." aDelay resumptionTime: Time millisecondClockValue + aDelay delayDuration. "Do the above here, via the high priority timer process to avoid rollover bug due to process pre-emption since the caller cannot use the AccessProtect semaphore." aDelay beingWaitedOn: true. ActiveDelay ifNil: [ ActiveDelay := aDelay ] ifNotNil: [ aDelay resumptionTime < ActiveDelay resumptionTime ifTrue: [ SuspendedDelays add: ActiveDelay. ActiveDelay := aDelay ] ifFalse: [ SuspendedDelays add: aDelay ]] ! ! !Delay class methodsFor: 'instance creation' stamp: 'laza 1/6/2008 06:35'! timeoutSemaphore: aSemaphore afterMSecs: anInteger "Create and schedule a Delay to signal the given semaphore when the given number of milliseconds has elapsed. Return the scheduled Delay. The timeout can be cancelled by sending 'unschedule' to this Delay." "Details: This mechanism is used to provide a timeout when waiting for an external event, such as arrival of data over a network connection, to signal a semaphore. The timeout ensures that the semaphore will be signalled within a reasonable period of time even if the event fails to occur. Typically, the waiting process cancels the timeout request when awoken, then determines if the awaited event has actually occurred." ^ (self new setDelay: anInteger forSemaphore: aSemaphore) schedule ! ! !Delay class methodsFor: 'timer process' stamp: 'StephaneDucasse 5/18/2012 18:19'! schedulingProcess ^ TimerEventLoop ! ! !Delay class methodsFor: 'snapshotting' stamp: 'CamilloBruni 6/23/2013 13:47'! restoreResumptionTimes "Private!! Restore the resumption times of all scheduled Delays after a snapshot or clock roll-over. This method should be called only while the AccessProtect semaphore is held." | newBaseTime | newBaseTime := Time millisecondClockValue. SuspendedDelays do: [ :delay | delay adjustResumptionTimeOldBase: 0 newBase: newBaseTime ]. ActiveDelay == nil ifFalse: [ ActiveDelay adjustResumptionTimeOldBase: 0 newBase: newBaseTime ]. ! ! !Delay class methodsFor: 'class initialization' stamp: 'GuillermoPolito 6/27/2012 12:56'! initialize "Delay initialize" TimingSemaphore := (Smalltalk specialObjectsArray at: 30). DelaySuspended := true. Smalltalk addToStartUpList: self.! ! !Delay class methodsFor: 'timer process' stamp: 'CamilloBruni 8/21/2013 19:18'! startTimerEventLoop "Start the timer event loop" "Delay startTimerEventLoop" self stopTimerEventLoop. AccessProtect := Semaphore forMutualExclusion. ActiveDelayStartTime := Time millisecondClockValue. SuspendedDelays := Heap withAll: (SuspendedDelays ifNil: [ #() ]) sortBlock: [ :delay1 :delay2 | delay1 resumptionTime <= delay2 resumptionTime ]. TimingSemaphore := Semaphore new. RunTimerEventLoop := true. TimerEventLoop := [ self runTimerEventLoop ] newProcess. TimerEventLoop name: 'Delay Scheduling Process'; priority: Processor timingPriority. TimerEventLoop resume. TimingSemaphore signal. "get going" ! ! !Delay class methodsFor: 'snapshotting' stamp: 'CamilloBruni 10/14/2013 21:41'! startUp "Restart active delay, if any, when resuming a snapshot." "Compare to false since it can be nil" (DelaySuspended = false) ifTrue:[ ^self error: 'Trying to activate Delay twice' ]. DelaySuspended := false. ActiveDelayStartTime := Time millisecondClockValue. self restoreResumptionTimes. AccessProtect signal. ! ! !Delay class methodsFor: 'timer process' stamp: 'ar 7/10/2007 21:26'! stopTimerEventLoop "Stop the timer event loop" RunTimerEventLoop := false. TimingSemaphore signal. TimerEventLoop := nil.! ! !Delay class methodsFor: 'testing' stamp: 'ClementBera 7/26/2013 16:15'! nextWakeUpTime ^ AccessProtect critical: [ ActiveDelay ifNil: [ 0 ] ifNotNil: [ ActiveDelay resumptionTime ]]! ! !Delay class methodsFor: 'timer process' stamp: 'CamilloBruni 6/23/2013 13:53'! unscheduleDelay: aDelay "Private. Unschedule this Delay." aDelay beingWaitedOn ifFalse:[ ^self ]. ActiveDelay == aDelay ifTrue: [ SuspendedDelays isEmpty ifTrue: [ ActiveDelay := nil ] ifFalse: [ ActiveDelay := SuspendedDelays removeFirst ]] ifFalse:[ SuspendedDelays remove: aDelay ifAbsent: []]. aDelay beingWaitedOn: false.! ! !Delay class methodsFor: 'testing' stamp: 'ar 9/6/1999 17:05'! anyActive "Return true if there is any delay currently active" ^ActiveDelay notNil! ! !Delay class methodsFor: 'timer process' stamp: 'CamilloBruni 10/14/2013 22:25'! handleTimerEvent "Handle a timer event; which can be either: - a schedule request (ScheduledDelay notNil) - an unschedule request (FinishedDelay notNil) - a timer signal (not explicitly specified) We check for timer expiry every time we get a signal." | nowTick nextTick | "Wait until there is work to do." TimingSemaphore wait. "Process any schedule requests" ScheduledDelay ifNotNil: [ "Schedule the given delay" self scheduleDelay: ScheduledDelay. ScheduledDelay := nil ]. "Process any unschedule requests" FinishedDelay ifNotNil: [ self unscheduleDelay: FinishedDelay. FinishedDelay := nil ]. "Check for clock wrap-around." nowTick := Time millisecondClockValue. nowTick < ActiveDelayStartTime ifTrue: [ "clock wrapped" self saveResumptionTimes. self restoreResumptionTimes ]. ActiveDelayStartTime := nowTick. "Signal any expired delays" [ ActiveDelay notNil and:[ nowTick >= ActiveDelay resumptionTime ]] whileTrue: [ ActiveDelay signalWaitingProcess. SuspendedDelays isEmpty ifTrue: [ ActiveDelay := nil ] ifFalse:[ ActiveDelay := SuspendedDelays removeFirst ]]. "And signal when the next request is due. We sleep at most 1sec here as a soft busy-loop so that we don't accidentally miss signals." nextTick := nowTick + 1000. ActiveDelay ifNotNil: [ nextTick := nextTick min: ActiveDelay resumptionTime ]. nextTick := nextTick min: SmallInteger maxVal. "Since we have processed all outstanding requests, reset the timing semaphore so that only new work will wake us up again. Do this RIGHT BEFORE setting the next wakeup call from the VM because it is only signaled once so we mustn't miss it." TimingSemaphore consumeAllSignals. Delay primSignal: TimingSemaphore atMilliseconds: nextTick. "This last test is necessary for the obscure case that the msecs clock rolls over after nowTick has been computed (unlikely but not impossible). In this case we'd wait for MillisecondClockMask msecs (roughly six days) or until another delay gets scheduled (which may not be any time soon). In any case, since handling the condition is easy, let's just deal with it" Time millisecondClockValue < nowTick ifTrue:[ TimingSemaphore signal ]. "retry" ! ! !DelayTest methodsFor: 'testing' stamp: 'nice 1/5/2010 15:59'! testSemaphore "When we provide our own semaphore for a Delay, it should be used" "See http://bugs.squeak.org/view.php?id=6834" "self run: #testSemaphore" | sem | sem := Semaphore new. [ | process | process := [Delay timeoutSemaphore: sem afterMSecs: 0. sem wait] newProcess. process priority: Processor highIOPriority. process resume. self assert: process isTerminated. ] ensure: [sem signal]! ! !DelayTest methodsFor: 'testing-limits' stamp: 'ar 9/21/2009 22:12'! testMultiSchedule "Ensure that scheduling the same delay twice raises an error" | delay | delay := Delay forSeconds: 1. delay schedule. self should:[delay schedule] raise: Error. ! ! !DelayTest methodsFor: 'testing-limits' stamp: 'ar 9/21/2009 22:14'! testMultiProcessWaitOnSameDelay "Ensure that waiting on the same delay from multiple processes raises an error" | delay p1 p2 wasRun | delay := Delay forSeconds: 1. wasRun := false. p1 := [delay wait] forkAt: Processor activePriority+1. p2 := [ self should:[delay wait] raise: Error. wasRun := true. ] forkAt: Processor activePriority+1. p1 terminate. p2 terminate. self assert: wasRun. ! ! !DelayTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testBounds "self run: #testBounds" self should: [ Delay forMilliseconds: -1 ] raise: Error. Delay forMilliseconds: SmallInteger maxVal // 2 + 1. Delay forMilliseconds: SmallInteger maxVal + 1. (Delay forMilliseconds: Float pi) wait "Wait 3ms"! ! !DelayWaitTimeout commentStamp: ''! DelayWaitTimeout is a special kind of Delay used in waitTimeoutMSecs: to avoid signaling the underlying semaphore when the wait times out.! !DelayWaitTimeout methodsFor: 'waiting' stamp: 'ar 3/27/2009 22:26'! wait "Wait until either the semaphore is signaled or the delay times out" [self schedule. "It is critical that the following has no suspension point so that the test and the wait primitive are atomic. In addition, if the delay is no longer being waited on while entering the way we know that it is expired because the delay has already fired." beingWaitedOn ifTrue:[delaySemaphore wait] ifFalse:[expired := true]] ensure:[self unschedule]. ^self isExpired ! ! !DelayWaitTimeout methodsFor: 'signaling' stamp: 'ar 3/24/2009 23:24'! signalWaitingProcess "Release the given process from the semaphore it is waiting on. This method relies on running at highest priority so that it cannot be preempted by the process being released." beingWaitedOn := false. "Release the process but only if it is still waiting on its original list" process suspendingList == delaySemaphore ifTrue:[ expired := true. process suspend; resume. ]. ! ! !DelayWaitTimeout methodsFor: 'testing' stamp: 'ar 3/23/2009 16:37'! isExpired "Did this timeout fire before the associated semaphore was signaled?" ^expired! ! !DelayWaitTimeout methodsFor: 'private' stamp: 'ar 3/23/2009 16:38'! setDelay: anInteger forSemaphore: aSemaphore super setDelay: anInteger forSemaphore: aSemaphore. process := Processor activeProcess. expired := false.! ! !DeleteVisitor commentStamp: 'cwp 11/18/2009 12:30'! I delete the directory tree that I visit. I use the PostorderGuide so that I can delete files before deleting their containing directories.! !DeleteVisitor methodsFor: 'visiting' stamp: 'CamilloBruni 4/10/2013 12:19'! visit: aReference PostorderGuide show: aReference to: self selecting: [ :entry | entry isSymlink not ]! ! !DeleteVisitor methodsFor: 'visiting' stamp: 'cwp 11/16/2009 10:53'! visitReference: anEntry anEntry reference delete! ! !DeleteVisitor class methodsFor: 'instance creation' stamp: 'cwp 11/17/2009 13:02'! delete: aReference ^ self new visit: aReference! ! !DeleteVisitorTest commentStamp: 'TorstenBergmann 1/31/2014 11:42'! SUnit tests for class DeleteVisitor! !DeleteVisitorTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:40'! testBeta self setUpGreek. DeleteVisitor delete: (filesystem / 'alpha' / 'beta'). self assert: (filesystem isDirectory: '/alpha'). self assert: (filesystem isDirectory: '/alpha/epsilon'). self deny: (filesystem exists: '/alpha/beta'). ! ! !DenyDialogWindow commentStamp: 'gvc 5/18/2007 13:27'! Dialog window displaying a message with a single OK button. Escape/return will close. Icon is a themed lock icon.! !DenyDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon "Answer an icon for the receiver." ^ Smalltalk ui icons lockIcon! ! !DenyDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallLockIcon! ! !DependentsArray commentStamp: 'nice 11/11/2009 20:30'! Act as an array of (weak) dependents of some object. When dependents are reclaimed, they are replaced by an UndefinedObject in the DependentsArray. This is why instances of this class will take care to iterate only on non nil elements. These nil also cause loops written as (1 to: self size do: [:i | (self at: i) doSomething]) to be inefficient. This is because #size and #at: both require scanning for nils. For this reason, DependentsArray though sequenceable, is not a subclass of SequenceableCollection.! !DependentsArray methodsFor: 'copying' stamp: 'nice 11/11/2009 16:56'! copyWith: newElement "Re-implemented to not copy any niled out dependents." | copy i | copy := self class new: self size + 1. i := 0. self do: [:item | copy basicAt: (i:=i+1) put: item]. copy basicAt: (i:=i+1) put: newElement. ^copy! ! !DependentsArray methodsFor: 'accessing' stamp: 'nice 11/11/2009 17:19'! last self reverseDo: [:dep | ^dep]. self error: 'this collection is empty'! ! !DependentsArray methodsFor: 'accessing' stamp: 'nice 11/11/2009 19:20'! size "count each non nil elements in self. Note: count: will use do: which will already have filtered out nil elements" ^self count: [:each | true]! ! !DependentsArray methodsFor: 'enumerating' stamp: 'MarcusDenker 8/16/2010 12:51'! select: aBlock "Refer to the comment in Collection|select:." | basicSize newSelf size selection | basicSize := self basicSize. newSelf := self species new: basicSize. size := 0. 1 to: basicSize do: [ :i | (self basicAt: i) ifNotNil: [ :dep | (aBlock value: dep) ifTrue: [ newSelf basicAt: (size := size+1) put: dep ] ] ]. selection := self species new: size. selection basicReplaceFrom: 1 to: size with: newSelf startingAt: 1. ^selection! ! !DependentsArray methodsFor: 'accessing' stamp: 'nice 11/11/2009 20:15'! at: anIndex put: anObject | basicSize counter | anIndex > 0 ifTrue: [ basicSize := self basicSize. anIndex <= basicSize ifTrue: [ counter := 0. 1 to: basicSize do: [:i | (self basicAt: i) == nil ifFalse: [(counter := counter + 1) = anIndex ifTrue: [^self basicAt: i put: anObject]]]]]. self error: 'access with an index out of bounds'! ! !DependentsArray methodsFor: 'private' stamp: 'nice 11/11/2009 17:08'! basicReplaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." start to: stop do: [:i | self basicAt: i put: (replacement basicAt: repStart - start + i)]! ! !DependentsArray methodsFor: 'accessing' stamp: 'nice 11/11/2009 17:19'! first self do: [:dep | ^dep]. self error: 'this collection is empty'! ! !DependentsArray methodsFor: 'enumerating' stamp: 'nice 11/11/2009 20:36'! do: aBlock "Evaluate a Block on non nil elements of the receiver" | dep | 1 to: self basicSize do:[:i| (dep := self basicAt: i) ifNotNil:[aBlock value: dep]].! ! !DependentsArray methodsFor: 'accessing' stamp: 'nice 11/11/2009 17:19'! at: anIndex | basicSize counter dep | anIndex > 0 ifTrue: [ basicSize := self basicSize. anIndex <= basicSize ifTrue: [ counter := 0. 1 to: basicSize do: [:i | (dep := self basicAt: i) == nil ifFalse: [(counter := counter + 1) = anIndex ifTrue: [^dep]]]]]. self error: 'access with an index out of bounds'! ! !DependentsArray methodsFor: 'enumerating' stamp: 'nice 11/11/2009 20:33'! collect: aBlock "Refer to the comment in Collection|select:." | basicSize newSelf size dep selection | basicSize := self basicSize. newSelf := self species new: basicSize. size := 0. 1 to: basicSize do: [:i | (dep := self basicAt: i) notNil ifTrue: [newSelf basicAt: (size := size+1) put: (aBlock value: dep)]]. selection := self species new: size. selection basicReplaceFrom: 1 to: size with: newSelf startingAt: 1. ^selection! ! !DependentsArray methodsFor: 'enumerating' stamp: 'nice 11/11/2009 17:18'! reverseDo: aBlock "Refer to the comment in Collection|do:." | dep | self basicSize to: 1 by: -1 do: [:i | (dep := self basicAt: i) ifNotNil: [aBlock value: dep]]! ! !DependentsArray methodsFor: 'converting' stamp: 'nice 12/18/2009 11:05'! writeStream ^ WriteStream on: self! ! !DependentsArray class methodsFor: 'instance creation' stamp: 'nice 11/11/2009 17:30'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject ^(self basicNew: 6) basicAt: 1 put: firstObject; basicAt: 2 put: secondObject; basicAt: 3 put: thirdObject; basicAt: 4 put: fourthObject; basicAt: 5 put: fifthObject; basicAt: 6 put: sixthObject; yourself! ! !DependentsArray class methodsFor: 'instance creation' stamp: 'nice 11/11/2009 17:29'! with: firstObject with: secondObject with: thirdObject with: fourthObject ^(self basicNew: 4) basicAt: 1 put: firstObject; basicAt: 2 put: secondObject; basicAt: 3 put: thirdObject; basicAt: 4 put: fourthObject; yourself! ! !DependentsArray class methodsFor: 'instance creation' stamp: 'nice 11/11/2009 17:29'! with: firstObject with: secondObject with: thirdObject ^(self basicNew: 3) basicAt: 1 put: firstObject; basicAt: 2 put: secondObject; basicAt: 3 put: thirdObject; yourself! ! !DependentsArray class methodsFor: 'instance creation' stamp: 'nice 11/11/2009 17:24'! with: anObject ^(self basicNew: 1) basicAt: 1 put: anObject; yourself! ! !DependentsArray class methodsFor: 'instance creation' stamp: 'nice 11/11/2009 17:29'! withAll: aCollection | newInstance | newInstance := self basicNew: aCollection size. 1 to: aCollection size do: [:i | newInstance basicAt: i put: (aCollection at: i)]. ^newInstance! ! !DependentsArray class methodsFor: 'instance creation' stamp: 'nice 11/11/2009 17:29'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject ^(self basicNew: 5) basicAt: 1 put: firstObject; basicAt: 2 put: secondObject; basicAt: 3 put: thirdObject; basicAt: 4 put: fourthObject; basicAt: 5 put: fifthObject; yourself! ! !DependentsArray class methodsFor: 'instance creation' stamp: 'nice 11/11/2009 17:29'! with: firstObject with: secondObject ^(self basicNew: 2) basicAt: 1 put: firstObject; basicAt: 2 put: secondObject; yourself! ! !DependentsArrayTest methodsFor: 'test' stamp: 'GabrielOmarCotelli 5/25/2009 16:16'! testSize self assert: (DependentsArray with: nil) size = 0; assert: (DependentsArray with: nil with: 1 with: nil) size = 1; assert: (DependentsArray with: 1 with: 3) size = 2; assert: (DependentsArray with: nil with: nil with: nil) size = 0! ! !Deprecation commentStamp: 'dew 5/21/2003 17:46'! This Warning is signalled by methods which are deprecated. The use of Object>>#deprecatedExplanation: aString and Object>>#deprecated: aBlock explanation: aString is recommended. Idiom: Imagine I want to deprecate the message #foo. foo ^ 'foo' I can replace it with: foo self deprecatedExplanation: 'The method #foo was not good. Use Bar>>newFoo instead.' ^ 'foo' Or, for certain cases such as when #foo implements a primitive, #foo can be renamed to #fooDeprecated. fooDeprecated ^ foo ^ self deprecated: [self fooDeprecated] explanation: 'The method #foo was not good. Use Bar>>newFoo instead.' ! !Deprecation methodsFor: 'accessing' stamp: 'eem 7/3/2009 19:07'! explanationString "Answer the value of explanationString" ^ explanationString! ! !Deprecation methodsFor: 'comparing' stamp: 'eem 7/3/2009 19:08'! hash ^(methodReference ifNil: [explanationString]) hash! ! !Deprecation methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 10:08'! showWarning ^ self class showWarning! ! !Deprecation methodsFor: 'accessing' stamp: 'eem 7/3/2009 19:07'! versionString "Answer the value of versionString" ^ versionString! ! !Deprecation methodsFor: 'comparing' stamp: 'eem 7/3/2009 19:10'! = anObject ^self class == anObject class and: [methodReference = anObject methodReference and: [methodReference ifNil: [explanationString = anObject explanationString] ifNotNil: [true]]]! ! !Deprecation methodsFor: 'handling' stamp: 'AlainPlantec 12/11/2009 10:09'! defaultAction Log ifNotNil: [:log | log add: self]. self showWarning ifTrue: [Transcript nextPutAll: self messageText; cr; flush]. self raiseWarning ifTrue: [super defaultAction]! ! !Deprecation methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 10:08'! raiseWarning ^ self class raiseWarning! ! !Deprecation methodsFor: 'initialize-release' stamp: 'eem 7/3/2009 18:57'! method: aCompiledMethod explanation: anExplanationString on: dateString in: aVersionString methodReference := aCompiledMethod methodReference. explanationString := anExplanationString. deprecationDate := dateString. versionString := aVersionString ! ! !Deprecation methodsFor: 'accessing' stamp: 'VeronicaUquillas 8/31/2011 15:26'! messageText "Return an exception's message text." ^ 'The method ', methodReference fullName, ' has been deprecated. ', explanationString! ! !Deprecation methodsFor: 'accessing' stamp: 'eem 7/3/2009 19:07'! methodReference "Answer the value of methodReference" ^ methodReference! ! !Deprecation methodsFor: 'accessing' stamp: 'eem 7/3/2009 19:07'! deprecationDate "Answer the value of deprecationDate" ^ deprecationDate! ! !Deprecation methodsFor: '*SUnit-Core' stamp: 'DamienCassou 12/4/2013 09:42'! sunitAnnounce: aTestCase toResult: aTestResult self resume! ! !Deprecation class methodsFor: 'class initialization' stamp: 'GuillermoPolito 5/21/2012 01:57'! initialize Log := nil! ! !Deprecation class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 10:07'! showWarning ^ ShowWarning ifNil: [ShowWarning := true]! ! !Deprecation class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 10:06'! raiseWarning ^ RaiseWarning ifNil: [RaiseWarning := true]! ! !Deprecation class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 10:06'! raiseWarning: aBoolean RaiseWarning := aBoolean! ! !Deprecation class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 10:07'! showWarning: aBoolean ShowWarning := aBoolean! ! !Deprecation class methodsFor: 'instance creation' stamp: 'eem 7/3/2009 19:15'! method: aCompiledMethod explanation: anExplanationString on: dateString in: aVersionString ^self new method: aCompiledMethod explanation: anExplanationString on: dateString in: aVersionString! ! !Deprecation class methodsFor: 'logging' stamp: 'eem 7/3/2009 19:13'! deprecationsWhile: aBlock | oldLog result | oldLog := Log. Log := Set new. aBlock value. result := Log. oldLog ifNotNil: [oldLog addAll: result]. Log := oldLog. ^result! ! !DialogGroupAdder commentStamp: 'TorstenBergmann 2/4/2014 21:13'! Adder for dialog groups! !DialogGroupAdder methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/29/2011 11:14'! uiClass ^ DialogGroupAdderUI! ! !DialogGroupAdder methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/2/2012 17:39'! add: aCollection into: aGroup (elementsToAdd allSatisfy: [:e | e isBehavior ]) ifTrue: [ self groups addClasses: aCollection into: aGroup ] ifFalse: [ self groups add: aCollection into: aGroup ]! ! !DialogGroupAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/28/2011 14:02'! elementsToAdd: anObject elementsToAdd := anObject! ! !DialogGroupAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/28/2011 14:01'! elementsToAdd ^ elementsToAdd! ! !DialogGroupAdderUI commentStamp: 'TorstenBergmann 2/4/2014 21:12'! Dialog UI for the group adder! !DialogGroupAdderUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 15:46'! elementBox ^ GroupboxMorph new addContentMorph: self buildTextMorph; label: 'Item to add:'; hResizing: #spaceFill; vResizing: #shrinkWrap! ! !DialogGroupAdderUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 15:45'! newContentMorph ^(self newColumn: { self elementBox. self treeBox}) hResizing: #spaceFill! ! !DialogGroupAdderUI methodsFor: 'build items' stamp: 'BenjaminVanRyseghem 3/28/2011 14:02'! elementsToAdd ^ self groupManager elementsToAdd! ! !DialogGroupAdderUI methodsFor: 'build items' stamp: 'BenjaminVanRyseghem 4/14/2012 12:13'! buildTextMorph ^ (PluggableTextMorph on: self text: #text accept: nil) disable; hResizing: #spaceFill; yourself! ! !DialogGroupAdderUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/14/2012 12:15'! valid self selectedGroup ifNotNil: [:group | self groupManager add: self elementsToAdd into: group ]! ! !DialogGroupAdderUI methodsFor: 'build items' stamp: 'BenjaminVanRyseghem 2/25/2012 16:41'! text ^ (self groupManager elementsToAdd collect: [:elt | elt prettyName ]) asArray joinUsing: '. '! ! !DialogGroupAdderUI methodsFor: 'tree' stamp: 'ClementBera 9/30/2013 11:00'! groups ^ self groupManager groups groups select: [:group | group isFillable and: [ group isReadOnly not ] ]! ! !DialogGroupManager commentStamp: 'TorstenBergmann 2/4/2014 21:12'! Dialog group manager for groups in Nautilus! !DialogGroupManager methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/29/2011 11:14'! uiClass ^ DialogGroupManagerUI! ! !DialogGroupManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:34'! groups: anObject groups := anObject! ! !DialogGroupManager methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 15:39'! open (self uiClass on: self) title: 'Group Manager'; openInWorld! ! !DialogGroupManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:34'! groups ^ groups! ! !DialogGroupManagerUI commentStamp: 'TorstenBergmann 2/4/2014 21:12'! Dialog UI for the group manager! !DialogGroupManagerUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 15:45'! newContentMorph ^(self newColumn: {self treeBox}) hResizing: #spaceFill! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/14/2012 12:39'! removeAGroup | group | group := self groupManager groups removeAGroup: self selectedGroup. tree updateList. treeModel selection: nil. treeModel changed: #selection.! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 9/15/2011 15:48'! removeAction self removeAGroup! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/19/2011 16:35'! renameGroup self groupManager groups renameAGroup: self selectedGroup. tree updateList.! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 14:33'! addAction self addAGroup! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 14:08'! removeState ^ self selectedGroup notNil! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/15/2011 16:53'! addAGroup | group | group := self groupManager groups createAnEmptyStaticGroup. tree updateList. treeModel hardlySelectItem: group.! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/15/2011 15:48'! valid! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 14:21'! addLabel ^ 'Create'! ! !DialogGroupManagerUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 15:32'! initialExtent ^ 300@400! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/15/2011 14:21'! okButtonAction self valid.! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/15/2011 14:19'! selectedGroup ^ self selectedNode ifNil: [ nil ] ifNotNil: [:node | node isGroup ifTrue: [ node item ] ifFalse: [ node parentNode item ]]! ! !DialogGroupManagerUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 15:34'! buildRenameButton ^ (PluggableButtonMorph on: self getState: #renameState action: #renameAction label: #renameLabel) hResizing: #spaceFill; yourself! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 15:34'! renameLabel ^ 'Rename'! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 14:08'! addState ^ true! ! !DialogGroupManagerUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:36'! groupManager ^ groupManager! ! !DialogGroupManagerUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 15:25'! isResizeable ^true! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 15:34'! renameState ^ self selectedGroup notNil! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 15:33'! renameAction self renameGroup! ! !DialogGroupManagerUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 14:11'! buildAddButton ^ (PluggableButtonMorph on: self getState: #addState action: #addAction label: #addLabel) hResizing: #spaceFill; yourself! ! !DialogGroupManagerUI methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 10/31/2011 03:34'! setSelectedNodeItem: anItem | node | node := tree listManager nodeMorphsWithAllNodeItems: { anItem }. tree listManager selectedItems: node. ^ node! ! !DialogGroupManagerUI methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 3/15/2011 14:19'! treeModel ^ treeModel ifNil: [treeModel := self treeModelClass new model: self]! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/15/2011 14:19'! selectedNode ^ self treeModel selectedNode! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/15/2011 13:16'! treeModelClass ^ GroupCreatorTreeModel! ! !DialogGroupManagerUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/17/2011 15:11'! groupManager: aModel groupManager := aModel! ! !DialogGroupManagerUI methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 3/15/2011 15:29'! buildGroupsTree tree := (MorphTreeMorph on: self treeModel) beSingle; autoDeselection: true; rowInset: 4; columnInset: 4; getMenuSelector: #menu:shifted:; rowColorForEven: Color lightGray muchLighter odd: Color white. tree vResizing: #spaceFill; hResizing: #spaceFill. ^ tree buildContents! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 14:08'! removeLabel ^ 'Remove'! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/15/2011 14:14'! updateSelectedNode self changed: #removeState! ! !DialogGroupManagerUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 15:35'! treeBox ^ GroupboxMorph new addContentMorph: self buildGroupsTree; addContentMorph: (self newRow: {self buildAddButton. self buildRenameButton. self buildRemoveButton}); label: 'Choose a group:'; hResizing: #spaceFill; vResizing: #spaceFill! ! !DialogGroupManagerUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 14:11'! buildRemoveButton ^ (PluggableButtonMorph on: self getState: #removeState action: #removeAction label: #removeLabel) hResizing: #spaceFill; yourself ! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/17/2011 15:11'! applyChanges self valid! ! !DialogGroupManagerUI methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 3/22/2011 17:11'! groups ^ self groupManager groups groups! ! !DialogGroupManagerUI class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 3/29/2011 15:33'! on: aModel ^ self basicNew groupManager: aModel; initialize.! ! !DialogItemsChooser commentStamp: 'TorstenBergmann 2/4/2014 20:44'! Dialog for choosing from a list of items! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:27'! unselectedItems ^ unselectedItems! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:04'! selectedLabel ^selectedLabel! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:14'! selectedItemsSetterSelector: aSelector selectedItemsSetterSelector := aSelector! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:27'! unselectedItems: anObject unselectedItems := anObject! ! !DialogItemsChooser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 9/16/2010 00:26'! initialize super initialize. selection := OrderedCollection new.! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:12'! selection ^selection! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:04'! selectedLabel: anObject selectedLabel := anObject! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/16/2010 22:04'! title ^title! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/16/2010 22:04'! title: aFinderUI title := aFinderUI! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:27'! choicesList: anObject choicesList := anObject! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:37'! choicesList ^ choicesList ifNil: [ choicesList := OrderedCollection new ]! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:04'! unselectedLabel ^unselectedLabel! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:27'! methodNameUI: anObject methodNameUI := anObject! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:04'! unselectedLabel: anObject unselectedLabel := anObject! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/16/2010 21:03'! resultList: aList resultList := aList! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:27'! selectedItems ^ selectedItems! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:27'! selectedItems: anObject selectedItems := anObject! ! !DialogItemsChooser methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 9/17/2010 02:02'! model ^model! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:31'! sendSelection self model perform: self selectedItemsSetterSelector with: self selectedItems! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:13'! selectedItemsSetterSelector ^selectedItemsSetterSelector! ! !DialogItemsChooser methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 9/18/2010 16:59'! uiClass ^DialogItemsChooserUI! ! !DialogItemsChooser methodsFor: 'display' stamp: 'BenjaminVanRyseghem 11/1/2011 07:35'! open (self uiClass on: self) title: self title; openInWorld! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/16/2010 21:02'! resultList ^ resultList! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:27'! methodNameUI ^ methodNameUI! ! !DialogItemsChooser methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 9/17/2010 02:02'! model: aModel model := aModel! ! !DialogItemsChooser class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 9/18/2010 17:15'! on: aModel unselectedItems: unselectedItems selectedItems: selectedItems selectedItemsSetterSelector: anotherSelector title: aString unselectedItemsLabel: unselectedLabel selectedItemsLabel: selectedLabel | instance | instance := self new model: aModel; unselectedItems: unselectedItems; selectedItems: selectedItems; selectedItemsSetterSelector: anotherSelector; title: aString; unselectedLabel: unselectedLabel; selectedLabel: selectedLabel. ^instance.! ! !DialogItemsChooserUI commentStamp: 'BenjaminVanRyseghem 9/17/2010 00:20'! unselectedItems is the original list to search in selectItems is the list of the selected items! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:16'! dialogItemsChooser: aDialogItemsChooser dialogItemsChooser := aDialogItemsChooser! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 15:35'! unselectedItemsTextArea: anObject unselectedItemsTextArea := anObject! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 15:51'! alreadySearchedUnselectedItemsList ^AlreadySearchedUnselectedItemsList ifNil: [AlreadySearchedUnselectedItemsList := OrderedCollection new]! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 00:43'! unselectedItems ^unselectedItems! ! !DialogItemsChooserUI methodsFor: 'build items' stamp: 'GaryChambers 2/11/2011 14:04'! buildAddAllButton "Answer a new button for removing all items form the unslected list and adding to the selected list." ^(self newButtonFor: self getState: #addAllButtonState action: #addAllButtonAction arguments: nil getEnabled: #hasUnselectedItems getLabel: #addAllButtonLabel help: nil) hResizing: #spaceFill! ! !DialogItemsChooserUI methodsFor: 'private' stamp: 'EstebanLorenzano 1/31/2013 19:24'! msgPaneMenu: aMenu shifted: shifted | donorMenu | donorMenu := shifted ifTrue: [SmalltalkEditor shiftedYellowButtonMenu] ifFalse: [SmalltalkEditor yellowButtonMenu]. ^ aMenu addAllFrom: donorMenu! ! !DialogItemsChooserUI methodsFor: 'build items' stamp: 'CamilloBruni 9/12/2011 14:49'! buildUnselectedItemsList ^(PluggableListMorph on: self list: #unselectedItemsProbablyRestricted primarySelection: #unselectedSelectionIndex changePrimarySelection: #unselectedSelectionIndex: listSelection: #unselectedSelectionAt: changeListSelection: #unselectedSelectionAt:put: menu: nil) hResizing: #spaceFill; vResizing: #spaceFill.! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:43'! addToAlreadySearchedUnselectedItemsList: aString self alreadySearchedUnselectedItemsList size = self alreadySearchedUnselectedItemsListMaxSize ifTrue: [self alreadySearchedUnselectedItemsList removeLast ]. self alreadySearchedUnselectedItemsList addFirst: aString! ! !DialogItemsChooserUI methodsFor: 'selectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:34'! selectedSelectionIndex selectedSelectionIndex ifNil: [selectedSelectionIndex := 0]. ^selectedSelectionIndex! ! !DialogItemsChooserUI methodsFor: 'unselectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:52'! unselectedSelectionAt: index Put: anObject unselectedSelectionList at: index put: anObject! ! !DialogItemsChooserUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 12/2/2010 18:14'! initialize unselectedItemsSearchingString := String new. selectedItemsSearchingString := String new. selectedSelectionList := Dictionary new. unselectedSelectionList := Dictionary new. super initialize. self vResizing: #shrinkWrap. self hResizing: #shrinkWrap.! ! !DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 12/2/2010 18:20'! selectedSelectionItems | result | result := OrderedCollection new. self selectedItemsProbablyRestricted doWithIndex: [:item :index | (self selectedSelectionAt: index) ifTrue: [result add: item]]. ^result! ! !DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: 'GaryChambers 2/11/2011 14:08'! addAllItems | selection | selection := self unselectedItemsProbablyRestricted. selection ifEmpty: [^self]. self unselectedItems removeAll: selection. self selectedItems addAll: selection. unselectedSelectionList removeAll. self unselectedSelectionIndex: 0. self changed: #selectedItemsProbablyRestricted; changed: #hasSelectedItems; changed: #unselectedItemsProbablyRestricted; changed: #hasUnselectedItems; changed: #hasUnselectedSelections! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! addButtonAction self addSelectedItems.! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! okButtonLabel ^'Ok'! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:46'! selectedItemsTextArea: anObject selectedItemsTextArea := anObject! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:20'! unselectedLabel ^self dialogItemsChooser isNil ifTrue: ['Unselected Items' translated] ifFalse: [self dialogItemsChooser unselectedLabel]! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/16/2010 23:49'! selectedItemsModel: anObject selectedItemsModel := anObject! ! !DialogItemsChooserUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/1/2010 15:16'! unselectedItemsProbablyRestricted | matcher string | string := self unselectedItemsSearchingString. matcher := string ifEmpty: ['*'] ifNotEmpty: [ (string last = $*) ifTrue: [string] ifFalse:[string, '*']]. ^self unselectedItems select: [:each | matcher match: each].! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! removeAllButtonState ^false! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:46'! selectedItemsTextArea ^ selectedItemsTextArea! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! removeButtonAction self removeSelectedItems.! ! !DialogItemsChooserUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/18/2010 16:49'! roots: aTree aTree == unselectedItemsModel ifTrue: [ ^ self unselectedItemsProbablyRestricted]. aTree == selectedItemsModel ifTrue:[ ^ self selectedItemsProbablyRestricted].! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 14:16'! unselectedItemsModel: anObject unselectedItemsModel := anObject! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! searchButtonLabel ^'Search'! ! !DialogItemsChooserUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 11/1/2011 07:42'! openInWorld super openInWorld. self width: 500. self height: 400. self centering ! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 14:10'! selectedItems ^ selectedItems! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! addButtonState ^false! ! !DialogItemsChooserUI methodsFor: 'selectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:34'! selectedSelectionIndex: anObject selectedSelectionIndex := anObject. self changed: #selectedSelectionIndex! ! !DialogItemsChooserUI methodsFor: 'build items' stamp: 'GaryChambers 2/11/2011 14:04'! buildAddButton "Answer a new button for removing selected items from the unselected list and adding to the selected list." ^(self newButtonFor: self getState: #addButtonState action: #addButtonAction arguments: nil getEnabled: #hasUnselectedSelections getLabel: #addButtonLabel help: nil) hResizing: #spaceFill! ! !DialogItemsChooserUI methodsFor: 'unselectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:52'! unselectedSelectionIndex: anObject unselectedSelectionIndex := anObject. self changed: #unselectedSelectionIndex! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 00:53'! selectedItems: aList selectedItems := aList.! ! !DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: 'GaryChambers 2/11/2011 14:09'! removeAllItems | selection | selection := self selectedItemsProbablyRestricted. selection ifEmpty: [^self]. self selectedItems removeAll: selection. self unselectedItems addAll: selection. selectedSelectionList removeAll. self selectedSelectionIndex: 0. self changed: #selectedItemsProbablyRestricted; changed: #hasSelectedItems; changed: #hasSelectedSelections; changed: #unselectedItemsProbablyRestricted; changed: #hasUnselectedItems! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! addAllButtonState ^false! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:43'! addToAlreadySearchedSelectedItemsList: aString self alreadySearchedSelectedItemsList size = self alreadySearchedSelectedItemsListMaxSize ifTrue: [self alreadySearchedSelectedItemsList removeLast ]. self alreadySearchedSelectedItemsList addFirst: aString! ! !DialogItemsChooserUI methodsFor: 'selectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:50'! selectedSelectionAt: index ^selectedSelectionList at: index ifAbsent: [false]! ! !DialogItemsChooserUI methodsFor: 'unselectedList' stamp: 'GaryChambers 2/11/2011 13:58'! hasUnselectedSelections "Answer whether the unselected list has selected items." ^unselectedSelectionList anySatisfy: [:selected | selected]! ! !DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 12/2/2010 18:20'! unselectedSelectionItems | result | result := OrderedCollection new. self unselectedItemsProbablyRestricted doWithIndex: [:item :index | (self unselectedSelectionAt: index) ifTrue: [result add: item]]. ^result! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:42'! alreadySearchedUnselectedItemsListMaxSize: anInteger [self alreadySearchedUnselectedItemsList size > anInteger] whileTrue: [self alreadySearchedUnselectedItemsList removeLast]! ! !DialogItemsChooserUI methodsFor: 'build items' stamp: 'GaryChambers 2/11/2011 14:04'! buildRemoveButton "Answer a new button for removing selected items from the selected list and adding to the unselected list." ^(self newButtonFor: self getState: #removeButtonState action: #removeButtonAction arguments: nil getEnabled: #hasSelectedSelections getLabel: #removeButtonLabel help: nil) hResizing: #spaceFill! ! !DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: 'GaryChambers 2/11/2011 14:09'! addSelectedItems | selection | selection := self unselectedSelectionItems. selection ifEmpty: [^self]. self unselectedItems removeAll: selection. self selectedItems addAll: selection. unselectedSelectionList removeAll. self unselectedSelectionIndex: 0. self changed: #selectedItemsProbablyRestricted; changed: #hasSelectedItems; changed: #unselectedItemsProbablyRestricted; changed: #hasUnselectedItems; changed: #hasUnselectedSelections! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 15:36'! unselectedItemsTextArea ^unselectedItemsTextArea! ! !DialogItemsChooserUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/16/2010 20:51'! applyChanges self valid! ! !DialogItemsChooserUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/1/2010 15:25'! selectedItemsProbablyRestricted | matcher string | string := self selectedItemsSearchingString. matcher := string ifEmpty: ['*'] ifNotEmpty: [ (string last = $*) ifTrue: [string] ifFalse:[string, '*']]. ^self selectedItems select: [:each | matcher match: each].! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/1/2010 15:52'! unselectedSelection unselectedSelection ifNil: [unselectedSelection := 0]. ^unselectedSelection! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'GaryChambers 2/11/2011 14:12'! selectedItemsSearchingString: anObject selectedItemsSearchingString := anObject. selectedSelectionList removeAll. self selectedSelectionIndex: 0. self changed: #selectedItemsProbablyRestricted; changed: #selectedSelectionAt:; changed: #selectedSelectionIndex; changed: #hasSelectedSelections! ! !DialogItemsChooserUI methodsFor: 'selectedList' stamp: 'GaryChambers 2/11/2011 13:58'! hasSelectedSelections "Answer whether the selected list has selected items." ^selectedSelectionList anySatisfy: [:selected | selected]! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:21'! alreadySearchedSelectedItemsList ^AlreadySearchedSelectedItemsList ifNil: [AlreadySearchedSelectedItemsList := OrderedCollection new]! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:44'! selectedItemsSearchingString ^ selectedItemsSearchingString! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! addAllButtonAction self addAllItems.! ! !DialogItemsChooserUI methodsFor: 'display' stamp: 'GaryChambers 7/5/2011 09:29'! centering self left: ((World width / 2) - (self width /2)) rounded. self top: ((World height / 2) - (self height /2)) rounded! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 14:16'! unselectedItemsModel ^ unselectedItemsModel! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! removeAllButtonAction self removeAllItems.! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:22'! selectedLabel ^self dialogItemsChooser isNil ifTrue: ['Selected Items' translated] ifFalse: [self dialogItemsChooser selectedLabel]! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! cancelButtonState ^false! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:41'! alreadySearchedSelectedItemsListMaxSize: anInteger [self alreadySearchedSelectedItemsList size > anInteger] whileTrue: [self alreadySearchedSelectedItemsList removeLast]! ! !DialogItemsChooserUI methodsFor: 'build items' stamp: 'GaryChambers 2/11/2011 14:05'! buildRemoveAllButton "Answer a new button for removing all items from the selected list and adding to the unselected list." ^(self newButtonFor: self getState: #removeAllButtonState action: #removeAllButtonAction arguments: nil getEnabled: #hasSelectedItems getLabel: #removeAllButtonLabel help: nil) hResizing: #spaceFill! ! !DialogItemsChooserUI methodsFor: 'unselectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:52'! unselectedSelectionAt: index ^unselectedSelectionList at: index ifAbsent: [false]! ! !DialogItemsChooserUI methodsFor: 'buttons behavior' stamp: 'GaryChambers 2/11/2011 14:09'! removeSelectedItems | selection | selection := self selectedSelectionItems. selection ifEmpty: [^self]. self selectedItems removeAll: selection. self unselectedItems addAll: selection. selectedSelectionList removeAll. self selectedSelectionIndex: 0. self changed: #selectedItemsProbablyRestricted; changed: #hasSelectedItems; changed: #hasSelectedSelections; changed: #unselectedItemsProbablyRestricted; changed: #hasUnselectedItems! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:42'! alreadySearchedUnselectedItemsListMaxSize ^self class alreadySearchedUnselectedItemsListMaxSize! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 00:52'! unselectedItems: anOrderedCollection unselectedItems := anOrderedCollection.! ! !DialogItemsChooserUI methodsFor: 'display' stamp: 'GaryChambers 2/11/2011 13:52'! newContentMorph | trees unselectedItemsCol selectedItemsCol buttons | buttons := (self newGroupboxFor: ( (self newColumn: { self buildAddAllButton. self buildAddButton. self buildRemoveButton. self buildRemoveAllButton}) vResizing: #shrinkWrap)) vResizing: #shrinkWrap. unselectedItemsCol := self newGroupbox: self unselectedLabel for: (self newColumn: { self buildUnselectedItemsSearchingTextArea: self. self buildUnselectedItemsList.}). selectedItemsCol := self newGroupbox: self selectedLabel for: (self newColumn: { self buildSelectedItemsSearchingTextArea: self. self buildSelectedItemsList.}). trees := self newRow: { unselectedItemsCol. "self newGroupboxFor: self buildUnselectedItemsTree." buttons hResizing: #shrinkWrap. selectedItemsCol}. ^trees vResizing: #spaceFill. ! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! removeAllButtonLabel ^'<<'! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! okButtonState ^false! ! !DialogItemsChooserUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/18/2010 17:17'! valid self dialogItemsChooser sendSelection! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/16/2010 23:49'! selectedItemsModel ^ selectedItemsModel! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! searchButtonState ^false! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/1/2010 15:44'! unselectedSelection: anObject unselectedSelection := anObject! ! !DialogItemsChooserUI methodsFor: 'build items' stamp: 'BenjaminVanRyseghem 12/3/2010 10:06'! buildSelectedItemsSearchingTextArea: aWindow ^aWindow newAutoAcceptTextEntryFor: self get: #selectedItemsSearchingString set: #selectedItemsSearchingString: class: String getEnabled: nil help: 'Enter the name of a package' translated! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! addButtonLabel ^'>'! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! okButtonAction self valid.! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 14:31'! unselectedItemsSearchingString ^ unselectedItemsSearchingString! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'GaryChambers 2/11/2011 14:11'! unselectedItemsSearchingString: anObject unselectedItemsSearchingString := anObject. unselectedSelectionList removeAll. self unselectedSelectionIndex: 0. self changed: #unselectedItemsProbablyRestricted; changed: #unselectedSelectionAt:; changed: #unselectedSelectionIndex; changed: #hasUnselectedSelections! ! !DialogItemsChooserUI methodsFor: 'build items' stamp: 'BenjaminVanRyseghem 12/3/2010 10:05'! buildUnselectedItemsSearchingTextArea: aWindow ^aWindow newAutoAcceptTextEntryFor: self get: #unselectedItemsSearchingString set: #unselectedItemsSearchingString: class: String getEnabled: nil help: 'Enter the name of a package' translated! ! !DialogItemsChooserUI methodsFor: 'display' stamp: 'bvr 9/19/2010 19:32'! isResizeable ^true! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! addAllButtonLabel ^'>>'! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! removeButtonLabel ^'<'! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! removeButtonState ^false! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:24'! alreadySearchedSelectedItemsListMaxSize ^self class alreadySearchedSelectedItemsListMaxSize! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:16'! dialogItemsChooser ^ dialogItemsChooser! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! cancelButtonLabel ^'Cancel'! ! !DialogItemsChooserUI methodsFor: 'unselectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:52'! unselectedSelectionIndex unselectedSelectionIndex ifNil: [unselectedSelectionIndex := 0]. ^unselectedSelectionIndex! ! !DialogItemsChooserUI methodsFor: 'build items' stamp: 'CamilloBruni 9/12/2011 14:49'! buildSelectedItemsList ^selectedItemsList := (PluggableListMorph on: self list: #selectedItemsProbablyRestricted primarySelection: #selectedSelectionIndex changePrimarySelection: #selectedSelectionIndex: listSelection: #selectedSelectionAt: changeListSelection: #selectedSelectionAt:put: menu: nil) hResizing: #spaceFill; vResizing: #spaceFill.! ! !DialogItemsChooserUI methodsFor: 'unselectedList' stamp: 'GaryChambers 2/11/2011 13:47'! hasUnselectedItems "Answer whether the unselected list has items." ^self unselectedItems notEmpty! ! !DialogItemsChooserUI methodsFor: 'selectedList' stamp: 'GaryChambers 2/11/2011 13:54'! hasSelectedItems "Answer whether the selected list has items." ^self selectedItems notEmpty! ! !DialogItemsChooserUI methodsFor: 'selectedList' stamp: 'GaryChambers 2/11/2011 14:00'! selectedSelectionAt: index put: aBoolean "Mark the item as selected or not." selectedSelectionList at: index put: aBoolean. self changed: #hasSelectedSelections! ! !DialogItemsChooserUI methodsFor: 'unselectedList' stamp: 'GaryChambers 2/11/2011 14:00'! unselectedSelectionAt: index put: aBoolean "Mark the item as selected or not." unselectedSelectionList at: index put: aBoolean. self changed: #hasUnselectedSelections! ! !DialogItemsChooserUI class methodsFor: 'accessing' stamp: 'bvr 9/19/2010 19:16'! alreadySearchedUnselectedItemsListMaxSize: anObject anObject ifNil: [^self]. alreadySearchedUnselectedItemsListMaxSize := anObject. self allInstancesDo: [:each | each alreadySearchedUnselectedItemsListMaxSize: anObject]! ! !DialogItemsChooserUI class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:25'! alreadySearchedSelectedItemsListMaxSize ^ alreadySearchedSelectedItemsListMaxSize! ! !DialogItemsChooserUI class methodsFor: 'initialize-release' stamp: 'bvr 9/19/2010 19:23'! initialize super initialize. alreadySearchedUnselectedItemsListMaxSize := 15. alreadySearchedSelectedItemsListMaxSize := 15! ! !DialogItemsChooserUI class methodsFor: 'settings' stamp: 'bvr 9/19/2010 19:24'! dialogItemsChooserSettingsOn: aBuilder (aBuilder group: #dialogItemsChooser) target: self; label: 'Items Chooser Dialog Window' translated; parent: #morphic; description: 'Settings related to the Items Chooser Dialog Window' translated; with: [ (aBuilder setting: #alreadySearchedUnselectedItemsListMaxSize) label: 'Size of the Unselected Items History' translated. (aBuilder setting: #alreadySearchedSelectedItemsListMaxSize) label: 'Size of the Selected Items History' translated.]! ! !DialogItemsChooserUI class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 9/18/2010 17:21'! on: aDialogItemsChooser ^self basicNew unselectedItems: aDialogItemsChooser unselectedItems; selectedItems: aDialogItemsChooser selectedItems; dialogItemsChooser: aDialogItemsChooser; initialize.! ! !DialogItemsChooserUI class methodsFor: 'accessing' stamp: 'bvr 9/19/2010 19:16'! alreadySearchedSelectedItemsListMaxSize: anObject anObject ifNil: [^self]. alreadySearchedSelectedItemsListMaxSize := anObject. self allInstancesDo: [:each | each alreadySearchedSelectedItemsListMaxSize: anObject]! ! !DialogItemsChooserUI class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:25'! alreadySearchedUnselectedItemsListMaxSize ^ alreadySearchedUnselectedItemsListMaxSize! ! !DialogWindow commentStamp: 'gvc 5/18/2007 13:26'! Dialog style window with no window controls (expand, collapse etc). Usually opened modally (the morph that is used to modally open determines the modal scope, use of World implies "system modal"). Designed to be subclassed with content. Supports Escape key for cancel and Enter key for default button.! !DialogWindow methodsFor: 'actions' stamp: 'gvc 8/14/2006 14:12'! ok "Apply the changes and close." self cancelled: false; applyChanges; delete! ! !DialogWindow methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 12/10/2013 22:21'! defaultIsResizeable ^ false! ! !DialogWindow methodsFor: 'theme' stamp: 'gvc 6/2/2009 10:26'! preferredCornerStyle "Answer the preferred corner style." ^self theme dialogWindowPreferredCornerStyleFor: self! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 8/25/2006 10:10'! close "Close the window." self delete! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 8/14/2006 11:58'! newContentMorph "Answer a new content morph." ^Morph new color: Color transparent; hResizing: #spaceFill; vResizing: #spaceFill! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 8/25/2006 10:10'! cancel "Cancel and close." self close! ! !DialogWindow methodsFor: 'event handling' stamp: 'gvc 7/30/2009 12:32'! keyStroke: evt "Check for return and escape keys." super keyStroke: evt. (self defaultButton notNil and: [evt keyCharacter = Character cr]) ifTrue: [self returnPressed. ^true]. evt keyCharacter = Character escape ifTrue: [self escapePressed. ^true]. ^false! ! !DialogWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/22/2009 11:16'! canBeMaximized "Answer whether we are not we can be maximised." ^self isResizeable ifTrue: [super canBeMaximized] ifFalse: [false]! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 1/10/2007 13:42'! escapePressed "Default is to cancel." self cancel! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 8/25/2006 10:25'! addInitialPanel "Add the panel." self addMainPanel! ! !DialogWindow methodsFor: 'initialization' stamp: 'gvc 4/3/2008 11:52'! initialize "Initialize the receiver." super initialize. self cancelled: true; addInitialPanel! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 2/2/2009 13:15'! mainPanel "Anwer the main panel morph or nil if not yet present." ^self paneMorphs isEmpty ifFalse: [self paneMorphs first]! ! !DialogWindow methodsFor: 'theme' stamp: 'gvc 5/24/2007 11:35'! activeFillStyle "Return the active fillStyle for the receiver." ^self theme dialogWindowActiveFillStyleFor: self! ! !DialogWindow methodsFor: 'controls' stamp: 'AlainPlantec 10/7/2011 11:22'! title: aString "Set the window title." super title: aString. label fitContents. self minimumExtent: (((label width + 20 min: (Display width // 2)) max: self minimumExtent x)@ self minimumExtent y)! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 5/15/2007 17:40'! newMainPanel "Answer a new main panel." ^self newDialogPanel addMorphBack: self newContentMorph; addMorphBack: self newButtonRow; yourself! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 1/10/2007 13:23'! defaultButton "Answer the default button." ^self findDeepSubmorphThat: [:m | (m isKindOf: PluggableButtonMorph) and: [m isDefault]] ifAbsent: [] ! ! !DialogWindow methodsFor: 'accessing' stamp: 'gvc 8/14/2006 14:12'! cancelled: anObject "Set the value of cancelled" cancelled := anObject! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 1/10/2007 13:50'! newButtons "Answer new buttons as appropriate." ^{self newOKButton isDefault: true. self newCancelButton}! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 8/12/2009 18:14'! buttons "Answer the buttons in the button row" ^self paneMorphs last lastSubmorph submorphs! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 12/3/2008 17:35'! newButtonRow "Answer a new ok/cancel button row." |answer buttons e| buttons := self newButtons. e := 0@0. buttons do: [:b | e := e max: b minExtent]. buttons do: [:b | b extent: e]. answer := Morph new color: Color transparent; changeTableLayout; cellInset: 8; listDirection: #leftToRight; listCentering: #bottomRight; hResizing: #spaceFill; vResizing: #shrinkWrap. buttons do: [:b | answer addMorphBack: b]. ^answer! ! !DialogWindow methodsFor: 'top window' stamp: 'MarcusDenker 12/11/2009 07:38'! activate "Set the default focus for now, will want to remember it at some point." super activate. self world ifNil: [^self]. self rememberedKeyboardFocus ifNil: [self defaultFocusMorph ifNotNil: [:m | m takeKeyboardFocus]]! ! !DialogWindow methodsFor: 'open/close' stamp: 'MarcusDenker 12/11/2009 09:34'! initialExtent "Answer the default extent for the receiver." |rl paneExt ext| rl := self getRawLabel. paneExt := self mainPanel ifNil: [0@0] ifNotNil: [:pane | pane minExtent]. ext := paneExt + (2@ self labelHeight) + (2 * self class borderWidth) max: rl extent + 20. self isResizeable ifTrue: [ self title: self title "adjust minimumExtent". self minimumExtent: (ext x max: self minimumExtent x)@(ext y max: self minimumExtent y)]. ^ext! ! !DialogWindow methodsFor: 'initialization' stamp: 'AlainPlantec 12/3/2010 09:00'! initializeLabelArea "Initialize the label area (titlebar) for the window." super initializeLabelArea. self removeBoxes. self replaceBoxes! ! !DialogWindow methodsFor: 'event handling' stamp: 'gvc 7/30/2009 12:21'! handlesKeyboard: evt "Return true if the receiver wishes to handle the given keyboard event" (super handlesKeyboard: evt) ifTrue: [^true]. ^evt keyCharacter = Character escape or: [ (self defaultButton notNil and: [ evt keyCharacter = Character cr])] ! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 8/9/2007 16:52'! addMainPanel "Add the main panel." self addMorph: self newMainPanel frame: (0@0 corner: 1@1)! ! !DialogWindow methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/26/2007 21:31'! setLabelWidgetAllowance "Set the extra space required, in general, apart from the label. No extra needed for dialogs." ^labelWidgetAllowance := 0! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 1/10/2007 13:48'! returnPressed "Default is to do the default button." (self defaultButton ifNil: [^self]) performAction! ! !DialogWindow methodsFor: 'actions' stamp: 'nice 1/5/2010 15:59'! setButtonFont: aFont "Set the font for the buttons." | buttons e| buttons := self buttons. e := 0@0. buttons do: [:b | | hRes vRes | hRes := b hResizing. vRes := b vResizing. b hResizing: #shrinkWrap; vResizing: #shrinkWrap. b label: b label font: aFont. e := e max: b minExtent. b hResizing: hRes; vResizing: vRes]. buttons do: [:b | b extent: e]! ! !DialogWindow methodsFor: 'initialization' stamp: 'gvc 6/1/2009 12:21'! setFramesForLabelArea "Delegate to theme." self theme configureDialogWindowLabelAreaFrameFor: self! ! !DialogWindow methodsFor: 'accessing' stamp: 'gvc 8/14/2006 14:12'! cancelled "Answer the value of cancelled" ^ cancelled! ! !DialogWindow methodsFor: 'event handling' stamp: 'GuillermoPolito 5/23/2012 11:39'! keyboardFocusChange: aBoolean "Set the focus to the default button." super keyboardFocusChange: aBoolean. aBoolean ifTrue: [ self defaultFocusMorph ifNotNil: [:b | b takeKeyboardFocus]]! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 8/14/2006 12:40'! defaultLabel "Answer the default label for the receiver." ^'Dialog' translated! ! !DialogWindow methodsFor: 'theme' stamp: 'gvc 4/24/2007 16:19'! animateClose "Animate closing."! ! !DialogWindow methodsFor: 'focus handling' stamp: 'MarcusDenker 12/11/2009 09:34'! defaultFocusMorph "Answer the morph that should have the keyboard focus by default when the dialog is opened." ^self defaultButton ifNil: [(self respondsTo: #nextMorphWantingFocus) ifTrue: [ self nextMorphWantingFocus]] ifNotNil: [:b | b enabled ifTrue: [b]]! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 8/27/2006 11:15'! acceptTextMorphs "Accept any text morphs except for those that have no edits." self allMorphs do: [:p | ((p respondsTo: #accept) and: [ (p respondsTo: #hasUnacceptedEdits) and: [ p hasUnacceptedEdits]]) ifTrue: [p accept]]! ! !DialogWindow methodsFor: 'event handling' stamp: 'gvc 9/22/2009 11:17'! doubleClick: event "Handle a double click. Maximize/restore the window. Not for dialogs if not resizeable..." self isResizeable ifTrue: [super doubleClick: event]! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 8/27/2006 11:11'! applyChanges "Apply the changes." self acceptTextMorphs! ! !DialogWindow methodsFor: 'theme' stamp: 'gvc 5/24/2007 11:36'! inactiveFillStyle "Return the active fillStyle for the receiver." ^self theme dialogWindowInactiveFillStyleFor: self! ! !DialogWindow methodsFor: 'theme' stamp: 'gvc 6/2/2009 10:36'! wantsRoundedCorners "Answer whether rounded corners are wanted." ^(self theme dialogWindowPreferredCornerStyleFor: self) == #rounded! ! !DialogWindowModel commentStamp: ''! A DialogWindowModel is a model used to describe a DialogWindow! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 23:47'! triggerOkAction self changed: #triggerOkAction with: #()! ! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 15:03'! toolbar ^ toolbar value! ! !DialogWindowModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/28/2013 23:50'! buildWithSpecLayout: aSpec "Build the widget using the spec name provided as argument" | widget | (self spec notNil and: [ self needRebuild not ]) ifTrue: [ widget := self spec instance ] ifFalse: [ contents := self model buildWithSpecLayout: aSpec. widget := SpecInterpreter private_buildWidgetFor: self withSpec: self defaultSpecSelector. contents := nil ]. self extent ifNotNil: [:ex | (widget respondsTo: #extent:) ifTrue: [ widget extent: ex ]]. ^ widget! ! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 15:05'! triggerCancelAction self changed: #triggerCancelAction with: #()! ! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 23:49'! cancelAction: aBlock ^ self changed: #cancelAction: with: { aBlock }! ! !DialogWindowModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. toolbar := OkCancelToolbar new asReactiveVariable. toolbar whenChangedDo: [ :t | self changed: #toolbar: with: { t } ]! ! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 22:06'! cancelled ^ self toolbar cancelled! ! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 15:03'! toolbar: aBar toolbar value: aBar! ! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 23:48'! okAction: aBlock ^ self changed: #okAction: with: { aBlock }! ! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 23:46'! okButtonEnabled: aBoolean self changed: #okButtonEnabled: with: { aBoolean }! ! !DialogWindowModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/28/2013 23:50'! contents ^ contents! ! !DialogWindowModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 13:39'! defaultSpec ^ #(DialogWindowAdapter adapt: #(model))! ! !DialogWindowModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:30'! adapterName ^ #DialogWindowAdapter! ! !Dictionary commentStamp: ''! I represent a set of elements that can be viewed from one of two perspectives: a set of associations, or a container of values that are externally named where the name can be any object that responds to =. The external name is referred to as the key. I inherit many operations from Set.! !Dictionary methodsFor: '*Fuel' stamp: 'MartinDias 2/25/2013 14:33'! fuelAfterMaterialization | class | "Since for Set and IdentitySet we are recreating the collection with #add: we do not need to rehash." class := self class. ^ (((class == Dictionary) or: [ class == IdentityDictionary ]) ) ifFalse: [ self rehash ] ifTrue: [ self ]! ! !Dictionary methodsFor: 'adding' stamp: 'raok 12/17/2003 16:01'! addAll: aKeyedCollection aKeyedCollection == self ifFalse: [ aKeyedCollection keysAndValuesDo: [:key :value | self at: key put: value]]. ^aKeyedCollection! ! !Dictionary methodsFor: 'testing' stamp: 'sw 2/14/2000 14:34'! includesIdentity: anObject "Answer whether anObject is one of the values of the receiver. Contrast #includes: in which there is only an equality check, here there is an identity check" self do: [:each | anObject == each ifTrue: [^ true]]. ^ false! ! !Dictionary methodsFor: 'enumerating' stamp: 'ar 5/18/2003 20:33'! bindingsDo: aBlock ^self associationsDo: aBlock! ! !Dictionary methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/19/2011 20:31'! keyAtIdentityValue: value "Answer the key that is the external name for the argument, value. If there is none, answer nil. Note: There can be multiple keys with the same value. Only one is returned." ^self keyAtIdentityValue: value ifAbsent: [self errorValueNotFound: value]! ! !Dictionary methodsFor: 'private' stamp: ''! valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary "Support for coordinating class variable and global declarations with variables that have been put in Undeclared so as to redirect all references to the undeclared variable." (aDictionary includesKey: aKey) ifTrue: [self atNewIndex: index put: ((aDictionary associationAt: aKey) value: anObject). aDictionary removeKey: aKey] ifFalse: [self atNewIndex: index put: (Association key: aKey value: anObject)]! ! !Dictionary methodsFor: 'testing' stamp: 'sw 3/23/2000 01:12'! keyForIdentity: anObject "If anObject is one of the values of the receive, return its key, else return nil. Contrast #keyAtValue: in which there is only an equality check, here there is an identity check" self associationsDo: [:assoc | assoc value == anObject ifTrue: [^ assoc key]]. ^ nil! ! !Dictionary methodsFor: 'removing' stamp: ''! removeKey: key ifAbsent: aBlock "Remove key (and its associated value) from the receiver. If key is not in the receiver, answer the result of evaluating aBlock. Otherwise, answer the value externally named by key." | index assoc | index := self findElementOrNil: key. assoc := array at: index. assoc == nil ifTrue: [ ^ aBlock value ]. array at: index put: nil. tally := tally - 1. self fixCollisionsFrom: index. ^ assoc value! ! !Dictionary methodsFor: 'accessing' stamp: 'nice 5/1/2011 18:29'! at: key ifPresent: aBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." ^(array at: (self findElementOrNil: key)) ifNotNil: [:assoc | aBlock cull: assoc value]! ! !Dictionary methodsFor: 'enumerating' stamp: 'SqR 11/7/2013 12:12'! valuesDo: aBlock "Evaluate aBlock for each of the receiver's values. Implemented with == checks merely for the sake of maximum efficiency" tally = 0 ifTrue: [ ^self ]. 1 to: array size do: [ :eachIndex | | eachAssociation | eachAssociation := array at: eachIndex. nil == eachAssociation ifFalse: [ aBlock value: eachAssociation value ] ]! ! !Dictionary methodsFor: 'enumerating' stamp: 'dtl 2/17/2003 09:40'! associationsSelect: aBlock "Evaluate aBlock with each of my associations as the argument. Collect into a new dictionary, only those associations for which aBlock evaluates to true." | newCollection | newCollection := self species new. self associationsDo: [:each | (aBlock value: each) ifTrue: [newCollection add: each]]. ^newCollection! ! !Dictionary methodsFor: 'accessing' stamp: 'ar 5/17/2003 14:07'! bindingOf: varName ^self associationAt: varName ifAbsent:[nil]! ! !Dictionary methodsFor: 'printing' stamp: 'apb 7/14/2004 12:48'! printElementsOn: aStream aStream nextPut: $(. self size > 100 ifTrue: [aStream nextPutAll: 'size '. self size printOn: aStream] ifFalse: [self keysSortedSafely do: [:key | aStream print: key; nextPutAll: '->'; print: (self at: key); space]]. aStream nextPut: $)! ! !Dictionary methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 10/26/2013 12:24'! includesKey: key "Answer whether the receiver has a key equal to the argument, key." ^ (array at: (self scanFor: key)) ~~ nil "We could use #notNil here, but ProtoObject doesn't understand it."! ! !Dictionary methodsFor: '*Tools-Explorer' stamp: 'yo 8/27/2008 23:16'! customizeExplorerContents ^ true. ! ! !Dictionary methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 01:13'! values "Answer a Collection containing the receiver's values." | out | out := (Array new: self size) writeStream. self valuesDo: [:value | out nextPut: value]. ^ out contents! ! !Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 15:01'! at: key ifAbsentPut: aBlock "Return the value at the given key. If key is not included in the receiver store the result of evaluating aBlock as new value." ^ self at: key ifAbsent: [self at: key put: aBlock value]! ! !Dictionary methodsFor: 'removing' stamp: ''! removeUnreferencedKeys "Undeclared removeUnreferencedKeys" ^ self unreferencedKeys do: [:key | self removeKey: key].! ! !Dictionary methodsFor: 'enumerating' stamp: 'CamilloBruni 9/9/2011 16:50'! difference: aCollection "Answer the set theoretic difference of two collections. This is a specialized version for Dictionaries keeping the keys of the objects. At a slightly higher price of an additional Set to track duplicates." | other result duplicates | other := aCollection asSet. duplicates := Set new. result := self class new: self size. self keysAndValuesDo: [ :key :value| ((other includes: value) not and: [ (duplicates includes: value) not ]) ifTrue: [ duplicates add: value. result at: key put: value]]. ^ result! ! !Dictionary methodsFor: 'testing' stamp: 'ab 9/17/2004 00:39'! includesAssociation: anAssociation ^ (self associationAt: anAssociation key ifAbsent: [ ^ false ]) value = anAssociation value ! ! !Dictionary methodsFor: 'private' stamp: ''! rehash "Smalltalk rehash." | newSelf | newSelf := self species new: self size. self associationsDo: [:each | newSelf noCheckAdd: each]. array := newSelf array! ! !Dictionary methodsFor: '*NewValueHolder' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! asValueHolder ^ DictionaryValueHolder value: self! ! !Dictionary methodsFor: 'removing' stamp: 'CamilloBruni 4/11/2011 13:30'! removeKey: key "Remove key from the receiver. If key is not in the receiver, notify an error." ^ self removeKey: key ifAbsent: [self errorKeyNotFound: key]! ! !Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 15:00'! at: key put: anObject "Set the value at key to be anObject. If key is not found, create a new entry for key and set is value to anObject. Answer anObject." | index assoc | index := self findElementOrNil: key. assoc := array at: index. assoc ifNil: [self atNewIndex: index put: (Association key: key value: anObject)] ifNotNil: [assoc value: anObject]. ^ anObject! ! !Dictionary methodsFor: 'enumerating' stamp: 'ar 6/13/2008 00:16'! collect: aBlock "Evaluate aBlock with each of my values as the argument. Collect the resulting values into a collection that is like me. Answer with the new collection." | newCollection | newCollection := self species new. self associationsDo:[:each | newCollection at: each key put: (aBlock value: each value). ]. ^newCollection! ! !Dictionary methodsFor: 'accessing' stamp: 'StephaneDucasse 12/25/2009 12:15'! keysSortedSafely "Answer an Array containing the receiver's keys." "Suggested by l. Uzonyi" | sortedKeys | sortedKeys := Array new: self size streamContents: [ :stream | self keysDo: [ :each | stream nextPut: each ] ]. sortedKeys sort: [ :x :y | "Should really be use compareSafely..." ((x isString and: [ y isString ]) or: [ x isNumber and: [ y isNumber ] ]) ifTrue: [ x < y ] ifFalse: [ x class == y class ifTrue: [ x printString < y printString ] ifFalse: [ x class name < y class name ] ] ]. ^sortedKeys! ! !Dictionary methodsFor: 'copying' stamp: 'ul 9/22/2009 04:51'! postCopy "Must copy the associations, or later store will affect both the original and the copy" array := array collect: [ :association | association ifNotNil: [ association copy ] ]! ! !Dictionary methodsFor: '*Tools-Explorer' stamp: 'yo 8/27/2008 23:44'! explorerContentsWithIndexCollect: twoArgBlock | sortedKeys | sortedKeys := self keys asSortedCollection: [:x :y | ((x isString and: [y isString]) or: [x isNumber and: [y isNumber]]) ifTrue: [x < y] ifFalse: [x class == y class ifTrue: [x printString < y printString] ifFalse: [x class name < y class name]]]. ^ sortedKeys collect: [:k | twoArgBlock value: (self at: k) value: k]. ! ! !Dictionary methodsFor: 'accessing' stamp: 'StephaneDucasse 12/25/2009 12:12'! associations "Answer a Collection containing the receiver's associations." "Suggested by l. Uzonyi" ^Array new: self size streamContents: [ :stream | self associationsDo: [ :each | stream nextPut: each ] ]! ! !Dictionary methodsFor: 'adding' stamp: ''! declare: key from: aDictionary "Add key to the receiver. If key already exists, do nothing. If aDictionary includes key, then remove it from aDictionary and use its association as the element of the receiver." (self includesKey: key) ifTrue: [^ self]. (aDictionary includesKey: key) ifTrue: [self add: (aDictionary associationAt: key). aDictionary removeKey: key] ifFalse: [self add: key -> nil]! ! !Dictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:16'! keyAtIdentityValue: value ifAbsent: exceptionBlock "Answer the key that is the external name for the argument, value. If there is none, answer the result of evaluating exceptionBlock. Note: There can be multiple keys with the same value. Only one is returned." self associationsDo: [:association | value == association value ifTrue: [^association key]]. ^exceptionBlock value! ! !Dictionary methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 23:17'! noCheckNoGrowFillFrom: anArray "Add the elements of anArray except nils to me assuming that I don't contain any of them, they are unique and I have more free space than they require." 1 to: anArray size do: [ :index | (anArray at: index) ifNotNil: [ :association | array at: (self scanForEmptySlotFor: association key) put: association ] ]! ! !Dictionary methodsFor: 'testing' stamp: 'StephaneDucasse 5/28/2011 14:01'! isHealthy "Test that object hashes match their positions stored in set's array, answer true if everything ok, false otherwise Dictionary allInstances select: [:dict | dict isHealthy not ] Dictionary allSubInstances select: [:dict | dict isHealthy not ] " array withIndexDo: [:elem :i | elem ifNotNil: [ (self scanFor: elem key) == i ifFalse: [ ^ false ] ] ]. ^ true! ! !Dictionary methodsFor: 'removing' stamp: 'di 4/4/2000 11:47'! keysAndValuesRemove: keyValueBlock "Removes all entries for which keyValueBlock returns true." "When removing many items, you must not do it while iterating over the dictionary, since it may be changing. This method takes care of tallying the removals in a first pass, and then performing all the deletions afterward. Many places in the sytem could be simplified by using this method." | removals | removals := OrderedCollection new. self associationsDo: [:assoc | (keyValueBlock value: assoc key value: assoc value) ifTrue: [removals add: assoc key]]. removals do: [:aKey | self removeKey: aKey]! ! !Dictionary methodsFor: 'accessing' stamp: 'StephaneDucasse 5/13/2010 11:37'! at: key ifPresent: oneArgBlock ifAbsent: absentBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating the oneArgBlock with the value associated with the key, otherwise answer the value of absentBlock." self at: key ifPresent: [ :v | ^oneArgBlock value: v ]. ^absentBlock value! ! !Dictionary methodsFor: '*Fuel' stamp: 'MarianoMartinezPeck 7/30/2012 23:16'! fuelAccept: aGeneralMapper | class | "Since we have subclasses of Dictionary that behave differently, we cannot use the visitDictionary: for all of them. We could also use MethodDictionary for this case, but its materialization is much slower with this cluster than with the default action." class := self class. ^ (((class == Dictionary) or: [class == IdentityDictionary ])) ifTrue: [ aGeneralMapper visitDictionary: self ] ifFalse: [ super fuelAccept: aGeneralMapper ] ! ! !Dictionary methodsFor: 'private' stamp: 'md 10/5/2005 15:42'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | element start finish | finish := array size. start := (anObject hash \\ finish) + 1. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element := array at: index) == nil or: [element key = anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element := array at: index) == nil or: [element key = anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !Dictionary methodsFor: 'enumerating' stamp: 'TristanBourgois 5/10/2010 10:41'! associationsDo: aBlock "Evaluate aBlock for each of the receiver's elements (key/value associations)." tally = 0 ifTrue: [^ self]. array do: [:each | each ifNotNil: [aBlock value: each]]! ! !Dictionary methodsFor: 'accessing' stamp: ''! associationAt: key ifAbsent: aBlock "Answer the association with the given key. If key is not found, return the result of evaluating aBlock." | index assoc | index := self findElementOrNil: key. assoc := array at: index. nil == assoc ifTrue: [ ^ aBlock value ]. ^ assoc! ! !Dictionary methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2011 13:30'! at: key "Answer the value associated with the key." ^ self at: key ifAbsent: [self errorKeyNotFound: key]! ! !Dictionary methodsFor: 'adding' stamp: ''! add: anAssociation | index element | index := self findElementOrNil: anAssociation key. element := array at: index. element == nil ifTrue: [self atNewIndex: index put: anAssociation] ifFalse: [element value: anAssociation value]. ^ anAssociation! ! !Dictionary methodsFor: 'accessing' stamp: 'MarcusDenker 8/18/2010 19:17'! at: key ifAbsent: aBlock "Answer the value associated with the key or, if key isn't found, answer the result of evaluating aBlock." ^((array at: (self findElementOrNil: key)) ifNil: [aBlock] ifNotNil: [:assoc | assoc]) value.! ! !Dictionary methodsFor: '*monticellofiletree-core' stamp: 'dkh 4/6/2012 15:56:14'! writeCypressJsonForHtmlOn: aStream self writeCypressJsonOn: aStream forHtml: true indent: 0! ! !Dictionary methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/19/2011 20:30'! errorValueNotFound: value ValueNotFound signalFor: value! ! !Dictionary methodsFor: '*monticellofiletree-core' stamp: 'dkh 4/6/2012 15:56:14'! writeCypressJsonOn: aStream forHtml: forHtml indent: startIndent "by default ignore ... is used for Dictionary and Array, i.e., container objects and String which actually encodes itself differently for HTML" | indent keys | indent := startIndent. aStream nextPutAll: '{'; lf. indent := indent + 1. keys := self keys sort: [ :a :b | a <= b ]. 1 to: keys size do: [ :index | | key value | key := keys at: index. value := self at: key. aStream tab: indent. key writeCypressJsonOn: aStream forHtml: forHtml indent: indent. aStream nextPutAll: ' : '. value writeCypressJsonOn: aStream forHtml: forHtml indent: indent. index < self size ifTrue: [ aStream nextPutAll: ','; lf ] ]. self size = 0 ifTrue: [ aStream tab: indent ]. aStream nextPutAll: ' }'! ! !Dictionary methodsFor: 'private' stamp: 'nice 11/14/2009 16:33'! fixCollisionsFrom: start "The element at start has been removed and replaced by nil. This method moves forward from there, relocating any entries that had been placed below due to collisions with this one." | element index | index := start. [ (element := array at: (index := index \\ array size + 1)) == nil ] whileFalse: [ | newIndex | (newIndex := self findElementOrNil: element key) = index ifFalse: [ array swap: index with: newIndex ] ]! ! !Dictionary methodsFor: 'testing' stamp: 'tween 9/13/2004 10:11'! 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! ! !Dictionary methodsFor: 'printing' stamp: ''! storeOn: aStream | noneYet | aStream nextPutAll: '(('. aStream nextPutAll: self class name. aStream nextPutAll: ' new)'. noneYet := true. self associationsDo: [:each | noneYet ifTrue: [noneYet := false] ifFalse: [aStream nextPut: $;]. aStream nextPutAll: ' add: '. aStream store: each]. noneYet ifFalse: [aStream nextPutAll: '; yourself']. aStream nextPut: $)! ! !Dictionary methodsFor: 'accessing' stamp: 'nice 10/20/2009 23:20'! keys "Answer an Array containing the receiver's keys." ^Array new: self size streamContents: [:s| self keysDo: [:key| s nextPut: key]]! ! !Dictionary methodsFor: 'removing' stamp: ''! remove: anObject ifAbsent: exceptionBlock self shouldNotImplement! ! !Dictionary methodsFor: 'accessing' stamp: 'tk 2/18/97'! keyAtValue: value ifAbsent: exceptionBlock "Answer the key that is the external name for the argument, value. If there is none, answer the result of evaluating exceptionBlock. : Use =, not ==, so stings like 'this' can be found. Note that MethodDictionary continues to use == so it will be fast." self associationsDo: [:association | value = association value ifTrue: [^association key]]. ^exceptionBlock value! ! !Dictionary methodsFor: 'testing' stamp: ''! includes: anObject self do: [:each | anObject = each ifTrue: [^true]]. ^false! ! !Dictionary methodsFor: 'enumerating' stamp: ''! keysDo: aBlock "Evaluate aBlock for each of the receiver's keys." self associationsDo: [:association | aBlock value: association key]! ! !Dictionary methodsFor: 'private' stamp: 'ul 11/21/2009 01:15'! fillFrom: aCollection with: aBlock "Evaluate aBlock with each of aCollections's elements as the argument. Collect the resulting values into self. Answer self." aCollection keysAndValuesDo: [ :key :value | self at: key put: (aBlock value: value) ]! ! !Dictionary methodsFor: 'enumerating' stamp: 'nice 10/5/2009 10:16'! select: aBlock "Evaluate aBlock with each of my values as the argument. Collect into a new dictionary, only those associations for which aBlock evaluates to true." | newCollection | newCollection := self copyEmpty. self associationsDo: [ :each | (aBlock value: each value) ifTrue: [ newCollection add: each copy ] ]. ^newCollection! ! !Dictionary methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/19/2011 20:31'! keyAtValue: value "Answer the key that is the external name for the argument, value. If there is none, signal an error." ^self keyAtValue: value ifAbsent: [self errorValueNotFound: value]! ! !Dictionary methodsFor: 'enumerating' stamp: 'MarcusDenker 7/2/2010 13:02'! do: aBlock ^self valuesDo: aBlock! ! !Dictionary methodsFor: 'comparing' stamp: 'cyrille.delaunay 7/17/2009 15:45'! = aDictionary "Two dictionaries are equal if (a) they are the same 'kind' of thing. (b) they have the same set of keys. (c) for each (common) key, they have the same value" self == aDictionary ifTrue: [ ^ true ]. (aDictionary isDictionary) ifFalse: [^false]. self size = aDictionary size ifFalse: [^false]. self associationsDo: [:assoc| (aDictionary at: assoc key ifAbsent: [^false]) = assoc value ifFalse: [^false]]. ^true ! ! !Dictionary methodsFor: 'removing' stamp: ''! remove: anObject self shouldNotImplement! ! !Dictionary methodsFor: '*monticellofiletree-core' stamp: 'dkh 4/6/2012 15:56:14'! writeCypressJsonOn: aStream self writeCypressJsonOn: aStream forHtml: false indent: 0. aStream lf! ! !Dictionary methodsFor: 'testing' stamp: 'md 8/11/2005 16:49'! isDictionary ^true! ! !Dictionary methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/19/2011 19:41'! errorKeyNotFound: aKey KeyNotFound signalFor: aKey! ! !Dictionary methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2011 13:30'! associationAt: key ^ self associationAt: key ifAbsent: [self errorKeyNotFound: key]! ! !Dictionary methodsFor: 'enumerating' stamp: 'MarianoMartinezPeck 8/24/2012 15:26'! keysAndValuesDo: aBlock ^self associationsDo:[:assoc| aBlock value: assoc key value: assoc value].! ! !Dictionary methodsFor: 'removing' stamp: 'MarcusDenker 10/9/2013 11:29'! unreferencedKeys "| uk | (Time millisecondsToRun: [uk := TextConstants unreferencedKeys]) -> uk" ^'Scanning for references . . .' displayProgressFrom: 0 to: Smalltalk globals classNames size * 2 during: [:bar | | currentClass n associations referencedAssociations | currentClass := nil. n := 0. associations := self associations asIdentitySet. referencedAssociations := IdentitySet new: associations size. self systemNavigation allMethodsSelect: [:m| m methodClass ~~ currentClass ifTrue: [currentClass := m methodClass. bar current: (n := n + 1)]. m literalsDo: [:l| (l isVariableBinding and: [associations includes: l]) ifTrue: [referencedAssociations add: l]]. false]. ((associations reject: [:assoc | referencedAssociations includes: assoc]) collect: [:assoc| assoc key]) asSet]! ! !Dictionary methodsFor: 'private' stamp: 'CamilloBruni 8/1/2012 16:12'! noCheckAdd: anObject "Must be defined separately for Dictionary because (self findElementOrNil:) expects a key, not an association." array at: (self findElementOrNil: anObject key) put: anObject. tally := tally + 1! ! !Dictionary class methodsFor: 'instance creation' stamp: ''! newFrom: aDict "Answer an instance of me containing the same associations as aDict. Error if any key appears twice." | newDictionary | newDictionary := self new: aDict size. aDict associationsDo: [:x | (newDictionary includesKey: x key) ifTrue: [self error: 'Duplicate key: ', x key printString] ifFalse: [newDictionary add: x]]. ^ newDictionary " NewDictionary newFrom: {1->#a. 2->#b. 3->#c} {1->#a. 2->#b. 3->#c} as: NewDictionary NewDictionary newFrom: {1->#a. 2->#b. 1->#c} {1->#a. 2->#b. 1->#c} as: NewDictionary "! ! !Dictionary class methodsFor: 'instance creation' stamp: 'bgf 10/25/2006 17:08'! newFromPairs: anArray "Answer an instance of me associating (anArray at:i) to (anArray at: i+i) for each odd i. anArray must have an even number of entries." | newDictionary | newDictionary := self new: (anArray size/2). 1 to: (anArray size-1) by: 2 do: [ :i| newDictionary at: (anArray at: i) put: (anArray at: i+1). ]. ^ newDictionary " Dictionary newFromPairs: {'Red' . Color red . 'Blue' . Color blue . 'Green' . Color green}. "! ! !Dictionary class methodsFor: '*Spec-Inspector' stamp: 'cb 6/25/2013 13:43'! inspectorClass ^ EyeDictionaryInspector! ! !DictionaryTest commentStamp: 'TorstenBergmann 2/20/2014 15:20'! SUnit tests for dictionaries! !DictionaryTest methodsFor: 'requirement' stamp: 'AlexandreBergel 1/6/2009 15:06'! nonEmptyDict ^ nonEmptyDict ! ! !DictionaryTest methodsFor: 'test - copying' stamp: ''! testDictionaryConcatenationWithCommonKeysDifferentValues | dictionary1 dictionary2 result value | dictionary1 := self nonEmptyDict. value := self nonEmptyDifferentFromNonEmptyDict values anyOne. dictionary2 := dictionary1 copy. dictionary2 keys do: [ :key | dictionary2 at: key put: value ]. result := dictionary1 , dictionary2. self assert: result size = ( dictionary2 size). dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! ! !DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !DictionaryTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''! testOccurrencesOfForMultipliness | collection elem | collection := self collectionWithEqualElements . elem := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: elem ) = 2. ! ! !DictionaryTest methodsFor: 'tests - dictionary including' stamp: ''! testIncludesIdentitySpecificComportement | valueIn collection | collection := self nonEmptyWithCopyNonIdentical . valueIn := collection values anyOne. self assert: (collection includesIdentity: valueIn ) . self deny: (collection includesIdentity: valueIn copy ) . ! ! !DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''! testValuesDo | collection values | collection := self nonEmptyDict . values := OrderedCollection new. collection valuesDo: [ :value | values add: value. ]. collection values do: [ :value | self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)]! ! !DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''! testReject "Ensure that Dictionary>>reject: answers a dictionary not something else" | collection result | collection := self nonEmptyDict . result := collection reject: [ :each | false]. self assert: result = collection. ! ! !DictionaryTest methodsFor: 'tests - converting' stamp: ''! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''! testAssociationsDo | collection keys | collection := self nonEmptyDict . keys := OrderedCollection new. collection associationsDo: [ :assoc | keys add: assoc key. self assert: ( collection at: assoc key ) = assoc value. ]. collection keys do: [:key | self assert: ( keys occurrencesOf: key ) = (collection keys occurrencesOf: key)].! ! !DictionaryTest methodsFor: 'tests - Dictionary keys values associations access' stamp: ''! testKeysSortedSafely | collection result | collection := self nonEmpty. result := collection keysSortedSafely. result do: [ :key | collection at: key ]. self assert: result size = collection size. self should: [ result detect: [ :each | (result occurrencesOf: each) > 1 ] ] raise: Error. self assert: result asArray isSorted! ! !DictionaryTest methodsFor: 'tests - converting' stamp: ''! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !DictionaryTest methodsFor: 'tests - converting' stamp: ''! testAsByteArray | res | self integerCollectionWithoutEqualElements. self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ]. res := true. self integerCollectionWithoutEqualElements detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0TStructuralEqualityTest self empty. self nonEmpty. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty! ! !DictionaryTest methodsFor: 'tests' stamp: 'nice 10/6/2009 14:21'! testAsSet "Non regression test for http://bugs.squeak.org/view.php?id=7258" | aDictionary aSet assoc0 assoc1 | "Create a dictionary" aDictionary := Dictionary new. "Convert it to a Set" aSet := aDictionary asSet. "Add two associations to it" assoc0 := #first -> 0. assoc1 := #first -> 1. aSet add: assoc0 copy; add: assoc1. "Check if the two associations were added (that should happen if they are different)" self assert: (assoc0 copy ~= assoc1) ==> (aSet size > 1) description: 'When adding two different elements, the set size should be greater than one'! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryIncludesIdentity self nonEmptyWithCopyNonIdentical. self deny: self nonEmptyWithCopyNonIdentical isEmpty. self nonEmptyWithCopyNonIdentical do: [ :each | self deny: each == each copy ]! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 15:21'! keyNotInNonEmptyDict " return a key not included in nonEmptyDict" ^ keyNotIn ! ! !DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !DictionaryTest methodsFor: 'test - removing' stamp: ''! testRemoveKeyIfAbsent | collection oldSize keyIn value result | collection := self nonEmptyDict . oldSize := collection size. keyIn := collection keys anyOne. value := collection at: keyIn . result := collection removeKey: keyIn ifAbsent: [888]. self assert: result = value. self assert: (collection size = (oldSize - 1)). self should: [ (collection at: keyIn )] raise: Error. self assert: (collection removeKey: self keyNotInNonEmptyDict ifAbsent: [888] ) = 888.! ! !DictionaryTest methodsFor: 'requirement' stamp: 'AlexandreBergel 1/6/2009 15:09'! newEmptyDict ^ self emptyDict copy! ! !DictionaryTest methodsFor: 'test - removing' stamp: ''! testRemoveKey "self debug: #testRemoveKey" | collection oldSize keyIn | collection := self nonEmptyDict . oldSize := collection size. keyIn := collection keys anyOne. collection removeKey: keyIn . self assert: (collection size = (oldSize - 1)). self should: [ (collection at: keyIn )] raise: Error. self should: [collection removeKey: self keyNotInNonEmptyDict ] raise: Error! ! !DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''! testAtPutDict "self run: #testAtPutDict" "self debug: #testAtPutDict" | adictionary keyIn | adictionary := self nonEmpty . keyIn := adictionary keys anyOne. adictionary at: keyIn put: 'new'. self assert: (adictionary at: keyIn ) = 'new'. adictionary at: keyIn put: 'newnew'. self assert: (adictionary at: keyIn ) = 'newnew'. adictionary at: self keyNotIn put: 666. self assert: (adictionary at: self keyNotIn ) = 666.! ! !DictionaryTest methodsFor: 'tests - dictionary including' stamp: ''! testIncludesKey | collection keyIn nonExistantKey | collection := self nonEmpty . keyIn := collection keys anyOne. nonExistantKey := self keyNotInNonEmpty. self assert: ( collection includesKey: keyIn ). self deny: ( collection includesKey: nonExistantKey ).! ! !DictionaryTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !DictionaryTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asArray sort. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !DictionaryTest methodsFor: 'tests - dictionary including' stamp: ''! testIncludesAssociation | nonExistantAssociation associationIn keyIn valueIn | keyIn := self nonEmpty keys anyOne. valueIn := self nonEmpty values anyOne. nonExistantAssociation := self keyNotInNonEmpty -> self valueNotInNonEmpty . associationIn := self nonEmpty associations anyOne. self assert: (self nonEmpty includesAssociation: associationIn ). self deny: (self nonEmpty includesAssociation: nonExistantAssociation ). " testing the case where key is included but not with the same value :" self deny: (self nonEmpty includesAssociation: (keyIn-> self valueNotInNonEmpty )). " testing the case where value is included but not corresponding key :" self deny: (self nonEmpty includesAssociation: (self keyNotInNonEmpty -> valueIn )). ! ! !DictionaryTest methodsFor: 'test - adding' stamp: 'delaunay 5/5/2009 12:08'! testAdd "| dict | dict := self emptyDict. dict add: #a -> 1. dict add: #b -> 2. self assert: (dict at: #a) = 1. self assert: (dict at: #b) = 2" | dictionary result | dictionary := self nonEmptyDict. result := dictionary add: self associationWithKeyNotInToAdd. self assert: result = self associationWithKeyNotInToAdd! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 15:52'! collectionWithoutEqualElements " return a collection without equal elements" ^ nonEmpty5ElementsNoDuplicates ! ! !DictionaryTest methodsFor: 'tests - converting' stamp: ''! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !DictionaryTest methodsFor: 'tests - dictionary assocition access' stamp: ''! testAssociationAtError | collection nonExistantKey | collection := self nonEmpty. nonExistantKey := self keyNotIn . self should: [collection associationAt: nonExistantKey] raise: Error. ! ! !DictionaryTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !DictionaryTest methodsFor: 'test - testing' stamp: 'damienpollet 1/30/2009 17:57'! testKeyForIdentity self assert: (nonEmptyDict keyForIdentity: 30) = #b. "The value 20 is associated to two different associations" self assert: (#(a c) includes: (nonEmptyDict keyForIdentity: self elementTwiceIn))! ! !DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !DictionaryTest methodsFor: 'tests - copy' stamp: ''! testCopyNotSame "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self nonEmpty copy. self deny: copy == self nonEmpty.! ! !DictionaryTest methodsFor: 'tests' stamp: 'CamilloBruni 3/23/2013 12:18'! testNilHashCollision "Ensures that fixCollisionsFrom: does the right thing in the presence of a nil key" | dict key | self supportsNilKey ifFalse: [ ^ self ]. dict := self collectionClass new. key := nil hash. "any key with same hash as nil" dict at: key hash put: 1. dict at: nil put: 2. self assert: (dict includesKey: nil). dict removeKey: key. self assert: (dict includesKey: nil). ! ! !DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collectionWithoutEqualElements difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res size equals: self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (res includes: each)]. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res equals: separateCol! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCloneTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 16:05'! collectionWithElement "Returns a collection that already includes what is returned by #element." ^ nonEmpty5ElementsNoDuplicates add: self element ;yourself.! ! !DictionaryTest methodsFor: 'tests - printing' stamp: ''! testPrintOn | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)).]. ].! ! !DictionaryTest methodsFor: 'tests - printing' stamp: ''! testPrintElementsOn | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)). ].! ! !DictionaryTest methodsFor: 'tests - at put' stamp: ''! testAtPutTwoValues "self debug: #testAtPutTwoValues" self nonEmpty at: self anIndex put: self aValue. self nonEmpty at: self anIndex put: self anotherValue. self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryKeysValuesAssociationsAccess self nonEmpty. self deny: self nonEmpty isEmpty! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryElementAccess | in | self nonEmpty. self deny: self nonEmpty isEmpty. self keyNotIn. in := true. self nonEmpty keys detect: [ :key | key = self keyNotIn ] ifNone: [ in := false ]. self assert: in = false! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryRemovingTest self nonEmptyDict. self deny: self nonEmptyDict isEmpty. self keyNotInNonEmptyDict. self deny: (self nonEmptyDict keys includes: self keyNotInNonEmptyDict)! ! !DictionaryTest methodsFor: 'requirement' stamp: 'stephane.ducasse 11/21/2008 15:05'! anotherElementNotIn ^ 42! ! !DictionaryTest methodsFor: 'tests - dictionary key access' stamp: ''! testKeyAtValue "self run: #testKeyAtValue" "self debug: #testKeyAtValue" | dict value result | dict := self nonEmpty . value := dict values anyOne. result := dict keyAtValue: value. self assert: (dict at: result) = value. self should: [dict keyAtValue: self valueNotIn ] raise: Error ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 11:09'! collectionWithElementsToRemove " return a collection of elements included in 'nonEmpty' " ^ collectionIncluded ! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString tmp | delim := ', '. last := 'and'. result:=''. tmp := self nonEmpty collect: [:each | each asString]. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) | i= allElementsAsString size ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. ]. ! ! !DictionaryTest methodsFor: 'test - integrity' stamp: 'CamilloBruni 3/23/2013 12:08'! testAllDictionariesAreHealthy "only makes sense on Dictionary" self classToBeTested = Dictionary ifFalse: [ ^ self ]. self assert: (Dictionary allSubInstances select: [:dict | dict isHealthy not ]) isEmpty.! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !DictionaryTest methodsFor: 'test - testing' stamp: 'AlexandreBergel 1/6/2009 13:48'! testIsDictionary self deny: Object new isDictionary. self assert: nonEmptyDict isDictionary. self assert: emptyDict isDictionary.! ! !DictionaryTest methodsFor: 'test - adding' stamp: ''! testDeclareFrom | newDict v dictionary keyIn associationKeyNotIn | dictionary := self nonEmptyDict. keyIn := dictionary keys anyOne. associationKeyNotIn := self associationWithKeyNotInToAdd . newDict := self collectionClass new add: associationKeyNotIn; yourself. "if the key already exist, nothing changes" v := dictionary at: keyIn. dictionary declare: keyIn from: newDict. self assert: (dictionary at: keyIn ) = v. "if the key does not exist, then it gets removed from newDict and is added to the receiver" self nonEmptyDict declare: associationKeyNotIn key from: newDict. self assert: (dictionary at: associationKeyNotIn key) = associationKeyNotIn value. self assert: (newDict size = 0)! ! !DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/30/2009 17:44'! expectedSizeAfterReject self flag: 'what should this return?'! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeTest | anElementIn | self nonEmpty. self deny: self nonEmpty isEmpty. self elementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self anotherElementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self empty. self assert: self empty isEmpty! ! !DictionaryTest methodsFor: 'setup' stamp: 'AlexandreBergel 1/14/2009 15:14'! classToBeTested ^ Dictionary! ! !DictionaryTest methodsFor: 'tests - dictionary including' stamp: ''! testIncludesIdentityBasicComportement | valueIn collection | collection := self nonEmpty . valueIn := collection values anyOne. self assert: (collection includesIdentity: valueIn ) . self deny: (collection includesIdentity: self valueNotInNonEmpty ).! ! !DictionaryTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !DictionaryTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotInForOccurrences). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotInForOccurrences)! ! !DictionaryTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 16:05'! keyNotIn " return a key not included in nonEmpty" ^ keyNotIn ! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do: [:each1 | self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] ]. ! ! !DictionaryTest methodsFor: 'tests - dictionary assocition access' stamp: ''! testAssociationAtIfAbsent | collection keyIn result | collection := self nonEmpty. keyIn := collection keys anyOne. result := collection associationAt: keyIn ifAbsent: [888]. self assert: (result key) = keyIn. self assert: (result value ) = (collection at: keyIn ). self assert: (collection associationAt: self keyNotIn ifAbsent: [888] ) = 888! ! !DictionaryTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiter | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)) ].! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSetAritmeticTest self collection. self deny: self collection isEmpty. self nonEmpty. self deny: self nonEmpty isEmpty. self anotherElementOrAssociationNotIn. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self collectionClass! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePutTest self aValue. self anotherValue. self anIndex. self nonEmpty isDictionary ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. self empty. self assert: self empty isEmpty . self nonEmpty. self deny: self nonEmpty isEmpty.! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 15:19'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^nonEmpty5ElementsNoDuplicates ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 15:52'! integerCollectionWithoutEqualElements " return a collection of integer without equal elements" ^ nonEmpty5ElementsNoDuplicates ! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self collectionWithoutEqualElements. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !DictionaryTest methodsFor: 'test - comparing' stamp: ''! testEquality | nonEmptyDict2 | nonEmptyDict2 := self nonEmpty class new. self nonEmpty keysAndValuesDo: [ :key :value | nonEmptyDict2 at: key put: value ]. self assert: (self nonEmptyDict = nonEmptyDict2)! ! !DictionaryTest methodsFor: 'test - integrity' stamp: 'CamilloBruni 3/23/2013 12:15'! testHealthyWorks "we use associations as keys on purpose, because they changing hash depending on the key" | a1 a2 dict | self classToBeTested = Dictionary ifFalse: [ ^ self "only works on Dictionary" ]. dict := Dictionary new. [a1 := 1 -> 2. a2 := 2 -> 2. dict at: a1 put: 2; at: a2 put: 3. self assert: dict isHealthy. a1 key: 0. a2 key: 0. self assert: dict isHealthy not] ensure: [dict removeAll]! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryAddingTest self nonEmptyDict. self deny: self nonEmptyDict isEmpty. self associationWithKeyNotInToAdd. self deny: (self nonEmptyDict keys includes: self associationWithKeyNotInToAdd key). self associationWithKeyAlreadyInToAdd. self assert: (self nonEmptyDict keys includes: self associationWithKeyAlreadyInToAdd key)! ! !DictionaryTest methodsFor: 'tests - copy' stamp: ''! testCopyEquals "self debug: #testCopySameClass" "A copy should be equivalent to the things it's a copy of" | copy | copy := self nonEmpty copy. self assert: copy = self nonEmpty.! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterMore | delim multiItemStream result allElementsAsString tmp | delim := ', '. result:=''. tmp:= self nonEmpty collect:[:each | each asString]. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. allElementsAsString := (result findBetweenSubStrs: ', ' ). allElementsAsString do: [:each | self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). ].! ! !DictionaryTest methodsFor: 'test - adding' stamp: 'delaunay 5/5/2009 12:08'! testAddWithKeyAlreadyIn | dictionary result association | dictionary := self nonEmptyDict. association := self associationWithKeyNotInToAdd. result := dictionary add: association. self assert: result = association. self assert: (dictionary at: association key) = association value! ! !DictionaryTest methodsFor: 'test - testing' stamp: 'CamilloBruni 3/23/2013 12:12'! testIncludesAssociationWithValue | association dictionary | association := Association key: #key value: 1. dictionary := self collectionClass new. dictionary add: association. self assert: (dictionary at: #key) = 1 ! ! !DictionaryTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !DictionaryTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:25'! anIndex ^ #GG! ! !DictionaryTest methodsFor: 'tests - includes' stamp: ''! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !DictionaryTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryIncludes | in | self nonEmpty. self deny: self nonEmpty isEmpty. self valueNotInNonEmpty. in := false. self nonEmpty valuesDo: [ :assoc | assoc = self valueNotInNonEmpty ifTrue: [ in := true ] ]. self assert: in = false. self keyNotInNonEmpty. in := false. self nonEmpty keysDo: [ :assoc | assoc = self keyNotInNonEmpty ifTrue: [ in := true ] ]. self assert: in = false! ! !DictionaryTest methodsFor: 'test - new' stamp: 'delaunay 5/4/2009 14:24'! testNew | d | d := self classToBeTested new: 10. self assert: d size = 0. "Why 14? Mysterious" "self assert: d capacity = 14"! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryCopyingTest | duplicateKey | self nonEmptyDict. self deny: self nonEmptyDict isEmpty. self nonEmptyDifferentFromNonEmptyDict. self deny: self nonEmptyDifferentFromNonEmptyDict isEmpty. duplicateKey := true. self nonEmptyDict keys detect: [ :key | self nonEmptyDifferentFromNonEmptyDict includes: key ] ifNone: [ duplicateKey := false ]. self assert: duplicateKey = false! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureAsStringCommaAndDelimiterTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty. self nonEmpty1Element. self assert: self nonEmpty1Element size = 1! ! !DictionaryTest methodsFor: 'test - removing' stamp: ''! testRemove self should: [self nonEmptyDict remove: nil] raise: Error. self should: [self nonEmptyDict remove: nil ifAbsent: ['What ever here']] raise: Error.! ! !DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''! testCollect | collection values result | collection := self nonEmptyDict . values := OrderedCollection new. result := collection collect: [ :value | values add: value. ]. collection values do: [ :value | self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)]. self assert: result = collection.! ! !DictionaryTest methodsFor: 'tests - converting' stamp: ''! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !DictionaryTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAny: self empty). self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAny: self nonEmpty).! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureOccurrencesForMultiplinessTest | cpt anElement collection | self collectionWithEqualElements. self collectionWithEqualElements. self elementTwiceInForOccurrences. anElement := self elementTwiceInForOccurrences. collection := self collectionWithEqualElements. cpt := 0. " testing with identity check ( == ) so that identy collections can use this trait : " self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. self assert: cpt = 2! ! !DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''! testSelect | collection values result | collection := self nonEmptyDict . values := OrderedCollection new. result := collection select: [ :value | values add: value. true]. collection values do: [ :value| self assert: (collection values occurrencesOf: value) = (values occurrencesOf: value)]. self assert: result = collection.! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/6/2009 10:09'! nonEmptyDifferentFromNonEmptyDict " return a dictionary for which all keys are not included in nonEmptyDict" ^ dictionaryNotIncluded ! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 10:17'! elementToAdd " return an element of type 'nonEmpy' elements'type'" ^ #u->5.! ! !DictionaryTest methodsFor: 'test - copying' stamp: ''! testDictionaryConcatenationWithoutCommonKeys | dictionary1 dictionary2 result | dictionary1 := self nonEmptyDict. dictionary2 := self nonEmptyDifferentFromNonEmptyDict. result := dictionary1 , dictionary2. self assert: result size = (dictionary1 size + dictionary2 size). dictionary1 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]. dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! ! !DictionaryTest methodsFor: 'requirements' stamp: 'stephane.ducasse 11/21/2008 15:04'! nonEmpty ^ nonEmptyDict! ! !DictionaryTest methodsFor: 'tests - at put' stamp: ''! testAtPut "self debug: #testAtPut" self nonEmpty at: self anIndex put: self aValue. self assert: (self nonEmpty at: self anIndex) = self aValue. ! ! !DictionaryTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyNonEmpty "self debug: #testCopyNonEmpty" | copy | copy := self nonEmpty copy. self deny: copy isEmpty. self assert: copy size = self nonEmpty size. self nonEmpty do: [:each | copy includes: each]! ! !DictionaryTest methodsFor: 'requirement' stamp: 'AlexandreBergel 1/6/2009 15:06'! emptyDict ^ emptyDict! ! !DictionaryTest methodsFor: 'test - removing' stamp: ''! testKeysAndValuesRemove | oldSize collection keyIn | collection := self nonEmptyDict . oldSize := collection size. keyIn := collection keys anyOne. collection keysAndValuesRemove: [:key :value | key == self keyNotInNonEmptyDict ]. self assert: (collection size = (oldSize )). collection keysAndValuesRemove: [:key :value | key == keyIn ]. self assert: (collection size = (oldSize - 1)). self should: [ collection at: keyIn ] raise: Error.! ! !DictionaryTest methodsFor: 'tests - printing' stamp: ''! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryEnumeratingTest self nonEmptyDict. self deny: self nonEmptyDict isEmpty! ! !DictionaryTest methodsFor: 'test - equality' stamp: ''! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''! testAtIfAbsentPut | collection association | collection := self nonEmpty . association := collection associations anyOne. collection at: association key ifAbsentPut: [ 888 ]. self assert: (collection at: association key) = association value. collection at: self keyNotIn ifAbsentPut: [ 888 ]. self assert: ( collection at: self keyNotIn ) = 888.! ! !DictionaryTest methodsFor: 'test - testing' stamp: 'CamilloBruni 3/23/2013 12:11'! testIncludes | o1 o2 newDict | self assert: (nonEmptyDict includes: self element). o1 := 2 @ 3. o2 := 2 @ 3. self deny: (o1 == o2). self assert: (o1 = o2). newDict := self collectionClass new. newDict at: #a put: o1. self assert: (newDict includes: o2). ! ! !DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/13/2009 16:55'! sizeCollection ^ nonEmptyDict! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsCommaStringMore | result resultAnd index allElementsAsString tmp | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . tmp :=OrderedCollection new. self nonEmpty do: [ :each | tmp add: each asString]. "verifying result :" index := 1. allElementsAsString := (result findBetweenSubStrs: ', ' ). allElementsAsString do: [:each | self assert: (tmp occurrencesOf: each)=(allElementsAsString occurrencesOf: each). ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) | i= allElementsAsString size ifTrue: [self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self assert: (allElementsAsString at:i)=('and')]. ].! ! !DictionaryTest methodsFor: 'requirement' stamp: 'delaunay 5/5/2009 14:15'! associationWithKeyNotInToAdd " return an association that will be used to add to nonEmptyDict" ^ associationNotIn ! ! !DictionaryTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:24'! aValue ^ 33! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryKeyAccess | collection equals | self nonEmptyWithoutEqualsValues. self deny: self nonEmptyWithoutEqualsValues isEmpty. equals := true. collection := self nonEmptyWithoutEqualsValues values. collection detect: [ :each | (collection occurrencesOf: each) > 1 ] ifNone: [ equals := false ]. self assert: equals = false. self valueNotIn. self deny: (self nonEmptyWithoutEqualsValues values includes: self valueNotIn)! ! !DictionaryTest methodsFor: 'requirement' stamp: 'stephane.ducasse 11/21/2008 15:04'! empty ^ emptyDict! ! !DictionaryTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res anElement | anElement := self elementToAdd . res := self nonEmpty copyWith: anElement. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: (anElement value)). self nonEmpty do: [ :each | res includes: each ]! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !DictionaryTest methodsFor: 'tests - dictionary assocition access' stamp: ''! testAssociationAt | collection keyIn result | collection := self nonEmpty. keyIn := collection keys anyOne. result := collection associationAt: keyIn. self assert: (result key) = keyIn. self assert: (result value ) = (collection at: keyIn ).! ! !DictionaryTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAllNotIncluded "self debug: #testCopyNonEmptyWithoutAllNotIncluded" | res | res := self nonEmpty copyWithoutAll: self collectionNotIncluded. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !DictionaryTest methodsFor: 'tests - dictionary including' stamp: ''! testIncludesComportementForDictionnary | valueIn collection keyIn | collection := self nonEmpty. valueIn := collection values anyOne. keyIn := collection keys anyOne. self assert: (collection includes: valueIn). self deny: (collection includes: self valueNotInNonEmpty). " testing that includes take only care of values :" self deny: (collection includes: keyIn)! ! !DictionaryTest methodsFor: 'tests' stamp: 'CamilloBruni 3/23/2013 12:13'! testRemoveAll "Allows one to remove all elements of a collection" | dict1 dict2 s2 | dict1 := self collectionClass new. dict1 at: #a put:1 ; at: #b put: 2. dict2 := dict1 copy. s2 := dict2 size. dict1 removeAll. self assert: dict1 size = 0. self assert: dict2 size = s2 description: 'the copy has not been modified'.! ! !DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/13/2009 16:15'! collection ^ self nonEmptyDict! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 11:56'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection associations anyOne.! ! !DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:54'! collectionWithEqualElements " return a collecition including atLeast two elements equal" ^ dictionaryWithDuplicateValues ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 10:45'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ nonEmpty5ElementsNoDuplicates ! ! !DictionaryTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !DictionaryTest methodsFor: 'test - testing' stamp: 'CamilloBruni 3/23/2013 12:11'! testHasBindingThatBeginsWith | newDict | newDict := self collectionClass new at: #abc put: 10; at: #abcd put: 100; at: #def put: 20; yourself. self assert: (newDict hasBindingThatBeginsWith: 'ab'). self assert: (newDict hasBindingThatBeginsWith: 'def'). self deny: (newDict hasBindingThatBeginsWith: 'defg').! ! !DictionaryTest methodsFor: 'tests - Dictionary keys values associations access' stamp: ''! testAssociations | collection result | collection := self nonEmpty . result := collection associations. self assert: result size = collection size. result do: [:assoc | self assert: (assoc value) = (collection at: assoc key) ]. "keys do: [ :key | self assert: ( result at: key ) = ( collection at: key )] ." ! ! !DictionaryTest methodsFor: 'tests - converting' stamp: ''! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !DictionaryTest methodsFor: 'tests - Dictionary keys values associations access' stamp: ''! testValues | collection result | collection := self nonEmpty . result := collection values. self assert: result size = collection size. result do: [:each | self assert: (collection occurrencesOf:each ) = (result occurrencesOf: each) ]. ! ! !DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''! testAtIfPresent "self run: #testAtIfAbsent" | t collection association nonExistantKey | collection := self nonEmpty . association := collection associations anyOne. nonExistantKey := self keyNotIn . t := false. self nonEmptyDict at: association key ifPresent: [:x | t := (x = association value)]. self assert: t. self assert: (self nonEmptyDict at: association key ifPresent: [:x | 'ABCDEF']) = 'ABCDEF'. self assert: (self nonEmptyDict at: nonExistantKey ifPresent: [:x | Error signal]) isNil ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 15:00'! valueNotInNonEmpty " return a value not included in nonEmpty" ^ valueNotIn ! ! !DictionaryTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !DictionaryTest methodsFor: 'requirements' stamp: 'CamilloBruni 3/23/2013 12:16'! supportsNilKey ^ true! ! !DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureOccurrencesTest | tmp | self empty. self assert: self empty isEmpty. self collectionWithoutEqualElements. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each ]. self elementNotInForOccurrences. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''! testAtIfAbsent | collection association | collection := self nonEmpty . association := collection associations anyOne. self assert: (collection at: association key ifAbsent: [ 888 ]) = association value. self assert: (collection at: self keyNotIn ifAbsent: [ 888 ]) = 888.! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 10:16'! collectionNotIncluded " return a collection for wich each element is not included in 'nonEmpty' " ^collectionNotIncluded ! ! !DictionaryTest methodsFor: 'requirement' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ 666! ! !DictionaryTest methodsFor: 'test - equality' stamp: ''! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !DictionaryTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !DictionaryTest methodsFor: 'requirement' stamp: 'delaunay 5/5/2009 14:16'! associationWithKeyAlreadyInToAdd " return an association that will be used to add to nonEmptyDict (the key of this association is already included in nonEmptyDict)" ^ (self nonEmptyDict keys anyOne)->valueNotIn .! ! !DictionaryTest methodsFor: 'tests' stamp: 'CamilloBruni 3/23/2013 12:13'! testSelectIsNotShallowCopy "self debug: #testSelectIsNotShallowCopy" | original even | original := self collectionClass new. original at: #one put: 1. original at: #two put: 2. even := original select: [:value |value even]. even at: #two put: 'deux'. self assert: (original at: #two) = 2 description: 'modifying a selection should not modify the original'! ! !DictionaryTest methodsFor: 'tests - Dictionary keys values associations access' stamp: ''! testKeys | collection result | collection := self nonEmpty. result := collection keys. result do: [ :key | collection at: key ]. self assert: result size = collection size. self should: [ result detect: [ :each | (result occurrencesOf: each) > 1 ] ] raise: Error! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 11:56'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ associationNotIn ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 15:00'! keyNotInNonEmpty " return a key not included in nonEmpty" ^ keyNotIn ! ! !DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !DictionaryTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:25'! anotherValue ^ 66! ! !DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" | difference | self assert: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements) isEmpty. self assert: (self empty difference: self collectionWithoutEqualElements) isEmpty. difference := (self collectionWithoutEqualElements difference: self empty). self assert: difference size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each)]. ! ! !DictionaryTest methodsFor: 'test - testing' stamp: 'CamilloBruni 3/23/2013 12:17'! testOccurrencesOf "self run:#testOccurrencesOf" | dict | dict := self collectionClass new. dict at: #a put: 1. dict at: #b put: 2. dict at: #c put: 1. dict at: #d put: 3. dict at: nil put: nil. dict at: #z put: nil. self assert: (dict occurrencesOf: 1 ) equals: 2. self supportsNilKey ifTrue: [ self assert: (dict occurrencesOf: nil ) equals: 2 ] ifFalse: [ self assert: (dict occurrencesOf: nil ) equals: 1 ]. ! ! !DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''! testKeysAndValuesDo | collection keys | collection := self nonEmptyDict . keys := OrderedCollection new. collection keysAndValuesDo: [ :key :value | keys add: key. self assert: (collection at: key) = value ]. collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]! ! !DictionaryTest methodsFor: 'tests - converting' stamp: ''! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionItself "self debug: #testIntersectionItself" | result | result := (self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements). self assert: result size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (result includes: each) ]. ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:54'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ duplicateValue ! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0CopyTest self empty. self assert: self empty size = 0. self nonEmpty. self assert: (self nonEmpty size = 0) not. self collectionWithElementsToRemove. self assert: (self collectionWithElementsToRemove size = 0) not. self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ]. self elementToAdd. self deny: (self nonEmpty includes: self elementToAdd). self collectionNotIncluded. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !DictionaryTest methodsFor: 'test - testing' stamp: 'damienpollet 1/30/2009 17:55'! testIncludeAssociation self assert: (nonEmptyDict includesAssociation: #a -> self elementTwiceIn). self assert: (nonEmptyDict includesAssociation: (nonEmptyDict associations first)). ! ! !DictionaryTest methodsFor: 'test - adding' stamp: ''! testAddAll | collectionToAdd collection result oldSize | collection := self nonEmptyDict . oldSize := collection size. collectionToAdd := self collectionClass new add: self associationWithKeyAlreadyInToAdd ; add: self associationWithKeyNotInToAdd ; yourself. result := collection addAll: collectionToAdd . self assert: result = collectionToAdd . " the association with the key already in should have replaced the oldest :" self assert: collection size = (oldSize + 1). result associationsDo: [:assoc | self assert: (collection at: (assoc key) ) = assoc value].! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 16:08'! element ^ 30! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 16:04'! otherCollection "Returns a collection that does not include what is returned by #element." ^ nonEmpty5ElementsNoDuplicates ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 10:12'! indexInNonEmpty " return an index between bounds of 'nonEmpty' " ^ #a! ! !DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''! testAtPutNil "self run: #testAtPut" "self debug: #testAtPut" | aDictionary keyIn | aDictionary := self nonEmpty . keyIn := aDictionary keys anyOne. aDictionary at: nil put: 'new'. self assert: (aDictionary at: nil) = 'new'. aDictionary at: keyIn put: nil. self assert: (aDictionary at: keyIn ) isNil. aDictionary at: self keyNotIn put: nil. self assert: ( aDictionary at: self keyNotIn ) isNil. aDictionary at: nil put: nil. self assert: (aDictionary at: nil) isNil.! ! !DictionaryTest methodsFor: 'requirement' stamp: 'CamilloBruni 3/23/2013 12:06'! result ^ self collectionClass newFromPairs: { #a . SmallInteger . #b . SmallInteger . #c . SmallInteger . #d . SmallInteger }! ! !DictionaryTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !DictionaryTest methodsFor: 'test - equality' stamp: ''! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''! testAssociationsSelect | collection keys result | collection := self nonEmptyDict . keys := OrderedCollection new. result := collection associationsSelect: [ :assoc | keys add: assoc key. true]. collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]. self assert: result = collection.! ! !DictionaryTest methodsFor: 'requirements' stamp: ''! collectionClass " return the class to be used to create instances of the class tested" ^ self explicitRequirement! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 15:24'! nonEmpty1Element " return a collection of size 1 including one element" ^ nonEmpty1Element ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 10:41'! valueNotIn " return a value not included in nonEmpty " ^valueNotIn ! ! !DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !DictionaryTest methodsFor: 'tests' stamp: 'CamilloBruni 3/23/2013 12:10'! testAtIfPresentIfAbsent "Test at:ifPresent:ifAbsent:" "to move to the corresponding trait" | dict present absent | dict := self collectionClass new. present := absent := false. dict at: #foo ifPresent: [:v| present := true] ifAbsent: [absent := true]. self deny: present. self assert: absent. dict at: #foo put: #bar. present := absent := false. dict at: #foo ifPresent: [:v| present := true] ifAbsent: [absent := true]. self assert: present. self deny: absent. present := absent := false. dict at: #foo ifPresent: [:v| present := true. nil] ifAbsent: [absent := true]. self assert: present. self deny: absent. ! ! !DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''! testDo | t collection | collection := self nonEmptyDict . t := OrderedCollection new. collection do: [: value | t add: value ]. t do: [ :each | self assert: (t occurrencesOf: each ) = ( collection values occurrencesOf: each) ].! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/12/2009 11:07'! nonEmptyWithCopyNonIdentical. " return a collection including elements for wich copy is not identical to the initial element ( this is not the cas of Integer )" ^nonEmptyWithFloat ! ! !DictionaryTest methodsFor: 'test - testing' stamp: 'CamilloBruni 3/23/2013 12:12'! testIncludesAssociationNoValue | association dictionary | association := Association key: #key. self assert: association value isNil. dictionary := self collectionClass new. dictionary add: association. self assert: (dictionary at: #key) isNil ! ! !DictionaryTest methodsFor: 'tests - copy' stamp: ''! testCopySameClass "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self empty copy. self assert: copy class == self empty class.! ! !DictionaryTest methodsFor: 'tests - dictionary key access' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testKeyAtIdentityValueIfAbsent "self run: #testKeyAtValue" "self debug: #testKeyAtValue" | dict value result | dict := self nonEmpty. value := dict values anyOne. result := dict keyAtIdentityValue: value ifAbsent: [ nil ]. self assert: (dict at: result) = value. self assert: (dict keyAtIdentityValue: self valueNotIn ifAbsent: [ nil ]) isNil! ! !DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/21/2009 18:04'! speciesClass ^ Dictionary! ! !DictionaryTest methodsFor: 'tests - set arithmetic' stamp: ''! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !DictionaryTest methodsFor: 'tests - dictionary key access' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testKeyAtValueIfAbsent "self run: #testKeyAtValue" "self debug: #testKeyAtValue" | dict value result | dict := self nonEmpty. value := dict values anyOne. result := dict keyAtValue: value ifAbsent: [ nil ]. self assert: (dict at: result) = value. self assert: (dict keyAtValue: self valueNotIn ifAbsent: [ nil ]) isNil! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryAssocitionAccess self nonEmpty. self deny: self nonEmpty isEmpty. self keyNotIn. self deny: (self nonEmpty keys includes: self keyNotIn)! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsCommaStringOne self nonEmpty1Element do: [:each | self assert: each asString =self nonEmpty1Element asCommaString. self assert: each asString=self nonEmpty1Element asCommaStringAnd.]. ! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePrintTest self nonEmpty. self deny: self nonEmpty isEmpty! ! !DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/21/2009 18:22'! expectedElementByDetect ^ 30! ! !DictionaryTest methodsFor: 'tests - dictionnary enumerating' stamp: ''! testKeysDo | collection keys | collection := self nonEmptyDict . keys := OrderedCollection new. collection keysDo: [ :key | keys add: key. ]. collection keys do: [ :key | self assert: (collection keys occurrencesOf: key) = (keys occurrencesOf: key)]! ! !DictionaryTest methodsFor: 'tests - includes' stamp: ''! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 14:51'! elementNotIn "return an element not included in 'nonEmpty' " ^ valueNotIn! ! !DictionaryTest methodsFor: 'setup' stamp: 'delaunay 5/13/2009 15:54'! setUp emptyDict := self classToBeTested new. nonEmptyDict := self classToBeTested new. nonEmptyDict at: #a put: self elementTwiceIn; at: #b put: 30; at: #c put: self elementTwiceIn; at: #d put: -2. nonEmpty5ElementsNoDuplicates := self classToBeTested new at: #a put: 5; at: #b put: 4; at: #c put: 7; at: #d put: 6; at: #e put: 9; yourself. valueNotIn := 666. keyNotIn := #z . associationNotIn := keyNotIn->valueNotIn. dictionaryNotIncluded := Dictionary new add: associationNotIn ;yourself. collectionNotIncluded := { valueNotIn. valueNotIn }. collectionIncluded := { (self elementTwiceIn) }. indexArray := #(2 3 1 ). valueArray := #(5 5 5 ). nonEmpty1Element := self classToBeTested new at: #a put: 5; yourself. nonEmptyWithFloat := Dictionary new add: #A->2.5; add: #b->3.5 ; yourself. duplicateValue := 2.5. dictionaryWithDuplicateValues := Dictionary new add: #A->duplicateValue ; add: #b->3.5 ; add: #C->duplicateValue ; yourself. ! ! !DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''! testAtError "self run: #testAtError" | dict nonExistantKey keyIn | dict := self nonEmpty. nonExistantKey := self keyNotIn. keyIn := dict keys anyOne. dict at: keyIn. self should: [ dict at: nonExistantKey ] raise: Error! ! !DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing' stamp: ''! testAt | collection association | collection := self nonEmpty . association := collection associations anyOne. self assert: (collection at: association key) = association value.! ! !DictionaryTest methodsFor: 'test - adding' stamp: 'delaunay 5/5/2009 12:08'! testAddWithKeyNotIn | dictionary result association | dictionary := self nonEmptyDict. association := self associationWithKeyNotInToAdd. result := dictionary add: association. self assert: result = association. self assert: (dictionary at: association key) = association value! ! !DictionaryTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiterLast | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. ].! ! !DictionaryTest methodsFor: 'tests - converting' stamp: ''! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !DictionaryTest methodsFor: 'test - copying' stamp: ''! testDictionaryConcatenationWithCommonKeys | dictionary1 dictionary2 result | dictionary1 := self nonEmptyDict. dictionary2 := self nonEmptyDict. result := dictionary1 , dictionary2. self assert: result size = ( dictionary2 size). dictionary2 associationsDo: [ :assoc | self assert: (result at: assoc key) = assoc value ]! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable' stamp: ''! testAsStringOnDelimiterOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do: [:each1 | self nonEmpty1Element do: [:each2 |self assert: each1 = (each2 asString) ] ]. ! ! !DictionaryTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWith "self debug: #testCopyWith" | res anElement | anElement := self elementToAdd. res := self empty copyWith: anElement. self assert: res size = (self empty size + 1). self assert: (res includes: (anElement value))! ! !DictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureConverAsSortedTest self collectionWithSortableElements. self deny: self collectionWithSortableElements isEmpty! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 10:41'! nonEmptyWithoutEqualsValues " return a dictionary that doesn't include equal values'" ^nonEmpty5ElementsNoDuplicates ! ! !DictionaryTest methodsFor: 'tests - dictionary key access' stamp: ''! testKeyAtIdentityValue | dict value result | dict := self nonEmpty . value := dict values anyOne. result := dict keyAtIdentityValue: value. self assert: (dict at: result) = value. self should: [dict keyAtIdentityValue: self valueNotIn ] raise: Error ! ! !DictionaryTest methodsFor: 'tests - printing' stamp: ''! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !DictionaryValueHolder commentStamp: 'BenjaminVanRyseghem 1/23/2014 15:18'! I am designed specifically for dictionaries.! !DictionaryValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/6/2012 20:29'! at: key ifAbsentPut: aBlock ^ self at: key ifAbsent: [self at: key put: aBlock value]! ! !DictionaryValueHolder methodsFor: 'override' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! size ^ value size! ! !DictionaryValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! atNewIndex: index put: anObject value atNewIndex: index put: anObject. self valueChanged: anObject.! ! !DictionaryValueHolder methodsFor: 'protocol' stamp: ''! removeKey: key "Remove key from the receiver. If key is not in the receiver, notify an error." ^ self removeKey: key ifAbsent: [self errorKeyNotFound: key].! ! !DictionaryValueHolder methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! initialize: n value initialize: n. self valueChanged.! ! !DictionaryValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary value valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary. self valueChanged.! ! !DictionaryValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! doesNotUnderstand: aMessage ^ (value respondsTo: aMessage selector) ifTrue: [ value perform: aMessage selector withEnoughArguments: aMessage arguments ] ifFalse: [ super doesNotUnderstand: aMessage ]! ! !DictionaryValueHolder methodsFor: 'protocol' stamp: 'CamilloBruni 11/18/2013 18:11'! fillFrom: aCollection with: aBlock "Evaluate aBlock with each of aCollections's elements as the argument. Collect the resulting values into self. Answer self." aCollection keysAndValuesDo: [ :key :aValue | self at: key put: (aBlock value: aValue) ]! ! !DictionaryValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:57'! at: key put: anObject value at: key put: anObject. self valueChanged: anObject. ^ anObject! ! !DictionaryValueHolder methodsFor: 'override' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! at: anObject ^ value at: anObject! ! !DictionaryValueHolder methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 10/17/2013 16:26'! initialize super initialize. self value: Dictionary new.! ! !DictionaryValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! removeKey: key ifAbsent: aBlock | result | result := value removeKey: key ifAbsent: aBlock. self valueChanged. ^ result! ! !DictionaryValueHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! removeAll value removeAll. self valueChanged.! ! !DiffChangeMorph methodsFor: 'initialization' stamp: 'gvc 2/9/2010 13:12'! initialColorInSystemWindow: aSystemWindow "Answer the colour the receiver should be when added to a SystemWindow." ^Color transparent! ! !DiffChangeMorph methodsFor: 'hooks' stamp: 'gvc 2/9/2010 13:12'! diffMorphClass "Answer a the class to use for a new diff morph." ^DiffMorph! ! !DiffChangeMorph methodsFor: 'accessing' stamp: 'gvc 2/9/2010 13:12'! defaultTitle "Answer the default title label for the receiver." ^'Change Diff' translated! ! !DiffChangeMorph methodsFor: 'actions' stamp: 'gvc 2/9/2010 13:07'! adoptPaneColor: paneColor "Change the fill styles on the descriptions." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self descriptionMorph borderStyle: (self theme listNormalBorderStyleFor: self). self updateDescriptionFillStyle: paneColor ! ! !DiffChangeMorph methodsFor: 'accessing' stamp: 'gvc 2/9/2010 13:07'! diffMorph: anObject "Set the value of diffMorph" diffMorph := anObject! ! !DiffChangeMorph methodsFor: 'accessing' stamp: 'gvc 2/9/2010 13:07'! diffMorph "Answer the value of diffMorph" ^ diffMorph! ! !DiffChangeMorph methodsFor: 'actions' stamp: 'gvc 2/9/2010 13:12'! fromDescription: aString "Set the description for the left-hand side of the patch, typically 'currently in image'." self fromDescriptionMorph contents: aString! ! !DiffChangeMorph methodsFor: 'actions' stamp: 'gvc 2/9/2010 13:17'! newDescriptionMorph "Answer a new morph for the descriptions of the source and destination." ^(self newColumn: { (self newRow: {self newLabel: 'Original'}) layoutInset: 1. (self newRow: {self newLabel: 'Changed'}) layoutInset: 1; listCentering: #bottomRight}) layoutInset: 0; cellInset: 2; fillStyle: Color white; borderStyle: (self theme listNormalBorderStyleFor: self) ! ! !DiffChangeMorph methodsFor: 'initialization' stamp: 'IgorStasenko 12/19/2012 17:26'! initialize "Initialize the receiver." |descriptionHeight| super initialize. self diffMorph: self newDiffMorph; descriptionMorph: self newDescriptionMorph. descriptionHeight := self descriptionMorph minExtent y. self changeProportionalLayout; addMorph: self descriptionMorph fullFrame: ((0@0 corner: 1@0) asLayoutFrame bottomOffset: descriptionHeight); addMorph: self diffMorph fullFrame: (LayoutFrame identity topOffset: descriptionHeight). self extent: self initialExtent; updateDescriptionFillStyle: self paneColor! ! !DiffChangeMorph methodsFor: 'actions' stamp: 'gvc 2/9/2010 13:12'! fromDescriptionMorph "Answer the morph for the source description." ^self descriptionMorph firstSubmorph firstSubmorph! ! !DiffChangeMorph methodsFor: 'actions' stamp: 'gvc 2/9/2010 13:13'! toDescription: aString "Set the description for the right-hand side of the patch, typically 'incoming' or 'changed'." self toDescriptionMorph contents: aString! ! !DiffChangeMorph methodsFor: 'actions' stamp: 'gvc 2/9/2010 13:13'! toDescriptionMorph "Answer the morph for the destination description." ^self descriptionMorph lastSubmorph firstSubmorph! ! !DiffChangeMorph methodsFor: 'actions' stamp: 'gvc 2/9/2010 13:12'! newDiffMorph "Answer a new morph for the source difference." ^self diffMorphClass new borderStyle: (BorderStyle inset width: 1); font: self theme statusFont; addDependent: self; yourself! ! !DiffChangeMorph methodsFor: 'actions' stamp: 'gvc 2/9/2010 13:13'! updateDescriptionFillStyle: aColor "Change the colours on the descriptions." self descriptionMorph fillStyle: aColor. self fromDescriptionMorph owner color: (aColor alphaMixed: 0.5 with: Color white). self toDescriptionMorph owner color: (aColor alphaMixed: 0.3 with: Color white).! ! !DiffChangeMorph methodsFor: 'accessing' stamp: 'gvc 2/9/2010 13:07'! descriptionMorph: anObject "Set the value of descriptionMorph" descriptionMorph := anObject! ! !DiffChangeMorph methodsFor: 'accessing' stamp: 'gvc 2/9/2010 13:07'! descriptionMorph "Answer the value of descriptionMorph" ^ descriptionMorph! ! !DiffChangeMorph methodsFor: 'actions' stamp: 'gvc 2/9/2010 13:10'! from: old to: new contextClass: aClass "Set the old (src) and new (dst) text." self diffMorph from: old to: new contextClass: aClass! ! !DiffChangeMorph methodsFor: 'user interface' stamp: 'gvc 3/5/2010 12:43'! initialExtent "Answer the initial extent for the receiver." ^RealEstateAgent standardWindowExtent! ! !DiffChangeMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 2/9/2010 13:10'! from: old label: oldLabel to: new label: newLabel contextClass: aClass "Answer a new instance of the receiver with the given old and new text and descriptions." ^self new from: old to: new contextClass: aClass; fromDescription: oldLabel; toDescription: newLabel! ! !DiffChangeRecordConverter commentStamp: ''! A DiffChangeRecordConverter is a converter used to show the diff between two methodreferences! !DiffChangeRecordConverter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 7/3/2012 14:30'! priorVersionOfAMethod: aChangeRecord | index | list := referencesList sorted: [:a :b | a timeStamp > b timeStamp ]. index := list indexOf: aChangeRecord . ^ list at: index+1 ifAbsent: [ aChangeRecord ]! ! !DiffElement commentStamp: 'HenrikSperreJohansen 5/21/2010 01:41'! My instances are container objects used by TextDiffBuilder for comparison. They hold a string and the precomputed hash of the string to speed up #=. They may reference another DiffElement object which is their pair in the diff. Instance Variables hash: match: string: hash - the hash of string, stored for fast access match - another DiffElement object which has the same string and turned out to be my pair in the longest common subsequence found by a TextDiffBuilder, or nil if I don't a matching DiffElement string - a part of a longer text, typically a line ! !DiffElement methodsFor: 'comparing' stamp: 'HenrikSperreJohansen 5/21/2010 01:50'! hash ^hash! ! !DiffElement methodsFor: 'comparing' stamp: 'HenrikSperreJohansen 5/21/2010 01:50'! = anObject ^anObject class == self class and: [ anObject hash = hash and: [ anObject string = string ] ]! ! !DiffElement methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 5/21/2010 01:51'! match ^match! ! !DiffElement methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 5/21/2010 01:50'! string: aString string := aString. string isOctetString ifTrue: [ "Make sure that #hash will return the same value if the strings are equal." string := string asOctetString ]. hash := string hash! ! !DiffElement methodsFor: 'testing' stamp: 'HenrikSperreJohansen 5/21/2010 01:51'! hasMatch ^match notNil! ! !DiffElement methodsFor: 'printing' stamp: 'HenrikSperreJohansen 5/21/2010 01:51'! printOn: aStream super printOn: aStream. aStream nextPut: $(; print: hash; nextPutAll: ', '; print: string; nextPutAll: ', '; print: (match class == self class); nextPut: $)! ! !DiffElement methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 5/21/2010 01:51'! string ^string! ! !DiffElement methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 5/21/2010 01:51'! matches: aDiffMatch match := aDiffMatch. aDiffMatch match: self! ! !DiffElement methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 5/21/2010 01:51'! match: aDiffMatch match := aDiffMatch ! ! !DiffElement class methodsFor: 'instance creation' stamp: 'HenrikSperreJohansen 5/21/2010 01:49'! string: aString ^self new string: aString; yourself! ! !DiffJoinMorph methodsFor: 'initialize' stamp: 'gvc 10/20/2006 14:21'! defaultColor "Answer the default color for the receiver." ^Color transparent! ! !DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/31/2006 11:33'! dstOffset: anInteger "Set the dstOffset." dstOffset := anInteger. self mappings do: [:j | j dstOffset: anInteger]! ! !DiffJoinMorph methodsFor: 'drawing' stamp: 'gvc 10/31/2006 12:08'! drawOn: aCanvas "Draw the indicators for the mappings." super drawOn: aCanvas. aCanvas translateBy: self topLeft clippingTo: self clippingBounds during: [:c | self mappings do: [:j | j drawOn: c]]! ! !DiffJoinMorph methodsFor: 'geometry' stamp: 'gvc 10/31/2006 13:18'! extent: aPoint "Update the shapes of the joins." super extent: aPoint. self updateMappings! ! !DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/31/2006 11:33'! srcOffset: anInteger "Set the srcOffset." srcOffset := anInteger. self mappings do: [:j | j srcOffset: anInteger]! ! !DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/24/2006 16:02'! dstOffset "Answer the value of dstOffset" ^ dstOffset! ! !DiffJoinMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:18'! updateMappings "Update the shapes of the joins." self mappings do: [:j | j width: self width]! ! !DiffJoinMorph methodsFor: 'initialization' stamp: 'gvc 10/31/2006 11:44'! initialize "Initialize the receiver." super initialize. self mappings: OrderedCollection new; srcOffset: 0@0; dstOffset: 0@0! ! !DiffJoinMorph methodsFor: 'layout' stamp: 'gvc 10/31/2006 13:18'! layoutBounds: aRectangle "Set the bounds for laying out children of the receiver." super layoutBounds: aRectangle. self updateMappings! ! !DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 11:50'! mappings "Answer the value of mappings" ^ mappings! ! !DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/31/2006 13:19'! mappings: anObject "Set the value of mappings" mappings := anObject. self updateMappings. self changed! ! !DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/24/2006 16:02'! srcOffset "Answer the value of srcOffset" ^ srcOffset! ! !DiffJoinMorph methodsFor: 'event handling' stamp: 'GabrielOmarCotelli 11/30/2013 16:23'! mouseDown: evt "Check for a click." self mappings detect: [ :j | j containsPoint: evt position - self topLeft ] ifFound: [ :cj | cj clicked. self triggerEvent: #joinClicked ]. super mouseDown: evt! ! !DiffJoinMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:43'! compositeText "Answer the composite text based on the selection state of the joins." |t| t := Text new. self mappings do: [:j | j appendToCompositeText: t]. ^t! ! !DiffJoinMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 2/3/2010 16:20'! splitterWidth "Answer the width of splitter to use for dif joins." ^30! ! !DiffMapMorph methodsFor: 'initialization' stamp: 'gvc 10/26/2006 14:08'! initialize "Initialize the receiver." super initialize. self mappings: #()! ! !DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 14:10'! defaultColor "Answer the default color for the receiver." ^Color white! ! !DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 3/21/2008 17:14'! extent: newExtent "Update the gradient." super extent: newExtent. (self fillStyle notNil and: [self fillStyle isOrientedFill]) ifTrue: [self fillStyle direction: 0@self height]! ! !DiffMapMorph methodsFor: 'nil' stamp: 'gvc 10/26/2006 15:05'! drawOn: aCanvas "Draw the indicators for the mappings." |b f| b := self innerBounds insetBy: 2. super drawOn: aCanvas. b height < 1 ifTrue: [^self]. f := self mappingsHeight. f < 1 ifTrue: [^self]. f := b height / f. aCanvas clipBy: self clippingBounds during: [:c | self mappings do: [:j | j drawMapOn: c in: b scale: f]]! ! !DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 13:57'! mappings "Answer the value of mappings" ^ mappings! ! !DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 14:15'! mappings: anObject "Set the value of mappings" mappings := anObject. self changed! ! !DiffMapMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 10:51'! mappingsHeight "Answer the maximum y of all the mappings." self mappings ifEmpty: [^0]. ^self mappings last dst range last ! ! !DiffMapMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/10/2010 13:28'! mouseDown: event "Trigger a 0..1 range based on location." |b| b := self innerBounds insetBy: 2. self triggerEvent: #mapClicked with: (((event cursorPoint y asFloat - b top / b height) min: 1) max: 0)! ! !DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 15:12'! gradientRampForColor: c "Answer the background gradient ramp to use." ^{0.0->c darker duller. 0.1-> c lighter. 0.9->c twiceLighter. 1.0->c darker}! ! !DiffMapMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/10/2010 13:30'! handlesMouseDown: anEvent "Answer true to report mouse down activity." ^true! ! !DiffMapMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 15:11'! adoptPaneColor: paneColor "Change our border color too." |c| super adoptPaneColor: paneColor. paneColor ifNil: [^self]. c := paneColor alphaMixed: 0.1 with: Color white. self fillStyle: ((GradientFillStyle ramp: (self gradientRampForColor: c)) origin: self bounds topLeft; direction: 0@ self height). self borderStyle baseColor: paneColor! ! !DiffMethodReferenceConverter commentStamp: 'TorstenBergmann 2/20/2014 13:48'! For diffs! !DiffMethodReferenceConverter methodsFor: 'private' stamp: ''! internalGetText ^TextDiffBuilder buildDisplayPatchFrom: ((self priorVersionOfAMethod: method) sourceCode) to: (method sourceCode) inClass: (method className)! ! !DiffModel commentStamp: ''! I am a Spec widget useful for visualising differences between two strings. When a classContext: is setted, the strings are highlighted using such contextual information. Examples: self exampleWithoutOptions. self exampleWithOptions.! !DiffModel methodsFor: '*Spec-Tools-VersionBrowser' stamp: 'BenjaminVanRyseghem 10/18/2013 14:48'! behavior ^ self contextClass! ! !DiffModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 22:29'! showBoth showOnlySource rawValue: false. showOnlyDestination rawValue: false. self changed: #showBoth with: { }! ! !DiffModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 22:33'! showOnlyDestination: aBoolean showOnlyDestination rawValue: false. showOnlyDestination value: aBoolean.! ! !DiffModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! rightText: anObject rightTextHolder value: anObject ! ! !DiffModel methodsFor: '*Spec-Tools-VersionBrowser' stamp: 'BenjaminVanRyseghem 10/18/2013 14:21'! getText ^ self rightText! ! !DiffModel methodsFor: '*Spec-Tools-VersionBrowser' stamp: 'BenjaminVanRyseghem 10/18/2013 14:24'! doItReceiver: aReceiver! ! !DiffModel methodsFor: '*Spec-Tools-VersionBrowser' stamp: 'BenjaminVanRyseghem 10/18/2013 14:23'! aboutToStyle: aBoolean! ! !DiffModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! showOptions: aBoolean showOptions value: aBoolean! ! !DiffModel methodsFor: '*Spec-Tools-VersionBrowser' stamp: 'BenjaminVanRyseghem 10/18/2013 14:27'! text: aPairOfString (aPairOfString isText or: [aPairOfString isString]) ifTrue: [ self leftText: ''. self rightText: aPairOfString ] ifFalse: [ self leftText: aPairOfString first. self rightText: aPairOfString second ]! ! !DiffModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! leftText ^ leftTextHolder value! ! !DiffModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! rightText ^ rightTextHolder value! ! !DiffModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. leftTextHolder := '' asReactiveVariable. rightTextHolder := '' asReactiveVariable. contextClassHolder := nil asReactiveVariable. showOptions := true asReactiveVariable. showOnlyDestination := false asReactiveVariable. showOnlySource := false asReactiveVariable. leftTextHolder whenChangedDo: [ :newText | self changed: #leftText: with: { newText } ]. rightTextHolder whenChangedDo: [ :newText | self changed: #rightText: with: { newText } ]. contextClassHolder whenChangedDo: [ :newClass | self changed: #contextClass: with: { newClass } ]. showOptions whenChangedDo: [ :aBoolean | self changed: #showOptions: with: { aBoolean }]. showOnlyDestination whenChangedDo: [:aBoolean | self changed: #showOnlyDestination: with: { aBoolean } ]. showOnlySource whenChangedDo: [:aBoolean | self changed: #showOnlySource: with: { aBoolean } ]! ! !DiffModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! contextClass: anObject contextClassHolder value: anObject ! ! !DiffModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 17:15'! showOnlyDestination ^ showOnlyDestination value! ! !DiffModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 22:11'! showOnlySource ^ showOnlySource value! ! !DiffModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 22:32'! showOnlySource: aBoolean showOnlyDestination rawValue: false. showOnlySource value: aBoolean! ! !DiffModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! leftText: anObject leftTextHolder value: anObject ! ! !DiffModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! contextClass ^ contextClassHolder value! ! !DiffModel methodsFor: '*Spec-Tools-VersionBrowser' stamp: 'BenjaminVanRyseghem 10/18/2013 14:23'! behavior: aClass self contextClass: aClass! ! !DiffModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! showOptions ^ showOptions value! ! !DiffModel class methodsFor: 'example' stamp: 'MartinDias 9/12/2013 17:38'! exampleWithOptions " self exampleWithOptions " ^ self new showOptions: true; leftText: (True >> #and:) sourceCode; rightText: (True >> #or:) sourceCode; contextClass: True; openWithSpec! ! !DiffModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/21/2013 18:17'! defaultSpec ^ #(MorphicDiffAdapter adapt: #(model))! ! !DiffModel class methodsFor: 'example' stamp: 'MartinDias 9/10/2013 22:59'! exampleWithoutOptions " self exampleWithoutOptions " ^ self new showOptions: false; leftText: 'Old text'; rightText: 'New text'; openWithSpec ! ! !DiffModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:20'! adapterName ^ #DiffAdapter! ! !DiffMorph commentStamp: ''! I am a morph useful for visualising differences between two strings. When a classContext: is setted, the strings are highlighted using such contextual information.! !DiffMorph methodsFor: 'initialization' stamp: 'MartinDias 9/12/2013 17:20'! addMorphsWithOptions self addMainMorphsWith: optionsPanel height. self addMorph: optionsPanel fullFrame: (LayoutFrame identity bottomFraction: 0; bottomOffset: optionsPanel height)! ! !DiffMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 12/1/2008 12:27'! themeChanged "Update the scrollbar width/frame." |offset| super themeChanged. self scrollbarMorph width: self theme scrollbarThickness. offset := self scrollbarMorph width negated - self mapMorph width. self scrollbarMorph layoutFrame leftOffset: offset. self dstMorph layoutFrame rightOffset: offset! ! !DiffMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:29'! showBoth showOnlyDestination ifTrue: [ showOnlyDestination := false ]. showOnlySource ifTrue: [ showOnlySource := false ]. self updateMorphs! ! !DiffMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:34'! showOnlyDestination: aBoolean showOnlyDestination = aBoolean ifTrue: [ ^ self ]. self showOnlySource: false. showOnlyDestination := aBoolean. self updateMorphs! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'gvc 11/1/2006 11:07'! newMatchJoinSectionFrom: srcRange to: dstRange "Answer a new match join section." |spl dpl sy1 sy2 dy1 dy2 c| spl := self srcMorph textMorph paragraph lines. dpl := self dstMorph textMorph paragraph lines. sy1 := (spl at: srcRange first) top truncated. sy2 := (spl at: srcRange last) bottom truncated. dy1 := (dpl at: dstRange first) top truncated. dy2 := (dpl at: dstRange last) bottom truncated. c := self colorForType: #match. ^self newJoinSection type: #match; borderWidth: 0; srcColor: c; dstColor: c; srcLineRange: srcRange; dstLineRange: dstRange; srcRange: (sy1 to: sy2); dstRange: (dy1 to: dy2); createHighlightsFrom: self srcMorph textMorph paragraph to: self dstMorph textMorph paragraph! ! !DiffMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/21/2013 22:25'! addMainMorphsWith: topOffset | halfWidth leftFraction leftOffset rightFraction rightOffset | halfWidth := self joinMorph width / 2. leftFraction := showOnlyDestination ifTrue: [ 0 ] ifFalse: [ 0.5 ]. leftOffset := showOnlyDestination ifTrue: [ 0 ] ifFalse: [ halfWidth ]. rightFraction := showOnlySource ifTrue: [ 1 ] ifFalse: [ 0.5 ]. rightOffset := showOnlySource ifTrue: [ 0 ] ifFalse: [ halfWidth negated ]. showOnlyDestination ifFalse: [ self addMorph: self srcMorph fullFrame: (LayoutFrame identity rightFraction: rightFraction; topOffset: topOffset; rightOffset: rightOffset). showOnlySource ifFalse: [ self addMorph: self joinMorph fullFrame: (LayoutFrame identity leftFraction: 0.5; rightFraction: 0.5; leftOffset: halfWidth negated; rightOffset: halfWidth; topOffset: topOffset). ] ]. showOnlySource ifFalse: [ self addMorph: self dstMorph fullFrame: (LayoutFrame identity leftFraction: leftFraction; topOffset: topOffset; leftOffset: leftOffset; rightOffset: (self scrollbarMorph width + self mapMorph width) negated) ]. self addMorph: self scrollbarMorph fullFrame: (LayoutFrame identity leftFraction: 1; leftOffset: self scrollbarMorph width negated - self mapMorph width; rightOffset: self mapMorph width negated; topOffset: topOffset). self addMorph: self mapMorph fullFrame: (LayoutFrame identity leftFraction: 1; leftOffset: self mapMorph width negated; topOffset: topOffset).! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'gvc 2/10/2010 13:31'! newMapMorph "Answer a new map morph." ^(DiffMapMorph new hResizing: #shrinkWrap; vResizing: #spaceFill; extent: 20@4; minWidth: 20; borderStyle: (BorderStyle inset width: 1)) when: #mapClicked send: #mapClicked: to: self! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 16:09'! updateJoinOffsets "Update the src and dst offsets in the join morph to match the src and dst tex scroll offsets." self joinMorph srcOffset: 0 @ self srcMorph scroller offset y negated; dstOffset: 0 @ self dstMorph scroller offset y negated; changed! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 12:34'! removalColor "Answer the color used to show removals." ^Color paleRed alpha: 0.5! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/23/2006 15:47'! scrollbarMorph: anObject "Set the value of scrollbarMorph" scrollbarMorph := anObject! ! !DiffMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 17:04'! removeOptionsPanel showOptions := false. self removeAllMorphs. self addMorphsWithoutOptions! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/31/2006 13:23'! font: aFont "Set the font on the src and dst morphs." self srcMorph font: aFont. self dstMorph font: aFont! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 14:29'! colorForType: type "Anwser the color to use for the given change type." ^{self matchColor. self additionColor. self removalColor. self modificationColor} at: (#(match addition removal modification) indexOf: type)! ! !DiffMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/21/2013 22:23'! initialize "Initialize the receiver." | exv exh ppCheckbox | super initialize. showOnlyDestination := false. showOnlySource := false. showOptions := true. self prettyPrint: CodeHolder diffsWithPrettyPrint. ppCheckbox := self newPrettyPrintCheckboxMorph. optionsPanel := self newPanel addMorph: ((self newRow: {ppCheckbox}) listCentering: #bottomRight); color: self defaultColor. optionsPanel vResizing: #shrinkWrap. optionsPanel extent: optionsPanel minExtent. self srcMorph: self newSrcMorph; joinMorph: self newJoinMorph; dstMorph: self newDstMorph; scrollbarMorph: self newScrollbarMorph; mapMorph: self newMapMorph; changeProportionalLayout. self addMorphsWithOptions. exv := ExclusiveWeakMessageSend newSharedState. exh := ExclusiveWeakMessageSend newSharedState. self srcMorph when: #vScroll send: #srcScroll: to: self exclusive: exv; when: #hScroll send: #hScrollValue: to: self dstMorph exclusive: exh. self dstMorph when: #vScroll send: #dstScroll: to: self exclusive: exv; when: #hScroll send: #hScrollValue: to: self srcMorph exclusive: exh. self linkSubmorphsToSplitters; extent: self initialExtent.! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 10:52'! applyHighlights "Apply the relevant highlights to src and dst." self srcMorph highlights: (self joinMappings gather: [:j | j src highlights]). self dstMorph highlights: (self joinMappings gather: [:j | j dst highlights])! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'gvc 9/2/2008 15:56'! newPrettyPrintCheckboxMorph "Answer a new checkbox for specifying whether to use pretty printing for the diff texts." ^self newCheckboxFor: self getSelected: #prettyPrint setSelected: #prettyPrint: getEnabled: nil label: 'Pretty print' translated help: 'If selected, pretty print will be applied to any displayed method source (eliminates trivial formatting changes)' translated! ! !DiffMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 11/22/2013 10:32'! update: aSymbol with: aValue aSymbol == #showOnlyDestination ifTrue: [ ^ self showOnlyDestination: aValue ]. aSymbol == #showOptions ifTrue: [ ^ self showOptions: aValue ]. ^ super update: aSymbol with: aValue! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/20/2006 11:26'! oldText "Answer the old (src) text." ^self srcMorph text! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/21/2009 23:12'! textSelectionColor "Answer the color used for thew text selection." ^self theme settings selectionColor alpha: 0.5! ! !DiffMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 17:06'! updateMorphs self removeAllMorphs. showOptions ifTrue: [ self addMorphsWithOptions ] ifFalse: [ self addMorphsWithoutOptions ]! ! !DiffMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:35'! showOnlySource: aBoolean showOnlySource = aBoolean ifTrue: [ ^ self ]. self showOnlyDestination: false. showOnlySource := aBoolean. self updateMorphs! ! !DiffMorph methodsFor: 'initialization' stamp: 'MartinDias 9/12/2013 17:20'! addMorphsWithoutOptions self addMainMorphsWith: 0! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:38'! contextClass "Answer the value of contextClass" ^ contextClass! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! dstMorph: anObject "Set the value of dstMorph" dstMorph := anObject! ! !DiffMorph methodsFor: '*Shout-Styling' stamp: 'AlainPlantec 8/28/2011 13:44'! shoutAboutToStyle: aPluggableShoutMorphOrView aPluggableShoutMorphOrView classOrMetaClass: self contextClass. ^ self contextClass notNil ! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 11:27'! difference: anObject "Set the value of difference" difference := anObject! ! !DiffMorph methodsFor: 'actions' stamp: 'gvc 11/1/2006 14:12'! joinSectionClass "Answer the class to use for a new join section." ^JoinSection! ! !DiffMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 17:04'! addOptionsPanel showOptions := true. self removeAllMorphs. self addMorphsWithOptions! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'AlainPlantec 8/28/2011 12:42'! newSrcMorph "Answer a new src text morph." ^(self newTextEditorFor: self getText: nil setText: nil getEnabled: nil) hideVScrollBarIndefinitely: true; borderWidth: 0; enabled: false; wrapFlag: false; selectionColor: self textSelectionColor; setText: ''! ! !DiffMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 17:01'! on: aModel aModel addDependent: self! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 14:29'! matchColor "Answer the color used to show matches." ^Color transparent! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! dstText "Answer the value of dstText" ^ dstText! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! srcMorph "Answer the value of srcMorph" ^ srcMorph! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 14:11'! applyMap "Apply the join mappings to the map morph." self mapMorph mappings: self joinMappings! ! !DiffMorph methodsFor: 'private' stamp: 'MartinDias 9/9/2013 15:09'! setOptionsPanel: aBoolean "This is a private method. The implementation is based on the fact the options are set by default" aBoolean ifFalse: [ self removeOptionsPanel ]! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:38'! contextClass: anObject "Set the value of contextClass" contextClass := anObject! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 12:35'! edgeColor "Answer the color used to show the border of the changes." ^Color gray alpha: 0.5! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/24/2006 15:55'! joinMappings "Answer the join parameters between src and dst." ^joinMappings ifNil: [self calculateJoinMappings]! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 8/28/2013 10:31'! setText "Set the src and dst text in the morphs applying prettyPrint if required." |src dst ctx| src := self srcText. dst := self dstText. ctx := self contextClass. (self prettyPrint and: [ctx notNil]) ifTrue: [src isEmpty ifFalse: [ src := ctx compiler source: src; class: ctx; format]. dst isEmpty ifFalse: [ dst := ctx compiler source: dst; class: ctx; format]]. self srcMorph setText: src; font: self theme textFont. self dstMorph setText: dst; font: self theme textFont! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! mapMorph: anObject "Set the value of mapMorph" mapMorph := anObject! ! !DiffMorph methodsFor: 'adding' stamp: 'gvc 10/24/2006 12:34'! additionColor "Answer the color used to show additions." ^Color paleGreen alpha: 0.5! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/20/2006 13:11'! calculateDifference "Calculate the difference of the src and dst." self difference: ((TextDiffBuilder from: self oldText asString to: self newText asString) buildPatchSequence)! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'gvc 10/20/2006 11:26'! newText "Answer the new (dst) text." ^self dstMorph text! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/23/2006 15:47'! scrollbarMorph "Answer the value of scrollbarMorph" ^ scrollbarMorph! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! srcText "Answer the value of srcText" ^ srcText! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! dstMorph "Answer the value of dstMorph" ^ dstMorph! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'gvc 10/31/2006 14:08'! newJoinSectionFrom: srcRange to: dstRange "Answer a new join section." |spl dpl sy1 sy2 dy1 dy2 t c| spl := self srcMorph textMorph paragraph lines. dpl := self dstMorph textMorph paragraph lines. t := #modification. sy1 := srcRange first > spl size ifTrue: [t := #addition. spl last bottom truncated - 1] ifFalse: [(spl at: srcRange first) top truncated - 1]. sy2 := srcRange size < 1 ifTrue: [t := #addition. sy1 + 3] ifFalse: [srcRange last > spl size ifTrue: [spl last bottom truncated + 3] ifFalse: [(spl at: srcRange last) bottom truncated - 1]]. dy1 := dstRange first > dpl size ifTrue: [t := #removal. dpl last bottom truncated - 1] ifFalse: [(dpl at: dstRange first) top truncated - 1]. dy2 := dstRange size < 1 ifTrue: [t := #removal. dy1 + 3] ifFalse: [dstRange last > dpl size ifTrue: [dpl last bottom truncated + 3] ifFalse: [(dpl at: dstRange last) bottom truncated - 1]]. c := self colorForType: t. ^self newJoinSection type: t; srcColor: c; dstColor: c; srcLineRange: srcRange; dstLineRange: dstRange; srcRange: (sy1 to: sy2); dstRange: (dy1 to: dy2); createHighlightsFrom: self srcMorph textMorph paragraph to: self dstMorph textMorph paragraph! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'BenjaminVanRyseghem 11/25/2012 04:07'! newHighlight "Anewser a new highlight." ^TextHighlightByBounds new color: self modificationColor; borderWidth: 1; borderColor: self edgeColor! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 15:56'! calculateJoinMappings "Calculate the join parameters between src and dst and store in joinMappings." self joinMappings: self calculatedJoinMappings! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! mapMorph "Answer the value of mapMorph" ^ mapMorph! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! joinMorph "Answer the value of joinMorph" ^ joinMorph! ! !DiffMorph methodsFor: 'instance creation' stamp: 'gvc 9/2/2008 15:24'! from: old to: new "Set the old (src) and new (dst) text." self srcText: old; dstText: new. self setText; calculateDifference; calculateJoinMappings; calibrateScrollbar; applyHighlights; applyJoin; applyMap! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:23'! adoptPaneColor: paneColor "Change our border color too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self borderStyle baseColor: paneColor! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/23/2006 16:12'! hideOrShowScrollBar "Do nothing" ! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:22'! dstScroll: scrollValue "Called from dst when scrolled by keyboard etc." self scrollbarMorph value: scrollValue. self srcMorph vScrollBarValue: scrollValue. self updateJoinOffsets! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 12:34'! modificationColor "Answer the color used to show changes." ^Color paleYellow alpha: 0.5! ! !DiffMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:18'! showOnlySource ^ showOnlySource! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'gvc 11/1/2006 14:11'! newJoinSection "Answer a new join section." ^self joinSectionClass new srcColor: self modificationColor; dstColor: self modificationColor; borderWidth: 1; borderColor: self edgeColor; addDependent: self; yourself! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'BenjaminVanRyseghem 11/25/2012 04:09'! newHighlight: type "Anewser a new highlight." ^TextHighlightByBounds new color: (self colorForType: type); borderWidth: 1; borderColor: self edgeColor; fillWidth: true! ! !DiffMorph methodsFor: 'actions' stamp: 'gvc 9/2/2008 15:45'! from: old to: new contextClass: aClass "Set the old (src) and new (dst) text." self contextClass: aClass; srcText: old; dstText: new. self setText; calculateDifference; calculateJoinMappings; calibrateScrollbar; applyHighlights; applyJoin; applyMap! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! prettyPrint "Answer the value of prettyPrint" ^ prettyPrint! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! dstText: anObject "Set the value of dstText" dstText := anObject! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'gvc 12/1/2008 11:48'! newScrollbarMorph "Answer a new scrollbar morph." ^ScrollBar new model: self; setValueSelector: #vScroll:; vResizing: #spaceFill; width: self theme scrollbarThickness! ! !DiffMorph methodsFor: 'user interface' stamp: 'gvc 3/5/2010 12:43'! initialExtent "Answer the initial extent for the receiver." ^RealEstateAgent standardWindowExtent! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 12:08'! joinColor "Answer the color used for the join bar." ^Color paleBlue duller! ! !DiffMorph methodsFor: 'geometry' stamp: 'gvc 10/23/2006 16:27'! extent: newExtent "Update the scrollbar." super extent: newExtent. self calibrateScrollbar! ! !DiffMorph methodsFor: 'updating' stamp: 'MartinDias 9/9/2013 15:07'! update: aSymbol aSymbol == #addOptions ifTrue: [ ^ self addOptionsPanel ]. aSymbol == #removeOptions ifTrue: [ ^ self removeOptionsPanel ]. ^ super update: aSymbol! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 17:55'! join: aJoin selected: aBoolean "Set the selection for the given join and update the src dst and join morphs." aJoin selected: aBoolean. self srcMorph changed. self joinMorph changed. self dstMorph changed! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! srcMorph: anObject "Set the value of srcMorph" srcMorph := anObject! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'gvc 2/3/2010 16:22'! newJoinMorph "Answer a new join morph." |w| w := DiffJoinMorph splitterWidth. ^DiffJoinMorph new hResizing: #shrinkWrap; vResizing: #spaceFill; extent: w@4; minWidth: w; color: self joinColor! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/24/2006 11:11'! applyJoin "Apply the join mappings to the join morph." self joinMorph mappings: self joinMappings! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:42'! joinMappings: aCollection "Set the join parameters between src and dst." joinMappings := aCollection! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:22'! srcScroll: scrollValue "Called from src when scrolled by keyboard etc.." self scrollbarMorph value: scrollValue. self dstMorph vScrollBarValue: scrollValue. self updateJoinOffsets! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 11:04'! defaultTitle "Answer the default title label for the receiver." ^'Diff' translated! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 11:27'! difference "Answer the value of difference" ^ difference! ! !DiffMorph methodsFor: 'instance-creation' stamp: 'gvc 10/26/2006 13:52'! newDstMorph "Answer a new dst text morph." ^self newSrcMorph! ! !DiffMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 17:10'! showOptions ^ showOptions! ! !DiffMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 17:10'! showOptions: aBoolean showOptions = aBoolean ifTrue: [ ^ self ]. showOptions := aBoolean. aBoolean ifTrue: [ self addOptionsPanel ] ifFalse: [ self removeOptionsPanel ]! ! !DiffMorph methodsFor: 'update' stamp: 'gvc 9/2/2008 15:23'! updateText "Reset the text if we have some." (self srcText notNil and: [self dstText notNil]) ifTrue: [ self from: self srcText to: self dstText]! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! srcText: anObject "Set the value of srcText" srcText := anObject! ! !DiffMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 17:02'! showOnlyDestination ^ showOnlyDestination! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/10/2010 13:33'! mapClicked: aFloat "Update the scrollbar value to match a click in the map." self scrollbarMorph setValue: aFloat! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:22'! vScroll: scrollValue "Called from standalone scroolbar. Scroll the srcMorph and redo the join." self srcMorph vScrollBarValue: scrollValue. self dstMorph vScrollBarValue: scrollValue. self updateJoinOffsets! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:22'! prettyPrint: aBoolean "Set the value of prettyPrint" prettyPrint == aBoolean ifTrue: [^self]. prettyPrint := aBoolean. self updateText ! ! !DiffMorph methodsFor: 'actions' stamp: 'gvc 10/31/2006 11:51'! calculatedJoinMappings "Calculate the join parameters between src and dst and answer. sl = src line, dl = dst line, j = joins, ds = dst run start, ss = src run start de = dst run end, se = dst run end, mds = match dst start, mss = match src start" |sl dl j ds ss de se mds mss| sl := dl := 0. j := OrderedCollection new. ds := de:= ss := se := mss := mds := 0. self difference do: [:p | p key = #match ifTrue: [ sl := sl + 1. dl := dl + 1. mss = 0 ifTrue: [mss := sl. mds := dl]. (ds > 0 or: [ss > 0]) ifTrue: [ ss = 0 ifTrue: [ss := sl]. ds = 0 ifTrue: [ds := dl]. se = 0 ifTrue: [se := ss - 1]. de = 0 ifTrue: [de := ds - 1]. j add: (self newJoinSectionFrom: (ss to: se) to: (ds to: de)). ds := de := ss := se := 0]]. p key = #remove ifTrue: [ mss > 0 ifTrue: [ j add: (self newMatchJoinSectionFrom: (mss to: sl) to: (mds to: dl)). mss := mds := 0]. sl := sl + 1. ss = 0 ifTrue: [ss := sl]. se := sl]. p key = #insert ifTrue: [ mss > 0 ifTrue: [ j add: (self newMatchJoinSectionFrom: (mss to: sl) to: (mds to: dl)). mss := mds := 0]. dl := dl + 1. ss > 0 ifTrue: [ se = 0 ifTrue: [se := ss]. de = 0 ifTrue: [de := ds]. j add: (self newJoinSectionFrom: (ss to: se) to: (ds to: de)). ds := de := ss := se := 0]. ds = 0 ifTrue: [ds := dl]. de := dl]]. sl := sl + 1. dl := dl + 1. (ds > 0 or: [ss > 0]) ifTrue: [ ss = 0 ifTrue: [ss := sl ]. ds = 0 ifTrue: [ds := dl]. se = 0 ifTrue: [se := ss - 1]. de = 0 ifTrue: [de := ds - 1]. j add: (self newJoinSectionFrom: (ss to: se) to: (ds to: de))]. mss > 0 ifTrue: [ j add: (self newMatchJoinSectionFrom: (mss to: sl - 1) to: (mds to: dl - 1))]. ^j! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! joinMorph: anObject "Set the value of joinMorph" joinMorph := anObject! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/23/2006 16:29'! calibrateScrollbar "Set the scrollbar parameters to match the texts." |maxY range delta innerH| self fullBounds. maxY := self srcMorph textExtent y max: self dstMorph textExtent y. innerH := self dstMorph innerBounds height. delta := self dstMorph textMorph defaultLineHeight. range := maxY - innerH max: 0. range = 0 ifTrue: [^self scrollbarMorph scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0; setValue: 0.0]. self scrollbarMorph scrollDelta: (delta / range) asFloat pageDelta: ((innerH - delta) / range) asFloat; interval: (innerH / maxY) asFloat; setValue: ((self srcMorph scroller offset y max: self dstMorph scroller offset y) / range min: 1.0) asFloat! ! !DiffMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2008 15:46'! from: old to: new contextClass: aClass "Answer a new instance of the receiver with the given old and new text." ^self new from: old to: new contextClass: aClass! ! !DiffMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 10/20/2006 11:26'! from: old to: new "Answer a new instance of the receiver with the given old and new text." ^self new from: old to: new! ! !DiffMorphChangeRecordConverter commentStamp: 'NicolaiHess 1/19/2014 23:41'! A DiffMorphChangeRecordConverter is a converter used to show the diff between two methodreferences with a side by side view.! !DiffMorphChangeRecordConverter methodsFor: 'private' stamp: 'NicolaiHess 1/21/2014 09:29'! priorVersionOfAMethod: aChangeRecord | index | index := referencesList identityIndexOf: aChangeRecord . ^ referencesList at: index+1 ifAbsent: [ nil ]! ! !DiffMorphChangeRecordConverter methodsFor: 'private' stamp: 'NicolaiHess 1/21/2014 09:30'! internalGetText | priorSource | priorSource := (self priorVersionOfAMethod: method) ifNotNil: [ :m | m sourceCode ] ifNil: [ '' ]. ^ Array with: priorSource with: method sourceCode! ! !DifferatorSystemSettings commentStamp: 'HenrikSperreJohansen 5/21/2010 02:43'! My settings allow the user to choose whether different line endings will be shown in diffs, and the colors/emphasis used for added/removed text! !DifferatorSystemSettings class methodsFor: 'settings' stamp: 'HenrikSperreJohansen 5/21/2010 02:42'! differatorSettingsOn: aBuilder (aBuilder group: #differator) label: 'Differator' translated; parent: #codeBrowsing; description: 'All settings concerned with the differator' translated; with: [ (aBuilder setting: #ignoreLineEndings) label: 'Ignore line endings' translated; target: TextDiffBuilder; description: 'When selected, line ending differences will be ignored ' translated. "Don't quite know how to build these... Should be able to choose emphasis and highlight-color" "(aBuilder setting: #insertedTextAttributes) label: 'Inserted text' translated; target: TextDiffBuilder; description: 'Select how inserted text will be displayed' translated. (aBuilder setting: #removedTextAttributes) label: 'Removed text' translated; target: TextDiffBuilder; description: 'Select how removed text will be displayed' translated." ] ! ! !DigitalSignatureAlgorithm commentStamp: ''! This class implements the Digital Signature Algorithm (DSA) of the U.S. government's "Digital Signature Standard" (DSS). The DSA algorithm was proposed in 1991 and became a standard in May 1994. The official description is available as a Federal Information Processing Standards Publication (FIPS PUB 186, May 19, 1994). A companion standard, the Secure Hash Standard, or SHS (FIPS PUB 180-1, April 17, 1995), describes a 160-bit message digest algorithm known as the Secure Hash Algorithm (SHA). This message digest is used to compute the document signature. Here's how to use it: 1. The "signer" creates a pair of keys. One of these must be kept private. The other may be freely distributed. For example, it could be built into the signature checking code of an application. 2. When the signer wishes to sign a packet of data (a "message") , he uses the secure hash algorithm to create a 160-bit message digest (hash) which is used as the input to DSA. The result of this is a pair of large numbers called a "signature" that is attached to the original message. 3. When someone receives a signed message purported to have come from the signer, they compute the 160-bit hash of the message and pass that, along with the message signature and the signer's public key, to the signature verification algorithm. If the signature checks, then it is virtually guaranteed that the message originated from someone who had the signer's private key. That is, the message is not a forgery and has not been modified since it was signed. For example, if the message contains a program, and the recipient trusts the signer, then the recipient can run the program with the assurance that it won't do anything harmful. (At least, not intentionally. A digital signature is no guarantee against bugs!! :->) The signer must keep the private key secure, since anyone who has the private key can forge the signer's signature on any message they like. As long as the secret key is not stolen, cryptographers believe it to be virtually impossible either to forge a signature, to find a message that matches an existing sigature, or to discover the signer's private key by analyzing message signatures. Knowing the public key (which, for example, could be recovered from an application that had it built in), does not weaken the security at all. An excellent reference work on digital signatures and cryptography in general is: Schneier, Bruce "Applied Cryptography: Protocols, Algorithms, and Source Code in C" John Wiley and Sons, 1996. I used this book as a guide to implementing many of the numerical algorithms required by DSA. Patents and Export Restrictions: Many digital signature technologies are patented. DSA is also patented, but the patent is owned by the U.S. government which has made DSA available royalty-free. There is a claim that the government patent infringes on an earlier patent by Schnorr, but the government is requiring the use of DSA, so they apparently believe this claim is not strong enough to be a serious threat to their own patent. Most cryptography technology, including digital signature technology, requires an export license for it to be distributed outside the U.S. Recent legislation may have relaxed the export license requirements, but it would be prudent to check the current regulations before exporting this code.! !DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'nice 9/2/2010 21:48'! computeSignatureForMessageHash: hash privateKey: privateKey "Answer the digital signature of the given message hash using the given private key. A signature is a pair of large integers. The private key is an array of four large integers: (p, q, g, x)." | p q g x r s k tmp | p := privateKey first. q := privateKey second. g := privateKey third. x := privateKey fourth. r := s := 0. [r = 0 or: [s = 0]] whileTrue: [ k := self nextRandom160 \\ q. r := (g raisedTo: k modulo: p) \\ q. tmp := (hash + (x * r)) \\ q. s := ((k reciprocalModulo: q) * tmp) \\ q]. ^ Array with: r with: s ! ! !DigitalSignatureAlgorithm methodsFor: 'large integer arithmetic' stamp: 'GabrielOmarCotelli 12/3/2013 17:14'! isProbablyPrime: p "Answer true if p is prime with very high probability. Such a number is sometimes called an 'industrial grade prime'--a large number that is so extremely likely to be prime that it can assumed that it actually is prime for all practical purposes. This implementation uses the Rabin-Miller algorithm (Schneier, p. 159)." | iterations pMinusOne b m r a j z couldBePrime | iterations := 50. "Note: The DSA spec requires >50 iterations; Schneier says 5 are enough (p. 260)" "quick elimination: check for p divisible by a small prime" SmallPrimes ifNil: [ "generate list of small primes > 2" SmallPrimes := Integer primesUpTo: 2000. SmallPrimes := SmallPrimes copyFrom: 2 to: SmallPrimes size ]. SmallPrimes detect: [ :f | p \\ f = 0 ] ifFound: [ :factor | ^ p = factor ]. pMinusOne := p - 1. b := self logOfLargestPowerOfTwoDividing: pMinusOne. m := pMinusOne bitShift: b negated. "Assert: pMinusOne = m * (2 raisedTo: b) and m is odd" Transcript show: ' Prime test pass '. r := Random new. 1 to: iterations do: [ :i | Transcript show: i printString; space. a := (r next * 16rFFFFFF) truncated. j := 0. z := (a raisedTo: m modulo: p) normalize. couldBePrime := z = 1. [ couldBePrime ] whileFalse: [ z = 1 ifTrue: [ Transcript show: 'failed!!'; cr. ^ false ]. "not prime" z = pMinusOne ifTrue: [ couldBePrime := true ] ifFalse: [ (j := j + 1) < b ifTrue: [ z := z * z \\ p ] ifFalse: [ Transcript show: 'failed!!'; cr. ^ false ] ] ] ]. "not prime" Transcript show: 'passed!!'; cr. ^ true "passed all tests; probably prime"! ! !DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'jm 1/11/2000 00:25'! initRandom: randomInteger "Initialize the the secure random number generator with the given value. The argument should be a positive integer of up to 512 bits chosen randomly to avoid someone being able to predict the sequence of random values generated." "Note: The random generator must be initialized before generating a key set or signature. Signature verification does not require initialization of the random generator." randSeed := 16rEFCDAB8998BADCFE10325476C3D2E1F067452301. "initial seed" randKey := randomInteger. Transcript show: 'Random seed: ', randomInteger printString; cr. ! ! !DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'adrian-lienhard 5/18/2009 21:08'! generateKeySet "Generate and answer a key set for DSA. The result is a pair (). Each key is an array of four large integers. The private key is (p, q, g, x); the public one is (p, q, g, y). The signer must be sure to record (p, q, g, x), and must keep x secret to prevent someone from forging their signature." "Note: Key generation can take some time. Open a transcript so you can see what's happening and take a coffee break!!" | qAndPandS q p exp g h x y | qAndPandS := self generateQandP. Transcript show: 'Computing g...'. q := qAndPandS first. p := qAndPandS second. exp := (p - 1) / q. h := 2. [g := h raisedTo: exp modulo: p. g = 1] whileTrue: [h := h + 1]. Transcript show: 'done.'; cr. Transcript show: 'Computing x and y...'. x := self nextRandom160. y := g raisedTo: x modulo: p. Transcript show: 'done.'; cr. Transcript show: 'Key generation complete!!'; cr. ^ Array with: (Array with: p with: q with: g with: x) with: (Array with: p with: q with: g with: y). ! ! !DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'PeterHugossonMiller 9/3/2009 01:13'! signatureToString: aSignature "Answer a string representation of the given signature. This string can be parsed using the stringToSignature: method." | s | s := (String new: 2000) writeStream. s nextPutAll: '[DSA digital signature '. s nextPutAll: aSignature first printStringHex. s space. s nextPutAll: aSignature second printStringHex. s nextPutAll: ']'. ^ s contents ! ! !DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'nice 9/2/2010 21:48'! verifySignature: aSignature ofMessageHash: hash publicKey: publicKey "Answer true if the given signature is the authentic signature of the given message hash. That is, if the signature must have been computed using the private key set corresponding to the given public key. The public key is an array of four large integers: (p, q, g, y)." | p q g y r s w u1 u2 v0 v | p := publicKey first. q := publicKey second. g := publicKey third. y := publicKey fourth. r := aSignature first. s := aSignature last. ((r > 0) and: [r < q]) ifFalse: [^ false]. "reject" ((s > 0) and: [s < q]) ifFalse: [^ false]. "reject" w := s reciprocalModulo: q. u1 := (hash * w) \\ q. u2 := (r * w) \\ q. v0 := (g raisedTo: u1 modulo: p) * (y raisedTo: u2 modulo: p). v := ( v0 \\ p) \\ q. ^ v = r ! ! !DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'ClementBera 7/26/2013 16:38'! initRandomFromUser "Ask the user to type a long random string and use the result to seed the secure random number generator." | s | s := UIManager default request: 'Enter a long random string to seed the random generator.'. s ifNil: [s := '']. ^self initRandomFromString: s! ! !DigitalSignatureAlgorithm methodsFor: 'large integer arithmetic' stamp: 'nice 8/28/2010 21:16'! inverseOf: x mod: n "Answer the inverse of x modulus n. That is, the integer y such that (x * y) \\ n is 1. Both x and n must be positive, and it is assumed that x < n and that x and n are integers." "Details: Use the extended Euclidean algorithm, Schneier, p. 247." | v u u1 u2 u3 t1 t2 t3 tmp | ((x <= 0) or: [n <= 0]) ifTrue: [self error: 'x and n must be greater than zero']. x >= n ifTrue: [self error: 'x must be < n']. v := x. u := n. (x even and: [n even]) ifTrue: [self error: 'no inverse']. u1 := 1. u2 := 0. u3 := u. t1 := v. t2 := u - 1. t3 := v. [ [u3 even ifTrue: [ ((u1 odd) or: [u2 odd]) ifTrue: [ u1 := u1 + v. u2 := u2 + u]. u1 := u1 bitShift: -1. u2 := u2 bitShift: -1. u3 := u3 bitShift: -1]. ((t3 even) or: [u3 < t3]) ifTrue: [ tmp := u1. u1 := t1. t1 := tmp. tmp := u2. u2 := t2. t2 := tmp. tmp := u3. u3 := t3. t3 := tmp]. u3 even and: [u3 > 0]] whileTrue: ["loop while u3 is even"]. [((u1 < t1) or: [u2 < t2]) and: [u1 > 0]] whileTrue: [ u1 := u1 + v. u2 := u2 + u]. u1 := u1 - t1. u2 := u2 - t2. u3 := u3 - t3. t3 > 0] whileTrue: ["loop while t3 > 0"]. [u1 >= v and: [u2 >= u]] whileTrue: [ u1 := u1 - v. u2 := u2 - u]. u3 = 1 ifFalse: [self error: 'no inverse']. ^ u - u2 ! ! !DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'raa 5/30/2000 15:47'! generateQandP "Generate the two industrial-grade primes, q (160-bits) and p (512-bit) needed to build a key set. Answer the array (q, p, s), where s is the seed that from which q and p were created. This seed is normally discarded, but can be used to verify the key generation process if desired." | pBits halfTwoToTheP chunkCount sAndq q twoQ n c w x p s | pBits := 512. "desired size of p in bits" halfTwoToTheP := 2 raisedTo: (pBits - 1). chunkCount := pBits // 160. Transcript show: 'Searching for primes q and p...'; cr. [true] whileTrue: [ sAndq := self generateSandQ. Transcript show: ' Found a candidate q.'; cr. s := sAndq first. q := sAndq last. twoQ := q bitShift: 1. n := 2. c := 0. [c < 4096] whileTrue: [ w := self generateRandomLength: pBits s: s n: n. x := w + halfTwoToTheP. p := (x - ( x \\ twoQ)) + 1. p highBit = pBits ifTrue: [ Transcript show: ' Testing potential p ', (c + 1) printString, '...'; cr. (self isProbablyPrime: p) ifTrue: [ Transcript show: ' Found p!!'; cr. ^ Array with: q with: p with: s]]. n := n + chunkCount + 1. c := c + 1]]. ! ! !DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'StephaneDucasse 8/4/2013 11:19'! initRandomNonInteractively "This logic only works when the sound package is loaded and in the future we should propose a simple random generator to be for the DummySoundSystem." [self initRandom: (SoundSystem current randomBitsFromSoundInput: 512)] ifError: [self initRandomFromString: Time millisecondClockValue printString, Date today printString, Smalltalk os platformName printString].! ! !DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'MaxLeske 7/28/2013 17:26'! generateSandQ "Generate a 160-bit random seed s and an industrial grade prime q." | hasher s sPlusOne u q | hasher := SHA1 new. [true] whileTrue: [ s := self nextRandom160. sPlusOne := s + 1. sPlusOne highBit > 160 ifTrue: [sPlusOne := sPlusOne \\ (2 raisedTo: 160)]. u := (hasher hashInteger: s) bitXor: (hasher hashInteger: sPlusOne). q := u bitOr: ((1 bitShift: 159) bitOr: 1). (self isProbablyPrime: q) ifTrue: [^ Array with: s with: q]]. ! ! !DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'nice 8/28/2010 21:04'! logOfLargestPowerOfTwoDividing: aPositiveInteger "Answer the base-2 log of the largest power of two that divides the given integer. For example, the largest power of two that divides 24 is 8, whose log base-2 is 3. Do this efficiently even when the given number is a large integer. Assume that the given integer is > 0." "DigitalSignatureAlgorithm new logOfLargestPowerOfTwoDividing: (32 * 3)" ^aPositiveInteger lowBit - 1! ! !DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'MaxLeske 7/28/2013 17:26'! nextRandom160 "Answer a newly generated 160-bit random number in the range [1..(2^160 - 1)]." "Details: Try again in the extremely unlikely chance that zero is encountered." | result | result := 0. [result = 0] whileTrue: [ result := SHA1 new hashInteger: randKey seed: randSeed. randKey := randKey + result + 1]. ^ result ! ! !DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'MaxLeske 7/28/2013 17:26'! generateRandomLength: bitLength s: s n: n "Answer a random number of bitLength bits generated using the secure hash algorithm." | sha out count extraBits v | sha := SHA1 new. out := 0. count := (bitLength // 160). extraBits := bitLength - (count * 160). 0 to: count do: [:k | v := sha hashInteger: (s + n + k). k = count ifTrue: [ v := v - ((v >> extraBits) << extraBits)]. out := out bitOr: (v bitShift: (160 * k))]. ^ out ! ! !DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'nice 12/14/2010 15:10'! initRandomFromString: aString "Ask the user to type a long random string and use the result to seed the secure random number generator." | s k srcIndex | s := aString. k := LargePositiveInteger new: (s size min: 64). srcIndex := 0. k digitLength to: 1 by: -1 do: [:i | k digitAt: i put: (s at: (srcIndex := srcIndex + 1)) asciiValue]. k := k normalize + (Random new next * 16r7FFFFFFF) asInteger. "a few additional bits randomness" k highBit > 512 ifTrue: [k := k bitShift: k highBit - 512]. self initRandom: k. ! ! !DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'dc 5/30/2008 10:17'! stringToSignature: aString "Answer the signature stored in the given string. A signature string has the format: '[DSA digital signature ]' where and are large positive integers represented by strings of hexidecimal digits." | prefix stream r s | prefix := '[DSA digital signature '. (aString beginsWith: prefix) ifFalse: [ self error: 'bad signature prefix' ]. stream := aString readStream. stream position: prefix size. r := Integer readFrom: stream base: 16. stream next. s := Integer readFrom: stream base: 16. ^ Array with: r with: s! ! !DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:40'! timeDirect: aBlock as: aString count: anInteger Transcript show: anInteger asStringWithCommas,' ', aString ,' took ', (Time millisecondsToRun: aBlock) asStringWithCommas,' ms'; cr ! ! !DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'MarcusDenker 5/2/2013 11:25'! testExamplesFromDisk "verify messages from file on disk" "Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature." "DigitalSignatureAlgorithm testExamplesFromDisk" FileStream readOnlyFileNamed: 'dsa.test.out' do: [ :file | | msg sig publicKey | [file atEnd] whileFalse: [ sig := file nextChunk. msg := file nextChunk. publicKey := self class compiler evaluate: file nextChunk. (self verify: sig isSignatureOf: msg publicKey: publicKey) ifTrue: [Transcript show: 'SUCCESS: ',msg; cr.] ifFalse: [self error: 'ERROR!! Signature verification failed']]]! ! !DigitalSignatureAlgorithm class methodsFor: 'initialization' stamp: 'NorbertHartl 6/13/2008 11:38'! initialize "DigitalSignatureAlgorithm initialize" "SmallPrimes is a list of small primes greater than two." SmallPrimes := Integer primesUpTo: 2000. SmallPrimes := SmallPrimes copyFrom: 2 to: SmallPrimes size. "HighBitOfByte maps a byte to the index of its top non-zero bit." HighBitOfByte := (0 to: 255) collect: [:byte | byte highBit]. ! ! !DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'jm 12/22/1999 11:23'! example "Example of signing a message and verifying its signature." "Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature." "DigitalSignatureAlgorithm example" | msg keys sig | msg := 'This is a test...'. keys := self testKeySet. sig := self sign: msg privateKey: keys first. self inform: 'Signature created'. (self verify: sig isSignatureOf: msg publicKey: keys last) ifTrue: [self inform: 'Signature verified.'] ifFalse: [self error: 'ERROR!! Signature verification failed']. ! ! !DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'md 3/26/2011 19:16'! timeDecode: count "Example of signing a message and verifying its signature." "Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature." "DigitalSignatureAlgorithm timeDecode: 20" | dsa | dsa := self new. dsa initRandomFromUser. #(1 10 100 1000 10000 100000) do: [ :extraLen | | s msg keys sig | s := String new: extraLen. 1 to: s size do: [ :i | s at: i put: (Character value: 200 atRandom)]. msg := 'This is a test...',s. keys := self testKeySet. sig := self sign: msg privateKey: keys first dsa: dsa. "self inform: 'Signature created'." self timeDirect: [ count timesRepeat: [ (self verify: sig isSignatureOf: msg publicKey: keys last) ifFalse: [self error: 'ERROR!! Signature verification failed']. ]. ] as: 'verify msgLen = ',msg size printString count: count ]. ! ! !DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'md 3/26/2011 19:15'! generateKeySet "Generate and answer a key set for code signing. The result is a pair (). Each key is an array of four large integers. The signer must be sure to record this keys set and must keep the private key secret to prevent someone from forging their signature." "Note: Key generation can take some time. Open a transcript so you can see what's happening and take a coffee break!!" "Note: Unguessable random numbers are needed for key generation. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before generating a key set. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams." "DigitalSignatureAlgorithm generateKeySet" | dsa | dsa := self new. (self confirm: 'Shall I seed the random generator from the current sound input?') ifTrue: [dsa initRandomNonInteractively] ifFalse: [dsa initRandomFromUser]. ^ dsa generateKeySet ! ! !DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'MaxLeske 7/28/2013 17:26'! sign: aStringOrStream privateKey: privateKey dsa: dsa "Sign the given message (a stream or string) and answer a signature string." "Note: Unguessable random numbers are needed for message signing. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before signing a message. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams." | hasher h sig | hasher := SHA1 new. h := aStringOrStream class isBytes ifTrue: [ hasher hashMessage: aStringOrStream ] ifFalse: [ hasher hashStream: aStringOrStream ]. sig := dsa computeSignatureForMessageHash: h privateKey: privateKey. ^ dsa signatureToString: sig! ! !DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'jm 12/22/1999 11:28'! testKeySet "Answer a pair of keys for testing. The first key is the private key, the second one is the public key." "WARNING: This test key set is public should be used only for testing!! In a real application, the user would create a set of keys using generateKeySet and would keep the private key secret." ^ #( (8343811888543852523216773185009428259187948644369498021763210776677854991854533186365944349987509452133156416880596803846631577352387751880552969116768071 1197175832754339660404549606408619548226315875117 1433467472198821951822151391684734233265646022897503720591270330985699984763922266163182803556189497900262038518780931942996381297743579119123094520048965 957348690772296812) (8343811888543852523216773185009428259187948644369498021763210776677854991854533186365944349987509452133156416880596803846631577352387751880552969116768071 1197175832754339660404549606408619548226315875117 1433467472198821951822151391684734233265646022897503720591270330985699984763922266163182803556189497900262038518780931942996381297743579119123094520048965 4645213122572190617807944614677917601101008235397095646475699959851618402406173485853587185431290863173614335452934961425661774118334228449202337038283799)) ! ! !DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'MaxLeske 7/28/2013 17:26'! sign: aStringOrStream privateKey: privateKey "Sign the given message (a stream or string) and answer a signature string." "Note: Unguessable random numbers are needed for message signing. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before signing a message. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams." | dsa hasher h sig | dsa := self new. dsa initRandomFromUser. hasher := SHA1 new. h := aStringOrStream class isBytes ifTrue: [ hasher hashMessage: aStringOrStream ] ifFalse: [ hasher hashStream: aStringOrStream ]. sig := dsa computeSignatureForMessageHash: h privateKey: privateKey. ^ dsa signatureToString: sig! ! !DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'md 3/26/2011 19:16'! writeExamplesToDisk "Example of signing a message and verifying its signature. Used to create samples from one implementation that could later be tested with a different implementation" "Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature." "DigitalSignatureAlgorithm writeExamplesToDisk" | file keyList dsa msgList | dsa := self new. dsa initRandomFromUser. self inform: 'About to generate 5 key sets. Will take a while'. keyList := {self testKeySet},((1 to: 5) collect: [ :ignore | self generateKeySet]). msgList := {'This is a test...'. 'This is the second test period.'. 'And finally, a third message'}. file := FileStream newFileNamed: 'dsa.test.out'. [ msgList do: [ :msg | keyList do: [ :keys | | sig | sig := self sign: msg privateKey: keys first dsa: dsa. (self verify: sig isSignatureOf: msg publicKey: keys last) ifTrue: [ file nextChunkPut: sig; nextChunkPut: msg; nextChunkPut: keys last storeString. ] ifFalse: [ self error: 'ERROR!! Signature verification failed' ]. ]. ]. ] ensure: [file close] ! ! !DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:21'! time: aBlock as: aString count: anInteger ^{anInteger. aString. (Time millisecondsToRun: aBlock)}! ! !DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'MaxLeske 7/28/2013 17:26'! verify: signatureString isSignatureOf: aStringOrStream publicKey: publicKey "Answer true if the given signature string signs the given message (a stream or string)." "Note: Random numbers are not needed for signature verification; thus, there is no need to call initRandomFromUser before verifying a signature." | dsa hasher h sig | dsa := self new. hasher := SHA1 new. h := aStringOrStream class isBytes ifTrue: [ hasher hashMessage: aStringOrStream ] ifFalse: [ hasher hashStream: aStringOrStream ]. sig := dsa stringToSignature: signatureString. ^ dsa verifySignature: sig ofMessageHash: h publicKey: publicKey! ! !DirectoryDoesNotExist commentStamp: 'cwp 11/18/2009 12:33'! I am raised when I an operation is attempted inside a directory that does not exist. ! !DirectoryEntryTest commentStamp: 'TorstenBergmann 1/31/2014 11:38'! SUnit tests for FileSystemDirectoryEntry! !DirectoryEntryTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testIsDirectory | ref entry | ref := FileLocator imageDirectory resolve. entry := ref entry. self assert: entry isDirectory! ! !DirectoryEntryTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/27/2011 22:26'! testCreationTimeIsADateAndTimeInstance "While creation is the message sent to a directory entry, creation returns a DateAndTime object" | creation | creation := self entry creation. self assert: creation class = DateAndTime. ! ! !DirectoryEntryTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/27/2011 22:27'! testModificationTimeIsADateAndTimeInstance "While modification is the message sent to a directory entry, modification returns a DateAndTime object" | modification | modification := self entry modification. self assert: modification class = DateAndTime. ! ! !DirectoryEntryTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testReference | ref entry | ref := FileLocator image resolve. entry := ref entry. self assert: entry reference = ref! ! !DirectoryEntryTest methodsFor: 'tests' stamp: 'cwp 11/15/2009 22:10'! testIsNotDirectory self deny: self entry isDirectory! ! !DirectoryEntryTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/27/2011 22:26'! testIsFile self assert: self entry isFile. self deny: self entry isDirectory! ! !DirectoryEntryTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testIsNotFile | ref | ref := FileLocator imageDirectory resolve. self deny: ref entry isFile! ! !DirectoryEntryTest methodsFor: 'tests' stamp: 'cwp 11/15/2009 22:05'! testSize self assert: self entry size isInteger! ! !DirectoryEntryTest methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 14:26'! entry ^ FileLocator image resolve entry! ! !DirectoryExists commentStamp: 'cwp 11/18/2009 12:35'! I am raised on an attempt to create a directory that already exists.! !DiskFileSystemTest commentStamp: 'TorstenBergmann 1/31/2014 11:44'! SUnit tests for the disk filesystem! !DiskFileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testIsDirectory self assert: (filesystem isDirectory: FileLocator imageDirectory resolve path)! ! !DiskFileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 11:42'! testEqual | other | other := self createFileSystem. self assert: filesystem = other! ! !DiskFileSystemTest methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 4/3/2012 13:17'! createFileSystem ^ FileSystem store: (DiskStore activeClass createDefault)! ! !DiskFileSystemTest methodsFor: 'tests' stamp: 'tbn 2/13/2013 09:36'! testDefaultWorkingDirectory | ref | ref := filesystem workingDirectory. self assert: (('File @ ', Smalltalk vm imagePath) beginsWith: ref asString)! ! !DiskStore commentStamp: ''! I am an abstract superclass for disk store implementations. My subclasses provide access to the actual data storage of a particular kind of filesystem. ! !DiskStore methodsFor: 'public' stamp: 'CamilloBruni 5/13/2012 19:17'! maxFileNameLength ^ maxFileNameLength! ! !DiskStore methodsFor: 'public' stamp: 'MarcusDenker 12/2/2013 14:06'! isWritable: aPath (self exists: aPath) ifFalse: [ ^ false ]. self flag: 'TODO: we need a decent primitive for this...'. (self basicOpen: aPath writable: true) ifNotNil: [ :id| Primitives close: id. ^ true]. ^ false! ! !DiskStore methodsFor: 'private' stamp: 'NicolaiHess 12/1/2013 01:53'! basicEntry: directoryEntry path: aPath nodesDo: aBlock | encodedPathString index entry pathString | index := 1. pathString := self stringFromPath: aPath. encodedPathString := Primitives encode: pathString. entry := Primitives lookupEntryIn: encodedPathString index: index. entry = #badDirectoryPath ifTrue: [ self signalDirectoryDoesNotExist: aPath ]. [ entry isNil ] whileFalse: [ entry at: 1 put: (Primitives decode: entry first). aBlock value: entry. index := index + 1. entry := Primitives lookupEntryIn: encodedPathString index: index ].! ! !DiskStore methodsFor: 'public' stamp: 'cwp 2/28/2011 12:35'! basicOpen: aPath writable: aBoolean | string encoded | string := self stringFromPath: aPath. encoded := Primitives encode: string. ^ Primitives open: encoded writable: aBoolean! ! !DiskStore methodsFor: 'public' stamp: 'cwp 4/3/2011 22:17'! createDirectory: path "Create a directory for the argument path. If the path refers to an existing file, raise FileExists. If the path refers to an existing directory, raise DirectoryExists. If the parent directory of the path does not exist, raise DirectoryDoesNotExist" | parent encodedPathString pathString result | pathString := self stringFromPath: path. encodedPathString := Primitives encode: pathString. result := Primitives createDirectory: encodedPathString. result ifNil: [ parent := path parent. (self exists: path) ifTrue: [ (self isFile: path) ifTrue: [ self signalFileExists: path ] ifFalse: [ self signalDirectoryExists: path ] ]. (self isDirectory: parent) ifFalse: [ ^ self signalDirectoryDoesNotExist: parent ]. self primitiveFailed ]. ^ self! ! !DiskStore methodsFor: 'public' stamp: 'CamilloBruni 1/23/2012 15:52'! rename: sourcePath to: destinationPath | sourcePathString encodedSourcePathString targetPathString encodedTargetPathString result | sourcePathString := self stringFromPath: sourcePath. encodedSourcePathString := Primitives encode: sourcePathString. targetPathString := self stringFromPath: destinationPath. encodedTargetPathString := Primitives encode: targetPathString. ^ Primitives rename: encodedSourcePathString to: encodedTargetPathString.! ! !DiskStore methodsFor: 'accessing' stamp: 'cwp 2/27/2011 10:03'! defaultWorkingDirectory | pathString | pathString := Primitives decode: Primitives imageFile. ^ (self pathFromString: pathString) parent! ! !DiskStore methodsFor: 'initialization' stamp: 'CamilloBruni 5/13/2012 19:18'! initialize super initialize. maxFileNameLength := Smalltalk vm maxFilenameLength ifNil: [ 255 ].! ! !DiskStore methodsFor: 'private' stamp: 'EstebanLorenzano 8/2/2012 15:38'! basicPosixPermissions: anEntry ^ (anEntry size >= 6) ifTrue: [ anEntry at: 6 ] ifFalse: [ nil ].! ! !DiskStore methodsFor: 'public' stamp: 'CamilloBruni 2/20/2012 21:41'! openFileStream: path writable: writable | fullPath | fullPath := self stringFromPath: path. "redirect over the default implementation" ^ writable ifFalse: [ FileStream readOnlyFileNamed: fullPath ] ifTrue: [ FileStream fileNamed: fullPath ]! ! !DiskStore methodsFor: 'private' stamp: 'EstebanLorenzano 8/2/2012 16:51'! basicIsSymlink: anEntry ^(anEntry size >= 7) ifTrue: [ anEntry at: 7 ] ifFalse: [ false ]! ! !DiskStore methodsFor: 'private' stamp: 'NicolaiHess 12/14/2013 13:46'! rootNode ^ #('' 0 0 true 0 8r555)! ! !DiskStore methodsFor: 'private' stamp: 'cwp 2/18/2011 11:32'! basicIsDirectory: anEntry ^ anEntry at: 4! ! !DiskStore methodsFor: 'printing' stamp: 'SeanDeNigris 2/9/2013 09:12'! forReferencePrintOn: aStream aStream nextPutAll: 'File @ '! ! !DiskStore methodsFor: 'public' stamp: 'CamilloBruni 6/17/2013 11:07'! delete: path | pathString encodedPathString | (self exists: path) ifFalse: [ ^ FileDoesNotExist signalWith: path ]. pathString := self stringFromPath: path. encodedPathString := Primitives encode: pathString. (self isDirectory: path) ifTrue: [ Primitives deleteDirectory: encodedPathString ] ifFalse: [ StandardFileStream retryWithGC: [ Primitives deleteFile: encodedPathString ] until: [ :result | result notNil ] forFileNamed: pathString ]! ! !DiskStore methodsFor: 'private' stamp: 'cwp 2/18/2011 11:33'! basicIsFile: anEntry ^ (anEntry at: 4) not! ! !DiskStore methodsFor: 'comparing' stamp: 'cwp 2/27/2011 09:51'! hash ^ self species hash! ! !DiskStore methodsFor: 'private' stamp: 'CamilloBruni 6/1/2012 14:44'! nodeAt: aPath ifPresent: presentBlock ifAbsent: absentBlock | entry | aPath isRoot ifTrue: [ ^ presentBlock value: self rootNode ]. entry := self basicEntryAt: aPath. ^ entry == #badDirectoryPath ifTrue: absentBlock ifFalse: [ entry at: 1 put: aPath basename. presentBlock value: entry ].! ! !DiskStore methodsFor: 'public' stamp: 'MarcusDenker 12/2/2013 14:06'! isReadable: aPath (self exists: aPath) ifFalse: [ ^ false ]. self flag: 'TODO: we need a decent primitive for this...'. (self basicOpen: aPath writable: false) ifNotNil: [ :id| Primitives close: id. ^ true]. ^ false! ! !DiskStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 21:13'! basicSize: anEntry ^ (anEntry at: 5)! ! !DiskStore methodsFor: 'private' stamp: 'cwp 2/18/2011 13:27'! basenameFromEntry: entry ^ entry at: 1! ! !DiskStore methodsFor: 'comparing' stamp: 'cwp 2/27/2011 09:50'! = other ^ self species = other species! ! !DiskStore methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/2/2012 11:46'! handleClass ^ FileHandle! ! !DiskStore methodsFor: 'public' stamp: 'EstebanLorenzano 6/20/2012 12:27'! basicEntryAt: aPath | encodedPath encodedBasename | encodedPath := Primitives encode: (self stringFromPath: aPath parent). encodedBasename := Primitives encode: aPath basename. ^ (Primitives lookupDirectory: encodedPath filename: encodedBasename) ifNil: [ #badDirectoryPath ]. ! ! !DiskStore methodsFor: 'private' stamp: 'CamilloBruni 7/17/2012 18:17'! basicCreationTime: anEntry " the entry contains the seconds since the squeak epoch in local time" ^ (DateAndTime fromSeconds: (anEntry at: 2) offset: 0) translateTo: DateAndTime localOffset! ! !DiskStore methodsFor: 'public' stamp: 'CamilloBruni 5/13/2012 19:17'! checkName: aFileName fixErrors: fixErrors "Check a string aFileName for validity as a file name. Answer the original file name if it is valid. If the name is not valid (e.g., it is too long or contains illegal characters) and fixing is false, raise an error. If fixing is true, fix the name (usually by truncating and/or tranforming characters), and answer the corrected name. The default behavior is just to truncate the name to the maximum length for this platform. Subclasses can do any kind of checking and correction appropriate for their platform." | maxLength | aFileName size = 0 ifTrue: [self error: 'zero length file name']. maxLength := self maxFileNameLength. aFileName size > maxLength ifTrue: [ fixErrors ifTrue: [^ aFileName contractTo: maxLength] ifFalse: [self error: 'file name is too long']]. ^ aFileName! ! !DiskStore methodsFor: 'public' stamp: 'CamilloBruni 6/1/2012 14:46'! isDirectory: aPath | entry | aPath isRoot ifTrue: [ ^ true ]. entry := self basicEntryAt: aPath. ^ entry == #badDirectoryPath ifTrue: [ false ] ifFalse: [ self basicIsDirectory: entry ]. ! ! !DiskStore methodsFor: 'public' stamp: 'EstebanLorenzano 8/2/2012 15:43'! isSymlink: aPath | entry | aPath isRoot ifTrue: [ ^false ]. entry := self basicEntryAt: aPath. ^ entry == #badDirectoryPath ifTrue: [ false ] ifFalse: [ self basicIsSymlink: entry ]. ! ! !DiskStore methodsFor: 'public' stamp: 'CamilloBruni 6/17/2012 17:22'! isFile: aPath | entry | aPath isRoot ifTrue: [ ^ false ]. entry := self basicEntryAt: aPath. ^ entry == #badDirectoryPath ifTrue: [ false ] ifFalse: [ self basicIsFile: entry ]. ! ! !DiskStore methodsFor: 'private' stamp: 'CamilloBruni 7/17/2012 18:17'! basicModificationTime: anEntry " the entry contains the seconds since the squeak epoch in local time" ^ (DateAndTime fromSeconds: (anEntry at: 3) offset: 0) translateTo: DateAndTime localOffset! ! !DiskStore class methodsFor: 'public' stamp: 'CamilloBruni 5/10/2012 16:03'! maxFileNameLength self subclassResponsibility ! ! !DiskStore class methodsFor: 'current' stamp: 'CamilloBruni 5/13/2012 19:17'! currentFileSystem ^ CurrentFS ifNil: [ CurrentFS := FileSystem store: self activeClass createDefault]! ! !DiskStore class methodsFor: 'class initialization' stamp: 'MarcusDenker 5/7/2013 12:07'! checkVMVersion "Display a warning if the VM is too old" | displayError | displayError := [ ^ self inform: 'Your VM is too old for this image. Please download the latest VM.' ]. [(Smalltalk vm interpreterSourceDate > '2012-07-08+2:00' asDate) ifFalse: displayError ] on: Error do: [ :e| displayError value ].! ! !DiskStore class methodsFor: 'current' stamp: 'cwp 4/4/2011 19:04'! reset CurrentFS := nil! ! !DiskStore class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 4/2/2012 11:46'! useFilePlugin Primitives := FilePluginPrims new! ! !DiskStore class methodsFor: 'current' stamp: 'cwp 2/27/2011 10:02'! createDefault ^ self new! ! !DiskStore class methodsFor: 'current' stamp: 'CamilloBruni 5/10/2012 15:41'! activeClass self allSubclassesDo: [:ea | ea isActiveClass ifTrue: [^ ea]]. ^ self! ! !DiskStore class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 6/21/2012 12:53'! initialize self useFilePlugin. Smalltalk removeFromStartUpList: self; removeFromShutDownList: self; addToStartUpList: self after: OSPlatform; addToShutDownList: self! ! !DiskStore class methodsFor: 'current' stamp: 'cwp 2/18/2011 17:20'! isActiveClass ^ self delimiter = Primitives delimiter! ! !DiskStore class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 6/21/2012 12:52'! shutDown: quitting "Force to detect filesystem after image restart" self reset! ! !DiskStore class methodsFor: 'public' stamp: 'Cami 7/9/2012 11:12'! delimiter ^ self current delimiter! ! !DiskStore class methodsFor: 'current' stamp: 'EstebanLorenzano 4/3/2012 11:30'! current ^ self currentFileSystem store! ! !DiskStore class methodsFor: 'class initialization' stamp: 'CamilloBruni 7/18/2012 12:22'! startUp: resuming self checkVMVersion. resuming ifTrue: [ self reset ]! ! !DisplayMedium commentStamp: ''! I am a display object which can both paint myself on a medium (displayOn: messages), and can act as a medium myself. My chief subclass is Form.! !DisplayMedium methodsFor: 'coloring' stamp: ''! fillGray: aRectangle "Set all bits in the receiver's area defined by aRectangle to the gray mask." self fill: aRectangle rule: Form over fillColor: Color gray! ! !DisplayMedium methodsFor: 'displaying' stamp: 'hmm 9/16/2000 21:27'! deferUpdatesIn: aRectangle while: aBlock "DisplayScreen overrides with something more involved..." ^aBlock value! ! !DisplayMedium methodsFor: 'bordering' stamp: ''! border: aRectangle width: borderWidth fillColor: aHalfTone "Paint a border whose rectangular area is defined by aRectangle. The width of the border of each side is borderWidth. Uses aHalfTone for drawing the border." self border: aRectangle widthRectangle: (Rectangle left: borderWidth right: borderWidth top: borderWidth bottom: borderWidth) rule: Form over fillColor: aHalfTone! ! !DisplayMedium methodsFor: 'coloring' stamp: ''! fillWithColor: aColor "Fill the receiver's bounding box with the given color." self fill: self boundingBox fillColor: aColor. ! ! !DisplayMedium methodsFor: 'displaying' stamp: ''! copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm "Make up a BitBlt table and copy the bits." self subclassResponsibility! ! !DisplayMedium methodsFor: 'coloring' stamp: ''! fillBlack "Set all bits in the receiver to black (ones)." self fill: self boundingBox fillColor: Color black! ! !DisplayMedium methodsFor: 'private' stamp: 'FernandoOlivero 9/9/2013 11:57'! quickHighLight: aDepth ^ self highLightBitmaps at: aDepth! ! !DisplayMedium methodsFor: 'private' stamp: 'MarcusDenker 12/8/2013 10:05'! initializeHighLights "Create a set of Bitmaps for quickly reversing areas of the screen without converting colors. " HighLightBitmaps := Array new: 32. ^HighLightBitmaps at: 1 put: (Bitmap with: 4294967295); at: 2 put: (Bitmap with: 4294967295); at: 4 put: (Bitmap with: 1431655765); at: 8 put: (Bitmap with: 117901063); at: 16 put: (Bitmap with: 4294967295); at: 32 put: (Bitmap with: 4294967295); yourself. ! ! !DisplayMedium methodsFor: 'coloring' stamp: ''! fill: aRectangle fillColor: aForm "Replace a rectangular area of the receiver with the pattern described by aForm according to the rule over." self fill: aRectangle rule: Form over fillColor: aForm! ! !DisplayMedium methodsFor: 'coloring' stamp: ''! reverse: aRectangle fillColor: aMask "Change all the bits in the receiver's area that intersects with aRectangle according to the mask. Black does not necessarily turn to white, rather it changes with respect to the rule and the bit in a corresponding mask location. Bound to give a surprise." self fill: aRectangle rule: Form reverse fillColor: aMask! ! !DisplayMedium methodsFor: 'bordering' stamp: ''! border: aRectangle widthRectangle: insets rule: combinationRule fillColor: aHalfTone "Paint a border whose rectangular area is defined by aRectangle. The width of each edge of the border is determined by the four coordinates of insets. Uses aHalfTone and combinationRule for drawing the border." (aRectangle areasOutside: (aRectangle insetBy: insets)) do: [:edgeStrip | self fill: edgeStrip rule: combinationRule fillColor: aHalfTone]! ! !DisplayMedium methodsFor: 'coloring' stamp: 'FernandoOlivero 9/9/2013 11:57'! reverse "Change all the bits in the receiver that are white to black, and the ones that are black to white." " Display reverse: (10@10 extent: 100@100) " self fill: self boundingBox rule: Form reverse fillColor: (self quickHighLight: self depth)! ! !DisplayMedium methodsFor: 'coloring' stamp: 'StephaneDucasse 10/25/2013 16:07'! fillShape: aShapeForm fillColor: aColor at: location "Fill a region corresponding to 1 bits in aShapeForm with aColor" ((BitBlt destForm: self sourceForm: aShapeForm fillColor: aColor combinationRule: Form paint destOrigin: location + aShapeForm offset sourceOrigin: 0@0 extent: self extent clipRect: self boundingBox) colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) copyBits! ! !DisplayMedium methodsFor: 'coloring' stamp: 'FernandoOlivero 9/9/2013 11:57'! reverse: aRectangle "Change all the bits in the receiver's area that intersects with aRectangle that are white to black, and the ones that are black to white." self fill: aRectangle rule: Form reverse fillColor: (self quickHighLight: self depth)! ! !DisplayMedium methodsFor: 'coloring' stamp: ''! fillBlack: aRectangle "Set all bits in the receiver's area defined by aRectangle to black (ones)." self fill: aRectangle rule: Form over fillColor: Color black! ! !DisplayMedium methodsFor: 'bordering' stamp: ''! border: aRectangle width: borderWidth "Paint a border whose rectangular area is defined by aRectangle. The width of the border of each side is borderWidth. Uses black for drawing the border." self border: aRectangle width: borderWidth fillColor: Color black. ! ! !DisplayMedium methodsFor: 'coloring' stamp: ''! fill: aRectangle rule: anInteger fillColor: aForm "Replace a rectangular area of the receiver with the pattern described by aForm according to the rule anInteger." self subclassResponsibility! ! !DisplayMedium methodsFor: 'coloring' stamp: ''! fillColor: aColor "Set all pixels in the receiver to the color. Must be a correct color for this depth of medium. TK 1 Jun 96" self fill: self boundingBox fillColor: aColor! ! !DisplayMedium methodsFor: 'coloring' stamp: ''! fillShape: aShapeForm fillColor: aColor "Fill a region corresponding to 1 bits in aShapeForm with aColor" ^ self fillShape: aShapeForm fillColor: aColor at: 0@0! ! !DisplayMedium methodsFor: 'coloring' stamp: ''! fillWhite "Set all bits in the form to white." self fill: self boundingBox fillColor: Color white. ! ! !DisplayMedium methodsFor: 'coloring' stamp: ''! fillGray "Set all bits in the receiver to gray." self fill: self boundingBox fillColor: Color gray! ! !DisplayMedium methodsFor: 'private' stamp: 'MarcusDenker 12/8/2013 10:07'! highLightBitmaps "Quickly return a Bitblt-ready raw colorValue for highlighting areas." ^HighLightBitmaps ifNil: [self initializeHighLights ]. ! ! !DisplayMedium methodsFor: 'displaying' stamp: ''! drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm "Draw line by copying the argument, sourceForm, starting at location beginPoint and ending at endPoint, clipped by the rectangle, clipRect. The rule and mask for copying are the arguments anInteger and aForm." self subclassResponsibility! ! !DisplayMedium methodsFor: 'coloring' stamp: ''! fillWhite: aRectangle "Set all bits in the receiver's area defined by aRectangle to white." self fill: aRectangle rule: Form over fillColor: Color white. ! ! !DisplayMedium methodsFor: 'bordering' stamp: ''! border: aRectangle width: borderWidth rule: combinationRule fillColor: aHalfTone "Paint a border whose rectangular area is defined by aRectangle. The width of the border of each side is borderWidth. Uses aHalfTone for drawing the border." self border: aRectangle widthRectangle: (Rectangle left: borderWidth right: borderWidth top: borderWidth bottom: borderWidth) rule: combinationRule fillColor: aHalfTone! ! !DisplayObject commentStamp: ''! The abstract protocol for most display primitives that are used by Views for presenting information on the screen.! !DisplayObject methodsFor: 'displaying-generic' stamp: 'jm 10/21/97 16:56'! displayOnPort: port at: location rule: rule port copyForm: self to: location rule: rule. ! ! !DisplayObject methodsFor: 'displaying-generic' stamp: ''! displayOn: aDisplayMedium at: aDisplayPoint "Display the receiver located at aDisplayPoint with default settings for rule and halftone." self displayOn: aDisplayMedium at: aDisplayPoint clippingBox: aDisplayMedium boundingBox rule: Form over fillColor: nil! ! !DisplayObject methodsFor: 'accessing' stamp: ''! offset "Answer the amount by which the receiver should be offset when it is displayed or its position is tested." self subclassResponsibility! ! !DisplayObject methodsFor: 'displaying-generic' stamp: ''! displayOn: aDisplayMedium "Simple default display in order to see the receiver in the upper left corner of screen." self displayOn: aDisplayMedium at: 0 @ 0! ! !DisplayObject methodsFor: 'accessing' stamp: ''! height "Answer the number that represents the height of the receiver's bounding box." ^self boundingBox height! ! !DisplayObject methodsFor: 'displaying-display' stamp: ''! display "Display the receiver on the Display at location 0,0." self displayOn: Display! ! !DisplayObject methodsFor: 'displaying-generic' stamp: ''! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm "This is the basic display primitive for graphic display objects. Display the receiver located at aDisplayPoint with rule, ruleInteger, and mask, aForm. Information to be displayed must be confined to the area that intersects with clipRectangle." self subclassResponsibility! ! !DisplayObject methodsFor: 'displaying-display' stamp: 'CamilloBruni 10/21/2012 23:43'! slideWithFirstFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs "Slide this object across the display over the given number of steps, pausing for the given number of milliseconds after each step." "Note: Does display at the first point and at the last." | i p delta | i := 0. delta := stopPoint - startPoint / nSteps asFloat. p := startPoint - delta. ^ self follow: [(p := p + delta) truncated] while: [(Delay forMilliseconds: milliSecs) wait. (i := i + 1) <= nSteps]! ! !DisplayObject methodsFor: 'display box access' stamp: ''! computeBoundingBox "Answer the rectangular area that represents the boundaries of the receiver's area for displaying information. This is the primitive for computing the area if it is not already known." self subclassResponsibility! ! !DisplayObject methodsFor: 'displaying-display' stamp: 'CamilloBruni 5/9/2013 18:56'! follow: locationBlock while: durationBlock "Move an image around on the Display. Restore the background continuously without causing flashing. The argument, locationBlock, supplies each new location, and the argument, durationBlock, supplies true to continue, and then false to stop." | bitsBehind loc | loc := locationBlock value. bitsBehind := Form fromDisplay: (loc extent: self extent). ^ self follow: locationBlock while: durationBlock bitsBehind: bitsBehind startingLoc: loc! ! !DisplayObject methodsFor: 'displaying-generic' stamp: ''! displayOn: aDisplayMedium at: aDisplayPoint rule: ruleInteger "Display the receiver located at aPoint with default setting for the halftone and clippingBox." self displayOn: aDisplayMedium at: aDisplayPoint clippingBox: aDisplayMedium boundingBox rule: ruleInteger fillColor: nil! ! !DisplayObject methodsFor: 'display box access' stamp: ''! initialExtent "Included here for when a FormView is being opened as a window. (4@4) covers border widths." ^ self extent + (4@4) ! ! !DisplayObject methodsFor: 'transforming' stamp: ''! align: alignmentPoint with: relativePoint "Translate the receiver's offset such that alignmentPoint aligns with relativePoint." self offset: (self offset translateBy: relativePoint - alignmentPoint)! ! !DisplayObject methodsFor: 'displaying-display' stamp: 'di 9/12/97 11:09'! isTransparent ^ false! ! !DisplayObject methodsFor: 'displaying-display' stamp: 'CamilloBruni 5/9/2013 18:53'! slideFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs "Slide this object across the display over the given number of steps, pausing for the given number of milliseconds after each step." "Note: Does not display at the first point, but does at the last." | i p delta | i := 0. p := startPoint. delta := (stopPoint - startPoint) / nSteps asFloat. ^ self follow: [ p := p + delta. p truncated] while: [ (Delay forMilliseconds: milliSecs) wait. (i := i + 1) < nSteps] ! ! !DisplayObject methodsFor: 'accessing' stamp: ''! width "Answer the number that represents the width of the receiver's bounding box." ^self boundingBox width! ! !DisplayObject methodsFor: 'displaying-generic' stamp: ''! displayAt: aDisplayPoint "Display the receiver located at aDisplayPoint with default settings for the displayMedium, rule and halftone." self displayOn: Display at: aDisplayPoint clippingBox: Display boundingBox rule: Form over fillColor: nil! ! !DisplayObject methodsFor: 'display box access' stamp: ''! center ^ self boundingBox center! ! !DisplayObject methodsFor: 'transforming' stamp: ''! translateBy: aPoint "Translate the receiver's offset." self offset: (self offset translateBy: aPoint)! ! !DisplayObject methodsFor: 'displaying-generic' stamp: ''! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle "Display the receiver located at aDisplayPoint with default settings for rule and halftone. Information to be displayed must be confined to the area that intersects with clipRectangle." self displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: Form over fillColor: nil! ! !DisplayObject methodsFor: 'accessing' stamp: ''! extent "Answer the point that represents the width and height of the receiver's bounding box." ^self boundingBox extent! ! !DisplayObject methodsFor: 'accessing' stamp: ''! relativeRectangle "Answer a Rectangle whose top left corner is the receiver's offset position and whose width and height are the same as the receiver." ^Rectangle origin: self offset extent: self extent! ! !DisplayObject methodsFor: 'transforming' stamp: ''! scaleBy: aPoint "Scale the receiver's offset by aPoint." self offset: (self offset scaleBy: aPoint)! ! !DisplayObject methodsFor: 'accessing' stamp: ''! offset: aPoint "Set the amount by which the receiver's position is offset." ^self! ! !DisplayObject methodsFor: 'display box access' stamp: ''! boundingBox "Answer the rectangular area that represents the boundaries of the receiver's space of information." ^self computeBoundingBox! ! !DisplayObject methodsFor: 'truncation and round off' stamp: ''! rounded "Convert the offset of the receiver to integer coordinates." self offset: self offset rounded! ! !DisplayObject methodsFor: 'displaying-display' stamp: 'StephaneDucasse 10/25/2013 16:07'! follow: locationBlock while: durationBlock bitsBehind: initialBitsBehind startingLoc: loc "Move an image around on the Display. Restore the background continuously without causing flashing. The argument, locationBlock, supplies each new location, and the argument, durationBlock, supplies true to continue or false to stop. This variant takes the bitsBehind as an input argument, and returns the final saved saved bits as method value." | location rect1 save1 save1Blt buffer bufferBlt newLoc rect2 bothRects | location := loc. rect1 := location extent: self extent. save1 := initialBitsBehind. save1Blt := BitBlt toForm: save1. buffer := Form extent: self extent*2 depth: Display depth. "Holds overlapping region" bufferBlt := BitBlt toForm: buffer. Display deferUpdates: true. self displayOn: Display at: location rule: Form paint. Display deferUpdates: false; forceToScreen: (location extent: self extent). [durationBlock value] whileTrue: [ newLoc := locationBlock value. newLoc ~= location ifTrue: [ rect2 := newLoc extent: self extent. bothRects := rect1 merge: rect2. (rect1 intersects: rect2) ifTrue: [ "when overlap, buffer background for both rectangles" bufferBlt copyFrom: bothRects in: Display to: 0@0. bufferBlt copyFrom: save1 boundingBox in: save1 to: rect1 origin - bothRects origin. "now buffer is clean background; get new bits for save1" save1Blt copy: (0@0 extent: self extent) from: rect2 origin - bothRects origin in: buffer. self displayOnPort: bufferBlt at: rect2 origin - bothRects origin rule: Form paint. Display deferUpdates: true. Display copy: bothRects from: 0@0 in: buffer rule: Form over. Display deferUpdates: false; forceToScreen: bothRects] ifFalse: [ "when no overlap, do the simple thing (both rects might be too big)" Display deferUpdates: true. Display copy: (location extent: save1 extent) from: 0@0 in: save1 rule: Form over. save1Blt copyFrom: rect2 in: Display to: 0@0. self displayOn: Display at: newLoc rule: Form paint. Display deferUpdates: false; forceToScreen: (location extent: save1 extent); forceToScreen: (newLoc extent: self extent)]. location := newLoc. rect1 := rect2]]. ^ save1 displayOn: Display at: location ! ! !DisplayScanner commentStamp: 'nice 10/11/2013 23:45'! A DisplayScanner is an abstract class for displaying characters. It is splitting text into elementary chunks of displayable String/Font pairs (see scanning protocol). Subclasses responsibility is to handle the effective rendering of these chunks on various backends. Instance Variables backgroundColor: defaultTextColor: foregroundColor: ignoreColorChanges: lastDisplayableIndex: lineY: morphicOffset: stopConditionsMustBeReset: backgroundColor - the background color for displaying next chunk of text. Note that this can be set to Color transparent, in which case no background is displayed. defaultTextColor - the default foreground color for displaying text in absence of other text attributes specification foregroundColor - the foreground color for displaying next chunk of text ignoreColorChanges - indicates that any change of color specified in text attributes shall be ignored. This is used for displaying text in a shadow mode, when dragging text for example. lastDisplayableIndex - the index of last character to be displayed. A different index than lastIndex is required in order to avoid display of control characters. This variable must be updated by the stop condition at each inner scan loop. lineY - the distance between destination form top and current line top morphicOffset - an offset for positionning the embedded morphs. THE EXACT SPECIFICATION YET REMAINS TO BE WRITTEN stopConditionsMustBeReset - indicates that it's necessary to call setStopConditions in next scan loop. Notes: In order to correctly set the lastDisplayableIndex, the display scanner performs the stopCondition BEFORE displaying the string being scanned. This explains why the stopCondition must not reset the font immediately, but differ this reset AFTER the display, thanks to stopConditionsMustBeReset. ! !DisplayScanner methodsFor: 'scanning' stamp: 'nice 10/22/2013 20:51'! displayLine: textLine offset: offset leftInRun: leftInRun "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." | stopCondition nowLeftInRun startIndex string lastPos lineHeight stop | line := textLine. morphicOffset := offset. lineY := line top + offset y. lineHeight := line lineHeight. rightMargin := line rightMargin + offset x. lastIndex := line first. leftInRun <= 0 ifTrue: [self setStopConditions]. leftMargin := (line leftMarginForAlignment: alignment) + offset x. destX := leftMargin. self fillTextBackground. lastDisplayableIndex := lastIndex := line first. leftInRun <= 0 ifTrue: [nowLeftInRun := text runLengthFor: lastIndex] ifFalse: [nowLeftInRun := leftInRun]. destY := lineY + line baseline - font ascent. runStopIndex := lastIndex + (nowLeftInRun - 1) min: line last. spaceCount := 0. string := text string. [ "reset the stopping conditions of this displaying loop, and also the font." stopConditionsMustBeReset ifTrue:[self setStopConditions]. "remember where this portion of the line starts" startIndex := lastIndex. lastPos := destX@destY. "find the end of this portion of the line" stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin. "handle the stop condition - this will also set lastDisplayableIndex" stop := self perform: stopCondition. "display that portion of the line" lastDisplayableIndex >= startIndex ifTrue:[ self displayString: string from: startIndex to: lastDisplayableIndex at: lastPos]. "if the stop condition were true, stop the loop" stop ] whileFalse. ^ runStopIndex - lastIndex "Number of characters remaining in the current run"! ! !DisplayScanner methodsFor: 'displaying' stamp: 'nice 10/19/2013 13:13'! displayEmbeddedForm: aForm self subclassResponsibility! ! !DisplayScanner methodsFor: 'private' stamp: 'nice 10/11/2013 23:46'! defaultTextColor defaultTextColor ifNil:[defaultTextColor := Color black]. ^defaultTextColor! ! !DisplayScanner methodsFor: 'text attributes' stamp: 'ar 1/8/2000 14:51'! textColor: textColor ignoreColorChanges ifTrue: [^ self]. foregroundColor := textColor! ! !DisplayScanner methodsFor: 'private' stamp: 'nice 10/11/2013 23:46'! defaultTextColor: color defaultTextColor := color.! ! !DisplayScanner methodsFor: 'displaying' stamp: 'nice 10/12/2013 03:39'! initialize super initialize. ignoreColorChanges := false.! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'nice 10/10/2013 00:13'! endOfRun "The end of a run in the display case either means that there is actually a change in the style (run code) to be associated with the string or the end of this line has been reached." | runLength | lastDisplayableIndex := lastIndex. lastIndex = line last ifTrue: [^true]. runLength := text runLengthFor: (lastIndex := lastIndex + 1). runStopIndex := lastIndex + (runLength - 1) min: line last. "differ reset of stopConditions and font AFTER the dispaly of last scanned string" stopConditionsMustBeReset := true. ^ false! ! !DisplayScanner methodsFor: 'private' stamp: 'nice 10/9/2013 23:39'! setStopConditions super setStopConditions. stopConditionsMustBeReset := false! ! !DisplayScanner methodsFor: 'displaying' stamp: 'nice 10/12/2013 01:05'! displayString: string from: startIndex to: stopIndex at: aPoint self subclassResponsibility! ! !DisplayScanner methodsFor: 'displaying' stamp: 'nice 10/12/2013 00:53'! fillTextBackground self subclassResponsibility! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'nice 10/8/2013 23:36'! paddedSpace "Each space is a stop condition when the alignment is right justified. Padding must be added to the base width of the space according to which space in the line this space is and according to the amount of space that remained at the end of the line when it was composed." lastDisplayableIndex := lastIndex - 1. spaceCount := spaceCount + 1. destX := destX + spaceWidth + kern + (line justifiedPadFor: spaceCount font: font). lastIndex := lastIndex + 1. pendingKernX := 0. ^ false! ! !DisplayScanner methodsFor: 'private' stamp: 'SeanDeNigris 1/7/2014 20:59'! placeEmbeddedObject: anchoredMorphOrForm anchoredMorphOrForm relativeTextAnchorPosition ifNotNil:[:relativeTextAnchorPosition | anchoredMorphOrForm position: relativeTextAnchorPosition + (anchoredMorphOrForm owner textBounds origin x @ (lineY - morphicOffset y)). ^true ]. anchoredMorphOrForm isMorph ifTrue: [ anchoredMorphOrForm position: (destX@(lineY + line baseline - anchoredMorphOrForm height)) - morphicOffset ] ifFalse: [ self displayEmbeddedForm: anchoredMorphOrForm ]. destX := destX + anchoredMorphOrForm width + kern. ^ true! ! !DisplayScanner methodsFor: 'private' stamp: 'nice 10/12/2013 01:33'! text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode text := t. textStyle := ts. foregroundColor := defaultTextColor := foreColor. backgroundColor := backColor. ignoreColorChanges := shadowMode! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'nice 10/8/2013 23:37'! crossedX "This condition will sometimes be reached 'legally' during display, when, for instance the space that caused the line to wrap actually extends over the right boundary. This character is allowed to display, even though it is technically outside or straddling the clipping rectangle since it is in the normal case not visible and is in any case appropriately clipped by the scanner." self advanceIfFirstCharOfLine. lastDisplayableIndex := lastIndex - 1. ^ true ! ! !DisplayScanner methodsFor: 'private' stamp: 'nice 10/11/2013 23:47'! setFont foregroundColor := self defaultTextColor. super setFont. "Sets font and emphasis bits, and maybe foregroundColor" text ifNotNil:[destY := lineY + line baseline - font ascent]! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'nice 10/8/2013 23:35'! cr "When a carriage return is encountered, simply increment the pointer into the paragraph." pendingKernX := 0. lastDisplayableIndex := lastIndex - 1. (lastIndex < text size and: [(text at: lastIndex) = CR and: [(text at: lastIndex+1) = Character lf]]) ifTrue: [lastIndex := lastIndex + 2] ifFalse: [lastIndex := lastIndex + 1]. ^false! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'nice 10/13/2013 22:10'! tab lastDisplayableIndex := lastIndex - 1. destX := self plainTab. lastIndex := lastIndex + 1. ^ false! ! !DisplayScanner class methodsFor: 'instance creation' stamp: 'nice 10/12/2013 03:36'! new "Use default concrete class" ^(self == DisplayScanner ifTrue: [BitBltDisplayScanner] ifFalse: [self]) basicNew initialize! ! !DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:39'! defaultFont ^ TextStyle defaultFont! ! !DisplayScreen commentStamp: ''! There is only one instance of me, Display. It is a global and is used to handle general user requests to deal with the whole display screen. Although I offer no protocol, my name provides a way to distinguish this special instance from all other Forms. This is useful, for example, in dealing with saving and restoring the system. To change the depth of your Display... Display newDepth: 16. Display newDepth: 8. Display newDepth: 1. Valid display depths are 1, 2, 4, 8, 16 and 32. It is suggested that you run with your monitors setting the same, for better speed and color fidelity. Note that this can add up to 4Mb for the Display form. Finally, note that newDepth: ends by executing a 'ControlManager restore' which currently terminates the active process, so nothing that follows in the doit will get executed. Depths 1, 2, 4 and 8 bits go through a color map to put color on the screen, but 16 and 32-bit color use the pixel values directly for RGB color (5 and 8 bits per, respectivlely). The color choice an be observed by executing Color fromUser in whatever depth you are using. ! !DisplayScreen methodsFor: 'initialization' stamp: 'ar 5/28/2000 11:25'! shutDown "Minimize Display memory saved in image" self setExtent: 240@120 depth: depth! ! !DisplayScreen methodsFor: 'other' stamp: 'jm 5/21/1998 23:48'! forceDisplayUpdate "On platforms that buffer screen updates, force the screen to be updated immediately. On other platforms, or if the primitive is not implemented, do nothing." "do nothing if primitive fails"! ! !DisplayScreen methodsFor: 'deferring' stamp: 'MarianoMartinezPeck 5/23/2012 13:38'! deferUpdatesIn: aRectangle while: aBlock | result | (self class deferUpdates: true) ifTrue: [^aBlock value]. result := aBlock value. self class deferUpdates: false. self forceToScreen: aRectangle. ^result! ! !DisplayScreen methodsFor: 'private' stamp: 'IgorStasenko 1/21/2011 19:05'! findAnyDisplayDepth "Return any display depth that is supported on this system." ^self findAnyDisplayDepthIfNone:[ "Ugh .... now this is a biggie - a system that does not support any of the display depths at all." Smalltalk logError:'Fatal error: This system has no support for any display depth at all.' inContext: thisContext. Smalltalk quitPrimitive. "There is no way to continue from here" ].! ! !DisplayScreen methodsFor: 'displaying' stamp: 'sw 1/1/2005 01:31'! flashAll: rectangleList andWait: msecs "Flash the areas of the screen defined by the given rectangles." rectangleList do: [:aRectangle | self reverse: aRectangle]. self forceDisplayUpdate. (Delay forMilliseconds: msecs) wait. rectangleList do: [:aRectangle | self reverse: aRectangle]. self forceDisplayUpdate. (Delay forMilliseconds: msecs) wait. ! ! !DisplayScreen methodsFor: 'screen managing' stamp: 'SeanDeNigris 11/28/2011 21:53'! fullscreenOff self fullscreen: false! ! !DisplayScreen methodsFor: 'other' stamp: 'CamilloBruni 8/1/2012 16:18'! usableArea "Answer the usable area of the receiver." ^ self boundingBox deepCopy! ! !DisplayScreen methodsFor: 'private' stamp: 'pavel.krivanek 11/20/2007 09:28'! newDepthNoRestore: pixelSize UIManager default newDisplayDepthNoRestore: pixelSize! ! !DisplayScreen methodsFor: 'other' stamp: ''! height ^ self boundingBox height! ! !DisplayScreen methodsFor: 'displaying' stamp: 'StephaneDucasse 10/25/2013 16:16'! copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf (BitBlt destForm: self sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: rect origin extent: rect extent clipRect: (clipRect intersect: clippingBox ifNone: [ ^ self ])) copyBits! ! !DisplayScreen methodsFor: 'other' stamp: 'pavel.krivanek 11/20/2007 09:28'! restore UIManager default restoreDisplay! ! !DisplayScreen methodsFor: 'other' stamp: 'SeanDeNigris 11/30/2011 14:48'! fullscreen "Display fullscreen" ScreenSave notNil ifTrue: [Display := ScreenSave]. clippingBox := super boundingBox! ! !DisplayScreen methodsFor: 'other' stamp: 'jm 5/19/1998 17:50'! forceToScreen: aRectangle "Force the given rectangular section of the Display to be copied to the screen. The primitive call does nothing if the primitive is not implemented. Typically used when the deferUpdates flag in the virtual machine is on; see deferUpdates:." self primShowRectLeft: aRectangle left right: aRectangle right top: aRectangle top bottom: aRectangle bottom. ! ! !DisplayScreen methodsFor: 'private' stamp: 'bf 5/16/2006 11:35'! setExtent: aPoint depth: bitsPerPixel "DisplayScreen startUp" "This method is critical. If the setExtent fails, there will be no proper display on which to show the error condition..." "ar 5/1/1999: ... and that is exactly why we check for the available display depths first." "RAA 27 Nov 99 - if depth and extent are the same and acceptable, why go through this. also - record when we change so worlds can tell if it is time to repaint" (depth == bitsPerPixel and: [aPoint = self extent and: [self supportsDisplayDepth: bitsPerPixel]]) ifFalse: [ bits := nil. "Free up old bitmap in case space is low" DisplayChangeSignature := (DisplayChangeSignature ifNil: [0]) + 1. (self supportsDisplayDepth: bitsPerPixel) ifTrue:[super setExtent: aPoint depth: bitsPerPixel] ifFalse:[(self supportsDisplayDepth: bitsPerPixel negated) ifTrue:[super setExtent: aPoint depth: bitsPerPixel negated] ifFalse:["Search for a suitable depth" super setExtent: aPoint depth: self findAnyDisplayDepth]]. ]. clippingBox := super boundingBox! ! !DisplayScreen methodsFor: 'other' stamp: ''! fullBoundingBox ^ super boundingBox! ! !DisplayScreen methodsFor: 'other' stamp: 'alain.plantec 5/30/2008 12:43'! newDepth: pixelSize " Display newDepth: 8. Display newDepth: 1 " (self supportsDisplayDepth: pixelSize) ifFalse: [^ self inform: 'Display depth ' , pixelSize printString , ' is not supported on this system']. self newDepthNoRestore: pixelSize. self restore! ! !DisplayScreen methodsFor: 'deferring' stamp: 'GuillermoPolito 5/1/2012 14:31'! deferUpdates: aBoolean ^self class deferUpdates: aBoolean! ! !DisplayScreen methodsFor: 'other' stamp: 'RAA 11/27/1999 15:48'! displayChangeSignature ^DisplayChangeSignature! ! !DisplayScreen methodsFor: 'screen managing' stamp: 'PavelKrivanek 11/17/2012 23:14'! fullscreen: aBoolean Display fullscreenMode: (LastScreenModeSelected := aBoolean). DisplayScreen checkForNewScreenSize. ! ! !DisplayScreen methodsFor: 'other' stamp: 'alain.plantec 6/10/2008 22:29'! clippingTo: aRect do: aBlock "Display clippingTo: Rectangle fromUser do:" | saveClip | saveClip := clippingBox. clippingBox := aRect. aBlock value. clippingBox := saveClip! ! !DisplayScreen methodsFor: 'private' stamp: 'jm 6/3/1998 13:00'! primRetryShowRectLeft: l right: r top: t bottom: b "Copy the given rectangular section of the Display to to the screen. This primitive is not implemented on all platforms. Do nothing if it fails. " "do nothing if primitive fails" ! ! !DisplayScreen methodsFor: 'displaying' stamp: 'jm 5/22/1998 01:23'! flash: aRectangle "Flash the area of the screen defined by the given rectangle." self reverse: aRectangle. self forceDisplayUpdate. (Delay forMilliseconds: 100) wait. self reverse: aRectangle. self forceDisplayUpdate. ! ! !DisplayScreen methodsFor: 'other' stamp: ''! replacedBy: aForm do: aBlock "Permits normal display to draw on aForm instead of the display." ScreenSave := self. Display := aForm. aBlock value. Display := self. ScreenSave := nil.! ! !DisplayScreen methodsFor: 'displaying' stamp: 'RAA 6/2/2000 12:09'! flash: aRectangle andWait: msecs "Flash the area of the screen defined by the given rectangle." self reverse: aRectangle. self forceDisplayUpdate. (Delay forMilliseconds: msecs) wait. self reverse: aRectangle. self forceDisplayUpdate. (Delay forMilliseconds: msecs) wait. ! ! !DisplayScreen methodsFor: 'initialization' stamp: 'ar 5/26/2000 00:07'! release "I am no longer Display. Release any resources if necessary"! ! !DisplayScreen methodsFor: 'displaying' stamp: 'StephaneDucasse 10/25/2013 16:16'! copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf map: map ((BitBlt destForm: self sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: rect origin extent: rect extent clipRect: (clipRect intersect: clippingBox ifNone: [ ^ self ] )) colorMap: map) copyBits! ! !DisplayScreen methodsFor: 'other' stamp: 'ar 5/17/2001 21:02'! supportedDisplayDepths "Return all pixel depths supported on the current host platform." ^#(1 2 4 8 16 32 -1 -2 -4 -8 -16 -32) select: [:d | self supportsDisplayDepth: d]! ! !DisplayScreen methodsFor: 'other' stamp: ''! width ^ self boundingBox width! ! !DisplayScreen methodsFor: 'other' stamp: 'pavel.krivanek11/20/2007 09:28'! restoreAfter: aBlock "Evaluate the block, wait for a mouse click, and then restore the screen." UIManager default restoreDisplayAfter: aBlock! ! !DisplayScreen methodsFor: 'testing' stamp: 'ar 5/25/2000 23:34'! isDisplayScreen ^true! ! !DisplayScreen methodsFor: 'screen managing' stamp: 'SeanDeNigris 11/28/2011 21:53'! toggleFullscreen self fullscreen: self isFullscreen not! ! !DisplayScreen methodsFor: 'private' stamp: 'jm 6/3/1998 13:02'! primShowRectLeft: l right: r top: t bottom: b "Copy the given rectangular section of the Display to to the screen. This primitive is not implemented on all platforms. If this fails, retry integer coordinates." "if this fails, coerce coordinates to integers and try again" self primRetryShowRectLeft: l truncated right: r rounded top: t truncated bottom: b rounded. ! ! !DisplayScreen methodsFor: 'screen managing' stamp: 'SeanDeNigris 11/28/2011 21:53'! fullscreenOn self fullscreen: true! ! !DisplayScreen methodsFor: 'private' stamp: 'di 3/3/1999 10:00'! copyFrom: aForm "Take on all state of aForm, with complete sharing" super copyFrom: aForm. clippingBox := super boundingBox! ! !DisplayScreen methodsFor: 'displaying' stamp: 'nice 1/5/2010 15:59'! forceDamageToScreen: allDamage "Force all the damage rects to the screen." | regions rectList | rectList := allDamage. "Note: Reset extra regions at the beginning to prevent repeated errors" regions := extraRegions. extraRegions := nil. regions ifNotNil:[ "exclude extra regions" regions do:[:drawerAndRect| | excluded remaining | excluded := drawerAndRect at: 2. remaining := Array new writeStream. rectList do:[:r| remaining nextPutAll:(r areasOutside: excluded)]. rectList := remaining contents]. ]. rectList do:[:r| self forceToScreen: r]. regions ifNotNil:[ "Have the drawers paint what is needed" regions do:[:drawerAndRect| (drawerAndRect at: 1) forceToScreen]. ].! ! !DisplayScreen methodsFor: 'screen managing' stamp: 'SeanDeNigris 11/28/2011 21:53'! isFullscreen ^ self lastScreenModeSelected.! ! !DisplayScreen methodsFor: 'screen managing' stamp: 'RobRothwell 2/23/2009 22:22'! lastScreenModeSelected ^ LastScreenModeSelected ifNil: [LastScreenModeSelected := false]! ! !DisplayScreen methodsFor: 'other' stamp: 'ar 2/11/1999 18:14'! forceToScreen "Force the entire display area to the screen" ^self forceToScreen: self boundingBox! ! !DisplayScreen methodsFor: 'private' stamp: ''! beDisplay "Primitive. Tell the interpreter to use the receiver as the current display image. Fail if the form is too wide to fit on the physical display. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !DisplayScreen methodsFor: 'other' stamp: 'hmm 6/18/2000 19:14'! primitiveDeferUpdates: aBoolean "Set the deferUpdates flag in the virtual machine. When this flag is true, BitBlt operations on the Display are not automatically propagated to the screen. If this underlying platform does not support deferred updates, this primitive will fail. Answer the receiver if the primitive succeeds, nil if it fails." ^ nil "answer nil if primitive fails" ! ! !DisplayScreen methodsFor: 'displaying' stamp: 'ar 4/19/2001 05:44'! addExtraRegion: aRectangle for: regionDrawer "Register the given rectangle as a region which is drawn by the specified region drawer. The region will be excluded from any updates when #forceDamageToScreen: is called. Note that the rectangle is only valid for a single update cycle; once #forceDamageToScreen: has been called, the region drawer and its region are being removed from the list" extraRegions ifNil:[extraRegions := #()]. extraRegions := extraRegions copyWith: (Array with: regionDrawer with: aRectangle). ! ! !DisplayScreen methodsFor: 'other' stamp: 'SeanDeNigris 11/30/2011 14:29'! fullscreenMode: aBoolean "On platforms that support it, set fullscreen mode to the value of the argument. (Note: you'll need to restore the Display after calling this primitive." "Display fullscreenMode: true. Display newDepth: Display depth" self primitiveFailed ! ! !DisplayScreen methodsFor: 'other' stamp: ''! boundingBox clippingBox == nil ifTrue: [clippingBox := super boundingBox]. ^ clippingBox! ! !DisplayScreen methodsFor: 'private' stamp: 'ar 5/17/2001 21:03'! findAnyDisplayDepthIfNone: aBlock "Return any display depth that is supported on this system. If there is none, evaluate aBlock." #(1 2 4 8 16 32 -1 -2 -4 -8 -16 -32) do:[:bpp| (self supportsDisplayDepth: bpp) ifTrue:[^bpp]. ]. ^aBlock value! ! !DisplayScreen methodsFor: 'other' stamp: 'ar 5/5/1999 23:45'! supportsDisplayDepth: pixelDepth "Return true if this pixel depth is supported on the current host platform. Primitive. Optional." ^#(1 2 4 8 16 32) includes: pixelDepth! ! !DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/28/2000 11:26'! shutDown "Minimize Display memory saved in image" Display shutDown.! ! !DisplayScreen class methodsFor: 'host window access' stamp: 'bf 8/22/2009 01:27'! hostWindowSize: aPoint self primitiveWindowSize: self hostWindowIndex width: aPoint x heigth: aPoint y ! ! !DisplayScreen class methodsFor: 'snapshots' stamp: 'CamilloBruni 5/24/2012 11:07'! actualScreenDepth ^ Display depth! ! !DisplayScreen class methodsFor: 'host window access' stamp: 'EstebanLorenzano 1/10/2012 11:36'! hostWindowTitle: aString self primitiveWindowTitle: self hostWindowIndex string: (UTF8TextConverter default convertFromSystemString: aString)! ! !DisplayScreen class methodsFor: 'deferring' stamp: 'GuillermoPolito 5/1/2012 14:30'! deferUpdates: aBoolean | wasDeferred | "Set the deferUpdates flag in the virtual machine. When this flag is true, BitBlt operations on the Display are not automatically propagated to the screen. If this underlying platform does not support deferred updates, this primitive will fail. Answer whether updates were deferred before if the primitive succeeds, nil if it fails." wasDeferred := DeferringUpdates == true. DeferringUpdates := aBoolean. ^(self primitiveDeferUpdates: aBoolean) ifNotNil: [wasDeferred]! ! !DisplayScreen class methodsFor: 'class initialization' stamp: 'GuillermoPolito 5/1/2012 14:34'! initialize self deferUpdates: false.! ! !DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/17/2001 15:50'! startUp "DisplayScreen startUp" Display setExtent: self actualScreenSize depth: Display nativeDepth. Display beDisplay! ! !DisplayScreen class methodsFor: 'host window access' stamp: 'bf 4/29/2009 21:50'! primitiveWindowTitle: id string: titleString "ignore failure"! ! !DisplayScreen class methodsFor: 'deferring' stamp: 'GuillermoPolito 5/1/2012 14:29'! primitiveDeferUpdates: aBoolean "Set the deferUpdates flag in the virtual machine. When this flag is true, BitBlt operations on the Display are not automatically propagated to the screen. If this underlying platform does not support deferred updates, this primitive will fail. Answer the receiver if the primitive succeeds, nil if it fails." ^ nil "answer nil if primitive fails"! ! !DisplayScreen class methodsFor: 'host window access' stamp: 'bf 8/22/2009 01:26'! primitiveWindowSize: id width: width heigth: height "ignore failure"! ! !DisplayScreen class methodsFor: 'display box access' stamp: 'VeronicaUquillas 6/11/2010 13:57'! depth: depthInteger width: widthInteger height: heightInteger fullscreen: aBoolean "Force Pharo's window (if there's one) into a new size and depth." "DisplayScreen depth: 8 width: 1024 height: 768 fullscreen: false" self primitiveFailed ! ! !DisplayScreen class methodsFor: 'display box access' stamp: ''! boundingBox "Answer the bounding box for the form representing the current display screen." ^Display boundingBox! ! !DisplayScreen class methodsFor: 'snapshots' stamp: ''! actualScreenSize ^ 640@480! ! !DisplayScreen class methodsFor: 'display box access' stamp: 'pavel.krivanek 11/20/2007 10:57'! checkForNewScreenSize "Check whether the screen size has changed and if so take appropriate actions" UIManager default checkForNewDisplaySize! ! !DisplayScreen class methodsFor: 'host window access' stamp: ''! hostWindowIndex ^ 1! ! !DisplaySettings commentStamp: 'TorstenBergmann 2/12/2014 23:26'! Settings for the display! !DisplaySettings class methodsFor: 'settings' stamp: 'SeanDeNigris 11/30/2011 14:41'! displaySettingsOn: aBuilder " (aBuilder pickOne: #displayDepth) label: 'Display depth' translated; parent: #appearance; target: #Display; getSelector: #depth; setSelector: #newDepth:; domainValues: self depthChoices; notInStyle. " (aBuilder setting: #displayFullscreen) label: 'Fullscreen mode' translated; parent: #desktopSettings; target: #Display; getSelector: #isFullscreen; setSelector: #fullscreen:; description: 'On platforms that support it, set fullscreen mode' translated; default: false. ! ! !DisplaySettings class methodsFor: 'settings' stamp: 'AlainPlantec 1/31/2010 17:13'! depthChoices | oldDepth allDepths hasBoth allLabels | oldDepth := Display nativeDepth. allDepths := #(1 -1 2 -2 4 -4 8 -8 16 -16 32 -32 ) select: [:d | Display supportsDisplayDepth: d]. hasBoth := (allDepths anySatisfy: [:d | d > 0]) and: [allDepths anySatisfy: [:d | d < 0]]. allLabels := allDepths collect: [:d | String streamContents: [:s | s print: d abs. hasBoth ifTrue: [s nextPutAll: (d > 0 ifTrue: [' (big endian)'] ifFalse: [' (little endian)'])]]]. ^ (allLabels with: allDepths collect: [:l :d | l -> d]) asArray sort: [:a :b | a value < b value] ! ! !DisplayTransform commentStamp: ''! This class represents a base for generic transformations of 2D points between different coordinate systems (including scaling and rotation). The transformations map objects between one coordinate system and another where it is assumed that a nested hierarchy of transformations can be defined. It is assumed that transformations deal with Integer points. All transformations should return Integer coordinates (even though float points may be passed in as argument). Compositions of transformations MUST work in the following order. A 'global' transformation (the argument in #composedWithGlobal:) is defined as a transformation that takes place between the receiver (the 'local') transformation and any 'global' point computations, whereas a 'local' transformation (e.g., the argument in #composedWithLocal:) takes place between the receiver ('global') and any 'local' points. For the transformation methods this means that combining a global and a local transformation will result in the following order: globalPointToLocal: globalPoint "globalPoint -> globalTransform -> localTransform -> locaPoint" ^localTransform globalPointToLocal: (globalTransform globalPointToLocal: globalPoint) localPointToGlobal: localPoint "localPoint -> localTransform -> globalTransform -> globalPoint" ^globalTransform localPointToGlobal: (localTransform localPointToGlobal: localPoint) ! !DisplayTransform methodsFor: 'transforming rects' stamp: 'ar 11/2/1998 16:19'! localBoundsToGlobal: aRectangle "Transform aRectangle from local coordinates into global coordinates" ^Rectangle encompassing: (self localPointsToGlobal: aRectangle corners)! ! !DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 16:17'! isIdentity "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself." ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 19:59'! asCompositeTransform "Represent the receiver as a composite transformation" ^CompositeTransform new globalTransform: self localTransform: self species identity! ! !DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:18'! localPointToGlobal: aPoint "Transform aPoint from local coordinates into global coordinates" ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'transforming rects' stamp: 'di 10/25/1999 12:49'! sourceQuadFor: aRectangle ^ aRectangle innerCorners collect: [:p | self globalPointToLocal: p]! ! !DisplayTransform methodsFor: 'initialize' stamp: 'ar 11/2/1998 23:18'! setIdentity "Initialize the receiver to the identity transformation (e.g., not affecting points)" ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/9/1998 14:35'! localPointsToGlobal: inArray "Transform all the points of inArray from local into global coordinates" ^inArray collect:[:pt| self localPointToGlobal: pt]! ! !DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:48'! isMorphicTransform "Return true if the receiver is a MorphicTransform, that is specifies the transformation values explicitly." ^false! ! !DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 16:16'! isPureTranslation "Return true if the receiver specifies no rotation or scaling." ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'composing' stamp: 'ar 11/2/1998 16:41'! composedWithLocal: aTransformation "Return the composition of the receiver and the local transformation passed in. A 'local' transformation is defined as a transformation that takes place between the receiver (the 'global') transformation and any 'local' point computations, e.g., for the methods globalPointToLocal: globalPoint globalPoint -> globalTransform -> localTransform -> locaPoint localPointToGlobal: localPoint localPoint -> localTransform -> globalTransform -> globalPoint " self isIdentity ifTrue:[^ aTransformation]. aTransformation isIdentity ifTrue:[^ self]. ^ CompositeTransform new globalTransform: self localTransform: aTransformation! ! !DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:47'! isCompositeTransform "Return true if the receiver is a composite transformation. Composite transformations may have impact on the accuracy." ^false! ! !DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:48'! isMatrixTransform2x3 "Return true if the receiver is 2x3 matrix transformation" ^false! ! !DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/9/1998 14:35'! globalPointsToLocal: inArray "Transform all the points of inArray from global into local coordinates" ^inArray collect:[:pt| self globalPointToLocal: pt]! ! !DisplayTransform methodsFor: 'transforming points' stamp: 'gh 10/22/2001 13:24'! invertBoundsRect: aRectangle "Return a rectangle whose coordinates have been transformed from local back to global coordinates." ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'accessing' stamp: 'ar 11/2/1998 19:43'! inverseTransformation "Return the inverse transformation of the receiver" ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'composing' stamp: 'ar 11/2/1998 16:15'! composedWithGlobal: aTransformation "Return the composition of the receiver and the global transformation passed in. A 'global' transformation is defined as a transformation that takes place between the receiver (the 'local') transformation and any 'global' point computations, e.g., for the methods globalPointToLocal: globalPoint globalPoint -> globalTransform -> localTransform -> locaPoint localPointToGlobal: localPoint localPoint -> localTransform -> globalTransform -> globalPoint " ^aTransformation composedWithLocal: self! ! !DisplayTransform methodsFor: 'transforming rects' stamp: 'ar 11/2/1998 16:19'! globalBoundsToLocal: aRectangle "Transform aRectangle from global coordinates into local coordinates" ^Rectangle encompassing: (self globalPointsToLocal: aRectangle corners)! ! !DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:17'! globalPointToLocal: aPoint "Transform aPoint from global coordinates into local coordinates" ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:01'! asMatrixTransform2x3 "Represent the receiver as a 2x3 matrix transformation" ^self subclassResponsibility! ! !DisplayTransform class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 20:55'! identity ^self new setIdentity! ! !DoItDeclaration commentStamp: ''! I represent the declaration of some code to evaluate. My contents are the code to evaluate. Sending me the message #import makes me evaluate the code and return the result of the computation. Be careful, my #import method also handles ChangeSet interaction so far, handling Changeset preambles and Postscripts.! !DoItDeclaration methodsFor: 'importing' stamp: 'MartinDias 2/7/2014 16:11'! importFor: requestor self flag: #fixme. "Ugly hack to parse preamble and postcript as a do it." ((contents beginsWith: '"Change Set:') and: [ ChangeSet current preambleString isNil ]) ifTrue: [ ChangeSet current preambleString: contents ]. ((contents beginsWith: '"Postscript:') and: [ ChangeSet current postscriptString isNil ]) ifTrue: [ ChangeSet current postscriptString: contents ]. ^Smalltalk compiler class new source: contents; requestor: requestor; logged: true; evaluate.! ! !DoItDeclaration methodsFor: 'importing' stamp: 'CamilloBruni 7/10/2013 16:00'! import ^ self importFor: nil! ! !DockingBarMorph commentStamp: 'LaurentLaffont 3/4/2011 22:42'! I'm a kind of container which adhere to one edge of the screen. See me in action with: DockingBarMorph new addMorph: (SimpleButtonMorph new label: 'Say hello'; target: [UIManager inform: 'Hello']; actionSelector: #value); addMorph: (SimpleButtonMorph new label: 'Say bonjour'; target: [UIManager inform: 'Bonjour']; actionSelector: #value); addMorph: (SimpleButtonMorph new label: 'Close'; target: [DockingBarMorph allInstances last delete]; actionSelector: #value); adhereToBottom; openInWorld.! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:57'! fillsOwner: aBoolean "Instruct the receiver to fill the owner or not" fillsOwner := aBoolean. self updateLayoutProperties! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 14:28'! autoGradient: aBoolean "Instruct the receiver to fill the owner or not" autoGradient := aBoolean. self updateColor! ! !DockingBarMorph methodsFor: 'menu' stamp: 'StephaneDucasse 4/22/2012 16:48'! avoidVisibleBordersAtEdgeString "Answer the string to be shown in a menu to represent the visible status" ^ (self avoidVisibleBordersAtEdge) -> 'avoid visible borders at edge' translated! ! !DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/10/2004 16:48'! add: wordingString icon: aForm subMenu: aMenuMorph "Append the given submenu with the given label." ^ self add: wordingString icon: aForm help: nil subMenu: aMenuMorph ! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'! isAdheringToLeft "Answer true if the receiver is adhering to left" ^ self edgeToAdhereTo == #left! ! !DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/10/2004 16:48'! add: wordingString icon: aForm help: helpString subMenu: aMenuMorph "Append the given submenu with the given label." | item | item := MenuItemMorph new. item contents: wordingString. item subMenu: aMenuMorph. item icon: aForm. helpString isNil ifFalse: [item setBalloonText: helpString]. self addMorphBack: item! ! !DockingBarMorph methodsFor: 'private - accessing' stamp: 'MarcusDenker 10/12/2013 11:41'! usedWidthByPredominantDockingBarsOfChastes: predominantChastes "Private - convenience" ^(self predominantDockingBarsOfChastes: predominantChastes) ifEmpty: [0] ifNotEmpty: [:predominants | (predominants collect: [:each | each width]) sum]! ! !DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:26'! toggleAvoidVisibleBordersAtEdge self avoidVisibleBordersAtEdge: self avoidVisibleBordersAtEdge not! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'MarcusDenker 12/11/2009 23:58'! color: aColor "Set the receiver's color." super color: aColor. originalColor := aColor asColor. self updateColor! ! !DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 9/1/2004 15:29'! updateBounds "private - update the receiver's bounds" self updateExtent. self isFloating ifFalse: [self updatePosition]! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 9/9/2004 19:45'! rootMenu ^ self! ! !DockingBarMorph methodsFor: 'initialization' stamp: 'FernandoOlivero 4/12/2011 09:44'! initialize "initialize the receiver" super initialize. "" selectedItem := nil. activeSubMenu := nil. fillsOwner := true. avoidVisibleBordersAtEdge := true. autoGradient := self theme preferGradientFill. "" self setDefaultParameters. "" self beFloating. "" self layoutInset: 0. ! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 14:28'! autoGradient "Answer if the receiver is in autoGradient mode" ^ autoGradient! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:58'! isVertical "Answer true if the receiver has a vertical layout" ^ self isAdheringToLeft or: [self isAdheringToRight] ! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'! adhereToRight "Instract the receiver to adhere to right" self adhereTo: #right! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:58'! isHorizontal "Answer true if the receiver has a horizontal layout" ^ self isAdheringToTop or: [self isAdheringToBottom]! ! !DockingBarMorph methodsFor: 'construction' stamp: 'dgd 8/31/2004 11:34'! addSpacer "Add a new spacer to the receiver. Spacer are objects that try to use as much space as they can" self addMorphBack: (AlignmentMorph newSpacer: Color transparent)! ! !DockingBarMorph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/1/2004 18:41'! noteNewOwner: aMorph "I have just been added as a submorph of aMorph" super noteNewOwner: aMorph. self submorphs do: [:each | each adjustLayoutBounds]. ! ! !DockingBarMorph methodsFor: 'private - layout' stamp: 'MarcusDenker 12/12/2009 00:06'! updateLayoutProperties "private - update the layout properties based on adhering, fillsOwner and avoidVisibleBordersAtEdge preferencs" (self isHorizontal or: [self isFloating]) ifTrue: [self listDirection: #leftToRight] ifFalse: [self listDirection: #topToBottom]. self hResizing: #shrinkWrap. self vResizing: #shrinkWrap. self fillsOwner ifTrue: [ self isHorizontal ifTrue: [self hResizing: #spaceFill]. self isVertical ifTrue: [self vResizing: #spaceFill]]. ! ! !DockingBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/26/2007 15:27'! originalColor "Answer the original color." ^originalColor! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'! isAdheringToTop "Answer true if the receiver is adhering to top" ^ self edgeToAdhereTo == #top! ! !DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/1/2004 19:10'! addLine "Append a divider line to this menu. Suppress duplicate lines." submorphs isEmpty ifTrue: [^ self]. (self lastSubmorph isKindOf: MenuLineMorph) ifFalse: [self addMorphBack: MenuLineMorph new]. ! ! !DockingBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/29/2007 15:31'! add: wordingString font: aFont icon: aForm help: helpString subMenu: aMenuMorph "Append the given submenu with the given label." | item | item := ToggleMenuItemMorph new. item font: aFont; contents: wordingString; subMenu: aMenuMorph; icon: aForm. helpString isNil ifFalse: [item setBalloonText: helpString]. self addMorphBack: item! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 9/13/2004 19:59'! addBlankIconsIfNecessary: anIcon "If any of my items have an icon, ensure that all do by using anIcon for those that don't" self items reject: [:each | each hasIconOrMarker] thenDo: [:each | each icon: anIcon]! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'! adhereToBottom "Instract the receiver to adhere to bottom" self adhereTo:#bottom! ! !DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:27'! toggleAutoGradient self autoGradient: self autoGradient not! ! !DockingBarMorph methodsFor: 'testing' stamp: 'dgd 8/31/2004 15:00'! isDockingBar "Return true if the receiver is a docking bar" ^ true! ! !DockingBarMorph methodsFor: 'menu' stamp: 'StephaneDucasse 4/22/2012 16:47'! autoGradientString "Answer the string to be shown in a menu to represent the 'resistsRemoval' status" ^ (self autoGradient) -> 'auto gradient' translated! ! !DockingBarMorph methodsFor: 'submorphs-add/remove' stamp: 'dgd 9/1/2004 19:26'! delete activeSubMenu ifNotNil: [activeSubMenu delete]. ^ super delete! ! !DockingBarMorph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 10/17/2009 17:03'! aboutToBeGrabbedBy: aHand "The morph is about to be grabbed, make it float" self beFloating. self updateBounds. self updateColor. (self bounds containsPoint: aHand position) ifFalse: [self center: aHand position]. ! ! !DockingBarMorph methodsFor: 'control' stamp: 'dgd 9/1/2004 16:48'! deleteIfPopUp: evt evt ifNotNil: [evt hand releaseMouseFocus: self]! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'! isAdheringToRight "Answer true if the receiver is adhering to right" ^ self edgeToAdhereTo == #right! ! !DockingBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 12/18/2009 22:32'! wantsYellowButtonMenu "Answer true if the receiver wants a yellow button menu. Fixed for when defaultYellowButtonMenuEnabled setting is off" ^ self defaultYellowButtonMenuEnabled! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:35'! fillsOwner "Answer if the receiver is in fillOwner mode" ^ fillsOwner! ! !DockingBarMorph methodsFor: 'private - layout' stamp: 'MarcusDenker 12/11/2009 23:58'! gradientRamp: colorRamp gradientRamp := colorRamp. self updateColor! ! !DockingBarMorph methodsFor: 'events-processing' stamp: 'dgd 9/9/2004 21:43'! handleFocusEvent: evt "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." (evt isMouse and:[ evt isMouseUp ]) ifTrue:[^ self]. self processEvent: evt. "Need to handle keyboard input if we have the focus." evt isKeyboard ifTrue: [^ self handleEvent: evt]. "We need to handle button clicks outside and transitions to local popUps so throw away everything else" (evt isMouseOver or:[evt isMouse not]) ifTrue:[^self]. "What remains are mouse buttons and moves" evt isMove ifFalse:[^self handleEvent: evt]. "handle clicks outside by regular means" "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." selectedItem ifNotNil:[(selectedItem activateSubmenu: evt) ifTrue:[^self]]. ! ! !DockingBarMorph methodsFor: 'construction' stamp: 'dgd 9/1/2004 19:08'! add: aString subMenu: aMenuMorph "Append the given submenu with the given label." self add: aString icon: nil subMenu: aMenuMorph ! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 16:39'! stayUp ^ false! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 16:33'! wantsToBeTopmost "Answer if the receiver want to be one of the topmost objects in its owner" ^ true! ! !DockingBarMorph methodsFor: 'change reporting' stamp: 'dgd 9/1/2004 15:29'! ownerChanged "The receiver's owner has changed its layout. " self updateBounds. ^ super ownerChanged! ! !DockingBarMorph methodsFor: 'private - accessing' stamp: 'MarcusDenker 10/12/2013 11:40'! usedHeightByPredominantDockingBarsOfChastes: predominantChastes "Private - convenience" ^(self predominantDockingBarsOfChastes: predominantChastes) ifEmpty: [0] ifNotEmpty: [:predominants | (predominants collect: [:each | each height]) sum] ! ! !DockingBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/25/2006 13:37'! adoptPaneColor: paneColor "Change our color too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. originalColor := paneColor. self borderStyle baseColor: paneColor. self updateColor! ! !DockingBarMorph methodsFor: 'construction' stamp: 'MarcusDenker 10/26/2011 14:55'! addSpace: sizePointOrNumber "Add a new space of the given size to the receiver." | space | space := Morph new. space extent: sizePointOrNumber asPoint. space color: Color transparent. space borderWidth: 0. self addMorphBack: space! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/30/2004 23:13'! isFloating "Answer true if the receiver has a float layout" ^ self isHorizontal not and: [self isVertical not]! ! !DockingBarMorph methodsFor: 'initialization' stamp: 'MarcusDenker 10/26/2011 15:09'! setDefaultParameters "private - set the default parameter using the current theme settings as the inspiration source" self color: self theme settings derivedMenuColor; borderWidth: self theme settings menuBorderWidth; borderColor: self theme settings menuBorderColor! ! !DockingBarMorph methodsFor: 'menus' stamp: 'dgd 9/1/2004 15:29'! snapToEdgeIfAppropriate (self owner isNil or: [self owner isHandMorph]) ifTrue: [^ self]. "" self updateBounds! ! !DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:24'! toggleFillsOwner self fillsOwner: self fillsOwner not! ! !DockingBarMorph methodsFor: 'private' stamp: 'dgd 9/9/2004 21:24'! selectedItem selectedItem isNil ifTrue: [^ nil]. ^ selectedItem isSelected ifTrue: [ selectedItem] ifFalse: [ nil]! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:38'! avoidVisibleBordersAtEdge "Answer if the receiver is in avoidVisibleBordersAtEdge mode" ^ avoidVisibleBordersAtEdge! ! !DockingBarMorph methodsFor: 'rounding' stamp: 'dgd 8/31/2004 14:16'! roundedCorners "Return a list of those corners to round" self isAdheringToTop ifTrue: [^ #(2 3 )]. self isAdheringToBottom ifTrue: [^ #(1 4 )]. self isAdheringToLeft ifTrue: [^ #(3 4 )]. self isAdheringToRight ifTrue: [^ #(1 2 )]. ^ #(1 2 3 4 )! ! !DockingBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 14:24'! extent: aPoint "Change the receiver's extent. optimized to not keep updating the (gradient) color!!" |old| old := self extent. super extent: aPoint. self extent = old ifTrue: [^self]. self updateColor! ! !DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 11/2/2004 11:55'! updateColor "private - update the receiver's color" | fill | self autoGradient ifFalse: [^ self]. "" fill := GradientFillStyle ramp: self gradientRamp. "" fill origin: self topLeft. self isVertical ifTrue: [fill direction: self width @ 0] ifFalse: [fill direction: 0 @ self height]. "" self fillStyle: fill! ! !DockingBarMorph methodsFor: 'menu' stamp: 'MarcusDenker 12/11/2009 23:57'! addCustomMenuItems: aMenu hand: aHandMorph "Populate aMenu with appropriate menu items for a yellow-button (context menu) click." super addCustomMenuItems: aMenu hand: aHandMorph. aMenu addLine. aMenu addUpdating: #autoGradientString action: #toggleAutoGradient. self isFloating ifFalse: [ aMenu addUpdating: #fillsOwnerString action: #toggleFillsOwner. aMenu addUpdating: #avoidVisibleBordersAtEdgeString action: #toggleAvoidVisibleBordersAtEdge]! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 11:57'! isAdheringToBottom "Answer true if the receiver is adhering to bottom" ^ self edgeToAdhereTo == #bottom! ! !DockingBarMorph methodsFor: 'private - layout' stamp: 'MarcusDenker 10/12/2013 11:38'! updateExtent "private - update the receiver's extent" | margin usedHeight | self fullBounds. self fillsOwner ifFalse: [^ self]. margin := self avoidVisibleBordersAtEdge ifTrue: [self borderWidth * 2] ifFalse: [0]. self isHorizontal ifTrue: [self width: self owner width + margin]. self isVertical ifTrue: [ usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top #bottom ). self height: self owner height + margin - usedHeight]! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:57'! avoidVisibleBordersAtEdge: aBoolean "Instruct the receiver to avoid showing the borders at edge" avoidVisibleBordersAtEdge := aBoolean. self updateLayoutProperties.! ! !DockingBarMorph methodsFor: 'events' stamp: 'dgd 9/1/2004 19:29'! activate: evt "Receiver should be activated; e.g., so that control passes correctly." evt hand newMouseFocus: self! ! !DockingBarMorph methodsFor: 'private - accessing' stamp: 'MarcusDenker 12/11/2009 23:58'! adhereTo: edgeSymbol "Private - Instruct the receiver to adhere to the given edge. Options: #left #top #right #bottom or #none" (#(#left #top #right #bottom #none ) includes: edgeSymbol) ifFalse: [^ self error: 'invalid option']. self setToAdhereToEdge: edgeSymbol. self updateLayoutProperties. self updateColor! ! !DockingBarMorph methodsFor: 'private - accessing' stamp: 'MarcusDenker 12/12/2009 00:00'! predominantDockingBarsOfChastes: predominantChastes "Private - Answer a collection of the docking bar of my owner that are predominant to the receiver. By 'predominant' we mean docking bar that have the right to get a position before the receiver. The predominance of individual living in the same chaste is determinated by the arrival order. " | allDockingBars byChaste byArrival | (self owner isNil or: [self owner isHandMorph]) ifTrue: [^ #()]. allDockingBars := self owner dockingBars. byChaste := allDockingBars select: [:each | predominantChastes includes: each edgeToAdhereTo]. (predominantChastes includes: self edgeToAdhereTo) ifFalse: [^ byChaste]. byChaste := byChaste reject: [:each | each edgeToAdhereTo = self edgeToAdhereTo]. byArrival := allDockingBars select: [:each | each edgeToAdhereTo = self edgeToAdhereTo]. byArrival := byArrival copyAfter: self. ^ byChaste , byArrival! ! !DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 11/2/2004 11:59'! gradientRamp ^ gradientRamp ifNil:[{0.0 -> originalColor muchLighter. 1.0 -> originalColor twiceDarker}]! ! !DockingBarMorph methodsFor: 'menu' stamp: 'StephaneDucasse 4/22/2012 16:48'! fillsOwnerString "Answer the string to be shown in a menu to represent the fills owner status" ^ (self fillsOwner) -> 'fills owner' translated ! ! !DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 8/31/2004 13:56'! edgeToAdhereTo "private - answer the edge where the receiver is adhering to" ^ self valueOfProperty: #edgeToAdhereTo ifAbsent: [#none]! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:02'! beFloating "Instract the receiver to be floating" self adhereTo: #none! ! !DockingBarMorph methodsFor: 'control' stamp: 'AlainPlantec 11/5/2011 14:30'! activeSubmenu: aSubmenu activeSubMenu ifNotNil: [activeSubMenu delete]. activeSubMenu := aSubmenu. aSubmenu isNil ifTrue: [^ self]. activeSubMenu selectItem: nil event: nil. activeSubMenu activatedFromDockingBar: self. activeSubMenu borderColor: self borderColor. activeSubMenu beSticky. activeSubMenu resistsRemoval: true. activeSubMenu removeMatchString.! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'! adhereToLeft "Instract the receiver to adhere to left" self adhereTo: #left! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'! adhereToTop "Instract the receiver to adhere to top" self adhereTo: #top! ! !DockingBarMorph methodsFor: 'private - layout' stamp: 'gvc 11/14/2006 15:37'! updatePosition "private - update the receiver's position. Fixed so as not to keep changing position!! (called twice if adhereing)" | edgeSymbol margin | edgeSymbol := self edgeToAdhereTo. edgeSymbol == #none ifTrue: [self perform: (edgeSymbol , ':') asSymbol with: (self owner perform: edgeSymbol)]. "" margin := self avoidVisibleBordersAtEdge ifTrue: [self borderWidth asPoint] ifFalse: [0 asPoint]. "" self isAdheringToTop ifTrue: [| usedHeight | usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ). self topLeft: self owner topLeft - margin + (0 @ usedHeight)]. self isAdheringToBottom ifTrue: [| usedHeight | usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#bottom ). self bottomLeft: self owner bottomLeft + (-1 @ 1 * margin) - (0 @ usedHeight)]. "" self isAdheringToLeft ifTrue: [| usedHeight usedWidth | usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ). usedWidth := self usedWidthByPredominantDockingBarsOfChastes: #(#left ). self topLeft: self owner topLeft - margin + (usedWidth @ usedHeight)]. self isAdheringToRight ifTrue: [| usedHeight usedWidth | usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top ). usedWidth := self usedWidthByPredominantDockingBarsOfChastes: #(#right ). self topRight: self owner topRight + (1 @ -1 * margin) + (usedWidth negated @ usedHeight)]! ! !DockingBarMorph methodsFor: 'dropping/grabbing' stamp: 'MarcusDenker 12/11/2009 23:59'! justDroppedInto: aMorph event: anEvent | ownerBounds leftRegion droppedPosition rightRegion topRegion bottomRegion | super justDroppedInto: aMorph event: anEvent. self owner isNil ifTrue: [^ self]. ownerBounds := aMorph bounds. topRegion := ownerBounds bottom: ownerBounds top + (ownerBounds height // 5). bottomRegion := ownerBounds top: ownerBounds bottom - (ownerBounds height // 5). leftRegion := ownerBounds right: ownerBounds left + (ownerBounds width // 5). leftRegion := leftRegion top: topRegion bottom. leftRegion := leftRegion bottom: bottomRegion top. rightRegion := ownerBounds left: ownerBounds right - (ownerBounds width // 5). rightRegion := rightRegion top: topRegion bottom. rightRegion := rightRegion bottom: bottomRegion top. droppedPosition := anEvent position. (topRegion containsPoint: droppedPosition) ifTrue: [ ^ self adhereToTop]. (bottomRegion containsPoint: droppedPosition) ifTrue: [ ^ self adhereToBottom]. (leftRegion containsPoint: droppedPosition) ifTrue: [ ^ self adhereToLeft]. (rightRegion containsPoint: droppedPosition) ifTrue: [ ^ self adhereToRight]. self beFloating! ! !DockingBarMorph methodsFor: 'wiw support' stamp: 'dgd 9/7/2004 19:25'! morphicLayerNumber "helpful for insuring some morphs always appear in front of or behind others. smaller numbers are in front" ^ 11! ! !DockingBarMorph methodsFor: 'control' stamp: 'dgd 9/1/2004 16:40'! selectItem: aMenuItem event: anEvent selectedItem ifNotNil: [selectedItem deselect: anEvent]. selectedItem := aMenuItem. selectedItem ifNotNil: [selectedItem select: anEvent]! ! !DockingBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/26/2010 11:19'! mouseDown: anEvent "Release the mouse focus if clicked outside the receiver." (self fullContainsPoint: anEvent position) ifFalse: [anEvent hand releaseMouseFocus: self]. ^super mouseDown: anEvent! ! !DoesNotUnderstandCatcher commentStamp: 'TorstenBergmann 1/30/2014 08:53'! Utility class to catch messages! !DoesNotUnderstandCatcher methodsFor: 'reflective operations' stamp: 'ClementBera 12/3/2012 14:16'! doesNotUnderstand: aMessage "returns the message caught" ^aMessage! ! !DoesNotUnderstandDebugAction commentStamp: ''! A DoesNotUnderstandDebugAction is a debugging action that can create a method if the debugger was opened as a result of a #doesNotUnderstand mesage send. ! !DoesNotUnderstandDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/20/2013 19:17'! id ^ #doesNotUnderstand! ! !DoesNotUnderstandDebugAction methodsFor: 'actions' stamp: 'CamilleTeruel 3/7/2014 12:04'! executeAction "Should only be called when the debugger was created in response to a MessageNotUnderstood exception. Create a stub for the method that was missing and proceed into it." | msg msgCategory chosenClass | msg := self interruptedContext tempAt: 1. chosenClass := self askForSuperclassOf: self interruptedContext receiver class toImplement: msg selector ifCancel: [^self]. msgCategory := (self askForCategoryIn: chosenClass default: 'as yet unclassified'). self session implement: msg classified: msgCategory inClass: chosenClass forContext: self interruptedContext. self debugger selectTopContext! ! !DoesNotUnderstandDebugAction methodsFor: 'testing' stamp: 'AndreiChis 9/20/2013 17:43'! appliesToDebugger: aDebugger ^ aDebugger session isInterruptedContextDoesNotUnderstand ! ! !DoesNotUnderstandDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/20/2013 19:17'! defaultLabel ^ 'Create'! ! !DoesNotUnderstandDebugAction methodsFor: 'private' stamp: 'AndreiChis 10/5/2013 21:54'! askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock | classes chosenClassIndex | classes := aClass withAllSuperclasses addAll: (aClass traits sort: [ :t1 :t2 | t1 asString < t2 asString ]); yourself. chosenClassIndex := UIManager default chooseFrom: (classes collect: [:c | c name]) title: 'Define #', aSelector, ' in which class?'. chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. ^ classes at: chosenClassIndex! ! !DoesNotUnderstandDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/20/2013 16:07'! defaultOrder ^ 45! ! !DoesNotUnderstandDebugAction methodsFor: 'private' stamp: 'AndreiChis 10/5/2013 21:49'! askForCategoryIn: aClass default: aString | categoryName | categoryName := AbstractTool requestProtocolNameFor: aClass initialAnswer: aString. categoryName ifNil: [^aString]. ^ categoryName isEmptyOrNil ifTrue: [^ aString] ifFalse: [ categoryName ]! ! !DoesNotUnderstandDebugAction class methodsFor: 'as yet unclassified' stamp: 'AndreiChis 9/20/2013 15:52'! actionType ! ! !DomainError commentStamp: ''! I am DomainError, an ArithmeticException indicating that some argument falls outside an expected domain, [from, to] When my valid interval is left- or right-open, use signal: creation protocol to provide a custom messageText rather than the default [from, to] notation.! !DomainError methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/15/2011 16:33'! to ^ to! ! !DomainError methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/15/2011 16:33'! from: start from := start! ! !DomainError methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/15/2011 16:33'! to: end to := end! ! !DomainError methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/15/2011 16:33'! from ^ from! ! !DomainError class methodsFor: 'signaling' stamp: 'nice 7/15/2011 13:55'! signal: signallerText from: start ^ self signal: signallerText from: start to: Float infinity! ! !DomainError class methodsFor: 'signaling' stamp: 'HenrikSperreJohansen 1/19/2012 16:26'! signalFrom: start to: end | msgStart msgEnd | msgStart := (start isFloat and: [start isFinite not]) ifTrue: ['(-infinity'] ifFalse: ['[', start printString]. msgEnd := (end isFloat and: [end isFinite not]) ifTrue: ['infinity)'] ifFalse: [end printString, ']']. ^ self signal: 'Value outside ', msgStart, ' , ' , msgEnd from: start; to: end! ! !DomainError class methodsFor: 'signaling' stamp: 'nice 7/15/2011 13:56'! signalTo: end ^ self signalFrom: Float infinity negated to: end! ! !DomainError class methodsFor: 'signaling' stamp: 'nice 7/15/2011 13:56'! signal: signallerText to: end ^ self signal: signallerText from: Float infinity negated to: end! ! !DomainError class methodsFor: 'signaling' stamp: 'nice 7/15/2011 13:54'! signal: signallerText from: start to: end ^ self new from: start; to: end; signal: signallerText! ! !DomainError class methodsFor: 'signaling' stamp: 'SvenVanCaekenberghe 4/15/2011 16:35'! signalFrom: start ^ self signalFrom: start to: Float infinity! ! !DosTimestamp commentStamp: ''! DOS stores timestamps, in local time, as 32 bit integers with the following format: 32 bits (low to high): Low 16 bits: Bits 0-4: seconds / 2 Bits 5-10: minutes 0-59 Bits 11-15: hours 0-23 High 16 bits: 16-20: day of month 1-31 21-24: month 1-12 25-31: year offset from 1980 (e.g. 1981 -> 1) References (with visual aids): http://blogs.msdn.com/b/oldnewthing/archive/2003/09/05/54806.aspx & http://mindprod.com/jgloss/zip.html! !DosTimestamp methodsFor: 'comparing' stamp: 'SeanDeNigris 5/21/2012 16:54'! hash ^ self value hash.! ! !DosTimestamp methodsFor: 'private' stamp: 'SeanDeNigris 5/21/2012 16:43'! low16Bits ^ value & 2r1111111111111111.! ! !DosTimestamp methodsFor: 'private' stamp: 'SeanDeNigris 5/21/2012 17:16'! epoch ^ self class epoch.! ! !DosTimestamp methodsFor: 'accessing' stamp: 'SeanDeNigris 5/21/2012 16:36'! value ^ value.! ! !DosTimestamp methodsFor: 'comparing' stamp: 'SeanDeNigris 5/21/2012 16:54'! = rhs ^ self value = rhs value.! ! !DosTimestamp methodsFor: 'printing' stamp: 'SeanDeNigris 5/21/2012 16:57'! printOn: aStream aStream nextPutAll: self asDateAndTime printString; nextPutAll: ' ('; nextPutAll: self value asString; nextPut: $).! ! !DosTimestamp methodsFor: 'private' stamp: 'SeanDeNigris 5/21/2012 16:49'! date "See class comment for format details" | encodedDate yearsSinceDosEpoch month day year | encodedDate := self high16Bits. yearsSinceDosEpoch := encodedDate >> 9. "High 7 bits" month := encodedDate >> 5 & 2r1111. "Middle 4 bits" day := encodedDate & 2r11111. "Low 5 bits" year := self epoch year + yearsSinceDosEpoch. ^ Date year: year month: month day: day. ! ! !DosTimestamp methodsFor: 'converting' stamp: 'SeanDeNigris 5/21/2012 16:42'! asDateAndTime ^ DateAndTime date: self date time: self time.! ! !DosTimestamp methodsFor: 'private' stamp: 'SeanDeNigris 5/21/2012 16:43'! time "See class comment for format details" | encodedTime hours minutes secondsHalved seconds | encodedTime := self low16Bits. hours := encodedTime >> 11. "High 5 bits" minutes := encodedTime >> 5 & 2r111111. "Middle 6 bits" secondsHalved := encodedTime & 2r11111. "Low 5 bits" seconds := (secondsHalved * 2) floor. ^ Time hour: hours minute: minutes second: seconds.! ! !DosTimestamp methodsFor: 'private' stamp: 'SeanDeNigris 5/21/2012 16:43'! high16Bits ^ value >> 16.! ! !DosTimestamp methodsFor: 'private' stamp: 'SeanDeNigris 5/21/2012 16:29'! initializeValue: anInteger value := anInteger. ^ self.! ! !DosTimestamp class methodsFor: 'instance creation' stamp: 'SeanDeNigris 5/21/2012 17:15'! fromDateAndTime: aDateAndTime | dateValue timeValue local | local := aDateAndTime asLocal. dateValue := self dateValueFrom: local asDate. timeValue := self timeValueFrom: local asTime. ^ self on: (dateValue << 16) + timeValue.! ! !DosTimestamp class methodsFor: 'instance creation' stamp: 'SeanDeNigris 5/21/2012 16:22'! on: anInteger ^ self new initializeValue: anInteger.! ! !DosTimestamp class methodsFor: 'accessing' stamp: 'CamilloBruni 8/22/2013 22:22'! epoch ^ DateAndTime dosEpoch! ! !DosTimestamp class methodsFor: 'private' stamp: 'SeanDeNigris 5/21/2012 17:13'! dateValueFrom: aDate | dosYear dosMonth dosDay | dosYear := aDate year - DateAndTime dosEpoch year << 9. dosMonth := aDate monthIndex << 5. dosDay := aDate dayOfMonth. ^ dosYear + dosMonth + dosDay.! ! !DosTimestamp class methodsFor: 'private' stamp: 'SeanDeNigris 5/21/2012 17:13'! timeValueFrom: aTime | dosHours dosMinutes dosSeconds | dosHours := aTime hour << 11. dosMinutes := aTime minute << 5. dosSeconds := (aTime second / 2) floor. ^ dosHours + dosMinutes + dosSeconds.! ! !DosTimestampTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/21/2012 16:32'! testFromDateAndTime | aDateAndTime timestamp | timestamp := DosTimestamp fromDateAndTime: '21 May 2012 3:02:44 pm' asDateAndTime. self assert: timestamp value equals: 16r40B57856.! ! !DosTimestampTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/21/2012 16:53'! testTimesAreLocal | remoteDateAndTime remoteTimestamp localTimestamp | remoteDateAndTime := DateAndTime current offset: DateAndTime localOffset + 2 hours. remoteTimestamp := DosTimestamp fromDateAndTime: remoteDateAndTime. localTimestamp := DosTimestamp fromDateAndTime: remoteDateAndTime asLocal. self assert: remoteTimestamp equals: localTimestamp.! ! !DosTimestampTest methodsFor: 'tests' stamp: 'SeanDeNigris 5/21/2012 16:49'! testAsDateAndTime | remoteDatetime timestamp | timestamp := DosTimestamp on: 16r40B57856. self assert: timestamp asDateAndTime equals: '21 May 2012 3:02:44 pm' asDateAndTime.! ! !DoubleLink commentStamp: 'SvenVanCaekenberghe 1/12/2014 14:15'! I am DoubleLink, the elementary part of a DoubleLinkedList. I hold a value, as well as a link to my successor (nextLink) and to my predecessor (previousLink) - both can be nil.! !DoubleLink methodsFor: 'converting' stamp: 'SvenVanCaekenberghe 12/16/2013 20:12'! asDoubleLink ^ self! ! !DoubleLink methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:41'! value ^ value! ! !DoubleLink methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:40'! value: anObject value := anObject! ! !DoubleLink methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:43'! hasPredecessor ^ previousLink notNil! ! !DoubleLink methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/5/2013 16:53'! clearLinks nextLink := previousLink := nil! ! !DoubleLink methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:40'! previousLink ^ previousLink! ! !DoubleLink methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:43'! hasSuccessor ^ nextLink notNil! ! !DoubleLink methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:40'! nextLink ^ nextLink! ! !DoubleLink methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:40'! previousLink: anObject previousLink := anObject! ! !DoubleLink methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:40'! nextLink: anObject nextLink := anObject! ! !DoubleLink class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 12/2/2013 16:41'! value: anObject ^ self new value: anObject; yourself! ! !DoubleLinkedList commentStamp: ''! I am DoubleLinkedList, an ordered list data structure consisting of objects, most likely DoubleLinks or something compatible, connected to each other by forward and backwards links.! !DoubleLinkedList methodsFor: 'adding' stamp: 'SvenVanCaekenberghe 12/16/2013 20:12'! add: anObjectOrLink beforeLink: otherLink | link otherLinkPredeccessor | otherLink = head ifTrue: [ ^ self addFirst: anObjectOrLink ]. link := anObjectOrLink asDoubleLink. otherLinkPredeccessor := otherLink previousLink. otherLink previousLink: link. link nextLink: otherLink. link previousLink: otherLinkPredeccessor. otherLinkPredeccessor nextLink: link. ^ link! ! !DoubleLinkedList methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/5/2013 16:54'! last self isEmpty ifTrue: [ CollectionIsEmpty signalWith: self ]. ^ tail value! ! !DoubleLinkedList methodsFor: 'adding' stamp: 'SvenVanCaekenberghe 12/9/2013 15:18'! addAll: collection collection do: [ :each | self add: each ]! ! !DoubleLinkedList methodsFor: 'converting' stamp: 'SvenVanCaekenberghe 12/2/2013 23:40'! asArray ^ Array streamContents: [ :out | self do: [ :each | out nextPut: each ] ]! ! !DoubleLinkedList methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/5/2013 16:53'! first self isEmpty ifTrue: [ CollectionIsEmpty signalWith: self ]. ^ head value! ! !DoubleLinkedList methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 19:08'! isEmpty ^ head isNil and: [ tail isNil ]! ! !DoubleLinkedList methodsFor: 'removing' stamp: 'SvenVanCaekenberghe 12/5/2013 16:54'! removeFirst | link | self isEmpty ifTrue: [ CollectionIsEmpty signalWith: self ]. link := head. head := head nextLink. head ifNil: [ tail := nil ] ifNotNil: [ head previousLink: nil ]. link clearLinks. ^ link! ! !DoubleLinkedList methodsFor: 'adding' stamp: 'SvenVanCaekenberghe 12/16/2013 20:12'! addFirst: anObjectOrLink | link | link := anObjectOrLink asDoubleLink. link nextLink: head. head ifNotNil: [ head previousLink: link ]. tail ifNil: [ tail := link ]. head := link. ^ link! ! !DoubleLinkedList methodsFor: 'removing' stamp: 'SvenVanCaekenberghe 12/5/2013 16:54'! removeLink: link | predecessor successor | predecessor := link previousLink. successor := link nextLink. predecessor ifNil: [ head := successor ] ifNotNil: [ predecessor nextLink: successor ]. successor ifNil: [ tail := predecessor ] ifNotNil: [ successor previousLink: predecessor ]. link clearLinks. ^ link! ! !DoubleLinkedList methodsFor: 'adding' stamp: 'SvenVanCaekenberghe 12/16/2013 20:12'! addLast: anObjectOrLink | link | link := anObjectOrLink asDoubleLink. link previousLink: tail. tail ifNotNil: [ tail nextLink: link ]. head ifNil: [ head := link ]. tail := link. ^ link! ! !DoubleLinkedList methodsFor: 'enumerating' stamp: 'SvenVanCaekenberghe 12/9/2013 15:12'! reject: block | result | result := self class new. self do: [ :each | (block value: each) ifFalse: [ result add: each ] ]. ^ result! ! !DoubleLinkedList methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/9/2013 15:44'! includes: object self do: [ :each | each = object ifTrue: [ ^ true ] ]. ^ false! ! !DoubleLinkedList methodsFor: 'enumerating' stamp: 'SvenVanCaekenberghe 12/9/2013 15:11'! select: block | result | result := self class new. self do: [ :each | (block value: each) ifTrue: [ result add: each ] ]. ^ result! ! !DoubleLinkedList methodsFor: 'enumerating' stamp: 'SvenVanCaekenberghe 12/9/2013 15:10'! collect: block | result | result := self class new. self do: [ :each | result add: (block value: each) ]. ^ result! ! !DoubleLinkedList methodsFor: 'adding' stamp: 'SvenVanCaekenberghe 12/2/2013 21:08'! add: anObjectOrLink ^ self addLast: anObjectOrLink! ! !DoubleLinkedList methodsFor: 'enumerating' stamp: 'SvenVanCaekenberghe 12/2/2013 19:09'! do: block | current | current := head. [ current isNil ] whileFalse: [ block value: current value. current := current nextLink ]! ! !DoubleLinkedList methodsFor: 'adding' stamp: 'SvenVanCaekenberghe 12/16/2013 20:12'! add: anObjectOrLink afterLink: otherLink | link otherLinkSuccessor | otherLink = tail ifTrue: [ ^ self addLast: anObjectOrLink ]. link := anObjectOrLink asDoubleLink. otherLinkSuccessor := otherLink nextLink. otherLink nextLink: link. link previousLink: otherLink. link nextLink: otherLinkSuccessor. otherLinkSuccessor previousLink: link. ^ link! ! !DoubleLinkedList methodsFor: 'removing' stamp: 'SvenVanCaekenberghe 12/5/2013 16:54'! removeLast | link | self isEmpty ifTrue: [ CollectionIsEmpty signalWith: self ]. link := tail. tail := tail previousLink. tail ifNil: [ head := nil ] ifNotNil: [ tail nextLink: nil ]. link clearLinks. ^ link! ! !DoubleLinkedList methodsFor: 'enumerating' stamp: 'SvenVanCaekenberghe 12/9/2013 15:09'! reverseDo: block | current | current := tail. [ current isNil ] whileFalse: [ block value: current value. current := current previousLink ]! ! !DoubleLinkedList methodsFor: 'removing' stamp: 'SvenVanCaekenberghe 12/5/2013 17:07'! removeAll head := tail := nil! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testAddFirst | list | list := DoubleLinkedList new. 1 to: 3 do: [ :each | list add: each ]. list addFirst: 0. self deny: list isEmpty. self assert: list first equals: 0. self assert: list last equals: 3. self assert: list asArray equals: #( 0 1 2 3 )! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testThreeRemoveFirst | list link | list := DoubleLinkedList new. 1 to: 3 do: [ :each | list add: each ]. link := list removeFirst. self assert: link value equals: 1. self assert: list first equals: 2. self assert: list last equals: 3. self assert: list asArray equals: #( 2 3 )! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testOne | list | list := DoubleLinkedList new. list add: #one. self deny: list isEmpty. self assert: list first equals: #one. self assert: list last equals: #one. self assert: list asArray equals: #( one )! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testAddLast | list | list := DoubleLinkedList new. 1 to: 3 do: [ :each | list add: each ]. list addLast: 0. self deny: list isEmpty. self assert: list first equals: 1. self assert: list last equals: 0. self assert: list asArray equals: #( 1 2 3 0 )! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testAddBeforeLink | list link | list := DoubleLinkedList new. list add: 1. link := list add: 2. list add: 3. list add: 0 beforeLink: link. self assert: list asArray equals: #( 1 0 2 3 )! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testIncludes | list | list := DoubleLinkedList new. list addAll: (1 to: 10). self assert: (list includes: 5). self deny: (list includes: 0)! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testReject | list even | list := DoubleLinkedList new. list addAll: (1 to: 10). even := list reject: [ :each | each odd ]. self assert: even asArray equals: #(2 4 6 8 10)! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testThreeRemoveLast | list link | list := DoubleLinkedList new. 1 to: 3 do: [ :each | list add: each ]. link := list removeLast. self assert: link value equals: 3. self assert: list first equals: 1. self assert: list last equals: 2. self assert: list asArray equals: #( 1 2 )! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testEmpty | list | list := DoubleLinkedList new. self assert: list isEmpty. self should: [ list first ] raise: CollectionIsEmpty. self should: [ list last ] raise: CollectionIsEmpty. list do: [ :each | self fail ] ! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testCollect | list doubles | list := DoubleLinkedList new. list addAll: #(1 2 3). doubles := list collect: [ :each | each * 2 ]. self assert: doubles asArray equals: #(2 4 6)! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testThreeRemoveLink | list link | list := DoubleLinkedList new. list add: 1. link := list add: 2. list add: 3. list removeLink: link. self assert: list first equals: 1. self assert: list last equals: 3. self assert: list asArray equals: #( 1 3 )! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testOneRemoveFirst | list | list := DoubleLinkedList new. list add: #one. list removeFirst. self assert: list isEmpty. list add: #one. list removeLast. self assert: list isEmpty! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testDo | list value | list := DoubleLinkedList new. list addAll: (1 to: 10). value := 1. list do: [ :each | self assert: each equals: value. value := value + 1 ]! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testAddAfterLink | list link | list := DoubleLinkedList new. list add: 1. link := list add: 2. list add: 3. list add: 0 afterLink: link. self assert: list asArray equals: #( 1 2 0 3 )! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testOneRemoveLast | list | list := DoubleLinkedList new. list add: #one. list removeLast. self assert: list isEmpty. list add: #one. list removeLast. self assert: list isEmpty! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testReverseDo | list value | list := DoubleLinkedList new. list addAll: (1 to: 10). value := 10. list reverseDo: [ :each | self assert: each equals: value. value := value - 1 ]! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testSelect | list even | list := DoubleLinkedList new. list addAll: (1 to: 10). even := list select: [ :each | each even ]. self assert: even asArray equals: #(2 4 6 8 10)! ! !DoubleLinkedListTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! testThree | list | list := DoubleLinkedList new. 1 to: 3 do: [ :each | list add: each ]. self deny: list isEmpty. self assert: list first equals: 1. self assert: list last equals: 3. self assert: list asArray equals: #( 1 2 3 )! ! !DropEvent commentStamp: 'LaurentLaffont 3/15/2011 20:47'! I model the event produced when a hand drops a (grabbed) morph into another morph. I know the position of the drop, the dropped morph and the hand that produced me. To handle this event a morph should override one of these methods: #acceptDroppingMorph:event: #justDroppedInto:event: Additionaly, a morph can specify if it wants to accept a dropped morph by overriding #wantsDroppedMorph:event:. Symmetrically, the morph being dropped can specify if it wants to be dropped in another morph by overriding #wantsToBeDroppedInto:. Note that for a successful drop operation both parties need to agree. See HandMorph>>dropMorph:event: for an example of usage. ! !DropEvent methodsFor: 'transforming' stamp: 'ar 10/7/2000 18:28'! transformedBy: aMorphicTransform "Return the receiver transformed by the given transform into a local coordinate system." ^self shallowCopy transformBy: aMorphicTransform! ! !DropEvent methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:24'! sentTo: anObject "Dispatch the receiver into anObject" self type == #dropEvent ifTrue:[^anObject handleDropMorph: self].! ! !DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:44'! wasHandled: aBool wasHandled := aBool.! ! !DropEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'! resetHandlerFields "Reset anything that is used to cross-communicate between two eventual handlers during event dispatch" wasHandled := false.! ! !DropEvent methodsFor: 'transforming' stamp: 'ar 10/7/2000 18:28'! transformBy: aMorphicTransform "Transform the receiver into a local coordinate system." position := aMorphicTransform globalPointToLocal: position.! ! !DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:44'! wasHandled ^wasHandled! ! !DropEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 18:33'! isDropEvent ^true! ! !DropEvent methodsFor: 'printing' stamp: 'JMM 9/29/2004 13:24'! printOn: aStream aStream nextPut: $[. aStream nextPutAll: self position printString; space. aStream nextPutAll: self type; space. aStream nextPutAll: self windowIndex printString. aStream nextPut: $].! ! !DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'! position ^position! ! !DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 19:21'! cursorPoint "For compatibility with mouse events" ^position! ! !DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'! type ^#dropEvent! ! !DropEvent methodsFor: 'private' stamp: 'ar 9/13/2000 19:23'! setPosition: pos contents: aMorph hand: aHand position := pos. contents := aMorph. source := aHand. wasHandled := false.! ! !DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'! contents ^contents! ! !DropEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:19'! copyHandlerState: anEvent "Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events." wasHandled := anEvent wasHandled.! ! !DropFilesEvent methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:35'! sentTo: anObject "Dispatch the receiver into anObject" self type == #dropFilesEvent ifTrue:[^anObject handleDropFiles: self].! ! !DropFilesEvent methodsFor: 'accessing' stamp: 'ar 1/10/2001 21:35'! type ^#dropFilesEvent! ! !DropListExample commentStamp: ''! A DropListExample is a simple example of how to use drop lists. DropListExample new openWithSpec! !DropListExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/1/2013 15:03'! container ^ container asSpecAdapter! ! !DropListExample methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 22:55'! initialize container := PanelMorph new. self instantiateMorphs. container changeTableLayout; listDirection: #bottomToLeft. super initialize.! ! !DropListExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/2/2012 15:20'! instantiateMorphs morph1 := Morph new color: Color red; width: 60; height: 20. morph2 := Morph new color: Color blue; width: 20; height: 60. morph3 := Morph new color: Color green; width: 50; height: 50.! ! !DropListExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/23/2013 13:11'! initializeWidgets uniformDropList := self newDropList. heterogeneousDropList := self newDropList. uniformDropList items: {morph1. morph2. morph3}; displayBlock: [ :m | m color name capitalized, ' morph' ]; iconHolder: [:e| Smalltalk ui icons testGreenIcon ]; whenSelectedItemChanged: [ :m | container removeAllMorphs. container addMorph: m ]. heterogeneousDropList addItemLabeled: 'Open workspace' do: [ Workspace open ] icon: Smalltalk ui icons smallOkIcon; addItemLabeled: 'Inspect current morph' do: [ uniformDropList selectedItem inspect ] icon: Smalltalk ui icons testRedIcon. "If this is uncommented, it will fire the action of the first item, which is not what we want: heterogeneousDropList setSelectedIndex: 1. same for: heterogeneousDropList setIndex: 1" uniformDropList setIndex: 1. self setFocus.! ! !DropListExample methodsFor: 'accessing' stamp: 'SeanDeNigris 4/17/2013 22:24'! uniformDropList ^ uniformDropList! ! !DropListExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 5/24/2013 19:24'! setFocus self focusOrder add: uniformDropList; add: heterogeneousDropList. ! ! !DropListExample methodsFor: 'accessing' stamp: 'SeanDeNigris 4/17/2013 22:15'! heterogeneousDropList ^ heterogeneousDropList.! ! !DropListExample class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2014 17:14'! defaultSpec ^ { #ContainerModel. #add:. { self topSpec . #layout: . #(#SpecLayoutFrame bottomFraction: 0 bottomOffset: 30) }. #add:. {{#model . #container } . #layout: . #(#SpecLayoutFrame topOffset: 42). }}! ! !DropListExample class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/5/2012 17:17'! title ^ 'Drop list'! ! !DropListExample class methodsFor: 'example' stamp: 'HernanMoralesDurand 2/3/2014 00:08'! example "self example" DropListExample new openWithSpec. ! ! !DropListExample class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 15:05'! topSpec ^ SpecLayout composed newRow: [ :r | r add: #uniformDropList; add: #heterogeneousDropList ]; yourself! ! !DropListItem commentStamp: ''! A DropListItem is an item (wrapper) designed to fit into a DropList! !DropListItem methodsFor: 'accessing' stamp: ''! actionHolder ^ actionHolder! ! !DropListItem methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize super initialize. actionHolder := [] asValueHolder. displayBlock := [ :e | e printString ]. icon := nil! ! !DropListItem methodsFor: 'accessing' stamp: 'SeanDeNigris 4/15/2013 21:05'! model ^ model.! ! !DropListItem methodsFor: 'protocol' stamp: 'SeanDeNigris 4/15/2013 20:44'! display: aBlock "aBlock - 1 optional argument, which is the underlying item; returns the string to be displayed" displayBlock := aBlock.! ! !DropListItem methodsFor: 'accessing' stamp: 'SeanDeNigris 4/15/2013 20:44'! label ^ displayBlock cull: model.! ! !DropListItem methodsFor: 'execution' stamp: 'BenjaminVanRyseghem 10/17/2013 16:36'! value "This way, I am polymorphic with nil" actionHolder value cull: self label cull: self! ! !DropListItem methodsFor: 'accessing' stamp: ''! = another self species = another species ifFalse: [ ^ false ]. ^ self label = another label and: [ self actionHolder = another actionHolder ]! ! !DropListItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/22/2013 18:26'! icon: anObject icon := anObject! ! !DropListItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:36'! action: aBlock actionHolder value: aBlock! ! !DropListItem methodsFor: 'accessing' stamp: 'SeanDeNigris 4/15/2013 20:44'! label: anObject "For compatibility with old raw-string usage. Send #display: instead" displayBlock := [ anObject ].! ! !DropListItem methodsFor: 'private' stamp: 'SeanDeNigris 4/15/2013 20:40'! model: anObject model := anObject.! ! !DropListItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/22/2013 18:26'! icon ^ icon! ! !DropListItem class methodsFor: 'instance creation' stamp: 'SeanDeNigris 4/15/2013 20:36'! on: anObject do: aBlock ^ self new action: aBlock; model: anObject; yourself! ! !DropListItem class methodsFor: 'instance creation' stamp: 'SeanDeNigris 4/17/2013 22:21'! named: label do: aBlock ^ self new action: aBlock; model: label; display: [ :e | e ]; yourself! ! !DropListModel commentStamp: ''! A DropListModel is a Spec model for drop lists. I am assume there is a little problem on an empty list, but frankly, who creates an empty drop list ? See DropListExample for an example! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 18:08'! resetSelection "Reset the current selection state" selectionHolder reset! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! emptyList listHolder value: OrderedCollection new! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! setSelectedIndex: anIndex "Force the selection of the item at index anIndex" | selection | selection := listHolder value at: anIndex ifAbsent: [ ^ self ]. selection value. selectionHolder index value: anIndex. selectionHolder selection value: selection! ! !DropListModel methodsFor: 'protocol-events' stamp: 'SeanDeNigris 2/8/2013 17:22'! whenSelectionChanged: aBlock "Set a block to perform when the selection is changed" "The method should be used only if you are interested in the fact that there was a change, without caring about what has changed If you are interested in the items, use whenSelectedItemChanged: If you are interested in the index, use whenSelectionIndexChanged:" selectionHolder whenChangedDo: aBlock.! ! !DropListModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 17:10'! initialize super initialize. listHolder := OrderedCollection new asReactiveVariable. selectionHolder := Object selectionReactiveVariable. listHolder whenChangedDo: [ self changed: #getList. self changed: #getIconFor:. self internalResetSelection.]. selectionHolder whenChangedDo: [ self changed: #getIndex ]. displayBlock := [ :model :item | item label ] asReactiveVariable. iconHolder := [ :model :item | item icon ] asReactiveVariable. self whenSelectedItemChanged: [:item | item value ]! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 18:26'! iconHolder: aBlock iconHolder value: aBlock! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! selectedItem ^ self selectedItemHolder value model! ! !DropListModel methodsFor: 'protocol-events' stamp: 'SeanDeNigris 4/15/2013 21:07'! whenSelectedItemChanged: aBlock "Set a block to perform when the selected item is changed" selectionHolder selection whenChangedDo: [ :new :old :announcement :ann | aBlock cull: (new ifNotNil: [ :item | item model ]) cull: old cull: announcement cull: ann ]! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/18/2013 13:02'! getList ^ listHolder value! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 18:08'! selectedIndex "Useless method but it provides a better and more consistent API" ^ self getIndex! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/19/2013 12:29'! addItemLabeled: aString do: aBlock | item | item := DropListItem named: aString do: aBlock. "If you add directly in the contents, the update is not triggered from the value holder" listHolder add: item.! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 18:27'! getIconFor: anItem ^ self iconHolder cull: anItem! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/18/2013 12:57'! displayBlock: aBlock displayBlock value: aBlock "listHolder replace: [ :e | e display: aBlock; yourself ]."! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! listItems "Return the list used to populate the drop list" ^ listHolder value collect: [ :e | e model ].! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 18:26'! iconHolder ^ iconHolder value! ! !DropListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/22/2013 18:33'! internalResetSelection selectionHolder reset. self getList ifNotEmpty: [ self silentlySetSelectedIndex: 1 ]! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 18:08'! displayForItem: anItem "The order of the arguments may looks weird, but then it seemsm ore natural while using the widget" ^ self displayBlock cull: anItem model cull: anItem! ! !DropListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/22/2013 18:37'! silentlySetSelectedIndex: anIndex "Force the selection of the item at index anIndex" | selection | selection := listHolder value at: anIndex ifAbsent: [ ^ self ]. selectionHolder index value: anIndex. selectionHolder selection value: selection.! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! getIndex ^ selectionHolder index value! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/23/2013 12:58'! addItemLabeled: aString do: aBlock icon: anIcon | item | item := DropListItem named: aString do: aBlock. item icon: anIcon. "If you add directly in the contents, the update is not triggered from the value holder" listHolder add: item.! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! setIndex: anIndex | item | selectionHolder index value: anIndex. item := (listHolder value at: anIndex ifAbsent: [ nil ]). item value. selectionHolder selection value: item. self changed: #getIndex! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 20:02'! listSize "Return the size of the list of choices" ^ self listItems size! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! setSelectedItem: anItem "Force the selection of the item anItem" | index realItem | index := self listItems indexOf: anItem ifAbsent: [ ^ self ]. realItem := listHolder at: index. selectionHolder index value: index. selectionHolder selection value: realItem.! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/18/2013 12:57'! displayBlock ^ displayBlock value! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! items: aList "Populate the drop list with a list of ui specific items" "aList is a list of domain specific objects. If you want to specify more precisely the item actions, see #addItemLabeled:do:" | dropListItems | dropListItems := aList collect: [ :e | DropListItem on: e do: [] ]. listHolder value: dropListItems! ! !DropListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/12/2012 18:10'! whenSelectionIndexChanged: aBlock "Set a block to perform when the selected index is changed" selectionHolder index whenChangedDo: aBlock! ! !DropListModel methodsFor: 'private' stamp: 'StephaneDucasse 5/17/2012 18:04'! selectedItemHolder ^ selectionHolder selection! ! !DropListModel methodsFor: 'private' stamp: 'StephaneDucasse 5/17/2012 18:04'! selectedIndexHolder ^ selectionHolder index! ! !DropListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 13:38'! defaultSpec ^ #(DropListAdapter adapt: #(model))! ! !DropListModel class methodsFor: 'specs' stamp: ''! title ^ 'Drop List'! ! !DropListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:21'! adapterName ^ #DropListAdapter! ! !DropListMorph commentStamp: 'gvc 5/23/2007 14:12'! Displays a selected item and a drop button. When pressed will popup a list to enable changing of the selection. Supports enablement.! !DropListMorph methodsFor: 'private' stamp: 'gvc 6/17/2006 12:26'! listVisible "Answer whether the list is visible." ^self listMorph owner notNil! ! !DropListMorph methodsFor: '*Polymorph-Widgets' stamp: 'GaryChambers 11/17/2011 11:57'! themeChanged "Update the selection colour." self selectionColor ifNotNil: [ self selectionColor: self theme selectionColor]. self layoutInset: self layoutInsetToUse. self buttonMorph extent: self buttonExtent. super themeChanged. self buttonMorph cornerStyle: self cornerStyle. self listMorph theme: self theme! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/14/2006 13:18'! enabled "Answer the value of enabled" ^ enabled! ! !DropListMorph methodsFor: 'initialization' stamp: 'gvc 6/17/2006 11:17'! defaultColor "Answer the default color of the receiver." ^Color white! ! !DropListMorph methodsFor: 'updating' stamp: 'GaryChambers 8/17/2010 15:24'! updateContentColor: paneColor "Change the content text color." self enabled ifTrue: [self contentMorph textColor: Color black] ifFalse: [self contentMorph textColor: Color lightGray]! ! !DropListMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 5/24/2013 19:26'! keyStroke: event "Pass on to the list." | indexToSelect | event keyCharacter = Character escape ifTrue: [ self hideList ]. (self navigationKey: event) ifTrue: [^self]. event keyCharacter == Character cr ifTrue: [ ^ self listSelectionIndex: self listSelectionIndex ]. indexToSelect := self listMorph keyStroke: event. "If the returned value is not an integer, do not handle it" indexToSelect isInteger ifFalse: [ ^ self ]. "If nothing found, do nothing" indexToSelect == 0 ifTrue: [ ^ self ]. self listSelectionIndex: indexToSelect! ! !DropListMorph methodsFor: 'initialize' stamp: 'gvc 7/8/2006 10:13'! outOfWorld: aWorld "Get rid of the list if visible." self hideList. ^super outOfWorld: aWorld! ! !DropListMorph methodsFor: 'private' stamp: 'AlainPlantec 12/17/2009 14:34'! buttonWidth "Answer based on scrollbar size." ^ (self theme scrollbarThickness + 3) max: self theme dropListControlButtonWidth! ! !DropListMorph methodsFor: 'private' stamp: ''! updateContentMorphWith: aString self contentMorph contents: aString! ! !DropListMorph methodsFor: 'as yet unclassified' stamp: ''! addToggleItemsToHaloMenu: aCustomMenu "Add toggle-items to the halo menu" super addToggleItemsToHaloMenu: aCustomMenu. aCustomMenu addUpdating: #enabledString target: self action: #toggleEnabled! ! !DropListMorph methodsFor: 'protocol' stamp: 'GaryChambers 11/17/2011 17:39'! getCurrentSelection "Answer the current selection from the model." ^(self model notNil and: [self getIndexSelector notNil]) ifTrue: [|mySelection| mySelection := self model perform: self getIndexSelector. (self list includes: mySelection) ifTrue: [mySelection]]! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! getListSelector: anObject "Set the value of getListSelector" getListSelector := anObject! ! !DropListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 3/14/2012 08:26'! newButtonMorph "Answer a new button morph" ^(ControlButtonMorph on: self getState: nil action: #popList label: #buttonLabel) roundedCorners: #(3 4); getEnabledSelector: #enabled; label: self buttonLabel; vResizing: #spaceFill; hResizing: #rigid; extent: self buttonExtent; setProperty: #wantsKeyboardFocusNavigation toValue: false; cornerStyle: self cornerStyle.! ! !DropListMorph methodsFor: 'accessing' stamp: 'GaryChambers 11/16/2011 13:41'! font: aFont "Set the content font" self contentMorph beAllFont: aFont! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! getIndexSelector: anObject "Set the value of getIndexSelector" getIndexSelector := anObject! ! !DropListMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/14/2012 08:04'! initialize "Initialize the receiver." super initialize. listSelectionIndex := 0. enabled := true. list := #(). "needs something to keep font" defaultContents := ' '. self useSelectionIndex: true; clipSubmorphs: true; layoutPolicy: RowLayout new; layoutInset: self layoutInsetToUse; cellPositioning: #center; listMorph: self newListMorph; contentMorph: self newContentMorph; buttonMorph: self newButtonMorph; fillStyle: self fillStyleToUse; borderStyle: self borderStyleToUse; addMorphBack: self contentMorph; addMorphBack: (self addDependent: self buttonMorph); on: #mouseDown send: #popList to: self; vResizing: #rigid; hResizing: #spaceFill; height: self font height + 10. self listMorph fillStyle: (self theme dropListNormalListFillStyleFor: self)! ! !DropListMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 12:18'! enable "Enable the receiver." self enabled: true! ! !DropListMorph methodsFor: 'wrapping' stamp: 'BenjaminVanRyseghem 3/20/2012 13:11'! wrapItem: anItem index: index ^ wrapSelector ifNil: [ anItem asString ] ifNotNil: [ wrapSelector numArgs = 0 ifTrue: [ anItem perform: wrapSelector ] ifFalse: [ self model perform: wrapSelector withEnoughArguments: {anItem. index. self.} ]]! ! !DropListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 5/19/2013 12:33'! newListMorph "Answer a new list morph" |m| m := (self listMorphClass on: self list: #list selected: #listSelectionIndex changeSelected: #listSelectionIndex: menu: nil keystroke: nil) autoDeselect: false; wrapSelector: #wrapItem:index:; roundedCorners: #(2 3); setProperty: #morphicLayerNumber toValue: 5; color: self color; borderStyle: (self theme dropListNormalListBorderStyleFor: self); on: #mouseDown send: #listMouseDown: to: self. ^m! ! !DropListMorph methodsFor: 'as yet unclassified' stamp: ''! toggleEnabled "Toggle the enabled state." self enabled: self enabled not! ! !DropListMorph methodsFor: 'private' stamp: 'GaryChambers 3/2/2012 12:27'! positionList "Position the list morph to fit on the display." |height topSpace bottomSpace pos| height := self listHeight. topSpace := self boundsInWorld top - self world top. bottomSpace := self world bottom - self boundsInWorld bottom. pos := height <= bottomSpace ifTrue: [#below] ifFalse: [height <= topSpace ifTrue: [#above] ifFalse: [bottomSpace >= topSpace ifTrue: [height := bottomSpace. #below] ifFalse: [height := topSpace. #above]]]. pos = #above ifTrue: [self buttonMorph roundedCorners: (self roundedCorners copyWithoutAll: #(1 4)). self roundedCorners: (self roundedCorners copyWithoutAll: #(1 4)). self listMorph bounds: (self boundsInWorld topLeft - (0 @ height) extent: self width @ height)] ifFalse: [self buttonMorph roundedCorners: (self roundedCorners copyWithoutAll: #(1 2 3)). self roundedCorners: (self roundedCorners copyWithoutAll: #(2 3)). self listMorph bounds: (self boundsInWorld bottomLeft extent: self width @ height)]! ! !DropListMorph methodsFor: 'protocol' stamp: 'gvc 8/8/2007 15:53'! useSelection "Use the model as returning the selected item rather than index." self useSelectionIndex: false! ! !DropListMorph methodsFor: 'testing' stamp: 'gvc 9/6/2006 12:48'! stepTime "Answer the desired time between steps in milliseconds." ^100! ! !DropListMorph methodsFor: 'private' stamp: ''! defaultContents ^ defaultContents! ! !DropListMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/4/2011 12:27'! list "Answer the list contents." ^list! ! !DropListMorph methodsFor: 'accessing' stamp: 'GaryChambers 2/9/2012 12:13'! allowKeyboardFocus: aBoolean "Set whether or not keyboard focus will be allowed." self setProperty: #allowKeyboardFocus toValue: aBoolean! ! !DropListMorph methodsFor: 'protocol' stamp: 'gvc 8/8/2007 15:53'! useIndex "Use the model as returning the selected index rather than item." self useSelectionIndex: true! ! !DropListMorph methodsFor: 'event handling' stamp: 'gvc 9/8/2006 11:30'! handlesKeyboard: evt "Return true if the receiver wishes to handle the given keyboard event." ^true! ! !DropListMorph methodsFor: 'accessing' stamp: ''! defaultContents: anObject "Set the value of defaultContents" defaultContents := anObject! ! !DropListMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 12:18'! disable "Disable the receiver." self enabled: false! ! !DropListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/20/2009 16:38'! focusBounds "Answer the bounds for drawing the focus indication." ^self theme dropListFocusBoundsFor: self! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 6/17/2006 11:45'! contentMorph "Answer the value of contentMorph" ^ contentMorph! ! !DropListMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 5/19/2013 12:42'! listMouseDown: evt "Click outside the list." (self listMorph fullContainsPoint: evt position) ifTrue: [ self listMorph selectionIndex: (self listMorph rowAtLocation: evt position) ]. self hideList! ! !DropListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:30'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 10/12/2006 13:58'! selectionColor: aColor "Set the selection color for the receiver." self listMorph selectionColor: aColor! ! !DropListMorph methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 3/13/2012 18:02'! updateContents "Update the contents." self updateContentMorphWith: (self listSelectionIndex > 0 ifTrue: [self listMorph wrapItem: (self list at: self listSelectionIndex) index: self listSelectionIndex ] ifFalse: [ self defaultContents ]) ! ! !DropListMorph methodsFor: 'updating' stamp: 'gvc 9/8/2009 13:25'! updateEnabled "Update the enablement state." self model ifNotNil: [ self getEnabledSelector ifNotNil: [ self enabled: (self model perform: self getEnabledSelector)]]! ! !DropListMorph methodsFor: 'accessing' stamp: 'GaryChambers 2/9/2012 12:14'! allowKeyboardFocus "Answer whether or not keyboard focus will be allowed." ^self valueOfProperty: #allowKeyboardFocus ifAbsent: [true]! ! !DropListMorph methodsFor: 'protocol' stamp: 'gvc 8/22/2006 15:00'! popList "Hide / show the list." self enabled ifFalse: [^self]. self listMorph owner isNil ifTrue: [self showList] ifFalse: [self hideList]! ! !DropListMorph methodsFor: 'stepping and presenter' stamp: 'gvc 9/21/2007 14:37'! step "Reset mouse focus to the list if it is showing." self listVisible ifTrue: [ self activeHand mouseFocus ifNil: [ self listMorph wantsKeyboardFocus ifTrue: [ self listMorph takeKeyboardFocus]. self activeHand newMouseFocus: self listMorph]]! ! !DropListMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 2/9/2012 12:12'! wantsKeyboardFocus "Answer whether the receiver would like keyboard focus in the general case (mouse action normally)." ^super wantsKeyboardFocus and: [ self allowKeyboardFocus]! ! !DropListMorph methodsFor: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:28'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/22/2006 13:25'! buttonMorph: anObject "Set the value of buttonMorph" buttonMorph := anObject! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! getIndexSelector "Answer the value of getIndexSelector" ^ getIndexSelector! ! !DropListMorph methodsFor: 'private' stamp: 'gvc 8/7/2007 11:03'! fillStyleToUse "Answer the fillStyle that should be used for the receiver." ^self enabled ifTrue: [self theme dropListNormalFillStyleFor: self] ifFalse: [self theme dropListDisabledFillStyleFor: self]! ! !DropListMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/23/2012 11:39'! keyboardFocusChange: aBoolean "The message is sent to a morph when its keyboard focus changes. Update for focus feedback." super keyboardFocusChange: aBoolean. self focusChanged! ! !DropListMorph methodsFor: 'accessing' stamp: 'GaryChambers 4/24/2012 15:04'! font "Answer the content font" ^self contentMorph font! ! !DropListMorph methodsFor: 'protocol' stamp: 'GaryChambers 11/17/2011 11:57'! showList "Show the list." self listMorph owner isNil ifTrue: [self positionList. self fillStyle: self fillStyleToUse; listPaneColor: self paneColor. self listMorph theme: self theme. self world addMorphInLayer: self listMorph. self listMorph wantsKeyboardFocus ifTrue: [ self listMorph takeKeyboardFocus]. self activeHand newMouseFocus: self listMorph]! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/22/2006 13:25'! buttonMorph "Answer the value of buttonMorph" ^ buttonMorph! ! !DropListMorph methodsFor: 'protocol' stamp: 'gvc 8/8/2007 15:58'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel "Set the receiver to the given model parameterized by the given message selectors." getListSel isSymbol ifTrue: [self getListSelector: getListSel] ifFalse: [self list: getListSel]. "allow direct list" self model: anObject; getIndexSelector: getSelectionSel; setIndexSelector: setSelectionSel; updateList; updateListSelectionIndex; updateContents! ! !DropListMorph methodsFor: 'protocol' stamp: 'gvc 7/17/2006 12:30'! getCurrentSelectionIndex "Answer the index of the current selection." self getIndexSelector ifNil: [^0]. ^self model perform: self getIndexSelector! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:53'! useSelectionIndex "Answer the value of useSelectionIndex" ^ useSelectionIndex! ! !DropListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/14/2012 08:26'! listMorph: anObject "Set the value of listMorph" listMorph := anObject. anObject on: #keyStroke send: #keyStroke: to: self.! ! !DropListMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/19/2013 12:41'! hideList "Hide the list." self listMorph ifNil: [^self]. self listVisible ifFalse: [^self]. self listMorph delete. self listMorph changeModelSelection: self listMorph selectionIndex. self roundedCorners: #(1 2 3 4). (self buttonMorph ifNil: [^self]) roundedCorners: (self roundedCorners copyWithoutAll: #(1 2)). self fillStyle: self fillStyleToUse. self wantsKeyboardFocus ifTrue: [self takeKeyboardFocus]! ! !DropListMorph methodsFor: 'updating' stamp: 'gvc 8/8/2007 15:57'! updateList "Refresh the list." self getListSelector isSymbol ifTrue: [ self list: (self model perform: self getListSelector). listSelectionIndex := 0]! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/14/2006 13:30'! getEnabledSelector: anObject "Set the value of getEnabledSelector" getEnabledSelector := anObject. self updateEnabled! ! !DropListMorph methodsFor: 'drawing' stamp: 'gvc 5/31/2007 15:16'! drawSubmorphsOn: aCanvas "Display submorphs back to front. Draw the focus here since we are using inset bounds for the focus rectangle." super drawSubmorphsOn: aCanvas. self hasKeyboardFocus ifTrue: [ self drawKeyboardFocusOn: aCanvas]! ! !DropListMorph methodsFor: 'private' stamp: 'gvc 1/23/2009 13:12'! buttonHeight "Answer based on theme." ^self theme buttonMinHeight! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 6/17/2006 11:45'! contentMorph: anObject "Set the value of contentMorph" contentMorph := anObject! ! !DropListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 3/14/2012 08:26'! newContentMorph "Answer a new content morph" ^TextMorphForFieldView new contents: self defaultContents; margins: (2@0 corner: 2@1); borderStyle: (BorderStyle simple width: 0); vResizing: #shrinkWrap; hResizing: #spaceFill; autoFit: false; lock.! ! !DropListMorph methodsFor: '*Polymorph-Widgets' stamp: 'MarcusDenker 12/11/2009 07:38'! roundedCorners: anArray "Set the corners to round." super roundedCorners: anArray. self buttonMorph ifNotNil: [:b | b roundedCorners: (anArray copyWithoutAll: #(1 2))]! ! !DropListMorph methodsFor: 'as yet unclassified' stamp: ''! enabledString "Answer the string to be shown in a menu to represent the 'enabled' status" ^ (self enabled) -> 'enabled' translated! ! !DropListMorph methodsFor: 'protocol' stamp: ''! ghostText: aStringOrText | text | text := aStringOrText asText asMorph. text textColor: Color lightGray. self contentMorph contents = self defaultContents ifTrue: [ self contentMorph contents: text ]. self defaultContents: text.! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 1/22/2009 15:35'! adoptPaneColor: paneColor "Pass on to the list morph and border too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self fillStyle: self fillStyleToUse. self borderWidth > 0 ifTrue: [ self borderStyle: self borderStyleToUse]. self buttonMorph cornerStyle: self cornerStyle. self updateContentColor: paneColor. self listPaneColor: paneColor. self changed: #buttonLabel! ! !DropListMorph methodsFor: 'updating' stamp: 'nice 4/19/2011 00:36'! updateListSelectionIndex "Update the list selection." |i| self useSelectionIndex ifTrue: [i := self getCurrentSelectionIndex. listSelectionIndex = i ifTrue: [^self]. listSelectionIndex := i] ifFalse: [i := self getCurrentSelection. listSelectionIndex := i isNil ifTrue: [0] ifFalse: [self list indexOf: i]]. self changed: #listSelectionIndex; updateContents; triggerEvent: #selectionIndex with: i! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 10/12/2006 13:58'! selectionColor "Answer the selection color for the receiver." ^self listMorph selectionColor! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:53'! useSelectionIndex: anObject "Set the value of useSelectionIndex" useSelectionIndex := anObject! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! setIndexSelector: anObject "Set the value of setIndexSelector" setIndexSelector := anObject! ! !DropListMorph methodsFor: 'wrapping' stamp: 'BenjaminVanRyseghem 4/25/2012 12:56'! wrapSelector: aSymbol wrapSelector := aSymbol. self updateList. self updateContents! ! !DropListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/19/2013 12:36'! listSelectionIndex: anInteger "Set the list selection." self hideList. anInteger = 0 ifTrue: [^self]. listSelectionIndex := anInteger. self changed: #listSelectionIndex; updateContents; triggerEvent: #selectionIndex with: anInteger. self model ifNotNil: [:m | self setIndexSelector ifNotNil: [:s | self useSelectionIndex ifTrue: [m perform: s with: anInteger] ifFalse: [m perform: s with: self selectedItem]]]! ! !DropListMorph methodsFor: 'private' stamp: 'GaryChambers 3/2/2012 12:10'! listHeight "Answer the height for the list." ^(self listMorph listMorph height + 6 max: 38) min: (15 * self listFont height)! ! !DropListMorph methodsFor: 'private' stamp: 'GaryChambers 8/18/2010 17:33'! layoutInsetToUse "Answer the layout inset that should be used." ^self theme dropListInsetFor: self! ! !DropListMorph methodsFor: 'protocol' stamp: 'gvc 1/12/2007 14:12'! selectedItem "Answer the selected list item." ^(self listSelectionIndex between: 1 and: self list size) ifTrue: [ self list at: self listSelectionIndex]! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 9/1/2006 15:57'! enabled: anObject "Set the value of enabled" enabled = anObject ifTrue: [^self]. enabled := anObject. anObject ifFalse: [self hideList]. self changed: #enabled. self adoptPaneColor: self paneColor; changed! ! !DropListMorph methodsFor: 'private' stamp: 'gvc 6/1/2009 11:40'! buttonLabel "Answer the label for the button." ^self theme dropListButtonLabelFor: self! ! !DropListMorph methodsFor: 'private' stamp: 'gvc 1/23/2009 13:12'! buttonExtent "Answer based on theme and preferences." ^self buttonWidth @ self buttonHeight! ! !DropListMorph methodsFor: 'geometry' stamp: 'gvc 8/7/2007 11:04'! extent: newExtent "Update the gradient." super extent: newExtent. (self fillStyle notNil and: [self fillStyle isSolidFill not]) ifTrue: [self fillStyle: self fillStyleToUse]! ! !DropListMorph methodsFor: 'updating' stamp: 'gvc 8/14/2006 13:18'! update: aSymbol "Refer to the comment in View|update:." aSymbol == getListSelector ifTrue: [self updateList. ^ self]. aSymbol == getIndexSelector ifTrue: [self updateListSelectionIndex. ^ self]. aSymbol == getEnabledSelector ifTrue: [self updateEnabled. ^ self]. ! ! !DropListMorph methodsFor: 'rounding' stamp: 'GaryChambers 8/18/2010 17:34'! cornerStyle: aSymbol "Update the layout inset too." super cornerStyle: aSymbol. self layoutInset: self layoutInsetToUse. self buttonMorph cornerStyle: self cornerStyle. self fillStyle: self fillStyleToUse! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/14/2006 13:16'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! getListSelector "Answer the value of getListSelector" ^ getListSelector! ! !DropListMorph methodsFor: 'private' stamp: 'gvc 6/17/2006 11:42'! listMorphClass "Answer the class for a new list morph" ^PluggableListMorph! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 6/17/2006 11:07'! listMorph "Answer the value of listMorph" ^ listMorph! ! !DropListMorph methodsFor: 'wrapping' stamp: 'BenjaminVanRyseghem 3/13/2012 04:17'! wrapSelector ^ wrapSelector! ! !DropListMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/4/2011 12:28'! list: aCollection "Set the list contents." list := aCollection. self changed: #list! ! !DropListMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/16/2011 13:41'! listFont: aFont "Set the list font" self listMorph font: aFont! ! !DropListMorph methodsFor: 'drawing' stamp: 'gvc 1/13/2009 14:01'! listPaneColor: paneColor "Set the pane color for the list." self listMorph ifNil: [^self]. self listMorph adoptPaneColor: paneColor; fillStyle: (self theme dropListNormalListFillStyleFor: self); borderStyle: (self theme dropListNormalListBorderStyleFor: self)! ! !DropListMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/17/2011 13:44'! listFont "Answer the list font" ^self listMorph font! ! !DropListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/20/2009 16:40'! focusIndicatorCornerRadius "Answer the corner radius preferred for the focus indicator for the receiver for themes that support this." ^self theme dropListFocusIndicatorCornerRadiusFor: self ! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! setIndexSelector "Answer the value of setIndexSelector" ^ setIndexSelector! ! !DropListMorph methodsFor: 'wiw support' stamp: 'gvc 6/17/2006 12:27'! morphicLayerNumber "Answer the layer number." ^self listVisible ifTrue: [10] ifFalse: [super morphicLayerNumber]! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 6/17/2006 11:28'! listSelectionIndex "Answer the list selection." ^listSelectionIndex! ! !DropListMorph methodsFor: 'private' stamp: 'gvc 8/7/2007 11:04'! borderStyleToUse "Answer the borderStyle that should be used for the receiver." ^self enabled ifTrue: [self theme dropListNormalBorderStyleFor: self] ifFalse: [self theme dropListDisabledBorderStyleFor: self]! ! !DropListMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 16:05'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel useIndex: useIndex "Answer a new instance of the receiver on the given model using the given selectors as the interface." ^self new useSelectionIndex: useIndex; on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel! ! !DropListMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 7/17/2006 12:25'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel "Answer a new instance of the receiver on the given model using the given selectors as the interface." ^self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel! ! !DualChangeSorterApplication commentStamp: ''! A DualChangeSorterApplication is a dual change sorter based on spec. DualChangeSorter shares the model between its two subcomponents (ChangeSorterApplication). ChangeSorterModel defines the application logic. ! !DualChangeSorterApplication methodsFor: 'accessing' stamp: ''! changeSorterRight ^ changeSorterRight! ! !DualChangeSorterApplication methodsFor: 'menu - class' stamp: 'BenjaminVanRyseghem 6/13/2012 12:14'! moveClassFrom: src to: dest self checkThatSidesDiffer: [^ self]. (self okToChange and: [ src selectedClass notNil]) ifFalse: [ ^ false ]. self copyClassFrom: src to: dest. src forgetClass! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: ''! setFocusOrder self focusOrder add: changeSorterLeft; add: changeSorterRight.! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'StephaneDucasse 8/4/2013 16:43'! initialize super initialize. model := ChangeSorterModel new. isRefreshing := false. SystemAnnouncer uniqueInstance weak on: CurrentChangeSetChanged send: #updateTitle to: self ! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/13/2012 12:30'! menusRegistration self menusRegistrationFrom: changeSorterLeft to: changeSorterRight. self menusRegistrationFrom: changeSorterRight to: changeSorterLeft! ! !DualChangeSorterApplication methodsFor: 'menu' stamp: 'NicolaiHess 3/12/2014 10:23'! changesMenu: menu shifted: shifted from: sourcePanel to: destinationPanel | menuDest | menu title: 'Change Set'. sourcePanel changeSetMenu1: menu shifted: shifted. menuDest := MenuModel new fromSpec: (PragmaMenuBuilder pragmaKeyword: 'dualChangeSorteChangesListMenu' model: {self. sourcePanel. destinationPanel}) menuSpec. menuDest menuGroups do: [ :each | menu addMenuGroup: each ]. sourcePanel changeSetMenu2: menu shifted: shifted. ^ menu! ! !DualChangeSorterApplication methodsFor: 'menu - class' stamp: 'AlejandroInfante 11/11/2013 14:53'! copyClassFrom: src to: dest "Place these changes in the other changeSet also" | otherChangeSet | self checkThatSidesDiffer: [ ^ self ]. self okToChange ifFalse: [ ^ self inform: 'Can''t discard edits.' ]. src selectedClass ifNil: [ ^ self inform: 'Selected class is nil.' ]. otherChangeSet := dest selectedChangeSet. self model copyClass: src selectedClass from: src selectedChangeSet to: otherChangeSet. dest setSelectedChangeSet: otherChangeSet.! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'StephaneDucasse 11/2/2012 14:02'! initializePresenter changeSorterLeft whenChangesListChanges: [ self refeshedChangeSet: changeSorterRight ]. changeSorterRight whenChangesListChanges: [ self refeshedChangeSet: changeSorterLeft ]. ! ! !DualChangeSorterApplication methodsFor: 'menu - change set' stamp: 'MartinDias 10/23/2013 14:42'! subtractFrom: src to: dest "Subtract the changes found on the other side from the requesting side." | source destination | source := src selectedChangeSet. destination := dest selectedChangeSet. self checkThatSidesDiffer: [^ self]. self model subtractFrom: source to: destination. changeSorterRight setSelectedChangeSet: source.! ! !DualChangeSorterApplication methodsFor: 'event' stamp: 'StephaneDucasse 11/2/2012 14:40'! title ^ super title, ' on: ', self model currentChangeSet name. ! ! !DualChangeSorterApplication methodsFor: 'menu' stamp: 'BenjaminVanRyseghem 6/13/2012 12:29'! menusRegistrationFrom: src to: dest src changesMenu: [:menu :shifted | self changesMenu: menu shifted: shifted from: src to: dest ]. src classesMenu: [:menu :shifted | self classMenu: menu shifted: shifted from: src to: dest ]. src methodsMenu: [:menu :shifted | self messageMenu: menu shifted: shifted from: src to: dest ].! ! !DualChangeSorterApplication methodsFor: 'menu - method' stamp: 'BenjaminVanRyseghem 6/13/2012 12:19'! moveMethodFrom: src to: dest self copyMethodFrom: src to: dest. src forgetMessage. src updateClassesListAndMessagesList.! ! !DualChangeSorterApplication methodsFor: 'event' stamp: 'StephaneDucasse 11/2/2012 14:42'! refeshedChangeSet: changeSet isRefreshing ifFalse: [ isRefreshing := true. changeSet updateChangesList. isRefreshing := false ]! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/31/2012 16:17'! initialExtent ^ 900@530! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/8/2013 14:12'! shortcutsRegistrationFrom: src to: dest src changesModelOn: $c command do: [ self copyAllFrom: src to: dest ]. src changesModelOn: $- command do: [ self subtractFrom: src to: dest ]. ! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/13/2012 12:05'! shortcutsRegistration self shortcutsRegistrationFrom: changeSorterLeft to: changeSorterRight. self shortcutsRegistrationFrom: changeSorterRight to: changeSorterLeft.! ! !DualChangeSorterApplication methodsFor: 'menu - method' stamp: 'BenjaminVanRyseghem 6/13/2012 12:18'! copyMethodFrom: src to: dest "Place this change in the other changeSet also" | other | self checkThatSidesDiffer: [^ self]. other := dest selectedChangeSet. src selectedSelector ifNotNil: [:selector || class | class := src selectedClass. self model copySelector: selector inClass: class from: src selectedChangeSet to: other. dest updateClassesListAndMessagesList ].! ! !DualChangeSorterApplication methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 13:49'! classMenu: menu shifted: shifted from: sourcePanel to: destinationPanel "Fill aMenu with items appropriate for the class list" | menuDest | sourcePanel selectedClass ifNil: [ ^ nil ]. sourcePanel classMenu: menu shifted: shifted. menuDest := MenuModel new fromSpec: (PragmaMenuBuilder pragmaKeyword: 'dualChangeSorterClassListMenu' model: {self. sourcePanel. destinationPanel}) menuSpec. menuDest menuGroups do: [ :each | menu addMenuGroup: each ]. ^ menu! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 22:55'! initializeWidgets self instantiateModels: #( changeSorterLeft ChangeSorterApplication changeSorterRight ChangeSorterApplication ). self menusRegistration. self shortcutsRegistration. self setFocusOrder! ! !DualChangeSorterApplication methodsFor: 'menu - change set' stamp: 'BenjaminVanRyseghem 6/13/2012 11:58'! copyAllFrom: src to: dest self checkThatSidesDiffer: [ ^ self ]. self model copyAllChangesFrom: (src selectedChangeSet) to: (dest selectedChangeSet). dest updateClassesList.! ! !DualChangeSorterApplication methodsFor: 'menu - change set' stamp: 'BenjaminVanRyseghem 6/13/2012 12:10'! submergeFrom: src into: dest "Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well." | source destination index | source := src selectedChangeSet. destination := dest selectedChangeSet. index := src selectedChangeSetIndex. (self model submerge: source into: destination) ifFalse: [ ^ self ]. src updateChangesList. src setSelectedChangeSetIndex: index.! ! !DualChangeSorterApplication methodsFor: 'accessing' stamp: ''! model ^ model! ! !DualChangeSorterApplication methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 13:48'! messageMenu: menu shifted: shifted from: sourcePanel to: destinationPanel "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" | menuDual | sourcePanel selectedSelector ifNil: [ ^ nil ]. sourcePanel messageMenu: menu shifted: shifted. menuDual := MenuModel new fromSpec: (PragmaMenuBuilder pragmaKeyword: 'dualChangeSorterMessageListMenu' model: { self. sourcePanel. destinationPanel }) menuSpec. menuDual menuGroups do: [ :each | menu addMenuGroup: each ]. ^menu ! ! !DualChangeSorterApplication methodsFor: 'menu - change set' stamp: ''! checkThatSidesDiffer: escapeBlock "If the change sets on both sides of the dual sorter are the same, put up an error message and escape via escapeBlock, else proceed happily" changeSorterLeft selectedChangeSet == changeSorterRight selectedChangeSet ifTrue: [self inform: 'This command requires that the change sets selected on the two sides of the change sorter *not* be the same.'. ^ escapeBlock value] ! ! !DualChangeSorterApplication methodsFor: 'accessing' stamp: ''! changeSorterLeft ^ changeSorterLeft! ! !DualChangeSorterApplication class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 7/31/2012 16:16'! defaultSpec ^ SpecLayout composed newRow: [:r | r add: #changeSorterLeft; addSplitter; add: #changeSorterRight ]! ! !DualChangeSorterApplication class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 12:05'! taskbarIcon ^ Smalltalk ui icons changeSorterIcon! ! !DualChangeSorterApplication class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:34'! messageListMenu: aBuilder | target src dest | self flag: #todo. "I do not like how I'm getting the parameters (an Array), but looks the faster way now :( And I need src and dest parameters because it is called in two sides of change sorter" target := aBuilder model first. src := aBuilder model second. dest := aBuilder model third. (aBuilder item: #'Copy method to the other change set') action: [ target copyMethodFrom: src to: dest ]. (aBuilder item: #'Move method to the other change set') action: [ target moveMethodFrom: src to: dest ]; withSeparatorAfter. ! ! !DualChangeSorterApplication class methodsFor: 'menu' stamp: 'TorstenBergmann 2/12/2014 09:31'! menuCommandOn: aBuilder (aBuilder group: #SystemChanges) parent: #Tools; order: 0.51; with: [ (aBuilder item: #'Change Sorter') action:[self open]; icon: self taskbarIcon. (aBuilder item: #'Recover lost changes...') icon: Smalltalk ui icons recoverLostChangesIcon; action: [Smalltalk tools changeList browseRecentLog].]. aBuilder withSeparatorAfter. ! ! !DualChangeSorterApplication class methodsFor: 'specs' stamp: 'StephaneDucasse 11/2/2012 13:59'! title ^'Dual Change Sorter'! ! !DualChangeSorterApplication class methodsFor: 'tools-registry' stamp: 'MarcusDenker 9/29/2013 15:28'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #changeSorter! ! !DualChangeSorterApplication class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:33'! classListMenu: aBuilder | target src dest | self flag: #todo. "I do not like how I'm getting the parameters (an Array), but looks the faster way now :( And I need src and dest parameters because it is called in two sides of change sorter" target := aBuilder model first. src := aBuilder model second. dest := aBuilder model third. (aBuilder item: #'Copy class to the other change set') keyText: 'c'; action: [ target copyClassFrom: src to: dest ]. (aBuilder item: #'Move class to the other change set') action: [ target moveClassFrom: src to: dest ]. ! ! !DualChangeSorterApplication class methodsFor: 'specs' stamp: 'MarcusDenker 9/29/2013 15:29'! open self new openWithSpec! ! !DualChangeSorterApplication class methodsFor: 'menu' stamp: 'StephaneDucasse 2/14/2014 13:36'! changesListMenu: aBuilder | target src dest | self flag: #todo. "I do not like how I'm getting the parameters (an Array), but looks the faster way now :( And I need src and dest parameters because it is called in two sides of change sorter" target := aBuilder model first. src := aBuilder model second. dest := aBuilder model third. src selectedChangeSet ifNil:[ ^self ]. (aBuilder item: #'Copy all to the other change set') keyText: 'c'; action: [ target copyAllFrom: src to: dest ]. (aBuilder item: #'Submerge into the other change set') action: [ target submerge: src into: dest ]. (aBuilder item: #'Subtract the other change set') keyText: '-'; action: [ target subtractFrom: src to: dest ]; withSeparatorAfter.! ! !DummyEcryptor commentStamp: ''! A DummyEcryptor is an encryptor that just do _NOT_ encrypt at all :)! !DummyEcryptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/6/2012 22:08'! encrypt: aString ^ aString! ! !DummyEcryptorDecryptor commentStamp: ''! A DummyEcryptorDecryptor is an encryptor that just do _NOT_ encrypt/decrypt at all :)! !DummyEcryptorDecryptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/6/2012 22:07'! decrypt: aString base: aBase ^ aString! ! !DummyEcryptorDecryptor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/6/2012 22:07'! encrypt: aString base: aBase ^ aString! ! !DummyKeyPressedPlugin commentStamp: ''! A DummyKeyPressedPlugin is a dummy plugin which display the counter of keystrokes! !DummyKeyPressedPlugin methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:56'! stringMorph: anObject stringMorph := anObject! ! !DummyKeyPressedPlugin methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 5/10/2011 17:55'! initialize super initialize. counter := 0. self stringMorph contents: 'Keys pressed: ', counter printString; openInWorld. ! ! !DummyKeyPressedPlugin methodsFor: 'announcement' stamp: 'MarcusDenker 9/27/2013 18:02'! keyPressed: anAnnouncement counter := counter +1. self stringMorph contents: 'Keys pressed: ', counter printString! ! !DummyKeyPressedPlugin methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 17:12'! stringMorph ^ stringMorph ifNil: [ stringMorph := LabelMorph new enabled:false; vResizing: #shrinkWrap; hResizing: #spaceFill; yourself]! ! !DummyKeyPressedPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/10/2011 16:43'! display ^ stringMorph! ! !DummyKeyPressedPlugin class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 8/25/2011 10:01'! defaultPosition ^ #bottom! ! !DummyKeyPressedPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 2/17/2012 16:50'! description ^ 'Display the number of key pressed'! ! !DummyPackageSelectedPlugin commentStamp: ''! A DummyPackageSelectedPlugin is a dummy plugin which display the counter of keystrokes! !DummyPackageSelectedPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/11/2011 11:07'! packageSelected: anAnnouncement | package name | package := anAnnouncement package. name := package name asString. package ifNil: [ name := '']. morph ifNotNil: [ morph contents: name]! ! !DummyPackageSelectedPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/10/2011 17:54'! display morph := LabelMorph new contents: ''; enabled: false; vResizing: #shrinkWrap; hResizing: #spaceFill; yourself. ^ morph! ! !DummyPackageSelectedPlugin class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 8/25/2011 10:01'! defaultPosition ^ #middle! ! !DummySoundSystem commentStamp: ''! A BeepingSoundSystem is a simple sound system just doing beep and niling everything else. ! !DummySoundSystem methodsFor: 'query' stamp: 'StephaneDucasse 8/3/2013 22:22'! soundNamed: soundName "There are no sounds to look up." ^ nil! ! !DummySoundSystem methodsFor: 'misc' stamp: 'StephaneDucasse 8/4/2013 11:21'! randomBitsFromSoundInput: bitCount "I'm not sure what the right thing to do here is." self error: 'Can not provide random data.' "in the future we should propose a simple random generator to be for the DummySoundSystem."! ! !DummySoundSystem methodsFor: 'playing' stamp: 'StephaneDucasse 8/3/2013 22:22'! playSoundNamed: soundName ifAbsentReadFrom: aifFileName "Do nothing."! ! !DummySoundSystem methodsFor: 'playing' stamp: 'StephaneDucasse 8/3/2013 22:22'! playSampledSound: samples rate: rate "Do nothing." ! ! !DummySoundSystem methodsFor: 'beep' stamp: 'StephaneDucasse 8/3/2013 22:48'! beep "Make a primitive beep if possible." self soundEnabled ifTrue: [ self beepPrimitive ]! ! !DummySoundSystem methodsFor: 'playing' stamp: 'StephaneDucasse 8/3/2013 22:22'! playSoundNamedOrBeep: soundName "There is no sound support, so we make the beep." self beep! ! !DummySoundSystem methodsFor: 'playing' stamp: 'StephaneDucasse 8/3/2013 22:22'! playSoundNamed: soundName "Do nothing."! ! !DummySoundSystem methodsFor: 'misc' stamp: 'StephaneDucasse 8/3/2013 22:22'! sampledSoundChoices "No choices other than this." ^ #('silence')! ! !DummySoundSystem methodsFor: 'private' stamp: 'StephaneDucasse 8/3/2013 22:22'! beepPrimitive "Make a primitive beep. Not to be called directly. It is much better to use SoundSystem current beep since this method does not if sound is enabled" self primitiveFailed! ! !DummySystemProgressItem commentStamp: 'TorstenBergmann 1/31/2014 11:56'! A dummy for a system progress item! !DummySystemProgressItem methodsFor: 'reflective operations' stamp: 'SeanDeNigris 6/11/2012 11:17'! doesNotUnderstand: aMessage! ! !DummyUIManager commentStamp: 'LaurentLaffont 2/23/2011 20:16'! I'm an alternative UIManager used to run an the image without GUI. I redefine methods which requires user input as these requests are irrelevant in a headless environment. ! !DummyUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 5/31/2007 08:20'! chooseFrom: labelList values: valueList lines: linesArray title: aString ^ valueList first! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'PavelKrivanek 11/19/2012 13:12'! request: queryString initialAnswer: defaultAnswer ^ self request: queryString initialAnswer: defaultAnswer title: 'Provide the following information' entryCompletion: nil ! ! !DummyUIManager methodsFor: 'accessing' stamp: 'PavelKrivanek 11/1/2010 20:15'! progressBarEnabled: aBoolean ProgressBarEnabled := aBoolean! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'StephaneDucasse 9/7/2011 21:21'! multiLineRequest: queryString initialAnswer: defaultAnswer answerHeight: answerHeight! ! !DummyUIManager methodsFor: 'default actions' stamp: 'pavel.krivanek 5/31/2007 08:20'! fileExistsDefaultAction: anException ! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'SeanDeNigris 1/23/2014 14:41'! merge: merger informing: aString! ! !DummyUIManager methodsFor: 'default actions' stamp: 'pavel.krivanek 5/31/2007 08:20'! syntaxErrorNotificationDefaultAction: anException Transcript show: '*** SYNTAX ERROR ***'; cr. Transcript show: anException; cr. Transcript show: (thisContext stack first: (20 min: thisContext stack size)); cr. anException return.! ! !DummyUIManager methodsFor: 'default actions' stamp: 'pavel.krivanek5/31/2007 08:20'! unhandledErrorDefaultAction: anException Transcript show: '*** EXCEPTION ***'; cr. Transcript show: anException; cr. Transcript show: (thisContext stack first: (20 min: thisContext stack size)); cr. anException isResumable ifTrue: [ anException resume ] ! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'MarcusDenker 4/29/2011 00:33'! confirm: aString orCancel: cancelBlock (ProvideAnswerNotification signal: aString) ifNotNil: [:answer | ^answer == #cancel ifTrue: [cancelBlock value] ifFalse: [answer]]. self error: 'No user response possible'! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 5/31/2007 08:23'! fontFromUser: priorFont self error: 'No user response possible'! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'PavelKrivanek 11/19/2012 13:13'! request: aStringOrText initialAnswer: defaultAnswer title: aTitle entryCompletion: anEntryCompletion (ProvideAnswerNotification signal: aStringOrText) ifNotNil: [:answer | ^ answer == #default ifTrue: [defaultAnswer] ifFalse: [answer]]. self error: 'No user response possible'! ! !DummyUIManager methodsFor: 'accessing' stamp: 'PavelKrivanek 11/1/2010 20:18'! progressBarEnabled ^ ProgressBarEnabled ifNil: [ ProgressBarEnabled := true ].! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'MarcusDenker 4/29/2011 00:33'! confirm: queryString (ProvideAnswerNotification signal: queryString) ifNotNil: [:answer | ^answer]. self error: 'No user response possible'! ! !DummyUIManager methodsFor: 'display' stamp: 'pavel.krivanek 5/31/2007 08:20'! checkForNewDisplaySize Display extent = DisplayScreen actualScreenSize ifTrue: [^ self]. DisplayScreen startUp. ! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'SeanDeNigris 6/20/2012 23:32'! informUserDuring: aBlock aBlock value: DummySystemProgressItem new.! ! !DummyUIManager methodsFor: 'display' stamp: 'pavel.krivanek 5/31/2007 08:20'! 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" 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. DisplayScreen startUp! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 5/31/2007 08:20'! edit: aText label: labelString accept: anAction ^ nil! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 5/31/2007 08:20'! chooseFrom: aList lines: linesArray title: aString ^ aList first! ! !DummyUIManager methodsFor: 'default actions' stamp: 'pavel.krivanek 5/31/2007 08:20'! lowSpaceWatcherDefaultAction Transcript show: '*** LOW SPACE ***'; cr. ! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 5/31/2007 08:20'! requestPassword: queryString ^ self request: queryString initialAnswer: ''! ! !DummyUIManager methodsFor: 'default actions' stamp: 'pavel.krivanek 5/11/2008 17:44'! warningDefaultAction: anException ^ self unhandledErrorDefaultAction: anException! ! !DummyUIManager methodsFor: 'default actions' stamp: 'pavel.krivanek 5/31/2007 08:20'! fileDoesNotExistsDefaultAction: anException ! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 9/22/2012 20:17'! inform: aString "Nothing to be done here"! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'PavelKrivanek 11/19/2012 13:10'! request: aStringOrText initialAnswer: defaultAnswer entryCompletion: anEntryCompletion ^ self request: aStringOrText initialAnswer: defaultAnswer title: 'Information Required' translated entryCompletion: anEntryCompletion ! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 5/31/2007 08:20'! chooseDirectory: label from: dir ^ nil! ! !DummyUIManager methodsFor: 'display' stamp: 'pavel.krivanek 5/31/2007 08:20'! restoreDisplay! ! !DummyUIManager methodsFor: 'display' stamp: 'pavel.krivanek 5/31/2007 08:20'! restoreDisplayAfter: aBlock aBlock value. Sensor waitButton.! ! !DummyUserManager commentStamp: ''! My purpose is to be loaded in the core without breaking anything. Then the real UserManager can be used! !DummyUserManager methodsFor: 'permissions' stamp: 'BenjaminVanRyseghem 5/4/2013 01:35'! canRunStartupScript ^ true! ! !DummyUserManager methodsFor: 'permissions' stamp: 'BenjaminVanRyseghem 5/4/2013 01:39'! canBrowse ^ true! ! !DummyUserManager methodsFor: 'permissions' stamp: 'BenjaminVanRyseghem 5/4/2013 01:37'! canEditCode ^ true! ! !DummyUserManager methodsFor: 'permissions' stamp: 'BenjaminVanRyseghem 5/4/2013 01:37'! canDropOSFile ^ true! ! !DummyUserManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/4/2013 18:31'! openSwitchUsers! ! !DummyUserManager methodsFor: 'permissions' stamp: 'BenjaminVanRyseghem 5/4/2013 01:37'! canEvaluateCode ^ true! ! !DummyUserManager methodsFor: 'permissions' stamp: 'BenjaminVanRyseghem 5/4/2013 01:35'! canInspect ^ true! ! !DummyUserManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/4/2013 12:59'! reset self class reset! ! !DummyUserManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/4/2013 01:36'! userNamePasswordFor: aGroup ^ nil! ! !DummyUserManager methodsFor: 'permissions' stamp: 'BenjaminVanRyseghem 5/7/2013 18:53'! canSaveImage ^ true! ! !DummyUserManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/4/2013 01:38'! addUser: aUser ^ false! ! !DummyUserManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/4/2013 01:38'! includesUser: aUser ^ false! ! !DummyUserManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/4/2013 13:03'! setCurrentUser: aGroup "I just absorb this message"! ! !DummyUserManager methodsFor: 'permissions' stamp: 'BenjaminVanRyseghem 5/4/2013 01:37'! canShowMorphHalo ^ true! ! !DummyUserManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/4/2013 01:40'! userNames ^ #()! ! !DummyUserManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/4/2013 01:39'! users ^ #()! ! !DummyUserManager methodsFor: 'permissions' stamp: 'BenjaminVanRyseghem 5/4/2013 01:26'! canDebug ^ true! ! !DummyUserManager class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/4/2013 12:59'! reset Smalltalk tools register: self new as: #userManager! ! !DummyUserManager class methodsFor: 'class initialization' stamp: 'BenjaminVanRyseghem 5/4/2013 12:59'! initialize self reset! ! !DummyUserManager class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/4/2013 01:28'! default ^ self new! ! !DuplicatedSlotName commentStamp: ''! I am signaled when trying to build a class with a duplicated slot.! !DuplicatedSlotName methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:10'! newSlot ^ newSlot! ! !DuplicatedSlotName methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:10'! oldSlot ^ oldSlot! ! !DuplicatedSlotName methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:15'! host: anObject host := anObject! ! !DuplicatedSlotName methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:17'! messageText ^ 'Slot #''', oldSlot name, ''' appeared twice in ', host name! ! !DuplicatedSlotName methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:10'! newSlot: anObject newSlot := anObject! ! !DuplicatedSlotName methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:15'! host ^ host! ! !DuplicatedSlotName methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:10'! oldSlot: anObject oldSlot := anObject! ! !DuplicatedVariableError commentStamp: ''! I am an error signalled when a variable is redeclared. For instance when a method is created wich has a temporary or argument with the same name as an instance variable.! !DuplicatedVariableError methodsFor: 'accessing' stamp: 'Janniklaval 10/23/2010 13:07'! variable: aVariable "Name of the duplicate variable" variable := aVariable! ! !DuplicatedVariableError methodsFor: 'accessing' stamp: 'Janniklaval 10/23/2010 13:06'! superclass: aSuperclass "The superclass in which the variable is defined" superclass := aSuperclass! ! !DuplicatedVariableError methodsFor: 'accessing' stamp: 'Janniklaval 10/23/2010 13:06'! variable "Name of the duplicate variable" ^variable! ! !DuplicatedVariableError methodsFor: 'accessing' stamp: 'Janniklaval 10/23/2010 13:06'! superclass "The superclass in which the variable is defined" ^superclass! ! !DuplicatedVariableError methodsFor: 'testing' stamp: 'Janniklaval 10/23/2010 13:06'! isResumable ^true! ! !Duration commentStamp: 'marcus.denker 6/5/2009 11:27'! I represent a duration of time. I have nanosecond precision! !Duration methodsFor: 'accessing' stamp: 'GuillermoPolito 8/24/2010 11:22'! minutes "Answer a number that represents the number of complete minutes in the receiver, after the number of complete hours has been removed." ^ (seconds rem: SecondsInHour) quo: SecondsInMinute ! ! !Duration methodsFor: 'converting' stamp: 'GuillermoPolito 8/24/2010 11:14'! asSeconds "Answer the number of seconds in the receiver." ^ seconds ! ! !Duration methodsFor: 'accessing' stamp: 'GuillermoPolito 8/24/2010 11:23'! seconds "Answer a number that represents the number of complete seconds in the receiver, after the number of complete minutes has been removed." ^ (seconds rem: SecondsInMinute)! ! !Duration methodsFor: 'converting' stamp: 'CamilloBruni 12/13/2011 17:30'! asDays "Answer the number of days in the receiver." ^ self asHours / 24! ! !Duration methodsFor: 'converting' stamp: 'CamilloBruni 12/13/2011 17:30'! asHours "Answer the number of hours in the receiver." ^ self asMinutes / 60.0! ! !Duration methodsFor: 'converting' stamp: 'brp 5/13/2003 08:01'! asDuration ^ self ! ! !Duration methodsFor: '*Network-Mail' stamp: 'SeanDeNigris 12/3/2011 14:04'! asEmailTimeOffsetString "Format per RFC5322 e.g. '-0500'" ^ String streamContents: [ :str | str nextPut: (self positive ifTrue: [ $+ ] ifFalse: [ $- ]); nextPutAll: self hours abs asTwoCharacterString; nextPutAll: self minutes asTwoCharacterString ].! ! !Duration methodsFor: 'arithmetic' stamp: 'brp 5/13/2003 08:00'! < comparand ^ self asNanoSeconds < comparand asNanoSeconds ! ! !Duration methodsFor: 'arithmetic' stamp: 'GuillermoPolito 8/24/2010 11:15'! + operand "operand is a Duration" ^ self class nanoSeconds: (self asNanoSeconds + operand asNanoSeconds) ! ! !Duration methodsFor: 'arithmetic' stamp: 'GuillermoPolito 8/24/2010 11:15'! - operand "operand is a Duration" ^ self + operand negated ! ! !Duration methodsFor: 'operations' stamp: 'brp 9/25/2003 15:07'! \\ operand "modulo. Remainder defined in terms of //. Answer a Duration with the same sign as aDuration. operand is a Duration or a Number." ^ operand isNumber ifTrue: [ self class nanoSeconds: (self asNanoSeconds \\ operand) ] ifFalse: [ self - (operand * (self // operand)) ] ! ! !Duration methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:51'! initialize super initialize. self seconds: 0 nanoSeconds: 0. ! ! !Duration methodsFor: 'printing' stamp: 'CamilloBruni 5/26/2012 13:09'! printOn: aStream "Format as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]" | d h m s n | d := self days abs. h := self hours abs. m := self minutes abs. s := self seconds abs truncated. n := self nanoSeconds abs. self negative ifTrue: [ aStream nextPut: $- ]. d printOn: aStream. aStream nextPut: $:. h < 10 ifTrue: [ aStream nextPut: $0. ]. h printOn: aStream. aStream nextPut: $:. m < 10 ifTrue: [ aStream nextPut: $0. ]. m printOn: aStream. aStream nextPut: $:. s < 10 ifTrue: [ aStream nextPut: $0. ]. s printOn: aStream. n = 0 ifFalse: [ | z ps | aStream nextPut: $.. ps := n printString padLeftTo: 9 with: $0. z := ps findLast: [ :c | c asciiValue > $0 asciiValue ]. ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]. ! ! !Duration methodsFor: 'operations' stamp: 'brp 9/25/2003 14:29'! // operand "operand is a Duration or a Number" ^ operand isNumber ifTrue: [ self class nanoSeconds: (self asNanoSeconds // operand) asInteger ] ifFalse: [ self asNanoSeconds // operand asDuration asNanoSeconds ] ! ! !Duration methodsFor: 'accessing' stamp: 'brp 5/13/2003 08:01'! abs ^ self class seconds: seconds abs nanoSeconds: nanos abs ! ! !Duration methodsFor: 'accessing' stamp: 'GuillermoPolito 8/24/2010 11:21'! hours "Answer a number that represents the number of complete hours in the receiver, after the number of complete days has been removed." ^ (seconds rem: SecondsInDay) quo: SecondsInHour ! ! !Duration methodsFor: 'converting' stamp: 'CamilloBruni 12/13/2011 17:30'! asMinutes "Answer the number of minutes in the receiver." ^ seconds / 60.0! ! !Duration methodsFor: 'accessing' stamp: 'GuillermoPolito 8/24/2010 11:22'! days "Answer a number that represents the number of complete days in the receiver" ^ seconds quo: SecondsInDay ! ! !Duration methodsFor: 'operations' stamp: 'brp 9/25/2003 15:42'! roundTo: aDuration "e.g. if the receiver is 5 minutes, 37 seconds, and aDuration is 2 minutes, answer 6 minutes." ^ self class nanoSeconds: (self asNanoSeconds roundTo: aDuration asNanoSeconds) ! ! !Duration methodsFor: 'operations' stamp: 'brp 9/25/2003 15:38'! truncateTo: aDuration "e.g. if the receiver is 5 minutes, 37 seconds, and aDuration is 2 minutes, answer 4 minutes." ^ self class nanoSeconds: (self asNanoSeconds truncateTo: aDuration asNanoSeconds) ! ! !Duration methodsFor: 'accessing' stamp: 'GuillermoPolito 8/24/2010 11:14'! hash ^seconds bitXor: nanos ! ! !Duration methodsFor: 'converting' stamp: 'brp 5/13/2003 08:03'! asMilliSeconds ^ ((seconds * NanosInSecond) + nanos) // (10 raisedToInteger: 6) ! ! !Duration methodsFor: 'private' stamp: 'brp 9/25/2003 14:42'! storeOn: aStream aStream nextPut: $(; nextPutAll: self className; nextPutAll: ' seconds: '; print: seconds; nextPutAll: ' nanoSeconds: '; print: nanos; nextPut: $). ! ! !Duration methodsFor: 'accessing' stamp: 'brp 5/13/2003 08:02'! negated ^ self class seconds: seconds negated nanoSeconds: nanos negated ! ! !Duration methodsFor: 'accessing' stamp: 'brp 5/13/2003 08:02'! negative ^ self positive not ! ! !Duration methodsFor: 'accessing' stamp: 'brp 5/13/2003 08:02'! positive ^ seconds = 0 ifTrue: [ nanos positive ] ifFalse: [ seconds positive ] ! ! !Duration methodsFor: 'private' stamp: 'StephaneDucasse 9/1/2010 14:32'! seconds: secondCount nanoSeconds: nanoCount "Private - only used by Duration class" seconds := secondCount. nanos := nanoCount rounded. "normalize if signs do not match" [ nanos < 0 and: [ seconds > 0 ] ] whileTrue: [ seconds := seconds - 1. nanos := nanos + NanosInSecond ]. [ seconds < 0 and: [ nanos > 0 ] ] whileTrue: [ seconds := seconds + 1. nanos := nanos - NanosInSecond ] ! ! !Duration methodsFor: 'arithmetic' stamp: 'brp 1/9/2004 06:25'! = comparand "Answer whether the argument is a representing the same period of time as the receiver." ^ self == comparand ifTrue: [true] ifFalse: [self species = comparand species ifTrue: [self asNanoSeconds = comparand asNanoSeconds] ifFalse: [false] ]! ! !Duration methodsFor: 'converting' stamp: 'brp 5/13/2003 08:03'! nanoSeconds ^ nanos ! ! !Duration methodsFor: 'converting' stamp: 'brp 5/13/2003 08:03'! asNanoSeconds ^ (seconds * NanosInSecond) + nanos ! ! !Duration methodsFor: 'private' stamp: 'adrian_lienhard 1/7/2009 18:21'! ticks "Answer an array {days. seconds. nanoSeconds}. Used by DateAndTime and Time." | days | days := self days. ^ Array with: days with: seconds - (days * SecondsInDay) with: nanos! ! !Duration methodsFor: 'converting' stamp: 'brp 9/25/2003 13:42'! asDelay ^ Delay forDuration: self! ! !Duration methodsFor: 'operations' stamp: 'BenjaminVanRyseghem 3/14/2013 15:04'! wait self asDelay wait! ! !Duration methodsFor: 'arithmetic' stamp: 'GuillermoPolito 8/24/2010 11:15'! * operand "operand is a Number" ^ self class nanoSeconds: ( (self asNanoSeconds * operand) asInteger) ! ! !Duration methodsFor: 'arithmetic' stamp: 'sd 3/16/2008 15:36'! / operand "operand is a Duration or a Number" ^ operand isNumber ifTrue: [ self class nanoSeconds: (self asNanoSeconds / operand) asInteger ] ifFalse: [ self asNanoSeconds / operand asDuration asNanoSeconds ] ! ! !Duration methodsFor: 'testing' stamp: 'brp 4/13/2006 10:20'! isZero ^ seconds = 0 and: [ nanos = 0 ] ! ! !Duration class methodsFor: 'instance creation' stamp: 'StephaneDucasse 5/1/2010 16:13'! readFrom: aStream "Formatted as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]" | sign days hours minutes seconds nanos nanosBuffer | sign := (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. days := (aStream upTo: $:) asInteger sign: sign. hours := (aStream upTo: $:) asInteger sign: sign. minutes := (aStream upTo: $:) asInteger sign: sign. seconds := (aStream upTo: $.) asInteger sign: sign. nanosBuffer := '000000000' copy. nanos := nanosBuffer writeStream. [aStream atEnd not and: [aStream peek isDigit]] whileTrue: [nanos nextPut: aStream next]. ^ self days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: (nanosBuffer asInteger sign: sign)! ! !Duration class methodsFor: 'instance creation simple' stamp: 'gk 8/31/2006 01:27'! minutes: aNumber ^ self seconds: aNumber * SecondsInMinute nanoSeconds: 0! ! !Duration class methodsFor: 'instance creation simple' stamp: 'CamilloBruni 9/22/2012 10:49'! years: aNumber ^ self days: (aNumber * 365) seconds: 0 ! ! !Duration class methodsFor: 'instance creation' stamp: 'gk 8/31/2006 01:09'! days: days hours: hours minutes: minutes seconds: seconds ^ self days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: 0! ! !Duration class methodsFor: 'instance creation' stamp: 'adrian_lienhard 1/7/2009 18:19'! seconds: seconds nanoSeconds: nanos ^ self basicNew seconds: seconds truncated nanoSeconds: seconds fractionPart * NanosInSecond + nanos! ! !Duration class methodsFor: 'instance creation' stamp: 'gk 8/30/2006 23:18'! days: days seconds: seconds ^ self basicNew seconds: days * SecondsInDay + seconds nanoSeconds: 0 ! ! !Duration class methodsFor: 'instance creation simple' stamp: 'gk 8/31/2006 01:34'! seconds: seconds ^ self seconds: seconds nanoSeconds: 0 ! ! !Duration class methodsFor: 'instance creation simple' stamp: 'CamilloBruni 8/22/2013 19:43'! month: aMonth "aMonth is an Integer or a String" ^ (Month month: aMonth) duration ! ! !Duration class methodsFor: 'instance creation simple' stamp: 'adrian_lienhard 1/7/2009 18:22'! nanoSeconds: nanos "This method is slow. If you have nanos less than 10^6 you should use #seconds:nanoSeconds: instead." | quo | quo := nanos quo: NanosInSecond. ^ self basicNew seconds: quo nanoSeconds: nanos - (quo * NanosInSecond)! ! !Duration class methodsFor: 'instance creation simple' stamp: 'gk 8/30/2006 23:20'! weeks: aNumber ^ self days: (aNumber * 7) seconds: 0 ! ! !Duration class methodsFor: 'instance creation' stamp: 'gk 8/31/2006 01:26'! days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: nanos ^ self seconds: ((days * SecondsInDay) + (hours * SecondsInHour) + (minutes * SecondsInMinute) + seconds) nanoSeconds: nanos ! ! !Duration class methodsFor: 'instance creation simple' stamp: 'StephaneDucasse 5/5/2010 22:01'! milliSeconds: milliCount ^ self seconds: (milliCount quo: 1000) nanoSeconds: (milliCount rem: 1000) * NanosInMillisecond! ! !Duration class methodsFor: 'instance creation simple' stamp: 'gk 8/31/2006 00:09'! zero ^ self basicNew seconds: 0 nanoSeconds: 0 ! ! !Duration class methodsFor: 'instance creation simple' stamp: 'gk 8/31/2006 01:26'! hours: aNumber ^ self seconds: aNumber * SecondsInHour nanoSeconds: 0! ! !Duration class methodsFor: 'instance creation' stamp: 'PeterHugossonMiller 9/2/2009 16:18'! fromString: aString ^ self readFrom: aString readStream ! ! !Duration class methodsFor: 'instance creation simple' stamp: 'gk 8/31/2006 01:25'! days: aNumber ^ self seconds: aNumber * SecondsInDay nanoSeconds: 0! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testNegative self deny: aDuration negative. self assert: aDuration negated negative ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 9/25/2003 14:57'! testQuotient | d1 d2 q | d1 := 11.5 seconds. d2 := d1 // 3. self assert: d2 = (Duration seconds: 3 nanoSeconds: 833333333). q := d1 // (3 seconds). self assert: q = 3. ! ! !DurationTest methodsFor: 'tests' stamp: 'StephaneDucasse 4/28/2010 22:16'! testAsMilliSeconds "self debug:#testAsMilliSeconds" self assert: (Duration nanoSeconds: 1000000) asMilliSeconds = 1. self assert: (Duration seconds: 1) asMilliSeconds = 1000. self assert: (Duration nanoSeconds: 1000000) asMilliSeconds = 1. self assert: (Duration nanoSeconds: 1000000) asMilliSeconds = 1. self assert: aDuration asMilliSeconds = 93784000. self assert: (Duration milliSeconds: 3775) asSeconds = 3. self assert: (Duration milliSeconds: 3775) nanoSeconds = 775000000. self assert: (Duration milliSeconds: -3775) asSeconds = -3. self assert: (Duration milliSeconds: -3775) nanoSeconds = -775000000! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testWeeks self assert: (Duration weeks: 1) days= 7. ! ! !DurationTest methodsFor: 'tests' stamp: 'al 6/12/2008 21:57'! testHash self assert: aDuration hash = (Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5) hash! ! !DurationTest methodsFor: 'tests' stamp: 'tbn 10/29/2012 15:16'! testAsWeeks |full half quarter| full := (Duration days: 7). half := (Duration weeks: 0.5). quarter := (Duration weeks: 0.25). self assert: 1 weeks = full; assert: 1.0 weeks = full; assert: 0.5 weeks = half; assert: (1/2) weeks = half; assert: (1/4) weeks = quarter. self assert: 1.4 weeks + 1.6 weeks = 3 weeks ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testIntegerDivision self assert: aDuration // aDuration = 1. self assert: aDuration // 2 = (aDuration / 2). "is there ever a case where this is not true, since precision is always to the nano second?"! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/9/2004 06:32'! testComparing | d1 d2 d3 | d1 := Duration seconds: 10 nanoSeconds: 1. d2 := Duration seconds: 10 nanoSeconds: 1. d3 := Duration seconds: 10 nanoSeconds: 2. self assert: (d1 = d1); assert: (d1 = d2); deny: (d1 = d3); assert: (d1 < d3) ! ! !DurationTest methodsFor: 'tests' stamp: 'CamilloBruni 6/22/2012 21:47'! testAsSeconds self assert: (Duration nanoSeconds: 1000000000) asSeconds = 1. self assert: (Duration seconds: 1) asSeconds = 1. self assert: aDuration asSeconds = 93784. self assert: 1 asSeconds equals: (Duration seconds: 1). self assert: (1/2) asSeconds equals: (Duration milliSeconds: 500).! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:37'! testTruncateTo self assert: ((5 minutes + 37 seconds) truncateTo: (2 minutes)) = (4 minutes). self assert: (aDuration truncateTo: (Duration days: 1)) = (Duration days: 1 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0). self assert: (aDuration truncateTo: (Duration hours: 1)) = (Duration days: 1 hours: 2 minutes: 0 seconds: 0 nanoSeconds: 0). self assert: (aDuration truncateTo: (Duration minutes: 1)) = (Duration days: 1 hours: 2 minutes: 3 seconds: 0 nanoSeconds: 0).! ! !DurationTest methodsFor: 'tests' stamp: 'tbn 10/29/2012 16:19'! testAsYear self assert: 1 year days = 365; assert: 0.5 year asHours = ((364 / 2) * 24 + 12)! ! !DurationTest methodsFor: 'tests' stamp: 'StephaneDucasse 4/24/2010 19:50'! testSeconds self assert: aDuration seconds = 4. self assert: (Duration nanoSeconds: 2) seconds = 0. self assert: (Duration seconds: 2) seconds = 2. self assert: (Duration days: 1 hours: 2 minutes: 3 seconds:4) seconds = (4). self deny: (Duration days: 1 hours: 2 minutes: 3 seconds:4) seconds = (1*24*60*60+(2*60*60)+(3*60)+4). ! ! !DurationTest methodsFor: 'tests' stamp: 'tbn 10/29/2012 16:07'! testAsMinute |full half quarter| full := (Duration seconds: 60). half := (Duration seconds: 30). quarter := (Duration seconds: 15). self assert: 1 minute = full; assert: 1.0 minute = full; assert: 0.5 minute = half; assert: (1/2) minute = half; assert: (1/4) minute = quarter. self assert: 0.4 minute + 0.6 minute = 1 minute ! ! !DurationTest methodsFor: 'tests' stamp: 'tbn 10/29/2012 15:15'! testAsWeek |full half quarter| full := (Duration days: 7). half := (Duration weeks: 0.5). quarter := (Duration weeks: 0.25). self assert: 1 week = full; assert: 1.0 week = full; assert: 0.5 week = half; assert: (1/2) week = half; assert: (1/4) week = quarter. self assert: 0.4 week + 0.6 week = 1 week ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/9/2004 06:28'! testNumberConvenienceMethods self assert: 1 week = (Duration days: 7); assert: -1 week = (Duration days: -7); assert: 1 day = (Duration days: 1); assert: -1 day = (Duration days: -1); assert: 1 hours = (Duration hours: 1); assert: -1 hour = (Duration hours: -1); assert: 1 minute = (Duration seconds: 60); assert: -1 minute = (Duration seconds: -60); assert: 1 second = (Duration seconds: 1); assert: -1 second = (Duration seconds: -1); assert: 1 milliSecond = (Duration milliSeconds: 1); assert: -1 milliSecond = (Duration milliSeconds: -1); assert: 1 nanoSecond = (Duration nanoSeconds: 1); assert: -1 nanoSecond = (Duration nanoSeconds: -1) ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testMultiply self assert: aDuration * 2 = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testZero self assert: (Duration zero) = (Duration seconds: 0). ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/16/2004 14:17'! testMonthDurations | jan feb dec | jan := Duration month: #January. feb := Duration month: #February. dec := Duration month: #December. self assert: jan = (Year current months first duration); assert: feb = (Year current months second duration); assert: dec = (Year current months last duration) ! ! !DurationTest methodsFor: 'tests' stamp: 'damiencassou 5/30/2008 11:09'! testPrintOn | cs rw | cs := '1:02:03:04.000000005' readStream. rw := ReadWriteStream on: ''. aDuration printOn: rw. self assert: rw contents = cs contents! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testAsDelay self deny: aDuration asDelay = aDuration. "want to come up with a more meaningful test" ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testPositive self assert: (Duration nanoSeconds: 0) positive. self assert: aDuration positive. self deny: aDuration negated positive ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testPlus self assert: (aDuration + 0 hours) = aDuration. self assert: (aDuration + aDuration) = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). ! ! !DurationTest methodsFor: 'tests' stamp: 'tbn 10/29/2012 16:34'! testNanoSecond self assert: (Duration nanoSeconds: 5) = 5 nanoSecond; assert: 0.5 nanoSecond = (Duration nanoSeconds: 0.5); assert: (1/2) nanoSecond = (Duration nanoSeconds: 0.5). ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testRoundTo self assert: ((5 minutes + 37 seconds) roundTo: (2 minutes)) = (6 minutes). self assert: (aDuration roundTo: (Duration days: 1)) = (Duration days: 1 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0). self assert: (aDuration roundTo: (Duration hours: 1)) = (Duration days: 1 hours: 2 minutes: 0 seconds: 0 nanoSeconds: 0). self assert: (aDuration roundTo: (Duration minutes: 1)) = (Duration days: 1 hours: 2 minutes: 3 seconds: 0 nanoSeconds: 0).! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testMinutes self assert: aDuration minutes = 3. self assert: (Duration minutes: 3) minutes = 3. ! ! !DurationTest methodsFor: 'tests' stamp: 'tbn 10/29/2012 15:12'! testAsSecond |full half quarter| full := (Duration seconds: 1). half := (Duration seconds: 0.5). quarter := (Duration seconds: 0.25). self assert: 1 second = full; assert: 1.0 second = full; assert: 0.5 second = half; assert: (1/2) second = half; assert: (1/4) second = quarter. self assert: 0.4 second + 0.6 second = 1 second ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testSecondsNanoSeconds self assert: (Duration seconds: 0 nanoSeconds: 5) = (Duration nanoSeconds: 5). "not sure I should include in sunit since its Private " self assert: (aDuration seconds: 0 nanoSeconds: 1) = (Duration nanoSeconds: 1). ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:36'! testModulo | d1 d2 d3 | d1 := 11.5 seconds. d2 := d1 \\ 3. self assert: d2 = (Duration nanoSeconds: 1). d3 := d1 \\ (3 seconds). self assert: d3 = (Duration seconds: 2 nanoSeconds: 500000000). self assert: aDuration \\ aDuration = (Duration days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0). self assert: aDuration \\ 2 = (Duration days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 1). ! ! !DurationTest methodsFor: 'tests' stamp: 'tbn 10/24/2012 15:31'! testAsHour |full half quarter| full := (Duration minutes: 60). half := (Duration minutes: 30). quarter := (Duration minutes: 15). self assert: 1 hour = full; assert: 1.0 hour = full; assert: 0.5 hour = half; assert: (1/2) hour = half; assert: (1/4) hour = quarter! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testMinus self assert: aDuration - aDuration = (Duration seconds: 0). self assert: aDuration - (Duration days: -1 hours: -2 minutes: -3 seconds: -4 nanoSeconds: -5) = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). self assert: aDuration - (Duration days: 0 hours: 1 minutes: 2 seconds: 3 nanoSeconds: 4) = (Duration days: 1 hours: 1 minutes: 1 seconds: 1 nanoSeconds: 1). self assert: aDuration - (Duration days: 0 hours: 3 minutes: 0 seconds: 5 nanoSeconds: 0) = (Duration days: 0 hours: 23 minutes: 2 seconds: 59 nanoSeconds: 5). ! ! !DurationTest methodsFor: 'tests' stamp: 'tbn 10/29/2012 16:11'! testAsMilliSecond self assert: 1 milliSecond = (1/1000) second; assert: (1/2) milliSecond = (1/2000) second; assert: 0.5 milliSecond = (1/2000) second; assert: 500 milliSecond = (1/2) second! ! !DurationTest methodsFor: 'coverage' stamp: 'brp 9/25/2003 14:30'! classToBeTested ^ Duration ! ! !DurationTest methodsFor: 'tests' stamp: 'StephaneDucasse 4/23/2010 21:55'! testReadFromMillisecond self assert: (Duration readFrom: '0:00:00:00.001 ' readStream) nanoSeconds = 1000000! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testNegated self assert: aDuration + aDuration negated = (Duration seconds: 0). ! ! !DurationTest methodsFor: 'tests' stamp: 'damiencassou 5/30/2008 11:09'! testReadFrom self assert: aDuration = (Duration readFrom: '1:02:03:04.000000005' readStream)! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testTicks self assert: aDuration ticks = #(1 7384 5)! ! !DurationTest methodsFor: 'tests' stamp: 'StephaneDucasse 4/24/2010 10:52'! testReadFromBogus self should: [Duration readFrom: '+0:01:02' readStream] raise: Error. "Seconds should be supplied as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]"! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testHours self assert: aDuration hours = 2. self assert: (Duration hours: 2) hours = 2. ! ! !DurationTest methodsFor: 'tests' stamp: 'tbn 10/29/2012 16:19'! testAsYears self assert: 2 years days = 730; assert: 0.5 year asHours = ((364 / 2) * 24 + 12)! ! !DurationTest methodsFor: 'tests' stamp: 'CamilloBruni 12/13/2011 17:36'! testAsMinutes self assert: (Duration seconds: 60) asMinutes = 1. self assert: (Duration hours: 1) asMinutes = 60. self assert: (aDuration asMinutes closeTo: 1563.0666).! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testDivide self assert: aDuration / aDuration = 1. self assert: aDuration / 2 = (Duration days: 0 hours: 13 minutes: 1 seconds: 32 nanoSeconds: 2). self assert: aDuration / (1/2) = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testAsNanoSeconds self assert: (Duration nanoSeconds: 1) asNanoSeconds = 1. self assert: (Duration seconds: 1) asNanoSeconds = 1000000000. self assert: aDuration asNanoSeconds = 93784000000005.! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testAbs self assert: aDuration abs = aDuration. self assert: (Duration nanoSeconds: -5) abs = (Duration nanoSeconds: 5). ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testNanoSeconds self assert: aDuration nanoSeconds = 5. self assert: (Duration nanoSeconds: 5) nanoSeconds = 5. ! ! !DurationTest methodsFor: 'tests' stamp: 'tbn 10/29/2012 15:55'! testAsDay |full half quarter| full := (Duration minutes: 60*24). half := (Duration minutes: 60*12). quarter := (Duration minutes: 60*6). self assert: 1 day = full; assert: 1.0 day = full; assert: 0.5 day = half; assert: (1/2) day = half; assert: (1/4) day = quarter. self assert: 0.4 day + 0.6 day = 1 day ! ! !DurationTest methodsFor: 'tests' stamp: 'CamilloBruni 12/13/2011 17:36'! testAsDays self assert: (Duration days: 2) asDays = 2. self assert: (Duration weeks: 1) asDays = 7. self assert: (aDuration asDays closeTo: 1.08546).! ! !DurationTest methodsFor: 'tests' stamp: 'StephaneDucasse 4/24/2010 10:53'! testReadFromNoException "self debug: #testReadFromNoException" #( '0:00:00:00' '0:00:00:00.000000001' '0:00:00:00.999999999' '0:00:00:00.100000000' '0:00:00:00.10' '0:00:00:00.1' '0:00:00:01' '0:12:45:45' '1:00:00:00' '365:00:00:00' '-7:09:12:06.10' '+0:01:02:55' '+0:01:02:3') do: [:each | each asDuration printString = each]! ! !DurationTest methodsFor: 'coverage' stamp: 'brp 9/25/2003 14:30'! selectorsToBeIgnored | private | private := #( #printOn: ). ^ super selectorsToBeIgnored, private ! ! !DurationTest methodsFor: 'tests' stamp: 'CamilloBruni 12/13/2011 17:35'! testAsHours self assert: (Duration hours: 2) asHours = 2. self assert: (Duration days: 1) asHours = 24. self assert: (aDuration asHours closeTo: 26.0511).! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testAsDuration self assert: aDuration asDuration = aDuration ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testFromString self assert: aDuration = (Duration fromString: '1:02:03:04.000000005'). ! ! !DurationTest methodsFor: 'running' stamp: 'brp 1/21/2004 18:36'! setUp aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testNew "self assert: Duration new = (Duration seconds: 0)." "new is not valid as a creation method: MessageNotUnderstood: UndefinedObject>>quo:, where Duration seconds is nil"! ! !DurationTest methodsFor: 'tests' stamp: 'StephaneDucasse 9/1/2010 14:30'! testNormalizeNanoSeconds "Subtraction of two DateAndTime values may result in a request to create a Duration with negative nanoseconds and positive seconds. The resulting Duration should be normalized, otherwise its printString will be invalid." | d t1 t2 | t1 := '2004-01-07T11:55:01+00:00' asDateAndTime. t2 := '2004-01-07T11:55:00.9+00:00' asDateAndTime. d := t1 - t2. "100 millisecond difference" self assert: d nanoSeconds > 0. self assert: d seconds = 0. self assert: d nanoSeconds = 100000000. self assert: d asString = '0:00:00:00.1'. "Verify that other combinations produces reasonable printString values" self assert: (Duration seconds: 1 nanoSeconds: 100000000) printString = '0:00:00:01.1'. self assert: (Duration seconds: -1 nanoSeconds: -100000000) printString = '-0:00:00:01.1'. self assert: (Duration seconds: 1 nanoSeconds: -100000000) printString = '0:00:00:00.9'. self assert: (Duration seconds: -1 nanoSeconds: 100000000) printString = '-0:00:00:00.9' ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testDays self assert: aDuration days = 1. self assert: (Duration days: 1) days= 1. ! ! !DurationTest methodsFor: 'tests' stamp: 'brp 1/21/2004 18:38'! testLessThan self assert: aDuration < (aDuration + 1 day ). self deny: aDuration < aDuration. ! ! !DurationTest methodsFor: 'tests' stamp: 'StephaneDucasse 5/5/2010 22:06'! testMilliSeconds #( "argument (milliseconds) seconds nanoseconds" (5 0 5000000) (1005 1 5000000) (-5 0 -5000000) (-1005 -1 -5000000) (1234567 1234 567000000) (-1234567 -1234 -567000000)) do: [ :each | | duration | duration := Duration milliSeconds: each first. self assert: duration asSeconds = each second. self assert: duration nanoSeconds = each third ]! ! !DurationTest methodsFor: 'tests' stamp: 'PeterHugossonMiller 9/3/2009 16:02'! testStoreOn | stream | aDuration storeOn: (stream := (String new: 20) writeStream). self assert: stream contents = '(Duration seconds: 93784 nanoSeconds: 5)'. ! ! !DynamicClassGroup commentStamp: ''! A DynamicClassGroup is a group automatically updated whose default granularity is class.! !DynamicClassGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 13:31'! methodModified: anAnnouncement "Do not care"! ! !DynamicClassGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:41'! protocolsFor: aClass ^ aClass protocols sort! ! !DynamicClassGroup methodsFor: 'queries' stamp: 'MarcusDenker 5/6/2013 17:12'! methods ^ self classes gather: [:e | e methods ]! ! !DynamicClassGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 16:57'! methodsFor: aClass categorised: aSymbol aSymbol ifNil: [ "all" ^ self methodsFor: aClass ]. ^ (aClass methodsInProtocol: aSymbol) sort: [:a :b | a selector < b selector ]! ! !DynamicClassGroup methodsFor: 'announcements' stamp: 'GuillermoPolito 8/3/2012 14:42'! classRemoved: anAnnouncement | class | class := anAnnouncement classRemoved. blocks copy do: [:b | (b value anySatisfy: [:c | c = class ]) ifTrue: [ | col | col := OrderedCollection new. b value do: [:c | c = class ifFalse: [ col add: c ]]. blocks remove: b; add: [ col ]]]! ! !DynamicClassGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/2/2012 17:31'! addClasses: aCollection self addBlock: [ aCollection ]! ! !DynamicClassGroup methodsFor: 'queries' stamp: 'MarcusDenker 5/6/2013 17:12'! methodsFor: aClass ^ aClass methods sort: [:a :b | a selector < b selector ]! ! !DynamicClassGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 16:53'! classes ^ (self elements collect: [:e | e theNonMetaClass]) asSet asArray sort: [:a :b | a name < b name ]! ! !DynamicClassGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 13:31'! methodRemoved: anAnnouncement "Do not care"! ! !DynamicComposableModel commentStamp: ''! A DynamicComposableModel is a model of spec with a dynamic binding for subwidgets! !DynamicComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 03:30'! widgets ^ widgets! ! !DynamicComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/10/2012 21:51'! widgetsDo: aBlock self widgets do: aBlock ! ! !DynamicComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/10/2012 21:51'! needFullRebuild: aBoolean self needRebuild: aBoolean. self widgetsDo: [:e | e needRebuild: aBoolean ]! ! !DynamicComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2014 09:53'! layout: aLayout layout value: aLayout! ! !DynamicComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 09:55'! retrieveSpec: aSelector self layout ifNil: [ ^ super retrieveSpec: aSelector ]. ^ self layout selector: aSelector; yourself! ! !DynamicComposableModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize widgets := OrderedIdentityDictionary new asReactiveVariable. layout := nil asReactiveVariable. super initialize. ! ! !DynamicComposableModel methodsFor: 'error handling' stamp: 'BenjaminVanRyseghem 7/9/2012 16:01'! doesNotUnderstand: aMessage ^ widgets at: aMessage selector ifAbsent: [ super doesNotUnderstand: aMessage ]! ! !DynamicComposableModel methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 1/21/2014 09:48'! assign: aModel to: anInstVarName widgets at: anInstVarName put: aModel. aModel owner: self! ! !DynamicComposableModel methodsFor: 'instance creation' stamp: 'ClementBera 3/7/2014 11:54'! instantiateModels: aCollectionOfPairs aCollectionOfPairs pairsDo: [ :k :v | widgets at: k asSymbol put: (self createInstanceFor: v) ]! ! !DynamicComposableModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/10/2012 23:21'! initializeWidgets! ! !DynamicComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2014 09:53'! layout ^ layout value! ! !DynamicComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 09:54'! openWithSpec self layout ifNil: [ ^ super openWithSpec ]. ^ self openWithSpecLayout: self layout! ! !DynamicEyeElement commentStamp: ''! I am a dynamic eye element, if you are too lazy to create your own subclass of AbstractEyeElement, use it...! !DynamicEyeElement methodsFor: 'accessing' stamp: 'ClementBera 5/2/2013 10:27'! value ^ valueBlock value! ! !DynamicEyeElement methodsFor: 'accessing' stamp: 'ClementBera 5/2/2013 10:51'! description "For big value to print, overwrite description block" descriptionBlock ifNil: [ ^ self value asString ]. ^ descriptionBlock cull: self value! ! !DynamicEyeElement methodsFor: 'accessing' stamp: 'ClementBera 5/2/2013 10:38'! accessorCode ^ self description! ! !DynamicEyeElement methodsFor: 'accessing' stamp: 'ClementBera 5/2/2013 10:27'! label ^ labelBlock value! ! !DynamicEyeElement methodsFor: 'accessing' stamp: 'ClementBera 5/2/2013 10:28'! description: aBlock descriptionBlock := aBlock! ! !DynamicEyeElement methodsFor: 'accessing' stamp: 'ClementBera 5/2/2013 10:27'! value: anObject valueBlock := anObject! ! !DynamicEyeElement methodsFor: 'accessing' stamp: 'ClementBera 7/2/2013 15:28'! save: aValue saveBlock value: aValue! ! !DynamicEyeElement methodsFor: 'accessing' stamp: 'ClementBera 7/2/2013 15:29'! saveBlock: anObject saveBlock := anObject! ! !DynamicEyeElement methodsFor: 'accessing' stamp: 'ClementBera 5/2/2013 10:27'! label: anObject labelBlock := anObject! ! !DynamicEyeElement class methodsFor: 'instance creation' stamp: 'ClementBera 4/30/2013 16:55'! host: anObject label: aLabel value: aValue ^ (self host: anObject) label: aLabel; value: aValue; yourself! ! !DynamicEyeElement class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/21/2013 16:14'! host: anObject value: aValue ^ (self host: anObject) value: aValue; yourself! ! !DynamicEyeElement class methodsFor: 'instance creation' stamp: 'ClementBera 5/2/2013 10:32'! host: anObject label: aLabel description: aBlock value: aValue ^ (self host: anObject label: aLabel value: aValue) description: aBlock; yourself! ! !DynamicGroup commentStamp: ''! A DynamicGroup is a group automatically updated whose default granularity is method.! !DynamicGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/28/2011 13:14'! blocks ^ blocks! ! !DynamicGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/14/2012 12:25'! addAll: aCollection aCollection do: [:e | self addBlock: [{ e }]]! ! !DynamicGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/2/2012 16:59'! addBlock: aBlock blocks add: aBlock! ! !DynamicGroup methodsFor: 'protocol' stamp: 'MarcusDenker 5/6/2013 17:12'! addClasses: aCollection aCollection do: [:e | self addBlock: [ e theNonMetaClass methods ]. self addBlock: [ e theMetaClass methods ]]! ! !DynamicGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2012 13:06'! block: aBlock blocks := OrderedCollection with: aBlock! ! !DynamicGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 16:52'! classes ^ (self methods collect: [:e | e methodClass theNonMetaClass]) asSet asArray sort: [:a :b | a name < b name ]! ! !DynamicGroup methodsFor: 'accessing' stamp: 'DamienPollet 3/6/2012 19:20'! blocks: aCollection blocks := aCollection! ! !DynamicGroup methodsFor: 'announcements' stamp: 'GuillermoPolito 8/3/2012 14:44'! methodRemoved: anAnnouncement | method | method := anAnnouncement methodAffected. blocks copy do:[: b | (b value anySatisfy: [:e | e == method ]) ifTrue: [ | col | col := OrderedCollection new. b value do: [:e | e == method ifFalse: [ col add: e ]]. blocks remove: b; add: [ col ]]]! ! !DynamicGroup methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 4/14/2012 12:41'! initialize super initialize. readOnly := false. blocks ifNil: [ blocks := OrderedCollection with: [{}] ]! ! !DynamicGroup methodsFor: 'announcements' stamp: 'GuillermoPolito 8/3/2012 13:29'! methodModified: anAnnouncement | method new | method := anAnnouncement oldMethod. new := anAnnouncement newMethod. blocks copy do:[: b | (b value anySatisfy: [:e | e == method ]) ifTrue: [ | col | col := OrderedCollection new. b value do: [:e | e == method ifTrue: [ col add: new ] ifFalse: [ col add: e ]]. blocks remove: b; add: [ col ]]]! ! !DynamicGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/9/2011 16:05'! elements ^ (self blocks gather: [:block | block value]) copy asOrderedCollection removeDuplicates! ! !DynamicGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/28/2011 13:48'! or: aGroup | instance | instance := self class named: (self name, ' + ', aGroup name) blocks: (self blocks union: aGroup blocks). ( self isReadOnly or: [ aGroup isReadOnly ]) ifTrue: [ instance beReadOnly ]. instance removable: ( self removable or: [ aGroup removable ]). ^ instance! ! !DynamicGroup methodsFor: 'protocol' stamp: 'EstebanLorenzano 2/14/2014 15:38'! addClass: aClass self addClasses: { aClass }! ! !DynamicGroup methodsFor: 'announcements' stamp: 'GuillermoPolito 8/3/2012 14:42'! classRemoved: anAnnouncement | class | class := anAnnouncement classRemoved theNonMetaClass. blocks copy do: [:b | (b value anySatisfy: [:e | e methodClass theNonMetaClass = class]) ifTrue: [ | col | col := OrderedCollection new. b value do: [:e | e methodClass theNonMetaClass = class ifFalse: [ col add: e ]]. blocks remove: b; add: [ col ]]].! ! !DynamicGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/2/2012 17:49'! removeClass: aClass self blocks copy do: [:b | (b value allSatisfy: [:m | m methodClass = aClass theNonMetaClass or: [ m methodClass = aClass theMetaClass ]]) ifTrue: [ blocks remove: b ]]! ! !DynamicGroup class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 8/5/2012 15:56'! named: aString block: aBlock | instance | instance := self basicNew name: aString; block: aBlock; initialize; yourself. GroupAnnouncer uniqueInstance announce: (AGroupHasBeenCreated group: instance). ^ instance! ! !DynamicGroup class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 8/5/2012 15:56'! named: aString blocks: aCollection | instance | instance := self basicNew name: aString; blocks: aCollection; initialize; yourself. GroupAnnouncer uniqueInstance announce: (AGroupHasBeenCreated group: instance). ^ instance! ! !DynamicMessageImplementor commentStamp: ''! Called in the debugger to generate methods when you click on the create button! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:14'! writeArgumentNameIfNecessaryOf: aKeyword at: anIndex (self hasParameter: aKeyword) ifTrue: [ self writeArgumentNameAt: anIndex ]! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:08'! writeSetterSourceCodeIfNecessary self isMessageASetter ifTrue: [ self writeSetterSourceCode ]! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:19'! argumentNamePrefixOf: argumentClassName ^ argumentClassName first isVowel ifTrue: [ 'an' ] ifFalse: [ 'a' ]! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'ClementBera 6/28/2013 14:27'! writeSourceCode self writeMethodName. self writeShouldBeImplementedIfNecessary. self writeGetterSourceCodeIfNecessary. self writeSetterSourceCodeIfNecessary! ! !DynamicMessageImplementor methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 16:38'! isMessageAGetter ^ message numArgs = 0 and: [ class instVarNames includes: message selector ]! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:14'! write: aKeyword of: anIndex stream nextPutAll: aKeyword. self writeArgumentNameIfNecessaryOf: aKeyword at: anIndex! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:08'! writeGetterSourceCodeIfNecessary self isMessageAGetter ifTrue: [ self writeGetterSourceCode ]! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'ClementBera 6/28/2013 14:28'! writeShouldBeImplementedIfNecessary self messageShouldBeImplemented ifTrue: [ self writeShouldBeImplemented ]! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:08'! writeSetterSourceCode stream cr; tab; nextPutAll: message selector allButLast; nextPutAll: ' := '; nextPutAll: argumentNames anyOne ! ! !DynamicMessageImplementor methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 17:11'! hasParameter: aKeyword ^ aKeyword last = $: or: [ message selector isInfix ]! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:04'! writeShouldBeImplemented stream cr; tab; nextPutAll: 'self '; nextPutAll: #shouldBeImplemented; nextPut: $.! ! !DynamicMessageImplementor methodsFor: 'initialization' stamp: 'HernanWilkinson 10/12/2010 16:32'! initializeFor: aMessage in: aClass message := aMessage. class := aClass! ! !DynamicMessageImplementor methodsFor: 'evaluating' stamp: 'HernanWilkinson 10/12/2010 17:02'! value argumentNames := Set new. stream := WriteStream on: String new. self writeSourceCode. ^ stream contents! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'SeanDeNigris 5/28/2013 18:09'! argumentNameAt: anIndex | argumentName argument | argument := message arguments at: anIndex. argumentName := argument class canonicalArgumentName. [ argumentNames includes: argumentName ] whileTrue: [ argumentName := argumentName , anIndex asString ]. argumentNames add: argumentName. ^ argumentName! ! !DynamicMessageImplementor methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 16:52'! isMessageASetter ^ message numArgs = 1 and: [ class instVarNames includes: message selector allButLast ]! ! !DynamicMessageImplementor methodsFor: 'testing' stamp: 'ClementBera 6/28/2013 14:29'! messageShouldBeImplemented ^ (self isMessageAGetter | self isMessageASetter) not! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:08'! writeGetterSourceCode stream cr; tab; nextPutAll: '^ '; nextPutAll: message selector ! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:09'! writeMethodName message selector keywords doWithIndex: [ :aKeyword :anIndex | self write: aKeyword of: anIndex ]! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:16'! writeArgumentNameAt: anIndex | argumentName | argumentName := self argumentNameAt: anIndex. stream nextPutAll: ' '; nextPutAll: argumentName; space! ! !DynamicMessageImplementor class methodsFor: 'instance creation' stamp: 'HernanWilkinson 10/12/2010 16:31'! for: aMessage in: aClass ^ self new initializeFor: aMessage in: aClass! ! !DynamicMessageImplementorTest commentStamp: 'TorstenBergmann 2/4/2014 20:46'! SUnit tests for class DynamicMessageImplementor! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'CamilloBruni 7/3/2013 16:01'! testGenerateGetter | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #instVar) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted equals: 'instVar ^ instVar' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'SeanDeNigris 5/28/2013 18:33'! testNonConflictingArgumentNames | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #m1:m2:m3: arguments: #(1 $a 'string')) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted equals: 'm1: anInteger m2: aCharacter m3: aString self shouldBeImplemented.' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'SeanDeNigris 5/28/2013 18:42'! testOneArgumentNotMatchingAnInstanceVariable | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #m1: argument: 1) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted equals: 'm1: anInteger self shouldBeImplemented.' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'CamilloBruni 7/3/2013 16:02'! testGenerateSetter | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #instVar: argument: 1) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted equals: 'instVar: anInteger instVar := anInteger' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'SeanDeNigris 5/28/2013 18:16'! testBinaryMessage | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #+ argument: 1) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted equals: '+ anInteger self shouldBeImplemented.' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'SeanDeNigris 5/28/2013 18:41'! testUnaryMessageNotMatchingAnInstanceVariable | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #m1) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted equals: 'm1 self shouldBeImplemented.' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'SeanDeNigris 5/28/2013 18:31'! testConflictingArgumentNames | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #m1:m2:m3: arguments: #(1 2 3)) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted equals: 'm1: anInteger m2: anInteger2 m3: anInteger3 self shouldBeImplemented.' withSeparatorsCompacted! ! !DynamicSpecExample commentStamp: ''! I am an example of how to fully dynamically create a UI, and also how to dynamically redrawn a widget. ========================== (DynamicSpecExample object: nil) open. (DynamicSpecExample object: 4) open. (DynamicSpecExample object: 'Hello World') open.! !DynamicSpecExample methodsFor: 'accessing' stamp: 'PavelKrivanek 12/13/2013 11:18'! object: anObject object value: anObject! ! !DynamicSpecExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. object := nil asReactiveVariable.! ! !DynamicSpecExample methodsFor: 'accessing' stamp: 'PavelKrivanek 12/13/2013 11:19'! object ^ object value! ! !DynamicSpecExample methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/1/2013 15:48'! openOnNil | ui layout | ui := DynamicComposableModel new. ui title: self title. ui instantiateModels: #( text TextInputFieldModel ). ui text text: 'Object is nil'; enabled: false. layout := SpecLayout composed newRow: #text height: 25; yourself. ui openWithSpecLayout: layout.! ! !DynamicSpecExample methodsFor: 'protocol' stamp: 'PavelKrivanek 12/13/2013 11:21'! openOnString | ui layout bottomLayout temp | ui := DynamicComposableModel new. ui title: self title. ui instantiateModels: #( label LabelModel check CheckBoxModel text TextInputFieldModel button ButtonModel ). ui label text: object value. object whenChangedDo: [ :o | ui label text: o asString ]. ui text text: object value; enabled: true; acceptBlock: [ :string | self object: string ]. temp := object value. ui button label: 'reset'; state: false; action: [ ui text text: temp. self object: temp ]. layout := SpecLayout composed newColumn: [ :c | c newRow: [ :r | r add: #label; add: #check width: 100 ] height: 25; newRow: [ :r | r add: #text; add: #button ] height: 25 ]; yourself. bottomLayout := SpecLayout composed newColumn: [ :c | c newRow: [ :r | r add: #text; add: #button ] height: 25; newRow: [ :r | r add: #label; add: #check width: 100 ] height: 25 ]; yourself. ui check label: 'Label on top'; state: true; whenActivatedDo: [ ui needFullRebuild: false. ui buildWithSpecLayout: layout ]; whenDesactivatedDo: [ ui needFullRebuild: false. ui buildWithSpecLayout: bottomLayout ]. ui openWithSpecLayout: layout.! ! !DynamicSpecExample methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 4/30/2013 16:17'! title ^ 'Dynamic Examples'! ! !DynamicSpecExample methodsFor: 'protocol' stamp: 'PavelKrivanek 12/13/2013 11:19'! openOnInteger | ui layout | ui := DynamicComposableModel new. ui title: self title. ui instantiateModels: #( text LabelModel plus ButtonModel minus ButtonModel ). ui text text: object value asString. ui minus label: '-'; state: false; action: [ object value: object value -1. ui text text: object value asString ]. ui plus label: '+'; state: false; action: [ object value: object value +1. ui text text: object value asString ]. layout := SpecLayout composed newColumn: [ :c | c add: #text height: 25; newRow: [ :r | r add: #minus ; addSplitter; add: #plus ] height: 25 ]; yourself. ui openWithSpecLayout: layout.! ! !DynamicSpecExample methodsFor: 'protocol' stamp: 'PavelKrivanek 12/13/2013 11:20'! open object value ifNil: [ ^ self openOnNil ]. object value isInteger ifTrue: [ ^ self openOnInteger ]. object value isString ifTrue: [ ^ self openOnString ]! ! !DynamicSpecExample class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/2/2013 15:36'! object: object ^ self new object: object; yourself! ! !DynamicVariable commentStamp: 'mvl 3/13/2007 13:55'! My subclasses are dynamic variables: each subclass represents a variable whose value persists inside the block passed to #value:during:. There is no way to change the value inside such a block, but it is possible to temporarirly rebind it in a nested manner.! !DynamicVariable methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/3/2012 21:53'! value: anObject during: aBlock | p oldValue | p := Processor activeProcess. oldValue := (p psValueAt: index) ifNil: [ self default ]. ^ [ p psValueAt: index put: anObject. aBlock value ] ensure: [ p psValueAt: index put: oldValue ]! ! !DynamicVariable class methodsFor: 'accessing' stamp: 'IgorStasenko 11/2/2011 18:40'! value: anObject during: aBlock ^ self soleInstance value: anObject during: aBlock! ! !DynamicWidgetChange commentStamp: ''! I am a dummy proto to see how easy it is to replace a subwidget with another one dynamically. DynamicWidgetChange new openWithSpec! !DynamicWidgetChange methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 22:55'! initialize super initialize. boolean := true! ! !DynamicWidgetChange methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/30/2013 16:04'! button ^ button! ! !DynamicWidgetChange methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/25/2013 18:24'! changeToList self instantiateModels: #( bottom #ListModel ). bottom items: (1 to: 100) asOrderedCollection.! ! !DynamicWidgetChange methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/30/2013 16:08'! changeToButton self instantiateModels: #( bottom ButtonModel ). bottom label: 'I am useless'.! ! !DynamicWidgetChange methodsFor: 'initialization' stamp: 'CamilloBruni 9/22/2013 21:33'! initializeWidgets button := self newButton. bottom := self newList. button label: 'Change'; action: [ self change ]; state: false. bottom items: (1 to: 10) asOrderedCollection.! ! !DynamicWidgetChange methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/30/2013 16:05'! bottom ^ bottom! ! !DynamicWidgetChange methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/30/2013 16:09'! change boolean := boolean not. boolean ifTrue: [ self changeToList ] ifFalse: [ self changeToButton ]. self needRebuild: false. button needRebuild: false. self openWithSpec! ! !DynamicWidgetChange class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 4/30/2013 16:05'! defaultSpec ^ SpecLayout composed newRow: #button height: 25; newRow: #bottom top: 25; yourself! ! !EUCJPTextConverter commentStamp: ''! Text converter for Japanese variation of EUC.! !EUCJPTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 10:09'! leadingChar ^ JISX0208 leadingChar ! ! !EUCJPTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'! languageEnvironment ^ JapaneseEnvironment. ! ! !EUCJPTextConverter class methodsFor: 'utilities' stamp: 'yo 12/19/2003 22:00'! encodingNames ^ #('euc-jp' 'eucjp') copy ! ! !EUCKRTextConverter commentStamp: ''! Text converter for Korean variation of EUC.! !EUCKRTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 15:19'! leadingChar ^ KSX1001 leadingChar ! ! !EUCKRTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'! languageEnvironment ^ KoreanEnvironment. ! ! !EUCKRTextConverter class methodsFor: 'utilities' stamp: 'yo 2/17/2004 18:45'! encodingNames ^ #('euc-kr' 'ks-c-5601-1987' 'euckr') copy ! ! !EUCTextConverter commentStamp: ''! Text converter for Extended Unix Character. This is an abstract class. The CJK variations are implemented as subclasses.! !EUCTextConverter methodsFor: 'private' stamp: 'yo 10/4/2003 15:48'! nonUnicodeClass ^ (EncodedCharSet charsetAt: self leadingChar). ! ! !EUCTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:40'! languageEnvironment self subclassResponsibility ! ! !EUCTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 10:09'! leadingChar ^ self subclassResponsibility ! ! !EUCTextConverter methodsFor: 'conversion' stamp: 'MarcusDenker 3/28/2011 22:15'! nextPut: aCharacter toStream: aStream | value leadingChar nonUnicodeChar value1 value2 | aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream]. value := aCharacter charCode. leadingChar := aCharacter leadingChar. (leadingChar = 0 and: [value < 128]) ifTrue: [ aStream basicNextPut: (Character value: value). ^ aStream ]. (128 <= value and: [value < 256]) ifTrue: [^ aStream]. nonUnicodeChar := self nonUnicodeClass charFromUnicode: value. nonUnicodeChar ifNotNil: [ value := nonUnicodeChar charCode. value1 := value // 94 + 161. value2 := value \\ 94 + 161. aStream basicNextPut: (Character value: value1). aStream basicNextPut: (Character value: value2). ^ aStream ] ! ! !EUCTextConverter methodsFor: 'conversion' stamp: 'SvenVanCaekenberghe 2/27/2013 20:57'! nextFromStream: aStream | character1 character2 offset value1 value2 nonUnicodeChar | aStream isBinary ifTrue: [^ aStream basicNext]. (character1 := aStream basicNext) ifNil: [^ nil]. character1 asciiValue <= 127 ifTrue: [^ character1]. (character2 := aStream basicNext) ifNil: [^ nil]. offset := 16rA1. value1 := character1 asciiValue - offset. value2 := character2 asciiValue - offset. (value1 < 0 or: [value1 > 93]) ifTrue: [^ nil]. (value2 < 0 or: [value2 > 93]) ifTrue: [^ nil]. nonUnicodeChar := Character leadingChar: self leadingChar code: value1 * 94 + value2. ^ Character codePoint: nonUnicodeChar asUnicode. ! ! !EUCTextConverterTest commentStamp: 'TorstenBergmann 2/5/2014 09:58'! SUnit tests for EUC-JP encoding! !EUCTextConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 2/27/2013 20:57'! testEUCJP | encodingName halfwidthKatakanaLetterKa cjkUnifiedIdeograph6CB4 cjkUnifiedIdeograph50BA encodedHalfwidthKatakanaLetterKa encodedCJKUnifiedIdeograph6CB4 encodedCJKUnifiedIdeograph50BA japaneseInJapanese | encodingName := 'euc-jp'. "Example characters taken from: http://www.sljfaq.org/afaq/encodings.html#encodings-EUC-JP" halfwidthKatakanaLetterKa := Character codePoint: 16rFF76. cjkUnifiedIdeograph6CB4 := Character codePoint: 16r6CB3. cjkUnifiedIdeograph50BA := Character codePoint: 16r50BA. encodedHalfwidthKatakanaLetterKa := #[16r8E 16rB6]. encodedCJKUnifiedIdeograph6CB4 := #[16rB2 16rCF]. encodedCJKUnifiedIdeograph50BA := #[16r8F 16rB2 16rB0]. self assert: ((String with: cjkUnifiedIdeograph6CB4) convertToEncoding: encodingName) asByteArray = encodedCJKUnifiedIdeograph6CB4. "EUCJPTextConverter does not currently support encoding the characters defined in the JIS-X-0201 and JIS-X-0212 standards:" self assert: ((String with: halfwidthKatakanaLetterKa) convertToEncoding: encodingName) asByteArray = #[]. self assert: ((String with: cjkUnifiedIdeograph50BA) convertToEncoding: encodingName) asByteArray = #[]. self assert: (encodedCJKUnifiedIdeograph6CB4 asString convertFromEncoding: encodingName) = (String with: cjkUnifiedIdeograph6CB4). "EUCJPTextConverter does not currently support decoding the representations that start with the 8E and 8F markers:" self assert: (encodedHalfwidthKatakanaLetterKa asString convertFromEncoding: encodingName) = (String new). self assert: (encodedCJKUnifiedIdeograph50BA asString convertFromEncoding: encodingName) = (String new). japaneseInJapanese := #(16r65E5 16r672C 16r8A9E) collect: [ :codePoint | Character codePoint: codePoint ] as: String. ((japaneseInJapanese convertToEncoding: encodingName) convertFromEncoding: encodingName) = japaneseInJapanese.! ! !EclipseUIThemeIcons commentStamp: ''! An icon set pack taken from eclipse.! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! protocolProtected2IconContents "Private - Method generated" ^ 'R0lGODlhEAAQALMAAL6cKLuYJ7uZJ66HH7ONIrKNIqd+HKqBHaqCHq6HIP7elv7PbP////// /wAAAAAAACH5BAEAAA0ALAAAAAAQABAAAAQksMlJq70468016A2gfFugMIqgFQvjLoSWtMvA HQsCGmDv/5kIADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! smallBackIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAP797/375v332f765vzyyv732f732v322f322vzpqPztuf3yyf3yyv72 2fvgjPzkmfvkmfzoqPzoqf3tufvdg/zgjPzjmb2EFq51Erd9FLd+FLV7FLV8FLyCFrmAFbuC FqtwEatxEaluEa90Eq1yEqdsEKZrEP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACcALAAA AAAQABAAAAZkwJNwSCwaj0jh5ZIkdgCdpvADAHyknkFg4Ol6PcSMACEoCAwHRKHR0Ag5DMZi IY8T6IyNcDRRKPp9fhODGEMkEhEJiBGMEo4kRCEWEA8gIZYhmUYiDhUiUkIlFCWgQiYmpaml QQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:21'! confirmIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQaAPb9/wJGjA5ipFWQv7bQ5MfU0PT7/5a2xff8//j9//r9//f9//z+//X8 //3+//n9/+zy9fb8/whUmPv+/wxcn/Lz9e3y9f7+/wtdn/Hy9f///wAAAAAAAAAAAAAAAAAA ACH5BAEAABoALAAAAAAQABAAAAWIoCaOZFkWgxAEwlCY2hEMRJURQ3CUh0A4AIEAcCEIdqJC 4AcIDgEOQuClGQwYTQC2yWBYRT5FU/icTIyiAOTxEAubCoUlkIYk7gAKBvC4Q+gaPggICwAS EgsLhGhVA4MIACsNABEIXxpKBA0NKysRDVJUMT4GpaZGSCMyNKU4OjAoKiwuMLUlIQA7'! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! changeSorterIconContents "Private - Method generated" ^ 'R0lGODlhEAAQALMAAI5GlKZ5qm92hGV9lFyFpU6PvVSLs01aXRuGe0WTiHipov///wAAAAAA AAAAAAAAACH5BAEAAAsALAAAAAAQABAAAARGcMlJq10KoaRumUi3XYY1WiWWbGeVrlJLvQgm T6mysgl6/YQLYEiUDISARWAoEVwCSqZgOrUsoZKD4GBlKrNISQD7Gy6HEQA7'! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! protocolPublic2IconContents "Private - Method generated" ^ 'R0lGODlhEAAQALMAABCGTTSYaEShdH29n5HIrh6JUnGxdYm4gf///////wAAAAAAAAAAAAAA AAAAAAAAACH5BAEAAAkALAAAAAAQABAAAAQpMMlJq704680xEQKxEcFxBGIWGAhiBBpwtAeg DXI9bEMB7J2gcEjURAAAOw=='! ! !EclipseUIThemeIcons methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/26/2013 15:29'! overlayModificationIconContents "Private - Method generated" ^ 'R0lGODlhCwAKAKIAAD8/X////7+/v5+fn4CAgF9fXwAAAP///yH5BAEAAAcALAAAAAALAAoA AAMpeLHMpwXIGV4A8RZTFR7BsHUXEXAEZwHCYAyC6jUnCRg4DpC08/zARwIAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! imageIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAPcAAMBSU8FTVLFRU+N8fdWPkdWTl6NiaLpjbMGOldzV3P/+/+Lg5fv6//n4 /fj3/1FRU/z8/vr6/G5zkPr7//n6/vj5/Wl0lO3x/NTX4Gp1kfDz+mZ1kmh3lGd2k2h2k2h2 kcnU6vr7/W97kWx3i1BuoFRwn1VwnWd3kWh4km96jOXt+vf6/1KG0VFxoFV0omx5jFF2qn+n 25CYo1mQ01OAt16Qy1F8r5O55rfU9qS1yXR+itjl9fP4/vD1+1GHw1qSz1qQzFWIwV2RylSC toy1477FzViTz1OIvluTzG12f8XV5eny++Xu91GFtLbG1XR+h3ORqVxufJequHZ/hoKLkubv 9vf7/lySuLbEzdDt/c/s/HeAhdLs+c3u/c7u/c/s+tDt+2h1e3B9g3uIjrzc6c7u+9Ds+M/t +M3t+MPLzc/X2fr+/3iChOj2+X2IiuH6/oCKi36EhP7///H9+19lYWRqZn+FgXqAfJacmLK5 soSHfpicjoOGe4qLeYqLe3p5ZY+OeZGPdpWSc6SdZ6WeapuWcJqUcJeScqabZaidZ6ecZqac Z6acaaCXbKeaZaibZqebZ6icaKebaaWabKSZa9mqWL6kg3txZf/69ItwU5iPhv/+/WxeU7i0 sbOEaNjT0NJqUeCNf/y/urd8eM1VVMBSUdt5eJBTUpNWVbywsP///////wAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAKsALAAAAAAQABAAAAj4AFcJHEiwoEBC kCAtGpTIUSRGkh5JUoRIIKUyYMyU0VKGy5kuXr5omSSwERojNZD8EELCRIkWLlQ0EmgIDAgl ey7hgGGDRpMhTAoJPATmTRROlj7FYHHER5AqggQG+oIp04M/oA5AuTIDyBJAAvt8IVXJU6g5 nTRJIXLjgh+BesAgwHMK1Q45bYo4yaGBj8A4WWSQMSBglBwMY6gk6WFH4JYscLAQAFBK1Bo2 YcTwmCLwiRYFC/IUCDBAgRo6bhzoEJhCC4RNCVKZSqNKVZ07FEQIfPHFSgUGKyhMiFChQQgr IwRKONGhwwkUFjJ04PDBw4cNBrMTDAgAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! paintIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAPcAAMBSU8FTVLFRU+N8fdWPkdWTl6NiaLpjbMGOldzV3P/+/+Lg5fv6//n4 /fj3/1FRU/z8/vr6/G5zkPr7//n6/vj5/Wl0lO3x/NTX4Gp1kfDz+mZ1kmh3lGd2k2h2k2h2 kcnU6vr7/W97kWx3i1BuoFRwn1VwnWd3kWh4km96jOXt+vf6/1KG0VFxoFV0omx5jFF2qn+n 25CYo1mQ01OAt16Qy1F8r5O55rfU9qS1yXR+itjl9fP4/vD1+1GHw1qSz1qQzFWIwV2RylSC toy1477FzViTz1OIvluTzG12f8XV5eny++Xu91GFtLbG1XR+h3ORqVxufJequHZ/hoKLkubv 9vf7/lySuLbEzdDt/c/s/HeAhdLs+c3u/c7u/c/s+tDt+2h1e3B9g3uIjrzc6c7u+9Ds+M/t +M3t+MPLzc/X2fr+/3iChOj2+X2IiuH6/oCKi36EhP7///H9+19lYWRqZn+FgXqAfJacmLK5 soSHfpicjoOGe4qLeYqLe3p5ZY+OeZGPdpWSc6SdZ6WeapuWcJqUcJeScqabZaidZ6ecZqac Z6acaaCXbKeaZaibZqebZ6icaKebaaWabKSZa9mqWL6kg3txZf/69ItwU5iPhv/+/WxeU7i0 sbOEaNjT0NJqUeCNf/y/urd8eM1VVMBSUdt5eJBTUpNWVbywsP///////wAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAKsALAAAAAAQABAAAAj4AFcJHEiwoEBC kCAtGpTIUSRGkh5JUoRIIKUyYMyU0VKGy5kuXr5omSSwERojNZD8EELCRIkWLlQ0EmgIDAgl ey7hgGGDRpMhTAoJPATmTRROlj7FYHHER5AqggQG+oIp04M/oA5AuTIDyBJAAvt8IVXJU6g5 nTRJIXLjgh+BesAgwHMK1Q45bYo4yaGBj8A4WWSQMSBglBwMY6gk6WFH4JYscLAQAFBK1Bo2 YcTwmCLwiRYFC/IUCDBAgRo6bhzoEJhCC4RNCVKZSqNKVZ07FEQIfPHFSgUGKyhMiFChQQgr IwRKONGhwwkUFjJ04PDBw4cNBrMTDAgAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:21'! helpIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAP78/f7+//Lz9/Hy9vv8/46Zr/z9/4+arpKdr7W9yvf6/9zj7cvT3tzk 79vj7rO9ybS+ytrk8Cphl1N/rJaxzKO706K60o2esLO9x9vl79rk7tnj7dzl7tvk7fn8//3+ /yZimClimShhlilil0Z1oU9/rVGAqlB/qVJ/qFOAqV6KsW2Tt3icvpSz0JSyzpWzz6G71Nvl 7trk7SZilidjlyhkmCdjlShilCljlU2Aq0+Aq1CBrE+AqFCAqFyJsGmUt5SyzJWzzZezy5ay yiZjkk2BqU+Bpl2NsZSyytvk69rj6ufw9/b7/62xtPj8//f7/u7y9ZOzypSzyNnm79jl7tvm 7Obv9Kuws/f8//n9//j9//b9//X9//T8/ury9Pr+//n9/vj8/fb+//T+//L8/fj+/vf9/ezy 8vz//6iysfv//vj8+6izr/3//v///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAG4ALAAAAAAQABAAAAfLgG6Cg4SFhR1DOSMSOkML hm4QOkIdAgMyQjsJhQ8ISQFaY1pcAA0XGINVJxpoGyQhIjYOAR0mj25AFG1PRzYrQDc4WGpS LYI9VAYEFSxaWCYzWB9KE4IjZ1oeWV9aKiIqBltQN4I2Xk5lYlg+Nz8EYmtnNYImEQpOXGBE IFphZh4MSgiKQgHLEy1ZYFjoIoYLliBIBGXgMYUJEyzBulikYiTGoCYFOjDUIoYJGQ4HrhRi U8RFgyVWOLzIkQaSBiApaNBAMcQjpJ+EAgEAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! jumpIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAAOASByKVCmPWi2UXkGZZ0qgbj+XYF+oej+YX0qbZVancGywgmywg2mr f3CxhV+qdGKqcHGxdnGxdYS/hIK9goS+hIK1f4i5gYi4gYm4gZjGkJe9iKvPmavPmLTSnf// /yH5BAEAAB8ALAAAAAAQABAAAAU/4CeOZGmeaKqupAMMzlo8nvYUKaNwfKcsKAClQpxQAKgA JBKRRCAB1AFxwWQuhkOKkNhYEoRVAyBosM7otDoEADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallOpenIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAPjomPjwyPjosOjQiPDYkPjgmPjgoPjYiPjQeODAePjYkPjQgNiwcLyF MsOLNrR/MqVsJK1yK7x/MsOFNq1sJJ5mJ61yL55fHZ5fII9SGf///////wAAAAAAAAAAAAAA ACH5BAEAABsALAAAAAAQABAAAAVV4CaOZGmeaGo6rKNulCZrVDoBADEkzOT7pEZgSCw2SBKB csnEkB6GqMFCrVo3EYXWUuh6uwPLBnI4WMpodFh0QVgW8Dh8LcpYEPg8nj6q+P+AL4KDIQA7'! ! !EclipseUIThemeIcons methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/26/2013 15:28'! overlayAddIconContents "Private - Method generated" ^ 'R0lGODlhCwAKAKIAAD8/X////19fXwAAAP///wAAAAAAAAAAACH5BAEAAAQALAAAAAALAAoA AAMkSLHMpALIGV4AQoQ8qsIa511N0FngJpxfprLXIMvAWDpPrj8JADs='! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/10/2013 14:38'! packageIcon ^ icons at: #'packageIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self packageIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private - notused' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallProjectIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAJWBiJWBiYl7jXJxk19knWBknmBknWBlnWNnmV9lnVZfnlFco1JdokVV qEVWqEpapYWRyDlPrTlQrD9UqihGsy5JsC9KsS9KsDVOrZK17JK27JK165K2653F8p3G8p7F 8p7G8qnW+anV+KnW+LHh/frpnvbflv/xwv/rs+zRi//lpP/aif/flv/Rdf/VfePBfdmycdCs eNGtedCsef///////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADUALAAA AAAQABAAAAZ8wJpwSCwaj0iZUoYczmhQWuwYCABKJVPqBQN4vYGaAHIqm88niEA4QLnfcNRg iFDZ73gVYqhgsRIGBQaDBAcEBoA1DyuMDCSPkJALNRMuLg4jIiEjIZ2bDUIYLREfHx4gHyAd ICASQxUWGRkcGxobHLMXRRS8vb5NwMFGQQA7'! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/14/2013 16:27'! testYellowIcon ^ icons at: #'testYellowIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self testYellowIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallPaintIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAPcAAMBSU8FTVLFRU+N8fdWPkdWTl6NiaLpjbMGOldzV3P/+/+Lg5fv6//n4 /fj3/1FRU/z8/vr6/G5zkPr7//n6/vj5/Wl0lO3x/NTX4Gp1kfDz+mZ1kmh3lGd2k2h2k2h2 kcnU6vr7/W97kWx3i1BuoFRwn1VwnWd3kWh4km96jOXt+vf6/1KG0VFxoFV0omx5jFF2qn+n 25CYo1mQ01OAt16Qy1F8r5O55rfU9qS1yXR+itjl9fP4/vD1+1GHw1qSz1qQzFWIwV2RylSC toy1477FzViTz1OIvluTzG12f8XV5eny++Xu91GFtLbG1XR+h3ORqVxufJequHZ/hoKLkubv 9vf7/lySuLbEzdDt/c/s/HeAhdLs+c3u/c7u/c/s+tDt+2h1e3B9g3uIjrzc6c7u+9Ds+M/t +M3t+MPLzc/X2fr+/3iChOj2+X2IiuH6/oCKi36EhP7///H9+19lYWRqZn+FgXqAfJacmLK5 soSHfpicjoOGe4qLeYqLe3p5ZY+OeZGPdpWSc6SdZ6WeapuWcJqUcJeScqabZaidZ6ecZqac Z6acaaCXbKeaZaibZqebZ6icaKebaaWabKSZa9mqWL6kg3txZf/69ItwU5iPhv/+/WxeU7i0 sbOEaNjT0NJqUeCNf/y/urd8eM1VVMBSUdt5eJBTUpNWVbywsP///////wAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAKsALAAAAAAQABAAAAj4AFcJHEiwoEBC kCAtGpTIUSRGkh5JUoRIIKUyYMyU0VKGy5kuXr5omSSwERojNZD8EELCRIkWLlQ0EmgIDAgl ey7hgGGDRpMhTAoJPATmTRROlj7FYHHER5AqggQG+oIp04M/oA5AuTIDyBJAAvt8IVXJU6g5 nTRJIXLjgh+BesAgwHMK1Q45bYo4yaGBj8A4WWSQMSBglBwMY6gk6WFH4JYscLAQAFBK1Bo2 YcTwmCLwiRYFC/IUCDBAgRo6bhzoEJhCC4RNCVKZSqNKVZ07FEQIfPHFSgUGKyhMiFChQQgr IwRKONGhwwkUFjJ04PDBw4cNBrMTDAgAOw=='! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/10/2013 12:44'! nautilusIcon ^ self smallSystemBrowserIcon! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallLanguageIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOZfAP79772EFqa72PzuuI6o0ODp66ZrEP30zpiw0yRonFeDqsjW47mcZfzp pJiw1Pvll9bh57fJ3v364kF4pC1tnv354ihqnurr2nqVrfvopP354a6QYqhtEbJ3E9nZwrV8 FOTr6rC7p+Hn4MLPya+hc7vBnu3nxdjd1lOBqc7Y3mGPu2iMqJWzyrqymIWpxSdqna6Ycdbh 6EmAs/30zS5tns62gdHQuMy0gLbJ3rfI3qhtEN3AgnSSrChqna50E5yeopCwyZqKWufgtcvS zb2me8avftGpVOTr66rBzKtwEanB0cjV47mcY1yFpdvj5enu6FyGpTNwoEh7pqCzp6a5srOe eLl/Ff764buBFuLize/y5sfSxr6+qr/M1kyBtP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAF8ALAAAAAAQABAAAAeagF+Cg4SFhoeIgwwBjAEM hhgKCiRcAJYAOwGECkAFNUcsSpeWWIIoBQU3BSBPWkgVVxoSElY8LhAxRRBOIhcjWwfBMx9S CwtLRAspJ1kmVAPQAx0TOBEROVVdQx5CUw0NGT5fKyoC5gIwLTYhJQ8PSYNRDgjzCD9MQRw6 RhuENAQACXihMMiAwUFNZLyw0ANKogQQE0mcSFFQIAA7'! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! referencesIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAPcAAAYlOhBrrbXe/87v/+f3/////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAUALAAAAAAQABAAAAhjAAsIHEiw4MAA CBEeTBjgIIGHAQRIDPCQQEOBAQZoDACgY8aNByUKuFgg4sSFCQUUGMmQoAAAAgG8NDhw5kqZ NAXOnInTIEOSPx1CFGrxoMYBQI8CFbn0JMaWTxPmnErVYEAAADs='! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/13/2013 17:15'! protocolPublicIcon ^ icons at: #'protocolPublicIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self protocolPublicIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallJumpIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAAOASByKVCmPWi2UXkGZZ0qgbj+XYF+oej+YX0qbZVancGywgmywg2mr f3CxhV+qdGKqcHGxdnGxdYS/hIK9goS+hIK1f4i5gYi4gYm4gZjGkJe9iKvPmavPmLTSnf// /yH5BAEAAB8ALAAAAAAQABAAAAU/4CeOZGmeaKqupAMMzlo8nvYUKaNwfKcsKAClQpxQAKgA JBKRRCAB1AFxwWQuhkOKkNhYEoRVAyBosM7otDoEADs='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! recoverLostChanges2IconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAImEhUhvwFJmj0xfhVVqlFhtmFVqk1twmkxhiE9ki1Jnj11znUhllnV/ j0tvonGq5ZLC76PL8arZ+n654On4//H6/tHy/8fp8/z4nPz4nfntWfz1m/blZPblZ/blafbl avblbffiavfia/TaT5OOc+3HL/vYTfLNTum9KvHDL/HDMMWaGfjBI8SXHO6+LsGSIKaUbL6E Fb6NJrqIK7mHK9+PD7aDMbaCMbN9NrJ+NrF9Ov///wAAAAAAAAAAAAAAACH5BAEAADsALAAA AAAQABAAAAZ+wJ1wSCwajavk6rhjCFemjSe1FAYCDoZ213KNULXYMDB07l4iDCf1GjqMMlGm k5IJteYhLf1JzcpGNyEYICo2TEI4JxolLDk7AwgJCgYFBwtCOpo6Vg8TEBESF5hHkQkCBJak RjAWrq8wTCQWFLW1JEwAFhW8vABMDcHCwUdBADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:26'! windowIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAGh2km95jm56jS1XjzBakTRdkzdgljxkmUBnnEBonERrn0Vsn0hvoklv oktxpUxypE50p091plF2qCtWjS1YjjBbkTlnnTdhlnh/iDlonj9wpXd/iD5wpUR2qkyBtU2B tVqTxVqUxWCbzWGbzY++5K3O6bnV7MHZ7k6c1Veg12Kn2m6t3XCu3YC24J/H59Xy//L7/+v5 /+76//H7/+n5/+36//T8/+Hp7Ov6//v+//X9//j+//v//4GGgYKFgI2NeY6MeZiTcqCZbKec aKCYbdnZ2f///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAEYALAAAAAAQABAAAAeXgEaCg4SFhoeGExMDFQUX BwgLDA8QEoMdKCgpKiwtJC4lJieWgooUBAUGBwkKDQ4RpEZDL7S1ti9Dg7MrvCs0vb65gkIv I0VFIjErxys4RINBLx7HHzIgNzchNUGDPy8Z2BYwHBrlM0CDPS8TNDQTOjo28To+gxvrihM7 +foYgwIvcuTgMZAHwYEBBgFYyLAhQ0QQIxoKBAA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallFontsIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAKIAADdSlm2LsqK1zitXj4egwEF0qMDR4v///yH5BAEAAAcALAAAAAAQABAA AAM1eLrc/jBKI5kZVV2cC+HHNhRWIXBGYVyUNrxcgRUAM1BfeB9DsOw8EgtGks1eFBkrw2w6 KwkAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! objectsIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAMsuOdleZt5vd+SCiT1spgpEhBlSkCdemhBLiB5XkZq41GOph3i3mCSA TzCJWwpsNxRwPFibXVibXGqranCkZ6uEGqeBGqeAGp50Fpx0FphtFJNoFJhtFf7SfZNnE/6/ U////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACAALAAA AAAQABAAAAZ1QJBwSCwKAcjkkOFwMIaAgXQAEDIaFErjCQIIvoIqqDEpSxrHgDogfkTekccR HBYuHtnH4phEDhcQekaDhIWDCgpGFRVGBgZFFx0dFkQKCAiJQhkfnB8YQwgHBwhDm52fIAoJ BAQJmSAckhpDBbW2RB4bhoVBADs='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! protocolExtension3IconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAACXBIWXMAAAsTAAALEwEAmpwY AAABDklEQVQ4jWP8//8/AyWAiSLdNDegyF6eoP8Y0cPgYKXhf2Y2bgYGBgaG81efMRhqS8Hl bBqPMBJ0ATMbN4N5RT2DqkckAxMrB5xNtBf+/PnH8O7CLYZXT98w3H32Fc7+8+cfYS8U2cv/ VxRlZmBi5WC4++wrw/+/vxgYmdkYlKW4Gf79/sFw//Vfhr6DD1G98f//fxS8Jdfk/69vu/6/ ODblf6GdHJy9JdfkP7ra////Y3rh568/cGcrS3HD2T9//WG4PydKHF09C7rA719/GQ7MnsnA wMDA8O/3DzibgYHhlyJ/4BuMQMDmLBgutJP7////f4brCwOF////z/j//34WdDUY6YBUMMjz AjEAAFJot416CC4JAAAAAElFTkSuQmCC'! ! !EclipseUIThemeIcons methodsFor: 'private - notused' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallObjectCatalogIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAMsuOdleZt5vd+SCiT1spgpEhBlSkCdemhBLiB5XkZq41GOph3i3mCSA TzCJWwpsNxRwPFibXVibXGqranCkZ6uEGqeBGqeAGp50Fpx0FphtFJNoFJhtFf7SfZNnE/6/ U////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACAALAAA AAAQABAAAAZ1QJBwSCwKAcjkkOFwMIaAgXQAEDIaFErjCQIIvoIqqDEpSxrHgDogfkTekccR HBYuHtnH4phEDhcQekaDhIWDCgpGFRVGBgZFFx0dFkQKCAiJQhkfnB8YQwgHBwhDm52fIAoJ BAQJmSAckhpDBbW2RB4bhoVBADs='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! overlayDirtyIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIBAMAAAA2IaO4AAAAMFBMVEX6+s4dFAchFwopHQ0i FwoqHQ00JBE+LBYzJBJJNBo/LBZROR1JMxpUODD///8AAACF0F/3AAAAD3RSTlP///////// /////////wDU3JihAAAAAWJLR0QPGLoA2QAAAAlwSFlzAAAASAAAAEgARslrPgAAADBJREFU CNdjeAcEDK93797N8OYu702GV7y87AwvLjBcY3jMy8vK8Ogu7xWGh4KCggCnUxHTmTvaYgAA AABJRU5ErkJggg=='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! testNotRunIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAyElEQVQ4je1ROw6DMBRzSh9i jbLwEUs4BAMSI4dmhgTOErGQgc9AOrUqUNQDtJYsPdmWZekBf7Aro+971zQNsixDFEXI8/xj 9qNY17ULggBxHGNZFgzDgHmeUVXVKX87ClprR0QIwxDbtuF5ExG01u5rgVIKnHNM07Qj5xxK qdPa+1EQQsBaC9/3d/q6rhBCnApOC6SUsNaCiHYcxxFSyu8FZVkyADDGwPM8OOdgjAFj7OW9 4/KNbdu6ruuQpimSJEFRFJfZX8cDTFpNEGq15bYAAAAASUVORK5CYII='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! testRedIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAA7ElEQVQ4je2RMU7DQBBF3+5G srSW1mA5Tp3KVEnhK8AF0iQVXAOfAM5CSwOCPmnTAXVSRCSWXGAJYjEUpCAsFhfIl6b58+fP Hw0c0Ioyz6WwVm4jJ2WeS5tO/UU+xbF0Q0twfsHnasX2/o7Xt5qTsvT02ts8HEisFcFkAh/v 6OMjgvGYWCvK4cBL4jkW1srl2SkY80OloGm4fnjkqq73Zjq/DfpG08znqCTZ42W9pm+8wP4J IxfxUlXotIfupt+V9niuKkYu+t8gWS6VARazKSoModmymE3p7HqeQxs2WSaFtXLjnGyyrPWN B8AX1+RFw2bQv8AAAAAASUVORK5CYII='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! testGreenIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAAOASByKVCmPWi2UXkGZZ0qgbj+XYF+oej+YX0qbZVancGywgmywg2mr f3CxhV+qdGKqcHGxdnGxdYS/hIK9goS+hIK1f4i5gYi4gYm4gZjGkJe9iKvPmavPmLTSnf// /yH5BAEAAB8ALAAAAAAQABAAAAU/4CeOZGmeaKqupAMMzlo8nvYUKaNwfKcsKAClQpxQAKgA JBKRRCAB1AFxwWQuhkOKkNhYEoRVAyBosM7otDoEADs='! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/14/2013 16:27'! testRedIcon ^ icons at: #'testRedIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self testRedIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'accessing - icons' stamp: 'EstebanLorenzano 5/14/2013 14:49'! referencesIcon ^ icons at: #'referencesIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self referencesIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! protocolPrivate2IconContents "Private - Method generated" ^ 'R0lGODlhEAAQAKIAANhCT+N3gOeIkP///////wAAAAAAAAAAACH5BAEAAAQALAAAAAAQABAA AAMcSLrc/jDKSesEGN8wArhD+EkAJ4xRplls675MAgA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallLockIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAPz8/v39/mh2kqSwyPj6/l54qGN8qGqAqGqAp36TuZipx6260rrH3+Hp +OHp92J8qHKGp3uMp3yMp6Sxx97o+ODp+N/o9+fu+vT3/EtuonKHp3uNp3yNp/L2/Pj6/YST p2x2g4STpouXpuTt+Obu+Orx+vH2/PD1+/P3/PL2+4uYpujw+e3z+pCbpvX5/ff6/fb5/Pn7 /XqBhc/t++H0/fv9/f3+/sPEu7m3qKCYbJuVcKyoj6ecaKSaapWQdf3zy/Tmtv3vvf3wwv3y x/3yyf3zzraSJPXaiPzhj/zkmvzmnvzmn/zmoOXgz7GLIbSPI8GeOKaJOMekRbiZRNi9bfDX jtnEh+XRldzPrHhbE6d+HK6GH6uDH8WwfdLAlNHBm8Kqc8m2idbLstnQvPPt4f///////wAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAGYALAAAAAAQABAAAAfPgGaCg4SFgzyIiYqKgj0z j5CPPJA8gjkzI5maIz4zGQw+gjozJKWmJDIzHSkygjszK7GyKwK1tYI4NCa7JiW+IAMTEyCC N2FQUF8YGCwsLQ4NFS2CYFJkZFJeLi4nKhYWFCJmYkZYZWVjRk0vKCEzFxcfZl1aYV1dYVpd MTAbERIcIph5gqSIFSA/ljypEUMDJAhmnAwREmVKECZOAgA44IkBAjNbiFzJkuWKki02bDyY 4YGAATNcqiShQiXJES4LFCQowLPAPC1Ag3YxZCYQADs='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! protocolPrivateIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAOdgYcgpMMgwNMgpMcgdLPJNXPFNXPV2gMgZKueTi8lDPMlHPsk+OvaS judgYPV8fO2Dg////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA ACH5BAEAABEALAAAAAAQABAAAAU0YCSOZGmeaKqu7Lm88JIqTV0rKdM8fMOkgoOhYDgIUgOI AwCABFKEhFRKSCGuWERry+2qQgA7'! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! traitIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAACXBIWXMAAAsTAAALEwEAmpwY AAACI0lEQVQ4ja2TS0uUURjHf+e9zatzaS6m42VCiFJBElG7I1hQixZ9g2jVImjTF+gjFARt 2kS0j2hTFmlRiZUWZKljg2maw2jNODPOxfdyWoQ6by2C6r98OP/fec55/o+QUlKribFl+frZ InMzq7iuRAjY39XIwOAe+o60Cn6RqAXcvjEh344vEQyZRBvqt+vf10oU8hV6D7Vx7mKfB6LV mp+PpOjqjtPUHKIuoG8famoJkUnneTGaApC1EA0gNfNNjg7P0dkb58Llw/iDhqdN23aZmvzK 3MwKo8NJjp1ol3s7YwJAAXh0L0lbIoxlu0y/X+HDuxXKG5tYlkMmXeDLfBbdVEFKfKbg8f2k 9wmfZlcpVSyM9TI3r72k3q9z5eoZNEPj7p1JPqdyBHeZlEoWqqaQ/JjxArLZEpvVKkIIbMeh kK9g+jQURRCJBZh8tczSQg4hBNWKjWPv/KMCEInUoxkGCBBCIITArNNRVUE4FsB2JFvTUlRB NOr3AroOxNE1BV3X0HQFRRVYlgNAecPGth10Q0XVBabpo2eg1Qs4dbaDXLZMMFRHvDlM78EE 0v15o2VvousqkQY/PsPHeq7C0aH234N06/ob+eTBLK1tYaKNOyEqFioszq9hmDpWVTJ4ch/n L/V7cwBsFeXIw1kc1wV2EtqwO0wmnWfodIfH7OlgSxNjy3L86QLTU2mKxSqBgI/unhb6jyf+ vAt/I+Wf3P8D8AOoI9lGL3q6bwAAAABJRU5ErkJggg=='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! bundle_exporterIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAAAAAP///z8/X6CgpACAAD+/Pz+fPz9fP8DcwL+/f9/fv//ff/+/P9+f P79/P39fP18/P////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA ACH5BAEAAAEALAAAAAAQABAAAAVoYCCOZGmK0FkqziM8jqImT8NAS/MkpvIsDB1jCJGRHLbg Y9hwOErLRjPqTI0gAshj+0IgIACr6Ddk/AgEA6KEZC4JhUJ6LfIFhfC43DBKQKoNeXEEByQs YBB5hAMqKWgHjCojA5GSliEAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallForwardIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAP797/375v332f765vzyyv732f732v322f322vzpqPztuf3yyf3yyv72 2fvgjPzkmfvkmfzoqPzoqf3tufvdg/zgjPzjmb2EFq51Erd9FLd+FLV7FLV8FLyCFrmAFbuC FqtwEatxEaluEa90Eq1yEqdsEKZrEP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACcALAAA AAAQABAAAAZkwJNwSCwaj0ji5ZIsdgCd5vADAHyMnqzWMwgMPERNo1FAHAyCggAhyAw3DMaC EF/I7QyOEDPpK/4TCoGCI0IkEogRihESCYwkRCGSISCUDxAWIVIiFQ4iUiclFCWgJyYmpalS QQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallNewIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAPP1+/j5/GN6p+7y+vL1+/n6/Pj5+152o2Z+qGqCrG2ErXGIsXOJsnyS uH6Tuoygw4GXvISav4mewZGlx97o+N3n99/o9+Ts+efu+e3y+vP2+9zn99/p+N7o9+Hq+OLr +Orw+ebu+fD1+/L2++jw+fX4+/f5+9DSy5iYkZmYipSTh/7978jGtJKQgJeVhZORg93axqSf g6GdhamigZ+agZuXhKOcfv30z52ZiMazbsOwb7ysdbiqd7Oneq2ieK6kfaiffNTInv3zz7WR I7WSI7qXJrmVKMOsZMCuc/zno555FqaBGqaCGqWCGq6KH7iUKPvdg5l0E6B7Gf///wAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAFMALAAAAAAQABAAAAedgFOCg4SFhodFhkeLjEEw RitPhTkFlZUfQ0QrRESEOiYBBqBONzdCQjdOg0glExAKByRNTUlMS4Q7BBojGgAaJUpQUoU8 IhMPEQ0MCSVRJ4U9GRkD0tUlLIU/IMfJywIgPoUzIRjl5uRAhTEX3MoJAhc2hTIe9fb2NIU4 HBMSDgsILHSgUKNQig0bKiRMqNBFIRQQIapoQfGFCkGBAAA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallSaveAsIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAPj4/IOt8F17q157q117ql57qlVvmkBTc2F9qmJ9qcnb+rvL5OTp8WWB qWSAqMjc+snc+cDP5sHQ5sbU6MfU6M3Z6mWBqGuEp7LD27vM5MDQ5s7a6tXf7dXf7GqFp3CI pc3a6t3l78/T2Oru82+IpbnF0+Tq8XWMpHWMo/D1+u/y9Vh1kXqQo3uQot7r9u/1+t/s9vD1 +X+Tod7s9t/s9YOWoPD2+fP19oSXn+/2+YiZn4iZnrfDxnGDhoqbnrG9v6Wzrv79+uTPnf// /wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAEMALAAAAAAQABAAAAekgEOCg4SFgiI+Pj0/jD89 iSKEPjc8QZaXPDc+hDoqPi8xKTY5KT4qO4Q4Iz4wLjAwMzQ+IzWEMgw+Qrq7PiYyhC0hGInE PhghLIQnHRwdzhzN0CiEJBsgIA7ZDhUbFR+EFxQTDgDlQg4TFB6EFhEaDg8QCkAOERINhAgZ Cw66K+cZMiQgVKIAgQICBhRYKGChoYcQDRkIMGRiRYoPDxgYopGjgUAAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallQuitIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAG2LuVx8qf797/342v332vvpoPzwvPzwvfvjkPvkkPvjkfvkkfzooPzp oPzoofvooPvoofzvvPvehfvfhvvgifvhifvdg72EFrF4E7qBFbZ8FbZ9FbqBFqluEKhuEKhu Ea1yErJ3E6ZrEP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACMALAAA AAAQABAAAAZgwJFwSCwaj8UAAGlUFi+Xo3N4EUSbS+GFMIB6r1OOYWyIHMiZkVPzYDgahUcD Qt+olyEFArFYJP57GHdCIBQVh4aGFSCDQh0SEx8eHR+VQlNCIhYiUllDIpxYTKOkpUNBADs='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! smallSystemBrowserIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAKIAAFx6qmB+rWaDsZGlx2yKt3KQunaUvv///yH5BAEAAAcALAAAAAAQABAA AAMqeLrc/jA6QOUCAxzDCxFBQ2mWQpYHOUojpn2haFbRWao01GYHXOeoICQBADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! smallCenteredIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAIAAAENKh////yH5BAEAAAEALAAAAAAQABAAAAIXjI+py+1/gJwAPoqldblu 1lEfmI3mGRQAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallErrorIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAPJ0dulqbuttcfm4uvm6vPvO0N9PV95PV+5YYuJUW+FUXO9fZvvJzM4o N84pON1ATdZMWOtVYPFea+OGjc4lNc4uPs4wQO/Jz+artc9uXNeKfduWislHPs9aUuRmYfN8 fOt8fOPExOvU1P///////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACQALAAA AAAQABAAAAZqQJJwSCwaj0iSaJPpZDQiZIjjAVk9nJBRxAF8vl8AJ0qcGADoNOAwKUIChIJc ThBAihXJaM8fSSpuEQMMhIQDEXdlDwiMjQgPbUQXFAgLlpYIDhdGGA0JAaAKDhhIFxMQFhAT m0mtrq9JQQA7'! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! monticelloPackageIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAPPz9f//eurqw+npy/z4pP36v/780vnqefvwofz1vefhtP7hNPLYSPnh Tsu0Q/nspvz0zPrdWvznjP3ur8+rI9KkD86jFsKhPsGeQMOTIL+dQ76bRfru0cKRIr6PI+S0 Q++/WbuYSLiWS+rMjOfPmuHNnriwn8SHDMKEDL6LJriJKfC1PuCvSLeTTuaXDb6BDr+BD/ao HbaFK9qpTrSQUfnhtuCPELx8Ebt8Ebh4E7h5E7OBLrB/MfC6XrOOU7ioje/hyfuaCbR1FbN1 FbBxF9SiVdeFFK1tGqxtGtCOMq16Ncx7GalpHax4Nubh26ZmH////wAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAFAALAAAAAAQABAAAAepgFBQDheFFw6CiYqEEwYJ D4eKihgjHywzRSslFBmdGRSCGiNAAAMKJBYZEgUIEJ9QG6MAFSe1JxU9PUkxHVAhI060EQQH DLcCDTEeUCLAKCAuNkZLLifIMSlQLcAwIDUcAQtBL9cqUDTAON7g4jfXMoM+Tjnr4UE61zuC DiZC9eJDrvFQRORfECLIlIBKdMQgkh9NFiaqwORbOCYVJCmq8KTjk4waQ4YMBAA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! scriptManagerIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAEpZfHaEnHmGmomPj4mQj0pUM0pTKtXet9XdsdzjtdzjttXcp9zhqtzh rNzhrebqvtfbk9fblNjcltjcmObpvufpttzdidzei9zejefotdXTUdXUWvDww5eXhubjd+He fuHff+HfgeHfg/DvvfDvvs3ITc3ITs3IT83IU+zlaOzlaufidebgdPj1w/DlX/DmYPDmYuzj bOzjbaKffvjqXvjqZaKaUYp7NYp9PYp9P5GFTrKoda6ld6ujeYp7OIp/Uf///wAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAEAALAAAAAAQABAAAAdwgECCg4I7O4SIhDscDzyJ iDstFAqOj4UtJAkOlY+RIxUNP5ZAOzk4GQw3EwKWOgcIPjcSGCKsjz0LNhEXIR4ytokzEBYg KzEwwIkdHywqLycBo0AEKS4mANIDBSgl2KMENTQG3qMAGxoD0oMA6erugQA7'! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! userIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOZsAN7p7OTq7K7G4cvb6ICcxff5+vL193CVze7y89bk6+Hp6+zx89bk6mmK ydDc5Vd2rKKyzHuTwd3l6Yum1EJmqEFqtW6Tzoibv73R5Y2iw4yhxOXr7/j6+lZwobjJ3eXq 77jI4Dpjr+Lo8sPR4aq+2MfY516HxoWbv9/m8ZSs0J+63pCv21V6wNrj7H6Wu9Pg6b3M2/// /9Pd6r/M3+ft8XyQttDa42qPy9fg556109Hb5KC63dnf6W+IuC1WqWKJydri55iszZ+63T5m sr3R5PP2+L/L4NXj6p611FVyqURin1FvpomewXeNtd3l6MzZ5HmZ0H2h1fL1+Kq+2X6d0sva 6Pb4+ZiqycbX5tzk6LjF2rzQ5dje55SnxjZfrVx/wWaMyYGYvU1rpOju8WmEt+3x9lJ/w3WP t9rj6Iam2Orv9ZGw2v///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAGwALAAAAAAQABAAAAe4gGyCEDUXgoeIhxABQBmG iYlXWToZTYdBPRGJXTYwWlxsMUYKOASaiBozPBNfDSI0TwRkqAgcEwAvBw1SMgQdh0wBtVRH JQcsKCAPhycBwlZQWAIHFAULCstsYc5OGwYWURXWCmgOvy4BEh/fAO3iYw4jHklnEt437QAM AxRFLR5TlhwCky/BgC0ChpQhkUPMoR/t9hERoCKEGiQplBwyASBBFQwChKzxAomNGYMgd6xI 46Oky0SBAAA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:26'! transcriptIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAPP1+/f4+zpOgUFWiENYi0pgklBmmFZtnmB3qF11pmZ/r1Rkg1dnhvb4 /FtriV9vjGR0kOHp+OHp91priGl6lWl5lG5+mHODnOXs+Onv+e3y+m5/mHeHn3eHnuHq+OHq 9+Ts+Pb4+ytcnCtalytYkytXkEZzrVp/r3KDm3aHn3eIn3aHnuDq9+Xt+O7z+vP2+ilvxClu wilsvilruipquilotSpotSlmsCpmsSpjrCpkqyphpithpipfoStfoStcmypalypblytblypY kypZkypXkCtYkCtXj3aIn/L2++3z+vb5/Pb5+8/t+////wAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAE4ALAAAAAAQABAAAAejgE6Cg4SFgycwiYqLMCeD MQuRkpMLMYMyDE2am5sMMoMzE01MIQEhSw0hDQ40gzYPTQoJBgQCL0kADzWDNxBNLi5KwMAa EDiDORSxCggHBQMCGRU6gzsbTRggIBjZGC0WPIM9KE0sER8eERIRHhc+gz8pKR0pHCopK0jy IoMmQkJB/gUBImQEQBOGnJggMYQIwoQmjByReKREkRIlHibcyHFjIAA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! lockIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAPz8/v39/mh2kqSwyPj6/l54qGN8qGqAqGqAp36TuZipx6260rrH3+Hp +OHp92J8qHKGp3uMp3yMp6Sxx97o+ODp+N/o9+fu+vT3/EtuonKHp3uNp3yNp/L2/Pj6/YST p2x2g4STpouXpuTt+Obu+Orx+vH2/PD1+/P3/PL2+4uYpujw+e3z+pCbpvX5/ff6/fb5/Pn7 /XqBhc/t++H0/fv9/f3+/sPEu7m3qKCYbJuVcKyoj6ecaKSaapWQdf3zy/Tmtv3vvf3wwv3y x/3yyf3zzraSJPXaiPzhj/zkmvzmnvzmn/zmoOXgz7GLIbSPI8GeOKaJOMekRbiZRNi9bfDX jtnEh+XRldzPrHhbE6d+HK6GH6uDH8WwfdLAlNHBm8Kqc8m2idbLstnQvPPt4f///////wAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAGYALAAAAAAQABAAAAfPgGaCg4SFgzyIiYqKgj0z j5CPPJA8gjkzI5maIz4zGQw+gjozJKWmJDIzHSkygjszK7GyKwK1tYI4NCa7JiW+IAMTEyCC N2FQUF8YGCwsLQ4NFS2CYFJkZFJeLi4nKhYWFCJmYkZYZWVjRk0vKCEzFxcfZl1aYV1dYVpd MTAbERIcIph5gqSIFSA/ljypEUMDJAhmnAwREmVKECZOAgA44IkBAjNbiFzJkuWKki02bDyY 4YGAATNcqiShQiXJES4LFCQowLPAPC1Ag3YxZCYQADs='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! smallProfileIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAABhHhRlEgBpFgR1JhCNVmCZYmiBKgiNNhDlnpD9spxZFgCRXmCJSjyNU kCdamiRSijxqpTBdkRZUkRdSjxdSjhhQi3KgzHSjzXOizHelznyo0QJWlwNXlwVXl3SfuXii u87k8H+pv9bs99fs993x+9vv+d7x+9Xs99ru997x+o62xoy1xarM2LLR3eb4/5C5x67O2Mrh 59Tp7tDm6tLn6+v8/+z8/9js78jf4tDl583i4uHx8fD///H//8Xc29zt7PH9/P///wAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAEEALAAAAAAQABAAAAd0gEGCg4SFhoeIgi8NAg0v iT4EFjtAPxgEPocLOj08njwwHYYhGTWmBqY2ECGFDTkusAOwLjcUhQEzJboHuiUoCoUMOCDE D8QgMRWFHhcnIs8RIiMJH4YOLSTZJCYsHIc+BRoyKTQIG5mIKxIAEyqJ7/Dx8IEAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! publishIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAL/F3UhgoExin1Fmm1hqmF5ulGV9sGRykXGEqmh1j292hHV8inmRu3WH qH6VuYSYtam/4LDI5bHI5YSQn2V9lLnS6c7g8LjT6bnT6VyFpU6PvVSLs8Hd7sDd7cHd7dTn 8sbk8Nfs9U1aXfrpnvrvwPbflv/xwv/11P301//rs//xyuzRi//lpP/tv//aif/flv/Rdf/V fePBfdmycffjy/vs4MnAwP///////wAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADgALAAA AAAQABAAAAaIQJwQN1kYh0jk5Faj0RZJoXEyIpVWsplxYeviBhAUykQuk08agDCRarvfqs3w wKrb7y25sPB6Ff6ABQ0PGw8NOAQuigQgjY4hGyEIXzExAx4dHZgcHh8bDkICMAIXpRcYFakW ejgBARGwsRKwDBlIrri5BjgUUb5CCr9JCsTEwkMiCiLHSMs4QQA7'! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/10/2013 16:20'! uncommentedClassIcon ^ icons at: #'uncommentedClassIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self uncommentedClassIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! testYellowIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAA7klEQVQ4je2RMUtCURTHf+/e q2AUD7SHYE4K4uDu0ODcd7At/BxOzm75QYqmxoRAdGgIiXg4PBqKGkSre8HTEIR6e/UF/MNZ fud/DufPgZ1S5SY16Xa0XJ8bcZOapPmC32BylZEov4cqnoF9YvV2yfPrkqMT5/nVNrDjihRC UNEprD7B5FFRm0L43ft3QW8wQ4ct5ONhrR7RYYveYOZda7ZBtQyyGBNkDje4uBeqZT+ul8ne Hsg0fqfeOAbkx3Z/d0O9kiPbnG/MeBGyzXmgFSTxEPQ+iCOJhxiNN/yn7Kgk3Y6Wi74ROyql vnEn+AKLwVPWIMle+gAAAABJRU5ErkJggg=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:26'! versionControlIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAIOKlPr8/2iOvGyRvm+Tv1J/sFaCs1aDs1qFtVuFtV+It1+Jt2OMuWSM uWiPvGuSvW+Uv019r018rlGAsdPl9Mzi86vS7bfY78Pe8fr9/4TA5pDG6J7M6vn9/9Xz/+n5 //D7//794v794/z4o/z4pPv1pP360P771cK0Osi5VvnqdPnqd/nqefnqe/nqf/z1x/PXP/LY R/LYSPLYSvfjYpmWg5mWhPPWPPLYTPrgYX91QsOnK8aqNfrdWoV4QKGafcCcHcOiJMOjJ8up L+/LQI58Pqugdea2GfrJLpiCO+WxGfG6JvG6J/rGK6yMNaOHOOO0PbKPNPfkuuvfxLd/C8KO JcGNJuOGCbF9OujYxOV5B////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAFsALAAAAAAQABAAAAejgFuCg4SFhoMpQTtCQCmH gihNOSMsMksojzxIPSSVS1SPU1IvJTdHV1aCERMGCAoMAgMQIioxTKlbGhscFhcYFRQEIiuW VYISBQcJCw0ODwQhLTNLxltRHh5G2NhRIS441IJOHh9GH+cfTiYwSlpYgk81NgA/9T9PJzRE WEOCSR4gAIAYCCJJFixYoAwq4iEAgA4QMxQ55EOHxYs6fDzayLFjIAA7'! ! !EclipseUIThemeIcons methodsFor: '*Komitter-UI' stamp: 'EstebanLorenzano 12/13/2013 14:44'! historyIconContents ^ #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4286673726 4286673726 4286673726 4286673726 4286673726 0 0 0 4278217148 4278217148 4278217148 4278217148 4286673726 4286673726 0 0 4288516712 4294967295 4294967295 4294967295 4294967295 4286673726 4286673726 4278217148 4286104319 4286104319 4286104319 4278217148 4294967295 4288516712 4284839308 0 4288516712 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4278217148 4286104319 4286104319 4286104319 4278217148 4294967295 4288516712 4284839308 0 4288253803 4294967295 4291942109 4291482074 4294967295 4294967295 4294967295 4278217148 4286104319 4286104319 4286104319 4278217148 4294967295 4288253803 4284839308 0 4287925358 4294967295 4294967295 4294967295 4290759126 4290759126 4294967295 4278217148 4286038527 4286038527 4286039039 4278217148 4294967295 4287925358 4284707465 0 4287465586 4294705151 4291942109 4291482074 4294705151 4294705151 4294705151 4278216120 4285971967 4285971967 4285971967 4278216633 4294705151 4287465586 4284444294 0 4287005814 4294376959 4294376959 4294376959 4290759126 4290759126 4294376959 4278215349 4285840127 4285840127 4285840127 4278215862 4294376959 4287005814 4284115330 0 4286480763 4294114047 4291942109 4291482074 4294114047 4294114047 4294114047 4278214064 4285708287 4285643519 4285708799 4278214319 4294114047 4286480763 4283786365 0 4286086271 4293785343 4293785343 4293785343 4290759126 4290759126 4293785343 4278213034 4285641983 4285641983 4285641983 4278213034 4293785343 4286086271 4283391608 0 4285626499 4293522687 4293522687 4293522687 4293522687 4293522687 4293522687 4278211492 4285444351 4285378815 4285378815 4278212003 4293457151 4285626499 4283062642 0 4285298055 4285298055 4285298055 4285298055 4285298055 4293325311 4293325311 4278210466 4285116671 4285116671 4285181951 4278210465 4285298055 4285298055 4282733421 0 0 4282207077 4282207077 4282207077 4285035401 4285035401 4285035401 4278209949 4284918783 4284786943 4284787455 4278209949 4282141286 4282207077 4282207078 0 0 0 0 0 4282141542 4282009699 4282009699 4278209949 4284721919 4278209949 4284525311 4278209949 0 0 0 0 0 0 0 0 0 0 0 4278209949 4278209949 0 4278209949 4278209949 0 0 0 0 0 0 0 0 0 0 0 0 4278209949 0 0 4278209949 0 0 0)! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/13/2013 16:44'! dirtyMonticelloPackageIcon ^ icons at: #'dirtyMonticelloPackageIcon' ifAbsentPut:[ (self monticelloPackageIcon asFormOfDepth: 32) mergeBottomRightWith: (Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self overlayDirtyIconContents readStream)) ].! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! classIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAGyogTOCTTaDT0CJWEKLWkaPXlSYalqbcFyccX6zkIG1ks3i1CR2Pi58 RjOBSzmGUFicbV2ecWOid6LJri18RC59RS99RjB+RjOBSUuSYEqQXneuh9jp3TKARzaESjuH Tz+JUo69mj6ITz6IUD6HUEaOV0ePWFKWYmuneo++msPdyeLv5VKWYFaaZFaZZF2caqvPs7zY wlSXYVeZZFiZZF6catrq3ebx6FKWXvH38mCgaXyyhHmugYW4jIy8k/D38VmZYWikb2GgZ2Ce Zp7Godzq3Weiam2mcHeueICzgHuxenmud4e4hYGzfeHv4JG+jLPSsLzZub7au5/HmqDHm7vY t8Lcv8bew7DQq////////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAFoALAAAAAAQABAAAAengFqCWgsRGQ8aEQuDjFoK D0FIkkEBCo2OHU1YVldWVEkMloMLD0tSWaioUUoBi4IHQlOoVU9QWU5MQhKDBThEWUVDwkdG RkAFgwEXKVkqFRQUFRgeIg68HxtZKyAkJBMwECbIghIjNTlZMSghWT8vLACDHAwyPDapNz40 DK6CCQ0ldOzosUPHDAEJLiWwcKKFixYnLCS8RMjAAAIDEPSjyLGjx4+NAgEAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallDebugItIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAALittxMTQ9fX5iAic4+QuSIpedPU4Dc/g1FapOPk7lBapFVfp1liqVli qG53s3J6tMzP40RQm0NPl0tXn09boFdip1lkqVllqWBrrmNurmRur2Vwr2Zwr2t1sjJCjTpI kENRl2Rwr255s3WAtX+Ju+bo8iU4hDxNlNjc6YyawIqZv5ypx7nD16O0y6O3y67Dz67Fz7LI 0LbL07jN08rg28ri3Mri29Lm4B+ETsLez8fg0z2WZESaaVameHOzj1erclircVircliqcU2n ZU2mZWGwYIO+gYO9gZPFh/Hx7f///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAEoALAAAAAAQABAAAAeegEqCgg6DhoeDGoMiiIYA CwCCGY0dGhcKHx8AE5GNSgARSTQgEhFKHhKNCDQINTczFAAADRuCIowADDZJojANnYYYExY3 SQY3Misehjg4ORAjMzQ3Dy4qJx4VgjhIOD06KC8xLQckJpEhSjhHR0Y4PAksKSQBBcxAQj8/ QTgCBAMDDuEYQmQIDh8lgAksgmOHDiUKPKlzJoiDxIuIAgEAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! protocolExtensionIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAACXBIWXMAAAsTAAALEwEAmpwY AAABmElEQVQ4jc2TwUtUURTGf2/m3VcwZBFGE640JmFACUShQaFN61aDazduRXdR7lon/gPm skWIiLRsMQsjok1JEMMoUjlPHZ03M83w5s2977Tq8d5YFLjxwLf4uN/57v0O51oiwkUqdaHu fxkszWSlXt2bBuzj8u6jt69eFuD7zbjGikcoPR1P5PlUbjKeG0iYDt5fvpYvFn/+5nb/rZML L+gcnXBS9ch0SozNzaKcNKffahy8WSFfvKX/GkEboXN8ig56EIYAdL0m3XoLJEQbod3O34v3 JF5ggpCa6yHa0Kq3KO+7TB01UI7C7/iYIMTyu1fI/GEGSzNZGblzlczQAwDK+24kyg1nAWj/ eEflwGflvWtFhyISYXN+VLy9Lal+WJfd7VV58vihHH5+LbWvG1Iprcnm/KjE9SKSjBD0DEql 0Y5COQ654SyOncKxNI5KEfRM/8yTBtoInnuGDnoEvg9As9ZA2RZdP0Cb81ub2IOd5xNS+eJF vKEN1+10xO/mb1B49tFKOPRnimNx+va5zP2wLvdn+p/6BQSj81S4jLsYAAAAAElFTkSuQmCC'! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/15/2013 21:09'! modifiedIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QA/wD/AP+gvaeTAAAA CXBIWXMAAAsTAAALEwEAmpwYAAAAB3RJTUUH3QQGEA05RBIJeAAAAlBJREFUOMulk0tPU2EQ ht+vh1OgxXohJFAQLzQR8QZeEiHRQKKRoHHTuBC5/IL2z7B2wSUQF8QFKCaAGHAjC8MGNMRC aaFATJEWOLTnfDPjwliQxpDoLCfzPvNmLkpE8D9RcDQRD4drhLhdg7rEdsoZDBG9QeA+Fhq8 8nIocrheHXawGgoHNVOP73KgwltfD3XKB2QycDYT2JqYwI+t5DoJhRr6Xg/nAVZD4SAR9Z55 0Oz13rgOWloANuOAbUOVnIaqrkZy9C3i0W97TLr7ztDYcA4QC4UuCvFM6f1Gv+d2A2hqBNZ+ BoocFLpNKBaInQHqbuL7u3GsbsYSLPpe06v3Sy4AEOIOj7/UX3ytDjQ9Bsrug7MWTCsN3k6C 0lvgjAVnZhxlLS0ozmT9xNQBAC4AYEWd3qu14C9zx05dL0dQUd8EFt2Z2wIJVRZ4PMDiIrLR JViJbQCAc1TtcsFMOSi6dRc8pytzDsR2wOk0eCcFSmVhnjDzOpMISAxozYAArDRyABJa21+J Qrw+GCcL4ezk9YahFAxFcJ89h9TyMtjRawcA1v3J2VmIP3CsA/N8ALH5KbDo/oMhih7Y9RYl kh+mYLY+BmddUIbxSwgFIgG4AL7WJ1iZfINd20qQkoE/Dunzi6dBFt1bVlLqLWt5CDsagR2J gG1G4aUA3FUXEJ8cQTS5uMeKu9tGF4bzTvnT80dBJt3jJruiqrYR7nI/AMBKxBCZn4ZFmXVW HPotzgMAwMdnzTWinXZtcJcwlYvtQBu8IUx9rPVg29jXvz/Tv8RP+TtdwOVsP3gAAAAASUVO RK5CYII='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! smallOkIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAPcAAAAAAAAAMwAAZgAAmQAAzAAA/zMAADMAMzMAZjMAmTMAzDMA/2YAAGYA M2YAZmYAmWYAzGYA/5kAAJkAM5kAZpkAmZkAzJkA/8wAAMwAM8wAZswAmcwAzMwA//8AAP8A M/8AZv8Amf8AzP8A/wAzAAAzMwAzZgAzmQAzzAAz/zMzADMzMzMzZjMzmTMzzDMz/2YzAGYz M2YzZmYzmWYzzGYz/5kzAJkzM5kzZpkzmZkzzJkz/8wzAMwzM8wzZswzmcwzzMwz//8zAP8z M/8zZv8zmf8zzP8z/wBmAABmMwBmZgBmmQBmzABm/zNmADNmMzNmZjNmmTNmzDNm/2ZmAGZm M2ZmZmZmmWZmzGZm/5lmAJlmM5lmZplmmZlmzJlm/8xmAMxmM8xmZsxmmcxmzMxm//9mAP9m M/9mZv9mmf9mzP9m/wCZAACZMwCZZgCZmQCZzACZ/zOZADOZMzOZZjOZmTOZzDOZ/2aZAGaZ M2aZZmaZmWaZzGaZ/5mZAJmZM5mZZpmZmZmZzJmZ/8yZAMyZM8yZZsyZmcyZzMyZ//+ZAP+Z M/+ZZv+Zmf+ZzP+Z/wDMAADMMwDMZgDMmQDMzADM/zPMADPMMzPMZjPMmTPMzDPM/2bMAGbM M2bMZmbMmWbMzGbM/5nMAJnMM5nMZpnMmZnMzJnM/8zMAMzMM8zMZszMmczMzMzM///MAP/M M//MZv/Mmf/MzP/M/wD/AAD/MwD/ZgD/mQD/zAD//zP/ADP/MzP/ZjP/mTP/zDP//2b/AGb/ M2b/Zmb/mWb/zGb//5n/AJn/M5n/Zpn/mZn/zJn//8z/AMz/M8z/Zsz/mcz/zMz/////AP// M///Zv//mf//zP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAANcALAAAAAAQABAAQAg0AK8JHEiw4MBL CAUiTGiwocKFBhk6nEix4MJLES9irMixo0eJEy9aJCjSokaQGVF6XGkwIAA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallRemoteOpenIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAPcAAAAAADRhqzpnsENwuE56v1R6tleCx12Iy36cyo9SGZ5fHZ5mJ6VsJK1s JK1yK61yL612NrR/Mrx/MqyFH7CKIbyFMrqXJsOFNsOLNvjQeJmv1K/B3OjQiPjQgPjYiPvf ifjYkPXfoPjgmPjomPjgoPzqr/josMDN5PXqxvjwyPP08P///wAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAP8ALAAAAAAQABAAAAiLAP8JHEiwoMGD CBMq/HdAIYaHGA4gOGDhYIMVGCVqMFDCQsWBF0aMKFDghEkCKlJSoCCwQooUAQJsmDkAhc2V AiWY2GkiAAINAj5MmEAwQggSSCE8WMqU6T8HIKI+EEG1KlUOD/4x8ODhAdevX7EKVJDhQYez aM+KFZjgQYa3cN+uHbigrt27CxMGBAA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:21'! homeIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAACM+gCdBhNre6BM0fC5NjxI0fCE/fV17r9ne505upU9uo1Z1qld3qlh3 qlt6rlt6rVt6rF59sF58r2KCtWOCtdje5yJHeSBHednh69fe59be5+30/PL4/+bx++f0/+Xx +8zX4Ov2//H5//j8/+Dw+yRTciVUct/y/uT0/ef2//X6/eL1/+v3/eb3/+b4//T8/y1kbClh Zv7//zt/ZDZ6XTyFYD2GXzmEW2JmYWdtZWzBOmhtZW9za7reHWVmX+3rAvPzBWhoXJOTg66r cpOPW66qc//7zpOSg396TWhmW//1v5SRgZSQgP/yv//qqv/srXJtXJiTgm5pWp2Te5mRfv/e lv/fmJ6VgP/Pc6KVfP/PdP/Ug6WVeaSVeqGTeaaWe54/NaBCN59FOv///////wAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAGQALAAAAAAQABAAAAewgGSCg4SFhWJFgl+GhUNg ZF1GXIyDYURZSlBNXpRkSFdPUhhSTlOUUVZBFWMVSVVUhktbPgJjtgI+W0yER1g4CGM3NTdj CDhaQoM8Oxm2Nj82tho5PIQFIDJjNDM0YzIgA4UEYyojtmMjKmMEhQovGyIxMDEcGy8JhRMs HyEmQCUhOrCgUCgCChIeLPS4kIIECgmFIKw40cKADgMuTqxwUOgBgwUHAAQAcGBBAwiCAgEA Ow=='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! protocolExtension2IconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQBAMAAADt3eJSAAAAMFBMVEVBd69ThroQXJwZY6Am a6cscKhIg7Owyd////////8AAAAAAAAAAAAAAAAAAAAAAAAAHByLAAAACnRSTlP///////// //8AsswszwAAAAFiS0dEDxi6ANkAAAAJcEhZcwAAAEgAAABIAEbJaz4AAAAtSURBVAjXY5gJ BQzEMjyhjGliUEZpayWEYdFhCWZMD2gIBzMmKSkpkWAyCAAAf19Ib5Xf/x4AAAAASUVORK5C YII='! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/10/2013 14:38'! emptyPackageIcon ^ icons at: #'emptyPackageIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self emptyPackageIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/13/2013 17:14'! protocolExtensionIcon ^ icons at: #'protocolExtensionIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self protocolExtensionIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallDoItIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAACCAQSaAQSaIQUGRV16abzqITzOISGatdy2IQUiRV0iaVzqRSEGRT2at bzqIQTN3OkGISEiRT0+aV1ekXi2AMzOIOkGaSEiaTzqIOkGRQVekV0iASGakZnetd63LrbrS utXg1V6aV4i3gG+kXoCtb4i3d5rBiIi3b5G3d5G3b6TBiIDMJsLpeP///////wAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAC4ALAAA AAAQABAAAAaYQJdwSCwWQYdCIFA4gIyug2G1MqlEnGbxkCitWqtUCoVKHIYgA+n0aYFP8JPh GZWMRm336n4/uwwhgXl6gR0GQgYbih5ujSwbHQFCAA+VjI0flQQAQgEUn5ctHp8QE5JRDBER lx6qFxIDfiAIEhmMHg4OGRcTCHRRCxMeHhUYFhoTC35DBwgKEw0NEwoIy0RIAksCTlDdRUEA Ow=='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 10/4/2013 15:57'! groupIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAALC91117rl99sF99r2OBs2OBsmeFtmeFtWuJuW+NvW+NvHORwGuKunOR v3WTwbzF0uPr8t7o8N7o79fk7M/f6Mba487f573V37fR277V3rfR2p27tWmdi2eaiWygjmyg jWmciqnNwG+kkHKpk3Opk3aulnmymXy1nHy2nHmymH64nbXMlb3Rl8bWmMfWmdDcm9nhneHm nuDlnubpoLeTJLmWJbuYJtC7eq6HH7GLIbSPIreSJPzejfzejvzhmf3mqPzmqP3qt/zqt/7v xv3uxf7y0v7z0v712qmBHKmAHauDHquEHq6HIP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAE0ALAAAAAAQABAAAAeZgE2Cg4SFhoeIiYQhKioh TTc2NjdNDw4OD4InMzMoTTZHRzZNDhAQDoImMTIpTTVGRTVNCxESDYIlMDAlTTtEQzRNChMT CYIjLy8kTTpCQTpNDBYUCIIiLS4iTTlAPzlNBhUVB4IfLCweTTg+PkxNBBcZBYIgKyscTUs9 PEpNAxgaBAja0KHDBkhIklACECAAAEUQI0qcWCgQADs='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/14/2013 14:52'! migrate16IconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAAK/INwWK6QAAABl0 RVh0U29mdHdhcmUAQWRvYmUgSW1hZ2VSZWFkeXHJZTwAAAJBSURBVHjaxFNLTBNRFD1v5s2n ndLOYEdIC0U0IbYYwWATY0JC7ML4C0tBN7hw5dKNC/duWLjR+FkoidGFIXHBQle4MGKQiKL1 ExsjCgH6s9YZpu18nkUjATVx0YUnuS95ue+de/LOeYQxhkbAoUHQ1M2hf08hLud57FHFsW/J gu/yXxVogjPaLPPPNZnO+jj7wsZDHuM9kYo9AUm5VLLKXX8QhERuuUWLnh3YubcnFU/2duix c4rALWzWwd6fSqagB7R01iitk3BhCY/370i0nD88gmR7Gzo1EUN9fTjSnYz6BdEKiGLOLwi5 mKZ3JiIRjA6epJHglvSK8VMJOTg27F0dPkNEpxmLpY+49+o2Fr4uId6SgB6MYenbCgSOQvXL KBg56EoQIUXHtalpp2CtnqC25xEQP5r4MHycAZ+oYldUAwGPorkInlXhugz5MoPtuniXncc2 tYx9MZ0+/LB0kUo8z6xakUx+mkHeLGK73got0ApFkJHJZ/HFMuoucGgPaZAoj4BEkcktY+rN nGnY1aNUFbyJOzOTx9pUHtOfn2Kgqx8dzRGMz07hyXymQAgp1C0kTbKkjST7w5ZNcHcuba6Y hrpVaXLIgRvHEZZp2iN8gpIKJMEHo8ZQs2svTIf1/nptgcOzQ/Hde+6/TZuL5aKqKyHnR5DW lnzF6dYl+7QDfrBiW57j2uOrnji2yUSQ+MTrl6xUMdYvrxOsIVcl1+uRqRep78Tf8u5yrsce VG3nSlBSnI098t8/U8ME3wUYAEK92uxZ9EygAAAAAElFTkSuQmCC'! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/13/2013 16:43'! monticelloPackageIcon ^ icons at: #'monticelloPackageIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self monticelloPackageIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: '*Komitter-UI' stamp: 'EstebanLorenzano 12/13/2013 14:40'! komitterIconContents ^ #(0 4291344726 4291011108 4291012395 4291011367 4290812957 4290613780 4291344726 0 0 0 0 0 0 0 0 4290950202 4294761036 4294698101 4294834877 4294767789 4294568578 4294303329 4294363448 4290950202 0 0 0 0 0 0 0 4291209781 4294761294 4294697579 4294834877 4294767789 4294568578 4294303329 4294363448 4290215691 0 0 0 0 0 0 0 4290483257 4293638436 4294435416 4294702476 4294568309 4294170434 4293640485 4293762572 4290874662 0 0 0 0 0 0 0 4290417209 4294302048 4294701206 4294834877 4294767789 4294568578 4294303329 4294363448 4290874662 0 0 0 0 0 0 0 4290483000 4294302048 4294701206 4294834877 4294767788 4294568577 4294303329 4294363448 4290940453 0 0 0 0 0 0 0 4290548791 4294302048 4294700950 4294834878 4294768043 4294568576 4294303330 4294363449 4290940453 0 0 0 0 0 0 0 4290614582 4291148953 4291148953 4291148953 4291148953 4291148953 4291148953 4291148953 4291148953 4291148953 4291148953 4291148953 4291148953 4291148953 4291148953 0 4290680630 4290427290 4294441212 4294441212 4294441212 4294441212 4294441212 4294441212 4294441212 4294441212 4294441212 4294441212 4294441212 4294441212 4290427290 0 4290680374 4290427290 4294441212 4287603139 4294309882 4287603139 4294309882 4294309882 4287603139 4287603139 4294441212 4287603139 4287603139 4294309882 4290427290 0 4290680376 4289835439 4294309882 4287011519 4294048510 4287011519 4294048510 4287011519 4294309882 4294309882 4294309882 4287011519 4294048510 4294309882 4289835439 0 4290680378 4289375144 4294048510 4286549936 4294048510 4286549936 4294048510 4286549936 4294048510 4294048510 4294048510 4294048510 4286549936 4294048510 4289375144 0 0 4288522415 4293523711 4293523711 4285957539 4293523711 4293523711 4293523711 4285957539 4285957539 4293523711 4285957539 4285957539 4293523711 4288522415 0 0 4288522415 4293523711 4293523711 4293523711 4293523711 4293523711 4293523711 4293523711 4293523711 4293523711 4293523711 4293523711 4293523711 4288522415 0 0 4287996342 4287996342 4287996342 4287996342 4287996342 4287996342 4287996342 4287996342 4287996342 4287996342 4287996342 4287996342 4287996342 4287996342 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! processBrowserIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAPP1+1Rkg1dnhvb4/Pn6/FtriV9vjGR0kIiTqKy0wuHp+OHp92l5lG5+ mHODnLa+y+Xs+Onv+e3y+neHn3eHnpqmt+Hq+OHq9+Ts+Pb4+ytcnCtalytYkytXkEZzrVp/ r3KDm3aHn3eIn3aHnuDq9+Xt+O7z+vP2+ilvxCluwilsvipquilotSpmsSpkqythpipfoStf oStcmypalypblytblypYkypZkypXkCtYkCtXj2qa1mqRwZe44pez13aIn/P3/PL2++3z+vb5 /M/t+93y/P//n//fX7+fP//78P+/P5qNc9+fP25NJZxoVlQ4MP///wAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAFAALAAAAAAQABAAAAe7gFCCTk9OgoeIgk1NT0ZP i4mITUhHlUhNkYNPR0tPS0eFPTsopCgfT0pKT0moqgkIAbEBKYRKnUuqTkVEvEQCKlCTTMOX BBlDAxkDBSvBjEyPTSfTJ0EABiyHhE5AJkIm4CYSBy2HPg9FEerr6gwuhzwVRBAYGBD0ECUN L4cwIEQkFFywoGCBAgsOYhySESIEhRATRIQY8aOhhkMeatSgoZHGjBobNnrI5IGDjRsjSebQ sVJHBxwdOowMBAA7'! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/11/2013 13:11'! traitIcon ^ icons at: #'traitIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self traitIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private - notused' stamp: 'EstebanLorenzano 5/10/2013 12:22'! projectIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAJWBiJWBiYl7jXJxk19knWBknmBknWBlnWNnmV9lnVZfnlFco1JdokVV qEVWqEpapYWRyDlPrTlQrD9UqihGsy5JsC9KsS9KsDVOrZK17JK27JK165K2653F8p3G8p7F 8p7G8qnW+anV+KnW+LHh/frpnvbflv/xwv/rs+zRi//lpP/aif/flv/Rdf/VfePBfdmycdCs eNGtedCsef///////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADUALAAA AAAQABAAAAZ8wJpwSCwaj0iZUoYczmhQWuwYCABKJVPqBQN4vYGaAHIqm88niEA4QLnfcNRg iFDZ73gVYqhgsRIGBQaDBAcEBoA1DyuMDCSPkJALNRMuLg4jIiEjIZ2bDUIYLREfHx4gHyAd ICASQxUWGRkcGxobHLMXRRS8vb5NwMFGQQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:26'! smallWarningIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAP7bc//egf/ij/7ijv/jl/7kl//mnv7lnv/uwf7CTP7DTf7DT/7IW//N a/7Na//NbP7QdP/dmbltAIJNAF03AMSAJMSCLKqASa2DS6uBSquCSrGHTq6ETbCHT7WKUrKI UcCVXL+UXMOYX8GWXsSZYMiib6+ETbOIUcOXX86uhd3Muf///wAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACsALAAA AAAQABAAAAZowJVwSCwaj0ihikRSJYcoBEL0XKlGkcjImQQhJBREKFnyICoThKeE/AAW6AXg dPyUAgrLJBEo0YsbAQyDhAEdRRwDDw8OaA4NDQImRBgFEJdglxAEGEQZKQcHBqOkKRpFF6mq q1WtrUEAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:26'! smallWindowIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAGh2km95jm56jS1XjzBakTRdkzdgljxkmUBnnEBonERrn0Vsn0hvoklv oktxpUxypE50p091plF2qCtWjS1YjjBbkTlnnTdhlnh/iDlonj9wpXd/iD5wpUR2qkyBtU2B tVqTxVqUxWCbzWGbzY++5K3O6bnV7MHZ7k6c1Veg12Kn2m6t3XCu3YC24J/H59Xy//L7/+v5 /+76//H7/+n5/+36//T8/+Hp7Ov6//v+//X9//j+//v//4GGgYKFgI2NeY6MeZiTcqCZbKec aKCYbdnZ2f///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAEYALAAAAAAQABAAAAeXgEaCg4SFhoeGExMDFQUX BwgLDA8QEoMdKCgpKiwtJC4lJieWgooUBAUGBwkKDQ4RpEZDL7S1ti9Dg7MrvCs0vb65gkIv I0VFIjErxys4RINBLx7HHzIgNzchNUGDPy8Z2BYwHBrlM0CDPS8TNDQTOjo28To+gxvrihM7 +foYgwIvcuTgMZAHwYEBBgFYyLAhQ0QQIxoKBAA7'! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! emptyPackageIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAMAAAAoLQ9TAAAAYFBMVEWen39fXz9/f1+CgmKF hWWIiGiMjG2RkXKlpYWyspK5uZnDw6PS0rKbmnqjooO+vZ3x7sL///8AAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKdzybAAAAEnRSTlP///////////////// /////wDiv78SAAAAAWJLR0QfBQ0QvQAAAAlwSFlzAAAASAAAAEgARslrPgAAAGVJREFUGNN1 j1sOgDAIBAH7oi/1/pe1W4xRk+7HkEzKhtL5Cy0Fv4SmEQHURNpLUQGSiV6OmgXoJqhUiAEy 0TRnZaBNwTLCbGO+iOhjINpKeEqDCf+UehMOfQK4+7BtRIC0+MsnF+ymDJF0K83MAAAAAElF TkSuQmCC'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallCopyIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAPP1+/j5/GN6p+7y+vL1+/n6/Pj5+152o2Z+qGqCrG2ErXGIsXOJsnyS uH6Tuoygw/D0+4GXvISav4mewZGlx97o+N3n99/o9+Ts+efu+e3y+vP2+9zn99/p+N7o9+Hq +Orw+fb4++bu+fD1+/L2+/X4+/f5+5qaj6Cdi52bjq+ngaukhKiihqOfirese7Sqfse1ccWz csOydL+wdryueeDIj9SyaNSyadq9fNWyaf///wAAAAAAAAAAAAAAAAAAACH5BAEAADoALAAA AAAQABAAAAaaQJ1wSCwKYchk0qiLFZ5KJVFmChicz+wNNpyVKBGqtRrA5bg6GmFD8oIVh1AN Z5vpXCPKQ83eADaAGzQ6LxoaA3h6Eg0MCQIQLjoqIHqFh4aYGi86KyIZGZOKjI4gKjosGHqd n6wZnis6LR+zqKKNAhgsOigdFBOys8HBLTopHBwWvL4OCwgXHhUoOifUJ8bI2BYWHClF1d/f QQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! openIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAPjomPjwyPjosOjQiPDYkPjgmPjgoPjYiPjQeODAePjYkPjQgNiwcLyF MsOLNrR/MqVsJK1yK7x/MsOFNq1sJJ5mJ61yL55fHZ5fII9SGf///////wAAAAAAAAAAAAAA ACH5BAEAABsALAAAAAAQABAAAAVV4CaOZGmeaGo6rKNulCZrVDoBADEkzOT7pEZgSCw2SBKB csnEkB6GqMFCrVo3EYXWUuh6uwPLBnI4WMpodFh0QVgW8Dh8LcpYEPg8nj6q+P+AL4KDIQA7'! ! !EclipseUIThemeIcons methodsFor: 'accessing - icons' stamp: 'EstebanLorenzano 9/19/2013 13:04'! changeAddIcon ^ self smallOkIcon! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallInspectItIconContents "Private - Method generated" ^ 'R0lGODlhEAAQALMAAKmyxouWqxcyXVVsh665xjJObuTo7NXz/+v6//z//////wAAAAAAAAAA AAAAAAAAACH5BAEAAAoALAAAAAAQABAAAARLUMlJax0DWFv0qEAxBFJXUqH0ZVtahkUXwwU5 FQeCdGG+UwVEIlEoCYlAQ8JVULokNBtNs6laBQpsVqC1EAQECWFcxWq5Xat6LYkAADs='! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/13/2013 19:10'! smallProfileIcon ^ icons at: #'smallProfileIcon ' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallProfileIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallSaveIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAPj4/Fp5q1t5q1t6q1t5ql57qmF9qdzj7+zv9Ft6qmB+qWR/qGSAqGiC p5ey2bXO8rfJ47rL5L7O5cTS58nW6c7a68/a68/a6vDy9WyFprrM5LLD27vM5LLD2r7P5r/P 5cPS58PS5sjW6cnW6M/b687a6tXf7dXf7Nvj7uLo8GeDp2uFpnCIpcjW6M/b6ufs8s/T2LnF 09vk7uHo8Obs83OLpHeNo+zw9Fh1kXeOo3yQouLt93uQouHt9+zz+dvo8uHt9n+Todzp8uzz +PDz9dvp8uvz+IKVoIOWoPP19oWXn4aYn4iZn4iZnrfDxnGDhoqbnrG9v4qbnPb5+ff5+aWz rv79+uTPnf///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAFgALAAAAAAQABAAAAfcgFiCg4SFgjBQiU9RjIxP iVAwWE1JSU5WmJlWTpVMWEoYRFBUpFRTpFChS1hINwhQPrFDRrFQNzdHWEE0L1A9vz07QEBQ Ly9BWDwpM1BFP0VCP0JFUDMzOlg2MjJQV97fV1AHKDlYNSYnHZDrGycmNVgsLhYWLhcl9PQV JCUsWBkjKARkQJDgiBYiRqzA0mBCCBAMAEgEcIUBiIsqsCyQIOEDAwcgpUhh8MGDBAZYDESI oIHBg5dVqjBYyUEBlgIQcjL4hqNiTggFsMQYQCCBAAEEAghIkIDAUgKBAAA7'! ! !EclipseUIThemeIcons methodsFor: '*Komitter-UI' stamp: 'EstebanLorenzano 12/13/2013 14:41'! komitterIcon ^ icons at: #'komitterIcon' ifAbsentPut:[ Pharo3UIThemeIcons form16x16FromContents: self komitterIconContents ].! ! !EclipseUIThemeIcons methodsFor: 'private - notused' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallHiararchyBrowserIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAG92hCaASDmHUkyTY0OSW1WbalWba1aYalueb1OXZ16gcVGVWlSWW2Kk Y3GucHSwcWupZ2ypaHqoa6HGhv7977qXJsSlQ6+IIK6IIK+IIf///wAAAAAAAAAAAAAAAAAA ACH5BAEAABoALAAAAAAQABAAAAVEoCaOZClaqKlWVKWaGXaNCKG8wGg8k1OogCAgAGlEAq/R gCFZDJKjhOAAJeWqo6sGZUkKASwXbhSbjbEiLdcrDKPLmhAAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallPublishIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAL/F3UhgoExin1Fmm1hqmF5ulGV9sGRykXGEqmh1j292hHV8inmRu3WH qH6VuYSYtam/4LDI5bHI5YSQn2V9lLnS6c7g8LjT6bnT6VyFpU6PvVSLs8Hd7sDd7cHd7dTn 8sbk8Nfs9U1aXfrpnvrvwPbflv/xwv/11P301//rs//xyuzRi//lpP/tv//aif/flv/Rdf/V fePBfdmycffjy/vs4MnAwP///////wAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADgALAAA AAAQABAAAAaIQJwQN1kYh0jk5Faj0RZJoXEyIpVWsplxYeviBhAUykQuk08agDCRarvfqs3w wKrb7y25sPB6Ff6ABQ0PGw8NOAQuigQgjY4hGyEIXzExAx4dHZgcHh8bDkICMAIXpRcYFakW ejgBARGwsRKwDBlIrri5BjgUUb5CCr9JCsTEwkMiCiLHSMs4QQA7'! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/14/2013 16:26'! testGreenIcon ^ icons at: #'testGreenIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self testGreenIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/14/2013 16:32'! protocolPublicIconContents "Private - Method generated" ^ 'R0lGODlhEAAQALMAABCGTTSYaEShdH29n5HIrh6JUnGxdYm4gf///////wAAAAAAAAAAAAAA AAAAAAAAACH5BAEAAAkALAAAAAAQABAAAAQpMMlJq704680xEQKxEcFxBGIWGAhiBBpwtAeg DXI9bEMB7J2gcEjURAAAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallLoadProjectIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAJWBiJWBiYl7jXJxk19knWBknmBknWBlnWNnmV9lnVZfnlFco1JdokVV qEVWqEpapYWRyDlPrTlQrD9UqihGsy5JsC9KsS9KsDVOrZK17JK27JK165K2653F8p3G8p7F 8p7G8qnW+anV+KnW+LHh/frpnvbflv/xwv/rs+zRi//lpP/aif/flv/Rdf/VfePBfdmycdCs eNGtedCsef///////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADUALAAA AAAQABAAAAZ8wJpwSCwaj0iZUoYczmhQWuwYCABKJVPqBQN4vYGaAHIqm88niEA4QLnfcNRg iFDZ73gVYqhgsRIGBQaDBAcEBoA1DyuMDCSPkJALNRMuLg4jIiEjIZ2bDUIYLREfHx4gHyAd ICASQxUWGRkcGxobHLMXRRS8vb5NwMFGQQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallQuestionIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAP7+//Hy9fLz9czU3tvk7v3+/yhilkR2pF2JsV+KsWqSt2yUuHmdvpWy zKK701CAqvX7//r9/+jw9fT7//f8/+3y9fb8/+zy9fn9//z+//X8//j9//f9//v+//b9//// /yH5BAEAAB8ALAAAAAAQABAAAAWA4CeOZGk+j2Ggppg2hBAQzVo+cMHtHEA/JAOhQDiohETD CJfhJAyLmoGTaQA/D0Kk42DsUpwO4Wq4YDCRHcKAiEQqyk95Q+esFRj6JZ6lUHYqO38DVzh+ fw4OFh4WFFYjQhoaHCoaFhoEcS4wEDwQEz83BjASEjQ2LSgqLC2tJSEAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! recentMessagesIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAK291u7z+0tuok9xpVR2qXuWwO/0+4qdtPn7/QU0YM/t++z4/fL8//b9 //nONNbQvJuFSox9ULGPPrORQKqLQfKqC7SQPeiNB6VkFaVlFaRhF4xZJ6BVGptLH5tKH5pH IP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACAALAAA AAAQABAAAAZeQBCIICwaj0OkUkg0fjocDebYFAg3l4ojQxUWrB9PlGsEEAaC9ETBtiy/oLXB IFla45Q8ZVmEKOYQfEIPCwgBEUgHCUWKBw+ISItCCQySSpYJDZaRRZmbR4uLjYKkQQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallHelpIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAP7+//Hy9fLz9czU3tvk7v3+/yhilkR2pF2JsV+KsWqSt2yUuHmdvpWy zKK701CAqvX7//r9/+jw9fT7//f8/+3y9fb8/+zy9fn9//z+//X8//j9//f9//v+//b9//// /yH5BAEAAB8ALAAAAAAQABAAAAWA4CeOZGk+j2Ggppg2hBAQzVo+cMHtHEA/JAOhQDiohETD CJfhJAyLmoGTaQA/D0Kk42DsUpwO4Wq4YDCRHcKAiEQqyk95Q+esFRj6JZ6lUHYqO38DVzh+ fw4OFh4WFFYjQhoaHCoaFhoEcS4wEDwQEz83BjASEjQ2LSgqLC2tJSEAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallPushpinIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAMAAAAoLQ9TAAADAFBMVEWIla4XMl2RmqmQmqgw dLpEdqpGd6tGeKs+hcQ+hMNdm86qyuSryuTF3/RdnM6EtNqEtdrN5PZanMxvtuKz2PBYtuhz xOyZ1PG64fa94vXZ7vny+//r+f/u+v/x+//1/P/4/f/r+v/u+//v+//x/P/y/P/1/f/4/v/3 /v+doaCdoqAAcjYAYS4AUicAlT41m1hytkl9tVGjyoGfp26qqperqZe3sY6/toj///8AAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABs 3AP9AAAAB3RJTUUH1gUREQgiKKvoswAAAJNJREFUeJx9z9kOgjAQheGi4F73XQsULVUr7UgV fP8nsxljgsT451x9F5MMedYif0Gb/BsU3PIqaFBgHAQtvzMc9a2yFq7awXS2WK42W2XAKjwa tP1ubzyAzGQlQkkxDzL7Ab7n3OOuNxQ0YUnC5owdCoQ73YljKMK1EA+EC02jNHKbRGeEJpUn GcvYrYFAKv349gU7qSnr237mhQAAAABJRU5ErkJggg=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallObjectsIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAMsuOdleZt5vd+SCiT1spgpEhBlSkCdemhBLiB5XkZq41GOph3i3mCSA TzCJWwpsNxRwPFibXVibXGqranCkZ6uEGqeBGqeAGp50Fpx0FphtFJNoFJhtFf7SfZNnE/6/ U////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACAALAAA AAAQABAAAAZ1QJBwSCwKAcjkkOFwMIaAgXQAEDIaFErjCQIIvoIqqDEpSxrHgDogfkTekccR HBYuHtnH4phEDhcQekaDhIWDCgpGFRVGBgZFFx0dFkQKCAiJQhkfnB8YQwgHBwhDm52fIAoJ BAQJmSAckhpDBbW2RB4bhoVBADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:26'! smallScreenshotIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAAK/INwWK6QAAABl0 RVh0U29mdHdhcmUAQWRvYmUgSW1hZ2VSZWFkeXHJZTwAAAJnSURBVHjapFNdSFNhGH6+s6lF ZDcpONcWJv1M66buCvrBoi5WGAh5E7SIIiIoLxoliVLgipF00U00MoKgWLoGgWFlWIxAwuzP ag5duUZzbuds7sfOOV/n+04eSgKDXnh5v/c9z/u8z3nP+aCqKhZyWbpD5fwbKn8sp3Lqoh5/ 5QL+xUrqgehmuDrbAOWbHrUcthcgbMJ86wsO0Md9/Ube6W2G6/gj+NztIMtkUNHMSXzXdukE p4+dpcnsInTfPk9Yc8MeB4iSANWmESWm+SRowsPJhNopqOHlOnPFGZCuSz4a/jwGouU/ZKI/ 0MLO3TsMBfucFVzB9bYrMBUlKGXlONJ+iisAIxALquH+u09oaHjccE2hvrDpDnrwkFdf4NQJ jmV1YSYn8ynRaAL9DwbQsHcbHGttiH2KYPDhM+w/cFOT9hZY3KhPZAJNVVhC38HjCUGYFmfx fjSKzEzekMyIQqNhfJeLuNddD3dXBoFgAkJZHQKve0GFargO+8F6zYl0EaKUAfuesXgKS0uB sfAXrLRV42jzRgy+SsFutfBaZlbHwGTR0ONgveZkugBJyvLNRSIxQ4VjTQ3SxUqsr6vk+VA8 ySPHmLbyM+s15/MKUmKGF75OpviUVbUrYLVWaXWJ1/lZq81hbtyPIy8LYL3m0hIFopgFVSkK s4S/Alsk2wOTzYwRWlbX8HNOGyBqA3NFgPWSpqYOum6THex/ZHt4/nQCPb2tHMzIXo5Ejdc6 576FLdvtRv5haALEHximl68G8fulmCNbyFpOOv9+F3qCI/SCN/hHrbXFiUbnBjIfSyil+B/7 KcAAqaNmtdvCPngAAAAASUVORK5CYII='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:26'! warningIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAP7bc//egf/ij/7ijv/jl/7kl//mnv7lnv/uwf7CTP7DTf7DT/7IW//N a/7Na//NbP7QdP/dmbltAIJNAF03AMSAJMSCLKqASa2DS6uBSquCSrGHTq6ETbCHT7WKUrKI UcCVXL+UXMOYX8GWXsSZYMiib6+ETbOIUcOXX86uhd3Muf///wAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACsALAAA AAAQABAAAAZowJVwSCwaj0ihikRSJYcoBEL0XKlGkcjImQQhJBREKFnyICoThKeE/AAW6AXg dPyUAgrLJBEo0YsbAQyDhAEdRRwDDw8OaA4NDQImRBgFEJdglxAEGEQZKQcHBqOkKRpFF6mq q1WtrUEAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! packageIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAMAAAAoLQ9TAAAAYFBMVEX58bvt0ablyaG/gjHF gzLbv57Bei3XuZi/dSrBdyvXuJe3bSi7cSrOq4upYCOTVR+uYyWlXCKgWSGiWSLHoIJxPBee cFh5T0D///8AAAAAAAAAAAAAAAAAAAAAAAAAAAAL0p7aAAAAGXRSTlP///////////////// //////////////8AATQKtwAAAAFiS0dEHwUNEL0AAAAJcEhZcwAAAEgAAABIAEbJaz4AAABt SURBVBjTdY9JDoAgEARZVFxAVGTG/79UmkmMmtCHOlSGSlDXb6op8kvYoSwCVsTUGxMImESM RumZgFGEN1o7AryIJczuZGCpIkciYubCmOvFhh4DmzxZn+gqYn+iu4iEHgFJRHeURaBr/OWz G0x4EXacxCpnAAAAAElFTkSuQmCC'! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/10/2013 17:06'! classIcon ^ icons at: #'classIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self classIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 10/4/2013 15:55'! groupIcon ^ icons at: #'groupIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self groupIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallFindIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAALClrLu1ubOpsKqdp6eapKufqMTAw7attLSrsrGnr62jq8C7v765vaeb pb22vLmyuMbCxsnGycfEx8G+wcrIysTBxUltof//yf///v70jergpPvws+nWc/npqvrpqvrp q/raffffnvXVkfTVkvXUkd+9f+SiOemvV+uyXa2OX7mYZqeIXKuNX/ClO7KQYqiIXJ59Vp19 VpFvTo9uTZBvTpNyUJNyUf///////wAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADgALAAA AAAQABAAAAZ4QJxwSCwajS2aS1U6DlunzcagcuKgG4sn5HJiLZ2QiHbEbj6hEapVTKVYr3OI tG5TIhVGLF0npigUEAsPAjV9Q24pEhMBCAoybEUmGRcrDgcAAzNGkxcYNzAJBQSbRJ0YqBc2 DaVEHJ6pGTStRBqfGBcZILRWvThBADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:26'! workspaceIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAMzFxqeantvb3v7+//39/t7f4vL1+aG41aS61iJDZ2ePupey0Km/2ER2 qkZ3q0l5rEl6rE19r1SCsu7y9v3+/9/o8Pr9/2iz4W214m+24ni65ITA5rrb8Pf8//X6/fL4 +/n9//j8/vv9/u/6/9Xz/9bz/+j4/+r5/+76//H7//j9//b7/en5/+z6/+36//T8//P7/vf9 //X7/fv+//b9//r+//n9/vf8/fz9/fv+/dvTobu0in91Qol6P4N3QZF+PYl6QJmCO5iCO66N NaiKN6GGOaCGOcu0drKPNLmcUPDYqOnEfvbmyJN8V5R/XZWBYJN4UY9pOI5pOI9sPpBwQ5Bw RJJ0So9pOamUj/W5rKmamLZ2b8CEfcikov////7+/v39/f///wAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAGEALAAAAAAQABAAAAfBgGGCg4SFhodhW1tdiIRP W1lbjYJOBQBckg0Omg8REgsVTUwCWliCFxgXGRobHB9QTEoBUAiCmg0QCgwTVrFLVgYHgkgk JCUmFFQ6SktVXjlHgkMkLCghXlM7O1EDXzJJgkQkJzAiCVdSUV5gMi1EgkYkKCMhCQleXgQe KC5GgkIkUqSwgM8LjhUCUwgR9IPEixc0VKiwoeLhwx+CepCI0aGDChAgVMQYGQOIIB8kLFio MaOly5Y+BPGYSbNmzTCBAAA7'! ! !EclipseUIThemeIcons methodsFor: 'accessing - icons' stamp: 'EstebanLorenzano 5/14/2013 14:27'! recoverLostChangesIcon ^ icons at: #'recoverLostChangesIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self recoverLostChangesIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallPrintIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAPcAAIyZuI2auYmYuIyauau52K+82rC92hY6gxc6g0NekoqauoqZuIybuZGd tEBdlFZ0qFRvn1hxn2Z/rWmCrnaNt3qQuH+WvoOZv4ubuVFyp1FxplV1qlV2qlV0qVV1qVV0 qFV1qFV1p1Z1qFZ1p118r2KCtWB/sWWFuGWEt2iIu2iIuoKf0IGezoKfzufw/1N1qVR2qlZ3 qld4q1x9sF+As2uNv2qLvYGgzoKgzoKhzpGftL3O58jW6snW6tDc7ejx/9rj8Nni7+ny/97m 8r3P6LzO573P57/Q6MnX6sjW6dDd7tnj8Nji7/H3//j7/7zP577Q58LU6snY6snX6ebx/+fy /9nj7+nz/97n8uXx/9nk8Njj756mr+r0//D3/52mr+32//f7//f5+/L5/+3y9vj8/+jv9PX7 //r9//L6//f8//b8/+3z9vf5+vX8//r+//n+//r///v///z//6uwra2wrvv9+vz9+ri4qb68 pry5oMfCoLe1p8jBmsS/o8vClMvClczDmM7FmsG7nMzCls7FnMvDody/befNk9GjQ82gQv// /////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAIwALAAAAAAQABAAAAjmABkJHEiwYEFB hP4AClTIIME+iyIuUrTHkENGg944cfIG0aFEfhzqKRPGCRo5cebkcchnjQUKEiA4gIOHIIEa B+g08ZLmjBo3Y+ogqEGAkY2IX7pcqDAhQgIwXCLaYKTCTpsGVLL8EHKligsdYu6kYISCjJkF CgAwCDAAAwYBZticYFRiSBArS7ToBQJEyxYmWEowoqFECo8pSBL36JGEhxQfJhiRiHLkieUi O4g8MQLlSJQZjGTEgOGhQwcPHja8MM0hhgxGBTKwwJGjRY4VtnHfyFBAoAEND0CIGD5CRIgP GgwwCggAOw=='! ! !EclipseUIThemeIcons methodsFor: 'accessing - icons' stamp: 'EstebanLorenzano 9/19/2013 13:04'! changeRemoveIcon ^ self smallCancelIcon! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:26'! smallUpdateIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAABVlg1dmQ1dmB9nnSBonR9onTR0okqBplyMql2NqnOas1yNqmmUrXig tI+xwH6mtn6mtYStt53Cw53Cwp7CwqzSxqzTxbjhybjhyLnhyMHryv797/vwtPnolPvpnvnd evHag7eUJPHTc/vehfnNX72EFrB2Erh+FLN6E7uBFbqBFbd+FbuBFqluEKhuEKxxEahuEbB1 Eq91EqxxEqtxEq91E////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADYALAAA AAAQABAAAAZtQJtQWCoNj0jixpg8slKpzUbVFJ5AnCyns2qGRJ5w+INq1kYkmQkdq85ILxuN NKvaXDAhrCVkMPp2Ngwaf4N/TQkZGAgLGRcITQcRFpQVFREHTQYQExQSEg8GdgQNDgMFBYE2 AgoBqkMAAK92QQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallCutIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAANjb5r7DzZ2nuba+zBcyXXmHnU1ge2KLs3OVuK7F3WGLsytto0d9q0h9 qxFemxJfnBJfm////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA ACH5BAEAABEALAAAAAAQABAAAAVRYCSOZGmWQnCagDGsZVDAZTGL79oK0VAYI4RwJDAUCwOA SJGIJA6RAsHgKjFEiYbNqCwtEuDFoJgzPSAOHJA2GggR7AjTCaVdnQ32Nxw/p0khADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallRightFlushIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAJEAADk7iUNKh////wAAACH5BAEAAAIALAAAAAAQABAAAAIglI+pyw0cohSv pWqkntiajmwB5SGdqJHlB23qCq7yfBQAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:21'! configurationIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAJKAiruyu4t8jYR5j4B2kXZxlXGFrH2RuX6RuYaawmJ3nWN3nHGFq4uW q1Vrj1Zrj/v9//j8//r9//H6//T7//f8/+35//D6//P7//b8//n9//z+/+z5/+/6//L7/9Xz /+v5/+76//H7//X8//j9/+z6//T8/+77//P8//f9//v+//b9//r+//n+/////////wAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAC8ALAAA AAAQABAAAAaOwFdjSCwahZ+kcqlsIEGAKGhKnTobH0DAFQBwOKXSt3T9CFxogSWBYCweoTJh GyB0Oqf7vTwp+EWAExciFxdlHogYGB4oih6KZSZRACMjJiMUlyZlWlwAKxkrFSkVGWVnAy4C JAkHBgoOEXJ0BC0sEhq3EmUQfgUQECrCwhBlG8fIycdXRs1EL9DR0tMvQQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallExportIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAD8/nz9fn0xnl1FtnlFsnVRvoVBtnVNwoVFtnVJunVh0pFh0o1h1o1l1 o1x4p198q2B9q197qGN/rWR/rWaCr4WhzYahzZ2z1l99q199qmOArYWizYaizYaizJCq0qe7 2qe82q/B3TNwpDNwo0B3pw1cmv///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACYALAAA AAAQABAAAAZmQJNwSCwaj0gjaVQqJYkkkfMpLEWppimJCjBGKGBiYAguh0KUYZd8pmhCGolw TJRIQpPHB/LMgDAOFw5PgQ4NHgkKDAuMjY0eCwccHBscFpUbGx0cFZQFAgYGAwgGpKEIqASo WERBADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallInfoIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQaAPb9/wJGjA5ipFWQv7bQ5MfU0PT7/5a2xff8//j9//r9//f9//z+//X8 //3+//n9/+zy9fb8/whUmPv+/wxcn/Lz9e3y9f7+/wtdn/Hy9f///wAAAAAAAAAAAAAAAAAA ACH5BAEAABoALAAAAAAQABAAAAWIoCaOZFkWgxAEwlCY2hEMRJURQ3CUh0A4AIEAcCEIdqJC 4AcIDgEOQuClGQwYTQC2yWBYRT5FU/icTIyiAOTxEAubCoUlkIYk7gAKBvC4Q+gaPggICwAS EgsLhGhVA4MIACsNABEIXxpKBA0NKysRDVJUMT4GpaZGSCMyNKU4OjAoKiwuMLUlIQA7'! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! testRunnerIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAKIAAAAAgD9fvwCAgICAAICAgAAAAP///wAAACH5BAEAAAYALAAAAAAQABAA AAM0aLrc/pANECIDpdhFANhZtnzPh2kFAREZ0QnWqW4nAD8CIXyT5rAnRefhYww3QswNyXwk AAA7'! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/15/2013 21:09'! widgetIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAB+UlEQVQ4jaWTy2oUURRF17m3 qvqRdHce3ZqHMYLgRIJm4sCR0whx6CQ+JhkK+iuSoYJgvkDwA/wDcZpojGny7rTRdKU6Vffh oE3FJqAB9+ge2HuzDocL/ykBWH754ZVSsqgDdaGQMc5j/dKjF/eeBwBKyeLY1WFvTSYiCq31 b2MGIgQ6AMBai/cOrQO2Ng6fAb0C5w1ZLOJciLGGpNtGqYgoLCIipOkRxmcMFIfQKsRpEcQJ QM5srGNuYYb5x7PEnZSTJOPB01nmn9zm+Dgl6WTcf3iLuYUZTGbzdRRAGEYkSYf4uwMBZx3l apibyoMhWWpQBfjZMiQnMVpp+ggQy/rqDgD18SqNsSrd2IKDxniNkUsVAL6ubAMmjwWnD68c 3z7vcfPOBFeuNajUyuxutimUIsYmh4kKPWtzrQXanx7wjKBeHyE+SsDD5HSDyxPDbDUP2G62 GJ+qMzndAANJnDA6OnKeoFdnaa4eMnVjCIDdzTbFUsTs3etUagXWV9qIdv2RPwfRno21vXw+ 2Dtif/tH7mx+2cfLXwrKgxGtnc4ZXhDg/ZmlvR9TqZX7CvpWKBXLuDTl/dtPOGcpDUSIwLs3 H9FaoUMoRIXzBcY4771HRGSgGuVwFYboV4/GOe+ddS4v6HaT11sbflHri30ma5xP0+7Shcz/ 0i8hyMm9wAyCcQAAAABJRU5ErkJggg=='! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/13/2013 16:24'! dirtyPackageIcon ^ icons at: #'dirtyPackageIcon' ifAbsentPut:[ (self packageIcon asFormOfDepth: 32) mergeBottomRightWith: (Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self overlayDirtyIconContents readStream)) ].! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallConfigurationIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAJKAiruyu4t8jYR5j4B2kXZxlXGFrH2RuX6RuYaawmJ3nWN3nHGFq4uW q1Vrj1Zrj/v9//j8//r9//H6//T7//f8/+35//D6//P7//b8//n9//z+/+z5/+/6//L7/9Xz /+v5/+76//H7//X8//j9/+z6//T8/+77//P8//f9//v+//b9//r+//n+/////////wAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAC8ALAAA AAAQABAAAAaOwFdjSCwahZ+kcqlsIEGAKGhKnTobH0DAFQBwOKXSt3T9CFxogSWBYCweoTJh GyB0Oqf7vTwp+EWAExciFxdlHogYGB4oih6KZSZRACMjJiMUlyZlWlwAKxkrFSkVGWVnAy4C JAkHBgoOEXJ0BC0sEhq3EmUQfgUQECrCwhBlG8fIycdXRs1EL9DR0tMvQQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallDebugIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAALGusR1ieR1jeR1jeB9leR9keCBleSJmeiFneSRoeidqeydreiptfCpt eytufCxvey1wfDhWUzFOSiA5Mi1ORThWTjFWSihBOTFORShIPShFOS1IPSM+MiNBMi1OPS5q Ijp8K1ONPJLBf3OnWJbDeZXCeZ/HgabJh67Oka/OkbXSmdvrzLbSmbjSnLjSncbcrtXnwtvq zOfz28fcr8bbrsfbr8vftNXmwsfbrv///wAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADkALAAA AAAQABAAAAZ5wJxQWBkaj0PJMII0AjYAIaZpkVAyEAhAE23mABBZLQvJTS5Nx+yzur0eAIDH IowwAY2YbGVzMbpGGBoKMCsiNCwnC00cCS82OCMpJgkTHkdcCC0qKCEkB1FKQxQABAYnJiUg BUh0QhMBAwIBXkMdcbVGGblGrry/QQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallPrintItIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAEOTXkiUXzKESUOUW0mRXbPSvC2ERD+VVoe9laXPsE2XX3S0g4C4jqPO rb7axcbcy8bay9fk2jyTTkOXVUGSUk2WXWCncFaSY3Kwf4G4jXOxf0GNTk6YWlKYXjyNSEqT VFGaW12kaNnm2y98OE2XVlukYyp9MjWEPUWNTFSgXMDVwi9/NT6PRESQSTp3PrbSuDeMOzZ2 OkiYTDqIPUSTRmykbbDOsbjTua3Lra3KrbfQt/X49bjSt12dWFSPT1qSVHS2bHGmZ0qIO2yj X2+kYGyjWcvcxXKmXmWjSIa0boe0bpa6gZK5eLrYpoG0WJ3VYIXOLp7VX5i/ba7ecq7cdvv/ 9vn+8P7/+Pj46P797/jwsPjomPDYgPjgiPDgqPjQYPjYePjYgLCDGbB8FKFuD5poD6l1FP// /////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAGgALAAAAAAQABAAAAergGhoBUA0BBUZDoKLiwgk UFNSS0EdCYyCEB9KTVZRTkxJHBGXFj1HKmdVT0hEQxqXGz8+OmdnV1RFNQqXAi4xObVnRkIX AJcGKyY4tTcnIyADlxgeLTZnLygsDxQMlyISMjw3MzAPYg/mYowNEyElKeZZYjtiWOqLDwsH AeZYWmL1vNy7hEZMFy0IEXIZQ1CQGTBbIm4BY6ahIDIYw3whY5FRmS9lOnoMKSgQADs='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! variable_viewIconContents "Private - Method generated" ^ 'iVBORw0KGgoAAAANSUhEUgAAABAAAAAQBAMAAADt3eJSAAAAD1BMVEX///+LmKqdprJlfJkz TG9+bST8AAAAAXRSTlMAQObYZgAAADZJREFUeNpjYMANGB0YGBxBDBEBCGYwYREQYTEAMpwZ nRyZHVxcGJyBEswOyCJwNXBdcHOIAAD04waDcvfrWwAAAABJRU5ErkJggg=='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! uncommentedClassIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAPR4e8gnL/Rmb/Nnb/NYY/JXY+mkqsgZKvLFyvTQ1PT3+8lHPvaSjsk6 OPaIhvaHh////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA ACH5BAEAABAALAAAAAAQABAAAAVHICSOSqmMKKogy4KcqbowzALHorI8jo2TDQCgccMpAoJB oBhTHAqEAzOlMLQMU+pB+ut6IYlW4qtz9LKkg5nbXW1fZNP3GwIAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:22'! smallCancelIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAMczNfRxdPRzdPNydPNzddgqL+AsNN8sM8cpMOY2PuU2PsUgK+UwOfJV YPRja/NjavNja/Nka8UYJ8YZKMUZJ8YgLPJUYMUTJfE/UvA/UfJIWPFIWNRldN+cqMpdSc5u XspXRspYRslYRtWIfMlQQ9ymoMlHPslHP8hHP8c9OeBhW/WBfcc9OuNST/WAfvSAfuPExP// /wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADEALAAA AAAQABAAAAZ8wJhwSCwaj0eYZ1QceWBEWKgVYgpHohYIKiyRXCvSp/QhvcIl4ghFEKhMqkHg ZCVyWBHIw/FIcZAACg0NFgkASDEIDBsaGgwISBwVGJSUC39FHBOUBRIFGBkUmEIdF6AXHB0c phkXHUMwFwaoQ6sHF1xCsaNCq7mIwMExQQA7'! ! !EclipseUIThemeIcons methodsFor: '*Komitter-UI' stamp: 'EstebanLorenzano 12/13/2013 14:44'! historyIcon ^ icons at: #'historyIcon' ifAbsentPut:[ Pharo3UIThemeIcons form16x16FromContents: self historyIconContents ].! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallDeleteIconContents "Private - Method generated" ^ 'R0lGODlhDgAQAOYAANDY6GiYyGiQuHCYwEiAsFCIuGCQuGiYwHCgyAhYmChwqDh4qECAsEiI uJC42LDQ6BBgmDB4qDiAsFCIsFiQuGiYuHioyAhgmEiIsBhomDiAqGCYuIiwyJC40JjA2Hio wICwyJi4yChwkCBwkIiwwKDI2BhwkDB4kHiouCh4kJi4wDiAkJjAyKDI0LDY4Dh4gECIkDiI kEiQkJjAwKDIyKjIyLjY2MDY2EiQiICooKDAuLDIwMDY0IiwoJi4qKjIuLDQwLjQwMDYyJCw mKjIsLDQuLjYwKjAqMjgyLDIqLjQsMDYuMjgwMjguMDQsNDgwNDguNDgsNjosP///wAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAFMALAAAAAAOABAAAAergFOCggSFBIODAAMGBQwR CgoLBAYAggcPLjdIT1BIPDYPB4IADQ0UAhUbFBgSDZWCMTk9MT4+MT05MYg4SU44UVI4R0Mv u0RKOFBROEpEMogwP0UwnDBFRDCIKzo7K0xNKzs6K4gnKjUnQksnNDMniCIkLSk8RiIhLCmI Jh8lIzZBRnDoMAJRhgMeMtgAksGCgwyINBBAAAEEigsTAmhANEVDgo8gN3IcyTEQADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:23'! smallHierarchyBrowserIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAG92hCaASDmHUkyTY0OSW1WbalWba1aYalueb1OXZ16gcVGVWlSWW2Kk Y3GucHSwcWupZ2ypaHqoa6HGhv///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA ACH5BAEAABQALAAAAAAQABAAAAVFICVSCKGMaGo8k1OkcAA1UQCnAyMtw50mgoMPBhiVTr4i ZdV63QBQGc32FOV2vaoIKEwOiUbTUMl0JaOzmpdy5a0pXFQIADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallHomeIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAACM+gCdBhNre6BM0fC5NjxI0fCE/fV17r9ne505upU9uo1Z1qld3qlh3 qlt6rlt6rVt6rF59sF58r2KCtWOCtdje5yJHeSBHednh69fe59be5+30/PL4/+bx++f0/+Xx +8zX4Ov2//H5//j8/+Dw+yRTciVUct/y/uT0/ef2//X6/eL1/+v3/eb3/+b4//T8/y1kbClh Zv7//zt/ZDZ6XTyFYD2GXzmEW2JmYWdtZWzBOmhtZW9za7reHWVmX+3rAvPzBWhoXJOTg66r cpOPW66qc//7zpOSg396TWhmW//1v5SRgZSQgP/yv//qqv/srXJtXJiTgm5pWp2Te5mRfv/e lv/fmJ6VgP/Pc6KVfP/PdP/Ug6WVeaSVeqGTeaaWe54/NaBCN59FOv///////wAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAGQALAAAAAAQABAAAAewgGSCg4SFhWJFgl+GhUNg ZF1GXIyDYURZSlBNXpRkSFdPUhhSTlOUUVZBFWMVSVVUhktbPgJjtgI+W0yER1g4CGM3NTdj CDhaQoM8Oxm2Nj82tho5PIQFIDJjNDM0YzIgA4UEYyojtmMjKmMEhQovGyIxMDEcGy8JhRMs HyEmQCUhOrCgUCgCChIeLPS4kIIECgmFIKw40cKADgMuTqxwUOgBgwUHAAQAcGBBAwiCAgEA Ow=='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallPasteIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAPb3+vP1+oeUroeUrfL1+/j5+152o22ErV9zlmBzlnGCoIeVrt/o+OLq +O/z+u7y+YGXvICUtIGUtJGlx4KRqoeVrZenwJinwI6bsI2Yqq+6zN7o+Obt+PP2+4yYqq66 zN7o9+Hq+OLr+Orw+d/p9+Lr9+Xt+PP2+pKbpt7p95KcpvL2+qvB1PX4+pqfoZmgoaGknKio l6+tkru0irawjrCskuDIj9q9fPLGcfHGcfLJefHIefLMg/LNg/LQjvLRjvTVmfPVmvTZpfTd sPXhuvXkwvHFcfLIefPMg/PQjvTUmfPUmvXYpfTYpfXdsPbhuvbjwvbkwvbmyNiubMyoddCs eNSwe86secWaYcOaZM6pdseicsqldNOuesGbbMSeb76Ya62BUq+EVrGJXLONY7yWarWQZ+TW xtTBr////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAGkALAAAAAAQABAAAAe6gGmCg4SFhmkYLCwYh4QU Hx8aHxSHZ1hYChcWFhcKYVhnhFZSCRISEaYSCFJXolKvsLFUhF1RUEVRM7q7WYRVRERPRDMF xQU3NIRaQ07MNC0TBgA2yINcTE1CQjUdBCsnJwEyg1tBS0BKMQ4TEAcGDzGDXz8+SUkwI/n6 MINePD1IkLzgwM6dCReDwOzQcUSHihAlGogI0QDFoDJTjODI4WEDCQYpUoDIMAiNGTJjxAhY UGHAgJYD0gQCADs='! ! !EclipseUIThemeIcons methodsFor: 'accessing - icons' stamp: 'EstebanLorenzano 9/19/2013 13:04'! changeUpdateIcon ^ self smallForwardIcon! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! recoverLostChangesIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAJJ+itPL0MfG1MPE1VxlnVxlnLi92k1boz5Tqj9UqjFLrzFMr7K73WZy jAsaOGx8mZC27AY3d9Pi9xpJgxpJgiJQh4GPoGKk7bC+zmeq75zG8m2y8sPf+XK59Ha+9qnW +LHh/eDz/uf3//H5/eP2/+f4/+76//T8//zTrfu5f/jAmPvXvfmbePvDs////wAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAC4ALAAA AAAQABAAAAZtQJdwSCwaAUjjUZVqBZRCpMfDQQICz2IixAWsUCwAQymQdjaZi7U4SIDe8Hei WJAQPo28Pk88GA4aDSSDhA1GCBANIg4lD4yGRQsKDSYWIxgWJpAVExERQg0noqOQLpyfLnt7 RBUUUEoVr7JQQQA7'! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! logical_package_objIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAPbpu/PhsvXjtfDesu7br+zZrsGYRPLaquzXrubTrPDo2Pjw4Pjy5uzR pezSpuzTqOjMoefLoOzQpefLoeXLo+DDnOHFnuPHoODEnt7Dn93CnvPr4MWDMty/mti7mPPq 38F6Lb13LNS0kde3lNm6l9e5lrpxKtOyj9Gwj9S0kte3lfDo4Ojg2KZeI5NVH6phJLBmJ8qm h6JZInE8F3A2F55wWHlPQMCooP///wAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADgALAAA AAAQABAAAAaEQJxwSCwai7MjEcQEuZqgIwjgKNUIAUzUaHhARrWJpBI6zjYf1k1BQpmG0Gfz Vqu5krhp9ZoFMQoaMEMhXmBiZAsHFy9DJh4qMTYpbSYrFx0tQjMudTaedS40BjIcQzADESI2 CYCCRi8CDSQ1CIqMRi0UFic1GZeZRhwywy7DpEpDeEdBADs='! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/14/2013 16:27'! testNotRunIcon ^ icons at: #'testNotRunIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self testNotRunIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:24'! smallLeftFlushIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAJEAADk7iUNKh////wAAACH5BAEAAAIALAAAAAAQABAAAAIelI+py53gngi0 MhgPrNzq/HXBBRqb6JmlcHLkCoMFADs='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! jmeth_objIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAOYAAGiUxXSdyYKn0Ims04uu1Nfj8d7o8+Ts9UV9tE2DuEt/s06DuE2AtFGG u06BtVKGulOHu1OGuV2Ov2CRwl+PwGKSw2GRwmSTw2aUxGaUw26byG6ax3ahzHukzn6mzn2l zYKoz4is0pGz1pO015a215e215q52qjB26nC26vE3bHI4LzR5tzm8OXt9U6CtE+DtVKIulWK vFWJu1aKvFeLu1uOvl2PvmKUw1+QvmGSwKrD27DI37LK4N/p8qbE3sfa6v///////wAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAEEALAAAAAAQABAAAAefgEGCg4SFhj8DFRMWAz+G giQTGgKUGhMkhiQ0ICY+niYgNJiDBQ0dLR2pqS0eDQWDAxsrQAcctgdAKwEigxc1KkBAPRQ9 wTs2F4MQDCdADixALA5AJwoPvTAoQC8vLNzULsmCIjMpQBHo6EA6MiWDBgg5PTn09Dw3CK+D IwkAH///cMQYYWjEAgwZEmJYQPDRjxASYEgg4OiRxYsYgwQCADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:25'! smallRedoIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAPz62f385vz52f797/375v352f775vvws/vwtPvxtPvpnvvpn/vjke7Y i/vllvvll/vontzKi/von+rftPvehfvfifvgifvhjfvijc24dfvjkt7VudS2X8KpZtK/htfH mLaWSceubcOrcs68k7yDFb2EFryDFrB2Erd9FLN5E7J4E7uBFbV8FLyCFrl/FbmAFbuCFrqB FqxxEapvEapwEaluEahuEa90Eq50Eq1xEqxyErB2E6dsEP///wAAAAAAACH5BAEAAD0ALAAA AAAQABAAAAaBwJ5wSCwKPaWNcVmadIil0rI1MBFJVWNsMFkNV4MBrCiaBCIvV+ZlMBBeRFFE UAA0GoWCYI8afkIICAcJB4IJgQgsQykNEgsQkAsLCo4QKkIfJw6bmw+eDg87RB84HAynDBoa DDdLIyA6MhcXGDlLRDQWFTO3RDYUNb1EPDzCxj1BADs='! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/13/2013 17:15'! protocolProtectedIcon ^ icons at: #'protocolProtectedIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self protocolProtectedIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:21'! forwardIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAP797/375v332f765vzyyv732f732v322f322vzpqPztuf3yyf3yyv72 2fvgjPzkmfvkmfzoqPzoqf3tufvdg/zgjPzjmb2EFq51Erd9FLd+FLV7FLV8FLyCFrmAFbuC FqtwEatxEaluEa90Eq1yEqdsEKZrEP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACcALAAA AAAQABAAAAZkwJNwSCwaj0ji5ZIsdgCd5vADAHyMnqzWMwgMPERNo1FAHAyCggAhyAw3DMaC EF/I7QyOEDPpK/4TCoGCI0IkEogRihESCYwkRCGSISCUDxAWIVIiFQ4iUiclFCWgJyYmpalS QQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:26'! toolsIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUyALJ5KP38+v313PjQgPjgoLCLIceLN8ymcKttJfjYkPjgmMabX6ttIrqX JqtnHbp/KO7z+OHr9/jomP3y141PFPrcmujQiP3v0ZxbF/zpv/jTh9e6lvDYkKh4SKNnHd7K s7eBNdiwcPzwzv3v1L2Wavrgqvrosrp5KODAePrlsPjYiNHf7sF/K/jQeJxhH/josPjwyIGY sv///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADIALAAA AAAQABAAAAZ/QJlwSCwSDUiDseggNpcylkTCsaBCrGyW+IB5v+AH8fQqm88dIoDAJgDeoMVh fljIGIk8Q8E3iQSAAhsyHioqCIaGKRMFjQVCGC0IA5QDGiUjMQ0NMUIUCC2hoRUZFzEBAZ1C LqytJB8xEagRqlAxKxAQK7VLtyu/vL0xw1DFQQA7'! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:26'! smallUndoIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAPz62f385vz52f797/375v352f775vvws/vwtPvxtPvpnvvpn/vjke7Y i/vllvvll/vontzKi/von+rftPvehfvfifvgifvhjfvijc24dfvjkt7VudS2X8KpZtK/htfH mLaWScOrcs68k7yDFb2EFryDFrN5E7qAFbqBFbV8FLyCFrh+FatxEaluEa1zEqtxErB2E6Zr EKhtEadsEf///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADQALAAA AAAQABAAAAaAQJpwSCwaj7QNyXMkkYidybNIGkyF1atwNBiUhqPJQEVEEQwGVOaEigQmoeFK QC8UGg1AQRCJ01IIgQkHCAeDgSEfNCYQCxIKCwsQk44NJkMwDw4PnA6enjCKQy4MGhoMqAwc LqJELBgXFy8vICJINC0VFi23RDMUMr1EMTHCxkEAOw=='! ! !EclipseUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/23/2013 10:52'! protocolProtectedIconContents "Private - Method generated" ^ 'R0lGODlhEAAQAMQAAP/ysP/pkf/qkbeTJb6cKLuYJ7uZJ//mmK6HH7ONIrKNIriTJP/efad+ HKqBHaqCHq6HIP7bjP7elv7PbP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA ACH5BAEAABQALAAAAAAQABAAAAUzICWOZGmeaKquJUGwFAEAr1oIeGCky8H8jMMApYhMjpNI IgWROCWIlcP5gDUasKx2CwsBADs='! ! !EclipseUIThemeIcons methodsFor: 'private' stamp: 'EstebanLorenzano 5/10/2013 12:21'! backIconContents "Private - Method generated" ^ 'R0lGODlhEAAQANUAAP797/375v332f765vzyyv732f732v322f322vzpqPztuf3yyf3yyv72 2fvgjPzkmfvkmfzoqPzoqf3tufvdg/zgjPzjmb2EFq51Erd9FLd+FLV7FLV8FLyCFrmAFbuC FqtwEatxEaluEa90Eq1yEqdsEKZrEP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAACcALAAA AAAQABAAAAZkwJNwSCwaj0jh5ZIkdgCdpvADAHyknkFg4Ol6PcSMACEoCAwHRKHR0Ag5DMZi IY8T6IyNcDRRKPp9fhODGEMkEhEJiBGMEo4kRCEWEA8gIZYhmUYiDhUiUkIlFCWgQiYmpaml QQA7'! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/10/2013 14:16'! removeIcon ^ self smallDeleteIcon! ! !EclipseUIThemeIcons methodsFor: 'nautilus' stamp: 'EstebanLorenzano 5/13/2013 17:14'! protocolPrivateIcon ^ icons at: #'protocolPrivateIcon' ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self protocolPrivateIconContents readStream) ].! ! !EclipseUIThemeIcons methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/26/2013 15:29'! overlayRemoveIconContents "Private - Method generated" ^ 'R0lGODlhCwAKAKIAAD8/X////19fXwAAAP///wAAAAAAAAAAACH5BAEAAAQALAAAAAALAAoA AAMjSLHMpALIGV4AIudRFdYCZwFNIHpg2F3peQ0wTFql89z4kwAAOw=='! ! !EclipseUIThemeIcons class methodsFor: 'license' stamp: 'EstebanLorenzano 6/21/2013 11:18'! LICENSE ^ ' The icon pack itself is distributed under MIT license. The eclipse icons, however, have their own open source license terms, the EPL, who can be found here: http://www.eclipse.org/legal/epl-v10.html '! ! !EclipseUIThemeIcons class methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/17/2013 13:33'! iconSetName ^ 'Eclipse'! ! !EclipseUIThemeIcons class methodsFor: 'testing' stamp: 'EstebanLorenzano 10/17/2013 13:34'! isAbstract ^ self ~= EclipseUIThemeIcons! ! !EdgeGripMorph commentStamp: 'gvc 9/23/2008 11:58'! Similar to a ProportionalSplitterMorph but designed to attach to an edge of a single morph only.! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/25/2011 13:10'! defaultHeight "Answer the default height for the receiver." ^ProportionalSplitterMorph splitterWidth! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2007 14:26'! themeChanged "Update the fill style." self fillStyle: self normalFillStyle. super themeChanged! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/19/2012 17:50'! bottomLayoutFrame "Answer the layout frame for a bottom edge." ^ (0 @ 1 corner: 1 @ 1) asLayoutFrame topLeftOffset: 22 @ SystemWindow borderWidth negated ; rightOffset: -22! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:33'! mouseUp: anEvent "Change the cursor back to normal if necessary and change the color back to normal." (self bounds containsPoint: anEvent cursorPoint) ifFalse: [anEvent hand showTemporaryCursor: nil]. self adoptPaneColor: self paneColor! ! !EdgeGripMorph methodsFor: 'accessing' stamp: 'GaryChambers 1/25/2011 13:05'! fitTargetOwner ^ fitTargetOwner! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 13:05'! positionPoint: aPoint "Reposition based on ptName." (#(top bottom) includes: self edgeName) ifTrue: [^self position: self left @ aPoint y]. (#(left right) includes: self edgeName) ifTrue: [^self position: aPoint x @ self top]. ^self position: aPoint! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/19/2012 17:57'! rightLayoutFrame "Answer the layout frame for a right edge." ^ (1 @ 0 corner: 1 @ 1) asLayoutFrame topLeftOffset: SystemWindow borderWidth negated @ -7 ; bottomOffset: SystemWindow borderWidth - 26! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/19/2012 17:58'! topLayoutFrame "Answer the layout frame for a top edge." ^ (0 @ 0 corner: 1 @ 0) asLayoutFrame topLeftOffset: 22 @ -29 ; bottomRightOffset: -22 @ (SystemWindow borderWidth - 29)! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/25/2011 15:13'! setTargetBounds: aRect "Set the target bounds, taking owner into account if required." self target bounds: aRect. self fitTargetOwner ifTrue: [ self fitTargetBoundsInOwner: aRect]! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:26'! adoptPaneColor: paneColor "Change our color too." super adoptPaneColor: paneColor. self fillStyle: self normalFillStyle! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:23'! normalFillStyle "Return the normal fillStyle of the receiver." ^self theme splitterNormalFillStyleFor: self! ! !EdgeGripMorph methodsFor: 'accessing' stamp: 'GaryChambers 1/25/2011 13:17'! edgeName: aSymbol "Set the value of edgeName. This is the edge of the target that will be manipulated by the grip." edgeName := aSymbol. self setLayoutSizingFor: aSymbol; layoutFrame: self gripLayoutFrame; layoutChanged! ! !EdgeGripMorph methodsFor: 'initialization' stamp: 'GaryChambers 1/25/2011 13:12'! initialize "Initialize the receiver." super initialize. self fitTargetOwner: false; edgeName: #right; extent: self defaultWidth @ self defaultHeight; hResizing: #spaceFill; vResizing: #spaceFill! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/25/2011 13:20'! setLayoutSizingFor: aSymbol "Adjust the sizing for use within table layouts." (aSymbol = #left or: [aSymbol = #right]) ifTrue: [self hResizing: #rigid; vResizing: #spaceFill]. (aSymbol = #top or: [aSymbol = #bottom]) ifTrue: [self hResizing: #spaceFill; vResizing: #rigid]! ! !EdgeGripMorph methodsFor: 'accessing' stamp: 'GaryChambers 1/25/2011 13:05'! fitTargetOwner: anObject fitTargetOwner := anObject! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 13:05'! targetPoint "Answer the reference point of the target." ^self target bounds pointAtSideOrCorner: self edgeName! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:20'! isHorizontal "Answer true if the receiver has a horizontal layout." ^self edgeName == #top or: [self edgeName == #bottom]! ! !EdgeGripMorph methodsFor: 'event handling' stamp: 'GaryChambers 1/20/2011 11:23'! mouseMove: anEvent "Track the mouse for resizing." target ifNil: [^self]. self theme settings fastDragging ifTrue: [target doFastReframe: self edgeName] ifFalse: [ lastMouse at: 1 put: anEvent cursorPoint. self targetPoint: lastMouse first - lastMouse last. self positionPoint: (lastMouse first - lastMouse second)].! ! !EdgeGripMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:58'! target: aMorph "Set the value of target" target := aMorph! ! !EdgeGripMorph methodsFor: 'geometry' stamp: 'gvc 10/19/2007 21:25'! extent: aPoint "If our minor extent changes then adopt the pane colour to reflect any size based gradient in the theme. Assumes fillStyle will not change on the major extent for performance reasons." |ext| ext := self extent. super extent: aPoint. self isHorizontal ifTrue: [self extent y ~= ext y ifTrue: [ self adoptPaneColor: self paneColor]] ifFalse: [self extent x ~= ext x ifTrue: [ self adoptPaneColor: self paneColor]] ! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2007 15:11'! splitsTopAndBottom "Answer true if the receiver has a horizontal layout." ^self isHorizontal! ! !EdgeGripMorph methodsFor: 'actions' stamp: 'gvc 10/1/2007 13:05'! resizeCursor ^ Cursor resizeForEdge: self edgeName! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/19/2012 17:56'! leftLayoutFrame "Answer the layout frame for a left edge." ^ (0 @ 0 corner: 0 @ 1) asLayoutFrame topOffset: -7; bottomRightOffset: SystemWindow borderWidth @ (SystemWindow borderWidth - 26)! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:23'! pressedFillStyle "Return the pressed fillStyle of the receiver." ^self theme splitterPressedFillStyleFor: self! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/25/2011 13:13'! fitTargetBoundsInOwner: aRect "Reset the target bounds if required to ensure that the owner's submorphs fit within the owner's exisiting bounds when layed out." |ownerMinExt targetOwner| targetOwner := self target owner ifNil: [^self]. ownerMinExt := targetOwner minExtent. ownerMinExt x > self target owner width ifTrue: [self edgeName = #left ifTrue: [self target bounds: (aRect left + (ownerMinExt x - targetOwner width) @ aRect top extent: (aRect width - (ownerMinExt x - targetOwner width)) @ aRect height)] ifFalse: [self target bounds: (aRect origin extent: (aRect width - (ownerMinExt x - targetOwner width)) @ aRect height)]]. ownerMinExt y > self target owner height ifTrue: [self edgeName = #top ifTrue: [self target bounds: (aRect left @ (aRect top + (ownerMinExt y - targetOwner height)) extent: aRect width @ (aRect height - (ownerMinExt y - targetOwner height)))] ifFalse: [self target bounds: (aRect origin extent: aRect width @ (aRect height - (ownerMinExt y - targetOwner height)))]] ! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/25/2011 13:10'! defaultWidth "Answer the default width for the receiver." ^ProportionalSplitterMorph splitterWidth! ! !EdgeGripMorph methodsFor: 'event handling' stamp: 'GaryChambers 1/24/2011 13:11'! mouseDown: anEvent "Remember the receiver and target offsets too." |cp| (self bounds containsPoint: anEvent cursorPoint) ifTrue: [self fillStyle: self pressedFillStyle]. cp := anEvent cursorPoint. lastMouse := {cp. cp - self position. cp - self targetPoint}. self eventHandler ifNotNil: [self eventHandler mouseDown: anEvent fromMorph: self] ! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/25/2011 15:24'! targetPoint: aPoint "Set the reference point of the target." |minExt rect ownerMinExt| rect := self target bounds withSideOrCorner: self edgeName setToPoint: aPoint. minExt := (self target layoutPolicy notNil and: [self target layoutPolicy isTableLayout]) ifTrue: [self target layoutPolicy minExtentOf: self target in: self target layoutBounds] ifFalse: [self target minimumExtent]. rect width <= minExt x ifTrue: [ rect := self edgeName = #left ifTrue: [rect withSideOrCorner: #left setToPoint: self target bounds bottomRight - minExt] ifFalse: [rect withSideOrCorner: #right setToPoint: self target bounds topLeft + minExt]]. rect height <= minExt y ifTrue: [ rect := self edgeName = #top ifTrue: [rect withSideOrCorner: #top setToPoint: self target bounds bottomRight - minExt] ifFalse: [rect withSideOrCorner: #bottom setToPoint: self target bounds topLeft + minExt]]. self setTargetBounds: rect! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:03'! gripLayoutFrame "Answer the layout frame dependinbg on our edge." self edgeName == #top ifTrue: [^self topLayoutFrame]. self edgeName == #bottom ifTrue: [^self bottomLayoutFrame]. self edgeName == #left ifTrue: [^self leftLayoutFrame]. ^self rightLayoutFrame! ! !EdgeGripMorph methodsFor: 'accessing' stamp: 'gvc 2/12/2007 16:43'! target "Answer the value of target" ^ target! ! !EdgeGripMorph methodsFor: 'accessing' stamp: 'gvc 10/1/2007 13:03'! edgeName "Answer the value of edgeName" ^ edgeName! ! !EditableDropListMorph commentStamp: 'LaurentLaffont 3/31/2011 21:04'! I'm a DropListMorph which content can be modified. Try: (EditableDropListMorph on: [#(one two three)] list: #value selected: nil changeSelected: nil) openInWindow extent: 400@20.! !EditableDropListMorph methodsFor: 'protocol' stamp: 'alain.plantec 4/8/2009 10:41'! ghostText: aText self contentMorph ghostText: aText ! ! !EditableDropListMorph methodsFor: 'private' stamp: 'alain.plantec 10/20/2009 12:41'! addToListSel: aSelector addToListSel := aSelector! ! !EditableDropListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 3/14/2012 07:54'! newContentMorph "Answer a new content morph" | pt | pt := PluggableTextFieldMorph new convertTo: String; alwaysAccept: true; on: self text: #content accept: #content: readSelection: nil menu: nil; acceptOnCR: true; getEnabledSelector: nil; font: self theme textFont; cornerStyle: (self theme textEntryCornerStyleIn: self); hResizing: #spaceFill; vResizing: #spaceFill; borderStyle: (BorderStyle simple width: 0); color: Color white; hideScrollBarsIndefinitely; setBalloonText: nil. pt textMorph autoFit: true; wrapFlag: false; margins: self theme editableDropListMargins. ^ pt! ! !EditableDropListMorph methodsFor: 'private' stamp: 'JurajKubelka 12/27/2013 11:26'! updateContentMorphWith: aString content := aString. self contentMorph setText: aString! ! !EditableDropListMorph methodsFor: 'accessing' stamp: 'alain.plantec 4/9/2009 10:11'! converter ^ self contentMorph converter! ! !EditableDropListMorph methodsFor: 'private' stamp: 'alain.plantec 4/9/2009 10:12'! objectAsString: anObject ^ self converter objectAsString: anObject! ! !EditableDropListMorph methodsFor: 'private' stamp: 'alain.plantec 4/9/2009 11:03'! default: anObject self contentMorph default: anObject! ! !EditableDropListMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/17/2010 16:57'! adoptPaneColor: paneColor "Clear the fill style of the text." super adoptPaneColor: paneColor. self contentMorph fillStyle: Color transparent ! ! !EditableDropListMorph methodsFor: 'accessing' stamp: 'AlainPlantec 12/3/2009 06:33'! font: aFont "Set the list and content font" self listMorph font: aFont. self contentMorph font: aFont! ! !EditableDropListMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/13/2009 15:26'! content ^ content ! ! !EditableDropListMorph methodsFor: 'protocol' stamp: 'AlainPlantec 12/3/2009 09:10'! wantsFrameAdornments: aBoolean self contentMorph wantsFrameAdornments: aBoolean! ! !EditableDropListMorph methodsFor: 'layout' stamp: 'FernandoOlivero 4/12/2011 09:45'! minHeight "Answer the minimum height for the drop list." ^self theme textFont height + 7! ! !EditableDropListMorph methodsFor: 'private' stamp: 'alain.plantec 3/13/2009 18:21'! listHeight "Answer the height for the list." ^(self listMorph listMorph height + 12) min: 200! ! !EditableDropListMorph methodsFor: 'private' stamp: 'StephaneDucasse 9/7/2013 12:37'! layoutInsetToUse "Answer the layout inset that should be used." ^ 0! ! !EditableDropListMorph methodsFor: 'private' stamp: 'alain.plantec 3/13/2009 16:30'! convertTo: aClass self contentMorph convertTo: aClass ! ! !EditableDropListMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/17/2010 17:08'! enabled: aBoolean "Set the value of enabled" super enabled: aBoolean. self contentMorph enabled: aBoolean; fillStyle: Color transparent ! ! !EditableDropListMorph methodsFor: 'private' stamp: ''! defaultContents "needs nothing to activate the ghostText" ^ ''! ! !EditableDropListMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2011 19:06'! content: anObject content := anObject. self model perform: addToListSel with: content. self listSelectionIndex: (self list indexOf: content). self updateList! ! !EditableDropListMorph class methodsFor: 'as yet unclassified' stamp: 'alain.plantec 4/9/2009 09:56'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel useIndex: useIndex addToList: addToListSel class: aClass getEnabled: getEnabledSel ^ self on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel useIndex: useIndex addToList: addToListSel class: aClass getEnabled: getEnabledSel default: '' ! ! !EditableDropListMorph class methodsFor: 'as yet unclassified' stamp: 'alain.plantec 10/20/2009 12:41'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel useIndex: useIndex addToList: addToListSel class: aClass getEnabled: getEnabledSel default: aDefaultValue ^ (super on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel useIndex: useIndex) convertTo: aClass; getEnabledSelector: getEnabledSel; addToListSel: addToListSel; default: aDefaultValue; yourself! ! !EditableList commentStamp: ''! This widget allows you to edit a list of items : - add / remove an item to/from the list - order the list by moving elements up/down/top/bottom. The default behavior is to do a copy of the list. The widget works with its internal copy. It allows the user to accept / reject changes (for example by opening the widget in a DialogWindow) before affecting the original list. It is your responsability to copy EditableList items back to the original list. The addItemBlock is used to provide a way to give the item to add (e.g. a UIManager default chooseFrom: values:). Example: self example! !EditableList methodsFor: 'protocol' stamp: 'ChristopheDemarey 7/3/2013 18:16'! addItemBlock: aBlock addItemBlock := aBlock.! ! !EditableList methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/3/2013 18:06'! downButton ^ downButton! ! !EditableList methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/3/2013 18:06'! upButton ^ upButton! ! !EditableList methodsFor: 'accessing' stamp: 'ChristopheDemarey 6/27/2013 16:54'! removeButton ^ removeButton! ! !EditableList methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/26/2013 13:41'! topButton ^ topButton! ! !EditableList methodsFor: 'initialization' stamp: 'ChristopheDemarey 9/11/2013 09:59'! initializeWidgets self instantiateModels: #( list NewListModel addButton ButtonModel removeButton ButtonModel upButton ButtonModel downButton ButtonModel topButton ButtonModel bottomButton ButtonModel ). addButton icon: (Smalltalk ui icons iconNamed: #addIcon); help: 'Add a new item to the list'. removeButton icon: (Smalltalk ui icons iconNamed: #deleteIcon); help: 'Remove a item from the list'. upButton icon: (Smalltalk ui icons iconNamed: #upIcon); help: 'Move this item up from one element'. downButton icon: (Smalltalk ui icons iconNamed: #downIcon); help: 'Move this item down from one element'. topButton icon: (Smalltalk ui icons iconNamed: #topIcon); help: 'Move this item on the first position of the list'. bottomButton icon: (Smalltalk ui icons iconNamed: #bottomIcon); help: 'Move this item on the last position of the list'.! ! !EditableList methodsFor: 'initialization' stamp: 'ChristopheDemarey 10/18/2013 13:16'! initializeDialogWindow: aWindow super initializeDialogWindow: aWindow. aWindow okAction: [ self performOkAction ]! ! !EditableList methodsFor: 'private' stamp: 'ChristopheDemarey 10/18/2013 13:17'! performOkAction okBlock value! ! !EditableList methodsFor: 'private' stamp: 'ChristopheDemarey 9/10/2013 13:37'! moveElementAt: index to: newIndex | elementToMove orderedList | (newIndex < 1 or: [ newIndex > list getItems size ]) ifTrue: [ ^self ]. elementToMove := list getItems at: index. orderedList := list getItems asOrderedCollection removeAt: index; add: elementToMove beforeIndex: newIndex; yourself. self list: orderedList. self list setSelectedIndex: newIndex.! ! !EditableList methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize "Initialization code for EditableList" title := 'Title' asReactiveVariable. super initialize. okBlock := [ ].! ! !EditableList methodsFor: 'private' stamp: 'ChristopheDemarey 9/10/2013 10:16'! list: aList list items: aList.! ! !EditableList methodsFor: 'initialization' stamp: 'ChristopheDemarey 9/10/2013 17:18'! initializePresenter super initializePresenter addButton action: [ | requirement | requirement := addItemBlock value. requirement ifNotNil: [ self list: (self list getItems copyWith: requirement) ] ]. removeButton action: [ self list: (list getItems copyWithoutIndex: list selectedIndex) ]. topButton action: [ self moveElementAt: list selectedIndex to: 1 ]. bottomButton action: [ self moveElementAt: list selectedIndex to: list getItems size ]. upButton action: [ self moveElementAt: list selectedIndex to: list selectedIndex - 1]. downButton action: [ self moveElementAt: list selectedIndex to: list selectedIndex + 1]. ! ! !EditableList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! title ^ title value! ! !EditableList methodsFor: 'accessing' stamp: 'ChristopheDemarey 6/27/2013 16:48'! title: aTitle title := aTitle ! ! !EditableList methodsFor: 'protocol' stamp: 'ChristopheDemarey 10/18/2013 13:19'! okAction: aBlock okBlock := aBlock! ! !EditableList methodsFor: 'accessing' stamp: 'ChristopheDemarey 6/27/2013 16:54'! list ^ list! ! !EditableList methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/26/2013 13:41'! bottomButton ^ bottomButton! ! !EditableList methodsFor: 'accessing' stamp: 'ChristopheDemarey 6/27/2013 16:54'! addButton ^ addButton! ! !EditableList class methodsFor: 'instance creation' stamp: 'ChristopheDemarey 9/10/2013 10:25'! new: aCollection ^ self new list: aCollection copy. ! ! !EditableList class methodsFor: 'example' stamp: 'ChristopheDemarey 7/15/2013 17:07'! example | widget | widget := self new. widget title: 'Selectors list'; list: self selectors. widget openWithSpec.! ! !EditableList class methodsFor: 'spec' stamp: 'ChristopheDemarey 7/26/2013 13:47'! spec ^ SpecLayout composed newColumn: [ :column | column newRow: [ :menuRow | menuRow add: #addButton; add: #removeButton ] height: 25; newRow: [ :listRow | listRow newColumn: [ :c1 | c1 add: #list ]; newColumn: [ :c2 | c2 add: #topButton; add: #upButton; add: #downButton; add: #bottomButton ] width: 24 ] ] yourself! ! !EditingState commentStamp: 'StephaneDucasse 2/6/2011 09:56'! I store the current state of an editing session. An instance of mine is shared by all TextEditor instances that are created during an editing session managed by a TextMorph (see below for more explanations about editing session). The state data are basically made of an undo/redo manager and of all data needed in order to manage text editing undo and redo (mainly all informations for the current and previous selection intervals). I'm created by a TextEditor at the beginning of an editing session (see TextEditor>>editingStateClass and TextEditor>>editingState). Specializations can be introduced to fit a particular TextEditor subclass need. Editing session: An editing session starts when a TextMorph is created (precisely, when a TextEditor instance is first assigned to a TextMorph editor instance variable). An editing session ends when a TextMorph is deleted. During an editing session, a TextMorph can make use of a lot of TextEditor instances, one at a time. As an example, each time a TextMorph is resized, its editor is released and a new one that fit the TextMorph physical properties is created. Another example, when a TextMorph loses the keyboard focus, then its editor could be fully released; it is created again when the TextMorph retrieves the focus. When an editor is created by a TextMorph, the state of the previous TextEditor, stored in its associated EditingState instance, is got and passed to the newly created editor. Thus the editing session remains stable (see TextEditor >> #stateArray and TextMorph >> #installEditorToReplace:). So TextEditor instances are extremely volatile whereas its associated EditingState instance remains during the whole editing session. Instance Variables: emphasisHere pointBlock markBlock startOfTyping previousInterval previousSelection undoManager lastParenLocation mouseDownInterval secondarySelectionToken ** obsolete ** should be removed ** - emphasisHere: The TextAttributes that are used for the newly entered text - pointBlock: The CharacterBlock where a selection begins (where the mouse has first pointed) - markBlock: The CharacterBlock where a selection ends - startOfTyping: The index of the first character which has been entered during the currently undoable/redoable portion of text (see TextEditor>>#openTypeIn and TextEditor>>#doneTyping) - previousInterval: Previous interval used for undo/redo actions - previousSelection: The previously selected text for undo/redo actions - undoManager: The undo/redo manager - lastParenLocation: Keep the position of the open parenthesis which corresponds to the last entered close parenthesis - mouseDownInterval: The position of the first mouse down in the editor ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 2/11/2011 15:51'! emphasisHere: aListOfTextAttribute emphasisHere := aListOfTextAttribute ifNotNil: [:l | l reject: [:a | TextSelectionColor = a class]]! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! lastParenLocation ^ lastParenLocation! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! markBlock: aCharacterBlock markBlock := aCharacterBlock! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! pointBlock: aCharacterBlock pointBlock := aCharacterBlock. ! ! !EditingState methodsFor: 'undo-redo' stamp: 'AlainPlantec 11/9/2010 15:04'! addUndoRecord: anUndoRecord self undoManager isPlugged ifTrue: [self undoManager clearRedoHistory. self undoManager addRecord: anUndoRecord] ! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! startOfTyping ^ startOfTyping! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! emphasisHere ^ emphasisHere! ! !EditingState methodsFor: 'events' stamp: 'AlainPlantec 11/19/2010 10:45'! focused: aBoolean from: aTextMorph (aBoolean and: [aTextMorph sharesFindReplace]) ifTrue: [[(EditorFindReplaceDialogWindow on: aTextMorph) comeToFront] on: Error do: []].! ! !EditingState methodsFor: 'undo-redo' stamp: 'AlainPlantec 11/9/2010 15:04'! redo ^ self undoManager redo ! ! !EditingState methodsFor: 'events' stamp: 'AlainPlantec 11/15/2010 09:54'! handlesKeyboard: evt from: aTextMorph ^ false! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 15:03'! secondarySelectionToken ^ secondarySelectionToken ! ! !EditingState methodsFor: 'events' stamp: 'AlainPlantec 11/19/2010 10:46'! mouseDown: anEvent from: aTextMorph self mouseDownInterval: aTextMorph editor selectionInterval. self focused: true from: aTextMorph ! ! !EditingState methodsFor: 'undo-redo' stamp: 'AlainPlantec 12/13/2010 22:48'! clearUndoManager: aKeyboardEvent self undoManager reset. ^ true! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! mouseDownInterval: anInterval mouseDownInterval := anInterval! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! startOfTyping: anIntegerIndex startOfTyping := anIntegerIndex! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! markBlock ^ markBlock! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 13:09'! undoManager ^ undoManager ifNil: [ undoManager := HistoryIterator new]. ! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! mouseDownInterval ^ mouseDownInterval! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 14:45'! secondarySelectionToken: aTextOrStringOrRegex secondarySelectionToken := (aTextOrStringOrRegex isText ifTrue: [aTextOrStringOrRegex asString] ifFalse: [aTextOrStringOrRegex])! ! !EditingState methodsFor: 'undo-redo' stamp: 'AlainPlantec 11/9/2010 15:04'! undo ^ self undoManager undo ! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! lastParenLocation: anIntegerIndex lastParenLocation := anIntegerIndex! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! previousInterval ^ previousInterval ifNil: [previousInterval := 1 to: 0]! ! !EditingState methodsFor: 'private-debugging' stamp: 'AlainPlantec 11/9/2010 15:04'! exploreUndoManager: aKeyboardEvent self undoManager explore. ^ true! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! previousSelection ^ previousSelection ifNil: [previousSelection := '' asText]! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! previousInterval: anInterval selection: aSelection previousInterval := anInterval. previousSelection := aSelection. ! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! pointBlock ^ pointBlock! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! unselect self markBlock: self pointBlock copy! ! !EditingState methodsFor: 'events' stamp: 'AlainPlantec 11/22/2010 12:03'! keystroke: aKeyboardEvent from: aTextMorph ! ! !EditingState methodsFor: 'undo-redo' stamp: 'AlainPlantec 12/14/2010 14:42'! redoArray: doArray undoArray: undoArray self undoManager isPlugged ifTrue: [self undoManager redoArray: doArray undoArray: undoArray]! ! !Editor commentStamp: 'AlainPlantec 11/2/2010 18:23'! New text editors. TextEditor provides most of the functionality that used to be in TextMorphEditor. This class is no longer a Controller!! SmalltalkEditor has Smalltalk code specific features. SimpleEditor provides basic functionality for single line text editing. It does not handle fonts and styles, aligning and Smalltalk utilities. It handles one single line. ! !Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! escape: aKeyboardEvent self morph escapePressed. ^ false ! ! !Editor methodsFor: 'accessing' stamp: 'FernandoOlivero 6/9/2011 16:07'! markBlock: aCharacterBlock self editingState markBlock: aCharacterBlock! ! !Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! escape self morph escapePressed . ! ! !Editor methodsFor: 'new selection' stamp: 'AlainPlantec 2/7/2011 09:12'! selectInvisiblyAt: characterIndex "Place the caret before the character at characterIndex. Be sure it is in view but vithout any further action." self selectInvisiblyFrom: characterIndex to: characterIndex - 1 ! ! !Editor methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme ^ Smalltalk ui theme ! ! !Editor methodsFor: 'new selection' stamp: 'AlainPlantec 11/8/2010 22:08'! selectMark: mark point: point "Select the specified characters inclusive. Be sure the selection is in view." (mark = self markIndex and: [point + 1 = self pointIndex]) ifFalse: [self deselect. self selectInvisiblyMark: mark point: point]! ! !Editor methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:08'! morph ^ morph! ! !Editor methodsFor: 'testing' stamp: 'AlainPlantec 11/8/2010 22:08'! isTextEditor ^ false ! ! !Editor methodsFor: 'new selection' stamp: 'AlainPlantec 11/8/2010 22:08'! selectInvisiblyFrom: start to: stop "Select the designated characters, inclusive. Make no visual changes." self markIndex: start; pointIndex: stop + 1! ! !Editor methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:08'! currentAttributes "Redefined by subclasses that handle TextAttributes" ^nil! ! !Editor methodsFor: 'menu messages' stamp: 'AlainPlantec 11/8/2010 22:08'! lineSelectAndEmptyCheck: returnBlock "If the current selection is an insertion point, expand it to be the entire current line; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this." self selectLine. "if current selection is an insertion point, then first select the entire line in which occurs before proceeding" self hasSelection ifFalse: [morph flash. ^ returnBlock value]! ! !Editor methodsFor: 'editing keys' stamp: 'AlainPlantec 11/8/2010 22:08'! noop: aKeyboardEvent "Unimplemented keyboard command; just ignore it." ^ true! ! !Editor methodsFor: 'typing/selecting keys' stamp: 'CamilloBruni 8/1/2012 16:16'! selectAll: aKeyboardEvent "select everything" self closeTypeIn. self selectFrom: 1 to: self string size. ^ true! ! !Editor methodsFor: 'editing keys' stamp: 'AlainPlantec 11/8/2010 22:08'! cut: aKeyboardEvent "Cut out the current text selection." self cut. ^true! ! !Editor methodsFor: 'new selection' stamp: 'AlainPlantec 11/8/2010 22:08'! selectInvisiblyMark: mark point: point "Select the designated characters, inclusive. Make no visual changes." self markIndex: mark; pointIndex: point + 1! ! !Editor methodsFor: 'editing keys' stamp: 'AlainPlantec 11/8/2010 22:08'! copySelection: aKeyboardEvent "Copy the current text selection." self copySelection. ^true! ! !Editor methodsFor: 'testing' stamp: 'AlainPlantec 11/8/2010 22:08'! isSimpleEditor ^ false ! ! !Editor methodsFor: 'private' stamp: 'CamilloBruni 6/21/2012 18:27'! moveCursor: directionBlock forward: forward specialBlock: specialBlock event: aKeyboardEvent "Private - Move cursor. directionBlock is a one argument Block that computes the new Position from a given one. specialBlock is a one argumentBlock that computes the new position from a given one under the alternate semantics. Note that directionBlock always is evaluated first." | shift indices newPosition | self morph manageCursor. shift := aKeyboardEvent shiftPressed. indices := self setIndices: shift forward: forward. newPosition := directionBlock value: (indices at: #moving). (aKeyboardEvent commandKeyPressed or: [ aKeyboardEvent controlKeyPressed ]) ifTrue: [newPosition := specialBlock value: newPosition]. shift ifTrue: [self selectMark: (indices at: #fixed) point: newPosition - 1] ifFalse: [self selectAt: newPosition]! ! !Editor methodsFor: 'nonediting/nontyping keys' stamp: 'IgorStasenko 10/7/2013 11:31'! cursorLeft: aKeyboardEvent "Private - Move cursor left one character if nothing selected, otherwise move cursor to beginning of selection. If the shift key is down, start selecting or extending current selection. Don't allow cursor past beginning of text" self closeTypeIn. self moveCursor:[:position | self class skipOverMultipleSpaces ifTrue: [ self previousNonBlank: position ] ifFalse: [ position - 1 max: 1 ] ] forward: false specialBlock:[:position | self previousWord: position] event: aKeyboardEvent. ^ true! ! !Editor methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:08'! cmdKeysInText ^ self class cmdKeysInText! ! !Editor methodsFor: 'testing' stamp: 'AlainPlantec 11/8/2010 22:08'! isSmalltalkEditor ^ false ! ! !Editor methodsFor: 'private' stamp: 'AlainPlantec 11/8/2010 22:08'! setIndices: shiftPressed forward: forward "Little helper method that sets the moving and fixed indices according to some flags." | indices | indices := Dictionary new. self flag: 'to be reviewed'. (shiftPressed) ifTrue: [ indices at: #moving put: self pointIndex. indices at: #fixed put: self markIndex ] ifFalse: [ forward ifTrue:[ indices at: #moving put: self stopIndex. indices at: #fixed put: self startIndex. ] ifFalse: [ indices at: #moving put: self startIndex. indices at: #fixed put: self stopIndex. ] ]. ^indices! ! !Editor methodsFor: 'nonediting/nontyping keys' stamp: 'IgorStasenko 10/7/2013 11:30'! cursorRight: aKeyboardEvent "Private - Move cursor right one character if nothing selected, otherwise move cursor to end of selection. If the shift key is down, start selecting characters or extending already selected characters. Don't allow cursor past end of text" self closeTypeIn. self moveCursor: [:position | self class skipOverMultipleSpaces ifTrue: [ self nextNonBlank: position ] ifFalse: [ position + 1 ] ] forward: true specialBlock:[:position | self nextWord: position] event: aKeyboardEvent. ^ true! ! !Editor methodsFor: 'accessing-selection' stamp: 'jmv 11/4/2008 14:02'! unselect self markIndex: self pointIndex! ! !Editor methodsFor: 'new selection' stamp: 'AlainPlantec 11/8/2010 22:08'! selectInterval: anInterval "Select the specified characters inclusive. Be sure the selection is in view." self selectFrom: anInterval first to: anInterval last! ! !Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! cursorDown: aKeyboardEvent "Private - Move cursor from position in current line to same position in next line. If next line too short, put at end. If shift key down, select." self closeTypeIn. self moveCursor:[:position | self sameColumn: position newLine:[:line | line + 1] forward: true] forward: true specialBlock:[:dummy | dummy] event: aKeyboardEvent. ^true! ! !Editor methodsFor: 'new selection' stamp: 'AlainPlantec 11/8/2010 22:08'! selectWord "Select delimited text or word--the result of double-clicking." | openDelimiter closeDelimiter direction match level leftDelimiters rightDelimiters string here hereChar start stop | string := self string. here := self pointIndex. (here between: 2 and: string size) ifFalse: ["if at beginning or end, select entire string" ^self selectFrom: 1 to: string size]. leftDelimiters := '([{<''" '. rightDelimiters := ')]}>''" '. openDelimiter := string at: here - 1. match := leftDelimiters indexOf: openDelimiter. match > 0 ifTrue: ["delimiter is on left -- match to the right" start := here. direction := 1. here := here - 1. closeDelimiter := rightDelimiters at: match] ifFalse: [openDelimiter := string at: here. match := rightDelimiters indexOf: openDelimiter. match > 0 ifTrue: ["delimiter is on right -- match to the left" stop := here - 1. direction := -1. closeDelimiter := leftDelimiters at: match] ifFalse: ["no delimiters -- select a token" direction := -1]]. level := 1. [level > 0 and: [direction > 0 ifTrue: [here < string size] ifFalse: [here > 1]]] whileTrue: [hereChar := string at: (here := here + direction). match = 0 ifTrue: ["token scan goes left, then right" hereChar tokenish ifTrue: [here = 1 ifTrue: [start := 1. "go right if hit string start" direction := 1]] ifFalse: [direction < 0 ifTrue: [start := here + 1. "go right if hit non-token" direction := 1] ifFalse: [level := 0]]] ifFalse: ["bracket match just counts nesting level" hereChar = closeDelimiter ifTrue: [level := level - 1"leaving nest"] ifFalse: [hereChar = openDelimiter ifTrue: [level := level + 1"entering deeper nest"]]]]. level > 0 ifTrue: ["in case ran off string end" here := here + direction]. direction > 0 ifTrue: [self selectFrom: start to: here - 1] ifFalse: [self selectFrom: here + 1 to: stop]! ! !Editor methodsFor: 'typing/selecting keys' stamp: 'AlainPlantec 11/8/2010 22:08'! selectAll self selectFrom: 1 to: self string size! ! !Editor methodsFor: 'private' stamp: 'IgorStasenko 10/7/2013 11:31'! previousNonBlank: position "decrement position up until any non-blank character found, or end of line" | string index | position <= 1 ifTrue: [ ^ 1 ]. string := self string. index := position. index := index -1. (string at: index) isSeparator ifFalse: [ ^ index ]. [ index > 1 and: [(string at: index-1) isSeparator and: [(string at:index-1) ~= Character cr]]] whileTrue: [index := index - 1]. ^ index! ! !Editor methodsFor: 'typing/selecting keys' stamp: 'AlainPlantec 11/8/2010 22:08'! lf: aKeyboardEvent "Append a line feed character to the stream of characters." self addString: Character lf asString. ^false! ! !Editor methodsFor: 'private' stamp: 'AlainPlantec 11/8/2010 22:08'! lines "Compute lines based on logical line breaks, not optical (which may change due to line wrapping of the editor). Subclasses using kinds of Paragraphs can instead use the service provided by it. " | lines string index lineIndex stringSize | string := self string. "Empty strings have no lines at all. Think of something." string isEmpty ifTrue:[^{#(1 0 0)}]. stringSize := string size. lines := OrderedCollection new: (string size // 15). index := 0. lineIndex := 0. string linesDo:[:line | lines addLast: (Array with: (index := index + 1) with: (lineIndex := lineIndex + 1) with: (index := index + line size min: stringSize))]. "Special workaround for last line empty." string last == Character cr "lines last last < stringSize" ifTrue:[lines addLast:{stringSize +1. lineIndex+1. stringSize}]. ^lines! ! !Editor methodsFor: 'typing/selecting keys' stamp: 'AlainPlantec 11/8/2010 22:08'! backWord: aKeyboardEvent "If the selection is not a caret, delete it and leave it in the backspace buffer. Else, delete the word before the caret." | startIndex | self hasCaret ifTrue: [ "a caret, delete at least one character" startIndex := 1 max: self markIndex - 1. [startIndex > 1 and: [(self string at: startIndex - 1) tokenish]] whileTrue: [ startIndex := startIndex - 1]] ifFalse: [ "a non-caret, just delete it" startIndex := self markIndex]. self backTo: startIndex. ^false! ! !Editor methodsFor: 'private' stamp: 'AlainPlantec 11/8/2010 22:08'! nextWord: position | string index | string := self string. index := position. [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]] whileTrue: [index := index + 1]. [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]] whileTrue: [index := index + 1]. ^ index! ! !Editor methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:08'! userHasEdited "Note that my text is free of user edits." morph notNil ifTrue:[ morph hasUnacceptedEdits: true ]! ! !Editor methodsFor: 'typing/selecting keys' stamp: 'AlainPlantec 11/8/2010 22:08'! normalCharacter: aKeyboardEvent "A nonspecial character is to be added to the stream of characters." self addString: aKeyboardEvent keyCharacter asString. ^false! ! !Editor methodsFor: 'menu messages' stamp: 'AlainPlantec 11/8/2010 22:08'! clipboardText ^ Clipboard clipboardText! ! !Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! cursorPageUp: aKeyboardEvent self closeTypeIn. self moveCursor: [:position | self sameColumn: position newLine: [:lineNo | lineNo - self pageHeight] forward: false] forward: false specialBlock:[:dummy | dummy] event: aKeyboardEvent. ^true! ! !Editor methodsFor: 'typing/selecting keys' stamp: 'AlainPlantec 11/8/2010 22:08'! cursorTopHome: aKeyboardEvent "Put cursor at beginning of text -- invoked from cmd-H shortcut, useful for keyboards that have no home key." self selectAt: 1. ^ true! ! !Editor methodsFor: 'private' stamp: 'IgorStasenko 3/10/2012 23:57'! nextNonBlank: position "if current position is not separator, advance by 1, otherwise advance up until non-separator char found or new line" | string index | string := self string. index := position. index >= string size ifTrue: [ ^ string size+1 ]. (string at: index) isSeparator ifFalse: [ ^ index + 1 ]. index := index + 1. [ index <= string size and: [(string at: index) isSeparator and: [(string at:index) ~= Character cr]]] whileTrue: [index := index + 1]. ^ index! ! !Editor methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:08'! morph: aMorph "Install a link back to the morph being edited (esp for text links)" morph := aMorph ! ! !Editor methodsFor: 'private' stamp: 'AlainPlantec 11/8/2010 22:08'! previousWord: position | string index | string := self string. index := position. [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]] whileTrue: [index := index - 1]. [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]] whileTrue: [index := index - 1]. ^ index + 1! ! !Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! selectWord: aKeyboardEvent self closeTypeIn. self selectWord. ^ true! ! !Editor methodsFor: 'current selection' stamp: 'AlainPlantec 11/8/2010 22:08'! deselect "If the text selection is visible on the screen, reverse its highlight." " ***** screw this logic ***** selectionShowing ifTrue: [self reverseSelection] "! ! !Editor methodsFor: 'accessing-selection' stamp: 'AlainPlantec 11/8/2010 22:08'! selectionInterval "Answer the interval that is currently selected." ^self startIndex to: self stopIndex - 1 ! ! !Editor methodsFor: 'editing keys' stamp: 'AlainPlantec 11/8/2010 22:08'! paste: aKeyboardEvent "Replace the current text selection by the text in the shared buffer." self closeTypeIn. self paste. ^true! ! !Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! cursorPageDown: aKeyboardEvent self closeTypeIn. self moveCursor: [:position | self sameColumn: position newLine: [:lineNo | lineNo + self pageHeight] forward: true] forward: true specialBlock:[:dummy | dummy] event: aKeyboardEvent. ^true! ! !Editor methodsFor: 'menu messages' stamp: 'AlainPlantec 11/8/2010 22:08'! clipboardTextPut: text ^ Clipboard clipboardText: text! ! !Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! cursorUp: aKeyboardEvent "Private - Move cursor from position in current line to same position in prior line. If prior line too short, put at end" self closeTypeIn. self moveCursor: [:position | self sameColumn: position newLine:[:line | line - 1] forward: false] forward: false specialBlock:[:dummy | dummy] event: aKeyboardEvent. ^true! ! !Editor methodsFor: 'menu messages' stamp: 'AlainPlantec 11/8/2010 22:08'! paste "Paste the text from the shared buffer over the current selection and redisplay if necessary. Undoer & Redoer: undoAndReselect." self replace: self selectionInterval with: self clipboardText and: [self selectAt: self pointIndex]! ! !Editor methodsFor: 'accessing-selection' stamp: 'AlainPlantec 11/8/2010 22:08'! hasSelection ^self hasCaret not! ! !Editor methodsFor: 'typing/selecting keys' stamp: 'AlainPlantec 11/12/2010 22:05'! backspace: aKeyboardEvent "Backspace over the last character." | startIndex | aKeyboardEvent shiftPressed ifTrue: [^ self backWord: aKeyboardEvent keyCharacter]. self hasSelection ifTrue: [self replaceSelectionWith: self nullText] ifFalse: [startIndex := self markIndex + (self hasCaret ifTrue: [0] ifFalse: [1]). startIndex := 1 max: startIndex - 1. self backTo: startIndex]. ^false! ! !Editor methodsFor: 'new selection' stamp: 'AlainPlantec 11/8/2010 22:08'! selectAt: characterIndex "Place the caret before the character at characterIndex. Be sure it is in view." self selectFrom: characterIndex to: characterIndex - 1! ! !Editor methodsFor: 'current selection' stamp: 'AlainPlantec 11/8/2010 22:08'! select "If the text selection is visible on the screen, reverse its highlight." ^'Not doing anything' "screw this logic selectionShowing ifFalse: [self reverseSelection]"! ! !Editor methodsFor: 'typing/selecting keys' stamp: 'AlainPlantec 11/8/2010 22:08'! crlf: aKeyboardEvent "Append a line feed character to the stream of characters." self addString: String crlf. ^false! ! !Editor methodsFor: 'testing' stamp: 'AlainPlantec 11/8/2010 22:08'! hasError ^ false ! ! !Editor class methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:08'! blinkingCursor ^ BlinkingCursor ifNil: [ BlinkingCursor := true ]! ! !Editor class methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:08'! blinkingCursor: aBoolean BlinkingCursor := aBoolean! ! !Editor class methodsFor: 'private accessing' stamp: 'AlainPlantec 11/8/2010 22:08'! specialShiftCmdKeys "Private - return array of key codes that represent single keys acting as if shift-command were also being pressed" ^#( 1 "home" 3 "enter" 4 "end" 8 "backspace" 11 "page up" 12 "page down" 27 "escape" 28 "left arrow" 29 "right arrow" 30 "up arrow" 31 "down arrow" 127 "delete" )! ! !Editor class methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:08'! dumbbellCursor: aBoolean DumbbellCursor := aBoolean! ! !Editor class methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:08'! dumbbellCursor ^ DumbbellCursor ifNil: [ DumbbellCursor := false ]! ! !Editor class methodsFor: 'settings' stamp: 'IgorStasenko 10/7/2013 11:22'! skipOverMultipleSpaces ^ SkipOverMultipleSpaces ifNil: [ SkipOverMultipleSpaces := false ]! ! !Editor class methodsFor: 'settings' stamp: 'IgorStasenko 10/7/2013 11:22'! skipOverMultipleSpaces: aBoolean SkipOverMultipleSpaces := aBoolean! ! !Editor class methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:08'! cmdKeysInText: aBoolean CmdKeysInText := aBoolean! ! !Editor class methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:08'! cmdKeysInText ^ CmdKeysInText ifNil: [CmdKeysInText := true]! ! !EditorFindReplaceDialogWindow commentStamp: 'TorstenBergmann 1/31/2014 12:21'! A find/replace dialog window for editors! !EditorFindReplaceDialogWindow methodsFor: 'updating' stamp: 'AlainPlantec 11/27/2010 23:38'! newFinding | t | (t := self findText asString) ifEmpty: [^ self ]. (self prevFinds includes: t) ifFalse: [self prevFinds addFirst: t]. self prevFinds size > self maxPreviousListSize ifTrue: [self prevFinds removeLast]! ! !EditorFindReplaceDialogWindow methodsFor: 'action' stamp: 'AlainPlantec 12/3/2010 09:42'! cancel self state findText: ''. super cancel! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:35'! maxPreviousListSize ^ self class maxPreviousListSize! ! !EditorFindReplaceDialogWindow methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 12/3/2010 09:46'! aboutText ^ 'This dialog can be opened with in an editable text area or from the text area contextual menu. Previous find and replace tokens are kept so that you can directly retrieve them from the find and the replace input fields. While you enter a find token in the find field, in the currently edited text, all matching text portions are dynamically enlighted with the find selection color (orange color by default). The find token is shared by all text editing areas. You can also set it with the keyboard by using the shortcut after having selected the portion of text you want to find. Then, you can find the next matching portion of text by using the shortcut. In order to get rid of the current find token, just enter with nothing selected or just cancel this dialog. The colorization is manageable with the settings browser from where you can completely disallow it or change the selection color'! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/10/2010 23:56'! replaceAllEnabled ^ self model notNil and: [self findText notEmpty]! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:19'! replaceText ^ self state replaceText! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:36'! prevReplacements ^ self class replacements! ! !EditorFindReplaceDialogWindow methodsFor: '*Polymorph-Widgets' stamp: 'GaryChambers 8/23/2011 13:26'! initialize "Set the initial position based on usable screen area." super initialize. self position: RealEstateAgent maximumUsableArea topLeft! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:18'! findText ^ self state findText! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/9/2010 17:24'! newButtons "Answer new buttons as appropriate." ^{self newFindButton isDefault: true. self newReplaceButton. self newReplaceAllButton. self newCancelButton}! ! !EditorFindReplaceDialogWindow methodsFor: 'updating' stamp: 'AlainPlantec 11/12/2010 12:10'! on: aTextView (model isNil or: [model ~= aTextView]) ifTrue: [self findText: self findText. self model: aTextView. self changed: #findText. self changed: #caseSensitive. self changed: #replaceEnabled. self owner ifNotNil: [self findText: self findText]]. ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:25'! caseSensitive: aBoolean self state caseSensitive: aBoolean. ! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/16/2010 09:51'! taskbarButtonFor: aTaskBar "No taskbar button because always on top" ^nil! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:20'! caseSensitive ^ self state caseSensitive! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/10/2010 22:13'! newReplaceAllButton ^ (self theme newButtonIn: self for: self getState: nil action: #replaceAll arguments: nil getEnabled: #replaceAllEnabled label: 'Replace all' translated help: 'Replace all occurences' translated) hResizing: #rigid; vResizing: #rigid! ! !EditorFindReplaceDialogWindow methodsFor: 'action' stamp: 'AlainPlantec 12/3/2010 09:49'! open self openAsIsIn: World. self extent: self extent. self activate ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 12/3/2010 09:38'! findText: aStringOrText self state findText: aStringOrText. ^ true ! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/17/2010 16:26'! findTextFieldMorph ^self findDeepSubmorphThat: [:m | (m isKindOf: PluggableTextFieldMorph) and: [m getTextSelector = #findText]] ifAbsent: [] ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:21'! entireWordsOnly ^ self state entireWordsOnly! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/8/2010 22:33'! newReplaceButton ^ (self theme newButtonIn: self for: self getState: nil action: #replace arguments: nil getEnabled: #replaceEnabled label: 'Replace' translated help: 'Replace the next occurence' translated) hResizing: #rigid; vResizing: #rigid! ! !EditorFindReplaceDialogWindow methodsFor: 'updating' stamp: 'AlainPlantec 11/26/2010 18:11'! findPolicyChanged self changed: #findText. self findTextFieldMorph textColor: Color black. self changed: #caseSensitive. self changed: #isRegex. self changed: #entireWordsOnly. self changed: #findEnabled. self changed: #replaceText. self changed: #replaceEnabled. self changed: #replaceAllEnabled. self model ifNotNil: [self model selectionChanged]. ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:21'! isRegex ^ self state isRegex! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/27/2010 13:41'! newContentMorph ^(self newColumn: { (self newGroupbox: nil for: (self newColumn: { self newFindTextEntryMorph. (self newRow: { (self newColumn: { (self newCheckboxFor: self getSelected: #isRegex setSelected: #isRegex: getEnabled: nil label: 'Regular expression' translated help: nil). (self newCheckboxFor: self getSelected: #caseSensitive setSelected: #caseSensitive: getEnabled: nil label: 'Case sensitive' translated help: nil). (self newCheckboxFor: self getSelected: #entireWordsOnly setSelected: #entireWordsOnly: getEnabled: nil label: 'Entire words only' translated help: nil) } ). (self newColumn: { (self newCheckboxFor: self getSelected: #searchBackwards setSelected: #searchBackwards: getEnabled: nil label: 'Search backwards' translated help: nil). (self newCheckboxFor: self getSelected: #wrapAround setSelected: #wrapAround: getEnabled: nil label: 'Wrap around' translated help: nil) } ) } ) } ) ). (self newLabelGroup: {'Replace with: ' translated -> self newReplaceTextEntryMorph}) vResizing: #shrinkWrap} ) ! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 4/27/2011 15:19'! replaceEnabled ^ self model notNil and: [self findText notEmpty]! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/23/2010 15:20'! replaceText: aStringOrText self state replaceText: aStringOrText asString. ^ true ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:25'! isRegex: aBoolean self state isRegex: aBoolean. ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 22:19'! wrapAround: aBoolean self state wrapAround: aBoolean. ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:36'! prevFinds ^ self class finds! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/8/2010 22:33'! newFindButton ^(self theme newButtonIn: self for: self getState: nil action: #find arguments: nil getEnabled: #findEnabled label: 'Find' translated help: 'Find the next occurence' translated) hResizing: #rigid; vResizing: #rigid! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/11/2010 22:58'! title ^ 'Find & Replace' translated. ! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/23/2010 14:40'! defaultButton "Answer the default button." ^self findDeepSubmorphThat: [:m | (m isKindOf: PluggableButtonMorph) and: [m actionSelector = #find]] ifAbsent: [] ! ! !EditorFindReplaceDialogWindow methodsFor: 'action' stamp: 'AlainPlantec 4/27/2011 13:35'! replace self newReplacement. self state replaceInTextMorph: self model. self find! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'EstebanLorenzano 5/14/2013 09:44'! buildWindowMenu "Build and answer the window menu." | aMenu | aMenu := self theme newMenuIn: self for: self. aMenu addToggle: 'Close' translated target: self selector: #closeBoxHit getStateSelector: nil enablementSelector: #allowedToClose. aMenu lastItem icon: self theme windowCloseForm. aMenu addLine. aMenu add: 'About' translated action: #showAbout. aMenu lastItem icon: Smalltalk ui icons smallHelpIcon. ^aMenu! ! !EditorFindReplaceDialogWindow methodsFor: 'action' stamp: 'AlainPlantec 11/21/2010 22:00'! replaceAll self model takeKeyboardFocus. self state replaceAllInTextMorph: self model! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 22:19'! searchBackwards: aBoolean self searchBackwards = aBoolean ifFalse: [self state searchBackwards: aBoolean. self state updateFindStartIndexForTextMorph: self model]! ! !EditorFindReplaceDialogWindow methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 12/3/2010 09:02'! removeBoxes "Remove all label area boxes." expandBox ifNotNil: [expandBox delete. expandBox := nil]. collapseBox ifNotNil: [collapseBox delete. collapseBox := nil]! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/27/2010 13:42'! initialExtent ^ 400 @ super initialExtent y! ! !EditorFindReplaceDialogWindow methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon ^ Smalltalk ui icons smallFindIcon! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:14'! state: aFindReplaceService state ifNotNil: [state removeDependent: self]. state := aFindReplaceService. state ifNotNil: [state addDependent: self]. ! ! !EditorFindReplaceDialogWindow methodsFor: 'updating' stamp: 'AlainPlantec 11/26/2010 18:12'! update: aSymbol | si | model ifNotNil: [ aSymbol = #regexError ifTrue: [self findTextFieldMorph textColor: Color red]. aSymbol = #newFinding ifTrue: [^ self newFinding]. aSymbol = #findPolicy ifTrue: [self findPolicyChanged]. aSymbol = #findReplaceSelection ifTrue: [self changed: #replaceEnabled. self state updateFindStartIndexForTextMorph: self model]]. super update: aSymbol! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/8/2010 22:33'! extent: anExtent ^ super extent: anExtent x @ self initialExtent y! ! !EditorFindReplaceDialogWindow methodsFor: 'updating' stamp: 'AlainPlantec 11/27/2010 23:38'! newReplacement | t | (t := self replaceText asString) ifEmpty: [^ self ]. (self prevReplacements includes: t) ifFalse: [self prevReplacements addFirst: t]. self prevReplacements size > self maxPreviousListSize ifTrue: [self prevReplacements removeLast]! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 17:28'! wrapAround ^ self state wrapAround ! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/8/2010 22:33'! isResizeable "Answer whether we are not we can be resized." ^true! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'EstebanLorenzano 8/17/2012 16:41'! newFindTextEntryMorph | entryCompletion pt | entryCompletion := EntryCompletion new dataSourceBlock: [:currText | self prevFinds ]; filterBlock: [:currApplicant :currText | currText size = 0 or: [currApplicant asUppercase includesSubstring: currText asString asUppercase]]. pt := (self newAutoAcceptTextEntryFor: self get: #findText set: #findText: class: String getEnabled: nil help: 'Enter the text to find' translated entryCompletion: entryCompletion) acceptOnCR: false; ghostText: 'Text to find'; withDropListButton; crAction: [:t | self find]; yourself. pt textMorph autoFit: true; wrapFlag: false; margins: (2@1 corner: 2@1). ^ pt ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:25'! entireWordsOnly: aBoolean self state entireWordsOnly: aBoolean. ! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/17/2010 15:57'! findEnabled ^ self findString isEmptyOrNil not ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:16'! state ^ state ifNil: [self state: FindReplaceService new]! ! !EditorFindReplaceDialogWindow methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 12/3/2010 09:05'! aboutTitle ^ 'Find & replace dialog'! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/27/2010 16:46'! defaultFocusMorph ^ self findTextFieldMorph textMorph! ! !EditorFindReplaceDialogWindow methodsFor: 'action' stamp: 'AlainPlantec 11/28/2010 09:41'! find self newFinding. ^ self state findInTextMorph: self model! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:57'! findString ^ self state findString! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'EstebanLorenzano 8/17/2012 16:40'! newReplaceTextEntryMorph | entryCompletion pt | entryCompletion := EntryCompletion new dataSourceBlock: [:currText | self prevReplacements ]; filterBlock: [:currApplicant :currText | currText size = 0 or: [currApplicant asUppercase includesSubstring: currText asString asUppercase]]. pt := (self newAutoAcceptTextEntryFor: self get: #replaceText set: #replaceText: class: String getEnabled: nil help: 'Enter the replacement text' translated entryCompletion: entryCompletion) acceptOnCR: true; crAction: [:t | self replace]; withDropListButton; yourself. pt textMorph autoFit: true; wrapFlag: false; margins: (2@1 corner: 2@1). ^ pt ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:22'! searchBackwards ^ self state searchBackwards! ! !EditorFindReplaceDialogWindow class methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:35'! finds ^ Finds ifNil: [Finds := OrderedCollection new]! ! !EditorFindReplaceDialogWindow class methodsFor: 'initializing' stamp: 'MarcusDenker 10/15/2013 10:36'! initialize "EditorFindReplaceDialogWindow initialize" Singleton := nil.! ! !EditorFindReplaceDialogWindow class methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:35'! replacements ^ Replacements ifNil: [Replacements := OrderedCollection new]! ! !EditorFindReplaceDialogWindow class methodsFor: 'instance creation' stamp: 'AlainPlantec 11/11/2010 19:26'! singleton ^ Singleton ifNil: [Singleton := self new]. ! ! !EditorFindReplaceDialogWindow class methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:35'! maxPreviousListSize ^ 15! ! !EditorFindReplaceDialogWindow class methodsFor: 'instance creation' stamp: 'AlainPlantec 11/11/2010 21:46'! on: aTextView ^ self singleton on: aTextView! ! !EditorFindReplaceDialogWindow class methodsFor: 'initializing' stamp: 'MarcusDenker 10/15/2013 10:35'! cleanUp Singleton ifNotNil: [ Singleton close. Singleton := nil ]! ! !EllipseMidpointTracer commentStamp: 'TorstenBergmann 2/20/2014 18:32'! Utility class for calculating! !EllipseMidpointTracer methodsFor: 'computing' stamp: 'ar 6/28/1999 15:35'! stepInY "Step to the next y value" inFirstRegion ifTrue:[ "In the upper region we must step until we reach the next y value" [(aSquared * (y-0.5)) > (bSquared * (x+1))] whileTrue:[ d1 < 0.0 ifTrue:[d1 := d1 + (bSquared * (2*x+3)). x := x + 1] ifFalse:[d1 := d1 + (bSquared * (2*x+3)) + (aSquared * (-2*y+2)). y := y - 1. ^x := x + 1]]. "Stepping into second region" d2 := (bSquared * (x + 0.5) squared) + (aSquared * (y-1) squared) - (aSquared * bSquared). inFirstRegion := false. ]. "In the lower region each step is a y-step" d2 < 0.0 ifTrue:[d2 := d2 + (bSquared * (2*x+2)) + (aSquared * (-2*y+3)). x := x + 1] ifFalse:[d2 := d2 + (aSquared * (-2*y+3))]. y := y - 1. ^x! ! !EllipseMidpointTracer methodsFor: 'initialize' stamp: 'ar 6/28/1999 15:33'! on: aRectangle rect := aRectangle. a := rect width // 2. b := rect height // 2. x := 0. y := b. aSquared := a * a. bSquared := b * b. d1 := bSquared - (aSquared * b) + (0.25 * aSquared). d2 := nil. inFirstRegion := true.! ! !EllipseMorph commentStamp: 'kfr 10/27/2003 10:32'! A round BorderedMorph. Supports borderWidth and borderColor. Only simple borderStyle is implemented. EllipseMorph new borderWidth:10; borderColor: Color green; openInWorld. EllipseMorph new borderStyle:(SimpleBorder width: 5 color: Color blue); openInWorld.! !EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:23'! bottomRightCorner ^self intersectionWithLineSegmentFromCenterTo: bounds bottomRight ! ! !EllipseMorph methodsFor: 'geometry testing' stamp: 'di 11/14/97 13:50'! containsPoint: aPoint | radius other delta xOverY | (bounds containsPoint: aPoint) ifFalse: [^ false]. "quick elimination" (bounds width = 1 or: [bounds height = 1]) ifTrue: [^ true]. "Degenerate case -- code below fails by a bit" radius := bounds height asFloat / 2. other := bounds width asFloat / 2. delta := aPoint - bounds topLeft - (other@radius). xOverY := bounds width asFloat / bounds height asFloat. ^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! ! !EllipseMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:26'! defaultColor "answer the default color/fill style for the receiver" ^ Color yellow! ! !EllipseMorph methodsFor: 't-rotating' stamp: ''! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !EllipseMorph methodsFor: 'drawing' stamp: 'CamilloBruni 8/30/2012 18:51'! drawOn: aCanvas aCanvas fillOval: bounds fillStyle: self fillStyle borderWidth: borderWidth borderColor: borderColor. ! ! !EllipseMorph methodsFor: 'geometry' stamp: 'nk 2/15/2001 16:08'! closestPointTo: aPoint ^self intersectionWithLineSegmentFromCenterTo: aPoint! ! !EllipseMorph methodsFor: 'accessing' stamp: 'sw 11/24/1999 14:59'! couldHaveRoundedCorners ^ false! ! !EllipseMorph methodsFor: 'rounding' stamp: 'MarcusDenker 4/13/2012 08:49'! cornerStyle: aSymbol "Set the receiver's corner style. But, in this case, do *not*" (extension isNil or: [self cornerStyle == aSymbol]) ifTrue: [^self]. extension cornerStyle: nil. self changed! ! !EllipseMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:29'! doesBevels ^ false! ! !EllipseMorph methodsFor: 'drawing' stamp: 'di 6/24/1998 14:27'! areasRemainingToFill: aRectangle "Could be improved by quick check of inner rectangle" ^ Array with: aRectangle! ! !EllipseMorph methodsFor: 'geometry' stamp: 'nk 2/13/2001 18:16'! intersectionWithLineSegmentFromCenterTo: aPoint | dx aSquared bSquared m mSquared xSquared x y dy | (self containsPoint: aPoint) ifTrue: [ ^aPoint ]. dx := aPoint x - self center x. dy := aPoint y - self center y. dx = 0 ifTrue: [ ^self bounds pointNearestTo: aPoint ]. m := dy / dx. mSquared := m squared. aSquared := (self bounds width / 2) squared. bSquared := (self bounds height / 2) squared. xSquared := 1 / ((1 / aSquared) + (mSquared / bSquared)). x := xSquared sqrt. dx < 0 ifTrue: [ x := x negated ]. y := m * x. ^ self center + (x @ y) asIntegerPoint. ! ! !EllipseMorph methodsFor: 't-rotating' stamp: ''! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !EllipseMorph methodsFor: 't-rotating' stamp: ''! heading "Return the receiver's heading" ^ self owner ifNil: [self forwardDirection] ifNotNil: [self forwardDirection + self owner degreesOfFlex]! ! !EllipseMorph methodsFor: 'drawing' stamp: 'IgorStasenko 8/8/2011 17:21'! drawDropShadowOn: aCanvas aCanvas fillOval: bounds fillStyle: self shadowColor borderWidth: 0 borderColor: nil! ! !EllipseMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'! canDrawBorder: aBorderStyle ^aBorderStyle style == #simple! ! !EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:26'! topRightCorner ^self intersectionWithLineSegmentFromCenterTo: bounds topRight ! ! !EllipseMorph methodsFor: 't-rotating' stamp: ''! prepareForRotating "If I require a flex shell to rotate, then wrap it in one and return it. Polygons, eg, may override to do nothing." ^ self addFlexShell! ! !EllipseMorph methodsFor: 't-rotating' stamp: ''! rotationDegrees: degrees "redefined in all morphs which are using myself"! ! !EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:23'! topLeftCorner ^self intersectionWithLineSegmentFromCenterTo: bounds topLeft ! ! !EllipseMorph methodsFor: 't-rotating' stamp: ''! setDirectionFrom: aPoint | delta degrees | delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition. degrees := delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! !EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:25'! bottomLeftCorner ^self intersectionWithLineSegmentFromCenterTo: bounds bottomLeft ! ! !EllipseMorph methodsFor: 't-rotating' stamp: ''! rotationDegrees "Default implementation." ^ 0.0 ! ! !EllipseMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !EmbeddedFreetypeFont commentStamp: 'IgorStasenko 4/8/2014 17:19'! Common superclass handling fonts that are not found on the disc but embedded in the image. Subclasses should redefine fontContents and originalFileName class methods. To do in the future: - a proper way to load font file and install them to avoid bloating the image with text that represent binary font data in addition to font themselves!!!!! !EmbeddedFreetypeFont class methodsFor: 'accessing' stamp: 'IgorStasenko 4/8/2014 17:17'! fontContents self subclassResponsibility ! ! !EmbeddedFreetypeFont class methodsFor: 'accessing' stamp: 'IgorStasenko 4/8/2014 17:08'! installAllFontsIn: provider self allSubclasses do: [ :each | each installFontsIn: provider ]! ! !EmbeddedFreetypeFont class methodsFor: 'accessing' stamp: 'IgorStasenko 4/8/2014 17:17'! originalFileName self subclassResponsibility ! ! !EmbeddedFreetypeFont class methodsFor: 'accessing' stamp: 'IgorStasenko 4/8/2014 17:08'! installFontsIn: provider provider addFromFileContents: self fontContents baseName: self originalFileName ! ! !EmbeddedMenuMorph commentStamp: 'gvc 5/18/2007 13:18'! Menu designed to be embedded in another morph rather than popped up directly.! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 14:22'! handlesKeyboard: evt "Answer whether the receiver handles the keystroke represented by the event" ^true! ! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 14:17'! drawOn: aCanvas "Draw the receiver on the canvas." self perform: #drawOn: withArguments: {aCanvas} inSuperclass: Morph. self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]! ! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2007 14:37'! keyStroke: evt "Handle tabbing and arrows and cr/space." |char selectable| (self navigationKey: evt) ifTrue: [^self]. char := evt keyCharacter. char = Character space ifTrue: [selectedItem ifNotNil: [selectedItem hasSubMenu ifTrue: [evt hand newMouseFocus: selectedItem subMenu. ^selectedItem subMenu takeKeyboardFocus] ifFalse: [^selectedItem invokeWithEvent: evt]]. (selectable := self items) size = 1 ifTrue: [^selectable first invokeWithEvent: evt]. ^self]. (char = Character arrowLeft or: [char = Character arrowRight]) ifTrue: [ (selectedItem notNil and: [selectedItem hasSubMenu]) ifTrue: [ evt hand newMouseFocus: selectedItem subMenu. selectedItem subMenu moveSelectionDown: 1 event: evt. ^evt hand newKeyboardFocus: selectedItem subMenu]]. char = Character arrowUp ifTrue: [^self moveSelectionDown: -1 event: evt]. "up arrow key" char = Character arrowDown ifTrue: [^self moveSelectionDown: 1 event: evt]. "down arrow key" char = Character pageUp ifTrue: [^self moveSelectionDown: -5 event: evt]. "page up key" char = Character pageDown ifTrue: [^self moveSelectionDown: 5 event: evt]. "page down key" ! ! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/17/2008 17:04'! allEnabledSiblingItems "Answer the receiver's submorphs followed by the (wrapping) owner's submorph items. Answer only enabled items." ^self allSiblingItems select: [:item | item isEnabled]! ! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 12/11/2009 07:38'! keyboardFocusChange: aBoolean "Nasty hack for scrolling upon keyboard focus." super keyboardFocusChange: aBoolean. aBoolean ifTrue: [(self ownerThatIsA: GeneralScrollPane) ifNotNil: [:sp | sp scrollToShow: self bounds]] ifFalse: [self selectItem: nil event: nil]! ! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 8/17/2012 16:41'! selectMatch: aString "Answer the first subitem that has text that includes the given substring. Answer nil if none. Disable non-matching items and enable matching items." |firstMatch| self items do: [:item | | match | match := aString isEmpty or: [item contents asString asLowercase includesSubstring: aString]. item isEnabled: match. (match and: [firstMatch isNil]) ifTrue: [firstMatch := item]]. ^firstMatch! ! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'nice 1/5/2010 15:59'! selectPrefix: aString "Answer the first subitem that has text that matches the given prefix. Answer nil if none. Disable non-matching items and enable matching items." | firstMatch| self items do: [:item | | match | match := aString isEmpty or: [item contents asString asLowercase beginsWith: aString]. item isEnabled: match. (match and: [firstMatch isNil]) ifTrue: [firstMatch := item]]. ^firstMatch! ! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 8/17/2012 16:40'! selectLastMatch: aString "Answer the last subitem that has text that includes the given substring. Answer nil if none. Disable non-matching items and enable matching items." |lastMatch| self items reverseDo: [:item | | match | match := aString isEmpty or: [item contents asString asLowercase includesSubstring: aString]. item isEnabled: match. (match and: [lastMatch isNil]) ifTrue: [lastMatch := item]]. ^lastMatch! ! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/20/2008 21:18'! allSiblingItems "Answer the receiver's submorphs followed by the (wrapping) owner's submorph items. Nasty." |menus str index| str := (Array new: 40) writeStream. menus := self owner submorphs select: [:m | m isKindOf: self class]. menus := (menus copyFrom: (index := menus indexOf: self) to: menus size), (menus copyFrom: 1 to: index - 1). menus do: [:menu | str nextPutAll: menu items]. ^str contents! ! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'nice 1/5/2010 15:59'! moveSelectionDown: anInteger event: anEvent "Move the selection down or up (negative number) by (at least) the specified amount. If the item is not enabled, scan one at a time in that direction. If we move off the top/bottom then switch focus to any sibling menu and start scanning at the relevant end." | allEnabledSiblingItems index| allEnabledSiblingItems := self allEnabledSiblingItems. index := (allEnabledSiblingItems indexOf: selectedItem ifAbsent: [0 + (anInteger negative ifTrue: [1] ifFalse: [0])]) + anInteger. allEnabledSiblingItems do: "Ensure finite" [:unused | | m | m := allEnabledSiblingItems atWrap: index. ((m isKindOf: MenuItemMorph) and: [m isEnabled]) ifTrue: [m owner = self owner ifFalse: [ anEvent hand newKeyboardFocus: m owner]. ^m owner selectItem: m event: anEvent]. "Keep looking for an enabled item" index := index + anInteger sign]. ^self selectItem: nil event: anEvent! ! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/6/2008 14:56'! selectItem: aMenuItem event: anEvent "Deselect any sibling menus." |menus| menus := self owner submorphs select: [:m | (m isKindOf: self class) and: [m ~~ self]]. menus do: [:menu | menu perform: #selectItem:event: withArguments: {nil. anEvent} inSuperclass: self class superclass]. ^super selectItem: aMenuItem event: anEvent! ! !EmbeddedMenuMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 7/5/2010 15:47'! selectLastPrefix: aString "Answer the last subitem that has text that matches the given prefix. Answer nil if none. Disable non-matching items and enable matching items." |lastMatch| self items reverseDo: [:item | | match | match := aString isEmpty or: [item contents asString asLowercase beginsWith: aString]. item isEnabled: match. (match and: [lastMatch isNil]) ifTrue: [lastMatch := item]]. ^lastMatch! ! !EmbossedStringMorph commentStamp: 'gvc 5/18/2007 13:15'! A label that underdraws to the top-left and/or bottom-right with a lighter and/or darker colour to the receiver.! !EmbossedStringMorph methodsFor: 'accessing' stamp: 'gvc 4/27/2006 12:09'! style "Answer the value of style" ^ style! ! !EmbossedStringMorph methodsFor: 'initialization' stamp: 'gvc 8/9/2007 11:52'! initialize "Initialize the receiver." super initialize. self style: #inset; trackPaneColor: true! ! !EmbossedStringMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:55'! initWithContents: aString font: aFont emphasis: emphasisCode "Grrr, why do they do basicNew?" super initWithContents: aString font: aFont emphasis: emphasisCode. self style: #inset; trackPaneColor: true.! ! !EmbossedStringMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 17:03'! drawOn: aCanvas "Draw the hi/lowlights too." |box| self style == #plain ifTrue: [^super drawOn: aCanvas]. box := self bounds. (self style == #inset or: [self style == #insetNoHighlight]) ifTrue: [self style == #insetNoHighlight ifFalse: [aCanvas drawString: self contents in: (box translateBy: 1) font: self fontToUse color: self color veryMuchLighter]. aCanvas drawString: self contents in: (box translateBy: -1) font: self fontToUse color: self color muchDarker; drawString: self contents in: box font: self fontToUse color: self color] ifFalse: [self style == #raisedNoHighlight ifFalse: [aCanvas drawString: self contents in: (box translateBy: -1) font: self fontToUse color: self color veryMuchLighter]. aCanvas drawString: self contents in: (box translateBy: 1) font: self fontToUse color: self color muchDarker; drawString: self contents in: box font: self fontToUse color: self color]! ! !EmbossedStringMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:52'! trackPaneColor "Answer the value of trackPaneColor" ^ trackPaneColor! ! !EmbossedStringMorph methodsFor: 'accessing' stamp: 'gvc 5/10/2006 15:26'! style: anObject "Set the value of style" style := anObject. self changed! ! !EmbossedStringMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 13:16'! measureContents "Measure the contents for fitting. Add 2@2 for hi/lowlights." ^super measureContents + 2! ! !EmbossedStringMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:52'! trackPaneColor: anObject "Set the value of trackPaneColor" trackPaneColor := anObject! ! !EmbossedStringMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:53'! adoptPaneColor: paneColor "Set the color." (paneColor notNil and: [self trackPaneColor]) ifTrue: [self color: paneColor]. super adoptPaneColor: paneColor! ! !EmbossedStringMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:35'! styleSymbols "Answer the valid styles." ^#(plain inset insetNoHighlight raised raisedNoHighlight)! ! !EmptyLayout commentStamp: ''! Empty top-level layout used to delimit the layout chains.! !EmptyLayout methodsFor: 'extending' stamp: 'ToonVerwaest 4/1/2011 13:56'! extendWord ^ WordLayout new! ! !EmptyLayout methodsFor: 'extending' stamp: 'MartinDias 12/9/2013 11:38'! extend: someSlots ^ FixedLayout new slotScope: (LayoutEmptyScope instance extend: someSlots)! ! !EmptyLayout methodsFor: 'extending' stamp: 'ToonVerwaest 4/1/2011 13:56'! extendByte ^ ByteLayout new! ! !EmptyLayout methodsFor: 'extending' stamp: 'ToonVerwaest 4/1/2011 13:57'! extendWeak ^ WeakLayout new! ! !EmptyLayout methodsFor: 'extending' stamp: 'ToonVerwaest 4/2/2011 14:26'! extendVariable: someSlots ^ VariableLayout new slotScope: (LayoutEmptyScope extend: someSlots)! ! !EmptyLayout class methodsFor: 'instance creation' stamp: 'ToonVerwaest 3/20/2011 15:29'! instance ^ instance ifNil: [ instance := self new ]! ! !EncodedCharSet commentStamp: 'yo 10/19/2004 19:08'! An abstract superclasss of the classes that represent encoded character sets. In the old implementation, the charsets had more important role. However, in the current implementation, the subclasses are used only for keeping the backward compatibility. The other confusion comes from the name of "Latin1" class. It used to mean the Latin-1 (ISO-8859-1) character set, but now it primarily means that the "Western European languages that are covered by the characters in Latin-1 character set. ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:55'! canBeGlobalVarInitial: char | leadingChar | leadingChar := char leadingChar. leadingChar = 0 ifTrue: [^ self isUppercase: char]. ^ self isLetter: char. ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 12/2/2004 16:13'! isCharset ^ true. ! ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:44'! isUppercase: char "Answer whether the receiver is an uppercase letter. (The old implementation answered whether the receiver is not a lowercase letter.)" | value | value := char asciiValue. ^ 8r101 <= value and: [value <= 8r132]. ! ! !EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'yo 12/18/2002 12:34'! isBreakableAt: index in: text self subclassResponsibility. ! ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:44'! isDigit: char "Answer whether the receiver is a digit." | value | value := char asciiValue. ^ value >= 48 and: [value <= 57]. ! ! !EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'yo 9/4/2002 22:51'! printingDirection self subclassResponsibility. ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 9/4/2002 22:57'! charsetAt: encoding ^ EncodedCharSets at: encoding + 1 ifAbsent: [EncodedCharSets at: 1]. ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 9/2/2002 16:32'! leadingChar self subclassResponsibility. ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 11/4/2002 14:43'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state self subclassResponsibility. ! ! !EncodedCharSet class methodsFor: 'initialize' stamp: 'StephaneDucasse 8/22/2013 14:24'! declareEncodedCharSet: anEncodedCharSetOrLanguageEnvironmentClass atIndex: aNumber EncodedCharSets at: aNumber put: anEncodedCharSetOrLanguageEnvironmentClass "this method is used to modularize the old initialize method: EncodedCharSets at: 0+1 put: Unicode. EncodedCharSets at: 1+1 put: JISX0208. EncodedCharSets at: 2+1 put: GB2312. EncodedCharSets at: 3+1 put: KSX1001. EncodedCharSets at: 4+1 put: JISX0208. EncodedCharSets at: 5+1 put: JapaneseEnvironment. EncodedCharSets at: 6+1 put: SimplifiedChineseEnvironment. EncodedCharSets at: 7+1 put: KoreanEnvironment. EncodedCharSets at: 8+1 put: GB2312. EncodedCharSets at: 12+1 put: KSX1001. EncodedCharSets at: 13+1 put: GreekEnvironment. EncodedCharSets at: 14+1 put: Latin2Environment. EncodedCharSets at: 15+1 put: RussianEnvironment. EncodedCharSets at: 17+1 put: Latin9Environment. EncodedCharSets at: 256 put: Unicode. " ! ! !EncodedCharSet class methodsFor: 'language methods' stamp: 'tpr 10/3/2013 12:43'! scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX font: aFont "the default for scanning multibyte characters- other more specific encodings may do something else" ^aFont scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX! ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:40'! isLowercase: char "Answer whether the receiver is a lowercase letter. (The old implementation answered whether the receiver is not an uppercase letter.)" | value | value := char asciiValue. ^ 8r141 <= value and: [value <= 8r172]. ! ! !EncodedCharSet class methodsFor: 'initialize' stamp: 'StephaneDucasse 8/22/2013 14:34'! initialize "self initialize" EncodedCharSets := Array new: 256. self allSubclassesDo: [:each | each initialize]. LanguageEnvironment allSubclassesDo: [:each | each initialize]. "EncodedCharSets at: 0+1 put: Unicode. EncodedCharSets at: 1+1 put: JISX0208. EncodedCharSets at: 2+1 put: GB2312. EncodedCharSets at: 3+1 put: KSX1001. EncodedCharSets at: 4+1 put: JISX0208. EncodedCharSets at: 5+1 put: JapaneseEnvironment. EncodedCharSets at: 6+1 put: SimplifiedChineseEnvironment. EncodedCharSets at: 7+1 put: KoreanEnvironment. EncodedCharSets at: 8+1 put: GB2312. EncodedCharSets at: 12+1 put: KSX1001. EncodedCharSets at: 13+1 put: GreekEnvironment. EncodedCharSets at: 14+1 put: Latin2Environment. EncodedCharSets at: 15+1 put: RussianEnvironment. EncodedCharSets at: 17+1 put: Latin9Environment. EncodedCharSets at: 256 put: Unicode." ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! ucsTable ^ UCSTable latin1Table. ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'StephaneDucasse 2/13/2010 16:02'! digitValueOf: char "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 otherwise. This is used to parse literal numbers of radix 2-36." | value | value := char charCode. value <= $9 asciiValue ifTrue: [^value - $0 asciiValue]. value >= $A asciiValue ifTrue: [ value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]. (value >= $a asciiValue and: [value <= $z asciiValue]) ifTrue: [^value - $a asciiValue + 10]]. ^ -1 ! ! !EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'sn 7/31/2009 15:01'! scanSelector ^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern:! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'tak 11/5/2005 18:14'! charFromUnicode: unicode | table index | unicode < 128 ifTrue: [^ Character value: unicode]. table := self ucsTable. index := table indexOf: unicode. index = 0 ifTrue: [ ^ nil. ]. ^ Character leadingChar: self leadingChar code: index - 1. ! ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:40'! isLetter: char "Answer whether the receiver is a letter." | value | value := char asciiValue. ^ (8r141 <= value and: [value <= 8r172]) or: [8r101 <= value and: [value <= 8r132]]. ! ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 17:18'! canBeNonGlobalVarInitial: char | leadingChar | leadingChar := char leadingChar. leadingChar = 0 ifTrue: [^ self isLowercase: char]. ^ self isLetter: char. ! ! !Encoder commentStamp: ''! I encode names and literals into tree nodes with byte codes for the compiler. Byte codes for literals are not assigned until the tree-sizing pass of the compiler, because only then is it known which literals are actually needed. I also keep track of sourceCode ranges during parsing and code generation so I can provide an inverse map for the debugger.! !Encoder methodsFor: 'initialize-release' stamp: 'PeterHugossonMiller 9/2/2009 16:18'! fillDict: dict with: nodeClass mapping: keys to: codeArray | codeStream | codeStream := codeArray readStream. keys do: [:key | dict at: key put: (nodeClass new name: key key: key code: codeStream next)]! ! !Encoder methodsFor: 'results' stamp: 'eem 6/24/2008 14:24'! unusedTempNames | unused | unused := OrderedCollection new. scopeTable associationsDo: [:assn | | name | (assn value isUnusedTemp) ifTrue: [name := assn value key. name ~= self doItInContextName ifTrue: [unused add: name]]]. ^ unused! ! !Encoder methodsFor: 'temps' stamp: 'crl 2/26/1999 12:18'! bindBlockTemp: name "Declare a temporary block variable; complain if it's not a field or class variable." | node | node := scopeTable at: name ifAbsent: [^self reallyBind: name]. node isTemp ifTrue: [ node scope >= 0 ifTrue: [^ self notify: 'Name already used in this method']. node scope: 0] ifFalse: [^self notify: 'Name already used in this class']. ^node ! ! !Encoder methodsFor: 'error handling' stamp: ''! notify: string at: location | req | requestor == nil ifFalse: [req := requestor. self release. req notify: string at: location]. ^false! ! !Encoder methodsFor: 'private' stamp: 'eem 9/10/2008 14:03'! lookupInPools: varName ifFound: assocBlock ^Symbol hasInterned: varName ifTrue: [:sym| (class bindingOf: sym) ifNil: [^false] ifNotNil: [:assoc| assocBlock value: assoc]]! ! !Encoder methodsFor: 'temps' stamp: 'eem 5/30/2008 12:05'! bindBlockArg: name within: aBlockNode "With standard Smalltalk-80 (BlueBook) blocks it used to be legal to use a method temp as a block argument. This shouldn't be the case with the current compiler, which checks for temp names already being used as block arguments. But it is easily fooled by local block temps in optimized blocks, e.g. false ifTrue: [| temp |] ifFalse:[[:temp|]] Rather than fix this we keep the semantics and fix it in the closure compiler." ^self autoBind: name! ! !Encoder methodsFor: 'temps' stamp: 'jm 9/18/97 21:06'! bindArg: name "Declare an argument." | node | nTemps >= 15 ifTrue: [^self notify: 'Too many arguments']. node := self bindTemp: name. ^ node nowHasDef nowHasRef! ! !Encoder methodsFor: 'private' stamp: 'yo 11/11/2002 10:23'! possibleVariablesFor: proposedVariable | results | results := proposedVariable correctAgainstDictionary: scopeTable continuedFrom: nil. proposedVariable first canBeGlobalVarInitial ifTrue: [ results := class possibleVariablesFor: proposedVariable continuedFrom: results ]. ^ proposedVariable correctAgainst: nil continuedFrom: results. ! ! !Encoder methodsFor: 'visiting' stamp: 'eem 5/30/2008 09:44'! accept: aVisitor "I am not really a ParseNode. Only here to access constants defined in parseNode." self shouldNotImplement! ! !Encoder methodsFor: 'temps' stamp: 'eem 12/1/2008 12:07'! fixTemp: name | node | node := scopeTable at: name ifAbsent: []. node class ~~ TempVariableNode ifTrue: [self error: 'can only fix a floating temp var']. node index: nTemps. nTemps := nTemps + 1. ^node! ! !Encoder methodsFor: 'error handling' stamp: ''! requestor: req "Often the requestor is a BrowserCodeController" requestor := req! ! !Encoder methodsFor: 'initialize-release' stamp: 'nice 4/1/2011 19:26'! initScopeAndLiteralTables scopeTable := StdVariables copy. litSet := StdLiterals copy. "comments can be left hanging on nodes from previous compilations. probably better than this hack fix is to create the nodes afresh on each compilation." scopeTable do: [:varNode| varNode comment: nil]. litSet do: [:varNode| varNode comment: nil]. selectorSet := StdSelectors copy. litIndSet := Dictionary new: 16. literalStream := (Array new: 32) writeStream. addedSelectorAndMethodClassLiterals := false. optimizedSelectors := Set new! ! !Encoder methodsFor: 'initialize-release' stamp: 'MarcusDenker 3/23/2010 18:43'! init: aClass context: aContext notifying: req requestor := req. class := aClass. nTemps := 0. supered := false. self initScopeAndLiteralTables. class variablesAndOffsetsDo: [:variable "" :offset "" | scopeTable at: variable put: (offset >= 0 ifTrue: [InstanceVariableNode new name: variable index: offset] ifFalse: [MaybeContextInstanceVariableNode new name: variable index: offset negated])]. aContext ~~ nil ifTrue: [| homeNode | homeNode := self bindTemp: self doItInContextName. "0th temp = aContext passed as arg" aContext tempNames withIndexDo: [:variable :index| scopeTable at: variable put: (MessageAsTempNode new receiver: homeNode selector: #namedTempAt: arguments: (Array with: (self encodeLiteral: index)) precedence: 3 from: self)]]. sourceRanges := Dictionary new: 32. globalSourceRanges := OrderedCollection new: 32! ! !Encoder methodsFor: 'initialize-release' stamp: ''! release requestor := nil! ! !Encoder methodsFor: 'encoding' stamp: 'MarcusDenker 6/24/2013 11:12'! encodeSelector: aSelector ^self name: aSelector key: aSelector class: SelectorNode type: SendType set: selectorSet! ! !Encoder methodsFor: 'temps' stamp: ''! newTemp: name nTemps := nTemps + 1. ^ TempVariableNode new name: name index: nTemps - 1 type: LdTempType scope: 0! ! !Encoder methodsFor: 'temps' stamp: 'eem 7/13/2007 14:13'! floatTemp: node (node ~~ (scopeTable at: node name ifAbsent: []) or: [node class ~~ TempVariableNode or: [node code ~= (node code: nTemps - 1 type: LdTempType)]]) ifTrue: [self error: 'can only float the last allocated temp var']. nTemps := nTemps - 1! ! !Encoder methodsFor: 'error handling' stamp: 'eem 12/22/2009 11:57'! notify: string "Put a separate notifier on top of the requestor's window" | req | requestor == nil ifTrue: [super notify: string] ifFalse: [req := requestor. self release. req notify: string]. ^false! ! !Encoder methodsFor: 'accessing' stamp: 'ar 9/9/2006 12:06'! selector: aSymbol selector := aSymbol! ! !Encoder methodsFor: 'encoding' stamp: 'MarcusDenker 5/16/2013 11:11'! encodeVariable: name sourceRange: range ifUnknown: action | varNode | varNode := scopeTable at: name ifAbsent: [(self lookupInPools: name ifFound: [:assoc | varNode := self global: assoc name: name]) ifTrue: [varNode] ifFalse: [^action value]]. range ifNotNil: [ name first canBeGlobalVarInitial ifTrue: [globalSourceRanges addLast: { name. range. false }]. ]. (varNode isTemp and: [varNode scope < 0]) ifTrue: [ "every client just does resume: true" action value. " OutOfScopeNotification signal ifTrue: [action value] ifFalse: [ ^self notify: 'out of scope']." ]. ^ varNode! ! !Encoder methodsFor: 'results' stamp: 'eem 5/27/2009 09:25'! associationForClass | assoc | assoc := self environment associationAt: class name ifAbsent: [nil]. ^assoc value == class ifTrue: [assoc] ifFalse: [Association new value: class]! ! !Encoder methodsFor: 'private' stamp: 'Lukas Renggli 11/2/2009 00:29'! name: name key: key class: leafNodeClass type: type set: dict ^dict at: key ifAbsentPut: [leafNodeClass new name: name key: key index: nil type: type]! ! !Encoder methodsFor: 'source mapping' stamp: 'RAA 8/21/1999 06:52'! rawSourceRanges ^ sourceRanges ! ! !Encoder methodsFor: 'temps' stamp: 'ar 9/9/2006 12:05'! autoBind: name "Declare a block argument as a temp if not already declared." | node | node := scopeTable at: name ifAbsent: [(self lookupInPools: name ifFound: [:assoc | assoc]) ifTrue: [self warnAboutShadowed: name]. ^ (self reallyBind: name) nowHasDef nowHasRef scope: 1]. node isTemp ifTrue: [node scope >= 0 ifTrue: [^ self notify: 'Name already used in this method']. node nowHasDef nowHasRef scope: 1] ifFalse: [^ self notify: 'Name already used in this class']. ^node! ! !Encoder methodsFor: 'results' stamp: ''! literals "Should only be used for decompiling primitives" ^ literalStream contents! ! !Encoder methodsFor: 'accessing' stamp: 'ar 9/9/2006 12:06'! selector ^selector! ! !Encoder methodsFor: 'encoding' stamp: 'eem 9/5/2009 20:04'! doItInContextName ^'ThisContext'! ! !Encoder methodsFor: 'temps' stamp: 'eem 5/30/2008 14:14'! bindBlockTemp: name within: aBlockNode "The BlockContext compiler (the Smalltalk-80 BlueBook compiler) does provide support for ANSI block syntax, but not for ANSI block semantics. Here all temps live at the same level, the method level. The approach taken to two block-local temps in different blocks is to merge them into a single temp. e.g. expr ifTrue: [|temp| self statementOne] ifFalse: [|temp| self statementTwo] is effectvely transformed into | temp | expr ifTrue: [self statementOne] ifFalse: [self statementTwo] and expr do: [:each| | temp | ...]. expr do: [:each| | temp | ...]. is also effectively transformed into | temp | expr do: [:each| ...]. expr do: [:each| ...]. The closure compiler treats the former similarly, but not the latter. The indirection through #bindBlockTemp:within: allows the closure encoder to do this." ^self bindBlockTemp: name! ! !Encoder methodsFor: 'results' stamp: 'nice 3/31/2011 00:35'! allLiterals addedSelectorAndMethodClassLiterals ifFalse: [addedSelectorAndMethodClassLiterals := true. "Put the optimized selectors in literals so as to browse senders more easily" optimizedSelectors := optimizedSelectors reject: [:e| literalStream originalContents hasLiteral: e]. optimizedSelectors isEmpty ifFalse: [ "Use one entry per literal if enough room, else make anArray" literalStream position + optimizedSelectors size + 2 > 255 ifTrue: [self litIndex: optimizedSelectors asArray] ifFalse: [optimizedSelectors do: [:e | self litIndex: e]]]. "Add a slot for selector or MethodProperties" self litIndex: nil. self litIndex: self associationForClass]. ^literalStream contents! ! !Encoder methodsFor: 'encoding' stamp: 'nice 3/30/2011 23:26'! noteOptimizedSelector: aSymbol "Register a selector as being optimized. These optimized selectors will later be registered into the literals so that tools can easily browse senders." optimizedSelectors add: aSymbol! ! !Encoder methodsFor: 'encoding' stamp: 'StephaneDucasse 3/20/2010 17:23'! environment "Answer the environment of the current compilation context, be it in a class or global (e.g. a workspace)" ^class == nil ifTrue: [Smalltalk globals] ifFalse: [class environment]! ! !Encoder methodsFor: 'temps' stamp: 'di 10/12/1999 16:53'! bindAndJuggle: name | node nodes first thisCode | node := self reallyBind: name. "Declared temps must precede block temps for decompiler and debugger to work right" nodes := self tempNodes. (first := nodes findFirst: [:n | n scope > 0]) > 0 ifTrue: [node == nodes last ifFalse: [self error: 'logic error']. thisCode := (nodes at: first) code. first to: nodes size - 1 do: [:i | (nodes at: i) key: (nodes at: i) key code: (nodes at: i+1) code]. nodes last key: nodes last key code: thisCode]. ^ node! ! !Encoder methodsFor: 'temps' stamp: 'JorgeRessia 6/5/2010 11:31'! evaluateShadowingInteractivelyOf: aNode self isAnalyzedMethodDefinedByATrait ifTrue: [^false]. aNode isTemp ifTrue: [ (aNode scope >= 0) ifTrue: [ ^self notify:'Name is already defined'] ] ifFalse: [ ^self notify:'Name is already defined' ]. ! ! !Encoder methodsFor: 'encoding' stamp: 'di 12/4/1999 20:09'! encodeVariable: name ^ self encodeVariable: name sourceRange: nil ifUnknown: [ self undeclared: name ]! ! !Encoder methodsFor: 'encoding' stamp: 'eem 5/16/2008 18:30'! sharableLitIndex: literal "Special access prevents multiple entries for post-allocated super send special selectors" 1 to: literalStream position do: [:index| (litSet literalEquality: literal and: (literalStream originalContents at: index)) ifTrue: [^index - 1]]. ^self litIndex: literal! ! !Encoder methodsFor: 'encoding' stamp: 'pavel.krivanek 3/2/2010 21:25'! undeclared: name | sym | requestor interactive ifTrue: [requestor == #error: ifTrue: [requestor error: 'Undeclared']. ^self notify: 'Undeclared']. "Allow knowlegeable clients to squash the undeclared warning if they want (e.g. Diffing pretty printers that are simply formatting text). As this breaks compilation it should only be used by clients that want to discard the result of the compilation. To squash the warning use e.g. [Compiler format: code in: class notifying: nil decorated: false] on: UndeclaredVariableWarning do: [:ex| ex resume: false]" sym := name asSymbol. ^(UndeclaredVariableWarning new name: name selector: selector class: class) signal ifTrue: [Undeclared at: sym put: nil. self global: (Undeclared associationAt: sym) name: sym] ifFalse: [self global: (Association key: sym) name: sym]! ! !Encoder methodsFor: 'results' stamp: 'eem 5/27/2008 12:07'! tempNodes | tempNodes | tempNodes := SortedCollection sortBlock: [:n1 :n2 | n1 code <= n2 code]. scopeTable associationsDo: [:assn | assn value isArray ifTrue: [assn value do: [:temp| tempNodes add: temp]] ifFalse: [assn value isTemp ifTrue: [tempNodes add: assn value]]]. ^tempNodes! ! !Encoder methodsFor: 'temps' stamp: 'JorgeRessia 6/5/2010 11:32'! isAnalyzedMethodDefinedByATrait ^( class traitOrClassOfSelector: #testReplaceFromToWithStartingAt ) isTrait! ! !Encoder methodsFor: 'temps' stamp: ''! maxTemp ^nTemps! ! !Encoder methodsFor: 'temps' stamp: 'JorgeRessia 6/5/2010 11:32'! evaluateShadowingNotInteractivelyOf: aNode self isAnalyzedMethodDefinedByATrait ifTrue: [^false]. aNode isTemp ifTrue: [(aNode scope >= 0) ifTrue: [ ^self notify:'Name is already defined'] ] ifFalse: [ self warnAboutShadowed: aNode name ] ! ! !Encoder methodsFor: 'private' stamp: ''! classEncoding "This is a hack so that the parser may findout what class it was parsing for when it wants to create a syntax error view." ^ class! ! !Encoder methodsFor: 'encoding' stamp: ''! encodeLiteral: object ^self name: object key: (class literalScannedAs: object notifying: self) class: LiteralNode type: LdLitType set: litSet! ! !Encoder methodsFor: 'private' stamp: 'ar 8/14/2001 23:12'! global: ref name: name ^self name: name key: ref class: LiteralVariableNode type: LdLitIndType set: litIndSet! ! !Encoder methodsFor: 'encoding' stamp: ''! cantStoreInto: varName ^StdVariables includesKey: varName! ! !Encoder methodsFor: 'private' stamp: ''! reallyBind: name | node | node := self newTemp: name. scopeTable at: name put: node. ^node! ! !Encoder methodsFor: 'private' stamp: 'ar 3/26/2004 15:44'! interactive ^requestor interactive! ! !Encoder methodsFor: 'initialize-release' stamp: 'PeterHugossonMiller 9/2/2009 16:17'! temps: tempVars literals: lits class: cl "Decompile." supered := false. class := cl. nTemps := tempVars size. tempVars do: [:node | scopeTable at: node name put: node]. (literalStream := lits readStream) position: lits size. sourceRanges := Dictionary new: 32. globalSourceRanges := OrderedCollection new: 32. ! ! !Encoder methodsFor: 'initialize-release' stamp: ''! noteSuper supered := true! ! !Encoder methodsFor: 'accessing' stamp: 'eem 5/29/2008 09:36'! methodNodeClass ^MethodNode! ! !Encoder methodsFor: 'encoding' stamp: ''! litIndex: literal | p | p := literalStream position. p = 256 ifTrue: [self notify: 'More than 256 literals referenced. You must split or otherwise simplify this method. The 257th literal is: ', literal printString. ^nil]. "Would like to show where it is in the source code, but that info is hard to get." literalStream nextPut: literal. ^ p! ! !Encoder methodsFor: 'source mapping' stamp: ''! noteSourceRange: range forNode: node sourceRanges at: node put: range! ! !Encoder methodsFor: 'results' stamp: 'di 10/12/1999 16:12'! tempNames ^ self tempNodes collect: [:node | (node isMemberOf: MessageAsTempNode) ifTrue: [scopeTable keyAtValue: node] ifFalse: [node key]]! ! !Encoder methodsFor: 'temps' stamp: 'JorgeRessia 3/4/2010 22:00'! bindTemp: name "Declare a temporary; error not if a field or class variable." scopeTable at: name ifPresent: [:node| (requestor interactive) ifTrue: [self evaluateShadowingInteractivelyOf: node] ifFalse: [self evaluateShadowingNotInteractivelyOf: node] ]. ^self reallyBind: name! ! !Encoder methodsFor: 'private' stamp: 'eem 6/19/2008 13:02'! warnAboutShadowed: name requestor addWarning: name,' is shadowed'. selector ifNotNil: [Transcript cr; show: class name,'>>', selector, '(', name,' is shadowed)']! ! !Encoder methodsFor: 'temps' stamp: 'mir 1/17/2004 12:31'! bindTemp: name in: methodSelector "Declare a temporary; error not if a field or class variable." scopeTable at: name ifPresent:[:node| "When non-interactive raise the error only if its a duplicate" (node isTemp or:[requestor interactive]) ifTrue:[^self notify:'Name is already defined'] ifFalse:[Transcript show: '(', name, ' is shadowed in "' , class printString , '>>' , methodSelector printString , '")']]. ^self reallyBind: name! ! !EncoderForLongFormV3 commentStamp: ''! I am an alternate to EncoderForV3 that tries to use thje longest forms of bytecodes possible so as to avoid using as many bytecode as possible to allow for the unused portions of the bytecode set this makes available to be reassigned. I do not use the following ranges 0 through 111 0- 15 0000iiii Push Receiver Variable #iiii 16- 31 0001iiii Push Temporary Location #iiii 32- 63 001iiiii Push Literal Constant #iiiii 64- 95 010iiiii Push Literal Variable #iiiii 96-103 01100iii Pop and Store Receiver Variable #iii 104-111 01101iii Pop and Store Temporary Location #iii 138-159 138-143 Unused. 144-151 10010iii Jump iii + 1 (i.e., 1 through 8). 152-159 10011iii Pop and Jump 0n False iii +1 (i.e., 1 through 8). 176-255 176-191 1011iiii Send Arithmetic Message #iiii 192-207 1100iiii Send Special Message #iiii 208-223 1101iiii Send Literal Selector #iiii With No Arguments 224-239 1110iiii Send Literal Selector #iiii With 1 Argument 240-255 1111iiii Send Literal Selector #iiii With 2 Arguments = 112 + (160 - 138) + (256 - 176) = 214, or 84% of the bytecodes! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:52'! genBranchPopFalse: distance "See BlueBook page 596" distance < 0 ifTrue: [^self outOfRangeError: 'distance' index: distance range: 0 to: 1023]. distance < 1024 ifTrue: ["172-175 101011ii jjjjjjjj Pop and Jump On False ii *256+jjjjjjjj" stream nextPut: 172 + (distance bitShift: -8); nextPut: distance + 1024 \\ 256. ^self]. ^self outOfRangeError: 'distance' index: distance range: 0 to: 1023! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:50'! genStorePopInstVar: instVarIndex "See BlueBook page 596" (instVarIndex >= 0 and: [instVarIndex < 64]) ifTrue: ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 130; nextPut: instVarIndex. ^self]. self genStorePopInstVarLong: instVarIndex! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:51'! genStoreInstVarLong: instVarIndex "See BlueBook page 596" "See also MaybeContextInstanceVariableNode" (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 160; nextPut: instVarIndex. ^self]. ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:55'! genSendSuper: selectorLiteralIndex numArgs: nArgs "See BlueBook page 596 (with exceptions for 132 & 134)" nArgs < 0 ifTrue: [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31 "!!!!"]. selectorLiteralIndex < 0 ifTrue: [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]. (selectorLiteralIndex < 32 and: [nArgs < 8]) ifTrue: [" 133 10000011 jjjkkkkk Send Literal Selector #kkkkk To Superclass With jjj Arguments" stream nextPut: 133; nextPut: ((nArgs bitShift: 5) + selectorLiteralIndex). ^self]. (selectorLiteralIndex <= 255 and: [nArgs <= 31]) ifTrue: ["In Squeak V3 132 10000100 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk With jjjjjjjj Arguments is replaced by 132 10000100 ooojjjjj kkkkkkkk ooo = 0 => Send Literal Selector #kkkkkkkk With jjjjj Arguments ooo = 1 => Send Literal Selector #kkkkkkkk To Superclass With jjjjj Arguments" stream nextPut: 132; nextPut: 32 + nArgs; nextPut: selectorLiteralIndex. ^self]. nArgs > 31 ifTrue: [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31]. selectorLiteralIndex > 255 ifTrue: [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:46'! genPushInstVar: instVarIndex "See BlueBook page 596" (instVarIndex >= 0 and: [instVarIndex < 64]) ifTrue: ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" stream nextPut: 128; nextPut: instVarIndex. ^self]. self genPushInstVarLong: instVarIndex! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! genDup "See BlueBook page 596" "136 10001000 Duplicate Stack Top" stream nextPut: 136! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! genReturnReceiver "See BlueBook page 596" "120-123 011110ii Return (receiver, true, false, nil) [ii] From Message" stream nextPut: 120! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:54'! genPushLiteral: literalIndex "See BlueBook page 596" literalIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. literalIndex < 64 ifTrue: ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" stream nextPut: 128; nextPut: 128 + literalIndex. ^self]. literalIndex < 256 ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 96; nextPut: literalIndex. ^self]. ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! genReturnTop "See BlueBook page 596" "124-125 0111110i Return Stack Top From (Message, Block) [i]" stream nextPut: 124! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:58'! genStoreTemp: tempIndex "See BlueBook page 596" tempIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. tempIndex < 64 ifTrue: ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 129; nextPut: 64 + tempIndex. ^self]. ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! genPushSpecialLiteral: aLiteral "112-119 01110iii Push (receiver, true, false, nil, -1, 0, 1, 2) [iii]" | index | index := #(true false nil -1 0 1 2) indexOf: aLiteral ifAbsent: 0. index = 0 ifTrue: [^self error: 'push special literal: ', aLiteral printString, ' is not one of true false nil -1 0 1 2']. stream nextPut: index + 112! ! !EncoderForLongFormV3 methodsFor: 'initialize-release' stamp: 'eem 5/15/2008 14:11'! initScopeAndLiteralTables super initScopeAndLiteralTables. "Start with an empty selector set to avoid the special selectors." selectorSet := Dictionary new: 16! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:58'! genStorePopTemp: tempIndex "See BlueBook page 596" tempIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. tempIndex < 64 ifTrue: ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 130; nextPut: 64 + tempIndex. ^self]. ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! genReturnTopToCaller "See BlueBook page 596" "124-125 0111110i Return Stack Top From (Message, Block) [i]" stream nextPut: 125! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! genPushReceiver "See BlueBook page 596" "112-119 01110iii Push (receiver, true, false, nil, -1, 0, 1, 2) [iii]" stream nextPut: 112! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:54'! genPushTemp: tempIndex "See BlueBook page 596" tempIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. tempIndex < 64 ifTrue: ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" stream nextPut: 128; nextPut: 64 + tempIndex. ^self]. ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:48'! genStoreInstVar: instVarIndex "See BlueBook page 596" (instVarIndex >= 0 and: [instVarIndex < 64]) ifTrue: ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 129; nextPut: instVarIndex. ^self]. self genStoreInstVarLong: instVarIndex! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:53'! genBranchPopTrue: distance "See BlueBook page 596" distance < 0 ifTrue: [^self outOfRangeError: 'distance' index: distance range: 0 to: 1023]. distance < 1024 ifTrue: ["168-171 101010ii jjjjjjjj Pop and Jump On True ii *256+jjjjjjjj" stream nextPut: 168 + (distance bitShift: -8); nextPut: distance + 1024 \\ 256. ^self]. ^self outOfRangeError: 'distance' index: distance range: 0 to: 1023! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! genReturnSpecialLiteral: aLiteral "120-123 011110ii Return (receiver, true, false, nil) [ii] From Message" | index | index := #(true false nil) indexOf: aLiteral ifAbsent: 0. index = 0 ifTrue: [^self error: 'return special literal: ', aLiteral printString, ' is not one of true false nil']. stream nextPut: 120 + index! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:20'! genJump: distance "See BlueBook page 596" ^self genJumpLong: distance! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:57'! genStoreLiteralVar: literalIndex "See BlueBook page 596" literalIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. literalIndex < 64 ifTrue: ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 129; nextPut: 192 + literalIndex. ^self]. literalIndex <= 255 ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 224; nextPut: literalIndex. ^self]. ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:51'! genPushInstVarLong: instVarIndex "See BlueBook page 596" "See also MaybeContextInstanceVariableNode" (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 64; nextPut: instVarIndex. ^self]. ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:56'! genSend: selectorLiteralIndex numArgs: nArgs "See BlueBook page 596 (with exceptions for 132 & 134)" nArgs < 0 ifTrue: [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31 "!!!!"]. selectorLiteralIndex < 0 ifTrue: ["No special selector sends in long form." ^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]. (selectorLiteralIndex < 32 and: [nArgs < 8]) ifTrue: [" 131 10000011 jjjkkkkk Send Literal Selector #kkkkk With jjj Arguments" stream nextPut: 131; nextPut: ((nArgs bitShift: 5) + selectorLiteralIndex). ^self]. (selectorLiteralIndex < 64 and: [nArgs < 4]) ifTrue: ["In Squeak V3 134 10000110 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk To Superclass With jjjjjjjj Arguments is replaced by 134 10000110 jjkkkkkk Send Literal Selector #kkkkkk With jj Arguments" stream nextPut: 134; nextPut: ((nArgs bitShift: 6) + selectorLiteralIndex). ^self]. (selectorLiteralIndex <= 255 and: [nArgs <= 31]) ifTrue: ["In Squeak V3 132 10000100 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk With jjjjjjjj Arguments is replaced by 132 10000100 ooojjjjj kkkkkkkk ooo = 0 => Send Literal Selector #kkkkkkkk With jjjjj Arguments ooo = 1 => Send Literal Selector #kkkkkkkk To Superclass With jjjjj Arguments" stream nextPut: 132; nextPut: nArgs; nextPut: selectorLiteralIndex. ^self]. nArgs > 31 ifTrue: [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31]. selectorLiteralIndex > 255 ifTrue: [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:58'! genStorePopLiteralVar: literalIndex "See BlueBook page 596" literalIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. literalIndex < 64 ifTrue: ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 130; nextPut: 192 + literalIndex. ^self]. literalIndex <= 255 ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 224; nextPut: literalIndex. self genPop. ^self]. ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:54'! genPushLiteralVar: literalIndex "See BlueBook page 596" literalIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. literalIndex < 64 ifTrue: ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" stream nextPut: 128; nextPut: 192 + literalIndex. ^self]. literalIndex < 256 ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 128; nextPut: literalIndex. ^self]. ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! genPushThisContext "See BlueBook page 596" "137 10001001 Push Active Context" stream nextPut: 137! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:51'! genStorePopInstVarLong: instVarIndex "See BlueBook page 596" "See also MaybeContextInstanceVariableNode" (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 192; nextPut: instVarIndex. ^self]. ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:53'! genJumpLong: distance "See BlueBook page 596" (distance >= -1024 and: [distance < 1024]) ifTrue: ["160-167 10100iii jjjjjjjj Jump(iii - 4) *256+jjjjjjjj" stream nextPut: 160 + (distance + 1024 bitShift: -8); nextPut: distance + 1024 \\ 256. ^self]. ^self outOfRangeError: 'distance' index: distance range: -1024 to: 1023! ! !EncoderForLongFormV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 14:12'! genPop "See BlueBook page 596" "135 10000111 Pop Stack Top" stream nextPut: 135! ! !EncoderForLongFormV3PlusClosures commentStamp: ''! An encoder for the V3 bytecode set augmented with the following bytecodes that are part of the full closure implementation. 138 10001010 jkkkkkkk Push (Array new: kkkkkkk) (j = 0) or Pop kkkkkkk elements into: (Array new: kkkkkkk) (j = 1) 140 10001100 kkkkkkkk jjjjjjjj Push Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 141 10001101 kkkkkkkk jjjjjjjj Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 142 10001110 kkkkkkkk jjjjjjjj Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 143 10001111 llllkkkk jjjjjjjj iiiiiiii Push Closure Num Copied llll Num Args kkkk BlockSize jjjjjjjjiiiiiiii This is an exact duplicate of EncoderForV3PlusClosures. Could be a trait (or in Newspeak, a Mixin). For now we impose upon you to synchronise any and all changes between these two classes.! !EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:10'! genPushClosureCopyNumCopiedValues: numCopied numArgs: numArgs jumpSize: jumpSize "143 10001111 llllkkkk jjjjjjjj iiiiiiii Push Closure Num Copied llll Num Args kkkk BlockSize jjjjjjjjiiiiiiii" (jumpSize < 0 or: [jumpSize > 65535]) ifTrue: [^self outOfRangeError: 'block size' index: jumpSize range: 0 to: 65535]. (numCopied < 0 or: [numCopied > 15]) ifTrue: [^self outOfRangeError: 'num copied' index: numCopied range: 0 to: 15]. (numArgs < 0 or: [numArgs > 15]) ifTrue: [^self outOfRangeError: 'num args' index: numArgs range: 0 to: 15]. stream nextPut: 143; nextPut: numArgs + (numCopied bitShift: 4); nextPut: (jumpSize bitShift: -8); nextPut: (jumpSize bitAnd: 16rFF)! ! !EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:06'! genPushConsArray: size (size < 0 or: [size > 127]) ifTrue: [^self outOfRangeError: 'numElements' index: size range: 0 to: 127]. "138 10001010 1kkkkkkk Pop kkkkkkk into: (Array new: kkkkkkk)" stream nextPut: 138; nextPut: size + 128! ! !EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:05'! genPushNewArray: size (size < 0 or: [size > 127]) ifTrue: [^self outOfRangeError: 'size' index: size range: 0 to: 127]. "138 10001010 0kkkkkkk Push (Array new: kkkkkkk)" stream nextPut: 138; nextPut: size! ! !EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:04'! genStorePopRemoteTemp: tempIndex inVectorAt: tempVectorIndex "142 10001110 kkkkkkkk jjjjjjjj Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" (tempIndex >= 0 and: [tempIndex < 256 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: [stream nextPut: 142; nextPut: tempIndex; nextPut: tempVectorIndex. ^self]. tempIndex >= 256 ifTrue: [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. tempVectorIndex >= 256 ifTrue: [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! !EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:04'! genStoreRemoteTemp: tempIndex inVectorAt: tempVectorIndex "141 10001101 kkkkkkkk jjjjjjjj Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" (tempIndex >= 0 and: [tempIndex < 256 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: [stream nextPut: 141; nextPut: tempIndex; nextPut: tempVectorIndex. ^self]. tempIndex >= 256 ifTrue: [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. tempVectorIndex >= 256 ifTrue: [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! !EncoderForLongFormV3PlusClosures methodsFor: 'testing' stamp: 'eem 5/24/2008 18:12'! supportsClosureOpcodes ^true! ! !EncoderForLongFormV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 6/16/2008 09:45'! genPushRemoteTemp: tempIndex inVectorAt: tempVectorIndex (tempIndex >= 0 and: [tempIndex < 256 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: ["140 10001100 kkkkkkkk jjjjjjjj Push Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" stream nextPut: 140; nextPut: tempIndex; nextPut: tempVectorIndex. ^self]. tempIndex >= 256 ifTrue: [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. tempVectorIndex >= 256 ifTrue: [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! !EncoderForV3 commentStamp: ''! I add behaviour to Encoder to size and emit bytecodes for the Squeak V3.x VM bytecode set. The intention is for another subclass to restrict the range of bytecodes used to long forms only, allowing the bytecode set to be redefined by avoiding using the many short forms. The short forms may then be reassigned.! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:59'! genBranchPopFalse: distance "See BlueBook page 596" distance < 0 ifTrue: [^self outOfRangeError: 'distance' index: distance range: 0 to: 1023]. (distance > 0 and: [distance < 9]) ifTrue: ["152-159 10011iii Pop and Jump 0n False iii +1 (i.e., 1 through 8)" stream nextPut: 152 + distance - 1. ^self]. distance < 1024 ifTrue: ["172-175 101011ii jjjjjjjj Pop and Jump On False ii *256+jjjjjjjj" stream nextPut: 172 + (distance bitShift: -8); nextPut: distance + 1024 \\ 256. ^self]. ^self outOfRangeError: 'distance' index: distance range: 0 to: 1023! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:43'! genStorePopInstVar: instVarIndex "See BlueBook page 596" instVarIndex >= 0 ifTrue: [instVarIndex < 8 ifTrue: ["96-103 01100iii Pop and Store Receiver Variable #iii" stream nextPut: 96 + instVarIndex. ^self]. instVarIndex < 64 ifTrue: ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 130; nextPut: instVarIndex. ^self]]. self genStorePopInstVarLong: instVarIndex! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:51'! genStoreInstVarLong: instVarIndex "See BlueBook page 596" "See also MaybeContextInstanceVariableNode" (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 160; nextPut: instVarIndex. ^self]. ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:00'! genSendSuper: selectorLiteralIndex numArgs: nArgs "See BlueBook page 596 (with exceptions for 132 & 134)" nArgs < 0 ifTrue: [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31 "!!!!"]. selectorLiteralIndex < 0 ifTrue: [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]. (selectorLiteralIndex < 32 and: [nArgs < 8]) ifTrue: [" 133 10000011 jjjkkkkk Send Literal Selector #kkkkk To Superclass With jjj Arguments" stream nextPut: 133; nextPut: ((nArgs bitShift: 5) + selectorLiteralIndex). ^self]. (selectorLiteralIndex < 256 and: [nArgs < 32]) ifTrue: ["In Squeak V3 132 10000100 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk With jjjjjjjj Arguments is replaced by 132 10000100 ooojjjjj kkkkkkkk ooo = 0 => Send Literal Selector #kkkkkkkk With jjjjj Arguments ooo = 1 => Send Literal Selector #kkkkkkkk To Superclass With jjjjj Arguments" stream nextPut: 132; nextPut: 32 + nArgs; nextPut: selectorLiteralIndex. ^self]. nArgs >= 32 ifTrue: [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31]. selectorLiteralIndex >= 256 ifTrue: [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:40'! genPushInstVar: instVarIndex "See BlueBook page 596" instVarIndex >= 0 ifTrue: [instVarIndex < 16 ifTrue: ["0-15 0000iiii Push Receiver Variable #iiii" stream nextPut: 0 + instVarIndex. ^self]. instVarIndex < 64 ifTrue: ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" stream nextPut: 128; nextPut: instVarIndex. ^self]]. self genPushInstVarLong: instVarIndex! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/15/2008 09:40'! genDup "See BlueBook page 596" "136 10001000 Duplicate Stack Top" stream nextPut: 136! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:40'! genReturnReceiver "See BlueBook page 596" "120-123 011110ii Return (receiver, true, false, nil) [ii] From Message" stream nextPut: 120! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:00'! genPushLiteral: literalIndex "See BlueBook page 596" literalIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. literalIndex < 32 ifTrue: ["32-63 001iiiii Push Literal Constant #iiiii" stream nextPut: 32 + literalIndex. ^self]. literalIndex < 64 ifTrue: ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" stream nextPut: 128; nextPut: 128 + literalIndex. ^self]. literalIndex < 256 ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 96; nextPut: literalIndex. ^self]. ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:35'! genReturnTop "See BlueBook page 596" "124-125 0111110i Return Stack Top From (Message, Block) [i]" stream nextPut: 124! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:01'! genStoreTemp: tempIndex "See BlueBook page 596" tempIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. tempIndex < 64 ifTrue: ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 129; nextPut: 64 + tempIndex. ^self]. ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:38'! genPushSpecialLiteral: aLiteral "112-119 01110iii Push (receiver, true, false, nil, -1, 0, 1, 2) [iii]" | index | index := #(true false nil -1 0 1 2) indexOf: aLiteral ifAbsent: 0. index = 0 ifTrue: [^self error: 'push special literal: ', aLiteral printString, ' is not one of true false nil -1 0 1 2']. stream nextPut: index + 112! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:01'! genStorePopTemp: tempIndex "See BlueBook page 596" tempIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. tempIndex < 8 ifTrue: ["104-111 01101iii Pop and Store Temporary Location #iii" stream nextPut: 104 + tempIndex. ^self]. tempIndex < 64 ifTrue: ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 130; nextPut: 64 + tempIndex. ^self]. ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:35'! genReturnTopToCaller "See BlueBook page 596" "124-125 0111110i Return Stack Top From (Message, Block) [i]" stream nextPut: 125! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 16:16'! genPushReceiver "See BlueBook page 596" "112-119 01110iii Push (receiver, true, false, nil, -1, 0, 1, 2) [iii]" stream nextPut: 112! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:00'! genPushTemp: tempIndex "See BlueBook page 596" tempIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63]. tempIndex < 16 ifTrue: ["16-31 0001iiii Push Temporary Location #iiii" stream nextPut: 16 + tempIndex. ^self]. tempIndex < 64 ifTrue: ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" stream nextPut: 128; nextPut: 64 + tempIndex. ^self]. ^self outOfRangeError: 'index' index: tempIndex range: 0 to: 63! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:37'! genStoreInstVar: instVarIndex "See BlueBook page 596" (instVarIndex >= 0 and: [instVarIndex < 64]) ifTrue: ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 129; nextPut: instVarIndex. ^self]. self genStoreInstVarLong: instVarIndex! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:59'! genBranchPopTrue: distance "See BlueBook page 596" distance < 0 ifTrue: [^self outOfRangeError: 'distance' index: distance range: 0 to: 1023]. distance < 1024 ifTrue: ["168-171 101010ii jjjjjjjj Pop and Jump On True ii *256+jjjjjjjj" stream nextPut: 168 + (distance bitShift: -8); nextPut: distance + 1024 \\ 256. ^self]. ^self outOfRangeError: 'distance' index: distance range: 0 to: 1023! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:39'! genReturnSpecialLiteral: aLiteral "120-123 011110ii Return (receiver, true, false, nil) [ii] From Message" | index | index := #(true false nil) indexOf: aLiteral ifAbsent: 0. index = 0 ifTrue: [^self error: 'return special literal: ', aLiteral printString, ' is not one of true false nil']. stream nextPut: 120 + index! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:41'! genJump: distance "See BlueBook page 596" (distance > 0 and: [distance < 9]) ifTrue: ["144-151 10010iii Jump iii + 1 (i.e., 1 through 8)" stream nextPut: 144 + distance - 1. ^self]. "160-167 10100iii jjjjjjjj Jump(iii - 4) *256+jjjjjjjj" ^self genJumpLong: distance! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:01'! genStoreLiteralVar: literalIndex "See BlueBook page 596" literalIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. literalIndex < 64 ifTrue: ["129 10000001 jjkkkkkk Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 129; nextPut: 192 + literalIndex. ^self]. literalIndex < 256 ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 224; nextPut: literalIndex. ^self]. ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:51'! genPushInstVarLong: instVarIndex "See BlueBook page 596" "See also MaybeContextInstanceVariableNode" (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 64; nextPut: instVarIndex. ^self]. ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:00'! genSend: selectorLiteralIndex numArgs: nArgs "See BlueBook page 596 (with exceptions for 132 & 134)" nArgs < 0 ifTrue: [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31 "!!!!"]. selectorLiteralIndex < 0 ifTrue: ["Special selector sends. 176-191 1011iiii Send Arithmetic Message #iiii 192-207 1100iiii Send Special Message #iiii" self flag: #yuck. (selectorLiteralIndex negated between: 176 and: 207) ifFalse: [^self outOfRangeError: 'special selector code' index: selectorLiteralIndex negated range: 176 to: 207]. stream nextPut: selectorLiteralIndex negated. ^self]. (selectorLiteralIndex < 16 and: [nArgs < 3]) ifTrue: [" 208-223 1101iiii Send Literal Selector #iiii With No Arguments 224-239 1110iiii Send Literal Selector #iiii With 1 Argument 240-255 1111iiii Send Literal Selector #iiii With 2 Arguments" stream nextPut: 208 + (nArgs * 16) + selectorLiteralIndex. ^self]. (selectorLiteralIndex < 32 and: [nArgs < 8]) ifTrue: [" 131 10000011 jjjkkkkk Send Literal Selector #kkkkk With jjj Arguments" stream nextPut: 131; nextPut: ((nArgs bitShift: 5) + selectorLiteralIndex). ^self]. (selectorLiteralIndex < 64 and: [nArgs < 4]) ifTrue: ["In Squeak V3 134 10000110 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk To Superclass With jjjjjjjj Arguments is replaced by 134 10000110 jjkkkkkk Send Literal Selector #kkkkkk With jj Arguments" stream nextPut: 134; nextPut: ((nArgs bitShift: 6) + selectorLiteralIndex). ^self]. (selectorLiteralIndex < 256 and: [nArgs < 32]) ifTrue: ["In Squeak V3 132 10000100 jjjjjjjj kkkkkkkk Send Literal Selector #kkkkkkkk With jjjjjjjj Arguments is replaced by 132 10000100 ooojjjjj kkkkkkkk ooo = 0 => Send Literal Selector #kkkkkkkk With jjjjj Arguments ooo = 1 => Send Literal Selector #kkkkkkkk To Superclass With jjjjj Arguments" stream nextPut: 132; nextPut: nArgs; nextPut: selectorLiteralIndex. ^self]. nArgs >= 32 ifTrue: [^self outOfRangeError: 'numArgs' index: nArgs range: 0 to: 31]. selectorLiteralIndex >= 256 ifTrue: [^self outOfRangeError: 'selector literal index' index: selectorLiteralIndex range: 0 to: 255]! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:01'! genStorePopLiteralVar: literalIndex "See BlueBook page 596" literalIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. literalIndex < 64 ifTrue: ["130 10000010 jjkkkkkk Pop and Store (Receiver Variable, Temporary Location, Illegal, Literal Variable) [jj] #kkkkkk" stream nextPut: 130; nextPut: 192 + literalIndex. ^self]. literalIndex < 256 ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 224; nextPut: literalIndex. self genPop. ^self]. ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:59'! genPushLiteralVar: literalIndex "See BlueBook page 596" literalIndex < 0 ifTrue: [^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255]. literalIndex < 32 ifTrue: ["64-95 010iiiii Push Literal Variable #iiiii" stream nextPut: 64 + literalIndex. ^self]. literalIndex < 64 ifTrue: ["128 10000000 jjkkkkkk Push (Receiver Variable, Temporary Location, Literal Constant, Literal Variable) [jj] #kkkkkk" stream nextPut: 128; nextPut: 192 + literalIndex. ^self]. literalIndex < 256 ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 128; nextPut: literalIndex. ^self]. ^self outOfRangeError: 'index' index: literalIndex range: 0 to: 255! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:36'! genPushThisContext "See BlueBook page 596" "137 10001001 Push Active Context" stream nextPut: 137! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 6/19/2008 08:52'! genStorePopInstVarLong: instVarIndex "See BlueBook page 596" "See also MaybeContextInstanceVariableNode" (instVarIndex >= 0 and: [instVarIndex < 256]) ifTrue: ["132 10000100 iiijjjjj kkkkkkkk (Send, Send Super, Push Receiver Variable, Push Literal Constant, Push Literal Variable, Store Receiver Variable, Store-Pop Receiver Variable, Store Literal Variable)[iii] #kkkkkkkk jjjjj" stream nextPut: 132; nextPut: 192; nextPut: instVarIndex. ^self]. ^self outOfRangeError: 'index' index: instVarIndex range: 0 to: 255! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 16:59'! genJumpLong: distance "See BlueBook page 596" (distance >= -1024 and: [distance < 1024]) ifTrue: ["160-167 10100iii jjjjjjjj Jump(iii - 4) *256+jjjjjjjj" stream nextPut: 160 + (distance + 1024 bitShift: -8); nextPut: distance + 1024 \\ 256. ^self]. ^self outOfRangeError: 'distance' index: distance range: -1024 to: 1023! ! !EncoderForV3 methodsFor: 'bytecode generation' stamp: 'eem 5/14/2008 17:27'! genPop "See BlueBook page 596" "135 10000111 Pop Stack Top" stream nextPut: 135! ! !EncoderForV3PlusClosures commentStamp: ''! An encoder for the V3 bytecode set augmented with the following bytecodes that are part of the full closure implementation. 138 10001010 jkkkkkkk Push (Array new: kkkkkkk) (j = 0) or Pop kkkkkkk elements into: (Array new: kkkkkkk) (j = 1) 140 10001100 kkkkkkkk jjjjjjjj Push Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 141 10001101 kkkkkkkk jjjjjjjj Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 142 10001110 kkkkkkkk jjjjjjjj Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj 143 10001111 llllkkkk jjjjjjjj iiiiiiii Push Closure Num Copied llll Num Args kkkk BlockSize jjjjjjjjiiiiiiii This is an exact duplicate of EncoderForLongFormV3PlusClosures. Could be a trait (or in Newspeak, a Mixin). For now we impose upon you to synchronise any and all changes between these two classes.! !EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:11'! genPushClosureCopyNumCopiedValues: numCopied numArgs: numArgs jumpSize: jumpSize "143 10001111 llllkkkk jjjjjjjj iiiiiiii Push Closure Num Copied llll Num Args kkkk BlockSize jjjjjjjjiiiiiiii" (jumpSize < 0 or: [jumpSize > 65535]) ifTrue: [^self outOfRangeError: 'block size' index: jumpSize range: 0 to: 65535]. (numCopied < 0 or: [numCopied > 15]) ifTrue: [^self outOfRangeError: 'num copied' index: numCopied range: 0 to: 15]. (numArgs < 0 or: [numArgs > 15]) ifTrue: [^self outOfRangeError: 'num args' index: numArgs range: 0 to: 15]. stream nextPut: 143; nextPut: numArgs + (numCopied bitShift: 4); nextPut: (jumpSize bitShift: -8); nextPut: (jumpSize bitAnd: 16rFF)! ! !EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:03'! genPushConsArray: size (size < 0 or: [size > 127]) ifTrue: [^self outOfRangeError: 'numElements' index: size range: 0 to: 127]. "138 10001010 1kkkkkkk Push (Array new: kkkkkkk)" stream nextPut: 138; nextPut: size + 128! ! !EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:06'! genPushNewArray: size (size < 0 or: [size > 127]) ifTrue: [^self outOfRangeError: 'numElements' index: size range: 0 to: 127]. "138 10001010 0kkkkkkk Pop kkkkkkk into: (Array new: kkkkkkk)" stream nextPut: 138; nextPut: size! ! !EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:02'! genStorePopRemoteTemp: tempIndex inVectorAt: tempVectorIndex "142 10001110 kkkkkkkk jjjjjjjj Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" (tempIndex >= 0 and: [tempIndex < 256 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: [stream nextPut: 142; nextPut: tempIndex; nextPut: tempVectorIndex. ^self]. tempIndex >= 256 ifTrue: [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. tempVectorIndex >= 256 ifTrue: [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! !EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 5/30/2008 17:02'! genStoreRemoteTemp: tempIndex inVectorAt: tempVectorIndex "141 10001101 kkkkkkkk jjjjjjjj Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" (tempIndex >= 0 and: [tempIndex < 256 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: [stream nextPut: 141; nextPut: tempIndex; nextPut: tempVectorIndex. ^self]. tempIndex >= 256 ifTrue: [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. tempVectorIndex >= 256 ifTrue: [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! !EncoderForV3PlusClosures methodsFor: 'testing' stamp: 'eem 5/24/2008 18:12'! supportsClosureOpcodes ^true! ! !EncoderForV3PlusClosures methodsFor: 'bytecode generation' stamp: 'eem 6/16/2008 09:45'! genPushRemoteTemp: tempIndex inVectorAt: tempVectorIndex (tempIndex >= 0 and: [tempIndex < 256 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: ["140 10001100 kkkkkkkk jjjjjjjj Push Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" stream nextPut: 140; nextPut: tempIndex; nextPut: tempVectorIndex. ^self]. tempIndex >= 256 ifTrue: [^self outOfRangeError: 'remoteTempIndex' index: tempIndex range: 0 to: 255]. tempVectorIndex >= 256 ifTrue: [^self outOfRangeError: 'tempVectorIndex' index: tempVectorIndex range: 0 to: 255]! ! !EntryCompletion commentStamp: 'AlainPlantec 11/29/2010 10:58'! An EntryCompletion is a handler for the driving of the completion menu in a PluggableTextFieldMorph. The completion menu is an IdentifierChooserMorph which is typically built and popup when a character is entered in a PluggableTextFieldMorph. Instance Variables chooseBlock: chooser: dataSourceBlock: filterBlock: previousToken: chooseBlock - One argument block which is evaluated when a token is chosen, the token is passed as argument chooser - The IdentifierChooserMorph which is currently opened dataSourceBlock - The block that is evaluated in order to get the list of items filterBlock - The block used to filter the dataSource list, it takes 2 args, the first is an item from the current dataSource list element, the second is the token fetched from the requestor (the PluggableTextFieldMorph). It returns true if the current dataSource list element is to be kept previousToken - Used to be able to not open the list if the current text in the PluggableTextFieldMorph was the previous chosen one ! !EntryCompletion methodsFor: 'event-handling' stamp: 'AlainPlantec 11/26/2010 15:55'! handlesKeyboard: anEvent ^ anEvent keyCharacter = Character arrowDown or: [chooser notNil and: [ anEvent keyCharacter = Character escape]]! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/24/2010 22:28'! choose: aToken chooseBlock ifNotNil: [self closeChooser. previousToken := aToken. chooseBlock value: aToken]! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/22/2010 16:04'! chooseBlock ^ chooseBlock! ! !EntryCompletion methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:38'! chooserWith: aToken | applicants | applicants := self filteredValuesWith: aToken. aToken ifNil: [applicants isEmpty ifFalse: [self setChooserWith: nil labels: applicants]] ifNotNil: [ | meaningfulApplicants | meaningfulApplicants := (applicants copyWithout: nil) asSet. meaningfulApplicants isEmpty ifFalse: [(meaningfulApplicants size = 1 and: [aToken = meaningfulApplicants anyOne]) ifFalse: [(previousToken isNil or: [previousToken size ~= aToken size]) ifTrue: [self setChooserWith: aToken labels: applicants]]]. previousToken := aToken]. ^ chooser! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 13:34'! setChooserWith: aToken labels: labels chooser ifNil: [chooser := IdentifierChooserMorph labels: labels chooseBlock: [:token | self choose: token]]. ^ chooser! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/29/2010 09:34'! openChooserWith: aToken from: aFieldMorph self closeChooser. self chooserWith: aToken. chooser ifNotNil: [ | baseColor | baseColor := aFieldMorph window ifNil: [aFieldMorph color veryMuchLighter] ifNotNil: [:w | w paneColor veryMuchLighter]. chooser baseColor: baseColor. chooser oneMenuOfWidth: aFieldMorph bounds width - aFieldMorph layoutInset - (aFieldMorph borderWidth * 2) - 2. chooser fillStyle: (aFieldMorph theme textEditorNormalFillStyleFor: aFieldMorph). chooser open. chooser requestor: aFieldMorph. chooser position: aFieldMorph bottomLeft + (aFieldMorph borderWidth @ 0). chooser boundsInWorld bottomLeft y > chooser allowedArea bottom ifTrue: [chooser forcesHeight: (chooser allowedArea bottom - (chooser boundsInWorld topLeft y + 2))]]. ^ chooser! ! !EntryCompletion methodsFor: 'event-handling' stamp: 'BenjaminVanRyseghem 9/8/2013 17:58'! closeIfNotNeeded: aMorph (chooser isNotNil and:[ chooser hasKeyboardFocus or: [ aMorph hasKeyboardFocus ] ]) ifFalse: [ self closeChooser ]! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/22/2010 16:04'! chooseBlock: aBlock chooseBlock := aBlock! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2010 10:20'! dataSourceBlock ^ dataSourceBlock ifNil: [dataSourceBlock := [:token | #()]]! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/24/2010 17:02'! filterBlock ^ filterBlock ifNil: [filterBlock := [:currApplicant :currText | true]]! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2010 09:06'! dataSourceBlock: aBlock dataSourceBlock := aBlock! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/23/2010 18:18'! filterBlock: aBlock filterBlock := aBlock! ! !EntryCompletion methodsFor: 'event-handling' stamp: 'AlainPlantec 11/27/2010 22:50'! keystroke: anEvent from: aMorph (self handlesKeyboard: anEvent) ifFalse: [^ false]. (chooser notNil and: [ anEvent keyCharacter = Character escape]) ifTrue: [self closeChooser. aMorph takeKeyboardFocus. ^ true]. (chooser isNil and: [ anEvent keyCharacter = Character arrowDown]) ifTrue: [previousToken := nil. self openChooserWith: aMorph textMorph text string from: aMorph. chooser ifNotNil: [^ true]]. ^ chooser ifNil: [false] ifNotNil: [chooser keyStroke: anEvent] ! ! !EntryCompletion methodsFor: 'event-handling' stamp: 'AlainPlantec 11/24/2010 22:19'! mouseDownFromTextMorph: anEvent self closeChooser! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2010 09:13'! positionChooser "Position the chooser to fit on the display." ! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2010 08:23'! positionChooser: aChooser "Position the list morph to fit on the display." aChooser boundsInWorld bottomLeft y + aChooser listHeight > aChooser world bottom ifTrue: [aChooser listMorph bounds: (aChooser boundsInWorld topLeft - (0 @ aChooser listHeight) extent: aChooser width @ aChooser listHeight)] ifFalse: [aChooser listMorph bounds: (aChooser boundsInWorld bottomLeft extent: aChooser width @ aChooser listHeight)] ! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 07:29'! filteredValuesWith: aToken ^ (self dataSourceBlock value: aToken) select: [:v | aToken isNil or: [v isNil or: [self filterBlock value: v value: aToken]]]! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/29/2010 08:57'! openChooserWithAllOrCloseFrom: aFieldMorph chooser ifNotNil: [self closeChooser] ifNil: [self openChooserWith: nil from: aFieldMorph]. ^ chooser! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/24/2010 21:30'! closeChooser chooser ifNotNil: [chooser close. chooser := nil]. ! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2010 20:12'! chooser ^ chooser! ! !EnvironmentChooser commentStamp: ''! I am widget for selecting environments.! !EnvironmentChooser methodsFor: 'updating' stamp: 'CamilloBruni 9/26/2013 19:59'! update self environmentsView emptyList. self enableGlobal ifTrue: [ self environmentsView addItemLabeled: 'System-wide' do: [ self environment: RBBrowserEnvironment new ]]. self environments do: [ :environemnt| |capturedValue| capturedValue := environemnt. self environmentsView addItemLabeled: capturedValue label do: [ self environment: capturedValue ]]. self enableCustom ifTrue: [ self environmentsView addItemLabeled: 'Custom...' do: [ self chooseNewEnvironment ifNotNil: [ :newEnvironment | self environment: newEnvironment ]]].! ! !EnvironmentChooser methodsFor: 'actions' stamp: 'CamilloBruni 10/1/2013 12:16'! chooseNewEnvironment | packagesAndClasses packages classes packageEnvironment classEnvironment | packagesAndClasses := PackageAndClassChooser new chooseModalTo: self window. (packagesAndClasses isNil or: [ packagesAndClasses isEmpty]) ifTrue: [ ^ nil ]. self flag: 'TODO create proper environments in a less ugly way'. packages := OrderedCollection new. classes := OrderedCollection new. packagesAndClasses do: [ :each | (each isKindOf: RPackage) ifTrue: [ packages add: each ] ifFalse: [ classes add: each ]]. packageEnvironment := RBPackageEnvironment packages: packages. classEnvironment := RBClassEnvironment classes: classes. classes ifEmpty: [ ^ packageEnvironment ]. packages ifEmpty: [ ^ classEnvironment ]. ^ packageEnvironment | classEnvironment! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 9/26/2013 00:50'! labelView ^ labelView ifNil: [ labelView := self instantiate: LabelModel. labelView text: 'Environment:' ]! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 11/17/2013 15:33'! enableCustom: aBoolean ^ enableCustom value: aBoolean! ! !EnvironmentChooser methodsFor: 'initialization' stamp: 'CamilloBruni 9/26/2013 01:07'! initializeWidgets environmentsHolder whenChangedDo: [ self update ]. enableCustom whenChangedDo: [ self update ]. enableGlobal whenChangedDo: [ self update ]. self update.! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 11/17/2013 15:33'! environment ^ environmentHolder value! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 11/17/2013 15:34'! environments: aCollection environmentsHolder value: aCollection! ! !EnvironmentChooser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize enableCustom := true asValueHolder. enableGlobal := true asValueHolder. environmentsHolder := #() asValueHolder. environmentHolder := nil asValueHolder. super initialize.! ! !EnvironmentChooser methodsFor: 'events' stamp: 'CamilloBruni 9/26/2013 01:10'! whenEnvironmentChanged: aBlock environmentHolder whenChangedDo: aBlock! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 9/26/2013 00:52'! label ^ self labelView text! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 11/17/2013 15:33'! environment: anEnvironment self environment = anEnvironment ifFalse: [ environmentHolder value: anEnvironment ]! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 11/17/2013 15:33'! enableCustom ^ enableCustom value! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 11/17/2013 15:33'! enableGlobal ^ enableGlobal value! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 11/17/2013 15:34'! environments ^ environmentsHolder value! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 9/26/2013 00:51'! environmentsView ^ environmentsView ifNil: [ environmentsView := self instantiate: DropListModel. ]! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 11/17/2013 15:33'! enableGlobal: aBoolean ^ enableGlobal value: aBoolean! ! !EnvironmentChooser methodsFor: 'accessing' stamp: 'CamilloBruni 9/26/2013 00:52'! label: aString self labelView text: aString! ! !EnvironmentChooser class methodsFor: 'specs' stamp: 'CamilloBruni 9/26/2013 00:50'! defaultSpec ^ SpecLayout composed newRow: [ :r| r add: #labelView width: 45; add: #environmentsView ]! ! !EqualityTester commentStamp: 'mjr 8/20/2003 13:04'! I provide a simple way to test the equality properties of any object.! !EqualityTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! resultFor: runs "Test that equality is the same over runs and answer the result" 1 to: runs do: [:i | self prototype = self prototype ifFalse: [^ false]]. ^ true! ! !Error commentStamp: ''! >From the ANSI standard: This protocol describes the behavior of instances of class Error. These are used to represent error conditions that prevent the normal continuation of processing. Actual error exceptions used by an application may be subclasses of this class. As Error is explicitly specified to be subclassable, conforming implementations must implement its behavior in a non-fragile manner. Additional notes: Error>defaultAction uses an explicit test for the presence of the Debugger class to decide whether or not it is in development mode. In the future, TFEI hopes to enhance the semantics of #defaultAction to improve support for pluggable default handlers.! !Error methodsFor: 'exceptiondescription' stamp: 'ajh 9/4/2002 19:24'! defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ! !Error methodsFor: 'private' stamp: 'ajh 2/1/2003 00:54'! isResumable "Determine whether an exception is resumable." ^ false! ! !Error methodsFor: '*SUnit-Core' stamp: 'NiallRoss 7/18/2010 11:59'! sunitAnnounce: aTestCase toResult: aTestResult aTestResult addError: aTestCase. self sunitExitWith: false.! ! !ErrorDialogWindow commentStamp: 'gvc 5/18/2007 14:51'! A message dialog with an error icon.! !ErrorDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon "Answer an icon for the receiver." ^ Smalltalk ui icons errorIcon! ! !ErrorDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallErrorIcon! ! !ErrorNonInteractive commentStamp: 'IgorStasenko 1/25/2011 13:29'! This error thrown when image runs in non-interactive mode (no user intervention possible nor expected), but application trying to use tools which require user's intervention. For example, in headless image application trying to query a user name, or dialog to confirm with proceeding some action.! !ErrorNonInteractive methodsFor: 'accessing' stamp: 'IgorStasenko 1/24/2011 10:36'! exception: anError exception := anError! ! !ErrorNonInteractive methodsFor: 'accessing' stamp: 'MarcusDenker 12/2/2013 14:06'! description ^ String streamContents: [ :s | s nextPutAll: 'An attempt to use interactive tools detected, while in non-interactive mode'. self messageText ifNotEmpty: [ :message| s cr; tab; nextPutAll: message ]. self exception ifNotNil: [ :ex | s cr; tab; print: ex ]].! ! !ErrorNonInteractive methodsFor: 'accessing' stamp: 'IgorStasenko 1/24/2011 10:36'! exception ^ exception! ! !ErrorNonInteractive methodsFor: 'exceptiondescription' stamp: 'CamilloBruni 7/24/2012 16:22'! defaultAction " log error and quit " ^ UIManager default quitFrom: self signalerContext withMessage: self description! ! !ErrorNonInteractive class methodsFor: 'signalling' stamp: 'IgorStasenko 1/24/2011 10:34'! signalForException: anError ^ self new exception: anError; signal! ! !ErrorState commentStamp: ''! I am the state when there was an error during the loading! !ErrorState methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:23'! image ^ Smalltalk ui icons smallCancelIcon asMorph! ! !EternalCookie commentStamp: ''! An EternalCookie is a cookie that live forever. Actualy not eternal, but will last one year! !EternalCookie methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/9/2012 10:35'! defaultTimeToLive ^ Year new duration! ! !EvaluateCommandLineHandler commentStamp: ''! Usage: eval [--help] [--save] [ --no-quit ] --help list this help message --save save the image after evaluation of the expression --no-quit if specified, the image continues runing after evaluating the a valid Smalltalk expression which is evaluated and the result is printed on stdout Documentation: A CommandLineHandler that reads a string from the command line, outputs the evaluated result and quits the image. This handler either evaluates the arguments passed to the image: pharo Pharo.image eval 1 + 2 or it can read directly from stdin: echo "1+2" | $PHARO_VM my.image eval Important: don't manually save the image at the end of the expression by calling something like 'Smalltalk snapshot: true andSave: true'!! Instead, use the safer --save option.! !EvaluateCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 5/26/2013 16:14'! evaluateArguments | argumentString | argumentString := self argumentString. argumentString ifEmpty: [ ^ self ]. self evaluate: argumentString! ! !EvaluateCommandLineHandler methodsFor: 'commands' stamp: 'MarcusDenker 5/21/2013 16:31'! evaluate: aStream | result exceptionClassToUse | "workaround to make old Compiler unloadable" exceptionClassToUse := (Smalltalk compilerClass == OpalCompiler) ifTrue: [OCSemanticWarning] ifFalse: [Smalltalk globals at: #ParserNotification]. [ result := Smalltalk evaluate: aStream. self hasSessionChanged ifFalse: [ self stdout print: result; lf ] ] on: Error, ParserNotification do: [ :error | self handleError: error ].! ! !EvaluateCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 6/1/2013 11:18'! argumentString | arguments skipArguments | "Now this is ugly... Coral would be nice here!! Basically we strip skipArguments if, and only if they appear at the beginning of arguments" skipArguments := #( '--no-quit' '--save' '-e'). arguments := (skipArguments includes: self arguments first) ifFalse: [ self arguments ] ifTrue: [ (self arguments size >= 2 and: [ skipArguments includes: self arguments second ]) ifTrue: [ self arguments allButFirst: 2 ] ifFalse: [ self arguments allButFirst ]]. ^ arguments joinUsing: Character space.! ! !EvaluateCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 5/29/2013 15:51'! activate self activateHelp ifTrue: [ ^ self ]. self arguments ifEmpty: [ ^ self evaluateStdIn ]. self evaluateArguments. (self hasOption: 'save') ifTrue: [ ^ Smalltalk snapshot: true andQuit: (self hasOption: 'no-quit') not ]. (self hasOption: 'no-quit') ifFalse: [ self quit ]! ! !EvaluateCommandLineHandler methodsFor: 'activation' stamp: 'MarcusDenker 12/2/2013 14:06'! evaluateStdIn | stdin | stdin := FileStream stdin ifNil: [ ^ self ]. stdin atEnd ifTrue: [ ^ self ]. self flag: #todo. "the whole compilation machinery does not work with stdin directly, hence we load everything a buffer first" self evaluate: (String streamContents: [ :s| [ stdin atEnd ] whileFalse: [ stdin next ifNotNil: [ :char| s nextPut: char ]]])! ! !EvaluateCommandLineHandler class methodsFor: 'handler selection' stamp: 'CamilloBruni 7/4/2012 00:20'! isResponsibleFor: commandLineArguments "directly handle top-level -e and --evaluate options" commandLineArguments withFirstArgument: [ :arg| (#('-e' '--evaluate') includes: arg) ifTrue: [ ^ true ]]. ^ commandLineArguments includesSubCommand: self commandName! ! !EvaluateCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 2/6/2013 18:16'! description ^ 'Directly evaluates passed in one line scripts'! ! !EvaluateCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 4/28/2012 22:48'! commandName ^ 'eval'! ! !EventHandler commentStamp: ''! Events in Morphic originate in a Hand, pass to a target morph, and are then dispatched by an EventHandler. EventHandlers support redirection of mouse and keyboard activity by specifying and independent recipient object and message selector for each of the possible events. In addition each eventHandler can supply an optional value parameter for distinguishing between, eg, events from a number of otherwise identical source morphs. The basic protocol of an event handler is to receive a message of the form mouseDown: event in: targetMorph and redirect this as one of mouseDownRecipient perform: mouseDownSelector0 mouseDownRecipient perform: mouseDownSelector1 with: event mouseDownRecipient perform: mouseDownSelector2 with: event with: targetMorph mouseDownRecipient perform: mouseDownSelector3 with: event with: targetMorph with: valueParameter depending on the arity of the mouseDownSelector. ! !EventHandler methodsFor: 'events' stamp: 'ar 10/7/2000 22:55'! click: event fromMorph: sourceMorph "This message is sent only when double clicks are handled." ^ self send: clickSelector to: clickRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 18:27'! mouseStillDownSelector ^mouseStillDownSelector! ! !EventHandler methodsFor: 'copying' stamp: 'tk 1/22/2001 17:43'! veryDeepFixupWith: deepCopier | old | "ALL inst vars were weakly copied. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. 1 to: self class instSize do: [:ii | old := self instVarAt: ii. self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old])]. ! ! !EventHandler methodsFor: 'access' stamp: ''! messageList "Return a list of 'Class selector' for each message I can send. tk 9/13/97" | list | self flag: #mref. "is this still needed? I replaced the one use that I could spot with #methodRefList " list := SortedCollection new. mouseDownRecipient ifNotNil: [list add: (mouseDownRecipient class whichClassIncludesSelector: mouseDownSelector) name , ' ' , mouseDownSelector]. mouseMoveRecipient ifNotNil: [list add: (mouseMoveRecipient class whichClassIncludesSelector: mouseMoveSelector) name , ' ' , mouseMoveSelector]. mouseStillDownRecipient ifNotNil: [list add: (mouseStillDownRecipient class whichClassIncludesSelector: mouseStillDownSelector) name , ' ' , mouseStillDownSelector]. mouseUpRecipient ifNotNil: [list add: (mouseUpRecipient class whichClassIncludesSelector: mouseUpSelector) name , ' ' , mouseUpSelector]. mouseEnterRecipient ifNotNil: [list add: (mouseEnterRecipient class whichClassIncludesSelector: mouseEnterSelector) name , ' ' , mouseEnterSelector]. mouseLeaveRecipient ifNotNil: [list add: (mouseLeaveRecipient class whichClassIncludesSelector: mouseLeaveSelector) name , ' ' , mouseLeaveSelector]. mouseEnterDraggingRecipient ifNotNil: [list add: (mouseEnterDraggingRecipient class whichClassIncludesSelector: mouseEnterDraggingSelector) name , ' ' , mouseEnterDraggingSelector]. mouseLeaveDraggingRecipient ifNotNil: [list add: (mouseLeaveDraggingRecipient class whichClassIncludesSelector: mouseLeaveDraggingSelector) name , ' ' , mouseLeaveDraggingSelector]. doubleClickRecipient ifNotNil: [list add: (doubleClickRecipient class whichClassIncludesSelector: doubleClickSelector) name , ' ' , doubleClickSelector]. keyStrokeRecipient ifNotNil: [list add: (keyStrokeRecipient class whichClassIncludesSelector: keyStrokeSelector) name , ' ' , keyStrokeSelector]. ^ list! ! !EventHandler methodsFor: 'testing' stamp: 'nk 2/15/2004 08:13'! handlesMouseDown: evt mouseDownRecipient ifNotNil: [^ true]. mouseStillDownRecipient ifNotNil: [^ true]. mouseUpRecipient ifNotNil: [^ true]. (self handlesClickOrDrag: evt) ifTrue:[^true]. ^self handlesGestureStart: evt! ! !EventHandler methodsFor: 'events' stamp: 'di 9/15/1998 16:35'! mouseEnterDragging: event fromMorph: sourceMorph ^ self send: mouseEnterDraggingSelector to: mouseEnterDraggingRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'events' stamp: 'mir 5/23/2000 17:43'! startDrag: event fromMorph: sourceMorph ^ self send: startDragSelector to: startDragRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'testing' stamp: ''! handlesMouseOver: evt mouseEnterRecipient ifNotNil: [^ true]. mouseLeaveRecipient ifNotNil: [^ true]. ^ false! ! !EventHandler methodsFor: 'testing' stamp: 'nk 2/15/2004 08:57'! handlesGestureStart: evt "Does the associated morph want to handle gestures?" ^false! ! !EventHandler methodsFor: 'access' stamp: 'di 9/14/1998 08:32'! mouseUpSelector ^ mouseUpSelector! ! !EventHandler methodsFor: 'initialization' stamp: 'nk 2/15/2004 08:59'! onGestureSend: selector to: recipient! ! !EventHandler methodsFor: 'events' stamp: ''! keyStroke: event fromMorph: sourceMorph ^ self send: keyStrokeSelector to: keyStrokeRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'initialization' stamp: 'MarcusDenker 9/13/2013 14:05'! on: eventName send: selector to: recipient withValue: value selector numArgs = 3 ifFalse: [self error: 'Warning: value parameters are passed as first of 3 arguments']. self on: eventName send: selector to: recipient. valueParameter := value ! ! !EventHandler methodsFor: 'printing' stamp: 'nice 1/5/2010 15:59'! printOn: aStream | recipients | super printOn: aStream. #('mouseDownSelector' 'mouseStillDownSelector' 'mouseUpSelector' 'mouseEnterSelector' 'mouseLeaveSelector' 'mouseEnterDraggingSelector' 'mouseLeaveDraggingSelector' 'doubleClickSelector' 'keyStrokeSelector') do: [:aName | | aVal | (aVal := self instVarNamed: aName) notNil ifTrue: [aStream nextPutAll: '; ' , aName , '=' , aVal]]. (recipients := self allRecipients) notEmpty ifTrue: [aStream nextPutAll: ' recipients: '. recipients printOn: aStream]! ! !EventHandler methodsFor: 'events' stamp: ''! mouseUp: event fromMorph: sourceMorph ^ self send: mouseUpSelector to: mouseUpRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 17:34'! firstMouseSelector "Answer the selector corresponding to the first mouse-handling selector fielded. Created in support of providing balloon-help for halo handles, triggered by the selector handled" mouseDownSelector ifNotNil: [^ mouseDownSelector]. mouseMoveSelector ifNotNil:[^mouseMoveSelector]. mouseStillDownSelector ifNotNil: [^ mouseStillDownSelector]. mouseUpSelector ifNotNil: [^ mouseUpSelector]. mouseEnterSelector ifNotNil: [^ mouseEnterSelector]. mouseLeaveSelector ifNotNil: [^ mouseLeaveSelector]. mouseEnterDraggingSelector ifNotNil: [^ mouseEnterDraggingSelector]. mouseLeaveDraggingSelector ifNotNil: [^ mouseLeaveDraggingSelector]. doubleClickSelector ifNotNil: [^ doubleClickSelector]. ^ nil! ! !EventHandler methodsFor: 'events' stamp: 'jcg 9/21/2001 13:06'! doubleClickTimeout: event fromMorph: sourceMorph ^ self send: doubleClickTimeoutSelector to: doubleClickTimeoutRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'testing' stamp: 'di 9/15/1998 16:35'! handlesMouseOverDragging: evt mouseEnterDraggingRecipient ifNotNil: [^ true]. mouseLeaveDraggingRecipient ifNotNil: [^ true]. ^ false! ! !EventHandler methodsFor: 'testing' stamp: 'ar 10/25/2000 17:33'! handlesMouseMove: evt ^mouseMoveRecipient notNil and:[mouseMoveSelector notNil]! ! !EventHandler methodsFor: 'access' stamp: 'di 9/14/1998 08:32'! mouseDownSelector ^ mouseDownSelector! ! !EventHandler methodsFor: 'events' stamp: ''! mouseStillDown: event fromMorph: sourceMorph ^ self send: mouseStillDownSelector to: mouseStillDownRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 17:33'! allRecipients "Answer a list, without duplication, of all the objects serving as recipients to any of the events I handle. Intended for debugging/documentation use only" | aList | aList := OrderedCollection with: mouseDownRecipient with: mouseStillDownRecipient with: mouseUpRecipient with: mouseEnterRecipient with: mouseLeaveRecipient. aList addAll: (OrderedCollection with: mouseEnterDraggingRecipient with: mouseLeaveDraggingRecipient with: doubleClickRecipient with: keyStrokeRecipient). aList add: mouseMoveRecipient. ^ (aList copyWithout: nil) asSet asArray! ! !EventHandler methodsFor: 'testing' stamp: 'ar 10/7/2000 22:56'! handlesClickOrDrag: evt clickRecipient ifNotNil:[^true]. doubleClickRecipient ifNotNil:[^true]. startDragRecipient ifNotNil:[^true]. ^false! ! !EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 18:27'! mouseStillDownRecipient ^mouseStillDownRecipient! ! !EventHandler methodsFor: 'events' stamp: 'di 9/15/1998 16:35'! mouseLeaveDragging: event fromMorph: sourceMorph ^ self send: mouseLeaveDraggingSelector to: mouseLeaveDraggingRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'testing' stamp: 'ar 10/28/2000 22:17'! handlesKeyboard: evt keyStrokeRecipient ifNotNil: [^ true]. ^ false! ! !EventHandler methodsFor: 'access' stamp: 'CamilloBruni 8/1/2012 16:11'! methodRefList "Return a MethodReference for each message I can send." | list adder | list := SortedCollection new. adder := [:recip :sel | recip ifNotNil: [list add: (RGMethodDefinition realClass: (recip class whichClassIncludesSelector: sel) selector: sel)]]. adder value: mouseDownRecipient value: mouseDownSelector. adder value: mouseMoveRecipient value: mouseMoveSelector. adder value: mouseStillDownRecipient value: mouseStillDownSelector. adder value: mouseUpRecipient value: mouseUpSelector. adder value: mouseEnterRecipient value: mouseEnterSelector. adder value: mouseLeaveRecipient value: mouseLeaveSelector. adder value: mouseEnterDraggingRecipient value: mouseEnterDraggingSelector. adder value: mouseLeaveDraggingRecipient value: mouseLeaveDraggingSelector. adder value: doubleClickRecipient value: doubleClickSelector. adder value: keyStrokeRecipient value: keyStrokeSelector. ^ list! ! !EventHandler methodsFor: 'events' stamp: ''! mouseEnter: event fromMorph: sourceMorph ^ self send: mouseEnterSelector to: mouseEnterRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'initialization' stamp: 'nk 2/15/2004 08:16'! on: eventName send: selector to: recipient eventName == #mouseDown ifTrue: [mouseDownRecipient := recipient. mouseDownSelector := selector. ^ self]. eventName == #mouseMove ifTrue: [mouseMoveRecipient := recipient. mouseMoveSelector := selector. ^ self]. eventName == #mouseStillDown ifTrue: [mouseStillDownRecipient := recipient. mouseStillDownSelector := selector. ^ self]. eventName == #mouseUp ifTrue: [mouseUpRecipient := recipient. mouseUpSelector := selector. ^ self]. eventName == #mouseEnter ifTrue: [mouseEnterRecipient := recipient. mouseEnterSelector := selector. ^ self]. eventName == #mouseLeave ifTrue: [mouseLeaveRecipient := recipient. mouseLeaveSelector := selector. ^ self]. eventName == #mouseEnterDragging ifTrue: [mouseEnterDraggingRecipient := recipient. mouseEnterDraggingSelector := selector. ^ self]. eventName == #mouseLeaveDragging ifTrue: [mouseLeaveDraggingRecipient := recipient. mouseLeaveDraggingSelector := selector. ^ self]. eventName == #click ifTrue: [clickRecipient := recipient. clickSelector := selector. ^ self]. eventName == #doubleClick ifTrue: [doubleClickRecipient := recipient. doubleClickSelector := selector. ^ self]. eventName == #doubleClickTimeout ifTrue: [doubleClickTimeoutRecipient := recipient. doubleClickTimeoutSelector := selector. ^ self]. eventName == #startDrag ifTrue: [startDragRecipient := recipient. startDragSelector := selector. ^ self]. eventName == #keyStroke ifTrue: [keyStrokeRecipient := recipient. keyStrokeSelector := selector. ^ self]. eventName == #gesture ifTrue: [ ^self onGestureSend: selector to: recipient ]. self error: 'Event name, ' , eventName , ' is not recognizable.' ! ! !EventHandler methodsFor: 'events' stamp: ''! mouseLeave: event fromMorph: sourceMorph ^ self send: mouseLeaveSelector to: mouseLeaveRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'events' stamp: 'LC 2/14/2000 08:38'! doubleClick: event fromMorph: sourceMorph ^ self send: doubleClickSelector to: doubleClickRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'events' stamp: 'ar 3/17/2001 14:34'! send: selector to: recipient withEvent: event fromMorph: sourceMorph | arity | recipient ifNil: [^ self]. arity := selector numArgs. arity = 0 ifTrue: [^ recipient perform: selector]. arity = 1 ifTrue: [^ recipient perform: selector with: event]. arity = 2 ifTrue: [^ recipient perform: selector with: event with: sourceMorph]. arity = 3 ifTrue: [^ recipient perform: selector with: valueParameter with: event with: sourceMorph]. self error: 'Event handling selectors must be Symbols and take 0-3 arguments'! ! !EventHandler methodsFor: 'events' stamp: 'ar 10/7/2000 22:54'! mouseDown: event fromMorph: sourceMorph "Take double-clicks into account." ((self handlesClickOrDrag: event) and:[event redButtonPressed]) ifTrue:[ event hand waitForClicksOrDrag: sourceMorph event: event. ]. ^self send: mouseDownSelector to: mouseDownRecipient withEvent: event fromMorph: sourceMorph. ! ! !EventHandler methodsFor: 'events' stamp: 'ar 10/25/2000 17:32'! mouseMove: event fromMorph: sourceMorph ^ self send: mouseMoveSelector to: mouseMoveRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'testing' stamp: 'ar 10/22/2000 17:05'! handlesMouseStillDown: evt ^mouseStillDownRecipient notNil and:[mouseStillDownSelector notNil]! ! !EventHandlerPlus commentStamp: 'gvc 5/18/2007 13:13'! Support for handling mouseOver events (no button down).! !EventHandlerPlus methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 8/21/2011 17:51'! methodRefList "Return a MethodReference for each message I can send." |list sel| list := super methodRefList. sel := mouseOverSelector. mouseOverRecipient ifNotNil: [:recipient | list add: (RGMethodDefinition realClass: (recipient class whichClassIncludesSelector: sel) selector: sel)]. ^list! ! !EventHandlerPlus methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 17:24'! on: eventName send: selector to: recipient "Register the selector and recipient for the given event name." eventName == #mouseOver ifTrue: [mouseOverRecipient := recipient. mouseOverSelector := selector. ^ self]. ^super on: eventName send: selector to: recipient! ! !EventHandlerPlus methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 17:19'! handlesMouseOver: evt "Answer whether we can handle the event." mouseOverRecipient ifNotNil: [^ true]. ^super handlesMouseOver: evt! ! !EventHandlerPlus methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 17:20'! mouseOver: event fromMorph: sourceMorph "Relay the event." ^ self send: mouseOverSelector to: mouseOverRecipient withEvent: event fromMorph: sourceMorph! ! !EventManager commentStamp: 'tlk 5/7/2006 20:01'! An EventManager is used to registers a 'observer' object's interest in in changes to an 'observed' object. Then when the observered object is changed, EventManager broadcasts the an update message to all objects with a registered interest. Finally, the Event manager can be used to remove an object from the list of observer object. An interested object is said to be a dependant on the target object. Registering an interest in an event is called adding a dependant. Deregistering is called removing a dependant. The EventManager's action map is a WeakIdentityDictionary that maps events (selectors) to dependants (objects & selectors) in a way that ensures the mapping is to specific objects (hence identity) and in a way that allows the object to be garbage collected if not other used (hence weak.) EventManager class has ActionMaps which has one actionMap for each object. Classic uses of an EventManager are to implement the Observer Pattern, see ChangeNotification or the MorphicModle as examples.! !EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:38'! updateableActionMap actionMap == nil ifTrue: [actionMap := self createActionMap]. ^actionMap! ! !EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'! removeDependent: anObject "Remove the given object as one of the receiver's dependents." self removeActionsWithReceiver: anObject forEvent: self changedEventSelector. ^ anObject! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 3/3/2001 10:07'! changedEventSelector ^#changed:! ! !EventManager methodsFor: 'copying' stamp: 'StephaneDucasse 10/2/2010 17:00'! postCopy super postCopy. self release! ! !EventManager methodsFor: 'updating' stamp: 'reThink 3/3/2001 10:20'! changed: aParameter "Receiver changed. The change is denoted by the argument aParameter. Usually the argument is a Symbol that is part of the dependent's change protocol. Inform all of the dependents." self triggerEvent: self changedEventSelector with: aParameter! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 3/3/2001 10:07'! updateEventSelector ^#update:! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:39'! releaseActionMap actionMap := nil! ! !EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'! addDependent: anObject "Make the given object one of the receiver's dependents." self when: self changedEventSelector send: self updateEventSelector to: anObject. ^anObject! ! !EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:18'! dependents ^(self actionSequenceForEvent: self changedEventSelector) asSet collect: [:each | each receiver]! ! !EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'! breakDependents "Remove all of the receiver's dependents." self removeActionsForEvent: self changedEventSelector! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:37'! actionMap ^actionMap == nil ifTrue: [self createActionMap] ifFalse: [actionMap]! ! !EventManager class methodsFor: 'accessing' stamp: 'nice 4/19/2011 00:02'! actionMaps ^ActionMaps ifNil: [ActionMaps := WeakIdentityKeyDictionary new]! ! !EventManager class methodsFor: 'accessing' stamp: 'reThink 2/18/2001 14:42'! actionMapFor: anObject ^self actionMaps at: anObject ifAbsent: [self createActionMap]! ! !EventManager class methodsFor: 'initialization' stamp: 'MarcusDenker 10/2/2013 20:16'! flushEvents "Object flushEvents" self actionMaps keysAndValuesDo:[:rcvr :evtDict| rcvr ifNotNil:[ "make sure we don't modify evtDict while enumerating" evtDict keysDo: [:evtName| | msgSet | msgSet := evtDict at: evtName ifAbsent:[nil]. (msgSet == nil) ifTrue:[rcvr removeActionsForEvent: evtName]]]]. EventManager actionMaps finalizeValues. ! ! !EventManager class methodsFor: 'accessing' stamp: 'reThink 2/25/2001 08:52'! updateableActionMapFor: anObject ^self actionMaps at: anObject ifAbsentPut: [self createActionMap]! ! !EventManager class methodsFor: 'releasing' stamp: 'reThink 2/18/2001 15:34'! releaseActionMapFor: anObject self actionMaps removeKey: anObject ifAbsent: []! ! !EventManager class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 22:22'! cleanUp: aggressive "Dump all ActionMaps but only when we're aggressively cleaning" aggressive ifTrue: [ActionMaps := nil].! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! getFalse ^false! ! !EventManagerTest methodsFor: 'running-dependent action' stamp: 'ar 8/26/2009 21:37'! testBlockReceiverOneArg eventSource when: #anEvent: evaluate:[:arg1| eventListener add: arg1]. eventSource triggerEvent: #anEvent: with: 9. self should: [eventListener includes: 9]! ! !EventManagerTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:01'! testRemoveActionsTwiceForEvent eventSource when: #anEvent send: #size to: eventListener; when: #anEvent send: #getTrue to: self; when: #anEvent: send: #fizzbin to: self. eventSource removeActionsForEvent: #anEvent. self assert: (eventSource hasActionForEvent: #anEvent) not. eventSource removeActionsForEvent: #anEvent. self assert: (eventSource hasActionForEvent: #anEvent) not.! ! !EventManagerTest methodsFor: 'running-dependent action' stamp: 'ar 8/26/2009 21:37'! testBlockReceiverNoArgs eventSource when: #anEvent evaluate:[self heardEvent]. eventSource triggerEvent: #anEvent. self should: [succeeded]! ! !EventManagerTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'! addArg1: arg1 addArg2: arg2 eventListener add: arg1; add: arg2! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:20'! heardEvent succeeded := true! ! !EventManagerTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'! testNoArgumentEvent eventSource when: #anEvent send: #heardEvent to: self. eventSource triggerEvent: #anEvent. self should: [succeeded]! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! getTrue ^true! ! !EventManagerTest methodsFor: 'running-broadcast query' stamp: 'jws 11/28/2000 15:52'! testSingleValueSupplier eventSource when: #needsValue send: #getTrue to: self. succeeded := eventSource triggerEvent: #needsValue. self should: [succeeded]! ! !EventManagerTest methodsFor: 'running-dependent action' stamp: 'JWS 9/7/2000 17:20'! testTwoArgumentEvent eventSource when: #anEvent:info: send: #addArg1:addArg2: to: self. eventSource triggerEvent: #anEvent:info: withArguments: #( 9 42 ). self should: [(eventListener includes: 9) and: [eventListener includes: 42]]! ! !EventManagerTest methodsFor: 'running-dependent action' stamp: 'ar 8/26/2009 21:38'! testBlockReceiverTwoArgs eventSource when: #anEvent:info: evaluate:[:arg1 :arg2| self addArg1: arg1 addArg2: arg2]. eventSource triggerEvent: #anEvent:info: withArguments: #( 9 42 ). self should: [(eventListener includes: 9) and: [eventListener includes: 42]]! ! !EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'! testReturnValueWithOneListener | value | eventSource when: #needsValue send: #yourself to: eventListener. value := eventSource triggerEvent: #needsValue. self should: [value == eventListener]! ! !EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'! testReturnValueWithNoListeners | value | value := eventSource triggerEvent: #needsValue. self should: [value == nil]! ! !EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:21'! testMultipleValueSuppliers eventSource when: #needsValue send: #getFalse to: self. eventSource when: #needsValue send: #getTrue to: self. succeeded := eventSource triggerEvent: #needsValue. self should: [succeeded]! ! !EventManagerTest methodsFor: 'running' stamp: 'jws 11/28/2000 16:25'! tearDown eventSource releaseActionMap. eventSource := nil. eventListener := nil. super tearDown. ! ! !EventManagerTest methodsFor: 'running-dependent action supplied arguments' stamp: 'JWS 9/7/2000 17:20'! testNoArgumentEventDependentSuppliedArgument eventSource when: #anEvent send: #add: to: eventListener with: 'boundValue'. eventSource triggerEvent: #anEvent. self should: [eventListener includes: 'boundValue']! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! getTrue: anArg ^true! ! !EventManagerTest methodsFor: 'running' stamp: 'JWS 9/7/2000 17:19'! setUp super setUp. eventSource := EventManager new. eventListener := Bag new. succeeded := false! ! !EventManagerTest methodsFor: 'running-dependent action supplied arguments' stamp: 'JWS 9/7/2000 17:21'! testNoArgumentEventDependentSuppliedArguments eventSource when: #anEvent send: #addArg1:addArg2: to: self withArguments: #('hello' 'world'). eventSource triggerEvent: #anEvent. self should: [(eventListener includes: 'hello') and: [eventListener includes: 'world']]! ! !EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'! testReturnValueWithManyListeners | value newListener | newListener := 'busybody'. eventSource when: #needsValue send: #yourself to: eventListener. eventSource when: #needsValue send: #yourself to: newListener. value := eventSource triggerEvent: #needsValue. self should: [value == newListener]! ! !EventManagerTest methodsFor: 'running-remove actions' stamp: 'gk 8/14/2007 23:51'! testRemoveActionsWithReceiver | action | eventSource when: #anEvent send: #size to: eventListener; when: #anEvent send: #getTrue to: self; when: #anEvent: send: #fizzbin to: self. self assert: (eventSource hasActionsWithReceiver: self). eventSource removeActionsWithReceiver: self. action := eventSource actionForEvent: #anEvent. self assert: (action respondsTo: #receiver). self assert: ((action receiver == self) not). self assert: ((eventSource hasActionsWithReceiver: self) not)! ! !EventManagerTest methodsFor: 'running-copying' stamp: 'SqR 11/12/2000 19:38'! testCopy "Ensure that the actionMap is zapped when you make a copy of anEventManager" eventSource when: #blah send: #yourself to: eventListener. self assert: eventSource actionMap keys isEmpty not. self assert: eventSource copy actionMap keys isEmpty! ! !EventManagerTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:01'! testRemoveActionsForEvent eventSource when: #anEvent send: #size to: eventListener; when: #anEvent send: #getTrue to: self; when: #anEvent: send: #fizzbin to: self. eventSource removeActionsForEvent: #anEvent. self shouldnt: [eventSource hasActionForEvent: #anEvent]! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! getFalse: anArg ^false! ! !EventManagerTest methodsFor: 'running-dependent action' stamp: 'JWS 9/7/2000 17:20'! testOneArgumentEvent eventSource when: #anEvent: send: #add: to: eventListener. eventSource triggerEvent: #anEvent: with: 9. self should: [eventListener includes: 9]! ! !EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:21'! testMultipleValueSuppliersEventHasArguments eventSource when: #needsValue: send: #getFalse: to: self. eventSource when: #needsValue: send: #getTrue: to: self. succeeded := eventSource triggerEvent: #needsValue: with: 'kolme'. self should: [succeeded]! ! !EventSensorConstants commentStamp: 'LaurentLaffont 3/15/2011 20:48'! This is a constants, used by EventSensor to identify various event types and theirs contents. NOTE: A constant values should be kept in sync with VM-side, which are defined in sq.h header file.! !EventSensorConstants class methodsFor: 'pool initialization' stamp: 'John M McIntosh 10/31/2008 14:34'! initialize "EventSensorConstants initialize" RedButtonBit := 4. BlueButtonBit := 2. YellowButtonBit := 1. ShiftKeyBit := 1. CtrlKeyBit := 2. OptionKeyBit := 4. CommandKeyBit := 8. "Types of events" EventTypeNone := 0. EventTypeMouse := 1. EventTypeKeyboard := 2. EventTypeDragDropFiles := 3. EventTypeMenu := 4. EventTypeWindow := 5. "Press codes for keyboard events" EventKeyChar := 0. EventKeyDown := 1. EventKeyUp := 2. "Window event action codes" WindowEventMetricChange := 1. " size or position of window changed - value1-4 are left/top/right/bottom values " WindowEventClose := 2. " window close icon pressed " WindowEventIconise := 3. " window iconised or hidden etc " WindowEventActivated :=4. " window made active - some platforms only - do not rely upon this " WindowEventPaint := 5. " window area (in value1-4) needs updating. Some platforms do not need to send this, do not rely on it in image " ! ! !ExactFloatPrintPolicy commentStamp: ''! I am ExactFloatPrintPolicy. Through FloatPrintPolicy and double dispatch I force Float>>#printOn:base: to dynamically use the slower but accurate way to print Floats using Float>>#absPrintExactlyOn:base:! !ExactFloatPrintPolicy methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 2/8/2013 11:57'! absPrint: float on: stream base: base "Doube dispatch to the slower but accurate way to print" ^ float absPrintExactlyOn: stream base: base ! ! !ExampleBuilderMorph commentStamp: 'gvc 7/19/2007 16:49'! Morph with an inset border by default and theme access. Overrides openModal: to allow multiple free example dialogs to be presented.! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! questionWithoutCancel: aStringOrText "Open a question dialog." ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText "Answer a color chooser with the given selectors." ^self theme newColorChooserIn: self for: aModel getColor: getSel setColor: setSel getEnabled: nil help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newWindowFor: aModel title: titleString "Answer a new window morph." ^self theme newWindowIn: self for: aModel title: titleString! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newGroupbox "Answer a plain groupbox." ^self theme newGroupboxIn: self! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! deny: aStringOrText "Open a denial dialog." ^self deny: aStringOrText title: 'Access Denied' translated! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText "Answer a color chooser with the given selectors." ^self theme newColorChooserIn: self for: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText "Answer an inremental slider with the given selectors." ^self theme newIncrementalSliderIn: self for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newLabelGroup: labelsAndControls font: aFont labelColor: aColor "Answer a morph laid out with a column of labels and a column of associated controls. Controls having a vResizing value of #spaceFill will cause their row to use #spaceFill also, otherwise #shrinkWrap." ^self theme newLabelGroupIn: self for: labelsAndControls font: aFont labelColor: aColor ! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newCloseButton "Answer a new close button." ^self newCloseButtonFor: self ! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newGroupbox: aString "Answer a groupbox with the given label." ^self theme newGroupboxIn: self label: aString! ! !ExampleBuilderMorph methodsFor: 'theme' stamp: ''! theme "Answer the ui theme that provides controls." ^ Smalltalk ui theme! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel getEnabled: enabledSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: 0 max: 1 quantum: nil getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts path: path "Answer the result of a file open dialog with the given title, extensions to show and path." ^self fileOpen: title extensions: exts path: path preview: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: (AlphaImageMorph new image: aForm) help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newPanel "Answer a new panel." ^self theme newPanelIn: self! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newPluggableDialogWindow: title "Answer a new pluggable dialog with the given content." ^self newPluggableDialogWindow: title for: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newSVSelector: aColor help: helpText "Answer a saturation-volume selector with the given color." ^self theme newSVSelectorIn: self color: aColor help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText "Answer a list for the given model." ^self newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: nil help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newMenu "Answer a new menu." ^self theme newMenuIn: self for: self! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! centeredAlert: aStringOrText title: aString configure: aBlock "Open an alert dialog. Configure the dialog with the 1 argument block before opening modally." ^self theme centeredAlertIn: self text: aStringOrText title: aString configure: aBlock! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newMenuFor: aModel "Answer a new menu." ^self theme newMenuIn: self for: aModel! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector "Answer a text editor for the given model." ^self theme newBasicTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText "Answer a morph drop list for the given model." ^self theme newMorphDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newAlphaImage: aForm help: helpText "Answer an alpha image morph." ^self theme newAlphaImageIn: self image: aForm help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a checkbox (radio button appearance) with the given label." ^self theme newRadioButtonIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newStack: controls "Answer a morph laid out with a stack of controls." ^self theme newStackIn: self for: controls! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! chooseFont "Answer the result of a font selector dialog." ^self chooseFont: nil! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! message: aStringOrText "Open a message dialog." ^self message: aStringOrText title: 'Information' translated! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a new button." ^self newButtonFor: aModel getState: nil action: actionSel arguments: nil getEnabled: enabledSel label: stringOrText help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText "Answer an alpha channel selector with the given selectors." ^self theme newAlphaSelectorIn: self for: aModel getAlpha: getSel setAlpha: setSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol "Answer a new balloon help with the given contents for aMorph at a given corner." ^self theme newBalloonHelpIn: self contents: aTextStringOrMorph for: aMorph corner: cornerSymbol! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! chooseDirectory: title path: path "Answer the result of a file dialog with the given title, answer a directory." ^self theme chooseDirectoryIn: self title: title path: path! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector "Answer a text editor for the given model." ^self theme newTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! longMessage: aStringOrText title: aString "Open a (long) message dialog." ^self theme longMessageIn: self text: aStringOrText title: aString! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newDialogPanel "Answer a new main dialog panel." ^self theme newDialogPanelIn: self! ! !ExampleBuilderMorph methodsFor: 'services' stamp: 'FernandoOlivero 3/2/2011 09:35'! chooseColor: aColor title: label "Answer the user choice of a colour." ^ self theme chooseColorIn: self modalMorph title: (label ifNil: ['Choose Color' translated]) color: aColor! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: nil label: stringOrText help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newCancelButtonFor: aModel "Answer a new cancel button." ^self theme newCancelButtonIn: self for: aModel! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newPluggableDialogWindow: title for: contentMorph "Answer a new pluggable dialog with the given content." ^self theme newPluggableDialogWindowIn: self title: title for: contentMorph! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newGroupbox: aString for: control "Answer a groupbox with the given label and control." ^self theme newGroupboxIn: self label: aString for: control! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newOKButton "Answer a new OK button." ^self newOKButtonFor: self! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: aModel label: aString offset: 1 alpha: 0.5 getEnabled: enabledSel! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newYesButton "Answer a new Yes button." ^self newYesButtonFor: self! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText "Answer an editable drop list for the given model." ^self theme newEditableDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! chooseColor "Answer the result of a color selector dialog ." ^self chooseColor: Color black! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText "Answer a morph drop list for the given model." ^self newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: nil useIndex: true help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText "Answer a list for the given model." ^self theme newListIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newString: aStringOrText font: aFont style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: aFont style: aStyle! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText "Answer a morph drop list for the given model." ^self newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: true help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText "Answer a drop list for the given model." ^self theme newDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newToolbar "Answer a toolbar." ^self theme newToolbarIn: self! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText "Answer a drop list for the given model." ^self newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: nil useIndex: true help: helpText! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! chooseFont: aFont "Answer the result of a font selector dialog with the given initial font." ^self theme chooseFontIn: self title: 'Font Selector' translated font: aFont! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newCloseButtonFor: aModel "Answer a new close button." ^self theme newCloseButtonIn: self for: aModel! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! fileSave: title path: path "Answer the result of a file save open dialog with the given title." ^self fileSave: title extensions: nil path: path! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newVerticalSeparator "Answer a vertical separator." ^self theme newVerticalSeparatorIn: self! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! proceed: aStringOrText "Open a proceed dialog." ^self proceed: aStringOrText title: 'Proceed' translated! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newHSVASelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVASelectorIn: self color: aColor help: helpText! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! chooseColor: aColor "Answer the result of a color selector dialog with the given color." ^self theme chooseColorIn: self title: 'Colour Selector' translated color: aColor! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! deny: aStringOrText title: aString "Open a denial dialog." ^self theme denyIn: self text: aStringOrText title: aString! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newButtonLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new button text label." ^self theme newButtonLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newPluggableDialogWindow "Answer a new pluggable dialog." ^self newPluggableDialogWindow: 'Dialog'! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! alert: aStringOrText title: aString configure: aBlock "Open an alert dialog. Configure the dialog with the 1 argument block before opening modally." ^self theme alertIn: self text: aStringOrText title: aString configure: aBlock! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newScrollPaneFor: aMorph "Answer a new scroll pane morph to scroll the given morph." ^self theme newScrollPaneIn: self for: aMorph! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newOKButtonFor: aModel "Answer a new OK button." ^self newOKButtonFor: aModel getEnabled: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newCancelButton "Answer a new cancel button." ^self newCancelButtonFor: self! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newString: aStringOrText style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: aStyle! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newHueSelector: aModel getHue: getSel setHue: setSel help: helpText "Answer a hue selector with the given selectors." ^self theme newHueSelectorIn: self for: aModel getHue: getSel setHue: setSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel ghostText: ghostText getEnabled: enabledSel help: helpText "Answer an editable drop list for the given model." ^self theme newEditableDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: String default: '' ghostText: ghostText getEnabled: enabledSel useIndex: false help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newGroupboxFor: control "Answer a plain groupbox with the given control." ^self theme newGroupboxIn: self for: control! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newOverflowRowForAll: aCollectionOfMorphs "Answer a new overflow row morph that provides a drop down for the given contents that are unable to fit the bounds." ^self theme newOverflowRowIn: self forAll: aCollectionOfMorphs! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newEmbeddedMenu "Answer a new menu." ^self theme newEmbeddedMenuIn: self for: self! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: 0 max: 1 quantum: nil getEnabled: nil help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! fileOpen: title "Answer the result of a file open dialog with the given title." ^self fileOpen: title extensions: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText "Answer a morph list for the given model." ^self theme newMorphListIn: self for: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! message: aStringOrText title: aString "Open a message dialog." ^self theme messageIn: self text: aStringOrText title: aString! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newTabGroup: labelsAndPages "Answer a tab group with the given tab labels associated with pages." ^self theme newTabGroupIn: self for: labelsAndPages! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newNoButtonFor: aModel "Answer a new No button." ^self theme newNoButtonIn: self for: aModel! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion ! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newImage: aForm size: aPoint "Answer a new image." ^self theme newImageIn: self form: aForm size: aPoint! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! chooseDropList: aStringOrText list: aList "Open a drop list chooser dialog." ^self chooseDropList: aStringOrText title: 'Choose' translated list: aList! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! textEntry: aStringOrText title: aString entryText: defaultEntryText "Open a text entry dialog." ^self theme textEntryIn: self text: aStringOrText title: aString entryText: defaultEntryText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newImage: aForm "Answer a new image." ^self theme newImageIn: self form: aForm! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel "Answer a text editor for the given model." ^self newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newImageFor: aModel get: getSel help: helpText "Answer a text entry for the given model." ^self theme newImageIn: self for: aModel get: getSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! alert: aStringOrText title: aString "Open an alert dialog." ^self alert: aStringOrText title: aString configure: [:d | ]! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! alert: aStringOrText "Open an alert dialog." ^self alert: aStringOrText title: 'Alert' translated! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! proceed: aStringOrText title: aString "Open a proceed dialog and answer true if not cancelled, false otherwise." ^self theme proceedIn: self text: aStringOrText title: aString! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self theme newAutoAcceptTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newBalloonHelp: aTextStringOrMorph for: aMorph "Answer a new balloon help with the given contents for aMorph at a given corner." ^self theme newBalloonHelpIn: self contents: aTextStringOrMorph for: aMorph corner: #bottomLeft! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector "Answer a new tree morph." ^self theme newTreeIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! abort: aStringOrText "Open an error dialog." ^self abort: aStringOrText title: 'Error' translated! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newColorPresenterFor: aModel getColor: getSel help: helpText "Answer a color presenter with the given selectors." ^self theme newColorPresenterIn: self for: aModel getColor: getSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText "Answer a bracket slider with the given selectors." ^self theme newBracketSliderIn: self for: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newOKButtonFor: aModel getEnabled: enabledSel "Answer a new OK button." ^self theme newOKButtonIn: self for: aModel getEnabled: enabledSel! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel action: actionSel label: stringOrText help: helpText "Answer a new button." ^self newButtonFor: aModel getState: nil action: actionSel arguments: nil getEnabled: nil label: stringOrText help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText "Answer a morph list for the given model." ^self newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: nil help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newText: aStringOrText "Answer a new text." ^self theme newTextIn: self text: aStringOrText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newNoButton "Answer a new No button." ^self newNoButtonFor: self! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel font: aFont help: helpText ! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! fileSave: title extensions: exts path: path "Answer the result of a file save dialog with the given title, extensions to show and path." ^self theme fileSaveIn: self title: title extensions: exts path: path! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText "Answer a drop list for the given model." ^self theme newDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: true help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newLabel: aString "Answer a new text label." ^self newLabelFor: nil label: aString getEnabled: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newHSVSelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVSelectorIn: self color: aColor help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newLabelGroup: labelsAndControls "Answer a morph laid out with a column of labels and a column of associated controls. Controls having a vResizing value of #spaceFill will cause their row to use #spaceFill also, otherwise #shrinkWrap." ^self theme newLabelGroupIn: self for: labelsAndControls! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newRow: controls "Answer a morph laid out with a row of controls." ^self theme newRowIn: self for: controls! ! !ExampleBuilderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/6/2010 17:08'! openModal: aSystemWindow "Open the given window an available position without modality. Answer the system window." |baseArea areas searching foundRect| aSystemWindow extent: aSystemWindow initialExtent. areas := World submorphs select: [:m | m isKindOf: DialogWindow] thenCollect: [:m | m bounds expandBy: 8]. baseArea := RealEstateAgent maximumUsableArea insetBy: 8. searching := true. baseArea allAreasOutsideList: areas do: [:rect | searching ifTrue: [ aSystemWindow extent <= (rect insetBy: 8) extent ifTrue: [foundRect := rect. searching := false]]]. searching ifTrue: [foundRect := baseArea]. aSystemWindow setWindowColor: self theme windowColor. aSystemWindow position: foundRect topLeft + 8. aSystemWindow openAsIs. ^aSystemWindow! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newExpander: aString "Answer an expander with the given label." ^self theme newExpanderIn: self label: aString forAll: #()! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel "Answer a text editor for the given model." ^self newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newExpander: aString for: aControl "Answer an expander with the given label and control." ^self theme newExpanderIn: self label: aString forAll: {aControl}! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newTitle: aString for: control "Answer a morph laid out with a column with a title." ^self theme newTitleIn: self label: aString for: control! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newColumn: controls "Answer a morph laid out with a column of controls." ^self theme newColumnIn: self for: controls! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! question: aStringOrText title: aString "Open a question dialog and answer true if yes, false if no and nil if cancelled." ^self theme questionIn: self text: aStringOrText title: aString! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts path: path preview: preview "Answer the result of a file open dialog with the given title, extensions to show, path and preview type." ^self theme fileOpenIn: self title: title extensions: exts path: path preview: preview! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newGroupboxForAll: controls "Answer a plain groupbox with the given controls." ^self theme newGroupboxIn: self forAll: controls! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText "Answer a bracket slider with the given selectors." ^self newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: nil help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newToolDockingBar "Answer a tool docking bar." ^self theme newToolDockingBarIn: self! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newMultistateButton "Answer a new multistate button morph. To be usable it needs to have fill styles assigned to various states along with mouse-up/down actions." ^self theme newMultistateButtonIn: self! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: nil! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! textEntry: aStringOrText title: aString "Open a text entry dialog." ^self textEntry: aStringOrText title: aString entryText: ''! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! chooseDirectory: title "Answer the result of a file dialog with the given title, answer a directory." ^self chooseDirectory: title path: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel help: helpText "Answer a text entry for the given model." ^self newTextEntryFor: aModel get: getSel set: setSel class: String getEnabled: nil help: helpText! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! fileSave: title extensions: exts "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: exts path: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel getLabel: labelSel getEnabled: enabledSel! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newSeparator "Answer an horizontal separator." ^self theme newSeparatorIn: self! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! fileSave: title "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: nil path: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newWorkArea "Answer a new work area morph." ^self theme newWorkAreaIn: self! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newCloseControlFor: aModel action: aValuable help: helpText "Answer a new cancel button." ^self theme newCloseControlIn: self for: aModel action: aValuable help: helpText! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! chooseDropList: aStringOrText title: aString list: aList "Open a drop list chooser dialog." ^self theme chooseDropListIn: self text: aStringOrText title: aString list: aList! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! question: aStringOrText "Open a question dialog." ^self question: aStringOrText title: 'Question' translated! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! textEntry: aStringOrText "Open a text entry dialog." ^self textEntry: aStringOrText title: 'Entry' translated! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText "Answer a list for the given model." ^self theme newListIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newGroupbox: aString forAll: controls "Answer a groupbox with the given label and controls." ^self theme newGroupboxIn: self label: aString forAll: controls! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newExpander: aString forAll: controls "Answer an expander with the given label and controls." ^self theme newExpanderIn: self label: aString forAll: controls! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newString: aStringOrText "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: #plain! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! questionWithoutCancel: aStringOrText title: aString "Open a question dialog and answer true if yes, false if no and nil if cancelled." ^self theme questionWithoutCancelIn: self text: aStringOrText title: aString! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newButtonLabel: aString "Answer a new button text label." ^self newButtonLabelFor: nil label: aString getEnabled: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newToolbar: controls "Answer a toolbar with the given controls." ^self theme newToolbarIn: self for: controls! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newToolSpacer "Answer a tool spacer." ^self theme newToolSpacerIn: self! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newFuzzyLabel: aString "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: nil label: aString offset: 1 alpha: 0.5 getEnabled: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newRow "Answer a morph laid out as a row." ^self theme newRowIn: self for: #()! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts "Answer the result of a file open dialog with the given title and extensions to show." ^self fileOpen: title extensions: exts path: nil! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newStack "Answer a morph laid out as a stack." ^self theme newStackIn: self for: #()! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! chooseFileName: title extensions: exts path: path preview: preview "Answer the result of a file name chooser dialog with the given title, extensions to show, path and preview type." ^self theme chooseFileNameIn: self title: title extensions: exts path: path preview: preview! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText "Answer a checkbox (radio button appearance) with the given label." ^self newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: nil label: stringOrText help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newYesButtonFor: aModel "Answer a new yes button." ^self theme newYesButtonIn: self for: aModel! ! !ExampleBuilderMorph methodsFor: 'controls' stamp: ''! newToolbarHandle "Answer a toolbar handle." ^self theme newToolbarHandleIn: self! ! !ExampleBuilderMorph methodsFor: 'services' stamp: ''! abort: aStringOrText title: aString "Open an error dialog." ^self theme abortIn: self text: aStringOrText title: aString! ! !ExampleForTest1 commentStamp: 'TorstenBergmann 2/5/2014 08:35'! An example class at level 1 (directly below Object) used for testing class hierarchy! !ExampleForTest11 commentStamp: 'TorstenBergmann 2/5/2014 08:35'! An example class at level 2 (indirectly below Object) used for testing class hierarchy! !ExampleForTest111 commentStamp: 'TorstenBergmann 2/5/2014 08:35'! An example class at level 3 (indirectly below Object) used for testing class hierarchy! !ExampleForTest112 commentStamp: 'TorstenBergmann 2/5/2014 08:35'! An example class at level 3 (indirectly below Object) used for testing class hierarchy! !ExampleForTest12 commentStamp: 'TorstenBergmann 2/5/2014 08:35'! An example class at level 2 (indirectly below Object) used for testing class hierarchy! !ExampleRadioButtonModel commentStamp: 'gvc 9/23/2008 11:58'! Model used for radio buttons in example of basic controls (see "UITheme exampleBasicControls").! !ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:17'! beLeft "Set the option to #left." self option: #left! ! !ExampleRadioButtonModel methodsFor: 'initialization' stamp: 'gvc 8/7/2007 13:17'! initialize "Initialize the receiver." super initialize. self option: #left! ! !ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:17'! beCenter "Set the option to #center." self option: #center! ! !ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:16'! isCenter "Answer whether the option if #center." ^self option == #center! ! !ExampleRadioButtonModel methodsFor: 'accessing' stamp: 'gvc 8/7/2007 13:15'! option: aSymbol "Set the value of option" option := aSymbol. self changed: #isLeft; changed: #isCenter; changed: #isRight! ! !ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:16'! isRight "Answer whether the option if #right." ^self option == #right! ! !ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:16'! isLeft "Answer whether the option if #left." ^self option == #left! ! !ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:17'! beRight "Set the option to #right." self option: #right! ! !ExampleRadioButtonModel methodsFor: 'accessing' stamp: 'gvc 8/7/2007 13:13'! option "Answer the value of option" ^ option! ! !ExampleSetTest commentStamp: 'TorstenBergmann 2/12/2014 23:16'! SUnit tests for example set! !ExampleSetTest methodsFor: 'testing' stamp: 'BaseSystem 8/30/2009 09:40'! testRemove full remove: 5. self assert: (full includes: #abc). self deny: (full includes: 5)! ! !ExampleSetTest methodsFor: 'testing' stamp: 'BaseSystem 8/30/2009 09:40'! testAdd empty add: 5. self assert: (empty includes: 5)! ! !ExampleSetTest methodsFor: 'testing' stamp: 'StephaneDucasse 6/9/2012 22:58'! testIllegal self should: [empty at: 5] raise: self defaultTestError. self should: [empty at: 5 put: #abc] raise: self defaultTestError! ! !ExampleSetTest methodsFor: 'testing' stamp: 'BaseSystem 8/30/2009 09:40'! testGrow empty addAll: (1 to: 100). self assert: empty size = 100! ! !ExampleSetTest methodsFor: 'testing' stamp: 'BaseSystem 8/30/2009 09:40'! testOccurrences self assert: (empty occurrencesOf: 0) = 0. self assert: (full occurrencesOf: 5) = 1. full add: 5. self assert: (full occurrencesOf: 5) = 1! ! !ExampleSetTest methodsFor: 'testing' stamp: 'BaseSystem 8/30/2009 09:40'! testIncludes self assert: (full includes: 5). self assert: (full includes: #abc)! ! !ExampleSetTest methodsFor: 'running' stamp: 'BaseSystem 8/30/2009 09:40'! setUp empty := Set new. full := Set with: 5 with: #abc! ! !Exception commentStamp: 'SvenVanCaekenberghe 4/18/2011 15:17'! This is the main class used to implement the exception handling system (EHS). It plays two distinct roles: that of the exception, and that of the exception handler. More specifically, it implements the bulk of the protocols laid out in the ANSI specification - those protocol names are reflected in the message categories. Exception is an abstract class. Instances should neither be created nor trapped. In most cases, subclasses should inherit from Error or Notification rather than directly from Exception. Exceptions have an optional #messageText that can be set when they are signaled. Exceptions also have the concept of #signaler, the object that is the subject of the exception. This will be set automatically (to the #receiver), but can be set when the exception is signaled. In implementing this EHS, The Fourth Estate Inc. incorporated some ideas and code from Craig Latta's EHS. His insights were crucial in allowing us to implement BlockContext>>valueUninterruptably (and by extension, #ensure: and #ifCurtailed:), and we imported the following methods with little or no modification: ContextPart>>terminateTo: ContextPart>>terminate MethodContext>>receiver: MethodContext>>answer: Thanks, Craig!!! !Exception methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 15:33'! description "Return a textual description of the exception." ^ String streamContents: [ :stream | | mt | stream << self class name. (mt := self messageText) isEmptyOrNil ifFalse: [ stream << ': ' << mt ] ]! ! !Exception methodsFor: 'handling' stamp: 'CamilloBruni 2/13/2012 16:59'! freeze "freeze the context stack to keep the exception usable outside the catch blocks" self freezeUpTo: thisContext! ! !Exception methodsFor: 'accessing' stamp: 'pnm 8/16/2000 15:23'! tag: t "This message is not specified in the ANSI protocol, but that looks like an oversight because #tag is specified, and the spec states that the signaler may store the tag value." tag := t! ! !Exception methodsFor: 'handling' stamp: 'CamilloBruni 7/12/2013 13:26'! resignalAs: replacementException "Signal an alternative exception in place of the receiver." ^ replacementException signalIn: signalContext! ! !Exception methodsFor: 'testing' stamp: 'ajh 2/1/2003 01:32'! isNested "Determine whether the current exception handler is within the scope of another handler for the same exception." ^ handlerContext nextHandlerContext canHandleSignal: self! ! !Exception methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 15:22'! signaler: anObject "Set the object that is the subject involving me. This is set automatically to my #receiver during #signal but could be overwritten when I am signaled" signaler := anObject! ! !Exception methodsFor: 'signaling' stamp: 'SvenVanCaekenberghe 4/18/2011 13:55'! signal "Ask ContextHandlers in the sender chain to handle this signal. The default is to execute and return my defaultAction." signalContext := thisContext contextTag. signaler ifNil: [ signaler := self receiver ]. ^ signalContext nextHandlerContext handleSignal: self! ! !Exception methodsFor: 'printing' stamp: 'ajh 9/30/2001 15:33'! printOn: stream stream nextPutAll: self description! ! !Exception methodsFor: 'signaling' stamp: 'ajh 9/30/2001 20:13'! signal: signalerText "Signal the occurrence of an exceptional condition with a specified textual description." self messageText: signalerText. ^ self signal! ! !Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:37'! return: returnValue "Return the argument as the value of the block protected by the active exception handler." handlerContext return: returnValue! ! !Exception methodsFor: 'handling' stamp: 'SvenVanCaekenberghe 4/18/2011 15:18'! resume: resumptionValue "Return resumptionValue as the value of the signal message." self isResumable ifFalse: [ IllegalResumeAttempt signal ]. self resumeUnchecked: resumptionValue! ! !Exception methodsFor: 'handling' stamp: 'StephaneDucasse 2/16/2010 14:03'! return "Return nil as the value of the block protected by the active exception handler." self return: self defaultReturnValue! ! !Exception methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/18/2011 15:17'! defaultResumeValue "Answer the value that by default should be returned if the exception is resumed" ^ nil! ! !Exception methodsFor: 'handling' stamp: 'ajh 2/16/2003 17:37'! searchFrom: aContext " Set the context where the handler search will start. " signalContext := aContext contextTag! ! !Exception methodsFor: 'testing' stamp: 'ajh 2/1/2003 00:58'! isResumable "Determine whether an exception is resumable." ^ true! ! !Exception methodsFor: 'handling' stamp: 'SvenVanCaekenberghe 4/18/2011 15:18'! resumeUnchecked: resumptionValue "Return resumptionValue as the value of #signal, unless this was called after an #outer message, then return resumptionValue as the value of #outer." | ctxt | outerContext ifNil: [ signalContext return: resumptionValue ] ifNotNil: [ ctxt := outerContext. outerContext := ctxt tempAt: 1. "prevOuterContext in #outer" ctxt return: resumptionValue ] ! ! !Exception methodsFor: 'handling' stamp: 'StephaneDucasse 2/16/2010 14:02'! resume "Return from the message that signaled the receiver." self resume: self defaultResumeValue! ! !Exception methodsFor: 'accessing' stamp: 'ClementBera 9/27/2013 17:57'! tag "Return an exception's tag value." ^ tag ifNil: [ self messageText ] ifNotNil: [ tag ]! ! !Exception methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2013 21:24'! signalerContext "Find the first sender of signal(:), the first context which is neither for an instance method nor for a class side method of Exception (or subclass). This will make sure that the same context is found for both, `Error signal` and `Error new signal`" ^ signalContext findContextSuchThat: [ :context | (context receiver == self or: [ context receiver == self class ]) not ]! ! !Exception methodsFor: 'signaling' stamp: 'ajh 9/30/2001 15:33'! messageText: signalerText "Set an exception's message text." messageText := signalerText! ! !Exception methodsFor: 'private' stamp: 'StephaneDucasse 2/16/2010 14:02'! defaultReturnValue "Answer the value that by default should be returned if the exception is returned" ^nil! ! !Exception methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 15:22'! signaler "Return the object that is the subject involving me. This is set automatically to my #receiver during #signal but could be overwritten when I am signaled" ^ signaler! ! !Exception methodsFor: '*SUnit-Core' stamp: 'jp 3/17/2003 10:03'! sunitExitWith: aValue self return: aValue! ! !Exception methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 15:20'! receiver ^ self signalerContext receiver! ! !Exception methodsFor: 'handling' stamp: 'CamilloBruni 2/13/2012 16:59'! freezeUpTo: aContext "freeze the signal context up to the given context so the exception is usable outside the catch block" signalContext := signalContext copyTo: aContext.! ! !Exception methodsFor: 'handling' stamp: 'ajh 2/1/2003 01:33'! pass "Yield control to the enclosing exception action for the receiver." handlerContext nextHandlerContext handleSignal: self! ! !Exception methodsFor: 'accessing' stamp: 'ajh 9/30/2001 15:33'! defaultAction "The default action taken if the exception is signaled." self subclassResponsibility! ! !Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:37'! retryUsing: alternativeBlock "Abort an exception handler and evaluate a new block in place of the handler's protected block." handlerContext restartWithNewReceiver: alternativeBlock ! ! !Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:36'! retry "Abort an exception handler and re-evaluate its protected block." handlerContext restart! ! !Exception methodsFor: 'private' stamp: 'ajh 1/29/2003 13:44'! privHandlerContext: aContextTag handlerContext := aContextTag! ! !Exception methodsFor: 'accessing' stamp: 'StephaneDucasse 2/13/2010 12:18'! messageText "Return an exception's message text." ^ messageText ifNil: [ String empty ]! ! !Exception methodsFor: 'handling' stamp: 'MarcusDenker 9/29/2013 09:05'! debug "open a debugger on myself" ^ Smalltalk tools debugger debugError: self! ! !Exception methodsFor: 'signaling' stamp: 'CamilloBruni 7/12/2013 13:15'! signalIn: context "Ask ContextHandlers in the sender chain starting at the given context to handle this signal. The default is to execute and return my defaultAction." signalContext := context. signaler ifNil: [ signaler := self receiver ]. ^ signalContext nextHandlerContext handleSignal: self! ! !Exception methodsFor: 'handling' stamp: 'SvenVanCaekenberghe 4/18/2011 15:17'! outer "Evaluate the enclosing exception action and return to here instead of signal if it resumes (see #resumeUnchecked:)." | prevOuterContext | self isResumable ifTrue: [ prevOuterContext := outerContext. outerContext := thisContext contextTag ]. self pass. ! ! !Exception class methodsFor: 'exceptioninstantiator' stamp: 'CamilloBruni 7/12/2013 13:17'! signal: message in: context "Signal the occurrence of an exceptional condition with a specified textual description in the given context." ^ self new messageText: message; signalIn: context! ! !Exception class methodsFor: 'exceptionselector' stamp: 'SvenVanCaekenberghe 11/22/2013 23:51'! - anotherException "Create an exception set containing the receiver and anotherException as exclusion." ^ ExceptionSetWithExclusions new add: self; addExclusion: anotherException; yourself! ! !Exception class methodsFor: 'exceptioninstantiator' stamp: 'ajh 9/30/2001 21:54'! signal "Signal the occurrence of an exceptional condition." ^ self new signal! ! !Exception class methodsFor: '*Polymorph-Widgets-Themes' stamp: 'YuriyTymchuk 12/20/2013 11:18'! systemIcon ^ Smalltalk ui icons iconNamed: #exceptionIcon! ! !Exception class methodsFor: 'exceptioninstantiator' stamp: 'CamilloBruni 7/12/2013 13:16'! signal: message "Signal the occurrence of an exceptional condition with a specified textual description." ^ self new signal: message! ! !Exception class methodsFor: 'exceptionselector' stamp: 'ajh 8/5/2003 11:33'! handles: exception "Determine whether an exception handler will accept a signaled exception." ^ exception isKindOf: self! ! !Exception class methodsFor: 'exceptionselector' stamp: 'SvenVanCaekenberghe 11/22/2013 23:51'! , anotherException "Create an exception set containing the receiver and anotherException" ^ ExceptionSet new add: self; add: anotherException; yourself! ! !Exception class methodsFor: 'exceptioninstantiator' stamp: 'CamilloBruni 7/12/2013 13:16'! signalIn: context "Signal the occurrence of an exceptional condition in the given context." ^ self new signalIn: context! ! !ExceptionHandler commentStamp: ''! I represent the BlockClosure>>on:do: temporaries in Pharo. Instance Variables block: enabled: exception: block - is the handler block enabled - is false if not active (to avoid running twice an handler block)) exception - is the exceptionClass ! !ExceptionHandler methodsFor: 'initialization' stamp: 'CamilloBruni 12/13/2011 15:07'! initialize super initialize. enabled := true.! ! !ExceptionHandler methodsFor: 'accessing' stamp: 'CamilloBruni 12/13/2011 15:08'! enabled ^ enabled! ! !ExceptionHandler methodsFor: 'accessing' stamp: 'CamilloBruni 12/12/2011 14:10'! exception ^ exception! ! !ExceptionHandler methodsFor: 'accessing' stamp: 'CamilloBruni 12/8/2011 15:47'! block ^ block! ! !ExceptionHandler methodsFor: 'accessing' stamp: 'CamilloBruni 12/12/2011 14:09'! exception: anException exception := anException! ! !ExceptionHandler methodsFor: 'exception-handling' stamp: 'ClementBera 12/3/2012 14:02'! handle: anError | value | self flag: 'TODO:do the ensure magic here.. instead of ^ there is resume: that trigger all the unwind block in Pharo I think there should be some gotoContext changes here'. enabled := false. value := self block cull: anError. enabled := true. ^ value! ! !ExceptionHandler methodsFor: 'accessing' stamp: 'ClementBera 10/18/2012 14:51'! enabled: aBool enabled := aBool! ! !ExceptionHandler methodsFor: 'testing' stamp: 'CamilloBruni 12/13/2011 15:07'! handles: anError ^ self enabled and: [ self exception handles: anError ]! ! !ExceptionHandler methodsFor: 'accessing' stamp: 'CamilloBruni 12/8/2011 15:48'! block: aBlock block := aBlock! ! !ExceptionHandler class methodsFor: 'instance-creation' stamp: 'CamilloBruni 12/11/2011 18:46'! forMessage: aMessage ^ self on: aMessage arguments first do: aMessage arguments second! ! !ExceptionHandler class methodsFor: 'instance-creation' stamp: 'CamilloBruni 12/12/2011 14:07'! on: anException do: aBlock ^ self new exception: anException; block: aBlock; yourself! ! !ExceptionSet commentStamp: ''! An ExceptionSet is a grouping of exception handlers which acts as a single handler. Within the group, the most recently added handler will be the last handler found during a handler search (in the case where more than one handler in the group is capable of handling a given exception). ! !ExceptionSet methodsFor: 'exceptionselector' stamp: 'SvenVanCaekenberghe 11/22/2013 23:39'! - anotherException "Create an exception set containnig the receiver and anotherException as an exclusion." ^ ExceptionSetWithExclusions new add: self; addExclusion: anotherException; yourself! ! !ExceptionSet methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:52'! initialize super initialize. exceptions := OrderedCollection new! ! !ExceptionSet methodsFor: 'exceptionselector' stamp: 'SvenVanCaekenberghe 11/22/2013 23:43'! handles: anException "Determine whether an exception handler will accept a signaled exception." ^ exceptions anySatisfy: [ :exception | exception handles: anException ]! ! !ExceptionSet methodsFor: 'exceptionselector' stamp: 'SvenVanCaekenberghe 11/22/2013 23:34'! , anException "Return an exception set that contains the receiver and the argument exception. This is commonly used to specify a set of exception selectors for an exception handler." self add: anException! ! !ExceptionSet methodsFor: 'private' stamp: 'SvenVanCaekenberghe 11/22/2013 23:40'! add: anException "Add anException to the exceptions that I handle" ^ exceptions add: anException! ! !ExceptionSetWithExclusions commentStamp: ''! I am ExceptionSetWithExclusions, an ExceptionSet that explicitely does not handle a number of exclusion Exceptions.! !ExceptionSetWithExclusions methodsFor: 'exceptionselector' stamp: 'SvenVanCaekenberghe 11/22/2013 13:34'! - exception "Add exception as an exclusion to me. I will explicitely not handle my exclusion exceptions." self addExclusion: exception! ! !ExceptionSetWithExclusions methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 11/22/2013 13:10'! initialize super initialize. exclusions := OrderedCollection new! ! !ExceptionSetWithExclusions methodsFor: 'exceptionselector' stamp: 'SvenVanCaekenberghe 11/22/2013 23:47'! handles: exception "Return true when I will handled exception. I extend my superclass behavior by explicitely not handling a number of exclusion exceptions." ^ (super handles: exception) and: [ exclusions noneSatisfy: [ :each | each handles: exception ] ]! ! !ExceptionSetWithExclusions methodsFor: 'private' stamp: 'SvenVanCaekenberghe 11/22/2013 13:35'! addExclusion: exception "Add exception as an exclusion to me. I will explicitely not handle my exclusion exceptions." ^ exclusions add: exception! ! !ExceptionTester commentStamp: 'TorstenBergmann 2/5/2014 08:36'! Utility class to test exceptions! !ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tpr 5/27/2004 21:50'! simpleOuterTest "uses #resume" [[self doSomething. MyTestNotification signal. "self doSomethingElse" self doSomethingExceptional] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ! !ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tfei 6/13/1999 00:37'! simplePassTest [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | self doYetAnotherThing. ex pass "expecting handler in #runTest:"]! ! !ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'! simpleNoTimeoutTest [ self doSomething ] valueWithin: 1 day onTimeout: [ self doSomethingElse ]. ! ! !ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/8/1999 09:38'! logTestResult: aString | index | index := self suiteLog size. self suiteLog at: index put: ((self suiteLog at: index), ' ', aString)! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:23'! simpleRetryUsingTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 02:39'! resumableFallOffTheEndHandlerResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingExceptionalString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 10:13'! simpleEnsureTestWithNotificationResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingElseString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'signaledexception tests' stamp: 'nice 1/5/2010 15:59'! simpleResumeTest "see if we can resume twice" [ | it |self doSomething. it := MyResumableTestError signal. it = 3 ifTrue: [self doSomethingElse]. it := MyResumableTestError signal. it = 3 ifTrue: [self doSomethingElse]. ] on: MyResumableTestError do: [:ex | self doYetAnotherThing. ex resume: 3]! ! !ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'! simpleTimeoutWithZeroDurationTest [ self doSomething ] valueWithin: 0 seconds onTimeout: [ self doSomethingElse ]. ! ! !ExceptionTester methodsFor: 'signaledexception tests' stamp: 'dtl 6/1/2004 21:49'! doubleOuterTest "uses #resume" [[[self doSomething. MyTestNotification signal. self doSomethingExceptional] on: MyTestNotification do: [:ex | ex outer. self doSomethingExceptional]] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 6/9/1999 17:44'! simpleEnsureTestWithErrorResults ^OrderedCollection new add: self doSomethingString; add: 'Unhandled Exception'; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 18:55'! simpleEnsureTestWithUparrowResults ^OrderedCollection new add: self doSomethingString; " add: self doSomethingElseString;" add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'dtl 6/1/2004 21:56'! doublePassOuterTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:23'! simpleRetryTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:16'! iterationsBeforeTimeout: anInteger iterationsBeforeTimeout := anInteger! ! !ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/13/1999 01:25'! runAllTests "ExceptionTester new runAllTests" self runBasicTests; runBasicANSISignaledExceptionTests! ! !ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'! simpleTimeoutTest | n | [1 to: 1000000 do: [ :i | n := i. self doSomething ] ] valueWithin: 50 milliSeconds onTimeout: [ self iterationsBeforeTimeout: n. self doSomethingElse ]! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'! doYetAnotherThingString ^'Do yet another thing.'! ! !ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tfei 6/13/1999 01:02'! simpleRetryTest | theMeaningOfLife | theMeaningOfLife := nil. [self doSomething. theMeaningOfLife == nil ifTrue: [MyTestError signal] ifFalse: [self doSomethingElse]] on: MyTestError do: [:ex | theMeaningOfLife := 42. self doYetAnotherThing. ex retry]! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'! doSomethingExceptionalString ^'Do something exceptional.'! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 11/14/1999 17:29'! doubleResumeTestResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingElseString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 13:43'! nonResumableFallOffTheEndHandler [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | self doSomethingExceptional]. self doYetAnotherThing! ! !ExceptionTester methodsFor: 'testing' stamp: 'brp 10/21/2004 17:40'! runTest: aSelector | actualResult expectedResult | [ self logTest: aSelector; clearLog; perform: aSelector ] on: MyTestError do: [ :ex | self log: 'Unhandled Exception'. ex return: nil ]. actualResult := self log. expectedResult := self perform: (aSelector, #Results) asSymbol. actualResult = expectedResult ifTrue: [self logTestResult: 'succeeded'] ifFalse: [self logTestResult: 'failed' ]. ! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:14'! doSomethingElse self log: self doSomethingElseString! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'! methodWithError MyTestError signal: self testString! ! !ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/9/1999 16:06'! runBasicTests self basicTestSelectors do: [:eachTestSelector | self runTest: eachTestSelector]! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'! doSomethingElseString ^'Do something else.'! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/7/1999 15:03'! log log == nil ifTrue: [log := OrderedCollection new]. ^log! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:04'! simpleEnsureTestWithUparrow [self doSomething. true ifTrue: [^nil]. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 14:28'! warningTest self log: 'About to signal warning.'. Warning signal: 'Ouch'. self log: 'Warning signal handled and resumed.'! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'dtl 6/1/2004 21:56'! doubleOuterPassTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tfei 6/13/1999 02:12'! simpleResignalAsTest "ExceptionTester new simpleResignalAsTest" [self doSomething. MyTestNotification signal. self doSomethingElse] on: MyTestNotification do: [:ex | ex resignalAs: MyTestError new]! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:10'! simpleOuterTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledexception tests' stamp: 'CamilloBruni 7/12/2013 13:21'! simpleIsNestedTest "uses resignalAs:" [ self doSomething. MyTestError signal. self doSomethingElse ] on: MyTestError do: [ :exception | "expecting to detect handler in #runTest:" exception isNested ifTrue: [ self doYetAnotherThing. exception resignalAs: MyTestNotification new ]]! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:13'! doSomethingString ^'Do something.'! ! !ExceptionTester methodsFor: 'signaledexception tests' stamp: 'dtl 6/1/2004 21:52'! doublePassOuterTest "uses #resume" [[[self doSomething. MyTestNotification signal. self doSomethingExceptional] on: MyTestNotification do: [:ex | ex pass. self doSomethingExceptional]] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 11/14/1999 17:26'! doubleResumeTest [self doSomething. MyResumableTestError signal. self doSomethingElse. MyResumableTestError signal. self doYetAnotherThing] on: MyResumableTestError do: [:ex | ex resume].! ! !ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 16:52'! simpleTimeoutWithZeroDurationTestResults ^OrderedCollection new add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:54'! basicTestSelectors ^ #(#simpleEnsureTest #simpleEnsureTestWithNotification #simpleEnsureTestWithUparrow #simpleEnsureTestWithError #signalFromHandlerActionTest #resumableFallOffTheEndHandler #nonResumableFallOffTheEndHandler #doubleResumeTest #simpleTimeoutWithZeroDurationTest #simpleTimeoutTest simpleNoTimeoutTest)! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 01:51'! signalFromHandlerActionTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: 'Unhandled Exception'; yourself! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:11'! simpleResignalAsTestResults ^OrderedCollection new add: self doSomethingString; add: 'Unhandled Exception'; yourself! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 10:15'! simpleEnsureTestWithNotification [self doSomething. self methodWithNotification. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ! !ExceptionTester methodsFor: 'signaledexception tests' stamp: 'dtl 6/1/2004 21:51'! doubleOuterPassTest "uses #resume" [[[self doSomething. MyTestNotification signal. self doSomethingExceptional] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | ex pass. self doSomethingExceptional]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 8/19/1999 01:39'! signalFromHandlerActionTest [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [self doYetAnotherThing. MyTestError signal]! ! !ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tfei 6/13/1999 00:59'! simpleReturnTest | it | it := [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | ex return: 3]. it = 3 ifTrue: [self doYetAnotherThing]! ! !ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/12/1999 23:07'! logTest: aSelector self suiteLog add: aSelector! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:21'! nonResumableFallOffTheEndHandlerResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingExceptionalString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 16:54'! simpleNoTimeoutTestResults ^OrderedCollection new add: self doSomethingString; yourself! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 09:44'! simpleEnsureTest [self doSomething. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ! !ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:15'! iterationsBeforeTimeout ^ iterationsBeforeTimeout! ! !ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/7/1999 15:03'! log: aString self log add: aString! ! !ExceptionTester methodsFor: 'signaledexception tests' stamp: 'tfei 6/13/1999 01:03'! simpleRetryUsingTest [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | ex retryUsing: [self doYetAnotherThing]]! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:30'! suiteLog suiteLog == nil ifTrue: [suiteLog := OrderedCollection new]. ^suiteLog! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'! testString ^'This is only a test.'! ! !ExceptionTester methodsFor: 'accessing' stamp: 'dtl 6/1/2004 21:53'! basicANSISignaledExceptionTestSelectors ^#( simpleIsNestedTest simpleOuterTest doubleOuterTest doubleOuterPassTest doublePassOuterTest simplePassTest simpleResignalAsTest simpleResumeTest simpleRetryTest simpleRetryUsingTest simpleReturnTest)! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'RAA 12/8/2000 12:59'! simpleResumeTestResults "see if we can resume twice" ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:10'! simplePassTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: 'Unhandled Exception'; yourself! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:09'! simpleIsNestedTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 02:22'! simpleReturnTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/8/1999 09:17'! clearLog log := nil! ! !ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/12/1999 23:54'! runBasicANSISignaledExceptionTests self basicANSISignaledExceptionTestSelectors do: [:eachTestSelector | self runTest: eachTestSelector]! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:14'! doSomethingExceptional self log: self doSomethingExceptionalString! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'! methodWithNotification MyTestNotification signal: self testString! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:07'! resumableFallOffTheEndHandler [self doSomething. MyTestNotification signal. self doSomethingElse] on: MyTestNotification do: [:ex | self doSomethingExceptional]. self doYetAnotherThing! ! !ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 17:44'! simpleTimeoutTestResults | things | things := OrderedCollection new: self iterationsBeforeTimeout. self iterationsBeforeTimeout timesRepeat: [ things add: self doSomethingString ]. things add: self doSomethingElseString. ^ things! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:47'! simpleEnsureTestResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingElseString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:13'! doSomething self log: self doSomethingString! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 12:50'! simpleEnsureTestWithError [self doSomething. MyTestError signal. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ! !ExceptionTester methodsFor: 'logging' stamp: 'PeterHugossonMiller 9/3/2009 01:25'! contents ^( self log inject: (String new: 80) writeStream into: [:result :item | result cr; nextPutAll: item; yourself] ) contents! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:15'! doYetAnotherThing self log: self doYetAnotherThingString! ! !ExceptionTests commentStamp: 'TorstenBergmann 2/5/2014 08:36'! SUnit tests for exceptions! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'dtl 6/1/2004 21:54'! testDoublePassOuter self assertSuccess: (ExceptionTester new runTest: #doublePassOuterTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:48'! testSimpleReturn self assertSuccess: (ExceptionTester new runTest: #simpleReturnTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:42'! testSimplePass self assertSuccess: (ExceptionTester new runTest: #simplePassTest ) ! ! !ExceptionTests methodsFor: 'testing-handling' stamp: 'GabrielOmarCotelli 11/21/2013 15:01'! testHandlingWithSeveralExclusions | wasHandled | wasHandled := false. self should: [ [ ZeroDivide signalWithDividend: 1 ] on: Error - Warning - ZeroDivide do: [ :exception | wasHandled := true. exception return ] ] raise: ZeroDivide. self deny: wasHandled. self should: [ [ ZeroDivide signalWithDividend: 1 ] on: Error - (Warning , ZeroDivide) do: [ :exception | wasHandled := true. exception return ] ] raise: ZeroDivide. self deny: wasHandled.! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:48'! testSimpleEnsure self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTest ) ! ! !ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 22:00'! testNonResumablePass self should: [ [Error signal. 4] on: Error do: [:ex | ex pass. ex return: 5] ] raise: Error ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:45'! testSimpleEnsureTestWithError self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithError ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:44'! testResumableFallOffTheEndHandler self assertSuccess: (ExceptionTester new runTest: #resumableFallOffTheEndHandler ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:43'! testSimpleResignalAs self assertSuccess: (ExceptionTester new runTest: #simpleResignalAsTest ) ! ! !ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 21:59'! testNonResumableOuter self should: [ [Error signal. 4] on: Error do: [:ex | ex outer. ex return: 5] ] raise: Error ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:46'! testSimpleIsNested self assertSuccess: (ExceptionTester new runTest: #simpleIsNestedTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:47'! testSimpleRetryUsing self assertSuccess: (ExceptionTester new runTest: #simpleRetryUsingTest ) ! ! !ExceptionTests methodsFor: 'testing-outer' stamp: 'StephaneDucasse 5/28/2011 13:49'! testResumablePass | result | result := [Notification signal. 4] on: Notification do: [:ex | ex pass. ex return: 5]. self assert: result = 4 ! ! !ExceptionTests methodsFor: 'testing-handling' stamp: 'SvenVanCaekenberghe 11/22/2013 16:25'! testHandlingExceptionSetWithExclusion | wasHandled | wasHandled := false. self should: [ [ ZeroDivide signalWithDividend: 1 ] on: Error, ArithmeticError - ZeroDivide do: [ :exception | wasHandled := true. exception return ] ] raise: ZeroDivide. self deny: wasHandled! ! !ExceptionTests methodsFor: 'testing-handling' stamp: 'GabrielOmarCotelli 11/21/2013 14:39'! testHandlingWhenThereIsSomeExclusionButDontApplies | wasHandled result | wasHandled := false. result := [ ZeroDivide signalWithDividend: 1. 2 ] on: Error - MessageNotUnderstood do: [ :exception | wasHandled := true. exception return ]. self assert: wasHandled; assert: result isNil! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:46'! testSimpleEnsureTestWithNotification self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithNotification ) ! ! !ExceptionTests methodsFor: 'private' stamp: 'md 3/25/2003 23:40'! assertSuccess: anExceptionTester self should: [ ( anExceptionTester suiteLog first) endsWith: 'succeeded'].! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'dtl 6/1/2004 21:54'! testDoubleOuterPass self assertSuccess: (ExceptionTester new runTest: #doubleOuterPassTest ) ! ! !ExceptionTests methodsFor: 'testing' stamp: 'brp 10/21/2004 16:42'! testNoTimeout self assertSuccess: (ExceptionTester new runTest: #simpleNoTimeoutTest ) ! ! !ExceptionTests methodsFor: 'testing-handling' stamp: 'GabrielOmarCotelli 11/21/2013 15:32'! testHandlingWithSeveralExclusionsAndExceptionSetsHandling | wasHandled result | wasHandled := false. result := [ ZeroDivide signalWithDividend: 1. 2 ] on: Error - MessageNotUnderstood - Warning do: [ :exception | wasHandled := true. exception return ]. self assert: wasHandled; assert: result isNil. wasHandled := false. result := [ ZeroDivide signalWithDividend: 1. 2 ] on: Error - (MessageNotUnderstood , Warning) do: [ :exception | wasHandled := true. exception return ]. self assert: wasHandled; assert: result isNil. ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:45'! testSimpleEnsureTestWithUparrow self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithUparrow ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:48'! testSimpleRetry self assertSuccess: (ExceptionTester new runTest: #simpleRetryTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:44'! testSignalFromHandlerActionTest self assertSuccess: (ExceptionTester new runTest: #signalFromHandlerActionTest ) ! ! !ExceptionTests methodsFor: 'testing-outer' stamp: 'StephaneDucasse 5/28/2011 13:50'! testResumableOuter | result | result := [Notification signal. 4] on: Notification do: [:ex | ex outer. ex return: 5]. self assert: result = 5 ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:44'! testNonResumableFallOffTheEndHandler self assertSuccess: (ExceptionTester new runTest: #nonResumableFallOffTheEndHandler ) ! ! !ExceptionTests methodsFor: 'testing' stamp: 'brp 10/21/2004 16:41'! testTimeoutWithZeroDuration self assertSuccess: (ExceptionTester new runTest: #simpleTimeoutWithZeroDurationTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:43'! testDoubleResume self assertSuccess: (ExceptionTester new runTest: #doubleResumeTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:41'! testSimpleOuter self assertSuccess: (ExceptionTester new runTest: #simpleOuterTest ) ! ! !ExceptionTests methodsFor: 'testing-handling' stamp: 'GabrielOmarCotelli 11/21/2013 14:38'! testHandlingWithExclusion | wasHandled | wasHandled := false. self should: [ [ ZeroDivide signalWithDividend: 1 ] on: Error - ZeroDivide do: [ :exception | wasHandled := true. exception return ] ] raise: ZeroDivide. self deny: wasHandled! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:48'! testSimpleResume self assertSuccess: (ExceptionTester new runTest: #simpleResumeTest ) ! ! !ExclusiveWeakMessageSend commentStamp: 'LaurentLaffont 4/15/2011 20:18'! See NonReentrantWeakMessageSend! !ExclusiveWeakMessageSend methodsFor: 'accessing' stamp: 'gvc 10/25/2006 18:07'! executing "Answer from the shared value holder." ^executing contents! ! !ExclusiveWeakMessageSend methodsFor: 'initialization' stamp: 'gvc 10/25/2006 18:13'! initialize "Initialize the receiver." executing := self class newSharedState. super initialize.! ! !ExclusiveWeakMessageSend methodsFor: 'accessing' stamp: 'gvc 10/25/2006 18:06'! executing: aBoolean "Set on the shared value holder." executing contents: aBoolean! ! !ExclusiveWeakMessageSend methodsFor: 'evaluating' stamp: 'gvc 7/30/2009 13:39'! basicExecuting: aValueHolder "Set the shared value holder." executing := aValueHolder! ! !ExclusiveWeakMessageSend class methodsFor: 'as yet unclassified' stamp: 'gvc 10/25/2006 18:13'! newSharedState "Answer a new ValueHolder with false as the contents." ^ValueHolder new contents: false! ! !Exit commentStamp: ''! An Exit is an exception that quit the image without saving with a given success status. Exit signalFaillure: 'something went wrong'! !Exit methodsFor: 'accessing' stamp: 'ErwanDouaille 4/8/2013 10:46'! status ^ status! ! !Exit methodsFor: 'accessing' stamp: 'ErwanDouaille 4/8/2013 11:07'! printMessage |stderr| stderr := VTermOutputDriver stderr. self isSuccess ifFalse: [ stderr red ]. stderr nextPutAll: self messageText; lf; clear.! ! !Exit methodsFor: 'accessing' stamp: 'CamilloBruni 4/20/2013 19:16'! defaultAction self messageText isEmpty ifFalse: [ self printMessage ]. Smalltalk exit: self status! ! !Exit methodsFor: 'accessing' stamp: 'ErwanDouaille 4/8/2013 10:46'! status: anInteger status := anInteger .! ! !Exit methodsFor: 'printing' stamp: 'CamilloBruni 5/9/2013 20:10'! printOn: aStream super printOn: aStream. aStream space print: self status.! ! !Exit methodsFor: 'testing' stamp: 'ErwanDouaille 4/8/2013 10:47'! isSuccess ^self status = 0! ! !Exit class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/8/2013 16:24'! failure ^ self status: 1! ! !Exit class methodsFor: 'signalling' stamp: 'ErwanDouaille 4/8/2013 10:52'! signalSuccess ^self success signal! ! !Exit class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/8/2013 16:24'! success ^ self status: 0! ! !Exit class methodsFor: 'signalling' stamp: 'ErwanDouaille 4/8/2013 10:53'! signalSuccess: aMessage ^self success signal: aMessage! ! !Exit class methodsFor: 'signalling' stamp: 'CamilloBruni 4/14/2013 22:27'! signalFailure: aMessage ^ self failure signal: aMessage! ! !Exit class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/8/2013 16:25'! status: aPositiveInteger ^ self new status: aPositiveInteger; yourself! ! !Exit class methodsFor: 'signalling' stamp: 'CamilloBruni 4/14/2013 22:27'! signalFailure ^ self failure signal! ! !ExpanderMorph commentStamp: 'gvc 5/18/2007 13:13'! A morph that can expand or collapse to show its contents.! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 11:32'! showMorphs: aBoolean "Hide/Show the other morphs." self submorphs do: [:m | m == self titleMorph ifFalse: [ m visible: aBoolean; disableTableLayout: aBoolean not]]! ! !ExpanderMorph methodsFor: 'accessing' stamp: 'GaryChambers 1/25/2011 13:48'! announcer "Answer the receiver's announcer, creating if required." ^ announcer ifNil: [ announcer := Announcer new ]! ! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 12/6/2011 11:51'! update: aspect "Update the receiver." aspect = #expanded ifTrue: [self spaceFillWeight: (self expanded ifTrue: [1] ifFalse: [0]). self showMorphs: self expanded. self fixLayout. self expanded ifTrue: [self announce: (ExpanderMorphExpanded on: self)] ifFalse: [self announce: (ExpanderMorphContracted on: self)]]! ! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 7/9/2013 11:22'! fixLayout "Fix the owner layout, nasty!!" self owner ifNil: [ ^ self ]. self owner allMorphsDo: [ :m | (m respondsTo: #resetExtent) ifTrue: [ self defer: (MessageSend receiver: m selector: #resetExtent). self defer: (MessageSend receiver: m selector: #setScrollDeltas) ]. (m isKindOf: self class) ifTrue: [ self defer: (MessageSend receiver: m selector: #adoptPaneColor) ] ]. self defer: (MessageSend receiver: self owner selector: #changed)! ! !ExpanderMorph methodsFor: 'accessing' stamp: 'gvc 7/27/2006 10:35'! titleMorph: aMorph "Set the value of titleMorph" titleMorph ifNotNil: [titleMorph delete; removeDependent: self]. titleMorph := aMorph. aMorph ifNotNil: [ aMorph addDependent: self. self addMorph: aMorph]! ! !ExpanderMorph methodsFor: 'accessing' stamp: 'gvc 7/27/2006 10:30'! titleMorph "Answer the value of titleMorph" ^ titleMorph! ! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/24/2011 13:23'! expandedSizingRigid "Set the vResizing to be (temporarily) #rigid." self expanded ifTrue: [self vResizing: #rigid]! ! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2006 10:30'! font: aFont "Set the title font" self titleMorph font: aFont! ! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/25/2011 13:46'! announce: anAnnouncement "see Announcements packages. No need to announce if no subscribers." announcer ifNotNil: [announcer announce: anAnnouncement]! ! !ExpanderMorph methodsFor: 'initialization' stamp: 'GaryChambers 12/8/2011 14:42'! initialize "Initialize the receiver." super initialize. self changeTableLayout; listDirection: #topToBottom; hResizing: #spaceFill; vResizing: #spaceFill; titleMorph: self defaultTitleMorph; expanded: false! ! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 11:23'! expanded "Answer whether the title is expanded." ^self titleMorph expanded! ! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 11:24'! addedMorph: aMorph "Notify the receiver that the given morph was just added." aMorph == self titleMorph ifFalse: [ self titleMorph ifNotNil: [ aMorph visible: self expanded; disableTableLayout: self expanded not]]! ! !ExpanderMorph methodsFor: 'accessing' stamp: 'GaryChambers 1/25/2011 13:40'! announcer: anObject announcer := anObject! ! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 11:23'! expanded: aBoolean "Set whether the title is expanded." self titleMorph expanded: aBoolean! ! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2006 10:29'! font "Answer the title font" ^self titleMorph font! ! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 10:55'! titleText: aStringOrText "Set the text if the title morph is capable." (self titleMorph respondsTo: #titleText:) ifTrue: [self titleMorph titleText: aStringOrText]! ! !ExpanderMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 12/8/2011 16:48'! defaultTitleMorph "Answer a default title morph for the receiver." ^ExpanderTitleMorph basicNew basicTheme: self theme; initialize; hResizing: #spaceFill; vResizing: #shrinkWrap; basicTheme: nil! ! !ExpanderMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 10:54'! titleText: aStringOrText "Answer a new instance of the receiver with the given title text." ^self new titleText: aStringOrText! ! !ExpanderMorphAnnouncement methodsFor: 'accessing' stamp: 'GaryChambers 1/25/2011 13:32'! expanderMorph ^ expanderMorph! ! !ExpanderMorphAnnouncement methodsFor: 'accessing' stamp: 'GaryChambers 1/25/2011 13:32'! expanderMorph: anObject expanderMorph := anObject! ! !ExpanderMorphAnnouncement class methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/25/2011 13:45'! on: anExpanderMorph "Answer a new announcement for the given expander." ^self new expanderMorph: anExpanderMorph! ! !ExpanderMorphContracted commentStamp: 'LaurentLaffont 4/15/2011 20:18'! I am an Announcement that occurs when an ExpanderMorph is contracted (rolled-up). Example where visibility of another UI component depends on the expanded/contracted state of Expander 2 |builder expanders ex1 ex2 text list row| builder := UITheme builder. expanders := builder newColumn: { ex1 := builder newExpander: 'Expander 1'. ex2 := builder newExpander: 'Expander 2'}. expanders width: 100; hResizing: #rigid. text := builder newTextEditorFor: (ValueHolder new contents: 'Some text') getText: #contents setText: #contents:. list := (builder newListFor: (ListModel new list: #('One' 'Two' 'Three' 'Four'); selectionIndex: 3) list: #list selected: #selectionIndex changeSelected: #selectionIndex: help: 'This is a list') minWidth: 120; visible: false; disableTableLayout: true. ex2 announcer when: ExpanderMorphContracted do: [list hide; disableTableLayout: true]; when: ExpanderMorphExpanded do: [list show; disableTableLayout: false]. row := builder newRow: { expanders. (builder newRow: {text. list}) vResizing: #spaceFill}.! !ExpanderTitleMorph commentStamp: 'gvc 5/18/2007 13:12'! The titlebar area for and ExpanderMorph. Includes title label and expand/collapse button.! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/20/2010 11:59'! themeChanged "Update the button corner style from default to match the receiver." super themeChanged. self buttonMorph cornerStyle: self cornerStyle! ! !ExpanderTitleMorph methodsFor: 'accessing' stamp: 'GaryChambers 7/27/2011 18:04'! labelMorph: anObject "Set the value of labelMorph. need to wrap to provide clipping!!" labelMorph ifNotNil: [self removeMorph: labelMorph owner]. labelMorph := anObject. labelMorph ifNotNil: [self addMorph: ( Morph new color: Color transparent; changeTableLayout; layoutInset: 4 @ 0; listDirection: #leftToRight; listCentering: #center; hResizing: #spaceFill; vResizing: #shrinkWrap; clipSubmorphs: true; addMorph: labelMorph)]! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 12/21/2011 16:29'! extent: aPoint "Set the receiver's extent to value provided. Update the gradient fills." |answer| aPoint = self extent ifTrue: [^super extent: aPoint]. answer := super extent: aPoint. self fillStyle isOrientedFill ifTrue: [self fillStyle: self normalFillStyle]. ^answer! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/17/2009 14:33'! buttonWidth "Answer based on scrollbar size." ^(self theme scrollbarThickness + 3) max: self theme expanderTitleControlButtonWidth! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/23/2009 16:30'! adoptPaneColor: paneColor "Update the fill styles, corner styles, label colour and expansion button indicator." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self fillStyle: self normalFillStyle. self borderStyle baseColor: paneColor twiceDarker. self buttonMorph cornerStyle: self cornerStyle. self labelMorph color: paneColor contrastingColor. self changed: #expandLabel! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/23/2007 14:28'! normalFillStyle "Return the normal fillStyle of the receiver." ^self theme expanderTitleNormalFillStyleFor: self! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2006 10:28'! font: aFont "Set the label font" ((self labelMorph isKindOf: StringMorph) or: [self labelMorph isTextMorph]) ifTrue: [self labelMorph font: aFont]! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 7/27/2011 17:10'! newLabelMorph "Answer a new label morph for the receiver." ^LabelMorph new hResizing: #spaceFill; vResizing: #shrinkWrap! ! !ExpanderTitleMorph methodsFor: 'initialization' stamp: 'gvc 1/22/2009 15:37'! initialize "Initialize the receiver." super initialize. self expanded: false; changeTableLayout; borderStyle: self defaultBorderStyle; layoutInset: (self theme expanderTitleInsetFor: self); listDirection: #leftToRight; listCentering: #center; wrapCentering: #center; buttonMorph: self newExpandButtonMorph; addMorph: self buttonMorph; labelMorph: self newLabelMorph; on: #mouseUp send: #toggleExpanded to: self! ! !ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 7/27/2006 10:16'! expanded "Answer the value of expanded" ^ expanded! ! !ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 9/13/2006 10:23'! labelMorph "Answer the value of labelMorph" ^ labelMorph! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/27/2006 10:23'! toggleExpanded "Toggle the expanded state." self expanded: self expanded not! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/23/2006 16:46'! defaultBorderStyle "Answer the default border style for the receiver." ^BorderStyle raised width: 1! ! !ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 1/22/2009 15:37'! buttonMorph: anObject "Set the value of buttonMorph" buttonMorph := anObject! ! !ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 7/27/2006 10:24'! expanded: aBoolean "Set the value of expanded" expanded := aBoolean. self changed: #expanded; changed: #expandLabel! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2006 10:29'! font "Answer the label font" ^((self labelMorph isKindOf: StringMorph) or: [self labelMorph isTextMorph]) ifTrue: [self labelMorph font]! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/31/2009 16:41'! expandLabel "Answer the label for the expand button." ^AlphaImageMorph new image: ( ScrollBar arrowOfDirection: (self expanded ifTrue: [#top] ifFalse: [#bottom]) size: self buttonWidth - 3 color: self paneColor darker)! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/22/2009 15:35'! newExpandButtonMorph "Answer a new expand button." ^(ControlButtonMorph on: self getState: nil action: #toggleExpanded label: #expandLabel) hResizing: #rigid; vResizing: #spaceFill; cornerStyle: self cornerStyle; extent: self buttonWidth asPoint! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/13/2006 10:24'! titleText: aStringOrText "Set the text if the title morph is capable." ((self labelMorph isKindOf: StringMorph) or: [self labelMorph isTextMorph]) ifTrue: [self labelMorph contents: aStringOrText]! ! !ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 1/22/2009 15:37'! buttonMorph "Answer the value of buttonMorph" ^ buttonMorph! ! !ExpanderTitleMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/18/2006 11:15'! titleText "Answer the text if the title morph is capable." ^((self labelMorph isKindOf: StringMorph) or: [self labelMorph isTextMorph]) ifTrue: [self labelMorph contents] ifFalse: ['']! ! !ExpressionEvaluated commentStamp: ''! This announcement correspond to code evaluation. For example, a DoIt or PrintIt evaluated in a workspace raises one of this announcements.! !ExpressionEvaluated methodsFor: 'temporal for remove' stamp: 'GuillermoPolito 8/2/2012 00:42'! expression ^self expressionEvaluated! ! !ExpressionEvaluated methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:42'! expressionEvaluated ^ expressionEvaluated! ! !ExpressionEvaluated methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:42'! context: anObject context := anObject! ! !ExpressionEvaluated methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:42'! expressionEvaluated: anObject expressionEvaluated := anObject! ! !ExpressionEvaluated methodsFor: 'temporal for remove' stamp: 'GuillermoPolito 8/2/2012 00:50'! item ^expressionEvaluated! ! !ExpressionEvaluated methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:42'! context ^ context! ! !ExpressionEvaluated class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:41'! expression: theEvaluatedExpression ^self expression: theEvaluatedExpression context: nil! ! !ExpressionEvaluated class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:42'! expression: theEvaluatedExpression context: anExecutionContext ^self new expressionEvaluated: theEvaluatedExpression; context: anExecutionContext; yourself! ! !ExtendedTabPanelBorder commentStamp: ''! Specialized border for TabGroup. Does not draw border beneath the selectd tab and only draws on top.! !ExtendedTabPanelBorder methodsFor: 'as yet unclassified' stamp: 'GaryChambers 6/8/2011 12:02'! frameRectangle: aRectangle on: aCanvas "Draw the border taking the currently selected tab into account. Only works for top-positioned tabs for the moment." |w h r tab| w := self width. w isPoint ifTrue: [h := w y. w := w x] ifFalse:[h := w]. tab := self selectedTab. (tab isNil or: [tab owner isNil]) ifTrue: [ r := aRectangle topLeft + (w@0) corner: aRectangle topRight - (w@h negated). aCanvas fillRectangle: r color: self color. ^self]. "top" r := aRectangle topLeft + (w@0) corner: tab bounds left + w@(aRectangle top + h). aCanvas fillRectangle: r color: self color. "top 1" r := tab bounds left + w@ aRectangle top corner: tab bounds right - w@(aRectangle top + h). aCanvas fillRectangle: r color: tab paneColor. "top 2" r := tab bounds right - w@ aRectangle top corner: aRectangle topRight - (w@h negated). aCanvas fillRectangle: r color: self color. "top 3"! ! !ExternalClipboard commentStamp: 'michael.rueger 3/2/2009 13:25'! An ExternalClipboard is the abstract superclass for the platform specific clipboards based on the clipboard plugin (former ExtendedClipboardInterface originally developed for Sophie). Instance Variables clipboard: SmallInteger clipboard - handle for the external clipboard. If 0 the external clipboard is invalid ! !ExternalClipboard methodsFor: 'initialization' stamp: 'StephaneDucasse 8/30/2009 14:55'! initialize super initialize. clipboard := [self createClipboard] on: Error do: [:ex | clipboard := 0]! ! !ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/2/2009 13:42'! primClearClipboard: aClipboard ^ self primitiveFailed. ! ! !ExternalClipboard methodsFor: 'primitives' stamp: 'marcus.denker 6/11/2009 12:24'! primReadClipboardData: aClipboard format: format ^ self primitiveFailed! ! !ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/25/2009 14:22'! addClipboardData: data dataFormat: aFormat clipboard = 0 ifTrue: [Clipboard clipboardText: data asString. ^self]. self primAddClipboardData: clipboard data: data dataFormat: aFormat! ! !ExternalClipboard methodsFor: 'accessing' stamp: 'michael.rueger 3/25/2009 14:47'! clipboardText: text | string data | string := text asString. self noteRecentClipping: text asText. contents := text asText. data := (string convertToWithConverter: UTF8TextConverter new) asByteArray. clipboard = 0 ifTrue: [^super clipboardText: text]. self clearClipboard. self primAddClipboardData: clipboard data: data dataFormat: 'public.utf8-plain-text'! ! !ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/2/2009 13:42'! primCreateClipboard ^ self primitiveFailed. ! ! !ExternalClipboard methodsFor: 'accessing' stamp: 'michael.rueger 6/10/2009 13:42'! clipboardText "Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard." | decodedString bytes | clipboard = 0 ifTrue: [^super clipboardText]. bytes := self primReadClipboardData: clipboard format: 'public.utf8-plain-text'. bytes ifNil: [^super clipboardText]. decodedString := bytes asString convertFromWithConverter: UTF8TextConverter new. decodedString := decodedString replaceAll: 10 asCharacter with: 13 asCharacter. ^decodedString = contents asString ifTrue: [contents] ifFalse: [decodedString asText]. ! ! !ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/25/2009 14:25'! primGetClipboardFormat: aClipboard formatNumber: formatNumber ^ self primitiveFailed! ! !ExternalClipboard methodsFor: 'accessing' stamp: 'michael.rueger 3/2/2009 13:42'! clearClipboard clipboard = 0 ifTrue: [^self]. ^ self primClearClipboard: clipboard.! ! !ExternalClipboard methodsFor: 'private' stamp: 'michael.rueger 3/2/2009 13:42'! createClipboard clipboard = 0 ifTrue: [^self]. ^ self primCreateClipboard.! ! !ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/25/2009 14:25'! primAddClipboardData: aClipboard data: data dataFormat: aFormat ^ self primitiveFailed! ! !ExternalDropHandler commentStamp: 'TorstenBergmann 1/31/2014 10:29'! Handle a number of dropped files from the OS! !ExternalDropHandler methodsFor: 'accessing' stamp: ''! extension ^extension! ! !ExternalDropHandler methodsFor: 'accessing' stamp: ''! handle: dropStream in: pasteUp dropEvent: anEvent ^action cull: dropStream cull: pasteUp cull: anEvent ! ! !ExternalDropHandler methodsFor: 'accessing' stamp: ''! type ^type! ! !ExternalDropHandler methodsFor: 'testing' stamp: 'CamilloBruni 5/7/2012 01:19'! matchesExtension: aExtension (self extension isNil or: [aExtension isNil]) ifTrue: [^false]. FileSystem disk isCaseSensitive ifTrue: [^extension = aExtension] ifFalse: [^extension sameAs: aExtension]! ! !ExternalDropHandler methodsFor: 'testing' stamp: ''! matchesTypes: types (self type isNil or: [types isNil]) ifTrue: [^false]. ^types anySatisfy: [:mimeType | mimeType beginsWith: self type]! ! !ExternalDropHandler methodsFor: 'initialize' stamp: ''! type: aType extension: anExtension action: anAction action := anAction. type := aType. extension := anExtension! ! !ExternalDropHandler class methodsFor: 'accessing' stamp: ''! defaultHandler DefaultHandler ifNil: [DefaultHandler := ExternalDropHandler type: nil extension: nil action: [:dropStream | dropStream edit]]. ^DefaultHandler! ! !ExternalDropHandler class methodsFor: 'initialization' stamp: 'PavelKrivanek 11/20/2012 21:25'! initialize "ExternalDropHandler initialize" self resetRegisteredHandlers. ! ! !ExternalDropHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 5/23/2012 16:55'! lookupServiceBasedHandler: dropStream "the file was just droped, let's do our job" | fileName services theOne | fileName := dropStream name. services := (Smalltalk tools fileList itemsForFile: fileName asFileReference) reject: [:svc | self unwantedSelectors includes: svc selector]. "no service, default behavior" services isEmpty ifTrue: [^nil]. theOne := self chooseServiceFrom: services. ^theOne ifNotNil: [ExternalDropHandler type: nil extension: nil action: [:stream | theOne performServiceFor: stream]]! ! !ExternalDropHandler class methodsFor: 'private' stamp: ''! chooseServiceFrom: aCollection "private - choose a service from aCollection asking the user if needed" aCollection size = 1 ifTrue: [^ aCollection anyOne]. ^ UIManager default chooseFrom: (aCollection collect: [:each | each label]) values: aCollection. ! ! !ExternalDropHandler class methodsFor: 'private' stamp: ''! unwantedSelectors "private - answer a collection well known unwanted selectors " ^ #(#removeLineFeeds: #addFileToNewZip: #compressFile: #putUpdate: )! ! !ExternalDropHandler class methodsFor: 'private' stamp: ''! resetRegisteredHandlers RegisteredHandlers := nil! ! !ExternalDropHandler class methodsFor: 'accessing' stamp: ''! defaultHandler: externalDropHandler DefaultHandler := externalDropHandler! ! !ExternalDropHandler class methodsFor: 'private' stamp: ''! registeredHandlers RegisteredHandlers ifNil: [RegisteredHandlers := OrderedCollection new]. ^RegisteredHandlers! ! !ExternalDropHandler class methodsFor: 'instance creation' stamp: ''! type: aType extension: anExtension action: anAction ^self new type: aType extension: anExtension action: anAction ! ! !ExternalDropHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 5/4/2012 21:26'! lookupExternalDropHandler: stream | types extension serviceHandler | types := stream mimeTypes. types ifNotNil: [ self registeredHandlers do: [:handler | (handler matchesTypes: types) ifTrue: [^handler]]]. extension := stream name asFileReference extension. self registeredHandlers do: [:handler | (handler matchesExtension: extension) ifTrue: [^handler]]. serviceHandler := self lookupServiceBasedHandler: stream. ^serviceHandler ifNil: [self defaultHandler]! ! !ExternalDropHandler class methodsFor: 'accessing' stamp: ''! registerHandler: aHandler self registeredHandlers add: aHandler! ! !ExternalDropHandler class methodsFor: 'cleanup' stamp: 'MarcusDenker 7/26/2013 17:00'! cleanUp self resetRegisteredHandlers.! ! !ExternalSemaphoreTable commentStamp: 'HenrikSperreJohansen 8/18/2011 11:25'! By John M McIntosh johnmci@smalltalkconsulting.com This class was written to mange the external semaphore table. When I was writing a Socket test server I discovered various race conditions on the access to the externalSemaphore table. This new class uses class side methods to restrict access using two mutex semaphores, one for removal and one for additions to the table. It seemed cleaner to deligate the reponsibility here versus adding more code and another class variable to SystemDictionary Note that in Smalltalk recreateSpecialObjectsArray we still directly play with the table. Henrik Sperre Johansen The name is somewhat of a misnomer; the table can be used for any objects, not just semaphores. That is its main usage though, so a split which deals with semaphores and other external objects differently (In the same underlying table) is not currently worth it. Therefore, while in general not all users will care if the table is above a certain size, we still guard against adding more objects than the limit above which external signals would be lost (on some VMs.) ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 8/17/2011 14:55'! registerExternalObject: anObject ^ ProtectAdd critical: [self safelyRegisterExternalObject: anObject] ! ! !ExternalSemaphoreTable class methodsFor: 'private' stamp: 'HenrikSperreJohansen 8/16/2011 14:45'! unprotectedExternalObjects ^Smalltalk specialObjectsArray at: 39! ! !ExternalSemaphoreTable class methodsFor: 'initialize' stamp: 'HenrikSperreJohansen 8/17/2011 14:54'! initialize ProtectAdd := Semaphore forMutualExclusion. ProtectRemove := Semaphore forMutualExclusion! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 8/17/2011 14:55'! unregisterExternalObject: anObject ProtectRemove critical: [self safelyUnregisterExternalObject: anObject] ! ! !ExternalSemaphoreTable class methodsFor: 'private' stamp: 'HenrikSperreJohansen 8/18/2011 10:33'! collectionBasedOn: externalObjects withRoomFor: anObject "Called if no slots to put anObject in have been found in externalObjects " "Return a externalObject collection which does, either: - Same collection with some slots freed up by finalization logic - A larger array, which has replaced the parameter as canonical externalObject array. An error must be raised if this method is incapable of fulfilling its duties" | newObjects newSize | "grow linearly" newSize := externalObjects size +20. (self freedSlotsIn: externalObjects ratherThanIncreaseSizeTo: newSize) ifTrue: [newObjects := externalObjects] ifFalse: [ newObjects := externalObjects species new: newSize. newObjects replaceFrom: 1 to: externalObjects size with: externalObjects startingAt: 1. self unprotectedExternalObjects: newObjects.]. ^newObjects! ! !ExternalSemaphoreTable class methodsFor: 'private' stamp: 'HenrikSperreJohansen 8/16/2011 14:45'! unprotectedExternalObjects: aCollection ^Smalltalk specialObjectsArray at: 39 put: aCollection! ! !ExternalSemaphoreTable class methodsFor: 'private' stamp: 'ClementBera 4/11/2013 14:06'! slotFor: anObject in: aCollection "find the first empty slot, or nil if there is none" "The following was written in an atomic fashion using special methods with no suspension points, not sure if on purpose, but keeping it that way for now. Uses should be protected by the ProtectTable semaphore anyhow, but... it's too much work to reason 100% about it" | firstEmptyIndex | 1 to: aCollection size do: [ :i | | obj | obj := aCollection at: i. obj == anObject ifTrue: [ ^ i ]. "object already there, just return its index" (firstEmptyIndex isNil and: [ obj isNil ]) ifTrue: [ firstEmptyIndex := i ] ]. ^ firstEmptyIndex! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 8/18/2011 10:18'! clearExternalObjects "Clear the array of objects that have been registered for use in non-Smalltalk code." "Only lock additions, removals executing in parallel would have little effect on the resulting array" ProtectAdd critical: [ self unprotectedExternalObjects: Array new]. ! ! !ExternalSemaphoreTable class methodsFor: 'private' stamp: 'SvenVanCaekenberghe 11/18/2013 16:20'! freedSlotsIn: externalObjects ratherThanIncreaseSizeTo: newSize "In some VM's, the external object table has a max size, which has to be increased for vm to reference them correctly." "In that case, try to gc to free slots first before actually increasing the max size" "Return whether I ended up freeing slots by GC'ing, or one should increase the size of " ^Smalltalk vm maxExternalSemaphores ifNotNil: [:maxSize | (maxSize < newSize) and: [| needToGrow | Smalltalk garbageCollect. "Do we have free slots now? If not, performing the GC didn't help and we still have to grow." needToGrow := externalObjects includes: nil. needToGrow ifTrue: ["If we did GC, warn we had to gc so actions could be taken if appropriate." self traceCr: DateAndTime now printString; traceCr: 'WARNING: Had to GC to make room for more external objects.'; traceCr: 'If this happens often, it would be a good idea to either:'; traceCr: '- Raise the maxExternalObjects size.'; traceCr: '- Write your code to explicitly release them rather than wait for finalization.'] ifFalse: [Smalltalk vm maxExternalSemaphores: newSize]. needToGrow]] ifNil:[false]! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 7/15/2011 15:30'! safelyUnregisterExternalObject: anObject "Unregister the given object in the external objects array. Do nothing if it isn't registered. JMM change to return if we clear the element, since it should only appear once in the array" | objects | anObject ifNil: [^ self]. objects := self unprotectedExternalObjects. 1 to: objects size do: [:i | (objects at: i) == anObject ifTrue: [objects at: i put: nil. ^self]]. ! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'ClementBera 4/11/2013 14:01'! safelyRegisterExternalObject: anObject "Register the given object in the external objects array and return its index. If it is already there, just return its index." | objects firstEmptyIndex | objects := self unprotectedExternalObjects. "find the first empty slot" firstEmptyIndex := (self slotFor: anObject in: objects) ifNil: ["if object has no empty slots, we need to get a collection which does" objects := self collectionBasedOn: objects withRoomFor: anObject. self slotFor: anObject in: objects.]. objects at: firstEmptyIndex put: anObject. ^ firstEmptyIndex ! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 8/18/2011 10:42'! externalObjects "Not really sure why this is protected, once called you are out of protection of the locks anyways, and any use of the object is dangerous... Only additions can potentially change the actual array in use though, so only lock that." ^ProtectAdd critical: [self unprotectedExternalObjects].! ! !EyeAbstractInspector commentStamp: ''! I am the abstract superclass for all kind of inspectors! !EyeAbstractInspector methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! object ^ object value! ! !EyeAbstractInspector methodsFor: 'initialization' stamp: 'CamilloBruni 10/15/2013 17:25'! initializeShortcuts "override to add custom shortcuts to your model"! ! !EyeAbstractInspector methodsFor: 'event-handling' stamp: 'CamilloBruni 9/20/2013 20:39'! close "Override in sublcasses for special actions"! ! !EyeAbstractInspector methodsFor: 'event-handling' stamp: 'CamilloBruni 9/20/2013 18:25'! objectChanged "triggered when the inspected object is changed" self subclassResponsibility! ! !EyeAbstractInspector methodsFor: 'actions' stamp: ''! inspectInNewWindow: anObject anObject inspect! ! !EyeAbstractInspector methodsFor: 'event-handling' stamp: 'CamilloBruni 10/15/2013 18:25'! ownerChanged self customMenuActions: self owner customMenuActions; takeKeyboardFocus! ! !EyeAbstractInspector methodsFor: 'actions' stamp: ''! browseSelectedObjectClass self selectedObjectDo: [ :anObject | Smalltalk tools browser newOnClass: anObject class ]! ! !EyeAbstractInspector methodsFor: 'accessing' stamp: 'CamilloBruni 10/15/2013 18:26'! customMenuActions: anObject customMenuActions := anObject! ! !EyeAbstractInspector methodsFor: 'testing' stamp: 'CamilloBruni 10/15/2013 18:11'! hasSelectedObject ^ self selectedElement isNotNil! ! !EyeAbstractInspector methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize "The inspected object will be stored in the valueObject object to be able to use WhenObjectChanged:" object := nil asReactiveVariable. super initialize. ! ! !EyeAbstractInspector methodsFor: 'accessing' stamp: 'CamilloBruni 10/15/2013 17:05'! selectedObject ^ self subclassResponsibility! ! !EyeAbstractInspector methodsFor: 'initialization' stamp: 'CamilloBruni 10/15/2013 17:12'! shortCuts "Answers a dictionary of the shortcuts usable in EyeInspector" |shortCuts| shortCuts := Dictionary new. shortCuts at: $d command put: [ self diveIntoSelectedObject ]. shortCuts at: $i command put: [ self inspectSelectedObjectInNewWindow ]. shortCuts at: $i command shift put: [ self exploreSelectedObject ]. shortCuts at: $b command put: [ self browseSelectedObject ]. shortCuts at: $h command put: [ self browseSelectedObjectClassHierarchy ]. ^shortCuts! ! !EyeAbstractInspector methodsFor: 'initialization' stamp: 'CamilloBruni 10/15/2013 17:32'! initializePresenter object whenChangedDo: [ self objectChanged ]. self initializeShortcuts.! ! !EyeAbstractInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 22:47'! title ^ self object class printString! ! !EyeAbstractInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 19:24'! inspect: anObject self object: anObject. ! ! !EyeAbstractInspector methodsFor: 'actions' stamp: ''! browseSelectedObject self selectedObjectDo: [ :anObject | anObject browse ]! ! !EyeAbstractInspector methodsFor: 'api' stamp: 'CamilloBruni 2/25/2014 18:39'! labelFor: anEyeElement error: error ^ 'Error while accessing label of ', anEyeElement accessorCode printString! ! !EyeAbstractInspector methodsFor: 'menu' stamp: 'CamilloBruni 10/15/2013 18:43'! refreshSubMenu: aMenu "Add a refresh button in the inspector. Not used anymore since there is this loop in initializeInspectorLoop." aMenu add: 'Refresh Inspector' translated target: self selector: #refresh. aMenu addLine. ! ! !EyeAbstractInspector methodsFor: 'private-focus' stamp: 'CamilloBruni 10/15/2013 18:26'! takeKeyboardFocus super takeKeyboardFocus! ! !EyeAbstractInspector methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! object: anObject object value: anObject! ! !EyeAbstractInspector methodsFor: 'accessing' stamp: 'abc 10/18/2013 14:54'! selectedObjectDo: aBlock self selectedElement ifNotNil: [ :element | aBlock value: element value ]! ! !EyeAbstractInspector methodsFor: 'event-handling' stamp: 'BenjaminVanRyseghem 11/8/2013 17:52'! diveInto: anObject self owner ifNotNil: [ :navigator | (navigator respondsTo: #diveInto:) ifTrue: [ ^ navigator diveInto: anObject ] ]. self inspectInNewWindow: anObject.! ! !EyeAbstractInspector methodsFor: 'actions' stamp: 'CamilloBruni 10/15/2013 18:19'! diveIntoSelectedObject self selectedObjectDo: [ :anObject | self diveInto: anObject ]! ! !EyeAbstractInspector methodsFor: 'initialization' stamp: 'CamilloBruni 9/21/2013 14:35'! initializeWidgets! ! !EyeAbstractInspector methodsFor: 'menu' stamp: 'CamilloBruni 10/15/2013 18:29'! inspectionMenu: aMenu self hasSelectedObject ifFalse: [ ^ aMenu ]. self inspectionSubMenu: aMenu. self selectedElement inspectionMenu: aMenu. ^aMenu! ! !EyeAbstractInspector methodsFor: 'accessing' stamp: 'MarcusDenker 12/2/2013 14:06'! selectedElementDo: aBlock self selectedElement ifNotNil: aBlock! ! !EyeAbstractInspector methodsFor: 'menu' stamp: 'BenjaminVanRyseghem 11/1/2013 15:50'! inspectionSubMenu: aMenu aMenu addGroup: [:aGroup | aGroup addItem: [ :item | item name: 'Inspect' translated; action: [ self inspectSelectedObjectInNewWindow ]; shortcut: $i command mac | $i alt win | $i alt unix ]. aGroup addItem: [ :item | item name: 'Explore' translated; action: [ self exploreSelectedObject ]; shortcut: $i shift command mac | $i shift alt win | $i shift alt unix ]. self customMenuActions cull: aMenu cull: aGroup. ]! ! !EyeAbstractInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 16:08'! variants | variants defaultInspectorClass | variants := OrderedCollection new. defaultInspectorClass := self object class inspectorClass. variants add: defaultInspectorClass. "We only need the basic inspector if we modify something" defaultInspectorClass = Object inspectorClass ifFalse: [ variants add: EyeBasicInspector ]. variants add: EyeTreeInspector. variants addAll: self object class additionalInspectorClasses. ^ variants! ! !EyeAbstractInspector methodsFor: 'actions' stamp: ''! browseSelectedObjectClassHierarchy self selectedObjectDo: [ :anObject | anObject class browseHierarchy ]! ! !EyeAbstractInspector methodsFor: 'accessing' stamp: 'CamilloBruni 10/15/2013 18:26'! customMenuActions ^ customMenuActions ifNil: [ customMenuActions := [ ] ]! ! !EyeAbstractInspector methodsFor: 'accessing' stamp: 'CamilloBruni 10/15/2013 18:11'! selectedElement "return the currently selected object wrapper / eye-element" ^ self subclassResponsibility! ! !EyeAbstractInspector methodsFor: 'actions' stamp: ''! exploreSelectedObject self selectedObjectDo: [ :anObject | anObject explore ].! ! !EyeAbstractInspector methodsFor: 'actions' stamp: ''! inspectSelectedObjectInNewWindow self selectedObjectDo: [ :anObject | self inspectInNewWindow: anObject ].! ! !EyeAbstractInspector class methodsFor: 'spec' stamp: 'CamilloBruni 9/20/2013 20:31'! debuggerSpec ^ self inspectorSpec! ! !EyeAbstractInspector class methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 20:10'! taskbarIcon ^ Smalltalk ui icons smallInspectItIcon! ! !EyeAbstractInspector class methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 18:37'! label "Override to return a proper label displayd in the inspector choice" ^ self name! ! !EyeAbstractInspector class methodsFor: 'spec' stamp: 'CamilloBruni 9/20/2013 20:30'! inspectorSpec self subclassResponsibility! ! !EyeBagInspector commentStamp: ''! Specialized version of inspector showing occurrences of items of the bag! !EyeBagInspector methodsFor: 'list' stamp: 'ClementBera 8/12/2013 10:33'! sortedKeys ^ [ [ self object valuesAndCounts keys sorted ] on: Error do: [ "case of non sortable keys" self object valuesAndCounts keys ] ] on: Error do: [ #() ]! ! !EyeBagInspector methodsFor: 'list' stamp: 'ClementBera 8/12/2013 10:35'! addVariableFields: elements self sortedKeys do: [ :key | elements add: (BagEyeElement host: self object index: key)]! ! !EyeBasicInspector commentStamp: ''! I am a special inspector that only lists the real fields of an object. I have exactly the same behavior as my superclass but I am used as a placeholder for the the different inspector views in the InspectorNavigator.! !EyeBasicInspector class methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 18:39'! label ^ 'Basic Inspector'! ! !EyeByteArrayInspector commentStamp: ''! Specialized version of inspector showing the hex and string representation of the byte array in some variations. ! !EyeByteArrayInspector methodsFor: 'converting' stamp: 'SvenVanCaekenberghe 12/21/2013 20:50'! objectAsLatin1String | width str | str := String new: (width := self object size < 5000 ifTrue: [ self object size ] ifFalse: [ 5000 ]). str replaceFrom: 1 to: str size with: (self object copyFrom: 1 to: width). ^ str! ! !EyeByteArrayInspector methodsFor: 'converting' stamp: 'SvenVanCaekenberghe 12/21/2013 20:56'! objectAsHexBytes ^ String streamContents: [ :s | s nextPutAll: '['. self object do: [ :each | s << (each printPaddedWith: $0 to: 2 base: 16) ] separatedBy: [ s nextPut: $ ]. s nextPut: $] ] limitedTo: 5000! ! !EyeByteArrayInspector methodsFor: 'list' stamp: 'SvenVanCaekenberghe 2/25/2014 09:03'! addSpecialFields: elements elements add: (DynamicEyeElement host: self object label: 'hex bytes' description: [ self objectAsHexBytes ] value: [ self object ]). elements add: (DynamicEyeElement host: self object label: 'hex string' value: [ self objectAsHexString ]). elements add: (DynamicEyeElement host: self object label: 'latin-1 string' value: [ self objectAsLatin1String ]). elements add: (DynamicEyeElement host: self object label: 'utf-8 string' value: [ [ self objectAsUTF8String ] on: ZnInvalidUTF8 do: [ :exception | exception asString ] ]).! ! !EyeByteArrayInspector methodsFor: 'converting' stamp: 'SvenVanCaekenberghe 12/21/2013 21:01'! objectAsUTF8String ^ String streamContents: [ :out | | in encoder | encoder := ZnUTF8Encoder new. in := self object readStream. [ in atEnd ] whileFalse: [ out nextPut: (encoder nextFromStream: in) ] ] limitedTo: 5000! ! !EyeByteArrayInspector methodsFor: 'converting' stamp: 'SvenVanCaekenberghe 12/21/2013 20:56'! objectAsHexString ^ String streamContents: [ :s | self object do: [ :each | s << (each printPaddedWith: $0 to: 2 base: 16) ] ] limitedTo: 5000! ! !EyeCharacterInspector commentStamp: 'SvenVanCaekenberghe 2/24/2014 14:44'! I am EyeCharacterInspector. I am a EyeInspector. I offer a specialized inspector to look at Character instances. I show the Unicode code point in standard notation, like U+0041 for $A. ! !EyeCharacterInspector methodsFor: 'converting' stamp: 'SvenVanCaekenberghe 2/24/2014 14:51'! objectAsUnicodeCodePoint ^ String streamContents: [ :stream | stream << 'U+'. self object codePoint printOn: stream base: 16 nDigits: 4 ]! ! !EyeCharacterInspector methodsFor: 'list' stamp: 'SvenVanCaekenberghe 2/25/2014 09:01'! addSpecialFields: elements elements add: (DynamicEyeElement host: self object label: 'unicode' description: [ self objectAsUnicodeCodePoint ] value: [ self object codePoint ])! ! !EyeCollectionInspector commentStamp: ''! Specialized version of inspector showing the size of the inspected collection in title.! !EyeCollectionInspector methodsFor: 'list' stamp: 'ClementBera 5/3/2013 14:00'! addInstancesVariable: elements "Do nothing"! ! !EyeCollectionInspector methodsFor: 'accessing' stamp: 'ClementBera 6/25/2013 14:25'! objectVariableSize ^ [ self object size ] on: Error do: [ self object basicSize ]! ! !EyeCollectionInspector methodsFor: 'list' stamp: 'ClementBera 4/30/2013 16:03'! addVariableFields: elements "add the variable fields to the inspector. Shorten the list for very long collection (cf limit1 and limit2), set them so that you can modify and save them" self variableFieldsToShow do: [ :index | elements add: (IndexedEyeElement host: self object index: index) ]! ! !EyeCollectionInspector methodsFor: 'accessing' stamp: 'ClementBera 3/7/2014 11:54'! title ^ super title, ' [', self objectVariableSize asString, ']' ! ! !EyeCollectionInspector methodsFor: 'list' stamp: 'ClementBera 5/3/2013 14:00'! addAllInstVars: elements "Do nothing"! ! !EyeCollectionInspector class methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 21:13'! label ^ 'Collection Inspector'! ! !EyeCompiledMethodInspector commentStamp: ''! Specialized version of inspector showing bytecodes symbolic representation, ast, ir, literals.! !EyeCompiledMethodInspector methodsFor: 'list' stamp: 'ClementBera 5/2/2013 10:23'! addInstancesVariable: elements "Do nothing"! ! !EyeCompiledMethodInspector methodsFor: 'list' stamp: 'ClementBera 5/3/2013 14:17'! addVariableFields: elements self object initialPC to: self object size do: [ :index | elements add: (DynamicEyeElement host: self object label: 'bc ', index asString value: (self object at: index) asString)].! ! !EyeCompiledMethodInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 20:06'! title ^ self object printString ! ! !EyeCompiledMethodInspector methodsFor: 'list' stamp: 'ClementBera 5/2/2013 10:51'! addSpecialFields: elements elements add: (DynamicEyeElement host: self object label: 'ast' value: [ self object ast ]). elements add: (DynamicEyeElement host: self object label: 'ir' description: [ :value | | string | string := value longPrintString. string copyFrom: 2 to: string size ] value: [ self object ir ]). elements add: (DynamicEyeElement host: self object label: 'all bytecodes' value: [ self object symbolic ]). elements add: (DynamicEyeElement host: self object label: 'header' value: [ self object headerDescription ]). self object literals withIndexDo: [ :literal :index| elements add: (DynamicEyeElement host: self object label: 'literal ', index asString value: literal) ]. ! ! !EyeCompiledMethodInspector methodsFor: 'list' stamp: 'ClementBera 5/2/2013 10:22'! addAllInstVars: elements "Useless for compiledMethod"! ! !EyeCompiledMethodInspector class methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 21:13'! label ^ 'Compiled Method Inspector'! ! !EyeDateAndTimeInspector commentStamp: ''! I am EyeDateAndTimeInspector. I am an EyeInspector. I am a specialized Inspector for DateAndTime. I show all individual elements by name, as well as a UTC representation.! !EyeDateAndTimeInspector methodsFor: 'list' stamp: 'SvenVanCaekenberghe 2/25/2014 09:05'! addSpecialFields: elements elements add: (DynamicEyeElement host: self object label: 'year' value: [ self object year ]). elements add: (DynamicEyeElement host: self object label: 'month of year' value: [ self object monthIndex ]). elements add: (DynamicEyeElement host: self object label: 'day of month' value: [ self object dayOfMonth ]). elements add: (DynamicEyeElement host: self object label: 'full hours' value: [ self object hours ]). elements add: (DynamicEyeElement host: self object label: 'full minutes' value: [ self object minutes ]). elements add: (DynamicEyeElement host: self object label: 'full seconds' value: [ self object seconds ]). elements add: (DynamicEyeElement host: self object label: 'utc' value: [ self object asUTC ])! ! !EyeDebuggerContextInspector commentStamp: ''! Specific context inspector for the bottom right of the debugger! !EyeDebuggerContextInspector methodsFor: 'list' stamp: 'abc 10/18/2013 14:09'! generateElements "generate the collection of elements to show in the inspector for the object inspected" |elements| elements := OrderedCollection new. self addSelf: elements. self addStackTop: elements. self addAllInstVars: elements. self addSpecialFields: elements. self addInstancesVariable: elements. self addVariableFields: elements. ^elements! ! !EyeDebuggerContextInspector methodsFor: 'list' stamp: 'ClementBera 5/3/2013 13:31'! addInstancesVariable: elements "Do nothing"! ! !EyeDebuggerContextInspector methodsFor: 'list' stamp: 'ClementBera 8/5/2013 10:44'! addSpecialFields: elements elements add: (DynamicEyeElement host: self object label: 'all temp vars' value: [ String streamContents: [ :s | self object tempNames withIndexDo: [ :name :index | s nextPutAll: name ; nextPut: Character space ; nextPut: $: ; nextPut: Character space ; nextPutAll: (self object namedTempAt: index) asString ; nextPut: Character lf ] ] ]).! ! !EyeDebuggerContextInspector methodsFor: 'list' stamp: 'abc 10/18/2013 14:09'! addStackTop: elements elements add: (DynamicEyeElement host: self object label: 'stackTop' value: [ self object stackPtr > 0 ifTrue: [ self object top ] ifFalse: [ #emptyStack ] ] ).! ! !EyeDebuggerContextInspector methodsFor: 'list' stamp: 'ClementBera 9/11/2013 08:44'! addSelf: elements "Add self to the list of elements you can access in the inspector with the label thisContext" elements add: (ThisContextEyeElement host: self object).! ! !EyeDebuggerContextInspector methodsFor: 'list' stamp: 'ClementBera 5/3/2013 13:32'! addAllInstVars: elements "Do nothing"! ! !EyeDictionaryInspector commentStamp: ''! Specialized version of inspector showing keys on left panel and values on description panel! !EyeDictionaryInspector methodsFor: 'accessing' stamp: 'MarcusDenker 10/7/2013 21:24'! sortedKeys ^ [ [ self object keys sort ] on: Error do: [ "case of non sortable keys" self object keys ] ] on: Error do: [ #() ]! ! !EyeDictionaryInspector methodsFor: 'list' stamp: 'ClementBera 6/25/2013 14:42'! addVariableFields: elements self sortedKeys do: [ :key | elements add: (IndexedEyeElement host: self object index: key)]! ! !EyeEditor commentStamp: ''! I am an abstract view model for editors displayed in the inspector! !EyeEditor class methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 20:16'! label ^ 'Default Editor'! ! !EyeFileSystemInspector commentStamp: ''! I am an inspector dedicated to the visualization of file systems! !EyeFileSystemInspector methodsFor: 'api' stamp: 'MarcusDenker 10/5/2013 22:01'! roots ^ self childrenForObject: self object! ! !EyeFileSystemInspector methodsFor: 'api' stamp: 'MarcusDenker 10/5/2013 21:58'! childrenForObject: aFileReference aFileReference isDirectory ifFalse: [^#()]. ^ aFileReference children collect: [ :each | DynamicEyeElement host: aFileReference value: each ]! ! !EyeFileSystemInspector class methodsFor: 'accessing' stamp: 'MarcusDenker 10/5/2013 22:00'! label ^ 'FileReference Tree Inspector'! ! !EyeFloatInspector commentStamp: ''! I am EyeFloatInspector. I am an EyeInspector. I am a specialized Inspector for Floats. I add extra elements (sign, significand, exponent) of the Float object that I am inspecting. Note that these should be interpreted as sign * significand * (2 raisedToInteger: exponent)! !EyeFloatInspector methodsFor: 'list' stamp: 'SvenVanCaekenberghe 12/21/2013 14:54'! addSpecialFields: elements elements add: (DynamicEyeElement host: self object label: 'sign' value: [ self object sign ]). elements add: (DynamicEyeElement host: self object label: 'significand' value: [ self object significand ]). elements add: (DynamicEyeElement host: self object label: 'exponent' value: [ self object exponent ])! ! !EyeInspector commentStamp: 'MarcusDenker 1/17/2014 13:44'! To do a specific inspector subclass this and override EyeInspector>>addSpecialFields Then on your object override Object>>inspectorClass so it returns your new inspector! !EyeInspector methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 14:25'! doItContext "Define a context where the DoIt method of the inspector should be done. To be overrriden in subclasses" ^ nil! ! !EyeInspector methodsFor: 'accessing' stamp: 'ClementBera 3/12/2013 14:16'! description ^ description! ! !EyeInspector methodsFor: 'event-handling' stamp: 'MarcusDenker 9/5/2013 12:51'! saveElement "When you press Cmd+s on the description TextModel, you can save the new value in the inspected object" |newValue| newValue := description doItReceiver class compiler source: description text readStream; context: nil "should be object in case of methodContext"; receiver: description doItReceiver; failBlock: [^ self]; evaluate. self selectedElement save: newValue. self objectChanged! ! !EyeInspector methodsFor: 'list' stamp: 'SvenVanCaekenberghe 3/14/2014 10:38'! limit1 "This is the max index shown before skipping to the last limit2 elements of very long arrays" ^ 1000! ! !EyeInspector methodsFor: 'accessing' stamp: 'CamilloBruni 5/2/2013 21:33'! selectedObject ^self selectedElement value! ! !EyeInspector methodsFor: 'initialization' stamp: 'CamilloBruni 10/15/2013 16:58'! shortCuts | shortCuts | shortCuts := super shortCuts. shortCuts at: $c command put: [ self copySelectedItemAccessorCode ]. ^ shortCuts! ! !EyeInspector methodsFor: 'event-handling' stamp: 'CamilloBruni 2/25/2014 18:59'! refreshDescription: item "When you select an element in the list of the inspector, print on the description textModel the element selected" | newDescription | item ifNil: [ ^ self ]. newDescription := ([ item description ] on: Error do: [ 'Error while printing ', item accessorCode ]). description text = newDescription ifTrue: [ ^ self ]. self keepScrollPositionOf: description during: [ description text: newDescription ].! ! !EyeInspector methodsFor: 'event-handling' stamp: 'BenjaminVanRyseghem 10/1/2013 13:37'! keepScrollPositionOf: specHolder during: aBlock | scrollValue | specHolder widget ifNil: [ ^ aBlock value ]. scrollValue := description scrollValue. aBlock value. description scrollValue: scrollValue.! ! !EyeInspector methodsFor: 'accessing' stamp: 'ClementBera 3/12/2013 14:16'! description: anObject description := anObject! ! !EyeInspector methodsFor: 'list' stamp: 'CamilloBruni 9/21/2013 16:04'! addClass: elements "Add class to the list of elements you can access in the inspector" elements add: (ClassEyeElement host: self object).! ! !EyeInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 15:32'! selectedIndex: integer ^ self list setSelectedIndex: integer! ! !EyeInspector methodsFor: 'event-handling' stamp: 'CamilloBruni 9/14/2013 17:09'! refreshPrintDescription self printDescription: self selectedElement! ! !EyeInspector methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/8/2013 17:54'! list ^ list ifNil: [ list := self instantiate: NewListModel. list handlesDoubleClick: true; whenSelectedItemChanged: [ :item | self refreshDescription: item ]; doubleClickAction: [ self diveIntoSelectedObject ]. ]! ! !EyeInspector methodsFor: 'private' stamp: 'CamilloBruni 9/21/2013 15:33'! takeKeyboardFocus ^ self list takeKeyboardFocus! ! !EyeInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 15:32'! selectedIndex ^ self list selectedIndex! ! !EyeInspector methodsFor: 'list' stamp: 'ClementBera 4/30/2013 11:42'! addInstancesVariable: elements "Add all the instance variables to the list of elements you can access in the inspector, set them so that you can modify and save them" self object class allInstVarNames do: [:name | elements add: (InstanceVariableEyeElement host: self object instVarName: name) ]! ! !EyeInspector methodsFor: 'initialization' stamp: 'CamilloBruni 9/21/2013 15:28'! initializeWidgets description := self instantiate: TextModel. ! ! !EyeInspector methodsFor: 'list' stamp: 'ClementBera 4/30/2013 11:21'! addSelf: elements "Add self to the list of elements you can access in the inspector" elements add: (SelfEyeElement host: self object).! ! !EyeInspector methodsFor: 'initialization' stamp: 'StephaneDucasse 3/7/2014 10:51'! step self refresh! ! !EyeInspector methodsFor: 'private' stamp: 'CamilloBruni 2/25/2014 18:48'! labelFor: anEyeElement ^ anEyeElement label! ! !EyeInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 15:32'! selectedObject: anObject "Sets the selectedElement of the inspector to anObject. If anObject is not in the list, then sets the selectedElement to 1" self list setSelectedIndex: 1. self list listItems withIndexDo: [ :item :index | item value == anObject ifTrue: [ self list setSelectedIndex: index ] ]! ! !EyeInspector methodsFor: 'list' stamp: 'ClementBera 4/30/2013 16:02'! addVariableFields: elements "add the variable fields to the inspector. Shorten the list for very long collection (cf limit1 and limit2), set them so that you can modify and save them" self variableFieldsToShow do: [ :index | elements add: (BasicIndexedEyeElement host: self object index: index) ]! ! !EyeInspector methodsFor: 'actions' stamp: 'abc 10/18/2013 14:56'! copySelectedItemAccessorCode self hasSelectedObject ifFalse: [ ^ self ]. self selectedElement copyAccessorCode.! ! !EyeInspector methodsFor: 'private' stamp: 'CamilloBruni 7/16/2013 15:01'! canDiscardEdits ^ true! ! !EyeInspector methodsFor: 'inspecting' stamp: 'MarcusDenker 9/28/2013 15:40'! explore: anObject "This is called to open a new ObjectExplorer on the object" ^self class explore: anObject! ! !EyeInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 15:38'! selectedElement ^ self list selectedItem ifNil: [ "sometimes the new list model desynchronize its selected index from its selected element, this mean that the inspector evaluates 'list setSelectedIndex: 1' but 'list selectedItem' still returns nil. This code fixes this case, that is triggered for example when you do Cmd+c in an ObjectExplorer." self list selectedIndex ifNotNil: [ :currentIndex | currentIndex = 0 ifTrue: [ ^ self ]. self list listItems ifNotEmpty: [ :aList | aList at: currentIndex ] ] ]! ! !EyeInspector methodsFor: 'list' stamp: 'SvenVanCaekenberghe 3/14/2014 10:38'! limit2 "This is the number of elements to show at the end of very long arrays" ^ 100! ! !EyeInspector methodsFor: 'event-handling' stamp: 'BenComan 4/13/2014 02:43'! updateList "update the list of elements displayed according to the new object" | elements | " self haltOnce." elements := self generateElements. self list getItems = elements ifTrue: [ ^ self ]. "first reset the items to make sure we don't interfere with the display block" self list items: #(). self list displayBlock: [ :eyeElement :index | self labelFor: (elements at: index ifAbsent: [ InstanceVariableEyeElement host: nil ]) ]. self list items: elements. "handle when last item of list is removed" (self list selectedIndex > self list getItems size) ifTrue: [ self list setSelectedIndex: self list getItems size ]. "handle when selected dictionary key is removed" self list setSelectedIndex: self list selectedIndex. self list menu: [ :aMenu | self inspectionMenu: aMenu ]! ! !EyeInspector methodsFor: 'initialization' stamp: 'CamilloBruni 10/15/2013 17:24'! initializeShortcuts "initialize the inspector' shortcuts with the dictionary defined in self shortCuts" self shortCuts keysAndValuesDo: [ :key :value | self list bindKeyCombination: key toAction: value ] ! ! !EyeInspector methodsFor: 'list' stamp: 'SvenVanCaekenberghe 3/14/2014 10:33'! generateElements "generate the collection of elements to show in the inspector for the object inspected" | elements | elements := OrderedCollection new. self addSelf: elements. self showClass ifTrue: [ self addClass: elements ]. self showAllInstVars ifTrue: [ self addAllInstVars: elements ]. self addSpecialFields: elements. self addInstancesVariable: elements. self addVariableFields: elements. ^ elements! ! !EyeInspector methodsFor: 'event-handling' stamp: 'ClementBer 10/18/2013 16:25'! objectChanged "triggered when the inspected object is changed" self updateList. self text doItReceiver: self object. self description doItReceiver: self object. self text doItContext: self doItContext. self description doItContext: self doItContext. ! ! !EyeInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 15:28'! text ^ text ifNil: [ text := self instantiate: TextModel. text aboutToStyle: true. ]! ! !EyeInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2013 17:13'! printTimeout ^ 10 seconds! ! !EyeInspector methodsFor: 'list' stamp: 'ClementBera 4/30/2013 14:23'! addSpecialFields: elements "Override in subclass to add fields to the inspector. You need to choose the appropriate sublcass of AbstractEyeElement" "ex : elements add: (AbstractEyeElement host: self object)"! ! !EyeInspector methodsFor: 'initialization' stamp: 'CamilloBruni 10/15/2013 17:25'! initializePresenter "initialize the event handlings" super initializePresenter. description whenTextIsAccepted: [ :newText | self saveElement: newText. self refreshDescription ].! ! !EyeInspector methodsFor: 'inspecting' stamp: 'CamilloBruni 9/21/2013 15:34'! inspect: anObject "This is called to update the inspector model with a new object, updates the UI" self object: anObject. self list setSelectedIndex: 1. self refresh ! ! !EyeInspector methodsFor: 'list' stamp: 'ClementBera 4/30/2013 11:35'! addAllInstVars: elements "Add AllInstVars to the list of elements you can access in the inspector" elements add: (AllInstVarsEyeElement host: self object).! ! !EyeInspector methodsFor: 'list' stamp: 'ClementBera 4/30/2013 16:13'! variableFieldsToShow "Answers the indexes of the variable fields of the object to show. Shorten the list for very long collection (cf limit1 and limit2)" |bSize| bSize := self objectVariableSize. ^ bSize <= (self limit1 + self limit2) ifTrue: [1 to: bSize] ifFalse: [(1 to: self limit1) , (bSize - self limit2 + 1 to: bSize)].! ! !EyeInspector methodsFor: 'event-handling' stamp: 'CamilloBruni 9/14/2013 17:10'! printDescription ^ description text! ! !EyeInspector methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 16:14'! objectVariableSize ^ self object basicSize! ! !EyeInspector methodsFor: 'menu' stamp: 'StephaneDucasse 4/3/2014 21:36'! inspectionMenu: aMenu self hasSelectedObject ifFalse: [ ^ aMenu ]. super inspectionMenu: aMenu.! ! !EyeInspector methodsFor: 'accessing' stamp: 'ClementBera 3/29/2013 13:48'! objectClass ^ self object class! ! !EyeInspector methodsFor: 'event-handling' stamp: 'SvenVanCaekenberghe 3/30/2014 13:11'! refresh "refresh the object in the inspector, updating his modified instance variables" description hasUnacceptedEdits ifTrue: [ ^ self ]. description getSelection size = 0 ifTrue: [ self refreshDescription; updateList ]! ! !EyeInspector methodsFor: 'event-handling' stamp: 'CamilloBruni 9/14/2013 17:17'! refreshDescription self refreshDescription: self selectedElement! ! !EyeInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 15:42'! elements ^ self list getItems! ! !EyeInspector methodsFor: 'event-handling' stamp: 'ClementBer 10/18/2013 16:26'! printDescription: item self refreshDescription: item! ! !EyeInspector methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 3/14/2014 10:32'! showClass ^ self class showClass! ! !EyeInspector methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 3/14/2014 10:32'! showAllInstVars ^ self class showAllInstVars! ! !EyeInspector methodsFor: 'event-handling' stamp: 'MarcusDenker 9/5/2013 12:48'! saveElement: newText "When you press Cmd+s on the description TextModel, you can save the new value in the inspected object" |newValue| newValue := description doItReceiver class compiler source: newText; context: self doItContext; receiver: description doItReceiver; failBlock: [^ self]; evaluate. self selectedElement save: newValue. self objectChanged.! ! !EyeInspector class methodsFor: 'inspecting' stamp: 'MarcusDenker 9/28/2013 17:01'! inspect: anObject label: aString (InspectorNavigator openInspector: (self inspector: anObject)) window title: aString. ^ anObject ! ! !EyeInspector class methodsFor: 'spec' stamp: 'BenjaminVanRyseghem 5/19/2013 16:38'! debuggerSpec ^ SpecLayout composed add: #list origin: 0@0 corner: 0.33@1; addVSplitter; add: #description origin: 0.33@0 corner: 1@1; yourself! ! !EyeInspector class methodsFor: 'inspecting' stamp: 'BenjaminVanRyseghem 5/19/2013 16:37'! basicInspect: anObject ^ self new inspect: anObject; openWithSpec: #inspectorSpec; yourself! ! !EyeInspector class methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 16:15'! label ^ 'Default Inspector'! ! !EyeInspector class methodsFor: 'inspecting' stamp: 'CamilloBruni 9/21/2013 16:31'! inspect: anObject InspectorNavigator openInspector: (self inspector: anObject). ^ anObject! ! !EyeInspector class methodsFor: 'spec' stamp: 'BenjaminVanRyseghem 5/19/2013 16:38'! debuggerSpecSlow ^ SpecLayout composed newRow: [:row | row add: #list width: 135; add: #description ]; yourself! ! !EyeInspector class methodsFor: 'tools registry' stamp: 'ClementBera 6/25/2013 14:03'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #inspector; register: self as: #basicInspector. ! ! !EyeInspector class methodsFor: 'inspecting' stamp: 'MarcusDenker 9/28/2013 15:32'! explore: anObject InspectorNavigator openExplorer: (self inspector: anObject). ^ anObject! ! !EyeInspector class methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 3/14/2014 10:31'! showClass ^ false! ! !EyeInspector class methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 3/14/2014 10:31'! showAllInstVars ^ false! ! !EyeInspector class methodsFor: 'inspecting' stamp: 'ClementBera 7/3/2013 12:52'! inspector: anObject ^ anObject class inspectorClass new inspect: anObject; yourself! ! !EyeInspector class methodsFor: 'spec' stamp: 'CamilloBruni 9/18/2013 22:13'! inspectorSpec ^ SpecLayout composed newRow: [ :r | r newColumn: #list right: 0.6; addSplitter; newColumn: #description left: 0.4 ] bottom: 0.3; addHSplitter; newRow: #text top: 0.7; yourself! ! !EyeInspectorTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testErrorRaised | inspector | self instancesToTry do: [ :each | inspector := each inspector ]! ! !EyeInspectorTest methodsFor: 'accessing' stamp: 'cb 6/25/2013 13:14'! instancesToTry ^ { Object new . Class . Metaclass . Array new . Dictionary new . WordArray new. ByteArray new. Color red . thisContext . PluggableTextMorph new . 12 . #symbol . (12.32) . TBehavior . (SmallInteger>>#+) . #(1 2 3) . #[1 2 3] . [ 1 + 2 ] . Error new . (1 << 40) }! ! !EyeInspectorToolBar commentStamp: ''! Toolbar to explore previous or next inpected elements! !EyeInspectorToolBar methodsFor: 'event-handling' stamp: 'CamilloBruni 9/20/2013 22:24'! update self preventUpdatesDuring: [ self updateInspectorChoice. self updateInspectorType. self previousButton enabled: self history hasPrevious. self nextButton enabled: self history hasNext ]! ! !EyeInspectorToolBar methodsFor: 'event-handling' stamp: 'BenjaminVanRyseghem 11/18/2013 14:42'! updateInspectorChoice self inspectorTypes ifNotNil: [ :variants | self inspectorChoice listItems = variants ifTrue: [ ^ self ]. self inspectorChoice items: variants; displayBlock: [ :label | label ]]! ! !EyeInspectorToolBar methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 22:29'! previousButton previousButton ifNil: [ previousButton := self instantiate: ButtonModel. previousButton label: '<'. previousButton action: [ self inspectorWrapper inspectPrevious. self update. ] ]. ^ previousButton! ! !EyeInspectorToolBar methodsFor: 'initialization' stamp: 'CamilloBruni 9/20/2013 22:28'! initializeWidgets " nothing to do"! ! !EyeInspectorToolBar methodsFor: 'event-handling' stamp: 'CamilloBruni 9/21/2013 16:38'! updateInspectorType self inspectorType ifNotNil: [ :inspectorClass | self inspectorChoice selectedItem = inspectorClass ifTrue: [ ^ self ]. self inspectorChoice setSelectedItem: inspectorClass ].! ! !EyeInspectorToolBar methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 19:36'! inspectorType ^ self inspectorWrapper inspectorType! ! !EyeInspectorToolBar methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2013 22:22'! history ^ self inspectorWrapper history! ! !EyeInspectorToolBar methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 22:29'! nextButton nextButton ifNil: [ nextButton := self instantiate: ButtonModel. nextButton label: '>'; action: [ self inspectorWrapper inspectNext. self update. ]]. ^ nextButton! ! !EyeInspectorToolBar methodsFor: 'initialization' stamp: 'CamilloBruni 9/20/2013 22:25'! initialize isUpdating := false. super initialize.! ! !EyeInspectorToolBar methodsFor: 'actions' stamp: 'CamilloBruni 9/21/2013 16:32'! inspectorType: anInspectorClass ^ self inspectorWrapper inspectorType: anInspectorClass! ! !EyeInspectorToolBar methodsFor: 'private' stamp: 'CamilloBruni 9/20/2013 22:29'! preventUpdatesDuring: aBlock "Used to prevent back-firing when the toolbar is update from the outside" isUpdating ifTrue: [ ^ self ]. isUpdating := true. aBlock ensure: [ isUpdating := false ]! ! !EyeInspectorToolBar methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2013 22:11'! inspectorWrapper ^ self owner! ! !EyeInspectorToolBar methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 19:32'! inspectorTypes ^ self inspectorWrapper inspectorTypes! ! !EyeInspectorToolBar methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 22:29'! inspectorChoice inspectorChoice ifNil: [ inspectorChoice := self instantiate: DropListModel. inspectorChoice whenSelectedItemChanged: [ :inspectorType | self preventUpdatesDuring: [ self inspectorType: inspectorType ]]]. ^ inspectorChoice! ! !EyeInspectorToolBar class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/8/2013 16:58'! defaultSpec ^ SpecLayout composed newRow: [ :r | r add: #previousButton width: 24; add: #nextButton width: 28; add: #inspectorChoice ]; yourself.! ! !EyeIntegerInspector commentStamp: ''! Specialized version of inspector showing hex, octal and binary representations. If within Unicode range, show a Character having using the Integer value as code point.! !EyeIntegerInspector methodsFor: 'list' stamp: 'SvenVanCaekenberghe 2/25/2014 09:17'! addSpecialFields: elements elements add: (DynamicEyeElement host: self object label: 'hex' description: [ self object printStringRadix: 16 ] value: [ self object ]). elements add: (DynamicEyeElement host: self object label: 'octal' description: [ self object printStringRadix: 8 ] value: [ self object ]). elements add: (DynamicEyeElement host: self object label: 'binary' description: [ self object printStringRadix: 2 ] value: [ self object ]). (self object between: 0 and: 16r10FFFF) ifTrue: [ elements add: (DynamicEyeElement host: self object label: 'character' description: [ :value | value printString ] value: [ self object asCharacter ]) ]! ! !EyeMethodContextInspector commentStamp: ''! I am an eye inspector specified for MethodContext! !EyeMethodContextInspector methodsFor: 'list' stamp: 'ClementBera 6/25/2013 14:46'! tempNames ^ [ self object tempNames ] on: Error do: [ #() ]! ! !EyeMethodContextInspector methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 14:25'! doItContext ^ self object! ! !EyeMethodContextInspector methodsFor: 'list' stamp: 'ClementBera 8/5/2013 10:44'! addVariableFields: elements self tempNames withIndexDo: [ :name :index | elements add: (ContextTempEyeElement host: self object tempName: name tempIndex: index) ]! ! !EyeMethodContextInspector class methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 21:13'! label ^ 'Context Inspector'! ! !EyeMethodEditor commentStamp: ''! A simple editor for complied methods.! !EyeMethodEditor methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 20:04'! method ^ self object! ! !EyeMethodEditor methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 20:09'! toolbar ^ toolbar ifNil: [ toolbar := self instantiate: MethodToolbar. ]! ! !EyeMethodEditor methodsFor: 'event-handling' stamp: 'CamilloBruni 9/21/2013 20:08'! objectChanged self text text: self method sourceCode; behavior: self method methodClass. self toolbar method: self method! ! !EyeMethodEditor methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 20:07'! title ^ self method printString ! ! !EyeMethodEditor methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 20:02'! text ^ text ifNil: [ text := self instantiate: TextModel. text aboutToStyle: true ]! ! !EyeMethodEditor class methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 20:17'! label ^ 'Method Editor'! ! !EyeMethodEditor class methodsFor: 'spec' stamp: 'CamilloBruni 9/21/2013 20:15'! inspectorSpec ^ SpecLayout composed add: #text; yourself! ! !EyeMorphViewer commentStamp: ''! A simple inspector view that displays a morph! !EyeMorphViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 17:46'! container ^ container ifNil: [ container := (PanelMorph new changeProportionalLayout) asSpecAdapter vSpaceFill; hSpaceFill]! ! !EyeMorphViewer methodsFor: 'initialize' stamp: 'StephaneDucasse 3/7/2014 10:52'! step self objectChanged! ! !EyeMorphViewer methodsFor: 'accessing' stamp: 'CamilloBruni 9/22/2013 19:53'! thumbnailSize ^ self container extent! ! !EyeMorphViewer methodsFor: 'event-handling' stamp: 'BenjaminVanRyseghem 10/17/2013 18:09'! objectChanged | newThumbnail | newThumbnail := self thumbnailMorph. newThumbnail when: #extent send: #resize: to: newThumbnail. self container morph removeAllMorphs. self container morph addMorph: newThumbnail fullFrame: LayoutFrame identity! ! !EyeMorphViewer methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 10/17/2013 17:28'! initializePresenter self whenWindowChanged: [ self objectChanged ]! ! !EyeMorphViewer methodsFor: 'event-handling' stamp: 'CamilloBruni 9/22/2013 19:51'! thumbnailMorph ^self object taskThumbnailOfSize: self thumbnailSize! ! !EyeMorphViewer class methodsFor: 'accessing' stamp: 'CamilloBruni 9/22/2013 19:40'! label ^ 'Morph Viewer'! ! !EyeMorphViewer class methodsFor: 'spec' stamp: 'BenjaminVanRyseghem 10/17/2013 17:32'! inspectorSpec ^ SpecLayout composed add: #container yourself! ! !EyeSetInspector commentStamp: ''! Specialized version of inspector showing values only! !EyeSetInspector methodsFor: 'list' stamp: 'ClementBera 4/30/2013 16:37'! addVariableFields: elements "add the variable fields to the inspector. Shorten the list for very long collection (cf limit1 and limit2), set them so that you can modify and save them" | externalIndex | externalIndex := 1. self object array withIndexDo: [ :value :index | value ifNotNil: [ elements add: (SetEyeElement host: self object index: index externalIndex: externalIndex). externalIndex := externalIndex + 1 ]]! ! !EyeStringInspector commentStamp: 'SvenVanCaekenberghe 3/14/2014 10:35'! EyeStringInspector is is the EyeInspector for Strings. Right now, the only difference is that the list of elements for the tree is overridden to be empty. ! !EyeStringInspector methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 3/14/2014 10:36'! elements ^ #()! ! !EyeTreeInspector commentStamp: ''! I am a tree inspector that takes the EyeElements from the default inspectors and displays them in a tree.! !EyeTreeInspector methodsFor: 'initialization' stamp: 'CamilloBruni 10/15/2013 17:58'! initializeShortcuts "initialize the inspector' shortcuts with the dictionary defined in self shortCuts" self shortCuts keysAndValuesDo: [ :key :value | self tree bindKeyCombination: key toAction: value ]! ! !EyeTreeInspector methodsFor: 'api' stamp: 'SvenVanCaekenberghe 3/14/2014 10:36'! childrenForObject: anObject ^ anObject inspector elements select: [ :element | element shouldShowInTree ]! ! !EyeTreeInspector methodsFor: 'api' stamp: 'CamilloBruni 9/21/2013 19:50'! childrenFor: anEyeElement ^ self childrenForObject: anEyeElement value! ! !EyeTreeInspector methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 3/15/2014 23:39'! roots ^ { RootEyeElement host: self object }! ! !EyeTreeInspector methodsFor: 'event-handling' stamp: 'MarcusDenker 10/4/2013 16:39'! objectChanged self text doItReceiver: self object. self tree roots: self roots; expandRoots.! ! !EyeTreeInspector methodsFor: 'event-handling' stamp: 'BenComan 3/17/2014 23:38'! ownerChanged super ownerChanged. self expandRoots. ! ! !EyeTreeInspector methodsFor: 'accessing' stamp: 'CamilloBruni 10/15/2013 17:20'! text ^ text ifNil: [ text := self instantiate: TextModel. text aboutToStyle: true. ]! ! !EyeTreeInspector methodsFor: 'accessing' stamp: 'CamilloBruni 9/22/2013 19:33'! selectedObject ^self selectedElement value! ! !EyeTreeInspector methodsFor: 'accessing' stamp: 'BenComan 3/16/2014 01:52'! tree ^ tree ifNil: [ tree := self instantiate: TreeModel. tree whenBuiltDo: [ self initializeShortcuts ]. tree whenSelectedItemChanged: [ :item | item ifNotNil: [ self text doItReceiver: item value ]]; childrenBlock: [ :anObject | self childrenFor: anObject ]; iconBlock: [ :treeNode | self iconFor: treeNode ]; displayBlock: [ :anObject | self labelFor: anObject ]; menu: [ :menu | self inspectionMenu: menu ]; doubleClick: [ self diveInto: self selectedObject ]; yourself]! ! !EyeTreeInspector methodsFor: 'api' stamp: 'BenComan 3/17/2014 22:19'! expandRoots self tree expandRoots! ! !EyeTreeInspector methodsFor: 'api' stamp: 'CamilloBruni 2/25/2014 18:48'! labelFor: anEyeElement "Take care of errors that might occur during label access" ^ [ anEyeElement longLabel ] on: Error do: [ :error | anEyeElement label, ': ', (self labelFor: anEyeElement error: error) ]! ! !EyeTreeInspector methodsFor: 'api' stamp: 'CamilloBruni 2/25/2014 18:24'! iconFor: anEyeElement anEyeElement withErrorsDo: [ :error | ^ self iconFor: anEyeElement error: error ]. ^ [ anEyeElement icon ] on: Error do: [ :error | self iconFor: anEyeElement error: error ]! ! !EyeTreeInspector methodsFor: 'api' stamp: 'CamilloBruni 2/25/2014 18:08'! iconFor: anEyeElement error: error ^ Smalltalk ui icons smallWarningIcon! ! !EyeTreeInspector methodsFor: 'accessing' stamp: 'PabloHerrero 11/29/2013 14:03'! selectedElement self tree hasSelectedItem ifFalse: [ ^ nil ]. ^ self tree selectedItem content! ! !EyeTreeInspector methodsFor: 'private-focus' stamp: 'CamilloBruni 10/15/2013 18:24'! takeKeyboardFocus ^ self tree takeKeyboardFocus! ! !EyeTreeInspector class methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 16:15'! label ^ 'Tree Inspector'! ! !EyeTreeInspector class methodsFor: 'spec' stamp: 'CamilloBruni 9/21/2013 14:38'! inspectorSpec ^ SpecLayout composed newRow: #tree bottom: 0.3; addHSplitter; newRow: #text top: 0.7; yourself! ! !EyeViewHierarchyInspector commentStamp: ''! A special tree inspector that displays the submorph hierarchy of the inspected morph.! !EyeViewHierarchyInspector methodsFor: 'api' stamp: 'CamilloBruni 9/21/2013 19:51'! roots ^ self childrenForObject: self object! ! !EyeViewHierarchyInspector methodsFor: 'api' stamp: 'CamilloBruni 9/21/2013 19:51'! childrenForObject: aMorph ^ aMorph submorphs collect: [ :each | DynamicEyeElement host: aMorph value: each ]! ! !EyeViewHierarchyInspector class methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2013 16:15'! label ^ 'Morph View Hierarchy Inspector'! ! !FIFOQueueTests commentStamp: 'TorstenBergmann 2/20/2014 15:29'! SUnit tests for FIFO queues! !FIFOQueueTests methodsFor: 'tests' stamp: 'IgorStasenko 2/28/2011 14:36'! testFlush | q v sema | q := self newQueue. sema := Semaphore new. [ #( 1 2 3 4 5 6 7 8 9 10 ) do: [:each | q nextPut: each ]. sema signal ] fork. v := 0. sema wait. q flush: [:each | self assert: v < each. v := each ]. self assert: v = 10 ! ! !FIFOQueueTests methodsFor: 'tests' stamp: 'IgorStasenko 4/15/2011 11:41'! testBasics | q | q := self newQueue. q nextPut: 5. self assert: q peek = 5. self assert: q nextOrNil = 5. q nextPut: 10. q nextPut: 15. self assert: q nextOrNil = 10. self assert: q peek = 15. self assert: q nextOrNil = 15. self assert: q nextOrNil == nil! ! !FIFOQueueTests methodsFor: 'tests' stamp: 'Igor.Stasenko 10/16/2010 01:20'! runValidationTest | q sema prio pusher feeder feeders r crit done | r := Random new. q := AtomicSharedQueue new. feeders := OrderedCollection new. count := 0. sema := Semaphore new. crit := Semaphore forMutualExclusion. done := Semaphore new. prio := Processor activePriority. pusher := [ sema wait. 1 to: 100 do: [:i | q nextPut: i ]. ]. feeder := [ sema wait. [ q next. crit critical: [count := count + 1 ]. count < 1000 ] whileTrue. done signal ]. 10 timesRepeat: [ | proc | proc := pusher newProcess priority: prio + (r next * 10) asInteger - 5. proc resume. proc := feeder newProcess priority: prio + (r next * 10) asInteger - 10. feeders add: proc. proc resume. ]. " let them run " 20 timesRepeat: [ sema signal ]. Processor yield. done waitTimeoutSeconds: 10. feeders do: [:ea | ea terminate ]. self assert: (count = 1000 ) ! ! !FIFOQueueTests methodsFor: 'tests' stamp: 'IgorStasenko 2/28/2011 15:17'! testContention1 "here is a test case that breaks the standard SharedQueue from Squeak 3.8" | q r1 r2 | q := AtomicSharedQueue new. q nextPut: 5. q nextPut: 10. self should: [ q nextOrNil = 5 ]. [ r1 := q next ] fork. [ r2 := q next ] fork. Processor yield. "let the above two threads block" q nextPut: 10. Processor yield. self should: [ r1 = 10 ]. self should: [ r2 = 10 ]. self should: [ q nextOrNil = nil ]. ! ! !FIFOQueueTests methodsFor: 'instance creation' stamp: 'IgorStasenko 11/2/2010 01:39'! newQueue ^ WaitfreeQueue new! ! !FIFOQueueTests methodsFor: 'tests' stamp: 'Igor.Stasenko 10/16/2010 02:08'! testFlushAllSuchThat | q | q := self newQueue. #( 1 2 3 4 5 6 7 8 9 10 ) do: [:each | q nextPut: each ]. q flushAllSuchThat: [:each | each odd ]. q flush: [:each | self assert: each even ]. self assert: q nextOrNil == nil! ! !FIFOQueueTests methodsFor: 'tests' stamp: 'Igor.Stasenko 10/15/2010 19:53'! runValidationTest2 | q sema prio pusher r cnt | r := Random new. q := AtomicSharedQueue new. cnt := 0. sema := Semaphore new. prio := Processor activePriority. pusher := [ sema wait. 1 to: 100 do: [:i | q nextPut: i ]. Processor yield ]. 10 timesRepeat: [ | proc | proc := pusher newProcess priority: prio + (r next * 10) asInteger - 5. proc resume. ]. " let them run " 10 timesRepeat: [ sema signal ]. Processor yield. [ q next. cnt := cnt + 1. cnt < 1000 ] whileTrue. " started := Time now asSeconds. [ [ count < (1000) ] whileTrue: [ Time now asSeconds - started > 20 ifTrue: [ self error: 'deadlock' ]. Processor yield ]. ] ensure: [ feeders do: [:ea | ea terminate ] ] "! ! !FIFOQueueTests methodsFor: 'tests' stamp: 'Igor.Stasenko 10/15/2010 18:34'! testSuchThat | q | q := self newQueue. #( 1 2 3 4 5 6 7 8 9 10 ) do: [:each | q nextPut: each ]. self assert: (q nextOrNilSuchThat: [:e | e = 100 ]) isNil. self assert: (q nextOrNilSuchThat: [:e | e = 5 ]) = 5. 9 timesRepeat: [ self assert: (q nextOrNil notNil) ]. self assert: q nextOrNil isNil! ! !FIFOQueueTests methodsFor: 'tests' stamp: 'IgorStasenko 2/28/2011 15:10'! testSize | q | q := self newQueue. #( 1 2 3 4 5 6 7 8 9 10 ) do: [:each | q nextPut: each ]. self assert: (q size = 10)! ! !FIFOQueueTests methodsFor: 'tests' stamp: 'IgorStasenko 2/28/2011 14:42'! testHeavyContention "run 10 threads, pushing new values to queue, and 10 threads pullung values from queue, at random priorities" | q sema prio pusher feeder feeders r crit done | r := Random new. q := AtomicSharedQueue new. feeders := OrderedCollection new. count := 0. sema := Semaphore new. crit := Semaphore forMutualExclusion. done := Semaphore new. prio := Processor activePriority. pusher := [ sema wait. 1 to: 100 do: [:i | q nextPut: i ]. ]. feeder := [ sema wait. [ q next. crit critical: [count := count + 1 ]. count < 1000 ] whileTrue. done signal ]. 10 timesRepeat: [ | proc | proc := pusher newProcess priority: prio + (r next * 10) asInteger. proc resume. proc := feeder newProcess priority: prio + (r next * 10) asInteger. feeders add: proc. proc resume. ]. " let them run " 20 timesRepeat: [ sema signal ]. Processor yield. done waitTimeoutSeconds: 10. feeders do: [:ea | ea terminate ]. self assert: (count = 1000 ). self assert: q nextOrNil == nil! ! !FIFOQueueTests methodsFor: 'tests' stamp: 'Igor.Stasenko 10/15/2010 18:56'! testNextOrNilSuchThat | q item | q := self newQueue. q nextPut: 5. q nextPut: 6. item := q nextOrNilSuchThat: [ :x | x even ]. self should: [ item = 6 ]. self should: [ q nextOrNil = 5 ]. self should: [ q nextOrNil = nil ]. ! ! !FIFOQueueTests methodsFor: 'tests' stamp: 'Igor.Stasenko 10/16/2010 01:52'! testHeavyContention2 "run 10 threads, pushing new values to queue, and 10 threads pullung values from queue, at random priorities" | q sema prio pusher feeder feeders r crit done | r := Random new. q := AtomicSharedQueue new. feeders := OrderedCollection new. count := 0. sema := Semaphore new. crit := Semaphore forMutualExclusion. done := Semaphore new. prio := Processor activePriority. pusher := [ sema wait. 1 to: 100 do: [:i | q nextPut: i ]. ]. feeder := [ sema wait. [ q waitForNewItems. q next. crit critical: [count := count + 1 ]. count < 1000 ] whileTrue. done signal ]. 10 timesRepeat: [ | proc | proc := pusher newProcess priority: prio + (r next * 10) asInteger - 5. proc resume. proc := feeder newProcess priority: prio + (r next * 10) asInteger - 5. feeders add: proc. proc resume. ]. " let them run " 20 timesRepeat: [ sema signal ]. Processor yield. done waitTimeoutSeconds: 10. feeders do: [:ea | ea terminate ]. self assert: (count = 1000 ). self assert: q nextOrNil == nil ! ! !FLAbstractCollectionCluster commentStamp: ''! A FLAbstractCollectionCluster is the common behavior for all cluster collections. ! !FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/25/2013 14:44'! materializeReferencesOf: anObject with: aDecoder "Hook method" self subclassResponsibility! ! !FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/25/2013 14:44'! serializeReferencesOf: anObject with: anEncoder ^ self subclassResponsibility ! ! !FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 7/26/2012 14:33'! afterMaterializationStepWith: aDecoder objects do: [ :anObject | anObject fuelAfterMaterialization ]! ! !FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 7/26/2012 14:22'! serializeReferencesStepWith: anEncoder objects do: [ :anObject | self serializeReferencesOf: anObject with: anEncoder ]! ! !FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 7/26/2012 14:24'! materializeReferencesStepWith: aDecoder objects do: [ :anObject | self materializeReferencesOf: anObject with: aDecoder ]! ! !FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 7/26/2012 16:07'! serializeInstance: anObject with: anEncoder anEncoder encodePositiveInteger: anObject size! ! !FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 7/26/2012 14:06'! materializeInstanceWith: aDecoder ^theClass new: aDecoder nextEncodedPositiveInteger! ! !FLAbstractCollectionCluster class methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 7/26/2012 17:38'! clusterBucketIn: aClusterization "During the materialization references step, we may send, for example, #hash to the newly materialized objects. #hash can be implemented delegating to OTHER objects which may not have been materialized yet (I mean, its references may not have been set yet). So in this case, we need to let these clusters at the end." ^aClusterization postBaselevelBucket! ! !FLAnalysis commentStamp: 'MartinDias 8/29/2011 19:15'! I am responsible of traversing the graph of references starting from a root object. I will produce a clusterization which the serializer will store on a stream. An example of use is: (FLAnalyzer newDefault clusterizationOf: (Array with: 1@2 with: 3@4)) clusters. ! !FLAnalysis methodsFor: 'tracing' stamp: 'MarianoMartinezPeck 9/18/2012 10:58'! privateTrace: anObject privateObjectStack push: anObject! ! !FLAnalysis methodsFor: 'initialize-release' stamp: 'MarianoMartinezPeck 9/18/2012 10:58'! initializeWith: aMapper private: privateMapper root: anObject self initialize. firstMapper := aMapper. privateFirstMapper := privateMapper. aMapper analysis: self. privateMapper analysis: self. root := anObject. objectStack := FLSimpleStack new. privateObjectStack := FLSimpleStack new. clusterization := FLClusterization new. ! ! !FLAnalysis methodsFor: 'mapping' stamp: 'MaxLeske 5/3/2013 15:35'! mapAndTrace: anObject "Map an object to its cluster. Trace its references." firstMapper mapAndTrace: anObject fuelReplacement! ! !FLAnalysis methodsFor: 'mapping' stamp: 'MarianoMartinezPeck 9/18/2012 10:58'! privateMapAndTrace: anObject "Map an object to its cluster. Trace its references." privateFirstMapper mapAndTrace: anObject! ! !FLAnalysis methodsFor: 'accessing' stamp: 'MartinDias 9/9/2011 21:47'! clusterization ^clusterization! ! !FLAnalysis methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLAnalysis methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 9/18/2012 10:58'! run objectStack push: root. [ objectStack isEmpty ] whileFalse: [ self mapAndTrace: objectStack pop ]. [ privateObjectStack isEmpty ] whileFalse: [ self privateMapAndTrace: privateObjectStack pop ].! ! !FLAnalysis methodsFor: 'tracing' stamp: 'MartinDias 8/20/2011 22:11'! trace: anObject objectStack push: anObject! ! !FLAnalysis class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 9/18/2012 10:59'! newWith: aMapper private: privateMapper root: anObject ^self basicNew initializeWith: aMapper private: privateMapper root: anObject; yourself.! ! !FLAnalyzer commentStamp: 'MartinDias 8/29/2011 19:15'! I am responsible of traversing the graph of references starting from a root object. I will produce a clusterization which the serializer will store on a stream. An example of use is: (FLAnalyzer newDefault clusterizationOf: (Array with: 1@2 with: 3@4)) clusters. ! !FLAnalyzer methodsFor: 'configuring' stamp: 'MartinDias 9/10/2011 17:04'! when: aCondition substituteBy: aFactory pluggableSubstitutions add: aCondition -> aFactory! ! !FLAnalyzer methodsFor: 'analyzing' stamp: 'MartinDias 2/21/2013 17:30'! lightGlobalMappers ^ globalSymbols isEmpty ifTrue: [ #() ] ifFalse: [ Array with: (FLLightGlobalMapper for: globalSymbols in: self globalEnvironment) ]! ! !FLAnalyzer methodsFor: 'defaults' stamp: 'MarianoMartinezPeck 12/14/2011 20:43'! generalMapper ^generalMapperFactory value! ! !FLAnalyzer methodsFor: 'protected' stamp: 'MartinDias 9/10/2011 17:55'! pluggableSubstitutionMappers ^pluggableSubstitutions collect: [:aLink | FLPluggableSubstitutionMapper when: aLink key substituteBy: aLink value]! ! !FLAnalyzer methodsFor: 'protected' stamp: 'MartinDias 1/10/2012 14:25'! firstInMapperChain ^ self mappers first ! ! !FLAnalyzer methodsFor: 'accessing' stamp: 'MartinDias 9/11/2011 11:22'! globalMappers ^globalMappersFactory value! ! !FLAnalyzer methodsFor: 'analyzing' stamp: 'MartinDias 9/14/2011 00:15'! analysisFor: anObject ^analysisFactory value: anObject! ! !FLAnalyzer methodsFor: 'configuring' stamp: 'MartinDias 12/30/2011 19:25'! considerGlobal: aSymbol globalSymbols add: aSymbol! ! !FLAnalyzer methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLAnalyzer methodsFor: 'accessing' stamp: 'MartinDias 2/21/2013 23:35'! globalEnvironment "Answer a dictionary where the look up for global symbols will be done during serialization." ^ globalEnvironment! ! !FLAnalyzer methodsFor: 'protected' stamp: 'MarianoMartinezPeck 9/18/2012 11:00'! setDefaultAnalysis analysisFactory := [:anObject | (FLAnalysis newWith: self firstInMapperChain private: self privateFirstInMapperChain root: anObject) run; yourself ]! ! !FLAnalyzer methodsFor: 'accessing' stamp: 'MartinDias 2/25/2013 11:26'! globalEnvironment: aDictionary globalEnvironment := aDictionary ! ! !FLAnalyzer methodsFor: 'protected' stamp: 'MarianoMartinezPeck 9/18/2012 11:00'! privateMappers ^ OrderedCollection new addAll: self globalMappers; add: self generalMapper; reduceRight: [:left :right | left next: right ]; yourself! ! !FLAnalyzer methodsFor: 'initialization' stamp: 'MartinDias 2/21/2013 23:35'! initialize super initialize. self setDefaultAnalysis. self useLightMappers. pluggableSubstitutions := OrderedCollection new. internalClasses := IdentitySet new. internalMethods := IdentitySet new. globalEnvironment := self class environment. globalSymbols := self class defaultGlobalSymbols asIdentitySet. ! ! !FLAnalyzer methodsFor: 'accessing' stamp: 'MartinDias 5/21/2012 12:30'! useLightMappers globalMappersFactory := [self lightGlobalMappers]. generalMapperFactory := [FLLightGeneralMapper new].! ! !FLAnalyzer methodsFor: 'protected' stamp: 'MarianoMartinezPeck 9/18/2012 11:00'! privateFirstInMapperChain ^ self privateMappers first ! ! !FLAnalyzer methodsFor: 'configuring' stamp: 'MartinDias 1/10/2012 14:41'! globalSymbols "Answer the collection of symbols whose associations and values in Smalltalk globals will be considered as globals by Fuel." ^ globalSymbols! ! !FLAnalyzer methodsFor: 'protected' stamp: 'MartinDias 1/10/2012 14:21'! mappers ^ OrderedCollection new addAll: self pluggableSubstitutionMappers; addAll: self globalMappers; add: self generalMapper; reduceRight: [:left :right | left next: right ]; yourself! ! !FLAnalyzer class methodsFor: 'accessing' stamp: 'MarcusDenker 10/15/2013 12:53'! defaultGlobalSymbols ^ #(#Smalltalk #SourceFiles #Transcript #Undeclared #Display #TextConstants #ActiveWorld #ActiveHand #ActiveEvent #Sensor #Processor #SystemOrganization #World) select: [:each | self environment includesKey: each ]! ! !FLAnalyzer class methodsFor: 'instance creation' stamp: 'MartinDias 9/9/2011 21:25'! newDefault "Returns an instance with default configuration." ^self new! ! !FLBadSignature commentStamp: 'MarianoMartinezPeck 10/23/2011 14:32'! I represent an error produced during materialization when the serialized signature doesn't match the materializer's signature (accessible via FLMaterializer>>signature). A signature is a byte prefix that should prefix a well-serialized stream.! !FLBadSignature class methodsFor: 'signaling' stamp: 'MartinDias 3/20/2012 12:03'! signalCurrentSignature: currentSignature streamSignature: streamSignature ^ self signal: 'Unexpected stream signature ', streamSignature asString, ' where it should be ', currentSignature asString, '.'! ! !FLBadVersion commentStamp: 'MarianoMartinezPeck 10/23/2011 14:33'! I represent an error produced during materialization when the serialized version doesn't match the materializer's version (accessible via FLMaterializer>>version). A version is encoded in 16 bits and is enconded heading the serialized stream, after the signature.! !FLBadVersion class methodsFor: 'signaling' stamp: 'MartinDias 3/20/2012 12:04'! signalCurrentVersion: currentVersion streamVersion: streamVersion ^ self signal: 'Unexpected stream version ', streamVersion asString, ' where it should be ', currentVersion asString, '.' ! ! !FLBasicSerializationTest commentStamp: 'TorstenBergmann 2/3/2014 23:24'! SUnit tests for basic fuel serialization! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/17/2012 20:36'! testWideAndByteCharacters "Since wide and byte characters are represented in the same class, this case is prone to fail." | materialized aByteCharacter aWideCharacter| aWideCharacter := Character value: 12345. aByteCharacter := $a. materialized := self resultOfSerializeAndMaterialize: (Array with: aWideCharacter with: aByteCharacter ). self assert: materialized first = aWideCharacter. self assert: materialized second == aByteCharacter.! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 1/9/2012 21:00'! testCharacter "Test character serialization. If the code is less than 255 the same instance is used. But if it is bigger, new ones are created. For more info read Character class comment and Character class >> value:" self assertSerializationIdentityOf: $a. self assertSerializationEqualityOf: (Character value: 12345). "Japanese Hiragana 'A' " self assertSerializationEqualityOf: Character allCharacters. self assertSerializationEqualityOf: (Array with: $a with: (Character value: 12345)).! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'MartinDias 12/15/2011 15:41'! testCompiledMethod "They should be considered as globals by default." self assertSerializationIdentityOf: FLPair >> #left ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 9/2/2011 14:25'! testPoint self assertSerializationEqualityOf: 10@20. self assertSerializationEqualityOf: -10@20. self assertSerializationEqualityOf: -10@ -20. self assertSerializationEqualityOf: 1.1@2.2. self assertSerializationEqualityOf: 1.1@ -2.2. ! ! !FLBasicSerializationTest methodsFor: 'failures' stamp: 'MaxLeske 2/26/2013 22:24'! expectedFailures | failures | failures := #(testConsiderCustomWideSymbolGlobal). ((SystemVersion current major = 1) and: [SystemVersion current minor < 3]) ifTrue: [ failures := failures, #(testSetElement testSetWithNil testSetWithSetElement) ]. ^ failures! ! !FLBasicSerializationTest methodsFor: 'tests-collections-Pharo1.3' stamp: 'MartinDias 8/13/2011 21:00'! testSetWithSetElement self assertSerializationEqualityOf: (Set with: (SetElement with: 3))! ! !FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: 'MartinDias 10/17/2010 20:57'! testSmallIntegerMaxValue self assertSerializationIdentityOf: SmallInteger maxVal . ! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 10/5/2011 18:18'! testSet | set materialized | set := Set new. set add: 10. set add: 20. set add: 30. set add: 30. materialized := self resultOfSerializeAndMaterialize: set. self assert: set = materialized. self assert: materialized size = 3. self assert: (materialized includes: 10). self assert: (materialized includes: 20). self assert: (materialized includes: 30). ! ! !FLBasicSerializationTest methodsFor: 'tests-cycles' stamp: 'MartinDias 11/11/2010 19:31'! testCyclicLinks | a b c materializedA | a := Link new. b := Link new. c := Link new. a nextLink: b. b nextLink: c. c nextLink: a. materializedA := self resultOfSerializeAndMaterialize: a. "We can't check using the equality of the links because hangs ad infinitum. So we only check that the structure is right." self assert: materializedA nextLink nextLink nextLink == materializedA. self deny: materializedA nextLink == materializedA. self deny: materializedA nextLink nextLink == materializedA.! ! !FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: 'MarianoMartinezPeck 10/11/2011 12:07'! testFloat self assertSerializationEqualityOf: 180.0. self assertSerializationEqualityOf: 0.0. self assertSerializationEqualityOf: -0.0. self assertSerializationEqualityOf: 11.22321. self assertSerializationEqualityOf: -11.22321. self assertSerializationEqualityOf: -132311.22321. self assertSerializationEqualityOf: 1234567890.123456789. self assertSerializationEqualityOf: -1234567890.123456789. self assertSerializationEqualityOf: Float e. self assertSerializationEqualityOf: Float infinity. self assertSerializationEqualityOf: Float halfPi. self assertSerializationEqualityOf: Float negativeZero. self assertSerializationEqualityOf: Float halfPi. self assertSerializationEqualityOf: Float pi. ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 10/17/2010 20:56'! testNil self assertSerializationIdentityOf: nil! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 10/26/2010 19:46'! testEmptyArray self assertSerializationEqualityOf: #()! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MarianoMartinezPeck 10/11/2011 12:00'! testByteArrays self assertSerializationEqualityOf: { #[1 2 3 4 5 6]. #[1 2 3 4 5 6]. #[7 8 9 10 11 12]. #[7 8 9 10 11 12] }. self assertSerializationEqualityOf: (ByteArray with: 10 with: 20 with: 30). self assertSerializationEqualityOf: ByteArray new. self assertSerializationEqualityOf: (ByteArray new: 100). self assertSerializationEqualityOf: (0 to: 255) asByteArray.! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 9/2/2011 10:42'! testDate self assertSerializationEqualityOf: (Date fromDays: 37023). self assertSerializationEqualityOf: (Date today). self assertSerializationEqualityOf: (Date year: 3050 month: 12 day: 31). self assertSerializationEqualityOf: (Date year: 1600 month: 12 day: 31). ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 10/17/2010 20:59'! testTrue self assertSerializationIdentityOf: true! ! !FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: 'MarianoMartinezPeck 10/11/2011 12:12'! testLargePositiveInteger self assertSerializationEqualityOf: 354314316134313999999999. self assertSerializationEqualityOf: 100 factorial. ! ! !FLBasicSerializationTest methodsFor: 'tests-strings' stamp: 'dsfsfs 6/26/2012 09:57'! testWideString self assertSerializationEqualityOf: 'aString' asWideString. self assertSerializationEqualityOf: (WideString streamContents: [ :stream | 2000 timesRepeat: [ stream nextPut: (256 to: 1000) atRandom asCharacter ] ] ). ! ! !FLBasicSerializationTest methodsFor: 'tests-streams' stamp: 'MartinDias 10/5/2011 18:18'! testWriteStream | aWriteStream materialized | aWriteStream := WriteStream on: (ByteArray new: 1). materialized := self resultOfSerializeAndMaterialize: aWriteStream. aWriteStream nextPut: 1. self assert: 1 = aWriteStream size. self assert: 0 = materialized size. materialized nextPut: 2. self assert: (Array with: 2) = materialized contents asArray. ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 6/3/2011 21:20'! testLotsOfCharacters | all | all := OrderedCollection new. (1 << 16) timesRepeat: [ all add: (1 to: 255 ) atRandom asCharacter ]. self assertSerializationEqualityOf: all.! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'MartinDias 12/30/2011 18:44'! testGlobalClass "A class should be global by default." self assertSerializationIdentityOf: Integer. ! ! !FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: 'MartinDias 9/29/2010 11:27'! testSmallIntegerNegative self assertSerializationIdentityOf: -42.! ! !FLBasicSerializationTest methodsFor: 'tests-collections-Pharo1.3' stamp: 'MartinDias 8/13/2011 20:58'! testSetWithNil self assertSerializationEqualityOf: (Set with: nil)! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'CamilloBruni 4/29/2013 19:11'! testConsiderCustomGlobal "A custom global variable is treated as global by Fuel, when we explicitly specify this." | aPerson globalKey | globalKey := #FLGlobalVariableForTesting. self analyzer considerGlobal: globalKey. aPerson := FLPerson new. [ Smalltalk globals at: globalKey put: aPerson. self assertSerializationIdentityOf: aPerson. ] ensure: [ Smalltalk globals removeKey: globalKey ] ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MaxLeske 10/18/2012 08:07'! testDateOffsets | bst sast materialized object | bst := TimeZone timeZones third. sast := TimeZone timeZones fourth. DateAndTime localTimeZone: bst. self assert: DateAndTime now offset equals: 1 hour. object := Date fromDays: 37023. self assert: object start offset equals: 0 hours. materialized := self resultOfSerializeAndMaterialize: object. self assert: materialized start offset equals: 0 hours. DateAndTime localTimeZone: sast. self assert: DateAndTime now offset equals: 2 hours. object := Date fromDays: 37023. self assert: object start offset equals: 0 hours. materialized := self resultOfSerializeAndMaterialize: object. self assert: materialized start offset equals: 0 hours ! ! !FLBasicSerializationTest methodsFor: 'tests-strings' stamp: 'MartinDias 10/5/2011 18:17'! testRemoteString "Tests that the materialized RemoteString has *the same* location on file." | aRemoteString materializedRemoteString | aRemoteString := RemoteString new setSourcePointer: thisContext method sourcePointer. materializedRemoteString := self resultOfSerializeAndMaterialize: aRemoteString. self assert: aRemoteString string = materializedRemoteString string. self assert: aRemoteString sourcePointer == materializedRemoteString sourcePointer.! ! !FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: 'MarianoMartinezPeck 10/11/2011 12:12'! testLargeNegativeInteger self assertSerializationEqualityOf: -354314316134313999999999. self assertSerializationEqualityOf: 0-100 factorial.! ! !FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: 'MarianoMartinezPeck 10/11/2011 12:16'! testSmallInteger self assertSerializationIdentityOf: -1212. self assertSerializationIdentityOf: 7. self assertSerializationIdentityOf: 0. self assertSerializationIdentityOf: 1111. self assertSerializationIdentityOf: SmallInteger one. ! ! !FLBasicSerializationTest methodsFor: 'tests-cycles' stamp: 'MartinDias 3/21/2011 16:08'! testCyclicLink | a materializedA | a := Link new. a nextLink: a. materializedA := self resultOfSerializeAndMaterialize: a. "We can't check using the equality of the links because hangs ad infinitum. So we only check that the structure is right." self assert: materializedA nextLink == materializedA! ! !FLBasicSerializationTest methodsFor: 'tests-strings' stamp: 'MarianoMartinezPeck 10/11/2011 12:20'! testSymbol self assertSerializationIdentityOf: #testSymbol. self assertSerializationIdentityOf: #with:with:with:with:. self assertSerializationIdentityOf: #'hello there'.! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 10/5/2011 18:18'! testSharedReferences | oneDotOne point1 point2 materialized array | oneDotOne := 1.1. "I cannot directly use 4.2 because the Compiler reuses the same float instance 4.2 for the literals and hence the last assert fails. " point1:= Point x: oneDotOne y: (Float readFrom: '4.2' readStream). point2:= Point x: (Float readFrom: '4.2' readStream) y: oneDotOne. array := (Array with: point1 with: point2). materialized := self resultOfSerializeAndMaterialize: array. self assert: array = materialized. self assert: materialized first x == materialized second y. self deny: materialized first y == materialized second x. ! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'MartinDias 1/10/2012 14:30'! testSmalltalkGlobals "Smalltalk globals should be global by default." self assertSerializationIdentityOf: Smalltalk globals! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 10/26/2010 19:46'! testEmptyOrderedCollection self assertSerializationEqualityOf: OrderedCollection new! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 10/11/2011 12:12'! testFraction self assertSerializationEqualityOf: (3 / 4). self assertSerializationEqualityOf: (4 / 3). self assertSerializationEqualityOf: (-4 / 3). self assertSerializationEqualityOf: (-4 / -3). self assertSerializationEqualityOf: (4 / -3). self assertSerializationIdentityOf: (0-0 / -3). self assertSerializationEqualityOf: 0-(1001/1000). ! ! !FLBasicSerializationTest methodsFor: 'tests-graph-modification' stamp: 'MaxLeske 5/3/2013 17:38'! testFuelReplacement | object | self assert: (self resultOfSerializeAndMaterialize: FLReplacementClassMock) equals: nil. self assert: (self resultOfSerializeAndMaterialize: {FLReplacementClassMock}) equals: { nil }. object := FLReplacementMock new ignoreMe; yourself. self assert: (self resultOfSerializeAndMaterialize: {object}) equals: { nil }. object dontIgnoreMe. self assert: (self resultOfSerializeAndMaterialize: {object}) equals: { object }! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 6/5/2011 01:52'! testEmptySet self assertSerializationEqualityOf: Set new! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 8/8/2011 15:47'! testTimestamp self assertSerializationEqualityOf: (TimeStamp date: (Date fromSeconds: 3330720000) time: (Time fromSeconds: 13506) ). self assertSerializationEqualityOf: (Date today asTimeStamp). ! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 9/19/2011 11:27'! testArray self assertSerializationEqualityOf: #(1). self assertSerializationEqualityOf: #(10 20). self assertSerializationEqualityOf: #(1 2 3 #('Hello' 2 3)). ! ! !FLBasicSerializationTest methodsFor: 'tests-fuelAfterMaterialization' stamp: 'MarianoMartinezPeck 4/19/2012 19:10'! testExecuteAfterMaterialization | anObject result aClass | aClass := self newClass addInstVarNamed: 'a'; duringTestCompileSilently: 'fuelAfterMaterialization a := #A'; yourself. anObject := aClass new. result := self resultOfSerializeAndMaterialize: anObject. self assert: #A = (result instVarNamed: 'a'). ! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MarianoMartinezPeck 6/20/2011 17:21'! testRunArray self assertSerializationEqualityOf: (RunArray runs: #(1 2 1) values: #(1 2 3)) ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MaxLeske 10/18/2012 08:08'! testDateOffsetsChanging | bst sast object | bst := TimeZone timeZones third. sast := TimeZone timeZones fourth. DateAndTime localTimeZone: bst. self assert: DateAndTime now offset equals: 1 hour. object := Date fromDays: 37023. self assert: object start offset equals: 0 hours. self serialize:object. DateAndTime localTimeZone: sast. self assert: DateAndTime now offset equals: 2 hours. object := Date fromDays: 37023. self assert: object start offset equals: 0 hours. self assert: self materialized start offset equals: 0 hours ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 11/25/2010 18:40'! testPair self assertSerializationEqualityOf: (FLPair new left: 10; right: 20; yourself)! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 10/17/2010 20:59'! testFalse self assertSerializationIdentityOf: false! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 3/21/2011 16:10'! testWordArray self assertSerializationEqualityOf: (WordArray with: 10 with: 20)! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 9/20/2011 20:39'! testTime self assertSerializationEqualityOf: (Time fromSeconds: 84072). self assertSerializationEqualityOf: (Time hour: 24 minute: 60 second: 60). self assertSerializationEqualityOf: (Time hour: 23 minute: 59 second: 59). self assertSerializationEqualityOf: (Time hour: 0 minute: 0 second: 0). self assertSerializationEqualityOf: (Time seconds: 0 nanoSeconds: 5). self assertSerializationEqualityOf: (Time allInstances sort: [:a :b | a asSeconds > b asSeconds]) first. self assertSerializationEqualityOf: (Time allInstances sort: [:a :b | a nanoSecond > b nanoSecond]) first ! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'MartinDias 12/15/2011 15:42'! testClassSideCompiledMethod "They should be considered as globals by default." self assertSerializationIdentityOf: FLGlobalSendMock class >> #newInstanceToSerialize ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 10/11/2011 12:06'! testExceptions | ex | ex := (Error new messageText: 'sample error'). self assert: (self resultOfSerializeAndMaterialize: ex) messageText equals: ex messageText. ex := (Warning new messageText: 'sample warning'). self assert: (self resultOfSerializeAndMaterialize: ex) messageText equals: ex messageText. ex := (Notification new messageText: 'sample notification'). self assert: (self resultOfSerializeAndMaterialize: ex) messageText equals: ex messageText. ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 6/20/2011 17:09'! testColor self assertSerializationEqualityOf: Color blue. self assertSerializationEqualityOf: Color black. ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 9/2/2011 14:25'! testRectangle self assertSerializationEqualityOf: (10@20 corner: 30@40). self assertSerializationEqualityOf: (1.1@2.2 corner: 3.3@4.4). self assertSerializationEqualityOf: (1.1@ -2.2 corner: -3.3@4.4).! ! !FLBasicSerializationTest methodsFor: 'tests-collections-Pharo1.3' stamp: 'MartinDias 9/9/2011 12:49'! testSetElement self assertSerializationEqualityOf: (SetElement with: 3)! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'CamilloBruni 4/29/2013 19:10'! testConsiderCustomWideSymbolGlobal "The same than #testConsiderCustomGlobal but with a WideSymbol." | aWideSymbol aPerson | aWideSymbol := (WideString streamContents: [ :stream | 256 to: 260 do: [ :code | stream nextPut: code asCharacter ] ]) asSymbol. self analyzer considerGlobal: aWideSymbol. aPerson := FLPerson new. [ Smalltalk globals at: aWideSymbol put: aPerson. self assertSerializationIdentityOf: aPerson ] ensure: [ Smalltalk globals removeKey: aWideSymbol ]. ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 9/9/2011 01:40'! testDuration self assertSerializationEqualityOf: 123 seconds. self assertSerializationEqualityOf: -123 seconds. self assertSerializationEqualityOf: ( Duration seconds: 3 nanoSeconds: 35). ! ! !FLBasicSerializationTest methodsFor: 'tests-not-so-basic' stamp: 'MartinDias 5/19/2012 18:48'! testNotSerializableObject self should: [ self serialize: FLNotSerializableMock new ] raise: FLNotSerializable whoseDescriptionIncludes: FLNotSerializableMock new printString description: 'User can prevent some objects from serialization.'! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 4/19/2011 13:02'! testColorArray self assertSerializationEqualityOf: (ColorArray with: (Color r: 0.0 g: 0.031 b: 0.008) with: (Color r: 0.0 g: 0.07 b: 0.023))! ! !FLBasicSerializationTest methodsFor: 'tests-cycles' stamp: 'MartinDias 10/5/2011 18:15'! testCyclicLinksInArray | a b c materializedA materialized | a := Link new. b := Link new. c := Link new. a nextLink: b. b nextLink: c. c nextLink: a. materialized := self resultOfSerializeAndMaterialize: (Array with: a with: b with: c). materializedA := materialized first. "We can't check using the equality of the links because hangs ad infinitum. So we only check that the structure is right." self assert: materialized size = 3. self assert: materializedA nextLink nextLink nextLink == materializedA. self deny: materializedA nextLink == materializedA. self deny: materializedA nextLink nextLink == materializedA.! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 10/5/2011 17:51'! testBitmap | bitmap materialized | self assertSerializationEqualityOf: (Bitmap with: 0 with: 16rFFFFFFFF). self assertSerializationEqualityOf: (Bitmap with: 4278190080). self assertSerializationEqualityOf: (Bitmap new: 4096). self assertSerializationEqualityOf: (Bitmap with: 0 with: 4294967295). self assertSerializationEqualityOf: (Bitmap new: 256). self assertSerializationEqualityOf: (Bitmap with: 0). bitmap := Bitmap new: 3. bitmap at: 1 put: 4324. bitmap at: 2 put: 5674. bitmap at: 3 put: 8978. materialized := self resultOfSerializeAndMaterialize: bitmap. self assert: (materialized at: 1) = 4324. self assert: (materialized at: 2) = 5674. self assert: (materialized at: 3) = 8978. ! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'MartinDias 12/30/2011 18:44'! testGlobalMetaclass "A metaclass should be global by default." self assertSerializationIdentityOf: Integer class. ! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 10/26/2010 19:45'! testEmptyDictionary self assertSerializationEqualityOf: Dictionary new! ! !FLBasicSerializationTest methodsFor: 'tests-not-so-basic' stamp: 'MartinDias 8/8/2011 15:47'! testGradientFillStyle self assertSerializationEqualityOf: GradientFillStyle sample! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 6/3/2011 20:27'! testLotsOfNils self assertSerializationEqualityOf: (Array new: 1 << 16).! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MarianoMartinezPeck 4/20/2012 21:37'! testMethodDictionary self resultOfSerializeAndMaterializeMethodDictionary: FLPair methodDict. ! ! !FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: 'MarianoMartinezPeck 10/11/2011 12:14'! testScaledDecimal self assertSerializationEqualityOf: (13/11s6). self assertSerializationEqualityOf: (-13/11s6). self assertSerializationEqualityOf: (7621476292473147/9007199254740992s8). self assertSerializationEqualityOf: (-7621476292473147/9007199254740992s8). self assertSerializationEqualityOf: (-0/9007199254740992s8). self assertSerializationEqualityOf: ((13 / 11) asScaledDecimal: 6). self assertSerializationEqualityOf: ((11 / 13) asFloat asScaledDecimal). ! ! !FLBasicSerializationTest methodsFor: 'tests-strings' stamp: 'MarianoMartinezPeck 10/11/2011 12:17'! testString self assertSerializationEqualityOf: 'testString'. self assertSerializationEqualityOf: 'Hi, I''m String-object'. self assertSerializationEqualityOf: String new. self assertSerializationEqualityOf: (0 to: 255) asByteArray asString. ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 10/11/2011 12:21'! testUUID self assertSerializationEqualityOf: (UUID fromString: 'a3b64357-377a-5b41-b575-1c653084a121'). self assertSerializationEqualityOf: UUID nilUUID. self assertSerializationEqualityOf: UUID new. ! ! !FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: 'MarianoMartinezPeck 6/15/2012 19:55'! testAllRangeOfIntegers self assertSerializationIdentityOf: 100. self assertSerializationIdentityOf: 10000. self assertSerializationIdentityOf: 100000. self assertSerializationIdentityOf: 10000000. self assertSerializationIdentityOf: 100000000. self assertSerializationIdentityOf: 1000000000. self assertSerializationEqualityOf: 3000000000. self assertSerializationEqualityOf: 10000000000. self assertSerializationEqualityOf: 100000000000. self assertSerializationEqualityOf: 100 factorial. self assertSerializationIdentityOf: -100. self assertSerializationIdentityOf: -10000. self assertSerializationIdentityOf: -100000. self assertSerializationIdentityOf: -10000000. self assertSerializationIdentityOf: -100000000. self assertSerializationIdentityOf: -1000000000. self assertSerializationEqualityOf: -3000000000. self assertSerializationEqualityOf: -10000000000. self assertSerializationEqualityOf: -100000000000. self assertSerializationEqualityOf: 100 factorial * -1. ! ! !FLBasicSerializationTest methodsFor: 'running' stamp: 'MaxLeske 10/18/2012 07:42'! tearDown super tearDown. DateAndTime localTimeZone: currentTimeZone! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'MaxLeske 2/20/2013 22:18'! testSystemDictionary "We want to treat the instance of SystemDictionary specially but want to serialize all others" self assertSerializationEqualityOf: SystemDictionary new! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 10/5/2011 17:54'! testBag | bag materialized | bag := Bag new. bag add: 10. bag add: 20. bag add: 30. bag add: 30. materialized := self resultOfSerializeAndMaterialize: bag. self assert: bag ~~ materialized. self assert: bag = materialized. self assert: materialized size = 4. ! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 10/17/2010 20:59'! testDictionary self assertSerializationEqualityOf: (Dictionary with: 1->2).! ! !FLBasicSerializationTest methodsFor: 'running' stamp: 'MaxLeske 10/18/2012 07:42'! setUp super setUp. currentTimeZone := DateAndTime localTimeZone.! ! !FLBasicSerializationTest methodsFor: 'tests-cycles' stamp: 'MartinDias 10/5/2011 18:16'! testRecursiveArray | arr materialized | arr := Array new: 3. arr at: 1 put: 10. arr at: 2 put: 20. arr at: 3 put: arr. materialized := self resultOfSerializeAndMaterialize: arr. "We can't check using the equality of the links because hangs ad infinitum. So we only check that the structure is right." self assert: materialized first = 10. self assert: materialized second = 20. self assert: materialized third == materialized.! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MarianoMartinezPeck 6/20/2011 17:11'! testNestedDictionary | childDic dic | childDic := Dictionary new. childDic at: #child1 put: 'abcde'. dic := Dictionary new. dic at: #parent1 put: 'sample string.'. dic at: #parent2 put: 100. dic at: #parent3 put: #(10 20 30 ). dic at: #parent4 put: childDic. self assertSerializationEqualityOf: childDic. self assertSerializationEqualityOf: dic.! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'CamilloBruni 4/29/2013 19:10'! testDontConsiderCustomGlobal "A custom global variable is not treated as global by Fuel, unless we explicitly specify this." | aPerson globalName | aPerson := FLPerson new. globalName := #FLGlobalVariableForTesting. [ Smalltalk globals at: globalName put: aPerson. self deny: (self resultOfSerializeAndMaterialize: aPerson) == aPerson ] ensure: [ Smalltalk globals removeKey: globalName ]. ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 9/2/2011 10:41'! testDateAndTime | initialTime initialDate | initialTime := Time fromSeconds: 76020. initialDate := Date fromSeconds: 3492288000. self assertSerializationEqualityOf: (DateAndTime date: initialDate time: initialTime). initialTime := (Time hour: 24 minute: 60 second: 60). initialDate := Date year: 3050 month: 12 day: 31. self assertSerializationEqualityOf: (DateAndTime date: initialDate time: initialTime). initialTime := (Time hour: 24 minute: 60 second: 60). initialDate := Date year: 1600 month: 12 day: 31. self assertSerializationEqualityOf: (DateAndTime date: initialDate time: initialTime). ! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 9/6/2011 23:33'! testAssociation self assertSerializationEqualityOf: 1-> 'marino'. self assertSerializationEqualityOf: nil-> 'marino'. self assertSerializationEqualityOf: nil-> nil. self assertSerializationEqualityOf: nil-> #(1 3 4). self assertSerializationEqualityOf: nil-> true.! ! !FLBasicSerializationTest methodsFor: 'tests-streams' stamp: 'MartinDias 10/5/2011 18:15'! testReadStream | aReadStream materialized | aReadStream := ReadStream on: 'A'. materialized := self resultOfSerializeAndMaterialize: aReadStream. self assert: $A = aReadStream next. self deny: materialized atEnd. self assert: $A = materialized next. self assert: materialized atEnd.! ! !FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: 'MartinDias 10/17/2010 21:04'! testSmallIntegerMinValue self assertSerializationIdentityOf: SmallInteger minVal ! ! !FLBasicSerializationTest methodsFor: 'tests-cycles' stamp: 'MarianoMartinezPeck 9/28/2011 22:35'! testCyclicIdentitySet | aSet materializedSet | aSet := IdentitySet new. aSet add: aSet. materializedSet := self resultOfSerializeAndMaterialize: aSet. self assert: aSet ~~ materializedSet . self assert: (materializedSet includes: materializedSet) description: 'The materialized set has to include himself. Note aSet = materializedSet is false, bacause equality implementation checks that materializedSet *identity-includes* each element of aSet, which is false.'! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MarianoMartinezPeck 6/6/2011 23:10'! testInterval self assertSerializationEqualityOf: (-10 to: 10 by: 5). self assertSerializationEqualityOf: (-0 to: 0 by: 1). self assertSerializationEqualityOf: (1 to: 10 by: 2). self assertSerializationEqualityOf: (33333333333333331 to: 1444444444444444440 by: 2). self assertSerializationEqualityOf: (0 to: 1 by: 2). ! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 9/29/2010 11:27'! testOrderedCollection self assertSerializationEqualityOf: (OrderedCollection with: 10 with: 20)! ! !FLBitsObjectCluster commentStamp: 'MartinDias 8/1/2011 02:59'! I have the common behavior for generic storing and loading variable bits objects.! !FLBitsObjectCluster methodsFor: 'analyzing' stamp: 'MartinDias 10/13/2011 16:26'! add: anObject traceWith: aAnalysis "Add an object to the cluster. We know the object doesn't have references." objects addLast: anObject! ! !FLBitsObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 10/13/2011 16:26'! registerIndexesOn: aDictionary self flag: #todo. "Converting objects collection here in this method is a bit confusing. This is because since this cluster is for primitives, they do not have pointers to other objects. Hence, instead of storing them in a IdentitySet we can use an OrderedCollection and then just convert them at the end. For more details see FLBitsObjectCluster >> #add: anObject traceWith: aAnalysis" objects := objects asIdentitySet. super registerIndexesOn: aDictionary.! ! !FLBitsObjectCluster methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 13:12'! newAnalyzingCollection "Answer a collection for the objects that correspond to this cluster." ^OrderedCollection new! ! !FLBlockClosureSerializationTest commentStamp: 'TorstenBergmann 2/3/2014 23:26'! SUnit tests for fuel serialization of block closures! !FLBlockClosureSerializationTest methodsFor: 'tests-clean' stamp: 'MartinDias 3/23/2012 02:01'! testBlockClosureWithThreeArguments | closure materializedClosure | closure := [ :a :b :c | a + b + c ]. materializedClosure := self resultOfSerializeAndMaterialize: closure. closure assertWellMaterializedInto: materializedClosure in: self. self assert: (materializedClosure value: 1 value: 2 value: 3) = 6! ! !FLBlockClosureSerializationTest methodsFor: 'tests-change' stamp: 'MarianoMartinezPeck 4/19/2012 19:10'! testBlockClosureRemoved "Raise an error when materializing a closure whose method was removed." | aClass aClosure | aClass := self newClass duringTestCompileSilently: 'methodWithClosure ^ [ 42 ]'; yourself. aClosure := aClass new perform: #methodWithClosure. self serialize: aClosure. aClass removeSelectorSilently: #methodWithClosure. self should: [ self materialized ] raise: FLMethodNotFound! ! !FLBlockClosureSerializationTest methodsFor: 'tests-unclean' stamp: 'MartinDias 3/23/2012 12:09'! testBlockClosureWithSelfSend | closure materializedClosure | closure := self class blockClosureWithSelfSend. materializedClosure := self resultOfSerializeAndMaterialize: closure. closure assertWellMaterializedInto: materializedClosure in: self. self assert: materializedClosure value = closure value! ! !FLBlockClosureSerializationTest methodsFor: 'tests-change' stamp: 'MarianoMartinezPeck 4/19/2012 19:10'! testBlockClosureChangeDifferentBytecodes "Raise an error when materializing a closure whose method has changed bytecodes." | aClass aClosure | aClass := self newClass duringTestCompileSilently: 'methodWithClosure ^ [ 42 ]'; yourself. aClosure := aClass new perform: #methodWithClosure. self serialize: aClosure. aClass duringTestCompileSilently: 'methodWithClosure ^ 42'. self should: [ self materialized ] raise: FLMethodChanged! ! !FLBlockClosureSerializationTest methodsFor: 'tests-change' stamp: 'MarianoMartinezPeck 4/19/2012 19:10'! testBlockClosureChangeSameBytecodes "Tolerate materializing a closure whose method has changed but not the bytecodes." | aClass aClosure materializedClosure | aClass := self newClass duringTestCompileSilently: 'methodWithClosure ^ [ 41 ]'; yourself. aClosure := aClass new perform: #methodWithClosure. self serialize: aClosure. aClass duringTestCompileSilently: 'methodWithClosure ^ [ 42 ]'. self deny: aClosure method isInstalled. materializedClosure := self materialized. self assert: materializedClosure value = 42! ! !FLBlockClosureSerializationTest methodsFor: 'tests-clean' stamp: 'mada 5/4/2012 11:10'! testBlockClosureWithTempVariableRead | closure materializedClosure | closure := self class blockClosureWithTempVariableRead. materializedClosure := self resultOfSerializeAndMaterialize: closure. closure assertWellMaterializedInto: materializedClosure in: self. self assert: materializedClosure value = 'TEST'. ! ! !FLBlockClosureSerializationTest methodsFor: 'tests-clean' stamp: 'MartinDias 3/23/2012 12:21'! testNestedBlockClosure | closure materializedClosure | closure := [ [ 42 ] ]. materializedClosure := self resultOfSerializeAndMaterialize: closure. closure assertWellMaterializedInto: materializedClosure in: self. self assert: materializedClosure value value = 42! ! !FLBlockClosureSerializationTest methodsFor: 'tests-clean' stamp: 'MartinDias 3/23/2012 02:03'! testBlockClosureWithClassVariableRead | closure materializedClosure | ClassVariableForTesting := nil. closure := [ ClassVariableForTesting ]. materializedClosure := self resultOfSerializeAndMaterialize: closure. closure assertWellMaterializedInto: materializedClosure in: self. ClassVariableForTesting := true. self assert: materializedClosure value. ClassVariableForTesting := false. self deny: materializedClosure value! ! !FLBlockClosureSerializationTest class methodsFor: 'closures for testing' stamp: 'MartinDias 3/23/2012 12:08'! blockClosureWithSelfSend ^ [ self printString ]! ! !FLBlockClosureSerializationTest class methodsFor: 'closures for testing' stamp: 'mada 5/4/2012 11:10'! blockClosureWithTempVariableRead | string | string := 'test'. ^ [ string asUppercase ].! ! !FLBufferedWriteStream commentStamp: 'MarianoMartinezPeck 6/5/2011 12:41'! FLBufferedWriteStream is a buffered write stream we use for Fuel serialization. Instead of directly using the stream provided to FLSerializer at creation time by the user, we create an instance of FLBufferedWriteStream for that stream. MultiByteFileStream has no real buffer and goes to disk too frequently. With FLBufferedWriteStream we keep stuff in a cache and only go to disk when this is full. The way of using it is jut FLBufferedWriteStream on: aWriteStream. For example: FLBufferedWriteStream on: (FileDirectory default forceNewFileNamed: 'TestFile') binary With the message #sizeBuffer: you can set the size of the buffer. Make sure to always send #flush or #close when you're done, otherwise the last buffer might not yet have been written. ! !FLBufferedWriteStream methodsFor: 'initialize-release' stamp: 'MartinDias 1/6/2012 18:06'! initializeOn: writeStream bufferSize: aSize self initialize. self initializeStream: writeStream. self sizeBuffer: aSize. position := 0.! ! !FLBufferedWriteStream methodsFor: 'private' stamp: 'MarianoMartinezPeck 8/17/2012 12:10'! buffer buffer ifNil: [ self sizeBuffer: self defaultBufferSize ]. ^ buffer! ! !FLBufferedWriteStream methodsFor: 'file open/close' stamp: 'MarianoMartinezPeck 5/17/2011 23:32'! close self flushBuffer. stream close! ! !FLBufferedWriteStream methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 9/23/2011 22:34'! bufferFreeSize ^ buffer size - position! ! !FLBufferedWriteStream methodsFor: 'writing' stamp: 'MarianoMartinezPeck 10/9/2011 22:47'! nextBytesPutAll: collection self flushBufferIfFull. collection size <= self bufferFreeSize ifTrue: [ self buffer replaceFrom: position + 1 to: position + collection size with: collection. position := position + collection size ] ifFalse: [ self flushBuffer. collection size > (self buffer size / 2) ifTrue: [ stream nextBytesPutAll: collection ] ifFalse: [ self nextBytesPutAll: collection ] ] ! ! !FLBufferedWriteStream methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/16/2012 13:47'! nextPut: object self flushBufferIfFull. position := position + 1. self buffer at: position put: object ! ! !FLBufferedWriteStream methodsFor: 'private' stamp: 'MaxLeske 10/29/2013 21:51'! copyWordObjectToBuffer: aWordObject | blt | blt := (BitBlt toForm: (Form new hackBits: self buffer)) sourceForm: (Form new hackBits: aWordObject). blt combinationRule: Form over. "store" blt sourceX: 0; sourceY: 0; height: aWordObject byteSize // 4; width: 4. blt destX: 0; destY: position // 4. blt copyBits! ! !FLBufferedWriteStream methodsFor: 'private' stamp: 'MarianoMartinezPeck 10/22/2011 12:46'! flushBuffer position = 0 ifTrue: [ ^ self ]. position = buffer size ifTrue: [ stream nextPutAll: buffer ] ifFalse: [ streamRespondsToNextPutAllStartingAt ifTrue: [ stream next: position putAll: buffer startingAt: 1 ] ifFalse: [ stream nextPutAll: (buffer copyFrom: 1 to: position) ] ]. position := 0! ! !FLBufferedWriteStream methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/16/2012 12:41'! sizeBuffer: size buffer ifNotNil: [self flushBuffer]. buffer := (stream isBinary ifTrue: [ ByteArray ] ifFalse: [ String ]) new: size ! ! !FLBufferedWriteStream methodsFor: 'initialize-release' stamp: 'MarianoMartinezPeck 10/22/2011 12:46'! initializeStream: aWriteStream stream := aWriteStream. "This is ugly, but it is an optimization for #flushBuffer" streamRespondsToNextPutAllStartingAt := (stream respondsTo: #next:putAll:startingAt:).! ! !FLBufferedWriteStream methodsFor: 'printing' stamp: 'MarianoMartinezPeck 5/17/2011 23:32'! printOn: aStream aStream nextPutAll: 'a '; nextPutAll: self class name! ! !FLBufferedWriteStream methodsFor: 'writing' stamp: 'MartinDias 2/20/2014 00:26'! nextWordsPut: aWordObject | byteSize | byteSize := aWordObject basicSize * 4. "Ensure we are at bigger than the words added, with size next power-of-two" byteSize > buffer size ifTrue: [ self sizeBuffer: 1 << (byteSize highBit)]. "BitBlt needs word-aligned access of object. Flushing the buffer is a very good idea because after the position will be zero, which is word aligned. Word objects always have a full number of words of data to write. (otherwise they'd be variableByte objects or something :P) So as long as the size you write per instance also takes N words, the position will always be aligned (except when writing the first object of a cluster) . After that, we flush when an object larger than current buffer is encountered (statistically rare), or if the buffer is full (which we do anyways). Finally, we also need enough free space in the buffer" ((position bitAnd: 3) = 0 and: [byteSize < self bufferFreeSize]) ifFalse: [self flushBuffer]. self copyWordObjectToBuffer: aWordObject. position := position + byteSize.! ! !FLBufferedWriteStream methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 5/17/2011 23:32'! defaultBufferSize ^ 8192 "2 raisedTo: 13 " ! ! !FLBufferedWriteStream methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 5/17/2011 23:32'! flush self flushBuffer. stream flush! ! !FLBufferedWriteStream methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 4/23/2012 16:02'! nextPutAll: collection self flushBufferIfFull. collection size <= self bufferFreeSize ifTrue: [ self buffer replaceFrom: position + 1 to: position + collection size with: collection. position := position + collection size ] ifFalse: [ self flushBuffer. collection size > (self buffer size / 2) ifTrue: [ stream nextPutAll: collection ] ifFalse: [ self nextPutAll: collection ] ] ! ! !FLBufferedWriteStream methodsFor: 'accessing' stamp: 'MartinDias 5/11/2012 20:40'! position ^ position + stream position! ! !FLBufferedWriteStream methodsFor: 'private' stamp: 'MarianoMartinezPeck 9/23/2011 22:35'! flushBufferIfFull position = buffer size ifTrue: [ self flushBuffer ] ! ! !FLBufferedWriteStream class methodsFor: 'instance creation' stamp: 'MartinDias 1/6/2012 19:14'! on: writeStream bufferSize: aSize ^ self basicNew initializeOn: writeStream bufferSize: aSize; yourself! ! !FLBufferedWriteStream class methodsFor: 'instance creation' stamp: 'MartinDias 1/6/2012 19:27'! on: writeStream ^ self on: writeStream bufferSize: self defaultBufferSize! ! !FLBufferedWriteStream class methodsFor: 'accessing' stamp: 'MartinDias 1/6/2012 19:28'! defaultBufferSize ^ 4096! ! !FLByteArrayStreamStrategy commentStamp: 'MartinDias 10/12/2011 11:37'! I am a strategy that emulate what we offer with FLSerializer class >> #serializeInMemory: and FLMaterializer class >> #materializeFromByteArray: ! !FLByteArrayStreamStrategy methodsFor: 'writing' stamp: 'MartinDias 10/12/2011 10:20'! writeStreamDo: aValuable "Evaluates the argument with a write stream. Answers the result." inMemoryStream := ByteArray new writeStream. ^aValuable value: inMemoryStream binary ! ! !FLByteArrayStreamStrategy methodsFor: 'reading' stamp: 'MartinDias 10/12/2011 10:21'! readStreamDo: aValuable "Evaluates the argument with a read stream. Answers the result." ^aValuable value: inMemoryStream contents readStream! ! !FLByteObjectCluster commentStamp: 'MartinDias 8/1/2011 02:59'! I am the generic cluster for storing and loading variable byte objects.! !FLByteObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 02:24'! materializeInstanceWith: aDecoder | instance size | size := aDecoder nextEncodedPositiveInteger. instance := theClass basicNew: size. aDecoder nextEncodedBytesInto: instance. ^ instance ! ! !FLByteObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 20:03'! serializeInstance: anObject with: anEncoder anEncoder encodePositiveInteger: anObject basicSize. anEncoder encodeBytes: anObject.! ! !FLClassNotFound commentStamp: 'MarianoMartinezPeck 10/23/2011 14:34'! I represent an error produced during materialization when a serialized class or trait name doesn't exist.! !FLClassNotFound class methodsFor: 'signaling' stamp: 'MartinDias 3/20/2012 12:06'! signalWithName: className ^ self signal: 'Class named ', className printString, ' not found.'! ! !FLClassSerializationTest commentStamp: ''! I have the common behavior for testing class serialization.! !FLClassSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/8/2011 04:14'! newSecondaryTrait "Returns a trait for testing" ^ self newTraitSuffixed: 'Secondary'! ! !FLClassSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 10/16/2012 09:33'! during: aBlock rename: aClass as: anotherClass [ Smalltalk at: aClass name put: anotherClass. ^aBlock value ] ensure: [ Smalltalk at: aClass name put: aClass ].! ! !FLClassSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 11/21/2011 20:20'! newClassWithInstanceVariableNames: instanceVariableNames "Returns a class for testing, with the specified instance variables." ^ self newClassWithInstanceVariableNames: instanceVariableNames superclass: Object! ! !FLClassSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 4/19/2012 19:10'! newClassWithInstanceVariableNames: instanceVariableNames superclass: aSuperclass "Returns a class for testing, with the specified instance variables." ^ self newSubclassOf: aSuperclass instanceVariableNames: instanceVariableNames classVariableNames: ''! ! !FLClassSerializationTest methodsFor: 'tests' stamp: 'MartinDias 10/8/2011 03:11'! newClassOrTrait "Returns a class for testing" ^ self newClassWithInstanceVariableNames: ''! ! !FLClassSerializationTest methodsFor: 'tests' stamp: 'MartinDias 3/23/2011 17:42'! newInstanceFrom: aClass ^ aClass new! ! !FLClassSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 12/13/2011 20:45'! newClassOrTraitWithSuperClass: superclass "Returns a class for testing" ^ self newClassWithInstanceVariableNames: '' superclass: superclass! ! !FLClassWithRecursiveSubstitution commentStamp: 'TorstenBergmann 2/3/2014 23:21'! A test mock for a class with recursive substitution! !FLClassWithRecursiveSubstitution methodsFor: 'accessing' stamp: 'MartinDias 5/9/2012 00:47'! index: anObject index := anObject ! ! !FLClassWithRecursiveSubstitution methodsFor: 'serialization' stamp: 'MartinDias 5/9/2012 00:57'! fuelAccept: aGeneralMapper ^ index < 10 ifTrue: [ aGeneralMapper visitSubstitution: self by: (self copy index: self index + 1) onRecursionDo: [ super fuelAccept: aGeneralMapper ] ] ifFalse: [ super fuelAccept: aGeneralMapper ]! ! !FLClassWithRecursiveSubstitution methodsFor: 'accessing' stamp: 'MartinDias 5/9/2012 00:48'! index ^ index! ! !FLCluster commentStamp: 'MartinDias 8/29/2011 19:20'! I represent a cluster of objects grouped by some specific similarity. I know how to serialize and materialize them all together.! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializePostInstancesStepWith: aDecoder ! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! afterMaterializationStepWith: aDecoder ! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:44'! serializeReferencesStepWith: anEncoder ! ! !FLCluster methodsFor: 'accessing' stamp: 'MartinDias 8/29/2011 00:50'! objects "Answer the objects that this cluster groups." self subclassResponsibility! ! !FLCluster methodsFor: 'initialize-release' stamp: 'MartinDias 1/8/2012 14:32'! initializeAnalyzing self initialize.! ! !FLCluster methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:38'! clusterSerializeStepWith: aSerialization "Serialize cluster stuff"! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:38'! clusterMaterializeStepWith: aMaterialization "Materialize cluster stuff" ! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:44'! serializePostInstancesStepWith: anEncoder ! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 1/8/2012 15:00'! materializeInstancesStepWith: aDecoder ! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 8/29/2011 01:23'! registerIndexesOn: aDictionary "Maps objects with indexes in the dictionary."! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeReferencesStepWith: aDecoder ! ! !FLCluster methodsFor: 'analyzing' stamp: 'MartinDias 8/29/2011 00:54'! clusterReferencesDo: aBlock "Evaluate a block with each object referenced by the cluster"! ! !FLCluster methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 9/18/2012 11:00'! traceWith: anAnalysis self clusterReferencesDo: [ :aChild | anAnalysis privateTrace: aChild ]! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 1/8/2012 15:11'! serializeInstancesStepWith: anEncoder ! ! !FLCluster methodsFor: 'initialize-release' stamp: 'MartinDias 1/8/2012 14:36'! initializeMaterializing self initialize.! ! !FLCluster class methodsFor: 'instance creation' stamp: 'MartinDias 2/17/2012 03:18'! newMaterializing ^ self basicNew initializeMaterializing; yourself.! ! !FLCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:36'! clusterBucketIn: aClusterization "Answer in which clusters bucket place this cluster. This defines the sort order in which the clusters will be ordered. See FLAnalyzer >> clusteredObjects for more information." self subclassResponsibility ! ! !FLCluster class methodsFor: 'instance creation' stamp: 'MartinDias 1/8/2012 14:32'! newAnalyzing ^ self basicNew initializeAnalyzing; yourself.! ! !FLCluster class methodsFor: 'instance creation' stamp: 'MartinDias 1/8/2012 14:33'! new self error: 'Use another instance creation message.'! ! !FLClusterization commentStamp: 'MartinDias 8/29/2011 19:12'! I manage the clusters collected during the analysis step of serialization.! !FLClusterization methodsFor: 'initialization' stamp: 'MarianoMartinezPeck 7/26/2012 17:36'! initialize super initialize. primitivesBucket := IdentityDictionary new. baselevelBucket := IdentityDictionary new. globalsBucket := IdentityDictionary new. metalevelInstanceSideBucket := IdentityDictionary new. metalevelClassSideBucket := IdentityDictionary new. substitutionsBucket := IdentityDictionary new. postBaselevelBucket := IdentityDictionary new. ! ! !FLClusterization methodsFor: 'cluster buckets' stamp: 'MartinDias 8/20/2011 22:52'! substitutionsBucket ^ substitutionsBucket! ! !FLClusterization methodsFor: 'cluster buckets' stamp: 'MarianoMartinezPeck 7/26/2012 17:36'! postBaselevelBucket ^ postBaselevelBucket! ! !FLClusterization methodsFor: 'cluster buckets' stamp: 'MartinDias 8/20/2011 22:27'! baselevelBucket ^ baselevelBucket! ! !FLClusterization methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 1/11/2012 11:02'! objectCount ^self clusterBuckets sum: [ :aClusterBucket | aClusterBucket inject: 0 into: [ :sum :aCluster | sum + aCluster objects size ] ].! ! !FLClusterization methodsFor: 'accessing' stamp: 'MartinDias 1/11/2012 00:27'! clusters ^self clusterBuckets gather: [:c | c ]. ! ! !FLClusterization methodsFor: 'cluster buckets' stamp: 'MartinDias 9/15/2011 20:16'! globalsBucket ^ globalsBucket ! ! !FLClusterization methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/26/2012 17:36'! clusterBuckets "Answer a new collection with all the clusters that have been collected in trace. Note that order is imporant." ^ OrderedCollection new add: globalsBucket; add: primitivesBucket; add: metalevelClassSideBucket; add: metalevelInstanceSideBucket; add: baselevelBucket; add: postBaselevelBucket; add: substitutionsBucket; yourself.! ! !FLClusterization methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLClusterization methodsFor: 'cluster buckets' stamp: 'MartinDias 9/17/2011 00:27'! metalevelClassSideBucket ^ metalevelClassSideBucket! ! !FLClusterization methodsFor: 'cluster buckets' stamp: 'MartinDias 9/17/2011 00:27'! metalevelInstanceSideBucket ^ metalevelInstanceSideBucket ! ! !FLClusterization methodsFor: 'cluster buckets' stamp: 'MartinDias 9/17/2011 00:29'! primitivesBucket ^ primitivesBucket! ! !FLCompiledMethodCluster commentStamp: ''! I am a cluster for CompiledMethod instances. How CompiledMethod trailers are serialized can be established using methods in 'configurating' class-side protocol.! !FLCompiledMethodCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:43'! serializeReferencesStepWith: anEncoder objects do: [ :aCompiledMethod | self serializeLiteralsOf: aCompiledMethod with: anEncoder ]! ! !FLCompiledMethodCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeReferencesStepWith: aDecoder objects do: [ :aCompiledMethod | self materializeLiteralsTo: aCompiledMethod with: aDecoder ]! ! !FLCompiledMethodCluster methodsFor: 'protected' stamp: 'MartinDias 3/21/2012 19:14'! serializeLiteralsOf: aCompiledMethod with: anEncoder aCompiledMethod fuelPrepare. 1 to: aCompiledMethod numLiterals do: [ :index | anEncoder encodeReferenceTo: (aCompiledMethod literalAt: index) ]! ! !FLCompiledMethodCluster methodsFor: 'protected' stamp: 'MartinDias 12/29/2011 19:48'! materializeLiteralsTo: compiledMethod with: aDecoder 1 to: compiledMethod numLiterals do: [ :index | compiledMethod literalAt: index put: aDecoder nextEncodedReference ] ! ! !FLCompiledMethodCluster methodsFor: 'analyzing' stamp: 'MartinDias 3/21/2012 19:14'! referencesOf: aCompiledMethod do: aBlock aCompiledMethod fuelPrepare. 1 to: aCompiledMethod numLiterals do: [ :index | aBlock value: (aCompiledMethod literalAt: index) ]! ! !FLCompiledMethodCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/18/2013 17:58'! serializeInstance: aCompiledMethodToSerialize with: anEncoder | header bytecodesPlusTrailerSize cmSize cmInitialPC aCompiledMethod | aCompiledMethod := self class transformationForSerializing value: aCompiledMethodToSerialize. header := aCompiledMethod header. cmSize := aCompiledMethod size. cmInitialPC := aCompiledMethod initialPC. bytecodesPlusTrailerSize := cmSize - cmInitialPC + 1. anEncoder encodeUint32: header; encodeUint16: bytecodesPlusTrailerSize. cmInitialPC to: cmSize do: [ :index | anEncoder encodeByte: (aCompiledMethod at: index) ].! ! !FLCompiledMethodCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 20:57'! materializeInstanceWith: aDecoder | compiledMethod header bytecodesPlusTrailerSize | header := aDecoder nextEncodedUint32. bytecodesPlusTrailerSize := aDecoder nextEncodedUint16. compiledMethod := CompiledMethod newMethod: bytecodesPlusTrailerSize header: header. compiledMethod initialPC to: compiledMethod size do: [ :index | compiledMethod at: index put: aDecoder nextEncodedByte ]. ^ compiledMethod! ! !FLCompiledMethodCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:37'! clusterBucketIn: aClusterization ^aClusterization primitivesBucket! ! !FLCompiledMethodCluster class methodsFor: 'configuring' stamp: 'MartinDias 2/18/2013 17:58'! setTrailerWithNoChange "Make compiled methods be serialized as they are." ^ self transformationForSerializing: [:aCompiledMethod | aCompiledMethod ]! ! !FLCompiledMethodCluster class methodsFor: 'configuring' stamp: 'MartinDias 2/18/2013 17:58'! setTrailerWithNoSource "Make compiled methods be serialized without source code." ^ self transformationForSerializing: [:aCompiledMethod | aCompiledMethod copyWithTrailerBytes: CompiledMethodTrailer empty ]! ! !FLCompiledMethodCluster class methodsFor: 'class initialization' stamp: 'MaxLeske 11/6/2013 09:11'! initialize self setTrailerWithSourceCode! ! !FLCompiledMethodCluster class methodsFor: 'configuring' stamp: 'MartinDias 2/18/2013 17:59'! setTrailerWithSourceCode "Make compiled methods be serialized with embedded source code." ^ self transformationForSerializing: [:aCompiledMethod | aCompiledMethod copyWithTrailerBytes: (CompiledMethodTrailer new sourceCode: aCompiledMethod sourceCode) ]! ! !FLCompiledMethodCluster class methodsFor: 'accessing' stamp: 'MartinDias 2/18/2013 17:58'! transformationForSerializing: aBlockWithOneArgument transformationForSerializing := aBlockWithOneArgument! ! !FLCompiledMethodCluster class methodsFor: 'accessing' stamp: 'MartinDias 2/25/2013 14:32'! transformationForSerializing "Answer a block closure that receives a CompiledMethod and returns another or the same CompiledMethod ready for being serialized." ^ transformationForSerializing! ! !FLCompiledMethodCluster class methodsFor: 'cleanup' stamp: 'MarcusDenker 10/11/2013 12:37'! cleanUp self initialize ! ! !FLCompiledMethodSerializationTest methodsFor: 'helpers' stamp: 'MaxLeske 11/6/2013 15:04'! useNotInstalled theClass duringTestCompileSilently: 'm ^ 42' storeSource: false. theCompiledMethod := theClass methodNamed: #m. theClass methodDict removeKey: #m! ! !FLCompiledMethodSerializationTest methodsFor: 'tests' stamp: 'MaxLeske 11/6/2013 15:29'! testDoIt | materialized | "Since Pharo 3.0 decompilation of compiled methods is no longer possible. That means we have to store the source too." self useDoIt. theCompiledMethod selector: #DoIt. self assert: theCompiledMethod isDoIt. self assert: theCompiledMethod isInstalled. self deny: theCompiledMethod trailer hasSource. self assert: theCompiledMethod trailer isEmpty. self deny: theCompiledMethod trailer hasSourcePointer. materialized := self resultOfSerializeAndMaterialize: theCompiledMethod. "not possible since it's a different instance" self deny: materialized isInstalled. self assert: materialized isDoIt. "we serialized the source" self assert: materialized trailer hasSource. self deny: materialized trailer isEmpty. self deny: materialized trailer hasSourcePointer. self assert: (materialized isEqualRegardlessTrailerTo: theCompiledMethod)! ! !FLCompiledMethodSerializationTest methodsFor: 'tests' stamp: 'MaxLeske 11/6/2013 15:29'! testNotInstalled | materialized | "Since Pharo 3.0 decompilation of compiled methods is no longer possible. That means we have to store the source too." self useNotInstalled. self deny: theCompiledMethod isInstalled. self deny: theCompiledMethod isDoIt. self deny: theCompiledMethod trailer hasSource. self assert: theCompiledMethod trailer isEmpty. self deny: theCompiledMethod trailer hasSourcePointer. materialized := self resultOfSerializeAndMaterialize: theCompiledMethod. self deny: materialized isInstalled. self deny: materialized isDoIt. "we serialized the source" self assert: materialized trailer hasSource. self deny: materialized trailer isEmpty. self deny: materialized trailer hasSourcePointer. self assert: (materialized isEqualRegardlessTrailerTo: theCompiledMethod)! ! !FLCompiledMethodSerializationTest methodsFor: 'tests' stamp: 'MaxLeske 11/6/2013 15:21'! testInstalled | materialized | "Since Pharo 3.0 decompilation of compiled methods is no longer possible. That means we have to store the source too." self useInstalled. self assert: theCompiledMethod isInstalled. self deny: theCompiledMethod isDoIt. self deny: theCompiledMethod trailer hasSource. self deny: theCompiledMethod trailer isEmpty. self assert: theCompiledMethod trailer hasSourcePointer. "if installed but not different, the installed instance will be answered" materialized := self resultOfSerializeAndMaterialize: theCompiledMethod. self assert: materialized == theCompiledMethod! ! !FLCompiledMethodSerializationTest methodsFor: 'helpers' stamp: 'MaxLeske 11/6/2013 15:05'! useInstalled theClass duringTestCompileSilently: 'm ^ 42' storeSource: true. theCompiledMethod := theClass methodNamed: #m! ! !FLCompiledMethodSerializationTest methodsFor: 'helpers' stamp: 'MaxLeske 11/6/2013 15:04'! useDoIt theClass duringTestCompileSilently: 'm ^ 42' storeSource: false. theCompiledMethod := theClass methodNamed: #m. theClass methodDict at: #DoIt put: theCompiledMethod! ! !FLCompiledMethodSerializationTest methodsFor: 'as yet unclassified' stamp: 'MaxLeske 11/6/2013 15:29'! testInstalledModified | copy materialized | "Since Pharo 3.0 decompilation of compiled methods is no longer possible. That means we have to store the source too." self useInstalled. self assert: theCompiledMethod isInstalled. self deny: theCompiledMethod isDoIt. self deny: theCompiledMethod trailer hasSource. self deny: theCompiledMethod trailer isEmpty. self assert: theCompiledMethod trailer hasSourcePointer. copy := theCompiledMethod copy. "different instance can not be installed at the same time." self deny: copy isInstalled. self deny: copy isDoIt. self deny: copy trailer hasSource. self deny: copy trailer isEmpty. self assert: copy trailer hasSourcePointer. "if installed but not different, the installed instance will be answered" materialized := self resultOfSerializeAndMaterialize: copy. self deny: materialized == theCompiledMethod. self deny: materialized == copy. self deny: materialized isInstalled. self deny: materialized isDoIt. "we serialized the source" self assert: materialized trailer hasSource. self deny: materialized trailer isEmpty. self deny: materialized trailer hasSourcePointer! ! !FLCompiledMethodSerializationTest methodsFor: 'running' stamp: 'MaxLeske 11/6/2013 15:01'! setUp super setUp. theClass := self newClass class! ! !FLDecoder commentStamp: 'MartinDias 1/6/2012 16:08'! I am an abstraction used by the materialization algorithm to decode the graph from a stream.! !FLDecoder methodsFor: 'decoding' stamp: 'MartinDias 12/29/2011 21:07'! nextEncodedByte ^stream next! ! !FLDecoder methodsFor: 'decoding' stamp: 'MarianoMartinezPeck 1/7/2012 14:57'! nextEncodedPositiveInteger "Read a 32-bit signed integer from the next 4 bytes" | s | s := 0. 1 to: 4 do: [:i | s := (s bitShift: 8) + stream next]. ^ s! ! !FLDecoder methodsFor: 'decoding' stamp: 'MarianoMartinezPeck 1/7/2012 14:58'! nextEncodedString | length aByteArray | "read the length in binary mode" length := stream next. "first byte." length >= 192 ifTrue: [length := length - 192. 1 to: 3 do: [:ii | length := length * 256 + stream next]]. aByteArray := ByteArray new: length. stream nextInto: aByteArray. ^aByteArray asString. ! ! !FLDecoder methodsFor: 'decoding' stamp: 'MartinDias 2/17/2012 04:10'! decodeYourself | objectCount | objectCount := self nextEncodedPositiveInteger. indexStream := FLIndexStream on: stream digits: objectCount digitLength. objects := Array new: objectCount. objectsWriteStream := WriteStream on: objects. isBigEndian := self nextEncodedPositiveInteger. ! ! !FLDecoder methodsFor: 'decoding' stamp: 'MartinDias 12/30/2011 15:34'! nextEncodedReference ^ objects at: indexStream nextIndex! ! !FLDecoder methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/1/2013 10:01'! variablesMappingFor: aClass | variables | variables := FLVariablesMapping materializing: aClass from: self. migrations select: [ :m | (m targetClass == aClass) or: [ aClass inheritsFrom: m targetClass ] ] thenDo: [ :m | m applyTo: variables ]. ^ variables ! ! !FLDecoder methodsFor: 'decoding' stamp: 'MarianoMartinezPeck 1/7/2012 14:56'! nextEncodedInt32 | n firstDigit | n := firstDigit := stream next. n := (n bitShift: 8) + stream next. n := (n bitShift: 8) + stream next. n := (n bitShift: 8) + stream next. firstDigit >= 128 ifTrue: [n := -16r100000000 + n]. "decode negative 32-bit integer" ^ n ! ! !FLDecoder methodsFor: 'accessing' stamp: 'MartinDias 12/29/2011 18:51'! objects ^ objects! ! !FLDecoder methodsFor: 'decoding' stamp: 'MarianoMartinezPeck 6/9/2012 11:56'! nextEncodedUint24 "Answer the next unsigned, 24-bit integer from this (binary) stream." | n | n := stream next. n := (n bitShift: 8) + stream next. n := (n bitShift: 8) + stream next. ^ n ! ! !FLDecoder methodsFor: 'accessing' stamp: 'MartinDias 2/21/2013 23:47'! globalEnvironment "Answer a dictionary where the look up for global symbols will be done during materialization." ^ globalEnvironment! ! !FLDecoder methodsFor: 'accessing' stamp: 'MartinDias 2/17/2012 04:06'! registerAll: someObjects objectsWriteStream nextPutAll: someObjects.! ! !FLDecoder methodsFor: 'accessing' stamp: 'MartinDias 1/5/2012 13:12'! classNamed: className ^ (migrations detect: [:m | m sourceClassName = className ] ifNone: [ ^ self globalClassNamed: className ]) targetClass. ! ! !FLDecoder methodsFor: 'initializing' stamp: 'MartinDias 2/21/2013 23:50'! initializeOn: aStream migrations: aCollection globalEnvironment: aDictionary self initialize. stream := aStream. migrations := aCollection. globalEnvironment := aDictionary.! ! !FLDecoder methodsFor: 'accessing' stamp: 'MartinDias 12/29/2011 18:27'! isBigEndian ^ isBigEndian! ! !FLDecoder methodsFor: 'decoding' stamp: 'MartinDias 12/29/2011 21:02'! nextEncodedWordsInto: aWordsObject stream fuelNextWordsInto: aWordsObject ! ! !FLDecoder methodsFor: 'decoding' stamp: 'MartinDias 12/30/2011 02:25'! nextEncodedBytesInto: aBytesObject stream next: aBytesObject basicSize into: aBytesObject ! ! !FLDecoder methodsFor: 'decoding' stamp: 'MartinDias 2/21/2013 15:27'! nextEncodedClusterClass ^ self class environment at: self nextEncodedString asSymbol! ! !FLDecoder methodsFor: 'decoding' stamp: 'MarianoMartinezPeck 6/9/2012 12:32'! nextEncodedUint16 "Answer the next unsigned, 16-bit integer from this (binary) stream." ^ (stream next bitShift: 8) + (stream next). ! ! !FLDecoder methodsFor: 'decoding' stamp: 'MarianoMartinezPeck 6/9/2012 20:01'! nextEncodedInt24 | n firstDigit | n := firstDigit := stream next. n := (n bitShift: 8) + stream next. n := (n bitShift: 8) + stream next. firstDigit >= 128 ifTrue: [n := -16r1000000 + n]. "decode negative 24-bit integer" ^ n ! ! !FLDecoder methodsFor: 'decoding' stamp: 'MarianoMartinezPeck 1/7/2012 20:09'! nextEncodedBitmap ^ Bitmap newFromStream: stream! ! !FLDecoder methodsFor: 'decoding' stamp: 'MarianoMartinezPeck 1/7/2012 14:59'! nextEncodedUint32 "Answer the next unsigned, 32-bit integer from this (binary) stream." | n | n := stream next. n := (n bitShift: 8) + stream next. n := (n bitShift: 8) + stream next. n := (n bitShift: 8) + stream next. ^ n ! ! !FLDecoder methodsFor: 'accessing' stamp: 'MartinDias 2/21/2013 23:48'! globalClassNamed: className ^ globalEnvironment at: className ifAbsent: [ FLClassNotFound signalWithName: className ]! ! !FLDecoder methodsFor: 'decoding' stamp: 'MarianoMartinezPeck 6/8/2012 22:55'! nextEncodedUint8 "Answer the next unsigned, 16-bit integer from this (binary) stream." ^ stream next. ! ! !FLDecoder class methodsFor: 'instance creation' stamp: 'MartinDias 2/21/2013 23:43'! on: aStream migrations: aCollection globalEnvironment: aDictionary ^self basicNew initializeOn: aStream migrations: aCollection globalEnvironment: aDictionary; yourself.! ! !FLDelayedSerializationMock methodsFor: 'serializing' stamp: 'MaxLeske 5/2/2013 09:15'! run "Serialize the graph starting at the root object." self analysisStep. self headerStep. self instancesStep. (Delay forMilliseconds: 100) wait. self referencesStep. self trailerStep.! ! !FLDelayedSerializerMock methodsFor: 'protected' stamp: 'MaxLeske 5/4/2013 16:17'! setDefaultSerialization ^ serializationFactory := [:anObject :anEncoder | (FLDelayedSerializationMock with: anEncoder root: anObject analyzer: self analyzer) run; yourself ]! ! !FLDictionaryCollectionCluster commentStamp: ''! A FLDictionaryCollectionCluster is a special optional cluster that rather than using the default (variable object) serialization, uses #keysAndValuesDo: to iterate objects and #add: during materialization. This way we avoid analyzing/serializing lots of nil. Also, the rehash is not needed. So far we use it for Dictionary, IdentityDictionary and MethodDictionary.! !FLDictionaryCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 7/26/2012 16:13'! materializeReferencesOf: anObject with: aDecoder aDecoder nextEncodedPositiveInteger "anObject size" timesRepeat: [ anObject add: aDecoder nextEncodedReference -> aDecoder nextEncodedReference ]! ! !FLDictionaryCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MaxLeske 5/3/2013 09:54'! serializeReferencesOf: anObject with: anEncoder | refs | refs := self references at: anObject ifAbsent: [ ^ self ]. anEncoder encodePositiveInteger: refs first. refs allButFirst do: [ :value | anEncoder encodeReferenceTo: value ] ! ! !FLDictionaryCollectionCluster methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 7/28/2012 22:27'! referencesOf: anObject do: aBlock aBlock value: anObject size. anObject keysAndValuesDo: [ :key :value | aBlock value: key. aBlock value: value. ] ! ! !FLEncoder commentStamp: 'MartinDias 1/6/2012 16:08'! I am an abstraction used by the serialization algorithm to encode the graph in a stream.! !FLEncoder methodsFor: 'encoding' stamp: 'MartinDias 12/30/2011 15:31'! encodeYourself self encodePositiveInteger: objectCount. self encodePositiveInteger: Smalltalk isBigEndian asBit.! ! !FLEncoder methodsFor: 'accessing' stamp: 'MartinDias 12/29/2011 17:12'! objectsIndexes ^ objectsIndexes! ! !FLEncoder methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 4/20/2012 23:31'! objectCount: aNumber objectCount := aNumber. objectsIndexes := FLLargeIdentityDictionary new. indexStream := FLIndexStream on: stream digits: aNumber digitLength.! ! !FLEncoder methodsFor: 'encoding' stamp: 'MarianoMartinezPeck 1/7/2012 20:13'! encodeInt32: aSmallInteger "Write a signed integer to the next 4 bytes" | pos | pos := aSmallInteger < 0 ifTrue: [(0-aSmallInteger) bitInvert32 + 1] ifFalse: [aSmallInteger]. 1 to: 4 do: [:i | stream nextPut: (pos digitAt: 5-i)]. ! ! !FLEncoder methodsFor: 'encoding' stamp: 'MarianoMartinezPeck 6/9/2012 12:13'! encodeUint32: aSmallInteger "Append to the receiver an Integer as the next 4 bytes." stream nextPut: (aSmallInteger bitShift: -24); nextPut: ((aSmallInteger bitShift: -16) bitAnd: 255); nextPut: ((aSmallInteger bitShift: -8) bitAnd: 255); nextPut: (aSmallInteger bitAnd: 255) ! ! !FLEncoder methodsFor: 'accessing' stamp: 'MartinDias 12/29/2011 18:46'! objectCount ^ objectCount! ! !FLEncoder methodsFor: 'encoding' stamp: 'MarianoMartinezPeck 1/7/2012 20:13'! encodePositiveInteger: anInteger "Append to the receiver an Integer as the next 4 bytes." 1 to: 4 do: [:i | stream nextPut: (anInteger digitAt: 4+1-i)].! ! !FLEncoder methodsFor: 'hooks' stamp: 'MartinDias 5/11/2012 16:15'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLEncoder methodsFor: 'encoding' stamp: 'MartinDias 12/30/2011 15:34'! encodeWeakReferenceTo: anObject indexStream nextIndexPut: (objectsIndexes at: anObject ifAbsent: [objectsIndexes at: nil]) ! ! !FLEncoder methodsFor: 'encoding' stamp: 'MarianoMartinezPeck 6/9/2012 12:16'! encodeUint24: aSmallInteger "Append to the receiver an Integer as the next 3 bytes." stream nextPut: ((aSmallInteger bitShift: -16) bitAnd: 255); nextPut: ((aSmallInteger bitShift: -8) bitAnd: 255); nextPut: (aSmallInteger bitAnd: 255) ! ! !FLEncoder methodsFor: 'encoding' stamp: 'MarianoMartinezPeck 1/7/2012 20:08'! encodeBitmap: aBitmap "Append to the receiver an Integer as the next two bytes." aBitmap writeOn: stream. ! ! !FLEncoder methodsFor: 'encoding' stamp: 'MarianoMartinezPeck 1/11/2012 22:24'! encodeReferenceTo: anObject indexStream nextIndexPut: (objectsIndexes at: anObject ifAbsent: [FLObjectNotFound signalWith: anObject])! ! !FLEncoder methodsFor: 'encoding' stamp: 'MartinDias 2/20/2012 15:37'! encodeClusterClass: aClusterClass self encodeString: aClusterClass name! ! !FLEncoder methodsFor: 'encoding' stamp: 'MarianoMartinezPeck 6/9/2012 20:00'! encodeInt24: aSmallInteger "Write a signed integer to the next 4 bytes" | pos | pos := aSmallInteger < 0 ifTrue: [((0-aSmallInteger) bitXor: 16rFFFFFF) + 1] ifFalse: [aSmallInteger]. 1 to: 3 do: [:i | stream nextPut: (pos digitAt: 4-i)]. ! ! !FLEncoder methodsFor: 'encoding' stamp: 'MarianoMartinezPeck 6/8/2012 22:54'! encodeUint8: aSmallInteger "Append to the receiver an Integer as the next two bytes." stream nextPut: aSmallInteger ! ! !FLEncoder methodsFor: 'accessing' stamp: 'MartinDias 2/21/2013 23:52'! globalEnvironment "Answer a dictionary where the look up for global symbols will be done during serialization." ^ globalEnvironment! ! !FLEncoder methodsFor: 'initialize-release' stamp: 'MartinDias 2/22/2013 10:57'! initializeOn: aStream globalEnvironment: aDictionary self initialize. stream := FLBufferedWriteStream on: aStream. globalEnvironment := aDictionary.! ! !FLEncoder methodsFor: 'encoding' stamp: 'MartinDias 12/29/2011 20:18'! encodeWords: aWordsObject stream nextWordsPut: aWordsObject! ! !FLEncoder methodsFor: 'encoding' stamp: 'MartinDias 12/29/2011 20:16'! encodeBytes: aBytesObject stream nextBytesPutAll: aBytesObject ! ! !FLEncoder methodsFor: 'encoding' stamp: 'MartinDias 12/29/2011 20:11'! encodeByte: aSmallInteger stream nextPut: aSmallInteger! ! !FLEncoder methodsFor: 'encoding' stamp: 'MartinDias 1/6/2012 22:42'! flush ^ stream flush.! ! !FLEncoder methodsFor: 'encoding' stamp: 'MarianoMartinezPeck 1/7/2012 20:13'! encodeString: aString | length | (length := aString size) < 192 ifTrue: [stream nextPut: length] ifFalse: [stream nextPut: (length digitAt: 4)+192. stream nextPut: (length digitAt: 3). stream nextPut: (length digitAt: 2). stream nextPut: (length digitAt: 1)]. stream nextBytesPutAll: aString.! ! !FLEncoder methodsFor: 'encoding' stamp: 'MarianoMartinezPeck 1/7/2012 20:13'! encodeUint16: aSmallInteger "Append to the receiver an Integer as the next two bytes." stream nextPut: (aSmallInteger bitShift: -8). stream nextPut: (aSmallInteger bitAnd: 255).! ! !FLEncoder class methodsFor: 'instance creation' stamp: 'MartinDias 2/22/2013 10:59'! on: aStream globalEnvironment: aDictionary ^self basicNew initializeOn: aStream globalEnvironment: aDictionary; yourself.! ! !FLEncoder class methodsFor: 'instance creation' stamp: 'MartinDias 2/22/2013 10:57'! on: aStream globalEnvironment: aDictionary do: aBlock | anEncoder | anEncoder := self on: aStream globalEnvironment: aDictionary. ^ [ aBlock value: anEncoder ] ensure: [ anEncoder flush ]! ! !FLError commentStamp: ''! I represent an error produced during Fuel operation.! !FLFileStreamStrategy commentStamp: 'MartinDias 10/12/2011 11:37'! I am a strategy for traditional file streams.! !FLFileStreamStrategy methodsFor: 'writing' stamp: 'MartinDias 12/7/2011 01:59'! writeStreamDo: aValuable "Evaluates the argument with a write stream. Answers the result." ^self fileStreamClass forceNewFileNamed: self fileName do: [ :aStream | aValuable value: aStream binary ]! ! !FLFileStreamStrategy methodsFor: 'writing' stamp: 'MartinDias 12/7/2011 02:01'! fileStreamClass "Returns the FileStream specific class" ^fileStreamClass! ! !FLFileStreamStrategy methodsFor: 'writing' stamp: 'MarcusDenker 7/10/2012 10:35'! fileName "Answer a filename to serialize and materialize using it." ^ Smalltalk image shortImageName, '-tests.fuel'! ! !FLFileStreamStrategy methodsFor: 'writing' stamp: 'MartinDias 12/7/2011 02:02'! initializeWith: aFileStreamClass self initialize. fileStreamClass := aFileStreamClass.! ! !FLFileStreamStrategy methodsFor: 'reading' stamp: 'MartinDias 12/7/2011 01:59'! readStreamDo: aValuable "Evaluates the argument with a read stream. Answers the result." ^self fileStreamClass oldFileNamed: self fileName do: [ :aStream | aValuable value: aStream binary ]! ! !FLFileStreamStrategy class methodsFor: 'instance creation' stamp: 'MartinDias 12/7/2011 02:05'! new self error: 'Invalid creation method.'! ! !FLFileStreamStrategy class methodsFor: 'instance creation' stamp: 'MartinDias 12/7/2011 02:03'! newWith: aFileStream ^self basicNew initializeWith: aFileStream; yourself! ! !FLFileStreamStrategy class methodsFor: 'instance creation' stamp: 'MartinDias 12/7/2011 02:03'! newWithMultiByteFileStream ^self newWith: MultiByteFileStream! ! !FLFileStreamStrategy class methodsFor: 'instance creation' stamp: 'MartinDias 12/7/2011 02:02'! newWithStandardFileStream ^self newWith: StandardFileStream! ! !FLFixedObjectCluster commentStamp: 'MartinDias 5/30/2011 01:25'! I am a generic cluster for objects without indexable variables.! !FLFixedObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/17/2012 03:05'! serializeInstancesStepWith: anEncoder "Do nothing. I know my objects have nothing to serialize in this step." ! ! !FLFixedObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/20/2013 21:46'! materializeInstanceWith: aDecoder ^theClass fuelNew! ! !FLFuelCommandLineHandler commentStamp: ''! I handle .fuel files that are passed as arguments when starting the image. Usage: fuel [save] [quit] save save the image after loading quit Don't save the image and directly quit the image fater loading Documentation: This command will load the and materialize/install it's contents. If no argument is specified the image continues running with the loaded contents. Example: #Load a fuel file and save and quit the image with the contents: pharo Pharo.image save quit path/to/foo.fuel #Load the contents of foo.fuel and save the image, but continue running: pharo Pharo.image save path/to/foo.fuel #Load the contents of foo.fuel and continue running without saving: pharo Pharo.image path/to/foo.fuel ! !FLFuelCommandLineHandler methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/4/2012 22:14'! fileExtension ^ self class fileExtension! ! !FLFuelCommandLineHandler methodsFor: 'manage' stamp: 'MarianoMartinezPeck 8/4/2012 23:46'! manageFile: aFileReference aFileReference readStreamDo: [ :stream | stream binary. FileStream stdout nextPutAll: 'Materializing from file: ', aFileReference fullName; lf. FLMaterializer new materializeFrom: stream. FileStream stdout nextPutAll: 'Materialization finished'; lf. ].! ! !FLFuelCommandLineHandler methodsFor: 'manage' stamp: 'MarianoMartinezPeck 8/4/2012 22:10'! manageFiles "Load all the source files in the given array." files := (self commandLine allFilesWithExtension: self fileExtension) collect: [ :each | (FileSystem disk resolve: each) asFileReference ]. files ifNil: [ ^self ]. files do: [ :reference | self manageFile: reference ] ! ! !FLFuelCommandLineHandler methodsFor: 'activation' stamp: 'MarianoMartinezPeck 8/21/2012 10:58'! activate self manageFiles. (self commandLine hasOption: 'save') ifTrue: [ ThreadSafeTranscript install. Smalltalk addDeferredStartupAction: [ Smalltalk snapshot: true andQuit: true. NonInteractiveTranscript new install. ] ]. (self commandLine hasOption: 'quit') ifTrue: [ self exitSuccess ].! ! !FLFuelCommandLineHandler class methodsFor: 'handler selection' stamp: 'MarianoMartinezPeck 8/4/2012 22:18'! isResponsibleFor: aCommandLine "This handler is reponsible only for .fuel files" (aCommandLine hasFileWithExtension: self fileExtension) ifTrue: [ ^ true ]. ^ super isResponsibleFor: aCommandLine ! ! !FLFuelCommandLineHandler class methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/4/2012 22:19'! fileExtension ^ '.fuel'! ! !FLFuelCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 2/6/2013 18:18'! description ^ 'Loads fuel files'! ! !FLFuelCommandLineHandler class methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/4/2012 22:16'! commandName ^ 'Fuel'! ! !FLGZipStrategy commentStamp: ''! I am a strategy for using GZipStream.! !FLGZipStrategy methodsFor: 'reading' stamp: 'MaxLeske 8/5/2013 09:01'! readStreamDo: aValuable "Evaluates the argument with a read stream. Answers the result." targetStrategy readStreamDo: [:aStream | ^ GZipReadStream with: aStream do: aValuable] ! ! !FLGZipStrategy methodsFor: 'initialize-release' stamp: 'MartinDias 10/12/2011 18:41'! initializeWith: aStreamStrategy self initialize. targetStrategy := aStreamStrategy.! ! !FLGZipStrategy methodsFor: 'writing' stamp: 'MaxLeske 8/5/2013 09:01'! writeStreamDo: aValuable "Evaluates the argument with a write stream. Answers the result." targetStrategy writeStreamDo: [:aStream | ^ GZipWriteStream with: aStream do: aValuable] ! ! !FLGZipStrategy class methodsFor: 'instance creation' stamp: 'MartinDias 10/12/2011 18:40'! newWithTarget: aStreamStrategy ^self basicNew initializeWith: aStreamStrategy; yourself ! ! !FLGZippedBasicSerializationTest commentStamp: 'TorstenBergmann 2/3/2014 23:25'! SUnit tests for basic serialization that is zipped! !FLGZippedBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2011 16:16'! testWideString | anObject | anObject := OrderedCollection new. 600 timesRepeat: [ anObject add: (WideString streamContents: [ :stream | 600 timesRepeat: [ stream nextPut: (256 to: 1000) atRandom asCharacter ] ] ) ]. self assertSerializationEqualityOf: anObject! ! !FLGZippedBasicSerializationTest methodsFor: 'expected failures' stamp: 'MartinDias 4/12/2012 20:02'! expectedFailures ^ super expectedFailures, #(testWideString)! ! !FLGZippedBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 9/27/2011 22:37'! testByteArray self assertSerializationEqualityOf: #[1 2 3 4 5 6 7]! ! !FLGZippedBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 9/27/2011 22:45'! testCompleteBinaryTree | aCollection numberOfLeafs | numberOfLeafs := 2 raisedTo: 13. aCollection := OrderedCollection new. 1 to: numberOfLeafs do: [ :i | aCollection add: ( FLPair new left: (2 * i); right: (2 * i) + 1; yourself) ]. [aCollection size > 1] whileTrue: [ aCollection := aCollection pairsCollect: [ :leftPair :rightPair | FLPair new left: leftPair; right: rightPair; yourself ] ]. self assertSerializationEqualityOf: aCollection! ! !FLGZippedBasicSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/22/2012 20:14'! setUp super setUp. self useGzipInMemoryStream.! ! !FLGZippedBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 9/27/2011 22:44'! testPairs | pairs | pairs := (1 to: 1 << 14) collect: [ :i | FLPair new left: i; right: i+1; yourself ]. self assertSerializationEqualityOf: pairs! ! !FLGZippedBasicSerializationTest class methodsFor: 'testing' stamp: 'MartinDias 3/22/2012 20:08'! shouldInheritSelectors ^true! ! !FLGlobalClassCluster commentStamp: 'MartinDias 5/30/2011 01:28'! I am a cluster for classes that should be present when materializing. In other words, it only serializes a reference to the class, using its name.! !FLGlobalClassCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 12:29'! materializeInstanceWith: aDecoder ^self materializeGlobalClassFrom: aDecoder ! ! !FLGlobalClassCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 12:27'! serializeInstance: aClass with: anEncoder self serializeGlobalClass: aClass on: anEncoder! ! !FLGlobalClassSerializationTest commentStamp: 'MartinDias 11/28/2011 10:48'! I test the serialization of classes as *global* objects, i.e. the classes has to be present in the image at materialization time.! !FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''! testClassSideMethodNotFoundAfterRemoval "Tests that serializer does not tolarate when the method was removed between serialization and materialization" | classOrTrait | classOrTrait := self newClassOrTrait. classOrTrait classSide duringTestCompileSilently: 'you'. self serialize: classOrTrait classSide >> #you. classOrTrait classSide removeSelectorSilently: #you. self should: [self materialized] raise: FLMethodNotFound whoseDescriptionIncludes: classOrTrait classSide printString description: 'Should raise an error when method is not present.' ! ! !FLGlobalClassSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 19:40'! testInstanceOfAnObsoleteClass "Tests that serializer does not serialize an instance of an obsolete class." | aClass instance | aClass := self newClassOrTrait. instance := self newInstanceFrom: aClass. self removeFromSystem: aClass. self should: [self serialize: instance ] raise: FLObsolete whoseDescriptionIncludes: aClass name description: 'Should raise an error when serializing as global an obsolete class.' ! ! !FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''! testClassSideObsolete "Tests that serializer does not serialize as global the class-side of an obsolete class or trait." | classOrTrait | classOrTrait := self newClassOrTrait. self removeFromSystem: classOrTrait. self should: [self serialize: classOrTrait ] raise: FLObsolete whoseDescriptionIncludes: classOrTrait name description: 'Should raise an error when serializing as global an obsolete class or trait.' ! ! !FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''! testObsolete "Tests that serializer does not serialize as global an obsolete class or trait." | classOrTrait | classOrTrait := self newClassOrTrait. self removeFromSystem: classOrTrait. self should: [self serialize: classOrTrait ] raise: FLObsolete whoseDescriptionIncludes: classOrTrait name description: 'Should raise an error when serializing as global an obsolete class or trait.' ! ! !FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''! testClassSidePreservesIdentity "Tests that serialization of the class side preserves identity" self assertSerializationIdentityOf: self newClassOrTrait classSide ! ! !FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''! testClassSideMethodPreservesIdentity "Tests that serialization of a method in the class-side of a class or trait preserves identity" | classOrTrait | classOrTrait := self newClassOrTrait. classOrTrait classSide duringTestCompileSilently: 'you'. self assertSerializationIdentityOf: classOrTrait classSide >> #you! ! !FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''! testNotFoundAfterRename "Tests that serializer does not tolarate when the class was renamed between serialization and materialization" | classOrTrait | classOrTrait := self newClassOrTrait. self serialize: classOrTrait. classOrTrait renameSilently: (classOrTrait name, 'Renamed') asSymbol. self should: [self materialized] raise: FLClassNotFound.! ! !FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''! testPreservesIdentity "Tests that serialization of the class or trait preserves identity" self assertSerializationIdentityOf: self newClassOrTrait! ! !FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''! testMethodNotFoundAfterRemoval "Tests that serializer does not tolarate when the method was removed between serialization and materialization" | classOrTrait | classOrTrait := self newClassOrTrait. classOrTrait duringTestCompileSilently: 'you'. self serialize: classOrTrait >> #you. classOrTrait removeSelectorSilently: #you. self should: [self materialized] raise: FLMethodNotFound whoseDescriptionIncludes: classOrTrait name, '>>#you' description: 'Should raise an error when method is not present.' ! ! !FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''! testMethodPreservesIdentity "Tests that serialization of a method in a class or trait preserves identity" | classOrTrait | classOrTrait := self newClassOrTrait. classOrTrait duringTestCompileSilently: 'you'. self assertSerializationIdentityOf: classOrTrait >> #you! ! !FLGlobalClassSerializationTest methodsFor: 'tests' stamp: ''! testNotFoundAfterRemoval "Tests that serializer does not tolarate when the class was removed between serialization and materialization" | classOrTrait | classOrTrait := self newClassOrTrait. self serialize: classOrTrait. self removeFromSystem: classOrTrait. self should: [self materialized] raise: FLClassNotFound.! ! !FLGlobalClassSideCluster commentStamp: 'MartinDias 8/1/2011 02:57'! I am a cluster for those Metaclasses and ClassTrait who are not stored in detail.! !FLGlobalClassSideCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 12:29'! materializeInstanceWith: aDecoder ^(self materializeGlobalClassFrom: aDecoder) classSide! ! !FLGlobalClassSideCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 12:27'! serializeInstance: aClassOrTraitClassSide with: anEncoder self serializeGlobalClass: aClassOrTraitClassSide instanceSide on: anEncoder ! ! !FLGlobalCluster commentStamp: 'MartinDias 9/16/2011 14:49'! I am a cluster for objects that are reachables from Smalltalk global dictionary.! !FLGlobalCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 12:24'! serializeGlobalClass: aClass on: anEncoder aClass isObsolete ifTrue: [ FLObsolete signalWithName: aClass name ]. anEncoder encodeString: aClass name ! ! !FLGlobalCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 12:24'! serializeGlobalAssociationKeyed: aSymbol on: anEncoder anEncoder encodeString: aSymbol! ! !FLGlobalCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/21/2013 17:30'! materializeGlobalAssociationFrom: aDecoder | globalName | globalName := aDecoder nextEncodedString asSymbol. ^ aDecoder globalEnvironment associationAt: globalName ifAbsent: [ FLGlobalNotFound signalWithName: globalName ] ! ! !FLGlobalCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 1/5/2012 01:05'! materializeGlobalClassFrom: aDecoder | className | className := aDecoder nextEncodedString asSymbol. ^ aDecoder classNamed: className! ! !FLGlobalCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:38'! clusterBucketIn: aClusterization ^aClusterization globalsBucket ! ! !FLGlobalCompiledMethodCluster commentStamp: ''! I clusterize CompiledMethods that will be obtained on materialization accessing method dictionary of the corresponding class in Smalltalk globals. ! !FLGlobalCompiledMethodCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 3/20/2012 00:38'! materializeInstanceWith: aDecoder | methodClass selector method serializedHash | methodClass := self materializeGlobalClassFrom: aDecoder. (aDecoder nextEncodedByte = 1) ifTrue: [ methodClass := methodClass classSide]. selector := aDecoder nextEncodedString asSymbol. method := methodClass compiledMethodAt: selector ifAbsent: [FLMethodNotFound signalWith: methodClass name and: selector]. serializedHash := aDecoder nextEncodedUint16. method bytecodesHash = serializedHash ifFalse: [FLMethodChanged signalWith: methodClass name and: selector]. ^method! ! !FLGlobalCompiledMethodCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 3/20/2012 00:38'! serializeInstance: aCompiledMethod with: anEncoder | methodClass | methodClass := aCompiledMethod methodClass. self serializeGlobalClass: methodClass instanceSide on: anEncoder. anEncoder encodeByte: (methodClass isClassSide ifTrue: [1] ifFalse: [0]). anEncoder encodeString: aCompiledMethod selector. anEncoder encodeUint16: aCompiledMethod bytecodesHash.! ! !FLGlobalEnvironmentTest commentStamp: 'TorstenBergmann 2/3/2014 23:27'! SUnit tests for global fuel environment! !FLGlobalEnvironmentTest methodsFor: 'tests' stamp: 'MartinDias 2/25/2013 13:21'! testGlobalClass "A class should be global by default. On materialization, the global symbol should be found in the global environment." materializationEnvironment at: #Integer put: FLPerson. self assert: (self resultOfSerializeAndMaterialize: Integer) == FLPerson! ! !FLGlobalEnvironmentTest methodsFor: 'tests' stamp: 'MartinDias 2/25/2013 13:15'! testGlobalMetaclassNotFound "If a class is not defined in the materialization environment, a proper error should be raised." self serialize: Integer class. self should: [ self materialization ] raise: FLClassNotFound description: 'Raise an error since the class is not present in materialization global environment'! ! !FLGlobalEnvironmentTest methodsFor: 'tests' stamp: 'MartinDias 2/25/2013 13:48'! testCompiledMethodChanged "A compiled methods should be serialized as global by default. On materialization, it must be found in the global environment, and the bytecodes hash must be the same. Else, raise a proper error." | classA classB | classA := self newClass duringTestCompileSilently: 'm ^ 42'; yourself. classB := self newClass duringTestCompileSilently: 'm ^ [ 42 ]'; yourself. materializationEnvironment at: classA name put: classB. self serialize: classA >> #m. self should: [ self materialization ] raise: FLMethodChanged description: 'Serialized and materialized methods should have the same bytecodes.'! ! !FLGlobalEnvironmentTest methodsFor: 'tests' stamp: 'MartinDias 2/25/2013 13:51'! testClassSideCompiledMethod "Any class-side compiled method should be serialized as global by default. On materialization, it should be found in the global environment, and the bytecodes hash must be the same." | classA classB | classA := self newClass. classA class duringTestCompileSilently: 'm ^ 42'. classB := self newClass. classB class duringTestCompileSilently: 'm ^ 42 '. self assert: (classA class >> #m) bytecodesHash = (classB class >> #m) bytecodesHash. self deny: (classA class >> #m) == (classB class >> #m). materializationEnvironment at: classA name put: classB. self assert: (self resultOfSerializeAndMaterialize: classA class >> #m) == (classB class >> #m)! ! !FLGlobalEnvironmentTest methodsFor: 'tests' stamp: 'MartinDias 2/25/2013 13:17'! testConsiderCustomGlobal "A custom global variable is treated as global if we explicitly specify that on serialization." self analyzer considerGlobal: #FLGlobalVariableForTesting. serializationEnvironment at: #FLGlobalVariableForTesting put: 42. materializationEnvironment at: #FLGlobalVariableForTesting put: 7. self assert: (self resultOfSerializeAndMaterialize: 42) equals: 7! ! !FLGlobalEnvironmentTest methodsFor: 'tests' stamp: 'MartinDias 2/25/2013 13:51'! testCompiledMethod "Any compiled method should be serialized as global by default. On materialization, it should be found in the global environment, and the bytecodes hash must be the same." | classA classB | classA := self newClass duringTestCompileSilently: 'm ^ 42'; yourself. classB := self newClass duringTestCompileSilently: 'm ^ 42 '; yourself. self assert: (classA >> #m) bytecodesHash = (classB >> #m) bytecodesHash. self deny: (classA >> #m) == (classB >> #m). materializationEnvironment at: classA name put: classB. self assert: (self resultOfSerializeAndMaterialize: classA >> #m) == (classB >> #m)! ! !FLGlobalEnvironmentTest methodsFor: 'tests' stamp: 'MartinDias 2/25/2013 13:13'! testConsiderCustomGlobalNotFound "A custom global variable is treated as global if we explicitly specify that on serialization. Then, if the variable is not defined in the materialization environment, a error should be raised." self analyzer considerGlobal: #FLGlobalVariableForTesting. serializationEnvironment at: #FLGlobalVariableForTesting put: 42. self serialize: 42. self should: [ self materialization ] raise: FLGlobalNotFound description: 'Raise an error since the variable is not present in materialization global environment'! ! !FLGlobalEnvironmentTest methodsFor: 'tests' stamp: 'MartinDias 2/25/2013 13:16'! testDontConsiderCustomGlobal "A custom global variable is not treated as global unless we explicitly specify during serialization." | anObject | anObject := Object new. serializationEnvironment at: #FLGlobalVariableForTesting put: anObject. materializationEnvironment at: #FLGlobalVariableForTesting put: anObject; at: #Object put: Object. self deny: (self analyzer globalSymbols includes: #FLGlobalVariableForTesting). self deny: (self resultOfSerializeAndMaterialize: anObject) == anObject! ! !FLGlobalEnvironmentTest methodsFor: 'tests' stamp: 'MartinDias 2/25/2013 13:15'! testGlobalClassNotFound "If a class is not defined in the materialization environment, a proper error should be raised." self serialize: Integer. self should: [ self materialization ] raise: FLClassNotFound description: 'Raise an error since the class is not present in materialization global environment'! ! !FLGlobalEnvironmentTest methodsFor: 'running' stamp: 'MartinDias 2/24/2013 19:46'! setUp super setUp. serializationEnvironment := Dictionary new. materializationEnvironment := Dictionary new. self analyzer globalEnvironment: serializationEnvironment. self materializer globalEnvironment: materializationEnvironment.! ! !FLGlobalEnvironmentTest methodsFor: 'tests' stamp: 'MartinDias 2/25/2013 13:21'! testGlobalMetaclass "A metaclass should be global by default. On materialization, the global symbol should be found in the global environment." materializationEnvironment at: #Integer put: FLPerson. self assert: (self resultOfSerializeAndMaterialize: Integer class) == FLPerson class! ! !FLGlobalNotFound commentStamp: 'MartinDias 12/16/2011 01:16'! I represent an error produced during materialization when a serialized global name doesn't exist (at Smalltalk globals).! !FLGlobalNotFound class methodsFor: 'signaling' stamp: 'MartinDias 3/20/2012 12:06'! signalWithName: aName ^ self signal: 'Global named ', aName printString, ' not found.'! ! !FLGlobalSendCluster commentStamp: 'MarianoMartinezPeck 10/23/2011 14:39'! I clusterize objects that will be obtained on materialization via a message send to a global object. Explained with an example: Suppose we have a special instance of User that represents the admin user, and it is a unique instance in the image. In case the admin user is referenced in our graph, we want to treat that object as a global. We can do that in this way: User >> fuelAccept: aVisitor ^self == User admin ifTrue: [aVisitor visitGlobalSend: self] ifFalse: [super fuelAccept: aVisitor] User >> fuelGlobalName ^#User User >> fuelSelector ^#admin So what will happen is that during serialization, the admin user won't be completly serialized (with all its intance variables) but instead its global name and selector are stored. Then, at materialization time, Fuel will send the selector #admin to the class User, and use what that answers as the admin user of the materialized graph. We test this feature in FLGlobalSendSerializationTest.! !FLGlobalSendCluster methodsFor: 'initialize-release' stamp: 'MarianoMartinezPeck 11/17/2012 12:49'! initializeAnalyzing super initializeAnalyzing. globalSends := IdentityDictionary new.! ! !FLGlobalSendCluster methodsFor: 'mapping' stamp: 'MartinDias 1/10/2012 02:53'! add: anObject name: globalName selector: selector traceWith: anAnalysis self add: anObject traceWith: anAnalysis. globalSends at: anObject ifAbsentPut: [ Association key: globalName value: selector ]! ! !FLGlobalSendCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/20/2013 20:54'! serializeInstance: anObject with: anEncoder | globalSend | globalSend := globalSends at: anObject. self serializeGlobalAssociationKeyed: globalSend key on: anEncoder. anEncoder encodeString: globalSend value. ! ! !FLGlobalSendCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/20/2013 20:54'! materializeInstanceWith: aDecoder | global selector | global := (self materializeGlobalAssociationFrom: aDecoder) value. selector := aDecoder nextEncodedString asSymbol. ^ global perform: selector! ! !FLGlobalSendMock commentStamp: 'TorstenBergmann 2/3/2014 23:21'! A mock for a global send! !FLGlobalSendMock methodsFor: 'comparing' stamp: 'MartinDias 9/15/2011 02:58'! hash "Answer an integer value that is related to the identity of the receiver." ^ contents hash! ! !FLGlobalSendMock methodsFor: 'comparing' stamp: 'MartinDias 9/15/2011 02:58'! = anObject "Answer whether the receiver and anObject represent the same object." self == anObject ifTrue: [ ^ true ]. self class = anObject class ifFalse: [ ^ false ]. ^ contents = anObject contents! ! !FLGlobalSendMock methodsFor: 'printing' stamp: 'MartinDias 9/15/2011 02:59'! printOn: aStream "Append a sequence of characters to aStream that identify the receiver." super printOn: aStream. aStream nextPutAll: ' contents: '; print: contents! ! !FLGlobalSendMock methodsFor: 'accessing' stamp: 'MartinDias 9/15/2011 02:58'! contents: anObject contents := anObject! ! !FLGlobalSendMock methodsFor: 'serialization' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitGlobalSend: self name: #FLGlobalSendMock selector: #newInstanceToMaterialize! ! !FLGlobalSendMock methodsFor: 'accessing' stamp: 'MartinDias 9/15/2011 02:58'! contents ^ contents! ! !FLGlobalSendMock methodsFor: 'initialization' stamp: 'MartinDias 9/15/2011 02:56'! initializeWith: aByteSymbol super initialize. contents := aByteSymbol ! ! !FLGlobalSendMock class methodsFor: 'instance creation' stamp: 'MartinDias 9/15/2011 02:56'! newWith: aByteSymbol ^self basicNew initializeWith: aByteSymbol; yourself! ! !FLGlobalSendMock class methodsFor: 'instance creation' stamp: 'MartinDias 9/15/2011 02:57'! newInstanceToMaterialize ^self newWith: #materializing! ! !FLGlobalSendMock class methodsFor: 'instance creation' stamp: 'MartinDias 9/15/2011 02:55'! newInstanceToSerialize ^self newWith: #serializing! ! !FLGlobalSendNotPresentMock commentStamp: 'TorstenBergmann 2/3/2014 23:22'! A test mock where a global send is not present! !FLGlobalSendNotPresentMock methodsFor: 'serialization' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitGlobalSend: self name: #FLKeyNotPresentInSmalltalks selector: #someSelector! ! !FLGlobalSendSerializationTest commentStamp: 'TorstenBergmann 2/3/2014 23:28'! SUnit tests for fuel serialization of global sends! !FLGlobalSendSerializationTest methodsFor: 'tests' stamp: 'MartinDias 3/20/2012 14:11'! testGlobalNotFound self should: [ self resultOfSerializeAndMaterialize: FLGlobalSendNotPresentMock new ] raise: FLGlobalNotFound whoseDescriptionIncludes: #FLKeyNotPresentInSmalltalks description: 'Should raise an error when global name is not present in Smalltalks globals.' ! ! !FLGlobalSendSerializationTest methodsFor: 'tests' stamp: 'MartinDias 2/20/2013 21:40'! testBasic | result | self deny: FLGlobalSendMock newInstanceToSerialize = FLGlobalSendMock newInstanceToMaterialize. result := self resultOfSerializeAndMaterialize: FLGlobalSendMock newInstanceToSerialize. self assert: FLGlobalSendMock newInstanceToMaterialize = result.! ! !FLGlobalTraitSerializationTest commentStamp: ''! I test the serialization of traits as *external* objects, i.e. the traits has to be present in the image at materialization time.! !FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''! testClassSideMethodNotFoundAfterRemoval "Tests that serializer does not tolarate when the method was removed between serialization and materialization" | classOrTrait | classOrTrait := self newClassOrTrait. classOrTrait classSide duringTestCompileSilently: 'you'. self serialize: classOrTrait classSide >> #you. classOrTrait classSide removeSelectorSilently: #you. self should: [self materialized] raise: FLMethodNotFound whoseDescriptionIncludes: classOrTrait classSide printString description: 'Should raise an error when method is not present.' ! ! !FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''! testClassSideObsolete "Tests that serializer does not serialize as global the class-side of an obsolete class or trait." | classOrTrait | classOrTrait := self newClassOrTrait. self removeFromSystem: classOrTrait. self should: [self serialize: classOrTrait ] raise: FLObsolete whoseDescriptionIncludes: classOrTrait name description: 'Should raise an error when serializing as global an obsolete class or trait.' ! ! !FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''! testObsolete "Tests that serializer does not serialize as global an obsolete class or trait." | classOrTrait | classOrTrait := self newClassOrTrait. self removeFromSystem: classOrTrait. self should: [self serialize: classOrTrait ] raise: FLObsolete whoseDescriptionIncludes: classOrTrait name description: 'Should raise an error when serializing as global an obsolete class or trait.' ! ! !FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''! testClassSidePreservesIdentity "Tests that serialization of the class side preserves identity" self assertSerializationIdentityOf: self newClassOrTrait classSide ! ! !FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''! testClassSideMethodPreservesIdentity "Tests that serialization of a method in the class-side of a class or trait preserves identity" | classOrTrait | classOrTrait := self newClassOrTrait. classOrTrait classSide duringTestCompileSilently: 'you'. self assertSerializationIdentityOf: classOrTrait classSide >> #you! ! !FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''! testNotFoundAfterRename "Tests that serializer does not tolarate when the class was renamed between serialization and materialization" | classOrTrait | classOrTrait := self newClassOrTrait. self serialize: classOrTrait. classOrTrait renameSilently: (classOrTrait name, 'Renamed') asSymbol. self should: [self materialized] raise: FLClassNotFound.! ! !FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''! testPreservesIdentity "Tests that serialization of the class or trait preserves identity" self assertSerializationIdentityOf: self newClassOrTrait! ! !FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''! testMethodNotFoundAfterRemoval "Tests that serializer does not tolarate when the method was removed between serialization and materialization" | classOrTrait | classOrTrait := self newClassOrTrait. classOrTrait duringTestCompileSilently: 'you'. self serialize: classOrTrait >> #you. classOrTrait removeSelectorSilently: #you. self should: [self materialized] raise: FLMethodNotFound whoseDescriptionIncludes: classOrTrait name, '>>#you' description: 'Should raise an error when method is not present.' ! ! !FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''! testMethodPreservesIdentity "Tests that serialization of a method in a class or trait preserves identity" | classOrTrait | classOrTrait := self newClassOrTrait. classOrTrait duringTestCompileSilently: 'you'. self assertSerializationIdentityOf: classOrTrait >> #you! ! !FLGlobalTraitSerializationTest methodsFor: 'tests' stamp: ''! testNotFoundAfterRemoval "Tests that serializer does not tolarate when the class was removed between serialization and materialization" | classOrTrait | classOrTrait := self newClassOrTrait. self serialize: classOrTrait. self removeFromSystem: classOrTrait. self should: [self materialized] raise: FLClassNotFound.! ! !FLGlobalValueCluster commentStamp: 'MartinDias 5/30/2011 01:28'! I am a cluster for known objects that belong to Smalltalk global dictionary. For example, Transcript could be serialized and materialized by me.! !FLGlobalValueCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 12:29'! materializeInstanceWith: aDecoder ^(self materializeGlobalAssociationFrom: aDecoder) value! ! !FLGlobalValueCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/21/2013 17:30'! serializeInstance: anObject with: anEncoder self serializeGlobalAssociationKeyed: (anEncoder globalEnvironment keyAtValue: anObject) on: anEncoder! ! !FLHashedCollectionSerializationTest commentStamp: 'TorstenBergmann 2/3/2014 23:28'! SUnit tests for fuel serialization of hashed collections! !FLHashedCollectionSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 5/20/2011 13:46'! testSetRehash | aSet person1 person2 person3 materializedSet newPerson1 | aSet := Set new. person1 := FLPerson new id: 1. person2 := FLPerson new id: 5. person3 := FLPerson new id: 8. aSet add: person1; add: person2; add: person3. self assert: (aSet includes: person1). self assert: (aSet includes: person2). self assert: (aSet includes: person3). materializedSet := self resultOfSerializeAndMaterialize: aSet. "If Fuel serializes the Set normally, it will copy its internal array just as it is. Hence, the element will be in the same order. But the objects instead may be recreated. SqueakVM assigns an identity hash at creation time (stored in the object header). So, all objects who didn't implement #hash will be finally using #identityHash. I cannot change the identityHash of an object, so I do a test changing the id by hand. Now, let's say that the id of person 1 change to 3 (this would be the same case when Fuel creates new objects and a new identity hash is asigned) . This 3 is not coincidence. It has to be a hash such that: (hash \\ aSet array size) + 1 gives you a position in the array that has a next nil in the array. In this case, the person1 is at position 2 of the array and there is a nil in position 3 and one at 5.. So (3 \\ 5) + 1 = 4. So....Set >> scanFor: will start to search from position 4 and since it will find a nil in 5 it will assume it has to stop searching and that the object is not present. For more details check .Set >> scanFor: " newPerson1 := materializedSet detect: [:each | each id = person1 id]. newPerson1 id: 3. "Fuel rehashes the set at the end. This means, after having materialized the instnaces of the set. In this case, we are chanign the has of the object once it was already been materialzed, so we should simulate the rehash done by Fuel" materializedSet rehash. self assert: (materializedSet includes: newPerson1).! ! !FLHashedCollectionSerializationTest methodsFor: 'tests' stamp: 'MartinDias 10/5/2011 19:23'! testDictionaryRehash | aDictionary person1 person2 person3 materializedDict newPerson1 | aDictionary := Dictionary new. person1 := FLPerson new id: 1. person2 := FLPerson new id: 5. person3 := FLPerson new id: 8. aDictionary at: person1 put: person1; at: person2 put: person2; at: person3 put: person3. self assert: (aDictionary at: person1) = person1. self assert: (aDictionary at: person2) = person2. self assert: (aDictionary at: person3) = person3. materializedDict := self resultOfSerializeAndMaterialize: aDictionary. "If Fuel serializes the Dictionary normally, it will copy its internal array just as it is. Hence, the element will be in the same order. But the objects instead may be recreated. SqueakVM assigns an identity hash at creation time (stored in the object header). So, all objects who didn't implement #hash will be finally using #identityHash. I cannot change the identityHash of an object, so I do a test changing the id by hand. Now, let's say that the id of person 1 change to 3 (this would be the same case when Fuel creates new objects and a new identity hash is asigned) . This 3 is not coincidence. It has to be a hash such that: (hash \\ aDictionary array size) + 1 gives you a position in the array that has a next nil in the array. In this case, the person1 is at position 2 of the array and there is a nil in position 3 and one at 5.. So (3 \\ 5) + 1 = 4. So....Dictionary >> scanFor: will start to search from position 4 and since it will find a nil in 5 it will assume it has to stop searching and that the object is not present. For more details check .Dictionary >> scanFor: " newPerson1 := materializedDict keys detect: [:each | each id = person1 id]. newPerson1 id: 3. "Fuel rehashes the set at the end. This means, after having materialized the instnaces of the set. In this case, we are chanign the has of the object once it was already been materialzed, so we should simulate the rehash done by Fuel" materializedDict rehash. self assert: (materializedDict includesKey: newPerson1).! ! !FLHeader commentStamp: ''! An instance of FLHeader is serialized together with the orignal object graph to serialize. This header is useful to: 1) Attach additional state or metadata associated to the graph being serialized. 2) Attach pre and post materialization actions! !FLHeader methodsFor: 'initialization' stamp: 'MarianoMartinezPeck 7/28/2012 12:33'! initialize additionalObjects := IdentityDictionary new. preMaterializationActions := OrderedCollection new. postMaterializationActions := OrderedCollection new.! ! !FLHeader methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/28/2012 13:48'! materialization: aMaterialization "This is just set once the materialization had happened" materialization := aMaterialization ! ! !FLHeader methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/28/2012 14:25'! addPostMaterializationAction: aCleanBlockClosure "The closure may (or not) have one parameter and it will be the materialization." aCleanBlockClosure isClean ifFalse: [ self error: 'Post materializaton actions have to be clean closures. For more details see method BlocKClosure >> #isClean' ]. postMaterializationActions add: aCleanBlockClosure ! ! !FLHeader methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/21/2012 16:50'! postMaterializationActions: listOfPostMaterializationActions postMaterializationActions := listOfPostMaterializationActions. ! ! !FLHeader methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/21/2012 16:50'! preMaterializationActions: listOfPreMaterializationActions preMaterializationActions := listOfPreMaterializationActions. ! ! !FLHeader methodsFor: 'testing' stamp: 'MartinDias 2/25/2013 14:55'! isEmpty ^ preMaterializationActions isEmpty and: [ postMaterializationActions isEmpty and: [ additionalObjects isEmpty ] ]! ! !FLHeader methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/28/2012 11:53'! additionalObjectAt: key ^ additionalObjects at: key! ! !FLHeader methodsFor: 'executing' stamp: 'MarianoMartinezPeck 7/28/2012 14:25'! executePreMaterializationActions preMaterializationActions do: [:each | each value]! ! !FLHeader methodsFor: 'executing' stamp: 'MarianoMartinezPeck 7/28/2012 14:25'! executePostMaterializationActions postMaterializationActions do: [:each | each cull: materialization]! ! !FLHeader methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/28/2012 11:36'! at: key putAdditionalObject: anObject "This is useful if we want to attach objects to a package that will also be serialized. The way they are stored is key-value." additionalObjects at: key put: anObject! ! !FLHeader methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/28/2012 14:24'! addPreMaterializationAction: aCleanBlockClosure aCleanBlockClosure isClean ifFalse: [ self error: 'Pre materializaton actions have to be clean closures. For more details see method BlocKClosure >> #isClean' ]. preMaterializationActions add: aCleanBlockClosure ! ! !FLHeaderSerializationTest commentStamp: 'TorstenBergmann 2/3/2014 23:32'! SUnit tests for header serialization in fuel! !FLHeaderSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 7/28/2012 13:47'! testAdditionalObjects | materialization | self serializer at: #test putAdditionalObject: 'test'. self serializer at: 42 putAdditionalObject: 68. self assertSerializationEqualityOf: 'foo'. self assert: (self materialization additionalObjectAt: #test) equals: 'test'. self assert: (self materialization additionalObjectAt: 42) equals: 68. ! ! !FLHeaderSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 7/28/2012 12:33'! testPreMaterializationActions | aClass | aClass := self newSubclassOf: Object instanceVariableNames: '' classVariableNames: 'ClassVariable ClassVariable2'. aClass class duringTestCompileSilently: 'postLoadMethod ClassVariable := 1'; duringTestCompileSilently: 'postLoadMethod2 ClassVariable := 2'; duringTestCompileSilently: 'classVariable ^ClassVariable '. aClass perform: #postLoadMethod. self assert: (aClass perform: #classVariable) = 1. self serializer addPreMaterializationAction: [ (Smalltalk at: #ClassForTestToBeDeleted1) perform: #postLoadMethod2 ]. self serialize: aClass. self assert: (aClass perform: #classVariable) = 1. self materialized. self assert: (aClass perform: #classVariable) = 2. ! ! !FLHeaderSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 7/28/2012 12:33'! testPostMaterializationActions | aClass | aClass := self newSubclassOf: Object instanceVariableNames: '' classVariableNames: 'ClassVariable ClassVariable2'. aClass class duringTestCompileSilently: 'postLoadMethod ClassVariable := 1'; duringTestCompileSilently: 'postLoadMethod2 ClassVariable := 2'; duringTestCompileSilently: 'classVariable ^ClassVariable '. aClass perform: #postLoadMethod. self assert: (aClass perform: #classVariable) = 1. self serializer addPostMaterializationAction: [ (Smalltalk at: #ClassForTestToBeDeleted1) perform: #postLoadMethod2 ]. self serialize: aClass. self assert: (aClass perform: #classVariable) = 1. self materialized. self assert: (aClass perform: #classVariable) = 2. ! ! !FLHeaderSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 7/28/2012 15:04'! testJustMaterializeHeader self serializer at: #test putAdditionalObject: 'test'. self serializer at: 42 putAdditionalObject: 68. self serialize: 'foo'. self assert: (self materializationHeader additionalObjectAt: #test) equals: 'test'. self assert: (self materializationHeader additionalObjectAt: 42) equals: 68. ! ! !FLHookPrimitiveCluster commentStamp: ''! I am a cluster for simple objects who define serialization and materialization via hooks on their classes.! !FLHookPrimitiveCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:42'! clusterMaterializeStepWith: aMaterialization super clusterMaterializeStepWith: aMaterialization. theClass := aMaterialization decoder nextEncodedReference. ! ! !FLHookPrimitiveCluster methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 4/23/2012 16:33'! clusterReferencesDo: aBlock aBlock value: theClass! ! !FLHookPrimitiveCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:41'! clusterSerializeStepWith: aSerialization super clusterSerializeStepWith: aSerialization. aSerialization encoder encodeReferenceTo: theClass. ! ! !FLHookPrimitiveCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 10:48'! serializeInstance: anObject with: anEncoder anObject serializeOn: anEncoder! ! !FLHookPrimitiveCluster methodsFor: 'initialize-release' stamp: 'MartinDias 2/25/2013 14:47'! initializeAnalyzing: aClass self initializeAnalyzing. theClass := aClass! ! !FLHookPrimitiveCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 10:47'! materializeInstanceWith: aDecoder ^theClass materializeFrom: aDecoder! ! !FLHookPrimitiveCluster methodsFor: 'printing' stamp: 'MartinDias 5/11/2012 19:23'! printNameOn: aStream "Append to the argument, aStream, a sequence of characters that identifies the receiver." super printNameOn: aStream. aStream nextPut: $[. theClass printOn: aStream. aStream nextPut: $].! ! !FLHookPrimitiveCluster class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 4/23/2012 16:34'! newAnalyzing: aClass ^ self basicNew initializeAnalyzing: aClass; yourself.! ! !FLHookedSubstitutionTest commentStamp: 'TorstenBergmann 2/3/2014 23:32'! SUnit tests for hooked serialization using fuel! !FLHookedSubstitutionTest methodsFor: 'tests' stamp: 'MartinDias 5/9/2012 01:17'! testSubstituteByItself | aRecursiveClass result | aRecursiveClass := (self newSubclassOf: Object instanceVariableNames: '' classVariableNames: '') duringTestCompileSilently: 'fuelAccept: aMapper ^aMapper visitSubstitution: self by: self onRecursionDo: [super fuelAccept: aMapper]'; yourself. result := self resultOfSerializeAndMaterialize: aRecursiveClass new. "self flag: #todo." "Should test that it doesn't enter in loop."! ! !FLHookedSubstitutionTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 19:12'! testProxyByTargetInsideObjectAndAnalisysIsPropagated | aProxyClass result original pair pairRoot | aProxyClass := (self newSubclassOf: Object instanceVariableNames: 'target' classVariableNames: '') duringTestCompileSilently: 'target: x target := x'; duringTestCompileSilently: 'fuelAccept: aVisitor ^aVisitor visitSubstitution: self by: target'; yourself. pair := FLPair new. pair left: 6. pair right: 'foo'. original := aProxyClass new target: pair; yourself. pairRoot := FLPair new left: original; yourself. result := self resultOfSerializeAndMaterialize: pairRoot. self assert: result left left = 6. self assert: result left right = 'foo'. self assert: result right isNil. ! ! !FLHookedSubstitutionTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 19:12'! testObjectByProxyThatBecomesItsContent "Tests a substitution of an object by a proxy that becomes another object on materialization." | aProxyClass result | aProxyClass := (self newSubclassOf: Object instanceVariableNames: 'someState' classVariableNames: '') duringTestCompileSilently: 'initialize someState := 5@1'; duringTestCompileSilently: 'fuelAccept: aVisitor ^aVisitor visitSubstitution: self by: (FLProxyThatBecomesItsContent newWith: someState)'; yourself. result := self resultOfSerializeAndMaterialize: aProxyClass new. self assert: 5@1 = result.! ! !FLHookedSubstitutionTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 19:12'! testTransientByNil | result aClassOfTransientObjects | aClassOfTransientObjects := self newClass duringTestCompileSilently: 'fuelAccept: aVisitor ^aVisitor visitSubstitution: self by: nil'; yourself. result := self resultOfSerializeAndMaterialize: aClassOfTransientObjects new. self assert: result isNil.! ! !FLHookedSubstitutionTest methodsFor: 'tests' stamp: 'MartinDias 5/9/2012 01:00'! testAvoidRecursion | aClass result original | original := FLClassWithRecursiveSubstitution new index: 1. result := self resultOfSerializeAndMaterialize: original. self assert: result index = 2! ! !FLHookedSubstitutionTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 19:12'! testProxyByTarget | aProxyClass result original | aProxyClass := (self newSubclassOf: Object instanceVariableNames: 'target' classVariableNames: '') duringTestCompileSilently: 'target: x target := x'; duringTestCompileSilently: 'fuelAccept: aVisitor ^aVisitor visitSubstitution: self by: target'; yourself. original := aProxyClass new target: 5; yourself. result := self resultOfSerializeAndMaterialize: original. self assert: 5 = result.! ! !FLHookedSubstitutionTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 19:12'! testProxyByTargetAnalisysIsPropagated | aProxyClass result pair | self flag: #todo. "I don't understand what are we testing here." aProxyClass := (self newSubclassOf: Object instanceVariableNames: 'target' classVariableNames: '') duringTestCompileSilently: 'target: x target := x'; duringTestCompileSilently: 'fuelAccept: aVisitor ^aVisitor visitSubstitution: self by: target'; yourself. pair := FLPair new. pair left: 6. pair right: 'foo'. aProxyClass new target: pair; yourself. result := self resultOfSerializeAndMaterialize: pair. self assert: result left = 6. self assert: result right = 'foo'.! ! !FLHookedSubstitutionTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 19:12'! testClassWithCachedValueByNil | aClassWithCachedValue result original | aClassWithCachedValue := (self newSubclassOf: Object instanceVariableNames: 'cache' classVariableNames: '') duringTestCompileSilently: 'cache ^cache'; duringTestCompileSilently: 'cache: x cache := x'; duringTestCompileSilently: ' fuelAccept: aVisitor ^cache ifNil: [ super fuelAccept: aVisitor ] ifNotNil: [ aVisitor visitSubstitution: self by: (self copy cache: nil)]'; yourself. original := aClassWithCachedValue new cache: 5; yourself. result := self resultOfSerializeAndMaterialize: original. self assert: result cache isNil.! ! !FLHookedSubstitutionTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 19:12'! testProxyInsideObjectByTarget | aProxyClass result original pair | aProxyClass := (self newSubclassOf: Object instanceVariableNames: 'target' classVariableNames: '') duringTestCompileSilently: 'target: x target := x'; duringTestCompileSilently: 'fuelAccept: aVisitor ^aVisitor visitSubstitution: self by: target'; yourself. original := aProxyClass new target: 5; yourself. pair := FLPair new. pair left: original. pair right: 'foo'. result := self resultOfSerializeAndMaterialize: pair. self assert: result left = 5. self assert: result right = 'foo'. ! ! !FLIgnoredVariablesTest commentStamp: 'TorstenBergmann 2/3/2014 23:26'! SUnit tests for serialization with ignored variables! !FLIgnoredVariablesTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 12:46'! testAllVariablesIgnored | anObject result aClass | aClass := self newClassWithInstanceVariableNames: 'a b'. aClass class duringTestCompileSilently: 'fuelIgnoredInstanceVariableNames ^#(a b)'. anObject := aClass new instVarAt: 1 put: $A; instVarAt: 2 put: $B; yourself. result := self resultOfSerializeAndMaterialize: anObject. self assert: (result instVarAt: 1) isNil. self assert: (result instVarAt: 2) isNil. ! ! !FLIgnoredVariablesTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 12:46'! testTwoIgnoredVariables | anObject result aClass | aClass := self newClassWithInstanceVariableNames: 'a b c'. aClass class duringTestCompileSilently: 'fuelIgnoredInstanceVariableNames ^#(a c)'. anObject := aClass new instVarAt: 1 put: $A; instVarAt: 2 put: $B; instVarAt: 3 put: $C; yourself. result := self resultOfSerializeAndMaterialize: anObject. self assert: nil = (result instVarAt: 1). self assert: $B = (result instVarAt: 2). self assert: nil = (result instVarAt: 3).! ! !FLIgnoredVariablesTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 12:07'! testIgnoredValueIsNotMaterialized | anObject materializedInstances aClass | aClass := self newClassWithInstanceVariableNames: 'a'. aClass class duringTestCompileSilently: 'fuelIgnoredInstanceVariableNames ^#(a)'. anObject := aClass new instVarAt: 1 put: #A; yourself. self serialize: anObject. materializedInstances := self materializedObjects. self deny: (materializedInstances includes: #A) ! ! !FLIgnoredVariablesTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 12:46'! testOneIgnoredVariable | anObject result aClass | aClass := self newClassWithInstanceVariableNames: 'a b c'. aClass class duringTestCompileSilently: 'fuelIgnoredInstanceVariableNames ^#(b)'. anObject := aClass new instVarAt: 1 put: $A; instVarAt: 2 put: $B; instVarAt: 3 put: $C; yourself. result := self resultOfSerializeAndMaterialize: anObject. self assert: $A = (result instVarAt: 1). self assert: nil = (result instVarAt: 2). self assert: $C = (result instVarAt: 3)! ! !FLInMemoryBasicSerializationTest commentStamp: 'TorstenBergmann 2/3/2014 23:25'! SUnit tests for basic in memory serialization! !FLInMemoryBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 3/28/2012 22:56'! testStringGlobalsAndClosure | materialized | materialized := self resultOfSerializeAndMaterialize: (Array with: 'a string' with: Transcript with: [ Transcript show: 'a string' ]). self assert: materialized first = 'a string'. self assert: materialized second == Transcript! ! !FLInMemoryBasicSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/28/2012 22:46'! serialize: anObject byteArray := FLSerializer serializeToByteArray: anObject! ! !FLInMemoryBasicSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/28/2012 22:48'! materialized ^ FLMaterializer materializeFromByteArray: byteArray. ! ! !FLInMemoryBasicSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/28/2012 22:48'! materialization self error: 'Disabled, instead use #materialized.' ! ! !FLInMemoryBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 3/28/2012 22:58'! testConsiderCustomGlobal "Since FLSerializer class >> serializeToByteArray: does not allow customizing serialization, this test is disabled."! ! !FLInMemoryBasicSerializationTest class methodsFor: 'testing' stamp: 'MartinDias 3/28/2012 22:49'! shouldInheritSelectors ^ true! ! !FLIndexStream commentStamp: ''! I am an optimized stream for writing and reading *indexes*, i.e. positive integers with a known upper bound. ! !FLIndexStream methodsFor: 'accessing' stamp: 'MartinDias 12/30/2011 15:25'! nextIndex | s | s := 0. 1 to: digits do: [:i | s := (s bitShift: 8) bitOr: stream next]. ^ s! ! !FLIndexStream methodsFor: 'accessing' stamp: 'MartinDias 12/30/2011 15:21'! nextIndexPut: v 1 to: digits do: [:i | stream nextPut: (v digitAt: digits + 1 - i)] ! ! !FLIndexStream methodsFor: 'initialize-release' stamp: 'MartinDias 12/30/2011 14:28'! initializeOn: aStream digits: aNumberOfDigits self initialize. stream := aStream. digits := aNumberOfDigits! ! !FLIndexStream class methodsFor: 'instance creation' stamp: 'MartinDias 12/30/2011 14:33'! on: aStream digits: aNumberOfDigits ^ self basicNew initializeOn: aStream digits: aNumberOfDigits; yourself. ! ! !FLIndexStreamTest commentStamp: 'TorstenBergmann 2/3/2014 23:22'! SUnit tests for index streams! !FLIndexStreamTest methodsFor: 'running' stamp: 'MartinDias 12/30/2011 15:29'! indexStreamOn: aStream digits: aNumberOfDigits ^ FLIndexStream on: aStream digits: aNumberOfDigits! ! !FLIndexStreamTest methodsFor: 'tests' stamp: 'MartinDias 12/30/2011 15:28'! testNextIndex | indexes indexStream targetStream | indexes := #(0 1 128 255). targetStream := #() writeStream. indexStream := self indexStreamOn: targetStream digits: 1. indexes do: [:x | indexStream nextIndexPut: x ]. indexStream := self indexStreamOn: targetStream contents readStream digits: 1. indexes do: [:x | self assert: indexStream nextIndex = x ].! ! !FLIndexStreamTest methodsFor: 'tests' stamp: 'MartinDias 12/30/2011 15:28'! testNextIndexPut | indexStream targetStream | targetStream := #() writeStream. indexStream := self indexStreamOn: targetStream digits: 1. indexStream nextIndexPut: 0. indexStream nextIndexPut: 1.! ! !FLIndexStreamTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testCreation self indexStreamOn: #() writeStream digits: 2! ! !FLIteratingCluster commentStamp: ''! I am a template class whose algorithm for serialize a collection of objects consists on delegate the serialization of each individual object to the subclass.! !FLIteratingCluster methodsFor: 'analyzing' stamp: 'MaxLeske 5/3/2013 15:22'! addReferenceFrom: anObject to: anotherObject | list | list := self references at: anObject ifAbsent: [ nil ]. list ifNil: [ self references at: anObject put: (list := OrderedCollection new) ]. list add: anotherObject! ! !FLIteratingCluster methodsFor: 'accessing' stamp: 'MaxLeske 5/3/2013 08:36'! references ^ references ifNil: [ references := FLLargeIdentityDictionary new ]! ! !FLIteratingCluster methodsFor: 'accessing' stamp: 'MartinDias 8/29/2011 00:59'! objects ^objects! ! !FLIteratingCluster methodsFor: 'initialize-release' stamp: 'MartinDias 1/8/2012 14:32'! initializeAnalyzing super initializeAnalyzing. objects := self newAnalyzingCollection.! ! !FLIteratingCluster methodsFor: 'analyzing' stamp: 'MartinDias 8/29/2011 00:56'! referencesOf: anObject do: aBlock "Evaluate a block with each object referenced by anObject"! ! !FLIteratingCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:41'! clusterSerializeStepWith: aSerialization super clusterSerializeStepWith: aSerialization. aSerialization encoder encodePositiveInteger: objects size.! ! !FLIteratingCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 13:37'! serializeInstance: anObject with: anEncoder "Hook method that each subclass should customize for its special way of serializing"! ! !FLIteratingCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeInstanceWith: aDecoder "Hook method that each subclass should customize for its special way of materializing" ^ self subclassResponsibility! ! !FLIteratingCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:42'! clusterMaterializeStepWith: aMaterialization super clusterMaterializeStepWith: aMaterialization. objects := Array new: aMaterialization decoder nextEncodedPositiveInteger! ! !FLIteratingCluster methodsFor: 'analyzing' stamp: 'MaxLeske 5/4/2013 09:46'! add: anObject traceWith: aAnalysis "Add an object to the cluster and trace references." objects addIfNotPresent: anObject ifPresentDo: [ ^ self ]. self referencesOf: anObject do: [ :aChild || actual | actual := aChild fuelReplacement. self addReferenceFrom: anObject to: actual. aAnalysis trace: actual ]! ! !FLIteratingCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/17/2012 03:01'! materializeInstancesStepWith: aDecoder 1 to: objects size do: [ :index | objects at: index put: (self materializeInstanceWith: aDecoder) ].! ! !FLIteratingCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 8/29/2011 01:22'! registerIndexesOn: aDictionary self objects do: [ :instance | aDictionary at: instance put: aDictionary size + 1 ].! ! !FLIteratingCluster methodsFor: 'printing' stamp: 'MartinDias 8/29/2011 00:52'! printOn: aStream self printNameOn: aStream. aStream nextPutAll: '->'. objects printElementsOn: aStream! ! !FLIteratingCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/17/2012 03:03'! serializeInstancesStepWith: anEncoder objects do: [ :instance | self serializeInstance: instance with: anEncoder ]! ! !FLIteratingCluster methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 4/20/2012 23:31'! newAnalyzingCollection "Answer a collection for the objects that correspond to this cluster." ^ FLLargeIdentitySet new! ! !FLIteratingCluster methodsFor: 'analyzing' stamp: 'MaxLeske 5/3/2013 10:48'! addReferencesFrom: anObject to: aCollection aCollection do: [ :ref | self addReferenceFrom: anObject to: ref ]! ! !FLIteratingCluster methodsFor: 'printing' stamp: 'MartinDias 8/29/2011 01:16'! printNameOn: aStream super printOn: aStream! ! !FLLargeIdentityDictionary commentStamp: ''! I am an IdentityDictionary optimized for including a large number of elements.! !FLLargeIdentityDictionary methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 1/12/2012 18:00'! at: key ifPresent: presentBlock ifAbsent: absentBlock | hash | (keys at: (hash := key largeIdentityHash + 1)) ifNotNil: [ :keyList | 1 to: (tallies at: hash) do: [ :index | (keyList at: index) == key ifTrue: [ ^ presentBlock value: ((values at: hash) at: index) ] ] ]. ^absentBlock value! ! !FLLargeIdentityDictionary methodsFor: 'accessing' stamp: 'ul 3/24/2010 21:57'! keys ^Array new: tally streamContents: [ :stream | self keysDo: [ :key | stream nextPut: key ] ]! ! !FLLargeIdentityDictionary methodsFor: 'enumerating' stamp: 'ul 3/24/2010 21:45'! keysDo: aBlock tally = 0 ifTrue: [ ^self ]. 1 to: 4096 do: [ :arrayIndex | | keyArray | keyArray := keys at: arrayIndex. 1 to: (tallies at: arrayIndex) do: [ :index | aBlock value: (keyArray at: index) ] ]! ! !FLLargeIdentityDictionary methodsFor: 'initialization' stamp: 'ul 12/18/2011 11:31'! initialize super initialize. keys := Array new: 4096. values := Array new: 4096! ! !FLLargeIdentityDictionary methodsFor: 'removing' stamp: 'ul 12/18/2011 11:22'! removeKey: key ifAbsent: aBlock | hash | (keys at: (hash := key largeIdentityHash + 1)) ifNotNil: [ :keyList | | size | 1 to: (size := tallies at: hash) do: [ :index | (keyList at: index) == key ifTrue: [ | valueList | keyList at: index put: (keyList at: size); at: size put: nil. (valueList := values at: hash) at: index put: (valueList at: size); at: size put: nil. (size := size - 1) < (keyList size // 4) ifTrue: [ | newList | newList := Array new: size * 2. newList replaceFrom: 1 to: size with: keyList startingAt: 1. keys at: hash put: newList. newList := Array new: size * 2. newList replaceFrom: 1 to: size with: valueList startingAt: 1. values at: hash put: newList ]. tallies at: hash put: size. tally := tally - 1. ^key ] ] ]. ^aBlock value! ! !FLLargeIdentityDictionary methodsFor: 'accessing' stamp: 'ul 12/18/2011 11:21'! at: key put: value | hash | (keys at: (hash := key largeIdentityHash + 1)) ifNil: [ keys at: hash put: (Array with: key). values at: hash put: (Array with: value). tallies at: hash put: 1. tally := tally + 1 ] ifNotNil: [ :keyList | | newIndex | 1 to: (tallies at: hash) do: [ :index | (keyList at: index) == key ifTrue: [ ^(values at: hash) at: index put: value ] ]. tally := tally + 1. keyList size < (newIndex := (tallies at: hash) + 1) ifFalse: [ keyList at: newIndex put: key. (values at: hash) at: newIndex put: value ] ifTrue: [ | newList | (newList := Array new: keyList size * 2) replaceFrom: 1 to: keyList size with: keyList startingAt: 1; at: newIndex put: key. keys at: hash put: newList. (newList := Array new: keyList size * 2) replaceFrom: 1 to: keyList size with: (values at: hash) startingAt: 1; at: newIndex put: value. values at: hash put: newList ]. tallies at: hash put: newIndex ]. ^value! ! !FLLargeIdentityDictionary methodsFor: 'accessing' stamp: 'ul 12/18/2011 11:21'! at: key | hash | (keys at: (hash := key largeIdentityHash + 1)) ifNotNil: [ :keyList | 1 to: (tallies at: hash) do: [ :index | (keyList at: index) == key ifTrue: [ ^(values at: hash) at: index ] ] ]. self errorKeyNotFound: key! ! !FLLargeIdentityDictionary methodsFor: 'enumerating' stamp: 'ul 3/24/2010 21:47'! do: aBlock ^self valuesDo: aBlock! ! !FLLargeIdentityDictionary methodsFor: 'accessing' stamp: 'ul 12/18/2011 11:22'! at: key ifAbsent: aBlock | hash | (keys at: (hash := key largeIdentityHash + 1)) ifNotNil: [ :keyList | 1 to: (tallies at: hash) do: [ :index | (keyList at: index) == key ifTrue: [ ^(values at: hash) at: index ] ] ]. ^aBlock value! ! !FLLargeIdentityDictionary methodsFor: 'copying' stamp: 'ul 12/18/2011 11:35'! postCopy super postCopy. keys := keys copy. values := values copy. 1 to: 4096 do: [ :index | (keys at: index) ifNotNil: [ :list | keys at: index put: list copy. values at: index put: (values at: index) copy ] ]! ! !FLLargeIdentityDictionary methodsFor: 'private' stamp: 'MarianoMartinezPeck 12/20/2011 10:29'! errorKeyNotFound: aKey KeyNotFound signalFor: aKey! ! !FLLargeIdentityDictionary methodsFor: 'enumerating' stamp: 'ul 3/24/2010 21:46'! valuesDo: aBlock tally = 0 ifTrue: [ ^self ]. 1 to: 4096 do: [ :arrayIndex | | valueArray | valueArray := values at: arrayIndex. 1 to: (tallies at: arrayIndex) do: [ :index | aBlock value: (valueArray at: index) ] ]! ! !FLLargeIdentityDictionary methodsFor: 'enumerating' stamp: 'ul 3/24/2010 21:35'! keysAndValuesDo: aBlock tally = 0 ifTrue: [ ^self ]. 1 to: 4096 do: [ :arrayIndex | | keyArray valueArray | keyArray := keys at: arrayIndex. valueArray := values at: arrayIndex. 1 to: (tallies at: arrayIndex) do: [ :index | aBlock value: (keyArray at: index) value: (valueArray at: index) ] ]! ! !FLLargeIdentityDictionary methodsFor: 'testing' stamp: 'MarianoMartinezPekc 1/10/2012 18:57'! includesKey: key | hash | ^(keys at: (hash := key largeIdentityHash + 1)) ifNil: [ false ] ifNotNil: [ :keyList | key ifNotNil: [ keyList fuelPointsTo: key ] ifNil: [ 1 to: (tallies at: hash) do: [ :index | (keyList at: index) == key ifTrue: [ ^true ] ]. false ] ]! ! !FLLargeIdentityDictionary methodsFor: 'accessing' stamp: 'ul 3/24/2010 21:57'! values ^Array new: tally streamContents: [ :stream | self valuesDo: [ :value | stream nextPut: value ] ]! ! !FLLargeIdentityHashedCollection commentStamp: ''! I share behavior for special HashedCollections that are optimized for including a large number of elements.! !FLLargeIdentityHashedCollection methodsFor: 'copying' stamp: 'ul 12/18/2011 11:35'! postCopy tallies := tallies copy ! ! !FLLargeIdentityHashedCollection methodsFor: 'initialization' stamp: 'ul 12/18/2011 11:31'! initialize tally := 0. tallies := Array new: 4096 withAll: 0! ! !FLLargeIdentityHashedCollection methodsFor: 'accessing' stamp: 'ul 12/18/2011 11:33'! size ^tally! ! !FLLargeIdentityHashedCollection class methodsFor: 'comparing' stamp: 'ul 12/18/2011 11:24'! permuteHash: anInteger "Return an integer between 1 and 4096 when the argument is between 1 and 4096." ^PermutationMap at: anInteger! ! !FLLargeIdentityHashedCollection class methodsFor: 'initialize-release' stamp: 'MarianoMartinezPeck 5/28/2012 01:16'! initialize | rng | rng := Random seed: 664399324. PermutationMap := (0 to: 4095) asArray shuffleBy: rng! ! !FLLargeIdentitySet commentStamp: 'HenrikSperreJohansen 12/16/2011 12:55'! A LargeIdentitySet is an IdentitySet for large collections. Rather than using linear probing, it takes advantage of the fact that identityHash (on a classic, 32bit VM) in Pharo only has 4096 unique values, using a bucket for each of those. It will still work if hash range changes (ie buckets are chosen mod 4096), but the potential gain will be lower the more diverse the hash space is. With linear probing you risk an array looking like this: Index: Hash: 1 X 2 X 3 X 4 4 5 5 6 4 7 4 8 7 9 6 10 X While with buckets the same dataset looks: Index: Hash: 1 X 2 X 3 X 4 [4, 4, 4] 5 5 6 6 7 7 8 X 9 X 10 X So includes: can generally be done faster (also sped up byusing a special primitive), and removal of objects does not have to do extensive cleanup if object was part of a chain.! !FLLargeIdentitySet methodsFor: 'initialization' stamp: 'ul 12/18/2011 11:31'! initialize super initialize. array := Array new: 4096. includesNil := false! ! !FLLargeIdentitySet methodsFor: 'enumerating' stamp: 'ul 3/23/2010 08:35'! do: aBlock tally = 0 ifTrue: [ ^self ]. includesNil ifTrue: [ aBlock value: nil ]. 1 to: 4096 do: [ :arrayIndex | | subArray | subArray := array at: arrayIndex. 1 to: (tallies at: arrayIndex) do: [ :index | aBlock value: (subArray at: index) ] ]! ! !FLLargeIdentitySet methodsFor: 'adding' stamp: 'MarianoMartinezPekc 1/10/2012 18:57'! add: anObject | hash | anObject ifNil: [ includesNil ifFalse: [ includesNil := true. tally := tally + 1 ]. ^anObject ]. (array at: (hash := anObject largeIdentityHash + 1)) ifNil: [ array at: hash put: (Array with: anObject). tallies at: hash put: 1. tally := tally + 1 ] ifNotNil: [ :list | (list fuelPointsTo: anObject) ifFalse: [ | newIndex | tally := tally + 1. list size < (newIndex := (tallies at: hash) + 1) ifFalse: [ list at: newIndex put: anObject ] ifTrue: [ | newList | newList := Array new: list size * 2. newList replaceFrom: 1 to: list size with: list startingAt: 1; at: newIndex put: anObject. array at: hash put: newList ]. tallies at: hash put: newIndex ] ]. ^anObject! ! !FLLargeIdentitySet methodsFor: 'copying' stamp: 'ul 12/18/2011 11:35'! postCopy super postCopy. array := array copy. 1 to: 4096 do: [ :index | (array at: index) ifNotNil: [ :list | array at: index put: list copy ] ]! ! !FLLargeIdentitySet methodsFor: 'removing' stamp: 'MarianoMartinezPekc 1/10/2012 18:57'! remove: anObject ifAbsent: aBlock | list hash size | anObject ifNil: [ includesNil ifTrue: [ includesNil := false. tally := tally - 1. ^anObject ]. ^aBlock value ]. list := (array at: (hash := anObject largeIdentityHash + 1)) ifNil: [ ^aBlock value ]. (list fuelPointsTo: anObject) ifFalse: [ ^aBlock value ]. 1 to: (size := tallies at: hash) do: [ :index | (list at: index) == anObject ifTrue: [ list at: index put: (list at: size); at: size put: nil. (size := size - 1) < (list size // 4) ifTrue: [ | newList | newList := Array new: size * 2. newList replaceFrom: 1 to: size with: list startingAt: 1. array at: hash put: newList ]. tallies at: hash put: size. tally := tally - 1. ^anObject ] ]. ^aBlock value! ! !FLLargeIdentitySet methodsFor: 'adding' stamp: 'MarianoMartinezPekc 1/10/2012 18:57'! addIfNotPresent: anObject ifPresentDo: aBlock | hash | anObject ifNil: [ includesNil ifFalse: [ includesNil := true. tally := tally + 1 ]. ^anObject ]. (array at: (hash := anObject largeIdentityHash + 1)) ifNil: [ array at: hash put: (Array with: anObject). tallies at: hash put: 1. tally := tally + 1 ] ifNotNil: [ :list | (list fuelPointsTo: anObject) ifTrue: [ aBlock value] ifFalse: [ | newIndex | tally := tally + 1. list size < (newIndex := (tallies at: hash) + 1) ifFalse: [ list at: newIndex put: anObject ] ifTrue: [ | newList | newList := Array new: list size * 2. newList replaceFrom: 1 to: list size with: list startingAt: 1; at: newIndex put: anObject. array at: hash put: newList ]. tallies at: hash put: newIndex ] ]. ^anObject! ! !FLLargeIdentitySet methodsFor: 'testing' stamp: 'MarianoMartinezPekc 1/10/2012 18:57'! includes: anObject anObject ifNil: [ ^includesNil ]. ^(array at: (anObject largeIdentityHash + 1)) ifNil: [ false ] ifNotNil: [ :list | list fuelPointsTo: anObject ]! ! !FLLightGeneralMapper commentStamp: ''! I know how to map an object to its default cluster. I can map every object.! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitWordsObject: anObject self mapAndTraceByObjectClass: anObject to: FLWordObjectCluster! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 3/28/2012 21:19'! visitHookPrimitive: anObject self mapAndTraceByObjectClass: anObject to: FLHookPrimitiveCluster ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 2/20/2013 20:55'! visitGlobalSend: anObject name: globalName selector: aSymbol (self clusterKeyedByClusterName: FLGlobalSendCluster) add: anObject name: globalName selector: aSymbol traceWith: analysis ! ! !FLLightGeneralMapper methodsFor: 'protected-mapping' stamp: 'MartinDias 1/9/2012 21:08'! clusterClassForCharacter: aCharacter ^ aCharacter isOctetCharacter ifTrue: [ FLHookPrimitiveCluster ] ifFalse: [ FLFixedObjectCluster ]! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 5/18/2012 17:38'! visitNotSerializable: anObject FLNotSerializable signalWith: anObject! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitVariableObject: anObject self mapAndTraceByObjectClass: anObject to: FLVariableObjectCluster! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 21:08'! visitCharacter: aCharacter self flag: #todo. "confusing" self mapAndTraceByObjectClass: aCharacter to: (self clusterClassForCharacter: aCharacter)! ! !FLLightGeneralMapper methodsFor: 'protected-mapping' stamp: 'MarianoMartinezPeck 6/9/2012 11:58'! clusterClassForSmallInteger: aSmallInteger aSmallInteger >= 0 ifTrue: [ aSmallInteger <= 255 ifTrue: [^ FLPositive8SmallIntegerCluster]. aSmallInteger <= 65535 ifTrue: [^ FLPositive16SmallIntegerCluster]. aSmallInteger <= 16777215 ifTrue: [^ FLPositive24SmallIntegerCluster]. aSmallInteger <= 4294967295 ifTrue: [^ FLPositive32SmallIntegerCluster]. ]. aSmallInteger >= -128 ifTrue: [^ FLNegative8SmallIntegerCluster]. aSmallInteger >= -32768 ifTrue: [^ FLNegative16SmallIntegerCluster]. aSmallInteger >= -8388608 ifTrue: [^ FLNegative24SmallIntegerCluster]. aSmallInteger >= -2147483648 ifTrue: [^ FLNegative32SmallIntegerCluster]. ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitFixedObject: anObject self mapAndTraceByObjectClass: anObject to: FLFixedObjectCluster! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 21:09'! visitSmallInteger: aSmallInteger self mapAndTraceByClusterName: aSmallInteger to: (self clusterClassForSmallInteger: aSmallInteger)! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitClassTrait: aClassTrait self mapAndTraceByClusterName: aClassTrait to: FLGlobalClassSideCluster! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitMetaclass: aMetaclass self mapAndTraceByClusterName: aMetaclass to: FLGlobalClassSideCluster! ! !FLLightGeneralMapper methodsFor: 'protected-mapping' stamp: 'MaxLeske 2/20/2013 22:23'! mapAndTraceInstanceSideGlobal: aClassOrTrait (self clusterKeyedByClusterName: FLGlobalClassCluster) add: aClassOrTrait traceWith: analysis ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitBytesObject: anObject self mapAndTraceByObjectClass: anObject to: FLByteObjectCluster! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:34'! visitPoint: aPoint self mapAndTraceByClusterName: aPoint to: FLPointCluster! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:34'! visitRectangle: aRectangle self mapAndTraceByClusterName: aRectangle to: FLRectangleCluster! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 5/9/2012 01:05'! visitSubstitution: anObject by: anotherObject onRecursionDo: aBlock | cluster | cluster := self clusterKeyedByClusterName: FLSubstitutionCluster. (cluster isSubstitute: anObject) ifTrue: aBlock ifFalse: [ cluster add: anObject substitutedBy: anotherObject traceWith: analysis ] ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MarianoMartinezPeck 7/26/2012 16:14'! visitDictionary: aDictionary self mapAndTraceByObjectClass: aDictionary to: FLDictionaryCollectionCluster ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:29'! visitSubstitution: anObject by: anotherObject (self clusterKeyedByClusterName: FLSubstitutionCluster) add: anObject substitutedBy: anotherObject traceWith: analysis ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/8/2012 20:14'! visitTrait: aTrait self mapAndTraceInstanceSideGlobal: aTrait! ! !FLLightGeneralMapper methodsFor: 'mapping' stamp: 'MartinDias 1/8/2012 12:36'! mapAndTrace: anObject anObject fuelAccept: self ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MarianoMartinezPeck 7/26/2012 17:41'! visitSimpleCollection: aCollection self mapAndTraceByObjectClass: aCollection to: FLSimpleCollectionCluster ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/8/2012 20:14'! visitClass: aClass self mapAndTraceInstanceSideGlobal: aClass! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitWeakObject: anObject self mapAndTraceByObjectClass: anObject to: FLWeakVariableObjectCluster! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 2/18/2013 19:05'! visitCompiledMethod: aCompiledMethod (aCompiledMethod isInstalled not or: [aCompiledMethod isDoIt ]) ifTrue: [ self mapAndTraceByClusterName: aCompiledMethod to: FLCompiledMethodCluster ] ifFalse: [self mapAndTraceByClusterName: aCompiledMethod to: FLGlobalCompiledMethodCluster] ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitMethodContext: aMethodContext self mapAndTraceByObjectClass: aMethodContext to: FLMethodContextCluster ! ! !FLLightGlobalMapper commentStamp: ''! I map classes, traits, and global objects that belong to Smalltalk dictionary. I collaborate in serialization default behavior. For example, the global Transcript as well as any class in the image, are mapped by me.! !FLLightGlobalMapper methodsFor: 'mapping' stamp: 'MartinDias 1/9/2012 18:36'! mapAndTrace: anObject "Uses the Chain of Responsibility pattern to answer the cluster which maps with the received object." (globals includes: anObject) ifTrue: [ self mapAndTraceByClusterName: anObject to: FLGlobalValueCluster ] ifFalse: [ next mapAndTrace: anObject ]! ! !FLLightGlobalMapper methodsFor: 'initialize-release' stamp: 'MartinDias 1/9/2012 18:11'! initializeWith: someObjects self initialize. globals := someObjects.! ! !FLLightGlobalMapper class methodsFor: 'instance creation' stamp: 'MartinDias 2/22/2013 12:57'! for: globalSymbols in: globalEnvironment ^ self basicNew initializeWith: (self valuesFor: globalSymbols in: globalEnvironment); yourself.! ! !FLLightGlobalMapper class methodsFor: 'private' stamp: 'MartinDias 2/25/2013 11:25'! valuesFor: globalSymbols in: globalEnvironment "Some globals, like ActiveHand have a nil value in the Smalltalk globals. Therefore, we cannot map nil to globalCluster. We could filter before in #defaultGlobalSymbols but that means that not even the Association will be consider global." | values | values := IdentitySet new: globalSymbols size. "todo: optimized ugly code" globalSymbols do: [:aSymbol | (globalEnvironment at: aSymbol ifPresent: [:value | value ifNotNil: [ values add: value ] ]) ]. ^ values! ! !FLMapper commentStamp: 'MartinDias 8/11/2011 03:09'! The purpose of my hierarchy is to map objects with clusters.! !FLMapper methodsFor: 'protected-mapping' stamp: 'MartinDias 1/9/2012 18:27'! clusterKeyedByObjectClass: clusterClass class: objectClass ^ self clusterInstanceOf: clusterClass keyInBucket: objectClass factory: [ clusterClass newAnalyzing: objectClass ]! ! !FLMapper methodsFor: 'protected-mapping' stamp: 'MartinDias 1/9/2012 18:28'! mapAndTraceByObjectClass: anObject to: aClusterClass (self clusterKeyedByObjectClass: aClusterClass class: anObject class) add: anObject traceWith: analysis ! ! !FLMapper methodsFor: 'mapping' stamp: 'MartinDias 1/8/2012 12:38'! mapAndTrace: anObject self subclassResponsibility! ! !FLMapper methodsFor: 'protected-mapping' stamp: 'MartinDias 1/9/2012 18:29'! clusterKeyedByClusterName: aClusterClass factory: clusterFactory ^ self clusterInstanceOf: aClusterClass keyInBucket: aClusterClass name factory: clusterFactory ! ! !FLMapper methodsFor: 'protected-mapping' stamp: 'MartinDias 1/9/2012 18:29'! mapAndTraceByClusterName: anObject to: aClusterClass (self clusterKeyedByClusterName: aClusterClass) add: anObject traceWith: analysis ! ! !FLMapper methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLMapper methodsFor: 'accessing' stamp: 'MartinDias 8/7/2011 17:19'! next: anObject next := anObject! ! !FLMapper methodsFor: 'protected-mapping' stamp: 'MartinDias 1/8/2012 20:45'! clusterInstanceOf: aClusterClass keyInBucket: clusterKey factory: clusterFactory | bucket | bucket := aClusterClass clusterBucketIn: analysis clusterization. ^ bucket at: clusterKey ifAbsentPut: [ clusterFactory value traceWith: analysis; yourself ]. ! ! !FLMapper methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:39'! analysis: anAnalysis analysis := anAnalysis. next ifNotNil: [ next analysis: anAnalysis ]! ! !FLMapper methodsFor: 'protected-mapping' stamp: 'MartinDias 1/9/2012 18:29'! clusterKeyedByClusterName: aClusterClass ^ self clusterKeyedByClusterName: aClusterClass factory: [ aClusterClass newAnalyzing ]! ! !FLMaterialization commentStamp: 'MarianoMartinezPeck 10/23/2011 14:42'! I implement the algorithm for materializing an object graph on a stream. FLMaterializer known how to build instances of me.! !FLMaterialization methodsFor: 'accessing' stamp: 'MartinDias 9/9/2011 01:58'! root ^ root ! ! !FLMaterialization methodsFor: 'private' stamp: 'MartinDias 12/29/2011 18:11'! referencesStep clusters do: [ :aCluster | aCluster materializeReferencesStepWith: decoder ]! ! !FLMaterialization methodsFor: 'private' stamp: 'MartinDias 12/29/2011 18:11'! trailerStep root := decoder nextEncodedReference! ! !FLMaterialization methodsFor: 'accessing' stamp: 'MartinDias 12/29/2011 18:12'! objects "Answer a collection with the materialized objects." ^ decoder objects ! ! !FLMaterialization methodsFor: 'header' stamp: 'MarianoMartinezPeck 7/28/2012 13:47'! additionalObjectAt: aKey ^ header additionalObjectAt: aKey! ! !FLMaterialization methodsFor: 'materializing' stamp: 'MarianoMartinezPeck 9/27/2011 16:50'! run self headerStep. self instancesStep. self referencesStep. self trailerStep. self afterMaterializationStep.! ! !FLMaterialization methodsFor: 'private' stamp: 'MartinDias 12/29/2011 18:09'! afterMaterializationStep clusters do: [ :aCluster | aCluster afterMaterializationStepWith: decoder ]! ! !FLMaterialization methodsFor: 'private' stamp: 'MartinDias 12/29/2011 18:25'! registerAll: materializedObjects decoder registerAll: materializedObjects ! ! !FLMaterialization methodsFor: 'private' stamp: 'MartinDias 12/29/2011 18:27'! headerStep decoder decodeYourself. clusterCount := decoder nextEncodedPositiveInteger. clusters := OrderedCollection new: clusterCount. clusters resetTo: 1. "Hack that avoids OrderedCollection>>makeRoomAtLast"! ! !FLMaterialization methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/28/2012 13:46'! header: aHeader header := aHeader ! ! !FLMaterialization methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 9/19/2012 14:36'! decoder ^ decoder! ! !FLMaterialization methodsFor: 'private' stamp: 'MarianoMartinezPeck 9/19/2012 14:38'! clusterInstancesStep | aCluster | aCluster := decoder nextEncodedClusterClass newMaterializing. aCluster clusterMaterializeStepWith: self. aCluster materializeInstancesStepWith: decoder. self registerAll: aCluster objects. aCluster materializePostInstancesStepWith: decoder. clusters add: aCluster.! ! !FLMaterialization methodsFor: 'private' stamp: 'MartinDias 9/9/2011 01:58'! instancesStep clusterCount timesRepeat: [ self clusterInstancesStep ] ! ! !FLMaterialization methodsFor: 'initialize-release' stamp: 'MartinDias 1/5/2012 14:30'! initializeWith: aDecoder self initialize. decoder := aDecoder. ! ! !FLMaterialization class methodsFor: 'instance creation' stamp: 'MartinDias 1/5/2012 14:29'! with: aDecoder ^self basicNew initializeWith: aDecoder; yourself ! ! !FLMaterializationError commentStamp: ''! I represent an error happened during materialization.! !FLMaterializationError class methodsFor: 'exceptioninstantiator' stamp: 'MartinDias 3/20/2012 12:47'! signal: signalerText ^ super signal: 'Materialization error. ', signalerText ! ! !FLMaterializer commentStamp: 'MartinDias 8/29/2011 19:06'! I am a binary object materializer. See an example of use in FLSerializer's documentation. ! !FLMaterializer methodsFor: 'protected' stamp: 'MartinDias 2/25/2013 14:46'! decodeHeaderWith: aDecoder "See FLSerializer>>encodeHeaderWith:" "todo: fix" "Here I cannot use #materializeFrom: again because I will end up in an infinitive loop. Therefore, I use #materializationFactory." ^(aDecoder nextEncodedByte = 0) ifTrue: [ FLHeader new ] ifFalse: [ (self class newDefault materializationFactory value: aDecoder) root ]! ! !FLMaterializer methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/29/2012 23:31'! materializationFactory ^ materializationFactory! ! !FLMaterializer methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLMaterializer methodsFor: 'materializing' stamp: 'MartinDias 2/24/2013 20:13'! materializeFrom: aStream | aDecoder materialization header | aDecoder := FLDecoder on: aStream migrations: migrations globalEnvironment: globalEnvironment. self verifySignatureFrom: aDecoder. self verifyVersionFrom: aDecoder. header := self decodeHeaderWith: aDecoder. header executePreMaterializationActions. materialization := materializationFactory value: aDecoder. "This is useful because when the user materialize something, what it is answered is the materialization objet, and not the materializer. Hence, it is difficult to query the header (like asking the additionalObjects) because materializer is lost. Therefore, we also set the header to the materialization." materialization header: header. "This is useful because the postMaterializationActions may need to have access to the state of the materialization, for example, to the root" header materialization: materialization. header executePostMaterializationActions. ^ materialization ! ! !FLMaterializer methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 22:57'! version ^ version! ! !FLMaterializer methodsFor: 'accessing' stamp: 'MartinDias 2/21/2013 23:47'! globalEnvironment "Answer a dictionary where the look up for global symbols will be done during materialization." ^ globalEnvironment! ! !FLMaterializer methodsFor: 'accessing' stamp: 'MartinDias 2/21/2013 23:47'! globalEnvironment: aDictionary "Set the dictionary where the look up for global symbols will be done during materialization." globalEnvironment := aDictionary! ! !FLMaterializer methodsFor: 'protected' stamp: 'MartinDias 1/6/2012 20:34'! setDefaultMaterialization materializationFactory := [:aDecoder | (FLMaterialization with: aDecoder) run; yourself ] ! ! !FLMaterializer methodsFor: 'initialization' stamp: 'MartinDias 2/21/2013 23:48'! initialize super initialize. self setDefaultMaterialization. self signature: self class defaultSignature. self version: self class currentVersion. migrations := Dictionary new. globalEnvironment := self class environment.! ! !FLMaterializer methodsFor: 'configuring-migration' stamp: 'MartinDias 1/5/2012 01:04'! migrateClassNamed: aSymbol toClass: aClass self migrateClassNamed: aSymbol toClass: aClass variables: #()! ! !FLMaterializer methodsFor: 'configuring-migration' stamp: 'MartinDias 5/18/2012 18:56'! migrateClassNamed: aSymbol toClass: aClass variables: aDictionary migrations at: aSymbol put: (FLMigration fromClassNamed: aSymbol toClass: aClass variables: aDictionary)! ! !FLMaterializer methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 22:57'! signature ^ signature! ! !FLMaterializer methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 22:57'! signature: anObject signature := anObject! ! !FLMaterializer methodsFor: 'protected' stamp: 'MartinDias 1/7/2012 12:21'! verifySignatureFrom: aDecoder | streamSignature | streamSignature := ByteArray new: self signature size. aDecoder nextEncodedBytesInto: streamSignature. (self signature asByteArray = streamSignature) ifFalse: [ FLBadSignature signalCurrentSignature: self signature streamSignature: streamSignature ]. ! ! !FLMaterializer methodsFor: 'protected' stamp: 'MartinDias 1/7/2012 12:13'! verifyVersionFrom: aDecoder | streamVersion | streamVersion := aDecoder nextEncodedUint16. (self version = streamVersion) ifFalse: [ FLBadVersion signalCurrentVersion: self version streamVersion: streamVersion ] ! ! !FLMaterializer methodsFor: 'materializing' stamp: 'MartinDias 2/25/2013 14:19'! materializeHeaderFrom: aStream | aDecoder | aDecoder := FLDecoder on: aStream migrations: migrations globalEnvironment: globalEnvironment. self verifySignatureFrom: aDecoder. self verifyVersionFrom: aDecoder. ^ self decodeHeaderWith: aDecoder! ! !FLMaterializer methodsFor: 'configuring-migration' stamp: 'MartinDias 2/21/2013 16:38'! migrateClassNamed: aSymbol variables: aDictionary self migrateClassNamed: aSymbol toClass: (self class environment at: aSymbol) variables: aDictionary! ! !FLMaterializer methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 22:57'! version: anObject version := anObject! ! !FLMaterializer class methodsFor: '*FuelSystem-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:56'! fileReaderServicesForFile: fullName suffix: suffix suffix = 'fuel' ifFalse: [ ^ #() ]. ^ { self serviceFuelMaterialize }! ! !FLMaterializer class methodsFor: 'materializing-shortcuts' stamp: 'MarianoMartinezPeck 7/28/2012 14:58'! materializeHeaderFromFileNamed: aFilename ^ self materializationHeaderFromFileNamed: aFilename ! ! !FLMaterializer class methodsFor: 'instance creation' stamp: 'MartinDias 9/10/2011 18:16'! newDefault ^self new! ! !FLMaterializer class methodsFor: 'protected' stamp: 'MaxLeske 2/18/2014 14:11'! currentVersion "If you change this method, you should also create a version in ConfigurationOfFuel and FLSerializer >> currentVersion" ^ 193! ! !FLMaterializer class methodsFor: 'protected' stamp: 'MartinDias 10/6/2011 23:31'! defaultSignature ^ 'FUEL'! ! !FLMaterializer class methodsFor: 'materializing-shortcuts' stamp: 'MarianoMartinezPeck 7/28/2012 14:57'! materializationHeaderFromFileNamed: aFilename ^StandardFileStream oldFileNamed: aFilename do: [:aFileStream | (self newDefault materializeHeaderFrom: aFileStream binary) ] ! ! !FLMaterializer class methodsFor: '*FuelSystem-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:37'! serviceFuelMaterialize ^ SimpleServiceEntry provider: self label: 'Materialize Fuel file' selector: #materializeFromFileNamed: description: 'Materialize objects previously serialized with Fuel' buttonLabel: 'materialize'! ! !FLMaterializer class methodsFor: 'materializing-shortcuts' stamp: 'MarianoMartinezPeck 9/27/2011 17:14'! materializationFromFileNamed: aFilename ^StandardFileStream oldFileNamed: aFilename do: [:aFileStream | (self newDefault materializeFrom: aFileStream binary) ] ! ! !FLMaterializer class methodsFor: 'materializing-shortcuts' stamp: 'MartinDias 9/9/2011 20:25'! materializeFromByteArray: byteArray ^(self newDefault materializeFrom: byteArray readStream) root! ! !FLMaterializer class methodsFor: 'materializing-shortcuts' stamp: 'MarianoMartinezPeck 9/27/2011 17:15'! materializeFromFileNamed: aFilename ^ (self materializationFromFileNamed: aFilename) root ! ! !FLMethodChanged commentStamp: ''! I represent an error produced during materialization when is detected a change in the bytecodes of a method serialized as global. This error was born when testing the materialization of a BlockClosure defined in a method that changed. The test produced a VM crash.! !FLMethodChanged class methodsFor: 'signaling' stamp: 'MartinDias 3/20/2012 17:47'! signalWith: aGlobalName and: aSelector ^ self signal: 'Method ', aGlobalName, '>>#', aSelector, ' changed its bytecodes.'! ! !FLMethodContextCluster commentStamp: 'MartinDias 5/30/2011 01:18'! I am a cluster for MethodContexts.! !FLMethodContextCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 20:58'! materializeInstanceWith: aDecoder ^ theClass newFromFrameSize: aDecoder nextEncodedByte ! ! !FLMethodContextCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 20:04'! serializeInstance: aMethodContext with: anEncoder anEncoder encodeByte: aMethodContext method frameSize. ! ! !FLMethodContextSerializationTest commentStamp: 'TorstenBergmann 2/3/2014 23:32'! SUnit tests for fuel serialization of methods contexts! !FLMethodContextSerializationTest methodsFor: 'tests' stamp: 'MartinDias 3/26/2012 22:52'! testMethodContextThisContext | materializedContext context | context := thisContextSample. materializedContext := self resultOfSerializeAndMaterialize: context. self deny: context == materializedContext. "I cannot compare by = because MethodContext do not implement it and it will finally use the identity." self assert: context pc = materializedContext pc. self assert: context stackPtr = materializedContext stackPtr. self assert: context method = materializedContext method. self assert: context receiver = materializedContext receiver. "I cannot compare by = because MethodContext do not implement it and it will finally use the identity." self deny: context sender == materializedContext sender. self assert: context sender pc == materializedContext sender pc. self assert: context sender stackPtr = materializedContext sender stackPtr. "etc...." ! ! !FLMethodContextSerializationTest methodsFor: 'tests' stamp: 'MartinDias 12/3/2011 22:22'! testMethodContextWithNilPc "This test should be improved" | methodContext1 materializedMethodContext1 | methodContext1 := (MethodContext newForMethod: FLPair >> #method1). methodContext1 initializeWith: nil stackPtr: 1 method: FLPair >> #method1 receiver: (FLPair new right: 4; left: 2) sender: nil. materializedMethodContext1 := self resultOfSerializeAndMaterialize: methodContext1. methodContext1 assertWellMaterializedInto: materializedMethodContext1 in: self.! ! !FLMethodContextSerializationTest methodsFor: 'tests' stamp: 'MarcusDenker 4/25/2013 15:09'! testDoIt "Serialization of DoIt methods should be possible by default." | context | [ Smalltalk evaluate: 'self error' ] on: Error do: [:error | context:= error signalerContext copyStack ]. self serialize: context! ! !FLMethodContextSerializationTest methodsFor: 'tests' stamp: 'MartinDias 12/3/2011 22:22'! testMethodContextWithClosureContextWithOutPointerTesting "This test should be improved" | methodContext1 materializedMethodContext1 | methodContext1 := self class blockClosureContextWithOutPointerTesting. self assert: (methodContext1 tempNamed: 'string') = 'test'. materializedMethodContext1 := self resultOfSerializeAndMaterialize: methodContext1. self assert: (materializedMethodContext1 tempNamed: 'string') = 'test'. methodContext1 assertWellMaterializedInto: materializedMethodContext1 in: self. ! ! !FLMethodContextSerializationTest methodsFor: 'tests' stamp: 'MartinDias 12/3/2011 22:22'! testMethodContextWithClosureAndSender "This test should be improved" | methodContext1 materializedMethodContext2 methodContext2 | methodContext1 := (MethodContext newForMethod: FLPair >> #method1). methodContext1 initializeWith: 23 stackPtr: 1 method: FLPair >> #method1 receiver: (FLPair new right: 4; left: 2) sender: nil. methodContext2 := self class blockClosureContextTestingWithSender: methodContext1. materializedMethodContext2 := self resultOfSerializeAndMaterialize: methodContext2. methodContext2 assertWellMaterializedInto: materializedMethodContext2 in: self. ! ! !FLMethodContextSerializationTest methodsFor: 'tests' stamp: 'MartinDias 12/3/2011 22:22'! testMethodContextWithSender "This test should be improved" | methodContext1 methodContext2 materializedMethodContext1 | methodContext1 := (MethodContext newForMethod: FLPair >> #method1). methodContext1 initializeWith: 23 stackPtr: 1 method: FLPair >> #method1 receiver: (FLPair new right: 4; left: 2) sender: nil. methodContext2 := (MethodContext newForMethod: FLPair >> #method2). methodContext2 initializeWith: 18 stackPtr: 1 method: FLPair >> #method2 receiver: (FLPair new right: 5; left: 6) sender: nil. methodContext1 privSender: methodContext2. materializedMethodContext1 := self resultOfSerializeAndMaterialize: methodContext1. methodContext1 assertWellMaterializedInto: materializedMethodContext1 in: self.! ! !FLMethodContextSerializationTest methodsFor: 'tests' stamp: 'MartinDias 12/3/2011 22:22'! testMethodContextWithTemp "This test should be improved" | methodContext1 materializedMethodContext1 | methodContext1 := (MethodContext newForMethod: FLPair >> #methodWithTemp). methodContext1 initializeWith: nil stackPtr: 1 method: FLPair >> #methodWithTemp receiver: (FLPair new right: 4; left: 2) sender: nil. methodContext1 tempNamed: 'string' put: 'capo'. materializedMethodContext1 := self resultOfSerializeAndMaterialize: methodContext1. self assert: (materializedMethodContext1 tempNamed: 'string') = 'capo'. methodContext1 assertWellMaterializedInto: materializedMethodContext1 in: self.! ! !FLMethodContextSerializationTest methodsFor: 'tests' stamp: 'MartinDias 12/3/2011 22:21'! testMethodContext "This test should be improved" | methodContext1 materializedMethodContext1 | methodContext1 := (MethodContext newForMethod: FLPair >> #method1). methodContext1 initializeWith: 23 stackPtr: 1 method: FLPair >> #method1 receiver: (FLPair new right: 4; left: 2) sender: nil. materializedMethodContext1 := self resultOfSerializeAndMaterialize: methodContext1. methodContext1 assertWellMaterializedInto: materializedMethodContext1 in: self.! ! !FLMethodContextSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/26/2012 22:52'! setUp super setUp. thisContextSample := self class thisContextSample.! ! !FLMethodContextSerializationTest methodsFor: 'tests' stamp: 'MartinDias 12/3/2011 22:21'! testMethodContextWithClosure "This test should be improved" | methodContext1 materializedMethodContext1 | methodContext1 := self class blockClosureContextTesting. materializedMethodContext1 := self resultOfSerializeAndMaterialize: methodContext1. methodContext1 assertWellMaterializedInto: materializedMethodContext1 in: self. ! ! !FLMethodContextSerializationTest class methodsFor: 'closures for testing' stamp: 'MarianoMartinezPeck 5/24/2011 13:44'! blockClosureContextTestingWithSender: aSenderContext ^ [self class] asContextWithSender: aSenderContext! ! !FLMethodContextSerializationTest class methodsFor: 'running' stamp: 'MartinDias 3/26/2012 22:54'! thisContextSample ^ thisContext copy! ! !FLMethodContextSerializationTest class methodsFor: 'closures for testing' stamp: 'MarianoMartinezPeck 7/1/2011 11:11'! blockClosureContextWithOutPointerTesting | string | string := 'test'. ^ [self class. string asUppercase] asContext! ! !FLMethodContextSerializationTest class methodsFor: 'closures for testing' stamp: 'MarianoMartinezPeck 5/24/2011 13:44'! blockClosureContextTesting ^ [self class] asContext! ! !FLMethodNotFound commentStamp: 'MartinDias 12/16/2011 01:17'! I represent an error produced during materialization when a serialized method in a class or trait name doesn't exist (at Smalltalk globals).! !FLMethodNotFound class methodsFor: 'signaling' stamp: 'MartinDias 3/20/2012 17:48'! signalWith: aGlobalName and: aSelector ^ self signal: 'Method ', aGlobalName, '>>#', aSelector, ' not found.'! ! !FLMigration commentStamp: 'MartinDias 1/6/2012 16:04'! I represent migration information about a class. See 'configuring-migration' protocol in FLMaterializer.! !FLMigration methodsFor: 'evaluating' stamp: 'MartinDias 1/5/2012 13:14'! applyTo: aVariablesMapping variables do: [:link | aVariablesMapping map: link key to: link value ] ! ! !FLMigration methodsFor: 'accessing' stamp: 'MartinDias 1/5/2012 01:09'! sourceClassName ^ sourceClassName! ! !FLMigration methodsFor: 'initializing' stamp: 'MartinDias 1/5/2012 13:12'! initializeClassNamed: aSymbol toClass: aClass variables: anArray self initialize. sourceClassName := aSymbol. targetClass := aClass. variables := anArray.! ! !FLMigration methodsFor: 'accessing' stamp: 'MartinDias 1/5/2012 13:12'! targetClass ^ targetClass! ! !FLMigration class methodsFor: 'instance creation' stamp: 'MartinDias 1/4/2012 23:57'! fromClassNamed: aSymbol toClass: aClass variables: anArray ^self basicNew initializeClassNamed: aSymbol toClass: aClass variables: anArray; yourself.! ! !FLMigrationTest commentStamp: 'TorstenBergmann 2/3/2014 23:26'! SUnit tests for migrations! !FLMigrationTest methodsFor: 'tests-automatic' stamp: 'MartinDias 1/6/2012 15:46'! testVariableInsertion "Tests that serializer tolarates when there is a new instance variable on materialization" | pairClass aPair resultPair | pairClass := self newClassWithInstanceVariableNames: 'left right'. aPair := pairClass new. aPair instVarAt: 1 put: $A. aPair instVarAt: 2 put: $B. self serialize: aPair. self redefined: pairClass with: 'left middle right'. resultPair := self materialized. self assert: $A = (resultPair instVarAt: 1). self assert: nil = (resultPair instVarAt: 2). self assert: $B = (resultPair instVarAt: 3).! ! !FLMigrationTest methodsFor: 'tests-manual' stamp: 'MartinDias 5/18/2012 23:00'! testClassAndVariableRename | pointClass aPoint resultPoint pointClassName | pointClass := self newClassWithInstanceVariableNames: 'x y'. pointClassName := pointClass name. aPoint := pointClass new. aPoint instVarNamed: 'x' put: 7. aPoint instVarNamed: 'y' put: 11. self serialize: aPoint. pointClass renameSilently: (pointClassName, 'Renamed') asSymbol. pointClass := self redefined: pointClass with: 'posY posX'. self materializer migrateClassNamed: pointClassName toClass: pointClass variables: {'x' -> 'posX'. 'y' -> 'posY'}. resultPoint := self materialized. self assert: (resultPoint instVarNamed: 'posX') = 7. self assert: (resultPoint instVarNamed: 'posY') = 11.! ! !FLMigrationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 7/10/2012 16:47'! redefined: aClass with: instanceVariableNames | name | name := aClass name. self removeFromSystem: aClass. "In this case we need to create a class with notifications" ^ (self withNotificationsNewClassWithInstanceVariableNames: instanceVariableNames) renameSilently: name. ! ! !FLMigrationTest methodsFor: 'tests-automatic' stamp: 'MartinDias 1/6/2012 15:46'! testChangeInSuperclass "Tests that serializer tolarates when there is a change in the superclass between serialization and materialization" | aClass aClassSubclass instance materializedInstance | aClass := self newClassWithInstanceVariableNames: 'a b c' superclass: Object. aClassSubclass := self newClassWithInstanceVariableNames: 'd e' superclass: aClass. instance := aClassSubclass new. instance instVarNamed: 'a' put: $A. instance instVarNamed: 'b' put: $B. instance instVarNamed: 'c' put: $C. instance instVarNamed: 'd' put: $D. instance instVarNamed: 'e' put: $E. self serialize: instance. aClass removeInstVarNamed: 'a'. aClass removeInstVarNamed: 'b'. aClass addInstVarNamed: 'x'. aClassSubclass superclass: aClass. materializedInstance := self materialized. self assert: $D = (materializedInstance instVarNamed: 'd'). self assert: $E = (materializedInstance instVarNamed: 'e'). self should: [materializedInstance instVarNamed: 'a'] raise: Error. self should: [materializedInstance instVarNamed: 'b'] raise: Error. self assert: $C = (materializedInstance instVarNamed: 'c'). self assert: (materializedInstance instVarNamed: 'x') isNil. ! ! !FLMigrationTest methodsFor: 'tests-automatic' stamp: 'MarianoMartinezPeck 10/16/2012 09:35'! testFormatFixedToVariable "Tests that serializer can tolerate a format change from a *fixed* class to *weak/variable*. Notice, however, that the other way around (variable to fixed) doesn't work so far" | materialized | self serialize: FLPair new. materialized := self during: [ self materialized ] rename: FLPair as: FLWeakClassMock. self assert: materialized size = 0! ! !FLMigrationTest methodsFor: 'tests-automatic' stamp: 'MartinDias 1/6/2012 15:46'! testSuperclassChange "Tests that serializer tolarates when the superclass changed between serialization and materialization" | aClass aClassSubclass instance materializedInstance anotherSuperclass | aClass := self newClassWithInstanceVariableNames: 'a b c' superclass: Object. aClassSubclass := self newClassWithInstanceVariableNames: 'd e' superclass: aClass. anotherSuperclass := self newClassWithInstanceVariableNames: 'x' superclass: Object. instance := aClassSubclass new. instance instVarNamed: 'a' put: $A. instance instVarNamed: 'b' put: $B. instance instVarNamed: 'c' put: $C. instance instVarNamed: 'd' put: $D. instance instVarNamed: 'e' put: $E. self serialize: instance. aClassSubclass superclass: anotherSuperclass. materializedInstance := self materialized. self assert: $D = (materializedInstance instVarNamed: 'd'). self assert: $E = (materializedInstance instVarNamed: 'e'). self should: [materializedInstance instVarNamed: 'a'] raise: Error. self should: [materializedInstance instVarNamed: 'b'] raise: Error. self should: [materializedInstance instVarNamed: 'c'] raise: Error. self assert: (materializedInstance instVarNamed: 'x') isNil. ! ! !FLMigrationTest methodsFor: 'tests-automatic' stamp: 'MartinDias 1/6/2012 15:46'! testVariableRemoved "Tests that serializer tolarates when an instance variable is missing on materialization" | pairClass aPair resultPair | pairClass := self newClassWithInstanceVariableNames: 'left right'. aPair := pairClass new. aPair instVarAt: 1 put: $A. aPair instVarAt: 2 put: $B. self serialize: aPair. self redefined: pairClass with: 'right'. resultPair := self materialized. self assert: $B = (resultPair instVarAt: 1). ! ! !FLMigrationTest methodsFor: 'tests-manual' stamp: 'MartinDias 5/18/2012 22:59'! testVariableRename | pointClass aPoint resultPoint pointClassName | pointClass := self newClassWithInstanceVariableNames: 'x y'. pointClassName := pointClass name. aPoint := pointClass new. aPoint instVarNamed: 'x' put: 7. aPoint instVarNamed: 'y' put: 11. self serialize: aPoint. self redefined: pointClass with: 'posY posX'. self materializer migrateClassNamed: pointClassName variables: {'x' -> 'posX'. 'y' -> 'posY'}. resultPoint := self materialized. self assert: (resultPoint instVarNamed: 'posX') = 7. self assert: (resultPoint instVarNamed: 'posY') = 11.! ! !FLMigrationTest methodsFor: 'tests-manual' stamp: 'MarianoMartinezPeck 4/19/2012 18:01'! testClassRename | pointClass aPoint resultPoint pointClassName | pointClass := self newClassWithInstanceVariableNames: 'x y'. pointClassName := pointClass name. aPoint := pointClass new. aPoint instVarNamed: 'x' put: 7. aPoint instVarNamed: 'y' put: 11. self serialize: aPoint. pointClass renameSilently: (pointClassName, 'Renamed') asSymbol. self materializer migrateClassNamed: pointClassName toClass: pointClass. resultPoint := self materialized. self assert: (resultPoint instVarNamed: 'x') = 7. self assert: (resultPoint instVarNamed: 'y') = 11.! ! !FLMigrationTest methodsFor: 'tests-automatic' stamp: 'MartinDias 1/6/2012 15:46'! testVariableOrderChange "Tests that serializer tolarates when the order in the instance variables changed between serialization and materialization" | pairClass aPair resultPair | pairClass := self newClassWithInstanceVariableNames: 'left right'. aPair := pairClass new. aPair instVarAt: 1 put: $A. aPair instVarAt: 2 put: $B. self serialize: aPair. self redefined: pairClass with: 'right left'. resultPair := self materialized. self assert: $B = (resultPair instVarAt: 1). self assert: $A = (resultPair instVarAt: 2). ! ! !FLMigrationTest methodsFor: 'tests-manual' stamp: 'MartinDias 1/6/2012 15:46'! testBadDestinationVariableRename | pointClass aPoint pointClassName | pointClass := self newClassWithInstanceVariableNames: 'x y'. pointClassName := pointClass name. aPoint := pointClass new. self materializer migrateClassNamed: pointClassName variables: {('x' -> 'posX')}. self serialize: aPoint. self should: [ self materialized ] raise: Error. self flag: #todo."Assert an specific materialization error"! ! !FLMultiByteStreamStrategy commentStamp: 'MartinDias 10/12/2011 11:37'! I am a strategy for MultiByteBinaryOrTextStream..! !FLMultiByteStreamStrategy methodsFor: 'writing' stamp: 'MartinDias 10/12/2011 10:25'! writeStreamDo: aValuable "Evaluates the argument with a write stream. Answers the result." inMemoryStream := MultiByteBinaryOrTextStream on: ''. ^aValuable value: inMemoryStream binary ! ! !FLMultiByteStreamStrategy methodsFor: 'reading' stamp: 'MartinDias 10/12/2011 10:25'! readStreamDo: aValuable "Evaluates the argument with a read stream. Answers the result." ^aValuable value: inMemoryStream reset! ! !FLNegative16SmallIntegerCluster commentStamp: 'TorstenBergmann 2/3/2014 23:19'! A cluster of unsigned int 16bit! !FLNegative16SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:50'! materializeInstanceWith: aDecoder ^ aDecoder nextEncodedUint16 negated ! ! !FLNegative16SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:50'! serializeInstance: anInteger with: anEncoder anEncoder encodeUint16: anInteger abs! ! !FLNegative24SmallIntegerCluster commentStamp: 'TorstenBergmann 2/3/2014 23:19'! A cluster of unsigned int 24bit! !FLNegative24SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/9/2012 11:52'! materializeInstanceWith: aDecoder ^ aDecoder nextEncodedUint24 negated ! ! !FLNegative24SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/9/2012 11:52'! serializeInstance: anInteger with: anEncoder anEncoder encodeUint24: anInteger abs! ! !FLNegative32SmallIntegerCluster commentStamp: 'TorstenBergmann 2/3/2014 23:19'! A cluster of unsigned int 32bit! !FLNegative32SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:57'! materializeInstanceWith: aDecoder ^ aDecoder nextEncodedUint32 negated ! ! !FLNegative32SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:57'! serializeInstance: anInteger with: anEncoder anEncoder encodeUint32: anInteger abs! ! !FLNegative8SmallIntegerCluster commentStamp: 'TorstenBergmann 2/3/2014 23:19'! A cluster of unsigned int 8bit! !FLNegative8SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:52'! materializeInstanceWith: aDecoder ^ aDecoder nextEncodedUint8 negated! ! !FLNegative8SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:53'! serializeInstance: anInteger with: anEncoder anEncoder encodeUint8: anInteger abs! ! !FLNotSerializable commentStamp: ''! I represent an error which may happen while tracing in the graph an object that is forbidden of being serialized.! !FLNotSerializable class methodsFor: 'signaling' stamp: 'MartinDias 5/16/2012 00:39'! signalWith: anObject self signal: 'Found a forbidden object in the graph: ', anObject printString.! ! !FLNotSerializableMock commentStamp: 'TorstenBergmann 2/3/2014 23:23'! A test mock which is not serializable! !FLNotSerializableMock methodsFor: 'hooks' stamp: 'MartinDias 5/18/2012 17:37'! fuelAccept: aGeneralMapper aGeneralMapper visitNotSerializable: self! ! !FLObjectCluster commentStamp: 'MartinDias 8/29/2011 19:20'! I implement a generic way of serializing and materializing an object, for those that do not need more special way of doing it.! !FLObjectCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:42'! clusterMaterializeStepWith: aMaterialization super clusterMaterializeStepWith: aMaterialization. theClass := aMaterialization decoder nextEncodedReference. ! ! !FLObjectCluster methodsFor: 'printing' stamp: 'MarianoMartinezPeck 10/24/2011 10:58'! printNameOn: aStream "Append to the argument, aStream, a sequence of characters that identifies the receiver." super printNameOn: aStream. aStream nextPut: $[. theClass printOn: aStream. aStream nextPut: $]. ! ! !FLObjectCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:41'! clusterSerializeStepWith: aSerialization super clusterSerializeStepWith: aSerialization. aSerialization encoder encodeReferenceTo: theClass.! ! !FLObjectCluster methodsFor: 'initialize-release' stamp: 'MartinDias 1/11/2012 00:36'! initializeAnalyzing: aClass self initializeAnalyzing. theClass := aClass! ! !FLObjectCluster methodsFor: 'analyzing' stamp: 'MartinDias 5/30/2011 03:45'! clusterReferencesDo: aBlock aBlock value: theClass! ! !FLObjectCluster methodsFor: 'printing' stamp: 'MarianoMartinezPeck 12/9/2011 20:26'! theClass ^ theClass! ! !FLObjectCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:38'! clusterBucketIn: aClusterization ^aClusterization baselevelBucket ! ! !FLObjectCluster class methodsFor: 'instance creation' stamp: 'MartinDias 1/8/2012 14:31'! newAnalyzing: aClass ^ self basicNew initializeAnalyzing: aClass; yourself.! ! !FLObjectNotFound commentStamp: ''! I represent an error which may happen during serialization, when trying to encode on the stream a reference to an object that should be encoded before, but it is not. This usually happens when the graph changes during serialization. Another possible cause is a bug in the analysis step of serialization.! !FLObjectNotFound class methodsFor: 'signaling' stamp: 'MartinDias 3/20/2012 12:15'! signalWith: anObject self signal: ( String streamContents: [ :stream | stream << 'Unexpected reference to '. stream print: anObject. stream << ' in the graph. This usually happens when the graph changes during serialization.'. ] )! ! !FLObsolete commentStamp: ''! I am an error produced during serialization, signaled when trying to serialize an obsolete class as global. It is a prevention, because such class is lekely to be absent during materialization.! !FLObsolete class methodsFor: 'signaling' stamp: 'MartinDias 3/19/2012 00:02'! signalWithName: classOrTraitName ^ self signal: classOrTraitName printString, ' can not be serialized as global because it is obsolete.'! ! !FLOptimizedObjectCluster commentStamp: ''! I have shared behavior of some optional clusters.! !FLOptimizedObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 13:41'! materializeReferencesOf: anObject with: aDecoder "Hook method" self subclassResponsibility! ! !FLOptimizedObjectCluster methodsFor: 'serialize/materialize' stamp: 'MaxLeske 5/3/2013 09:32'! serializeReferencesOf: anObject with: anEncoder (self references at: anObject ifAbsent: [ ^ self ]) do: [ :value | anEncoder encodeReferenceTo: value ]! ! !FLOptimizedObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/17/2012 03:05'! serializeInstancesStepWith: anEncoder "Do nothing. I know my objects have nothing to serialize in this step." ! ! !FLOptimizedObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:43'! serializeReferencesStepWith: anEncoder objects do: [ :anObject | self serializeReferencesOf: anObject with: anEncoder ]! ! !FLOptimizedObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeReferencesStepWith: aDecoder objects do: [ :anObject | self materializeReferencesOf: anObject with: aDecoder ]! ! !FLOptimizedObjectCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:39'! clusterBucketIn: aClusterization ^aClusterization baselevelBucket ! ! !FLPair commentStamp: 'TorstenBergmann 2/3/2014 23:23'! A test mock for pairs! !FLPair methodsFor: 'accessing' stamp: 'MartinDias 9/16/2010 19:58'! right ^ right! ! !FLPair methodsFor: 'comparing' stamp: 'MartinDias 10/15/2010 10:54'! hash "Answer an integer value that is related to the identity of the receiver." ^ self right hash bitXor: self left hash! ! !FLPair methodsFor: 'comparing' stamp: 'MartinDias 10/15/2010 10:54'! = anObject "Answer whether the receiver and anObject represent the same object." self == anObject ifTrue: [ ^ true ]. self class = anObject class ifFalse: [ ^ false ]. ^ self right = anObject right and: [ self left = anObject left ]! ! !FLPair methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 5/23/2011 00:14'! method2 self name. ! ! !FLPair methodsFor: 'accessing' stamp: 'MartinDias 9/16/2010 19:58'! right: anObject right := anObject! ! !FLPair methodsFor: 'printing' stamp: 'MartinDias 8/20/2011 22:57'! printOn: aStream "Append a sequence of characters to aStream that identify the receiver." super printOn: aStream. aStream nextPutAll: '('; print: left; space; print: right; nextPutAll: ')'! ! !FLPair methodsFor: 'accessing' stamp: 'MartinDias 9/16/2010 19:58'! left ^ left! ! !FLPair methodsFor: 'accessing' stamp: 'MartinDias 9/16/2010 19:58'! left: anObject left := anObject! ! !FLPair methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/1/2011 11:17'! methodWithTemp | string | string := 'test'. self name. self printString. ! ! !FLPair methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 5/23/2011 00:14'! method1 self name. self printString. ! ! !FLPerson commentStamp: 'MarianoMartinezPeck 5/19/2011 23:51'! FLPerson is a class just to be able to change the hash of an object and try to test problems with hash.! !FLPerson methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 5/19/2011 22:28'! id ^ id! ! !FLPerson methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 5/19/2011 22:28'! id: anObject id := anObject! ! !FLPerson methodsFor: 'comparing' stamp: 'MarianoMartinezPeck 5/19/2011 22:29'! hash "Answer an integer value that is related to the identity of the receiver." ^ id! ! !FLPerson methodsFor: 'comparing' stamp: 'MarianoMartinezPeck 5/19/2011 22:29'! = anObject "Answer whether the receiver and anObject represent the same object." self == anObject ifTrue: [ ^ true ]. self class = anObject class ifFalse: [ ^ false ]. ^ id = anObject id! ! !FLPluggableSubstitutionMapper commentStamp: 'MartinDias 8/20/2011 23:45'! I map substituted objects. For example, suppose you want to substitute instances of WriteStream by nil. In such case, I will map every WriteStream instance to my substitutions cluster, and its factory block will value to nil with any argument. ! !FLPluggableSubstitutionMapper methodsFor: 'mapping' stamp: 'MartinDias 5/9/2012 00:12'! mapAndTrace: anObject "Uses the Chain of Responsibility pattern to answer the cluster which maps with the received object." (condition value: anObject) ifTrue: [ self mapAndTraceSubstitutionIfNotRecursive: anObject ] ifFalse: [ next mapAndTrace: anObject ]! ! !FLPluggableSubstitutionMapper methodsFor: 'mapping' stamp: 'MartinDias 5/9/2012 00:13'! mapAndTraceSubstitutionIfNotRecursive: anObject | cluster | cluster := self clusterKeyedByClusterName: FLSubstitutionCluster. (cluster isSubstitute: anObject) ifTrue: [ next mapAndTrace: anObject ] ifFalse: [ cluster add: anObject substitutedBy: (substitutionFactory value: anObject) traceWith: analysis ] ! ! !FLPluggableSubstitutionMapper methodsFor: 'initialize-release' stamp: 'MartinDias 1/9/2012 14:53'! initializeWith: aCondition substitutionFactory: aBlock self initialize. condition := aCondition. substitutionFactory := aBlock.! ! !FLPluggableSubstitutionMapper class methodsFor: 'instance creation' stamp: 'MartinDias 1/9/2012 14:52'! when: aCondition substituteBy: aFactory ^self basicNew initializeWith: aCondition substitutionFactory: aFactory; yourself! ! !FLPluggableSubstitutionTest commentStamp: 'TorstenBergmann 2/3/2014 23:31'! SUnit tests for fuels pluggable substitutions! !FLPluggableSubstitutionTest methodsFor: 'tests' stamp: 'MartinDias 5/8/2012 19:57'! testSubstituteByItself | result | self analyzer when: [:x | true ] substituteBy: [:x | x ]. result := self resultOfSerializeAndMaterialize: 1. self assert: result = 1.! ! !FLPluggableSubstitutionTest methodsFor: 'tests' stamp: 'MartinDias 10/7/2011 16:33'! testTransientPairLeft | result | self analyzer when: [:x | FLPair = x class and: [x left isNil not]] substituteBy: [:x | x copy left: nil]. result := self resultOfSerializeAndMaterialize: (FLPair new left: $A; yourself). self assert: result left isNil.! ! !FLPluggableSubstitutionTest methodsFor: 'tests' stamp: 'MartinDias 10/7/2011 16:33'! testTransientPair | result | self analyzer when: [:x | FLPair = x class] substituteBy: [:x | nil]. result := self resultOfSerializeAndMaterialize: FLPair new. self assert: result isNil.! ! !FLPluggableSubstitutionTest methodsFor: 'tests' stamp: 'MartinDias 5/9/2012 00:17'! testAvoidRecursion | result | self analyzer when: [:x | x < 10 ] substituteBy: [:x | x + 1 ]. result := self resultOfSerializeAndMaterialize: 1. self assert: result = 2.! ! !FLPluggableSubstitutionTest methodsFor: 'tests' stamp: 'MartinDias 5/8/2012 19:26'! testUniqueSubstitution "Tests that an object with two occurrences in the graph is substituted to the *same* object." | result | self analyzer when: [ :x | x isNumber ] substituteBy: [ :x | x printString ]. "This line demonstrates that behavior being tested is not trivial" self deny: 1 printString == 1 printString. result := self resultOfSerializeAndMaterialize: (Array with: 1 with: 1). self assert: result first = '1'. self assert: result first == result second.! ! !FLPluggableSubstitutionTest methodsFor: 'failures' stamp: 'MarianoMartinezPeck 11/17/2012 13:18'! expectedFailures ^ #(testPrivateExcludedAndWithConflicts)! ! !FLPluggableSubstitutionTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 9/18/2012 11:03'! testPrivateExcluded | result | self analyzer when: [:x | x isBehavior ] substituteBy: [:x | FLWeakClassMock ]. result := self resultOfSerializeAndMaterialize: {String new. FLPair}. self assert: result first class == ByteString. self assert: result second == FLWeakClassMock.! ! !FLPluggableSubstitutionTest methodsFor: 'tests' stamp: 'MartinDias 5/8/2012 20:03'! testSimple | result | self analyzer when: [:x | x < 0 ] substituteBy: [:x | 0 ]. result := self resultOfSerializeAndMaterialize: -1. self assert: result = 0.! ! !FLPluggableSubstitutionTest methodsFor: 'tests' stamp: 'MartinDias 10/7/2011 16:33'! testLowercaseSomeSymbols | result | self analyzer when: [:x | #A = x] substituteBy: [:x | #a]. self analyzer when: [:x | #B = x] substituteBy: [:x | #b]. result := self resultOfSerializeAndMaterialize: #(A B C). self assert: #(a b C) = result.! ! !FLPluggableSubstitutionTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 9/18/2012 11:03'! testPrivateExcludedAndWithConflicts | result | self analyzer when: [:x | FLPair == x ] substituteBy: [:x | FLWeakClassMock ]. result := self resultOfSerializeAndMaterialize: {FLPair new. FLPair}. self assert: result first class == FLPair. self assert: result second == FLWeakClassMock.! ! !FLPointCluster commentStamp: 'MarianoMartinezPeck 9/8/2011 22:33'! FLPointCluster is an optional class that optimizes Point instances, since there are a lot of instances in the system, it makes sense to optimize them. We take advantage of bytecode optimizations done by Pharo for messages like #@, #x and #y. In addition, we avoid the overhead of class reshape, etc. ! !FLPointCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeReferencesOf: aPoint with: aDecoder aPoint setX: aDecoder nextEncodedReference setY: aDecoder nextEncodedReference. ! ! !FLPointCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeInstanceWith: aDecoder "Since in Pharo #@ is associated with a special bytecode, it is faster than doing Point basicNew" ^ 0@0 ! ! !FLPointCluster methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 9/8/2011 21:37'! referencesOf: aPoint do: aBlock aBlock value: aPoint x. aBlock value: aPoint y. ! ! !FLPointerObjectCluster commentStamp: 'MartinDias 8/1/2011 03:00'! I have the common behavior for storing and loading pointer objects.! !FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeReferencesOf: anObject with: aDecoder variablesMapping materializeReferencesOf: anObject with: aDecoder! ! !FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:43'! serializeReferencesOf: anObject with: anEncoder variablesMapping serializeReferencesOf: anObject with: anEncoder ! ! !FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! afterMaterializationStepWith: aDecoder objects do: [ :anObject | anObject fuelAfterMaterialization ]! ! !FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:43'! serializeReferencesStepWith: anEncoder objects do: [ :anObject | self serializeReferencesOf: anObject with: anEncoder ]! ! !FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeReferencesStepWith: aDecoder objects do: [ :anObject | self materializeReferencesOf: anObject with: aDecoder ]! ! !FLPointerObjectCluster methodsFor: 'analyzing' stamp: 'MartinDias 12/22/2011 15:07'! referencesOf: anObject do: aBlock variablesMapping referencesOf: anObject do: aBlock! ! !FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:41'! clusterSerializeStepWith: aSerialization super clusterSerializeStepWith: aSerialization. variablesMapping serializeOn: aSerialization encoder.! ! !FLPointerObjectCluster methodsFor: 'initialize-release' stamp: 'MaxLeske 5/3/2013 17:43'! initializeAnalyzing: aClass super initializeAnalyzing: aClass. variablesMapping := FLVariablesMapping newAnalyzing: theClass references: self references! ! !FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:42'! clusterMaterializeStepWith: aMaterialization super clusterMaterializeStepWith: aMaterialization. variablesMapping := aMaterialization decoder variablesMappingFor: theClass.! ! !FLPositive16SmallIntegerCluster commentStamp: 'TorstenBergmann 2/3/2014 23:20'! unsigned, 16-bit integer cluster! !FLPositive16SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:51'! materializeInstanceWith: aDecoder ^ aDecoder nextEncodedUint16 ! ! !FLPositive16SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:51'! serializeInstance: anInteger with: anEncoder anEncoder encodeUint16: anInteger! ! !FLPositive24SmallIntegerCluster commentStamp: 'TorstenBergmann 2/3/2014 23:20'! unsigned, 24-bit integer! !FLPositive24SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/9/2012 11:52'! materializeInstanceWith: aDecoder ^ aDecoder nextEncodedUint24 ! ! !FLPositive24SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/9/2012 11:52'! serializeInstance: anInteger with: anEncoder anEncoder encodeUint24: anInteger! ! !FLPositive32SmallIntegerCluster commentStamp: 'TorstenBergmann 2/3/2014 23:20'! unsigned, 32-bit integer! !FLPositive32SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:57'! materializeInstanceWith: aDecoder ^ aDecoder nextEncodedUint32! ! !FLPositive32SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:57'! serializeInstance: anInteger with: anEncoder anEncoder encodeUint32: anInteger! ! !FLPositive8SmallIntegerCluster commentStamp: 'TorstenBergmann 2/3/2014 23:20'! unsigned, 8-bit integer! !FLPositive8SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:52'! materializeInstanceWith: aDecoder ^ aDecoder nextEncodedUint8! ! !FLPositive8SmallIntegerCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 6/8/2012 22:52'! serializeInstance: anInteger with: anEncoder anEncoder encodeUint8: anInteger! ! !FLPrimitiveCluster commentStamp: 'MartinDias 8/29/2011 19:21'! I am a cluster that serializes and materializes interacting directly with the stream.! !FLPrimitiveCluster methodsFor: 'analyzing' stamp: 'MartinDias 1/9/2012 17:12'! add: anObject traceWith: anAnalysis "Add an object to the cluster. We know the object doesn't have references." objects addLast: anObject! ! !FLPrimitiveCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 10/13/2011 16:26'! registerIndexesOn: aDictionary self flag: #todo. "Converting objects collection here in this method is a bit confusing. This is because since this cluster is for primitives, they do not have pointers to other objects. Hence, instead of storing them in a IdentitySet we can use an OrderedCollection and then just convert them at the end. For more details see FLPrimitiveCluster >> #add: anObject traceWith: aAnalysis" objects := objects asIdentitySet. super registerIndexesOn: aDictionary.! ! !FLPrimitiveCluster methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 13:12'! newAnalyzingCollection "Answer a collection for the objects that correspond to this cluster." ^OrderedCollection new! ! !FLPrimitiveCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:39'! clusterBucketIn: aClusterization ^aClusterization primitivesBucket ! ! !FLProcessSerializationTest methodsFor: 'tests' stamp: 'MaxLeske 5/2/2013 09:20'! testSerializingShortDelay | process | process := [ 2 timesRepeat: [ | d | d := Delay forMilliseconds: 50. d wait ] ] forkAt: Processor userBackgroundPriority. self shouldnt: [ self serialize: process ] raise: FLObjectNotFound! ! !FLProcessSerializationTest methodsFor: 'running' stamp: 'MaxLeske 5/4/2013 16:17'! setUpSerializer ^ serializer := FLDelayedSerializerMock newDefault! ! !FLProxyThatBecomesItsContent commentStamp: 'MartinDias 11/17/2011 03:18'! Used at #testObjectByProxyThatBecomesItsContent! !FLProxyThatBecomesItsContent methodsFor: 'serialization' stamp: 'MartinDias 11/17/2011 03:03'! fuelAfterMaterialization self become: contents! ! !FLProxyThatBecomesItsContent methodsFor: 'initialization' stamp: 'MartinDias 11/17/2011 03:04'! initializeWith: anObject super initialize. contents := anObject! ! !FLProxyThatBecomesItsContent class methodsFor: 'instance creation' stamp: 'MartinDias 11/17/2011 02:59'! newWith: aByteSymbol ^self basicNew initializeWith: aByteSymbol; yourself! ! !FLRectangleCluster commentStamp: 'MarianoMartinezPeck 9/8/2011 22:53'! FLRectangleCluster is an optional class that optimizes Rectangle instances, since there are a lot of instances in the system, it makes sense to optimize them. We take advantage of bytecode optimizations done by Pharo for messages like #new, #@, #x and #y. In addition, we avoid the overhead of class reshape, etc. ! !FLRectangleCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeReferencesOf: aRectangle with: aDecoder aRectangle setOrigin: aDecoder nextEncodedReference @ aDecoder nextEncodedReference corner: aDecoder nextEncodedReference @ aDecoder nextEncodedReference. ! ! !FLRectangleCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeInstanceWith: aDecoder "Since in Pharo #@ is associated with a special bytecode, it is faster than doing Point basicNew" ^ Rectangle basicNew! ! !FLRectangleCluster methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 9/8/2011 22:45'! referencesOf: aRectangle do: aBlock aBlock value: aRectangle origin x. aBlock value: aRectangle origin y. aBlock value: aRectangle corner x. aBlock value: aRectangle corner y.! ! !FLReplacementClassMock class methodsFor: 'accessing' stamp: 'MaxLeske 5/3/2013 16:28'! fuelReplacement ^ nil! ! !FLReplacementMock methodsFor: 'accessing' stamp: 'MaxLeske 5/3/2013 17:34'! dontIgnoreMe ignoreMe := false! ! !FLReplacementMock methodsFor: 'accessing' stamp: 'MaxLeske 5/3/2013 17:34'! ignoreMe ^ ignoreMe := true! ! !FLReplacementMock methodsFor: 'accessing' stamp: 'MaxLeske 5/3/2013 17:34'! fuelReplacement ^ ignoreMe ifTrue: [ nil ] ifFalse: [ self ]! ! !FLReplacementMock methodsFor: 'comparing' stamp: 'MaxLeske 5/3/2013 11:26'! = anObject ^ self class = anObject class! ! !FLSerialization commentStamp: 'MarianoMartinezPeck 10/23/2011 14:42'! I implement the algorithm for serializing an object graph on a stream. FLSerializer known how to build instances of me.! !FLSerialization methodsFor: 'accessing' stamp: 'MartinDias 9/9/2011 01:33'! root ^ root! ! !FLSerialization methodsFor: 'initialize-release' stamp: 'MaxLeske 5/3/2013 17:39'! initializeWith: anEncoder root: anObject analyzer: anAnalyzer self initialize. encoder := anEncoder. root := anObject fuelReplacement. analyzer := anAnalyzer.! ! !FLSerialization methodsFor: 'private' stamp: 'MartinDias 12/29/2011 18:06'! referencesStep clusters do: [ :aCluster | aCluster serializeReferencesStepWith: encoder ]! ! !FLSerialization methodsFor: 'private' stamp: 'MartinDias 12/29/2011 17:07'! trailerStep encoder encodeReferenceTo: root! ! !FLSerialization methodsFor: 'private' stamp: 'MaxLeske 5/3/2013 09:27'! analysisStep | anAnalysis | anAnalysis := analyzer analysisFor: root. clusters := anAnalysis clusterization clusters. encoder objectCount: anAnalysis clusterization objectCount ! ! !FLSerialization methodsFor: 'accessing' stamp: 'MartinDias 1/6/2012 12:24'! objects "Answer a collection with the serialized objects." ^ encoder objectsIndexes keys! ! !FLSerialization methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLSerialization methodsFor: 'serializing' stamp: 'MarianoMartinezPeck 7/26/2012 16:04'! run "Serialize the graph starting at the root object." self analysisStep. self headerStep. self instancesStep. self referencesStep. self trailerStep.! ! !FLSerialization methodsFor: 'private' stamp: 'MartinDias 12/29/2011 18:28'! headerStep encoder encodeYourself. encoder encodePositiveInteger: clusters size.! ! !FLSerialization methodsFor: 'accessing' stamp: 'MartinDias 9/13/2011 16:34'! clusters ^ clusters! ! !FLSerialization methodsFor: 'private' stamp: 'MarianoMartinezPeck 9/19/2012 14:40'! clusterInstancesStepOf: aCluster encoder encodeClusterClass: aCluster class. aCluster clusterSerializeStepWith: self. aCluster serializeInstancesStepWith: encoder. aCluster serializePostInstancesStepWith: encoder. ! ! !FLSerialization methodsFor: 'debugging' stamp: 'MarianoMartinezPeck 9/24/2013 15:57'! clustersSortedByAmountOfObjects ^ self clusters sorted: [ :a :b | a objects size > b objects size ]! ! !FLSerialization methodsFor: 'accessing' stamp: 'MartinDias 12/29/2011 16:55'! encoder ^ encoder! ! !FLSerialization methodsFor: 'private' stamp: 'MartinDias 1/6/2012 12:24'! instancesStep clusters do: [ :aCluster | aCluster registerIndexesOn: encoder objectsIndexes ]. clusters do: [ :aCluster | self clusterInstancesStepOf: aCluster ]! ! !FLSerialization class methodsFor: 'instance creation' stamp: 'MartinDias 1/5/2012 14:34'! with: anEncoder root: anObject analyzer: anAnalyzer ^ self basicNew initializeWith: anEncoder root: anObject analyzer: anAnalyzer; yourself! ! !FLSerializationError commentStamp: ''! I represent an error happened during serialization.! !FLSerializationError class methodsFor: 'exceptioninstantiator' stamp: 'MartinDias 3/20/2012 12:47'! signal: signalerText ^ super signal: 'Serialization error. ', signalerText ! ! !FLSerializationTest commentStamp: 'TorstenBergmann 2/3/2014 23:24'! Superclass for serialization tests! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/8/2011 04:05'! tearDownTraits self cleanUpTraits! ! !FLSerializationTest methodsFor: 'accessing' stamp: 'MartinDias 10/7/2011 16:33'! analyzer ^serializer analyzer! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 1/6/2012 11:07'! materializedObjects ^ self materialization objects! ! !FLSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 12/9/2011 20:28'! serializationOf: anObject self streamFactory writeStreamDo: [:aStream | ^ serializer serialize: anObject on: aStream. ]. ! ! !FLSerializationTest methodsFor: 'stream-strategies' stamp: 'MartinDias 10/12/2011 11:21'! useInMemorySerializationStream "This is a special factory to test what we offer with FLSerializer class >> #serializeInMemory: and FLMaterializer class >> #materializeFromByteArray: " streamFactory := FLByteArrayStreamStrategy new! ! !FLSerializationTest methodsFor: 'class-factory' stamp: 'MarianoMartinezPeck 4/19/2012 19:30'! withNotificationsNewClassWithInstanceVariableNames: instanceVariableNames "Returns a class for testing, with the specified instance variables." ^ classFactory withNotificationsNewClassWithInstanceVariableNames: instanceVariableNames! ! !FLSerializationTest methodsFor: 'stream-strategies' stamp: 'MartinDias 10/12/2011 11:21'! useMemoryStream streamFactory := FLMultiByteStreamStrategy new! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/6/2011 23:52'! setUpMaterializer materializer := FLMaterializer newDefault! ! !FLSerializationTest methodsFor: 'traits-factory' stamp: 'MarianoMartinezPeck 8/13/2012 22:20'! newTraitNamed: traitName inCategory: aCategory ^ Trait named: traitName asSymbol uses: Array new category: aCategory asSymbol! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/12/2011 10:56'! resultOfSerializeAndMaterialize: anObject self serialize: anObject. ^ self materialized ! ! !FLSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 7/28/2012 15:03'! materializationHeader self streamFactory readStreamDo: [:aStream | ^ self materializer materializeHeaderFrom: aStream ]! ! !FLSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 5/11/2012 10:46'! resultOfSerializeAndMaterializeMethod: aCompiledMethod self analyzer considerInternalMethod: aCompiledMethod. self serialize: aCompiledMethod. ^ self materialized ! ! !FLSerializationTest methodsFor: 'class-factory' stamp: 'MarianoMartinezPeck 4/19/2012 19:18'! withNotificationsNewClass ^ self classFactory withNotificationsNewClass! ! !FLSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 4/20/2012 21:38'! resultOfSerializeAndMaterializeCompiledMethod: aCompiledMethod | materialized | materialized := self resultOfSerializeAndMaterialize: aCompiledMethod. self assert: (materialized isEqualRegardlessTrailerTo: aCompiledMethod)! ! !FLSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 4/20/2012 21:35'! resultOfSerializeAndMaterializeMethodDictionary: aMethodDictionary | materialized | materialized := self resultOfSerializeAndMaterialize: aMethodDictionary. self assert: (materialized isEqualRegardlessMethodsTrailerTo: aMethodDictionary)! ! !FLSerializationTest methodsFor: 'class-factory' stamp: 'MarianoMartinezPeck 4/19/2012 19:19'! newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString ^ self classFactory silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 1/6/2012 11:07'! materialization self streamFactory readStreamDo: [:aStream | ^ self materializer materializeFrom: aStream ]! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 12/30/2011 19:03'! tearDownGlobalVariables Smalltalk globals removeKey: #FLGlobalVariableForTesting ifAbsent: []! ! !FLSerializationTest methodsFor: 'accessing' stamp: 'MartinDias 10/7/2011 16:31'! classFactory ^classFactory! ! !FLSerializationTest methodsFor: 'traits-factory' stamp: 'MartinDias 10/8/2011 04:03'! traitNamePrefix ^'FLTraitForTesting'! ! !FLSerializationTest methodsFor: 'cleaning' stamp: 'S 6/17/2013 13:16'! deleteFileNamed: aFilename aFilename asFileReference ensureDelete! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 1/6/2012 11:13'! serializationOf: anObject includes: anotherObject | serialization | self streamFactory writeStreamDo: [:aStream | serialization := serializer serialize: anObject on: aStream. ^ serialization objects includes: anotherObject ].! ! !FLSerializationTest methodsFor: 'running' stamp: 'MaxLeske 2/27/2013 21:49'! tearDown super tearDown. "Traits should be cleaned before classFactory because it seems class factory only knwos how to clean classes, not traits." self tearDownTraits. self tearDownClassFactory. self tearDownGlobalVariables. self tearDownInstanceVariables! ! !FLSerializationTest methodsFor: 'class-factory' stamp: 'MarianoMartinezPeck 4/19/2012 19:28'! newClassInCategory: aCategory ^ self classFactory silentlyNewClassInCategory: aCategory! ! !FLSerializationTest methodsFor: 'running' stamp: 'MaxLeske 2/27/2013 21:49'! tearDownInstanceVariables self class withAllSuperclasses do: [ :class | class = TestCase ifTrue: [ ^ self ]. class instVarNames do: [ :varName | self instVarNamed: varName put: nil ] ]! ! !FLSerializationTest methodsFor: 'traits-factory' stamp: 'MarianoMartinezPeck 4/19/2012 19:13'! newTraitSuffixed: suffix ^ Trait named: (self traitNamePrefix, suffix) asSymbol uses: Array new category: (self classFactory packageName, '-', self classFactory defaultCategoryPostfix) asSymbol! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/6/2011 23:52'! setUpSerializer serializer := FLSerializer newDefault! ! !FLSerializationTest methodsFor: 'class-factory' stamp: 'MarianoMartinezPeck 4/19/2012 19:14'! newClass ^ self newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' ! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 4/12/2012 17:21'! setUp super setUp. self setUpClassFactory. self setUpSerializer. self setUpMaterializer. "You have several stream strategies available on 'stream-strategies' category." self useMemoryStream. ! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/7/2011 16:29'! setUpClassFactory classFactory := ClassFactoryForTestCase new ! ! !FLSerializationTest methodsFor: 'cleaning' stamp: 'MarianoMartinezPeck 4/19/2012 19:39'! removeFromSystem: aClassOrTrait aClassOrTrait removeFromSystem: false! ! !FLSerializationTest methodsFor: 'accessing' stamp: 'MartinDias 10/12/2011 10:57'! streamFactory ^streamFactory! ! !FLSerializationTest methodsFor: 'stream-strategies' stamp: 'MartinDias 12/7/2011 02:11'! useMultiByteFileStream streamFactory := FLFileStreamStrategy newWithMultiByteFileStream! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/12/2011 10:58'! serialize: anObject self streamFactory writeStreamDo: [:aStream | self serializer serialize: anObject on: aStream ]! ! !FLSerializationTest methodsFor: 'traits-factory' stamp: 'MarianoMartinezPeck 4/19/2012 19:40'! cleanUpTraits Smalltalk globals allTraits select: [ :aTrait | aTrait name beginsWith: self traitNamePrefix ] thenDo: [ :aTrait | self removeFromSystem: aTrait ]! ! !FLSerializationTest methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 23:44'! materializer ^materializer! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/22/2012 10:39'! assertSerializationEqualityOf: anObject "Asserts that the original object and the materialized one are equal (but not the same)" | materialized | materialized := self resultOfSerializeAndMaterialize: anObject. self assert: anObject ~~ materialized description: 'The materialized object should not be the same as the serialized one'. self assert: anObject = materialized description: 'The materialized object should be equal to serialized one'.! ! !FLSerializationTest methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 23:44'! serializer ^serializer! ! !FLSerializationTest methodsFor: 'stream-strategies' stamp: 'MartinDias 10/12/2011 18:42'! useGzipInMemoryStream streamFactory := FLGZipStrategy newWithTarget: FLByteArrayStreamStrategy new! ! !FLSerializationTest methodsFor: 'stream-strategies' stamp: 'MartinDias 12/7/2011 02:11'! useStandardFileStream streamFactory := FLFileStreamStrategy newWithStandardFileStream! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 1/6/2012 11:07'! materialized ^ self materialization root! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 11/29/2011 20:44'! assertSerializationIdentityOf: anObject "Asserts that the original object and the materialized one are the same" | result | result := self resultOfSerializeAndMaterialize: anObject. self assert: anObject == result description: 'The materialized object is not the same as the serialized one'.! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/8/2011 01:26'! tearDownClassFactory self classFactory cleanUp! ! !FLSerializationTest class methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 10/31/2011 11:58'! packageNamesUnderTest ^ #('Fuel')! ! !FLSerializer commentStamp: 'MartinDias 8/29/2011 19:10'! I am a binary object serializer. An example of use: | sourceArray loadedArray | sourceArray := Array with: 'a string' with: Transcript with: [ Transcript show: 'a string' ]. "Store to the file" FLSerializer serialize: sourceArray toFileNamed: 'example.FL'. "Load from the file" loadedArray := FLMaterializer materializeFromFileNamed: 'example.FL'. "The arrays are not the same" [ sourceArray ~~ loadedArray ] assert. "The strings are not the same" [ sourceArray first ~~ loadedArray first ] assert. [ sourceArray first = loadedArray first ] assert. "The global instance Transcript is the same" [ sourceArray second == loadedArray second ] assert. "Appreciate in Transcript that the loaded block prints a string" loadedArray third value. ! !FLSerializer methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 22:56'! version: anObject version := anObject! ! !FLSerializer methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:40'! analyzer ^ analyzer ifNil: [ analyzer := self defaultAnalyzer ]! ! !FLSerializer methodsFor: 'protected' stamp: 'MartinDias 2/25/2013 14:46'! encodeHeaderWith: anEncoder "todo: fix how header is encoded" anEncoder encodeByte: (header isEmpty ifTrue: [0] ifFalse: [1]). header isEmpty ifFalse: [ self class newDefault serializationFactory value: header value: anEncoder ]! ! !FLSerializer methodsFor: 'protected' stamp: 'MartinDias 1/6/2012 20:31'! setDefaultSerialization ^ serializationFactory := [:anObject :anEncoder | (FLSerialization with: anEncoder root: anObject analyzer: self analyzer) run; yourself ]! ! !FLSerializer methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 5/30/2012 21:50'! stream: aStream stream := aStream! ! !FLSerializer methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLSerializer methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 22:56'! version ^ version! ! !FLSerializer methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/21/2012 16:49'! header ^ header! ! !FLSerializer methodsFor: 'accessing' stamp: 'MartinDias 8/20/2011 17:33'! analyzer: anObject analyzer := anObject! ! !FLSerializer methodsFor: 'initialization' stamp: 'MarianoMartinezPeck 7/28/2012 11:37'! initialize super initialize. self signature: self class defaultSignature. self version: self class currentVersion. header := FLHeader new.! ! !FLSerializer methodsFor: 'serializing' stamp: 'MarianoMartinezPeck 8/19/2012 23:57'! serialize: anObject toFileNamed: aFilename "Serialize the graph starting at the root object received and answers the FLSerialization object" StandardFileStream forceNewFileNamed: aFilename do: [ :aFileStream | aFileStream binary. self serialize: anObject on: aFileStream ] ! ! !FLSerializer methodsFor: 'header' stamp: 'MarianoMartinezPeck 7/28/2012 12:32'! addPostMaterializationAction: aCleanBlockClosure header addPostMaterializationAction: aCleanBlockClosure! ! !FLSerializer methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 22:56'! signature ^ signature! ! !FLSerializer methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 22:56'! signature: anObject signature := anObject! ! !FLSerializer methodsFor: 'serializing' stamp: 'MarianoMartinezPeck 5/30/2012 21:49'! serialize: anObject "Serialize the graph starting at the root object received and answers the FLSerialization object" ^ self serialize: anObject on: stream! ! !FLSerializer methodsFor: 'protected' stamp: 'MartinDias 9/13/2011 19:26'! defaultAnalyzer ^FLAnalyzer newDefault! ! !FLSerializer methodsFor: 'protected' stamp: 'MartinDias 1/7/2012 12:07'! encodeVersionWith: anEncoder anEncoder encodeUint16: self version ! ! !FLSerializer methodsFor: 'protected' stamp: 'MartinDias 1/7/2012 12:07'! encodeSignatureWith: anEncoder anEncoder encodeBytes: self signature asByteArray! ! !FLSerializer methodsFor: 'header' stamp: 'MarianoMartinezPeck 7/28/2012 11:38'! at: key putAdditionalObject: anObject "This is useful if we want to attach objects to a package that will also be serialized. The way they are stored is key-value." header at: key putAdditionalObject: anObject ! ! !FLSerializer methodsFor: 'serializing' stamp: 'MartinDias 2/24/2013 20:17'! serialize: anObject on: aStream "Serialize the graph starting at the root object received and answers the FLSerialization object" FLEncoder on: aStream globalEnvironment: self analyzer globalEnvironment do: [ :anEncoder | self encodeSignatureWith: anEncoder. self encodeVersionWith: anEncoder. self encodeHeaderWith: anEncoder. ^ self serializationFactory value: anObject value: anEncoder ]! ! !FLSerializer methodsFor: 'header' stamp: 'MarianoMartinezPeck 7/28/2012 11:38'! addPreMaterializationAction: aCleanBlockClosure header addPreMaterializationAction: aCleanBlockClosure! ! !FLSerializer methodsFor: 'protected' stamp: 'MartinDias 1/6/2012 20:31'! serializationFactory ^ serializationFactory ifNil: [ self setDefaultSerialization. serializationFactory ].! ! !FLSerializer class methodsFor: 'instance creation' stamp: 'MartinDias 9/25/2011 20:12'! newLight ^self new! ! !FLSerializer class methodsFor: 'serializing-shortcuts' stamp: 'mada 5/10/2012 20:56'! serialize: anObject toFileNamed: aFilename self newDefault serialize: anObject toFileNamed: aFilename! ! !FLSerializer class methodsFor: 'protected' stamp: 'MaxLeske 2/18/2014 14:11'! currentVersion "If you change this method, you should also create a version in ConfigurationOfFuel and FLMaterializer >> currentVersion" ^ 193! ! !FLSerializer class methodsFor: 'protected' stamp: 'MartinDias 10/6/2011 23:28'! defaultSignature ^ 'FUEL'! ! !FLSerializer class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 5/30/2012 21:48'! on: aStream ^ self newLight stream: aStream; yourself! ! !FLSerializer class methodsFor: 'serializing-shortcuts' stamp: 'MarianoMartinezPeck 5/11/2012 16:23'! serialize: anObject on: aStream self newDefault serialize: anObject on: aStream! ! !FLSerializer class methodsFor: 'instance creation' stamp: 'MartinDias 9/25/2011 20:12'! newDefault ^self newLight! ! !FLSerializer class methodsFor: 'serializing-shortcuts' stamp: 'MartinDias 1/11/2012 00:45'! serializeToByteArray: anObject "No stream is needed by the user. An internal in-memory stream will be used. This method returns a ByteArray representing the serialization" | aStream | aStream := WriteStream on: (ByteArray new: 100). self newDefault serialize: anObject on: aStream. ^ aStream contents! ! !FLSignatureTest commentStamp: 'TorstenBergmann 2/3/2014 23:31'! SUnit tests for fuel serializations, here signatures! !FLSignatureTest methodsFor: 'tests' stamp: 'MartinDias 10/7/2011 12:22'! testSameSignature serializer signature: 'FUELx'. materializer signature: 'FUELx'. self assertSerializationEqualityOf: 'content'! ! !FLSignatureTest methodsFor: 'tests' stamp: 'MartinDias 3/20/2012 12:59'! testBadSignature serializer signature: 'FUELx'. materializer signature: 'FUELy'. self should: [ self resultOfSerializeAndMaterialize: 'content' ] raise: FLBadSignature whoseDescriptionIncludes: 'FUELy' description: 'The materializer should raise an error when signature differs of the expected one.'! ! !FLSimpleCollectionCluster commentStamp: ''! A FLSimpleCollectionCluster is a special optional cluster that rather than using the default (variable object) serialization, uses #do: to iterate objects and #add: during materialization. So far we use it for Set, IdentitySet and OrderedCollection.! !FLSimpleCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 7/26/2012 16:10'! materializeReferencesOf: anObject with: aDecoder aDecoder nextEncodedPositiveInteger "anObject size" timesRepeat: [ anObject add: aDecoder nextEncodedReference ]! ! !FLSimpleCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MaxLeske 5/3/2013 09:49'! serializeReferencesOf: anObject with: anEncoder | refs | refs := self references at: anObject ifAbsent: [ ^ self ]. anEncoder encodePositiveInteger: refs first. refs allButFirst do: [ :each | anEncoder encodeReferenceTo: each ] ! ! !FLSimpleCollectionCluster methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 7/28/2012 22:27'! referencesOf: anObject do: aBlock aBlock value: anObject size. anObject do: [ :each | aBlock value: each ] ! ! !FLSimpleStack commentStamp: 'MarianoMartinezPeck 6/5/2011 12:29'! FLSimpleStack is a simple stack used in Fuel to avoid a recursion while traversing the graph to serialize. While analizing the content of an object (inst vars) we can encounter simple objects (direct string representation) or complex objects (composite). In the latter case we start analizing those instVars. So... Imagine object X with two instVars Y and Z. Imagine the method of the traverse is called #analye:. So you do #analize: X. Then, in such method you check whether X has regular pointers to regular objects, and if true, you analize them. So in this case you would send #analyze: Y and #analize: Z, generating the recursion. Right ? Notice that the time between analyse: Y and analyse: Z is dependent on the graph that is attached to Y. Y can have objects that have further objects etc. So leaving X aside, Y can be the first object to serialize and Z the last. With this FLSimpleStack, instead of sending #analyze: Y and #analize: Z what Fuel does is just to do a push on a stack: #push: Y and #push: Z. And then we are done with X, so we pop from the stack and we continue with the next object (at some point in the future we will pop Y and Z) When there are no more objects in the stack it means we are done. ! !FLSimpleStack methodsFor: 'adding' stamp: 'MartinDias 5/15/2011 23:15'! grow "Become larger in capacity." | newArray | newArray := Array new: array size * 2. newArray replaceFrom: 1 to: array size with: array startingAt: 1. array := newArray! ! !FLSimpleStack methodsFor: 'removing' stamp: 'MartinDias 5/15/2011 22:52'! pop "Returns the first element and remove it from the stack." slotIndex := slotIndex - 1. ^ array at: slotIndex ! ! !FLSimpleStack methodsFor: 'accessing' stamp: 'MartinDias 5/15/2011 23:08'! capacity ^ array size! ! !FLSimpleStack methodsFor: 'accessing' stamp: 'MartinDias 5/15/2011 22:54'! isEmpty ^ 1 = slotIndex! ! !FLSimpleStack methodsFor: 'printing' stamp: 'MartinDias 6/3/2011 20:25'! printOn: aStream "Append a sequence of characters that identify the receiver to aStream." super printOn: aStream. array printElementsOn: aStream ! ! !FLSimpleStack methodsFor: 'adding' stamp: 'MartinDias 5/15/2011 22:44'! push: anObject "Adds a new object of any kind on top of the stack." array at: slotIndex put: anObject. array size = slotIndex ifTrue: [ self grow ]. slotIndex := slotIndex + 1. ^ anObject.! ! !FLSimpleStack methodsFor: 'initialize-release' stamp: 'MartinDias 5/15/2011 23:10'! initialize: hintSize array := Array new: hintSize. slotIndex := 1.! ! !FLSimpleStack class methodsFor: 'instance creation' stamp: 'MartinDias 5/15/2011 23:09'! new: nElements "Create a Set large enough to hold nElements without growing" ^ self basicNew initialize: nElements! ! !FLSimpleStack class methodsFor: 'instance creation' stamp: 'MartinDias 5/15/2011 23:11'! hintSize ^64! ! !FLSimpleStack class methodsFor: 'instance creation' stamp: 'MartinDias 5/15/2011 23:11'! new ^ self new: self hintSize! ! !FLSimpleStackTest methodsFor: 'testing' stamp: 'MartinDias 10/5/2011 19:23'! testCapacity | stack | stack := FLSimpleStack new: 3. self assert: 3 = stack capacity. stack := FLSimpleStack new: 5. self assert: 5 = stack capacity.! ! !FLSimpleStackTest methodsFor: 'tests-adding' stamp: 'MartinDias 5/15/2011 23:13'! testGrow | stack | stack := FLSimpleStack new: 1. self assert: 1 = stack capacity. stack push: #a. self assert: 1 < stack capacity.! ! !FLSimpleStackTest methodsFor: 'testing' stamp: 'MartinDias 5/15/2011 22:50'! testPop | stack | stack := FLSimpleStack new. stack push: 1. stack pop. self assert: stack isEmpty.! ! !FLSimpleStackTest methodsFor: 'testing' stamp: 'MartinDias 5/15/2011 22:50'! testIsEmpty | stack | stack := FLSimpleStack new. self assert: stack isEmpty.! ! !FLSimpleStackTest methodsFor: 'testing' stamp: 'MartinDias 5/15/2011 22:50'! testPush | stack | stack := FLSimpleStack new. stack push: 1. self deny: stack isEmpty.! ! !FLSingletonMock commentStamp: 'TorstenBergmann 2/3/2014 23:28'! A mock for a singleton! !FLSingletonMock methodsFor: 'accessing' stamp: 'MML 10/19/2012 17:26'! reference ^ reference! ! !FLSingletonMock methodsFor: 'accessing' stamp: 'MML 10/19/2012 17:26'! reference: anObject ^ reference := anObject! ! !FLSingletonMock class methodsFor: 'accessing' stamp: 'MaxLeske 2/26/2013 22:37'! instance ^ Instance ifNil: [ Instance := self basicNew ]! ! !FLSingletonMock class methodsFor: 'accessing' stamp: 'MaxLeske 2/26/2013 22:37'! reset Instance := nil! ! !FLSingletonMock class methodsFor: 'instance creation' stamp: 'MML 10/19/2012 17:26'! new self error: 'I''m a singleton!!'! ! !FLSingletonMockEnforced commentStamp: 'TorstenBergmann 2/3/2014 23:29'! A test mock where a new instance is enforced! !FLSingletonMockEnforced class methodsFor: 'fuel' stamp: 'MaxLeske 2/20/2013 23:13'! fuelNew ^ self instance! ! !FLSingletonTest commentStamp: 'TorstenBergmann 2/3/2014 23:31'! SUnit tests for fuel serialization of singletons! !FLSingletonTest methodsFor: 'tests' stamp: 'MML 10/19/2012 17:31'! testSingletonMaterialization | singleton materialized | singleton := FLSingletonMock instance. singleton reference: 'a reference'. self assert: singleton equals: FLSingletonMock instance. materialized := self resultOfSerializeAndMaterialize: singleton. self deny: materialized == singleton. self deny: materialized reference isNil. self deny: materialized reference == singleton reference. FLSingletonMock reset "cannot do this in tearDown because that's used by some helper methods"! ! !FLSingletonTest methodsFor: 'tests' stamp: 'MML 10/19/2012 17:31'! testSingletonMaterializationEnforcedNoInstance | singleton materialized | singleton := FLSingletonMockEnforced instance. singleton reference: 'a reference'. self assert: singleton equals: FLSingletonMockEnforced instance. self serialize: singleton. FLSingletonMock reset. materialized := self materialized. self deny: materialized == singleton. self deny: materialized reference isNil. self assert: materialized reference equals: singleton reference. FLSingletonMock reset "cannot do this in tearDown because that's used by some helper methods"! ! !FLSingletonTest methodsFor: 'running' stamp: 'MML 10/19/2012 17:28'! setUp super setUp. FLSingletonMock reset! ! !FLSingletonTest methodsFor: 'tests' stamp: 'MML 10/19/2012 17:43'! testSingletonMaterializationEnforced | singleton materialized | singleton := FLSingletonMockEnforced instance. singleton reference: 'a reference'. self assert: singleton equals: FLSingletonMockEnforced instance. materialized := self resultOfSerializeAndMaterialize: singleton. self assert: materialized == singleton. self deny: materialized reference isNil. self assert: materialized reference == singleton reference. FLSingletonMock reset "cannot do this in tearDown because that's used by some helper methods"! ! !FLSmallIntegerCluster commentStamp: 'MartinDias 1/7/2012 11:57'! I don't have so much sense as a class.! !FLSortedCollectionSerializationTest commentStamp: 'TorstenBergmann 2/3/2014 23:30'! SUnit tests for fuel serialization of sorted collections! !FLSortedCollectionSerializationTest methodsFor: 'tests' stamp: 'MartinDias 3/26/2012 22:29'! testSortedCollectionWithInstanceVariableReference "Tests serialization of a SortedCollection whose sortBlock has a reference to the outer context. Note: Equality can not be used to assert, since its behavior is this: | x y | x := SortedCollection sortBlock: [:a :b | a >= b ]. y := SortedCollection sortBlock: [:a :b | a >= b ]. self assert: x ~= y" | aSortedCollection materialized | instanceVariableForTesting := false. aSortedCollection := self sortedBlockClosureWithInstanceVariable. materialized := self resultOfSerializeAndMaterialize: aSortedCollection. materialized addAll: #(2 3 1). aSortedCollection addAll: #(2 3 1). self assert: aSortedCollection asArray = materialized asArray. self assert: aSortedCollection asArray = #(3 2 1)! ! !FLSortedCollectionSerializationTest methodsFor: 'tests' stamp: 'mariano 12/4/2011 18:57'! testSortedCollectionWithClassVariableReference "Tests serialization of a SortedCollection whose sortBlock has a reference to the outer context. Note: Equality can not be used to assert, since its behavior is this: | x y | x := SortedCollection sortBlock: [:a :b | a >= b ]. y := SortedCollection sortBlock: [:a :b | a >= b ]. self assert: x ~= y" | aSortedCollection materialized | ClassVariableForTesting := false. aSortedCollection := self class sortedCollectionForTestingWithClassVariable. materialized := self resultOfSerializeAndMaterialize: aSortedCollection. ClassVariableForTesting := true. materialized addAll: #(2 3 1). aSortedCollection addAll: #(2 3 1). aSortedCollection sortBlock assertWellMaterializedInto: materialized sortBlock in: self. self assert: aSortedCollection asArray = materialized asArray.! ! !FLSortedCollectionSerializationTest methodsFor: 'tests' stamp: 'MartinDias 3/26/2012 22:28'! testSortedCollectionWithInstanceVariableReferenceChange "IMPORTANT: this test is to demonstrate a limitation. Unfortunatly there is nothing we can do to solve this problem. The sortBlock was serialized with a method context with different receiver, different temps, etc. Tests serialization of a SortedCollection whose sortBlock has a reference to the outer context. Note: Equality can not be used to assert, since its behavior is this: | x y | x := SortedCollection sortBlock: [:a :b | a >= b ]. y := SortedCollection sortBlock: [:a :b | a >= b ]. self assert: x ~= y" | aSortedCollection materialized | instanceVariableForTesting := false. aSortedCollection := self sortedBlockClosureWithInstanceVariable. materialized := self resultOfSerializeAndMaterialize: aSortedCollection. instanceVariableForTesting := true. materialized addAll: #(2 3 1). aSortedCollection addAll: #(2 3 1). "IMPORTANT: Unfortunatly there is nothing we can do to solve this problem. The sortBlock was serialized with a method context with different values." self deny: aSortedCollection asArray = materialized asArray.! ! !FLSortedCollectionSerializationTest methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 6/8/2011 17:50'! classVariableForTesting ^ ClassVariableForTesting! ! !FLSortedCollectionSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/26/2012 21:40'! sortedBlockClosureWithInstanceVariable ^ SortedCollection sortBlock: [ :a :b | instanceVariableForTesting ifTrue: [ a <= b ] ifFalse: [ a >= b ] ]! ! !FLSortedCollectionSerializationTest methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 6/8/2011 17:50'! classVariableForTesting: anObject ClassVariableForTesting := anObject ! ! !FLSortedCollectionSerializationTest methodsFor: 'tests' stamp: 'MartinDias 10/5/2011 19:24'! testSortedCollection "Tests that a SortedCollection works fine after materialization. Note: Equality can not be used to assert, since its behavior is this: | x y | x := SortedCollection sortBlock: [:a :b | a >= b ]. y := SortedCollection sortBlock: [:a :b | a >= b ]. self assert: x ~= y" | aSortBlock aSortedCollection materialized | aSortBlock := [:a :b | a >= b ]. aSortedCollection := SortedCollection sortBlock: aSortBlock. materialized := self resultOfSerializeAndMaterialize: aSortedCollection. self assert: aSortedCollection sortBlock ~~ materialized sortBlock. materialized addAll: #(2 1 3). aSortedCollection addAll: #(2 1 3). self assert: aSortedCollection asArray = materialized asArray.! ! !FLSortedCollectionSerializationTest methodsFor: 'tests' stamp: 'MarcusDenker 5/21/2013 15:20'! testSortedCollectionWithClassVariableChanges "Tests serialization of a SortedCollection whose sortBlock has a reference to a class variable and its value is changed. See also FLBlockClosureSerializationTest >> testBlockClosureWithClassVariableChanges and FLCompiledMethodSerializationTest >> testMethodChangingClassVariable" | aSortedCollection materialized mmethod index | ClassVariableForTesting := false. aSortedCollection := self class sortedCollectionForTestingWithClassVariable. materialized := self resultOfSerializeAndMaterialize: aSortedCollection. "the class variable ClassVariableForTesting should be false" mmethod := materialized sortBlock outerContext method. index := mmethod literals indexOf: (self class bindingOf: #ClassVariableForTesting). self deny: (mmethod literalAt: index) value. ClassVariableForTesting := true. "the class variable ClassVariableForTesting should be true" self assert: (mmethod literalAt: index) value. ! ! !FLSortedCollectionSerializationTest class methodsFor: 'sorted collections for testing' stamp: 'MarcusDenker 5/21/2013 15:21'! sortedCollectionForTestingWithClassVariable. ^ SortedCollection sortBlock: [:a :b | ClassVariableForTesting ifTrue: [ a <= b ] ifFalse: [ a >= b ] ]. ! ! !FLStreamStrategy commentStamp: 'MartinDias 10/12/2011 11:36'! I am a strategy that help tests for writing (and then reading) on streams.! !FLStreamStrategy methodsFor: 'serializing' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper "Visit myself as a substitution. See #fuelSubstitution." ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLStreamStrategy methodsFor: 'writing' stamp: 'MartinDias 10/12/2011 10:18'! writeStreamDo: aValuable "Evaluates the argument with a write stream. Answer the result." self subclassResponsibility ! ! !FLStreamStrategy methodsFor: 'reading' stamp: 'MartinDias 10/12/2011 10:18'! readStreamDo: aValuable "Evaluates the argument with a read stream. Answer the result." self subclassResponsibility ! ! !FLSubstitutionCluster commentStamp: 'MartinDias 1/9/2012 15:04'! I am a cluster for objects that have to be replaced in the object graph by another one (at serialization time). Examples of use: 1) Suppose you want to substitute instances of WriteStream by nil. In such case, WriteStream has to implement this method: fuelAccept: aVisitor ^aVisitor visitSubstitution: self by: nil 2) Suppose you want to substitute every integer in the graph by its string representation. In such case you should configure the analyzer through: anAnalyzer when: [:x | x isInteger] substituteBy: [:x | x printString]. In this way, when you serialize #(1 2), you will then materialize #('1' '2')! !FLSubstitutionCluster methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 10/16/2012 09:32'! isSubstitute: anObject ^ substitutes identityIncludes: anObject! ! !FLSubstitutionCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 8/20/2011 23:18'! registerIndexesOn: aDictionary substitutions keysAndValuesDo: [ :anObject :theSubstitution | | substitutionIndex | substitutionIndex := aDictionary at: theSubstitution. aDictionary at: anObject put: substitutionIndex. ].! ! !FLSubstitutionCluster methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 5/15/2012 11:52'! substitutions ^ substitutions ! ! !FLSubstitutionCluster methodsFor: 'printing' stamp: 'MartinDias 8/29/2011 01:16'! printOn: aStream super printOn: aStream. aStream nextPutAll: '->'. substitutions printElementsOn: aStream! ! !FLSubstitutionCluster methodsFor: 'accessing' stamp: 'MartinDias 8/29/2011 01:04'! objects "This cluster does not have objects" ^#()! ! !FLSubstitutionCluster methodsFor: 'initialize-release' stamp: 'MartinDias 5/9/2012 00:14'! initializeAnalyzing super initializeAnalyzing. substitutions := IdentityDictionary new. substitutes := IdentitySet new.! ! !FLSubstitutionCluster methodsFor: 'analyzing' stamp: 'MartinDias 5/9/2012 00:14'! add: anObject substitutedBy: anotherObject traceWith: aAnalysis substitutions at: anObject ifAbsent: [ substitutions at: anObject put: anotherObject. substitutes add: anotherObject. aAnalysis trace: anotherObject ].! ! !FLSubstitutionCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:39'! clusterBucketIn: aClusterization ^aClusterization substitutionsBucket! ! !FLTraitSerializationTest commentStamp: ''! I have the common behavior for testing trait serialization.! !FLTraitSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/8/2011 04:14'! newSecondaryTrait "Returns a trait for testing" ^ self newTraitSuffixed: 'Secondary'! ! !FLTraitSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 4/19/2012 19:13'! newInstanceFrom: aTrait | aClass | aClass := self newClass. "If one wants to use a materialized trait in a class, it has to be added to Smalltalk globals. Fuel does not do that. Fuel just materializes the trait. It is up to the user to decide what to do with it. " Smalltalk globals at: aTrait name put: aTrait. aClass addToComposition: aTrait. ^ aClass new! ! !FLTraitSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/8/2011 04:14'! newClassOrTrait "Returns a trait for testing" ^ self newTraitSuffixed: 'Main'! ! !FLUserGuidesTest commentStamp: 'TorstenBergmann 2/3/2014 23:30'! SUnit tests to guide users with fuel serialization! !FLUserGuidesTest methodsFor: 'tests-Managing Globals' stamp: 'MartinDias 5/19/2012 01:10'! testConsiderGlobal | aSerializer anArray materializedArray | "Prepare an array whose two elements are system globals." anArray := Array with: Set new with: Set new. Smalltalk at: #GlobalSet1 put: anArray first. Smalltalk at: #GlobalSet2 put: anArray second. "Serialize considering *only first* as a global object." FileStream forceNewFileNamed: 'demo.fuel' do: [:aStream | aSerializer := FLSerializer newDefault. aSerializer analyzer considerGlobal: #GlobalSet1. aSerializer serialize: anArray on: aStream binary]. "Materialize" FileStream oldFileNamed: 'demo.fuel' do: [:aStream | materializedArray := (FLMaterializer newDefault materializeFrom: aStream binary) root]. "Check that second element is a new Set." [ (Smalltalk at: #GlobalSet1) == materializedArray first ] assert. [ (Smalltalk at: #GlobalSet2) ~~ materializedArray second ] assert. ! ! !FLUserGuidesTest methodsFor: 'tests-Customizing Graph' stamp: 'MartinDias 5/24/2012 11:06'! testPluggableSubstitution | materialized objectToSerialize aSerializer | objectToSerialize := Array with: 'hello' with: '' writeStream. FileStream forceNewFileNamed: 'demo.fuel' do: [ :aStream | aSerializer := FLSerializer newDefault. aSerializer analyzer when: [ :o | o isStream ] substituteBy: [ :o | nil ]. aSerializer serialize: objectToSerialize on: aStream binary ]. FileStream oldFileNamed: 'demo.fuel' do: [ :aStream | (FLMaterializer newDefault materializeFrom: aStream binary) root ].! ! !FLUserGuidesTest methodsFor: 'running' stamp: 'MartinDias 2/16/2013 19:43'! tearDown super tearDown. #('demo.fuel' 'numbers.fuel' 'number.fuel.zip' 'example.FL' ) do: [:each | self deleteFileNamed: each ]. ! ! !FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: 'MartinDias 5/18/2012 14:33'! testFileShortcuts | materializedString | FLSerializer serialize: 'stringToSerialize' toFileNamed: 'demo.fuel'. materializedString := FLMaterializer materializeFromFileNamed: 'demo.fuel'. ! ! !FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: 'MartinDias 5/18/2012 15:39'! testGZip | materialization | FileStream forceNewFileNamed: 'number.fuel.zip' do: [:aFileStream | |gzip| aFileStream binary. gzip := GZipWriteStream on: aFileStream. FLSerializer newDefault serialize: 123 on: gzip. gzip close. ]. FileStream oldFileNamed: 'number.fuel.zip' do: [:aFileStream | |gzip| aFileStream binary. gzip := GZipReadStream on: aFileStream. materialization := FLMaterializer newDefault materializeFrom: gzip. gzip close. ].! ! !FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: 'MartinDias 5/18/2012 15:34'! testShowingProgressBar | materializedString | (Smalltalk globals includesKey: #FLProgressSerialization) ifFalse: [ " Needs: (ConfigurationOfFuel project latestVersion) load: 'FuelProgressUpdate'. " ^self ]. FileStream forceNewFileNamed: 'numbers.fuel' do: [:aStream | FLSerializer newDefault showProgress; serialize: (1 to: 200000) asArray on: aStream binary ]. FileStream oldFileNamed: 'numbers.fuel' do: [:aStream | FLMaterializer newDefault showProgress; materializeFrom: aStream binary ].! ! !FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: 'MartinDias 5/19/2012 00:48'! testFileStream | materializedString | FileStream forceNewFileNamed: 'demo.fuel' do: [:aStream | FLSerializer newDefault serialize: 'stringToSerialize' on: aStream binary]. FileStream oldFileNamed: 'demo.fuel' do: [:aStream | materializedString := (FLMaterializer newDefault materializeFrom: aStream binary) root].! ! !FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: 'MartinDias 5/18/2012 14:32'! testMemoryStream | anArray materializedString | anArray := FLSerializer serializeToByteArray: 'stringToSerialize'. materializedString := FLMaterializer materializeFromByteArray: anArray. ! ! !FLUserGuidesTest methodsFor: 'tests-Getting Started' stamp: 'MartinDias 5/18/2012 19:29'! testDemo | sourceArray loadedArray | sourceArray := Array with: 'a string' with: Transcript with: [ Transcript show: 'a string'; flush ]. "Store to the file" FLSerializer serialize: sourceArray toFileNamed: 'example.FL'. "Load from the file" loadedArray := FLMaterializer materializeFromFileNamed: 'example.FL'. "The arrays are not the same" [ sourceArray ~~ loadedArray ] assert. "The strings are not the same" [ sourceArray first ~~ loadedArray first ] assert. [ sourceArray first = loadedArray first ] assert. "The global instance Transcript is the same" [ sourceArray second == loadedArray second ] assert. "Look at Transcript how the loaded block prints a string" loadedArray third value.! ! !FLVariableObjectCluster commentStamp: 'MartinDias 5/30/2011 01:25'! I am a generic cluster for objects with indexable variables.! !FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 3/23/2012 12:34'! materializeReferencesOf: anObject with: aDecoder super materializeReferencesOf: anObject with: aDecoder. self materializeReferencesVariablePartOf: anObject with: aDecoder.! ! !FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:44'! serializeReferencesOf: anObject with: anEncoder super serializeReferencesOf: anObject with: anEncoder. self serializeReferencesVariablePartOf: anObject with: anEncoder. ! ! !FLVariableObjectCluster methodsFor: 'analyzing' stamp: 'MaxLeske 5/4/2013 10:35'! addVariableReferenceFrom: anObject to: anotherObject | list | list := self variableReferences at: anObject ifAbsent: [ nil ]. list ifNil: [ self variableReferences at: anObject put: (list := OrderedCollection new) ]. list add: anotherObject! ! !FLVariableObjectCluster methodsFor: 'accessing' stamp: 'MaxLeske 5/3/2013 17:31'! variableReferences ^ variableReferences ifNil: [ variableReferences := FLLargeIdentityDictionary new ]! ! !FLVariableObjectCluster methodsFor: 'analyzing' stamp: 'MaxLeske 5/4/2013 11:05'! add: anObject traceWith: aAnalysis "Add an object to the cluster and trace references." objects addIfNotPresent: anObject ifPresentDo: [ ^ self ]. self referencesOf: anObject do: [ :aChild || actual | actual := aChild fuelReplacement. self addReferenceFrom: anObject to: actual. aAnalysis trace: actual ]. self variablePartReferencesOf: anObject do: [ :aChild || actual | actual := aChild fuelReplacement. self addVariableReferenceFrom: anObject to: actual. aAnalysis trace: actual ]! ! !FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: 'MaxLeske 5/4/2013 10:24'! serializeReferencesVariablePartOf: anObject with: anEncoder (self variableReferences at: anObject ifAbsent: [ ^ self ]) do: [ :value | anEncoder encodeReferenceTo: value ]! ! !FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:44'! serializeInstance: anObject with: anEncoder anEncoder encodePositiveInteger: anObject basicSize! ! !FLVariableObjectCluster methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 12/6/2011 18:41'! variablePartReferencesOf: anObject do: aBlock 1 to: anObject basicSize do: [ :index | aBlock value: (anObject basicAt: index) ]! ! !FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 3/23/2012 12:34'! materializeReferencesVariablePartOf: anObject with: aDecoder 1 to: anObject basicSize do: [ :index | anObject basicAt: index put: aDecoder nextEncodedReference ]! ! !FLVariableObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/20/2013 21:46'! materializeInstanceWith: aDecoder ^theClass fuelNew: aDecoder nextEncodedPositiveInteger! ! !FLVariablesMapping commentStamp: 'MartinDias 8/1/2011 03:01'! I am used to materialize instance variables in an object, tolerating "class shape changing". Cases tolerated are: - instance variable added - instance variable order change - instance variable removed ! !FLVariablesMapping methodsFor: 'serialize/materialize' stamp: 'MartinDias 5/11/2012 14:07'! materializeReferencesOf: anObject with: aDecoder mapping do: [ :index | | reference | reference := aDecoder nextEncodedReference. index ifNotNil: [ anObject instVarAt: index put: reference ]].! ! !FLVariablesMapping methodsFor: 'serialize/materialize' stamp: 'MaxLeske 5/3/2013 17:41'! serializeReferencesOf: anObject with: anEncoder (self references at: anObject ifAbsent: [ ^ self ]) do: [ :value | anEncoder encodeReferenceTo: value ].! ! !FLVariablesMapping methodsFor: 'private' stamp: 'MartinDias 12/22/2011 15:24'! instanceVariableNamesToSerialize | ignoredInstanceVariableNames instanceVariableNamesToSerialize | ignoredInstanceVariableNames := theClass fuelIgnoredInstanceVariableNames. instanceVariableNamesToSerialize := OrderedCollection new. theClass instanceVariableNamesDo: [:name | (ignoredInstanceVariableNames includes: name) ifFalse: [ instanceVariableNamesToSerialize add: name ]]. ^ instanceVariableNamesToSerialize! ! !FLVariablesMapping methodsFor: 'initialize-release' stamp: 'MaxLeske 5/3/2013 17:42'! initializeWithClass: aClass references: aCollection self initialize. theClass := aClass. references := aCollection! ! !FLVariablesMapping methodsFor: 'accessing' stamp: 'MartinDias 1/11/2012 00:22'! map: sourceName to: destinationName | indexOfVariableToMap | indexOfVariableToMap := notIgnoredVariables indexOf: sourceName. indexOfVariableToMap > 0 ifTrue: [ mapping at: indexOfVariableToMap put: (theClass instVarIndexFor: destinationName ifAbsent: [self error: 'Bad variable destination.'])]. ! ! !FLVariablesMapping methodsFor: 'accessing' stamp: 'MaxLeske 5/3/2013 17:41'! references ^ references! ! !FLVariablesMapping methodsFor: 'serialize/materialize' stamp: 'MartinDias 1/7/2012 11:54'! initializeMaterializingFrom: aDecoder notIgnoredVariables := (1 to: aDecoder nextEncodedByte) collect: [ :index | aDecoder nextEncodedString ]. mapping := notIgnoredVariables collect: [ :name | theClass instVarIndexFor: name ifAbsent: [ nil ] ]. ! ! !FLVariablesMapping methodsFor: 'serialize/materialize' stamp: 'MartinDias 1/8/2012 14:42'! initializeAnalyzing notIgnoredVariables := self instanceVariableNamesToSerialize. mapping := notIgnoredVariables collect: [ :name | theClass instVarIndexFor: name ].! ! !FLVariablesMapping methodsFor: 'analyzing' stamp: 'MartinDias 12/22/2011 15:08'! referencesOf: anObject do: aBlock mapping do: [ :index | aBlock value: (anObject instVarAt: index) ].! ! !FLVariablesMapping methodsFor: 'initialize-release' stamp: 'MaxLeske 5/3/2013 17:03'! initializeWithClass: aClass self initialize. theClass := aClass! ! !FLVariablesMapping methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 20:10'! serializeOn: anEncoder anEncoder encodeByte: notIgnoredVariables size. notIgnoredVariables do: [ :name | anEncoder encodeString: name ].! ! !FLVariablesMapping class methodsFor: 'instance creation' stamp: 'MaxLeske 5/3/2013 17:03'! materializing: aClass from: aDecoder ^ self basicNew initializeWithClass: aClass; initializeMaterializingFrom: aDecoder; yourself.! ! !FLVariablesMapping class methodsFor: 'instance creation' stamp: 'MaxLeske 5/3/2013 17:42'! newAnalyzing: anAnalysis references: aCollection ^ self basicNew initializeWithClass: anAnalysis references: aCollection; initializeAnalyzing; yourself! ! !FLVersionTest commentStamp: 'TorstenBergmann 2/3/2014 23:29'! SUnit tests for fuel versioning! !FLVersionTest methodsFor: 'tests' stamp: 'MartinDias 3/20/2012 12:59'! testBadVersion serializer version: 2. materializer version: 1. self should: [ self resultOfSerializeAndMaterialize: 'content' ] raise: FLBadVersion whoseDescriptionIncludes: '2' description: 'The materializer should raise an error when version differs of the expected one.'! ! !FLVersionTest methodsFor: 'tests' stamp: 'MartinDias 10/7/2011 12:24'! testSameVersion serializer version: 1. materializer version: 1. self assertSerializationEqualityOf: 'content'! ! !FLWeakClassMock commentStamp: 'TorstenBergmann 2/3/2014 23:23'! Test mock for a weak class! !FLWeakClassMock methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 12/6/2011 21:23'! instVar1 ^ instVar1 ! ! !FLWeakClassMock methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 12/6/2011 21:22'! instVar1: anObject instVar1 := anObject! ! !FLWeakObjectsTest commentStamp: 'TorstenBergmann 2/3/2014 23:29'! SUnit tests for fuel serialization of weak objects! !FLWeakObjectsTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 12/6/2011 12:11'! testWeakAndNoStrongReferenceFromGraph "This tests when there are weak objects inside the graph to serialize but there are no strong references from the graph." | weak graph obj1 obj2 materializedGraph | obj1 := 11. obj2 := 'something'. weak := WeakArray with: obj1 with: obj2. graph := OrderedCollection with: 40 with: 'aaaa' with: weak. materializedGraph := self resultOfSerializeAndMaterialize: graph. self assert: (materializedGraph at: 3) first isNil. self assert: (materializedGraph at: 3) second isNil. self deny: (self serializationOf: graph includes: 11). self deny: (self serializationOf: graph includes: 'something'). ! ! !FLWeakObjectsTest methodsFor: 'tests' stamp: 'MartinDias 3/22/2012 22:54'! testAssociationWithWeakFinalizationList "This tests an association with WeakFInalizationList as its value." | weak association materializedAssociation object list | object := Object new. list := WeakFinalizationList new. weak := WeakFinalizerItem new list: list object: object executor: nil. association := Association key: #foo value: weak. materializedAssociation := self resultOfSerializeAndMaterialize: association. "Both, 'executor' and 'list' are fixed instance variables, hence they are strong and hence should not be replaced by nil. Instead, 'object' is stored in the variable part of WeakFinalizationItem, so it is weak and so it should have been replaced by nil." self assert: materializedAssociation value executor isNil. self assert: materializedAssociation value list isNil not. self assert: materializedAssociation value object isNil. self assert: materializedAssociation key = #foo. ! ! !FLWeakObjectsTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 12/6/2011 19:16'! testAssociationWithWeak "This tests an association with weak values. InstVar1 is a fixed instance variable, hence they are strong and hence should not be replaed by nil. Instead, 'weak' is stored in the variable part of FLWeakClassMock, so it is weak and so it should have been replaced by nil." | weak association materializedAssociation | weak := FLWeakClassMock new: 1. weak instVar1: 'nonWeak'. weak basicAt: 1 put: 'weak'. association := Association key: #foo value: weak. materializedAssociation := self resultOfSerializeAndMaterialize: association. self assert: materializedAssociation value instVar1 isNil not. self assert: (materializedAssociation value basicAt: 1) isNil. self assert: materializedAssociation key = #foo. ! ! !FLWeakObjectsTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 12/6/2011 12:11'! testWeakWithStrongReferenceFromGraph "This tests when there are weak objects inside the graph to serialize and there are also strong references from the graph." | weak graph obj1 obj2 materializedGraph | obj1 := 11. obj2 := 'something'. weak := WeakArray with: obj1 with: obj2. graph := OrderedCollection with: 40 with: 'aaaa' with: weak with: obj2. materializedGraph := self resultOfSerializeAndMaterialize: graph. self assert: (materializedGraph at: 3) first isNil. self assert: (materializedGraph at: 3) second = obj2. self deny: (self serializationOf: graph includes: 11). self assert: (self serializationOf: graph includes: obj2). ! ! !FLWeakObjectsTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 12/6/2011 13:59'! testWeakWithStrongReferenceFromGraph2 "This tests when there are weak objects inside the graph to serialize and there are also strong references from the graph." | weak graph obj1 obj2 materializedGraph | obj1 := 11. obj2 := 'something'. weak := WeakArray with: obj1 with: obj2. graph := OrderedCollection with: 40 with: 'aaaa' with: weak with: obj2 with: (Point x: weak y: weak). materializedGraph := self resultOfSerializeAndMaterialize: graph. self assert: (materializedGraph at: 3) first isNil. self assert: (materializedGraph at: 3) second = obj2. self deny: (self serializationOf: graph includes: 11). self assert: (self serializationOf: graph includes: obj2). ! ! !FLWeakVariableObjectCluster commentStamp: ''! I am a cluster for objects with weak indexable variables.! !FLWeakVariableObjectCluster methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 12/6/2011 19:22'! variablePartReferencesOf: anObject do: aBlock "Since the variable part of Weak classes are weak references, we should not do nothing here."! ! !FLWeakVariableObjectCluster methodsFor: 'analyzing' stamp: 'MartinDias 2/17/2012 03:24'! clusterReferencesDo: aBlock "Ensures that nil could be encoded, later in references step." super clusterReferencesDo: aBlock. aBlock value: nil! ! !FLWeakVariableObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:44'! serializeReferencesVariablePartOf: anObject with: anEncoder 1 to: anObject basicSize do: [ :index | anEncoder encodeWeakReferenceTo: (anObject basicAt: index) ]! ! !FLWordObjectCluster commentStamp: 'MarianoMartinezPeck 9/6/2011 22:50'! I am the generic cluster for storing and loading variable word objects. Most word-like objects are subclasses from ArrayedCollection. Hence, we may have used the method #writeOn: to serialize, and #newFromStream: to materialize. #writeOn: is slow because it ALWAYS encode wors in a big endian format. Most machines today are even little endian. Even worst, #newFromStream: has to always do a #restoreEndianness. #newFromStream: is fast because it uses the method #nextWordsInto: which is a hack but that is really fast. The problem is that #nextWordsInto: has to always do the #restoreEndianness when we are in little endian machines (most of the time). Hence, this cluster provives the best of both worlds: the serialization is done with a platform-dependen way, that is, the endianness will be the same of the machine where we are serializing. In addition, we serialize with the same hack that #nextWordsInto: uses, that is, the Bitmap >> hackBits: And the materialization will use a variation of #nextWordsInto: (#fuelNextWordsInto:) that ONLY does the #restoreEndianness if the machine where we are materializing has a different endianness than where we have serialized the object. To do this, while serializing, we store in the header of the Fuel stream, the endianness. Then in materialization, we compare agains that. Conclusion: we only restore endianness when needed. Notice, in addition, that the method #newFromStream: sends the message #restoreEndianness. This method EXPECTS that the object was serialized in big endian format, and it will only change the endianness if we are materializing in a little endian machine. This means that if you serialize in little endian and materialize in big endian, you are screw. For this reason, this cluster uses a method that always change the endianness, Bitmap class >> swapBytesIn:from:to: Future work: maybe we can modify and use the Bitmap hackBits: not only for materialization but also for serialization. ! !FLWordObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 20:05'! serializeInstance: aWordObject with: anEncoder anEncoder encodePositiveInteger: aWordObject basicSize. anEncoder encodeWords: aWordObject ! ! !FLWordObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 20:59'! materializeInstanceWith: aDecoder | inst wideSize | wideSize := aDecoder nextEncodedPositiveInteger. inst := theClass basicNew: wideSize. aDecoder nextEncodedWordsInto: inst. (aDecoder isBigEndian = Smalltalk isBigEndian asBit) ifTrue: [^ inst ] ifFalse: [ ^ self swapBytesOf: inst ] ! ! !FLWordObjectCluster methodsFor: 'endianness' stamp: 'MarianoMartinezPeck 9/6/2011 12:34'! swapBytesOf: aWordObject Bitmap swapBytesIn: aWordObject from: 1 to: aWordObject basicSize. ^ aWordObject! ! !FT2BitmapSize commentStamp: ''! Do not rearrange these fields!! This structure models the size of a bitmap strike (i.e., a bitmap instance of the font for a given resolution) in a fixed-size font face. It is used for the `availableSizes' field of the FT2Face structure. height :: The (vertical) baseline-to-baseline distance in pixels. It makes most sense to define the height of a bitmap font in this way. width :: The average width of the font (in pixels). Since the algorithms to compute this value are different for the various bitmap formats, it can only give an additional hint if the `height' value isn't sufficient to select the proper font. For monospaced fonts the average width is the same as the maximum width. size :: The point size in 26.6 fractional format this font shall represent (for a given vertical resolution). x_ppem :: The horizontal ppem value (in 26.6 fractional format). y_ppem :: The vertical ppem value (in 26.6 fractional format). Usually, this is the `nominal' pixel height of the font. The values in this structure are taken from the bitmap font. If the font doesn't provide a parameter it is set to zero to indicate that the information is not available. The following formula converts from dpi to ppem: ppem = size * dpi / 72 where `size' is in points. Windows FNT: The `size' parameter is not reliable: There exist fonts (e.g., app850.fon) which have a wrong size for some subfonts; x_ppem and y_ppem are thus set equal to pixel width and height given in in the Windows FNT header. TrueType embedded bitmaps: `size', `width', and `height' values are not contained in the bitmap strike itself. They are computed from the global font parameters. ! !FT2Constants commentStamp: ''! The various flags from the Freetype/2 header. The LoadXXXX flags can be used with primitiveLoadGlyph:flags: or with the Cairo primCairoFtFontCreateForFtFace:flags:scale: primitives. FT_LOAD_DEFAULT :: Corresponding to 0, this value is used a default glyph load. In this case, the following will happen: 1. FreeType looks for a bitmap for the glyph corresponding to the face's current size. If one is found, the function returns. The bitmap data can be accessed from the glyph slot (see note below). 2. If no embedded bitmap is searched or found, FreeType looks for a scalable outline. If one is found, it is loaded from the font file, scaled to device pixels, then "hinted" to the pixel grid in order to optimize it. The outline data can be accessed from the glyph slot (see note below). Note that by default, the glyph loader doesn't render outlines into bitmaps. The following flags are used to modify this default behaviour to more specific and useful cases. FT_LOAD_NO_SCALE :: Don't scale the vector outline being loaded to 26.6 fractional pixels, but kept in font units. Note that this also disables hinting and the loading of embedded bitmaps. You should only use it when you want to retrieve the original glyph outlines in font units. FT_LOAD_NO_HINTING :: Don't hint glyph outlines after their scaling to device pixels. This generally generates "blurrier" glyphs in anti-aliased modes. This flag is ignored if @FT_LOAD_NO_SCALE is set. FT_LOAD_RENDER :: Render the glyph outline immediately into a bitmap before the glyph loader returns. By default, the glyph is rendered for the @FT_RENDER_MODE_NORMAL mode, which corresponds to 8-bit anti-aliased bitmaps using 256 opacity levels. You can use either @FT_LOAD_TARGET_MONO or @FT_LOAD_MONOCHROME to render 1-bit monochrome bitmaps. This flag is ignored if @FT_LOAD_NO_SCALE is set. FT_LOAD_NO_BITMAP :: Don't look for bitmaps when loading the glyph. Only scalable outlines will be loaded when available, and scaled, hinted, or rendered depending on other bit flags. This does not prevent you from rendering outlines to bitmaps with @FT_LOAD_RENDER, however. FT_LOAD_VERTICAL_LAYOUT :: Prepare the glyph image for vertical text layout. This basically means that `face.glyph.advance' will correspond to the vertical advance height (instead of the default horizontal advance width), and that the glyph image will be translated to match the vertical bearings positions. FT_LOAD_FORCE_AUTOHINT :: Force the use of the FreeType auto-hinter when a glyph outline is loaded. You shouldn't need this in a typical application, since it is mostly used to experiment with its algorithm. FT_LOAD_CROP_BITMAP :: Indicates that the glyph loader should try to crop the bitmap (i.e., remove all space around its black bits) when loading it. This is only useful when loading embedded bitmaps in certain fonts, since bitmaps rendered with @FT_LOAD_RENDER are always cropped by default. FT_LOAD_PEDANTIC :: Indicates that the glyph loader should perform pedantic verifications during glyph loading, rejecting invalid fonts. This is mostly used to detect broken glyphs in fonts. By default, FreeType tries to handle broken fonts also. FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH :: Indicates that the glyph loader should ignore the global advance width defined in the font. As far as we know, this is only used by the X-TrueType font server, in order to deal correctly with the incorrect metrics contained in DynaLab's TrueType CJK fonts. FT_LOAD_NO_RECURSE :: This flag is only used internally. It merely indicates that the glyph loader should not load composite glyphs recursively. Instead, it should set the `num_subglyph' and `subglyphs' values of the glyph slot accordingly, and set "glyph->format" to @FT_GLYPH_FORMAT_COMPOSITE. The description of sub-glyphs is not available to client applications for now. FT_LOAD_IGNORE_TRANSFORM :: Indicates that the glyph loader should not try to transform the loaded glyph image. This doesn't prevent scaling, hinting, or rendering. FT_LOAD_MONOCHROME :: This flag is used with @FT_LOAD_RENDER to indicate that you want to render a 1-bit monochrome glyph bitmap from a vectorial outline. Note that this has no effect on the hinting algorithm used by the glyph loader. You should better use @FT_LOAD_TARGET_MONO if you want to render monochrome-optimized glyph images instead. FT_LOAD_LINEAR_DESIGN :: Return the linearly scaled metrics expressed in original font units instead of the default 16.16 pixel values. FT_LOAD_NO_AUTOHINT :: Indicates that the auto-hinter should never be used to hint glyph outlines. This doesn't prevent native format-specific hinters from being used. This can be important for certain fonts where unhinted output is better than auto-hinted one. One of following flags (as LoadTargetXXX) can be used to further specify the result. FT_RENDER_MODE_NORMAL :: This is the default render mode; it corresponds to 8-bit anti-aliased bitmaps, using 256 levels of opacity. FT_RENDER_MODE_LIGHT :: This is similar to @FT_RENDER_MODE_NORMAL, except that this changes the hinting to prevent stem width quantization. This results in glyph shapes that are more similar to the original, while being a bit more fuzzy ("better shapes", instead of "better contrast" if you want :-). FT_RENDER_MODE_MONO :: This mode corresponds to 1-bit bitmaps. FT_RENDER_MODE_LCD :: This mode corresponds to horizontal RGB/BGR sub-pixel displays, like LCD-screens. It produces 8-bit bitmaps that are 3 times the width of the original glyph outline in pixels, and which use the @FT_PIXEL_MODE_LCD mode. FT_RENDER_MODE_LCD_V :: This mode corresponds to vertical RGB/BGR sub-pixel displays (like PDA screens, rotated LCD displays, etc.). It produces 8-bit bitmaps that are 3 times the height of the original glyph outline in pixels and use the @FT_PIXEL_MODE_LCD_V mode. The LCD-optimized glyph bitmaps produced by FT_Render_Glyph are _not filtered_ to reduce color-fringes. It is up to the caller to perform this pass. ! !FT2Constants class methodsFor: 'class initialization' stamp: 'tween 8/13/2006 15:55'! initialize "FT2Constants initialize" LoadDefault := 0. LoadNoScale := 1. LoadNoHinting := 2. LoadRender := 4. LoadNoBitmap := 8. LoadVerticalLayout := 16. LoadForceAutohint := 32. LoadCropBitmap := 64. LoadPedantic := 128. LoadIgnoreGlobalAdvanceWidth := 512. LoadNoRecurse := 1024. LoadIgnoreTransform := 2048. LoadMonochrome := 4096. LoadLinearDesign := 8192. LoadSbitsOnly := 16384. LoadNoAutohint := 32768. "One of these flags may be OR'd with the above." LoadTargetNormal := 0. LoadTargetLight := 1 bitShift: 16. LoadTargetMono := 2 bitShift: 16. LoadTargetLCD := 3 bitShift: 16. LoadTargetLCDV := 4 bitShift: 16. "rendering mode constants" RenderModeNormal := 0. RenderModeLight := 1. RenderModeMono := 2. RenderModeLCD := 3. RenderModeLCDV := 4. "pixel mode constants" PixelModeNone := 0. PixelModeMono := 1. PixelModeGray := 2. PixelModeGray2 := 3. PixelModeGray4 := 4. PixelModeLCD := 5. PixelModeLCDV := 6. StyleFlagItalic := 1. StyleFlagBold := 2. ! ! !FT2Error commentStamp: ''! This is an Error that knows how to get the Freetype2 error code and string.! !FT2Error methodsFor: 'accessing' stamp: 'nk 11/4/2004 13:31'! errorCode errorCode ifNotNil: [^ errorCode]. ^ errorCode := [FT2Library errorCode] on: Error do: [:ex | ex return: 'can''t get error code']! ! !FT2Error methodsFor: 'accessing' stamp: 'nk 11/4/2004 13:31'! errorString errorString ifNotNil: [^ errorString]. ^ errorString := [FT2Library errorString] on: Error do: [:ex | ex return: 'can''t get error string']! ! !FT2Error methodsFor: 'accessing' stamp: 'nk 3/17/2005 12:50'! messageText ^String streamContents: [ :strm | messageText ifNotNil: [ strm nextPutAll: messageText; space ]. self errorCode isZero ifFalse: [ strm nextPutAll: '[error '; print: self errorCode; nextPutAll: ']['; nextPutAll: self errorString; nextPut: $] ]]! ! !FT2Face commentStamp: ''! Do not rearrange these fields!! New fields should go at the end, because the plugin has to know about these indexes. ByteArray representing a pointer to the malloc'd FT_Face struct: handle Copied from the FT_Face struct on creation: numFaces faceIndex faceFlags styleFlags numGlyphs familyName styleName numFixedSizes availableSizes numCharmaps charmaps Copied on creation, but only relevant to scalable outlines: bbox unitsPerEm ascender descender height maxAdvanceWidth maxAdvanceHeight underlinePosition underlineThickness Working memory: glyph -- FT2GlyphSlot, set by loadGlyph or loadChar size -- the active size, set by activateSize, used by loadGlyph, getKerning, etc. charmap -- set by setCharmap ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/2/2006 20:45'! primTransformGlyphSlotOutline: anIntegerArray ^self primitiveFailed.! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 18:05'! primLoadCharacter: index flags: flags ^self primitiveFailed! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! maxAdvanceWidth ^maxAdvanceWidth! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! numFaces ^numFaces! ! !FT2Face methodsFor: 'private' stamp: 'tween 7/29/2006 11:31'! primLoadFields ^self primitiveFailed! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 17:06'! bbox bbox ifNil: [bbox := Rectangle new. self primLoadBbox: bbox]. ^ bbox! ! !FT2Face methodsFor: 'private-primitives' stamp: 'bf 11/19/2005 12:56'! primRenderGlyphIntoForm: aForm ^self primitiveFailed! ! !FT2Face methodsFor: 'rendering' stamp: 'tween 8/13/2006 15:57'! renderGlyphIntoForm: aForm pixelMode: anInteger "render the current glyph (selected by loadChar/loadGlyph into the given form (1 or 8 bpp) with pixel mode anInteger " self primRenderGlyphIntoForm: aForm pixelMode: anInteger ! ! !FT2Face methodsFor: 'charmaps' stamp: 'nk 11/3/2004 19:36'! getCharMap self primGetCharMap.! ! !FT2Face methodsFor: 'glyphs' stamp: 'jl 5/30/2006 14:08'! glyphOfCharacter: aCharacter "load a glyph with outline, glyph is not scaled " | em aGlyph | em := self unitsPerEm. self validate. self setPixelWidth: em height: em. self loadCharacter: aCharacter asInteger flags: LoadIgnoreTransform. "load glyph metrics" aGlyph := self glyph shallowCopy. " copy because 'face glyph' is only a slot" aGlyph outline: (self characterOutline: aCharacter). ^aGlyph! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! height ^height! ! !FT2Face methodsFor: 'kerning' stamp: 'tween 3/11/2007 21:17'! kerningLeft: leftCharacter right: rightCharacter [^self primGetKerningLeft: (self primGetCharIndex: leftCharacter asInteger) right: (self primGetCharIndex: rightCharacter asInteger) ] on: FT2Error do:[:e | ^0@0]! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:35'! primSetPixelWidth: x height: y ^self primitiveFailed.! ! !FT2Face methodsFor: 'private' stamp: 'tween 7/31/2006 21:30'! loadFields self isValid ifTrue:[ [self primLoadFields] on: FT2Error do:[:e | "need to do something here"]]! ! !FT2Face methodsFor: 'testing' stamp: 'tween 8/7/2006 08:47'! isItalic styleFlags == nil ifTrue:[^false]. ^styleFlags allMask: StyleFlagItalic! ! !FT2Face methodsFor: 'accessing' stamp: 'bf 11/17/2005 15:56'! glyph glyph ifNil: [ glyph := FT2GlyphSlot fromFace: self ]. ^glyph! ! !FT2Face methodsFor: 'rendering' stamp: 'tween 8/2/2006 17:40'! angle: angle scalePoint: scalePoint offset: aPoint slant: slant | oneX oneY matrix delta slantOne| oneX := (16r10000 * scalePoint x) asInteger. oneY := (16r10000 * scalePoint y) asInteger. slantOne := (16r10000 * scalePoint x * slant) asInteger. matrix := IntegerArray new: 4. angle isZero ifTrue: [ matrix at: 1 put: oneX. matrix at: 2 put: slantOne. matrix at: 4 put: oneY. ] ifFalse: [ | phi cos sin | phi := angle degreesToRadians. cos := (phi sin * oneX) rounded. sin := (phi cos * oneY) rounded. matrix at: 1 put: sin. matrix at: 2 put: cos negated. matrix at: 3 put: cos. matrix at: 4 put: sin. ]. delta := IntegerArray new: 2. delta at: 1 put: (aPoint x * 64) rounded. delta at: 2 put: (aPoint y * 64) rounded. self primSetTransform: matrix delta: delta. ! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 19:35'! primGetCharMap ^self primitiveFailed! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 21:05'! charmaps "Answer an Array of Strings naming the different character maps available for setCharMap:" charmaps ifNil: [ charmaps := Array new: numCharmaps. self getCharMapsInto: charmaps ]. ^charmaps! ! !FT2Face methodsFor: 'glyphs' stamp: 'nk 11/3/2004 18:23'! setPixelWidth: x height: y self primSetPixelWidth: x height: y! ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/13/2006 15:56'! primRenderGlyphIntoForm: aForm pixelMode: anInteger ^self primitiveFailed! ! !FT2Face methodsFor: 'charmaps' stamp: 'nk 11/3/2004 20:38'! getCharMapsInto: array self primGetCharMapsInto: array.! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! familyName ^familyName! ! !FT2Face methodsFor: 'private-primitives' stamp: 'bf 11/18/2005 19:33'! primSetBitmapLeft: x top: y ^self primitiveFailed.! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! underlineThickness ^underlineThickness! ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 7/24/2006 21:10'! primNewMemoryFaceByteSize: anInteger index: anInteger2 ^self primitiveFailed! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! numFixedSizes ^numFixedSizes! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:34'! primLoadBbox: aRectangle ^self primitiveFailed.! ! !FT2Face methodsFor: 'private-primitives' stamp: 'jl 5/30/2006 13:21'! primGetCharIndex: characterCode "Return the glyph index of a given character code" ^self primitiveFailed. ! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! numGlyphs ^numGlyphs! ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/11/2007 11:24'! primGetPostscriptName ^nil! ! !FT2Face methodsFor: 'rendering' stamp: 'tween 8/2/2006 20:47'! transformOutlineAngle: angle scalePoint: scalePoint slant: slant | oneX oneY matrix slantOne| oneX := (16r10000 * scalePoint x) asInteger. oneY := (16r10000 * scalePoint y) asInteger. slantOne := (16r10000 * scalePoint x * slant) asInteger. matrix := IntegerArray new: 4. angle isZero ifTrue: [ matrix at: 1 put: oneX. matrix at: 2 put: slantOne. matrix at: 4 put: oneY. ] ifFalse: [ | phi cos sin | phi := angle degreesToRadians. cos := (phi sin * oneX) rounded. sin := (phi cos * oneY) rounded. matrix at: 1 put: sin. matrix at: 2 put: cos negated. matrix at: 3 put: cos. matrix at: 4 put: sin. ]. self primTransformGlyphSlotOutline: matrix! ! !FT2Face methodsFor: 'testing' stamp: 'tween 8/7/2006 08:46'! isBold styleFlags == nil ifTrue:[^false]. ^styleFlags allMask: StyleFlagBold! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! availableSizes ^availableSizes! ! !FT2Face methodsFor: 'rendering' stamp: 'tween 8/2/2006 21:19'! emboldenOutline: strength ^self primEmboldenGlyphSlotOutline: (strength * 64) rounded! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 19:35'! primSetCharMap: encodingString ^self primitiveFailed! ! !FT2Face methodsFor: 'initialize-release' stamp: 'DenisKudryashov 1/29/2013 22:04'! newFaceFromFile: fileName index: anInteger [self primNewFaceFromFile: fileName fullName index: anInteger] on: FT2Error do:[:e | ^self "need to do something here?"]. self class register: self.! ! !FT2Face methodsFor: 'outlines' stamp: 'MichaelRueger 12/16/2009 14:59'! characterOutline: aCharacter ^self loadCharacterOutline: aCharacter asUnicode flags: LoadIgnoreTransform! ! !FT2Face methodsFor: 'glyphs' stamp: 'MichaelRueger 12/16/2009 15:41'! glyphOfCharacter: aCharacter fontSize: fontSize ^self glyphOfCharacter: aCharacter pixelSize: fontSize@fontSize! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! styleFlags ^styleFlags! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 20:46'! encoding encoding ifNil: [ self getCharMap ]. ^encoding! ! !FT2Face methodsFor: 'outlines' stamp: 'jl 5/24/2006 15:22'! loadCharacterOutline: index flags: flags | em outline | em := unitsPerEm. self setPixelWidth: em height: em. self loadCharacter: index flags: flags. outline := FT2Outline new. outline primLoadSizesFrom: self. outline allocateArrays. outline primLoadArraysFrom: self. ^outline! ! !FT2Face methodsFor: 'private-primitives' stamp: 'jl 5/30/2006 13:23'! primGetKerningLeft: leftGlyphIndex right: rightGlyphIndex "self primGetKerningLeft: $V asInteger right: $a asInteger " ^self primitiveFailed.! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 15:58'! primNewFaceFromFile: fileName index: anInteger ^self primitiveFailed! ! !FT2Face methodsFor: 'rendering' stamp: 'tween 8/2/2006 20:48'! translateOutlineBy: aPoint | delta| delta := IntegerArray new: 2. delta at: 1 put: (aPoint x * 64) rounded. delta at: 2 put: (aPoint y * 64) rounded. self primTranslateGlyphSlotOutline: delta.! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! faceFlags ^faceFlags! ! !FT2Face methodsFor: 'rendering' stamp: 'bf 11/21/2005 18:07'! angle: angle scale: scale offset: aPoint | one matrix delta | one := (16r10000 * scale) asInteger. matrix := IntegerArray new: 4. angle isZero ifTrue: [ matrix at: 1 put: one. matrix at: 4 put: one. ] ifFalse: [ | phi cos sin | phi := angle degreesToRadians. cos := (phi sin * one) rounded. sin := (phi cos * one) rounded. matrix at: 1 put: sin. matrix at: 2 put: cos negated. matrix at: 3 put: cos. matrix at: 4 put: sin. ]. delta := IntegerArray new: 2. delta at: 1 put: (aPoint x * 64) rounded. delta at: 2 put: (aPoint y * 64) rounded. self primSetTransform: matrix delta: delta. ! ! !FT2Face methodsFor: 'testing' stamp: 'tween 8/7/2006 08:47'! isRegular styleFlags == nil ifTrue:[^true]. ^styleFlags = 0! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! numCharmaps ^numCharmaps! ! !FT2Face methodsFor: 'private-primitives' stamp: 'bf 11/19/2005 15:36'! primSetTransform: matrixWordArray delta: deltaWordArray "matrix is 16.16 fixed point x' = x*m[0] + y*m[1] y' = x*m[2] + y*yy[3] delta is 26.6 fixed point x' = x + d[0] y' = y + d[1] " ^self primitiveFailed.! ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/2/2006 21:14'! primEmboldenGlyphSlotOutline: strengthInteger ^self primitiveFailed.! ! !FT2Face methodsFor: 'testing' stamp: 'tween 8/7/2006 08:47'! isFixedWidth styleFlags == nil ifTrue:[^false]. ^faceFlags allMask: 4 "FT_FACE_FLAG_FIXED_WIDTH" ! ! !FT2Face methodsFor: 'private-primitives' stamp: 'jl 5/30/2006 15:59'! primGetTrackKerningPointSize: pointSize degree: degree ^self primitiveFailed.! ! !FT2Face methodsFor: 'accessing' stamp: 'tween 8/11/2007 11:24'! postscriptName ^self primGetPostscriptName! ! !FT2Face methodsFor: 'printing' stamp: 'ClementBera 7/26/2013 16:42'! printOn: aStream super printOn: aStream. handle ifNil: [^self]. "self familyName isNil ifTrue: [ self loadFields ]." aStream nextPut: $[; nextPutAll: (self familyName ifNil: ['?']); space; nextPutAll: (self styleName ifNil: ['?']); nextPut: $]! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 18:05'! primLoadGlyph: index flags: flags ^self primitiveFailed! ! !FT2Face methodsFor: 'glyphs' stamp: 'nk 11/3/2004 18:25'! loadGlyph: index flags: flags self primLoadGlyph: index flags: flags. glyph ifNil: [ glyph := FT2GlyphSlot fromFace: self ] ifNotNil: [ glyph loadFrom: self ]. ! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! faceIndex ^faceIndex! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:35'! primGetCharMapsInto: array ^self primitiveFailed.! ! !FT2Face methodsFor: 'rendering' stamp: 'MichaelRueger 12/16/2009 15:42'! transform: aMatrix | matrix delta | matrix := IntegerArray new: 4. matrix at: 1 put: (aMatrix a11 * 16r10000) rounded. matrix at: 2 put: (aMatrix a12 * 16r10000) rounded. matrix at: 3 put: (aMatrix a21 * 16r10000) rounded. matrix at: 4 put: (aMatrix a22 * 16r10000) rounded. delta := IntegerArray new: 2. delta at: 1 put: (aMatrix a13 * 64) rounded. delta at: 2 put: (aMatrix a23 * 64) rounded. self primSetTransform: matrix delta: delta. ! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! maxAdvanceHeight ^maxAdvanceHeight! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! styleName ^styleName! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! size ^size! ! !FT2Face methodsFor: 'rendering' stamp: 'tween 3/22/2006 23:07'! angle: angle scalePoint: scalePoint offset: aPoint | oneX oneY matrix delta | oneX := (16r10000 * scalePoint x) asInteger. oneY := (16r10000 * scalePoint y) asInteger. matrix := IntegerArray new: 4. angle isZero ifTrue: [ matrix at: 1 put: oneX. matrix at: 4 put: oneY. ] ifFalse: [ | phi cos sin | phi := angle degreesToRadians. cos := (phi sin * oneX) rounded. sin := (phi cos * oneY) rounded. matrix at: 1 put: sin. matrix at: 2 put: cos negated. matrix at: 3 put: cos. matrix at: 4 put: sin. ]. delta := IntegerArray new: 2. delta at: 1 put: (aPoint x * 64) rounded. delta at: 2 put: (aPoint y * 64) rounded. self primSetTransform: matrix delta: delta. ! ! !FT2Face methodsFor: 'glyphs' stamp: 'nk 11/3/2004 18:25'! loadCharacter: index flags: flags self primLoadCharacter: index flags: flags. glyph ifNil: [ glyph := FT2GlyphSlot fromFace: self ] ifNotNil: [ glyph loadFrom: self ]. ! ! !FT2Face methodsFor: 'accessing' stamp: 'tween 7/24/2006 22:49'! memoryFaceData self subclassResponsibility! ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/2/2006 20:45'! primTranslateGlyphSlotOutline: anIntegerArray ^self primitiveFailed.! ! !FT2Face methodsFor: 'rendering' stamp: 'bf 11/19/2005 12:56'! renderGlyphIntoForm: aForm "render the current glyph (selected by loadChar/loadGlyph into the given form (1 or 8 bpp)" self primRenderGlyphIntoForm: aForm ! ! !FT2Face methodsFor: 'charmaps' stamp: 'nk 11/3/2004 20:39'! setCharMap: encodingString self primSetCharMap: encodingString. self primGetCharMap. ! ! !FT2Face methodsFor: 'glyphs' stamp: 'MichaelRueger 12/16/2009 15:40'! glyphOfCharacter: aCharacter pixelSize: pixelSize "load a glyph with outline, glyph is not scaled " | aGlyph | self validate. self setPixelWidth: pixelSize x height: pixelSize y. self loadCharacter: aCharacter asUnicode flags: LoadIgnoreTransform. "load glyph metrics" aGlyph := self glyph. " copy because 'face glyph' is only a slot" glyph := nil. ^aGlyph! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! descender ^descender! ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/6/2006 15:47'! primDestroyHandle ^self primitiveFailed.! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! underlinePosition ^underlinePosition! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! unitsPerEm ^unitsPerEm! ! !FT2Face methodsFor: 'rendering' stamp: 'tween 8/2/2006 10:05'! angle: angle scale: scale offset: aPoint slant: slant | one matrix delta slantOne | one := (16r10000 * scale) asInteger. slantOne := (16r10000 * scale* slant) asInteger. matrix := IntegerArray new: 4. angle isZero ifTrue: [ matrix at: 1 put: one. matrix at: 2 put: slantOne. matrix at: 4 put: one. ] ifFalse: [ | phi cos sin | phi := angle degreesToRadians. cos := (phi sin * one) rounded. sin := (phi cos * one) rounded. matrix at: 1 put: sin. matrix at: 2 put: cos negated. matrix at: 3 put: cos. matrix at: 4 put: sin. ]. delta := IntegerArray new: 2. delta at: 1 put: (aPoint x * 64) rounded. delta at: 2 put: (aPoint y * 64) rounded. self primSetTransform: matrix delta: delta. ! ! !FT2Face methodsFor: 'initialize-release' stamp: 'tween 8/12/2006 10:01'! newFaceFromExternalMemory: aFreeTypeExternalMemory index: anInteger | memSize | aFreeTypeExternalMemory validate. memSize := aFreeTypeExternalMemory bytes size. [self primNewFaceFromExternalMemory: aFreeTypeExternalMemory size: memSize index: anInteger] on: FT2Error do:[:e |"need to do something here?"]. self isValid ifTrue:[self class register: self]! ! !FT2Face methodsFor: 'private-primitives' stamp: 'jl 5/29/2006 15:52'! primHasKerning ^self primitiveFailed.! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! ascender ^ascender! ! !FT2GlyphRenderer commentStamp: ''! i am used to render freetype glyphs using balloon primitives.! !FT2GlyphRenderer methodsFor: 'initailize-release' stamp: 'IgorStasenko 11/21/2011 16:32'! initForFont: aFont surface: aSurface self assert: (aFont class == FreeTypeFont). surface := aSurface. font := aFont. slot := SimpleTextGlyphInfo new. pixelSize := font pixelSize rounded. blt := BitBlt toForm: surface form. self loadSurfaceTransform. colorMap := Bitmap new: 256. blt sourceForm: form; sourceX: 0; sourceY: 0; destOrigin: 0@0; sourceOrigin: 0@0; halftoneForm: nil; combinationRule: 24; width: form width; height: form height; colorMap: colorMap; clipRect: surface clipRect. translation := IntegerArray new: 2. ! ! !FT2GlyphRenderer methodsFor: 'accessing' stamp: 'IgorStasenko 10/19/2011 15:37'! form ^ form! ! !FT2GlyphRenderer methodsFor: 'private' stamp: 'IgorStasenko 11/7/2011 13:45'! setPosition: aPoint advance: advancePt baseline: baselineOffset "aPoint is a text origin in user's coordinate system, and andvance is accumulated advance came from another renderer instance, expressed in surface's coordinate system" | pt offset | offset := baselineOffset - font getPreciseAscent "(font face ascender * pixelSize / font face unitsPerEm)". pt := aPoint + (0@offset). pt := surface pathTransform transform: pt. origin := pt. pt := pt + advancePt. "remember the origin, so on #getAdvance , we will answer the current advance for renderer in surface coordinate system" " 2 raisedTo: 6 " penX := (pt x * 64) rounded. penY := (pt y * 64) rounded. ! ! !FT2GlyphRenderer methodsFor: 'rendering' stamp: 'IgorStasenko 11/7/2011 13:45'! renderGlyphsIn: text from: start to: stop | face | face := font face. " face setPixelWidth: pixelSize height: pixelSize. " start to: stop do: [:i | | bx by | bx := penX + bitmapX. by := penY + bitmapY. "add a small shift, to incorporate subpixel position" translation at: 1 put: descend x + (bx bitAnd: 2r111111). translation at: 2 put: descend y - (by bitAnd: 2r111111). face primSetTransform: matrix delta: translation. self loadUnicode: (text at: i) asUnicode. self clearBitmap. face renderGlyphIntoForm: form. blt destX: bx >> 6; destY: by >> 6; copyBits. "increment x by horizontal advance" penX := penX + slot advanceX. penY := penY - slot advanceY. ]. ! ! !FT2GlyphRenderer methodsFor: 'private' stamp: 'IgorStasenko 7/12/2011 20:11'! loadSlotInfo slot loadFrom: font face.! ! !FT2GlyphRenderer methodsFor: 'accessing' stamp: 'IgorStasenko 11/7/2011 13:59'! setColor: color "Set the color which will be used to render glyphs." | clr rgb alpha | currentColor = color ifTrue: [ ^ self ]. currentColor := color. clr := color pixelValue32. rgb := clr bitAnd: 16rFFFFFF. alpha := clr >> 24. 0 to: 255 do:[:i | | a | a := (i+1) * alpha bitAnd: 16rFF00. colorMap at: i+1 put: ( (a<<16) + rgb ). ]. " colorMap at: 1 put: (Color red alpha: 0.1) pixelValue32." ! ! !FT2GlyphRenderer methodsFor: 'private' stamp: 'IgorStasenko 11/7/2011 14:25'! loadSurfaceTransform | m mt org xaxis yaxis sum xmin xmax ymin ymax formW formH fix face bbox | face := font face. face setPixelWidth: pixelSize height: pixelSize. bbox := face bbox. m := surface pathTransform copy transposed. org := m transform: 0@0. xaxis := (m transform: bbox right - bbox left * pixelSize / face unitsPerEm @ 0) - org. yaxis := (m transform: 0 @ (bbox bottom - bbox top * pixelSize / face unitsPerEm)) - org. sum := xaxis + yaxis. xmin := 0 min: ((xaxis x min: yaxis x) min: sum x). ymin := 0 min: ((xaxis y min: yaxis y) min: sum y). xmax := 0 max: ((xaxis x max: yaxis x) max: sum x). ymax := 0 max: ((xaxis y max: yaxis y) max: sum y). formW := (xmax - xmin) ceiling + 1. formH := (ymax - ymin) ceiling + 1. " freetype 'zero' points to bottom-left point on form" "calculate bitmap translation relative to top-left corner of glyph" bitmapX := (yaxis x negated + xmin * 64.0) rounded. bitmapY := (xaxis y negated + ymin * 64.0) rounded. descend := 0 @ ((face bbox height - face bbox bottom * pixelSize / face unitsPerEm) +1). descend := (m transform: descend) - org. descend := descend + (xmin negated@(ymin negated)). descend := (descend * 64 ) rounded. form := Form extent: formW @ formH depth: 8. blt sourceForm: form; width: form width; height: form height. "prepare transformation matrix for freetype" matrix := IntegerArray new: 4. "values in matrix are 16.16 fixed point floating values" fix := 65536. "(2 raisedTo: 16)." matrix at: 1 put: (m sx * fix) rounded; at: 2 put: (m shx * fix) rounded; at: 3 put: (m shy * fix) rounded; at: 4 put: (m sy * fix) rounded. ! ! !FT2GlyphRenderer methodsFor: 'private' stamp: 'IgorStasenko 10/25/2011 18:40'! loadUnicode: unicode | ext hintingFlags flags arr face | face := font face. " hintingFlags := FreeTypeSettings current hintingFlags." flags := LoadNoBitmap bitOr: 2 "hintingFlags". " bitOr:( LoadIgnoreTransform bitOr: 2 ). " face primLoadCharacter: unicode flags: flags. self loadSlotInfo. ! ! !FT2GlyphRenderer methodsFor: 'private' stamp: 'IgorStasenko 10/19/2011 15:31'! clearBitmap form bits atAllPut: 0. ! ! !FT2GlyphRenderer methodsFor: 'accessing' stamp: 'IgorStasenko 10/25/2011 18:29'! getAdvance "aPoint is a text origin in user's coordinate system, and anvance is accumulated advance came from another renderer instance, expressed in surface's coordinate system" | pt | pt := (penX/64.0) @ (penY/64.0) - origin. ^ pt! ! !FT2GlyphRenderer class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 10/20/2011 10:29'! forFont: aFont surface: aSurface ^ self new initForFont: aFont surface: aSurface! ! !FT2GlyphSlot commentStamp: ''! Do not rearrange these fields!! face -- the FT2Face that owns this FT2GlyphSlot. Note that even when the glyph image is transformed, the metrics are not. linearHoriAdvance -- For scalable formats only, this field holds the linearly scaled horizontal advance width for the glyph (i.e. the scaled and unhinted value of the hori advance). This can be important to perform correct WYSIWYG layout. Note that this value is expressed by default in 16.16 pixels. However, when the glyph is loaded with the FT_LOAD_LINEAR_DESIGN flag, this field contains simply the value of the advance in original font units. linearVertAdvance -- For scalable formats only, this field holds the linearly scaled vertical advance height for the glyph. See linearHoriAdvance for comments. advance -- This is the transformed advance width for the glyph. format -- This field indicates the format of the image contained in the glyph slot. Typically FT_GLYPH_FORMAT_BITMAP, FT_GLYPH_FORMAT_OUTLINE, and FT_GLYPH_FORMAT_COMPOSITE, but others are possible. bitmap -- This field is used as a bitmap descriptor when the slot format is FT_GLYPH_FORMAT_BITMAP. Note that the address and content of the bitmap buffer can change between calls of @FT_Load_Glyph and a few other functions. bitmap_left -- This is the bitmap's left bearing expressed in integer pixels. Of course, this is only valid if the format is FT_GLYPH_FORMAT_BITMAP. bitmap_top -- This is the bitmap's top bearing expressed in integer pixels. Remember that this is the distance from the baseline to the top-most glyph scanline, upwards y-coordinates being *positive*. outline -- The outline descriptor for the current glyph image if its format is FT_GLYPH_FORMAT_OUTLINE. num_subglyphs -- The number of subglyphs in a composite glyph. This field is only valid for the composite glyph format that should normally only be loaded with the @FT_LOAD_NO_RECURSE flag. For now this is internal to FreeType. subglyphs -- An array of subglyph descriptors for composite glyphs. There are `num_subglyphs' elements in there. Currently internal to FreeType. control_data -- Certain font drivers can also return the control data for a given glyph image (e.g. TrueType bytecode, Type 1 charstrings, etc.). This field is a pointer to such data. control_len -- This is the length in bytes of the control data. other -- Really wicked formats can use this pointer to present their own glyph image to client apps. Note that the app will need to know about the image format. width, height, hBearingX, hBearingY, hAdvance, vBearingX, vBearingY, vAdvance -- The metrics of the last loaded glyph in the slot. The returned values depend on the last load flags (see the @FT_Load_Glyph API function) and can be expressed either in 26.6 fractional pixels or font units. ! !FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'tween 3/11/2007 08:56'! roundedPixelLinearAdvance "Answer the scaled linearAdvance, rounded to whole pixels" ^linearHorizontalAdvance rounded @ linearVerticalAdvance rounded ! ! !FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'bf 11/19/2005 17:16'! advance ^advanceX@advanceY! ! !FT2GlyphSlot methodsFor: 'private' stamp: 'nk 11/3/2004 17:58'! primLoadFrom: anFT2Face ^self primitiveFailed.! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! advanceX ^advanceX! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:53'! width ^width! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'MichaelRueger 12/16/2009 15:10'! outline ^outline! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! linearVerticalAdvance ^linearVerticalAdvance! ! !FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'bf 11/20/2005 14:56'! hBearing ^hBearingX@hBearingY! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:52'! hBearingY ^hBearingY! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! advanceY ^advanceY! ! !FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'tween 8/5/2007 11:14'! linearAdvance ^"("(linearHorizontalAdvance @ linearVerticalAdvance) "* 2540) rounded" ! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:52'! hBearingX ^hBearingX! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:53'! height ^height! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'MichaelRueger 12/16/2009 15:00'! outline: anOutline outline := anOutline! ! !FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'bf 11/20/2005 14:42'! extent ^width@height! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! linearHorizontalAdvance ^linearHorizontalAdvance! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! bitmapLeft ^bitmapLeft! ! !FT2GlyphSlot methodsFor: 'private' stamp: 'StephaneDucasse 3/17/2010 20:56'! loadFrom: anFT2Face face := anFT2Face. self primLoadFrom: anFT2Face. format := ((Smalltalk isLittleEndian) ifTrue: [ format reversed ] ifFalse: [ format ]) asString. linearHorizontalAdvance := linearHorizontalAdvance / 65536.0. linearVerticalAdvance isZero ifFalse: [ linearVerticalAdvance := linearVerticalAdvance / 65536.0 ]. advanceX := advanceX bitShift: -6. advanceY isZero ifFalse: [ advanceY := advanceY bitShift: -6 ]. width := width + 63 bitShift: -6. "round up" height := height + 63 bitShift: -6. "round up" hBearingX := hBearingX bitShift: -6. hBearingY := hBearingY bitShift: -6. hAdvance := hAdvance bitShift: -6. vBearingX := vBearingX bitShift: -6. vBearingY := vBearingY bitShift: -6. vAdvance := vAdvance bitShift: -6.! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! format ^format! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! bitmapTop ^bitmapTop! ! !FT2GlyphSlot class methodsFor: 'instance creation' stamp: 'nk 11/3/2004 17:38'! fromFace: anFT2Face ^(super new) loadFrom: anFT2Face; yourself.! ! !FT2Handle commentStamp: ''! handle holds a (typically 32-bit) pointer to an externally managed object.! !FT2Handle methodsFor: 'error handling' stamp: 'nk 11/3/2004 13:51'! errorCode ^self primitiveFailed! ! !FT2Handle methodsFor: 'comparing' stamp: 'Igor.Stasenko 10/12/2010 19:48'! hash ^ handle hash! ! !FT2Handle methodsFor: 'private' stamp: 'IgorStasenko 10/9/2012 18:54'! destroyHandle "remove receiver from finalization registry, so #finalize won't try to free handle again" self class deregister: self. self pvtDestroyHandle. ! ! !FT2Handle methodsFor: 'finalization' stamp: 'IgorStasenko 10/15/2012 17:07'! finalize "If session has changed, and startup is not yet done, we do not attempt to free external resources" Session == Smalltalk session ifFalse: [ ^ self ]. self pvtDestroyHandle. ! ! !FT2Handle methodsFor: 'private' stamp: 'IgorStasenko 10/9/2012 18:51'! pvtDestroyHandle "This should only be sent from the finalizer." handle ifNil: [ ^self ]. self primDestroyHandle. self beNull. ! ! !FT2Handle methodsFor: 'error handling' stamp: 'nk 11/4/2004 13:32'! primitiveFailed ^self primitiveFailed: 'Freetype2 primitive failed'! ! !FT2Handle methodsFor: 'private' stamp: 'nk 11/3/2004 16:10'! beNull handle := nil.! ! !FT2Handle methodsFor: 'private' stamp: 'nk 11/3/2004 21:19'! handle ^handle! ! !FT2Handle methodsFor: 'error handling' stamp: 'nk 11/3/2004 21:07'! errorString ^self primitiveFailed! ! !FT2Handle methodsFor: 'initialization' stamp: 'nk 3/11/2005 18:44'! initialize self shouldNotImplement.! ! !FT2Handle methodsFor: 'private' stamp: 'nk 11/3/2004 12:21'! primDestroyHandle self subclassResponsibility! ! !FT2Handle methodsFor: 'comparing' stamp: 'Igor.Stasenko 10/12/2010 19:47'! = anObject ^ (self class == anObject class) and: [ handle = anObject handle ]! ! !FT2Handle methodsFor: 'printing' stamp: 'ClementBera 7/26/2013 16:42'! printOn: aStream | handleHex | super printOn: aStream. handle ifNil: [ ^aStream nextPutAll: '' ]. handleHex := (handle unsignedLongAt: 1 bigEndian: Smalltalk isBigEndian) printStringHex. aStream nextPutAll: '<0x'; nextPutAll: handleHex; nextPut: $>.! ! !FT2Handle methodsFor: 'printing' stamp: 'nk 3/17/2005 16:40'! isValid ^handle notNil and: [ handle anySatisfy: [ :b | b isZero not ] ]! ! !FT2Handle methodsFor: 'error handling' stamp: 'nk 11/4/2004 13:33'! primitiveFailed: aString ^FT2Error new signal: aString! ! !FT2Handle class methodsFor: 'error reporting' stamp: 'nk 11/3/2004 13:51'! errorCode ^self primitiveFailed! ! !FT2Handle class methodsFor: 'error reporting' stamp: 'nk 11/3/2004 15:50'! moduleErrorCode ^self primitiveFailed! ! !FT2Handle class methodsFor: 'private-handle registry' stamp: 'IgorStasenko 10/9/2012 18:50'! register: anFT2Handle self registry add: anFT2Handle.! ! !FT2Handle class methodsFor: 'error reporting' stamp: 'nk 11/3/2004 15:49'! errorString ^self primitiveFailed! ! !FT2Handle class methodsFor: 'class initialization' stamp: 'IgorStasenko 10/9/2012 17:50'! initialize "FT2Handle initialize" Smalltalk removeFromShutDownList: self. Smalltalk removeFromStartUpList: self. "in case it was added by earlier version" Smalltalk addToStartUpList: self. ! ! !FT2Handle class methodsFor: 'system startup' stamp: 'IgorStasenko 10/9/2012 18:51'! clearRegistry self registry do: [:each | each beNull ]; removeAll.! ! !FT2Handle class methodsFor: 'private-handle registry' stamp: 'IgorStasenko 10/9/2012 18:50'! deregister: anFT2Handle self registry remove: anFT2Handle ifAbsent: nil.! ! !FT2Handle class methodsFor: 'private-handle registry' stamp: 'Igor.Stasenko 10/12/2010 19:45'! registry ^Registry ifNil: [ Registry := WeakRegistry new]! ! !FT2Handle class methodsFor: 'initialize-release' stamp: 'nk 11/3/2004 21:00'! unload Smalltalk removeFromStartUpList: self. Smalltalk removeFromShutDownList: self. ! ! !FT2Handle class methodsFor: 'system startup' stamp: 'IgorStasenko 10/15/2012 17:08'! startUp: booting booting ifFalse: [ ^ self ]. self clearRegistry. "update session" Session := Smalltalk session ! ! !FT2Library commentStamp: ''! This is a wrapper for the global 'library' in the plugin. It is provided for the use of Cairo APIs that take an FT_Library argument.! !FT2Library methodsFor: 'private-primitives' stamp: 'tween 3/17/2007 14:18'! current ^[self primCurrentLibrary] on: Error do: [:e | nil]! ! !FT2Library methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:32'! primCurrentLibrary ^self primitiveFailed! ! !FT2Library methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:27'! destroyHandle "This is not a managed handle, but a global. Do nothing."! ! !FT2Library class methodsFor: 'instance creation' stamp: 'nk 3/17/2005 14:19'! current ^[ (self basicNew) current ] on: FT2Error do: [ :ex | ex return: nil ].! ! !FT2MemoryFaceData commentStamp: 'TorstenBergmann 2/4/2014 22:06'! Freetype 2 MemoryFace data ! !FT2MemoryFaceData methodsFor: 'accessing' stamp: 'tween 7/24/2006 23:04'! bytes ^bytes ! ! !FT2MemoryFaceData methodsFor: 'primitives' stamp: 'tween 7/24/2006 22:32'! primMalloc: aByteArray "copy aByteArray into newly allocated, external memory, and store the address of that memory in the receiver's handle" ^self primitiveFailed! ! !FT2MemoryFaceData methodsFor: 'validation' stamp: 'tween 7/31/2006 21:48'! validate self isValid ifFalse: [ bytes ifNotNil:[ [self primMalloc: bytes] on: FT2Error do:[:e |"need to do something here?"]. self isValid ifTrue:[self class register: self]]]! ! !FT2MemoryFaceData methodsFor: 'primitives' stamp: 'tween 7/24/2006 21:52'! primDestroyHandle ^self primitiveFailed.! ! !FT2MemoryFaceData methodsFor: 'initialize-release' stamp: 'tween 7/24/2006 21:53'! free ^self destroyHandle! ! !FT2MemoryFaceData methodsFor: 'accessing' stamp: 'tween 7/24/2006 22:43'! bytes: aByteArray bytes := aByteArray. ! ! !FT2MemoryFaceData class methodsFor: 'instance creation' stamp: 'tween 8/6/2006 11:11'! bytes: aByteArray | answer | answer := self basicNew bytes: aByteArray; yourself. ^answer! ! !FT2Outline commentStamp: ''! @instVar: contoursSize - The number of contours in the outline. @instVar: pointsSize - The number of points in the outline. @instVar: points - an array of 26.6 fixed point integer pairs giving the outline's point coordinates. @instVar: tags - an array of pointsSize bytes, giving each outline point's type. (counting from 0) If bit 0 is unset, the point is 'off' the curve, i.e., a Bézier control point, while it is 'on' when set. Bit 1 is meaningful for 'off' points only. If set, it indicates a third-order Bézier arc control point; and a second-order control point if unset. @instVar: contours - an array of contoursSize shorts, giving the end point of each contour within the outline. For example, the first contour is defined by the points '0' to 'contours[0]', the second one is defined by the points 'contours[0]+1' to 'contours[1]', etc. @instVar: flags - a set of bit flags used to characterize the outline and give hints to the scan-converter and hinter on how to convert/grid-fit it.! !FT2Outline methodsFor: 'accessing' stamp: 'jl 5/24/2006 15:19'! contoursCollection "returns a list of contours with tag => points list pairs" | allPoints result start end | allPoints := self pointCollection. result := OrderedCollection new. start := 1. "no normal iteration because contours size can be bigger than contourSize" 1 to: contoursSize do: [ :i | end := (contours at: i) + 1. "c converion" result add: ((tags copyFrom: start to: end) -> (allPoints copyFrom: start to: end)). start := end + 1. ]. ^result ! ! !FT2Outline methodsFor: 'private' stamp: 'jl 5/24/2006 13:58'! allocateArrays " allocate the arrays for the primLoadArraysFrom:" points := IntegerArray new: pointsSize * 2. tags := ByteArray new: pointsSize. contours := ShortIntegerArray new: contoursSize.! ! !FT2Outline methodsFor: 'accessing' stamp: 'jl 5/24/2006 14:26'! pointCollection ^(1 to: pointsSize * 2 by: 2) collect: [ :i | ((points at: i) / 64) @ ((points at: i + 1) / 64)] ! ! !FT2Outline methodsFor: 'private' stamp: 'jl 5/23/2006 17:01'! primLoadSizesFrom: anFT2Face ^self primitiveFailed.! ! !FT2Outline methodsFor: 'private' stamp: 'jl 5/23/2006 17:01'! primLoadArraysFrom: anFT2Face ^self primitiveFailed.! ! !FT2Version commentStamp: ''! Do not rearrange these fields!! This is used to report FT2 version information. Its fields must remain unchanged, or you must change FT2Plugin>>primitiveVersion.! !FT2Version methodsFor: 'primitives' stamp: 'nk 11/3/2004 11:20'! libraryVersion ^self primitiveFailed. ! ! !FT2Version methodsFor: 'accessing' stamp: 'nk 3/21/2004 11:03'! minor ^minor! ! !FT2Version methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:17'! patch ^patch! ! !FT2Version methodsFor: 'printing' stamp: 'nk 11/3/2004 11:22'! printOn: aStream aStream print: major; nextPut: $.; print: minor; nextPut:$.; print: patch.! ! !FT2Version methodsFor: 'accessing' stamp: 'nk 3/21/2004 11:03'! major ^major! ! !FT2Version class methodsFor: 'instance creation' stamp: 'nk 11/4/2004 11:10'! current " FT2Version current " ^ [(self new) libraryVersion; yourself] on: Error do: [:ex | ex return: nil]! ! !FTPClient commentStamp: 'mir 5/12/2003 17:55'! A minimal FTP client program. Could store all state in inst vars, and use an instance to represent the full state of a connection in progress. But simpler to do all that in one method and have it be a complete transaction. Always operates in passive mode (PASV). All connections are initiated from client in order to get through firewalls. See ServerDirectory openFTP, ServerDirectory getFileNamed:, ServerDirectory putFile:named: for examples of use. See TCP/IP, second edition, by Dr. Sidnie Feit, McGraw-Hill, 1997, Chapter 14, p311.! !FTPClient methodsFor: 'private protocol' stamp: 'mir 2/13/2002 18:06'! getData | dataStream | dataStream := RWBinaryOrTextStream on: (String new: 4000). self getDataInto: dataStream. self closeDataSocket. ^dataStream contents ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 3/7/2002 13:36'! binary self sendCommand: 'TYPE I'. self lookForCode: 200! ! !FTPClient methodsFor: 'private protocol' stamp: 'michael.rueger 6/16/2009 11:28'! openPassiveDataConnection | portInfo list dataPort remoteHostAddress remoteAddressString | self sendCommand: 'PASV'. self lookForCode: 227 ifDifferent: [:response | (TelnetProtocolError protocolInstance: self) signal: 'Could not enter passive mode: ' , response]. portInfo := (self lastResponse findTokens: '()') at: 2. list := portInfo findTokens: ','. remoteHostAddress := ByteArray with: (list at: 1) asNumber with: (list at: 2) asNumber with: (list at: 3) asNumber with: (list at: 4) asNumber. remoteAddressString := String streamContents: [:addrStream | remoteHostAddress do: [ :each | each printOn: addrStream ] separatedBy: [ addrStream nextPut: $. ]]. dataPort := (list at: 5) asNumber * 256 + (list at: 6) asNumber. self openDataSocket: (NetNameResolver addressForName: remoteAddressString) port: dataPort! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 19:23'! getFileNamed: remoteFileName | data | self openPassiveDataConnection. self sendCommand: 'RETR ', remoteFileName. [self checkResponse] on: TelnetProtocolError do: [:ex | self closeDataSocket. ex pass]. data := self getData. self checkResponse. ^data ! ! !FTPClient methodsFor: 'private' stamp: 'mir 10/31/2000 16:24'! dataSocket ^dataSocket! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/13/2002 17:52'! changeDirectoryTo: newDirName self sendCommand: 'CWD ' , newDirName. self checkResponse. ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:10'! makeDirectory: newDirName self sendCommand: 'MKD ' , newDirName. self checkResponse. ! ! !FTPClient methodsFor: 'private' stamp: 'mir 11/14/2002 18:14'! sendStreamContents: aStream self dataSocket sendStreamContents: aStream checkBlock: [self checkForPendingError. true]! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 16:55'! passive self sendCommand: 'PASV'. self lookForCode: 227! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 16:54'! putFileNamed: filePath as: fileNameOnServer "FTP a file to the server." | fileStream | fileStream := FileStream readOnlyFileNamed: filePath. fileStream ifNil: [(FileDoesNotExistException fileName: filePath) signal]. self putFileStreamContents: fileStream as: fileNameOnServer ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 12/8/2003 16:54'! putFileStreamContents: fileStream as: fileNameOnServer "FTP a file to the server." self openPassiveDataConnection. self sendCommand: 'STOR ', fileNameOnServer. fileStream reset. [self sendStreamContents: fileStream] ensure: [self closeDataSocket]. self checkResponse. self checkResponse. ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 10/31/2000 13:12'! quit self sendCommand: 'QUIT'. self close! ! !FTPClient methodsFor: 'private' stamp: 'mir 2/19/2002 18:27'! closeDataSocket self dataSocket ifNotNil: [ self dataSocket closeAndDestroy. self dataSocket: nil] ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/13/2002 17:50'! removeFileNamed: remoteFileName self sendCommand: 'DELE ', remoteFileName. self checkResponse. ! ! !FTPClient methodsFor: 'private protocol' stamp: 'LucFabresse 11/2/2010 22:10'! lookForCode: code ifDifferent: handleBlock "We are expecting a certain numeric code next. However, in the FTP protocol, multiple lines are allowed. If the response is multi-line, the fourth character of the first line is a $- and the last line repeats the numeric code but the code is followed by a space. So it's possible that there are more lines left of the last response that we need to throw away. We use peekForAll: so that we don't discard the next response that is not a continuation line." "check for multi-line response" (self lastResponse size > 3 and: [(self lastResponse at: 4) = $-]) ifTrue: ["Discard continuation lines." | headToDiscard | headToDiscard := self lastResponse first: 4. [[self stream peekForAll: headToDiscard] whileTrue: [self stream nextLine]] on: Exception do: [:ex | ^handleBlock value: nil]]. ^ super lookForCode: code ifDifferent: handleBlock! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/12/2002 18:39'! loginUser: userName password: passwdString self user: userName. self password: passwdString. self login! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 16:50'! getFileList | dirList | self openPassiveDataConnection. self sendCommand: 'NLST'. dirList := self getData. self checkResponse. self checkResponse. ^dirList ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 3/7/2002 13:36'! ascii self sendCommand: 'TYPE A'. self lookForCode: 200! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:12'! deleteFileNamed: fileName self sendCommand: 'DELE ' , fileName. self checkResponse. ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:11'! deleteDirectory: dirName self sendCommand: 'RMD ' , dirName. self checkResponse. ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 2/20/2002 13:53'! getDirectory | dirList | self openPassiveDataConnection. self sendCommand: 'LIST'. dirList := self getData. self checkResponse. self checkResponse. ^dirList ! ! !FTPClient methodsFor: 'protocol' stamp: 'nk 1/26/2005 16:40'! renameFileNamed: oldFileName to: newFileName self sendCommand: 'RNFR ' , oldFileName. self lookForCode: 350. self sendCommand: 'RNTO ' , newFileName. self lookForCode: 250! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 5/9/2003 15:50'! getFileNamed: remoteFileName into: dataStream self openPassiveDataConnection. self sendCommand: 'RETR ', remoteFileName. [self checkResponse] on: TelnetProtocolError do: [:ex | self closeDataSocket. ex pass]. self getDataInto: dataStream. self closeDataSocket. self checkResponse! ! !FTPClient methodsFor: 'private protocol' stamp: 'svp 10/28/2003 11:06'! get: limit dataInto: dataStream "Reel in data until the server closes the connection or the limit is reached. At the same time, watch for errors on otherSocket." | buf bytesRead currentlyRead | currentlyRead := 0. buf := String new: 4000. [currentlyRead < limit and: [self dataSocket isConnected or: [self dataSocket dataAvailable]]] whileTrue: [ self checkForPendingError. bytesRead := self dataSocket receiveDataWithTimeoutInto: buf. 1 to: (bytesRead min: (limit - currentlyRead)) do: [:ii | dataStream nextPut: (buf at: ii)]. currentlyRead := currentlyRead + bytesRead]. dataStream reset. "position: 0." ^ dataStream! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 10/31/2000 19:03'! getPartial: limit fileNamed: remoteFileName into: dataStream | data | self openPassiveDataConnection. self sendCommand: 'RETR ', remoteFileName. [self checkResponse] on: TelnetProtocolError do: [:ex | self closeDataSocket. ex pass]. data := self get: limit dataInto: dataStream. self abortDataConnection. ^data ! ! !FTPClient methodsFor: 'private' stamp: 'mir 10/31/2000 18:23'! dataSocket: aSocket dataSocket := aSocket! ! !FTPClient methodsFor: 'private' stamp: 'mir 4/7/2003 17:20'! login self user ifNil: [^self]. ["repeat both USER and PASS since some servers require it" self sendCommand: 'USER ', self user. "331 Password required" self lookForCode: 331. "will ask user, if needed" self sendCommand: 'PASS ', self password. "230 User logged in" ([self lookForCode: 230.] on: TelnetProtocolError do: [false]) == false ] whileTrue: [ (LoginFailedException protocolInstance: self) signal: self lastResponse] ! ! !FTPClient methodsFor: 'private protocol' stamp: 'svp 10/28/2003 11:04'! getDataInto: dataStream "Reel in all data until the server closes the connection. At the same time, watch for errors on otherSocket. Don't know how much is coming. Put the data on the stream." | buf bytesRead | buf := String new: 4000. [self dataSocket isConnected or: [self dataSocket dataAvailable]] whileTrue: [ self checkForPendingError. bytesRead := self dataSocket receiveDataWithTimeoutInto: buf. 1 to: bytesRead do: [:ii | dataStream nextPut: (buf at: ii)]]. dataStream reset. "position: 0." ^ dataStream! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 17:51'! openDataSocket: remoteHostAddress port: dataPort dataSocket := Socket new. dataSocket connectTo: remoteHostAddress port: dataPort! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 2/13/2002 18:05'! abortDataConnection self sendCommand: 'ABOR'. self closeDataSocket! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 16:43'! pwd | result | self sendCommand: 'PWD'. self lookForCode: 257. result := self lastResponse. ^result copyFrom: (result indexOf: $")+1 to: (result lastIndexOf: $")-1! ! !FTPClient class methodsFor: 'accessing' stamp: 'mir 10/30/2000 20:10'! defaultPortNumber ^21! ! !FTPClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 19:08'! logFlag ^#ftp! ! !FTPClient class methodsFor: 'accessing' stamp: 'mir 2/13/2002 17:50'! rawResponseCodes #(200 'Command okay.' 500 'Syntax error, command unrecognized. This may include errors such as command line too long.' 501 'Syntax error in parameters or arguments.' 202 'Command not implemented, superfluous at this site.' 502 'Command not implemented.' 503 'Bad sequence of commands.' 504 'Command not implemented for that parameter.' 110 'Restart marker reply. In this case, the text is exact and not left to the particular implementation; it must read: MARK yyyy = mmmm Where yyyy is User-process data stream marker, and mmmm server''s equivalent marker (note the spaces between markers and "=").' 211 'System status, or system help reply.' 212 'Directory status.' 213 'File status.' 214 'Help message. On how to use the server or the meaning of a particular non-standard command. This reply is useful only to the human user.' 215 'NAME system type. Where NAME is an official system name from the list in the Assigned Numbers document.' 120 'Service ready in nnn minutes.' 220 'Service ready for new user.' 221 'Service closing control connection. Logged out if appropriate.' 421 'Service not available, closing control connection. This may be a reply to any command if the service knows it must shut down.' 125 'Data connection already open; transfer starting.' 225 'Data connection open; no transfer in progress.' 425 'Can''t open data connection.' 226 'Closing data connection. Requested file action successful (for example, file transfer or file abort).' 426 'Connection closed; transfer aborted.' 227 'Entering Passive Mode (h1,h2,h3,h4,p1,p2).' 230 'User logged in, proceed.' 530 'Not logged in.' 331 'User name okay, need password.' 332 'Need account for login.' 532 'Need account for storing files.' 150 'File status okay; about to open data connection.' 250 'Requested file action okay, completed.' 257 '"PATHNAME" created.' 350 'Requested file action pending further information.' 450 'Requested file action not taken. File unavailable (e.g., file busy).' 550 'Requested action not taken. File unavailable (e.g., file not found, no access).' 451 'Requested action aborted. Local error in processing.' 551 'Requested action aborted. Page type unknown.' 452 'Requested action not taken. Insufficient storage space in system.' 552 'Requested file action aborted. Exceeded storage allocation (for current directory or dataset).' 553 'Requested action not taken. File name not allowed.') ! ! !FTPConnectionException commentStamp: 'TorstenBergmann 2/20/2014 13:34'! An exception occured while connection using FTP! !FTPConnectionException methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 07:47'! defaultAction self resume! ! !FTPConnectionException methodsFor: 'as yet unclassified' stamp: 'RAA 3/14/2001 15:57'! isResumable ^true! ! !FailingTestResourceTestCase commentStamp: 'TorstenBergmann 2/12/2014 23:14'! SUnit tests for failing test resources! !FailingTestResourceTestCase methodsFor: 'utility' stamp: 'StephaneDucasse 6/9/2012 22:58'! clearOuterResourceStateDuring: aBlock "Make the resource impossible to make available, then ensure that every test raises a failure but not an error (which its setUp would do if it reached it and the resource were nil)." ^super clearOuterResourceStateDuring: [SimpleTestResource preventAvailabilityDuring: [self should: aBlock raise: self defaultTestFailure]]! ! !FakeCompiledMethod commentStamp: ''! I hold the source code for DoIt. It is needed if you want to debug with ASTDebugger (Smalltalkhub user:'dh83' project:'ast-interpreter') a DoIt method or if you want to look at the stack in the AIContextInspector! !FakeCompiledMethod methodsFor: 'accessing' stamp: 'ClementBera 3/18/2013 15:45'! selector ^#DoIt! ! !FakeCompiledMethod methodsFor: 'accessing' stamp: 'ClementBera 3/18/2013 15:48'! methodClass ^AIRootContext! ! !FakeCompiledMethod methodsFor: 'accessing' stamp: 'ClementBera 3/18/2013 11:23'! sourceCode ^ sourceCode! ! !FakeCompiledMethod methodsFor: 'accessing' stamp: 'ClementBera 3/18/2013 15:43'! sourceCode: aString sourceCode := (self selector, String lf, String tab, aString) asText! ! !FallbackMenu commentStamp: ''! I appear when there is an error while trying to build a menu from pragmas. I include items to: * Debug: give the user an opportunity to see and correct the error * Explain: why they're seeing a different menu * Custom: clients can add items to me by implementing #fallbackMenuOn:. Browse implementors for examples.! !FallbackMenu methodsFor: 'private' stamp: 'SeanDeNigris 6/16/2013 13:48'! builder: aPragmaMenuBuilder builder := aPragmaMenuBuilder.! ! !FallbackMenu methodsFor: 'private' stamp: 'SeanDeNigris 6/14/2013 02:31'! fallbackMenuExplanations | workspace wsBindings | wsBindings := Dictionary newFrom: { #menu-> self }. workspace := Smalltalk tools workspace openContents: '"Something is wrong with this menu. To investigate just debug following expression:" menu debug'. workspace label: 'Fallback menu explanations'; setBindings: wsBindings.! ! !FallbackMenu methodsFor: 'menu actions' stamp: 'SeanDeNigris 6/16/2013 14:50'! debug "If we don't reset the builder after debugging, the fallback menu does not appear anymore" [ builder menuSpec asMenuMorph ] ensure: [ builder reset ].! ! !FallbackMenu methodsFor: 'private' stamp: 'SeanDeNigris 6/16/2013 13:59'! menu "Build the menu that is put up if something is going wrong with the menubuilder" | menu | menu := UIManager default newMenuIn: ActiveWorld for: self. menu addStayUpItem. menu add: 'Why you see this menu' target: self selector: #fallbackMenuExplanations. menu add: 'Debug' target: self selector: #debug. menu addLine. client fallbackMenuOn: menu. ^ menu! ! !FallbackMenu methodsFor: 'private' stamp: 'SeanDeNigris 6/16/2013 13:49'! client: anObject client := anObject.! ! !FallbackMenu class methodsFor: 'instance creation' stamp: 'SeanDeNigris 6/16/2013 13:48'! when: aPragmaMenuBuilder fails: anObject ^ self new builder: aPragmaMenuBuilder; client: anObject; menu.! ! !False commentStamp: ''! False defines the behavior of its single instance, false -- logical negation. Notice how the truth-value checks become direct message sends, without the need for explicit testing. Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.! !False methodsFor: 'converting' stamp: 'IgorStasenko 12/28/2012 15:09'! asBit ^ 0! ! !False methodsFor: 'logical operations' stamp: ''! | aBoolean "Evaluating disjunction (OR) -- answer with the argument, aBoolean." ^aBoolean! ! !False methodsFor: 'controlling' stamp: ''! ifTrue: alternativeBlock "Since the condition is false, answer the value of the false alternative, which is nil. Execution does not actually reach here because the expression is compiled in-line." ^nil! ! !False methodsFor: 'controlling' stamp: ''! ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock "Answer the value of falseAlternativeBlock. Execution does not actually reach here because the expression is compiled in-line." ^falseAlternativeBlock value! ! !False methodsFor: 'controlling' stamp: ''! ifFalse: alternativeBlock "Answer the value of alternativeBlock. Execution does not actually reach here because the expression is compiled in-line." ^alternativeBlock value! ! !False methodsFor: 'controlling' stamp: ''! or: alternativeBlock "Nonevaluating disjunction -- answer value of alternativeBlock." ^alternativeBlock value! ! !False methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: 'false'! ! !False methodsFor: 'logical operations' stamp: 'md 7/30/2005 18:05'! & aBoolean "Evaluating conjunction -- answer false since receiver is false." ^self! ! !False methodsFor: 'logical operations' stamp: 'CamilloBruni 8/1/2012 16:25'! xor: aBoolean ^aBoolean value! ! !False methodsFor: 'logical operations' stamp: ''! not "Negation -- answer true since the receiver is false." ^true! ! !False methodsFor: 'controlling' stamp: ''! ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock "Answer the value of falseAlternativeBlock. Execution does not actually reach here because the expression is compiled in-line." ^falseAlternativeBlock value! ! !False methodsFor: 'controlling' stamp: ''! and: alternativeBlock "Nonevaluating conjunction -- answer with false since the receiver is false." ^self! ! !False class methodsFor: '*Fuel' stamp: 'MartinDias 2/21/2013 12:51'! materializeFrom: aDecoder "Answer my unique instance" ^ false! ! !FalseTest commentStamp: 'TorstenBergmann 2/5/2014 08:50'! SUnit tests for false/False class! !FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:04'! testOr self assert: (false or: ['alternativeBlock']) = 'alternativeBlock'.! ! !FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'! testIfFalse self assert: ((false ifFalse: ['alternativeBlock']) = 'alternativeBlock'). ! ! !FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'! testIfFalseIfTrue self assert: (false ifFalse: ['falseAlternativeBlock'] ifTrue: ['trueAlternativeBlock']) = 'falseAlternativeBlock'. ! ! !FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'! testIfTrueIfFalse self assert: (false ifTrue: ['trueAlternativeBlock'] ifFalse: ['falseAlternativeBlock']) = 'falseAlternativeBlock'. ! ! !FalseTest methodsFor: 'tests' stamp: 'FabrizioPerin 3/13/2010 15:23'! testAnd self deny: (false and: ['alternativeBlock']).! ! !FalseTest methodsFor: 'tests' stamp: 'FabrizioPerin 3/13/2010 15:24'! testOR self assert: (false | true). self deny: (false | false).! ! !FalseTest methodsFor: 'tests' stamp: 'FabrizioPerin 3/13/2010 15:23'! testAND self deny: (false & true). self deny: (false & false).! ! !FalseTest methodsFor: 'tests' stamp: 'StephaneDucasse 3/5/2010 15:32'! testNot self assert: (false not).! ! !FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:04'! testPrintOn self assert: (String streamContents: [:stream | false printOn: stream]) = 'false'. ! ! !FalseTest methodsFor: 'tests' stamp: 'StephaneDucasse 6/9/2012 22:58'! testNew self should: [False new] raise: self defaultTestError ! ! !FalseTest methodsFor: 'tests' stamp: 'Md 11/18/2010 18:49'! testXor self assert: (false xor: true) = true. self assert: (false xor: false) = false. self assert: (false xor: [true]) = true. self assert: (false xor: [false]) = false.! ! !FalseTest methodsFor: 'tests' stamp: 'StephaneDucasse 2/2/2010 13:49'! testAsBit self assert: (false asBit = 0).! ! !FalseTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testIfTrue self assert: (false ifTrue: [ 'alternativeBlock' ]) isNil! ! !FastDraggingFrameMorph commentStamp: 'AlainPlantec 2/22/2012 23:23'! I represents the windows frame for window dragging or resizing when fast dragging or fast resizing is wanted (when UITheme currentSettings fastDragging is set to true). For window resizing, I'm created by a corner or an edge grip when the mouse is clicked on it (see SystemWindow>>doFastWindowReframe:). For window dragging, I'm created when the top window bar is clicked (see SystemWindow>>doFastFrameDrag:). I'm always created with the same bounds as the target window bounds. The mouse focus is given to me and my bounds are changed while the hand is moving. On mouse up, the window bounds is set to my own bounds and then I'm deleted. Instance Variables location: startGap: target: location - The symbol representing the corner or the edge (#topLeft, #top, #topRight .... or #left). I'm set to nil for window dragging startGap - For window dragging, keep track of the distance between the window top bar first click location and the window position target - The window to be resized or dragged ! !FastDraggingFrameMorph methodsFor: 'initialization' stamp: 'FernandoOlivero 9/10/2013 09:56'! defaultBorderWidth ^ 2. ! ! !FastDraggingFrameMorph methodsFor: 'initialization' stamp: 'FernandoOlivero 9/10/2013 09:56'! defaultColor ^ Color gray alpha: 0.15. ! ! !FastDraggingFrameMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/22/2012 23:05'! location: aSymbol "The symbol wich represents the corner or the edge grip location (#topLeft, #top ..., #bottomLeft or #left)" location := aSymbol! ! !FastDraggingFrameMorph methodsFor: 'event handling' stamp: 'AlainPlantec 2/22/2012 23:17'! mouseUp: evt target ifNotNil: [Display deferUpdatesIn: Display boundingBox while: [target bounds: self bounds]]. self delete! ! !FastDraggingFrameMorph methodsFor: 'event handling' stamp: 'AlainPlantec 2/22/2012 22:12'! draggedTo: aPoint self position: aPoint + startGap ! ! !FastDraggingFrameMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/22/2012 21:51'! wantsToBeTopmost "Answer if the receiver want to be one of the topmost objects in its owner" ^ true! ! !FastDraggingFrameMorph methodsFor: 'event handling' stamp: 'AlainPlantec 2/22/2012 23:17'! handlesMouseDown: evt ^ true! ! !FastDraggingFrameMorph methodsFor: 'event handling' stamp: 'AlainPlantec 2/22/2012 22:18'! reframedTo: aPoint self bounds: (self bounds withSideOrCorner: location setToPoint: aPoint)! ! !FastDraggingFrameMorph methodsFor: 'initialization' stamp: 'FernandoOlivero 9/10/2013 09:56'! defaultBorderColor ^ Color gray ! ! !FastDraggingFrameMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/22/2012 23:06'! startGap: aPoint "APoint is the distance between the window position and the first click position" startGap := aPoint! ! !FastDraggingFrameMorph methodsFor: 'event handling' stamp: 'AlainPlantec 2/22/2012 23:09'! mouseDown: evt "Normally, should not be possible" self delete ! ! !FastDraggingFrameMorph methodsFor: 'testing' stamp: 'AlainPlantec 2/22/2012 22:28'! isForDragging ^ location isNil! ! !FastDraggingFrameMorph methodsFor: 'event handling' stamp: 'AlainPlantec 2/22/2012 22:29'! mouseMove: evt self isForDragging ifTrue: [self draggedTo: evt position] ifFalse: [self reframedTo: evt position] ! ! !FastDraggingFrameMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/22/2012 18:56'! target ^ target! ! !FastDraggingFrameMorph methodsFor: 'accessing' stamp: 'FernandoOlivero 9/10/2013 09:57'! target: aSystemWindow target := aSystemWindow. self color: (target paneColor alpha: 0.35). self bounds: aSystemWindow bounds. self currentHand newMouseFocus: self! ! !FastDraggingFrameMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 2/23/2012 00:16'! forResizing: aWindow fromLocation: aSideOrCorner | b | b := self new. b target: aWindow. b location: aSideOrCorner. ^ b ! ! !FastDraggingFrameMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 2/22/2012 23:34'! forDragging: aWindow clickedAt: aPoint | b | b := self new. b target: aWindow. b startGap: aWindow topLeft - aPoint. ^ b! ! !FastInflateStream commentStamp: ''! This class adds the following optimizations to the basic Inflate decompression: a) Bit reversed access If we want to fetch the bits efficiently then we have them in the wrong bit order (e.g., when we should fetch 2r100 we would get 2r001). But since the huffman tree lookup determines the efficiency of the decompression, reversing the bits before traversal is expensive. Therefore the entries in each table are stored in REVERSE BIT ORDER. This is achieved by a reverse increment of the current table index in the huffman table construction phase (see method increment:bits:). According to my measures this speeds up the implementation by about 30-40%. b) Inplace storage of code meanings and extra bits Rather than looking up the meaning for each code during decompression of blocks we store the appropriate values directly in the huffman tables, using a pre-defined mapping. Even though this does not make a big difference in speed, it cleans up the code and allows easier translation into primitive code (which is clearly one goal of this implementation). c) Precomputed huffman tables for fixed blocks So we don't have to compute the huffman tables from scratch. The precomputed tables are not in our superclass to avoid double storage (and my superclass is more intended for documentation anyways).! !FastInflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:15'! processFixedBlock litTable := FixedLitTable. distTable := FixedDistTable. state := state bitOr: BlockProceedBit. self proceedFixedBlock.! ! !FastInflateStream methodsFor: 'inflating' stamp: 'ar 2/2/2001 15:47'! decompressBlock: llTable with: dTable "Process the compressed data in the block. llTable is the huffman table for literal/length codes and dTable is the huffman table for distance codes." | value extra length distance oldPos oldBits oldBitPos | [readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[ "Back up stuff if we're running out of space" oldBits := bitBuf. oldBitPos := bitPos. oldPos := sourcePos. value := self decodeValueFrom: llTable. value < 256 ifTrue:[ "A literal" collection byteAt: (readLimit := readLimit + 1) put: value. ] ifFalse:["length/distance or end of block" value = 256 ifTrue:["End of block" state := state bitAnd: StateNoMoreData. ^self]. "Compute the actual length value (including possible extra bits)" extra := (value bitShift: -16) - 1. length := value bitAnd: 16rFFFF. extra > 0 ifTrue:[length := length + (self nextBits: extra)]. "Compute the distance value" value := self decodeValueFrom: dTable. extra := (value bitShift: -16). distance := value bitAnd: 16rFFFF. extra > 0 ifTrue:[distance := distance + (self nextBits: extra)]. (readLimit + length >= collection size) ifTrue:[ bitBuf := oldBits. bitPos := oldBitPos. sourcePos := oldPos. ^self]. collection replaceFrom: readLimit+1 to: readLimit + length + 1 with: collection startingAt: readLimit - distance + 1. readLimit := readLimit + length. ]. ].! ! !FastInflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:02'! nextSingleBits: n "Fetch the bits all at once" ^self nextBits: n.! ! !FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'! distanceMap ^DistanceMap! ! !FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'! increment: value bits: nBits "Increment value in reverse bit order, e.g. for a 3 bit value count as follows: 000 / 100 / 010 / 110 001 / 101 / 011 / 111 See the class comment why we need this." | result bit | result := value. "Test the lowest bit first" bit := 1 << (nBits - 1). "If the currently tested bit is set then we need to turn this bit off and test the next bit right to it" [(result bitAnd: bit) = 0] whileFalse:[ "Turn off current bit" result := result bitXor: bit. "And continue testing the next bit" bit := bit bitShift: -1]. "Turn on the right-most bit that we haven't touched in the loop above" ^result bitXor: bit! ! !FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'! literalLengthMap ^LiteralLengthMap! ! !FastInflateStream class methodsFor: 'initialization' stamp: 'ar 12/21/1999 23:00'! initialize "FastInflateStream initialize" | low high | "Init literal/length map" low := #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258 ). high := #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0 0). LiteralLengthMap := WordArray new: 256 + 32. 1 to: 257 do:[:i| LiteralLengthMap at: i put: i-1]. 1 to: 29 do:[:i| LiteralLengthMap at: 257+i put: (low at:i) + ( (high at: i) + 1 << 16)]. "Init distance map" high := #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13). low := #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 1025 1537 2049 3073 4097 6145 8193 12289 16385 24577). DistanceMap := WordArray new: 32. 1 to: 30 do:[:i| DistanceMap at: i put: (low at: i) + ( (high at: i) << 16)]. "Init fixed block huffman tables" FixedLitTable := self basicNew huffmanTableFrom: FixedLitCodes mappedBy: LiteralLengthMap. FixedDistTable := self basicNew huffmanTableFrom: FixedDistCodes mappedBy: DistanceMap.! ! !FileCompilerRequestor commentStamp: ''! I am an Object used to interact with the OpalCompiler. I keep a reference to the original input so that error messages can be properly analyzed later-on.! !FileCompilerRequestor methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 15:38'! initialize interactive := false.! ! !FileCompilerRequestor methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2013 15:38'! interactive ^ interactive! ! !FileCompilerRequestor methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2013 16:12'! fileReference: anObject fileReference := anObject! ! !FileCompilerRequestor methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2013 16:45'! failBlock ^ [ :exception | exception pass ]! ! !FileCompilerRequestor methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2013 16:12'! fileReference ^ fileReference! ! !FileCompilerRequestor methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2013 16:12'! contents: anObject contents := anObject! ! !FileCompilerRequestor methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2013 15:38'! interactive: aBoolean interactive := aBoolean! ! !FileCompilerRequestor methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2013 16:12'! contents ^ contents! ! !FileCompilerRequestor methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2013 15:29'! text "compatibility method for the method installer" ^ self contents! ! !FileCompilerRequestor methodsFor: 'interactive error protocol' stamp: 'CamilloBruni 7/10/2013 18:46'! notify: message at: location in: code self flag: #hack. "Should use the new OPalWarnings directly instead of recreating a SyntaxErrorNotification" SyntaxErrorNotification inClass: STCommandLineHandler category: nil withCode: code doitFlag: nil errorMessage: message location: location.! ! !FileCompilerRequestor class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/17/2013 15:08'! fileStream: fileStream ^ self fileReference: fileStream name asFileReference! ! !FileCompilerRequestor class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/10/2013 16:12'! fileReference: aFileReference ^ self new fileReference: aFileReference; yourself! ! !FileContentsBrowser commentStamp: ''! I am a class browser view on a fileout (either a source file (.st) or change set (.cs)). I do not actually load the code into to the system, nor do I alter the classes in the image. Use me to vet code in a comfortable way before loading it into your image. From a FileList, I can be invoked by selecting a source file and selecting the "browse code" menu item from the yellow button menu. I use PseudoClass, PseudoClassOrganizers, and PseudoMetaclass to model the class structure of the source file.! !FileContentsBrowser methodsFor: 'infoview' stamp: 'alain.plantec 5/30/2008 13:04'! updateInfoView self changed: #infoViewContents! ! !FileContentsBrowser methodsFor: 'other' stamp: 'IgorStasenko 3/6/2011 18:51'! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." | class selector | (selector := self selectedMessageName) ifNotNil: [class := self selectedClassOrMetaClass. (class exists and: [class realClass includesSelector: selector]) ifTrue: [Smalltalk tools versionBrowser browseVersionsOf: (class realClass compiledMethodAt: selector) class: class realClass theNonMetaClass meta: class realClass isMeta category: self selectedMessageCategoryName selector: selector]]! ! !FileContentsBrowser methodsFor: 'creation' stamp: 'SD 10/18/2013 14:26'! messageList "Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range. Otherwise, answer an empty Array If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero." ^ super messageList sorted! ! !FileContentsBrowser methodsFor: 'other' stamp: ''! changeMessageCategories: aString "The characters in aString represent an edited version of the the message categories for the selected class. Update this information in the system and inform any dependents that the categories have been changed. This message is invoked because the user had issued the categories command and edited the message categories. Then the user issued the accept command." self classOrMetaClassOrganizer changeFromString: aString. self unlock. self editClass. self classListIndex: classListIndex. ^ true! ! !FileContentsBrowser methodsFor: 'creation' stamp: 'MarcusDenker 11/13/2012 15:10'! createViews contentsSymbol := self defaultDiffsSymbol. "#showDiffs or #prettyDiffs" ^ self open! ! !FileContentsBrowser methodsFor: 'other' stamp: 'sw 10/1/2001 11:16'! labelString "Answer the string for the window title" ^ 'File Contents Browser ', (self selectedSystemCategoryName ifNil: [''])! ! !FileContentsBrowser methodsFor: 'keys' stamp: 'sma 2/6/2000 12:05'! packageListKey: aChar from: view aChar == $f ifTrue: [^ self findClass]. self arrowKey: aChar from: view! ! !FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 2/3/1999 18:46'! fileInMessageCategories Cursor read showWhile:[ self selectedClassOrMetaClass fileInCategory: self selectedMessageCategoryName. ].! ! !FileContentsBrowser methodsFor: 'metaclass' stamp: 'sd 11/20/2005 21:27'! selectedClassOrMetaClass "Answer the selected class or metaclass." | cls | self metaClassIndicated ifTrue: [^ (cls := self selectedClass) ifNotNil: [cls metaClass]] ifFalse: [^ self selectedClass]! ! !FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 5/13/1998 14:19'! fileOutPackage Cursor write showWhile:[ self selectedPackage fileOut. ].! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'tpr 3/11/2001 21:26'! classListMenu: aMenu shifted: ignored "Answer the class list menu, ignoring the state of the shift key in this case" ^ self classListMenu: aMenu! ! !FileContentsBrowser methodsFor: 'class list' stamp: ''! classList "Answer an array of the class names of the selected category. Answer an empty array if no selection exists." (systemCategoryListIndex = 0 or:[self selectedPackage isNil]) ifTrue: [^Array new] ifFalse: [^self selectedPackage classes keys asSortedCollection].! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'StephaneDucasse 8/29/2013 21:05'! removeMessageCategory "If a message category is selected, create a Confirmer so the user can verify that the currently selected message category should be removed from the system. If so, remove it." | messageCategoryName | messageCategoryListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageCategoryName := self selectedMessageCategoryName. (self messageList size = 0 or: [self confirm: 'Are you sure you want to remove this method category and all its methods?']) ifFalse: [^ self]. self selectedClassOrMetaClass removeProtocol: messageCategoryName. self messageCategoryListIndex: 0. self changed: #messageCategoryList.! ! !FileContentsBrowser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | aString := input asString. aText := input asText. editSelection == #editComment ifTrue: [theClass := self selectedClass. theClass ifNil: [self inform: 'You must select a class before giving it a comment.'. ^ false]. theClass comment: aText. ^ true]. editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. self inform:'You cannot change the current selection'. ^false ! ! !FileContentsBrowser methodsFor: 'other' stamp: 'sma 2/6/2000 12:27'! methodHierarchy (self selectedClassOrMetaClass isNil or: [self selectedClassOrMetaClass hasDefinition]) ifFalse: [super methodHierarchy]! ! !FileContentsBrowser methodsFor: '*Shout-Styling' stamp: ''! shoutAboutToStyle: aPluggableShoutMorphOrView self shoutIsModeStyleable ifFalse: [^ false]. aPluggableShoutMorphOrView classOrMetaClass: self selectedClassOrMetaClass. ^ true! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'MarcusDenker 10/7/2012 11:35'! messageListMenu: aMenu ^aMenu addList: #( ('FileIn' fileInMessage) ('FileOut' fileOutMessage) - ('Senders (n)' browseSenders) ('Implementors (m)' browseImplementors) ('Method inheritance (h)' methodHierarchy) ('Versions (v)' browseVersions) - ('Remove' removeMessage)) ! ! !FileContentsBrowser methodsFor: 'class list' stamp: 'StephaneDucasse 5/28/2011 13:40'! findClass | pattern foundClass classNames index foundPackage | self okToChange ifFalse: [^ self classNotFound]. pattern := (UIManager default request: 'Class Name?') asLowercase. pattern isEmptyOrNil ifTrue: [^ self]. classNames := Set new. self packages do:[:p| classNames addAll: p classes keys]. classNames := classNames asArray select: [:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0]. classNames isEmpty ifTrue: [^ self]. index := classNames size = 1 ifTrue: [1] ifFalse: [(UIManager default chooseFrom: classNames lines: #())]. index = 0 ifTrue: [^ self]. foundPackage := nil. foundClass := nil. self packages do:[:p| (p classes includesKey: (classNames at: index)) ifTrue:[ foundClass := p classes at: (classNames at: index). foundPackage := p]]. foundClass isNil ifTrue:[^self]. self systemCategoryListIndex: (self systemCategoryList indexOf: foundPackage packageName asSymbol). self classListIndex: (self classList indexOf: foundClass name). ! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'sw 11/13/2001 09:12'! contentsSymbolQuints "Answer a list of quintuplets representing information on the alternative views available in the code pane. For the file-contents browser, the choices are restricted to source and the two diffing options" ^ self sourceAndDiffsQuintsOnly! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'MarcusDenker 10/7/2012 11:40'! messageCategoryMenu: aMenu ^aMenu addList: #( ('FileIn' fileInMessageCategories) ('FileOut' fileOutMessageCategories) - ('Reorganize' editMessageCategories) - ('Add item...' addCategory) ('Rename...' renameCategory) ('Remove' removeMessageCategory) ('Remove existing' removeUnmodifiedMethods))! ! !FileContentsBrowser methodsFor: 'creation' stamp: 'IgorStasenko 12/20/2012 14:39'! addLowerPanesTo: window at: nominalFractions with: editString | verticalOffset row codePane infoPane infoHeight | row := AlignmentMorph newColumn hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 1; borderColor: Color black; layoutPolicy: ProportionalLayout new. codePane := PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. infoPane := PluggableTextMorph on: self text: #infoViewContents accept: nil readSelection: nil menu: nil. infoPane askBeforeDiscardingEdits: false. verticalOffset := 0. infoHeight := 20. row addMorph: (codePane borderWidth: 0) fullFrame: ( LayoutFrame identity topOffset: verticalOffset ; bottomOffset: infoHeight negated). row addMorph: (infoPane borderWidth: 0; hideScrollBarsIndefinitely) fullFrame: ((0@1 corner: 1@1) asLayoutFrame topOffset: infoHeight negated). window addMorph: row frame: nominalFractions. row on: #mouseEnter send: #paneTransition: to: window. row on: #mouseLeave send: #paneTransition: to: window. ! ! !FileContentsBrowser methodsFor: 'accessing' stamp: ''! packages: aDictionary packages := aDictionary.! ! !FileContentsBrowser methodsFor: 'infoview' stamp: 'sma 5/6/2000 19:19'! extraInfo ^ (self methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName) class: self selectedClass selector: self selectedMessageName meta: self metaClassIndicated) unembellished ifTrue: [' - identical'] ifFalse: [' - modified']! ! !FileContentsBrowser methodsFor: 'diffs' stamp: 'lr 3/14/2010 21:13'! modifiedClassDefinition | pClass rClass old new diff | pClass := self selectedClassOrMetaClass. pClass hasDefinition ifFalse: [ ^ pClass definition ]. rClass := Smalltalk globals at: self selectedClass name asSymbol ifAbsent: [ nil ]. rClass isNil ifTrue: [ ^ pClass definition ]. self metaClassIndicated ifTrue: [ rClass := rClass class ]. old := rClass definition. new := pClass definition. Cursor wait showWhile: [ diff := ClassDiffBuilder buildDisplayPatchFrom: old to: new ]. ^ diff! ! !FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 6/16/1998 17:14'! fileOutMessage self selectedMessageName ifNil: [^self]. Cursor write showWhile: [ self selectedClassOrMetaClass fileOutMethod: self selectedMessageName].! ! !FileContentsBrowser methodsFor: 'infoview' stamp: 'lr 3/14/2010 21:13'! infoViewContents "Answer the string to show in the info view" | theClass stamp exists | editSelection == #newClass ifTrue: [ ^ self packageInfo: self selectedPackage ]. self selectedClass isNil ifTrue: [ ^ '' ]. theClass := Smalltalk globals at: self selectedClass name asSymbol ifAbsent: [ ]. editSelection == #editClass ifTrue: [ ^ theClass notNil ifTrue: [ 'Class exists already in the system' translated ] ifFalse: [ 'New class' translated ] ]. editSelection == #editMessage ifFalse: [ ^ '' ]. (theClass notNil and: [ self metaClassIndicated ]) ifTrue: [ theClass := theClass class ]. stamp := self selectedClassOrMetaClass stampAt: self selectedMessageName. exists := theClass notNil and: [ theClass includesSelector: self selectedMessageName ]. ^ stamp = 'methodWasRemoved' ifTrue: [ exists ifTrue: [ 'Existing method removed by this change-set' translated ] ifFalse: [ 'Removal request for a method that is not present in this image' translated ] ] ifFalse: [ stamp , ' · ' , (exists ifTrue: [ 'Method already exists' translated , self extraInfo ] ifFalse: [ 'New method' translated ]) ]! ! !FileContentsBrowser methodsFor: 'edit pane' stamp: 'MarcusDenker 8/28/2013 10:53'! selectedBytecodes "Compile the source code for the selected message selector and extract and return the bytecode listing." | class selector | class := self selectedClassOrMetaClass. selector := self selectedMessageName. contents := class sourceCodeAt: selector. contents := self class compiler parse: contents. contents := contents generate. ^ contents symbolic asText! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'MarcusDenker 10/7/2012 11:54'! classListMenu: aMenu ^ aMenu addList: #( ('Definition' editClass) ('Comment' editComment) - ('Browse full (b)' browseMethodFull) ('Class refs (N)' browseClassRefs) - ('FileIn' fileInClass) ('FileOut' fileOutClass) - ('Rename...' renameClass) ('Remove' removeClass) - ('Remove existing' removeUnmodifiedCategories)) ! ! !FileContentsBrowser methodsFor: 'creation' stamp: 'MarcusDenker 11/13/2012 15:10'! open "Create a pluggable version of all the views for a Browser, including views and controllers." | window aListExtent next mySingletonList | window := (SystemWindow labelled: 'later') model: self. self packages size = 1 ifTrue: [ aListExtent := 0.333333 @ 0.34. self systemCategoryListIndex: 1. mySingletonList := PluggableListMorph on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: nil keystroke: #packageListKey:from:. mySingletonList hideScrollBarsIndefinitely. window addMorph: mySingletonList frame: (0@0 extent: 1.0@0.06). next := 0@0.06] ifFalse: [ aListExtent := 0.25 @ 0.4. window addMorph: (PluggableListMorph on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: nil keystroke: #packageListKey:from:) frame: (0@0 extent: aListExtent). next := aListExtent x @ 0]. self addClassAndSwitchesTo: window at: (next extent: aListExtent) plus: 0. next := next + (aListExtent x @ 0). window addMorph: (PluggableListMorph on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:) frame: (next extent: aListExtent). next := next + (aListExtent x @ 0). window addMorph: (PluggableListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu: keystroke: #messageListKey:from:) frame: (next extent: aListExtent). self addLowerPanesTo: window at: (0@0.4 corner: 1@1) with: nil. ^ window ! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'wod 2/3/1999 18:47'! removeUnmodifiedMethods | theClass cat | self okToChange ifFalse:[^self]. theClass := self selectedClassOrMetaClass. theClass isNil ifTrue:[^self]. cat := self selectedMessageCategoryName. cat isNil ifTrue:[^self]. Cursor wait showWhile:[ theClass removeUnmodifiedMethods: (theClass organization listAtCategoryNamed: cat). ]. self messageListIndex: 0. self changed: #messageList.! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'StephaneDucasse 8/29/2013 21:05'! removePackage systemCategoryListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (self confirm: 'Are you sure you want to remove this package and all its classes?') ifFalse:[^self]. (systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) do:[:el| systemOrganizer removeElement: el]. self packages removeKey: self selectedPackage packageName. systemOrganizer removeProtocol: self selectedSystemCategoryName. self systemCategoryListIndex: 0. self changed: #systemCategoryList! ! !FileContentsBrowser methodsFor: 'filein/fileout' stamp: ''! fileInClass Cursor read showWhile:[ self selectedClass fileIn. ].! ! !FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 6/16/1998 17:14'! fileInMessage self selectedMessageName ifNil: [^self]. Cursor read showWhile: [ self selectedClassOrMetaClass fileInMethod: self selectedMessageName. ].! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'sd 11/20/2005 21:27'! removeMessage | messageName | messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageName := self selectedMessageName. (self selectedClass confirmRemovalOf: messageName) ifFalse: [^ false]. self selectedClassOrMetaClass removeMethod: self selectedMessageName. self messageListIndex: 0. self setClassOrganizer. "In case organization not cached" self changed: #messageList! ! !FileContentsBrowser methodsFor: 'accessing' stamp: ''! packages ^packages! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'MarcusDenker 9/24/2013 14:13'! removeClass | class | classListIndex = 0 ifTrue: [^ self]. class := self selectedClass. (self confirm:'Are you certain that you want to delete the class ', class name, '?') ifFalse:[^self]. self selectedPackage removeClass: class. self classListIndex: 0. self changed: #classList.! ! !FileContentsBrowser methodsFor: 'edit pane' stamp: 'MarcusDenker 8/28/2013 10:32'! selectedMessage "Answer a copy of the source code for the selected message selector." | class selector | class := self selectedClassOrMetaClass. selector := self selectedMessageName. contents := class sourceCodeAt: selector. self browseWithPrettyPrint ifTrue: [ contents := class compiler format: contents ]. self showingAnyKindOfDiffs ifTrue: [ contents := self methodDiffFor: contents class: self selectedClass selector: self selectedMessageName meta: self metaClassIndicated ]. ^ contents! ! !FileContentsBrowser methodsFor: 'class list' stamp: 'StephaneDucasse 10/15/2011 20:54'! browseMethodFull | myClass | (myClass := self selectedClassOrMetaClass) ifNotNil: [Smalltalk tools browser fullOnClass: myClass realClass selector: self selectedMessageName]! ! !FileContentsBrowser methodsFor: 'other' stamp: 'MarcusDenker 10/13/2013 07:59'! browseSenders "Create and schedule a message set browser on all senders of the currently selected message selector. Do nothing if no message is selected." messageListIndex ~= 0 ifTrue: [self systemNavigation browseAllSendersOf: self selectedMessageName]! ! !FileContentsBrowser methodsFor: 'keys' stamp: 'sma 5/6/2000 18:50'! messageListKey: aChar from: view aChar == $b ifTrue: [^ self browseMethodFull]. super messageListKey: aChar from: view! ! !FileContentsBrowser methodsFor: 'accessing' stamp: ''! selectedPackage | cat | cat := self selectedSystemCategoryName. cat isNil ifTrue:[^nil]. ^self packages at: cat asString ifAbsent:[nil]! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'sd 11/20/2005 21:27'! removeUnmodifiedCategories | theClass | self okToChange ifFalse: [^self]. theClass := self selectedClass. theClass isNil ifTrue: [^self]. Cursor wait showWhile: [theClass removeUnmodifiedMethods: theClass selectors. theClass metaClass removeUnmodifiedMethods: theClass metaClass selectors]. self messageCategoryListIndex: 0. self changed: #messageCategoryList.! ! !FileContentsBrowser methodsFor: 'initialization' stamp: 'dew 9/15/2001 16:19'! defaultBrowserTitle ^ 'File Contents Browser'! ! !FileContentsBrowser methodsFor: 'class list' stamp: ''! selectedClass "Answer the class that is currently selected. Answer nil if no selection exists." self selectedClassName == nil ifTrue: [^nil]. ^self selectedPackage classAt: self selectedClassName! ! !FileContentsBrowser methodsFor: 'diffs' stamp: 'lr 3/14/2010 21:13'! methodDiffFor: aString class: aPseudoClass selector: selector meta: meta "Answer the diff between the current copy of the given class/selector/meta for the string provided" | theClass source | theClass := Smalltalk globals at: aPseudoClass name ifAbsent: [ ^ aString copy ]. meta ifTrue: [ theClass := theClass class ]. (theClass includesSelector: selector) ifFalse: [ ^ aString copy ]. source := theClass sourceCodeAt: selector. ^ Cursor wait showWhile: [ TextDiffBuilder buildDisplayPatchFrom: source to: aString inClass: theClass prettyDiffs: self showingPrettyDiffs ]! ! !FileContentsBrowser methodsFor: 'keys' stamp: 'sma 5/6/2000 18:48'! classListKey: aChar from: view aChar == $b ifTrue: [^ self browseMethodFull]. aChar == $N ifTrue: [^ self browseClassRefs]. self packageListKey: aChar from: view! ! !FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 2/3/1999 18:46'! fileOutMessageCategories Cursor write showWhile:[ self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName. ].! ! !FileContentsBrowser methodsFor: 'infoview' stamp: 'lr 3/14/2010 21:13'! packageInfo: p | nClasses newClasses oldClasses | p isNil ifTrue: [ ^ '' ]. nClasses := newClasses := oldClasses := 0. p classes do: [ :cls | nClasses := nClasses + 1. (Smalltalk globals includesKey: cls name asSymbol) ifTrue: [ oldClasses := oldClasses + 1 ] ifFalse: [ newClasses := newClasses + 1 ] ]. ^ nClasses printString , ' classes (' , newClasses printString , ' new / ' , oldClasses printString , ' modified)'! ! !FileContentsBrowser methodsFor: 'class list' stamp: 'DamienCassou 9/29/2009 09:11'! renameClass | oldName newName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName := self selectedClass name. newName := (self request: 'Please type new class name' initialAnswer: oldName) asSymbol. (newName isEmptyOrNil or:[newName = oldName]) ifTrue: [^ self]. (self selectedPackage classes includesKey: newName) ifTrue: [^ self error: newName , ' already exists in the package']. systemOrganizer classify: newName under: self selectedSystemCategoryName. systemOrganizer removeElement: oldName. self selectedPackage renameClass: self selectedClass to: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). ! ! !FileContentsBrowser methodsFor: 'other' stamp: 'sd 11/20/2005 21:27'! didCodeChangeElsewhere "Determine whether the code for the currently selected method and class has been changed somewhere else." | aClass | (aClass := self selectedClassOrMetaClass) ifNil: [^ false]. (aClass isKindOf: PseudoClass) ifTrue: [^ false]. "class not installed" ^super didCodeChangeElsewhere! ! !FileContentsBrowser methodsFor: 'accessing' stamp: ''! contents self updateInfoView. (editSelection == #newClass and:[self selectedPackage notNil]) ifTrue: [^self selectedPackage packageInfo]. editSelection == #editClass ifTrue:[^self modifiedClassDefinition]. ^super contents! ! !FileContentsBrowser methodsFor: 'metaclass' stamp: 'sd 11/20/2005 21:27'! setClassOrganizer "Install whatever organization is appropriate" | theClass | classOrganizer := nil. metaClassOrganizer := nil. classListIndex = 0 ifTrue: [^ self]. classOrganizer := (theClass := self selectedClass) organization. metaClassOrganizer := theClass metaClass organization. ! ! !FileContentsBrowser methodsFor: 'filein/fileout' stamp: ''! fileOutClass Cursor write showWhile:[ self selectedClass fileOut. ].! ! !FileContentsBrowser class methodsFor: 'System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:21'! fileReaderServicesForFile: fullName suffix: suffix ((FileStream isSourceFileSuffix: suffix) or: [ suffix = '*' ]) ifTrue: [ ^Array with: self serviceBrowseCode]. ^(fullName endsWith: 'cs.gz') ifTrue: [ Array with: self serviceBrowseCompressedCode ] ifFalse: [#()] ! ! !FileContentsBrowser class methodsFor: 'System-FileRegistry' stamp: 'tbn 8/11/2010 10:11'! serviceBrowseCodeFiles ^ (SimpleServiceEntry provider: self label: 'Browse code files' selector: #selectAndBrowseFile:) argumentGetter: [ :fileList | fileList ]; yourself! ! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nice 1/5/2010 15:59'! browseStream: aStream named: aString | browser | Cursor wait showWhile: [ | package packageDict organizer | packageDict := Dictionary new. browser := self new. organizer := SystemOrganizer defaultList: Array new. package := (FilePackage new fullName: aString; fileInFrom: aStream). packageDict at: package packageName put: package. organizer classifyAll: package classes keys under: package packageName. (browser := self systemOrganizer: organizer) packages: packageDict]. self openBrowserView: browser createViews label: 'File Contents Browser'. ! ! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nice 1/5/2010 15:59'! browseCompressedCodeStream: aStandardFileStream "Browse the selected file in fileIn format." | unzipped | [ | zipped |zipped := GZipReadStream on: aStandardFileStream. unzipped := MultiByteBinaryOrTextStream with: zipped contents asString] ensure: [aStandardFileStream close]. unzipped reset. self browseStream: unzipped named: aStandardFileStream name! ! !FileContentsBrowser class methodsFor: 'window color' stamp: 'AlainPlantec 12/16/2009 22:08'! patchworkUIThemeColor "Answer a default color for UI themes that make use of different colors for Browser, MessageList etc..." ^ Color tan ! ! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nice 1/5/2010 15:59'! browseFiles: fileList | browser | Cursor wait showWhile: [ | packageDict organizer | packageDict := Dictionary new. organizer := SystemOrganizer defaultList: Array new. fileList do: [:fileName | | package | package := FilePackage fromFileNamed: fileName. packageDict at: package packageName put: package. organizer classifyAll: package classes keys under: package packageName]. (browser := self systemOrganizer: organizer) packages: packageDict]. self openBrowserView: browser createViews label: 'File Contents Browser'. ! ! !FileContentsBrowser class methodsFor: 'System-FileRegistry' stamp: 'tbn 8/11/2010 10:11'! serviceBrowseCode "Answer the service of opening a file-contents browser" ^ (SimpleServiceEntry provider: self label: 'Code-file browser' selector: #browseStream: description: 'Open a "file-contents browser" on this file, allowing you to view and selectively load its code' buttonLabel: 'code') argumentGetter: [ :fileList | fileList readOnlyStream ]! ! !FileContentsBrowser class methodsFor: 'System-FileRegistry' stamp: 'tbn 8/11/2010 10:12'! serviceBrowseCompressedCode "Answer a service for opening a changelist browser on a file" ^ (SimpleServiceEntry provider: self label: 'Code-file browser' selector: #browseCompressedCodeStream: description: 'Open a "file-contents browser" on this file, allowing you to view and selectively load its code' buttonLabel: 'Code') argumentGetter: [ :fileList | fileList readOnlyStream ]! ! !FileContentsBrowser class methodsFor: 'System-FileRegistry' stamp: 'md 11/23/2004 13:34'! services "Answer potential file services associated with this class" ^ {self serviceBrowseCode}.! ! !FileContentsBrowser class methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:36'! initialize FileServices registerFileReader: self! ! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'onierstrasz 11/11/2013 12:25'! browseFile: aFilename "Open a file contents browser on a file of the given name" aFilename ifNil: [^ self inform: 'File name to browse is nil']. self browseFiles: (Array with: aFilename)! ! !FileContentsBrowser class methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:37'! unload FileServices unregisterFileReader: self ! ! !FileContentsBrowser class methodsFor: 'System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:27'! fileReaderServicesForDirectory: aDirectory ^{ self serviceBrowseCodeFiles }! ! !FileContentsBrowser class methodsFor: 'System-FileRegistry' stamp: 'CamilloBruni 5/9/2012 11:54'! selectAndBrowseFile: aFileList "When no file are selected you can ask to browse several of them" | selectionPattern files | selectionPattern := UIManager default request:'What files?' initialAnswer: '*.cs;*.st'. selectionPattern ifNil: [selectionPattern := String new]. files := (aFileList directory filesMatching: selectionPattern). self browseFiles: files. ! ! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'IgorStasenko 3/6/2011 18:12'! browseStream: aStream aStream setConverterForCode. self browseStream: aStream named: aStream name! ! !FileDialogWindow commentStamp: 'gvc 5/18/2007 13:10'! Dialog based file chooser for selcting or saving files. Supports various types of answer (file stream, file name, directory path etc) with optional extension filters and image or text file preview.! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 6/22/2012 13:04'! newFileList "Answer a new file list." ^(self newListFor: self list: #files selected: #selectedFileIndex changeSelected: #selectedFileIndex: icon: #iconFor: getEnabled: nil help: nil) wrapSelector: #basename; doubleClickSelector: #doubleClickFile; minWidth: 200! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/21/2012 19:24'! answerDirectory "Set the receiver to answer a directory." self actionSelector: #selectedAnyFileDirectory. self fileSelectionBlock: self directoryFileSelectionBlock. self changed: #okEnabled! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 16:04'! answerForceSaveFile "Set the receiver to answer a forced new file stream." self actionSelector: #saveForcedSelectedFile. self changed: #okEnabled! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 2/14/2012 11:46'! directoriesFor: item "Answer the filtered entries." ^item directories! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 6/22/2012 13:06'! cache: dir "Cache the contents of the given directory and answer them." self entryCacheDirectory = dir ifFalse: [Cursor wait showWhile: [ self entryCache: (dir isReadable ifFalse: [ #() ] ifTrue: [ dir entries ]); entryCacheDirectory: dir]]. ^self entryCache! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:51'! fileSortBlock "Answer the value of fileSortBlock" ^ fileSortBlock! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 12/2/2011 12:45'! updateFiles "Notify that the files have changed." self changed: #files! ! !FileDialogWindow methodsFor: 'initialization' stamp: 'SeanDeNigris 6/21/2012 20:27'! initialize "Initialize the receiver." selectedFileIndex := 0. fileNameText := ''. self answerPathName; directories: self initialDirectories; showDirectoriesInFileList: true; fileSelectionBlock: self defaultFileSelectionBlock; fileSortBlock: self defaultFileSortBlock. super initialize. "Must be at end or signals error. No idea why - SeanDeNigris"! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:44'! showDirectoriesInFileList: anObject "Set the value of showDirectoriesInFileList" showDirectoriesInFileList := anObject. self updateFiles! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 6/22/2012 13:21'! deleteFileOrDirectory "Delete the selected file or directory." |entry| self hasSelectedFileOrDirectory ifFalse: [^self]. entry := self selectedFileEntry. entry isDirectory ifTrue: [(self proceed: 'Are you sure you wish to delete the\selected directory along with its files?' withCRs translated title: 'Delete Directory' translated) ifTrue: [ entry asFileReference delete. self clearEntryCache; updateDirectories]] ifFalse: [(self proceed: 'Are you sure you wish to delete the\file' withCRs translated, ' "', entry name, '"?' title: 'Delete Directory' translated) ifTrue: [ entry asFileReference delete. self selectedFileIndex: 0; clearEntryCache; updateFiles]].! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/14/2007 16:42'! previewType: anObject "Set the value of previewType. See #updatePreview for supported types." previewType := anObject! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:36'! updateTextPreview "Update the text preview." |str text| str := self openSelectedFile. str ifNil: [^self]. [[text := str next: 5000] on: Error do: []] ensure: [str close]. text ifNil: [text := '']. self previewMorph setText: text! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:39'! fileSelectionBlock "Answer the value of fileSelectionBlock" ^ fileSelectionBlock! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! entryCacheDirectory "Answer the value of entryCacheDirectory" ^ entryCacheDirectory! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2009 10:54'! newDirectoryTree "Answer a new directory tree." ^(self newTreeFor: self list: #directories selected: #selectedDirectory changeSelected: #selectedDirectory:) minHeight: 200; minWidth: 180! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'S 6/17/2013 13:26'! newDirectory "Create a new directory within the selected directory." |dir dirName title| dir := self selectedFileDirectory ifNil: [^self]. title := 'Create Directory' translated. dirName := self textEntry: 'Enter directory name' translated title: title. dirName ifNil: [^self]. [ (dir / dirName) exists ifTrue: [ ^self alert: 'A file or directory already exists\with the name' withCRs translated, ' "', dirName, '"' title: title ]. (dir / dirName) ensureCreateDirectory ] on: Error do: [:ex | ^self alert: 'Invalid directory name' translated, ' "', dirName, '"' title: title ]. self clearEntryCache; updateDirectories! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:51'! fileSortBlock: anObject "Set the value of fileSortBlock" fileSortBlock := anObject! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 5/4/2012 20:07'! validExtensions: aList "Set the filter for the files to be those with the given extensions." aList notEmpty ifTrue: [self defaultExtension: aList first]. self fileSelectionBlock: [:de | de isDirectory ifTrue: [self showDirectoriesInFileList] ifFalse: [ (self fileNamePattern match: de name) and: [ aList includes: de extension asLowercase]]] ! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 13:55'! previewMorph: anObject "Set the value of previewMorph" previewMorph := anObject! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:45'! fileSelectionBlock: anObject "Set the value of fileSelectionBlock" fileSelectionBlock := anObject. self updateFiles! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 15:42'! selectedFileIndex "Answer the value of selectedFileIndex" ^ selectedFileIndex! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/21/2012 20:22'! hasSelectedFileOrDirectory "Answer whether a file or directopry is selected in the file list." ^ self selectedFileIndex ~= 0! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/27/2006 10:33'! actionSelector "Answer the value of actionSelector" ^ actionSelector! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/21/2012 20:20'! files "Answer the contents of the selected directory." self selectedFileDirectory ifNil: [ ^#() ]. Cursor wait showWhile: [ | cache filteredCache | cache := self cache: self selectedFileDirectory. filteredCache := cache select: self fileSelectionBlock. ^ filteredCache asSortedCollection: self fileSortBlock ].! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! iconFor: anEntry "Answer the icon to use for the directory entry." ^ anEntry isDirectory ifTrue: [ Smalltalk ui icons smallOpenIcon ] ifFalse: [(self isImageFile: anEntry basename) ifTrue: [ Smalltalk ui icons smallPaintIcon] ifFalse: [ Smalltalk ui icons smallLeftFlushIcon]]! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 10/3/2013 23:49'! selectedDirectoryName ^ self selectedFileDirectory ifNotNil: [ :dir | dir basename ]! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! directoryTreeMorph "Answer the value of directoryTreeMorph" ^ directoryTreeMorph! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2009 10:55'! newContentMorph "Answer a new content morph." self directoryTreeMorph: self newDirectoryTree; fileListMorph: self newFileList; previewMorph: self newPreviewMorph. ^(self newRow: { self newColumn: { self newGroupbox: 'Directory' translated for: self directoryTreeMorph. (self newLabelGroup: { 'File name' translated->self newFileNameTextEntry}) vResizing: #shrinkWrap}. self newGroupbox: 'File' translated forAll: { self fileListMorph. self newActionButtonRow}}, (self previewMorph notNil ifTrue: [{self newGroupbox: 'Preview' translated for: self previewMorph}] ifFalse: [#()])) vResizing: #spaceFill! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 15:59'! newOKButton "Answer a new OK button." ^self newOKButtonFor: self getEnabled: #okEnabled! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/21/2012 20:36'! newTextPreviewMorph "Answer a new text preview morph." ^(self newTextEditorFor: self getText: nil setText: nil getEnabled: nil) hResizing: #rigid; vResizing: #spaceFill; extent: self previewSize; minWidth: self previewSize x; minHeight: self previewSize y; enabled: false! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 5/4/2012 19:59'! addInitialPanel "Add the panel." super addInitialPanel. self selectDirectory: FileSystem disk workingDirectory ! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:38'! previewSize "Answer the size of preview to use." self previewType == #text ifTrue: [^256@256]. ^128@128! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:46'! selectedFileIndex: anObject "Set the value of selectedFileIndex" selectedFileIndex := anObject. self updateSelectedFile! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! entryCache: anObject "Set the value of entryCache" entryCache := anObject! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! newUpButton "Answer a new up one directory level button." ^self newButtonFor: self getState: nil action: #selectParentDirectory arguments: nil getEnabled: #hasParentDirectory labelForm: Smalltalk ui icons smallUndoIcon help: 'Press to switch to the parent of the current directory' translated! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:42'! showDirectoriesInFileList "Answer the value of showDirectoriesInFileList" ^ showDirectoriesInFileList! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/11/2010 22:00'! initialExtent ^ 750@550! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! newDeleteButton "Answer a new delete button." ^self newButtonFor: self getState: nil action: #deleteFileOrDirectory arguments: nil getEnabled: #hasSelectedFileOrDirectory labelForm: Smalltalk ui icons smallDeleteIcon help: 'Press to delete the selected file or directory' translated! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/21/2012 20:22'! hasParentDirectory "Answer whether the selected directory in the tree part has a parent." ^ self selectedFileDirectory ifNotNil: [ :dir | dir isRoot not ] ifNil: [ false ].! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/4/2007 16:34'! okEnabled "Answer wether the ok button should be enabled." (#(selectedAnyFileDirectory selectedPathName) includes: self actionSelector) ifTrue: [^true]. ((#(saveSelectedFile saveForcedSelectedFile) includes: self actionSelector) and: [self fileNameText notEmpty]) ifTrue: [^true]. (self actionSelector = #selectedFileName and: [ self selectedFileName notNil]) ifTrue: [^true]. ^self selectedFileName notNil and: [self selectedFileEntry isDirectory not]! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 10:41'! updateSelectedDirectory "Notify that the selected directory has changed." self changed: #selectedDirectory; changed: #selectedFileDirectory; changed: #selectedPathName; changed: #hasParentDirectory! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! entryCache "Answer the value of entryCache" ^ entryCache! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2009 11:17'! isResizeable "Answer whether we are not we can be resized." ^true! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! fileListMorph "Answer the value of fileListMorph" ^ fileListMorph! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 9/24/2012 16:47'! openSelectedFile "Open a stream on the selected file if available and return it." |d f fileRef | d := self selectedFileDirectory ifNil: [^nil]. f := self selectedFileName ifNil: [^nil]. self selectedFileEntry isDirectory ifTrue: [^nil]. fileRef := d/f. ^ fileRef exists ifTrue: [ fileRef readStream ] ifFalse: nil ! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! entryCacheDirectory: anObject "Set the value of entryCacheDirectory" entryCacheDirectory := anObject! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/4/2007 16:00'! answerFileName "Set the receiver to answer the selected file name." self actionSelector: #selectedFileName. self changed: #okEnabled! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/2/2007 12:19'! selectFileFromPattern "If there is a single file matching the pattern then select it. If none then try for a directory." |f matches subMatches| f := self files. matches := f select: [:de | self fileNamePattern match: de name]. subMatches := matches select: [:de | de isDirectory not]. subMatches size = 1 ifTrue: [ ^self selectedFileIndex: (f indexOf: subMatches first)]. subMatches := matches select: [:de | de isDirectory]. subMatches size = 1 ifTrue: [^self selectedFileIndex: (f indexOf: subMatches first)]. self selectedFileIndex: 0! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/23/2006 14:29'! directoryNamesFor: item "Answer the filtered entries." ^item directoryNames! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:24'! newPreviewMorph "Answer a new preview morph." self previewType == #image ifTrue: [^self newImagePreviewMorph]. self previewType == #text ifTrue: [^self newTextPreviewMorph]. ^nil! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:33'! updateImagePreview "Update the image preview." |str form| (self isImageFile: self selectedFileName) ifFalse: [^self previewMorph image: nil size: self previewSize]. str := self openSelectedFile. str ifNil: [^self]. [[str binary. form := ImageReadWriter formFromStream: str] on: Error do: []] ensure: [str close]. self previewMorph image: form size: self previewSize! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/21/2012 19:26'! defaultFileSelectionBlock "Answer the default file selection block." ^[:entry | entry isDirectory ifTrue: [self showDirectoriesInFileList] ifFalse: [self fileNamePattern match: entry basename]]! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 10:41'! ok "Apply the changes and close." self cancelled: false. self applyChanges. self answer: (self perform: self actionSelector). answer ifNil: [ self cancelled: true. ^self delete]. super ok! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! fileListMorph: anObject "Set the value of fileListMorph" fileListMorph := anObject! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/31/2006 15:19'! answer "Answer the result of performing the action selector." self cancelled ifTrue: [^nil]. ^answer! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 7/12/2012 08:45'! saveSelectedFile "Open a stream on the selected file if available and return it." |d f| d := self selectedFileDirectory ifNil: [^nil]. f := self selectedFileName ifNil: [self fileNameText trimBoth]. f ifEmpty: [ ^ nil ]. f := d asFileReference / f. (f extension isEmpty and: [self defaultExtension notNil]) ifTrue: [ f := f, self defaultExtension]. f exists ifFalse: [ ^ f ]. ^(self proceed: ('The file {1} already exists. Overwrite the file?' translated format: {f printString}) title: 'Save File' translated) ifTrue: [ f delete ]! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 16:04'! answerSaveFile "Set the receiver to answer a new file stream." self actionSelector: #saveSelectedFile. self changed: #okEnabled! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 14:19'! directories: anObject "Set the value of directories" directories := anObject! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/21/2012 19:23'! selectedPathName "Answer the name of the selected path." selectedDirectory := self selectedFileDirectory ifNil: [^nil]. ^ self selectedFileName ifNil: [ selectedDirectory fullName ] ifNotNil: [ :filename | (selectedDirectory / filename) fullName ].! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 7/17/2012 17:24'! selectDirectory: aFileReference "Expand and select the given directory." self changed: #(openPath), aFileReference pathSegments! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! newNewDirectoryButton "Answer a new 'new directory' button." ^self newButtonFor: self getState: nil action: #newDirectory arguments: nil getEnabled: nil labelForm: Smalltalk ui icons smallOpenIcon help: 'Press to create a new directory within the current directory' translated! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/21/2012 19:11'! initialDirectories "Answer the initial directories." | dirList | dirList := FileSystem disk root directories collect: [ :each | FileDirectoryWrapper with: each name: each basename model: self ]. dirList isEmpty ifTrue: [ | workingDirectory wrapper | workingDirectory := FileSystem disk workingDirectory. wrapper := FileDirectoryWrapper with: workingDirectory name: workingDirectory basename model: self. dirList := Array with: wrapper ]. ^dirList! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 5/7/2013 09:26'! selectPathName: aString "Select the directory and set the file name text from the given string." | reference | reference := aString asFileReference asAbsolute. reference exists ifFalse: [ ^ self selectPathName: reference parent fullName ]. reference isDirectory ifTrue: [ ^ self selectDirectory: reference ]. "must be a file then" self selectDirectory: reference parent. self fileNameText: reference basename.! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/3/2007 15:19'! fileNameText: aString "The typed file name has changed." fileNameText = aString asString ifTrue: [^self]. fileNameText := aString asString. self updateFiles. self changed: #fileNameText; changed: #okEnabled. self selectFileFromPattern! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/3/2007 15:20'! newFileNameTextEntry "Answer a new file name text entry morph." ^self newAutoAcceptTextEntryFor: self getText: #fileNameText setText: #fileNameText: getEnabled: nil help: 'File name filter pattern' translated! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 14:00'! answer: anObject "Set the answer." answer := anObject! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/11/2006 13:33'! defaultExtension "Answer the value of defaultExtension" ^ defaultExtension! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/21/2012 19:28'! defaultFileSortBlock "Answer the default file stor block" ^[:entry1 :entry2 | entry1 isDirectory = entry2 isDirectory ifTrue: [entry1 basename <= entry2 basename] ifFalse: [entry1 isDirectory ifTrue: [true] ifFalse: [entry2 isDirectory ifTrue: [false] ifFalse: [entry1 basename <= entry2 basename]]]]! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/27/2006 10:33'! actionSelector: anObject "Set the value of actionSelector" actionSelector := anObject! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SvenVanCaekenberghe 1/8/2012 14:43'! fileNamePattern "Answer the file name pattern to filter on." ^self fileNameText trimBoth, '*'! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 14:19'! directories "Answer the value of directories" ^ directories! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 16:04'! answerPathName "Set the receiver to answer the selected path name." self actionSelector: #selectedPathName. self changed: #okEnabled! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 6/22/2012 13:08'! doubleClickFile "If the selected entry is a directory then navigate it otherwise ok the dialog." |fe de sm| fe := self selectedFileEntry. fe ifNil: [^self]. fe isDirectory ifTrue: [de := self selectedFileDirectory. sm := self directoryTreeMorph selectedMorph. self changed: #(openPath), de pathSegments. sm := self directoryTreeMorph selectedMorph. self selectedDirectory: (sm children detect: [:w | w complexContents item basename = fe basename ]) complexContents] ifFalse: [self ok]! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! directoryTreeMorph: anObject "Set the value of directoryTreeMorph" directoryTreeMorph := anObject! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 6/22/2012 13:12'! selectParentDirectory "Switch to the parent directory." self hasParentDirectory ifFalse: [^self]. self selectDirectory: self selectedFileDirectory asFileReference parent! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 13:55'! previewMorph "Answer the value of previewMorph" ^ previewMorph! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 2/1/2013 11:59'! selectedAnyFileDirectory "If a directory is selected in the 'File' pane, return that. Otherwise, return the directory selected in 'Directory pane (i.e. the tree)" | selectedFile isDirectorySelected | selectedFile := self selectedFileEntry. isDirectorySelected := selectedFile isNil not and: [ selectedFile isDirectory ]. ^ isDirectorySelected ifTrue: [ selectedFile asFileReference ] ifFalse: [ self selectedFileDirectory ].! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 10:39'! newActionButtonRow "Answer a new row with the action buttons." ^(self newRow: { self newUpButton. self newNewDirectoryButton. self newDeleteButton}) listCentering: #bottomRight! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/4/2007 16:08'! answerFileEntry "Set the receiver to answer the selected file entry." self actionSelector: #selectedFileEntry. self changed: #okEnabled! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:49'! selectedDirectory: anObject "Set the value of selectedDirectory" selectedDirectory := anObject. self selectedFileIndex: 0; updateSelectedDirectory; updateFiles! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 10/13/2011 17:56'! updateDirectories "Update the directory tree and reselect the current." |dir| dir := self selectedFileDirectory. self changed: #directories. self selectDirectory: dir. self updateFiles! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:25'! updatePreview "Update the preview." self previewType == #image ifTrue: [self updateImagePreview]. self previewType == #text ifTrue: [self updateTextPreview]! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 10:40'! updateSelectedFile "Notify that the selected file has changed." self changed: #selectedFileIndex; changed: #selectedFileEntry; changed: #selectedFileName; changed: #selectedPathName; changed: #okEnabled; changed: #hasSelectedFileOrDirectory. self updatePreview! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SvenVanCaekenberghe 1/8/2012 14:43'! saveForcedSelectedFile "Open a stream on the selected file if available and return it." |d f| d := self selectedFileDirectory ifNil: [^nil]. f := self selectedFileName ifNil: [self fileNameText trimBoth]. f ifEmpty: [^nil]. ^d forceNewFileNamed: f! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 10/3/2013 23:50'! selectedFileName ^ self selectedFileEntry ifNotNil: [ :dir | dir basename ]! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 11:23'! clearEntryCache "Clear the entry cache." self entryCache: nil; entryCacheDirectory: nil! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 3/23/2007 16:04'! answerOpenFile "Set the receiver to answer a new file stream on an existing file." self actionSelector: #openSelectedFile. self changed: #okEnabled! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 13:30'! previewType "Answer the value of previewType" ^ previewType! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 7/12/2012 08:44'! isImageFile: aString "Answer whether the file name indicates an image file." aString ifNil: [^false]. ^#('pcx' 'bmp' 'jpeg' 'xbm' 'pnm' 'ppm' 'gif' 'pam' 'jpg' 'png' 'pbm') includes: aString asFileReference extension asLowercase! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 11/5/2008 12:09'! selectedFileEntry "Answer the selected file." self selectedFileIndex = 0 ifTrue: [^nil]. ^self files at: self selectedFileIndex ifAbsent: [nil]! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/24/2006 15:54'! fileNameText "Answer the typed file name." ^fileNameText! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 9/5/2012 20:37'! selectedFileDirectory "Answer the selected file directory in the tree part." ^ (self selectedDirectory ifNil: [^nil]) item! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/23/2006 14:19'! defaultLabel "Answer the default label for the receiver." ^'File' translated! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'stephane.ducasse 4/13/2009 21:06'! directoryFileSelectionBlock "Answer the directory file selection block." ^[:de | de isDirectory ifTrue: [self showDirectoriesInFileList] ifFalse: [false]] ! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/14/2007 16:33'! newImagePreviewMorph "Answer a new image preview morph." ^ImagePreviewMorph new cornerStyle: self preferredCornerStyle; image: nil size: self previewSize! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 14:33'! selectedDirectory "Answer the value of selectedDirectory" ^ selectedDirectory! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/11/2006 13:33'! defaultExtension: anObject "Set the value of defaultExtension" defaultExtension := anObject! ! !FileDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallOpenIcon! ! !FileDialogWindowTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:26'! testIssue6406 | aFolder dialog file invalidFolder | aFolder := (FileSystem workingDirectory / 'folder') ensureCreateDirectory. [ "Absolute folder paths work" dialog := FileDialogWindow new selectPathName: aFolder fullName. "just compare the lower-case path names for now since on mac the test will fail under certain circumstances..." self assert: dialog selectedFileDirectory fullName asLowercase equals: aFolder fullName asLowercase. "Relative folder paths work" dialog := FileDialogWindow new selectPathName: 'folder' asFileReference. self assert: dialog selectedFileDirectory fullName asLowercase equals: aFolder fullName asLowercase. "Invalid folder defaults to the working folder" invalidFolder := 'cant-possibly-exist-for-testIssue6406'. dialog := FileDialogWindow new selectPathName: invalidFolder. self assert: dialog selectedFileDirectory fullName asLowercase equals: FileSystem workingDirectory fullName asLowercase. ] ensure: [ aFolder ensureDelete. ]! ! !FileDirectoryWrapper methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon "Answer a form to be used as icon" "^ item isRemoteDirectory ifTrue: [ Smalltalk ui icons smallRemoteOpenIcon] ifFalse: [Smalltalk ui icons smallOpenIcon]" ^ Smalltalk ui icons smallOpenIcon! ! !FileDirectoryWrapper methodsFor: 'accessing' stamp: 'RAA 7/21/2000 11:00'! balloonText ^balloonText! ! !FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 18:30'! settingSelector ^#setSelectedDirectoryTo:! ! !FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/21/2000 11:01'! balloonText: aStringOrNil balloonText := aStringOrNil! ! !FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 6/22/2012 12:54'! directoriesFor: anItem ^model directoriesFor: anItem! ! !FileDirectoryWrapper methodsFor: 'accessing' stamp: 'CamilloBruni 9/4/2013 15:33'! hasContents "Return whether this directory has subfolders. The value is cached to avoid a performance penalty. Also for performance reasons, the code below will just assume that the directory does indeed have contents in a few of cases: 1. If the item is not a FileDirectory (thus avoiding the cost of refreshing directories that are not local) 2. If it's the root directory of a given volume 3. If there is an error computing the FileDirectory's contents " hasContents ifNil: [ hasContents := [ item isDirectory and: [ item isReadable and: [ item hasDirectories ]] ] on: Error do: [ :error | false ]]. ^ hasContents! ! !FileDirectoryWrapper methodsFor: 'accessing' stamp: 'CamilloBruni 2/14/2012 13:03'! contents ^((model directoriesFor: item) sort: [ :a :b | a basename caseInsensitiveLessOrEqual: b basename]) collect: [ :directory| self class with: directory name: directory basename model: self ] ! ! !FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'sps 12/5/2002 16:59'! setItem: anObject name: aString model: aModel item := anObject. model := aModel. itemName := aString. hasContents := nil. ! ! !FileDirectoryWrapper methodsFor: 'converting' stamp: 'dgd 8/27/2004 18:45'! asString ^itemName translatedIfCorresponds! ! !FileDirectoryWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 18:01'! with: anObject name: aString model: aModel ^self new setItem: anObject name: aString model: aModel! ! !FileDoesNotExist commentStamp: 'cwp 11/18/2009 12:35'! I am raised when an operation is attempted on a file that does not exist. This includes cases where a file operation is attempted on a directory.! !FileDoesNotExistException commentStamp: 'TorstenBergmann 2/3/2014 23:37'! Notify when fie does not exist! !FileDoesNotExistException methodsFor: 'accessing' stamp: 'mir 7/25/2000 16:41'! readOnly ^readOnly == true! ! !FileDoesNotExistException methodsFor: 'accessing' stamp: 'mir 7/25/2000 16:40'! readOnly: aBoolean readOnly := aBoolean! ! !FileDoesNotExistException methodsFor: 'exceptiondescription' stamp: 'pavel.krivanek 6/17/2010 10:00'! defaultAction "The default action taken if the exception is signaled." ^ UIManager default fileDoesNotExistsDefaultAction: self ! ! !FileDoesNotExistException class methodsFor: 'examples' stamp: 'mir 2/29/2000 11:44'! example "FileDoesNotExistException example" | result | result := [(StandardFileStream readOnlyFileNamed: 'error42.log') contentsOfEntireFile] on: FileDoesNotExistException do: [:ex | 'No error log']. Transcript show: result; cr! ! !FileExists commentStamp: 'cwp 11/18/2009 12:37'! I am raised on an attempt to create a file or directory over top of an existing file.! !FileExistsException commentStamp: 'TorstenBergmann 2/3/2014 23:37'! Notify when file exists! !FileExistsException methodsFor: 'accessing' stamp: 'LC 10/24/2001 21:42'! fileClass: aClass fileClass := aClass! ! !FileExistsException methodsFor: 'accessing' stamp: 'LC 10/24/2001 21:49'! fileClass ^ fileClass ifNil: [StandardFileStream]! ! !FileExistsException methodsFor: 'exceptiondescription' stamp: 'pavel.krivanek 6/17/2010 10:00'! defaultAction "The default action taken if the exception is signaled." ^ UIManager default fileExistsDefaultAction: self ! ! !FileExistsException class methodsFor: 'exceptioninstantiator' stamp: 'LC 10/24/2001 21:50'! fileName: aFileName fileClass: aClass ^ self new fileName: aFileName; fileClass: aClass! ! !FileHandle commentStamp: 'cwp 11/18/2009 13:02'! I provide an interface for doing IO on an open file. I keep an id, which as an opaque identifier used by the FilePlugin primitives. I translate positions from the 1-based indexes used in Smalltalk to the 0-based offsets used by the primitives. I do not implement the primitives myself, instead delegating those to an instance of FilePluginPrimitives.! !FileHandle methodsFor: 'streams-compatibility' stamp: 'MaxLeske 1/25/2014 23:07'! binaryReadStream ^ (FileStream onHandle: self) ifNil: [ self streamError ] ifNotNilDo: [ :stream | stream binary; yourself ]! ! !FileHandle methodsFor: 'public' stamp: 'CamilloBruni 5/24/2012 15:20'! size self flag: 'TODO: remove once FileHandles are really used!!'. self assureOpen. ^ Primitives size: id! ! !FileHandle methodsFor: 'public' stamp: 'cwp 11/20/2009 14:59'! close Primitives close: id. id := nil! ! !FileHandle methodsFor: 'testing' stamp: 'cwp 7/22/2009 07:10'! isOpen ^ (Primitives sizeOrNil: id) notNil! ! !FileHandle methodsFor: 'finalization' stamp: 'CamilloBruni 5/24/2012 15:07'! finalize self primCloseNoError: id.! ! !FileHandle methodsFor: 'public' stamp: 'CamilloBruni 5/24/2012 15:20'! at: index write: buffer startingAt: start count: count self flag: 'TODO: remove once FileHandles are really used!!'. self assureOpen. Primitives setPosition: id to: index - 1; write: id from: buffer startingAt: start count: count ! ! !FileHandle methodsFor: 'finalization' stamp: 'CamilloBruni 5/24/2012 15:05'! register "register the instance for proper clreanup on garbage collection" ^self class register: self! ! !FileHandle methodsFor: 'public' stamp: 'abc 5/11/2012 23:22'! readStream ^ (FileStream onHandle: self) ifNil: [ self streamError ] ! ! !FileHandle methodsFor: 'public' stamp: 'abc 5/11/2012 23:22'! streamError reference exists ifFalse: [FileDoesNotExist signalWith: reference]. self error: 'Unable to open file ' , reference printString! ! !FileHandle methodsFor: 'public' stamp: 'CamilloBruni 5/24/2012 15:20'! at: index read: buffer startingAt: start count: count self flag: 'TODO: remove once FileHandles are really used!!'. self assureOpen. ^ Primitives setPosition: id to: index - 1; read: id into: buffer startingAt: start count: count ! ! !FileHandle methodsFor: 'public' stamp: 'CamilloBruni 5/24/2012 15:19'! assureOpen "compatibility method to make the FileHandle Tests pass" self isOpen ifFalse: [ id := self basicOpen ].! ! !FileHandle methodsFor: 'private' stamp: 'cwp 11/20/2009 16:48'! startUp "This functionality is disabled for now, to avoid doing lots of processing on start up." "We're starting up in a new OS process, so the file id will be invalid. Try to reopen the file, but fail silently: just leave the id as nil. #isOpen will answer false, and we'll raise an error if anyone tries to do IO." self basicOpen! ! !FileHandle methodsFor: 'public' stamp: 'abc 5/11/2012 23:22'! writeStream ^( FileStream onHandle: self) ifNil: [ self streamError ]! ! !FileHandle methodsFor: 'public' stamp: 'CamilloBruni 5/24/2012 15:20'! flush self flag: 'TODO: remove once FileHandles are really used!!'. self assureOpen. Primitives flush: id! ! !FileHandle methodsFor: 'public' stamp: 'CamilloBruni 5/24/2012 15:18'! open self flag: 'TODO: for now we solely rely on the old FileStreams' "id := self basicOpen. id ifNil: [ reference exists ifFalse: [FileDoesNotExist signalWith: reference]. self error: 'Unable to open file ' , reference printString]"! ! !FileHandle methodsFor: 'public' stamp: 'cwp 7/22/2009 08:17'! truncateTo: anInteger Primitives truncate: id to: anInteger. self reopen! ! !FileHandle class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 5/24/2012 15:06'! registry ^Registry ifNil: [Registry := WeakRegistry new] ! ! !FileHandle class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 5/24/2012 15:06'! register: aFileHandle "properly register the given FileHandle for being closed on garbage collection" ^self registry add: aFileHandle! ! !FileHandle class methodsFor: 'class initialization' stamp: 'cwp 11/20/2009 16:16'! initialize self useFilePlugin. ! ! !FileHandle class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 4/2/2012 11:46'! useFilePlugin Primitives := FilePluginPrims new! ! !FileHandle class methodsFor: 'class initialization' stamp: 'cwp 11/20/2009 16:51'! startUp: resuming "This functionality is disabled for now, to avoid doing a lot of processing at image start up. To reenable, add this class to the start up list." resuming ifTrue: [self allInstancesDo: [:ea | ea startUp]]! ! !FileHandleTest commentStamp: 'TorstenBergmann 1/31/2014 11:49'! SUnit tests for file handles, the tests may be found in superclass! !FileHandleTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/3/2012 11:42'! createFileSystem ^ FileSystem store: DiskStore activeClass createDefault! ! !FileList commentStamp: 'StephaneDucasse 3/28/2010 20:44'! A FileList is a tool to deal with files. FileList open "open FileList"! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 2/14/2012 15:00'! fileListIndex "Answer the index of the currently selected file." ^ listIndex! ! !FileList methodsFor: 'drag''n''drop' stamp: 'MarcusDenker 10/15/2013 18:18'! acceptDroppingMorph: aTransferMorph event: evt inMorph: dest | oldEntry destDirectory newEntry response | destDirectory := self dropDestinationDirectory: dest event: evt. oldEntry := FileSystem disk referenceTo: aTransferMorph passenger. newEntry := destDirectory / oldEntry basename. oldEntry = newEntry ifTrue: [ "Transcript nextPutAll: 'same as old name'; cr." ^ true ]. newEntry ifNotNil: [ | msg | msg := String streamContents: [ :s | s nextPutAll: 'destination file '; nextPutAll: newEntry parent fullName; nextPutAll: ' exists already,'; cr; nextPutAll: 'and is '; nextPutAll: (oldEntry modificationTime < newEntry modificationTime ifTrue: [ 'newer' ] ifFalse: [ 'not newer' ]); nextPutAll: ' than source file '; nextPutAll: oldEntry parent fullName; nextPut: $.; cr; nextPutAll: 'Overwrite file '; nextPutAll: newEntry basename; nextPut: $? ]. response := self confirm: msg. response ifFalse: [ ^false ]. ]. aTransferMorph shouldCopy ifTrue: [ oldEntry copyAs: newEntry ] ifFalse: [ oldEntry renameTo: newEntry ]. self updateFileList; fileListIndex: 0. aTransferMorph source model ~= self ifTrue: [ aTransferMorph source model updateFileList; fileListIndex: 0 ]. "Transcript nextPutAll: 'copied'; cr." ^true! ! !FileList methodsFor: 'private' stamp: 'onierstrasz 11/11/2013 12:26'! okHit ok := true. self directory ifNil: [self inform: 'Missing directory'] ifNotNil: [modalView delete]! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 8/12/2011 20:10'! postOpen reference ifNotNil: [ self changed: #(openPath) , reference pathSegments. ]. ! ! !FileList methodsFor: 'private' stamp: 'NicolaiHess 12/1/2013 01:54'! filesMatching: aRegex "Answer a list of directory entries which match the patternString. The patternString may consist of multiple patterns separated by ';'. Each pattern can include a '*' or '#' as wildcards - see String>>match:" | files | files := [self directory files] on:DirectoryDoesNotExist do:[#()]. pattern ifNil: [ ^ files ]. ^ files select: [:entry | (aRegex search: entry basename)]! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 8/12/2011 20:25'! directoriesFor: directory "item may be file directory or server directory" | entries | entries := directory directories. dirSelectionBlock ifNotNil:[ entries := entries select: dirSelectionBlock ]. ^entries! ! !FileList methodsFor: 'private' stamp: 'PavelKrivanek 7/13/2012 14:07'! findFileListIndex: aMorphTreeSelectionChanged | node selectedPath | selectedPath := aMorphTreeSelectionChanged selection selectedNodePath. selectedPath ifNil: [^ self]. node := selectedPath first. self fileListIndex: (self fileList indexOf: node item). ! ! !FileList methodsFor: 'initialization' stamp: 'CamilloBruni 4/24/2013 19:27'! initialDirectoryList | dirList | dirList := self fileSystem root directories collect: [ :each | FileDirectoryWrapper with: each name: each basename model: self]. dirList isEmpty ifTrue:[ dirList := Array with: (FileDirectoryWrapper with: self fileSystem workingDirectory name: self fileSystem workingDirectory basename model: self)]. ^dirList! ! !FileList methodsFor: 'own services' stamp: 'sw 2/22/2002 02:35'! okayAndCancelServices "Answer ok and cancel services" ^ {self serviceOkay. self serviceCancel}! ! !FileList methodsFor: 'private' stamp: 'SeanDeNigris 7/7/2012 21:45'! resort: newMode "Re-sort the list of files." | item | listIndex > 0 ifTrue: [ item := (list at: listIndex) ]. sortMode := newMode. self updateFileList. item ifNotNil: [ reference := item. listIndex := list findFirst: [:i | i = item. ]. self changed: #fileListIndex]. listIndex = 0 ifTrue: [self changed: #contents]. self updateButtonRow ! ! !FileList methodsFor: 'initialization' stamp: 'CamilloBruni 8/12/2011 20:18'! labelString reference ifNil: [ ^ '[]' ]. ^ reference basename contractTo: 50! ! !FileList methodsFor: 'file menu action' stamp: 'hfm 11/29/2008 19:24'! getHex "Get contents of file again, and display in Hex. Do this by making the cancel string be the contents, and doing a cancel." Cursor read showWhile: [ brevityState := #needToGetBriefHex. self changed: #contents]. ! ! !FileList methodsFor: 'user interface' stamp: ''! morphicGrid grid := FileListGrid new parent: self. grid onSelectionChangeSend: #findFileListIndex: to: self ; menu: #fileListMenu shifted: false. ^ grid treeMorph ! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 21:59'! sortBlockTimestamp "Answer block to decide what order to display the directory entries." ^ [ :x :y | |xIsDir| ((xIsDir := x isDirectory) = y isDirectory) ifTrue: [ x modificationTime <= y modificationTime ] ifFalse: [ "directories always precede files" xIsDir ]]! ! !FileList methodsFor: 'initialization' stamp: 'MarcusDenker 8/15/2010 15:05'! initialize super initialize. ok := false. dirSelectionBlock := [ :dirName | true].! ! !FileList methodsFor: 'initialization' stamp: 'SeanDeNigris 7/12/2012 08:44'! setFileStream: aStream "Used to initialize a spawned file editor. Sets directory too." self directory: aStream name asFileReference. pattern := nil. aStream close. brevityState := #needToGetBrief. self changed: #fileList. self changed: #contents. self changed: #selectedDirectory. ! ! !FileList methodsFor: 'user interface' stamp: 'AlainPlantec 8/28/2011 13:51'! morphicFileContentsPane ^(PluggableTextMorph on: self text: #contents accept: #put: readSelection: nil menu: #fileContentsMenu:shifted:) ! ! !FileList methodsFor: 'initialization' stamp: 'NicolaiHess 2/7/2014 23:51'! folderSelectButtonRow "Answer the button row used for folder selection" | aRow | aRow := AlignmentMorph newRow beSticky. aRow color: Color transparent. aRow clipSubmorphs: true. aRow layoutInset: 0@0; cellInset: 6. aRow setNameTo: 'buttons'. ^ aRow! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:17'! serviceViewContentsInWorkspace "Answer a service for viewing the contents of a file in a workspace" ^ (SimpleServiceEntry provider: self label: 'Workspace with contents' selector: #viewContentsInWorkspace) description: 'Open a new Workspace whose contents are set to the contents of this file'! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 2/14/2012 14:54'! defaultContents contents := list isNil ifTrue: [String new] ifFalse: [ String streamContents: [:s | s << 'NO FILE SELECTED' translated; cr. s << ' -- Folder Summary --' translated; cr. list do: [:item | s << item basename; cr]]]. brevityState := #FileList. ^ contents! ! !FileList methodsFor: 'volume list and pattern' stamp: 'MarcusDenker 2/11/2012 13:57'! volumeList "Answer the current list of volumes." ^ volumeList ! ! !FileList methodsFor: 'private' stamp: 'NicolaiHess 2/8/2014 00:10'! getSelectedFolder "Answer the selected folder or nil if dialog was canceled" ok ifFalse: [ ^ nil ]. ^ self directory! ! !FileList methodsFor: '*Shout-Styling' stamp: 'AlainPlantec 8/27/2011 00:26'! shoutAboutToStyle: aPluggableShoutMorphOrView ^ false! ! !FileList methodsFor: 'private' stamp: 'NicolaiHess 2/8/2014 01:02'! updateFileList "Update my files list with file names in the current directory that match the pattern. The pattern string may have embedded newlines or semicolons; these separate different patterns." list := grid ifNil:[#()] ifNotNil:[self listForPattern: pattern]. listIndex := self getListIndex. volumeListIndex := volumeList size. contents := ''. self changed: #volumeListIndex. self changed: #fileList. self grid updateList. self updateButtonRow! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:59'! serviceAddNewFile "Answer a service entry characterizing the 'add new file' command" ^(SimpleServiceEntry provider: self label: 'Add new file' selector: #addNewFile description: 'Create a new,. empty file, and add it to the current directory.') usingLineAfter: false! ! !FileList methodsFor: 'own services' stamp: 'sw 2/22/2002 02:36'! servicesForFolderSelector "Answer the ok and cancel servies for the folder selector" ^ self okayAndCancelServices! ! !FileList methodsFor: 'own services' stamp: 'CarloTeixeira 7/3/2010 22:25'! deleteDirectory self basicDeleteDirectory. self updateFileList. self updateDirectory. ! ! !FileList methodsFor: 'own services' stamp: 'CamilloBruni 7/10/2012 22:34'! openImageInWindow "Handle five file formats: GIF, JPG, PNG, Form stoteOn: (run coded), and BMP. Fail if file format is not recognized." | image | self reference streamWritable: false do: [ :stream| image := Form fromBinaryStream: stream]. (World drawingClass withForm: image) openInWorld! ! !FileList methodsFor: 'private' stamp: 'AlexisParseghian 3/25/2012 20:24'! selectEncoding "self new selectEncoding" | aMenu | aMenu := UIManager default newMenuIn: self for: self. TextConverter allSubclasses do: [:each | | names | names := each encodingNames. names notEmpty ifTrue: [ | label | label := '' writeStream. names do: [ :eachName | label nextPutAll: eachName ] separatedBy: [ label nextPutAll: ', ']. aMenu "add: label contents action: names first asSymbol" add: label contents target: self selector: #fileEncoding: argument: names first asSymbol ]]. aMenu popUpInWorld! ! !FileList methodsFor: 'volume list and pattern' stamp: 'HilaireFernandes 1/2/2014 23:57'! volumeListIndex: index "Select the volume name having the given index." | delim path | volumeListIndex := index. index = 1 ifTrue: [self directory: FileSystem disk root ] ifFalse: [ delim := reference fileSystem delimiter. path := String streamContents: [:stream | 2 to: index do: [:i | stream nextPutAll: (volumeList at: i) trimBoth. i < index ifTrue: [stream nextPut: delim]]]]. brevityState := #FileList. self addPath: path. self changed: #fileList. self changed: #contents. self updateButtonRow! ! !FileList methodsFor: 'file menu action' stamp: 'MarcusDenker 8/15/2010 15:06'! get "Get contents of file again, it may have changed. Do this by making the cancel string be the contents, and doing a cancel." Cursor read showWhile: [ self okToChange ifFalse: [ ^ nil ]. brevityState := brevityState == #briefHex ifTrue: [ #needToGetFullHex ] ifFalse: [ #needToGetFull ]. self changed: #contents ]! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 2/16/2012 12:13'! reference ^ reference! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 2/16/2012 12:14'! directory: dir ^ self reference: dir! ! !FileList methodsFor: 'own services' stamp: 'HilaireFernandes 1/2/2014 23:58'! basicDeleteDirectory "Remove the currently selected directory" reference entries isEmpty ifFalse:[^self inform:'Directory must be empty']. (self confirm: 'Really delete ' , reference basename , '?') ifFalse: [^ self]. self volumeListIndex: self volumeListIndex-1. reference delete. self directory: reference parent! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:14'! serviceGetHex ^ (SimpleServiceEntry provider: self label: 'View as hex' selector: #getHex description: 'View as hex') ! ! !FileList methodsFor: 'own services' stamp: 'GabrielOmarCotelli 11/30/2013 16:15'! servicesFromSelectorSpecs: symbolArray "Answer an array of services represented by the incoming symbols, eliminating any that do not have a currently-registered service. Pass the symbol #- along unchanged to serve as a separator between services" "FileList new servicesFromSelectorSpecs: #(fileIn: fileIntoNewChangeSet: browseChangesFile:)" | registeredServices services | services := OrderedCollection new. registeredServices := self class allRegisteredServices. symbolArray do: [ :sel | sel == #- ifTrue: [ services add: sel ] ifFalse: [ registeredServices detect: [ :each | each selector = sel ] ifFound: [ :service | services add: service ] ] ]. ^ services! ! !FileList methodsFor: 'accessing' stamp: 'hfm 11/29/2008 18:30'! fileList "Answer the list of files in the current volume." ^ list! ! !FileList methodsFor: 'file menu action' stamp: 'S 6/17/2013 13:24'! addNewFile self addNew: 'File' byEvaluating: [:newName | (self directory / newName) ensureCreateFile ] ! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 22:53'! readContentsBrief: brevityFlag "Read the contents of the receiver's selected file, unless it is too long, in which case show just the first 5000 characters. Don't create a file if it doesn't already exist." | fileSize first5000 | self reference streamWritable: false do: [:f| (brevityFlag not or: [(fileSize := f size) <= 100000]) ifTrue:[ contents := [ f contents asString ] on: Error do: [ :ex | ^ f binary contents asString ]. brevityState := #fullFile. "don't change till actually read" ^ contents]. "if brevityFlag is true, don't display long files when first selected" [ first5000 := f next: 5000 ] on: Error do: [ :ex | first5000 := (f binary next: 5000) asString ]]. contents := '{1} ------------------------------------------ ... end of the first 5000 characters.' translated format: {first5000}. brevityState := #briefFile. "don't change till actually read" ^ contents. ! ! !FileList methodsFor: 'private' stamp: 'GabrielOmarCotelli 11/30/2013 16:11'! addPath: aString "Add the given string to the list of recently visited directories." | full | aString ifNil: [^self]. full := String streamContents: [ :strm | 2 to: volumeList size do: [ :i | strm nextPutAll: (volumeList at: i) trimBoth. strm nextPut: FileSystem disk separator]]. full := full, aString. "Remove and super-directories of aString from the collection." RecentDirs removeAllSuchThat: [ :aDir | ((aDir, '*') match: full)]. "If a sub-directory is in the list, do nothing." RecentDirs detect: [ :aDir | ((full, '*') match: aDir)] ifFound: [^self]. [RecentDirs size >= 10] whileTrue: [RecentDirs removeFirst]. RecentDirs addLast: full! ! !FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 22:00'! isDirectoryList: aMorph ^aMorph isKindOf: SimpleHierarchicalListMorph! ! !FileList methodsFor: 'volume list and pattern' stamp: 'EstebanLorenzano 4/2/2012 11:43'! veryDeepFixupWith: deepCopier super veryDeepFixupWith: deepCopier. volumeListIndex := 1. self directory: FileSystem disk workingDirectory. self updateFileList! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 8/14/2011 15:50'! setSelectedDirectoryTo: aFileDirectoryWrapper self directory: aFileDirectoryWrapper withoutListWrapper. brevityState := #FileList. "self addPath: path." self changed: #fileList. self changed: #contents. self changed: #selectedDirectory.! ! !FileList methodsFor: 'private' stamp: 'EstebanLorenzano 4/2/2012 11:43'! recentDirs "Put up a menu and let the user select from the list of recently visited directories." | dirName | RecentDirs isEmpty ifTrue: [ ^ self ]. dirName := UIManager default chooseFrom: RecentDirs values: RecentDirs. dirName ifNil: [ ^ self ]. self directory: (FileSystem disk root resolve: dirName)! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 8/12/2011 20:09'! isFileSelected "return if a file is currently selected" ^ reference notNil and: [ reference isFile ].! ! !FileList methodsFor: 'user interface' stamp: 'CamilloBruni 2/16/2012 11:15'! optionalButtonSpecs: aSpecArray optionalButtonSpecs := aSpecArray! ! !FileList methodsFor: 'volume list and pattern' stamp: 'CamilloBruni 8/12/2011 21:40'! volumeListIndex "Answer the index of the currently selected volume." ^ volumeListIndex ! ! !FileList methodsFor: 'drag''n''drop' stamp: 'CamilloBruni 8/12/2011 22:03'! dragPassengerFor: item inMorph: dragSource ^ item contents copy ! ! !FileList methodsFor: 'file list menu' stamp: 'CamilloBruni 8/12/2011 21:27'! itemsForNoFile | services | services := OrderedCollection new. services addAll: (self itemsForDirectory: (self isFileSelected ifFalse: [ self directory ] ifTrue: [])). ^ services ! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:14'! serviceDeleteFile ^ (SimpleServiceEntry provider: self label: 'Delete' selector: #deleteFile) description: 'Delete the seleted item'! ! !FileList methodsFor: 'own services' stamp: 'CamilloBruni 7/10/2012 22:34'! viewContentsInWorkspace "View the contents of my selected file in a new workspace" | aString | self reference streamWritable: false do: [ :stream| aString := stream setConverterForCode contentsOfEntireFile ]. UIManager default edit: aString label: 'Workspace from ', self reference basename! ! !FileList methodsFor: 'accessing' stamp: 'MarcusDenker 12/2/2013 14:14'! reference: dir | tmpReference | "Set the path of the volume to be displayed." self okToChange ifFalse: [^ self]. tmpReference := dir ifNotNil: [ :d| d asFileReference] ifNil: [ FileSystem disk workingDirectory ]. tmpReference isReadable ifFalse: [ ^ self inform: ('Cannot read {1}' translated format: { tmpReference})]. reference := tmpReference. sortMode ifNil: [sortMode := #date]. volumeList := ((Array with: '[]'), reference pathSegments) withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each]. volumeListIndex := volumeList size. self changed: #relabel. self changed: #volumeList. self updateFileList.! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:14'! serviceOkay "Answer a service for hitting the okay button" ^ (SimpleServiceEntry new provider: self label: 'Okay' selector: #okHit description: 'Hit here to accept the current selection') buttonLabel: 'Ok'! ! !FileList methodsFor: 'private' stamp: 'hfm 11/29/2008 18:38'! registeredFileReaderClasses "return the list of classes that provide file reader services" ^ self class registeredFileReaderClasses! ! !FileList methodsFor: 'file menu action' stamp: 'hfm 11/29/2008 19:24'! getEncodedText Cursor read showWhile: [ self selectEncoding. self changed: #contents]. ! ! !FileList methodsFor: 'user interface' stamp: 'RAA 2/17/2001 12:18'! morphicDirectoryTreePane ^self morphicDirectoryTreePaneFiltered: #initialDirectoryList ! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 2/16/2012 12:26'! getSelectedFile "Answer a filestream on the selected file. If it cannot be opened for read/write, try read-only before giving up; answer nil if unsuccessful" ok ifFalse: [ ^ nil ]. reference ifNil: [ ^ nil ]. reference isFile ifFalse: [ ^ nil ]. ^ reference readStream.! ! !FileList methodsFor: 'file list' stamp: 'CamilloBruni 2/16/2012 12:29'! readOnlyStream "Answer a read-only stream on the selected file. For the various stream-reading services." ^ MultiByteFileStream readOnlyFileNamed: self reference fullName! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 8/12/2011 21:18'! pattern ^ pattern ! ! !FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 18:42'! itemsForAnyFile "Answer a list of universal services that could apply to any file" | services | services := OrderedCollection new: 4. services add: self serviceCopyName. services add: self serviceRenameFile. services add: self serviceDeleteFile. services add: self serviceViewContentsInWorkspace. ^ services! ! !FileList methodsFor: 'initialization' stamp: 'CamilloBruni 8/14/2011 15:50'! updateDirectory "directory has been changed externally, by calling directory:. Now change the view to reflect the change." self changed: #selectedDirectory. self postOpen.! ! !FileList methodsFor: 'volume list and pattern' stamp: 'CamilloBruni 8/12/2011 21:14'! listForPattern: aPattern "Make the list be those file names which match the pattern." | newList | newList := self filesMatching: aPattern. newList := newList asArray sort: self sortBlock. ^ newList ! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:13'! serviceCompressFile "Answer a service for compressing a file" ^ SimpleServiceEntry provider: self label: 'Compress' selector: #compressFile description: 'Compress file' buttonLabel: 'Compress'! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 2/14/2012 15:02'! getListIndex ^ list indexOf: reference ifAbsent: [ 0 ]! ! !FileList methodsFor: 'private' stamp: ''! sortBlockBasename "Answer block to decide what order to display the directory entries." ^ [ :x :y | |xIsDir| ((xIsDir := x isDirectory) = y isDirectory) ifTrue: [ x basename <= y basename ] ifFalse: [ "directories always precede files" xIsDir ]]! ! !FileList methodsFor: 'user interface' stamp: 'CamilloBruni 2/16/2012 11:15'! optionalButtonSpecs ^ optionalButtonSpecs! ! !FileList methodsFor: 'initialization' stamp: 'CamilloBruni 8/12/2011 21:56'! optionalButtonRow "Answer the button row associated with a file list" | aRow | aRow := AlignmentMorph newRow beSticky. aRow color: Color transparent. aRow clipSubmorphs: true. aRow layoutInset: 0@0; cellInset: 6. aRow setNameTo: 'buttons'. aRow setProperty: #buttonRow toValue: true. "Used for dynamic retrieval later on" ^ aRow! ! !FileList methodsFor: 'user interface' stamp: 'CamilloBruni 8/14/2011 15:19'! morphicPatternPane "Remove the vertical scrollbar since the minHeight would otherwise be too large to fit the layout frame. Added here for Pharo since FileList2 has been merged into FileList." ^ SearchMorph new model: self; setIndexSelector: #pattern:; searchList: self class searchList; vResizing: #spaceFill; hResizing: #spaceFill; yourself! ! !FileList methodsFor: 'initialization' stamp: 'tbn 6/29/2012 10:58'! dynamicButtonServices "Answer services for buttons that may come and go in the button pane, depending on selection" ^ reference isDirectory ifTrue: [#()] ifFalse: [ | toReject | toReject := self buttonSelectorsToSuppress. (self itemsForFile: reference) reject: [:svc | toReject includes: svc selector]]! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:13'! serviceCancel "Answer a service for hitting the cancel button" ^ (SimpleServiceEntry new provider: self label: 'Cancel' selector: #cancelHit description: 'Hit here to cancel ') buttonLabel: 'Cancel'! ! !FileList methodsFor: 'drag''n''drop' stamp: 'hfm 11/29/2008 19:21'! dragTransferTypeForMorph: aMorph ^#file! ! !FileList methodsFor: 'file menu action' stamp: 'tbn 4/23/2012 16:24'! renameFile "Rename the currently selected file" | newName response | listIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (response := UIManager default request: 'NewFileName?' translated initialAnswer: reference basename) isEmptyOrNil ifTrue: [^ self]. newName := response asFileName. newName = reference basename ifTrue: [^ self]. reference renameTo: newName. self updateFileList. listIndex := list findFirst: [:item | item = newName]. listIndex > 0 ifTrue: [reference := newName]. self changed: #fileListIndex. ! ! !FileList methodsFor: 'private' stamp: 'AlexisParseghian 3/25/2012 23:26'! fileEncoding: aByteSymbol fileEncoding := aByteSymbol. brevityState := #needToGetBrief. self changed: #contents! ! !FileList methodsFor: 'user interface' stamp: 'CamilloBruni 2/16/2012 15:00'! wrapFile: aFile ^ aFile basename! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:14'! serviceGetEncodedText ^ (SimpleServiceEntry provider: self label: 'View as encoded text' selector: #getEncodedText description: 'View as encoded text') ! ! !FileList methodsFor: 'private' stamp: 'AlexisParseghian 3/26/2012 00:19'! sortBlock: aBlockClosure sortBlock := aBlockClosure. self updateFileList! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 2/16/2012 19:07'! fullName "Answer the full name for the currently selected file; answer nil if no file is selected." ^ reference fullName! ! !FileList methodsFor: 'file list menu' stamp: 'CamilloBruni 8/12/2011 20:03'! fileListMenu: aMenu reference ifNil: [^ self noFileSelectedMenu: aMenu] ifNotNil: [^ self fileSelectedMenu: aMenu]. ! ! !FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 19:33'! suffixOfSelectedFile "Answer the file extension of the receiver's selected file" ^ self class suffixOf: self fullName.! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 2/14/2012 14:37'! directory ^ reference isFile ifTrue: [ reference parent ] ifFalse: [ reference ]! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 4/24/2013 19:27'! fileSystem ^ reference ifNil: [ FileSystem disk ] ifNotNil: [ reference fileSystem ]! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 22:00'! sortBlockPermissions "Answer block to decide what order to display the directory entries." ^ [ :x :y | |xIsDir| ((xIsDir := x isDirectory) = y isDirectory) ifTrue: [ x permissions <= y permissions ] ifFalse: [ "directories always precede files" xIsDir ]]! ! !FileList methodsFor: 'file menu action' stamp: 'CamilloBruni 7/10/2012 22:50'! deleteFile "Delete the currently selected file" listIndex = 0 ifTrue: [^ self]. (self confirm: ('Really delete {1}?' translated format: { reference basename } )) ifFalse: [^ self]. reference delete. reference := reference parent. self updateFileList. brevityState := #FileList. self get! ! !FileList methodsFor: 'own services' stamp: 'S 6/17/2013 13:26'! addNewDirectory self addNew: 'Directory' byEvaluating: [:newName | (self directory / newName ) ensureCreateDirectory ] ! ! !FileList methodsFor: 'private' stamp: 'AlexisParseghian 3/26/2012 00:15'! sortBlock "Answer block to decide what order to display the directory entries." ^ sortBlock ifNil: [ sortBlock := self sortBlockBasename ]! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:15'! serviceRenameFile ^ (SimpleServiceEntry provider: self label: 'Rename' selector: #renameFile description: 'Rename file')! ! !FileList methodsFor: 'user interface' stamp: 'AlexisParseghian 3/15/2012 23:57'! grid ^ grid ifNil: [ grid := self morphicGrid ]! ! !FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 13:07'! dropDestinationDirectory: dest event: evt "Answer a FileDirectory representing the drop destination in the directory hierarchy morph dest" ^ (dest itemFromPoint: evt position) withoutListWrapper! ! !FileList methodsFor: 'menu messages' stamp: 'hfm 11/29/2008 19:22'! copyName listIndex = 0 ifTrue: [^ self]. Clipboard clipboardText: self fullName asText. ! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:14'! serviceGet "Answer a service for getting the entire file" ^ (SimpleServiceEntry provider: self label: 'Get entire file' selector: #get description: 'If the file has only been partially read in, because it is very large, read the entire file in at this time.')! ! !FileList methodsFor: 'drag''n''drop' stamp: 'BenjaminVanRyseghem 11/5/2013 11:23'! wantsDroppedMorph: aTransferMorph event: evt inMorph: dest | retval | retval := (aTransferMorph isTransferable) and: [ (aTransferMorph dragTransferType == #file) and: [ self isDirectoryList: dest ]]. ^retval! ! !FileList methodsFor: 'volume list and pattern' stamp: 'CamilloBruni 1/17/2012 16:20'! changeDirectoryTo: aFileDirectory "Change directory as requested." self directory: aFileDirectory. self updateDirectory! ! !FileList methodsFor: 'menu messages' stamp: 'CamilloBruni 8/12/2011 21:37'! perform: selector orSendTo: otherTarget "Selector was just chosen from a menu by a user. If it's one of the three sort-by items, handle it specially. If I can respond myself, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." ^ (#(get getHex copyName openImageInWindow renameFile deleteFile deleteDirectory addNewFile recentDirs ) includes: selector) ifTrue: [self perform: selector] ifFalse: [super perform: selector orSendTo: otherTarget]! ! !FileList methodsFor: 'file menu action' stamp: 'NicolaiHess 2/8/2014 00:27'! addNew: aString byEvaluating: aBlock "A parameterization of earlier versions of #addNewDirectory and #addNewFile. Fixes the bug in each that pushing the cancel button in the FillInTheBlank dialog gave a walkback." | response newName index | self okToChange ifFalse: [^ self]. (response := UIManager default request: ('New {1} Name?' translated format: {aString translated}) initialAnswer: ('{1}Name' translated format: {aString translated})) isEmptyOrNil ifTrue: [^ self]. newName := response asFileName. Cursor wait showWhile: [ aBlock value: newName]. self updateFileList. self updateDirectory. list ifNotNil:[ index := list indexOf: newName. index = 0 ifTrue: [ index := list findFirst: [:line | line basename endsWith: newName]]. self fileListIndex: index.] ! ! !FileList methodsFor: 'volume menu' stamp: 'CamilloBruni 8/12/2011 21:36'! volumeMenu: aMenu aMenu addList: { {'Recent...' translated. #recentDirs}. #-. {'Delete directory...' translated. #deleteDirectory}. #-}. aMenu addServices: (self itemsForDirectory: self directory) for: self extraLines: #(). ^aMenu.! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 2/14/2012 14:56'! selectedDirectory: aFileDirectoryWrapper | file | file := aFileDirectoryWrapper withoutListWrapper. file ifNil: [ brevityState := #FileList. self changed: #fileList. self changed: #selectedDirectory. ^ self ]. self directory: file. brevityState := #FileList. "self addPath: path." self changed: #fileList. self changed: #contents. self changed: #selectedDirectory.! ! !FileList methodsFor: 'file list menu' stamp: 'EstebanLorenzano 2/1/2013 11:24'! fileContentsMenu: aMenu shifted: shifted "Construct aMenu to have items appropriate for the file browser's code pane, given the shift state provided" | shiftMenu services maybeLine extraLines | shifted ifTrue: [shiftMenu := SmalltalkEditor shiftedYellowButtonMenu. ^ aMenu addAllFrom: shiftMenu]. reference ifNotNil: [services := OrderedCollection new. (#(briefHex briefFile needToGetBriefHex needToGetBrief) includes: brevityState) ifTrue: [services add: self serviceGet]. (#(fullHex briefHex needToGetFullHex needToGetBriefHex) includes: brevityState) ifFalse: [services add: self serviceGetHex]. (#(needToGetShiftJIS needToGetEUCJP needToGetCNGB needToGetEUCKR needToGetUTF8) includes: brevityState) ifFalse: [services add: self serviceGetEncodedText]. maybeLine := services size. (FileStream sourceFileSuffixes includes: self suffixOfSelectedFile) ifTrue: [services addAll: (self servicesFromSelectorSpecs: #(fileIntoNewChangeSet: fileIn: browseChangesFile: browseFile:))]. extraLines := OrderedCollection new. maybeLine > 0 ifTrue: [extraLines add: maybeLine]. services size > maybeLine ifTrue: [extraLines add: services size]. aMenu addServices: services for: self reference extraLines: extraLines]. aMenu addAllFromPragma: 'fileListContentMenu' target: self. ^ aMenu ! ! !FileList methodsFor: 'file list menu' stamp: 'CamilloBruni 8/12/2011 20:51'! itemsForFile: file "Answer a list of services appropriate for a file" ^ (self class itemsForFile: file).! ! !FileList methodsFor: 'accessing' stamp: 'nice 5/13/2012 17:43'! pattern: aStringOrNil pattern := aStringOrNil ifNotNil: [:aString | aString asString trimBoth ifEmpty: [nil] ifNotEmpty: [:trimmed | trimmed asRegex]]. self updateFileList. ! ! !FileList methodsFor: 'file menu action' stamp: 'CamilloBruni 2/16/2012 12:17'! compressFile "Compress the currently selected file" | f | f := StandardFileStream readOnlyFileNamed: self reference fullName. f compressFile. self updateFileList! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:13'! serviceCopyName ^ (SimpleServiceEntry provider: self label: 'Copy name to clipboard' selector: #copyName description: 'Copy name to clipboard' )! ! !FileList methodsFor: 'updating' stamp: 'hfm 11/29/2008 19:33'! update: aParameter "Receive a change notice from an object of whom the receiver is a dependent" (aParameter == #fileListChanged) ifTrue: [self updateFileList]. super update: aParameter! ! !FileList methodsFor: 'file list menu' stamp: 'MarcusDenker 3/3/2012 16:22'! fileSelectedMenu: aMenu | n1 n2 n3 services | services := OrderedCollection withAll: (self itemsForFile: reference). n1 := services size. services addAll: self itemsForAnyFile. n2 := services size. services addAll: self itemsForNoFile. n3 := services size. services := services collect: [ :svc | svc copy.]. services do: [ :svc | svc addDependent: self; doNotUseLineAfter ]. ^ aMenu addServices: services for: self extraLines: (Array with: n1 with: n2 with: n3) ! ! !FileList methodsFor: 'private' stamp: 'NicolaiHess 2/11/2014 23:51'! put: aText "Private - put the supplied text onto the file" | ff type | brevityState == #fullFile ifTrue:[ ff := StandardFileStream newFileNamed:reference fullName. Cursor write showWhile: [ff nextPutAll: aText asString; close]. reference basename = ff localName ifTrue: [contents := aText asString] ifFalse: [ self updateFileList. "user renamed the file" ]. ^ true "accepted"]. listIndex = 0 ifTrue: [ self inform: 'No fileName is selected' translated. ^ false "failed" ]. type := 'These'. brevityState = #briefFile ifTrue: [type := 'Abbreviated']. brevityState = #briefHex ifTrue: [type := 'Abbreviated']. brevityState = #fullHex ifTrue: [type := 'Hexadecimal']. brevityState = #FileList ifTrue: [type := 'Directory']. self inform: ('{1} contents cannot meaningfully be saved at present.' translated format:{type translated}). ^ false "failed"! ! !FileList methodsFor: 'file list menu' stamp: 'hfm 11/29/2008 19:26'! noFileSelectedMenu: aMenu ^ aMenu addServices: self itemsForNoFile for: self extraLines: #() ! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 8/14/2011 15:33'! cancelHit modalView delete.! ! !FileList methodsFor: 'file list menu' stamp: 'StephaneDucasse 3/5/2010 14:42'! itemsForDirectory: dir | services | services := OrderedCollection new. dir ifNotNil: [ services addAll: (self class itemsForDirectory: dir). services last useLineAfter. ]. services add: self serviceAddNewFile. services add: self serviceAddNewDirectory. ^ services! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 8/14/2011 15:35'! directoriesMatching: aRegex "Answer a list of directory entries which match the patternString. The patternString may consist of multiple patterns separated by ';'. Each pattern can include a '*' or '#' as wildcards - see String>>match:" | directories | directories := reference directories. pattern ifNil: [ ^ directories ]. ^ directories reject: [:entry | (aRegex matchingRangesIn: entry basename) isEmpty ]! ! !FileList methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 11/30/2013 16:17'! updateButtonRow "Dynamically update the contents of the button row, if any." self dependents detect: [ :m | m isSystemWindow and: [ m model == self ] ] ifFound: [ :aWindow | | aRow | aRow := aWindow findDeepSubmorphThat: [ :m | m hasProperty: #buttonRow ] ifAbsent: [ ^ self ]. aRow submorphs size - 1 timesRepeat: [ aRow submorphs last delete ]. self dynamicButtonServices do: [ :service | aRow addMorphBack: (service buttonToTriggerIn: self). service addDependent: self ] ]! ! !FileList methodsFor: 'user interface' stamp: 'AlexisParseghian 3/26/2012 00:18'! setSortSelector: aByteSymbol self sortBlock: (self perform: aByteSymbol).! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 21:59'! sortBlockFilesize "Answer block to decide what order to display the directory entries." ^ [ :x :y | |xIsDir| ((xIsDir := x isDirectory) = y isDirectory) ifTrue: [ x size <= y size ] ifFalse: [ "directories always precede files" xIsDir ]]! ! !FileList methodsFor: 'own services' stamp: 'tbn 8/11/2010 10:12'! serviceAddNewDirectory "Answer a service entry characterizing the 'add new directory' command" ^ SimpleServiceEntry provider: self label: 'Add new directory' selector: #addNewDirectory description: 'Adds a new, empty directory (folder)' ! ! !FileList methodsFor: 'initialization' stamp: 'MarcusDenker 5/25/2011 12:21'! buttonSelectorsToSuppress "Answer a list of action selectors whose corresponding services we would prefer *not* to have appear in the filelist's button pane; this can be hand-jimmied to suit personal taste." ^ #(removeLineFeeds: addFileToNewZip: compressFile:)! ! !FileList methodsFor: 'user interface' stamp: 'AlexisParseghian 3/15/2012 23:38'! morphicFileListPane ^ grid ifNil: [ grid := self morphicGrid ]. ! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 22:44'! readContentsHex: brevity "retrieve the contents from the external file unless it is too long. Don't create a file here. Check if exists." | size data hexData s | self reference streamWritable: false do: [ :f| f isNil ifTrue: [^ 'For some reason, this file cannot be read' translated]. f binary. ((size := f size)) > 5000 & brevity ifTrue: [data := f next: 10000. f close. brevityState := #briefHex] ifFalse: [data := f contentsOfEntireFile. brevityState := #fullHex]. s := (String new: data size*4) writeStream. 0 to: data size-1 by: 16 do: [:loc | s nextPutAll: loc printStringHex; space; nextPut: $(; print: loc; nextPut: $); space; tab. loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) printStringHex; space]. s cr]. hexData := s contents]. ^ contents := ((size > 5000) & brevity ifTrue: ['{3} ------------------------------------------ ... end of the first 5000 characters.' translated format: {hexData}] ifFalse: [hexData]). ! ! !FileList methodsFor: 'accessing' stamp: 'MarcusDenker 10/15/2013 18:16'! fileListIndex: anInteger "Select the file name having the given index, and display its contents." | item | self okToChange ifFalse: [^ self]. listIndex := anInteger. listIndex = 0 ifFalse: [ item := (list at: anInteger). item isDirectory ifTrue: [ listIndex := 0. brevityState := #FileList. self addPath: item fullName. self directory: item ] ifFalse: [reference := item]]. "open the file selected" brevityState := #needToGetBrief. self changed: #fileListIndex. self changed: #contents. self updateButtonRow! ! !FileList methodsFor: 'private' stamp: 'RAA 6/21/2000 12:06'! modalView: aSystemWindowOrSuch modalView := aSystemWindowOrSuch! ! !FileList methodsFor: 'initialization' stamp: 'sw 2/22/2002 02:34'! universalButtonServices "Answer the services to be reflected in the receiver's buttons" ^ self optionalButtonSpecs! ! !FileList methodsFor: 'user interface' stamp: 'CamilloBruni 8/14/2011 15:48'! morphicDirectoryTreePaneFiltered: aSymbol ^(SimpleHierarchicalListMorph on: self list: aSymbol selected: #selectedDirectory changeSelected: #selectedDirectory: menu: #volumeMenu: keystroke: nil) autoDeselect: false; enableDrag: false; enableDrop: true; yourself ! ! !FileList methodsFor: 'private' stamp: 'MarcusDenker 9/13/2013 14:04'! contents "Answer the contents of the file, reading it first if needed." "Possible brevityState values: FileList, fullFile, briefFile, needToGetFull, needToGetBrief, fullHex, briefHex, needToGetFullHex, needToGetBriefHex" self reference isReadable ifFalse: [ ^ 'cannot read {1}' translated format: { reference }]. (listIndex = 0) | (brevityState == #FileList) ifTrue: [^ self defaultContents]. "no file selected" brevityState == #fullFile ifTrue: [^ contents]. brevityState == #fullHex ifTrue: [^ contents]. brevityState == #briefFile ifTrue: [^ contents]. brevityState == #briefHex ifTrue: [^ contents]. brevityState == #needToGetFullHex ifTrue: [^ self readContentsHex: false]. brevityState == #needToGetBriefHex ifTrue: [^ self readContentsHex: true]. brevityState == #needToGetFull ifTrue: [^ self readContentsBrief: false]. brevityState == #needToGetBrief ifTrue: [^ self readContentsBrief: true]. "default" (TextConverter allEncodingNames includes: brevityState) ifTrue: [ ^self readContentsAsEncoding: brevityState]. self error: 'unknown state ' , brevityState printString! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 8/14/2011 15:48'! selectedDirectory ^ self directory! ! !FileList class methodsFor: 'menu' stamp: 'EstebanLorenzano 5/14/2013 09:44'! contentMenu: aBuilder (aBuilder item: #'Find...' translated) keyText: 'f'; selector: #find; icon: Smalltalk ui icons smallFindIcon. (aBuilder item: #'Find again' translated) keyText: 'g'; selector: #findAgain; icon: Smalltalk ui icons smallFindIcon. (aBuilder item: #'Set search string' translated) keyText: 'h'; selector: #setSearchString; withSeparatorAfter. (aBuilder item: #'Do again' translated) keyText: 'j'; selector: #again; icon: Smalltalk ui icons smallRedoIcon. (aBuilder item: #'Undo' translated) keyText: 'z'; selector: #undo; icon: Smalltalk ui icons smallUndoIcon; withSeparatorAfter. (aBuilder item: #'Copy' translated) keyText: 'c'; selector: #copySelection; icon: Smalltalk ui icons smallCopyIcon. (aBuilder item: #'Cut' translated) keyText: 'x'; selector: #cut; icon: Smalltalk ui icons smallCutIcon. (aBuilder item: #'Paste' translated) keyText: 'v'; selector: #paste; icon: Smalltalk ui icons smallPasteIcon. (aBuilder item: #'Paste...' translated) selector: #pasteRecent; icon: Smalltalk ui icons smallPasteIcon; withSeparatorAfter . (aBuilder item: #'Do it' translated) keyText: 'd'; selector: #doIt; icon: Smalltalk ui icons smallDoItIcon. (aBuilder item: #'Print it' translated) keyText: 'p'; selector: #printIt; icon: Smalltalk ui icons smallPrintItIcon. (aBuilder item: #'Inspect it' translated) keyText: 'i'; selector: #inspectIt; icon: Smalltalk ui icons smallInspectItIcon. (aBuilder item: #'FileIn selection' translated) keyText: 'G'; selector: #fileItIn; withSeparatorAfter. (aBuilder item: #'Accept' translated) keyText: 's'; selector: #accept; icon: Smalltalk ui icons smallOkIcon. (aBuilder item: #'Cancel' translated) keyText: 'l'; selector: #cancel; icon: Smalltalk ui icons smallCancelIcon; withSeparatorAfter. (aBuilder item: #'More...' translated) selector: #shiftedYellowButtonActivity. ! ! !FileList class methodsFor: 'initialization' stamp: 'hfm 11/29/2008 19:38'! removeObsolete "FileList removeObsolete" self registeredFileReaderClasses copy do:[:cls| cls isObsolete ifTrue:[self unregisterFileReader: cls]]! ! !FileList class methodsFor: 'modal dialogs' stamp: 'EstebanLorenzano 4/2/2012 11:43'! modalFolderSelector ^self modalFolderSelector: FileSystem disk root! ! !FileList class methodsFor: 'modal dialogs' stamp: 'CamilloBruni 8/12/2011 21:44'! modalFileSelectorForSuffixes: aList | window aFileList | window := self morphicViewFileSelectorForSuffixes: aList. aFileList := window valueOfProperty: #fileListModel. World openModal: window. ^aFileList getSelectedFile! ! !FileList class methodsFor: 'morphic ui' stamp: 'NicolaiHess 2/8/2014 00:29'! morphicViewFolderSelector: aDir "Answer a tool that allows the user to select a folder" | window buttonRow fileListTopOffset aFileList | aFileList := self new directory: aDir. aFileList optionalButtonSpecs: aFileList servicesForFolderSelector. window := (SystemWindow labelled: aDir fullName) model: aFileList. aFileList modalView: window. buttonRow := aFileList folderSelectButtonRow. aFileList universalButtonServices do: [:service | buttonRow addMorphBack: (service buttonToTriggerIn: self)]. fileListTopOffset := (TextStyle defaultFont pointSize * 2) + 11. self addFullPanesTo: window from: { {aFileList morphicDirectoryTreePane. (0@0 corner: 1@1) asLayoutFrame topOffset: (fileListTopOffset)}. {buttonRow . (0@0 corner: 1@0) asLayoutFrame bottomOffset: (fileListTopOffset-3)}. }. aFileList postOpen. ^ window ! ! !FileList class methodsFor: 'instance creation' stamp: 'hfm 11/29/2008 19:04'! registerFileReader: aProviderClass "register the given class as providing services for reading files" | registeredReaders | registeredReaders := self registeredFileReaderClasses. (registeredReaders includes: aProviderClass) ifFalse: [ registeredReaders addLast: aProviderClass ]! ! !FileList class methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme ^ Smalltalk ui theme ! ! !FileList class methodsFor: 'initialization' stamp: 'MarcusDenker 12/12/2009 07:36'! initialize "FileList initialize" RecentDirs := OrderedCollection new. (self systemNavigation allClassesImplementing: #fileReaderServicesForFile:suffix:) do: [:providerMetaclass | self registerFileReader: providerMetaclass soleInstance]! ! !FileList class methodsFor: 'morphic ui' stamp: 'StephaneDucasse 12/19/2012 16:36'! morphicViewOnFile: aFile contents: contents fileList: aFileList | window fileListBottom midLine fileListTopOffset buttonPane fileContentsView | window := (SystemWindow labelled: aFile fullName) model: aFileList. fileListTopOffset := (TextStyle defaultFont pointSize * 2) + 11. fileListBottom := 0.4. midLine := 0.2. buttonPane := aFileList optionalButtonRow addMorph: (aFileList morphicPatternPane). self addFullPanesTo: window from: { {aFileList morphicDirectoryTreePane. (0@0 corner: midLine@1) asLayoutFrame }. {buttonPane. (midLine@0 corner: 1@0) asLayoutFrame bottomOffset: (fileListTopOffset-3)}. {aFileList morphicFileListPane. (midLine @ 0 corner: 1@fileListBottom) asLayoutFrame topOffset: fileListTopOffset}. {fileContentsView := aFileList morphicFileContentsPane. (midLine@fileListBottom corner: 1@1) asLayoutFrame}. }. contents ifNotNil: [ fileContentsView editString: contents. fileContentsView hasUnacceptedEdits: true]. aFileList postOpen. ^ window ! ! !FileList class methodsFor: 'file reader registration' stamp: 'hfm 11/29/2008 19:36'! isReaderNamedRegistered: aSymbol "return if a given reader class has been registered. Note that this is on purpose that the argument is a symbol and not a class" ^ (self registeredFileReaderClasses collect: [:each | each name]) includes: aSymbol ! ! !FileList class methodsFor: 'utility' stamp: 'StephaneDucasse 12/19/2012 16:36'! addFullPanesTo: window from: aCollection aCollection do: [ :each | window addMorph: each first fullFrame: each second ]! ! !FileList class methodsFor: 'tools registry' stamp: 'IgorStasenko 2/19/2011 03:00'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #fileList ! ! !FileList class methodsFor: 'utility' stamp: 'AlainRastoul 4/19/2012 15:00'! itemsForFile: file "Answer a list of services appropriate for a file of the given full name" | services suffix | suffix := self suffixOf: file fullName. services := OrderedCollection new. self registeredFileReaderClasses do: [:reader | reader ifNotNil: [ services addAll: (reader fileReaderServicesForFile: file fullName suffix: suffix)]]. ^ services! ! !FileList class methodsFor: 'instance creation' stamp: 'hfm 11/29/2008 19:37'! openEditorOn: aFileStream editString: editString "Open an editor on the given FileStream." ^ (self openMorphOn: aFileStream editString: editString) openInWorld! ! !FileList class methodsFor: 'file reader registration' stamp: 'MarcusDenker 10/16/2013 21:56'! allRegisteredServices "self allRegisteredServices" ^self registeredFileReaderClasses flatCollect: [:each | each services] ! ! !FileList class methodsFor: 'morphic ui' stamp: 'EstebanLorenzano 4/2/2012 11:43'! morphicView ^ self morphicViewOnDirectory: FileSystem disk workingDirectory! ! !FileList class methodsFor: 'morphic ui' stamp: 'CamilloBruni 2/14/2012 14:34'! morphicViewOnDirectory: aFileDirectory ^ self morphicViewOnFile: aFileDirectory contents: nil fileList: (self new directory: aFileDirectory).! ! !FileList class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallOpenIcon! ! !FileList class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/12/2011 21:53'! searchList ^ searchList ifNil: [ searchList := OrderedCollection new ].! ! !FileList class methodsFor: 'world menu' stamp: 'TorstenBergmann 2/12/2014 09:25'! menuCommandOn: aBuilder (aBuilder item: #'File Browser') parent: #Tools; order: 0.43; action:[self open]; icon: self taskbarIcon. aBuilder withSeparatorAfter. ! ! !FileList class methodsFor: 'utility' stamp: 'CamilloBruni 5/4/2012 20:09'! suffixOf: aName "Answer the file extension of the given file" ^ aName ifNil: [''] ifNotNil: [ aName asFileReference extension asLowercase]! ! !FileList class methodsFor: 'window color' stamp: 'AlainPlantec 12/16/2009 22:09'! patchworkUIThemeColor "Answer a default color for UI themes that make use of different colors for Browser, MessageList etc..." ^ Color lightMagenta ! ! !FileList class methodsFor: 'modal dialogs' stamp: 'NicolaiHess 2/8/2014 00:10'! modalFolderSelector: aDir | window fileModel | window := self morphicViewFolderSelector: aDir. fileModel := window model. window openInWorld: self currentWorld extent: 300@400. World openModal: window. ^fileModel getSelectedFolder! ! !FileList class methodsFor: 'utility' stamp: 'RAA 3/6/2001 12:39'! textRow: aString ^AlignmentMorph newRow wrapCentering: #center; cellPositioning: #leftCenter; color: Color transparent; layoutInset: 0; addMorph: ( AlignmentMorph newColumn wrapCentering: #center; cellPositioning: #topCenter; color: Color transparent; vResizing: #shrinkWrap; layoutInset: 0; addMorph: ( AlignmentMorph newRow wrapCentering: #center; cellPositioning: #leftCenter; color: Color transparent; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0; addMorph: ((StringMorph contents: aString) color: Color blue; lock) ) )! ! !FileList class methodsFor: 'utility' stamp: 'hfm 11/29/2008 18:37'! registeredFileReaderClasses FileReaderRegistry := nil. "wipe it out" ^FileServices registeredFileReaderClasses ! ! !FileList class methodsFor: 'file reader registration' stamp: 'hfm 11/29/2008 19:39'! unregisterFileReader: aProviderClass "unregister the given class as providing services for reading files" self registeredFileReaderClasses remove: aProviderClass ifAbsent: [nil]! ! !FileList class methodsFor: 'utility' stamp: 'hfm 11/29/2008 18:58'! itemsForDirectory: aFileDirectory "Answer a list of services appropriate when no file is selected." | services | services := OrderedCollection new. self registeredFileReaderClasses do: [:reader | reader ifNotNil: [services addAll: (reader fileReaderServicesForDirectory: aFileDirectory) ]]. ^ services! ! !FileList class methodsFor: 'instance creation' stamp: 'SeanDeNigris 7/12/2012 08:44'! openMorphOn: aFileStream editString: editString "Open a morphic view of a FileList on the given file." ^ self morphicViewOnFile: aFileStream fullName asFileReference contents: editString fileList: (self new setFileStream: aFileStream).! ! !FileList class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/24/2013 19:30'! openOn: aFileReference "Open a view of an instance of me on the given file reference." "FileList openOn: FileSystem memory" (FileList morphicViewOnDirectory: aFileReference) openInWorld! ! !FileList class methodsFor: 'instance creation' stamp: 'MarcusDenker 12/12/2009 07:29'! open "Open a view of an instance of me on the default directory." "FileList open openInWorld" ^ self morphicView openInWorld! ! !FileListGrid commentStamp: 'TorstenBergmann 2/4/2014 20:43'! A grid for a list of files! !FileListGrid methodsFor: 'menus' stamp: 'AlexisParseghian 3/15/2012 23:25'! fileListMenu: aMenuMorph ^ parent fileListMenu: aMenuMorph! ! !FileListGrid methodsFor: 'accessing' stamp: ''! parent: aFileList parent := aFileList! ! !FileListGrid methodsFor: 'accessing' stamp: ''! rootNodeClassFromItem: anItem ^ FileListGridNode! ! !FileListGrid methodsFor: 'user interface' stamp: 'CamilloBruni 7/10/2012 22:03'! treeMorph treeMorph ifNil: [ treeMorph := (self treeMorphClass on: self) columns: { MorphTreeColumn new rowMorphGetSelector: #fileName; startWidth: 300; headerButtonLabel: 'File name' translated font: nil target: self parent actionSelector: #setSortSelector: arguments: { #sortBlockBasename }. MorphTreeColumn new rowMorphGetSelector: #fileSize; headerButtonLabel: 'Size' translated font: nil target: self parent actionSelector: #setSortSelector: arguments: { #sortBlockFilesize }. MorphTreeColumn new rowMorphGetSelector: #modificationDate; headerButtonLabel: 'Last mod.' translated font: nil target: self parent actionSelector: #setSortSelector: arguments: { #sortBlockTimestamp }. MorphTreeColumn new rowMorphGetSelector: #filePermissions; headerButtonLabel: 'Permissions' translated font: nil target: self parent actionSelector: #setSortSelector: arguments: { #sortBlockPermissions }}. treeMorph hResizing: #spaceFill; vResizing: #spaceFill; columnInset: 3; getMenuSelector: #fileListMenu:; makeLastColumnUnbounded. ]. ^ treeMorph buildContents ! ! !FileListGrid methodsFor: 'accessing' stamp: ''! rootItems ^ parent fileList! ! !FileListGrid methodsFor: 'accessing' stamp: ''! parent ^ parent! ! !FileListGridNode commentStamp: 'TorstenBergmann 2/4/2014 20:42'! A node in the file list grid! !FileListGridNode methodsFor: 'user interface' stamp: 'CamilloBruni 7/10/2012 22:04'! fileSize ^ self theme newTextIn: self text: item humanReadableSize asString! ! !FileListGridNode methodsFor: 'user interface' stamp: 'AlexisParseghian 3/14/2012 14:36'! fileName ^ self theme newTextIn: self text: item basename! ! !FileListGridNode methodsFor: 'user interface' stamp: 'CamilloBruni 7/10/2012 22:02'! filePermissions ^ self theme newTextIn: self text: item permissions asString! ! !FileListGridNode methodsFor: 'user interface' stamp: 'CamilloBruni 7/10/2012 22:03'! modificationDate ^ self theme newTextIn: self text: item modificationTime asString! ! !FileLocator commentStamp: ''! I am a late-bound reference. I refer to a file or directory in relation to a well-known location on the filesystem, called an origin. When asked to perform concrete operation, I look up the current location of my origin, and resolve my path against it. Usage ---------- FileLocator vmDirectory parent pathString > '/Applications' FileLocator desktop. FileLocator desktop basename. FileLocator home basename. FileLocator image. FileLocator vmBinary asAbsolute pathString > '/Applications/CogVM.app/Contents/MacOS/CogVM' FileLocator vmBinary pathString > '/Applications/CogVM.app/Contents/MacOS/CogVM' Implementation ------------------------ origin A symbolic name for base reference I use to resolve myself. path A relative path that is resolved against my origin" ! !FileLocator methodsFor: 'comparing' stamp: 'cwp 10/25/2009 11:05'! hash ^ origin hash bitXor: path hash! ! !FileLocator methodsFor: 'streams-compatibility' stamp: 'MaxLeske 1/26/2014 20:50'! binaryReadStream ^ self resolve binaryReadStream! ! !FileLocator methodsFor: 'accessing' stamp: 'cwp 10/25/2009 21:31'! origin ^ origin! ! !FileLocator methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! readStream ^ self resolve readStream ! ! !FileLocator methodsFor: 'copying' stamp: 'CamilloBruni 7/10/2012 15:17'! copyWithPath: newPath ^ self class origin: origin path: newPath! ! !FileLocator methodsFor: 'converting' stamp: 'cwp 10/25/2009 10:30'! asAbsolute ^ self ! ! !FileLocator methodsFor: 'accessing' stamp: 'cwp 10/25/2009 21:31'! path ^ path! ! !FileLocator methodsFor: 'testing' stamp: 'cwp 10/25/2009 11:15'! isRelative ^ false! ! !FileLocator methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:19'! resolveString: aString | filesystem thePath | filesystem := (Resolver resolve: origin) fileSystem. thePath := filesystem pathFromString: aString. ^ self withPath: (path resolvePath: thePath)! ! !FileLocator methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:23'! fullPath ^ self resolve path! ! !FileLocator methodsFor: 'error handling' stamp: 'CamilloBruni 5/24/2012 12:35'! doesNotUnderstand: aMessage "Redirect message to the resolved version of this FileLocator. If FileReference won't understand the message send a normal DNU." | resolved | resolved := self resolve. (resolved respondsTo: aMessage selector) ifTrue: [ ^ resolved perform: aMessage selector withArguments: aMessage arguments ]. ^ super doesNotUnderstand: aMessage.! ! !FileLocator methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! writeStream ^ self resolve writeStream ! ! !FileLocator methodsFor: 'printing' stamp: 'EstebanLorenzano 4/3/2012 12:55'! printOn: aStream | fs | aStream nextPut: ${; nextPutAll: origin; nextPut: $}. path isWorkingDirectory ifTrue: [ ^ self ]. fs := self fileSystem. aStream nextPut: fs delimiter. fs printPath: path on: aStream! ! !FileLocator methodsFor: 'testing' stamp: 'cwp 10/25/2009 10:30'! isAbsolute ^ true! ! !FileLocator methodsFor: 'converting' stamp: 'EstebanLorenzano 4/12/2012 14:28'! asFileReference ^ self resolve! ! !FileLocator methodsFor: 'comparing' stamp: 'cwp 10/26/2009 10:28'! = other ^ self species = other species and: [origin = other origin and: [path = other path]]! ! !FileLocator methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 17:45'! renameTo: newBasename | result | result := self resolve renameTo: newBasename. path size > 0 ifTrue: [ path basename: newBasename ] ifFalse: [ path := result path ]! ! !FileLocator methodsFor: 'navigating' stamp: 'cwp 10/25/2009 09:59'! resolve ^ (Resolver resolve: origin) resolve: path! ! !FileLocator methodsFor: 'accessing' stamp: 'StephaneDucasse 9/14/2012 11:12'! absolutePath "Return the absolute path" ^ self resolve path! ! !FileLocator methodsFor: 'initialize-release' stamp: 'cwp 10/25/2009 09:56'! initializeWithOrigin: aSymbol path: aPath self initialize. origin := aSymbol. path := aPath.! ! !FileLocator class methodsFor: 'origins' stamp: 'CamilloBruni 7/10/2012 21:36'! root ^ FileSystem disk root! ! !FileLocator class methodsFor: 'mac-origins' stamp: 'CamilloBruni 11/8/2013 19:06'! systemLibrary ^ self origin: #systemLibrary! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! P ^ self driveNamed: #P ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! N ^ self driveNamed: #N ! ! !FileLocator class methodsFor: 'class initialization' stamp: 'cwp 11/20/2009 15:01'! initialize Smalltalk addToStartUpList: self. self startUp: true! ! !FileLocator class methodsFor: 'origins' stamp: 'cwp 10/26/2009 13:49'! vmDirectory ^ self origin: #vmDirectory! ! !FileLocator class methodsFor: 'mac-origins' stamp: 'CamilloBruni 11/7/2013 21:01'! systemApplicationSupport ^ self origin: #systemApplicationSupport! ! !FileLocator class methodsFor: 'origins' stamp: 'cwp 10/27/2009 09:34'! home ^ self origin: #home! ! !FileLocator class methodsFor: 'mac-origins' stamp: 'CamilloBruni 11/7/2013 21:02'! userApplicationSupport ^ self origin: #userApplicationSupport! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! H ^ self driveNamed: #H ! ! !FileLocator class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 4/2/2012 11:39'! startUp: resuming resuming ifFalse: [ ^ self ]. Resolver := InteractiveResolver new. Resolver addResolver: SystemResolver new. Resolver addResolver: PlatformResolver forCurrentPlatform! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! F ^ self driveNamed: #F ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! Y ^ self driveNamed: #Y ! ! !FileLocator class methodsFor: 'origins' stamp: 'DamienCassou 12/20/2013 11:59'! temp ^ self origin: #temp! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! D ^ self driveNamed: #D ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! U ^ self driveNamed: #U ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! Q ^ self driveNamed: #Q ! ! !FileLocator class methodsFor: 'origins' stamp: 'CamilloBruni 5/24/2012 12:07'! preferences ^ self origin: #preferences! ! !FileLocator class methodsFor: 'origins' stamp: 'CamilloBruni 7/10/2012 21:36'! workingDirectory ^ FileSystem disk referenceTo: RelativePath new! ! !FileLocator class methodsFor: 'origins' stamp: 'lr 7/13/2010 13:35'! imageDirectory ^ self origin: #imageDirectory ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! Z ^ self driveNamed: #Z ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! C ^ self driveNamed: #C ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! M ^ self driveNamed: #M ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! I ^ self driveNamed: #I ! ! !FileLocator class methodsFor: 'origins' stamp: 'cwp 10/26/2009 11:37'! vmBinary ^ self origin: #vmBinary! ! !FileLocator class methodsFor: 'origins' stamp: 'lr 7/13/2010 13:29'! changes ^ self origin: #changes ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! T ^ self driveNamed: #T ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! W ^ self driveNamed: #W! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! R ^ self driveNamed: #R ! ! !FileLocator class methodsFor: 'origins' stamp: 'CamilloBruni 11/8/2013 18:39'! cache ^ self origin: #cache! ! !FileLocator class methodsFor: 'mac-origins' stamp: 'CamilloBruni 11/8/2013 18:38'! userLibrary ^ self origin: #userLibrary! ! !FileLocator class methodsFor: 'origins' stamp: 'CamilloBruni 5/24/2012 12:07'! documents ^ self origin: #documents! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! S ^ self driveNamed: #S ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:39'! driveNamed: driveName ^ FileReference fileSystem: (FileSystem disk) path: Path / (driveName, ':')! ! !FileLocator class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 4/2/2012 11:42'! origin: aSymbol ^ self origin: aSymbol path: Path workingDirectory! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! L ^ self driveNamed: #L ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! O ^ self driveNamed: #O ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! J ^ self driveNamed: #J ! ! !FileLocator class methodsFor: 'unix-origins' stamp: 'CamilloBruni 11/7/2013 21:02'! userData ^ self origin: #userData! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! E ^ self driveNamed: #E ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! K ^ self driveNamed: #K ! ! !FileLocator class methodsFor: 'origins' stamp: 'cwp 10/25/2009 09:54'! image ^ self origin: #image ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! G ^ self driveNamed: #G ! ! !FileLocator class methodsFor: 'origins' stamp: 'CamilloBruni 7/10/2012 21:39'! cwd ^ self workingDirectory! ! !FileLocator class methodsFor: 'origins' stamp: 'cwp 10/27/2009 10:24'! desktop ^ self origin: #desktop! ! !FileLocator class methodsFor: 'accessing' stamp: 'cwp 10/27/2009 11:25'! supportedOrigins | origins current | origins := IdentitySet new. current := Resolver. [current notNil] whileTrue: [origins addAll: current supportedOrigins. current := current next]. ^ origins! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! A ^ self driveNamed: #A ! ! !FileLocator class methodsFor: 'class initialization' stamp: 'cwp 10/27/2009 10:28'! flushCaches Resolver flushCaches! ! !FileLocator class methodsFor: 'class initialization' stamp: 'cwp 10/26/2009 20:54'! addResolver: aResolver Resolver addResolver: aResolver! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! B ^ self driveNamed: #B ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! X ^ self driveNamed: #X ! ! !FileLocator class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/24/2012 14:49'! origin: aSymbol path: aPath ^ self basicNew initializeWithOrigin: aSymbol path: aPath! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! V ^ self driveNamed: #V ! ! !FileLocatorTest commentStamp: 'TorstenBergmann 1/31/2014 11:38'! SUnit test for FileLocator! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testParent locator := FileLocator image. self assert: locator parent resolve = FileLocator imageDirectory resolve! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testIsRelative locator := FileLocator image. self deny: locator isRelative! ! !FileLocatorTest methodsFor: 'resolution tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testResolveAbsoluteReference | result reference | locator := FileLocator image / 'plonk'. reference := FileSystem memory / 'griffle'. result := locator resolve: reference.. self assert: result == reference! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testEqual | a b | a := FileLocator image. b := FileLocator image. self deny: a == b. self assert: a = b.! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testAsAbsolute locator := FileLocator image. self assert: locator asAbsolute = locator! ! !FileLocatorTest methodsFor: 'resolution tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testResolveCompoundString | result compound | locator := FileLocator image / 'plonk'. compound := 'griffle', locator fileSystem delimiter asString, 'nurp'. result := locator resolve: compound. self assert: result class = locator class. self assert: result origin = locator origin. self assert: result path = ((Path * 'plonk') / 'griffle' / 'nurp')! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testContainsLocator locator := FileLocator image. self assert: (locator contains: locator / 'griffle').! ! !FileLocatorTest methodsFor: 'resolution tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testImageDirectory locator := FileLocator image. self assert: locator resolve = FileLocator image resolve! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'CamilloBruni 2/25/2014 14:38'! testMoveTo | old new | [ old := FileLocator imageDirectory / 'testMoveTo_old'. old ensureCreateFile. new := FileLocator home / 'testMoveTo_new'. old moveTo: new. self deny: old exists. self assert: new exists. ] ensure: [ old ensureDelete. new ensureDelete. ]! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testCommaAddsExtension locator := FileLocator image / 'griffle'. self assert: (locator , 'plonk') basename = 'griffle.plonk'! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testIsRoot locator := FileLocator image. (locator resolve path size) timesRepeat: [locator := locator / '..']. self assert: locator isRoot! ! !FileLocatorTest methodsFor: 'resolution tests' stamp: 'CamilloBruni 2/22/2014 15:03'! testResolveString | result path | locator := FileLocator image / 'plonk'. result := locator resolve: 'griffle'. path := (Path * 'plonk') / 'griffle'. self assert: result class = locator class. self assert: result origin = locator origin. self assert: result path = path.! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testIsAbsolute locator := FileLocator image. self assert: locator isAbsolute! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testSlash locator := FileLocator image / 'griffle'. self assert: locator = (FileLocator image / 'griffle')! ! !FileLocatorTest methodsFor: 'resolution tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testResolveRelativeReference | result reference | locator := FileLocator image / 'plonk'. self flag: 'this is a bit weird...'. reference := FileSystem memory * 'griffle'. result := locator resolve: reference.. self assert: result class= locator class. self assert: result origin = locator origin. self assert: result path = reference path.! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testCommaAddsExtensionAgain locator := FileLocator image / 'griffle.plonk'. self assert: (locator , 'nurp') basename = 'griffle.plonk.nurp'! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testWithExtensionAddsExtension locator := FileLocator image / 'griffle'. self assert: (locator withExtension: 'plonk') basename = 'griffle.plonk'! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testOriginBasename locator := FileLocator image. self assert: locator basename = FileLocator image resolve basename! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testFileSystem locator := FileLocator image. self assert: (locator fileSystem isKindOf: FileSystem)! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testBasename locator := FileLocator image / 'griffle'. self assert: locator basename = 'griffle'! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'CamilloBruni 2/22/2014 15:16'! testExtension locator := FileLocator image, 'bak'. self assert: (locator basename endsWith: '.bak') ! ! !FileLocatorTest methodsFor: 'tests' stamp: 'CamilloBruni 7/10/2012 22:54'! testCPath | ref | ref := FileLocator C / 'WINDOWS'. self assert: (ref fileSystem isKindOf: FileSystem). self assert: ref path = (Path / 'C:' / 'WINDOWS')! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testContainsPath "self debug: #testContainsPath" locator := FileLocator image. self assert: (locator contains: (locator resolve / 'griffle') path).! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testContainsReference locator := FileLocator image. self assert: (locator contains: (locator resolve / 'griffle')).! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testIsNotRoot locator := FileLocator image. self deny: locator isRoot! ! !FileLocatorTest methodsFor: 'resolution tests' stamp: 'CamilloBruni 2/22/2014 15:03'! testResolvePath | result path | locator := FileLocator image / 'plonk'. result := locator resolve: (Path * 'griffle'). path := (Path * 'plonk') / 'griffle'. self assert: result class = locator class. self assert: result origin = locator origin. self assert: result path = path.! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testWithExtensionReplacesExtension locator := FileLocator image / 'griffle.nurp'. self assert: (locator withExtension: 'plonk') basename = 'griffle.plonk'! ! !FileModifyingSimpleServiceEntry commentStamp: 'nk 11/26/2002 12:03'! I represent a service that may change the contents of a directory. Such changes include: * file creation * file deletion * file modification! !FileModifyingSimpleServiceEntry methodsFor: 'performing service' stamp: 'nk 11/26/2002 12:08'! performServiceFor: anObject | retval | retval := super performServiceFor: anObject. self changed: #fileListChanged. ^retval "is this used anywhere?"! ! !FilePackage commentStamp: 'TorstenBergmann 1/31/2014 10:27'! Represents a file package used to browse code files. This is for instance used in the FileContentsBrowser! !FilePackage methodsFor: 'private' stamp: 'MarcusDenker 5/18/2013 15:44'! removedMethod: string with: chgRec | class tokens | tokens := string parseLiterals. (tokens size = 3 and:[(tokens at: 2) == #removeSelector: ]) ifTrue:[ class := self getClass: (tokens at: 1). ^class removeSelector: (tokens at: 3). ]. (tokens size = 4 and:[(tokens at: 2) == #class and:[(tokens at: 3) == #removeSelector:]]) ifTrue:[ class := self getClass: (tokens at: 1). ^class metaClass removeSelector: (tokens at: 4). ]. doIts add: chgRec! ! !FilePackage methodsFor: 'change record types' stamp: ''! method: chgRec (self getClass: chgRec methodClassName) methodChange: chgRec! ! !FilePackage methodsFor: 'accessing' stamp: 'pnm 8/23/2000 17:10'! fullName: aString fullName := aString! ! !FilePackage methodsFor: 'private' stamp: 'MarcusDenker 5/18/2013 15:44'! possibleSystemSource: chgRec | tokens | sourceSystem isEmpty ifTrue:[ tokens := chgRec string parseLiterals. (tokens size = 1 and:[tokens first isString]) ifTrue:[ sourceSystem := tokens first. ^self]]. doIts add: chgRec.! ! !FilePackage methodsFor: 'change record types' stamp: ''! classComment: chgRec (self getClass: chgRec methodClassName) classComment: chgRec! ! !FilePackage methodsFor: 'accessing' stamp: ''! classAt: className ^self classes at: className! ! !FilePackage methodsFor: 'accessing' stamp: 'md 1/15/2014 14:06'! packageInfo ^String streamContents:[:s| s nextPutAll:'Package: '. s nextPutAll: self fullPackageName asString; cr; cr. sourceSystem isEmpty ifFalse:[ s nextPutAll: sourceSystem; cr; cr]. doIts isEmpty ifFalse:[ s nextPutAll:'Unresolvable doIts:'; cr; cr. doIts do:[:chgRec| s nextPut:$!!; nextPutAll: chgRec string; nextPut: $!!; cr]]].! ! !FilePackage methodsFor: 'change record types' stamp: 'avi 1/19/2004 23:47'! doIts ^ doIts! ! !FilePackage methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:54'! initialize super initialize. classes := Dictionary new. classOrder := OrderedCollection new. sourceSystem := ''. doIts := OrderedCollection new.! ! !FilePackage methodsFor: 'filein/fileout' stamp: 'alain.plantec 2/6/2009 17:02'! fileOutOn: aStream | doitsMark | doitsMark := 1. doIts isEmpty ifFalse:[doitsMark := self askForDoits]. doitsMark = 0 ifTrue: [^nil]. doitsMark = 2 ifTrue:[self fileOutDoits: aStream]. classOrder do:[:cls| cls fileOutDefinitionOn: aStream. ]. classes do:[:cls| cls fileOutMethodsOn: aStream. cls hasMetaclass ifTrue:[cls metaClass fileOutMethodsOn: aStream]. ]. doitsMark = 3 ifTrue:[self fileOutDoits: aStream].! ! !FilePackage methodsFor: 'private' stamp: 'MarcusDenker 5/18/2013 15:44'! metaClassDefinition: string with: chgRec | tokens theClass | tokens := string parseLiterals. theClass := self getClass: (tokens at: 1). theClass metaClass definition: string. classOrder add: theClass metaClass.! ! !FilePackage methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 02:09'! packageName ^ self fullPackageName asFileReference basename! ! !FilePackage methodsFor: 'change record types' stamp: ''! preamble: chgRec self doIt: chgRec! ! !FilePackage methodsFor: 'accessing' stamp: ''! fullPackageName ^fullName! ! !FilePackage methodsFor: 'filein/fileout' stamp: ''! fileInDoits doIts do:[:chgRec| chgRec fileIn].! ! !FilePackage methodsFor: 'accessing' stamp: ''! removeClass: aPseudoClass (self classes removeKey: aPseudoClass name). classOrder copy do:[:cls| cls name = aPseudoClass name ifTrue:[ classOrder remove: cls]. ].! ! !FilePackage methodsFor: 'change record types' stamp: ''! doIt: chgRec | string | string := chgRec string. ('*ubclass:*instanceVariableNames:*classVariableNames:*poolDictionaries:*category:*' match: string) ifTrue:[^self classDefinition: string with: chgRec]. ('* class*instanceVariableNames:*' match: string) ifTrue:[^self metaClassDefinition: string with: chgRec]. ('* removeSelector: *' match: string) ifTrue:[^self removedMethod: string with: chgRec]. ('* comment:*' match: string) ifTrue:[^self msgClassComment: string with: chgRec]. ('* initialize' match: string) ifTrue:[^self]. "Initialization is done based on class>>initialize" ('''From *' match: string) ifTrue:[^self possibleSystemSource: chgRec]. doIts add: chgRec.! ! !FilePackage methodsFor: 'reading' stamp: 'SeanDeNigris 6/21/2012 09:04'! fileInFrom: aStream | changes | changes := ChangeSet scanFile: aStream from: 0 to: aStream size. aStream close. ('Processing ', self packageName) displayProgressFrom: 1 to: changes size during:[:bar| | chgRec | 1 to: changes size do:[:i| bar current: i. chgRec := changes at: i. self perform: (chgRec type copyWith: $:) asSymbol with: chgRec. ]. ].! ! !FilePackage methodsFor: 'filein/fileout' stamp: 'alain.plantec 2/6/2009 17:01'! askForDoits | choice choices | choices := {'do not process' translated. 'at the beginning' translated. 'at the end' translated}. choice := nil. [choices includes: choice] whileFalse: [ choice := UIManager default chooseFrom: choices values: choices title: 'Unprocessed doIts found. When to process those?' translated. choice ifNil: [^0]]. ^choices indexOf: choice! ! !FilePackage methodsFor: 'accessing' stamp: ''! classes ^classes! ! !FilePackage methodsFor: 'accessing' stamp: ''! renameClass: aPseudoClass to: newName | oldName | oldName := aPseudoClass name. self classes removeKey: oldName. self classes at: newName put: aPseudoClass. aPseudoClass renameTo: newName.! ! !FilePackage methodsFor: 'filein/fileout' stamp: ''! fileOutDoits: aStream doIts do:[:chgRec| chgRec fileOutOn: aStream].! ! !FilePackage methodsFor: 'change record types' stamp: 'MarcusDenker 5/18/2013 15:44'! classDefinition: string with: chgRec | tokens theClass | self flag: #traits. tokens := string parseLiterals. "tokens size = 11 ifFalse:[^doIts add: chgRec]." theClass := self getClass: (tokens at: 3). theClass definition: string. classOrder add: theClass.! ! !FilePackage methodsFor: 'private' stamp: 'MarcusDenker 5/18/2013 15:44'! msgClassComment: string with: chgRec | tokens theClass | tokens := string parseLiterals. (tokens size = 3 and:[(tokens at: 3) isString]) ifTrue:[ theClass := self getClass: tokens first. ^theClass commentString: tokens last]. (tokens size = 4 and:[(tokens at: 3) asString = 'class' and:[(tokens at: 4) isString]]) ifTrue:[ theClass := self getClass: tokens first. theClass metaClass commentString: tokens last]. ! ! !FilePackage methodsFor: 'filein/fileout' stamp: 'alain.plantec 2/6/2009 17:02'! fileIn | doitsMark | doitsMark := 1. doIts isEmpty ifFalse:[doitsMark := self askForDoits]. doitsMark = 0 ifTrue: [^nil]. doitsMark = 2 ifTrue:[self fileInDoits]. classOrder do:[:cls| cls fileInDefinition. ]. classes do:[:cls| Transcript cr; show:'Filing in ', cls name. cls fileInMethods. cls hasMetaclass ifTrue:[cls metaClass fileInMethods]. ]. doitsMark = 3 ifTrue:[self fileInDoits].! ! !FilePackage methodsFor: 'private' stamp: ''! getClass: className | pseudoClass | (classes includesKey: className) ifTrue:[ ^classes at: className. ]. pseudoClass := PseudoClass new. pseudoClass name: className. classes at: className put: pseudoClass. ^pseudoClass.! ! !FilePackage methodsFor: 'filein/fileout' stamp: 'ar 7/17/2005 03:36'! fileOut | fileName stream | fileName := UIManager default request: 'Enter the file name' initialAnswer:''. stream := FileStream newFileNamed: fileName. sourceSystem isEmpty ifFalse:[ stream nextChunkPut: sourceSystem printString;cr ]. self fileOutOn: stream. stream cr; cr. self classes do:[:cls| cls needsInitialize ifTrue:[ stream cr; nextChunkPut: cls name,' initialize']]. stream cr. stream close. "DeepCopier new checkVariables." ! ! !FilePackage methodsFor: 'initialize' stamp: 'StephaneDucasse 2/2/2010 21:52'! fromFileNamed: aName fullName := aName. FileStream readOnlyFileNamed: aName do: [ :aStream | aStream setConverterForCode. self fileInFrom: aStream] ! ! !FilePackage class methodsFor: 'instance creation' stamp: ''! fromFileNamed: aName ^self new fromFileNamed: aName! ! !FilePathEncoder commentStamp: 'yo 10/19/2004 21:36'! This class absorb the difference of internal and external representation of the file path. The idea is to keep the internal one as much as possible, and only when it goes to a primitive, the encoded file path, i.e. the native platform representation is passsed to the primitive. The converter used is obtained by "LanguageEnvironment defaultFileNameConverter". ! !FilePathEncoder class methodsFor: 'encoding' stamp: 'MartinDias 10/2/2013 16:09'! decode: aString ^ aString convertFromWithConverter: LanguageEnvironment defaultFileNameConverter.! ! !FilePathEncoder class methodsFor: 'encoding' stamp: 'MartinDias 10/2/2013 16:07'! encode: pathString ^ pathString convertToWithConverter: LanguageEnvironment defaultFileNameConverter.! ! !FilePluginPrims commentStamp: 'cwp 11/18/2009 13:02'! I provide an interface to the primitives in the FilePlugin. ! !FilePluginPrims methodsFor: 'encoding primitives' stamp: 'lr 7/13/2010 14:10'! decode: aString ^ aString convertFromWithConverter: LanguageEnvironment defaultFileNameConverter! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'cwp 7/20/2009 17:23'! getMacFile: fileName type: typeString creator: creatorString "Get the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. This primitive is Mac specific; it is a noop on other platforms." ! ! !FilePluginPrims methodsFor: 'file primitives' stamp: 'cwp 7/20/2009 17:27'! close: id "Close this file." ! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'cwp 7/20/2009 17:22'! deleteFile: aFileName "Delete the file of the given name. Return self if the primitive succeeds, nil otherwise." ^ nil ! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'cwp 7/20/2009 17:25'! setMacFileNamed: fileName type: typeString creator: creatorString "Set the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. This primitive is Mac specific; it is a noop on other platforms." self primitiveFailed ! ! !FilePluginPrims methodsFor: 'file primitives' stamp: 'cwp 7/20/2009 17:26'! atEnd: id "Answer true if the file position is at the end of the file." self primitiveFailed ! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'CamilloBruni 6/17/2013 11:06'! lookupEntryIn: fullPath index: index "Look up the index-th entry of the directory with the given fully-qualified path (i.e., starting from the root of the file hierarchy) and return an array containing: The empty string enumerates the top-level files or drives. (For example, on Unix, the empty path enumerates the contents of '/'. On Macs and PCs, it enumerates the mounted volumes/drives.) The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad." ^ #badDirectoryPath ! ! !FilePluginPrims methodsFor: 'file primitives' stamp: 'cwp 7/20/2009 17:33'! truncate: id to: anInteger "Truncate this file to the given position." self primitiveFailed ! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'cwp 11/17/2009 16:26'! createDirectory: fullPath "Create a directory named by the given path. Fail if the path is bad or if a file or directory by that name already exists." ^ nil ! ! !FilePluginPrims methodsFor: 'file primitives' stamp: 'cwp 7/20/2009 17:27'! getPosition: id "Get this files current position." self primitiveFailed ! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'CamilloBruni 6/17/2013 11:05'! lookupDirectory: fullPath filename: fileName ^ #badDirectoryPath ! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'cwp 7/20/2009 17:24'! rename: oldFileFullName to: newFileFullName "Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name." ^nil! ! !FilePluginPrims methodsFor: 'encoding primitives' stamp: 'lr 7/13/2010 14:11'! encode: aString ^ aString convertToWithConverter: LanguageEnvironment defaultFileNameConverter! ! !FilePluginPrims methodsFor: 'file primitives' stamp: 'lr 3/21/2010 12:10'! flush: id "Flush pending changes to the disk" | pos | "In some OS's seeking to 0 and back will do a flush" pos := self getPosition: id. self setPosition: id to: 0; setPosition: id to: pos! ! !FilePluginPrims methodsFor: 'file primitives' stamp: 'cwp 7/20/2009 17:28'! read: id into: byteArray startingAt: startIndex count: count "Read up to count bytes of data from this file into the given string or byte array starting at the given index. Answer the number of bytes actually read." self primitiveFailed! ! !FilePluginPrims methodsFor: 'file primitives' stamp: 'cwp 7/20/2009 17:30'! size: id "Answer the size of this file." self primitiveFailed ! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'cwp 10/11/2009 11:02'! imageFile "Answer the full path name for the current image." self primitiveFailed! ! !FilePluginPrims methodsFor: 'file primitives' stamp: 'cwp 7/20/2009 17:27'! open: fileName writable: writableFlag "Open a file of the given name, and return the file ID obtained. If writableFlag is true, then if there is none with this name, then create one else prepare to overwrite the existing from the beginning otherwise if the file exists, open it read-only else return nil" ^ nil ! ! !FilePluginPrims methodsFor: 'file primitives' stamp: 'cwp 7/20/2009 17:30'! setPosition: id to: anInteger "Set this file to the given position." self primitiveFailed ! ! !FilePluginPrims methodsFor: 'file primitives' stamp: 'cwp 7/22/2009 07:10'! sizeOrNil: id "Answer the size of this file." ^ nil! ! !FilePluginPrims methodsFor: 'file primitives' stamp: 'cwp 7/20/2009 17:33'! write: id from: stringOrByteArray startingAt: startIndex count: count "Write count bytes onto this file from the given string or byte array starting at the given index. Answer the number of bytes written." self primitiveFailed! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'cwp 10/11/2009 11:02'! delimiter "Return the path delimiter for the underlying platform's file system." self primitiveFailed ! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'cwp 7/20/2009 17:21'! deleteDirectory: fullPath "Delete the directory named by the given path. Fail if the path is bad or if a directory by that name does not exist." self primitiveFailed ! ! !FileReference commentStamp: ''! I combine a filesystem and path, which is sufficient to refer to a concrete file or directory. I provide methods for navigating my filesystem, performing filesystem operations and opening and closing files. I am the primary mechanism for working with files and directories. | working | working := FileSystem disk workingDirectory. working files | disk | disk := FileSystem disk. disk root. "a reference to the root directory" disk working. "a reference to the working directory"! !FileReference methodsFor: 'testing' stamp: 'cwp 7/20/2009 09:26'! isRoot ^ path isRoot! ! !FileReference methodsFor: 'testing' stamp: 'StephaneDucasse 6/22/2012 17:35'! hasFiles "Return whether the receiver has children that are files." "FileSystem workingDirectory hasFiles" ^ filesystem hasFiles: path! ! !FileReference methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2012 00:37'! isReadable ^ filesystem isReadable: path! ! !FileReference methodsFor: 'streams-compatibility' stamp: 'MaxLeske 1/25/2014 22:50'! binaryReadStream ^ filesystem binaryReadStreamOn: self path! ! !FileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:52'! deleteIfAbsent: aBlock self exists ifTrue: [ self delete ] ifFalse: aBlock! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 1/19/2012 14:16'! path "Return the path internal representation that denotes the receiver in the context of its filesystem. " ^ path! ! !FileReference methodsFor: 'comparing' stamp: 'EstebanLorenzano 4/3/2012 13:05'! containsReference: aReference ^ aReference fileSystem = filesystem and: [path contains: aReference path]! ! !FileReference methodsFor: 'converting' stamp: 'CamilloBruni 7/10/2012 15:03'! asAbsolute "Return the receiver as an absolute file reference." ^ self isAbsolute ifTrue: [ self ] ifFalse: [ filesystem referenceTo: (filesystem resolve: path) ]! ! !FileReference methodsFor: 'accessing' stamp: 'sd 2/11/2011 19:58'! entry "Return the entry (meta data) describing the receiver." ^ filesystem entryAt: path! ! !FileReference methodsFor: 'resolving' stamp: 'cwp 11/21/2009 11:30'! resolveString: aString | thePath | thePath := filesystem pathFromString: aString. ^ filesystem referenceTo: (path resolve: thePath)! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 1/27/2014 17:18'! absolutePath "Return the absolute of the receiver" ^ self path isRelative ifFalse: [ self path ] ifTrue: [ filesystem resolve: self path ]! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 5/9/2012 13:04'! mimeTypes "Return the possible mime types for the given path." ^ filesystem mimeTypesAt: path! ! !FileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 20:17'! hasDirectories "Return whether the receiver has children that are directories." "FileSystem workingDirectory hasDirectories" ^ filesystem hasDirectories: path! ! !FileReference methodsFor: 'testing' stamp: 'cwp 1/13/2009 20:52'! exists ^ filesystem exists: path! ! !FileReference methodsFor: 'streams' stamp: 'CamilloBruni 1/20/2012 13:24'! openWritable: aBoolean ^ filesystem open: path writable: aBoolean! ! !FileReference methodsFor: 'operations' stamp: 'CamilloBruni 2/22/2014 14:56'! copyTo: aReference self isDirectory ifTrue: [ aReference ensureCreateDirectory ] ifFalse: [ filesystem = aReference fileSystem ifTrue: [ filesystem copy: path to: aReference resolve path ] ifFalse: [ filesystem copy: path toReference: aReference ] ]! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 20:51'! modificationTime ^ filesystem modificationTime: self path! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 11:37'! macTypeAndCreator | results typeString creatorString | "get the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. Does nothing on other platforms (where the underlying primitive is a noop)." "FileDirectory default getMacFileNamed: 'foo'" self flag: 'TODO'. " typeString := ByteArray new: 4 withAll: ($? asInteger). #[63 63 63 63] creatorString := ByteArray new: 4 withAll: ($? asInteger). [self primGetMacFileNamed: (self fullNameFor: fileName) asVmPathName type: typeString creator: creatorString.] ensure: [typeString := typeString asString. creatorString := creatorString asString]. results := Array with: typeString convertFromSystemString with: creatorString convertFromSystemString. ^results" ! ! !FileReference methodsFor: 'accessing' stamp: 'sd 2/11/2011 20:34'! fullName "Return the full path name of the receiver." ^ filesystem stringFromPath: (filesystem resolve: path)! ! !FileReference methodsFor: 'operations' stamp: 'S 6/17/2013 13:33'! ensureCreateDirectory "Create if necessary a directory for the receiver." filesystem ensureCreateDirectory: path ! ! !FileReference methodsFor: 'navigating' stamp: 'CamilloBruni 2/21/2014 22:31'! , extension ^ self withPath: self path, extension! ! !FileReference methodsFor: 'operations' stamp: 'CamilloBruni 2/22/2014 14:58'! moveTo: aReference | result | result := self fileSystem rename: self path to: aReference resolve path. result ifNotNil: [ self setFileSystem: filesystem path: aReference path ]. ! ! !FileReference methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/3/2012 13:03'! fileSystem "Return the filesystem to which the receiver belong." ^ filesystem! ! !FileReference methodsFor: 'testing' stamp: 'cwp 7/20/2009 09:25'! isRelative ^ path isRelative! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:23'! fullPath ^ self path! ! !FileReference methodsFor: 'operations' stamp: 'cwp 7/22/2009 07:42'! delete filesystem delete: path! ! !FileReference methodsFor: 'resolving' stamp: 'CamilloBruni 1/19/2012 12:45'! resolvePath: anObject ^ self withPath: (path resolve: anObject)! ! !FileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:25'! writeStream ^ filesystem writeStreamOn: self path! ! !FileReference methodsFor: 'testing' stamp: 'StephaneDucasse 6/22/2012 17:32'! hasChildren "Return whether the receiver has any children." "FileSystem workingDirectory hasChildren" ^ filesystem hasChildren: path! ! !FileReference methodsFor: 'testing' stamp: 'cwp 1/13/2009 21:57'! isFile ^ filesystem isFile: path! ! !FileReference methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 4/3/2012 13:07'! setFileSystem: aFilesystem path: aPath filesystem := aFilesystem. path := aPath! ! !FileReference methodsFor: '*monticellofiletree-filesystem-utilities' stamp: 'dkh 8/10/2012 10:27'! fileTreeUtilityClass ^ MCFileTreeFileSystemUtils! ! !FileReference methodsFor: 'operations' stamp: 'StephaneDucasse 8/4/2012 10:55'! createDirectory "Create a directory if it does not already exist, if this is the case raise the DirectoryExists exception." filesystem createDirectory: path! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 20:50'! creationTime ^ filesystem creationTime: self path! ! !FileReference methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2012 00:37'! isWritable ^ filesystem isWritable: path! ! !FileReference methodsFor: 'testing' stamp: 'EstebanLorenzano 8/2/2012 15:42'! isSymlink ^ filesystem isSymlink: path! ! !FileReference methodsFor: 'testing' stamp: 'cwp 1/13/2009 21:39'! isDirectory ^ filesystem isDirectory: path! ! !FileReference methodsFor: 'printing' stamp: 'cwp 10/11/2009 22:32'! printOn: aStream filesystem forReferencePrintOn: aStream. filesystem printPath: path on: aStream! ! !FileReference methodsFor: 'utility' stamp: 'GuillermoPolito 6/22/2012 13:31'! nextVersion "Assumes a file name includes a version number encoded as '.' followed by digits preceding the file extension. Increment the version number and answer the new file name. If a version number is not found, return just the file" | parent version versionNumbers nameWithoutExtension | self exists ifFalse: [ ^ self ]. parent := self parent. nameWithoutExtension := self basename copyUpTo: $.. versionNumbers := parent files select: [ :f| (f basename beginsWith: nameWithoutExtension) ] thenCollect: [ :f| Number squeezeNumberOutOfString: f basename ifFail: [ 0 ]]. versionNumbers ifEmpty: [ ^self ]. version := versionNumbers max + 1. ^ parent / (nameWithoutExtension , '.', version asString) , self extension! ! !FileReference methodsFor: 'resolving' stamp: 'EstebanLorenzano 4/3/2012 13:09'! resolveReference: aReference ^ (filesystem = aReference fileSystem or: [aReference isRelative]) ifTrue: [filesystem referenceTo: (path resolvePath: aReference path)] ifFalse: [aReference]! ! !FileReference methodsFor: 'navigating' stamp: 'EstebanLorenzano 4/3/2012 13:07'! entries "Return the entries (meta data - file description) of the direct children of the receiver" ^ self fileSystem entriesAt: self path ! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 22:06'! size ^ filesystem size: path! ! !FileReference methodsFor: 'comparing' stamp: 'cwp 9/16/2009 23:54'! hash ^ path hash bitXor: filesystem hash! ! !FileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:25'! readStream ^ filesystem readStreamOn: self path! ! !FileReference methodsFor: 'copying' stamp: 'CamilloBruni 7/10/2012 15:17'! copyWithPath: newPath ^ filesystem referenceTo: newPath! ! !FileReference methodsFor: 'testing' stamp: 'cwp 7/20/2009 09:24'! isAbsolute ^ path isAbsolute! ! !FileReference methodsFor: 'printing' stamp: 'sd 2/11/2011 20:34'! pathString "Return the full path name of the receiver." ^ filesystem stringFromPath: (filesystem resolve: path)! ! !FileReference methodsFor: 'converting' stamp: 'EstebanLorenzano 4/12/2012 14:28'! asFileReference ^ self! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 21:29'! permissions ^ filesystem permissions: self path! ! !FileReference methodsFor: 'comparing' stamp: 'EstebanLorenzano 4/3/2012 13:02'! = other ^ self species = other species and: [self path = other path and: [self fileSystem = other fileSystem]]! ! !FileReference methodsFor: 'operations' stamp: 'CamilloBruni 2/22/2014 14:58'! renameTo: newBasename | destinationPath | destinationPath := self fileSystem rename: self to: self parent / newBasename. destinationPath ifNotNil: [ self setFileSystem: filesystem path: destinationPath ]. ^ self ! ! !FileReference methodsFor: 'accessing' stamp: 'cwp 10/26/2009 02:02'! resolve ^ self! ! !FileReference methodsFor: '*metacello-platform' stamp: 'ChristopheDemarey 5/24/2013 14:54'! asRepositorySpecFor: aMetacelloMCProject ^ aMetacelloMCProject repositorySpec description: self fullName; type: 'directory'; yourself! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 02:01'! setMacType: aTypeString creator: aCreatorString self flag: 'TODO'. " self primSetMacFileNamed: (self fullNameFor: fileName) asVmPathName type: typeString convertToSystemString creator: creatorString convertToSystemString. "! ! !FileReference class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 4/3/2012 13:21'! fileSystem: aFilesystem path: aPath ^ self new setFileSystem: aFilesystem path: aPath! ! !FileReference class methodsFor: 'cross platform' stamp: 'EstebanLorenzano 4/2/2012 11:43'! / aString "Answer a reference to the argument resolved against the root of the current disk filesystem." ^ FileSystem disk / aString! ! !FileReference class methodsFor: '*Spec-Inspector' stamp: 'MarcusDenker 10/5/2013 22:00'! additionalInspectorClasses ^ super additionalInspectorClasses, { EyeFileSystemInspector }! ! !FileReferenceTest commentStamp: 'TorstenBergmann 1/31/2014 11:39'! SUnit tests for file reference! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:41'! testReadStreamNotFound | ref | ref := filesystem * 'plonk'. self should: [ref readStream] raise: FileDoesNotExist ! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:25'! testAllDirectories "allDirectories returns all folders recursively nested in a reference" "self debug: #testAllDirectories" | ref children | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. filesystem createDirectory: '/alpha/beta/delta'. filesystem createDirectory: '/alpha/gamma'. ref := filesystem / 'alpha'. children := ref allDirectories. "all children returns the directories: '/alpha', '/alpha/beta', and '/alpha/gamma'." self assert: children size = 4. children do: [:child | self assert: child class = FileReference. self assert: (ref = child or: [ref contains: child])]. self assert: (children collect: [:ea | ea basename]) = #('alpha' 'beta' 'gamma' 'delta')! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/23/2012 00:16'! testReadStreamIfAbsent | ref stream path | path := Path * 'plonk'. filesystem store createFile: path. ref := filesystem referenceTo: path. [ stream := ref readStreamIfAbsent: [ self signalFailure: 'Should not reach here.' ]. ] ensure: [ stream ifNotNil: [ stream close ] ]! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:25'! testAllChildren "allChildren returns all the files and folders recursively nested in a reference" "self debug: #testAllChildren" | ref children | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. filesystem createDirectory: '/alpha/beta/delta'. filesystem createDirectory: '/alpha/gamma'. ref := filesystem / 'alpha'. children := ref allChildren. "all children returns the nodes: '/alpha', '/alpha/beta', '/alpha/beta/delta', and '/alpha/gamma'." self assert: children size = 4. children do: [:child | self assert: child class = FileReference. self assert: (ref = child or: [ref contains: child])]. self assert: (children collect: [:ea | ea basename]) = #('alpha' 'beta' 'gamma' 'delta')! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:41'! testIsNotAbsolute self deny: (filesystem * 'plonk') isAbsolute! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:31'! testIsRelative self assert: (filesystem * 'plonk') isRelative! ! !FileReferenceTest methodsFor: 'tests' stamp: 'StephaneDucasse 6/17/2012 19:17'! testDeleteAllChildren "allChildren returns all the files and folders recursively nested in a reference" "self debug: #testDeleteAllChildren" | ref children | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. filesystem createDirectory: '/alpha/beta/delta'. filesystem createDirectory: '/alpha/gamma'. ref := filesystem / 'alpha'. ref deleteAllChildren. self assert: ref exists. self deny: (ref / 'beta') exists. self deny: (ref / 'beta' / 'delta') exists. self deny: (ref / 'beta' / 'gamma') exists.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/22/2012 18:03'! testHasChildren "self debug: #testHasChildren" | ref children | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. filesystem createDirectory: '/alpha/beta/delta'. filesystem createDirectory: '/alpha/gamma'. ref := filesystem / 'alpha'. self assert: ref hasChildren. self assert: (ref / 'beta') hasChildren. self deny: (ref / 'beta' / 'delta') hasChildren. self deny: (ref / 'beta' / 'gamma') hasChildren.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testPathRelativeTo | parent childPath relative | parent := filesystem / 'griffle'. childPath := Path / 'griffle' / 'plonk' / 'nurb'. relative := childPath relativeTo: parent. self assert: relative = (Path * 'plonk' / 'nurb')! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:43'! testAllEntries | ref entries | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. filesystem createDirectory: '/alpha/beta/delta'. filesystem createDirectory: '/alpha/gamma'. ref := filesystem / 'alpha'. entries := ref allEntries. self assert: entries size = 4. entries do: [:entry | self assert: entry class = FileSystemDirectoryEntry. self assert: (ref = entry reference or: [ref contains: entry reference])]. self assert: (entries collect: [:ea | ea basename]) = #('alpha' 'beta' 'gamma' 'delta')! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testDoesntContainLocator | ref | ref := filesystem * 'griffle'. self deny: (ref contains: FileLocator image)! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:47'! testRootParent | root | root := filesystem root. self assert: root parent == root! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/23/2012 00:17'! testWriteStreamifPresent | ref stream | ref := filesystem / 'plonk'. [stream := ref writeStreamIfPresent: [self signalFailure: 'Should not reach here']] ensure: [stream ifNotNil: [stream close]]! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testContainsLocator | ref | ref := FileLocator imageDirectory resolve parent. self assert: (ref contains: FileLocator image)! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/23/2012 00:19'! testWriteStreamDoifPresent | ref s | ref := filesystem / 'plonk'. ref writeStreamDo: [:stream | s := stream. self deny: stream isNil ] ifPresent: [self signalFailure: 'The file does not exist!!']. ! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:44'! testAsAbsoluteIdentity | ref | ref := filesystem / 'plonk'. self assert: ref asAbsolute == ref! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/13/2013 16:06'! testContents | ref contents | contents := '12345 abcdf!!'. ref := filesystem * 'file'. ref writeStreamDo: [ :stream | stream nextPutAll: contents ]. self assert: ref contents asString equals: contents! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:42'! testGrandchildOfReference | griffle nurb | griffle := filesystem / 'griffle'. nurb := filesystem / 'griffle' / 'plonk' / 'nurb'. self deny: (griffle isChildOf: nurb). self deny: (nurb isChildOf: griffle).! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:47'! testResolve | ref | ref := filesystem / 'griffle'. self assert: ref resolve == ref! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testSimpleResolution | base relative absolute | base := filesystem / 'plonk'. relative := (Path * 'griffle') / 'zonk'. absolute := base resolve: relative. self assert: absolute isAbsolute. self assert: (absolute path at: 1) = 'plonk'. self assert: (absolute path at: 2) = 'griffle'. self assert: (absolute path at: 3) = 'zonk'. ! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:42'! testCommaAddsExtension | ref result | ref := filesystem * 'plonk'. result := ref, 'griffle'. self assert: result basename = 'plonk.griffle'! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/23/2012 00:19'! testWriteStreamDo | ref s | ref := filesystem / 'plonk'. ref writeStreamDo: [:stream | s := stream. self deny: stream isNil ]. ! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:25'! testChildren | ref children | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. filesystem createDirectory: '/alpha/gamma'. ref := filesystem / 'alpha'. children := ref children. self assert: children size = 2. children do: [:child | self assert: child class = FileReference. self assert: (child isChildOf: ref). self assert: (#('beta' 'gamma') includes: child basename)]! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/23/2012 00:17'! testWriteStream | ref stream | ref := filesystem / 'plonk'. [stream := ref writeStream.] ensure: [stream ifNotNil: [stream close]]! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:44'! testAsAbsoluteConverted "Converts a relative reference to absolute, and asserts that it's absolute and still has the same path." | ref absolute | ref := filesystem * 'plonk'. absolute := ref asAbsolute. self assert: absolute isAbsolute. self assert: (absolute path at: 1) = 'plonk'! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/22/2012 18:22'! testBasenameWithoutExtension "self debug: #testBasenameWithoutExtension" | ref | ref := filesystem root. self assert: ref basename = '/'. ref := filesystem * 'plonk' / 'griffle'. self assert: ref basenameWithoutExtension = 'griffle'. ref := filesystem * 'plonk' / 'griffle.taz'. self assert: ref basenameWithoutExtension = 'griffle'. ref := filesystem * 'plonk' / 'griffle.taz.zork'. self assert: ref basenameWithoutExtension = 'griffle.taz'.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 13:18'! testDoesntContainReferenceFileSystem | ref other | ref := filesystem * 'griffle'. other := FileSystem memory / 'griffle' / 'nurp'. self deny: (ref contains: other)! ! !FileReferenceTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:24'! testHasDirectories "self debug: #testHasDirectories" | ref children | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. (filesystem / 'alpha' / 'beta' / 'delta') ensureCreateFile. filesystem createDirectory: '/alpha/gamma'. ref := filesystem / 'alpha'. self assert: ref hasDirectories. self deny: (ref / 'beta') hasDirectories. self deny: (ref / 'beta' / 'gamma') hasDirectories.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:31'! testSlash | ref result | ref := filesystem * 'plonk'. result := ref / 'griffle'. self assert: result class = ref class. self assert: result isRelative. self assert: (result path at: 1) = 'plonk'. self assert: (result path at: 2) = 'griffle'. ! ! !FileReferenceTest methodsFor: 'tests' stamp: 'StephaneDucasse 6/17/2012 19:17'! testDeleteAll "allChildren returns all the files and folders recursively nested in a reference" "self debug: #testDeleteAll" | ref children | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. filesystem createDirectory: '/alpha/beta/delta'. filesystem createDirectory: '/alpha/gamma'. ref := filesystem / 'alpha'. ref deleteAll. self deny: ref exists. self deny: (ref / 'beta') exists. self deny: (ref / 'beta' / 'delta') exists. self deny: (ref / 'beta' / 'gamma') exists.! ! !FileReferenceTest methodsFor: 'support' stamp: 'S 6/17/2013 13:33'! createFile: aPath filesystem ensureCreateDirectory: aPath parent. (filesystem writeStreamOn: aPath) close! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testChildOfPath | parent child | parent := Path / 'griffle'. child := filesystem / 'griffle' / 'nurb'. self deny: (child isChildOf: parent). self deny: (parent isChildOf: child).! ! !FileReferenceTest methodsFor: 'tests stream' stamp: 'EstebanLorenzano 4/2/2012 11:41'! testReadStreamDoNotFound | ref | ref := filesystem / 'plonk'. self should: [ref readStreamDo: [:s]] raise: FileDoesNotExist ! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/23/2012 00:18'! testReadStreamDoifAbsent | ref path s | path := Path * 'plonk'. filesystem store createFile: path. ref := filesystem referenceTo: path. ref readStreamDo: [ :stream | self deny: stream isNil. s := stream ] ifAbsent: [ self signalFailure: 'The file exists!!' ].! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRelativeToReference | parent child relative | parent := filesystem / 'griffle'. child := filesystem / 'griffle' / 'plonk' / 'nurb'. relative := child relativeTo: parent. self assert: relative = (Path * 'plonk' / 'nurb')! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:46'! testUnequalContent | a b | a := filesystem * 'plonk'. b := filesystem * 'griffle'. self deny: a = b.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:26'! testRename | file newName tmp originalPwd originalFullName | [ file := (FileLocator imageDirectory / 'oldName') ensureCreateFile. originalFullName := file fullName. tmp := (FileLocator imageDirectory / 'tmp') ensureCreateDirectory. originalPwd := FileSystem disk workingDirectory. file renameTo: 'newName'. self deny: originalFullName asFileReference exists. self assert: file basename equals: 'newName'. self assert: (originalFullName asFileReference parent / 'newName') exists ] ensure: [ file delete. tmp deleteAll. ].! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:50'! testContainsPath | ref | ref := filesystem * 'griffle'. self assert: (ref contains: (ref / 'nurp') path)! ! !FileReferenceTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:24'! testHasFiles "self debug: #testHasFiles" | ref children | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. (filesystem / 'alpha' / 'beta' / 'delta') ensureCreateFile. filesystem createDirectory: '/alpha/beta/eta'. filesystem createDirectory: '/alpha/gamma'. ref := filesystem / 'alpha'. self deny: ref hasFiles. self assert: (ref / 'beta') hasFiles. self deny: (ref / 'beta' / 'gamma') hasFiles.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:49'! testIsNotRoot self deny: (filesystem / 'plonk') isRoot! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:24'! testWithExtentionReplacesExtension | ref result | ref := filesystem * 'plonk.griffle'. result := ref withExtension: 'nurp'. self assert: result isRelative. self assert: result basename = 'plonk.nurp'! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:25'! testChildDirectories | childDirectories | filesystem createDirectory: '/beta'. filesystem createDirectory: '/gamma'. (filesystem / 'delta') writeStreamDo: [ :stream | stream nextPutAll: '1' ]. (filesystem / 'epsilon') writeStreamDo: [ :stream | stream nextPutAll: '2' ]. childDirectories := filesystem root directories. self assert: childDirectories size = 2. childDirectories do: [ :each | self assert: each class = FileReference. self assert: each isDirectory description: 'Collection should not contain references to files.' ]! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:48'! testParent | ref parent | ref := filesystem * 'plonk' / 'griffle'. parent := ref parent. self assert: parent class = ref class. self assert: (parent path at: 1) = 'plonk'! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:42'! testChildOfReference | parent child | parent := filesystem / 'griffle'. child := filesystem / 'griffle' / 'nurb'. self assert: (child isChildOf: parent). self deny: (parent isChildOf: child).! ! !FileReferenceTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:24'! testRenameTargetExists | existingFile fileToRename | [ existingFile := 'existingFile' asFileReference ensureCreateFile. fileToRename := 'fileToRename' asFileReference ensureCreateFile. self should: [ fileToRename renameTo: existingFile basename ] raise: FileExists ] ensure: [ existingFile delete. fileToRename delete ].! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:42'! testEqual | a b | a := filesystem * 'plonk'. b := filesystem * 'plonk'. self deny: a == b. self assert: a = b.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/28/2012 00:13'! testBaseAndExtension "self debug: #testBaseAndExtension" | noExtension simpleExtension complexExtension | noExtension := filesystem * 'plonk'. self assert: noExtension extension equals: ''. "We create a reference to the plonk/griffle.taz in the context of filesystem" simpleExtension := filesystem * 'plonk' / 'griffle.taz'. self assert: simpleExtension base = 'griffle'. self assert: simpleExtension extension = 'taz'. "Note that the extension of a complex extension starts after the last extension delimiter" complexExtension := filesystem * 'plonk' / 'griffle.taz.txt'. self assert: complexExtension base equals: 'griffle'. self assert: complexExtension extension equals: 'txt'.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/23/2012 00:14'! testWriteStreamExists | ref stream path | path := Path * 'plonk'. filesystem store createFile: path. ref := filesystem referenceTo: path. [stream := ref writeStream ] ensure: [ stream ifNotNil: [ stream close ] ]! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testWorkingDirectoryParent | wd | wd := filesystem referenceTo: Path workingDirectory. self assert: wd parent path size = 1. self assert: (wd parent path at: 1) = '..'.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:49'! testDoesntContainReferencePath | ref other | ref := filesystem * 'griffle'. other := filesystem * 'nurp'. self deny: (ref contains: other)! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:41'! testIndicator "self debug: #testIndicator" | ref | ref := filesystem * 'plonk' / 'griffle'. self deny: ref exists. self assert: ref indicator = '?'. ref := filesystem workingDirectory / 'plonk'. self deny: ref exists. [ref createDirectory. self assert: ref exists. self assert: ref isDirectory. self assert: ref indicator equals: '/' ] ensure: [ref delete]. ref := filesystem workingDirectory / 'plonk'. self deny: ref exists. [ref writeStreamDo: [:stream | stream nextPutAll: 'foo' ] ifPresent: [self fail]. self assert: ref exists. self assert: ref isFile. self assert: ref indicator equals: '' ] ensure: [ref delete].! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 13:09'! testParentResolutionWithAbsoluteReference | base relative absolute | base := (filesystem / '/plonk' / 'pinto'). relative := (FileSystem memory / 'griffle' / 'zonk'). absolute := base resolve: relative. self assert: absolute fileSystem == relative fileSystem. self assert: absolute isAbsolute. self assert: (absolute path at: 1) = 'griffle'. self assert: (absolute path at: 2) = 'zonk'. ! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:47'! testReadStreamDoifAbsentNot | ref pass | pass := false. ref := filesystem * 'plonk'. ref readStreamDo: [:stream] ifAbsent: [pass := true]. self assert: pass! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:31'! testIsNotRelative self deny: (filesystem / 'plonk') isRelative! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:43'! testEntries | ref entries | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. filesystem createDirectory: '/alpha/gamma'. ref := filesystem / 'alpha'. entries := ref entries. self assert: entries size = 2. entries do: [:entry | self assert: entry class = FileSystemDirectoryEntry. self assert: (entry reference isChildOf: ref). self assert: (#('beta' 'gamma') includes: entry reference basename)]! ! !FileReferenceTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:24'! testExists | reference | reference := filesystem / 'plonk'. reference ensureCreateFile. self assert: reference exists. reference delete. self deny: reference exists. ! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:49'! testIsRoot self assert: (filesystem root) isRoot! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:48'! testParentResolutionWithReference | base relative absolute | base := (filesystem / 'plonk' / 'pinto'). relative := (filesystem referenceTo: '../griffle/zonk'). absolute := base resolve: relative. self assert: absolute isAbsolute. self assert: (absolute path at: 1) = 'plonk'. self assert: (absolute path at: 2) = 'griffle'. self assert: (absolute path at: 3) = 'zonk'. ! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:43'! testParentResolutionWithRemoteReference | base relative absolute | base := (filesystem / 'plonk' / 'pinto'). relative := (FileSystem memory referenceTo: '../griffle/zonk'). absolute := base resolve: relative. self assert: absolute isAbsolute. self assert: (absolute path at: 1) = 'plonk'. self assert: (absolute path at: 2) = 'griffle'. self assert: (absolute path at: 3) = 'zonk'. ! ! !FileReferenceTest methodsFor: 'tests' stamp: 'MarcusDenker 9/12/2013 14:48'! testEnsureDelete | reference | reference := filesystem / 'plonk'. "Deletes the file if it exists" reference ensureCreateFile. self assert: reference exists. reference ensureDelete. self deny: reference exists. "No-op if file does not exist" reference ensureDelete! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testWriteStreamDoifPresentNot | ref pass path | pass := false. path := Path * 'plonk'. filesystem store createFile: path. ref := filesystem referenceTo: path. ref writeStreamDo: [ :stream | ] ifPresent: [ pass := true ]. self assert: pass! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testParentResolutionWithPath | base relative absolute | base := filesystem / 'plonk' / 'pinto'. relative := Path parent / 'griffle' / 'zonk'. absolute := base resolve: relative. self assert: absolute isAbsolute. self assert: (absolute path at: 1) = 'plonk'. self assert: (absolute path at: 2) = 'griffle'. self assert: (absolute path at: 3) = 'zonk'. ! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:41'! testIsAbsolute self assert: (filesystem / 'plonk') isAbsolute! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testMakeRelative "self run: #testMakeRelative" | parent child relative | parent := filesystem / 'griffle'. child := filesystem / 'griffle' / 'plonk' / 'nurb'. relative := parent makeRelative: child. self assert: relative = (Path * 'plonk' / 'nurb')! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/23/2012 00:19'! testWriteStreamDoExists | ref s path | path := Path * 'plonk'. filesystem store createFile: path. ref := filesystem referenceTo: path. ref writeStreamDo: [ :stream | s := stream. self deny: stream isNil ].! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:42'! testCommaAddsExtensionAgain | ref result | ref := filesystem * 'plonk.griffle'. result := ref, 'nurp'. self assert: result basename = 'plonk.griffle.nurp'! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:46'! testSiblingOfReference | griffle nurb | griffle := filesystem / 'griffle'. nurb := filesystem / 'nurb'. self deny: (griffle isChildOf: nurb). self deny: (nurb isChildOf: griffle).! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testWriteStreamifPresentExists | ref pass path | pass := false. path := Path * 'plonk'. filesystem store createFile: path. ref := filesystem referenceTo: path. ref writeStreamIfPresent: [ pass := true ]. self assert: pass! ! !FileReferenceTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:24'! testDeleteIfAbsent | flag reference | flag := false. reference := filesystem / 'plonk'. reference ensureCreateFile. reference exists ifFalse: [self error]. reference deleteIfAbsent: [flag := true]. self deny: flag. reference exists ifTrue: [self error]. reference deleteIfAbsent: [flag := true]. self assert: flag.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:43'! testBasename "self debug: #testBasename" | ref | ref := filesystem root. self assert: ref basename = '/'. ref := filesystem * 'plonk' / 'griffle'. self assert: ref basename = 'griffle'. ref := filesystem * 'plonk' / 'griffle.taz'. self assert: ref basename = 'griffle.taz'.! ! !FileReferenceTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/2/2012 11:43'! setUp filesystem := FileSystem memory.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:31'! testWithExtentionAddsExtension | ref result | ref := filesystem * 'plonk'. result := ref withExtension: 'griffle'. self assert: result isRelative. self assert: result basename = 'plonk.griffle'! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRelativeToPath | parentPath child relative | parentPath := Path / 'griffle'. child := filesystem / 'griffle' / 'plonk' / 'nurb'. relative := child relativeTo: parentPath. self assert: relative = (Path * 'plonk' / 'nurb')! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/9/2011 16:12'! testGlob | ref children | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. filesystem createDirectory: '/alpha/gamma'. ref := filesystem root. children := ref glob: [ :node| true]. self assert: children size == 4. "including root" children := ref glob: [ :node| node basename size > 1]. self assert: children size == 3. "without root" children := ref glob: [ :node| node basename = #gamma]. self assert: children size == 1. "gamma" self assert: children first basename = #gamma.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:25'! testChildFiles | childFiles | filesystem createDirectory: '/beta'. filesystem createDirectory: '/gamma'. (filesystem / 'delta') writeStreamDo: [ :stream | stream nextPutAll: '1' ]. (filesystem / 'epsilon') writeStreamDo: [ :stream | stream nextPutAll: '2' ]. childFiles := filesystem root files. self assert: childFiles size = 2. childFiles do: [ :each | self assert: each class = FileReference. self assert: each isFile description: 'Collection should not contain references to directories.' ]! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:49'! testContainsReference | ref | ref := filesystem * 'griffle'. self assert: (ref contains: ref / 'nurp')! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testDoesntContainPath | ref | ref := filesystem * 'griffle'. self deny: (ref contains: (Path * 'nurp'))! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:28'! testAsReference | ref | ref := filesystem * 'plonk'. self assert: ref asFileReference == ref! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/23/2012 00:15'! testReadStream | ref stream path | path := Path * 'plonk'. filesystem store createFile: path. ref := filesystem referenceTo: path. [stream := ref readStream. ] ensure: [ stream ifNotNil: [ stream close ] ]! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 6/23/2012 00:18'! testReadStreamDo | ref path s | path := Path * 'plonk'. filesystem store createFile: path. ref := filesystem referenceTo: path. ref readStreamDo: [ :stream | self deny: stream isNil. s := stream ].! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:46'! testUnequalSize | a b | a := filesystem * 'plonk'. b := filesystem / 'plonk' / 'griffle'. self deny: a = b.! ! !FileServices commentStamp: 'TorstenBergmann 2/4/2014 20:23'! Registered file services for specific file types! !FileServices class methodsFor: 'removing' stamp: 'StephaneDucasse 9/9/2010 09:50'! removeObsolete "FileServices removeObsolete" self registeredFileReaderClasses copy do: [:cls| cls isObsolete ifTrue:[self unregisterFileReader: cls]]! ! !FileServices class methodsFor: 'initialize-release' stamp: 'StephaneDucasse 9/9/2010 09:49'! initialize "FileServices initialize" Smalltalk globals allClassesDo: [ :aClass | (aClass class includesSelector: #fileReaderServicesForFile:suffix:) ifTrue: [self registerFileReader: aClass]].! ! !FileServices class methodsFor: 'testing' stamp: 'CamilloBruni 2/3/2013 17:19'! isReaderNamedRegistered: aSymbol "return if a given reader class has been registered. Note that this is on purpose that the argument is a symbol and not a class" ^ self registeredFileReaderClasses anySatisfy: [:each | each name = aSymbol ] ! ! !FileServices class methodsFor: 'helper' stamp: 'CamilloBruni 5/4/2012 20:10'! suffixOf: aName "Answer the file extension of the given file" ^ aName ifNil: [''] ifNotNil: [ aName asFileReference extension asLowercase]! ! !FileServices class methodsFor: 'adding' stamp: 'ar 7/16/2005 17:00'! registerFileReader: aProviderClass "register the given class as providing services for reading files" | registeredReaders | registeredReaders := self registeredFileReaderClasses. (registeredReaders includes: aProviderClass) ifFalse: [ registeredReaders addLast: aProviderClass ]! ! !FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'! itemsForFile: fullName "Answer a list of services appropriate for a file of the given full name" | services suffix | suffix := self suffixOf: fullName. services := OrderedCollection new. self registeredFileReaderClasses do: [:reader | reader ifNotNil: [services addAll: (reader fileReaderServicesForFile: fullName suffix: suffix)]]. ^ services! ! !FileServices class methodsFor: 'accessing' stamp: 'ar 7/16/2005 17:00'! itemsForDirectory: aFileDirectory "Answer a list of services appropriate when no file is selected." | services | services := OrderedCollection new. self registeredFileReaderClasses do: [:reader | reader ifNotNil: [services addAll: (reader fileReaderServicesForDirectory: aFileDirectory) ]]. ^ services! ! !FileServices class methodsFor: 'adding' stamp: 'ar 7/16/2005 16:59'! registeredFileReaderClasses FileReaderRegistry ifNil: [FileReaderRegistry := OrderedCollection new]. ^ FileReaderRegistry! ! !FileServices class methodsFor: 'removing' stamp: 'ar 7/16/2005 17:00'! unregisterFileReader: aProviderClass "unregister the given class as providing services for reading files" self registeredFileReaderClasses remove: aProviderClass ifAbsent: [nil]! ! !FileServices class methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2013 17:20'! allRegisteredServices "self allRegisteredServices" | allServices | allServices := OrderedCollection new. self registeredFileReaderClasses do: [:each | allServices addAll: (each services)]. ^ allServices! ! !FileServices class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:31'! cleanUp "Remove obsolete services" self removeObsolete! ! !FileStream commentStamp: ''! I represent a Stream that accesses a FilePage from a File. One use for my instance is to access larger "virtual Strings" than can be stored contiguously in main memory. I restrict the objects stored and retrieved to be Integers or Characters. An end of file pointer terminates reading; it can be extended by writing past it, or the file can be explicitly truncated. To use the file system for most applications, you typically create a FileStream. This is done by sending a message to a FileDirectory (file:, oldFile:, newFile:, rename:newName:) which creates an instance of me. Accesses to the file are then done via my instance. *** On DOS, files cannot be shortened!! *** To overwrite a file with a shorter one, first delete the old file (FileDirectory deleteFilePath: 'Hard Disk:aFolder:dataFolder:foo') or (aFileDirectory deleteFileNamed: 'foo'). Then write your new shorter version.! !FileStream methodsFor: 'file accessing' stamp: 'CamilloBruni 8/1/2012 16:05'! file "Answer the file for the page the receiver is streaming over." self subclassResponsibility! ! !FileStream methodsFor: 'positioning' stamp: 'CamilloBruni 8/1/2012 16:16'! skip: n "Set the character position to n characters from the current position. Error if not enough characters left in the file." self subclassResponsibility! ! !FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 12:59'! binary "Set this file to binary mode." self subclassResponsibility ! ! !FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:02'! close "Close this file." self subclassResponsibility ! ! !FileStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'! next (position >= readLimit and: [self atEnd]) ifTrue: [^nil] ifFalse: [^collection at: (position := position + 1)]! ! !FileStream methodsFor: 'positioning' stamp: 'CamilloBruni 8/1/2012 16:13'! position: pos "Set the current character position in the file to pos." self subclassResponsibility! ! !FileStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'! contentsOfEntireFile "Read all of the contents of the receiver." | s binary | self readOnly. binary := self isBinary. self reset. "erases knowledge of whether it is binary" binary ifTrue: [self binary]. s := self next: self size. self close. ^s! ! !FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:01'! text "Set this file to text (ascii) mode." self ascii. ! ! !FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:04'! reopen "Ensure that the receiver is open, re-open it if necessary." "Details: Files that were open when a snapshot occurs are no longer valid when the snapshot is resumed. This operation re-opens the file if that has happened." self subclassResponsibility ! ! !FileStream methodsFor: 'positioning' stamp: 'JMM 5/24/2001 22:58'! truncate: pos "Truncate file to pos" self subclassResponsibility! ! !FileStream methodsFor: '*zinc-resource-meta-core' stamp: 'SvenVanCaekenberghe 10/25/2013 16:48'! asZnUrl "Convert the receiver in a file:// ZnUrl" | fileUrl | fileUrl := ZnUrl new. fileUrl scheme: #file. self directory pathSegments do: [ :each | fileUrl addPathSegment: each ]. fileUrl addPathSegment: self localName. ^ fileUrl! ! !FileStream methodsFor: 'printing' stamp: ''! printOn: aStream super printOn: aStream. aStream nextPutAll: ' on '. self file printOn: aStream! ! !FileStream methodsFor: 'accessing' stamp: 'CamilloBruni 5/23/2012 16:55'! mimeTypes ^ self name asFileReference mimeTypes.! ! !FileStream methodsFor: 'accessing' stamp: ''! nextPutAll: aCollection "1/31/96 sw: made subclass responsibility" self subclassResponsibility! ! !FileStream methodsFor: 'printing' stamp: 'tk 12/5/2001 09:12'! longPrintOn: aStream "Do nothing, so it will print short. Called to print the error file. If the error was in a file operation, we can't read the contents of that file. Just print its name instead." ! ! !FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:00'! readWrite "Set this file's mode to read-write." self subclassResponsibility ! ! !FileStream methodsFor: 'positioning' stamp: 'CamilloBruni 8/1/2012 16:16'! setToEnd "Set the current character position to the end of the File. The same as self position: self size." self subclassResponsibility! ! !FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:01'! ascii "Set this file to ascii (text) mode." self subclassResponsibility ! ! !FileStream methodsFor: '*System-Changes' stamp: 'StephaneDucasse 3/23/2010 22:42'! fileIntoNewChangeSet "File all of my contents into a new change set." self readOnly. ChangeSet newChangesFromStream: self named: (self localName) ! ! !FileStream methodsFor: '*Compression' stamp: 'MarcusDenker 1/19/2011 15:43'! viewGZipContents "View the contents of a gzipped file" | stringContents | self binary. stringContents := self contentsOfEntireFile. stringContents := Cursor wait showWhile: [(GZipReadStream on: stringContents) upToEnd]. stringContents := stringContents asString withSqueakLineEndings. UIManager default edit: stringContents label: 'Decompressed contents of: ', self localName! ! !FileStream methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:16'! size "Answer the size of the file in characters." self subclassResponsibility! ! !FileStream methodsFor: 'file accessing' stamp: 'CamilloBruni 5/7/2012 02:09'! localName ^ self name asFileReference basename ! ! !FileStream methodsFor: 'testing' stamp: 'CamilloBruni 8/1/2012 16:00'! atEnd "Answer true if the current position is >= the end of file position." self subclassResponsibility! ! !FileStream methodsFor: 'accessing' stamp: ''! nextPut: aByte "1/31/96 sw: subclassResponsibility" self subclassResponsibility! ! !FileStream methodsFor: '*Tools' stamp: 'IgorStasenko 3/6/2011 18:52'! edit "Create and schedule an editor on this file." Smalltalk tools fileList openEditorOn: self editString: nil. ! ! !FileStream methodsFor: 'accessing' stamp: 'abc 5/11/2012 23:29'! directoryEntry ^(self directory / self localName) entry! ! !FileStream methodsFor: 'positioning' stamp: 'CamilloBruni 8/1/2012 16:15'! reset "Set the current character position to the beginning of the file." self subclassResponsibility! ! !FileStream methodsFor: 'accessing' stamp: 'nice 11/22/2009 18:11'! next: anInteger | newCollection howManyRead increment | newCollection := self collectionSpecies new: anInteger. howManyRead := 0. [howManyRead < anInteger] whileTrue: [self atEnd ifTrue: [(howManyRead + 1) to: anInteger do: [:i | newCollection at: i put: (self next)]. ^newCollection]. increment := (readLimit - position) min: (anInteger - howManyRead). newCollection replaceFrom: (howManyRead + 1) to: (howManyRead := howManyRead + increment) with: collection startingAt: (position + 1). position := position + increment]. ^newCollection! ! !FileStream methodsFor: '*Network-Url' stamp: 'fbs 2/2/2005 13:23'! url "Convert my path into a file:// type url String." ^self asUrl asString! ! !FileStream methodsFor: '*Network-Url' stamp: 'SvenVanCaekenberghe 10/25/2013 17:04'! asUrl ^ self asZnUrl ! ! !FileStream methodsFor: 'file modes' stamp: 'mir 8/24/2004 17:58'! readOnlyStream ^self readOnly! ! !FileStream methodsFor: 'printing' stamp: 'tk 12/5/2001 09:32'! longPrintOn: aStream limitedTo: sizeLimit indent: indent "Do nothing, so it will print short. Called to print the error file. If the error was in a file operation, we can't read the contents of that file. Just print its name instead." aStream cr! ! !FileStream methodsFor: 'positioning' stamp: 'CamilloBruni 8/1/2012 16:12'! position "Answer the current character position in the file." self subclassResponsibility! ! !FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:03'! flush "When writing, flush the current buffer out to disk." self subclassResponsibility ! ! !FileStream methodsFor: '*codeimport' stamp: 'GuillermoPolito 5/5/2012 19:34'! fileIn "Guarantee that the receiver is readOnly before fileIn for efficiency and to eliminate remote sharing conflicts." self readOnly. CodeImporter evaluateFileStream: self.! ! !FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 12:59'! readOnly "Set this file's mode to read-only." self subclassResponsibility ! ! !FileStream methodsFor: 'converting' stamp: 'tk 2/4/2000 09:16'! asBinaryOrTextStream "I can switch between binary and text data" ^ self! ! !FileStream methodsFor: 'file accessing' stamp: 'CamilloBruni 8/1/2012 16:11'! name "Answer the name of the file for the page the receiver is streaming over." self subclassResponsibility! ! !FileStream methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:31'! contents "Return the contents of the receiver. Do not close or otherwise touch the receiver. Return data in whatever mode the receiver is in (e.g., binary or text)." | s savePos | savePos := self position. self position: 0. s := self next: self size. self position: savePos. ^s! ! !FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:02'! closed "Answer true if this file is closed." self subclassResponsibility ! ! !FileStream class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/4/2012 21:11'! fullName: fileName ^ fileName asFileReference fullName ! ! !FileStream class methodsFor: 'file reader services' stamp: 'stephaneducasse 2/4/2006 20:32'! removeLineFeeds: fullName | fileContents | fileContents := ((FileStream readOnlyFileNamed: fullName) wantsLineEndConversion: true) contentsOfEntireFile. (FileStream newFileNamed: fullName) nextPutAll: fileContents; close.! ! !FileStream class methodsFor: 'instance creation' stamp: 'VeronicaUquillas 6/11/2010 14:52'! oldFileNamed: fileName do: aBlock "Returns the result of aBlock." ^ self detectFile: [ self oldFileNamed: fileName ] do: aBlock! ! !FileStream class methodsFor: 'instance creation' stamp: ''! newFileNamed: fileName ^ self concreteStream newFileNamed: (self fullName: fileName)! ! !FileStream class methodsFor: 'concrete classes' stamp: 'yo 7/5/2004 20:18'! concreteStream "Who should we really direct class queries to? " ^ MultiByteFileStream. ! ! !FileStream class methodsFor: '*Tools-FileList' stamp: 'tbn 8/11/2010 10:33'! serviceRemoveLineFeeds "Answer a service for removing linefeeds from a file" ^ FileModifyingSimpleServiceEntry provider: self label: 'Remove line feeds' selector: #removeLineFeeds: description: 'Remove line feeds in file' buttonLabel: 'Remove lfs'! ! !FileStream class methodsFor: 'instance creation' stamp: 'tpr 10/16/2001 12:49'! forceNewFileNamed: fileName "Create a new file with the given name, and answer a stream opened for writing on that file. If the file already exists, delete it without asking before creating the new file." ^self concreteStream forceNewFileNamed: fileName! ! !FileStream class methodsFor: '*Tools-FileList' stamp: 'sd 2/1/2002 22:28'! services ^ Array with: self serviceRemoveLineFeeds with: self serviceFileIn ! ! !FileStream class methodsFor: 'initialize-release' stamp: 'CamilloBruni 5/9/2012 12:07'! initialize TheStdioHandles := Array new: 3. "original comment was: the intent being before: AutoStart" Smalltalk addToStartUpList: self after: DiskStore; addToShutDownList: self after: DiskStore! ! !FileStream class methodsFor: 'instance creation' stamp: 'VeronicaUquillas 6/11/2010 14:52'! fileNamed: fileName do: aBlock "Returns the result of aBlock." ^ self detectFile: [ self fileNamed: fileName ] do: aBlock! ! !FileStream class methodsFor: 'instance creation' stamp: ''! readOnlyFileNamed: fileName ^ self concreteStream readOnlyFileNamed: (self fullName: fileName)! ! !FileStream class methodsFor: '*FileSystem-Core' stamp: 'abc 5/11/2012 23:23'! onHandle: aFileSystemHandle ^ self concreteStream new open: aFileSystemHandle fullName forWrite: aFileSystemHandle isWritable! ! !FileStream class methodsFor: 'stdio' stamp: 'StephaneDucasse 5/18/2011 23:19'! stdioHandles self primitiveFailed! ! !FileStream class methodsFor: 'file reader services' stamp: 'MarcusDenker 2/14/2010 09:35'! sourceFileSuffixes ^#('st' 'cs') ! ! !FileStream class methodsFor: 'initialize-release' stamp: 'GabrielOmarCotelli 6/4/2009 20:36'! unload FileServices unregisterFileReader: self ! ! !FileStream class methodsFor: 'stdio' stamp: 'StephaneDucasse 5/18/2011 23:13'! flushAndVoidStdioFiles StdioFiles ifNotNil: [ StdioFiles do: [ :file | file ifNotNil: [ file isReadOnly ifFalse: [ [ file flush ] on: Error do: [ :ex | "care less" ] ] ] ]. self voidStdioFiles ]! ! !FileStream class methodsFor: 'dnd requests' stamp: 'VeronicaUquillas 6/11/2010 14:52'! requestDropStream: dropIndex "Request a read-only stream for some file that was dropped onto the application" ^self concreteStream new requestDropStream: dropIndex.! ! !FileStream class methodsFor: 'file reader services' stamp: 'tpr 9/15/2005 15:06'! isSourceFileSuffix: suffix ^ FileStream sourceFileSuffixes includes: suffix ! ! !FileStream class methodsFor: 'system startup' stamp: 'StephaneDucasse 5/18/2011 23:19'! startUp: resuming resuming ifTrue: [ self voidStdioFiles. [ TheStdioHandles := self stdioHandles ] on: Error do: [:ex| TheStdioHandles isArray ifFalse: [ TheStdioHandles := Array new: 3 ] ] ]! ! !FileStream class methodsFor: 'file reader services' stamp: 'AlejandroInfante 11/11/2013 14:54'! fileIn: fullName "File in the entire contents of the file specified by the name provided" | ff fn | fullName ifNil: [^ self inform: 'Filename is nil.']. fn := fullName asFileReference. fn := (Smalltalk hasClassNamed: #GZipReadStream) ifTrue: [(Smalltalk classNamed: #GZipReadStream) uncompressedFileName: fn fullName] ifFalse: [fn fullName]. ff := self readOnlyFileNamed: fn. ff fileIn. ! ! !FileStream class methodsFor: '*Tools-FileList' stamp: 'CamilloBruni 2/3/2013 17:21'! fileReaderServicesForFile: fullName suffix: suffix "Answer services for the given file" ^ ((self isSourceFileSuffix: suffix) or: [ suffix = '*' ]) ifTrue: [{self serviceRemoveLineFeeds. self serviceFileIn}] ifFalse: [#()]! ! !FileStream class methodsFor: 'instance creation' stamp: ''! oldFileNamed: fileName ^ self concreteStream oldFileNamed: (self fullName: fileName)! ! !FileStream class methodsFor: 'stdio' stamp: 'SeanDeNigris 5/3/2012 22:37'! stdin ^Stdin ifNil: [ Stdin := self standardIOStreamNamed: #stdin forWrite: false. Stdin disableReadBuffering; yourself ].! ! !FileStream class methodsFor: 'instance creation' stamp: 'VeronicaUquillas 6/11/2010 14:52'! newFileNamed: fileName do: aBlock "Returns the result of aBlock." ^ self detectFile: [ self newFileNamed: fileName ] do: aBlock! ! !FileStream class methodsFor: 'instance creation' stamp: 'StephaneDucasse 2/2/2010 21:46'! readOnlyFileNamed: fileName do: aBlock "Open the existing file with the given name for read-only access and pass it as argument to aBlock. Returns the result of aBlock." ^ self detectFile: [ self readOnlyFileNamed: fileName ] do: aBlock! ! !FileStream class methodsFor: 'instance creation' stamp: 'TPR 8/26/1999 10:49'! isAFileNamed: fName "return whether a file exists with the given name" ^self concreteStream isAFileNamed: (self fullName: fName)! ! !FileStream class methodsFor: 'stdio' stamp: 'StephaneDucasse 5/18/2011 23:20'! voidStdioFiles Stdin := Stdout := Stderr := StdioFiles := nil! ! !FileStream class methodsFor: 'stdio' stamp: 'cami 7/22/2013 18:26'! standardIOStreamNamed: moniker forWrite: forWrite "Create if necessary and store default stdin, stdout and other files based on the their names" | index | self flag: #todo. "This is an ugly hack, while waiting for a real fix for windows. There several problems with this approach, but it allow us to run tests, etc." Smalltalk os isWin32 ifTrue: [ [ ^ MultiByteFileStream forceNewFileNamed: moniker asString ] on: CannotDeleteFileException do: [ "HACK: if the image is opened a second time windows barks about the already opened locked file" ^ MultiByteFileStream forceNewFileNamed: moniker asString, '_', (Random new nextInt: SmallInteger maxVal) asString ]]. index := #(stdin stdout stderr) identityIndexOf: moniker. ^((StdioFiles ifNil: [ StdioFiles := Array new: 3 ]) at: index) ifNil: [ StdioFiles at: index put: ( (TheStdioHandles at: index) ifNil: [ ^self error: moniker, ' is unavailable' ] ifNotNil: [ :handle | MultiByteFileStream newForStdio openOnHandle: handle name: moniker forWrite: forWrite ]) ] ! ! !FileStream class methodsFor: 'instance creation' stamp: 'StephaneDucasse 8/21/2010 22:50'! oldFileOrNoneNamed: fileName "If the file exists, answer a read-only FileStream on it. If it doesn't, answer nil." | fullName | fullName := self fullName: fileName. ^ (self concreteStream isAFileNamed: fullName) ifTrue: [ self concreteStream readOnlyFileNamed: fullName] ifFalse: [ nil]. ! ! !FileStream class methodsFor: 'instance creation' stamp: 'StephaneDucasse 8/3/2010 18:23'! detectFile: aBlock do: anotherBlock ^aBlock value ifNil: [nil] ifNotNil: [:file| [anotherBlock value: file] ensure: [file close]]! ! !FileStream class methodsFor: 'utils' stamp: 'stephane.ducasse 7/10/2009 16:30'! convertCRtoLF: fileName "Convert the given file to LF line endings. Put the result in a file with the extention '.lf'" | in out c justPutCR | in := (self readOnlyFileNamed: fileName) binary. out := (self newFileNamed: fileName, '.lf') binary. justPutCR := false. [in atEnd] whileFalse: [ c := in next. c = 10 ifTrue: [ out nextPut: 13. justPutCR := true] ifFalse: [ (justPutCR and: [c = 10]) ifFalse: [out nextPut: c]. justPutCR := false]]. in close. out close. ! ! !FileStream class methodsFor: 'stdio' stamp: 'StephaneDucasse 5/18/2011 23:15'! newForStdio "This is a hook for subclasses to initialize themselves properly." ^self new! ! !FileStream class methodsFor: 'file reader services' stamp: 'CamilloBruni 5/10/2012 16:09'! writeSourceCodeFrom: aStream baseName: baseName isSt: stOrCsFlag | extension converter fileName | extension := stOrCsFlag ifTrue: ['.st'] ifFalse: ['.cs']. converter := aStream contents isAsciiString ifTrue: [MacRomanTextConverter new] ifFalse: [UTF8TextConverter new]. fileName := baseName, extension. fileName := FileSystem disk checkName: fileName fixErrors: true. [FileStream newFileNamed: fileName do: [:fileStream | (converter isMemberOf: UTF8TextConverter) ifTrue: [fileStream binary. UTF8TextConverter writeBOMOn: fileStream]. fileStream text; converter: converter; nextPutAll: aStream contents; close]] on: Abort do: [:e | ]! ! !FileStream class methodsFor: '*Tools-FileList' stamp: 'tbn 8/11/2010 10:18'! serviceFileIn "Answer a service for filing in an entire file" ^ SimpleServiceEntry provider: self label: 'FileIn entire file' selector: #fileIn: description: 'File in the entire contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' buttonLabel: 'Filein'! ! !FileStream class methodsFor: 'instance creation' stamp: 'di 2/15/98 14:03'! new ^ self basicNew! ! !FileStream class methodsFor: 'system startup' stamp: 'StephaneDucasse 5/18/2011 23:15'! shutDown: quitting quitting ifTrue: [ self flushAndVoidStdioFiles ]! ! !FileStream class methodsFor: 'instance creation' stamp: 'VeronicaUquillas 6/11/2010 14:52'! forceNewFileNamed: fileName do: aBlock "Returns the result of aBlock." ^ self detectFile: [ self forceNewFileNamed: fileName ] do: aBlock! ! !FileStream class methodsFor: 'instance creation' stamp: ''! fileNamed: fileName ^ self concreteStream fileNamed: (self fullName: fileName)! ! !FileStream class methodsFor: 'stdio' stamp: 'StephaneDucasse 5/18/2011 23:19'! stderr ^Stderr ifNil: [ Stderr := self standardIOStreamNamed: #stderr forWrite: true ]! ! !FileStream class methodsFor: 'stdio' stamp: 'StephaneDucasse 5/18/2011 23:20'! stdout ^Stdout ifNil: [ Stdout := self standardIOStreamNamed: #stdout forWrite: true ]! ! !FileStreamException commentStamp: 'TorstenBergmann 2/3/2014 23:36'! Common superclass for exceptions while using file streams! !FileStreamException methodsFor: 'exceptiondescription' stamp: 'mir 2/23/2000 20:14'! messageText "Return an exception's message text." ^messageText == nil ifTrue: [fileName printString] ifFalse: [messageText]! ! !FileStreamException methodsFor: 'exceptionbuilder' stamp: 'mir 2/23/2000 20:13'! fileName: aFileName fileName := aFileName! ! !FileStreamException methodsFor: 'exceptiondescription' stamp: 'mir 2/25/2000 17:29'! fileName ^fileName! ! !FileStreamException methodsFor: 'exceptiondescription' stamp: 'mir 2/23/2000 20:13'! isResumable "Determine whether an exception is resumable." ^true! ! !FileStreamException class methodsFor: 'exceptioninstantiator' stamp: 'mir 2/23/2000 20:12'! fileName: aFileName ^self new fileName: aFileName! ! !FileStreamTest methodsFor: 'testing' stamp: 'S 6/17/2013 13:16'! testDetectFileDo | file | [ file := 'filestream.tst' asFileReference. file writeStreamDo: [ :s | s nextPutAll: '42' ]. FileStream detectFile: [ file readStream ] do: [ :stream | self assert: stream notNil. self deny: stream closed. self assert: stream contentsOfEntireFile = '42']] ensure: [ file ensureDelete ].! ! !FileStreamTest methodsFor: 'testing' stamp: 'HenrikSperreJohansen 3/15/2010 22:34'! testReadIntoStartingAtCountBufferedAll "Tests for correct count and contents when all could be read, some pre-buffered" self doTestsForReading: 5000 intoBufferWithSize: 6000 startingAt: 500 fromFileOfSize: 6000 offsetBy: 200.! ! !FileStreamTest methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2013 17:23'! testCachingNextChunkPut "Ensure that nextChunkPut:/nextChunk works properly on a caching file" | file text read filename | filename := 'testCachingNextChunkPut'. [file := FileStream forceNewFileNamed: filename. text := 'this is a chunkful of text'. file nextChunkPut: text. read := [file position: 0; nextChunkText] valueWithin: 1 seconds onTimeout:['']. self assert: read = text. ] ensure:[ file close. (FileSystem disk workingDirectory / filename) ensureDelete ].! ! !FileStreamTest methodsFor: 'testing' stamp: 'HenrikSperreJohansen 3/15/2010 22:27'! testReadIntoStartingAtCountNotAll "Tests for correct count and contents when not all could be read, and none pre-buffered" self doTestsForReading: 500 intoBufferWithSize: 800 startingAt: 10 fromFileOfSize: 300 offsetBy: 0.! ! !FileStreamTest methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2013 15:24'! testNextChunkOutOfBounds "self debug: #testNextChunkOutOfBounds" "Ensure that nextChunkPut:/nextChunk works properly on a caching file" | file text read filename | filename := 'testNextChunkOutOfBounds'. [file := FileStream forceNewFileNamed: filename. text := 'this is a chunkful of text'. file nextChunkPut: text. read := [file position: 999999; nextChunkText] valueWithin: 1 seconds onTimeout:[nil]. self assert: read = ''. ] ensure: [ file close. (FileSystem disk workingDirectory / filename) ensureDelete ].! ! !FileStreamTest methodsFor: 'testing' stamp: 'HenrikSperreJohansen 3/15/2010 22:29'! testReadIntoStartingAtCountAll "Tests for correct count and contents when all could be read, none pre-buffered" self doTestsForReading: 100 intoBufferWithSize: 400 startingAt: 100 fromFileOfSize: 200 offsetBy: 0. ! ! !FileStreamTest methodsFor: 'testing' stamp: 'HenrikSperreJohansen 3/15/2010 22:48'! testReadIntoStartingAtCountBufferedNotAll "Tests for correct count and contents when all could be read, some pre-buffered" self doTestsForReading: 8000 intoBufferWithSize: 10000 startingAt: 500 fromFileOfSize: 6000 offsetBy: 200.! ! !FileStreamTest methodsFor: 'private' stamp: 'S 6/17/2013 13:16'! doTestsForReading: count intoBufferWithSize: readSize startingAt: startIndex fromFileOfSize: writeSize offsetBy: startOffset "Do the actual assertions for read/write buffers with the given parameters If offset > 0, some elements will be fetched from buffer. If count > writeSize - startOffset, not all will be successfully read." | file filename | filename := 'filestream.tst'. [ |writeBuffer readBuffer bytesRead| writeBuffer := (ByteArray new: writeSize). 0 to: writeSize -1 do: [:ix | writeBuffer at: ix +1 put: (ix \\ 255) + 1]. (StandardFileStream forceNewFileNamed: filename) binary ; nextPutAll: writeBuffer ; close. file := StandardFileStream readOnlyFileNamed: filename. readBuffer := ByteArray new: readSize. startOffset > 0 ifTrue: [file next: startOffset]. bytesRead := file readInto: readBuffer startingAt: startIndex count: count. "Test the count is correct, ie. either read count, or the remaining bytes in write buffer" self assert: ((writeSize - startOffset) min: count) equals: bytesRead. "quick test for total not written" self assert: readSize - bytesRead equals: (readBuffer occurrencesOf: 0). "compare test for readStream and what was in write" 1 to: readSize do: [ : n | |expected| expected := (n between: startIndex and: startIndex + bytesRead -1) ifTrue: [ (writeBuffer at: startOffset + n - startIndex +1) ] ifFalse: [ 0 ]. self assert: expected equals: (readBuffer at: n) ] ] ensure: [ file ifNotNil: [ file close ]. (FileSystem disk workingDirectory / filename) ensureDelete ]! ! !FileStreamTest methodsFor: 'testing' stamp: 'Anonymous 6/17/2013 13:16'! testNextLine | filename lines text | filename := 'filestream.tst'. lines := #('line 1' ' and line 2' '' 'fourth'). text := lines first , String cr , lines second , String crlf , lines third , String lf , lines fourth. [ | file | (StandardFileStream forceNewFileNamed: filename) nextPutAll: text; close. file := StandardFileStream readOnlyFileNamed: filename. lines do: [ :e | self assert: file nextLine = e ]. self assert: file nextLine isNil. file close ] ensure: [ (FileSystem disk workingDirectory / filename) ensureDelete ].! ! !FileStreamTest methodsFor: 'testing' stamp: 'S 6/17/2013 13:16'! testFileTruncation "Ensure that nextChunkPut:/nextChunk works properly on a caching file" "self debug: #testFileTruncation" | file stream | file := 'TruncationTest.txt' asFileReference. [ file writeStreamDo: [ :s | s nextPutAll: '1234567890' ]. file writeStreamDo: [ :s | self assert: s contents equals: '1234567890'. s truncate: 4 ]. file readStreamDo: [ :s | self assert: s contents equals: '1234' ]. ] ensure: [ file ensureDelete ] ! ! !FileSystem commentStamp: ''! I present a low-level protocol for interacting with filesystems. I hold a reference to a store (a subinstance of FileSystemStore) which takes care of the details of performing file and directory operations on the filesystem I represent. I keep track of the current directory, and am responsible for resolving all paths that I pass into my store. My store acts as a factory and offers platform specific actions. FileSystem instances know two methods that return a Reference object: workingDirectory and root. FileSystem disk workingDirectory FileSystem disk root ! !FileSystem methodsFor: 'private' stamp: 'CamilloBruni 1/20/2012 12:33'! copyFrom: inputStream to: destPath | buffer out | out := nil. (self exists: destPath) ifTrue: [ store signalFileExists: destPath ]. ^ [ out := self writeStreamOn: destPath. buffer := ByteArray new: 1024. [ inputStream atEnd ] whileFalse: [ buffer := inputStream nextInto: buffer. out nextPutAll: buffer ]] ensure: [ out ifNotNil: [ out close ]]! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 1/19/2012 00:31'! childrenAt: aResolvable ^ Array streamContents: [ :out | self childrenAt: aResolvable do: [ :path| out nextPut: path ]].! ! !FileSystem methodsFor: 'public' stamp: 'cwp 3/29/2011 15:54'! resolve: aResolvable ^ aResolvable asResolvedBy: self! ! !FileSystem methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/2/2012 11:42'! root "Returns the root of the receiver filesystem, i.e. / on unix" ^ self referenceTo: Path root! ! !FileSystem methodsFor: 'public' stamp: 'CamilloBruni 9/5/2012 11:26'! referenceTo: aResolvable "Answer a reference to the argument from the context of the receiver filesystem. Example: Filesystem disk referenceTo: 'plonk.taz'" ^ FileReference fileSystem: self path: (self pathFromObject: aResolvable)! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 7/10/2012 15:44'! fileNamesAt: aResolvable do: aBlock | path | path := self resolve: aResolvable. store directoryAt: path ifAbsent: [ store signalDirectoryDoesNotExist: path ] fileNodesDo: [ :entry | aBlock value: (store basenameFromEntry: entry) ]! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 6/22/2012 21:58'! childrenAt: aResolvable do: aBlock | path | path := self resolve: aResolvable. store directoryAt: path ifAbsent: [ store signalDirectoryDoesNotExist: path ] nodesDo: [ :entry | aBlock value: path / (store basenameFromEntry: entry) ]! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 7/10/2012 15:43'! childNamesAt: aResolvable ^ Array streamContents: [ :out | self childNamesAt: aResolvable do: [ :path| out nextPut: path ]].! ! !FileSystem methodsFor: 'public' stamp: 'cwp 3/25/2011 13:15'! createDirectory: aResolvable "Resolve aResolvable into an absolute path, then as the store to create a directory there. The store is expected to raise an exception if it cannot do so." ^ store createDirectory: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'accessing' stamp: 'cwp 3/29/2011 15:57'! workingDirectoryPath ^ workingDirectory! ! !FileSystem methodsFor: 'public' stamp: 'S 6/17/2013 13:33'! ensureCreateDirectory: aResolvable "Resolve the argument to an absolute path, then ask the store to make sure that all the directories contained in the argument path exist or are created." store ensureCreateDirectory: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'navigating' stamp: 'cwp 3/29/2011 15:56'! resolveString: aString "Returns the root of the receiver filesystem, i.e. / on unix" ^ workingDirectory resolvePath: (store pathFromString: aString)! ! !FileSystem methodsFor: 'accessing' stamp: 'CamilloBruni 5/4/2012 19:14'! workingDirectoryPath: aPath aPath isAbsolute ifFalse: [ self error: 'Cannot set the working directory to a relative path' ]. workingDirectory := aPath ! ! !FileSystem methodsFor: 'public' stamp: 'MaxLeske 1/25/2014 23:02'! binaryReadStreamOn: aResolvable "Resolve the argument into an absolute path and open a file handle on the file at that path. Ask the handle to give us a read stream for reading the file." ^ (self open: aResolvable writable: false) binaryReadStream.! ! !FileSystem methodsFor: 'delegated' stamp: 'cwp 3/25/2011 13:16'! openFileStream: aResolvable writable: aBoolean ^ store openFileStream: (self resolve: aResolvable) writable: aBoolean! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 6/22/2012 17:57'! entriesAt: aResolvable do: aBlock ^ self entriesAt: aResolvable ifAbsent: [ store signalDirectoryDoesNotExist: ( self resolve: aResolvable) ] do: aBlock ! ! !FileSystem methodsFor: 'converting' stamp: 'cwp 11/21/2009 11:30'! pathFromObject: anObject ^ anObject asPathWith: self! ! !FileSystem methodsFor: 'initialize-release' stamp: 'cwp 2/18/2011 20:33'! initializeWithStore: aStore store := aStore. workingDirectory := store defaultWorkingDirectory! ! !FileSystem methodsFor: 'printing' stamp: 'cwp 2/28/2011 12:29'! printPath: aPath on: aStream store printPath: aPath on: aStream! ! !FileSystem methodsFor: 'accessing' stamp: 'cwp 2/18/2011 16:08'! store ^ store! ! !FileSystem methodsFor: 'public-testing' stamp: 'StephaneDucasse 6/22/2012 17:30'! hasChildren: aResolvable "Returns whether aResolvable has children." store directoryAt: (self resolve: aResolvable) ifAbsent: [ ^false ] nodesDo: [ :node | ^true ]. ^false! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 1/19/2012 00:32'! directoriesAt: aResolvable ^ Array streamContents: [ :out | self directoriesAt: aResolvable do: [ :path| out nextPut: path ]].! ! !FileSystem methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 01:12'! separator "Return path separator used by this filesystem." ^ store separator! ! !FileSystem methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 20:54'! modificationTime: aResolvable "Resolve the argument, and answer true if the result refers to a directory, false if it refers to a file or doesn't exist." ^ store modificationTime: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 20:54'! creationTime: aResolvable "Resolve the argument, and answer true if the result refers to a directory, false if it refers to a file or doesn't exist." ^ store creationTime: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'public-testing' stamp: 'CamilloBruni 7/10/2012 21:31'! isReadable: aResolvable "Resolve the argument, and answer true if the there is a file or directory that can be read from." ^ (self permissions: aResolvable) isReadable! ! !FileSystem methodsFor: 'accessing' stamp: 'StephaneDucasse 7/3/2011 16:07'! workingDirectory "Returns a reference to the directory from where the image was launched" ^ self referenceTo: self workingDirectoryPath! ! !FileSystem methodsFor: 'navigating' stamp: 'CamilloBruni 2/4/2012 19:22'! resolvePath: aPath "Return a path where the argument is resolved in the context of the receiver. The behavior is similar to the one of a command line. > cd /a/b/c > cd b The shell will attempt to make /a/b/c/b the current directory. " ^ workingDirectory resolve: aPath! ! !FileSystem methodsFor: 'public' stamp: 'EstebanLorenzano 4/3/2012 13:27'! entryAt: aResolvable | path | path := self resolve: aResolvable. ^ store nodeAt: path ifPresent: [ :node | store entryFromNode: node fileSystem: self path: path ] ifAbsent: [ store signalFileDoesNotExist: path ]! ! !FileSystem methodsFor: 'converting' stamp: 'cwp 2/18/2011 16:39'! pathFromString: aString ^ store pathFromString: aString! ! !FileSystem methodsFor: 'public' stamp: 'cwp 3/25/2011 19:23'! open "Some kinds of filesystems need to open connections to external resources. Does nothing by default." store open! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 1/19/2012 00:32'! filesAt: aResolvable ^ Array streamContents: [ :out | self filesAt: aResolvable do: [ :path| out nextPut: path ]].! ! !FileSystem methodsFor: 'public' stamp: 'CamilloBruni 5/10/2012 16:01'! checkName: aString fixErrors: fixErrors ^ store checkName: aString fixErrors: fixErrors! ! !FileSystem methodsFor: 'public' stamp: 'EstebanLorenzano 4/3/2012 13:24'! rename: sourcePath ifAbsent: aBlock to: destPath ifPresent: pBlock "Rename the file referenced as sourcePath to the destination referred as destPath. Perform associate actions in case of problems." | source destination | source := self resolve: sourcePath. destination := self resolve: destPath. store rename: source ifAbsent: aBlock to: destination ifPresent: pBlock fileSystem: self. ^ destination! ! !FileSystem methodsFor: 'public' stamp: 'cwp 3/25/2011 19:14'! delimiter "Return path delimiter used by this filesystem." ^ store delimiter! ! !FileSystem methodsFor: 'public' stamp: 'CamilloBruni 1/20/2012 13:23'! readStreamOn: aResolvable "Resolve the argument into an absolute path and open a file handle on the file at that path. Ask the handle to give us a read stream for reading the file." ^ (self open: aResolvable writable: false) readStream.! ! !FileSystem methodsFor: 'public-testing' stamp: 'cwp 3/25/2011 19:21'! isDirectory: aResolvable "Resolve the argument, and answer true if the result refers to a directory, false if it refers to a file or doesn't exist." ^ store isDirectory: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 1/19/2012 00:30'! directoriesAt: aResolvable do: aBlock | path | path := self resolve: aResolvable. store directoryAt: path ifAbsent: [ store signalDirectoryDoesNotExist: path ] directoryNodesDo: [ :entry | aBlock value: path / (store basenameFromEntry: entry) ]! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'GuillermoPolito 6/22/2012 12:21'! entriesAt: aResolvable ^ Array streamContents: [ :out | self entriesAt: aResolvable do: [ :entry | out nextPut: entry ] ]! ! !FileSystem methodsFor: 'navigating' stamp: 'cwp 3/25/2011 13:04'! / anObject "Return the absolute reference obtained by resolving anObject against the root of this filesystem." ^ self root / anObject! ! !FileSystem methodsFor: 'public-testing' stamp: 'EstebanLorenzano 8/2/2012 15:42'! isSymlink: aResolvable "Resolve the argument, and answer true if the result refers to a directory, false if it refers to a file or doesn't exist." ^ store isSymlink: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 7/10/2012 15:43'! directoryNamesAt: aResolvable do: aBlock | path | path := self resolve: aResolvable. store directoryAt: path ifAbsent: [ store signalDirectoryDoesNotExist: path ] directoryNodesDo: [ :entry | aBlock value: (store basenameFromEntry: entry) ]! ! !FileSystem methodsFor: 'public' stamp: 'cwp 2/19/2011 01:39'! close store close! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 1/19/2012 00:30'! filesAt: aResolvable do: aBlock | path | path := self resolve: aResolvable. store directoryAt: path ifAbsent: [ store signalDirectoryDoesNotExist: path ] fileNodesDo: [ :entry | aBlock value: path / (store basenameFromEntry: entry) ]! ! !FileSystem methodsFor: 'public-testing' stamp: 'CamilloBruni 5/7/2012 01:19'! isCaseSensitive ^ self store isCaseSensitive! ! !FileSystem methodsFor: 'converting' stamp: 'cwp 2/18/2011 12:09'! stringFromPath: aPath ^ store stringFromPath: aPath! ! !FileSystem methodsFor: 'public' stamp: 'CamilloBruni 1/20/2012 13:23'! writeStreamOn: aResolvable "Open a write stream on the file referred by the argument. It can be a string or a path" ^ (self open: aResolvable writable: true) writeStream.! ! !FileSystem methodsFor: 'public-testing' stamp: 'CamilloBruni 7/10/2012 21:31'! isWritable: aResolvable "Resolve the argument, and answer true if the there is a file that can be written to or directory that can be changed." ^ (self permissions: aResolvable) isWritable! ! !FileSystem methodsFor: 'public' stamp: 'SeanDeNigris 8/17/2012 09:30'! rename: sourcePath to: destName "Rename the file referenced as sourcePath to destPath. Raise exceptions FileExists or FileDoesNotExist if the operation fails" ^ self rename: sourcePath ifAbsent: [store signalFileDoesNotExist: sourcePath] to: destName ifPresent: [store signalFileExists: destName]! ! !FileSystem methodsFor: 'accessing' stamp: 'cwp 3/29/2011 15:58'! changeDirectory: aPath self workingDirectoryPath: (self resolve: aPath)! ! !FileSystem methodsFor: 'printing' stamp: 'cwp 2/18/2011 16:34'! forReferencePrintOn: aStream store forReferencePrintOn: aStream! ! !FileSystem methodsFor: 'public' stamp: 'cwp 3/25/2011 13:14'! delete: aResolvable store delete: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'navigating' stamp: 'EstebanLorenzano 4/3/2012 13:06'! resolveReference: aReference ^ aReference fileSystem = self ifTrue: [workingDirectory resolvePath: aReference path]! ! !FileSystem methodsFor: 'public-testing' stamp: 'CamilloBruni 9/4/2013 15:30'! hasDirectories: aResolvable self entriesAt: aResolvable ifAbsent: [ ^ false ] do: [ :entry | entry isDirectory ifTrue: [ ^true ] ]. ^false! ! !FileSystem methodsFor: 'comparing' stamp: 'cwp 2/18/2011 16:08'! hash ^ store hash! ! !FileSystem methodsFor: 'public' stamp: 'cwp 3/25/2011 19:19'! exists: aResolvable "Resolve the argument, and answer true if the there is a file or directory at that path, false if there is not." ^ store exists: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'public' stamp: 'EstebanLorenzano 4/3/2012 13:29'! copy: sourcePath ifAbsent: absentBlock to: destinationPath ifPresent: presentBlock "Copy the file referenced as sourcePath to the destination referred as destPath. Perform associate actions in case of problems." store copy: (self resolve: sourcePath) ifAbsent: absentBlock to: (self resolve: destinationPath) ifPresent: presentBlock fileSystem: self! ! !FileSystem methodsFor: 'public-testing' stamp: 'CamilloBruni 6/22/2012 17:57'! hasFiles: aResolvable self entriesAt: aResolvable ifAbsent: [ ^ false ] do: [ :entry | entry isFile ifTrue: [ ^true ] ]. ^false! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 7/10/2012 15:44'! fileNamesAt: aResolvable ^ Array streamContents: [ :out | self fileNamesAt: aResolvable do: [ :path| out nextPut: path ]].! ! !FileSystem methodsFor: 'private' stamp: 'CamilloBruni 9/5/2012 11:28'! openStreamDescription: aResolvable writable: aBoolean "I am a helper method to delegate basicOpen:writable: to the store. I am called from FileSystemHandle implementations." | path | path := self resolve: aResolvable. ^ store basicOpen: path writable: aBoolean! ! !FileSystem methodsFor: 'public' stamp: 'CamilloBruni 5/9/2012 13:03'! mimeTypesAt: aResolvable "Return the possible mime types for the given path." ^ store mimeTypesAt: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 6/22/2012 17:56'! entriesAt: aResolvable ifAbsent: absentBlock do: aBlock | path entry aFilesystem | path := self resolve: aResolvable. aFilesystem := self. store directoryAt: path ifAbsent: [ ^ absentBlock value ] nodesDo: [ :node | entry := store entryFromNode: node path: path for: aFilesystem. aBlock value: entry ]! ! !FileSystem methodsFor: 'public' stamp: 'cwp 4/3/2011 22:17'! copy: sourcePath to: destPath "Copy the file referenced as sourcePath to the destination referred as destPath. If there is no file at sourcePath, raise FileDoesNotExist. If destPath is a file, raise FileExists." self copy: sourcePath ifAbsent: [ store signalFileDoesNotExist: sourcePath ] to: destPath ifPresent: [ store signalFileExists: destPath ]! ! !FileSystem methodsFor: 'private' stamp: 'EstebanLorenzano 4/3/2012 13:06'! copy: aPath toReference: destRef | inputStream path | path := self resolve: aPath. [ inputStream := self readStreamOn: path. inputStream ifNil: [ store signalFileDoesNotExist: path ]. destRef fileSystem copyFrom: inputStream to: destRef path ] ensure: [ inputStream ifNotNil: [ inputStream close ]]! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 7/10/2012 15:48'! directoryNamesAt: aResolvable ^ Array streamContents: [ :out | self directoryNamesAt: aResolvable do: [ :name| out nextPut: name ]].! ! !FileSystem methodsFor: 'comparing' stamp: 'cwp 2/18/2011 16:08'! = other ^ self species = other species and: [self store = other store]! ! !FileSystem methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 22:09'! size: aResolvable "Resolve the argument and return the size for this file or directory " ^ store size: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'public' stamp: 'EstebanLorenzano 4/12/2012 14:25'! open: aResolvable writable: aBoolean "Resolve aResolvable into an absolute path, then ask the store to open the file at that path using the specified access mode." | path | path := self resolve: aResolvable. ^ store handleClass open: (FileReference fileSystem: self path: path) writable: aBoolean ! ! !FileSystem methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 21:31'! permissions: aResolvable "Resolve the argument and return the Permissions for this file or directory " ^ store permissions: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'public-enumerating' stamp: 'CamilloBruni 7/10/2012 15:43'! childNamesAt: aResolvable do: aBlock | path | path := self resolve: aResolvable. store directoryAt: path ifAbsent: [ store signalDirectoryDoesNotExist: path ] nodesDo: [ :entry | aBlock value: (store basenameFromEntry: entry) ]! ! !FileSystem methodsFor: 'public' stamp: 'CamilloBruni 5/7/2012 01:15'! extensionDelimiter ^ $.! ! !FileSystem methodsFor: 'public-testing' stamp: 'CamilloBruni 6/1/2012 14:45'! isFile: aResolvable "Resolve the argument, and answer true if the result refers to a file, false if it refers to a directory or doesn't exist." ^ store isFile: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'navigating' stamp: 'EstebanLorenzano 4/2/2012 11:42'! * anObject "Return a relative reference." ^ self referenceTo:( Path * anObject)! ! !FileSystem class methodsFor: '*filesystem-disk' stamp: 'CamilloBruni 5/4/2012 20:54'! root ^ self disk root! ! !FileSystem class methodsFor: '*filesystem-disk' stamp: 'CamilloBruni 5/7/2012 11:57'! lookInUsualPlaces: fileName "Check the default directory, the imagePath, and the vmPath (and the vmPath's owner) for this file." | file | (file := fileName asFileReference) exists ifTrue: [ ^ file ]. (file := Smalltalk imageFile resolve: fileName) exists ifTrue: [ ^ file ]. (file := Smalltalk vmDirectory resolve: fileName) exists ifTrue: [ ^ file ]. (file := Smalltalk vmDirectory parent resolve: fileName) exists ifTrue: [ ^ file ]. ^ nil! ! !FileSystem class methodsFor: '*filesystem-disk' stamp: 'CamilloBruni 5/4/2012 20:53'! workingDirectory ^ self disk workingDirectory! ! !FileSystem class methodsFor: '*filesystem-disk' stamp: 'CamilloBruni 5/4/2012 19:19'! * aFileOrDirectoryName ^ self disk * aFileOrDirectoryName! ! !FileSystem class methodsFor: '*filesystem-disk' stamp: 'EstebanLorenzano 4/3/2012 11:30'! disk "Answer a filesystem that represents the 'on-disk' filesystem used by the host operating system." ^ DiskStore currentFileSystem! ! !FileSystem class methodsFor: '*filesystem-zip' stamp: 'EstebanLorenzano 4/3/2012 17:20'! zip: aReference ^ self store: (ZipStore reference: aReference)! ! !FileSystem class methodsFor: 'instance creation' stamp: 'cwp 2/18/2011 20:34'! store: aStore ^ self basicNew initializeWithStore: aStore; yourself! ! !FileSystem class methodsFor: '*filesystem-memory' stamp: 'EstebanLorenzano 4/3/2012 09:36'! memory ^ self store: (MemoryStore new)! ! !FileSystem class methodsFor: '*filesystem-disk' stamp: 'CamilloBruni 5/4/2012 19:19'! / aFileOrDirectoryName ^ self disk / aFileOrDirectoryName! ! !FileSystem class methodsFor: 'initializing' stamp: 'EstebanLorenzano 4/3/2012 13:13'! startUp: aBoolean "This is only here to deal with migration from older versions of FileSystem that wanted to receive startup notifcations." Smalltalk removeFromStartUpList: self! ! !FileSystemDirectoryEntry commentStamp: 'cwp 11/18/2009 11:09'! I am a cache for metadata about a file or directory. The information I hold is as follows: reference A reference to the file or directory to which my data pertains. creation The creation date and time, stored as number seconds since the Smalltalk epoch. modification The modification date and time, number seconds since the Smalltalk epoch. isDirectory True if my data pertains to a directory, false if a file. size Size in bytes for a file, 0 for a directory. ! !FileSystemDirectoryEntry methodsFor: 'delegate' stamp: 'CamilloBruni 8/15/2011 17:02'! extension ^ reference extension! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'StephaneDucasse 1/27/2011 22:15'! size "Returns the receiver size" ^ size! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 21:20'! creationTime "Return the creation date and time of the entry receiver." ^ creation! ! !FileSystemDirectoryEntry methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 8/2/2012 15:33'! initializeWithRef: ref creation: cTime modification: mTime isDir: directoryBoolean size: bytes posixPermissions: posixNumber isSymlink: symlinkBoolean reference := ref. creation := cTime. modification := mTime. isDirectory := directoryBoolean. size := bytes. posixPermissions := posixNumber. isSymlink := symlinkBoolean.! ! !FileSystemDirectoryEntry methodsFor: 'testing' stamp: 'EstebanLorenzano 8/2/2012 15:32'! isSymlink ^isSymlink! ! !FileSystemDirectoryEntry methodsFor: 'delegate' stamp: 'CamilloBruni 8/12/2011 20:33'! fullName ^ reference fullName! ! !FileSystemDirectoryEntry methodsFor: 'testing' stamp: 'StephaneDucasse 1/27/2011 22:16'! isDirectory "Return whether the receiver is a directory" ^ isDirectory! ! !FileSystemDirectoryEntry methodsFor: 'delegate' stamp: 'CamilloBruni 8/12/2011 20:32'! readStream ^ reference readStream! ! !FileSystemDirectoryEntry methodsFor: 'converting' stamp: 'EstebanLorenzano 4/12/2012 14:28'! asFileReference ^ reference! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'abc 5/11/2012 23:31'! creation ^ self creationTime ! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'StephaneDucasse 1/27/2011 22:15'! modificationSeconds "Return the modification date and time of the entry receiver in seconds." ^ modification! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'EstebanLorenzano 7/3/2012 11:29'! permissions ^self posixPermissions ifNotNil: [ FileSystemPermission posixPermissions: self posixPermissions ]! ! !FileSystemDirectoryEntry methodsFor: 'delegate' stamp: 'CamilloBruni 8/12/2011 20:33'! writeStream ^ reference writeStream! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'abc 5/11/2012 23:30'! modification ^ self modificationTime ! ! !FileSystemDirectoryEntry methodsFor: 'printing' stamp: 'MarcusDenker 12/2/2013 14:06'! printOn: aStream aStream nextPutAll: 'DirectoryEntry: '. reference ifNotNil: [:ref | aStream nextPutAll: reference printString].! ! !FileSystemDirectoryEntry methodsFor: 'testing' stamp: 'StephaneDucasse 1/27/2011 22:16'! isFile "Return whether the receiver is a file" ^ isDirectory not! ! !FileSystemDirectoryEntry methodsFor: 'delegate' stamp: 'CamilloBruni 8/12/2011 20:56'! pathSegments ^ reference pathSegments! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'cwp 11/15/2009 21:54'! reference ^ reference! ! !FileSystemDirectoryEntry methodsFor: '*monticellofiletree-filesystem-utilities' stamp: 'dkh 8/10/2012 09:06'! readStreamDo: aBlock ^ reference readStreamDo: aBlock! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'StephaneDucasse 2/15/2010 17:59'! basename ^ reference basename! ! !FileSystemDirectoryEntry methodsFor: '*monticellofiletree-filesystem-utilities' stamp: 'dkh 8/10/2012 09:04'! name ^ self basename! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 14:54'! posixPermissions ^posixPermissions! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'StephaneDucasse 8/3/2012 22:14'! creationSeconds "Return the creation date and time of the entry receiver in seconds." ^ creation asSeconds! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 21:20'! modificationTime "Return the modification date and time of the entry receiver." ^ modification! ! !FileSystemDirectoryEntry class methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 14:52'! allPosixPermissions ^8r777! ! !FileSystemDirectoryEntry class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 8/2/2012 15:37'! fileSystem: aFilesystem path: aPath creation: cTime modification: mTime isDir: aBoolean size: anInteger posixPermissions: posixNumber isSymlink: symlinkBooleam "Create a directory entry given a filesystem and a path in such filesystem. In addition, the creation and modification time are required as well as a boolean that indicates whether the entry is a folder or a file and its size." ^ self reference: (aFilesystem referenceTo: aPath) creation: cTime modification: mTime isDir: aBoolean size: anInteger posixPermissions: posixNumber isSymlink: symlinkBooleam! ! !FileSystemDirectoryEntry class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 8/2/2012 15:36'! reference: ref creation: cTime modification: mTime isDir: aBoolean size: anInteger posixPermissions: posixNumber isSymlink: symlinkBoolean "Create a directory entry for the file reference ref, with the creation time, cTime, the modification time, mTime. aBoolean indicates if the entry represents a directory or a file of size given by anInteger" ^ self basicNew initializeWithRef: ref creation: cTime modification: mTime isDir: aBoolean size: anInteger posixPermissions: posixNumber isSymlink: symlinkBoolean! ! !FileSystemError commentStamp: 'cwp 11/18/2009 12:32'! I am an abstract superclass for errors that may occur during filesystem operations.! !FileSystemError methodsFor: 'initialize-release' stamp: 'lr 8/16/2010 16:00'! initializeWithReference: aReference reference := aReference. messageText := aReference printString! ! !FileSystemError methodsFor: 'accessing' stamp: 'lr 7/13/2010 15:31'! reference ^ reference! ! !FileSystemError methodsFor: 'testing' stamp: 'lr 8/16/2010 16:00'! isResumable ^ true! ! !FileSystemError class methodsFor: 'instance creation' stamp: 'cwp 11/14/2009 23:32'! reference: aReference ^ self basicNew initializeWithReference: aReference! ! !FileSystemError class methodsFor: 'instance creation' stamp: 'cwp 11/14/2009 23:31'! signalWith: aReference ^ (self reference: aReference) signal! ! !FileSystemGuide commentStamp: 'cwp 11/18/2009 12:09'! I am an abstract superclass for objects that fulfill the Guide role in the Guide/Visitor pattern. My subclasses know how to traverse a filesystem in a specific order, "showing" the files and directories they encounter to a visitor. visitor An object that fulfills the Visitor role and implements the visitor protocol. work An OrderedCollection, used to keep track of filesystem nodes that have not yet been visited! !FileSystemGuide methodsFor: 'showing' stamp: 'CamilloBruni 8/12/2011 18:20'! pushAll: aCollection aCollection do: [ :ea | self push: ea ]! ! !FileSystemGuide methodsFor: 'initialization' stamp: 'StephaneDucasse 1/27/2011 10:37'! initialize super initialize. work := OrderedCollection new! ! !FileSystemGuide methodsFor: 'initialize-release' stamp: 'cwp 10/29/2009 23:48'! initializeWithVisitor: aVisitor self initialize. visitor := aVisitor. ! ! !FileSystemGuide methodsFor: 'removing' stamp: 'CamilloBruni 8/12/2011 18:18'! pop ^ work removeLast! ! !FileSystemGuide methodsFor: 'accessing' stamp: 'CamilloBruni 4/10/2013 12:29'! selectChildren ^ selectChildren! ! !FileSystemGuide methodsFor: 'adding' stamp: 'CamilloBruni 8/12/2011 18:18'! push: anObject work add: anObject! ! !FileSystemGuide methodsFor: 'accessing' stamp: 'CamilloBruni 8/12/2011 18:22'! top ^ work removeFirst! ! !FileSystemGuide methodsFor: 'showing' stamp: 'cwp 10/29/2009 23:21'! show: aReference self subclassResponsibility! ! !FileSystemGuide methodsFor: 'accessing' stamp: 'CamilloBruni 4/10/2013 12:34'! selectChildren: aBlock "With this block you can control how the guide spreads over directories. Example: self selectChildren: [ :parentEntry | parentEntry isSymlink not ]. This will prevent the outer visitor to see any children of symlinked directories. Since the guides essentially rearrange the files visited controlling which children you see is the main concern of the guide. All the other visiting aspects can be controlled in the visitor." selectChildren := aBlock! ! !FileSystemGuide methodsFor: 'showing' stamp: 'lr 7/13/2010 15:36'! whileNotDoneDo: aBlock [ work isEmpty ] whileFalse: [ aBlock value ]! ! !FileSystemGuide methodsFor: 'testing' stamp: 'CamilloBruni 4/10/2013 12:29'! shouldVisitChildrenOf: anEntry ^ selectChildren ifNil: [ true ] ifNotNil: [ selectChildren cull: anEntry ]! ! !FileSystemGuide class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/10/2013 12:29'! show: aReference to: aVisitor selecting: aBlock ^ (self for: aVisitor) selectChildren: aBlock; show: aReference! ! !FileSystemGuide class methodsFor: 'instance creation' stamp: 'cwp 11/17/2009 11:58'! show: aReference to: aVisitor ^ (self for: aVisitor) show: aReference! ! !FileSystemGuide class methodsFor: 'instance creation' stamp: 'cwp 10/29/2009 19:27'! for: aVisitor ^ self basicNew initializeWithVisitor: aVisitor! ! !FileSystemHandle commentStamp: 'cwp 11/18/2009 11:11'! I am an abstract superclass for file handle implementations. I provide a uniform interface that streams can use for read and write operations on a file regardless of the filesystem. I encapsulate the actual IO primitives.! !FileSystemHandle methodsFor: 'public' stamp: 'cwp 7/26/2009 12:50'! close self subclassResponsibility! ! !FileSystemHandle methodsFor: 'testing' stamp: 'cwp 7/26/2009 12:50'! isOpen self subclassResponsibility! ! !FileSystemHandle methodsFor: 'testing' stamp: 'abc 5/11/2012 23:24'! isWritable ^ writable! ! !FileSystemHandle methodsFor: 'public' stamp: 'cwp 7/26/2009 12:50'! at: offset write: buffer startingAt: start count: count self subclassResponsibility! ! !FileSystemHandle methodsFor: 'accessing' stamp: 'abc 5/11/2012 23:24'! fullName ^ reference fullName! ! !FileSystemHandle methodsFor: 'private' stamp: 'EstebanLorenzano 4/3/2012 13:06'! basicOpen "get the raw stream description from the filesystem's store" ^ self fileSystem openStreamDescription: reference path writable: writable! ! !FileSystemHandle methodsFor: 'public' stamp: 'PavelKrivanek 11/23/2012 12:21'! readStream self subclassResponsibility! ! !FileSystemHandle methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/3/2012 13:02'! fileSystem ^ reference fileSystem ! ! !FileSystemHandle methodsFor: 'public' stamp: 'SeanDeNigris 6/13/2012 07:47'! ensureClosed reference exists ifTrue: [self close]! ! !FileSystemHandle methodsFor: 'public' stamp: 'cwp 7/26/2009 12:51'! reopen self close. self open! ! !FileSystemHandle methodsFor: 'public' stamp: 'cwp 7/26/2009 12:50'! at: offset read: buffer startingAt: start count: count self subclassResponsibility! ! !FileSystemHandle methodsFor: 'public' stamp: 'lr 4/13/2010 16:10'! at: index put: anObject | buffer | buffer := ByteArray with: (anObject isCharacter ifTrue: [ anObject codePoint ] ifFalse: [ anObject ]). self at: index write: buffer startingAt: 1 count: 1. ! ! !FileSystemHandle methodsFor: 'public' stamp: 'cwp 7/29/2009 22:19'! at: index | buffer | buffer := ByteArray new: 1. self at: index read: buffer startingAt: 1 count: 1. ^ buffer at: 1! ! !FileSystemHandle methodsFor: 'accessing' stamp: 'cwp 7/26/2009 12:51'! reference ^ reference! ! !FileSystemHandle methodsFor: 'public' stamp: 'PavelKrivanek 11/23/2012 12:21'! writeStream self subclassResponsibility! ! !FileSystemHandle methodsFor: 'public' stamp: 'cwp 7/26/2009 12:50'! flush self subclassResponsibility! ! !FileSystemHandle methodsFor: 'public' stamp: 'cwp 7/26/2009 12:50'! open self subclassResponsibility! ! !FileSystemHandle methodsFor: 'initialize-release' stamp: 'cwp 11/20/2009 14:56'! setReference: aReference writable: aBoolean reference := aReference resolve. writable := aBoolean! ! !FileSystemHandle methodsFor: 'public' stamp: 'cwp 7/26/2009 12:50'! truncateTo: anInteger self subclassResponsibility! ! !FileSystemHandle class methodsFor: 'instance creation' stamp: 'cwp 7/26/2009 12:52'! open: aReference writable: aBoolean ^ (self on: aReference writable: aBoolean) open! ! !FileSystemHandle class methodsFor: 'instance creation' stamp: 'cwp 7/26/2009 12:52'! on: aReference writable: aBoolean ^ self new setReference: aReference writable: aBoolean! ! !FileSystemHandleTest commentStamp: 'TorstenBergmann 1/31/2014 11:35'! SUnit tests for FileSystemHandle! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/29/2009 22:03'! testAtPut | in | handle at: 1 put: 3. in := ByteArray new: 1. handle at: 1 read: in startingAt: 1 count: 1. self assert: in first = 3! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/31/2009 00:13'! testReadBufferTooLarge | out in result | out := #(1 2 3) asByteArray. in := ByteArray new: 5. in atAllPut: 9. handle at: 1 write: out startingAt: 1 count: 3. result := handle at: 1 read: in startingAt: 2 count: 4. self assert: result = 3. self assert: in = #(9 1 2 3 9) asByteArray.! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testEnsureClosed filesystem := self createFileSystem. reference := filesystem * 'plonk'. handle := reference openWritable: true. handle ensureClosed. self deny: handle isOpen. handle ensureClosed. reference ensureDelete. handle reference exists ifTrue: [ self error ]. handle ensureClosed! ! !FileSystemHandleTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/3/2012 11:43'! createFileSystem self subclassResponsibility ! ! !FileSystemHandleTest methodsFor: 'running' stamp: 'S 6/17/2013 13:16'! tearDown handle ensureClosed. reference ensureDelete.! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/26/2009 14:15'! testIO | out in | out := #(1 2 3) asByteArray. in := ByteArray new: 3. handle at: 1 write: out startingAt: 1 count: 3. handle at: 1 read: in startingAt: 1 count: 3. self assert: out = in.! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/26/2009 14:16'! testReadOnly handle close. handle := reference openWritable: false. self should: [ handle at: 1 write: #(1 2 3 ) startingAt: 1 count: 3 ] raise: Error! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/26/2009 14:16'! testTruncate | out | out := #(1 2 3 4 5) asByteArray. handle at: 1 write: out startingAt: 1 count: 5. handle truncateTo: 3. self assert: handle size = 3! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/29/2009 22:06'! testAt handle at: 1 write: (ByteArray with: 3) startingAt: 1 count: 1. self assert: (handle at: 1) = 3! ! !FileSystemHandleTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/3/2012 11:42'! setUp filesystem := self createFileSystem. reference := filesystem * 'plonk'. handle := reference openWritable: true! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testAtPutBinaryAscii handle at: 1 put: 32. handle at: 1 put: Character space! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/26/2009 12:45'! testReference self assert: handle reference = reference asAbsolute! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/29/2009 22:11'! testSizeAfterGrow | out | out := #(1 2 3) asByteArray. handle at: 1 write: out startingAt: 1 count: 3. self assert: handle size = 3! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/29/2009 22:13'! testSizeNoGrow | bytes | bytes := #(1 2 3 4) asByteArray. handle at: 1 write: bytes startingAt: 1 count: 3. handle at: 4 write: bytes startingAt: 4 count: 1. self assert: handle size = 4! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/28/2009 22:40'! testWriteStream | stream | stream := handle writeStream. self assert: (stream respondsTo: #nextPut:)! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testAtWriteBinaryAscii handle at: 1 write: #[32] startingAt: 1 count: 1. handle at: 1 write: (String with: Character space) startingAt: 1 count: 1! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'CamilloBruni 5/24/2012 15:21'! testCreatedOpen self flag: 'TODO: activated once FileHandle is in use again!!'. "self assert: handle isOpen"! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/26/2009 12:23'! testClose handle close. self deny: handle isOpen ! ! !FileSystemHandleTest class methodsFor: 'testing' stamp: 'cwp 7/26/2009 12:46'! shouldInheritSelectors ^ true! ! !FileSystemHandleTest class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/3/2012 09:38'! isAbstract ^ self name = #FileSystemHandleTest! ! !FileSystemPermission commentStamp: ''! I'm a set of permissions for a Directory Entry! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:10'! groupExecute ^ self permissionBitAt: 4! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:11'! otherExecute ^ self permissionBitAt: 1! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:11'! groupWrite ^ self permissionBitAt: 5! ! !FileSystemPermission methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 21:32'! isReadable ^ self ownerRead! ! !FileSystemPermission methodsFor: 'comparing' stamp: 'NicolaiHess 12/25/2013 14:52'! > other ^ other posixPermission < posixPermission! ! !FileSystemPermission methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 21:33'! isWritable ^ self ownerWrite! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:12'! ownerExecute ^ self permissionBitAt: 7! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 7/3/2012 11:28'! permissionBitAt: bitIndex ^ (posixPermission bitAt: bitIndex) == 1! ! !FileSystemPermission methodsFor: 'comparing' stamp: 'NicolaiHess 12/25/2013 14:53'! >= other ^ other posixPermission <= posixPermission! ! !FileSystemPermission methodsFor: 'comparing' stamp: 'CamilloBruni 7/10/2012 22:01'! < other ^ posixPermission < other posixPermission! ! !FileSystemPermission methodsFor: 'initialization' stamp: 'EstebanLorenzano 6/22/2012 15:02'! initialize: aNumber posixPermission := aNumber. self initialize. ! ! !FileSystemPermission methodsFor: 'private' stamp: 'NicolaiHess 12/25/2013 14:54'! posixPermission ^ posixPermission! ! !FileSystemPermission methodsFor: 'printing' stamp: 'EstebanLorenzano 6/22/2012 15:06'! printOn: aStream aStream "Owner" nextPut: (self ownerRead ifTrue: [ $r ] ifFalse: [ $- ]); nextPut: (self ownerWrite ifTrue: [ $w ] ifFalse: [ $- ]); nextPut: (self ownerExecute ifTrue: [ $x ] ifFalse: [ $- ]); "Group" nextPut: (self groupRead ifTrue: [ $r ] ifFalse: [ $- ]); nextPut: (self groupWrite ifTrue: [ $w ] ifFalse: [ $- ]); nextPut: (self groupExecute ifTrue: [ $x ] ifFalse: [ $- ]); "Other" nextPut: (self otherRead ifTrue: [ $r ] ifFalse: [ $- ]); nextPut: (self otherWrite ifTrue: [ $w ] ifFalse: [ $- ]); nextPut: (self otherExecute ifTrue: [ $x ] ifFalse: [ $- ]) ! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:10'! groupRead ^ self permissionBitAt: 6! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:12'! ownerRead ^ self permissionBitAt: 9! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:11'! otherWrite ^ self permissionBitAt: 2! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:12'! ownerWrite ^ self permissionBitAt: 8! ! !FileSystemPermission methodsFor: 'comparing' stamp: 'NicolaiHess 12/25/2013 14:53'! <= other ^ (posixPermission > other posixPermission) not! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:11'! otherRead ^ self permissionBitAt: 3! ! !FileSystemPermission class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 6/22/2012 15:01'! posixPermissions: aNumber ^self basicNew initialize: aNumber; yourself! ! !FileSystemPermission class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/23/2013 00:14'! default ^ self posixPermissions: 8r777! ! !FileSystemPermission class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 6/22/2012 15:02'! new self error: 'Should not be called. Use #posixPermission: instead'! ! !FileSystemResolver commentStamp: 'cwp 3/29/2011 17:04'! I am an abstract superclass for objects that can resolve origins into references. Such objects use the Chain of Responsibility pattern, and when unable to resolve a particular origin, delegate that resolution request to the next resolver in the list. next The next resolver in the list, or nil ! !FileSystemResolver methodsFor: 'resolving' stamp: 'cwp 10/27/2009 11:18'! resolve: aSymbol ^ (self canResolve: aSymbol) ifTrue: [self perform: aSymbol] ifFalse: [self unknownOrigin: aSymbol]! ! !FileSystemResolver methodsFor: 'resolving' stamp: 'cwp 10/27/2009 09:26'! unknownOrigin: aSymbol ^ next ifNotNil: [next resolve: aSymbol]! ! !FileSystemResolver methodsFor: 'resolving' stamp: 'cwp 10/27/2009 11:18'! canResolve: aSymbol ^ self supportedOrigins includes: aSymbol! ! !FileSystemResolver methodsFor: 'accessing' stamp: 'cwp 10/26/2009 20:53'! addResolver: aResolver next ifNil: [next := aResolver] ifNotNil: [next addResolver: aResolver]! ! !FileSystemResolver methodsFor: 'resolving' stamp: 'CamilloBruni 9/7/2013 11:28'! resolveString: aString | decoded fs | decoded := FilePathEncoder decode: aString. fs := FileSystem disk. ^ FileReference fileSystem: fs path: (fs pathFromString: decoded)! ! !FileSystemResolver methodsFor: 'accessing' stamp: 'cwp 10/27/2009 10:28'! flushLocalCache! ! !FileSystemResolver methodsFor: 'accessing' stamp: 'cwp 10/27/2009 11:25'! next ^ next! ! !FileSystemResolver methodsFor: 'resolving' stamp: 'cwp 10/26/2009 20:06'! supportedOrigins ^ #()! ! !FileSystemResolver methodsFor: 'accessing' stamp: 'cwp 10/27/2009 10:28'! flushCaches self flushLocalCache. next ifNotNil: [next flushCaches]! ! !FileSystemResolverTest commentStamp: 'TorstenBergmann 1/31/2014 11:35'! SUnit tests for FileSystemResolver! !FileSystemResolverTest methodsFor: 'running' stamp: 'cwp 10/27/2009 11:12'! createResolver self subclassResponsibility ! ! !FileSystemResolverTest methodsFor: 'running' stamp: 'cwp 10/26/2009 21:25'! setUp resolver := self createResolver.! ! !FileSystemResolverTest methodsFor: 'asserting' stamp: 'DamienCassou 6/28/2013 14:35'! assertOriginResolves: aSymbol | reference | reference := resolver resolve: aSymbol. self assert: (reference isKindOf: FileReference). self assert: reference isAbsolute. self assert: reference exists. ^ reference! ! !FileSystemResolverTest class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/3/2012 09:40'! isAbstract ^ self name = #FileSystemResolverTest! ! !FileSystemStore commentStamp: ''! I am an abstract superclass for store implementations. My subclasses provide access to the actual data storage of a particular kind of filesystem. The file system can be accessed via FileSystem disk FileSystem memory My associated filesystem can be accessed as follows: DiskStore currentFileSystem! !FileSystemStore methodsFor: 'abstract' stamp: 'CamilloBruni 5/9/2012 00:41'! basicIsWritable: aNode "Used to decide whether the low-level representation (node / entry) from the store is a writable file or can be changed." self subclassResponsibility ! ! !FileSystemStore methodsFor: 'private' stamp: 'EstebanLorenzano 8/2/2012 15:35'! entryFromNode: aNode fileSystem: aFilesystem path: aPath ^ FileSystemDirectoryEntry fileSystem: aFilesystem path: aPath creation: (self basicCreationTime: aNode) modification:(self basicModificationTime: aNode) isDir: (self basicIsDirectory: aNode) size: (self basicSize: aNode) posixPermissions: (self basicPosixPermissions: aNode) isSymlink: (self basicIsSymlink: aNode)! ! !FileSystemStore methodsFor: 'abstract' stamp: 'CamilloBruni 5/5/2013 01:17'! basicEntry: directoryEntry path: aPath nodesDo: aBlock self subclassResponsibility ! ! !FileSystemStore methodsFor: 'error signalling' stamp: 'CamilloBruni 1/20/2012 13:34'! basicOpen: aPath writable: aBoolean "open the file at the given path and return an identifier" self subclassResponsibility! ! !FileSystemStore methodsFor: 'abstract' stamp: 'cwp 2/18/2011 23:59'! createDirectory: aPath self subclassResponsibility ! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 5/5/2013 01:22'! directoryAt: aPath ifAbsent: absentBlock nodesDo: aBlock ^ self nodeAt: aPath ifPresent: [ :entry | (self basicIsDirectory: entry) ifTrue: [ self basicEntry: entry path: aPath nodesDo: aBlock ] ifFalse: [ DirectoryDoesNotExist signalWith: aPath ] ] ifAbsent: absentBlock! ! !FileSystemStore methodsFor: 'public' stamp: 'S 6/17/2013 13:33'! ensureCreateDirectory: aPath (self isDirectory: aPath) ifTrue: [ ^ self ]. self ensureCreateDirectory: aPath parent. self createDirectory: aPath! ! !FileSystemStore methodsFor: 'abstract' stamp: 'EstebanLorenzano 8/2/2012 15:38'! basicIsSymlink: aNode ^self subclassResponsibility ! ! !FileSystemStore methodsFor: 'public' stamp: 'PavelKrivanek 11/23/2012 12:21'! openFileStream: path writable: writable self subclassResponsibility! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 21:05'! directoryAt: aPath ifAbsent: absentBlock fileNodesDo: aBlock ^ self directoryAt: aPath ifAbsent: absentBlock nodesDo: [ :entry| (self basicIsDirectory: entry) ifFalse: [ aBlock value: entry ]].! ! !FileSystemStore methodsFor: 'converting' stamp: 'BenComan 3/13/2014 16:24'! printPath: aPath on: out "Use the unix convention by default, since it's the most common." aPath isAbsolute ifTrue: [ out nextPut: self delimiter ]. ^ aPath printOn: out delimiter: self delimiter! ! !FileSystemStore methodsFor: 'abstract' stamp: 'CamilloBruni 1/20/2012 11:34'! basicIsFile: aNode "Used to decide whether the low-level representation (node / entry) from the store is a file. This private message should only be called form within the store." self subclassResponsibility ! ! !FileSystemStore methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 20:07'! copy: sourcePath ifAbsent: absentBlock to: destinationPath ifPresent: presentBlock fileSystem: aFilesystem | buffer out in | in := nil. out := nil. buffer := nil. [ in := aFilesystem readStreamOn: sourcePath. in ifNil: [ ^ absentBlock value ]. (self exists: destinationPath) ifTrue: [ "cannot overwrite destination" ^ presentBlock value ]. out := aFilesystem writeStreamOn: destinationPath. buffer := ByteArray new: 1024. [ in atEnd ] whileFalse: [ buffer := in nextInto: buffer. out nextPutAll: buffer ]] ensure: [ in ifNotNil: [ in close ]. out ifNotNil: [ out close ]]! ! !FileSystemStore methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 01:13'! separator ^ self class separator! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 6/22/2012 21:02'! entryFromNode: node path: path for: aFileystem | entryPath | entryPath := path / (self basenameFromEntry: node). ^ self entryFromNode: node fileSystem: aFileystem path: entryPath! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 20:56'! modificationTime: aPath self nodeAt: aPath ifPresent: [ :entry | ^ self basicModificationTime: entry ] ifAbsent: [ ^ false ]. ! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 20:56'! creationTime: aPath self nodeAt: aPath ifPresent: [ :entry | ^ self basicCreationTime: entry ] ifAbsent: [ ^ false ]. ! ! !FileSystemStore methodsFor: 'abstract' stamp: 'CamilloBruni 7/10/2012 21:12'! basicSize: aNode "Used to get the size of the low-level representation (node / entry) " self subclassResponsibility ! ! !FileSystemStore methodsFor: 'converting' stamp: 'CamilloBruni 5/7/2012 02:20'! pathFromString: aString "Use the unix convention by default, since many filesystems are based on it." ^ Path from: aString delimiter: self delimiter! ! !FileSystemStore methodsFor: 'private' stamp: 'cwp 2/18/2011 12:28'! filename: aByteString matches: aByteString2 ^ aByteString = aByteString2! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 5/10/2012 16:01'! checkName: aString fixErrors: fixErrors ^ self subclassResponsibility! ! !FileSystemStore methodsFor: 'abstract' stamp: 'cwp 2/19/2011 01:38'! open "Some kinds of filesystems need to open connections to external resources"! ! !FileSystemStore methodsFor: 'public' stamp: 'cwp 2/18/2011 13:22'! isDirectory: aPath aPath isRoot ifTrue: [ ^ true ]. self nodeAt: aPath ifPresent: [ :entry | ^ self basicIsDirectory: entry ] ifAbsent: [ ^ false ]. ! ! !FileSystemStore methodsFor: 'public' stamp: 'EstebanLorenzano 8/2/2012 15:42'! isSymlink: aPath aPath isRoot ifTrue: [ ^ true ]. self nodeAt: aPath ifPresent: [ :entry | ^ self basicIsSymlink: entry ] ifAbsent: [ ^ false ]. ! ! !FileSystemStore methodsFor: 'error signalling' stamp: 'CamilloBruni 9/5/2012 11:27'! signalFileExists: aPath ^ FileExists signalWith: aPath! ! !FileSystemStore methodsFor: 'accessing' stamp: 'cwp 2/18/2011 17:19'! delimiter ^ self class delimiter! ! !FileSystemStore methodsFor: 'abstract' stamp: 'cwp 2/19/2011 01:39'! close "Some kinds of filesystems need to open connections to external resources"! ! !FileSystemStore methodsFor: 'error signalling' stamp: 'CamilloBruni 9/5/2012 11:27'! signalFileDoesNotExist: aPath ^ FileDoesNotExist signalWith: aPath! ! !FileSystemStore methodsFor: 'error signalling' stamp: 'CamilloBruni 9/5/2012 11:27'! signalDirectoryExists: aPath ^ DirectoryExists signalWith: aPath! ! !FileSystemStore methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 01:20'! isCaseSensitive ^ self class isCaseSensitive! ! !FileSystemStore methodsFor: 'converting' stamp: 'CamilloBruni 1/19/2012 00:24'! stringFromPath: aPath ^ String streamContents: [ :out | self printPath: aPath on: out ]! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 5/9/2012 00:40'! isWritable: aPath self nodeAt: aPath ifPresent: [ :entry | ^ self basicIsWritable: entry ] ifAbsent: [ ^ false ]. ! ! !FileSystemStore methodsFor: 'abstract' stamp: 'CamilloBruni 5/24/2013 13:39'! rename: sourcePath to: destinationPath self subclassResponsibility ! ! !FileSystemStore methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/2/2012 11:42'! defaultWorkingDirectory ^ Path root! ! !FileSystemStore methodsFor: 'abstract' stamp: 'CamilloBruni 7/10/2012 21:15'! basicPosixPermissions: aNode "Used to get the posix permissions from a low-level filesystem entry / node" self subclassResponsibility ! ! !FileSystemStore methodsFor: 'abstract' stamp: 'CamilloBruni 1/20/2012 11:34'! basicIsDirectory: aNode "Used to decide whether the low-level representation (node / entry) from the store is a directory. This private message should only be called form within the store." self subclassResponsibility ! ! !FileSystemStore methodsFor: 'abstract' stamp: 'cwp 2/18/2011 13:25'! delete: aPath self subclassResponsibility ! ! !FileSystemStore methodsFor: 'abstract' stamp: 'cwp 2/18/2011 12:50'! nodeAt: aPath ifPresent: presentBlock ifAbsent: absentBlock self subclassResponsibility ! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 5/5/2013 01:06'! exists: aPath self nodeAt: aPath ifPresent: [ :entry | ^ true ] ifAbsent: [ ^ false ]. ! ! !FileSystemStore methodsFor: 'public' stamp: 'SvenVanCaekenberghe 10/22/2013 11:38'! mimeTypesAt: aPath | mimeType | mimeType := ZnMimeType forFilenameExtension: aPath extension ifAbsent: [ ^ nil ]. ^ Array with: mimeType! ! !FileSystemStore methodsFor: 'private' stamp: 'SeanDeNigris 8/17/2012 09:30'! rename: sourcePath ifAbsent: absentBlock to: destinationPath ifPresent: presentBlock fileSystem: anFSFilesystem | result | (self exists: destinationPath) ifTrue: [ ^ presentBlock value ]. (self exists: sourcePath) ifFalse: [ ^ absentBlock value ]. result := self rename: sourcePath to: destinationPath. result ifNil: [ self primitiveFailed ]. ^ self.! ! !FileSystemStore methodsFor: 'error signalling' stamp: 'CamilloBruni 9/5/2012 11:27'! signalDirectoryDoesNotExist: aPath ^ DirectoryDoesNotExist signalWith: aPath! ! !FileSystemStore methodsFor: 'public' stamp: 'PavelKrivanek 11/23/2012 12:21'! basenameFromEntry: aNode "Used to extract the basename from the low-level representation (node / entry) from the store." self subclassResponsibility! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 22:08'! size: aPath ^ self nodeAt: aPath ifPresent: [ :entry | ^ self basicSize: entry ] ifAbsent: [ ^ false ] ! ! !FileSystemStore methodsFor: 'abstract' stamp: 'CamilloBruni 7/10/2012 20:56'! basicCreationTime: aNode "Used to decide whether the low-level representation (node / entry) from the store is a readable file or a directory whose contents can be listed." self subclassResponsibility ! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 3/23/2013 00:13'! permissions: aPath self nodeAt: aPath ifPresent: [ :entry | ^ FileSystemPermission posixPermissions: (self basicPosixPermissions: entry) ] ifAbsent: [ ^ FileSystemPermission default ]. ! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 1/19/2012 00:15'! directoryAt: aPath ifAbsent: absentBlock directoryNodesDo: aBlock ^ self directoryAt: aPath ifAbsent: absentBlock nodesDo: [ :entry| (self basicIsDirectory: entry) ifTrue: [ aBlock value: entry ]].! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 1/20/2012 13:13'! isFile: aPath "slow solution for big directories!! " ^ self nodeAt: aPath ifPresent: [ :entry | ^ self basicIsFile: entry ] ifAbsent: [ ^ false ] ! ! !FileSystemStore methodsFor: 'abstract' stamp: 'CamilloBruni 7/10/2012 20:56'! basicModificationTime: aNode "Used to decide whether the low-level representation (node / entry) from the store is a readable file or a directory whose contents can be listed." self subclassResponsibility ! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 5/24/2013 13:47'! nodeAt: aPath ^ self nodeAt: aPath ifPresent: [ :node| node ] ifAbsent: [ NotFound signalFor: aPath in: self ]! ! !FileSystemStore class methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 01:20'! isCaseSensitive ^ self shouldBeImplemented! ! !FileSystemStore class methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 01:11'! separator self shouldBeImplemented! ! !FileSystemStore class methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 01:10'! delimiter self shouldBeImplemented ! ! !FileSystemTest commentStamp: ''! I am an abstract file system test. I directly test - the public interface of a FileSystem using these methods directly - the FileSystem in general through the operation methods of the FileReference! !FileSystemTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:33'! testEnsureDirectory | path | path := Path * 'plonk'. self markForCleanup: path. filesystem ensureCreateDirectory: path. self assert: (filesystem isDirectory: path).! ! !FileSystemTest methodsFor: 'tests-streams' stamp: 'CamilloBruni 5/24/2013 14:27'! testReadStreamIfAbsent | reference stream | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). self assert: (reference readStreamIfAbsent: [ true ]). reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ]. stream := reference readStreamIfAbsent: [ false ]. self assert: stream contents asString = 'griffle'. stream close! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 5/24/2013 14:40'! testFile | path | path := Path * 'gooly'. self markForCleanup: path. (filesystem open: path writable: true) writeStream close. self assert: (filesystem exists: path). self deny: (filesystem isDirectory: path). self assert: (filesystem isFile: path). filesystem delete: path. self deny: (filesystem exists: path)! ! !FileSystemTest methodsFor: 'tests-streams-compatibility' stamp: 'MaxLeske 1/25/2014 23:13'! testBinaryReadStreamDoIfAbsent | reference | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). self assert: (reference binaryReadStreamDo: [ :stream | false ] ifAbsent: [ true ]). reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ]. self assert: (reference binaryReadStreamDo: [ :stream | stream contents asString = 'griffle' ] ifAbsent: [ false ])! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRootIsNotAFile self deny: (filesystem isFile: Path root)! ! !FileSystemTest methodsFor: 'tests-streams-compatibility' stamp: 'MaxLeske 1/25/2014 23:13'! testBinaryReadStreamDo | reference | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). self should: [ reference binaryReadStreamDo: [ :stream | self assert: false ] ] raise: FileDoesNotExist. reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ]. self assert: (reference readStreamDo: [ :stream | stream contents asString ]) = 'griffle'! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 5/24/2013 14:27'! testChildrenAt | directory entries | directory := Path * 'plonk'. filesystem createDirectory: directory. filesystem createDirectory: directory / 'griffle'. filesystem createDirectory: directory / 'bint'. self markForCleanup: directory / 'griffle'. self markForCleanup: directory / 'bint'. self markForCleanup: directory. entries := filesystem childrenAt: directory. self assert: entries size = 2. entries do: [ :ea | self assert: (ea isKindOf: Path). self assert: ea parent = (filesystem resolve: directory). self assert: (#('griffle' 'bint' ) includes: ea basename) ]! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testChangeDirectoryString | cwd | filesystem workingDirectoryPath: (Path / 'plonk'). filesystem changeDirectory: 'griffle'. cwd := filesystem workingDirectoryPath. self assert: cwd isAbsolute. self assert: (cwd at: 1) = 'plonk'. self assert: (cwd at: 2) = 'griffle'! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 13:06'! testRoot self assert: filesystem root fileSystem = filesystem. self assert: filesystem root path = Path root. self assert: filesystem root isRoot.! ! !FileSystemTest methodsFor: 'tests-streams' stamp: 'CamilloBruni 5/24/2013 14:27'! testWriteStreamDo | reference | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). self assert: (reference writeStreamDo: [ :stream | stream nextPutAll: 'griffle'. true ]). self assert: (filesystem workingDirectory / 'griffle') isFile. self assert: (reference writeStreamDo: [ :stream | true ])! ! !FileSystemTest methodsFor: 'tests-streams' stamp: 'DamienCassou 11/27/2013 17:44'! testReadingAfterWriting | reference stream | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). self deny: reference exists. reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ]. stream := reference readStream. self assert: stream contents equals: 'griffle'. stream close! ! !FileSystemTest methodsFor: 'tests-streams' stamp: 'CamilloBruni 5/24/2013 14:27'! testWriteStream | reference stream | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). stream := reference writeStream. stream nextPutAll: 'griffle'. stream close. self assert: (filesystem workingDirectory / 'griffle') isFile. stream := reference writeStream. stream close! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testChangeDirectory | cwd | filesystem workingDirectoryPath: Path / 'plonk'. filesystem changeDirectory: 'griffle'. cwd := filesystem workingDirectoryPath. self assert: cwd isAbsolute. self assert: (cwd at: 1) = 'plonk'. self assert: (cwd at: 2) = 'griffle'. ! ! !FileSystemTest methodsFor: 'tests' stamp: 'cwp 7/20/2009 07:30'! testDelimiter self assert: filesystem delimiter isCharacter! ! !FileSystemTest methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 4/3/2012 13:04'! createFileSystem self subclassResponsibility ! ! !FileSystemTest methodsFor: 'tests' stamp: 'BenComan 2/18/2014 01:26'! testEntryAt | path1 path2 entry1 entry2 | path1 := Path * 'plonk1'. path2 := Path * 'plonk2'. self markForCleanup: path1. self markForCleanup: path2. filesystem createDirectory: path1. (Delay forSeconds: 2) wait. "#creationTime seems limited to 1 second resolution" filesystem createDirectory: path2. entry1 := filesystem entryAt: path1. entry2 := filesystem entryAt: path2. self assert: entry1 isDirectory. self assert: entry2 isDirectory. self assert: entry1 reference = (filesystem referenceTo: path1) asAbsolute. self assert: entry2 reference = (filesystem referenceTo: path2) asAbsolute. self assert: entry1 creationTime < entry2 creationTime. self assert: entry1 modificationTime < entry2 modificationTime. ! ! !FileSystemTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:24'! testCopyWithCorrectBasename | directory | self markForCleanup: 'gooly'; markForCleanup: 'plonk'. directory := filesystem workingDirectory. (directory / 'gooly') ensureCreateFile. directory / 'gooly' copyTo: directory / 'plonk'. self assert: (directory / 'plonk') exists. self assert: (directory childNames includes: 'plonk')! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 13:06'! testWorking self assert: filesystem workingDirectory fileSystem = filesystem. self assert: filesystem workingDirectory path = filesystem workingDirectoryPath! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 11/5/2013 17:42'! testFileNames | reference | #('test one' 'test with two' 'test-äöü' 'test.äöü') do: [ :each | reference := filesystem workingDirectory / each. self assert: reference basename = each. self deny: reference exists. reference writeStreamDo: [ :stream | stream nextPutAll: 'gooly' ] ifPresent: [ self fail ]. [ self assert: reference exists. self assert: (filesystem workingDirectory children anySatisfy: [ :ref | ref = reference ]) ] ensure: [ reference delete ] ]! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 5/24/2013 14:30'! testCreateDirectoryExists | path | path := Path * 'griffle'. self markForCleanup: path. filesystem createDirectory: path. self should: [filesystem createDirectory: path] raise: DirectoryExists. ! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 5/24/2013 14:30'! testCopy | out in contents | self markForCleanup: 'gooly'; markForCleanup: 'plonk'. out := filesystem writeStreamOn: 'gooly'. [ out nextPutAll: 'gooly' ] ensure: [ out close ]. filesystem copy: 'gooly' to: 'plonk'. in := filesystem readStreamOn: 'plonk'. contents := [ in contents asString ] ensure: [ in close ]. self assert: contents equals: 'gooly'! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRootIsDirectory self assert: (filesystem isDirectory: Path root)! ! !FileSystemTest methodsFor: 'tests-streams-compatibility' stamp: 'MaxLeske 1/25/2014 23:15'! testBinaryReadStream | reference stream | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). self should: [ reference binaryReadStream ] raise: FileDoesNotExist. reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ]. stream := reference binaryReadStream. self assert: stream contents asString equals: 'griffle'. stream close! ! !FileSystemTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:26'! testMoveToFailingExistingDestination | base file folder | base := filesystem workingDirectory. folder := (base / 'folder') ensureCreateDirectory. (folder / 'newFile') ensureCreateFile. file := (base / 'file') ensureCreateFile. "Cleanup after running" self markForCleanup: (base / 'folder' / 'newFile'); markForCleanup: (base / 'folder') ; markForCleanup: (base / 'file'). "Destination exists already" self should: [ file moveTo: (folder / 'newFile') ] raise: Error. self assert: (base / 'file') exists. self assert: (folder / 'newFile') exists.! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 5/24/2013 14:30'! testCopyDestExists | out | self markForCleanup: 'gooly'; markForCleanup: 'plonk'. out := (filesystem open: 'gooly' writable: true) writeStream. [out nextPutAll: 'gooly'] ensure: [out close]. (filesystem open: 'plonk' writable: true) writeStream close. self should: [filesystem copy: 'gooly' to: 'plonk'] raise: FileExists! ! !FileSystemTest methodsFor: 'tests-streams' stamp: 'CamilloBruni 5/24/2013 14:27'! testReadStreamDoIfAbsent | reference | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). self assert: (reference readStreamDo: [ :stream | false ] ifAbsent: [ true ]). reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ]. self assert: (reference readStreamDo: [ :stream | stream contents asString = 'griffle' ] ifAbsent: [ false ])! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 8/21/2013 17:55'! testChildrenSorting | directory sorted | directory := Path * 'plonk'. filesystem createDirectory: directory. filesystem createDirectory: directory / 'alfa'. filesystem createDirectory: directory / 'beta'. self markForCleanup: directory / 'alfa'. self markForCleanup: directory / 'beta'. self markForCleanup: directory. sorted := (filesystem childrenAt: directory) sorted. self assert: sorted size = 2. self assert: (sorted at: 1) basename = 'alfa'. self assert: (sorted at: 2) basename = 'beta'.! ! !FileSystemTest methodsFor: 'tests-streams' stamp: 'CamilloBruni 5/24/2013 14:27'! testWriteStreamIfPresent | reference stream | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). stream := reference writeStreamIfPresent: [ false ]. stream nextPutAll: 'griffle'. stream close. self assert: (filesystem workingDirectory / 'griffle') isFile. self assert: (reference writeStreamIfPresent: [ true ])! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testEnsureDirectoryCreatesParent | path | path := Path * 'plonk' / 'griffle'. self markForCleanup: path. self markForCleanup: path parent. filesystem ensureCreateDirectory: path. self assert: (filesystem isDirectory: Path * 'plonk'). self assert: (filesystem isDirectory: path)! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testEnsureDirectoryExists | path | path := Path * 'plonk'. self markForCleanup: path. filesystem createDirectory: path. filesystem ensureCreateDirectory: path! ! !FileSystemTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:26'! testMoveTo | base file folder | base := filesystem workingDirectory. folder := (base / 'folder') ensureCreateDirectory. file := (base / 'file') ensureCreateFile. "Cleanup after running" self markForCleanup: (base / 'folder' / 'newFile'); markForCleanup: (base / 'folder') ; markForCleanup: (base / 'file'). file moveTo: (folder / 'newFile'). self deny: (base / 'file') exists. self assert: (folder / 'newFile') exists.! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 5/24/2013 14:39'! testDirectory | path | path := Path * 'plonk'. self markForCleanup: path. filesystem createDirectory: path. self assert: (filesystem exists: path). self assert: (filesystem isDirectory: path). filesystem delete: path. self deny: (filesystem isFile: path). self deny: (filesystem exists: path)! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testSetWorkingDirectory | cwd | filesystem workingDirectoryPath: (Path / 'plonk'). cwd := filesystem workingDirectoryPath. self assert: cwd isAbsolute. self assert: (cwd at: 1) = 'plonk'! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRootExists self assert: (filesystem exists: Path root)! ! !FileSystemTest methodsFor: 'tests-streams-compatibility' stamp: 'MaxLeske 1/25/2014 23:14'! testBinaryReadStreamIfAbsent | reference stream | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). self assert: (reference binaryReadStreamIfAbsent: [ true ]). reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ]. stream := reference binaryReadStreamIfAbsent: [ false ]. self assert: stream contents asString = 'griffle'. stream close! ! !FileSystemTest methodsFor: 'initialize-release' stamp: 'CamilloBruni 5/24/2013 14:27'! markForCleanup: anObject toDelete add: (filesystem resolve: anObject)! ! !FileSystemTest methodsFor: 'tests' stamp: 'cwp 7/20/2009 07:30'! testDefaultWorkingDirectory self assert: filesystem workingDirectory isRoot! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 7/8/2012 15:30'! testReferenceTo |path| "use a relative path since absolute path behavior differs on mac, linux vs win native filesystems" path := Path * 'a' / 'b'. self assert: (filesystem referenceTo: 'a/b') path = path.! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 8/21/2013 17:54'! testChildrenSortingRoot | directory1 directory2 | "self skip." directory1 := Path * 'plonk1'. directory2 := Path * 'plonk2'. filesystem createDirectory: directory1. filesystem createDirectory: directory2. self markForCleanup: directory1. self markForCleanup: directory2. self assert: filesystem workingDirectory children sorted size = filesystem workingDirectory children size! ! !FileSystemTest methodsFor: 'tests-streams' stamp: 'CamilloBruni 5/24/2013 14:27'! testWriteStreamDoIfPresent | reference | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). self assert: (reference writeStreamDo: [ :stream | stream nextPutAll: 'griffle'. true ] ifPresent: [ false ]). self assert: (filesystem workingDirectory / 'griffle') isFile. self assert: (reference writeStreamDo: [ :stream | true ] ifPresent: [ true ])! ! !FileSystemTest methodsFor: 'initialize-release' stamp: 'CamilloBruni 5/24/2013 14:28'! tearDown toDelete select: [ :path | filesystem exists: path ] thenDo: [ :path | filesystem delete: path ]! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:41'! testCopySourceDoesntExist self should: [filesystem copy: 'plonk' to: 'griffle'] raise: FileDoesNotExist! ! !FileSystemTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:24'! testDelete "Unlike ensureDelete, delete raises an exception if the file does not exist." | reference | reference := filesystem workingDirectory / 'does-not-exist'. self deny: reference exists. self should: [ reference delete ] raise: FileDoesNotExist. reference := ( filesystem workingDirectory / 'file') ensureCreateFile. reference delete. self deny: reference exists. ! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testSetRelativeWorkingDirectory self should: [filesystem workingDirectoryPath: (Path * 'plonk')] raise: Error ! ! !FileSystemTest methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 4/3/2012 11:42'! setUp filesystem := self createFileSystem. toDelete := OrderedCollection new.! ! !FileSystemTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:26'! testMoveToFailingMissingSource | base folder | base := filesystem workingDirectory. folder := (base / 'folder') ensureCreateDirectory. "Cleanup after running" self markForCleanup: (base / 'folder' / 'newFile'); markForCleanup: (base / 'folder'). self deny: (base / 'file') exists. "Destination exists already" self should: [ (base / 'file') moveTo: (folder / 'newFile') ] raise: Error. self deny: (base / 'file') exists. self deny: (folder / 'newFile') exists.! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testCreateDirectoryNoParent | path | path := Path * 'griffle' / 'nurp'. self should: [filesystem createDirectory: path] raise: DirectoryDoesNotExist. ! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 5/24/2013 14:31'! testEntriesAt | directory entries | directory := Path * 'plonk'. filesystem createDirectory: directory. filesystem createDirectory: directory / 'griffle'. filesystem createDirectory: directory / 'bint'. self markForCleanup: directory / 'griffle'; markForCleanup: directory / 'bint'; markForCleanup: directory. entries := filesystem entriesAt: directory. self assert: entries size = 2. entries do: [ :ea | self assert: (ea isKindOf: FileSystemDirectoryEntry). self assert: ea reference parent path = (filesystem resolve: directory). self assert: (#('griffle' 'bint' ) includes: ea reference basename). self assert: ea isDirectory ]! ! !FileSystemTest methodsFor: 'tests-streams' stamp: 'CamilloBruni 8/31/2013 20:23'! testReadStream | reference stream | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). self should: [ reference readStream ] raise: FileDoesNotExist. reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ]. stream := reference readStream. self assert: stream contents asString equals: 'griffle'. stream close! ! !FileSystemTest methodsFor: 'tests' stamp: 'S 6/17/2013 13:24'! testMoveToFailingMissingDestination | base file | base := filesystem workingDirectory. file := (base / 'file') ensureCreateFile. "Cleanup after running" self markForCleanup: (base / 'folder' / 'newFile'); markForCleanup: (base / 'folder') ; markForCleanup: (base / 'file'). "Destination exists already" self deny: (base / 'folder') exists. self should: [ file moveTo: (base / 'folder' / 'newFile') ] raise: Error. self assert: (base / 'file') exists. self deny: (base / 'folder' / 'newFile') exists.! ! !FileSystemTest methodsFor: 'tests-streams' stamp: 'CamilloBruni 5/24/2013 14:27'! testReadStreamDo | reference | self markForCleanup: (reference := filesystem workingDirectory / 'griffle'). self should: [ reference readStreamDo: [ :stream | self assert: false ] ] raise: FileDoesNotExist. reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ]. self assert: (reference readStreamDo: [ :stream | stream contents asString ]) = 'griffle'! ! !FileSystemTest class methodsFor: 'testing' stamp: 'cwp 7/20/2009 08:56'! shouldInheritSelectors ^ true ! ! !FileSystemTest class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/3/2012 09:37'! isAbstract ^ self name = #FileSystemTest! ! !FileSystemTest class methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/3/2012 12:53'! packageNamesUnderTest ^ #('FileSystem')! ! !FileSystemTreeTest commentStamp: 'TorstenBergmann 1/31/2014 11:39'! SUnit tests for a file system tree! !FileSystemTreeTest methodsFor: 'running' stamp: 'lr 7/13/2010 15:26'! createDirectory: aString self subclassResponsibility! ! !FileSystemTreeTest methodsFor: 'running' stamp: 'lr 7/13/2010 15:26'! createFile: aString self subclassResponsibility! ! !FileSystemTreeTest methodsFor: 'running' stamp: 'cwp 10/30/2009 13:32'! setUpGreek self createDirectory: '/alpha'; createDirectory: '/alpha/beta'; createFile: '/alpha/beta/gamma'; createFile: '/alpha/beta/delta'; createDirectory: '/alpha/epsilon'; createFile: '/alpha/epsilon/zeta'! ! !FileSystemTreeTest class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/3/2012 11:38'! isAbstract ^ self name = #FileSystemTreeTest! ! !FileSystemVisitor commentStamp: 'cwp 11/18/2009 12:25'! I am an abstract superclass for objects that can perform operations on directory trees. My subclasses implement the visitor protocol, and process filesystem nodes shown to them by guides.! !FileSystemVisitor methodsFor: 'visiting' stamp: 'cwp 11/15/2009 00:45'! visitFile: aReference ^ self visitReference: aReference! ! !FileSystemVisitor methodsFor: 'visiting' stamp: 'cwp 11/15/2009 00:45'! visitReference: aReference! ! !FileSystemVisitor methodsFor: 'visiting' stamp: 'cwp 11/15/2009 00:45'! visitDirectory: aReference ^ self visitReference: aReference! ! !FileUrl commentStamp: 'gk 10/21/2005 10:58'! This class models a file URL according to (somewhat) RFC1738, see http://www.w3.org/Addressing/rfc1738.txt Here is the relevant part of the RFC: 3.10 FILES The file URL scheme is used to designate files accessible on a particular host computer. This scheme, unlike most other URL schemes, does not designate a resource that is universally accessible over the Internet. A file URL takes the form: file:/// where is the fully qualified domain name of the system on which the is accessible, and is a hierarchical directory path of the form //.../. For example, a VMS file DISK$USER:[MY.NOTES]NOTE123456.TXT might become As a special case, can be the string "localhost" or the empty string; this is interpreted as `the machine from which the URL is being interpreted'. The file URL scheme is unusual in that it does not specify an Internet protocol or access method for such files; as such, its utility in network protocols between hosts is limited. From the above we can conclude that the RFC says that the part never starts or ends with a slash and is always absolute. If the last name can be a directory instead of a file is not specified clearly. The path is stored as a SequenceableCollection of path parts. Notes regarding non RFC features in this class: - If the last path part is the empty string, then the FileUrl is referring to a directory. This is also shown with a trailing slash when converted to a String. - The FileUrl has an attribute isAbsolute which signals if the path should be considered absolute or relative to the current directory. This distinction is not visible in the String representation of FileUrl, since the RFC does not have that. - Fragment is supported (kept for historical reasons) ! !FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'! schemeName ^self class schemeName! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 00:15'! path "Return an ordered collection of the path elements." ^path! ! !FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 00:19'! pathDirString "Path to directory as url, using slash as delimiter. Filename is left out." ^String streamContents: [ :s | isAbsolute ifTrue: [ s nextPut: $/ ]. 1 to: self path size - 1 do: [ :ii | s nextPutAll: (path at: ii); nextPut: $/]]! ! !FileUrl methodsFor: 'downloading' stamp: 'SeanDeNigris 7/12/2012 08:45'! retrieveContents | s entries pathString | pathString := self pathForFile. "We pursue the execution even if the file is not found" [ | type file |file := FileStream readOnlyFileNamed: pathString. type := file mimeTypes. type ifNotNil: [type := type first]. type ifNil: [type := MIMEDocument guessTypeFromName: self path last]. ^MIMELocalFileDocument contentStream: file mimeType: type] on: FileDoesNotExistException do:[:ex| ]. "see if it's a directory... If not, then nil is returned" entries := [pathString asFileReference entries] on: InvalidDirectoryError do: [:ex| ^ nil]. s := String new writeStream. (pathString endsWith: '/') ifFalse: [ pathString := pathString, '/' ]. s nextPutAll: 'Directory Listing for ', pathString, ''. s nextPutAll: '

Directory Listing for ', pathString, '

'. s nextPutAll: ''. ^MIMEDocument contentType: 'text/html' content: s contents url: ('file://', pathString)! ! !FileUrl methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 10/27/2013 11:44'! printOn: aStream "Return the FileUrl according to RFC1738 plus supporting fragments: 'file:///#' Note that being '' is equivalent to 'localhost'. Note: The pathString can not start with a leading $/ to indicate an 'absolute' file path. This is not according to RFC1738 where the path should have no leading or trailing slashes, and always be considered absolute relative to the filesystem." aStream nextPutAll: self schemeName, '://'. host ifNotNil: [aStream nextPutAll: host]. aStream nextPut: $/; nextPutAll: self pathString. fragment ifNotNil: [aStream nextPut: $#; nextPutAll: fragment urlEncoded].! ! !FileUrl methodsFor: 'access' stamp: 'gk 10/21/2005 11:14'! fileName "Return the last part of the path, most often a filename but can also be a directory." ^self path last! ! !FileUrl methodsFor: 'access' stamp: 'CamilloBruni 5/4/2012 21:50'! pathForFile "Path using local file system's delimiter. $\ or $:" ^ self asFileReference! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/12/2004 16:22'! host: hostName "Set the host name, either 'localhost', '', or a fully qualified domain name." host := hostName! ! !FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'! scheme ^self class schemeName! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 10:16'! host "Return the host name, either 'localhost', '', or a fully qualified domain name." ^host ifNil: ['']! ! !FileUrl methodsFor: 'testing' stamp: 'gk 2/9/2004 20:32'! firstPartIsDriveLetter "Return true if the first part of the path is a letter followed by a $: like 'C:' " | firstPart | path isEmpty ifTrue: [^false]. firstPart := path first. ^firstPart size = 2 and: [ firstPart first isLetter and: [firstPart last = $:]]! ! !FileUrl methodsFor: '*Gofer-Core' stamp: 'SeanDeNigris 8/26/2012 15:40'! mcRepositoryAsUser: usernameString withPassword: passwordString ^ MCDirectoryRepository new directory: self asFileReference.! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 10/21/2005 11:11'! path: aCollection "Set the collection of path elements." path := aCollection! ! !FileUrl methodsFor: 'paths' stamp: 'SvenVanCaekenberghe 10/27/2013 11:43'! pathString "Path as it appears in a URL with $/ as delimiter." ^String streamContents: [ :s | | first | "isAbsolute ifTrue:[ s nextPut: $/ ]." first := true. self path do: [ :p | first ifFalse: [ s nextPut: $/ ]. first := false. s nextPutAll: p urlEncoded ] ]! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 10/21/2005 11:12'! isAbsolute "Should the path be considered absolute to the filesystem instead of relative to the default directory?" ^isAbsolute! ! !FileUrl methodsFor: 'access' stamp: 'CamilloBruni 5/4/2012 21:58'! asFileReference "convert this FileUrl to a FileReference" ^ FileSystem disk root resolve: self pathString ! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 10/21/2005 11:13'! isAbsolute: aBoolean "Set if the path should be considered absolute to the filesystem instead of relative to the default directory." isAbsolute := aBoolean! ! !FileUrl methodsFor: 'private-initialization' stamp: 'SvenVanCaekenberghe 10/25/2013 14:59'! privateInitializeFromText: aString "Calculate host and path from a file URL in String format. Some malformed formats are allowed and interpreted by guessing." | schemeName pathString bare i | bare := aString trimBoth. schemeName := self class schemeNameForString: bare. (schemeName isNil or: [schemeName ~= self schemeName]) ifTrue: [ host := ''. pathString := bare] ifFalse: [ "First remove schemeName and colon" bare := bare copyFrom: (schemeName size + 2) to: bare size. "A proper file URL then has two slashes before host, A malformed URL is interpreted as using syntax file:." (bare beginsWith: '//') ifTrue: [i := bare indexOf: $/ startingAt: 3. i=0 ifTrue: [ host := bare copyFrom: 3 to: bare size. pathString := ''] ifFalse: [ host := bare copyFrom: 3 to: i-1. pathString := bare copyFrom: host size + 3 to: bare size]] ifFalse: [host := ''. pathString := bare]]. self initializeFromPathString: pathString ! ! !FileUrl methodsFor: 'private-initialization' stamp: 'SvenVanCaekenberghe 10/27/2013 12:19'! privateInitializeFromText: pathString relativeTo: aUrl " should be a filesystem path. This url is adjusted to be aUrl + the path." | newPath | self host: aUrl host. self initializeFromPathString: pathString. self isAbsolute: aUrl isAbsolute. newPath := aUrl path copy. newPath removeLast. "empty string that says its a directory" path do: [ :token | ((token ~= '..') and: [token ~= '.']) ifTrue: [ newPath addLast: token urlDecoded ]. token = '..' ifTrue: [ newPath isEmpty ifFalse: [ newPath last = '..' ifFalse: [ newPath removeLast ] ] ]. "token = '.' do nothing" ]. path := newPath ! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/10/2004 13:05'! host: aHostString pathParts: aCollection isAbsolute: aBoolean host := aHostString. path := aCollection. isAbsolute := aBoolean! ! !FileUrl methodsFor: 'copying' stamp: 'nice 1/13/2010 21:57'! postCopy "Be sure not to share the path with the copy." super postCopy. path := path copy! ! !FileUrl methodsFor: 'downloading' stamp: 'CamilloBruni 5/7/2012 01:13'! default "Use the default local Pharo file directory." | local | local := self class pathParts: (FileSystem workingDirectory pathSegments), #('') isAbsolute: true. self privateInitializeFromText: self pathString relativeTo: local. "sets absolute also"! ! !FileUrl methodsFor: 'private-initialization' stamp: 'SvenVanCaekenberghe 10/27/2013 12:19'! initializeFromPathString: aPathString " is a file path as a String. We construct a path collection using various heuristics." | pathString hasDriveLetter | pathString := aPathString. pathString isEmpty ifTrue: [pathString := '/']. path := (pathString findTokens: '/') collect: [:token | token urlDecoded]. "A path like 'C:' refers in practice to 'c:/'" ((pathString endsWith: '/') or: [(hasDriveLetter := self firstPartIsDriveLetter) and: [path size = 1]]) ifTrue: [path add: '']. "Decide if we are absolute by checking for leading $/ or beginning with drive letter. Smarts for other OSes?" self isAbsolute: ((pathString beginsWith: '/') or: [hasDriveLetter ifNil: [self firstPartIsDriveLetter]])! ! !FileUrl methodsFor: 'paths' stamp: 'CamilloBruni 5/7/2012 01:13'! pathForDirectory "Path using local file system's pathname delimiter. DOS paths with drive letters should not be prepended with a delimiter even though they are absolute. Filename is left out." | delimiter | delimiter := FileSystem disk separator. ^String streamContents: [ :s | (self isAbsolute and: [self firstPartIsDriveLetter not]) ifTrue: [ s nextPut: delimiter ]. 1 to: self path size - 1 do: [ :ii | s nextPutAll: (path at: ii); nextPut: delimiter]]! ! !FileUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:42'! hasContents ^true! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/10/2004 13:04'! pathParts: aCollection isAbsolute: aBoolean ^self host: nil pathParts: aCollection isAbsolute: aBoolean! ! !FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:06'! pathParts: aCollectionOfPathParts isAbsolute: aBoolean "Create a FileUrl." ^self host: nil pathParts: aCollectionOfPathParts isAbsolute: aBoolean! ! !FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:04'! host: aHost pathParts: aCollectionOfPathParts isAbsolute: aBoolean "Create a FileUrl." ^self new host: aHost pathParts: aCollectionOfPathParts isAbsolute: aBoolean! ! !FileUrl class methodsFor: 'constants' stamp: 'gk 2/10/2004 10:33'! schemeName ^'file'! ! !FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:10'! pathParts: aCollectionOfPathParts "Create a FileUrl." ^self host: nil pathParts: aCollectionOfPathParts isAbsolute: true! ! !FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 12:16'! absoluteFromText: aString "Method that can be called explicitly to create a FileUrl." ^self new privateInitializeFromText: aString! ! !FileUrlTest commentStamp: 'TorstenBergmann 2/5/2014 10:13'! SUnit tests for FileUrl! !FileUrlTest methodsFor: 'testing' stamp: 'fbs 2/2/2005 12:43'! testAsString | target url | target := 'file://localhost/etc/rc.conf'. url := target asUrl. self assert: url asString = target. ! ! !FileUrlTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 10/25/2013 18:51'! testNew [ super testNew ] on: Deprecation do: [ :notification | notification resume ]! ! !FileWriteError commentStamp: 'TorstenBergmann 2/3/2014 23:38'! Notify about an error when trying to attempt to write to a file! !FillStyle commentStamp: ''! FillStyle is an abstract base class for fills in the BalloonEngine.! !FillStyle methodsFor: 'converting' stamp: 'ar 6/4/2001 00:41'! mixed: fraction with: aColor ^self asColor mixed: fraction with: aColor! ! !FillStyle methodsFor: 'testing' stamp: 'ar 6/18/1999 07:57'! isOrientedFill "Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)" ^false! ! !FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'! isBitmapFill ^false! ! !FillStyle methodsFor: 'converting' stamp: 'Sd 11/2/2010 12:54'! asColor ^self subclassResponsibility ! ! !FillStyle methodsFor: 'testing' stamp: 'ar 10/26/2000 19:24'! isTransparent ^false! ! !FillStyle methodsFor: 'testing' stamp: 'gvc 3/20/2008 23:03'! isCompositeFill "Answer whether the receiver is a composite fill. False by default." ^false! ! !FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'! isGradientFill ^false! ! !FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'! isSolidFill ^false! ! !FillStyle methodsFor: 'accessing' stamp: 'ar 1/14/1999 15:23'! scaledPixelValue32 "Return a pixel value of depth 32 for the primary color in the fill style" ^self asColor scaledPixelValue32! ! !FillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:28'! isTranslucent ^true "Since we don't know better"! ! !FillStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/21/2008 16:35'! fillRectangle: aRectangle on: aCanvas "Fill the given rectangle on the given canvas with the receiver." aCanvas fillRectangle: aRectangle basicFillStyle: self! ! !FillStyleBorder commentStamp: 'gvc 9/23/2008 11:56'! BorderStyle supporting general (potentially composite) fillstyles. ! !FillStyleBorder methodsFor: 'drawing' stamp: 'gvc 6/24/2008 16:15'! frameRectangle: aRectangle on: aCanvas "Fill the border areas with the fill style, clipping for each segment." (self borderRectsFor: aRectangle) do: [:r | aCanvas fillRectangle: r fillStyle: self fillStyle]! ! !FillStyleBorder methodsFor: 'accessing' stamp: 'gvc 6/24/2008 16:20'! fillStyle: anObject "Set the value of fillStyle" fillStyle := anObject. anObject ifNotNil: [self baseColor: anObject asColor]! ! !FillStyleBorder methodsFor: 'accessing' stamp: 'gvc 6/24/2008 16:18'! fillStyle "Answer the value of fillStyle" ^fillStyle ifNil: [self color]! ! !FillStyleBorder methodsFor: 'testing' stamp: 'gvc 6/25/2008 12:11'! hasFillStyle "Answer true." ^true! ! !FillStyleBorder methodsFor: 'geometry' stamp: 'gvc 6/24/2008 16:19'! borderRectsFor: aRectangle "Answer a collection of rectangles to fill. Just four here for a rectangular border." |rTop rBottom rLeft rRight w| w := self width. rTop := aRectangle topLeft corner: aRectangle right @ (aRectangle top + w). rBottom := aRectangle left @ (aRectangle bottom - w) corner: aRectangle bottomRight. rLeft := aRectangle left @ (aRectangle top + w) corner: aRectangle left + w @ (aRectangle bottom - w). rRight := aRectangle right - w @ (aRectangle top + w) corner: aRectangle right @ (aRectangle bottom - w). ^{rTop. rBottom. rLeft. rRight}! ! !FillStyleTest commentStamp: ''! A FillStyleTest is a test class for testing the behavior of FillStyle! !FillStyleTest methodsFor: 'tests' stamp: 'AlexandreBergel 1/29/2013 14:02'! testIsTransparentWithTranslucentColor colorStyle color: (Color red alpha: 0.5). self deny: colorStyle isTransparent. self assert: colorStyle isTranslucent.! ! !FillStyleTest methodsFor: 'tests' stamp: 'AlexandreBergel 1/29/2013 14:01'! testIsTransparentWithNonTransparentColors colorStyle color: Color red. self deny: colorStyle isTransparent ! ! !FillStyleTest methodsFor: 'tests' stamp: 'AlexandreBergel 1/29/2013 14:04'! testIsTransparentWithTransparentColor colorStyle color: (Color red alpha: 0). self assert: colorStyle isTransparent. self assert: colorStyle isTranslucent. self deny: composite isTransparent. self assert: composite isTranslucent. "Because we do not know better, as said in the comment"! ! !FillStyleTest methodsFor: 'running' stamp: 'AlexandreBergel 1/29/2013 14:00'! setUp super setUp. composite := CompositeFillStyle new. colorStyle := ColorFillStyle new. composite fillStyles: (Array with: ImageFillStyle new with: colorStyle)! ! !FillStyleTest methodsFor: 'tests' stamp: 'AlexandreBergel 1/29/2013 14:00'! testIsTransparentWithNoColor self deny: composite isTransparent! ! !FilterTest commentStamp: 'TorstenBergmann 1/31/2014 11:30'! SUnit test for debugger filters! !FilterTest methodsFor: 'tests' stamp: 'AndreiChis 9/30/2013 11:01'! testBlockFilter | fromBlockFilter | fromBlockFilter := [ :ctx | ctx isNotNil ] asFilter. self assert: (fromBlockFilter shouldDisplay: context)! ! !FilterTest methodsFor: 'tests' stamp: 'AndreiChis 9/30/2013 11:01'! testKernelClassesFilter | kernelClassesFilter setContext | setContext := session stepInto stepInto stack first. kernelClassesFilter := KernelClassesFilter new. self assert: (kernelClassesFilter shouldDisplay: context). self assert: (kernelClassesFilter shouldDisplay: nilContext). self deny: (kernelClassesFilter shouldDisplay: setContext)! ! !FilterTest methodsFor: 'tests' stamp: 'AndreiChis 9/30/2013 11:01'! testBooleanFilter | kernelFilter doItFilter filters booleanFilter | kernelFilter := KernelClassesFilter new. doItFilter := SelectorFilter forSelector: #doIt. filters := OrderedCollection with: kernelFilter with: doItFilter. booleanFilter := BooleanFilter withFilters: filters operator: #or:. self assert: (booleanFilter shouldDisplay: context)! ! !FilterTest methodsFor: 'running' stamp: 'AndreiChis 9/30/2013 11:00'! setUp context := [ (Set with: 1 with: 2) collect: [ :e | e * 2 ]. self halt ] asContext. process := Process forContext: context priority: Processor userInterruptPriority. session := DebugSession process: process context: context. nilContext := [ self isNil ] asContext. otherProcess := Process forContext: nilContext priority: Processor userInterruptPriority. otherSession := (DebugSession process: otherProcess context: nilContext) stepInto! ! !FilterTest methodsFor: 'tests' stamp: 'AndreiChis 9/30/2013 11:01'! testSelectorFilter | doItFilter nilMessagesFilter | doItFilter := SelectorFilter forSelector: #doIt. self assert: (doItFilter shouldDisplay: context). self assert: (doItFilter shouldDisplay: nilContext). nilMessagesFilter := SelectorFilter forSelectors: (OrderedCollection with: #isNil with: #ifNil:). self assert: (nilMessagesFilter shouldDisplay: context) "self deny: (nilMessagesFilter shouldDisplay: otherSession context)"! ! !FindReplaceService commentStamp: 'TorstenBergmann 1/31/2014 12:21'! Model for a find and replace service in editors! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 12:35'! searchBackwards ^ searchBackwards ifNil: [searchBackwards := false]! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 12:35'! isRegex ^ isRegex ifNil: [isRegex := false]! ! !FindReplaceService methodsFor: 'services' stamp: 'AlainPlantec 11/18/2010 09:08'! findRegex | s | s := self entireWordsOnly ifTrue: ['\<', self regexString, '\>'] ifFalse: [ self regexString]. [^ self caseSensitive ifTrue: [s asRegex] ifFalse: [s asRegexIgnoringCase]] on: Error do: [self changed: #regexError. ^ '' asRegex] ! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:50'! findTextSilently: aStringOrText findText := aStringOrText asText. self changed: #findText! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 12:47'! replaceText ^ replaceText ifNil: [replaceText := '']! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:23'! isRegex: aBoolean isRegex := aBoolean. self changed: #findPolicy ! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/16/2010 08:34'! replaceText: aStringOrText replaceText := aStringOrText asString. self changed: #findPolicy ! ! !FindReplaceService methodsFor: 'services' stamp: 'AlainPlantec 4/27/2011 15:34'! replaceInTextMorph: aTextMorph findStartIndex := self searchBackwards ifTrue: [aTextMorph editor stopIndex] ifFalse: [aTextMorph editor startIndex]. (self findInTextMorph: aTextMorph) ifNotNil: [aTextMorph replaceSelectionWith: self replaceText]! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:24'! wrapAround: aBoolean wrapAround := aBoolean. self changed: #findPolicy ! ! !FindReplaceService methodsFor: 'services' stamp: 'AlainPlantec 4/27/2011 15:26'! findNextSubString: aSubString inTextMorph: aTextMorph | where | findStartIndex ifNil: [findStartIndex := aTextMorph editor startIndex]. findStartIndex > 0 ifTrue: [where := aTextMorph findNextString: aSubString asString startingAt: findStartIndex]. (where isNil and: [self wrapAround]) ifTrue: [where := aTextMorph findNextString: aSubString asString startingAt: 1]. ^ where ! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:59'! convertedFindString | specials | specials := '^$:\+*[]()'. ^String streamContents: [:s | self findString do: [:c | (specials includes: c) ifTrue: [s nextPut:$\]. s nextPut: c]]! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:55'! findText ^ (findText ifNil: [findText := '' asText. findText]) asString! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:23'! searchBackwards: aBoolean searchBackwards := aBoolean. self changed: #findPolicy ! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:22'! caseSensitive: aBoolean caseSensitive := aBoolean. self changed: #findPolicy! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 08:19'! findText: aStringOrText isRegex: aBoolean entireWordsOnly: forEntireWordsOnly self isRegex: aBoolean. self findText: aStringOrText. self entireWordsOnly: forEntireWordsOnly! ! !FindReplaceService methodsFor: 'services' stamp: 'AlainPlantec 11/11/2010 23:46'! replaceAllInTextMorph: aTextMorph | startIdx | startIdx := self wrapAround ifTrue: [1] ifFalse: [aTextMorph editor selectionInterval first]. aTextMorph replaceAll: self findRegex with: self replaceText startingAt: startIdx ! ! !FindReplaceService methodsFor: 'services' stamp: 'AlainPlantec 11/21/2010 22:00'! findInTextMorph: aTextMorph | where | findStartIndex ifNil: [findStartIndex := self searchBackwards ifTrue: [aTextMorph editor stopIndex] ifFalse: [aTextMorph editor startIndex]]. findStartIndex > 0 ifTrue: [where := aTextMorph findAndSelect: self findRegex startingAt: findStartIndex searchBackwards: self searchBackwards]. (where isNil and: [self wrapAround]) ifTrue: [ | idx | idx := self searchBackwards ifTrue: [aTextMorph editor string size] ifFalse: [1]. where := aTextMorph findAndSelect: self findRegex startingAt: idx searchBackwards: self searchBackwards]. where ifNil: [aTextMorph flash]. ^ where ! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:59'! regexString ^ self isRegex ifTrue: [self findString] ifFalse: [self convertedFindString] ! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 12:08'! findText: aStringOrText isRegex: isReg caseSensitive: isCaseSensitive entireWordsOnly: forEntireWordsOnly self isRegex: isReg. self findText: aStringOrText. self entireWordsOnly: forEntireWordsOnly. self caseSensitive: isCaseSensitive! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 12:35'! wrapAround ^ wrapAround ifNil: [wrapAround := true]! ! !FindReplaceService methodsFor: 'updating' stamp: 'AlainPlantec 11/10/2010 19:43'! updateFindStartIndexForTextMorph: aTextMorph | si | si := aTextMorph editor selectionInterval. self findStartIndex: (self searchBackwards ifTrue: [si first - 1] ifFalse: [si last + 1])! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:22'! entireWordsOnly: aBoolean entireWordsOnly := aBoolean. self changed: #findPolicy! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:59'! selectionRegexString ^ self convertedFindString ! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2010 17:56'! findText: aStringOrText isRegex: aBoolean self isRegex: aBoolean. self findText: aStringOrText. self replaceText: ''. ! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 12:06'! caseSensitive ^ caseSensitive ifNil: [caseSensitive := TextEditor caseSensitiveFinds]! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:49'! findText: aStringOrText findText := aStringOrText asText. self changed: #findPolicy! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 12:35'! entireWordsOnly ^ entireWordsOnly ifNil: [entireWordsOnly := false]! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 19:39'! findStartIndex ^ findStartIndex! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 19:39'! findStartIndex: anInteger findStartIndex := anInteger! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:55'! findString ^ self findText asString! ! !FindReplaceService class methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:07'! default ^ EditorFindReplaceDialogWindow singleton state ! ! !Finder commentStamp: 'BenjaminVanRyseghem 9/15/2010 11:17'! I'm the finderUI model in the MVC pattern. I'm compute the search string and I construct a resultDictionary. Then I throw events everywhere and my views are redrawn.! !Finder methodsFor: 'private' stamp: 'sd 4/21/2011 15:56'! resetEnvironment "I send an event when I reset the environment" self environment: self defaultEnvironment. self triggerEvent: #resetEnvironment.! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:55'! searchingString: aString "When the search string is modified (in fact, when I make a search) I rebuild the result dictionary" searchingString := aString. self constructDictionary.! ! !Finder methodsFor: 'private-pragma' stamp: 'BenjaminVanRyseghem 2/21/2012 08:46'! constructDictionaryWithPragmaSearch: aString "construct dictionary when searching for pragmas" | dictionary | dictionary := self pragmaSearch: aString. dictionary keysDo:[ :k || result | result := Dictionary new. (dictionary at: k) do: [:method || key value | key := method selector. value := method methodClass. (result at: key ifAbsentPut: OrderedCollection new ) add: value]. dictionary at: k put: result ]. self resultDictionary: dictionary.! ! !Finder methodsFor: 'private' stamp: 'CamilloBruni 10/10/2012 13:57'! methodSearch: aSelectBlock | result | result := OrderedCollection new. self packagesSelection do: [ :class | class methodsDo: [ :method | (aSelectBlock value: method) ifTrue: [ result add: method ]]. class classSide methodsDo: [ :method | (aSelectBlock value: method) ifTrue: [ result add: method ]]] displayingProgress: [ :aClass | aClass name ]. ^ result! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:55'! selectedMethod "I should answer a CompiledMethod" ^selectedMethod! ! !Finder methodsFor: 'initialization' stamp: 'sd 4/21/2011 15:50'! initialize super initialize. searchingString := self defaultString. environment := self defaultEnvironment. packagesSelection := self defaultPackagesSelection. resultDictionary := Dictionary new. currentSearchMode := #Selectors. useRegEx := false. ! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:50'! environment: aCollection environment := aCollection! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:55'! searchingString ^searchingString! ! !Finder methodsFor: 'private-class' stamp: 'CamilloBruni 10/10/2012 13:56'! computeListOfClasses: aString "Compute in the case I'm searching class names" ^ self useRegEx ifTrue: [ | regex | regex := aString asRegex. self classSearch: [ :class | regex search: class name ]] ifFalse: [ self classSearch: [ :class | class name includesSubstring: aString caseSensitive: false ]].! ! !Finder methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! defaultPackagesSelection ^ self environment! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:56'! packagesSelection: aCollection "I change the classes selection, then I rebuild the result dictionary" packagesSelection := aCollection. self constructDictionary.! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:55'! resultDictionary: aDictionary "When the result dictionary is update, I send an event through the whole universe" resultDictionary := aDictionary. self triggerEvent: #updateResultDictionary. self selectedMethod: nil. self selectedClass: nil. self triggerEvent: #updateSourceCode.! ! !Finder methodsFor: 'private' stamp: 'sd 4/21/2011 15:49'! enableUseRegEx "send a enable useRegEx dropbox event" ^ self triggerEvent: #enableUseRegEx! ! !Finder methodsFor: 'private' stamp: 'CamilloBruni 10/9/2012 20:47'! sourceSearch: aSearchString "I'm searching in sources" ^ self useRegEx ifTrue: [ self sourceRegexSearch: aSearchString ] ifFalse:[ self sourceStringSearch: aSearchString ].! ! !Finder methodsFor: 'private-example' stamp: 'Anonymous 12/11/2013 13:25'! computeWithMethodFinder: aString "Compute the selectors for the single example of receiver and args, in the very top pane" | data result resultArray dataStrings methodFinder dataObjects temporarySearchResult statements | (aString includes: $.) ifFalse: [ ^ #() ]. "delete trailing period. This should be fixed in the Parser!!" data := aString trimRight: [ :char | char isSeparator or: [ char = $. ] ]. methodFinder := MethodFinder new. data := methodFinder cleanInputs: data. "remove common mistakes" [ dataObjects := Smalltalk compiler evaluate: '{' , data , '}' ] on: SyntaxErrorNotification do: [ :e | self inform: 'Syntax Error: ' , e errorMessage. self contents: e errorCode allButFirst allButLast. ^ #() ]. "#( data1 data2 result )" statements := (self class compiler parse: 'zort ' , data) body statements reject: [ :each | each isReturn ]. dataStrings := statements collect: [ :node | String streamContents: [ :strm | node isMessage ifTrue: [ strm nextPut: $( ]. strm << node formattedCode. node isMessage ifTrue: [ strm nextPut: $) ] ] ]. dataObjects size < 2 ifTrue: [ self inform: 'If you are giving an example of receiver, \args, and result, please put periods between the parts.\Otherwise just type one selector fragment' withCRs. ^ #() ]. dataObjects := Array with: dataObjects allButLast with: dataObjects last. "#( (data1 data2) result )" result := methodFinder load: dataObjects; findMessage. (result first beginsWith: 'no single method') ifFalse: [ temporarySearchResult := self testObjects: dataObjects strings: dataStrings. dataObjects := temporarySearchResult second. dataStrings := temporarySearchResult third ]. resultArray := self listFromResult: result. resultArray isEmpty ifTrue: [ self inform: result first ]. dataStrings size = (dataObjects first size + 1) ifTrue: [ resultArray := resultArray collect: [ :expression | | newExp | newExp := expression. dataObjects first withIndexDo: [ :lit :i | newExp := newExp copyReplaceAll: 'data' , i printString with: (dataStrings at: i) ]. newExp , ' --> ' , dataStrings last ] ]. ^ resultArray! ! !Finder methodsFor: 'private-selector' stamp: 'sd 4/21/2011 15:40'! constructDictionaryWithMessagesNameSearch: aString "Construct dictionary when searching for selector" | result listOfMethods | result := Dictionary new. listOfMethods := self messagesNameSearch: aString. listOfMethods do: [:method || key value | key := method selector. value := method methodClass. (result includesKey: key) ifTrue: [ (result at: key) add: value] ifFalse: [ result at: key put: (OrderedCollection new add: value; yourself)]]. self resultDictionary: result.! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:52'! useRegEx "I should answer a boolean that tells whether regExpression should be taken into account" ^ useRegEx! ! !Finder methodsFor: 'initialize-release' stamp: 'sd 4/21/2011 15:52'! uiClass "Answer the class used to create UI" ^FinderUI! ! !Finder methodsFor: 'initialize-release' stamp: 'sd 4/21/2011 15:49'! defaultEnvironment ^ Smalltalk globals allClassesAndTraits.! ! !Finder methodsFor: 'private' stamp: 'CamilleTeruel 1/8/2013 12:54'! classSearch: aSelectBlock | result | result := OrderedCollection new. self packagesSelection do: [ :class | (aSelectBlock value: class) ifTrue: [ result add: class ] ] displayingProgress: [ :aClass | aClass name ]. ^ result! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:49'! currentSearchMode "Getter" "I shoud answer a Symbol in : - #Selectors - #Classes - #Source - #Examples" ^ currentSearchMode! ! !Finder methodsFor: 'private-selector' stamp: 'CamilloBruni 10/10/2012 11:20'! messageSearchBlockFrom: aString | exactMatch | exactMatch := aString first = $" and: [ aString last = $"]. exactMatch ifFalse: [ ^ [ :method | method selector includesSubstring: aString caseSensitive: false ]]. ^ (Symbol findInterned: (aString copyFrom: 2 to: aString size - 1)) ifNil: [ nil ] ifNotNil: [ :aSymbol | [ :method | method selector = aSymbol ]].! ! !Finder methodsFor: 'display' stamp: 'FernandoOlivero 5/30/2011 09:59'! open ^ (self uiClass on: self) open! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:55'! resultDictionary "I should answer a dictionary" ^resultDictionary! ! !Finder methodsFor: 'private-class' stamp: 'MarcusDenker 5/7/2013 23:28'! constructClassNamesDictionary "Construct the dictionary in the case I'm searching in class names" | result listOfClasses | listOfClasses := self computeListOfClasses: self searchingString. result := Dictionary new. listOfClasses do: [:each | result at: each put: (each selectors sort: [:a :b | a < b])]. self resultDictionary: result.! ! !Finder methodsFor: 'private' stamp: 'MarcusDenker 5/18/2013 15:44'! findSelector: aString "Answer the selector of aString." | example tokens | example := aString. tokens := example parseLiterals. tokens size = 1 ifTrue: [^ tokens first]. tokens first == #'^' ifTrue: [^ nil]. (tokens second includes: $:) ifTrue: [^ example findSelector]. Symbol hasInterned: tokens second ifTrue: [:aSymbol | ^ aSymbol]. ^ nil! ! !Finder methodsFor: 'checkbox' stamp: 'BenjaminVanRyseghem 5/14/2012 13:45'! isClassNamesSymbol "answer if the current mode is Classes" ^self currentSearchMode = #Classes! ! !Finder methodsFor: 'private' stamp: 'CamilloBruni 10/10/2012 14:07'! testObjects: dataObjects strings: dataStrings "Try to make substitutions in the user's inputs and search for the selector again. 1 no change to answer. 2 answer Array -> OrderedCollection. 2 answer Character -> String 4 answer Symbol or String of len 1 -> Character For each of these, try straight, and try converting args: Character -> String Symbol or String of len 1 -> Character Return array with result, dataObjects, dataStrings. Don't ever do a find on the same set of data twice." | selectors classes didUnmodifiedAnswer | selectors := {#asString. #first. #asOrderedCollection}. classes := {Character. String. Array}. didUnmodifiedAnswer := false. selectors withIndexDo: [:ansSel :ansInd | | tempDataObjects result tempDataStrings answerMod | "Modify the answer object" answerMod := false. tempDataObjects := dataObjects copyTwoLevel. tempDataStrings := dataStrings copy. (dataObjects last isKindOf: (classes at: ansInd)) ifTrue: [ ((ansSel ~~ #first) or: [dataObjects last size = 1]) ifTrue: [ tempDataObjects at: tempDataObjects size put: (tempDataObjects last perform: ansSel). "asString" tempDataStrings at: tempDataStrings size put: tempDataStrings last, ' ', ansSel. result := MethodFinder new load: tempDataObjects; findMessage. (result first beginsWith: 'no single method') ifFalse: [ "found a selector!!" ^ Array with: result first with: tempDataObjects with: tempDataStrings]. answerMod := true]]. selectors allButLast withIndexDo: [:argSel :argInd | | dds ddo | "Modify an argument object" "for args, no reason to do Array -> OrderedCollection. Identical protocol." didUnmodifiedAnswer not | answerMod ifTrue: [ ddo := tempDataObjects copyTwoLevel. dds := tempDataStrings copy. dataObjects first withIndexDo: [:arg :ind | (arg isKindOf: (classes at: argInd)) ifTrue: [ ((argSel ~~ #first) or: [arg size = 1]) ifTrue: [ ddo first at: ind put: ((ddo first at: ind) perform: argSel). "asString" dds at: ind put: (dds at: ind), ' ', argSel. result := MethodFinder new load: ddo; findMessage. (result first beginsWith: 'no single method') ifFalse: [ "found a selector!!" ^ Array with: result first with: ddo with: dds]. didUnmodifiedAnswer not & answerMod not ifTrue: [ didUnmodifiedAnswer := true]. ]]]]]. ]. ^ Array with: 'no single method does that function' with: dataObjects with: dataStrings! ! !Finder methodsFor: 'checkbox' stamp: 'SeanDeNigris 6/25/2012 15:06'! isExamplesSymbol "Answer if the current mode is Examples" ^self currentSearchMode = #Examples! ! !Finder methodsFor: 'private-selector' stamp: 'CamilloBruni 10/10/2012 11:17'! messagesNameSearch: aString "I'm searching for selectors" ^ self useRegEx ifTrue: [ | regex | regex := aString asRegex. self methodSearch: [ :method| regex search: method selector asString ]] ifFalse: [ self methodSearch: (self messageSearchBlockFrom: aString)].! ! !Finder methodsFor: 'checkbox' stamp: 'BenjaminVanRyseghem 9/15/2010 23:23'! isSelectorsSymbol "answer if the current mode is Selectors" ^self currentSearchMode = #Selectors! ! !Finder methodsFor: 'accessing' stamp: 'SeanDeNigris 6/25/2012 15:05'! currentSearchMode: aSymbol "Setter" "If #Examples is selected, I disable the RegEx checkbo. Then I rebuild the resultDictionary" currentSearchMode := aSymbol. self isExamplesSymbol ifTrue: [ self disableUseRegEx] ifFalse:[ self enableUseRegEx]. self update: #sourceCode. self constructDictionary! ! !Finder methodsFor: 'accessing' stamp: 'CamilloBruni 10/10/2012 13:57'! environment "Gette: I should be a classes collection" ^ environment reject: [:each | each isObsolete].! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:55'! selectedMethod: aMethod "When the method seletion is changed, I send an event to UI" selectedMethod := aMethod. self triggerEvent: #updateSelectedMethod! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:55'! selectedClass: aClass "When the class seletion is changed, I send an event to UI" selectedClass := aClass. self triggerEvent: #updateSelectedClass ! ! !Finder methodsFor: 'private' stamp: 'sd 4/21/2011 15:57'! listFromResult: resultOC "The argument, resulOC, is of the form #('(data1 op data2)' '(...)'). Answer a sorted array." (resultOC first beginsWith: 'no single method') ifTrue: [^ #()]. ^ resultOC sort: [:a :b | (a copyFrom: 6 to: a size) < (b copyFrom: 6 to: b size)]. ! ! !Finder methodsFor: 'accessing' stamp: 'NicolaiHess 11/30/2013 14:29'! selection: aSelectionHolder "anObject is a selection holder" "Depending of the value of currentSearchMode, I fill selectedMethod and SelectedClass with the good items." "Then, I update the source code text area" | path methodNode method classNode class | (aSelectionHolder isNil or: [aSelectionHolder selectedNodePath isNil]) ifTrue: [ self selectedClass: nil. self selectedMethod: nil. ^self]. path := aSelectionHolder selectedNodePath. self isSelectorsSymbol ifTrue: [ path first isSingle ifTrue: [ method := path first itemMethod selector. class := path first itemMethod methodClass ] ifFalse: [ methodNode := path first. classNode := path at: 2 ifAbsent: [ nil ]]]. self isClassNamesSymbol ifTrue: [ classNode := path first. methodNode := path at: 2 ifAbsent:[nil]]. self isSourceSymbol ifTrue: [ methodNode := path first. classNode := path at: 2 ifAbsent:[nil]]. self isExamplesSymbol ifTrue: [ methodNode := path first. classNode := path at: 2 ifAbsent:[nil]]. self isPragmasSymbol ifTrue: [ methodNode := path at:2 ifAbsent: [ nil ]. classNode := path at: 3 ifAbsent:[nil]]. classNode ifNotNil: [ class := classNode item ]. self selectedClass: class. methodNode ifNotNil: [ method := methodNode item ]. self selectedMethod: method. self triggerEvent: #updateSourceCode! ! !Finder methodsFor: 'private-example' stamp: 'MarcusDenker 10/15/2013 18:15'! constructDictionaryWithMethodFinder: aString "construct dictionary when searching patterns" | result listOfStrings listOfSelectors | result := Dictionary new. listOfStrings := self computeWithMethodFinder: aString. listOfSelectors := listOfStrings collect: [ :each | self findSelector: each ]. self packagesSelection do: [ :class | class methodDict do: [ :method | | index | (index := listOfSelectors indexOf: method selector) = 0 ifFalse: [ | key value | key := listOfStrings at: index. value := method methodClass. (result includesKey: key) ifTrue: [ (result at: key) add: value ] ifFalse: [ result at: key put: (OrderedCollection new add: value; yourself) ] ] ] ]. self resultDictionary: result! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:51'! useRegEx: aBoolean useRegEx := aBoolean.! ! !Finder methodsFor: 'checkbox' stamp: 'sd 4/21/2011 15:50'! isSourceSymbol "answer if the current mode is Source" ^self currentSearchMode = #Source! ! !Finder methodsFor: 'private' stamp: 'CamilloBruni 10/9/2012 20:47'! sourceRegexSearch: aSearchString | regex | regex := aSearchString asRegex. ^ self methodSearch: [ :method | regex search: method sourceCode ]! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:55'! selectedClass ^selectedClass! ! !Finder methodsFor: 'private' stamp: 'CamilloBruni 10/9/2012 20:47'! sourceStringSearch: aSearchString ^ self methodSearch: [ :method | method sourceCode includesSubstring: aSearchString caseSensitive: false ]! ! !Finder methodsFor: 'private' stamp: 'MarcusDenker 10/15/2013 18:14'! constructDictionary "I construct the adequate dictionary regarding the search mode" self searchingString isEmpty ifTrue: [ ^ self resultDictionary: Dictionary new]. [ :job| job title: 'Searching...'. self isSelectorsSymbol ifTrue: [ self constructDictionaryWithMessagesNameSearch: self searchingString]. self isClassNamesSymbol ifTrue: [ self constructClassNamesDictionary]. self isSourceSymbol ifTrue: [ self constructSourceDictionary]. self isExamplesSymbol ifTrue: [ self constructDictionaryWithMethodFinder: self searchingString]. self isPragmasSymbol ifTrue: [ self constructDictionaryWithPragmaSearch: self searchingString ]. ] asJob run! ! !Finder methodsFor: 'private' stamp: 'CamilloBruni 10/9/2012 20:51'! constructSourceDictionary "construct dictionary when searching source" | result listOfMethods | result := Dictionary new. listOfMethods := self sourceSearch: self searchingString. listOfMethods do: [:method || key value | key := method selector. value := method methodClass. (result includesKey: key) ifTrue: [ (result at: key) add: value] ifFalse: [ result at: key put: (OrderedCollection new add: value; yourself)]]. self resultDictionary: result.! ! !Finder methodsFor: 'private-pragma' stamp: 'CamilloBruni 10/10/2012 13:59'! pragmaSearch: aString | result byCondition | " I choose a dictionary here because the next step is to group result by pragmas " result := Dictionary new. byCondition := self useRegEx ifTrue: [[ :pragma | pragma keyword matchesRegexIgnoringCase: aString ]] ifFalse: [[ :pragma | pragma keyword includesSubstring: aString caseSensitive: false ]]. (PragmaCollector filter: byCondition) reset; do: [ :pragma || pragmaName | pragmaName := String streamContents: [:s | s << '<'; << pragma keyword; << '>' ]. (result at: pragmaName ifAbsentPut: OrderedCollection new) add: pragma method ]. ^ result! ! !Finder methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! defaultString ^''! ! !Finder methodsFor: 'private' stamp: 'sd 4/21/2011 15:49'! disableUseRegEx "send a disable useRegEx dropbox event" ^ self triggerEvent: #disableUseRegEx! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:56'! packagesSelection "I should be a selection of classes" ^packagesSelection! ! !Finder methodsFor: 'accessing' stamp: 'bvr 9/19/2010 18:27'! searchingStringSilently: aString searchingString := aString. ! ! !Finder methodsFor: 'checkbox' stamp: 'BenjaminVanRyseghem 5/14/2012 13:49'! isPragmasSymbol "answer if the current mode is Pragmas" ^self currentSearchMode = #Pragmas! ! !Finder class methodsFor: 'menu' stamp: 'AlainPlantec 2/14/2011 21:25'! open ^ self new open! ! !Finder class methodsFor: 'menu' stamp: 'TorstenBergmann 2/12/2014 09:22'! finderMenuOn: aBuilder "I build a menu" (aBuilder item: #Finder) action: [self open]; order: 0.10; parent: #Tools; help: 'Looking for something ?'; icon: self icon. aBuilder withSeparatorAfter. ! ! !Finder class methodsFor: 'tools registry' stamp: 'IgorStasenko 2/19/2011 03:02'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #finder ! ! !Finder class methodsFor: 'menu' stamp: 'BenjaminVanRyseghem 3/18/2011 11:30'! icon "My menu icon" ^ FinderUI icon! ! !FinderClassNode commentStamp: ''! A FinderClassNode is a node used by the FinderUI's tree representing a Class! !FinderClassNode methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 2/26/2011 12:53'! menu: menu shifted: aBoolean menu add: 'Hierarchy (h)' translated target: self selector: #browseHierarchy. menu add: 'References (N)' translated target: self selector: #browseReferences. ^ super menu: menu shifted: aBoolean.! ! !FinderClassNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/7/2012 18:11'! browseReferences self systemNavigation browseAllCallsOnClass: self item.! ! !FinderClassNode methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 2/26/2011 12:46'! keyStroke: anEvent (anEvent controlKeyPressed or: [ anEvent commandKeyPressed ]) ifFalse: [ ^ false ]. anEvent keyCharacter == $h ifTrue: [ ^ self browseHierarchy ]. anEvent keyCharacter == $N ifTrue: [ ^ self browseReferences ]. ^ super keyStroke: anEvent.! ! !FinderClassNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/7/2012 18:11'! browseHierarchy self systemNavigation browseHierarchy: self item! ! !FinderClassNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/15/2010 12:06'! childrenItems "I search the children, if I have not got any, I call my super method" ^ (self model resultDictionary at: self item ifAbsent:[^super childrenItems])! ! !FinderClassNode methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 21:03'! childNodeClassFromItem: anItem "The children (if there are some) are instances of FinderMethodNode (in the case of a Classes research)" ^ FinderMethodNode ! ! !FinderClassNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/8/2012 17:08'! browse self hasParentNode ifFalse: [ ^ super browseClass ]. ^ self browseClass! ! !FinderClassNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/8/2012 17:08'! browseClass ^ Smalltalk tools browser fullOnClass: self item selector: self parentNode item! ! !FinderExampleClassNode commentStamp: ''! A FinderExampleClassNode is a node used by the FinderUI's tree representing the Class for the method deduced from an examples (by MethodFinder)! !FinderExampleClassNode methodsFor: 'private' stamp: 'NicolaiHess 12/22/2013 00:25'! displayString (self parentNode receiver isKindOf: self item) ifTrue: [ ^ '*' , super displayString ]. ^ super displayString! ! !FinderExampleMethodNode commentStamp: ''! A FinderExampleMethodNode is a node used by the FinderUI's tree representing a Method deduced from an examples (by MethodFinder)! !FinderExampleMethodNode methodsFor: 'private' stamp: 'NicolaiHess 12/22/2013 00:03'! selector ^ self model finder findSelector: self item! ! !FinderExampleMethodNode methodsFor: 'private' stamp: 'NicolaiHess 12/22/2013 00:35'! receiver |index rec| index:=self item findString: self selector. rec:= self item copyFrom:1 to:(index-1). ^ Compiler evaluate:rec! ! !FinderExampleMethodNode methodsFor: 'private' stamp: 'NicolaiHess 12/22/2013 00:08'! childNodeClassFromItem: anItem "I answer the class of my children nodes (if I have some)" ^ FinderExampleClassNode! ! !FinderMethodNode commentStamp: ''! A FinderMethodNode is a node used by the FinderUI's tree representing a Method! !FinderMethodNode methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 2/26/2011 12:49'! addInspectMenuItem: menu self hasParentNode ifTrue: [ ^ super addInspectMenuItem: menu ].! ! !FinderMethodNode methodsFor: 'private' stamp: 'NicolaiHess 12/21/2013 23:56'! browseImplementors SystemNavigation new browseImplementorsOf: self selector name: 'Implementors of ', self selector autoSelect: nil! ! !FinderMethodNode methodsFor: 'private' stamp: 'NicolaiHess 12/21/2013 23:56'! selector ^ self item! ! !FinderMethodNode methodsFor: 'private' stamp: 'NicolaiHess 12/22/2013 00:05'! browseSenders SystemNavigation new browseSendersOf: self selector name: 'Senders of ', self selector autoSelect: self selector! ! !FinderMethodNode methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 2/26/2011 12:54'! menu: menu shifted: aBoolean menu add: 'Implementors (m)' translated target: self selector: #browseImplementors. menu add: 'Senders (n)' translated target: self selector: #browseSenders. ^ super menu: menu shifted: aBoolean.! ! !FinderMethodNode methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 2/26/2011 12:46'! keyStroke: anEvent (anEvent controlKeyPressed or: [ anEvent commandKeyPressed ]) ifFalse: [ ^ false ]. anEvent keyCharacter == $n ifTrue: [ ^ self browseSenders ]. anEvent keyCharacter == $m ifTrue: [ ^ self browseImplementors ]. ^ super keyStroke: anEvent.! ! !FinderMethodNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/14/2012 13:51'! childrenItems "I search the children, if I have not got any, I call my super method" self model isPragmasSymbol ifTrue: [ ^ (self model resultDictionary at: parentNode item ifAbsent:[^super childrenItems]) at: self item ifAbsent: [ ^ super childrenItems]]. ^ (self model resultDictionary at: self item ifAbsent:[^super childrenItems])! ! !FinderMethodNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/15/2010 12:13'! childNodeClassFromItem: anItem "I answer the class of my children nodes (if I have some)" ^ FinderClassNode! ! !FinderMethodNode methodsFor: 'private' stamp: 'MarcusDenker 10/15/2013 18:08'! inspectItem self hasParentNode ifTrue: [ (self parentNode item compiledMethodAt: self item) inspect ].! ! !FinderMethodNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/22/2012 14:42'! isSingle ^ false! ! !FinderMethodNode methodsFor: 'private' stamp: 'CamilloBruni 6/29/2012 11:43'! browse self item isSymbol ifTrue: [ ^ SystemNavigation new browseImplementorsOf: self item name: 'Implementors of ', self item asString autoSelect: nil ]. self item browse.! ! !FinderMethodNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/8/2012 17:08'! browseClass ^ Smalltalk tools browser fullOnClass: self parentNode item selector: self item! ! !FinderNode commentStamp: ''! A FinderNode is an abstract class used by the tree of FinderUI! !FinderNode methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 2/26/2011 12:53'! addInspectMenuItem: menu menu add: 'Inspect (i)' translated target: self selector: #inspectItem.! ! !FinderNode methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 2/26/2011 12:51'! menu: menu shifted: aBoolean menu add: 'Browse (b)' translated target: self selector: #browse. self addInspectMenuItem: menu. menu addLine. menu add: 'Expand All' translated target: self model selector: #expandAll. menu add: 'Collapse All' translated target: self model selector: #collapseAll. ^menu! ! !FinderNode methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 2/26/2011 12:44'! keyStroke: anEvent (anEvent controlKeyPressed or: [ anEvent commandKeyPressed ]) ifFalse: [ ^ false ]. anEvent keyCharacter == $b ifTrue: [ ^ self browse ]. anEvent keyCharacter == $i ifTrue: [ ^ self inspectItem ].! ! !FinderNode methodsFor: 'private' stamp: 'CamilloBruni 2/21/2011 16:05'! inspectItem self item inspect! ! !FinderNode methodsFor: 'private' stamp: 'MarcusDenker 12/21/2013 00:53'! displayString ^ self item asString! ! !FinderNode methodsFor: 'testing' stamp: 'CamilloBruni 2/21/2011 15:47'! hasParentNode ^ self parentNode isNil not! ! !FinderNode methodsFor: 'private' stamp: 'CamilloBruni 2/21/2011 15:29'! doubleClick self browse! ! !FinderNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/3/2011 13:30'! browse self subclassResponsibility! ! !FinderNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/8/2012 17:08'! browseClass ^ Smalltalk tools browser fullOnClass: self item! ! !FinderPlugin commentStamp: ''! I show the finder bar within Nautilus! !FinderPlugin methodsFor: 'display' stamp: 'BenjaminVanRysgehem 4/29/2012 14:01'! openFinderUI "The finder bar calls this method when the user accepts his search query." finderui open. "Without that, if you reuse the same Finder for anotehr research, it will open a new window again" finder removeActionsWithReceiver: self! ! !FinderPlugin methodsFor: 'registration' stamp: 'DamienCassou 4/27/2012 19:18'! registerTo: aModel "I don't see any use of Nautilus notifications for this plugin."! ! !FinderPlugin methodsFor: 'display' stamp: 'BenjaminVanRysgehem 4/28/2012 20:48'! display "Nautilus calls this method when the plugin is first displayed. Show the Finder bar." finder := Finder new. finder when: #updateResultDictionary send: #openFinderUI to: self. finderui := FinderUI on: finder. ^ (finderui buildSearchModeToolBar: StandardWindow new) height: 25! ! !FinderPlugin class methodsFor: 'position' stamp: 'DamienCassou 4/27/2012 19:19'! defaultPosition ^ #top! ! !FinderPlugin class methodsFor: 'information' stamp: 'DamienCassou 4/27/2012 19:21'! description "Use class comment as a description for the plugin" ^ self comment! ! !FinderPragmaNode commentStamp: ''! A FinderPragmaNode is a Node used to render a pragma in the Finder Tree! !FinderPragmaNode methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 2/21/2012 08:29'! menu: menu shifted: aBoolean menu add: 'Hierarchy (h)' translated target: self selector: #browseHierarchy. menu add: 'References (N)' translated target: self selector: #browseReferences. ^ super menu: menu shifted: aBoolean.! ! !FinderPragmaNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/21/2012 08:29'! browseReferences self systemNavigation browseAllCallsOnClass: self item.! ! !FinderPragmaNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/21/2012 08:29'! browseHierarchy! ! !FinderPragmaNode methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 2/21/2012 08:29'! keyStroke: anEvent (anEvent controlKeyPressed or: [ anEvent commandKeyPressed ]) ifFalse: [ ^ false ]. anEvent keyCharacter == $h ifTrue: [ ^ self browseHierarchy ]. anEvent keyCharacter == $N ifTrue: [ ^ self browseReferences ]. ^ super keyStroke: anEvent.! ! !FinderPragmaNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/21/2012 08:49'! childrenItems "I search the children, if I have not got any, I call my super method" ^ (self model resultDictionary at: self item ifAbsent:[^super childrenItems]) keys! ! !FinderPragmaNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/21/2012 08:52'! childNodeClassFromItem: anItem ^ FinderMethodNode ! ! !FinderPragmaNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/21/2012 08:29'! foundReceiverOf: aString "It's ugly, but I haven't found a method that allows me to do that easily" | selector index firstPart | selector := (self model finder findSelector: aString). index := selector indexOf: $:. firstPart := selector. (index = 0) ifFalse: [firstPart := selector copyFrom: 1 to: index]. index := aString findString: firstPart. ^ aString copyFrom: 1 to: (index-1).! ! !FinderPragmaNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/21/2012 08:29'! browse! ! !FinderPragmaNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/21/2012 08:29'! browseClass! ! !FinderSingleMethodNode commentStamp: ''! A FinderSingleMethodNode is a node used to display a selector implemented only once in the system! !FinderSingleMethodNode methodsFor: 'as yet unclassified' stamp: 'NicolaiHess 11/30/2013 14:27'! displayString ^ self itemMethod selector, ' (',self itemMethod methodClass name,')'! ! !FinderSingleMethodNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/22/2012 14:43'! isSingle ^ true! ! !FinderSingleMethodNode methodsFor: 'private' stamp: 'NicolaiHess 11/30/2013 14:26'! itemMethod |itemClass| itemClass:=((self model resultDictionary) at:self item) first. ^ (itemClass>> self item) ! ! !FinderSingleMethodNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/22/2012 14:48'! childrenItems ^ #()! ! !FinderUI commentStamp: ''! A FinderUI is a UI used to render a Finder instance. This tool is used to look for selectors, class, source code or patterns through the system, or through a specified environment! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 2/17/2011 11:06'! buildSearchButton ^ (PluggableButtonMorph on: self getState: #searchButtonState action: #searchButtonAction label: #searchButtonLabel) hResizing: #shrinkWrap! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/23/2011 15:27'! searchingString: aString ^self finder searchingString: aString! ! !FinderUI methodsFor: 'items creation' stamp: 'sd 3/25/2012 20:45'! buildSourceTextArea sourceTextArea := PluggableTextMorph on: self text: #sourceCode accept: #compileSource:notifying: readSelection: #autoSelection menu: #msgPaneMenu:shifted:. sourceTextArea askBeforeDiscardingEdits: true. sourceTextArea font: StandardFonts codeFont. self updateSourceCode. ^ sourceTextArea! ! !FinderUI methodsFor: 'private' stamp: 'EstebanLorenzano 1/31/2013 19:24'! msgPaneMenu: aMenu shifted: shifted | donorMenu | donorMenu := shifted ifTrue: [SmalltalkEditor shiftedYellowButtonMenu] ifFalse: [SmalltalkEditor yellowButtonMenu]. ^ aMenu addAllFrom: donorMenu! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! versionsButtonState ^self selectedClass isNil | self isClassNamesSymbol.! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/16/2010 14:55'! searchedTextList: aCollection SearchedTextList := aCollection! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! sendersButtonState ^self selectedMethod isNil | self isClassNamesSymbol.! ! !FinderUI methodsFor: 'searching' stamp: 'SeanDeNigris 6/25/2012 19:23'! forSelectorsDo: selectorBlock forClassNamesDo: classNamesBlock forSourceDo: sourceBlock forExamplesDo: exampleBlock forPragmasDo: pragmaBlock self isSelectorsSymbol ifTrue: [^selectorBlock value]. self isClassNamesSymbol ifTrue: [^classNamesBlock value]. self isSourceSymbol ifTrue: [^sourceBlock value]. self isExamplesSymbol ifTrue: [^exampleBlock value]. self isPragmasSymbol ifTrue: [^pragmaBlock value].! ! !FinderUI methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:05'! initialize super initialize. finder := nil. forceSearch := nil. searchingTextArea := nil. sourceTextArea := nil. useRegExCheckbox := nil. wrapBlockOrSelector := [: i | i asString ].! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'StephaneDucasse 12/11/2013 13:28'! environmentButtonLabel ^ 'Packages...'! ! !FinderUI methodsFor: '*necompletion' stamp: 'SeanDeNigris 6/24/2012 09:20'! selectedClassOrMetaClass ^ self selectedClass.! ! !FinderUI methodsFor: 'private' stamp: 'BernardoContreras 12/15/2011 17:55'! openPackageChooser (DialogItemsChooser on: self unselectedItems: self constructPackagesSet selectedItems: (self constructPackagesSet: self packagesSelection) selectedItemsSetterSelector: #collectFromPackages: title: 'Package Chooser' unselectedItemsLabel: 'Unselected Packages' translated selectedItemsLabel: 'Selected Packages' translated) open! ! !FinderUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/15/2010 02:16'! updateSelectedMethod self changed: #selectedMethod! ! !FinderUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 2/25/2011 16:48'! doubleClick self selectedNode doubleClick! ! !FinderUI methodsFor: '*Shout-Styling' stamp: 'ClementBera 7/26/2013 16:39'! shoutAboutToStyle: aPluggableShoutMorphOrView aPluggableShoutMorphOrView classOrMetaClass: self selectedClass. self selectedClass ifNil: [^ false]. self selectedMethod ifNil: [^ false]. ^ true! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! hierarchyButtonAction self hierarchy.! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 9/15/2010 02:04'! buildImplementorsButton ^ (PluggableButtonMorph on: self getState: #implementorsButtonState action: #implementorsButtonAction label: #implementorsButtonLabel) hResizing: #spaceFill! ! !FinderUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/17/2010 02:16'! packagesSelection: aCollection self finder packagesSelection: aCollection.! ! !FinderUI methodsFor: 'private' stamp: 'MarcusDenker 4/29/2011 00:34'! inheritance self selectedClass ifNotNil: [ :class |. self selectedMethod ifNotNil: [:selector | SystemNavigation new methodHierarchyBrowserForClass: class selector: selector]]! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! allClassesButtonState ^false! ! !FinderUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 9/15/2010 02:47'! defaultWindowLabel ^'Finder'.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! searchButtonLabel ^'Search'! ! !FinderUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/15/2010 02:45'! useRegEx ^ self finder useRegEx! ! !FinderUI methodsFor: 'text areas behavior' stamp: 'BenjaminVanRyseghem 2/17/2011 11:21'! searchingAccept: aText self forceSearch ifFalse: [aText asString = self searchingString ifTrue: [^self]]. self searchingString: aText asString. forceSearch := false.! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! buildAllTextArea self buildSearchingTextArea. self buildSourceTextArea.! ! !FinderUI methodsFor: 'display' stamp: 'AlainPlantec 2/13/2011 22:03'! open | window | window := StandardWindow new model: self. self addAllItems: window. window setLabel: self defaultWindowLabel. window openInWorld. self searchingTextArea contentMorph takeKeyboardFocus! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! versionsButtonLabel ^'Versions'! ! !FinderUI methodsFor: 'tree behavior' stamp: 'BenjaminVanRyseghem 9/14/2010 16:35'! resultDictionary ^self finder resultDictionary ! ! !FinderUI methodsFor: 'do it requirements' stamp: 'MarcusDenker 6/21/2011 16:33'! doItReceiver ^ self selectedClass ifNotNil: [:selectedClass | selectedClass theNonMetaClass].! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! versionsButtonAction self versions.! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 9/15/2010 02:04'! buildVersionsButton ^ (PluggableButtonMorph on: self getState: #versionsButtonState action: #versionsButtonAction label: #versionsButtonLabel) hResizing: #spaceFill! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:03'! finder: aFinder finder := aFinder! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/3/2011 13:29'! browseButtonState ^self selectedClass isNil or: [self selectedMethod isNil]! ! !FinderUI methodsFor: 'private' stamp: 'SeanDeNigris 6/21/2012 08:38'! constructPackagesSet | list result | list := (self environment difference: self packagesSelection). result := OrderedCollection new. 'Building Packages' displayProgressFrom: 0 to: list size during:[ :bar | list doWithIndex: [:each :i | bar current: i. result add: each category]]. ^result asSet asSortedCollection: [:a :b | a anInteger] whileTrue: [ self searchedTextList removeLast]. self changed: #searchedTextList.! ! !FinderUI methodsFor: 'accessing' stamp: 'AlainPlantec 10/8/2011 13:48'! selection: aSelection super selection: aSelection. self finder selection: aSelection! ! !FinderUI methodsFor: 'text areas behavior' stamp: 'ClementBera 7/26/2013 16:39'! sourceCode ^ self selectedClass ifNil: [ self isExamplesSymbol ifTrue: [ self class methodFinderExplanation ] ifFalse: [ self defaultExplanation]] ifNotNil:[ self selectedMethod ifNil: [ self buildDescriptionOf: self selectedClass] ifNotNil:[ | method | method := self isExamplesSymbol ifTrue: [self finder findSelector: self selectedMethod] ifFalse: [self selectedMethod]. (self selectedClass >> method) sourceCode]]! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! browseButtonLabel ^'Browse'! ! !FinderUI methodsFor: 'text areas behavior' stamp: 'BenjaminVanRyseghem 3/4/2011 12:18'! buildDescriptionOf: aClass | stream | stream := WriteStream on: ''. stream nextPutAll: aClass definition. aClass hasComment ifTrue: [ stream nextPut: Character cr; nextPut: Character cr; nextPut: Character cr; nextPutAll: aClass comment]. ^ stream contents! ! !FinderUI methodsFor: 'tree behavior' stamp: 'BenjaminVanRyseghem 9/18/2010 15:08'! rootItems ^self resultDictionary keys sort:[:a :b | a name < b name]! ! !FinderUI methodsFor: 'private' stamp: 'MarcusDenker 4/29/2011 00:34'! hierarchy self selectedClass ifNotNil: [ :class | self selectedMethod ifNil: [SystemNavigation new browseHierarchy: class] ifNotNil: [:selector | SystemNavigation new browseHierarchy:class selector: selector]]! ! !FinderUI methodsFor: 'mode list' stamp: 'BenjaminVanRyseghem 9/14/2010 23:54'! isSourceSymbol ^self finder isSourceSymbol! ! !FinderUI methodsFor: 'display' stamp: 'AlainPlantec 2/13/2011 21:17'! initialExtent ^700 @ 500! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:11'! selectedClass ^ self finder selectedClass! ! !FinderUI methodsFor: '*Polymorph-TaskbarIcons' stamp: 'BenjaminVanRyseghem 3/18/2011 11:29'! taskbarIcon ^ self class icon! ! !FinderUI methodsFor: 'checkbox' stamp: 'BenjaminVanRyseghem 9/15/2010 01:47'! disableUseRegEx useRegExCheckbox isSelected ifTrue: [ useRegExCheckbox toggleSelected]. useRegExCheckbox enabled: false. ! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 6/22/2012 15:05'! defaultTreeMorph | col | col := MorphTreeColumn new rowMorphGetSelector: [:node | node displayString asMorph ]. self headerLabel ifNotNil: [ col headerButtonLabel: self headerLabel font: nil]. ^ (self treeMorphClass on: self) columns: (Array with: col); hResizing: #spaceFill; vResizing: #spaceFill; resizerWidth: 0; columnInset: 0; rowInset: 2; keystrokeActionSelector: #keyStroke:; preferedPaneColor: Color white; multiSelection: self multiSelection; autoMultiSelection: self autoMultiSelection; isCheckList: self isCheckList; doubleClickSelector: #doubleClick; getMenuSelector: #menu:shifted:; rowColorForEven: Color veryLightGray muchLighter odd: Color white.! ! !FinderUI methodsFor: 'items creation' stamp: 'AlainPlantec 10/8/2011 14:20'! buildPackagesTree ^ self defaultTreeMorph! ! !FinderUI methodsFor: 'private' stamp: 'CamilloBruni 6/29/2012 11:42'! implementors self selectedMethod ifNotNil: [ :selector | SystemNavigation new browseImplementorsOf: selector name: 'Implementors of ', selector asString autoSelect: nil]! ! !FinderUI methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 21:28'! addToSearchedTextList: aString self searchedTextList: (self searchedTextList remove: aString ifAbsent: []; yourself). self searchedTextList size = self searchedTextListMaxSize ifTrue: [self searchedTextList removeLast]. self searchedTextList addFirst: aString ! ! !FinderUI methodsFor: 'items creation' stamp: 'MarcusDenker 5/15/2011 15:21'! buildSearchModeToolBar: aWindow ^aWindow newToolbar: { self buildSearchingTextArea. self buildSearchButton. self buildRegExChooser. self buildSearchModeDropListIn: aWindow. self buildEnvironmentButton. self buildAllClassesButton}.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! hierarchyButtonLabel ^'Hierarchy'! ! !FinderUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! resetEnvironment self triggerEvent: #resetEnvironment! ! !FinderUI methodsFor: 'do it requirements' stamp: 'BenjaminVanRyseghem 4/14/2011 11:47'! doItContext ^ nil! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 9/16/2010 22:59'! buildBrowseToolBar: aWindow | toolbar | toolbar := aWindow newToolbar: { self buildBrowseButton. self buildSendersButton. self buildImplementorsButton. self buildVersionsButton. self buildInheritanceButton. self buildHierarchyButton}. ^toolbar hResizing: #shrinkWrap! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 9/15/2010 02:04'! buildSendersButton ^ (PluggableButtonMorph on: self getState: #sendersButtonState action: #sendersButtonAction label: #sendersButtonLabel) hResizing: #spaceFill! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 9/16/2010 01:16'! environmentButtonAction self openPackageChooser! ! !FinderUI methodsFor: 'events handling' stamp: 'StephaneDucasse 3/12/2011 15:07'! keyStroke: event self selectedNode ifNotNil: [:node | node keyStroke: event]! ! !FinderUI methodsFor: 'items creation' stamp: 'AlainPlantec 2/13/2011 22:30'! buildRegExChooser | string btnHeight btnWidth | string := 'Regexp'. btnHeight := StandardFonts buttonFont height + 8. btnWidth := 0. string do: [:c | btnWidth := btnWidth + (StandardFonts buttonFont widthOf: c)]. ^useRegExCheckbox := (CheckboxMorph on: self finder selected: #useRegEx changeSelected: #useRegEx:) beCheckbox; vResizing: #rigid; height: btnHeight; width: btnWidth + 30; label: string! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:13'! selectedMethod ^ self finder selectedMethod! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/14/2010 14:25'! searchedTextList ^SearchedTextList ifNil: [ SearchedTextList := OrderedCollection new]! ! !FinderUI methodsFor: 'mode list' stamp: 'SeanDeNigris 6/25/2012 19:20'! searchModesList ^#(Selectors Classes Source Pragmas Examples)! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:06'! searchingString ^self finder searchingString! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! inheritanceButtonLabel ^'Inheritance'! ! !FinderUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/15/2010 01:21'! resetSearchedTextList self searchedTextList removeAll.! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 9/15/2010 02:03'! buildHierarchyButton ^ (PluggableButtonMorph on: self getState: #hierarchyButtonState action: #hierarchyButtonAction label: #hierarchyButtonLabel) hResizing: #spaceFill! ! !FinderUI methodsFor: 'text areas behavior' stamp: 'MarcusDenker 10/15/2013 18:16'! compileSource: aString notifying: aController | class method | (self selectedClass isNil or: [ self selectedMethod isNil ]) ifTrue:[ self changed: #clearUserEdits. ^self]. class := self selectedClass. method := class methodDict at: self selectedMethod. (class compile: (aString asString) classified: method category notifying: aController) ifNil: [^ self ] ifNotNil: [:selector | self changed: #clearUserEdits ]! ! !FinderUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! labelFont ^StandardFonts defaultFont! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! buildAllClassesButton ^ PluggableButtonMorph on: self getState: #allClassesButtonState action: #allClassesButtonAction label: #allClassesButtonLabel! ! !FinderUI methodsFor: 'checkbox' stamp: 'BenjaminVanRyseghem 9/15/2010 01:41'! enableUseRegEx useRegExCheckbox enabled: true; updateEnabled! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! inheritanceButtonState ^self selectedClass isNil | self isClassNamesSymbol.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! environmentButtonState ^false.! ! !FinderUI methodsFor: 't - accessing' stamp: 'NicolaiHess 12/21/2013 23:33'! rootNodeClassFromItem: anItem "To have the good class for my nodes, I ask my owner, because he is the only one who knows his state" ^ self forSelectorsDo: [ (self resultDictionary at: anItem) size > 1 ifTrue: [ FinderMethodNode ] ifFalse: [ FinderSingleMethodNode ]] forClassNamesDo: [FinderClassNode] forSourceDo: [FinderMethodNode] forExamplesDo: [FinderExampleMethodNode] forPragmasDo: [FinderPragmaNode]! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/14/2010 17:44'! currentSearchMode ^self finder currentSearchMode! ! !FinderUI methodsFor: 'items creation' stamp: 'AlainPlantec 2/13/2011 21:44'! useRegExCheckbox ^ useRegExCheckbox ifNil: [self buildRegExChooser] ! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/2/2011 16:41'! forceSearch ^ forceSearch ifNil: [forceSearch := false].! ! !FinderUI methodsFor: 'text areas behavior' stamp: 'BenjaminVanRyseghem 5/16/2011 13:38'! updateSourceCode self changed: #sourceCode.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! implementorsButtonState ^self selectedMethod isNil | self isClassNamesSymbol.! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 13:42'! searchedTextListMaxSize ^self class searchedTextListMaxSize! ! !FinderUI methodsFor: 'mode list' stamp: 'BenjaminVanRyseghem 5/14/2012 13:45'! isClassNamesSymbol ^self finder isClassNamesSymbol! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! implementorsButtonAction self implementors.! ! !FinderUI methodsFor: 'mode list' stamp: 'SeanDeNigris 6/25/2012 15:05'! isExamplesSymbol ^self finder isExamplesSymbol! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! hierarchyButtonState ^self selectedClass isNil.! ! !FinderUI methodsFor: 'private' stamp: 'SeanDeNigris 6/25/2012 19:18'! defaultExplanation ^ 'The Finder can be used in 4 different ways: - Selectors: your research is done among selectors - Classes : your research is done among classes names - Source : your research is done among all the source code - Pragmas: your research is done among pragmas - Examples : your research uses the Method Finder behavior (for further informations, print ''FinderUI methodFinderExplanation'') In these four modes, you can also tick the ''Use RegEx'' checkbox. If you pick this box, your search will be done using regular expressions instead of just matching. The ''Select classes'' button opened a dialog window to select which classes will be used for the search. The ''All classes'' button is used to reset the classes selection.'! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! inheritanceButtonAction self inheritance.! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! buildEnvironmentButton ^ (PluggableButtonMorph on: self getState: #environmentButtonState action: #environmentButtonAction label: #environmentButtonLabel) beSticky! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:12'! environment ^ self finder environment.! ! !FinderUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/13/2010 16:46'! searchModeHelpText ^'Choose the mode for the search'! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 2/17/2011 11:20'! searchButtonAction forceSearch := true. self searchingTextArea contentMorph acceptTextInModel.! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 9/15/2010 02:04'! buildInheritanceButton ^ (PluggableButtonMorph on: self getState: #inheritanceButtonState action: #inheritanceButtonAction label: #inheritanceButtonLabel) hResizing: #spaceFill! ! !FinderUI methodsFor: '*necompletion' stamp: 'SeanDeNigris 7/12/2012 08:00'! guessTypeForName: aString self flag: 'we may be able to do something more sophisticated here, but needed something to prevent a DNU. Returning nil was taken from AbstractTool. See Debugger or Workspace for actual guessing logic'. ^ nil.! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:02'! finder ^finder! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! searchButtonState ^false.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! implementorsButtonLabel ^'Implementors'! ! !FinderUI methodsFor: 't - accessing' stamp: 'MarcusDenker 12/9/2013 12:45'! menu: menu shifted: b self selectedNode ifNil: [ ^menu ]. ^ self selectedNode menu: menu shifted: b ! ! !FinderUI methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 21:48'! searchingTextArea ^searchingTextArea ifNil: [self buildSearchingTextArea]! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 9/13/2010 17:28'! buildSearchingTextArea ^ searchingTextArea := (EditableDropListMorph on: self list: #searchedTextList selected: #searchingString changeSelected: #searchingAccept: useIndex: false addToList: #addToSearchedTextList: class: String getEnabled: nil) hResizing: #spaceFill; ghostText: 'Hit return to accept' translated. ! ! !FinderUI methodsFor: 'private' stamp: 'SeanDeNigris 6/21/2012 08:39'! constructPackagesSet: aList | result | result := OrderedCollection new. 'Building Packages' displayProgressFrom: 0 to: aList size during:[ :bar | aList doWithIndex: [:each :i | bar current: i. result add: each category]]. ^(result reject: [:each | each isNil]) asSet asSortedCollection: [:a :b | a (aBuilder group: #finderUI) target: self; label: 'Finder' translated; description: 'Settings related to the finder' translated; with: [ (aBuilder setting: #searchedTextListMaxSize) label: 'Size of the History' translated]! ! !FinderUI class methodsFor: 'event subscriptions' stamp: 'BenjaminVanRyseghem 2/25/2011 17:04'! subscribesUpdateSourceCodeOn: aFinder to: anInstance aFinder when: #updateSourceCode send: #updateSourceCode to: anInstance.! ! !FinderUI class methodsFor: 'event subscriptions' stamp: 'AlainPlantec 2/13/2011 22:20'! subscribesResetEnvironmentOn: aFinder to: anInstance aFinder when: #resetEnvironment send: #resetEnvironment to: anInstance! ! !FinderUI class methodsFor: 'event subscriptions' stamp: 'BenjaminVanRyseghem 2/25/2011 17:04'! subscribesEnableUseRegExOn: aFinder to: anInstance aFinder when: #enableUseRegEx send: #enableUseRegEx to: anInstance.! ! !FinderUI class methodsFor: 'event subscriptions' stamp: 'BenjaminVanRyseghem 2/25/2011 17:05'! subscribesUpdateListOn: aFinder to: anInstance aFinder when: #updateResultDictionary send: #updateList to: anInstance.! ! !FinderUI class methodsFor: 'initialize-release' stamp: 'AlainPlantec 2/13/2011 22:20'! initialize searchedTextListMaxSize := 15! ! !FinderUI class methodsFor: 'event subscriptions' stamp: 'BenjaminVanRyseghem 2/25/2011 17:04'! subscribesDisableUseRegExOn: aFinder to: anInstance. aFinder when: #disableUseRegEx send: #disableUseRegEx to: anInstance.! ! !FinderUI class methodsFor: 'explanations' stamp: 'SeanDeNigris 6/25/2012 19:19'! methodFinderExplanation "The comment in the bottom pane" false ifTrue: [MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10)]. "to keep the method methodFor: from being removed from the system" ^ 'Type a fragment of a selector in the search box and click . Or, use an example to find a method in the system. An example is made up of the following three items separated by a period: receiver. args. answer. For example, type: 3. 4. 7. into the search box and click Alternatively, in this bottom pane, use #methodFor: directly to find a method in the system. Select this line of code and choose "print it". MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10). This will discover (data1 + data2). You supply inputs and answers and the system will find the method. Each inner array is a list of inputs. It contains the receiver and zero or more arguments. For Booleans and any computed arguments, use brace notation. MethodFinder methodFor: { {1. 3}. true. {20. 10}. false}. This will discover the expressions (data1 < data2), (data2 > data1), and many others. MethodFinder methodFor: { {''29 Apr 1999'' asDate}. ''Thursday''. {''30 Apr 1999'' asDate}. ''Friday'' }. This will discover the expression (data1 weekday) Receiver and arguments do not have to be in the right order. See MethodFinder.verify for more examples.'! ! !FinderUI class methodsFor: 'accessing' stamp: 'bvr 9/19/2010 19:19'! searchedTextListMaxSize: anInteger self allInstancesDo: [:each | each searchedTextListMaxSize: anInteger]. searchedTextListMaxSize := anInteger! ! !FinderUI class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/25/2011 17:04'! on: aFinder | instance | instance := self new finder: aFinder. self doAllSubscriptionsOn: aFinder to: instance. ^instance.! ! !FinderUI class methodsFor: 'event subscriptions' stamp: 'BenjaminVanRyseghem 2/25/2011 17:04'! subscribesUpdateSelectedMethodOn: aFinder to: anInstance aFinder when: #updateSelectedMethod send: #updateSelectedMethod to: anInstance.! ! !FinderUI class methodsFor: 'accessing' stamp: 'AlainPlantec 2/14/2011 01:00'! searchedTextListMaxSize ^ searchedTextListMaxSize ifNil: [searchedTextListMaxSize := 15]! ! !FinderUI class methodsFor: 'event subscriptions' stamp: 'BenjaminVanRyseghem 2/25/2011 17:04'! subscribesUpdateSelectedClassOn: aFinder to: anInstance aFinder when: #updateSelectedClass send: #updateSelectedClass to: anInstance.! ! !FinderUI class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/15/2013 14:19'! icon ^ Smalltalk ui icons iconNamed: #smallFindIcon! ! !FixedFaceFont commentStamp: 'tak 12/22/2004 01:45'! I am a font for special purpose like password or fallback. I can show same form whenever someone requests any character. Variable displaySelector is future use to show a form dynamically. (Although it would be unnecessary...)! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:51'! maxAscii ^ SmallInteger maxVal! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:58'! ascent ^baseFont ascent! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 12:00'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta | size | size := stopIndex - startIndex + 1. ^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: aPoint y + self ascent).! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:51'! displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont baselineY: baselineY | destPoint | destPoint := self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY. ^ Array with: stopIndex + 1 with: destPoint! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:49'! displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY | maskedString | maskedString := String new: length. maskedString atAllPut: substitutionCharacter. ^ baseFont displayString: maskedString on: aCanvas from: 1 to: length at: aPoint kern: kernDelta baselineY: baselineY! ! !FixedFaceFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:48'! releaseCachedState baseFont releaseCachedState.! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'! height ^baseFont height! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'ar 1/5/2003 17:00'! installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor ^baseFont installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor! ! !FixedFaceFont methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:54'! initialize super initialize. baseFont := TextStyle defaultFont. self passwordFont! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'! baseFont ^baseFont! ! !FixedFaceFont methodsFor: 'private' stamp: 'yo 1/11/2005 18:54'! glyphInfoOf: aCharacter into: glyphInfoArray ^ baseFont glyphInfoOf: substitutionCharacter into: glyphInfoArray. ! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:26'! lineGrid ^baseFont lineGrid! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 12:19'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY | size | size := stopIndex - startIndex + 1. ^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: baselineY).! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:50'! displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY | maskedString | maskedString := String new: length. maskedString atAllPut: substitutionCharacter. ^ baseFont displayString: maskedString on: aCanvas from: 1 to: length at: aPoint kern: kernDelta baselineY: baselineY! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:58'! descentKern ^baseFont descentKern! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:10'! emphasized: emph ^self class new baseFont: (baseFont emphasized: emph)! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:19'! fontSize: aNumber self baseFont: (StrikeFont familyName: baseFont familyName size: aNumber) copy! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:25'! familyName ^baseFont familyName, '-pw'! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 18:06'! displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta | maskedString | maskedString := String new: length. maskedString atAllPut: substitutionCharacter. ^ baseFont displayString: maskedString on: aCanvas from: 1 to: length at: aPoint kern: kernDelta! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'! baseFont: aFont baseFont := aFont! ! !FixedFaceFont methodsFor: 'initialization' stamp: 'yo 1/7/2005 11:59'! passwordFont displaySelector := #displayPasswordOn:length:at:kern:baselineY:. substitutionCharacter := $*! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'! baseKern ^baseFont baseKern! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 11:10'! displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont | destPoint | destPoint := self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta. ^ Array with: stopIndex + 1 with: destPoint! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/22/2004 02:01'! characterFormAt: character ^ baseFont characterFormAt: substitutionCharacter! ! !FixedFaceFont methodsFor: 'measuring' stamp: 'tak 12/20/2004 18:05'! widthOf: aCharacter ^ baseFont widthOf: substitutionCharacter! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 18:06'! displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta | maskedString | maskedString := String new: length. maskedString atAllPut: substitutionCharacter. ^ baseFont displayString: maskedString on: aCanvas from: 1 to: length at: aPoint kern: kernDelta! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 17:00'! descent ^baseFont descent! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:28'! pointSize ^baseFont pointSize! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'! passwordCharacter ^$*! ! !FixedFaceFont methodsFor: 'initialization' stamp: 'yo 1/7/2005 11:59'! errorFont displaySelector := #displayErrorOn:length:at:kern:baselineY:. substitutionCharacter := $?.! ! !FixedLayout commentStamp: ''! I am the default layout for objects. I contain a fixed number of Slots. Instances of classes using this kind of layout have always the same size.! !FixedLayout methodsFor: 'format' stamp: 'ToonVerwaest 4/1/2011 01:27'! instanceSpecificationBase ^ 0! ! !FixedLayout class methodsFor: 'instance creation' stamp: 'MartinDias 7/11/2013 16:01'! extending: superLayout scope: aScope host: aClass ^ (superLayout extend: aScope) host: aClass; yourself! ! !Float commentStamp: 'VeronicaUquillas 6/11/2010 14:51'! My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Float constants. This is great for teaching about numbers, but may be confusing to the average reader: 3r20.2 --> 6.66666666666667 8r20.2 --> 16.25 If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... sign 1 bit exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent in the range -1023 .. +1024 - 16r000: significand = 0: Float zero significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit) - 16r7FF: significand = 0: Infinity significand ~= 0: Not A Number (NaN) representation mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. The single-precision format is... sign 1 bit exponent 8 bits, with bias of 127, to represent -126 to +127 - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - 16r7F reserved for Float underflow/overflow (mantissa is ignored) mantissa 24 bits, but only 23 are stored This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. Thanks to Rich Harmon for asking many questions and to Tim Olson, Bruce Cohen, Rick Zaccone and others for the answers that I have collected here.! !Float methodsFor: 'testing' stamp: ''! isZero ^self = 0.0! ! !Float methodsFor: 'comparing' stamp: ''! ~= aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is not equal to the argument. Otherwise return false. Fail if the argument is not a Float. Optional. See Object documentation whatIsAPrimitive." ^super ~= aNumber! ! !Float methodsFor: 'testing' stamp: 'ar 6/9/2000 18:56'! isPowerOfTwo "Return true if the receiver is an integral power of two. Floats never return true here." ^false! ! !Float methodsFor: 'converting' stamp: ''! radiansToDegrees "Answer the receiver in degrees. Assumes the receiver is in radians." ^self / RadiansPerDegree! ! !Float methodsFor: 'mathematical functions' stamp: 'jmv 10/13/2011 09:03'! nthRoot: aPositiveInteger "Answer the nth root of the receiver." aPositiveInteger = 2 ifTrue: [ ^self sqrt ]. (aPositiveInteger isInteger not or: [ aPositiveInteger negative ]) ifTrue: [^ ArithmeticError signal: 'nth root only defined for positive Integer n.']. ^self negative ifTrue: [ aPositiveInteger odd ifTrue: [ (self negated raisedTo: 1.0 / aPositiveInteger) negated ] ifFalse: [ ArithmeticError signal: 'Negative numbers don''t have even roots.' ]] ifFalse: [ self raisedTo: 1.0 / aPositiveInteger ]! ! !Float methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:36'! < aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is less than the argument. Otherwise return false. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^ aNumber adaptToFloat: self andCompare: # or: [selector = #'>=']) ifTrue: [^ self positive not]. ^self error: 'unknow comparison selector']. "Try to avoid asTrueFraction because it can cost" selector == #= ifTrue: [ self fractionPart = 0.0 ifFalse: [^false]]. selector == #~= ifTrue: [ self fractionPart = 0.0 ifFalse: [^true]]. ^ rcvr perform: selector with: self asTrueFraction! ! !Float methodsFor: 'truncation and round off' stamp: 'nice 12/1/2009 12:07'! ulp "Answer the unit of least precision of self (the power of two corresponding to last bit of mantissa)" | exponent | self isFinite ifFalse: [ self isNaN ifTrue: [^self]. ^Float infinity]. self = 0.0 ifTrue: [^Float fmin]. exponent := self exponent. ^exponent < self class emin ifTrue: [Float fminDenormalized] ifFalse: [Float epsilon timesTwoPower: exponent]! ! !Float methodsFor: 'arithmetic' stamp: 'nice 8/21/2010 22:31'! abs "This is faster than using Number abs and works for negativeZero." self <= 0.0 ifTrue: [^ 0.0 - self] ifFalse: [^ self]! ! !Float methodsFor: 'accessing' stamp: 'StephaneDucasse 9/24/2010 20:47'! basicAt: index put: value "Primitive. Assumes receiver is indexable. Store the second argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive. This version of basicAt: is specifically for floats, answering the most significant word for index 1 and the least significant word for index 2. This alows the VM to store floats in whatever order it chooses while it appears to the image that they are always in big-endian/PowerPC order." ^super basicAt: index put: value! ! !Float methodsFor: 'mathematical functions' stamp: ''! arcTan "Answer the angle in radians. Optional. See Object documentation whatIsAPrimitive." | theta eps step sinTheta cosTheta | "Newton-Raphson" self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ]. "first guess" theta := (self * Halfpi) / (self + 1.0). "iterate" eps := Halfpi * Epsilon. step := theta. [(step * step) > eps] whileTrue: [ sinTheta := theta sin. cosTheta := theta cos. step := (sinTheta * cosTheta) - (self * cosTheta * cosTheta). theta := theta - step]. ^ theta! ! !Float methodsFor: 'truncation and round off' stamp: 'nice 12/2/2009 17:35'! predecessor | ulp | self isFinite ifFalse: [ (self isNaN or: [self negative]) ifTrue: [^self]. ^Float fmax]. self = 0.0 ifTrue: [^Float fmin negated]. ulp := self ulp. ^self - (0.5 * ulp) = self ifTrue: [self - ulp] ifFalse: [self - (0.5 * ulp)]! ! !Float methodsFor: 'mathematical functions' stamp: ''! sin "Answer the sine of the receiver taken as an angle in radians. Optional. See Object documentation whatIsAPrimitive." | sum delta self2 i | "Taylor series" "normalize to the range [0..Pi/2]" self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))]. self > Twopi ifTrue: [^ (self \\ Twopi) sin]. self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)]. self > Halfpi ifTrue: [^ (Pi - self) sin]. "unroll loop to avoid use of abs" sum := delta := self. self2 := 0.0 - (self * self). i := 2.0. [delta > Epsilon] whileTrue: [ "once" delta := (delta * self2) / (i * (i + 1.0)). i := i + 2.0. sum := sum + delta. "twice" delta := (delta * self2) / (i * (i + 1.0)). i := i + 2.0. sum := sum + delta]. ^ sum! ! !Float methodsFor: 'converting' stamp: 'sma 5/3/2000 21:46'! asFraction ^ self asTrueFraction ! ! !Float methodsFor: 'mathematical functions' stamp: 'nice 5/16/2012 21:15'! floorLog: radix "Answer the floor of the log base radix of the receiver. The result may be off by one due to rounding errors, except in base 2." (radix = 2 and: [self > 0.0]) ifTrue: [^self exponent]. ^ (self log: radix) floor ! ! !Float methodsFor: 'mathematical functions' stamp: ''! timesTwoPower: anInteger "Primitive. Answer with the receiver multiplied by 2.0 raised to the power of the argument. Optional. See Object documentation whatIsAPrimitive." anInteger < -29 ifTrue: [^ self * (2.0 raisedToInteger: anInteger)]. anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]. ^ self * (2.0 raisedToInteger: anInteger)! ! !Float methodsFor: 'mathematical functions' stamp: 'nice 10/30/2009 22:21'! arcTan: denominator "Answer the angle in radians. Optional. See Object documentation whatIsAPrimitive. Implementation note: use sign in order to catch cases of negativeZero" ^self = 0.0 ifTrue: [denominator sign >= 0 ifTrue: [ 0 ] ifFalse: [ self sign >= 0 ifTrue: [ Pi ] ifFalse: [ Pi negated ]]] ifFalse: [denominator = 0.0 ifTrue: [self > 0.0 ifTrue: [ Halfpi ] ifFalse: [ Halfpi negated ]] ifFalse: [denominator > 0 ifTrue: [ (self / denominator) arcTan ] ifFalse: [self > 0 ifTrue: [ ((self / denominator) arcTan) + Pi ] ifFalse: [ ((self / denominator) arcTan) - Pi ]]]]! ! !Float methodsFor: 'mathematical functions' stamp: 'tao 4/19/98 23:22'! reciprocalFloorLog: radix "Quick computation of (self log: radix) floor, when self < 1.0. Avoids infinite recursion problems with denormalized numbers" | adjust scale n | adjust := 0. scale := 1.0. [(n := radix / (self * scale)) isInfinite] whileTrue: [scale := scale * radix. adjust := adjust + 1]. ^ ((n floorLog: radix) + adjust) negated! ! !Float methodsFor: 'comparing' stamp: 'nice 7/10/2009 22:14'! >= aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is greater than or equal to the argument. Otherwise return false. Fail if the argument is not a Float. Optional. See Object documentation whatIsAPrimitive. " ^ aNumber adaptToFloat: self andCompare: #>=! ! !Float methodsFor: 'arithmetic' stamp: 'nice 12/20/2012 23:16'! negated "Answer a Number that is the negation of the receiver. Implementation note: this version cares of negativeZero." ^-1.0 * self! ! !Float methodsFor: 'mathematical functions' stamp: ''! exp "Answer E raised to the receiver power. Optional. See Object documentation whatIsAPrimitive." | base fract correction delta div | "Taylor series" "check the special cases" self < 0.0 ifTrue: [^ (self negated exp) reciprocal]. self = 0.0 ifTrue: [^ 1]. self abs > MaxValLn ifTrue: [self error: 'exp overflow']. "get first approximation by raising e to integer power" base := E raisedToInteger: (self truncated). "now compute the correction with a short Taylor series" "fract will be 0..1, so correction will be 1..E" "in the worst case, convergance time is logarithmic with 1/Epsilon" fract := self fractionPart. fract = 0.0 ifTrue: [ ^ base ]. "no correction required" correction := 1.0 + fract. delta := fract * fract / 2.0. div := 2.0. [delta > Epsilon] whileTrue: [ correction := correction + delta. div := div + 1.0. delta := delta * fract / div]. correction := correction + delta. ^ base * correction! ! !Float methodsFor: 'mathematical functions' stamp: ''! log "Answer the base 10 logarithm of the receiver." ^ self ln / Ln10! ! !Float methodsFor: 'arithmetic' stamp: 'GabrielOmarCotelli 5/23/2009 20:40'! reciprocal "Returns the reciprocal. If self is 0.0 the / signals a ZeroDivide" ^1.0 / self! ! !Float methodsFor: 'printing' stamp: 'ClementBera 9/27/2013 17:26'! absPrintExactlyOn: aStream base: base "Print my value on a stream in the given base. Assumes that my value is strictly positive; negative numbers, zero, and NaNs have already been handled elsewhere. Based upon the algorithm outlined in: Robert G. Burger and R. Kent Dybvig Printing Floating Point Numbers Quickly and Accurately ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation June 1996. This version guarantees that the printed representation exactly represents my value by using exact integer arithmetic." | fBase significand exp baseExpEstimate be be1 r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount | self isInfinite ifTrue: [ aStream nextPutAll: 'Float infinity'. ^ self]. fBase := base asFloat. significand := self significandAsInteger. roundingIncludesLimits := significand even. exp := (self exponent - 52) max: MinValLogBase2. baseExpEstimate := (self exponent * fBase reciprocalLogBase2 - 1.0e-10) ceiling. exp >= 0 ifTrue: [be := 1 << exp. significand ~= 16r10000000000000 ifTrue: [r := significand * be * 2. s := 2. mPlus := be] ifFalse: [be1 := be * 2. r := significand * be1 * 2. s := 4. mPlus := be1]. mMinus := be] ifFalse: [(exp = MinValLogBase2) | (significand ~= 16r10000000000000) ifTrue: [r := significand * 2. s := (1 << (exp negated)) * 2. mPlus := 1] ifFalse: [r := significand * 4. s := (1 << (exp negated + 1)) * 2. mPlus := 2]. mMinus := 1]. baseExpEstimate >= 0 ifTrue: [s := s * (base raisedToInteger: baseExpEstimate)] ifFalse: [scale := base raisedToInteger: baseExpEstimate negated. r := r * scale. mPlus := mPlus * scale. mMinus := mMinus * scale]. (r + mPlus > s) | (roundingIncludesLimits & (r + mPlus = s)) ifTrue: [baseExpEstimate := baseExpEstimate + 1] ifFalse: [r := r * base. mPlus := mPlus * base. mMinus := mMinus * base]. (fixedFormat := baseExpEstimate between: -3 and: 6) ifTrue: [decPointCount := baseExpEstimate. baseExpEstimate <= 0 ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] ifFalse: [decPointCount := 1]. [d := r // s. r := r \\ s. (tc1 := (r < mMinus) | (roundingIncludesLimits & (r = mMinus))) | (tc2 := (r + mPlus > s) | (roundingIncludesLimits & (r + mPlus = s)))] whileFalse: [aStream nextPut: (Character digitValue: d). r := r * base. mPlus := mPlus * base. mMinus := mMinus * base. decPointCount := decPointCount - 1. decPointCount = 0 ifTrue: [aStream nextPut: $.]]. tc2 ifTrue: [tc1 not | (tc1 & (r*2 >= s)) ifTrue: [d := d + 1]]. aStream nextPut: (Character digitValue: d). decPointCount > 0 ifTrue: [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. aStream nextPutAll: '.0']. fixedFormat ifFalse: [aStream nextPut: $e. aStream nextPutAll: (baseExpEstimate - 1) printString]! ! !Float methodsFor: 'testing' stamp: 'bf 8/20/1999 12:56'! hasContentsInExplorer ^false! ! !Float methodsFor: 'accessing' stamp: 'eem 4/19/2009 18:03'! at: index put: value ^self basicAt: index put: value! ! !Float methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 2/8/2013 15:48'! absPrintInexactlyOn: aStream base: base "Print my value on a stream in the given base. Assumes that my value is strictly positive; negative numbers, zero, and NaNs have already been handled elsewhere. Based upon the algorithm outlined in: Robert G. Burger and R. Kent Dybvig Printing Floating Point Numbers Quickly and Accurately ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation June 1996. This version performs all calculations with Floats instead of LargeIntegers, and loses about 3 lsbs of accuracy compared to an exact conversion." | significantBits fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount | self isInfinite ifTrue: [aStream nextPutAll: 'Float infinity'. ^ self]. significantBits := 50. "approximately 3 lsb's of accuracy loss during conversion" fBase := base asFloat. exp := self exponent. baseExpEstimate := (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling. exp >= 0 ifTrue: [r := self. s := 1.0. mPlus := 1.0 timesTwoPower: exp - significantBits. mMinus := self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]] ifFalse: [r := self timesTwoPower: significantBits. s := 1.0 timesTwoPower: significantBits. mMinus := 1.0 timesTwoPower: (exp max: -1024). mPlus := (exp = MinValLogBase2) | (self significand ~= 1.0) ifTrue: [mMinus] ifFalse: [mMinus * 2.0]]. baseExpEstimate >= 0 ifTrue: [s := s * (fBase raisedToInteger: baseExpEstimate). exp = 1023 ifTrue: "scale down to prevent overflow to Infinity during conversion" [r := r / fBase. s := s / fBase. mPlus := mPlus / fBase. mMinus := mMinus / fBase]] ifFalse: [exp < -1023 ifTrue: "scale up to prevent denorm reciprocals overflowing to Infinity" [d := (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling. scale := fBase raisedToInteger: d. r := r * scale. mPlus := mPlus * scale. mMinus := mMinus * scale. scale := fBase raisedToInteger: (baseExpEstimate + d) negated] ifFalse: [scale := fBase raisedToInteger: baseExpEstimate negated]. s := s / scale]. (r + mPlus >= s) ifTrue: [baseExpEstimate := baseExpEstimate + 1] ifFalse: [s := s / fBase]. (fixedFormat := baseExpEstimate between: -3 and: 6) ifTrue: [decPointCount := baseExpEstimate. baseExpEstimate <= 0 ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] ifFalse: [decPointCount := 1]. [d := (r / s) truncated. r := r - (d * s). (tc1 := r <= mMinus) | (tc2 := r + mPlus >= s)] whileFalse: [aStream nextPut: (Character digitValue: d). r := r * fBase. mPlus := mPlus * fBase. mMinus := mMinus * fBase. decPointCount := decPointCount - 1. decPointCount = 0 ifTrue: [aStream nextPut: $.]]. tc2 ifTrue: [tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d := d + 1]]. aStream nextPut: (Character digitValue: d). decPointCount > 0 ifTrue: [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. aStream nextPutAll: '.0']. fixedFormat ifFalse: [aStream nextPut: $e. aStream nextPutAll: (baseExpEstimate - 1) printString]! ! !Float methodsFor: 'truncation and round off' stamp: 'nice 7/24/2008 01:32'! rounded "Answer the integer nearest the receiver. Implementation note: super would not handle tricky inexact arithmetic" "self assert: 5000000000000001.0 rounded = 5000000000000001" self fractionPart abs < 0.5 ifTrue: [^self truncated] ifFalse: [^self truncated + self sign rounded]! ! !Float methodsFor: 'arithmetic' stamp: 'GabrielOmarCotelli 6/6/2009 17:12'! / aNumber "Primitive. Answer the result of dividing receiver by aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." aNumber = 0.0 ifTrue: [ ZeroDivide signalWithDividend: self]. ^aNumber adaptToFloat: self andSend: #/! ! !Float methodsFor: 'mathematical functions' stamp: 'tao 10/15/97 14:23'! reciprocalLogBase2 "optimized for self = 10, for use in conversion for printing" ^ self = 10.0 ifTrue: [Ln2 / Ln10] ifFalse: [Ln2 / self ln]! ! !Float methodsFor: 'printing' stamp: 'StephaneDucasse 7/21/2010 17:41'! hex ^ String streamContents: [:strm | | word nibble | 1 to: 2 do: [:i | word := self at: i. 1 to: 8 do: [:s | nibble := (word bitShift: -8+s*4) bitAnd: 16rF. strm nextPut: ('0123456789ABCDEF' at: nibble+1)]]] " (-2.0 to: 2.0) collect: [:f | f hex] "! ! !Float methodsFor: 'comparing' stamp: 'nice 7/19/2009 19:27'! closeTo: num "are these two numbers close?" num isNumber ifFalse: [^[self = num] ifError: [false]]. self = 0.0 ifTrue: [^num abs < 0.0001]. num = 0 ifTrue: [^self abs < 0.0001]. ^self = num asFloat or: [(self - num) abs / (self abs max: num abs) < 0.0001]! ! !Float methodsFor: 'converting' stamp: 'nice 1/4/2009 20:31'! adaptToFraction: rcvr andCompare: selector "If I am involved in comparison with a Fraction, convert myself to a Fraction. This way, no bit is lost and comparison is exact." self isFinite ifFalse: [ selector == #= ifTrue: [^false]. selector == #~= ifTrue: [^true]. self isNaN ifTrue: [^ false]. (selector = #< or: [selector = #'<=']) ifTrue: [^ self positive]. (selector = #> or: [selector = #'>=']) ifTrue: [^ self positive not]. ^self error: 'unknow comparison selector']. "Try to avoid asTrueFraction because it can cost" selector == #= ifTrue: [ rcvr denominator isPowerOfTwo ifFalse: [^false]]. selector == #~= ifTrue: [ rcvr denominator isPowerOfTwo ifFalse: [^true]]. ^ rcvr perform: selector with: self asTrueFraction! ! !Float methodsFor: 'truncation and round off' stamp: ''! fractionPart "Primitive. Answer a Float whose value is the difference between the receiver and the receiver's asInteger value. Optional. See Object documentation whatIsAPrimitive." ^self - self truncated asFloat! ! !Float methodsFor: 'mathematical functions' stamp: 'jm 4/28/1998 01:10'! sign "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0. Handle IEEE-754 negative-zero by reporting a sign of -1" self > 0 ifTrue: [^ 1]. (self < 0 or: [((self at: 1) bitShift: -31) = 1]) ifTrue: [^ -1]. ^ 0! ! !Float methodsFor: 'mathematical functions' stamp: ''! arcCos "Answer the angle in radians." ^ Halfpi - self arcSin! ! !Float methodsFor: 'testing' stamp: ''! isFloat ^ true! ! !Float methodsFor: 'printing' stamp: 'nice 11/3/2011 20:26'! asMinimalDecimalFraction "Answer the shortest decimal Fraction that will equal self when converted back asFloat. A decimal Fraction has only powers of 2 and 5 as decnominator. For example, 0.1 asMinimalDecimalFraction = (1/10)." | significand exp baseExpEstimate r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount slowbit shead denominator numerator | self isFinite ifFalse: [self error: 'Only finite Float can be converted to a Fraction']. self = 0.0 ifTrue: [^0]. self < 0.0 ifTrue: [^self negated asMinimalDecimalFraction negated]. numerator := 0. denominator := 0. significand := self significandAsInteger. roundingIncludesLimits := significand even. exp := (self exponent - 52) max: MinValLogBase2. baseExpEstimate := (self exponent * 10 asFloat reciprocalLogBase2 - 1.0e-10) ceiling. exp >= 0 ifTrue: [significand ~= 16r10000000000000 ifTrue: [r := significand bitShift: 1 + exp. s := 2. mPlus := mMinus := 1 bitShift: exp] ifFalse: [r := significand bitShift: 2 + exp. s := 4. mPlus := 2 * (mMinus := 1 bitShift: exp)]] ifFalse: [(exp = MinValLogBase2 or: [significand ~= 16r10000000000000]) ifTrue: [r := significand bitShift: 1. s := 1 bitShift: 1 - exp. mPlus := mMinus := 1] ifFalse: [r := significand bitShift: 2. s := 1 bitShift: 2 - exp. mPlus := 2. mMinus := 1]]. baseExpEstimate >= 0 ifTrue: [s := s * (10 raisedToInteger: baseExpEstimate)] ifFalse: [scale := 10 raisedToInteger: baseExpEstimate negated. r := r * scale. mPlus := mPlus * scale. mMinus := mMinus * scale]. ((r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]]) ifTrue: [baseExpEstimate := baseExpEstimate + 1] ifFalse: [r := r * 10. mPlus := mPlus * 10. mMinus := mMinus * 10]. (fixedFormat := baseExpEstimate between: -3 and: 6) ifTrue: [decPointCount := baseExpEstimate. baseExpEstimate <= 0 ifTrue: [denominator := 10 raisedTo: baseExpEstimate negated]] ifFalse: [decPointCount := 1]. slowbit := 1 - s lowBit . shead := s bitShift: slowbit. [d := (r bitShift: slowbit) // shead. r := r - (d * s). (tc1 := (r > mMinus) not and: [roundingIncludesLimits or: [r < mMinus]]) | (tc2 := (r + mPlus < s) not and: [roundingIncludesLimits or: [r + mPlus > s]])] whileFalse: [numerator := 10 * numerator + d. denominator := 10 * denominator. r := r * 10. mPlus := mPlus * 10. mMinus := mMinus * 10. decPointCount := decPointCount - 1. decPointCount = 0 ifTrue: [denominator := 1]]. tc2 ifTrue: [(tc1 not or: [r * 2 >= s]) ifTrue: [d := d + 1]]. numerator := 10 * numerator + d. denominator := 10 * denominator. decPointCount > 0 ifTrue: [numerator := (10 raisedTo: decPointCount - 1) * numerator]. fixedFormat ifFalse: [(baseExpEstimate - 1) > 0 ifTrue: [numerator := (10 raisedTo: baseExpEstimate - 1) * numerator] ifFalse: [denominator := (10 raisedTo: 1 - baseExpEstimate) * (denominator max: 1)]]. denominator < 2 ifTrue: [^numerator]. ^numerator / denominator! ! !Float methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitHookPrimitive: self! ! !Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:22'! + aNumber "Primitive. Answer the sum of the receiver and aNumber. Essential. Fail if the argument is not a Float. See Object documentation whatIsAPrimitive." ^ aNumber adaptToFloat: self andSend: #+! ! !Float methodsFor: 'mathematical functions' stamp: ''! tan "Answer the tangent of the receiver taken as an angle in radians." ^ self sin / self cos! ! !Float methodsFor: 'converting' stamp: ''! degreesToRadians "Answer the receiver in radians. Assumes the receiver is in degrees." ^self * RadiansPerDegree! ! !Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:55'! - aNumber "Primitive. Answer the difference between the receiver and aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^ aNumber adaptToFloat: self andSend: #-! ! !Float methodsFor: 'converting' stamp: 'nice 4/23/2011 02:24'! withNegativeSign "Same as super, but handle the subtle case of Float negativeZero" self = 0.0 ifTrue: [^self class negativeZero]. ^super withNegativeSign! ! !Float methodsFor: 'mathematical functions' stamp: ''! cos "Answer the cosine of the receiver taken as an angle in radians." ^ (self + Halfpi) sin! ! !Float methodsFor: 'accessing' stamp: 'eem 4/19/2009 18:03'! at: index ^self basicAt: index! ! !Float methodsFor: 'copying' stamp: 'pmm 3/13/2010 11:30'! veryDeepCopyWith: deepCopier "Return self. Do not record me." ^ self shallowCopy! ! !Float methodsFor: 'truncation and round off' stamp: 'nice 4/26/2006 05:09'! truncated "Answer with a SmallInteger equal to the value of the receiver without its fractional part. The primitive fails if the truncated value cannot be represented as a SmallInteger. In that case, the code below will compute a LargeInteger truncated value. Essential. See Object documentation whatIsAPrimitive. " (self isInfinite or: [self isNaN]) ifTrue: [self error: 'Cannot truncate this number']. self abs < 2.0e16 ifTrue: ["Fastest way when it may not be an integer" "^ (self quo: 1073741823.0) * 1073741823 + (self rem: 1073741823.0) truncated" | di df q r | di := (SmallInteger maxVal bitShift: -1)+1. df := di asFloat. q := self quo: df. r := self - (q asFloat * df). ^q*di+r truncated] ifFalse: [^ self asTrueFraction. "Extract all bits of the mantissa and shift if necess"] ! ! !Float methodsFor: 'truncation and round off' stamp: 'tk 12/30/2000 20:04'! reduce "If self is close to an integer, return that integer" (self closeTo: self rounded) ifTrue: [^ self rounded]! ! !Float methodsFor: 'truncation and round off' stamp: ''! integerPart "Answer a Float whose value is the receiver's truncated value." ^self - self fractionPart! ! !Float methodsFor: 'converting' stamp: 'st 9/17/2004 17:14'! asApproximateFractionAtOrder: maxOrder "Answer a Fraction approximating the receiver. This conversion uses the continued fraction method to approximate a floating point number. If maxOrder is zero, use maximum order" | num1 denom1 num2 denom2 int frac newD temp order | num1 := self asInteger. "The first of two alternating numerators" denom1 := 1. "The first of two alternating denominators" num2 := 1. "The second numerator" denom2 := 0. "The second denominator--will update" int := num1. "The integer part of self" frac := self fractionPart. "The fractional part of self" order := maxOrder = 0 ifTrue: [-1] ifFalse: [maxOrder]. [frac = 0 or: [order = 0] ] whileFalse: ["repeat while the fractional part is not zero and max order is not reached" order := order - 1. newD := 1.0 / frac. "Take reciprocal of the fractional part" int := newD asInteger. "get the integer part of this" frac := newD fractionPart. "and save the fractional part for next time" temp := num2. "Get old numerator and save it" num2 := num1. "Set second numerator to first" num1 := num1 * int + temp. "Update first numerator" temp := denom2. "Get old denominator and save it" denom2 := denom1. "Set second denominator to first" denom1 := int * denom1 + temp. "Update first denominator" 10000000000.0 < denom1 ifTrue: ["Is ratio past float precision? If so, pick which of the two ratios to use" num2 = 0.0 ifTrue: ["Is second denominator 0?" ^ Fraction numerator: num1 denominator: denom1]. ^ Fraction numerator: num2 denominator: denom2]]. "If fractional part is zero, return the first ratio" denom1 = 1 ifTrue: ["Am I really an Integer?" ^ num1 "Yes, return Integer result"] ifFalse: ["Otherwise return Fraction result" ^ Fraction numerator: num1 denominator: denom1]! ! !Float methodsFor: 'testing' stamp: 'nice 3/14/2008 23:45'! isFinite "simple, byte-order independent test for rejecting Not-a-Number and (Negative)Infinity" ^(self - self) = 0.0! ! !Float methodsFor: 'truncation and round off' stamp: ''! exponent "Primitive. Consider the receiver to be represented as a power of two multiplied by a mantissa (between one and two). Answer with the SmallInteger to whose power two is raised. Optional. See Object documentation whatIsAPrimitive." | positive | self >= 1.0 ifTrue: [^self floorLog: 2]. self > 0.0 ifTrue: [positive := (1.0 / self) exponent. self = (1.0 / (1.0 timesTwoPower: positive)) ifTrue: [^positive negated] ifFalse: [^positive negated - 1]]. self = 0.0 ifTrue: [^-1]. ^self negated exponent! ! !Float methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 2/8/2013 11:41'! printOn: stream base: base "Handle sign, zero, and NaNs; all other values passed to FloatPrintPolicy" self isNaN ifTrue: [ ^ stream nextPutAll: 'Float nan' ]. "check for NaN before sign" self isInfinite ifTrue: [ stream nextPutAll: 'Float infinity'. ^ self sign = -1 ifTrue: [ stream nextPutAll: ' negated' ] ]. self > 0.0 ifTrue: [ FloatPrintPolicy absPrint: self on: stream base: base ] ifFalse: [ self sign = -1 ifTrue: [ stream nextPut: $- ]. self = 0.0 ifTrue: [ stream nextPutAll: '0.0' ] ifFalse: [ FloatPrintPolicy absPrint: self negated on: stream base: base ] ]! ! !Float methodsFor: 'accessing' stamp: 'StephaneDucasse 9/24/2010 20:46'! basicAt: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive. This version of basicAt: is specifically for floats, answering the most significant word for index 1 and the least significant word for index 2. This alows the VM to store floats in whatever order it chooses while it appears to the image that they are always in big-endian/PowerPC order." ^super basicAt: index. ! ! !Float methodsFor: 'comparing' stamp: 'nice 6/11/2009 01:03'! hash "Hash is reimplemented because = is implemented. Both words of the float are used; 8 bits are removed from each end to clear most of the exponent regardless of the byte ordering. (The bitAnd:'s ensure that the intermediate results do not become a large integer.) Slower than the original version in the ratios 12:5 to 2:1 depending on values. (DNS, 11 May, 1997)" (self isFinite and: [self fractionPart = 0.0]) ifTrue: [^self truncated hash]. ^ (((self basicAt: 1) bitAnd: 16r00FFFF00) + ((self basicAt: 2) bitAnd: 16r00FFFF00)) bitShift: -8 ! ! !Float methodsFor: 'mathematical functions' stamp: 'nice 7/15/2011 13:59'! ln "Answer the natural logarithm of the receiver. Optional. See Object documentation whatIsAPrimitive." | expt n mant x div pow delta sum eps | "Taylor series" self <= 0.0 ifTrue: [^DomainError signal: 'ln is only defined for x > 0' from: 0]. "get a rough estimate from binary exponent" expt := self exponent. n := Ln2 * expt. mant := self timesTwoPower: 0 - expt. "compute fine correction from mantinssa in Taylor series" "mant is in the range [0..2]" "we unroll the loop to avoid use of abs" x := mant - 1.0. div := 1.0. pow := delta := sum := x. x := x negated. "x <= 0" eps := Epsilon * (n abs + 1.0). [delta > eps] whileTrue: [ "pass one: delta is positive" div := div + 1.0. pow := pow * x. delta := pow / div. sum := sum + delta. "pass two: delta is negative" div := div + 1.0. pow := pow * x. delta := pow / div. sum := sum + delta]. ^ n + sum "2.718284 ln 1.0"! ! !Float methodsFor: 'mathematical functions' stamp: 'nice 11/1/2010 11:56'! degreeSin "Take care of exceptional values" self isFinite ifTrue: [^super degreeSin]. ^self degreesToRadians sin! ! !Float methodsFor: 'mathematical functions' stamp: 'CamilloBruni 8/1/2012 16:16'! sqrt "Answer the square root of the receiver. Optional. See Object documentation whatIsAPrimitive." | exp guess eps delta | "Newton-Raphson" self <= 0.0 ifTrue: [self = 0.0 ifTrue: [^ 0.0] ifFalse: ["v Chg" ^ DomainError signal: 'sqrt undefined for number less than zero.']]. "first guess is half the exponent" exp := self exponent // 2. guess := self timesTwoPower: 0 - exp. "get eps value" eps := guess * Epsilon. eps := eps * eps. delta := self - (guess * guess) / (guess * 2.0). [delta * delta > eps] whileTrue: [guess := guess + delta. delta := self - (guess * guess) / (guess * 2.0)]. ^ guess! ! !Float methodsFor: 'copying' stamp: ''! deepCopy ^self copy! ! !Float methodsFor: 'printing' stamp: 'nice 3/15/2008 22:41'! storeOn: aStream "Print the Number exactly so it can be interpreted back unchanged" self storeOn: aStream base: 10! ! !Float methodsFor: 'truncation and round off' stamp: 'nice 6/7/2012 00:17'! significandAsInteger "Answer the mantissa of a Float shifted so as to have the ulp equal to 1. For exceptional values, infinity and nan, just answer the bit pattern." self isFinite ifTrue: [^(self timesTwoPower: self class precision - 1 - (self exponent max: self class emin)) truncated abs]. ^(((self basicAt: 1) bitAnd: 16r000FFFFF) bitShift: 32) bitOr: (self basicAt: 2)! ! !Float methodsFor: 'converting' stamp: 'nice 3/29/2006 01:01'! asTrueFraction " Answer a fraction that EXACTLY represents self, a double precision IEEE floating point number. Floats are stored in the same form on all platforms. (Does handle gradual underflow but not NANs.) By David N. Smith with significant performance improvements by Luciano Esteban Notarfrancesco. (Version of 11April97)" | signexp positive expPart exp fraction fractionPart signedFraction result zeroBitsCount | self isInfinite ifTrue: [self error: 'Cannot represent infinity as a fraction']. self isNaN ifTrue: [self error: 'Cannot represent Not-a-Number as a fraction']. " Extract the sign and the biased exponent " signexp := (self basicAt: 1) bitShift: -20. positive := (signexp bitAnd: 16r800) = 0. expPart := signexp bitAnd: 16r7FF. " Extract fractional part; answer 0 if this is a true 0.0 value " fractionPart := (((self basicAt: 1) bitAnd: 16rFFFFF) bitShift: 32)+ (self basicAt: 2). ( expPart=0 and: [ fractionPart=0 ] ) ifTrue: [ ^ 0 ]. " Replace omitted leading 1 in fraction unless gradual underflow" fraction := expPart = 0 ifTrue: [fractionPart bitShift: 1] ifFalse: [fractionPart bitOr: 16r0010000000000000]. signedFraction := positive ifTrue: [fraction] ifFalse: [fraction negated]. "Unbias exponent: 16r3FF is bias; 52 is fraction width" exp := 16r3FF + 52 - expPart. " Form the result. When exp>52, the exponent is adjusted by the number of trailing zero bits in the fraction to minimize the (huge) time otherwise spent in #gcd:. " exp negative ifTrue: [ result := signedFraction bitShift: exp negated ] ifFalse: [ zeroBitsCount := fraction lowBit - 1. exp := exp - zeroBitsCount. exp <= 0 ifTrue: [ zeroBitsCount := zeroBitsCount + exp. "exp := 0." " Not needed; exp not refernced again " result := signedFraction bitShift: zeroBitsCount negated ] ifFalse: [ result := Fraction numerator: (signedFraction bitShift: zeroBitsCount negated) denominator: (1 bitShift: exp) ] ]. "Low cost validation omitted after extensive testing" "(result asFloat = self) ifFalse: [self error: 'asTrueFraction validation failed']." ^ result ! ! !Float methodsFor: 'testing' stamp: 'nice 3/14/2008 23:49'! isLiteral "There is no literal representation of NaN. However, there are literal representations of Infinity, like 1.0e1000. But since they are not able to print properly, only case of finite Float is considered." ^self isFinite! ! !Float methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:36'! > aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is greater than the argument. Otherwise return false. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^ aNumber adaptToFloat: self andCompare: #>! ! !Float methodsFor: 'mathematical functions' stamp: 'nice 7/15/2011 14:12'! arcSin "Answer the angle in radians." ((self < -1.0) or: [self > 1.0]) ifTrue: [^DomainError signal: 'Value out of range' from: -1 to: 1]. ((self = -1.0) or: [self = 1.0]) ifTrue: [^ Halfpi * self] ifFalse: [^ (self / (1.0 - (self * self)) sqrt) arcTan]! ! !Float methodsFor: 'copying' stamp: 'nice 10/4/2009 23:16'! shallowCopy ^self - 0.0! ! !Float methodsFor: 'mathematical functions' stamp: 'nice 4/23/2011 02:26'! copySignTo: aNumber "Return a number with same magnitude as aNumber and same sign as self. Implementation note: take care of Float negativeZero, which is considered as having a negative sign." (self > 0.0 or: [(self at: 1) = 0]) ifTrue: [^ aNumber abs]. ^aNumber withNegativeSign! ! !Float methodsFor: 'private' stamp: 'StephaneDucasse 10/16/2011 18:07'! absPrintOn: aStream base: base digitCount: digitCount "Print me in the given base, using digitCount significant figures." | fuzz x exp q fBase scale logScale xi | self isInfinite ifTrue: [^ aStream nextPutAll: 'Infinity']. fBase := base asFloat. "x is myself normalized to [1.0, fBase), exp is my exponent" exp := self < 1.0 ifTrue: [self reciprocalFloorLog: fBase] ifFalse: [self floorLog: fBase]. scale := 1.0. logScale := 0. [(x := fBase raisedTo: (exp + logScale)) = 0] whileTrue: [scale := scale * fBase. logScale := logScale + 1]. x := self * scale / x. fuzz := fBase raisedTo: 1 - digitCount. "round the last digit to be printed" x := 0.5 * fuzz + x. x >= fBase ifTrue: ["check if rounding has unnormalized x" x := x / fBase. exp := exp + 1]. (exp < 6 and: [exp > -4]) ifTrue: ["decimal notation" q := 0. exp < 0 ifTrue: [1 to: 1 - exp do: [:i | aStream nextPut: ('0.0000' at: i)]]] ifFalse: ["scientific notation" q := exp. exp := 0]. [x >= fuzz] whileTrue: ["use fuzz to track significance" xi := x asInteger. aStream nextPut: (Character digitValue: xi). x := x - xi asFloat * fBase. fuzz := fuzz * fBase. exp := exp - 1. exp = -1 ifTrue: [aStream nextPut: $.]]. [exp >= -1] whileTrue: [aStream nextPut: $0. exp := exp - 1. exp = -1 ifTrue: [aStream nextPut: $.]]. q ~= 0 ifTrue: [aStream nextPut: $e. q printOn: aStream]! ! !Float methodsFor: 'printing' stamp: 'StephaneDucasse 2/28/2011 09:22'! printPaddedWith: aCharacter to: aNumber "Answer the string containing the ASCII representation of the receiver padded on the left with aCharacter to be at least on aNumber integerPart characters and padded the right with aCharacter to be at least anInteger fractionPart characters." | aStream digits fPadding fLen iPadding iLen curLen periodIndex | #Numeric. "2000/03/04 Harmon R. Added Date and Time support" aStream := (String new: 10) writeStream. self printOn: aStream. digits := aStream contents. periodIndex := digits indexOf: $.. curLen := periodIndex - 1. iLen := aNumber integerPart. curLen < iLen ifTrue: [iPadding := (String new: (iLen - curLen) asInteger) atAllPut: aCharacter; yourself] ifFalse: [iPadding := '']. curLen := digits size - periodIndex. "n.b. Treat aNumber as a string format specifier rather than as a number, because floating point truncation can produce incorrect results for the fraction part." fLen := (aNumber asString copyAfterLast: $. ) ifNotEmpty: [:s | s asInteger] ifEmpty: [ 0 ]. curLen < fLen ifTrue: [fPadding := (String new: fLen - curLen) atAllPut: aCharacter; yourself] ifFalse: [fPadding := '']. ^ iPadding , digits , fPadding! ! !Float methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 10:55'! serializeOn: anEncoder anEncoder encodeUint32: (self at: 1); encodeUint32: (self at: 2).! ! !Float methodsFor: 'converting' stamp: ''! asFloat "Answer the receiver itself." ^self! ! !Float methodsFor: 'printing' stamp: 'nice 3/24/2008 16:56'! printShowingDecimalPlaces: placesDesired "This implementation avoids any rounding error caused by rounded or roundTo:" ^self asTrueFraction printShowingDecimalPlaces: placesDesired! ! !Float methodsFor: 'printing' stamp: 'nice 10/31/2009 23:45'! storeOn: aStream base: base "Print the Number exactly so it can be interpreted back unchanged" self isFinite ifTrue: [self sign = -1 ifTrue: [aStream nextPutAll: '-']. base = 10 ifFalse: [aStream print: base; nextPut: $r]. self = 0.0 ifTrue: [aStream nextPutAll: '0.0'] ifFalse: [self abs absPrintExactlyOn: aStream base: base]] ifFalse: [self isNaN ifTrue: [aStream nextPutAll: 'Float nan'] ifFalse: [self > 0.0 ifTrue: [aStream nextPutAll: 'Float infinity'] ifFalse: [aStream nextPutAll: 'Float infinity negated']]]! ! !Float methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:36'! = aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is equal to the argument. Otherwise return false. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." aNumber isNumber ifFalse: [^ false]. ^ aNumber adaptToFloat: self andCompare: #=! ! !Float methodsFor: 'converting' stamp: 'st 9/17/2004 17:17'! asApproximateFraction "Answer a Fraction approximating the receiver. This conversion uses the continued fraction method to approximate a floating point number." ^ self asApproximateFractionAtOrder: 0! ! !Float methodsFor: 'truncation and round off' stamp: 'nice 12/2/2009 17:35'! successor | ulp | self isFinite ifFalse: [ (self isNaN or: [self positive]) ifTrue: [^self]. ^Float fmax negated]. self = 0.0 ifTrue: [^Float fmin]. ulp := self ulp. ^self + (0.5 * ulp) = self ifTrue: [self + ulp] ifFalse: [self + (0.5 * ulp)]! ! !Float methodsFor: 'converting' stamp: 'di 11/6/1998 13:07'! adaptToInteger: rcvr andSend: selector "If I am involved in arithmetic with an Integer, convert it to a Float." ^ rcvr asFloat perform: selector with: self! ! !Float methodsFor: 'testing' stamp: 'jm 4/30/1998 13:50'! isInfinite "Return true if the receiver is positive or negative infinity." ^ self = Infinity or: [self = NegativeInfinity] ! ! !Float methodsFor: 'truncation and round off' stamp: 'tao 4/19/98 13:14'! significand ^ self timesTwoPower: (self exponent negated)! ! !Float methodsFor: 'testing' stamp: 'StephaneDucasse 10/16/2011 18:14'! isSelfEvaluating ^true! ! !Float methodsFor: 'truncation and round off' stamp: 'GuillermoPolito 6/22/2012 14:45'! round: numberOfWishedDecimal "only leave a fixed amount of decimal" "10.12345 round: 2 => 10.12" | v | v := 10 raisedTo: numberOfWishedDecimal. ^ ((self * v) rounded / v) asFloat ! ! !Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'! * aNumber "Primitive. Answer the result of multiplying the receiver by aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^ aNumber adaptToFloat: self andSend: #*! ! !Float methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:36'! <= aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is less than or equal to the argument. Otherwise return false. Fail if the argument is not a Float. Optional. See Object documentation whatIsAPrimitive." ^ aNumber adaptToFloat: self andCompare: #<=! ! !Float methodsFor: 'converting' stamp: 'nice 5/30/2006 02:29'! asIEEE32BitWord "Convert the receiver into a 32 bit Integer value representing the same number in IEEE 32 bit format. Used for conversion in FloatArrays only." | word1 word2 sign mantissa exponent destWord truncatedBits mask roundToUpper | "skip fast positive and nnegative zero" self = 0.0 ifTrue: [^self basicAt: 1]. "retrieve 64 bits of IEEE 754 double" word1 := self basicAt: 1. word2 := self basicAt: 2. "prepare sign exponent and mantissa of 32 bits float" sign := word1 bitAnd: 16r80000000. exponent := ((word1 bitShift: -20) bitAnd: 16r7FF) - 1023 + 127. mantissa := (word2 bitShift: -29) + ((word1 bitAnd: 16rFFFFF) bitShift: 3). truncatedBits := (word2 bitAnd: 16r1FFFFFFF). "We must now honour default IEEE rounding mode (round to nearest even)" "we are below gradual underflow, even if rounded to upper mantissa" exponent < -24 ifTrue: [^sign "this can be negative zero"]. "BEWARE: rounding occurs on less than 23bits when gradual underflow" exponent <= 0 ifTrue: [mask := 1 bitShift: exponent negated. mantissa := mantissa bitOr: 16r800000. roundToUpper := (mantissa bitAnd: mask) isZero not and: [truncatedBits isZero not or: [(mantissa bitAnd: mask - 1) isZero not or: [(mantissa bitAnd: mask*2) isZero not]]]. mantissa := mantissa bitShift: exponent - 1. "exponent := exponent + 1"] ifFalse: [roundToUpper := (truncatedBits bitAnd: 16r10000000) isZero not and: [(mantissa bitAnd: 16r1) isZero not or: [(truncatedBits bitAnd: 16r0FFFFFFF) isZero not]] ]. "adjust mantissa and exponent due to IEEE rounding mode" roundToUpper ifTrue: [mantissa := mantissa + 1. mantissa > 16r7FFFFF ifTrue: [mantissa := 0. exponent := exponent+1]]. exponent > 254 ifTrue: ["Overflow" exponent := 255. self isNaN ifTrue: [mantissa isZero ifTrue: ["BEWARE: do not convert a NaN to infinity due to truncatedBits" mantissa := 1]] ifFalse: [mantissa := 0]]. "Encode the word" destWord := (sign bitOr: ((exponent max: 0) bitShift: 23)) bitOr: mantissa. ^ destWord! ! !Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:20'! fmax "Answer the maximum finite floating point value representable." ^MaxVal! ! !Float class methodsFor: 'constants' stamp: 'sw 10/8/1999 22:59'! halfPi ^ Halfpi! ! !Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:22'! fminDenormalized "Answer the minimum denormalized value representable." ^1.0 timesTwoPower: MinValLogBase2! ! !Float class methodsFor: 'instance creation' stamp: ''! readFrom: aStream "Answer a new Float as described on the stream, aStream." ^(super readFrom: aStream) asFloat! ! !Float class methodsFor: 'constants' stamp: ''! e "Answer the constant, E." ^E! ! !Float class methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 11:00'! materializeFrom: aDecoder ^ (self new: 2) at: 1 put: aDecoder nextEncodedUint32; at: 2 put: aDecoder nextEncodedUint32; yourself. ! ! !Float class methodsFor: 'constants' stamp: 'tao 4/23/98 11:37'! infinity "Answer the value used to represent an infinite magnitude" ^ Infinity! ! !Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:33'! fmin "Answer minimum positive representable value." ^self denormalized ifTrue: [self fminDenormalized] ifFalse: [self fminNormalized]! ! !Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:43'! emin "Answer exponent of minimal normalized representable value" ^-1022! ! !Float class methodsFor: 'class initialization' stamp: 'nice 3/15/2008 22:42'! initialize "Float initialize" "Constants from Computer Approximations, pp. 182-183: Pi = 3.14159265358979323846264338327950288 Pi/2 = 1.57079632679489661923132169163975144 Pi*2 = 6.28318530717958647692528676655900576 Pi/180 = 0.01745329251994329576923690768488612 2.0 ln = 0.69314718055994530941723212145817657 2.0 sqrt = 1.41421356237309504880168872420969808" Pi := 3.14159265358979323846264338327950288. Halfpi := Pi / 2.0. Twopi := Pi * 2.0. ThreePi := Pi * 3.0. RadiansPerDegree := Pi / 180.0. Ln2 := 0.69314718055994530941723212145817657. Ln10 := 10.0 ln. Sqrt2 := 1.41421356237309504880168872420969808. E := 2.718281828459045235360287471353. Epsilon := 0.000000000001. "Defines precision of mathematical functions" MaxVal := 1.7976931348623157e308. MaxValLn := 709.782712893384. MinValLogBase2 := -1074. Infinity := MaxVal * MaxVal. NegativeInfinity := 0.0 - Infinity. NaN := Infinity - Infinity. NegativeZero := 1.0 / Infinity negated. ! ! !Float class methodsFor: 'constants' stamp: 'tao 4/23/98 12:05'! negativeZero ^ NegativeZero! ! !Float class methodsFor: 'instance creation' stamp: 'nice 3/15/2008 00:54'! readFrom: aStream ifFail: aBlock "Answer a new Float as described on the stream, aStream." ^(super readFrom: aStream ifFail: [^aBlock value]) asFloat! ! !Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:22'! fminNormalized "Answer the minimum normalized value representable." ^1.0 timesTwoPower: -1022! ! !Float class methodsFor: 'constants' stamp: 'nice 6/11/2009 12:29'! denormalized "Answer whether implementation supports denormalized numbers (also known as gradual underflow)." ^true! ! !Float class methodsFor: 'constants' stamp: 'nice 6/11/2009 12:40'! precision "Answer the apparent precision of the floating point representation. That is the maximum number of radix-based digits (bits if radix=2) representable in floating point without round off error. Technically, 52 bits are stored in the representation, and normalized numbers have an implied leading 1 that does not need to be stored. Note that denormalized floating point numbers don't have the implied leading 1, and thus gradually loose precision. This format conforms IEEE 754 double precision standard." ^53! ! !Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:16'! radix "Answer the radix used for internal floating point representation." ^2! ! !Float class methodsFor: 'constants' stamp: 'tao 4/23/98 11:38'! nan "Answer the canonical value used to represent Not-A-Number" ^ NaN! ! !Float class methodsFor: '*Spec-Inspector' stamp: 'SvenVanCaekenberghe 12/21/2013 20:46'! inspectorClass ^ EyeFloatInspector! ! !Float class methodsFor: 'instance creation' stamp: 'VeronicaUquillas 6/11/2010 14:02'! fromIEEE32Bit: word "Convert the given 32 bit word (which is supposed to be a positive 32bit value) from a 32bit IEEE floating point representation into an actual Pharo float object (being 64bit wide). Should only be used for conversion in FloatArrays or likewise objects." | sign mantissa exponent newFloat delta | word negative ifTrue: [^ self error:'Cannot deal with negative numbers']. word = 0 ifTrue: [^ 0.0]. sign := word bitAnd: 16r80000000. word = sign ifTrue: [^self negativeZero]. exponent := ((word bitShift: -23) bitAnd: 16rFF) - 127. mantissa := word bitAnd: 16r7FFFFF. exponent = 128 ifTrue:["Either NAN or INF" mantissa = 0 ifFalse:[^ Float nan]. sign = 0 ifTrue:[^ Float infinity] ifFalse:[^ Float infinity negated]]. exponent = -127 ifTrue: [ "gradual underflow (denormalized number) Remove first bit of mantissa and adjust exponent" delta := mantissa highBit. mantissa := (mantissa bitShift: 1) bitAnd: (1 bitShift: delta) - 1. exponent := exponent + delta - 23]. "Create new float" newFloat := self new: 2. newFloat basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3)). newFloat basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29). ^newFloat! ! !Float class methodsFor: 'constants' stamp: 'GabrielOmarCotelli 5/25/2009 15:42'! one ^1.0! ! !Float class methodsFor: 'constants' stamp: 'nice 6/11/2009 12:30'! epsilon "Answer difference between 1.0 and previous representable value" ^1.0 timesTwoPower: 1 - self precision! ! !Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:42'! emax "Answer exponent of maximal representable value" ^1023! ! !Float class methodsFor: 'constants' stamp: 'yo 6/17/2004 17:44'! threePi ^ ThreePi ! ! !Float class methodsFor: 'constants' stamp: ''! pi "Answer the constant, Pi." ^Pi! ! !Float class methodsFor: 'constants' stamp: 'jmv 10/13/2011 19:57'! maxExactInteger "Answer the biggest integer such that it is exactly represented in a float, and all smaller integers also are" ^1 bitShift: self precision! ! !Float class methodsFor: 'constants' stamp: 'yo 6/17/2004 17:41'! twoPi ^ Twopi ! ! !FloatArray commentStamp: ''! FloatArrays store 32bit IEEE floating point numbers.! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'ar 9/14/1998 22:48'! += anObject ^anObject isNumber ifTrue:[self primAddScalar: anObject asFloat] ifFalse:[self primAddArray: anObject]! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! primMulScalar: scalarValue 1 to: self size do:[:i| self at: i put: (self at: i) * scalarValue].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! primAddScalar: scalarValue 1 to: self size do:[:i| self at: i put: (self at: i) + scalarValue].! ! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'yo 9/14/2004 17:12'! \\= other other isNumber ifTrue: [ 1 to: self size do: [:i | self at: i put: (self at: i) \\ other ]. ^ self. ]. 1 to: (self size min: other size) do: [:i | self at: i put: (self at: i) \\ (other at: i). ]. ! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! primDivScalar: scalarValue 1 to: self size do:[:i| self at: i put: (self at: i) / scalarValue].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! primAddArray: floatArray 1 to: self size do:[:i| self at: i put: (self at: i) + (floatArray at: i)].! ! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'GuillermoPolito 2/18/2011 07:23'! + anObject ^self copy += anObject! ! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'StephaneDucasse 12/24/2011 12:04'! - anObject ^self shallowCopy -= anObject! ! !FloatArray methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! at: index ^Float fromIEEE32Bit: (self basicAt: index)! ! !FloatArray methodsFor: 'converting' stamp: 'ar 9/14/1998 23:46'! asFloatArray ^self! ! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'ar 9/14/1998 22:49'! -= anObject ^anObject isNumber ifTrue:[self primSubScalar: anObject asFloat] ifFalse:[self primSubArray: anObject]! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'jcg 6/12/2003 17:54'! sum ^ super sum! ! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'ar 9/14/1998 22:49'! *= anObject ^anObject isNumber ifTrue:[self primMulScalar: anObject asFloat] ifFalse:[self primMulArray: anObject]! ! !FloatArray methodsFor: 'arithmetic' stamp: 'MarcusDenker 3/22/2011 20:18'! dot: aFloatVector "Primitive. Return the dot product of the receiver and the argument. Fail if the argument is not of the same size as the receiver." | result | self size = aFloatVector size ifFalse:[^self error:'Must be equal size']. result := 0.0. 1 to: self size do:[:i| result := result + ((self at: i) * (aFloatVector at: i))]. ^result! ! !FloatArray methodsFor: 'comparing' stamp: 'ar 5/3/2001 13:02'! hash | result | result := 0. 1 to: self size do:[:i| result := result + (self basicAt: i) ]. ^result bitAnd: 16r1FFFFFFF! ! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'GuillermoPolito 2/18/2011 07:23'! negated ^self copy *= -1! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! primSubScalar: scalarValue 1 to: self size do:[:i| self at: i put: (self at: i) - scalarValue].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! primDivArray: floatArray 1 to: self size do:[:i| self at: i put: (self at: i) / (floatArray at: i)].! ! !FloatArray methodsFor: 'comparing' stamp: 'ar 2/2/2001 15:47'! = aFloatArray | length | aFloatArray class = self class ifFalse: [^ false]. length := self size. length = aFloatArray size ifFalse: [^ false]. 1 to: self size do: [:i | (self at: i) = (aFloatArray at: i) ifFalse: [^ false]]. ^ true! ! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'ar 10/7/1998 19:58'! /= anObject ^anObject isNumber ifTrue:[self primDivScalar: anObject asFloat] ifFalse:[self primDivArray: anObject]! ! !FloatArray methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! at: index put: value value isFloat ifTrue:[self basicAt: index put: value asIEEE32BitWord] ifFalse:[self at: index put: value asFloat]. ^value! ! !FloatArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! defaultElement "Return the default element of the receiver" ^0.0! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! primSubArray: floatArray 1 to: self size do:[:i| self at: i put: (self at: i) - (floatArray at: i)].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'! primMulArray: floatArray 1 to: self size do:[:i| self at: i put: (self at: i) * (floatArray at: i)].! ! !FloatArray methodsFor: 'private' stamp: 'ar 10/9/1998 11:27'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'nice 11/24/2007 00:10'! adaptToNumber: rcvr andSend: selector "If I am involved in arithmetic with a Number. If possible, convert it to a float and perform the (more efficient) primitive operation." selector == #+ ifTrue:[^self + rcvr]. selector == #* ifTrue:[^self * rcvr]. selector == #- ifTrue:[^self negated += rcvr]. selector == #/ ifTrue:[ "DO NOT USE TRIVIAL CODE ^self reciprocal * rcvr BECAUSE OF GRADUAL UNDERFLOW self should: (1.0e-39 / (FloatArray with: 1.0e-39)) first < 2." ^(self class new: self size withAll: rcvr) / self ]. ^super adaptToNumber: rcvr andSend: selector! ! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'GuillermoPolito 2/18/2011 07:23'! * anObject ^self copy *= anObject! ! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'GuillermoPolito 2/18/2011 07:22'! / anObject ^self copy /= anObject! ! !FloatArrayTest commentStamp: 'nice 5/30/2006 01:24'! These tests are used to assert that FloatArrayPlugin has same results as Float asIEEE32BitWord! !FloatArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButLast "self debug: #testAllButLast" | abf col | col := self moreThan3Elements. abf := col allButLast. self deny: abf last = col last. self assert: abf size + 1 = col size! ! !FloatArrayTest methodsFor: 'tests - begins ends with' stamp: ''! testsEndsWith self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst). self assert: (self nonEmpty endsWith: self nonEmpty). self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first)).! ! !FloatArrayTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElementsOfIdenticalCollectionObjects "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" self assert: (self empty hasEqualElements: self empty). self assert: (self nonEmpty hasEqualElements: self nonEmpty). ! ! !FloatArrayTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceAllWith1Occurence | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . index:= firstIndexesOfOccurrence at: 1. "verify content of 'result' : " "first part of 'result'' : '" 1 to: (index -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " index to: (index + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) ]. " end part :" endPartIndexResult := index + self replacementCollection size . endPartIndexCollection := index + self oldSubCollection size . 1 to: (result size - endPartIndexResult - 1 ) do: [ :i | self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). ]. ! ! !FloatArrayTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOf "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyWithReplacementTest self replacementCollection. self oldSubCollection. self collectionWith1TimeSubcollection. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:36'! moreThan4Elements " return a collection including at leat 4 elements" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:27'! secondIndex " return an index between 'nonEmpty' bounds that is > to 'first index' " ^self firstIndex +1! ! !FloatArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testFirstNElements "self debug: #testFirstNElements" | result | result := self moreThan3Elements first: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: Error! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:35'! collectionWith2TimeSubcollection " return a collection including 'oldSubCollection' two or many time " ^ collectionWith2TimeSubcollection ifNil: [ collectionWith2TimeSubcollection := self collectionWith1TimeSubcollection, self oldSubCollection ].! ! !FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testFromToPut | collection index | index := self indexArray anyOne. collection := self nonEmpty copy. collection from: 1 to: index put: self aValue.. 1 to: index do: [:i | self assert: (collection at: i)= self aValue]. (index +1) to: collection size do: [:i | self assert: (collection at:i)= (self nonEmpty at:i)].! ! !FloatArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithoutFirst | result | result := self nonEmpty copyWithoutFirst. self assert: result size = (self nonEmpty size - 1). 1 to: result size do: [:i | self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0TStructuralEqualityTest self empty. self nonEmpty. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty! ! !FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:37'! unsortedCollection " retur a collection that is not yat sorted" ^nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testLastIndexOfDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element) = collection size! ! !FloatArrayTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !FloatArrayTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asArray sort. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:11'! collectionWithoutEqualElements " return a collection not including equal elements " ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - converting' stamp: ''! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !FloatArrayTest methodsFor: 'test - creation' stamp: ''! testWith "self debug: #testWith" | aCol anElement | anElement := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: anElement. self assert: (aCol includes: anElement).! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testBefore "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). self should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] raise: Error. self should: [ self moreThan4Elements before: 66 ] raise: Error! ! !FloatArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyNotSame "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self nonEmpty copy. self deny: copy == self nonEmpty.! ! !FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindFirst | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. self assert: result=1. ! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyUpToWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpTo:' should copy until the first occurence :" result := collection copyUpTo: (element ). "verifying content: " self assert: result isEmpty. ! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! testOFixtureReplacementSequencedTest self nonEmpty. self deny: self nonEmpty isEmpty. self elementInForReplacement. self assert: (self nonEmpty includes: self elementInForReplacement ) . self newElement. self firstIndex. self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). self secondIndex. self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). self assert: self firstIndex <=self secondIndex . self replacementCollection. self replacementCollectionSameSize. self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithIndexCollect | result index collection | index := 0. collection := self nonEmptyMoreThan1Element . result := collection withIndexCollect: [:each :i | self assert: i = (index := index + 1). self assert: i = (collection indexOf: each) . each] . 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. self assert: result size = collection size.! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:26'! firstIndex " return an index between 'nonEmpty' bounds that is < to 'second index' " ^2! ! !FloatArrayTest methodsFor: 'tests - printing' stamp: ''! testPrintElementsOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !FloatArrayTest methodsFor: 'tests - begins ends with' stamp: ''! testsEndsWithEmpty self deny: (self nonEmpty endsWith: self empty). self deny: (self empty endsWith: self nonEmpty). ! ! !FloatArrayTest methodsFor: 'tests - concatenation' stamp: ''! testConcatenationWithEmpty | result | result:= self empty,self secondCollection . 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:i). ]. "size : " self assert: result size = ( self secondCollection size).! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIterateSequencedReadableTest | res | self nonEmptyMoreThan1Element. self assert: self nonEmptyMoreThan1Element size > 1. self empty. self assert: self empty isEmpty . res := true. self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false.! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:50'! anotherElementNotIn " return an element different of 'elementNotIn' not included in 'nonEmpty' " ^ elementNotIn ! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyUpToLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpToLast:' should copy until the last occurence :" result := collection copyUpToLast: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (result at: i ) = ( collection at: i ) ]. self assert: result size = (collection size - 1). ! ! !FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testSwapWith "self debug: #testSwapWith" | result index | index := self indexArray anyOne. result:= self nonEmpty copy . result swap: index with: 1. self assert: (result at: index) = (self nonEmpty at:1). self assert: (result at: 1) = (self nonEmpty at: index). ! ! !FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtAllIndexesPut self nonEmpty atAllPut: self aValue. self nonEmpty do:[ :each| self assert: each = self aValue]. ! ! !FloatArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithSequenceable | result index element | index := self indexInNonEmpty . element := self nonEmpty at: index. result := self nonEmpty copyWith: (element ). self assert: result size = (self nonEmpty size + 1). self assert: result last = element . 1 to: (result size - 1) do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:39'! collectionWith1TimeSubcollection " return a collection including 'oldSubCollection' only one time " ^ collectionWith1TimeSubcollection ifNil: [ collectionWith1TimeSubcollection := collectionWithSameAtEndAndBegining , self oldSubCollection , collectionWithSameAtEndAndBegining ].! ! !FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtAllPut | | self nonEmpty atAll: self indexArray put: self aValue.. self indexArray do: [:i | self assert: (self nonEmpty at: i)=self aValue ]. ! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtOutOfBounds "self debug: #testAtOutOfBounds" self should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] raise: Error. self should: [ self moreThan4Elements at: -1 ] raise: Error! ! !FloatArrayTest methodsFor: 'test - creation' stamp: ''! testOfSize "self debug: #testOfSize" | aCol | aCol := self collectionClass ofSize: 3. self assert: (aCol size = 3). ! ! !FloatArrayTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithCollect | result firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := 0. result := firstCollection with: secondCollection collect: [:a :b | ( index := index + 1). self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b. b]. 1 to: result size do:[: i | self assert: (result at:i)= (secondCollection at: i)]. self assert: result size = secondCollection size.! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSetAritmeticTest self collection. self deny: self collection isEmpty. self nonEmpty. self deny: self nonEmpty isEmpty. self anotherElementOrAssociationNotIn. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self collectionClass! ! !FloatArrayTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiter | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeWithIdentityTest | anElement | self collectionWithCopyNonIdentical. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:44'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePutTest self aValue. self anotherValue. self anIndex. self nonEmpty isDictionary ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. self empty. self assert: self empty isEmpty . self nonEmpty. self deny: self nonEmpty isEmpty.! ! !FloatArrayTest methodsFor: 'tests - replacing' stamp: ''! testReplaceFromToWithStartingAt | result repStart collection replacementCollec firstInd secondInd | collection := self nonEmpty . result := collection copy. replacementCollec := self replacementCollectionSameSize . firstInd := self firstIndex . secondInd := self secondIndex . repStart := replacementCollec size - ( secondInd - firstInd + 1 ) + 1. result replaceFrom: firstInd to: secondInd with: replacementCollec startingAt: repStart . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstInd - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstInd ) to: ( replacementCollec size - repStart +1 ) do: [:i| self assert: (result at: i)=( replacementCollec at: ( repStart + ( i - firstInd ) ) ) ]. " end part :" ( firstInd + replacementCollec size ) to: ( result size ) do: [ :i | self assert: ( result at: i ) = ( collection at: ( secondInd + 1 - ( firstInd + replacementCollec size ) + i ) ) ].! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self collectionWithoutEqualElements. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !FloatArrayTest methodsFor: 'requirements' stamp: ''! valueArray " return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty' at indexes in 'indexArray' " | result | result := Array new: self indexArray size. 1 to: result size do: [:i | result at:i put: (self aValue ). ]. ^ result.! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterMore | delim multiItemStream result index | "delim := ', '. multiItemStream := '' readWrite. self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. self assert: multiItemStream contents = '1, 2, 3'." delim := ', '. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. index:=1. (result findBetweenSubStrs: ', ' )do: [:each | self assert: each= ((self nonEmpty at:index)asString). index:=index+1 ].! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:23'! anIndex " return an index in nonEmpty bounds" ^ 2! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:05'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testDetectSequenced " testing that detect keep the first element returning true for sequenceable collections " | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. self assert: result = element. ! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureAsStringCommaAndDelimiterTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty. self nonEmpty1Element. self assert: self nonEmpty1Element size = 1! ! !FloatArrayTest methodsFor: 'testing' stamp: 'nice 5/30/2006 03:17'! testFloatArrayPluginPrimitiveAt "if FloatArrayPlugin primitive are not here, this test is dumb. Otherwise, it will compare primitive and #fromIEEE32Bit:" #( "regular numbers no truncation or rounding" 2r0.0 2r1.0 2r1.1 2r1.00000000000000000000001 2r1.0e-10 2r1.1e-10 2r1.00000000000000000000001e-10 2r1.0e10 2r1.1e10 2r1.00000000000000000000001e10 "smallest float32 before gradual underflow" 2r1.0e-126 "biggest float32" 2r1.11111111111111111111111e127 "overflow" 2r1.11111111111111111111111e128 "gradual underflow" 2r0.11111111111111111111111e-126 2r0.00000000000000000000001e-126 "with rounding mode : tests on 25 bits" 2r1.0000000000000000000000001 2r1.0000000000000000000000010 2r1.0000000000000000000000011 2r1.0000000000000000000000100 2r1.0000000000000000000000101 2r1.0000000000000000000000110 2r1.0000000000000000000000111 2r1.1111111111111111111111001 2r1.1111111111111111111111010 2r1.1111111111111111111111011 2r1.1111111111111111111111101 2r1.1111111111111111111111110 2r1.1111111111111111111111111 "overflow" 2r1.1111111111111111111111110e127 "gradual underflow" 2r0.1111111111111111111111111e-126 2r0.1111111111111111111111110e-126 2r0.1111111111111111111111101e-126 2r0.1111111111111111111111011e-126 2r0.1111111111111111111111010e-126 2r0.1111111111111111111111001e-126 2r0.0000000000000000000000111e-126 2r0.0000000000000000000000110e-126 2r0.0000000000000000000000101e-126 2r0.0000000000000000000000011e-126 2r0.0000000000000000000000010e-126 2r0.0000000000000000000000001e-126 2r0.0000000000000000000000010000000000000000000000000001e-126 ) do: [:e | self assert: ((FloatArray with: e) at: 1) = (Float fromIEEE32Bit: ((FloatArray with: e) basicAt: 1)). self assert: ((FloatArray with: e negated) at: 1) = (Float fromIEEE32Bit: ((FloatArray with: e negated) basicAt: 1))]. "special cases" (Array with: Float infinity with: Float infinity negated with: Float negativeZero) do: [:e | self assert: ((FloatArray with: e) at: 1) = (Float fromIEEE32Bit: ((FloatArray with: e) basicAt: 1))]. "Cannot compare NaN" (Array with: Float nan) do: [:e | self assert: (Float fromIEEE32Bit: ((FloatArray with: e) basicAt: 1)) isNaN].! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:55'! collectionMoreThan1NoDuplicates " return a collection of size > 1 without equal elements" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - sorting' stamp: ''! testSorted | result tmp unsorted | unsorted := self unsortedCollection. result := unsorted sorted. self deny: unsorted == result. tmp := result at: 1. result do: [ :each | self assert: each >= tmp. tmp := each ]! ! !FloatArrayTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAny: self empty). self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAny: self nonEmpty).! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:45'! elementToAdd " return an element of type 'nonEmpy' elements'type' not yet included in nonEmpty" ^ elementNotIn ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testPairsDo | index | index:=1. self nonEmptyMoreThan1Element pairsDo: [:each1 :each2 | self assert:(self nonEmptyMoreThan1Element at:index)=each1. self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. index:=index+2]. self nonEmptyMoreThan1Element size odd ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! !FloatArrayTest methodsFor: 'requirements' stamp: ''! collectionWithCopy "return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals ( with identity equality) but 2 elements only equals with classic equality" | result collection | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. collection add: collection first copy. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !FloatArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testLastNElements "self debug: #testLastNElements" | result | result := self moreThan3Elements last: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] raise: Error! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testCollectFromTo | result | result:=self nonEmptyMoreThan1Element collect: [ :each | each ] from: 1 to: (self nonEmptyMoreThan1Element size - 1). 1 to: result size do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! !FloatArrayTest methodsFor: 'tests - printing' stamp: ''! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream . Transcript show: result asString. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0SortingArrayedTest | tmp sorted | " an unsorted collection of number " self unsortedCollection. self unsortedCollection do: [ :each | each isNumber ]. sorted := true. self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ]. self assert: sorted = false. " a collection of number sorted in an ascending order" self sortedInAscendingOrderCollection. self sortedInAscendingOrderCollection do: [ :each | each isNumber ]. tmp := self sortedInAscendingOrderCollection at: 1. self sortedInAscendingOrderCollection do: [ :each | self assert: each >= tmp. tmp := each ]! ! !FloatArrayTest methodsFor: 'test - equality' stamp: ''! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !FloatArrayTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceAllWithManyOccurence | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | " testing fixture here as this method may be not used for collection that can't contain equals element :" self collectionWith2TimeSubcollection. self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection) = 2. " test :" diff := self replacementCollection size - self oldSubCollection size. result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection. "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection. " verifying that replacementCollection has been put in places of oldSubCollections " firstIndexesOfOccurrence do: [ :each | (firstIndexesOfOccurrence indexOf: each) = 1 ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ifFalse: [ each + diff to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ]. " verifying that the 'between' parts correspond to the initial collection : " 1 to: firstIndexesOfOccurrence size do: [ :i | i = 1 ifTrue: [ 1 to: (firstIndexesOfOccurrence at: i) - 1 do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ] ifFalse: [ resultBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self replacementCollection size. collectionBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self oldSubCollection size. 1 to: (firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | self assert: (result at: resultBetweenPartIndex + i - 1) = (self collectionWith2TimeSubcollection at: collectionBetweenPartIndex + i - 1) ] ] " specific comportement for the begining of the collection :" " between parts till the end : " ]. "final part :" 1 to: self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size) do: [ :i | self assert: (result at: firstIndexesOfOccurrence last + self replacementCollection size - 1 + i) = (self collectionWith2TimeSubcollection at: firstIndexesOfOccurrence last + self oldSubCollection size - 1 + i) ]! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:35'! elementInForElementAccessing " return an element inculded in 'moreThan4Elements'" ^ elementInNonEmpty ! ! !FloatArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 55 ]) = 1. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 55 ]) = collection size! ! !FloatArrayTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceFromToWithInsertion | result indexOfSubcollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . "verify content of 'result' : " "first part of 'result'' : '" 1 to: (indexOfSubcollection -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) ]. " end part :" (indexOfSubcollection + self replacementCollection size) to: (result size) do: [:i| self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. " verify size: " self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). ! ! !FloatArrayTest methodsFor: 'tests - replacing' stamp: ''! testReplaceFromToWith | result collection replacementCollec firstInd secondInd | collection := self nonEmpty . replacementCollec := self replacementCollectionSameSize . firstInd := self firstIndex . secondInd := self secondIndex . result := collection copy. result replaceFrom: firstInd to: secondInd with: replacementCollec . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstInd - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstInd ) to: ( firstInd + replacementCollec size - 1 ) do: [ :i | self assert: ( result at: i ) = ( replacementCollec at: ( i - firstInd +1 ) ) ]. " end part :" ( firstInd + replacementCollec size) to: (result size) do: [:i| self assert: ( result at: i ) = ( collection at: ( secondInd + 1 - ( firstInd + replacementCollec size ) + i ) ) ]. ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:26'! newElement "return an element that will be put in the collection in place of another" ^ elementNotIn ! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringMore "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' " | result resultAnd index allElementsAsString | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . index := 1. (result findBetweenSubStrs: ',' )do: [:each | index = 1 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. index:=index+1 ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size ) ifTrue: [ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] ]. i=(allElementsAsString size) ifTrue:[ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ]. ].! ! !FloatArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res anElement | anElement := self elementToAdd . res := self nonEmpty copyWith: anElement. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: (anElement value)). self nonEmpty do: [ :each | res includes: each ]! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyEmptyMethod | result | result := self collectionWithoutEqualElements copyEmpty . self assert: result isEmpty . self assert: result class= self nonEmpty class.! ! !FloatArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAllNotIncluded "self debug: #testCopyNonEmptyWithoutAllNotIncluded" | res | res := self nonEmpty copyWithoutAll: self collectionNotIncluded. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtAllPutAll | aValueArray | aValueArray := self valueArray . self nonEmpty atAll: self indexArray putAll: aValueArray . 1 to: self indexArray size do: [:i | self assert: (self nonEmpty at:(self indexArray at: i))= (aValueArray at:i) ]! ! !FloatArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOfSubCollectionStartingAt "self debug: #testIndexOfIfAbsent" | subcollection index collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. index := collection indexOfSubCollection: subcollection startingAt: 1. self assert: index = 1. index := collection indexOfSubCollection: subcollection startingAt: 2. self assert: index = 0! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:02'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyAfterWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the first occurence :" result := collection copyAfter: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (collection at:(i + 1 )) = (result at: (i)) ]. "verify size: " self assert: result size = (collection size - 1).! ! !FloatArrayTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTConvertAsSetForMultiplinessTest "a collection with equal elements:" | res | self withEqualElements. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true! ! !FloatArrayTest methodsFor: 'tests - sorting' stamp: ''! testSortedUsingBlock | result tmp | result := self unsortedCollection sorted: [:a :b | a>b].. tmp := result at: 1. result do: [:each | self assert: each<=tmp. tmp:= each. ].! ! !FloatArrayTest methodsFor: 'test - creation' stamp: ''! testWithAll "self debug: #testWithAll" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection . aCol := self collectionClass withAll: collection . collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. self assert: (aCol size = collection size ).! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIndexAccessTest | res collection element | self collectionMoreThan1NoDuplicates. self assert: self collectionMoreThan1NoDuplicates size > 1. res := true. self collectionMoreThan1NoDuplicates detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self elementInForIndexAccessing. self assert: ((collection := self collectionMoreThan1NoDuplicates) includes: (element := self elementInForIndexAccessing)). self elementNotInForIndexAccessing. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := 0. firstCollection with: secondCollection do: [:a :b | ( index := index + 1). self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b.] ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:41'! sortedInAscendingOrderCollection " return a collection sorted in an acsending order" ^ sortedCollection ifNil: [ sortedCollection := ( FloatArray new: 3)at: 1 put: 1.0 ; at: 2 put: 2.0 ; at: 3 put: 3.0 ; yourself ] ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testAllButFirstDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:55'! secondCollection " return a collection that will be the second part of the concatenation" ^ collectionWithEqualElements ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !FloatArrayTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtWrap "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! !FloatArrayTest methodsFor: 'tests - arithmetic' stamp: 'nice 11/23/2007 23:53'! testArithmeticCoercion "This test is related to http://bugs.squeak.org/view.php?id=6782" self should: [3.0 / (FloatArray with: 2.0) = (FloatArray with: 1.5)]. self should: [3.0 * (FloatArray with: 2.0) = (FloatArray with: 6.0)]. self should: [3.0 + (FloatArray with: 2.0) = (FloatArray with: 5.0)]. self should: [3.0 - (FloatArray with: 2.0) = (FloatArray with: 1.0)].! ! !FloatArrayTest methodsFor: 'tests - concatenation' stamp: ''! testConcatenation | result index | result:= self firstCollection,self secondCollection . "first part : " index := 1. self firstCollection do: [:each | self assert: (self firstCollection at: index)=each. index := index+1.]. "second part : " 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:index). index:=index+1]. "size : " self assert: result size = (self firstCollection size + self secondCollection size).! ! !FloatArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !FloatArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !FloatArrayTest methodsFor: 'tests - converting' stamp: ''! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionItself "self debug: #testIntersectionItself" | result | result := (self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements). self assert: result size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (result includes: each) ]. ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testKeysAndValuesDo "| result | result:= OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| result add: (value+i)]. 1 to: result size do: [:i| self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0CopyTest self empty. self assert: self empty size = 0. self nonEmpty. self assert: (self nonEmpty size = 0) not. self collectionWithElementsToRemove. self assert: (self collectionWithElementsToRemove size = 0) not. self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ]. self elementToAdd. self deny: (self nonEmpty includes: self elementToAdd). self collectionNotIncluded. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !FloatArrayTest methodsFor: 'tests - streaming' stamp: ''! testStreamContentsProtocol | result index | result:= self collectionClass << [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:30'! indexInNonEmpty " return an index between bounds of 'nonEmpty' " ^ 3.! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:07'! collectionWithNonIdentitySameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ collectionWithSameAtEndAndBegining ! ! !FloatArrayTest methodsFor: 'tests - begins ends with' stamp: ''! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !FloatArrayTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElements "self debug: #testHasEqualElements" self deny: (self empty hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSequencedConcatenationTest self empty. self assert: self empty isEmpty. self firstCollection. self secondCollection! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:50'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'test - equality' stamp: ''! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !FloatArrayTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0TSequencedStructuralEqualityTest self nonEmpty at: 1 "Ensures #nonEmpty is sequenceable"! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 11:45'! collectionClass ^ FloatArray! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:57'! nonEmpty1Element " return a collection of size 1 including one element" ^ nonEmpty1Element ! ! !FloatArrayTest methodsFor: 'tests - begins ends with' stamp: ''! testsBeginsWith self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty last)). self assert: (self nonEmpty beginsWith:(self nonEmpty )). self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! !FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !FloatArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testDo! ! !FloatArrayTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElementsIsTrueForNonIdenticalButEqualCollections "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" self assert: (self empty hasEqualElements: self empty copy). self assert: (self empty copy hasEqualElements: self empty). self assert: (self empty copy hasEqualElements: self empty copy). self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! !FloatArrayTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceFromToWith | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . "verify content of 'result' : " "first part of 'result' " 1 to: (indexOfSubcollection - 1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) ]. " middle part containing replacementCollection : " (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) ]. " end part :" 1 to: (result size - lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). ]. ! ! !FloatArrayTest methodsFor: 'tests - copying same contents' stamp: ''! testShuffled | result | result := self nonEmpty shuffled . "verify content of 'result: '" result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !FloatArrayTest methodsFor: 'tests - copy' stamp: ''! testCopySameClass "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self empty copy. self assert: copy class == self empty class.! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAfter "self debug: #testAfter" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). self should: [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] raise: Error. self should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] raise: Error! ! !FloatArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButFirstNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. self assert: abf size + 2 = col size! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureAsSetForIdentityMultiplinessTest "a collection (of elements for which copy is not identical ) without equal elements:" | anElement res | self elementsCopyNonIdenticalWithoutEqualElements. anElement := self elementsCopyNonIdenticalWithoutEqualElements anyOne. self deny: anElement copy == anElement. res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:36'! oldSubCollection " return a subCollection included in collectionWith1TimeSubcollection . ex : subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfter | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfter: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePrintTest self nonEmpty! ! !FloatArrayTest methodsFor: 'tests - sorting' stamp: ''! testIsSortedBy self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | ab]). ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := firstCollection size. firstCollection reverseWith: secondCollection do: [:a :b | self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b. ( index := index - 1).] ! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyFromTo | result index collection | collection := self collectionWithoutEqualElements . index :=self indexInForCollectionWithoutDuplicates . result := collection copyFrom: index to: collection size . "verify content of 'result' : " 1 to: result size do: [:i | self assert: (result at:i)=(collection at: (i + index - 1))]. "verify size of 'result' : " self assert: result size = (collection size - index + 1).! ! !FloatArrayTest methodsFor: 'tests - includes' stamp: ''! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !FloatArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:35'! elementNotInForElementAccessing " return an element not included in 'moreThan4Elements' " ^ elementNotIn ! ! !FloatArrayTest methodsFor: 'tests - as set tests' stamp: ''! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !FloatArrayTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiterLast | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ].! ! !FloatArrayTest methodsFor: 'tests - converting' stamp: ''! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyAfterLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the last occurence of element :" result := collection copyAfterLast: (element ). "verifying content: " self assert: result isEmpty. ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:26'! indexInForCollectionWithoutDuplicates " return an index between 'collectionWithoutEqualsElements' bounds" ^ 2.! ! !FloatArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWith "self debug: #testCopyWith" | res anElement | anElement := self elementToAdd. res := self empty copyWith: anElement. self assert: res size = (self empty size + 1). self assert: (res includes: (anElement value))! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureConverAsSortedTest self collectionWithSortableElements. self deny: self collectionWithSortableElements isEmpty! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! howMany: aSubCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp := collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: aSubCollection) ifTrue: [ nTime := nTime + 1. 1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !FloatArrayTest methodsFor: 'tests - printing' stamp: ''! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !FloatArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOfStartingAtIfAbsent "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !FloatArrayTest methodsFor: 'tests - replacing' stamp: ''! testReplaceAllWith | result collection oldElement newElement oldOccurrences | collection := self nonEmpty . result := collection copy. oldElement := self elementInForReplacement . newElement := self newElement . oldOccurrences := (result occurrencesOf: oldElement) + (result occurrencesOf: newElement). result replaceAll: oldElement with: newElement . self assert: oldOccurrences = (result occurrencesOf: newElement)! ! !FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtAll "self debug: #testAtAll" " self flag: #theCollectionshouldbe102030intheFixture. self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." | result | result := self moreThan4Elements atAll: #(2 1 2 ). self assert: (result at: 1) = (self moreThan4Elements at: 2). self assert: (result at: 2) = (self moreThan4Elements at: 1). self assert: (result at: 3) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! !FloatArrayTest methodsFor: 'tests - converting' stamp: ''! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !FloatArrayTest methodsFor: 'tests - copying same contents' stamp: ''! testShallowCopy | result | result := self nonEmpty shallowCopy . "verify content of 'result: '" 1 to: self nonEmpty size do: [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !FloatArrayTest methodsFor: 'tests - streaming' stamp: ''! testStreamContentsSized | result | result:= self collectionClass new: 1 streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection. result:= self collectionClass new: 1000 streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !FloatArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | collection | collection := self collectionMoreThan1NoDuplicates. self assert: (collection indexOf: collection first ifAbsent: [ 33 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing ifAbsent: [ 33 ]) = 33! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyPartOfSequenceableTest self collectionWithoutEqualElements. self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ]. self indexInForCollectionWithoutDuplicates. self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size. self empty. self assert: self empty isEmpty! ! !FloatArrayTest methodsFor: 'test - creation' stamp: ''! testWithWithWith "self debug: #testWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !FloatArrayTest methodsFor: 'tests - converting' stamp: ''! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !FloatArrayTest methodsFor: 'tests - converting' stamp: ''! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyWithOrWithoutSpecificElementsTest self nonEmpty. self deny: self nonEmpty isEmpty. self indexInNonEmpty. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:55'! elementNotInForIndexAccessing " return an element not included in 'collectionMoreThan1NoDuplicates' " ^ elementNotIn ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:55'! firstCollection " return a collection that will be the first part of the concatenation" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !FloatArrayTest methodsFor: 'tests - sorting' stamp: ''! testSortUsingSortBlock | result tmp | result := self unsortedCollection sort: [:a :b | a>b]. tmp := result at: 1. result do: [:each | self assert: each<=tmp. tmp:= each. ].! ! !FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collectionWithoutEqualElements difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res size equals: self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (res includes: each)]. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res equals: separateCol! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCloneTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:04'! withEqualElements ^ collectionWithEqualElements ! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpToLast: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1).! ! !FloatArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOfSubCollectionStartingAtIfAbsent "self debug: #testIndexOfIfAbsent" | index absent subcollection collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ]. self assert: absent = false. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ]. self assert: absent = true! ! !FloatArrayTest methodsFor: 'tests - printing' stamp: ''! testPrintOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. ].! ! !FloatArrayTest methodsFor: 'tests - at put' stamp: ''! testAtPutTwoValues "self debug: #testAtPutTwoValues" self nonEmpty at: self anIndex put: self aValue. self nonEmpty at: self anIndex put: self anotherValue. self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpTo | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpTo: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1). ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:44'! collectionWithElementsToRemove " return a collection of elements included in 'nonEmpty' " ^ nonEmptySubcollection ifNil: [ nonEmptySubcollection := (FloatArray new:2 ) at:1 put: self nonEmpty first ; at:2 put: self nonEmpty last ; yourself ]! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testLast "self debug: #testLast" self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString | delim := ', '. last := 'and'. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ]. ! ! !FloatArrayTest methodsFor: 'tests - copying same contents' stamp: ''! testReversed | result | result := self nonEmpty reversed . "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeTest | anElementIn | self nonEmpty. self deny: self nonEmpty isEmpty. self elementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self anotherElementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self empty. self assert: self empty isEmpty! ! !FloatArrayTest methodsFor: 'tests - including with identity' stamp: ''! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection anElement | collection := self collectionWithCopyNonIdentical. anElement := collection anyOne copy. self deny: (collection identityIncludes: anElement)! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIndexAccessFotMultipliness self collectionWithSameAtEndAndBegining. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [ :i | i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! !FloatArrayTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotIn). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotIn)! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:37'! replacementCollection " return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' " ^ collectionWithSameAtEndAndBegining ! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:28'! collectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals . (others elements of the collection are not equal to those elements)" ^ collectionWithSameAtEndAndBegining ! ! !FloatArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testLastIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 55 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 55 ]) = 1! ! !FloatArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithoutIndex | result index | index := self indexInNonEmpty . result := self nonEmpty copyWithoutIndex: index . "verify content of 'result:'" 1 to: result size do: [:i | i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. "verify size of result : " self assert: result size=(self nonEmpty size -1).! ! !FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtWrapPut "self debug: #testAtWrapPut" | index | index := self indexArray anyOne. self nonEmpty atWrap: 0 put: self aValue. self assert: (self nonEmpty at:(self nonEmpty size))=self aValue. self nonEmpty atWrap: (self nonEmpty size+1) put: self aValue. self assert: (self nonEmpty at:(1))=self aValue. self nonEmpty atWrap: (index ) put: self aValue. self assert: (self nonEmpty at: index ) = self aValue. self nonEmpty atWrap: (self nonEmpty size+index ) put: self aValue . self assert: (self nonEmpty at:(index ))=self aValue .! ! !FloatArrayTest methodsFor: 'testing' stamp: 'nice 5/30/2006 03:17'! testFloatArrayPluginPrimitiveAtPut "if FloatArrayPlugin primitive are not here, this test is dumb. Otherwise, it will compare primitive and #asIEEE32BitWord" #( "regular numbers no truncation or rounding" 2r0.0 2r1.0 2r1.1 2r1.00000000000000000000001 2r1.0e-10 2r1.1e-10 2r1.00000000000000000000001e-10 2r1.0e10 2r1.1e10 2r1.00000000000000000000001e10 "smallest float32 before gradual underflow" 2r1.0e-126 "biggest float32" 2r1.11111111111111111111111e127 "overflow" 2r1.11111111111111111111111e128 "gradual underflow" 2r0.11111111111111111111111e-126 2r0.00000000000000000000001e-126 "with rounding mode : tests on 25 bits" 2r1.0000000000000000000000001 2r1.0000000000000000000000010 2r1.0000000000000000000000011 2r1.0000000000000000000000100 2r1.0000000000000000000000101 2r1.0000000000000000000000110 2r1.0000000000000000000000111 2r1.1111111111111111111111001 2r1.1111111111111111111111010 2r1.1111111111111111111111011 2r1.1111111111111111111111101 2r1.1111111111111111111111110 2r1.1111111111111111111111111 "overflow" 2r1.1111111111111111111111110e127 "gradual underflow" 2r0.1111111111111111111111111e-126 2r0.1111111111111111111111110e-126 2r0.1111111111111111111111101e-126 2r0.1111111111111111111111011e-126 2r0.1111111111111111111111010e-126 2r0.1111111111111111111111001e-126 2r0.0000000000000000000000111e-126 2r0.0000000000000000000000110e-126 2r0.0000000000000000000000101e-126 2r0.0000000000000000000000011e-126 2r0.0000000000000000000000010e-126 2r0.0000000000000000000000001e-126 2r0.0000000000000000000000010000000000000000000000000001e-126 ) do: [:e | self assert: ((FloatArray with: e) basicAt: 1) = e asIEEE32BitWord. self assert: ((FloatArray with: e negated) basicAt: 1) = e negated asIEEE32BitWord]. "special cases" (Array with: Float infinity with: Float infinity negated with: Float negativeZero with: Float nan) do: [:e | self assert: ((FloatArray with: e) basicAt: 1) = e asIEEE32BitWord]. ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseDo | result | result:= OrderedCollection new. self nonEmpty reverseDo: [: each | result add: each]. 1 to: result size do: [:i| self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! !FloatArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyEquals "self debug: #testCopySameClass" "A copy should be equivalent to the things it's a copy of" | copy | copy := self nonEmpty copy. self assert: copy = self nonEmpty.! ! !FloatArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIndexOfDuplicate "self debug: #testIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf: should return the position of the first occurrence :'" self assert: (collection indexOf: element) = 1! ! !FloatArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtPin "self debug: #testAtPin" self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! !FloatArrayTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:04'! elementsCopyNonIdenticalWithoutEqualElements " return a collection that does niot incllude equal elements ( classic equality ) all elements included are elements for which copy is not identical to the element " ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtLastIfAbsent "self debug: #testAtLastIfAbsent" self assert: (self moreThan4Elements atLast: 1 ifAbsent: [ nil ]) = self moreThan4Elements last. self assert: (self moreThan4Elements atLast: self moreThan4Elements size + 1 ifAbsent: [ 222 ]) = 222! ! !FloatArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButLastNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButLast: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i) ]. self assert: abf size + 2 = col size! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfterLast: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !FloatArrayTest methodsFor: 'test - equality' stamp: ''! testEqualSignIsTrueForEmptyButNonIdenticalCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). ! ! !FloatArrayTest methodsFor: 'tests - converting' stamp: ''! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAfterIfAbsent "self debug: #testAfterIfAbsent" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1) ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ifAbsent: [ 33 ]) = 33. self assert: (self moreThan4Elements after: self elementNotInForElementAccessing ifAbsent: [ 33 ]) = 33! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !FloatArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testForceToPaddingWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). "verify content of 'result' : " 1 to: self nonEmpty size do: [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. (result size - 1) to: result size do: [:i | self assert: ( result at:i ) = ( element ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:45'! nonEmpty ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindLast | element result | element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. self assert: result=self nonEmptyMoreThan1Element size. ! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCreationWithTest self collectionMoreThan5Elements. self assert: self collectionMoreThan5Elements size >= 5! ! !FloatArrayTest methodsFor: 'tests - at put' stamp: ''! testAtPut "self debug: #testAtPut" self nonEmpty at: self anIndex put: self aValue. self assert: (self nonEmpty at: self anIndex) = self aValue. ! ! !FloatArrayTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyNonEmpty "self debug: #testCopyNonEmpty" | copy | copy := self nonEmpty copy. self deny: copy isEmpty. self assert: copy size = self nonEmpty size. self nonEmpty do: [:each | copy includes: each]! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !FloatArrayTest methodsFor: 'test - creation' stamp: ''! testWithWith "self debug: #testWithWith" | aCol collection element1 element2 | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . element1 := collection at: 1. element2 := collection at:2. aCol := self collectionClass with: element1 with: element2 . self assert: (aCol occurrencesOf: element1 ) = ( collection occurrencesOf: element1). self assert: (aCol occurrencesOf: element2 ) = ( collection occurrencesOf: element2). ! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testFirstSecondThird "self debug: #testFirstSecondThird" self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! !FloatArrayTest methodsFor: 'requirements' stamp: ''! collectionWithIdentical "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" | result collection anElement | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. anElement := collection first. collection add: anElement. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !FloatArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testForceToPaddingStartWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). "verify content of 'result' : " 1 to: 2 do: [:i | self assert: ( element ) = ( result at:(i) ) ]. 3 to: result size do: [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:55'! sizeCollection "Answers a collection not empty" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithFirst | index element result | index:= self indexInNonEmpty . element:= self nonEmpty at: index. result := self nonEmpty copyWithFirst: element. self assert: result size = (self nonEmpty size + 1). self assert: result first = element . 2 to: result size do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:22'! aValue " return a value to put into nonEmpty" ^ elementNotIn ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:45'! empty ^ empty ! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtLast "self debug: #testAtLast" | index | self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. "tmp:=1. self do: [:each | each =self elementInForIndexAccessing ifTrue:[index:=tmp]. tmp:=tmp+1]." index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:23'! indexArray " return a Collection including indexes between bounds of 'nonEmpty' " ^ { 1. 4. 3.}! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:56'! collection ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'tests - sorting' stamp: ''! testSort | result tmp | result := self unsortedCollection sort. tmp := result at: 1. result do: [:each | self assert: each>=tmp. tmp:= each. ].! ! !FloatArrayTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtLastPut | result index | index := self indexArray anyOne. result := self nonEmpty atLast: index put: self aValue. self assert: (self nonEmpty at: (self nonEmpty size +1 - index)) = self aValue .! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:55'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne! ! !FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !FloatArrayTest methodsFor: 'tests - sorting' stamp: ''! testIsSorted self assert: self sortedInAscendingOrderCollection isSorted. self deny: self unsortedCollection isSorted! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !FloatArrayTest methodsFor: 'tests - converting' stamp: ''! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !FloatArrayTest methodsFor: 'tests - equality' stamp: ''! testEqualSignForSequenceableCollections "self debug: #testEqualSign" self deny: (self nonEmpty = self nonEmpty asSet). self deny: (self nonEmpty reversed = self nonEmpty). self deny: (self nonEmpty = self nonEmpty reversed).! ! !FloatArrayTest methodsFor: 'tests - streaming' stamp: ''! testStreamContents | result index | result:= self collectionClass streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureBeginsEndsWithTest self nonEmpty. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size > 1. self empty. self assert: self empty isEmpty! ! !FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAtIfAbsent "self debug: #testAt" | absent | absent := false. self moreThan4Elements at: self moreThan4Elements size + 1 ifAbsent: [ absent := true ]. self assert: absent = true. absent := false. self moreThan4Elements at: self moreThan4Elements size ifAbsent: [ absent := true ]. self assert: absent = false! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:41'! collectionNotIncluded " return a collection for wich each element is not included in 'nonEmpty' " ^ collectionNotIncluded ifNil: [ collectionNotIncluded := (FloatArray new: 2) at:1 put: elementNotIn ; at: 2 put: elementNotIn ; yourself ].! ! !FloatArrayTest methodsFor: 'test - equality' stamp: ''! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSubcollectionAccessTest self moreThan3Elements. self assert: self moreThan3Elements size > 2! ! !FloatArrayTest methodsFor: 'tests - index access' stamp: ''! testIndexOf "self debug: #testIndexOf" | tmp index collection | collection := self collectionMoreThan1NoDuplicates. tmp := collection size. collection reverseDo: [ :each | each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. tmp := tmp - 1 ]. self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:56'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotIn ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:02'! elementInForIndexAccessing " return an element included in 'collectionMoreThan1NoDuplicates' " ^ elementInNonEmpty .! ! !FloatArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testLastIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element ifAbsent: [ 55 ]) = collection size! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSequencedElementAccessTest self moreThan4Elements. self assert: self moreThan4Elements size >= 4. self subCollectionNotIn. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self elementNotInForElementAccessing. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self elementInForElementAccessing. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:24'! anotherValue " return a value ( not eual to 'aValue' ) to put into nonEmpty " ^ elementInNonEmpty ! ! !FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" | difference | self assert: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements) isEmpty. self assert: (self empty difference: self collectionWithoutEqualElements) isEmpty. difference := (self collectionWithoutEqualElements difference: self empty). self assert: difference size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each)]. ! ! !FloatArrayTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButFirst "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst. self deny: abf first = col first. self assert: abf size + 1 = col size! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testAllButLastDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyPartOfForMultipliness self collectionWithSameAtEndAndBegining. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [ :i | i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testPairsCollect | index result | index:=0. result:=self nonEmptyMoreThan1Element pairsCollect: [:each1 :each2 | self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). ]. result do: [:each | self assert: each = true]. ! ! !FloatArrayTest methodsFor: 'tests - copying same contents' stamp: ''! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:36'! subCollectionNotIn " return a collection for which at least one element is not included in 'moreThan4Elements' " ^ collectionNotIncluded ifNil: [ collectionNotIncluded := (FloatArray new: 2) at:1 put: elementNotIn ; at: 2 put: elementNotIn ; yourself ].! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithIndexDo "| result | result:=Array new: self nonEmptyMoreThan1Element size. self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element withIndexDo: [:value :i | indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !FloatArrayTest methodsFor: 'tests - copying same contents' stamp: ''! testReverse | result | result := self nonEmpty reversed. "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at: i) = (self nonEmpty at: (self nonEmpty size - i + 1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !FloatArrayTest methodsFor: 'test - creation' stamp: ''! testWithWithWithWith "self debug: #testWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testBeforeIfAbsent "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 1) ifAbsent: [ 99 ]) = 99. self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2) ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! !FloatArrayTest methodsFor: 'tests - as identity set' stamp: ''! testAsIdentitySetWithoutIdentityEqualsElements | result collection | collection := self collectionWithCopy. result := collection asIdentitySet. " no elements should have been removed as no elements are equels with Identity equality" self assert: result size = collection size. collection do: [ :each | (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. self assert: result class = IdentitySet! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePutOneOrMoreElementsTest self aValue. self indexArray. self indexArray do: [ :each| self assert: each class = SmallInteger. self assert: (each>=1 & each<= self nonEmpty size). ]. self assert: self indexArray size = self valueArray size. self empty. self assert: self empty isEmpty . self nonEmpty. self deny: self nonEmpty isEmpty.! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !FloatArrayTest methodsFor: 'tests - set arithmetic' stamp: ''! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringOne "self assert: self oneItemCol asCommaString = '1'. self assert: self oneItemCol asCommaStringAnd = '1'." self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFromToDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 1 to: (self nonEmptyMoreThan1Element size -1) do: [:i| self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !FloatArrayTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopySameContentsTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:34'! replacementCollectionSameSize " return a collection of size (secondIndex - firstIndex + 1)" ^replacementCollectionSameSize ifNil: [ replacementCollectionSameSize := FloatArray new: (self secondIndex - self firstIndex + 1). 1 to: replacementCollectionSameSize size do: [ :i | replacementCollectionSameSize at:i put: elementInNonEmpty ]. replacementCollectionSameSize. ].! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:50'! elementNotIn "return an element not included in 'nonEmpty' " ^ elementNotIn ! ! !FloatArrayTest methodsFor: 'running' stamp: 'delaunay 5/14/2009 16:40'! setUp empty := FloatArray new. elementInNonEmpty := 7.0. nonEmpty5ElementsNoDuplicate := (FloatArray new:5) at: 1 put: 1.5 ; at: 2 put: 2.5 ; at: 3 put: elementInNonEmpty ; at: 4 put: 4.5 ; at: 5 put: 5.5 ; yourself. elementNotIn := 999.0. elementTwiceIn := 2.3 . collectionWithEqualElements := (FloatArray new: 3) at: 1 put: 2.0 ; at: 2 put: 2.0 ; at: 3 put: 3.5 ; yourself. nonEmpty1Element := ( FloatArray new: 1) at:1 put: 1.2 ; yourself. collectionWithSameAtEndAndBegining := (FloatArray new: 3) at: 1 put: 2.0 ; at: 2 put: 1.0 ; at: 3 put: 2.0 copy ; yourself.! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testAt "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:44'! moreThan3Elements " return a collection including atLeast 3 elements" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'requirements' stamp: ''! elementInForReplacement " return an element included in 'nonEmpty' " ^ self nonEmpty anyOne.! ! !FloatArrayTest methodsFor: 'tests - element accessing' stamp: ''! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:11'! nonEmptyMoreThan1Element " return a collection that doesn't includes equal elements' and doesn't include nil elements'" ^nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'test - creation' stamp: ''! testWithWithWithWithWith "self debug: #testWithWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !FloatArrayTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent: should return the position of the first occurrence :'" self assert: (collection indexOf: element ifAbsent: [ 55 ]) = 1! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterOne | delim oneItemStream result | "delim := ', '. oneItemStream := '' readWrite. self oneItemCol asStringOn: oneItemStream delimiter: delim. self assert: oneItemStream contents = '1'." delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !FloatArrayTest methodsFor: 'tests - at put' stamp: ''! testAtPutOutOfBounds "self debug: #testAtPutOutOfBounds" self should: [self empty at: self anIndex put: self aValue] raise: Error ! ! !FloatArrayTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element ifAbsent: [ 99 ]) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 99 ]) = 99! ! !FloatArrayTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection last. self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 99 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 99 ]) = 99. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing startingAt: collection size ifAbsent: [ 99 ]) = 99! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !FloatArrayTest methodsFor: 'tests - copying with replacement' stamp: ''! firstIndexesOf: aSubCollection in: collection " return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " | tmp result currentIndex | tmp:= collection. result:= OrderedCollection new. currentIndex := 1. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: aSubCollection) ifTrue: [ result add: currentIndex. 1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !FloatPrintPolicy commentStamp: ''! I am FloatPrintPolicy. I am a DynamicVariable. I control whether Float instances are printed exactly or inexactly. The inexact printing is much faster, but can be less accurate. The default policy is ExactFloatPrintPolicy. FloatPrintPolicy value: InexactFloatPrintPolicy new during: [ Float pi printString ]! !FloatPrintPolicy methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 2/8/2013 11:20'! initialize default := ExactFloatPrintPolicy new! ! !FloatPrintPolicy methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 2/8/2013 11:20'! default ^ default! ! !FloatPrintPolicy class methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 2/8/2013 11:52'! absPrint: float on: stream base: base "I delegate Float printing to the current dynamic value of myself" self value absPrint: float on: stream base: base! ! !FloatTest commentStamp: 'fbs 3/8/2004 22:13'! I provide a test suite for Float values. Examine my tests to see how Floats should behave, and see how to use them.! !FloatTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/13/2011 09:06'! testRaisedTo " FloatTest new testRaisedTo " self should: [ -1.23 raisedTo: 1/4 ] raise: ArithmeticError! ! !FloatTest methodsFor: 'tests - printing' stamp: 'MarcusDenker 4/19/2013 15:01'! testPrintPaddedWithTo "The problem was caused by treating the format specifier as a number rather than as a string, such the the number may be a Float subject to floating point rounding errors. The solution to treat the format specifier as a string, and extract the integer fields before and after the decimal point in the string." self assert: (1.0 printPaddedWith: $0 to: 2.2) = '01.00'. self assert: (1.0 printPaddedWith: $X to: 2.2) = 'X1.0X'. self assert: (1.0 printPaddedWith: $0 to: 2) = '01.0'. self assert: (12345.6789 printPaddedWith: $0 to: 2) = '12345.6789'. self assert: (12345.6789 printPaddedWith: $0 to: 2.2) = '12345.6789'. self assert: (12.34 printPaddedWith: $0 to: 2.2) = '12.34'. self assert: (12345.6789 printPaddedWith: $0 to: 2.2) = '12345.6789'. self assert: (123.456 printPaddedWith: $X to: 4.4) = 'X123.456X'. self assert: (1.0 printPaddedWith: $0 to: 2.1) = '01.0'. self assert: (1.0 printPaddedWith: $0 to: 2.2) = '01.00'. self assert: (1.0 printPaddedWith: $0 to: 2.3) = '01.000'. "previously failed due to float usage" self assert: (1.0 printPaddedWith: $0 to: 2.4) = '01.0000'. "previously failed due to float usage" self assert: (1.0 printPaddedWith: $0 to: 2.5) = '01.00000' ! ! !FloatTest methodsFor: 'tests - mathematical functions' stamp: 'nice 10/31/2010 21:49'! testDegreeCosForExceptionalValues self assert: Float nan degreeCos isNaN. self assert: Float infinity degreeCos isNaN. self assert: Float infinity negated degreeCos isNaN.! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'StephaneDucasse 11/1/2010 08:09'! testFloatPrinting "This test shows that floats are printed exactly. The idea is too make sure that users understand that " self assert: (0.1+0.2) printString = '0.30000000000000004'. self assert: (-0.1-0.2) printString = '-0.30000000000000004'. self assert: 240 degreesToRadians cos = -0.5000000000000004. self assert: 240 degreesToRadians cos abs = 0.5000000000000004! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'nice 6/3/2011 21:29'! testFloor self assert: 1.0 floor = 1. self assert: 1.1 floor = 1. self assert: -2.0 floor = -2. self assert: -2.1 floor = -3.! ! !FloatTest methodsFor: 'tests - mathematical functions' stamp: 'nice 5/16/2012 21:12'! testFloorLog2 "Float internal representation of Float being in base 2, we expect (aFloat floorLog: 2) to be exact." | aBitLess aBitMore | aBitMore := 1 + Float epsilon. aBitLess := 1 - Float epsilon. Float emin + 1 to: Float emax - 1 do: [:exp | | exactPowerOfTwo | exactPowerOfTwo := 1.0 timesTwoPower: exp. self assert: (exactPowerOfTwo floorLog: 2) equals: exp. self assert: (exactPowerOfTwo * aBitMore floorLog: 2) equals: exp. self assert: (exactPowerOfTwo * aBitLess floorLog: 2) equals: exp - 1].! ! !FloatTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testHash self assert: 2 = 2.0 ==> (2 hash = 2.0 hash). self assert: 1 / 2 = 0.5 ==> ((1 / 2) hash = 0.5 hash). Float nan hash. Float infinity hash! ! !FloatTest methodsFor: 'tests - infinity behavior' stamp: 'nice 10/17/2007 23:54'! testInfinityCloseTo "This is a test for bug http://bugs.squeak.org/view.php?id=6729:" "FloatTest new testInfinityCloseTo" self deny: (Float infinity closeTo: Float infinity negated). self deny: (Float infinity negated closeTo: Float infinity).! ! !FloatTest methodsFor: 'tests - compare' stamp: 'StephaneDucasse 2/13/2010 11:18'! testSetOfFloat "Classical disagreement between hash and = did lead to a bug. This is a non regression test from http://bugs.squeak.org/view.php?id=3360" "self debug: #testSetOfFloat" | size3 size4 | size3 := (Set new: 3) add: 3; add: 3.0; size. size4 := (Set new: 4) add: 3; add: 3.0; size. self assert: size3 = size4 description: 'The size of a Set should not depend on its capacity.'! ! !FloatTest methodsFor: 'tests - zero behavior' stamp: 'sd 6/5/2005 08:33'! testZero1 "FloatTest new testZero1" self assert: Float negativeZero = 0 asFloat. self assert: (Float negativeZero at: 1) ~= (0 asFloat at: 1). "The negative zero has a bit representation that is different from the bit representation of the positive zero. Nevertheless, both values are defined to be equal." ! ! !FloatTest methodsFor: 'tests - compare' stamp: 'nice 7/10/2009 22:27'! testComparisonWhenPrimitiveFails "This is related to http://bugs.squeak.org/view.php?id=7361" self deny: 0.5 < (1/4). self deny: 0.5 < (1/2). self assert: 0.5 < (3/4). self deny: 0.5 <= (1/4). self assert: 0.5 <= (1/2). self assert: 0.5 <= (3/4). self assert: 0.5 > (1/4). self deny: 0.5 > (1/2). self deny: 0.5 > (3/4). self assert: 0.5 >= (1/4). self assert: 0.5 >= (1/2). self deny: 0.5 >= (3/4). self deny: 0.5 = (1/4). self assert: 0.5 = (1/2). self deny: 0.5 = (3/4). self assert: 0.5 ~= (1/4). self deny: 0.5 ~= (1/2). self assert: 0.5 ~= (3/4).! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'nice 6/3/2011 21:28'! testCeiling self assert: 1.0 ceiling = 1. self assert: 1.1 ceiling = 2. self assert: -2.0 ceiling = -2. self assert: -2.1 ceiling = -2.! ! !FloatTest methodsFor: 'tests - zero behavior' stamp: 'nice 3/23/2008 16:00'! testZeroSignificandAsInteger "This is about http://bugs.squeak.org/view.php?id=6990" self assert: 0.0 significandAsInteger = 0! ! !FloatTest methodsFor: 'tests - IEEE 754' stamp: 'nice 5/30/2006 02:34'! test32bitGradualUnderflow "method asIEEE32BitWord did not respect IEEE gradual underflow" | conv expected exponentPart | "IEEE 32 bits Float have 1 bit sign/8 bit exponent/23 bits of mantissa after leading 1 2r1.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2reeeeeeee-127) * sign except when 2reeeeeeee isZero, which is a gradual underflow: 2r0.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2r00000000-126) * sign and when 2reeeeeeee = 255, which is infinity if mantissa all zero or nan otherwise" "case 1: This example is the first gradual underflow case" conv := 2r0.11111111111111111111111e-126 asIEEE32BitWord. "expected float encoded as sign/exponent/mantissa (whithout leading 1 or 0)" exponentPart := 0. expected := exponentPart bitOr: 2r11111111111111111111111. self assert: expected = conv. "case 2: smallest number" conv := 2r0.00000000000000000000001e-126 asIEEE32BitWord. expected := exponentPart bitOr: 2r1. self assert: expected = conv. "case 3: round to nearest even also in underflow cases... here round to upper" conv := 2r0.000000000000000000000011e-126 asIEEE32BitWord. expected := exponentPart bitOr: 2r10. self assert: expected = conv. "case 4: round to nearest even also in underflow cases... here round to lower" conv := 2r0.000000000000000000000101e-126 asIEEE32BitWord. expected := exponentPart bitOr: 2r10. self assert: expected = conv. "case 5: round to nearest even also in underflow cases... here round to upper" conv := 2r0.0000000000000000000001011e-126 asIEEE32BitWord. expected := exponentPart bitOr: 2r11. self assert: expected = conv. ! ! !FloatTest methodsFor: 'tests - mathematical functions' stamp: 'nice 7/14/2011 13:30'! testCopySignTo "Set up" | negatives negz positives strictNegatives strictPositives zero | strictPositives := {2. 2.5. Float infinity}. strictNegatives := {-3. -3.25. Float infinity negated}. zero := 0.0. negz := Float negativeZero. positives := strictPositives copyWith: zero. negatives := strictNegatives copyWith: negz. "Test the copy sign functions" positives do: [:aPositiveSign | positives do: [:aPositive | self assert: (aPositiveSign copySignTo: aPositive) = aPositive]. negatives do: [:aNegative | self assert: (aPositiveSign copySignTo: aNegative) = aNegative negated]. (aPositiveSign copySignTo: zero) sign = 0. (aPositiveSign copySignTo: negz) sign = 0]. negatives do: [:aNegativeSign | positives do: [:aPositive | self assert: (aNegativeSign copySignTo: aPositive) = aPositive negated]. negatives do: [:aNegative | self assert: (aNegativeSign copySignTo: aNegative) = aNegative]. (aNegativeSign copySignTo: zero) sign = -1. (aNegativeSign copySignTo: negz) sign = -1].! ! !FloatTest methodsFor: 'tests - NaN behavior' stamp: 'sd 6/5/2005 08:31'! testNaN1 "FloatTest new testNaN1" self assert: Float nan == Float nan. self deny: Float nan = Float nan. "a NaN is not equal to itself." ! ! !FloatTest methodsFor: 'tests - zero behavior' stamp: 'nice 8/21/2010 22:30'! testNegativeZeroSign self assert: Float negativeZero sign = -1! ! !FloatTest methodsFor: 'tests - printing' stamp: 'SvenVanCaekenberghe 2/8/2013 15:54'! testFloatPrintPolicy "It is hard to test printing Floats reliably, but this at least covers the code path" | pi | pi := FloatPrintPolicy value: InexactFloatPrintPolicy new during: [ Float pi printString ]. self assert: (pi beginsWith: '3.14159'). pi := FloatPrintPolicy value: ExactFloatPrintPolicy new during: [ Float pi printString ]. self assert: (pi beginsWith: '3.14159').! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'nice 4/26/2006 05:21'! testFloatTruncated "(10 raisedTo: 16) asFloat has an exact representation (no round off error). It should convert back to integer without loosing bits. This is a no regression test on http://bugs.impara.de/view.php?id=3504" | x y int r | int := 10 raisedTo: 16. x := int asFloat. y := (5 raisedTo: 16) asFloat timesTwoPower: 16. self assert: x = y. self assert: x asInteger = int. "this one should be true for any float" self assert: x asInteger = x asTrueFraction asInteger. "a random test" r := Random new. 10000 timesRepeat: [ x := r next * 1.9999e16 + 1.0e12 . self assert: x truncated = x asTrueFraction truncated]! ! !FloatTest methodsFor: 'tests - NaN behavior' stamp: 'StephaneDucasse 5/28/2011 13:45'! testNaN2 "Two NaN values are always considered to be different. On an little-endian machine (32 bit Intel), Float nan is 16rFFF80000 16r00000000. On a big-endian machine (PowerPC), Float nan is 16r7FF80000 16r00000000. Changing the bit pattern of the first word of a NaN produces another value that is still considered equal to NaN. This test should work on both little endian and big endian machines. However, it is not guaranteed to work on future 64 bit versions of Squeak, for which Float may have different internal representations." "FloatTest new testNaN2" | nan1 nan2 | nan1 := Float nan copy. nan2 := Float nan copy. "test two instances of NaN with the same bit pattern" self deny: nan1 = nan2. self deny: nan1 == nan2. self deny: nan1 = nan1. self assert: nan1 == nan1. "change the bit pattern of nan1" self assert: nan1 size = 2. self assert: (nan1 at: 2) = 0. nan1 at: 1 put: (nan1 at: 1) + 999. self assert: nan1 isNaN. self assert: nan2 isNaN. self deny: (nan1 at: 1) = (nan2 at: 1). "test two instances of NaN with different bit patterns" self deny: nan1 = nan2. self deny: nan1 == nan2. self deny: nan1 = nan1. self assert: nan1 == nan1 ! ! !FloatTest methodsFor: 'tests - mathematical functions' stamp: 'Janniklaval 10/23/2010 13:39'! testSign "Set up" | negatives negz positives strictNegatives strictPositives zero | strictPositives := {2. 2.5. Float infinity}. strictNegatives := {-3. -3.25. Float infinity negated}. zero := 0.0. negz := Float negativeZero. positives := strictPositives copyWith: zero. negatives := strictNegatives copyWith: negz. "The sign of non zeros" strictPositives do: [:aPositive | self assert: aPositive sign = 1]. strictNegatives do: [:aNegative | self assert: aNegative sign = -1]. "The sign of zeros" self assert: zero sign = 0. self assert: negz sign = -1. "remark though that negz >= 0.0, and is thus considered positive... Weird" "Test the copy sign functions" positives do: [:aPositiveSign | positives do: [:aPositive | self assert: (aPositive sign: aPositiveSign) = aPositive]. negatives do: [:aNegative | self assert: (aNegative sign: aPositiveSign) = aNegative negated]. (zero sign: aPositiveSign) sign = 0. (negz sign: aPositiveSign) sign = 0]. negatives do: [:aNegativeSign | positives do: [:aPositive | self assert: (aPositive sign: aNegativeSign) = aPositive negated]. negatives do: [:aNegative | self assert: (aNegative sign: aNegativeSign) = aNegative]. (zero sign: aNegativeSign) sign = -1. (negz sign: aNegativeSign) sign = -1].! ! !FloatTest methodsFor: 'tests - mathematical functions' stamp: 'CamilloBruni 8/31/2013 20:23'! testDegreeSin 45.0 degreeSin. "Following tests use approximate equality, because sine are generally evaluated using inexact Floating point arithmetic" self assert: (45.0 degreeSin squared - 0.5) abs <= Float epsilon. self assert: (30.0 degreeSin - 0.5) abs <= Float epsilon. self assert: (-30.0 degreeSin + 0.5) abs <= Float epsilon. -360.0 to: 360.0 do: [ :i | self assert: (i degreeSin closeTo: i degreesToRadians sin) ]. "Following tests use strict equality which is a requested property of degreeSin" -10.0 to: 10.0 do: [ :k | self assert: (k * 360 + 90) degreeSin - 1 = 0. self assert: (k * 360 - 90) degreeSin + 1 = 0. self assert: (k * 360 + 180) degreeSin = 0. self assert: (k * 360) degreeSin = 0 ]! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'nice 6/3/2011 21:37'! testRounded self assert: 0.9 rounded = 1. self assert: 1.0 rounded = 1. self assert: 1.1 rounded = 1. self assert: -1.9 rounded = -2. self assert: -2.0 rounded = -2. self assert: -2.1 rounded = -2. "In case of tie, round to upper magnitude" self assert: 1.5 rounded = 2. self assert: -1.5 rounded = -2.! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'nice 5/6/2006 22:13'! testIntegerAsFloat "assert IEEE 754 round to nearest even mode is honoured" self deny: 16r1FFFFFFFFFFFF0801 asFloat = 16r1FFFFFFFFFFFF0800 asFloat. "this test is on 65 bits" self deny: 16r1FFFFFFFFFFFF0802 asFloat = 16r1FFFFFFFFFFFF0800 asFloat. "this test is on 64 bits" self assert: 16r1FFFFFFFFFFF1F800 asFloat = 16r1FFFFFFFFFFF20000 asFloat. "nearest even is upper" self assert: 16r1FFFFFFFFFFFF0800 asFloat = 16r1FFFFFFFFFFFF0000 asFloat. "nearest even is lower" ! ! !FloatTest methodsFor: 'tests - rounding' stamp: 'GuillermoPolito 6/22/2012 14:44'! testRounding " self debug: #testRounding " self assert: (10.1234 round: 2) = 10.12. self assert: (10.1234 round: 0) = 10! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'nice 6/3/2011 21:34'! testTruncated self assert: 1.0 truncated = 1. self assert: 1.1 truncated = 1. self assert: -2.0 truncated = -2. self assert: -2.1 truncated = -2.! ! !FloatTest methodsFor: 'tests - infinity behavior' stamp: 'nice 7/14/2009 09:32'! testHugeIntegerCloseTo "This is a test for bug http://bugs.squeak.org/view.php?id=7368" "FloatTest new testHugeIntegerCloseTo" self deny: (1.0 closeTo: 200 factorial). self deny: (200 factorial closeTo: 1.0). self assert: (Float infinity closeTo: 200 factorial) = (200 factorial closeTo: Float infinity).! ! !FloatTest methodsFor: 'tests' stamp: 'nice 10/4/2009 23:13'! testCopy "Elementary tests" self assert: 2.0 copy = 2.0. self assert: -0.5 copy = -0.5. "Are exceptional Floats preserved by the copy ?" self assert: Float nan copy isNaN. self assert: Float infinity copy = Float infinity. self assert: Float infinity negated copy = Float infinity negated. "Is the sign of zero preserved by the copy ?" self assert: 0.0 copy hex = 0.0 hex. self assert: Float negativeZero copy hex = Float negativeZero hex.! ! !FloatTest methodsFor: 'tests - NaN behavior' stamp: 'nice 10/11/2007 00:09'! testNaNCompare "IEEE 754 states that NaN cannot be ordered. As a consequence, every arithmetic comparison involving a NaN SHOULD return false. Except the is different test (~=). This test does verify this rule" | compareSelectors theNaN anotherNaN comparand brokenMethods warningMessage | compareSelectors := #(#< #<= #> #>= #=). theNaN := Float nan. anotherNaN := Float infinity - Float infinity. comparand := {1. 2.3. Float infinity. 2/3. 1.25s2. 2 raisedTo: 50}. comparand := comparand , (comparand collect: [:e | e negated]). comparand := comparand , {theNaN. anotherNaN}. "do a first pass to collect all broken methods" brokenMethods := Set new. comparand do: [:comp | compareSelectors do: [:op | (theNaN perform: op with: comp) ifTrue: [brokenMethods add: (theNaN class lookupSelector: op)]. (comp perform: op with: theNaN) ifTrue: [brokenMethods add: (comp class lookupSelector: op)]]. (theNaN ~= comp) ifFalse: [brokenMethods add: (theNaN class lookupSelector: #~=)]. (comp ~= theNaN) ifFalse: [brokenMethods add: (comp class lookupSelector: #~=)]]. "build a warning message to tell about all broken methods at once" warningMessage := String streamContents: [:s | s nextPutAll: 'According to IEEE 754 comparing with a NaN should always return false, except ~= that should return true.'; cr. s nextPutAll: 'All these methods failed to do so. They are either broken or call a broken one'. brokenMethods do: [:e | s cr; print: e methodClass; nextPutAll: '>>'; print: e selector]]. "Redo the tests so as to eventually open a debugger on one of the failures" brokenMethods := Set new. comparand do: [:comp2 | compareSelectors do: [:op2 | self deny: (theNaN perform: op2 with: comp2) description: warningMessage. self deny: (comp2 perform: op2 with: theNaN) description: warningMessage]. self assert: (theNaN ~= comp2) description: warningMessage. self assert: (comp2 ~= theNaN) description: warningMessage].! ! !FloatTest methodsFor: 'tests - IEEE 754' stamp: 'nice 5/30/2006 00:07'! test32bitRoundingMode "method asIEEE32BitWord did not respect IEEE default rounding mode" | conv expected exponentPart | "IEEE 32 bits Float have 1 bit sign/8 bit exponent/23 bits of mantissa after leading 1 2r1.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2reeeeeeee-127) * sign except when 2reeeeeeee isZero, which is a gradual underflow: 2r0.mmmmmmmmmmmmmmmmmmmmmmm * (2 raisedTo: 2r00000000-127) * sign and when 2reeeeeeee = 255, which is infinity if mantissa all zero or nan otherwise" "This example has two extra bits in mantissa for testing rounding mode case 1: should obviously round to upper" conv := 2r1.0000000000000000000000111e25 asIEEE32BitWord. "expected float encoded as sign/exponent/mantissa (whithout leading 1)" exponentPart := 25+127 bitShift: 23. "127 is 2r01111111 or 16r7F" expected := exponentPart bitOr: 2r10. self assert: expected = conv. "case 2: exactly in the mid point of two 32 bit float: round toward nearest even (to upper)" conv := 2r1.0000000000000000000000110e25 asIEEE32BitWord. expected := exponentPart bitOr: 2r10. self assert: expected = conv. "case 3: exactly in the mid point of two 32 bit float: round toward nearest even (to lower)" conv := 2r1.0000000000000000000000010e25 asIEEE32BitWord. expected := exponentPart bitOr: 2r0. self assert: expected = conv. "case 4: obviously round to upper" conv := 2r1.0000000000000000000000011e25 asIEEE32BitWord. expected := exponentPart bitOr: 2r1. self assert: expected = conv. ! ! !FloatTest methodsFor: 'tests - mathematical functions' stamp: 'CamilloBruni 8/31/2013 20:23'! testDegreeCos 45.0 degreeCos. "Following tests use approximate equality, because cosine are generally evaluated using inexact Floating point arithmetic" self assert: (45.0 degreeCos squared - 0.5) abs <= Float epsilon. self assert: (60.0 degreeCos - 0.5) abs <= Float epsilon. self assert: (120.0 degreeCos + 0.5) abs <= Float epsilon. -360.0 to: 360.0 do: [ :i | self assert: (i degreeCos closeTo: i degreesToRadians cos) ]. "Following tests use strict equality which is a requested property of degreeCos" -10.0 to: 10.0 do: [ :k | self assert: (k * 360 + 90) degreeCos = 0. self assert: (k * 360 - 90) degreeCos = 0. self assert: (k * 360 + 180) degreeCos + 1 = 0. self assert: (k * 360) degreeCos - 1 = 0 ]! ! !FloatTest methodsFor: 'tests - characterization' stamp: 'nice 6/11/2009 20:47'! testCharacterization "Test the largest finite representable floating point value" self assert: Float fmax successor = Float infinity. self assert: Float infinity predecessor = Float fmax. self assert: Float fmax negated predecessor = Float infinity negated. self assert: Float infinity negated successor = Float fmax negated. "Test the smallest positive representable floating point value" self assert: Float fmin predecessor = 0.0. self assert: 0.0 successor = Float fmin. self assert: Float fmin negated successor = 0.0. self assert: 0.0 predecessor = Float fmin negated. "Test the relative precision" self assert: Float one + Float epsilon > Float one. self assert: Float one + Float epsilon = Float one successor. self assert: Float one + (Float epsilon / Float radix) = Float one. "Test maximum and minimum exponent" self assert: Float fmax exponent = Float emax. self assert: Float fminNormalized exponent = Float emin. Float denormalized ifTrue: [ self assert: Float fminDenormalized exponent = (Float emin + 1 - Float precision)]. "Alternative tests for maximum and minimum" self assert: (Float radix - Float epsilon) * (Float radix raisedTo: Float emax) = Float fmax. self assert: Float epsilon * (Float radix raisedTo: Float emin) = Float fmin. "Test sucessors and predecessors" self assert: Float one predecessor successor = Float one. self assert: Float one successor predecessor = Float one. self assert: Float one negated predecessor successor = Float one negated. self assert: Float one negated successor predecessor = Float one negated. self assert: Float infinity successor = Float infinity. self assert: Float infinity negated predecessor = Float infinity negated. self assert: Float nan predecessor isNaN. self assert: Float nan successor isNaN. "SPECIFIC FOR IEEE 754 double precision - 64 bits" self assert: Float fmax hex = '7FEFFFFFFFFFFFFF'. self assert: Float fminDenormalized hex = '0000000000000001'. self assert: Float fminNormalized hex = '0010000000000000'. self assert: 0.0 hex = '0000000000000000'. self assert: Float negativeZero hex = '8000000000000000'. self assert: Float one hex = '3FF0000000000000'. self assert: Float infinity hex = '7FF0000000000000'. self assert: Float infinity negated hex = 'FFF0000000000000'.! ! !FloatTest methodsFor: 'tests - characterization' stamp: 'jmv 10/11/2011 08:55'! testMaxExactInteger " FloatTest new testMaxExactInteger " self assert: Float maxExactInteger asFloat truncated = Float maxExactInteger. 0 to: 10000 do: [ :j | self assert: (Float maxExactInteger-j) asFloat truncated = (Float maxExactInteger-j) ]. self deny: (Float maxExactInteger+1) asFloat truncated = (Float maxExactInteger+1) ! ! !FloatTest methodsFor: 'tests - arithmetic' stamp: 'st 9/20/2004 17:04'! testContinuedFractions self assert: (Float pi asApproximateFractionAtOrder: 1) = (22/7). self assert: (Float pi asApproximateFractionAtOrder: 3) = (355/113)! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'nice 3/14/2008 23:59'! testReadFromManyDigits "A naive algorithm may interpret these representations as Infinity or NaN. This is http://bugs.squeak.org/view.php?id=6982" | s1 s2 | s1 := '1' , (String new: 321 withAll: $0) , '.0e-321'. s2 := '0.' , (String new: 320 withAll: $0) , '1e321'. self assert: (Number readFrom: s1) = 1. self assert: (Number readFrom: s2) = 1.! ! !FloatTest methodsFor: 'tests - NaN behavior' stamp: 'sd 6/5/2005 08:32'! testNaN4 "FloatTest new testNaN4" | dict | dict := Dictionary new. dict at: Float nan put: #NaN. self deny: (dict includes: Float nan). "as a NaN is not equal to itself, it can not be retrieved when it is used as a dictionary key" ! ! !FloatTest methodsFor: 'tests - compare' stamp: 'nice 7/19/2009 19:24'! testCloseTo self deny: (Float nan closeTo: Float nan) description: 'NaN isn''t close to anything'. self deny: (Float nan closeTo: 1.0) description: 'NaN isn''t close to anything'. self deny: (1.0 closeTo: Float nan) description: 'NaN isn''t close to anything'. self deny: (-1.0 closeTo: 1.0). self deny: (1.0 closeTo: Float infinity). self assert: (Float infinity closeTo: Float infinity) description: 'since they are =, they also are closeTo:'. self assert: (1.0/3.0 closeTo: 1/3). self assert: (1.0e-8 closeTo: 0). self assert: (0 closeTo: 1.0e-8). self assert: (1+1.0e-8 closeTo: 1.0). self assert: (1000000001.0 closeTo: 1000000000.0). self deny: (1000000001 closeTo: 1000000000) description: 'exact representation are considered closeTo: only if equal'.! ! !FloatTest methodsFor: 'tests - mathematical functions' stamp: 'nice 10/31/2010 21:49'! testDegreeSinForExceptionalValues self assert: Float nan degreeSin isNaN. self assert: Float infinity degreeSin isNaN. self assert: Float infinity negated degreeSin isNaN.! ! !FloatTest methodsFor: 'tests - IEEE 754' stamp: 'al 6/22/2008 11:52'! testNaN5 self assert: ((Float nan asIEEE32BitWord printPaddedWith: $0 to: 32 base: 2) copyFrom: 2 to: 9) = '11111111'. self assert: (Float fromIEEE32Bit: (Integer readFrom: '01111111110000000000000000000000' readStream base: 2)) isNaN! ! !FloatTest methodsFor: 'tests' stamp: 'nice 7/15/2011 14:53'! testFractionAsFloatWithUnderflow "test rounding to nearest even" | underflowPower | underflowPower := Float emin - Float precision. self assert: (2 raisedTo: underflowPower) asFloat = 0.0. self assert: (2 raisedTo: underflowPower) negated asFloat = 0.0. self assert: (2 raisedTo: underflowPower) negated asFloat sign = -1 description: 'a negative underflow should return a negative zero'.! ! !FloatTest methodsFor: 'tests - arithmetic' stamp: 'nice 10/14/2011 21:43'! testZeroRaisedToNegativePower "this is a test related to http://bugs.squeak.org/view.php?id=6781" self should: [0.0 raisedTo: -1] raise: ZeroDivide. self should: [0.0 raisedTo: -1.0] raise: ZeroDivide.! ! !FloatTest methodsFor: 'tests - zero behavior' stamp: 'md 4/16/2003 15:02'! testIsZero self assert: 0.0 isZero. self deny: 0.1 isZero.! ! !FloatTest methodsFor: 'tests - arithmetic' stamp: 'GabrielOmarCotelli 6/6/2009 17:14'! testDivide self assert: 1.5 / 2.0 = 0.75. self assert: 2.0 / 1 = 2.0. self should: [ 2.0 / 0 ] raise: ZeroDivide. self should: [ 2.0 / 0.0 ] raise: ZeroDivide. self should: [ 1.2 / Float negativeZero ] raise: ZeroDivide. self should: [ 1.2 / (1.3 - 1.3) ] raise: ZeroDivide ! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'dtl 9/18/2004 12:40'! testStringAsNumber "This covers parsing in Number>>readFrom:" | aFloat | aFloat := '10r-12.3456' asNumber. self assert: -12.3456 = aFloat. aFloat := '10r-12.3456e2' asNumber. self assert: -1234.56 = aFloat. aFloat := '10r-12.3456d2' asNumber. self assert: -1234.56 = aFloat. aFloat := '10r-12.3456q2' asNumber. self assert: -1234.56 = aFloat. aFloat := '-12.3456q2' asNumber. self assert: -1234.56 = aFloat. aFloat := '12.3456q2' asNumber. self assert: 1234.56 = aFloat. ! ! !FloatTest methodsFor: 'tests - compare' stamp: 'nice 5/30/2008 01:23'! testComparison "test equality when Float conversion loose bits" | a b c | a := 16r1FFFFFFFFFFFFF1. b := 16r1FFFFFFFFFFFFF3. c := a asFloat. self assert: ((a = c) & (b = c)) ==> (a = b). "Test equality when Float conversion exact" self assert: 16r1FFFFFFFFFFFFF = 16r1FFFFFFFFFFFFF asFloat. self assert: 16r1FFFFFFFFFFFFF = 16r1FFFFFFFFFFFFF asFloat asInteger. "Test inequality when Float conversion loose bits" self assert: (((1 bitShift: 54)+1)/(1 bitShift: 54)) > 1. self assert: (((1 bitShift: 54)+1)/(1 bitShift: 54)) > 1.0. self assert: (((1 bitShift: 54)-1)/(1 bitShift: 54)) < 1. self assert: (((1 bitShift: 54)-1)/(1 bitShift: 54)) < 1.0. "Test exact vs inexact arithmetic" (1 to: 100) do: [:i | i isPowerOfTwo ifTrue: [self assert: (1/i) = (1/i) asFloat] ifFalse: [self deny: (1/i) = (1/i) asFloat]]. "Test overflow (compare to infinity)" a := (11 raisedTo: 400) / 2. b := (13 raisedTo: 400) / 2. c := a asFloat. self assert: ((a = c) & (b = c)) ==> (a = b). "every integer is smaller than infinity" self assert: a < Float infinity. self assert: a > Float infinity negated. "Test underflow" self deny: 1 / (11 raisedTo: 400) = 0. self deny: 1 / (11 raisedTo: 400) = 0.0. "Test hash code" self assert: ((Set new: 3) add: 3; add: 3.0; size) = ((Set new: 4) add: 3; add: 3.0; size).! ! !FloatTest methodsFor: 'tests - infinity behavior' stamp: 'sd 6/5/2005 08:30'! testInfinity1 "FloatTest new testInfinity1" | i1 i2 | i1 := 10000 exp. i2 := 1000000000 exp. self assert: i1 isInfinite & i2 isInfinite & (i1 = i2). "All infinities are equal. (This is a very substantial difference to NaN's, which are never equal." ! ! !FloatTest methodsFor: 'tests - infinity behavior' stamp: 'sd 6/5/2005 08:30'! testInfinity2 "FloatTest new testInfinity2" | i1 i2 | i1 := 10000 exp. i2 := 1000000000 exp. i2 := 0 - i2. " this is entirely ok. You can compute with infinite values." self assert: i1 isInfinite & i2 isInfinite & i1 positive & i2 negative. self deny: i1 = i2. "All infinities are signed. Negative infinity is not equal to Infinity" ! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'nice 7/24/2008 02:04'! testFloatRounded "5000000000000001 asFloat has an exact representation (no round off error). It should round to nearest integer without loosing bits. This is a no regression test on http://bugs.squeak.org/view.php?id=7134" | x y int r | "This is a preamble asserting exactness of representation and quality of various conversions" int := 5000000000000001. x := int asFloat. y := (5 asFloat squared squared squared squared timesTwoPower: 15) + 1. self assert: x = y. self assert: x asTrueFraction = int. "this one should be true for any float in order to conform to ISO/IEC 10967-2" self assert: x rounded = x asTrueFraction rounded. self assert: x negated rounded = x negated asTrueFraction rounded. "a random test" r := Random new. 10000 timesRepeat: [ x := r next * 1.9999e16 + 1.0e12 . self assert: x rounded = x asTrueFraction rounded. self assert: x negated rounded = x negated asTrueFraction rounded]! ! !FloatTest methodsFor: 'tests - mathematical functions' stamp: 'nice 10/30/2009 22:23'! testArcTan self assert: ((100 arcTan: 100) closeTo: Float pi / 4). self assert: ((-100 arcTan: 100) closeTo: Float pi / -4). self assert: ((100 arcTan: -100) closeTo: Float pi * 3 / 4). self assert: ((-100 arcTan: -100) closeTo: Float pi * -3 / 4). self assert: ((0 arcTan: 100) closeTo: 0). self assert: ((0 arcTan: -100) closeTo: Float pi). self assert: ((100 arcTan: 0) closeTo: Float pi / 2). self assert: ((-100 arcTan: 0) closeTo: Float pi / -2). self assert: ((Float negativeZero arcTan: 100) closeTo: 0). self assert: ((Float negativeZero arcTan: -100) closeTo: Float pi * -1). self assert: (0 arcTan: 0) = 0. self assert: (Float negativeZero arcTan: 0) = 0. self assert: ((0 arcTan: Float negativeZero) closeTo: Float pi). self assert: ((Float negativeZero arcTan: Float negativeZero) closeTo: Float pi negated). ! ! !FloatTest methodsFor: 'tests - NaN behavior' stamp: 'nice 3/14/2008 23:42'! testNaNisLiteral self deny: Float nan isLiteral description: 'there is no literal representation of NaN'! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'nice 5/7/2006 16:22'! testFractionAsFloat "use a random test" | r m frac err collec | r := Random new seed: 1234567. m := (2 raisedTo: 54) - 1. 200 timesRepeat: [ frac := ((r nextInt: m) * (r nextInt: m) + 1) / ((r nextInt: m) * (r nextInt: m) + 1). err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52). self assert: err < (1/2)]. collec := #(16r10000000000000 16r1FFFFFFFFFFFFF 1 2 16r20000000000000 16r20000000000001 16r3FFFFFFFFFFFFF 16r3FFFFFFFFFFFFE 16r3FFFFFFFFFFFFD). collec do: [:num | collec do: [:den | frac := Fraction numerator: num denominator: den. err := (frac - frac asFloat asTrueFraction) * frac reciprocal * (1 bitShift: 52). self assert: err <= (1/2)]].! ! !FloatTest methodsFor: 'tests - NaN behavior' stamp: 'GabrielOmarCotelli 5/23/2009 20:38'! testReciprocal self assert: 1.0 reciprocal = 1.0; assert: 2.0 reciprocal = 0.5; assert: -1.0 reciprocal = -1.0; assert: -2.0 reciprocal = -0.5. self should: [ 0.0 reciprocal ] raise: ZeroDivide! ! !FloatTest methodsFor: 'tests - printing' stamp: 'nice 10/11/2008 21:45'! testStoreBase16 "This bug was reported in mantis http://bugs.squeak.org/view.php?id=6695" self assert: (20.0 storeStringBase: 16) = '16r14.0' description: 'the radix prefix should not be omitted, except in base 10'! ! !FloatTest methodsFor: 'tests - zero behavior' stamp: 'nice 8/21/2010 22:29'! testNegativeZeroAbs self assert: Float negativeZero abs sign positive description: 'the absolute value of a negative zero is zero'! ! !FloatTest methodsFor: 'tests - NaN behavior' stamp: 'sd 6/5/2005 08:32'! testNaN3 "FloatTest new testNaN3" | set item identitySet | set := Set new. set add: (item := Float nan). self deny: (set includes: item). identitySet := IdentitySet new. identitySet add: (item := Float nan). self assert: (identitySet includes: item). "as a NaN is not equal to itself, it can not be retrieved from a set" ! ! !FloatTest methodsFor: 'tests - conversion' stamp: 'nice 1/10/2007 02:29'! testFractionAsFloat2 "test rounding to nearest even" self assert: ((1<<52)+0+(1/4)) asFloat asTrueFraction = ((1<<52)+0). self assert: ((1<<52)+0+(1/2)) asFloat asTrueFraction = ((1<<52)+0). self assert: ((1<<52)+0+(3/4)) asFloat asTrueFraction = ((1<<52)+1). self assert: ((1<<52)+1+(1/4)) asFloat asTrueFraction = ((1<<52)+1). self assert: ((1<<52)+1+(1/2)) asFloat asTrueFraction = ((1<<52)+2). self assert: ((1<<52)+1+(3/4)) asFloat asTrueFraction = ((1<<52)+2).! ! !FloatTest methodsFor: 'tests' stamp: 'MarcusDenker 5/2/2013 11:27'! testStoreOn "If storeOn: prints exactly and the parser avoid cumulating round off Errors, then Float should be read back exactly. Note: there is no guarantee to restore the bit pattern of NaN though" self assert: (self class compiler evaluate: Float halfPi storeString) = Float halfPi. self assert: (self class compiler evaluate: Float halfPi negated storeString) = Float halfPi negated. self assert: (self class compiler evaluate: Float infinity storeString) = Float infinity. self assert: (self class compiler evaluate: Float infinity negated storeString) = Float infinity negated. self assert: (self class compiler evaluate: Float nan storeString) isNaN.! ! !FloatingPointException commentStamp: 'SvenVanCaekenberghe 4/21/2011 12:39'! I am FloatingPointException, an ArithmeticError indicating a problem in a floating point calculation. Precision underflow or overflow could be considered FloatingPointExceptions. ZeroDivide, DomainError and NaNException are examples of more specific ArithmeticErrors that can be signaled before an operation is actually attempted.! !FontChooser commentStamp: 'StephaneDucasse 1/1/2010 18:00'! I'm an object holding information to choose a font from a list of fonts.! !FontChooser methodsFor: 'accessing' stamp: 'NicolaiHess 1/25/2014 00:19'! pointSizeList pointSizeList ifNotNil: [ ^ pointSizeList ]. ^ pointSizeList := (1 to: 256) collect: [ :each | each asString padLeftTo: 3 ].! ! !FontChooser methodsFor: 'selected' stamp: 'HenrikSperreJohansen 9/5/2013 16:19'! selectedFontIndex | font textStyleName family | selectedFontIndex ifNotNil: [^selectedFontIndex]. selectedFontIndex := 0. font := (getSelector isSymbol and:[target notNil]) ifTrue:[target perform: getSelector] ifFalse:[getSelector]. self setStyleValuesFrom: font. (font isKindOf: AbstractFont) ifTrue:[ pointSize := font pointSize. textStyleName := font textStyleName. family := self fontList detect:[:f | f familyName = textStyleName] ifNone:[]. selectedFontIndex := self fontList indexOf: family ifAbsent:[0]]. self selectedFontIndex: selectedFontIndex. ^selectedFontIndex! ! !FontChooser methodsFor: 'action' stamp: 'StephaneDucasse 11/11/2013 17:41'! refreshFontList ^fontList := LogicalFontManager current allFamilies! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:23'! fontStyleListStrings "names of simulated styles are enclosed in parenthesis" ^ self fontStyleList collect: [:fontFamilyMember | | styleName | styleName := fontFamilyMember styleName. fontFamilyMember simulated ifTrue: ['(', styleName, ')'] ifFalse: [styleName]].! ! !FontChooser methodsFor: 'action' stamp: 'HenrikSperreJohansen 12/9/2009 00:08'! updateFontList FreeTypeFontProvider current updateFromSystem. self refreshFontList! ! !FontChooser methodsFor: 'selected' stamp: 'StephaneDucasse 11/11/2013 18:29'! setPointSizeListFrom: aFontFamilyMember | style old new | old := pointSizeList. (aFontFamilyMember isKindOf: FontFamilyMemberAbstract) ifTrue:[ style := TextStyle named: aFontFamilyMember family familyName. style ifNotNil:[ new := style pointSizes collect: [:each | each reduce asString padLeftTo: 3]]]. new ifNil: [ new := (1 to: 256) collect: [:each | each asString padLeftTo: 3 ]]. pointSizeList := new. old ~= new ifTrue: [ self announcer announce: #pointSizeListChanged]! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:24'! getSelector: aSelectorSymbolOrFont getSelector := aSelectorSymbolOrFont! ! !FontChooser methodsFor: 'initialization' stamp: 'tween 8/4/2007 10:27'! initialize super initialize. title := 'Choose A Font'.! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:24'! pointSize: aNumber pointSize := aNumber. self announcer announce: #pointSizeChanged.! ! !FontChooser methodsFor: 'selected' stamp: 'HenrikSperreJohansen 9/5/2013 16:34'! selectedPointSizeIndex ^self pointSizeList indexOf: (pointSize reduce asString padLeftTo: 3)! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:26'! title: aString title := aString! ! !FontChooser methodsFor: 'selected' stamp: 'StephaneDucasse 11/11/2013 17:32'! selectedFontStyleIndex: anIndex | familyMember | anIndex = 0 ifTrue: [^self]. selectedFontStyleIndex := anIndex. familyMember := self fontStyleList at: anIndex. self setStyleValuesFrom: familyMember. self announcer announce: #selectedFontStyleIndex.! ! !FontChooser methodsFor: 'selected' stamp: 'SeanDeNigris 1/23/2014 15:12'! selectedPointSizeIndex: anIndex anIndex = 0 ifTrue: [^self]. pointSize := (self pointSizeList at: anIndex) trimBoth asNumber. self announcer announce: #pointSizeChanged. ! ! !FontChooser methodsFor: 'selected' stamp: 'tween 8/19/2007 16:23'! selectedFontStyleIndex | family member | selectedFontStyleIndex ifNotNil: [ ^selectedFontStyleIndex := selectedFontStyleIndex min: self fontStyleList size]. family := self fontList at: selectedFontIndex ifAbsent:[^0]. member := family closestMemberWithStretchValue: stretchValue weightValue: weightValue slantValue: slantValue. selectedFontStyleIndex := self fontStyleList indexOf: member. ^selectedFontStyleIndex! ! !FontChooser methodsFor: 'selected' stamp: 'tween 8/18/2007 11:18'! selectedFont | font style | font := self unemphasizedSelectedFont. font ifNil:[^nil]. style := self fontStyleList at: self selectedFontStyleIndex ifAbsent:[nil]. style ifNil:[^nil]. (style isKindOf: TextStyleAsFontFamilyMember) ifTrue:[ ^font emphasized: style emphasisCode]. ^LogicalFont familyName: font familyName pointSize: pointSize stretchValue: style stretchValue weightValue: style weightValue slantValue: style slantValue ! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:26'! target: anObject target := anObject! ! !FontChooser methodsFor: 'selected' stamp: 'tween 8/27/2007 23:12'! selectedPointSize ^self selectedFont pointSize! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:13'! fontList ^ fontList ifNil: [ self refreshFontList ].! ! !FontChooser methodsFor: 'accessing' stamp: 'StephaneDucasse 11/11/2013 17:06'! announcer ^ announcer ifNil: [ announcer := Announcer new ]! ! !FontChooser methodsFor: 'action' stamp: 'SeanDeNigris 1/23/2014 15:16'! apply (target isNil or: [ setSelector isNil ]) ifTrue: [ ^ self ]. self selectedFont ifNotNil: [ :font | target perform: setSelector with: font ].! ! !FontChooser methodsFor: 'selected' stamp: 'StephaneDucasse 11/11/2013 17:27'! selectedFontFamily ^ self fontList at: self selectedFontIndex ifAbsent: [nil]. ! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:24'! getSelector ^ getSelector! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:18'! fontListStrings | isUpdateRequired | isUpdateRequired := fontListStrings isNil or: [fontList size ~= fontListStrings size]. isUpdateRequired ifTrue: [ fontListStrings := self fontList collect: [:each | each familyName]]. ^ fontListStrings! ! !FontChooser methodsFor: 'selected' stamp: 'SeanDeNigris 1/23/2014 15:13'! selectedFontIndex: anIndex | family member newStyleIndex | anIndex = 0 ifTrue: [^self]. selectedFontIndex := anIndex. "change the selected style to be the closest to the last user selected weight slant and stretch values. By user selected I mean that the user changed the style list selection, rather than a change being forced because a particular family didn't have that style" family := self fontList at: selectedFontIndex. member := family closestMemberWithStretchValue: stretchValue weightValue: weightValue slantValue: slantValue. newStyleIndex := self fontStyleList indexOf: member. selectedFontStyleIndex := newStyleIndex. self setPointSizeListFrom: member. self announcer announce: #selectedFontStyleIndex. self announcer announce: #selectedFontIndex. ! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 10:27'! windowTitle ^ title translated! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:19'! fontStyleList ^ self selectedFontFamily ifNil: [ #() ] ifNotNil: [ :family | fontStyleList := family members asSortedCollection ].! ! !FontChooser methodsFor: 'action' stamp: 'tween 8/18/2007 21:10'! unemphasizedSelectedFont |name font family | family := self fontList at: self selectedFontIndex ifAbsent:[nil]. family ifNil:[^nil]. (family isKindOf: TextStyleAsFontFamily) ifTrue:[^family textStyle fontOfPointSize: pointSize]. name := family familyName. font := LogicalFont familyName: name pointSize: pointSize stretchValue: 5 weightValue: 400 slantValue: 0. font realFont isTTCFont "true for FreeTypeFont" ifFalse: [font := font textStyle fontOfPointSize: pointSize]. ^font ! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:25'! setSelector: selector setSelector := selector! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:24'! pointSize ^ pointSize ifNil: [pointSize := 10.0]! ! !FontChooser methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 15:26'! target ^ target! ! !FontChooser methodsFor: 'action' stamp: 'tween 8/18/2007 13:49'! setStyleValuesFrom: aFont ((aFont isKindOf: LogicalFont) or:[aFont isKindOf: FontFamilyMemberAbstract]) ifTrue:[ weightValue := aFont weightValue. slantValue := aFont slantValue. stretchValue := aFont stretchValue] ifFalse:[ weightValue := (aFont emphasis bitAnd: 1) > 0 ifTrue:[700] ifFalse:[400]. slantValue := (aFont emphasis bitAnd: 2) > 0 ifTrue:[1] ifFalse:[0]. stretchValue := 5 "normal"]! ! !FontChooser class methodsFor: 'open' stamp: 'MarcusDenker 11/13/2012 15:10'! openWithWindowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector "FontChooser openWithWindowTitle: 'Choose the Menu Font' for: StandardFonts setSelector: #menuFont: getSelector: #menuFont" | instance windowMorph world | instance := self new. instance title: titleString; target: anObject; setSelector: setSelector; getSelector: getSelector. world := self currentWorld. (windowMorph := FontChooserMorph withModel: instance) "position: self currentWorld primaryHand position;" position: ((World width-640)/2)@((World height-480)/2); extent: 640@480; open. ^windowMorph ! ! !FontChooser class methodsFor: 'instance creation' stamp: 'StephaneDucasse 1/1/2010 18:00'! windowTitle: titleString for: anObject setSelector: setSelector getSelector: getSelector | instance answer | instance := self new. instance title: titleString; target: anObject; setSelector: setSelector; getSelector: getSelector. (answer := FontChooserMorph withModel: instance) position: self currentWorld primaryHand position; extent: 450@220; createWindow. ^answer! ! !FontChooserMorph commentStamp: ''! I'm the UI of a font chooser. FontChooser openWithWindowTitle: 'Choose the Menu Font' for: StandardFonts setSelector: #menuFont: getSelector: #menuFont ! !FontChooserMorph methodsFor: 'interface building' stamp: 'SeanDeNigris 1/23/2014 16:16'! newLanguageList | widget | widget := PluggableListMorph on: self list: #languages selected: #languageIndex changeSelected: #languageIndex:. ^ widget color: Color white; borderInset; vResizing: #spaceFill; hResizing: #spaceFill; yourself.! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 11/11/2013 17:27'! languageIndex | item | item := self pangrams detect: [ :one | one value = selectedPangram ] ifNone: nil. ^self pangrams indexOf: item.! ! !FontChooserMorph methodsFor: 'actions' stamp: 'SeanDeNigris 1/23/2014 16:34'! updatePointSize pointSizeList ifNotNil: [ pointSizeList selectionIndex: model selectedPointSizeIndex ]. "this should not be like that but managed by the list!!!!!!!!" self updatePreview! ! !FontChooserMorph methodsFor: 'actions' stamp: 'SeanDeNigris 1/23/2014 16:34'! updateStyleList styleList ifNotNil: [ styleList selectionIndex: model selectedFontStyleIndex ]. "this should not be like that but managed by the list!!!!!!!!" self updatePreview! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'SeanDeNigris 1/23/2014 15:32'! languages ^ self pangrams collect: #key! ! !FontChooserMorph methodsFor: 'initialize-release' stamp: 'StephaneDucasse 1/21/2014 21:20'! initializeWithModel: aFontChooser self model: aFontChooser; clipSubmorphs: true; setLabel: self model windowTitle; name: 'FontChooser'. self model announcer when: #pointSizeListChanged send: #updatePointSizeList to: self. self model announcer when: #selectedFontIndex send: #updateFontIndex to: self. self model announcer when: #pointSizeChanged send: #updatePointSize to: self. self model announcer when: #selectedFontStyleIndex send: #updateStyleList to: self. self updatePreview! ! !FontChooserMorph methodsFor: 'actions' stamp: 'SeanDeNigris 1/23/2014 16:33'! updateFontList model updateFontList. self announcer announce: #fontsUpdated.! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 16:18'! pointSizeString ^ model pointSize asString.! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2014 16:31'! result ^ result! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'SeanDeNigris 1/23/2014 15:42'! newFontSizePanel pointSizeMorph := self newFontPointSizeField. ^ Morph new borderWidth: 1; borderColor: Color black; hResizing: #spaceFill; vResizing: #shrinkwrap; color: Color transparent; layoutPolicy: TableLayout new; cellInset: 0; listCentering: #topLeft; listDirection: #leftToRight; cellPositioning: #leftCenter; clipSubmorphs: true; addMorphBack: self newFontPointSizeLabel; addMorphBack: pointSizeMorph. ! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'SeanDeNigris 1/23/2014 15:12'! newFontPointSizeField ^ (PluggableTextMorph on: self text: #pointSizeString accept: #pointSizeString:) acceptOnCR: true; hideVScrollBarIndefinitely: true; color: Color gray veryMuchLighter; borderColor: #inset; vResizing: #rigid; hResizing: #spaceFill; width: (TextStyle defaultFont widthOfString: '99999999.99'); height: TextStyle defaultFont height + 6; yourself. ! ! !FontChooserMorph methodsFor: 'actions' stamp: 'SeanDeNigris 1/23/2014 16:25'! pointSizeString: aText | string number | string := aText asString trimBoth. string isEmpty ifTrue: [^self]. string detect: [:c | c isDigit not and: [c ~= $.]] ifFound: [^self]. [number := string asNumber asFloat] on: Error do: [:e | ^self]. (number < 1 or: [number > 1024]) ifTrue: [^self]. pointSizeMorph ifNotNil: [pointSizeMorph hasUnacceptedEdits: false]. model pointSize: number! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 1/24/2014 22:27'! previewText "Answer the preview text based on current font." | sample i maxLineLength endOfLineCharacters | model selectedFont isNil ifTrue: [ ^'' ]. sample := String new writeStream. model selectedFont isSymbolFont ifFalse: [ | pangram | pangram := self selectedPangram. sample nextPutAll: pangram; cr; nextPutAll: pangram asUppercase; cr ]. i := 0. maxLineLength := 30. endOfLineCharacters := '@Z`z'. 33 to: 255 do: [ :asciiValue | | character | character := Character value: asciiValue. sample nextPut: character. i := i + 1. ((endOfLineCharacters includes: character) or: [ i = maxLineLength ]) ifTrue: [ i := 0. sample cr ] ]. ^ sample contents.! ! !FontChooserMorph methodsFor: 'actions' stamp: 'SeanDeNigris 1/23/2014 16:34'! updatePreview self fontPreviewPanel scrollTarget: self newFontPreviewInnerPanel! ! !FontChooserMorph methodsFor: 'ui elements' stamp: 'SeanDeNigris 1/23/2014 16:17'! okButton okButton ifNotNil: [ ^ okButton ]. okButton := self newButtonFor: self action: #okButtonClicked label: 'OK' translated help: 'Click here to close this dialog, and accept your selection' translated. ^ okButton hResizing: #spaceFill; yourself.! ! !FontChooserMorph methodsFor: 'initialize-release' stamp: 'StephaneDucasse 11/11/2013 16:32'! initializeLabelArea "Customize the window bar by removing all the decorations" super initializeLabelArea. self removeCollapseBox; removeExpandBox; removeMenuBox! ! !FontChooserMorph methodsFor: 'ui elements' stamp: 'SeanDeNigris 1/23/2014 16:32'! updateButton updateButton ifNotNil: [ ^ updateButton ]. updateButton := self newButtonFor: self action: #updateButtonClicked label: 'Update' translated help: 'Click here to rescan Font Folder and update the font list' translated. ^ updateButton hResizing: #spaceFill; yourself.! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'SeanDeNigris 1/23/2014 15:41'! newFontPreviewInnerPanel "Answer a morph for the preview text." | textMorph | textMorph := self newText: self previewText. textMorph margins: 4. ^ self model selectedFont ifNil: [ textMorph ] ifNotNil: [ :f | textMorph beAllFont: f ]! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'SeanDeNigris 1/24/2014 22:29'! newFontStyleList | widget minWidth requiredWidth | widget := PluggableListMorph on: self model list: #fontStyleListStrings selected: #selectedFontStyleIndex changeSelected: #selectedFontStyleIndex:. minWidth := widget font widthOfStringOrText: 'Condensed Extra Bold Oblique' "long, but not the longest". requiredWidth := self widthRequiredFor: [ :each | widget font widthOfStringOrText: each styleName ] from: model fontStyleList noLessThan: minWidth. ^ widget color: Color white; borderInset; vResizing: #spaceFill; hResizing: #spaceFill; width: requiredWidth + widget scrollBarThickness + (widget font widthOfStringOrText: ' '); yourself.! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'SeanDeNigris 1/23/2014 15:41'! newFontPointSizeLabel ^ StringMorph contents: 'Point size:' translated; yourself.! ! !FontChooserMorph methodsFor: 'actions' stamp: 'tween 8/4/2007 20:28'! apply result := model selectedFont. model apply! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'SeanDeNigris 1/24/2014 22:36'! newFontList | widget requiredWidth | widget := PluggableListMorph on: self model list: #fontListStrings selected: #selectedFontIndex changeSelected: #selectedFontIndex:. requiredWidth := self widthRequiredFor: [ :each | widget font widthOfStringOrText: each familyName ] from: model fontList noLessThan: 20. widget color: Color white; borderInset; vResizing: #spaceFill; hResizing: #spaceFill; width: requiredWidth + widget scrollBarThickness + (widget font widthOfStringOrText: ' '). self model announcer when: #fontsUpdated send: #verifyContents to: widget. ^ widget.! ! !FontChooserMorph methodsFor: 'actions' stamp: 'SeanDeNigris 1/23/2014 16:33'! updateButtonClicked self updateFontList.! ! !FontChooserMorph methodsFor: 'private' stamp: 'SeanDeNigris 1/24/2014 22:28'! widthRequiredFor: aBlock from: aCollection noLessThan: anInteger "aBlock - takes each item as an argument, and returns the width it needs" ^ aCollection inject: anInteger into: [ :max :each | | itemWidth | itemWidth := aBlock value: each. max max: itemWidth ].! ! !FontChooserMorph methodsFor: 'ui elements' stamp: 'StephaneDucasse 11/11/2013 18:19'! applyButton ^applyButton ifNil: [ applyButton := (self newButtonFor: self action: #applyButtonClicked label: 'Apply' translated help: 'Click here to apply your selection without closing this dialog' translated) hResizing: #spaceFill ]! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'SeanDeNigris 1/23/2014 15:32'! createWindow "Create the package loader window." | buttonBar buttonBarOffset previewFrame buttonBarFrame | buttonBar := self newRow: { self applyButton. self okButton. self cancelButton. self updateButton }. buttonBar cellInset: 8@0. buttonBarOffset := buttonBar minExtent y negated - (2 * ProportionalSplitterMorph splitterWidth). fontList := self newFontList borderWidth: 0. self addMorph: fontList frame: (0.0 @ 0.0 corner: 0.4 @ 0.4). styleList := self newFontStyleList borderWidth: 0; yourself. self addMorph: styleList frame: (0.4 @ 0.0 corner: 0.6 @ 0.4). pointSizeList := self newPointSizeList borderWidth: 0; yourself. self addMorph: pointSizeList frame: (0.6 @ 0.0 corner: 0.75 @ 0.4). languageList := self newLanguageList borderWidth: 0; yourself. self addMorph: languageList frame: (0.75 @ 0.0 corner: 1.0 @ 0.4). self languageIndex: 1. previewFrame := (0 @ 0.4 corner: 1 @1) asLayoutFrame bottomOffset: buttonBarOffset yourself. self addMorph: self fontPreviewPanel fullFrame: previewFrame. buttonBarFrame := (0 @1 corner: 1@1) asLayoutFrame topOffset: buttonBarOffset; yourself. self addMorph: buttonBar fullFrame: buttonBarFrame.! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 11/11/2013 17:39'! selectedPangram ^ selectedPangram ifNil: [ self pangrams first value ]! ! !FontChooserMorph methodsFor: 'ui elements' stamp: 'StephaneDucasse 11/11/2013 18:19'! fontPreviewPanel ^fontPreviewPanel ifNil: [ fontPreviewPanel := self newScrollPaneFor: self newFontPreviewInnerPanel ]! ! !FontChooserMorph methodsFor: 'actions' stamp: 'tween 8/4/2007 20:25'! delete model := nil. super delete ! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'SeanDeNigris 1/23/2014 16:16'! newPointSizeList | widget | widget := PluggableListMorph on: self model list: #pointSizeList selected: #selectedPointSizeIndex changeSelected: #selectedPointSizeIndex:. ^ widget color: Color white; borderInset; vResizing: #spaceFill; hResizing: #spaceFill; yourself.! ! !FontChooserMorph methodsFor: 'ui elements' stamp: 'StephaneDucasse 11/11/2013 18:19'! cancelButton ^cancelButton ifNil: [ cancelButton := (self newButtonFor: self action: #cancelButtonClicked label: 'Cancel' translated help: 'Click here to cancel and close this dialog' translated) hResizing: #spaceFill ]! ! !FontChooserMorph methodsFor: 'actions' stamp: 'tween 8/4/2007 20:27'! cancelButtonClicked result :=nil. self delete ! ! !FontChooserMorph methodsFor: 'actions' stamp: 'tween 8/4/2007 13:49'! applyButtonClicked self apply. ! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'HenrikSperreJohansen 9/5/2013 16:05'! pangrams ^ OrderedCollection new add: 'English' -> 'the quick brown fox jumps over the lazy dog'; add: 'Bulgarian' -> 'Под южно дърво, цъфтящо в синьо, бягаше малко пухкаво зайче.'; add: 'Czech' -> 'Příliš žluťoučký kůň úpěl ďábelské ódy.'; add: 'Chinese' -> '視野無限廣，窗外有藍天 微風迎客，軟語伴茶'; add: 'Danish' -> 'Quizdeltagerne spiste jordbær med fløde, mens cirkusklovnen Walther spillede på xylofon.'; add: 'Dutch' -> 'Pa''s wijze lynx bezag vroom het fikse aquaduct'; add: 'Esperanto' -> 'Eĥoŝanĝo ĉiuĵaŭde'; add: 'Estonian' -> 'See väike mölder jõuab rongile hüpata'; add: 'Finnish' -> 'Viekas kettu punaturkki laiskan koiran takaa kurkki'; add: 'French' -> 'Voix ambiguë d''un cœur qui au zéphyr préfère les jattes de kiwis'; add: 'German' -> 'Zwölf Boxkämpfer jagen Viktor quer über den großen Sylter Deich'; add: 'Greek' -> 'Θέλει αρετή και τόλμη η ελευθερία. (Ανδρέας Κάλβος)'; add: 'Hebrew' -> 'דג סקרן שט לו בים זך אך לפתע פגש חבורה נחמדה שצצה כך'; add: 'Hungarian' -> 'Egy hűtlen vejét fülöncsípő, dühös mexikói úr Wesselényinél mázol Quitóban'; add: 'Italian' -> 'Ma la volpe, col suo balzo, ha raggiunto il quieto Fido.'; add: 'Japanese' -> 'いろはにほへと ちりぬるを わかよたれそ つねならむ うゐのおくやま けふこえて あさきゆめみし ゑひもせす'; add: 'Korean' -> '다람쥐 헌 쳇바퀴에 타고파'; add: 'Latvian' -> 'Sarkanās jūrascūciņas peld pa jūru.'; add: 'Norwegian' -> 'En god stil må først og fremst være klar. Den må være passende. Aristoteles.'; add: 'Portugese' -> 'A rápida raposa castanha salta por cima do cão lento.'; add: 'Brazilian portugese' -> 'A ligeira raposa marrom ataca o cão preguiçoso'; add: 'Polish' -> 'Pchnąć w tę łódź jeża lub ośm skrzyń fig'; add: 'Romanian' -> 'Agera vulpe maronie sare peste câinele cel leneş'; add: 'Russian' -> 'Съешь ещё этих мягких французских булок да выпей же чаю'; add: 'Serbian (cyrillic)' -> 'Чешће цeђење мрeжастим џаком побољшава фертилизацију генских хибрида.'; add: 'Serbian (latin)' -> 'Češće ceđenje mrežastim džakom poboljšava fertilizaciju genskih hibrida.'; add: 'Slovak' -> 'Kŕdeľ šťastných ďatľov učí pri ústí Váhu mĺkveho koňa obhrýzať kôru a žrať čerstvé mäso.'; add: 'Slovene' -> 'V kožuščku hudobnega fanta stopiclja mizar in kliče 0619872345.'; add: 'Spanish' -> 'El veloz murciélago hindú comía feliz cardillo y kiwi. La cigüeña tocaba el saxofón detrás del palenque de paja.'; add: 'Swedish' -> 'Flygande bäckasiner söka hwila på mjuka tuvor'; add: 'Thai' -> 'เป็นมนุษย์สุดประเสริฐเลิศคุณค่า กว่าบรรดาฝูงสัตว์เดรัจฉาน จงฝ่าฟันพัฒนาวิชาการ อย่าล้างผลาญฤๅเข่นฆ่าบีฑาใคร ไม่ถือโทษโกรธแช่งซัดฮึดฮัดด่า หัดอภัยเหมือนกีฬาอัชฌาสัย ปฏิบัติประพฤติกฎกำหนดใจ พูดจาให้จ๊ะ ๆ จ๋า ๆ น่าฟังเอยฯ'; add: 'Turkish' -> 'Pijamalı hasta, yağız şoföre çabucak güvendi'; yourself!]lang[(2798)0! ! !FontChooserMorph methodsFor: 'actions' stamp: 'SeanDeNigris 1/23/2014 16:17'! okButtonClicked self apply. self delete.! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'SeanDeNigris 1/23/2014 16:17'! open ^ self createWindow openAsIsIn: self currentWorld.! ! !FontChooserMorph methodsFor: 'actions' stamp: 'StephaneDucasse 11/11/2013 18:48'! updateFontIndex fontList ifNotNil: [ fontList selectionIndex: model selectedFontIndex ]. styleList ifNotNil: [ styleList updateList ]. pointSizeList ifNotNil: [ pointSizeList updateList ]. self updatePreview! ! !FontChooserMorph methodsFor: 'actions' stamp: 'SeanDeNigris 1/23/2014 16:34'! updatePointSizeList pointSizeList ifNotNil: [ pointSizeList updateList ]. self updatePreview! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 1/21/2014 21:32'! languageIndex: anIndex anIndex isZero ifTrue: [ ^ self ]. selectedPangram := (self pangrams at: anIndex) value. languageList selectionIndex: anIndex. self updatePreview! ! !FontChooserMorph class methodsFor: 'instance creation' stamp: 'tween 8/4/2007 10:24'! withModel: aFontChooser ^self new initializeWithModel: aFontChooser; yourself.! ! !FontFamilyAbstract commentStamp: 'TorstenBergmann 2/4/2014 22:07'! Abstract font family! !FontFamilyAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:47'! members "Answer the value of members" ^ members! ! !FontFamilyAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:46'! familyName: anObject "Set the value of familyName" familyName := anObject! ! !FontFamilyAbstract methodsFor: 'printing' stamp: 'tween 9/7/2007 19:36'! printOn: aStream aStream nextPutAll: self class name asString; nextPut: $ ; nextPutAll: self familyName printString! ! !FontFamilyAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:46'! familyName "Answer the value of familyName" ^ familyName! ! !FontFamilyAbstract methodsFor: 'member lookup' stamp: 'tween 8/18/2007 13:50'! closestMemberWithStretchValue: stretchValue weightValue: weightValue slantValue: slantValue "answer the member that has weight, slant and stretch values that most closely match those given by stretchValue, weightValue, and slantValue" ^(self members asSortedCollection:[:a :b | a isCloserMatchThan: b toStretch: stretchValue weight: weightValue slant: slantValue]) first. ! ! !FontFamilyMemberAbstract commentStamp: 'TorstenBergmann 2/4/2014 22:08'! Abstract member for a font family! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 9/8/2007 13:24'! stretchValue self subclassResponsibility! ! !FontFamilyMemberAbstract methodsFor: 'comparing' stamp: 'tween 9/29/2007 13:00'! closenessVectorForStretch: stretch slant: slant weight: weight | normalizedSlant | normalizedSlant := slant. normalizedSlant ~= 0 ifTrue:[ "treat italic and oblique as though they were they same" normalizedSlant := LogicalFont slantItalic]. ^{(stretch - LogicalFont stretchRegular) * 11. slant * 7. ((weight - LogicalFont weightRegular) / 100) * 5}! ! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:41'! styleName "Answer the value of styleName" ^ styleName! ! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 8/25/2007 14:22'! family ^family! ! !FontFamilyMemberAbstract methodsFor: 'converting' stamp: 'tween 9/8/2007 13:25'! asLogicalFontOfPointSize: pointSize ^LogicalFont familyName: self family familyName pointSize: pointSize stretchValue: self stretchValue weightValue: self weightValue slantValue: self slantValue! ! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:41'! styleName: anObject "Set the value of styleName" styleName := anObject! ! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 9/8/2007 13:24'! weightValue self subclassResponsibility! ! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 9/8/2007 13:24'! slantValue self subclassResponsibility! ! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 8/25/2007 14:22'! family: aFontFamily family := aFontFamily! ! !FontFamilyMemberAbstract methodsFor: 'comparing' stamp: 'tween 8/18/2007 13:42'! closenessVector ^self closenessVectorForStretch: self stretchValue slant: self slantValue weight: self weightValue! ! !FontFamilyMemberAbstract methodsFor: 'comparing' stamp: 'tween 8/18/2007 13:43'! isCloserMatchThan: otherMember toStretch: inputStretch weight: inputWeight slant: inputSlant | inputVector vector otherVector distance otherDistance dotProduct otherDotProduct | inputVector := self closenessVectorForStretch: inputStretch slant: inputSlant weight: inputWeight. vector := self closenessVector. otherVector := otherMember closenessVector. distance := (((inputVector first - vector first) raisedTo: 2) + ((inputVector second - vector second) raisedTo: 2) + ((inputVector third - vector third) raisedTo: 2)) sqrt. otherDistance := (((inputVector first - otherVector first) raisedTo: 2) + ((inputVector second - otherVector second) raisedTo: 2) + ((inputVector third - otherVector third) raisedTo: 2)) sqrt. distance < otherDistance ifTrue:[^true]. distance > otherDistance ifTrue:[^false]. dotProduct := (inputVector first * vector first) + (inputVector second * vector second) + (inputVector third * vector third). otherDotProduct := (inputVector first * otherVector first) + (inputVector second * otherVector second) + (inputVector third * otherVector third). dotProduct > otherDotProduct ifTrue:[^true]. dotProduct < otherDotProduct ifTrue:[^false]. vector first > otherVector first ifTrue:[^true]. vector first < otherVector first ifTrue:[^false]. vector second > otherVector second ifTrue:[^true]. vector second < otherVector second ifTrue:[^false]. vector third > otherVector third ifTrue:[^true]. vector third < otherVector third ifTrue:[^false]. ^false ! ! !FontProviderAbstract commentStamp: 'tween 3/14/2007 22:59'! Abstract superClass for fontProviders examples of possible fontProviders are StrikeFontProvider FreeTypeFontProvider Win32NativeFontProvider ! !FontProviderAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 22:00'! families self subclassResponsibility! ! !FontProviderAbstract methodsFor: 'font lookup' stamp: 'tween 3/16/2007 17:57'! fontFor: aLogicalFont ^nil! ! !FontSet commentStamp: ''! FontSet provides a mechanism for storing a set of fonts as a class that can be conveniently filedOut, filedIn, and installed as a TextStyle. The most common use is... Find a font you like. Use BitFont to convert a bunch of sizes to data files named, eg, LovelyNN.BF Use FontSet convertFontsNamed: 'Lovely' to produce a FontSet named Lovely. FileOut that FontSet for later use. Use Lovely installAsTextStyle to make all sizes available in a TextStyle named #Lovely in the TextConstants dictionary. Use ctrl-k in any text pane to select the new Lovely style for that paragraph. Then use cmd-1 through 5 or cmd-k to set the point-size for any selection. ! !FontSet class methodsFor: 'private' stamp: 'sma 12/29/1999 12:58'! fontCategory ^ 'Graphics-Fonts' asSymbol! ! !FontSet class methodsFor: 'converting' stamp: 'lr 7/4/2009 10:42'! convertTextStyleNamed: aString | style fontSet | (style := TextStyle named: aString) ifNil: [ ^ self error: 'unknown text style ' , aString ]. fontSet := self fontSetClass: aString. style fontArray do: [ :each | fontSet compileFont: each ]! ! !FontSet class methodsFor: 'compiling' stamp: 'sma 12/29/1999 11:48'! acceptsLoggingOfCompilation "Dont log sources for my subclasses, so as not to waste time and space storing printString versions of the string literals." ^ self == FontSet! ! !FontSet class methodsFor: 'installing' stamp: 'BenjaminVanRyseghem 11/28/2010 19:02'! installAsTextStyle "FontSetNewYork installAsTextStyle" | selectors | (TextSharedInformation includesKey: self fontName) ifTrue: [ (self confirm: self fontName , ' is already defined in TextSharedInformation. Do you want to replace that definition?') ifFalse: [ ^ self ] ]. selectors := (self class selectors select: [ :s | s beginsWith: 'size' ]) asSortedCollection. TextSharedInformation at: self fontName put: (TextStyle fontArray: (selectors collect: [ :each | self perform: each ]))! ! !FontSet class methodsFor: 'installing' stamp: 'di 1/24/2005 11:13'! fontNamed: fontName fromMimeLiteral: aString "This method allows a font set to be captured as sourcecode in a subclass. The string literals will presumably be created by printing, eg, (FileStream readOnlyFileNamed: 'Palatino24.sf2') contentsOfEntireFile, and following the logic in compileFont: to encode and add a heading. See the method installAsTextStyle to see how this can be used." ^ StrikeFont new name: fontName; readFromStrike2Stream: (Base64MimeConverter mimeDecodeToBytes: aString readStream)! ! !FontSet class methodsFor: 'converting' stamp: 'CamilloBruni 5/4/2012 20:17'! convertFontsNamed: familyName inDirectoryNamed: dirName "FontSet convertFontsNamed: 'Tekton' inDirectoryNamed: 'Tekton Fonts' " "This utility is for use after you have used BitFont to produce data files for the fonts you wish to use. It will read the BitFont files and build a fontset class from them. If one already exists, the sizes that can be found will be overwritten." "For this utility to work as is, the BitFont data files must be named 'familyNN.BF', and must reside in the directory named by dirName (use '' for the current directory)." "Check first for matching file names and usable FontSet class name." | allFontNames fontSet dir | dir := FileSystem disk workingDirectory. dirName isEmpty ifFalse: [ dir := dir / dirName ]. allFontNames := dir files select: [ :file| familyName , '..\.BF' matches: file basename]. allFontNames isEmpty ifTrue: [ ^ self error: 'No files found like ' , familyName , 'NN.BF' ]. fontSet := self fontSetClass: familyName. allFontNames do: [ :each | Transcript cr; show: each. fontSet compileFont: (StrikeFont new readFromBitFont: (dir / each) fullName) ]! ! !FontSet class methodsFor: 'as yet unclassified' stamp: 'di 9/15/97 12:01'! convertFontsNamed: familyName "FontSet convertFontsNamed: 'Palatino' " ^ self convertFontsNamed: familyName inDirectoryNamed: ''! ! !FontSet class methodsFor: 'private' stamp: 'ClementBera 6/13/2013 15:23'! fontName ^ self name asSymbol! ! !FontSet class methodsFor: 'compiling' stamp: 'CamilloBruni 5/4/2012 20:11'! compileFont: strikeFont | tempName literalString header sizeStr familyName | tempName := 'FontTemp.sf2'. strikeFont writeAsStrike2named: tempName. literalString := (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: tempName) binary) contents fullPrintString. sizeStr := strikeFont pointSize asString. familyName := strikeFont name first: (strikeFont name findLast: [ :x | x isDigit not ]). header := 'size' , sizeStr , ' ^ self fontNamed: ''' , familyName , sizeStr , ''' fromMimeLiteral: '. self class compile: header , literalString classified: 'fonts' notifying: nil. (FileSystem root workingDirectory / tempName) delete.! ! !FontSet class methodsFor: 'filein/out' stamp: 'sma 12/29/1999 11:49'! fileOut "FileOut and then change the properties of the file so that it won't be treated as text by, eg, email attachment facilities" super fileOut. (FileStream oldFileNamed: self name , '.st') setFileTypeToObject; close! ! !FontSet class methodsFor: 'installing' stamp: 'BenjaminVanRyseghem 11/28/2010 19:02'! installAsDefault "FontSetNewYork installAsDefault" (self confirm: 'Do you want to install' translated, ' ''' , self fontName , ''' as default font?' translated) ifFalse: [^ self]. self installAsTextStyle. TextSharedInformation at: #DefaultTextStyle put: (TextStyle named: self fontName). ! ! !FontSet class methodsFor: 'private' stamp: 'simon.denier 6/11/2010 14:33'! fontSetClass: aString | className fontSet | className := (self name , (aString select: [ :c | c isAlphaNumeric ]) capitalized) asSymbol. fontSet := Smalltalk globals at: className ifAbsentPut: [ self subclass: className instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self fontCategory ]. (fontSet inheritsFrom: self) ifFalse: [ ^ self error: 'The name ' , className , ' is already in use' ]. ^ fontSet! ! !FontSubstitutionDuringLoading commentStamp: ''! signaled by font loading code when reading a DiskProxy that calls for a missing font.! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! pixelSize "Answer the value of pixelSize" ^ pixelSize! ! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! pixelSize: anObject "Set the value of pixelSize" pixelSize := anObject! ! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'AlainPlantec 11/29/2009 21:33'! defaultAction familyName ifNil: [ familyName := 'NoName' ]. pixelSize ifNil: [ pixelSize := 12 ]. ^((familyName beginsWith: 'Comic') ifTrue: [ TextStyle named: (StandardFonts buttonFont familyName) ] ifFalse: [ TextStyle default ]) fontOfSize: pixelSize.! ! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! familyName: anObject "Set the value of familyName" familyName := anObject! ! !FontSubstitutionDuringLoading methodsFor: 'printing' stamp: 'nk 11/8/2004 16:55'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: familyName; nextPut: $-; print: pixelSize; nextPut: $).! ! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! familyName "Answer the value of familyName" ^ familyName! ! !FontSubstitutionDuringLoading class methodsFor: 'instance creation' stamp: 'nk 11/8/2004 15:07'! forFamilyName: aName pixelSize: aSize ^(self new) familyName: aName; pixelSize: aSize; yourself.! ! !FontTest commentStamp: 'tak 3/11/2005 14:31'! I am mainly a test for fallback font. FontTest buildSuite run! !FontTest methodsFor: 'testing' stamp: 'AlainPlantec 9/15/2011 17:26'! testParagraph "self debug: #testParagraph" | text p style height width | text := 'test' asText. p := Paragraph new. style := TextStyle default. p compose: text style: style from: 1 in: (0 @ 0 corner: 100 @ 100). "See CompositionScanner>>setActualFont: & CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:" height := style defaultFont height + style leading. width := text inject: 0 into: [:tally :next | tally + (style defaultFont widthOf: next)]. p adjustRightX. self assert: p extent = (width @ height)! ! !FontTest methodsFor: 'testing' stamp: 'sd 2/4/2008 21:10'! testDisplay "self debug: #testDisplay" | text font bb destPoint width | text := 'test' asText. font := TextStyle default fontOfSize: 21. text addAttribute: (TextFontReference toFont: font). bb := (Form extent: 100 @ 30) getCanvas privatePort. bb combinationRule: Form paint. font installOn: bb foregroundColor: Color black backgroundColor: Color white. destPoint := font displayString: text on: bb from: 1 to: 4 at: 0@0 kern: 1. width := text inject: 0 into: [:max :char | max + (font widthOf: char)]. self assert: destPoint x = (width + 4). "bb destForm asMorph openInHand." ! ! !FontTest methodsFor: '*Multilingual-OtherLanguages' stamp: 'AlainPlantec 9/15/2011 17:26'! testMultistringFont "self debug: #testMultistringFont" | text p style height width | [(TextStyle default fontArray at: JapaneseEnvironment leadingChar) ifNil: [^ self]] ifError: [ ^ self]. text := ((#(20983874 20983876 20983878 ) collect: [:e | e asCharacter]) as: String) asText. p := Paragraph new. style := TextStyle default. p compose: text style: style from: 1 in: (0 @ 0 corner: 100 @ 100). "See CompositionScanner>>setActualFont: & CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:" height := style defaultFont height + style leading. width := text inject: 0 into: [:tally :next | tally + (style defaultFont widthOf: next)]. p adjustRightX. self assert: p extent = (width @ height). "Display getCanvas paragraph: p bounds: (10 @ 10 extent: 100 @ 100) color: Color black"! ! !FooSharedPool commentStamp: 'NicoPaez 10/17/2010 14:44'! Just a class for testing.! !Form commentStamp: 'ls 1/4/2004 17:16'! A rectangular array of pixels, used for holding images. All pictures, including character images are Forms. The depth of a Form is how many bits are used to specify the color at each pixel. The actual bits are held in a Bitmap, whose internal structure is different at each depth. Class Color allows you to deal with colors without knowing how they are actually encoded inside a Bitmap. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. Forms are indexed starting at 0 instead of 1; thus, the top-left pixel of a Form has coordinates 0@0. Forms are combined using BitBlt. See the comment in class BitBlt. Forms that repeat many times to fill a large destination are InfiniteForms. colorAt: x@y Returns the abstract Color at this location displayAt: x@y shows this form on the screen displayOn: aMedium at: x@y shows this form in a Window, a Form, or other DisplayMedium fillColor: aColor Set all the pixels to the color. edit launch an editor to change the bits of this form. pixelValueAt: x@y The encoded color. The encoding depends on the depth. ! !Form methodsFor: 'other' stamp: 'ar 12/12/2003 18:24'! fixAlpha "Fix the alpha channel if the receiver is 32bit" | bb | self depth = 32 ifFalse:[^self]. bb := BitBlt toForm: self. bb combinationRule: 40 "fixAlpha:with:". bb copyBits.! ! !Form methodsFor: 'other' stamp: 'bf 8/17/2009 13:08'! preMultiplyAlpha "Pre-multiply each pixel by its alpha, for proper alpha compositing (BitBlt rule 34). E.g., half-transparent green 16r7F00FF00 becomes 16r7F007F00" depth = 32 ifFalse: [^self]. 1 to: bits size do: [:i | | v a r g b | v := bits at: i. a := v bitShift: -24. r := ((v bitShift: -16) bitAnd: 255) * a // 255. g := ((v bitShift: -8) bitAnd: 255) * a // 255. b := (v bitAnd: 255) * a // 255. bits at: i put: (a bitShift: 24) + (r bitShift: 16) + (g bitShift: 8) + b].! ! !Form methodsFor: 'filling' stamp: 'CamilloBruni 8/1/2012 16:01'! bitPatternForDepth: suspectedDepth "Only called when a Form is being used as a fillColor. Use a Pattern or InfiniteForm instead for this purpose. Interpret me as an array of (32/depth) Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary." ^ self! ! !Form methodsFor: 'transitions' stamp: 'Jb 11/19/2010 16:29'! fadeImageSquares: otherImage at: topLeft "Display fadeImageSquares: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: [:i :mask | mask fill: ((16-i) asPoint extent: (i*2) asPoint) fillColor: Color black. i <= 16]! ! !Form methodsFor: '*Morphic-Base-Support' stamp: 'LB 8/26/2002 18:08'! stencil "return a 1-bit deep, black-and-white stencil of myself" | canvas | canvas := FormCanvas extent: self extent depth: 1. canvas fillColor: (Color white). canvas stencil: self at: 0@0 sourceRect: (Rectangle origin: 0@0 corner: self extent) color: Color black. ^ canvas form ! ! !Form methodsFor: 'analyzing' stamp: 'StephaneDucasse 10/25/2013 16:14'! rectangleEnclosingPixelsNotOfColor: aColor "Answer the smallest rectangle enclosing all the pixels of me that are different from the given color. Useful for extracting a foreground graphic from its background." | cm slice copyBlt countBlt top bottom newH left right | "map the specified color to 1 and all others to 0" cm := Bitmap new: (1 bitShift: (self depth min: 15)). cm primFill: 1. cm at: (aColor indexInMap: cm) put: 0. "build a 1-pixel high horizontal slice and BitBlts for counting pixels of interest" slice := Form extent: width@1 depth: 1. copyBlt := (BitBlt toForm: slice) sourceForm: self; combinationRule: Form over; destX: 0 destY: 0 width: width height: 1; colorMap: cm. countBlt := (BitBlt toForm: slice) fillColor: (Bitmap with: 0); destRect: (0@0 extent: slice extent); combinationRule: 32. "scan in from top and bottom" top := (0 to: height) detect: [:y | copyBlt sourceOrigin: 0@y; copyBits. countBlt copyBits > 0] ifNone: [^ 0@0 extent: 0@0]. bottom := (height - 1 to: top by: -1) detect: [:y | copyBlt sourceOrigin: 0@y; copyBits. countBlt copyBits > 0]. "build a 1-pixel wide vertical slice and BitBlts for counting pixels of interest" newH := bottom - top + 1. slice := Form extent: 1@newH depth: 1. copyBlt := (BitBlt current toForm: slice) sourceForm: self; combinationRule: Form over; destX: 0 destY: 0 width: 1 height: newH; colorMap: cm. countBlt := (BitBlt current toForm: slice) fillColor: (Bitmap with: 0); destRect: (0@0 extent: slice extent); combinationRule: 32. "scan in from left and right" left := (0 to: width) detect: [:x | copyBlt sourceOrigin: x@top; copyBits. countBlt copyBits > 0]. right := (width - 1 to: left by: -1) detect: [:x | copyBlt sourceOrigin: x@top; copyBits. countBlt copyBits > 0]. ^ left@top corner: (right + 1)@(bottom + 1) ! ! !Form methodsFor: 'displaying' stamp: 'ar 5/14/2001 23:33'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm aDisplayMedium copyBits: self boundingBox from: self at: aDisplayPoint + self offset clippingBox: clipRectangle rule: rule fillColor: aForm map: (self colormapIfNeededFor: aDisplayMedium). ! ! !Form methodsFor: 'color mapping' stamp: 'FernandoOlivero 9/9/2013 19:40'! balancedPatternFor: aColor depth: aDepth "A generalization of bitPatternForDepth: as it exists. Generates a 2x2 stipple of color. The topLeft and bottomRight pixel are closest approx to this color" | pv1 pv2 mask1 mask2 pv3 c | aColor isTransparent ifTrue:[ ^ Bitmap with: 0 ]. (depth between: 4 and: 16) ifFalse: [ ^ aColor bitPatternForDepth: depth ]. pv1 := aColor pixelValueForDepth: depth. " Subtract error due to pv1 to get pv2. pv2 := (self - (err1 := (Color colorFromPixelValue: pv1 depth: depth) - self)) pixelValueForDepth: depth. Subtract error due to 2 pv1's and pv2 to get pv3. pv3 := (self - err1 - err1 - ((Color colorFromPixelValue: pv2 depth: depth) - self)) pixelValueForDepth: depth. " "Above two statements computed faster by the following..." pv2 := (c := aColor - ((Color colorFromPixelValue: pv1 depth: depth) - aColor)) pixelValueForDepth: depth. pv3 := c + (c - (Color colorFromPixelValue: pv2 depth: depth)) pixelValueForDepth: depth. "Return to a 2-word bitmap that encodes a 2x2 stipple of the given pixelValues." mask1 := #( #- #- #- 16843009 #- #- #- 65537 #- #- #- #- #- #- #- 1 ) at: depth. "replicates every other 4 bits" "replicates every other 8 bits" "replicates every other 16 bits" mask2 := #( #- #- #- 269488144 #- #- #- 16777472 #- #- #- #- #- #- #- 65536 ) at: depth. "replicates the other 4 bits" "replicates the other 8 bits" "replicates the other 16 bits" ^ Bitmap with: mask1 * pv1 + (mask2 * pv2) with: mask1 * pv3 + (mask2 * pv1). ! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! bitPatternFor: aColor "Return the pixel word for representing the given color on the receiver" aColor isColor ifFalse:[^aColor bitPatternForDepth: self depth]. self hasNonStandardPalette ifTrue:[^Bitmap with: (self pixelWordFor: aColor)] ifFalse:[^aColor bitPatternForDepth: self depth]! ! !Form methodsFor: 'filein/out' stamp: ''! storeBits:startBit to:stopBit on:aStream bits storeBits:startBit to:stopBit on:aStream.! ! !Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'! isBltAccelerated: ruleInteger for: sourceForm "Return true if the receiver can perform accelerated blts operations by itself" ^false! ! !Form methodsFor: 'image manipulation' stamp: 'StephaneDucasse 10/25/2013 16:14'! replaceColor: oldColor withColor: newColor "Replace one color with another everywhere is this form" | cm newInd target ff | self depth = 32 ifTrue: [cm := (Color cachedColormapFrom: 16 to: 32) copy] ifFalse: [cm := Bitmap new: (1 bitShift: (self depth min: 15)). 1 to: cm size do: [:i | cm at: i put: i - 1]]. newInd := newColor pixelValueForDepth: self depth. cm at: (oldColor pixelValueForDepth: (self depth min: 16))+1 put: newInd. target := newColor isTransparent ifTrue: [ff := Form extent: self extent depth: depth. ff fillWithColor: newColor. ff] ifFalse: [self]. (BitBlt toForm: target) sourceForm: self; sourceOrigin: 0@0; combinationRule: Form paint; destX: 0 destY: 0 width: width height: height; colorMap: cm; copyBits. newColor = Color transparent ifTrue: [target displayOn: self].! ! !Form methodsFor: 'testing' stamp: 'ar 5/15/2001 16:14'! hasNonStandardPalette "Return true if the receiver has a non-standard palette. Non-standard means that RGBA components may be located at positions differing from the standard Squeak RGBA layout at the receiver's depth." ^false! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:42'! colormapIfNeededForDepth: destDepth "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." self depth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" ^ Color colorMapIfNeededFrom: self depth to: destDepth ! ! !Form methodsFor: 'scaling, rotation' stamp: 'ar 5/14/2001 23:33'! flipBy: direction centerAt: aPoint "Return a copy of the receiver flipped either #vertical or #horizontal." | newForm quad | newForm := self class extent: self extent depth: depth. quad := self boundingBox innerCorners. quad := (direction = #vertical ifTrue: [#(2 1 4 3)] ifFalse: [#(4 3 2 1)]) collect: [:i | quad at: i]. (WarpBlt current toForm: newForm) sourceForm: self; colorMap: (self colormapIfNeededFor: newForm); combinationRule: 3; copyQuad: quad toRect: newForm boundingBox. newForm offset: (self offset flipBy: direction centerAt: aPoint). ^ newForm " [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) flipBy: #vertical centerAt: 0@0) display] " "Consistency test... | f f2 p | [Sensor anyButtonPressed] whileFalse: [f := Form fromDisplay: ((p := Sensor cursorPoint) extent: 31@41). Display fillBlack: (p extent: 31@41). f2 := f flipBy: #vertical centerAt: 0@0. (f2 flipBy: #vertical centerAt: 0@0) displayAt: p] " ! ! !Form methodsFor: 'transitions' stamp: 'jm 10/16/97 15:21'! wipeImage: otherImage at: topLeft delta: delta "Display wipeImage: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40 delta: 0@-2" self wipeImage: otherImage at: topLeft delta: delta clippingBox: nil. ! ! !Form methodsFor: 'testing' stamp: 'ar 7/21/2007 21:37'! isAllWhite "Answer whether all bits in the receiver are white" | word | self unhibernate. word := Color white pixelWordForDepth: self depth. 1 to: bits size do: [:i | (bits at: i) = word ifFalse: [^ false]]. ^ true! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/16/2001 22:23'! colormapIfNeededFor: destForm "Return a ColorMap mapping from the receiver to destForm." (self hasNonStandardPalette or:[destForm hasNonStandardPalette]) ifTrue:[^self colormapFromARGB mappingTo: destForm colormapFromARGB] ifFalse:[^self colormapIfNeededForDepth: destForm depth]! ! !Form methodsFor: 'initialization' stamp: 'ar 5/28/2000 18:45'! shutDown "The system is going down. Try to preserve some space" self hibernate! ! !Form methodsFor: 'filling' stamp: 'StephaneDucasse 10/25/2013 16:13'! eraseShape: bwForm "use bwForm as a mask to clear all pixels where bwForm has 1's" ((BitBlt destForm: self sourceForm: bwForm fillColor: nil combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" destOrigin: bwForm offset sourceOrigin: 0@0 extent: self extent clipRect: self boundingBox) colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) copyBits. ! ! !Form methodsFor: 'transitions' stamp: 'di 3/2/98 09:15'! zoomOutTo: otherImage at: topLeft "Display zoomOutTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" ^ self zoomIn: false orOutTo: otherImage at: topLeft vanishingPoint: otherImage extent//2+topLeft! ! !Form methodsFor: 'transitions' stamp: 'nice 1/5/2010 15:59'! zoomIn: goingIn orOutTo: otherImage at: topLeft vanishingPoint: vp "Display zoomInTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40. Display zoomOutTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40." | nSteps minTime startTime | nSteps := 16. minTime := 500. "milliseconds" startTime := Time millisecondClockValue. ^ self wipeImage: otherImage at: topLeft clippingBox: nil rectForIndex: [:i | | bigR j lilR lead | "i runs from 1 to nsteps" i > nSteps ifTrue: [nil "indicates all done"] ifFalse: ["If we are going too fast, delay for a bit" lead := startTime + (i-1*minTime//nSteps) - Time millisecondClockValue. lead > 10 ifTrue: [(Delay forMilliseconds: lead) wait]. "Return an array with the difference rectangles for this step." j := goingIn ifTrue: [i] ifFalse: [nSteps+1-i]. bigR := vp - (vp*(j)//nSteps) corner: vp + (otherImage extent-vp*(j)//nSteps). lilR := vp - (vp*(j-1)//nSteps) corner: vp + (otherImage extent-vp*(j-1)//nSteps). bigR areasOutside: lilR]]! ! !Form methodsFor: '*Morphic-Base' stamp: 'ar 7/8/2006 21:01'! iconOrThumbnailOfSize: aNumberOrPoint "Answer an appropiate form to represent the receiver" ^ self scaledIntoFormOfSize: aNumberOrPoint! ! !Form methodsFor: 'filein/out' stamp: 'ar 2/24/2001 22:39'! replaceByResource: aForm "Replace the receiver by some resource that just got loaded" (self extent = aForm extent and:[self depth = aForm depth]) ifTrue:[ bits := aForm bits. ].! ! !Form methodsFor: 'filein/out' stamp: 'laza 3/29/2004 12:21'! storeBitsOn:aStream base:anInteger bits do: [:word | anInteger = 10 ifTrue: [aStream space] ifFalse: [aStream crtab: 2]. word storeOn: aStream base: anInteger]. ! ! !Form methodsFor: 'transitions' stamp: 'di 3/2/98 09:14'! zoomInTo: otherImage at: topLeft "Display zoomInTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" ^ self zoomIn: true orOutTo: otherImage at: topLeft vanishingPoint: otherImage extent//2+topLeft! ! !Form methodsFor: 'analyzing' stamp: 'StephaneDucasse 10/25/2013 16:16'! xTallyPixelValue: pv orNot: not "Return an array of the number of pixels with value pv by x-value. Note that if not is true, then this will tally those different from pv." | cm slice countBlt copyBlt | cm := self newColorMap. "Map all colors but pv to zero" not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" cm at: pv+1 put: 1 - (cm at: pv+1). slice := Form extent: 1@height. copyBlt := (BitBlt destForm: slice sourceForm: self halftoneForm: nil combinationRule: Form over destOrigin: 0@0 sourceOrigin: 0@0 extent: 1 @ slice height clipRect: slice boundingBox) colorMap: cm. countBlt := (BitBlt toForm: slice) fillColor: (Bitmap with: 0); destRect: (0@0 extent: slice extent); combinationRule: 32. ^ (0 to: width-1) collect: [:x | copyBlt sourceOrigin: x@0; copyBits. countBlt copyBits]! ! !Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:39'! isTransparentAt: aPoint "Return true if the receiver is transparent at the given point." self depth = 1 ifTrue: [^ false]. "no transparency at depth 1" ^ (self pixelValueAt: aPoint) = (self pixelValueFor: Color transparent) ! ! !Form methodsFor: 'private' stamp: 'tk 3/13/2000 15:21'! hackBits: bitThing "This method provides an initialization so that BitBlt may be used, eg, to copy ByteArrays and other non-pointer objects efficiently. The resulting form looks 4 wide, 8 deep, and bitThing-size-in-words high." width := 4. depth := 8. bitThing class isBits ifFalse: [self error: 'bitThing must be a non-pointer object']. bitThing class isBytes ifTrue: [height := bitThing basicSize // 4] ifFalse: [height := bitThing basicSize]. bits := bitThing! ! !Form methodsFor: '*Graphics-Files' stamp: 'sw 2/20/2002 15:37'! writeJPEGfileNamed: fileName "Write a JPEG file to the given filename using default settings" self writeJPEGfileNamed: fileName progressive: false " Display writeJPEGfileNamed: 'display.jpeg' Form fromUser writeJPEGfileNamed: 'yourPatch.jpeg' "! ! !Form methodsFor: 'filein/out' stamp: ''! storeOn: aStream base: anInteger "Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original." self unhibernate. aStream nextPut: $(. aStream nextPutAll: self species name. aStream crtab: 1. aStream nextPutAll: 'extent: '. self extent printOn: aStream. aStream crtab: 1. aStream nextPutAll: 'depth: '. self depth printOn: aStream. aStream crtab: 1. aStream nextPutAll: 'fromArray: #('. self storeBitsOn:aStream base:anInteger. aStream nextPut: $). aStream crtab: 1. aStream nextPutAll: 'offset: '. self offset printOn: aStream. aStream nextPut: $). ! ! !Form methodsFor: 'pixel access' stamp: 'StephaneDucasse 10/25/2013 16:14'! pixelValueAt: aPoint put: pixelValue "Store the given raw pixel value at the given point. Typical clients use colorAt:put: to store a color. " (BitBlt bitPokerToForm: self) pixelAt: aPoint put: pixelValue. ! ! !Form methodsFor: '*Morphic-Base' stamp: 'AlainPlantec 12/10/2009 11:07'! floodFillTolerance ^ self class floodFillTolerance! ! !Form methodsFor: '*Polymorph-Widgets-Themes' stamp: 'EstebanLorenzano 5/10/2013 14:56'! mergeWith: aForm ^ self mergeWith: aForm at: 0@0! ! !Form methodsFor: 'transitions' stamp: 'jm 5/21/1998 23:46'! slideImage: otherImage at: topLeft delta: delta "Display slideImage: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40 delta: 3@-4" | bb nSteps clipRect | bb := otherImage boundingBox. clipRect := topLeft extent: otherImage extent. nSteps := 1. delta x = 0 ifFalse: [nSteps := nSteps max: (bb width//delta x abs) + 1]. delta y = 0 ifFalse: [nSteps := nSteps max: (bb height//delta y abs) + 1]. 1 to: nSteps do: [:i | self copyBits: bb from: otherImage at: delta*(i-nSteps) + topLeft clippingBox: clipRect rule: Form paint fillColor: nil. Display forceDisplayUpdate]! ! !Form methodsFor: 'initialization' stamp: 'ar 5/26/2000 00:46'! finish "If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."! ! !Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45'! depth ^ depth < 0 ifTrue:[0-depth] ifFalse:[depth]! ! !Form methodsFor: 'accessing' stamp: 'ar 5/27/2000 16:56'! displayScreen "Return the display screen the receiver is allocated on. Forms in general are Squeak internal and not allocated on any particular display." ^nil! ! !Form methodsFor: 'color mapping' stamp: 'FernandoOlivero 9/9/2013 19:41'! balancedPatternFor: aColor "Return the pixel word for representing the given color on the receiver" self hasNonStandardPalette ifTrue:[ ^ self bitPatternFor: aColor] ifFalse:[^ self balancedPatternFor: aColor depth: self depth]! ! !Form methodsFor: 'converting' stamp: 'HenrikSperreJohansen 5/26/2010 15:59'! dimmed: factor "Answer a dimmed variant of this form. factor in a float between 0 and 1" "(Form fromUser dimmed: 0.6) asMorph openInWorld" ^ self collectColors: [ :color | color alpha: (color alpha min: factor)]! ! !Form methodsFor: 'other' stamp: 'ar 4/30/2008 12:18'! fillAlpha: alphaValue "Fill a 32bit form with a constant alpha value" | bb | self depth = 32 ifFalse:[^self error: 'Only valid for 32 bit forms']. bb := BitBlt toForm: self. bb combinationRule: 7. "bitOr:with:". bb fillColor: (Bitmap with: alphaValue << 24). bb copyBits. ! ! !Form methodsFor: 'converting' stamp: 'StephaneDucasse 10/25/2013 16:12'! asFormOfDepth: d | newForm | d = self depth ifTrue:[^self]. newForm := Form extent: self extent depth: d. (BitBlt toForm: newForm) colorMap: (self colormapIfNeededFor: newForm); copy: (self boundingBox) from: 0@0 in: self fillColor: nil rule: Form over. "Special case: For a 16 -> 32 bit conversion fill the alpha channel because it gets lost in translation." (self depth = 16 and:[d= 32]) ifTrue:[newForm fillAlpha: 255]. ^newForm! ! !Form methodsFor: 'filein/out' stamp: 'nice 1/5/2010 15:59'! store15To24HexBitsOn:aStream | buf lineWidth | "write data for 16-bit form, optimized for encoders writing directly to files to do one single file write rather than 12. I'm not sure I understand the significance of the shifting pattern, but I think I faithfully translated it from the original" lineWidth := 0. buf := String new: 12. bits do: [:word | | i | i := 0. "upper pixel" buf at: (i := i + 1) put: ((word bitShift: -27) bitAnd: 15) asHexDigit. buf at: (i := i + 1) put: ((word bitShift: -32) bitAnd: 8) asHexDigit. buf at: (i := i + 1) put: ((word bitShift: -22) bitAnd: 15) asHexDigit. buf at: (i := i + 1) put: ((word bitShift: -27) bitAnd: 8) asHexDigit. buf at: (i := i + 1) put: ((word bitShift: -17) bitAnd: 15) asHexDigit. buf at: (i := i + 1) put: ((word bitShift: -22) bitAnd: 8) asHexDigit. "lower pixel" buf at: (i := i + 1) put: ((word bitShift: -11) bitAnd: 15) asHexDigit. buf at: (i := i + 1) put: ((word bitShift: -16) bitAnd: 8) asHexDigit. buf at: (i := i + 1) put: ((word bitShift: -6) bitAnd: 15) asHexDigit. buf at: (i := i + 1) put: ((word bitShift: -11) bitAnd: 8) asHexDigit. buf at: (i := i + 1) put: ((word bitShift: -1) bitAnd: 15) asHexDigit. buf at: (i := i + 1) put: ((word bitShift: -6) bitAnd: 8) asHexDigit. aStream nextPutAll: buf. lineWidth := lineWidth + 12. lineWidth > 100 ifTrue: [ aStream cr. lineWidth := 0 ]. "#( 31 26 21 15 10 5 ) do:[:startBit | ]" ].! ! !Form methodsFor: 'converting' stamp: 'HenrikSperreJohansen 5/26/2010 16:00'! darker: aFactor "Answer a darker variant of this form. aFactor is a float between 0 and 1 representing the strength of the darkening." "(Form fromUser darker: 0.08) asMorph openInWorld" "(Form fromUser darker: 0.16) asMorph openInWorld" ^ self collectColors: [ :color | color adjustBrightness: aFactor negated]! ! !Form methodsFor: 'accessing' stamp: ''! height ^ height! ! !Form methodsFor: '*Graphics-Files' stamp: 'MarianoMartinezPeck 3/24/2010 21:13'! writeJPEGfileNamed: fileName progressive: aBoolean "Write a JPEG file to the given filename using default settings. Make it progressive or not, depending on the boolean argument" PluginBasedJPEGReadWriter putForm: self quality: -1 "default" progressiveJPEG: aBoolean onFileNamed: fileName " Display writeJPEGfileNamed: 'display.jpeg' progressive: false. Form fromUser writeJPEGfileNamed: 'yourPatch.jpeg' progressive: true "! ! !Form methodsFor: 'copying' stamp: 'StephaneDucasse 10/25/2013 16:13'! copyBits: sourceRect from: sourceForm at: destOrigin colorMap: map "Make up a BitBlt table and copy the bits with the given colorMap." ((BitBlt destForm: self sourceForm: sourceForm halftoneForm: nil combinationRule: Form over destOrigin: destOrigin sourceOrigin: sourceRect origin extent: sourceRect extent clipRect: self boundingBox) colorMap: map) copyBits! ! !Form methodsFor: '*Morphic-Base' stamp: 'StephaneDucasse 5/23/2013 18:34'! asMorph ^ImageMorph new form: self! ! !Form methodsFor: 'filein/out' stamp: 'tk 2/19/1999 07:30'! writeUncompressedOn: file "Write the receiver on the file in the format depth, extent, offset, bits. Warning: Caller must put header info on file!! Use writeUncompressedOnFileNamed: instead." self unhibernate. file binary. file nextPut: depth. file nextWordPut: width. file nextWordPut: height. file nextWordPut: ((self offset x) >=0 ifTrue: [self offset x] ifFalse: [self offset x + 65536]). file nextWordPut: ((self offset y) >=0 ifTrue: [self offset y] ifFalse: [self offset y + 65536]). bits writeUncompressedOn: file! ! !Form methodsFor: 'color mapping' stamp: 'di 10/16/2001 15:23'! reducedPaletteOfSize: nColors "Return an array of colors of size nColors, such that those colors represent well the pixel values actually found in this form." | threshold tallies colorTallies dist delta palette cts top cluster | tallies := self tallyPixelValues. "An array of tallies for each pixel value" threshold := width * height // 500. "Make an array of (color -> tally) for all tallies over threshold" colorTallies := Array streamContents: [:s | tallies withIndexDo: [:v :i | v >= threshold ifTrue: [s nextPut: (Color colorFromPixelValue: i-1 depth: depth) -> v]]]. "Extract a set of clusters by picking the top tally, and then removing all others whose color is within dist of it. Iterate the process, adjusting dist until we get nColors." dist := 0.2. delta := dist / 2. [cts := colorTallies copy. palette := Array streamContents: [:s | [cts isEmpty] whileFalse: [top := cts detectMax: [:a | a value]. cluster := cts select: [:a | (a key diff: top key) < dist]. s nextPut: top key -> (cluster detectSum: [:a | a value]). cts := cts copyWithoutAll: cluster]]. palette size = nColors or: [delta < 0.001]] whileFalse: [palette size > nColors ifTrue: [dist := dist + delta] ifFalse: [dist := dist - delta]. delta := delta / 2]. ^ palette collect: [:a | a key] ! ! !Form methodsFor: '*Morphic-Base' stamp: 'ar 7/8/2006 21:01'! scaledIntoFormOfSize: aNumberOrPoint "Scale and center the receiver into a form of a given size" | extent scale scaledForm result | extent := aNumberOrPoint asPoint. extent = self extent ifTrue: [^ self]. (self height isZero or: [self width isZero]) ifTrue: [^ Form extent: extent depth: self depth]. scale := extent y / self height min: extent x / self width. scaledForm := self magnify: self boundingBox by: scale smoothing: 8. result := Form extent: extent depth: 32. result getCanvas translucentImage: scaledForm at: extent - scaledForm extent // 2. ^ result ! ! !Form methodsFor: 'initialization' stamp: 'ar 5/17/2001 22:54'! allocateForm: extentPoint "Allocate a new form which is similar to the receiver and can be used for accelerated blts" ^Form extent: extentPoint depth: self nativeDepth! ! !Form methodsFor: 'copying' stamp: 'ar 6/9/2000 19:00'! contentsOfArea: aRect into: newForm "Return a new form which derives from the portion of the original form delineated by aRect." ^ newForm copyBits: aRect from: self at: 0@0 clippingBox: newForm boundingBox rule: Form over fillColor: nil! ! !Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:35'! writeBitsOn: file bits writeOn: file! ! !Form methodsFor: 'testing' stamp: 'ar 5/28/2000 15:04'! isDisplayScreen ^false! ! !Form methodsFor: 'converting' stamp: 'ar 3/28/2010 15:34'! collectColors: aBlock "Create a new copy of the receiver with all the colors transformed by aBlock" ^self collectPixels:[:pv| (aBlock value: (Color colorFromPixelValue: pv depth: self depth)) pixelValueForDepth: self depth. ].! ! !Form methodsFor: 'color mapping' stamp: ''! makeBWForm: foregroundColor "Map this form into a B/W form with 1's in the foreground regions." | bwForm map | bwForm := Form extent: self extent. map := self newColorMap. "All non-foreground go to 0's" map at: (foregroundColor indexInMap: map) put: 1. bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map. ^ bwForm! ! !Form methodsFor: '*Polymorph-Widgets-Themes' stamp: 'EstebanLorenzano 5/14/2013 09:43'! setAsBackground "Set this form as a background image." | world | world := self currentWorld. world backgroundMorph: ((Smalltalk ui theme builder newAlphaImage: self help: nil) autoSize: false; layout: #scaled; lock) ! ! !Form methodsFor: 'accessing' stamp: ''! bits "Answer the receiver's Bitmap containing its bits." ^ bits! ! !Form methodsFor: 'other' stamp: 'RAA 1/30/2002 16:42'! relativeTextAnchorPosition ^nil "so forms can be in TextAnchors"! ! !Form methodsFor: 'converting' stamp: 'StephaneDucasse 3/27/2010 21:09'! dimmed "Answer a dimmed variant of this form." "Form fromUser dimmed asMorph openInWorld" ^ self dimmed: 0.5! ! !Form methodsFor: 'copying' stamp: 'StephaneDucasse 10/25/2013 16:13'! copy: destRectangle from: sourcePt in: sourceForm rule: rule "Make up a BitBlt table and copy the bits." (BitBlt toForm: self) copy: destRectangle from: sourcePt in: sourceForm fillColor: nil rule: rule! ! !Form methodsFor: 'converting' stamp: 'ClementBera 7/26/2013 16:40'! colorReduced "Return a color-reduced ColorForm version of the receiver, if possible, or the receiver itself if not." | tally tallyDepth colorCount newForm cm oldPixelValues newFormColors nextColorIndex c | tally := self tallyPixelValues asArray. tallyDepth := (tally size log: 2) asInteger. colorCount := 0. tally do: [:n | n > 0 ifTrue: [colorCount := colorCount + 1]]. (tally at: 1) = 0 ifTrue: [colorCount := colorCount + 1]. "include transparent" colorCount > 256 ifTrue: [^ self]. "cannot reduce" newForm := self formForColorCount: colorCount. "build an array of just the colors used, and a color map to translate old pixel values to their indices into this color array" cm := Bitmap new: tally size. oldPixelValues := self colormapIfNeededForDepth: 32. newFormColors := Array new: colorCount. newFormColors at: 1 put: Color transparent. nextColorIndex := 2. 2 to: cm size do: [:i | (tally at: i) > 0 ifTrue: [ oldPixelValues ifNil: [c := Color colorFromPixelValue: i - 1 depth: tallyDepth] ifNotNil: [c := Color colorFromPixelValue: (oldPixelValues at: i) depth: 32]. newFormColors at: nextColorIndex put: c. cm at: i put: nextColorIndex - 1. "pixel values are zero-based indices" nextColorIndex := nextColorIndex + 1]]. "copy pixels into new ColorForm, mapping to new pixel values" newForm copyBits: self boundingBox from: self at: 0@0 clippingBox: self boundingBox rule: Form over fillColor: nil map: cm. newForm colors: newFormColors. newForm offset: offset. ^ newForm ! ! !Form methodsFor: 'filling' stamp: 'StephaneDucasse 10/25/2013 16:13'! fillFromXYColorBlock: colorBlock "General Gradient Fill. Supply relative x and y in [0.0 ... 1.0] to colorBlock, and paint each pixel with the color that comes back" | poker yRel xRel | poker := BitBlt bitPokerToForm: self. 0 to: height-1 do: [:y | yRel := y asFloat / (height-1) asFloat. 0 to: width-1 do: [:x | xRel := x asFloat / (width-1) asFloat. poker pixelAt: x@y put: ((colorBlock value: xRel value: yRel) pixelWordForDepth: self depth)]] " | d | ((Form extent: 100@20 depth: Display depth) fillFromXYColorBlock: [:x :y | d := 1.0 - (x - 0.5) abs - (y - 0.5) abs. Color r: d g: 0 b: 1.0-d]) display "! ! !Form methodsFor: 'filling' stamp: 'di 2/19/1999 07:07'! anyShapeFill "Fill the interior of the outermost outlined region in the receiver, a 1-bit deep form. Typically the resulting form is used with fillShape:fillColor: to paint a solid color. See also convexShapeFill:" | shape | "Draw a seed line around the edge and fill inward from the outside." shape := self findShapeAroundSeedBlock: [:f | f borderWidth: 1]. "Reverse so that this becomes solid in the middle" shape := shape reverse. "Finally erase any bits from the original so the fill is only elsewhere" shape copy: shape boundingBox from: self to: 0@0 rule: Form erase. ^ shape! ! !Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:41'! bitsSize | pixPerWord | depth == nil ifTrue: [depth := 1]. pixPerWord := 32 // self depth. ^ width + pixPerWord - 1 // pixPerWord * height! ! !Form methodsFor: 'bordering' stamp: 'StephaneDucasse 10/25/2013 16:12'! border: rect width: borderWidth rule: rule fillColor: fillColor "Paint a border whose rectangular area is defined by rect. The width of the border of each side is borderWidth. Uses fillColor for drawing the border." | blt | blt := (BitBlt toForm: self) combinationRule: rule; fillColor: fillColor. blt sourceOrigin: 0@0. blt destOrigin: rect origin. blt width: rect width; height: borderWidth; copyBits. blt destY: rect corner y - borderWidth; copyBits. blt destY: rect origin y + borderWidth. blt height: rect height - borderWidth - borderWidth; width: borderWidth; copyBits. blt destX: rect corner x - borderWidth; copyBits! ! !Form methodsFor: '*Graphics-Files' stamp: 'di 7/6/1998 23:00'! writeOnMovie: file "Write just my bits on the file." self unhibernate. bits writeUncompressedOn: file! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! pixelWordFor: aColor "Return the pixel word for representing the given color on the receiver" | basicPattern | self hasNonStandardPalette ifFalse:[^aColor pixelWordForDepth: self depth]. basicPattern := self pixelValueFor: aColor. self depth = 32 ifTrue:[^basicPattern] ifFalse:[^aColor pixelWordFor: self depth filledWith: basicPattern]! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! pixelValueFor: aColor "Return the pixel word for representing the given color on the receiver" self hasNonStandardPalette ifTrue:[^self colormapFromARGB mapPixel: (aColor pixelValueForDepth: 32)] ifFalse:[^aColor pixelValueForDepth: self depth]! ! !Form methodsFor: 'accessing' stamp: 'ar 2/16/2000 22:00'! offset ^offset ifNil:[0@0]! ! !Form methodsFor: 'transitions' stamp: 'Jb 11/19/2010 15:44'! fadeImageCoarse: otherImage at: topLeft "Display fadeImageCoarse: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" | d pix| d := self depth. ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: [:i :mask | | j | i=1 ifTrue: [pix := (1 bitShift: d) - 1. 1 to: 8//d-1 do: [:q | pix := pix bitOr: (pix bitShift: d*4)]] . i <= 16 ifTrue:[ j := i-1//4+1. (0 to: 28 by: 4) do: [:k | mask bits at: j+k put: (pix bitOr: (mask bits at: j+k))]. true] ifFalse: [false]]! ! !Form methodsFor: 'pixel access' stamp: 'ar 5/14/2001 23:46'! colorAt: aPoint put: aColor "Store a Color into the pixel at coordinate aPoint. " self pixelValueAt: aPoint put: (self pixelValueFor: aColor). "[Sensor anyButtonPressed] whileFalse: [Display colorAt: Sensor cursorPoint put: Color red]" ! ! !Form methodsFor: 'analyzing' stamp: 'StephaneDucasse 10/25/2013 16:14'! primCountBits "Count the non-zero pixels of this form." self depth > 8 ifTrue: [^(self asFormOfDepth: 8) primCountBits]. ^ (BitBlt toForm: self) fillColor: (Bitmap with: 0); destRect: (0@0 extent: width@height); combinationRule: 32; copyBits! ! !Form methodsFor: 'converting' stamp: 'ar 7/23/1999 17:04'! orderedDither32To16 "Do an ordered dithering for converting from 32 to 16 bit depth." | ditherMatrix ii out inBits outBits index pv dmv r di dmi dmo g b pvOut outIndex | self depth = 32 ifFalse:[^self error:'Must be 32bit for this']. ditherMatrix := #( 0 8 2 10 12 4 14 6 3 11 1 9 15 7 13 5). ii := (0 to: 31) collect:[:i| i]. out := Form extent: self extent depth: 16. inBits := self bits. outBits := out bits. index := outIndex := 0. pvOut := 0. 0 to: self height-1 do:[:y| 0 to: self width-1 do:[:x| pv := inBits at: (index := index + 1). dmv := ditherMatrix at: (y bitAnd: 3) * 4 + (x bitAnd: 3) + 1. r := pv bitAnd: 255. di := r * 496 bitShift: -8. dmi := di bitAnd: 15. dmo := di bitShift: -4. r := dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. g := (pv bitShift: -8) bitAnd: 255. di := g * 496 bitShift: -8. dmi := di bitAnd: 15. dmo := di bitShift: -4. g := dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. b := (pv bitShift: -16) bitAnd: 255. di := b * 496 bitShift: -8. dmi := di bitAnd: 15. dmo := di bitShift: -4. b := dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. pvOut := (pvOut bitShift: 16) + (b bitShift: 10) + (g bitShift: 5) + r. (x bitAnd: 1) = 1 ifTrue:[ outBits at: (outIndex := outIndex+1) put: pvOut. pvOut := 0]. ]. (self width bitAnd: 1) = 1 ifTrue:[ outBits at: (outIndex := outIndex+1) put: (pvOut bitShift: -16). pvOut := 0]. ]. ^out! ! !Form methodsFor: 'resources' stamp: 'StephaneDucasse 3/17/2010 20:56'! readResourceFrom: aStream "Store a resource representation of the receiver on aStream. Must be specific to the receiver so that no code is filed out." | bitsSize msb | (aStream next: 4) asString = self resourceTag ifFalse: [aStream position: aStream position - 4. ^self readNativeResourceFrom: aStream]. width := aStream nextNumber: 4. height := aStream nextNumber: 4. depth := aStream nextNumber: 4. bitsSize := aStream nextNumber: 4. bitsSize = 0 ifFalse: [bits := aStream next: bitsSize. ^self]. msb := (aStream nextNumber: 4) = 1. bitsSize := aStream nextNumber: 4. bits := Bitmap new: self bitsSize. (Form extent: width @ height depth: depth bits: (aStream next: bitsSize * 4)) displayOn: self. msb = Smalltalk isBigEndian ifFalse: [Bitmap swapBytesIn: bits from: 1 to: bits size]! ! !Form methodsFor: 'scaling, rotation' stamp: 'jannik.laval 5/1/2010 16:12'! flipHorizontally "Flip the image around the x axis. Flip the form upside/down" | rowLen row topIndex botIndex | self unhibernate. rowLen := bits size // height. row := Bitmap new: rowLen. topIndex := 1. botIndex := bits size - rowLen + 1. 1 to: height // 2 do: [ :i | [topIndex+rowLen <= botIndex] assert. row replaceFrom: 1 to: rowLen with: bits startingAt: topIndex. bits replaceFrom: topIndex to: topIndex+rowLen-1 with: bits startingAt: botIndex. bits replaceFrom: botIndex to: botIndex+rowLen-1 with: row startingAt: 1. topIndex := topIndex + rowLen. botIndex := botIndex - rowLen ].! ! !Form methodsFor: 'converting' stamp: 'StephaneDucasse 10/25/2013 16:12'! asGrayScale "Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.)" | f32 srcForm result map bb grays | self depth = 32 ifFalse: [ f32 := Form extent: width@height depth: 32. self displayOn: f32. ^ f32 asGrayScale]. self unhibernate. srcForm := Form extent: (width * 4)@height depth: 8. srcForm bits: bits. result := ColorForm extent: width@height depth: 8. map := Bitmap new: 256. 2 to: 256 do: [:i | map at: i put: i - 1]. map at: 1 put: 1. "map zero pixel values to near-black" bb := (BitBlt toForm: result) sourceForm: srcForm; combinationRule: Form over; colorMap: map. 0 to: width - 1 do: [:dstX | bb sourceRect: (((dstX * 4) + 2)@0 extent: 1@height); destOrigin: dstX@0; copyBits]. "final BitBlt to zero-out pixels that were truely transparent in the original" map := Bitmap new: 512. map at: 1 put: 16rFF. (BitBlt toForm: result) sourceForm: self; sourceRect: self boundingBox; destOrigin: 0@0; combinationRule: Form erase; colorMap: map; copyBits. grays := (0 to: 255) collect: [:brightness | Color gray: brightness asFloat / 255.0]. grays at: 1 put: Color transparent. result colors: grays. ^ result ! ! !Form methodsFor: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 2/21/2013 23:14'! listRenderOn: aCanvas atRow: index bounds: aRectangle color: aColor backgroundColor: backgroundColor from: aList self asMorph listRenderOn: aCanvas atRow: index bounds: aRectangle color: aColor backgroundColor: backgroundColor from: aList! ! !Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:43'! readBitsFrom: aBinaryStream bits := Bitmap newFromStream: aBinaryStream. bits size = self bitsSize ifFalse: [self error: 'wrong bitmap size; bad Form file?']. ^ self ! ! !Form methodsFor: 'private' stamp: 'ar 10/30/2000 23:22'! setResourceBits: aForm "Private. Really. Used for setting the 'resource bits' when externalizing some form" bits := aForm.! ! !Form methodsFor: 'copying' stamp: 'tk 8/19/1998 16:11'! veryDeepCopyWith: deepCopier "Return self. I am immutable in the Morphic world. Do not record me." ^ self! ! !Form methodsFor: 'scaling, rotation' stamp: 'AliakseiSyrel 4/1/2014 11:21'! magnifyBy: scale "Answer a Form created as a scaling of the receiver. Scale may be a Float, and may be greater or less than 1.0." ^ self magnify: self boundingBox by: scale smoothing: (scale < 1 ifTrue: [2] ifFalse: [1])! ! !Form methodsFor: 'testing' stamp: 'JuanVuletich 10/12/2010 12:44'! mightBeTranslucent "Answer whether this form may be translucent" ^self depth = 32! ! !Form methodsFor: 'transitions' stamp: 'ar 5/28/2000 12:12'! pageWarp: otherImage at: topLeft forward: forward "Produce a page-turning illusion that gradually reveals otherImage located at topLeft in this form. forward == true means turn pages toward you, else away. [ignored for now]" | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | pageRect := otherImage boundingBox. oldPage := self copy: (pageRect translateBy: topLeft). (forward ifTrue: [oldPage] ifFalse: [otherImage]) border: pageRect widthRectangle: (Rectangle left: 0 right: 2 top: 1 bottom: 1) rule: Form over fillColor: Color black. oldBottom := self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). nSteps := 8. buffer := Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. d := pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. 1 to: nSteps-1 do: [:i | forward ifTrue: [buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. p := pageRect topRight + (d * i // nSteps)] ifFalse: [buffer copy: pageRect from: oldPage to: 0@0 rule: Form over. p := pageRect topRight + (d * (nSteps-i) // nSteps)]. buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. leafRect := pageRect topLeft corner: p x @ (pageRect bottom + p y). sourceQuad := Array with: pageRect topLeft with: pageRect bottomLeft + (0@p y) with: pageRect bottomRight with: pageRect topRight - (0@p y). warp := (WarpBlt current toForm: buffer) clipRect: leafRect; sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); combinationRule: Form paint. warp copyQuad: sourceQuad toRect: leafRect. self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. Display forceDisplayUpdate]. buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. Display forceDisplayUpdate. " 1 to: 4 do: [:corner | Display pageWarp: (Form fromDisplay: (10@10 extent: 200@300)) reverse at: 10@10 forward: false] " ! ! !Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:44'! readAttributesFrom: aBinaryStream | offsetX offsetY | depth := aBinaryStream next. (self depth isPowerOfTwo and: [self depth between: 1 and: 32]) ifFalse: [self error: 'invalid depth; bad Form file?']. width := aBinaryStream nextWord. height := aBinaryStream nextWord. offsetX := aBinaryStream nextWord. offsetY := aBinaryStream nextWord. offsetX > 32767 ifTrue: [offsetX := offsetX - 65536]. offsetY > 32767 ifTrue: [offsetY := offsetY - 65536]. offset := Point x: offsetX y: offsetY. ! ! !Form methodsFor: 'copying' stamp: 'jm 2/27/98 09:35'! deepCopy ^ self shallowCopy bits: bits copy; offset: offset copy ! ! !Form methodsFor: 'filling' stamp: 'StephaneDucasse 10/25/2013 16:13'! findShapeAroundSeedBlock: seedBlock "Build a shape that is black in any region marked by seedBlock. SeedBlock will be supplied a form, in which to blacken various pixels as 'seeds'. Then the seeds are smeared until there is no change in the smear when it fills the region, ie, when smearing hits a black border and thus goes no further." | smearForm previousSmear all count smearPort | self assert: [self depth > 1]. "Only meaningful for B/W forms." all := self boundingBox. smearForm := Form extent: self extent. smearPort := BitBlt toForm: smearForm. seedBlock value: smearForm. "Blacken seeds to be smeared" smearPort copyForm: self to: 0 @ 0 rule: Form erase. "Clear any in black" previousSmear := smearForm deepCopy. count := 1. [count = 10 and: "check for no change every 10 smears" [count := 1. previousSmear copy: all from: 0 @ 0 in: smearForm rule: Form reverse. previousSmear isAllWhite]] whileFalse: [smearPort copyForm: smearForm to: 1 @ 0 rule: Form under. smearPort copyForm: smearForm to: -1 @ 0 rule: Form under. "After horiz smear, trim around the region border" smearPort copyForm: self to: 0 @ 0 rule: Form erase. smearPort copyForm: smearForm to: 0 @ 1 rule: Form under. smearPort copyForm: smearForm to: 0 @ -1 rule: Form under. "After vert smear, trim around the region border" smearPort copyForm: self to: 0 @ 0 rule: Form erase. count := count+1. count = 9 ifTrue: "Save penultimate smear for comparison" [previousSmear copy: all from: 0 @ 0 in: smearForm rule: Form over]]. "Now paint the filled region in me with aHalftone" ^ smearForm! ! !Form methodsFor: 'analyzing' stamp: ''! innerPixelRectFor: pv orNot: not "Return a rectangle describing the smallest part of me that includes all pixels of value pv. Note: If orNot is true, then produce a copy that includes all pixels that are DIFFERENT from the supplied (background) value" | xTally yTally | xTally := self xTallyPixelValue: pv orNot: not. yTally := self yTallyPixelValue: pv orNot: not. ^ ((xTally findFirst: [:t | t>0]) - 1) @ ((yTally findFirst: [:t | t>0]) - 1) corner: (xTally findLast: [:t | t>0])@(yTally findLast: [:t | t>0])! ! !Form methodsFor: 'converting' stamp: 'ar 2/7/2004 18:16'! asSourceForm ^self! ! !Form methodsFor: 'displaying' stamp: ''! displayOnPort: port at: location port copyForm: self to: location rule: Form over! ! !Form methodsFor: 'analyzing' stamp: 'StephaneDucasse 10/25/2013 16:16'! yTallyPixelValue: pv orNot: not "Return an array of the number of pixels with value pv by y-value. Note that if not is true, then this will tally those different from pv." | cm slice copyBlt countBlt | cm := self newColorMap. "Map all colors but pv to zero" not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" cm at: pv+1 put: 1 - (cm at: pv+1). slice := Form extent: width@1. copyBlt := (BitBlt destForm: slice sourceForm: self halftoneForm: nil combinationRule: Form over destOrigin: 0@0 sourceOrigin: 0@0 extent: slice width @ 1 clipRect: slice boundingBox) colorMap: cm. countBlt := (BitBlt toForm: slice) fillColor: (Bitmap with: 0); destRect: (0@0 extent: slice extent); combinationRule: 32. ^ (0 to: height-1) collect: [:y | copyBlt sourceOrigin: 0@y; copyBits. countBlt copyBits]! ! !Form methodsFor: 'display box access' stamp: ''! boundingBox ^ Rectangle origin: 0 @ 0 corner: width @ height! ! !Form methodsFor: 'analyzing' stamp: 'jm 6/18/1999 18:41'! tallyPixelValues "Answer a Bitmap whose elements contain the number of pixels in this Form with the pixel value corresponding to their index. Note that the pixels of multiple Forms can be tallied together using tallyPixelValuesInRect:into:." ^ self tallyPixelValuesInRect: self boundingBox into: (Bitmap new: (1 bitShift: (self depth min: 15))) " Move a little rectangle around the screen and print its tallies... | r tallies nonZero | Cursor blank showWhile: [ [Sensor anyButtonPressed] whileFalse: [r := Sensor cursorPoint extent: 10@10. Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil. tallies := (Display copy: r) tallyPixelValues. nonZero := (1 to: tallies size) select: [:i | (tallies at: i) > 0] thenCollect: [:i | (tallies at: i) -> (i-1)]. nonZero printString , ' ' displayAt: 0@0. Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]] " ! ! !Form methodsFor: 'accessing' stamp: ''! bits: aBitmap "Reset the Bitmap containing the receiver's bits." bits := aBitmap! ! !Form methodsFor: '*Morphic-Core' stamp: 'PavelKrivanek 11/18/2012 20:37'! defaultCanvasClass "Return the default canvas used for drawing onto the receiver" ^ FormCanvas! ! !Form methodsFor: 'analyzing' stamp: 'jm 12/5/97 19:48'! colorsUsed "Return a list of the Colors this form uses." | tallies tallyDepth usedColors | tallies := self tallyPixelValues. tallyDepth := (tallies size log: 2) asInteger. usedColors := OrderedCollection new. tallies doWithIndex: [:count :i | count > 0 ifTrue: [ usedColors add: (Color colorFromPixelValue: i - 1 depth: tallyDepth)]]. ^ usedColors asArray ! ! !Form methodsFor: '*Polymorph-Widgets-Themes' stamp: 'EstebanLorenzano 5/10/2013 14:56'! mergeBottomRightWith: aForm ^ self mergeWith: aForm at: self extent - aForm extent! ! !Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:44'! readFrom: aBinaryStream "Reads the receiver from the given binary stream with the format: depth, extent, offset, bits." self readAttributesFrom: aBinaryStream. self readBitsFrom: aBinaryStream! ! !Form methodsFor: 'transitions' stamp: 'IgorStasenko 12/22/2012 03:28'! wipeImage: otherImage at: topLeft clippingBox: clipBox rectForIndex: rectForIndexBlock | i clipRect t rectOrList waitTime | i := 0. clipRect := topLeft extent: otherImage extent. clipBox ifNotNil: [clipRect := clipRect intersect: clipBox ifNone: [ ^ self ]]. [rectOrList := rectForIndexBlock value: (i := i + 1). rectOrList == nil] whileFalse: [ t := Time millisecondClockValue. rectOrList asOrderedCollection do: [:r | self copyBits: r from: otherImage at: topLeft + r topLeft clippingBox: clipRect rule: Form over fillColor: nil]. Display forceDisplayUpdate. waitTime := 3 - (Time millisecondClockValue - t). waitTime > 0 ifTrue: ["(Delay forMilliseconds: waitTime) wait"]]. ! ! !Form methodsFor: 'other' stamp: 'jm 1/6/98 10:37'! primPrintHScale: hScale vScale: vScale landscape: aBoolean "On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer." "(Form extent: 10@10) primPrintHScale: 1.0 vScale: 1.0 landscape: true" self primitiveFailed ! ! !Form methodsFor: 'filein/out' stamp: 'di 8/5/1998 11:37'! hibernate "Replace my bitmap with a compactly encoded representation (a ByteArray). It is vital that BitBlt and any other access to the bitmap (such as writing to a file) not be used when in this state. Since BitBlt will fail if the bitmap size is wrong (not = bitsSize), we do not allow replacement by a byteArray of the same (or larger) size." "NOTE: This method copies code from Bitmap compressToByteArray so that it can nil out the old bits during the copy, thus avoiding 2x need for extra storage." | compactBits lastByte | (bits isMemberOf: Bitmap) ifFalse: [^ self "already hibernated or weird state"]. compactBits := ByteArray new: (bits size*4) + 7 + (bits size//1984*3). lastByte := bits compress: bits toByteArray: compactBits. lastByte < (bits size*4) ifTrue: [bits := nil. "Let GC reclaim the old bits before the copy if necessary" bits := compactBits copyFrom: 1 to: lastByte]! ! !Form methodsFor: 'testing' stamp: 'ar 5/27/2000 16:54'! isExternalForm ^false! ! !Form methodsFor: 'copying' stamp: ''! copy: aRect "Return a new form which derives from the portion of the original form delineated by aRect." | newForm | newForm := self class extent: aRect extent depth: depth. ^ newForm copyBits: aRect from: self at: 0@0 clippingBox: newForm boundingBox rule: Form over fillColor: nil! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:41'! newColorMap "Return an uninitialized color map array appropriate to this Form's depth." ^ Bitmap new: (1 bitShift: (self depth min: 15)) ! ! !Form methodsFor: 'color mapping' stamp: 'StephaneDucasse 10/25/2013 16:13'! mapColor: oldColor to: newColor "Make all pixels of the given color in this Form to the given new color." "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." | map | map := (Color cachedColormapFrom: self depth to: self depth) copy. map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth). (BitBlt toForm: self) sourceForm: self; sourceOrigin: 0@0; combinationRule: Form over; destX: 0 destY: 0 width: width height: height; colorMap: map; copyBits. ! ! !Form methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:06'! form "Answer the receiver's form. For vanilla Forms, this degenerates to self. Makes several methods that operate on both Forms and MaskedForms much more straightforward." ^ self! ! !Form methodsFor: 'transitions' stamp: 'MarcusDenker 10/2/2013 20:21'! fadeImage: otherImage at: topLeft indexAndMaskDo: indexAndMaskBlock "This fade uses halftones as a blending hack. Zeros in the halftone produce the original image (self), and ones in the halftone produce the 'otherImage'. IndexAndMaskBlock gets evaluated prior to each cycle, and the resulting boolean determines whether to continue cycling." | index imageRect maskForm resultForm | imageRect := otherImage boundingBox. resultForm := self copy: (topLeft extent: imageRect extent). maskForm := Form extent: 32@32. index := 0. [indexAndMaskBlock value: (index := index+1) value: maskForm] whileTrue: [maskForm reverse. resultForm copyBits: imageRect from: resultForm at: 0@0 clippingBox: imageRect rule: Form over fillColor: maskForm. maskForm reverse. resultForm copyBits: imageRect from: otherImage at: 0@0 clippingBox: imageRect rule: Form under fillColor: maskForm. self copyBits: imageRect from: resultForm at: topLeft clippingBox: self boundingBox rule: Form over fillColor: nil. Display forceDisplayUpdate]! ! !Form methodsFor: 'converting' stamp: 'jm 11/12/97 19:28'! as8BitColorForm "Simple conversion of zero pixels to transparent. Force it to 8 bits." | f map | f := ColorForm extent: self extent depth: 8. self displayOn: f at: self offset negated. map := Color indexedColors copy. map at: 1 put: Color transparent. f colors: map. f offset: self offset. ^ f ! ! !Form methodsFor: 'transitions' stamp: 'Jb 11/19/2010 15:53'! fadeImageVert: otherImage at: topLeft "Display fadeImageVert: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10" | d | d := self depth. ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: [:i :mask | mask fill: ((mask width//2//d-i*d)@0 extent: i*2*d@mask height) fillColor: Color black. i <= (mask width//d)]! ! !Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 00:48'! hasBeenModified: aBool "Change the receiver to reflect the modification state" aBool ifTrue:[^self unhibernate]. self shouldPreserveContents ifTrue:[self hibernate] ifFalse:[bits := nil]! ! !Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40'! dominantColor | tally max maxi | self depth > 16 ifTrue: [^(self asFormOfDepth: 16) dominantColor]. tally := self tallyPixelValues. max := maxi := 0. tally withIndexDo: [:n :i | n > max ifTrue: [max := n. maxi := i]]. ^ Color colorFromPixelValue: maxi - 1 depth: self depth! ! !Form methodsFor: 'accessing' stamp: ''! extent ^ width @ height! ! !Form methodsFor: 'transitions' stamp: ''! fadeImageHorFine: otherImage at: topLeft "Display fadeImageHorFine: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10" ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: [:i :mask | mask fill: (0@(i-1) extent: mask width@1) fillColor: Color black. mask fill: (0@(i-1+16) extent: mask width@1) fillColor: Color black. (i*2) <= mask width]! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/27/2000 20:14'! rgbaBitMasks "Return the masks for specifying the R,G,B, and A components in the receiver" self depth <= 8 ifTrue:[^#(16rFF0000 16rFF00 16rFF 16rFF000000)]. self depth = 16 ifTrue:[^#(16r7C00 16r3E0 16r1F 16r0)]. self depth = 32 ifTrue:[^#(16rFF0000 16rFF00 16rFF 16rFF000000)]. self error:'Bad depth for form'! ! !Form methodsFor: 'transitions' stamp: ''! fadeImageHor: otherImage at: topLeft "Display fadeImageHor: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10" ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: [:i :mask | mask fill: (0@(mask height//2-i) extent: mask width@(i*2)) fillColor: Color black. (i*2) <= mask width]! ! !Form methodsFor: 'displaying' stamp: 'StephaneDucasse 10/25/2013 16:14'! paintBits: sourceForm at: destOrigin translucent: factor "Make up a BitBlt table and copy the bits with the given colorMap." (BitBlt destForm: self sourceForm: sourceForm halftoneForm: nil combinationRule: 31 destOrigin: destOrigin sourceOrigin: 0@0 extent: sourceForm extent clipRect: self boundingBox) copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) " | f f2 f3 | f := Form fromUser. f replaceColor: f peripheralColor withColor: Color transparent. f2 := Form fromDisplay: (0@0 extent: f extent). f3 := f2 deepCopy. 0.0 to: 1.0 by: 1.0/32 do: [:t | f3 := f2 deepCopy. f3 paintBits: f at: 0@0 translucent: t. f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. "! ! !Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'! shouldPreserveContents "Return true if the receiver should preserve it's contents when flagged to be clean. Most forms can not be trivially restored by some drawing operation but some may." ^true! ! !Form methodsFor: 'analyzing' stamp: 'StephaneDucasse 10/25/2013 16:16'! tallyPixelValuesInRect: destRect into: valueTable "Tally the selected pixels of this Form into valueTable, a Bitmap of depth 2^depth similar to a color map. Answer valueTable." (BitBlt toForm: self) sourceForm: self; "src must be given for color map ops" sourceOrigin: 0@0; tallyMap: valueTable; combinationRule: 33; destRect: destRect; copyBits. ^ valueTable " Move a little rectangle around the screen and print its tallies... | r tallies nonZero | Cursor blank showWhile: [ [Sensor anyButtonPressed] whileFalse: [r := Sensor cursorPoint extent: 10@10. Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil. tallies := (Display copy: r) tallyPixelValues. nonZero := (1 to: tallies size) select: [:i | (tallies at: i) > 0] thenCollect: [:i | (tallies at: i) -> (i-1)]. nonZero printString , ' ' displayAt: 0@0. Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]] "! ! !Form methodsFor: 'testing' stamp: 'ar 5/17/2001 15:47'! isLittleEndian "Return true if the receiver contains little endian pixels, meaning the left-most pixel is stored in the least significant bits of a word." ^depth < 0! ! !Form methodsFor: 'scaling, rotation' stamp: ''! magnify: aRectangle by: scale "Answer a Form created as a scaling of the receiver. Scale may be a Float, and may be greater or less than 1.0." ^ self magnify: aRectangle by: scale smoothing: 1 "Dynamic test... [Sensor anyButtonPressed] whileFalse: [(Display magnify: (Sensor cursorPoint extent: 31@41) by: 5@3) display] " "Scaling test... | f cp | f := Form fromDisplay: (Rectangle originFromUser: 100@100). Display restoreAfter: [Sensor waitNoButton. [Sensor anyButtonPressed] whileFalse: [cp := Sensor cursorPoint. (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent) display]] " "Consistency test... | f f2 p | [Sensor anyButtonPressed] whileFalse: [f := Form fromDisplay: ((p := Sensor cursorPoint) extent: 31@41). Display fillBlack: (p extent: 31@41). f2 := f magnify: f boundingBox by: 5@3. (f2 shrink: f2 boundingBox by: 5@3) displayAt: p] " ! ! !Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 17:00'! magnify: aRectangle by: scale smoothing: cellSize "Answer a Form created as a scaling of the receiver. Scale may be a Float or even a Point, and may be greater or less than 1.0." | newForm | newForm := self blankCopyOf: aRectangle scaledBy: scale. (WarpBlt current toForm: newForm) sourceForm: self; colorMap: (self colormapIfNeededFor: newForm); cellSize: cellSize; "installs a new colormap if cellSize > 1" combinationRule: 3; copyQuad: aRectangle innerCorners toRect: newForm boundingBox. ^ newForm "Dynamic test... [Sensor anyButtonPressed] whileFalse: [(Display magnify: (Sensor cursorPoint extent: 131@81) by: 0.5 smoothing: 2) display] " "Scaling test... | f cp | f := Form fromDisplay: (Rectangle originFromUser: 100@100). Display restoreAfter: [Sensor waitNoButton. [Sensor anyButtonPressed] whileFalse: [cp := Sensor cursorPoint. (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent smoothing: 2) display]] "! ! !Form methodsFor: 'resources' stamp: 'ar 2/27/2001 14:56'! resourceTag ^'FORM'! ! !Form methodsFor: 'copying' stamp: 'StephaneDucasse 10/25/2013 16:13'! copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm "Make up a BitBlt table and copy the bits." (BitBlt destForm: self sourceForm: sourceForm fillColor: aForm combinationRule: rule destOrigin: destOrigin sourceOrigin: sourceRect origin extent: sourceRect extent clipRect: clipRect) copyBits! ! !Form methodsFor: 'copying' stamp: 'StephaneDucasse 10/25/2013 16:13'! copyBits: sourceForm at: destOrigin translucent: factor "Make up a BitBlt table and copy the bits with the given colorMap." (BitBlt destForm: self sourceForm: sourceForm halftoneForm: nil combinationRule: 30 destOrigin: destOrigin sourceOrigin: 0@0 extent: sourceForm extent clipRect: self boundingBox) copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) " | f f2 f3 | f := Form fromUser. f2 := Form fromDisplay: (0@0 extent: f extent). f3 := f2 deepCopy. 0.0 to: 1.0 by: 1.0/32 do: [:t | f3 := f2 deepCopy. f3 copyBits: f at: 0@0 translucent: t. f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait]. "! ! !Form methodsFor: 'copying' stamp: 'RAA 9/28/1999 11:20'! blankCopyOf: aRectangle scaledBy: scale ^ self class extent: (aRectangle extent * scale) truncated depth: depth! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! colormapToARGB "Return a ColorMap mapping from the receiver into canonical ARGB space." self hasNonStandardPalette ifTrue:[^self colormapFromARGB inverseMap]. self depth <= 8 ifTrue:[ ^ColorMap shifts: #(0 0 0 0) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000) colors: (Color colorMapIfNeededFrom: self depth to: 32)]. self depth = 16 ifTrue:[ ^ColorMap shifts: #( 9 6 3 0) masks: #(16r7C00 16r3E0 16r1F 0)]. self depth = 32 ifTrue:[ ^ColorMap shifts: #(0 0 0 0) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)]. self error:'Bad depth'! ! !Form methodsFor: 'bordering' stamp: ''! borderWidth: anInteger "Set the width of the border for the receiver to be anInteger and paint it using black as the border color." self border: self boundingBox width: anInteger fillColor: Color black! ! !Form methodsFor: 'accessing' stamp: 'MarcusDenker 9/13/2013 14:04'! depth: bitsPerPixel (bitsPerPixel > 32 or: [(bitsPerPixel bitAnd: bitsPerPixel-1) ~= 0]) ifTrue: [self error: 'bitsPerPixel must be 1, 2, 4, 8, 16 or 32']. depth := bitsPerPixel! ! !Form methodsFor: 'printing' stamp: 'di 3/15/1999 14:50'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(; print: width; nextPut: $x; print: height; nextPut: $x; print: depth; nextPut: $). ! ! !Form methodsFor: 'filein/out' stamp: ''! storeHexBitsOn:aStream ^self storeBits:28 to:0 on:aStream.! ! !Form methodsFor: 'displaying' stamp: 'ar 3/2/2001 21:32'! displayScaledOn: aForm "Display the receiver on aForm, scaling if necessary. Form fromUser displayScaledOn: Display. " self extent = aForm extent ifTrue:[^self displayOn: aForm]. (WarpBlt current toForm: aForm) sourceForm: self destRect: aForm boundingBox; combinationRule: Form paint; cellSize: 2; warpBits.! ! !Form methodsFor: 'converting' stamp: 'HenrikSperreJohansen 5/26/2010 15:59'! lighter: aFactor "Answer a lighter variant of this form. aFactor is a float from 0 to 1 representing the strength of the lightening." "(Form fromUser lighter: 0.16) asMorph openInWorld" "(Form fromUser lighter: 0.30) asMorph openInWorld" ^self collectColors: [:color | color adjustSaturation: -0.03 brightness: aFactor]! ! !Form methodsFor: 'accessing' stamp: ''! width ^ width! ! !Form methodsFor: 'filein/out' stamp: ''! storeOn: aStream self storeOn: aStream base: 10! ! !Form methodsFor: 'accessing' stamp: 'tk 3/9/97'! center "Note that offset is ignored here. Are we really going to embrace offset? " ^ (width @ height) // 2! ! !Form methodsFor: 'filling' stamp: 'StephaneDucasse 10/25/2013 16:13'! fill: aRectangle rule: anInteger fillColor: aForm "Replace a rectangular area of the receiver with the pattern described by aForm according to the rule anInteger." (BitBlt toForm: self) copy: aRectangle from: 0@0 in: nil fillColor: aForm rule: anInteger! ! !Form methodsFor: 'scaling, rotation' stamp: 'RAA 7/13/2000 12:09'! scaledToSize: newExtent | scale | newExtent = self extent ifTrue: [^self]. scale := newExtent x / self width min: newExtent y / self height. ^self magnify: self boundingBox by: scale smoothing: 2. ! ! !Form methodsFor: 'displaying' stamp: 'MarcusDenker 10/2/2013 20:21'! displayResourceFormOn: aForm "a special display method for blowing up resource thumbnails" self extent = aForm extent ifTrue: [ ^ self displayOn: aForm ]. "We've got no bilinear interpolation. Use WarpBlt instead" (WarpBlt current toForm: aForm) sourceForm: self destRect: aForm boundingBox; combinationRule: 3; cellSize: 2; warpBits. ! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! colormapFromARGB "Return a ColorMap mapping from canonical ARGB space into the receiver. Note: This version is optimized for Squeak forms." | map nBits | self hasNonStandardPalette ifTrue:[^ColorMap mappingFromARGB: self rgbaBitMasks]. self depth <= 8 ifTrue:[ map := Color colorMapIfNeededFrom: 32 to: self depth. map size = 512 ifTrue:[nBits := 3]. map size = 4096 ifTrue:[nBits := 4]. map size = 32768 ifTrue:[nBits := 5]. ^ColorMap shifts: (Array with: 3 * nBits - 24 with: 2 * nBits - 16 with: 1 * nBits - 8 with: 0) masks: (Array with: (1 << nBits) - 1 << (24 - nBits) with: (1 << nBits) - 1 << (16 - nBits) with: (1 << nBits) - 1 << (8 - nBits) with: 0) colors: map]. self depth = 16 ifTrue:[ ^ColorMap shifts: #(-9 -6 -3 0) masks: #(16rF80000 16rF800 16rF8 0)]. self depth = 32 ifTrue:[ ^ColorMap shifts: #(0 0 0 0) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)]. self error:'Bad depth'! ! !Form methodsFor: 'scaling, rotation' stamp: 'nice 1/5/2010 15:59'! rotateBy: deg magnify: scale smoothing: cellSize "Rotate the receiver by the indicated number of degrees and magnify. scale can be a Point to make for interesting 3D effects " "rot is the destination form, big enough for any angle." | side rot warp r1 pts bigSide | side := 1 + self extent r asInteger. bigSide := (side asPoint * scale) rounded. rot := self blankCopyOf: self boundingBox scaledBy: ( bigSide / self extent ). warp := (WarpBlt current toForm: rot) sourceForm: self; colorMap: (self colormapIfNeededFor: rot); cellSize: cellSize; "installs a new colormap if cellSize > 1" combinationRule: Form paint. r1 := (0@0 extent: side@side) align: (side@side)//2 with: self boundingBox center. "Rotate the corners of the source rectangle." pts := r1 innerCorners collect: [:pt | | p | p := pt - r1 center. (r1 center x asFloat + (p x asFloat*deg degreeCos) + (p y asFloat*deg degreeSin)) @ (r1 center y asFloat - (p x asFloat*deg degreeSin) + (p y asFloat*deg degreeCos))]. warp copyQuad: pts toRect: rot boundingBox. ^ rot " | a f | f := Form fromDisplay: (0@0 extent: 200@200). a := 0. [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) rotateBy: (a := a+5) magnify: 0.75@2 smoothing: 2) display]. f display "! ! !Form methodsFor: 'scaling, rotation' stamp: ''! shrink: aRectangle by: scale | scalePt | scalePt := scale asPoint. ^ self magnify: aRectangle by: (1.0 / scalePt x asFloat) @ (1.0 / scalePt y asFloat)! ! !Form methodsFor: 'accessing' stamp: ''! offset: aPoint offset := aPoint! ! !Form methodsFor: 'filein/out' stamp: 'ar 3/3/2001 15:50'! unhibernate "If my bitmap has been compressed into a ByteArray, then expand it now, and return true." | resBits | bits isForm ifTrue:[ resBits := bits. bits := Bitmap new: self bitsSize. resBits displayResourceFormOn: self. ^true]. bits == nil ifTrue:[bits := Bitmap new: self bitsSize. ^true]. (bits isMemberOf: ByteArray) ifTrue: [bits := Bitmap decompressFromByteArray: bits. ^ true]. ^ false! ! !Form methodsFor: 'testing' stamp: 'RAA 8/14/2000 10:00'! isStatic ^false! ! !Form methodsFor: 'color mapping' stamp: 'ar 12/14/2001 18:11'! maskingMap "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." ^Color maskingMap: self depth! ! !Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:35'! writeAttributesOn: file self unhibernate. file nextPut: depth. file nextWordPut: width. file nextWordPut: height. file nextWordPut: ((self offset x) >=0 ifTrue: [self offset x] ifFalse: [self offset x + 65536]). file nextWordPut: ((self offset y) >=0 ifTrue: [self offset y] ifFalse: [self offset y + 65536]). ! ! !Form methodsFor: 'filling' stamp: ''! fillFromYColorBlock: colorBlock "Vertical Gradient Fill. Supply relative y in [0.0 ... 1.0] to colorBlock, and paint each pixel with the color that comes back" | yRel | 0 to: height-1 do: [:y | yRel := y asFloat / (height-1) asFloat. self fill: (0@y extent: width@1) fillColor: (colorBlock value: yRel)] " ((Form extent: 100@100 depth: Display depth) fillFromYColorBlock: [:y | Color r: y g: 0.0 b: 0.5]) display "! ! !Form methodsFor: 'bordering' stamp: ''! borderWidth: anInteger color: aMask "Set the width of the border for the receiver to be anInteger and paint it using aMask as the border color." self border: self boundingBox width: anInteger fillColor: aMask! ! !Form methodsFor: 'private' stamp: ''! initFromArray: array "Fill the bitmap from array. If the array is shorter, then cycle around in its contents until the bitmap is filled." | ax aSize array32 i j word16 | ax := 0. aSize := array size. aSize > bits size ifTrue: ["backward compatibility with old 16-bit bitmaps and their forms" array32 := Array new: height * (width + 31 // 32). i := j := 0. 1 to: height do: [:y | 1 to: width+15//16 do: [:x16 | word16 := array at: (i := i + 1). x16 odd ifTrue: [array32 at: (j := j+1) put: (word16 bitShift: 16)] ifFalse: [array32 at: j put: ((array32 at: j) bitOr: word16)]]]. ^ self initFromArray: array32]. 1 to: bits size do: [:index | (ax := ax + 1) > aSize ifTrue: [ax := 1]. bits at: index put: (array at: ax)]! ! !Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:42'! colorAt: aPoint "Return the color in the pixel at the given point. " ^ Color colorFromPixelValue: (self pixelValueAt: aPoint) depth: self depth ! ! !Form methodsFor: 'converting' stamp: 'StephaneDucasse 3/27/2010 21:30'! darker "Answer a darker variant of this form." ^ self darker: 0.16! ! !Form methodsFor: 'copying' stamp: ''! copy: sourceRectangle from: sourceForm to: destPt rule: rule ^ self copy: (destPt extent: sourceRectangle extent) from: sourceRectangle topLeft in: sourceForm rule: rule! ! !Form methodsFor: 'pixel access' stamp: 'StephaneDucasse 10/25/2013 16:14'! pixelValueAt: aPoint "Return the raw pixel value at the given point. This pixel value depends on the receiver's depth. Typical clients use colorAt: to get a Color. " ^ (BitBlt bitPeekerFromForm: self) pixelAt: aPoint ! ! !Form methodsFor: 'display box access' stamp: ''! computeBoundingBox ^ Rectangle origin: 0 @ 0 corner: width @ height! ! !Form methodsFor: 'image manipulation' stamp: 'jm 6/30/1999 15:36'! trimBordersOfColor: aColor "Answer a copy of this Form with each edge trimmed in to the first pixel that is not of the given color. (That is, border strips of the given color are removed)." | r | r := self rectangleEnclosingPixelsNotOfColor: aColor. ^ self copy: r ! ! !Form methodsFor: 'scaling, rotation' stamp: ''! rotateBy: deg "Rotate the receiver by the indicated number of degrees." "rot is the destination form, bit enough for any angle." ^ self rotateBy: deg smoothing: 1 " | a f | f := Form fromDisplay: (0@0 extent: 200@200). a := 0. [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) rotateBy: (a := a+5)) display]. f display "! ! !Form methodsFor: 'copying' stamp: 'StephaneDucasse 10/25/2013 16:13'! copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm map: map "Make up a BitBlt table and copy the bits. Use a colorMap." ((BitBlt destForm: self sourceForm: sourceForm fillColor: aForm combinationRule: rule destOrigin: destOrigin sourceOrigin: sourceRect origin extent: sourceRect extent clipRect: clipRect) colorMap: map) copyBits! ! !Form methodsFor: 'converting' stamp: 'nice 1/5/2010 15:59'! copyWithColorsReducedTo: nColors "Note: this has not been engineered. There are better solutions in the literature." | palette colorMap | palette := self reducedPaletteOfSize: nColors. colorMap := (1 to: (1 bitShift: depth)) collect: [:i | | pc closest | pc := Color colorFromPixelValue: i-1 depth: depth. closest := palette detectMin: [:c | c diff: pc]. closest pixelValueForDepth: depth]. ^ self deepCopy copyBits: self boundingBox from: self at: 0@0 colorMap: (colorMap as: Bitmap) ! ! !Form methodsFor: 'scaling, rotation' stamp: 'wiz 1/22/2006 01:15'! rotateBy: direction centerAt: aPoint "Return a rotated copy of the receiver. direction = #none, #right, #left, or #pi" | newForm quad rot scale | direction == #none ifTrue: [^ self]. scale := (direction = #pi ifTrue: [width@height] ifFalse: [height@width]) / self extent . newForm := self blankCopyOf: self boundingBox scaledBy: scale. quad := self boundingBox innerCorners. rot := #(right pi left) indexOf: direction. (WarpBlt current toForm: newForm) sourceForm: self; colorMap: (self colormapIfNeededFor: newForm); combinationRule: 3; copyQuad: ((1+rot to: 4+rot) collect: [:i | quad atWrap: i]) toRect: newForm boundingBox. newForm offset: (self offset rotateBy: direction centerAt: aPoint). ^ newForm " [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) rotateBy: #left centerAt: 0@0) display] " "Consistency test... | f f2 p | [Sensor anyButtonPressed] whileFalse: [f := Form fromDisplay: ((p := Sensor cursorPoint) extent: 31@41). Display fillBlack: (p extent: 31@41). f2 := f rotateBy: #left centerAt: 0@0. (f2 rotateBy: #right centerAt: 0@0) displayAt: p] " ! ! !Form methodsFor: 'filling' stamp: ''! fillFromXColorBlock: colorBlock "Horizontal Gradient Fill. Supply relative x in [0.0 ... 1.0] to colorBlock, and paint each pixel with the color that comes back" | xRel | 0 to: width-1 do: [:x | xRel := x asFloat / (width-1) asFloat. self fill: (x@0 extent: 1@height) fillColor: (colorBlock value: xRel)] " ((Form extent: 100@100 depth: Display depth) fillFromXColorBlock: [:x | Color r: x g: 0.0 b: 0.5]) display "! ! !Form methodsFor: 'converting' stamp: 'ar 4/2/2010 22:35'! collectPixels: aBlock "Create a new copy of the receiver with all the pixels transformed by aBlock" self depth = 32 ifFalse:[ "Perform the operation in 32bpp" ^((self asFormOfDepth: 32) collectPixels: aBlock) asFormOfDepth: self depth]. self unhibernate. "ensure unhibernated before touching bits" ^Form extent: self extent depth: self depth bits: (self bits collect: aBlock)! ! !Form methodsFor: 'displaying' stamp: 'StephaneDucasse 10/25/2013 16:13'! drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm "Refer to the comment in DisplayMedium|drawLine:from:to:clippingBox:rule:mask:." | dotSetter | "set up an instance of BitBlt for display" dotSetter := BitBlt destForm: self sourceForm: sourceForm fillColor: aForm combinationRule: anInteger destOrigin: beginPoint sourceOrigin: 0 @ 0 extent: sourceForm extent clipRect: clipRect. dotSetter drawFrom: beginPoint to: endPoint! ! !Form methodsFor: 'transitions' stamp: 'Jb 11/19/2010 15:45'! fadeImageFine: otherImage at: topLeft "Display fadeImageFine: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" | d pix| d := self depth. ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: [:i :mask | | j ii | i=1 ifTrue: [pix := (1 bitShift: d) - 1. 1 to: 8//d-1 do: [:q | pix := pix bitOr: (pix bitShift: d*4)]]. i <= 16 ifTrue: [ii := #(0 10 2 8 7 13 5 15 1 11 3 9 6 12 4 14) at: i. j := ii//4+1. (0 to: 28 by: 4) do: [:k | mask bits at: j+k put: ((mask bits at: j+k) bitOr: (pix))]. true] ifFalse: [false]]! ! !Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:50'! nativeDepth "Return the 'native' depth of the receiver, e.g., including the endianess" ^depth! ! !Form methodsFor: 'analyzing' stamp: 'StephaneDucasse 10/25/2013 16:14'! pixelCompare: aRect with: otherForm at: otherLoc "Compare the selected bits of this form (those within aRect) against those in a similar rectangle of otherFrom. Return the sum of the absolute value of the differences of the color values of every pixel. Obviously, this is most useful for rgb (16- or 32-bit) pixels but, in the case of 8-bits or less, this will return the sum of the differing bits of the corresponding pixel values (somewhat less useful)" | pixPerWord temp | pixPerWord := 32//self depth. (aRect left\\pixPerWord = 0 and: [aRect right\\pixPerWord = 0]) ifTrue: ["If word-aligned, use on-the-fly difference" ^ (BitBlt toForm: self) copy: aRect from: otherLoc in: otherForm fillColor: nil rule: 32]. "Otherwise, combine in a word-sized form and then compute difference" temp := self copy: aRect. temp copy: aRect from: otherLoc in: otherForm rule: 21. ^ (BitBlt toForm: temp) copy: aRect from: otherLoc in: nil fillColor: (Bitmap with: 0) rule: 32 " Dumb example prints zero only when you move over the original rectangle... | f diff | f := Form fromUser. [Sensor anyButtonPressed] whileFalse: [diff := f pixelCompare: f boundingBox with: Display at: Sensor cursorPoint. diff printString , ' ' displayAt: 0@0] "! ! !Form methodsFor: 'private' stamp: 'ar 5/28/2000 15:49'! setExtent: extent depth: bitsPerPixel bits: bitmap "Create a virtual bit map with the given extent and bitsPerPixel." width := extent x asInteger. width < 0 ifTrue: [width := 0]. height := extent y asInteger. height < 0 ifTrue: [height := 0]. depth := bitsPerPixel. (bits isNil or:[self bitsSize = bitmap size]) ifFalse:[^self error:'Bad dimensions']. bits := bitmap! ! !Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 16:55'! rotateBy: deg smoothing: cellSize "Rotate the receiver by the indicated number of degrees." ^self rotateBy: deg magnify: 1 smoothing: cellSize " | a f | f := Form fromDisplay: (0@0 extent: 200@200). a := 0. [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) rotateBy: (a := a+5) smoothing: 2) display]. f display "! ! !Form methodsFor: 'resources' stamp: 'StephaneDucasse 3/17/2010 20:57'! storeResourceOn: aStream "Store a resource representation of the receiver on aStream. Must be specific to the receiver so that no code is filed out." self hibernate. aStream nextPutAll: self resourceTag asByteArray. "tag" aStream nextNumber: 4 put: width. aStream nextNumber: 4 put: height. aStream nextNumber: 4 put: depth. (bits isMemberOf: ByteArray) ifFalse: "must store bitmap" [aStream nextNumber: 4 put: 0. "tag" aStream nextNumber: 4 put: (Smalltalk isBigEndian ifTrue:[1] ifFalse: [0])]. aStream nextNumber: 4 put: bits size. aStream nextPutAll: bits. ! ! !Form methodsFor: '*Morphic-Core' stamp: 'ar 5/28/2000 12:03'! getCanvas "Return a Canvas that can be used to draw onto the receiver" ^self defaultCanvasClass on: self! ! !Form methodsFor: 'color mapping' stamp: 'StephaneDucasse 10/25/2013 16:14'! mapColors: oldColorBitsCollection to: newColorBits "Make all pixels of the given color in this Form to the given new color." "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." | map | self depth < 16 ifTrue: [map := (Color cachedColormapFrom: self depth to: self depth) copy] ifFalse: [ "use maximum resolution color map" "source is 16-bit or 32-bit RGB; use colormap with 5 bits per color component" map := Color computeRGBColormapFor: self depth bitsPerColor: 5]. oldColorBitsCollection do:[ :oldColor | map at: oldColor put: newColorBits]. (BitBlt toForm: self) sourceForm: self; sourceOrigin: 0@0; combinationRule: Form over; destX: 0 destY: 0 width: width height: height; colorMap: map; copyBits. ! ! !Form methodsFor: 'bordering' stamp: ''! borderWidth: anInteger fillColor: aMask "Set the width of the border for the receiver to be anInteger and paint it using aMask as the border color." self border: self boundingBox width: anInteger fillColor: aMask! ! !Form methodsFor: '*Graphics-Files' stamp: 'ar 6/16/2002 17:53'! writeBMPfileNamed: fName "Display writeBMPfileNamed: 'display.bmp'" BMPReadWriter putForm: self onFileNamed: fName! ! !Form methodsFor: 'testing' stamp: 'ar 2/10/2004 17:18'! isTranslucent "Answer whether this form may be translucent" ^self depth = 32! ! !Form methodsFor: 'converting' stamp: 'StephaneDucasse 3/27/2010 21:38'! lighter "Answer a lighter variant of this form" ^ self lighter: 0.16! ! !Form methodsFor: 'private' stamp: '6/9/97 16:10 di'! setExtent: extent depth: bitsPerPixel "Create a virtual bit map with the given extent and bitsPerPixel." width := extent x asInteger. width < 0 ifTrue: [width := 0]. height := extent y asInteger. height < 0 ifTrue: [height := 0]. depth := bitsPerPixel. bits := Bitmap new: self bitsSize! ! !Form methodsFor: 'testing' stamp: 'ar 5/17/2001 15:46'! isBigEndian "Return true if the receiver contains big endian pixels, meaning the left-most pixel is stored in the most significant bits of a word." ^depth > 0! ! !Form methodsFor: 'initialization' stamp: ''! fromDisplay: aRectangle "Create a virtual bit map from a user specified rectangular area on the display screen. Reallocates bitmap only if aRectangle ~= the receiver's extent." (width = aRectangle width and: [height = aRectangle height]) ifFalse: [self setExtent: aRectangle extent depth: depth]. self copyBits: (aRectangle origin extent: self extent) from: Display at: 0 @ 0 clippingBox: self boundingBox rule: Form over fillColor: nil! ! !Form methodsFor: 'image manipulation' stamp: 'StephaneDucasse 10/25/2013 16:16'! smear: dir distance: dist "Smear any black pixels in this form in the direction dir in Log N steps" | skew bb | bb := BitBlt destForm: self sourceForm: self fillColor: nil combinationRule: Form under destOrigin: 0@0 sourceOrigin: 0@0 extent: self extent clipRect: self boundingBox. skew := 1. [skew < dist] whileTrue: [bb destOrigin: dir*skew; copyBits. skew := skew+skew]! ! !Form methodsFor: '*Graphics-Files' stamp: 'ar 12/9/2002 16:04'! readNativeResourceFrom: byteStream | img aStream | (byteStream isKindOf: FileStream) ifTrue:[ "Ugly, but ImageReadWriter will send #reset which is implemented as #reopen and we may not be able to do so." aStream := RWBinaryOrTextStream with: byteStream contents. ] ifFalse:[ aStream := byteStream. ]. img := [ImageReadWriter formFromStream: aStream] on: Error do:[:ex| nil]. img ifNil:[^nil]. (img isColorForm and:[self isColorForm]) ifTrue:[ | cc | cc := img colors. img colors: nil. img displayOn: self. img colors: cc. ] ifFalse:[ img displayOn: self. ]. img := nil.! ! !Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'! isFillAccelerated: ruleInteger for: aColor "Return true if the receiver can perform accelerated fill operations by itself" ^false! ! !Form methodsFor: '*Polymorph-Widgets-Themes' stamp: 'EstebanLorenzano 5/10/2013 15:28'! mergeWith: aForm at: aPoint | mergedForm | mergedForm := self deepCopy. mergedForm getCanvas translucentImage: aForm at: aPoint. ^ mergedForm ! ! !Form methodsFor: '*Athens-Core' stamp: 'IgorStasenko 3/8/2012 13:45'! asAthensPaintOn: canvas ^ canvas surface createFormPaint: self! ! !Form methodsFor: 'filein/out' stamp: 'jm 3/27/98 16:54'! readFromOldFormat: aBinaryStream "Read a Form in the original ST-80 format." | w h offsetX offsetY newForm theBits pos | self error: 'this method must be updated to read into 32-bit word bitmaps'. w := aBinaryStream nextWord. h := aBinaryStream nextWord. offsetX := aBinaryStream nextWord. offsetY := aBinaryStream nextWord. offsetX > 32767 ifTrue: [offsetX := offsetX - 65536]. offsetY > 32767 ifTrue: [offsetY := offsetY - 65536]. newForm := Form extent: w @ h offset: offsetX @ offsetY. theBits := newForm bits. pos := 0. 1 to: w + 15 // 16 do: [:j | 1 to: h do: [:i | theBits at: (pos := pos+1) put: aBinaryStream nextWord]]. newForm bits: theBits. ^ newForm ! ! !Form methodsFor: 'filein/out' stamp: 'mu 8/17/2003 00:36'! writeOn: file "Write the receiver on the file in the format depth, extent, offset, bits." self writeAttributesOn: file. self writeBitsOn: file! ! !Form methodsFor: 'filling' stamp: 'di 9/11/1998 16:25'! convexShapeFill: aMask "Fill the interior of the outtermost outlined region in the receiver. The outlined region must not be concave by more than 90 degrees. Typically aMask is Color black, to produce a solid fill. then the resulting form is used with fillShape: to paint a solid color. See also anyShapeFill" | destForm tempForm | destForm := Form extent: self extent. destForm fillBlack. tempForm := Form extent: self extent. (0@0) fourNeighbors do: [:dir | "Smear self in all 4 directions, and AND the result" self displayOn: tempForm at: (0@0) - self offset. tempForm smear: dir distance: (dir dotProduct: tempForm extent) abs. tempForm displayOn: destForm at: 0@0 clippingBox: destForm boundingBox rule: Form and fillColor: nil]. destForm displayOn: self at: 0@0 clippingBox: self boundingBox rule: Form over fillColor: aMask! ! !Form methodsFor: 'filein/out' stamp: ''! store32To24HexBitsOn:aStream ^self storeBits:20 to:0 on:aStream.! ! !Form methodsFor: 'initialization' stamp: 'ar 6/16/2002 18:39'! swapEndianness "Swap from big to little endian pixels and vice versa" depth := 0 - depth.! ! !Form methodsFor: 'transitions' stamp: 'jm 10/16/97 15:17'! wipeImage: otherImage at: topLeft delta: delta clippingBox: clipBox | wipeRect bb nSteps | bb := otherImage boundingBox. wipeRect := delta x = 0 ifTrue: [delta y = 0 ifTrue: [nSteps := 1. bb "allow 0@0"] ifFalse: [ nSteps := bb height//delta y abs + 1. "Vertical movement" delta y > 0 ifTrue: [bb topLeft extent: bb width@delta y] ifFalse: [bb bottomLeft+delta extent: bb width@delta y negated]]] ifFalse: [nSteps := bb width//delta x abs + 1. "Horizontal movement" delta x > 0 ifTrue: [bb topLeft extent: delta x@bb height] ifFalse: [bb topRight+delta extent: delta x negated@bb height]]. ^ self wipeImage: otherImage at: topLeft clippingBox: clipBox rectForIndex: [:i | i <= nSteps ifTrue: [wipeRect translateBy: (delta* (i-1))] ifFalse: [nil]]! ! !Form methodsFor: 'other' stamp: 'jm 9/27/97 21:02'! formForColorCount: colorCount "Return a ColorForm of sufficient depth to represent the given number of colors. The maximum number of colors is 256." colorCount > 256 ifTrue: [^ self error: 'too many colors']. colorCount > 16 ifTrue: [^ ColorForm extent: self extent depth: 8]. colorCount > 4 ifTrue: [^ ColorForm extent: self extent depth: 4]. colorCount > 2 ifTrue: [^ ColorForm extent: self extent depth: 2]. ^ ColorForm extent: self extent depth: 1 ! ! !Form methodsFor: 'copying' stamp: 'ar 6/9/2000 18:59'! contentsOfArea: aRect "Return a new form which derives from the portion of the original form delineated by aRect." ^self contentsOfArea: aRect into: (self class extent: aRect extent depth: depth).! ! !Form methodsFor: 'private' stamp: 'ar 12/19/2000 16:23'! privateFloodFillValue: aColor "Private. Compute the pixel value in the receiver's depth but take into account implicit color conversions by BitBlt." | f1 f2 bb | f1 := Form extent: 1@1 depth: depth. f2 := Form extent: 1@1 depth: 32. bb := BitBlt toForm: f1. bb fillColor: aColor; destRect: (0@0 corner: 1@1); combinationRule: 3; copyBits. bb := BitBlt toForm: f2. bb sourceForm: f1; sourceOrigin: 0@0; destRect: (0@0 corner: 1@1); combinationRule: 3; copyBits. ^f2 pixelValueAt: 0@0.! ! !Form methodsFor: 'testing' stamp: 'ar 10/30/2000 23:23'! isForm ^true! ! !Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 00:48'! hasBeenModified "Return true if something *might* have been drawn into the receiver" ^(bits == nil or:[bits class == ByteArray]) not "Read the above as: If the receiver has forgotten its contents (bits == nil) or is still hibernated it can't be modified."! ! !Form methodsFor: 'initialization' stamp: 'ar 5/26/2000 00:45'! flush "If there are any pending operations on the receiver start doing them. In time, they will show up on the receiver but not necessarily immediately after this method returns."! ! !Form methodsFor: '*Morphic-Base' stamp: 'BenjaminVanRyseghem 2/7/2014 15:20'! asAlphaImageMorph ^ AlphaImageMorph new image: self! ! !Form methodsFor: 'converting' stamp: 'MarcusDenker 4/10/2011 10:14'! asCursorForm ^ Form newFrom: self! ! !Form methodsFor: 'converting' stamp: 'CamilloBruni 9/19/2013 10:24'! asGrayScaleWithAlpha "Unlike asGrayScale, this method fully preserves the alpha channel and only desaturates the form(makes grayscale)." ^ (self asFormOfDepth: 32) collectColors: [ :c | |l| l := c luminance. Color r:l g: l b: l alpha: c alpha ]! ! !Form class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 11:06'! floodFillTolerance: aFloat (aFloat >= 0.0 and: [aFloat < 0.3]) ifTrue: [FloodFillTolerance := aFloat] ifFalse: [FloodFillTolerance := 0.0]! ! !Form class methodsFor: '*Graphics-Files' stamp: 'StephaneDucasse 2/2/2010 22:20'! fromFileNamed: fileName "Read a Form or ColorForm from the given file." ^ FileStream readOnlyFileNamed: fileName do: [:aFile | aFile binary. self fromBinaryStream: aFile.] ! ! !Form class methodsFor: 'mode constants' stamp: ''! and "Answer the integer denoting the logical 'and' combination rule." ^1! ! !Form class methodsFor: 'shut down' stamp: 'ar 5/28/2000 23:35'! shutDown "Form shutDown" "Compress all instances in the system. Will decompress on demand..." Form allInstancesDo: [:f | f hibernate]. ColorForm allInstancesDo: [:f | f hibernate].! ! !Form class methodsFor: 'instance creation' stamp: ''! fromDisplay: aRectangle using: oldForm "Like fromDisplay: only if oldForm is the right size, copy into it and answer it instead." ((oldForm ~~ nil) and: [oldForm extent = aRectangle extent]) ifTrue: [oldForm fromDisplay: aRectangle. ^ oldForm] ifFalse: [^ self fromDisplay: aRectangle]! ! !Form class methodsFor: 'instance creation' stamp: 'ar 10/9/1998 23:44'! extent: extentPoint depth: bitsPerPixel bits: aBitmap "Answer an instance of me with blank bitmap of the given dimensions and depth." ^ self basicNew setExtent: extentPoint depth: bitsPerPixel bits: aBitmap! ! !Form class methodsFor: 'mode constants' stamp: ''! paint "Answer the integer denoting the 'paint' combination rule." ^25! ! !Form class methodsFor: 'mode constants' stamp: ''! over "Answer the integer denoting mode over." ^3! ! !Form class methodsFor: 'instance creation' stamp: 'ar 3/1/2006 22:50'! fromUser: gridPoint "Answer an instance of me with bitmap initialized from the area of the display screen designated by the user. The grid for selecting an area is aPoint. Ensures that the returned form has positive extent." | rect | rect := Rectangle fromUser: gridPoint. ^ self fromDisplay: (rect origin extent: (rect extent max: gridPoint))! ! !Form class methodsFor: '*Graphics-Files' stamp: 'PavelKrivanek 11/21/2012 21:19'! fromBinaryStream: aBinaryStream "Read a Form or ColorForm from given file, using the first byte of the file to guess its format. Currently handles: GIF, uncompressed BMP, and both old and new DisplayObject writeOn: formats, JPEG, and PCX. Return nil if the file could not be read or was of an unrecognized format." | firstByte | aBinaryStream binary. firstByte := aBinaryStream next. firstByte = 1 ifTrue: [ "old Squeakform format" ^ self new readFromOldFormat: aBinaryStream]. firstByte = 2 ifTrue: [ "new Squeak form format" ^ self new readFrom: aBinaryStream]. "Try for JPG, GIF, or PCX..." "Note: The following call closes the stream." ^ ImageReadWriter formFromStream: aBinaryStream ! ! !Form class methodsFor: '*Graphics-Files-FileRegistry' stamp: 'MarcusDenker 3/23/2011 18:28'! services ^ Array with: self serviceOpenImageInWindow with: self serviceImageAsBackground ! ! !Form class methodsFor: 'initialize-release' stamp: 'GabrielOmarCotelli 6/4/2009 20:34'! initialize FileServices registerFileReader: self! ! !Form class methodsFor: 'instance creation' stamp: 'StephaneDucasse 3/24/2010 10:48'! fromUser "Answer an instance of me with bitmap initialized from the area of the display screen designated by the user. The grid for selecting an area is 1@1." "self fromUser asMorph openInWorld" ^self fromUser: 1 @ 1! ! !Form class methodsFor: '*Graphics-Files-FileRegistry' stamp: 'StephaneDucasse 11/13/2009 18:42'! openImageInWindow: fullName "Handle five file formats: GIF, JPG, PNG, Form storeOn: (run coded), and BMP. Fail if file format is not recognized." | image | image := self fromFileNamed: fullName. (World drawingClass withForm: image) openInWorld! ! !Form class methodsFor: 'instance creation' stamp: ''! fromDisplay: aRectangle "Answer an instance of me with bitmap initialized from the area of the display screen defined by aRectangle." ^ (self extent: aRectangle extent depth: Display depth) fromDisplay: aRectangle! ! !Form class methodsFor: 'instance creation' stamp: 'jm 12/5/97 19:32'! fromUserWithExtent: anExtent "Answer an instance of me with bitmap initialized from the area of the display screen whose origin is designated by the user and whose size is anExtent" ^ self fromDisplay: (Rectangle originFromUser: anExtent) "(Form fromUserWithExtent: 50@50) displayAt: 10@10"! ! !Form class methodsFor: 'instance creation' stamp: 'nice 1/5/2010 15:59'! extent: extentPoint fromStipple: fourNibbles "Answer an instance of me with bitmap initialized from a repeating 4x4 bit stipple encoded in a 16-bit constant." ^ (self extent: extentPoint depth: 1) initFromArray: ((1 to: 4) collect: [:i | | nibble | nibble := (fourNibbles bitShift: -4*(4-i)) bitAnd: 16rF. 16r11111111 * nibble]) "fill 32 bits with each 4-bit nibble" ! ! !Form class methodsFor: 'mode constants' stamp: ''! blend "Answer the integer denoting BitBlt's alpha blend combination rule." ^24! ! !Form class methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:34'! unload FileServices unregisterFileReader: self ! ! !Form class methodsFor: 'mode constants' stamp: ''! reverse "Answer the integer denoting mode reverse." ^6! ! !Form class methodsFor: '*Graphics-Files-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:21'! fileReaderServicesForFile: fullName suffix: suffix ^((ImageReadWriter allTypicalFileExtensions add: '*'; add: 'form'; yourself) includes: suffix) ifTrue: [ self services ] ifFalse: [#()] ! ! !Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:36'! extent: extentPoint depth: bitsPerPixel "Answer an instance of me with blank bitmap of the given dimensions and depth." ^ self basicNew setExtent: extentPoint depth: bitsPerPixel ! ! !Form class methodsFor: 'mode constants' stamp: ''! erase "Answer the integer denoting mode erase." ^4! ! !Form class methodsFor: 'mode constants' stamp: ''! oldPaint "Answer the integer denoting the 'paint' combination rule." ^16! ! !Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:27'! extent: extentPoint "Answer an instance of me with a blank bitmap of depth 1." ^ self extent: extentPoint depth: 1 ! ! !Form class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/25/2013 16:17'! dotOfSize: diameter "Create a form which contains a round black dot." | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | radius := diameter//2. form := self extent: diameter@diameter offset: (0@0) - (radius@radius). bb := (BitBlt toForm: form) sourceX: 0; sourceY: 0; combinationRule: Form over; fillColor: Color black. rect := form boundingBox. centerX := rect center x. centerY := rect center y. centerYBias := rect height odd ifTrue: [0] ifFalse: [1]. centerXBias := rect width odd ifTrue: [0] ifFalse: [1]. radiusSquared := (rect height asFloat / 2.0) squared - 0.01. xOverY := rect width asFloat / rect height asFloat. maxy := rect height - 1 // 2. "First do the inner fill, and collect x values" 0 to: maxy do: [:dy | dx := ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. bb destX: centerX - centerXBias - dx destY: centerY - centerYBias - dy width: dx + dx + centerXBias + 1 height: 1; copyBits. bb destY: centerY + dy; copyBits]. ^ form " Time millisecondsToRun: [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] "! ! !Form class methodsFor: '*Graphics-Files-FileRegistry' stamp: 'GabrielOmarCotelli 6/4/2009 20:42'! setBackgroundFromImageFileNamed: aFileName (self fromFileNamed: aFileName) setAsBackground! ! !Form class methodsFor: 'mode constants' stamp: ''! erase1bitShape "Answer the integer denoting mode erase." ^ 26! ! !Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:35'! extent: extentPoint depth: bitsPerPixel fromArray: anArray offset: offsetPoint "Answer an instance of me with a pixmap of the given depth initialized from anArray." ^ (self extent: extentPoint depth: bitsPerPixel) offset: offsetPoint; initFromArray: anArray ! ! !Form class methodsFor: 'mode constants' stamp: ''! under "Answer the integer denoting mode under." ^7! ! !Form class methodsFor: '*Morphic-Base' stamp: 'AlainPlantec 12/10/2009 11:00'! floodFillTolerance ^ FloodFillTolerance ifNil: [FloodFillTolerance := 0.0]! ! !Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:26'! extent: extentPoint offset: offsetPoint "Answer an instance of me with a blank bitmap of depth 1." ^ (self extent: extentPoint depth: 1) offset: offsetPoint ! ! !Form class methodsFor: '*Graphics-Files-FileRegistry' stamp: 'tbn 8/11/2010 10:19'! serviceOpenImageInWindow "Answer a service for opening a graphic in a window" ^ SimpleServiceEntry provider: self label: 'Open graphic in a window' selector: #openImageInWindow: description: 'Open a graphic file in a window' buttonLabel: 'Open'! ! !Form class methodsFor: 'mode constants' stamp: ''! oldErase1bitShape "Answer the integer denoting mode erase." ^ 17! ! !Form class methodsFor: '*Graphics-Files-FileRegistry' stamp: 'tbn 8/11/2010 10:18'! serviceImageAsBackground "Answer a service for setting the desktop background from a given graphical file's contents" ^ SimpleServiceEntry provider: self label: 'Use graphic as background' selector: #setBackgroundFromImageFileNamed: description: 'Use the graphic as the background for the desktop' buttonLabel: 'Background'! ! !Form class methodsFor: 'mode constants' stamp: 'di 12/31/1998 14:02'! blendAlpha "Answer the integer denoting BitBlt's blend-with-constant-alpha rule." ^ 30! ! !Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:33'! extent: extentPoint fromArray: anArray offset: offsetPoint "Answer an instance of me of depth 1 with bitmap initialized from anArray." ^ (self extent: extentPoint depth: 1) offset: offsetPoint; initFromArray: anArray ! ! !Form class methodsFor: 'mode constants' stamp: 'di 12/31/1998 14:02'! paintAlpha "Answer the integer denoting BitBlt's paint-with-constant-alpha rule." ^ 31! ! !FormCanvas commentStamp: ''! Note that when shadowDrawing is true, shadowStipple may be either a color, for a solid shadow of the given color, or it may be a stipple used to simulate gray shading when the display cannot support alpha blending.! !FormCanvas methodsFor: 'Morphic-Base-Balloon' stamp: 'gvc 3/16/2009 13:36'! balloonFillRectangle: aRectangle fillStyle: aFillStyle self asBalloonCanvas fillRectangle: aRectangle basicFillStyle: aFillStyle! ! !FormCanvas methodsFor: 'initialization' stamp: 'ar 5/27/2000 21:51'! finish "If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect." form finish! ! !FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:02'! clipBy: aRectangle during: aBlock "Set a clipping rectangle active only during the execution of aBlock. Note: In the future we may want to have more general clip shapes - not just rectangles" ^aBlock value: (self copyClipRect: aRectangle)! ! !FormCanvas methodsFor: 'private' stamp: 'FernandoOlivero 9/9/2013 11:52'! setPaintColor: aColor "Install a new color used for filling." | paintColor screen patternWord | paintColor := aColor. paintColor ifNil: [paintColor := Color transparent]. paintColor isColor ifFalse: [ (paintColor isKindOf: InfiniteForm) ifFalse: [^self error:'Cannot install color']. ^port fillPattern: paintColor; combinationRule: Form paint]. "Okay, so paintColor really *is* a color" port sourceForm: nil. (paintColor isTranslucent) ifFalse: [ port fillPattern: paintColor. port combinationRule: Form paint. self depth = 8 ifTrue: [ port fillColor: (form balancedPatternFor: paintColor)]. ^self]. "paintColor is translucent color" self depth > 8 ifTrue: [ "BitBlt setup for alpha mapped transfer" port fillPattern: paintColor. self depth = 16 ifTrue: [port alphaBits: paintColor privateAlpha; combinationRule: 31] ifFalse: [port combinationRule: Form blend]. ^self]. "Can't represent actual transparency -- use stipple pattern" screen := self translucentMaskFor: paintColor alpha depth: self depth. patternWord := form pixelWordFor: paintColor. port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]). port combinationRule: Form paint ! ! !FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:02'! translateBy: delta during: aBlock "Set a translation only during the execution of aBlock." ^aBlock value: (self copyOffset: delta)! ! !FormCanvas methodsFor: 'drawing-text' stamp: 'IgorStasenko 7/18/2011 18:12'! drawString: aString from: firstIndex to: lastIndex in: bounds font: fontOrNil color: c | font portRect | port colorMap: nil. portRect := port clipRect. port clipByX1: bounds left + origin x y1: bounds top + origin y x2: bounds right + origin x y2: bounds bottom + origin y. font := fontOrNil ifNil: [TextStyle defaultFont]. port combinationRule: Form paint. font installOn: port foregroundColor: c backgroundColor: Color transparent. font displayString: aString asString on: port from: firstIndex to: lastIndex at: (bounds topLeft + origin) kern: 0. port clipRect: portRect.! ! !FormCanvas methodsFor: 'private' stamp: 'FernandoOlivero 9/12/2013 13:36'! translucentPatterns ^ self class translucentPatterns! ! !FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'! copyOffset: aPoint ^ self copyOrigin: origin + aPoint clipRect: clipRect! ! !FormCanvas methodsFor: 'private' stamp: 'tpr 9/15/2004 10:28'! setClearColor: aColor "Install a new clear color - e.g., a color is used for clearing the background" | clearColor | clearColor := aColor ifNil:[Color transparent]. clearColor isColor ifFalse:[ (clearColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color']. ^port fillPattern: clearColor; combinationRule: Form over]. "Okay, so clearColor really *is* a color" port sourceForm: nil. port combinationRule: Form over. port fillPattern: clearColor. self depth = 8 ifTrue:[ "Use a stipple pattern" port fillColor: (form balancedPatternFor: clearColor)]. ! ! !FormCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:06'! clipRect "Return the currently active clipping rectangle" ^ clipRect translateBy: origin negated! ! !FormCanvas methodsFor: 'accessing' stamp: 'ar 5/28/2000 17:11'! allocateForm: extentPoint "Allocate a new form which is similar to the receiver" ^form allocateForm: extentPoint! ! !FormCanvas methodsFor: 'initialization' stamp: 'FernandoOlivero 9/11/2013 13:29'! initializeTranslucentPatterns TranslucentPatterns := Array new: 8. #(1 2 4 8 ) do: [ :d | | mask bits pattern patternList | patternList := Array new: 5. mask := (1 bitShift: d) - 1. bits := 2 * d. [ bits >= 32 ] whileFalse: [ mask := mask bitOr: (mask bitShift: bits). "double the length of mask" bits := bits + bits ]. "0% pattern" pattern := Bitmap with: 0 with: 0. patternList at: 1 put: pattern. "25% pattern" pattern := Bitmap with: mask with: 0. patternList at: 2 put: pattern. "50% pattern" pattern := Bitmap with: mask with: mask bitInvert32. patternList at: 3 put: pattern. "75% pattern" pattern := Bitmap with: mask with: 4294967295. patternList at: 4 put: pattern. "100% pattern" pattern := Bitmap with: 4294967295 with: 4294967295. patternList at: 5 put: pattern. TranslucentPatterns at: d put: patternList ]! ! !FormCanvas methodsFor: 'accessing' stamp: 'ar 12/31/2001 03:26'! contentsOfArea: aRectangle into: aForm | bb | self flush. bb := BitBlt toForm: aForm. bb sourceForm: form; combinationRule: Form over; sourceX: (aRectangle left + origin x); sourceY: (aRectangle top + origin y); width: aRectangle width; height: aRectangle height; copyBits. ^aForm! ! !FormCanvas methodsFor: 'accessing' stamp: ''! form ^ form! ! !FormCanvas methodsFor: 'private' stamp: 'yo 6/18/2004 15:11'! privateWarp: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize "Warp the given using the appropriate transform and offset." | globalRect sourceQuad warp tfm | tfm := aTransform. globalRect := tfm localBoundsToGlobal: sourceRect. sourceQuad := (tfm sourceQuadFor: globalRect) collect:[:p| p - sourceRect topLeft]. extraOffset ifNotNil:[globalRect := globalRect translateBy: extraOffset]. warp := (WarpBlt current toForm: port destForm) combinationRule: Form paint; sourceQuad: sourceQuad destRect: (globalRect origin corner: globalRect corner+(1@1)); clipRect: port clipRect. warp cellSize: cellSize. warp sourceForm: aForm. warp warpBits! ! !FormCanvas methodsFor: 'copying' stamp: 'IgorStasenko 12/22/2012 03:26'! copyOffset: aPoint clipRect: sourceClip "Make a copy of me offset by aPoint, and further clipped by sourceClip, a rectangle in the un-offset coordinates" ^ self copyOrigin: aPoint + origin clipRect: ((sourceClip translateBy: origin) intersect: clipRect ifNone: [ 0@0 corner: 0@0 ])! ! !FormCanvas methodsFor: 'private' stamp: 'RAA 12/17/2000 13:24'! privateClipRect ^clipRect! ! !FormCanvas methodsFor: 'drawing' stamp: 'ar 5/14/2000 15:50'! fillColor: c "Note: This always fills, even if the color is transparent." self setClearColor: c. port fillRect: form boundingBox offset: origin.! ! !FormCanvas methodsFor: 'initialization' stamp: 'ar 2/17/2000 00:21'! reset origin := 0@0. "origin of the top-left corner of this cavas" clipRect := (0@0 corner: 10000@10000). "default clipping rectangle" self shadowColor: nil.! ! !FormCanvas methodsFor: 'testing' stamp: 'ar 6/22/1999 14:08'! isVisible: aRectangle "Optimization" (aRectangle right + origin x) < clipRect left ifTrue: [^ false]. (aRectangle left + origin x) > clipRect right ifTrue: [^ false]. (aRectangle bottom + origin y) < clipRect top ifTrue: [^ false]. (aRectangle top + origin y) > clipRect bottom ifTrue: [^ false]. ^ true ! ! !FormCanvas methodsFor: 'drawing-images' stamp: 'tpr 9/15/2004 10:27'! stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor "Flood this canvas with aColor wherever stencilForm has non-zero pixels" self setPaintColor: aColor. port colorMap: stencilForm maskingMap. port stencil: stencilForm at: aPoint + origin sourceRect: sourceRect.! ! !FormCanvas methodsFor: 'accessing' stamp: ''! extent ^ form extent! ! !FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 2/16/2000 22:07'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor | w h rect | "First use quick code for top and left borders and fill" self frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: topLeftColor. "Now use slow code for bevelled bottom and right borders" bottomRightColor isTransparent ifFalse: [ borderWidth isNumber ifTrue: [w := h := borderWidth] ifFalse: [w := borderWidth x. h := borderWidth y]. rect := r translateBy: origin. self setFillColor: bottomRightColor. port frameRectRight: rect width: w; frameRectBottom: rect height: h]. ! ! !FormCanvas methodsFor: 'Morphic-Base-Balloon' stamp: 'ar 11/11/1998 22:57'! asBalloonCanvas ^(BalloonCanvas on: form) setOrigin: origin clipRect: clipRect! ! !FormCanvas methodsFor: 'copying' stamp: 'nice 1/13/2010 21:21'! postCopy "The copy share same underlying Form but with its own grafPort." super postCopy. self resetGrafPort! ! !FormCanvas methodsFor: 'private' stamp: 'MarcusDenker 3/24/2012 21:31'! resetGrafPort "Private!! Create a new grafPort for a new copy." port := GrafPort toForm: form. port clipRect: clipRect. ! ! !FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:51'! copyClipRect: aRectangle ^ self copyOrigin: origin clipRect: (aRectangle translateBy: origin) ! ! !FormCanvas methodsFor: 'drawing-general' stamp: 'GaryChambers 9/8/2011 14:48'! roundShadowCornersOf: aMorph in: bounds during: aBlock aMorph wantsRoundedCorners ifFalse:[^aBlock value]. (self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds)) ifTrue: ["Don't bother with corner logic if the region is inside them" ^ aBlock value]. CornerRounder roundShadowCornersOf: aMorph on: self in: bounds displayBlock: aBlock borderWidth: aMorph borderWidthForRounding corners: aMorph roundedCorners! ! !FormCanvas methodsFor: 'other' stamp: ''! showAt: pt ^ form displayAt: pt! ! !FormCanvas methodsFor: 'drawing-text' stamp: 'IgorStasenko 7/18/2011 18:12'! drawString: aString from: firstIndex to: lastIndex in: bounds font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc | font portRect endPoint | port colorMap: nil. portRect := port clipRect. port clipByX1: bounds left + origin x y1: bounds top + origin y x2: bounds right + origin x y2: bounds bottom + origin y. font := fontOrNil ifNil: [TextStyle defaultFont]. port combinationRule: Form paint. font installOn: port foregroundColor: c backgroundColor: Color transparent. endPoint := font displayString: aString asString on: port from: firstIndex to: lastIndex at: (bounds topLeft + origin) kern: 0. underline ifTrue:[ font installOn: port foregroundColor: uc backgroundColor: Color transparent. font displayUnderlineOn: port from: (bounds topLeft + origin + (0@font ascent)) to: endPoint. ]. port clipRect: portRect.! ! !FormCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:10'! origin "Return the current origin for drawing operations" ^ origin! ! !FormCanvas methodsFor: 'drawing-text' stamp: 'IgorStasenko 7/18/2011 18:12'! drawString: aString from: firstIndex to: lastIndex autoBoundAt: aPoint font: fontOrNil color: c | font textStyle portRect bounds character width carriageReturn lineWidth lineHeight | carriageReturn := Character cr. width := lineWidth := 0. font := StandardFonts codeFont. textStyle := font textStyle. lineHeight := textStyle lineGrid. 1 to: aString size do: [:i | character := aString at: i. character = carriageReturn ifTrue: [lineWidth := lineWidth max: width. lineHeight := lineHeight + textStyle lineGrid. width := 0] ifFalse: [width := width + (font widthOf: character)]]. lineWidth := lineWidth max: width. bounds := aPoint extent: (lineWidth @ lineHeight). port colorMap: nil. portRect := port clipRect. port clipByX1: bounds left + origin x y1: bounds top + origin y x2: bounds right + origin x y2: bounds bottom + origin y. port combinationRule: Form paint. port fill: bounds fillColor: Color white rule: Form paint. font installOn: port foregroundColor: c backgroundColor: Color white. aString lines doWithIndex: [:line :index | font displayString: line on: port from: 1 to: line size at: (bounds topLeft + origin + (0@(index-1)*textStyle lineGrid)) kern: 0. ]. port clipRect: portRect.! ! !FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 02:55'! translateTo: newOrigin clippingTo: aRectangle during: aBlock "Set a new origin and clipping rectangle only during the execution of aBlock." aBlock value: (self copyOrigin: newOrigin clipRect: aRectangle)! ! !FormCanvas methodsFor: 'drawing' stamp: 'ar 2/16/2000 22:07'! line: pt1 to: pt2 width: w color: c | offset | offset := origin - (w // 2) asPoint. self setFillColor: c. port width: w; height: w; drawFrom: (pt1 + offset) to: (pt2 + offset)! ! !FormCanvas methodsFor: 'private' stamp: 'RAA 12/17/2000 13:25'! privatePort ^port! ! !FormCanvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:58'! roundCornersOf: aMorph in: bounds during: aBlock aMorph wantsRoundedCorners ifFalse:[^aBlock value]. (self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds)) ifTrue: ["Don't bother with corner logic if the region is inside them" ^ aBlock value]. CornerRounder roundCornersOf: aMorph on: self in: bounds displayBlock: aBlock borderWidth: aMorph borderWidthForRounding corners: aMorph roundedCorners! ! !FormCanvas methodsFor: 'drawing-rectangles' stamp: 'IgorStasenko 7/18/2011 18:14'! fillRectangle: aRectangle basicFillStyle: aFillStyle "Fill the given rectangle with the given, non-composite, fill style." | pattern | (aFillStyle isKindOf: InfiniteForm) ifTrue: [ ^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle ]. (aFillStyle isSolidFill) ifTrue:[^self fillRectangle: aRectangle color: aFillStyle asColor]. "We have a very special case for filling with infinite forms" (aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[ pattern := aFillStyle form. (aFillStyle direction = (pattern width @ 0) and:[aFillStyle normal = (0@pattern height)]) ifTrue:[ "Can use an InfiniteForm" ^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)]. ]. "Use a BalloonCanvas instead" self balloonFillRectangle: aRectangle fillStyle: aFillStyle.! ! !FormCanvas methodsFor: 'other' stamp: ''! flushDisplay Display deferUpdates: false; forceDisplayUpdate.! ! !FormCanvas methodsFor: 'drawing-ovals' stamp: 'di 5/25/2001 01:40'! fillOval: r color: fillColor borderWidth: borderWidth borderColor: borderColor | rect | "draw the border of the oval" rect := (r translateBy: origin) truncated. (borderWidth = 0 or: [borderColor isTransparent]) ifFalse:[ self setFillColor: borderColor. (r area > 10000 or: [fillColor isTranslucent]) ifTrue: [port frameOval: rect borderWidth: borderWidth] ifFalse: [port fillOval: rect]]. "faster this way" "fill the inside" fillColor isTransparent ifFalse: [self setFillColor: fillColor. port fillOval: (rect insetBy: borderWidth)]. ! ! !FormCanvas methodsFor: 'other' stamp: 'StephaneDucasse 2/9/2011 14:51'! forceToScreen: rect ^Display forceToScreen: rect. ! ! !FormCanvas methodsFor: 'private' stamp: 'ar 5/14/2001 23:34'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule.! ! !FormCanvas methodsFor: 'printing' stamp: 'ar 5/28/2000 17:07'! printOn: aStream super printOn: aStream. aStream nextPutAll:' on: '; print: form.! ! !FormCanvas methodsFor: 'drawing' stamp: 'ar 9/9/2000 22:18'! render: anObject "Do some 3D operations with the object if possible" ^self asBalloonCanvas render: anObject! ! !FormCanvas methodsFor: 'drawing-support' stamp: 'IgorStasenko 7/18/2011 18:21'! transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize "Note: This method has been originally copied from TransformationMorph." | innerRect patchRect sourceQuad warp start subCanvas rule| (aDisplayTransform isPureTranslation) ifTrue:[ ^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated clipRect: aClipRect) ]. "Prepare an appropriate warp from patch to innerRect" innerRect := aClipRect. patchRect := (aDisplayTransform globalBoundsToLocal: innerRect) truncated. sourceQuad := (aDisplayTransform sourceQuadFor: innerRect) collect: [:p | p - patchRect topLeft]. warp := self warpFrom: sourceQuad toRect: innerRect. warp cellSize: cellSize. "Render the submorphs visible in the clipping rectangle, as patchForm" start := (self depth = 1) "If this is true B&W, then we need a first pass for erasure." ifTrue: [1] ifFalse: [2]. "If my depth has alpha, do blending rather than paint" rule := self depth = 32 ifTrue: [Form blend] ifFalse: [Form paint]. start to: 2 do: [:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W" subCanvas := self class extent: patchRect extent depth: self depth. i=1 ifTrue: [ warp combinationRule: Form erase ] ifFalse: [ warp combinationRule: rule]. subCanvas translateBy: patchRect topLeft negated during:[:offsetCanvas| aBlock value: offsetCanvas]. warp sourceForm: subCanvas form; warpBits. warp sourceForm: nil. subCanvas := nil "release space for next loop"] ! ! !FormCanvas methodsFor: 'private' stamp: 'MarcusDenker 3/24/2012 21:31'! setForm: aForm self reset. form := aForm. port := GrafPort toForm: form. ! ! !FormCanvas methodsFor: 'other' stamp: 'ar 5/28/2000 12:12'! warpFrom: sourceQuad toRect: destRect ^ (WarpBlt current toForm: port destForm) combinationRule: Form paint; sourceQuad: sourceQuad destRect: (destRect translateBy: origin); clipRect: clipRect! ! !FormCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:21'! image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule alpha: sourceAlpha.! ! !FormCanvas methodsFor: 'private' stamp: 'ar 6/22/1999 14:06'! setOrigin: aPoint clipRect: aRectangle origin := aPoint. clipRect := aRectangle. port clipRect: aRectangle. ! ! !FormCanvas methodsFor: 'drawing-text' stamp: 'IgorStasenko 7/18/2011 18:12'! drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: c | font | port colorMap: nil. font := fontOrNil ifNil: [TextStyle defaultFont]. port combinationRule: Form paint. font installOn: port foregroundColor: c backgroundColor: Color transparent. font displayString: aString on: port from: firstIndex to: lastIndex at: (origin + aPoint) kern: 0.! ! !FormCanvas methodsFor: 'private' stamp: 'FernandoOlivero 9/9/2013 11:51'! setFillColor: aColor "Install a new color used for filling." | screen patternWord fillColor | fillColor := aColor. fillColor ifNil:[fillColor := Color transparent]. fillColor isColor ifFalse:[ (fillColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color']. ^port fillPattern: fillColor; combinationRule: Form over]. "Okay, so fillColor really *is* a color" port sourceForm: nil. fillColor isTranslucent ifFalse:[ port combinationRule: Form over. port fillPattern: fillColor. self depth = 8 ifTrue:[ "In 8 bit depth it's usually a good idea to use a stipple pattern" port fillColor: (form balancedPatternFor: fillColor)]. ^self]. "fillColor is some translucent color" self depth > 8 ifTrue:[ "BitBlt setup for alpha masked transfer" port fillPattern: fillColor. self depth = 16 ifTrue:[port alphaBits: fillColor privateAlpha; combinationRule: 30] ifFalse:[port combinationRule: Form blend]. ^self]. "Can't represent actual transparency -- use stipple pattern" screen := self translucentMaskFor: fillColor alpha depth: self depth. patternWord := form pixelWordFor: fillColor. port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]). port combinationRule: Form paint. ! ! !FormCanvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:57'! drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc "Generalize for the BalloonCanvas" ^self drawPolygon: vertices fillStyle: aColor borderWidth: bw borderColor: bc! ! !FormCanvas methodsFor: 'drawing-rectangles' stamp: 'IgorStasenko 12/22/2012 03:25'! infiniteFillRectangle: aRectangle fillStyle: aFillStyle | additionalOffset rInPortTerms clippedPort targetTopLeft clipOffset ex | "this is a bit of a kludge to get the form to be aligned where I *think* it should be. something better is needed, but not now" additionalOffset := 0@0. ex := aFillStyle form extent. rInPortTerms := (aRectangle intersect: aFillStyle boundingBox ifNone: ["nothing to draw" ^ self ]) translateBy: origin. clippedPort := port clippedBy: rInPortTerms. targetTopLeft := clippedPort clipRect topLeft truncateTo: ex. clipOffset := rInPortTerms topLeft - targetTopLeft. additionalOffset := (clipOffset \\ ex) - ex. ^aFillStyle displayOnPort: clippedPort offsetBy: additionalOffset ! ! !FormCanvas methodsFor: 'drawing-ovals' stamp: 'IgorStasenko 7/18/2011 18:13'! fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc "Fill the given oval." self flag: #bob. "this and its siblings could be moved up to Canvas with the right #balloonFillOval:..." (aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[ self flag: #fixThis. ^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc]. (aFillStyle isSolidFill) ifTrue:[ ^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc]. "Use a BalloonCanvas instead" self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc! ! !FormCanvas methodsFor: 'drawing-ovals' stamp: 'RAA 11/6/2000 15:21'! balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc self asBalloonCanvas fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc! ! !FormCanvas methodsFor: 'private' stamp: 'FernandoOlivero 9/12/2013 13:36'! translucentMaskFor: alphaValue depth: d "Return a pattern representing a mask usable for stipple transparency" ^(self translucentPatterns at: d) at: ((alphaValue min: 1.0 max: 0.0) * 4) rounded + 1 ! ! !FormCanvas methodsFor: 'drawing' stamp: 'IgorStasenko 7/18/2011 18:15'! paragraph: para bounds: bounds color: c | scanner | self setPaintColor: c. scanner := (port clippedBy: (bounds translateBy: origin)) displayScannerFor: para foreground: c background: Color transparent ignoreColorChanges: false. para displayOn: (self copyClipRect: bounds) using: scanner at: origin+ bounds topLeft. ! ! !FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 5/14/2000 15:50'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor | rect | rect := r translateBy: origin. "draw the border of the rectangle" borderColor isTransparent ifFalse:[ self setFillColor: borderColor. (r area > 10000 or: [fillColor isTranslucent]) ifTrue: [ port frameRect: rect borderWidth: borderWidth. ] ifFalse: ["for small rectangles, it's faster to fill the entire outer rectangle than to compute and fill the border rects" port fillRect: rect offset: origin]]. "fill the inside" fillColor isTransparent ifFalse: [self setFillColor: fillColor. port fillRect: (rect insetBy: borderWidth) offset: origin].! ! !FormCanvas methodsFor: 'drawing-images' stamp: 'ar 12/30/2001 16:36'! warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize "Warp the given using the appropriate transform and offset." | tfm | tfm := (MatrixTransform2x3 withOffset: origin) composedWithLocal: aTransform. ^self privateWarp: aForm transform: tfm at: extraOffset sourceRect: sourceRect cellSize: cellSize! ! !FormCanvas methodsFor: 'other' stamp: 'StephaneDucasse 10/25/2013 16:17'! showAt: pt invalidRects: updateRects | blt | blt := (BitBlt toForm: Display) sourceForm: form; combinationRule: Form over. updateRects do: [:rect | blt sourceRect: rect; destOrigin: rect topLeft + pt; copyBits]! ! !FormCanvas methodsFor: 'copying' stamp: 'IgorStasenko 12/22/2012 03:26'! copyOrigin: aPoint clipRect: aRectangle "Return a copy of this canvas with the given origin. The clipping rectangle of this canvas is the intersection of the given rectangle and the receiver's current clipping rectangle. This allows the clipping rectangles of nested clipping morphs to be composed." ^ self copy setOrigin: aPoint clipRect: (clipRect intersect: aRectangle ifNone: ["well, now we will clip everything" 0@0 corner: 0@0])! ! !FormCanvas methodsFor: 'drawing-polygons' stamp: 'IgorStasenko 7/18/2011 18:11'! drawPolygon: vertices fillStyle: aFillStyle borderWidth: bw borderColor: bc "Use a BalloonCanvas" self asBalloonCanvas drawPolygon: vertices asArray fillStyle: aFillStyle borderWidth: bw borderColor: bc! ! !FormCanvas methodsFor: 'accessing' stamp: ''! depth ^ form depth ! ! !FormCanvas class methodsFor: 'caching' stamp: 'FernandoOlivero 9/12/2013 13:35'! initializeTranslucentPatterns TranslucentPatterns := Array new: 8. #(1 2 4 8 ) do: [ :d | | mask bits pattern patternList | patternList := Array new: 5. mask := (1 bitShift: d) - 1. bits := 2 * d. [ bits >= 32 ] whileFalse: [ mask := mask bitOr: (mask bitShift: bits). "double the length of mask" bits := bits + bits ]. "0% pattern" pattern := Bitmap with: 0 with: 0. patternList at: 1 put: pattern. "25% pattern" pattern := Bitmap with: mask with: 0. patternList at: 2 put: pattern. "50% pattern" pattern := Bitmap with: mask with: mask bitInvert32. patternList at: 3 put: pattern. "75% pattern" pattern := Bitmap with: mask with: 4294967295. patternList at: 4 put: pattern. "100% pattern" pattern := Bitmap with: 4294967295 with: 4294967295. patternList at: 5 put: pattern. TranslucentPatterns at: d put: patternList ]! ! !FormCanvas class methodsFor: 'instance creation' stamp: ''! extent: extent depth: depth ^ self new setForm: (Form extent: extent depth: depth)! ! !FormCanvas class methodsFor: 'instance creation' stamp: 'jm 8/2/97 13:54'! on: aForm ^ self new setForm: aForm ! ! !FormCanvas class methodsFor: 'instance creation' stamp: ''! extent: aPoint ^ self extent: aPoint depth: Display depth ! ! !FormCanvas class methodsFor: 'caching' stamp: 'FernandoOlivero 9/12/2013 13:36'! translucentPatterns TranslucentPatterns isNil ifTrue:[ self initializeTranslucentPatterns ]. ^ TranslucentPatterns ! ! !FormCanvas class methodsFor: 'instance creation' stamp: 'nk 7/4/2003 10:11'! extent: extent depth: depth origin: aPoint clipRect: aRectangle ^ self new setForm: (Form extent: extent depth: depth); setOrigin: aPoint clipRect: aRectangle; yourself! ! !FormTest commentStamp: 'ar 7/21/2007 21:39'! Various tests for class form.! !FormTest methodsFor: 'tests' stamp: 'nice 1/5/2010 15:59'! testIsAllWhite "self run: #testIsAllWhite" "Make sure #isAllWhite works for all bit depths" #(-32 -16 -8 -4 -2 -1 1 2 4 8 16 32) do:[:d| | form | form := Form extent: 16@16 depth: d. form fillBlack. self deny: form isAllWhite. form fillWhite. self assert: form isAllWhite. ]. ! ! !FormTest methodsFor: 'tests' stamp: 'HenrikSperreJohansen 5/27/2010 23:26'! test32BitTranslucentBlackIsBlack |form| form := Form extent: 1@1 depth: 32. form colorAt: 0@0 put: (Color black alpha: 0.0). self assert: 0 equals: (form pixelValueAt: 0@0)! ! !Fraction commentStamp: 'VeronicaUquillas 6/11/2010 14:04'! Fraction provides methods for dealing with fractions like 1/3 as fractions (not as 0.33333...). All public arithmetic operations answer reduced fractions (see examples). instance variables: 'numerator denominator ' Examples: (note the parentheses required to get the right answers in Smalltalk and Pharo): (2/3) + (2/3) (2/3) + (1/2) "answers shows the reduced fraction" (2/3) raisedToInteger: 5 "fractions also can have exponents" ! !Fraction methodsFor: 'truncation and round off' stamp: 'HenrikSperreJohansen 1/19/2012 15:44'! asSmallerPowerOfTwo "Convert the receiver into a power of two which is not larger than the receiver" | quotient | (numerator = 0 or: [numerator sign ~= denominator sign]) ifTrue: [^DomainError signal: 'Value outside (0 , infinity)' from: 0]. ^(quotient := denominator // numerator) > 0 ifTrue: [ "If my quotient is a power of two, we, we need to check remainder, to see if we should shift by highbit or not. (This is equivalent to Integer asSmallerPowerOfTwo returning self when receiver is power of two) " (quotient isPowerOfTwo and: [denominator \\ numerator = 0]) ifTrue: [Fraction numerator: 1 denominator: quotient] ifFalse:[Fraction numerator: 1 denominator: (1 bitShift: quotient highBit)]] ifFalse: [1 bitShift: ((numerator // denominator) highBit -1)]! ! !Fraction methodsFor: 'testing' stamp: 'ClementBera 9/27/2013 17:38'! isPowerOfTwo |reduced| reduced := self reduced. ^(reduced numerator = 1 and: [reduced denominator isPowerOfTwo]) or: [reduced denominator = 1 and: [reduced numerator isPowerOfTwo]]! ! !Fraction methodsFor: 'mathematical functions' stamp: 'LC 4/22/1998 14:03'! raisedToInteger: anInteger "See Number | raisedToInteger:" anInteger = 0 ifTrue: [^ 1]. anInteger < 0 ifTrue: [^ self reciprocal raisedToInteger: anInteger negated]. ^ Fraction numerator: (numerator raisedToInteger: anInteger) denominator: (denominator raisedToInteger: anInteger)! ! !Fraction methodsFor: 'mathematical functions' stamp: 'jmv 10/13/2011 21:38'! nthRoot: aPositiveInteger "Answer the nth root of the receiver." | d n | n := numerator nthRoot: aPositiveInteger. d := denominator nthRoot: aPositiveInteger. "The #sqrt method in integer will only answer a Float if there's no exact square root. So, we need a float anyway." (n isInfinite or: [ d isInfinite ]) ifTrue: [ ^self asFloat nthRoot: aPositiveInteger ]. ^n / d! ! !Fraction methodsFor: 'private' stamp: ''! denominator ^denominator! ! !Fraction methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:37'! < aNumber aNumber isFraction ifTrue: [^ numerator * aNumber denominator < (aNumber numerator * denominator)]. ^ aNumber adaptToFraction: self andCompare: # 0 or: [roundedFractionPart > 0]]) ifTrue: [aStream nextPut: $-]. integerPart printOn: aStream. aStream nextPut: $.. roundedFractionPart printOn: aStream base: 10 length: placesDesired padded: true].! ! !Fraction methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPut: $(. numerator printOn: aStream. aStream nextPut: $/. denominator printOn: aStream. aStream nextPut: $). ! ! !Fraction methodsFor: 'truncation and round off' stamp: ''! truncated "Refer to the comment in Number|truncated." ^numerator quo: denominator! ! !Fraction methodsFor: 'converting' stamp: 'nice 2/13/2010 22:58'! asScaledDecimal "Convert the receiver to a ScaledDecimal. If there is a finite decimal representation of the receiver, then use the exact number of decimal places required. Else, use a default number of decimals." | pow2 pow5 q q5 | pow2 := denominator lowBit - 1. q := denominator bitShift: pow2 negated. pow5 := 0. [q = 1] whileFalse: [ q5 := q // 5. (q - (5 * q5)) = 0 ifFalse: [^super asScaledDecimal]. q := q5. pow5 := pow5 + 1]. ^self asScaledDecimal: (pow2 max: pow5)! ! !Fraction methodsFor: 'converting' stamp: ''! asFraction "Answer the receiver itself." ^self! ! !Fraction methodsFor: 'mathematical functions' stamp: 'LC 4/22/1998 14:05'! squared "See Fraction (Number) | squared" ^ Fraction numerator: numerator squared denominator: denominator squared! ! !Fraction methodsFor: 'printing' stamp: 'laza 3/29/2004 12:56'! printOn: aStream base: base aStream nextPut: $(. numerator printOn: aStream base: base. aStream nextPut: $/. denominator printOn: aStream base: base. aStream nextPut: $). ! ! !Fraction methodsFor: 'comparing' stamp: 'nice 6/11/2009 02:52'! hash "Hash is reimplemented because = is implemented. Care is taken that a Fraction equal to a Float also have an equal hash" | tmp | denominator isPowerOfTwo ifTrue: [ "If denominator is a power of two, I can be exactly equal to a Float" tmp := self asFloat. tmp isFinite ifTrue: [^tmp hash]]. "Else, I cannot be exactly equal to a Float, use own hash algorithm. (Assume the fraction is already reduced)" ^numerator hash bitXor: denominator hash! ! !Fraction methodsFor: 'comparing' stamp: 'nice 1/4/2009 17:35'! > aNumber aNumber isFraction ifTrue: [^ numerator * aNumber denominator > (aNumber numerator * denominator)]. ^ aNumber adaptToFraction: self andCompare: #>! ! !Fraction methodsFor: 'mathematical functions' stamp: 'nice 7/15/2011 14:28'! ln "This function is defined because super ln might overflow." | res int | self <= 0 ifTrue: [^DomainError signal: 'ln is only defined for x > 0' from: 0]. "Test self < 1 before converting to float in order to avoid precision loss due to gradual underflow." numerator < denominator ifTrue: [^self reciprocal ln negated]. res := super ln. res isFinite ifTrue: [^res]. ^numerator ln - denominator ln! ! !Fraction methodsFor: 'mathematical functions' stamp: 'jmv 10/13/2011 20:16'! sqrt | d n | n := numerator sqrt. d := denominator sqrt. "The #sqrt method in integer will only answer a Float if there's no exact square root. So, we need a float anyway." (n isInfinite or: [ d isInfinite ]) ifTrue: [ ^self asFloat sqrt ]. ^n / d! ! !Fraction methodsFor: 'truncation and round off' stamp: 'HenrikSperreJohansen 1/19/2012 15:43'! asLargerPowerOfTwo "Convert the receiver into a power of two which is not less than the receiver" | quotient | (numerator = 0 or: [numerator sign ~= denominator sign]) ifTrue: [^DomainError signal: 'Value outside (0 , infinity)' from: 0]. ^(quotient := denominator // numerator) > 0 ifTrue: [Fraction numerator: 1 denominator: (1 bitShift: (quotient highBit -1))] ifFalse: [quotient := numerator // denominator. "If my quotient is a power of two, we, we need to check remainder, to see if we should shift by highbit or not. (This is equivalent to Integer asLargerPowerOfTwo returning self when receiver is power of two) " (quotient isPowerOfTwo and: [numerator \\ denominator = 0]) ifTrue: [quotient] ifFalse: [1 bitShift: (quotient highBit )]]! ! !Fraction methodsFor: 'private' stamp: ''! numerator ^numerator! ! !Fraction methodsFor: 'arithmetic' stamp: ''! negated "Refer to the comment in Number|negated." ^ Fraction numerator: numerator negated denominator: denominator! ! !Fraction methodsFor: 'comparing' stamp: 'nice 1/4/2009 17:35'! >= aNumber aNumber isFraction ifTrue: [^ numerator * aNumber denominator >= (aNumber numerator * denominator)]. ^ aNumber adaptToFraction: self andCompare: #>=! ! !Fraction methodsFor: 'private' stamp: 'GabrielOmarCotelli 5/23/2009 20:36'! reciprocal numerator abs = 1 ifTrue: [^denominator * numerator]. ^self class numerator: denominator denominator: numerator! ! !Fraction methodsFor: 'private' stamp: 'tfei 4/12/1999 12:45'! setNumerator: n denominator: d d = 0 ifTrue: [^(ZeroDivide dividend: n) signal] ifFalse: [numerator := n asInteger. denominator := d asInteger abs. "keep sign in numerator" d < 0 ifTrue: [numerator := numerator negated]]! ! !Fraction methodsFor: 'mathematical functions' stamp: 'nice 7/15/2011 14:28'! log "This function is defined because super log might overflow." | res int | self <= 0 ifTrue: [^DomainError signal: 'log is only defined for x > 0' from: 0]. "Test self < 1 before converting to float in order to avoid precision loss due to gradual underflow." numerator < denominator ifTrue: [^self reciprocal log negated]. res := super log. res isFinite ifTrue: [^res]. ^numerator log - denominator log! ! !Fraction methodsFor: 'testing' stamp: 'ul 11/29/2010 20:05'! negative ^numerator negative! ! !Fraction methodsFor: 'converting' stamp: 'nice 11/21/2011 22:34'! asFloat "Answer a Float that closely approximates the value of the receiver. This implementation will answer the closest floating point number to the receiver. In case of a tie, it will use the IEEE 754 round to nearest even mode. In case of overflow, it will answer +/- Float infinity." | a b mantissa exponent hasTruncatedBits lostBit n ha hb hm | a := numerator abs. b := denominator. "denominator is always positive" ha := a highBitOfMagnitude. hb := b highBitOfMagnitude. "Number of bits to keep in mantissa plus one to handle rounding." n := 1 + Float precision. "If both numerator and denominator are represented exactly in floating point number, then fastest thing to do is to use hardwired float division." (ha < n and: [hb < n]) ifTrue: [^numerator asFloat / denominator asFloat]. "Shift the fraction by a power of two exponent so as to obtain a mantissa with n bits. First guess is rough, the mantissa might have n+1 bits." exponent := ha - hb - n. exponent >= 0 ifTrue: [b := b bitShift: exponent] ifFalse: [a := a bitShift: exponent negated]. mantissa := a quo: b. hasTruncatedBits := a > (mantissa * b). hm := mantissa highBit. "Check for gradual underflow, in which case the mantissa will loose bits. Keep at least one bit to let underflow preserve the sign of zero." lostBit := Float emin - (exponent + hm - 1). lostBit > 0 ifTrue: [n := n - lostBit max: 1]. "Remove excess bits in the mantissa." hm > n ifTrue: [exponent := exponent + hm - n. hasTruncatedBits := hasTruncatedBits or: [mantissa anyBitOfMagnitudeFrom: 1 to: hm - n]. mantissa := mantissa bitShift: n - hm]. "Check if mantissa must be rounded upward. The case of tie (mantissa odd & hasTruncatedBits not) will be handled by Integer>>asFloat." (hasTruncatedBits and: [mantissa odd]) ifTrue: [mantissa := mantissa + 1]. ^ (self positive ifTrue: [mantissa asFloat] ifFalse: [mantissa asFloat negated]) timesTwoPower: exponent! ! !Fraction methodsFor: 'printing' stamp: 'laza 3/29/2004 13:25'! storeOn: aStream base: base aStream nextPut: $(. numerator storeOn: aStream base: base. aStream nextPut: $/. denominator storeOn: aStream base: base. aStream nextPut: $). ! ! !Fraction methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:41'! = aNumber aNumber isNumber ifFalse: [^ false]. aNumber isFraction ifTrue: [numerator = 0 ifTrue: [^ aNumber numerator = 0]. ^ (numerator * aNumber denominator) = (aNumber numerator * denominator) "Note: used to just compare num and denom, but this fails for improper fractions"]. ^ aNumber adaptToFraction: self andCompare: #=! ! !Fraction methodsFor: 'converting' stamp: ''! isFraction ^ true! ! !Fraction methodsFor: 'converting' stamp: 'nice 9/7/2011 21:56'! adaptToInteger: rcvr andSend: selector "If I am involved in arithmetic with an Integer, convert it to a Fraction." ^ (Fraction numerator: rcvr denominator: 1) perform: selector with: self! ! !Fraction methodsFor: 'private' stamp: ''! reduced | gcd numer denom | numerator = 0 ifTrue: [^0]. gcd := numerator gcd: denominator. numer := numerator // gcd. denom := denominator // gcd. denom = 1 ifTrue: [^numer]. ^Fraction numerator: numer denominator: denom! ! !Fraction methodsFor: 'truncation and round off' stamp: 'GuillermoPolito 6/22/2012 14:49'! round: numberOfWishedDecimal ^self asFloat round: numberOfWishedDecimal! ! !Fraction methodsFor: 'self evaluating' stamp: 'apb 4/20/2006 18:41'! isSelfEvaluating ^ true! ! !Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'! * aNumber "Answer the result of multiplying the receiver by aNumber." | d1 d2 | aNumber isFraction ifTrue: [d1 := numerator gcd: aNumber denominator. d2 := denominator gcd: aNumber numerator. (d2 = denominator and: [d1 = aNumber denominator]) ifTrue: [^ numerator // d1 * (aNumber numerator // d2)]. ^ Fraction numerator: numerator // d1 * (aNumber numerator // d2) denominator: denominator // d2 * (aNumber denominator // d1)]. ^ aNumber adaptToFraction: self andSend: #*! ! !Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'! / aNumber "Answer the result of dividing the receiver by aNumber." aNumber isFraction ifTrue: [^self * aNumber reciprocal]. ^ aNumber adaptToFraction: self andSend: #/! ! !Fraction methodsFor: 'comparing' stamp: 'nice 1/4/2009 17:34'! <= aNumber aNumber isFraction ifTrue: [^ numerator * aNumber denominator <= (aNumber numerator * denominator)]. ^ aNumber adaptToFraction: self andCompare: #<=! ! !Fraction class methodsFor: 'instance creation' stamp: 'YuriyTymchuk 10/29/2013 11:10'! readFrom: stringOrStream "Answer a Fraction as described on aStream with following rules: - numerator can specify a different radix (like '16rABC'). - fraction sign '/' is optional, and must immediately follow numerator without space. - denominator must immediately follow fraction sign and can specify a different radix (like 16rABC). If stringOrStream does not start with a valid number description, fail." ^(NumberParser on: stringOrStream) nextFraction! ! !Fraction class methodsFor: 'instance creation' stamp: 'di 8/31/1999 10:16'! numerator: numInteger denominator: denInteger "Answer an instance of me (numInteger/denInteger). NOTE: This primitive initialization method will not reduce improper fractions, so normal usage should be coded as, eg, (Fraction numerator: a denominator: b) reduced or, more simply, as a / b." ^self new setNumerator: numInteger denominator: denInteger! ! !FractionTest commentStamp: 'TorstenBergmann 2/5/2014 08:36'! SUnit tests for fractions! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'CamilloBruni 8/31/2013 20:23'! testDegreeCos "self run: #testDegreeCos" (4 / 3) degreeCos. -361 / 3 to: 359 / 3 do: [ :i | self assert: (i degreeCos closeTo: i degreesToRadians cos) ]! ! !FractionTest methodsFor: 'private' stamp: 'jmv 10/11/2011 22:12'! assert: a classAndValueEquals: b self assert: a class = b class. self assert: a = b! ! !FractionTest methodsFor: 'tests - conversions' stamp: 'nice 6/3/2011 21:32'! testFloor self assert: (3 / 2) floor = 1. self assert: (-3 / 2) floor = -2.! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/13/2011 21:38'! testInexactRaisedTo " FractionTest new testInexactRaisedTo " self assert: (((1 << 1024 + 1) / (1 << 1024 + 3)) raisedTo: 1/3) = 1.0. self assert: (((1 << 1024 + 1) / (1 << 1024 + 3)) negated raisedTo: 1/3) = -1.0! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/13/2011 21:48'! testSqrtErrorConditions " FractionTest new testSqrtErrorConditions " self should: [ (-1/4) sqrt ] raise: DomainError. self should: [ ((1 << 1024 + 1) / (1 << 1024 + 3)) negated sqrt ] raise: DomainError! ! !FractionTest methodsFor: 'tests - conversions' stamp: 'HenrikSperreJohansen 1/19/2012 16:15'! testAsSmallerPowerOfTwo "SmallIntegers, Fraction value < 1" "Exact power of two" self assert: (1/2) asSmallerPowerOfTwo equals: 1/2. "Non-reduced exact power of two" self assert: (Fraction numerator: 2 denominator: 4) asSmallerPowerOfTwo equals: 1/2. "Not power of two" self assert: (2 / 5) asSmallerPowerOfTwo equals: 1/4. "Non-reduced non-power of two" self assert: (Fraction numerator: 10 denominator: 25) asSmallerPowerOfTwo equals: 1/4. "SmallIntegers, Fraction value > 1" "Exact power of two" self assert: (Fraction numerator: 2 denominator: 1) asSmallerPowerOfTwo equals: 2. "Non-reduced exact power of two" self assert: (Fraction numerator: 4 denominator: 2) asSmallerPowerOfTwo equals: 2. "Not power of two" self assert: (11 / 2) asSmallerPowerOfTwo equals: 4. "Non-reduced non-power of two" self assert: (Fraction numerator: 44 denominator: 8) asSmallerPowerOfTwo equals: 4. "LargeIntegers, Fraction value < 1" "Exact power of two" self assert: (1/(2 raisedTo:80)) asSmallerPowerOfTwo equals: 1/(2 raisedTo: 80). "Non-reduced exact power of two" self assert: (Fraction numerator: (2 raisedTo: 80) denominator: (2 raisedTo: 160)) asSmallerPowerOfTwo equals: 1/(2 raisedTo: 80). "Not power of two" self assert: (1/((2 raisedTo:80) - 1)) asSmallerPowerOfTwo equals: 1/(2 raisedTo: 80). "Non-reduced non-power of two" self assert: (Fraction numerator: (2 raisedTo: 80) denominator: (2 raisedTo: 160) - 1) asSmallerPowerOfTwo equals: 1/(2 raisedTo: 80). "LargeIntegers, Fraction value > 1" "Exact power of two" self assert: (Fraction numerator: (2 raisedTo:80) denominator: 1) asSmallerPowerOfTwo equals: (2 raisedTo: 80). "Non-reduced exact power of two" self assert: (Fraction numerator: (2 raisedTo: 160) denominator: (2 raisedTo: 80)) asSmallerPowerOfTwo equals: (2 raisedTo: 80). "Not power of two" self assert: (Fraction numerator: (2 raisedTo:80) +1 denominator: 1) asSmallerPowerOfTwo equals: (2 raisedTo: 80). "Non-reduced non-power of two" self assert: (Fraction numerator: (2 raisedTo: 160) +1 denominator: (2 raisedTo: 80)) asSmallerPowerOfTwo equals: (2 raisedTo: 80). "Error condition: numerator is 0" self should: [(Fraction numerator: 0 denominator: 1) asSmallerPowerOfTwo] raise: DomainError. "Errro condition: Negative fraction" "SmallIntegers, variations of negated numerator/denominator, and reduced/ non-reduced " self should: [(Fraction numerator: 1 negated denominator: 2) asSmallerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: 1 denominator: 2 negated) asSmallerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: 2 negated denominator: 4) asSmallerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: 2 denominator: 4 negated) asSmallerPowerOfTwo] raise: DomainError. "LargeNegativeIntegers, variations of negated numerator/denominator, and reduced/ non-reduced " self should: [(Fraction numerator: 1 negated denominator: (2 raisedTo: 80)) asSmallerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: 1 denominator:(2 raisedTo: 80) negated) asSmallerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: (2 raisedTo: 80) negated denominator: (2 raisedTo: 160)) asSmallerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: (2 raisedTo: 80) denominator: (2 raisedTo: 160) negated) asSmallerPowerOfTwo] raise: DomainError ! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'nice 12/11/2012 19:56'! testFloorLog self assert: (1/100 floorLog: 10) = -2. self assert: (((2 raisedTo: Float emax + 11)/3) floorLog: 10) = ((Float emax + 11)*2 log - 3 log) floor description: 'Fraction>>log should not overflow'. self assert: ((3/(2 raisedTo: Float precision - Float emin)) floorLog: 10) = ((Float emin - Float precision)*2 log + 3 log) floor description: 'Fraction>>log should not underflow'! ! !FractionTest methodsFor: 'tests - reading' stamp: 'nice 10/30/2011 16:46'! testReadFrom self assert: (Fraction readFromString: '3') = 3 description: 'denominator is optional'. self assert: (Fraction readFromString: '2/3') = (2/3) description: 'fraction and denominator must follow numerator'. self assert: (Fraction readFromString: '-2/3') = (-2/3) description: 'numerator can specify a minus sign'. .self assert: (Fraction readFromString: '2/-5') = (-2/5) description: 'denominator can specify a minus sign'. self assert: (Fraction readFromString: '-3/-7') = (3/7) description: 'numerator and denominator can both specify a minus sign'. self assert: (Fraction readFromString: '2e3/3') = (2000/3) description: 'numerator can specify an exponent'. self assert: (Fraction readFromString: '3/1e4') = (3/10000) description: 'denominator can specify an exponent'. self assert: (Fraction readFromString: '16rA0/3') = (160/3) description: 'numerator can specify a radix'. self assert: (Fraction readFromString: '1/3r22') = (1/8) description: 'denominator can specify a radix'.! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/11/2011 22:27'! testExactRaisedTo " FractionTest new testExactRaisedTo " | f | self assert: (4/9 raisedTo: 1/2) classAndValueEquals: 2/3. self assert: (9/4 raisedTo: 1/2) classAndValueEquals: 3/2. #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b | f := a / b. self assert: (f squared raisedTo: 1/2) classAndValueEquals: f. self assert: (f negated squared raisedTo: 1/2) classAndValueEquals: f. f := b / a. self assert: (f squared raisedTo: 1/2) classAndValueEquals: f. self assert: (f negated squared raisedTo: 1/2) classAndValueEquals: f ]. self assert: (8/27 raisedTo: 1/3) classAndValueEquals: 2/3. self assert: (27/8 raisedTo: 1/3) classAndValueEquals: 3/2. #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b | f := a / b. self assert: ((f raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f. self assert: ((f negated raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f negated. f := b / a. self assert: ((f raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f. self assert: ((f negated raisedTo: 3) raisedTo: 1/3) classAndValueEquals: f negated ]. self assert: (4/9 raisedTo: 3/2) classAndValueEquals: 8/27. self assert: (8/27 raisedTo: 2/3) classAndValueEquals: 4/9. #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b | f := a / b. self assert: ((f raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f. self assert: ((f raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f. self assert: ((f negated raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f. self assert: ((f negated raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f. f := b / a. self assert: ((f raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f. self assert: ((f raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f. self assert: ((f negated raisedTo: 3) raisedTo: 2/3) classAndValueEquals: f*f. self assert: ((f negated raisedTo: 2) raisedTo: 3/2) classAndValueEquals: f*f*f ]. self assert: (32/243 raisedTo: 3/5) classAndValueEquals: 8/27. self assert: (8/27 raisedTo: 5/3) classAndValueEquals: 32/243. #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :a :b | f := a / b. self assert: ((f raisedTo: 5) raisedTo: 3/5) classAndValueEquals: f*f*f. self assert: ((f raisedTo: 3) raisedTo: 5/3) classAndValueEquals: f*f*f*f*f. self assert: ((f negated raisedTo: 5) raisedTo: 3/5) classAndValueEquals: (f*f*f) negated. self assert: ((f negated raisedTo: 3) raisedTo: 5/3) classAndValueEquals: (f*f*f*f*f) negated. self assert: ((f raisedTo: -5) raisedTo: 3/5) classAndValueEquals: 1/(f*f*f). self assert: ((f raisedTo: -3) raisedTo: 5/3) classAndValueEquals: 1/(f*f*f*f*f). self assert: ((f negated raisedTo: -5) raisedTo: 3/5) classAndValueEquals: -1/(f*f*f). self assert: ((f negated raisedTo: -3) raisedTo: 5/3) classAndValueEquals: -1/(f*f*f*f*f). self assert: ((f raisedTo: 5) raisedTo: -3/5) classAndValueEquals: 1/(f*f*f). self assert: ((f raisedTo: 3) raisedTo: -5/3) classAndValueEquals: 1/(f*f*f*f*f). self assert: ((f negated raisedTo: 5) raisedTo: -3/5) classAndValueEquals: -1/(f*f*f). self assert: ((f negated raisedTo: 3) raisedTo: -5/3) classAndValueEquals: -1/(f*f*f*f*f). "No exact result => Float result" self assert: ((f raisedTo: 3) +1 raisedTo: 5/3) isFloat. self assert: ((f negated raisedTo: 3) -1 raisedTo: 5/3) isFloat. f := b / a. self assert: ((f raisedTo: 5) raisedTo: 3/5) classAndValueEquals: f*f*f. self assert: ((f raisedTo: 3) raisedTo: 5/3) classAndValueEquals: f*f*f*f*f. self assert: ((f negated raisedTo: 5) raisedTo: 3/5) classAndValueEquals: (f*f*f) negated. self assert: ((f negated raisedTo: 3) raisedTo: 5/3) classAndValueEquals: (f*f*f*f*f) negated. "No exact result => Float result" self assert: ((f raisedTo: 3) +1 raisedTo: 5/3) isFloat. self assert: ((f negated raisedTo: 3) -1 raisedTo: 5/3) isFloat ].! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'nice 6/12/2010 00:35'! testLn self assert: ((1/100) ln closeTo: -2 * 10 ln). self assert: (((2 raisedTo: Float emax + 11)/3) ln closeTo: (Float emax + 11)*2 ln - 3 ln) description: 'Fraction>>ln should not overflow'. self assert: ((3/(2 raisedTo: Float precision - Float emin)) ln closeTo: (Float emin - Float precision)*2 ln + 3 ln) description: 'Fraction>>ln should not underflow'! ! !FractionTest methodsFor: 'tests - conversions' stamp: 'nice 6/3/2011 21:32'! testCeiling self assert: (3 / 2) ceiling = 2. self assert: (-3 / 2) ceiling = -1.! ! !FractionTest methodsFor: 'tests - conversions' stamp: 'HenrikSperreJohansen 1/19/2012 16:15'! testAsLargerPowerOfTwo "SmallIntegers, Fraction value < 1" "Exact power of two" self assert: (1/2) asLargerPowerOfTwo equals: 1/2. "Non-reduced exact power of two" self assert: (Fraction numerator: 2 denominator: 4) asLargerPowerOfTwo equals: 1/2. "Not power of two" self assert: (2 / 5) asLargerPowerOfTwo equals: 1/2. "Non-reduced non-power of two" self assert: (Fraction numerator: 10 denominator: 25) asLargerPowerOfTwo equals: 1/2. "SmallIntegers, Fraction value > 1" "Exact power of two" self assert: (Fraction numerator: 2 denominator: 1) asLargerPowerOfTwo equals: 2. "Non-reduced exact power of two" self assert: (Fraction numerator: 4 denominator: 2) asLargerPowerOfTwo equals: 2. "Not power of two" self assert: (3 / 2) asLargerPowerOfTwo equals: 2. "Non-reduced non-power of two" self assert: (Fraction numerator: 12 denominator: 8) asLargerPowerOfTwo equals: 2. "LargeIntegers, Fraction value < 1" "Exact power of two" self assert: (1/(2 raisedTo:80)) asLargerPowerOfTwo equals: 1/(2 raisedTo: 80). "Non-reduced exact power of two" self assert: (Fraction numerator: (2 raisedTo: 80) denominator: (2 raisedTo: 160)) asLargerPowerOfTwo equals: 1/(2 raisedTo: 80). "Not power of two" self assert: (1/((2 raisedTo: 80)+1)) asLargerPowerOfTwo equals: 1/(2 raisedTo: 80). "Non-reduced non-power of two" self assert: (Fraction numerator: (2 raisedTo: 80) denominator: (2 raisedTo: 160) + 1) asLargerPowerOfTwo equals: 1/(2 raisedTo: 80). "LargeIntegers, Fraction value > 1" "Exact power of two" self assert: (Fraction numerator: (2 raisedTo:80) denominator: 1) asLargerPowerOfTwo equals: (2 raisedTo: 80). "Non-reduced exact power of two" self assert: (Fraction numerator: (2 raisedTo: 160) denominator: (2 raisedTo: 80)) asLargerPowerOfTwo equals: (2 raisedTo: 80). "Not power of two" self assert: (Fraction numerator: (2 raisedTo:80) -1 denominator: 1) asLargerPowerOfTwo equals: (2 raisedTo: 80). "Non-reduced non-power of two" self assert: (Fraction numerator: (2 raisedTo: 160) -1 denominator: (2 raisedTo: 80)) asLargerPowerOfTwo equals: (2 raisedTo: 80). "Error condition: numerator is 0" self should: [(Fraction numerator: 0 denominator: 1) asLargerPowerOfTwo] raise: DomainError. "Errro condition: Negative fraction" "SmallIntegers, variations of negated numerator/denominator, and reduced/ non-reduced " self should: [(Fraction numerator: 1 negated denominator: 2) asLargerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: 1 denominator: 2 negated) asLargerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: 2 negated denominator: 4) asLargerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: 2 denominator: 4 negated) asLargerPowerOfTwo] raise: DomainError. "LargeNegativeIntegers, variations of negated numerator/denominator, and reduced/ non-reduced " self should: [(Fraction numerator: 1 negated denominator: (2 raisedTo: 80)) asLargerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: 1 denominator:(2 raisedTo: 80) negated) asLargerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: (2 raisedTo: 80) negated denominator: (2 raisedTo: 160)) asLargerPowerOfTwo] raise: DomainError. self should: [(Fraction numerator: (2 raisedTo: 80) denominator: (2 raisedTo: 160) negated) asLargerPowerOfTwo] raise: DomainError ! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/13/2011 21:49'! testRaisedToErrorConditions " FractionTest new testRaisedToErrorConditions " self should: [ (-1/16) raisedTo: 1/4 ] raise: ArithmeticError. self should: [ ((1 << 1024 + 1) / (1 << 1024 + 3)) negated raisedTo: 1/4 ] raise: ArithmeticError! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'nice 10/19/2011 20:48'! testNthRoot self assert: ((-2 raisedTo: 35) / (3 raisedTo: 20) raisedTo: 1/5) equals: (-2 raisedTo: 7) / (3 raisedTo: 4). self assert: (1 / (1 << 2000) raisedTo: 1/100) equals: 1 / (1 << 20)! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'nice 6/12/2010 00:37'! testLog self assert: ((1/100) log closeTo: -2). self assert: (((2 raisedTo: Float emax + 11)/3) log closeTo: (Float emax + 11)*2 log - 3 log) description: 'Fraction>>log should not overflow'. self assert: ((3/(2 raisedTo: Float precision - Float emin)) log closeTo: (Float emin - Float precision)*2 log + 3 log) description: 'Fraction>>log should not underflow'! ! !FractionTest methodsFor: 'tests - reading' stamp: 'nice 10/30/2011 16:56'! testIvalidReadFrom self should: [Fraction readFromString: '+3'] raise: Error description: 'numerator cannot specify a plus sign'. self should: [Fraction readFromString: '-2/+3'] raise: Error description: 'denominator cannot specify a plus sign'. self should: [Fraction readFromString: '(3/2)'] raise: Error description: 'parenthesis are not allowed'. self should: [Fraction readFromString: ' 3/25'] raise: Error description: 'leading spaces are not allowed before numerator'. self should: [Fraction readFromString: '22/ 3'] raise: Error description: 'leading spaces are not allowed before denominator'. "These behaviours are questionnable, but that's currently how it works:" self assert: (Fraction readFromString: '12345with some trailing characters') = 12345 description: 'non numeric trailing characters interrupt decoding'. self assert: (Fraction readFromString: '1 / 2') = 1 description: 'A space behind numerator interrupt decoding'. self assert: (Fraction readFromString: '22.0/3') = 22 description: 'decimal point interrupt decoding'. self assert: (Fraction readFromString: '23s0/3') = 23 description: 'scale specification interrupt decoding'.! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'CamilloBruni 8/31/2013 20:23'! testDegreeSin "self run: #testDegreeSin" (4 / 3) degreeSin. -361 / 3 to: 359 / 3 do: [ :i | self assert: (i degreeSin closeTo: i degreesToRadians sin) ]! ! !FractionTest methodsFor: 'tests - conversions' stamp: 'nice 6/3/2011 21:39'! testRounded self assert: (4 / 5) rounded = 1. self assert: (6 / 5) rounded = 1. self assert: (-4 / 5) rounded = -1. self assert: (-6 / 5) rounded = -1. "In case of tie, round to upper magnitude" self assert: (3 / 2) rounded = 2. self assert: (-3 / 2) rounded = -2.! ! !FractionTest methodsFor: 'tests - sinuses' stamp: 'GabrielOmarCotelli 5/23/2009 20:19'! testReciprocal self assert: (1/2) reciprocal = 2; assert: (3/4) reciprocal = (4/3); assert: (-1/3) reciprocal = -3; assert: (-3/5) reciprocal = (-5/3)! ! !FractionTest methodsFor: 'tests - conversions' stamp: 'HenrikSperreJohansen 1/19/2012 16:08'! testIsPowerOfTwo "LargeNegativeIntegers" self deny: (1 / (2 raisedTo: 80) negated) isPowerOfTwo. self deny: (1 negated / (2 raisedTo: 80) ) isPowerOfTwo. self deny: ((2 raisedTo: 80) negated / 3) isPowerOfTwo. self deny: ((2 raisedTo: 80) / 4 negated) isPowerOfTwo. "Negative SmallIntegers" self deny: (1/ 2 negated) isPowerOfTwo. " 0, incase implementation has forgotten edge case" self deny: (0 isPowerOfTwo). "Positive SmallIntegers" self assert: (1 isPowerOfTwo). self assert: (2 isPowerOfTwo). self deny: (3 isPowerOfTwo). self assert: (4 isPowerOfTwo). self deny: (5 isPowerOfTwo). " LargePositiveIntegers" self deny: ((2 raisedTo: 80) - 1) isPowerOfTwo. self assert: (2 raisedTo: 80) isPowerOfTwo. self deny: ((2 raisedTo: 80) + 1) isPowerOfTwo! ! !FractionTest methodsFor: 'tests - rounding' stamp: 'GuillermoPolito 6/22/2012 14:51'! testRounding " self debug: #testRounding " self assert: ((6/90) round: 2) equals: 0.07! ! !FractionTest methodsFor: 'tests - conversions' stamp: 'nice 6/3/2011 21:35'! testTruncated self assert: (3 / 2) truncated = 1. self assert: (-3 / 2) truncated = -1.! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/13/2011 21:27'! testInexactSqrt " FractionTest new testInexactSqrt " self assert: ((1 << 1024 + 1) / (1 << 1024 + 3)) sqrt = 1.0! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/11/2011 22:12'! testExactSqrt " FractionTest new testExactSqrt " | f | self assert: (4/9) sqrt classAndValueEquals: 2/3. #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) pairsDo: [ :i :j | f := i / j. self assert: f squared sqrt classAndValueEquals: f. f := j / i. self assert: f squared sqrt classAndValueEquals: f ]! ! !FractionTest methodsFor: 'tests - printing' stamp: 'nice 3/5/2010 22:35'! testFractionPrinting self assert: (353/359) printString = '(353/359)'. self assert: ((2/3) printStringBase: 2) = '(10/11)'. self assert: ((2/3) storeStringBase: 2) = '(2r10/2r11)'. self assert: ((5/7) printStringBase: 3) = '(12/21)'. self assert: ((5/7) storeStringBase: 3) = '(3r12/3r21)'. self assert: ((11/13) printStringBase: 4) = '(23/31)'. self assert: ((11/13) storeStringBase: 4) = '(4r23/4r31)'. self assert: ((17/19) printStringBase: 5) = '(32/34)'. self assert: ((17/19) storeStringBase: 5) = '(5r32/5r34)'. self assert: ((23/29) printStringBase: 6) = '(35/45)'. self assert: ((23/29) storeStringBase: 6) = '(6r35/6r45)'. self assert: ((31/37) printStringBase: 7) = '(43/52)'. self assert: ((31/37) storeStringBase: 7) = '(7r43/7r52)'. self assert: ((41/43) printStringBase: 8) = '(51/53)'. self assert: ((41/43) storeStringBase: 8) = '(8r51/8r53)'. self assert: ((47/53) printStringBase: 9) = '(52/58)'. self assert: ((47/53) storeStringBase: 9) = '(9r52/9r58)'. self assert: ((59/61) printStringBase: 10) = '(59/61)'. self assert: ((59/61) storeStringBase: 10) = '(59/61)'. self assert: ((67/71) printStringBase: 11) = '(61/65)'. self assert: ((67/71) storeStringBase: 11) = '(11r61/11r65)'. self assert: ((73/79) printStringBase: 12) = '(61/67)'. self assert: ((73/79) storeStringBase: 12) = '(12r61/12r67)'. self assert: ((83/89) printStringBase: 13) = '(65/6B)'. self assert: ((83/89) storeStringBase: 13) = '(13r65/13r6B)'. self assert: ((97/101) printStringBase: 14) = '(6D/73)'. self assert: ((97/101) storeStringBase: 14) = '(14r6D/14r73)'. self assert: ((103/107) printStringBase: 15) = '(6D/72)'. self assert: ((103/107) storeStringBase: 15) = '(15r6D/15r72)'. self assert: ((109/113) printStringBase: 16) = '(6D/71)'. self assert: ((109/113) storeStringBase: 16) = '(16r6D/16r71)'. self assert: ((127/131) printStringBase: 17) = '(78/7C)'. self assert: ((127/131) storeStringBase: 17) = '(17r78/17r7C)'. self assert: ((137/139) printStringBase: 18) = '(7B/7D)'. self assert: ((137/139) storeStringBase: 18) = '(18r7B/18r7D)'. self assert: ((149/151) printStringBase: 19) = '(7G/7I)'. self assert: ((149/151) storeStringBase: 19) = '(19r7G/19r7I)'. self assert: ((157/163) printStringBase: 20) = '(7H/83)'. self assert: ((157/163) storeStringBase: 20) = '(20r7H/20r83)'. self assert: ((167/173) printStringBase: 21) = '(7K/85)'. self assert: ((167/173) storeStringBase: 21) = '(21r7K/21r85)'. self assert: ((179/181) printStringBase: 22) = '(83/85)'. self assert: ((179/181) storeStringBase: 22) = '(22r83/22r85)'. self assert: ((191/193) printStringBase: 23) = '(87/89)'. self assert: ((191/193) storeStringBase: 23) = '(23r87/23r89)'. self assert: ((197/199) printStringBase: 24) = '(85/87)'. self assert: ((197/199) storeStringBase: 24) = '(24r85/24r87)'. self assert: ((211/223) printStringBase: 25) = '(8B/8N)'. self assert: ((211/223) storeStringBase: 25) = '(25r8B/25r8N)'. self assert: ((227/229) printStringBase: 26) = '(8J/8L)'. self assert: ((227/229) storeStringBase: 26) = '(26r8J/26r8L)'. self assert: ((233/239) printStringBase: 27) = '(8H/8N)'. self assert: ((233/239) storeStringBase: 27) = '(27r8H/27r8N)'. self assert: ((241/251) printStringBase: 28) = '(8H/8R)'. self assert: ((241/251) storeStringBase: 28) = '(28r8H/28r8R)'. self assert: ((257/263) printStringBase: 29) = '(8P/92)'. self assert: ((257/263) storeStringBase: 29) = '(29r8P/29r92)'. self assert: ((269/271) printStringBase: 30) = '(8T/91)'. self assert: ((269/271) storeStringBase: 30) = '(30r8T/30r91)'. self assert: ((277/281) printStringBase: 31) = '(8T/92)'. self assert: ((277/281) storeStringBase: 31) = '(31r8T/31r92)'. self assert: ((283/293) printStringBase: 32) = '(8R/95)'. self assert: ((283/293) storeStringBase: 32) = '(32r8R/32r95)'. self assert: ((307/311) printStringBase: 33) = '(9A/9E)'. self assert: ((307/311) storeStringBase: 33) = '(33r9A/33r9E)'. self assert: ((313/317) printStringBase: 34) = '(97/9B)'. self assert: ((313/317) storeStringBase: 34) = '(34r97/34r9B)'. self assert: ((331/337) printStringBase: 35) = '(9G/9M)'. self assert: ((331/337) storeStringBase: 35) = '(35r9G/35r9M)'. self assert: ((347/349) printStringBase: 36) = '(9N/9P)'. self assert: ((347/349) storeStringBase: 36) = '(36r9N/36r9P)'. self assert: ((-2/3) printStringBase: 2) = '(-10/11)'. self assert: ((-2/3) storeStringBase: 2) = '(-2r10/2r11)'. self assert: ((5 / -7) printStringBase: 3) = '(-12/21)'. self assert: ((5 / -7) storeStringBase: 3) = '(-3r12/3r21)'. ! ! !FreeTypeCache commentStamp: 'TorstenBergmann 2/4/2014 22:09'! Cache for freetype fonts! !FreeTypeCache methodsFor: 'public' stamp: 'tween 8/10/2006 15:14'! sizeOf: anObject ^(anObject isKindOf: Form) ifTrue:[(anObject bitsSize * 4) + 32] ifFalse:[4] ! ! !FreeTypeCache methodsFor: 'private' stamp: 'tween 8/10/2006 13:22'! fifoEntryClass ^FreeTypeCacheEntry! ! !FreeTypeCache methodsFor: 'public' stamp: 'ClementBera 7/26/2013 16:41'! report "answer a description of the current state of the cache" | usedPercent | usedPercent := maximumSize ifNil: [0] ifNotNil: [(used * 100 / maximumSize) asFloat rounded]. ^usedPercent asString,'% Full (maximumSize: ', maximumSize asString, ' , used: ', used asString,')'! ! !FreeTypeCache methodsFor: 'private' stamp: 'tween 8/10/2006 13:20'! dictionaryClass ^Dictionary! ! !FreeTypeCache methodsFor: 'add-remove' stamp: 'tween 8/10/2006 19:34'! atFont: aFreeTypeFont charCode: charCodeInteger type: typeFlag | entry charCodeTable typeTable | (charCodeTable := fontTable at: aFreeTypeFont ifAbsent:[]) ifNotNil:[ (typeTable := charCodeTable at: charCodeInteger ifAbsent:[]) ifNotNil:[ (entry := typeTable at: typeFlag ifAbsent:[]) ifNotNil:[ fifo moveDown: entry. ^entry object]]]. self error: 'Not found'! ! !FreeTypeCache methodsFor: 'public' stamp: 'AlainPlantec 11/26/2009 21:58'! cacheSize ^ self maximumSize / 1024! ! !FreeTypeCache methodsFor: 'private' stamp: 'tween 8/10/2006 19:03'! fifoClass ^FreeTypeCacheLinkedList! ! !FreeTypeCache methodsFor: 'private' stamp: 'tween 9/29/2007 20:10'! shrinkTo: newSize "if the used size is greater than newSize, then remove all the receiver's entries" used > newSize ifTrue:[self removeAll]! ! !FreeTypeCache methodsFor: 'add-remove' stamp: 'nice 1/5/2010 15:59'! removeAllForType: typeFlag | toRemove | toRemove := IdentitySet new. fifo do:[:entry | entry type = typeFlag ifTrue:[toRemove add: entry]]. toRemove do:[:entry | | d | fifo remove: entry. d := (fontTable at: entry font) at: entry charCode. d removeKey: entry type. used := used - (self sizeOf: entry object) ]. ! ! !FreeTypeCache methodsFor: 'public' stamp: 'AlainPlantec 11/13/2009 14:46'! maximumSize ^ maximumSize ! ! !FreeTypeCache methodsFor: 'add-remove' stamp: 'ClementBera 7/26/2013 16:40'! atFont: aFreeTypeFont charCode: charCodeInteger type: typeFlag put: anObject | charCodeTable typeTable anObjectSize oldEntry oldEntrySize entry | anObjectSize := self sizeOf: anObject. (maximumSize notNil and:[anObjectSize > maximumSize]) ifTrue:[^anObject]. (charCodeTable := fontTable at: aFreeTypeFont ifAbsentPut:[self dictionaryClass new: 60]) ifNotNil:[ (typeTable := charCodeTable at: charCodeInteger ifAbsentPut:[self dictionaryClass new: 10]) ifNotNil:[ oldEntry := typeTable at: typeFlag ifAbsent:[]. oldEntrySize := (oldEntry ifNil:[0] ifNotNil:[self sizeOf: oldEntry object]). entry := (self fifoEntryClass new font: aFreeTypeFont; charCode: charCodeInteger; type: typeFlag; object: anObject; yourself). typeTable at: typeFlag put: entry]]. used := used + anObjectSize - oldEntrySize. oldEntry ifNotNil: [fifo remove: oldEntry]. fifo addLast: entry. maximumSize ifNotNil:[self shrinkTo: maximumSize]. ^anObject ! ! !FreeTypeCache methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:54'! initialize super initialize. maximumSize := self class defaultMaximumSize. fontTable := self dictionaryClass new: 100. used := 0. fifo := self fifoClass new ! ! !FreeTypeCache methodsFor: 'public' stamp: 'tween 8/10/2006 12:56'! maximumSize: anIntegerOrNil maximumSize := anIntegerOrNil. maximumSize ifNotNil:[ used > maximumSize ifTrue:["shrink" self shrinkTo: maximumSize]]! ! !FreeTypeCache methodsFor: 'add-remove' stamp: 'tween 8/10/2006 21:20'! atFont: aFreeTypeFont charCode: charCodeInteger type: typeFlag ifAbsentPut: aBlock | charCodeTable typeTable entry v vSize | charCodeTable := fontTable at: aFreeTypeFont ifAbsentPut:[self dictionaryClass new: 60]. typeTable := charCodeTable at: charCodeInteger ifAbsentPut:[self dictionaryClass new: 10]. entry := typeTable at: typeFlag ifAbsent:[]. entry ifNotNil:[ fifo moveDown: entry. ^entry object]. v := aBlock value. vSize := self sizeOf: v. (maximumSize notNil and:[vSize > maximumSize]) ifTrue:[^v]. used := used + vSize. entry := (self fifoEntryClass new font: aFreeTypeFont; charCode: charCodeInteger; type: typeFlag; object: v; yourself). typeTable at: typeFlag put: entry. fifo addLast: entry. maximumSize ifNotNil:[self shrinkTo: maximumSize]. ^v ! ! !FreeTypeCache methodsFor: 'public' stamp: 'AlainPlantec 11/26/2009 21:59'! cacheSize: anInteger self maximumSize: (anInteger * 1024)! ! !FreeTypeCache methodsFor: 'add-remove' stamp: 'nice 1/5/2010 15:59'! removeAllForFont: aFreeTypeFont | toRemove | (fontTable includesKey: aFreeTypeFont) ifFalse:[^self]. toRemove := IdentitySet new. fifo do:[:entry | entry font = aFreeTypeFont ifTrue:[toRemove add: entry]]. toRemove do:[:entry | | d | fifo remove: entry. d := (fontTable at: entry font) at: entry charCode. d removeKey: entry type. used := used - (self sizeOf: entry object) ]. ! ! !FreeTypeCache methodsFor: 'add-remove' stamp: 'tween 8/10/2006 13:40'! removeAll fontTable := self dictionaryClass new: 100. fifo := self fifoClass new. used := 0. ! ! !FreeTypeCache class methodsFor: 'system shutdown' stamp: 'tween 8/10/2006 15:44'! clearCacheOnShutdown "answer true if the cache should be cleared on image shutdown" ^true! ! !FreeTypeCache class methodsFor: 'accessing' stamp: 'tween 8/10/2006 15:45'! initialize " self initialize. " Smalltalk addToShutDownList: self. "should it be at a particular place in the list?"! ! !FreeTypeCache class methodsFor: 'cleanup' stamp: 'MarcusDenker 4/22/2011 10:32'! cleanUp self clearCurrent! ! !FreeTypeCache class methodsFor: 'accessing' stamp: 'tween 8/10/2006 15:45'! shutDown: quitting (current notNil and: [self clearCacheOnShutdown]) ifTrue:[self current removeAll]! ! !FreeTypeCache class methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:16'! current ^ current ifNil: [ current := self new ]! ! !FreeTypeCache class methodsFor: 'accessing' stamp: 'tween 8/10/2006 09:30'! defaultMaximumSize "answer the default maximumSize in bytes" ^1024*5000 "5 Megabytes"! ! !FreeTypeCache class methodsFor: 'accessing' stamp: 'tween 8/10/2006 15:33'! clearCurrent " self clearCurrent. " current := nil! ! !FreeTypeCacheConstants commentStamp: 'TorstenBergmann 2/4/2014 22:09'! Constants for the FreeType cache! !FreeTypeCacheConstants class methodsFor: 'class initialization' stamp: 'tween 3/31/2007 21:31'! initialize " FreeTypeCacheConstants initialize " FreeTypeCacheWidth := 0. FreeTypeCacheGlyph := 100. "start at 100 and allow room for 64 subpixel positioned glyphs" FreeTypeCacheGlyphLCD := 200. "start at 200 and allow room for 64 subpixel positioned glyphs" FreeTypeCacheGlyphMono := 3. FreeTypeCacheLinearWidth := 4 ! ! !FreeTypeCacheEntry commentStamp: 'TorstenBergmann 2/4/2014 22:09'! An entry for the FreeTypeCache! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 14:55'! object: anObject "Set the value of object" object := anObject! ! !FreeTypeCacheEntry methodsFor: 'comparing' stamp: 'tween 8/10/2006 13:34'! hash ^charCode hash! ! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 14:55'! object "Answer the value of object" ^ object! ! !FreeTypeCacheEntry methodsFor: 'comparing' stamp: 'tween 8/10/2006 14:58'! = aFreeTypeCacheEntry "equailty based on font,charcode, type, object, but not nextLink" (aFreeTypeCacheEntry isKindOf: FreeTypeCacheEntry) ifFalse:[^false]. ^font = aFreeTypeCacheEntry font and: [ charCode = aFreeTypeCacheEntry charCode and: [type = aFreeTypeCacheEntry type and:[object = aFreeTypeCacheEntry object]]]! ! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! charCode "Answer the value of charCode" ^ charCode! ! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! charCode: anObject "Set the value of charCode" charCode := anObject! ! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! font "Answer the value of font" ^ font! ! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! type "Answer the value of type" ^ type! ! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 17:56'! previousLink "Answer the value of previousLink" ^ previousLink! ! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! type: anObject "Set the value of type" type := anObject! ! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 17:56'! previousLink: anObject "Set the value of previousLink" previousLink := anObject! ! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 13:16'! font: anObject "Set the value of font" font := anObject! ! !FreeTypeCacheLinkedList commentStamp: 'TorstenBergmann 2/4/2014 22:09'! A linked list for the FreeTypeCache! !FreeTypeCacheLinkedList methodsFor: 'adding' stamp: 'nice 4/19/2011 00:03'! add: link after: otherLink "Add otherLink after link in the list. Answer aLink." | savedLink | savedLink := otherLink nextLink. otherLink nextLink: link. link nextLink: savedLink. savedLink ifNotNil: [savedLink previousLink: link]. link previousLink: otherLink. ^link. ! ! !FreeTypeCacheLinkedList methodsFor: 'removing' stamp: 'tween 8/10/2006 21:06'! removeFirst "Remove the first element and answer it. If the receiver is empty, create an error notification." | oldLink | self emptyCheck. oldLink := firstLink. oldLink previousLink: nil. lastLink == firstLink ifTrue:[ lastLink := firstLink := nil. oldLink nextLink: nil. ^oldLink]. firstLink := oldLink nextLink. firstLink == nil ifTrue:[firstLink := lastLink := nil] ifFalse:[firstLink previousLink: nil]. oldLink nextLink: nil. ^oldLink! ! !FreeTypeCacheLinkedList methodsFor: 'removing' stamp: 'tween 8/10/2006 21:09'! removeLast "Remove the first element and answer it. If the receiver is empty, create an error notification." | oldLink | self emptyCheck. oldLink := lastLink. oldLink nextLink: nil. lastLink == firstLink ifTrue:[ lastLink := firstLink := nil. oldLink previousLink: nil. ^oldLink]. lastLink := oldLink previousLink. lastLink == nil ifTrue:[firstLink := lastLink := nil] ifFalse:[lastLink nextLink: nil]. oldLink previousLink: nil. ^oldLink! ! !FreeTypeCacheLinkedList methodsFor: 'removing' stamp: 'tween 8/10/2006 18:48'! remove: aLink ifAbsent: aBlock | prev next | prev := aLink previousLink. next := aLink nextLink. prev == nil ifFalse: [prev nextLink: next]. next == nil ifFalse: [next previousLink: prev]. aLink == firstLink ifTrue:[firstLink := next]. aLink == lastLink ifTrue:[lastLink := prev]. aLink nextLink: nil. aLink previousLink: nil. ^aLink! ! !FreeTypeCacheLinkedList methodsFor: 'adding' stamp: 'nice 4/19/2011 00:05'! addFirst: aLink "Add aLink to the beginning of the receiver's list. Answer aLink." self isEmpty ifTrue: [^lastLink :=firstLink := aLink]. aLink nextLink: firstLink. aLink previousLink: nil. firstLink ifNotNil: [firstLink previousLink: aLink]. firstLink := aLink. ^aLink! ! !FreeTypeCacheLinkedList methodsFor: 'reordering' stamp: 'tween 3/31/2007 12:31'! moveDown: aLink | e1 e2 e3 e4 | (e3 := aLink nextLink) ifNil:[^self]. e2 := aLink. e4 := e3 nextLink. e1 := e2 previousLink. "swap e2 & e3" e1 ifNotNil:[e1 nextLink: e2]. e2 nextLink: e3. e3 nextLink: e4. e4 ifNotNil:[e4 previousLink: e3]. e3 previousLink: e2. e2 previousLink: e1 ! ! !FreeTypeCacheLinkedList methodsFor: 'adding' stamp: 'nice 4/19/2011 00:04'! add: link before: otherLink | savedLink | firstLink == otherLink ifTrue: [^ self addFirst: link]. otherLink ifNotNil:[ savedLink := otherLink previousLink. link nextLink: otherLink. link previousLink: savedLink. otherLink previousLink: link. savedLink ifNotNil: [savedLink nextLink: link]]. ^ self errorNotFound: otherLink! ! !FreeTypeCacheLinkedList methodsFor: 'adding' stamp: 'nice 4/19/2011 00:06'! addLast: aLink "Add aLink to the end of the receiver's list. Answer aLink." self isEmpty ifTrue: [^firstLink := lastLink := aLink]. aLink previousLink: lastLink. aLink nextLink: nil. lastLink ifNotNil: [lastLink nextLink: aLink]. lastLink := aLink. ^aLink! ! !FreeTypeCacheTest commentStamp: 'TorstenBergmann 2/4/2014 22:12'! SUnit tests for FreeType cache! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 9/29/2007 20:02'! testEntriesRemovedFIFO | | cache maximumSize: 10*(cache sizeOf: font1XGlyph). 1 to: 10 do:[:i | cache atFont: font1 charCode: (1000-i) type: FreeTypeCacheGlyph put: font1XGlyph]. self validateCollections: cache. 11 to:1000 do:[:i | cache atFont: font1 charCode: (1000-i) type: FreeTypeCacheGlyph put: font1XGlyph. self validateSizes: cache. self validateCollections: cache. "i-9 to: i do:[:i2 | self shouldnt: [cache atFont: font1 charCode: 1000-i2 type: FreeTypeCacheGlyph] raise: Error]." self should: [cache atFont: font1 charCode: 1000-(i-10) type: FreeTypeCacheGlyph] raise: Error]. self validateSizes: cache. ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 12:48'! testSetMaximumSizeUnbounded | u | u := fullCache instVarNamed: #used. fullCache maximumSize: nil. "unbounded" self assert: u = (fullCache instVarNamed: #used). self validateSizes: cache. self validateCollections: cache ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 15:52'! testNormalGetIfAbsentPut | u g r | cache maximumSize: nil. u := cache instVarNamed: #used. r := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph ifAbsentPut: [font1XGlyph]. self assert: (r isKindOf: GlyphForm). self assert: (cache instVarNamed: #used) > u. "grown" self validateSizes: cache. g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. self assert: g == font1XGlyph. self validateSizes: cache. self validateCollections: cache ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 15:29'! testRemoveAllForType | fifo | fullCache maximumSize: nil. 1 to: 100 do:[:i | fullCache atFont: font1 charCode: i type: 1 put: font1XGlyph]. 1 to: 100 do:[:i | fullCache atFont: font2 charCode: i type: 2 put: font1YGlyph]. 1 to: 100 do:[:i | fullCache atFont: font3 charCode: i type: 3 put: font1ZGlyph]. fifo := fullCache instVarNamed: #fifo. self assert: (fifo detect:[:each | each type = 1] ifNone:[]) notNil. self assert: (fifo detect:[:each | each type = 2] ifNone:[]) notNil. self assert: (fifo detect:[:each | each type = 3] ifNone:[]) notNil. fullCache removeAllForType: 1. self validateSizes: fullCache. self validateCollections: fullCache. fifo := (fullCache instVarNamed: #fifo). self assert: (fifo detect:[:each | each type = 1] ifNone:[]) isNil. self assert: (fifo detect:[:each | each type = 2] ifNone:[]) notNil. self assert: (fifo detect:[:each | each type = 3] ifNone:[]) notNil. ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 11:19'! testFailedGet | | self should: [cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph] raise: Error. self assert: (cache instVarNamed: #fontTable) isEmpty. self assert: (cache instVarNamed: #used) = 0. self validateSizes: cache ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 12:48'! testSetMaximumSizeGrow | u m | u := fullCache instVarNamed: #used. m := fullCache instVarNamed: #maximumSize. fullCache maximumSize: m * 2 . "grow" self assert: u = (fullCache instVarNamed: #used). self validateSizes: cache. self validateCollections: cache! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 3/31/2007 12:26'! testNormalGetIfAbsentPutTwiceIntoNonEmptyCache | u g r | cache maximumSize: nil. u := cache instVarNamed: #used. r := cache atFont: font1 charCode: $Z asInteger type: FreeTypeCacheGlyph ifAbsentPut: [font1XGlyph]. r := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph ifAbsentPut: [font1XGlyph]. r := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph ifAbsentPut: [font1XGlyph]. self assert: (r isKindOf: GlyphForm). self assert: (cache instVarNamed: #used) > u. "grown" self validateSizes: cache. g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. self assert: g == font1XGlyph. self validateSizes: cache. self validateCollections: cache ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 3/31/2007 12:26'! testNormalGetIfAbsentPutTwice | u g r | cache maximumSize: nil. u := cache instVarNamed: #used. r := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph ifAbsentPut: [font1XGlyph]. r := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph ifAbsentPut: [font1XGlyph]. self assert: (r isKindOf: GlyphForm). self assert: (cache instVarNamed: #used) > u. "grown" self validateSizes: cache. g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. self assert: g == font1XGlyph. self validateSizes: cache. self validateCollections: cache ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 13:41'! testInstanceInitialization self assert: (cache instVarNamed: #maximumSize) = FreeTypeCache defaultMaximumSize. self assert: (cache instVarNamed: #used) = 0. self assert: (cache instVarNamed: #fontTable) class = cache dictionaryClass. self assert: (cache instVarNamed: #fontTable) isEmpty. self assert: (cache instVarNamed: #fifo) class = cache fifoClass. self assert: (cache instVarNamed: #fifo) isEmpty. ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 13:05'! testRemoveAll | m fifo fontTable | m := fullCache instVarNamed: #maximumSize. fifo := fullCache instVarNamed: #fifo. fontTable := fullCache instVarNamed: #fontTable. fullCache removeAll. self assert: (fullCache instVarNamed: #fifo) isEmpty. self assert: (fullCache instVarNamed: #fontTable) isEmpty. self assert: (fullCache instVarNamed: #used) = 0. self assert: m = (fullCache instVarNamed: #maximumSize). self assert: fifo class = (fullCache instVarNamed: #fifo) class. self assert: fontTable class = (fullCache instVarNamed: #fontTable) class. ! ! !FreeTypeCacheTest methodsFor: 'private' stamp: 'tween 3/31/2007 12:12'! validateCollections: aFreeTypeCache "check that the fifo list entries match the fontTable dict hierarchy" | fontTable fontTableEntries fifo lastLink | fontTable := aFreeTypeCache instVarNamed: #fontTable. fifo := aFreeTypeCache instVarNamed: #fifo. lastLink := (fifo instVarNamed:#lastLink). fontTableEntries := Set new. fontTable keysAndValuesDo:[:k1 :v1 | v1 keysAndValuesDo:[:k2 :v2 | v2 keysAndValuesDo:[:k3 :v3 | fontTableEntries add: v3 ]]]. self assert: fifo size = fontTableEntries size. self assert: (fifo asSet = fontTableEntries). self assert: (lastLink isNil or:[lastLink nextLink isNil]) ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testSetMaximumSize cache maximumSize: 0. self assert: (cache instVarNamed: #maximumSize) = 0. cache maximumSize: 99999999999999999. self assert: (cache instVarNamed: #maximumSize) = 99999999999999999. cache maximumSize: nil. "unbounded" self assert: (cache instVarNamed: #maximumSize) isNil. self validateSizes: cache. self validateCollections: cache! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 9/29/2007 20:07'! testSetMaximumSizeShrink | m | m := fullCache instVarNamed: #maximumSize. fullCache maximumSize: m // 2 . "shrink" self assert: (fullCache instVarNamed: #used) = 0. "cache is cleared when used > maximumSize" self validateSizes: fullCache. self validateCollections: fullCache. ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 14:57'! testFreeTypeCacheEntry | f f2 f3 | f := FreeTypeCacheEntry new. f charCode: 1; font: font1; type: FreeTypeCacheGlyph; object: font1XGlyph. f2 := FreeTypeCacheEntry new. f2 charCode: 2; font: font1; type: FreeTypeCacheGlyphLCD; object: font1XGlyph. f nextLink: f2. self assert: f ~= f2. self assert: f nextLink = f2 . f3 := f copy. f3 nextLink: nil. self assert: f = f3. "equality not based on nextLink"! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 14:21'! testRemoveAllForFont | fifo | fullCache maximumSize: nil. 1 to: 100 do:[:i | fullCache atFont: font1 charCode: i type: 1 put: font1XGlyph]. 1 to: 100 do:[:i | fullCache atFont: font2 charCode: i type: 2 put: font1YGlyph]. 1 to: 100 do:[:i | fullCache atFont: font3 charCode: i type: 3 put: font1ZGlyph]. fifo := fullCache instVarNamed: #fifo. self assert: (fifo detect:[:each | each font = font1] ifNone:[]) notNil. self assert: (fifo detect:[:each | each font = font2] ifNone:[]) notNil. self assert: (fifo detect:[:each | each font = font3] ifNone:[]) notNil. fullCache removeAllForFont: font1. self validateSizes: fullCache. self validateCollections: fullCache. fifo := (fullCache instVarNamed: #fifo). self assert: (fifo detect:[:each | each font = font1] ifNone:[]) isNil. self assert: (fifo detect:[:each | each font = font2] ifNone:[]) notNil. self assert: (fifo detect:[:each | each font = font2] ifNone:[]) notNil. ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 12:47'! testNormalPutGet | u g | cache maximumSize: nil. u := cache instVarNamed: #used. cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph put: font1XGlyph. self assert: (cache instVarNamed: #used) > u. "grown" self validateSizes: cache. g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. self assert: g == font1XGlyph. self validateSizes: cache. self validateCollections: cache ! ! !FreeTypeCacheTest methodsFor: 'running' stamp: 'tween 3/23/2007 08:07'! setUp cache := FreeTypeCache new. font1 := FreeTypeFont basicNew. font2 := FreeTypeFont basicNew. font3 := FreeTypeFont basicNew. font1XGlyph := (GlyphForm extent: 100@100 depth: 32) advance: 100; linearAdvance: 10000; yourself. font1YGlyph := (GlyphForm extent: 100@100 depth: 32) advance: 100; linearAdvance: 10000; yourself. font1ZGlyph := (GlyphForm extent: 100@100 depth: 32) advance: 100; linearAdvance: 10000; yourself. fullCache := FreeTypeCache new. fullCache maximumSize: (10*(fullCache sizeOf: font1YGlyph)).. 1 to: 10 do:[:i | fullCache atFont: font1 charCode: i type: FreeTypeCacheGlyph put: font1YGlyph]. ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 09:24'! testSingleton self assert: FreeTypeCache current class = FreeTypeCache. self assert: FreeTypeCache current == FreeTypeCache current. ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 13:52'! testReport self assert: fullCache report = '100% Full (maximumSize: 400320 , used: 400320)'. fullCache maximumSize: 800640. self assert: fullCache report = '50% Full (maximumSize: 800640 , used: 400320)'. self assert: cache report = '0% Full (maximumSize: 5120000 , used: 0)'. cache maximumSize: nil. self assert: cache report = '0% Full (maximumSize: nil , used: 0)'. ! ! !FreeTypeCacheTest methodsFor: 'private' stamp: 'tween 8/10/2006 15:04'! validateSizes: aFreeTypeCache "check that the used, maximumSize, and caches entries are valid" | fontTable calcSize max used | fontTable := aFreeTypeCache instVarNamed: #fontTable. used := aFreeTypeCache instVarNamed: #used. max := aFreeTypeCache instVarNamed: #maximumSize. calcSize := 0. fontTable do:[:charCodeTable | charCodeTable do:[:typeTable | typeTable do:[:entry | calcSize := calcSize + (aFreeTypeCache sizeOf: entry object)]]]. self assert: calcSize = used. self assert: (max isNil or:[used <= max]) ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 10:29'! testConstants | constants | constants := {FreeTypeCacheWidth. FreeTypeCacheGlyphMono. FreeTypeCacheGlyphLCD.FreeTypeCacheGlyph}. self assert: constants asSet size = constants size. "no 2 have same value" self assert: (constants detect:[:x | x isNil] ifNone:[]) isNil. "no value is nil" ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 3/31/2007 12:21'! testNormalPutGetTwice | u g | cache maximumSize: nil. u := cache instVarNamed: #used. cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph put: font1XGlyph. self assert: (cache instVarNamed: #used) > u. "grown" self validateSizes: cache. g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph. self assert: g == font1XGlyph. self validateSizes: cache. self validateCollections: cache ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 15:12'! testNormalPutGetWidth | u g | cache maximumSize: nil. u := cache instVarNamed: #used. cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheWidth put: 100. self assert: (cache instVarNamed: #used) > u. "grown" self validateSizes: cache. g := cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheWidth. self assert: g = 100. self validateSizes: cache. self validateCollections: cache ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 9/29/2007 20:05'! testMaximumSizeRespectedOnIfAbsentPut | | cache maximumSize: (cache sizeOf: font1XGlyph). cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph ifAbsentPut: font1XGlyph. self validateSizes: cache. self validateCollections: cache. cache atFont: font1 charCode: $Y asInteger type: FreeTypeCacheGlyph ifAbsentPut: font1XGlyph. self assert: (cache instVarNamed:#used) = 0. "cache has been cleared on reaching max size" self validateSizes: cache. self validateCollections: cache. self should: [cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph] raise: Error. self should: [cache atFont: font1 charCode: $Y asInteger type: FreeTypeCacheGlyph] raise: Error. ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 8/10/2006 14:41'! testPutSameElementTwice | | cache maximumSize: nil. cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph put: font1XGlyph. self assert: (cache instVarNamed: #used) = (cache sizeOf: font1XGlyph). self validateSizes: cache. self validateCollections: cache. cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph put: font1XGlyph. self assert: (cache instVarNamed: #used) = (cache sizeOf: font1XGlyph). self validateSizes: cache. self validateCollections: cache ! ! !FreeTypeCacheTest methodsFor: 'tests' stamp: 'tween 9/29/2007 20:06'! testMaximumSizeRespectedOnPut | | cache maximumSize: (cache sizeOf: font1XGlyph). cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph put: font1XGlyph. self validateSizes: cache. self validateCollections: cache. cache atFont: font1 charCode: $Y asInteger type: FreeTypeCacheGlyph put: font1XGlyph. self assert: (cache instVarNamed:#used) = 0. "cache has been cleared on reaching max size" self validateSizes: cache. self validateCollections: cache. self should: [cache atFont: font1 charCode: $X asInteger type: FreeTypeCacheGlyph] raise: Error. self should: [cache atFont: font1 charCode: $Y asInteger type: FreeTypeCacheGlyph] raise: Error. ! ! !FreeTypeEmbeddedFileInfo commentStamp: 'TorstenBergmann 2/4/2014 22:10'! File info for embbeded FreeType fonts! !FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/28/2007 12:43'! fileSize ^fileContents size! ! !FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:21'! baseName "Answer the value of baseName" ^ baseName! ! !FreeTypeEmbeddedFileInfo methodsFor: 'printing' stamp: 'tween 8/16/2007 01:08'! printOn: aStream "super printOn: aStream." aStream nextPutAll: '{', self locationType asString,'}'; nextPutAll: '(' , fileContents size asString, ' bytes )'; nextPutAll: '[',index asString,'] '; nextPutAll: familyName asString; nextPutAll: ' - ', styleName asString; nextPutAll: ' - ', postscriptName asString; nextPutAll: ' ',(bold ifTrue:['B'] ifFalse:['']); nextPutAll: ' ',(italic ifTrue:['I'] ifFalse:['']); nextPutAll: ' ',(fixedWidth ifTrue:['Monospaced'] ifFalse:['']); nextPutAll: ' ',(stretchValue asString); nextPutAll: ' ',(weightValue asString); cr! ! !FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:19'! fileContents "Answer the value of fileContents" ^ fileContents! ! !FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:19'! baseName: anObject "Set the value of baseName" baseName := anObject! ! !FreeTypeEmbeddedFileInfo methodsFor: 'testing' stamp: 'tween 7/16/2007 00:31'! isEmbedded ^true! ! !FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:19'! fileContents: anObject "Set the value of fileContents" fileContents := anObject! ! !FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:16'! locationType "Answer the value of locationType" ^ #embedded! ! !FreeTypeExternalMemory commentStamp: 'TorstenBergmann 2/4/2014 22:06'! FreeType externalMemory ! !FreeTypeExternalMemory methodsFor: 'accessing' stamp: 'tween 8/12/2006 08:40'! bytes ^bytes! ! !FreeTypeExternalMemory methodsFor: 'validation' stamp: 'tween 8/12/2006 10:25'! validate self isValid ifFalse: [ bytes ifNotNil:[ [self primCopyToExternalMemory: bytes] on: FT2Error do:[:e |"need to do something here?"]. self isValid ifTrue:[self class register: self]]]! ! !FreeTypeExternalMemory methodsFor: 'primitives' stamp: 'tween 8/12/2006 10:24'! primDestroyHandle ^self primitiveFailed! ! !FreeTypeExternalMemory methodsFor: 'primitives' stamp: 'tween 8/12/2006 10:25'! primCopyToExternalMemory: aByteArray "copy aByteArray into newly allocated, external memory, and store the address of that memory in the receiver's handle" ^self primitiveFailed! ! !FreeTypeExternalMemory methodsFor: 'accessing' stamp: 'tween 8/12/2006 08:40'! bytes: aByteArray bytes := aByteArray! ! !FreeTypeExternalMemory class methodsFor: 'instance creation' stamp: 'tween 8/12/2006 08:42'! bytes: aByteArray | answer | answer := self basicNew bytes: aByteArray; yourself. ^answer! ! !FreeTypeFace commentStamp: 'TorstenBergmann 2/4/2014 22:06'! Do not rearrange these fields!!! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! index ^index! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! styleName ^super styleName ifNil:['']! ! !FreeTypeFace methodsFor: 'validation' stamp: 'YuriyTymchuk 1/31/2013 18:31'! validate "If the receiver is not valid (has a nil handle), then create the receiver to obtain a handle and load the receiver's fields" session == Smalltalk session ifFalse: [ handle := nil. session := Smalltalk session. self create. ]. self isValid ifFalse: [self create]! ! !FreeTypeFace methodsFor: 'testing' stamp: 'tween 3/31/2007 14:52'! hasKerning ^hasKerning ifNil:[ [hasKerning := self primHasKerning = 64] on: Error do:[:e | hasKerning := false]. hasKerning]! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! familyName ^super familyName ifNil:['?']! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! fileContentsExternalMemoryBytes ^fileContentsExternalMemory ifNotNil:[fileContentsExternalMemory bytes]! ! !FreeTypeFace methodsFor: 'caching' stamp: 'IgorStasenko 10/9/2012 17:41'! releaseCachedState hasKerning := nil. ! ! !FreeTypeFace methodsFor: 'initialize-release' stamp: 'tween 3/16/2007 12:53'! beNull super beNull. valid := nil ! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! fileContentsExternalMemory: aFreeTypeExternalMemory fileContentsExternalMemory := aFreeTypeExternalMemory! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! filename ^filename! ! !FreeTypeFace methodsFor: 'validation' stamp: 'tween 3/16/2007 12:44'! primNewFaceFromExternalMemory: aFreeTypeExternalMemory size: anInteger index: anInteger2 ^self primitiveFailed! ! !FreeTypeFace methodsFor: 'initialize-release' stamp: 'tween 3/16/2007 12:44'! actAsExecutor super actAsExecutor. filename := ''.! ! !FreeTypeFace methodsFor: 'validation' stamp: 'ClementBera 7/26/2013 16:42'! create "create me in the FT2Plugin. This gets my handle, and loads the fields" fileContentsExternalMemory ifNil: [ self newFaceFromFile: filename asFileReference index: index ] ifNotNil: [ self newFaceFromExternalMemory: fileContentsExternalMemory index: index ]. self loadFields ! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! filename: aString filename := aString! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! index: anInteger index := anInteger! ! !FreeTypeFace methodsFor: 'testing' stamp: 'tween 3/31/2007 16:18'! isValid ^valid ifNil:[valid := super isValid]! ! !FreeTypeFace methodsFor: 'validation' stamp: 'tween 3/17/2007 12:21'! newFaceFromExternalMemory: aFreeTypeExternalMemory index: anInteger | answer | valid := nil. answer := super newFaceFromExternalMemory: aFreeTypeExternalMemory index: anInteger. valid := super isValid. ^answer ! ! !FreeTypeFace methodsFor: 'testing' stamp: 'tween 3/16/2007 12:44'! hasFamilyName ^super familyName notNil! ! !FreeTypeFace methodsFor: 'testing' stamp: 'tween 3/16/2007 12:44'! hasStyleName ^super styleName notNil! ! !FreeTypeFace methodsFor: 'validation' stamp: 'tween 3/17/2007 12:19'! newFaceFromFile: fileName index: anInteger | answer | valid := nil. answer := super newFaceFromFile: fileName index: anInteger. valid := super isValid. ^answer ! ! !FreeTypeFace class methodsFor: 'font dirs' stamp: 'CamilloBruni 5/4/2012 20:18'! fontPathFor: aFilename "aFilename is local. Try hard to return a valid path to be handed to freetype library" "temporary solution ;-)" ^ (FileSystem disk workingDirectory / 'Fonts' / aFilename) fullName! ! !FreeTypeFace class methodsFor: 'font dirs' stamp: 'tween 3/16/2007 12:44'! rememberFontDir: aDirecory! ! !FreeTypeFace class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/4/2012 20:21'! fromFile: aFileName index: anInteger "share alike instances" | file | file := aFileName asFileReference. self rememberFontDir: file parent fullName . self allInstancesDo: [:inst | (inst filename = aFileName and: [inst index = anInteger]) ifTrue: [^inst "validate"]]. ^ (self basicNew) filename: aFileName; index: anInteger; yourself! ! !FreeTypeFace class methodsFor: 'instance creation' stamp: 'tween 3/16/2007 12:44'! fromBytes: aByteArray index: anInteger "share alike instances" self allInstancesDo: [:inst | (inst fileContentsExternalMemoryBytes = aByteArray and: [inst index = anInteger]) ifTrue: [^inst "validate"]]. ^(self basicNew) fileContentsExternalMemory: (FreeTypeExternalMemory bytes: aByteArray); index: anInteger; yourself! ! !FreeTypeFileInfo commentStamp: 'TorstenBergmann 2/4/2014 22:10'! File infos for a FreeType font! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 00:55'! fileSize "Answer the value of fileSize" ^ fileSize! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'CamilloBruni 5/4/2012 20:21'! baseName ^ absolutePath asFileReference basename! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/15/2007 17:31'! locationType "Answer the value of locationType" ^ locationType! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 01:14'! modificationTime: anObject "Set the value of modificationTime" modificationTime := anObject! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 01:14'! modificationTime "Answer the value of modificationTime" ^ modificationTime! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 00:55'! fileSize: anObject "Set the value of fileSize" fileSize := anObject! ! !FreeTypeFileInfo methodsFor: 'printing' stamp: 'tween 8/16/2007 01:08'! printOn: aStream "super printOn: aStream." aStream nextPutAll: familyGroupName asString, '::',styleNameExtracted asString, ' '; nextPutAll: (locationType = #absolute ifTrue:[''] ifFalse:['{',locationType asString,'}']); nextPutAll: absoluteOrRelativePath asString; nextPutAll: '[',index asString,'] '; nextPutAll: familyName asString; nextPutAll: ' - ', styleName asString; nextPutAll: ' - ', postscriptName asString; nextPutAll: ' ',(bold ifTrue:['B'] ifFalse:['']); nextPutAll: ' ',(italic ifTrue:['I'] ifFalse:['']); nextPutAll: ' ',(fixedWidth ifTrue:['Monospaced'] ifFalse:['']); nextPutAll: ' ',(stretchValue asString); nextPutAll: ' ',(weightValue asString); cr! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 04:26'! absolutePath: anObject "Set the value of absolutePath" absolutePath := anObject! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/15/2007 18:29'! absoluteOrRelativePath "Answer the value of absoluteOrRelativePath" ^ absoluteOrRelativePath! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/15/2007 17:31'! locationType: anObject "Set the value of locationType" locationType := anObject! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/15/2007 18:29'! absoluteOrRelativePath: anObject "Set the value of absoluteOrRelativePath" absoluteOrRelativePath := anObject! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 04:26'! absolutePath "Answer the value of absolutePath" ^ absolutePath! ! !FreeTypeFileInfoAbstract commentStamp: 'TorstenBergmann 2/4/2014 22:10'! Abstract superclass for file infos for a FreeType font! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! numFaces "Answer the value of numFaces" ^ numFaces! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/12/2007 19:27'! styleNameExtracted ^styleNameExtracted! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! stretchValue: anObject "Set the value of stretchValue" stretchValue := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! bold: anObject "Set the value of bold" bold := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'testing' stamp: 'tween 7/16/2007 00:31'! isEmbedded ^false! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! italic "Answer the value of italic" ^ italic! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:44'! styleNameWithWeightForcedToBe: aString italicForcedToBe: aString2 | answer | answer := ''. stretch ifNotNil:[ answer := answer ,stretch]. answer := answer , ' ', aString. answer := answer , ' ', aString2. answer := answer trimBoth. ^answer ! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! bold "Answer the value of bold" ^ bold! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 9/29/2007 10:41'! isItalicOrOblique ^self slantValue > 0! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! postscriptName "Answer the value of postscriptName" ^ postscriptName! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:44'! validStyleName "answer the receiver's styleName, or an alternative name to use if the styleName is invalid for some reason" (styleName copyWithout: $? ) ifEmpty:[ | answer | "workaround problem with FreeType 2.2.1 and MS Gothic, MS Mincho where familyName is not read correctly. This may be fixed in later versions of FreeType" answer := ''. italic ifTrue:[answer := answer , 'Italic ']. bold ifTrue:[answer := answer, 'Bold ']. (italic or:[bold]) not ifTrue:[answer := answer, 'Regular ']. ^answer trimBoth]. ^styleName! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! weightValue "Answer the value of weightValue" ^ weightValue! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! postscriptName: anObject "Set the value of postscriptName" postscriptName := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:44'! styleNameWithItalicForcedToBe: aString | answer | answer := ''. stretch ifNotNil:[ answer := answer ,stretch]. (weight notNil "and:[weight asLowercase ~= 'medium']") ifTrue:[ answer := answer , ' ', weight]. answer := answer , ' ', aString. answer := answer trimBoth. ^answer ! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:59'! slant "Answer the value of slant" ^ slant! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! index "Answer the value of index" ^ index! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! stretchValue "Answer the value of stretchValue" ^ stretchValue! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! styleName "Answer the value of styleName" ^ styleName! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! numFaces: anObject "Set the value of numFaces" numFaces := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:44'! styleNameWithWeightForcedToBe: aString | answer | answer := ''. stretch ifNotNil:[ answer := answer ,stretch]. answer := answer , ' ', aString. slant ifNotNil:[ answer := answer , ' ', slant]. answer := answer trimBoth. ^answer ! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! familyName "Answer the value of familyName" ^ familyName! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 9/29/2007 10:42'! isBolderThan: val ^self weightValue >= val! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! weightValue: anObject "Set the value of weightValue" weightValue := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! familyGroupName "Answer the value of familyGroupName" ^ familyGroupName! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! familyName: anObject "Set the value of familyName" familyName := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/11/2007 14:22'! stretch "Answer the value of stretch" ^ stretch! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! italic: anObject "Set the value of italic" italic := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:59'! style "Answer the value of slant" ^ slant! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/11/2007 14:22'! weight "Answer the value of weight" ^ weight! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:44'! extractAttributesFromNames "derive values for the receiver's style(italic), weight, and stretch inst vars. Also set the familyGroupName and styleNameExtracted" | p | p:= FreeTypeNameParser new familyNameIn: self validFamilyName; styleNameIn: self validStyleName; italicFlag: italic; boldFlag: bold; parse. familyGroupName := p familyName. slant := p extractedSlant. slantValue := p extractedSlantValue. weight := p extractedWeight. weightValue := p extractedWeightValue. stretch := p extractedStretch. stretchValue := p extractedStretchValue. upright := p extractedUpright. styleNameExtracted := ''. stretch ifNotNil:[ styleNameExtracted := styleNameExtracted ,stretch]. (weight notNil "and:[weight asLowercase ~= 'medium']") ifTrue:[ styleNameExtracted := styleNameExtracted , ' ', weight]. slant ifNotNil:[ styleNameExtracted := styleNameExtracted , ' ', slant]. styleNameExtracted := styleNameExtracted trimBoth. styleNameExtracted ifEmpty: [ styleNameExtracted := upright ifNil:['Regular']]. ! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! fixedWidth "Answer the value of fixedWidth" ^ fixedWidth! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! index: anObject "Set the value of index" index := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! styleName: anObject "Set the value of styleName" styleName := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 9/1/2007 18:38'! validFamilyName "answer the receiver's familyName, or an alternative name to use if the familyName is invalid for some reason" (familyName copyWithout: $? ) ifEmpty:[ "workaround problem with FreeType 2.2.1 and MS Gothic, MS Mincho where familyName is not read correctly. This may be fixed in later versions of FreeType" self baseName asUppercase = 'MSGOTHIC' ifTrue:[ index = 0 ifTrue:[^'MS Gothic']. index = 1 ifTrue:[^'MS PGothic']. index = 2 ifTrue:[^'MS UI Gothic']]. self baseName asUppercase = 'MSMINCHO' ifTrue:[ index = 0 ifTrue:[^'MS Mincho']. index = 1 ifTrue:[^'MS PMincho']. ^self baseName asUppercase, ' ', index asString]]. ^familyName! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 21:39'! slantValue ^slantValue! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! fixedWidth: anObject "Set the value of fixedWidth" fixedWidth := anObject! ! !FreeTypeFont commentStamp: 'TorstenBergmann 2/4/2014 22:10'! A FreeType font! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/3/2007 17:22'! ascent | asc desc h | cachedAscent ifNotNil:[^cachedAscent]. asc := self basicAscent. desc := self descent. h := self height. asc + desc < h ifFalse:[^cachedAscent := asc]. "height is greater than asc+desc, adjust ascent to include the difference" ^cachedAscent := h - desc ! ! !FreeTypeFont methodsFor: 'displaying' stamp: 'tween 3/17/2007 11:32'! displayUnderlineOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint | underlineTop underlineBottom underlineThickness s e | underlineThickness := (self face underlineThickness * self pixelSize / self face unitsPerEm). underlineTop := (self face underlinePosition * self pixelSize / self face unitsPerEm) negated - (underlineThickness/2). underlineTop := underlineTop rounded + 1. "needs the +1 , possibly because glyph origins are moved down by 1 so that their baselines line up with strike fonts" underlineBottom := underlineTop + underlineThickness ceiling. s := baselineStartPoint + (0@underlineTop). e := baselineEndPoint + (0@(underlineBottom)). self displayLineGlyphOn: aDisplayContext from: s to: e! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:45'! isSimulatedRegular ^simulatedEmphasis = 0! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/31/2007 23:08'! hintedWidthOf: aCharacter "retrieve advance width for character. try to use cached glyph if possible" | charCode answer | charCode := aCharacter asUnicode asInteger. answer := FreeTypeCache current atFont: self charCode: charCode type: FreeTypeCacheWidth ifAbsentPut: [self getWidthOf: aCharacter]. ^answer ! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:42'! simulatedEmphasis "Answer the simulatedEmphasis. This is 0 - normal (no simulatedEmphasis, or simulated regular). 1 - bold 2 - italic 3 - bold & italic" ^simulatedEmphasis ifNil:[0]! ! !FreeTypeFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 11/7/2011 14:15'! getGlyphWidth: aCharacter aCharacter asciiValue = 9 ifTrue: [ ^ (self linearWidthOf: Character space) * 8 ]. ^ (self linearWidthOf: aCharacter)! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:41'! isSimulated ^simulatedEmphasis notNil! ! !FreeTypeFont methodsFor: 'initialize-release' stamp: 'tween 3/17/2007 11:39'! initialize: aFont self face: aFont face.! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/3/2007 17:25'! height ^cachedHeight ifNil:[ cachedHeight := (self face height * self pixelSize / self face unitsPerEm) ceiling ]! ! !FreeTypeFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 10/28/2011 11:46'! getPreciseHeight "get precise font ascent, can be floating value" ^(self face height * self pixelSize / self face unitsPerEm) asFloat. ! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 7/15/2007 21:59'! kerningLeft: leftChar right: rightChar ^self isSubPixelPositioned ifTrue: [self linearKerningLeft: leftChar right: rightChar] ifFalse:[self hintedKerningLeft: leftChar right: rightChar]! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/17/2007 11:45'! pointSize: aSize pointSize := aSize! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:34'! face: aFace face := aFace! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:43'! simulatedBoldStrength "Answer the amount by which glyphs need to be emboldened/lightened according to the receiver's simulated emphasis and the face's real emphasis" | bold faceBold | self isSimulated ifFalse:[^0]. bold := self isSimulatedBold. faceBold := face isBold. (bold and: [faceBold not]) ifTrue:[^self pixelSize/24]. ^0! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:44'! simulatedItalicSlant "Answer the slant that needs to be added to italicize/un-italicize glyphs according to the receiver's simulated emphasis and the face's real emphasis" | italic faceItalic | self isSimulated ifFalse:[^0]. italic := self isSimulatedItalic. faceItalic := face isItalic. (italic and: [faceItalic not]) ifTrue:[^self defaultSimulatedItalicSlant]. ^0! ! !FreeTypeFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 9/1/2012 21:00'! getPreciseAscent "we using face bouding box for getting ascent value, otherwise two different font sizes on same line won't align properly" ^(self face ascender * self pixelSize / self face unitsPerEm) asFloat. ! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:48'! isItalic ^(simulatedEmphasis == nil and:[self face isItalic]) or:[self isSimulatedItalic]! ! !FreeTypeFont methodsFor: 'testing' stamp: 'nice 1/5/2010 15:59'! hasDistinctGlyphsForAll: asciiString "Answer true if the receiver has glyphs for all the characters in asciiString and no single glyph is shared by more than one character, false otherwise. The default behaviour is to answer true, but subclasses may reimplement" | setOfIndices | self face isValid ifFalse:[^false]. setOfIndices := Set new. asciiString asSet do:[:c | | i | (i := self face primGetCharIndex: c asInteger) = 0 ifTrue:[^false] ifFalse:[ (setOfIndices includes: i) ifTrue:[^false] ifFalse:[setOfIndices add: i]]]. ^true! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/31/2007 11:38'! pixelSize ^pixelSize ifNil:[pixelSize := super pixelSize rounded]! ! !FreeTypeFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 10/20/2011 05:12'! glyphRendererOn: anAthensSurface ^ anAthensSurface getFreetypeFontRendererFor: self ! ! !FreeTypeFont methodsFor: 'glyph lookup' stamp: 'tween 9/1/2007 15:35'! glyphOf: aCharacter destDepth: destDepth colorValue: aColorValue subpixelPosition: sub "sub can be between 0 and 63 and denotes the sub-pixel position of the glyph" | validSub | validSub := self isSubPixelPositioned ifTrue: [((sub asInteger max: 0) min: 63) "bitAnd: 2r111000"] ifFalse:[0]. ^(destDepth >=8 and:[FreeTypeSettings current subPixelAntiAliasing]) ifTrue:[ self subGlyphOf: aCharacter colorValue: aColorValue mono: FreeTypeSettings current monoHinting subpixelPosition: validSub] ifFalse:[ (destDepth >= 8 and:[FreeTypeSettings current bitBltSubPixelAvailable]) ifTrue:[ self mode41GlyphOf: aCharacter colorValue: aColorValue mono: FreeTypeSettings current monoHinting subpixelPosition: validSub] ifFalse:[ self glyphOf: aCharacter colorValue: aColorValue mono: FreeTypeSettings current monoHinting subpixelPosition: validSub]]! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:47'! setFace: aFreetypeFace pointSize: anInteger face := aFreetypeFace. pointSize := anInteger.! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:44'! defaultSimulatedItalicSlant ^0.22! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:33'! face "Validate, and answer, the receiver's face" ^face validate! ! !FreeTypeFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 11/7/2011 14:47'! getPreciseDescent "we using face bouding box for getting ascent value, otherwise two different font sizes on same line won't align properly" ^(self face descender * self pixelSize / self face unitsPerEm) asFloat negated. ! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 8/1/2007 01:08'! isSymbolFont | charmaps | symbolFont ifNotNil:[^symbolFont]. self face isValid ifFalse:[^false]. charmaps := self face charmaps. (charmaps includes: 'symb') ifTrue:[^symbolFont := true]."MS Symbol font" ^symbolFont := false! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/2/2007 22:11'! widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray "Set the first element of aTwoElementArray to the width of leftCharacter and the second element to the width of left character when kerned with rightCharacterOrNil. Answer the receiver We use a widthAndKernedWidthCache to store these values for speed" | privateArray | privateArray := (self widthAndKernedWidthCache at: leftCharacter ifAbsentPut:[Dictionary new]) at: (rightCharacterOrNil ifNil:[0 asCharacter]) ifAbsentPut:[ super widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: (Array new: 2)]. "We can't answer privateArray, we MUST copy its elements into aTwoElementArray" aTwoElementArray at: 1 put: (privateArray at: 1); at: 2 put: (privateArray at: 2). ^aTwoElementArray! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 7/15/2007 21:57'! subPixelPositioned "Answer true if the receiver is currently using subpixel positioned glyphs, false otherwise. This affects how padded space sizes are calculated when composing text." | settings | ^subPixelPositioned ifNil:[ settings := FreeTypeSettings current. subPixelPositioned := settings hinting not or:[settings lightHinting]]! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 3/29/2007 13:28'! hasGlyphsForAll: asciiString "Answer true if the receiver has glyphs for all the characters in asciiString, false otherwise. The default behaviour is to answer true, but subclasses may reimplement" self face isValid ifFalse:[^false]. asciiString do:[:c | (self face primGetCharIndex: c asInteger) = 0 ifTrue:[^false]]. ^true! ! !FreeTypeFont methodsFor: 'glyph lookup' stamp: 'tween 4/4/2007 19:14'! mode41GlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub | | ^FreeTypeCache current atFont: self charCode: aCharacter asUnicode asInteger type: (FreeTypeCacheGlyph + sub) ifAbsentPut: [ FreeTypeGlyphRenderer current mode41GlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: self] ! ! !FreeTypeFont methodsFor: 'glyph lookup' stamp: 'tween 4/4/2007 19:13'! subGlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub | | ^FreeTypeCache current atFont: self charCode: aCharacter asUnicode asInteger type: FreeTypeCacheGlyphLCD + sub ifAbsentPut: [ FreeTypeGlyphRenderer current subGlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: self] ! ! !FreeTypeFont methodsFor: 'glyph lookup' stamp: 'tween 4/4/2007 19:13'! glyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub | | ^FreeTypeCache current atFont: self charCode: aCharacter asUnicode asInteger type: ((1+sub) << 32) + aColorValue ifAbsentPut: [ FreeTypeGlyphRenderer current glyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: self] ! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 7/15/2007 21:55'! isSubPixelPositioned "Answer true if the receiver is currently using subpixel positioned glyphs, false otherwise. This affects how padded space sizes are calculated when composing text. Currently, only FreeTypeFonts are subPixelPositioned, and only when not Hinted" ^self subPixelPositioned! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 7/15/2007 22:00'! widthOf: aCharacter "retrieve advance width for character. try to use cached glyph if possible" ^self isSubPixelPositioned ifTrue:[self linearWidthOf: aCharacter] ifFalse: [self hintedWidthOf: aCharacter] ! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/3/2007 17:24'! descent ^cachedDescent ifNil:[ cachedDescent := ((self face descender * self pixelSize // self face unitsPerEm) negated) ]! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 7/15/2007 22:00'! clearCachedMetrics widthAndKernedWidthCache := cachedHeight := cachedAscent := cachedDescent := subPixelPositioned := nil! ! !FreeTypeFont methodsFor: 'displaying' stamp: 'tween 9/1/2007 10:32'! displayLineGlyphOn: aDisplayContext from: startPoint to: endPoint | oldCombinationRule oldHalftoneForm originalColorMap clr depth foreColorVal foreColorAlpha glyph width height startPointX startPointY endPointX endPointY foreColor | oldCombinationRule := aDisplayContext combinationRule . oldHalftoneForm := aDisplayContext halftoneForm . originalColorMap := aDisplayContext colorMap. clr := (foreColor := aDisplayContext lastFontForegroundColor ifNil:[Color black asNontranslucentColor]) pixelValueForDepth: 32. depth := aDisplayContext destForm depth. foreColorVal := clr bitAnd: 16rFFFFFF. foreColorAlpha := (clr bitAnd: 16rFF000000) >> 24. depth <= 8 ifTrue:[ aDisplayContext colorMap: (aDisplayContext cachedFontColormapFrom:32 to: depth)] ifFalse:[ aDisplayContext colorMap: nil]. startPointX := startPoint x truncated. startPointY := startPoint y. endPointX := endPoint x ceiling. endPointY := endPoint y. width := endPointX - startPointX. height := endPointY - startPointY. glyph := (Form extent: width@height depth: 32) fillWhite. "we could cache a big white glyph somewhere to save having to create this. Clipping will make only a part of it display" aDisplayContext sourceForm: glyph. aDisplayContext destOrigin: startPointX@startPointY. aDisplayContext width: width. aDisplayContext height: height. aDisplayContext sourceOrigin: 0@0; halftoneForm: nil. (FreeTypeSettings current bitBltSubPixelAvailable and: [depth >= 8]) ifTrue:[ aDisplayContext combinationRule: 41. aDisplayContext copyBitsColor: foreColorVal alpha: foreColorAlpha gammaTable: FreeTypeSettings current gammaTable ungammaTable: FreeTypeSettings current gammaInverseTable] ifFalse:[ glyph fillWithColor: foreColor. aDisplayContext combinationRule: (depth <= 8 ifTrue: [Form paint] ifFalse: [34]). aDisplayContext copyBits]. aDisplayContext colorMap: originalColorMap; combinationRule: oldCombinationRule; halftoneForm: oldHalftoneForm. ! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:49'! isBold ^(simulatedEmphasis == nil and:[self face isBold]) or:[self isSimulatedBold]! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 7/4/2009 12:58'! widthOfString: aString from: startIndex to: stopIndex "Measure the length of the given string between start and stop index. Currently this allows for the right side bearing of the last char, but does not allow for the left side bearing of the first char. We really need a new method - boundingBoxOfString that allows for both. Senders of this will also need to know the LSB of the first char, and position their text accordingly" | char nextChar resultX glyph a subPixelPosition | a := Array new: 2. "FreeTypeSettings current hinting ifFalse:[ ^self linearWidthOfString: aString from: startIndex to: stopIndex]." resultX := 0. startIndex to: stopIndex do:[:i | char := aString at: i. nextChar := (i + 1 <= stopIndex) ifTrue:[ aString at: i + 1] ifFalse:[nil]. self widthAndKernedWidthOfLeft: char right: nextChar into: a. resultX := resultX + (a at:2). i = stopIndex ifTrue:[ subPixelPosition := (((resultX \\ 1) roundTo: "1/64" 0.015625) * 64) asInteger. subPixelPosition = 64 ifTrue:[ subPixelPosition := 0. resultX := resultX + 1 ]. subPixelPosition := (subPixelPosition max: 0) min: 63. glyph := self glyphOf: char colorValue: 0 mono: FreeTypeSettings current monoHinting subpixelPosition: subPixelPosition. glyph ifNotNil:[ "currently the glyph is too wide. This is to allow for some extra space to ensure the glyph is not clipped when it is produced. Either make the width accurate, or hold the RSB value separately, or hold an accurate width separately" resultX := resultX "+ 2" + glyph offset x "negated" + (glyph width - (a at: 2) "glyph linearAdvance x floor")]]]. ^resultX ceiling ! ! !FreeTypeFont methodsFor: '*Text-Scanning' stamp: 'nice 10/29/2013 04:07'! scanByteCharactersFrom: startIndex to: stopIndex in: aByteString with: aCharacterScanner rightX: rightX "scan a single byte character string" ^aCharacterScanner scanKernableByteCharactersFrom: startIndex to: stopIndex in: aByteString rightX: rightX! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 3/17/2007 11:42'! isTTCFont "not really - look for senders of this" ^true! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:44'! maxAscii "should have default in AbstractFont" ^SmallInteger maxVal! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/3/2007 16:42'! hintedKerningLeft: leftChar right: rightChar ^(self linearKerningLeft: leftChar right: rightChar) rounded! ! !FreeTypeFont methodsFor: 'displaying' stamp: 'tween 3/17/2007 11:30'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta ^self displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:43'! simulatedEmphasis: anIntegerOrNil "Set the simulatedEmphasis. This is nil - no simulated emphasis 0 - normal (simulated regular). 1 - bold 2 - italic 3 - bold & italic" simulatedEmphasis := anIntegerOrNil! ! !FreeTypeFont methodsFor: 'initialize-release' stamp: 'tween 3/17/2007 11:45'! releaseCachedState face releaseCachedState. FreeTypeCache current removeAllForFont: self.! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:49'! isRegular ^(simulatedEmphasis == nil and:[self face isRegular]) or: [self isSimulatedRegular]! ! !FreeTypeFont methodsFor: 'displaying' stamp: 'tween 4/5/2007 08:15'! installOn: aBitBlt foregroundColor: foreColor backgroundColor: backColor | | "fcolor := foreColor pixelValueForDepth: 32." aBitBlt installFreeTypeFont: self foregroundColor: foreColor backgroundColor: backColor. ! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 3/17/2007 11:41'! isFixedWidth ^self face isFixedWidth ! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:45'! isSimulatedItalic ^self simulatedEmphasis anyMask: 2! ! !FreeTypeFont methodsFor: 'printing' stamp: 'tween 3/17/2007 11:45'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(; print: face familyName; space; print: face styleName; space; print: pointSize; nextPut: $)! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/17/2007 11:43'! lineGrid ^self height! ! !FreeTypeFont methodsFor: 'notifications' stamp: 'tween 4/3/2007 16:48'! pixelsPerInchChanged "the TextStyle pixels per inch setting has changed" pixelSize := nil. widthAndKernedWidthCache := nil. FreeTypeCache current removeAllForFont: self.! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 8/27/2007 10:02'! postscriptName ^self face postscriptName! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/2/2007 22:10'! widthAndKernedWidthCache ^widthAndKernedWidthCache ifNil:[widthAndKernedWidthCache := Dictionary new]! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'dik 6/10/2010 21:13'! veryDeepCopyWith: deepCopier! ! !FreeTypeFont methodsFor: 'displaying' stamp: 'tween 4/5/2007 09:32'! displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY | glyph depth foreColorVal foreColorAlpha originalColorMap clr subPixelPosition widthAndKernedWidth char nextChar floatDestX destX destY offset gammaTable gammaInverseTable useRule41 | useRule41 := FreeTypeSettings current bitBltSubPixelAvailable and: [aBitBlt destForm depth >= 8]. depth := aBitBlt destForm depth. originalColorMap := aBitBlt colorMap. clr := (aBitBlt lastFontForegroundColor ifNil:[Color black asNontranslucentColor]) pixelValueForDepth: 32. useRule41 ifTrue:[ foreColorVal := clr bitAnd: 16rFFFFFF. foreColorAlpha := (clr bitAnd: 16rFF000000) >> 24. gammaTable := FreeTypeSettings current gammaTable. gammaInverseTable := FreeTypeSettings current gammaInverseTable.] ifFalse:[ foreColorVal := clr]. depth <= 8 ifTrue:[ aBitBlt colorMap: (aBitBlt cachedFontColormapFrom:32 to: depth)] ifFalse:[ aBitBlt colorMap: nil]. destX := aPoint x. destY := baselineY. floatDestX := aPoint x. widthAndKernedWidth := Array new: 2. startIndex to: stopIndex do: [:i | subPixelPosition := ((floatDestX \\ 1) roundTo: "1/64" 0.015625) * 64. subPixelPosition = 64 ifTrue:[ subPixelPosition := 0. destX := destX + 1]. char := aString at: i. glyph := self glyphOf: char destDepth: depth colorValue: foreColorVal subpixelPosition: subPixelPosition. aBitBlt sourceForm: glyph. offset := glyph offset. aBitBlt destX: destX + offset x. aBitBlt destY: destY + offset y. aBitBlt width: glyph width. aBitBlt height: glyph height. useRule41 ifTrue:[ aBitBlt copyBitsColor: foreColorVal alpha: foreColorAlpha gammaTable: gammaTable ungammaTable: gammaInverseTable] ifFalse:[ aBitBlt copyBits]. nextChar := (i + 1 <= stopIndex) ifTrue:[aString at: i + 1] ifFalse:[nil]. self widthAndKernedWidthOfLeft: char right: nextChar into: widthAndKernedWidth. floatDestX := floatDestX + (widthAndKernedWidth at: 2) + kernDelta. destX := floatDestX ]. aBitBlt colorMap: originalColorMap. ^ destX @ destY ! ! !FreeTypeFont methodsFor: '*Text-Scanning' stamp: 'nice 10/29/2013 04:08'! scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX "scan a multibyte character string" ^aCharacterScanner scanKernableMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString rightX: rightX ! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/26/2007 13:14'! basicAscent ^(self face ascender * self pixelSize // self face unitsPerEm). ! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/17/2007 11:28'! descentKern "should have default in AbstractFont" ^0! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/31/2007 11:57'! hash ^pointSize hash! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'michael.rueger 2/5/2009 17:03'! getLinearWidthOf: aCharacter | em glyph la charCode | aCharacter < $ ifTrue: [^self getLinearWidthOf: $ ]. charCode := aCharacter asUnicode asInteger. (self face charmaps includes:'unic') ifTrue:[ (self isSymbolFont and:[charCode >= 16r20 and: [charCode <= 16rFF ] ]) ifTrue:[charCode := charCode + 16rF000]] ifFalse:[ (self face charmaps includes:'armn') ifTrue:[ "select apple roman char map, and map character from unicode to mac encoding" self face setCharMap:'armn'. charCode := aCharacter unicodeToMacRoman asUnicode asInteger. "check this!!"]]. em := self pixelSize. face validate. face setPixelWidth: em height: em. [face loadCharacter: charCode flags: (LoadNoBitmap bitOr: (LoadIgnoreTransform bitOr: "FreeTypeSettings current hintingFlags" 2 "no hinting"))] on: FT2Error do:[:e | face loadGlyph: 0 flags: (LoadNoBitmap bitOr: (LoadIgnoreTransform bitOr: FreeTypeSettings current hintingFlags "no hinting")) ]. glyph := face glyph. la := glyph linearHorizontalAdvance. la isZero ifTrue:[ "FreeType 2.2.1 sometimes screws up when getting metrics, Maybe the bug is in the plugin? For example Calibri pixel size 13 gives linearAdvance x of zero !! We try again at double the size, and half the result" em := self pixelSize * 2. face validate. face setPixelWidth: em height: em. face loadCharacter: charCode flags:(LoadNoBitmap bitOr: (LoadIgnoreTransform bitOr: "FreeTypeSettings current hintingFlags" 2 "no hinting")). "load glyph metrics" glyph := face glyph. la := glyph linearHorizontalAdvance / 2.0]. ^la ! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'michael.rueger 2/5/2009 17:04'! linearKerningLeft: leftChar right: rightChar | f l r | f := self face. f hasKerning ifFalse:[^0]. l := leftChar asUnicode. r := rightChar asUnicode. (self face charmaps includes:'unic') ifTrue:[ self isSymbolFont ifTrue:[ (l asInteger >= 16r20 and:[l asInteger <= 16rFF ]) ifTrue:[l := (Character value: l asInteger + 16rF000) asUnicode]. (r asInteger >= 16r20 and:[ r asInteger <= 16rFF ]) ifTrue:[r := (Character value: r asInteger + 16rF000) asUnicode]]] ifFalse:[ (self face charmaps includes:'armn') ifTrue:[ "select apple roman char map, and map characters from unicode to mac encoding" self face setCharMap:'armn'. (l asInteger >= 16r20 and:[l asInteger <= 16rFF ]) ifTrue:[l := (Character value: l asInteger) unicodeToMacRoman]. (r asInteger >= 16r20 and:[ r asInteger <= 16rFF ]) ifTrue:[r := (Character value: r asInteger) unicodeToMacRoman]]]. ^(f kerningLeft: l right: r) x asFloat * self pixelSize / f unitsPerEm! ! !FreeTypeFont methodsFor: 'displaying' stamp: 'tween 3/17/2007 11:30'! displayStrikeoutOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint | top bottom strikeoutThickness s e | "the strikeout size/position for TrueType fonts should really come from the TT_OS2 table. This needs to be read by the plugin when the face is created. For now, we use the underlineThickness, and 1/4 of the ascender from the baseline" strikeoutThickness := (self face underlineThickness * self pixelSize / self face unitsPerEm). top := ((self face ascender / 4) * self pixelSize / self face unitsPerEm) negated - (strikeoutThickness/2). top := top rounded. bottom := top + strikeoutThickness ceiling. s := baselineStartPoint + (0@top). e := baselineEndPoint + (0@bottom). self displayLineGlyphOn: aDisplayContext from: s to: e ! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/31/2007 20:18'! linearWidthOf: aCharacter "retrieve linear advance width for character. try to use cached glyph if possible. This is the scaled, unrounded advance width." | charCode answer | charCode := aCharacter asUnicode asInteger. answer := FreeTypeCache current atFont: self charCode: charCode type: FreeTypeCacheLinearWidth ifAbsentPut: [self getLinearWidthOf: aCharacter]. ^answer ! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:44'! minAscii "should have default in AbstractFont" ^0! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:42'! isSimulatedBold ^self simulatedEmphasis anyMask: 1! ! !FreeTypeFont methodsFor: 'glyph lookup' stamp: 'tween 9/1/2007 09:54'! characterFormAt: aCharacter FreeTypeSettings current forceNonSubPixelDuring:[ ^self glyphOf: aCharacter destDepth: 32 colorValue: (Color black pixelValueForDepth: 32) subpixelPosition: 0]! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'michael.rueger 2/5/2009 17:03'! getWidthOf: aCharacter "Glyphs are either 1 or 8 bit deep. For 32 bpp we use 8 bits, otherwise 1" | em glyph hintingFlags flags charCode | aCharacter < $ ifTrue: [^self getWidthOf: $ ]. charCode := aCharacter asUnicode asInteger. (self face charmaps includes:'unic') ifTrue:[ (self isSymbolFont and:[charCode >= 16r20 and: [charCode <= 16rFF ] ]) ifTrue:[charCode := charCode + 16rF000]] ifFalse:[ (self face charmaps includes:'armn') ifTrue:[ "select apple roman char map, and map character from unicode to mac encoding" self face setCharMap:'armn'. charCode := aCharacter unicodeToMacRoman asUnicode asInteger. "check this!!"]]. em := self pixelSize. face validate. face isValid ifFalse:[^0]. face setPixelWidth: em height: em. hintingFlags := FreeTypeSettings current hintingFlags. flags := LoadNoBitmap bitOr:( LoadIgnoreTransform bitOr: hintingFlags). [face loadCharacter: charCode flags: flags. ] on:FT2Error do:[:e | "character not in map?"^0]. glyph := face glyph. "When not hinting FreeType sets the advance to the truncated linearAdvance. The characters appear squashed together. Rounding is probably better, so we answer the rounded linear advance here" ^self subPixelPositioned ifTrue:[ glyph roundedPixelLinearAdvance x] ifFalse:[ glyph advance x]. ! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/17/2007 11:45'! pointSize ^pointSize! ! !FreeTypeFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 11/20/2013 14:15'! asFreetypeFont ^ self! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:27'! depth ^ 32.! ! !FreeTypeFont class methodsFor: 'instance creation' stamp: 'tween 7/16/2007 00:33'! fromBytes: aByteArray pointSize: anInteger index: i ^self new setFace: (FreeTypeFace fromBytes: aByteArray index: i) pointSize: anInteger; yourself! ! !FreeTypeFont class methodsFor: 'instance creation' stamp: 'marcus.denker 12/16/2008 11:17'! fromFile: aFileName pointSize: anInteger index: i ^self new setFace: (FreeTypeFace fromFile: aFileName index: i) pointSize: anInteger; yourself! ! !FreeTypeFont class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/15/2012 19:13'! forLogicalFont: aLogicalFont fileInfo: aFreeTypeFileInfoAbstract | pointSize index | pointSize := aLogicalFont pointSize. index := aFreeTypeFileInfoAbstract index. ^aFreeTypeFileInfoAbstract isEmbedded ifTrue:[ self fromBytes: aFreeTypeFileInfoAbstract fileContents pointSize: pointSize index: index] ifFalse:[ self fromFile: aFreeTypeFileInfoAbstract absolutePath pointSize: pointSize index: index]! ! !FreeTypeFontFamily commentStamp: 'TorstenBergmann 2/4/2014 22:07'! FreeType font family! !FreeTypeFontFamily methodsFor: 'initialization' stamp: 'tween 8/16/2007 20:44'! initialize super initialize. members := OrderedCollection new.! ! !FreeTypeFontFamily methodsFor: 'simulated members' stamp: 'nice 1/5/2010 15:59'! addSimulatedMembers | membersBySlantAndStretch membersByWeightAndStretch | membersBySlantAndStretch := Dictionary new. members do:[:each| (membersBySlantAndStretch at: {each slantValue. each stretchValue} ifAbsentPut:[OrderedCollection new]) add: each]. membersBySlantAndStretch keysAndValuesDo:[:key :col | | heaviest | heaviest := col ifNotEmpty:[col first]. col do:[:each | heaviest weightValue < each weightValue ifTrue:[heaviest := each]]. (heaviest weightValue between: (LogicalFont weightRegular - 50) and: (LogicalFont weightMedium + 50)) ifTrue:[ members add: heaviest asSimulatedBold]]. membersByWeightAndStretch := Dictionary new. members do:[:each| | normalizedWeight | normalizedWeight := each weightValue. each weightValue = LogicalFont weightMedium ifTrue:[normalizedWeight := LogicalFont weightRegular]. "regular and medium weights are used interchangeably. For example, FreeSans has Regular-weightMedium(500), and Oblique-weightRegular(400). We don't want to simulate oblique-weightMedium(500) when a real Oblique-weightMedium(500) exists, so we normalize any weightMedium(500) values to weightRegular(400) to prevent this happening" (membersByWeightAndStretch at: {normalizedWeight. each stretchValue} ifAbsentPut:[OrderedCollection new]) add: each]. membersByWeightAndStretch keysAndValuesDo:[:key :col | | oblique regular | regular := col detect: [:each | each slantValue = 0] ifNone:[]. oblique := col detect:[:each | each slantValue > 0] ifNone:[]. "oblique or italic" (oblique isNil and:[regular notNil]) ifTrue:[ regular simulated ifTrue:[members add: regular asSimulatedBoldOblique] ifFalse:[ members add: regular asSimulatedOblique]]]! ! !FreeTypeFontFamily methodsFor: 'accessing' stamp: 'nice 1/5/2010 15:59'! addMembersFromFileInfos: aCollectionOfFreeTypeFileInfo aCollectionOfFreeTypeFileInfo do:[:aFileInfo | | member | member := FreeTypeFontFamilyMember fromFileInfo: aFileInfo. (self memberWithStyleName: member styleName) ifNil:[self addMember: member]]. ! ! !FreeTypeFontFamily methodsFor: 'simulated members' stamp: 'tween 8/18/2007 22:22'! rebuildSimulatedMembers "FOR TESTING ONLY" members := members reject:[:each| each simulated]. self addSimulatedMembers.! ! !FreeTypeFontFamily methodsFor: 'accessing' stamp: 'tween 8/16/2007 22:59'! memberWithStyleName: aString ^members detect:[:each | each styleName = aString] ifNone:[] ! ! !FreeTypeFontFamily methodsFor: 'accessing' stamp: 'tween 8/25/2007 14:26'! addMember: aFreeTypeFontFamilyMember aFreeTypeFontFamilyMember family: self. members add: aFreeTypeFontFamilyMember! ! !FreeTypeFontFamilyMember commentStamp: 'TorstenBergmann 2/4/2014 22:08'! FreeType FontFamily member ! !FreeTypeFontFamilyMember methodsFor: 'copying' stamp: 'tween 9/29/2007 12:50'! asSimulatedBoldOblique ^self copy slantValue: LogicalFont slantItalic; "treat italic and oblique the same" weightValue:LogicalFont weightBold; styleName: (fileInfo styleNameWithWeightForcedToBe: 'Bold' italicForcedToBe: 'Oblique'); simulated: true; yourself! ! !FreeTypeFontFamilyMember methodsFor: 'copying' stamp: 'tween 9/29/2007 12:50'! asSimulatedOblique ^self copy slantValue: LogicalFont slantItalic; "treat italic and oblique the same" styleName: (fileInfo styleNameWithItalicForcedToBe: 'Oblique'); simulated: true; yourself! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! stretchName: anObject "Set the value of stretchName" stretchName := anObject! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! stretchValue "Answer the value of stretchValue" ^ stretchValue! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! weightName: anObject "Set the value of weightName" weightName := anObject! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! stretchValue: anObject "Set the value of stretchValue" stretchValue := anObject! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! weightValue: anObject "Set the value of weightValue" weightValue := anObject! ! !FreeTypeFontFamilyMember methodsFor: 'copying' stamp: 'tween 9/29/2007 12:49'! asSimulatedBold ^self copy weightValue: LogicalFont weightBold; styleName: (fileInfo styleNameWithWeightForcedToBe: 'Bold'); simulated: true; yourself! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! slantValue: anObject "Set the value of slantValue" slantValue := anObject! ! !FreeTypeFontFamilyMember methodsFor: 'comparing' stamp: 'tween 9/29/2007 12:51'! sortValue | v normalizedWeight | normalizedWeight := weightValue. normalizedWeight = LogicalFont weightMedium ifTrue:["sort medium and regular weights as though they were the same" normalizedWeight := LogicalFont weightRegular]. v :=self simulated ifTrue:[10000] ifFalse:[0]. v := v + (stretchValue * 1000). v := v + (normalizedWeight). v := v + (slantValue). ^v ! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! simulated "Answer the value of simulated" ^ simulated! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! stretchName "Answer the value of stretchName" ^ stretchName! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:46'! fileInfo "Answer the value of fileInfo" ^ fileInfo! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! simulated: anObject "Set the value of simulated" simulated := anObject! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! weightName "Answer the value of weightName" ^ weightName! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:46'! fileInfo: anObject "Set the value of fileInfo" fileInfo := anObject! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! weightValue "Answer the value of weightValue" ^ weightValue! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! slantName "Answer the value of slantName" ^ slantName! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! slantName: anObject "Set the value of slantName" slantName := anObject! ! !FreeTypeFontFamilyMember methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:29'! slantValue "Answer the value of slantValue" ^ slantValue! ! !FreeTypeFontFamilyMember methodsFor: 'comparing' stamp: 'tween 8/16/2007 23:23'! <= aFreeTypeFontFamilyMember ^self sortValue <= aFreeTypeFontFamilyMember sortValue! ! !FreeTypeFontFamilyMember class methodsFor: 'instance creation' stamp: 'tween 8/16/2007 21:39'! fromFileInfo: aFreeTypeFileInfo ^self new fileInfo: aFreeTypeFileInfo; simulated: false; styleName: aFreeTypeFileInfo styleNameExtracted; stretchName: aFreeTypeFileInfo stretch; stretchValue: aFreeTypeFileInfo stretchValue; weightName: aFreeTypeFileInfo weight; weightValue: aFreeTypeFileInfo weightValue; slantName: aFreeTypeFileInfo slant; slantValue: aFreeTypeFileInfo slantValue; yourself ! ! !FreeTypeFontProvider commentStamp: ''! This is a font provider for true type fonts. You can use it to add TTF files to your image: FreeTypeFontProvider current updateFromFileEntry: (FileDirectory default entryAt: 'UnDotum.ttf') directory: FileDirectory default locationType: #imageRelative. FreeTypeFontProvider current buildFamilies. FreeTypeFontSelectorDialogWindow new open. StandardFonts balloonFont: (LogicalFont familyName: 'UnDotum' pointSize: 10). StandardFonts defaultFont: (LogicalFont familyName: 'UnDotum' pointSize: 14).! !FreeTypeFontProvider methodsFor: 'file paths' stamp: 'nice 10/30/2013 21:38'! getWindowsFontFolderPath "Answer the windows font folder path. This is obtained through the Windows API if FFI is present, otherwise it is a guess !!" | externalLibraryClass externalTypeClass fun buff | externalLibraryClass := Smalltalk globals at: #ExternalLibraryFunction ifAbsent: [ ]. externalTypeClass := Smalltalk globals at: #ExternalType ifAbsent: [ ]. (externalLibraryClass isNil or: [ externalTypeClass isNil ]) ifTrue: [ ^ self guessWindowsFontFolderPath ]. fun := externalLibraryClass name: 'SHGetFolderPathA' module: 'shfolder.dll' callType: 1 returnType: externalTypeClass long argumentTypes: {(externalTypeClass long). (externalTypeClass long). (externalTypeClass long). (externalTypeClass long). (externalTypeClass char asPointerType)}. buff := ByteArray new: 1024. [ | r | r := fun invokeWith: 0 with: 16r0014 with: 0 with: 0 with: buff "CSIDL_FONTS" ] on: Error do: [ :e | "will get error if ffiplugin is missing" ^ self guessWindowsFontFolderPath ]. ^ (buff copyFrom: 1 to: (buff indexOf: 0) - 1) asString! ! !FreeTypeFontProvider methodsFor: 'error handling' stamp: 'CamilloBruni 7/15/2012 19:19'! failedToOpen: face from: path index: i face destroyHandle. "Transcript cr; show: 'Failed : ', path asString, '[', i asString,']'." "remove all cache entries for path with index >= i" ! ! !FreeTypeFontProvider methodsFor: 'accessing' stamp: 'tween 7/28/2007 13:28'! addFirstFileInfo: aFreeTypeFileInfo index: i fileInfos addFirst: aFreeTypeFileInfo ! ! !FreeTypeFontProvider methodsFor: 'error handling' stamp: 'CamilloBruni 7/15/2012 19:19'! failedToOpen: face index: i face destroyHandle. "Transcript cr; show: 'Failed : ', path asString, '[', i asString,']'." "remove all cache entries for path with index >= i" ! ! !FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'CamilloBruni 7/15/2012 19:26'! updateAvailableFontFamilies 'Calculating available font families' displayProgressFrom: 0 to: 1 during:[ :bar | "self removeUnavailableTextStyles." "self addTextStylesWithPointSizes: #(8 10 12 15 24)." tempFileInfos := nil. self buildFamilies. tempFamilies := nil ].! ! !FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'CamilloBruni 7/15/2012 19:34'! updateFromDirectory: aDirectory done: aSet "get info from fonts in aDirectory" (aSet includes: aDirectory) ifTrue: [ ^ self ]. aSet add: aDirectory. aDirectory files do: [ :each | "SUSE 10.2 has lots of files ending .gz that aren't fonts. We skip them to save time'" ((each basename beginsWith: '.' ) or: [ each basename asLowercase endsWith:' .gz' ]) ifFalse: [ self updateFromFile: each ]] displayingProgress: 'Loading fonts in ', aDirectory fullName. aDirectory directories do: [ :each | self updateFromDirectory: each done: aSet ].! ! !FreeTypeFontProvider methodsFor: 'initialization' stamp: 'DamienCassou 8/22/2009 15:14'! initialize super initialize. fileInfos := OrderedCollection new: 100. fileInfoCache := Dictionary new: 100. "keyed by file size" embeddedFileInfoCache := Dictionary new: 10. "keyed by file size" families := Dictionary new. ! ! !FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'CamilloBruni 7/15/2012 19:26'! prepareForUpdating. tempFileInfos := fileInfos. "tempFileInfos will be used during update" tempFamilies := families. "tempFamilies will be used during update" fileInfos := OrderedCollection new: 100.! ! !FreeTypeFontProvider methodsFor: 'accessing' stamp: 'CamilloBruni 7/15/2012 19:18'! fileInfosByFamilyAndGroup "Answer a Dictionary of Dictionaries of Sets. familyName->familyGroupName->Set(FreeTypeFileInfo) self current fileInfosByFamilyAndGroup " | answer | answer := Dictionary new. "file could be in fileInfos twice? need to only process once, need directory precedence?" fileInfos do:[:info | | group family | family := answer at: info familyName ifAbsentPut:[Dictionary new]. group := family at: info familyGroupName ifAbsentPut: [OrderedCollection new]. group detect:[:each| each bold = info bold and:[ each italic = info italic and:[ each fixedWidth = info fixedWidth and:[ each postscriptName = info postscriptName and:[ each styleName = info styleName ]]]]] ifNone:[ group add: info]]. ^ answer ! ! !FreeTypeFontProvider methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:41'! addFromFileContents: bytes baseName: originalFileBaseName | i face numFaces info externalMem cachedInfo cachedNumFaces | i:= 0. [(cachedInfo := self validEmbeddedCachedInfoFor: bytes index: i) notNil] whileTrue:[ i = 0 ifTrue:[cachedNumFaces := cachedInfo numFaces]. self addFirstFileInfo: cachedInfo index: i. i := i + 1.]. (cachedNumFaces notNil and:[i >= cachedNumFaces]) ifTrue:[^self]. [externalMem := FreeTypeExternalMemory bytes: bytes. externalMem validate. face := FreeTypeFace basicNew fileContentsExternalMemory: externalMem . [ "we use the primNewFaceFromFile:index: method because we want to do this as fast as possible and we don't need the face registered because it will be explicitly destroyed later" face primNewFaceFromExternalMemory: externalMem size: bytes size index: i. face loadFields] on: FT2Error do:[:e | self failedToOpen:face index: i. ^externalMem destroyHandle.]. (face height notNil and:[face hasFamilyName and:[face hasStyleName and:[face isValid]]]) ifFalse:[ self failedToOpen:face index: i. ^ externalMem destroyHandle.] ifTrue:[ numFaces ifNil: [numFaces := face numFaces]. info := FreeTypeEmbeddedFileInfo new baseName: originalFileBaseName; fileContents: bytes; index: i; familyName: face familyName; styleName: face styleName; postscriptName: face postscriptName; bold: face isBold; italic: face isItalic; fixedWidth: face isFixedWidth; numFaces: numFaces; extractAttributesFromNames; yourself. self addFirstFileInfo: info index: i. self cacheEmbeddedFileInfo: info index: i. "Transcript show: 'from file : ', info asString." face destroyHandle. externalMem destroyHandle]. i := i + 1. i < numFaces "note, we use < rather than <= , because i is zero based"] whileTrue:[]. ! ! !FreeTypeFontProvider methodsFor: 'file paths' stamp: 'CamilloBruni 7/15/2012 18:52'! platformImageRelativeDirectories | directory | directory := Smalltalk imagePath asFileReference / 'Fonts'. directory exists ifTrue: [ ^ { directory } ]. ^ #()! ! !FreeTypeFontProvider methodsFor: 'font lookup' stamp: 'tween 9/29/2007 10:48'! fontFor: aLogicalFont familyName: familyName | info answer simulatedSqueakEmphasis needsSimulatedBold needsSimulatedSlant squeakBoldEmphasis squeakItalicEmphasis | FT2Library current == nil ifTrue:[^nil]. info:= self fontInfoFor: aLogicalFont familyName: familyName. info ifNil:[^nil]. answer := FreeTypeFont forLogicalFont: aLogicalFont fileInfo: info. needsSimulatedBold := aLogicalFont isBoldOrBolder and:[(info isBolderThan: 500) not]. needsSimulatedSlant := aLogicalFont isItalicOrOblique and: [info isItalicOrOblique not]. (needsSimulatedBold or:[needsSimulatedSlant]) ifTrue:[ squeakBoldEmphasis := 1. squeakItalicEmphasis := 2. simulatedSqueakEmphasis := 0. needsSimulatedBold ifTrue:[ simulatedSqueakEmphasis := simulatedSqueakEmphasis + squeakBoldEmphasis]. needsSimulatedSlant ifTrue:[ simulatedSqueakEmphasis := simulatedSqueakEmphasis + squeakItalicEmphasis]. answer simulatedEmphasis: simulatedSqueakEmphasis]. answer face validate. answer face isValid ifFalse:[^nil]. "we may get this if startup causes text display BEFORE receiver has been updated from the system" ^answer! ! !FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'CamilloBruni 7/15/2012 19:23'! updateFileCacheInfo. fileInfoCache values do:[ :col | col copy do:[:each | | dir | dir := each absolutePath asFileReference. dir exists ifFalse: [ col remove: each ]]] displayingProgress: [ 'Updating cached file info' ].! ! !FreeTypeFontProvider methodsFor: 'font families' stamp: 'tween 8/16/2007 21:43'! buildFamilyNamed: aFamilyGroupName | infos family| family := FreeTypeFontFamily new familyName: aFamilyGroupName; yourself. infos := fileInfos select:[:each | each familyGroupName = aFamilyGroupName]. family addMembersFromFileInfos: infos. family addSimulatedMembers. ^family ! ! !FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'CamilloBruni 7/15/2012 19:11'! validCachedInfoFor: aFile index: i "answer info from cache if the file on the disk has the same size/timestamp as the cached info, otherwise answer nil" | cacheEntry fileSize modificationTime path | fileSize := aFile size. modificationTime := aFile modificationTime. path := aFile fullName. cacheEntry := (fileInfoCache at: {fileSize. i} ifAbsentPut: [ Set new ]) detect: [ :each | each modificationTime = modificationTime and: [ each absolutePath = path ]] ifNone:[]. "cacheEntry ifNotNil:[Transcript cr; show: 'from cache : ', cacheEntry asString]." ^ cacheEntry! ! !FreeTypeFontProvider methodsFor: 'file paths' stamp: 'EstebanLorenzano 8/3/2012 12:54'! guessWindowsFontFolderPath "Guess the location of the Windows font folder" | possibilities | possibilities := Set new. 'cdefghijklmnopqrstuvwxyz' do:[:drive | #('\windows\fonts' '\winnt\fonts') do:[:path | | d | (d := (FileLocator driveNamed: drive asSymbol) resolve: path) exists ifTrue:[possibilities add: d]]]. possibilities := possibilities asSortedCollection: [:a :b | a entry creationTime >= b entry creationTime]. possibilities ifNotEmpty:[ ^ possibilities first fullName ]. ^nil ! ! !FreeTypeFontProvider methodsFor: 'file paths' stamp: 'cami 7/22/2013 18:29'! platformAbsoluteDirectories Smalltalk os isWin32 ifTrue: [ ^ self winFontDirectories ]. Smalltalk os isUnix ifTrue: [ ^ self unixFontDirectories ]. Smalltalk os isMacOSX ifTrue: [ ^ self macOSXFolderDirectories ]. ^ {}! ! !FreeTypeFontProvider methodsFor: 'file paths' stamp: 'CamilloBruni 7/15/2012 18:50'! macOSXFolderDirectories "Answer the Mac OS X font folder paths. This needs some FFI code, but for the time being, we guess these and omit the user fonts folder" ^#('/System/Library/Fonts' '/Library/Fonts') collect: [ :each| each asFileReference ] thenSelect: [ :each| each exists ].! ! !FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'ClementBera 7/26/2013 16:42'! updateFromFile: aFile | i face numFaces cachedInfo info cachedNumFaces path | i:= 0. [(cachedInfo := self validCachedInfoFor: aFile index: i) notNil] whileTrue:[ i = 0 ifTrue: [ cachedNumFaces := cachedInfo numFaces ]. self addFileInfo: cachedInfo index: i. i := i + 1.]. (cachedNumFaces notNil and:[ i >= cachedNumFaces ]) ifTrue:[ ^ self ]. path := aFile fullName . [face := FreeTypeFace basicNew filename: path; index: i. ["we use the primNewFaceFromFile:index: method because we want to do this as fast as possible and we don't need the face registered because it will be explicitly destroyed later" face primNewFaceFromFile: path index: i. face loadFields] on: FT2Error do:[:e | ^self failedToOpen: face from: path index: i ]. (face height notNil and:[face hasFamilyName and:[face hasStyleName and:[face isValid]]]) ifFalse: [ ^self failedToOpen:face from: path index: i ] ifTrue: [ numFaces ifNil: [numFaces := face numFaces]. info :=FreeTypeFileInfo new absoluteOrRelativePath: aFile path isAbsolute; absolutePath: path; "used for quick lookup on same platform" locationType: #default; index: i; fileSize: aFile size; modificationTime: aFile modificationTime; familyName: face familyName; styleName: face styleName; postscriptName: face postscriptName; bold: face isBold; italic: face isItalic; fixedWidth: face isFixedWidth; numFaces: numFaces; extractAttributesFromNames; yourself. self addFileInfo: info index: i. self cacheFileInfo: info index: i. "Transcript show: 'from file : ', info asString." face destroyHandle]. i := i + 1. i < numFaces "note, we use < rather than <= , because i is zero based"] whileTrue:[]. ! ! !FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'CamilloBruni 5/4/2012 20:25'! embedFilesInDirectory: aDirectory "embed all the files in aDirectory FreeTypeFontProvider current embedFilesInDirectory: (FileSystem disk workingDirectory / 'Fonts') " aDirectory files do:[:file | file readStreamDo: [ :fileStream|. fileStream binary. self addFromFileContents: fileStream contents baseName: file basename]]. "update so that missing text styles are created." self updateFromSystem. "clear all the logicalFonts realFonts so that embedded fonts take precedence over external ones" LogicalFont allInstances do:[:logFont | logFont clearRealFont] ! ! !FreeTypeFontProvider methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:41'! cacheFileInfo: aFreeTypeFileInfo index: i (fileInfoCache at: {aFreeTypeFileInfo fileSize. i} ifAbsentPut:[Set new]) add: aFreeTypeFileInfo ! ! !FreeTypeFontProvider methodsFor: 'font families' stamp: 'tween 8/18/2007 14:19'! families ^tempFamilies ifNil:[families]! ! !FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'tween 7/28/2007 13:34'! validEmbeddedCachedInfoFor: bytes index: i "answer info from cache if the bytes are the same as the cached info, otherwise answer nil" | cacheEntry fileSize | fileSize := bytes size. cacheEntry := (embeddedFileInfoCache at: {fileSize. i} ifAbsentPut:[Set new]) detect:[:each | each fileContents = bytes] ifNone:[]. ^cacheEntry ! ! !FreeTypeFontProvider methodsFor: 'font families' stamp: 'CamilloBruni 7/15/2012 19:19'! buildFamilies | familyNames | families := Dictionary new. familyNames := (fileInfos collect: [:each | each familyGroupName]) asSet asSortedCollection asArray. familyNames do:[:familyName | | family | family := self buildFamilyNamed: familyName. families at: familyName put: family ].! ! !FreeTypeFontProvider methodsFor: 'accessing' stamp: 'CamilloBruni 7/15/2012 19:18'! cacheEmbeddedFileInfo: aFreeTypeEmbeddedFileInfo index: i (embeddedFileInfoCache at:{aFreeTypeEmbeddedFileInfo fileSize. i} ifAbsentPut:[ Set new ]) add: aFreeTypeEmbeddedFileInfo ! ! !FreeTypeFontProvider methodsFor: 'font lookup' stamp: 'tween 8/27/2007 11:33'! fontInfoFor: aLogicalFont familyName: familyName | family member | "use tempFileInfos if not nil, i.e. during an update" "^self fontInfoFor: aLogicalFont in: (tempFileInfos ifNil:[fileInfos]) " family := self families at: familyName ifAbsent:[]. family ifNil:[^nil]. member := family closestMemberWithStretchValue: aLogicalFont stretchValue weightValue: aLogicalFont weightValue slantValue: aLogicalFont slantValue. member ifNil:[^nil]. ^member fileInfo! ! !FreeTypeFontProvider methodsFor: 'file paths' stamp: 'CamilloBruni 7/15/2012 18:49'! unixFontDirectories "Answer the unix/linux font folder paths" ^ #('/usr/share/fonts' '/usr/local/share/fonts') collect: [ :each| each asFileReference ] thenSelect: [ :each| each exists ].! ! !FreeTypeFontProvider methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:39'! addFileInfo: aFreeTypeFileInfo index: i fileInfos add: aFreeTypeFileInfo ! ! !FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'IgorStasenko 4/8/2014 17:09'! updateFontsFromSystem | done | FT2Library current ifNil: [ ^ self ]. EmbeddedFreetypeFont installAllFontsIn: self. "Add all the embedded file infos" embeddedFileInfoCache valuesDo:[:eachSet | eachSet do:[:each | fileInfos addFirst: each]]. done := Set new. "visited directories are tracked in done, so that they are not processed twice" self platformImageRelativeDirectories do:[:each | self updateFromDirectory: each done: done] displayingProgress: 'Loading image relative font files'. self platformVMRelativeDirectories do:[:each | self updateFromDirectory: each done: done] displayingProgress: 'Loading vm relative font files'. self platformAbsoluteDirectories do:[:each | self updateFromDirectory: each done: done ] displayingProgress: 'Loading platform font files'.! ! !FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'CamilloBruni 7/15/2012 19:27'! updateFromSystem | i | i := 0. self prepareForUpdating. 'FreeType' displayProgressFrom: 0 to: 3 during:[:mainBar | | platformDirs vmDirs imageDirs done | self updateFileCacheInfo. mainBar current: 1. self updateFontsFromSystem. mainBar current: 2. self updateAvailableFontFamilies. mainBar current: 3]. LogicalFont allInstances do:[:each | each clearRealFont]. "in case they have a bad one" ! ! !FreeTypeFontProvider methodsFor: 'file paths' stamp: 'CamilloBruni 7/15/2012 18:47'! winFontDirectories | directory | directory := self getWindowsFontFolderPath. directory ifNil: [ ^ #() ]. directory := directory asFileReference. directory exists ifTrue: [ ^ { directory }]. ^ #()! ! !FreeTypeFontProvider methodsFor: 'file paths' stamp: 'CamilloBruni 7/15/2012 18:52'! platformVMRelativeDirectories | directory | directory := Smalltalk vm path asFileReference / 'Fonts'. directory exists ifTrue: [ ^ { directory } ]. ^ #()! ! !FreeTypeFontProvider methodsFor: 'loading and updating' stamp: 'tween 3/14/2007 23:17'! loadFromSystem self updateFromSystem. ! ! !FreeTypeFontProvider class methodsFor: 'class initialization' stamp: 'MarcusDenker 3/17/2012 10:03'! initialize " self initialize " "ensure that other classes have also been initialized by forcefully initializing them now. It then does not matter which order they are initialized in during the package load" FT2Constants initialize. FreeTypeCache initialize. FreeTypeCacheConstants initialize. FreeTypeSettings initialize. self current. "this creates an instance of me, and updates from the system"! ! !FreeTypeFontProvider class methodsFor: 'class initialization' stamp: 'AlainPlantec 9/17/2011 16:51'! unload " self unload " current ifNotNil: [current initialize]. FreeTypeCache clearCurrent. LogicalFontManager unload ! ! !FreeTypeFontProvider class methodsFor: 'accessing' stamp: 'tween 3/23/2007 09:59'! current " current := nil. TimeProfileBrowser onBlock: [FreeTypeFontProvider current] " ^current ifNil:[ current := self new. current updateFromSystem]! ! !FreeTypeFontProvider class methodsFor: 'extra fonts registration' stamp: 'IgorStasenko 4/9/2014 15:11'! registerFont: aClassWithFont "Do nothing if freetype is disabled currently" FreeTypeSystemSettings loadFt2Library ifTrue: [ aClassWithFont installFontsIn: self current ]! ! !FreeTypeFontSelectorDialogWindow commentStamp: 'LaurentLaffont 4/15/2011 20:19'! I'm a dialog to select a font. Usage example: |fontSelector| fontSelector := FreeTypeFontSelectorDialogWindow new. UITheme builder openModal: fontSelector. fontSelector selectedFont inspect.! !FreeTypeFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 12/11/2009 07:39'! updateFromSelectedFont "Update our state based on the selected font." |font| font := self selectedFont ifNil: [TextStyle defaultFont]. fontFamilyIndex := (self fontFamilies indexOf: font familyName). fontSizeIndex := (self fontSizes indexOf: font pointSize). isBold := (font emphasis allMask: TextEmphasis bold emphasisCode). isItalic := (font emphasis allMask: TextEmphasis italic emphasisCode). self changed: #fontFamilyIndex; changed: #fontSizeIndex; changed: #isBold; changed: #isItalic. self textPreviewMorph ifNotNil: [:tp | tp font: self selectedFont. self changed: #previewText]! ! !FreeTypeFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:14'! matchingFont "Answer the font that matches the selections." |lf emp| self familyName ifNil: [^TextStyle defaultFont]. lf := LogicalFont familyName: self familyName pointSize: (self fontSize ifNil: [10]). emp := self isBold ifTrue: [TextEmphasis bold emphasisCode] ifFalse: [TextEmphasis normal emphasisCode]. self isItalic ifTrue: [emp := emp + TextEmphasis italic emphasisCode]. self isUnderlined ifTrue: [emp := emp + TextEmphasis underlined emphasisCode]. self isStruckOut ifTrue: [emp := emp + TextEmphasis struckOut emphasisCode]. lf := lf emphasis: emp. lf realFont ifNil: [^TextStyle defaultFont]. ^lf ! ! !FreeTypeFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 8/25/2011 17:33'! defaultFontFamilies "Answer the set of available fonts families that are supported in the font that they represent." |fonts defaultFont| defaultFont := TextStyle default fontOfPointSize: self theme listFont pointSize. fonts := (LogicalFontManager current allFamilies asSortedCollection: [:a :b | a familyName <= b familyName]) collect: [:ff | (ff closestMemberWithStretchValue: LogicalFont stretchRegular weightValue: LogicalFont weightRegular slantValue: LogicalFont slantRegular) asLogicalFontOfPointSize: self theme listFont pointSize]. ^fonts collect: [:f | |dispFont| dispFont := defaultFont. f familyName asText addAttribute: (TextFontReference toFont: dispFont)]! ! !FreeTypeFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:49'! newFontStyleButtonRowMorph "Answer a new font style button row morph." ^self newRow: { self newBoldButtonMorph. self newItalicButtonMorph}! ! !FreeTypeGlyphRenderer commentStamp: 'tween 4/4/2007 09:48'! This class produces glyphs for a FreeTypeFont. It can be subclassed to provide, for example, sub-pixel anti-aliased glyphs.! !FreeTypeGlyphRenderer methodsFor: 'private' stamp: 'tween 4/4/2007 21:24'! convert8to32: aGlyphForm colorValue: foreColorValue "convert from the 8 bit deep form produced by FreeType, where each byte represents the intensity of a single pixel, to a 32 bit deep form with pixels of color foreColorValue " | w h s answer rowstart bytes word littleEndian shift v a colorVal foreColorVal foreColorA foreColorR foreColorG foreColorB r g b | foreColorVal := foreColorValue. foreColorA := foreColorVal >> 24. foreColorR := foreColorVal >> 16 bitAnd: 16rFF. foreColorG := foreColorVal >> 8 bitAnd: 16rFF. foreColorB := foreColorVal bitAnd: 16rFF. bytes := aGlyphForm bits. w := aGlyphForm width. h := aGlyphForm height. answer := aGlyphForm class extent: w@h depth: 32. answer offset: (aGlyphForm offset x) @ (aGlyphForm offset y); advance: aGlyphForm advance; linearAdvance: aGlyphForm linearAdvance. s := w + 3 >> 2. littleEndian := aGlyphForm isLittleEndian. 0 to: h - 1 do: [:y | rowstart := (y * s)+1. 0 to: w - 1 do:[:x | word := bytes at: rowstart + (x//4). shift := 8* (littleEndian ifTrue:[x bitAnd: 3] ifFalse:[3-(x bitAnd: 3)]). v := word >>shift bitAnd: 16rFF. a := v > 0 ifTrue:[v * foreColorA // 16rFF] ifFalse:[0]. r := v > 0 ifTrue:[a * foreColorR // 16rFF] ifFalse:[0]. g := v > 0 ifTrue:[a * foreColorG // 16rFF] ifFalse:[0]. b := v > 0 ifTrue:[a * foreColorB // 16rFF] ifFalse:[0]. colorVal := (a bitShift: 24) + (r bitShift: 16) + (g bitShift: 8) + b. answer bits integerAt: (y*w)+(x+1) put: colorVal]]. ^answer! ! !FreeTypeGlyphRenderer methodsFor: 'public' stamp: 'tween 4/4/2007 10:35'! glyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont | f | f := self renderGlyph: aCharacter depth: (monoBoolean ifTrue:[1] ifFalse:[8]) subpixelPosition: sub font: aFreeTypeFont. monoBoolean ifTrue:[ f := self fixBytesForMono: f. f := f asFormOfDepth: 8]. f := self convert8to32: f colorValue: aColorValue. ^f ! ! !FreeTypeGlyphRenderer methodsFor: 'public' stamp: 'tween 4/4/2007 19:25'! subGlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont "the default renderer does not support sub-pixel anti-aliasing, so answer an ordinary glyph" ^self mode41GlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont ! ! !FreeTypeGlyphRenderer methodsFor: 'private' stamp: 'nice 1/5/2010 15:59'! renderGlyph: aCharacter depth: depth subpixelPosition: sub font: aFreeTypeFont "Glyphs are either 1 or 8 bit deep. For 32 bpp we use 8 bits, otherwise 1" | em form glyph charCode slant extraWidth extraHeight boldExtra offsetX offsetY s synthBoldStrength face | charCode := aCharacter asUnicode asInteger. (aFreeTypeFont face charmaps includes:'unic') ifTrue:[ (aFreeTypeFont isSymbolFont and:[charCode >= 16r20 and: [charCode <= 16rFF ] ]) ifTrue:[charCode := charCode + 16rF000]] ifFalse:[ (aFreeTypeFont face charmaps includes:'armn') ifTrue:[ "select apple roman char map, and map character from unicode to mac encoding" aFreeTypeFont face setCharMap:'armn'. charCode := aCharacter unicodeToMacRoman asUnicode asInteger. "check this!!"]]. aCharacter < $ ifTrue: ["charCode := $ asUnicode asInteger" ^(GlyphForm extent: 0@0 depth: depth) advance: 0@0; linearAdvance: 0@0; offset:0@0; yourself ]. em := aFreeTypeFont pixelSize. [ | hintingFlags flags |face := aFreeTypeFont face. face setPixelWidth: em height: em. hintingFlags := FreeTypeSettings current hintingFlags. flags := LoadNoBitmap bitOr:( LoadIgnoreTransform bitOr: hintingFlags). face loadCharacter:charCode flags: flags] on: FT2Error do:[:e | ^(GlyphForm extent: 0@0 depth: depth) advance: 0@0; linearAdvance: 0@0; offset:0@0; yourself]. glyph := face glyph. slant := aFreeTypeFont simulatedItalicSlant. extraWidth := (glyph height * slant) abs ceiling. synthBoldStrength := aFreeTypeFont simulatedBoldStrength. boldExtra := 4 * synthBoldStrength abs ceiling. extraWidth := extraWidth + boldExtra. sub > 0 ifTrue:[ extraWidth := extraWidth + 1]. extraHeight := boldExtra. form := GlyphForm extent: (glyph width + extraWidth + 1)@(glyph height + extraHeight+ 1) depth: depth. s := (glyph height-glyph hBearingY) * slant. s := s sign * (s abs ceiling). offsetX := glyph hBearingX negated + s + (boldExtra // 2) . offsetY := glyph height - glyph hBearingY + (boldExtra//2). synthBoldStrength ~= 0 ifTrue:[face emboldenOutline: synthBoldStrength]. face transformOutlineAngle: 0 scalePoint: 1@1 slant: slant. face translateOutlineBy: (offsetX+(sub/64))@offsetY. face renderGlyphIntoForm: form. form offset: (glyph hBearingX - s - (boldExtra // 2) ) @ (glyph hBearingY + 1 + (boldExtra / 2) ceiling ) negated. "When not hinting FreeType sets the advance to the truncated linearAdvance. The characters appear squashed together. Rounding is probably better, so we fix the advance here" aFreeTypeFont subPixelPositioned ifTrue:[ form advance: glyph roundedPixelLinearAdvance] ifFalse:[ form advance: glyph advance]. form linearAdvance: glyph linearAdvance. ^form! ! !FreeTypeGlyphRenderer methodsFor: 'private' stamp: 'tween 4/4/2007 10:25'! convert8To32: aGlyphForm "convert aGlyphForm from the 8 bit deep form produced by FreeType, where each byte represents the intensity of a single pixel, to a 32 bit deep form" | w h s answer rowstart bytes word littleEndian shift v a colorVal | bytes := aGlyphForm bits. w := aGlyphForm width. h := aGlyphForm height. answer := aGlyphForm class extent: w@h depth: 32. answer offset: (aGlyphForm offset x) @(aGlyphForm offset y); advance: aGlyphForm advance; linearAdvance: aGlyphForm linearAdvance. s := w + 3 >> 2. littleEndian := aGlyphForm isLittleEndian. 0 to: h - 1 do: [:y | rowstart := (y * s)+1. 0 to: w - 1 do:[:x | word := bytes at: rowstart + (x//4). shift := 8* (littleEndian ifTrue:[x bitAnd: 3] ifFalse:[3-(x bitAnd: 3)]). v := word >>shift bitAnd: 16rFF. a := v > 0 ifTrue:[16rFF] ifFalse:[0]. colorVal := v + (v bitShift: 8) + (v bitShift: 16) + (a bitShift: 24). answer bits integerAt: (y*w)+(x+1) put: colorVal]]. ^answer! ! !FreeTypeGlyphRenderer methodsFor: 'public' stamp: 'tween 4/4/2007 20:53'! mode41GlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont | f | f := self renderGlyph: aCharacter depth: (monoBoolean ifTrue:[1] ifFalse:[8]) subpixelPosition: sub font: aFreeTypeFont. monoBoolean ifTrue:[ f := self fixBytesForMono: f. f := f asFormOfDepth: 32] ifFalse:[ f := self convert8To32: f]. ^f! ! !FreeTypeGlyphRenderer methodsFor: 'private' stamp: 'tween 4/4/2007 10:28'! fixBytesForMono: aGlyphForm "On Windows, the bits in each byte are in reverse order, and inverted. i.e. 2r10100000 should be 2r11111010 to display correctly. This needs further investigation" | b newB bits | bits := aGlyphForm bits. 1 to: bits byteSize do:[:i | b := bits byteAt: i. newB := ((((((((b bitAnd: 2r10000000) bitShift: -7) bitOr: ((b bitAnd: 2r1000000) bitShift: -5)) bitOr: ((b bitAnd: 2r100000) bitShift: -3)) bitOr: ((b bitAnd: 2r10000) bitShift: -1)) bitOr: ((b bitAnd: 2r1000) bitShift: 1)) bitOr: ((b bitAnd: 2r100) bitShift: 3)) bitOr: ((b bitAnd: 2r10) bitShift: 5)) bitOr: ((b bitAnd: 2r1) bitShift: 7). bits byteAt: i put: (newB bitXor: 2r11111111)]. ^aGlyphForm! ! !FreeTypeGlyphRenderer class methodsFor: 'instance creation' stamp: 'tween 4/4/2007 19:24'! current " FreeTypeGlyphRenderer current " ^current ifNil:[current := self new]! ! !FreeTypeGlyphRenderer class methodsFor: 'accessing' stamp: 'tween 4/4/2007 09:50'! current: aKindOfFreeTypeGlyphRender current := aKindOfFreeTypeGlyphRender! ! !FreeTypeNameParser commentStamp: 'TorstenBergmann 2/4/2014 22:11'! A name parser! !FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 8/14/2007 22:01'! extractUpright "extract from current combined name. answer new combinedName" | normalTok start end | normalTok := tokens reversed detect: [:tok | (self normalNames detect: [:str | str asLowercase = tok first asLowercase] ifNone:[]) notNil ] ifNone:[]. normalTok ifNotNil:[ "remove it from combinedName" start := normalTok second. end := normalTok third. extractedUpright := combinedName copyFrom: start to: end. [start > 1 and:[delimiters includes: (combinedName at: start - 1)]] whileTrue:[start := start - 1]. [end < combinedName size and:[delimiters includes: (combinedName at: end + 1)]] whileTrue:[end := end + 1]. combinedName := combinedName copyReplaceFrom: start to: end with: ' ']. ! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 12:29'! extractedStretch ^extractedStretch! ! !FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 9/29/2007 12:34'! extractWeight "match and remove last weight tokens" | matches start end | extractedWeightValue := LogicalFont weightRegular. (self weightNames detect: [:each | matches := self lastMatchValueSequence: each allButFirst. matches ifNotNil:[extractedWeightValue := each first]. matches notNil] ifNone:[]) ifNotNil:[ start := matches first second. end := matches last third. extractedWeight := combinedName copyFrom: start to: end. [start > 1 and:[delimiters includes: (combinedName at: start - 1)]] "also remove delimiters before token" whileTrue:[start := start - 1]. [end < combinedName size and:[delimiters includes: (combinedName at: end + 1)]] "also remove delimiters after token" whileTrue:[end := end + 1]. combinedName := combinedName copyReplaceFrom: start to: end with: ' '.]. (extractedWeight isNil and:[boldFlag]) ifTrue:["no weight specified in familyName or styleName; force it to be 'Bold'" extractedWeight := 'Bold'. extractedWeightValue := LogicalFont weightBold] ! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 21:33'! extractedSlantValue ^extractedSlantValue! ! !FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 8/25/2007 13:28'! normalNames ^self class normalNames ! ! !FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 8/16/2007 02:12'! italicNames ^self class italicNames! ! !FreeTypeNameParser methodsFor: 'initialization' stamp: 'nice 10/30/2013 21:39'! initialize super initialize. delimiters := ',.-_'. Character separators do:[:c | delimiters := delimiters , c asString]. ! ! !FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 9/29/2007 11:41'! weightNames ^self class weightNames ! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 12:29'! extractedWeight ^extractedWeight! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 21:32'! extractedSlant ^extractedSlant! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 00:55'! extractedStretchValue ^extractedStretchValue! ! !FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 9/29/2007 12:35'! extractStretch "match and remove last stretch tokens" | matches start end | extractedStretchValue := LogicalFont stretchRegular. (self stretchNames detect: [:each | matches := self lastMatchValueSequence: each allButFirst. matches ifNotNil:[extractedStretchValue := each first]. matches notNil] ifNone:[]) ifNotNil:[ start := matches first second. end := matches last third. extractedStretch := combinedName copyFrom: start to: end. [start > 1 and:[delimiters includes: (combinedName at: start - 1)]] "also remove delimiters before token" whileTrue:[start := start - 1]. [end < combinedName size and:[delimiters includes: (combinedName at: end + 1)]] "also remove delimiters after token" whileTrue:[end := end + 1]. combinedName := combinedName copyReplaceFrom: start to: end with: ' '. "re-tokenize" "tokens := self tokenize: combinedName delimiters: delimiters"]. ! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 20:14'! italicFlag: aBoolean italicFlag := aBoolean! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 00:55'! extractedWeightValue ^extractedWeightValue! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 23:39'! familyNameIn: familyName familyNameIn := familyName. ! ! !FreeTypeNameParser methodsFor: 'parsing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:44'! parse | styleName | styleNameIn := self splitBadTokensIn: styleNameIn. combinedName := styleNameIn trimBoth. tokens := self tokenize: combinedName. self extractUpright. styleName := combinedName. combinedName := familyNameIn trimBoth. self addStyleNameToCombinedName: styleName.. tokens := self tokenize: combinedName. self extractSlant. tokens := self tokenize: combinedName. self extractStretch. tokens := self tokenize: combinedName. self extractWeight. ! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 20:14'! boldFlag: aBoolean boldFlag := aBoolean! ! !FreeTypeNameParser methodsFor: 'parsing' stamp: 'nice 10/30/2013 21:39'! tokenize: aString "answer an OrderedCollection of {string. start. end} tuples. tokens are separated by $- $_ $, $. and whitespace" | currentTokens answer start | currentTokens := aString findTokens: delimiters keep: delimiters. answer := OrderedCollection new. start := 1. currentTokens do:[:tok | (delimiters includes: tok first) ifFalse:[answer add: {tok. start. start+tok size - 1}]. start := start + tok size]. ^answer! ! !FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 8/16/2007 02:54'! italicAndObliqueNames ^self class italicAndObliqueNames! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:44'! familyName ^combinedName trimBoth! ! !FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 8/13/2007 23:02'! addStyleNameToCombinedName: aStyleString | lcCombined lcStyleName addStyle index | lcCombined := combinedName asLowercase. lcStyleName := aStyleString asLowercase. addStyle := true. (index := lcCombined findString: lcStyleName) > 0 ifTrue:[ (index = 1 or:[delimiters includes: (lcCombined at: index - 1)]) ifTrue:[ ((index + lcStyleName size > lcCombined size) or:[ delimiters includes: (lcCombined at: index + lcStyleName size) ]) ifTrue:["don't add the style to the combinedName, because it already contains it" addStyle := false]]]. addStyle ifTrue:[combinedName := combinedName , ' ', aStyleString]. ! ! !FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 9/29/2007 12:03'! extractSlant | matches start end | "match and remove last italic/oblique token" extractedSlant := nil. extractedSlantValue := LogicalFont slantRegular. "not italic or oblique" (self italicAndObliqueNames detect: [:each | (matches := self lastMatchValueSequence: {each}) notNil] ifNone:[]) ifNotNil:[ start := matches first second. end := matches last third. extractedSlant := combinedName copyFrom: start to: end. "extractedSlantValue := (self italicNames includes: extractedSlant asLowercase) ifTrue:[1] ifFalse:[2]." extractedSlantValue := LogicalFont slantItalic. "treat italic and oblique the same, as italic" [start > 1 and:[delimiters includes: (combinedName at: start - 1)]] "also remove delimiters before token" whileTrue:[start := start - 1]. [end < combinedName size and:[delimiters includes: (combinedName at: end + 1)]] "also remove delimiters after token" whileTrue:[end := end + 1]. combinedName := combinedName copyReplaceFrom: start to: end with: ' '.]. (extractedSlant isNil and:[italicFlag]) ifTrue:["no italic specified in familyName or styleName; force it to be 'Italic'" extractedSlant := 'Italic'. extractedSlantValue := LogicalFont slantItalic] ! ! !FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 9/29/2007 11:41'! stretchNames ^self class stretchNames! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:16'! extractedUpright ^extractedUpright! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 23:39'! styleNameIn: styleName styleNameIn := styleName. ! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 18:06'! familyName: familyName familyNameIn := familyName. ! ! !FreeTypeNameParser methodsFor: 'parsing' stamp: 'tween 8/11/2007 18:23'! lastMatchValueSequence: values "answer the last contiguous tokens that match pattern tokens, or nil if not found. matching is case insensitive " | answer nullToken match tok | nullToken := {''. nil. nil}. tokens size - values size + 1 to: 1 by: -1 do:[:ti | match := true. answer := Array new. 1 to: values size do:[:vi | tok := tokens at: ti + vi - 1 ifAbsent: [nullToken]. (match and: [tok first asLowercase = ( values at: vi) asLowercase]) ifFalse:[match := false] ifTrue:[answer := answer, {tok} ]]. match ifTrue:[^answer]]. ^nil ! ! !FreeTypeNameParser methodsFor: 'parsing' stamp: 'nice 1/5/2010 15:59'! splitBadTokensIn: aString "split tokens such as BoldOblique, that should be two words" | str | str := aString. #( ('bold' 'oblique') ('bold' 'italic') ) do:[:pair | | i | (i := str asLowercase findString: pair first, pair second startingAt: 1) > 0 ifTrue:[ str := (str first: i + pair first size - 1), ' ', (str last: (str size - (i + pair first size - 1)))]]. ^str! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 18:06'! styleName: styleName styleNameIn := styleName. ! ! !FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 9/30/2007 12:44'! normalNames "Answer a sequence of String tokens that indicate a Regular (i.e. non-oblique, non-italic) font within a font family-style name" " TO RE-INITIALIZE... self instVarNamed: #normalNames put: nil. " normalNames ifNotNil:[^normalNames]. ^normalNames := #('Book' 'Normal' 'Regular' 'Roman' 'Upright').! ! !FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 9/30/2007 12:43'! obliqueNames "Answer a sequence of String tokens that indicate an oblique font within a font family-style name" " TO RE-INITIALIZE... self instVarNamed: #obliqueNames put: nil. " obliqueNames ifNotNil:[^obliqueNames]. ^obliqueNames := #( 'inclined' 'oblique' 'backslanted' 'backslant' 'slanted').! ! !FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 9/30/2007 12:42'! stretchNames "Answer a sequence of arrays. Each array has an integer stretch value as its first element (1 - 9). The remaining elements are String tokens which might appear within a font family-style name" " TO RE-INITIALIZE... self instVarNamed: #stretchNames put: nil. " stretchNames ifNotNil:[^stretchNames]. ^stretchNames := { {LogicalFont stretchExtraCompressed. 'extra'. 'compressed'}. {LogicalFont stretchExtraCompressed. 'extracompressed'}. {LogicalFont stretchExtraCompressed. 'ext'. 'compressed'}. {LogicalFont stretchExtraCompressed. 'extcompressed'}. {LogicalFont stretchUltraCompressed. 'ultra'. 'compressed'}. {LogicalFont stretchUltraCompressed. 'ultracompressed'}. {LogicalFont stretchUltraCondensed. 'ultra'. 'condensed'}. {LogicalFont stretchUltraCondensed. 'ultracondensed'}. {LogicalFont stretchUltraCondensed. 'ultra'. 'cond'}. {LogicalFont stretchUltraCondensed. 'ultracond'}. {LogicalFont stretchCompressed. 'compressed'}. {LogicalFont stretchExtraCondensed. 'extra'. 'condensed'}. {LogicalFont stretchExtraCondensed. 'extracondensed'}. {LogicalFont stretchExtraCondensed. 'ext'. 'condensed'}. {LogicalFont stretchExtraCondensed. 'extcondensed'}. {LogicalFont stretchExtraCondensed. 'extra'. 'cond'}. {LogicalFont stretchExtraCondensed. 'extracond'}. {LogicalFont stretchExtraCondensed. 'ext'. 'cond'}. {LogicalFont stretchExtraCondensed. 'extcond'}. {LogicalFont stretchNarrow. 'narrow'}. {LogicalFont stretchCompact. 'compact'}. {LogicalFont stretchSemiCondensed. 'semi'. 'condensed'}. {LogicalFont stretchSemiCondensed. 'semicondensed'}. {LogicalFont stretchSemiCondensed. 'semi'. 'cond'}. {LogicalFont stretchSemiCondensed. 'semicond'}. {LogicalFont stretchWide. 'wide'}. {LogicalFont stretchSemiExpanded. 'semi'. 'expanded'}. {LogicalFont stretchSemiExpanded. 'semiexpanded'}. {LogicalFont stretchSemiExtended. 'semi'. 'extended'}. {LogicalFont stretchSemiExtended. 'semiextended'}. {LogicalFont stretchExtraExpanded. 'extra'. 'expanded'}. {LogicalFont stretchExtraExpanded. 'extraexpanded'}. {LogicalFont stretchExtraExpanded. 'ext'. 'expanded'}. {LogicalFont stretchExtraExpanded. 'extexpanded'}. {LogicalFont stretchExtraExtended. 'extra'. 'extended'}. {LogicalFont stretchExtraExtended. 'extraextended'}. {LogicalFont stretchExtraExtended. 'ext'. 'extended'}. {LogicalFont stretchExtraExtended. 'extextended'}. {LogicalFont stretchUltraExpanded. 'ultra'. 'expanded'}. {LogicalFont stretchUltraExpanded. 'ultraexpanded'}. {LogicalFont stretchUltraExtended. 'ultra'. 'extended'}. {LogicalFont stretchUltraExtended. 'ultraextended'}. {LogicalFont stretchCondensed. 'condensed'}. {LogicalFont stretchCondensed. 'cond'}. {LogicalFont stretchExpanded. 'expanded'}. {LogicalFont stretchExtended. 'extended'} }. "search for them in the order given here" ! ! !FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 9/30/2007 12:41'! weightNames "Answer a sequence of arrays. Each array has an integer weight value as its first element. The remaining elements are String tokens which might appear within a font family-style name" " TO RE-INITIALIZE... self instVarNamed: #weightNames put: nil. " weightNames ifNotNil:[^weightNames]. ^weightNames := { {LogicalFont weightExtraThin. 'extra'. 'thin'}. {LogicalFont weightExtraThin.'extrathin'}. {LogicalFont weightExtraThin. 'ext'. 'thin'}. {LogicalFont weightExtraThin. 'extthin'}. {LogicalFont weightUltraThin.'ultra'. 'thin'}. {LogicalFont weightUltraThin.'ultrathin'}. {LogicalFont weightExtraLight. 'extra'. 'light'}. {LogicalFont weightExtraLight. 'extralight'}. {LogicalFont weightExtraLight. 'ext'. 'light'}. {LogicalFont weightExtraLight. 'extlight'}. {LogicalFont weightUltraLight. 'ultra'. 'light'}. {LogicalFont weightUltraLight. 'ultralight'}. {LogicalFont weightSemiBold. 'semi'. 'bold'}. {LogicalFont weightSemiBold. 'semibold'}. {LogicalFont weightDemiBold. 'demi'. 'bold'}. {LogicalFont weightDemiBold. 'demibold'}. {LogicalFont weightExtraBold. 'extra'. 'bold'}. {LogicalFont weightExtraBold. 'extrabold'}. {LogicalFont weightExtraBold. 'ext'. 'bold'}. {LogicalFont weightExtraBold. 'extbold'}. {LogicalFont weightUltraBold. 'ultra'. 'bold'}. {LogicalFont weightUltraBold. 'ultrabold'}. {LogicalFont weightExtraBlack. 'extra'. 'black'}. {LogicalFont weightExtraBlack. 'extrablack'}. {LogicalFont weightExtraBlack. 'ext'. 'black'}. {LogicalFont weightExtraBlack. 'extblack'}. {LogicalFont weightUltraBlack.'ultra'. 'black'}. {LogicalFont weightUltraBlack. 'ultrablack'}. {LogicalFont weightBold. 'bold'}. {LogicalFont weightThin.'thin'}. {LogicalFont weightLight. 'light'}. {LogicalFont weightMedium. 'medium'}. {LogicalFont weightBlack. 'black'}. {LogicalFont weightHeavy. 'heavy'}. {LogicalFont weightNord. 'nord'}. {LogicalFont weightDemi. 'demi'}. {LogicalFont weightUltra. 'ultra'}. } ! ! !FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 8/16/2007 02:47'! italicAndObliqueNames ^self italicNames, self obliqueNames! ! !FreeTypeNameParser class methodsFor: 'known names' stamp: 'tween 9/30/2007 12:44'! italicNames "Answer a sequence of String tokens that indicate an italic font within a font family-style name" " TO RE-INITIALIZE... self instVarNamed: #italicNames put: nil. " italicNames ifNotNil:[^italicNames]. ^italicNames := #( 'ita' 'ital' 'italic' 'cursive' 'kursiv').! ! !FreeTypeSettings commentStamp: 'TorstenBergmann 2/4/2014 22:11'! Settings for FreeType! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:16'! lightHinting ^lightHinting ifNil:[lightHinting := true]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:04'! clearBitBltSubPixelAvailable bitBltSubPixelAvailable := nil.! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:15'! hintingFlags | answer | answer := 0. self hinting ifTrue:[ self forceAutoHinting ifTrue:[answer := answer bitOr: 32 "forceAutoHinting"]. self lightHinting ifTrue:[answer := answer bitOr: LoadTargetLight]. self monoHinting ifTrue:[answer := answer bitOr: LoadTargetMono]. self lcdHinting ifTrue:[answer := answer bitOr: LoadTargetLCD]. self lcdvHinting ifTrue:[answer := answer bitOr: LoadTargetLCDV]] ifFalse:[answer := 2 "no hinting"]. ^answer! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:12'! forceAutoHinting ^forceAutoHinting ifNil:[forceAutoHinting := false]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:13'! forceNonSubPixelCount ^forceNonSubPixelCount ifNil:[forceNonSubPixelCount := 0]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'AlainPlantec 11/24/2009 16:26'! hintingSymbol "#Full, #Light, #Normal or #None" ^ self monoHinting ifTrue: [#Full] ifFalse: [ self lightHinting ifTrue: [#Light] ifFalse: [ self hinting ifTrue: [#Normal] ifFalse: [#None]]] ! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'marcus.denker 11/29/2008 10:43'! setSubPixelFilter: ratiosArray "Set the subPixelFilters from ratiosArray. the ratiosArray can specify the red, green, and blue filter ratios separately. e.g. #((1 3 5 3 1) (1 4 7 4 1) (1 2 3 2 1)) or, as single set of ratios e.g. #(1 3 5 3 1)" | validArray newFilters | validArray := ratiosArray. (ratiosArray size = 5) ifTrue:[validArray := {ratiosArray. ratiosArray. ratiosArray}]. newFilters := self subPixelFiltersFromRatios: validArray. (newFilters = subPixelFilters) ifFalse:[ subPixelFilters := newFilters. FreeTypeCache current removeAllForType: FreeTypeCacheGlyphLCD. World restoreMorphicDisplay]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:25'! gammaInverseTable ^gammaInverseTable! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'marcus.denker 11/29/2008 10:41'! setGamma: aFloat (aFloat closeTo: self gamma) ifFalse:[ gamma := aFloat. (gamma closeTo: 1.0) ifTrue:[gammaTable := gammaInverseTable := nil] ifFalse:[ gammaTable := ByteArray new: 256. gammaInverseTable := ByteArray new: 256. 0 to: 255 do:[:i | | g ug | g := ((i / 255.0) raisedTo: (1.0/gamma)) * 255. ug := ((i / 255.0) raisedTo: gamma) * 255. g := (g rounded min: 255) max: 0 . ug := (ug rounded min: 255) max: 0 . gammaTable at: i + 1 put: g. gammaInverseTable at: i + 1 put: ug]]. World restoreMorphicDisplay]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:20'! subPixelAntiAliasing self bitBltSubPixelAvailable ifFalse:[^false]. self forceNonSubPixelCount > 0 ifTrue:[^false]. ^subPixelAntiAliasing ifNil:[false]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 22:22'! glyphContrast ^ 100 - ((self gamma sqrt * 100) - 50)! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:15'! lcdHinting ^lcdHinting ifNil:[lcdHinting := false]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:25'! gammaTable ^gammaTable! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 4/2/2007 23:29'! pretendBitBltSubPixelUnavailableDuring: aBlock " For testing/profiling only. Answer true if the the subPixel combination rule is available, false otherwise. to test :- bitBltSubPixelAvailable := false. FreeTypeCache current removeAll. Smalltalk isMorphic ifTrue:[World restoreMorphicDisplay] " | old | old := bitBltSubPixelAvailable. [bitBltSubPixelAvailable := false. FreeTypeCache current removeAll. aBlock value. ] ensure:[ bitBltSubPixelAvailable := old. FreeTypeCache current removeAll.]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:15'! lcdvHinting ^lcdvHinting ifNil:[lcdvHinting := false]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:17'! monoHinting ^monoHinting ifNil:[monoHinting := false]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/6/2009 12:42'! monitorType: aSymbol "#LCD or #CRT" subPixelAntiAliasing := aSymbol = #LCD. World restoreMorphicDisplay.! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:13'! hinting ^hinting ifNil:[hinting := true]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'Pavelkrivanek 11/6/2010 12:20'! monitorType "#LCD or #CRT" ^ self subPixelAntiAliasing ifTrue: [#LCD] ifFalse: [#CRT] ! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:13'! forceNonSubPixelDuring: aBlock forceNonSubPixelCount ifNil:[forceNonSubPixelCount := 0]. forceNonSubPixelCount := forceNonSubPixelCount + 1. aBlock ensure:[forceNonSubPixelCount := forceNonSubPixelCount - 1]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'AlainPlantec 1/5/2010 11:40'! subPixelAntiAliasing: aBoolean subPixelAntiAliasing := aBoolean! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:22'! subPixelFilters ^subPixelFilters ifNil:[subPixelFilters := self subPixelFiltersFromRatios: self defaultSubPixelFilterRatios]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 22:21'! glyphContrast: aContrastValue " value between 1 and 100. 100 is highest contrast and maps to gamma 0.25 1 is lowest contrast and maps to gamma 2.22" Cursor wait showWhile: [ | v g | v := (((aContrastValue asNumber) min: 100) max: 1) asFloat. (v closeTo: 50.0) ifTrue: [g := 1.0] ifFalse: [g := ((100 - v) + 50 / 100.0) raisedTo: 2]. self setGamma: g]. ! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:22'! subPixelFiltersFromRatios: anArray "Convert the ratios in anArray to a similar array containing the filter proportions as floats. Example: if = #((1 3 5 3 1) (1 3 5 3 1) (1 3 5 3 1)) Then the answer is #(#(0.0769230769230769 0.2307692307692308 0.3846153846153846 0.2307692307692308 0.0769230769230769) #(0.0769230769230769 0.2307692307692308 0.3846153846153846 0.2307692307692308 0.0769230769230769) #(0.0769230769230769 0.2307692307692308 0.3846153846153846 0.2307692307692308 0.0769230769230769))" | r g b rRatios gRatios bRatios rsum gsum bsum rfilter gfilter bfilter blurR blurG blurB | r := "Color red luminance" 1.0 . g := "Color green luminance" 1.0 . b := "Color blue luminance"1.0 . blurR := anArray first. blurG := anArray second. blurB := anArray third. rRatios := blurR collect:[:i | r*i]. gRatios := blurG collect:[:i | g*i]. bRatios := blurB collect:[:i | b*i]. "rRatios := {g*blurR first . b*blurR second. r*blurR third. g*bl. b*blur*blur }. gRatios := {b*blur*blur. r*blur. g. b*blur. r*blur*blur}. bRatios := {r*blur*blur. g*blur. b. r*blur. g*blur*blur }." rsum := rRatios inject:0 into:[:t :i | t+i]. gsum := gRatios inject:0 into:[:t :i | t+i]. bsum := bRatios inject:0 into:[:t :i | t+i]. rfilter := rRatios collect:[:e | e / rsum]. gfilter := gRatios collect:[:e | e / gsum]. bfilter := bRatios collect:[:e | e / bsum]. ^{rfilter. gfilter. bfilter}! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'AlainPlantec 1/5/2010 10:53'! bitBltSubPixelAvailable "Answer true if the the subPixel combination rule is available, false otherwise. to test :- bitBltSubPixelAvailable := false. FreeTypeCache current removeAll. World restoreMorphicDisplay " | form bitBlt color | bitBltSubPixelAvailable == nil ifFalse:[^bitBltSubPixelAvailable]. form := Form extent: 10@10 depth: 32. bitBlt := GrafPort toForm: form. bitBlt combinationRule: 41. bitBlt sourceForm: (Form extent: 5@5 depth: 32). bitBlt destOrigin: 1@1. bitBlt width: 5; height: 5. color := Color black asNontranslucentColor pixelValueForDepth: 32. [bitBlt copyBitsColor: (color bitAnd: 16rFFFFFF) alpha: (color bitAnd: 16rFF000000) >> 24 gammaTable: nil ungammaTable: nil] on: Error do:[:e | ^bitBltSubPixelAvailable := false]. #toDo. "need to check that rule 41 has done the right thing, and isn't someone elses new BitBlt rule" ^bitBltSubPixelAvailable := true ! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2009 09:13'! gamma ^gamma ifNil:[gamma := 1.0] ! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'AlainPlantec 9/15/2011 17:26'! hintingSymbol: aSymbol "#Full, #Light, #Normal or #None" monoHinting := aSymbol = #Full. lightHinting := aSymbol = #Light. hinting := monoHinting or:[lightHinting or:[aSymbol = #Normal]]. FreeTypeCache current removeAll. FreeTypeFont allSubInstances do:[:each | each clearCachedMetrics]. Paragraph allSubInstances do:[:each | each composeAll]. World restoreMorphicDisplay. ! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:03'! clearForceNonSubPixelCount forceNonSubPixelCount := nil. ! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:12'! defaultSubPixelFilterRatios ^#((1 3 5 3 1) (1 3 5 3 1) (1 3 5 3 1))! ! !FreeTypeSettings class methodsFor: 'settings' stamp: 'AlainPlantec 12/3/2009 12:42'! updateFontsAtImageStartup ^ UpdateFontsAtImageStartup ifNil: [UpdateFontsAtImageStartup := false]! ! !FreeTypeSettings class methodsFor: 'settings' stamp: 'AlainPlantec 12/3/2009 12:43'! updateFontsAtImageStartup: aBoolean UpdateFontsAtImageStartup := aBoolean! ! !FreeTypeSettings class methodsFor: 'class initialization' stamp: 'MarcusDenker 3/17/2012 10:04'! initialize " self initialize " Smalltalk removeFromStartUpList: self. Smalltalk addToStartUpList: self . ! ! !FreeTypeSettings class methodsFor: 'shutdown' stamp: 'tween 8/31/2007 18:00'! shutDown: quitting self current clearBitBltSubPixelAvailable. self current clearForceNonSubPixelCount! ! !FreeTypeSettings class methodsFor: 'startup' stamp: 'MarcusDenker 3/17/2012 10:02'! startUp: resuming resuming ifTrue:[ self current clearBitBltSubPixelAvailable; clearForceNonSubPixelCount. self updateFontsAtImageStartup ifTrue: [FreeTypeFontProvider current updateFromSystem]]! ! !FreeTypeSettings class methodsFor: 'instance creation' stamp: 'tween 3/30/2007 17:54'! current current == nil ifFalse:[^current]. ^current := self new! ! !FreeTypeSubPixelAntiAliasedGlyphRenderer commentStamp: 'TorstenBergmann 2/4/2014 22:11'! A SubPixel-AntiAliased GlyphRenderer for FreeType! !FreeTypeSubPixelAntiAliasedGlyphRenderer methodsFor: 'rendering' stamp: 'nice 1/5/2010 15:59'! renderStretchedGlyph: aCharacter depth: depth subpixelPosition: sub font: aFreeTypeFont "Glyphs are either 1 or 8 bit deep. For 32 bpp we use 8 bits, otherwise 1" | em form glyph scaleX charCode slant extraWidth s offsetX offsetY synthBoldStrength boldExtra extraHeight face | charCode := aCharacter asUnicode asInteger. (aFreeTypeFont face charmaps includes:'unic') ifTrue:[ (aFreeTypeFont isSymbolFont and:[charCode >= 16r20 and: [charCode <= 16rFF ] ]) ifTrue:[charCode := charCode + 16rF000]] ifFalse:[ (aFreeTypeFont face charmaps includes:'armn') ifTrue:[ "select apple roman char map, and map character from unicode to mac encoding" aFreeTypeFont face setCharMap:'armn'. charCode := aCharacter unicodeToMacRoman asUnicode asInteger. "check this!!"]]. aCharacter < $ ifTrue: ["charCode := $ asUnicode asInteger" ^(GlyphForm extent: 0@0 depth: depth) advance: 0@0; linearAdvance: 0@0; offset:0@0; yourself ]. scaleX := 3. em := aFreeTypeFont pixelSize. [ | hintingFlags flags |face := aFreeTypeFont face. face setPixelWidth: em height: em. hintingFlags := FreeTypeSettings current hintingFlags. flags := LoadNoBitmap bitOr:( LoadIgnoreTransform bitOr: hintingFlags). face loadCharacter:charCode flags: flags. ] on: FT2Error do:[:e | ^(GlyphForm extent: 0@0 depth: depth) advance: 0@0; linearAdvance: 0@0; offset:0@0; yourself]. glyph := face glyph. slant := aFreeTypeFont simulatedItalicSlant. synthBoldStrength := aFreeTypeFont simulatedBoldStrength. synthBoldStrength ~= 0 ifTrue:[face emboldenOutline: synthBoldStrength]. boldExtra := 4 * synthBoldStrength abs ceiling. face transformOutlineAngle: 0 scalePoint: scaleX@1 slant: slant. extraWidth := (glyph height * slant) abs ceiling. extraWidth := extraWidth + boldExtra. sub > 0 ifTrue:[ extraWidth := extraWidth + 3]. extraHeight := boldExtra. form := GlyphForm extent: ((glyph width + extraWidth "+ 6" + 1 + 2)*scaleX)@(glyph height +extraHeight + 1) depth: depth. s := (glyph height-glyph hBearingY) * slant. s := s sign * (s abs ceiling). offsetX := (glyph hBearingX negated + s + (boldExtra // 2) + 1) * scaleX . offsetY := glyph height - glyph hBearingY + (boldExtra//2). face translateOutlineBy: (offsetX+(sub*scaleX/64))@offsetY. face renderGlyphIntoForm: form. form offset: ((glyph hBearingX - s - 1 - (boldExtra // 2)) * scaleX)@ (glyph hBearingY + 1 + (boldExtra / 2) ceiling) negated. "When not hinting FreeType sets the advance to the truncated linearAdvance. The characters appear squashed together. Rounding is probably better, so we fix the advance here" aFreeTypeFont subPixelPositioned ifTrue:[ form advance: glyph roundedPixelLinearAdvance * (scaleX@1)] ifFalse:[ form advance: glyph advance x * scaleX@glyph advance y]. form linearAdvance: glyph linearAdvance. ^form! ! !FreeTypeSubPixelAntiAliasedGlyphRenderer methodsFor: 'rendering' stamp: 'tween 4/4/2007 18:42'! filter: aGlyphForm "aGlyphForm should be 3x stretched 8 bit GlyphForm" | w h s answer rowstart bytes word littleEndian shift v a colorVal i prevG prevB r g b nextR nextG filters rfilter gfilter bfilter balR balG balB | "correctionFactor := 0.0 ." filters := FreeTypeSettings current subPixelFilters. rfilter := filters at: 1. gfilter := filters at: 2. bfilter := filters at: 3. bytes := aGlyphForm bits. w := aGlyphForm width. h := aGlyphForm height. answer := aGlyphForm class extent: ((aGlyphForm width / 3) ceiling + 2)@h depth: 32. answer offset: (aGlyphForm offset x / 3) rounded@(aGlyphForm offset y); advance: (aGlyphForm advance / 3) rounded; linearAdvance: aGlyphForm linearAdvance. s := w + 3 >> 2. littleEndian := aGlyphForm isLittleEndian. 0 to: h - 1 do: [:y | rowstart := (y * s)+1. prevG := prevB :=0. 0 to: w - 1 by: 3 do:[:x | 0 to: 2 do:[:subpixelindex | i := x + subpixelindex. word := bytes at: rowstart + (i//4). shift := -8* (littleEndian ifTrue:[i bitAnd: 3] ifFalse:[3-(i bitAnd: 3)]). v := (word bitShift: shift) bitAnd: 16rFF. subpixelindex = 0 ifTrue:[r := v]. subpixelindex = 1 ifTrue:[g := v]. subpixelindex = 2 ifTrue:[b := v]]. x >= (w-3) ifTrue:[nextR := nextG := 0] ifFalse:[ 0 to: 1 do:[:subpixelindex | i := x + 3 + subpixelindex. word := bytes at: rowstart + (i//4). shift := -8* (littleEndian ifTrue:[i bitAnd: 3] ifFalse:[3-(i bitAnd: 3)]). v := (word bitShift: shift) bitAnd: 16rFF. subpixelindex = 0 ifTrue:[nextR := v]. subpixelindex = 1 ifTrue:[nextG := v]]]. "balance r g b" balR := (prevG*(rfilter at: 1))+ (prevB*(rfilter at: 2))+ (r*(rfilter at: 3))+ (g*(rfilter at: 4))+ (b*(rfilter at: 5)). balG := (prevB*(gfilter at: 1))+ (r*(gfilter at: 2))+ (g*(gfilter at: 3))+ (b*(gfilter at: 4))+ (nextR*(gfilter at: 5)). balB := (r*(bfilter at: 1))+ (g*(bfilter at: 2))+ (b*(bfilter at: 3))+ (nextR*(bfilter at: 4))+ (nextG*(bfilter at: 5)). "luminance := (0.299*balR)+(0.587*balG)+(0.114*balB). balR := balR + ((luminance - balR)*correctionFactor). balG := balG + ((luminance - balG)*correctionFactor). balB := balB + ((luminance - balB)*correctionFactor)." balR := balR truncated. balR < 0 ifTrue:[balR := 0] ifFalse:[balR > 255 ifTrue:[balR := 255]]. balG := balG truncated. balG < 0 ifTrue:[balG := 0] ifFalse:[balG > 255 ifTrue:[balG := 255]]. balB := balB truncated. balB < 0 ifTrue:[balB := 0] ifFalse:[balB > 255 ifTrue:[balB := 255]]. a := balR + balG + balB > 0 ifTrue:[16rFF] ifFalse:[0]. colorVal := balB + (balG bitShift: 8) + (balR bitShift: 16) + (a bitShift: 24). answer bits integerAt: (y*answer width)+(x//3+1) put: colorVal. prevB := b. prevG := g. "remember the unbalanced values" ]]. ^answer! ! !FreeTypeSubPixelAntiAliasedGlyphRenderer methodsFor: 'rendering' stamp: 'tween 4/4/2007 18:43'! subGlyphOf: aCharacter colorValue: aColorValue mono: monoBoolean subpixelPosition: sub font: aFreeTypeFont | f | monoBoolean ifFalse:[ f := self renderStretchedGlyph: aCharacter depth: 8 subpixelPosition: sub font: aFreeTypeFont. f := self filter: f] ifTrue:[ f := self renderGlyph: aCharacter depth: 1 subpixelPosition: sub font: aFreeTypeFont. f := self fixBytesForMono: f. f := f asFormOfDepth: 32]. ^f! ! !FreeTypeSubPixelAntiAliasedGlyphRenderer class methodsFor: 'class initialization' stamp: 'AlainPlantec 1/5/2010 11:44'! initialize " self initialize " FreeTypeGlyphRenderer current: self new. ! ! !FreeTypeSystemSettings commentStamp: 'TorstenBergmann 2/12/2014 23:27'! Settings for the FreeType system! !FreeTypeSystemSettings class methodsFor: 'settings' stamp: 'AlainPlantec 9/17/2011 16:09'! loadFt2Library ^ LoadFT2Library ifNil: [LoadFT2Library := false] ! ! !FreeTypeSystemSettings class methodsFor: 'settings' stamp: 'EstebanLorenzano 5/14/2013 09:43'! ft2LibraryVersion ^ Smalltalk ui theme newLabelIn: World for: self label: 'Available version: ', FT2Version current libraryVersion asString getEnabled: nil.! ! !FreeTypeSystemSettings class methodsFor: 'settings' stamp: 'CamilloBruni 7/15/2012 18:58'! loadFt2Library: aBoolean (LoadFT2Library = aBoolean) ifTrue: [^ self]. LoadFT2Library := aBoolean. aBoolean ifTrue: [FreeTypeFontProvider current updateFromSystem] ifFalse: [StandardFonts restoreDefaultFonts. FreeTypeFontProvider unload] ! ! !FreeTypeSystemSettings class methodsFor: 'settings' stamp: 'EstebanLorenzano 5/14/2013 09:44'! freeTypeSettingsOn: aBuilder (aBuilder setting: #noFt2Library) target: self; icon: Smalltalk ui icons smallConfigurationIcon; type: #Label; label: 'Free type' translated; precondition: [FT2Library current isNil]; parent: #appearance; order: 3; description: 'Free type fonts are not available probably because the FT2 plugin is not installed. Check your VM installation' translated. (aBuilder setting: #loadFt2Library) target: self; dialog: [self ft2LibraryVersion]; icon: Smalltalk ui icons smallConfigurationIcon; label: 'Use Free type' translated; description: 'If checked then allows free type fonts using and update available fonts by scanning the current system' translated; precondition: [FT2Library current notNil]; parent: #appearance; order: 3; with: [ (aBuilder pickOne: #monitorType) label: 'Monitor type' translated; description: 'LCD is generally better for laptops, CRT for others' translated; target: FreeTypeSettings; targetSelector: #current; order: 0; default: #LCD; domainValues: {#LCD. #CRT}. (aBuilder setting: #updateFontsAtImageStartup) order: 1; target: FreeTypeSettings; label: 'Update fonts at startup' translated; description: 'If true, then the available font list is recomputed at each startup' translated. (aBuilder group: #advancedSettings) order: 10; label: 'Advanced features' translated; description: 'Some very specific parameters as the hinting or the cache size' translated; with: [ (aBuilder range: #cacheSize) target: FreeTypeCache; targetSelector: #current; label: 'Cache size' translated; description: 'The size of the cache in KBytes' translated; default: 5000; range: (0 to: 50000 by: 10). (aBuilder pickOne: #hintingSymbol) label: 'Hinting' translated; description: 'Changes the glyph shapes:' translated , ' o FULL: glyph shapes features are snapped to pixel boundaries. Glyphs are monochrome, with no anti-aliasing. This option changes the shapes the most.' translated , ' o LIGHT: glyph shapes features are partially snapped to pixel boundaries. This option changes the shapes less than with Full, resulting in better shapes, but less contrast.' translated , ' o NORMAL: glyph shapes features are snapped to pixel boundaries. Glyphs are anti-aliased.' translated , ' o NONE: use the original glyph shapes without snapping their features to pixel boundaries. This gives the best shapes, but with less contrast and more fuzziness.' translated; target: FreeTypeSettings; targetSelector: #current; default: #Light; domainValues: { 'Light' translated->#Light. 'Normal' translated ->#Normal. 'Full' translated -> #Full. 'None' translated -> #None}. (aBuilder range: #glyphContrast) target: FreeTypeSettings; targetSelector: #current; label: 'Glyph contrast' translated; description: 'Change the contrast level for glyphs. This is an integer between 1 and 100' translated; default: 50; range: (0 to: 100 by: 10)]]! ! !FreeTypeSystemSettings class methodsFor: 'settings' stamp: 'MikeMueller 3/5/2013 12:58'! noFt2Library: aBoolean "ignore it for now" ! ! !FreeTypeSystemSettings class methodsFor: 'settings' stamp: 'AlainPlantec 9/17/2011 15:50'! noFt2Library ^ 'Free type fonts are not available'! ! !FtpUrl commentStamp: 'TorstenBergmann 2/3/2014 23:09'! An FTP Url! !FtpUrl methodsFor: '*Gofer-Core' stamp: 'SeanDeNigris 8/26/2012 15:38'! mcRepositoryAsUser: usernameString withPassword: passwordString ^ MCFtpRepository host: (self port ifNil: [ self authority ] ifNotNil: [ self authority , ':', self port ]) directory: self fullPath allButFirst "FTW: MCFtpRepository assumes NO prefixed / in the path" user: usernameString password: passwordString.! ! !FtpUrl class methodsFor: 'constants' stamp: 'SeanDeNigris 8/26/2012 15:32'! schemeName ^ 'ftp'.! ! !FuelOutStackDebugAction commentStamp: ''! A FuelOutStackDebugAction is a debugging action that serialize a portion of the current stack trace using fuel. ! !FuelOutStackDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 10/7/2013 11:47'! id ^ #fuelOutStack! ! !FuelOutStackDebugAction methodsFor: 'actions' stamp: 'AndreiChis 10/7/2013 11:51'! executeAction self serializeStack! ! !FuelOutStackDebugAction methodsFor: 'actions' stamp: 'AndreiChis 10/7/2013 11:57'! serializeStack | date fileName | "Serialize a portion of the current stack trace using fuel.." date := DateAndTime now. fileName := String streamContents: [ :s| s << 'Debugger-Stack-'; << self interruptedContext receiver class theNonMetaClass name; << '-'. date printYMDOn: s. s << '-'; print: date hour24; print: date minute; print: date second; << '.fuel']. [ self class serializeTestFailureContext: self interruptedContext copyStack toFileNamed: fileName ] on: Error do: [:err| "simply continue..." ].! ! !FuelOutStackDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 10/7/2013 11:47'! defaultLabel ^ 'Fuel out Stack'! ! !FuelOutStackDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 10/7/2013 11:48'! defaultOrder ^ 125! ! !FuelOutStackDebugAction class methodsFor: 'private' stamp: 'AndreiChis 10/7/2013 11:59'! encodeDebugInformationOn: aSerializer | str | str := String new writeStream. str print: Date today; space; print: Time now. aSerializer at: #Timestamp putAdditionalObject: str contents. str := String new writeStream. str nextPutAll: 'VM: '; nextPutAll: Smalltalk os name asString; nextPutAll: ' - '; nextPutAll: Smalltalk os subtype asString; nextPutAll: ' - '; nextPutAll: Smalltalk os version asString; nextPutAll: ' - '; nextPutAll: Smalltalk vm version asString. aSerializer at: #VM putAdditionalObject: str contents. str := String new writeStream. str nextPutAll: 'Image: '; nextPutAll: SystemVersion current version asString; nextPutAll: ' ['; nextPutAll: Smalltalk lastUpdateString asString; nextPutAll: ']'. aSerializer at: #Image putAdditionalObject: str contents.! ! !FuelOutStackDebugAction class methodsFor: 'serialization' stamp: 'AndreiChis 10/7/2013 11:59'! serializeTestFailureContext: aContext toFileNamed: aFilename | serializer | serializer := FLSerializer newDefault. self encodeDebugInformationOn: serializer. serializer addPostMaterializationAction: [ :materialization | Smalltalk tools debugger openOn: Processor activeProcess context: materialization root label: 'External stack' contents: nil fullView: false ]. serializer " use the sender context, generally the current context is not interesting" serialize: aContext toFileNamed: aFilename! ! !FuelOutStackDebugAction class methodsFor: 'registration' stamp: 'AndreiChis 10/7/2013 12:05'! actionType ! ! !FullStackDebugAction commentStamp: ''! A FullStackDebugAction displays the entire stack in the stack widget. ! !FullStackDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/20/2013 15:47'! id ^ #fullStack! ! !FullStackDebugAction methodsFor: 'actions' stamp: 'AndreiChis 9/29/2013 16:28'! executeAction self debugger stack expandBy: self expandedStackSize ! ! !FullStackDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/20/2013 16:00'! enabled ^ self shouldEnableFullStackButton! ! !FullStackDebugAction methodsFor: 'testing' stamp: 'AndreiChis 9/20/2013 15:59'! shouldEnableFullStackButton self debugger ifNil: [ ^ false ]. ^ self debugger stack listItems ifEmpty: [ false ] ifNotEmpty: [ :aList | aList last sender notNil ] ! ! !FullStackDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/20/2013 15:47'! defaultLabel ^ 'Full Stack'! ! !FullStackDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/20/2013 15:46'! defaultOrder ^ 30! ! !FullStackDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/29/2013 16:28'! expandedStackSize ^ 100000! ! !FullStackDebugAction class methodsFor: 'registration' stamp: 'AndreiChis 9/21/2013 22:14'! actionType ! ! !FullscreenMorph commentStamp: 'gvc 5/18/2007 13:04'! Provides for another morph to occupy the full screen area (less docking bars).! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/19/2012 17:58'! setContentMorph: aMorph "Replace the submorphs with aMorph." self removeAllMorphs. self addMorph: aMorph fullFrame: LayoutFrame identity! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:15'! isAdheringToTop "Must implement. Answer false." ^false! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 12/3/2007 12:39'! defaultColor "Return the receiver's default color." ^Color white! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:15'! isAdheringToLeft "Must implement. Answer false." ^false! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/30/2006 10:44'! contentMorph "Answer the current content." ^self submorphs first! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:15'! isAdheringToBottom "Must implement. Answer false." ^false! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/1/2012 20:06'! openAsIsIn: aWorld "Start stepping." aWorld addMorph: self. (self submorphs notEmpty and: [self submorphs first isSystemWindow]) ifTrue: [self submorphs first openedFullscreen]. aWorld startSteppingSubmorphsOf: self. self announceOpened.! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:11'! isDockingBar "Answer yes so we get updated when the Display is resized." ^true! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 19:27'! updateBounds "Update the receiver's bounds to fill the world." self bounds: self owner clearArea ! ! !FullscreenMorph methodsFor: 'initialization' stamp: 'gvc 9/19/2006 12:57'! initialize "Initialize the receiver." super initialize. self changeProportionalLayout; bounds: World clearArea; beSticky! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:21'! edgeToAdhereTo "Must implement. Answer #none." ^#none! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 12/11/2009 07:39'! layoutChanged "Don't pass to owner, since the receiver doesn't care!! Improves frame rate." fullBounds := nil. self layoutPolicy ifNotNil:[:l | l flushLayoutCache].! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 09:04'! openInWorld: aWorld "Open as is." ^self openAsIsIn: aWorld! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/30/2006 14:06'! openAsIs "Open in the current world with the current position and extent." ^self openAsIsIn: self currentWorld ! ! !FullscreenMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/14/2006 16:15'! isAdheringToRight "Must implement. Answer false." ^false! ! !FuzzyLabelMorph commentStamp: 'gvc 5/18/2007 13:16'! A label that underdraws to the top-left, top-right, bottom-right and bottom left by a specifed offset in a contrasting colour to the receiver's with a specified alpha value.! !FuzzyLabelMorph methodsFor: 'initialization' stamp: 'gvc 8/9/2007 12:52'! initialize "Initialize the receiver." offset := 1. alpha := 0.5. super initialize! ! !FuzzyLabelMorph methodsFor: 'accessing' stamp: 'gvc 3/26/2007 16:57'! alpha "Answer the value of alpha" ^ alpha! ! !FuzzyLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 12:52'! initWithContents: aString font: aFont emphasis: emphasisCode "Grrr, why do they do basicNew?" offset := 1. alpha := 0.5. super initWithContents: aString font: aFont emphasis: emphasisCode! ! !FuzzyLabelMorph methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 3/24/2010 17:12'! drawOn: aCanvas "Draw based on enablement." |pc fuzzColor labelColor| pc := self paneColor. labelColor := self enabled ifTrue: [self color] ifFalse: [pc twiceDarker]. fuzzColor := self enabled ifTrue: [labelColor twiceDarker darker contrastingColor alpha: self alpha] ifFalse: [Color transparent]. aCanvas depth < 8 ifTrue: [fuzzColor := Color transparent alpha: 0.001]. fuzzColor isTransparent ifFalse: [ aCanvas drawString: self contents in: (self bounds translateBy: 0 @ -1) font: self fontToUse color: fuzzColor; drawString: self contents in: (self bounds translateBy: (self offset * 2) @ -1) font: self fontToUse color: fuzzColor; drawString: self contents in: (self bounds translateBy: (self offset * 2) @ (self offset * 2 - 1)) font: self fontToUse color: fuzzColor; drawString: self contents in: (self bounds translateBy: 0 @ (self offset * 2 - 1)) font: self fontToUse color: fuzzColor]. aCanvas drawString: self contents in: (self bounds translateBy: self offset @ (self offset - 1)) font: self fontToUse color: labelColor! ! !FuzzyLabelMorph methodsFor: 'accessing' stamp: 'gvc 3/16/2007 10:45'! offset "Answer the value of offset" ^ offset! ! !FuzzyLabelMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 13:06'! offset: anObject "Set the value of offset" offset := anObject. self fitContents! ! !FuzzyLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/29/2007 17:02'! measureContents "Add 2 times offset." ^super measureContents ceiling + (self offset * 2) asPoint! ! !FuzzyLabelMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 12:51'! alpha: anObject "Set the value of alpha" alpha := anObject. self changed! ! !FuzzyLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/29/2007 17:22'! setWidth: width "Set the width/extent." self extent: width @ (self fontToUse height ceiling + (2 * self offset))! ! !GB2312 commentStamp: 'yo 10/19/2004 19:52'! This class represents the domestic character encoding called GB 2312 used for simplified Chinese. ! !GB2312 class methodsFor: 'class methods' stamp: 'yo 8/6/2003 05:30'! isLetter: char | value leading | leading := char leadingChar. value := char charCode. leading = 0 ifTrue: [^ super isLetter: char]. value := value // 94 + 1. ^ 1 <= value and: [value < 84]. ! ! !GB2312 class methodsFor: 'class methods' stamp: 'StephaneDucasse 8/22/2013 14:31'! initialize " GB2312 initialize " EncodedCharSet declareEncodedCharSet: self atIndex: 2+1. EncodedCharSet declareEncodedCharSet: self atIndex: 8+1. compoundTextSequence := String streamContents: [ :stream | stream nextPut: Character escape. stream nextPut: $$. stream nextPut: $(. stream nextPut: $A ]! ! !GB2312 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! compoundTextSequence ^ compoundTextSequence! ! !GB2312 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state | c1 c2 | state charSize: 2. state g0Leading ~= self leadingChar ifTrue: [ state g0Leading: self leadingChar. state g0Size: 2. aStream basicNextPutAll: compoundTextSequence ]. c1 := ascii // 94 + 33. c2 := ascii \\ 94 + 33. ^ aStream basicNextPut: (Character value: c1); basicNextPut: (Character value: c2)! ! !GB2312 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:51'! leadingChar ^ 2. ! ! !GB2312 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! ucsTable ^ UCSTable gb2312Table. ! ! !GIFReadWriter commentStamp: ''! Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved. Used with permission. Modified for use in Squeak.! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'lr 7/4/2009 10:42'! readColorTable: numberOfEntries | array r g b | array := Array new: numberOfEntries. 1 to: array size do: [ :i | r := self next. g := self next. b := self next. array at: i put: (Color r: r g: g b: b range: 255) ]. ^ array! ! !GIFReadWriter methodsFor: 'private-bits access' stamp: 'lr 7/4/2009 10:42'! nextBits | integer readBitCount shiftCount byte | integer := 0. remainBitCount = 0 ifTrue: [ readBitCount := 8. shiftCount := 0 ] ifFalse: [ readBitCount := remainBitCount. shiftCount := remainBitCount - 8 ]. [ readBitCount < codeSize ] whileTrue: [ byte := self nextByte. byte == nil ifTrue: [ ^ eoiCode ]. integer := integer + (byte bitShift: shiftCount). shiftCount := shiftCount + 8. readBitCount := readBitCount + 8 ]. (remainBitCount := readBitCount - codeSize) = 0 ifTrue: [ byte := self nextByte ] ifFalse: [ byte := self peekByte ]. byte == nil ifTrue: [ ^ eoiCode ]. ^ integer + (byte bitShift: shiftCount) bitAnd: maxCode! ! !GIFReadWriter methodsFor: 'stream access' stamp: 'bf 5/29/2003 01:23'! close "Write terminator" self nextPut: Terminator. ^super close! ! !GIFReadWriter methodsFor: 'private-packing' stamp: ''! nextBytePut: aByte bufStream nextPut: aByte. bufStream size >= 254 ifTrue: [self flushBuffer]! ! !GIFReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! checkCodeSize (freeCode > maxCode and: [ codeSize < 12 ]) ifTrue: [ codeSize := codeSize + 1. maxCode := (1 bitShift: codeSize) - 1 ]! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: 'lr 7/4/2009 10:42'! readPixelFrom: bits "Since bits is a Bitmap with 32 bit values, watch out for the padding at the end of each row. But, GIF format already wants padding to 32 bit boundary!! OK as is. tk 9/14/97" | pixel | ypos >= height ifTrue: [ ^ nil ]. pixel := bits byteAt: ypos * rowByteSize + xpos + 1. self updatePixelPosition. ^ pixel! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: ''! writeWord: aWord self nextPut: (aWord bitAnd: 255). self nextPut: ((aWord bitShift: -8) bitAnd: 255). ^aWord! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: ''! readWord ^self next + (self next bitShift: 8)! ! !GIFReadWriter methodsFor: 'private-packing' stamp: ''! peekByte bufStream atEnd ifTrue: [self atEnd ifTrue: [^nil]. self fillBuffer]. ^bufStream peek! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'CamilloBruni 8/1/2012 16:14'! readBitData "using modified Lempel-Ziv Welch algorithm." | outCodes outCount bitMask initCodeSize code curCode oldCode inCode finChar i bytes f c packedBits hasLocalColor localColorSize maxOutCodes | maxOutCodes := 4096. offset := self readWord @ self readWord. "Image Left@Image Top" width := self readWord. height := self readWord. "--- Local Color Table Flag 1 Bit Interlace Flag 1 Bit Sort Flag 1 Bit Reserved 2 Bits Size of Local Color Table 3 Bits ----" packedBits := self next. interlace := (packedBits bitAnd: 64) ~= 0. hasLocalColor := (packedBits bitAnd: 128) ~= 0. localColorSize := 1 bitShift: (packedBits bitAnd: 7) + 1. hasLocalColor ifTrue: [ localColorTable := self readColorTable: localColorSize ]. pass := 0. xpos := 0. ypos := 0. rowByteSize := (width + 3) // 4 * 4. remainBitCount := 0. bufByte := 0. bufStream := ByteArray new readStream. outCodes := ByteArray new: maxOutCodes + 1. outCount := 0. prefixTable := Array new: 4096. suffixTable := Array new: 4096. initCodeSize := self next. bitMask := (1 bitShift: initCodeSize) - 1. self setParameters: initCodeSize. bitsPerPixel > 8 ifTrue: [ ^ self error: 'never heard of a GIF that deep' ]. bytes := ByteArray new: rowByteSize * height. [ (code := self readCode) = eoiCode ] whileFalse: [ code = clearCode ifTrue: [ self setParameters: initCodeSize. curCode := oldCode := code := self readCode. finChar := curCode bitAnd: bitMask. "Horrible hack to avoid running off the end of the bitmap. Seems to cure problem reading some gifs!!?" xpos = 0 ifTrue: [ ypos < height ifTrue: [ bytes at: ypos * rowByteSize + xpos + 1 put: finChar ] ] ifFalse: [ bytes at: ypos * rowByteSize + xpos + 1 put: finChar ]. self updatePixelPosition ] ifFalse: [ curCode := inCode := code. curCode >= freeCode ifTrue: [ curCode := oldCode. outCodes at: (outCount := outCount + 1) put: finChar ]. [ curCode > bitMask ] whileTrue: [ outCount > maxOutCodes ifTrue: [ ^ self error: 'corrupt GIF file (OutCount)' ]. outCodes at: (outCount := outCount + 1) put: (suffixTable at: curCode + 1). curCode := prefixTable at: curCode + 1 ]. finChar := curCode bitAnd: bitMask. outCodes at: (outCount := outCount + 1) put: finChar. i := outCount. [ i > 0 ] whileTrue: [ "self writePixel: (outCodes at: i) to: bits" bytes at: ypos * rowByteSize + xpos + 1 put: (outCodes at: i). self updatePixelPosition. i := i - 1 ]. outCount := 0. prefixTable at: freeCode + 1 put: oldCode. suffixTable at: freeCode + 1 put: finChar. oldCode := inCode. freeCode := freeCode + 1. self checkCodeSize ] ]. prefixTable := suffixTable := nil. f := ColorForm extent: width @ height depth: 8. f bits copyFromByteArray: bytes. "Squeak can handle depths 1, 2, 4, and 8" bitsPerPixel > 4 ifTrue: [ ^ f ]. "reduce depth to save space" c := ColorForm extent: width @ height depth: (bitsPerPixel = 3 ifTrue: [ 4 ] ifFalse: [ bitsPerPixel ]). f displayOn: c. ^ c! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: 'PeterHugossonMiller 9/3/2009 01:35'! writeBitData: bits "using modified Lempel-Ziv Welch algorithm." | maxBits maxMaxCode tSize initCodeSize ent tShift fCode pixel index disp nomatch | pass := 0. xpos := 0. ypos := 0. rowByteSize := (width * 8 + 31) // 32 * 4. remainBitCount := 0. bufByte := 0. bufStream := (ByteArray new: 256) writeStream. maxBits := 12. maxMaxCode := 1 bitShift: maxBits. tSize := 5003. prefixTable := Array new: tSize. suffixTable := Array new: tSize. initCodeSize := bitsPerPixel <= 1 ifTrue: [ 2 ] ifFalse: [ bitsPerPixel ]. self nextPut: initCodeSize. self setParameters: initCodeSize. tShift := 0. fCode := tSize. [ fCode < 65536 ] whileTrue: [ tShift := tShift + 1. fCode := fCode * 2 ]. tShift := 8 - tShift. 1 to: tSize do: [ :i | suffixTable at: i put: -1 ]. self writeCodeAndCheckCodeSize: clearCode. ent := self readPixelFrom: bits. [ (pixel := self readPixelFrom: bits) == nil ] whileFalse: [ fCode := (pixel bitShift: maxBits) + ent. index := ((pixel bitShift: tShift) bitXor: ent) + 1. (suffixTable at: index) = fCode ifTrue: [ ent := prefixTable at: index ] ifFalse: [ nomatch := true. (suffixTable at: index) >= 0 ifTrue: [ disp := tSize - index + 1. index = 1 ifTrue: [ disp := 1 ]. "probe" [ (index := index - disp) < 1 ifTrue: [ index := index + tSize ]. (suffixTable at: index) = fCode ifTrue: [ ent := prefixTable at: index. nomatch := false "continue whileFalse:" ]. nomatch and: [ (suffixTable at: index) > 0 ] ] whileTrue: [ "probe" ] ]. "nomatch" nomatch ifTrue: [ self writeCodeAndCheckCodeSize: ent. ent := pixel. freeCode < maxMaxCode ifTrue: [ prefixTable at: index put: freeCode. suffixTable at: index put: fCode. freeCode := freeCode + 1 ] ifFalse: [ self writeCodeAndCheckCodeSize: clearCode. 1 to: tSize do: [ :i | suffixTable at: i put: -1 ]. self setParameters: initCodeSize ] ] ] ]. prefixTable := suffixTable := nil. self writeCodeAndCheckCodeSize: ent. self writeCodeAndCheckCodeSize: eoiCode. self flushCode. self nextPut: 0 "zero-length packet"! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! nextImage "Read in the next GIF image from the stream. Read it all into memory first for speed." | f thisImageColorTable | stream class == ReadWriteStream ifFalse: [ stream binary. self on: (ReadWriteStream with: stream contentsOfEntireFile) ]. localColorTable := nil. self readHeader. f := self readBody. self close. f == nil ifTrue: [ ^ self error: 'corrupt GIF file' ]. thisImageColorTable := localColorTable ifNil: [ colorPalette ]. transparentIndex ifNotNil: [ transparentIndex + 1 > thisImageColorTable size ifTrue: [ thisImageColorTable := thisImageColorTable forceTo: transparentIndex + 1 paddingWith: Color white ]. thisImageColorTable at: transparentIndex + 1 put: Color transparent ]. f colors: thisImageColorTable. ^ f! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'lr 7/4/2009 10:42'! skipBitData | misc blocksize | self readWord. "skip Image Left" self readWord. "skip Image Top" self readWord. "width" self readWord. "height" misc := self next. (misc bitAnd: 128) = 0 ifFalse: [ "skip colormap" 1 to: (1 bitShift: (misc bitAnd: 7) + 1) do: [ :i | self next; next; next ] ]. self next. "minimum code size" [ (blocksize := self next) > 0 ] whileTrue: [ self next: blocksize ]! ! !GIFReadWriter methodsFor: 'private-packing' stamp: 'damiencassou 5/30/2008 14:51'! fillBuffer | packSize | packSize := self next. bufStream := (self next: packSize) readStream! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'bf 5/29/2003 01:43'! delay: aNumberOrNil "Set delay for next image in hundredth (1/100) of seconds" delay := aNumberOrNil! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: ''! flushCode self flushBits! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: 'ClementBera 7/26/2013 16:44'! writeHeader | byte | stream position = 0 ifTrue: [ "For first image only" self nextPutAll: 'GIF89a' asByteArray. self writeWord: width. "Screen Width" self writeWord: height. "Screen Height" byte := 128. "has color map" byte := byte bitOr: (bitsPerPixel - 1 bitShift: 5). "color resolution" byte := byte bitOr: bitsPerPixel - 1. "bits per pixel" self nextPut: byte. self nextPut: 0. "background color." self nextPut: 0. "reserved" colorPalette do: [ :pixelValue | self nextPut: ((pixelValue bitShift: -16) bitAnd: 255); nextPut: ((pixelValue bitShift: -8) bitAnd: 255); nextPut: (pixelValue bitAnd: 255) ]. loopCount notNil ifTrue: [ "Write a Netscape loop chunk" self nextPut: Extension. self nextPutAll: #( 255 11 78 69 84 83 67 65 80 69 50 46 48 3 1 ) asByteArray. self writeWord: loopCount. self nextPut: 0 ] ]. delay notNil | transparentIndex notNil ifTrue: [ self nextPut: Extension; nextPutAll: #(249 4 ) asByteArray; nextPut: (transparentIndex ifNil: [ 0 ] ifNotNil: [ 9 ]); writeWord: (delay ifNil: [ 0 ]); nextPut: (transparentIndex ifNil: [ 0 ]); nextPut: 0 ]. self nextPut: ImageSeparator. self writeWord: 0. "Image Left" self writeWord: 0. "Image Top" self writeWord: width. "Image Width" self writeWord: height. "Image Height" byte := interlace ifTrue: [ 64 ] ifFalse: [ 0 ]. self nextPut: byte! ! !GIFReadWriter methodsFor: 'private-bits access' stamp: 'lr 7/4/2009 10:42'! nextBitsPut: anInteger | integer writeBitCount shiftCount | shiftCount := 0. remainBitCount = 0 ifTrue: [ writeBitCount := 8. integer := anInteger ] ifFalse: [ writeBitCount := remainBitCount. integer := bufByte + (anInteger bitShift: 8 - remainBitCount) ]. [ writeBitCount < codeSize ] whileTrue: [ self nextBytePut: ((integer bitShift: shiftCount) bitAnd: 255). shiftCount := shiftCount - 8. writeBitCount := writeBitCount + 8 ]. (remainBitCount := writeBitCount - codeSize) = 0 ifTrue: [ self nextBytePut: (integer bitShift: shiftCount) ] ifFalse: [ bufByte := integer bitShift: shiftCount ]. ^ anInteger! ! !GIFReadWriter methodsFor: 'private-bits access' stamp: 'lr 7/4/2009 10:42'! flushBits remainBitCount = 0 ifFalse: [ self nextBytePut: bufByte. remainBitCount := 0 ]. self flushBuffer! ! !GIFReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setParameters: initCodeSize clearCode := 1 bitShift: initCodeSize. eoiCode := clearCode + 1. freeCode := clearCode + 2. codeSize := initCodeSize + 1. maxCode := (1 bitShift: codeSize) - 1! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'ar 10/24/2005 22:52'! nextPutImage: aForm | reduced tempForm | aForm unhibernate. aForm depth > 8 ifTrue:[ reduced := aForm colorReduced. "minimize depth" reduced depth > 8 ifTrue: [ "Not enough color space; do it the hard way." reduced := reduced asFormOfDepth: 8]. ] ifFalse:[reduced := aForm]. reduced depth < 8 ifTrue: [ "writeBitData: expects depth of 8" tempForm := reduced class extent: reduced extent depth: 8. (reduced isColorForm) ifTrue:[ tempForm copyBits: reduced boundingBox from: reduced at: 0@0 clippingBox: reduced boundingBox rule: Form over fillColor: nil map: nil. tempForm colors: reduced colors. ] ifFalse: [reduced displayOn: tempForm]. reduced := tempForm. ]. (reduced isColorForm) ifTrue:[ (reduced colorsUsed includes: Color transparent) ifTrue: [ transparentIndex := (reduced colors indexOf: Color transparent) - 1. ] ] ifFalse: [transparentIndex := nil]. width := reduced width. height := reduced height. bitsPerPixel := reduced depth. colorPalette := reduced colormapIfNeededForDepth: 32. interlace := false. self writeHeader. self writeBitData: reduced bits. ! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: ''! writeCode: aCode self nextBitsPut: aCode! ! !GIFReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! updatePixelPosition (xpos := xpos + 1) >= width ifFalse: [ ^ self ]. xpos := 0. interlace ifFalse: [ ypos := ypos + 1. ^ self ]. pass = 0 ifTrue: [ (ypos := ypos + 8) >= height ifTrue: [ pass := pass + 1. ypos := 4 ]. ^ self ]. pass = 1 ifTrue: [ (ypos := ypos + 8) >= height ifTrue: [ pass := pass + 1. ypos := 2 ]. ^ self ]. pass = 2 ifTrue: [ (ypos := ypos + 4) >= height ifTrue: [ pass := pass + 1. ypos := 1 ]. ^ self ]. pass = 3 ifTrue: [ ypos := ypos + 2. ^ self ]. ^ self error: 'can''t happen'! ! !GIFReadWriter methodsFor: 'private-packing' stamp: 'PeterHugossonMiller 9/3/2009 01:34'! flushBuffer bufStream isEmpty ifTrue: [ ^ self ]. self nextPut: bufStream size. self nextPutAll: bufStream contents. bufStream := (ByteArray new: 256) writeStream.! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! setStream: aStream "Feed it in from an existing source" stream := aStream! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'lr 7/4/2009 10:42'! readHeader | is89 byte hasColorMap | (self hasMagicNumber: 'GIF87a' asByteArray) ifTrue: [ is89 := false ] ifFalse: [ (self hasMagicNumber: 'GIF89a' asByteArray) ifTrue: [ is89 := true ] ifFalse: [ ^ self error: 'This does not appear to be a GIF file' ] ]. self readWord. "skip Screen Width" self readWord. "skip Screen Height" byte := self next. hasColorMap := (byte bitAnd: 128) ~= 0. bitsPerPixel := (byte bitAnd: 7) + 1. byte := self next. "skip background color." self next ~= 0 ifTrue: [ is89 ifFalse: [ ^ self error: 'corrupt GIF file (screen descriptor)' ] ]. hasColorMap ifTrue: [ colorPalette := self readColorTable: (1 bitShift: bitsPerPixel) ] ifFalse: [ "Transcript cr; show: 'GIF file does not have a color map.'." colorPalette := nil "Palette monochromeDefault" ]! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'bf 5/29/2003 01:39'! loopCount: aNumber "Set looping. This must be done before any image is written!!" loopCount := aNumber! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: ''! writeCodeAndCheckCodeSize: aCode self writeCode: aCode. self checkCodeSize! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'ClementBera 7/26/2013 16:43'! readBody "Read the GIF blocks. Modified to return a form. " | form extype block blocksize packedFields delay1 | form := nil. [ stream atEnd ] whileFalse: [ block := self next. block = Terminator ifTrue: [ ^ form ]. block = ImageSeparator ifTrue: [ form ifNil: [ form := self readBitData ] ifNotNil: [ self skipBitData ] ] ifFalse: [ block = Extension ifFalse: [ ^ form "^ self error: 'Unknown block type'" ]. "Extension block" extype := self next. "extension type" extype = 249 ifTrue: [ "graphics control" self next = 4 ifFalse: [ ^ form "^ self error: 'corrupt GIF file'" ]. "==== Reserved 3 Bits Disposal Method 3 Bits User Input Flag 1 Bit Transparent Color Flag 1 Bit ===" packedFields := self next. delay1 := self next. "delay time 1" delay := (self next * 256 + delay1) * 10. "delay time 2" transparentIndex := self next. (packedFields bitAnd: 1) = 0 ifTrue: [ transparentIndex := nil ]. self next = 0 ifFalse: [ ^ form "^ self error: 'corrupt GIF file'" ] ] ifFalse: [ "Skip blocks" [ (blocksize := self next) > 0 ] whileTrue: [ "Read the block and ignore it and eat the block terminator" self next: blocksize ] ] ] ]! ! !GIFReadWriter methodsFor: 'private-packing' stamp: ''! nextByte bufStream atEnd ifTrue: [self atEnd ifTrue: [^nil]. self fillBuffer]. ^bufStream next! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: ''! readCode ^self nextBits! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'di 9/15/1998 09:53'! understandsImageFormat ^('abc' collect: [:x | stream next asCharacter]) = 'GIF'! ! !GIFReadWriter class methodsFor: 'examples' stamp: 'AlejandroInfante 11/11/2013 15:06'! grabScreenAndSaveOnDisk "GIFReadWriter grabScreenAndSaveOnDisk" | form fileName | form := Form fromUser. form bits size = 0 ifTrue: [ ^ self inform: 'Empty region selected.' ]. fileName := (FileSystem disk workingDirectory / 'Pharo', 'gif') fullName. UIManager default informUser: 'Writing ' translated, fileName during: [ GIFReadWriter putForm: form onFileNamed: fileName ]! ! !GIFReadWriter class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! initialize "GIFReadWriter initialize" ImageSeparator := $, asInteger. Extension := $!! asInteger. Terminator := $; asInteger! ! !GIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! wantsToHandleGIFs ^ false! ! !GIFReadWriter class methodsFor: 'examples' stamp: 'bf 5/29/2003 01:56'! exampleAnim "GIFReadWriter exampleAnim" | writer extent center | writer := GIFReadWriter on: (FileStream newFileNamed: 'anim.gif'). writer loopCount: 20. "Repeat 20 times" writer delay: 10. "Wait 10/100 seconds" extent := 42@42. center := extent / 2. Cursor write showWhile: [ [2 to: center x - 1 by: 2 do: [:r | "Make a fancy anim without using Canvas - inefficient as hell" | image | image := ColorForm extent: extent depth: 8. 0.0 to: 359.0 do: [:theta | image colorAt: (center + (Point r: r degrees: theta)) rounded put: Color red]. writer nextPutImage: image] ] ensure: [writer close]].! ! !GIFReadWriter class methodsFor: 'image reading/writing' stamp: 'GabrielOmarCotelli 12/3/2013 17:22'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^ self allSubclasses detect: [ :cls | cls wantsToHandleGIFs ] ifFound: [ #() ] ifNone: [ "if none of my subclasses wants , then i''ll have to do" #('gif') ]! ! !GZipConstants commentStamp: ''! This class defines magic numbers taken from the RFC1952 GZIP file format specification version 4.3 (1996) [1]. A class imports these constants as 'class variables' by including the following in its class definition: poolDictionaries: 'GZipConstants' A method on the class side initialises the values. [1] http://www.ietf.org/rfc/rfc1952.txt (Section 2.3.1 Member header and trailer) -------------8<----snip--------------- As an aside the following in [GzipConstants class >> initialize] does not match the specification for bit 5 as "reserved". GZipEncryptFlag := 16r20. "Archive is encrypted" I did find it defined here [2] & [3] however the FAQ [4] specifically says encryption is NOT part of the standard. This constant is only used in [GzipReadStream >> on:from:to] as... (flags anyMask: GZipEncryptFlag) ifTrue:[^self error:'Cannot decompress encrypted stream']. So perhaps its okay to leave but maybe some slight benefit from amending the text as follows.. GZipEncryptFlag := 16r20. "Archive is encrypted. Not supported. Not part of the standard." ifTrue:[^self error:'Cannot decompress encrypted stream. Encryption is not part of RFC1952']. It is a better presentation to a user if you can indicate that it is someone else's fault that their decompress failed, and not Pharo. [2] http://www.onicos.com/staff/iz/formats/gzip.html [3] http://research.cs.wisc.edu/wpis/examples/pcca/gzip/gzip.h [3] http://www.gzip.org/#faq15! !GZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:00'! initialize "GZipConstants initialize" GZipMagic := 16r8B1F. "GZIP magic number" GZipDeflated := 8. "Compression method" GZipAsciiFlag := 16r01. "Contents is ASCII" GZipContinueFlag := 16r02. "Part of a multi-part archive" GZipExtraField := 16r04. "Archive has extra fields" GZipNameFlag := 16r08. "Archive has original file name" GZipCommentFlag := 16r10. "Archive has comment" GZipEncryptFlag := 16r20. "Archive is encrypted" GZipReservedFlags := 16rC0. "Reserved" ! ! !GZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:00'! gzipMagic ^GZipMagic! ! !GZipReadStream commentStamp: ''! gzip is an integral part of the VM. ! !GZipReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:30'! updateCrc: oldCrc from: start to: stop in: aCollection "Answer an updated CRC for the range of bytes in aCollection" ^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection.! ! !GZipReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:20'! verifyCrc | stored | stored := 0. 0 to: 24 by: 8 do: [ :i | sourcePos >= sourceLimit ifTrue: [ ^ self crcError: 'No checksum (proceed to ignore)' ]. stored := stored + (self nextByte bitShift: i) ]. stored := stored bitXor: 16rFFFFFFFF. stored = crc ifFalse: [ ^ self crcError: 'Wrong checksum (proceed to ignore)' ]. ^stored! ! !GZipReadStream methodsFor: 'initialize' stamp: 'ar 2/29/2004 03:32'! on: aCollection from: firstIndex to: lastIndex "Check the header of the GZIP stream." | method magic flags length | super on: aCollection from: firstIndex to: lastIndex. crc := 16rFFFFFFFF. magic := self nextBits: 16. (magic = GZipMagic) ifFalse:[^self error:'Not a GZipped stream']. method := self nextBits: 8. (method = GZipDeflated) ifFalse:[^self error:'Bad compression method']. flags := self nextBits: 8. (flags anyMask: GZipEncryptFlag) ifTrue:[^self error:'Cannot decompress encrypted stream']. (flags anyMask: GZipReservedFlags) ifTrue:[^self error:'Cannot decompress stream with unknown flags']. "Ignore stamp, extra flags, OS type" self nextBits: 16; nextBits: 16. "stamp" self nextBits: 8. "extra flags" self nextBits: 8. "OS type" (flags anyMask: GZipContinueFlag) "Number of multi-part archive - ignored" ifTrue:[self nextBits: 16]. (flags anyMask: GZipExtraField) "Extra fields - ignored" ifTrue:[ length := self nextBits: 16. 1 to: length do:[:i| self nextBits: 8]]. (flags anyMask: GZipNameFlag) "Original file name - ignored" ifTrue:[[(self nextBits: 8) = 0] whileFalse]. (flags anyMask: GZipCommentFlag) "Comment - ignored" ifTrue:[[(self nextBits: 8) = 0] whileFalse]. ! ! !GZipReadStream class methodsFor: '*System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:21'! fileReaderServicesForFile: fullName suffix: suffix | services | suffix = 'gz' | (suffix = '*') ifFalse: [ ^ #() ]. services := OrderedCollection new. suffix = '*' | (fullName asLowercase endsWith: '.cs.gz') | (fullName asLowercase endsWith: '.mcs.gz') ifTrue: [ services add: self serviceFileIn. (Smalltalk globals includesKey: #ChangeSorter) ifTrue: [ services add: self serviceFileIntoNewChangeSet ] ]. services addAll: self services. ^ services! ! !GZipReadStream class methodsFor: 'filein/out' stamp: 'dgd 9/21/2003 17:46'! uncompressedFileName: fullName ^((fullName endsWith: '.gz') and: [self confirm: ('{1} appears to be a compressed file. Do you want to uncompress it?' translated format:{fullName})]) ifFalse: [fullName] ifTrue:[self saveContents: fullName]! ! !GZipReadStream class methodsFor: 'unzipping' stamp: 'HernanMoralesDurand 1/23/2014 10:06'! unzip: fullFileName "Unzip the contents of a gzipped file specified by its full file name to the current working directory" ^ self unzip: fullFileName to: FileSystem disk workingDirectory ! ! !GZipReadStream class methodsFor: 'filein/out' stamp: 'CamilloBruni 5/4/2012 20:27'! fileIntoNewChangeSet: fullFileName "FileIn the contents of a gzipped file" | zipped unzipped csClass | csClass := Smalltalk globals at: #ChangeSet ifAbsent: [ ^ self ]. zipped := self on: (FileStream readOnlyFileNamed: fullFileName). unzipped := MultiByteBinaryOrTextStream with: zipped contents asString. unzipped reset. csClass newChangesFromStream: unzipped named: fullFileName asFileReference basename! ! !GZipReadStream class methodsFor: '*System-FileRegistry' stamp: 'tbn 8/11/2010 10:19'! serviceViewDecompress ^ SimpleServiceEntry provider: self label: 'View decompressed' selector: #viewContents: description: 'View decompressed' ! ! !GZipReadStream class methodsFor: '*System-FileRegistry' stamp: 'sd 2/1/2002 22:16'! services ^ Array with: self serviceViewDecompress with: self serviceDecompressToFile ! ! !GZipReadStream class methodsFor: '*System-FileRegistry' stamp: 'tbn 8/11/2010 10:19'! serviceFileIn "Answer a service for filing in an entire file" ^ SimpleServiceEntry provider: self label: 'FileIn entire file' selector: #fileIn: description: 'File in the entire decompressed contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' buttonLabel: 'Filein' ! ! !GZipReadStream class methodsFor: 'filein/out' stamp: 'StephaneDucasse 7/31/2012 23:04'! saveContents: fullFileName "Save the contents of a gzipped file" | zipped buffer unzipped newName | newName := fullFileName copyUpToLast: FileSystem disk extensionDelimiter. unzipped := FileStream newFileNamed: newName. unzipped binary. zipped := self on: (FileStream readOnlyFileNamed: fullFileName). buffer := ByteArray new: 50000. 'Extracting ' , fullFileName displayProgressFrom: 0 to: zipped sourceStream size during: [:bar | [zipped atEnd] whileFalse: [bar current: zipped sourceStream position. unzipped nextPutAll: (zipped nextInto: buffer)]. zipped close. unzipped close]. ^ newName! ! !GZipReadStream class methodsFor: 'filein/out' stamp: 'marcus.denker 11/10/2008 10:04'! viewContents: fullFileName "Open the decompressed contents of the .gz file with the given name. This method is only required for the registering-file-list of Squeak 3.3a and beyond, but does no harm in an earlier system" (FileStream readOnlyFileNamed: fullFileName) ifNotNil: [:aStream | aStream viewGZipContents]! ! !GZipReadStream class methodsFor: 'unzipping' stamp: 'ClementBera 7/26/2013 16:16'! unzip: fullFileName to: pathString "Unzip the contents of the file specified by the full path name fullFileName to the location given by pathString." | zipped buffer unzipped newName | newName := fullFileName copyUpToLast: FileSystem disk extensionDelimiter. pathString asFileReference ensureCreateDirectory. unzipped := FileStream newFileNamed: (pathString asFileReference / newName) fullName. unzipped ifNil: [self error: pathString, ' looks incorrect']. [ unzipped binary. zipped := self on: (FileStream readOnlyFileNamed: fullFileName). buffer := ByteArray new: 50000. [zipped atEnd] whileFalse: [unzipped nextPutAll: (zipped nextInto: buffer)]] ensure: [ zipped close. unzipped close]. ^ newName! ! !GZipReadStream class methodsFor: 'initialization' stamp: 'IgorStasenko 3/6/2011 18:53'! unload Smalltalk tools fileList unregisterFileReader: self ! ! !GZipReadStream class methodsFor: 'filein/out' stamp: 'yo 8/18/2004 20:24'! fileIn: fullFileName "FileIn the contents of a gzipped file" | zipped unzipped | zipped := self on: (FileStream readOnlyFileNamed: fullFileName). unzipped := MultiByteBinaryOrTextStream with: (zipped contents asString). unzipped reset. unzipped fileIn. ! ! !GZipReadStream class methodsFor: '*System-FileRegistry' stamp: 'tbn 8/11/2010 10:19'! serviceFileIntoNewChangeSet "Answer a service for filing in an entire file" ^ SimpleServiceEntry provider: self label: 'Install into new change set' selector: #fileIntoNewChangeSet: description: 'Install the decompressed contents of the file as a body of code in the image: create a new change set and file-in the selected file into it' buttonLabel: 'Install'! ! !GZipReadStream class methodsFor: '*System-FileRegistry' stamp: 'tbn 8/11/2010 10:29'! serviceDecompressToFile ^ FileModifyingSimpleServiceEntry provider: self label: 'Decompress to file' selector: #saveContents: description: 'Decompress to file'! ! !GZipWriteStream commentStamp: ''! gzip is an integral part of the VM. ! !GZipWriteStream methodsFor: 'initialization' stamp: 'ar 12/30/1999 11:41'! writeHeader "Write the GZip header" encoder nextBits: 16 put: GZipMagic. encoder nextBits: 8 put: GZipDeflated. encoder nextBits: 8 put: 0. "No flags" encoder nextBits: 32 put: 0. "no time stamp" encoder nextBits: 8 put: 0. "No extra flags" encoder nextBits: 8 put: 0. "No OS type" ! ! !GZipWriteStream methodsFor: 'initialization' stamp: 'nk 2/19/2004 08:31'! writeFooter "Write some footer information for the crc" super writeFooter. 0 to: 3 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)]. 0 to: 3 do:[:i| encoder nextBytePut: (bytesWritten >> (i*8) bitAnd: 255)].! ! !GZipWriteStream class methodsFor: '*System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:21'! fileReaderServicesForFile: fullName suffix: suffix "Don't offer to compress already-compressed files sjc 3-May 2003-added jpeg extension" ^({ 'gz' . 'sar' . 'zip' . 'gif' . 'jpg' . 'jpeg'. 'pr'. 'png'} includes: suffix) ifTrue: [ #() ] ifFalse: [ self services ] ! ! !GZipWriteStream class methodsFor: '*System-FileRegistry' stamp: 'nk 11/26/2002 13:10'! services ^ { self serviceCompressFile }! ! !GZipWriteStream class methodsFor: 'initialization' stamp: 'IgorStasenko 3/6/2011 18:53'! initialize Smalltalk tools fileList registerFileReader: self! ! !GZipWriteStream class methodsFor: 'initialization' stamp: 'IgorStasenko 3/6/2011 18:53'! unload Smalltalk tools fileList unregisterFileReader: self! ! !GZipWriteStream class methodsFor: 'file list services' stamp: 'sw 11/30/2002 00:11'! compressFile: fileName "Create a compressed file from the file of the given name" (FileStream readOnlyFileNamed: fileName) compressFile! ! !GZipWriteStream class methodsFor: '*System-FileRegistry' stamp: 'tbn 8/11/2010 10:33'! serviceCompressFile ^ FileModifyingSimpleServiceEntry provider: self label: 'Compress file' selector: #compressFile: description: 'Compress file using gzip compression, making a new file'! ! !GeneralScrollBar commentStamp: 'gvc 5/18/2007 13:01'! Support for GeneralScrollPane.! !GeneralScrollBar methodsFor: 'accessing' stamp: 'GaryChambers 11/16/2011 13:28'! showsWhenNeeded "Answer whether the scrollbar should be shown if needed." ^self showState == #whenNeeded! ! !GeneralScrollBar methodsFor: 'initialization' stamp: 'GaryChambers 11/16/2011 13:29'! initialize "Initialize the receiver." super initialize. self showWhenNeeded! ! !GeneralScrollBar methodsFor: 'accessing' stamp: 'GaryChambers 11/16/2011 13:30'! showNever "Set the scrollbar to be never shown." self showState: #never! ! !GeneralScrollBar methodsFor: 'accessing' stamp: 'GaryChambers 11/16/2011 13:28'! showsAlways "Answer whether the scrollbar should always be shown." ^self showState == #always! ! !GeneralScrollBar methodsFor: 'accessing' stamp: 'GaryChambers 11/16/2011 13:29'! showWhenNeeded "Set the scrollbar to be shown if needed." self showState: #whenNeeded! ! !GeneralScrollBar methodsFor: 'accessing' stamp: 'GaryChambers 11/16/2011 13:28'! showsNever "Answer whether the scrollbar should never be shown." ^self showState == #never! ! !GeneralScrollBar methodsFor: 'accessing' stamp: 'GaryChambers 11/16/2011 13:26'! showState: anObject showState := anObject! ! !GeneralScrollBar methodsFor: 'accessing' stamp: 'GaryChambers 11/16/2011 13:26'! showState ^ showState! ! !GeneralScrollBar methodsFor: 'accessing' stamp: 'GaryChambers 11/16/2011 13:30'! showAlways "Set the scrollbar to be always shown." self showState: #always! ! !GeneralScrollBar methodsFor: 'model access' stamp: 'gvc 9/7/2006 13:45'! setValue: newValue "Bypass screwed up scrollbar!!" ^self perform: #setValue: withArguments: {newValue} inSuperclass: Slider! ! !GeneralScrollPane commentStamp: 'gvc 5/18/2007 13:01'! A scroll pane that handles its contents accurately.! !GeneralScrollPane methodsFor: 'initialize' stamp: 'gvc 9/7/2006 12:23'! defaultColor "Answer the default color/fill style for the receiver." ^ Color transparent! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/22/2011 19:07'! newHScrollbar "Answer a new horizontal scrollbar." ^GeneralScrollBar new model: self accessor: #hScrollbarValue! ! !GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 09:40'! scroller: anObject "Set the value of scroller" scroller := anObject! ! !GeneralScrollPane methodsFor: 'event handling' stamp: 'gvc 9/7/2006 12:16'! keyStroke: evt "If pane is not empty, pass the event to the last submorph, assuming it is the most appropriate recipient (!!)" (self scrollByKeyboard: evt) ifTrue: [^self]. self scrollTarget keyStroke: evt! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/22/2011 19:07'! newVScrollbar "Answer a new vertical scrollbar." ^GeneralScrollBar new model: self accessor: #vScrollbarValue! ! !GeneralScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/28/2008 16:55'! mouseWheel: event "Handle a mouseWheel event." (self scrollTarget handlesMouseWheel: event) ifTrue: [^self scrollTarget mouseWheel: event]. "pass on" event direction = #up ifTrue: [ vScrollbar scrollUp: 3]. event direction = #down ifTrue: [ vScrollbar scrollDown: 3]! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:50'! vPageDelta "Answer the vertical page delta." |pd tw sw| tw := self scrollTarget height. sw := self scrollBounds height. pd := tw - sw max: 0. pd = 0 ifFalse: [pd := sw / pd]. ^pd! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 13:48'! vScrollbarInterval "Answer the computed size of the thumb of the vertical scrollbar." ^self scrollBounds height asFloat / self scrollTarget height min: 1.0.! ! !GeneralScrollPane methodsFor: 'initialization' stamp: 'gvc 9/7/2006 10:54'! initialize "Initialize the receiver." super initialize. self scroller: self newScroller; hScrollbar: self newHScrollbar; vScrollbar: self newVScrollbar; scrollTarget: self defaultScrollTarget. self addMorph: self scroller; resizeScroller! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/11/2011 13:15'! changeScrollerTableLayout "Change the scroller's layout policy to a table layout." self scroller changeTableLayout! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 09:48'! scrollTarget "Answer the morph that is scrolled." ^self scroller submorphs first! ! !GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 10:16'! vScrollbar: anObject "Set the value of vScrollbar" vScrollbar := anObject! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 09:57'! resizeScroller "Resize the scroller to fit the scroll bounds." self scroller bounds: self scrollBounds! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/16/2011 13:33'! vScrollbarShowNever "Set the vertical scrollbar to never show." self vScrollbar showNever. self updateScrollbars! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/16/2011 13:33'! vScrollbarShowWhenNeeded "Set the vertical scrollbar to show if needed." self vScrollbar showWhenNeeded. self updateScrollbars! ! !GeneralScrollPane methodsFor: 'event handling' stamp: 'gvc 9/7/2006 12:16'! handlesKeyboard: evt "Yes for page up/down." ^true! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 13:37'! hScrollbarInterval "Answer the computed size of the thumb of the horizontal scrollbar." ^self scrollBounds width asFloat / self scrollTarget width min: 1.0.! ! !GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 10:16'! hScrollbar: anObject "Set the value of hScrollbar" hScrollbar := anObject! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 13:47'! vLeftoverScrollRange "Return the entire scrolling range minus the currently viewed area." ^self scrollTarget height - self scrollBounds height max: 0 ! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:25'! vHideScrollbar "Hide the vertical scrollbar." self vScrollbarShowing ifFalse: [^self]. self removeMorph: self vScrollbar. self hResizeScrollbar. self resizeScroller! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/3/2008 13:06'! scrollBarThickness "Answer the width or height of a scrollbar as appropriate to its orientation." ^self theme scrollbarThickness! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 10/26/2011 14:56'! defaultScrollTarget "Answer a new default scroll target." ^ Morph new extent: 200@150! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:15'! vScrollbarShowing "Answer whether the vertical scrollbar is showing." ^self vScrollbar owner notNil ! ! !GeneralScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/28/2008 16:49'! handlesMouseWheel: evt "Do I want to receive mouseWheel events?." ^true! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:28'! hShowScrollbar "Show the horizontal scrollbar." self hResizeScrollbar. self hScrollbarShowing ifTrue: [^self]. self privateAddMorph: self hScrollbar atIndex: 1. self vResizeScrollbar. self resizeScroller! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/3/2008 13:07'! hResizeScrollbar "Resize the horizontal scrollbar to fit the receiver." |b| b := self innerBounds. b := b top: b bottom - self scrollBarThickness. self vScrollbarShowing ifTrue: [ b := b right: b right - self scrollBarThickness]. self hScrollbar bounds: b! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/3/2008 13:07'! fitScrollTarget "If the scroller is bigger than the scroll target then resize the scroll target to fill the scroller." |extra| extra := 0. self scroller width > self scrollTarget width ifTrue: [self scrollTarget width: self scroller width] ifFalse: [extra := self scrollBarThickness]. self scroller height - extra > self scrollTarget height ifTrue: [self scrollTarget height: self scroller height + extra]! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/16/2011 13:25'! hScrollbarNeeded "Return whether the horizontal scrollbar is needed." self hScrollbar showsAlways ifTrue: [^true]. self hScrollbar showsNever ifTrue: [^false]. ^self scrollTarget width + (self scrollTarget height > self innerBounds height ifTrue: [self scrollBarThickness] ifFalse: [0]) > self innerBounds width! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/16/2011 13:33'! hScrollbarShowAlways "Set the horizontal scrollbar to always show." self hScrollbar showAlways. self updateScrollbars! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:25'! hHideScrollbar "Hide the horizontal scrollbar." self hScrollbarShowing ifFalse: [^self]. self removeMorph: self hScrollbar. self vResizeScrollbar. self resizeScroller! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:49'! hPageDelta "Answer the horizontal page delta." |pd tw sw| tw := self scrollTarget width. sw := self scrollBounds width. pd := tw - sw max: 0. pd = 0 ifFalse: [pd := sw / pd]. ^pd! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 11:16'! updateScrollbars "Update the visibility, dimensions and values of the scrollbars as needed." self vUpdateScrollbar; hUpdateScrollbar; setScrollDeltas! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 11:16'! setScrollDeltas "Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range." self hSetScrollDelta; vSetScrollDelta! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/3/2008 13:07'! vResizeScrollbar "Resize the vertical scrollbar to fit the receiver." |b| b := self innerBounds. b := b left: b right - self scrollBarThickness. self hScrollbarShowing ifTrue: [ b := b bottom: b bottom - self scrollBarThickness]. self vScrollbar bounds: b! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/16/2011 13:25'! vScrollbarNeeded "Return whether the vertical scrollbar is needed." self vScrollbar showsAlways ifTrue: [^true]. self vScrollbar showsNever ifTrue: [^false]. ^self scrollTarget height + (self scrollTarget width > self innerBounds width ifTrue: [self scrollBarThickness] ifFalse: [0]) > self innerBounds height! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/16/2011 13:33'! hScrollbarShowWhenNeeded "Set the horizontal scrollbar to show if needed." self hScrollbar showWhenNeeded. self updateScrollbars! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/17/2009 14:29'! scrollbarThickness "Answer the width or height of a scrollbar as appropriate to its orientation." ^ self theme scrollbarThickness! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/16/2011 13:32'! hScrollbarShowNever "Set the horizontal scrollbar to never show." self hScrollbar showNever. self updateScrollbars! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/19/2006 10:30'! hScrollbarValue: scrollValue "Set the offset of the scroller to match the 0.0-1.0 scroll value." |r| r := self scrollTarget width - self scrollBounds width max: 0. self scroller offset: (r * scrollValue) rounded @ self scroller offset y! ! !GeneralScrollPane methodsFor: 'accessing' stamp: 'GaryChambers 6/20/2011 13:19'! adoptPaneColor: paneColor "Adopt the given pane color." super adoptPaneColor: paneColor. self hScrollbar adoptPaneColor: paneColor. self vScrollbar adoptPaneColor: paneColor! ! !GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 10:16'! hScrollbar "Answer the value of hScrollbar" ^ hScrollbar! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 12/9/2008 12:06'! hUpdateScrollbar "Update the visibility and dimensions of the horizontal scrollbar as needed." self hScrollbarNeeded ifTrue: [self hShowScrollbar; hResizeScrollbar] ifFalse: [self hHideScrollbar]! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:51'! vSetScrollDelta "Set the vertical scrollbar delta, value and interval, based on the current scroll bounds and offset." |pd| pd := self vPageDelta. self vScrollbar scrollDelta: pd / 10 pageDelta: pd; interval: self vScrollbarInterval; setValue: self vScrollbarValue! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/19/2006 10:30'! vScrollbarValue: scrollValue "Set the offset of the scroller to match the 0.0-1.0 scroll value." |r| r := self scrollTarget height - self scrollBounds height max: 0. self scroller offset: self scroller offset x @ (r * scrollValue) rounded! ! !GeneralScrollPane methodsFor: 'layout' stamp: 'GaryChambers 9/8/2011 10:40'! minWidth "Fit the width of the scroll target if hResizing is shrinkWrap." ^self hResizing = #shrinkWrap ifTrue: [self scrollTarget minExtent x + self scrollbarThickness + 5] ifFalse: [super minWidth]! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2008 10:19'! scrollToShow: aRectangle "Scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space." |offset| offset := self scroller offset. ((aRectangle top - offset y) >= 0 and: [ (aRectangle bottom - offset y) <= self innerBounds height]) ifFalse: [offset := offset x @ ( (aRectangle top min: self scrollTarget height - self innerBounds height))]. ((aRectangle left - offset x) >= 0 and: [ (aRectangle right - offset x) <= self innerBounds width]) ifFalse: [offset := (aRectangle left min: self scrollTarget width - self innerBounds width) @ offset y]. offset = self scroller offset ifFalse: [ self scroller offset: offset. self setScrollDeltas]! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/16/2011 13:34'! vScrollbarShowAlways "Set the vertical scrollbar to always show." self vScrollbar showAlways. self updateScrollbars! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:28'! vShowScrollbar "Show the vertical scrollbar." self vResizeScrollbar. self vScrollbarShowing ifTrue: [^self]. self privateAddMorph: self vScrollbar atIndex: 1. self hResizeScrollbar. self resizeScroller! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 10/3/2008 13:07'! scrollBounds "Return the visible scroll area taking into account whether the scrollbars need to be shown." |b| b := self innerBounds. self vScrollbarNeeded ifTrue: [b := b right: (b right - self scrollBarThickness)]. self hScrollbarNeeded ifTrue: [b := b bottom: (b bottom - self scrollBarThickness)]. ^b! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:03'! vUpdateScrollbar "Update the visibility and dimensions of the vertical scrollbar as needed." self vScrollbarNeeded ifTrue: [self vShowScrollbar; vResizeScrollbar] ifFalse: [self vHideScrollbar]! ! !GeneralScrollPane methodsFor: 'geometry' stamp: 'gvc 9/8/2006 11:06'! extent: newExtent "Update the receiver's extent. Hide/show the scrollbars and resize the scroller as neccessary." |scrollbarChange| bounds extent = newExtent ifTrue: [^ self]. super extent: newExtent. scrollbarChange := (self vScrollbarShowing = self vScrollbarNeeded) not. scrollbarChange := scrollbarChange or: [(self hScrollbarShowing = self hScrollbarNeeded) not]. self updateScrollbars. scrollbarChange ifFalse: [self resizeScroller] "if there is a scrollbar change then done already"! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:07'! hScrollbarShowing "Answer whether the horizontal scrollbar is showing." ^self hScrollbar owner notNil ! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:50'! vScrollbarValue "Answer the computed vertical scrollbar value." |tw sw v| tw := self scrollTarget height. sw := self scrollBounds height. v := tw - sw max: 0. v = 0 ifFalse: [v := self scroller offset y asFloat / v min: 1.0]. ^v! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:49'! hScrollbarValue "Answer the computed horizontal scrollbar value." |tw sw v| tw := self scrollTarget width. sw := self scrollBounds width. v := tw - sw max: 0. v = 0 ifFalse: [v := self scroller offset x asFloat / v min: 1.0]. ^v! ! !GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 09:40'! scroller "Answer the value of scroller" ^ scroller! ! !GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 10:16'! vScrollbar "Answer the value of vScrollbar" ^ vScrollbar! ! !GeneralScrollPane methodsFor: 'layout' stamp: 'GaryChambers 1/11/2011 13:33'! doLayoutIn: layoutBounds "Compute a new layout based on the given layout bounds." |scrollbarChange| super doLayoutIn: layoutBounds. scrollbarChange := (self vScrollbarShowing = self vScrollbarNeeded) not. scrollbarChange := scrollbarChange or: [(self hScrollbarShowing = self hScrollbarNeeded) not]. self updateScrollbars. scrollbarChange ifFalse: [self resizeScroller]. "if there is a scrollbar change then done already" super doLayoutIn: layoutBounds ! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:50'! scrollByKeyboard: event "If event is ctrl+up/down then scroll and answer true." |sb| sb := event commandKeyPressed ifTrue: [self hScrollbar] ifFalse: [self vScrollbar]. (event keyValue = 30 or: [event keyValue = 11]) ifTrue: [ sb scrollUp: 3. ^true]. (event keyValue = 31 or: [event keyValue = 12])ifTrue: [ sb scrollDown: 3. ^true]. ^false! ! !GeneralScrollPane methodsFor: 'layout' stamp: 'GaryChambers 9/8/2011 10:40'! minHeight "Fit the width of the scroll target if vResizing is shrinkWrap." ^self vResizing = #shrinkWrap ifTrue: [self scrollTarget minExtent y + self scrollbarThickness + 5] ifFalse: [super minHeight]! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:50'! hSetScrollDelta "Set the horizontal scrollbar delta, value and interval, based on the current scroll bounds and offset." |pd| pd := self hPageDelta. self hScrollbar scrollDelta: pd / 10 pageDelta: pd; interval: self hScrollbarInterval; setValue: self hScrollbarValue! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 8/8/2012 15:32'! newScroller "Answer a new scroller." ^TransformWithLayoutMorph new color: Color transparent! ! !GeneralScrollPane methodsFor: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:48'! scrollTarget: aMorph "Set the morph that is scrolled." self scroller removeAllMorphs; addMorph: aMorph. self updateScrollbars! ! !Generator commentStamp: 'ar 2/10/2010 20:51'! A Generator transforms callback interfaces into stream interfaces. When a producer algorithm provide results as callbacks (blocks) and a consumer algorithm expects streamable input, a Generator transforms one into the other, for example: | generator | generator := Generator on: [:g| Integer primesUpTo: 100 do:[:prime| g yield: prime]]. [generator atEnd] whileFalse:[Transcript show: generator next]. Instance Variables block: The block associated with the generator. continue: The continuation to return to. home: The home (root) context of the activated block next: The next object to return from the Generator. ! !Generator methodsFor: 'accessing' stamp: 'lr 2/10/2010 09:16'! size "A generator does not know its size." ^ self shouldNotImplement! ! !Generator methodsFor: 'accessing' stamp: 'ar 2/10/2010 20:54'! close "Close the receiving generator and unwind its ensure-blocks." continue ifNotNil:[continue unwindTo: home]. continue := block := next := nil! ! !Generator methodsFor: 'testing' stamp: 'ar 2/10/2010 21:00'! atEnd "Answer whether the receiver can access any more objects." ^ continue isNil! ! !Generator methodsFor: 'accessing' stamp: 'lr 2/10/2010 09:16'! nextPut: anObject "Add anObject into the generator. A synonym to #yield: and value:." | previous | previous := next. next := anObject. continue := thisContext swapSender: continue. ^ previous! ! !Generator methodsFor: 'accessing' stamp: 'ar 2/10/2010 20:45'! next "Generate and answer the next object in the receiver." ^ self atEnd ifFalse: [ home swapSender: thisContext sender. continue := thisContext swapSender: continue ]! ! !Generator methodsFor: 'public' stamp: 'ar 2/10/2010 20:52'! yield: anObject "Yield the next value to the consumer of the generator. A synonym for #nextPut:" ^ self nextPut: anObject! ! !Generator methodsFor: 'public' stamp: 'ar 2/10/2010 21:04'! reset "Reset the generator, i.e., start it over" continue ifNotNil:[continue unwindTo: home]. next := nil. continue := thisContext. [ self fork ] value! ! !Generator methodsFor: 'private' stamp: 'ar 2/10/2010 20:46'! fork | result | home := thisContext. block reentrant value: self. thisContext swapSender: continue. result := next. continue := next := home := nil. ^ result! ! !Generator methodsFor: 'public' stamp: 'ar 2/10/2010 21:01'! value: anObject "Allows passing generators as arguments to methods expecting blocks. A synonym for #yield: / #nextPut:." ^ self nextPut: anObject! ! !Generator methodsFor: 'printing' stamp: 'lr 1/8/2009 16:21'! printOn: aStream aStream nextPutAll: self class name; nextPutAll: ' on: '; print: block! ! !Generator methodsFor: 'initialization' stamp: 'lr 1/8/2009 16:18'! initializeOn: aBlock block := aBlock. self reset! ! !Generator methodsFor: 'accessing' stamp: 'lr 4/26/2009 11:50'! contents "Answer the contents of this generator. Do not call this method on infinite generators." | stream | stream := (Array new: 10) writeStream. [ self atEnd ] whileFalse: [ stream nextPut: self next ]. ^ stream contents! ! !Generator methodsFor: 'accessing' stamp: 'lr 2/10/2010 09:16'! peek "Answer the upcoming object of the receiver." ^ next! ! !Generator class methodsFor: 'instance-creation' stamp: 'lr 1/8/2009 15:54'! on: aBlock ^ self basicNew initializeOn: aBlock! ! !GeneratorTest commentStamp: 'TorstenBergmann 2/20/2014 15:29'! SUnit tests for class Generator! !GeneratorTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testErrorPropagation "Ensure that errors in the generator block are properly propagated" | generator | generator := Generator on: [ :g | g yield: 1. g error: 'yo' ]. self should: [ generator next ] raise: Error! ! !GeneratorTest methodsFor: 'testing' stamp: 'ar 2/10/2010 21:03'! testResetUnwind "Just like close, just using reset" | generator doEnsure notEnsure | doEnsure := notEnsure := 0. [ generator := Generator on: [ :g | [ g yield: 1; yield: 2 ] ensure: [ doEnsure := doEnsure + 1 ] ]. self assert: doEnsure = 0; assert: notEnsure = 0. self assert: generator peek = 1. self assert: doEnsure = 0; assert: notEnsure = 0. generator reset. self assert: doEnsure = 1; assert: notEnsure = 0 ] ensure: [ notEnsure := notEnsure + 1 ]. self assert: doEnsure = 1; assert: notEnsure = 1! ! !GeneratorTest methodsFor: 'testing' stamp: 'lr 2/10/2010 09:02'! testEnsure | generator | generator := Generator on: [ :g | [ g yield: 1; yield: 2 ] ensure: [ g yield: 3 ] ]. self assert: generator upToEnd asArray = #( 1 2 3 )! ! !GeneratorTest methodsFor: 'testing' stamp: 'lr 4/26/2009 11:51'! testContents | generator | generator := self numbersBetween: 1 and: 3. self assert: generator contents = #(1 2 3)! ! !GeneratorTest methodsFor: 'testing' stamp: 'lr 1/8/2009 16:33'! testNext | generator | generator := self numbersBetween: 1 and: 3. self assert: generator next = 1. self assert: generator next = 2. self assert: generator next = 3. self assert: generator next isNil! ! !GeneratorTest methodsFor: 'testing' stamp: 'lr 1/8/2009 16:45'! testPeek | generator | generator := self numbersBetween: 1 and: 3. self assert: generator peek = 1. self assert: generator peek = 1. generator next. self assert: generator peek = 2! ! !GeneratorTest methodsFor: 'testing' stamp: 'lr 1/8/2009 16:45'! testEmpty | generator | generator := Generator on: [ :g | ]. self assert: generator atEnd. self assert: generator peek isNil. self assert: generator next isNil! ! !GeneratorTest methodsFor: 'generators' stamp: 'lr 1/8/2009 16:29'! fibonacciSequence "Yields an infinite sequence of fibonacci numbers." ^ Generator on: [ :generator | | a b | a := 0. b := 1. [ a := b + (b := a). generator yield: a ] repeat ]! ! !GeneratorTest methodsFor: 'testing' stamp: 'lr 1/8/2009 16:33'! testAtEnd | generator | generator := self numbersBetween: 1 and: 3. self deny: generator atEnd. generator next. self deny: generator atEnd. generator next. self deny: generator atEnd. generator next. self assert: generator atEnd! ! !GeneratorTest methodsFor: 'testing' stamp: 'lr 1/8/2009 16:50'! testFibonacci | generator | generator := self fibonacciSequence. self assert: (generator next: 10) asArray = #( 1 1 2 3 5 8 13 21 34 55 )! ! !GeneratorTest methodsFor: 'testing' stamp: 'lr 1/8/2009 16:35'! testReset | generator | generator := self numbersBetween: 1 and: 3. self assert: generator next = 1. self assert: generator next = 2. generator reset. self assert: generator next = 1. self assert: generator next = 2. self assert: generator next = 3. self assert: generator next = nil. generator reset. self assert: generator next = 1! ! !GeneratorTest methodsFor: 'generators' stamp: 'lr 1/8/2009 15:49'! numbersBetween: aStartInteger and: aStopInteger "Yields the nubmers between aStartInteger and aStopInteger." ^ Generator on: [ :generator | aStartInteger to: aStopInteger do: [ :value | generator yield: value ] ]! ! !GeneratorTest methodsFor: 'testing' stamp: 'lr 1/8/2009 16:46'! testSimple | generator | generator := Generator on: [ :g | g yield: 1; yield: 2 ]. self assert: generator upToEnd asArray = #( 1 2 )! ! !GeneratorTest methodsFor: 'testing' stamp: 'lr 2/10/2010 09:18'! testClose | generator doEnsure notEnsure | doEnsure := notEnsure := 0. [ generator := Generator on: [ :g | [ g yield: 1; yield: 2 ] ensure: [ doEnsure := doEnsure + 1 ] ]. self assert: doEnsure = 0; assert: notEnsure = 0. self assert: generator peek = 1. self assert: doEnsure = 0; assert: notEnsure = 0. generator close. self assert: doEnsure = 1; assert: notEnsure = 0 ] ensure: [ notEnsure := notEnsure + 1 ]. self assert: doEnsure = 1; assert: notEnsure = 1! ! !GeneratorTest class methodsFor: 'accessing' stamp: 'lr 2/10/2010 08:34'! packageNamesUnderTest ^ #('Generator')! ! !GenericUrl commentStamp: ''! a URL type that can't be broken down in any systematic way. For example, mailto: and telnet: URLs. The part after the scheme name is stored available via the #locator message.! !GenericUrl methodsFor: 'parsing' stamp: 'SvenVanCaekenberghe 10/25/2013 15:00'! privateInitializeFromText: aString schemeName := self class schemeNameForString: aString. locator := schemeName ifNil: [ aString ] ifNotNil: [ aString copyFrom: (schemeName size+2) to: aString size ].! ! !GenericUrl methodsFor: 'parsing' stamp: 'ls 8/4/1998 01:28'! privateInitializeFromText: aString relativeTo: aUrl schemeName := aUrl schemeName. locator := aString.! ! !GenericUrl methodsFor: 'printing' stamp: 'CamilloBruni 12/16/2011 11:27'! printOn: aStream self schemeName ifNotNil: [ aStream nextPutAll: self schemeName; nextPut: $:]. aStream nextPutAll: self locator. self fragment ifNotNil: [ aStream nextPut: $#; nextPutAll: self fragment].! ! !GenericUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:46'! schemeName ^schemeName! ! !GenericUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:46'! locator ^locator! ! !GenericUrl methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:39'! scheme ^ self schemeName.! ! !GenericUrl methodsFor: 'private' stamp: 'ls 6/20/1998 19:46'! schemeName: schemeName0 locator: locator0 schemeName := schemeName0. locator := locator0.! ! !GenericUrl class methodsFor: 'instance creation' stamp: 'ls 6/20/1998 19:46'! schemeName: schemeName locator: locator ^self new schemeName: schemeName locator: locator! ! !GenericUrl class methodsFor: 'parsing' stamp: 'SvenVanCaekenberghe 10/25/2013 15:01'! absoluteFromText: aString | schemeName locator | schemeName := self schemeNameForString: aString. schemeName ifNil: [ ^self schemeName: 'xnoscheme' locator: aString ]. locator := aString copyFrom: (schemeName size + 2) to: aString size. ^self schemeName: schemeName locator: locator! ! !GlyphForm commentStamp: 'TorstenBergmann 2/4/2014 22:11'! A specialized form for glyphs! !GlyphForm methodsFor: 'accessing' stamp: 'tween 4/23/2006 20:54'! advance ^advance! ! !GlyphForm methodsFor: 'converting' stamp: 'StephaneDucasse 10/25/2013 16:16'! asFormOfDepth: d | newForm | d = self depth ifTrue:[^self]. newForm := self class extent: self extent depth: d. (BitBlt toForm: newForm) colorMap: (self colormapIfNeededFor: newForm); copy: (self boundingBox) from: 0@0 in: self fillColor: nil rule: Form over. newForm offset: offset; advance:advance; linearAdvance: linearAdvance. ^newForm! ! !GlyphForm methodsFor: 'accessing' stamp: 'tween 8/6/2006 21:10'! linearAdvance ^linearAdvance ! ! !GlyphForm methodsFor: 'accessing' stamp: 'tween 4/23/2006 20:54'! advance: aNumber ^advance := aNumber! ! !GlyphForm methodsFor: 'accessing' stamp: 'tween 8/6/2006 21:10'! linearAdvance: aNumber ^linearAdvance := aNumber! ! !GlyphRenderer commentStamp: 'TorstenBergmann 2/12/2014 22:21'! Renderer for font glyphs! !GlyphRenderer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/12/2011 19:45'! initForFont: aFont self subclassResponsibility ! ! !GlyphRenderer class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/12/2011 19:26'! test | fnt glyph | fnt := StandardFonts defaultFont. fnt class == LogicalFont ifTrue: [ fnt := fnt realFont. ]. fnt class ~~ FreeTypeFont ifTrue: [ self error: 'invalid font' ]. glyph := self new initPixelSize: fnt pixelSize. glyph renderGlyph: $A asUnicode face: fnt face. glyph renderGlyph: $B asUnicode face: fnt face. glyph renderGlyph: $C asUnicode face: fnt face. glyph renderGlyph: $+ asUnicode face: fnt face. glyph drawOn: Display at: 0@0! ! !GlyphRenderer class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/12/2011 19:45'! forFont: aFont ^ self basicNew initForFont: aFont! ! !GoBackStringMorph commentStamp: ''! A GoBackStringMorph is a string morph which do not totally rotate but do some go and back! !GoBackStringMorph methodsFor: 'event handling' stamp: 'CT 1/8/2013 18:25'! mouseEnter: evt super mouseEnter: evt. frontward := true. index := 0. wait := 0! ! !GoBackStringMorph methodsFor: 'private' stamp: 'CT 1/8/2013 18:55'! currentContentsLargeEnough ^(self font widthOfString: self contents) <= (self ownerChain collect: [ :morph | morph extent x ]) min! ! !GoBackStringMorph methodsFor: 'stepping and presenter' stamp: 'CT 1/8/2013 18:43'! stepAction wait = 0 ifFalse: [ wait := wait - 1. ^ self ]. frontward ifTrue: [ self stepFrontward ] ifFalse: [ self stepBackward ]. self privateSetContents: (initialContents allButFirst: index)! ! !GoBackStringMorph methodsFor: 'stepping and presenter' stamp: 'CT 1/8/2013 18:44'! stepBackward index := index - 1. index = 0 ifTrue: [ frontward := true. wait := 3 ]! ! !GoBackStringMorph methodsFor: 'stepping and presenter' stamp: 'CT 1/8/2013 18:55'! stepFrontward index := index + 1. self currentContentsLargeEnough ifTrue: [ frontward := false. wait := 5 ]! ! !Gofer commentStamp: 'lr 1/30/2010 14:42'! : Gofer, a person who runs errands. Origin 1960s: from go for, i.e. go and fetch. : ''The New Oxford American Dictionary'' !! Synopsis Gofer is a small tool on top of Monticello that loads, updates, merges, diffs, reverts, commits, recompiles and unloads groups of Monticello packages. Contrary to existing tools Gofer makes sure that these operations are performed as clean as possible: - Gofer treats packages from one or more repository in one operation. - Gofer works with fixed versions or tries to find the "latest" version using a given package name. - Gofer automatically assigns repositories to all packages, so that the other tools are ready to be used on individual packages. - Gofer makes sure that there is only one repository instance registered for a single physical location. - Gofer works with Monticello dependencies and uniformly treats them like the primary package. - Gofer prefers to work with faster repositories if there is a choice. - Gofer cleans up after Monticello, no empty class categories and no empty method protocols are to be expected. - Gofer supports operations to sync remote and local repositories with each other. !! Installation Gofer is included with the latest Pharo and GemStone distributions. To update to the latest version you can use Gofer itself: == Gofer upgrade In case you are missing Gofer in your image, grab it from *http://source.lukas-renggli.ch/gofer.html*. !! Description Gofer is very simple by design, the basic useage scenario is always the same and consists of three steps: # You specify one or more Monticello repository URLs. You can do this using the methods ==url:==, ==url:username:password:== (HTTP, FTP), ==directory:==, or ==repository:== if you need full control. You might also use the convenience methods like ==squeaksource:==, ==wiresong:==, or ==gemsource:== for well known repositories. Additionally the following settings are available: #- Gofer implicitly declares the local package cache as a repository. To disable the local package cache use the method ==disablePackageCache==, to re-enable use ==enablePackageCache==. #- Gofer throws an error if a repository is not reachable. To silently ignore repository erros use the message ==disableRepositoryErrors==, to re-enable use ==enableRepositoryErrors==. # You specify one or more Monticello packages you want to work with, by adding them to the Gofer instance. Use ==version:== to add a specific version, or use ==package:== to add the "latest" version in the given repository. Furthermore there is ==package:constraint:== that allows you to further constraint the version to be loaded in a block passed in as the second argument. # You specify one or more actions to be performed on the specified packages: | ==load== | Load the specified packages. | ==update== | Update the specified packages. | ==merge== | Merge the specified packages into their working copies. | ==localChanges== | Answer the changes between the base version and the working copy. | ==browseLocalChanges== | Browse the changes between the base version and the working copy. | ==remoteChanges== | Answer the changes between the working copy and the remote changes. | ==browseRemoteChanges== | Browse the changes between the working copy and the remote changes. | ==cleanup== | Cleans the specified packages. | ==commit== | Commit the modified specified packages. | ==commit:== | Commit the modified specified packages with the given commit message. | ==revert== | Revert the specified packages to the currently loaded version. | ==recompile== | Recompile the specified packages. | ==reinitialize== | Call the class side initializers on the specified packages. | ==unload== | Unload the specified packages. | ==fetch== | Download versions from remote repositories into the local cache. | ==push== | Upload local versions from local cache into remote repositories. !! Example To use Gofer to update to exact versions of the Kom Server, the 'latest' code of Seaside 2.8 and the 'latest' code of the Scriptaculous package that is committed by the author with the initials 'lr' one could evaluate: == Gofer new == squeaksource: 'KomHttpServer'; == version: 'DynamicBindings-gc.7'; == version: 'KomServices-gc.19'; == version: 'KomHttpServer-gc.32'; == update. == Gofer new == squeaksource: 'Seaside'; == package: 'Seaside2.8a'; == package: 'Scriptaculous' constraint: [ :version | version author = 'lr' ]; == load! !Gofer methodsFor: '*metacello-testsmc' stamp: 'dkh 6/12/2012 15:41:23.319'! metacelloUnload "Unload the specified packages." ^ self execute: MetacelloTestsGoferUnload! ! !Gofer methodsFor: '*metacello-testsmc' stamp: 'dkh 6/12/2012 15:41:23.319'! metacelloCleanup "Cleans the specified packages." ^ self execute: MetacelloTestsGoferCleanup! ! !Gofer methodsFor: 'repositories-places' stamp: 'StephaneDucasse 8/5/2013 14:20'! squeaksource3: aProjectName self repository: (MCGemstoneRepository location: 'http://ss3.gemtalksystems.com/ss/' , aProjectName)! ! !Gofer methodsFor: 'repositories-places' stamp: 'lr 7/10/2009 16:27'! impara: aString self url: 'http://source.impara.de/' , aString! ! !Gofer methodsFor: 'initialization' stamp: 'lr 12/13/2009 16:33'! initialize self enablePackageCache; enableRepositoryErrors. references := OrderedCollection new. repositories := OrderedCollection new! ! !Gofer methodsFor: 'operations' stamp: 'lr 12/3/2009 21:06'! push "Upload local versions from local cache into remote repositories." ^ self execute: GoferPush! ! !Gofer methodsFor: 'references' stamp: 'lr 4/3/2010 09:56'! package: aString "Add the package aString to the receiver. aString is a package name as it appears in the Monticello Browser, something like 'Magritte-Seaside'. Gofer will try to resolve this name to an actual version in one of the configured repositories before doing something with the package. Gofer sorts all the versions in all the repositories according to branch name (versions without a branch are preferred), version number, author name and repository priority. The top hit of this sorted list is eventually going to be loaded and used." references addLast: (GoferPackageReference name: aString)! ! !Gofer methodsFor: 'operations' stamp: 'CamilloBruni 9/18/2012 19:10'! loadStable "Load the stable version of the previously specifed configuration." ^ self loadVersion: #stable! ! !Gofer methodsFor: '*metacello-testsmc' stamp: 'dkh 6/12/2012 15:41:23.319'! metacelloLoad "Load the specified packages into the image." ^ self execute: MetacelloGoferLoad! ! !Gofer methodsFor: 'operations' stamp: 'CamilloBruni 9/12/2013 11:00'! loadDevelopment "Load the development version of the previously specifed configuration." ^ self loadVersion: #development! ! !Gofer methodsFor: 'operations' stamp: 'lr 11/10/2009 10:06'! merge "Merge the specified packages into their working copies." ^ self execute: GoferMerge! ! !Gofer methodsFor: 'repositories-places' stamp: 'lr 7/10/2009 16:26'! wiresong: aString self url: 'http://source.wiresong.ca/' , aString! ! !Gofer methodsFor: 'references' stamp: 'lr 4/3/2010 09:52'! version: aString "Add the version aString to the receiver. aString is a version name as it appears in the Monticello Repository Browser, something like 'Magritte-Seaside-lr.334'. Gofer will try to resolve this name to one of the configured repositories before loading the code." references addLast: (GoferVersionReference name: aString)! ! !Gofer methodsFor: 'operations' stamp: 'lr 9/18/2009 18:12'! update "Update the specified packages." ^ self execute: GoferUpdate! ! !Gofer methodsFor: 'repositories-options' stamp: 'lr 12/13/2009 16:32'! disableRepositoryErrors "Silently swallow all repository errors." errorBlock := [ :error | error resume: #() ]! ! !Gofer methodsFor: 'operations' stamp: 'lr 12/30/2009 11:27'! reinitialize "Calls the class side initializers on all package code." ^ self execute: GoferReinitialize! ! !Gofer methodsFor: 'repositories-places' stamp: 'CamilloBruni 9/18/2012 18:27'! smalltalkhubUser: aUserName project: aProjectName self repository: (MCSmalltalkhubRepository owner: aUserName project: aProjectName)! ! !Gofer methodsFor: 'operations' stamp: 'lr 8/20/2009 11:44'! recompile "Recompile the specified packages." ^ self execute: GoferRecompile! ! !Gofer methodsFor: 'repositories-options' stamp: 'SeanDeNigris 7/17/2012 15:47'! enablePackageCache "Enable the use of the package-cache repository." packageCacheRepository := MCCacheRepository uniqueInstance.! ! !Gofer methodsFor: 'operations' stamp: 'CamilloBruni 9/18/2012 19:11'! loadVersion: anMetacelloVersionIdentifierSymbol "Load the given version name" ^ self execute: GoferMetacelloLoad do: [ :operation| operation version: anMetacelloVersionIdentifierSymbol ]! ! !Gofer methodsFor: 'copying' stamp: 'lr 12/13/2009 16:52'! postCopy references := references copy. repositories := repositories copy. resolvedReferencesCache := nil! ! !Gofer methodsFor: 'repositories' stamp: 'SeanDeNigris 7/12/2012 08:44'! directory: aDirectoryOrString "Add a file-system repository at aDirectoryOrString." | repository | repository := (aDirectoryOrString isString and: [ aDirectoryOrString endsWith: '*' ]) ifTrue: [ ((Smalltalk globals at: #MCSubDirectoryRepository ifAbsent: [ self error: aDirectoryOrString printString , ' is an unsupported repository type' ]) new) directory: aDirectoryOrString allButLast asFileReference; yourself ] ifFalse: [ (MCDirectoryRepository new) directory: (aDirectoryOrString isString ifTrue: [ aDirectoryOrString asFileReference ] ifFalse: [ aDirectoryOrString ]); yourself ]. self repository: repository! ! !Gofer methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:17'! allResolvedIn: aRepository "Answer all sorted references within aRepository. For efficiency cache the references." ^ (resolvedReferencesCache ifNil: [ resolvedReferencesCache := Dictionary new ]) at: aRepository ifAbsentPut: [ self basicReferencesIn: aRepository ]! ! !Gofer methodsFor: 'references' stamp: 'CamilloBruni 9/18/2012 18:52'! configurationOf: aProjectName "Add a package reference to the configuration of the given project" references addLast: (GoferConfigurationReference name: aProjectName)! ! !Gofer methodsFor: 'operations-ui' stamp: 'lr 12/14/2009 23:51'! browseLocalChanges "Browse the changes between the base version and the working copy." ^ self execute: GoferBrowseLocalChanges! ! !Gofer methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:14'! resolved "Answer the resolved references of the receiver." ^ self references collect: [ :each | each resolveWith: self ]! ! !Gofer methodsFor: 'operations-ui' stamp: 'lr 12/14/2009 23:51'! browseRemoteChanges "Browse the changes between the working copy and the remote changes." ^ self execute: GoferBrowseRemoteChanges! ! !Gofer methodsFor: 'operations' stamp: 'lr 10/3/2009 11:31'! cleanup "Cleans the specified packages." ^ self execute: GoferCleanup! ! !Gofer methodsFor: 'repositories-places' stamp: 'CamilloBruni 9/18/2012 18:29'! squeaksource: aProjectName self repository: (MCSqueaksourceRepository location: 'http://www.squeaksource.com/' , aProjectName)! ! !Gofer methodsFor: 'private' stamp: 'lr 10/2/2009 10:11'! execute: anOperationClass ^ self execute: anOperationClass do: nil! ! !Gofer methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:17'! allResolved "Answer all sorted references within the configured repositories." | resolved | resolved := OrderedCollection new. self repositories do: [ :repository | resolved addAll: (self allResolvedIn: repository) ]. ^ resolved asSortedCollection asArray! ! !Gofer methodsFor: 'repositories-options' stamp: 'lr 12/13/2009 16:33'! disablePackageCache "Disable the use of the package-cache repository." packageCacheRepository := nil! ! !Gofer methodsFor: 'repositories-places' stamp: 'lr 7/10/2009 16:25'! renggli: aString self url: 'http://source.lukas-renggli.ch/' , aString! ! !Gofer methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:45'! repositories "Answer the configured monticello repositories." | result | result := OrderedCollection withAll: repositories. packageCacheRepository ifNotNil: [ result addFirst: packageCacheRepository ]. ^ result asArray! ! !Gofer methodsFor: 'operations' stamp: 'lr 8/20/2009 10:15'! revert "Revert the specified packages to the currently loaded version." ^ self execute: GoferRevert! ! !Gofer methodsFor: 'operations' stamp: 'lr 11/30/2009 14:17'! load "Load the specified packages into the image." ^ self execute: GoferLoad! ! !Gofer methodsFor: 'private' stamp: 'lr 12/13/2009 16:28'! basicReferencesIn: aRepository ^ [ aRepository goferReferences asSortedCollection asArray ] on: GoferRepositoryError do: errorBlock! ! !Gofer methodsFor: 'operations' stamp: 'lr 11/10/2009 10:07'! unload "Unload the specified packages." ^ self execute: GoferUnload! ! !Gofer methodsFor: 'deprecated' stamp: 'StephaneDucasse 4/25/2012 16:18'! addPackage: aPackage self package: aPackage! ! !Gofer methodsFor: 'private' stamp: 'ClementBera 7/26/2013 16:44'! execute: anOperationClass do: aBlock | operation | operation := anOperationClass on: self copy. aBlock ifNotNil: [ aBlock value: operation ]. ^ operation execute! ! !Gofer methodsFor: 'operations' stamp: 'lr 12/3/2009 21:06'! fetch "Download versions from remote repositories into the local cache." ^ self execute: GoferFetch! ! !Gofer methodsFor: 'operations' stamp: 'lr 11/10/2009 10:08'! commit: aString "Commit the modified packages with the given commit message." ^ self execute: GoferCommit do: [ :operation | operation message: aString ]! ! !Gofer methodsFor: 'operations' stamp: 'lr 12/14/2009 23:51'! localChanges "Answer the changes between the base version and the working copy." ^ self execute: GoferLocalChanges! ! !Gofer methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:18'! references "Answer the configured references." ^ Array withAll: references! ! !Gofer methodsFor: 'references' stamp: 'CamilloBruni 9/18/2012 18:35'! configuration "Add a default Configuration package by using the repository name. Assumes that there has been at least one repository set" ^ self configurationOf: self repositories last project capitalized.! ! !Gofer methodsFor: 'operations' stamp: 'lr 12/12/2009 12:49'! remoteChanges "Display the changes between the working copy and the remote changes." ^ self execute: GoferRemoteChanges! ! !Gofer methodsFor: 'repositories-places' stamp: 'lr 7/10/2009 16:28'! squeakfoundation: aString self url: 'http://source.squeakfoundation.org/' , aString! ! !Gofer methodsFor: 'repositories' stamp: 'lr 12/9/2009 22:17'! url: anUrlString "Add anUrlString as a repository for the following package operations." self url: anUrlString username: String new password: String new! ! !Gofer methodsFor: 'repositories-places' stamp: 'lr 2/7/2010 15:11'! blueplane: aString self url: 'http://squeaksource.blueplane.jp/' , aString! ! !Gofer methodsFor: 'repositories' stamp: 'lr 1/11/2010 10:34'! repository: aRepository "Add aRepository to the repository configuration. If there is already a repository defined in the global configuration with that URL take this one instead." | repository | repository := MCRepositoryGroup default repositories detect: [ :each | each = aRepository ] ifNone: [ aRepository ]. repositories addLast: repository! ! !Gofer methodsFor: 'repositories-options' stamp: 'lr 12/13/2009 16:32'! enableRepositoryErrors "Throw an exception when repositories are not available." errorBlock := [ :error | error pass ]! ! !Gofer methodsFor: 'operations' stamp: 'lr 11/10/2009 10:08'! commit "Commit the modified packages." ^ self execute: GoferCommit! ! !Gofer methodsFor: 'references' stamp: 'lr 4/3/2010 09:56'! package: aString constraint: aOneArgumentBlock "Add the package aString to the receiver, but constraint the resulting versions further with aOneArgumentBlock. For details on the package, see #package:. The following example defines various constraints: aGofer package: 'Magritte-Seaside' constraint: [ :version | version author = 'lr' and: [ version branch = 'trial' and: [ version versionNumber > 120 ] ] ]" references addLast: (GoferConstraintReference name: aString constraint: aOneArgumentBlock)! ! !Gofer methodsFor: 'repositories-places' stamp: 'dkh 10/16/2009 10:04'! gemsource: aString self url: 'http://seaside.gemstone.com/ss/' , aString! ! !Gofer methodsFor: 'repositories' stamp: 'SeanDeNigris 8/26/2012 15:44'! url: urlString username: username password: passwordString "Add urlString as a repository for the following package operations." | repository | repository := urlString asUrl mcRepositoryAsUser: username withPassword: passwordString. self repository: repository.! ! !Gofer class methodsFor: 'private' stamp: 'lr 1/12/2010 19:39'! upgrade "Update Gofer to the latest version using itself." | working | [ self gofer load ] on: Error do: [ :err | err retry ]. self new unload unregister: (MCWorkingCopy forPackage: (MCPackage named: 'Gofer')). self gofer recompile; cleanup! ! !Gofer class methodsFor: 'private' stamp: 'lr 1/5/2010 10:45'! gofer "Create a Gofer instance of Gofer." ^ self new renggli: 'gofer'; package: 'Gofer-Core'; package: 'Gofer-Tests'; yourself! ! !Gofer class methodsFor: 'instance creation' stamp: 'lr 11/6/2009 10:50'! it ^ self new! ! !GoferApiTest commentStamp: 'TorstenBergmann 2/5/2014 09:36'! SUnit tests for Gofer API! !GoferApiTest methodsFor: 'testing-repositories-places' stamp: 'lr 12/13/2009 13:36'! testSqueaksource gofer squeaksource: 'Seaside29'. self assert: gofer repositories: #('http://www.squeaksource.com/Seaside29')! ! !GoferApiTest methodsFor: 'testing-repositories' stamp: 'lr 12/13/2009 16:51'! testHttpRepository gofer url: 'http://source.lukas-renggli.ch/pier' username: 'foo' password: 'bar'. self assert: gofer repositories: #('http://source.lukas-renggli.ch/pier'). self assert: (gofer repositories first isKindOf: MCHttpRepository)! ! !GoferApiTest methodsFor: 'testing' stamp: 'SeanDeNigris 7/17/2012 15:48'! testInitialRepositories gofer := Gofer new. self assert: (gofer repositories size = 1). self assert: (gofer repositories first isKindOf: MCCacheRepository uniqueInstance class)! ! !GoferApiTest methodsFor: 'testing-repositories-options' stamp: 'CamilloBruni 8/31/2013 20:23'! testRepositoryErrors gofer url: 'http://pharo-project.org/page-that-will-never-ever-exist'; repository: self monticelloRepository. gofer package: 'GoferFoo'. gofer enableRepositoryErrors. self should: [ gofer resolved ] raise: GoferRepositoryError. gofer disableRepositoryErrors. gofer resolved! ! !GoferApiTest methodsFor: 'testing-repositories-places' stamp: 'lr 12/13/2009 13:36'! testRenggli gofer renggli: 'pier'. self assert: gofer repositories: #('http://source.lukas-renggli.ch/pier')! ! !GoferApiTest methodsFor: 'testing' stamp: 'lr 12/13/2009 17:40'! testInitialReferences self assert: gofer references isEmpty! ! !GoferApiTest methodsFor: 'testing-repositories-options' stamp: 'SeanDeNigris 7/17/2012 15:49'! testPackageCache gofer squeaksource: 'r1'; squeaksource: 'r2'. gofer enablePackageCache. self assert: gofer repositories: (Array with: MCCacheRepository uniqueInstance description) , #('http://www.squeaksource.com/r1' 'http://www.squeaksource.com/r2'). gofer disablePackageCache. self assert: gofer repositories: #('http://www.squeaksource.com/r1' 'http://www.squeaksource.com/r2')! ! !GoferApiTest methodsFor: 'testing-repositories' stamp: 'CamilloBruni 5/4/2012 18:57'! testDirectoryRepository gofer directory: FileSystem disk workingDirectory fullName. self assert: gofer repositories: (Array with: FileSystem disk workingDirectory fullName). self assert: (gofer repositories first isKindOf: MCDirectoryRepository)! ! !GoferApiTest methodsFor: 'testing-repositories' stamp: 'CamilloBruni 5/4/2012 19:00'! testSubDirectoryRepository Smalltalk globals at: #MCSubDirectoryRepository ifPresent: [ :subDirectoryRepositoryClass | |path| path := (FileSystem disk workingDirectory / '*') fullName. gofer directory: path. self assert: gofer repositories: (Array with: path). self assert: (gofer repositories first isKindOf: subDirectoryRepositoryClass) ]! ! !GoferApiTest methodsFor: 'testing-repositories-places' stamp: 'lr 2/7/2010 15:14'! testBlueplane gofer blueplane: 'SIXX'. self assert: gofer repositories: #('http://squeaksource.blueplane.jp/SIXX')! ! !GoferApiTest methodsFor: 'testing-references' stamp: 'lr 12/13/2009 17:27'! testVersionReference gofer repository: self monticelloRepository; version: 'GoferFoo-lr.2'. self assert: (gofer resolved size = 1). self assert: (gofer resolved first isKindOf: GoferResolvedReference). self assert: (gofer resolved first packageName = 'GoferFoo'). self assert: (gofer resolved first author = 'lr'). self assert: (gofer resolved first branch isEmpty). self assert: (gofer resolved first versionNumber = 2). self assert: (gofer resolved first repository = self monticelloRepository)! ! !GoferApiTest methodsFor: 'testing-repositories-places' stamp: 'CamilloBruni 10/21/2012 12:47'! testSmalltalkhub gofer smalltalkhubUser: 'dh83' project: 'ci'. self assert: gofer repositories: #('http://smalltalkhub.com/mc/dh83/ci/main/')! ! !GoferApiTest methodsFor: 'testing-repositories-places' stamp: 'lr 12/13/2009 13:36'! testImpara gofer impara: 'Tweak'. self assert: gofer repositories: #('http://source.impara.de/Tweak')! ! !GoferApiTest methodsFor: 'testing-repositories' stamp: 'TestRunner 12/13/2009 16:51'! testCustomRepository gofer repository: self monticelloRepository. self assert: gofer repositories: (Array with: self monticelloRepository description). self assert: (gofer repositories first = self monticelloRepository)! ! !GoferApiTest methodsFor: 'testing-repositories' stamp: 'SeanDeNigris 8/27/2012 10:22'! testHttpRepositoryUseStoredCredentials | exampleServer registry | [ exampleServer := 'http://my.cool.repo.server.com/'. registry := MCServerRegistry uniqueInstance. registry on: exampleServer beUser: 'myusername' withPassword: 'mypassword'. gofer url: exampleServer. self assert: gofer repositories: { exampleServer }. self assert: gofer repositories first user equals: 'myusername' ] ensure: [ registry removeCredentialsFor: exampleServer ]. ! ! !GoferApiTest methodsFor: 'testing-repositories-places' stamp: 'lr 12/13/2009 13:36'! testGemsource gofer gemsource: 'Seaside29'. self assert: gofer repositories: #('http://seaside.gemstone.com/ss/Seaside29')! ! !GoferApiTest methodsFor: 'testing-repositories-places' stamp: 'lr 12/13/2009 13:36'! testWiresong gofer wiresong: 'ob'. self assert: gofer repositories: #('http://source.wiresong.ca/ob')! ! !GoferApiTest methodsFor: 'utilities' stamp: 'CamilloBruni 10/21/2012 12:47'! assert: aGofer repositories: anArray self assert: aGofer repositories size = anArray size. aGofer repositories with: anArray do: [ :first :second | self assert: first description equals: second ]! ! !GoferApiTest methodsFor: 'asserting' stamp: 'SeanDeNigris 8/27/2012 11:20'! assert: registry on: serverUrlString hasUser: nameString withPassword: passwordString registry repositoryAt: serverUrlString credentialsDo: [ :user :password | self assert: nameString equals: user. self assert: passwordString equals: password ].! ! !GoferApiTest methodsFor: 'testing-references' stamp: 'lr 12/13/2009 17:27'! testPackageReference gofer repository: self monticelloRepository; package: 'GoferFoo'. self assert: (gofer resolved size = 1). self assert: (gofer resolved first isKindOf: GoferResolvedReference). self assert: (gofer resolved first packageName = 'GoferFoo'). self assert: (gofer resolved first author = 'lr'). self assert: (gofer resolved first branch isEmpty). self assert: (gofer resolved first versionNumber = 4). self assert: (gofer resolved first repository = self monticelloRepository)! ! !GoferApiTest methodsFor: 'testing-repositories' stamp: 'SeanDeNigris 8/27/2012 11:19'! testHttpRepositoryOverrideStoredCredentials | exampleServer registry | [ exampleServer := 'http://my.cool.repo.server.com/'. registry := MCServerRegistry uniqueInstance. registry on: exampleServer beUser: 'myusername' withPassword: 'mypassword'. gofer url: exampleServer username: 'foo' password: 'bar'.. self assert: gofer repositories: { exampleServer }. self assert: gofer repositories first user equals: 'foo'. self assert: registry on: exampleServer hasUser: 'myusername' withPassword: 'mypassword'. ] ensure: [ registry removeCredentialsFor: exampleServer ]. ! ! !GoferApiTest methodsFor: 'testing-repositories-places' stamp: 'lr 12/13/2009 13:36'! testSqueakfoundation gofer squeakfoundation: '39a'. self assert: gofer repositories: #('http://source.squeakfoundation.org/39a')! ! !GoferApiTest methodsFor: 'testing-references' stamp: 'lr 12/13/2009 17:25'! testConstraintReference gofer repository: self monticelloRepository; package: 'GoferBar' constraint: [ :ref | ref branch = 'branch' ]. self assert: (gofer resolved size = 1). self assert: (gofer resolved first isKindOf: GoferResolvedReference). self assert: (gofer resolved first packageName = 'GoferBar'). self assert: (gofer resolved first author = 'lr'). self assert: (gofer resolved first branch = 'branch'). self assert: (gofer resolved first versionNumber = 2). self assert: (gofer resolved first repository = self monticelloRepository)! ! !GoferBrowseLocalChanges commentStamp: 'TorstenBergmann 2/5/2014 09:33'! Browse local changes! !GoferBrowseLocalChanges methodsFor: 'running' stamp: 'lr 12/14/2009 23:50'! execute ^ super execute browse! ! !GoferBrowseRemoteChanges commentStamp: 'TorstenBergmann 2/5/2014 09:33'! Browse remote changes! !GoferBrowseRemoteChanges methodsFor: 'running' stamp: 'lr 12/14/2009 23:50'! execute ^ super execute browse! ! !GoferChanges commentStamp: 'TorstenBergmann 2/5/2014 09:33'! Handling changes! !GoferChanges methodsFor: 'queries' stamp: 'lr 12/12/2009 13:06'! patchsetOf: aReference "Answer the source snapshot of aReference." | source target | source := self sourceSnapshotOf: aReference. target := self targetSnapshotOf: aReference. ^ target patchRelativeToBase: source! ! !GoferChanges methodsFor: 'private' stamp: 'lr 8/19/2009 14:02'! defaultModel ^ MCPatch operations: OrderedCollection new! ! !GoferChanges methodsFor: 'private' stamp: 'lr 12/12/2009 12:56'! addReference: aReference super addReference: aReference. self model operations addAll: (self patchsetOf: aReference) operations! ! !GoferChanges methodsFor: 'queries' stamp: 'lr 12/12/2009 12:59'! targetSnapshotOf: aReference "Answer the source snapshot of aReference." self subclassResponsibility! ! !GoferChanges methodsFor: 'queries' stamp: 'lr 12/12/2009 13:00'! sourceSnapshotOf: aReference "Answer the source snapshot of aReference." self subclassResponsibility! ! !GoferChanges methodsFor: 'running' stamp: 'lr 12/14/2009 23:50'! execute ^ self model! ! !GoferCleanup commentStamp: 'TorstenBergmann 2/5/2014 09:34'! Cleanup working copies! !GoferCleanup methodsFor: 'cleaning' stamp: 'lr 10/3/2009 11:37'! cleanup: aWorkingCopy self cleanupCategories: aWorkingCopy. self cleanupProtocols: aWorkingCopy! ! !GoferCleanup methodsFor: 'cleaning' stamp: 'EstebanLorenzano 9/12/2012 13:33'! cleanupProtocols: aWorkingCopy aWorkingCopy packageSet extensionClasses do: [ :class | (aWorkingCopy packageSet extensionCategoriesForClass: class) do: [ :category | (class organization listAtCategoryNamed: category) isEmpty ifTrue: [ class organization removeCategory: category ] ] ]. aWorkingCopy packageSet classesAndMetaClasses do: [ :class | (aWorkingCopy packageSet coreCategoriesForClass: class) do: [ :category | (class organization listAtCategoryNamed: category) isEmpty ifTrue: [ class organization removeCategory: category ] ] ]! ! !GoferCleanup methodsFor: 'cleaning' stamp: 'EstebanLorenzano 9/12/2012 13:33'! cleanupCategories: aWorkingCopy aWorkingCopy packageSet systemCategories do: [ :category | (Smalltalk organization classesInCategory: category) isEmpty ifTrue: [ Smalltalk organization removeSystemCategory: category ] ]! ! !GoferCleanup methodsFor: 'running' stamp: 'lr 10/3/2009 11:30'! execute self workingCopies do: [ :each | self cleanup: each ]! ! !GoferCommit commentStamp: 'TorstenBergmann 2/5/2014 09:35'! Commit work! !GoferCommit methodsFor: 'accessing' stamp: 'lr 10/2/2009 10:12'! message ^ message! ! !GoferCommit methodsFor: 'running' stamp: 'lr 12/13/2009 19:20'! initializeOn: aGofer super initializeOn: aGofer disablePackageCache! ! !GoferCommit methodsFor: 'running' stamp: 'EstebanLorenzano 9/8/2013 10:58'! execute: aWorkingCopy | repositories version | repositories := self gofer repositories reject: [ :repository | (aWorkingCopy changesRelativeToRepository: repository) isEmpty ]. repositories isEmpty ifTrue: [ ^ self ]. version := [ aWorkingCopy newVersionIn: (MCRepositoryGroup withRepositories: repositories) ] on: MCVersionNameAndMessageRequest do: [ :notifcation | self message ifNil: [ message := notifcation outer last ]. notifcation resume: (Array with: notifcation suggestedName with: self message) ]. self gofer repositories do: [ :repository | repository storeVersion: version ]! ! !GoferCommit methodsFor: 'accessing' stamp: 'lr 10/2/2009 10:12'! message: aString message := aString! ! !GoferCommit methodsFor: 'running' stamp: 'lr 12/13/2009 18:44'! execute self workingCopies do: [ :each | self execute: each ]! ! !GoferConfigurationReference commentStamp: ''! A GoferPackageReference refers to the latest version of a Monticello package representing a Metacello Configuration.! !GoferConfigurationReference methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 19:06'! configurationClass ^ Smalltalk globals at: self configurationName asSymbol! ! !GoferConfigurationReference methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 19:05'! project ^ self configurationClass project! ! !GoferConfigurationReference methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 19:06'! configurationName ^ 'ConfigurationOf', name! ! !GoferConfigurationReference methodsFor: 'accessing' stamp: 'CamilloBruni 10/21/2012 13:01'! name ^ self configurationName ! ! !GoferConfigurationReference methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 19:06'! packageName ^ self configurationName! ! !GoferConfigurationReference methodsFor: 'testing' stamp: 'CamilloBruni 9/18/2012 19:05'! isConfigurationReference ^ true! ! !GoferConstraintReference commentStamp: 'lr 1/30/2010 14:37'! A GoferPackageReference refers to the latest version of a Monticello package satisfying an additional constraint.! !GoferConstraintReference methodsFor: 'initialization' stamp: 'TestRunner 12/12/2009 00:18'! initializeName: aString constraint: aBlock self initializeName: aString. constraintBlock := aBlock! ! !GoferConstraintReference methodsFor: 'private' stamp: 'lr 1/21/2010 00:17'! matches: aResolvedReference ^ (super matches: aResolvedReference) and: [ constraintBlock value: aResolvedReference ]! ! !GoferConstraintReference class methodsFor: 'instance creation' stamp: 'lr 12/9/2009 22:44'! name: aString constraint: aBlock ^ self basicNew initializeName: aString constraint: aBlock! ! !GoferFetch commentStamp: 'TorstenBergmann 2/5/2014 09:31'! Fetch packages using Gofer! !GoferFetch methodsFor: 'private' stamp: 'lr 11/30/2009 13:46'! defaultModel ^ Set new! ! !GoferFetch methodsFor: 'initialization' stamp: 'TestRunner 12/13/2009 19:56'! initializeOn: aGofer super initializeOn: aGofer. self gofer references do: [ :reference | self gofer allResolved do: [ :resolved | ((reference matches: resolved) and: [ (cacheReferences includes: resolved) not ]) ifTrue: [ self model add: resolved ] ] ]! ! !GoferFetch methodsFor: 'running' stamp: 'lr 12/13/2009 17:22'! execute self model do: [ :reference | self cacheRepository storeVersion: reference version ] displayingProgress: 'Fetching Versions'! ! !GoferLoad commentStamp: 'TorstenBergmann 2/5/2014 09:31'! Loading for specific packages using Gofer! !GoferLoad methodsFor: 'accessing' stamp: 'StephaneDucasse 12/30/2012 20:29'! versions ^ model versions! ! !GoferLoad methodsFor: 'private' stamp: 'lr 12/18/2009 12:55'! updateCategories "This method makes sure that the categories are ordered in load-order and as specified in the packages." | categories | categories := OrderedCollection new. self versions do: [ :version | version snapshot definitions do: [ :definition | definition isOrganizationDefinition ifTrue: [ definition categories do: [ :category | (categories includes: category) ifFalse: [ categories addLast: category ] ] ] ] ]. (MCOrganizationDefinition categories: categories) postloadOver: nil! ! !GoferLoad methodsFor: 'running' stamp: 'StephaneDucasse 12/30/2012 20:28'! execute self model hasVersions ifTrue: [ self model load ]. self updateRepositories. self updateCategories! ! !GoferLoad methodsFor: 'private' stamp: 'lr 12/18/2009 12:55'! updateRepositories "This code makes sure that all packages have a repository assigned, including the dependencies." self versions do: [ :version | gofer repositories do: [ :repository | version workingCopy repositoryGroup addRepository: repository ] ]! ! !GoferLoad methodsFor: 'private' stamp: 'lr 9/3/2009 11:00'! defaultModel ^ MCVersionLoader new! ! !GoferLoad methodsFor: 'initialization' stamp: 'TestRunner 12/13/2009 14:49'! initializeOn: aGofer super initializeOn: aGofer. aGofer resolved do: [ :each | self addResolved: each ] displayingProgress: 'Loading Versions'! ! !GoferLoad methodsFor: 'private' stamp: 'MonkeyGalactikalIntegrator 12/16/2011 16:49'! addResolved: aResolvedReference | version reference | version := aResolvedReference version. (self versions includes: version) ifTrue: [ ^ self ]. self versions addLast: version. version dependencies do: [ :dependency | self addResolved: ((GoferVersionReference name: dependency versionInfo name) resolveWith: self gofer) ]! ! !GoferLocalChanges commentStamp: 'TorstenBergmann 2/5/2014 09:33'! Handling local changes! !GoferLocalChanges methodsFor: 'queries' stamp: 'lr 12/12/2009 13:01'! targetSnapshotOf: aReference ^ aReference workingCopy package snapshot! ! !GoferLocalChanges methodsFor: 'queries' stamp: 'TestRunner 12/13/2009 18:02'! sourceSnapshotOf: aReference | ancestors reference | ancestors := aReference workingCopy ancestry ancestors. ancestors isEmpty ifTrue: [ ^ MCSnapshot new ]. reference := GoferVersionReference name: ancestors first name. ^ (reference resolveWith: self gofer) version snapshot! ! !GoferMerge commentStamp: 'TorstenBergmann 2/5/2014 09:36'! Merge work! !GoferMerge methodsFor: 'private' stamp: 'lr 8/19/2009 14:01'! defaultModel ^ MCVersionMerger new! ! !GoferMerge methodsFor: 'running' stamp: 'CamilloBruni 9/15/2013 17:50'! execute [ self model merge ] on: MCMergeResolutionRequest do: [ :request | request autoMerge ]. self gofer cleanup! ! !GoferMetacelloLoad commentStamp: ''! I am a Gofer Operation that extracts a metacello configuration from the current repository and loads the given version.! !GoferMetacelloLoad methodsFor: 'accessing' stamp: 'CamilloBruni 9/12/2013 11:04'! configurationReference ^ gofer references detect: [ :ref | ref isConfigurationReference ] ifNone: [ gofer configuration. ^ self configurationReference ].! ! !GoferMetacelloLoad methodsFor: 'accessing' stamp: 'CamilloBruni 9/12/2013 11:09'! metacelloVersion | configuration | configuration := self configuration project. self version ifNil: [ ^ configuration stableVersion ]. "Now let's wrap Metcaello's strange behaviors of distinguishing strings and symbols" [ "First we try to load the latest version for a given version string" ^ (configuration latestVersion: self version) ifNil: [ "If that doesn't work we use the default version lookup to find a version with the given name" configuration version: self version ] ] on: MetacelloVersionDoesNotExistError do: [ :error | ^ self version = 'last' ifTrue: [ "manual fallback since there is no symbolic name for lastVersion" configuration lastVersion ] ifFalse: [ "symbols and strings are not equal in Meteacello..." configuration version: self version asSymbol ]].! ! !GoferMetacelloLoad methodsFor: 'accessing' stamp: 'CamilloBruni 9/12/2013 11:05'! configuration ^ self configurationReference project! ! !GoferMetacelloLoad methodsFor: 'running' stamp: 'CamilloBruni 9/18/2012 18:53'! execute super execute. self loadConfiguration.! ! !GoferMetacelloLoad methodsFor: 'running' stamp: 'CamilloBruni 9/12/2013 10:58'! loadConfiguration self metacelloVersion load! ! !GoferMetacelloLoad methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 18:54'! version ^ version! ! !GoferMetacelloLoad methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 19:13'! version: aVersionStringOrSymbol "A version identifiery see MetacelloProject>>#version:" version := aVersionStringOrSymbol! ! !GoferOperation commentStamp: 'TorstenBergmann 2/5/2014 09:30'! Common superclass of Gofer operations! !GoferOperation methodsFor: 'accessing' stamp: 'lr 10/3/2009 11:38'! gofer "Answer the Gofer instance that triggered this operation." ^ gofer! ! !GoferOperation methodsFor: 'initialization' stamp: 'lr 8/19/2009 14:01'! initialize model := self defaultModel! ! !GoferOperation methodsFor: 'accessing' stamp: 'lr 8/20/2009 10:13'! model "Answer the Monticello model of this operation." ^ model! ! !GoferOperation methodsFor: 'private' stamp: 'lr 8/19/2009 14:01'! defaultModel ^ nil! ! !GoferOperation methodsFor: 'initialization' stamp: 'TestRunner 12/12/2009 11:09'! initializeOn: aGofer gofer := aGofer. self initialize! ! !GoferOperation methodsFor: 'running' stamp: 'lr 8/17/2009 14:40'! execute "Execute the receiving action." self subclassResponsibility! ! !GoferOperation class methodsFor: 'instance creation' stamp: 'lr 8/20/2009 12:01'! on: aGofer ^ self basicNew initializeOn: aGofer! ! !GoferOperation class methodsFor: 'instance creation' stamp: 'TestRunner 12/12/2009 11:09'! new self error: 'Gofer operations can only work on Gofer instances.'! ! !GoferOperationTest commentStamp: 'TorstenBergmann 2/5/2014 09:36'! SUnit tests for Gofer operations! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testReinitialize | class | gofer package: 'GoferFoo'; load. class := Smalltalk classNamed: #GoferFoo. class addClassVarNamed: #InstanceSide; addClassVarNamed: #ClassSide. class compile: 'initialize InstanceSide := true'. class class compile: 'initialize ClassSide := true'. self assert: (class classPool at: #InstanceSide) isNil. self assert: (class classPool at: #ClassSide) isNil. gofer reinitialize. self assert: (class classPool at: #InstanceSide) isNil. self assert: (class classPool at: #ClassSide)! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testLocalChanges | changes | gofer package: 'GoferBar'; load. (Smalltalk globals classNamed: #GoferBar) compile: 'foo'. changes := gofer localChanges. self assert: changes operations size = 1! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testMerge | initial | initial := gofer copy. initial version: 'GoferBar-jf.1'; load. gofer package: 'GoferBar'; load. (Smalltalk globals classNamed: #GoferBar) compile: 'foo'. [ gofer merge ] on: ProvideAnswerNotification do: [ :e | e resume: true ]. self assert: (self hasClass: #GoferBar selector: #foo)! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPush | repository | gofer := Gofer new. gofer disablePackageCache. gofer repository: (repository := MCDictionaryRepository new). gofer package: 'GoferFoo'. gofer push! ! !GoferOperationTest methodsFor: 'running' stamp: 'CamilloBruni 10/21/2012 12:44'! tearDown (self hasPackage: 'GoferFoo') ifTrue: [ Gofer new package: 'GoferFoo'; unload ]. (self hasPackage: 'GoferBar') ifTrue: [ Gofer new package: 'GoferBar'; unload ]. (self hasPackage: 'ConfigurationOfGoferFoo') ifTrue: [ Gofer new package: 'ConfigurationOfGoferFoo'; unload ]! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testCleanup | class | gofer package: 'GoferFoo'; load. class := Smalltalk globals classNamed: #GoferFoo. Smalltalk globals organization addCategory: #'GoferFoo-Empty'. class organization addCategory: #empty. class class organization addCategory: #empty. gofer cleanup. self deny: (Smalltalk organization categories includes: #'GoferFoo-Empty'). self deny: (class organization categories includes: #'GoferFoo-Empty'). self deny: (class class organization categories includes: #'GoferFoo-Empty')! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testLoad gofer version: 'GoferFoo-lr.1'. gofer load. self assert: (self hasVersion: 'GoferFoo-lr.1'). self assert: (self hasClass: #GoferFoo)! ! !GoferOperationTest methodsFor: 'running' stamp: 'EstebanLorenzano 9/12/2012 16:44'! runCase ^ "SystemAnnouncer uniqueInstance suspendAllWhile: [ "super runCase "]"! ! !GoferOperationTest methodsFor: 'utilities' stamp: 'lr 3/14/2010 21:13'! hasClass: aSymbol selector: aSelector ^ (Smalltalk globals classNamed: aSymbol) includesSelector: aSelector! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testRecompile gofer package: 'Gofer-Core'. gofer recompile! ! !GoferOperationTest methodsFor: 'utilities' stamp: 'StephaneDucasse 6/2/2012 20:31'! allManagers ^ MCWorkingCopy allManagers ! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testRemoteChanges | changes | gofer package: 'GoferBar'; load. (Smalltalk globals classNamed: #GoferBar) compile: 'foo'. changes := gofer remoteChanges. self assert: changes operations size = 1! ! !GoferOperationTest methodsFor: 'running' stamp: 'lr 12/13/2009 17:49'! setUp super setUp. gofer repository: self monticelloRepository! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testUpdate | initial | initial := gofer copy. initial version: 'GoferFoo-lr.1'; load. gofer package: 'GoferFoo'. gofer update. self assert: (self hasVersion: 'GoferFoo-lr.4')! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testCommit | repository | repository := MCDictionaryRepository new. gofer package: 'GoferFoo'; load. gofer := Gofer new. gofer disablePackageCache. gofer repository: repository. gofer package: 'GoferFoo'. gofer commit: 'A test commit'. self assert: repository allVersionInfos size = 1! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testUnload gofer package: 'GoferFoo'; load. gofer unload. self deny: (self hasPackage: 'GoferFoo'). self deny: (self hasClass: #GoferFoo)! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testRevert gofer package: 'GoferFoo'; package: 'GoferBar'; load. (Smalltalk globals classNamed: #GoferBar) category: 'GoferFoo'. gofer revert. self assert: (Smalltalk globals classNamed: #GoferFoo) category asSymbol = #GoferFoo. self assert: (Smalltalk globals classNamed: #GoferBar) category asSymbol = #GoferBar! ! !GoferOperationTest methodsFor: 'utilities' stamp: 'lr 3/14/2010 21:13'! hasClass: aSymbol ^ Smalltalk globals includesKey: aSymbol! ! !GoferOperationTest methodsFor: 'utilities' stamp: 'GabrielOmarCotelli 12/3/2013 17:21'! hasVersion: aString ^ self allManagers anySatisfy: [ :version | version ancestry ancestorString = aString ]! ! !GoferOperationTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testFetch gofer package: 'GoferFoo'. gofer fetch! ! !GoferOperationTest methodsFor: 'utilities' stamp: 'GabrielOmarCotelli 12/3/2013 17:20'! hasPackage: aString ^ self allManagers anySatisfy: [ :package | package packageName = aString ]! ! !GoferPackageReference commentStamp: 'lr 12/9/2009 22:47'! A GoferPackageReference refers to the latest version of a Monticello package.! !GoferPackageReference methodsFor: 'private' stamp: 'lr 1/21/2010 00:16'! matches: aResolvedReference ^ self packageName = aResolvedReference packageName! ! !GoferPackageReference methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:12'! packageName ^ name! ! !GoferPackageReference methodsFor: '*metacello-mc' stamp: 'dkh 6/30/2012 07:52'! metacelloPackageNameWithBranch "answer array with package name and package name with branch name .. no branch name" ^ {(self packageName). (self packageName)}! ! !GoferPush commentStamp: 'TorstenBergmann 2/5/2014 09:32'! Push a version! !GoferPush methodsFor: 'private' stamp: 'lr 11/30/2009 13:46'! defaultModel ^ OrderedCollection new! ! !GoferPush methodsFor: 'initialization' stamp: 'TestRunner 12/13/2009 20:08'! initializeOn: aGofer super initializeOn: aGofer. self gofer references do: [ :reference | cacheReferences do: [ :resolved | (reference matches: resolved) ifTrue: [ self gofer repositories do: [ :repository | ((self gofer allResolvedIn: repository) includes: resolved) ifFalse: [ self model add: resolved -> repository ] ] ] ] ]! ! !GoferPush methodsFor: 'running' stamp: 'lr 12/13/2009 17:23'! execute self model do: [ :assocation | assocation value storeVersion: assocation key version ] displayingProgress: 'Pushing Versions'! ! !GoferRecompile commentStamp: 'TorstenBergmann 2/5/2014 09:36'! Recompile! !GoferRecompile methodsFor: 'running' stamp: 'EstebanLorenzano 9/12/2012 13:33'! execute: aWorkingCopy aWorkingCopy packageSet methods do: [ :each | each actualClass recompile: each selector ]! ! !GoferRecompile methodsFor: 'running' stamp: 'lr 12/13/2009 19:12'! execute self workingCopies do: [ :each | self execute: each ]! ! !GoferReference commentStamp: 'lr 1/30/2010 14:38'! A GoferReference is an abstract superclass for various kinds of references to Monticello packages and versions.! !GoferReference methodsFor: 'querying' stamp: 'lr 12/13/2009 17:20'! resolveAllWith: aGofer "Answer a sorted collection of all resolved references within aGofer." ^ aGofer allResolved select: [ :each | self matches: each ]! ! !GoferReference methodsFor: 'comparing' stamp: 'lr 12/12/2009 13:33'! hash ^ self name hash! ! !GoferReference methodsFor: 'comparing' stamp: 'lr 12/12/2009 13:33'! = aReference ^ self class = aReference class and: [ self name = aReference name ]! ! !GoferReference methodsFor: 'querying' stamp: 'CamilloBruni 9/5/2012 17:26'! workingCopyIfAbsent: aBlock "Answer a working copy or throw an error if not present." ^ MCWorkingCopy allManagers detect: [ :each | self packageName = each packageName ] ifNone: aBlock! ! !GoferReference methodsFor: 'printing' stamp: 'lr 12/11/2009 22:02'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' name: '; print: self name! ! !GoferReference methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:09'! packageName "Answer the package name." self subclassResponsibility! ! !GoferReference methodsFor: 'initialization' stamp: 'lr 12/9/2009 22:57'! initializeName: aString name := aString! ! !GoferReference methodsFor: 'querying' stamp: 'CamilloBruni 9/5/2012 17:26'! workingCopy "Answer a working copy or throw an error if not present." ^ self workingCopyIfAbsent: [ self error: 'Working copy for ' , self name , ' not found' ]! ! !GoferReference methodsFor: 'private' stamp: 'lr 1/21/2010 00:16'! matches: aResolvedReference "Answer true if the receiver matches aResolvedReference." self subclassResponsibility! ! !GoferReference methodsFor: 'querying' stamp: 'lr 12/13/2009 17:20'! resolveWith: aGofer "Answer a single resolved reference with aGofer configuration, throw an error if the version can't be found.'" | references | references := self resolveAllWith: aGofer. ^ references isEmpty ifTrue: [ self error: 'Unable to resolve ' , self name ] ifFalse: [ references last ]! ! !GoferReference methodsFor: 'accessing' stamp: 'lr 12/11/2009 22:02'! name "Answer the name of this reference." ^ name! ! !GoferReference methodsFor: 'testing' stamp: 'CamilloBruni 9/18/2012 19:05'! isConfigurationReference ^ false! ! !GoferReference class methodsFor: 'instance creation' stamp: 'lr 12/9/2009 22:42'! name: aString ^ self basicNew initializeName: aString! ! !GoferReference class methodsFor: 'instance creation' stamp: 'lr 12/9/2009 22:42'! new self error: 'Use #name: to initialize the receiver.'! ! !GoferReferenceTest commentStamp: 'TorstenBergmann 2/5/2014 09:37'! SUnit tests for GoferReference and subclasses! !GoferReferenceTest methodsFor: 'testing' stamp: 'lr 2/6/2011 18:03'! testBranchAfterAuthorIsNotABranch | queryReference | queryReference := GoferVersionReference name: 'Seaside-Core-jf.configcleanup.3'. self assert: queryReference packageName = 'Seaside-Core'. self assert: queryReference author = 'jf.configcleanup'. self assert: queryReference branch isEmpty. self assert: queryReference versionNumber = 3. queryReference := GoferVersionReference name: 'Seaside-Core-lr.configcleanup.extraspeedup.69'. self assert: queryReference packageName = 'Seaside-Core'. self assert: queryReference author = 'lr.configcleanup.extraspeedup'. self assert: queryReference branch isEmpty. self assert: queryReference versionNumber = 69. queryReference := GoferVersionReference name: 'Seaside-Core-lr.configcleanup42.extraspeedup.69'. self assert: queryReference packageName = 'Seaside-Core'. self assert: queryReference author = 'lr.configcleanup42.extraspeedup'. self assert: queryReference branch isEmpty. self assert: queryReference versionNumber = 69 ! ! !GoferReferenceTest methodsFor: 'testing' stamp: 'lr 2/6/2011 17:47'! testVersionShouldParseComplexName | queryReference | queryReference := GoferVersionReference name: 'Seaside2.8b5'. self assert: queryReference packageName = 'Seaside2'. self assert: queryReference author isEmpty. self assert: queryReference branch = '8b5'. self assert: queryReference versionNumber = 0. queryReference := GoferVersionReference name: 'Seaside2.8b5-avi.1'. self assert: queryReference packageName = 'Seaside2'. self assert: queryReference author = 'avi'. self assert: queryReference branch = '8b5'. self assert: queryReference versionNumber = 1. queryReference := GoferVersionReference name: 'Seaside-Core-pmm.2'. self assert: queryReference packageName = 'Seaside-Core'. self assert: queryReference author = 'pmm'. self assert: queryReference branch isEmpty. self assert: queryReference versionNumber = 2. queryReference := GoferVersionReference name: 'Seaside-Core.configcleanup-jf.3'. self assert: queryReference packageName = 'Seaside-Core'. self assert: queryReference author = 'jf'. self assert: queryReference branch = 'configcleanup'. self assert: queryReference versionNumber = 3. queryReference := GoferVersionReference name: 'Seaside-Core.configcleanup.extraspeedup-lr.69'. self assert: queryReference packageName = 'Seaside-Core'. self assert: queryReference author = 'lr'. self assert: queryReference branch = 'configcleanup.extraspeedup'. self assert: queryReference versionNumber = 69. queryReference := GoferVersionReference name: 'Seaside-Core.configcleanup42.extraspeedup-lr.69'. self assert: queryReference packageName = 'Seaside-Core'. self assert: queryReference author = 'lr'. self assert: queryReference branch = 'configcleanup42.extraspeedup'. self assert: queryReference versionNumber = 69 ! ! !GoferReferenceTest methodsFor: 'testing-reference' stamp: 'TestRunner 12/13/2009 17:30'! testContraintShouldFindLatestVersion | constraintReference reference | constraintReference := GoferConstraintReference name: 'GoferBar' constraint: [ :ref | true ]. self assert: (constraintReference resolveAllWith: gofer) size = 4. reference := constraintReference resolveWith: gofer. self assert: reference packageName = 'GoferBar'. self assert: reference author = 'lr'. self assert: reference branch isEmpty. self assert: reference versionNumber = 1. self assert: reference repository = self monticelloRepository. constraintReference := GoferConstraintReference name: 'GoferBar' constraint: [ :ref | ref branch = 'branch' ]. self assert: (constraintReference resolveAllWith: gofer) size = 2. reference := constraintReference resolveWith: gofer. self assert: reference packageName = 'GoferBar'. self assert: reference author = 'lr'. self assert: reference branch = 'branch'. self assert: reference versionNumber = 2. self assert: reference repository = self monticelloRepository. constraintReference := GoferConstraintReference name: 'GoferBar' constraint: [ :ref | ref author = 'jf' ]. self assert: (constraintReference resolveAllWith: gofer) size = 1. reference := constraintReference resolveWith: gofer. self assert: reference packageName = 'GoferBar'. self assert: reference author = 'jf'. self assert: reference branch isEmpty. self assert: reference versionNumber = 1. self assert: reference repository = self monticelloRepository. constraintReference := GoferConstraintReference name: 'GoferBar' constraint: [ :ref | false ]. self assert: (constraintReference resolveAllWith: gofer) isEmpty. self should: [ constraintReference resolveWith: gofer ] raise: Error.! ! !GoferReferenceTest methodsFor: 'testing-reference' stamp: 'lr 12/13/2009 17:29'! testVersionShouldFindLatestVersion | versionReference reference | versionReference := GoferVersionReference name: 'GoferFoo-lr.2'. reference := versionReference resolveWith: gofer. self assert: reference packageName = 'GoferFoo'. self assert: reference author = 'lr'. self assert: reference versionNumber = 2. self assert: reference branch isEmpty. self assert: reference repository = self monticelloRepository. versionReference := GoferVersionReference name: 'GoferFoo-lr.3'. self should: [ versionReference resolveWith: gofer ] raise: Error! ! !GoferReferenceTest methodsFor: 'testing-working' stamp: 'lr 1/5/2010 11:08'! testResolvedShouldFindWorkingCopy | versionReference workingCopy | versionReference := GoferResolvedReference name: 'Gofer-Core-lr.18' repository: self monticelloRepository. workingCopy := versionReference workingCopy. self assert: workingCopy packageName = 'Gofer-Core'! ! !GoferReferenceTest methodsFor: 'testing-reference' stamp: 'lr 12/13/2009 17:29'! testPackageShouldFindLatestVersion | packageReference reference | packageReference := GoferPackageReference name: 'GoferFoo'. reference := packageReference resolveWith: gofer. self assert: reference packageName = 'GoferFoo'. self assert: reference author = 'lr'. self assert: reference branch isEmpty. self assert: reference versionNumber = 4. self assert: reference repository = self monticelloRepository! ! !GoferReferenceTest methodsFor: 'testing' stamp: 'lr 12/13/2009 17:27'! testLoadableShouldSortCorrectly | sorted | sorted := self versionReferences collect: [ :each | each resolveWith: gofer ]. sorted withIndexDo: [ :first :firstIndex | sorted withIndexDo: [ :second :secondIndex | firstIndex <= secondIndex ifTrue: [ self assert: first <= second ]. firstIndex >= secondIndex ifTrue: [ self assert: second <= first ] ] ]! ! !GoferReferenceTest methodsFor: 'testing-working' stamp: 'lr 1/5/2010 11:08'! testVersionShouldFindWorkingCopy | versionReference workingCopy | versionReference := GoferVersionReference name: 'Gofer-Core-lr.18'. workingCopy := versionReference workingCopy. self assert: workingCopy packageName = 'Gofer-Core'! ! !GoferReferenceTest methodsFor: 'testing-reference' stamp: 'lr 12/13/2009 17:28'! testResolvedShouldFindLatestVersion | versionReference reference | versionReference := GoferResolvedReference name: 'GoferFoo-lr.2' repository: self monticelloRepository. reference := versionReference resolveWith: gofer. self assert: reference packageName = 'GoferFoo'. self assert: reference author = 'lr'. self assert: reference branch isEmpty. self assert: reference versionNumber = 2. self assert: reference repository = self monticelloRepository! ! !GoferReferenceTest methodsFor: 'testing-working' stamp: 'lr 1/5/2010 11:03'! testPackageShouldFindWorkingCopy | packageReference workingCopy | packageReference := GoferPackageReference name: 'Gofer-Core'. workingCopy := packageReference workingCopy. self assert: workingCopy packageName = 'Gofer-Core'! ! !GoferReferenceTest methodsFor: 'running' stamp: 'lr 12/13/2009 17:53'! setUp super setUp. gofer repository: self monticelloRepository! ! !GoferReferenceTest methodsFor: 'testing-working' stamp: 'lr 1/5/2010 11:06'! testContraintShouldFindWorkingCopy | constraintReference workingCopy | constraintReference := GoferConstraintReference name: 'Gofer-Core' constraint: [ :reference | false ]. workingCopy := constraintReference workingCopy. self assert: workingCopy packageName = 'Gofer-Core'! ! !GoferReinitialize commentStamp: 'LaurentLaffont 2/23/2011 20:22'! I'm a private and internal class to Gofer. I'm a command used to call the class side initializers on all package code.! !GoferReinitialize methodsFor: 'running' stamp: 'EstebanLorenzano 9/12/2012 13:33'! execute: aWorkingCopy aWorkingCopy packageSet methods do: [ :each | (each classIsMeta and: [ each selector = #initialize ]) ifTrue: [ each actualClass theNonMetaClass initialize ] ]! ! !GoferReinitialize methodsFor: 'running' stamp: 'lr 12/30/2009 11:14'! execute self workingCopies do: [ :each | self execute: each ]! ! !GoferRemoteChanges commentStamp: 'TorstenBergmann 2/5/2014 09:33'! Handling remote changes! !GoferRemoteChanges methodsFor: 'private' stamp: 'TestRunner 12/13/2009 19:27'! targetSnapshotOf: aReference ^ (aReference resolveWith: self gofer) version snapshot! ! !GoferRemoteChanges methodsFor: 'queries' stamp: 'lr 12/12/2009 13:00'! sourceSnapshotOf: aReference ^ aReference workingCopy package snapshot! ! !GoferRepositoryError commentStamp: 'lr 1/30/2010 14:39'! A GoferRepositoryError is the error thrown when a repository cannot be accessed.! !GoferRepositoryError methodsFor: 'accessing' stamp: 'lr 12/9/2009 19:14'! repository ^ repository! ! !GoferRepositoryError methodsFor: 'accessing' stamp: 'lr 12/9/2009 19:14'! repository: aRepository repository := aRepository! ! !GoferRepositoryError methodsFor: 'private' stamp: 'lr 12/9/2009 22:32'! isResumable ^ true! ! !GoferRepositoryError class methodsFor: 'instance creation' stamp: 'lr 12/9/2009 19:15'! signal: aString repository: aRepository ^ self new repository: aRepository; signal: aString! ! !GoferResolvedReference commentStamp: 'lr 1/30/2010 14:38'! A GoferVersionReference refers to a specific version of a Monticello package in a particular repository. This class is the only one that can actually load the version, because it is the only one knowing where to find it.! !GoferResolvedReference methodsFor: 'accessing' stamp: 'lr 12/11/2009 22:33'! repository "Answer the repository of the receiver." ^ repository! ! !GoferResolvedReference methodsFor: 'initialization' stamp: 'lr 12/9/2009 22:55'! initializeName: aString repository: aRepository self initializeName: aString. repository := aRepository! ! !GoferResolvedReference methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:22'! version "Answer a Monticello version of the receiver." ^ self repository goferVersionFrom: self! ! !GoferResolvedReference methodsFor: 'actions' stamp: 'CamilloBruni 12/4/2012 19:29'! merge "Merge-in the changes of this refence" Gofer new repository: self repository; package: package; version: self name; merge! ! !GoferResolvedReference methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! asMetacelloCachingResolvedReference ^MetacelloCachingGoferResolvedReference name: self name repository: self repository! ! !GoferResolvedReference methodsFor: 'comparing' stamp: 'lr 3/5/2010 07:19'! <= aResolvedReference "Sort versions according to: 1. package name 2. branch name, list versions without branch last 3. version number 4. author name 5. repository priority" self packageName = aResolvedReference packageName ifFalse: [ ^ self packageName <= aResolvedReference packageName ]. self branch = aResolvedReference branch ifFalse: [ ^ (self branch isEmpty or: [ aResolvedReference branch isEmpty ]) ifTrue: [ self branch size > aResolvedReference branch size ] ifFalse: [ self branch <= aResolvedReference branch ] ]. self versionNumber = aResolvedReference versionNumber ifFalse: [ ^ self versionNumber <= aResolvedReference versionNumber ]. self author = aResolvedReference author ifFalse: [ ^ self author <= aResolvedReference author ]. self repository goferPriority = aResolvedReference repository goferPriority ifFalse: [ ^ self repository goferPriority <= aResolvedReference repository goferPriority ]. ^ true! ! !GoferResolvedReference class methodsFor: 'instance creation' stamp: 'lr 12/9/2009 22:55'! name: aString repository: aRepository ^ self basicNew initializeName: aString repository: aRepository! ! !GoferResource commentStamp: 'TorstenBergmann 2/5/2014 09:30'! SUnit test resource for Gofer testing! !GoferResource methodsFor: 'running' stamp: 'lr 12/13/2009 17:25'! setUpMonticelloRepository "This method builds a fake repository with the version references from #buildReferences." monticelloRepository := MCDictionaryRepository new. versionReferences do: [ :reference | monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)) with: (MCClassDefinition name: reference packageName asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: ''))) dependencies: #()) ]! ! !GoferResource methodsFor: 'accessing' stamp: 'lr 12/12/2009 10:37'! monticelloRepository ^ monticelloRepository! ! !GoferResource methodsFor: 'accessing' stamp: 'lr 12/12/2009 10:37'! versionReferences ^ versionReferences! ! !GoferResource methodsFor: 'running' stamp: 'lr 12/13/2009 16:38'! setUp super setUp. self setUpVersionReferences; setUpMonticelloRepository! ! !GoferResource methodsFor: 'running' stamp: 'lr 2/6/2011 17:30'! setUpVersionReferences "This method answers a set of Gofer references in the order they should be sorted. It includes two different packages (Gofer-Foo, Gofer-Bar), linear series of packages (Gofer-Foo-lr.1, Gofer-Foo-lr.2, Gofer-Foo-lr.4), packages with a branch (Gofer-Bar.branch-lr.1,Gofer.branch-Bar-lr.2), and packages with the same version but different authors (Gofer-Bar-jf.1, Gofer-Bar-lr.1)." versionReferences := OrderedCollection new. versionReferences add: (GoferVersionReference name: 'GoferBar.branch-lr.1'); add: (GoferVersionReference name: 'GoferBar.branch-lr.2'); add: (GoferVersionReference name: 'GoferBar-jf.1'); add: (GoferVersionReference name: 'GoferBar-lr.1'); add: (GoferVersionReference name: 'GoferFoo-lr.1'); add: (GoferVersionReference name: 'GoferFoo-lr.2'); add: (GoferVersionReference name: 'GoferFoo-lr.4')! ! !GoferRevert commentStamp: 'TorstenBergmann 2/5/2014 09:36'! Revert work! !GoferRevert methodsFor: 'private' stamp: 'TestRunner 12/13/2009 18:09'! referenceFor: aReference | ancestors reference | ancestors := aReference workingCopy ancestry ancestors. ancestors isEmpty ifTrue: [ ^ MCSnapshot new ]. ^ GoferVersionReference name: ancestors first name! ! !GoferRevert methodsFor: 'running' stamp: 'lr 9/19/2009 13:15'! execute self workingCopies do: [ :each | each modified: false ]. super execute! ! !GoferSynchronize commentStamp: 'TorstenBergmann 2/5/2014 09:31'! Synchronize repos ! !GoferSynchronize methodsFor: 'accessing' stamp: 'SeanDeNigris 7/17/2012 15:49'! cacheRepository ^ MCCacheRepository uniqueInstance! ! !GoferSynchronize methodsFor: 'initialization' stamp: 'TestRunner 12/13/2009 19:54'! initializeOn: aGofer super initializeOn: aGofer disablePackageCache. MCFileBasedRepository flushAllCaches. cacheReferences := self gofer allResolvedIn: self cacheRepository! ! !GoferTest commentStamp: 'TorstenBergmann 2/5/2014 09:30'! SUnit tests for Gofer! !GoferTest methodsFor: 'accessing' stamp: 'lr 12/12/2009 10:44'! monticelloRepository ^ GoferResource current monticelloRepository! ! !GoferTest methodsFor: 'running' stamp: 'lr 12/13/2009 17:38'! setUp super setUp. gofer := Gofer new. gofer disablePackageCache! ! !GoferTest methodsFor: 'accessing' stamp: 'lr 12/12/2009 10:46'! versionReferences ^ GoferResource current versionReferences! ! !GoferTest class methodsFor: 'accessing' stamp: 'lr 12/11/2009 23:54'! resources ^ Array with: GoferResource! ! !GoferTest class methodsFor: 'testing' stamp: 'JorgeRessia 3/16/2010 20:23'! isUnitTest ^false! ! !GoferTest class methodsFor: 'testing' stamp: 'lr 10/1/2009 22:00'! isAbstract ^ self name = #GoferTest! ! !GoferTest class methodsFor: 'accessing' stamp: 'lr 1/5/2010 11:06'! packageNamesUnderTest ^ #('Gofer-Core')! ! !GoferUnload commentStamp: 'TorstenBergmann 2/5/2014 09:36'! Unload! !GoferUnload methodsFor: 'unloading' stamp: 'EstebanLorenzano 9/12/2012 13:33'! unloadClasses: aWorkingCopy aWorkingCopy packageSet methods do: [ :each | (each classIsMeta and: [ each selector = #unload ]) ifTrue: [ each actualClass theNonMetaClass unload ] ]! ! !GoferUnload methodsFor: 'unregistering' stamp: 'lr 8/19/2009 13:50'! unregisterRepositories: aWorkingCopy aWorkingCopy repositoryGroup repositories allButFirst do: [ :repository | MCWorkingCopy allManagers do: [ :copy | (copy repositoryGroup includes: repository) ifTrue: [ ^ self ] ]. MCRepositoryGroup default removeRepository: repository ]! ! !GoferUnload methodsFor: 'unregistering' stamp: 'EstebanLorenzano 9/12/2012 13:34'! unregister: aWorkingCopy self unregisterWorkingCopy: aWorkingCopy. self unregisterRepositories: aWorkingCopy. self unregisterPackageSet: aWorkingCopy. self unregisterPackageInfo: aWorkingCopy! ! !GoferUnload methodsFor: 'running' stamp: 'lr 10/3/2009 11:45'! execute self workingCopies do: [ :copy | self unload: copy ]. self model load. self gofer cleanup. self workingCopies do: [ :copy | self unregister: copy ]! ! !GoferUnload methodsFor: 'private' stamp: 'lr 3/14/2010 21:13'! defaultModel ^ (Smalltalk globals at: #MCMultiPackageLoader ifAbsent: [ MCPackageLoader ]) new! ! !GoferUnload methodsFor: 'unloading' stamp: 'lr 10/3/2009 11:46'! unload: aWorkingCopy self unloadClasses: aWorkingCopy. self unloadPackage: aWorkingCopy ! ! !GoferUnload methodsFor: 'unloading' stamp: 'lr 8/19/2009 14:00'! unloadPackage: aWorkingCopy self model unloadPackage: aWorkingCopy package! ! !GoferUnload methodsFor: 'unregistering' stamp: 'lr 8/20/2009 11:54'! unregisterWorkingCopy: aWorkingCopy aWorkingCopy unregister! ! !GoferUnload methodsFor: 'unregistering' stamp: 'EstebanLorenzano 9/12/2012 13:34'! unregisterPackageSet: aWorkingCopy aWorkingCopy packageSet unregister! ! !GoferUnload methodsFor: 'unregistering' stamp: 'EstebanLorenzano 9/14/2012 11:31'! unregisterPackageInfo: aWorkingCopy PackageOrganizer default unregisterPackageNamed: aWorkingCopy packageName! ! !GoferUpdate commentStamp: 'TorstenBergmann 2/5/2014 09:36'! Update! !GoferUpdate methodsFor: 'private' stamp: 'lr 9/18/2009 18:13'! defaultModel ^ MCVersionLoader new! ! !GoferUpdate methodsFor: 'private' stamp: 'TestRunner 12/13/2009 18:09'! addReference: aReference super addReference: aReference. self model addVersion: ((self referenceFor: aReference) resolveWith: self gofer) version! ! !GoferUpdate methodsFor: 'private' stamp: 'TestRunner 12/13/2009 18:08'! referenceFor: aReference ^ aReference! ! !GoferUpdate methodsFor: 'running' stamp: 'StephaneDucasse 12/30/2012 20:28'! execute self model hasVersions ifTrue: [ self model load ]. self gofer cleanup! ! !GoferVersionReference commentStamp: 'lr 12/9/2009 22:50'! A GoferVersionReference refers to a specific version of a Monticello package.! !GoferVersionReference methodsFor: '*metacello-mc' stamp: 'dkh 07/19/2013 15:25'! compare: aLoadableReference using: aComparisonOperator "Compare versions using . package names #= then compare based upon version number Branches and Author names are used in the case of a version number tie, because we need to avoid seesaw loading." self packageName = aLoadableReference packageName ifFalse: [ ^false ]. self versionNumber = aLoadableReference versionNumber ifFalse: [ ^ self versionNumber perform: aComparisonOperator with: aLoadableReference versionNumber ]. self branch = aLoadableReference branch ifFalse: [ ^ self branch perform: aComparisonOperator with: aLoadableReference branch ]. ^ self author perform: aComparisonOperator with: aLoadableReference author! ! !GoferVersionReference methodsFor: 'accessing' stamp: 'lr 12/11/2009 22:22'! author "Answer the author of the receiver." ^ author! ! !GoferVersionReference methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:12'! packageName "Answer the package of the receiver." ^ package! ! !GoferVersionReference methodsFor: 'initialization' stamp: 'lr 12/11/2009 22:17'! initializeName: aString super initializeName: aString. self parseName: aString! ! !GoferVersionReference methodsFor: 'initialization' stamp: 'lr 2/6/2011 18:01'! parseName: aString | basicName | basicName := aString last isDigit ifTrue: [ aString ] ifFalse: [ (aString copyUpToLast: $.) copyUpTo: $( ]. package := basicName copyUpToLast: $-. (package includes: $.) ifFalse: [ branch := '' ] ifTrue: [ branch := package copyAfter: $.. package := package copyUpTo: $. ]. author := (basicName copyAfterLast: $-) copyUpToLast: $.. versionNumber := (basicName copyAfterLast: $-) copyAfterLast: $.. (versionNumber notEmpty and: [ versionNumber allSatisfy: [ :each | each isDigit ] ]) ifTrue: [ versionNumber := versionNumber asInteger ] ifFalse: [ versionNumber := 0 ]! ! !GoferVersionReference methodsFor: 'private' stamp: 'lr 1/21/2010 00:17'! matches: aResolvedReference ^ self name = aResolvedReference name! ! !GoferVersionReference methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:20'! versionNumber "Answer the version of the receiver." ^ versionNumber! ! !GoferVersionReference methodsFor: 'accessing' stamp: 'lr 12/11/2009 22:23'! branch "Answer the branch of the receiver." ^ branch! ! !GoferVersionReference methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! metacelloPackageNameWithBranch "answer array with package name and package name with branch name" self branch isEmpty ifTrue: [ ^ {(self packageName). (self packageName)} ]. ^ {(self packageName). (self packageName , '.' , self branch)}! ! !GoferWorking commentStamp: 'TorstenBergmann 2/5/2014 09:34'! Common superclass for workin copies in Gofer! !GoferWorking methodsFor: 'accessing' stamp: 'lr 9/24/2009 16:55'! workingCopies "Answer the working copies to be operated on." ^ workingCopies! ! !GoferWorking methodsFor: 'initialization' stamp: 'lr 8/19/2009 13:14'! initialize super initialize. workingCopies := OrderedCollection new! ! !GoferWorking methodsFor: 'initialization' stamp: 'lr 12/13/2009 19:16'! initializeOn: aGofer super initializeOn: aGofer. aGofer references do: [ :each | self addReference: each ]! ! !GoferWorking methodsFor: 'private' stamp: 'CamilloBruni 9/5/2012 17:27'! addReference: aReference | workingCopy | workingCopy := aReference workingCopyIfAbsent: [ ^ self ]. (self workingCopies includes: workingCopy) ifTrue: [ ^ self ]. self workingCopies addLast: workingCopy. workingCopy requiredPackages do: [ :package | self addReference: (GoferPackageReference name: package name) ]! ! !GradientFillStyle commentStamp: 'efc 8/30/2005 21:44'! A gradient fill style is a fill which interpolates smoothly between any number of colors. Instance variables: colorRamp Contains the colors and their relative positions along the fill, which is a number between zero and one. pixelRamp A cached version of the colorRamp to avoid needless recomputations. radial If true, this fill describes a radial gradient. If false, it is a linear gradient. isTranslucent A (cached) flag determining if there are any translucent colors involved. Class variables: PixelRampCache Recently used pixelRamps. They tend to have high temporal locality and this saves space and time.! !GradientFillStyle methodsFor: 'private' stamp: 'nice 1/5/2010 15:59'! computePixelRampOfSize: length "Compute the pixel ramp in the receiver" | bits lastValue ramp lastColor lastIndex lastWord | ramp := colorRamp asSortedCollection:[:a1 :a2| a1 key < a2 key]. bits := Bitmap new: length. lastColor := ramp first value. lastWord := lastColor pixelWordForDepth: 32. lastIndex := 0. ramp do:[:assoc| | theta nextIndex nextColor nextWord distance step | nextIndex := (assoc key * length) rounded. nextColor := assoc value. nextWord := nextColor pixelWordForDepth: 32. distance := (nextIndex - lastIndex). distance = 0 ifTrue:[distance := 1]. step := 1.0 / distance asFloat. theta := 0.0. lastIndex+1 to: nextIndex do:[:i| theta := theta + step. "The following is an open-coded version of: color := nextColor alphaMixed: theta with: lastColor. bits at: i put: (color scaledPixelValue32). " bits at: i put: (self scaledAlphaMix: theta of: lastWord with: nextWord). ]. lastIndex := nextIndex. lastColor := nextColor. lastWord := nextWord. ]. lastValue := lastColor scaledPixelValue32. lastIndex+1 to: length do:[:i| bits at: i put: lastValue]. ^bits! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'ar 9/2/1999 14:30'! colorRamp: anArray colorRamp := anArray. pixelRamp := nil. isTranslucent := nil.! ! !GradientFillStyle methodsFor: 'converting' stamp: 'ar 8/25/2001 21:02'! asColor "Guess..." ^colorRamp first value mixed: 0.5 with: colorRamp last value! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/7/1998 22:10'! colorRamp ^colorRamp! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:06'! pixelRamp: aBitmap pixelRamp := aBitmap! ! !GradientFillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:29'! isTranslucent ^isTranslucent ifNil:[isTranslucent := self checkTranslucency]! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/11/2014 10:12'! pixelRamp "Compute a pixel ramp, and cache it for future accesses" ^ pixelRamp ifNil: [ "Ask my cache for an existing instance or to create one" pixelRamp := self class pixelRampCache at: colorRamp ]! ! !GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'dik 7/1/2010 00:46'! changeColorOf: aMorph rampIndex: rampIndex | originalColor | originalColor := (colorRamp at: rampIndex) value. UIManager default chooseColor: originalColor for: [:color | self changeColorAt: rampIndex to: color. aMorph changed] ! ! !GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'ar 6/18/1999 07:25'! beLinearGradientIn: aMorph self radial: false. aMorph changed.! ! !GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'dgd 10/17/2003 22:37'! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" self isRadialFill ifTrue:[ aMenu add: 'linear gradient' translated target: self selector: #beLinearGradientIn: argument: aMorph. ] ifFalse:[ aMenu add: 'radial gradient' translated target: self selector: #beRadialGradientIn: argument: aMorph. ]. aMenu addLine. aMenu add: 'change first color' translated target: self selector: #changeFirstColorIn:event: argument: aMorph. aMenu add: 'change second color' translated target: self selector: #changeSecondColorIn:event: argument: aMorph. aMenu addLine. super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'ar 8/31/2004 11:06'! radial ^radial ifNil:[false]! ! !GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'dik 7/1/2010 00:45'! changeColorAt: rampIndex to: aColor | ramp | ramp := colorRamp deepCopy. (ramp at: rampIndex) value: aColor. colorRamp := ramp. isTranslucent := nil. pixelRamp := nil.! ! !GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'dik 6/28/2010 00:22'! changeFirstColorIn: aMorph event: evt. ^self changeColorOf: aMorph rampIndex: 1! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/7/1998 22:11'! radial: aBoolean radial := aBoolean! ! !GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'ar 6/18/1999 07:25'! beRadialGradientIn: aMorph self radial: true. aMorph changed.! ! !GradientFillStyle methodsFor: 'converting' stamp: 'ar 6/4/2001 00:42'! mixed: fraction with: aColor ^self copy colorRamp: (colorRamp collect:[:assoc| assoc key -> (assoc value mixed: fraction with: aColor)])! ! !GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'HenrikSperreJohansen 6/11/2010 12:29'! changeColorSelector: aSymbol hand: aHand morph: aMorph originalColor: originalColor "Change either the firstColor or the lastColor (depending on aSymbol). Put up a color picker to hande it. We always use a modal picker so that the user can adjust both colors concurrently." |arraySelector| "A bad hack, I know... but it already uses a perform which depends on only firstColor: ... / lastColor: ... being sent" arraySelector := (aSymbol readStream upTo: $C) asSymbol. ( UIManager default chooseColor: (colorRamp perform: arraySelector) value) ifNotNil: [:nc | self perform: aSymbol with: nc with: aMorph with: aHand] ! ! !GradientFillStyle methodsFor: 'comparing' stamp: 'gvc 7/24/2007 12:22'! hash "Hash is implemented because #= is implemented." ^super hash bitXor: self pixelRamp hash! ! !GradientFillStyle methodsFor: '*Athens-Core' stamp: 'IgorStasenko 10/11/2012 16:16'! asAthensPaintOn: anAthensCanvas ^ AthensMorphicGradientPaint new gradient: self. "^ radial ifTrue: [ anAthensCanvas surface createRadialGradient: colorRamp center: (anAthensCanvas pathTransform inverseTransform: origin ) radius: direction y ] ifFalse: [ anAthensCanvas surface createLinearGradient: colorRamp origin: (anAthensCanvas pathTransform inverseTransform: origin) corner: (anAthensCanvas pathTransform inverseTransform: origin + direction ) ] "! ! !GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'ar 6/18/1999 09:49'! addNewColorIn: aMorph event: evt ^self inform:'not yet implemented'! ! !GradientFillStyle methodsFor: 'testing' stamp: 'ar 11/7/1998 22:13'! isRadialFill ^radial == true! ! !GradientFillStyle methodsFor: 'private' stamp: 'ar 7/11/2000 16:47'! scaledAlphaMix: theta of: lastWord with: nextWord "Open-coded version of alpha mixing two 32bit pixel words and returning the scaled pixel value." | word0 word1 a0 a1 alpha v0 v1 vv value | word0 := lastWord. word1 := nextWord. "note: extract alpha first so we'll be in SmallInteger range afterwards" a0 := word0 bitShift: -24. a1 := word1 bitShift: -24. alpha := a0 + (a1 - a0 * theta) truncated. "Now make word0 and word1 SmallIntegers" word0 := word0 bitAnd: 16rFFFFFF. word1 := word1 bitAnd: 16rFFFFFF. "Compute first component value" v0 := (word0 bitAnd: 255). v1 := (word1 bitAnd: 255). vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255. value := vv. "Compute second component value" v0 := ((word0 bitShift: -8) bitAnd: 255). v1 := ((word1 bitShift: -8) bitAnd: 255). vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255. value := value bitOr: (vv bitShift: 8). "Compute third component value" v0 := ((word0 bitShift: -16) bitAnd: 255). v1 := ((word1 bitShift: -16) bitAnd: 255). vv := (v0 + (v1 - v0 * theta) truncated) * alpha // 255. value := value bitOr: (vv bitShift: 16). "Return result" ^value bitOr: (alpha bitShift: 24)! ! !GradientFillStyle methodsFor: 'private' stamp: 'di 11/21/1999 20:18'! checkTranslucency ^colorRamp anySatisfy: [:any| any value isTranslucent]! ! !GradientFillStyle methodsFor: 'comparing' stamp: 'gvc 7/24/2007 12:22'! = anGradientFillStyle "Answer whether equal." ^super = anGradientFillStyle and: [self pixelRamp == anGradientFillStyle pixelRamp] "LRU should make identity equal"! ! !GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'dik 6/28/2010 00:31'! copyWith: aColor atRamp: rampIndex | ramp | ramp := colorRamp deepCopy. (ramp at: rampIndex) value: aColor. ^(self class ramp: ramp) origin: self origin; direction: self direction; normal: self normal; radial: self radial; yourself! ! !GradientFillStyle methodsFor: 'testing' stamp: 'ar 11/7/1998 22:12'! isGradientFill ^true! ! !GradientFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'dik 6/28/2010 00:22'! changeSecondColorIn: aMorph event: evt ^self changeColorOf: aMorph rampIndex: 2! ! !GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/10/1998 19:13'! sample "GradientFill sample" ^(self ramp: { 0.0 -> Color red. 0.5 -> Color green. 1.0 -> Color blue}) origin: 300 @ 300; direction: 400@0; normal: 0@400; radial: true; yourself! ! !GradientFillStyle class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 1/12/2014 15:44'! initPixelRampCache "Create an LRUCache to use for accessing pixel ramps. When a new pixel ramp is needed, a temporary GradientFillStyle is created so that it can be used to create a new pixel ramp" ^ PixelRampCache := LRUCache new maximumWeight: 32; factory: [ :key | (GradientFillStyle new colorRamp: key) computePixelRampOfSize: 512 ]; yourself! ! !GradientFillStyle class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 1/12/2014 15:49'! initialize "GradientFillStyle initialize" self initPixelRampCache ! ! !GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/9/1998 14:05'! ramp: colorRamp ^self new colorRamp: colorRamp! ! !GradientFillStyle class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 1/11/2014 10:11'! pixelRampCache "Allow access to my cache of pixel ramps." ^ PixelRampCache ifNil: [ self initPixelRampCache ]! ! !GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 23:09'! colors: colorArray "Create a gradient fill style from an array of equally spaced colors" ^self ramp: (colorArray withIndexCollect: [:color :index| (index-1 asFloat / (colorArray size - 1 max: 1)) -> color]).! ! !GradientFillStyle class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:32'! cleanUp "Flush caches" self initPixelRampCache! ! !GradientPaint commentStamp: ''! I am paint which using color gradient for fills. The gradient is defined using color ramp in range between 0 and 1 where colors can be set at certain point. The color are interpolated between defined points. The color ramp is a collection of associations with keys - floating point values between 0 and 1 and values with Colors, for example: { 0 -> Color white. 1 -> Color black }. My subclasses used to define a concrete kind of gradient, while me is an abstract class which has common properties for all gradients: color ramp. Also, note that my subclasses representing backend-neutral gradients, encapsulating all necessary data, which is then passed to corresponding surface factory method, like AthensSurface>>#createLinearGradient:start:stop: , which answers backend-specific gradient paint. I am userful in cases when user wants to define a paint without need to have any Athens surface at hand. Sure thing, using backend-specific gradients is preferable, if possible, because conversion to backend-specific paint can be costly. Especially if gradient is statically defined (ramp values and other parameters never changing) and used many times during the life time of surface. ! !GradientPaint methodsFor: 'initialize-release' stamp: 'IgorStasenko 4/12/2013 09:51'! initialize super initialize. colorRamp := OrderedCollection new.! ! !GradientPaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/12/2013 09:54'! atStop: anOffset put: aColor colorRamp add: (anOffset -> aColor). ! ! !GradientPaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/13/2013 09:11'! colorRamp: aRamp "The color ramp is a collection of associations with keys - floating point values between 0 and 1 and values with Colors, for example: { 0 -> Color white. 1 -> Color black }. " colorRamp := aRamp copy.! ! !GradientPaint methodsFor: 'accessing' stamp: 'FernandoOlivero 1/13/2012 21:11'! colorRamp ^ colorRamp! ! !GrafPort commentStamp: 'TorstenBergmann 2/20/2014 18:35'! Provides extended Graphic support like translucency! !GrafPort methodsFor: 'accessing' stamp: 'ar 5/28/2000 14:41'! contentsOfArea: aRectangle into: aForm destForm displayOn: aForm at: aRectangle origin clippingBox: (0@0 extent: aRectangle extent). ^aForm! ! !GrafPort methodsFor: 'accessing' stamp: 'tween 4/5/2007 08:03'! lastFontForegroundColor ^lastFontForegroundColor! ! !GrafPort methodsFor: 'copying' stamp: 'MarcusDenker 10/21/2013 14:22'! copyBits "Override copybits to do translucency if desired" (combinationRule between: 30 and: 31) ifTrue: [ self copyBitsTranslucent: (alpha ifNil: [ 255 ]) ] ifFalse: [ super copyBits ]! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 00:31'! stencil: stencilForm at: aPoint sourceRect: aRect "Paint using aColor wherever stencilForm has non-zero pixels" self sourceForm: stencilForm; destOrigin: aPoint; sourceRect: aRect. self copyBits! ! !GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:12'! installStrikeFont: aStrikeFont ^ self installStrikeFont: aStrikeFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]) backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]). ! ! !GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:13'! lastFont ^ lastFont. ! ! !GrafPort methodsFor: 'private' stamp: 'tween 6/8/2008 12:29'! installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor super installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor. aStrikeFont glyphs depth = 1 ifTrue: [ alpha := foregroundColor privateAlpha. "dynamically switch between blend modes to support translucent text" "To handle the transition from TTCFont to StrikeFont, rule 34 must be taken into account." alpha = 255 ifTrue:[ combinationRule = 30 ifTrue: [combinationRule := Form over]. combinationRule = 31 ifTrue: [combinationRule := Form paint]. combinationRule = 34 ifTrue: [combinationRule := Form paint]. combinationRule = 41 ifTrue: [combinationRule := Form paint]. "41 is SPRmode" ] ifFalse:[ combinationRule = Form over ifTrue: [combinationRule := 30]. combinationRule = Form paint ifTrue: [combinationRule := 31]. combinationRule = 34 ifTrue: [combinationRule := 31]. combinationRule = 41 ifTrue: [combinationRule := 31]. "41 is SPR mode" ] ]. lastFont := aStrikeFont. lastFontForegroundColor := foregroundColor. lastFontBackgroundColor := backgroundColor. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'! frameRectBottom: rect height: h destX := rect left + 1. destY := rect bottom - 1. width := rect width - 2. height := 1. 1 to: h do: [:i | self copyBits. destX := destX + 1. destY := destY - 1. width := width - 2]. ! ! !GrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:09'! fillPattern: anObject fillPattern := anObject. self fillColor: anObject.! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 5/17/2000 21:20'! fillRect: rect offset: aPoint "The offset is really just for stupid InfiniteForms." | fc | fillPattern class == InfiniteForm ifTrue:[ fc := halftoneForm. self fillColor: nil. fillPattern displayOnPort: ((self clippedBy: rect) colorMap: nil) at: aPoint. halftoneForm := fc. ^self]. destX := rect left. destY := rect top. sourceX := 0. sourceY := 0. width := rect width. height := rect height. self copyBits.! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." sourceForm := aForm. combinationRule := rule. self sourceRect: sourceRect. self destOrigin: aPoint. self copyBits! ! !GrafPort methodsFor: 'copying' stamp: 'ar 12/30/2001 20:32'! clippedBy: aRectangle ^ self copy clipBy: aRectangle! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 14:44'! frameRect: rect borderWidth: borderWidth sourceX := 0. sourceY := 0. (rect areasOutside: (rect insetBy: borderWidth)) do: [:edgeStrip | self destRect: edgeStrip; copyBits]. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'MarcusDenker 10/28/2010 14:02'! frameOval: rect borderWidth: borderWidth | centerX centerY nextY yBias xBias wp outer inner nextOuterX nextInnerX | rect area <= 0 ifTrue: [^ self]. height := 1. wp := borderWidth asPoint. yBias := rect height odd ifTrue: [0] ifFalse: [-1]. xBias := rect width odd ifTrue: [1] ifFalse: [0]. centerX := rect center x. centerY := rect center y. outer := EllipseMidpointTracer new on: rect. inner := EllipseMidpointTracer new on: (rect insetBy: wp). nextY := rect height // 2. 1 to: (wp y min: nextY) do:[:i| nextOuterX := outer stepInY. width := (nextOuterX bitShift: 1) + xBias. destX := centerX - nextOuterX. destY := centerY - nextY. self copyBits. destY := centerY + nextY + yBias. self copyBits. nextY := nextY - 1. ]. [nextY > 0] whileTrue:[ nextOuterX := outer stepInY. nextInnerX := inner stepInY. destX := centerX - nextOuterX. destY := centerY - nextY. width := nextOuterX - nextInnerX. self copyBits. destX := centerX + nextInnerX + xBias. self copyBits. destX := centerX - nextOuterX. destY := centerY + nextY + yBias. self copyBits. destX := centerX + nextInnerX + xBias. self copyBits. nextY := nextY - 1. ]. destY := centerY. height := 1 + yBias. width := wp x. destX := rect left. self copyBits. destX := rect right - wp x. self copyBits. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/16/2000 22:32'! fillOval: rect | centerX centerY nextY yBias xBias outer nextOuterX | rect area <= 0 ifTrue: [^ self]. height := 1. yBias := rect height odd ifTrue: [0] ifFalse: [-1]. xBias := rect width odd ifTrue: [1] ifFalse: [0]. centerX := rect center x. centerY := rect center y. outer := EllipseMidpointTracer new on: rect. nextY := rect height // 2. [nextY > 0] whileTrue:[ nextOuterX := outer stepInY. width := (nextOuterX bitShift: 1) + xBias. destX := centerX - nextOuterX. destY := centerY - nextY. self copyBits. destY := centerY + nextY + yBias. self copyBits. nextY := nextY - 1. ]. destY := centerY. height := 1 + yBias. width := rect width. destX := rect left. self copyBits. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'! frameRectRight: rect width: w width := 1. height := rect height - 1. destX := rect right - 1. destY := rect top + 1. 1 to: w do: [:i | self copyBits. destX := destX - 1. destY := destY + 1. height := height - 2]. ! ! !GrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:07'! alphaBits: a alpha := a! ! !GrafPort methodsFor: 'accessing' stamp: 'nice 11/2/2013 17:29'! displayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode ^ (BitBltDisplayScanner new text: para text textStyle: para textStyle foreground: foreColor background: backColor fillBlt: self ignoreColorChanges: shadowMode) setPort: self shallowCopy! ! !GrafPort methodsFor: '*FreeType-addition' stamp: 'tween 4/5/2007 08:39'! installFreeTypeFont: aFreeTypeFont foregroundColor: foregroundColor backgroundColor: backgroundColor super installFreeTypeFont: aFreeTypeFont foregroundColor: foregroundColor backgroundColor: backgroundColor. lastFont := aFreeTypeFont. lastFontForegroundColor := foregroundColor. lastFontBackgroundColor := backgroundColor. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 8/8/2001 14:26'! image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." sourceForm := aForm. combinationRule := rule. self sourceRect: sourceRect. self destOrigin: aPoint. self copyBitsTranslucent: (alpha := (sourceAlpha * 255) truncated min: 255 max: 0).! ! !GraphicFontSettings commentStamp: 'TorstenBergmann 2/12/2014 23:27'! Settings for the fonts! !GraphicFontSettings class methodsFor: 'fonts' stamp: 'EstebanLorenzano 5/14/2013 09:44'! resetAllFontToDefaultButton ^ (self theme newButtonIn: World for: self getState: nil action: #resetAllFontToDefault arguments: {} getEnabled: nil getLabel: nil help: 'Force all system fonts to be the default one' translated) label: (self theme newRowIn: World for: { AlphaImageMorph new image: Smalltalk ui icons smallRedoIcon. self theme buttonLabelForText: 'Force all' translated}); yourself. ! ! !GraphicFontSettings class methodsFor: 'fonts' stamp: 'AlainPlantec 1/10/2010 08:15'! resetAllFontToDefault StandardFonts setAllStandardFontsTo: StandardFonts defaultFont. SettingBrowser refreshAllSettingBrowsers ! ! !GraphicFontSettings class methodsFor: 'fonts' stamp: 'EstebanLorenzano 5/14/2013 09:43'! fontChoiceButtonForStyle: aSymbol label: aLabel | label | label := StringMorph contents: aLabel asString font: (TextStyle default fontOfPointSize: (StandardFonts pointSizeForStyleNamed: aSymbol)). ^ (Smalltalk ui theme newButtonIn: World for: self getState: nil action: #setFontsToStyleNamed: arguments: { aSymbol } getEnabled: nil getLabel: nil help: ('Change font style to ', aLabel) translated) label: label; yourself ! ! !GraphicFontSettings class methodsFor: 'fonts' stamp: 'AlainPlantec 9/18/2011 10:11'! setFontsToStyleNamed: aSymbol StandardFonts setFontsToStyleNamed: aSymbol. SettingBrowser refreshAllSettingBrowsers! ! !GraphicFontSettings class methodsFor: 'fonts' stamp: 'AlainPlantec 9/18/2011 10:14'! fontSizeRow | label | ^ self theme newRowIn: World for: { self theme buttonLabelForText: 'Predefined styles: ' translated. self fontChoiceButtonForStyle: #small label: 'Small' translated. self fontChoiceButtonForStyle: #medium label: 'Medium' translated. self fontChoiceButtonForStyle: #large label: 'Large' translated. self fontChoiceButtonForStyle: #veryLarge label: 'Very large' translated. self fontChoiceButtonForStyle: #huge label: 'Huge' translated. }! ! !GraphicFontSettings class methodsFor: 'fonts' stamp: 'AlainPlantec 9/17/2011 22:16'! standardFontsSettingsOn: aBuilder (aBuilder group: #standardFonts) label: 'Standard fonts' translated; target: StandardFonts; dialog: [self fontSizeRow]; parent: #appearance; order: 4; with: [ (aBuilder setting: #defaultFont) order: 1; description: 'The default text font' translated; dialog: (MessageSend receiver: self selector: #resetAllFontToDefaultButton); label: 'Default' translated. (aBuilder setting: #codeFont) description: 'The standard code font' translated; label: 'Code' translated. (aBuilder setting: #listFont) description: 'The standard list font' translated; label: 'List' translated. (aBuilder setting: #menuFont) description: 'The standard menu font' translated; label: 'Menu' translated. (aBuilder setting: #buttonFont) description: 'The standard button font' translated; label: 'Button' translated. (aBuilder setting: #windowTitleFont) description: 'The standard window title font' translated; label: 'Window title' translated. (aBuilder setting: #balloonFont) description: 'The standard balloon-help font' translated; label: 'Balloon-help' translated. (aBuilder setting: #haloFont) description: 'The morphic halo font' translated; label: 'Morphic halo' translated] ! ! !GraphicFontSettings class methodsFor: 'private' stamp: 'AlainPlantec 4/28/2011 12:17'! theme ^ UIManager default theme! ! !GreekEnvironment commentStamp: ''! This class provides the support for Greek. It is here, but most of the methods are not implemented yet. ! !GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'cami 7/22/2013 18:26'! systemConverterClass Smalltalk os isWin32 ifTrue: [^CP1253TextConverter ]. ^ ISO88597TextConverter. ! ! !GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 18:23'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." ^#('el' )! ! !GreekEnvironment class methodsFor: 'class initialization' stamp: 'StephaneDucasse 8/22/2013 14:32'! initialize EncodedCharSet declareEncodedCharSet: self atIndex: 13+1.! ! !GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'nice 5/1/2011 19:22'! leadingChar ^0! ! !GroupAlreadyExists commentStamp: ''! A GroupAreadyExists is an exception raised when a group with the provided name already exists! !GroupAlreadyExists methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/24/2013 14:34'! groupName: anObject groupName := anObject! ! !GroupAlreadyExists methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/24/2013 14:34'! groupName ^ groupName! ! !GroupAlreadyExists class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 1/24/2013 14:35'! groupName: groupName ^ self new groupName: groupName; yourself! ! !GroupAnnouncer commentStamp: 'TorstenBergmann 2/4/2014 21:10'! Announcer for group announcements! !GroupCreatorTreeModel commentStamp: 'TorstenBergmann 2/4/2014 21:13'! Tree model for group creation in Nautilus! !GroupCreatorTreeModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:39'! model: anObject model := anObject! ! !GroupCreatorTreeModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:39'! model ^ model! ! !GroupCreatorTreeModel methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:43'! rootNodeClassFromItem: anItem ^ GroupNode! ! !GroupCreatorTreeModel methodsFor: 't - accessing' stamp: 'AlainPlantec 10/18/2013 10:35'! selection | list | list := self rootItems. (list notEmpty and: [ super selection isNil ]) ifTrue: [ self hardlySelectItem: list first ]. ^ super selection! ! !GroupCreatorTreeModel methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 9/15/2011 16:34'! setSelectedNodeItem: anItem ^ self model setSelectedNodeItem: anItem! ! !GroupCreatorTreeModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/18/2011 15:26'! groupsManager ^ self model groupsManager! ! !GroupCreatorTreeModel methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 14:18'! selection: aNode super selection: aNode. self model updateSelectedNode.! ! !GroupCreatorTreeModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/15/2011 16:50'! hardlySelectItem: anItem self selectNodePath: ((self setSelectedNodeItem: anItem)collect:#complexContents)! ! !GroupCreatorTreeModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/15/2011 13:44'! groups ^ self model groups! ! !GroupCreatorTreeModel methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 9/15/2011 09:58'! rootItems ^ self groups! ! !GroupHolder commentStamp: ''! A GroupsHolder is a simple object which manage a collection of groups! !GroupHolder methodsFor: 'dynamic group' stamp: 'BenjaminVanRyseghem 2/27/2012 23:34'! addADynamicClassGroupSilentlyNamed: entry block: aBlock (self includesAGroupNamed: entry) ifTrue: [ ^ nil ] ifFalse: [ | group | group := self groups add: (DynamicClassGroup named: entry block: aBlock). ^ group]! ! !GroupHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/24/2013 14:33'! renameAGroup: aGroup | entry | entry := UIManager default request: 'New name of the group' initialAnswer: aGroup name title: 'Rename a group'. (entry isNil or: [entry isEmpty]) ifTrue: [^ aGroup]. (self includesAGroupNamed: entry) ifTrue: [ ^ self openError: entry ]. aGroup isReadOnly ifTrue: [ ^ self openReadOnlyError ]. aGroup name: entry. GroupAnnouncer uniqueInstance announce: ( AGroupHasBeenRenamed group: aGroup from: self ). ^ aGroup ! ! !GroupHolder methodsFor: 'adding' stamp: 'BenjaminVanRyseghem 1/24/2013 14:33'! addAGroup: aGroup (self includesAGroupNamed: aGroup name) ifTrue: [ self openError: aGroup name. ^ nil]. self groups add: aGroup. GroupAnnouncer uniqueInstance announce: ( AGroupHasBeenAdded group: aGroup into: self ).! ! !GroupHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:37'! includesAGroupNamed: aName ^ self groupsNames includes: aName! ! !GroupHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/2/2012 17:24'! addClasses: aCollection into: aGroup aGroup addClasses: aCollection! ! !GroupHolder methodsFor: 'dynamic group' stamp: 'BenjaminVanRyseghem 2/27/2012 23:35'! addADynamicGroupSilentlyNamed: entry blocks: aCollection (self includesAGroupNamed: entry) ifTrue: [ ^ nil ] ifFalse: [ | group | group := self groups add: (DynamicGroup named: entry blocks: aCollection). ^ group]! ! !GroupHolder methodsFor: 'protocol' stamp: 'MarianoMartinezPeck 8/5/2012 15:56'! removeAGroupSilently: aGroup | group | aGroup ifNil: [ ^ self ]. aGroup removable ifFalse: [ ^ self openReadOnlyError ]. group := self groups remove: aGroup ifAbsent: []. GroupAnnouncer uniqueInstance announce: ( AGroupHasBeenRemoved group: aGroup from: self ). ^ group! ! !GroupHolder methodsFor: 'adding' stamp: 'BenjaminVanRyseghem 3/28/2011 14:04'! add: aCollection into: aGroup aGroup ifAllowed: [ aGroup addAll: aCollection ] ifNot: [ self openReadOnlyError ]! ! !GroupHolder methodsFor: 'dynamic group' stamp: 'BenjaminVanRyseghem 1/24/2013 14:32'! addADynamicClassGroupNamed: entry block: aBlock (self includesAGroupNamed: entry) ifTrue: [ self openError: entry. ^ nil] ifFalse: [ | group | group := self groups add: (DynamicClassGroup named: entry block: aBlock). GroupAnnouncer uniqueInstance announce: ( AGroupHasBeenAdded group: group into: self ). ^ group]! ! !GroupHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 16:58'! remove: aClass from: aGroup ^ aGroup ifAllowed: [ aGroup remove: aClass ] ifNot: [ self openReadOnlyError ]! ! !GroupHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:32'! groupsNames ^ self groups collect: [:group | group name ]! ! !GroupHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/28/2011 17:22'! removeAGroup: aGroup | yesIWantToRemoveTheGroup | yesIWantToRemoveTheGroup := self openRemoveDialogOn: aGroup. yesIWantToRemoveTheGroup ifFalse: [ ^ nil ]. ^ self removeAGroupSilently: aGroup ! ! !GroupHolder methodsFor: 'windows' stamp: 'BenjaminVanRyseghem 3/22/2011 18:15'! openRemoveDialogOn: aGroup ^UIManager default confirm: ('Dou you really want to delete the group named ', aGroup name)! ! !GroupHolder methodsFor: 'dynamic group' stamp: 'BenjaminVanRyseghem 1/24/2013 14:32'! addADynamicClassGroupNamed: entry blocks: aCollection (self includesAGroupNamed: entry) ifTrue: [ self openError: entry. ^ nil] ifFalse: [ | group | group := self groups add: (DynamicClassGroup named: entry blocks: aCollection). GroupAnnouncer uniqueInstance announce: ( AGroupHasBeenAdded group: group into: self ). ^ group]! ! !GroupHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/21/2011 11:06'! isEmpty ^ self groups isEmpty.! ! !GroupHolder methodsFor: 'dynamic group' stamp: 'BenjaminVanRyseghem 1/24/2013 14:33'! addADynamicGroupNamed: entry blocks: aCollection (self includesAGroupNamed: entry) ifTrue: [ self openError: entry. ^ nil] ifFalse: [ | group | group := self groups add: (DynamicGroup named: entry blocks: aCollection). GroupAnnouncer uniqueInstance announce: ( AGroupHasBeenAdded group: group into: self ). ^ group]! ! !GroupHolder methodsFor: 'dynamic group' stamp: 'BenjaminVanRyseghem 2/27/2012 23:35'! addADynamicClassGroupSilentlyNamed: entry blocks: aCollection (self includesAGroupNamed: entry) ifTrue: [ ^ nil ] ifFalse: [ | group | group := self groups add: (DynamicClassGroup named: entry blocks: aCollection). ^ group]! ! !GroupHolder methodsFor: 'dynamic group' stamp: 'BenjaminVanRyseghem 1/24/2013 14:32'! addADynamicGroupNamed: entry block: aBlock (self includesAGroupNamed: entry) ifTrue: [ self openError: entry. ^ nil] ifFalse: [ | group | group := self groups add: (DynamicGroup named: entry block: aBlock). GroupAnnouncer uniqueInstance announce: ( AGroupHasBeenAdded group: group into: self ). ^ group]! ! !GroupHolder methodsFor: 'adding' stamp: 'BenjaminVanRyseghem 3/21/2011 15:26'! createADynamicGroup | entry aClass aSelector | entry := UIManager default textEntry: 'Name of the new group:' title: 'Create a new group' entryText: 'MyNewGroupName'. aClass := nil. aSelector := nil. ^ entry ifNotNil: [ self addADynamicGroupSilentlyNamed: entry model: aClass selector: aSelector ].! ! !GroupHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/14/2011 16:00'! includes: aGroup ^ self groups includes: aGroup! ! !GroupHolder methodsFor: 'windows' stamp: 'BenjaminVanRyseghem 3/22/2011 18:14'! openReadOnlyError UIManager default alert: 'This group is read only' title: 'Access error'! ! !GroupHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/1/2012 00:55'! removeClass: aClass from: aStaticGroup ^ aStaticGroup ifAllowed: [ aStaticGroup removeClass: aClass ] ifNot: [ self openReadOnlyError ]! ! !GroupHolder methodsFor: 'dynamic group' stamp: 'BenjaminVanRyseghem 2/27/2012 23:35'! addADynamicGroupSilentlyNamed: entry block: aBlock (self includesAGroupNamed: entry) ifTrue: [ ^ nil ] ifFalse: [ | group | group := self groups add: (DynamicGroup named: entry block: aBlock). ^ group]! ! !GroupHolder methodsFor: 'adding' stamp: 'BenjaminVanRyseghem 3/2/2012 17:16'! createAnEmptyStaticGroup | entry | entry := UIManager default request: 'Name of the new group:' initialAnswer: '' title: 'Create a new group'. ^ (entry isNil or: [entry isEmpty]) ifFalse: [ self addAnEmptyDynamicGroupNamed: entry ]! ! !GroupHolder methodsFor: 'protocol' stamp: 'EstebanLorenzano 10/10/2013 13:13'! groupNamed: aString ^ self groups detect: [:each | each name = aString]! ! !GroupHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:54'! sort: aBlock ^ groups := self groups sort: aBlock! ! !GroupHolder methodsFor: 'windows' stamp: 'BenjaminVanRyseghem 1/24/2013 14:40'! openError: name (GroupAlreadyExists groupName: name) signal! ! !GroupHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 15:04'! groups ^ groups ifNil: [ groups := OrderedCollection new ]! ! !GroupHolder methodsFor: 'dynamic group' stamp: 'BenjaminVanRyseghem 3/2/2012 17:32'! addAnEmptyDynamicGroupNamed: aName ^ (self addADynamicGroupNamed: aName block: [ {} ]) isFillable: true; yourself! ! !GroupNode commentStamp: 'TorstenBergmann 2/4/2014 21:13'! A group node in the morph tree! !GroupNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/18/2011 15:29'! rowMorphForColumn: aTreeColumn ^ self item ifNotNil: [:i | i name asMorph] ! ! !GroupNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 3/15/2011 14:07'! isGroup ^ true! ! !GroupNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/18/2011 15:27'! childrenItems ^ self item elements! ! !GroupNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:46'! childNodeClassFromItem: anItem ^ ItemNode! ! !GroupWindowMorph commentStamp: 'LaurentLaffont 7/12/2011 23:33'! I'm a morph where you can drag windows to group them as tabs. Try: (GroupWindowMorph new openInWindowLabeled: 'Window organizer') extent: 400@400.! !GroupWindowMorph methodsFor: 'services' stamp: ''! questionWithoutCancel: aStringOrText "Open a question dialog." ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newWindowFor: aModel title: titleString "Answer a new window morph." ^self theme newWindowIn: self for: aModel title: titleString! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText "Answer a color chooser with the given selectors." ^self theme newColorChooserIn: self for: aModel getColor: getSel setColor: setSel getEnabled: nil help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newGroupbox "Answer a plain groupbox." ^self theme newGroupboxIn: self! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText "Answer a color chooser with the given selectors." ^self theme newColorChooserIn: self for: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText "Answer an inremental slider with the given selectors." ^self theme newIncrementalSliderIn: self for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! deny: aStringOrText "Open a denial dialog." ^self deny: aStringOrText title: 'Access Denied' translated! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newLabelGroup: labelsAndControls font: aFont labelColor: aColor "Answer a morph laid out with a column of labels and a column of associated controls. Controls having a vResizing value of #spaceFill will cause their row to use #spaceFill also, otherwise #shrinkWrap." ^self theme newLabelGroupIn: self for: labelsAndControls font: aFont labelColor: aColor ! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newCloseButton "Answer a new close button." ^self newCloseButtonFor: self ! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newGroupbox: aString "Answer a groupbox with the given label." ^self theme newGroupboxIn: self label: aString! ! !GroupWindowMorph methodsFor: 'theme' stamp: ''! theme "Answer the ui theme that provides controls." ^ Smalltalk ui theme! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel getEnabled: enabledSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: 0 max: 1 quantum: nil getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'initialization' stamp: 'IgorStasenko 12/19/2012 17:58'! initialize "Add the tab group with an inital workspace." super initialize. self changeProportionalLayout. self tabGroup: self newTabGroup. self tabGroup tabSelectorMorph addDependent: self. self dropEnabled: true; addMorph: self tabGroup fullFrame: LayoutFrame identity. self tabGroup color: Color transparent. ! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts path: path "Answer the result of a file open dialog with the given title, extensions to show and path." ^self fileOpen: title extensions: exts path: path preview: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: (AlphaImageMorph new image: aForm) help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newPanel "Answer a new panel." ^self theme newPanelIn: self! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newPluggableDialogWindow: title "Answer a new pluggable dialog with the given content." ^self newPluggableDialogWindow: title for: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newSVSelector: aColor help: helpText "Answer a saturation-volume selector with the given color." ^self theme newSVSelectorIn: self color: aColor help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText "Answer a list for the given model." ^self newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: nil help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newMenu "Answer a new menu." ^self theme newMenuIn: self for: self! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! centeredAlert: aStringOrText title: aString configure: aBlock "Open an alert dialog. Configure the dialog with the 1 argument block before opening modally." ^self theme centeredAlertIn: self text: aStringOrText title: aString configure: aBlock! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newMenuFor: aModel "Answer a new menu." ^self theme newMenuIn: self for: aModel! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector "Answer a text editor for the given model." ^self theme newBasicTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText "Answer a morph drop list for the given model." ^self theme newMorphDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a checkbox (radio button appearance) with the given label." ^self theme newRadioButtonIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newStack: controls "Answer a morph laid out with a stack of controls." ^self theme newStackIn: self for: controls! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newAlphaImage: aForm help: helpText "Answer an alpha image morph." ^self theme newAlphaImageIn: self image: aForm help: helpText! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! chooseFont "Answer the result of a font selector dialog." ^self chooseFont: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a new button." ^self newButtonFor: aModel getState: nil action: actionSel arguments: nil getEnabled: enabledSel label: stringOrText help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol "Answer a new balloon help with the given contents for aMorph at a given corner." ^self theme newBalloonHelpIn: self contents: aTextStringOrMorph for: aMorph corner: cornerSymbol! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText "Answer an alpha channel selector with the given selectors." ^self theme newAlphaSelectorIn: self for: aModel getAlpha: getSel setAlpha: setSel help: helpText! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! message: aStringOrText "Open a message dialog." ^self message: aStringOrText title: 'Information' translated! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! chooseDirectory: title path: path "Answer the result of a file dialog with the given title, answer a directory." ^self theme chooseDirectoryIn: self title: title path: path! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector "Answer a text editor for the given model." ^self theme newTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! longMessage: aStringOrText title: aString "Open a (long) message dialog." ^self theme longMessageIn: self text: aStringOrText title: aString! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText! ! !GroupWindowMorph methodsFor: 'windows' stamp: 'GaryChambers 6/9/2011 12:35'! newTabGroup "Answer a new tab group." ^(self newTabGroup: #()) cornerStyle: #square! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newDialogPanel "Answer a new main dialog panel." ^self theme newDialogPanelIn: self! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! chooseColor: aColor title: title "Answer the result of a color selector dialog with the given title and initial colour." ^self theme chooseColorIn: self title: title color: aColor! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: nil label: stringOrText help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newCancelButtonFor: aModel "Answer a new cancel button." ^self theme newCancelButtonIn: self for: aModel! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newPluggableDialogWindow: title for: contentMorph "Answer a new pluggable dialog with the given content." ^self theme newPluggableDialogWindowIn: self title: title for: contentMorph! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newOKButton "Answer a new OK button." ^self newOKButtonFor: self! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newGroupbox: aString for: control "Answer a groupbox with the given label and control." ^self theme newGroupboxIn: self label: aString for: control! ! !GroupWindowMorph methodsFor: 'layout' stamp: 'LaurentLaffont 2/16/2012 09:33'! changePropotionalLayout | layout | ((layout := self layoutPolicy) notNil and:[layout isProportionalLayout]) ifTrue:[^self]. "already proportional layout" self layoutPolicy: ProportionalLayout new. self layoutChanged.! ! !GroupWindowMorph methodsFor: 'windows' stamp: 'StephaneDucasse 8/4/2013 17:14'! onWindowLabelChanged: ann self tabGroup relabelPage: ann window with: (self tabLabelFor: ann window) ! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: aModel label: aString offset: 1 alpha: 0.5 getEnabled: enabledSel! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newYesButton "Answer a new Yes button." ^self newYesButtonFor: self! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText "Answer an editable drop list for the given model." ^self theme newEditableDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! chooseColor "Answer the result of a color selector dialog ." ^self chooseColor: Color black! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText "Answer a morph drop list for the given model." ^self newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: nil useIndex: true help: helpText! ! !GroupWindowMorph methodsFor: 'dropping/grabbing' stamp: 'PavelKrivaenk 4/19/2012 10:23'! wantsDroppedMorph: aMorph event: evt "Accept if a SystemWindow." self visible ifFalse: [^ false]. self dropEnabled ifFalse: [^ false]. (self tabGroup tabSelectorMorph bounds containsPoint: evt position) ifFalse: [^ false]. ^aMorph isSystemWindow! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newString: aStringOrText font: aFont style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: aFont style: aStyle! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText "Answer a list for the given model." ^self theme newListIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'layout' stamp: 'GaryChambers 6/9/2011 13:12'! acceptDroppingMorph: aSystemWindow event: evt "Add the window." self addWindow: aSystemWindow! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText "Answer a morph drop list for the given model." ^self newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: true help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText "Answer a drop list for the given model." ^self theme newDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newToolbar "Answer a toolbar." ^self theme newToolbarIn: self! ! !GroupWindowMorph methodsFor: 'windows' stamp: 'StephaneDucasse 8/4/2013 17:14'! addWindow: aSystemWindow "Add an existing window to the pages." |tab| SystemWindow topWindow = aSystemWindow ifTrue: [SystemWindow passivateTopWindow]. self tabGroup addPage: aSystemWindow configureForEmbedding label: (self tabLabelFor: aSystemWindow); selectedPageIndex: self tabGroup pages size. self isActive ifFalse: [self tabGroup selectedTab passivate]. tab := self tabGroup selectedTab. tab on: #startDrag send: #dragTab:event:in: to: self withValue: aSystemWindow. aSystemWindow announcer on: WindowLabelled send: #onWindowLabelChanged: to: self! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText "Answer a drop list for the given model." ^self newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: nil useIndex: true help: helpText! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! chooseFont: aFont "Answer the result of a font selector dialog with the given initial font." ^self theme chooseFontIn: self title: 'Font Selector' translated font: aFont! ! !GroupWindowMorph methodsFor: 'windows' stamp: 'EstebanLorenzano 5/14/2013 09:44'! offerWindowMenu "Popup the window menu. Fill from current workspace." | aMenu | aMenu := self buildWindowMenu. aMenu addLine; add: 'Grab window...' target: self action: #grabWindow. aMenu lastItem icon: Smalltalk ui icons smallWindowIcon. self tabGroup page ifNotNil: [: page | page model addModelItemsToWindowMenu: aMenu]. aMenu popUpEvent: self currentEvent in: self world! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newCloseButtonFor: aModel "Answer a new close button." ^self theme newCloseButtonIn: self for: aModel! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newVerticalSeparator "Answer a vertical separator." ^self theme newVerticalSeparatorIn: self! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! proceed: aStringOrText "Open a proceed dialog." ^self proceed: aStringOrText title: 'Proceed' translated! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! fileSave: title path: path "Answer the result of a file save open dialog with the given title." ^self fileSave: title extensions: nil path: path! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newHSVASelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVASelectorIn: self color: aColor help: helpText! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! deny: aStringOrText title: aString "Open a denial dialog." ^self theme denyIn: self text: aStringOrText title: aString! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newScrollPaneFor: aMorph "Answer a new scroll pane morph to scroll the given morph." ^self theme newScrollPaneIn: self for: aMorph! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! chooseColor: aColor "Answer the result of a color selector dialog with the given color." ^self theme chooseColorIn: self title: 'Colour Selector' translated color: aColor! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newPluggableDialogWindow "Answer a new pluggable dialog." ^self newPluggableDialogWindow: 'Dialog'! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! alert: aStringOrText title: aString configure: aBlock "Open an alert dialog. Configure the dialog with the 1 argument block before opening modally." ^self theme alertIn: self text: aStringOrText title: aString configure: aBlock! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newButtonLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new button text label." ^self theme newButtonLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newOKButtonFor: aModel "Answer a new OK button." ^self newOKButtonFor: aModel getEnabled: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newCancelButton "Answer a new cancel button." ^self newCancelButtonFor: self! ! !GroupWindowMorph methodsFor: 'dropping/grabbing' stamp: 'GaryChambers 6/10/2011 14:02'! dragTab: aSystemWindow event: anEvent in: aTabLabel "Drag a tab. Remove the window from the organiser and place in hand." self removeWindow: aSystemWindow. aSystemWindow position: anEvent targetPoint. anEvent hand grabMorph: aSystemWindow! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newString: aStringOrText style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: aStyle! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newHueSelector: aModel getHue: getSel setHue: setSel help: helpText "Answer a hue selector with the given selectors." ^self theme newHueSelectorIn: self for: aModel getHue: getSel setHue: setSel help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel ghostText: ghostText getEnabled: enabledSel help: helpText "Answer an editable drop list for the given model." ^self theme newEditableDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: String default: '' ghostText: ghostText getEnabled: enabledSel useIndex: false help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newGroupboxFor: control "Answer a plain groupbox with the given control." ^self theme newGroupboxIn: self for: control! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newOverflowRowForAll: aCollectionOfMorphs "Answer a new overflow row morph that provides a drop down for the given contents that are unable to fit the bounds." ^self theme newOverflowRowIn: self forAll: aCollectionOfMorphs! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newEmbeddedMenu "Answer a new menu." ^self theme newEmbeddedMenuIn: self for: self! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: 0 max: 1 quantum: nil getEnabled: nil help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText! ! !GroupWindowMorph methodsFor: 'windows' stamp: 'GaryChambers 6/10/2011 14:06'! tabLabelFor: aSystemWindow "Answer the tab label to use for the given page." ^self newRow: { (self newButtonLabel: (aSystemWindow labelString truncateWithElipsisTo: 40)) setBalloonText: aSystemWindow labelString. self newCloseControlFor: nil action: [self removeWindow: aSystemWindow] help: 'Close this tab and free the window'}! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! fileOpen: title "Answer the result of a file open dialog with the given title." ^self fileOpen: title extensions: nil! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! message: aStringOrText title: aString "Open a message dialog." ^self theme messageIn: self text: aStringOrText title: aString! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newTabGroup: labelsAndPages "Answer a tab group with the given tab labels associated with pages." ^self theme newTabGroupIn: self for: labelsAndPages! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText "Answer a morph list for the given model." ^self theme newMorphListIn: self for: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newNoButtonFor: aModel "Answer a new No button." ^self theme newNoButtonIn: self for: aModel! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion ! ! !GroupWindowMorph methodsFor: 'updating' stamp: 'LaurentLaffont 7/12/2011 23:00'! update: aSymbol with: anObject "Handle tab changes." super update: aSymbol. aSymbol == #selectedIndex ifTrue: [ |selectedPage| selectedPage := self tabGroup pages at: anObject ifAbsent: [nil]. selectedPage ifNotNil: [ selectedPage rememberKeyboardFocus: ActiveHand keyboardFocus. self tabGroup page ifNotNil: [self tabGroup page activate].] ]! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newImage: aForm size: aPoint "Answer a new image." ^self theme newImageIn: self form: aForm size: aPoint! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! chooseDropList: aStringOrText list: aList "Open a drop list chooser dialog." ^self chooseDropList: aStringOrText title: 'Choose' translated list: aList! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! textEntry: aStringOrText title: aString entryText: defaultEntryText "Open a text entry dialog." ^self theme textEntryIn: self text: aStringOrText title: aString entryText: defaultEntryText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newImage: aForm "Answer a new image." ^self theme newImageIn: self form: aForm! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel "Answer a text editor for the given model." ^self newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newImageFor: aModel get: getSel help: helpText "Answer a text entry for the given model." ^self theme newImageIn: self for: aModel get: getSel help: helpText! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! alert: aStringOrText title: aString "Open an alert dialog." ^self alert: aStringOrText title: aString configure: [:d | ]! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! alert: aStringOrText "Open an alert dialog." ^self alert: aStringOrText title: 'Alert' translated! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! proceed: aStringOrText title: aString "Open a proceed dialog and answer true if not cancelled, false otherwise." ^self theme proceedIn: self text: aStringOrText title: aString! ! !GroupWindowMorph methodsFor: 'testing' stamp: 'LaurentLaffont 7/5/2011 23:37'! isActive ^ false! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self theme newAutoAcceptTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel! ! !GroupWindowMorph methodsFor: 'accessing' stamp: 'GaryChambers 6/9/2011 12:36'! tabGroup: anObject tabGroup := anObject! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newBalloonHelp: aTextStringOrMorph for: aMorph "Answer a new balloon help with the given contents for aMorph at a given corner." ^self theme newBalloonHelpIn: self contents: aTextStringOrMorph for: aMorph corner: #bottomLeft! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector "Answer a new tree morph." ^self theme newTreeIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector! ! !GroupWindowMorph methodsFor: 'windows' stamp: 'EstebanLorenzano 7/6/2012 17:51'! removeWindow: aSystemWindow "Remove a window from the pages." aSystemWindow announcer unsubscribe: self. self tabGroup removePage: aSystemWindow. aSystemWindow configureForUnembedding. "self world addMorph: aSystemWindow" aSystemWindow delete. self tabGroup pages size = 0 ifTrue: [ self owner delete ]! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! abort: aStringOrText "Open an error dialog." ^self abort: aStringOrText title: 'Error' translated! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newColorPresenterFor: aModel getColor: getSel help: helpText "Answer a color presenter with the given selectors." ^self theme newColorPresenterIn: self for: aModel getColor: getSel help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText "Answer a bracket slider with the given selectors." ^self theme newBracketSliderIn: self for: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newButtonFor: aModel action: actionSel label: stringOrText help: helpText "Answer a new button." ^self newButtonFor: aModel getState: nil action: actionSel arguments: nil getEnabled: nil label: stringOrText help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newOKButtonFor: aModel getEnabled: enabledSel "Answer a new OK button." ^self theme newOKButtonIn: self for: aModel getEnabled: enabledSel! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText "Answer a morph list for the given model." ^self newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: nil help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newText: aStringOrText "Answer a new text." ^self theme newTextIn: self text: aStringOrText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel font: aFont help: helpText ! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText "Answer a drop list for the given model." ^self theme newDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: true help: helpText! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! fileSave: title extensions: exts path: path "Answer the result of a file save dialog with the given title, extensions to show and path." ^self theme fileSaveIn: self title: title extensions: exts path: path! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newNoButton "Answer a new No button." ^self newNoButtonFor: self! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newLabel: aString "Answer a new text label." ^self newLabelFor: nil label: aString getEnabled: nil! ! !GroupWindowMorph methodsFor: 'testing' stamp: 'LaurentLaffont 7/12/2011 23:00'! isWindowActive: aSystemWindow "Answer whether the given window is active. True if the receiver is active and the window is the current page." ^ self tabGroup page == aSystemWindow and: [aSystemWindow topWindow == aSystemWindow]! ! !GroupWindowMorph methodsFor: 'accessing' stamp: 'GaryChambers 6/9/2011 12:36'! tabGroup ^ tabGroup! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newHSVSelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVSelectorIn: self color: aColor help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newLabelGroup: labelsAndControls "Answer a morph laid out with a column of labels and a column of associated controls. Controls having a vResizing value of #spaceFill will cause their row to use #spaceFill also, otherwise #shrinkWrap." ^self theme newLabelGroupIn: self for: labelsAndControls! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newRow: controls "Answer a morph laid out with a row of controls." ^self theme newRowIn: self for: controls! ! !GroupWindowMorph methodsFor: 'events-processing' stamp: 'GaryChambers 6/9/2011 13:19'! handleDropMorph: anEvent "Handle a dropping morph." | aMorph | aMorph := anEvent contents. "Ignore whether the dropping morph wants to be dropped, just whether the receiver wants it" (self wantsDroppedMorph: aMorph event: anEvent) ifFalse: [^ self]. anEvent wasHandled: true. self acceptDroppingMorph: aMorph event: anEvent. aMorph justDroppedInto: self event: anEvent ! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel "Answer a text editor for the given model." ^self newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newTitle: aString for: control "Answer a morph laid out with a column with a title." ^self theme newTitleIn: self label: aString for: control! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newExpander: aString for: aControl "Answer an expander with the given label and control." ^self theme newExpanderIn: self label: aString forAll: {aControl}! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newMultistateButton "Answer a new multistate button morph. To be usable it needs to have fill styles assigned to various states along with mouse-up/down actions." ^self theme newMultistateButtonIn: self! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newWorkArea "Answer a new work area morph." ^self theme newWorkAreaIn: self! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! question: aStringOrText title: aString "Open a question dialog and answer true if yes, false if no and nil if cancelled." ^self theme questionIn: self text: aStringOrText title: aString! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newGroupboxForAll: controls "Answer a plain groupbox with the given controls." ^self theme newGroupboxIn: self forAll: controls! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newColumn: controls "Answer a morph laid out with a column of controls." ^self theme newColumnIn: self for: controls! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts path: path preview: preview "Answer the result of a file open dialog with the given title, extensions to show, path and preview type." ^self theme fileOpenIn: self title: title extensions: exts path: path preview: preview! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newToolDockingBar "Answer a tool docking bar." ^self theme newToolDockingBarIn: self! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! textEntry: aStringOrText title: aString "Open a text entry dialog." ^self textEntry: aStringOrText title: aString entryText: ''! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel help: helpText "Answer a text entry for the given model." ^self newTextEntryFor: aModel get: getSel set: setSel class: String getEnabled: nil help: helpText! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! chooseDirectory: title "Answer the result of a file dialog with the given title, answer a directory." ^self chooseDirectory: title path: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel getLabel: labelSel getEnabled: enabledSel! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! fileSave: title extensions: exts "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: exts path: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newSeparator "Answer an horizontal separator." ^self theme newSeparatorIn: self! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText "Answer a bracket slider with the given selectors." ^self newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: nil help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newExpander: aString "Answer an expander with the given label." ^self theme newExpanderIn: self label: aString forAll: #()! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newCloseControlFor: aModel action: aValuable help: helpText "Answer a new cancel button." ^self theme newCloseControlIn: self for: aModel action: aValuable help: helpText! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! chooseDropList: aStringOrText title: aString list: aList "Open a drop list chooser dialog." ^self theme chooseDropListIn: self text: aStringOrText title: aString list: aList! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! fileSave: title "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: nil path: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! question: aStringOrText "Open a question dialog." ^self question: aStringOrText title: 'Question' translated! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! textEntry: aStringOrText "Open a text entry dialog." ^self textEntry: aStringOrText title: 'Entry' translated! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText "Answer a list for the given model." ^self theme newListIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newGroupbox: aString forAll: controls "Answer a groupbox with the given label and controls." ^self theme newGroupboxIn: self label: aString forAll: controls! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newString: aStringOrText "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: #plain! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newExpander: aString forAll: controls "Answer an expander with the given label and controls." ^self theme newExpanderIn: self label: aString forAll: controls! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! questionWithoutCancel: aStringOrText title: aString "Open a question dialog and answer true if yes, false if no and nil if cancelled." ^self theme questionWithoutCancelIn: self text: aStringOrText title: aString! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newButtonLabel: aString "Answer a new button text label." ^self newButtonLabelFor: nil label: aString getEnabled: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newToolbar: controls "Answer a toolbar with the given controls." ^self theme newToolbarIn: self for: controls! ! !GroupWindowMorph methodsFor: 'updating' stamp: 'GaryChambers 6/10/2011 15:12'! update: aSymbol "Handle tab changes." super update: aSymbol. aSymbol == #selectedIndex ifTrue: [self tabGroup page activate]! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newToolSpacer "Answer a tool spacer." ^self theme newToolSpacerIn: self! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newFuzzyLabel: aString "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: nil label: aString offset: 1 alpha: 0.5 getEnabled: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newRow "Answer a morph laid out as a row." ^self theme newRowIn: self for: #()! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts "Answer the result of a file open dialog with the given title and extensions to show." ^self fileOpen: title extensions: exts path: nil! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newStack "Answer a morph laid out as a stack." ^self theme newStackIn: self for: #()! ! !GroupWindowMorph methodsFor: 'windows' stamp: 'GaryChambers 6/9/2011 12:45'! grabWindow "Request an existing window from the user and add it." |windows choice| windows := self world visibleSystemWindows. choice := UIManager default chooseFrom: (windows collect: [:e | e labelString]) values: windows lines: #() message: 'Choose a window to add to the organiser' translated title: 'Grab window' translated. choice ifNotNil: [self addWindow: choice]! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! chooseFileName: title extensions: exts path: path preview: preview "Answer the result of a file name chooser dialog with the given title, extensions to show, path and preview type." ^self theme chooseFileNameIn: self title: title extensions: exts path: path preview: preview! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText "Answer a checkbox (radio button appearance) with the given label." ^self newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: nil label: stringOrText help: helpText! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newYesButtonFor: aModel "Answer a new yes button." ^self theme newYesButtonIn: self for: aModel! ! !GroupWindowMorph methodsFor: 'controls' stamp: ''! newToolbarHandle "Answer a toolbar handle." ^self theme newToolbarHandleIn: self! ! !GroupWindowMorph methodsFor: 'services' stamp: ''! abort: aStringOrText title: aString "Open an error dialog." ^self theme abortIn: self text: aStringOrText title: aString! ! !GroupboxMorph commentStamp: 'gvc 5/18/2007 12:36'! Groupbox with title with a vertical layout. Appears in a lighter colour than the owner's pane colour.! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/12/2007 10:49'! initialColorInSystemWindow: aSystemWindow "Answer the colour the receiver should be when added to a SystemWindow." ^Color transparent! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 8/19/2006 16:31'! labelMorph: anObject "Set the value of labelMorph" labelMorph := anObject! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 15:34'! minExtent "Answer the minmum extent of the receiver. Based on label and rounding." ^super minExtent max: self labelMorph minExtent + (8@0)! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 8/19/2006 16:31'! contentMorph: anObject "Set the value of contentMorph" contentMorph := anObject! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 9/7/2013 12:39'! newContentMorph "Answer a new content morph" |p| p := PanelMorph new roundedCorners: self roundedCorners; changeTableLayout; layoutInset: 4; cellInset: 8; vResizing: #spaceFill; hResizing: #spaceFill. p borderStyle: (self theme groupPanelBorderStyleFor: p). ^p! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 12/11/2009 07:39'! roundedCorners: anArray "Set the corners to round." super roundedCorners: anArray. self contentMorph ifNotNil: [:cm | cm roundedCorners: self roundedCorners]! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/25/2008 14:39'! selectedTab "Answer the label morph for compatibility with TabPanelBorder." ^self labelMorph owner ifNotNil: [self labelMorph]! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/25/2008 14:55'! adoptPaneColor: paneColor "Pass on to the content morph." |c| paneColor ifNil: [^super adoptPaneColor: paneColor]. c := self theme subgroupColorFrom: paneColor. super adoptPaneColor: c. self contentMorph borderStyle: (self theme groupPanelBorderStyleFor: self). self labelMorph color: paneColor blacker muchDarker; backgroundColor: c; borderStyle: (self theme groupLabelBorderStyleFor: self)! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:55'! font: aFont "Set the label font" self labelMorph font: aFont! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/19/2010 16:21'! newLabelMorph "Answer a new label morph" ^TextMorph new roundedCorners: #(1 4); margins: (2@1 corner: 2 @ -1); contents: 'groupbox'; vResizing: #shrinkWrap; hResizing: #shrinkWrap; lock! ! !GroupboxMorph methodsFor: 'initialization' stamp: 'gvc 3/19/2010 16:21'! initialize "Initialize the receiver." super initialize. self roundedCorners: #(2 3 4); borderWidth: 0; changeTableLayout; cellPositioning: #topLeft; cellInset: 0 @ -1; reverseTableCells: true; labelMorph: self newLabelMorph; contentMorph: self newContentMorph; addMorphBack: self contentMorph; addMorphBack: self labelMorph! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 7/26/2011 10:13'! contentFromModel "Answer content from the model." ^self getContentSelector ifNotNil: [:s | self model ifNotNil: [:m | m perform: s]]! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 12/11/2009 07:39'! paneColorOrNil "Answer the window's pane color or nil otherwise." ^super paneColorOrNil ifNotNil: [:c | self theme subgroupColorFrom: c]! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/25/2008 14:31'! label: aString "Set the contents of the label morph." aString ifNil: [ self roundedCorners: #(1 2 3 4). self labelMorph delete. ^self]. self roundedCorners: #(2 3 4). self labelMorph owner ifNil: [ self addMorph: self labelMorph]. self labelMorph contents: aString! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/24/2007 10:05'! containsPoint: aPoint "Override here to check the label and content instead." ^(super containsPoint: aPoint) and: [ (self labelMorph containsPoint: aPoint) or: [ self contentMorph containsPoint: aPoint]]! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'GaryChambers 7/26/2011 10:11'! getContentSelector: anObject getContentSelector := anObject! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 7/26/2011 10:14'! update: aSymbol "Replace the content if appropriate." super update: aSymbol. aSymbol = self getContentSelector ifTrue: [ self contentFromModel ifNotNil: [:c | self replaceContentMorph: c]] ! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/20/2006 11:24'! addContentMorph: aMorph "Add a morph to the content." ^self contentMorph addMorphBack: aMorph! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 8/19/2006 16:31'! contentMorph "Answer the value of contentMorph" ^ contentMorph! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/20/2006 11:47'! cornerStyle: aSymbol "Pass on to list too." super cornerStyle: aSymbol. self labelMorph cornerStyle: aSymbol. self contentMorph cornerStyle: aSymbol! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'GaryChambers 7/26/2011 10:11'! getContentSelector ^ getContentSelector! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 12/7/2011 15:26'! replaceContentMorph: aMorph "Replace the content." self contentMorph removeAllMorphs; addMorphBack: aMorph. self adoptPaneColor: super paneColorOrNil. ^aMorph ! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 8/19/2006 16:31'! labelMorph "Answer the value of labelMorph" ^ labelMorph! ! !GroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/20/2006 11:26'! label "Answer the contents of the label morph." ^self labelMorph contents! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:55'! font "Answer the label font" ^self labelMorph font! ! !GroupsAlreadyExist commentStamp: ''! A GroupsAlreadyExists is fired when a set of groups already exists firstGroup points to a correct group which was part of the set! !GroupsAlreadyExist methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/24/2013 18:11'! groupName: anObject groupName := anObject! ! !GroupsAlreadyExist methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/24/2013 18:11'! groupName ^ groupName! ! !GroupsAlreadyExist class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 1/24/2013 18:11'! groupName: groupName ^ self new groupName: groupName; yourself! ! !GrowlMorph commentStamp: 'TudorGirba 10/25/2011 17:14'! A GrowlMorph is a little Morph to announce event happening. Freely inspired from the MIT Snarl developed by Tony Garnock-Jones. GrowlMorph new openInWorld 10 timesRepeat: [ (GrowlMorph openWithLabel: 'The time' contents: TimeStamp now) " vanishDelay: 1000; resetVanishTimer". World doOneCycle ] (GrowlMorph openWithLabel: 'The time' contents: TimeStamp now) actionBlock: [Transcript open]! !GrowlMorph methodsFor: 'stepping' stamp: 'StephaneDucasse 7/19/2011 19:45'! enabled ^ false! ! !GrowlMorph methodsFor: 'default' stamp: 'StephaneDucasse 7/16/2011 14:33'! defaultTextStyle ^ TextStyle actualTextStyles at: #Accuny! ! !GrowlMorph methodsFor: 'position' stamp: 'BenjaminVanRyseghem 3/2/2012 01:11'! unoccupiedPosition self class position = #bottomLeft ifTrue: [ ^ self unoccupiedPositionBottomLeft ]. self class position = #topRight ifTrue: [ ^ self unoccupiedPositionTopRight ]. self class position = #bottomRight ifTrue: [ ^ self unoccupiedPositionBottomRight ]. self class position = #topLeft ifTrue: [ ^ self unoccupiedPositionTopLeft ]. ^ 0@0 ! ! !GrowlMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 8/7/2011 18:10'! initializeContentsAttributes contentsAttr := TextColor color: self contentsColor. ! ! !GrowlMorph methodsFor: 'interaction' stamp: 'StephaneDucasse 7/19/2011 19:32'! handlesMouseDown: evt ^ actionBlock notNil or: [super handlesMouseDown: evt]! ! !GrowlMorph methodsFor: 'accessing' stamp: 'IgorStasenko 10/13/2013 18:32'! contentsColor ^ contentsColor ifNil: [ contentsColor := self theme growlContentsColorFor: self ] ! ! !GrowlMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/19/2012 23:34'! backgroundColor ^ backgroundColor ifNil: [ backgroundColor := self defaultBackgroundColor ]! ! !GrowlMorph methodsFor: 'initialization' stamp: 'TudorGirba 8/8/2011 11:32'! createDismissHandle | handle | handle := self theme growlDismissHandleFor: self. handle on: #mouseUp send: #delete to: self. ^ handle! ! !GrowlMorph methodsFor: 'internal' stamp: 'StephaneDucasse 7/19/2011 19:12'! resetAlpha ^ self alpha: 0.9! ! !GrowlMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 8/7/2011 17:02'! alpha ^ alpha ! ! !GrowlMorph methodsFor: 'initialization' stamp: 'tbn 7/10/2012 09:29'! initialize super initialize. self borderStyle: BorderStyle thinGray. self setProperty: #autoFitContents toValue: false. self initializeLabelAttributes. self initializeContentsAttributes. self vanishDelay: self defaultVanishDelay. self label: 'A cool title' contents: 'Here an important message'. dismissHandle := self createDismissHandle. self addMorph: dismissHandle! ! !GrowlMorph methodsFor: 'position' stamp: 'BenjaminVanRyseghem 3/2/2012 01:09'! unoccupiedPositionBottomRight | delta b morphs | delta := 0. TaskbarMorph showTaskbar ifTrue: [ delta := TaskbarMorph allInstances inject: 0 into: [:s :e | s + e height ]]. b := (World bottomRight - (self width@ (self height +delta))) extent: self extent. morphs := self class allSubInstances select: [:m | m world == World]. [self is: b saneWithRespectTo: morphs] whileFalse: [ b := b translateBy: 0@(-10). b top < 0 ifTrue: [^ World bottomRight - (self width@ (self height +delta))]]. ^ b origin! ! !GrowlMorph methodsFor: 'position' stamp: 'BenjaminVanRyseghem 3/2/2012 01:11'! unoccupiedPositionTopLeft | b morphs | b := World topLeft extent: self extent. morphs := self class allSubInstances select: [:m | m world == World]. [self is: b saneWithRespectTo: morphs] whileFalse: [ b := b translateBy: 0@10. b bottom > World height ifTrue: [^ World topLeft ]]. ^ b origin! ! !GrowlMorph methodsFor: 'default' stamp: 'BenjaminVanRyseghem 3/1/2012 23:35'! defaultVanishDelay ^ 1 seconds! ! !GrowlMorph methodsFor: 'position' stamp: 'BenjaminVanRyseghem 3/2/2012 01:10'! unoccupiedPositionBottomLeft | delta b morphs | delta := 0. TaskbarMorph showTaskbar ifTrue: [ delta := TaskbarMorph allInstances inject: 0 into: [:s :e | s + e height ]]. b := (World bottomLeft - (0@ (self height +delta))) extent: self extent. morphs := self class allSubInstances select: [:m | m world == World]. [self is: b saneWithRespectTo: morphs] whileFalse: [ b := b translateBy: 0@(-10). b top < 0 ifTrue: [^ World bottomLeft - (0@ (self height +delta))]]. ^ b origin! ! !GrowlMorph methodsFor: 'stepping' stamp: 'TudorGirba 10/25/2011 17:15'! stepTime ^ 100! ! !GrowlMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 8/7/2011 18:10'! initializeLabelAttributes labelAttr := TextColor color: self labelColor. ! ! !GrowlMorph methodsFor: 'default' stamp: 'TudorGirba 8/8/2011 11:21'! defaultBackgroundColor ^ self theme growlFillColorFor: self! ! !GrowlMorph methodsFor: 'accessing' stamp: 'IgorStasenko 10/13/2013 18:47'! alpha: newAlpha "self alpha = newAlpha ifTrue: [^ self]." alpha := newAlpha. labelAttr color: (self labelColor alpha: alpha). contentsAttr color: (self contentsColor alpha: alpha). self backgroundColor: (self nextColorStep: self backgroundColor). self allMorphsDo: [:m | m borderColor: (self nextColorStep: m borderColor). m color: (self nextColorStep: m color)]. self borderColor isTransparent ifTrue: [self delete].! ! !GrowlMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/2/2012 00:12'! contentsAttributes ^ { contentsAttr. TextAlignment centered. TextFontChange font2. }! ! !GrowlMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/2/2012 00:12'! labelAttributes ^ { labelAttr. TextAlignment centered. TextFontChange font4. TextEmphasis bold. }! ! !GrowlMorph methodsFor: 'accessing' stamp: 'IgorStasenko 10/13/2013 18:25'! labelColor ^ labelColor ifNil: [ labelColor := self theme growlLabelColorFor: self ]! ! !GrowlMorph methodsFor: 'internal' stamp: 'SvenVanCaekenberghe 11/18/2013 16:21'! resetVanishTimer vanishTime := DateAndTime now + self vanishDelay. self resetAlpha.! ! !GrowlMorph methodsFor: 'accessing' stamp: 'IgorStasenko 10/13/2013 18:45'! contentsColor: aColor "when you set this contentsColor, it takes precedence over theme one. In certain case (such as for green as in SUnit) it is needed, normally you do not need it." contentsColor := aColor. contentsAttr color: aColor. ! ! !GrowlMorph methodsFor: 'accessing' stamp: 'IgorStasenko 10/13/2013 18:43'! labelColor: aColor "when you set this labelColor, it takes precedence over theme one. In certain case (such as for green as in SUnit) it is needed, normally you do not need it." labelColor := aColor. labelAttr color: self labelColor.! ! !GrowlMorph methodsFor: 'internal' stamp: 'StephaneDucasse 7/19/2011 19:27'! openInWorld self position: self unoccupiedPosition. super openInWorld! ! !GrowlMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/1/2012 23:31'! vanishDelay: aDuration vanishDelay := aDuration. self resetVanishTimer! ! !GrowlMorph methodsFor: 'building' stamp: 'IgorStasenko 10/13/2013 18:54'! label: labelString contents: contentsString self streamDo: [ :w | w withAttributes: self labelAttributes do: [w nextPutAll: labelString asString; cr]. w withAttributes: self contentsAttributes do: [w nextPutAll: contentsString asString]. ].! ! !GrowlMorph methodsFor: 'stepping' stamp: 'SvenVanCaekenberghe 11/18/2013 16:21'! step (self containsPoint: ActiveHand position) ifTrue: [ self resetAlpha. ^ self]. vanishTime ifNotNil: [DateAndTime now < vanishTime ifTrue: [^self]]. self alpha: self alpha - 0.05.! ! !GrowlMorph methodsFor: 'default' stamp: 'StephaneDucasse 8/7/2011 18:18'! minimumExtent ^ 256@38! ! !GrowlMorph methodsFor: 'default' stamp: 'TudorGirba 8/8/2011 11:22'! defaultBorderColor ^ self theme growlBorderColorFor: self! ! !GrowlMorph methodsFor: 'stepping' stamp: 'StephaneDucasse 7/19/2011 19:03'! wantsSteps ^ true! ! !GrowlMorph methodsFor: 'internal' stamp: 'BenjaminVanRyseghem 3/2/2012 00:10'! streamDo: aBlock self contentsWrapped: (Text streamContents: aBlock). self extent: self minimumExtent. self height: (paragraph extent y + (self borderWidth * 2) + (margins ifNil: [0] ifNotNil: [margins top + margins bottom]) + 2). self vanishDelay: ((((self contents size /50)seconds)+1 seconds) max: self defaultVanishDelay).! ! !GrowlMorph methodsFor: 'interaction' stamp: 'StephaneDucasse 7/19/2011 19:35'! mouseDown: evt super mouseDown: evt. evt yellowButtonPressed ifTrue: [^ self]. actionBlock ifNotNil: [actionBlock valueWithPossibleArgs: { self }].! ! !GrowlMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/19/2011 19:01'! vanishDelay ^ vanishDelay! ! !GrowlMorph methodsFor: 'building' stamp: 'StephaneDucasse 7/19/2011 18:56'! contents: contentsString self streamDo: [ :w | w withAttributes: self contentsAttributes do: [w nextPutAll: contentsString asString]].! ! !GrowlMorph methodsFor: 'internal' stamp: 'StephaneDucasse 7/19/2011 19:28'! is: rect saneWithRespectTo: morphs morphs do: [:m | (m owner notNil and: [m bounds intersects: rect]) ifTrue: [^ false]]. ^ true! ! !GrowlMorph methodsFor: 'building' stamp: 'StephaneDucasse 7/19/2011 19:38'! actionBlock: aBlock actionBlock := aBlock! ! !GrowlMorph methodsFor: 'position' stamp: 'BenjaminVanRyseghem 3/2/2012 00:47'! unoccupiedPositionTopRight | b morphs | b := (World topRight - (self width @ 0)) extent: self extent. morphs := self class allSubInstances select: [:m | m world == World]. [self is: b saneWithRespectTo: morphs] whileFalse: [ b := b translateBy: 0@10. b bottom > World height ifTrue: [^ (World topRight - (self width @ 0))]]. ^ b origin! ! !GrowlMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 7/19/2011 19:21'! nextColorStep: aColor ^ aColor alpha: self alpha! ! !GrowlMorph class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 3/2/2012 01:06'! possiblePositions ^ #( bottomRight bottomLeft topRight topLeft )! ! !GrowlMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 7/19/2011 19:38'! openWithLabel: aString contents: contentString ^ (self label: aString contents: contentString) openInWorld! ! !GrowlMorph class methodsFor: 'position' stamp: 'tbn 3/27/2013 01:33'! position ^ Position ifNil: [ Position := #topRight ]! ! !GrowlMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 7/19/2011 19:38'! openWithContents: contentString ^ (self contents: contentString) openInWorld! ! !GrowlMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 7/19/2011 19:36'! contents: contentString ^ self new label: '' contents: contentString; yourself! ! !GrowlMorph class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 3/2/2012 01:05'! position: aSymbol (self possiblePositions includes: aSymbol) ifFalse: [ ^ self ]. Position := aSymbol! ! !GrowlMorph class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/19/2012 23:36'! openWithLabel: aString contents: contentString color: aColor ^ (self label: aString contents: contentString) backgroundColor: aColor; openInWorld! ! !GrowlMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 7/19/2011 19:17'! label: aString contents: contentString ^ self new label: aString contents: contentString; yourself! ! !GrowlMorph class methodsFor: 'instance creation' stamp: 'IgorStasenko 10/13/2013 18:33'! openWithLabel: aString contents: contentString backgroundColor: aColor labelColor: aLabelColor ^ (self label: aString contents: contentString) backgroundColor: aColor; labelColor: aLabelColor; contentsColor: aLabelColor; openInWorld! ! !GuideTest commentStamp: 'TorstenBergmann 1/31/2014 11:43'! Common superclass for tests of guidance through the filesystem! !GuideTest methodsFor: 'asserting' stamp: 'cwp 11/16/2009 10:46'! assertVisitedIs: anArray visited with: anArray do: [:entry :basename | self assert: entry reference basename = basename]! ! !GuideTest methodsFor: 'visitor' stamp: 'cwp 10/29/2009 21:54'! visitFile: aReference visited add: aReference.! ! !GuideTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/2/2012 11:43'! setUp visited := OrderedCollection new. filesystem := FileSystem memory. self setUpGreek! ! !GuideTest methodsFor: 'visitor' stamp: 'cwp 10/29/2009 21:54'! visitDirectory: aReference visited add: aReference.! ! !GuideTest class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/3/2012 09:43'! isAbstract ^ self name = #GuideTest! ! !HColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:58'! ColorComponentSelector showing a hue rainbow palette.! !HColorSelectorMorph methodsFor: 'protocol' stamp: 'gvc 9/3/2009 13:44'! defaultFillStyle "Answer the hue gradient." ^(GradientFillStyle colors: ((0.0 to: 359.9 by: 0.1) collect: [:a | Color h: a s: 1.0 v: 1.0])) origin: self topLeft; direction: (self bounds isWide ifTrue: [self width@0] ifFalse: [0@self height])! ! !HColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 14:13'! color: aColor "Ignore to preserve fill style." ! ! !HDChangeReport commentStamp: 'TorstenBergmann 2/12/2014 22:31'! A change report! !HDChangeReport methodsFor: 'accessing' stamp: 'lr 9/29/2010 13:27'! resolved ^ gofer resolved! ! !HDChangeReport methodsFor: 'generating' stamp: 'lr 9/29/2010 13:42'! generateChangeModification: aPatch on: aStream aStream tab; tab; tab; nextPutAll: ''; nextPutAll: (self encode: (self convert: aPatch summary)); nextPutAll: ''; nextPut: Character lf! ! !HDChangeReport methodsFor: 'generating' stamp: 'lr 9/29/2010 13:35'! generateChange: aPatch on: aStream aPatch isAddition ifTrue: [ ^ self generateChangeAddition: aPatch on: aStream ]. aPatch isModification ifTrue: [ ^ self generateChangeModification: aPatch on: aStream ]. aPatch isRemoval ifTrue: [ ^ self generateChangeRemoval: aPatch on: aStream ]! ! !HDChangeReport methodsFor: 'generating' stamp: 'lr 9/29/2010 14:07'! generateChangeSet: aResolvedVersion on: aStream | info | info := aResolvedVersion version info. aStream tab; nextPutAll: ''; nextPut: Character lf. aStream tab; tab; nextPutAll: ''; nextPutAll: (self encode: info date yyyymmdd); space; nextPutAll: (self encode: info time print24); nextPutAll: ''; nextPut: Character lf. aStream tab; tab; nextPutAll: ''; nextPutAll: (self encode: info author); nextPutAll: ''; nextPut: Character lf. aStream tab; tab; nextPutAll: ''; nextPutAll: (self encode: (self convert: info message)); nextPutAll: ''; nextPut: Character lf. "aStream tab; tab; nextPutAll: ''; nextPut: Character lf. (self changesFor: aResolvedVersion) do: [ :each | self generateChange: each on: aStream ]. aStream tab; tab; nextPutAll: ''; nextPut: Character lf." aStream tab; nextPutAll: ''; nextPut: Character lf! ! !HDChangeReport methodsFor: 'generating' stamp: 'lr 9/29/2010 13:42'! generateChangeAddition: aPatch on: aStream aStream tab; tab; tab; nextPutAll: ''; nextPutAll: (self encode: (self convert: aPatch summary)); nextPutAll: ''; nextPut: Character lf! ! !HDChangeReport methodsFor: 'accessing' stamp: 'lr 9/29/2010 13:42'! changesFor: aResolvedVersion | references patch | references := gofer allResolved select: [ :each | each packageName = aResolvedVersion packageName ]. patch := MCPatch fromBase: (references size > 1 ifTrue: [ (references at: references size - 1) version snapshot ] ifFalse: [ MCSnapshot empty ]) target: aResolvedVersion version snapshot. ^ patch operations asSortedCollection! ! !HDChangeReport methodsFor: 'running' stamp: 'S 6/17/2013 13:16'! run 'changelog.xml' asFileReference ensureDelete writeStreamDo: [ :stream| self generateOn: stream ]! ! !HDChangeReport methodsFor: 'generating' stamp: 'lr 9/29/2010 13:29'! generateOn: aStream aStream nextPutAll: ''; nextPut: Character lf. aStream nextPutAll: ''; nextPut: Character lf. self resolved do: [ :each | self generateChangeSet: each on: aStream ]. aStream nextPutAll: ''! ! !HDChangeReport methodsFor: 'initialization' stamp: 'lr 9/29/2010 11:22'! initializeOn: aCollection gofer := Gofer new. aCollection do: [ :each | gofer package: each ]! ! !HDChangeReport methodsFor: 'generating' stamp: 'lr 9/29/2010 13:41'! generateChangeRemoval: aPatch on: aStream aStream tab; tab; tab; nextPutAll: ''; nextPutAll: (self encode: (self convert: aPatch summary)); nextPutAll: ''; nextPut: Character lf! ! !HDChangeReport class methodsFor: 'running' stamp: 'lr 9/29/2010 11:13'! runClasses: aCollectionOfClasses named: aString self error: 'The change report is only runnable on packages.'! ! !HDChangeReport class methodsFor: 'running' stamp: 'lr 9/29/2010 11:14'! runPackages: aCollectionOfStrings ^ (self new initializeOn: aCollectionOfStrings) run! ! !HDChangeReport class methodsFor: 'running' stamp: 'lr 9/29/2010 11:14'! runPackage: aString ^ self runPackages: (Array with: aString)! ! !HDCoverageReport commentStamp: 'TorstenBergmann 2/12/2014 22:31'! Hudson report for test coverage! !HDCoverageReport methodsFor: 'private' stamp: 'EstebanLorenzano 1/25/2013 10:11'! addTestsIn: aTestAsserter to: aSet (aTestAsserter isKindOf: TestSuite) ifTrue: [ aTestAsserter tests do: [ :each | self addTestsIn: each to: aSet ] ]. (aTestAsserter isKindOf: TestCase) ifTrue: [ (aTestAsserter class respondsTo: #packageNamesUnderTest) ifTrue: [ aTestAsserter class packageNamesUnderTest do: [ :each | aSet add: (RPackage organizer packageNamed: each) ] ] ]. ^ aSet! ! !HDCoverageReport methodsFor: 'generating' stamp: 'lr 7/5/2010 08:24'! generate | coverage | covered := (wrappers select: [ :each | each hasRun ]) collect: [ :each | each reference ]. coverage := StandardFileStream forceNewFileNamed: suite name , '-Coverage.xml'. [ self generateOn: coverage ] ensure: [ coverage close ]! ! !HDCoverageReport methodsFor: 'generating' stamp: 'lr 7/5/2010 13:30'! generateDataOn: aStream | items | aStream tab; nextPutAll: ''; nextPut: Character lf. aStream tab; tab; nextPutAll: ''; nextPut: Character lf. self generateType: 'class' indent: 3 total: (items := (packages gather: [ :each | each classes ]) asSet) size actual: ((covered collect: [ :each | each actualClass theNonMetaClass ]) asSet count: [ :each | items includes: each ]) on: aStream. self generateType: 'method' indent: 3 total: (items := (packages gather: [ :each | each methods ]) asSet) size actual: (covered count: [ :each | items includes: each ]) on: aStream. packages do: [ :each | self generatePackage: each on: aStream ]. aStream tab; tab; nextPutAll: ''; nextPut: Character lf. aStream tab; nextPutAll: ''; nextPut: Character lf! ! !HDCoverageReport methodsFor: 'generating' stamp: 'lr 7/5/2010 13:26'! generatePackage: aPackage class: aClass on: aStream | items | aStream tab: 4; nextPutAll: ''; nextPut: Character lf. self generateType: 'class' indent: 5 total: 1 actual: ((covered anySatisfy: [ :each | each actualClass theNonMetaClass = aClass ]) ifTrue: [ 1 ] ifFalse: [ 0 ]) on: aStream. self generateType: 'method' indent: 5 total: (items := aPackage coreMethodsForClass: aClass) size actual: (covered count: [ :each | items includes: each ]) on: aStream. items do: [ :each | self generatePackage: each method: each on: aStream ]. aStream tab: 4; nextPutAll: ''; nextPut: Character lf! ! !HDCoverageReport methodsFor: 'generating' stamp: 'lr 7/5/2010 13:30'! generatePackage: aPackage on: aStream | items | aStream tab: 3; nextPutAll: ''; nextPut: Character lf. self generateType: 'class' indent: 4 total: (items := aPackage classes asSet) size actual: ((covered collect: [ :each | each actualClass theNonMetaClass ]) asSet count: [ :each | items includes: each ]) on: aStream. self generateType: 'method' indent: 4 total: (items := aPackage methods asSet) size actual: (covered count: [ :each | items includes: each ]) on: aStream. aPackage classes do: [ :class | self generatePackage: aPackage class: class on: aStream ]. aStream tab: 3; nextPutAll: ''; nextPut: Character lf! ! !HDCoverageReport methodsFor: 'generating' stamp: 'lr 7/5/2010 13:08'! generateStatsOn: aStream aStream tab; nextPutAll: ''; nextPut: Character lf. aStream tab; tab; nextPutAll: ''; nextPut: Character lf. aStream tab; tab; nextPutAll: ''; nextPut: Character lf. aStream tab; tab; nextPutAll: ''; nextPut: Character lf. aStream tab; nextPutAll: ''; nextPut: Character lf.! ! !HDCoverageReport methodsFor: 'private' stamp: 'lr 6/9/2010 10:58'! ignoredSelectors ^ #(packageNamesUnderTest classNamesNotUnderTest)! ! !HDCoverageReport methodsFor: 'running' stamp: 'lr 7/5/2010 08:22'! tearDown wrappers do: [ :each | each uninstall ]. super tearDown. self generate! ! !HDCoverageReport methodsFor: 'generating' stamp: 'lr 7/5/2010 13:09'! generateOn: aStream aStream nextPutAll: ''; nextPut: Character lf. aStream nextPutAll: ''; nextPut: Character lf. self generateStatsOn: aStream. self generateDataOn: aStream. aStream nextPutAll: ''; nextPut: Character lf! ! !HDCoverageReport methodsFor: 'running' stamp: 'lr 6/9/2010 19:30'! setUp super setUp. wrappers := ((packages := self packagesIn: suite) gather: [ :package | self methodsIn: package ]) collect: [ :each | HDTestCoverage on: each ]. wrappers do: [ :each | each install ]! ! !HDCoverageReport methodsFor: 'generating' stamp: 'CamilloBruni 7/20/2012 16:35'! generateType: aString indent: anInteger total: totalInteger actual: actualInteger on: aStream aStream tab: anInteger; nextPutAll: ''; nextPut: Character lf! ! !HDCoverageReport methodsFor: 'private' stamp: 'CamilloBruni 8/27/2013 01:40'! methodsIn: aPackage aPackage ifNil: [ ^ #() ]. ^ aPackage methods reject: [ :method | (self ignoredSelectors includes: method selector) or: [ method compiledMethod isAbstract or: [ method compiledMethod refersToLiteral: #ignoreForCoverage ] ] ]! ! !HDCoverageReport methodsFor: 'private' stamp: 'lr 6/9/2010 10:51'! packagesIn: aTestAsserter ^ self addTestsIn: aTestAsserter to: Set new! ! !HDCoverageReport methodsFor: 'generating' stamp: 'lr 7/5/2010 13:28'! generatePackage: aPackage method: aReference on: aStream | items | aStream tab: 5; nextPutAll: ''; nextPut: Character lf. self generateType: 'method' indent: 6 total: 1 actual: ((covered includes: aReference) ifTrue: [ 1 ] ifFalse: [ 0 ]) on: aStream. aStream tab: 5; nextPutAll: ''; nextPut: Character lf! ! !HDLintReport commentStamp: 'TorstenBergmann 2/12/2014 22:31'! Hudson report for lint results! !HDLintReport methodsFor: 'generating' stamp: 'lr 7/4/2010 22:35'! generateViolations: aCollection source: aString offset: aPoint on: aStream aCollection do: [ :rule | | interval start | interval := (rule result selectionIntervalFor: aString) ifNil: [ 1 to: aString size ]. start := self lineAndColumn: aString at: interval first. aStream tab; tab; nextPutAll: ''; nextPut: Character lf ]! ! !HDLintReport methodsFor: 'testing' stamp: 'lr 5/15/2010 14:05'! isClassEnvironment: anEnvironment ^ #(CategoryEnvironment ClassEnvironment VariableEnvironment) includes: anEnvironment class name! ! !HDLintReport methodsFor: 'generating' stamp: 'lr 7/4/2010 20:46'! generateClass: aClass selector: aSelector source: sourceStream on: aStream | offset source matching | offset := self lineAndColumn: sourceStream contents at: sourceStream position. sourceStream nextPutAll: (source := self convert: (aClass sourceCodeAt: aSelector)); nextPut: Character lf; nextPut: Character lf. matching := rules select: [ :each | (self isSelectorEnvironment: each result) and: [ each result includesSelector: aSelector in: aClass ] ]. self generateViolations: matching source: source offset: offset on: aStream! ! !HDLintReport methodsFor: 'generating' stamp: 'Anonymous 6/17/2013 13:16'! generateClass: aClass on: aStream | sourceStream sourceName | sourceStream := WriteStream on: String new. sourceName := environment name , '-' , aClass name , '.st'. aStream tab; nextPutAll: ''; nextPut: Character lf. self generateClass: aClass source: sourceStream on: aStream. self generateClass: aClass class source: sourceStream on: aStream. aStream tab; nextPutAll: ''; nextPut: Character lf. sourceName asFileReference ensureDelete writeStreamDo: [ :stream | stream nextPutAll: sourceStream contents ]! ! !HDLintReport methodsFor: 'accessing' stamp: 'MarcusDenker 4/20/2013 13:36'! rules ^rules! ! !HDLintReport methodsFor: 'running' stamp: 'Anonymous 6/17/2013 13:16'! run RBSmalllintChecker runRule: (RBCompositeLintRule rules: rules) onEnvironment: environment. (environment name , '-Lint.xml') asFileReference ensureDelete writeStreamDo: [ :stream| self generateOn: stream ]! ! !HDLintReport methodsFor: 'initialization' stamp: 'lr 7/4/2010 22:34'! initializeOn: anEnvironment environment := anEnvironment. rules := (RBCompositeLintRule rulesFor: RBBasicLintRule) reject: [ :each | each class name endsWith: 'SpellingRule' ]! ! !HDLintReport methodsFor: 'testing' stamp: 'lr 5/15/2010 14:05'! isSelectorEnvironment: anEnvironment ^ #(SelectorEnvironment ParseTreeEnvironment VariableEnvironment) includes: anEnvironment class name! ! !HDLintReport methodsFor: 'generating' stamp: 'lr 7/4/2010 21:17'! generateOn: aStream aStream nextPutAll: ''; nextPut: Character lf. aStream nextPutAll: ''; nextPut: Character lf. (environment allClasses asSortedCollection: [ :a :b | a name <= b name ]) do: [ :class | self generateClass: class on: aStream ]. aStream nextPutAll: ''! ! !HDLintReport methodsFor: 'generating' stamp: 'lr 7/4/2010 21:08'! generateClass: aClass source: sourceStream on: aStream | offset source matching selectors | offset := self lineAndColumn: sourceStream contents at: sourceStream position. sourceStream nextPutAll: (source := self convert: aClass definition); nextPut: Character lf; nextPut: Character lf. (environment definesClass: aClass) ifTrue: [ matching := rules select: [ :rule | (self isClassEnvironment: rule result) and: [ rule result includesClass: aClass ] ]. self generateViolations: matching source: source offset: offset on: aStream ]. (environment selectorsForClass: aClass) asSortedCollection do: [ :selector | self generateClass: aClass selector: selector source: sourceStream on: aStream ]! ! !HDLintReport methodsFor: 'private' stamp: 'lr 5/14/2010 22:29'! lineAndColumn: aString at: anInteger | line last stream | line := 1. last := 0. stream := aString readStream. [ (stream nextLine isNil or: [ anInteger <= stream position ]) ifTrue: [ ^ line @ (anInteger - last) ]. last := stream position. line := line + 1 ] repeat! ! !HDLintReport class methodsFor: 'running' stamp: 'Anonymous 7/15/2012 13:15'! runClasses: aCollectionOfClasses named: aString | classEnvironment | classEnvironment := RBBrowserEnvironment new forClasses: aCollectionOfClasses. classEnvironment label: aString. ^ self runEnvironment: classEnvironment! ! !HDLintReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:20'! runEnvironment: anEnvironment ^ self new initializeOn: anEnvironment; run! ! !HDLintReport class methodsFor: 'running' stamp: 'MarcusDenker 7/15/2012 13:16'! runPackage: aString | packageEnvironment | packageEnvironment := RBBrowserEnvironment new forPackageNames: (Array with: aString). packageEnvironment label: aString. ^ self runEnvironment: packageEnvironment! ! !HDReport commentStamp: 'TorstenBergmann 2/12/2014 22:30'! A Hudson report! !HDReport methodsFor: 'private' stamp: 'lr 5/14/2010 08:36'! encode: aString ^ ((aString asString copyReplaceAll: '&' with: '&') copyReplaceAll: '"' with: '"') copyReplaceAll: '<' with: '<'! ! !HDReport methodsFor: 'private' stamp: 'lr 5/15/2010 14:27'! convert: aString ^ (aString asString copyReplaceAll: (String with: Character cr with: Character lf) with: (String with: Character lf)) copyReplaceAll: (String with: Character cr) with: (String with: Character lf)! ! !HDReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:17'! runCategory: aString ^ self runClasses: (Smalltalk organization classesInCategory: aString) named: aString! ! !HDReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:17'! runCategories: aCollectionOfStrings ^ aCollectionOfStrings do: [ :each | self runCategory: each ]! ! !HDReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:15'! runClasses: aCollectionOfClasses named: aString self subclassResponsibility! ! !HDReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:17'! runPackages: aCollectionOfStrings ^ aCollectionOfStrings do: [ :each | self runPackage: each ]! ! !HDReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:16'! runPackage: aString self subclassResponsibility! ! !HDTestCoverage commentStamp: 'TorstenBergmann 2/12/2014 22:32'! Used to measure test coverage for Hudson reports! !HDTestCoverage methodsFor: 'testing' stamp: 'lr 7/6/2010 11:16'! hasRun ^ hasRun! ! !HDTestCoverage methodsFor: 'private' stamp: 'lr 7/6/2010 11:16'! doesNotUnderstand: aMessage ^ method perform: aMessage selector withArguments: aMessage arguments! ! !HDTestCoverage methodsFor: 'actions' stamp: 'CamilloBruni 8/27/2013 01:40'! install reference actualClass methodDict at: reference selector put: self. self flushCache! ! !HDTestCoverage methodsFor: 'accessing' stamp: 'lr 7/5/2010 08:24'! reference ^ reference! ! !HDTestCoverage methodsFor: 'private' stamp: 'CamilloBruni 8/27/2013 01:40'! flushCache reference selector flushCache. method flushCache! ! !HDTestCoverage methodsFor: 'evaluation' stamp: 'lr 7/6/2010 11:15'! run: aSelector with: anArray in: aReceiver self mark; uninstall. ^ aReceiver withArgs: anArray executeMethod: method! ! !HDTestCoverage methodsFor: 'accessing' stamp: 'lr 7/5/2010 08:23'! method ^ method! ! !HDTestCoverage methodsFor: 'private' stamp: 'lr 7/6/2010 11:16'! mark hasRun := true! ! !HDTestCoverage methodsFor: 'initialization' stamp: 'lr 7/6/2010 11:16'! initializeOn: aMethodReference hasRun := false. reference := aMethodReference. method := reference compiledMethod! ! !HDTestCoverage methodsFor: 'actions' stamp: 'CamilloBruni 8/27/2013 01:40'! uninstall reference actualClass methodDict at: reference selector put: method. self flushCache! ! !HDTestCoverage class methodsFor: 'instance creation' stamp: 'lr 6/9/2010 11:05'! on: aMethodReference ^ self new initializeOn: aMethodReference! ! !HDTestReport commentStamp: 'TorstenBergmann 2/12/2014 22:31'! Hudson report for test results! !HDTestReport methodsFor: 'private' stamp: 'CamilloBruni 11/4/2013 08:27'! stackTraceString: err of: aTestCase ^ String streamContents: [ :str | | context | context := err signalerContext. [ context isNil or: [ context receiver == aTestCase and: [ context methodSelector == #runCase ] ] ] whileFalse: [ str print: context; lf. context := context sender ] ] ! ! !HDTestReport methodsFor: 'running' stamp: 'IgorStasenko 1/6/2012 15:12'! done "just close the file" [ progressFile close ] on: Error do: []! ! !HDTestReport methodsFor: 'running' stamp: 'AndreiChis 10/7/2013 11:59'! serializeError: error of: aTestCase "We got an error from a test, let's serialize it so we can properly debug it later on..." | context testCaseMethodContext | context := error signalerContext. testCaseMethodContext := context findContextSuchThat: [ :ctx| ctx receiver == aTestCase and: [ ctx methodSelector == #performTest ]]. context := context copyTo: testCaseMethodContext. [ FuelOutStackDebugAction serializeTestFailureContext: context sender toFileNamed: aTestCase class name asString,'-', aTestCase selector, '.fuel' ] on: Error do: [:err| "simply continue..." ] ! ! !HDTestReport methodsFor: 'running' stamp: 'MaxLeske 11/6/2013 10:10'! tearDown suite resources do: [ :each | each reset ]. stream tab; nextPutAll: ''; lf. stream tab; nextPutAll: ''; lf. stream nextPutAll: ''. stream position: suitePosition. stream nextPutAll: ' failures="'; print: suiteFailures; nextPutAll: '" errors="'; print: suiteErrors; nextPutAll: '" time="'; print: suiteTime asMilliSeconds / 1000.0; nextPutAll: '">'. stream close. progressFile nextPutAll: 'finished running suite: '; nextPutAll: suite name; close! ! !HDTestReport methodsFor: 'running' stamp: 'lr 6/9/2010 20:01'! run Author uniqueInstance ifUnknownAuthorUse: 'hudson' during: [ [ self setUp. suiteTime := [ self runAll ] timeToRun ] ensure: [ self tearDown ] ]! ! !HDTestReport methodsFor: 'private' stamp: 'CamilloBruni 11/6/2013 21:33'! beginTestCase: aTestCase runBlock: aBlock | time | progressFile nextPutAll: 'starting testcase: ' ; nextPutAll: aTestCase class name; nextPutAll:'>>'; nextPutAll: aTestCase selector; nextPutAll: ' ... '; flush. time := aBlock timeToRun. stream tab; nextPutAll: ''; lf ! ! !HDTestReport methodsFor: 'private' stamp: 'CamilloBruni 11/4/2013 08:27'! writeFailure: error stack: stack suiteFailures := suiteFailures + 1. stream tab; tab; nextPutAll: ''; lf. stream nextPutAll: ''. "Now this is ugly. We want to update the time and the number of failures and errors, but still at the same time stream a valid XML. So remember this position and add some whitespace, that we can fill later." suitePosition := stream position - 1. stream nextPutAll: (String new: 100 withAll: $ ); lf. "Initialize the test resources." suite resources do: [ :each | each isAvailable ifFalse: [ each signalInitializationError ] ]! ! !HDTestReport methodsFor: 'running' stamp: 'MaxLeske 11/6/2013 10:03'! runCase: aTestCase | error stack | self beginTestCase: aTestCase runBlock: [ [ [ aTestCase runCase ] on: Halt , Error, TestFailure do: [ :err | error := err. aTestCase isExpectedFailure ifFalse: [self serializeError: error of: aTestCase]. stack := self stackTraceString: err of: aTestCase ]] on: TestSkip do: [ :err| "nothing to do..." ] ]. (error isNil or: [aTestCase isExpectedFailure]) ifFalse: [ (error isKindOf: TestFailure) ifTrue: [ self writeError: error stack: stack ] ifFalse: [ self writeFailure: error stack: stack ]]. self endTestCase! ! !HDTestReport methodsFor: 'private' stamp: 'CamilloBruni 11/4/2013 08:27'! writeError: error stack: stack suiteErrors := suiteErrors + 1. stream tab; tab; nextPutAll: ''; nextPutAll: (self encode: stack).! ! !HDTestReport methodsFor: 'initialization' stamp: 'IgorStasenko 1/6/2012 15:13'! initializeOn: aTestSuite suite := aTestSuite. suitePosition := suiteTime := suiteFailures := suiteErrors := 0. progressFile := StandardFileStream forceNewFileNamed: 'progress.log'! ! !HDTestReport methodsFor: 'running' stamp: 'JohanBrichau 10/25/2010 23:05'! runAll suite tests do: [ :each | each run: self ]! ! !HDTestReport class methodsFor: 'running' stamp: 'IgorStasenko 1/6/2012 15:12'! runSuite: aTestSuite ^ self new initializeOn: aTestSuite; run; done! ! !HDTestReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:16'! runClasses: aCollectionOfClasses named: aString | suite classes | suite := TestSuite named: aString. classes := (aCollectionOfClasses select: [ :each | (each includesBehavior: TestCase) and: [ each isAbstract not ] ]) asSortedCollection: [ :a :b | a name <= b name ]. classes isEmpty ifTrue: [ ^ self ]. classes do: [ :each | each addToSuiteFromSelectors: suite ]. ^ self runSuite: suite! ! !HDTestReport class methodsFor: 'running' stamp: 'CamilloBruni 8/30/2013 13:37'! runPackage: aString ^ self runClasses: (RPackage organizer packageNamed: aString) definedClasses named: aString! ! !HMAC commentStamp: ''! HMAC is a mechanism for message authentication using cryptographic hash functions. HMAC can be used with any iterative cryptographic hash function, e.g., MD5, SHA-1, in combination with a secret shared key. The cryptographic strength of HMAC depends on the properties of the underlying hash function. See RFC 2114.! !HMAC methodsFor: 'accessing' stamp: 'len 8/3/2002 02:06'! digestSize ^ hash hashSize! ! !HMAC methodsFor: 'accessing' stamp: 'StephaneDucasse 10/17/2009 17:15'! key: aByteArray key := aByteArray. key size > hash blockSize ifTrue: [ key := hash hashMessage: key ]. key size < hash blockSize ifTrue: [ key := key , (ByteArray new: hash blockSize - key size) ]! ! !HMAC methodsFor: 'accessing' stamp: 'len 10/16/2002 16:43'! digestMessage: aByteArray ^ hash hashMessage: (key bitXor: epad), (hash hashMessage: (key bitXor: ipad), aByteArray)! ! !HMAC methodsFor: 'initialization' stamp: 'StephaneDucasse 10/17/2009 17:15'! setHash: aHash hash := aHash. ipad := ByteArray new: aHash blockSize withAll: 54. epad := ByteArray new: aHash blockSize withAll: 92! ! !HMAC methodsFor: 'accessing' stamp: 'cmm 12/2/2006 14:57'! destroy key destroy! ! !HMAC methodsFor: 'printing' stamp: 'len 8/3/2002 02:08'! printOn: aStream aStream nextPutAll: 'HMAC-'; print: hash! ! !HMAC class methodsFor: 'instance creation' stamp: 'len 8/15/2002 01:42'! on: aHashFunction ^ self new setHash: aHashFunction! ! !HSVAColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:55'! Colour selector featuring a saturation/volume area, hue selection strip and alpha selection strip.! !HSVAColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 14:05'! hsvMorph: anObject "Set the value of hsvMorph" hsvMorph := anObject! ! !HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 13:44'! defaultColor "Answer the default color/fill style for the receiver." ^Color transparent ! ! !HSVAColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 14:05'! hsvMorph "Answer the value of hsvMorph" ^ hsvMorph! ! !HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 10:11'! newAColorMorph "Answer a new alpha color morph." ^AColorSelectorMorph new model: self; hResizing: #spaceFill; vResizing: #rigid; setValueSelector: #alphaSelected:; extent: 24@24! ! !HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 11:12'! selectedColor: aColor "Set the hue and sv components." self aMorph value: aColor alpha. self hsvMorph selectedColor: aColor asNontranslucentColor! ! !HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:58'! colorSelected: aColor "A color has been selected. Set the base color for the alpha channel." self aMorph color: aColor. self triggerSelectedColor! ! !HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 14:00'! newHSVColorMorph "Answer a new hue/saturation/volume color morph." ^HSVColorSelectorMorph new hResizing: #spaceFill; vResizing: #spaceFill; when: #colorSelected send: #colorSelected: to: self! ! !HSVAColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 14:05'! aMorph: anObject "Set the value of aMorph" aMorph := anObject! ! !HSVAColorSelectorMorph methodsFor: 'initialization' stamp: 'gvc 9/21/2006 16:47'! initialize "Initialize the receiver." super initialize. self extent: 180@168; changeTableLayout; cellInset: 4; aMorph: self newAColorMorph; hsvMorph: self newHSVColorMorph; addMorphBack: self hsvMorph; addMorphBack: self aMorph. self aMorph color: self hsvMorph selectedColor! ! !HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:57'! triggerSelectedColor "Trigger the event for the selected colour" self triggerEvent: #selectedColor with: self selectedColor! ! !HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 14:18'! selectedColor "Answer the selected color." ^self hsvMorph selectedColor alpha: self aMorph value! ! !HSVAColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 14:05'! aMorph "Answer the value of aMorph" ^ aMorph! ! !HSVAColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/22/2006 09:58'! alphaSelected: aFloat "The alpha has changed." self triggerSelectedColor! ! !HSVColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:55'! Colour selector featuring a saturation/volume area and a hue selection strip.! !HSVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/21/2006 13:30'! hMorph "Answer the value of hMorph" ^ hMorph! ! !HSVColorSelectorMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 12:25'! initialize "Initialize the receiver." super initialize. self borderWidth: 0; changeTableLayout; cellInset: 4; listDirection: #leftToRight; cellPositioning: #topLeft; svMorph: self newSVColorMorph; hMorph: self newHColorMorph; addMorphBack: self svMorph; addMorphBack: self hMorph; extent: 192@152; hue: 0.5! ! !HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 13:44'! defaultColor "Answer the default color/fill style for the receiver." ^Color transparent ! ! !HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/19/2006 12:33'! newHColorMorph "Answer a new hue color morph." ^HColorSelectorMorph new model: self; setValueSelector: #hue:; hResizing: #rigid; vResizing: #spaceFill; extent: 36@36! ! !HSVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 12:26'! svMorph "Answer the value of svMorph" ^ svMorph! ! !HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 12:54'! newSVColorMorph "Answer a new saturation/volume color morph." ^SVColorSelectorMorph new extent: 152@152; hResizing: #spaceFill; vResizing: #spaceFill; when: #colorSelected send: #colorSelected: to: self! ! !HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 16:23'! hue: aFloat "Set the hue in the range 0.0 - 1.0. Update the SV morph and hMorph." self hMorph value: aFloat. self svMorph color: (Color h: aFloat * 359.9 s: 1.0 v: 1.0)! ! !HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 13:38'! selectedColor: aColor "Set the hue and sv components." self hue: aColor hue / 360. self svMorph selectedColor: aColor! ! !HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 13:41'! selectedColor "Answer the selected color." ^self svMorph selectedColor! ! !HSVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/21/2006 13:30'! hMorph: anObject "Set the value of hMorph" hMorph := anObject! ! !HSVColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 12:26'! svMorph: anObject "Set the value of svMorph" svMorph := anObject! ! !HSVColorSelectorMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/21/2006 16:28'! colorSelected: aColor "A color has been selected. Make the hue match." "self hMorph value: aColor hue / 360. self svMorph basicColor: (Color h: aColor hue s: 1.0 v: 1.0)." self triggerEvent: #colorSelected with: aColor! ! !HTTPEncodingTest commentStamp: 'TorstenBergmann 2/5/2014 10:13'! SUnit tests for HTTPEncoding! !HTTPEncodingTest methodsFor: 'tests' stamp: 'SvenVanCaekenberghe 10/27/2013 11:45'! testEncodeForHTTP self assert: 'aa aa éé aa aa' urlEncoded = 'aa%20aa%20%C3%A9%C3%A9%20aa%20aa'! ! !HTTPEncodingTest methodsFor: '*Multilingual-OtherLanguages' stamp: 'SvenVanCaekenberghe 10/27/2013 11:55'! testPercentEncodingHiragana | hiraA hiraO hiraAO encodedHiraA encodedHiraO encodedHiraAO | "Make Japanese String from unicode. see http://www.unicode.org/charts/PDF/U3040.pdf" hiraA := (Character value: 16r3042) asString. "HIRAGANA LETTER A" hiraO := (Character value: 16r304A) asString. "HIRAGANA LETTER O" hiraAO := hiraA , hiraO. "Percent Encoded Japanese String" encodedHiraA := hiraA urlEncoded. self assert: encodedHiraA = '%E3%81%82'. encodedHiraO := hiraO urlEncoded. self assert: encodedHiraO = '%E3%81%8A'. encodedHiraAO := hiraAO urlEncoded. self assert: encodedHiraAO = '%E3%81%82%E3%81%8A'. "without percent encoded string" self assert: '' urlDecoded = ''. self assert: 'abc' urlDecoded = 'abc'. "latin1 character" "encoded latin1 string" self assert: '%61' urlDecoded = 'a'. self assert: '%61%62%63' urlDecoded = 'abc'. "encoded multibyte string" self assert: encodedHiraA urlDecoded = hiraA. self assert: encodedHiraAO urlDecoded = hiraAO. "mixed string" self assert: (encodedHiraAO , 'a') urlDecoded = (hiraAO , 'a'). self assert: ('a' , encodedHiraA) urlDecoded = ('a' , hiraA). self assert: ('a' , encodedHiraA , 'b') urlDecoded = ('a' , hiraA , 'b'). self assert: ('a' , encodedHiraA , 'b' , encodedHiraO) urlDecoded = ('a' , hiraA , 'b' , hiraO). self assert: (encodedHiraA , encodedHiraO , 'b' , encodedHiraA) urlDecoded = (hiraA , hiraO , 'b' , hiraA). "for Seaside" self assert: (encodedHiraA , '+' , encodedHiraO) urlDecoded = (hiraA , ' ' , hiraO)! ! !HTTPProgress commentStamp: ''! I am HTTPProgress, a notification to show progress when using HTTP. I include - total: The total size of the download/upload (if known) - amount: The completed amount of the download/upload (if known) Use #total:, #amount: or #amountLeft: to set the appropriate byte counts to indicate progress. Use #fraction or #percentage as a value that indicates progress. Total and amount are optional and can be nil. Test using #isEmpty. You can try HTTPProgress example. ! !HTTPProgress methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:47'! amount: byteCount "Set the amount of bytes that has already been transferred." amount := byteCount! ! !HTTPProgress methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:52'! isComplete "Answer true when I am complete, i.e. all bytes were transferred. When I am empty, I am also complete." ^ amount = total! ! !HTTPProgress methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:40'! percentage "Answer the percentage of total that has already been transferred. Can be nil. Should be between 0 and 100." ^ self isEmpty ifFalse: [ self fraction * 100 ]! ! !HTTPProgress methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:45'! isEmpty "Answer true if I do not contain a numerical progress indication." ^ amount isNil or: [ total isNil ]! ! !HTTPProgress methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:39'! amountLeft "Answer the amount that has not yet been transferred. Can be nil. Should be between 0 and total." ^ self isEmpty ifFalse: [ total - amount ]! ! !HTTPProgress methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:38'! total "Answer the total byte count to transfer. Can be nil." ^ total! ! !HTTPProgress methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:46'! printOn: stream "Print an extra progress percentage if available" super printOn: stream. self isEmpty ifFalse: [ stream space; print: self percentage rounded; nextPut: $% ]! ! !HTTPProgress methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:47'! total: byteCount "Set the total byte count to transfer" total := byteCount! ! !HTTPProgress methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:40'! fraction "Answer the fraction of total that has already been transferred. Can be nil. Should be between 0 and 1." ^ self isEmpty ifFalse: [ amount / total ]! ! !HTTPProgress methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:48'! amountLeft: byteCount "Set the amount that has not yet been transferred. Can be nil. Should be between 0 and total." ^ total ifNotNil: [ amount := total - byteCount ]! ! !HTTPProgress methodsFor: 'accessing' stamp: 'MarcusDenker 9/29/2013 09:45'! beComplete "Make me complete, i.e. indicate that all bytes were transferred." amount := total! ! !HTTPProgress methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:37'! amount "Answer the amount that has already been transferred. Can be nil. Should be between 0 and total." ^ amount! ! !HTTPProgress class methodsFor: 'examples' stamp: 'SvenVanCaekenberghe 9/16/2012 20:03'! example "self example" UIManager default informUserDuring: [ :bar | bar label: 'Transfer Demo...'. 1 second asDelay wait. [ 1 to: 20 do: [ :each | HTTPProgress signal: 'Transferring...' amount: each * 1024 total: 20*1024. (Delay forMilliseconds: 100) wait ] ] on: HTTPProgress do: [ :progress | bar label: progress printString. progress isEmpty ifFalse: [ bar current: progress percentage ]. progress resume ] ] ! ! !HTTPProgress class methodsFor: 'exceptioninstantiator' stamp: 'SvenVanCaekenberghe 9/16/2012 20:07'! signal: signalerText amount: amount total: total "Create and signal HTTPProgress with amount bytes transferred out of total. Use an additional signalerText." ^ self new amount: amount; total: total; signal: signalerText! ! !HTTPProgress class methodsFor: 'exceptioninstantiator' stamp: 'SvenVanCaekenberghe 9/16/2012 20:06'! signalAmount: amount total: total "Create and signal HTTPProgress with amount bytes transferred out of total." ^ self new amount: amount; total: total; signal! ! !HaloMorph commentStamp: ''! This morph provides a halo of handles for its target morph. Dragging, duplicating, rotating, and resizing to be done by mousing down on the appropriate handle. There are also handles for help and for a menu of infrequently used operations.! !HaloMorph methodsFor: 'private' stamp: 'FernandoOlivero 9/9/2013 01:51'! doRot: evt with: rotHandle "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." | degrees | evt hand obtainHalo: self. degrees := (evt cursorPoint - (target pointInWorld: target referencePosition)) degrees. degrees := degrees - angleOffset degrees. degrees := degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. degrees = 0.0 ifTrue: [self setColor: Color lightBlue toHandle: rotHandle] ifFalse: [self setColor: Color blue toHandle: rotHandle]. rotHandle submorphsDo: [:m | m color: rotHandle color contrastingForegroundColor]. self removeAllHandlesBut: rotHandle. self showingDirectionHandles ifFalse: [self showDirectionHandles: true addHandles: false]. self addDirectionHandles. target rotationDegrees: degrees. rotHandle position: evt cursorPoint - (rotHandle extent // 2). ! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 5/7/2010 22:52'! addHandles self addCircleHandles. ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 18:43'! simpleFudgeOffset "account for the difference in basicBoxes between regular and simple handles" ^ 0@0 ! ! !HaloMorph methodsFor: 'private' stamp: 'StephaneDucasse 12/29/2011 12:37'! addHandle: handleSpec on: eventName send: selector to: recipient "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." | handle aPoint | aPoint := self positionIn: haloBox horizontalPlacement: handleSpec horizontalPlacement verticalPlacement: handleSpec verticalPlacement. handle := self addHandleAt: aPoint color: (Color colorFrom: handleSpec color) icon: handleSpec iconSymbol on: eventName send: selector to: recipient. ^ handle! ! !HaloMorph methodsFor: 'private' stamp: 'FernandoOlivero 9/9/2013 01:51'! createHandleAt: aPoint color: aColor iconName: iconName | bou handle | bou := Rectangle center: aPoint extent: self handleSize asPoint. self gradientHalo ifTrue: [ handle := Morph newBounds: bou color: aColor. handle borderWidth: 1. handle useRoundedCorners. self setColor: aColor toHandle: handle] ifFalse: [handle := EllipseMorph newBounds: bou color: aColor]. "" handle borderColor: aColor muchDarker. handle wantsYellowButtonMenu: false. "" iconName isNil ifFalse: [| form | form := Smalltalk ui icons iconNamed: iconName ifNone: []. form isNil ifFalse: [| image | image := ImageMorph new. image form: form. image color: aColor contrastingForegroundColor. image lock. handle addMorphCentered: image]]. "" ^ handle! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 5/5/2010 13:36'! addCircleHandles | box | target isWorldMorph ifTrue: [^ self addHandlesForWorldHalos]. self removeAllMorphs. "remove old handles, if any" self bounds: (self worldBoundsForMorph: target renderedMorph). "update my size" box := self basicBox. target addHandlesTo: self box: box. self addName. growingOrRotating := false. self layoutChanged. self changed. ! ! !HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'! addFontEmphHandle: haloSpec (innerTarget isTextMorph) ifTrue: [self addHandle: haloSpec on: #mouseDown send: #chooseEmphasisOrAlignment to: innerTarget]! ! !HaloMorph methodsFor: 'initialization' stamp: 'AlainPlantec 5/5/2010 13:36'! initialize "initialize the state of the receiver" super initialize. growingOrRotating := false. self borderStyle: (SimpleBorder width: 2 color: self theme settings menuSelectionColor)! ! !HaloMorph methodsFor: 'meta-actions' stamp: 'StephaneDucasse 12/29/2011 12:36'! blueButtonDown: event "Transfer the halo to the next likely recipient" target ifNil:[^self delete]. event hand obtainHalo: self. positionOffset := event position - (target point: target position in: owner). "wait for drags or transfer" event hand waitForClicksOrDrag: self event: event selectors: { #transferHalo:. nil. nil. #dragTarget:. } threshold: 5.! ! !HaloMorph methodsFor: 'dropping/grabbing' stamp: 'stephane.ducasse 11/8/2008 19:38'! startDrag: evt with: dragHandle "Drag my target without removing it from its owner." self obtainHaloForEvent: evt andRemoveAllHandlesBut: dragHandle. positionOffset := dragHandle center - (target point: target position in: owner).! ! !HaloMorph methodsFor: 'testing' stamp: 'jm 7/16/97 06:54'! stepTime ^ 0 "every cycle" ! ! !HaloMorph methodsFor: 'events' stamp: 'MarcusDenker 12/2/2013 14:07'! popUpFor: aMorph event: evt "This message is sent by morphs that explicitly request the halo on a button click. Note: anEvent is in aMorphs coordinate frame." | hand anEvent | self flag: #workAround. "We should really have some event/hand here..." anEvent := evt isNil ifTrue: [hand := aMorph world ifNotNil: [:w | w activeHand]. hand ifNil: [hand := aMorph world primaryHand]. hand lastEvent transformedBy: (aMorph transformedFrom: nil)] ifFalse: [hand := evt hand. evt]. self target: aMorph. hand halo: self. hand world addMorphFront: self. positionOffset := anEvent position - (aMorph point: aMorph position in: owner). self startStepping. ! ! !HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:16'! directionArrowLength ^ 25! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 16:05'! addMenuHandle: haloSpec self addHandle: haloSpec on: #mouseDown send: #doMenu:with: to: self! ! !HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:49'! addRotateHandle: haloSpec (self addHandle: haloSpec on: #mouseDown send: #startRot:with: to: self) on: #mouseMove send: #doRot:with: to: self ! ! !HaloMorph methodsFor: 'events-processing' stamp: 'ar 10/10/2000 22:00'! rejectsEvent: anEvent "Return true to reject the given event. Rejecting an event means neither the receiver nor any of it's submorphs will be given any chance to handle it." (super rejectsEvent: anEvent) ifTrue:[^true]. anEvent isDropEvent ifTrue:[^true]. "never attempt to drop on halos" ^false! ! !HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:42'! magicAlpha: alpha self setProperty: #magicAlpha toValue: alpha. self changed.! ! !HaloMorph methodsFor: 'private' stamp: 'sw 10/28/1999 15:39'! addSimpleHandlesForWorldHalos "Nothing special at present here -- just use the regular handles. Cannot rotate or resize world" self addHandlesForWorldHalos ! ! !HaloMorph methodsFor: 'private' stamp: 'aoy 2/17/2003 01:27'! showDirectionHandles: wantToShow addHandles: needHandles directionArrowAnchor := wantToShow ifTrue: [target referencePositionInWorld "not nil means show"] ifFalse: [nil]. needHandles ifTrue: [self addHandles] ! ! !HaloMorph methodsFor: 'stepping' stamp: 'nk 6/27/2003 12:32'! step | newBounds | target ifNil: [^ self]. newBounds := target isWorldMorph ifTrue: [target bounds] ifFalse: [self localHaloBoundsFor: target renderedMorph]. newBounds = self bounds ifTrue: [^ self]. newBounds extent = self bounds extent ifTrue: [^ self position: newBounds origin]. growingOrRotating ifFalse: [submorphs size > 1 ifTrue: [self addHandles]]. "adjust halo bounds if appropriate" self bounds: newBounds! ! !HaloMorph methodsFor: 'private' stamp: 'StephaneDucasse 12/29/2011 12:52'! endInteraction "Clean up after a user interaction with the a halo control" | m | (target isInWorld not or: [owner isNil]) ifTrue: [^self]. [target isFlexMorph and: [target hasNoScaleOrRotation]] whileTrue: [m := target firstSubmorph. target removeFlexShell. target := m]. self isInWorld ifTrue: ["make sure handles show in front, even if flex shell added" self comeToFront. self addHandles]. ! ! !HaloMorph methodsFor: 'private' stamp: 'marcus.denker 11/20/2008 12:24'! doRecolor: evt with: aHandle "The mouse went down in the 'recolor' halo handle. Allow the user to change the color of the innerTarget" evt hand obtainHalo: self. (aHandle containsPoint: evt cursorPoint) ifFalse: "only do it if mouse still in handle on mouse up" [self delete. target addHalo: evt] ifTrue: [innerTarget changeColor]. self showingDirectionHandles ifTrue: [self addHandles]! ! !HaloMorph methodsFor: 'submorphs-add/remove' stamp: 'StephaneDucasse 12/29/2011 12:51'! delete "Delete the halo. Tell the target that it no longer has the halo; accept any pending edits to the name; and then actually delete myself" target ifNotNil: [target hasHalo: false]. super delete.! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 5/7/2010 23:34'! positionDirectionShaft: shaft "Position the shaft." | alphaRadians unitVector | "Pretty crude and slow approach at present, but a stake in the ground" alphaRadians := target heading degreesToRadians. unitVector := alphaRadians sin @ alphaRadians cos negated. shaft setVertices: {unitVector * 6 + directionArrowAnchor. "6 = radius of deadeye circle" unitVector * self directionArrowLength + directionArrowAnchor} ! ! !HaloMorph methodsFor: 'handles' stamp: 'AlainPlantec 12/6/2009 21:14'! addDebugHandle: handleSpec self class haloWithDebugHandle ifTrue: [self addHandle: handleSpec on: #mouseDown send: #doDebug:with: to: self] ! ! !HaloMorph methodsFor: 'handles' stamp: 'WilliamSix 1/14/2013 19:46'! addScaleHandle: haloSpec target shouldFlex ifTrue: [(self addHandle: haloSpec on: #mouseDown send: #startScale:with: to: self) on: #mouseMove send: #doScale:with: to: self]. "This or addGrowHandle:, but not both, will prevail at any one time" ! ! !HaloMorph methodsFor: 'meta-actions' stamp: 'ar 9/15/2000 16:42'! handlerForBlueButtonDown: anEvent "Blue button was clicked within the receiver" ^self! ! !HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:48'! addDragHandle: haloSpec (self addHandle: haloSpec on: #mouseDown send: #startDrag:with: to: self) on: #mouseMove send: #doDrag:with: to: self ! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 9/29/2004 19:56'! setDismissColor: evt with: dismissHandle "Called on mouseStillDown in the dismiss handle; set the color appropriately." | colorToUse | evt hand obtainHalo: self. colorToUse := (dismissHandle containsPoint: evt cursorPoint) ifFalse: [Color red muchLighter] ifTrue: [Color lightGray]. self setColor: colorToUse toHandle: dismissHandle. ! ! !HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:25'! showDirectionHandles: wantToShow self showDirectionHandles: wantToShow addHandles: true "called from menu" ! ! !HaloMorph methodsFor: 'private' stamp: 'StephaneDucasse 6/28/2013 11:26'! doGrow: evt with: growHandle "Called while the mouse is down in the grow handle" | newExtent extentToUse scale | evt hand obtainHalo: self. newExtent := (target pointFromWorld: (evt cursorPoint - positionOffset)) - target topLeft. evt shiftPressed ifTrue: [ scale := (newExtent x / (originalExtent x max: 1)) min: (newExtent y / (originalExtent y max: 1)). newExtent := (originalExtent x * scale) asInteger @ (originalExtent y * scale) asInteger ]. (newExtent x < 1 or: [newExtent y < 1 ]) ifTrue: [^ self]. target renderedMorph setExtentFromHalo: (extentToUse := newExtent). growHandle position: evt cursorPoint - (growHandle extent // 2). self layoutChanged. ! ! !HaloMorph methodsFor: 'halos and balloon help' stamp: 'WilliamSix 1/14/2013 19:45'! addSimpleHandlesTo: aHaloMorph box: aBox | aHandle | target isWorldMorph ifTrue: [^ self addSimpleHandlesForWorldHalos]. self removeAllMorphs. "remove old handles, if any" self bounds: (self worldBoundsForMorph: target renderedMorph). "update my size" self addHandleAt: (((aBox topLeft + aBox leftCenter) // 2) + self simpleFudgeOffset) color: Color paleBuff icon: #haloMoreHandlesIcon on: #mouseDown send: #addFullHandles to: self. aHandle := self addGraphicalHandle: #rotateIcon at: aBox bottomLeft on: #mouseDown send: #startRot:with: to: self. aHandle on: #mouseMove send: #doRot:with: to: self. target shouldFlex ifTrue: [(self addGraphicalHandle: #scaleIcon at: aBox bottomRight on: #mouseDown send: #startScale:with: to: self) on: #mouseMove send: #doScale:with: to: self] ifFalse: [(self addGraphicalHandle: #scaleIcon at: aBox bottomRight on: #mouseDown send: #startGrow:with: to: self) on: #mouseMove send: #doGrow:with: to: self]. growingOrRotating := false. self layoutChanged. self changed. ! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 12/11/2009 22:50'! handleSize ^ 20! ! !HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:35'! prepareToTrackCenterOfRotation: evt with: rotationHandle evt hand obtainHalo: self. evt shiftPressed ifTrue:[ self removeAllHandlesBut: rotationHandle. ] ifFalse:[ rotationHandle setProperty: #dragByCenterOfRotation toValue: true. self startDrag: evt with: rotationHandle ]. evt hand showTemporaryCursor: Cursor blank! ! !HaloMorph methodsFor: 'drawing' stamp: 'ar 8/8/2001 15:13'! drawSubmorphsOn: aCanvas | alpha | ((alpha := self magicAlpha) = 1.0) ifTrue:[^super drawSubmorphsOn: aCanvas]. ^super drawSubmorphsOn: (aCanvas asAlphaBlendingCanvas: alpha)! ! !HaloMorph methodsFor: 'handles' stamp: 'WilliamSix 1/14/2013 19:44'! addGrowHandle: haloSpec target shouldFlex ifFalse: [(self addHandle: haloSpec on: #mouseDown send: #startGrow:with: to: self) on: #mouseMove send: #doGrow:with: to: self] "This or addScaleHandle:, but not both, will prevail at any one time" ! ! !HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:28'! magicAlpha ^self valueOfProperty: #magicAlpha ifAbsent:[1.0]! ! !HaloMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:37'! veryDeepFixupWith: deepCopier "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. target := deepCopier references at: target ifAbsent: [target]. innerTarget := deepCopier references at: innerTarget ifAbsent: [innerTarget]. ! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 16:16'! addHelpHandle: haloSpec target balloonText ifNotNil: [(self addHandle: haloSpec on: #mouseDown send: #mouseDownOnHelpHandle: to: innerTarget) on: #mouseUp send: #deleteBalloon to: innerTarget] ! ! !HaloMorph methodsFor: 'handles' stamp: 'stephane.ducasse 11/8/2008 19:52'! addDupHandle: haloSpec "Add the halo that offers duplication, or, when shift is down, make-sibling" self addHandle: haloSpec on: #mouseDown send: #doDup:with: to: self ! ! !HaloMorph methodsFor: 'updating' stamp: 'di 11/17/2001 10:56'! changed "Quicker to invalidate handles individually if target is large (especially the world)" self extent > (200@200) ifTrue: [(target notNil and: [target ~~ self world]) ifTrue: ["Invalidate 4 outer strips first, thus subsuming separate damage." (self fullBounds areasOutside: target bounds) do: [:r | self invalidRect: r]]. self submorphsDo: [:m | m changed]] ifFalse: [super changed]. ! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 5/7/2010 22:38'! removeAllHandlesBut: aHandle "Remove all handles except aHandle." submorphs copy do: [:m | m == aHandle ifFalse: [m delete]] ! ! !HaloMorph methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 23:01'! haloEnclosesFullBounds ^ self class haloEnclosesFullBounds! ! !HaloMorph methodsFor: 'private' stamp: 'IgorStasenko 12/22/2012 03:09'! basicBox | aBox minSide anExtent w | minSide := 4 * self handleSize. anExtent := ((self width + self handleSize + 8) max: minSide) @ ((self height + self handleSize + 8) max: minSide). aBox := Rectangle center: self center extent: anExtent. w := self world ifNil:[target outermostWorldMorph]. ^ w ifNil: [aBox] ifNotNil: [aBox intersect: (w viewBox insetBy: 8@8) ifNone: [self error: 'should not happen' ]] ! ! !HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:33'! setCenterOfRotation: evt with: rotationHandle | localPt | evt hand obtainHalo: self. evt hand showTemporaryCursor: nil. (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[ localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center. innerTarget setRotationCenterFrom: localPt. ]. rotationHandle removeProperty: #dragByCenterOfRotation. self endInteraction ! ! !HaloMorph methodsFor: 'handles' stamp: 'AlainPlantec 12/11/2009 23:45'! addDismissHandle: handleSpec "Add the dismiss handle according to the spec, unless my target resists dismissal " | dismissHandle | target okayToAddDismissHandle ifTrue: [dismissHandle := self addHandle: handleSpec on: #mouseDown send: #mouseDownInDimissHandle:with: to: self. dismissHandle on: #mouseUp send: #maybeDismiss:with: to: self. dismissHandle on: #mouseDown send: #setDismissColor:with: to: self. dismissHandle on: #mouseMove send: #setDismissColor:with: to: self]! ! !HaloMorph methodsFor: 'private' stamp: 'StephaneDucasse 4/22/2012 16:19'! doMenu: evt with: menuHandle "Ask hand to invoke the halo menu for my inner target." | menu | self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil. target world displayWorld. menu := innerTarget buildHandleMenu: evt hand. innerTarget addTitleForHaloMenu: menu. menu popUpEvent: evt in: target world. ! ! !HaloMorph methodsFor: 'private' stamp: 'IgorStasenko 12/22/2012 03:09'! basicBoxForSimpleHalos | w | w := self world ifNil:[target outermostWorldMorph]. ^ ((self worldBoundsForMorph: target topRendererOrSelf) expandBy: self handleAllowanceForIconicHalos) intersect: (w bounds insetBy: 8@8) ifNone: [self error: 'should not happen' ] ! ! !HaloMorph methodsFor: 'private' stamp: 'MarcusDenker 11/7/2009 17:35'! addHandlesForWorldHalos "Add handles for world halos, like the man said" | box w | w := self world ifNil:[target world]. self removeAllMorphs. "remove old handles, if any" self bounds: target bounds. box := w bounds insetBy: 9. target addWorldHandlesTo: self box: box. self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName. growingOrRotating := false. self layoutChanged. self changed. ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 10/3/2001 00:21'! mouseDownInCollapseHandle: evt with: collapseHandle "The mouse went down in the collapse handle; collapse the morph" self obtainHaloForEvent: evt andRemoveAllHandlesBut: collapseHandle. self setDismissColor: evt with: collapseHandle! ! !HaloMorph methodsFor: 'private' stamp: 'BenComan 4/17/2014 21:32'! addNameBeneath: outerRectangle string: aString "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." | namePosition w | w := self world ifNil:[target world]. nameMorph := NameStringInHalo contents: aString font: StandardFonts haloFont. nameMorph wantsYellowButtonMenu: false. nameMorph color: Color black. nameMorph target: innerTarget. namePosition := outerRectangle bottomCenter - ((nameMorph width // 2) @ (self handleSize negated // 2 - 1)). nameMorph position: (namePosition min: w viewBox bottomRight - nameMorph extent y + 2). self addMorph: nameMorph. ^ nameMorph! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 5/7/2010 21:29'! startScale: evt with: scaleHandle "Initialize scaling of my target." self obtainHaloForEvent: evt andRemoveAllHandlesBut: scaleHandle. target prepareForScaling. growingOrRotating := true. positionOffset := 0@0. originalExtent := target extent ! ! !HaloMorph methodsFor: 'private' stamp: 'FernandoOlivero 9/9/2013 01:51'! doScale: evt with: scaleHandle "Update the scale of my target if it is scalable." | newHandlePos colorToUse | evt hand obtainHalo: self. newHandlePos := evt cursorPoint - (scaleHandle extent // 2). target scaleToMatch: newHandlePos. colorToUse := target scale = 1.0 ifTrue: [Color yellow] ifFalse: [Color orange]. self setColor: colorToUse toHandle: scaleHandle. scaleHandle submorphsDo: [:m | m color: colorToUse contrastingForegroundColor]. scaleHandle position: newHandlePos. ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 1/29/2000 18:36'! addHandleAt: aPoint color: aColor on: eventName send: selector to: recipient ^ self addHandleAt: aPoint color: aColor icon: nil on: eventName send: selector to: recipient ! ! !HaloMorph methodsFor: 'private' stamp: 'StephaneDucasse 5/23/2013 18:35'! addGraphicalHandleFrom: formKey at: aPoint "Add the supplied form as a graphical handle centered at the given point. Return the handle." | handle aForm | aForm := Smalltalk ui icons iconNamed: formKey ifNone: [ Smalltalk ui icons iconNamed: #solidMenuIcon ]. handle := ImageMorph new form: aForm; bounds: (Rectangle center: aPoint extent: aForm extent). handle wantsYellowButtonMenu: false. self addMorph: handle. handle on: #mouseUp send: #endInteraction to: self. ^ handle ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 18:42'! handleAllowanceForIconicHalos ^ 12! ! !HaloMorph methodsFor: 'wiw support' stamp: 'RAA 6/27/2000 19:12'! morphicLayerNumber "helpful for insuring some morphs always appear in front of or behind others. smaller numbers are in front" ^7 "Halos are very front-like things"! ! !HaloMorph methodsFor: 'accessing' stamp: 'jm 7/16/97 06:51'! target ^ target ! ! !HaloMorph methodsFor: 'initialization' stamp: 'gvc 3/17/2009 10:42'! defaultColor "Answer the default color/fill style for the receiver." ^Color transparent! ! !HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:32'! trackCenterOfRotation: anEvent with: rotationHandle (rotationHandle hasProperty: #dragByCenterOfRotation) ifTrue:[^self doDrag: anEvent with: rotationHandle]. anEvent hand obtainHalo: self. rotationHandle center: anEvent cursorPoint.! ! !HaloMorph methodsFor: 'geometry' stamp: 'di 9/26/2000 21:03'! position: pos "Halos display imprefectly if their coordinates are non-integral -- especially the direction handles." ^ super position: pos asIntegerPoint! ! !HaloMorph methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 23:02'! showBoundsInHalo ^ self class showBoundsInHalo! ! !HaloMorph methodsFor: 'events' stamp: 'ar 10/4/2000 19:26'! staysUpWhenMouseIsDownIn: aMorph ^ ((aMorph == target) or: [aMorph hasOwner: self])! ! !HaloMorph methodsFor: 'events' stamp: 'ar 10/10/2000 19:09'! transferHalo: event "Transfer the halo to the next likely recipient" target ifNil:[^self delete]. target transferHalo: (event transformedBy: (target transformedFrom: self)) from: target.! ! !HaloMorph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 16:54'! containsPoint: aPoint event: anEvent "Blue buttons are handled by the halo" (anEvent isMouse and:[anEvent isMouseDown and:[anEvent blueButtonPressed]]) ifFalse:[^super containsPoint: aPoint event: anEvent]. ^bounds containsPoint: anEvent position! ! !HaloMorph methodsFor: 'private' stamp: 'StephaneDucasse 2/9/2011 18:02'! doDup: evt with: dupHandle "Ask hand to duplicate my target." (target isKindOf: SelectionMorph) ifTrue: [^ target doDup: evt fromHalo: self handle: dupHandle]. self obtainHaloForEvent: evt andRemoveAllHandlesBut: dupHandle. self setTarget: (target duplicateMorph: evt). evt hand grabMorph: target. self step. "update position if necessary" evt hand addMouseListener: self. "Listen for the drop"! ! !HaloMorph methodsFor: 'accessing' stamp: 'sw 1/26/2000 15:36'! haloBox: aBox haloBox := aBox! ! !HaloMorph methodsFor: 'handles' stamp: 'ar 1/30/2001 23:32'! positionIn: aBox horizontalPlacement: horiz verticalPlacement: vert | xCoord yCoord | horiz == #left ifTrue: [xCoord := aBox left]. horiz == #leftCenter ifTrue: [xCoord := aBox left + (aBox width // 4)]. horiz == #center ifTrue: [xCoord := (aBox left + aBox right) // 2]. horiz == #rightCenter ifTrue: [xCoord := aBox left + ((3 * aBox width) // 4)]. horiz == #right ifTrue: [xCoord := aBox right]. vert == #top ifTrue: [yCoord := aBox top]. vert == #topCenter ifTrue: [yCoord := aBox top + (aBox height // 4)]. vert == #center ifTrue: [yCoord := (aBox top + aBox bottom) // 2]. vert == #bottomCenter ifTrue: [yCoord := aBox top + ((3 * aBox height) // 4)]. vert == #bottom ifTrue: [yCoord := aBox bottom]. ^ xCoord asInteger @ yCoord asInteger! ! !HaloMorph methodsFor: 'geometry' stamp: 'PavelKrivanek 12/3/2013 14:59'! worldBoundsForMorph: aMorph "Answer the rectangle to be used as the inner dimension of aMorph halos. Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle." | r | r := (self haloEnclosesFullBounds) ifFalse: [ aMorph boundsIn: nil ] ifTrue: [ aMorph fullBoundsInWorld ]. self showBoundsInHalo ifTrue: [ ^r expandBy: 2 ]. ^r! ! !HaloMorph methodsFor: 'private' stamp: 'sw 10/2/2001 22:35'! doGrab: evt with: grabHandle "Ask hand to grab my target." self obtainHaloForEvent: evt andRemoveAllHandlesBut: grabHandle. evt hand grabMorph: target. self step. "update position if necessary" evt hand addMouseListener: self. "Listen for the drop"! ! !HaloMorph methodsFor: 'copying' stamp: 'GuillermoPolito 8/9/2010 21:27'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. "target := target. Weakly copied" "innerTarget := innerTarget. Weakly copied" positionOffset := positionOffset veryDeepCopyWith: deepCopier. angleOffset := angleOffset veryDeepCopyWith: deepCopier. growingOrRotating := growingOrRotating veryDeepCopyWith: deepCopier. directionArrowAnchor := directionArrowAnchor. haloBox := haloBox. originalExtent := originalExtent. nameMorph := nameMorph. ! ! !HaloMorph methodsFor: 'accessing' stamp: 'jm 5/7/1998 15:42'! target: aMorph self setTarget: aMorph. target ifNotNil: [self addHandles]. ! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 5/7/2010 09:17'! doDebug: evt with: menuHandle "Ask hand to invoke the a debugging menu for my inner target. If shift key is down, immediately put up an inspector on the inner target" | menu | "self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil." self world displayWorld. evt shiftPressed ifTrue: [self delete. ^ innerTarget inspectInMorphic: evt]. menu := innerTarget buildDebugMenu: evt hand. menu addTitle: (innerTarget externalName truncateWithElipsisTo: 40). menu popUpEvent: evt in: self world! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 12/11/2009 22:49'! setColor: aColor toHandle: aHandle "private - change the color to the given handle, applying the alternate look if corresponds" aHandle color: aColor. self gradientHalo ifTrue: [| fill | fill := GradientFillStyle ramp: {0.0 -> aColor muchLighter. 1.0 -> aColor darker}. fill origin: aHandle topLeft. fill direction: aHandle extent. aHandle fillStyle: fill] ! ! !HaloMorph methodsFor: 'accessing' stamp: 'nk 6/12/2004 21:56'! setTarget: aMorph "Private!! Set the target without adding handles." target := aMorph topRendererOrSelf. innerTarget := target renderedMorph. innerTarget wantsDirectionHandles ifTrue: [self showDirectionHandles: true addHandles: false]. target hasHalo: true. ! ! !HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:41'! doDirection: anEvent with: directionHandle anEvent hand obtainHalo: self. self removeAllHandlesBut: directionHandle! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 8/28/2003 15:15'! addGraphicalHandle: formKey at: aPoint on: eventName send: selector to: recipient "Add the supplied form as a graphical handle centered at the given point, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." | handle | handle := self addGraphicalHandleFrom: formKey at: aPoint. handle on: eventName send: selector to: recipient. handle setBalloonText: (target balloonHelpTextForHandle: handle) translated. ^ handle ! ! !HaloMorph methodsFor: 'stepping' stamp: 'StephaneDucasse 5/27/2010 22:22'! localHaloBoundsFor: aMorph "aMorph may be in the hand and perhaps not in our world" | r | r := (self worldBoundsForMorph: aMorph) truncated. aMorph world = self world ifFalse: [^r]. ^((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated! ! !HaloMorph methodsFor: 'private' stamp: 'ar 6/12/2001 05:24'! setDirection: anEvent with: directionHandle "The user has let up after having dragged the direction arrow; now set the forward direction of the actual SketchMorph accordingly" anEvent hand obtainHalo: self. target setDirectionFrom: directionHandle center. self endInteraction! ! !HaloMorph methodsFor: 'private' stamp: 'aoy 2/15/2003 21:10'! maybeCollapse: evt with: collapseHandle "Ask hand to collapse my target if mouse comes up in it." evt hand obtainHalo: self. self delete. (collapseHandle containsPoint: evt cursorPoint) ifFalse: [ target addHalo: evt] ifTrue: [ target collapse]! ! !HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:43'! trackDirectionArrow: anEvent with: shaft anEvent hand obtainHalo: self. shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}. self layoutChanged! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 9/26/2004 19:39'! addHandleAt: aPoint color: aColor icon: iconName on: eventName send: selector to: recipient "Add a handle centered at the given point with the given color, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." | handle | handle := self createHandleAt: aPoint color: aColor iconName: iconName. self addMorph: handle. handle on: #mouseUp send: #endInteraction to: self. handle on: eventName send: selector to: recipient. handle setBalloonText: (target balloonHelpTextForHandle: handle) translated. ^ handle ! ! !HaloMorph methodsFor: 'events' stamp: 'tk 7/14/2001 11:04'! dragTarget: event "Begin dragging the target" | thePoint | thePoint := target point: event position - positionOffset from: owner. target setConstrainedPosition: thePoint hangOut: true. event hand newMouseFocus: self.! ! !HaloMorph methodsFor: 'menu' stamp: 'dgd 9/20/2004 19:35'! wantsYellowButtonMenu "Answer true if the receiver wants a yellow button menu" ^ false! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 5/7/2010 23:00'! startRot: evt with: rotHandle "Initialize rotation of my target if it is rotatable" self obtainHaloForEvent: evt andRemoveAllHandlesBut: rotHandle. target prepareForRotating. growingOrRotating := true. angleOffset := evt cursorPoint - (target pointInWorld: target referencePosition). angleOffset := Point r: angleOffset r degrees: angleOffset degrees - target rotationDegrees. ! ! !HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'! addFontStyleHandle: haloSpec (innerTarget isTextMorph) ifTrue: [self addHandle: haloSpec on: #mouseDown send: #chooseStyle to: innerTarget]! ! !HaloMorph methodsFor: 'accessing' stamp: 'dgd 9/9/2004 22:55'! wantsToBeTopmost "Answer if the receiver want to be one of the topmost objects in its owner" ^ true! ! !HaloMorph methodsFor: 'private' stamp: 'StephaneDucasse 6/28/2013 11:26'! doDrag: evt with: dragHandle | thePoint | evt hand obtainHalo: self. thePoint := target point: evt position - positionOffset from: owner. target setConstrainedPosition: thePoint hangOut: true. ! ! !HaloMorph methodsFor: 'handles' stamp: 'MarcusDenker 11/7/2009 21:51'! addGrabHandle: haloSpec "If appropriate, add the black halo handle for picking up the target" self addHandle: haloSpec on: #mouseDown send: #doGrab:with: to: self ! ! !HaloMorph methodsFor: 'private' stamp: 'IgorStasenko 1/2/2012 18:05'! obtainHaloForEvent: evt andRemoveAllHandlesBut: aHandle "Make sure the event's hand correlates with the receiver, and remove all handles except the given one. If nil is provided as the handles argument, the result is that all handles are removed. Note that any pending edits to the name-string in the halo are accepted at this time." evt hand obtainHalo: self. self removeAllHandlesBut: aHandle! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 12/13/2001 14:07'! addCollapseHandle: handleSpec "Add the collapse handle, with all of its event handlers set up, unless the target's owner is not the world or the hand." | collapseHandle | (target owner notNil "nil happens, amazingly" and: [target owner isWorldOrHandMorph]) ifFalse: [^ self]. collapseHandle := self addHandle: handleSpec on: #mouseDown send: #mouseDownInCollapseHandle:with: to: self. collapseHandle on: #mouseUp send: #maybeCollapse:with: to: self. collapseHandle on: #mouseMove send: #setDismissColor:with: to: self ! ! !HaloMorph methodsFor: 'private' stamp: 'adrian_lienhard 7/19/2009 17:34'! mouseDownInDimissHandle: evt with: dismissHandle evt hand obtainHalo: self. self removeAllHandlesBut: dismissHandle. self setColor: Color darkGray toHandle: dismissHandle. ! ! !HaloMorph methodsFor: 'event handling' stamp: 'tk 7/14/2001 11:04'! mouseMove: evt "Drag our target around" | thePoint | thePoint := target point: (evt position - positionOffset) from: owner. target setConstrainedPosition: thePoint hangOut: true.! ! !HaloMorph methodsFor: 'events-processing' stamp: 'nk 6/26/2002 07:19'! handleListenEvent: anEvent "We listen for possible drop events here to add back those handles after a dup/grab operation" (anEvent isMouse and:[anEvent isMove not]) ifFalse:[^ self]. "not interested" anEvent hand removeMouseListener: self. "done listening" (self world ifNil: [target world]) ifNil: [^ self]. self addHandles "and get those handles back"! ! !HaloMorph methodsFor: 'accessing' stamp: 'AlainPlantec 1/7/2010 22:09'! borderStyle "Answer the border style to use for the receiver. Depends on the target and on some settings." ^(target notNil and: [self showBoundsInHalo and: [target isWorldMorph not]]) ifTrue: [super borderStyle] ifFalse: [SimpleBorder width: 0 color: Color transparent]! ! !HaloMorph methodsFor: 'geometry testing' stamp: 'StephaneDucasse 9/4/2010 13:33'! containsPoint: aPoint "This method is overridden so that, once up, the handles will stay up as long as the mouse is within the box that encloses all the handles even if it is not over any handle or over its owner." ^ target ifNil: [super containsPoint: aPoint] ifNotNil: [false]! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 4/4/2006 16:56'! addDirectionHandles | centerHandle d w directionShaft patch patchColor crossHairColor | self showingDirectionHandles ifFalse: [^ self]. directionArrowAnchor := (target point: target referencePosition in: self world) rounded. patch := target imageFormForRectangle: (Rectangle center: directionArrowAnchor extent: 3@3). patchColor := patch colorAt: 1@1. (directionShaft := LineMorph newSticky makeForwardArrow) borderWidth: 2; borderColor: (Color green orColorUnlike: patchColor). self positionDirectionShaft: directionShaft. self addMorphFront: directionShaft. directionShaft setCenteredBalloonText: 'Set forward direction' translated; on: #mouseDown send: #doDirection:with: to: self; on: #mouseMove send: #trackDirectionArrow:with: to: self; on: #mouseUp send: #setDirection:with: to: self. d := 15. "diameter" w := 3. "borderWidth" crossHairColor := Color red orColorUnlike: patchColor. (centerHandle := EllipseMorph newBounds: (0@0 extent: d@d) color: Color transparent) borderWidth: w; borderColor: (Color blue orColorUnlike: patchColor); addMorph: (LineMorph from: (d//2)@w to: (d//2)@(d-w-1) color: crossHairColor width: 1) lock; addMorph: (LineMorph from: w@(d//2) to: (d-w-1)@(d//2) color: crossHairColor width: 1) lock; align: centerHandle bounds center with: directionArrowAnchor. centerHandle wantsYellowButtonMenu: false. self addMorph: centerHandle. centerHandle setCenteredBalloonText: 'Rotation center (hold down the shift key and drag from here to change it)' translated; on: #mouseDown send: #prepareToTrackCenterOfRotation:with: to: self; on: #mouseMove send: #trackCenterOfRotation:with: to: self; on: #mouseUp send: #setCenterOfRotation:with: to: self ! ! !HaloMorph methodsFor: 'private' stamp: 'MarcusDenker 11/7/2009 17:36'! addName "Add a name readout at the bottom of the halo." self addNameBeneath: self basicBox string: target externalName ! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 1/7/2010 22:09'! addFullHandles self addCircleHandles! ! !HaloMorph methodsFor: 'private' stamp: 'MarcusDenker 11/7/2009 18:52'! maybeDoDup: evt with: dupHandle evt hand obtainHalo: self. ^ self doDup: evt with: dupHandle! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 19:04'! showingDirectionHandles ^directionArrowAnchor notNil! ! !HaloMorph methodsFor: 'private' stamp: 'SeanDeNigris 5/22/2012 12:22'! maybeDismiss: evt with: dismissHandle "Ask hand to dismiss my target if mouse comes up in it." | confirmed | evt hand obtainHalo: self. (dismissHandle containsPoint: evt cursorPoint) ifTrue: [ target resistsRemoval ifTrue: [ confirmed := self confirm: 'Really throw this away?' translated. confirmed ifFalse: [^ self]]. evt hand removeHalo. self delete. target dismissViaHalo] ifFalse: [ self delete. target addHalo: evt]! ! !HaloMorph methodsFor: 'settings' stamp: 'MarcusDenker 10/26/2011 14:57'! gradientHalo ^ true! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 5/5/2010 18:03'! startGrow: evt with: growHandle "Initialize resizing of my target. Launch a command representing it, to support Undo" | botRt | self obtainHaloForEvent: evt andRemoveAllHandlesBut: growHandle. botRt := target point: target bottomRight in: owner. positionOffset := (self world viewBox containsPoint: botRt) ifTrue: [evt cursorPoint - botRt] ifFalse: [0@0]. originalExtent := target extent! ! !HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'! addFontSizeHandle: haloSpec (innerTarget isTextMorph) ifTrue: [self addHandle: haloSpec on: #mouseDown send: #chooseFont to: innerTarget]! ! !HaloMorph methodsFor: 'accessing' stamp: 'jm 5/22/1998 16:28'! innerTarget ^ innerTarget ! ! !HaloMorph methodsFor: 'event handling' stamp: 'sw 5/21/1998 15:41'! wantsKeyboardFocusFor: aSubmorph "to allow the name to be edited in the halo in the old tty way; when we morphic-text-ize the name editing, presumably this method should be removed" ^ true! ! !HaloMorph methodsFor: 'handles' stamp: 'MarcusDenker 9/13/2013 15:55'! addRecolorHandle: haloSpec "Add a recolor handle to the receiver, if appropriate" "since this halo now opens a more general properties panel, allow it in all cases" "innerTarget canSetColor ifTrue:" self addHandle: haloSpec on: #mouseUp send: #doRecolor:with: to: self.! ! !HaloMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/6/2009 21:07'! haloWithDebugHandle ^ HaloWithDebugHandle ifNil: [HaloWithDebugHandle := true]! ! !HaloMorph class methodsFor: 'halo theme' stamp: 'AlainPlantec 12/12/2009 09:43'! allHaloSpecsFromArray: anArray ^ anArray collect: [:quin | self haloSpecFromArray: quin]! ! !HaloMorph class methodsFor: 'halo theme' stamp: 'AlainPlantec 12/12/2009 09:55'! currentHaloSpecifications ^ CurrentHaloSpecifications ifNil: [self installHaloTheme: #iconicHaloSpecifications] ! ! !HaloMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 22:58'! haloEnclosesFullBounds: aBoolean HaloEnclosesFullBounds := aBoolean! ! !HaloMorph class methodsFor: 'halo theme' stamp: 'StephaneDucasse 2/19/2010 16:26'! simpleFullHaloSpecifications "This method gives the specs for the 'full' handles variant when simple halos are in effect" " self installHaloTheme: #simpleFullHaloSpecifications will result in the standard default halos being reinstalled" "NB: listed below in clockwise order" ^ #( " selector horiz vert color info icon key --------- ------ ----------- ------------------------------- ---------------" (addDebugHandle: right topCenter (blue veryMuchLighter) #haloDebugIcon) (addDismissHandle: left top (red muchLighter) #haloDismissIcon) (addRotateHandle: left bottom (blue) #haloRotIcon) (addMenuHandle: leftCenter top (red) #haloMenuIcon) (addGrabHandle: center top (black) #halograbIcon) (addDragHandle: rightCenter top (brown) #haloDragIcon) (addDupHandle: right top (green) #haloDupIcon) (addHelpHandle: center bottom (lightBlue) #haloHelpIcon') (addGrowHandle: right bottom (yellow) #haloScaleIcon) (addScaleHandle: right bottom (lightOrange) #haloScaleIcon) (addFewerHandlesHandle: left topCenter (paleBuff) #haloFewerHandlesIcon') (addFontSizeHandle: leftCenter bottom (lightGreen) #haloFontSizeIcon) (addFontStyleHandle: center bottom (lightRed) #haloFontStyleIcon) (addFontEmphHandle: rightCenter bottom (lightBrown darker) #haloFontEmphIcon) (addRecolorHandle: right bottomCenter (magenta darker) #haloRecolorIcon) ) ! ! !HaloMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 22:59'! showBoundsInHalo: aBoolean ShowBoundsInHalo := aBoolean! ! !HaloMorph class methodsFor: 'halo theme' stamp: 'StephaneDucasse 2/19/2010 16:26'! iconicHaloSpecifications "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" "self installHaloTheme: #iconicHaloSpecifications" ^ #( " selector horiz vert color info icon key --------- ------ ----------- ------------------------------- ---------------" (addCollapseHandle: left topCenter (tan) #haloCollapseIcon) (addDebugHandle: right topCenter (blue veryMuchLighter) #haloDebugIcon) (addDismissHandle: left top (red muchLighter) #haloDismissIcon) (addRotateHandle: left bottom (blue) #haloRotIcon) (addMenuHandle: leftCenter top (red) #haloMenuIcon) (addGrabHandle: center top (black) #haloGrabIcon) (addDragHandle: rightCenter top (brown) #haloDragIcon) (addDupHandle: right top (green) #haloDupIcon) (addHelpHandle: center bottom (lightBlue) #haloHelpIcon) (addGrowHandle: right bottom (yellow) #haloScaleIcon) (addScaleHandle: right bottom (lightOrange) #haloScaleIcon) (addFontSizeHandle: leftCenter bottom (lightGreen) #haloFontSizeIcon) (addFontStyleHandle: center bottom (lightRed) #haloFontStyleIcon) (addFontEmphHandle: rightCenter bottom (lightBrown darker) #haloFontEmphIcon) (addRecolorHandle: right bottomCenter (magenta darker) #haloRecolorIcon) ) ! ! !HaloMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 22:58'! showBoundsInHalo ^ ShowBoundsInHalo ifNil: [ShowBoundsInHalo := false]! ! !HaloMorph class methodsFor: 'halo theme' stamp: 'AlainPlantec 12/12/2009 09:54'! haloSpecificationsForWorld | desired | "Answer a list of HaloSpecs that describe which halos are to be used on a world halo, what they should look like, and where they should be situated" desired := #(addDebugHandle: addMenuHandle: addHelpHandle: addRecolorHandle:). ^ self currentHaloSpecifications select: [:spec | desired includes: spec addHandleSelector]! ! !HaloMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/6/2009 21:13'! haloWithDebugHandle: aBoolean HaloWithDebugHandle := aBoolean! ! !HaloMorph class methodsFor: 'halo theme' stamp: 'StephaneDucasse 2/20/2010 21:57'! initialize "self initialize" super initialize. self installHaloTheme: #iconicHaloSpecifications ! ! !HaloMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 22:58'! haloEnclosesFullBounds ^ HaloEnclosesFullBounds ifNil: [HaloEnclosesFullBounds := false]! ! !HaloMorph class methodsFor: 'halo theme' stamp: 'StephaneDucasse 2/19/2010 16:26'! classicHaloSpecifications "Non-iconic halos with traditional placements" " self installHaloTheme: #classicHaloSpecifications will result in the standard default halos being reinstalled" "NB: listed below in clockwise order" ^ #( " selector horiz vert color info icon key --------- ------ ----------- ------------------------------- ---------------" (addMenuHandle: left top (red) none) (addDismissHandle: leftCenter top (red muchLighter) #haloDismissIcon) (addGrabHandle: center top (black) none) (addDragHandle: rightCenter top (brown) none) (addDupHandle: right top (green) none) (addDebugHandle: right topCenter (blue veryMuchLighter) none) (addGrowHandle: right bottom (yellow) none) (addScaleHandle: right bottom (lightOrange) none) (addFontEmphHandle: rightCenter bottom (lightBrown darker) none) (addFontStyleHandle: center bottom (lightRed) none) (addFontSizeHandle: leftCenter bottom (lightGreen) none) (addRecolorHandle: right bottomCenter (magenta darker) none) (addRotateHandle: left bottom (blue) none)) ! ! !HaloMorph class methodsFor: 'halo theme' stamp: 'AlainPlantec 12/12/2009 09:39'! haloSpecFromArray: anArray | aColor | aColor := Color. anArray fourth do: [:sel | aColor := aColor perform: sel]. ^ HaloSpec new horizontalPlacement: anArray second verticalPlacement: anArray third color: aColor iconSymbol: anArray fifth addHandleSelector: anArray first ! ! !HaloMorph class methodsFor: 'halo theme' stamp: 'AlainPlantec 12/12/2009 09:52'! installHaloTheme: haloSpecificationsSelector ^ CurrentHaloSpecifications := self allHaloSpecsFromArray: (self perform: haloSpecificationsSelector). ! ! !HaloMorph class methodsFor: 'halo theme' stamp: 'StephaneDucasse 2/19/2010 16:26'! customHaloSpecifications "Intended for you to modify to suit your personal preference. What is implemented in the default here is just a skeleton; in comment at the bottom of this method are some useful lines you may wish to paste in to the main body here, possibly modifying positions, colors, etc.. Note that in this example, we include: Dismiss handle, at top-left Menu handle, at top-right Resize handle, at bottom-right Rotate handle, at bottom-left Drag handle, at top-center Recolor handle, at left-center. (this one is NOT part of the standard formulary -- it is included here to illustrate how to add non-standard halos) Note that the optional handles for specialized morphs, such as Sketch, Text, PasteUp, are also included" ^ #( (addDismissHandle: left top (red muchLighter) #haloDismissIcon) (addMenuHandle: right top (red) #haloMenuIcon) (addDragHandle: center top (brown) #haloDragIcon) (addGrowHandle: right bottom (yellow) #haloScaleIcon) (addScaleHandle: right bottom (lightOrange) #haloScaleIcon) (addRecolorHandle: left center (green muchLighter lighter) #haloRecolorIcon) (addFontSizeHandle: leftCenter bottom (lightGreen) #haloFontSizeIcon) (addFontStyleHandle: center bottom (lightRed) #haloFontStyleIcon) (addFontEmphHandle: rightCenter bottom (lightBrown darker) #haloFontEmphIcon) (addRotateHandle: left bottom (blue) #haloRotIcon) (addDebugHandle: right topCenter (blue veryMuchLighter) #haloDebugIcon) ) " Other useful handles... selector horiz vert color info icon key --------- ------ ----------- ------------------------------- --------------- (addTileHandle: left bottomCenter (lightBrown) #haloTileIcon) (addViewHandle: left center (cyan) #haloViewIcon) (addGrabHandle: center top (black) #haloGrabIcon) (addDragHandle: rightCenter top (brown) #haloDragIcon) (addDupHandle: right top (green) #haloDupIcon) (addHelpHandle: center bottom (lightBlue) #haloHelpIcon) (addFewerHandlesHandle: left topCenter (paleBuff) #haloFewerHandlesIcon) (addPaintBgdHandle: right center (lightGray) #haloPaintIcon) " ! ! !HaloSpec commentStamp: 'kfr 10/27/2003 16:23'! Sets spec's for how handles are layed out in a halo.! !HaloSpec methodsFor: 'accessing' stamp: 'sw 1/25/2000 18:41'! horizontalPlacement ^ horizontalPlacement! ! !HaloSpec methodsFor: 'actions' stamp: 'sw 1/25/2000 19:54'! addHandleSelector ^ addHandleSelector! ! !HaloSpec methodsFor: 'accessing' stamp: 'sw 1/25/2000 18:41'! iconSymbol ^ iconSymbol! ! !HaloSpec methodsFor: 'accessing' stamp: 'sw 1/25/2000 18:41'! verticalPlacement ^ verticalPlacement! ! !HaloSpec methodsFor: 'accessing' stamp: 'sw 1/25/2000 18:41'! color ^ color! ! !HaloSpec methodsFor: 'printing' stamp: 'sw 11/15/2001 16:31'! printOn: aStream "Add a textual printout representing the receiver to a stream" super printOn: aStream. aStream nextPutAll: ' (', addHandleSelector asString, ' ', iconSymbol asString, ')'! ! !HaloSpec methodsFor: 'setter' stamp: 'sw 1/25/2000 19:54'! horizontalPlacement: hp verticalPlacement: vp color: col iconSymbol: is addHandleSelector: sel horizontalPlacement := hp. verticalPlacement := vp. color:= col. iconSymbol := is asSymbol. addHandleSelector := sel! ! !Halt commentStamp: ''! Halt is provided to support Object>>halt.! !Halt methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2013 21:24'! signalerContext "specialized version to find the proper context to open the debugger on. This will find the first context whose method is no longer on Halt or Halt class nor is #halt method iteself." ^ signalContext findContextSuchThat: [ :context | (context receiver == self or: [ (context receiver == self class) or: [ context method selector = #halt ]]) not ]! ! !Halt methodsFor: 'priv handling' stamp: 'CamilloBruni 2/24/2013 20:37'! defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" ^ UIManager default unhandledErrorDefaultAction: self "^ UnhandledError signalForException: self" ! ! !Halt class methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2011 17:43'! haltIfBlockWithCallingObject: aBlock | callingObject | callingObject := thisContext sender sender receiver. (aBlock cull: callingObject) ifTrue: [self signal] ifFalse: [^ self].! ! !Halt class methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2011 17:18'! isCounting ^ callsUntilHaltOnCount > 0.! ! !Halt class methodsFor: 'halting' stamp: 'MarcusDenker 3/29/2012 13:14'! once "To enable, use self enableHaltOnce" self isHaltOnceEnabled ifTrue: [ self disableHaltOnce. ^ self signal]! ! !Halt class methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2011 17:19'! stopCounting callsUntilHaltOnCount := 0.! ! !Halt class methodsFor: 'halting' stamp: 'StephaneDucasse 10/20/2011 15:41'! halt: aString "backward compatible method with self halt:" self signal: aString! ! !Halt class methodsFor: 'once-enabling/disabling' stamp: 'SeanDeNigris 8/29/2011 16:04'! disableHaltOnce isHaltOnceEnabled := false.! ! !Halt class methodsFor: 'halting' stamp: 'SeanDeNigris 8/29/2011 12:16'! ifShiftPressed self if: [Sensor shiftPressed]! ! !Halt class methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2011 17:43'! haltIfCallChainContains: aSelector | cntxt | cntxt := thisContext. [cntxt sender isNil] whileFalse: [ cntxt := cntxt sender. (cntxt selector = aSelector) ifTrue: [self signal]].! ! !Halt class methodsFor: 'once-enabling/disabling' stamp: 'StephaneDucasse 11/2/2012 13:48'! enableHaltOnce "self enableHaltOnce" isHaltOnceEnabled := true.! ! !Halt class methodsFor: 'once-enabling/disabling' stamp: 'StephaneDucasse 8/29/2011 23:20'! isHaltOnceEnabled ^ isHaltOnceEnabled ifNil: [isHaltOnceEnabled := false]! ! !Halt class methodsFor: 'class initialization' stamp: 'StephaneDucasse 8/29/2011 23:22'! initialize isHaltOnceEnabled := false. callsUntilHaltOnCount := 1.! ! !Halt class methodsFor: 'halting' stamp: 'StephaneDucasse 10/20/2011 15:41'! halt "backward compatible method with self halt" self signal! ! !Halt class methodsFor: 'halting' stamp: 'StephaneDucasse 10/20/2011 15:42'! now: aString "set a breakpoint with some explanation" self signal: aString! ! !Halt class methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2011 17:24'! callsUntilHaltOnCount ^ callsUntilHaltOnCount.! ! !Halt class methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2011 17:24'! callsUntilHaltOnCount: anInteger callsUntilHaltOnCount := anInteger.! ! !Halt class methodsFor: 'halting' stamp: 'SeanDeNigris 8/29/2011 17:51'! if: condition "This is the typical message to use for inserting breakpoints during debugging. The argument can be one of the following: - a block: if the Block has one arg, the calling object is bound to that. - an expression - a selector: Halt if found in the call chain" condition isSymbol ifTrue: [ ^ self haltIfCallChainContains: condition ]. condition isBlock ifTrue: [ ^ self haltIfBlockWithCallingObject: condition]. condition ifTrue: [self signal].! ! !Halt class methodsFor: 'halting' stamp: 'SeanDeNigris 8/29/2011 10:43'! now self signal.! ! !Halt class methodsFor: 'halting' stamp: 'SeanDeNigris 8/29/2011 17:59'! onCount: anInteger "Halt on the anInteger-th time through" | currentCount | currentCount := self isCounting ifTrue: [ self callsUntilHaltOnCount ] ifFalse: [ anInteger ]. self callsUntilHaltOnCount: currentCount - 1. self callsUntilHaltOnCount = 0 ifTrue: [ self signal ].! ! !HandBugs methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2013 20:23'! testTargetPoint "self new testTargetPoint" "self run: #testTargetPoint" ActiveHand targetPoint! ! !HandMorph commentStamp: ''! The cursor may be thought of as the HandMorph. The hand's submorphs hold anything being carried by dragging. There is some minimal support for multiple hands in the same world.! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:28'! mouseListeners ^mouseListeners! ! !HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:49'! savePatchFrom: aCanvas "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." | damageRect myBnds | damageRect := myBnds := self fullBounds. savedPatch ifNotNil: [damageRect := myBnds merge: (savedPatch offset extent: savedPatch extent)]. (savedPatch isNil or: [savedPatch extent ~= myBnds extent]) ifTrue: ["allocate new patch form if needed" savedPatch := aCanvas form allocateForm: myBnds extent]. aCanvas contentsOfArea: (myBnds translateBy: aCanvas origin) into: savedPatch. savedPatch offset: myBnds topLeft. ^damageRect! ! !HandMorph methodsFor: 'events-processing' stamp: 'StephaneDucasse 12/26/2011 10:49'! showMouseFocusEvent: evt ShowEvents == true ifTrue: [ | ofs| ofs := (owner hands indexOf: self) - 1 * 60. self mouseFocus printString displayAt: (0@ofs) + (0@15)]. ! ! !HandMorph methodsFor: 'focus handling' stamp: 'nk 2/14/2004 18:44'! mouseFocus: aMorphOrNil mouseFocus := aMorphOrNil! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'! releaseKeyboardFocus "Release the current keyboard focus unconditionally" self newKeyboardFocus: nil. ! ! !HandMorph methodsFor: 'selected object' stamp: 'ClementBera 7/30/2013 11:06'! selectedObject "answer the selected object for the hand or nil is none" | halo | halo := self halo. halo ifNil: [^ nil]. ^ halo target renderedMorph! ! !HandMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 12/26/2011 10:18'! initialize super initialize. self initForEvents. keyboardFocus := nil. mouseFocus := nil. bounds := 0@0 extent: Cursor normal extent. damageRecorder := DamageRecorder new. cachedCanvasHasHoles := false. temporaryCursor := temporaryCursorOffset := nil. self initForEvents.! ! !HandMorph methodsFor: 'event handling' stamp: 'ar 9/25/2000 14:27'! noticeMouseOver: aMorph event: anEvent mouseOverHandler ifNil:[^self]. mouseOverHandler noticeMouseOver: aMorph event: anEvent.! ! !HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:11'! pasteBuffer: aMorphOrNil "Set the contents of the paste buffer." PasteBuffer := aMorphOrNil. ! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 9/14/2000 11:22'! dropMorphs: anEvent "Drop the morphs at the hands position" self submorphsReverseDo:[:m| "Drop back to front to maintain z-order" self dropMorph: m event: anEvent. ].! ! !HandMorph methodsFor: 'halo handling' stamp: 'GabrielOmarCotelli 11/30/2013 16:46'! obtainHalo: aHalo "Used for transfering halos between hands" self halo == aHalo ifTrue: [ ^ self ]. "Find former owner" self world hands detect: [ :hand | hand halo == aHalo ] ifFound: [ :formerOwner | formerOwner releaseHalo: aHalo ]. self halo: aHalo! ! !HandMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:43'! cursorPoint "Implemented for allowing embedded worlds in an event cycle to query a hand's position and get it in its coordinates. The same can be achieved by #point:from: but this is simply much more convenient since it will look as if the hand is in the lower world." | pos | pos := self position. (ActiveWorld isNil or: [ActiveWorld == owner]) ifTrue: [^pos]. ^ActiveWorld point: pos from: owner! ! !HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:42'! sendFocusEvent: anEvent to: focusHolder clear: aBlock "Send the event to the morph currently holding the focus" | result w | w := focusHolder world ifNil:[^ aBlock value]. w becomeActiveDuring:[ ActiveHand := self. ActiveEvent := anEvent. result := focusHolder handleFocusEvent: (anEvent transformedBy: (focusHolder transformedFrom: self)). ]. ^result! ! !HandMorph methodsFor: 'cursor' stamp: 'ClementBera 7/30/2013 11:06'! showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset "Set the temporary cursor to the given Form. If the argument is nil, revert to the normal hardware cursor." self changed. temporaryCursorOffset ifNotNil: [bounds := bounds translateBy: temporaryCursorOffset negated]. cursorOrNil ifNil: [temporaryCursor := temporaryCursorOffset := hardwareCursor := nil] ifNotNil: [temporaryCursor := cursorOrNil asCursorForm. temporaryCursorOffset := temporaryCursor offset - hotSpotOffset. (cursorOrNil isKindOf: Cursor) ifTrue: [hardwareCursor := cursorOrNil]]. bounds := self cursorBounds. self layoutChanged; changed! ! !HandMorph methodsFor: 'events-processing' stamp: 'BenjaminVanRyseghem 6/25/2013 17:43'! handleEvent: anEvent | evt | owner ifNil:[^self]. evt := anEvent. self logEventStats: evt. evt isMouse ifTrue:[ "just for record, to be used by capture block" lastMouseEvent := evt]. captureBlock ifNotNil: [ ^ captureBlock value: anEvent ]. evt isMouseOver ifTrue:[^self sendMouseEvent: evt]. self showDebugEvent: evt. "Notify listeners" self sendListenEvent: evt to: self eventListeners. evt isWindowEvent ifTrue: [ self sendEvent: evt focus: nil. ^self mouseOverHandler processMouseOver: lastMouseEvent]. evt isKeyboard ifTrue:[ self sendListenEvent: evt to: self keyboardListeners. self sendKeyboardEvent: evt. ^self mouseOverHandler processMouseOver: lastMouseEvent]. evt isDropEvent ifTrue:[ self sendEvent: evt focus: nil. ^self mouseOverHandler processMouseOver: lastMouseEvent]. evt isMouse ifTrue:[ self sendListenEvent: evt to: self mouseListeners. lastMouseEvent := evt]. "Check for pending drag or double click operations." mouseClickState ifNotNil:[ (mouseClickState handleEvent: evt from: self) ifFalse:[ "Possibly dispatched #click: or something and will not re-establish otherwise" ^self mouseOverHandler processMouseOver: lastMouseEvent]]. evt isMove ifTrue:[ | pos | pos := evt position. evt isDraggingEvent ifTrue: [ | treshold | treshold := 0. (self submorphs at: 1 ifAbsent: [ nil ]) ifNotNil: [ :first | treshold := self top-first top ]. pos y < (self class upperHandLimit+treshold) ifTrue: [ pos := pos x @ (self class upperHandLimit + treshold)] ]. self position: pos. self sendMouseEvent: evt. ] ifFalse:[ "Issue a synthetic move event if we're not at the position of the event" (evt position = self position) ifFalse:[self moveToEvent: evt]. "Drop submorphs on button events" (self hasSubmorphs) ifTrue:[self dropMorphs: evt] ifFalse:[self sendMouseEvent: evt]. ]. self showMouseFocusEvent: evt. self mouseOverHandler processMouseOver: lastMouseEvent. ! ! !HandMorph methodsFor: 'focus handling' stamp: 'ClementBera 7/30/2013 11:06'! newMouseFocus: aMorph event: event aMorph ifNotNil: [targetOffset := event cursorPoint - aMorph position]. ^self newMouseFocus: aMorph! ! !HandMorph methodsFor: 'drawing' stamp: 'nk 10/24/2003 22:12'! visible: aBoolean self needsToBeDrawn ifFalse: [ ^self ]. super visible: aBoolean! ! !HandMorph methodsFor: '*SUnit-UITesting' stamp: 'GuillermoPolito 3/19/2013 19:12'! simulateKeyStroke: aCharacterOrShortcut | shortcut | shortcut := aCharacterOrShortcut asKeyCombination. self handleEvent: (KeyboardEvent new setType: #keystroke buttons: shortcut modifier eventCode position: self position keyValue: shortcut key asciiValue charCode: shortcut key asciiValue hand: self activeHand stamp: DateAndTime now).! ! !HandMorph methodsFor: 'private events' stamp: 'AlainPlantec 1/7/2010 19:44'! sendKeyboardEvent: anEvent "Send the event to the morph currently holding the focus, or if none to the owner of the hand." ^ self sendEvent: anEvent focus: self keyboardFocus clear: [self keyboardFocus: nil]! ! !HandMorph methodsFor: 'drawing' stamp: 'ClementBera 7/30/2013 11:06'! drawOn: aCanvas "Draw the hand itself (i.e., the cursor)." temporaryCursor ifNil: [aCanvas paintImage: NormalCursor at: bounds topLeft] ifNotNil: [aCanvas paintImage: temporaryCursor at: bounds topLeft]. ! ! !HandMorph methodsFor: 'accessing' stamp: 'ar 10/5/2000 23:17'! lastEvent ^ lastMouseEvent! ! !HandMorph methodsFor: 'drop shadows' stamp: ''! shadowOffset ^ 6@8! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:32'! newMouseFocus: aMorphOrNil "Make the given morph the new mouse focus, canceling the previous mouse focus if any. If the argument is nil, the current mouse focus is cancelled." self mouseFocus: aMorphOrNil. ! ! !HandMorph methodsFor: '*EventModel' stamp: 'IgorStasenko 1/22/2012 18:18'! handleKeyboardInputEvent: sysEvent "For the moment just to give a try, working on generateKeyboardEvent2: " | stamp charCode keyValue keyEvent | recentModifiers := sysEvent modifiers. sysEvent isKeyDown ifTrue: [ lastKeyScanCode := sysEvent charCode]. keyValue := sysEvent charCode. charCode := sysEvent utf32Code. "Adjustments to provide consistent key value data for different VM's: - charCode always contains unicode code point. - keyValue contains 0 if input is outside legacy range" "If there is no unicode data in the event, assume keyValue contains a correct (<256) Unicode codepoint, and use that" (charCode isNil or: [charCode = 0]) ifTrue: [charCode := keyValue]. "If charCode is not single-byte, we definately have Unicode input. Nil keyValue to avoid garbage values from som VMs." charCode > 255 ifTrue: [keyValue := 0]. " This should be checked... sysEvent isKeyStroke ifTrue: [ combinedChar ifNil: [ (CombinedChar isCompositionCharacter: charCode) ifTrue: [ combinedChar := CombinedChar new. combinedChar simpleAdd: charCode asCharacter. ^ nil ]. ] ifNotNil: [ (combinedChar simpleAdd: charCode asCharacter) ifTrue: [charCode := combinedChar combined charCode]. combinedChar := nil] ]. " sysEvent isMouseWheel ifTrue: [^MouseWheelEvent new setType: #mouseWheel position: lastMouseEvent cursorPoint direction: (charCode = 30 ifTrue: [#up] ifFalse: [#down]) buttons: sysEvent buttons hand: self stamp: sysEvent timeStamp]. keyEvent := KeyboardEvent new setType: sysEvent pressType buttons: sysEvent buttons position: self position keyValue: keyValue charCode: charCode hand: self stamp: sysEvent timeStamp. keyEvent scanCode: lastKeyScanCode. ^keyEvent ! ! !HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:45'! sendMouseEvent: anEvent "Send the event to the morph currently holding the focus, or if none to the owner of the hand." ^self sendEvent: anEvent focus: self mouseFocus clear:[self mouseFocus: nil]! ! !HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 17:15'! spawnBalloonFor: aMorph aMorph showBalloon: aMorph balloonText hand: self.! ! !HandMorph methodsFor: 'drawing' stamp: 'StephaneDucasse 12/26/2011 10:19'! restoreSavedPatchOn: aCanvas "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." | cursor | hasChanged := false. savedPatch ifNotNil: [aCanvas drawImage: savedPatch at: savedPatch offset. submorphs notEmpty ifTrue: [^self]. (temporaryCursor notNil and: [hardwareCursor isNil]) ifTrue: [^self]. "Make the transition to using hardware cursor. Clear savedPatch and report one final damage rectangle to erase the image of the software cursor." super invalidRect: (savedPatch offset extent: savedPatch extent + self shadowOffset) from: self. cursor := hardwareCursor ifNil: [Cursor normal]. cursor isCurrent ifFalse: [cursor show]. "show hardware cursor" savedPatch := nil]! ! !HandMorph methodsFor: 'accessing' stamp: 'tk 10/20/2004 15:54'! anyButtonPressed ^lastMouseEvent anyButtonPressed! ! !HandMorph methodsFor: 'events-processing' stamp: 'StephaneDucasse 12/26/2011 10:45'! logEventStats: evt EventStats ifNil:[EventStats := IdentityDictionary new]. EventStats at: #count put: (EventStats at: #count ifAbsent:[0]) + 1. EventStats at: evt type put: (EventStats at: evt type ifAbsent:[0]) + 1.! ! !HandMorph methodsFor: 'drawing' stamp: 'ls 4/3/2000 20:30'! hasChanged "Return true if this hand has changed, either because it has moved or because some morph it is holding has changed." ^ hasChanged ifNil: [ true ] ! ! !HandMorph methodsFor: 'accessing' stamp: ''! targetOffset "Return the offset of the last mouseDown location relative to the origin of the recipient morph. During menu interactions, this is the absolute location of the mouse down event that invoked the menu." ^ targetOffset ! ! !HandMorph methodsFor: 'accessing' stamp: 'tk 10/20/2004 15:54'! noButtonPressed "Answer whether any mouse button is not being pressed." ^self anyButtonPressed not! ! !HandMorph methodsFor: 'drawing' stamp: 'StephaneDucasse 12/26/2011 10:19'! needsToBeDrawn "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden." "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor and shadow from the display." | cursor | (savedPatch notNil or: [ (submorphs anySatisfy: [ :ea | ea visible ]) or: [ (temporaryCursor notNil and: [hardwareCursor isNil]) ]]) ifTrue: [ "using the software cursor; hide the hardware one" Cursor blank isCurrent ifFalse: [Cursor blank show]. ^ true]. "Switch from one hardware cursor to another, if needed." cursor := hardwareCursor ifNil: [Cursor normal]. cursor isCurrent ifFalse: [cursor show]. ^ false ! ! !HandMorph methodsFor: 'private events' stamp: 'dgd 3/31/2003 18:22'! generateDropFilesEvent: evtBuf "Generate the appropriate mouse event for the given raw event buffer" "Note: This is still in an experimental phase and will need more work" | position buttons modifiers stamp numFiles dragType | stamp := evtBuf second. stamp = 0 ifTrue: [stamp := Time millisecondClockValue]. dragType := evtBuf third. position := evtBuf fourth @ evtBuf fifth. buttons := 0. modifiers := evtBuf sixth. buttons := buttons bitOr: (modifiers bitShift: 3). numFiles := evtBuf seventh. dragType = 4 ifTrue: ["e.g., drop" owner borderWidth: 0. ^DropFilesEvent new setPosition: position contents: numFiles hand: self]. "the others are currently not handled by morphs themselves" dragType = 1 ifTrue: ["experimental drag enter" owner borderWidth: 4; borderColor: owner color asColor negated]. dragType = 2 ifTrue: ["experimental drag move" ]. dragType = 3 ifTrue: ["experimental drag leave" owner borderWidth: 0]. ^nil! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'! mouseFocus ^mouseFocus! ! !HandMorph methodsFor: 'updating' stamp: 'jm 2/20/98 19:54'! changed hasChanged := true. ! ! !HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:49'! updateCacheCanvas: aCanvas "Update the cached image of the morphs being held by this hand." "Note: The following is an attempt to quickly get out if there's no change" | subBnds rectList nPix | subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]). rectList := damageRecorder invalidRectsFullBounds: subBnds. damageRecorder reset. (rectList isEmpty and: [cacheCanvas notNil and: [cacheCanvas extent = subBnds extent]]) ifTrue: [^self]. "Always check for real translucency -- can't be cached in a form" self submorphsDo: [:m | m wantsToBeCachedByHand ifFalse: [cacheCanvas := nil. cachedCanvasHasHoles := true. ^self]]. (cacheCanvas isNil or: [cacheCanvas extent ~= subBnds extent]) ifTrue: [cacheCanvas := (aCanvas allocateForm: subBnds extent) getCanvas. cacheCanvas translateBy: subBnds origin negated during: [:tempCanvas | self drawSubmorphsOn: tempCanvas]. self submorphsDo: [:m | (m areasRemainingToFill: subBnds) isEmpty ifTrue: [^cachedCanvasHasHoles := false]]. nPix := cacheCanvas form tallyPixelValues first. "--> begin rounded corners hack <---" cachedCanvasHasHoles := (nPix = 48 and: [submorphs size = 1 and: [submorphs first wantsRoundedCorners]]) ifTrue: [false] ifFalse: [nPix > 0]. "--> end rounded corners hack <---" ^self]. "incrementally update the cache canvas" cacheCanvas translateBy: subBnds origin negated during: [:cc | rectList do: [:r | cc clipBy: r during: [:c | c fillColor: Color transparent. self drawSubmorphsOn: c]]]! ! !HandMorph methodsFor: 'meta-actions' stamp: 'ar 11/6/2000 13:07'! copyToPasteBuffer: aMorph "Save this morph in the paste buffer. This is mostly useful for copying morphs between projects." aMorph ifNil:[^PasteBuffer := nil]. Cursor wait showWhile:[ PasteBuffer := aMorph topRendererOrSelf veryDeepCopy. PasteBuffer privateOwner: nil]. ! ! !HandMorph methodsFor: 'accessing' stamp: 'wiz 12/4/2006 00:16'! targetPoint "Return the new position of the target. I.E. return the position of the hand less the original distance between hand and target position" ^ self position - targetOffset ! ! !HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:10'! pasteBuffer "Return the paste buffer associated with this hand" ^ PasteBuffer! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'! eventListeners: anArrayOrNil eventListeners := anArrayOrNil! ! !HandMorph methodsFor: 'events-processing' stamp: 'MarcusDenker 7/28/2013 13:03'! showDebugEvent: evt ShowEvents == true ifTrue: [ | ofs| Display fill: (0@0 extent: 500@120) rule: Form over fillColor: Color white. ofs := (owner hands indexOf: self) - 1 * 60. evt printString displayAt: (0@ofs) + (evt isKeyboard ifTrue: [0@30] ifFalse: [0@0]). self keyboardFocus printString displayAt: (0@ofs)+(0@45). ].! ! !HandMorph methodsFor: 'accessing' stamp: 'MarcusDenker 9/13/2013 16:31'! cursorBounds temporaryCursor ifNil: [^ self position extent: NormalCursor extent] ifNotNil: [^ self position + temporaryCursorOffset extent: temporaryCursor extent]! ! !HandMorph methodsFor: 'events-processing' stamp: 'IgorStasenko 1/2/2012 18:41'! waitButton self captureEventsUntil: [:evt | self anyButtonPressed ] ! ! !HandMorph methodsFor: 'change reporting' stamp: 'ar 12/30/2001 17:32'! invalidRect: damageRect from: aMorph "Note that a change has occurred and record the given damage rectangle relative to the origin this hand's cache." hasChanged := true. aMorph == self ifTrue:[^self]. damageRecorder recordInvalidRect: damageRect. ! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 10/8/2000 23:42'! attachMorph: m "Position the center of the given morph under this hand, then grab it. This method is used to grab far away or newly created morphs." | delta | self releaseMouseFocus. "Break focus" delta := m bounds extent // 2. m position: (self position - delta). m formerPosition: m position. targetOffset := m position - self position. self addMorphBack: m.! ! !HandMorph methodsFor: 'accessing' stamp: 'ar 9/25/2000 14:24'! mouseOverHandler ^mouseOverHandler ifNil:[mouseOverHandler := MouseOverHandler new].! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:41'! removeEventListener: anObject "Remove anObject from the current event listeners." self eventListeners: (self removeListener: anObject from: self eventListeners).! ! !HandMorph methodsFor: 'private events' stamp: 'IgorStasenko 1/22/2012 18:30'! processEvents "Process user input events from the local input devices." | evt evtBuf type hadAny | ActiveEvent ifNotNil: ["Meaning that we were invoked from within an event response. Make sure z-order is up to date" self mouseOverHandler processMouseOver: lastMouseEvent]. hadAny := false. [(evtBuf := Sensor nextEvent) isNil] whileFalse: [evt := nil. "for unknown event types" type := evtBuf first. type = EventTypeMouse ifTrue: [recentModifiers := evtBuf sixth. evt := self generateMouseEvent: evtBuf]. type = EventTypeKeyboard ifTrue: [recentModifiers := evtBuf fifth. evt := self generateKeyboardEvent: evtBuf]. type = EventTypeDragDropFiles ifTrue: [evt := self generateDropFilesEvent: evtBuf]. type = EventTypeWindow ifTrue:[evt := self generateWindowEvent: evtBuf]. "All other events are ignored" (type ~= EventTypeDragDropFiles and: [evt isNil]) ifTrue: [^self]. evt isNil ifFalse: ["Finally, handle it" self handleEvent: evt. hadAny := true. "For better user feedback, return immediately after a mouse event has been processed." (evt isMouse and: [evt isMouseWheel not]) ifTrue: [^self]]]. "note: if we come here we didn't have any mouse events" mouseClickState notNil ifTrue: ["No mouse events during this cycle. Make sure click states time out accordingly" mouseClickState handleEvent: lastMouseEvent asMouseMove from: self]. hadAny ifFalse: ["No pending events. Make sure z-order is up to date" self mouseOverHandler processMouseOver: lastMouseEvent]! ! !HandMorph methodsFor: 'private events' stamp: 'BenjaminVanRyseghem 7/6/2012 14:00'! generateMouseEvent: evtBuf "Generate the appropriate mouse event for the given raw event buffer" | position buttons modifiers type trail stamp oldButtons evtChanged | KMBuffer uniqueInstance clearBuffer. evtBuf first = lastEventBuffer first ifTrue: ["Workaround for Mac VM bug, *always* generating 3 events on clicks" evtChanged := false. 3 to: evtBuf size do: [:i | (lastEventBuffer at: i) = (evtBuf at: i) ifFalse: [evtChanged := true]]. evtChanged ifFalse: [^nil]]. stamp := evtBuf second. stamp = 0 ifTrue: [stamp := Time millisecondClockValue]. position := evtBuf third @ evtBuf fourth. buttons := evtBuf fifth. modifiers := evtBuf sixth. type := buttons = 0 ifTrue: [lastEventBuffer fifth = 0 ifTrue: [#mouseMove] ifFalse: [#mouseUp]] ifFalse: [lastEventBuffer fifth = 0 ifTrue: [#mouseDown] ifFalse: [#mouseMove]]. buttons := buttons bitOr: (modifiers bitShift: 3). oldButtons := lastEventBuffer fifth bitOr: (lastEventBuffer sixth bitShift: 3). lastEventBuffer := evtBuf. type == #mouseMove ifTrue: [trail := self mouseTrailFrom: evtBuf. ^MouseMoveEvent basicNew setType: type startPoint: (self position) endPoint: trail last trail: trail buttons: buttons hand: self stamp: stamp]. ^MouseButtonEvent basicNew setType: type position: position which: (oldButtons bitXor: buttons) buttons: buttons hand: self stamp: stamp! ! !HandMorph methodsFor: 'double click support' stamp: 'ar 9/18/2000 17:16'! resetClickState "Reset the double-click detection state to normal (i.e., not waiting for a double-click)." mouseClickState := nil.! ! !HandMorph methodsFor: 'events-processing' stamp: 'IgorStasenko 1/2/2012 18:58'! captureEventsUntil: aBlock " Capture all input events, bypassing normal processing flow and redirect all events into block instead. Repeat until block will answer true. World activeHand captureEventsUntil: [:evt | evt isKeyboard and: [ evt keyCharacter = $a ] ] " | release | release := false. captureBlock := [:evt | release := aBlock value: evt ]. [ [ self world doOneCycle. release ] whileFalse. ] ensure: [ captureBlock := nil. ]! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'! eventListeners ^eventListeners! ! !HandMorph methodsFor: 'private events' stamp: 'ar 10/26/2000 01:43'! sendListenEvent: anEvent to: listenerGroup "Send the event to the given group of listeners" listenerGroup ifNil:[^self]. listenerGroup do:[:listener| listener ifNotNil:[listener handleListenEvent: anEvent copy]].! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 8/13/2003 11:39'! dropMorph: aMorph event: anEvent "Drop the given morph which was carried by the hand" | event dropped | (anEvent isMouseUp and:[aMorph shouldDropOnMouseUp not]) ifTrue:[^self]. "Note: For robustness in drag and drop handling we remove the morph BEFORE we drop him, but we keep his owner set to the hand. This prevents system lockups when there is a problem in drop handling (for example if there's an error in #wantsToBeDroppedInto:). THIS TECHNIQUE IS NOT RECOMMENDED FOR CASUAL USE." self privateRemove: aMorph. aMorph privateOwner: self. dropped := aMorph. (dropped hasProperty: #addedFlexAtGrab) ifTrue:[dropped := aMorph removeFlexShell]. event := DropEvent new setPosition: self position contents: dropped hand: self. self sendEvent: event focus: nil. event wasHandled ifFalse:[aMorph rejectDropMorphEvent: event]. aMorph owner == self ifTrue:[aMorph delete]. self mouseOverHandler processMouseOver: anEvent.! ! !HandMorph methodsFor: '*EventModel' stamp: 'MarcusDenker 9/13/2013 15:52'! eventSource ^ Sensor! ! !HandMorph methodsFor: 'private events' stamp: 'marcus.denker 8/24/2008 21:40'! moveToEvent: anEvent "Issue a mouse move event to make the receiver appear at the given position" self handleEvent: (MouseMoveEvent basicNew setType: #mouseMove startPoint: self position endPoint: anEvent position trail: (Array with: self position with: anEvent position) buttons: anEvent buttons hand: self stamp: anEvent timeStamp)! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'! releaseMouseFocus "Release the current mouse focus unconditionally." self newMouseFocus: nil.! ! !HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:42'! sendEvent: anEvent focus: focusHolder clear: aBlock "Send the event to the morph currently holding the focus, or if none to the owner of the hand." | result | focusHolder ifNotNil:[^self sendFocusEvent: anEvent to: focusHolder clear: aBlock]. ActiveEvent := anEvent. result := owner processEvent: anEvent. ActiveEvent := nil. ^result! ! !HandMorph methodsFor: 'geometry' stamp: 'nk 8/20/2003 17:39'! position: aPoint "Overridden to align submorph origins to the grid if gridding is on." | adjustedPosition delta box | adjustedPosition := aPoint. temporaryCursor ifNotNil: [adjustedPosition := adjustedPosition + temporaryCursorOffset]. "Copied from Morph to avoid owner layoutChanged" "Change the position of this morph and and all of its submorphs." delta := adjustedPosition - bounds topLeft. (delta x = 0 and: [delta y = 0]) ifTrue: [^ self]. "Null change" box := self fullBounds. (delta dotProduct: delta) > 100 ifTrue:[ "e.g., more than 10 pixels moved" self invalidRect: box. self invalidRect: (box translateBy: delta). ] ifFalse:[ self invalidRect: (box merge: (box translateBy: delta)). ]. self privateFullMoveBy: delta. ! ! !HandMorph methodsFor: 'halos and balloon help' stamp: 'ar 10/4/2000 13:40'! halo "Return the halo associated with this hand, if any" ^self valueOfProperty: #halo! ! !HandMorph methodsFor: 'double click support' stamp: 'nk 7/26/2004 10:29'! waitForClicksOrDrag: aMorph event: evt "Wait for mouse button and movement events, informing aMorph about events interesting to it via callbacks. This message is typically sent to the Hand by aMorph when it first receives a mouse-down event. The callback methods invoked on aMorph (which are passed a copy of evt) are: #click: sent when the mouse button goes up within doubleClickTime. #doubleClick: sent when the mouse goes up, down, and up again all within DoubleClickTime. #doubleClickTimeout: sent when the mouse does not have a doubleClick within DoubleClickTime. #startDrag: sent when the mouse moves more than 10 pixels from evt's position within DoubleClickTime. Note that mouseMove: and mouseUp: events are not sent to aMorph until it becomes the mouse focus, which is typically done by aMorph in its click:, doubleClick:, or drag: methods." ^self waitForClicksOrDrag: aMorph event: evt selectors: #( #click: #doubleClick: #doubleClickTimeout: #startDrag:) threshold: 10 ! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'! releaseAllFoci mouseFocus := nil. keyboardFocus := nil. ! ! !HandMorph methodsFor: 'halo handling' stamp: 'ar 10/24/2000 18:40'! releaseHalo: aHalo "Used for transfering halos between hands" self removeProperty: #halo! ! !HandMorph methodsFor: 'meta-actions' stamp: 'adrian_lienhard 3/5/2009 22:44'! grabMorph: aMorph "Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand." | grabbed | aMorph = World ifTrue: [^ self]. self releaseMouseFocus. grabbed := aMorph aboutToBeGrabbedBy: self. grabbed ifNil: [^self]. grabbed := grabbed topRendererOrSelf. ^self grabMorph: grabbed from: grabbed owner! ! !HandMorph methodsFor: 'focus handling' stamp: 'BenjaminVanRyseghem 7/3/2012 12:25'! newKeyboardFocus: aMorphOrNil "Make the given morph the new keyboard focus, canceling the previous keyboard focus if any. If the argument is nil, the current keyboard focus is cancelled." | oldFocus | oldFocus := self keyboardFocus. self keyboardFocus: aMorphOrNil. oldFocus ifNotNil: [oldFocus == aMorphOrNil ifFalse: [oldFocus keyboardFocusChange: false]]. aMorphOrNil ifNotNil: [ aMorphOrNil keyboardFocusChange: true ]. ! ! !HandMorph methodsFor: 'listeners' stamp: 'dgd 2/21/2003 22:48'! removeListener: anObject from: aListenerGroup "Remove anObject from the given listener group. Return the new group." | listeners | aListenerGroup ifNil: [^nil]. listeners := aListenerGroup. listeners := listeners copyWithout: anObject. listeners := listeners copyWithout: nil. "obsolete entries" listeners isEmpty ifTrue: [listeners := nil]. ^listeners! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:43'! addEventListener: anObject "Make anObject a listener for all events. All events will be reported to the object." self eventListeners: (self addListener: anObject to: self eventListeners)! ! !HandMorph methodsFor: 'cursor' stamp: 'di 3/6/1999 23:52'! showTemporaryCursor: cursorOrNil "Set the temporary cursor to the given Form. If the argument is nil, revert to the normal cursor." self showTemporaryCursor: cursorOrNil hotSpotOffset: 0@0 ! ! !HandMorph methodsFor: 'balloon help' stamp: 'sw 10/15/2002 20:01'! deleteBalloonTarget: aMorph "Delete any existing balloon help. This is now done unconditionally, whether or not the morph supplied is the same as the current balloon target" self balloonHelp: nil " | h | h := self balloonHelp ifNil: [^ self]. h balloonOwner == aMorph ifTrue: [self balloonHelp: nil]"! ! !HandMorph methodsFor: 'private events' stamp: 'GuillermoPolito 6/28/2013 13:15'! generateKeyboardEvent: evtBuf "Generate the appropriate mouse event for the given raw event buffer" | buttons modifiers type pressType stamp charCode keyValue keyEvent | stamp := evtBuf second. stamp = 0 ifTrue: [stamp := Time millisecondClockValue]. pressType := evtBuf fourth. pressType = EventKeyDown ifTrue: [ type := #keyDown. lastKeyScanCode := evtBuf third]. pressType = EventKeyUp ifTrue: [type := #keyUp]. pressType = EventKeyChar ifTrue: [ type := #keystroke]. modifiers := evtBuf fifth. buttons := modifiers bitShift: 3. keyValue := evtBuf third. charCode := evtBuf sixth. type = #keystroke ifTrue: [combinedChar ifNil: [ | peekedEvent | peekedEvent := Sensor peekEvent. (peekedEvent notNil and: [peekedEvent fourth = EventKeyDown]) ifTrue: [ (CombinedChar isCompositionCharacter: charCode) ifTrue: [ combinedChar := CombinedChar new. combinedChar simpleAdd: charCode asCharacter. (combinedChar combinesWith: peekedEvent third asCharacter) ifTrue: [^nil]. ]]] ifNotNil: [ (combinedChar simpleAdd: charCode asCharacter) ifTrue: [charCode := combinedChar combined charCode]. combinedChar := nil]]. self flag: #fixme. "This piece of code handles the creation of scrolling events. When a scroll is done by the user, the VM forwards a keystroke event with the up/down key. So we reconvert it to a MouseWheelEvent in that case." (type = #keystroke and: [(buttons anyMask: 16) and: [charCode = 30 or: [charCode = 31]]]) ifTrue: [^MouseWheelEvent new setType: #mouseWheel position: lastMouseEvent cursorPoint direction: (charCode = 30 ifTrue: [#up] ifFalse: [#down]) buttons: buttons hand: self stamp: stamp]. keyEvent := KeyboardEvent new setType: type buttons: buttons position: self position keyValue: keyValue charCode: charCode hand: self stamp: stamp. keyEvent scanCode: lastKeyScanCode. ^keyEvent ! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:30'! keyboardFocus: aMorphOrNil keyboardFocus := aMorphOrNil! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'! mouseListeners: anArrayOrNil mouseListeners := anArrayOrNil! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:40'! addListener: anObject to: aListenerGroup "Add anObject to the given listener group. Return the new group." | listeners | listeners := aListenerGroup. (listeners notNil and:[listeners includes: anObject]) ifFalse:[ listeners ifNil:[listeners := WeakArray with: anObject] ifNotNil:[listeners := listeners copyWith: anObject]]. listeners := listeners copyWithout: nil. "obsolete entries" ^listeners! ! !HandMorph methodsFor: 'halo handling' stamp: 'dgd 4/4/2006 16:14'! removeHalo "remove the receiver's halo (if any)" | halo | halo := self halo. halo ifNil: [^ self]. halo delete. self removeProperty: #halo! ! !HandMorph methodsFor: 'accessing' stamp: 'sw 2/11/98 18:00'! colorForInsets "Morphs being dragged by the hand use the world's color" ^ owner colorForInsets! ! !HandMorph methodsFor: 'drawing' stamp: 'JW 7/12/2005 20:13'! shadowForm "Return a 1-bit shadow of my submorphs. Assumes submorphs is not empty" | bnds canvas | bnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]). canvas := (Display defaultCanvasClass extent: bnds extent depth: 1) asShadowDrawingCanvas: Color black. canvas translateBy: bnds topLeft negated during:[:tempCanvas| self drawSubmorphsOn: tempCanvas]. ^ canvas form offset: bnds topLeft! ! !HandMorph methodsFor: 'geometry' stamp: 'ar 3/20/2001 20:34'! position ^temporaryCursor ifNil: [bounds topLeft] ifNotNil: [bounds topLeft - temporaryCursorOffset]! ! !HandMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/24/2009 10:36'! fullDrawOn: aCanvas "A HandMorph has unusual drawing requirements: 1. the hand itself (i.e., the cursor) appears in front of its submorphs 2. morphs being held by the hand cast a shadow on the world/morphs below The illusion is that the hand plucks up morphs and carries them above the world." "Note: This version caches an image of the morphs being held by the hand for better performance. This cache is invalidated if one of those morphs changes." | disableCaching subBnds roundCorners rounded | self visible ifFalse: [^self]. (aCanvas isVisible: self fullBounds) ifFalse: [^self]. disableCaching := false. disableCaching ifTrue: [self nonCachingFullDrawOn: aCanvas. ^self]. submorphs isEmpty ifTrue: [cacheCanvas := nil. ^self drawOn: aCanvas]. "just draw the hand itself" subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]). self updateCacheCanvas: aCanvas. (cacheCanvas isNil or: [cachedCanvasHasHoles and: [cacheCanvas depth = 1]]) ifTrue: ["could not use caching due to translucency; do full draw" self nonCachingFullDrawOn: aCanvas. ^self]. "--> begin rounded corners hack <---" roundCorners := cachedCanvasHasHoles == false and: [submorphs size = 1 and: [submorphs first wantsRoundedCorners]]. roundCorners ifTrue: [rounded := submorphs first. aCanvas asShadowDrawingCanvas translateBy: self shadowOffset during: [:shadowCanvas | shadowCanvas roundCornersOf: rounded during: [(subBnds areasOutside: (rounded boundsWithinCorners translateBy: self shadowOffset negated)) do: [:r | shadowCanvas fillRectangle: r color: Color black]]]. aCanvas roundCornersOf: rounded during: [aCanvas drawImage: cacheCanvas form at: subBnds origin sourceRect: cacheCanvas form boundingBox]. ^self drawOn: aCanvas "draw the hand itself in front of morphs"]. "--> end rounded corners hack <---" "draw the shadow" (submorphs anySatisfy: [:m | m handlesDropShadowInHand not]) ifTrue: [ aCanvas asShadowDrawingCanvas translateBy: self shadowOffset during: [:shadowCanvas | cachedCanvasHasHoles ifTrue: ["Have to draw the real shadow of the form" shadowCanvas paintImage: cacheCanvas form at: subBnds origin] ifFalse: ["Much faster if only have to shade the edge of a solid rectangle" (subBnds areasOutside: (subBnds translateBy: self shadowOffset negated)) do: [:r | shadowCanvas fillRectangle: r color: Color black]]]]. "draw morphs in front of the shadow using the cached Form" aCanvas translucentImage: cacheCanvas form at: subBnds origin. self drawOn: aCanvas "draw the hand itself in front of morphs"! ! !HandMorph methodsFor: 'layout' stamp: 'jm 2/20/98 18:55'! fullBounds "Extend my bounds by the shadow offset when carrying morphs." | bnds | bnds := super fullBounds. submorphs isEmpty ifTrue: [^ bnds ] ifFalse: [^ bnds topLeft corner: bnds bottomRight + self shadowOffset]. ! ! !HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:43'! sendEvent: anEvent focus: focusHolder "Send the event to the morph currently holding the focus, or if none to the owner of the hand." ^self sendEvent: anEvent focus: focusHolder clear:[nil]! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'! releaseMouseFocus: aMorph "If the given morph had the mouse focus before, release it" self mouseFocus == aMorph ifTrue:[self releaseMouseFocus].! ! !HandMorph methodsFor: 'accessing' stamp: 'ar 12/22/2008 12:04'! shiftPressed ^lastMouseEvent shiftPressed! ! !HandMorph methodsFor: 'private events' stamp: 'tbn 3/12/2010 01:38'! generateWindowEvent: evtBuf "Generate the appropriate window event for the given raw event buffer" | evt | evt := WindowEvent new. evt setTimeStamp: evtBuf second. evt timeStamp = 0 ifTrue: [evt setTimeStamp: Time millisecondClockValue]. evt action: evtBuf third. evt rectangle: (Rectangle origin: evtBuf fourth @ evtBuf fifth corner: evtBuf sixth @ evtBuf seventh ). ^evt ! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:42'! addMouseListener: anObject "Make anObject a listener for mouse events. All mouse events will be reported to the object." self mouseListeners: (self addListener: anObject to: self mouseListeners)! ! !HandMorph methodsFor: 'balloon help' stamp: 'MarcusDenker 10/10/2013 23:45'! balloonHelp: aBalloonMorph "Return the balloon morph associated with this hand" self balloonHelp ifNotNil:[:oldHelp |oldHelp delete]. aBalloonMorph ifNil:[self removeProperty: #balloonHelpMorph] ifNotNil:[self setProperty: #balloonHelpMorph toValue: aBalloonMorph]! ! !HandMorph methodsFor: 'caching' stamp: 'StephaneDucasse 12/26/2011 10:39'! releaseCachedState | oo | super releaseCachedState. cacheCanvas := nil. oo := owner. self removeAllMorphs. self initialize. "nuke everything" self privateOwner: oo. self releaseAllFoci.! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'! keyboardFocus ^ keyboardFocus! ! !HandMorph methodsFor: 'cursor' stamp: 'NS 2/17/2001 11:01'! temporaryCursor ^ temporaryCursor! ! !HandMorph methodsFor: 'initialization' stamp: 'nk 2/14/2004 18:28'! interrupted "Something went wrong - we're about to bring up a debugger. Release some stuff that could be problematic." self releaseAllFoci. "or else debugger might not handle clicks" ! ! !HandMorph methodsFor: 'drawing' stamp: 'nice 1/5/2010 15:59'! nonCachingFullDrawOn: aCanvas "A HandMorph has unusual drawing requirements: 1. the hand itself (i.e., the cursor) appears in front of its submorphs 2. morphs being held by the hand cast a shadow on the world/morphs below The illusion is that the hand plucks up morphs and carries them above the world." "Note: This version does not cache an image of the morphs being held by the hand. Thus, it is slower for complex morphs, but consumes less space." submorphs isEmpty ifTrue: [^ self drawOn: aCanvas]. "just draw the hand itself" aCanvas asShadowDrawingCanvas translateBy: self shadowOffset during:[:shadowCanvas| | shadowForm | "Note: We use a shadow form here to prevent drawing overlapping morphs multiple times using the transparent shadow color." shadowForm := self shadowForm. " shadowForm displayAt: shadowForm offset negated. Display forceToScreen: (0@0 extent: shadowForm extent). " shadowCanvas paintImage: shadowForm at: shadowForm offset. "draw shadows" ]. "draw morphs in front of shadows" self drawSubmorphsOn: aCanvas. self drawOn: aCanvas. "draw the hand itself in front of morphs" ! ! !HandMorph methodsFor: 'halo handling' stamp: 'dgd 9/9/2004 22:44'! removeHaloFromClick: anEvent on: aMorph | halo | halo := self halo ifNil: [^ self]. (halo target hasOwner: self) ifTrue: [^ self]. (halo staysUpWhenMouseIsDownIn: aMorph) ifFalse: [self removeHalo]! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 10/5/2000 16:23'! dropMorphs "Drop the morphs at the hands position" self dropMorphs: lastMouseEvent.! ! !HandMorph methodsFor: 'double click support' stamp: 'nk 7/26/2004 10:32'! waitForClicksOrDrag: aMorph event: evt selectors: clickAndDragSelectors threshold: threshold "Wait for mouse button and movement events, informing aMorph about events interesting to it via callbacks. This message is typically sent to the Hand by aMorph when it first receives a mouse-down event. The callback methods, named in clickAndDragSelectors and passed a copy of evt, are: 1 (click) sent when the mouse button goes up within doubleClickTime. 2 (doubleClick) sent when the mouse goes up, down, and up again all within DoubleClickTime. 3 (doubleClickTimeout) sent when the mouse does not have a doubleClick within DoubleClickTime. 4 (startDrag) sent when the mouse moves more than threshold pixels from evt's position within DoubleClickTime. Note that mouseMove: and mouseUp: events are not sent to aMorph until it becomes the mouse focus, which is typically done by aMorph in its click:, doubleClick:, or drag: methods." mouseClickState := MouseClickState new client: aMorph click: clickAndDragSelectors first dblClick: clickAndDragSelectors second dblClickTime: DoubleClickTime dblClickTimeout: clickAndDragSelectors third drag: clickAndDragSelectors fourth threshold: threshold event: evt. ! ! !HandMorph methodsFor: 'copying' stamp: 'ar 10/6/2000 00:11'! veryDeepCopyWith: deepCopier "Return self. Do not copy hands this way." ^ self! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:31'! releaseKeyboardFocus: aMorph "If the given morph had the keyboard focus before, release it" self keyboardFocus == aMorph ifTrue:[self releaseKeyboardFocus].! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'AlainPlantec 5/7/2010 22:28'! grabMorph: aMorph from: formerOwner "Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand." | grabbed offset targetPoint grabTransform fullTransform | self releaseMouseFocus. "Break focus" grabbed := aMorph. aMorph keepsTransform ifTrue: [grabTransform := fullTransform := IdentityTransform new] ifFalse: ["Compute the transform to apply to the grabbed morph" grabTransform := formerOwner ifNil: [IdentityTransform new] ifNotNil: [formerOwner grabTransform]. fullTransform := formerOwner ifNil: [IdentityTransform new] ifNotNil: [formerOwner transformFrom: owner]]. "targetPoint is point in aMorphs reference frame" targetPoint := fullTransform globalPointToLocal: self position. "but current position will be determined by grabTransform, so compute offset" offset := targetPoint - (grabTransform globalPointToLocal: self position). "apply the transform that should be used after grabbing" grabbed := grabbed transformedBy: grabTransform. grabbed == aMorph ifFalse: [grabbed setProperty: #addedFlexAtGrab toValue: true]. "offset target to compensate for differences in transforms" grabbed position: grabbed position - offset asIntegerPoint. "And compute distance from hand's position" targetOffset := grabbed position - self position. self addMorphBack: grabbed. grabbed justGrabbedFrom: formerOwner! ! !HandMorph methodsFor: 'classification' stamp: ''! isHandMorph ^ true! ! !HandMorph methodsFor: 'halo handling' stamp: 'ar 10/4/2000 13:40'! halo: newHalo "Set halo associated with this hand" | oldHalo | oldHalo := self halo. (oldHalo isNil or:[oldHalo == newHalo]) ifFalse:[oldHalo delete]. newHalo ifNil:[self removeProperty: #halo] ifNotNil:[self setProperty: #halo toValue: newHalo]! ! !HandMorph methodsFor: 'events-processing' stamp: 'IgorStasenko 1/2/2012 18:40'! captureEventsWhile: aBlock " Capture all input events, bypassing normal processing flow and redirect all events into block instead. Repeat until block will answer false. " ^ self captureEventsUntil: [:evt | (aBlock value: evt) not ]! ! !HandMorph methodsFor: 'private events' stamp: 'PavelKrivanek 6/21/2011 13:05'! mouseTrailFrom: currentBuf "Current event, a mouse event buffer, is about to be processed. If there are other similar mouse events queued up, then drop them from the queue, and report the positions inbetween." | nextEvent trail | trail := (Array new: 1) writeStream. trail nextPut: currentBuf third @ currentBuf fourth. [(nextEvent := Sensor peekEvent) isNil] whileFalse: [nextEvent first = currentBuf first ifFalse: [^trail contents "different event type"]. nextEvent fifth = currentBuf fifth ifFalse: [^trail contents "buttons changed"]. nextEvent sixth = currentBuf sixth ifFalse: [^trail contents "modifiers changed"]. "nextEvent is similar. Remove it from the queue, and check the next." nextEvent := Sensor nextEvent. nextEvent ifNotNil: [ trail nextPut: nextEvent third @ nextEvent fourth ]]. ^trail contents! ! !HandMorph methodsFor: '*EventModel' stamp: 'IgorStasenko 1/22/2012 18:19'! handleMouseInputEvent: sysEvent "it is complex... ignore it" | type oldButtons | type := sysEvent typeBasedOnPreviousEvent: self lastSystemEvent. oldButtons := self lastSystemEvent buttons. lastSystemEvent := sysEvent. recentModifiers := lastSystemEvent modifiers. type == #mouseMove ifTrue: [ ^MouseMoveEvent basicNew setType: type startPoint: self position endPoint: sysEvent trail last trail: sysEvent trail buttons: sysEvent buttons hand: self stamp: sysEvent timeStamp]. ^MouseButtonEvent basicNew setType: type position: self position which: ( oldButtons bitXor: sysEvent buttons) buttons: sysEvent buttons hand: self stamp: sysEvent timeStamp! ! !HandMorph methodsFor: 'balloon help' stamp: 'ar 10/6/2000 00:14'! removePendingBalloonFor: aMorph "Get rid of pending balloon help." self removeAlarm: #spawnBalloonFor:. self deleteBalloonTarget: aMorph.! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:41'! removeMouseListener: anObject "Remove anObject from the current mouse listeners." self mouseListeners: (self removeListener: anObject from: self mouseListeners).! ! !HandMorph methodsFor: 'initialization' stamp: 'IgorStasenko 1/22/2012 18:19'! initForEvents mouseOverHandler := nil. lastMouseEvent := MouseEvent basicNew setType: #mouseMove position: 0@0 buttons: 0 hand: self. lastEventBuffer := {1. 0. 0. 0. 0. 0. nil. nil}. recentModifiers := 0. self resetClickState.! ! !HandMorph methodsFor: 'accessing' stamp: 'IgorStasenko 1/22/2012 18:24'! anyModifierKeyPressed ^recentModifiers anyMask: 16r0E "cmd | opt | ctrl"! ! !HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 16:49'! balloonHelp "Return the balloon morph associated with this hand" ^self valueOfProperty: #balloonHelpMorph! ! !HandMorph methodsFor: 'listeners' stamp: 'MarcusDenker 9/13/2013 15:53'! keyboardListeners ^nil! ! !HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 17:14'! triggerBalloonFor: aMorph after: timeOut "Trigger balloon help after the given time out for some morph" self addAlarm: #spawnBalloonFor: with: aMorph after: timeOut.! ! !HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:10'! objectToPaste "It may need to be sent #startRunning by the client" ^ Cursor wait showWhile: [PasteBuffer veryDeepCopy] "PasteBuffer usableDuplicateIn: self world" ! ! !HandMorph class methodsFor: 'class initialization' stamp: 'kfr 7/13/2003 14:15'! initialize "HandMorph initialize" PasteBuffer := nil. DoubleClickTime := 350. NormalCursor := CursorWithMask normal asCursorForm. ! ! !HandMorph class methodsFor: 'utilities' stamp: 'MarcusDenker 7/28/2013 13:03'! showEvents: aBool "HandMorph showEvents: true" "HandMorph showEvents: false" ShowEvents := aBool. aBool ifFalse: [ World invalidRect: (0@0 extent: 500@120) ].! ! !HandMorph class methodsFor: 'utilities' stamp: 'sma 4/30/2000 10:34'! attach: aMorph "Attach aMorph the current world's primary hand." self currentWorld primaryHand attachMorph: aMorph! ! !HandMorph class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/25/2013 17:43'! upperHandLimit ^ UpperHandLimit ifNil: [ UpperHandLimit := 0 ]! ! !HandMorph class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/25/2013 17:45'! upperHandLimit: anInteger UpperHandLimit := anInteger! ! !HandMorph class methodsFor: 'accessing' stamp: ''! doubleClickTime ^ DoubleClickTime ! ! !HandMorph class methodsFor: 'accessing' stamp: ''! doubleClickTime: milliseconds DoubleClickTime := milliseconds. ! ! !HandleMorph commentStamp: ''! A HandleMorph provides mouse-up control behavior.! !HandleMorph methodsFor: 'stepping and presenter' stamp: 'di 11/3/97 16:34'! step pointBlock value: self center! ! !HandleMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:30'! initialize "initialize the state of the receiver" super initialize. "" self extent: 8 @ 8. ! ! !HandleMorph methodsFor: 'initialize' stamp: 'di 8/30/2000 21:48'! forEachPointDo: aBlock lastPointDo: otherBlock pointBlock := aBlock. lastPointBlock := otherBlock! ! !HandleMorph methodsFor: 'initialize' stamp: 'di 11/3/97 16:34'! forEachPointDo: aBlock pointBlock := aBlock! ! !HandleMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 23:30'! keyStroke: evt "Check for cursor keys" | keyValue | owner isHandMorph ifFalse:[^self]. keyValue := evt keyValue. keyValue = 28 ifTrue:[^self position: self position - (1@0)]. keyValue = 29 ifTrue:[^self position: self position + (1@0)]. keyValue = 30 ifTrue:[^self position: self position - (0@1)]. keyValue = 31 ifTrue:[^self position: self position + (0@1)]. "Special case for return" keyValue = 13 ifTrue:[ "Drop the receiver and be done" self flag: #arNote. "Probably unnecessary" owner releaseKeyboardFocus: self. self delete]. ! ! !HandleMorph methodsFor: 'testing' stamp: 'JMM 10/21/2003 18:15'! stepTime "Update every hundredth of a second." ^ 10 ! ! !HandleMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 9/10/2004 13:40'! justDroppedInto: aMorph event: anEvent "So that when the hand drops me (into the world) I go away" self removeHalo. lastPointBlock ifNotNil: [lastPointBlock value: self center]. self flag: #arNote. "Probably unnecessary" anEvent hand releaseKeyboardFocus: self. self changed. self delete. ! ! !HandleMorph methodsFor: 'stepping and presenter' stamp: 'ar 9/15/2000 23:24'! startStepping "Make the receiver the keyboard focus for editing" super startStepping. "owner isHandMorph ifTrue:[owner newKeyboardFocus: self]." self flag: #arNote. "make me #handleKeyboard:"! ! !HashAndEqualsTestCase commentStamp: 'mjr 8/20/2003 17:37'! I am a simple TestCase that tests for correct operation of #hash and #=. Subclasses of me need to fill my prototypes with suitable objects to be tested.! !HashAndEqualsTestCase methodsFor: 'testing' stamp: 'mjr 8/20/2003 18:56'! testEquality "Check that TextFontChanges report equality correctly" prototypes do: [:p | self should: [(EqualityTester with: p) result]] ! ! !HashAndEqualsTestCase methodsFor: 'testing' stamp: 'al 6/12/2008 21:58'! testHash "test that TextFontChanges hash correctly" prototypes do: [:p | self should: [(HashTester with: p) result]] ! ! !HashAndEqualsTestCase methodsFor: 'running' stamp: 'stephaneducasse 2/3/2006 22:39'! setUp "subclasses will add their prototypes into this collection" prototypes := OrderedCollection new ! ! !HashFunction commentStamp: 'TorstenBergmann 1/31/2014 10:15'! Common superclass for hash functions! !HashFunction methodsFor: 'accessing' stamp: 'cmm 2/20/2006 23:22'! doubleHashMessage: aStringOrByteArray "SHA1 new doubleHashMessage: 'foo'" ^ self doubleHashStream: aStringOrByteArray asByteArray readStream! ! !HashFunction methodsFor: 'accessing' stamp: 'cmm 2/20/2006 23:21'! doubleHashStream: aStream ^ self hashStream: ((self hashStream: aStream) asByteArray readStream)! ! !HashFunction methodsFor: 'converting' stamp: 'len 8/3/2002 02:42'! hmac ^ HMAC on: self! ! !HashFunction methodsFor: 'accessing' stamp: 'len 8/7/2002 16:30'! hashMessage: aStringOrByteArray "MD5 new hashMessage: 'foo'" ^ self hashStream: aStringOrByteArray asByteArray readStream! ! !HashFunction methodsFor: 'accessing' stamp: 'len 8/2/2002 02:21'! hashStream: aStream ^ self subclassResponsibility! ! !HashFunction methodsFor: 'accessing' stamp: 'len 8/15/2002 01:43'! blockSize ^ self class blockSize! ! !HashFunction methodsFor: 'accessing' stamp: 'len 8/9/2002 13:17'! hashSize ^ self class hashSize! ! !HashFunction class methodsFor: 'accessing' stamp: 'len 8/9/2002 13:17'! hashSize ^ self subclassResponsibility! ! !HashFunction class methodsFor: 'hashing' stamp: 'len 8/2/2002 02:20'! hashStream: aPositionableStream ^ self new hashStream: aPositionableStream! ! !HashFunction class methodsFor: 'accessing' stamp: 'len 8/15/2002 01:43'! blockSize ^ self subclassResponsibility! ! !HashFunction class methodsFor: 'hashing' stamp: 'len 8/2/2002 02:20'! hashMessage: aStringOrByteArray ^ self new hashMessage: aStringOrByteArray! ! !HashTableSizes commentStamp: 'MartinMcClure 3/18/2010 21:44'! HashTableSizes is a helper class, used by hashedCollections to determine sizes for hash tables. Public protocol is all class-side: #goodSizeAtLeast: anInteger answers a "good" integer greater than or equal to the given integer. An integer is not "good" as a hash table size if it is any of: * Not prime * Divides 256**k +- a, for small k and a * Close to a power of two * Close to dividing the hashMultiply constant See Andres Valloud's hashing book, and Knuth TAOCP vol. 3. This class caches a table of selected good primes within the positive SmallInteger range. When this table must be rebuilt, it uses an instance to compute the table. Primes are selected to keep the table fairly small, with approximately five entries per power of two. The cached table is ordered, and is searched with a binary search to find the closest good size >= the requested size.! !HashTableSizes methodsFor: 'private' stamp: 'MartinMcClure 1/17/2010 09:41'! goodPrimeForExp: exp "Answer the next prime integer >= 2**exp that will make a good hash table size, Some primes are rejected: * Primes close to a power of two. * Primes which divide 256**k +- a, for small k and a * Primes which are close to dividing 1664525, the hashMultiply constant See Andres Valloud's hashing book, and Knuth TAOCP volume 3." candidate := self firstCandidateForExp: exp. limit := self limitForExp: exp. [ self candidateIsGoodPrime ] whileFalse: [ candidate := candidate + 2. candidate > limit ifTrue: [ ^ nil ] ]. ^ candidate! ! !HashTableSizes methodsFor: 'private' stamp: 'MartinMcClure 12/27/2009 21:03'! firstCandidateForExp: exp "Answer the smallest odd integer greater 2**exp." | n | n := (2 raisedTo: exp) rounded. ^n odd ifTrue: [n] ifFalse: [n + 1]! ! !HashTableSizes methodsFor: 'private' stamp: 'MartinMcClure 1/17/2010 09:43'! candidateIsGoodPrime "Answer true if candidate will make a good hash table size. Some integers are rejected: * Non-primes * Primes which are close to dividing 1664525, the hashMultiply constant * Primes which divide 256**k +- a, for small k and a See Andres Valloud's hashing book, and Knuth TAOCP volume 3." candidate isPrime ifFalse: [ ^ false ]. (primesToAvoid includes: candidate) ifTrue: [ ^ false ]. candidate < 256 ifTrue: [ ^ true ]. "Small primes cannot satisify divisibility constraints" ^ valuesNotToDivide allSatisfy: [ :dividend | dividend \\ candidate ~~ 0 ]! ! !HashTableSizes methodsFor: 'initialization' stamp: 'MartinMcClure 1/17/2010 09:44'! initialize "Can't use any hashed collections, if sizes is being initialized might get infinite recursion" goodPrimes := OrderedCollection new. "Must contain a value less than any prime to avoid extra work in binary search" goodPrimes add: 0. valuesNotToDivide := OrderedCollection new. 1 to: 8 do: [ :k | | n | n := 256 raisedToInteger: k. -32 to: 32 do: [ :a | valuesNotToDivide add: n + a ] ]. primesToAvoid := self primeAlmostFactorsOf: 1 hashMultiply! ! !HashTableSizes methodsFor: 'private' stamp: 'MartinMcClure 12/27/2009 13:49'! primeAlmostFactorsOf: anInteger "Answer primes less than anInteger whose remainder when dividing anInteger is small" | factors trial | factors := OrderedCollection new. anInteger even ifTrue: [factors add: 2]. 3 to: anInteger // 2 + 2 by: 2 do: [:i | (i isPrime and: [| remainder | remainder := anInteger \\ i. remainder <= 1 or: [remainder = (i - 1)]]) ifTrue: [factors add: i]]. ^factors asArray ! ! !HashTableSizes methodsFor: 'private' stamp: 'MartinMcClure 12/27/2009 21:13'! limitForExp: exp "Answer the largest integer that isn't too close to the next higher power of 2 than exp." | expLimit | expLimit := exp ceiling - (0.5 / self numValuesPerPower). ^(2 raisedTo: expLimit) rounded. ! ! !HashTableSizes methodsFor: 'private' stamp: 'MartinMcClure 1/17/2010 09:49'! computeSizes "Answer an array of integers that make good hash table sizes. In each power of two, there are about five primes to choose from. Some primes are rejected: * Primes close to a power of two. * Primes which divide 256**k +- a, for small k and a * Primes which are close to dividing 1664525, the hashMultiply constant See Andres Valloud's hashing book, and Knuth TAOCP volume 3." | logInterval | logInterval := 0.5 / self numValuesPerPower. 2 + logInterval to: 30 by: 2 * logInterval do: [ :exp | (self goodPrimeForExp: exp) ifNotNil: [ :prime | goodPrimes last ~~ prime ifTrue: [ goodPrimes add: prime ] ] ]. ^ goodPrimes asArray! ! !HashTableSizes methodsFor: 'private' stamp: 'MartinMcClure 12/25/2009 16:59'! numValuesPerPower "Answer the number of values that should be available in the cached table of primes for each power-of-two range." ^self class numValuesPerPower ! ! !HashTableSizes class methodsFor: 'initialize-release' stamp: 'MartinMcClure 1/17/2010 09:51'! initialize "Throw away any previously-cached sizes, then compute and cache the sizes." "HashTableSizes initialize" sizes := nil. self sizes! ! !HashTableSizes class methodsFor: 'private' stamp: 'MartinMcClure 1/17/2010 09:35'! sizes sizes ~~ nil ifFalse: [ sizes := self new computeSizes ]. ^ sizes! ! !HashTableSizes class methodsFor: 'private' stamp: 'MartinMcClure 1/17/2010 09:45'! numValuesPerPower "Answer the number of values that should be available in the cached table of primes for each power-of-two range. A larger number allows closer sizing for pre-sized collections, but results in a larger table that takes longer to search." ^5 "Chosen so there will be fewer than 128 primes in the sizes table"! ! !HashTableSizes class methodsFor: 'public' stamp: 'MartinMcClure 1/11/2010 22:29'! atLeast: lowerLimit "Answer the next good size >= lowerlimit. If lowerLimit is larger than the largest known good prime, just make it odd." | primes low mid high prime | primes := self sizes. low := 1. high := primes size. lowerLimit > (primes at: high) ifTrue: [ ^ lowerLimit even ifTrue: [ lowerLimit + 1 ] ifFalse: [ lowerLimit ] ]. [ mid := (high - low) // 2 + low. prime := primes at: mid. prime < lowerLimit ifTrue: [ low := mid ] ifFalse: [ high := mid ]. high - low <= 1 ifTrue: [ ^ primes at: high ] ] repeat! ! !HashTester commentStamp: 'mjr 8/20/2003 12:48'! I provide a simple way to test the hash properties of any object. I am given an object that should be tested and I treat it like a prototype. I take a copy of it when I am given it so that it can't change whilst I am holding on to it. I can then test that multiple copies of this object all hash to the same value.! !HashTester methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/3/2006 22:39'! resultFor: runs "Test that the hash is the same over runs and answer the result" | hash | hash := self prototype hash. 1 to: runs do: [:i | hash = self prototype hash ifFalse: [^ false]]. ^ true ! ! !HashTesterTest commentStamp: 'mjr 8/20/2003 12:48'! I am a simple test case to check that HashTester works correctly! !HashTesterTest methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! testBasicBehaviour self should: [(HashTester with: 1) resultFor: 100]. self should: [(HashTester with: 'fred') resultFor: 100]. self shouldnt: [(HashTester with: BadHasher new) resultFor: 100] ! ! !HashedCollection commentStamp: 'StephaneDucasse 11/29/2011 22:22'! I am an abstract collection of objects that implement hash and equality in a consitent way. This means that whenever two objects are equal, their hashes have to be equal too. If two objects are equal then I can only store one of them. Hashes are expected to be integers (preferably SmallIntegers). I also expect that the objects contained by me do not change their hashes. If that happens, hash invariants have to be re-established, which can be done by #rehash. Since I'm abstract, no instances of me should exist. My subclasses should implement #scanFor:, #fixCollisionsFrom: and #noCheckNoGrowFillFrom:. Instance Variables array: (typically Array or WeakArray) tally: (non-negative) array - An array whose size is a prime number, it's non-nil elements are the elements of the collection, and whose nil elements are empty slots. There is always at least one nil. In fact I try to keep my "load" at 75% or less so that hashing will work well. tally - The number of elements in the collection. The array size is always greater than this. Implementation details: I implement a hash table which uses open addressing with linear probing as the method of collision resolution. Searching for an element or a free slot for an element is done by #scanFor: which should return the index of the slot in array corresponding to it's argument. When an element is removed #fixCollisionsFrom: should rehash all elements in array between the original index of the removed element, wrapping around after the last slot until reaching an empty slot. My maximum load factor (75%) is hardcoded in #atNewIndex:put:, so it can only be changed by overriding that method. When my load factor reaches this limit I replace my array with a larger one (see #grow) ensuring that my load factor will be less than or equal to 50%. The new array is filled by #noCheckNoGrowFillFrom: which should use #scanForEmptySlotFor: instead of #scanFor: for better performance. I do not shrink. ! !HashedCollection methodsFor: '*Fuel' stamp: 'MartinDias 6/13/2011 02:43'! fuelAfterMaterialization self rehash! ! !HashedCollection methodsFor: 'removing' stamp: 'TristanBourgois 4/30/2010 16:13'! removeAll "remove all elements from this collection. Preserve the capacity" self initialize: self capacity! ! !HashedCollection methodsFor: 'private' stamp: 'TristanBourgois 4/30/2010 16:13'! grow "Grow the elements array and reinsert the old elements" | oldElements | oldElements := array. array := Array new: (HashTableSizes atLeast: oldElements size * 2). tally := 0. oldElements do: [ :each | each == nil ifFalse: [ self noCheckAdd: each ] ]! ! !HashedCollection methodsFor: 'private' stamp: 'TristanBourgois 4/30/2010 16:13'! fullCheck "Keep array at least 1/4 free for decent hash behavior" array size - tally < (array size // 4 max: 1) ifTrue: [self grow]! ! !HashedCollection methodsFor: 'adding' stamp: 'HenrikSperreJohansen 9/1/2010 22:00'! add: newObject withOccurrences: anInteger "Add newObject anInteger times to the receiver. Do nothing if anInteger is less than one. Answer newObject." anInteger < 1 ifTrue: [ ^newObject ]. "I can only store an object once." ^ self add: newObject! ! !HashedCollection methodsFor: 'initialization' stamp: 'TristanBourgois 4/30/2010 16:13'! initialize: n "Initialize array to an array size of n" array := Array new: n. tally := 0! ! !HashedCollection methodsFor: 'accessing' stamp: 'TristanBourgois 4/30/2010 16:13'! someElement "Deprecated. Use anyOne." ^ self anyOne! ! !HashedCollection methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 22:43'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or raise an error if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." self subclassResponsibility! ! !HashedCollection methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 22:49'! scanForEmptySlotFor: aKey "Scan the key array for the first slot containing an empty slot (indicated by a nil). Answer the index of that slot. This method will be overridden in various subclasses that have different interpretations for matching elements." | index start | index := start := aKey hash \\ array size + 1. [ (array at: index) ifNil: [ ^index ]. (index := index \\ array size + 1) = start ] whileFalse. self errorNoFreeSpace! ! !HashedCollection methodsFor: 'enumerating' stamp: 'TristanBourgois 4/30/2010 16:13'! doWithIndex: aBlock2 "Support Set enumeration with a counter, even though not ordered" | index | index := 0. self do: [:item | aBlock2 value: item value: (index := index+1)]! ! !HashedCollection methodsFor: 'enumerating' stamp: 'EstebanLorenzano 8/17/2012 12:19'! union: aCollection "Answer the set theoretic union of the receiver and aCollection, using the receiver's notion of equality and not side effecting the receiver at all." ^ self copy addAll: aCollection; yourself! ! !HashedCollection methodsFor: 'private' stamp: 'TristanBourgois 4/30/2010 16:13'! array ^ array! ! !HashedCollection methodsFor: 'copying' stamp: 'CamilloBruni 10/2/2013 19:29'! veryDeepCopyWith: deepCopier | copyOfSelf| copyOfSelf := super veryDeepCopyWith: deepCopier. "force Sets and Dictionaries to rehash" copyOfSelf rehash. ^ copyOfSelf! ! !HashedCollection methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 22:06'! fixCollisionsFrom: start "The element at start has been removed and replaced by nil. This method moves forward from there, relocating any entries that had been placed below due to collisions with this one." self subclassResponsibility! ! !HashedCollection methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 21:58'! errorNoFreeSpace self error: 'There is no free space in this collection!!'! ! !HashedCollection methodsFor: 'accessing' stamp: 'TristanBourgois 4/30/2010 16:13'! size ^ tally! ! !HashedCollection methodsFor: 'accessing' stamp: 'TristanBourgois 4/30/2010 16:13'! capacity "Answer the current capacity of the receiver." ^ array size! ! !HashedCollection methodsFor: '*Monticello-Storing' stamp: 'StephaneDucasse 10/18/2010 14:54'! comeFullyUpOnReload: smartRefStream "Symbols have new hashes in this image." self compact. "^ self" ! ! !HashedCollection methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 23:21'! rehash self growTo: self capacity! ! !HashedCollection methodsFor: 'private' stamp: 'TristanBourgois 4/30/2010 16:13'! atNewIndex: index put: anObject array at: index put: anObject. tally := tally + 1. self fullCheck! ! !HashedCollection methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 22:24'! compact "Reduce the size of array so that the load factor will be ~75%." | newCapacity | newCapacity := HashTableSizes atLeast: tally * 4 // 3. self growTo: newCapacity! ! !HashedCollection methodsFor: 'explorer' stamp: 'TristanBourgois 4/30/2010 16:13'! hasContentsInExplorer ^self notEmpty! ! !HashedCollection methodsFor: 'private' stamp: 'TristanBourgois 4/30/2010 16:13'! findElementOrNil: anObject "Answer the index of a first slot containing either a nil (indicating an empty slot) or an element that matches the given object. Answer the index of that slot or zero. Fail if neither a match nor an empty slot is found." | index | index := self scanFor: anObject. index > 0 ifTrue: [^index]. "Bad scene. Neither have we found a matching element nor even an empty slot. No hashed set is ever supposed to get completely full." self error: 'There is no free space in this set!!'.! ! !HashedCollection methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 22:20'! growSize "Answer what my next higher table size should be" ^HashTableSizes atLeast: self capacity * 3 // 2 + 2 ! ! !HashedCollection methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 22:21'! growTo: anInteger "Grow the elements array and reinsert the old elements" | oldElements | oldElements := array. array := Array new: anInteger. self noCheckNoGrowFillFrom: oldElements! ! !HashedCollection methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 22:20'! noCheckNoGrowFillFrom: anArray "Add the elements of anArray except nils to me assuming that I don't contain any of them, they are unique and I have more free space than they require." self subclassResponsibility! ! !HashedCollection methodsFor: 'private' stamp: 'jordidelgado 10/30/2013 16:49'! noCheckAdd: anObject self subclassResponsibility! ! !HashedCollection class methodsFor: 'instance creation' stamp: 'TristanBourgois 4/30/2010 16:13'! new: nElements "Create a Set large enough to hold nElements without growing" ^ self basicNew initialize: (self sizeFor: nElements)! ! !HashedCollection class methodsFor: 'initialization' stamp: 'StephaneDucasse 10/18/2010 14:48'! compactAllInstances "Do not use #allInstancesDo: because rehash may create new instances." self allInstances do: [ :each | each compact ]! ! !HashedCollection class methodsFor: 'initialization' stamp: 'HenrikSperreJohansen 9/1/2010 22:31'! rehashAll "HashedCollection rehashAll" self allSubclassesDo: #rehashAllInstances! ! !HashedCollection class methodsFor: 'instance creation' stamp: 'HenrikSperreJohansen 9/1/2010 22:18'! sizeFor: nElements "Large enough size to hold nElements with some slop (see fullCheck)" nElements < 4 ifTrue: [ ^5 ]. ^ HashTableSizes atLeast: nElements +1 * 4 // 3! ! !HashedCollection class methodsFor: 'instance creation' stamp: 'HenrikSperreJohansen 9/1/2010 22:25'! new ^ self basicNew initialize: 5! ! !HashedCollection class methodsFor: 'cleanup' stamp: 'HenrikSperreJohansen 9/1/2010 23:40'! cleanUp: aggressive "Rehash all instances when cleaning aggressively" aggressive ifTrue: [self compactAll]. ! ! !HashedCollection class methodsFor: 'instance creation' stamp: 'HenrikSperreJohansen 9/1/2010 22:27'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." ^self subclassResponsibility! ! !HashedCollection class methodsFor: 'initialization' stamp: 'HenrikSperreJohansen 9/1/2010 23:39'! compactAll "HashedCollection rehashAll" self allSubclassesDo: #compactAllInstances! ! !HashedCollection class methodsFor: 'initialization' stamp: 'StephaneDucasse 10/18/2010 14:49'! rehashAllInstances "Do not use #allInstancesDo: because rehash may create new instances." self allInstances do: [ :each | each rehash ]! ! !Heap commentStamp: 'StephaneDucasse 10/2/2010 17:42'! Heap implements a special data structure commonly referred to as 'heap' [ http://en.wikipedia.org/wiki/Heap_%28data_structure%29 ] Heaps are good at handling priority queues because: 1) greatest priority element according to the sort block will be stored in first position and thus accessed in O(1) operations 2) worse time for inserting or removing an element is in O(log n) operations, where n is the size of the Heap Insertion/Removal times are more efficient than above upper bound, provided that: a) Elements are only removed at the beginning b) Elements are added with arbitrary sort order. 3) there is no need to fully sort the Heap, which makes it more efficient than a SortedCollection The heap can be fully sorted by sending the message #fullySort. Worse time for fully sorting the Heap is in O(n log n) operations, but this is rarely used a feature. Remind that the Heap does not fully sort the collection if you don't ask. Thus don't expect #do: and other iterators to enumerate elements according to the sortBlock order. Instance variables: array The data repository tally The number of elements in the heap sortBlock A two-argument block defining the sort order, or nil in which case the default sort order is [:element1 :element2| element1 <= element2] indexUpdateBlock A two-argument block of the form [:data :index | ... ] which allows an application object to keep track of its index within the heap. Useful for quick heap update when object's sort value changes (for example, when an object in a priority queue has its priority increased by an external event, you don't want to have to search through the whole heap to find the index before fixing the heap). No update occurs if nil. The Heap can be viewed as a binary tree (every node in the tree has at most two children). The root is stored in first slot of internal array. The children are stored in next two slots. The children of children in next four slots. etc... For a node A of index i (1 based), the two children B1 and B2 are thus stored in indices (2*i) and (2*i+1). Of course, the children indices must be less than the tally otherwise they are considered inexistent. The Heap does arrange to preserve the following invariant: For any children B of a node A, A is sorted before B, in other words, (self sort: A before: B) = true This implies that the root is always the first element according to sort order. ! !Heap methodsFor: 'private' stamp: 'ar 9/10/1999 13:18'! setCollection: aCollection tally: newTally array := aCollection. tally := newTally.! ! !Heap methodsFor: 'testing' stamp: 'rhi 8/14/2003 08:51'! isHeap ^ true! ! !Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:17'! grow "Become larger." self growTo: self size + self growSize.! ! !Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'! growSize "Return the size by which the receiver should grow if there are no empty slots left." ^array size max: 5! ! !Heap methodsFor: 'accessing' stamp: 'ar 9/10/1999 14:08'! reSort "Resort the entire heap" self isEmpty ifTrue:[^self]. tally // 2 to: 1 by: -1 do:[:i| self downHeap: i].! ! !Heap methodsFor: 'private' stamp: 'StephaneDucasse 10/2/2010 17:37'! privateReverseSort "Arrange to have the array sorted in reverse order. WARNING: this method breaks the heap invariants. It's up to the sender to restore them afterwards." | oldTally | oldTally := tally. [tally > 1] whileTrue: [array swap: 1 with: tally. tally := tally - 1. self downHeapSingle: 1]. tally := oldTally! ! !Heap methodsFor: 'accessing' stamp: 'md 1/19/2006 09:56'! first "Return the first element in the receiver" ^array at: 1! ! !Heap methodsFor: 'sorting' stamp: ''! sort "Sort this collection into ascending order using the '<=' operator." self sort: [:a :b | a <= b]! ! !Heap methodsFor: 'private' stamp: 'jcg 3/8/2003 02:08'! updateObjectIndex: index "If indexUpdateBlock is not nil, notify the object at index of its new position in the heap array." indexUpdateBlock ifNotNil: [ indexUpdateBlock value: (array at: index) value: index]! ! !Heap methodsFor: 'sorting' stamp: ''! isSortedBy: aBlock "Return true if the receiver is sorted by the given criterion." | lastElm elm | self isEmpty ifTrue: [^ true]. lastElm := self first. 2 to: self size do: [:index | elm := self at: index. (aBlock value: lastElm value: elm) ifFalse: [^ false]. lastElm := elm]. ^ true! ! !Heap methodsFor: 'private' stamp: 'ar 9/15/2000 17:12'! privateRemoveAt: index "Remove the element at the given index and make sure the sorting order is okay" | removed | removed := array at: index. array at: index put: (array at: tally). array at: tally put: nil. tally := tally - 1. index > tally ifFalse:[ "Use #downHeapSingle: since only one element has been removed" self downHeapSingle: index]. ^removed! ! !Heap methodsFor: 'accessing' stamp: 'nice 3/26/2011 17:38'! at: index "Heap are not designed to be accessed sequentially." self shouldNotImplement.! ! !Heap methodsFor: 'adding' stamp: 'jcg 3/8/2003 02:07'! add: anObject "Include newObject as one of the receiver's elements. Answer newObject." tally = array size ifTrue:[self grow]. array at: (tally := tally + 1) put: anObject. self updateObjectIndex: tally. self upHeap: tally. ^anObject! ! !Heap methodsFor: 'private' stamp: 'ar 7/1/1999 04:19'! array ^array! ! !Heap methodsFor: 'sorting' stamp: ''! mergeSortFrom: startIndex to: stopIndex by: aBlock "Sort the given range of indices using the mergesort algorithm. Mergesort is a worst-case O(N log N) sorting algorithm that usually does only half as many comparisons as heapsort or quicksort." "Details: recursively split the range to be sorted into two halves, mergesort each half, then merge the two halves together. An extra copy of the data is used as temporary storage and successive merge phases copy data back and forth between the receiver and this copy. The recursion is set up so that the final merge is performed into the receiver, resulting in the receiver being completely sorted." self size <= 1 ifTrue: [^ self]. "nothing to do" startIndex = stopIndex ifTrue: [^ self]. [startIndex >= 1 and: [startIndex < stopIndex]] assert. "bad start index" [stopIndex <= self size] assert. "bad stop index" self mergeSortFrom: startIndex to: stopIndex src: self copy dst: self by: aBlock! ! !Heap methodsFor: 'sorting' stamp: ''! sorted "Return a new sequenceable collection which contains the same elements as self but its elements are sorted in ascending order using the #'<=' operator." ^self sorted: [ :a :b| a <= b ]! ! !Heap methodsFor: 'sorting' stamp: ''! mergeFirst: first middle: middle last: last into: dst by: aBlock "Private. Merge the sorted ranges [first..middle] and [middle+1..last] of the receiver into the range [first..last] of dst." | i1 i2 val1 val2 out | i1 := first. i2 := middle + 1. val1 := self at: i1. val2 := self at: i2. out := first - 1. "will be pre-incremented" "select 'lower' half of the elements based on comparator" [(i1 <= middle) and: [i2 <= last]] whileTrue: [(aBlock value: val1 value: val2) ifTrue: [dst at: (out := out + 1) put: val1. val1 := self at: (i1 := i1 + 1)] ifFalse: [dst at: (out := out + 1) put: val2. i2 := i2 + 1. i2 <= last ifTrue: [val2 := self at: i2]]]. "copy the remaining elements" i1 <= middle ifTrue: [dst replaceFrom: out + 1 to: last with: self startingAt: i1] ifFalse: [dst replaceFrom: out + 1 to: last with: self startingAt: i2]! ! !Heap methodsFor: 'sorting' stamp: ''! sorted: aSortBlockOrNil "Return a new sequenceable collection which contains the same elements as self but its elements are sorted by aSortBlockOrNil. The block should take two arguments and return true if the first element should preceed the second one. If aSortBlock is nil then <= is used for comparison." ^self copy sort: aSortBlockOrNil! ! !Heap methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:37'! size "Answer how many elements the receiver contains." ^ tally! ! !Heap methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:05'! sortBlock: aBlock sortBlock := aBlock. self reSort.! ! !Heap methodsFor: 'testing' stamp: 'ar 9/10/1999 13:03'! isEmpty "Answer whether the receiver contains any elements." ^tally = 0! ! !Heap methodsFor: 'removing' stamp: 'nice 3/26/2011 17:36'! removeFirst "Remove the first element from the receiver" self emptyCheck. ^self privateRemoveAt: 1! ! !Heap methodsFor: 'accessing' stamp: 'CamilloBruni 10/20/2012 18:23'! defaultSortBlock ^ self class defaultSortBlock! ! !Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:04'! remove: oldObject ifAbsent: aBlock "Remove oldObject as one of the receiver's elements. If several of the elements are equal to oldObject, only one is removed. If no element is equal to oldObject, answer the result of evaluating anExceptionBlock. Otherwise, answer the argument, oldObject." 1 to: tally do:[:i| (array at: i) = oldObject ifTrue:[^self privateRemoveAt: i]]. ^aBlock value! ! !Heap methodsFor: 'private-heap' stamp: 'jcg 3/8/2003 02:11'! downHeap: anIndex "Check the heap downwards for correctness starting at anIndex. Everything above (i.e. left of) anIndex is ok." | value k n j | anIndex = 0 ifTrue:[^self]. n := tally bitShift: -1. k := anIndex. value := array at: anIndex. [k <= n] whileTrue:[ j := k + k. "use max(j,j+1)" (j < tally and:[self sorts: (array at: j+1) before: (array at: j)]) ifTrue:[ j := j + 1]. "check if position k is ok" (self sorts: value before: (array at: j)) ifTrue:[ "yes -> break loop" n := k - 1] ifFalse:[ "no -> make room at j by moving j-th element to k-th position" array at: k put: (array at: j). self updateObjectIndex: k. "and try again with j" k := j]]. array at: k put: value. self updateObjectIndex: k.! ! !Heap methodsFor: 'sorting' stamp: ''! mergeSortFrom: first to: last src: src dst: dst by: aBlock "Private. Split the range to be sorted in half, sort each half, and merge the two half-ranges into dst." | middle | first = last ifTrue: [^ self]. middle := (first + last) // 2. self mergeSortFrom: first to: middle src: dst dst: src by: aBlock. self mergeSortFrom: middle + 1 to: last src: dst dst: src by: aBlock. src mergeFirst: first middle: middle last: last into: dst by: aBlock! ! !Heap methodsFor: 'testing' stamp: 'ar 9/10/1999 13:03'! sorts: element1 before: element2 "Return true if element1 should be sorted before element2. This method defines the sort order in the receiver" ^sortBlock == nil ifTrue:[element1 <= element2] ifFalse:[sortBlock value: element1 value: element2].! ! !Heap methodsFor: 'copying' stamp: 'nice 8/21/2010 15:53'! copyEmpty "Answer a copy of the receiver without any of the receiver's elements." ^self class sortBlock: sortBlock! ! !Heap methodsFor: 'sorting' stamp: ''! isSorted "Return true if the receiver is sorted by the given criterion. Optimization for isSortedBy: [:a :b | a <= b]." | lastElm elm | self isEmpty ifTrue: [^ true]. lastElm := self first. 2 to: self size do: [:index | elm := self at: index. lastElm <= elm ifFalse: [^ false]. lastElm := elm]. ^ true! ! !Heap methodsFor: 'private' stamp: 'ar 7/1/1999 04:35'! setCollection: aCollection array := aCollection. tally := 0.! ! !Heap methodsFor: 'private-heap' stamp: 'jcg 3/8/2003 02:11'! downHeapSingle: anIndex "This version is optimized for the case when only one element in the receiver can be at a wrong position. It avoids one comparison at each node when travelling down the heap and checks the heap upwards after the element is at a bottom position. Since the probability for being at the bottom of the heap is much larger than for being somewhere in the middle this version should be faster." | value k n j | anIndex = 0 ifTrue:[^self]. n := tally bitShift: -1. k := anIndex. value := array at: anIndex. [k <= n] whileTrue:[ j := k + k. "use max(j,j+1)" (j < tally and:[self sorts: (array at: j+1) before: (array at: j)]) ifTrue:[ j := j + 1]. array at: k put: (array at: j). self updateObjectIndex: k. "and try again with j" k := j]. array at: k put: value. self updateObjectIndex: k. self upHeap: k! ! !Heap methodsFor: 'accessing' stamp: 'nice 3/26/2011 17:38'! at: index put: newObject "Heap are not designed to be accessed sequentially. Please consider using #add: instead." self shouldNotImplement.! ! !Heap methodsFor: 'comparing' stamp: 'CamilloBruni 10/20/2012 18:17'! = anObject "Heap are considered equals only if they have same sort order and same elements." self == anObject ifTrue: [^true]. anObject isHeap ifFalse: [^false]. self sortBlock = anObject sortBlock ifFalse: [^false]. self size = anObject size ifFalse: [^false]. ^(self asArray sort: sortBlock) = (anObject asArray sort: sortBlock)! ! !Heap methodsFor: 'enumerating' stamp: 'ar 9/10/1999 13:05'! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." 1 to: tally do:[:i| aBlock value: (array at: i)]! ! !Heap methodsFor: 'copying' stamp: 'nice 10/5/2009 08:47'! postCopy super postCopy. array := array copy! ! !Heap methodsFor: 'sorting' stamp: 'StephaneDucasse 10/2/2010 17:37'! fullySort "Fully sort the heap. This method preserves the heap invariants and can thus be sent safely" self privateReverseSort. 1 to: tally // 2 do: [:i | array swap: i with: 1 + tally - i]! ! !Heap methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:05'! indexUpdateBlock: aBlockOrNil indexUpdateBlock := aBlockOrNil. ! ! !Heap methodsFor: 'sorting' stamp: ''! sort: aSortBlock "Sort this array using aSortBlock. The block should take two arguments and return true if the first element should preceed the second one." self mergeSortFrom: 1 to: self size by: aSortBlock! ! !Heap methodsFor: 'enumerating' stamp: 'nice 8/21/2010 15:40'! collect: aBlock ^self collect: aBlock as: Array! ! !Heap methodsFor: 'private-heap' stamp: 'jcg 3/8/2003 02:12'! upHeap: anIndex "Check the heap upwards for correctness starting at anIndex. Everything below anIndex is ok." | value k kDiv2 tmp | anIndex = 0 ifTrue:[^self]. k := anIndex. value := array at: anIndex. [ (k > 1) and:[self sorts: value before: (tmp := array at: (kDiv2 := k bitShift: -1))] ] whileTrue:[ array at: k put: tmp. self updateObjectIndex: k. k := kDiv2]. array at: k put: value. self updateObjectIndex: k.! ! !Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'! growTo: newSize "Grow to the requested size." | newArray | newArray := Array new: (newSize max: tally). newArray replaceFrom: 1 to: array size with: array startingAt: 1. array := newArray! ! !Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'! trim "Remove any empty slots in the receiver." self growTo: self size.! ! !Heap methodsFor: 'accessing' stamp: 'CamilloBruni 10/20/2012 18:23'! sortBlock ^ sortBlock ifNil: [ sortBlock := self defaultSortBlock ]! ! !Heap methodsFor: 'removing' stamp: 'klub 9/14/2009 19:10'! removeAll array atAllPut: nil. tally := 0! ! !Heap class methodsFor: 'instance creation' stamp: 'ar 7/1/1999 04:20'! new: n ^super new setCollection: (Array new: n)! ! !Heap class methodsFor: 'instance creation' stamp: 'MarcusDenker 6/24/2013 11:12'! withAll: aCollection sortBlock: aBlock "Create a new heap with all the elements from aCollection" ^(self basicNew) setCollection: aCollection asArray copy tally: aCollection size; sortBlock: aBlock; yourself! ! !Heap class methodsFor: 'instance creation' stamp: 'ar 7/1/1999 04:20'! new ^self new: 10! ! !Heap class methodsFor: 'instance creation' stamp: 'ar 9/10/1999 14:13'! sortBlock: aBlock "Create a new heap sorted by the given block" ^self new sortBlock: aBlock! ! !Heap class methodsFor: 'accessing' stamp: 'CamilloBruni 10/20/2012 18:22'! defaultSortBlock "Cache the default sort block here. Since the sortBlock is used to compare instances, a single instance for the default block helps us.." ^ sortBlock ifNil: [ sortBlock := [ :a :b | a <= b]]! ! !Heap class methodsFor: 'instance creation' stamp: 'ar 9/10/1999 13:23'! withAll: aCollection "Create a new heap with all the elements from aCollection" ^(self basicNew) setCollection: aCollection asArray copy tally: aCollection size; reSort; yourself! ! !HeapTest commentStamp: 'TorstenBergmann 2/20/2014 15:28'! SUnit tests for heap collections! !HeapTest methodsFor: 'tests - set arithmetic' stamp: ''! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !HeapTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''! testOccurrencesOfForMultipliness | collection elem | collection := self collectionWithEqualElements . elem := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: elem ) = 2. ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:12'! moreThan4Elements " return a collection including at leat 4 elements" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementReallyRemovesElement "self debug: #testRemoveElementReallyRemovesElement" | size | size := self nonEmptyWithoutEqualElements size. self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! !HeapTest methodsFor: 'tests - converting' stamp: ''! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:06'! secondIndex " return an index between 'nonEmpty' bounds that is > to 'second index' " ^3! ! !HeapTest methodsFor: 'tests - converting' stamp: ''! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !HeapTest methodsFor: 'test - creation' stamp: ''! testWithWithWith "self debug: #testWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !HeapTest methodsFor: 'tests - adding' stamp: ''! testTWrite | added collection elem | collection := self otherCollection . elem := self element . added := collection write: elem . self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: elem ) . self assert: (collection includes: elem ). ! ! !HeapTest methodsFor: 'tests - converting' stamp: ''! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !HeapTest methodsFor: 'tests - converting' stamp: ''! testAsByteArray | res | self integerCollectionWithoutEqualElements. self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ]. res := true. self integerCollectionWithoutEqualElements detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 09:56'! elementNotInForIndexAccessing " return an element not included in 'collectionMoreThan1NoDuplicates' " ^ elementNotIn ! ! !HeapTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:43'! firstCollection " return a collection that will be the first part of the concatenation" ^nonEmpty ! ! !HeapTest methodsFor: 'parameters' stamp: 'cyrille.delaunay 3/20/2009 13:22'! valuePutIn "the value that we will put in the non empty collection" ^ 7! ! !HeapTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !HeapTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asArray sort. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !HeapTest methodsFor: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:11'! collectionWithoutEqualElements " return a collection not including equal elements " ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'basic tests' stamp: 'nice 3/26/2011 17:50'! testAdd "self run: #testAdd" | heap | heap := Heap new. self assert: heap size = 0. heap add: 3. self assert: heap size = 1. self assert: heap isEmpty not. self assert: heap first = 3. heap add: 2. self assert: heap size = 2. self assert: heap first = 2. ! ! !HeapTest methodsFor: 'test - creation' stamp: ''! testWith "self debug: #testWith" | aCol anElement | anElement := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: anElement. self assert: (aCol includes: anElement).! ! !HeapTest methodsFor: 'tests - converting' stamp: ''! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !HeapTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !HeapTest methodsFor: 'testing' stamp: 'nice 8/21/2010 16:33'! testIfEqualIsTransitive "This is http://bugs.squeak.org/view.php?id=6943" | anArray heap1 heap2 | anArray := #(1 2 3). heap1 := Heap withAll: (1 to: 3) sortBlock: [:a :b | a < b]. heap2 := Heap withAll: (1 to: 3) sortBlock: [:a :b | b > a]. self assert: (heap1 = anArray) & (heap2 = anArray) ==> (heap1 = heap2) description: 'Heap equality should be transitive'! ! !HeapTest methodsFor: 'tests - copy' stamp: ''! testCopyNotSame "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self nonEmpty copy. self deny: copy == self nonEmpty.! ! !HeapTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !HeapTest methodsFor: 'tests - adding' stamp: ''! testTWriteTwice | added oldSize collection elem | collection := self collectionWithElement . elem := self element . oldSize := collection size. added := collection write: elem ; write: elem . self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: elem ). self assert: collection size = (oldSize + 2)! ! !HeapTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collectionWithoutEqualElements difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res size equals: self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (res includes: each)]. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res equals: separateCol! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/18/2009 15:07'! collectionWithElement ^ collectionWithElement! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:13'! withEqualElements ^ sameAtEndAndBegining ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:05'! firstIndex " return an index between 'nonEmpty' bounds that is < to 'second index' " ^2! ! !HeapTest methodsFor: 'tests - adding' stamp: ''! testTAddIfNotPresentWithElementAlreadyIn | added oldSize collection anElement | collection := self collectionWithElement . oldSize := collection size. anElement := self element . self assert: (collection includes: anElement ). added := collection addIfNotPresent: anElement . self assert: added == anElement . "test for identiy because #add: has not reason to copy its parameter." self assert: collection size = oldSize! ! !HeapTest methodsFor: 'tests - adding' stamp: ''! testTAddAll | added collection toBeAdded | collection := self collectionWithElement . toBeAdded := self otherCollection . added := collection addAll: toBeAdded . self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." self assert: (collection includesAll: toBeAdded )! ! !HeapTest methodsFor: 'tests - adding' stamp: ''! testTAddWithOccurences | added oldSize collection anElement | collection := self collectionWithElement . anElement := self element . oldSize := collection size. added := collection add: anElement withOccurrences: 5. self assert: added == anElement. "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: anElement). self assert: collection size = (oldSize + 5)! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 15:44'! anotherElementNotIn " return an element different of 'elementNotIn' not included in 'nonEmpty' " ^ 9999! ! !HeapTest methodsFor: 'tests - remove' stamp: ''! testRemoveIfAbsent "self debug: #testRemoveElementThatExists" | el res | el := self elementNotIn. res := self nonEmptyWithoutEqualElements remove: el ifAbsent: [ 33 ]. self assert: res = 33! ! !HeapTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementFromEmpty "self debug: #testRemoveElementFromEmpty" self should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] raise: Error! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:26'! collectionWithElementsToRemove " return a collection of elements included in 'nonEmpty' " ^ self nonEmpty ! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 11:33'! elementTwiceIn ^elementTwiceIn! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 13:46'! expectedSizeAfterReject "Number of even elements in #collection" ^ expectedSizeAfterReject.! ! !HeapTest methodsFor: 'tests - adding' stamp: ''! testTAdd | added collection | collection :=self otherCollection . added := collection add: self element. self assert: added == self element. "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: self element) . self assert: (self collectionWithElement includes: self element). ! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeTest | anElementIn | self nonEmpty. self deny: self nonEmpty isEmpty. self elementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self anotherElementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self empty. self assert: self empty isEmpty! ! !HeapTest methodsFor: 'tests - including with identity' stamp: ''! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection anElement | collection := self collectionWithCopyNonIdentical. anElement := collection anyOne copy. self deny: (collection identityIncludes: anElement)! ! !HeapTest methodsFor: 'basic tests' stamp: 'stephane.ducasse 5/20/2009 18:11'! testFirst "self run: #testFirst" | heap | heap := Heap new. heap add: 5. heap add: 12. heap add: 1. self assert: heap first = 1. heap removeFirst. self assert: heap first = 5.! ! !HeapTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !HeapTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotIn). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotIn)! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 12/18/2009 13:08'! replacementCollection " return a collection including elements of type 'collectionOfSize5' elements'type" ^ collectionWith4Elements ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:01'! collectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals . (others elements of the collection are not equal to those elements)" ^ sameAtEndAndBegining ! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSetAritmeticTest self collection. self deny: self collection isEmpty. self nonEmpty. self deny: self nonEmpty isEmpty. self anotherElementOrAssociationNotIn. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self collectionClass! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeWithIdentityTest | anElement | self collectionWithCopyNonIdentical. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:23'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'tests - adding' stamp: ''! testTAddTwice | added oldSize collection anElement | collection := self collectionWithElement . anElement := self element . oldSize := collection size. added := collection add: anElement ; add: anElement . self assert: added == anElement . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: anElement ). self assert: collection size = (oldSize + 2)! ! !HeapTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 8/31/2013 20:23'! test0FixtureRequirementsOfTGrowableTest self empty. self nonEmpty. self element. self elementNotInForOccurrences. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty. self assert: (self nonEmpty includes: self element). self deny: (self nonEmpty includes: self elementNotInForOccurrences)! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self collectionWithoutEqualElements. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:12'! integerCollectionWithoutEqualElements " return a collection of integer without equal elements" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'tests - copy' stamp: ''! testCopyEquals "self debug: #testCopySameClass" "A copy should be equivalent to the things it's a copy of" | copy | copy := self nonEmpty copy. self assert: copy = self nonEmpty.! ! !HeapTest methodsFor: 'testing' stamp: 'nice 3/26/2011 17:49'! test1 | data | "The first element of each array is the sort value, and the second will be updated by the heap with the index of the element within the heap." data := (1 to: 8) collect: [:i | {i*2. 0}]. "Repeat with different data ordering." 5 timesRepeat: [ | h | h := Heap new sortBlock: [:e1 :e2 | e1 first < e2 first]. h indexUpdateBlock: [:array :index | array at: 2 put: index]. data shuffled do: [:d | h add: d]. data do: [:d | self should: (h asArray at: d second) == d]. ]! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:18'! elementInForOccurrences ^self nonEmpty anyOne! ! !HeapTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementThatExists "self debug: #testRemoveElementThatExists" | el res | el := self nonEmptyWithoutEqualElements anyOne. res := self nonEmptyWithoutEqualElements remove: el. self assert: res == el! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:00'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !HeapTest methodsFor: 'tests - adding' stamp: ''! testTAddIfNotPresentWithNewElement | added oldSize collection elem | collection := self otherCollection . oldSize := collection size. elem := self element . self deny: (collection includes: elem ). added := collection addIfNotPresent: elem . self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection size = (oldSize + 1)). ! ! !HeapTest methodsFor: 'tests - includes' stamp: ''! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !HeapTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !HeapTest methodsFor: 'tests - growable' stamp: 'delaunay 4/2/2009 11:53'! testAddNonEmptyGrowsWhenNewElement "self debug: #testAddNonEmptyGrowsWhenNewElement" | oldSize | oldSize := self nonEmpty size. self deny: (self nonEmpty includes: self elementNotInForOccurrences). self nonEmpty add: self elementNotInForOccurrences. self assert: self nonEmpty size > oldSize! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:15'! elementsCopyNonIdenticalWithoutEqualElements " return a collection that does niot incllude equal elements ( classic equality ) all elements included are elements for which copy is not identical to the element " ^ floatCollection ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 09:55'! collectionMoreThan1NoDuplicates " return a collection of size > 1 without equal elements" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'basic tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testRemove "self run: #testRemove" | heap | heap := Heap new. self should: [ heap removeFirst ] raise: Error. heap add: 5. heap removeFirst. self assert: heap size = 0. heap add: 5. self should: [ heap removeAt: 2 ] raise: Error! ! !HeapTest methodsFor: 'tests - converting' stamp: ''! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !HeapTest methodsFor: 'basic tests' stamp: 'nice 8/21/2010 16:11'! testSortBlock "self run: #testSortBlock" | heap | heap := Heap withAll: #(1 3 5). self assert: heap asArray = #(1 3 5). heap sortBlock: [ :e1 :e2 | e1 >= e2 ]. self assert: heap asArray = #(5 3 1) ! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureOccurrencesForMultiplinessTest | cpt anElement collection | self collectionWithEqualElements. self collectionWithEqualElements. self elementTwiceInForOccurrences. anElement := self elementTwiceInForOccurrences. collection := self collectionWithEqualElements. cpt := 0. " testing with identity check ( == ) so that identy collections can use this trait : " self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. self assert: cpt = 2! ! !HeapTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAny: self empty). self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAny: self nonEmpty).! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/18/2009 15:23'! nonEmpty ^nonEmpty.! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:28'! elementToAdd " return an element of type 'nonEmpy' elements'type'" ^ elementNotIn ! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCreationWithTest self collectionMoreThan5Elements. self assert: self collectionMoreThan5Elements size >= 5! ! !HeapTest methodsFor: 'requirements' stamp: ''! collectionWithCopy "return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals ( with identity equality) but 2 elements only equals with classic equality" | result collection | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. collection add: collection first copy. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:12'! accessCollection ^ nonEmpty5ElementsWithoutDuplicate! ! !HeapTest methodsFor: 'tests - remove' stamp: ''! testRemoveAllFoundIn "self debug: #testRemoveElementThatExists" | el aSubCollection res | el := self nonEmptyWithoutEqualElements anyOne. aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. res := self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureRequirementsOfTAddTest self collectionWithElement. self otherCollection. self element. self assert: (self collectionWithElement includes: self element). self deny: (self otherCollection includes: self element)! ! !HeapTest methodsFor: 'test - creation' stamp: ''! testWithWith "self debug: #testWithWith" | aCol collection element1 element2 | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . element1 := collection at: 1. element2 := collection at:2. aCol := self collectionClass with: element1 with: element2 . self assert: (aCol occurrencesOf: element1 ) = ( collection occurrencesOf: element1). self assert: (aCol occurrencesOf: element2 ) = ( collection occurrencesOf: element2). ! ! !HeapTest methodsFor: 'requirements' stamp: ''! collectionWithIdentical "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" | result collection anElement | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. anElement := collection first. collection add: anElement. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:10'! elementInForElementAccessing " return an element inculded in 'moreThan4Elements'" ^ self moreThan4Elements anyOne.! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTRemoveTest | duplicate | self empty. self nonEmptyWithoutEqualElements. self deny: self nonEmptyWithoutEqualElements isEmpty. duplicate := true. self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ]. self assert: duplicate = false. self elementNotIn. self assert: self empty isEmpty. self deny: self nonEmptyWithoutEqualElements isEmpty. self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 12/18/2009 13:08'! sizeCollection "Answers a collection whose #size is 4" ^collectionWith4Elements ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:06'! newElement "return an element that will be put in the collection in place of another" ^ elementNotIn ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:17'! aValue " return a value to put into nonEmpty" ^ self nonEmpty anyOne ! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/18/2009 15:24'! empty ^empty.! ! !HeapTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res anElement | anElement := self elementToAdd . res := self nonEmpty copyWith: anElement. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: (anElement value)). self nonEmpty do: [ :each | res includes: each ]! ! !HeapTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAllNotIncluded "self debug: #testCopyNonEmptyWithoutAllNotIncluded" | res | res := self nonEmpty copyWithoutAll: self collectionNotIncluded. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:19'! indexArray " return a Collection including indexes between bounds of 'nonEmpty' " ^ indexArray ! ! !HeapTest methodsFor: 'tests - remove' stamp: ''! testRemoveAll "self debug: #testRemoveElementThatExists" | el aSubCollection collection res | collection := self nonEmptyWithoutEqualElements. el := collection anyOne. aSubCollection := collection copyWithout: el. res := collection removeAll: aSubCollection. self assert: collection size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 12/18/2009 13:07'! collection ^ collectionWith4Elements.! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:43'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne! ! !HeapTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:06'! collectionWithEqualElements " return a collecition including atLeast two elements equal" ^ collectionWithDuplicateElement ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:13'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !HeapTest methodsFor: 'tests - converting' stamp: ''! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTConvertAsSetForMultiplinessTest "a collection with equal elements:" | res | self withEqualElements. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:34'! collectionOfSize5 " return a collection of size 5" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !HeapTest methodsFor: 'examples' stamp: 'md 2/12/2006 15:34'! heapSortExample "HeapTest new heapSortExample" "Sort a random collection of Floats and compare the results with SortedCollection (using the quick-sort algorithm) and ArrayedCollection>>mergeSortFrom:to:by: (using the merge-sort algorithm)." | n rnd array time sorted | n := 10000. "# of elements to sort" rnd := Random new. array := (1 to: n) collect:[:i| rnd next]. "First, the heap version" time := Time millisecondsToRun:[ sorted := Heap withAll: array. 1 to: n do:[:i| sorted removeFirst]. ]. Transcript cr; show:'Time for heap-sort: ', time printString,' msecs'. "The quicksort version" time := Time millisecondsToRun:[ sorted := SortedCollection withAll: array. ]. Transcript cr; show:'Time for quick-sort: ', time printString,' msecs'. "The merge-sort version" time := Time millisecondsToRun:[ array mergeSortFrom: 1 to: array size by: [:v1 :v2| v1 <= v2]. ]. Transcript cr; show:'Time for merge-sort: ', time printString,' msecs'. ! ! !HeapTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !HeapTest methodsFor: 'test - creation' stamp: ''! testWithAll "self debug: #testWithAll" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection . aCol := self collectionClass withAll: collection . collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. self assert: (aCol size = collection size ).! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureOccurrencesTest | tmp | self empty. self assert: self empty isEmpty. self collectionWithoutEqualElements. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each ]. self elementNotInForOccurrences. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:26'! collectionNotIncluded " return a collection for wich each element is not included in 'nonEmpty' " ^ collectionNotIncluded ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ elementNotIn! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:43'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotIn ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:43'! secondCollection " return a collection that will be the second part of the concatenation" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 09:57'! elementInForIndexAccessing " return an element included in 'collectionMoreThan1NoDuplicates' " ^ self collectionMoreThan1NoDuplicates anyOne.! ! !HeapTest methodsFor: 'tests - as set tests' stamp: ''! testAsIdentitySetWithEqualsElements | result collection | collection := self withEqualElements . result := collection asIdentitySet. collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = IdentitySet.! ! !HeapTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !HeapTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !HeapTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !HeapTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" | difference | self assert: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements) isEmpty. self assert: (self empty difference: self collectionWithoutEqualElements) isEmpty. difference := (self collectionWithoutEqualElements difference: self empty). self assert: difference size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each)]. ! ! !HeapTest methodsFor: 'tests - converting' stamp: ''! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !HeapTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOf | collection | collection := self collectionWithoutEqualElements . collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! !HeapTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionItself "self debug: #testIntersectionItself" | result | result := (self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements). self assert: result size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (result includes: each) ]. ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:06'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ duplicateElement ! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0CopyTest self empty. self assert: self empty size = 0. self nonEmpty. self assert: (self nonEmpty size = 0) not. self collectionWithElementsToRemove. self assert: (self collectionWithElementsToRemove size = 0) not. self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ]. self elementToAdd. self deny: (self nonEmpty includes: self elementToAdd). self collectionNotIncluded. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 13:37'! element ^ element! ! !HeapTest methodsFor: 'basic tests' stamp: 'stephane.ducasse 5/20/2009 18:11'! testHeap "self run: #testHeap" | heap | heap := Heap new. self assert: heap isHeap. self assert: heap isEmpty. heap add: 1. self assert: heap isEmpty not ! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/18/2009 15:08'! otherCollection ^ otherCollection! ! !HeapTest methodsFor: 'tests - remove' stamp: ''! testRemoveAllSuchThat "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self nonEmptyWithoutEqualElements anyOne. aSubCollection := self nonEmptyWithoutEqualElements copyWithout: el. self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | aSubCollection includes: each ]. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:35'! indexInNonEmpty " return an index between bounds of 'nonEmpty' " ^2! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:01'! collectionWithNonIdentitySameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ sameAtEndAndBegining ! ! !HeapTest methodsFor: 'test - remove' stamp: ''! testRemoveElementThatExistsTwice "self debug: #testRemoveElementThatDoesExistsTwice" | size | size := self nonEmpty size. self assert: (self nonEmpty includes: self elementTwiceIn). self nonEmpty remove: self elementTwiceIn. self assert: size - 1 = self nonEmpty size. self assert: (self nonEmpty includes: self elementTwiceIn). self nonEmpty remove: self elementTwiceIn. self assert: size - 2 = self nonEmpty size! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 12/18/2009 12:05'! result ^ collectResult.! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 15:44'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ floatCollection ! ! !HeapTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !HeapTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !HeapTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testExamples self heapExample. self heapSortExample! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:42'! collectionClass " return the class to be used to create instances of the class tested" ^ Heap! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:11'! nonEmpty1Element " return a collection of size 1 including one element" ^ nonEmpty1Element ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:53'! nonEmptyWithoutEqualElements " return a collection without equal elements " ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !HeapTest methodsFor: 'examples' stamp: 'md 2/12/2006 15:33'! heapExample "HeapTest new heapExample" "Create a sorted collection of numbers, remove the elements sequentially and add new objects randomly. Note: This is the kind of benchmark a heap is designed for." | n rnd array time sorted | n := 5000. "# of elements to sort" rnd := Random new. array := (1 to: n) collect:[:i| rnd next]. "First, the heap version" time := Time millisecondsToRun:[ sorted := Heap withAll: array. 1 to: n do:[:i| sorted removeFirst. sorted add: rnd next]. ]. Transcript cr; show:'Time for Heap: ', time printString,' msecs'. "The quicksort version" time := Time millisecondsToRun:[ sorted := SortedCollection withAll: array. 1 to: n do:[:i| sorted removeFirst. sorted add: rnd next]. ]. Transcript cr; show:'Time for SortedCollection: ', time printString,' msecs'. ! ! !HeapTest methodsFor: 'basic tests' stamp: 'stephane.ducasse 5/20/2009 18:11'! testDo "self run: #testDo" | heap coll | heap := Heap withAll: #(1 3 5). coll := OrderedCollection new. heap do: [:each | coll add: each]. self assert: coll = #(1 3 5) asOrderedCollection. ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:13'! subCollectionNotIn " return a collection for which at least one element is not included in 'moreThan4Elements' " ^ collectionNotIncluded ! ! !HeapTest methodsFor: 'tests - as identity set' stamp: ''! testAsIdentitySetWithoutIdentityEqualsElements | result collection | collection := self collectionWithCopy. result := collection asIdentitySet. " no elements should have been removed as no elements are equels with Identity equality" self assert: result size = collection size. collection do: [ :each | (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. self assert: result class = IdentitySet! ! !HeapTest methodsFor: 'tests - copy' stamp: ''! testCopySameClass "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self empty copy. self assert: copy class == self empty class.! ! !HeapTest methodsFor: 'test - creation' stamp: ''! testWithWithWithWith "self debug: #testWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !HeapTest methodsFor: 'tests - as identity set' stamp: ''! testAsIdentitySetWithIdentityEqualsElements | result | result := self collectionWithIdentical asIdentitySet. " Only one element should have been removed as two elements are equals with Identity equality" self assert: result size = (self collectionWithIdentical size - 1). self collectionWithIdentical do: [ :each | (self collectionWithIdentical occurrencesOf: each) > 1 ifTrue: [ "the two elements equals only with classic equality shouldn't 'have been removed" self assert: (result asOrderedCollection occurrencesOf: each) = 1 " the other elements are still here" ] ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ]. self assert: result class = IdentitySet! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 11:26'! speciesClass ^ speciesClass! ! !HeapTest methodsFor: 'tests - set arithmetic' stamp: ''! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureAsSetForIdentityMultiplinessTest "a collection (of elements for which copy is not identical ) without equal elements:" | anElement res | self elementsCopyNonIdenticalWithoutEqualElements. anElement := self elementsCopyNonIdenticalWithoutEqualElements anyOne. self deny: anElement copy == anElement. res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 11:19'! expectedElementByDetect "Returns the first even element of #collection" ^ expectedElementByDetect. ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:09'! replacementCollectionSameSize " return a collection of size (secondIndex - firstIndex + 1)" ^subCollection ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:15'! elementNotIn ^ elementNotIn ! ! !HeapTest methodsFor: 'running' stamp: 'cyrille.delaunay 12/18/2009 13:07'! setUp element := 33. elementNotIn := 666. elementTwiceIn := 3. expectedSizeAfterReject := 1. expectedElementByDetect := -2. nonEmpty5ElementsWithoutDuplicate := Heap new add: 2; add: 98; add: 4; add: 25; add: 1; yourself. collectionWithElement := Heap new. { 4. 5. 6. 2. 1. 1. (self element) } do: [ :nb | collectionWithElement add: nb ]. collectionWith4Elements := Heap new add: 1; add: -2; add: 3; add: 1; yourself. otherCollection := Heap new add: 1; add: 20; add: 30; yourself. empty := Heap new. nonEmpty := Heap new add: self valuePutIn; add: self element; add: self elementTwiceIn; add: self elementTwiceIn; yourself. collectionNotIncluded := Heap new add: elementNotIn; add: elementNotIn; yourself. doWithoutNumber := 3. collectResult := collectionWith4Elements collect: [ :each | each + 1 ]. speciesClass := Heap. sameAtEndAndBegining := Heap new add: 1.5 ; add: 1.5 copy ; yourself. nonEmpty1Element := Heap new add: 5 ; yourself. floatCollection := Heap new add: 2.5 ; add: 5.5 ; add:4.2 ; yourself. indexArray := #( 1 3). subCollection := Heap new. duplicateElement := 1. collectionWithDuplicateElement := Heap new add: duplicateElement ; add: duplicateElement ; add:4 ; yourself. self firstIndex to: self secondIndex do: [:each | subCollection add: elementNotIn ]. ! ! !HeapTest methodsFor: 'tests - growable' stamp: ''! testAddEmptyGrows "self debug: #testAddEmptyGrows" | oldSize | oldSize := self empty size. self empty add: self element. self assert: (self empty size) = (oldSize + 1).! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:07'! moreThan3Elements " return a collection including atLeast 3 elements" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'test - creation' stamp: ''! testWithWithWithWithWith "self debug: #testWithWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:11'! elementNotInForElementAccessing " return an element not included in 'moreThan4Elements' " ^ elementNotIn ! ! !HeapTest methodsFor: 'tests - as set tests' stamp: ''! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:44'! nonEmptyMoreThan1Element " return a collection that don't includes equal elements'" ^nonEmpty5ElementsWithoutDuplicate .! ! !HeapTest methodsFor: 'tests - converting' stamp: ''! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !HeapTest methodsFor: 'tests - includes' stamp: ''! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:39'! indexInForCollectionWithoutDuplicates " return an index between 'collectionWithoutEqualsElements' bounds" ^ 2! ! !HeapTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureConverAsSortedTest self collectionWithSortableElements. self deny: self collectionWithSortableElements isEmpty! ! !HeapTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWith "self debug: #testCopyWith" | res anElement | anElement := self elementToAdd. res := self empty copyWith: anElement. self assert: res size = (self empty size + 1). self assert: (res includes: (anElement value))! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:01'! collectionWith5Elements " return a collection of size 5 including 5 elements" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'tests - remove' stamp: ''! testRemoveAllError "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self elementNotIn. aSubCollection := self nonEmptyWithoutEqualElements copyWith: el. self should: [ | res | res := self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! ! !HelpAPIDocumentation commentStamp: 'tbn 4/30/2010 15:12'! This class represents the browsable package API help for the help system. Instance Variables ! !HelpAPIDocumentation class methodsFor: 'accessing' stamp: 'tbn 3/29/2010 14:50'! bookName ^'API Documentation'! ! !HelpAPIDocumentation class methodsFor: 'defaults' stamp: 'tbn 3/11/2010 23:57'! builder ^PackageAPIHelpBuilder! ! !HelpAPIDocumentation class methodsFor: 'accessing' stamp: 'StephanEggermont 12/9/2013 19:59'! helpPackages ^#('HelpSystem-Core-Model' 'HelpSystem-Core-Utilities' 'HelpSystem-Core-UI')! ! !HelpBrowser commentStamp: 'tbn 3/8/2010 09:33'! A HelpBrowser is used to display a hierarchy of help topics and their contents. Instance Variables rootTopic: window: treeMorph: contentMorph: rootTopic - xxxxx window - xxxxx treeMorph - xxxxx contentMorph - xxxxx ! !HelpBrowser methodsFor: 'actions' stamp: 'AlexandreBergel 4/29/2011 21:05'! refresh | helpTopic items | helpTopic := self helpTopic. window setLabel: helpTopic title. items := helpTopic subtopics collect: [ :each | HelpTopicListItemWrapper with: each ]. treeMorph list: items. contentMorph setText: helpTopic contents! ! !HelpBrowser methodsFor: 'ui' stamp: 'StephaneDucasse 12/19/2012 16:43'! initWindow | toolbar dock| window := (Smalltalk at: #StandardWindow) new. window model: self. window title: 'Help Browser'. toolbar := window newToolbar: {window newButtonFor: self getState: nil action: #refresh arguments: nil getEnabled: nil labelForm: (HelpIcons iconNamed: #refreshIcon) help: 'Refresh' translated. }. dock := window newToolDockingBar. dock addMorphBack: toolbar. window addMorph: dock fullFrame: ( (0@0 corner: 1@0) asLayoutFrame bottomOffset: dock minExtent y). "Tree" treeMorph := PluggableTreeMorph new. treeMorph model: self; setSelectedSelector: #onItemClicked:. window addMorph: treeMorph fullFrame: ((0@0 corner: 0.3@1) asLayoutFrame topOffset: dock minExtent y). "Text" contentMorph := self defaultViewerClass on: self text: nil accept: nil readSelection: nil menu: nil. window addMorph: contentMorph fullFrame: ((0.3@0 corner: 1@1) asLayoutFrame topOffset: dock minExtent y). ! ! !HelpBrowser methodsFor: 'initialization' stamp: 'tbn 3/5/2010 23:39'! initialize super initialize. self initWindow. ! ! !HelpBrowser methodsFor: 'accessing' stamp: 'tbn 3/5/2010 22:56'! rootTopic ^rootTopic! ! !HelpBrowser methodsFor: 'ui' stamp: 'tbn 2/12/2010 12:57'! close window notNil ifTrue: [window delete]! ! !HelpBrowser methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:11'! rootTopic: aHelpTopic rootTopic := aHelpTopic. self refresh ! ! !HelpBrowser methodsFor: 'defaults' stamp: 'tbn 4/30/2010 12:39'! defaultViewerClass ^PluggableTextMorph! ! !HelpBrowser methodsFor: 'ui' stamp: 'tbn 3/3/2010 23:32'! open "Open the receivers window" self refresh. window openInWorld. ! ! !HelpBrowser methodsFor: 'events' stamp: 'ClementBera 7/26/2013 16:45'! onItemClicked: anItem anItem ifNil: [^contentMorph setText: rootTopic asHelpTopic contents]. contentMorph setText: anItem contents! ! !HelpBrowser methodsFor: 'actions' stamp: 'AlexandreBergel 4/29/2011 21:05'! helpTopic ^ helpTopicCache ifNil: [ helpTopicCache := rootTopic asHelpTopic ]! ! !HelpBrowser methodsFor: '*Shout-Styling' stamp: 'AlainPantec 2/23/2012 08:30'! shoutAboutToStyle: aPluggableShoutMorphOrView ^ (self rootTopic respondsTo: #canHaveSyntaxHighlighting) and: [self rootTopic canHaveSyntaxHighlighting]! ! !HelpBrowser class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'tbn 5/20/2010 11:47'! taskbarIcon "Answer the icon for the receiver in a task bar." ^HelpIcons iconNamed: #bookIcon! ! !HelpBrowser class methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:17'! defaultHelpBrowser ^ DefaultHelpBrowser ifNil: [DefaultHelpBrowser := self] ! ! !HelpBrowser class methodsFor: 'world menu' stamp: 'EstebanLorenzano 5/14/2013 09:44'! menuCommandOn: aBuilder (aBuilder item: #'Help Browser') parent: #Help; action: [self open]; icon: Smalltalk ui icons smallHelpIcon! ! !HelpBrowser class methodsFor: 'instance creation' stamp: 'tbn 9/20/2010 09:36'! openOn: aHelpTopic "Open the receiver on the given help topic or any other object that can be transformed into a help topic by sending #asHelpTopic." ^(self defaultHelpBrowser new) rootTopic: aHelpTopic; open; yourself! ! !HelpBrowser class methodsFor: 'instance creation' stamp: 'tbn 5/3/2010 18:37'! open ^self openOn: SystemHelp! ! !HelpBrowser class methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme ^ Smalltalk ui theme ! ! !HelpBrowser class methodsFor: 'accessing' stamp: 'tbn 5/3/2010 18:42'! defaultHelpBrowser: aClass "Use a new help browser implementation" DefaultHelpBrowser := aClass ! ! !HelpBrowserTest commentStamp: 'TorstenBergmann 2/4/2014 21:18'! SUnit tests for the help browser! !HelpBrowserTest methodsFor: 'testing' stamp: 'tbn 5/3/2010 20:22'! 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 ] ! ! !HelpBrowserTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:33'! testOpen |browser| browser := self defaultTestClass open. World doOneCycleNow. browser close ! ! !HelpBrowserTest methodsFor: 'accessing' stamp: 'tbn 5/3/2010 19:35'! defaultTestClass ^HelpBrowser! ! !HelpBrowserTest methodsFor: 'testing' stamp: 'tbn 5/3/2010 19:28'! 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 ] ! ! !HelpBrowserTest methodsFor: 'testing' stamp: 'tbn 5/3/2010 18:43'! testLazyDefaultHelpBrowser self assert: self defaultTestClass defaultHelpBrowser notNil! ! !HelpBuilder commentStamp: 'tbn 2/12/2010 14:54'! This is an utility class that builds the books for a help system. Instance Variables rootTopics: rootTopics - a collection of books ! !HelpBuilder methodsFor: 'initialization' stamp: 'tbn 3/5/2010 23:12'! initialize "Initializes the receiver" super initialize. topicToBuild := self topicClass new. ! ! !HelpBuilder methodsFor: 'accessing' stamp: 'tbn 2/12/2010 14:53'! rootToBuildFrom: anObject rootToBuildFrom := anObject! ! !HelpBuilder methodsFor: 'building' stamp: 'tbn 3/3/2010 22:55'! build self subclassResponsibility ! ! !HelpBuilder methodsFor: 'accessing' stamp: 'tbn 3/5/2010 23:15'! topicToBuild ^topicToBuild! ! !HelpBuilder methodsFor: 'private accessing' stamp: 'tbn 3/5/2010 23:13'! topicClass ^HelpTopic! ! !HelpBuilder class methodsFor: 'building' stamp: 'tbn 3/5/2010 23:25'! buildHelpTopicFrom: aHelpTopicDescription "Start building from the given help topic description" ^(self new) rootToBuildFrom: aHelpTopicDescription; build; topicToBuild ! ! !HelpHowToHelpTopics commentStamp: 'TorstenBergmann 2/4/2014 21:17'! Explains help topics! !HelpHowToHelpTopics class methodsFor: 'accessing' stamp: 'tbn 3/29/2010 14:47'! bookName ^'Implementation'! ! !HelpHowToHelpTopics class methodsFor: 'accessing' stamp: 'tbn 3/29/2010 19:21'! pages ^#(overview page1 page2 page3 page4 page5)! ! !HelpHowToHelpTopics class methodsFor: 'pages' stamp: 'tbn 3/29/2010 15:01'! page4 ^HelpTopic title: '4. Own help objects' contents: 'You can open this help browser directly on an instance of HelpTopic, but it is more common to open it on any object that understands the message #asHelpTopic. So you can write for instance: HelpBrowser openOn: Integer opening a short API help/system reference on the Integer class. The above expression is the short form for: HelpBrowser openOn: (SystemReference forClass: Integer) If you want you can include the subclasses: HelpBrowser openOn: (SystemReference hierarchyFor: Integer) or even methods HelpBrowser openOn: (SystemReference hierarchyWithMethodsFor: Integer) You can browse the whole system reference documentation using: HelpBrowser openOn: SystemReference But these are only a few examples what we can extract from the system. However - the major goal is NOT an API browser, the idea is to provide a simple architecture to provide browsable help contents depending on the context. For instance it should also be possible to use the help system to provide end user help on any commercial application that is written with the Smalltalk system. ' ! ! !HelpHowToHelpTopics class methodsFor: 'pages' stamp: 'tbn 3/29/2010 19:23'! page5 ^HelpTopic title: '5. Help sources' contents: 'Since the underlying model is very simple you can easily fill it with nearly any information from different sources. Try this: |topic day url sub| topic := HelpTopic named: ''Last week on Squeak IRC''. 0 to: 7 do: [:index | day := (Date today subtractDays: index) printFormat: #(3 2 1 $. 1 2 2). url := ''http://tunes.org/~nef/logs/squeak/'' , day. sub := HelpTopic title: day contents: (HTTPLoader default retrieveContentsFor: url) contents. topic addSubtopic: sub. ]. HelpBrowser openOn: topic ' ! ! !HelpHowToHelpTopics class methodsFor: 'pages' stamp: 'tbn 3/29/2010 14:10'! page3 ^HelpTopic title: '3. Adding icons' contents: 'If you dont like the default icon you can add own custom icons to the topics. See the class HelpIcons for more details. |root sub1 sub2| root := HelpTopic title: ''My first topic'' contents: ''A simple topic of interest''. sub1 := HelpTopic title: ''My first subtopic'' contents: ''First subsection''. sub2 := HelpTopic title: ''My second subtopic'' icon: (HelpIcons iconNamed: #packageIcon) contents: ''Second subsection''. root addSubtopic: sub1; addSubtopic: sub2. HelpBrowser openOn: root '! ! !HelpHowToHelpTopics class methodsFor: 'pages' stamp: 'tbn 3/29/2010 14:03'! page2 ^HelpTopic title: '2. Forming a hierarchy' contents: 'To form a hierarchy we just have to add new subtopics on our root topic. |root sub1 sub2| root := HelpTopic title: ''My first topic'' contents: ''A simple topic of interest''. sub1 := HelpTopic title: ''My first subtopic'' contents: ''First subsection''. sub2 := HelpTopic title: ''My second subtopic'' contents: ''Second subsection''. root addSubtopic: sub1; addSubtopic: sub2. HelpBrowser openOn: root '! ! !HelpHowToHelpTopics class methodsFor: 'pages' stamp: 'tbn 3/29/2010 14:59'! overview ^HelpTopic title: 'Overview' contents: 'THE IMPLEMENTATION The help system typically consists of help books including one or more pages. A book or page is therefore a "topic of interest" providing contents for help to a user. A topic has a title and an icon and is able to have subtopics forming a hierarchy of topics. This simple model is reflected in the class HelpTopic. Since this model forms a hierarchical structure of help topics there is a browser with a tree to display the help contents. This browser is implemented in class HelpBrowser. You can open this browser programmatically using: HelpBrowser open ' ! ! !HelpHowToHelpTopics class methodsFor: 'pages' stamp: 'tbn 3/29/2010 14:03'! page1 ^HelpTopic title: '1. Simple help topics' contents: 'The help browser usually operates on a hierarchy of help topics with one help topic at the root level. Evaluate the following expression in a workspace to contruct a simple help topic and open it as a root topic in the help browser. |root| root := HelpTopic title: ''My first topic'' contents: ''A simple topic of interest''. HelpBrowser openOn: root Note that the help browser displays the contents of our topic in the right page and uses the topics title as the title for the help browser window. '! ! !HelpHowToHelpTopicsFromCode commentStamp: 'TorstenBergmann 2/4/2014 21:17'! How to create help topics from code! !HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: 'tbn 9/30/2010 23:54'! step7 ^HelpTopic title: 'Step 7 - Tips and Tricks' contents: 'STEP 7 - TIPS AND TRICKS Tip1: If you implement the #pages method you can also use the name of a custom help class that should be integrated between the specific pages: #pages ^(firstPage MyAppTutorial secondPage) Tip2: You can easily edit the help contents of a page by using the #edit: message. For our example just evaluate: MyAppHelp edit: #firstPage This will open a workspace with the help contents and when you accept it it will be saved back to the help method defining the topic. ' ! ! !HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: 'tbn 3/5/2010 21:36'! step1 ^HelpTopic title: 'Step 1 - Create a class for the book' contents: 'STEP 1 - CREATE A CLASS FOR THE BOOK There is a predefined class CustomHelp which you have to subclass for a custom help book to show up as a book in the Help browser: CustomHelp subclass: #MyAppHelp instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''MyApp-Help'' Class methods on this class can reflect pages and if you want to provide nested help books just subclass your own help class to form a hierarchy. Any new subclass of MyAppHelp will then be a new book in your hierarchy. The class category used should end with "-Help" so it is easy to recognize that it includes the help support of your project.' ! ! !HelpHowToHelpTopicsFromCode class methodsFor: 'accessing' stamp: 'tbn 3/29/2010 14:06'! bookName ^'Custom help from code'! ! !HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: 'tbn 9/30/2010 23:48'! step6 ^HelpTopic title: 'Step 6 - Add more structure' contents: 'STEP 6 - ADD MORE STRUCTURE If you add a new subclass to your custom help class and repeating step 2 to 4 you can profide new substructures (subbooks) since the help books are mapped to the class hierarchy. Example: MyAppHelp subclass: #MyAppTutorial instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''MyApp-Help'' then implement a #bookName, the pages and a #pages method as before on this new class and reopen the help browser. ' ! ! !HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: 'tbn 3/28/2010 22:56'! step5 ^HelpTopic title: 'Step 5 - Test your help' contents: 'STEP 5 - TEST YOUR HELP By using HelpBrowser open ' ! ! !HelpHowToHelpTopicsFromCode class methodsFor: 'accessing' stamp: 'tbn 9/30/2010 23:46'! pages ^#(overview step1 step2 step3 step4 step5 step6 step7)! ! !HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: 'tbn 3/5/2010 21:36'! step2 ^HelpTopic title: 'Step 2 - Provide a book name' contents: 'STEP 2 - PROVIDE A BOOK NAME Now implement the class method #bookName to return the name of your help book. bookName ^''My App help'' By implementing this method the system knows how you would like to name your book and uses the given string as a label in the HelpBrowser later.' ! ! !HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: 'tbn 3/29/2010 13:52'! overview ^HelpTopic title: 'Overview' contents: 'OVERVIEW The help system allows you to provide own books and help texts. You can open the help browser on any object that is able to understand #asHelpTopic. This method returns the root node of the displayed topic hierarchy: HelpBrowser openOn: myObject Typically the object does not convert itself to a help topic structure, usually it dispatches to a builder (see HelpBuilder and subclasses) who does all this. A much more convenient and reproducable way is to implement custom help classes. This allows you to implement and manage your help texts using the standard development and code management tools. These custom help classes are subclasses of "CustomHelp" and are automatically included into the standard help browser. '! ! !HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: 'tbn 3/5/2010 21:41'! step4 ^HelpTopic title: 'Step 4 - Defining the page order' contents: 'STEP 4 - DEFINING THE PAGE ORDER By implementing the class method #pages you return a collection of method selectors to define the order in which the pages appear in your book: pages ^#(firstPage secondPage) ' ! ! !HelpHowToHelpTopicsFromCode class methodsFor: 'pages' stamp: 'tbn 3/29/2010 13:41'! step3 ^HelpTopic title: 'Step 3 - Implement pages using methods' contents: 'STEP 3 - IMPLEMENT PAGES USING METHODS Implement a page by defining a method that returns an instance of HelpPage defining a page title and a help text displayed in the help browser. firstPage ^HelpTopic title: ''First Page'' contents: ''Hello world'' Define a new method for each page of your book. Please group the pages in a method category called "pages". You can also define an icon for the specific page: secondPage ^HelpTopic title: ''Second Page'' icon: (HelpIcons iconNamed: #packageIcon) contents: ''More to come'' Note: ===== Later we may add support for better help contents than just plain text (markup descriptions, active morphs, ...) ' ! ! !HelpIcons commentStamp: 'tbn 3/8/2010 09:29'! This class is used to store help icons for the help browser. Typically one implements a method returning a 12x12 Form instance which should not be called directly. Since the class provides an internal icon cache (so the icons can be reused without creating too many new instances) the icons should be accessed using the #iconNamed: message with the method selector as argument. To create a form from an icon file stored on disk you can use the following code: | image stream | image := ColorForm fromFileNamed: '/path/to/icon.png'. stream := WriteStream with: String new. image storeOn: stream. stream contents inspect.! !HelpIcons class methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:17'! icons ^ Icons ifNil: [Icons := Dictionary new]! ! !HelpIcons class methodsFor: 'private icons' stamp: 'tbn 3/3/2010 00:47'! refreshIcon ^(Form extent: 16@16 depth: 32 fromArray: #( 0 0 0 0 0 0 0 895969127 526080859 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1884706390 4168710521 2288675434 271330348 0 0 0 0 0 0 0 0 0 828465505 2609087363 3615917702 4269439610 4285887861 4285624689 3899156584 1766607948 67569415 0 0 0 0 0 50529027 2306242166 4237069452 4286940549 4286611584 4286282619 4285887861 4285558896 4285229931 4268189543 2235514687 0 0 0 0 0 2590862701 4287598479 4287269514 4270097540 3329652342 3312217196 4285887861 4285558896 3345179491 1011567435 0 0 0 0 0 1263423054 4287532686 4287532686 3867378563 1096835168 0 1885166941 3681579120 1549227863 50923785 0 0 0 0 0 0 3061545851 4287795858 4236937866 811951461 0 0 641547581 137441585 0 0 0 0 0 0 0 34936085 4102720138 4287795858 3011016824 0 0 0 0 0 0 0 0 0 0 0 0 272317243 4287861651 4287795858 2489607268 0 0 0 0 0 0 0 0 68095759 0 0 0 204682035 4287730065 4287795858 2658432116 0 0 0 0 0 0 0 34014983 3965146967 4283979864 3125694030 0 0 3767044232 4287795858 3884287365 137244206 0 0 0 0 0 0 1129863256 4284769380 4284506208 2739423304 0 0 2189459584 4287795858 4287532686 2541123190 16843009 0 0 0 0 305805882 3597166696 4284703587 4250885983 910114623 0 0 273698896 3834218889 4287532686 4287335307 3094442353 1094532413 101255433 286199567 1582124365 3731318631 4284966759 4284703587 2689946965 0 0 0 0 879126118 3985082247 4287269514 4286940549 4286611584 4285624689 4285558896 4285624689 4285229931 4284966759 3227212635 220998700 0 0 0 0 0 509698401 2977659771 4286743170 4286545791 4286282619 4285887861 4285558896 4100417383 2170116441 103295016 0 0 0 0 0 0 0 0 575820370 1734895720 2121298032 2037017194 1448564567 255013683 0 0 0 0 0) offset: 0@0)! ! !HelpIcons class methodsFor: 'private icons' stamp: 'tbn 2/12/2010 14:17'! bookIcon ^(Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 0 284817913 552924404 0 0 0 0 0 0 0 0 0 817149108 3747766882 4287730065 2679749049 549766340 0 0 0 0 0 0 1086110908 4016202338 4287137928 4288914339 4288914339 4289111718 3216290996 1086505666 0 0 0 816754350 4014952271 4287137928 4289309097 4289769648 4289111718 4288453788 4288453788 4288453788 2947658161 0 814846353 4283782485 4287072135 4288059030 4288059030 4288387995 4289243304 4289309097 4287927444 4287598479 2411050421 1081900156 4283585106 4286611584 4287532686 4287532686 4287466893 4287466893 4287401100 4287401100 4287401100 4288716960 2946868645 3211290728 4288651167 4287269514 4287006342 4287006342 4287006342 4286940549 4286940549 4287203721 4289177511 3483213213 281725642 2677183122 4293190884 4292861919 4289177511 4286874756 4286611584 4286611584 4287006342 4289638062 4020084125 549042617 0 282054607 2677643673 4289572269 4293256677 4292796126 4288980132 4287137928 4290164406 4020215711 816754350 0 0 0 0 551082200 2677643673 4289572269 4293256677 4292401368 4289177511 1085584564 0 0 0 0 0 0 0 551213786 2677643673 4288651167 1623244992 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0)! ! !HelpIcons class methodsFor: 'accessing' stamp: 'tbn 2/12/2010 15:54'! iconNamed: aSymbol ^self icons at: aSymbol ifAbsentPut: [self perform: aSymbol]! ! !HelpIcons class methodsFor: 'private icons' stamp: 'tbn 3/6/2010 01:23'! packageIcon ^(Form extent: 12@12 depth: 32 fromArray: #( 0 0 0 0 1075649821 3744937783 3208395836 807016986 0 0 0 0 0 0 537857807 2939368243 4283256141 4284045657 4284572001 4284111450 2671524924 269488144 0 0 0 2150575919 4014820685 4284111450 4284374622 4284769380 4285098345 4285295724 4286216826 4017057647 1883456323 0 1076505130 4283848278 4284769380 4284966759 4285624689 4285690482 4285887861 4286611584 4287269514 4287861651 4287269514 1074597133 1076965681 4283914071 4283848278 4285953654 4286216826 4286414205 4286940549 4287466893 4287335307 4286808963 4286743170 1074399754 1077163060 4284637794 4284045657 4284835173 4285887861 4287269514 4287335307 4286282619 4286216826 4286874756 4287006342 1074465547 1077294646 4284835173 4284703587 4285361517 4285624689 4286414205 4285624689 4286085240 4286677377 4287269514 4287401100 1074465547 1077426232 4285098345 4285032552 4286019447 4285822068 4286743170 4286348412 4286677377 4287203721 4287730065 4287795858 1074531340 1077492025 4285229931 4285427310 4286808963 4286216826 4287137928 4287072135 4287401100 4287795858 4288256409 4288190616 1074531340 269356558 2672051268 4285493103 4287598479 4286940549 4287532686 4287795858 4287993237 4288387995 4287006342 2404668500 268501249 0 0 1075912993 3479726184 4287598479 4287927444 4288453788 4287993237 2943118444 539371046 0 0 0 0 0 0 1615086660 4017781370 3749148535 1078347334 0 0 0 0) offset: 0@0)! ! !HelpIcons class methodsFor: 'private icons' stamp: 'tbn 2/12/2010 14:18'! pageIcon ^(Form extent: 12@12 depth: 32 fromArray: #( 0 221196079 1366981242 1366915449 1366915449 1366849656 1366783863 1128876361 33554432 0 0 0 0 726552142 4294309365 4294243572 4294111986 4294046193 4293914607 4292861919 2843705215 319885585 0 0 0 726551886 4294177779 4294111986 4293980400 4293914607 4293848814 4293717228 4292138196 3734147730 269619730 0 0 726486349 4294046193 4293980400 4293914607 4293783021 4293717228 4293585642 4293454056 4291085508 639705377 0 0 726420557 4293980400 4293848814 4293783021 4293651435 4293585642 4293519849 4293388263 4292993505 640034342 0 0 726420556 4293848814 4293717228 4293651435 4293585642 4293454056 4293388263 4293256677 4293190884 623322919 0 0 726354764 4293717228 4293651435 4293519849 4293454056 4293322470 4293256677 4293125091 4293059298 623257126 0 0 726354507 4293585642 4293519849 4293388263 4293322470 4293190884 4293125091 4293059298 4292993505 623191333 0 0 726288970 4293454056 4293388263 4293256677 4293190884 4293125091 4292993505 4292993505 4292993505 623191333 0 0 726223178 4293322470 4293256677 4293190884 4293059298 4292993505 4292993505 4292993505 4292993505 623191333 0 0 726223177 4293256677 4293125091 4293059298 4292993505 4292993505 4292993505 4292993505 4292993505 623191333 0 0 490092087 3080033685 3079967892 3079967892 3079967892 3079967892 3079967892 3079967892 3079967892 454629657 0) offset: 0@0)! ! !HelpIcons class methodsFor: 'private icons' stamp: 'tbn 3/3/2010 23:53'! blankIcon ^Form extent: 12 @ 1 depth:8! ! !HelpIconsTest commentStamp: 'TorstenBergmann 2/4/2014 21:19'! SUnit tests for the icons used in the help system! !HelpIconsTest methodsFor: 'testing' stamp: 'tbn 3/3/2010 00:50'! 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. ] ! ! !HelpIconsTest methodsFor: 'accessing' stamp: 'tbn 2/12/2010 14:23'! defaultTestClass ^HelpIcons! ! !HelpOnHelp commentStamp: 'tbn 2/12/2010 14:27'! Welcome to Pharo Smalltalk Help System! !HelpOnHelp class methodsFor: 'accessing' stamp: 'tbn 2/19/2010 14:21'! bookName ^'Help on Help'! ! !HelpOnHelp class methodsFor: 'accessing' stamp: 'tbn 10/1/2010 00:27'! pages ^#(introduction HelpHowToHelpTopics HelpAPIDocumentation)! ! !HelpOnHelp class methodsFor: 'pages' stamp: 'hjh 4/21/2010 16:59'! introduction "This method was automatically generated. Edit it using:" "HelpOnHelp edit: #introduction" ^HelpTopic title: 'Introduction' contents: 'WELCOME TO THE HELP SYSTEM The help system is a simple user interface to display help contents to the user. It can be accessed from the world menu using "Tools" -> "Help Browser" or by evaluating ''HelpBrowser open'' in a workspace. There is a predefined mechanism allowing you to have help contents stored as source code using methods in specific help provider classes. This allows to manage the help texts using the standard development tools. But this is only one possible representation. Yes, this is a good solution. !!' readStream nextChunkText! ! !HelpOnHelp class methodsFor: 'accessing' stamp: 'tbn 3/5/2010 23:56'! key ^'HelpOnHelp'! ! !HelpTopic commentStamp: 'tbn 3/29/2010 14:53'! A HelpTopic provides content information that can be used as a help to the user. It can be labeled with a title, identified using an (optional) unique key and marked with an (optional) icon. Help topics form a hierarchy since any topic is able to have zero or more subtopics. Instance Variables contents: The help topic contents icon: An optional icon for the topic key: An optional unique key subtopics: A collection of subtopics title: The title contents - The help topic contents - typically containing the help topics information icon - An optional icon for the topic key - An optional unique key which can be used to identify the topic. subtopics - A collection of subtopics. By default the subtopics are not sorted, so the insertion order is used. If necessary it is possible to sort the subtopics by title. title - A meaninful title for the help topic ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:20'! key: aUniqueKey "Sets a unique key identifying the receiver in the help system" key := aUniqueKey ! ! !HelpTopic methodsFor: 'accessing' stamp: 'kilonalios 9/22/2013 17:31'! addSubtopic: aTopic "Adds the given topic to the receivers collection of subtopics, and set this object as owner of the subtopic" self subtopics add: aTopic. aTopic owner: self. ^aTopic! ! !HelpTopic methodsFor: 'operating' stamp: 'tbn 3/8/2010 09:12'! sortSubtopicsByTitle "Sort the subtopics by title" subtopics := SortedCollection withAll: self subtopics ! ! !HelpTopic methodsFor: 'testing' stamp: 'tbn 3/6/2010 00:23'! hasSubtopics "Returns true if the receiver has subtopics, false otherwise" ^self subtopics notEmpty ! ! !HelpTopic methodsFor: 'conversion' stamp: 'tbn 3/8/2010 09:09'! asHelpTopic "Converts the receiver to a help topic" ^self! ! !HelpTopic methodsFor: 'defaults' stamp: 'tbn 3/5/2010 21:31'! defaultTitle "Returns the receivers default title" ^'Unnamed Topic' ! ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:20'! icon: aSymbol "Sets the receivers icon" icon := aSymbol ! ! !HelpTopic methodsFor: 'initialization' stamp: 'tbn 3/8/2010 08:44'! initialize "Initializes the receiver" super initialize. self title: self defaultTitle. self contents: ''. self key: '' ! ! !HelpTopic methodsFor: 'accessing' stamp: 'kilonalios 9/22/2013 17:30'! owner "an ownder is a HelpTopic that uses the current HelptTopic as subtopic" ^ owner! ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:22'! title "Returns the receivers title" ^ title! ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:22'! title: anObject "Sets the receivers title" title := anObject! ! !HelpTopic methodsFor: 'accessing' stamp: 'kilonalios 9/22/2013 17:43'! subtopics: aCollection "Sets the receivers subtopics" aCollection do: [ :topic| topic owner: self ]. subtopics := aCollection.! ! !HelpTopic methodsFor: 'accessing' stamp: 'kilonalios 9/22/2013 17:56'! owner: topic "an owner is a HelpTopic that uses the current HelptTopic as subtopic" owner := topic! ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:19'! contents: anObject "Sets the receivers contents to the given object" contents := anObject! ! !HelpTopic methodsFor: 'accessing' stamp: 'ClementBera 7/29/2013 15:06'! subtopics "Returns the receivers list of subtopics" ^ subtopics ifNil: [subtopics := OrderedCollection new]! ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:20'! key "Returns a unique key identifying the receiver in the help system" ^key! ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:19'! contents "Returns the receivers contents" ^ contents! ! !HelpTopic methodsFor: 'comparing' stamp: 'tbn 3/8/2010 09:11'! <= anotherHelpTopic "Use sorting by title as the default sort order" ^self title <= anotherHelpTopic title ! ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:19'! icon "Returns the receivers icon" ^icon! ! !HelpTopic class methodsFor: 'instance creation' stamp: 'tbn 3/29/2010 13:16'! named: aString "Create a new instance with given title and empty contents" ^(self new) title: aString; yourself! ! !HelpTopic class methodsFor: 'instance creation' stamp: 'tbn 3/29/2010 13:16'! title: aTitle icon: anIcon contents: aText "Create a new instance with given title, icon and content" ^(self new) title: aTitle; icon: anIcon; contents: aText; yourself. ! ! !HelpTopic class methodsFor: 'instance creation' stamp: 'tbn 3/29/2010 13:16'! title: aTitle contents: aText "Create a new instance with given title and content" ^(self new) title: aTitle; contents: aText; yourself. ! ! !HelpTopicListItemWrapper commentStamp: 'tbn 3/8/2010 09:30'! This class implements a list item wrapper for help topics. Instance Variables ! !HelpTopicListItemWrapper methodsFor: 'accessing' stamp: 'tbn 3/5/2010 22:55'! icon "Either return the icon for the given topic" | symbol | item icon notNil ifTrue: [^item icon]. symbol := item hasSubtopics ifTrue: [#bookIcon] ifFalse: [#pageIcon]. ^HelpIcons iconNamed: symbol! ! !HelpTopicListItemWrapper methodsFor: 'accessing' stamp: 'tbn 3/8/2010 17:26'! balloonText "Returns a string used for fly by help" ^self item title! ! !HelpTopicListItemWrapper methodsFor: 'accessing' stamp: 'tbn 3/8/2010 17:26'! contents "Returns subnodes (if any)" item hasSubtopics ifFalse: [^#()]. ^(item subtopics) collect: [ :each | HelpTopicListItemWrapper with: each ]. ! ! !HelpTopicListItemWrapper methodsFor: 'accessing' stamp: 'tbn 3/8/2010 17:25'! asString "Returns a string used as a label" ^item title! ! !HelpTopicListItemWrapperTest commentStamp: 'TorstenBergmann 2/4/2014 21:19'! SUnit tests for class HelpTopicListItemWrapper! !HelpTopicListItemWrapperTest methodsFor: 'accessing' stamp: 'tbn 2/12/2010 13:16'! defaultTestClass ^HelpTopicListItemWrapper ! ! !HelpTopicListItemWrapperTest methodsFor: 'testing' stamp: 'tbn 3/5/2010 21:46'! testDisplayLabel |instance| instance := self defaultTestClass with: (HelpTopic named: 'My Topic'). self assert: instance asString = 'My Topic' ! ! !HelpTopicTest commentStamp: 'TorstenBergmann 2/4/2014 21:19'! SUnit tests for HelpTopic class! !HelpTopicTest methodsFor: 'testing' stamp: 'tbn 3/6/2010 00:07'! testInitialization self assert: topic title = 'Unnamed Topic'. self assert: topic key isEmpty. self assert: topic contents isEmpty ! ! !HelpTopicTest methodsFor: 'testing' stamp: 'tbn 3/6/2010 00:06'! testInstanceCreation |instance| instance := self defaultTestClass named: 'My Topic'. self assert: instance title = 'My Topic'. ! ! !HelpTopicTest methodsFor: 'accessing' stamp: 'tbn 3/5/2010 21:47'! defaultTestClass ^HelpTopic ! ! !HelpTopicTest methodsFor: 'testing' stamp: 'kilonalios 9/22/2013 17:56'! testSubtopicOwnership "Test that when a subtopic is added to a topic then owner of the subtopic is the topic" |subtopic owner| owner := self defaultTestClass named: 'I am the owner'. subtopic := self defaultTestClass named: 'I am the subtopic'. owner addSubtopic: subtopic. self assert: (subtopic owner == owner). ! ! !HelpTopicTest methodsFor: 'testing' stamp: 'tbn 3/6/2010 00:06'! 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. ! ! !HelpTopicTest methodsFor: 'testing' stamp: 'tbn 3/8/2010 16:44'! testAddingSubtopic |subtopic returned| subtopic := self defaultTestClass named: 'Subtopic'. returned := topic addSubtopic: subtopic. self assert: returned == subtopic. self assert: (topic subtopics includes: subtopic) ! ! !HelpTopicTest methodsFor: 'running' stamp: 'tbn 3/5/2010 21:49'! setUp super setUp. topic := self defaultTestClass new.! ! !HierarchicalUrl commentStamp: ''! A URL which has a hierarchical encoding. For instance, http and ftp URLs are hierarchical.! !HierarchicalUrl methodsFor: 'access' stamp: 'gk 10/21/2005 11:15'! path: aCollection "Set the collection of path elements." path := aCollection! ! !HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:58'! schemeName ^schemeName! ! !HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/15/2003 13:13'! password "http://user:pword@foo.com' asUrl password" ^password! ! !HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:58'! authority ^authority! ! !HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/15/2003 13:13'! username "http://user:pword@foo.com' asUrl username" ^username! ! !HierarchicalUrl methodsFor: 'access' stamp: 'KLC 4/3/2006 10:05'! path "return a collection of the decoded path elements, as strings" ^path! ! !HierarchicalUrl methodsFor: 'access' stamp: 'tk 9/6/1998 12:45'! isAbsolute path size > 0 ifFalse: [^ false]. (path at: 1) size > 0 ifFalse: [^ false]. ^ ((path at: 1) at: 1) ~~ $.! ! !HierarchicalUrl methodsFor: 'parsing' stamp: 'SvenVanCaekenberghe 10/27/2013 12:20'! privateInitializeFromText: aString | remainder ind specifiedSchemeName | remainder := aString. schemeName ifNil: [specifiedSchemeName := self class schemeNameForString: remainder. specifiedSchemeName ifNotNil: [schemeName := specifiedSchemeName. remainder := remainder copyFrom: schemeName size + 2 to: remainder size]. schemeName ifNil: ["assume HTTP" schemeName := 'http']]. "remove leading // if it's there" (remainder beginsWith: '//') ifTrue: [remainder := remainder copyFrom: 3 to: remainder size]. "get the query" ind := remainder indexOf: $?. ind > 0 ifTrue: [query := remainder copyFrom: ind + 1 to: remainder size. remainder := remainder copyFrom: 1 to: ind - 1]. "get the authority" ind := remainder indexOf: $/. ind > 0 ifTrue: [ind = 1 ifTrue: [authority := ''] ifFalse: [authority := remainder copyFrom: 1 to: ind - 1. remainder := remainder copyFrom: ind + 1 to: remainder size]] ifFalse: [authority := remainder. remainder := '']. "extract the username+password" (authority includes: $@) ifTrue: [username := authority copyUpTo: $@. authority := authority copyFrom: (authority indexOf: $@) + 1 to: authority size. (username includes: $:) ifTrue: [password := (username copyFrom: (username indexOf: $:) + 1 to: username size) urlDecoded. username := (username copyUpTo: $:) urlDecoded]]. "Extract the port" (authority includes: $:) ifTrue: [| lastColonIndex portString | lastColonIndex := authority findLast: [:c | c = $:]. portString := authority copyFrom: lastColonIndex + 1 to: authority size. portString isAllDigits ifTrue: [port := Integer readFromString: portString. (port > 65535) ifTrue: [self error: 'Invalid port number']. authority := authority copyFrom: 1 to: lastColonIndex - 1] ifFalse:[self error: 'Invalid port number']]. "get the path" path := self privateParsePath: remainder relativeTo: #() .! ! !HierarchicalUrl methodsFor: 'parsing' stamp: 'MarcusDenker 10/9/2013 16:32'! privateInitializeFromText: aString relativeTo: aUrl | remainder ind basePath | remainder := aString. "set the scheme" schemeName := aUrl schemeName. "a leading // means the authority is specified, meaning it is absolute" (remainder beginsWith: '//') ifTrue: [ ^ self privateInitializeFromText: aString ]. "otherwise, use the same authority" authority := aUrl authority. port := aUrl port. username := aUrl username. password := aUrl password. "get the query" ind := remainder indexOf: $?. ind > 0 ifTrue: [ query := remainder copyFrom: ind + 1 to: remainder size. remainder := remainder copyFrom: 1 to: ind - 1 ]. "get the path" basePath := (remainder beginsWith: '/') ifTrue: [ #() ] ifFalse: [ aUrl path ]. path := self privateParsePath: remainder relativeTo: basePath! ! !HierarchicalUrl methodsFor: 'private' stamp: 'ls 6/20/1998 19:41'! schemeName: schemeName0 authority: authority0 path: path0 query: query0 "initialize a new instance" schemeName := schemeName0. authority := authority0. path := path0. query := query0. ! ! !HierarchicalUrl methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 10/27/2013 11:44'! fullPath | ans | ans := String new writeStream. path do: [ :pathElem | ans nextPut: $/. ans nextPutAll: pathElem urlEncoded ]. self query ifNotNil: [ ans nextPut: $?. ans nextPutAll: self query. ]. self fragment ifNotNil: [ ans nextPut: $#. ans nextPutAll: self fragment urlEncoded ]. ^ ans contents! ! !HierarchicalUrl methodsFor: 'parsing' stamp: 'SvenVanCaekenberghe 10/27/2013 12:19'! privateParsePath: remainder relativeTo: basePath | nextTok s parsedPath | s := remainder readStream. parsedPath := OrderedCollection new. parsedPath addAll: basePath. parsedPath isEmpty ifFalse: [ parsedPath removeLast ]. [ s peek = $/ ifTrue: [ s next ]. nextTok := String new writeStream. [ s atEnd or: [ s peek = $/ ] ] whileFalse: [ nextTok nextPut: s next ]. nextTok := nextTok contents urlDecoded. nextTok = '..' ifTrue: [ parsedPath size > 0 ifTrue: [ parsedPath removeLast ] ] ifFalse: [ nextTok ~= '.' ifTrue: [ parsedPath add: nextTok ] ]. s atEnd ] whileFalse. parsedPath isEmpty ifTrue: [ parsedPath add: '' ]. ^ parsedPath! ! !HierarchicalUrl methodsFor: 'access' stamp: 'mir 7/30/1999 13:05'! port ^port! ! !HierarchicalUrl methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 10/27/2013 11:45'! printOn: aStream aStream nextPutAll: self schemeName. aStream nextPutAll: '://'. self username ifNotNil: [ aStream nextPutAll: self username urlEncoded. self password ifNotNil: [ aStream nextPutAll: ':'. aStream nextPutAll: self password urlEncoded]. aStream nextPutAll: '@' ]. aStream nextPutAll: self authority. port ifNotNil: [aStream nextPut: $:; print: port]. path do: [ :pathElem | aStream nextPut: $/. aStream nextPutAll: pathElem urlEncoded ]. self query ifNotNil: [ aStream nextPut: $?. aStream nextPutAll: self query. ]. self fragment ifNotNil: [ aStream nextPut: $#. aStream nextPutAll: self fragment urlEncoded ].! ! !HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:59'! query "return the query, the part after any ?. Any %XY's have already been decoded. If there wasno query part, nil is returned (it is possible to also have an empty query" ^query ! ! !HierarchicalUrl methodsFor: 'access' stamp: 'gk 10/21/2005 11:06'! fileName "Return the last part of the path, most often a filename but does not need to be." ^self path last! ! !HierarchicalUrl methodsFor: 'copying' stamp: 'nice 1/13/2010 21:58'! postCopy "Be sure not to share the path with the copy" super postCopy. path := path copy! ! !HierarchicalUrl methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:07'! scheme ^ self schemeName.! ! !HierarchicalUrl methodsFor: '*zinc-http' stamp: 'SvenVanCaekenberghe 12/8/2012 21:02'! asZnUrl ^ ZnUrl new scheme: self scheme; host: self authority; port: self port; segments: (self path collect: [ :each | each isEmpty ifTrue: [ #/ ] ifFalse: [ each ] ]); query: (self query isNil ifTrue: [ nil ] ifFalse: [ ZnResourceMetaUtils parseQueryFrom: self query readStream ]); fragment: self fragment; yourself! ! !HierarchicalUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:44'! hasContents "most of these do...." ^true! ! !HierarchicalUrl class methodsFor: 'instance creation' stamp: 'ls 6/20/1998 19:41'! schemeName: schemeName authority: authority path: path query: query ^self new schemeName: schemeName authority: authority path: path query: query! ! !HierarchicalUrlTest commentStamp: 'TorstenBergmann 2/5/2014 10:13'! SUnit tests for hierarchical Urls! !HierarchicalUrlTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 10/25/2013 16:00'! testAsString self assert: 'ftp://localhost/path/to/file?aQuery' asUrl asString = 'ftp://localhost/path/to/file?aQuery'.! ! !HierarchicalUrlTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 10/25/2013 18:50'! testNew [ super testNew ] on: Deprecation do: [ :notification | notification resume ]! ! !HistoryCollection commentStamp: 'BenjaminVanRyseghem 3/17/2011 13:41'! I'm a data structure used to store an history. My behavior is - I store Associations (anElement -> anInteger), where anElement is the element to store and anInteger the number of times it has been added. (as a Dictionary) - I only store once each element (as a Set). - I have a max size. If I add an element and have reached the max size, I remove the less seen element. - I store element in the chronological order (as an OrderedCollection)! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 13:49'! size ^ storage size! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 14:03'! oldest ^ storage last key! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 14:00'! lessSeen | min | min := storage first. 2 to: storage size do: [:index || each | each := storage at: index. (each value < min value) ifTrue: [ min := each]]. ^ min key! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 13:37'! includes: anElement ^ storage anySatisfy: [:association | association key = anElement ]! ! !HistoryCollection methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/17/2011 13:32'! maxSize: anInteger maxSize := anInteger! ! !HistoryCollection methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/17/2011 13:47'! initialize super initialize. maxSize := 5. storage := OrderedCollection new: maxSize.! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 13:38'! identityIncludes: anElement ^ storage anySatisfy: [:association | association key == anElement ]! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 15:33'! elements ^ storage collect: [:each | each key ]! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 13:43'! at: anElement ^ storage detect: [:each | each key = anElement]! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 13:37'! add: anElement | count | count := 0. (self includes: anElement) ifTrue: [ | association | association := self remove: anElement. count := association value ]. self size = self maxSize ifTrue: [ self removeLast ]. ^ storage addFirst: (anElement -> (count+1))! ! !HistoryCollection methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/17/2011 13:31'! maxSize ^ maxSize! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 14:05'! mostSeen | max | max := storage first. 2 to: storage size do: [:index || each | each := storage at: index. (each value > max value) ifTrue: [ max := each]]. ^ max key! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 13:49'! remove: anElement | association | association := self at: anElement. ^ storage remove: association. ! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 13:54'! removeLast " I remove the less seen one, in case of equality, I remove the latest one " | min reversedStorage | reversedStorage := storage reverse. min := reversedStorage first. 2 to: storage size do: [:index || each | each := reversedStorage at: index. (each value < min value) ifTrue: [ min := each ]]. storage remove: min! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 14:03'! youngest ^ storage first key! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/14/2012 15:48'! mostViewedElements ^ (storage copy sort: [:a :b | a value >= b value]) collect: [:each | each key ]! ! !HistoryCollection class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 3/17/2011 13:47'! maxSize: anInteger ^ self new maxSize: anInteger! ! !HistoryIterator commentStamp: 'AlainPlantec 12/14/2010 23:40'! A HistoryIterator holds an UndoRedoGroup in order to store an history of commands with the possibility of undoing and redoing. The iterator cursor is represented by the index inst var. Index always contains the position of the command that can be currently undone. So, undo decrease index and redo increase index. When a new record is stored, then, index contains the newly added record position. See HistoryIteratorTest for examples. Instance Variables index: maxSize: plugged: recorder: index - the iterator cursor maxSize - the maximum number of records that can be added in the root group. plugged - if false, then adding of command is not allowed. Useful to prevent bad history recording recurssions (record while undoing or redoing). recorder - The root of the history tree which records undo/redo commands ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 19:06'! last ^ self recorder last! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 19:08'! first ^ self recorder first! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 12:54'! next "next item in history" ^ self hasNext ifTrue: [ index := self index + 1. self current]! ! !HistoryIterator methodsFor: 'adding' stamp: 'AlainPlantec 12/14/2010 18:52'! addItem: anHistoryItem | result | self isPlugged ifFalse: [^ false]. self recorder removeLast: (self size - self index). result := self recorder addItem: anHistoryItem. self updateIndex. ^ result! ! !HistoryIterator methodsFor: 'compatibility' stamp: 'AlainPlantec 12/14/2010 12:54'! closeRecordGroup ^ self closeGroup! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 13:01'! nextList "return 'next' items sublist " ^ self recorder copyFrom: self index + 1 to: self size! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 18:54'! maxSize: anInteger maxSize := anInteger! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 22:27'! doAndAddRecord: anUndoRedoRecord | result | result := anUndoRedoRecord do. self addItem: anUndoRedoRecord. ^ result! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 14:37'! recorder ^ recorder ifNil: [recorder := UndoRedoGroup new]! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 13:03'! redo self unplugWhile: [ self hasNext ifFalse: [^false]. self next redo]. ^ true! ! !HistoryIterator methodsFor: 'removing' stamp: 'AlainPlantec 12/14/2010 19:58'! removeAt: anIndex self recorder removeAt: anIndex! ! !HistoryIterator methodsFor: 'adding' stamp: 'AlainPlantec 12/14/2010 12:54'! addRecord: anItem ^ self addItem: anItem ! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 19:03'! at: anInteger ^ self recorder at: anInteger! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 18:46'! maxSize ^ maxSize ifNil: [maxSize := self defaultMaximumSize]! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 12:54'! unplugWhile: aBlock | wasPlugged | wasPlugged := self isPlugged. plugged := false. aBlock ensure: [ plugged := wasPlugged ]! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 12:54'! index ^ index ifNil: [index := self size]! ! !HistoryIterator methodsFor: 'grouping' stamp: 'AlainPlantec 12/14/2010 18:52'! openGroup self recorder openGroup. self updateIndex. ! ! !HistoryIterator methodsFor: 'grouping' stamp: 'MarcusDenker 5/31/2011 15:33'! groupFrom: firstIdx to: secondIdx | group | group := UndoRedoGroup new. firstIdx to: (secondIdx min: index) do: [:i | group addItem: (self at:i)]. group close. group isEmpty ifTrue: [^ self]. firstIdx + 1 to: (secondIdx min: index) do: [:i | self removeAt: i]. self at: firstIdx put: group. index := index - group size + 1.! ! !HistoryIterator methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 12:54'! isPlugged ^ plugged ifNil: [plugged := true]! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 13:00'! size ^ self recorder size! ! !HistoryIterator methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 12:58'! hasNext "is there an item after current index" ^ self recorder size - self index > 0! ! !HistoryIterator methodsFor: 'removing' stamp: 'AlainPlantec 12/14/2010 18:51'! removeFirst self recorder removeFirst! ! !HistoryIterator methodsFor: 'compatibility' stamp: 'AlainPlantec 12/14/2010 12:54'! openRecordGroup ^ self openGroup! ! !HistoryIterator methodsFor: 'adding' stamp: 'AlainPlantec 12/14/2010 18:51'! updateIndex self size <= self maxSize ifFalse: [self removeFirst]. index := self size. ! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 13:02'! reset self recorder reset. index := nil.! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 13:03'! undo self unplugWhile: [ self current ifNotNil: [:curr | curr undo]. self previous]. ^ true! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 22:28'! redoArray: doArray undoArray: undoArray self addItem: (UndoRedoRecord redoArray: doArray undoArray: undoArray)! ! !HistoryIterator methodsFor: 'grouping' stamp: 'AlainPlantec 12/14/2010 14:33'! closeGroup self recorder closeGroup ! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 19:59'! at: anInteger put: anItem self recorder at: anInteger put: anItem! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 18:31'! do ^ self redo! ! !HistoryIterator methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 12:54'! hasPrevious "is there an item before current index" ^ self index > 0! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 12:54'! previous "previous item in history" ^ self hasPrevious ifTrue: [index := self index - 1. self current]! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 22:27'! redo: doMessageSend undo: undoMessageSend self addItem: (UndoRedoRecord redo: doMessageSend undo: undoMessageSend)! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 13:01'! previousList "return 'prev' items sublist" ^ self recorder copyFrom: 1 to: self index - 1! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 13:00'! current ^ (self index <= self size and: [self index > 0]) ifTrue: [self recorder at: self index]! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 18:49'! defaultMaximumSize "unlimited by default" ^ 999999999! ! !HistoryIteratorTest methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 23:42'! testUndo2 | aCollection | aCollection := OrderedCollection newFrom: {1. 2. 3}. historyList doAndAddRecord: ( UndoRedoRecord do: (MessageSend receiver: aCollection selector: #removeLast ) undo: (MessageSend receiver: aCollection selector: #addLast: argument: aCollection last)). historyList undo. self assert: aCollection size = 3. self assert: aCollection last = 3.! ! !HistoryIteratorTest methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 23:01'! testUndo1 | aCollection | aCollection := OrderedCollection new. historyList doAndAddRecord: ( UndoRedoRecord do: (MessageSend receiver: aCollection selector: #addLast: argument: 1) undo: (MessageSend receiver: aCollection selector: #removeLast)). historyList undo. self assert: aCollection size = 0.! ! !HistoryIteratorTest methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 23:43'! testGroupedUndo2 "test of grouping history entries by #openGroup and #closeGroup" | aCollection | aCollection := OrderedCollection newFrom: {1. 2. 3}. historyList openGroup. historyList doAndAddRecord: ( UndoRedoRecord do: (MessageSend receiver: aCollection selector: #removeLast ) undo: (MessageSend receiver: aCollection selector: #addLast: argument: aCollection last)). historyList doAndAddRecord: ( UndoRedoRecord do: (MessageSend receiver: aCollection selector: #removeLast ) undo: (MessageSend receiver: aCollection selector: #addLast: argument: aCollection last)). historyList closeGroup. "the historyList should have grouped the two commands and placed this group in the undoHistory" self assert: ((historyList size = 1) and: [historyList last isKindOf: UndoRedoGroup]). historyList undo. "both UndoRecords in the group should have been made undone" self assert: ((aCollection last = 3) and: [aCollection second = 2]).! ! !HistoryIteratorTest methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 23:01'! testGrouping | aCollection | aCollection := OrderedCollection new. historyList openGroup. self assert: historyList size = 1. self assert: (historyList at: 1) isComposite. self assert: (historyList at: 1) opened. historyList doAndAddRecord: ( UndoRedoRecord do: (MessageSend receiver: aCollection selector: #addLast: argument: 1) undo: (MessageSend receiver: aCollection selector: #removeLast)). historyList doAndAddRecord: ( UndoRedoRecord do: (MessageSend receiver: aCollection selector: #addLast: argument: 2) undo: (MessageSend receiver: aCollection selector: #removeLast)). self assert: historyList size = 1. self assert: (historyList at: 1) size = 2. historyList closeGroup. self assert: (historyList at: 1) closed. self assert: aCollection size = 2. self assert: aCollection first = 1. self assert: aCollection last = 2. historyList undo. self assert: aCollection isEmpty ! ! !HistoryIteratorTest methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 23:43'! testGroupedUndo1 "test of grouping history entries afterwards by #groupFrom:to:" | aCollection | aCollection := OrderedCollection newFrom: {1. 2. 3}. historyList doAndAddRecord: ( UndoRedoRecord do: (MessageSend receiver: aCollection selector: #removeLast ) undo: (MessageSend receiver: aCollection selector: #addLast: argument: aCollection last)). historyList doAndAddRecord: ( UndoRedoRecord do: (MessageSend receiver: aCollection selector: #removeLast ) undo: (MessageSend receiver: aCollection selector: #addLast: argument: aCollection last)). historyList groupFrom: 1 to: 2. historyList undo. self assert: ((aCollection last = 3) and: [aCollection second = 2]).! ! !HistoryIteratorTest methodsFor: 'running' stamp: 'AlainPlantec 12/14/2010 23:38'! setUp historyList := HistoryIterator new.! ! !HistoryIteratorTest methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 23:01'! testMaxSize | aCollection | aCollection := OrderedCollection newFrom: {1. 2. 3}. historyList maxSize: 5. 10 timesRepeat: [ historyList doAndAddRecord: ( UndoRedoRecord do: (MessageSend receiver: aCollection selector: #size) undo: (MessageSend receiver: aCollection selector: #size)). ]. self assert: historyList size = 5.! ! !HistoryLeaf commentStamp: 'AlainPlantec 12/14/2010 23:06'! This class represents the abstract leaf structure of items stored in History tree. Composite nodes of such trees are made of HistoryNode instances. For a particular use, this class need to be subclassed. See for example UndoRedoRecord! !HistoryLeaf methodsFor: 'testing' stamp: 'AlainPlantec 12/13/2010 13:04'! isComposite ^ false! ! !HistoryLeaf methodsFor: 'adding' stamp: 'AlainPlantec 12/13/2010 13:07'! addItem: anHistoryItem ^ false! ! !HistoryLeaf methodsFor: 'testing' stamp: 'AlainPlantec 12/13/2010 11:54'! opened ^ false! ! !HistoryNode commentStamp: 'AlainPlantec 12/15/2010 00:04'! A HistoryNode is composite node of an history tree. It is made to contain some other HistoryNode or HistoryLeaf instances. A subnode is added with #addItem: In order to add and feed a new subtree, one can use openGroup which add a new HistoryNode. When openGroup is sent to an HistoryNode named H, then a new group G is added and all subsequent sent of #addItem: or of #openGroup to H will update the new node G until G is closed by a closeGroup. As examples: --------------- H := HistoryNode new. H addItem: (i1 := HistoryLeaf new). --------------- gives: H i1 --------------- H := HistoryNode new. H openGroup. "add a new group named g1" H addItem: (i1 := HistoryLeaf new). H addItem: (i2 := HistoryLeaf new). -------------- gives: H g1 i1 i2 -------------- H := HistoryNode new. H openGroup. "add a new group named g1" H openGroup. "add a new group named g2" H addItem: (i1 := HistoryLeaf new). H addItem: (i2 := HistoryLeaf new). -------------- gives: H g1 g2 i1 i2 -------------- H := HistoryNode new. H openGroup. "add a new group named g1" H openGroup. "add a new group named g2" H addItem: (i1 := HistoryLeaf new). H closeGroup. "close g2" H addItem: (i2 := HistoryLeaf new). H closeGroup. "close g1" H addItem: (i3 := HistoryLeaf new). -------------- gives: H g1 g2 i1 i2 i3 Also se HistoryNodeTest. Instance Variables history: opened: history - The list of subnodes (HistoryLeaf or HistoryNode instances) opened - true if the node is opened for adding ! !HistoryNode methodsFor: 'copying' stamp: 'AlainPlantec 12/14/2010 13:06'! copyFrom: start to: stop ^ self history copyFrom: start to: stop! ! !HistoryNode methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 19:08'! last ^ self history last! ! !HistoryNode methodsFor: 'accessing' stamp: 'AlainPlantec 12/12/2010 19:03'! size ^ self history size! ! !HistoryNode methodsFor: 'opening-closing' stamp: 'AlainPlantec 12/13/2010 11:53'! close opened := false! ! !HistoryNode methodsFor: 'testing' stamp: 'AlainPlantec 12/13/2010 15:59'! isEmpty ^ self history isEmpty! ! !HistoryNode methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 19:08'! first ^ self history first! ! !HistoryNode methodsFor: 'private ' stamp: 'AlainPlantec 12/12/2010 19:06'! removeFirst self history removeFirst! ! !HistoryNode methodsFor: 'testing' stamp: 'AlainPlantec 12/13/2010 13:04'! isComposite ^ true! ! !HistoryNode methodsFor: 'adding' stamp: 'AlainPlantec 12/14/2010 18:49'! addItem: anHistoryItem self current notNil ifTrue: [(self current addItem: anHistoryItem) ifTrue: [^ true]]. self opened ifTrue: [self history add: anHistoryItem. ^ true]. ^ false! ! !HistoryNode methodsFor: 'opening-closing' stamp: 'AlainPlantec 12/13/2010 22:00'! reset history := nil. opened := true! ! !HistoryNode methodsFor: 'accessing' stamp: 'AlainPlantec 12/12/2010 18:37'! history ^ history ifNil: [history := OrderedCollection new] ! ! !HistoryNode methodsFor: 'accessing' stamp: 'AlainPlantec 12/13/2010 10:39'! groupClass ^ self class! ! !HistoryNode methodsFor: 'opening-closing' stamp: 'AlainPlantec 1/5/2011 09:36'! closeGroup (self current notNil and: [self current isComposite and: [self current opened]]) ifTrue: [self current closeGroup] ifFalse: [self close]! ! !HistoryNode methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 19:42'! at: aPosition put: anItem self history at: aPosition put: anItem! ! !HistoryNode methodsFor: 'accessing' stamp: 'AlainPlantec 12/12/2010 19:01'! at: aPosition ^ self history at: aPosition! ! !HistoryNode methodsFor: 'testing' stamp: 'AlainPlantec 12/13/2010 11:54'! opened ^ opened ifNil: [opened := true]! ! !HistoryNode methodsFor: 'removing' stamp: 'AlainPlantec 12/14/2010 19:57'! removeAt: anIndex self history removeAt: anIndex! ! !HistoryNode methodsFor: 'removing' stamp: 'AlainPlantec 12/14/2010 12:56'! removeLast self history removeLast! ! !HistoryNode methodsFor: 'opening-closing' stamp: 'AlainPlantec 12/13/2010 11:53'! open opened := true! ! !HistoryNode methodsFor: 'removing' stamp: 'AlainPlantec 12/14/2010 12:59'! removeLast: count self history removeLast: count! ! !HistoryNode methodsFor: 'accessing' stamp: 'AlainPlantec 12/13/2010 15:05'! current ^ self history isEmpty ifFalse: [self history last] ! ! !HistoryNode methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 19:04'! closed ^ self opened not! ! !HistoryNode methodsFor: 'opening-closing' stamp: 'AlainPlantec 12/13/2010 13:07'! openGroup ^ self addItem: self groupClass new! ! !HistoryNodeTest methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/14/2010 13:23'! testOneGroup | h i c i2 i3 i4 | h := HistoryNode new. h addItem: (i := HistoryLeaf new). self assert: h size = 1. self assert: (h at: 1) = i. h openGroup. self assert: h size = 2. self assert: (h at: 1) = i. self assert: (c := h at: 2) isComposite. self assert: c isEmpty. h addItem: (i2 := HistoryLeaf new). self assert: h size = 2. self assert: c size = 1. self assert: c current = i2. h closeGroup. h addItem: (i3 := HistoryLeaf new). self assert: h size = 3. self assert: (h at: 3) = i3. h closeGroup. h addItem: (i4 := HistoryLeaf new). self assert: h size = 3. ! ! !HistoryNodeTest methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/14/2010 13:21'! testEmptyHistory | h | h := HistoryNode new. self assert: h size = 0. self assert: h current isNil! ! !HistoryNodeTest methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/14/2010 13:22'! testOneItem | h i | h := HistoryNode new. h addItem: (i := HistoryLeaf new). self assert: h size = 1. self assert: h current = i! ! !HistoryNodeTest methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/5/2011 09:31'! testTwoConsecutiveCloseGroup | h i grp1 grp2 i2 i3 i4 | h := HistoryNode new. h addItem: (i := HistoryLeaf new). self assert: h size = 1. self assert: (h at: 1) = i. h openGroup. self assert: h size = 2. grp1 := h at: 2. h openGroup. self assert: h size = 2. self assert: grp1 size = 1. grp2 := grp1 at: 1. self assert: grp2 size = 0. h closeGroup. h closeGroup. h addItem: (i3 := HistoryLeaf new). self assert: h size = 3. self assert: h current = i3. ! ! !HistoryNodeTest methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/14/2010 13:23'! testTwoGroups | h i grp1 grp2 i2 i3 i4 | h := HistoryNode new. h addItem: (i := HistoryLeaf new). self assert: h size = 1. self assert: (h at: 1) = i. h openGroup. self assert: h size = 2. grp1 := h at: 2. h openGroup. self assert: h size = 2. self assert: grp1 size = 1. grp2 := grp1 at: 1. self assert: grp2 size = 0. h addItem: (i2 := HistoryLeaf new). self assert: grp2 size = 1. h closeGroup. h addItem: (i2 := HistoryLeaf new). self assert: grp2 size = 1. self assert: grp1 size = 2. self assert: grp1 current = i2. h closeGroup. h addItem: (i3 := HistoryLeaf new). self assert: grp2 size = 1. self assert: grp1 size = 2. self assert: h size = 3. self assert: h current = i3. ! ! !HistoryNodeTest methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/14/2010 13:23'! testGroup | h i | h := HistoryNode new. h addItem: (i := HistoryLeaf new). self assert: h size = 1. self assert: (h at: 1) = i. h openGroup. self assert: h size = 2. self assert: (h at: 1) = i. self assert: (h at: 2) isComposite. ! ! !HistoryNodeTest methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/14/2010 13:23'! testReset | h i | h := HistoryNode new. h addItem: (i := HistoryLeaf new). self assert: h current = i. self assert: h size = 1. h reset. self assert: h size = 0.! ! !HistoryNodeTest methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/14/2010 13:22'! testClose | h i | h := HistoryNode new. h close. h addItem: (i := HistoryLeaf new). h open. h addItem: i. self assert: h current = i! ! !HowToMakeYourOwnTutorial commentStamp: 'CamilloBruni 2/22/2014 18:44'! I'm a Pharo tutorial which teach to create a Pharo tutorial. Open me with PharoTutorial goOn: HowToMakeYourOwnTutorial.! !HowToMakeYourOwnTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:45'! implementTutorial ^ Lesson title: 'Implement tutorial method' lesson: '"Finally implement the tutorial method to return an Array of your lesson factory methods:" HowToDebug compile: ''tutorial ^ #( #useSelfHalt #examineStackTrace #changeReturnValue )'' classified: ''tutorial''. PharoTutorial next.'.! ! !HowToMakeYourOwnTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:45'! createLessonFactoryMethods ^ Lesson title: 'Lesson factory methods' lesson: '"Next, create category ''lessons'' and add a method per lesson. Each method must return a Lesson object. Your can use Lesson class>>title:lesson: to create Lesson object." HowToDebug compile: ''useSelfHalt ^ Lesson title: ''''self halt'''' lesson: ''''"Put self halt. in the method you want to debug." PharoTutorial next.'''''' classified: ''lessons''. HowToDebug compile: ''examineStackTrace ^ Lesson title: ''''self halt'''' lesson: ''''"Look at PharoDebug.log." PharoTutorial next.'''''' classified: ''lessons''. HowToDebug compile: ''changeReturnValue ^ Lesson title: ''''Change return value'''' lesson: ''''"Easy in the debugger !!"'''''' classified: ''lessons''. PharoTutorial next.'.! ! !HowToMakeYourOwnTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:45'! runYourTutorial ^ Lesson title: 'Run your tutorial' lesson: '"You can run your fresh new tutorial like this:" PharoTutorial goOn: HowToDebug.'.! ! !HowToMakeYourOwnTutorial methodsFor: 'tutorial' stamp: 'LaurentLaffont 1/21/2010 21:45'! tutorial ^ #( subclassAbstractTutorial createLessonFactoryMethods implementTutorial runYourTutorial )! ! !HowToMakeYourOwnTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:45'! subclassAbstractTutorial ^ Lesson title: 'AbstractTutorial' lesson: '"Here are the steps to create your own Pharo tutorial. First, create a subclass of AbstractTutorial. For example:" AbstractTutorial subclass: #HowToDebug instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''PharoTutorial''. PharoTutorial next.'! ! !HowToMakeYourOwnTutorialTest commentStamp: 'TorstenBergmann 2/12/2014 22:50'! Tests for HowToMakeYourOwnTutorial! !HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: ''! testLessonAtReturnsCorrespondingLesson | answer | 1 to: (self testedTutorial tutorial size) do: [:index| answer := self testedTutorial lessonAt: index. self assert: (answer isKindOf: Lesson) ] ! ! !HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: 'LaurentLaffont 2/1/2010 22:04'! testedTutorial "Returns an instance of an AbstractTutorial subclass" ^ HowToMakeYourOwnTutorial new! ! !HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: ''! testNotEmpty self assert: self testedTutorial tutorial notEmpty.! ! !HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: ''! testEachSelectorReturnsALesson | answer | self testedTutorial tutorial do: [:aSelector| answer := (self testedTutorial perform: aSelector). self assert: (answer isKindOf: Lesson). ]! ! !HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: 'LaurentLaffont 2/1/2010 22:05'! testEachSelectorExists self testedTutorial tutorial do: [:aSelector| self assert: (self testedTutorial respondsTo: aSelector) ]! ! !HowToMakeYourOwnTutorialTest methodsFor: 'tests' stamp: ''! testSizeReturnsNumberOfSelectors self assert: (self testedTutorial tutorial size) equals: self testedTutorial size.! ! !HttpUrl commentStamp: 'ls 6/15/2003 13:44'! A URL that can be accessed via the Hypertext Transfer Protocol (HTTP), ie, a standard Web URL realm = the name of the security realm that has been discovered for this URL. Look it up in Passwords. Passwords = a Dictionary of (realm -> encoded user&password) TODO: use the username and password, if specified ! !HttpUrl methodsFor: '*Gofer-Core' stamp: 'SeanDeNigris 8/26/2012 15:39'! mcRepositoryAsUser: usernameString withPassword: passwordString ^ MCHttpRepository location: self asString user: usernameString password: passwordString.! ! !HttpUrl methodsFor: 'downloading' stamp: 'SvenVanCaekenberghe 9/27/2012 11:16'! retrieveContents "Download and return the resource that I refer to. This will typically return a String or a ByteArray (see ZnClient>>#get:). If something goes wrong, an exception will be signalled." " 'http://zn.stfx.eu/zn/numbers.txt' asUrl retrieveContents. " ^ self asZnUrl retrieveContents! ! !HttpUrl class methodsFor: 'constants' stamp: 'SeanDeNigris 1/30/2011 11:32'! schemeName ^ 'http'.! ! !HttpUrlTest commentStamp: 'TorstenBergmann 2/5/2014 10:13'! SUnit tests for HttpUrl ! !HttpUrlTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 9/27/2012 11:28'! testRetrieveContents | contents | contents := 'http://zn.stfx.eu/zn/small.html' asUrl retrieveContents. self assert: contents isString. self assert: (contents includesSubstring: 'Small')! ! !HttpUrlTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2011 18:58'! testHttps self assert: 'https://encrypted.google.com' asUrl scheme = 'https'.! ! !HttpsUrl commentStamp: 'TorstenBergmann 2/3/2014 23:10'! An Https Url! !HttpsUrl class methodsFor: 'constants' stamp: 'CamilloBruni 12/16/2011 11:17'! schemeName ^ 'https'.! ! !IRAccess commentStamp: ''! IRAccess models all bytecodes that read or write variables or self/super/thisContext! !IRAccess methodsFor: 'testing' stamp: 'md 6/13/2005 12:01'! isRead ^self isStore not! ! !IRAccess methodsFor: 'initialization' stamp: 'MarcusDenker 8/13/2010 13:59'! initialize store := false! ! !IRAccess methodsFor: 'testing' stamp: 'MarcusDenker 8/13/2010 13:59'! isStore ^store! ! !IRAccess methodsFor: 'accessing' stamp: 'JorgeRessia 5/1/2010 08:30'! name: aString name := aString! ! !IRAccess methodsFor: 'accessing' stamp: 'JorgeRessia 4/29/2010 16:35'! name ^name! ! !IRAccess methodsFor: 'accessing' stamp: 'MarcusDenker 8/13/2010 14:03'! store: aBool store := aBool! ! !IRBlockReturnTop methodsFor: 'testing' stamp: 'md 10/8/2004 16:04'! isBlockReturnTop ^true.! ! !IRBlockReturnTop methodsFor: 'interpret' stamp: 'md 10/8/2004 16:04'! executeOn: interpreter interpreter blockReturnTop.! ! !IRBlockReturnTop methodsFor: 'accessing' stamp: 'MarcusDenker 6/19/2012 13:50'! successorSequences "sent to last instruction in sequence which is expected to be a jump and return instruction" ^ { successor }! ! !IRBlockReturnTop methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:23'! accept: aVisitor ^ aVisitor visitBlockReturnTop: self! ! !IRBlockReturnTop methodsFor: 'accessing' stamp: 'MarcusDenker 6/19/2012 13:50'! successor: anObject successor := anObject. ! ! !IRBuilder commentStamp: ''! I provide a simple interface for constructing an IRMethod. For example, to create an ir method that compares first instVar to first arg and returns 'yes' or 'no' (same example as in BytecodeGenerator), do: IRBuilder new numArgs: 1; addTemps: #(a z); pushReceiver; pushInstVar: 1; pushTemp: #a; send: #>; jumpAheadTo: #else if: false; pushLiteral: 'yes'; returnTop; jumpAheadTarget: #else; pushLiteral: 'no'; returnTop; ir Sending #compiledMethod to an ir method will generate its compiledMethod. Sending #methodNode to it will decompile to its parse tree. ! !IRBuilder methodsFor: 'initialize' stamp: 'jb 4/2/2010 11:32'! addTemp: tempKey self addTemps: {tempKey}! ! !IRBuilder methodsFor: 'private' stamp: 'MarcusDenker 6/13/2012 14:13'! startNewSequence "End current instruction sequence and start a new sequence to add instructions to. If ending block just falls through to new block then add an explicit jump to it so they stay linked" | newSequence | currentSequence ifEmpty: [^ self]. "block is still empty, continue using it" newSequence := IRSequence orderNumber: currentSequence orderNumber + 1. newSequence method: ir. currentSequence last isJumpOrReturn ifFalse: [ self add: (IRJump new destination: newSequence)]. self currentScope isPushClosureCopy ifTrue: [self currentScope lastBlockSequence: currentSequence]. currentSequence := newSequence. ! ! !IRBuilder methodsFor: 'scopes' stamp: 'JorgeRessia 5/20/2010 09:58'! popScope currentScope pop.! ! !IRBuilder methodsFor: 'instructions' stamp: 'jre 9/29/2009 15:39'! pushConsArray: size self add: (IRInstruction pushConsArray: size)! ! !IRBuilder methodsFor: 'initialization' stamp: 'MarcusDenker 6/13/2012 14:12'! initialize ir := IRMethod new. jumpAheadStacks := IdentityDictionary new. jumpBackTargetStacks := IdentityDictionary new. sourceMapNodes := OrderedCollection new. "stack" currentScope := Stack new. self pushScope: ir. "Leave an empty sequence up front (guaranteed not to be in loop)" ir startSequence: ((IRSequence orderNumber: 0) method:ir). currentSequence := (IRSequence orderNumber: 1) method:ir. ir startSequence add: (IRJump new destination: currentSequence; bytecodeIndex: sourceMapByteIndex; yourself). ! ! !IRBuilder methodsFor: 'accessing' stamp: 'md 7/10/2005 22:37'! properties: aDict ir properties: aDict! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 8/19/2010 16:12'! pushInstVar: index self add: (IRInstruction pushInstVar: index).! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 6/13/2012 14:19'! storeTemp: aSymbol ^self add: (IRInstruction storeTemp: aSymbol)! ! !IRBuilder methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:17'! mapToByteIndex: index "decompiling" sourceMapByteIndex := index! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 6/13/2012 14:18'! storeIntoLiteralVariable: name ^self add: (IRInstruction storeIntoLiteralVariable: name)! ! !IRBuilder methodsFor: 'instructions' stamp: 'md 4/21/2005 12:06'! pushThisContext self add: (IRInstruction pushThisContext)! ! !IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09'! pushDup self add: IRInstruction pushDup! ! !IRBuilder methodsFor: 'instructions' stamp: 'JorgeRessia 5/20/2010 07:25'! returnTop self add: IRInstruction returnTop. self startNewSequence. ! ! !IRBuilder methodsFor: 'scopes' stamp: 'MarcusDenker 4/13/2010 14:20'! currentScope ^currentScope top! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 8/18/2010 19:55'! pushLiteral: object self add: (IRInstruction pushLiteral: object)! ! !IRBuilder methodsFor: 'instructions' stamp: 'ajh 3/10/2003 01:09'! popTop self add: IRInstruction popTop! ! !IRBuilder methodsFor: 'instructions' stamp: 'ToonVerwaest 3/27/2011 17:17'! jumpAheadTarget: labelSymbol "Pop latest jumpAheadTo: with this labelSymbol and have it point to this new instruction sequence" | jumpInstr | self startNewSequence. jumpInstr := (jumpAheadStacks at: labelSymbol ifAbsent: [ self error: 'Missing jumpAheadTo: ', labelSymbol printString]) removeLast. jumpInstr destination: currentSequence. ! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 6/15/2012 10:37'! pushClosureCopyCopiedValues: copiedValuesNames args: args jumpTo: aJumpLabel | irInstruction | irInstruction := IRInstruction pushClosureCopyCopiedValues: copiedValuesNames args: args. self add: irInstruction. (jumpAheadStacks at: aJumpLabel ifAbsentPut: [OrderedCollection new]) addLast: irInstruction. self startNewSequence. irInstruction blockSequence: currentSequence. self pushScope: irInstruction. self addTemps: args. self addTemps: copiedValuesNames. ^irInstruction! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 12/14/2012 11:51'! pushTemp: aSelector ^ self add: (IRInstruction pushTemp: aSelector)! ! !IRBuilder methodsFor: 'initialize' stamp: 'MarcusDenker 5/14/2013 10:07'! compilationContext: aCompilationContext ir compilationContext: aCompilationContext! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 6/13/2012 14:19'! storeRemoteTemp: name inVector: nameOfVector ^self add: (IRInstruction storeRemoteTemp: name inVectorAt: nameOfVector)! ! !IRBuilder methodsFor: 'mapping' stamp: 'MarcusDenker 8/20/2010 08:07'! sourceByteIndex ^ sourceMapByteIndex! ! !IRBuilder methodsFor: 'initialize' stamp: 'MarcusDenker 5/19/2011 13:49'! createTempVectorNamed: name withVars: anArray "self addVectorTemps: anArray." self addTemp: name. self add: (IRInstruction createTempVectorNamed: name withVars: anArray). ! ! !IRBuilder methodsFor: 'instructions' stamp: 'md 4/21/2005 11:38'! pushReceiver self add: (IRInstruction pushReceiver)! ! !IRBuilder methodsFor: 'results' stamp: 'ajh 3/10/2003 15:51'! ir ^ ir! ! !IRBuilder methodsFor: 'instructions' stamp: 'JB 8/1/2010 14:56'! jumpAheadTo: labelSymbol "Jump to the sequence that will be created when jumpAheadTarget: labelSymbol is sent to self. This is and its corresponding target is only good for one use. Other jumpAheadTo: with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called." "jumpAheadTarget: label will pop this and replace destination with its basic block" (jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new]) addLast: (self add: IRJump new). self startNewSequence. ! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 6/19/2012 13:19'! jumpBackTo: labelSymbol "Pop last remembered position with this label and write an unconditional jump to it" | sequence jump | sequence := (jumpBackTargetStacks at: labelSymbol ifAbsent: [self error: 'Missing jumpBackTarget: ', labelSymbol printString]) removeLast. jump := IRJump new destination: sequence. self add: jump. self startNewSequence. jump successor: currentSequence. ! ! !IRBuilder methodsFor: 'scopes' stamp: 'MarcusDenker 8/18/2010 19:55'! pushScope: anIRBlockOrMethod currentScope push: anIRBlockOrMethod! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 12/14/2012 10:43'! blockReturnTop | retInst | retInst := IRInstruction blockReturnTop. self add: retInst. self startNewSequence. retInst successor: currentSequence. self popScope.! ! !IRBuilder methodsFor: 'initialize' stamp: 'MarcusDenker 5/13/2011 13:40'! addLiteral: aLiteral "Add this literal at the end of the literal array if there is space left" ir addAdditionalLiteral: aLiteral.! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 6/13/2012 14:18'! storeInstVar: name ^self add: (IRInstruction storeInstVar: name).! ! !IRBuilder methodsFor: 'initialize' stamp: 'MarcusDenker 1/23/2014 17:17'! addTemps: newKeys | i offset | offset := self currentScope tempMap size. i := 1. newKeys do: [:key | self currentScope tempMap at: key ifAbsentPut: [i:=i+1.offset + i - 1]. ]. ! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 6/13/2012 14:19'! send: selector toSuperOf: behavior ^self add: (IRInstruction send: selector toSuperOf: behavior)! ! !IRBuilder methodsFor: 'accessing' stamp: 'MarcusDenker 5/14/2013 17:10'! irPrimitive: primNode ir irPrimitive: primNode! ! !IRBuilder methodsFor: 'private' stamp: 'ToonVerwaest 3/31/2011 13:17'! add: instr "Associate instr with current parse node or byte range" instr sourceNode: self sourceNode. instr bytecodeIndex: self sourceByteIndex. ^ currentSequence add: instr! ! !IRBuilder methodsFor: 'initialize' stamp: 'MarcusDenker 6/6/2012 13:38'! additionalLiterals: literals "Add this literal at the end of the literal array if there is space left" ir addAdditionalLiterals: literals.! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 6/13/2012 14:17'! pushRemoteTemp: name inVector: nameOfVector ^self add: (IRInstruction pushRemoteTemp: name inVectorAt: nameOfVector)! ! !IRBuilder methodsFor: 'mapping' stamp: 'ajh 6/22/2003 14:25'! popMap sourceMapNodes removeLast! ! !IRBuilder methodsFor: 'mapping' stamp: 'MarcusDenker 11/19/2012 17:14'! sourceNode ^ sourceMapNodes ifEmpty: [nil] ifNotEmpty: [sourceMapNodes last]! ! !IRBuilder methodsFor: 'instructions' stamp: 'jre 9/29/2009 15:39'! pushNewArray: size self add: (IRInstruction pushNewArray: size)! ! !IRBuilder methodsFor: 'mapping' stamp: 'ajh 6/22/2003 14:45'! mapToNode: object "new instructions will be associated with object" sourceMapNodes addLast: object! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 10/12/2010 12:19'! addBlockReturnTopIfRequired "If the current sequence is empty this means that there was a returntop before then since there is no more stmts we do not need a blockreturntop" "cant we optimize this away later? Then the frontend can always just add a return...." | predecessors | self flag: 'cant we do this automatically.... frontend always adds return, we ignore it if there is a ret method before?'. predecessors := ir predecessorsOf: currentSequence. (currentSequence isEmpty and: [(predecessors isEmpty) or: [((ir predecessorsOf: currentSequence) anySatisfy: [:each | (each last isBlockReturnTop not) and: [(each last isReturn) or: [(each size > 1) and: [(each at: each size -1) isReturn] ]]])] ]) ifTrue: [self popScope] ifFalse: [self blockReturnTop ]! ! !IRBuilder methodsFor: 'initialize' stamp: 'MarcusDenker 11/19/2012 17:16'! numArgs: anInteger ir numArgs: anInteger. ir sourceNode: self sourceNode.! ! !IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:44'! jumpBackTarget: labelSymbol "Remember this basic block for a future jumpBackTo: labelSymbol. Stack up remembered targets with same name and remove them from stack for each jumpBackTo: called with same name." self startNewSequence. (jumpBackTargetStacks at: labelSymbol ifAbsentPut: [OrderedCollection new]) addLast: currentSequence. ! ! !IRBuilder methodsFor: 'accessing' stamp: 'MarcusDenker 5/18/2013 17:37'! compilationContext ^ir compilationContext ! ! !IRBuilder methodsFor: 'instructions' stamp: 'ajh 6/22/2003 14:44'! jumpAheadTo: labelSymbol if: boolean "Conditional jump to the sequence that will be created when jumpAheadTarget: labelSymbol is sent to self. This and its corresponding target is only good for one use. Other jumpAheadTo:... with the same label will be put on a stack and superceed existing ones until its jumpAheadTarget: is called." | instr | "jumpAheadTarget: label will pop this and replace destination with its basic block" (jumpAheadStacks at: labelSymbol ifAbsentPut: [OrderedCollection new]) addLast: (instr := self add: (IRJumpIf new boolean: boolean)). self startNewSequence. instr otherwise: currentSequence. ! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 8/18/2010 19:55'! pushLiteralVariable: object self add: (IRInstruction pushLiteralVariable: object)! ! !IRBuilder methodsFor: 'decompiling' stamp: 'ajh 3/21/2003 01:48'! testJumpAheadTarget: label jumpAheadStacks at: label ifPresent: [:stack | [stack isEmpty] whileFalse: [self jumpAheadTarget: label] ]! ! !IRBuilder methodsFor: 'initialize' stamp: 'JorgeRessia 5/6/2010 11:04'! addPragma: aPragma ^ir addPragma: aPragma! ! !IRBuilder methodsFor: 'instructions' stamp: 'MarcusDenker 6/13/2012 14:19'! send: selector ^self add: (IRInstruction send: selector)! ! !IRBuilder methodsFor: 'decompiling' stamp: 'ajh 6/22/2003 14:44'! addJumpBackTarget: label to: sequence (jumpBackTargetStacks at: label ifAbsentPut: [OrderedCollection new]) addLast: sequence! ! !IRBuilder class methodsFor: 'builder api' stamp: 'MarcusDenker 7/9/2013 16:07'! buildMethod: aBlock ^(self buildIR: aBlock) compiledMethod! ! !IRBuilder class methodsFor: 'builder api' stamp: 'MarcusDenker 7/9/2013 16:09'! buildIR: aBlock ^(aBlock value: self new) ir.! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/18/2010 18:52'! testLiteralBoolean | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: true; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() )). ^iRMethod. ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:45'! testLiteralVariableClass | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteralVariable: Object binding; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = Object). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 9/3/2010 14:12'! testRemoteTempShadowed | iRMethod aCompiledMethod | iRMethod := IRBuilder new addTemps: #(a); "we have one real temp" pushLiteral: 1; storeTemp: #a; popTop; pushClosureCopyCopiedValues: #() args: #() jumpTo: #block; addTemps: #(a); pushTemp: #a; "a shadows the outer one" send: #isNil; blockReturnTop; jumpAheadTarget: #block; send: #value; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = true). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 8/27/2010 13:22'! testPushClosureCopyOneCopiedArg | iRMethod aCompiledMethod | iRMethod := IRBuilder new addTemps: #(c a); pushReceiver; pushLiteral: 1; storeTemp: #a; popTop; pushClosureCopyCopiedValues: #(a) args: #(d) jumpTo: #block; pushTemp: #a; pushTemp: #d; send: #+; blockReturnTop; jumpAheadTarget: #block; pushLiteral: 1; send: #value:; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:46'! testPushSelf | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushReceiver; send: #class; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) == UndefinedObject). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/25/2010 14:22'! testStorePopIntoVariable | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 4; storeIntoLiteralVariable: (self class bindingOf: #TestToPush); popTop; pushLiteralVariable: (self class bindingOf: #TestToPush); returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). aCompiledMethod valueWithReceiver: nil arguments: #(). self assert: (self class testToPush = 4). self class testToPush: nil. ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:45'! testLiteralVariableClassVariable | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteralVariable: (DateAndTime bindingOf: #LocalTimeZone); returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = DateAndTime localTimeZone). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:49'! testPushNewArray | iRMethod aCompiledMethod receiver | iRMethod := IRBuilder new pushNewArray: 1; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. receiver := (5@8). self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: receiver arguments: #()) first isNil). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/25/2010 14:25'! testStoreIvar | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 34; storeInstVar: 2; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: self arguments: #() ) = 34). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:54'! testStoreIntoVariable | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 4; storeIntoLiteralVariable: (self class bindingOf: #TestToPush); returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). aCompiledMethod valueWithReceiver: nil arguments: #(). self assert: (self class testToPush = 4). self class testToPush: nil. ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 11/11/2011 15:40'! testLiteralVariableGlobale | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteralVariable: (Smalltalk globals associationAt: #Smalltalk); returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = Smalltalk). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/18/2010 19:00'! testReturnTop | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: false; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self deny: (aCompiledMethod valueWithReceiver: nil arguments: #()). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 9/14/2013 17:31'! testSendSuper | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushReceiver; send: #isThisEverCalled toSuperOf: self class; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self should: [(aCompiledMethod valueWithReceiver: (self class new) arguments: #())] raise: Error. ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/18/2010 19:01'! testPopTop | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushReceiver; pushLiteral: false; popTop; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) isNil). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:48'! testInstVar | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushInstVar: 1; pushInstVar: 2; send: #+; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: (3@4) arguments: #() ) = 7). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 8/27/2010 10:38'! testPushClosureCopyNoCopiedArgNamed | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushReceiver; pushClosureCopyCopiedValues: #() args: #(d) jumpTo: #block; pushLiteral: 1; pushTemp: #d; send: #+; blockReturnTop; jumpAheadTarget: #block; pushLiteral: 1; send: #value:; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 8/27/2010 13:22'! testPushClosureCopyNoCopied | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushReceiver; pushClosureCopyCopiedValues: #() args: #() jumpTo: #block; pushLiteral: 1; pushLiteral: 2; send: #+; blockReturnTop; jumpAheadTarget: #block; send: #value; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 3). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/18/2010 18:58'! testLiteralArray | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: #(test 4 you); returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = #(test 4 you)). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:45'! testLiteralNil | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: nil; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: 4 arguments: #() ) isNil). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/18/2010 19:49'! testJumpBackTo | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushReceiver; pushLiteral: false; jumpBackTarget: #begin; jumpAheadTo: #end if: true; pushLiteral: true; jumpBackTo: #begin; jumpAheadTarget: #end; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) isNil). ^iRMethod. ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/20/2010 22:46'! testJumpAheadTo | iRMethod aCompiledMethod iRBuilder | iRBuilder := IRBuilder new. iRMethod := iRBuilder pushLiteral: 2; pushLiteral: 1; send: #+; jumpAheadTo: #end; pushLiteral: 3; jumpAheadTarget: #end; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: (aCompiledMethod valueWithReceiver: nil arguments: #()) = 3. ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:49'! testPushConsArray | iRMethod aCompiledMethod receiver | iRMethod := IRBuilder new pushReceiver; pushConsArray: 1; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. receiver := (5@8). self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: receiver arguments: #()) first == receiver). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 7/9/2013 16:08'! testDup | iRMethod aCompiledMethod | iRMethod := IRBuilder buildIR: [ : builder | builder pushLiteral: 3; pushDup; send: #=; returnTop]. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: (aCompiledMethod valueWithReceiver: nil arguments: #() ). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:45'! testLiteralString | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 'hello'; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 'hello'). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:49'! testPushConsArray2 | iRMethod aCompiledMethod receiver | iRMethod := IRBuilder new pushLiteral: 'hi!!'; pushConsArray: 1; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. receiver := (5@8). self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: (((aCompiledMethod valueWithReceiver: receiver arguments: #()))= #('hi!!')). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing - builder' stamp: 'MarcusDenker 7/9/2013 16:10'! testBuildMethod | aCompiledMethod | aCompiledMethod := IRBuilder buildMethod: [ : builder | builder pushLiteral: 3; pushDup; send: #=; returnTop]. self assert: (aCompiledMethod isKindOf: CompiledMethod).! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 6/17/2013 12:51'! testLiteralCharacter | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: $e; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = $e). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 8/27/2010 13:21'! testPushClosureCopyOneCopiedTemp | iRMethod aCompiledMethod | iRMethod := IRBuilder new addTemps: #(c a); pushReceiver; pushLiteral: 1; storeTemp: #a; popTop; pushClosureCopyCopiedValues: #(a) args: #() jumpTo: #block; addTemps: #(d); "the temp" pushTemp: #a; pushLiteral: 1; send: #+; storeTemp: #d; popTop; pushTemp: #d; blockReturnTop; jumpAheadTarget: #block; send: #value; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 8/27/2010 13:22'! testPushClosureCopyNoCopiedArg | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushReceiver; pushClosureCopyCopiedValues: #() args: #(d) jumpTo: #block; pushLiteral: 1; pushTemp: #d; send: #+; blockReturnTop; jumpAheadTarget: #block; pushLiteral: 1; send: #value:; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 8/27/2010 13:22'! testPushClosureCopyOneCopied | iRMethod aCompiledMethod | iRMethod := IRBuilder new addTemps: #(c a); pushReceiver; pushLiteral: 1; storeTemp: #a; popTop; pushClosureCopyCopiedValues: #(a) args: #() jumpTo: #block; pushTemp: #a; blockReturnTop; jumpAheadTarget: #block; send: #value; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 1). ^iRMethod! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 7/5/2013 15:41'! testLiteralInteger | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 2; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:45'! testLiteralSymbol | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: #you; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = #you). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 8/27/2010 13:21'! testRemoteTempNested | iRMethod aCompiledMethod | iRMethod := IRBuilder new addTemps: #(a); "we have one real temp" createTempVectorNamed:#methodVector withVars: #(b); "b we know will be written to, so make a tempvector entry" pushLiteral: 1; storeTemp: #a; popTop; pushClosureCopyCopiedValues: #(methodVector a) args: #() jumpTo: #block; createTempVectorNamed:#blockVector withVars: #(f); pushTemp: #a; "a is just read, so we copy it to the block" pushClosureCopyCopiedValues: #(methodVector) args: #() jumpTo: #block2; pushLiteral: 1; storeRemoteTemp: #b inVector: #methodVector; "f comes from tempvetor, as we do write to it" blockReturnTop; jumpAheadTarget: #block2; send: #value; send: #+; storeRemoteTemp: #b inVector: #methodVector; "b comes from tempvetor, as we do write to it" blockReturnTop; jumpAheadTarget: #block; send: #value; pushRemoteTemp: #b inVector: #methodVector; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #()) = 2). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 8/27/2010 13:20'! testRemoteTemp | iRMethod aCompiledMethod | iRMethod := IRBuilder new addTemps: #(a c); "we have one real temp" createTempVectorNamed:#methodVector withVars: #(b); "b we know will be written to, so make a tempvector entry" pushLiteral: 1; storeTemp: #a; popTop; pushClosureCopyCopiedValues: #(#a #c #methodVector) args: #() jumpTo: #block; pushTemp: #a; "a is just read, so we copy it to the block" pushLiteral: 1; send: #+; storeRemoteTemp: #b inVector: #methodVector; "b comes from tempvetor, as we do write to it" popTop; blockReturnTop; jumpAheadTarget: #block; send: #value; pushRemoteTemp: #b inVector: #methodVector; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/18/2010 18:58'! testLiteralFloat | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 2.0; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) closeTo: 2.0). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:47'! testPushTempTemp | iRMethod aCompiledMethod | iRMethod := IRBuilder new addTemps: #(a); pushTemp: #a; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: 5 arguments: #() ) isNil). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 8/27/2010 13:25'! testPushClosureCopyOneCopiedTempArg | iRMethod aCompiledMethod | iRMethod := IRBuilder new addTemps: #(c a); pushReceiver; pushLiteral: 1; storeTemp: #a; popTop; pushClosureCopyCopiedValues: #(a) args: #(e) jumpTo: #block; addTemps: #(d); "the temp" pushTemp: #a; pushTemp: #e; send: #+; storeTemp: #d; popTop; pushTemp: #d; blockReturnTop; jumpAheadTarget: #block; pushLiteral: 1; send: #value:; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 6/19/2012 14:57'! testJumpAheadToIf | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushReceiver; pushLiteral: true; jumpAheadTo: #end if: true; returnTop; jumpAheadTarget: #end; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) isNil). ^iRMethod. ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'JB 8/19/2010 16:46'! testPushTempArgument | iRMethod aCompiledMethod | iRMethod := IRBuilder new numArgs: 2; addTemps: #(a b); pushTemp: #a; pushTemp: #b; send: #+; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #(2 8) ) = 10). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/20/2010 22:42'! testPushThisContext | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushThisContext; send: #receiver; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: 5 arguments: #() ) = 5). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 7/4/2011 16:59'! testReturnInstVar | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushInstVar: 1; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: (3@4) arguments: #() ) = 3). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/25/2010 14:25'! testStorePopIvar | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 34; storeInstVar: 2; popTop; pushInstVar: 2; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: self arguments: #() ) = 34). ^iRMethod ! ! !IRBuilderTest methodsFor: 'testing' stamp: 'MarcusDenker 8/18/2010 19:00'! testStoreTemp | iRMethod aCompiledMethod | iRMethod := IRBuilder new addTemps: #(a); pushLiteral: 34; storeTemp: #a; popTop; pushTemp: #a; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 34). ^iRMethod ! ! !IRBuilderTest class methodsFor: 'accessing' stamp: 'ms 7/12/2006 18:43'! testToPush ^TestToPush! ! !IRBuilderTest class methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 5/13/2013 14:47'! compilerClass ^ OpalCompiler! ! !IRBuilderTest class methodsFor: 'accessing' stamp: 'ms 7/12/2006 18:43'! testToPush: anObject TestToPush := anObject! ! !IRBytecodeDecompiler commentStamp: 'ajh 3/25/2003 00:26'! I interpret bytecode instructions, sending the appropriate instruction messages to my IRBuilder, resulting in an IRMethod.! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/27/2011 15:25'! popIntoTemporaryVariable: offset newTempVector ifNil: [ self storeIntoTemporaryVariable: offset. self doPop. ] ifNotNil: [ self scope newTempVector: newTempVector at: offset. " Keep offset for remapping in popScope " newTempVector index: offset. irBuilder createTempVectorNamed: newTempVector withVars: newTempVector. newTempVector := nil ]! ! !IRBytecodeDecompiler methodsFor: 'quick methods' stamp: 'MarcusDenker 6/19/2012 11:48'! methodReturnReceiver self pushReceiver. self methodReturnTop.! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:09'! pushReceiver irBuilder pushReceiver! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/28/2011 18:21'! pushConstant: value irBuilder pushLiteral: value! ! !IRBytecodeDecompiler methodsFor: 'private' stamp: 'MarcusDenker 4/29/2013 17:39'! methodClass ^ instructionStream method methodClass! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:09'! popIntoLiteralVariable: offset self storeIntoLiteralVariable: offset. self doPop.! ! !IRBytecodeDecompiler methodsFor: 'scope' stamp: 'ToonVerwaest 3/31/2011 14:54'! popScope | scope tempIndex | scope := self scope. irBuilder addTemps: scope temps. " Remap your own temp vectors " scope ownTempVectors do: [ :tempVector | irBuilder remapTemp: (scope -> tempVector index) toRemote: tempVector ]. " Remap the copied values " tempIndex := scope numArgs. scope copiedValues do: [ :copiedValue | irBuilder remapTemp: (scope -> tempIndex) toRemote: copiedValue. tempIndex := tempIndex + 1. ]. ^ scopeStack pop! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'MarcusDenker 11/11/2011 15:51'! send: selector super: superFlag numArgs: numArgs superFlag ifTrue: [irBuilder send: selector toSuperOf: self methodClass] ifFalse: [irBuilder send: selector]! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:08'! jump: dist if: bool | index | index := instructionStream pc + dist . dist >= 0 ifTrue: [ "conditional jump forward" ^ irBuilder jumpAheadTo: index if: bool ]. self error: 'Should not do this'! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'MarcusDenker 6/13/2012 13:23'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize | closureEnd copiedValues | copiedValues := irBuilder removeLast: numCopied. self pushScope: copiedValues numArgs: numArgs. closureEnd := instructionStream pc + blockSize. irBuilder pushClosureCopyCopiedValues: copiedValues args: self scope args jumpTo: closureEnd.! ! !IRBytecodeDecompiler methodsFor: 'quick methods' stamp: 'MarcusDenker 7/16/2012 16:05'! quickMethod instructionStream method primitive = 256 ifTrue: [ ^ self methodReturnReceiver ]. instructionStream method isReturnSpecial ifTrue: [ ^ self methodReturnConstant: (IRBytecodeGenerator specialConstants at: instructionStream method primitive - 256) ]. instructionStream method isReturnField ifTrue: [ self pushReceiverVariable: instructionStream method returnField. ^ self methodReturnTop ]. self error: 'quick method inconsistency'! ! !IRBytecodeDecompiler methodsFor: 'scope' stamp: 'MarcusDenker 7/16/2012 16:05'! pushScope: copiedValues numArgs: numArgs |scope | scope := IRBytecodeScope new numArgs: numArgs. scopeStack push: scope. scope copiedValues: copiedValues.! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:10'! storeIntoLiteralVariable: value irBuilder storeIntoLiteralVariable: value! ! !IRBytecodeDecompiler methodsFor: 'scope' stamp: 'ToonVerwaest 3/24/2011 21:17'! scope ^ scopeStack top! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'MarcusDenker 7/16/2012 16:06'! pushNewArrayOfSize: size newTempVector := IRRemoteArray new size: size! ! !IRBytecodeDecompiler methodsFor: 'private' stamp: 'ToonVerwaest 3/24/2011 23:22'! checkIfJumpTarget irBuilder testJumpAheadTarget: instructionStream pc! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:08'! doPop irBuilder popTop! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/27/2011 01:29'! pushTemporaryVariable: offset irBuilder pushTemp: (self scope tempAt: offset)! ! !IRBytecodeDecompiler methodsFor: 'public access' stamp: 'MarcusDenker 5/14/2013 17:07'! decompile: aCompiledMethod instructionStream := InstructionStream on: aCompiledMethod. irBuilder := IRReconstructor new. scopeStack := Stack new. self pushScope: #() numArgs: aCompiledMethod numArgs. irBuilder irPrimitive: aCompiledMethod irPrimitive. irBuilder properties: aCompiledMethod properties copy. irBuilder numArgs: aCompiledMethod numArgs. irBuilder addTemps: self scope args. aCompiledMethod isQuick ifTrue: [self quickMethod] ifFalse: [self interpret]. self popScope. "just add all literals of the compiledMethod as additional literals. duplicates will be filtered out, but we keep the optimized ones" irBuilder additionalLiterals: (aCompiledMethod literals allButLast: 2). "when compiling methods of context classes, force long form for iVar access by getting the correct context" irBuilder compilationContext: aCompiledMethod methodClass compiler compilationContext. ^ irBuilder ir.! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'MarcusDenker 6/13/2012 13:33'! methodReturnTop irBuilder isLastClosureInstruction ifTrue: [ self popScope. irBuilder fixPushNilsForTemps. irBuilder returnTop. irBuilder popScope. ] ifFalse: [ irBuilder returnTop ]! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:09'! popIntoReceiverVariable: offset self storeIntoReceiverVariable: offset. self doPop.! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:09'! popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex self storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex. self doPop. ! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'MarcusDenker 6/19/2012 11:41'! jump: dist | index seq instr newSeq seqs | index := instructionStream pc + dist . dist >= 0 ifTrue: [ "jump forward" ^ irBuilder jumpAheadTo: index ]. "jump to the jump instuction itself" dist >= -2 ifTrue: [ irBuilder jumpBackTarget: index. irBuilder jumpBackTo: index. ^self]. "jump backward" seqs := irBuilder ir allSequences. seq := seqs findLast: [:s | s notEmpty and: [s first bytecodeIndex <= index]]. seq := seqs at: seq. seq first bytecodeIndex = index ifTrue: [ newSeq := seq ] ifFalse: [ instr := seq detect: [:i | (seq after: i) bytecodeIndex = index]. newSeq := seq splitAfter: instr ]. irBuilder addJumpBackTarget: index to: newSeq. "if we have split the currentSequence of the irBuilder, make sure to set it to the newSeq". irBuilder currentSequence = seq ifTrue: [irBuilder currentSequence: newSeq]. irBuilder jumpBackTo: index. ! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:09'! pushConsArrayWithElements: numElements irBuilder pushConsArray: numElements ! ! !IRBytecodeDecompiler methodsFor: 'quick methods' stamp: 'ToonVerwaest 3/24/2011 23:08'! methodReturnConstant: value self pushConstant: value. self methodReturnTop.! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:09'! pushActiveContext irBuilder pushThisContext! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/25/2011 17:13'! storeIntoRemoteTemp: remoteIndex inVectorAt: tempIndex | remoteArray remoteTempName | remoteArray := self scope tempAt: tempIndex. remoteTempName := self scope tempAt: remoteIndex inRemote: remoteArray. irBuilder storeRemoteTemp: remoteTempName inVector: remoteArray. ! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'MarcusDenker 6/13/2012 17:07'! interpret | endPC | endPC := instructionStream method endPC. [instructionStream pc > endPC ] whileFalse: [ self checkIfJumpTarget. irBuilder mapToByteIndex: instructionStream pc. instructionStream interpretNextInstructionFor: self.]! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:10'! pushReceiverVariable: offset irBuilder pushInstVar: offset + 1. ! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/28/2011 18:19'! pushLiteralVariable: assoc irBuilder pushLiteralVariable: assoc.! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/25/2011 17:13'! pushRemoteTemp: remoteIndex inVectorAt: tempIndex | remoteArray remoteTempName | remoteArray := self scope tempAt: tempIndex. remoteTempName := self scope tempAt: remoteIndex inRemote: remoteArray. irBuilder pushRemoteTemp: remoteTempName inVector: remoteArray.! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 15:40'! doDup irBuilder pushDup! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:10'! storeIntoReceiverVariable: offset irBuilder storeInstVar: offset + 1. ! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'ToonVerwaest 3/24/2011 23:10'! storeIntoTemporaryVariable: offset irBuilder storeTemp: (self scope tempAt: offset)! ! !IRBytecodeDecompiler methodsFor: 'instruction decoding' stamp: 'MarcusDenker 6/8/2012 13:50'! blockReturnTop self popScope. irBuilder blockReturnTop.! ! !IRBytecodeGenerator commentStamp: 'ajh 5/23/2003 10:59'! I generate bytecodes in response to 'instructions' messages being sent to me. I rewrite jumps at the end so their jump offsets are correct (see #bytecodes). For example, to create a compiled method that compares first instVar to first arg and returns 'yes' or 'no' (same example as in IRBuilder), do: BytecodeGenerator new numArgs: 1; pushInstVar: 1; pushTemp: 1; send: #>; if: false goto: #else; pushLiteral: 'yes'; returnTop; label: #else; pushLiteral: 'no'; returnTop; compiledMethod You can send #ir to the compiledMethod to decompile to its IRMethod, and you can send #methodNode to either to decompile to its parse tree. ! !IRBytecodeGenerator methodsFor: 'results' stamp: 'MarcusDenker 12/20/2012 17:21'! bytecodes | stream | self updateJumpOffsets. stream := (ByteArray new: 100) writeStream. orderSeq do: [ :seqId | (instrMaps at: seqId) do: [ :assoc | assoc key bytecodeIndex: stream position + assoc value "instr" ]. stream nextPutAll: (seqBytes at: seqId) ]. ^ stream contents! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 6/15/2012 14:14'! returnReceiver bytes ifEmpty: [ lastSpecialReturn := Message selector: #returnReceiver]. self nextPut: (Bytecodes at: #returnReceiver). ! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'MarcusDenker 5/18/2013 16:30'! addLastLiteral: object lastLiteral ifNil: [ ^ lastLiteral := object ]. ((lastLiteral literalEqual: object) or: [ "case of metaclass, they have no unique association" (lastLiteral isKindOf: Association) and: [ lastLiteral key isNil ] ]) ifFalse: [ self error: 'there can only be one last literal' ]! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 6/19/2012 10:04'! pushConsArray: size stack push. stack pop: size. (size < 0 or: [size > 127]) ifTrue: [self error: 'The array size is out of range. Should be 0 - 127']. "138 10001010 1kkkkkkk Pop kkkkkkk into: (Array new: kkkkkkk)" self nextPut: (Bytecodes at: #pushConsArray); nextPut: size + 128. ! ! !IRBytecodeGenerator methodsFor: 'initialization' stamp: 'MarcusDenker 6/13/2012 12:55'! initialize literals := OCLiteralList new. "The following dicts are keyed by sequence id given by client in label: (and gotos)." seqOrder := IdentityDictionary new. "seqId -> seq order num" seqBytes := IdentityDictionary new. "seqId -> seq bytecodes" jumps := IdentityDictionary new. "seqId -> last jump instr" instrMaps := IdentityDictionary new. "seqId -> (clientInstr -> bytecode pos)" stacks := IdentityDictionary new. "seqId -> stackCount" primNum := 0. numArgs := 0. currentSeqNum := 0. orderSeq := OrderedCollection new. "reverse map of seqOrder" additionalLiterals := OCLiteralSet new. forceLongForm := false. "starting label in case one is not provided by client" self label: self newDummySeqId. ! ! !IRBytecodeGenerator methodsFor: 'accessing' stamp: 'md 7/10/2005 22:21'! properties: propDict properties := propDict.! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'awe 6/22/2008 12:35'! jump: distance if: condition | hi | distance = 0 ifTrue: [ "jumps to fall through, no-op" ^ self nextPut: (Bytecodes at: #popStackBytecode)]. condition ifTrue: [ hi := distance // 256. hi < 4 ifFalse: [self error: 'true jump too big']. self nextPut: (Bytecodes at: #longJumpIfTrue) first + hi. self nextPut: distance \\ 256. ] ifFalse: [ distance <= 8 ifTrue: [ self nextPut: (Bytecodes at: #shortConditionalJump) first + distance - 1. ] ifFalse: [ hi := distance // 256. hi < 4 ifFalse: [self error: 'false jump too big']. self nextPut: (Bytecodes at: #longJumpIfFalse) first + hi. self nextPut: distance \\ 256. ]. ] ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 7/4/2011 17:45'! pushInstVar: instVarIndex | interval | stack push. interval := Bytecodes at: #pushReceiverVariableBytecode. (instVarIndex <= interval size and: [forceLongForm not]) ifTrue: [ ^ self nextPut: (interval at: instVarIndex). ]. (instVarIndex <= 64 and: [forceLongForm not]) ifTrue: [ self nextPut: (Bytecodes at: #extendedPushBytecode). ^ self nextPut: (0 "instVar" << 6) + instVarIndex - 1. ]. instVarIndex <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 2 "pushInstVar" << 5. self nextPut: instVarIndex - 1. ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 4/14/2010 14:20'! storeTemp: index index <= 64 ifFalse: [self error: 'too many temps (>64)']. self nextPut: (Bytecodes at: #extendedStoreBytecode). self nextPut: (1 "temp" << 6) + index - 1. ! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'JorgeRessia 5/6/2010 14:16'! pragmas: aCollection aCollection do: [:each | self addPragma: each]! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'md 10/4/2005 17:42'! storeIntoLiteralVariable: object | index | index := self addLiteral: object. index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedStoreBytecode). ^ self nextPut: (3 "instVar" << 6) + index - 1. ]. index <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 7 "storeLiteralVar" << 5. self nextPut: index - 1. ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 8/19/2010 11:58'! storeRemoteTemp: tempIndex inVectorAt: tempVectorIndex "141 10001101 kkkkkkkk jjjjjjjj Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" (tempIndex >= 0 and: [tempIndex < 256 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: [self nextPut: (Bytecodes at: #storeRemoteTempInVectorAt); nextPut: tempIndex - 1; nextPut: tempVectorIndex - 1. ^self]. tempIndex >= 256 ifTrue: [^self error: 'remoteTempIndex out of range 0 to 255']. tempVectorIndex >= 256 ifTrue: [^self error: 'tempVectorIndex out of range 0 to 255']! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 7/16/2012 16:06'! label: seqId lastSpecialReturn := nil. currentSeqId := seqId. currentSeqNum := currentSeqNum + 1. seqOrder at: seqId put: currentSeqNum. orderSeq at: currentSeqNum ifAbsentPut: [seqId]. bytes := seqBytes at: seqId ifAbsentPut: [OrderedCollection new]. jumps at: seqId ifAbsentPut: [nil]. instrMap := instrMaps at: seqId ifAbsentPut: [OrderedCollection new]. stack := stacks at: currentSeqId ifAbsentPut: [IRStackCount new] ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'jb 3/31/2010 17:05'! pushThisContext stack push. self nextPut: (Bytecodes at: #pushActiveContextBytecode). ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 4/15/2010 11:28'! pushDup stack push. self nextPut: (Bytecodes at: #duplicateTopBytecode). ! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'MarcusDenker 6/19/2012 13:20'! updateJump: seqId "Recalculate final jump bytecodes. Return true if jump bytecodes SIZE has changed, otherwise return false" | pair s1 | pair := jumps at: seqId. pair ifNil: [^ false]. "no jump, a return" bytes := seqBytes at: seqId. s1 := bytes size. bytes removeLast: (bytes size - pair first). pair last sendTo: self. ^ s1 ~= bytes size.! ! !IRBytecodeGenerator methodsFor: 'accessing' stamp: 'MarcusDenker 7/5/2013 17:01'! properties ^ properties! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 6/15/2012 14:14'! returnTop stack pop. self nextPut: (Bytecodes at: #returnTopFromMethod). ! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:46'! jumpForward: distance distance = 0 ifTrue: [^ self]. "no-op" distance <= 8 ifTrue: [ self nextPut: (Bytecodes at: #shortUnconditionalJump) first + distance - 1. ] ifFalse: [ distance > 1023 ifTrue: [self error: 'forward jump too big']. self nextPut: (Bytecodes at: #longUnconditionalJump) first + (distance // 256) + 4. self nextPut: distance \\ 256. ]. ! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'MarcusDenker 6/12/2012 16:23'! jumpBackward: distance | dist | dist := 1024 - distance - 2. dist < 0 ifTrue: [self error: 'back jump too big']. self nextPut: (Bytecodes at: #longUnconditionalJump) first + (dist // 256). self nextPut: dist \\ 256. ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'JorgeRessia 6/12/2010 09:05'! pushLiteral: object | index interval | stack push. (index := SpecialConstants identityIndexOf: object ifAbsent: 0) > 0 ifTrue: [ ^ self nextPut: (Bytecodes at: #pushConstantTrueBytecode) + index - 1]. (index := literals literalIndexOf: object ifAbsent: 0) > 0 ifFalse: [ index := self addLiteral: object]. interval := Bytecodes at: #pushLiteralConstantBytecode. (index <= interval size) ifTrue: [ ^ self nextPut: (interval at: index) ]. index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedPushBytecode). ^ self nextPut: 2 "lit constant" << 6 + index - 1 ]. index > 256 ifTrue: [self error: 'too many literals (>256)']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 3 "lit constant" << 5. self nextPut: index - 1. ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 4/14/2010 14:20'! storePopTemp: index | interval | stack pop. interval := Bytecodes at: #storeAndPopTemporaryVariableBytecode. index <= interval size ifTrue: [ ^ self nextPut: (interval at: index ) ]. index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedStoreAndPopBytecode). ^ self nextPut: (1 "temp" << 6) + index - 1. ]. self error: 'too many temps (>64)'! ! !IRBytecodeGenerator methodsFor: 'results' stamp: 'MarcusDenker 8/10/2010 12:42'! compiledMethod ^ self compiledMethodWith: CompiledMethodTrailer empty! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'JorgeRessia 5/19/2010 15:19'! popTop stack pop. self nextPut: (Bytecodes at: #popStackBytecode). ! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'ClementBera 9/30/2013 11:20'! updateJumpOffsets [ orderSeq inject: false into: [ :changed :seqId | (self updateJump: seqId) or: [ changed ]] ] whileTrue! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'ms 12/3/2006 20:17'! storePopIntoLiteralVariable: assoc | index | index := self addLiteral: assoc. index <= 64 ifTrue: [ stack pop. self nextPut: (Bytecodes at: #extendedStoreAndPopBytecode). ^ self nextPut: (3 "temp" << 6) + index - 1. ]. index <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 7 "storeLiteralVar" << 5. self nextPut: index - 1. self popTop ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 8/19/2010 11:50'! pushTemp: index | interval | stack push. interval := Bytecodes at: #pushTemporaryVariableBytecode. index <= interval size ifTrue: [ ^ self nextPut: (interval at: index). ]. index <= 64 ifFalse: [self error: 'too many temp vars (>64)']. self nextPut: (Bytecodes at: #extendedPushBytecode). self nextPut: (1 "temp" << 6) + index - 1. ! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'MarcusDenker 6/15/2012 13:36'! from: fromSeqId goto: toSeqId | distance from to | from := seqOrder at: fromSeqId. to := seqOrder at: toSeqId ifAbsent: [^ self]. from + 1 = to ifTrue: [^ self]. "fall through, no jump needed" from < to ifTrue: [ "jump forward" distance := (from + 1 to: to - 1) inject: 0 into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size]. self jumpForward: distance. ] ifFalse: [ "jump backward" distance := ((to to: from - 1) inject: 0 into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size]) + bytes size. self jumpBackward: distance. ]. ! ! !IRBytecodeGenerator methodsFor: 'accessing' stamp: 'ajh 3/13/2003 18:27'! primNum ^ primNum! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 8/19/2010 11:58'! pushRemoteTemp: tempIndex inVectorAt: tempVectorIndex stack push. (tempIndex >= 0 and: [tempIndex < 256 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: ["140 10001100 kkkkkkkk jjjjjjjj Push Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" self nextPut: ( Bytecodes at: #pushRemoteTempInVectorAt); nextPut: tempIndex - 1; nextPut: tempVectorIndex - 1. ^self]. tempIndex >= 256 ifTrue: [^self error: 'remoteTempIndex is out of range 0 to 255']. tempVectorIndex >= 256 ifTrue: [^self error: 'tempVectorIndex is out of range 0 to 255']! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'JorgeRessia 5/19/2010 13:59'! pushReceiver stack push. self nextPut: (Bytecodes at: #pushReceiverBytecode)! ! !IRBytecodeGenerator methodsFor: 'results' stamp: 'MarcusDenker 5/19/2011 14:56'! literals literals := literals asArray. "Put the optimized selectors in literals so as to browse senders more easily" additionalLiterals := additionalLiterals asArray reject: [ :e | literals hasLiteral: e ]. additionalLiterals isEmpty ifFalse: [ "Use one entry per literal if enough room, else make anArray" literals := literals size + additionalLiterals size + 2 > 255 ifTrue: [ literals copyWith: additionalLiterals ] ifFalse: [ literals , additionalLiterals ] ]. (literals anySatisfy: [ :each | each isMethodProperties ]) ifFalse: [ literals := literals copyWith: nil ]. ^ lastLiteral ifNil: [ literals copyWith: nil ] ifNotNil: [ literals copyWith: lastLiteral ]! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 6/19/2012 13:21'! blockReturnTop self nextPut: (Bytecodes at: #returnTopFromBlock). ! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'ClementBera 6/28/2013 14:09'! closureFrom: fromSeqId to: toSeqId copyNumCopiedValues: numCopied numArgs: numArgs2 | distance from to | (numCopied < 0 or: [numCopied > 15]) ifTrue: [^self error: 'too many copied vars']. from := seqOrder at: fromSeqId. to := seqOrder at: toSeqId ifAbsent: [^ self]. "not done yet" distance := (from + 1 to: to -1 ) inject: 0 into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size]. distance > 65535 ifTrue: [self error: 'forward jump too big']. self nextPut: (Bytecodes at: #PushClosureCopyNumCopiedValuesNuumArgsJumpSize); nextPut: numArgs2 + (numCopied bitShift: 4); nextPut: (distance bitShift: -8); nextPut: (distance bitAnd: 16rFF). ! ! !IRBytecodeGenerator methodsFor: 'results' stamp: 'MarcusDenker 7/1/2012 20:55'! quickMethodPrim | index | self numArgs = 0 ifFalse: [^ 0]. lastSpecialReturn ifNil: [^ 0]. (seqBytes size <= 2) ifFalse: [^ 0]. "this is for ruling out the case in which the structure is the same as a quick return but with and invalid special literal." ((literals size = 1) and: [ (SpecialConstants identityIncludes: literals first) not and: [ lastSpecialReturn selector = #returnConstant: ] ] ) ifTrue: [^ 0]. lastSpecialReturn selector == #returnReceiver ifTrue: [^256]. lastSpecialReturn selector == #returnConstant: ifTrue: [^(index := SpecialConstants indexOf: lastSpecialReturn argument) > 0 ifTrue: [256 + index] ifFalse: [0]]. lastSpecialReturn selector == #returnInstVar: ifTrue: [^forceLongForm ifTrue: [0] "when compiling long bytecodes for Contexts, do not do quick return either" ifFalse: [263 + lastSpecialReturn argument]] ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'ClementBera 7/26/2013 15:48'! returnConstant: constant bytes ifEmpty: [ lastSpecialReturn := Message selector: #returnConstant: argument: constant ]. constant == true ifTrue: [ ^ self nextPut: (Bytecodes at: #returnTrue) ]. constant == false ifTrue: [ ^ self nextPut: (Bytecodes at: #returnFalse) ]. constant ifNil: [ ^ self nextPut: (Bytecodes at: #returnNil) ]. self pushLiteral: constant. self returnTop! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'JorgeRessia 5/7/2010 12:20'! addLiteral: object literals add: object. ^ literals identityIndexOf: object! ! !IRBytecodeGenerator methodsFor: 'mapping' stamp: 'MarcusDenker 12/20/2012 17:23'! mapBytesTo: instr "Associate the current byte offset with instr. We fix this later to have the correct offset, see #bytecodes" instrMap add: instr -> bytes size! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 7/4/2011 16:52'! storeInstVar: index (index <= 64 and: [forceLongForm not]) ifTrue: [ self nextPut: (Bytecodes at: #extendedStoreBytecode). ^ self nextPut: (0 "instVar" << 6) + index - 1. ]. index <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 5 "storeInstVar" << 5. self nextPut: index - 1. ! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'MarcusDenker 6/13/2012 13:13'! from: fromSeqId if: bool goto: toSeqId otherwise: otherwiseSeqId | distance from to otherwise | from := seqOrder at: fromSeqId. to := seqOrder at: toSeqId ifAbsent: [^ self jump: 0 if: bool]. "not done yet" otherwise := seqOrder at: otherwiseSeqId ifAbsent: [^ self jump: 0 if: bool]. "not done yet" from < to ifFalse: [self error]. from + 1 = otherwise ifFalse: [self error]. distance := (from + 1 to: to - 1) inject: 0 into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size]. self jump: distance if: bool. ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 13:26'! if: bool goto: seqId | otherwiseSeqId | otherwiseSeqId := self newDummySeqId. self if: bool goto: seqId otherwise: otherwiseSeqId. self label: otherwiseSeqId. ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'md 2/27/2006 17:03'! send: selector toSuperOf: behavior | index nArgs | nArgs := selector numArgs. stack pop: nArgs. self addLastLiteral: behavior binding. index := self addLiteral: selector. (index <= 32 and: [nArgs <= 7]) ifTrue: [ "extended (2-byte) send" self nextPut: (Bytecodes at: #singleExtendedSuperBytecode). ^ self nextPut: nArgs * 32 + index - 1 ]. "long (3-byte) send" self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 1 << 5 "super" + nArgs. self nextPut: index - 1. ! ! !IRBytecodeGenerator methodsFor: 'results' stamp: 'MarcusDenker 5/23/2013 08:40'! compiledMethodWith: trailer | cm | cm := (CompiledMethod primitive: (self primNum > 0 ifTrue: [self primNum] ifFalse: [self quickMethodPrim]) numArgs: self numArgs numTemps: self numTemps stackSize: self stackFrameSize literals: self literals bytecodes: self bytecodes trailer: trailer). "set the properties of cm according to properties saved" properties ifNotNil: [ cm penultimateLiteral: properties. properties method: cm. properties pragmas do: [:each | each method: cm]. ]. ^cm.! ! !IRBytecodeGenerator methodsFor: 'initialize' stamp: 'MarcusDenker 5/15/2013 08:27'! irPrimitive: anIrPrimitive literals isEmpty ifFalse: [self error: 'init prim before adding instructions']. anIrPrimitive spec ifNotNil: [literals add: anIrPrimitive spec]. primNum := anIrPrimitive num. ! ! !IRBytecodeGenerator methodsFor: 'accessing' stamp: 'MarcusDenker 5/13/2011 13:45'! additionalLiterals: aSet additionalLiterals := aSet. ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 6/13/2012 13:11'! goto: seqId stacks at: seqId put: (stack linkTo: (stacks at: seqId ifAbsentPut: [nil])). self saveLastJump: (Message selector: #from:goto: arguments: {currentSeqId. seqId}). self from: currentSeqId goto: seqId. ! ! !IRBytecodeGenerator methodsFor: 'accessing' stamp: 'MarcusDenker 4/14/2010 15:33'! numTemps: anInteger numberOfTemps := anInteger! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'jorgeRessia 11/3/2009 16:33'! pushNewArray: size stack push. (size < 0 or: [size > 127]) ifTrue: [self error: 'The array size is out of range. Should be 0 - 127']. "138 10001010 0kkkkkkk Push kkkkkkk into: (Array new: kkkkkkk)" self nextPut: (Bytecodes at: #pushConsArray); nextPut: size. ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 6/19/2012 13:21'! returnInstVar: index bytes ifEmpty: [ lastSpecialReturn := Message selector: #returnInstVar: argument: index]. self pushInstVar: index. self returnTop. ! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/13/2003 13:00'! nextPut: byte bytes add: byte! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 11/11/2011 16:47'! storePopInstVar: index | interval | stack pop. interval := Bytecodes at: #storeAndPopReceiverVariableBytecode. (index <= interval size and: [forceLongForm not]) ifTrue: [ ^ self nextPut: (interval at: index) ]. (index <= 64 and: [forceLongForm not]) ifTrue: [ self nextPut: (Bytecodes at: #extendedStoreAndPopBytecode). ^ self nextPut: (0 "instVar" << 6) + index - 1. ]. index <= 256 ifFalse: [ self error: 'can''t reference more than 256 inst vars']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 6 "storePopInstVar" << 5. self nextPut: index - 1. ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 6/13/2012 13:04'! if: bool goto: seqId1 otherwise: seqId2 stack pop. stacks at: seqId1 put: (stack linkTo: (stacks at: seqId1 ifAbsentPut: [nil])). stacks at: seqId2 put: (stack linkTo: (stacks at: seqId2 ifAbsentPut: [nil])). self saveLastJump: (Message selector: #from:if:goto:otherwise: arguments: {currentSeqId. bool. seqId1. seqId2}). self from: currentSeqId if: bool goto: seqId1 otherwise: seqId2.! ! !IRBytecodeGenerator methodsFor: 'accessing' stamp: 'MarcusDenker 7/4/2011 16:41'! forceLongForm: aBoolean forceLongForm := aBoolean! ! !IRBytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 3/13/2003 18:21'! numArgs: n numArgs := n! ! !IRBytecodeGenerator methodsFor: 'results' stamp: 'MarcusDenker 6/13/2012 11:33'! stackFrameSize ^ (stacks collect: [:s | s length]) max! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'MarcusDenker 6/15/2012 13:42'! saveLastJump: message jumps at: currentSeqId put: {bytes size. message}. ! ! !IRBytecodeGenerator methodsFor: 'accessing' stamp: 'ajh 3/13/2003 18:27'! numArgs ^ numArgs! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 6/19/2012 15:25'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs2 to: toSeqId | blockSeqId | blockSeqId := self newDummySeqId. stack pop: numCopied. stacks at: blockSeqId put: (stack linkTo: (stacks at: blockSeqId ifAbsentPut: [nil])). stack push. stacks at: toSeqId put: (stack linkTo: (stacks at: toSeqId ifAbsentPut: [nil])). self saveLastJump: (Message selector: #closureFrom:to:copyNumCopiedValues:numArgs: arguments: {currentSeqId.toSeqId. numCopied. numArgs2.}). self closureFrom: currentSeqId to: toSeqId copyNumCopiedValues: numCopied numArgs: numArgs2. self label: blockSeqId. ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'MarcusDenker 8/19/2010 11:58'! storePopRemoteTemp: tempIndex inVectorAt: tempVectorIndex stack pop. "142 10001110 kkkkkkkk jjjjjjjj Pop and Store Temp At kkkkkkkk In Temp Vector At: jjjjjjjj" (tempIndex >= 0 and: [tempIndex < 256 and: [tempVectorIndex >= 0 and: [tempVectorIndex < 256]]]) ifTrue: [self nextPut: ( Bytecodes at: #storePopRemoteTempInVectorAt); nextPut: tempIndex -1; nextPut: tempVectorIndex - 1. ^self]. tempIndex >= 256 ifTrue: [^self error: 'remoteTempIndex out of range 0 to 255']. tempVectorIndex >= 256 ifTrue: [^self error: 'tempVectorIndex out of range range 0 to 255']! ! !IRBytecodeGenerator methodsFor: 'accessing' stamp: 'JorgeRessia 4/14/2010 11:42'! numTemps ^ numberOfTemps! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'kwl 6/25/2006 19:58'! pushLiteralVariable: object | index interval | stack push. object isVariableBinding ifFalse: [self error: 'not a literal variable']. (index := literals literalIndexOf: object ifAbsent: 0) > 0 ifFalse: [ index := self addLiteral: object]. interval := Bytecodes at: #pushLiteralVariableBytecode. (index <= interval size) ifTrue: [ ^ self nextPut: (interval at: index) ]. index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedPushBytecode). ^ self nextPut: 3 "literal variable" << 6 + index - 1 ]. index > 256 ifTrue: [self error: 'too many literals (>256)']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 1 "lit variable" << 7. self nextPut: index - 1. ! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:28'! newDummySeqId ^ Object new! ! !IRBytecodeGenerator methodsFor: 'private' stamp: 'MarcusDenker 7/5/2013 17:04'! addPragma: aPragma properties ifNil: [ properties := AdditionalMethodState new ]. properties := properties copyWith: aPragma. ! ! !IRBytecodeGenerator methodsFor: 'instructions' stamp: 'JorgeRessia 5/19/2010 14:58'! send: selector | index nArgs | nArgs := selector numArgs. stack pop: nArgs. SpecialSelectors at: selector ifPresent: [:i | ^ self nextPut: (Bytecodes at: #bytecodePrimAdd) + i]. index := self addLiteral: selector. (index <= 16 and: [nArgs <= 2]) ifTrue: [ "short send" ^ self nextPut: (Bytecodes at: #sendLiteralSelectorBytecode) first + (nArgs * 16) + index - 1 ]. (index <= 32 and: [nArgs <= 7]) ifTrue: [ "extended (2-byte) send" self nextPut: (Bytecodes at: #singleExtendedSendBytecode). ^ self nextPut: nArgs * 32 + index - 1 ]. (index <= 64 and: [nArgs <= 3]) ifTrue: [ "new extended (2-byte)" self nextPut: (Bytecodes at: #secondExtendedSendBytecode). ^ self nextPut: nArgs * 64 + index - 1 ]. "long (3-byte) send" self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: nArgs. self nextPut: index - 1. ! ! !IRBytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:40'! initialize self initializeBytecodeTable. self initializeSpecialSelectors. self initializeSpecialConstants. ! ! !IRBytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:40'! initializeSpecialSelectors "Create a map from specialSelector -> bytecode offset from sendAdd (the first one)" | array | SpecialSelectors := IdentityDictionary new. array := self specialSelectorsArray. "Smalltalk specialObjectsArray at: 24" 1 to: array size by: 2 "skip numArgs" do: [:i | SpecialSelectors at: (array at: i) put: i - 1 / 2]. ! ! !IRBytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:45'! initializeSpecialConstants SpecialConstants := {true. false. nil. -1. 0. 1. 2}! ! !IRBytecodeGenerator class methodsFor: 'initialize' stamp: 'MarcusDenker 11/11/2011 15:52'! specialSelectorsArray ^ #(#+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1 #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1 #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 nil 0 #blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0)! ! !IRBytecodeGenerator class methodsFor: 'initialize' stamp: 'MarcusDenker 8/12/2010 13:15'! bytecodeTableFrom: specArray "SpecArray is an array of either (index selector) or (index1 index2 selector)." | contiguous | Bytecodes := IdentityDictionary new: 256. BytecodeTable := Array new: 256. contiguous := 0. specArray do: [ :spec | (spec first) = contiguous ifFalse: [self error: 'Non-contiguous table entry']. spec size = 2 ifTrue: [ Bytecodes at: (spec second) put: (spec first). BytecodeTable at: (spec first) + 1 put: (spec second). contiguous := contiguous + 1. ] ifFalse: [ spec size = 3 ifFalse: [self error: 'bad spec size']. Bytecodes at: spec third put: (spec first to: spec second). spec first to: spec second do: [ :i | BytecodeTable at: i + 1 put: spec third. ]. contiguous := contiguous + spec second - spec first + 1. ]. ]. ^ BytecodeTable! ! !IRBytecodeGenerator class methodsFor: 'initialize' stamp: 'MarcusDenker 11/11/2011 15:52'! initializeBytecodeTable "OCBytecodeGenerator initialize" "Defines all the bytecode instructions for the Compiler and the Interpreter. The following bytecode tuple format is: #(bytecode bytecodeSelector) bytecodeSelector is the method in the Interpreter that gets executed for the given bytecode. Common Send selector position within the specialSelectorsArray is hard code in the Interpreter, see senders of Interpreter specialSelector:." ^ self bytecodeTableFrom: #( ( 0 15 pushReceiverVariableBytecode) ( 16 31 pushTemporaryVariableBytecode) ( 32 63 pushLiteralConstantBytecode) ( 64 95 pushLiteralVariableBytecode) ( 96 103 storeAndPopReceiverVariableBytecode) (104 111 storeAndPopTemporaryVariableBytecode) (112 pushReceiverBytecode) (113 pushConstantTrueBytecode) (114 pushConstantFalseBytecode) (115 pushConstantNilBytecode) (116 pushConstantMinusOneBytecode) (117 pushConstantZeroBytecode) (118 pushConstantOneBytecode) (119 pushConstantTwoBytecode) (120 returnReceiver) (121 returnTrue) (122 returnFalse) (123 returnNil) (124 returnTopFromMethod) (125 returnTopFromBlock) (126 unknownBytecode) (127 unknownBytecode) (128 extendedPushBytecode) (129 extendedStoreBytecode) (130 extendedStoreAndPopBytecode) (131 singleExtendedSendBytecode) (132 doubleExtendedDoAnythingBytecode) (133 singleExtendedSuperBytecode) (134 secondExtendedSendBytecode) (135 popStackBytecode) (136 duplicateTopBytecode) (137 pushActiveContextBytecode) "(138 143 experimentalBytecode)" (138 pushConsArray) (139 experimentalBytecode) (140 pushRemoteTempInVectorAt) (141 storeRemoteTempInVectorAt) (142 storePopRemoteTempInVectorAt) (143 PushClosureCopyNumCopiedValuesNuumArgsJumpSize) (144 151 shortUnconditionalJump) (152 159 shortConditionalJump) (160 167 longUnconditionalJump) (168 171 longJumpIfTrue) (172 175 longJumpIfFalse) "176-191 were sendArithmeticSelectorBytecode" (176 bytecodePrimAdd) (177 bytecodePrimSubtract) (178 bytecodePrimLessThan) (179 bytecodePrimGreaterThan) (180 bytecodePrimLessOrEqual) (181 bytecodePrimGreaterOrEqual) (182 bytecodePrimEqual) (183 bytecodePrimNotEqual) (184 bytecodePrimMultiply) (185 bytecodePrimDivide) (186 bytecodePrimMod) (187 bytecodePrimMakePoint) (188 bytecodePrimBitShift) (189 bytecodePrimDiv) (190 bytecodePrimBitAnd) (191 bytecodePrimBitOr) "192-207 were sendCommonSelectorBytecode" (192 bytecodePrimAt) (193 bytecodePrimAtPut) (194 bytecodePrimSize) (195 bytecodePrimNext) (196 bytecodePrimNextPut) (197 bytecodePrimAtEnd) (198 bytecodePrimEquivalent) (199 bytecodePrimClass) (200 bytecodePrimBlockCopy) (201 bytecodePrimValue) (202 bytecodePrimValueWithArg) (203 bytecodePrimDo) (204 bytecodePrimNew) (205 bytecodePrimNewWithArg) (206 bytecodePrimPointX) (207 bytecodePrimPointY) (208 255 sendLiteralSelectorBytecode) ) ! ! !IRBytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/15/2003 15:43'! specialConstants ^ SpecialConstants! ! !IRBytecodeScope commentStamp: ''! I am an internal class used by the decompiler to recreat variable information! !IRBytecodeScope methodsFor: 'accessing' stamp: 'ToonVerwaest 3/27/2011 14:55'! ownTempVectors ^ ownTempVectors! ! !IRBytecodeScope methodsFor: 'accessing' stamp: 'ToonVerwaest 3/27/2011 16:21'! tempAt: zeroBasedIndex temps := temps max: zeroBasedIndex + 1. ^ self -> zeroBasedIndex! ! !IRBytecodeScope methodsFor: 'initialization' stamp: 'ToonVerwaest 3/27/2011 14:49'! initialize temps := 0. ownTempVectors := OrderedCollection new! ! !IRBytecodeScope methodsFor: 'accessing' stamp: 'ToonVerwaest 3/31/2011 14:59'! temps | result tempOffset numTemps | tempOffset := copiedValues size + numArgs. numTemps := temps - tempOffset. result := Array new: numTemps. tempOffset := tempOffset - 1. 1 to: numTemps do: [ :idx | result at: idx put: self -> (tempOffset + idx) ]. ownTempVectors do: [ :tempVector | result at: tempVector index - tempOffset put: tempVector ]. ^ result! ! !IRBytecodeScope methodsFor: 'accessing' stamp: 'ToonVerwaest 3/27/2011 13:08'! numArgs ^ numArgs! ! !IRBytecodeScope methodsFor: 'accessing' stamp: 'ToonVerwaest 3/27/2011 13:43'! args | args | args := Array new: numArgs. 1 to: numArgs do: [ :idx | args at: idx put: self -> (idx - 1)]. ^ args! ! !IRBytecodeScope methodsFor: 'accessing' stamp: 'ToonVerwaest 3/27/2011 12:37'! tempAt: remoteIndex inRemote: remoteArray ^ remoteIndex! ! !IRBytecodeScope methodsFor: 'accessing' stamp: 'ToonVerwaest 3/27/2011 14:48'! copiedValues: someCopiedValues copiedValues := someCopiedValues! ! !IRBytecodeScope methodsFor: 'accessing' stamp: 'ToonVerwaest 3/27/2011 14:52'! copiedValues ^ copiedValues! ! !IRBytecodeScope methodsFor: 'accessing' stamp: 'ToonVerwaest 3/27/2011 13:45'! numArgs: anInteger numArgs := anInteger. temps := temps max: numArgs! ! !IRBytecodeScope methodsFor: 'accessing' stamp: 'ToonVerwaest 3/27/2011 14:51'! newTempVector: aTempVector at: offset ownTempVectors add: aTempVector. self tempAt: offset! ! !IRInstVarAccess commentStamp: ''! I am a bytecode accessing an instance variable. As such, I have an index.! !IRInstVarAccess methodsFor: 'interpret' stamp: 'MarcusDenker 11/21/2012 16:00'! executeOn: interpreter store ifFalse: [interpreter pushInstVar: index ] ifTrue: [interpreter storeInstVar: index ] ! ! !IRInstVarAccess methodsFor: 'testing' stamp: 'md 6/13/2005 11:10'! isInstVarAccess ^true.! ! !IRInstVarAccess methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:25'! accept: aVisitor ^ aVisitor visitInstVarAccess: self! ! !IRInstVarAccess methodsFor: 'accessing' stamp: 'MarcusDenker 11/21/2012 16:00'! index: anInteger index := anInteger.! ! !IRInstVarAccess methodsFor: 'accessing' stamp: 'MarcusDenker 11/21/2012 16:00'! index ^index! ! !IRInstruction commentStamp: ''! I am an instruction in the IR (intermediate representation) language. The IR serves as the intermediary between the Smalltalk language and the bytecode language. It is easier to optimize and translate to/from this language than it is to optimize/translate directly from Smalltalk to bytecodes. The IR is generic and simple consisting of just twelve instructions. They are: goto: labelNum if: boolean goto: labelNum1 otherwise: labelNum2 label: labelNum popTop pushDup pushLiteral: object pushTemp: name blockReturn returnTop send: selector send: selector toSuperOf: behavior storeTemp: name Each instruction is reified as an instance of one of my subclasses and grouped by basic block (IRSequence) into an IRMethod. IRInterpreter visits each instruction in a IRMethod responding to the above instruction messages sent to it. ! !IRInstruction methodsFor: 'adding' stamp: 'md 7/9/2005 22:41'! addInstructionsBefore: aCollection sequence addInstructions: aCollection before: self.! ! !IRInstruction methodsFor: 'testing' stamp: 'md 2/26/2005 16:22'! isSelf ^false! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 12/19/2012 08:07'! isBlockReturnTop ^false ! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 12/19/2012 08:07'! isReturn ^ false ! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 9/20/2013 13:26'! isPushLiteral: valueTest ^ false! ! !IRInstruction methodsFor: 'adding' stamp: 'md 7/9/2005 22:41'! addInstructionsAfter: aCollection sequence addInstructions: aCollection after: self.! ! !IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:07'! bytecodeIndex ^ bytecodeIndex! ! !IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:14'! bytecodeIndex: index bytecodeIndex := index! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 12/14/2012 11:52'! isIf ^ false ! ! !IRInstruction methodsFor: 'replacing' stamp: 'ClementBera 7/26/2013 15:48'! replaceWith: aNode sequence ifNil: [self error: 'This node doesn''t have a sequence']. sequence replaceNode: self withNode: aNode! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 8/13/2010 14:25'! isRead ^false! ! !IRInstruction methodsFor: 'replacing' stamp: 'ClementBera 7/26/2013 15:48'! replaceWithInstructions: aCollection sequence ifNil: [self error: 'This node doesn''t have a sequence']. sequence replaceNode: self withNodes: aCollection! ! !IRInstruction methodsFor: 'visiting' stamp: 'MarcusDenker 12/14/2012 11:52'! accept: aVisitor aVisitor visit: self ! ! !IRInstruction methodsFor: 'testing' stamp: 'md 2/22/2005 11:28'! isTemp ^false! ! !IRInstruction methodsFor: 'testing' stamp: ''! isPushClosureCopy ^false! ! !IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/6/2003 14:32'! sourceNode ^ sourceNode ! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 12/19/2012 08:05'! isGoto "is unconditional jump" ^ false ! ! !IRInstruction methodsFor: 'accessing' stamp: 'md 7/9/2005 22:38'! sequence ^sequence! ! !IRInstruction methodsFor: 'testing' stamp: 'md 10/4/2005 16:52'! isLiteralVariable ^false! ! !IRInstruction methodsFor: 'accessing' stamp: 'md 7/9/2005 22:42'! method ^sequence method.! ! !IRInstruction methodsFor: 'replacing' stamp: 'md 10/11/2004 15:56'! replaceNode: aNode withNode: anotherNode self error: 'I don''t store other nodes'! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 12/19/2012 08:05'! isSend ^false.! ! !IRInstruction methodsFor: 'accessing' stamp: 'MarcusDenker 8/8/2011 13:29'! nonBodySuccessorSequences ^self successorSequences! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 8/13/2010 14:26'! isStore ^false! ! !IRInstruction methodsFor: 'mapping' stamp: 'md 9/1/2005 21:18'! bytecodeOffset | startpc | startpc := self method compiledMethod initialPC. self bytecodeIndex ifNil: [^startpc]. ^self bytecodeIndex + startpc - 1.! ! !IRInstruction methodsFor: 'interpret' stamp: ''! executeOn: interpreter "Send approriate message to interpreter" self subclassResponsibility! ! !IRInstruction methodsFor: 'replacing' stamp: 'ClementBera 7/26/2013 15:48'! delete sequence ifNil: [self error: 'This node doesn''t have a sequence']. sequence remove: self.! ! !IRInstruction methodsFor: 'accessing' stamp: 'md 7/9/2005 22:39'! sequence: aSeq sequence := aSeq! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 12/14/2012 11:51'! isTempVector ^false! ! !IRInstruction methodsFor: 'mapping' stamp: 'ajh 3/6/2003 14:32'! sourceNode: parseNode sourceNode := parseNode ! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 9/20/2013 15:14'! isPushLiteral ^false! ! !IRInstruction methodsFor: 'testing' stamp: 'ajh 3/10/2003 16:13'! isJumpOrReturn ^ self isJump or: [self isReturn]! ! !IRInstruction methodsFor: 'accessing' stamp: 'MarcusDenker 12/14/2012 11:51'! successorSequences "sent to last instruction in sequence which is expected to be a jump and return instruction" ^ #()! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 12/19/2012 08:07'! isJump "goto or if" ^false ! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 8/18/2010 20:11'! isInstVarAccess ^false.! ! !IRInstruction methodsFor: 'testing' stamp: 'MarcusDenker 12/14/2012 11:52'! isPop ^ false! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/13/2010 13:43'! pushDup ^ IRPushDup new! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'JorgeRessia 5/6/2010 16:33'! blockReturnTop ^ IRBlockReturnTop new ! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/19/2010 15:03'! pushNewArray: aSize ^IRPushArray new size: aSize; cons: false; yourself.! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/27/2010 13:28'! pushClosureCopyCopiedValues: copiedValues args: arguments ^IRPushClosureCopy new copiedValues: copiedValues; arguments: arguments; yourself.! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 4/15/2010 15:22'! returnTop ^ IRReturn new! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/13/2010 13:23'! pushLiteral: object ^ IRPushLiteral new literal: object! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 11/21/2012 16:01'! storeInstVar: index ^ IRInstVarAccess new index: index; store: true; yourself. ! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'jorgeRessia 10/11/2009 19:44'! popTop ^ IRPop new! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/19/2010 15:03'! pushConsArray: aSize ^IRPushArray new size: aSize; cons: true; yourself.! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/12/2010 14:31'! send: selector toSuperOf: behavior behavior ifNil: [self error: 'super of nil does not exist']. ^ IRSend new selector: selector; superOf: behavior; yourself.! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 11/21/2012 16:01'! pushInstVar: index ^ IRInstVarAccess new index: index; store: false; yourself! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/19/2010 15:33'! pushTemp: aName aName = 'self' ifTrue: [self error: 'use pushReceiver']. ^ IRTempAccess new name: aName; store: false; yourself! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/19/2010 15:33'! storeTemp: aName ^ IRTempAccess new name: aName; store: true; yourself ! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/19/2010 15:33'! pushLiteralVariable: object ^ IRLiteralVariableAccess new association: object; store: false; yourself ! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/18/2010 15:32'! pushRemoteTemp: aName inVectorAt: nameOfVector ^ IRRemoteTempAccess new name: aName; tempVectorName: nameOfVector; store: false; yourself.! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/19/2010 15:33'! storeIntoLiteralVariable: object ^ IRLiteralVariableAccess new association: object; store: true; yourself! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/19/2010 08:21'! createTempVectorNamed: aTempVectorName withVars: anArray ^ IRTempVector new name: aTempVectorName; vars: anArray; yourself.! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'JorgeRessia 4/29/2010 17:07'! pushReceiver ^IRReceiverAccess new! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/18/2010 15:31'! storeRemoteTemp: aName inVectorAt: nameOfVector ^ IRRemoteTempAccess new name: aName; tempVectorName: nameOfVector; store: true; yourself.! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'ajh 3/10/2003 01:08'! send: selector ^ IRSend new selector: selector! ! !IRInstruction class methodsFor: 'instance creation' stamp: 'JorgeRessia 4/29/2010 17:16'! pushThisContext ^IRThisContextAccess new! ! !IRInterpreter commentStamp: 'ajh 3/24/2003 23:55'! I visit each IRInstruction in an IRMethod in order. Each instruction sends its instruction message to me upon being visited. See my 'instructions' method category for complete list of instructions. Subclasses should override them.! !IRInterpreter methodsFor: 'instructions' stamp: 'MarcusDenker 12/14/2012 11:52'! blockReturnTop! ! !IRInterpreter methodsFor: 'interpret' stamp: ''! interpretInstruction: irInstruction irInstruction executeOn: self ! ! !IRInterpreter methodsFor: 'interpret' stamp: ''! interpret: anIr self interpretAll: anIr allSequences! ! !IRInterpreter methodsFor: 'instructions' stamp: 'ClementBera 2/28/2014 10:23'! storeInstVar: index ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! pushConsArray: aSize! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! send: selector toSuperOf: behavior ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! pushInstVar: aSmallInteger ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! storeTemp: index ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! pushRemoteTemp: name inVector: tempVectorName! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! storeIntoLiteralVariable: index ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! label: seqNum! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! pushNewArray: size! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! pushThisContext! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! pushDup ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! goto: seqNum ! ! !IRInterpreter methodsFor: 'interpret' stamp: ''! interpretAll: irSequences irSequences do: [:seq | self interpretSequence: seq] ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! returnTop! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! if: bool goto: seqNum1 otherwise: seqNum2! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! pushLiteral: object ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! popTop! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! pushClosureCopyCopiedValues: copiedValues args: args jumpTo: labelSymbol ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! pushTemp: index ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! pushLiteralVariable: object ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! storeRemoteTemp: name inVector: tempVectorName! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! pushReceiver ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! createTempVectorNamed: name withVars: vars! ! !IRInterpreter methodsFor: 'interpret' stamp: 'jorgeRessia 11/3/2009 16:40'! interpretSequence: instructionSequence self label: instructionSequence orderNumber. instructionSequence do: [:instr | self interpretInstruction: instr]. ! ! !IRInterpreter methodsFor: 'instructions' stamp: ''! send: selector ! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testReturnTop | ir | ir := IRBuilderTest new testReturnTop. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testInstVar | ir | ir := IRBuilderTest new testInstVar. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testJumpBackTo | ir | ir := IRBuilderTest new testJumpBackTo. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testJumpAheadTo | ir | ir := IRBuilderTest new testJumpAheadTo. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testLiteralVariableClass | ir | ir := IRBuilderTest new testLiteralVariableClass. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testDup | ir | ir := IRBuilderTest new testDup. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPushConsArray | ir | ir := IRBuilderTest new testPushConsArray. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPushClosureCopyNoCopied | ir | ir := IRBuilderTest new testPushClosureCopyNoCopied. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPushSelf | ir | ir := IRBuilderTest new testPushSelf. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPushNewArray | ir | ir := IRBuilderTest new testPushNewArray. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testRemoteTempNested | ir | ir := IRBuilderTest new testRemoteTempNested. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testRemoteTemp | ir | ir := IRBuilderTest new testRemoteTemp. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPushTempTemp | ir | ir := IRBuilderTest new testPushTempTemp. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPushThisContext | ir | ir := IRBuilderTest new testPushThisContext. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testSendSuper | ir | ir := IRBuilderTest new testSendSuper. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPushTempArgument | ir | ir := IRBuilderTest new testPushTempArgument. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testStoreTemp | ir | ir := IRBuilderTest new testStoreTemp. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testLiteralArray | ir | ir := IRBuilderTest new testLiteralArray. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testStoreIntoVariable | ir | ir := IRBuilderTest new testStoreIntoVariable. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testJumpAheadToIf | ir | ir := IRBuilderTest new testJumpAheadToIf. IRInterpreter new interpret: ir! ! !IRInterpreterTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPopTop | ir | ir := IRBuilderTest new testPopTop. IRInterpreter new interpret: ir! ! !IRJump commentStamp: 'ajh 3/24/2003 23:56'! Instruction "goto: labelNum"! !IRJump methodsFor: 'interpret' stamp: 'MarcusDenker 12/14/2012 11:51'! executeOn: interpreter ^ interpreter goto: destination orderNumber! ! !IRJump methodsFor: 'accessing' stamp: 'MarcusDenker 4/23/2013 15:48'! successor ^successor! ! !IRJump methodsFor: 'visiting' stamp: 'MarcusDenker 12/14/2012 11:51'! accept: aVisitor ^ aVisitor visitJump: self! ! !IRJump methodsFor: 'accessing' stamp: 'MarcusDenker 6/19/2012 13:57'! successorSequences ^ {destination. successor} ! ! !IRJump methodsFor: 'testing' stamp: 'ajh 3/11/2003 00:22'! isJump "goto or if" ^ true! ! !IRJump methodsFor: 'accessing' stamp: 'ajh 3/10/2003 23:08'! destination ^ destination! ! !IRJump methodsFor: 'accessing' stamp: 'JorgeRessia 5/19/2010 11:17'! destination: aSequence destination := aSequence! ! !IRJump methodsFor: 'testing' stamp: 'MarcusDenker 12/14/2012 11:51'! isGoto "is unconditional jump" ^ true! ! !IRJump methodsFor: 'accessing' stamp: 'MarcusDenker 6/19/2012 13:18'! successor: succ successor := succ! ! !IRJumpIf commentStamp: 'ajh 3/24/2003 23:56'! Instruction "if: boolean goto: labelNum1 otherwise: labelNum2"! !IRJumpIf methodsFor: 'acessing' stamp: 'ajh 3/10/2003 00:43'! boolean: bool boolean := bool! ! !IRJumpIf methodsFor: 'interpret' stamp: 'ajh 3/10/2003 00:47'! executeOn: interpreter ^ interpreter if: boolean goto: destination orderNumber otherwise: otherwise orderNumber! ! !IRJumpIf methodsFor: 'acessing' stamp: 'pmm 2/2/2007 18:05'! otherwise: aSequence otherwise := aSequence! ! !IRJumpIf methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:24'! accept: aVisitor ^ aVisitor visitJumpIf: self! ! !IRJumpIf methodsFor: 'acessing' stamp: 'ajh 3/10/2003 00:43'! boolean ^ boolean! ! !IRJumpIf methodsFor: 'acessing' stamp: 'ajh 3/11/2003 00:02'! successorSequences ^ {destination. otherwise}! ! !IRJumpIf methodsFor: 'acessing' stamp: 'ajh 3/10/2003 00:43'! otherwise ^ otherwise! ! !IRJumpIf methodsFor: 'acessing' stamp: 'MarcusDenker 4/23/2013 16:53'! nextBytecodeOffsetAfterJump "check if we are in ifTrue:ifFalse: / ifFalse:ifTrue: or in ifTrue: / ifFalse: and answers the next byte code offset" ^destination last isJump ifTrue: [ destination last destination first bytecodeOffset ] ifFalse: [ self flag: #FIXME. "it does not work in case of multiple byte code instruction in the optimized block" (destination sequence at: (destination size - 1)) bytecodeOffset ]! ! !IRJumpIf methodsFor: 'testing' stamp: 'ajh 3/11/2003 00:21'! isIf ^ true! ! !IRJumpIf methodsFor: 'acessing' stamp: 'MarcusDenker 8/8/2011 13:30'! nonBodySuccessorSequences ^ {destination}! ! !IRJumpIf methodsFor: 'testing' stamp: 'ajh 3/11/2003 00:19'! isGoto "is unconditional jump" ^ false! ! !IRLiteralVariableAccess commentStamp: ''! LiteralVariables are -> Globals -> Pool access -> Class Var access! !IRLiteralVariableAccess methodsFor: 'interpret' stamp: 'MarcusDenker 8/13/2010 14:06'! executeOn: interpreter store ifFalse: [interpreter pushLiteralVariable: association] ifTrue: [interpreter storeIntoLiteralVariable: association] ! ! !IRLiteralVariableAccess methodsFor: 'testing' stamp: 'md 10/4/2005 16:45'! isLiteralVariable ^true! ! !IRLiteralVariableAccess methodsFor: 'accessing' stamp: 'md 7/9/2005 21:14'! association: anAssociation association := anAssociation! ! !IRLiteralVariableAccess methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:25'! accept: aVisitor ^ aVisitor visitLiteralVariableAccess: self! ! !IRLiteralVariableAccess methodsFor: 'accessing' stamp: 'MarcusDenker 6/6/2012 12:33'! association ^association! ! !IRLiteralVariableAccess methodsFor: 'accessing' stamp: 'MarcusDenker 8/4/2011 14:05'! name ^association key! ! !IRMethod commentStamp: 'ajh 5/23/2003 11:08'! I am a method in the IR (intermediate representation) language consisting of IRInstructions grouped by IRSequence (basic block). The IRSequences form a control graph (therefore I only have to hold onto the starting sequence). #compiledMethod will convert me to a CompiledMethod. #methodNode will convert me back to a parse tree. ! !IRMethod methodsFor: 'enumerating' stamp: 'jb 3/29/2010 18:04'! allSequences ^ startSequence withAllSuccessors! ! !IRMethod methodsFor: 'enumerating' stamp: 'md 6/10/2005 16:07'! allInstructions " return irNodes as a flat collection " | irInstructions | irInstructions := OrderedCollection new. startSequence withAllSuccessorsDo: [:seq | seq do: [:bc | irInstructions add: bc]]. ^irInstructions! ! !IRMethod methodsFor: 'inlining' stamp: 'md 7/14/2005 12:31'! addInstructionsBefore: aCollection (self startSequence nextSequence first) addInstructionsBefore: aCollection. ! ! !IRMethod methodsFor: 'debugging' stamp: 'ClementBera 7/22/2013 16:45'! instructionForPC: aPC self compiledMethod. "generates the compiledMethod and optimize the ir. Removes the side-effect of optimizing the IR while looking for instruction, which results in incorrect found instruction" 0 to: -3 by: -1 do: [ :off | (self firstInstructionMatching: [:ir | ir bytecodeOffset = (aPC - off) ]) ifNotNil: [:it |^it]] ! ! !IRMethod methodsFor: 'inlining' stamp: 'md 9/12/2005 12:00'! removeReturn self allSequences last removeLast.! ! !IRMethod methodsFor: 'optimizing' stamp: 'MarcusDenker 7/22/2013 16:10'! optimize self removeEmptyStart. self compilationContext optionOptimizeIR ifFalse: [^self]. self absorbJumpsToSingleInstrs. self absorbConstantConditionalJumps. self absorbJumpsToSingleInstrs! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 4/13/2010 14:47'! tempKeys ^ tempMap keys! ! !IRMethod methodsFor: 'enumerating' stamp: 'md 6/13/2005 10:41'! allInstructionsMatching: aBlock " return irNodes as a flat collection " | irInstructions | irInstructions := OrderedCollection new. startSequence withAllSuccessorsDo: [:seq | seq do: [:bc | (aBlock value: bc) ifTrue: [irInstructions add: bc]]]. ^irInstructions! ! !IRMethod methodsFor: 'optimizing' stamp: 'ClementBera 2/28/2014 10:24'! removeEmptyStart (startSequence size = 1 and: [ startSequence last isPushClosureCopy not ]) ifTrue: [ "startSeq is just unconditional jump, forget it" startSequence := startSequence last destination]. ! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 6/6/2012 13:38'! addAdditionalLiterals: literals additionalLiterals := literals! ! !IRMethod methodsFor: 'inlining' stamp: 'md 9/11/2005 18:52'! addInstructionsAfter: aCollection | returningSeqs lastInstr | aCollection ifEmpty: [^self]. returningSeqs := self allSequences select: [:each | each last isReturn]. lastInstr := returningSeqs last last. lastInstr addInstructionsBefore: aCollection. ! ! !IRMethod methodsFor: 'optimizing' stamp: 'ajh 3/10/2003 15:45'! absorbJumpsToSingleInstrs startSequence absorbJumpToSingleInstr: IdentitySet new! ! !IRMethod methodsFor: 'initialization' stamp: 'MarcusDenker 5/15/2013 11:12'! initialize irPrimitive := IRPrimitive null. tempMap := Dictionary new. pragmas := OrderedCollection new. additionalLiterals := OCLiteralSet new. numArgs := 0.! ! !IRMethod methodsFor: 'accessing' stamp: 'md 7/10/2005 22:06'! properties: propDict properties := propDict.! ! !IRMethod methodsFor: 'initialize' stamp: 'md 7/9/2005 22:36'! startSequence: irSequence startSequence := irSequence. irSequence method: self.! ! !IRMethod methodsFor: 'optimizing' stamp: 'ajh 3/10/2003 15:45'! absorbConstantConditionalJumps startSequence absorbConstantConditionalJumps: IdentitySet new! ! !IRMethod methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:23'! accept: aVisitor ^ aVisitor visitMethod: self! ! !IRMethod methodsFor: 'translating' stamp: 'MarcusDenker 12/17/2012 14:25'! compiledMethodWith: trailer ^compiledMethod ifNil: [self generate: trailer ] ifNotNil: [compiledMethod]! ! !IRMethod methodsFor: 'printing' stamp: 'ajh 3/9/2003 15:53'! longPrintOn: stream IRPrinter new indent: 0; stream: stream; interpret: self! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 5/15/2013 08:29'! irPrimitive: aPrimitiveNode irPrimitive := aPrimitiveNode! ! !IRMethod methodsFor: 'accessing' stamp: 'ajh 3/10/2003 17:53'! startSequence ^ startSequence! ! !IRMethod methodsFor: 'testing' stamp: 'JorgeRessia 5/13/2010 11:18'! isPushClosureCopy ^false.! ! !IRMethod methodsFor: 'testing' stamp: 'ToonVerwaest 3/27/2011 17:45'! hasTempVector: aSymbol startSequence withAllSuccessorsDo: [ :seq | (seq hasTempVector: aSymbol) ifTrue: [ ^ true ]]. ^ false! ! !IRMethod methodsFor: 'enumerating' stamp: 'MarcusDenker 12/13/2012 17:39'! firstInstructionMatching: aBlock " return irNodes as a flat collection " startSequence withAllSuccessorsDo: [:seq | seq do: [:bc | (aBlock value: bc) ifTrue: [^bc]]]. ^nil! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 5/13/2011 13:56'! additionalLiterals ^additionalLiterals! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 11/19/2012 17:11'! sourceNode ^sourceNode! ! !IRMethod methodsFor: 'enumerating' stamp: 'MarcusDenker 12/18/2012 14:28'! tempVectorNamed: aName ^self firstInstructionMatching: [:ir | ir isTempVector and: [ir name = aName ] ]! ! !IRMethod methodsFor: 'enumerating' stamp: 'MarcusDenker 8/13/2010 14:11'! allTempAccessInstructions ^self allInstructionsMatching: [:bc | bc isTemp].! ! !IRMethod methodsFor: 'translating' stamp: 'MarcusDenker 12/17/2012 14:24'! generate ^self generate: CompiledMethodTrailer empty! ! !IRMethod methodsFor: 'accessing' stamp: 'JorgeRessia 5/20/2010 10:15'! predecessorsOf: aSequence | predecessors | predecessors := OrderedCollection new. self allSequences do: [:each | (each successorSequences includes: aSequence) ifTrue: [predecessors add: each]]. ^predecessors! ! !IRMethod methodsFor: 'accessing' stamp: 'md 7/10/2005 22:06'! properties ^properties! ! !IRMethod methodsFor: 'scoping' stamp: 'MarcusDenker 8/18/2010 14:54'! indexForVarNamed: aName ^tempMap at: aName! ! !IRMethod methodsFor: 'accessing' stamp: 'md 6/16/2005 15:02'! method ^self.! ! !IRMethod methodsFor: 'decompiling' stamp: 'MarcusDenker 8/8/2011 13:42'! instructionsForDecompiling "return all instructions, but skip the block bodies, as the decompiler recurses over blocks" ^startSequence instructionsForDecompiling allButFirst.! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 5/15/2013 08:29'! irPrimitive ^ irPrimitive! ! !IRMethod methodsFor: 'testing' stamp: 'md 6/21/2005 13:56'! isSend ^false.! ! !IRMethod methodsFor: 'translating' stamp: 'MarcusDenker 8/11/2010 17:06'! compiledMethod ^ self compiledMethodWith: CompiledMethodTrailer empty! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 7/22/2013 16:09'! forceLongForm compilationContext ifNil: [ ^ false ]. ^compilationContext optionLongIvarAccessBytecodes ! ! !IRMethod methodsFor: 'translating' stamp: 'MarcusDenker 5/27/2013 16:01'! generate: trailer | irTranslator | irTranslator := IRTranslator new compilationContext: compilationContext; trailer: trailer; interpret: self; pragmas: pragmas; yourself. compiledMethod := irTranslator compiledMethod. self sourceNode ifNotNil: [ compiledMethod classBinding: self sourceNode methodClass binding. compiledMethod selector: self sourceNode selector.] ifNil: [ compiledMethod classBinding: UndefinedObject binding. compiledMethod selector: #UndefinedMethod ]. ^compiledMethod.! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 8/18/2010 19:03'! numArgs: anInteger numArgs := anInteger! ! !IRMethod methodsFor: 'accessing' stamp: 'ClementBera 5/23/2013 11:09'! compilationContext ^ compilationContext ifNil: [ "only happens when decompiling or using stand-alone" compilationContext := CompilationContext default]! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 11/19/2012 17:12'! sourceNode: aNode sourceNode := aNode! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 8/18/2010 19:03'! numArgs ^ numArgs! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 5/13/2013 13:57'! compilationContext: aCompilationContext compilationContext := aCompilationContext! ! !IRMethod methodsFor: 'accessing' stamp: 'MarcusDenker 5/13/2011 13:42'! addAdditionalLiteral: aLiteral additionalLiterals add: aLiteral! ! !IRMethod methodsFor: 'accessing' stamp: 'JorgeRessia 5/6/2010 11:07'! addPragma: aPragma pragmas add: aPragma.! ! !IRMethod methodsFor: 'accessing' stamp: 'JorgeRessia 4/16/2010 11:34'! tempMap ^ tempMap! ! !IRMethod methodsFor: 'accessing' stamp: 'md 11/15/2004 17:08'! ir ^self.! ! !IRPop commentStamp: 'ajh 3/24/2003 23:57'! Instruction "popTop"! !IRPop methodsFor: 'interpret' stamp: 'jb 3/31/2010 15:42'! executeOn: interpreter ^ interpreter popTop! ! !IRPop methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:24'! accept: aVisitor ^ aVisitor visitPop: self! ! !IRPop methodsFor: 'testing' stamp: 'ms 7/10/2007 14:12'! isPop ^true! ! !IRPrimitive commentStamp: 'ajh 3/24/2003 21:35'! I represent a primitive. I am more than just a number if I am a named primitive. Structure: num Primitive number. spec Stored in first literal when num is 117 or 120. ! !IRPrimitive methodsFor: 'accessing' stamp: 'ajh 7/14/2001 12:23'! num: n primitiveNum := n! ! !IRPrimitive methodsFor: 'accessing' stamp: 'ajh 7/14/2001 12:30'! spec: literal spec := literal! ! !IRPrimitive methodsFor: 'printing' stamp: 'ajh 3/12/2003 12:26'! printOn: aStream aStream nextPutAll: 'primitive '; print: primitiveNum! ! !IRPrimitive methodsFor: 'printing' stamp: 'ajh 3/19/2003 22:02'! sourceText ^ String streamContents: [:stream | self printPrimitiveOn: stream]! ! !IRPrimitive methodsFor: 'accessing' stamp: 'MarcusDenker 8/12/2010 15:54'! initializeFrom: aPragmaNode primitiveNum := 0. spec := Array with: (aPragmaNode arguments second) name with: (aPragmaNode arguments first) name with: 0 with: 0. ! ! !IRPrimitive methodsFor: 'accessing' stamp: 'ajh 7/14/2001 12:37'! num ^ primitiveNum! ! !IRPrimitive methodsFor: 'accessing' stamp: 'ajh 7/14/2001 12:37'! spec ^ spec! ! !IRPrimitive methodsFor: 'printing' stamp: 'MarcusDenker 8/13/2010 11:39'! printPrimitiveOn: aStream "Print the primitive on aStream" | primIndex primDecl | primIndex := primitiveNum. primIndex = 0 ifTrue: [ ^ self ]. primIndex = 120 ifTrue: [ "External call spec" ^ aStream print: spec ]. aStream nextPutAll: '. (primIndex ~= 117 and: [ primIndex ~= 120 ]) ifTrue: [ Smalltalk at: #Interpreter ifPresent: [ :cls | aStream nextPutAll: ' "'; nextPutAll: ((cls classPool at: #PrimitiveTable) at: primIndex + 1); nextPutAll: '" ' ] ]! ! !IRPrimitive class methodsFor: 'instance creation' stamp: 'ajh 7/14/2001 12:47'! null ^ self new num: 0! ! !IRPrimitive class methodsFor: 'initialization' stamp: 'JorgeRessia 1/10/2010 11:28'! from: aPragmaNode ^ self new initializeFrom: aPragmaNode! ! !IRPrinter commentStamp: 'ajh 3/25/2003 00:22'! I interpret IRMethod instructions and write them out to a print stream.! !IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:44'! send: selector stream nextPutAll: 'send: '. selector printOn: stream. ! ! !IRPrinter methodsFor: 'interpret' stamp: 'ajh 3/9/2003 15:48'! interpretInstruction: irInstruction indent timesRepeat: [stream tab]. super interpretInstruction: irInstruction. stream cr. ! ! !IRPrinter methodsFor: 'initialize' stamp: 'ajh 3/9/2003 15:50'! stream: stringWriteStream stream := stringWriteStream! ! !IRPrinter methodsFor: 'instructions' stamp: 'ClementBera 2/28/2014 10:23'! storeInstVar: index stream nextPutAll: 'storeInstVar: '. index printOn: stream.! ! !IRPrinter methodsFor: 'instructions' stamp: 'MarcusDenker 8/22/2010 09:31'! pushConsArray: size stream nextPutAll: 'pushConsArray: '. size printOn: stream.! ! !IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:44'! send: selector toSuperOf: behavior stream nextPutAll: 'send: '. selector printOn: stream. stream nextPutAll: ' toSuperOf: '. behavior printOn: stream. ! ! !IRPrinter methodsFor: 'instructions' stamp: 'MarcusDenker 8/22/2010 09:30'! pushInstVar: index stream nextPutAll: 'pushInstVar: '. index printOn: stream.! ! !IRPrinter methodsFor: 'instructions' stamp: ''! storeTemp: index stream nextPutAll: 'storeTemp: '. index printOn: stream. ! ! !IRPrinter methodsFor: 'instructions' stamp: 'MarcusDenker 12/19/2012 08:07'! pushRemoteTemp: name inVector: tempVectorName stream nextPutAll: 'pushRemoteTemp: '. name printOn: stream.. stream nextPutAll: ' inVector: '. tempVectorName printOn: stream.! ! !IRPrinter methodsFor: 'instructions' stamp: 'MarcusDenker 8/22/2010 09:46'! storeIntoLiteralVariable: object stream nextPutAll: 'storeLiteralVariable: '. object isVariableBinding ifTrue: [^ stream nextPutAll: object key]. object printOn: stream.! ! !IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/11/2003 00:36'! label: seqNum "add tab and cr since this does not get called within interpretInstruction:" stream cr. "extra cr just to space out sequences" indent timesRepeat: [stream tab]. stream nextPutAll: 'label: '. seqNum printOn: stream. stream cr. ! ! !IRPrinter methodsFor: 'instructions' stamp: 'MarcusDenker 8/22/2010 09:31'! pushNewArray: size stream nextPutAll: 'pushNewArray: '. size printOn: stream.! ! !IRPrinter methodsFor: 'instructions' stamp: 'MarcusDenker 8/22/2010 09:27'! pushThisContext stream nextPutAll: 'pushThisContext'! ! !IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:42'! pushDup stream nextPutAll: 'pushDup'! ! !IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:41'! goto: seqNum stream nextPutAll: 'goto: '. seqNum printOn: stream. ! ! !IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:43'! returnTop stream nextPutAll: 'returnTop'. ! ! !IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:42'! if: bool goto: seqNum1 otherwise: seqNum2 stream nextPutAll: 'if: '. bool printOn: stream. stream nextPutAll: ' goto: '. seqNum1 printOn: stream. stream nextPutAll: ' else: '. seqNum2 printOn: stream. ! ! !IRPrinter methodsFor: 'instructions' stamp: 'MarcusDenker 8/22/2010 09:29'! pushLiteral: object stream nextPutAll: 'pushLiteral: '. object isVariableBinding ifTrue: [^ stream nextPutAll: object key]. object printOn: stream. ! ! !IRPrinter methodsFor: 'instructions' stamp: 'ajh 3/9/2003 15:42'! popTop stream nextPutAll: 'popTop'! ! !IRPrinter methodsFor: 'instructions' stamp: ''! pushClosureCopyCopiedValues: copiedValues args: args jumpTo: labelSymbol stream nextPutAll: 'pushClosureCopyCopiedValues: '. stream nextPutAll: copiedValues printString . stream nextPutAll: ' args: '. stream nextPutAll: args printString .! ! !IRPrinter methodsFor: 'instructions' stamp: ''! pushTemp: index stream nextPutAll: 'pushTemp: '. index printOn: stream.! ! !IRPrinter methodsFor: 'instructions' stamp: 'md 8/10/2005 11:28'! pushLiteralVariable: object stream nextPutAll: 'pushLiteralVariable: '. object isVariableBinding ifTrue: [^ stream nextPutAll: object key]. object printOn: stream.! ! !IRPrinter methodsFor: 'instructions' stamp: ''! storeRemoteTemp: name inVector: tempVectorName stream nextPutAll: 'storeRemoteTemp: '. name printOn: stream.. stream nextPutAll: ' inVector: '. tempVectorName printOn: stream.! ! !IRPrinter methodsFor: 'instructions' stamp: ''! createTempVectorNamed: name withVars: vars stream nextPutAll: 'createTempVectorNamed: '. name printOn: stream. stream nextPutAll: ' withVars: '. stream nextPutAll: vars printString.! ! !IRPrinter methodsFor: 'instructions' stamp: 'MarcusDenker 8/22/2010 09:26'! pushReceiver stream nextPutAll: 'pushReceiver'! ! !IRPrinter methodsFor: 'initialize' stamp: 'ajh 3/9/2003 15:49'! indent: tabs indent := tabs! ! !IRPrinter methodsFor: 'instructions' stamp: 'md 8/9/2005 17:08'! blockReturnTop stream nextPutAll: 'blockReturnTop'. ! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testReturnTop | ir | ir := IRBuilderTest new testReturnTop. self assert: ir longPrintString = ' label: 1 pushLiteral: false returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testInstVar | ir | ir := IRBuilderTest new testInstVar. self assert: ir longPrintString = ' label: 1 pushInstVar: 1 pushInstVar: 2 send: #+ returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testJumpBackTo | ir | ir := IRBuilderTest new testJumpBackTo. self assert: ir longPrintString = ' label: 1 pushReceiver pushLiteral: false goto: 2 label: 2 if: true goto: 4 else: 3 label: 3 pushLiteral: true goto: 2 label: 4 returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testJumpAheadTo | ir | ir := IRBuilderTest new testJumpAheadTo. self assert: ir longPrintString = ' label: 1 pushLiteral: 2 pushLiteral: 1 send: #+ goto: 2 label: 2 returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralVariableClass | ir | ir := IRBuilderTest new testLiteralVariableClass. self assert: ir longPrintString = ' label: 1 pushLiteralVariable: Object returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testDup | ir | ir := IRBuilderTest new testDup. self assert: ir longPrintString = ' label: 1 pushLiteral: 3 pushDup send: #= returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushConsArray | ir | ir := IRBuilderTest new testPushConsArray. self assert: ir longPrintString = ' label: 1 pushReceiver pushConsArray: 1 returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushClosureCopyNoCopied | ir | ir := IRBuilderTest new testPushClosureCopyNoCopied. self assert: ir longPrintString = ' label: 1 pushReceiver pushClosureCopyCopiedValues: #() args: #() label: 2 pushLiteral: 1 pushLiteral: 2 send: #+ blockReturnTop label: 3 send: #value returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushSelf | ir | ir := IRBuilderTest new testPushSelf. self assert: ir longPrintString = ' label: 1 pushReceiver send: #class returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushNewArray | ir | ir := IRBuilderTest new testPushNewArray. self assert: ir longPrintString = ' label: 1 pushNewArray: 1 returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testRemoteTempNested | ir | ir := IRBuilderTest new testRemoteTempNested. self assert: ir longPrintString = ' label: 1 createTempVectorNamed: #methodVector withVars: #(#b) pushLiteral: 1 storeTemp: #a popTop pushClosureCopyCopiedValues: #(#methodVector #a) args: #() label: 2 createTempVectorNamed: #blockVector withVars: #(#f) pushTemp: #a pushClosureCopyCopiedValues: #(#methodVector) args: #() label: 3 pushLiteral: 1 storeRemoteTemp: #b inVector: #methodVector blockReturnTop label: 4 send: #value send: #+ storeRemoteTemp: #b inVector: #methodVector blockReturnTop label: 5 send: #value pushRemoteTemp: #b inVector: #methodVector returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testRemoteTemp | ir | ir := IRBuilderTest new testRemoteTemp. self assert: ir longPrintString = ' label: 1 createTempVectorNamed: #methodVector withVars: #(#b) pushLiteral: 1 storeTemp: #a popTop pushClosureCopyCopiedValues: #(#a #c #methodVector) args: #() label: 2 pushTemp: #a pushLiteral: 1 send: #+ storeRemoteTemp: #b inVector: #methodVector popTop blockReturnTop label: 3 send: #value pushRemoteTemp: #b inVector: #methodVector returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushTempTemp | ir | ir := IRBuilderTest new testPushTempTemp. self assert: ir longPrintString = ' label: 1 pushTemp: #a returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushThisContext | ir | ir := IRBuilderTest new testPushThisContext. self assert: ir longPrintString = ' label: 1 pushThisContext send: #receiver returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:12'! testSendSuper | ir | ir := IRBuilderTest new testSendSuper. self assert: ir longPrintString = ' label: 1 pushReceiver send: #isThisEverCalled toSuperOf: IRBuilderTest returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushTempArgument | ir | ir := IRBuilderTest new testPushTempArgument. self assert: ir longPrintString = ' label: 1 pushTemp: #a pushTemp: #b send: #+ returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testStoreTemp | ir | ir := IRBuilderTest new testStoreTemp. self assert: ir longPrintString = ' label: 1 pushLiteral: 34 storeTemp: #a popTop pushTemp: #a returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralArray | ir | ir := IRBuilderTest new testLiteralArray. self assert: ir longPrintString = ' label: 1 pushLiteral: #(#test 4 #you) returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testStoreIntoVariable | ir | ir := IRBuilderTest new testStoreIntoVariable. self assert: ir longPrintString = ' label: 1 pushLiteral: 4 storeLiteralVariable: TestToPush returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testJumpAheadToIf | ir | ir := IRBuilderTest new testJumpAheadToIf. self assert: ir longPrintString = ' label: 1 pushReceiver pushLiteral: true if: true goto: 3 else: 2 label: 2 returnTop label: 3 returnTop '! ! !IRPrinterTest methodsFor: 'testing' stamp: 'MarcusDenker 7/16/2012 16:07'! testPopTop | ir | ir := IRBuilderTest new testPopTop. self assert: ir longPrintString = ' label: 1 pushReceiver pushLiteral: false popTop returnTop '! ! !IRPushArray methodsFor: 'initializing' stamp: 'MarcusDenker 8/13/2010 13:32'! size: aSmallInteger size := aSmallInteger! ! !IRPushArray methodsFor: 'initializing' stamp: 'MarcusDenker 8/13/2010 13:40'! executeOn: interpreter ^cons ifFalse: [interpreter pushNewArray: size] ifTrue: [interpreter pushConsArray: size]! ! !IRPushArray methodsFor: 'initialization' stamp: 'MarcusDenker 8/13/2010 13:31'! initialize size := 0. cons := false. ! ! !IRPushArray methodsFor: 'initializing' stamp: 'MarcusDenker 8/13/2010 13:33'! cons: aBool cons := aBool.! ! !IRPushArray methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:24'! accept: aVisitor ^ aVisitor visitPushArray: self! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'jb 3/29/2010 13:38'! blockSequence ^blockSequence! ! !IRPushClosureCopy methodsFor: 'scoping' stamp: 'MarcusDenker 8/18/2010 14:55'! indexForVarNamed: aName ^tempMap at: aName! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'JorgeRessia 5/19/2010 11:23'! lastBlockSequence: aSequence lastBlockSequence := aSequence! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'MarcusDenker 8/19/2010 15:00'! copiedValues: anArray copiedValues := anArray.! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'MarcusDenker 4/13/2010 14:52'! tempKeys ^tempMap keys ! ! !IRPushClosureCopy methodsFor: 'testing' stamp: 'MarcusDenker 8/19/2010 10:34'! tempVectorName self blockSequence do:[:irNode | irNode isTempVector ifTrue:[^irNode name]]. ^nil.! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'ToonVerwaest 3/26/2011 19:26'! copiedValues ^ copiedValues! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'MarcusDenker 8/27/2010 13:28'! arguments: anArray arguments := anArray! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'MarcusDenker 10/14/2010 15:27'! definedTemps ^self tempMap keys copyWithoutAll: (arguments, copiedValues).! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'MarcusDenker 8/8/2011 13:30'! nonBodySuccessorSequences ^ {destination}! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'MarcusDenker 8/19/2010 15:00'! numArgs: aSmallInteger numArgs := aSmallInteger! ! !IRPushClosureCopy methodsFor: 'interpret' stamp: 'MarcusDenker 8/27/2010 13:32'! executeOn: interpreter ^interpreter pushClosureCopyCopiedValues: copiedValues args: arguments jumpTo: destination! ! !IRPushClosureCopy methodsFor: 'initialization' stamp: 'MarcusDenker 5/19/2011 14:55'! initialize super initialize. tempMap := Dictionary new. ! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'JorgeRessia 5/19/2010 11:23'! lastBlockSequence ^lastBlockSequence! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'jb 4/2/2010 16:27'! blockSequence: anIRSequence blockSequence := anIRSequence! ! !IRPushClosureCopy methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:24'! accept: aVisitor ^ aVisitor visitPushClosureCopy: self! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'jorgeRessia 10/1/2009 16:31'! numArgs ^numArgs! ! !IRPushClosureCopy methodsFor: 'testing' stamp: 'JorgeRessia 12/25/2009 20:44'! isPushClosureCopy ^true! ! !IRPushClosureCopy methodsFor: 'testing' stamp: 'ToonVerwaest 3/27/2011 18:25'! hasTempVector: aSymbol blockSequence withAllSuccessorsDo: [ :seq | (seq hasTempVector: aSymbol) ifTrue: [ ^ true ]. seq == lastBlockSequence ifTrue: [ ^ false ]]. ^false! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'jb 3/31/2010 11:32'! successorSequences ^ {destination. blockSequence} ! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'MarcusDenker 8/27/2010 13:28'! arguments ^arguments! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'jb 8/26/2010 17:01'! tempMap ^tempMap! ! !IRPushClosureCopy methodsFor: 'accessing' stamp: 'MarcusDenker 12/20/2012 14:22'! tempVectorNamed: aName (self hasTempVector: aName) ifFalse: [^nil]. ^blockSequence tempVectorNamed: aName.! ! !IRPushDup commentStamp: 'ajh 3/24/2003 23:56'! Instruction "pushDup"! !IRPushDup methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:23'! accept: aVisitor ^ aVisitor visitPushDup: self! ! !IRPushDup methodsFor: 'interpret' stamp: 'ajh 3/10/2003 00:46'! executeOn: interpreter ^ interpreter pushDup! ! !IRPushLiteral commentStamp: 'ajh 3/24/2003 23:56'! Instruction "pushLiteral: object"! !IRPushLiteral methodsFor: 'testing' stamp: 'MarcusDenker 9/20/2013 13:26'! isPushLiteral ^ true! ! !IRPushLiteral methodsFor: 'interpret' stamp: 'ToonVerwaest 3/26/2011 17:52'! executeOn: interpreter interpreter pushLiteral: literal! ! !IRPushLiteral methodsFor: 'testing' stamp: 'MarcusDenker 9/20/2013 13:26'! isPushLiteral: valueTest ^ valueTest value: literal! ! !IRPushLiteral methodsFor: 'accessing' stamp: 'MarcusDenker 8/13/2010 13:23'! literal: object literal := object! ! !IRPushLiteral methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:23'! accept: aVisitor ^ aVisitor visitPushLiteral: self! ! !IRPushLiteral methodsFor: 'accessing' stamp: 'MarcusDenker 8/13/2010 13:23'! literal ^ literal! ! !IRReceiverAccess commentStamp: ''! I am modelling the push self bytecode! !IRReceiverAccess methodsFor: 'interpret' stamp: 'JorgeRessia 4/29/2010 17:08'! executeOn: interpreter interpreter pushReceiver.! ! !IRReceiverAccess methodsFor: 'testing' stamp: 'JorgeRessia 4/29/2010 17:06'! isSelf ^true! ! !IRReceiverAccess methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:24'! accept: aVisitor ^ aVisitor visitReceiverAccess: self! ! !IRReconstructor commentStamp: ''! I am a specialized IRBuilder for the decompiler! !IRReconstructor methodsFor: 'accessors' stamp: 'MarcusDenker 6/8/2012 15:25'! currentSequence: aSeq currentSequence := aSeq! ! !IRReconstructor methodsFor: 'remapping' stamp: 'ToonVerwaest 3/27/2011 15:19'! rememberReference: anInstruction to: name in: dictionary (dictionary at: name ifAbsentPut: [ OrderedCollection new ]) add: anInstruction! ! !IRReconstructor methodsFor: 'removing' stamp: 'MarcusDenker 6/8/2012 13:53'! fixPushNilsForTemps " There are pushConstant: nil in the beginning of the blocksequence for all of the defined temps. We got these pushConstant: nil in. Now our closure will generate them again, meaning we will double the number of pushConstant: nil in the final block. To avoid this, we strip the ones we got in from the IR. " | blocksequence | blocksequence := self currentScope blockSequence sequence. self currentScope definedTemps do: [ :temp | blocksequence removeFirst ]. ! ! !IRReconstructor methodsFor: 'remapping' stamp: 'ToonVerwaest 3/27/2011 15:22'! remapTemp: aTemp toRemote: aRemote (temps removeKey: aTemp ifAbsent: [ #() ]) do: [ :tempAccess | tempAccess name: aRemote. self rememberReference: tempAccess to: aRemote in: temps ]. (remoteTemps removeKey: aTemp ifAbsent: [ #() ]) do: [ :tempAccess | tempAccess tempVectorName: aRemote. self rememberReference: tempAccess to: aRemote in: remoteTemps. ]. (closureCopiedValues removeKey: aTemp ifAbsent: [ #() ]) do: [ :aClosureAndIndex | |closure index| closure := aClosureAndIndex key. index := aClosureAndIndex value. closure copiedValues at: index put: aRemote. closure tempMap at: aRemote put: (closure tempMap removeKey: aTemp). self rememberReference: aClosureAndIndex to: aRemote in: closureCopiedValues. ].! ! !IRReconstructor methodsFor: 'initialization' stamp: 'ToonVerwaest 3/28/2011 00:05'! initialize temps := Dictionary new. remoteTemps := Dictionary new. closureCopiedValues := Dictionary new. sourceMapByteIndex := 0. super initialize.! ! !IRReconstructor methodsFor: 'instructions' stamp: 'MarcusDenker 6/8/2012 13:46'! pushClosureCopyCopiedValues: copiedValuesNames args: args jumpTo: aJumpLabel | anInstruction | anInstruction := super pushClosureCopyCopiedValues: copiedValuesNames args: args jumpTo: aJumpLabel. "remove pushed nils of local temps" anInstruction copiedValues withIndexDo: [ :aValue :index | self rememberReference: anInstruction -> index to: aValue in: closureCopiedValues ]! ! !IRReconstructor methodsFor: 'instructions' stamp: 'ToonVerwaest 3/27/2011 15:18'! pushRemoteTemp: name inVector: nameOfVector | anInstruction | anInstruction := super pushRemoteTemp: name inVector: nameOfVector. self rememberReference: anInstruction to: nameOfVector in: remoteTemps.! ! !IRReconstructor methodsFor: 'instructions' stamp: 'ToonVerwaest 3/27/2011 15:20'! pushTemp: aSelector | anInstruction | anInstruction := super pushTemp: aSelector. self rememberReference: anInstruction to: aSelector in: temps.! ! !IRReconstructor methodsFor: 'testing' stamp: 'MarcusDenker 5/12/2011 13:40'! isLastClosureInstruction | nextJumps | nextJumps := jumpAheadStacks at: sourceMapByteIndex + 1 ifAbsent: [ ^ false ]. ^ nextJumps anySatisfy: [ :anOrigin | anOrigin = self currentScope ]! ! !IRReconstructor methodsFor: 'instructions' stamp: 'ToonVerwaest 3/27/2011 15:20'! storeTemp: aSelector | anInstruction | anInstruction := super storeTemp: aSelector. self rememberReference: anInstruction to: aSelector in: temps.! ! !IRReconstructor methodsFor: 'initialize' stamp: 'MarcusDenker 5/19/2011 13:50'! createTempVectorNamed: name withVars: anArray " Don't add the temp yet, we only know it's index at the end of the block or method " "self addVectorTemps: anArray". " Update the byte index to point before the pushing of the new vector " sourceMapByteIndex := sourceMapByteIndex - 2. self add: (IRInstruction createTempVectorNamed: name withVars: anArray)! ! !IRReconstructor methodsFor: 'removing' stamp: 'ToonVerwaest 3/27/2011 18:09'! removeLast: n " Make the address of the instruction be the address of the first removed instruction. " sourceMapByteIndex := sourceMapByteIndex - n. ^ (currentSequence removeLast: n) collect: [ :node | node isTemp ifFalse: [ self error: 'Should only remove temp accesses!!' ]. node name ]! ! !IRReconstructor methodsFor: 'accessors' stamp: 'MarcusDenker 6/8/2012 15:24'! currentSequence ^currentSequence ! ! !IRReconstructor methodsFor: 'instructions' stamp: 'MarcusDenker 5/19/2011 14:21'! storeRemoteTemp: name inVector: nameOfVector | anInstruction | anInstruction := super storeRemoteTemp: name inVector: nameOfVector. self rememberReference: anInstruction to: nameOfVector in: remoteTemps.! ! !IRReconstructor methodsFor: 'instructions' stamp: 'MarcusDenker 6/8/2012 13:53'! blockReturnTop self fixPushNilsForTemps. ^ super blockReturnTop! ! !IRRemoteArray commentStamp: ''! I model the TempVector for the decompiler! !IRRemoteArray methodsFor: 'enumerating' stamp: 'MarcusDenker 5/19/2011 14:27'! indexOf: anInteger ^anInteger + 1.! ! !IRRemoteArray methodsFor: 'accessing' stamp: 'ToonVerwaest 3/26/2011 19:13'! size: aSize size := aSize! ! !IRRemoteArray methodsFor: 'accessing' stamp: 'ToonVerwaest 3/26/2011 19:15'! size ^ size! ! !IRRemoteArray methodsFor: 'enumerating' stamp: 'ToonVerwaest 3/27/2011 12:46'! do: aBlock 1 to: size do: [ :idx | aBlock value: (idx - 1) ]! ! !IRRemoteArray methodsFor: 'accessing' stamp: 'ToonVerwaest 3/27/2011 12:39'! index: anIndex index := anIndex! ! !IRRemoteArray methodsFor: 'accessing' stamp: 'ToonVerwaest 3/27/2011 14:59'! index ^ index! ! !IRRemoteTempAccess methodsFor: 'interpret' stamp: 'MarcusDenker 8/18/2010 15:51'! executeOn: interpreter ^store ifFalse: [interpreter pushRemoteTemp: name inVector: tempVectorName] ifTrue: [interpreter storeRemoteTemp: name inVector: tempVectorName]! ! !IRRemoteTempAccess methodsFor: 'accessing' stamp: 'ToonVerwaest 3/26/2011 18:48'! tempVectorName ^ tempVectorName! ! !IRRemoteTempAccess methodsFor: 'testing' stamp: 'ToonVerwaest 3/26/2011 18:50'! isRemoteTemp ^ true! ! !IRRemoteTempAccess methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:24'! accept: aVisitor ^ aVisitor visitRemoteTempAccess: self! ! !IRRemoteTempAccess methodsFor: 'accessing' stamp: 'MarcusDenker 8/18/2010 15:31'! tempVectorName: anObject tempVectorName := anObject! ! !IRReturn commentStamp: ''! Instruction "returnTop"! !IRReturn methodsFor: 'testing' stamp: 'ajh 3/10/2003 16:10'! isReturn ^ true! ! !IRReturn methodsFor: 'interpret' stamp: 'MarcusDenker 4/15/2010 15:21'! executeOn: interpreter interpreter returnTop! ! !IRReturn methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:23'! accept: aVisitor ^ aVisitor visitReturn: self! ! !IRReturn methodsFor: 'accessing' stamp: 'MarcusDenker 8/8/2011 13:47'! nonBodySuccessorSequences ^#()! ! !IRSend commentStamp: 'ajh 3/24/2003 23:57'! Instruction "send: selector" or "send: selector toSuperOf: behavior"! !IRSend methodsFor: 'accessing' stamp: 'md 6/23/2005 13:45'! selector ^selector! ! !IRSend methodsFor: 'interpret' stamp: 'TestRunner 1/6/2010 10:26'! executeOn: interpreter ^ superOf ifNil: [interpreter send: selector] ifNotNil: [interpreter send: selector toSuperOf: superOf]! ! !IRSend methodsFor: 'testing' stamp: 'md 10/10/2005 17:37'! isSuperSend ^superOf notNil! ! !IRSend methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:23'! accept: aVisitor ^ aVisitor visitSend: self! ! !IRSend methodsFor: 'accessing' stamp: 'ajh 3/10/2003 00:45'! superOf: behavior superOf := behavior! ! !IRSend methodsFor: 'testing' stamp: 'md 11/12/2004 15:57'! isSend ^true.! ! !IRSend methodsFor: 'accessing' stamp: 'ajh 3/10/2003 00:44'! selector: symbol selector := symbol! ! !IRSequence commentStamp: ''! A sequence is corresponds to a block in the control flow graph.! !IRSequence methodsFor: 'accessing' stamp: 'md 7/14/2005 12:23'! last ^sequence last! ! !IRSequence methodsFor: 'adding' stamp: 'dr 9/11/2005 15:35'! addAll: aCollection ^sequence addAll: aCollection! ! !IRSequence methodsFor: 'adding' stamp: 'md 7/14/2005 11:57'! addInstructions: aCollection after: anInstruction ^aCollection reverseDo: [:instr | self add: instr after: anInstruction].! ! !IRSequence methodsFor: 'adding' stamp: 'dr 9/10/2005 20:57'! addLast: anInstruction ^self add: anInstruction.! ! !IRSequence methodsFor: 'accessing' stamp: 'md 9/29/2005 11:25'! after: o ^sequence after: o! ! !IRSequence methodsFor: 'initialization' stamp: 'jb 4/1/2010 13:48'! initialize sequence := OrderedCollection new.! ! !IRSequence methodsFor: 'optimizing' stamp: 'md 5/17/2013 16:49'! absorbJumpToSingleInstr: alreadySeen "Collapse jumps to single return instructions into caller" | seqs seq | (alreadySeen includes: self) ifTrue: [^ self]. alreadySeen add: self. [ (seqs := self successorSequences) size = 1 "unconditional jump..." and: [((seq := seqs first) size = 1) "...to single instruction..." and: [seq successorSequences size < 2 and: [self last isBlockReturnTop not and: [((seq sequence size = 1) and: [(seq sequence first isBlockReturnTop) or: [seq sequence first isReturn]]) not]]]]"...but don't collapse conditional jumps so their otherwiseSequences can stay right after them" ] whileTrue: [ "replace goto with single instruction" self removeLast. seq do: [:instr | self add: instr copy]. ]. seqs do: [:instrs | instrs ifNotNil: [:i | i absorbJumpToSingleInstr: alreadySeen]]. ! ! !IRSequence methodsFor: 'visiting' stamp: 'CamilloBruni 9/20/2013 22:51'! accept: aVisitor ^ self visitSequence: self! ! !IRSequence methodsFor: 'printing' stamp: 'md 7/14/2005 11:59'! longPrintOn: stream [IRPrinter new indent: 0; stream: stream; interpretSequence: self ] onDNU: #orderNumber do: [:ex | ex resume: ex receiver]! ! !IRSequence methodsFor: 'manipulating' stamp: 'ToonVerwaest 3/27/2011 17:20'! splitAfter: instruction | newSeq index next | next := self nextSequence. next := next ifNil: [self orderNumber + 1] ifNotNil: [(next orderNumber + self orderNumber) / 2]. newSeq := self class new orderNumber: next. newSeq method: self method. "Split after instruction" index := sequence indexOf: instruction. (sequence last: sequence size - index) do: [:instr | newSeq add: instr]. sequence := sequence first: index. self flag: 'The jump inherits the bytecode index from the instruction where it was split. Check if this value is correct.'. self add: (IRJump new destination: newSeq; bytecodeIndex: (instruction bytecodeIndex + 1)). ^ newSeq! ! !IRSequence methodsFor: 'removing' stamp: 'dr 9/10/2005 21:03'! removeFirst ^sequence removeFirst.! ! !IRSequence methodsFor: 'testing' stamp: 'md 7/14/2005 12:23'! isEmpty ^sequence isEmpty! ! !IRSequence methodsFor: 'successor sequences' stamp: 'md 7/14/2005 11:59'! withAllSuccessorsDo: block "Iterate over me and all my successors only once" self withAllSuccessorsDo: block alreadySeen: IdentitySet new! ! !IRSequence methodsFor: 'optimizing' stamp: 'MarcusDenker 9/20/2013 15:18'! absorbConstantConditionalJumps: alreadySeen "Collapse sequences that look like: [if] goto s1 ... s1: pushConst: true/false goto s2 s2: if true/false goto s3 else s4 into: [if] goto s3/s4 These sequences are produced by and:/or: messages" | seq bool if | (alreadySeen includes: self) ifTrue: [^ self]. alreadySeen add: self. [(seq := self successorSequences) notEmpty "not return" and: [(seq := seq first "destination") size = 2 and: [(seq first isPushLiteral: [:obj | (bool := obj) isKindOf: Boolean]) and: [seq last isGoto and: [(if := seq last destination first) isIf]]]] ] whileTrue: [ "absorb" self last destination: (bool == if boolean ifTrue: [if destination] ifFalse: [if otherwise]). ]. self successorSequences do: [:instrs | instrs ifNotNil: [:i | i absorbConstantConditionalJumps: alreadySeen]]. ! ! !IRSequence methodsFor: 'successor sequences' stamp: 'MarcusDenker 8/8/2011 13:42'! instructionsForDecompiling | irInstructions | irInstructions := OrderedCollection new. self withNonBodySuccessorsDo: [:seq | seq do: [:bc | irInstructions add: bc]]. ^irInstructions ! ! !IRSequence methodsFor: 'replacing' stamp: 'md 7/14/2005 12:01'! replaceNode: aNode withNode: anotherNode self add: anotherNode before: aNode. sequence remove: aNode ifAbsent: [self error].! ! !IRSequence methodsFor: 'copying' stamp: 'dr 9/10/2005 20:59'! , otherCollection ^sequence, otherCollection! ! !IRSequence methodsFor: 'replacing' stamp: 'md 7/14/2005 12:01'! replaceNode: aNode withNodes: aCollection self addInstructions: aCollection before: aNode. sequence remove: aNode ifAbsent: [self error].! ! !IRSequence methodsFor: 'successor sequences' stamp: 'md 7/14/2005 11:58'! nextSequence | sequences i | sequences := self withAllSuccessors. i := sequences findFirst: [:seq | seq orderNumber = self orderNumber]. (i = 0 or: [i = sequences size]) ifTrue: [^ nil]. ^ sequences at: i + 1! ! !IRSequence methodsFor: 'enumerating' stamp: 'md 7/14/2005 12:28'! reverseDo: aBlock ^sequence reverseDo: aBlock.! ! !IRSequence methodsFor: 'successor sequences' stamp: 'md 7/14/2005 11:59'! withAllSuccessors "Return me and all my successors sorted by sequence orderNumber" | list | list := OrderedCollection new: 20. self withAllSuccessorsDo: [:seq | list add: seq]. ^ list asSortedCollection: [:x :y | x orderNumber <= y orderNumber]! ! !IRSequence methodsFor: 'enumerating' stamp: 'MarcusDenker 8/19/2010 08:39'! contains: aBlock ^sequence contains: aBlock.! ! !IRSequence methodsFor: 'accessing' stamp: 'md 7/14/2005 12:00'! method: aIRMethod method := aIRMethod! ! !IRSequence methodsFor: 'enumerating' stamp: 'dr 9/10/2005 21:02'! detect: aBlock ^sequence detect: aBlock! ! !IRSequence methodsFor: 'accessing' stamp: 'md 7/14/2005 12:31'! first ^sequence first! ! !IRSequence methodsFor: 'successor sequences' stamp: 'md 7/14/2005 11:59'! withAllSuccessorsDo: block alreadySeen: set "Iterate over me and all my successors only once" (set includes: self) ifTrue: [^ self]. set add: self. block value: self. self successorSequences do: [:seq | seq ifNotNil: [seq withAllSuccessorsDo: block alreadySeen: set]]. ! ! !IRSequence methodsFor: 'testing' stamp: 'md 7/14/2005 12:30'! ifEmpty: aBlock ^sequence ifEmpty: aBlock! ! !IRSequence methodsFor: 'adding' stamp: 'md 7/14/2005 11:57'! add: instr after: another sequence add: instr after: another. instr sequence: self. ^instr.! ! !IRSequence methodsFor: 'accessing' stamp: 'dr 9/10/2005 21:01'! at: index ^sequence at: index! ! !IRSequence methodsFor: 'adding' stamp: 'md 7/14/2005 11:57'! add: anInstruction sequence add: anInstruction. anInstruction sequence: self. ^anInstruction.! ! !IRSequence methodsFor: 'printing' stamp: 'md 7/14/2005 12:00'! printOn: stream stream nextPutAll: 'an '. self class printOn: stream. stream space. stream nextPut: $(. self orderNumber printOn: stream. stream nextPut: $). ! ! !IRSequence methodsFor: 'testing' stamp: 'MarcusDenker 8/19/2010 15:30'! hasTempVector: aSymbol ^sequence anySatisfy: [:irNode | irNode isTempVector and: [irNode name = aSymbol]].! ! !IRSequence methodsFor: 'adding' stamp: 'md 7/14/2005 11:58'! add: instr before: another sequence add: instr before: another. instr sequence: self. ^instr.! ! !IRSequence methodsFor: 'accessing' stamp: 'md 7/14/2005 12:32'! sequence ^sequence! ! !IRSequence methodsFor: 'accessing' stamp: 'MarcusDenker 12/20/2012 14:21'! tempVectorNamed: aSymbol ^sequence detect: [:irNode | irNode isTempVector and: [irNode name = aSymbol]].! ! !IRSequence methodsFor: 'successor sequences' stamp: 'md 7/14/2005 11:58'! instructionsDo: aBlock ^self withAllSuccessorsDo: [:seq | seq do: aBlock].! ! !IRSequence methodsFor: 'accessing' stamp: 'md 7/14/2005 12:25'! size ^sequence size.! ! !IRSequence methodsFor: 'accessing' stamp: 'md 7/14/2005 12:00'! method ^method! ! !IRSequence methodsFor: 'adding' stamp: 'md 7/14/2005 12:29'! addInstructions: aCollection before: anInstruction aCollection do: [:instr | self add: instr before: anInstruction].! ! !IRSequence methodsFor: 'accessing' stamp: 'md 7/14/2005 12:00'! orderNumber "Sequences are sorted by this number" ^ orderNumber! ! !IRSequence methodsFor: 'adding' stamp: 'md 9/28/2005 17:55'! addAllFirst: aCollection ^sequence addAllFirst: aCollection.! ! !IRSequence methodsFor: 'successor sequences' stamp: 'MarcusDenker 8/8/2011 13:31'! nonBodySuccessorSequences sequence isEmpty ifTrue: [^ #()]. ^ sequence last nonBodySuccessorSequences! ! !IRSequence methodsFor: 'testing' stamp: 'dr 9/10/2005 20:55'! notEmpty ^sequence notEmpty! ! !IRSequence methodsFor: 'accessing' stamp: 'JorgeRessia 6/19/2010 08:20'! orderNumber: num "Sequences are sorted by this number" orderNumber := num.! ! !IRSequence methodsFor: 'testing' stamp: 'md 7/14/2005 12:30'! ifNotEmpty: aBlock ^sequence ifNotEmpty: aBlock! ! !IRSequence methodsFor: 'enumerating' stamp: 'md 7/14/2005 12:28'! select: aBlock ^sequence select: aBlock.! ! !IRSequence methodsFor: 'successor sequences' stamp: 'MarcusDenker 8/8/2011 13:27'! withNonBodySuccessorsDo: block "Iterate over me and all my successors only once" self withNonBodySuccessorsDo: block alreadySeen: IdentitySet new! ! !IRSequence methodsFor: 'enumerating' stamp: 'md 7/14/2005 12:24'! do: aBlock ^sequence do: aBlock.! ! !IRSequence methodsFor: 'removing' stamp: 'md 7/14/2005 12:25'! removeLast ^sequence removeLast.! ! !IRSequence methodsFor: 'replacing' stamp: 'md 7/14/2005 12:00'! remove: aNode aNode sequence: nil. sequence remove: aNode ifAbsent: [self error].! ! !IRSequence methodsFor: 'successor sequences' stamp: 'MarcusDenker 8/8/2011 13:28'! withNonBodySuccessorsDo: block alreadySeen: set "Iterate over me and all my successors only once" (set includes: self) ifTrue: [^ self]. set add: self. block value: self. self nonBodySuccessorSequences do: [:seq | seq ifNotNil: [seq withNonBodySuccessorsDo: block alreadySeen: set]]. ! ! !IRSequence methodsFor: 'adding' stamp: 'md 7/14/2005 11:58'! addInstructions: aCollection ^aCollection do: [:instr | self add: instr].! ! !IRSequence methodsFor: 'successor sequences' stamp: 'md 7/14/2005 11:59'! successorSequences sequence isEmpty ifTrue: [^ #()]. ^ sequence last successorSequences! ! !IRSequence methodsFor: 'removing' stamp: 'ToonVerwaest 3/26/2011 14:40'! removeLast: n ^sequence removeLast: n.! ! !IRSequence class methodsFor: 'instance creation' stamp: 'MarcusDenker 6/13/2012 14:11'! orderNumber: aNumber ^self new orderNumber: aNumber! ! !IRStackCount commentStamp: 'ajh 3/25/2003 00:34'! This keeps track of the stack count for the BytecodeGenerator.! !IRStackCount methodsFor: 'comparing' stamp: 'ajh 3/13/2003 01:51'! hash ^ position hash bitXor: (length hash bitXor: start hash)! ! !IRStackCount methodsFor: 'affecting' stamp: 'MarcusDenker 6/19/2012 10:07'! pop: n (position := position - n) < 0 ifTrue: [self error: 'stack underflow in bytecode generator']! ! !IRStackCount methodsFor: 'results' stamp: 'ajh 3/13/2003 01:32'! size ^length! ! !IRStackCount methodsFor: 'results' stamp: 'MarcusDenker 6/19/2012 15:13'! linkTo: stackOrNil stackOrNil ifNil: [^ self class startAt: self position]. ^ self position = stackOrNil start ifTrue: [stackOrNil] ifFalse: [self error: 'stack out of sync in bytecode generator']! ! !IRStackCount methodsFor: 'initialize' stamp: 'ajh 3/13/2003 01:48'! startAt: pos start := position := length := pos! ! !IRStackCount methodsFor: 'affecting' stamp: 'jorgeRessia 11/3/2009 16:54'! push ^ self push: 1! ! !IRStackCount methodsFor: 'comparing' stamp: 'ajh 3/13/2003 01:39'! = other ^ self class == other class and: [start = other start and: [position = other position and: [length = other size]]]! ! !IRStackCount methodsFor: 'affecting' stamp: 'jorgeRessia 11/3/2009 16:56'! pop ^ self pop: 1! ! !IRStackCount methodsFor: 'printing' stamp: 'ajh 3/13/2003 01:38'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' start '; print: start; nextPutAll: ' stop '; print: position; nextPutAll: ' max '; print: length. ! ! !IRStackCount methodsFor: 'results' stamp: 'ajh 3/13/2003 01:32'! position ^position! ! !IRStackCount methodsFor: 'affecting' stamp: 'jorgeRessia 11/3/2009 16:59'! push: n (position := position + n) > length ifTrue: [length := position]! ! !IRStackCount methodsFor: 'results' stamp: 'ajh 3/13/2003 01:32'! length ^length! ! !IRStackCount methodsFor: 'results' stamp: 'ajh 3/13/2003 01:36'! start ^ start! ! !IRStackCount class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/13/2010 15:26'! startAt: pos ^ self new startAt: pos! ! !IRStackCount class methodsFor: 'instance creation' stamp: 'ajh 3/13/2003 01:49'! new ^ super new startAt: 0! ! !IRTempAccess commentStamp: ''! I model the pushTemporary Bytecode! !IRTempAccess methodsFor: 'interpret' stamp: 'MarcusDenker 8/19/2010 20:12'! executeOn: interpreter store ifFalse: [interpreter pushTemp: name] ifTrue: [interpreter storeTemp: name] ! ! !IRTempAccess methodsFor: 'testing' stamp: 'ToonVerwaest 3/26/2011 18:52'! isRemoteTemp ^ false! ! !IRTempAccess methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:24'! accept: aVisitor ^ aVisitor visitTempAccess: self! ! !IRTempAccess methodsFor: 'testing' stamp: 'md 2/22/2005 11:28'! isTemp ^true.! ! !IRTempVector methodsFor: 'accessing' stamp: 'MarcusDenker 8/19/2010 08:27'! executeOn: interpreter interpreter createTempVectorNamed: name withVars: vars! ! !IRTempVector methodsFor: 'initialization' stamp: 'MarcusDenker 8/19/2010 01:09'! initialize vars := Dictionary new! ! !IRTempVector methodsFor: 'accessing' stamp: 'MarcusDenker 8/19/2010 01:05'! name: anObject name := anObject! ! !IRTempVector methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:23'! accept: aVisitor ^ aVisitor visitTempVector: self! ! !IRTempVector methodsFor: 'accessing' stamp: 'MarcusDenker 5/19/2011 13:26'! indexForVarNamed: aName ^vars indexOf: aName ! ! !IRTempVector methodsFor: 'testing' stamp: 'MarcusDenker 8/19/2010 08:36'! isTempVector ^true! ! !IRTempVector methodsFor: 'accessing' stamp: 'MarcusDenker 8/19/2010 08:13'! vars: anObject vars := anObject.! ! !IRTempVector methodsFor: 'accessing' stamp: 'MarcusDenker 8/19/2010 01:06'! name ^ name! ! !IRThisContextAccess methodsFor: 'visiting' stamp: 'MarcusDenker 12/14/2012 11:48'! accept: aVisitor ^ aVisitor visitThisContextAccess: self! ! !IRThisContextAccess methodsFor: 'interpret' stamp: 'JorgeRessia 4/29/2010 17:13'! executeOn: interpreter interpreter pushThisContext! ! !IRTransformTest methodsFor: 'testing - adding' stamp: 'MarcusDenker 8/18/2010 18:59'! testAddBefore | iRMethod aCompiledMethod ret | iRMethod := IRBuilder new pushLiteral: 1; returnTop; ir. (iRMethod allSequences last) last delete. (iRMethod allSequences last) last delete. ret := (IRInstruction returnTop). (iRMethod allSequences last) add: ret. (iRMethod allSequences last) add: (IRInstruction pushLiteral: 2) before: ret. aCompiledMethod := iRMethod compiledMethod. self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2]. ! ! !IRTransformTest methodsFor: 'testing - adding' stamp: 'MarcusDenker 8/18/2010 18:54'! testAdd | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 1; returnTop; ir. (iRMethod allSequences last) last delete. (iRMethod allSequences last) last delete. (iRMethod allSequences last) add: (IRInstruction pushLiteral: 2). (iRMethod allSequences last) add: (IRInstruction returnTop). aCompiledMethod := iRMethod compiledMethod. self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2]. ! ! !IRTransformTest methodsFor: 'testing - adding' stamp: 'MarcusDenker 8/18/2010 18:59'! testAddIntructionsBeforeFromLList | iRMethod aCompiledMethod push llist col | iRMethod := IRBuilder new pushLiteral: 1; returnTop; ir. push := (iRMethod allSequences last) at: (iRMethod allSequences size - 1) . llist := LinkedList new. llist add: (IRInstruction pushLiteral: 2). llist add: (IRInstruction returnTop). col := llist asOrderedCollection. (iRMethod allSequences last) addInstructions: col before: push. aCompiledMethod := iRMethod compiledMethod. self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2]. ! ! !IRTransformTest methodsFor: 'testing - adding' stamp: 'MarcusDenker 8/18/2010 18:52'! testReplace | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 1; returnTop; ir. (iRMethod allSequences last first) replaceWith: (IRInstruction pushLiteral: 2). aCompiledMethod := iRMethod compiledMethod. self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2]. ! ! !IRTransformTest methodsFor: 'testing - enumeration' stamp: 'MarcusDenker 7/16/2012 16:07'! testAllInstructions | ir | ir := IRBuilderTest new testPushTempTemp. self assert: ir allInstructions last isReturn.! ! !IRTransformTest methodsFor: 'testing - adding' stamp: 'MarcusDenker 8/18/2010 18:54'! testAddIntructionsBefore | iRMethod aCompiledMethod push | iRMethod := IRBuilder new pushLiteral: 1; returnTop; ir. push := (iRMethod allSequences last) at: (iRMethod allSequences size - 1) . (iRMethod allSequences last) addInstructions: {(IRInstruction pushLiteral: 2). (IRInstruction returnTop)} before: push. aCompiledMethod := iRMethod compiledMethod. self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2]. ! ! !IRTransformTest methodsFor: 'testing - enumeration' stamp: 'MarcusDenker 7/16/2012 16:07'! testAllTempAccessInstructions | ir | ir := IRBuilderTest new testPushTempTemp. self assert: ir allTempAccessInstructions size = 1.! ! !IRTransformTest methodsFor: 'testing - adding' stamp: 'MarcusDenker 8/18/2010 18:59'! testAddIntructions | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 1; returnTop; ir. (iRMethod allSequences last) last delete. (iRMethod allSequences last) last delete. (iRMethod allSequences last) addInstructions: {(IRInstruction pushLiteral: 2). (IRInstruction returnTop)}. aCompiledMethod := iRMethod compiledMethod. self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2]. ! ! !IRTransformTest methodsFor: 'testing - adding' stamp: 'MarcusDenker 8/18/2010 18:52'! testReplaceInstr | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 1; returnTop; ir. (iRMethod allSequences last first) replaceWithInstructions: {(IRInstruction pushLiteral: 2)}. aCompiledMethod := iRMethod compiledMethod. self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2]. ! ! !IRTransformTest methodsFor: 'testing - adding' stamp: 'MarcusDenker 9/20/2013 15:18'! testDelete | iRMethod aCompiledMethod | iRMethod := IRBuilder new pushLiteral: 1; pushLiteral: 2; returnTop; ir. ((iRMethod allSequences last) detect: [:each | each isPushLiteral: [:c | c == 2]]) delete. aCompiledMethod := iRMethod compiledMethod. self should: [(aCompiledMethod valueWithReceiver: nil arguments: #() ) = 1]. ! ! !IRTranslator commentStamp: 'ajh 3/25/2003 00:26'! I interpret IRMethod instructions, sending the appropriate bytecode messages to my BytecodeGenerator (gen). I hold some messages back in pending awaiting certain sequences of them that can be consolidated into single bytecode instructions, otherwise the pending messages are executed in order as if they were executed when they first appeared.! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:27'! send: selector self doPending. gen send: selector. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'priv pending' stamp: 'MarcusDenker 12/20/2012 17:29'! doPending "execute pending instructions. we hand the IR instruction over so the backend can fill the bytecode offset. (mapBytesTo:)" | assoc | [pending isEmpty] whileFalse: [ assoc := pending removeFirst. assoc value "message" sendTo: gen. gen mapBytesTo: assoc key ].! ! !IRTranslator methodsFor: 'instructions' stamp: 'JorgeRessia 4/29/2010 17:09'! pushReceiver ^ self addPending: (Message selector: #pushReceiver) ! ! !IRTranslator methodsFor: 'interpret' stamp: 'TestRunner 12/21/2009 10:24'! interpretInstruction: irInstruction currentInstr := irInstruction. super interpretInstruction: irInstruction. ! ! !IRTranslator methodsFor: 'interpret' stamp: 'MarcusDenker 5/14/2013 17:07'! interpret: anIr self pushScope: anIr. anIr optimize. gen irPrimitive: anIr irPrimitive. gen numArgs: anIr numArgs. gen properties: anIr properties. gen numTemps: (anIr tempMap size). gen additionalLiterals: anIr additionalLiterals. gen forceLongForm: anIr forceLongForm. super interpret: anIr. ! ! !IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/22/2003 21:06'! pendingSelector pending isEmpty ifTrue: [^ nil]. ^ pending last value "message" selector! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 4/13/2010 18:17'! storeInstVar: index self addPending: (Message selector: #storeInstVar: argument: index)! ! !IRTranslator methodsFor: 'instructions' stamp: 'JorgeRessia 5/20/2010 09:58'! popScope currentScope size = 1 ifFalse: [currentScope pop] ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:26'! pushConsArray: aSize self doPending. gen pushConsArray: aSize. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'initialization' stamp: 'MarcusDenker 5/27/2013 16:04'! initialize gen := self compilationContext bytecodeGeneratorClass new . trailer := CompiledMethodTrailer empty. currentScope := Stack new. tempVectorStack := Stack new. ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:27'! send: selector toSuperOf: behavior self doPending. gen send: selector toSuperOf: behavior. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'results' stamp: 'MarcusDenker 8/12/2010 15:08'! compiledMethodWith: aTrailer ^ gen compiledMethodWith: aTrailer! ! !IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/22/2003 21:06'! pendingSelector: selector pending last value "message" setSelector: selector! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 4/13/2010 18:15'! pushInstVar: index self addPending: (Message selector: #pushInstVar: argument: index) ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:27'! pushRemoteTemp: name inVector: tempVectorName | tempIndex tempVectorIndex tempVector | tempVector := tempVectorStack detect: [:each | each name = tempVectorName]. tempVectorIndex := tempVector indexForVarNamed: name. tempIndex := self currentScope indexForVarNamed: tempVectorName. self doPending. gen pushRemoteTemp: tempVectorIndex inVectorAt: tempIndex. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'instructions' stamp: 'JorgeRessia 6/12/2010 09:05'! pragmas: aCollection gen pragmas: aCollection! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 8/19/2010 20:23'! storeTemp: aString self addPending: (Message selector: #storeTemp: argument: (self currentScope indexForVarNamed: aString) )! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 4/13/2010 18:17'! storeIntoLiteralVariable: assoc self addPending: (Message selector: #storeIntoLiteralVariable: argument: assoc)! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 6/12/2012 21:57'! label: seqNum pending := OrderedCollection new. gen label: seqNum. ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:31'! pushNewArray: aSize self doPending. gen pushNewArray: aSize. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 8/12/2010 14:29'! pushThisContext self addPending: (Message selector: #pushThisContext) ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:26'! pushDup self doPending. gen pushDup. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'initialize' stamp: 'MarcusDenker 8/12/2010 14:39'! trailer: aTrailer trailer := aTrailer! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 4/17/2013 17:04'! goto: seqNum self doPending. gen goto: seqNum. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'interpret' stamp: 'JorgeRessia 6/12/2010 09:31'! interpretAll: irSequences irSequences withIndexDo: [:seq :i | seq orderNumber: i]. super interpretAll: irSequences. ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:27'! returnTop #pushReceiver == self pendingSelector ifTrue: [ self pendingSelector: #returnReceiver. self doPending. ^self popScopeIfRequired. ]. #pushLiteral: == self pendingSelector ifTrue: [ self pendingSelector: #returnConstant:. self doPending. ^self popScopeIfRequired. ]. #pushInstVar: == self pendingSelector ifTrue: [ self pendingSelector: #returnInstVar:. self doPending. ^self popScopeIfRequired. ]. self doPending. self popScopeIfRequired. gen returnTop. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 4/17/2013 17:03'! if: bool goto: seqNum1 otherwise: seqNum2 self doPending. gen if: bool goto: seqNum1 otherwise: seqNum2. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'private' stamp: 'JorgeRessia 4/29/2010 16:57'! currentScope ^currentScope top! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 4/13/2010 18:35'! pushLiteral: object self addPending: (Message selector: #pushLiteral: argument: object)! ! !IRTranslator methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 16:03'! compilationContext ^compilationContext ifNil: [ compilationContext := CompilationContext default ]! ! !IRTranslator methodsFor: 'results' stamp: 'MarcusDenker 6/6/2012 17:55'! compiledMethod ^ gen compiledMethodWith: trailer! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:26'! popTop "if last was storeTemp, storeInstVar storeIntoLiteralVariable then convert to storePopTemp, storePopInstVar storePopIntoLiteralVariable" #storeTemp: == self pendingSelector ifTrue: [ self pendingSelector: #storePopTemp:. ^ self doPending. ]. #storeInstVar: == self pendingSelector ifTrue: [ self pendingSelector: #storePopInstVar:. ^ self doPending.]. #storeIntoLiteralVariable: == self pendingSelector ifTrue:[ self pendingSelector: #storePopIntoLiteralVariable:. ^ self doPending.]. #storeRemoteTemp:inVectorAt: == self pendingSelector ifTrue:[ self pendingSelector: #storePopRemoteTemp:inVectorAt:. ^ self doPending.]. "otherwise do normal pop" self doPending. gen popTop. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:26'! pushClosureCopyCopiedValues: copiedValues args: args jumpTo: labelSymbol self doPending. copiedValues do: [:name | self pushTemp: name]. gen pushClosureCopyNumCopiedValues: copiedValues size numArgs: args size to: currentInstr destination orderNumber. self pushScope: currentInstr. currentInstr definedTemps do: [ :each | gen pushLiteral: nil ]. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:27'! pushTemp: aSymbol self doPending. gen pushTemp: (self currentScope indexForVarNamed: aSymbol). gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'instructions' stamp: 'JorgeRessia 5/20/2010 11:20'! popScopeIfRequired self currentScope isPushClosureCopy ifFalse: [^nil]. (((currentInstr = currentInstr sequence last) or: [currentInstr = (currentInstr sequence at: currentInstr sequence size - 1)]) and: [ currentInstr sequence = self currentScope lastBlockSequence ] ) ifTrue: [self popScope]. ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 4/13/2010 18:15'! pushLiteralVariable: object self addPending: (Message selector: #pushLiteralVariable: argument: object)! ! !IRTranslator methodsFor: 'accessing' stamp: 'MarcusDenker 5/27/2013 16:00'! compilationContext: aContext compilationContext := aContext! ! !IRTranslator methodsFor: 'priv pending' stamp: 'ajh 6/22/2003 14:54'! addPending: message pending addLast: currentInstr -> message! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 8/21/2010 16:42'! pushScope: anIRBlockOrMethod currentScope push: anIRBlockOrMethod! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:26'! createTempVectorNamed: name withVars: vars self doPending. tempVectorStack push: currentInstr. self pushNewArray: vars size. self storeTemp: name. self popTop. gen mapBytesTo: currentInstr. ! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 6/13/2012 13:59'! storeRemoteTemp: name inVector: tempVectorName | tempIndex tempVectorIndex tempVector | tempVector := tempVectorStack detect: [:each | each name = tempVectorName]. tempVectorIndex := tempVector indexForVarNamed: name. tempIndex := self currentScope indexForVarNamed: tempVectorName. self addPending: (Message selector: #storeRemoteTemp:inVectorAt: arguments: (Array with: tempVectorIndex with: tempIndex))! ! !IRTranslator methodsFor: 'instructions' stamp: 'MarcusDenker 12/20/2012 17:25'! blockReturnTop self doPending. self popScope. gen blockReturnTop. gen mapBytesTo: currentInstr. ! ! !IRVisitor commentStamp: ''! I am a generic visitor implementation for the OpalCompiler IR! !IRVisitor methodsFor: 'visiting' stamp: ''! visitReceiverAccess: aReceiverAccess! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitPushClosureCopy: aPushClosureCopy! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitJumpIf: aJumpIf! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitSend: aSend! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitJump: aJump! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitLiteralVariableAccess: aLiteralVariableAccess! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitTempAccess: aTempAccess! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitInstVarAccess: anInstVarAccess! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitThisContextAccess: aThisContextAccess! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitReturn: aReturn! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitPop: aPop! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitPushArray: aPushArray! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitPushDup: aPushDup! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitSequence: anIRSequence anIRSequence do: [ :instruction | instruction accept: self ]. ^ anIRSequence! ! !IRVisitor methodsFor: 'visiting' stamp: 'ToonVerwaest 3/27/2011 19:31'! visitMethod: aMethod aMethod startSequence withAllSuccessorsDo: [ :seq | seq do: [ :instruction | instruction accept: self ]]. ^ aMethod! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitPushLiteral: aPushLiteral! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitRemoteTempAccess: aRemoteTempAccess! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitTempVector: aTempVector! ! !IRVisitor methodsFor: 'visiting' stamp: ''! visitBlockReturnTop: aBlockReturnTop! ! !IRVisitor class methodsFor: 'instance creation' stamp: 'MarcusDenker 6/6/2012 13:41'! on: anIRMethod ^self new visitMethod: anIRMethod; yourself.! ! !ISO885915TextConverter commentStamp: ''! Text converter for ISO 8859-15. An international encoding used in Western Europe, similar to ISO 8859-1 but adds the Euro symbol and drops others like one quarter.! !ISO885915TextConverter class methodsFor: 'initialization' stamp: 'pmm 8/16/2010 10:58'! initialize self initializeTables! ! !ISO885915TextConverter class methodsFor: 'accessing' stamp: 'pmm 8/16/2010 10:30'! languageEnvironment ^Latin9Environment! ! !ISO885915TextConverter class methodsFor: 'accessing' stamp: 'pmm 8/16/2010 10:30'! encodingNames ^ #('iso-8859-15') copy ! ! !ISO885915TextConverter class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 21:38'! byteToUnicodeSpec "ByteTextConverter generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-15.TXT'" ^ #( nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 16r00A0 16r00A1 16r00A2 16r00A3 16r20AC 16r00A5 16r0160 16r00A7 16r0161 16r00A9 16r00AA 16r00AB 16r00AC 16r00AD 16r00AE 16r00AF 16r00B0 16r00B1 16r00B2 16r00B3 16r017D 16r00B5 16r00B6 16r00B7 16r017E 16r00B9 16r00BA 16r00BB 16r0152 16r0153 16r0178 16r00BF 16r00C0 16r00C1 16r00C2 16r00C3 16r00C4 16r00C5 16r00C6 16r00C7 16r00C8 16r00C9 16r00CA 16r00CB 16r00CC 16r00CD 16r00CE 16r00CF 16r00D0 16r00D1 16r00D2 16r00D3 16r00D4 16r00D5 16r00D6 16r00D7 16r00D8 16r00D9 16r00DA 16r00DB 16r00DC 16r00DD 16r00DE 16r00DF 16r00E0 16r00E1 16r00E2 16r00E3 16r00E4 16r00E5 16r00E6 16r00E7 16r00E8 16r00E9 16r00EA 16r00EB 16r00EC 16r00ED 16r00EE 16r00EF 16r00F0 16r00F1 16r00F2 16r00F3 16r00F4 16r00F5 16r00F6 16r00F7 16r00F8 16r00F9 16r00FA 16r00FB 16r00FC 16r00FD 16r00FE 16r00FF )! ! !ISO88592TextConverter commentStamp: ''! Text converter for ISO 8859-2. An international encoding used in Eastern Europe.! !ISO88592TextConverter class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 21:46'! initialize self initializeTables! ! !ISO88592TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:48'! languageEnvironment ^Latin2Environment! ! !ISO88592TextConverter class methodsFor: 'utilities' stamp: 'yo 1/18/2005 09:17'! encodingNames ^ #('iso-8859-2') copy ! ! !ISO88592TextConverter class methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 3/7/2012 21:39'! byteToUnicodeSpec "ByteTextConverter generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-2.TXT'" ^ #( nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 16r00A0 16r0104 16r02D8 16r0141 16r00A4 16r013D 16r015A 16r00A7 16r00A8 16r0160 16r015E 16r0164 16r0179 16r00AD 16r017D 16r017B 16r00B0 16r0105 16r02DB 16r0142 16r00B4 16r013E 16r015B 16r02C7 16r00B8 16r0161 16r015F 16r0165 16r017A 16r02DD 16r017E 16r017C 16r0154 16r00C1 16r00C2 16r0102 16r00C4 16r0139 16r0106 16r00C7 16r010C 16r00C9 16r0118 16r00CB 16r011A 16r00CD 16r00CE 16r010E 16r0110 16r0143 16r0147 16r00D3 16r00D4 16r0150 16r00D6 16r00D7 16r0158 16r016E 16r00DA 16r0170 16r00DC 16r00DD 16r0162 16r00DF 16r0155 16r00E1 16r00E2 16r0103 16r00E4 16r013A 16r0107 16r00E7 16r010D 16r00E9 16r0119 16r00EB 16r011B 16r00ED 16r00EE 16r010F 16r0111 16r0144 16r0148 16r00F3 16r00F4 16r0151 16r00F6 16r00F7 16r0159 16r016F 16r00FA 16r0171 16r00FC 16r00FD 16r0163 16r02D9 )! ! !ISO88597TextConverter commentStamp: ''! Text converter for ISO 8859-7. An international encoding used for Greek. ! !ISO88597TextConverter class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 21:46'! initialize self initializeTables! ! !ISO88597TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:49'! languageEnvironment ^GreekEnvironment! ! !ISO88597TextConverter class methodsFor: 'utilities' stamp: 'yo 2/10/2004 06:32'! encodingNames ^ #('iso-8859-7' 'greek-iso-8859-8bit') copy ! ! !ISO88597TextConverter class methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 3/7/2012 21:39'! byteToUnicodeSpec "ByteTextConverter generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-7.TXT'" ^ #( nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 16r00A0 16r2018 16r2019 16r00A3 16r20AC 16r20AF 16r00A6 16r00A7 16r00A8 16r00A9 16r037A 16r00AB 16r00AC 16r00AD nil 16r2015 16r00B0 16r00B1 16r00B2 16r00B3 16r0384 16r0385 16r0386 16r00B7 16r0388 16r0389 16r038A 16r00BB 16r038C 16r00BD 16r038E 16r038F 16r0390 16r0391 16r0392 16r0393 16r0394 16r0395 16r0396 16r0397 16r0398 16r0399 16r039A 16r039B 16r039C 16r039D 16r039E 16r039F 16r03A0 16r03A1 nil 16r03A3 16r03A4 16r03A5 16r03A6 16r03A7 16r03A8 16r03A9 16r03AA 16r03AB 16r03AC 16r03AD 16r03AE 16r03AF 16r03B0 16r03B1 16r03B2 16r03B3 16r03B4 16r03B5 16r03B6 16r03B7 16r03B8 16r03B9 16r03BA 16r03BB 16r03BC 16r03BD 16r03BE 16r03BF 16r03C0 16r03C1 16r03C2 16r03C3 16r03C4 16r03C5 16r03C6 16r03C7 16r03C8 16r03C9 16r03CA 16r03CB 16r03CC 16r03CD 16r03CE nil )! ! !ISOLanguageDefinition commentStamp: 'TorstenBergmann 1/31/2014 10:08'! The language definitions from International Organization for Standardization! !ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 8/15/2003 13:13'! language ^language! ! !ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'! iso2: aString iso2 := aString ifEmpty: [nil] ifNotEmpty: [aString]! ! !ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:21'! iso3 ^iso3 ifNil: ['']! ! !ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 8/15/2003 13:40'! language: aString language := aString! ! !ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'! iso3Alternate: aString iso3Alternate := aString ifEmpty: [nil] ifNotEmpty: [aString]! ! !ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:20'! iso2 ^iso2 ifNil: [self iso3]! ! !ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'! iso3: aString iso3 := aString ifEmpty: [nil] ifNotEmpty: [aString]! ! !ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 6/30/2004 15:47'! iso3Alternate ^iso3Alternate ifNil: ['']! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:13'! initISO3LanguageTable "ISOLanguageDefinition initIso3LanguageTable" | table | table := ISOLanguageDefinition readISOLanguagesFrom: ISOLanguageDefinition isoLanguages readStream. table addAll: self extraISO3Definitions. ^table! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 13:57'! iso3166Codes "http://www.unicode.org/onlinedat/countries.html" ^'ÅLAND ISLANDS AX         AFGHANISTAN AF AFG 004         ALBANIA AL ALB 008 CTRY_ALBANIA 355     ALGERIA DZ DZA 012 CTRY_ALGERIA 213 verArabic 16 AMERICAN SAMOA AS ASM 016         ANDORRA AD AND 020         ANGOLA AO AGO 024         ANGUILLA AI AIA 660         ANTARCTICA AQ ATA 010         ANTIGUA AND BARBUDA AG ATG 028         ARGENTINA AR ARG 032 CTRY_ARGENTINA 54     ARMENIA AM ARM 051 CTRY_ARMENIA 374 verArmenian 84 ARUBA AW ABW 533         AUSTRALIA AU AUS 036 CTRY_AUSTRALIA 61 verAustralia 15 AUSTRIA AT AUT 040 CTRY_AUSTRIA 43 verAustria 92 AZERBAIJAN AZ AZE 031 CTRY_AZERBAIJAN 994     BAHAMAS BS BHS 044         BAHRAIN BH BHR 048 CTRY_BAHRAIN 973     BANGLADESH BD BGD 050     verBengali 60 BARBADOS BB BRB 052         BELARUS BY BLR 112 CTRY_BELARUS 375     BELGIUM BE BEL 056 CTRY_BELGIUM 32 verFrBelgium, verFlemish 98 BELIZE BZ BLZ 084 CTRY_BELIZE 501     BENIN BJ BEN 204         BERMUDA BM BMU 060         BHUTAN BT BTN 064     verBhutan 83 BOLIVIA BO BOL 068 CTRY_BOLIVIA 591     BOSNIA AND HERZEGOVINA BA BIH 070         BOTSWANA BW BWA 072         BOUVET ISLAND BV BVT 074         BRAZIL BR BRA 076 CTRY_BRAZIL 55 verBrazil 71 BRITISH INDIAN OCEAN TERRITORY IO IOT 086         BRUNEI DARUSSALAM BN BRN 096 CTRY_BRUNEI_DARUSSALAM 673     BULGARIA BG BGR 100 CTRY_BULGARIA 359 verBulgaria  72 BURKINA FASO BF BFA 854         BURUNDI BI BDI 108         CAMBODIA KH KHM 116         CAMEROON CM CMR 120         CANADA CA CAN 124 CTRY_CANADA 2 verFrCanada, verEndCanada 82 CAPE VERDE CV CPV 132         CAYMAN ISLANDS KY CYM 136         CENTRAL AFRICAN REPUBLIC CF CAF 140         CHAD TD TCD 148         CHILE CL CHL 152 CTRY_CHILE 56     CHINA CN CHN 156 CTRY_PRCHINA 86 verChina 52 CHRISTMAS ISLAND CX CXR 162         COCOS (KEELING) ISLANDS CC CCK 166         COLOMBIA CO COL 170 CTRY_COLOMBIA 57     COMOROS KM COM 174         CONGO CG COG 178         CONGO, THE DEMOCRATIC REPUBLIC OF THE CD         COOK ISLANDS CK COK 184         COSTA RICA CR CRI 188 CTRY_COSTA_RICA 506     COTE D''IVOIRE CI CIV 384         CROATIA (local name: Hrvatska) HR HRV 191 CTRY_CROATIA 385 verCroatia, verYugoCroatian 68 (c), 25 (y) CUBA CU CUB 192         CYPRUS CY CYP 196     verCyprus 23 CZECH REPUBLIC CZ CZE 203 CTRY_CZECH 420 verCzech  56 DENMARK DK DNK 208 CTRY_DENMARK 45 verDenmark(da), verFaeroeIsl(fo) 9(da), 47(fo) DJIBOUTI DJ DJI 262         DOMINICA DM DMA 212         DOMINICAN REPUBLIC DO DOM 214 CTRY_DOMINICAN_REPUBLIC 1     EAST TIMOR TL TLS 626         ECUADOR EC ECU 218 CTRY_ECUADOR 593     EGYPT EG EGY 818 CTRY_EGYPT 20 verArabic 16 EL SALVADOR SV SLV 222 CTRY_EL_SALVADOR 503     EQUATORIAL GUINEA GQ GNQ 226         ERITREA ER ERI 232         ESTONIA EE EST 233 CTRY_ESTONIA 372 verEstonia 44 ETHIOPIA ET ETH 210         FALKLAND ISLANDS (MALVINAS) FK FLK 238         FAROE ISLANDS FO FRO 234 CTRY_FAEROE_ISLANDS 298     FIJI FJ FJI 242         FINLAND FI FIN 246 CTRY_FINLAND 358 verFinland 17 FRANCE FR FRA 250 CTRY_FRANCE 33 verFrance 1 FRANCE, METROPOLITAN FX FXX 249         FRENCH GUIANA GF GUF 254         FRENCH POLYNESIA PF PYF 258         FRENCH SOUTHERN TERRITORIES TF ATF 260         GABON GA GAB 266         GAMBIA GM GMB 270         GEORGIA GE GEO 268 CTRY_GEORGIA 995 verGeorgian 85 GERMANY DE DEU 276 CTRY_GERMANY 49 verGermany 3 GHANA GH GHA 288         GIBRALTAR GI GIB 292         GREECE GR GRC 300 CTRY_GREECE 30 verGreece, verGreecePoly 20, 40 GREENLAND GL GRL 304     verGreenland 107 GRENADA GD GRD 308         GUADELOUPE GP GLP 312         GUAM GU GUM 316         GUATEMALA GT GTM 320 CTRY_GUATEMALA 502     GUINEA GN GIN 324         GUINEA-BISSAU GW GNB 624         GUYANA GY GUY 328         HAITI HT HTI 332         HEARD ISLAND & MCDONALD ISLANDS HM HMD 334         HONDURAS HN HND 340 CTRY_HONDURAS 504     HONG KONG HK HKG 344 CTRY_HONG_KONG 852     HUNGARY HU HUN 348 CTRY_HUNGARY 36 verHungary 43 ICELAND IS ISL 352 CTRY_ICELAND 354 verIceland 21 INDIA IN IND 356 CTRY_INDIA 91 verIndiaHindi(hi) 33 INDONESIA ID IDN 360 CTRY_INDONESIA 62     IRAN, ISLAMIC REPUBLIC OF IR IRN 364 CTRY_IRAN 981 verIran 48 IRAQ IQ IRQ 368 CTRY_IRAQ 964 verArabic 16 IRELAND IE IRL 372 CTRY_IRELAND 353 verIreland 50 ISRAEL IL ISR 376 CTRY_ISRAEL 972 verIsrael 13 ITALY IT ITA 380 CTRY_ITALY 39 verItaly 4 JAMAICA JM JAM 388 CTRY_JAMAICA 1     JAPAN JP JPN 392 CTRY_JAPAN 81 verJapan 14 JORDAN JO JOR 400 CTRY_JORDAN 962     KAZAKHSTAN KZ KAZ 398 CTRY_KAZAKSTAN 7     KENYA KE KEN 404 CTRY_KENYA 254     KIRIBATI KI KIR 296         KOREA, DEMOCRATIC PEOPLE''S REPUBLIC OF KP PRK 408     verKorea 51 KOREA, REPUBLIC OF KR KOR 410 CTRY_SOUTH_KOREA 82 verKorea   KUWAIT KW KWT 414 CTRY_KUWAIT 965     KYRGYZSTAN KG KGZ 417 CTRY_KYRGYZSTAN 996     LAO PEOPLE''S DEMOCRATIC REPUBLIC LA LAO 418         LATVIA LV LVA 428 CTRY_LATVIA 371 verLatvia 45 LEBANON LB LBN 422 CTRY_LEBANON 961     LESOTHO LS LSO 426         LIBERIA LR LBR 430         LIBYAN ARAB JAMAHIRIYA LY LBY 434 CTRY_LIBYA 218 verArabic 16 LIECHTENSTEIN LI LIE 438 CTRY_LIECHTENSTEIN 41     LITHUANIA LT LTU 440 CTRY_LITHUANIA 370 verLithuania 41 LUXEMBOURG LU LUX 442 CTRY_LUXEMBOURG 352 verFrBelgiumLux 6 MACAU MO MAC 446 CTRY_MACAU 853     MACEDONIA, THE FORMER YUGOSLAV REPUBLIC OF MK MKD 807 CTRY_MACEDONIA 389 verMacedonian   MADAGASCAR MG MDG 450         MALAWI MW MWI 454         MALAYSIA MY MYS 458 CTRY_MALAYSIA 60     MALDIVES MV MDV 462 CTRY_MALDIVES 960     MALI ML MLI 466         MALTA MT MLT 470     verMalta 22 MARSHALL ISLANDS MH MHL 584         MARTINIQUE MQ MTQ 474         MAURITANIA MR MRT 478         MAURITIUS MU MUS 480         MAYOTTE YT MYT 175         MEXICO MX MEX 484 CTRY_MEXICO 52     MICRONESIA, FEDERATED STATES OF FM FSM 583         MOLDOVA, REPUBLIC OF MD MDA 498         MONACO MC MCO 492 CTRY_MONACO 33     MONGOLIA MN MNG 496 CTRY_MONGOLIA 976     MONTSERRAT MS MSR 500         MOROCCO MA MAR 504 CTRY_MOROCCO 212 verArabic 16 MOZAMBIQUE MZ MOZ 508         MYANMAR MM MMR 104         NAMIBIA NA NAM 516         NAURU NR NRU 520         NEPAL NP NPL 524     verNepal 106 NETHERLANDS NL NLD 528 CTRY_NETHERLANDS 31 verNetherlands 5 NETHERLANDS ANTILLES AN ANT 530         NEW CALEDONIA NC NCL 540         NEW ZEALAND NZ NZL 554 CTRY_NEW_ZEALAND 64     NICARAGUA NI NIC 558 CTRY_NICARAGUA 505     NIGER NE NER 562         NIGERIA NG NGA 566         NIUE NU NIU 570         NORFOLK ISLAND NF NFK 574         NORTHERN MARIANA ISLANDS MP MNP 580         NORWAY NO NOR 578 CTRY_NORWAY 47 verNorway 12 OMAN OM OMN 512 CTRY_OMAN 968     PAKISTAN PK PAK 586 CTRY_PAKISTAN 92 verPakistanUrdu, verPunjabi 34 (U), 95 (P) PALAU PW PLW 585         PANAMA PA PAN 591 CTRY_PANAMA 507     PALESTINIAN TERRITORY, OCCUPIED PS     PAPUA NEW GUINEA PG PNG 598         PARAGUAY PY PRY 600 CTRY_PARAGUAY 595     PERU PE PER 604 CTRY_PERU 51     PHILIPPINES PH PHL 608 CTRY_PHILIPPINES 63     PITCAIRN PN PCN 612         POLAND PL POL 616 CTRY_POLAND 48 verPoland 42 PORTUGAL PT PRT 620 CTRY_PORTUGAL 351 verPortugal 10 PUERTO RICO PR PRI 630 CTRY_PUERTO_RICO 1     QATAR QA QAT 634 CTRY_QATAR 974     REUNION RE REU 638         ROMANIA RO ROU* 642 CTRY_ROMANIA 40 verRomania 39 RUSSIAN FEDERATION RU RUS 643 CTRY_RUSSIA 7 verRussia 49 RWANDA RW RWA 646         SAINT KITTS AND NEVIS KN KNA 659         SAINT LUCIA LC LCA 662         SAINT VINCENT AND THE GRENADINES VC VCT 670         SAMOA WS WSM 882         SAN MARINO SM SMR 674         SAO TOME AND PRINCIPE ST STP 678         SAUDI ARABIA SA SAU 682 CTRY_SAUDI_ARABIA 966 verArabic 16 SENEGAL SN SEN 686         SERBIA AND MONTENEGRO CS     CTRY_SERBIA 381     SEYCHELLES SC SYC 690         SIERRA LEONE SL SLE 694         SINGAPORE SG SGP 702 CTRY_SINGAPORE 65 verSingapore 100 SLOVAKIA (Slovak Republic) SK SVK 703 CTRY_SLOVAK 421 verSlovak 57  SLOVENIA SI SVN 705 CTRY_SLOVENIA 386 verSlovenian 66 SOLOMON ISLANDS SB SLB 90         SOMALIA SO SOM 706         SOUTH AFRICA ZA ZAF 710 CTRY_SOUTH_AFRICA 27     SOUTH GEORGIA AND THE SOUTH SANDWICH ISLANDS GS     SPAIN ES ESP 724 CTRY_SPAIN 34 verSpain 8 SRI LANKA LK LKA 144         SAINT HELENA SH SHN 654         SAINT PIERRE AND MIQUELON PM SPM 666         SUDAN SD SDN 736         SURINAME SR SUR 740         SVALBARD AND JAN MAYEN ISLANDS SJ SJM 744         SWAZILAND SZ SWZ 748         SWEDEN SE SWE 752 CTRY_SWEDEN 46 verSweden 7 SWITZERLAND CH CHE 756 CTRY_SWITZERLAND 41 verFrSwiss(fr), verGrSwiss(de) 18(fr), 19(de) SYRIAN ARAB REPUBLIC SY SYR 760 CTRY_SYRIA 963     TAIWAN, PROVINCE OF CHINA TW TWN 158 CTRY_TAIWAN 886 verTaiwan 53 TAJIKISTAN TJ TJK 762         TANZANIA, UNITED REPUBLIC OF TZ TZA 834         TATARSTAN   CTRY_TATARSTAN 7     THAILAND TH THA 764 CTRY_THAILAND 66 verThailand 54 TIMOR-LESTE TL         TOGO TG TGO 768         TOKELAU TK TKL 772         TONGA TO TON 776     verTonga 88 TRINIDAD AND TOBAGO TT TTO 780 CTRY_TRINIDAD_Y_TOBAGO 1     TUNISIA TN TUN 788 CTRY_TUNISIA 216 verArabic 16 TURKEY TR TUR 792 CTRY_TURKEY 90 verTurkey 24 TURKMENISTAN TM TKM 795         TURKS AND CAICOS ISLANDS TC TCA 796         TUVALU TV TUV 798         UGANDA UG UGA 800         UKRAINE UA UKR 804 CTRY_UKRAINE 380 verUkraine  62 UNITED ARAB EMIRATES AE ARE 784 CTRY_UAE 971     UNITED KINGDOM GB GBR 826 CTRY_UNITED_KINGDOM 44 verBritain 2 UNITED STATES US USA 840 CTRY_UNITED_STATES 1 verUS 0 UNITED STATES MINOR OUTLYING ISLANDS UM UMI 581         URUGUAY UY URY 858 CTRY_URUGUAY 598     UZBEKISTAN UZ UZB 860 CTRY_UZBEKISTAN 7     VANUATU VU VUT 548         VATICAN CITY STATE (HOLY SEE) VA VAT 336         VENEZUELA VE VEN 862 CTRY_VENEZUELA 58     VIET NAM VN VNM 704 CTRY_VIET_NAM 84 verVietnam   VIRGIN ISLANDS (BRITISH) VG VGB 92         VIRGIN ISLANDS (U.S.) VI VIR 850         WALLIS AND FUTUNA ISLANDS WF WLF 876         WESTERN SAHARA EH ESH 732         YEMEN YE YEM 887 CTRY_YEMEN 967     YUGOSLAVIA YU YUG 891         ZAIRE ZR ZAR 180         ZAMBIA ZM ZMB 894         ZIMBABWE ZW ZWE 716 CTRY_ZIMBABWE 263     '! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:14'! extraISO3Definitions ^self readISOLanguagesFrom: 'jpk Japanese (Kids) ' readStream! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'yo 12/3/2004 17:46'! isoLanguages "ISO 639: 3-letter codes" ^'abk ab Abkhazian ace Achinese ach Acoli ada Adangme aar aa Afar afh Afrihili afr af Afrikaans afa Afro-Asiatic (Other) aka Akan akk Akkadian alb/sqi sq Albanian ale Aleut alg Algonquian languages tut Altaic (Other) amh am Amharic apa Apache languages ara ar Arabic arc Aramaic arp Arapaho arn Araucanian arw Arawak arm/hye hy Armenian art Artificial (Other) asm as Assamese ath Athapascan languages map Austronesian (Other) ava Avaric ave Avestan awa Awadhi aym ay Aymara aze az Azerbaijani nah Aztec ban Balinese bat Baltic (Other) bal Baluchi bam Bambara bai Bamileke languages bad Banda bnt Bantu (Other) bas Basa bak ba Bashkir baq/eus eu Basque bej Beja bem Bemba ben bn Bengali ber Berber (Other) bho Bhojpuri bih bh Bihari bik Bikol bin Bini bis bi Bislama bra Braj bre be Breton bug Buginese bul bg Bulgarian bua Buriat bur/mya my Burmese bel be Byelorussian cad Caddo car Carib cat ca Catalan cau Caucasian (Other) ceb Cebuano cel Celtic (Other) cai Central American Indian (Other) chg Chagatai cha Chamorro che Chechen chr Cherokee chy Cheyenne chb Chibcha chi/zho zh Chinese chn Chinook jargon cho Choctaw chu Church Slavic chv Chuvash cop Coptic cor Cornish cos co Corsican cre Cree mus Creek crp Creoles and Pidgins (Other) cpe Creoles and Pidgins, English-based (Other) cpf Creoles and Pidgins, French-based (Other) cpp Creoles and Pidgins, Portuguese-based (Other) cus Cushitic (Other) hr Croatian ces/cze cs Czech dak Dakota dan da Danish del Delaware din Dinka div Divehi doi Dogri dra Dravidian (Other) dua Duala dut/nla nl Dutch dum Dutch, Middle (ca. 1050-1350) dyu Dyula dzo dz Dzongkha efi Efik egy Egyptian (Ancient) eka Ekajuk elx Elamite eng en English enm English, Middle (ca. 1100-1500) ang English, Old (ca. 450-1100) esk Eskimo (Other) epo eo Esperanto est et Estonian ewe Ewe ewo Ewondo fan Fang fat Fanti fao fo Faroese fij fj Fijian fin fi Finnish fiu Finno-Ugrian (Other) fon Fon fra/fre fr French frm French, Middle (ca. 1400-1600) fro French, Old (842- ca. 1400) fry fy Frisian ful Fulah gaa Ga gae/gdh Gaelic (Scots) glg gl Gallegan lug Ganda gay Gayo gez Geez geo/kat ka Georgian deu/ger de German gmh German, Middle High (ca. 1050-1500) goh German, Old High (ca. 750-1050) gem Germanic (Other) gil Gilbertese gon Gondi got Gothic grb Grebo grc Greek, Ancient (to 1453) ell/gre el Greek, Modern (1453-) kal kl Greenlandic grn gn Guarani guj gu Gujarati hai Haida hau ha Hausa haw Hawaiian heb he Hebrew her Herero hil Hiligaynon him Himachali hin hi Hindi hmo Hiri Motu hun hu Hungarian hup Hupa iba Iban ice/isl is Icelandic ibo Igbo ijo Ijo ilo Iloko inc Indic (Other) ine Indo-European (Other) ind id Indonesian ina ia Interlingua (International Auxiliary language Association) ine Interlingue iku iu Inuktitut ipk ik Inupiak ira Iranian (Other) gai/iri ga Irish sga Irish, Old (to 900) mga Irish, Middle (900 - 1200) iro Iroquoian languages ita it Italian jpn ja Japanese jav/jaw jv/jw Javanese jrb Judeo-Arabic jpr Judeo-Persian kab Kabyle kac Kachin kam Kamba kan kn Kannada kau Kanuri kaa Kara-Kalpak kar Karen kas ks Kashmiri kaw Kawi kaz kk Kazakh kha Khasi khm km Khmer khi Khoisan (Other) kho Khotanese kik Kikuyu kin rw Kinyarwanda kir ky Kirghiz kom Komi kon Kongo kok Konkani kor ko Korean kpe Kpelle kro Kru kua Kuanyama kum Kumyk kur ku Kurdish kru Kurukh kus Kusaie kut Kutenai lad Ladino lah Lahnda lam Lamba oci oc Langue d''Oc (post 1500) lao lo Lao lat la Latin lav lv Latvian ltz Letzeburgesch lez Lezghian lin ln Lingala lit lt Lithuanian loz Lozi lub Luba-Katanga lui Luiseno lun Lunda luo Luo (Kenya and Tanzania) mac/mak mk Macedonian mad Madurese mag Magahi mai Maithili mak Makasar mlg mg Malagasy may/msa ms Malay mal Malayalam mlt ml Maltese man Mandingo mni Manipuri mno Manobo languages max Manx mao/mri mi Maori mar mr Marathi chm Mari mah Marshall mwr Marwari mas Masai myn Mayan languages men Mende mic Micmac min Minangkabau mis Miscellaneous (Other) moh Mohawk mol mo Moldavian mkh Mon-Kmer (Other) lol Mongo mon mn Mongolian mos Mossi mul Multiple languages mun Munda languages nau na Nauru nav Navajo nde Ndebele, North nbl Ndebele, South ndo Ndongo nep ne Nepali new Newari nic Niger-Kordofanian (Other) ssa Nilo-Saharan (Other) niu Niuean non Norse, Old nai North American Indian (Other) nor no Norwegian nno Norwegian (Nynorsk) nub Nubian languages nym Nyamwezi nya Nyanja nyn Nyankole nyo Nyoro nzi Nzima oji Ojibwa ori or Oriya orm om Oromo osa Osage oss Ossetic oto Otomian languages pal Pahlavi pau Palauan pli Pali pam Pampanga pag Pangasinan pan pa Panjabi pap Papiamento paa Papuan-Australian (Other) fas/per fa Persian peo Persian, Old (ca 600 - 400 B.C.) phn Phoenician pol pl Polish pon Ponape por pt Portuguese pra Prakrit languages pro Provencal, Old (to 1500) pus ps Pushto que qu Quechua roh rm Rhaeto-Romance raj Rajasthani rar Rarotongan roa Romance (Other) ron/rum ro Romanian rom Romany run rn Rundi rus ru Russian sal Salishan languages sam Samaritan Aramaic smi Sami languages smo sm Samoan sad Sandawe sag sg Sango san sa Sanskrit srd Sardinian sco Scots sel Selkup sem Semitic (Other) sr Serbian scr sh Serbo-Croatian srr Serer shn Shan sna sn Shona sid Sidamo bla Siksika snd sd Sindhi sin si Singhalese sit Sino-Tibetan (Other) sio Siouan languages sla Slavic (Other) ssw ss Siswant slk/slo sk Slovak slv sl Slovenian sog Sogdian som so Somali son Songhai wen Sorbian languages nso Sotho, Northern sot st Sotho, Southern sai South American Indian (Other) esl/spa es Spanish suk Sukuma sux Sumerian sun su Sudanese sus Susu swa sw Swahili ssw Swazi sve/swe sv Swedish syr Syriac tgl tl Tagalog tah Tahitian tgk tg Tajik tmh Tamashek tam ta Tamil tat tt Tatar tel te Telugu ter Tereno tha th Thai bod/tib bo Tibetan tig Tigre tir ti Tigrinya tem Timne tiv Tivi tli Tlingit tog to Tonga (Nyasa) ton Tonga (Tonga Islands) tru Truk tsi Tsimshian tso ts Tsonga tsn tn Tswana tum Tumbuka tur tr Turkish ota Turkish, Ottoman (1500 - 1928) tuk tk Turkmen tyv Tuvinian twi tw Twi uga Ugaritic uig ug Uighur ukr uk Ukrainian umb Umbundu und Undetermined urd ur Urdu uzb uz Uzbek vai Vai ven Venda vie vi Vietnamese vol vo Volapük vot Votic wak Wakashan languages wal Walamo war Waray was Washo cym/wel cy Welsh wol wo Wolof xho xh Xhosa sah Yakut yao Yao yap Yap yid yi Yiddish yor yo Yoruba zap Zapotec zen Zenaga zha za Zhuang zul zu Zulu zun Zuni'! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:18'! iso2Countries "ISOLanguageDefinition iso2Countries" "ISO2Countries := nil. ISO3Countries := nil" ISO2Countries ifNil: [self initISOCountries]. ^ISO2Countries! ! !ISOLanguageDefinition class methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:06'! iso3LanguageDefinition: aString ^self iso3LanguageTable at: aString! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:18'! iso3Countries "ISOLanguageDefinition iso3Countries" "ISO2Countries := nil. ISO3Countries := nil" ISO3Countries ifNil: [self initISOCountries]. ^ISO3Countries! ! !ISOLanguageDefinition class methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:06'! iso2LanguageDefinition: aString ^self iso2LanguageTable at: aString! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/21/2004 13:10'! iso3LanguageTable "ISOLanguageDefinition iso3LanguageTable" ^ISO3Table ifNil: [ISO3Table := self initISO3LanguageTable]! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:14'! extraCountryDefinitions ^{ {'Kids'. 'KIDS'. 'KIDS'.}. }! ! !ISOLanguageDefinition class methodsFor: 'initialization' stamp: 'mir 7/1/2004 18:19'! initialize "ISOLanguageDefinition initialize" ISO3Table := nil. ISO2Table := nil! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:12'! initISOCountries "ISOLanguageDefinition initISOCountries" | iso3166Table | iso3166Table := ISOLanguageDefinition buildIso3166CodesTables. ISO2Countries := Dictionary new. ISO3Countries := Dictionary new. iso3166Table do: [:entry | ISO2Countries at: (entry at: 2) put: (entry at: 1). ISO3Countries at: (entry at: 3) put: (entry at: 1)]. self extraCountryDefinitions do: [:entry | ISO2Countries at: (entry at: 2) put: (entry at: 1). ISO3Countries at: (entry at: 3) put: (entry at: 1)]! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 9/1/2005 14:06'! buildIso3166CodesTables "ISOLanguageDefinition buildIso3166CodesTables" | rawdata stream country isoa2 isoa3 unNumeric macName macCode windowsName windowsCode empty table | rawdata := self iso3166Codes. table := OrderedCollection new: 200. stream := rawdata readStream. empty := 160 asCharacter asString. [stream atEnd] whileFalse: [country := stream nextLine. isoa2 := stream nextLine. isoa3 := stream nextLine. unNumeric := stream nextLine. windowsName := stream nextLine. windowsName = empty ifTrue: [windowsName := nil]. windowsCode := stream nextLine. windowsCode = empty ifTrue: [windowsCode := nil]. macName := stream nextLine. macName = empty ifTrue: [macName := nil]. macCode := stream nextLine. macCode = empty ifTrue: [macCode := nil]. table add: { country. isoa2. isoa3. unNumeric. windowsName. windowsCode. macName. macCode. }]. ^table! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/1/2004 18:07'! readISOLanguagesFrom: stream "ISOLanguageDefinition readISOLanguagesFrom: ISOLanguageDefinition isoLanguages readStream " | languages language code3 index line | languages := Dictionary new. [stream atEnd or: [(line := stream nextLine readStream) atEnd]] whileFalse: [ language := ISOLanguageDefinition new. code3 := line upTo: Character tab. (index := code3 indexOf: $/) > 0 ifTrue: [ language iso3: (code3 copyFrom: 1 to: index-1). language iso3Alternate: (code3 copyFrom: index+1 to: code3 size)] ifFalse: [language iso3: code3]. language iso2: (line upTo: Character tab); language: line upToEnd. languages at: language iso3 put: language]. ^languages! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/1/2004 18:14'! iso2LanguageTable "ISOLanguageDefinition iso2LanguageTable" ISO2Table ifNotNil: [^ISO2Table]. ISO2Table := Dictionary new: self iso3LanguageTable basicSize. self iso3LanguageTable do: [:entry | ISO2Table at: entry iso2 put: entry]. ^ISO2Table! ! !IVsAndClassVarNamesConflictTest commentStamp: 'TorstenBergmann 2/5/2014 08:36'! SUnit tests to tests conflicts for instance variables and class variable names! !IVsAndClassVarNamesConflictTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testOneCanProceedWhenIntroducingClasseVariablesBeginingWithLowerCaseCharacters [ Object subclass: className instanceVariableNames: '' classVariableNames: 'a BVariableName' poolDictionaries: '' category: self class category ] on: Exception do: [ :ex | ex resume ]. self assert: (Smalltalk keys includes: className)! ! !IVsAndClassVarNamesConflictTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testOneCanProceedWhenIntroducingCapitalizedInstanceVariables [ Object subclass: className instanceVariableNames: 'X Y' classVariableNames: '' poolDictionaries: '' category: self class category ] on: Exception do: [ :ex | ex resume ]. self assert: (Smalltalk keys includes: className)! ! !IVsAndClassVarNamesConflictTest methodsFor: 'setup' stamp: 'lr 3/14/2010 21:13'! tearDown | cl | super tearDown. cl := Smalltalk globals at: className ifAbsent: [ ^ self ]. cl removeFromChanges; removeFromSystemUnlogged! ! !IVsAndClassVarNamesConflictTest methodsFor: 'setup' stamp: 'oscar.nierstrasz 10/18/2009 17:11'! setUp super setUp. className := #ClassForTestToBeDeleted.! ! !IconListModel commentStamp: ''! An IconListModel is a spec model for icon list! !IconListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! getIconFor: anItem ^ iconHolder value cull: anItem cull: self! ! !IconListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! icons: aBlock "Set a block which takes an item as argument and returns the icon to display in the list" iconHolder value: aBlock! ! !IconListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! icons "Return the block which takes an item as argument and returns the icon to display in the list" ^ iconHolder value! ! !IconListModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. iconHolder := [:item | nil ] asReactiveVariable.! ! !IconListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:51'! whenIconsChanged: aBlock iconHolder whenChangedDo: aBlock ! ! !IconListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 13:38'! defaultSpec ^ #(IconListAdapter adapt: #(model))! ! !IconListModel class methodsFor: 'example' stamp: 'EstebanLorenzano 5/14/2013 09:44'! example self new icons: [:e | Smalltalk ui icons forwardIcon ]; items: (1 to: 10) asArray; openWithSpec! ! !IconListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:21'! adapterName ^ #IconListAdapter! ! !IconSetChanged commentStamp: ''! I'm announced when an IconSet has been changed. ! !IconicButton commentStamp: ''! A "Simple Button" in which the appearance is provided by a Form.! !IconicButton methodsFor: 'accessing' stamp: 'YuriyTymchuk 12/20/2013 15:13'! graphicalMorph ^ graphicalMorph! ! !IconicButton methodsFor: 'accessing' stamp: 'sw 11/29/1999 20:56'! shedSelvedge self extent: (self extent - (6@6))! ! !IconicButton methodsFor: 'initialization' stamp: 'ar 12/15/2001 14:43'! buttonSetup self actWhen: #buttonUp. self cornerStyle: #rounded. self borderNormal. self on: #mouseEnter send: #borderRaised to: self. self on: #mouseLeave send: #borderNormal to: self. self on: #mouseLeaveDragging send: #borderNormal to: self. self on: #mouseDown send: #borderInset to: self. self on: #mouseUp send: #borderRaised to: self.! ! !IconicButton methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/29/2007 10:55'! handlesMouseOver: anEvent "Answer true, otherwise what is all that #mouseEnter:/#mouseLeave: stuff about?" ^true! ! !IconicButton methodsFor: 'initialization' stamp: 'sw 11/29/1999 20:52'! initialize super initialize. self useSquareCorners! ! !IconicButton methodsFor: 'accessing' stamp: 'StephaneDucasse 5/17/2012 16:33'! defaultGraphics ^ DefaultGraphics ! ! !IconicButton methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/23/2008 17:19'! mouseOverBorderStyle "Answer the border style to use whilst the mouse is over the receiver." ^self valueOfProperty: #mouseOverBorderStyle ifAbsent: [BorderStyle thinGray]! ! !IconicButton methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:38'! borderInset self borderStyle: (BorderStyle inset width: 2).! ! !IconicButton methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 8/23/2011 14:31'! interactSelector ^ #interact! ! !IconicButton methodsFor: 'initialization' stamp: 'ar 12/18/2001 21:22'! stationarySetup self actWhen: #startDrag. self cornerStyle: #rounded. self borderNormal. self on: #mouseEnter send: #borderThick to: self. self on: #mouseDown send: nil to: nil. self on: #mouseLeave send: #borderNormal to: self. self on: #mouseLeaveDragging send: #borderNormal to: self. self on: #mouseUp send: #borderThick to: self.! ! !IconicButton methodsFor: 'geometry' stamp: 'MarcusDenker 11/23/2010 14:58'! extent: newExtent "Update the graphic position to keep centered." super extent: newExtent. graphicalMorph ifNotNil: [graphicalMorph position: self center - (graphicalMorph extent // 2)]! ! !IconicButton methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 8/23/2011 15:04'! update: aSelector aSelector = self interactSelector ifTrue: [ ^ self doButtonAction ]. super update: aSelector! ! !IconicButton methodsFor: 'initialization' stamp: 'StephaneDucasse 5/17/2012 16:36'! setDefaultLabel self labelGraphic: self class defaultGraphics! ! !IconicButton methodsFor: '*Polymorph-Widgets-override' stamp: 'BenjaminVanRyseghem 4/12/2011 17:08'! extraBorder ^ 6! ! !IconicButton methodsFor: '*Nautilus' stamp: 'StephaneDucasse 5/23/2013 18:06'! labelGraphic ^ graphicalMorph form! ! !IconicButton methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/23/2008 17:19'! mouseOverBorderStyle: aBorderStyle "Set the border style to use whilst the mouse is over the receiver." self setProperty: #mouseOverBorderStyle toValue: aBorderStyle! ! !IconicButton methodsFor: 'initialization' stamp: 'ar 12/17/2001 21:17'! borderThick self borderStyle: (BorderStyle width: 2 color: self raisedColor twiceDarker).! ! !IconicButton methodsFor: '*Polymorph-Widgets-override' stamp: 'StephaneDucasse 5/23/2013 18:35'! labelGraphic: aForm "Changed to look for any image morph rather than just a sketch." graphicalMorph ifNotNil: [graphicalMorph delete]. graphicalMorph := ImageMorph new form: aForm. self extent: graphicalMorph extent + (self borderWidth + self extraBorder). graphicalMorph position: self center - (graphicalMorph extent // 2). self addMorph: graphicalMorph. graphicalMorph lock! ! !IconicButton methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/23/2008 17:20'! mouseEnter: evt "Remember the old border style." (self hasProperty: #oldBorder) ifFalse: [ self setProperty: #oldBorder toValue: self borderStyle]. self borderStyle: self mouseOverBorderStyle! ! !IconicButton methodsFor: 'accessing' stamp: 'sw 9/28/1999 14:11'! labelFromString: aString "Make an iconic label from aString" self labelGraphic: (StringMorph contents: aString) imageForm ! ! !IconicButton methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/21/2008 13:03'! mouseDown: evt "Partial workaraound for broken MouseOverHandler. Remove the border on mouse down if mouse focus has changed." super mouseDown: evt. (actWhen == #buttonDown and: [(evt hand mouseFocus = self) not]) ifTrue: [self mouseLeave: evt]! ! !IconicButton methodsFor: 'initialization' stamp: 'ar 12/12/2001 01:38'! borderNormal self borderStyle: (BorderStyle width: 2 color: Color transparent).! ! !IconicButton methodsFor: 'menu' stamp: 'sw 9/28/1999 20:42'! addLabelItemsTo: aCustomMenu hand: aHandMorph "don't do the inherited behavior, since there is no textual label in this case"! ! !IconicButton methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:41'! borderRaised self borderStyle: (BorderStyle raised width: 2).! ! !IconicButton methodsFor: '*Polymorph-Widgets' stamp: 'MarcusDenker 12/11/2009 09:58'! mouseLeave: evt "Reinstate the old border style." (self valueOfProperty: #oldBorder) ifNotNil: [:b | self borderStyle: b. self removeProperty: #oldBorder] ifNil: [self borderNormal]! ! !IconicButton methodsFor: 'accessing' stamp: ''! graphicalMorph: aMorph self addMorph: aMorph. aMorph lock.! ! !IconicButton class methodsFor: 'initialize' stamp: 'StephaneDucasse 5/17/2012 16:33'! initialize "self initialize" DefaultGraphics := self defaultGraphics! ! !IconicButton class methodsFor: 'initialize' stamp: 'StephaneDucasse 5/17/2012 16:40'! defaultGraphics ^ DefaultGraphics ifNil: [ DefaultGraphics := (Form extent: 20 @ 1 depth: 8)].! ! !IconicButtonStateHolder commentStamp: ''! An IconicButtonStateHolder is a state holder for Iconic button. Since Nautilus cache the icon, I do not want to keep pointers to the iconic button's target. I use this state holder for the storage! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! actionSelector: anObject actionSelector := anObject! ! !IconicButtonStateHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/14/2012 15:23'! asIconTargetting: newTarget ^self asIcon target: newTarget; yourself! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! extent: anObject extent := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! labelGraphic ^ labelGraphic! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2013 23:29'! arguments: aCollection arguments := WeakArray withAll: aCollection! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! color: anObject color := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! extent ^ extent! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! labelGraphic: anObject labelGraphic := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! helpText: anObject helpText := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! borderWidth: anObject borderWidth := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! color ^ color! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! actionSelector ^ actionSelector! ! !IconicButtonStateHolder methodsFor: 'protocol' stamp: 'CamilloBruni 5/7/2013 23:29'! asIcon ^ IconicButton new target: self target; actionSelector: self actionSelector; arguments: self arguments; labelGraphic: self labelGraphic; color: self color; helpText: self helpText; extent: self extent; borderWidth: self borderWidth! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! borderWidth ^ borderWidth! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2013 23:29'! arguments "convert arguments back from a WeakArray" ^ Array withAll: arguments! ! !IconicButtonStateHolder methodsFor: 'protocol' stamp: 'CamilloBruni 5/7/2013 23:29'! forIcon: icon self target: icon target; actionSelector: icon actionSelector; arguments: icon arguments; labelGraphic: icon labelGraphic; color: icon color; helpText: icon helpText; extent: icon extent; borderWidth: icon borderWidth! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: ''! helpText ^ helpText! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2013 23:26'! target ^ target first! ! !IconicButtonStateHolder methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2013 23:26'! target: anObject target := WeakArray with: anObject! ! !IconicButtonStateHolder class methodsFor: 'instance creation' stamp: ''! forIcon: icon ^ self new forIcon: icon; yourself ! ! !IconicButtonStateHolder class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/7/2013 23:24'! forNautilus: icon ^ self new forIcon: icon; yourself ! ! !IconicListItem commentStamp: ''! I am a wrapper used to display a morph with ahead an icon. Here is the way to use me IconicListItem new icon: UITheme current smallOkIcon asMorph; morph: 'Accept' asMorph; yourself! !IconicListItem methodsFor: 'accessing' stamp: 'StephaneDucasse 5/31/2013 17:41'! morph: anObject morph ifNotNil: [ self removeMorph: morph ]. morph := anObject. morph ifNotNil: [ "since the text can be removed" self addMorphBack: morph. self adjustLayoutBounds] ! ! !IconicListItem methodsFor: 't-rotating' stamp: ''! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !IconicListItem methodsFor: 't-rotating' stamp: ''! heading "Return the receiver's heading" ^ self owner ifNil: [self forwardDirection] ifNotNil: [self forwardDirection + self owner degreesOfFlex]! ! !IconicListItem methodsFor: 't-rotating' stamp: ''! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !IconicListItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/7/2011 15:19'! originalObject: anObject originalObject := anObject! ! !IconicListItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/20/2014 12:55'! icon: anObject icon ifNotNil: [ self removeMorph: icon ]. icon := anObject asAlphaImageMorph. anObject ifNotNil: [ "since the text can be removed" self addMorphFront: icon. self adjustLayoutBounds] ! ! !IconicListItem methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:05'! initialize super initialize. self changeTableLayout; listDirection: #leftToRight; cellPositioning: #center; cellInset: 2; borderWidth: 0; color: Color transparent; hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 20@16.! ! !IconicListItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/6/2013 23:25'! morph ^ morph! ! !IconicListItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/7/2011 15:19'! originalObject ^ originalObject! ! !IconicListItem methodsFor: 't-rotating' stamp: ''! prepareForRotating "If I require a flex shell to rotate, then wrap it in one and return it. Polygons, eg, may override to do nothing." ^ self addFlexShell! ! !IconicListItem methodsFor: 't-rotating' stamp: ''! setDirectionFrom: aPoint | delta degrees | delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition. degrees := delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! !IconicListItem methodsFor: 't-rotating' stamp: ''! rotationDegrees: degrees "redefined in all morphs which are using myself"! ! !IconicListItem methodsFor: 'accessing' stamp: 'StephaneDucasse 5/31/2013 17:44'! enabled: aBoolean self submorphs do: [ :each | each enabled: aBoolean ].! ! !IconicListItem methodsFor: 't-rotating' stamp: ''! rotationDegrees "Default implementation." ^ 0.0 ! ! !IconicListItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/6/2013 23:26'! icon ^ icon! ! !IconicListItem class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/18/2014 22:37'! text: aText icon: form | morph | aText ifNotNil: [ morph := aText asMorph lock; yourself ]. ^ self new morph: morph; icon: form; yourself! ! !IdentifierChooserMorph commentStamp: 'AlainPlantec 11/29/2010 10:50'! An IdentifierChooserMorph is a menu builder which takes a list of labels as input and build/popup a menu for them. The morph could be made of one menu in one column for all labels of of several menus in a scrollabe row. The action which is performed when a menu item is selected is also parametrized (see examples below). The morph can take the keyboard focus and then, up, down, left and right arrows can be used to choose a menu item. It is the responsibility of the user of this morph to decide when and how the keyboard focus is token. The design is widely inpired from PopupChoiceDialogWindow. example 1 A very simple example with three label. The nil value will be represented as a menu line in the resulting morph. (IdentifierChooserMorph labels: {'aaaaaa'. 'bbbbbbb'. nil. 'cccccccc'} chooseBlock: [ :chosen | UIManager default inform: (chosen, (' has been chosen' translated))]) open example 2 The same except that a color is specified (IdentifierChooserMorph labels: {'aaaaaa'. 'bbbbbbb'. nil. 'cccccccc'} chooseBlock: [ :chosen | UIManager default inform: (chosen, (' has been chosen' translated))]) baseColor: Color white; open example 3 Allows the presentation of one menu (one column) vith two fixed labels followed by the list of all classes. (IdentifierChooserMorph labels: ({'aaaaaa'. 'bbbbbbb'}, { nil }, (Object allSubclasses collect: [:c | c theNonMetaClass name]) asSet asArray sort) chooseBlock: [ :chosen | (Smalltalk globals at: chosen asSymbol) ifNotNil: [:c | c browse] ]) oneMenuOfWidth: 300; baseColor: Color white; open Instance Variables baseColor: choiceMenus: choicesMorph: chooseBlock: labels: maxLines: requestor: scrollPaneWidth: baseColor - The color used for the menu items and the receiver choiceMenus - The array of EmbeddedMenuMorph choicesMorph - The AlignmentMorph which contains all menus chooseBlock - A block with one argument which is evaluated when a menu item is selected. The argument takes the chosen label as argument labels - The array of labels maxLines - If not nil, gives the maximum number of lines for one menu requestor - if not nil, a Morph from which the receiver is built scrollPaneWidth - The maximum width of the scrollPane, this contraints the width of the receiver. ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 9/8/2013 17:59'! selectFirstItem "Select the first item in the embedded menus" self choiceMenus first selectItem: self choiceMenuItems first event: nil. self takeKeyboardFocus.! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2010 09:33'! allowedArea ^ self class allowedArea! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/26/2010 09:54'! forcesHeight: aHeight | sp | (sp := self scrollPane) minHeight: aHeight. sp height: sp minHeight. self height: sp height. ! ! !IdentifierChooserMorph methodsFor: 'action' stamp: 'AlainPlantec 11/26/2010 18:22'! choose: index "Set the given choice and ok." | chosen | chosen := index > 0 ifTrue: [self labels at: index] ifFalse: [nil]. chooseBlock value: chosen. self close. requestor ifNotNil: [requestor takeKeyboardFocus] ! ! !IdentifierChooserMorph methodsFor: 'action' stamp: 'AlainPlantec 11/26/2010 16:54'! close self delete. ! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/26/2010 16:55'! keyStroke: anEvent anEvent keyCharacter = Character escape ifTrue: [self close. requestor ifNotNil: [requestor takeKeyboardFocus]. ^true]. anEvent keyCharacter = Character arrowUp ifTrue: [self selectPreviousItem. ^true]. anEvent keyCharacter = Character arrowDown ifTrue: [self selectNextItem. ^true]. anEvent keyCharacter = Character arrowLeft ifTrue: [self switchToPreviousColumn. ^true]. anEvent keyCharacter = Character arrowRight ifTrue: [self switchToNextColumn. ^true]. (anEvent keyCharacter ~= Character cr and: [anEvent keyCharacter < Character space]) ifTrue: [^false]. "ignore pageup/down etc." (anEvent keyCharacter = Character space or: [ anEvent keyCharacter = Character cr]) ifTrue: [ ^self processEnter: anEvent ]. ^false! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 13:41'! labels "Answer the value of labels" ^ labels! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/29/2010 09:01'! newContentMorph "Answer a new content morph." | sp choices | self choicesMorph: (choices := self newChoicesMorph). sp := (self newScrollPaneFor: choices) color: Color transparent; scrollTarget: choices; hResizing: #spaceFill; vResizing: #spaceFill. sp minWidth: (scrollPaneWidth ifNil: [(choicesMorph width min: (Display width // 2) - 50) + sp scrollBarThickness]); minHeight: (choicesMorph height min: (Display height // 3)). choicesMorph width > sp minWidth ifTrue: [sp minHeight: sp minHeight + sp scrollBarThickness]. ^ sp! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/21/2010 13:41'! switchToPreviousColumn "Give the previous embedded menu keyboard focus." self switchToOtherColumn: [:prevIdx | prevIdx = 1 ifTrue: [self choiceMenus size] ifFalse: [prevIdx - 1]] ! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/21/2010 13:41'! switchToNextColumn "Give the next embedded menu keyboard focus." self switchToOtherColumn: [:prevIdx | prevIdx = self choiceMenus size ifTrue: [1] ifFalse: [prevIdx + 1]] ! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme ^ Smalltalk ui theme ! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 18:59'! choicesMorph: aMorph choicesMorph := aMorph! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 14:02'! chooseBlock: aBlock chooseBlock := aBlock! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/29/2010 09:12'! defaultBaseColor ^ Color transparent! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/29/2010 09:22'! baseColor ^ baseColor ifNil: [baseColor := self defaultBaseColor]! ! !IdentifierChooserMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 9/7/2013 12:39'! initialize super initialize. self borderWidth: 1. self layoutInset: 0. self changeTableLayout. self hResizing: #shrinkWrap. self vResizing: #shrinkWrap. self color: self defaultBaseColor. ! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 13:41'! choiceMenuItems "Answer the value of choiceMenus" ^ Array streamContents: [:strm | self choiceMenus do: [:menu | strm nextPutAll: menu menuItems]]. ! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2010 16:54'! requestor ^ requestor! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/21/2010 13:41'! processEnter: anEvent self choiceMenus do: [:embeddedMenu | embeddedMenu selectedItem ifNotNil: [:item | item invokeWithEvent: anEvent. ^true ] ]. ^false! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/21/2010 13:41'! selectLastItem "Select the last item in the embedded menus" self choiceMenus last selectItem: self choiceMenuItems last event: nil. self activeHand newKeyboardFocus: self. ! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2010 09:00'! listHeight "Answer the height for the list." ^ choicesMorph height! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 13:41'! choiceMenus "Answer the value of choiceMenus" ^ choiceMenus! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/21/2010 22:04'! newMenu ^ self theme newEmbeddedMenuIn: self for: self! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2010 16:32'! requestor: aTextMorph requestor := aTextMorph! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/29/2010 09:23'! baseColor: aColor baseColor := aColor. self setColor: aColor! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 16:32'! maxLines: anInteger maxLines := anInteger! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/24/2010 21:44'! selectNextItem "Select the next item in the embedded menus" | idx next | self choiceMenus do: [:embeddedMenu | embeddedMenu menuItems do: [:mi | ((mi isKindOf: MenuItemMorph) and: [mi isSelected]) ifTrue: [idx := embeddedMenu menuItems indexOf: mi. idx = embeddedMenu menuItems size ifTrue: [idx := 0]. idx := idx + 1. [(embeddedMenu menuItems at: idx) isKindOf: MenuItemMorph] whileFalse: [idx := idx+ 1]. next := embeddedMenu menuItems at: idx. self activeHand newKeyboardFocus: self. self scrollPane ifNotNil: [:sp | sp scrollToShow: next bounds]. ^ embeddedMenu selectItem: next event: nil]]]. self selectFirstItem! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/24/2010 21:44'! selectPreviousItem "Select the previous item in the embedded menus" | idx previous | self choiceMenus do: [:embeddedMenu | embeddedMenu menuItems do: [:mi | ((mi isKindOf: MenuItemMorph) and: [mi isSelected]) ifTrue: [idx := embeddedMenu menuItems indexOf: mi. idx = 1 ifTrue: [idx := embeddedMenu menuItems size + 1]. idx := idx - 1. [(embeddedMenu menuItems at: idx) isKindOf: MenuItemMorph] whileFalse: [idx := idx- 1]. previous := embeddedMenu menuItems at: idx. self scrollPane ifNotNil: [:sp | sp scrollToShow: previous bounds]. ^ embeddedMenu selectItem: previous event: nil]]]. self selectFirstItem. ! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/29/2010 09:08'! setColor: aColor self color: aColor. self choiceMenus ifNotNil: [:menus | menus do: [:cm | cm color: aColor]]! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/21/2010 13:41'! handlesKeyboard: evt "True when either the filter morph doesn't have the focus and the key is a text key or backspace or no menus have the focus and is up or down arrow." ^(super handlesKeyboard: evt) or: [ (self hasKeyboardFocus) ifTrue: [ evt keyCharacter = Character escape or: [evt keyCharacter = Character cr or: [evt keyCharacter = Character arrowLeft or: [evt keyCharacter = Character arrowRight or: [evt keyCharacter = Character arrowUp or: [evt keyCharacter = Character arrowDown]]]]]] ifFalse: [ evt keyCharacter = Character escape or: [evt keyCharacter = Character arrowUp or: [evt keyCharacter = Character arrowDown or: [evt keyCharacter = Character arrowLeft or: [evt keyCharacter = Character arrowRight]]]]]]! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/27/2010 12:41'! oneMenuOfWidth: anInteger self maxLines: 999999999. scrollPaneWidth := anInteger. ! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/25/2010 09:24'! newChoicesMorph "Answer a row of columns of buttons and separators based on the model." | answer morphs str | answer := self newRow cellPositioning: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap. self labels ifEmpty: [^answer]. self labels first isNil ifTrue: [self labels: self labels allButFirst]. self labels ifEmpty: [^answer]. self labels last isNil ifTrue: [self labels: self labels allButLast]. self labels ifEmpty: [^answer]. morphs := OrderedCollection new. 1 to: self labels size do: [:i | morphs add: (self newChoiceButtonFor: i)]. str := morphs readStream. [str atEnd] whileFalse: [ answer addMorphBack: (self newMenuWith: (str next: self maxLines)); addMorphBack: self newVerticalSeparator]. answer removeMorph: answer submorphs last. answer submorphs last hResizing: #spaceFill. scrollPaneWidth ifNotNil: [answer hResizing: #spaceFill. answer submorphs last hResizing: #rigid. answer submorphs last width: scrollPaneWidth]. self choiceMenus: (answer submorphs select: [:m| m isKindOf: MenuMorph]). ^answer! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/21/2010 13:41'! newVerticalSeparator ^ SeparatorMorph new fillStyle: Color transparent; borderStyle: (BorderStyle inset baseColor: Color gray; width: 1); extent: 1@1; vResizing: #spaceFill! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/29/2010 10:53'! activate: evt "Backstop." ! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/21/2010 13:41'! newRow ^ AlignmentMorph new listDirection: #leftToRight; hResizing: #spaceFill; vResizing: #spaceFill; extent: 1@1; borderWidth: 0; color: Color transparent. ! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2010 09:01'! listMorph "Answer the height for the list." ^ choicesMorph! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/21/2010 13:41'! newScrollPaneFor: aMorph ^ self theme newScrollPaneIn: self for: aMorph! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 13:41'! choiceMenus: anObject "Set the value of choiceMenus" choiceMenus := anObject! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/29/2010 09:24'! newChoiceButtonFor: index "Answer a new choice button." ^ (self labels at: index) ifNotNil: [:v | (ToggleMenuItemMorph new contents: v asText; target: self; selector: #choose:; arguments: {index}) cornerStyle: #square; hResizing: #spaceFill] ifNil: [MenuLineMorph new] ! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/29/2010 09:26'! newMenuWith: menuItems "Answer menu with the given morphs." | menu | menu := self newMenu. menu cornerStyle: #square. menuItems do: [:m | menu addMenuItem: m]. menu borderWidth: 0; color: self baseColor; borderColor: Color transparent; stayUp: true; beSticky; removeDropShadow; popUpOwner: (MenuItemMorph new privateOwner: self). ^ menu! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 16:31'! maxLines ^ maxLines ifNil: [maxLines := 6]! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/29/2010 10:55'! labels: aCollectionOfString "Set the value of labels" labels := aCollectionOfString! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/29/2010 09:24'! open self addMorph: self newContentMorph. self openInWorld. ! ! !IdentifierChooserMorph methodsFor: 'ui-building' stamp: 'AlainPlantec 11/21/2010 13:41'! scrollPane "Answer the scroll pane." ^self findDeeplyA: GeneralScrollPane! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/21/2010 13:41'! deleteIfPopUp: evt "For compatibility with MenuMorph."! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/24/2010 21:36'! switchToOtherColumn: aBlock "Give the next embedded menu keyboard focus. The next menu indice is computed by the argument" | menuWithFocus idx menu sub subIdx | (self choiceMenus isNil or: [self choiceMenus isEmpty]) ifTrue: [^self]. menuWithFocus := self choiceMenus detect: [:m | m menuItems anySatisfy: [:sm | ((sm isKindOf: MenuItemMorph) and: [sm isSelected]) ifTrue: [sub := sm]. sm isSelected]] ifNone: []. self choiceMenus do: [:embeddedMenu | embeddedMenu selectItem: nil event: nil]. menuWithFocus isNil ifTrue: [self selectFirstItem] ifFalse: [ idx := aBlock value: (self choiceMenus indexOf: menuWithFocus). menu := (self choiceMenus at: idx). subIdx := sub ifNil: [1] ifNotNil: [(menuWithFocus menuItems indexOf: sub) min: menu menuItems size]. menu selectItem: (menu menuItems at: subIdx) event: nil. self scrollPane ifNotNil: [:sp | sp scrollToShow: menu bounds]]. self activeHand newKeyboardFocus: self.! ! !IdentifierChooserMorph class methodsFor: 'accessing' stamp: 'IgorStasenko 12/22/2012 03:24'! allowedArea "The area allowed for the building and positioning of the morph" | allowedArea | allowedArea := Display usableArea. allowedArea := allowedArea intersect: World visibleClearArea ifNone: [ 0@0 corner: 0@0 "not sure about this"]. ^allowedArea! ! !IdentifierChooserMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 11/29/2010 10:51'! labels: aCollection chooseBlock: aBlock "return a new chooser or nil" ^ aCollection isEmpty ifFalse: [ self new chooseBlock: aBlock; labels: aCollection; yourself]. ! ! !IdentityBag commentStamp: ''! Like a Bag, except that items are compared with #== instead of #= . See the comment of IdentitySet for more information. ! !IdentityBag methodsFor: 'converting' stamp: 'nice 12/18/2009 12:02'! asSet ^contents keys asIdentitySet! ! !IdentityBag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:53'! contentsClass ^IdentityDictionary! ! !IdentityBagTest commentStamp: 'TorstenBergmann 2/20/2014 15:20'! SUnit tests for identity bags! !IdentityBagTest methodsFor: 'requirements' stamp: 'damienpollet 1/9/2009 18:28'! speciesClass ^ IdentityBag! ! !IdentityBagTest methodsFor: 'tests' stamp: 'stephane.ducasse 5/20/2009 18:03'! testIdentity "self run:#testIdentity" "self debug:#testIdentity" | bag identityBag aString anOtherString | aString := 'hello'. anOtherString := aString copy. self assert: (aString = anOtherString). self assert: (aString == anOtherString) not. bag := Bag new. bag add: aString. bag add: aString. bag add: anOtherString. self assert: (bag occurrencesOf: aString) = 3. self assert: (bag occurrencesOf: anOtherString) = 3. identityBag := IdentityBag new. identityBag add: aString. identityBag add: aString. identityBag add: anOtherString. self assert: (identityBag occurrencesOf: aString) = 2. self assert: (identityBag occurrencesOf: anOtherString) = 1. ! ! !IdentityBagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:02'! identityCollectionWithElementsCopyNotIdentical "Returns a collection including elements for which #copy doesn't return the same object." ^ identityBagNonEmptyNoDuplicate5Elements ifNil: [ identityBagNonEmptyNoDuplicate5Elements := IdentityBag new add: 2.5 ; add: 1.5 ;add: 5.5 ; yourself ]! ! !IdentityBagTest methodsFor: 'tests - converting' stamp: 'delaunay 4/30/2009 12:02'! testAsSetWithEqualsElements | t1 | t1 := self withEqualElements asSet. self withEqualElements do: [:t2 | self assert: (t1 occurrencesOf: t2) = 1]. self assert: t1 class = IdentitySet! ! !IdentityBagTest methodsFor: 'requirements' stamp: 'delaunay 4/30/2009 11:20'! elementToCopy ^ elementToCopy ifNil: [ elementToCopy := 'element to copy' ]! ! !IdentityBagTest methodsFor: 'requirements' stamp: 'delaunay 4/30/2009 11:20'! equalNotIdenticalElement ^ equalNotIdenticalElement ifNil: [ equalNotIdenticalElement := self elementToCopy copy ]! ! !IdentityBagTest methodsFor: 'tests - identity adding' stamp: 'delaunay 4/30/2009 11:19'! testIdentityAdd | added oldSize | oldSize := self collection size. self collection add: self elementToCopy . self deny: (self collection includes: self equalNotIdenticalElement). added := self collection add: self equalNotIdenticalElement. self assert: added == self equalNotIdenticalElement. self assert: (self collection includes: self equalNotIdenticalElement)! ! !IdentityDictionary commentStamp: 'ls 06/15/02 22:35'! Like a Dictionary, except that keys are compared with #== instead of #= . See the comment of IdentitySet for more information.! !IdentityDictionary methodsFor: 'private' stamp: 'MartinMcClure 1/16/2010 18:19'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | finish start element | finish := array size. start := (anObject identityHash \\ finish) + 1. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element := array at: index) == nil or: [element key == anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element := array at: index) == nil or: [element key == anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !IdentityDictionary methodsFor: 'private' stamp: 'di 12/1/1999 20:54'! keyAtValue: value ifAbsent: exceptionBlock "Answer the key that is the external name for the argument, value. If there is none, answer the result of evaluating exceptionBlock." self associationsDo: [:association | value == association value ifTrue: [^ association key]]. ^ exceptionBlock value! ! !IdentityDictionary methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 22:50'! scanForEmptySlotFor: aKey "Scan the key array for the first slot containing an empty slot (indicated by a nil). Answer the index of that slot. This method will be overridden in various subclasses that have different interpretations for matching elements." | index start | index := start := aKey identityHash \\ array size + 1. [ (array at: index) ifNil: [ ^index ]. (index := index \\ array size + 1) = start ] whileFalse. self errorNoFreeSpace! ! !IdentityDictionaryTest commentStamp: 'TorstenBergmann 2/20/2014 15:20'! SUnit tests for identity dictionaries! !IdentityDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 11:41'! classToBeTested ^ IdentityDictionary! ! !IdentityDictionaryTest methodsFor: 'tests - identity' stamp: 'cyrille.delaunay 6/29/2009 13:21'! testIdentity | dict key | dict := self classToBeTested new. key := 'key'. dict at: key put: 2.5. self assert: (dict includesKey: key). self deny: (dict includesKey: key copy). " dict at: 1 put: 'djdh'. dict at: 'sksl' put: 1.0. self deny: (dict includesKey: 1.0) . self assert: (dict includes: 1)" ! ! !IdentityDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 11:41'! shouldInheritSelectors ^true! ! !IdentityMorphTreeListManager commentStamp: ''! An IdentityMorphTreeListManager is a MorphTreeListManager which always check for identity between items ! !IdentityMorphTreeListManager methodsFor: 'accessing' stamp: ''! nodeMorphsWithAllNodeItems: aNodeItemList ^ self allNodeMorphs select: [:m | aNodeItemList identityIncludes: m complexContents withoutListWrapper]! ! !IdentityMorphTreeMorph commentStamp: ''! An IdentityMorphTreeMorph is a MorphTreeMorph which always check for identity between items ! !IdentityMorphTreeMorph methodsFor: 'accessing' stamp: ''! listManager: aManager listManager := aManager! ! !IdentityMorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''! notExpandedFormForMorph: aMorph ^ ((self selectedMorphList identityIncludes: aMorph) and: [self theme selectionColor luminance < 0.6]) ifTrue: [self theme whiteTreeUnexpandedForm] ifFalse: [self theme treeUnexpandedForm]! ! !IdentityMorphTreeMorph methodsFor: 'expanding-collapsing' stamp: ''! expandedFormForMorph: aMorph "Answer the form to use for expanded items." ^ ((self selectedMorphList identityIncludes: aMorph) and: [self theme selectionColor luminance < 0.6]) ifTrue: [self theme whiteTreeExpandedForm] ifFalse: [self theme treeExpandedForm]! ! !IdentityNewValueHolder commentStamp: 'BenjaminVanRyseghem 1/23/2014 15:19'! I am a special because I announce changes only if the new value set is different from the current value.! !IdentityNewValueHolder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/23/2014 12:09'! value: anObject self value == anObject ifTrue: [ ^ anObject ]. super value: anObject! ! !IdentitySet commentStamp: 'sw 1/14/2003 22:35'! The same as a Set, except that items are compared using #== instead of #=. Almost any class named IdentityFoo is the same as Foo except for the way items are compared. In Foo, #= is used, while in IdentityFoo, #== is used. That is, identity collections will treat items as the same only if they have the same identity. For example, note that copies of a string are equal: ('abc' copy) = ('abc' copy) but they are not identitcal: ('abc' copy) == ('abc' copy) A regular Set will only include equal objects once: | aSet | aSet := Set new. aSet add: 'abc' copy. aSet add: 'abc' copy. aSet An IdentitySet will include multiple equal objects if they are not identical: | aSet | aSet := IdentitySet new. aSet add: 'abc' copy. aSet add: 'abc' copy. aSet ! !IdentitySet methodsFor: 'private' stamp: 'IgorStasenko 5/30/2011 18:23'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | index start hash | hash := anObject identityHash. index := start := hash \\ array size + 1. [ | element | ((element := array at: index) == nil or: [ element enclosedSetElement == anObject ]) ifTrue: [ ^index ]. (index := index \\ array size + 1) = start ] whileFalse. self errorNoFreeSpace! ! !IdentitySet methodsFor: 'converting' stamp: 'ar 9/22/2000 10:13'! asIdentitySet ^self! ! !IdentitySet methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 22:50'! scanForEmptySlotFor: aKey "Scan the key array for the first slot containing an empty slot (indicated by a nil). Answer the index of that slot. This method will be overridden in various subclasses that have different interpretations for matching elements." | index start | index := start := aKey identityHash \\ array size + 1. [ (array at: index) ifNil: [ ^index ]. (index := index \\ array size + 1) = start ] whileFalse. self errorNoFreeSpace! ! !IdentitySetTest commentStamp: 'TorstenBergmann 2/20/2014 15:28'! SUnit tests for identity sets! !IdentitySetTest methodsFor: 'requirements' stamp: 'CamilloBruni 7/3/2013 12:59'! classToBeTested ^ IdentitySet! ! !IdentitySetTest methodsFor: 'tests - identity' stamp: 'cyrille.delaunay 6/29/2009 11:18'! testIdentity "self run:#testIdentity" "self debug:#testIdentity" | identitySet aString anOtherString | aString := 'hello'. anOtherString := aString copy. self assert: (aString = anOtherString). self assert: (aString == anOtherString) not. identitySet := self classToBeTested new. identitySet add: aString. self assert: (identitySet occurrencesOf: aString) = 1. self assert: (identitySet occurrencesOf: anOtherString) = 0. self assert: (identitySet includes: aString). self deny: (identitySet includes: anOtherString) = 0.! ! !IdentitySetTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:05'! identityCollectionWithElementsCopyNotIdentical " return a collection including elements for which #copy return a new object " ^ floatCollection ifNil: [ floatCollection := IdentitySet new add: 2.5 ; add: 4.5 ; add:5.5 ; yourself ].! ! !IdentitySetTest methodsFor: 'tests - identity' stamp: 'StephaneDucasse 12/29/2011 14:31'! testGrowWithNil "self run: #testGrowWithNil" "This test covers that grow take into account that nil are wrapped elements of sets" | set | set := IdentitySet new. set add: nil. set grow. self assert: (set includes: nil)! ! !IdentitySetTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 10:51'! shouldInheritSelectors ^true! ! !IdentityTransform commentStamp: 'TorstenBergmann 2/12/2014 22:28'! Identity transformation! !IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:20'! localBoundsToGlobal: aRectangle "Transform aRectangle from local coordinates into global coordinates" ^aRectangle! ! !IdentityTransform methodsFor: 'testing' stamp: 'ar 9/11/2000 21:18'! isIdentity "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself." ^true! ! !IdentityTransform methodsFor: 'accessing' stamp: 'di 9/29/2000 09:04'! angle ^ 0.0! ! !IdentityTransform methodsFor: 'accessing' stamp: 'ar 4/19/2001 06:01'! offset ^0@0! ! !IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'! localPointToGlobal: aPoint "Transform aPoint from local coordinates into global coordinates" ^aPoint! ! !IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:21'! sourceQuadFor: aRectangle ^ aRectangle innerCorners! ! !IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'! localPointsToGlobal: inArray "Transform all the points of inArray from local into global coordinates" ^inArray! ! !IdentityTransform methodsFor: 'initialize' stamp: 'ar 9/11/2000 21:18'! setIdentity "I *am* the identity transform" ^self! ! !IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:27'! composedWith: aTransform ^aTransform! ! !IdentityTransform methodsFor: 'testing' stamp: 'ar 9/11/2000 21:19'! isPureTranslation "Return true if the receiver specifies no rotation or scaling." ^true! ! !IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:19'! composedWithLocal: aTransformation ^aTransformation! ! !IdentityTransform methodsFor: 'transforming points' stamp: 'gh 10/22/2001 13:24'! invertBoundsRect: aRectangle "Return a rectangle whose coordinates have been transformed from local back to global coordinates. Since I am the identity matrix no transformation is made." ^aRectangle ! ! !IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'! globalPointsToLocal: inArray "Transform all the points of inArray from global into local coordinates" ^inArray! ! !IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:20'! globalBoundsToLocal: aRectangle "Transform aRectangle from global coordinates into local coordinates" ^aRectangle! ! !IdentityTransform methodsFor: 'accessing' stamp: 'ar 9/11/2000 21:18'! inverseTransformation "Return the inverse transformation of the receiver" ^self! ! !IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:19'! composedWithGlobal: aTransformation ^aTransformation! ! !IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:19'! globalPointToLocal: aPoint "Transform aPoint from global coordinates into local coordinates" ^aPoint! ! !IdentityTransform methodsFor: 'converting' stamp: 'ar 9/11/2000 21:21'! asMatrixTransform2x3 "Represent the receiver as a 2x3 matrix transformation" ^MatrixTransform2x3 identity! ! !IdentityTransform class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! initialize "IdentityTransform initialize" Default := self basicNew! ! !IdentityTransform class methodsFor: 'instance creation' stamp: 'ar 9/11/2000 21:24'! new "There can be only one" ^Default! ! !IfNotNilTests commentStamp: 'TorstenBergmann 1/31/2014 11:24'! SUnit tests for ifNotNil: variations! !IfNotNilTests methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testIfNotNil1Arg self assert: (5 ifNotNil: [ :a | a printString ]) = '5'. self assert: (nil ifNotNil: [ :a | a printString ]) isNil! ! !IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:43'! testIfNilIfNotNil0Arg self assert: (5 ifNil: [#foo] ifNotNil: [#bar]) = #bar. self assert: (nil ifNil: [#foo] ifNotNil: [#bar]) = #foo! ! !IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:43'! testIfNilIfNotNil0ArgAsVar | block1 block2 | block1 := [#foo]. block2 := [#bar]. self assert: (5 ifNil: block1 ifNotNil: block2) = #bar. self assert: (nil ifNil: block1 ifNotNil: block2) = #foo! ! !IfNotNilTests methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testIfNotNil1ArgAsVar | block | block := [ :a | a printString ]. self assert: (5 ifNotNil: block) = '5'. self assert: (nil ifNotNil: block) isNil! ! !IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:35'! testIfNotNilIfNil0Arg self assert: (5 ifNotNil: [#foo] ifNil: [#bar]) = #foo. self assert: (nil ifNotNil: [#foo] ifNil: [#bar]) = #bar! ! !IfNotNilTests methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testIfNotNil0Arg self assert: (5 ifNotNil: [ #foo ]) = #foo. self assert: (nil ifNotNil: [ #foo ]) isNil! ! !IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:36'! testIfNotNilIfNil0ArgAsVar | block1 block2 | block1 := [#foo]. block2 := [#bar]. self assert: (5 ifNotNil: block2 ifNil: block1) = #bar. self assert: (nil ifNotNil: block2 ifNil: block1) = #foo! ! !IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:36'! testIfNotNilIfNil1ArgAsVar | block1 block2 | block1 := [#foo]. block2 := [:a | a printString]. self assert: (5 ifNotNil: block2 ifNil: block1) = '5'. self assert: (nil ifNotNil: block2 ifNil: block1) = #foo! ! !IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:35'! testIfNotNilIfNil1Arg self assert: (5 ifNotNil: [:a | a printString] ifNil: [#foo]) = '5'. self assert: (nil ifNotNil: [:a | a printString] ifNil: [#foo]) = #foo! ! !IfNotNilTests methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testIfNotNil0ArgAsVar | block | block := [ #foo ]. self assert: (5 ifNotNil: block) = #foo. self assert: (nil ifNotNil: block) isNil! ! !IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:33'! testIfNilIfNotNil1ArgAsVar | block1 block2 | block1 := [#foo]. block2 := [:a | a printString]. self assert: (5 ifNil: block1 ifNotNil: block2) = '5'. self assert: (nil ifNil: block1 ifNotNil: block2) = #foo! ! !IfNotNilTests methodsFor: 'tests' stamp: 'vb 4/15/2007 12:25'! testIfNilIfNotNil1Arg self assert: (5 ifNil: [#foo] ifNotNil: [:a | a printString]) = '5'. self assert: (nil ifNil: [#foo] ifNotNil: [:a | a printString]) = #foo! ! !IgorsPlugin commentStamp: ''! An IgorsPlugin is a plugin which displays info about the current selection! !IgorsPlugin methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 1/19/2012 13:36'! buildString | mdl | mdl := self model. ^ mdl selectedClass ifNil: [ '' ] ifNotNil: [:class | mdl selectedMethod ifNil: [ (RGCommentDefinition realClass: class) timeStamp asTimeStamp asString ] ifNotNil: [:method | method methodReference timeStamp asTimeStamp asString ]]! ! !IgorsPlugin class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 2/17/2012 16:39'! description ^ 'Display the information of the selected class/method'! ! !IllegalName commentStamp: 'TorstenBergmann 1/31/2014 11:34'! I am raised on an attempt to use an illegal file name ! !IllegalName methodsFor: 'accessing' stamp: 'DamienPollet 2/28/2011 17:08'! name ^ name! ! !IllegalName methodsFor: 'initialization' stamp: 'DamienPollet 2/28/2011 17:08'! initializeWithName: aName name := aName. self messageText: aName! ! !IllegalName class methodsFor: 'instance creation' stamp: 'DamienPollet 2/28/2011 17:03'! signalWith: aName ^ (self name: aName) signal! ! !IllegalName class methodsFor: 'instance creation' stamp: 'DamienPollet 2/28/2011 17:04'! name: aName ^ self basicNew initializeWithName: aName! ! !IllegalResumeAttempt commentStamp: ''! This class is private to the EHS implementation. An instance of it is signaled whenever an attempt is made to resume from an exception which answers false to #isResumable.! !IllegalResumeAttempt methodsFor: 'comment' stamp: 'ajh 9/4/2002 19:24'! defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ! !IllegalResumeAttempt methodsFor: 'comment' stamp: 'tfei 6/2/1999 14:59'! readMe "Never handle this exception!!"! ! !IllegalResumeAttempt methodsFor: 'comment' stamp: 'ajh 2/1/2003 00:57'! isResumable ^ false! ! !ImageCleaner commentStamp: 'TorstenBergmann 2/4/2014 20:43'! Used for cleaning the image! !ImageCleaner methodsFor: 'cleaning' stamp: 'MarcusDenke 10/23/2013 13:28'! cleanUpMethods "Make sure that all methods in use are restarted" "ScriptLoader new cleanUpMethods" WeakArray restartFinalizationProcess. WorldState allInstancesDo: [ :ws | ws convertAlarms; convertStepList; resetWorldMenu]. WorldState allInstancesDo: [ :ws | ws instVarNamed: 'menuBuilder' put: nil ]. ProcessBrowser initialize. Delay startTimerEventLoop.! ! !ImageCleaner methodsFor: 'cleaning' stamp: 'MarcusDenker 6/24/2013 12:42'! cleanUpProcesses (Process allInstances reject: [ :p | {(InputEventFetcher default fetcherProcess). (Processor activeProcess). (WeakArray runningFinalizationProcess). (Processor backgroundProcess). (SmalltalkImage current lowSpaceWatcherProcess). (UIManager default uiProcess). (Delay schedulingProcess)} includes: p ]) do: [ :p | p suspend; terminate ] ! ! !ImageCleaner methodsFor: 'cleaning' stamp: 'MarcusDenker 1/31/2014 16:28'! examplePackages ^RPackageOrganizer default packageNames select: [ :each | each endsWith: 'Examples' ]! ! !ImageCleaner methodsFor: 'api' stamp: 'MarcusDenker 7/26/2013 17:00'! cleanUpForRelease "self new cleanUpForRelease" Author fullName: 'Mr.Cleaner'. self cleanUpMethods. FreeTypeFontProvider current initialize. SystemNavigation new allObjectsDo: [ :each | (each respondsTo: #releaseCachedState) ifTrue: [ each releaseCachedState ] ]. "Remove empty categories, which are not in MC packages, because MC does not do this (this script does not make packages dirty)" Smalltalk organization removeEmptyCategories. Smalltalk allClassesAndTraitsDo: [ :class | [ :each | each removeEmptyCategories; sortCategories ] value: class organization; value: class class organization ]. Smalltalk organization sortCategories. Smalltalk garbageCollect. Smalltalk cleanOutUndeclared. Smalltalk fixObsoleteReferences. Smalltalk cleanUp: true except: #() confirming: false. Author reset! ! !ImageCleaner methodsFor: 'cleaning' stamp: 'MarcusDenker 1/31/2014 16:37'! packagesForCleanUpInProduction "A list of packages who will be unloaded when going to production. WARNING, ORDER IS IMPORTANT" ^#( "Manifest & Critics Browser" 'Manifest-Core' 'Manifest-CriticBrowser' 'Manifest-Tests' 'Manifest-Resources-Tests' "Metacello" 'Metacello-ToolBox' 'Metacello-MC' 'Metacello-Platform' 'Metacello-Core' 'Metacello-Base' 'Metacello-ProfStef' 'Metacello-Tutorial' 'Metacello-TestsCore' 'Metacello-TestsMC' 'Metacello-TestsMCCore' 'Metacello-TestsMCResources' 'Metacello-TestsPharo20MC' 'Metacello-TestsPlatform' 'Metacello-TestsTutorial' ) ! ! !ImageCleaner methodsFor: 'api' stamp: 'MarcusDenker 1/31/2014 16:43'! cleanUpForProduction "self new cleanUpForProduction" "trim MC ancestory information" MCVersionInfo allInstances do: [ :each | each instVarNamed: 'ancestors' put: nil ]. "delete logo" PolymorphSystemSettings showDesktopLogo: false. self packagesForCleanUpInProduction do: [ :each | (MCPackage named: each) unload ]. self helpPackages do: [ :each | (MCPackage named: each) unload ]. self testPackages do: [ :each | (MCPackage named: each) unload ]. self examplePackages do: [ :each | (MCPackage named: each) unload ]. (MCPackage named: 'ScriptLoader30') unload. (MCPackage named: 'MonticelloMocks') unload. (MCPackage named: 'ToolsTest') unload. (MCPackage named: 'Announcements-Tests-Core') unload. (MCPackage named: 'AST-Tests-Core') unload. (MCPackage named: 'AST-Interpreter-Test') unload. (MCPackage named: 'Ring-Tests-Containers') unload. (MCPackage named: 'Ring-Tests-Kernel') unload. (MCPackage named: 'Ring-Tests-Monticello') unload. (MCPackage named: 'Regex-Tests-Core') unload. (MCPackage named: 'Refactoring-Tests-Changes') unload. (MCPackage named: 'Refactoring-Tests-Core') unload. (MCPackage named: 'Refactoring-Tests-Critics') unload. (MCPackage named: 'Refactoring-Tests-Environment') unload. (MCPackage named: 'FileSystem-Tests-Core') unload. (MCPackage named: 'FileSystem-Tests-Disk') unload. (MCPackage named: 'FileSystem-Tests-Memory') unload. self cleanUpForRelease. ! ! !ImageCleaner methodsFor: 'cleaning' stamp: 'MarcusDenker 1/30/2014 15:28'! helpPackages ^RPackageOrganizer default packageNames select: [ :each | each endsWith: '-Help' ]! ! !ImageCleaner methodsFor: 'cleaning' stamp: 'MarcusDenker 1/31/2014 16:39'! testPackages ^(RPackageOrganizer default packageNames select: [ :each | each endsWith: 'Tests' ]) copyWithout: 'ReleaseTests'! ! !ImageCleaner class methodsFor: 'instance creation' stamp: 'MarcusDenker 11/16/2012 17:01'! cleanUpForProduction self new cleanUpForProduction! ! !ImageCleaner class methodsFor: 'instance creation' stamp: 'MarcusDenker 11/16/2012 17:01'! cleanUpForRelease self new cleanUpForRelease! ! !ImageCleanerCommandLineHandler commentStamp: 'MarcusDenker 1/25/2014 13:04'! Usage: clean [ --release ] --release do #cleanUpForRelease --production do #cleanUpForProduction Documentation: This allows to run the ImageCleaner from the commandLine. With no special option it runs Smalltalk cleanUp: true. Usage: pharo Pharo.image clean pharo Pharo.image clean --release! !ImageCleanerCommandLineHandler methodsFor: 'activation' stamp: 'MarcusDenker 1/25/2014 13:03'! activate self activateHelp ifTrue: [ ^ self ]. self cleanUpImage. Smalltalk snapshot: true andQuit: true.! ! !ImageCleanerCommandLineHandler methodsFor: 'actions' stamp: 'MarcusDenker 1/25/2014 13:03'! cleanUpImage (self hasOption: 'release') ifTrue: [^ImageCleaner cleanUpForRelease]. (self hasOption: 'production') ifTrue: [ ^ImageCleaner cleanUpForProduction]. Smalltalk cleanUp: true except: #() confirming: false. ! ! !ImageCleanerCommandLineHandler class methodsFor: 'accessing' stamp: 'MarcusDenker 1/25/2014 13:05'! description ^ 'Run image cleanup'! ! !ImageCleanerCommandLineHandler class methodsFor: 'accessing' stamp: 'MarcusDenker 1/25/2014 12:49'! commandName ^ 'clean'! ! !ImageFillStyle commentStamp: 'gvc 9/23/2008 11:55'! Simple fillstyle that draws a (potentially translucent) form at the specified origin. Direction and normal are unused.! !ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 3/26/2008 19:18'! form "Answer the value of form" ^ form! ! !ImageFillStyle methodsFor: 'comparing' stamp: 'gvc 12/8/2008 18:53'! hash "Hash is implemented because #= is implemented." ^super hash bitXor: self form hash! ! !ImageFillStyle methodsFor: 'converting' stamp: 'gvc 3/2/2010 17:16'! asColor "Answer transparent, no other reasonable interpretation." ^Color transparent! ! !ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 10/3/2008 11:57'! extent: anObject "Set the value of extent" extent := anObject! ! !ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 10/3/2008 11:57'! extent "Answer the value of extent" ^ extent! ! !ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 1/28/2009 17:40'! offset "Answer the value of offset" ^ offset! ! !ImageFillStyle methodsFor: 'initialization' stamp: 'gvc 1/28/2009 17:40'! initialize "Initialize the receiver." super initialize. self origin: 0@0; offset: 0@0! ! !ImageFillStyle methodsFor: 'comparing' stamp: 'gvc 12/8/2008 18:54'! = anOrientedFillStyle "Answer whether equal." ^super = anOrientedFillStyle and: [self form = anOrientedFillStyle form]! ! !ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 1/28/2009 17:40'! offset: anObject "Set the value of offset" offset := anObject! ! !ImageFillStyle methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/28/2009 17:40'! fillRectangle: aRectangle on: aCanvas "Fill the given rectangle on the given canvas with the receiver." self extent ifNil: [aCanvas translucentImage: self form at: self origin] ifNotNil: [aCanvas clipBy: (self origin + self offset extent: self extent) during: [:c | c translucentImage: self form at: self origin]]! ! !ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:51'! form: aForm "Set the value of form" form := aForm. self direction: aForm extent! ! !ImageFillStyle methodsFor: '*Athens-Core' stamp: 'IgorStasenko 10/12/2012 03:28'! asAthensPaintOn: anAthensCanvas ^ (anAthensCanvas cacheAt: self ifAbsentPut: [ anAthensCanvas surface createFormPaint: form ]) origin: origin; direction: (form width@0) ! ! !ImageFillStyle class methodsFor: 'as yet unclassified' stamp: 'gvc 3/26/2008 19:17'! form: aForm "Answer a new instance of the receiver with the given form." ^self new form: aForm! ! !ImageModel commentStamp: ''! An ImageModel is a spec model for images! !ImageModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/11/2014 22:20'! image: aForm "Set the form of the imagemorph" imageHolder value: aForm! ! !ImageModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. imageHolder := nil asReactiveVariable. action := [] asReactiveVariable. imageHolder whenChangedDo: [ self changed: #getImage ].! ! !ImageModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/11/2014 22:02'! image ^ imageHolder value! ! !ImageModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/11/2014 22:18'! action ^ action value! ! !ImageModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 1/11/2014 22:19'! whenImageChanged: aBlock "Set a block to performed when the image is changed" imageHolder whenChangedDo: aBlock! ! !ImageModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/11/2014 22:19'! action: aBlock "Set the action of the image" action value: aBlock! ! !ImageModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 1/11/2014 22:19'! whenActionChanged: aBlock "Set a block to performed when the action is changed" action whenChangedDo: aBlock! ! !ImageModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/3/2013 23:03'! defaultSpec ^ #(ImageAdapter adapt: #(model))! ! !ImageModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:21'! adapterName ^ #ImageAdapter! ! !ImageMorph commentStamp: 'efc 3/7/2003 17:48'! ImageMorph is a morph that displays a picture (Form). My extent is determined by the extent of my form. Use #image: to set my picture. Structure: instance var Type Description image Form The Form to use when drawing Code examples: ImageMorph new openInWorld; grabFromScreen (Form fromFileNamed: 'myGraphicsFileName') asMorph openInWorld Relationship to SketchMorph: ImageMorph should be favored over SketchMorph, a parallel, legacy class -- see the Swiki FAQ for details ( http://minnow.cc.gatech.edu/squeak/1372 ). ! !ImageMorph methodsFor: 'testing' stamp: 'StephaneDucasse 5/23/2013 17:21'! wantsRecolorHandle ^ image notNil and: [image depth = 1]! ! !ImageMorph methodsFor: 't-rotating' stamp: ''! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !ImageMorph methodsFor: 'testing' stamp: 'WilliamSix 1/14/2013 19:44'! shouldFlex ^ true.! ! !ImageMorph methodsFor: 'menu commands' stamp: 'StephaneDucasse 5/23/2013 18:36'! readFromFile | fileName | fileName := UIManager default request: 'Please enter the image file name' translated initialAnswer: 'fileName'. fileName isEmptyOrNil ifTrue: [^ self]. self form: (Form fromFileNamed: fileName). ! ! !ImageMorph methodsFor: 'caching' stamp: ''! releaseCachedState super releaseCachedState. image hibernate. ! ! !ImageMorph methodsFor: 'geometry' stamp: 'gvc 9/25/2006 15:45'! adoptPaneColor: paneColor "Change our border color too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self borderStyle baseColor: paneColor twiceDarker! ! !ImageMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 17:18'! color: aColor "Set the color. Change to a ColorForm here if depth 1." super color: aColor. (image depth = 1 and: [aColor isColor]) ifTrue: [ image isColorForm ifFalse: [ image := ColorForm mappingWhiteToTransparentFrom: image]. image colors: {Color transparent. aColor}. self changed]! ! !ImageMorph methodsFor: 't-rotating' stamp: ''! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !ImageMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 5/23/2013 17:28'! initialize super initialize. self form: self defaultImage. ! ! !ImageMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 17:22'! borderWidth: bw | newExtent | newExtent := 2 * bw + image extent. bounds extent = newExtent ifFalse: [super extent: newExtent]. super borderWidth: bw! ! !ImageMorph methodsFor: '*Deprecated30' stamp: 'StephaneDucasse 5/23/2013 17:26'! newForm: aForm self deprecated: 'Use form: instead' on: '23 May 2013' in: #pharo30. self form: aForm! ! !ImageMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 17:22'! isOpaque: aBool "Mark the receiver as being completely opaque or not" aBool == false ifTrue: [self removeProperty: #isOpaque] ifFalse: [self setProperty: #isOpaque toValue: aBool]. self changed! ! !ImageMorph methodsFor: 'menu' stamp: 'ar 11/7/2000 14:57'! changeOpacity self isOpaque: self isOpaque not! ! !ImageMorph methodsFor: 't-rotating' stamp: ''! prepareForRotating "If I require a flex shell to rotate, then wrap it in one and return it. Polygons, eg, may override to do nothing." ^ self addFlexShell! ! !ImageMorph methodsFor: 't-rotating' stamp: ''! rotationDegrees: degrees "redefined in all morphs which are using myself"! ! !ImageMorph methodsFor: 't-rotating' stamp: ''! setDirectionFrom: aPoint | delta degrees | delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition. degrees := delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! !ImageMorph methodsFor: 'accessing' stamp: 'gvc 8/27/2009 11:56'! borderStyle: newStyle "Set the extent to include border width." | newExtent | self borderStyle = newStyle ifTrue: [^self]. newExtent := 2 * newStyle width + image extent. bounds extent = newExtent ifFalse: [super extent: newExtent]. super borderStyle: newStyle! ! !ImageMorph methodsFor: 'other' stamp: 'StephaneDucasse 5/23/2013 18:06'! imageExport ^ self form bits asArray! ! !ImageMorph methodsFor: '*Deprecated30' stamp: 'StephaneDucasse 5/23/2013 17:27'! setNewImageFrom: form "Change the receiver's image to be one derived from the supplied form." self deprecated: 'Use form: instead' on: '23 May 2013' in: #pharo30. self form: form! ! !ImageMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 17:22'! isOpaque "Return true if the receiver is marked as being completely opaque" ^ self valueOfProperty: #isOpaque ifAbsent: [false]! ! !ImageMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 18:32'! image: anImage image := anImage. super extent: (2 * self borderWidth) asPoint + image extent. self changed! ! !ImageMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 17:20'! form ^ image ! ! !ImageMorph methodsFor: 'geometry' stamp: 'BenjaminVanRyseghem 10/17/2013 18:08'! extent: aPoint "Do nothing; my extent is determined by my image Form." self triggerEvent: #extent with: aPoint! ! !ImageMorph methodsFor: 'drawing' stamp: 'StephaneDucasse 5/23/2013 17:19'! drawOn: aCanvas "Draw the border after the image." | style | self isOpaque ifTrue: [aCanvas drawImage: image at: self innerBounds origin] ifFalse: [aCanvas translucentImage: image at: self innerBounds origin]. (style := self borderStyle) ifNotNil: [style frameRectangle: bounds on: aCanvas]! ! !ImageMorph methodsFor: '*Deprecated30' stamp: 'StephaneDucasse 5/23/2013 17:26'! image self deprecated: 'Use form instead' on: '23 May 2013' in: #pharo30. ^ self form ! ! !ImageMorph methodsFor: 'menus' stamp: 'ar 11/7/2000 14:55'! addCustomMenuItems: aMenu hand: aHand super addCustomMenuItems: aMenu hand: aHand. aMenu addUpdating: #opacityString action: #changeOpacity! ! !ImageMorph methodsFor: 'menu' stamp: 'StephaneDucasse 4/22/2012 16:48'! opacityString ^ (self isOpaque) -> 'opaque' translated! ! !ImageMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 17:20'! withSnapshotBorder self borderStyle: ((ComplexBorder style: #complexFramed) color: (Color r: 0.613 g: 1.0 b: 0.516); width: 1; yourself)! ! !ImageMorph methodsFor: 'menu commands' stamp: 'StephaneDucasse 5/23/2013 18:35'! grabFromScreen self form: Form fromUser. ! ! !ImageMorph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 7/3/2013 15:51'! drawOnAthensCanvas: aCanvas | cached | cached := aCanvas cacheAt: image ifAbsentPut: [ image asAthensPaintOn: aCanvas. ]. aCanvas setPaint: cached. aCanvas paintTransform restoreAfter: [ aCanvas paintTransform translateBy: self innerBounds origin "negated". aCanvas drawShape: self innerBounds. ]. ! ! !ImageMorph methodsFor: 't-rotating' stamp: ''! heading "Return the receiver's heading" ^ self owner ifNil: [self forwardDirection] ifNotNil: [self forwardDirection + self owner degreesOfFlex]! ! !ImageMorph methodsFor: 'testing' stamp: 'StephaneDucasse 12/5/2009 21:08'! areasRemainingToFill: aRectangle ^self isOpaque ifTrue: [aRectangle areasOutside: self bounds] ifFalse: [Array with: aRectangle]! ! !ImageMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 18:33'! form: aForm image := aForm. super extent: (2 * self borderWidth) asPoint + image extent. self changed! ! !ImageMorph methodsFor: '*Spec-Inspector' stamp: 'BenjaminVanRyseghem 10/17/2013 18:10'! resize: newSize self form: (image scaledToSize: newSize)! ! !ImageMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:36'! defaultImage "Answer the default image for the receiver." ^ DefaultForm! ! !ImageMorph methodsFor: 't-rotating' stamp: ''! rotationDegrees "Default implementation." ^ 0.0 ! ! !ImageMorph class methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:59'! defaultForm ^DefaultForm! ! !ImageMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 3/3/2010 15:16'! fromStream: aStream ^self withForm: (ImageReadWriter formFromStream: aStream)! ! !ImageMorph class methodsFor: 'initialization' stamp: 'AlainPlantec 10/17/2009 18:03'! initialize "ImageMorph initialize" | h p d | DefaultForm := (Form extent: 80@40 depth: 16). h := DefaultForm height // 2. 0 to: h - 1 do: [:i | p := (i * 2)@i. d := i asFloat / h asFloat. DefaultForm fill: (p corner: DefaultForm extent - p) fillColor: (Color r: d g: 0.5 b: 1.0 - d)]. ! ! !ImageMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 11/29/2009 21:34'! fromString: aString "Create a new ImageMorph which displays the input string in the standard button font" ^ self fromString: aString font: StandardFonts buttonFont! ! !ImageMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 5/23/2013 18:23'! fromString: aString font: aFont "Create a new ImageMorph showing the given string in the given font" ^ self new form: (StringMorph contents: aString font: aFont) imageForm! ! !ImageMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 5/23/2013 18:23'! withForm: aForm ^ self new form: aForm ; yourself! ! !ImagePreviewMorph commentStamp: 'gvc 5/18/2007 12:51'! Displays an image scaled to a fixed size along with a label describing the original dimensions.! !ImagePreviewMorph methodsFor: 'accessing' stamp: 'gvc 10/9/2006 14:25'! imageMorph: anObject "Set the value of imageMorph" imageMorph := anObject! ! !ImagePreviewMorph methodsFor: 'accessing' stamp: 'gvc 10/9/2006 14:25'! imageMorph "Answer the value of imageMorph" ^ imageMorph! ! !ImagePreviewMorph methodsFor: 'initialization' stamp: 'gvc 10/9/2006 14:42'! initialize "Initialize the receiver." super initialize. self changeTableLayout; color: Color transparent; hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellInset: 16; imageMorph: self newImageMorph; textMorph: self newTextMorph; addMorphBack: self imageMorph; addMorphBack: self textMorph! ! !ImagePreviewMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2006 14:42'! newImageMorph "Answer a new image morph." ^AlphaImageMorph new borderStyle: (BorderStyle inset width: 1); color: Color white; alpha: 1.0! ! !ImagePreviewMorph methodsFor: 'accessing' stamp: 'gvc 10/9/2006 14:25'! textMorph "Answer the value of textMorph" ^ textMorph! ! !ImagePreviewMorph methodsFor: 'accessing' stamp: 'gvc 10/9/2006 14:25'! textMorph: anObject "Set the value of textMorph" textMorph := anObject! ! !ImagePreviewMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:59'! defaultImageFormOfSize: aPoint "Answer a default preview image form." ^(defaultImageForm isNil or: [defaultImageForm extent ~= aPoint]) ifTrue: [defaultImageForm := Form extent: aPoint] ifFalse: [defaultImageForm]! ! !ImagePreviewMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2006 14:33'! cornerStyle: aSymbol "Pass on to selector and content too." super cornerStyle: aSymbol. self imageMorph cornerStyle: aSymbol! ! !ImagePreviewMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/1/2007 12:38'! image: form size: imageSize "Set the image and update the description." form ifNil: [self imageMorph image: (self defaultImageFormOfSize: imageSize). self textMorph contents: ''] ifNotNil: [self imageMorph image: form size: imageSize. self textMorph contents: ('{1} x {2} pixels' translated format: {form width asString. form height asString})] ! ! !ImagePreviewMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/9/2006 14:34'! newTextMorph "Answer a new text morph." ^StringMorph contents: ''! ! !ImageReadWriter commentStamp: ''! Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved. I am an abstract class to provide for encoding and/or decoding an image on a stream. Instance Variables: stream stream for image storages Class Variables: ImageNotStoredSignal image not stored error signal MagicNumberErrorSignal magic number error signal Subclasses must implement the following messages: accessing nextImage nextPutImage: testing canUnderstand (added tao 10/26/97)! !ImageReadWriter methodsFor: 'stream access' stamp: ''! skip: anInteger ^stream skip: anInteger! ! !ImageReadWriter methodsFor: 'stream access' stamp: 'sd 1/30/2004 15:18'! close stream close! ! !ImageReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! changePadOfBits: bits width: width height: height depth: depth from: oldPad to: newPad "Change padding size of bits." | srcRowByteSize dstRowByteSize newBits srcRowBase rowEndOffset | (#(8 16 32 ) includes: oldPad) ifFalse: [ ^ self error: 'Invalid pad: ' , oldPad printString ]. (#(8 16 32 ) includes: newPad) ifFalse: [ ^ self error: 'Invalid pad: ' , newPad printString ]. srcRowByteSize := (width * depth + oldPad - 1) // oldPad * (oldPad / 8). srcRowByteSize * height = bits size ifFalse: [ ^ self error: 'Incorrect bitmap array size.' ]. dstRowByteSize := (width * depth + newPad - 1) // newPad * (newPad / 8). newBits := ByteArray new: dstRowByteSize * height. srcRowBase := 1. rowEndOffset := dstRowByteSize - 1. 1 to: newBits size by: dstRowByteSize do: [ :dstRowBase | newBits replaceFrom: dstRowBase to: dstRowBase + rowEndOffset with: bits startingAt: srcRowBase. srcRowBase := srcRowBase + srcRowByteSize ]. ^ newBits! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! next ^stream next! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! position: anInteger ^stream position: anInteger! ! !ImageReadWriter methodsFor: 'stream access' stamp: 'tao 10/23/97 18:00'! peekFor: aValue ^stream peekFor: aValue! ! !ImageReadWriter methodsFor: 'accessing' stamp: ''! nextImage "Dencoding an image on stream and answer the image." ^self subclassResponsibility! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! nextPutAll: aByteArray ^stream nextPutAll: aByteArray! ! !ImageReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! on: aStream (stream := aStream) reset. stream binary "Note that 'reset' makes a file be text. Must do this after."! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! cr ^stream nextPut: Character cr asInteger! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! tab ^stream nextPut: Character tab asInteger! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! lf "PPM and PBM are used LF as CR." ^stream nextPut: Character lf asInteger! ! !ImageReadWriter methodsFor: 'accessing' stamp: ''! nextPutImage: anImage "Encoding anImage on stream." ^self subclassResponsibility! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! atEnd ^stream atEnd! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! nextPut: aByte ^stream nextPut: aByte! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! size ^stream size! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! next: size ^stream next: size! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! space ^stream nextPut: Character space asInteger! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! nextLongPut: a32BitW "Write out a 32-bit integer as 32 bits." stream nextPut: ((a32BitW bitShift: -24) bitAnd: 16rFF). stream nextPut: ((a32BitW bitShift: -16) bitAnd: 16rFF). stream nextPut: ((a32BitW bitShift: -8) bitAnd: 16rFF). stream nextPut: (a32BitW bitAnd: 16rFF). ^a32BitW! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! nextWord "Read a 16-bit quantity from the input stream." ^(stream next bitShift: 8) + stream next! ! !ImageReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! unpackBits: bits depthTo8From: depth with: width height: height pad: pad "Unpack bits of depth 1, 2, or 4 image to it of depth 8 image." | bitMask pixelInByte bitsWidth upBitsWidth stopWidth trailingSize upBits bitIndex upBitIndex val | (#(1 2 4 ) includes: depth) ifFalse: [ ^ self error: 'depth must be 1, 2, or 4' ]. (#(8 16 32 ) includes: pad) ifFalse: [ ^ self error: 'pad must be 8, 16, or 32' ]. bitMask := (1 bitShift: depth) - 1. pixelInByte := 8 / depth. bitsWidth := (width * depth + pad - 1) // pad * (pad / 8). upBitsWidth := (width * 8 + pad - 1) // pad * (pad / 8). stopWidth := (width * depth + 7) // 8. trailingSize := width - ((stopWidth - 1) * pixelInByte). upBits := ByteArray new: upBitsWidth * height. 1 to: height do: [ :i | bitIndex := (i - 1) * bitsWidth. upBitIndex := (i - 1) * upBitsWidth. 1 to: stopWidth - 1 do: [ :j | val := bits at: (bitIndex := bitIndex + 1). upBitIndex := upBitIndex + pixelInByte. 1 to: pixelInByte do: [ :k | upBits at: upBitIndex - k + 1 put: (val bitAnd: bitMask). val := val bitShift: depth negated ] ]. val := (bits at: (bitIndex := bitIndex + 1)) bitShift: depth negated * (pixelInByte - trailingSize). upBitIndex := upBitIndex + trailingSize. 1 to: trailingSize do: [ :k | upBits at: upBitIndex - k + 1 put: (val bitAnd: bitMask). val := val bitShift: depth negated ] ]. ^ upBits! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! position ^stream position! ! !ImageReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! hasMagicNumber: aByteArray | position | position := stream position. (stream size - position >= aByteArray size and: [ (stream next: aByteArray size) = aByteArray ]) ifTrue: [ ^ true ]. stream position: position. ^ false! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! nextLong "Read a 32-bit quantity from the input stream." ^(stream next bitShift: 24) + (stream next bitShift: 16) + (stream next bitShift: 8) + stream next! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! contents ^stream contents! ! !ImageReadWriter methodsFor: 'testing' stamp: 'tao 10/27/97 09:26'! understandsImageFormat "Test to see if the image stream format is understood by this decoder. This should be implemented in each subclass of ImageReadWriter so that a proper decoder can be selected without ImageReadWriter having to know about all possible image file types." ^ false! ! !ImageReadWriter methodsFor: 'stream access' stamp: ''! nextWordPut: a16BitW "Write out a 16-bit integer as 16 bits." stream nextPut: ((a16BitW bitShift: -8) bitAnd: 16rFF). stream nextPut: (a16BitW bitAnd: 16rFF). ^a16BitW! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! allTypicalFileExtensions "Answer a collection of file extensions (lowercase) which files that my subclasses can read might commonly have" "ImageReadWriter allTypicalFileExtensions" | extensions | extensions := Set new. self allSubclassesDo: [ :cls | extensions addAll: cls typicalFileExtensions ]. ^ extensions! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:55'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#()! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! formFromStream: aBinaryStream "Answer a ColorForm stored on the given stream. closes the stream" | reader readerClass form | readerClass := self withAllSubclasses detect: [ :subclass | subclass understandsImageFormat: aBinaryStream ] ifNone: [ aBinaryStream close. ^ self error: 'image format not recognized' ]. reader := readerClass new on: aBinaryStream reset. Cursor read showWhile: [ form := reader nextImage. reader close ]. ^ form! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! putForm: aForm onStream: aWriteStream "Store the given form on a file of the given name." | writer | writer := self on: aWriteStream. Cursor write showWhile: [ writer nextPutImage: aForm ]. writer close! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! formFromFileNamed: fileName "Answer a ColorForm stored on the file with the given name." | stream | stream := FileStream readOnlyFileNamed: fileName. ^ self formFromStream: stream! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'ar 3/1/2006 22:59'! understandsImageFormat: aStream ^[(self new on: aStream) understandsImageFormat] on: Error do:[:ex| ex return: false]! ! !ImageReadWriter class methodsFor: 'instance creation' stamp: ''! on: aStream "Answer an instance of the receiver for encoding and/or decoding images on the given." ^ self new on: aStream ! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'lr 7/4/2009 10:42'! putForm: aForm onFileNamed: fileName "Store the given form on a file of the given name." | writer | writer := self on: (FileStream newFileNamed: fileName) binary. Cursor write showWhile: [ writer nextPutImage: aForm ]. writer close! ! !InMidstOfFileinNotification commentStamp: ''! I am a Hack. I am a notification used to know if the the current process is in the middle of a FileIn. But I am used everywhere. Probably I should be removed, but not now.! !InMidstOfFileinNotification methodsFor: 'exceptiondescription' stamp: 'RAA 5/28/2001 17:07'! defaultAction self resume: false! ! !IncompatibleLayoutConflict commentStamp: ''! I am an error raised when extending a class with an incompatible layout.! !IncompatibleLayoutConflict methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:28'! layout: anObject layout := anObject! ! !IncompatibleLayoutConflict methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:30'! messageText ^ 'Class with ', layout class name, ' cannot be extended as ', subType! ! !IncompatibleLayoutConflict methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:28'! subType: anObject subType := anObject! ! !IncompatibleLayoutConflict methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:28'! layout ^ layout! ! !IncompatibleLayoutConflict methodsFor: 'accessing' stamp: 'ToonVerwaest 3/21/2011 01:28'! subType ^ subType! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! getValueSelector "Answer the value of getValueSelector" ^ getValueSelector! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'MarcusDenker 12/11/2009 09:34'! enabled "Answer whether the receiver is enabled for user input." ^self sliderMorph ifNil: [super enabled] ifNotNil: [:sm | sm enabled]! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:56'! decrement "Decrement the value." self value: self value - self quantum! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 12/7/2011 14:12'! minExtent "Must answer a fixed small size here to allow auto orientation to work." |superMin| superMin := super minExtent. ^(24 max: superMin x) @ (24 max: superMin y)! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:18'! sliderMorph: anObject "Set the value of sliderMorph" sliderMorph := anObject! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:31'! max "Answer the max value." ^(self sliderMorph ifNil: [^0]) max! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:35'! notAtMax "Answer whether the value is not at the maximum," ^self value < self max! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 15:19'! updateOrientation: aPoint "Set the layout for the new extent." |butts| butts := self buttons. aPoint x >= aPoint y ifTrue: [self listDirection: #leftToRight. butts first roundedCorners: #(1 2); hResizing: #rigid; vResizing: #spaceFill; width: aPoint y; label: (self newButtonLabel: #left ofSize: aPoint y // 2). butts last roundedCorners: #(3 4); hResizing: #rigid; vResizing: #spaceFill; width: aPoint y; label: (self newButtonLabel: #right ofSize: aPoint y // 2)] ifFalse: [self listDirection: #topToBottom. butts first roundedCorners: #(1 4); hResizing: #spaceFill; vResizing: #rigid; height: aPoint x; label: (self newButtonLabel: #top ofSize: aPoint x // 2). butts last roundedCorners: #(2 3); hResizing: #spaceFill; vResizing: #rigid; height: aPoint x; label: (self newButtonLabel: #bottom ofSize: aPoint x // 2)]! ! !IncrementalSliderMorph methodsFor: 'initialize-release' stamp: 'FernandoOlivero 4/12/2011 09:47'! newDecrementButton "Answer a new decrement button." ^(self theme builder newButtonFor: self action: #decrement getEnabled: #minEnabled label: (self newButtonLabel: #left ofSize: 24) help: nil) vResizing: #spaceFill; width: 64; roundedCorners: #(1 2); setProperty: #wantsKeyboardFocusNavigation toValue: false; on: #mouseStillDown send: #decrement to: self! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! setValueSelector: anObject "Set the value of setValueSelector" setValueSelector := anObject! ! !IncrementalSliderMorph methodsFor: 'initialize-release' stamp: 'gvc 9/3/2009 13:54'! defaultSliderFillStyle "Answer the hue gradient." ^(GradientFillStyle colors: {Color white. Color black}) origin: self topLeft; direction: (self bounds isWide ifTrue: [self width@0] ifFalse: [0@self height])! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! getValueSelector: anObject "Set the value of getValueSelector" getValueSelector := anObject! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:56'! increment "Increment the value." self value: self value + self quantum! ! !IncrementalSliderMorph methodsFor: 'initialization' stamp: 'gvc 9/2/2009 14:22'! initialize "Initialize the receiver." super initialize. self sliderMorph: self newSliderMorph. self changeTableLayout; listDirection: #leftToRight; cellInset: 0; borderWidth: 0; hResizing: #spaceFill; vResizing: #spaceFill; borderColor: Color transparent; addMorphBack: self newDecrementButton; addMorphBack: self sliderMorph; addMorphBack: self newIncrementButton! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 5/23/2013 18:38'! newButtonLabel: direction ofSize: size "Answer a new label for an inc/dec button." ^AlphaImageMorph new image: (ScrollBar arrowOfDirection: direction size: size color: self paneColor darker)! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/4/2009 16:15'! value "Answer the slider value." ^self getValueSelector ifNil: [(self sliderMorph ifNil: [^0]) scaledValue] ifNotNil: [self model ifNil: [(self sliderMorph ifNil: [^0]) scaledValue] ifNotNil: [self model perform: self getValueSelector]]! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:13'! maxEnabled "Answer whether the maximum button should be enabled." ^self enabled and: [self notAtMax]! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:31'! quantum "Answer the quantum value." ^(self sliderMorph ifNil: [^0]) quantum! ! !IncrementalSliderMorph methodsFor: 'initialize-release' stamp: 'FernandoOlivero 4/12/2011 09:47'! newIncrementButton "Answer a new increment button." ^(self theme builder newButtonFor: self action: #increment getEnabled: #maxEnabled label: (self newButtonLabel: #right ofSize: 24) help: nil) vResizing: #spaceFill; width: 64; roundedCorners: #(3 4); setProperty: #wantsKeyboardFocusNavigation toValue: false; on: #mouseStillDown send: #increment to: self! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:13'! minEnabled "Answer whether the minimum button should be enabled." ^self enabled and: [self notAtMin]! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! setValueSelector "Answer the value of setValueSelector" ^ setValueSelector! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2009 13:17'! value: aNumber "Set the slider value." (self sliderMorph ifNil: [^self]) scaledValue: aNumber. self model ifNotNil: [ self setValueSelector ifNotNil: [ self model perform: self setValueSelector with: self sliderMorph scaledValue]]. self changed: #minEnabled; changed: #maxEnabled! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'MarcusDenker 12/11/2009 07:39'! enabled: aBoolean "Set whether the receiver is enabled for user input." self sliderMorph ifNotNil: [:sm | sm enabled: aBoolean]. self changed: #enabled; changed: #minEnabled; changed: #maxEnabled! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:55'! quantum: aNumber "Set the quantum value." (self sliderMorph ifNil: [^self]) quantum: aNumber! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:45'! buttons "Answer the buttons." ^{self firstSubmorph. self lastSubmorph}! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 15:17'! extent: aPoint "Set the button width to match the height." self extent = aPoint ifTrue: [^self]. super extent: aPoint. self updateOrientation: aPoint! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:24'! update: aSymbol "Update the value." super update: aSymbol. aSymbol = self getValueSelector ifTrue: [^self updateValue]. aSymbol = self getEnabledSelector ifTrue: [^self updateEnabled]! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:35'! notAtMin "Answer whether the value is not at the minimum," ^self value > self min! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/8/2009 13:26'! updateEnabled "Update the enablement state." self model ifNotNil: [ self getEnabledSelector ifNotNil: [ self enabled: (self model perform: self getEnabledSelector)]]! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:55'! min: aNumber "Set the min value." (self sliderMorph ifNil: [^self]) min: aNumber! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:31'! min "Answer the min value." ^(self sliderMorph ifNil: [^0]) min! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/10/2009 13:37'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:55'! max: aNumber "Set the max value." (self sliderMorph ifNil: [^self]) max: aNumber! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:02'! on: anObject getValue: getSel setValue: setSel "Use the given selectors as the interface." self model: anObject; getValueSelector: getSel; setValueSelector: setSel; updateValue! ! !IncrementalSliderMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 12/11/2009 07:39'! updateValue "Update the value." self model ifNotNil: [ self getValueSelector ifNotNil: [ self sliderMorph ifNotNil: [:sm | sm scaledValue: self value. self changed: #minEnabled; changed: #maxEnabled]]]! ! !IncrementalSliderMorph methodsFor: 'initialize-release' stamp: 'FernandoOlivero 4/12/2011 09:47'! newSliderMorph "Answer a new morph for the slider." |slider| slider := self theme builder newBracketSliderFor: self getValue: #value setValue: #value: min: 0 max: 100 quantum: 1 getEnabled: #enabled help: nil. slider fillStyle: self defaultSliderFillStyle. ^slider! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:18'! sliderMorph "Answer the value of sliderMorph" ^ sliderMorph! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/10/2009 13:37'! getEnabledSelector: aSymbol "Set the value of getEnabledSelector" getEnabledSelector := aSymbol. self updateEnabled! ! !IncrementalSliderMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:02'! on: anObject getValue: getSel setValue: setSel "Answer a new instance of the receiver with the given selectors as the interface." ^self new on: anObject getValue: getSel setValue: setSel! ! !IncrementalSliderMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:01'! on: anObject getValue: getSel setValue: setSel min: min max: max quantum: quantum "Answer a new instance of the receiver with the given selectors as the interface." ^self new min: min; max: max; quantum: quantum; on: anObject getValue: getSel setValue: setSel! ! !IndentingListItemMorph commentStamp: 'AlainPlantec 1/7/2010 22:16'! An IndentingListItemMorph is a StringMorph that draws itself with an optional toggle at its left, as part of the display of the SimpleHierarchicalListMorph. It will also display lines around the toggle depending on UITheme settings Instance variables: indentLevel the indent level, from 0 at the root and increasing by 1 at each level of the hierarchy. isExpanded true if this item is expanded (showing its children) complexContents an adapter wrapping my represented item that can answer its children, etc. firstChild my first child, or nil if none container my container nextSibling the next item in the linked list of siblings, or nil if none. Contributed by Bob Arning as part of the ObjectExplorer package. Don't blame him if it's not perfect. We wanted to get it out for people to play with.! !IndentingListItemMorph methodsFor: 'private' stamp: 'RAA 7/11/1998 14:25'! withSiblingsDo: aBlock | node | node := self. [node isNil] whileFalse: [ aBlock value: node. node := node nextSibling ].! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'dgd 9/25/2004 22:25'! hasIcon "Answer whether the receiver has an icon." ^ icon notNil! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'panda 4/28/2000 15:30'! children | children | children := OrderedCollection new. self childrenDo: [:each | children add: each]. ^children! ! !IndentingListItemMorph methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'! withoutListWrapper ^complexContents withoutListWrapper! ! !IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 13:56'! outerBounds "Return the 'outer' bounds of the receiver, e.g., the bounds that need to be invalidated when the receiver changes." |box| box := super outerBounds. container ifNil: [^box]. ^box left: (box left min: self selectionFrame left)! ! !IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme "Answer the ui theme that provides controls. Done directly here to avoid performance hit of looking up in window." ^ Smalltalk ui theme ! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 3/8/2004 11:43'! drawLinesOn: aCanvas lineColor: lineColor | hasToggle | hasToggle := self hasToggle. "Draw line from toggle to text" self drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle. "Draw the line from my toggle to the nextSibling's toggle" self nextSibling ifNotNil: [ self drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle ]. "If I have children and am expanded, draw a line to my first child" (self firstChild notNil and: [ self isExpanded ]) ifTrue: [ self drawLinesToFirstChildOn: aCanvas lineColor: lineColor]! ! !IndentingListItemMorph methodsFor: 'private' stamp: 'CarloTeixeira 7/2/2010 23:44'! findExactPathMatchIn: anArray self withSiblingsDo: [:each | (each complexContents asString = anArray first or: [anArray first isNil]) ifTrue: [^ each]]. ^ nil! ! !IndentingListItemMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'! initialize "initialize the state of the receiver" super initialize. "" indentLevel := 0. isExpanded := false! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/30/2000 19:15'! indentLevel ^indentLevel! ! !IndentingListItemMorph methodsFor: 'enumeration' stamp: 'panda 4/28/2000 15:29'! childrenDo: aBlock firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aBlock value: aNode]. ]! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'bf 2/9/2004 10:55'! userString "Add leading tabs to my userString" ^ (String new: indentLevel withAll: Character tab), super userString ! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'MarcusDenker 1/23/2011 09:19'! drawLinesToFirstChildOn: aCanvas lineColor: lineColor "Draw line from me to first child. Don't bother if the first child has a toggle.." | vLineX vLineTop vLineBottom childBounds childCenter myTheme | self firstChild hasToggle ifTrue: [ ^ self ]. childBounds := self firstChild toggleBounds. childCenter := childBounds center. vLineX := childCenter x. vLineTop := bounds bottom. vLineBottom := self firstChild hasToggle ifTrue: [ childCenter y - (childBounds height // 2) + 1 ] ifFalse: [ childCenter y - 2 ]. myTheme := self theme. aCanvas frameRectangle: (vLineX @ vLineTop corner: (vLineX + 1) @ vLineBottom) width: myTheme treeLineWidth colors: (myTheme treeLineColorsFrom: lineColor) dashes: myTheme treeLineDashes! ! !IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'MarcusDenker 1/23/2011 09:19'! toggleExpandedState isExpanded := isExpanded not. self refreshExpandedState.! ! !IndentingListItemMorph methodsFor: 'search' stamp: 'BenjaminVanRyseghem 5/31/2011 15:36'! searchingString " string used to detect research " ^ self contents asString! ! !IndentingListItemMorph methodsFor: 'private' stamp: 'CarloTeixeira 7/2/2010 23:46'! findSimilarPathMatchIn: anArray self withSiblingsDo: [:each | (each complexContents asString sameAs: anArray first) ifTrue: [^ each]]. ^ nil! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/31/1998 00:30'! isExpanded ^isExpanded! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 6/24/2012 23:12'! drawOn: aCanvas | tRect sRect columnScanner colorToUse columnLeft | tRect := self toggleRectangle. sRect := bounds withLeft: tRect right + 4. self drawToggleOn: aCanvas in: tRect. colorToUse := complexContents preferredColor ifNil: [ color ]. icon isNil ifFalse: [ aCanvas translucentImage: icon at: sRect left @ (self top + ((self height - icon height) // 2)). sRect := sRect left: sRect left + icon width + 2 ]. (container columns isNil or: [ (contents asString indexOf: Character tab) = 0 ]) ifTrue: [ sRect := sRect top: (sRect top + sRect bottom - self fontToUse height) // 2. contents treeRenderOn: aCanvas bounds: sRect color: colorToUse font: self fontToUse from: self ] ifFalse: [ columnLeft := sRect left. columnScanner := contents asString readStream. container columns do: [ :width | | columnData columnRect | columnRect := columnLeft @ sRect top extent: width @ sRect height. columnData := columnScanner upTo: Character tab. columnData isEmpty ifFalse: [ aCanvas drawString: columnData in: columnRect font: self fontToUse color: colorToUse ]. columnLeft := columnRect right + 5 ] ]! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'AlainPlantec 2/11/2011 15:05'! drawToggleOn: aCanvas in: aRectangle | aForm centeringOffset | complexContents hasContents ifFalse: [^self]. aForm := isExpanded ifTrue: [container expandedFormForMorph: self] ifFalse: [container notExpandedFormForMorph: self]. centeringOffset := ((aRectangle height - aForm extent y) / 2.0) truncated. ^aCanvas translucentImage: aForm at: (aRectangle topLeft translateBy: 0 @ centeringOffset). ! ! !IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 6/21/1999 14:54'! recursiveAddTo: aCollection firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: aCollection]. ]. aCollection add: self ! ! !IndentingListItemMorph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/11/2012 14:56'! drawOnAthensCanvas: aCanvas | tRect sRect columnScanner colorToUse columnLeft | tRect := self toggleRectangle. sRect := bounds withLeft: tRect right + 4. " self athensDrawToggleOn: aCanvas in: tRect. " colorToUse := complexContents preferredColor ifNil: [ color ]. icon isNil ifFalse: [ "aCanvas translucentImage: icon at: sRect left @ (self top + ((self height - icon height) // 2))." sRect := sRect left: sRect left + icon width + 2 ]. (container columns isNil or: [ (contents asString indexOf: Character tab) = 0 ]) ifTrue: [ sRect := sRect top: (sRect top + sRect bottom - self fontToUse height) // 2. "contents treeRenderOn: aCanvas bounds: sRect color: colorToUse font: self fontToUse from: self" ] ifFalse: [ columnLeft := sRect left. columnScanner := contents asString readStream. container columns do: [ :width | | columnData columnRect | columnRect := columnLeft @ sRect top extent: width @ sRect height. columnData := columnScanner upTo: Character tab. columnData isEmpty ifFalse: [ aCanvas morphicDrawString: columnData in: columnRect font: self fontToUse color: colorToUse ]. columnLeft := columnRect right + 5 ] ]! ! !IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'ThierryGoubier 9/21/2012 14:32'! measureContents "Round up in case fractional." | f iconWidth | f := self fontToUse. iconWidth := self hasIcon ifTrue: [self icon width + 2] ifFalse: [0]. ^ ((13 * indentLevel + 15 + iconWidth + (contents widthToDisplayInTree: self) max: self minimumWidth) @ ((contents heightToDisplayInTree: self) max: f height) + (self layoutInset * 2)) ceiling! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 3/31/1999 17:44'! canExpand ^complexContents hasContents! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/21/2000 11:00'! balloonText ^complexContents balloonText ifNil: [super balloonText]! ! !IndentingListItemMorph methodsFor: 'halos and balloon help' stamp: 'IgorStasenko 12/22/2012 02:55'! boundsForBalloon "some morphs have bounds that are way too big" container ifNil: [^super boundsForBalloon]. ^self boundsInWorld intersect: container boundsInWorld ifNone: [self boundsInWorld ]! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 6/10/2012 20:25'! isFirstItem "I have no idea why the owner of the list can get nil but it happens when the packages are published with the Monticello Browser." ^ (owner ~= nil) and: [owner submorphs first == self]! ! !IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'CarloTeixeira 7/2/2010 23:54'! openPath: anArray | found | anArray isEmpty ifTrue: [^ container setSelectedMorph: nil]. found := self findPathIn: anArray. found ifNil: [^ container setSelectedMorph: nil]. found isExpanded ifTrue: [found refreshExpandedState] ifFalse: [found toggleExpandedState]. container adjustSubmorphPositions. found changed. anArray size = 1 ifTrue: [^ container setSelectedMorph: found]. ^ found firstChild ifNil: [container setSelectedMorph: nil] ifNotNil: [found firstChild openPath: anArray allButFirst]! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'dgd 9/25/2004 22:27'! icon "answer the receiver's icon" ^ icon! ! !IndentingListItemMorph methodsFor: 'initialization' stamp: 'ThierryGoubier 9/21/2012 14:21'! initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel container := hostList. complexContents := anObject. indentLevel := newLevel. self initWithContents: anObject asString font: StandardFonts listFont emphasis: nil. isExpanded := false. nextSibling := firstChild := nil. priorMorph ifNotNil: [ priorMorph nextSibling: self. ]. icon := anObject icon. self extent: self minWidth @ self minHeight! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 8/1/1998 01:05'! nextSibling: anotherMorph nextSibling := anotherMorph! ! !IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'CarloTeixeira 7/2/2010 23:11'! refreshExpandedState | newChildren toDelete c | toDelete := OrderedCollection new. firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: toDelete]. ]. container noteRemovalOfAll: toDelete. (isExpanded and: [complexContents hasContents]) ifFalse: [ ^self changed ]. (c := complexContents contents) isEmpty ifTrue: [^self changed]. newChildren := container addSubmorphsAfter: self fromCollection: c allowSorting: true. firstChild := newChildren first. ! ! !IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 8/3/1999 09:47'! highlight complexContents highlightingColor ifNotNil: [self color: complexContents highlightingColor]. self changed. ! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/31/1998 00:48'! isExpanded: aBoolean isExpanded := aBoolean! ! !IndentingListItemMorph methodsFor: 'private' stamp: 'nk 2/19/2004 18:29'! hasToggle ^ complexContents hasContents! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/11/1998 12:15'! nextSibling ^nextSibling! ! !IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 10:47'! changed "Need to invalidate the selection frame." container ifNil: [^super changed]. self invalidRect: self selectionFrame. super changed! ! !IndentingListItemMorph methodsFor: 'private' stamp: 'nk 12/5/2002 15:16'! toggleBounds ^self toggleRectangle! ! !IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 13:56'! lastChild "Answer the last child." |c| c := self firstChild ifNil: [^nil]. [c nextSibling isNil] whileFalse: [c := c nextSibling]. ^c! ! !IndentingListItemMorph methodsFor: 'mouse events' stamp: 'ar 3/17/2001 17:32'! inToggleArea: aPoint ^self toggleRectangle containsPoint: aPoint! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'gvc 7/30/2009 13:55'! drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle "If I am not the only item in my container, draw the line between: - my toggle (if any) or my left edge (if no toggle) - and my text left edge. Only draw now if no toggle." | myBounds myCenter hLineY hLineLeft myTheme| self isSoleItem ifTrue: [ ^self ]. self hasToggle ifTrue: [^self]. myBounds := self toggleBounds. myCenter := myBounds center. hLineY := myCenter y - 1. hLineLeft := myCenter x. "Draw line from toggle to text. Use optimised form since vertical." myTheme := self theme. aCanvas frameRectangle: (hLineLeft @ hLineY corner: myBounds right + 3 @ (hLineY + 1)) width: myTheme treeLineWidth colors: (myTheme treeLineColorsFrom: lineColor) dashes: myTheme treeLineDashes! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/24/2012 22:44'! minWidth "Fixed to work such that guessed width is unnecessary in #adjustSubmorphPositions." | iconWidth | iconWidth := self hasIcon ifTrue: [self icon width + 2] ifFalse: [0]. ^(13 * indentLevel + 15 + (contents widthToDisplayInTree: self) + iconWidth) max: super minWidth! ! !IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/12/2006 15:34'! drawMouseDownHighlightOn: aCanvas "Draw with a dotted border." |frame| self highlightedForMouseDown ifTrue: [ container ifNil: [^super drawMouseDownHighlightOn: aCanvas]. frame := self selectionFrame. aCanvas frameRectangle: frame width: 1 colors: {container mouseDownHighlightColor. Color transparent} dashes: #(1 1)]! ! !IndentingListItemMorph methodsFor: 'drag and drop' stamp: 'nk 6/12/2004 16:49'! acceptDroppingMorph: toDrop event: evt complexContents acceptDroppingObject: toDrop complexContents. toDrop delete. self highlightForDrop: false.! ! !IndentingListItemMorph methodsFor: 'action' stamp: 'gvc 4/25/2007 19:42'! toggleRectangle | h | h := bounds height. ^(bounds left + (13 * indentLevel)) @ bounds top extent: 9@h! ! !IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 7/30/2000 19:49'! addChildrenForList: hostList addingTo: morphList withExpandedItems: expandedItems firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aNode delete]. ]. firstChild := nil. complexContents hasContents ifFalse: [^self]. firstChild := hostList addMorphsTo: morphList from: complexContents contents allowSorting: true withExpandedItems: expandedItems atLevel: indentLevel + 1. ! ! !IndentingListItemMorph methodsFor: 'private' stamp: 'CarloTeixeira 7/2/2010 23:53'! findPathIn: anArray | found | found := self findExactPathMatchIn: anArray. found ifNil: ["try again with no case sensitivity" found := self findSimilarPathMatchIn: anArray]. ^ found! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'nk 3/8/2004 09:15'! isSoleItem ^self isFirstItem and: [ owner submorphs size = 1 ]! ! !IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 4/2/1999 18:02'! recursiveDelete firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aNode recursiveDelete]. ]. self delete ! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'gvc 7/30/2009 13:55'! drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle "Draw line from me to next sibling" | myBounds nextSibBounds vLineX myCenter vLineTop vLineBottom myTheme| myBounds := self toggleBounds. nextSibBounds := self nextSibling toggleBounds. myCenter := myBounds center. vLineX := myCenter x. vLineTop := myCenter y + 1. vLineBottom := nextSibBounds center y - 1. "Draw line from me to next sibling" myTheme := self theme. aCanvas frameRectangle: (vLineX @ vLineTop corner: vLineX + 1 @ vLineBottom) width: myTheme treeLineWidth colors: (myTheme treeLineColorsFrom: lineColor) dashes: myTheme treeLineDashes! ! !IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/12/2006 15:34'! selectionFrame "Answer the selection frame rectangle." |frame| frame := self bounds: self bounds in: container. frame := self bounds: ((frame left: container innerBounds left) right: container innerBounds right) from: container. ^frame! ! !IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 7/11/1998 14:34'! complexContents ^complexContents! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 8/2/1999 16:48'! firstChild ^firstChild! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/24/2012 23:31'! minHeight "Answer the minimum height of the receiver." | iconHeight | iconHeight := self hasIcon ifTrue: [self icon height + 2] ifFalse: [0]. ^(( self contents heightToDisplayInTree: self) max: iconHeight) max: super minHeight! ! !IndentingListItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 11/15/2007 14:26'! openItemPath: anArray "Open a path based on wrapper item equivalence. Generally more specific than #openPath: (string based)." | found | anArray isEmpty ifTrue: [^ container setSelectedMorph: nil]. found := nil. self withSiblingsDo: [:each | found ifNil: [(each complexContents withoutListWrapper == anArray first or: [anArray first isNil]) ifTrue: [found := each]]]. found ifNotNil: [found isExpanded ifFalse: [found toggleExpandedState. container adjustSubmorphPositions]. found changed. anArray size = 1 ifTrue: [^ container setSelectedMorph: found]. ^ found firstChild ifNil: [container setSelectedMorph: nil] ifNotNil: [found firstChild openItemPath: anArray allButFirst]]. ^container setSelectedMorph: nil! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'RAA 8/3/1999 09:46'! unhighlight complexContents highlightingColor ifNotNil: [self color: Color black]. self changed. ! ! !IndexedEyeElement commentStamp: ''! I am an eye element for indexable fields. (at:)! !IndexedEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 15:53'! accessorCode ^ '(self at: ', self index asString, ')'! ! !IndexedEyeElement methodsFor: 'action' stamp: 'ClementBera 4/30/2013 15:53'! save: aValue self host at: self index put: aValue! ! !IndexedEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 15:54'! value ^ self host at: self index! ! !InexactFloatPrintPolicy commentStamp: ''! I am InexactFloatPrintPolicy. Through FloatPrintPolicy and double dispatch I force Float>>#printOn:base: to dynamically use the faster but potentially less accurate way to print Floats using Float>>#absPrintOn:base:! !InexactFloatPrintPolicy methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 2/8/2013 15:48'! absPrint: float on: stream base: base "Doube dispatch to the faster but potentially less accurate way to print" ^ float absPrintInexactlyOn: stream base: base ! ! !InfiniteForm commentStamp: ''! I represent a Form obtained by replicating a pattern form indefinitely in all directions.! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! isBitmapFill ^true! ! !InfiniteForm methodsFor: 'accessing' stamp: 'mjg 7/9/2001 14:12'! asColor ^ patternForm dominantColor! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! direction ^patternForm width @ 0! ! !InfiniteForm methodsFor: 'accessing' stamp: ''! offset "Refer to the comment in DisplayObject|offset." ^0 @ 0! ! !InfiniteForm methodsFor: 'accessing' stamp: ''! asForm ^ patternForm! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! origin ^0@0! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 9/2/1999 14:32'! isTranslucent "Return true since the bitmap may be translucent and we don't really want to check" ^true! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'bolot 9/15/1999 10:13'! bitPatternForDepth: suspectedDepth ^ patternForm! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:57'! normal ^0 @ patternForm height! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! origin: aPoint "Ignored" ! ! !InfiniteForm methodsFor: 'as yet unclassified' stamp: 'RAA 6/1/2000 10:50'! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" "prevents a walkback when control menu is built for morph with me as color"! ! !InfiniteForm methodsFor: 'displaying' stamp: 'StephaneDucasse 10/25/2013 16:16'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm "This is the real display message, but it doesn't get used until the new display protocol is installed." | targetBox patternBox bb | (patternForm isForm) ifFalse: [^ aDisplayMedium fill: clipRectangle rule: ruleInteger fillColor: patternForm]. "Do it iteratively" targetBox := aDisplayMedium boundingBox intersect: clipRectangle ifNone: [ ^ self ]. patternBox := patternForm boundingBox. bb := BitBlt destForm: aDisplayMedium sourceForm: patternForm fillColor: aForm combinationRule: ruleInteger destOrigin: 0@0 sourceOrigin: 0@0 extent: patternBox extent clipRect: clipRectangle. bb colorMap: (patternForm colormapIfNeededFor: aDisplayMedium). (targetBox left truncateTo: patternBox width) to: targetBox right - 1 by: patternBox width do: [:x | (targetBox top truncateTo: patternBox height) to: targetBox bottom - 1 by: patternBox height do: [:y | bb destOrigin: x@y; copyBits]]! ! !InfiniteForm methodsFor: 'display box access' stamp: ''! computeBoundingBox "Refer to the comment in DisplayObject|computeBoundingBox." ^0 @ 0 corner: SmallInteger maxVal @ SmallInteger maxVal! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! isSolidFill ^false! ! !InfiniteForm methodsFor: 'testing' stamp: 'JuanVuletich 10/12/2010 12:44'! mightBeTranslucent "Return true since the bitmap may be translucent and we don't really want to check" ^true! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! form "Bitmap fills respond to #form" ^patternForm! ! !InfiniteForm methodsFor: 'displaying' stamp: 'nk 4/17/2004 19:48'! displayOnPort: aPort offsetBy: offset | targetBox patternBox savedMap top left | "this version tries to get the form aligned where the user wants it and not just aligned with the cliprect" (patternForm isForm) ifFalse: [ "patternForm is a Pattern or Color; just use it as a mask for BitBlt" ^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over]. "do it iteratively" targetBox := aPort clipRect. patternBox := patternForm boundingBox. savedMap := aPort colorMap. aPort sourceForm: patternForm; fillColor: nil; combinationRule: Form paint; sourceRect: (0@0 extent: patternBox extent); colorMap: (patternForm colormapIfNeededFor: aPort destForm). top := (targetBox top truncateTo: patternBox height) + offset y. left := (targetBox left truncateTo: patternBox width) + offset x. left to: (targetBox right - 1) by: patternBox width do: [:x | top to: (targetBox bottom - 1) by: patternBox height do: [:y | aPort destOrigin: x@y; copyBits]]. aPort colorMap: savedMap. ! ! !InfiniteForm methodsFor: 'private' stamp: ''! form: aForm patternForm := aForm! ! !InfiniteForm methodsFor: 'displaying' stamp: 'sw 2/16/98 03:42'! colorForInsets ^ Color transparent! ! !InfiniteForm methodsFor: 'accessing' stamp: 'di 9/2/97 20:21'! dominantColor ^ patternForm dominantColor! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:59'! isOrientedFill ^true! ! !InfiniteForm methodsFor: 'displaying' stamp: 'ar 8/16/2001 12:47'! raisedColor ^ Color transparent! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! isGradientFill ^false! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:55'! isTiled "Return true if the receiver should be drawn as a tiled pattern" ^true! ! !InfiniteForm methodsFor: 'displaying' stamp: 'nk 4/17/2004 19:48'! displayOnPort: aPort at: offset | targetBox patternBox savedMap top left | self flag: #bob. "this *may* not get called at the moment. I have been trying to figure out the right way for this to work and am using #displayOnPort:offsetBy: as my current offering - Bob" (patternForm isForm) ifFalse: [ "patternForm is a Pattern or Color; just use it as a mask for BitBlt" ^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over]. "do it iteratively" targetBox := aPort clipRect. patternBox := patternForm boundingBox. savedMap := aPort colorMap. aPort sourceForm: patternForm; fillColor: nil; combinationRule: Form paint; sourceRect: (0@0 extent: patternBox extent); colorMap: (patternForm colormapIfNeededFor: aPort destForm). top := (targetBox top truncateTo: patternBox height) "- (offset y \\ patternBox height)". left := (targetBox left truncateTo: patternBox width) "- (offset x \\ patternBox width)". left to: (targetBox right - 1) by: patternBox width do: [:x | top to: (targetBox bottom - 1) by: patternBox height do: [:y | aPort destOrigin: x@y; copyBits]]. aPort colorMap: savedMap. ! ! !InfiniteForm methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/21/2008 16:37'! fillRectangle: aRectangle on: aCanvas "Fill the given rectangle on the given canvas with the receiver." aCanvas fillRectangle: aRectangle basicFillStyle: self! ! !InfiniteForm class methodsFor: 'instance creation' stamp: ''! with: aForm "Answer an instance of me whose pattern form is the argument, aForm." ^self new form: aForm! ! !InflateStream commentStamp: 'MarcusDenker 2/14/2010 22:29'! This class implements the Inflate decompression algorithm as defined by RFC1951 and used in PKZip, GZip and ZLib (and many, many more). It is a variant of the LZ77 compression algorithm described in [LZ77] Ziv J., Lempel A., "A Universal Algorithm for Sequential Data Compression", IEEE Transactions on Information Theory", Vol. 23, No. 3, pp. 337-343. [RFC1951] Deutsch. P, "DEFLATE Compressed Data Format Specification version 1.3" For more information see the above mentioned RFC 1951 which can for instance be found at http://www.leo.org/pub/comp/doc/standards/rfc/index.html Huffman Tree Implementation Notes: =========================================== The huffman tree used for decoding literal, distance and length codes in the inflate algorithm has been encoded in a single Array. The tree is made up of subsequent tables storing all entries at the current bit depth. Each entry in the table (e.g., a 32bit Integer value) is either a leaf or a non-leaf node. Leaf nodes store the immediate value in its low 16 bits whereas non-leaf nodes store the offset of the subtable in its low 16bits. The high 8 bits of non-leaf nodes contain the number of additional bits needed for the sub table (the high 8 bits of leaf-nodes are always zero). The first entry in each table is always a non-leaf node indicating how many bits we need to fetch initially. We can thus travel down the tree as follows (written in sort-of-pseudocode the actual implementation can be seen in InflateStream>>decodeValueFrom:): table := initialTable. bitsNeeded := high 8 bits of (table at: 1). "Determine initial bits" table := initialTable + (low 16 bits of (table at: 1)). "Determine start of first real table" [bits := fetch next bitsNeeded bits. "Grab the bits" value := table at: bits. "Lookup the value" value has high 8 bit set] whileTrue:[ "Check if it's leaf" table := initialTable + (low 16 bits of value). "No - compute new sub table start" bitsNeeded := high 8 bit of value]. "Compute additional number of bits needed" ^value ! !InflateStream methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 12/16/2011 10:26'! readInto: buffer startingAt: startIndex count: n "Read n objects into the given collection. Return number of elements that have been read." | c numRead count | n = 0 ifTrue: [ ^n ]. numRead := 0. ["Force decompression if necessary" (c := self next) == nil ifTrue: [^numRead]. "Store the first value which provoked decompression" buffer at: startIndex + numRead put: c. numRead := numRead + 1. "After collection has been filled copy as many objects as possible" count := (readLimit - position) min: (n - numRead). buffer replaceFrom: startIndex + numRead to: startIndex + numRead + count - 1 with: collection startingAt: position+1. position := position + count. numRead := numRead + count. numRead = n] whileFalse. ^n! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'! proceedDynamicBlock self decompressBlock: litTable with: distTable! ! !InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:04'! crcError: aString ^CRCError signal: aString! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:52'! sourcePosition ^sourcePos! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'! close sourceStream ifNotNil:[sourceStream close].! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:51'! distanceMap "This is used by the fast decompressor" ^nil! ! !InflateStream methodsFor: 'private' stamp: 'ar 2/29/2004 04:18'! pastEndRead "A client has attempted to read beyond the read limit. Check in what state we currently are and perform the appropriate action" | blockType bp oldLimit | state = StateNoMoreData ifTrue:[^nil]. "Get out early if possible" "Check if we can move decoded data to front" self moveContentsToFront. "Check if we can fetch more source data" self moveSourceToFront. state = StateNewBlock ifTrue:[state := self getNextBlock]. blockType := state bitShift: -1. bp := self bitPosition. oldLimit := readLimit. self perform: (BlockTypes at: blockType+1). "Note: if bit position hasn't advanced then nothing has been decoded." bp = self bitPosition ifTrue:[^self primitiveFailed]. "Update crc for the decoded contents" readLimit > oldLimit ifTrue:[crc := self updateCrc: crc from: oldLimit+1 to: readLimit in: collection]. state = StateNoMoreData ifTrue:[self verifyCrc]. ^self next! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/22/1999 01:29'! next "Answer the next decompressed object in the Stream represented by the receiver." position >= readLimit ifTrue: [^self pastEndRead] ifFalse: [^collection at: (position := position + 1)]! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:54'! sourceLimit ^sourceLimit! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:13'! processFixedBlock litTable := self huffmanTableFrom: FixedLitCodes mappedBy: self literalLengthMap. distTable := self huffmanTableFrom: FixedDistCodes mappedBy: self distanceMap. state := state bitOr: BlockProceedBit. self proceedFixedBlock.! ! !InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:00'! nextBits: n | bits | [bitPos < n] whileTrue:[ bitBuf := bitBuf + (self nextByte bitShift: bitPos). bitPos := bitPos + 8]. bits := bitBuf bitAnd: (1 bitShift: n)-1. bitBuf := bitBuf bitShift: 0 - n. bitPos := bitPos - n. ^bits! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:17'! moveContentsToFront "Move the decoded contents of the receiver to the front so that we have enough space for decoding more data." | delta | readLimit > 32768 ifTrue:[ delta := readLimit - 32767. collection replaceFrom: 1 to: collection size - delta + 1 with: collection startingAt: delta. position := position - delta + 1. readLimit := readLimit - delta + 1].! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'! proceedFixedBlock self decompressBlock: litTable with: distTable! ! !InflateStream methodsFor: 'huffman trees' stamp: 'jannik.laval 5/1/2010 17:03'! createHuffmanTables: values counts: counts from: minBits to: maxBits "Create the actual tables" | table tableStart tableSize tableEnd valueIndex tableStack numValues deltaBits maxEntries lastTable lastTableStart tableIndex lastTableIndex | table := WordArray new: ((4 bitShift: minBits) max: 16). "Create the first entry - this is a dummy. It gives us information about how many bits to fetch initially." table at: 1 put: (minBits bitShift: 24) + 2. "First actual table starts at index 2" "Create the first table from scratch." tableStart := 2. "See above" tableSize := 1 bitShift: minBits. tableEnd := tableStart + tableSize. "Store the terminal symbols" valueIndex := (counts at: minBits+1). tableIndex := 0. 1 to: valueIndex do:[:i| table at: tableStart + tableIndex put: (values at: i). tableIndex := self increment: tableIndex bits: minBits]. "Fill up remaining entries with invalid entries" tableStack := OrderedCollection new: 10. "Should be more than enough" tableStack addLast: (Array with: minBits "Number of bits (e.g., depth) for this table" with: tableStart "Start of table" with: tableIndex "Next index in table" with: minBits "Number of delta bits encoded in table" with: tableSize - valueIndex "Entries remaining in table"). "Go to next value index" valueIndex := valueIndex + 1. "Walk over remaining bit lengths and create new subtables" minBits+1 to: maxBits do:[:bits| numValues := counts at: bits+1. [numValues > 0] whileTrue:["Create a new subtable" lastTable := tableStack last. lastTableStart := lastTable at: 2. lastTableIndex := lastTable at: 3. deltaBits := bits - (lastTable at: 1). "Make up a table of deltaBits size" tableSize := 1 bitShift: deltaBits. tableStart := tableEnd. tableEnd := tableEnd + tableSize. [tableEnd > table size ] whileTrue:[table := self growHuffmanTable: table]. "Connect to last table" [(table at: lastTableStart + lastTableIndex) = 0] assert."Entry must be unused" table at: lastTableStart + lastTableIndex put: (deltaBits bitShift: 24) + tableStart. lastTable at: 3 put: (self increment: lastTableIndex bits: (lastTable at: 4)). lastTable at: 5 put: (lastTable at: 5) - 1. [(lastTable at: 5) >= 0] assert. "Don't exceed tableSize" "Store terminal values" maxEntries := numValues min: tableSize. tableIndex := 0. 1 to: maxEntries do:[:i| table at: tableStart + tableIndex put: (values at: valueIndex). valueIndex := valueIndex + 1. numValues := numValues - 1. tableIndex := self increment: tableIndex bits: deltaBits]. "Check if we have filled up the current table completely" maxEntries = tableSize ifTrue:[ "Table has been filled. Back up to the last table with space left." [tableStack isEmpty not and:[(tableStack last at: 5) = 0]] whileTrue:[tableStack removeLast]. ] ifFalse:[ "Table not yet filled. Put it back on the stack." tableStack addLast: (Array with: bits "Nr. of bits in this table" with: tableStart "Start of table" with: tableIndex "Index in table" with: deltaBits "delta bits of table" with: tableSize - maxEntries "Unused entries in table"). ]. ]. ]. ^table copyFrom: 1 to: tableEnd-1! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/27/1999 13:49'! processStoredBlock | chkSum length | "Skip to byte boundary" self nextBits: (bitPos bitAnd: 7). length := self nextBits: 16. chkSum := self nextBits: 16. (chkSum bitXor: 16rFFFF) = length ifFalse:[^self error:'Bad block length']. litTable := nil. distTable := length. state := state bitOr: BlockProceedBit. ^self proceedStoredBlock! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'! increment: value bits: nBits "Increment a value of nBits length. The fast decompressor will do this differently" ^value+1! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:50'! literalLengthMap "This is used by the fast decompressor" ^nil! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 02:24'! decodeValueFrom: table "Decode the next value in the receiver using the given huffman table." | bits bitsNeeded tableIndex value | bitsNeeded := (table at: 1) bitShift: -24. "Initial bits needed" tableIndex := 2. "First real table" [bits := self nextSingleBits: bitsNeeded. "Get bits" value := table at: (tableIndex + bits). "Lookup entry in table" (value bitAnd: 16r3F000000) = 0] "Check if it is a non-leaf node" whileFalse:["Fetch sub table" tableIndex := value bitAnd: 16rFFFF. "Table offset in low 16 bit" bitsNeeded := (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit" bitsNeeded > MaxBits ifTrue:[^self error:'Invalid huffman table entry']]. ^value! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/27/1999 13:49'! proceedStoredBlock "Proceed decompressing a stored (e.g., uncompressed) block" | length decoded | "Literal table must be nil for a stored block" litTable == nil ifFalse:[^self error:'Bad state']. length := distTable. [length > 0 and:[readLimit < collection size and:[sourcePos < sourceLimit]]] whileTrue:[ collection at: (readLimit := readLimit + 1) put: (source at: (sourcePos := sourcePos + 1)). length := length - 1]. length = 0 ifTrue:[state := state bitAnd: StateNoMoreData]. decoded := length - distTable. distTable := length. ^decoded! ! !InflateStream methodsFor: 'initialize' stamp: 'ls 1/2/2001 11:44'! on: aCollectionOrStream aCollectionOrStream isStream ifTrue:[ aCollectionOrStream binary. sourceStream := aCollectionOrStream. self getFirstBuffer] ifFalse:[source := aCollectionOrStream]. ^self on: source from: 1 to: source size.! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:15'! getFirstBuffer "Get the first source buffer after initialization has been done" sourceStream == nil ifTrue:[^self]. source := sourceStream next: 1 << 16. "This is more than enough..." sourceLimit := source size.! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/3/1998 17:32'! getNextBlock ^self nextBits: 3! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:25'! decodeDynamicTable: nItems from: aHuffmanTable "Decode the code length of the literal/length and distance table in a block compressed with dynamic huffman trees" | values index value repCount theValue | values := Array new: nItems. index := 1. theValue := 0. [index <= nItems] whileTrue:[ value := self decodeValueFrom: aHuffmanTable. value < 16 ifTrue:[ "Immediate values" theValue := value. values at: index put: value. index := index+1. ] ifFalse:[ "Repeated values" value = 16 ifTrue:[ "Repeat last value" repCount := (self nextBits: 2) + 3. ] ifFalse:[ "Repeat zero value" theValue := 0. value = 17 ifTrue:[repCount := (self nextBits: 3) + 3] ifFalse:[value = 18 ifTrue:[repCount := (self nextBits: 7) + 11] ifFalse:[^self error:'Invalid bits tree value']]]. 0 to: repCount-1 do:[:i| values at: index+i put: theValue]. index := index + repCount]. ]. ^values! ! !InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:49'! updateCrc: oldCrc from: start to: stop in: aCollection "Answer an updated CRC for the range of bytes in aCollection. Subclasses can implement the appropriate means for the check sum they wish to use." ^oldCrc! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/3/1998 16:19'! size "This is a compressed stream - we don't know the size beforehand" ^self shouldNotImplement! ! !InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:01'! nextSingleBits: n | out | out := 0. 1 to: n do:[:i| out := (out bitShift: 1) + (self nextBits: 1)]. ^out! ! !InflateStream methodsFor: 'testing' stamp: 'marcus.denker 9/14/2008 18:57'! atEnd "Note: It is possible that we have a few bits left, representing just the EOB marker. To check for this we must force decompression of the next block if at end of data." super atEnd ifFalse:[^false]. "Primitive test" (position >= readLimit and:[state = StateNoMoreData]) ifTrue:[^true]. "Force decompression, by calling #next. Since #moveContentsToFront will never move data to the beginning of the buffer it is safe to skip back the read position afterwards" self next ifNil: [^true]. position := position - 1. ^false! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/21/1999 22:59'! computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits "Assign numerical values to all codes. Note: The values are stored according to the bit length" | offsets values baseOffset codeLength | offsets := Array new: maxBits. offsets atAllPut: 0. baseOffset := 1. minBits to: maxBits do:[:bits| offsets at: bits put: baseOffset. baseOffset := baseOffset + (counts at: bits+1)]. values := WordArray new: aCollection size. 1 to: aCollection size do:[:i| codeLength := aCollection at: i. codeLength > 0 ifTrue:[ baseOffset := offsets at: codeLength. values at: baseOffset put: i-1. offsets at: codeLength put: baseOffset + 1]]. ^values! ! !InflateStream methodsFor: 'bit access' stamp: 'ar 12/27/1999 13:47'! bitPosition "Return the current bit position of the source" sourceStream == nil ifTrue:[^sourcePos * 8 + bitPos] ifFalse:[^sourceStream position + sourcePos * 8 + bitPos]! ! !InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:22'! verifyCrc "Verify the crc checksum in the input"! ! !InflateStream methodsFor: 'initialize' stamp: 'ar 12/3/1998 16:32'! reset "Position zero - nothing decoded yet" position := readLimit := 0. sourcePos := 0. bitBuf := bitPos := 0. state := 0.! ! !InflateStream methodsFor: 'accessing' stamp: 'nk 3/7/2004 18:45'! next: anInteger "Answer the next anInteger elements of my collection. overriden for simplicity" | newArray | "try to do it the fast way" position + anInteger < readLimit ifTrue: [ newArray := collection copyFrom: position + 1 to: position + anInteger. position := position + anInteger. ^newArray ]. "oh, well..." newArray := collection species new: anInteger. 1 to: anInteger do: [:index | newArray at: index put: (self next ifNil: [ ^newArray copyFrom: 1 to: index - 1]) ]. ^newArray! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/3/1998 13:16'! growHuffmanTable: table | newTable | newTable := table species new: table size * 2. newTable replaceFrom: 1 to: table size with: table startingAt: 1. ^newTable! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:27'! huffmanTableFrom: aCollection mappedBy: valueMap "Create a new huffman table from the given code lengths. Map the actual values by valueMap if it is given. See the class comment for a documentation of the huffman tables used in this decompressor." | counts values table minBits maxBits | minBits := MaxBits + 1. maxBits := 0. "Count the occurences of each code length and compute minBits and maxBits" counts := Array new: MaxBits+1. counts atAllPut: 0. aCollection do:[:length| length > 0 ifTrue:[ length < minBits ifTrue:[minBits := length]. length > maxBits ifTrue:[maxBits := length]. counts at: length+1 put: (counts at: length+1)+1]]. maxBits = 0 ifTrue:[^nil]. "Empty huffman table" "Assign numerical values to all codes." values := self computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits. "Map the values if requested" self mapValues: values by: valueMap. "Create the actual tables" table := self createHuffmanTables: values counts: counts from: minBits to: maxBits. ^table! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:27'! moveSourceToFront "Move the encoded contents of the receiver to the front so that we have enough space for decoding more data." (sourceStream == nil or:[sourceStream atEnd]) ifTrue:[^self]. sourcePos > 10000 ifTrue:[ source replaceFrom: 1 to: source size - sourcePos with: source startingAt: sourcePos + 1. source := sourceStream next: sourcePos into: source startingAt: source size - sourcePos + 1. sourcePos := 0. sourceLimit := source size].! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 3/15/1999 15:38'! decompressBlock: llTable with: dTable "Process the compressed data in the block. llTable is the huffman table for literal/length codes and dTable is the huffman table for distance codes." | value extra length distance oldPos oldBits oldBitPos | [readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[ "Back up stuff if we're running out of space" oldBits := bitBuf. oldBitPos := bitPos. oldPos := sourcePos. value := self decodeValueFrom: llTable. value < 256 ifTrue:[ "A literal" collection byteAt: (readLimit := readLimit + 1) put: value. ] ifFalse:["length/distance or end of block" value = 256 ifTrue:["End of block" state := state bitAnd: StateNoMoreData. ^self]. "Compute the actual length value (including possible extra bits)" extra := #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0) at: value - 256. length := #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258) at: value - 256. extra > 0 ifTrue:[length := length + (self nextBits: extra)]. "Compute the distance value" value := self decodeValueFrom: dTable. extra := #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13) at: value+1. distance := #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 1025 1537 2049 3073 4097 6145 8193 12289 16385 24577) at: value+1. extra > 0 ifTrue:[distance := distance + (self nextBits: extra)]. (readLimit + length >= collection size) ifTrue:[ bitBuf := oldBits. bitPos := oldBitPos. sourcePos := oldPos. ^self]. collection replaceFrom: readLimit+1 to: readLimit + length + 1 with: collection startingAt: readLimit - distance + 1. readLimit := readLimit + length. ]. ].! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ClementBera 7/26/2013 16:47'! mapValues: values by: valueMap | oldValue | valueMap ifNil: [^values]. 1 to: values size do:[:i| oldValue := values at: i. "Note: there may be nil values if not all values are used" oldValue ifNil: [^values] ifNotNil: [values at: i put: (valueMap at: oldValue+1)]]. ! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 01:46'! processDynamicBlock | nLit nDist nLen codeLength lengthTable bits | nLit := (self nextBits: 5) + 257. nDist := (self nextBits: 5) + 1. nLen := (self nextBits: 4) + 4. codeLength := Array new: 19. codeLength atAllPut: 0. 1 to: nLen do:[:i| bits := #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) at: i. codeLength at: bits+1 put: (self nextBits: 3). ]. lengthTable := self huffmanTableFrom: codeLength mappedBy: nil. "RFC 1951: In other words, all code lengths form a single sequence..." codeLength := self decodeDynamicTable: nLit+nDist from: lengthTable. litTable := self huffmanTableFrom: (codeLength copyFrom: 1 to: nLit) mappedBy: self literalLengthMap. distTable := self huffmanTableFrom: (codeLength copyFrom: nLit+1 to: codeLength size) mappedBy: self distanceMap. state := state bitOr: BlockProceedBit. self proceedDynamicBlock.! ! !InflateStream methodsFor: 'initialize' stamp: 'ar 12/23/1999 15:35'! on: aCollection from: firstIndex to: lastIndex bitBuf := bitPos := 0. "The decompression buffer has a size of at 64k, since we may have distances up to 32k back and repetitions of at most 32k length forward" collection := aCollection species new: 1 << 16. readLimit := 0. "Not yet initialized" position := 0. source := aCollection. sourceLimit := lastIndex. sourcePos := firstIndex-1. state := StateNewBlock.! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/4/1998 02:03'! decompressAll "Profile the decompression speed" [self atEnd] whileFalse:[ position := readLimit. self next "Provokes decompression" ].! ! !InflateStream methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:00'! upTo: anObject "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of anObject in the receiver. If anObject is not in the collection, answer the entire rest of the receiver." | newStream element | newStream := (collection species new: 100) writeStream. [self atEnd or: [(element := self next) = anObject]] whileFalse: [newStream nextPut: element]. ^newStream contents! ! !InflateStream methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:00'! upToEnd "Answer a subcollection from the current access position through the last element of the receiver." | newStream buffer | buffer := collection species new: 1000. newStream := (collection species new: 100) writeStream. [self atEnd] whileFalse: [newStream nextPutAll: (self nextInto: buffer)]. ^ newStream contents! ! !InflateStream methodsFor: 'bit access' stamp: 'ar 12/5/1998 14:54'! nextByte ^source byteAt: (sourcePos := sourcePos + 1)! ! !InflateStream methodsFor: 'accessing' stamp: 'tk 2/4/2000 10:26'! contents ^ self upToEnd! ! !InflateStream methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 12/16/2011 10:25'! next: n into: buffer startingAt: startIndex "Read n objects into the given collection. Return aCollection or a partial copy if less than n elements have been read." | c numRead count | n = 0 ifTrue: [ ^buffer ]. numRead := 0. ["Force decompression if necessary" (c := self next) == nil ifTrue:[^buffer copyFrom: 1 to: startIndex+numRead-1]. "Store the first value which provoked decompression" buffer at: startIndex + numRead put: c. numRead := numRead + 1. "After collection has been filled copy as many objects as possible" count := (readLimit - position) min: (n - numRead). buffer replaceFrom: startIndex + numRead to: startIndex + numRead + count - 1 with: collection startingAt: position+1. position := position + count. numRead := numRead + count. numRead = n] whileFalse. ^buffer! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'! sourceStream ^sourceStream! ! !InflateStream class methodsFor: 'initialization' stamp: 'stephane.ducasse 6/14/2009 22:47'! initialize "InflateStream initialize" MaxBits := 16. StateNewBlock := 0. StateNoMoreData := 1. BlockProceedBit := 8. BlockTypes := #( processStoredBlock "New block in stored format" processFixedBlock "New block with fixed huffman tables" processDynamicBlock "New block with dynamic huffman tables" errorBadBlock "Bad block format" proceedStoredBlock "Continue block in stored format" proceedFixedBlock "Continue block in fixed format" proceedDynamicBlock "Continue block in dynamic format" errorBadBlock "Bad block format"). "Initialize fixed block values" FixedLitCodes := ((1 to: 144) collect:[:i| 8]), ((145 to: 256) collect:[:i| 9]), ((257 to: 280) collect:[:i| 7]), ((281 to: 288) collect:[:i| 8]). FixedDistCodes := ((1 to: 32) collect:[:i| 5]).! ! !InlineTextDiffBuilder methodsFor: 'as yet unclassified' stamp: 'gvc 9/2/2008 16:10'! split: aString "Answer the split 'lines' by splitting on whitespace." |str lines sep| lines := OrderedCollection new. sep := Character separators, '^()[]{}''"`;.'. str := aString readStream. [str atEnd] whileFalse: [ lines add: (str upToAny: sep). str atEnd ifFalse: [ str skip: -1. lines add: str next asString]]. ^lines! ! !InputEventFetcher commentStamp: 'michael.rueger 4/22/2009 11:59'! EventFetcher is responsible for fetching the raw VM events and forward them to the registered event handlers. Event fetching is done in a high priority process, so even with other processes (e.g. the Morphic UI process) being busy events will still be fetched. Instance Variables inputSemaphore: eventHandlers fetcherProcess inputSemaphore - a semaphore registered with the VM to signal availability of an event. Currently not supported on all platforms. eventHandlers - registered event handlers. Event buffers are cloned before sent to each handler. fetcherProcess - a process that fetches the events from the VM. Either polling (InputEventPollingFetcher) or waiting on the inputSemaphore. Event format: The current event format is very simple. Each event is recorded into an 8 element array. All events must provide some SmallInteger ID (the first field in the event buffer) and a time stamp (the second field in the event buffer), so that the difference between the time stamp of an event and the current time can be reported. Currently, the following events are defined: Null event ============= The Null event is returned when the ST side asks for more events but no more events are available. Structure: [1] - event type 0 [2-8] - unused Mouse event structure ========================== Mouse events are generated when mouse input is detected. Structure: [1] - event type 1 [2] - time stamp [3] - mouse x position [4] - mouse y position [5] - button state; bitfield with the following entries: 1 - yellow (e.g., right) button 2 - blue (e.g., middle) button 4 - red (e.g., left) button [all other bits are currently undefined] [6] - modifier keys; bitfield with the following entries: 1 - shift key 2 - ctrl key 4 - (Mac specific) option key 8 - Cmd/Alt key [all other bits are currently undefined] [7] - reserved. [8] - reserved. Keyboard events ==================== Keyboard events are generated when keyboard input is detected. [1] - event type 2 [2] - time stamp [3] - character code For now the character code is in Mac Roman encoding. [4] - press state; integer with the following meaning 0 - character 1 - key press (down) 2 - key release (up) [5] - modifier keys (same as in mouse events) [6] - reserved. [7] - reserved. [8] - reserved. ! !InputEventFetcher methodsFor: 'initialize-release' stamp: 'michael.rueger 4/22/2009 11:33'! terminateEventLoop "Terminate the event loop process. Terminate the old process if any." "InputEventFetcher default terminateEventLoop" fetcherProcess ifNotNil: [fetcherProcess terminate]! ! !InputEventFetcher methodsFor: 'initialize-release' stamp: 'michael.rueger 4/22/2009 11:34'! shutDown self terminateEventLoop. inputSemaphore ifNotNil: [Smalltalk unregisterExternalObject: inputSemaphore]! ! !InputEventFetcher methodsFor: 'private' stamp: 'mir 8/14/2008 16:00'! eventHandlers ^eventHandlers ifNil: [eventHandlers := OrderedCollection new]! ! !InputEventFetcher methodsFor: 'handlers' stamp: 'mir 8/13/2008 16:29'! unregisterHandler: handler self eventHandlers remove: handler ifAbsent: []! ! !InputEventFetcher methodsFor: 'private events' stamp: 'mir 8/14/2008 15:43'! primInterruptSemaphore: aSemaphore "Primitive. Install the argument as the semaphore to be signalled whenever the user presses the interrupt key. The semaphore will be signaled once each time the interrupt key is pressed." ^self primitiveFailed "Note: This primitive was marked obsolete but is still used and actually quite useful. It could bre replace with a check in the event loop though, without a need for the now obsolete event tickler as event fetching isn't bound to the Morphic loop."! ! !InputEventFetcher methodsFor: 'events' stamp: 'mir 11/19/2008 19:40'! signalEvent: eventBuffer "Signal the event buffer to all registered event handlers. Handlers need make sure to copy the buffer or extract the data otherwise, as the buffer will be reused." self eventHandlers do: [:handler | handler handleEvent: eventBuffer]! ! !InputEventFetcher methodsFor: 'initialize-release' stamp: 'CamilloBruni 10/14/2013 22:25'! startUp inputSemaphore := Semaphore new. self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). inputSemaphore consumeAllSignals. self installEventLoop! ! !InputEventFetcher methodsFor: 'private events' stamp: 'mir 8/14/2008 15:57'! primSetInputSemaphore: semaIndex "Set the input semaphore the VM should use for asynchronously signaling the availability of events. Primitive. Optional." ^nil! ! !InputEventFetcher methodsFor: 'accessing' stamp: 'StephaneDucasse 5/18/2012 18:01'! fetcherProcess ^ fetcherProcess ! ! !InputEventFetcher methodsFor: 'initialize-release' stamp: 'CamilloBruni 8/21/2013 19:15'! installEventLoop "Initialize the event loop process. Terminate the old process if any." "InputEventFetcher default installEventLoop" self terminateEventLoop.. fetcherProcess := [self eventLoop] forkAt: Processor lowIOPriority. fetcherProcess name: 'Input Event Fetcher Process'! ! !InputEventFetcher methodsFor: 'private' stamp: 'StephaneDucasse 11/8/2010 18:39'! primGetNextEvent: array "Store the next OS event available into the provided array. Essential." array at: 1 put: EventTypeNone. ^nil ! ! !InputEventFetcher methodsFor: 'events' stamp: 'IgorStasenko 11/22/2008 20:20'! waitForInput inputSemaphore wait.! ! !InputEventFetcher methodsFor: 'events' stamp: 'IgorStasenko 11/22/2008 20:23'! eventLoop "Fetch pending raw events from the VM. This method is run at high priority." | eventBuffer | eventBuffer := Array new: 8. [true] whileTrue: [ | type window | self waitForInput. [self primGetNextEvent: eventBuffer. type := eventBuffer at: 1. type = EventTypeNone] whileFalse: [ "Patch up the window index in case we don't get one" window := eventBuffer at: 8. (window isNil or: [window isZero]) ifTrue: [eventBuffer at: 8 put: 1]. self signalEvent: eventBuffer]]! ! !InputEventFetcher methodsFor: 'handlers' stamp: 'mir 8/13/2008 16:29'! registerHandler: handler self eventHandlers add: handler! ! !InputEventFetcher class methodsFor: 'class initialization' stamp: 'michael.rueger 4/24/2009 13:23'! deinstall "InputEventFetcher deinstall" Default ifNotNil: [ Default shutDown. Smalltalk removeFromStartUpList: Default class. Smalltalk removeFromShutDownList: Default class. Default := nil]. Smalltalk removeFromStartUpList: self. Smalltalk removeFromShutDownList: self! ! !InputEventFetcher class methodsFor: 'accessing' stamp: 'MarcusDenker 2/24/2012 13:30'! default "InputEventFetcher default" ^Default ifNil: [Default := InputEventFetcher new]! ! !InputEventFetcher class methodsFor: 'system startup' stamp: 'mir 8/14/2008 15:21'! shutDown "InputEventFetcher shutDown" self default shutDown! ! !InputEventFetcher class methodsFor: 'class initialization' stamp: 'michael.rueger 4/24/2009 13:20'! install "InputEventFetcher install" Smalltalk addToStartUpList: self after: Cursor. Smalltalk addToShutDownList: self after: Form. Default := self new. Default startUp ! ! !InputEventFetcher class methodsFor: 'system startup' stamp: 'mir 8/13/2008 14:25'! startUp "InputEventFetcher startUp" self default startUp! ! !InputEventHandler commentStamp: 'michael.rueger 4/22/2009 11:56'! An InputEventHandler is the abstract superclass for all input event handlers. Subclasses need to implement handleEvent:. Instance Variables eventFetcher: eventFetcher - the event fetcher I'm registered with and receiving my events from. ! !InputEventHandler methodsFor: 'initialize-release' stamp: 'FernandoOlivero 11/25/2012 20:24'! unregister eventFetcher ifNotNil: [ eventFetcher unregisterHandler: self. eventFetcher := nil. ]! ! !InputEventHandler methodsFor: 'events' stamp: 'mir 8/13/2008 19:35'! handleEvent: eventBuffer self subclassResponsibility! ! !InputEventHandler methodsFor: 'events' stamp: 'JuanVuletich 11/1/2010 15:48'! flushEvents! ! !InputEventHandler methodsFor: 'initialize-release' stamp: 'mir 8/13/2008 16:27'! registerIn: anEventFetcher eventFetcher := anEventFetcher. eventFetcher registerHandler: self! ! !InputEventHandler methodsFor: 'events' stamp: 'ThierryGoubier 7/5/2013 16:17'! isKbdEvent: bufEvt ^ bufEvt first = EventTypeKeyboard and: [ bufEvt fourth = EventKeyChar ]! ! !InputEventSensor commentStamp: 'michael.rueger 4/22/2009 11:59'! An InputEventSensor is a replacement for the old Morphic EventSensor framework. It updates its state when events are received so that all state based users of Sensor (e.g., Sensor keyboard, Sensor leftShiftDown, Sensor mouseButtons) will work exactly as before. The usage of these funtions is discouraged. Instance variables: mouseButtons - mouse button state as replacement for primMouseButtons mousePosition - mouse position as replacement for primMousePt eventQueue - an optional event queue for event driven applications modifiers - modifier states Class variables: ButtonDecodeTable KeyDecodeTable ! !InputEventSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:02'! tabletExtent "Answer the full tablet extent in tablet coordinates." | params | params := self primTabletGetParameters: 1. params ifNil: [^ self error: 'no tablet available']. ^ (params at: 1)@(params at: 2) ! ! !InputEventSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:02'! noButtonPressed "Answer whether any mouse button is not being pressed." ^self anyButtonPressed not ! ! !InputEventSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! primTabletGetParameters: cursorIndex "Answer the pen tablet parameters. For parameters that differ from cursor to cursor, answer those associated with the cursor having the given index. Answer nil if there is no pen tablet. The parameters are: 1. tablet width, in tablet units 2. tablet height, in tablet units 3. number of tablet units per inch 4. number of cursors (pens, pucks, etc; some tablets have more than one) 5. this cursor index 6. and 7. x scale and x offset for scaling tablet coordintes (e.g., to fit the screen) 8. and 9. y scale and y offset for scaling tablet coordintes (e.g., to fit the screen) 10. number of pressure levels 11. presure threshold needed close pen tip switch 12. number of pen tilt angles" ^ nil ! ! !InputEventSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! primTabletRead: cursorIndex "Answer the pen tablet data for the cursor having the given index. Answer nil if there is no pen tablet. The data is: 1. index of the cursor to which this data applies 2. timestamp of the last state chance for this cursor 3., 4., and 5. x, y, and z coordinates of the cursor (z is typically 0) 6. and 7. xTilt and yTilt of the cursor; (signed) 8. type of cursor (0 = unknown, 1 = pen, 2 = puck, 3 = eraser) 9. cursor buttons 10. cursor pressure, downward 11. cursor pressure, tangential 12. flags" self primitiveFailed ! ! !InputEventSensor methodsFor: 'events' stamp: 'mir 11/19/2008 12:44'! flushAllButDandDEvents! ! !InputEventSensor methodsFor: 'private events' stamp: 'AdrianLienhard 10/19/2009 15:56'! nextKeyboardEvent "Allows for use of old Sensor protocol to get at the keyboard, as when running kbdTest or the InterpreterSimulator in Morphic" | evtBuf | evtBuf := eventQueue findFirst: [:buf | self isKbdEvent: buf]. self flushNonKbdEvents. ^evtBuf! ! !InputEventSensor methodsFor: 'initialize-release' stamp: 'mir 8/14/2008 15:18'! shutDown! ! !InputEventSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 23:03'! tabletTimestamp "Answer the time (in tablet clock ticks) at which the tablet's primary pen last changed state. This can be used in polling loops; if this timestamp hasn't changed, then the pen state hasn't changed either." | data | data := self primTabletRead: 1. "state of first/primary pen" ^ data at: 2 ! ! !InputEventSensor methodsFor: 'events' stamp: 'JuanVuletich 10/10/2010 22:56'! someEventInQueue ^eventQueue isEmpty not! ! !InputEventSensor methodsFor: 'mouse' stamp: 'mir 11/19/2008 21:15'! redButtonPressed "Answer true if only the red mouse button is being pressed. This is the first mouse button, usually the left one." ^(self mouseButtons bitAnd: 7) = 4 ! ! !InputEventSensor methodsFor: 'private events' stamp: 'michael.rueger 4/22/2009 12:59'! modifiers "modifier keys; bitfield with the following entries: 1 - shift key 2 - ctrl key 4 - (Mac specific) option key 8 - Cmd/Alt key" "Fetch the next event if any to update state. Makes sure that the old polling methods consume events" " self nextEvent." ^modifiers! ! !InputEventSensor methodsFor: 'keyboard' stamp: 'mir 8/13/2008 20:06'! flushKeyboard "Remove all characters from the keyboard buffer." [self keyboardPressed] whileTrue: [self keyboard]! ! !InputEventSensor methodsFor: 'initialization' stamp: 'StephaneDucasse 3/16/2012 20:27'! initialize "Initialize the receiver" super initialize. eventQueue := WaitfreeQueue new. mouseButtons := 0. mousePosition := 0 @ 0. modifiers := 0! ! !InputEventSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:12'! tabletPoint "Answer the current position of the first tablet pointing device (pen, puck, or eraser) in tablet coordinates." | data | data := self primTabletRead: 1. "state of first/primary pen" ^ (data at: 3) @ (data at: 4) ! ! !InputEventSensor methodsFor: 'private events' stamp: 'michael.rueger 4/9/2009 15:02'! characterForEvent: evtBuf | keycode | evtBuf ifNil: [^nil]. keycode := evtBuf sixth. ^keycode ifNotNil: [Unicode value: keycode]! ! !InputEventSensor methodsFor: 'modifier keys' stamp: 'mir 11/19/2008 21:09'! controlKeyPressed "Answer whether the control key on the keyboard is being held down." ^self modifiers anyMask: 16r02! ! !InputEventSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 22:14'! hasTablet "Answer true if there is a pen tablet available on this computer." ^ (self primTabletGetParameters: 1) notNil ! ! !InputEventSensor methodsFor: 'keyboard' stamp: 'mir 8/14/2008 14:02'! keyboard "Answer the next character from the keyboard." ^self characterForEvent: self nextKeyboardEvent! ! !InputEventSensor methodsFor: 'events' stamp: 'MarcusDenker 1/26/2010 09:40'! peekEvent "Look ahead at the next event." | nextEvent | nextEvent := eventQueue peek. ^((nextEvent notNil) and: [(nextEvent at: 1) ~= EventTypeMenu]) ifTrue: [self processEvent: nextEvent]! ! !InputEventSensor methodsFor: 'cursor' stamp: 'michael.rueger 5/25/2009 13:45'! cursorPoint "Answer a Point indicating the cursor location." "Fetch the next event if any to update state. Makes sure that the old polling methods consume events self nextEvent." ^ mousePosition! ! !InputEventSensor methodsFor: 'initialize-release' stamp: 'MichaelRueger 10/18/2009 12:56'! startUp self initialize! ! !InputEventSensor methodsFor: 'events' stamp: 'IgorStasenko 4/15/2011 11:57'! nextEvent "Return the next event from the receiver." | evt | evt := eventQueue nextOrNil. ^ evt ifNotNil: [ self processEvent: evt ] ! ! !InputEventSensor methodsFor: 'events' stamp: 'pmm 3/13/2010 11:31'! handleEvent: evt self queueEvent: evt shallowCopy! ! !InputEventSensor methodsFor: 'keyboard' stamp: 'mir 8/14/2008 14:06'! keyboardPressed "Answer true if keystrokes are available." ^self peekKeyboardEvent notNil! ! !InputEventSensor methodsFor: 'private events' stamp: 'GuillermoPolito 4/22/2012 16:59'! processEvent: evt "Process a single event. This method is run at high priority." | type | type := evt at: 1. "Treat menu events first" type = EventTypeMenu ifTrue: [ self processMenuEvent: evt. ^nil]. "Tackle mouse events first" type = EventTypeMouse ifTrue: [ "Transmogrify the button state according to the platform's button map definition" evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1). "Map the mouse buttons depending on modifiers" evt at: 5 put: (self mapButtons: (evt at: 5) modifiers: (evt at: 6)). "Update state for polling calls" mousePosition := (evt at: 3) @ (evt at: 4). modifiers := evt at: 6. mouseButtons := evt at: 5. ^evt]. "Finally keyboard" type = EventTypeKeyboard ifTrue: [ "Update state for polling calls" modifiers := evt at: 5. ^evt]. "Handle all events other than Keyborad or Mouse." ^evt. ! ! !InputEventSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:22'! waitButtonOrKeyboard "Wait for the user to press either any mouse button or any key. Answer the current cursor location or nil if a keypress occured." | delay | delay := Delay forMilliseconds: 50. [self anyButtonPressed] whileFalse: [delay wait. self keyboardPressed ifTrue: [^ nil]]. ^ self cursorPoint ! ! !InputEventSensor methodsFor: 'private events' stamp: 'mir 11/19/2008 19:42'! queueEvent: evt "Queue the given event in the event queue" eventQueue nextPut: evt! ! !InputEventSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:22'! waitButton "Wait for the user to press any mouse button and then answer with the current location of the cursor." | delay | delay := Delay forMilliseconds: 50. [self anyButtonPressed] whileFalse: [ delay wait ]. ^self cursorPoint ! ! !InputEventSensor methodsFor: 'private events' stamp: 'AdrianLienhard 6/7/2010 10:47'! processMenuEvent: evt | handler localCopyOfEvt | Smalltalk globals at: #HostSystemMenus ifPresent: [ :menus | localCopyOfEvt := evt shallowCopy. handler := (menus defaultMenuBarForWindowIndex: (localCopyOfEvt at: 8)) getHandlerForMenu: (localCopyOfEvt at: 3) item: (localCopyOfEvt at: 4). handler handler value: localCopyOfEvt ]! ! !InputEventSensor methodsFor: 'events' stamp: 'JuanVuletich 11/1/2010 15:47'! flushEvents eventQueue ifNotNil:[eventQueue flush]! ! !InputEventSensor methodsFor: 'private events' stamp: 'michael.rueger 5/25/2009 13:45'! mouseButtons "button state; bitfield with the following entries: 1 - yellow (e.g., right) button 2 - blue (e.g., middle) button 4 - red (e.g., left) button [all other bits are currently undefined]" "Fetch the next event if any to update state. Makes sure that the old polling methods consume events" self nextEvent. ^mouseButtons! ! !InputEventSensor methodsFor: 'joystick' stamp: ''! joystickXY: index | inputWord x y | inputWord := self primReadJoystick: index. x := (inputWord bitAnd: 16r7FF) - 16r400. y := ((inputWord bitShift: -11) bitAnd: 16r7FF) - 16r400. ^ x@y ! ! !InputEventSensor methodsFor: 'private events' stamp: 'mir 8/14/2008 13:37'! peekKeyboardEvent "Allows for use of old Sensor protocol to get at the keyboard, as when running kbdTest or the InterpreterSimulator in Morphic" ^eventQueue findFirst: [:buf | self isKbdEvent: buf]! ! !InputEventSensor methodsFor: 'mouse' stamp: 'mir 11/19/2008 21:15'! yellowButtonPressed "Answer whether only the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac." ^(self mouseButtons bitAnd: 7) = 2 ! ! !InputEventSensor methodsFor: 'modifier keys' stamp: 'michael.rueger 6/10/2009 13:36'! commandKeyPressed "Answer whether the command key on the keyboard is being held down." ^self modifiers anyMask: 16r08! ! !InputEventSensor methodsFor: 'private events' stamp: 'MarcusDenker 6/24/2013 11:18'! mapButtons: buttons modifiers: anInteger "Map the buttons to yellow or blue based on the given modifiers. If only the red button is pressed, then map Ctrl-RedButton -> BlueButton. Cmd-RedButton -> YellowButton. " (buttons = RedButtonBit) ifFalse:[^buttons]. (anInteger allMask: CtrlKeyBit) ifTrue:[^BlueButtonBit]. (anInteger allMask: CommandKeyBit) ifTrue:[^YellowButtonBit]. ^buttons! ! !InputEventSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'! primReadJoystick: index "Return the joystick input word for the joystick with the given index in the range [1..16]. Returns zero if the index does not correspond to a currently installed joystick." ^ 0 ! ! !InputEventSensor methodsFor: 'joystick' stamp: ''! joystickOn: index ^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) ~= 0 ! ! !InputEventSensor methodsFor: 'mouse' stamp: ''! waitClickButton "Wait for the user to click (press and then release) any mouse button and then answer with the current location of the cursor." self waitButton. ^self waitNoButton! ! !InputEventSensor methodsFor: 'tablet' stamp: 'jm 4/12/1999 13:05'! tabletPressure "Answer the current pressure of the first tablet pointing device (pen, puck, or eraser), a number between 0.0 (no pressure) and 1.0 (max pressure)" | params data | params := self primTabletGetParameters: 1. params ifNil: [^ self]. data := self primTabletRead: 1. "state of first/primary pen" ^ (data at: 10) asFloat / ((params at: 10) - 1) ! ! !InputEventSensor methodsFor: 'keyboard' stamp: 'mir 8/14/2008 14:03'! keyboardPeek "Answer the next character in the keyboard buffer without removing it, or nil if it is empty." ^ self characterForEvent: self peekKeyboardEvent! ! !InputEventSensor methodsFor: 'mouse' stamp: 'mir 11/19/2008 21:07'! blueButtonPressed "Answer whether only the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac." ^(self mouseButtons bitAnd: 7) = 1 ! ! !InputEventSensor methodsFor: 'mouse' stamp: 'mir 11/19/2008 22:28'! anyButtonPressed "Answer whether at least one mouse button is currently being pressed." ^self mouseButtons anyMask: 7! ! !InputEventSensor methodsFor: 'modifier keys' stamp: 'mir 11/19/2008 21:07'! anyModifierKeyPressed "ignore, however, the shift keys 'cause that's not REALLY a command key" ^self modifiers anyMask: 16r0E "cmd | opt | ctrl"! ! !InputEventSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:25'! waitNoButton "Wait for the user to release any mouse button and then answer the current location of the cursor." | delay | delay := Delay forMilliseconds: 50. [self anyButtonPressed] whileTrue: [ delay wait]. ^self cursorPoint ! ! !InputEventSensor methodsFor: 'joystick' stamp: ''! joystickButtons: index ^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71F ! ! !InputEventSensor methodsFor: 'private events' stamp: 'nice 4/20/2009 22:48'! flushNonKbdEvents eventQueue ifNil: [^ self]. eventQueue flushAllSuchThat: [:buf | (self isKbdEvent: buf) not]! ! !InputEventSensor methodsFor: 'modifier keys' stamp: 'mir 11/19/2008 21:16'! shiftPressed "Answer whether the shift key on the keyboard is being held down." ^self modifiers anyMask: 16r01 ! ! !InputEventSensor class methodsFor: 'class initialization' stamp: 'AlainPlantec 1/7/2010 22:16'! installMouseDecodeTable "Create a decode table that swaps the lowest-order 2 bits" ButtonDecodeTable := self swapMouseButtons ifTrue: [ByteArray withAll: ((0 to: 255) collect: [:ea | ((ea bitAnd: 1) << 1 bitOr: (ea bitAnd: 2) >> 1) bitOr: (ea bitAnd: 16rFC) ])] ifFalse: [ByteArray withAll: (0 to: 255)]! ! !InputEventSensor class methodsFor: 'system startup' stamp: 'nk 6/21/2004 10:36'! shutDown self default shutDown.! ! !InputEventSensor class methodsFor: 'class initialization' stamp: 'nk 7/11/2002 07:41'! defaultCrossPlatformKeys "Answer a list of key letters that are used for common editing operations on different platforms." ^{ $c . $x . $v . $a . $s . $f . $g . $z } ! ! !InputEventSensor class methodsFor: 'public' stamp: ''! default "Answer the default system InputEventSensor, Sensor." ^ Sensor! ! !InputEventSensor class methodsFor: 'system startup' stamp: 'GuillermoPolito 4/22/2012 17:00'! startUp self installMouseDecodeTable. self default startUp! ! !InputEventSensor class methodsFor: 'settings' stamp: 'MarcusDenker 7/26/2013 11:21'! swapMouseButtons ^ Smalltalk os isWindows not! ! !InputEventSensor class methodsFor: 'class initialization' stamp: 'MarcusDenker 2/24/2012 13:33'! installEventSensorFramework: fetcherClass "Installs the new sensor framework." | newSensor | "Do some extra cleanup" Smalltalk removeFromShutDownList: InputEventFetcher. Smalltalk removeFromStartUpList: InputEventFetcher. InputEventFetcher deinstall. newSensor := self new. fetcherClass install. newSensor registerIn: InputEventFetcher default. "Shut down old sensor" Sensor shutDown. Smalltalk removeFromShutDownList: Sensor class. Smalltalk removeFromStartUpList: Sensor class. "Note: We must use #become: here to replace all references to the old sensor with the new one, since Sensor is referenced from all the existing controllers." Sensor becomeForward: newSensor. "done" "Register the interrupt handler" UserInterruptHandler new registerIn: InputEventFetcher default. Smalltalk addToStartUpList: Sensor class after: fetcherClass. Smalltalk addToShutDownList: Sensor class after: Form. "Project spawnNewProcessAndTerminateOld: true"! ! !InputEventSensor class methodsFor: 'class initialization' stamp: 'michael.rueger 4/22/2009 11:48'! installEventSensorFramework "Installs the new sensor framework." "InputEventSensor installEventSensorFramework" self installEventSensorFramework: InputEventFetcher! ! !InputEventSensorSystemSettings commentStamp: 'TorstenBergmann 2/12/2014 23:28'! Settings for the InputEventSensor! !InputWidget commentStamp: 'SeanDeNigris 1/23/2014 11:40'! I am a generic widget far a user to enter a string Example (printMe): self example inspect.! !InputWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/26/2013 13:51'! ghostText: aString input ghostText: aString! ! !InputWidget methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! ok input accept. ^ okAction value value! ! !InputWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/26/2013 14:16'! triggerOkAction self window ifNotNil: [ :w | w triggerOkAction ]! ! !InputWidget methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 4/26/2013 14:15'! initializeWidgets self instantiateModels: #( input TextInputFieldModel label LabelModel ). input ghostText: 'input'; acceptBlock: [ self triggerOkAction ]; entryCompletion: nil; acceptOnCR: true. label text: 'label'! ! !InputWidget methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 4/26/2013 13:49'! initializeDialogWindow: aWindow aWindow okAction: [ self ok ]! ! !InputWidget methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize okAction := [ ] asReactiveVariable. value := '' asReactiveVariable. title := 'Title' asReactiveVariable. super initialize.! ! !InputWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! value ^ value value! ! !InputWidget methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! initializePresenter input whenTextIsAccepted: [:text | self ok == false ifFalse: [ value value: text ] ]. title whenChangedDo: [ self updateTitle ]! ! !InputWidget methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/26/2013 13:56'! label ^ label! ! !InputWidget methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! title ^ title value! ! !InputWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! title: aString title value: aString! ! !InputWidget methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 4/26/2013 13:54'! whenValueChanged: aBlock value whenChangedDo: aBlock! ! !InputWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/26/2013 13:51'! label: aString label text: aString.! ! !InputWidget methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/26/2013 13:56'! input ^ input! ! !InputWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/26/2013 13:57'! initialExtent ^ 250@125! ! !InputWidget class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 4/26/2013 13:56'! defaultSpec ^ SpecLayout composed newRow: #label bottom: 0.5; newRow: #input top: 0.5; yourself! ! !InputWidget class methodsFor: 'example' stamp: 'SeanDeNigris 1/23/2014 11:43'! example "self example inspect" | widget | widget := self new. widget title: 'Name'; label: 'What''s your name?'; ghostText: 'John Doe'. widget openDialogWithSpec modalRelativeTo: self currentWorld. ^ widget value! ! !InputWidget class methodsFor: 'example' stamp: 'SeanDeNigris 1/23/2014 11:37'! example2 "self example2" | widget buttonModel buttonWindow | buttonModel := ButtonModel new. buttonWindow := buttonModel openWithSpec. widget := InputWidget new. widget title: 'Label?'; label: 'Enter a button label'; ghostText: 'Ok'. widget openDialogWithSpec modalRelativeTo: buttonWindow. buttonModel label: widget value! ! !InsetBorder commentStamp: 'kfr 10/27/2003 09:32'! see BorderedMorph! !InsetBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'! style ^#inset! ! !InsetBorder methodsFor: 'accessing' stamp: 'gvc 1/31/2007 13:41'! topLeftColor "Changed from direct access to color since, if nil, self color is transparent." ^width = 1 ifTrue: [self color twiceDarker] ifFalse: [self color darker]! ! !InsetBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'! trackColorFrom: aMorph baseColor ifNil:[self color: aMorph insetColor].! ! !InsetBorder methodsFor: 'accessing' stamp: 'gvc 1/31/2007 13:41'! bottomRightColor "Changed from direct access to color since, if nil, self color is transparent." ^width = 1 ifTrue: [self color twiceLighter] ifFalse: [self color lighter]! ! !InsetBorder methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:23'! colorsAtCorners | c c14 c23 | c := self color. c14 := c lighter. c23 := c darker. ^Array with: c23 with: c14 with: c14 with: c23.! ! !InspectorNavigator commentStamp: ''! This a wrapper around inspectors for diving. It is used in the case where the inspector is dynamically replaced by another inspector. For example, EyeCollectionInspector would be replaced by EyeIntegerInspector.! !InspectorNavigator methodsFor: 'initialization' stamp: 'CamilloBruni 10/15/2013 17:21'! initializeShortcuts self bindKeyCombination: $[ command toAction: [ self inspectPrevious ]. self bindKeyCombination: $] command toAction: [ self inspectNext ]. self bindKeyCombination: $[ shift command toAction: [ self usePreviousInspectorType ]. self bindKeyCombination: $] shift command toAction: [ self useNextInspectorType ]. self bindKeyCombination: $0 command toAction: [ self useBasicInspector ]. self bindKeyCombination: $0 shift command toAction: [ self useDefaultInspector ]. "code duplication? yes, but still easier than capturing arguments ;)" self bindKeyCombination: $1 command toAction: [ self useInspectorAt: 1 ]. self bindKeyCombination: $2 command toAction: [ self useInspectorAt: 2 ]. self bindKeyCombination: $3 command toAction: [ self useInspectorAt: 3 ]. self bindKeyCombination: $4 command toAction: [ self useInspectorAt: 4 ]. self bindKeyCombination: $5 command toAction: [ self useInspectorAt: 5 ]. self bindKeyCombination: $6 command toAction: [ self useInspectorAt: 6 ]. self bindKeyCombination: $7 command toAction: [ self useInspectorAt: 7 ]. self bindKeyCombination: $8 command toAction: [ self useInspectorAt: 8 ]. self bindKeyCombination: $9 command toAction: [ self useInspectorAt: 9 ].! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 5/2/2013 21:15'! object ^ self inspector object! ! !InspectorNavigator methodsFor: 'history' stamp: 'CamilloBruni 9/20/2013 22:07'! pushHistory history add: self inspector. self toolbar update.! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! basicInspector: anEyeInspector inspector value ifNotNil: [ :inspect | inspect owner: nil ]. inspector value: anEyeInspector. anEyeInspector owner: self; ownerChanged.! ! !InspectorNavigator methodsFor: 'actions' stamp: 'CamilloBruni 9/20/2013 22:07'! inspectPrevious history hasPrevious ifFalse: [ ^ self ]. self inspectHistoryItem: history previous! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'StephaneDucasse 3/7/2014 11:34'! defaultWindowModelClass | stdout | FileStream stdout wantsLineEndConversion: true; converter. stdout := VTermOutputDriver stdout. stdout nextPutAll: self class name. stdout cr. ^ TickingWindowModel ! ! !InspectorNavigator methodsFor: 'actions' stamp: 'CamilloBruni 9/20/2013 21:54'! useBasicInspector self inspectorType: EyeBasicInspector! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 21:48'! previousInspectorType | index types | types := self inspectorTypes. index := types indexOf: self inspectorType ifAbsent: [ ^ types first ]. ^types atWrap: index - 1.! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 19:31'! inspectorType ^ self inspector class! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2013 22:22'! history ^ history! ! !InspectorNavigator methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. history := NavigationHistory new. inspector := nil asReactiveVariable. self initializeShortcuts. inspector whenChangedDo: [ :new :old | self updateInspectorFrom: old ]. self announcer on: WidgetBuilt send: #setRefreshedToTrue to: self. canBeRefreshed := false. self whenWindowChanged: [ :w | w whenClosedDo: [ self inspector close ] ].! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 5/2/2013 21:27'! selectedObject ^ self inspector selectedObject! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'ClementBera 5/2/2013 11:43'! title ^ self inspector title! ! !InspectorNavigator methodsFor: 'actions' stamp: 'CamilloBruni 11/25/2013 17:00'! inspect: anObject | oldInspectorType | oldInspectorType := self inspectorType. self inspector: (EyeInspector inspector: anObject); inspectorType: oldInspectorType. ! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2013 22:16'! toolbar: anObject toolbar := anObject ! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 5/2/2013 21:17'! selectedIndex: anInteger self inspector selectedIndex: anInteger! ! !InspectorNavigator methodsFor: 'initialization' stamp: 'StephaneDucasse 3/7/2014 11:07'! stepTime ^ 1500! ! !InspectorNavigator methodsFor: 'actions' stamp: 'MarcusDenker 9/28/2013 15:31'! useTreeInspector self inspectorType: EyeTreeInspector! ! !InspectorNavigator methodsFor: 'updating' stamp: 'ClementBera 7/3/2013 13:04'! takeKeyboardFocus ^ self inspector takeKeyboardFocus! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 5/2/2013 00:37'! canBeRefreshed ^ canBeRefreshed! ! !InspectorNavigator methodsFor: 'initialization' stamp: 'ClementBera 8/13/2013 11:11'! initialExtent ^ self inspector initialExtent ! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 5/2/2013 21:15'! selectedIndex ^ self inspector selectedIndex! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 20:12'! taskbarIcon ^ self inspector ifNil: [ super taskbarIcon ] ifNotNil: [ :anInspector | anInspector taskbarIcon ]! ! !InspectorNavigator methodsFor: 'actions' stamp: 'ClementBera 5/3/2013 14:59'! diveInto: anObject self inspect: anObject.! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 5/2/2013 00:37'! canBeRefreshed: anObject canBeRefreshed := anObject! ! !InspectorNavigator methodsFor: 'actions' stamp: 'CamilloBruni 9/20/2013 22:16'! inspectNext history hasNext ifFalse: [ ^ self ]. self inspectHistoryItem: history next! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2013 22:16'! toolbar ^ toolbar! ! !InspectorNavigator methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 11/8/2013 17:55'! diveIntoSelectedObject self inspector diveIntoSelectedObject! ! !InspectorNavigator methodsFor: 'history' stamp: 'CamilloBruni 9/20/2013 22:08'! inspectHistoryItem: historyItem "self inspect: historyItem key . self selectedIndex: historyItem value." self inspector: historyItem key! ! !InspectorNavigator methodsFor: 'actions' stamp: 'CamilloBruni 9/20/2013 22:03'! useInspectorAt: index "choose an inspector at the given index from the given inspectorTypes. If the index is out of bounds, simply crop it to the neares value" | types | types := self inspectorTypes. self inspectorType: (types at: (index min: types size max: 1))! ! !InspectorNavigator methodsFor: 'initialization' stamp: 'CamilloBruni 9/20/2013 20:26'! initializeWidgets toolbar := self instantiate: EyeInspectorToolBar.! ! !InspectorNavigator methodsFor: 'actions' stamp: 'CamilloBruni 9/20/2013 19:34'! usePreviousInspectorType self inspectorType: self previousInspectorType! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! inspector ^ inspector value! ! !InspectorNavigator methodsFor: 'actions' stamp: 'CamilloBruni 9/20/2013 21:54'! useDefaultInspector self inspectorType: self object class inspectorClass! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'BenComan 3/18/2014 02:13'! inspectorType: anInspectorClass "Use a new inspector type. Instantiate the given inspector class and replace the current view" | oldScriptAreaTextModel | oldScriptAreaTextModel := self inspector text. anInspectorClass = self inspector class ifTrue: [ ^ self ]. anInspectorClass isNil ifTrue: [ ^ self ]. (self inspectorTypes includes: anInspectorClass) ifFalse: [ ^ self ]. self basicInspector: (anInspectorClass new inspect: self object; yourself). self inspector text text: oldScriptAreaTextModel getText; setSelection: oldScriptAreaTextModel getSelection. history replaceCurrentWith: self inspector. self toolbar update.! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 21:47'! nextInspectorType | index types | types := self inspectorTypes. index := types indexOf: self inspectorType ifAbsent: [ ^ types first ]. ^types atWrap: index + 1.! ! !InspectorNavigator methodsFor: 'updating' stamp: 'CamilloBruni 9/20/2013 20:38'! updateInspectorFrom: oldInspector self updateTitle. self inspector ifNil: [ ^ self ]. self canBeRefreshed ifFalse: [ ^ self ]. self needRebuild: false. self buildWithSpec: oldInspector spec selector. oldInspector close. "kill the update process"! ! !InspectorNavigator methodsFor: 'initialization' stamp: 'StephaneDucasse 3/7/2014 11:07'! step self inspector step.! ! !InspectorNavigator methodsFor: 'private' stamp: 'StephaneDucasse 8/4/2013 16:54'! setRefreshedToTrue "introduced because we should not use weak announcer with on:do:." canBeRefreshed := true! ! !InspectorNavigator methodsFor: 'actions' stamp: 'CamilloBruni 9/20/2013 19:34'! useNextInspectorType self inspectorType: self nextInspectorType! ! !InspectorNavigator methodsFor: 'menu' stamp: 'NicolaiHess 2/15/2014 23:59'! customMenuActions ^ [:aMenu :currentGroup | currentGroup addItem: [ :item | item name: 'Dive Into' translated; action: [ self diveIntoSelectedObject ]; shortcut: $d command mac | $d alt win | $d alt unix]. (history hasPrevious or: [ history hasNext ]) ifTrue: [ aMenu addGroup: [ :aGroup | history hasPrevious ifTrue: [ aGroup addItem: [ :item | item name: 'Back' translated; action: [ self inspectPrevious ]; shortcut: $[ command mac | $[ alt win | $[ alt unix ] ]. history hasNext ifTrue: [ aGroup addItem: [ :item | item name: 'Forward' translated; action: [ self inspectNext ]; shortcut: $] command mac | $] alt win | $] alt unix ] ] ] ] ]! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 19:32'! inspectorTypes ^ self inspector variants! ! !InspectorNavigator methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 22:31'! inspector: anEyeInspector self basicInspector: anEyeInspector. self pushHistory.! ! !InspectorNavigator class methodsFor: 'instance creation' stamp: 'ClementBera 5/2/2013 11:43'! openInspector: inspector ^ self new inspector: inspector; openWithSpec: #inspectorSpec; yourself! ! !InspectorNavigator class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/8/2013 16:56'! debuggerSpec ^ SpecLayout composed newRow: #toolbar height: self toolbarHeight; add: #inspector withSpec: #debuggerSpec top: self toolbarHeight; yourself! ! !InspectorNavigator class methodsFor: 'instance creation' stamp: 'MarcusDenker 9/28/2013 15:58'! openExplorer: inspector ^ (self openInspector: inspector) useTreeInspector! ! !InspectorNavigator class methodsFor: 'instance creation' stamp: 'cb 6/25/2013 13:39'! inspect: anObject ^ self openInspector: anObject inspector! ! !InspectorNavigator class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/8/2013 16:57'! inspectorSpec ^ SpecLayout composed newColumn: [ :c | c add: #toolbar height: self toolbarHeight; add: #inspector withSpec: #inspectorSpec ]; yourself! ! !InstVarRefLocator commentStamp: 'md 4/8/2003 12:50'! My job is to scan bytecodes for instance variable references. BlockContext allInstances collect: [ :x | {x. x hasInstVarRef} ].! !InstVarRefLocator methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:46'! popIntoReceiverVariable: offset bingo := true! ! !InstVarRefLocator methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:46'! pushReceiverVariable: offset bingo := true! ! !InstVarRefLocator methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:46'! storeIntoReceiverVariable: offset bingo := true! ! !InstVarRefLocator methodsFor: 'initialize-release' stamp: 'md 4/8/2003 11:35'! interpretNextInstructionUsing: aScanner bingo := false. aScanner interpretNextInstructionFor: self. ^bingo! ! !InstVarRefLocatorTest commentStamp: ''! This is the unit test for the class InstVarRefLocator. 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 - there is a chapter in the PharoByExample book (http://pharobyexample.org) - the sunit class category! !InstVarRefLocatorTest methodsFor: 'examples' stamp: 'sd 6/5/2005 08:27'! example1 | ff | (1 < 2) ifTrue: [tt ifNotNil: [ff := 'hallo']]. ^ ff.! ! !InstVarRefLocatorTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testInstructions Object methods do: [ :method | | scanner printer end | scanner := InstructionStream on: method. printer := InstVarRefLocator new. end := scanner method endPC. [ scanner pc <= end ] whileTrue: [ printer interpretNextInstructionUsing: scanner ] ]! ! !InstVarRefLocatorTest methodsFor: 'tests' stamp: 'md 4/8/2003 12:42'! testExample2 | method | method := self class compiledMethodAt: #example2. self deny: (self hasInstVarRef: method).! ! !InstVarRefLocatorTest methodsFor: 'tests' stamp: 'md 4/8/2003 12:42'! testExample1 | method | method := self class compiledMethodAt: #example1. self assert: (self hasInstVarRef: method).! ! !InstVarRefLocatorTest methodsFor: 'private' stamp: 'md 4/8/2003 12:39'! hasInstVarRef: aMethod "Answer whether the receiver references an instance variable." | scanner end printer | scanner := InstructionStream on: aMethod. printer := InstVarRefLocator new. end := scanner method endPC. [scanner pc <= end] whileTrue: [ (printer interpretNextInstructionUsing: scanner) ifTrue: [^true]. ]. ^false! ! !InstVarRefLocatorTest methodsFor: 'examples' stamp: 'md 4/8/2003 12:31'! example2 | ff| ff := 1. (1 < 2) ifTrue: [ff ifNotNil: [ff := 'hallo']]. ^ ff.! ! !InstanceModification commentStamp: ''! I collect and provide the information to migrate instances when a class changed.! !InstanceModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:14'! installModifiedSlot: modifiedSlot modificationMap at: modifiedSlot newFieldIndex put: modifiedSlot! ! !InstanceModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:14'! installRemovedSlot: removedSlot " ignore "! ! !InstanceModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:13'! installAddedSlot: addedSlot modificationMap at: addedSlot newFieldIndex put: addedSlot! ! !InstanceVariableEyeElement commentStamp: ''! I am an eye element for instance variables.! !InstanceVariableEyeElement methodsFor: 'action' stamp: 'ClementBera 4/30/2013 11:45'! referencesToInstanceVariable "Open a browser on all references to the selected instance variable, if that's what currently selected." ^ self systemNavigation browseAllAccessesTo: self instVarName from: self hostClass! ! !InstanceVariableEyeElement methodsFor: 'action' stamp: 'ClementBera 4/30/2013 11:43'! save: aValue self host instVarNamed: self instVarName put: aValue! ! !InstanceVariableEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 11:43'! value ^ self host instVarNamed: self instVarName! ! !InstanceVariableEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 11:41'! instVarName: aString instVarName := aString! ! !InstanceVariableEyeElement methodsFor: 'menu' stamp: 'ClementBera 4/30/2013 13:05'! accessorCode ^ self instVarName! ! !InstanceVariableEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 11:41'! instVarName ^ instVarName! ! !InstanceVariableEyeElement methodsFor: 'menu' stamp: 'TudorGirba 11/14/2013 22:17'! customSubMenu: aMenu aMenu addGroup: [ :aGroup | aGroup addItem: [:anItem | anItem name: 'List Methods Using "', self instVarName, '"'; action: [ self referencesToInstanceVariable] ]; addItem: [:anItem | anItem name: 'List Methods Storing into "', self instVarName, '"'; action: [ self storingsIntoInstanceVariable]. ]. ]! ! !InstanceVariableEyeElement methodsFor: 'accessing' stamp: 'ClementBera 4/30/2013 11:41'! label ^ self instVarName! ! !InstanceVariableEyeElement methodsFor: 'action' stamp: 'ClementBera 4/30/2013 11:46'! storingsIntoInstanceVariable ^ self systemNavigation browseAllStoresInto: self instVarName from: self hostClass! ! !InstanceVariableEyeElement methodsFor: 'comparing' stamp: 'SvenVanCaekenberghe 3/30/2014 13:10'! = anObject ^ super = anObject and: [ instVarName = anObject instVarName ]! ! !InstanceVariableEyeElement methodsFor: 'comparing' stamp: 'SvenVanCaekenberghe 4/1/2014 09:54'! hash ^ super hash bitXor: instVarName hash! ! !InstanceVariableEyeElement class methodsFor: 'instance creation' stamp: 'ClementBera 4/30/2013 11:40'! host: anObject instVarName: aString ^ (self host: anObject) instVarName: aString! ! !InstanceVariableNode commentStamp: 'TorstenBergmann 1/31/2014 11:19'! I am a parse tree leaf representing an instance variable.! !InstanceVariableNode methodsFor: 'initialize-release' stamp: 'eem 5/13/2008 10:17'! name: varName index: varIndex ^self name: varName index: varIndex-1 type: LdInstType! ! !InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:08'! emitCodeForStore: stack encoder: encoder encoder genStoreInstVar: index! ! !InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:07'! sizeCodeForStorePop: encoder ^encoder sizeStorePopInstVar: index! ! !InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:08'! emitCodeForValue: stack encoder: encoder stack push: 1. ^encoder genPushInstVar: index! ! !InstanceVariableNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:34'! accept: aVisitor ^aVisitor visitInstanceVariableNode: self! ! !InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:57'! sizeCodeForStore: encoder ^encoder sizeStoreInstVar: index! ! !InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 10:05'! emitCodeForStorePop: stack encoder: encoder encoder genStorePopInstVar: index. stack pop: 1! ! !InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:53'! sizeCodeForValue: encoder ^encoder sizePushInstVar: index! ! !InstructionClient commentStamp: 'md 4/8/2003 12:50'! My job is to make it easier to implement clients for InstructionStream. See InstVarRefLocator as an example. ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! pushConstant: value "Push Constant, value, on Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! methodReturnReceiver "Return Self bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! pushReceiver "Push Active Context's Receiver on Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! popIntoTemporaryVariable: offset "Remove Top Of Stack And Store Into Temporary Variable bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! popIntoLiteralVariable: anAssociation "Remove Top Of Stack And Store Into Literal Variable bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! send: selector super: supered numArgs: numberArguments "Send Message With Selector, selector, bytecode. The argument, supered, indicates whether the receiver of the message is specified with 'super' in the source method. The arguments of the message are found in the top numArguments locations on the stack and the receiver just below them." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! jump: offset if: condition "Conditional Jump bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:49'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize "Push Closure bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! storeIntoLiteralVariable: anAssociation "Store Top Of Stack Into Literal Variable Of Method bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:50'! pushNewArrayOfSize: numElements "Push New Array of size numElements bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! doPop "Remove Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! pushTemporaryVariable: offset "Push Contents Of Temporary Variable Whose Index Is the argument, offset, On Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! methodReturnTop "Return Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! popIntoReceiverVariable: offset "Remove Top Of Stack And Store Into Instance Variable bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:51'! popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Remove Top Of Stack And Store Into Offset of Temp Vector bytecode."! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! jump: offset "Unconditional Jump bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 6/16/2008 14:26'! pushConsArrayWithElements: numElements "Push Cons Array of size numElements popping numElements items from the stack into the array bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! pushActiveContext "Push Active Context On Top Of Its Own Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! methodReturnConstant: value "Return Constant bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:52'! storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Store Top Of Stack And Store Into Offset of Temp Vector bytecode."! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! pushReceiverVariable: offset "Push Contents Of the Receiver's Instance Variable Whose Index is the argument, offset, On Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! pushLiteralVariable: anAssociation "Push Contents Of anAssociation On Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'eem 5/31/2008 13:54'! pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Push Contents at Offset in Temp Vector bytecode."! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! doDup "Duplicate Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! storeIntoReceiverVariable: offset "Store Top Of Stack Into Instance Variable Of Method bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! storeIntoTemporaryVariable: offset "Store Top Of Stack Into Temporary Variable Of Method bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! blockReturnTop "Return Top Of Stack bytecode." ! ! !InstructionClientTest commentStamp: ''! This is the unit test for the class InstructionClient. 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 - there is a chapter in the PharoByExample book (http://pharobyexample.org) - the sunit class category! !InstructionClientTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testInstructions "just interpret all of methods of Object" | client | client := InstructionClient new. Object methods do: [ :method | | scanner | scanner := InstructionStream on: method. [ scanner pc <= method endPC ] whileTrue: [ scanner interpretNextInstructionFor: client ] ]! ! !InstructionPrinter commentStamp: 'md 4/8/2003 12:47'! My instances can print the object code of a CompiledMethod in symbolic format. They print into an instance variable, stream, and uses oldPC to determine how many bytes to print in the listing. The variable method is used to hold the method being printed.! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! popIntoTemporaryVariable: offset "Print the Remove Top Of Stack And Store Into Temporary Variable bytecode." self print: 'popIntoTemp: ' , offset printString! ! !InstructionPrinter methodsFor: 'accessing' stamp: 'eem 5/29/2008 14:00'! method: aMethod method := aMethod. printPC := true. indentSpanOfFollowingJump := false! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! pushReceiver "Print the Push Active Context's Receiver on Top Of Stack bytecode." self print: 'self'! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! storeIntoReceiverVariable: offset "Print the Store Top Of Stack Into Instance Variable Of Method bytecode." self print: 'storeIntoRcvr: ' , offset printString! ! !InstructionPrinter methodsFor: 'initialize-release' stamp: 'eem 8/4/2008 16:26'! printInstructionsOn: aStream do: aBlock "Append to the stream, aStream, a description of each bytecode in the instruction stream. Evaluate aBlock with the receiver, the scanner and the stream after each instruction." | end | stream := aStream. scanner := InstructionStream on: method. end := method endPC. oldPC := scanner pc. innerIndents := Array new: end withAll: 0. [scanner pc <= end] whileTrue: [scanner interpretNextInstructionFor: self. aBlock value: self value: scanner value: stream]! ! !InstructionPrinter methodsFor: 'initialize-release' stamp: 'ajh 2/9/2003 14:16'! indent: numTabs indent := numTabs! ! !InstructionPrinter methodsFor: 'printing' stamp: 'eem 5/29/2008 13:53'! print: instruction "Append to the receiver a description of the bytecode, instruction." | code | stream tab: self indent. printPC ifTrue: [stream print: oldPC; space]. stream tab: (innerIndents at: oldPC). stream nextPut: $<. oldPC to: scanner pc - 1 do: [:i | code := (method at: i) radix: 16. stream nextPut: (code size < 2 ifTrue: [$0] ifFalse: [code at: 1]). stream nextPut: code last; space]. stream skip: -1. stream nextPut: $>. stream space. stream nextPutAll: instruction. stream cr. oldPC := scanner pc. "(InstructionPrinter compiledMethodAt: #print:) symbolic." ! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/23/2008 13:58'! pushConstant: obj "Print the Push Constant, obj, on Top Of Stack bytecode." self print: (String streamContents: [:s | s nextPutAll: 'pushConstant: '. (obj isKindOf: LookupKey) ifFalse: [obj printOn: s] ifTrue: [obj key ifNotNil: [s nextPutAll: '##'; nextPutAll: obj key] ifNil: [s nextPutAll: '###'; nextPutAll: obj value soleInstance name]]]). (obj isKindOf: CompiledMethod) ifTrue: [obj longPrintOn: stream indent: self indent + 2. ^self].! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! popIntoLiteralVariable: anAssociation "Print the Remove Top Of Stack And Store Into Literal Variable bytecode." self print: 'popIntoLit: ' , anAssociation key! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'marcusDenker 2/26/2012 20:09'! send: selector super: supered numArgs: numberArguments "Print the Send Message With Selector, selector, bytecode. The argument, supered, indicates whether the receiver of the message is specified with 'super' in the source method. The arguments of the message are found in the top numArguments locations on the stack and the receiver just below them." self print: (supered ifTrue: ['superSend: '] ifFalse: ['send: ']) , selector. indentSpanOfFollowingJump := #(#closureCopy:copiedValues:) includes: selector! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 11:13'! jump: offset if: condition "Print the Conditional Jump bytecode." self print: (condition ifTrue: ['jumpTrue: '] ifFalse: ['jumpFalse: ']) , (scanner pc + offset) printString! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 6/16/2008 14:04'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize self print: 'closureNumCopied: ', numCopied printString , ' numArgs: ', numArgs printString , ' bytes ', scanner pc printString , ' to ', (scanner pc + blockSize - 1) printString. innerIndents atAll: (scanner pc to: scanner pc + blockSize - 1) put: (innerIndents at: scanner pc - 1) + 1! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! storeIntoLiteralVariable: anAssociation "Print the Store Top Of Stack Into Literal Variable Of Method bytecode." self print: 'storeIntoLit: ' , anAssociation key! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/25/2008 15:02'! pushNewArrayOfSize: numElements self print: 'push: (Array new: ', numElements printString, ')'! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 12:14'! doPop "Print the Remove Top Of Stack bytecode." self print: 'pop'! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! pushTemporaryVariable: offset "Print the Push Contents Of Temporary Variable Whose Index Is the argument, offset, On Top Of Stack bytecode." self print: 'pushTemp: ' , offset printString! ! !InstructionPrinter methodsFor: 'accessing' stamp: 'ajh 6/27/2003 22:25'! indent ^ indent ifNil: [0]! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! methodReturnTop "Print the Return Top Of Stack bytecode." self print: 'returnTop'! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! popIntoReceiverVariable: offset "Print the Remove Top Of Stack And Store Into Instance Variable bytecode." self print: 'popIntoRcvr: ' , offset printString! ! !InstructionPrinter methodsFor: 'initialize-release' stamp: 'eem 5/29/2008 13:26'! printInstructionsOn: aStream "Append to the stream, aStream, a description of each bytecode in the instruction stream." | end | stream := aStream. scanner := InstructionStream on: method. end := method endPC. oldPC := scanner pc. innerIndents := Array new: end withAll: 0. [scanner pc <= end] whileTrue: [scanner interpretNextInstructionFor: self]! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/29/2008 14:02'! jump: offset "Print the Unconditional Jump bytecode." self print: 'jumpTo: ' , (scanner pc + offset) printString. indentSpanOfFollowingJump ifTrue: [indentSpanOfFollowingJump := false. innerIndents atAll: (scanner pc to: scanner pc + offset - 1) put: (innerIndents at: scanner pc - 1) + 1]! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/25/2008 14:06'! popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex self print: 'popIntoTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! ! !InstructionPrinter methodsFor: 'accessing' stamp: 'md 4/8/2003 11:20'! method ^method.! ! !InstructionPrinter methodsFor: 'accessing' stamp: 'eem 5/29/2008 13:50'! printPC ^printPC! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/30/2008 17:42'! pushConsArrayWithElements: numElements self print: 'pop ', numElements printString, ' into (Array new: ', numElements printString, ')'! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! methodReturnConstant: value "Print the Return Constant bytecode." self print: 'return: ' , value printString! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! pushActiveContext "Print the Push Active Context On Top Of Its Own Stack bytecode." self print: 'pushThisContext: '! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/25/2008 14:06'! storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex self print: 'storeIntoTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! pushReceiverVariable: offset "Print the Push Contents Of the Receiver's Instance Variable Whose Index is the argument, offset, On Top Of Stack bytecode." self print: 'pushRcvr: ' , offset printString! ! !InstructionPrinter methodsFor: 'accessing' stamp: 'eem 5/29/2008 13:50'! printPC: aBoolean printPC := aBoolean! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! pushLiteralVariable: anAssociation "Print the Push Contents Of anAssociation On Top Of Stack bytecode." self print: 'pushLit: ' , anAssociation key! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'eem 5/25/2008 00:00'! pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex self print: 'pushTemp: ', remoteTempIndex printString, ' inVectorAt: ', tempVectorIndex printString! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! storeIntoTemporaryVariable: offset "Print the Store Top Of Stack Into Temporary Variable Of Method bytecode." self print: 'storeIntoTemp: ' , offset printString! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! doDup "Print the Duplicate Top Of Stack bytecode." self print: 'dup'! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! methodReturnReceiver "Print the Return Self bytecode." self print: 'returnSelf'! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: ''! blockReturnTop "Print the Return Top Of Stack bytecode." self print: 'blockReturn'! ! !InstructionPrinter class methodsFor: 'printing' stamp: 'md 4/8/2003 11:19'! on: aMethod ^self new method: aMethod. ! ! !InstructionPrinter class methodsFor: 'printing' stamp: 'nice 1/16/2010 12:56'! printClass: class "Create a file whose name is the argument followed by '.bytes'. Store on the file the symbolic form of the compiled methods of the class." | file | file := FileStream newFileNamed: class name , '.bytes'. class selectorsAndMethodsDo: [:sel :meth | file cr; nextPutAll: sel; cr. (self on: meth) printInstructionsOn: file]. file close "InstructionPrinter printClass: Parser." ! ! !InstructionPrinterTest commentStamp: ''! This is the unit test for the class InstructionPrinter. 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 - there is a chapter in the PharoByExample book (http://pharobyexample.org) - the sunit class category! !InstructionPrinterTest methodsFor: 'examples' stamp: 'md 4/8/2003 12:28'! example1 | ff| (1 < 2) ifTrue: [tt ifNotNil: [ff := 'hallo']]. ^ ff.! ! !InstructionPrinterTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testInstructions "just print all of methods of Object and see if no error accours" | printer | printer := InstructionPrinter. Object methods do: [ :method | String streamContents: [ :stream | (printer on: method) printInstructionsOn: stream ] ]! ! !InstructionStream commentStamp: ''! Instance variables: sender: context that invoked this context pc: (pc = program counter) offset of the bytecode instruction currently executed My instances can interpret the byte-encoded Smalltalk instruction set. They maintain a program counter (pc) for streaming through CompiledMethods. My subclasses are Contexts, which inherit this capability. They store the return pointer in the instance variable sender, and the current position in their method in the instance variable pc. For other users, sender can hold a method to be similarly interpreted. The unclean re-use of sender to hold the method was to avoid a trivial subclass for the stand-alone scanning function.! !InstructionStream methodsFor: 'scanning' stamp: 'eem 6/4/2008 10:58'! addSelectorTo: set "If this instruction is a send, add its selector to set." | selectorOrSelf | (selectorOrSelf := self selectorToSendOrSelf) == self ifFalse: [set add: selectorOrSelf]! ! !InstructionStream methodsFor: 'testing' stamp: 'MarcusDenker 11/18/2013 16:02'! willCreateBlock "next bytecode is a block creation" ^ (self method at: pc) = 143! ! !InstructionStream methodsFor: 'scanning' stamp: 'eem 6/5/2008 10:07'! previousPc ^self method pcPreviousTo: pc! ! !InstructionStream methodsFor: 'testing' stamp: ''! willReturn "Answer whether the next bytecode is a return." ^(self method at: pc) between: 120 and: 125! ! !InstructionStream methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2013 22:08'! willStorePop "Answer whether the next bytecode is a store-pop." | byte | byte := self method at: pc. "130 extendedStoreAndPopBytecode" ^ byte = 130 or: [ "142 storeAndPopRemoteTempLongBytecode" byte = 142 or: [ "96 103 storeAndPopReceiverVariableBytecode" "104 111 storeAndPopTemporaryVariableBytecode" byte between: 96 and: 111 ]]! ! !InstructionStream methodsFor: 'decoding' stamp: ''! interpretJump | byte | byte := self method at: pc. (byte between: 144 and: 151) ifTrue: [pc := pc + 1. ^byte - 143]. (byte between: 160 and: 167) ifTrue: [pc := pc + 2. ^(byte - 164) * 256 + (self method at: pc - 1)]. ^nil! ! !InstructionStream methodsFor: 'scanning' stamp: ''! pc "Answer the index of the next bytecode." ^pc! ! !InstructionStream methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 22:02'! pc: anInteger pc := anInteger! ! !InstructionStream methodsFor: 'scanning' stamp: 'eem 6/16/2008 09:52'! firstByte "Answer the first byte of the current bytecode." ^self method at: pc! ! !InstructionStream methodsFor: 'scanning' stamp: 'eem 6/16/2008 09:53'! fourthByte "Answer the fourth byte of the current bytecode." ^self method at: pc + 3! ! !InstructionStream methodsFor: 'scanning' stamp: 'StephaneDucasse 12/22/2010 17:23'! followingBytecode "Answer the bytecode of the following bytecode (different to nextByte)." ^self method at: self followingPc! ! !InstructionStream methodsFor: 'scanning' stamp: 'StephaneDucasse 12/22/2010 17:23'! scanFor: scanBlock "Answer the index of the first bytecode for which scanBlock answers true when supplied with that bytecode." | method end byte | method := self method. end := method endPC. [pc <= end] whileTrue: [(scanBlock value: (byte := method at: pc)) ifTrue: [^true]. pc := self nextPc: byte]. ^false! ! !InstructionStream methodsFor: 'decoding' stamp: 'md 1/20/2006 17:19'! interpretNextInstructionFor: client "Send to the argument, client, a message that specifies the type of the next instruction." | byte type offset method | method := self method. byte := method at: pc. type := byte // 16. offset := byte \\ 16. pc := pc+1. "We do an inline binary search on each of the possible 16 values of type: The old, cleaner but slowe code is retained as a comment below" type < 8 ifTrue: [type < 4 ifTrue: [type < 2 ifTrue: [type < 1 ifTrue: ["type = 0" ^ client pushReceiverVariable: offset] ifFalse: ["type = 1" ^ client pushTemporaryVariable: offset]] ifFalse: [type < 3 ifTrue: ["type = 2" ^ client pushConstant: (method literalAt: offset + 1)] ifFalse: ["type = 3" ^ client pushConstant: (method literalAt: offset + 17)]]] ifFalse: [type < 6 ifTrue: [type < 5 ifTrue: ["type = 4" ^ client pushLiteralVariable: (method literalAt: offset + 1)] ifFalse: ["type = 5" ^ client pushLiteralVariable: (method literalAt: offset + 17)]] ifFalse: [type < 7 ifTrue: ["type = 6" offset < 8 ifTrue: [^ client popIntoReceiverVariable: offset] ifFalse: [^ client popIntoTemporaryVariable: offset - 8]] ifFalse: ["type = 7" offset = 0 ifTrue: [^ client pushReceiver]. offset < 8 ifTrue: [^ client pushConstant: (SpecialConstants at: offset)]. offset = 8 ifTrue: [^ client methodReturnReceiver]. offset < 12 ifTrue: [^ client methodReturnConstant: (SpecialConstants at: offset - 8)]. offset = 12 ifTrue: [^ client methodReturnTop]. offset = 13 ifTrue: [^ client blockReturnTop]. offset > 13 ifTrue: [^ self error: 'unusedBytecode']]]]] ifFalse: [type < 12 ifTrue: [type < 10 ifTrue: [type < 9 ifTrue: ["type = 8" ^ self interpretExtension: offset in: method for: client] ifFalse: ["type = 9 (short jumps)" offset < 8 ifTrue: [^ client jump: offset + 1]. ^ client jump: offset - 8 + 1 if: false]] ifFalse: [type < 11 ifTrue: ["type = 10 (long jumps)" byte := method at: pc. pc := pc + 1. offset < 8 ifTrue: [^ client jump: offset - 4 * 256 + byte]. ^ client jump: (offset bitAnd: 3) * 256 + byte if: offset < 12] ifFalse: ["type = 11" ^ client send: (Smalltalk specialSelectorAt: offset + 1) super: false numArgs: (Smalltalk specialNargsAt: offset + 1)]]] ifFalse: [type = 12 ifTrue: [^ client send: (Smalltalk specialSelectorAt: offset + 17) super: false numArgs: (Smalltalk specialNargsAt: offset + 17)] ifFalse: ["type = 13, 14 or 15" ^ client send: (method literalAt: offset + 1) super: false numArgs: type - 13]]]. " old code type=0 ifTrue: [^client pushReceiverVariable: offset]. type=1 ifTrue: [^client pushTemporaryVariable: offset]. type=2 ifTrue: [^client pushConstant: (method literalAt: offset+1)]. type=3 ifTrue: [^client pushConstant: (method literalAt: offset+17)]. type=4 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+1)]. type=5 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+17)]. type=6 ifTrue: [offset<8 ifTrue: [^client popIntoReceiverVariable: offset] ifFalse: [^client popIntoTemporaryVariable: offset-8]]. type=7 ifTrue: [offset=0 ifTrue: [^client pushReceiver]. offset<8 ifTrue: [^client pushConstant: (SpecialConstants at: offset)]. offset=8 ifTrue: [^client methodReturnReceiver]. offset<12 ifTrue: [^client methodReturnConstant: (SpecialConstants at: offset-8)]. offset=12 ifTrue: [^client methodReturnTop]. offset=13 ifTrue: [^client blockReturnTop]. offset>13 ifTrue: [^self error: 'unusedBytecode']]. type=8 ifTrue: [^self interpretExtension: offset in: method for: client]. type=9 ifTrue: short jumps [offset<8 ifTrue: [^client jump: offset+1]. ^client jump: offset-8+1 if: false]. type=10 ifTrue: long jumps [byte:= method at: pc. pc:= pc+1. offset<8 ifTrue: [^client jump: offset-4*256 + byte]. ^client jump: (offset bitAnd: 3)*256 + byte if: offset<12]. type=11 ifTrue: [^client send: (Smalltalk specialSelectorAt: offset+1) super: false numArgs: (Smalltalk specialNargsAt: offset+1)]. type=12 ifTrue: [^client send: (Smalltalk specialSelectorAt: offset+17) super: false numArgs: (Smalltalk specialNargsAt: offset+17)]. type>12 ifTrue: [^client send: (method literalAt: offset+1) super: false numArgs: type-13]"! ! !InstructionStream methodsFor: 'scanning' stamp: 'CamilloBruni 7/17/2013 22:04'! skipBackBeforeJump "Assuming that the receiver is positioned jast after a jump, skip back one or two bytes, depending on the size of the previous jump instruction." | strm short | strm := InstructionStream on: self method. (strm scanFor: [ :byte | ((short := byte between: 152 and: 159) or: [byte between: 168 and: 175]) and: [strm pc = (short ifTrue: [pc-1] ifFalse: [pc-2])]]) ifFalse: [self error: 'Where''s the jump??']. self jump: (short ifTrue: [-1] ifFalse: [-2]). ! ! !InstructionStream methodsFor: 'testing' stamp: ''! willJumpIfFalse "Answer whether the next bytecode is a jump-if-false." | byte | byte := self method at: pc. ^(byte between: 152 and: 159) or: [byte between: 172 and: 175]! ! !InstructionStream methodsFor: 'debugger access' stamp: 'eem 6/5/2008 10:45'! debuggerMap ^self method debuggerMap! ! !InstructionStream methodsFor: 'scanning' stamp: 'eem 6/16/2008 09:52'! secondByte "Answer the second byte of the current bytecode." ^self method at: pc + 1! ! !InstructionStream methodsFor: 'scanning' stamp: 'StephaneDucasse 12/22/2010 17:24'! followingPc "Answer the pc of the following bytecode." ^self nextPc: (self method at: pc)! ! !InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:32'! nextInstruction "Return the next bytecode instruction as a message that an InstructionClient would understand. This advances the pc by one instruction." ^ self interpretNextInstructionFor: MessageCatcher new! ! !InstructionStream methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2013 22:04'! willSend "Answer whether the next bytecode is a message-send." | byte | byte := self method at: pc. ^byte >= 131 and: [ "special send or short send" byte >= 176 or: [ "long sends" byte <= 134]]! ! !InstructionStream methodsFor: 'decoding' stamp: 'ajh 7/29/2001 20:45'! atEnd ^ pc > self method endPC! ! !InstructionStream methodsFor: 'scanning' stamp: ''! method "Answer the compiled method that supplies the receiver's bytecodes." ^sender "method access when used alone (not as part of a context)"! ! !InstructionStream methodsFor: 'testing' stamp: 'MarcusDenker 6/30/2012 16:40'! willBlockReturn ^ (self method at: pc) = 125! ! !InstructionStream methodsFor: 'testing' stamp: 'MarcusDenker 6/30/2012 16:40'! willJustPop ^ (self method at: pc) = 135! ! !InstructionStream methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2013 22:07'! willStore "Answer whether the next bytecode is a store or store-pop" | byte | byte := self method at: pc. ^(byte between: 96 and: 142) and: [ "96 103 storeAndPopReceiverVariableBytecode" "104 111 storeAndPopTemporaryVariableBytecode" byte <= 111 or: [ "129 extendedStoreBytecode" byte >= 129 and: [ "130 extendedStoreAndPopBytecode" byte <= 130 or: [( "132 doubleExtendedDoAnythingBytecode" byte = 132 and: [ (self method at: pc+1) >= 160 ]) or: [ "141 storeRemoteTempLongBytecode" byte = 141 or: [ "142 storeAndPopRemoteTempLongBytecode" byte = 142]]]]]]! ! !InstructionStream methodsFor: 'scanning' stamp: ''! followingByte "Answer the next bytecode." ^self method at: pc + 1! ! !InstructionStream methodsFor: 'private' stamp: ''! method: method pc: startpc sender := method. "allows this class to stand alone as a method scanner" pc := startpc! ! !InstructionStream methodsFor: 'testing' stamp: 'di 1/29/2000 14:42'! willJumpIfTrue "Answer whether the next bytecode is a jump-if-true." | byte | byte := self method at: pc. ^ byte between: 168 and: 171! ! !InstructionStream methodsFor: 'decoding' stamp: 'MarcusDenker 6/13/2012 17:03'! interpret | endPC | endPC := self method endPC. [pc > endPC] whileFalse: [self interpretNextInstructionFor: self]! ! !InstructionStream methodsFor: 'scanning' stamp: 'CamilloBruni 7/17/2013 22:03'! selectorToSendOrSelf "If this instruction is a send, answer the selector, otherwise answer self." | byte byte2 | byte := self method at: pc. byte < 131 ifTrue: [^self]. byte >= 176 ifTrue: [ "special byte or short send" byte >= 208 ifTrue: [^self method literalAt: (byte bitAnd: 15) + 1] ifFalse: [^Smalltalk specialSelectorAt: byte - 176 + 1]] ifFalse: [ byte <= 134 ifTrue: [ byte2 := self method at: pc + 1. byte = 131 ifTrue: [^self method literalAt: byte2 \\ 32 + 1]. byte = 132 ifTrue: [ byte2 < 64 ifTrue: [^self method literalAt: (self method at: pc + 2) + 1]] . byte = 133 ifTrue: [^self method literalAt: byte2 \\ 32 + 1]. byte = 134 ifTrue: [^self method literalAt: byte2 \\ 64 + 1]]]! ! !InstructionStream methodsFor: 'private' stamp: 'eem 6/16/2008 09:49'! interpretExtension: offset in: method for: client | type offset2 byte2 byte3 byte4 | offset <= 6 ifTrue: ["Extended op codes 128-134" byte2 := method at: pc. pc := pc + 1. offset <= 2 ifTrue: ["128-130: extended pushes and pops" type := byte2 // 64. offset2 := byte2 \\ 64. offset = 0 ifTrue: [type = 0 ifTrue: [^client pushReceiverVariable: offset2]. type = 1 ifTrue: [^client pushTemporaryVariable: offset2]. type = 2 ifTrue: [^client pushConstant: (method literalAt: offset2 + 1)]. type = 3 ifTrue: [^client pushLiteralVariable: (method literalAt: offset2 + 1)]]. offset = 1 ifTrue: [type = 0 ifTrue: [^client storeIntoReceiverVariable: offset2]. type = 1 ifTrue: [^client storeIntoTemporaryVariable: offset2]. type = 2 ifTrue: [self error: 'illegalStore']. type = 3 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]]. offset = 2 ifTrue: [type = 0 ifTrue: [^client popIntoReceiverVariable: offset2]. type = 1 ifTrue: [^client popIntoTemporaryVariable: offset2]. type = 2 ifTrue: [self error: 'illegalStore']. type = 3 ifTrue: [^client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]]. "131-134: extended sends" offset = 3 ifTrue: "Single extended send" [^client send: (method literalAt: byte2 \\ 32 + 1) super: false numArgs: byte2 // 32]. offset = 4 ifTrue: "Double extended do-anything" [byte3 := method at: pc. pc := pc + 1. type := byte2 // 32. type = 0 ifTrue: [^client send: (method literalAt: byte3 + 1) super: false numArgs: byte2 \\ 32]. type = 1 ifTrue: [^client send: (method literalAt: byte3 + 1) super: true numArgs: byte2 \\ 32]. type = 2 ifTrue: [^client pushReceiverVariable: byte3]. type = 3 ifTrue: [^client pushConstant: (method literalAt: byte3 + 1)]. type = 4 ifTrue: [^client pushLiteralVariable: (method literalAt: byte3 + 1)]. type = 5 ifTrue: [^client storeIntoReceiverVariable: byte3]. type = 6 ifTrue: [^client popIntoReceiverVariable: byte3]. type = 7 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]]. offset = 5 ifTrue: "Single extended send to super" [^client send: (method literalAt: byte2 \\ 32 + 1) super: true numArgs: byte2 // 32]. offset = 6 ifTrue: "Second extended send" [^client send: (method literalAt: byte2 \\ 64 + 1) super: false numArgs: byte2 // 64]]. offset = 7 ifTrue: [^client doPop]. offset = 8 ifTrue: [^client doDup]. offset = 9 ifTrue: [^client pushActiveContext]. byte2 := method at: pc. pc := pc + 1. offset = 10 ifTrue: [^byte2 < 128 ifTrue: [client pushNewArrayOfSize: byte2] ifFalse: [client pushConsArrayWithElements: byte2 - 128]]. offset = 11 ifTrue: [^self error: 'unusedBytecode']. byte3 := method at: pc. pc := pc + 1. offset = 12 ifTrue: [^client pushRemoteTemp: byte2 inVectorAt: byte3]. offset = 13 ifTrue: [^client storeIntoRemoteTemp: byte2 inVectorAt: byte3]. offset = 14 ifTrue: [^client popIntoRemoteTemp: byte2 inVectorAt: byte3]. "offset = 15" byte4 := method at: pc. pc := pc + 1. ^client pushClosureCopyNumCopiedValues: (byte2 bitShift: -4) numArgs: (byte2 bitAnd: 16rF) blockSize: (byte3 * 256) + byte4! ! !InstructionStream methodsFor: 'scanning' stamp: 'eem 6/16/2008 09:52'! thirdByte "Answer the third byte of the current bytecode." ^self method at: pc + 2! ! !InstructionStream methodsFor: 'scanning' stamp: 'CamilloBruni 7/17/2013 22:03'! peekInstruction "Return the next bytecode instruction as a message that an InstructionClient would understand. The pc remains unchanged." | currentPc instruction | currentPc := self pc. instruction := self nextInstruction. self pc: currentPc. ^ instruction! ! !InstructionStream methodsFor: 'scanning' stamp: ''! nextByte "Answer the next bytecode." ^self method at: pc! ! !InstructionStream methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 22:02'! nextPc: currentByte "Answer the pc of the next bytecode following the current one, given the current bytecode.." | type | type := currentByte // 16. "extensions" ^ type = 8 ifTrue: [pc + (#(2 2 2 2 3 2 2 1 1 1 2 1 3 3 3 4) at: currentByte \\ 16 + 1)] ifFalse: [ "long jumps" type = 10 ifTrue: [pc + 2] ifFalse: [pc + 1]]! ! !InstructionStream methodsFor: 'testing' stamp: 'ajh 8/13/2002 11:10'! willJump "unconditionally" | byte | byte := self method at: pc. ^ (byte between: 144 and: 151) or: [byte between: 160 and: 167]! ! !InstructionStream methodsFor: 'decoding' stamp: 'eem 9/29/2008 11:59'! interpretJumpIfCond | byte | byte := self method at: pc. (byte between: 152 and: 159) ifTrue: [pc := pc + 1. ^byte - 151]. (byte between: 168 and: 175) ifTrue: [pc := pc + 2. ^(byte bitAnd: 3) * 256 + (self method at: pc - 1)]. ^nil! ! !InstructionStream class methodsFor: 'class initialization' stamp: ''! initialize "Initialize an array of special constants returned by single-bytecode returns." SpecialConstants := (Array with: true with: false with: nil) , (Array with: -1 with: 0 with: 1 with: 2) "InstructionStream initialize." ! ! !InstructionStream class methodsFor: 'instance creation' stamp: ''! on: method "Answer an instance of me on the argument, method." ^self new method: method pc: method initialPC! ! !InstructionStream class methodsFor: '*Compiler' stamp: 'eem 6/19/2008 10:00'! isContextClass ^false! ! !InstructionStream class methodsFor: '*Compiler' stamp: 'eem 7/17/2008 13:16'! instVarNamesAndOffsetsDo: aBinaryBlock "This is part of the interface between the compiler and a class's instance or field names. We override here to arrange that the compiler will use MaybeContextInstanceVariableNodes for instances variables of ContextPart or any of its superclasses and subclasses. The convention to make the compiler use the special nodes is to use negative indices" | superInstSize | (self withAllSubclasses noneSatisfy: [:class|class isContextClass]) ifTrue: [^super instVarNamesAndOffsetsDo: aBinaryBlock]. (superInstSize := superclass notNil ifTrue: [superclass instSize] ifFalse: [0]) > 0 ifTrue: [superclass instVarNamesAndOffsetsDo: aBinaryBlock]. 1 to: self instSize - superInstSize do: [:i| aBinaryBlock value: (instanceVariables at: i) value: (i + superInstSize) negated]! ! !InstructionStream class methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 7/22/2013 16:09'! compiler "The JIT compiler needs to trap all reads to instance variables of contexts. As this check is costly, it is only done in the long form of the bytecodes, which are not used often. In this hierarchy we force the compiler to alwasy generate long bytecodes" ^super compiler options: #(+ optionLongIvarAccessBytecodes)! ! !Integer commentStamp: ''! I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger. Integer division consists of: / exact division, answers a fraction if result is not a whole integer // answers an Integer, rounded towards negative infinity \\ is modulo rounded towards negative infinity quo: truncated division, rounded towards zero! !Integer methodsFor: 'private' stamp: ''! copyto: x | stop | stop := self digitLength min: x digitLength. ^ x replaceFrom: 1 to: stop with: self startingAt: 1! ! !Integer methodsFor: 'enumerating' stamp: ''! timesRepeat: aBlock "Evaluate the argument, aBlock, the number of times represented by the receiver." | count | count := 1. [count <= self] whileTrue: [aBlock value. count := count + 1]! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asAJOperand "Convert receiver into operand: a signed immediate" ^ AJImmediate new ivalue: self! ! !Integer methodsFor: 'printing-numerative' stamp: 'CamilloBruni 10/21/2012 14:48'! printOn: aStream base: base length: minimum padded: zeroFlag | prefix | prefix := self negative ifTrue: ['-'] ifFalse: [ '' ]. self print: (self abs printStringBase: base) on: aStream prefix: prefix length: minimum padded: zeroFlag ! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asUImm "Convert integer value into an unsigned immediate operand" ^ AJImmediate new uvalue: self! ! !Integer methodsFor: 'mathematical functions' stamp: 'nice 3/13/2014 02:56'! nthRoot: aPositiveInteger "Answer the nth root of the receiver. Answer an Integer if root is exactly this Integer, else answer the Float nearest the exact root." | guess p | guess := self nthRootRounded: aPositiveInteger. (guess raisedTo: aPositiveInteger) = self ifTrue: [ ^ guess ]. p := Float precision - guess highBitOfMagnitude. p < 0 ifTrue: [ ^ guess asFloat ]. guess := self << (p * aPositiveInteger) nthRootRounded: aPositiveInteger. ^(guess / (1 << p)) asFloat! ! !Integer methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:38'! < aNumber aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [self negative ifTrue: [^ (self digitCompare: aNumber) > 0] ifFalse: [^ (self digitCompare: aNumber) < 0]] ifFalse: [^ self negative]]. ^ aNumber adaptToInteger: self andCompare: # norm := n normalize. ^ self digitLogic: norm op: #bitXor: length: (self digitLength max: norm digitLength)! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! isByte ^ self >= 0 and: [ self <= 255 ]! ! !Integer methodsFor: 'testing' stamp: 'StephaneDucasse 12/1/2009 14:38'! sqrtFloor "Return the integer part of the square root of self" | guess guessSquared delta | guess := 1 bitShift: self highBit + 1 // 2. [ guessSquared := guess * guess. delta := guessSquared - self // (guess bitShift: 1). delta = 0 ] whileFalse: [ guess := guess - delta ]. guessSquared = self ifFalse: [ guess := guess - 1 ]. ^guess! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 14:46'! printOn: aStream showingDecimalPlaces: placesDesired "Same as super, but provides a faster implementation because fraction part and rounding are trivial." self printOn: aStream base: 10. placesDesired <= 0 ifTrue: [ ^ self ]. aStream nextPut: $.. placesDesired timesRepeat: [ aStream nextPut: $0 ]! ! !Integer methodsFor: 'mathematical functions' stamp: 'di 4/22/1998 14:45'! factorial "Answer the factorial of the receiver." self = 0 ifTrue: [^ 1]. self > 0 ifTrue: [^ self * (self - 1) factorial]. self error: 'Not valid for negative integers'! ! !Integer methodsFor: 'printing' stamp: 'nice 6/17/2011 04:10'! numberOfDigitsInBase: b "Return how many digits are necessary to print this number in base b. This does not count any place for minus sign, radix prefix or whatever. Note that this algorithm may cost a few operations on LargeInteger." | nDigits q total | self negative ifTrue: [^self negated numberOfDigitsInBase: b]. self < b ifTrue: [^1]. b isPowerOfTwo ifTrue: [^self highBit + b highBit - 2 quo: b highBit - 1]. "A conversion from base 2 to base b has to be performed. This algorithm avoids Float computations like (self log: b) floor + 1, 1) because they are inexact 2) because LargeInteger might overflow 3) because this algorithm might be cheaper than conversion" q := self. total := 0. ["Make an initial nDigits guess that is lower than or equal to required number of digits" nDigits := b = 10 ifTrue: [((q highBit - 1) * 1233 >> 12) + 1. "This is because (2 log)/(10 log)*4096 is slightly greater than 1233"] ifFalse: [q highBit quo: b highBit]. total := total + nDigits. "See how many digits remains above these first nDigits guess" (q := q quo: (b raisedToInteger: nDigits)) < b] whileFalse. ^q = 0 ifTrue: [total] ifFalse: [total + 1]! ! !Integer methodsFor: 'arithmetic' stamp: 'CamilloBruni 8/1/2012 15:57'! // aNumber | q | aNumber = 0 ifTrue: [^ (ZeroDivide dividend: self) signal"<- Chg"]. self = 0 ifTrue: [^ 0]. q := self quo: aNumber. "Refer to the comment in Number|//." (q negative ifTrue: [q * aNumber ~= self] ifFalse: [q = 0 and: [self negative ~= aNumber negative]]) ifTrue: [^ q - 1"Truncate towards minus infinity."] ifFalse: [^ q]! ! !Integer methodsFor: 'arithmetic' stamp: 'bf 9/25/2008 15:13'! \\\ anInteger "a modulo method for use in DSA. Be careful if you try to use this elsewhere." ^self \\ anInteger! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asImm32 "Convert integer value into a signed immediate operand" ^ AJImmediate new ivalue: self; size: 4! ! !Integer methodsFor: 'private' stamp: 'sr 6/8/2000 01:28'! digitDiv: arg neg: ng "Answer with an array of (quotient, remainder)." | quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t | arg = 0 ifTrue: [^ (ZeroDivide dividend: self) signal]. "TFEI added this line" l := self digitLength - arg digitLength + 1. l <= 0 ifTrue: [^ Array with: 0 with: self]. "shortcut against #highBit" d := 8 - arg lastDigit highBitOfPositiveReceiver. div := arg digitLshift: d. div := div growto: div digitLength + 1. "shifts so high order word is >=128" rem := self digitLshift: d. rem digitLength = self digitLength ifTrue: [rem := rem growto: self digitLength + 1]. "makes a copy and shifts" quo := Integer new: l neg: ng. dl := div digitLength - 1. "Last actual byte of data" ql := l. dh := div digitAt: dl. dnh := dl = 1 ifTrue: [0] ifFalse: [div digitAt: dl - 1]. 1 to: ql do: [:k | "maintain quo*arg+rem=self" "Estimate rem/div by dividing the leading to bytes of rem by dh." "The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles." j := rem digitLength + 1 - k. "r1 := rem digitAt: j." (rem digitAt: j) = dh ifTrue: [qhi := qlo := 15 "i.e. q=255"] ifFalse: ["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh. Note that r1,r2 are bytes, not nibbles. Be careful not to generate intermediate results exceeding 13 bits." "r2 := (rem digitAt: j - 1)." t := ((rem digitAt: j) bitShift: 4) + ((rem digitAt: j - 1) bitShift: -4). qhi := t // dh. t := (t \\ dh bitShift: 4) + ((rem digitAt: j - 1) bitAnd: 15). qlo := t // dh. t := t \\ dh. "Next compute (hi,lo) := q*dnh" hi := qhi * dnh. lo := qlo * dnh + ((hi bitAnd: 15) bitShift: 4). hi := (hi bitShift: -4) + (lo bitShift: -8). lo := lo bitAnd: 255. "Correct overestimate of q. Max of 2 iterations through loop -- see Knuth vol. 2" r3 := j < 3 ifTrue: [0] ifFalse: [rem digitAt: j - 2]. [(t < hi or: [t = hi and: [r3 < lo]]) and: ["i.e. (t,r3) < (hi,lo)" qlo := qlo - 1. lo := lo - dnh. lo < 0 ifTrue: [hi := hi - 1. lo := lo + 256]. hi >= dh]] whileTrue: [hi := hi - dh]. qlo < 0 ifTrue: [qhi := qhi - 1. qlo := qlo + 16]]. "Subtract q*div from rem" l := j - dl. a := 0. 1 to: div digitLength do: [:i | hi := (div digitAt: i) * qhi. lo := a + (rem digitAt: l) - ((hi bitAnd: 15) bitShift: 4) - ((div digitAt: i) * qlo). rem digitAt: l put: lo - (lo // 256 * 256). "sign-tolerant form of (lo bitAnd: 255)" a := lo // 256 - (hi bitShift: -4). l := l + 1]. a < 0 ifTrue: ["Add div back into rem, decrease q by 1" qlo := qlo - 1. l := j - dl. a := 0. 1 to: div digitLength do: [:i | a := (a bitShift: -8) + (rem digitAt: l) + (div digitAt: i). rem digitAt: l put: (a bitAnd: 255). l := l + 1]]. quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4) + qlo]. rem := rem digitRshift: d bytes: 0 lookfirst: dl. ^ Array with: quo with: rem! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asQuadWord ^ self asTwosComplement: 16rFFFFFFFFFFFFFFFF! ! !Integer methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 6/28/2013 13:03'! asShortcut ^ self asKeyCombination! ! !Integer methodsFor: '*Graphics-Primitives' stamp: 'ar 10/31/1998 23:04'! asColorOfDepth: d "Return a color value representing the receiver as color of the given depth" ^Color colorFromPixelValue: self depth: d! ! !Integer methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! metacelloIntegerLessThanSelf: anInteger ^anInteger < self! ! !Integer methodsFor: 'converting' stamp: 'ls 5/26/1998 20:53'! asHexDigit ^'0123456789ABCDEF' at: self+1! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asUImm32 "Convert integer value into an unsigned immediate operand" ^ AJImmediate new uvalue: self; size: 4! ! !Integer methodsFor: 'converting-arrays' stamp: 'PeterHugossonMiller 9/3/2009 10:00'! asArray | stream | stream := Array new writeStream. self digitLength to: 1 by: -1 do: [:digitIndex | stream nextPut: (self digitAt: digitIndex)]. ^ stream contents ! ! !Integer methodsFor: 'private' stamp: 'StephaneDucasse 2/12/2012 14:57'! montgomeryTimes: a modulo: m mInvModB: mInv "Answer the result of a Montgomery multiplication self * a * (256 raisedTo: m digitLength) inv \\ m NOTE: it is assumed that: self digitLength <= m digitLength a digitLength <= m digitLength mInv * m \\ 256 = (-1 \\ 256) = 255 (this implies m odd) Answer nil in case of absent plugin or other failure." ^nil! ! !Integer methodsFor: 'truncation and round off' stamp: 'lr 11/4/2003 12:14'! atRandom "Answer a random integer from 1 to self. This implementation uses a shared generator. Heavy users should their own implementation or use Interval>atRandom: directly." self = 0 ifTrue: [ ^0 ]. self < 0 ifTrue: [ ^self negated atRandom negated ]. ^Collection mutexForPicking critical: [ self atRandom: Collection randomForPicking ]! ! !Integer methodsFor: 'comparing' stamp: 'nice 1/4/2009 17:35'! >= aNumber aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [self negative ifTrue: [^(self digitCompare: aNumber) <= 0] ifFalse: [^(self digitCompare: aNumber) >= 0]] ifFalse: [^ aNumber negative]]. ^ aNumber adaptToInteger: self andCompare: #>=! ! !Integer methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! metacelloVersionComponentLessThan: aMetacelloVersonComponent ^aMetacelloVersonComponent metacelloIntegerLessThanSelf: self! ! !Integer methodsFor: '*Keymapping-KeyCombinations' stamp: 'CamilloBruni 3/18/2011 23:14'! shift ^ KMModifier shift + self! ! !Integer methodsFor: 'truncation and round off' stamp: ''! normalize "SmallInts OK; LgInts override" ^ self! ! !Integer methodsFor: 'converting' stamp: 'brp 5/13/2003 10:12'! asYear ^ Year year: self ! ! !Integer methodsFor: 'bit manipulation' stamp: 'nice 3/21/2008 21:47'! bitAt: anInteger "Answer 1 if the bit at position anInteger is set to 1, 0 otherwise. self is considered an infinite sequence of bits, so anInteger can be any strictly positive integer. Bit at position 1 is the least significant bit. Negative numbers are in two-complements. This is a naive implementation that can be refined in subclass for speed" ^(self bitShift: 1 - anInteger) bitAnd: 1! ! !Integer methodsFor: 'arithmetic' stamp: ''! alignedTo: anInteger "Answer the smallest number not less than receiver that is a multiple of anInteger." ^(self+anInteger-1//anInteger)*anInteger "5 alignedTo: 2" "12 alignedTo: 3"! ! !Integer methodsFor: 'benchmarks' stamp: 'di 4/11/1999 11:20'! benchmark "Handy bytecode-heavy benchmark" "(500000 // time to run) = approx bytecodes per second" "5000000 // (Time millisecondsToRun: [10 benchmark]) * 1000" "3059000 on a Mac 8100/100" | size flags prime k count | size := 8190. 1 to: self do: [:iter | count := 0. flags := (Array new: size) atAllPut: true. 1 to: size do: [:i | (flags at: i) ifTrue: [prime := i+1. k := i + prime. [k <= size] whileTrue: [flags at: k put: false. k := k + prime]. count := count + 1]]]. ^ count! ! !Integer methodsFor: '*Tools-Explorer' stamp: 'laza 3/17/2005 13:38'! hasContentsInExplorer ^true! ! !Integer methodsFor: 'accessing' stamp: 'CamilloBruni 10/21/2012 14:07'! decimalDigitAt: anExponent ^ self digitAt: anExponent base: 10! ! !Integer methodsFor: 'converting-arrays' stamp: 'StephaneDucasse 10/17/2009 17:15'! asByteArrayOfSize: aSize "Answer a ByteArray of aSize with my value, most-significant byte first." | answer digitPos | aSize < self digitLength ifTrue: [ self error: 'number to large for byte array' ]. answer := ByteArray new: aSize. digitPos := 1. aSize to: aSize - self digitLength + 1 by: -1 do: [ :pos | answer at: pos put: (self digitAt: digitPos). digitPos := digitPos + 1 ]. ^ answer! ! !Integer methodsFor: 'system primitives' stamp: ''! replaceFrom: start to: stop with: replacement startingAt: repStart | j | "Catches failure if LgInt replace primitive fails" j := repStart. start to: stop do: [:i | self digitAt: i put: (replacement digitAt: j). j := j+1]! ! !Integer methodsFor: 'private' stamp: ''! digitRshift: anInteger bytes: b lookfirst: a "Shift right 8*b+anInteger bits, 0<=n<8. Discard all digits beyond a, and all zeroes at or below a." | n x r f m digit count i | n := 0 - anInteger. x := 0. f := n + 8. i := a. m := 255 bitShift: 0 - f. digit := self digitAt: i. [((digit bitShift: n) bitOr: x) = 0 and: [i ~= 1]] whileTrue: [x := digit bitShift: f "Can't exceed 8 bits". i := i - 1. digit := self digitAt: i]. i <= b ifTrue: [^Integer new: 0 neg: self negative]. "All bits lost" r := Integer new: i - b neg: self negative. count := i. x := (self digitAt: b + 1) bitShift: n. b + 1 to: count do: [:j | digit := self digitAt: j + 1. r digitAt: j - b put: (((digit bitAnd: m) bitShift: f) bitOr: x) "Avoid values > 8 bits". x := digit bitShift: n]. ^r! ! !Integer methodsFor: 'bit manipulation' stamp: ''! bitInvert32 "Answer the 32-bit complement of the receiver." ^ self bitXor: 16rFFFFFFFF! ! !Integer methodsFor: 'printing-numerative' stamp: 'nice 2/15/2008 21:44'! printOn: aStream base: b nDigits: n "Append a representation of this number in base b on aStream using nDigits. self must be positive." self subclassResponsibility! ! !Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:43'! digitCompare: arg "Compare the magnitude of self with that of arg. Return a code of 1, 0, -1 for self >, = , < arg" | len arglen argDigit selfDigit | len := self digitLength. (arglen := arg digitLength) ~= len ifTrue: [arglen > len ifTrue: [^ -1] ifFalse: [^ 1]]. [len > 0] whileTrue: [(argDigit := arg digitAt: len) ~= (selfDigit := self digitAt: len) ifTrue: [argDigit < selfDigit ifTrue: [^ 1] ifFalse: [^ -1]]. len := len - 1]. ^ 0! ! !Integer methodsFor: 'arithmetic' stamp: 'nice 3/15/2014 16:24'! reciprocalModulo: n "Answer an integer x such that (self * x) \\ n = 1, x > 0, x < n. Raise an error if there is no such integer. The algorithm is a non extended euclidean modular inversion called NINV. It is described in this article: 'Using an RSA Accelerator for Modular Inversion' by Martin Seysen. See http://www.iacr.org/archive/ches2005/017.pdf" | u v f fPlusN b result result2 | ((self <= 0) or: [n <= 0]) ifTrue: [self error: 'self and n must be greater than zero']. self >= n ifTrue: [self error: 'self must be < n']. b := n highBit + 1. f := 1 bitShift: b. v := (self bitShift: b) + 1. u := n bitShift: b. fPlusN := f + n. [v >= fPlusN] whileTrue: [v := u \\ (u := v)]. result := v - f. (result2 := result + n) > 0 ifFalse: [self error: 'no inverse']. ^result positive ifTrue: [result] ifFalse: [result2]! ! !Integer methodsFor: 'private' stamp: 'nice 3/15/2014 16:25'! slidingLeftRightRaisedTo: n modulo: m "Private - compute (self raisedTo: n) \\ m, Note: this method has to be fast because it is generally used with large integers in cryptography. It thus operate on exponent bits from left to right by packets with a sliding window rather than bit by bit (see below)." | pow j k w index oddPowersOfSelf square | "Precompute powers of self for odd bit patterns xxxx1 up to length w + 1. The width w is chosen with respect to the total bit length of n, such that each bit pattern will on average be encoutered P times in the whole bit sequence of n. This costs (2 raisedTo: w) multiplications, but more will be saved later (see below)." k := n highBit. w := (k highBit - 1 >> 1 min: 16) max: 1. oddPowersOfSelf := Array new: 1 << w. oddPowersOfSelf at: 1 put: (pow := self). square := self * self \\ m. 2 to: oddPowersOfSelf size do: [:i | pow := oddPowersOfSelf at: i put: pow * square \\ m]. "Now exponentiate by searching precomputed bit patterns with a sliding window" pow := 1. [k > 0] whileTrue: [pow := pow * pow \\ m. "Skip bits set to zero (the sliding window)" (n bitAt: k) = 0 ifFalse: ["Find longest odd bit pattern up to window length (w + 1)" j := k - w max: 1. [j < k and: [(n bitAt: j) = 0]] whileTrue: [j := j + 1]. "We found an odd bit pattern of length k-j+1; perform the square powers for each bit (same cost as bitwise algorithm); compute the index of this bit pattern in the precomputed powers." index := 0. [k > j] whileTrue: [pow := pow * pow \\ m. index := index << 1 + (n bitAt: k). k := k - 1]. "Perform a single multiplication for the whole bit pattern. This saves up to (k-j) multiplications versus a naive algorithm operating bit by bit" pow := pow * (oddPowersOfSelf at: index + 1) \\ m]. k := k - 1]. ^pow normalize! ! !Integer methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 5/31/2011 18:26'! command ^ KMModifier command + self! ! !Integer methodsFor: 'converting-arrays' stamp: 'PeterHugossonMiller 9/3/2009 10:01'! asByteArray | stream | stream := ByteArray new writeStream. self digitLength to: 1 by: -1 do: [:digitIndex | stream nextPut: (self digitAt: digitIndex)]. ^ stream contents ! ! !Integer methodsFor: '*metacello-core' stamp: 'dkh 6/21/2012 20:47'! metacelloSemanticVersionComponentLessThan: aMetacelloVersonComponent ^ aMetacelloVersonComponent metacelloSemanticIntegerLessThanSelf: self! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 6/9/2000 10:09'! bitShift: shiftCount "Answer an Integer whose value (in twos-complement representation) is the receiver's value (in twos-complement representation) shifted left by the number of bits indicated by the argument. Negative arguments shift right. Zeros are shifted in from the right in left shifts." | magnitudeShift | magnitudeShift := self bitShiftMagnitude: shiftCount. ^ ((self negative and: [shiftCount negative]) and: [self anyBitOfMagnitudeFrom: 1 to: shiftCount negated]) ifTrue: [magnitudeShift - 1] ifFalse: [magnitudeShift]! ! !Integer methodsFor: 'printing' stamp: 'tk 4/1/2002 11:30'! asWords "SmallInteger maxVal asWords" | mils minus three num answer milCount | self = 0 ifTrue: [^'zero']. mils := #('' ' thousand' ' million' ' billion' ' trillion' ' quadrillion' ' quintillion' ' sextillion' ' septillion' ' octillion' ' nonillion' ' decillion' ' undecillion' ' duodecillion' ' tredecillion' ' quattuordecillion' ' quindecillion' ' sexdecillion' ' septendecillion' ' octodecillion' ' novemdecillion' ' vigintillion'). num := self. minus := ''. self < 0 ifTrue: [ minus := 'negative '. num := num negated. ]. answer := String new. milCount := 1. [num > 0] whileTrue: [ three := (num \\ 1000) threeDigitName. num := num // 1000. three isEmpty ifFalse: [ answer isEmpty ifFalse: [ answer := ', ',answer ]. answer := three,(mils at: milCount),answer. ]. milCount := milCount + 1. ]. ^minus,answer! ! !Integer methodsFor: 'testing' stamp: 'StephaneDucasse 11/1/2009 22:37'! isMostLikelyPrime "See isProbablyPrimeWithK:andQ: for the algoritm description." | k q | self <= 1 ifTrue: [^self error: 'operation undefined']. self even ifTrue: [^self = 2]. k := 1. q := self - 1 bitShift: -1. [q odd] whileFalse: [q := q bitShift: -1. k := k + 1]. 25 timesRepeat: [(self isProbablyPrimeWithK: k andQ: q) ifFalse: [^false]]. ^true! ! !Integer methodsFor: 'arithmetic' stamp: 'nice 3/11/2013 08:12'! + aNumber "Refer to the comment in Number + " aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [^ (self digitAdd: aNumber) normalize] ifFalse: [^ self digitSubtract: aNumber]]. aNumber isFraction ifTrue: [^Fraction numerator: self * aNumber denominator + aNumber numerator denominator: aNumber denominator]. ^ aNumber adaptToInteger: self andSend: #+! ! !Integer methodsFor: 'bit manipulation' stamp: 'adrian-lienhard 5/18/2009 20:35'! << shiftAmount "left shift" shiftAmount < 0 ifTrue: [self error: 'negative arg']. ^ self bitShift: shiftAmount! ! !Integer methodsFor: 'converting' stamp: ''! asInteger "Answer with the receiver itself." ^self ! ! !Integer methodsFor: '*FileSystem-Core' stamp: 'CamilloBruni 7/10/2012 22:12'! humanReadableSIByteSize ^ String streamContents: [ :s| self humanReadableSIByteSizeOn: s ]! ! !Integer methodsFor: 'mathematical functions' stamp: 'nice 3/11/2014 01:55'! nthRootRounded: aPositiveInteger "Answer the integer nearest the nth root of the receiver." | guess | self = 0 ifTrue: [^0]. self negative ifTrue: [aPositiveInteger even ifTrue: [ ArithmeticError signal: 'Negative numbers don''t have even roots.' ]. ^(self negated nthRootRounded: aPositiveInteger) negated]. guess := self nthRootTruncated: aPositiveInteger. ^self * 2 > ((guess + 1 raisedTo: aPositiveInteger) + (guess raisedTo: aPositiveInteger)) ifTrue: [guess + 1] ifFalse: [guess]! ! !Integer methodsFor: 'printing' stamp: 'nice 2/15/2008 21:49'! printString "For Integer, prefer the stream version to the string version for efficiency" ^String streamContents: [:str | self printOn: str base: 10]! ! !Integer methodsFor: 'testing' stamp: 'StephaneDucasse 2/4/2012 16:58'! isPrime "Answer true if the receiver is a prime number. See isProbablyPrime for a probabilistic implementation that is much faster for large integers, and that is correct to an extremely high statistical level of confidence (effectively deterministic)." self <= 1 ifTrue: [ ^false ]. self even ifTrue: [ ^self = 2]. 3 to: self sqrtFloor by: 2 do: [ :each | self \\ each = 0 ifTrue: [ ^false ] ]. ^true! ! !Integer methodsFor: 'printing' stamp: 'nice 2/15/2008 21:49'! printOn: aStream ^self printOn: aStream base: 10! ! !Integer methodsFor: 'bit manipulation' stamp: 'StephaneDucasse 2/19/2010 15:14'! bitAt: anInteger put: value "Answer a new Integer that has the bit of rank anInteger set to value. The bit value should be 0 or 1, otherwise raise an Error. The bits are indexed starting at 1 for the least significant bit. For negative integers, operate on 2-complement representation." | b | b := self bitAt: anInteger. b = value ifTrue: [^self]. 0 = value ifTrue: [^self bitAnd: (1 bitShift: anInteger - 1) bitInvert]. 1 = value ifTrue: [^self bitOr: (1 bitShift: anInteger - 1)]. self error: 'bit value should be 0 or 1'! ! !Integer methodsFor: 'converting' stamp: 'nice 2/13/2010 22:46'! asScaledDecimal "The number of significant digits of the answer is the same as the number of decimal digits in the receiver." ^ ScaledDecimal newFromNumber: self scale: 0! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 13:52'! printPaddedWith: aCharacter to: anInteger base: aRadix "Answer the string containing the ASCII representation of the receiver padded on the left with aCharacter to be at least anInteger characters." | aStream padding digits | aStream := (String new: 10) writeStream. self printOn: aStream base: aRadix showRadix: false. digits := aStream contents. padding := anInteger - digits size. padding > 0 ifFalse: [^ digits]. ^ ((String new: padding) atAllPut: aCharacter; yourself) , digits! ! !Integer methodsFor: 'printing-numerative' stamp: 'StephaneDucasse 7/31/2010 19:45'! printStringHex "returns the hex digit part of the integer when printed in hexadecimal format. 30 printStringHex '1E' 30 hex '16r1E' " ^self printStringBase: 16! ! !Integer methodsFor: 'printing-numerative' stamp: 'CamilloBruni 10/21/2012 14:47'! storeStringBase: base length: minimum padded: zeroFlag ^String streamContents: [:s| self storeOn: s base: base length: minimum padded: zeroFlag ]! ! !Integer methodsFor: 'printing-numerative' stamp: 'PeterHugossonMiller 9/3/2009 10:01'! printStringRoman | stream integer | stream := String new writeStream. integer := self negative ifTrue: [stream nextPut: $-. self negated] ifFalse: [self]. integer // 1000 timesRepeat: [stream nextPut: $M]. integer romanDigits: 'MDC' for: 100 on: stream; romanDigits: 'CLX' for: 10 on: stream; romanDigits: 'XVI' for: 1 on: stream. ^stream contents! ! !Integer methodsFor: 'accessing' stamp: 'CamilloBruni 10/21/2012 14:24'! decimalDigitLength ^ self numberOfDigitsInBase: 10! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 13:59'! printWithCommasOn: aStream "123456789 asStringWithCommas" "-123456789 asStringWithCommas" ^ self printSeparatedBy: $, every: 3 signed: false on: aStream! ! !Integer methodsFor: 'bit manipulation' stamp: 'CamilloBruni 3/27/2012 17:18'! | aNumber ^ self bitOr: aNumber! ! !Integer methodsFor: 'truncation and round off' stamp: 'HenrikSperreJohansen 1/19/2012 11:41'! asLargerPowerOfTwo "Convert the receiver into a power of two which is not less than the receiver" ^self isPowerOfTwo ifTrue:[self] ifFalse:[self > 0 ifTrue: [ 1 bitShift: (self highBit)] ifFalse: [DomainError signal: 'Value outside (0 , infinity)' from: 0]]! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 13:51'! printStringRadix: baseInteger "Return a string containing a sequence of characters that represents the numeric value of the receiver in the radix specified by the argument. If the receiver is negative, a minus sign ('-') is prepended to the sequence of characters. The result is undefined if baseInteger less than 2 or greater than 36." | tempString | baseInteger = 10 ifTrue: [ tempString := self storeStringBase: baseInteger. self negative ifTrue: [^ '-10r' , (tempString copyFrom: 2 to: tempString size)] ifFalse: [^ '10r' , tempString]]. ^ self storeStringBase: baseInteger! ! !Integer methodsFor: 'mathematical functions' stamp: 'nice 10/29/2011 15:00'! sqrt "Answer the square root of the receiver." | selfAsFloat floatResult guess | selfAsFloat := self asFloat. floatResult := selfAsFloat sqrt. floatResult isInfinite ifFalse: [ guess := floatResult truncated. "If got an exact answer, answer it. Otherwise answer float approximate answer." guess squared = self ifTrue: [ ^ guess ]]. "In this case, maybe it failed because we are such a big integer that the Float method becomes inexact, even if we are a whole square number. So, try the slower but more general method" selfAsFloat >= Float maxExactInteger asFloat squared ifTrue: [ guess := self sqrtFloor. guess squared = self ifTrue: [ ^guess ]. "Nothing else can be done. No exact answer means answer must be a Float. Answer the best we have which is the rounded sqrt." guess := (self * 4) sqrtFloor. ^(guess // 2 + (guess \\ 2)) asFloat]. "We need an approximate result" ^floatResult! ! !Integer methodsFor: 'bit manipulation' stamp: ''! anyMask: mask "Treat the argument as a bit mask. Answer whether any of the bits that are 1 in the argument are 1 in the receiver." ^0 ~= (self bitAnd: mask)! ! !Integer methodsFor: 'printing' stamp: ''! isLiteral ^true! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 6/9/2000 14:02'! bitShiftMagnitude: shiftCount "Answer an Integer whose value (in magnitude representation) is the receiver's value (in magnitude representation) shifted left by the number of bits indicated by the argument. Negative arguments shift right. Zeros are shifted in from the right in left shifts." | rShift | shiftCount >= 0 ifTrue: [^ self digitLshift: shiftCount]. rShift := 0 - shiftCount. ^ (self digitRshift: (rShift bitAnd: 7) bytes: (rShift bitShift: -3) lookfirst: self digitLength) normalize! ! !Integer methodsFor: '*Files' stamp: 'cmm 2/15/2010 15:52'! asBytesDescription "Answer a terse, easily-readable representation of this Integer reprsenting a number of bytes. Useful for file-browsers." | suffixes | suffixes := { 'k'"ilobytes". 'M'"egabytes". 'G'"igabytes". 'T'"erabytes". 'P'"etabytes". 'E'"xabytes". 'Z'"ettabytes". 'Y'"ottabytes"}. suffixes size to: 1 by: -1 do: [ : index | | units | units := 1000 raisedTo: index. self > units ifTrue: [ ^ ((self / units) asFloat roundTo: 0.01) asString, (suffixes at: index) ] ]. ^ self asString! ! !Integer methodsFor: 'accessing' stamp: 'CamilloBruni 10/21/2012 14:30'! digitAt: anExponent base: base ^ self // (base raisedToInteger: anExponent - 1) \\ base! ! !Integer methodsFor: 'benchmarks' stamp: 'adrian-lienhard 5/18/2009 20:33'! tinyBenchmarks "Report the results of running the two tiny Squeak benchmarks. ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results" "0 tinyBenchmarks" "On a 292 MHz G3 Mac: 22727272 bytecodes/sec; 984169 sends/sec" "On a 400 MHz PII/Win98: 18028169 bytecodes/sec; 1081272 sends/sec" | t1 t2 r n1 n2 | n1 := 1. [t1 := Time millisecondsToRun: [n1 benchmark]. t1 < 1000] whileTrue:[n1 := n1 * 2]. "Note: #benchmark's runtime is about O(n)" n2 := 28. [t2 := Time millisecondsToRun: [r := n2 benchFib]. t2 < 1000] whileTrue:[n2 := n2 + 1]. "Note: #benchFib's runtime is about O(n^2)." ^ ((n1 * 500000 * 1000) // t1) printString, ' bytecodes/sec; ', ((r * 1000) // t2) printString, ' sends/sec'! ! !Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:14'! destinationBuffer:digitLength digitLength <= 1 ifTrue: [self] ifFalse: [LargePositiveInteger new: digitLength].! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 01:55'! highBitOfMagnitude "Answer the index of the high order bit of the magnitude of the receiver, or zero if the receiver is zero." ^ self subclassResponsibility! ! !Integer methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 3/19/2013 20:28'! asKeyCombination ^ KMSingleKeyCombination from: self asCharacter! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 13:36'! storeOn: aStream base: base "Print a representation of the receiver on the stream in base where 2 <= <= 16. If is other than 10 it is written first separated by $r followed by the number like for example: 16rFCE2" | integer | integer := self negative ifTrue: [aStream nextPut: $-. self negated] ifFalse: [self]. base = 10 ifFalse: [aStream nextPutAll: base printString; nextPut: $r]. aStream nextPutAll: (integer printStringBase: base). ! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 13:50'! asStringWithCommasSigned "123456789 asStringWithCommasSigned" "-123456789 asStringWithCommasSigned" ^ String streamContents: [:stream | self printWithCommasSignedOn: stream ]! ! !Integer methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:41'! = aNumber aNumber isNumber ifFalse: [^ false]. aNumber isInteger ifTrue: [aNumber negative == self negative ifTrue: [^ (self digitCompare: aNumber) = 0] ifFalse: [^ false]]. ^ aNumber adaptToInteger: self andCompare: #=! ! !Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:16'! digitBuffer:digitLength ^Array new:digitLength*8.! ! !Integer methodsFor: 'private' stamp: 'StephaneDucasse 2/12/2012 14:57'! montgomeryRaisedTo: n times: y modulo: m mInvModB: mInv "Private - do a Montgomery exponentiation of self modulo m. The operation is equivalent to (self/y raisedTo: n)*y \\ m, with y is (256 raisedTo: m digitLength), with (m bitAnd: 255) * mInv \\ 256 = 255." | pow j k w index oddPowersOfSelf square | "Precompute powers of self for odd bit patterns xxxx1 up to length w + 1. The width w is chosen with respect to the total bit length of n, such that each bit pattern will on average be encoutered P times in the whole bit sequence of n. This costs (2 raisedTo: w) multiplications, but more will be saved later (see below)." k := n highBit. w := (k highBit - 1 >> 1 min: 16) max: 1. oddPowersOfSelf := Array new: 1 << w. oddPowersOfSelf at: 1 put: (pow := self). square := self montgomeryTimes: self modulo: m mInvModB: mInv. 2 to: oddPowersOfSelf size do: [:i | pow := oddPowersOfSelf at: i put: (pow montgomeryTimes: square modulo: m mInvModB: mInv)]. "Now exponentiate by searching precomputed bit patterns with a sliding window" pow := y. [k > 0] whileTrue: [pow := pow montgomeryTimes: pow modulo: m mInvModB: mInv. "Skip bits set to zero (the sliding window)" (n bitAt: k) = 0 ifFalse: ["Find longest odd bit pattern up to window length (w + 1)" j := k - w max: 1. [j < k and: [(n bitAt: j) = 0]] whileTrue: [j := j + 1]. "We found a bit pattern of length k-j+1; perform the square powers for each bit (same cost as bitwise algorithm); compute the index of this bit pattern in the precomputed powers." index := 0. [k > j] whileTrue: [pow := pow montgomeryTimes: pow modulo: m mInvModB: mInv. index := index << 1 + (n bitAt: k). k := k - 1]. "Perform a single multiplication for the whole bit pattern. This saves up to (k-j) multiplications versus a naive algorithm operating bit by bit" pow := pow montgomeryTimes: (oddPowersOfSelf at: index + 1) modulo: m mInvModB: mInv]. k := k - 1]. ^pow! ! !Integer methodsFor: 'bit manipulation' stamp: ''! noMask: mask "Treat the argument as a bit mask. Answer whether none of the bits that are 1 in the argument are 1 in the receiver." ^0 = (self bitAnd: mask)! ! !Integer methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 3/5/2014 22:15'! printSeparatedBy: aDelimiter every: offset signed: printSigned base: base on: aStream | digits | digits := self abs printStringBase: base. self sign = -1 ifTrue: [ aStream nextPut: $- ] ifFalse: [ printSigned ifTrue: [ aStream nextPut: $+ ] ]. 1 to: digits size do: [ :i | aStream nextPut: (digits at: i). (i < digits size and: [ (i - digits size) \\ offset = 0 ]) ifTrue: [ aStream nextPut: aDelimiter ] ]! ! !Integer methodsFor: '*FileSystem-Core' stamp: 'CamilloBruni 7/10/2012 22:26'! humanReadableSIByteSizeOn: s | exponent base | "Print a string with an SI binary unit represation of myself." base := 1000. self < base ifTrue: [ ^ s print: self; space; nextPut: $B ]. exponent := (self log / base log) asInteger. (self / (base ** exponent)) printOn: s showingDecimalPlaces: 2. s space; nextPut: ('kMGTPE' at: exponent); nextPut: $B.! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asDoubleWord ^ self asTwosComplement: 16rFFFFFFFF! ! !Integer methodsFor: 'private' stamp: 'sr 6/8/2000 01:30'! digitLshift: shiftCount | carry rShift mask len result digit byteShift bitShift highBit | (highBit := self highBitOfMagnitude) = 0 ifTrue: [^ 0]. len := highBit + shiftCount + 7 // 8. result := Integer new: len neg: self negative. byteShift := shiftCount // 8. bitShift := shiftCount \\ 8. bitShift = 0 ifTrue: ["Fast version for byte-aligned shifts" ^ result replaceFrom: byteShift + 1 to: len with: self startingAt: 1]. carry := 0. rShift := bitShift - 8. mask := 255 bitShift: 0 - bitShift. 1 to: byteShift do: [:i | result digitAt: i put: 0]. 1 to: len - byteShift do: [:i | digit := self digitAt: i. result digitAt: i + byteShift put: (((digit bitAnd: mask) bitShift: bitShift) bitOr: carry). carry := digit bitShift: rShift]. ^ result! ! !Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'! * aNumber "Refer to the comment in Number * " aNumber isInteger ifTrue: [^ self digitMultiply: aNumber neg: self negative ~~ aNumber negative]. ^ aNumber adaptToInteger: self andSend: #*! ! !Integer methodsFor: 'bit manipulation' stamp: ''! allMask: mask "Treat the argument as a bit mask. Answer whether all of the bits that are 1 in the argument are 1 in the receiver." ^mask = (self bitAnd: mask)! ! !Integer methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:26'! lastDigit "Answer the last digit of the integer base 256. LargePositiveInteger uses bytes of base two number, and each is a 'digit'." ^self digitAt: self digitLength! ! !Integer methodsFor: 'mathematical functions' stamp: 'StephaneDucasse 2/12/2012 14:56'! raisedTo: n modulo: m "Answer the modular exponential. Note: this implementation is optimized for case of large integers raised to large powers." | a s mInv | n = 0 ifTrue: [^1]. (self >= m or: [self < 0]) ifTrue: [^self \\ m raisedTo: n modulo: m]. n < 0 ifTrue: [^(self reciprocalModulo: m) raisedTo: n negated modulo: m]. (n < 4096 or: [m even]) ifTrue: ["Overhead of Montgomery method might cost more than naive divisions, use naive" ^self slidingLeftRightRaisedTo: n modulo: m]. mInv := 256 - ((m bitAnd: 255) reciprocalModulo: 256). "Initialize the result to R=256 raisedTo: m digitLength" a := (1 bitShift: m digitLength*8) \\ m. "Montgomerize self (multiply by R)" (s := self montgomeryTimes: (a*a \\ m) modulo: m mInvModB: mInv) ifNil: ["No Montgomery primitive available ? fallback to naive divisions" ^self slidingLeftRightRaisedTo: n modulo: m]. "Exponentiate self*R" a := s montgomeryRaisedTo: n times: a modulo: m mInvModB: mInv. "Demontgomerize the result (divide by R)" ^a montgomeryTimes: 1 modulo: m mInvModB: mInv! ! !Integer methodsFor: 'comparing' stamp: 'nice 1/4/2009 17:35'! <= aNumber aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [self negative ifTrue: [^ (self digitCompare: aNumber) >= 0] ifFalse: [^ (self digitCompare: aNumber) <= 0]] ifFalse: [^ self negative]]. ^ aNumber adaptToInteger: self andCompare: #<=! ! !Integer methodsFor: 'bit manipulation' stamp: 'di 4/30/1998 10:32'! bitClear: aMask "Answer an Integer equal to the receiver, except with all bits cleared that are set in aMask." ^ (self bitOr: aMask) - aMask! ! !Integer methodsFor: 'testing' stamp: 'HenrikSperreJohansen 1/18/2012 12:51'! isPowerOfTwo "Return true if the receiver is an integral power of two." ^ self ~= 0 and: [(self bitAnd: self-1) = 0]! ! !Integer methodsFor: 'truncation and round off' stamp: 'HenrikSperreJohansen 1/19/2012 11:39'! asSmallerPowerOfTwo "Convert the receiver into a power of two which is not larger than the receiver" ^self isPowerOfTwo ifTrue:[self] ifFalse:[self > 0 ifTrue: [ 1 bitShift: (self highBit - 1)] ifFalse: [DomainError signal: 'Value outside (0 , infinity)' from: 0]]! ! !Integer methodsFor: 'printing' stamp: 'stephane.ducasse 4/13/2009 14:15'! numberOfDigits "Return how many digits are necessary to print this number in base 10. This does not count any place for minus sign, radix prefix or whatever." ^ self numberOfDigitsInBase: 10 ! ! !Integer methodsFor: '*Kernel-Chronology' stamp: 'CamilloBruni 6/22/2012 21:42'! asSeconds ^ Duration seconds: self! ! !Integer methodsFor: 'truncation and round off' stamp: ''! ceiling "Refer to the comment in Number|ceiling."! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:14'! printStringBase: base length: minimum padded: zeroFlag ^String streamContents: [:s| self printOn: s base: base length: minimum padded: zeroFlag]! ! !Integer methodsFor: 'mathematical functions' stamp: 'CamilloBruni 7/13/2012 17:45'! take: kk "Return the number of combinations of (self) elements taken kk at a time. For 6 take 3, this is 6*5*4 / (1*2*3). Zero outside of Pascal's triangle. Use a trick to go faster." " 6 take: 3 " | num denom | kk < 0 ifTrue: [^ 0]. kk > self ifTrue: [^ 0]. num := 1. self to: (kk max: self-kk) + 1 by: -1 do: [:factor | num := num * factor]. denom := 1. 1 to: (kk min: self-kk) do: [:factor | denom := denom * factor]. ^ num // denom! ! !Integer methodsFor: '*Tools-Explorer' stamp: 'laza 3/17/2005 13:37'! explorerContents ^{ 'hexadecimal' -> 16. 'octal' -> 8. 'binary' -> 2 } collect: [:each | ObjectExplorerWrapper with: each key translated name: (self printStringBase: each value) model: self]! ! !Integer methodsFor: 'accessing' stamp: 'nice 9/7/2011 21:47'! denominator "Let an Integer be polymorphic to a Fraction. See #isFraction." ^1! ! !Integer methodsFor: 'truncation and round off' stamp: 'sma 5/12/2000 12:35'! atRandom: aGenerator "Answer a random integer from 1 to self picked from aGenerator." ^ aGenerator nextInt: self! ! !Integer methodsFor: 'converting' stamp: 'nice 9/7/2011 22:03'! adaptToFraction: rcvr andSend: selector "If I am involved in arithmetic with a Fraction, convert me to a Fraction." ^ rcvr perform: selector with: (Fraction numerator: self denominator: 1)! ! !Integer methodsFor: 'filter streaming' stamp: 'MarcusDenker 7/15/2012 15:47'! putOn: aStream (aStream isBinary ifTrue: [ self asByteArray ] ifFalse: [ self asString]) putOn: aStream ! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asImm16 "Convert integer value into a signed immediate word operand " ^ AJImmediate new ivalue: self; size: 2! ! !Integer methodsFor: 'converting' stamp: 'CamilloBruni 10/21/2012 14:09'! asCharacterDigit "Answer the Character whose string representation is the receiver." ^Character digitValue: self! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 14:04'! asStringWithCommas "123456789 asStringWithCommas" "-123456789 asStringWithCommas" ^ String streamContents: [:stream | self printWithCommasOn: stream ]! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asByte ^ self asTwosComplement: 16rFF! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asTwosComplement: mask "return the two's completemented cropped version. Example for a byte value: -5 asTwosComplement: 16rFF " | bound | bound := (mask + 1). self * 2 >= bound ifTrue: [Error signal: self printString , ' too big for signed ', mask highBit printString, 'bit value']. (self >= 0) ifTrue: [ ^ self bitAnd: mask ]. self * 2 < bound negated ifTrue: [Error signal: self printString , ' too small for signed ', mask highBit printString, 'bit value']. ^ (self + mask + 1) bitAnd: mask! ! !Integer methodsFor: '*AsmJit-Extension' stamp: 'CamilloBruni 5/14/2012 17:18'! bin "Print the receiver as hex, prefixed with 2r." ^self storeStringBase: 2! ! !Integer methodsFor: '*metacello-core' stamp: 'dkh 6/21/2012 20:44'! metacelloSemanticIntegerLessThanSelf: anInteger ^ anInteger < self! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asUImm16 "Convert integer value into an unsigned immediate operand" ^ AJImmediate new uvalue: self; size: 2! ! !Integer methodsFor: 'bit manipulation' stamp: 'IgorStasenko 12/28/2012 15:10'! & aNumber ^ self bitAnd: aNumber! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 13:52'! printOn: outputStream base: baseInteger showRadix: flagBoolean "Write a sequence of characters that describes the receiver in radix baseInteger with optional radix specifier. The result is undefined if baseInteger less than 2 or greater than 36." | tempString startPos | tempString := self printStringRadix: baseInteger. flagBoolean ifTrue: [ ^ outputStream nextPutAll: tempString ]. startPos := (tempString indexOf: $r ifAbsent: [ self error: 'radix indicator not found.' ]) + 1. self negative ifTrue: [ outputStream nextPut: $-] . outputStream nextPutAll: (tempString copyFrom: startPos to: tempString size)! ! !Integer methodsFor: 'mathematical functions' stamp: 'nice 10/19/2011 20:21'! nthRootTruncated: aPositiveInteger "Answer the integer part of the nth root of the receiver." | guess guessToTheNthMinusOne delta | self = 0 ifTrue: [^0]. self negative ifTrue: [aPositiveInteger even ifTrue: [ ArithmeticError signal: 'Negative numbers don''t have even roots.' ]. ^(self negated nthRootTruncated: aPositiveInteger) negated]. guess := 1 bitShift: self highBitOfMagnitude + aPositiveInteger - 1 // aPositiveInteger. [ guessToTheNthMinusOne := guess raisedTo: aPositiveInteger - 1. delta := (guess * guessToTheNthMinusOne - self) // (guessToTheNthMinusOne * aPositiveInteger). delta = 0 ] whileFalse: [ guess := guess - delta ]. ( (guess := guess - 1) raisedTo: aPositiveInteger) > self ifTrue: [ guess := guess - 1 ]. ^guess! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! printAsOperandOn: aStream aStream print: self.! ! !Integer methodsFor: 'converting' stamp: 'nice 9/7/2011 22:21'! asFraction "Answer a Fraction that represents the value of the receiver. Since an Integer already behaves as a special kind of Fraction, no conversion is required, see #isFraction." ^self! ! !Integer methodsFor: 'converting' stamp: 'ar 4/9/2005 22:31'! asCharacter "Answer the Character whose value is the receiver." ^Character value: self! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'! bitAnd: n "Answer an Integer whose bits are the logical AND of the receiver's bits and those of the argument, n." | norm | norm := n normalize. ^ self digitLogic: norm op: #bitAnd: length: (self digitLength max: norm digitLength)! ! !Integer methodsFor: 'private' stamp: 'laza 3/29/2004 18:16'! print: positiveNumberString on: aStream prefix: prefix length: minimum padded: zeroFlag | padLength | padLength := minimum - positiveNumberString size - prefix size. padLength > 0 ifTrue: [zeroFlag ifTrue: [aStream nextPutAll: prefix; nextPutAll: (String new: padLength withAll: $0)] ifFalse: [aStream nextPutAll: (String new: padLength withAll: Character space); nextPutAll: prefix]] ifFalse: [aStream nextPutAll: prefix]. aStream nextPutAll: positiveNumberString ! ! !Integer methodsFor: 'truncation and round off' stamp: 'ar 6/9/2000 18:56'! asPowerOfTwo "Convert the receiver into a power of two" ^self asSmallerPowerOfTwo! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asImm8 "Convert integer value into a signed immediate operand" ^ AJImmediate new ivalue: self; size: 1! ! !Integer methodsFor: 'private' stamp: 'nice 1/26/2008 02:12'! digitLogic: arg op: op length: len | i result neg1 neg2 rneg z1 z2 rz b1 b2 b | neg1 := self negative. neg2 := arg negative. rneg := ((neg1 ifTrue: [-1] ifFalse: [0]) perform: op with: (neg2 ifTrue: [-1] ifFalse: [0])) < 0. result := Integer new: len neg: rneg. rz := z1 := z2 := true. i := 0. [(i := i + 1) <= len or: ["mind a carry on result that might go past len digits" rneg and: [rz and: [result := result growby: 1. true]]]] whileTrue: [b1 := self digitAt: i. neg1 ifTrue: [b1 := z1 ifTrue: [b1 = 0 ifTrue: [0] ifFalse: [z1 := false. 256 - b1]] ifFalse: [255 - b1]]. b2 := arg digitAt: i. neg2 ifTrue: [b2 := z2 ifTrue: [b2 = 0 ifTrue: [0] ifFalse: [z2 := false. 256 - b2]] ifFalse: [255 - b2]]. b := b1 perform: op with: b2. result digitAt: i put: (rneg ifTrue: [rz ifTrue: [b = 0 ifTrue: [0] ifFalse: [rz := false. 256 - b]] ifFalse: [255 - b]] ifFalse: [b])]. ^ result normalize! ! !Integer methodsFor: 'mathematical functions' stamp: 'LC 6/17/1998 19:22'! gcd: anInteger "See Knuth, Vol 2, 4.5.2, Algorithm L" "Initialize" | higher u v k uHat vHat a b c d vPrime vPrimePrime q t | higher := SmallInteger maxVal highBit. u := self abs max: (v := anInteger abs). v := self abs min: v. [v class == SmallInteger] whileFalse: [(uHat := u bitShift: (k := higher - u highBit)) class == SmallInteger ifFalse: [k := k - 1. uHat := uHat bitShift: -1]. vHat := v bitShift: k. a := 1. b := 0. c := 0. d := 1. "Test quotient" [(vPrime := vHat + d) ~= 0 and: [(vPrimePrime := vHat + c) ~= 0 and: [(q := uHat + a // vPrimePrime) = (uHat + b // vPrime)]]] whileTrue: ["Emulate Euclid" c := a - (q * (a := c)). d := b - (q * (b := d)). vHat := uHat - (q * (uHat := vHat))]. "Multiprecision step" b = 0 ifTrue: [v := u rem: (u := v)] ifFalse: [t := u * a + (v * b). v := u * c + (v * d). u := t]]. ^ v gcd: u! ! !Integer methodsFor: 'testing' stamp: ''! isInteger "True for all subclasses of Integer." ^ true! ! !Integer methodsFor: 'bit manipulation' stamp: 'jm 2/19/98 12:11'! lowBit "Answer the index of the low order bit of this number." | index | self = 0 ifTrue: [ ^ 0 ]. index := 1. [ (self digitAt: index) = 0 ] whileTrue: [ index := index + 1 ]. ^ (self digitAt: index) lowBit + (8 * (index - 1))! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:21'! printStringLength: minimal ^self printStringLength: minimal padded: false ! ! !Integer methodsFor: 'testing' stamp: 'nice 9/7/2011 22:20'! isFraction "Each Integer is considered as a special kind of Fraction with self as numerator and a unit denominator. Rationale: A Fraction with a unit denominator will be automatically reduced to an Integer. Hence Integer has to be polymorphic to Fraction." ^true! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asUImm8 "Convert integer value into an unsigned immediate operand" ^ AJImmediate new uvalue: self; size: 1! ! !Integer methodsFor: '*Keymapping-KeyCombinations' stamp: 'CamilloBruni 3/18/2011 23:14'! ctrl ^ KMModifier ctrl + self! ! !Integer methodsFor: 'private' stamp: ''! growby: n ^self growto: self digitLength + n! ! !Integer methodsFor: 'mathematical functions' stamp: 'es 5/25/2005 11:04'! raisedToInteger: exp modulo: m (exp = 0) ifTrue: [^ 1]. exp even ifTrue: [^ (self raisedToInteger: (exp // 2) modulo: m) squared \\ m] ifFalse: [^ (self * (self raisedToInteger: (exp - 1) modulo: m)) \\ m].! ! !Integer methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 18:09'! primeFactors "Return all primeFactors of myself" "( 106260 primeFactors fold: [ :a :b | a * b ]) = 106260" ^ Array streamContents: [ :s | self primeFactorsOn: s ]! ! !Integer methodsFor: 'truncation and round off' stamp: ''! rounded "Refer to the comment in Number|rounded."! ! !Integer methodsFor: 'arithmetic' stamp: 'nice 1/9/2013 01:35'! / aNumber "Refer to the comment in Number / " | quoRem | aNumber isInteger ifTrue: [quoRem := self digitDiv: aNumber neg: self negative ~~ aNumber negative. (quoRem at: 2) = 0 ifTrue: [^ (quoRem at: 1) normalize] ifFalse: [^ (Fraction numerator: self denominator: aNumber) reduced]]. ^ aNumber adaptToInteger: self andSend: #/! ! !Integer methodsFor: '*metacello-core' stamp: 'dkh 6/21/2012 20:44'! metacelloSemanticStringLessThanSelf: aString "string version components are always '<' integer component" ^ true! ! !Integer methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! metacelloStringLessThanSelf: aString "string version components are always '<' integer component" ^true! ! !Integer methodsFor: 'private' stamp: 'sma 5/20/2000 17:00'! romanDigits: digits for: base on: aStream | n | n := self \\ (base * 10) // base. n = 9 ifTrue: [^ aStream nextPut: digits last; nextPut: digits first]. n = 4 ifTrue: [^ aStream nextPut: digits last; nextPut: digits second]. n > 4 ifTrue: [aStream nextPut: digits second]. n \\ 5 timesRepeat: [aStream nextPut: digits last]! ! !Integer methodsFor: 'arithmetic' stamp: 'nice 1/9/2013 01:35'! quo: aNumber "Refer to the comment in Number quo: " | ng quo | aNumber isInteger ifTrue: [ng := self negative == aNumber negative == false. quo := (self digitDiv: aNumber neg: ng) at: 1. ^ quo normalize]. ^ aNumber adaptToInteger: self andSend: #quo:! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'! bitOr: n "Answer an Integer whose bits are the logical OR of the receiver's bits and those of the argument, n." | norm | norm := n normalize. ^ self digitLogic: norm op: #bitOr: length: (self digitLength max: norm digitLength)! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 11/29/2000 14:32'! anyBitOfMagnitudeFrom: start to: stopArg "Tests for any magnitude bits in the interval from start to stopArg." "Primitive fixed in LargeIntegers v1.2. If you have an earlier version comment out the primitive call (using this ST method then)." | magnitude firstDigitIx lastDigitIx rightShift leftShift stop | start < 1 | (stopArg < 1) ifTrue: [^ self error: 'out of range']. magnitude := self abs. stop := stopArg min: magnitude highBit. start > stop ifTrue: [^ false]. firstDigitIx := start - 1 // 8 + 1. lastDigitIx := stop - 1 // 8 + 1. rightShift := (start - 1 \\ 8) negated. leftShift := 7 - (stop - 1 \\ 8). firstDigitIx = lastDigitIx ifTrue: [| digit mask | mask := (255 bitShift: rightShift negated) bitAnd: (255 bitShift: leftShift negated). digit := magnitude digitAt: firstDigitIx. ^ (digit bitAnd: mask) ~= 0]. ((magnitude digitAt: firstDigitIx) bitShift: rightShift) ~= 0 ifTrue: [^ true]. firstDigitIx + 1 to: lastDigitIx - 1 do: [:ix | (magnitude digitAt: ix) ~= 0 ifTrue: [^ true]]. (((magnitude digitAt: lastDigitIx) bitShift: leftShift) bitAnd: 255) ~= 0 ifTrue: [^ true]. ^ false! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:16'! storeOn: aStream base: base length: minimum padded: zeroFlag | prefix | prefix := self negative ifTrue: ['-'] ifFalse: [String new]. base = 10 ifFalse: [prefix := prefix, base printString, 'r']. self print: (self abs printStringBase: base) on: aStream prefix: prefix length: minimum padded: zeroFlag ! ! !Integer methodsFor: 'arithmetic' stamp: 'jannik.laval 5/1/2010 17:03'! crossSumBase: aBase |aResult| "Precondition" [aBase isInteger and: [aBase >=2]] assert. self < 0 ifTrue: [^self negated crossSumBase: aBase]. self < aBase ifTrue: [^ self]. aResult := self \\ aBase + (self // aBase crossSumBase: aBase). "Postcondition E.g. 18 crossSumBase: 10 -> 9 => 18\\(10-1) = 0" [((aResult \\ (aBase - 1) = 0)) = ((self \\ (aBase - 1)) =0)] assert. ^aResult! ! !Integer methodsFor: 'converting' stamp: 'StephaneDucasse 7/21/2010 17:39'! hex "Print the receiver as hex, prefixed with 16r. DO NOT CHANGE THIS!! The Cog VMMaker depends on this. Consider using any of printStringHex printStringBase: 16 printStringBase: 16 length: 8 padded: true storeStringHex storeStringBase: 16 storeStringBase: 16 length: 11 padded: true" ^self storeStringBase: 16! ! !Integer methodsFor: 'benchmarks' stamp: 'jm 11/20/1998 07:06'! benchFib "Handy send-heavy benchmark" "(result // seconds to run) = approx calls per second" " | r t | t := Time millisecondsToRun: [r := 26 benchFib]. (r * 1000) // t" "138000 on a Mac 8100/100" ^ self < 2 ifTrue: [1] ifFalse: [(self-1) benchFib + (self-2) benchFib + 1] ! ! !Integer methodsFor: '*Keymapping-KeyCombinations' stamp: 'CamilloBruni 3/18/2011 23:14'! alt ^ KMModifier alt + self! ! !Integer methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 3/19/2013 20:26'! control ^ KMModifier ctrl + self! ! !Integer methodsFor: 'truncation and round off' stamp: ''! floor "Refer to the comment in Number|floor."! ! !Integer methodsFor: 'arithmetic' stamp: 'nice 3/11/2013 08:12'! - aNumber "Refer to the comment in Number - " aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [^ self digitSubtract: aNumber] ifFalse: [^ (self digitAdd: aNumber) normalize]]. aNumber isFraction ifTrue: [^Fraction numerator: self * aNumber denominator - aNumber numerator denominator: aNumber denominator]. ^ aNumber adaptToInteger: self andSend: #-! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 13:35'! radix: base ^ self printStringBase: base! ! !Integer methodsFor: 'bit manipulation' stamp: 'tak 9/25/2008 15:17'! bitInvert "Answer an Integer whose bits are the logical negation of the receiver's bits. Numbers are interpreted as having 2's-complement representation." ^ -1 - self.! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 14:00'! printWithCommasSignedOn: aStream "123456789 asStringWithCommasSigned" "-123456789 asStringWithCommasSigned" ^ self printSeparatedBy: $, every: 3 signed: true on: aStream! ! !Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:46'! digitMultiply: arg neg: ng | prod prodLen carry digit k ab | (arg digitLength = 1 and: [(arg digitAt: 1) = 0]) ifTrue: [^ 0]. (self digitLength = 1 and: [(self digitAt: 1) = 0]) ifTrue: [^ 0]. prodLen := self digitLength + arg digitLength. prod := Integer new: prodLen neg: ng. "prod starts out all zero" 1 to: self digitLength do: [:i | (digit := self digitAt: i) ~= 0 ifTrue: [k := i. carry := 0. "Loop invariant: 0<=carry<=0377, k=i+j-1" 1 to: arg digitLength do: [:j | ab := (arg digitAt: j) * digit + carry + (prod digitAt: k). carry := ab bitShift: -8. prod digitAt: k put: (ab bitAnd: 255). k := k + 1]. prod digitAt: k put: carry]]. ^ prod normalize! ! !Integer methodsFor: 'truncation and round off' stamp: ''! truncated "Refer to the comment in Number|truncated."! ! !Integer methodsFor: 'testing' stamp: 'StephaneDucasse 2/4/2012 17:01'! isProbablyPrimeWithK: k andQ: q "Algorithm P, probabilistic primality test, from Knuth, Donald E. 'The Art of Computer Programming', Vol 2, Third Edition, section 4.5.4, page 395, P1-P5 refer to Knuth description.. Note that this is a Miller Rabin test which may answer false positives (known as pseudoprimes) for at most 1/4 of the possible bases x." | x j y minusOne | "P1" x := (self - 2) atRandom + 1. "P2" j := 0. y := x raisedTo: q modulo: self. minusOne := self - 1. ["P3" y = 1 ifTrue: [^j = 0]. y = minusOne ifTrue: [^true]. "P4" (j := j + 1) < k] whileTrue: [y := y squared \\ self]. "P5" ^false! ! !Integer methodsFor: 'mathematical functions' stamp: ''! lcm: n "Answer the least common multiple of the receiver and n." ^self // (self gcd: n) * n! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 13:48'! asTwoCharacterString "Answer a two-character string representing the receiver, with leading zero if required. Intended for use with integers in the range 0 to 99, but plausible replies given for other values too Examples: 2 asTwoCharacterString 11 asTwoCharacterString 1943 asTwoCharacterString 0 asTwoCharacterString -2 asTwoCharacterString -234 asTwoCharacterString " ^ (self >= 0 and: [self < 10]) ifTrue: ['0', self printString] ifFalse: [self printString copyFrom: 1 to: 2]! ! !Integer methodsFor: 'bit manipulation' stamp: 'NicolasCellier 7/29/2011 23:28'! bitStringLength ^self digitLength * 8 "make sure positive integer bitString always begins with 0" + (self positive ifTrue: [1] ifFalse: [0])! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asWord ^ self asTwosComplement: 16rFFFF! ! !Integer methodsFor: 'comparing' stamp: 'nice 3/28/2006 23:38'! > aNumber aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [self negative ifTrue: [^(self digitCompare: aNumber) < 0] ifFalse: [^(self digitCompare: aNumber) > 0]] ifFalse: [^ aNumber negative]]. ^ aNumber adaptToInteger: self andCompare: #>! ! !Integer methodsFor: 'testing' stamp: 'StephaneDucasse 2/4/2012 17:01'! isProbablyPrime "See isProbablyPrimeWithK:andQ: for the algoritm description." | k q | self <= 1 ifTrue: [ ^false ]. self even ifTrue: [ ^self = 2 ]. "Factor self into (2 raisedTo: k) * q + 1, where q odd" q := self bitShift: -1. k := q lowBit. q := q bitShift: 1 - k. "Repeat the probabilistic until false (the probability of false negative is null) or until probability is very low." 25 timesRepeat: [ (self isProbablyPrimeWithK: k andQ: q) ifFalse: [ ^false ] ]. "The probability of false positive after 25 iterations is less than (1/4 raisedTo: 25) < 1.0e-15" ^true! ! !Integer methodsFor: 'private' stamp: ''! growto: n ^self copyto: (self species new: n)! ! !Integer methodsFor: 'accessing' stamp: 'nice 9/7/2011 21:47'! numerator "Let an Integer be polymorphic to a Fraction. See #isFraction." ^self! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:20'! printStringLength: minimal padded: zeroFlag ^self printStringBase: 10 length: minimal padded: zeroFlag! ! !Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:41'! digitAdd: arg | len arglen accum sum | accum := 0. (len := self digitLength) < (arglen := arg digitLength) ifTrue: [len := arglen]. "Open code max: for speed" sum := Integer new: len neg: self negative. 1 to: len do: [:i | accum := (accum bitShift: -8) + (self digitAt: i) + (arg digitAt: i). sum digitAt: i put: (accum bitAnd: 255)]. accum > 255 ifTrue: [sum := sum growby: 1. sum at: sum digitLength put: (accum bitShift: -8)]. ^ sum! ! !Integer methodsFor: 'bit manipulation' stamp: 'NicolasCellier 7/29/2011 23:35'! bitString "Returns a string representing the receiver in binary form" "2 bitString '0000000000000000000000000000010' -1 bitString '1111111111111111111111111111111' -2 bitString '1111111111111111111111111111110' " ^(self bitStringLength to: 1 by: -1) collect: [:i | Character value: $0 charCode + (self bitAt: i)] as: String! ! !Integer methodsFor: '*NativeBoost-Core' stamp: 'Igor.Stasenko 4/28/2010 12:19'! asNBExternalType: gen "integer value in callout argument description aray are pushed directly on stack #( 100 ) - an integer value argument = 100 " ^ NBFFIConst value: (self )! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 13:52'! printPaddedWith: aCharacter to: anInteger "Answer the string containing the ASCII representation of the receiver padded on the left with aCharacter to be at least anInteger characters." ^ self printPaddedWith: aCharacter to: anInteger base: 10! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 10:58'! storeStringHex ^self storeStringBase: 16! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:20'! printStringPadded: minimal ^self printStringLength: minimal padded: true ! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 14:43'! printSeparatedBy: aDelimiter every: offset signed: printSigned on: aStream ^ self printSeparatedBy: aDelimiter every: offset signed: printSigned base: 10 on: aStream! ! !Integer methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 18:06'! primeFactorsOn: aStream "Recursively calculate the primefactors of myself and put the factors into the given stream" self = 1 ifTrue: [ ^ self ]. self even ifTrue: [ aStream nextPut: 2. ^ (self / 2) primeFactorsOn: aStream ]. 3 to: self sqrtFloor by: 2 do: [ :each | self \\ each = 0 ifTrue: [ aStream nextPut: each. ^ (self / each) primeFactorsOn: aStream ]]. aStream nextPut: self.! ! !Integer methodsFor: 'testing' stamp: ''! even "Refer to the comment in Number|even." ^((self digitAt: 1) bitAnd: 1) = 0! ! !Integer methodsFor: 'bit manipulation' stamp: 'adrian-lienhard 5/18/2009 20:34'! >> shiftAmount "right shift" shiftAmount < 0 ifTrue: [self error: 'negative arg']. ^ self bitShift: 0 - shiftAmount! ! !Integer methodsFor: 'truncation and round off' stamp: 'GuillermoPolito 6/22/2012 14:49'! round: numberOfWishedDecimal ^self! ! !Integer methodsFor: 'private' stamp: 'StephaneDucasse 3/5/2010 14:47'! digitSubtract: arg | smaller larger z sum sl al ng | sl := self digitLength. al := arg digitLength. (sl = al ifTrue: [[(self digitAt: sl) = (arg digitAt: sl) and: [sl > 1]] whileTrue: [sl := sl - 1]. al := sl. (self digitAt: sl) < (arg digitAt: sl)] ifFalse: [sl < al]) ifTrue: [larger := arg. smaller := self. ng := self negative == false. sl := al] ifFalse: [larger := self. smaller := arg. ng := self negative]. sum := Integer new: sl neg: ng. z := 0. "Loop invariant is -1<=z<=1" 1 to: sl do: [:i | z := z + (larger digitAt: i) - (smaller digitAt: i). sum digitAt: i put: z - (z // 256 * 256). "sign-tolerant form of (z bitAnd: 255)" z := z // 256]. ^ sum normalize! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:13'! highBit "Answer the index of the high order bit of the receiver, or zero if the receiver is zero. Raise an error if the receiver is negative, since negative integers are defined to have an infinite number of leading 1's in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to get the highest bit of the magnitude." ^ self subclassResponsibility! ! !Integer methodsFor: '*AsmJit-Extension' stamp: ''! asImm "Convert integer value into a signed immediate operand" ^ AJImmediate new ivalue: self! ! !Integer class methodsFor: 'instance creation' stamp: 'nice 3/15/2008 00:36'! readFrom: aStringOrStream "Answer a new Integer as described on the stream, aStream. Embedded radix specifiers not allowed - use Number readFrom: for that." ^self readFrom: aStringOrStream base: 10! ! !Integer class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:18'! basicNew self == Integer ifTrue: [ ^ self error: 'Integer is an abstract class. Make a concrete subclass.']. ^ super basicNew! ! !Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 02:38'! largePrimesUpTo: max do: aBlock "Evaluate aBlock with all primes up to maxValue. The Algorithm is adapted from http://www.rsok.com/~jrm/printprimes.html It encodes prime numbers much more compactly than #primesUpTo: 38.5 integer per byte (2310 numbers per 60 byte) allow for some fun large primes. (all primes up to SmallInteger maxVal can be computed within ~27MB of memory; the regular #primesUpTo: would require 4 *GIGA*bytes). Note: The algorithm could be re-written to produce the first primes (which require the longest time to sieve) faster but only at the cost of clarity." | limit flags maskBitIndex bitIndex maskBit byteIndex index primesUpTo2310 indexLimit | limit := max asInteger - 1. indexLimit := max sqrt truncated + 1. "Create the array of flags." flags := ByteArray new: (limit + 2309) // 2310 * 60 + 60. flags atAllPut: 16rFF. "set all to true" "Compute the primes up to 2310" primesUpTo2310 := self primesUpTo: 2310. "Create a mapping from 2310 integers to 480 bits (60 byte)" maskBitIndex := Array new: 2310. bitIndex := -1. "for pre-increment" maskBitIndex at: 1 put: (bitIndex := bitIndex + 1). maskBitIndex at: 2 put: (bitIndex := bitIndex + 1). 1 to: 5 do:[:i| aBlock value: (primesUpTo2310 at: i)]. index := 6. 2 to: 2309 do:[:n| [(primesUpTo2310 at: index) < n] whileTrue:[index := index + 1]. n = (primesUpTo2310 at: index) ifTrue:[ maskBitIndex at: n+1 put: (bitIndex := bitIndex + 1). ] ifFalse:[ "if modulo any of the prime factors of 2310, then could not be prime" (n \\ 2 = 0 or:[n \\ 3 = 0 or:[n \\ 5 = 0 or:[n \\ 7 = 0 or:[n \\ 11 = 0]]]]) ifTrue:[maskBitIndex at: n+1 put: 0] ifFalse:[maskBitIndex at: n+1 put: (bitIndex := bitIndex + 1)]. ]. ]. "Now the real work begins... Start with 13 since multiples of 2,3,5,7,11 are handled by the storage method; increment by 2 for odd numbers only." 13 to: limit by: 2 do:[:n| (maskBit := maskBitIndex at: (n \\ 2310 + 1)) = 0 ifFalse:["not a multiple of 2,3,5,7,11" byteIndex := n // 2310 * 60 + (maskBit-1 bitShift: -3) + 1. bitIndex := 1 bitShift: (maskBit bitAnd: 7). ((flags at: byteIndex) bitAnd: bitIndex) = 0 ifFalse:["not marked -- n is prime" aBlock value: n. "Start with n*n since any integer < n has already been sieved (e.g., any multiple of n with a number k < n has been cleared when k was sieved); add 2 * i to avoid even numbers and mark all multiples of this prime. Note: n < indexLimit below limits running into LargeInts -- nothing more." n < indexLimit ifTrue:[ index := n * n. (index bitAnd: 1) = 0 ifTrue:[index := index + n]. [index <= limit] whileTrue:[ (maskBit := maskBitIndex at: (index \\ 2310 + 1)) = 0 ifFalse:[ byteIndex := (index // 2310 * 60) + (maskBit-1 bitShift: -3) + 1. maskBit := 255 - (1 bitShift: (maskBit bitAnd: 7)). flags at: byteIndex put: ((flags at: byteIndex) bitAnd: maskBit). ]. index := index + (2 * n)]. ]. ]. ]. ]. ! ! !Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:33'! verbosePrimesUpTo: max "Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh" "Compute primes up to max, but be verbose about it" ^Array streamContents:[:s| self verbosePrimesUpTo: max do:[:prime| s nextPut: prime]].! ! !Integer class methodsFor: '*Tools-Debugger' stamp: 'SeanDeNigris 5/28/2013 17:51'! canonicalArgumentName ^ 'anInteger'.! ! !Integer class methodsFor: '*Spec-Inspector' stamp: 'cb 6/25/2013 13:43'! inspectorClass ^ EyeIntegerInspector! ! !Integer class methodsFor: 'instance creation' stamp: 'bf 2/2/2004 00:23'! byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4 "Depending on high-order byte copy directly into a LargeInteger, or build up a SmallInteger by shifting" | value | byte4 < 16r40 ifTrue: [^ (byte4 bitShift: 24) + (byte3 bitShift: 16) + (byte2 bitShift: 8) + byte1]. value := LargePositiveInteger new: 4. value digitAt: 4 put: byte4. value digitAt: 3 put: byte3. value digitAt: 2 put: byte2. value digitAt: 1 put: byte1. ^ value! ! !Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:34'! largePrimesUpTo: maxValue "Compute and return all the prime numbers up to maxValue" ^Array streamContents:[:s| self largePrimesUpTo: maxValue do:[:prime| s nextPut: prime]]! ! !Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:33'! primesUpTo: max "Return a list of prime integers up to the given integer." "Integer primesUpTo: 100" ^Array streamContents:[:s| self primesUpTo: max do:[:prime| s nextPut: prime]]! ! !Integer class methodsFor: 'class initialization' stamp: 'MarcusDenker 2/1/2012 10:59'! initialize "Integer initialize" "Ensure we have the right compact class index" "LPI has been a compact class forever - just ensure basic correctness" (LargePositiveInteger indexIfCompact = 5) ifFalse:[ (Smalltalk compactClassesArray at: 5) ifNil:[LargePositiveInteger becomeCompactSimplyAt: 5] ifNotNil:[self error: 'Unexpected compact class setup']]. (LargeNegativeInteger indexIfCompact = 4) ifFalse:[ (Smalltalk compactClassesArray at: 4) ifNil:[LargeNegativeInteger becomeCompactSimplyAt: 4] ifNotNil:[self error: 'Unexpected compact class setup']]. ! ! !Integer class methodsFor: 'instance creation' stamp: ''! new: length neg: neg "Answer an instance of a large integer whose size is length. neg is a flag determining whether the integer is negative or not." neg ifTrue: [^LargeNegativeInteger new: length] ifFalse: [^LargePositiveInteger new: length]! ! !Integer class methodsFor: 'instance creation' stamp: 'tk 4/18/1999 22:01'! new self == Integer ifTrue: [ ^ self error: 'Integer is an abstract class. Make a concrete subclass.']. ^ super new! ! !Integer class methodsFor: 'compatibility' stamp: 'laza 10/16/2004 14:34'! readFrom: aStream radix: radix ^self readFrom: aStream base: radix! ! !Integer class methodsFor: 'instance creation' stamp: 'YuriyTymchuk 10/29/2013 11:10'! readFrom: aStringOrStream ifFail: aBlock "Answer an instance of one of the concrete subclasses if Integer. Initial minus sign accepted. Imbedded radix specifiers not allowed; use Number class readFrom: for that. Execute aBlock if there are no digits." ^(NumberParser on: aStringOrStream) nextIntegerBase: 10 ifFail: aBlock! ! !Integer class methodsFor: 'instance creation' stamp: 'YuriyTymchuk 10/29/2013 11:10'! readFrom: aStringOrStream base: base "Answer an instance of one of the concrete subclasses if Integer. Initial minus sign accepted, and bases > 10 use letters A-Z. Imbedded radix specifiers not allowed; use Number class readFrom: for that. Raise an Error if there are no digits. If stringOrStream dos not start with a valid number description, answer 0 for backward compatibility. This is not clever and should better be changed." ^(NumberParser on: aStringOrStream) nextIntegerBase: base! ! !Integer class methodsFor: 'prime numbers' stamp: 'SeanDeNigris 6/21/2012 08:44'! verbosePrimesUpTo: max do: aBlock "Compute primes up to max, but be verbose about it" | lastTime | lastTime := Time millisecondClockValue. UIManager default informUserDuring: [ :bar | bar label: 'Computing primes...'. self primesUpTo: max do: [ :prime | | nowTime | aBlock value: prime. nowTime := Time millisecondClockValue. nowTime - lastTime > 1000 ifTrue: [ lastTime := nowTime. bar label: 'Last prime found: ', prime printString ] ] ]! ! !Integer class methodsFor: 'prime numbers' stamp: 'md 2/13/2006 14:38'! primesUpTo: max do: aBlock "Compute aBlock with all prime integers up to the given integer." "Integer primesUpTo: 100" | limit flags prime k | limit := max asInteger - 1. "Fall back into #largePrimesUpTo:do: if we'd require more than 100k of memory; the alternative will only requre 1/154th of the amount we need here and is almost as fast." limit > 25000 ifTrue:[^self largePrimesUpTo: max do: aBlock]. flags := (Array new: limit) atAllPut: true. 1 to: limit - 1 do: [:i | (flags at: i) ifTrue: [ prime := i + 1. k := i + prime. [k <= limit] whileTrue: [ flags at: k put: false. k := k + prime]. aBlock value: prime]]. ! ! !IntegerApiSetter commentStamp: 'TorstenBergmann 2/5/2014 09:18'! Widget setter API for integers! !IntegerApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 20:01'! initializeWidgets self instantiateModels: #( selector LabelModel choice IntegerEditor ). self selector text: ''. self choice whenIntegerChangedDo: [:b | self setValueTo: b ]! ! !IntegerApiSetter methodsFor: 'private' stamp: 'GabrielOmarCotelli 12/3/2013 17:40'! updateSliderWith: aMethod aMethod pragmas detect: [ :e | e keyword beginsWith: 'api:' ] ifFound: [ :apiPragma | | min max | min := apiPragma arguments second. max := apiPragma arguments third. max isInteger ifTrue: [ choice max: max ] ifFalse: [ choice max: (self model perform: max) ]. min isInteger ifTrue: [ choice min: min ] ifFalse: [ choice min: (self model perform: min) ] ]! ! !IntegerApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/13/2012 02:55'! registerMethodEvents method whenChangedDo: [ :s | selector text: s asString. self model ifNotNil: [ :m || mth | mth := (m class lookupSelector: s). self updateSliderWith: mth. choice help: mth comment ]]! ! !IntegerApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:58'! internUpdateWith: value choice value: value ! ! !IntegerArray commentStamp: ''! IntegerArrays store 32bit signed Integer values. Negative values are stored as 2's complement.! !IntegerArray methodsFor: 'private' stamp: 'ar 3/3/2001 23:34'! primFill: aPositiveInteger "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." self errorImproperStore.! ! !IntegerArray methodsFor: 'converting' stamp: 'ar 10/10/1998 16:18'! asIntegerArray ^self! ! !IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:40'! at: index put: anInteger | word | anInteger < 0 ifTrue:["word := 16r100000000 + anInteger" word := (anInteger + 1) negated bitInvert32] ifFalse:[word := anInteger]. self basicAt: index put: word. ^anInteger! ! !IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:40'! at: index | word | word := self basicAt: index. word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" ^word >= 16r80000000 "Negative?!!" ifTrue:["word - 16r100000000" (word bitInvert32 + 1) negated] ifFalse:[word]! ! !IntegerArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! defaultElement "Return the default element of the receiver" ^0! ! !IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 23:34'! atAllPut: anInteger | word | anInteger < 0 ifTrue:["word := 16r100000000 + anInteger" word := (anInteger + 1) negated bitInvert32] ifFalse:[word := anInteger]. self primFill: word.! ! !IntegerArrayTest commentStamp: 'TorstenBergmann 2/20/2014 15:29'! SUnit tests for integer arrays! !IntegerArrayTest methodsFor: 'testing' stamp: 'HilaireFernandes 3/29/2010 21:54'! testAt | array | array := IntegerArray new: 5 withAll: 2. self assert: (array at: 3) = 2. array at: 3 put: 5. self assert: (array at: 3) = 5 ! ! !IntegerArrayTest methodsFor: 'testing' stamp: 'HilaireFernandes 3/29/2010 21:58'! testPutNegative | array | array := IntegerArray new: 2. array at: 2 put: -1000. self assert: (array at: 2) = -1000! ! !IntegerArrayTest methodsFor: 'testing' stamp: 'HilaireFernandes 3/29/2010 21:59'! testPutAllNegative | array | array := IntegerArray new: 2. array atAllPut: -1000. self assert: (array at: 2) = -1000! ! !IntegerDigitLogicTest commentStamp: 'TorstenBergmann 2/5/2014 08:37'! SUnit test to test digit logic of integers! !IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'! testNBitAndNNegatedEqualsN "Verify that (n bitAnd: n negated) = n for single bits" | n | 1 to: 100 do: [:i | n := 1 bitShift: i. self assert: (n bitAnd: n negated) = n]! ! !IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'! testAndSingleBitWithMinusOne "And a single bit with -1 and test for same value" 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)].! ! !IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:13'! testShiftMinusOne1LeftThenRight "Shift -1 left then right and test for 1" 1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) = -1]. ! ! !IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'! testNNegatedEqualsNComplementedPlusOne "Verify that n negated = (n complemented + 1) for single bits" | n | 1 to: 100 do: [:i | n := 1 bitShift: i. self assert: n negated = ((n bitXor: -1) + 1)]! ! !IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:12'! testShiftOneLeftThenRight "Shift 1 bit left then right and test for 1" 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) = 1]. ! ! !IntegerDigitLogicTest methodsFor: 'tests' stamp: 'hmm 1/7/2002 21:13'! testMixedSignDigitLogic "Verify that mixed sign logic with large integers works." self assert: (-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE! ! !IntegerDigitLogicTest methodsFor: 'tests' stamp: 'StephaneDucasse 2/11/2010 21:06'! testLargeShift "A sanity check for LargeInteger bitShifts" "self debug: #testLargeShift" | suite | suite := #( "some numbers on 64 bits or less" '101101011101001100110111110110011101101101000001110110011' '1101101001100010011001101110100000111011011010100011101100' '101101101011110011001100110011011101011001111000100011101000' '10101101101000101001111111111100101101011001011000100011100000' '1000101010101001111011101010111001011111110011110001000110000000' '1100101010101000010011101000110010111110110011110000000000000001' ). "65 bits or less" suite := suite , (suite collect: [:e | '1' , e reversed ]). "129 bits or less" suite := suite , (suite collect: [:e | e ,e ]). suite do: [:bits | | num ls rs | num := Integer readFrom: bits readStream base: 2. 0 to: bits size-1 do: [:shift | ls := (num bitShift: shift) printStringBase: 2. rs := (num bitShift: 0-shift) printStringBase: 2. self assert: ls = (bits , (String new: shift withAll: $0)). self assert: rs = (bits copyFrom: 1 to: bits size - shift).]]! ! !IntegerEditor commentStamp: 'TorstenBergmann 2/5/2014 09:19'! Integer editor! !IntegerEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! integer: aBlock integer value: aBlock ! ! !IntegerEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! integer ^ integer value! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:52'! min: aNumber slider min: aNumber! ! !IntegerEditor methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! initializeWidgets self instantiateModels: #( slider SliderModel text LabelModel ). text borderWidth: 4; borderColor: Color black; text: '0'. slider quantum: 1; whenValueChangedDo: [:v | integer value: v. text text: v asString ]. self focusOrder add: slider; add: text! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 19:38'! max: aNumber slider max: aNumber! ! !IntegerEditor methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/12/2012 19:38'! whenIntegerChangedDo: aBlock integer whenChangedDo: aBlock ! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 19:33'! buildWithSpec: aSpec ^ self buildWithSpecLayout: self layout! ! !IntegerEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 7/12/2012 19:40'! layout | width | width := StandardFonts defaultFont widthOfStringOrText: (slider max + slider quantum) asString. ^ SpecLayout composed newRow: [:r | r add: #slider; newColumn: [:c | c add: #text ] width: width ] height: 25; yourself! ! !IntegerEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 19:33'! text ^ text! ! !IntegerEditor methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. integer := 0 asReactiveVariable! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 19:33'! buildWithSpec ^ self buildWithSpecLayout: self layout! ! !IntegerEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 19:34'! slider ^ slider! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 19:38'! value: aNumber slider value: aNumber! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 19:38'! help: aString slider help: aString ! ! !IntegerTest commentStamp: 'TorstenBergmann 2/5/2014 08:37'! SUnit tests for integers! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'SeanDeNigris 5/16/2012 20:52'! testLowBit | suite | "Simple examples" self assert: (2r1011 lowBit) equals: 1. self assert: (2r1010 lowBit) equals: 2. self assert: (2r000000 lowBit) equals: 0. suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}. suite := suite , (suite collect: [:e | e raisedTo: 20]). suite do: [:anInteger | | lowBit | lowBit := (anInteger respondsTo: #bitAt:) ifTrue: [(1 to: anInteger highBit) detect: [:bitIndex | (anInteger bitAt: bitIndex) ~= 0] ifNone: [0]] ifFalse: [(1 to: anInteger highBit) detect: [:bitIndex | (anInteger bitAnd: (1 bitShift: bitIndex-1)) ~= 0] ifNone: [0]]. self assert: anInteger lowBit = lowBit. self assert: anInteger negated lowBit = lowBit].! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'SvenVanCaekenberghe 3/5/2014 22:17'! testAsStringWithCommas self assert: 123456789 asStringWithCommas equals: '123,456,789'. self assert: -123456789 asStringWithCommas equals: '-123,456,789'! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'SeanDeNigris 5/16/2012 20:21'! testBitAnd self assert: (2r1100 bitAnd: 2r1010) equals: 2r1000. self assert: (2r1100 & 2r1010) equals: 2r1000. self assert: (-2 bitAnd: 16rFFFFFFFF) equals: 16rFFFFFFFE. self assert: (-2 & 16rFFFFFFFF) equals: 16rFFFFFFFE.! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/13/2011 21:46'! testSqrtErrorConditions " IntegerTest new testSqrtErrorConditions " self should: [ -1 sqrt ] raise: ArithmeticError! ! !IntegerTest methodsFor: 'testing - arithmetic' stamp: 'nice 9/6/2010 21:48'! testReciprocalModulo 1 to: 512 do: [:a | a + 1 to: 512 do: [:b | | c | (a gcd: b) = 1 ifTrue: [c := a reciprocalModulo: b. self assert: (a * c) \\ b = 1] ifFalse: [self should: [ a reciprocalModulo: b ] raise: Error]]].! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'HenrikSperreJohansen 1/19/2012 15:57'! testAsSmallerPowerOfTwo "Invalid input testing" "LargeNegativeIntegers" self should: [(2 raisedTo: 80) negated asSmallerPowerOfTwo] raise: DomainError. "Negative SmallIntegers" self should: [-1 asSmallerPowerOfTwo] raise: DomainError. "0" self should: [0 asSmallerPowerOfTwo] raise: DomainError. "Valid inputs" "Small integers" self assert: 1 asSmallerPowerOfTwo equals: 1. self assert: 2 asSmallerPowerOfTwo equals: 2. self assert: 3 asSmallerPowerOfTwo equals: 2. self assert: 4 asSmallerPowerOfTwo equals: 4. self assert: 5 asSmallerPowerOfTwo equals: 4. "Large integers" self assert: ((2 raisedTo: 80) +1) asSmallerPowerOfTwo equals: (2 raisedTo: 80). self assert: (2 raisedTo: 80) asSmallerPowerOfTwo equals: (2 raisedTo: 80). self assert: ((2 raisedTo: 80) - 1) asSmallerPowerOfTwo equals: (2 raisedTo: 80 - 1)! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/30/2004 14:20'! testNegativeIntegerPrinting "self run: #testnegativeIntegerPrinting" self assert: (-2 printStringBase: 2) = '-10'. self assert: (-2 radix: 2) = '-10'. self assert: -2 printStringHex = '-2'. self assert: (-2 storeStringBase: 2) = '-2r10'. self assert: -2 storeStringHex = '-16r2'. self assert: (-21 printStringBase: 3) = '-210'. self assert: (-21 radix: 3) = '-210'. self assert: -21 printStringHex = '-15'. self assert: (-21 storeStringBase: 3) = '-3r210'. self assert: -21 storeStringHex = '-16r15'. self assert: (-228 printStringBase: 4) = '-3210'. self assert: (-228 radix: 4) = '-3210'. self assert: -228 printStringHex = '-E4'. self assert: (-228 storeStringBase: 4) = '-4r3210'. self assert: -228 storeStringHex = '-16rE4'. self assert: (-2930 printStringBase: 5) = '-43210'. self assert: (-2930 radix: 5) = '-43210'. self assert: -2930 printStringHex = '-B72'. self assert: (-2930 storeStringBase: 5) = '-5r43210'. self assert: -2930 storeStringHex = '-16rB72'. self assert: (-44790 printStringBase: 6) = '-543210'. self assert: (-44790 radix: 6) = '-543210'. self assert: -44790 printStringHex = '-AEF6'. self assert: (-44790 storeStringBase: 6) = '-6r543210'. self assert: -44790 storeStringHex = '-16rAEF6'. self assert: (-800667 printStringBase: 7) = '-6543210'. self assert: (-800667 radix: 7) = '-6543210'. self assert: -800667 printStringHex = '-C379B'. self assert: (-800667 storeStringBase: 7) = '-7r6543210'. self assert: -800667 storeStringHex = '-16rC379B'. self assert: (-16434824 printStringBase: 8) = '-76543210'. self assert: (-16434824 radix: 8) = '-76543210'. self assert: -16434824 printStringHex = '-FAC688'. self assert: (-16434824 storeStringBase: 8) = '-8r76543210'. self assert: -16434824 storeStringHex = '-16rFAC688'. self assert: (-381367044 printStringBase: 9) = '-876543210'. self assert: (-381367044 radix: 9) = '-876543210'. self assert: -381367044 printStringHex = '-16BB3304'. self assert: (-381367044 storeStringBase: 9) = '-9r876543210'. self assert: -381367044 storeStringHex = '-16r16BB3304'. self assert: (-9876543210 printStringBase: 10) = '-9876543210'. self assert: (-9876543210 radix: 10) = '-9876543210'. self assert: -9876543210 printStringHex = '-24CB016EA'. self assert: (-9876543210 storeStringBase: 10) = '-9876543210'. self assert: -9876543210 storeStringHex = '-16r24CB016EA'. self assert: (-282458553905 printStringBase: 11) = '-A9876543210'. self assert: (-282458553905 radix: 11) = '-A9876543210'. self assert: -282458553905 printStringHex = '-41C3D77E31'. self assert: (-282458553905 storeStringBase: 11) = '-11rA9876543210'. self assert: -282458553905 storeStringHex = '-16r41C3D77E31'. self assert: (-8842413667692 printStringBase: 12) = '-BA9876543210'. self assert: (-8842413667692 radix: 12) = '-BA9876543210'. self assert: -8842413667692 printStringHex = '-80AC8ECF56C'. self assert: (-8842413667692 storeStringBase: 12) = '-12rBA9876543210'. self assert: -8842413667692 storeStringHex = '-16r80AC8ECF56C'. self assert: (-300771807240918 printStringBase: 13) = '-CBA9876543210'. self assert: (-300771807240918 radix: 13) = '-CBA9876543210'. self assert: -300771807240918 printStringHex = '-1118CE4BAA2D6'. self assert: (-300771807240918 storeStringBase: 13) = '-13rCBA9876543210'. self assert: -300771807240918 storeStringHex = '-16r1118CE4BAA2D6'. self assert: (-11046255305880158 printStringBase: 14) = '-DCBA9876543210'. self assert: (-11046255305880158 radix: 14) = '-DCBA9876543210'. self assert: -11046255305880158 printStringHex = '-273E82BB9AF25E'. self assert: (-11046255305880158 storeStringBase: 14) = '-14rDCBA9876543210'. self assert: -11046255305880158 storeStringHex = '-16r273E82BB9AF25E'. self assert: (-435659737878916215 printStringBase: 15) = '-EDCBA9876543210'. self assert: (-435659737878916215 radix: 15) = '-EDCBA9876543210'. self assert: -435659737878916215 printStringHex = '-60BC6392F366C77'. self assert: (-435659737878916215 storeStringBase: 15) = '-15rEDCBA9876543210'. self assert: -435659737878916215 storeStringHex = '-16r60BC6392F366C77'. self assert: (-18364758544493064720 printStringBase: 16) = '-FEDCBA9876543210'. self assert: (-18364758544493064720 radix: 16) = '-FEDCBA9876543210'. self assert: -18364758544493064720 printStringHex = '-FEDCBA9876543210'. self assert: (-18364758544493064720 storeStringBase: 16) = '-16rFEDCBA9876543210'. self assert: -18364758544493064720 storeStringHex = '-16rFEDCBA9876543210'. self assert: (-824008854613343261192 printStringBase: 17) = '-GFEDCBA9876543210'. self assert: (-824008854613343261192 radix: 17) = '-GFEDCBA9876543210'. self assert: -824008854613343261192 printStringHex = '-2CAB6B877C1CD2D208'. self assert: (-824008854613343261192 storeStringBase: 17) = '-17rGFEDCBA9876543210'. self assert: -824008854613343261192 storeStringHex = '-16r2CAB6B877C1CD2D208'. self assert: (-39210261334551566857170 printStringBase: 18) = '-HGFEDCBA9876543210'. self assert: (-39210261334551566857170 radix: 18) = '-HGFEDCBA9876543210'. self assert: -39210261334551566857170 printStringHex = '-84D97AFCAE81415B3D2'. self assert: (-39210261334551566857170 storeStringBase: 18) = '-18rHGFEDCBA9876543210'. self assert: -39210261334551566857170 storeStringHex = '-16r84D97AFCAE81415B3D2'. self assert: (-1972313422155189164466189 printStringBase: 19) = '-IHGFEDCBA9876543210'. self assert: (-1972313422155189164466189 radix: 19) = '-IHGFEDCBA9876543210'. self assert: -1972313422155189164466189 printStringHex = '-1A1A75329C5C6FC00600D'. self assert: (-1972313422155189164466189 storeStringBase: 19) = '-19rIHGFEDCBA9876543210'. self assert: -1972313422155189164466189 storeStringHex = '-16r1A1A75329C5C6FC00600D'. self assert: (-104567135734072022160664820 printStringBase: 20) = '-JIHGFEDCBA9876543210'. self assert: (-104567135734072022160664820 radix: 20) = '-JIHGFEDCBA9876543210'. self assert: -104567135734072022160664820 printStringHex = '-567EF3C9636D242A8C68F4'. self assert: (-104567135734072022160664820 storeStringBase: 20) = '-20rJIHGFEDCBA9876543210'. self assert: -104567135734072022160664820 storeStringHex = '-16r567EF3C9636D242A8C68F4'. self assert: (-5827980550840017565077671610 printStringBase: 21) = '-KJIHGFEDCBA9876543210'. self assert: (-5827980550840017565077671610 radix: 21) = '-KJIHGFEDCBA9876543210'. self assert: -5827980550840017565077671610 printStringHex = '-12D4CAE2B8A09BCFDBE30EBA'. self assert: (-5827980550840017565077671610 storeStringBase: 21) = '-21rKJIHGFEDCBA9876543210'. self assert: -5827980550840017565077671610 storeStringHex = '-16r12D4CAE2B8A09BCFDBE30EBA'. self assert: (-340653664490377789692799452102 printStringBase: 22) = '-LKJIHGFEDCBA9876543210'. self assert: (-340653664490377789692799452102 radix: 22) = '-LKJIHGFEDCBA9876543210'. self assert: -340653664490377789692799452102 printStringHex = '-44CB61B5B47E1A5D8F88583C6'. self assert: (-340653664490377789692799452102 storeStringBase: 22) = '-22rLKJIHGFEDCBA9876543210'. self assert: -340653664490377789692799452102 storeStringHex = '-16r44CB61B5B47E1A5D8F88583C6'. self assert: (-20837326537038308910317109288851 printStringBase: 23) = '-MLKJIHGFEDCBA9876543210'. self assert: (-20837326537038308910317109288851 radix: 23) = '-MLKJIHGFEDCBA9876543210'. self assert: -20837326537038308910317109288851 printStringHex = '-1070108876456E0EF115B389F93'. self assert: (-20837326537038308910317109288851 storeStringBase: 23) = '-23rMLKJIHGFEDCBA9876543210'. self assert: -20837326537038308910317109288851 storeStringHex = '-16r1070108876456E0EF115B389F93'. self assert: (-1331214537196502869015340298036888 printStringBase: 24) = '-NMLKJIHGFEDCBA9876543210'. self assert: (-1331214537196502869015340298036888 radix: 24) = '-NMLKJIHGFEDCBA9876543210'. self assert: -1331214537196502869015340298036888 printStringHex = '-41A24A285154B026B6ED206C6698'. self assert: (-1331214537196502869015340298036888 storeStringBase: 24) = '-24rNMLKJIHGFEDCBA9876543210'. self assert: -1331214537196502869015340298036888 storeStringHex = '-16r41A24A285154B026B6ED206C6698'. self assert: (-88663644327703473714387251271141900 printStringBase: 25) = '-ONMLKJIHGFEDCBA9876543210'. self assert: (-88663644327703473714387251271141900 radix: 25) = '-ONMLKJIHGFEDCBA9876543210'. self assert: -88663644327703473714387251271141900 printStringHex = '-111374860A2C6CEBE5999630398A0C'. self assert: (-88663644327703473714387251271141900 storeStringBase: 25) = '-25rONMLKJIHGFEDCBA9876543210'. self assert: -88663644327703473714387251271141900 storeStringHex = '-16r111374860A2C6CEBE5999630398A0C'. self assert: (-6146269788878825859099399609538763450 printStringBase: 26) = '-PONMLKJIHGFEDCBA9876543210'. self assert: (-6146269788878825859099399609538763450 radix: 26) = '-PONMLKJIHGFEDCBA9876543210'. self assert: -6146269788878825859099399609538763450 printStringHex = '-49FBA7F30B0F48BD14E6A99BD8ADABA'. self assert: (-6146269788878825859099399609538763450 storeStringBase: 26) = '-26rPONMLKJIHGFEDCBA9876543210'. self assert: -6146269788878825859099399609538763450 storeStringHex = '-16r49FBA7F30B0F48BD14E6A99BD8ADABA'. self assert: (-442770531899482980347734468443677777577 printStringBase: 27) = '-QPONMLKJIHGFEDCBA9876543210'. self assert: (-442770531899482980347734468443677777577 radix: 27) = '-QPONMLKJIHGFEDCBA9876543210'. self assert: -442770531899482980347734468443677777577 printStringHex = '-14D1A80A997343640C1145A073731DEA9'. self assert: (-442770531899482980347734468443677777577 storeStringBase: 27) = '-27rQPONMLKJIHGFEDCBA9876543210'. self assert: -442770531899482980347734468443677777577 storeStringHex = '-16r14D1A80A997343640C1145A073731DEA9'. self assert: (-33100056003358651440264672384704297711484 printStringBase: 28) = '-RQPONMLKJIHGFEDCBA9876543210'. self assert: (-33100056003358651440264672384704297711484 radix: 28) = '-RQPONMLKJIHGFEDCBA9876543210'. self assert: -33100056003358651440264672384704297711484 printStringHex = '-6145B6E6DACFA25D0E936F51D25932377C'. self assert: (-33100056003358651440264672384704297711484 storeStringBase: 28) = '-28rRQPONMLKJIHGFEDCBA9876543210'. self assert: -33100056003358651440264672384704297711484 storeStringHex = '-16r6145B6E6DACFA25D0E936F51D25932377C'. self assert: (-2564411043271974895869785066497940850811934 printStringBase: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'. self assert: (-2564411043271974895869785066497940850811934 radix: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'. self assert: -2564411043271974895869785066497940850811934 printStringHex = '-1D702071CBA4A1597D4DD37E95EFAC79241E'. self assert: (-2564411043271974895869785066497940850811934 storeStringBase: 29) = '-29rSRQPONMLKJIHGFEDCBA9876543210'. self assert: -2564411043271974895869785066497940850811934 storeStringHex = '-16r1D702071CBA4A1597D4DD37E95EFAC79241E'. self assert: (-205646315052919334126040428061831153388822830 printStringBase: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-205646315052919334126040428061831153388822830 radix: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'. self assert: -205646315052919334126040428061831153388822830 printStringHex = '-938B4343B54B550989989D02998718FFB212E'. self assert: (-205646315052919334126040428061831153388822830 storeStringBase: 30) = '-30rTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -205646315052919334126040428061831153388822830 storeStringHex = '-16r938B4343B54B550989989D02998718FFB212E'. self assert: (-17050208381689099029767742314582582184093573615 printStringBase: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-17050208381689099029767742314582582184093573615 radix: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -17050208381689099029767742314582582184093573615 printStringHex = '-2FC8ECB1521BA16D24A69E976D53873E2C661EF'. self assert: (-17050208381689099029767742314582582184093573615 storeStringBase: 31) = '-31rUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -17050208381689099029767742314582582184093573615 storeStringHex = '-16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'. self assert: (-1459980823972598128486511383358617792788444579872 printStringBase: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-1459980823972598128486511383358617792788444579872 radix: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -1459980823972598128486511383358617792788444579872 printStringHex = '-FFBBCDEB38BDAB49CA307B9AC5A928398A418820'. self assert: (-1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '-32rVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -1459980823972598128486511383358617792788444579872 storeStringHex = '-16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'. self assert: (-128983956064237823710866404905431464703849549412368 printStringBase: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-128983956064237823710866404905431464703849549412368 radix: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -128983956064237823710866404905431464703849549412368 printStringHex = '-584120A0328DE272AB055A8AA003CE4A559F223810'. self assert: (-128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '-33rWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -128983956064237823710866404905431464703849549412368 storeStringHex = '-16r584120A0328DE272AB055A8AA003CE4A559F223810'. self assert: (-11745843093701610854378775891116314824081102660800418 printStringBase: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-11745843093701610854378775891116314824081102660800418 radix: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -11745843093701610854378775891116314824081102660800418 printStringHex = '-1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. self assert: (-11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '-34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -11745843093701610854378775891116314824081102660800418 storeStringHex = '-16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. self assert: (-1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-1101553773143634726491620528194292510495517905608180485 radix: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -1101553773143634726491620528194292510495517905608180485 printStringHex = '-B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. self assert: (-1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '-35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -1101553773143634726491620528194292510495517905608180485 storeStringHex = '-16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. self assert: (-106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-106300512100105327644605138221229898724869759421181854980 radix: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -106300512100105327644605138221229898724869759421181854980 printStringHex = '-455D441E55A37239AB4C303189576071AF5578FFCA80504'. self assert: (-106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '-36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -106300512100105327644605138221229898724869759421181854980 storeStringHex = '-16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/13/2011 21:46'! testExactRaisedTo " IntegerTest new testExactRaisedTo " self assert: (4 raisedTo: 1/2) classAndValueEquals: 2. self assert: (9 raisedTo: 1/2) classAndValueEquals: 3. self assert: (9 raisedTo: -1/2) classAndValueEquals: 1/3. self assert: (-1 raisedTo: 1/3) classAndValueEquals: -1. #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i | self assert: (i squared raisedTo: 1/2) classAndValueEquals: i. self assert: (i negated squared raisedTo: 1/2) classAndValueEquals: i ]. self assert: (8 raisedTo: 1/3) classAndValueEquals: 2. self assert: (27 raisedTo: 1/3) classAndValueEquals: 3. #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i | self assert: ((i raisedTo: 3) raisedTo: 1/3) classAndValueEquals: i. self assert: ((i negated raisedTo: 3) raisedTo: 1/3) classAndValueEquals: i negated ]. self assert: (4 raisedTo: 3/2) classAndValueEquals: 8. self assert: (8 raisedTo: 2/3) classAndValueEquals: 4. self assert: (8 raisedTo: -2/3) classAndValueEquals: 1/4. #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i | self assert: ((i raisedTo: 3) raisedTo: 2/3) classAndValueEquals: i*i. self assert: ((i raisedTo: 2) raisedTo: 3/2) classAndValueEquals: i*i*i. self assert: ((i negated raisedTo: 3) raisedTo: 2/3) classAndValueEquals: i*i. self assert: ((i negated raisedTo: 2) raisedTo: 3/2) classAndValueEquals: i*i*i ]. self assert: (32 raisedTo: 3/5) classAndValueEquals: 8. self assert: (8 raisedTo: 5/3) classAndValueEquals: 32. #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i | self assert: ((i raisedTo: 5) raisedTo: 3/5) classAndValueEquals: i*i*i. self assert: ((i raisedTo: 3) raisedTo: 5/3) classAndValueEquals: i*i*i*i*i. self assert: ((i negated raisedTo: 5) raisedTo: 3/5) classAndValueEquals: (i*i*i) negated. self assert: ((i negated raisedTo: 3) raisedTo: 5/3) classAndValueEquals: (i*i*i*i*i) negated. self assert: ((i raisedTo: -5) raisedTo: 3/5) classAndValueEquals: 1/(i*i*i). self assert: ((i raisedTo: -3) raisedTo: 5/3) classAndValueEquals: 1/(i*i*i*i*i). self assert: ((i negated raisedTo: -5) raisedTo: 3/5) classAndValueEquals: -1/(i*i*i). self assert: ((i negated raisedTo: -3) raisedTo: 5/3) classAndValueEquals: -1/(i*i*i*i*i). self assert: ((i raisedTo: 5) raisedTo: -3/5) classAndValueEquals: 1/(i*i*i). self assert: ((i raisedTo: 3) raisedTo: -5/3) classAndValueEquals: 1/(i*i*i*i*i). self assert: ((i negated raisedTo: 5) raisedTo: -3/5) classAndValueEquals: -1/(i*i*i). self assert: ((i negated raisedTo: 3) raisedTo: -5/3) classAndValueEquals: -1/(i*i*i*i*i). "No exact result => Float result" self assert: ((i raisedTo: 3) +1 raisedTo: 5/3) isFloat. self assert: ((i negated raisedTo: 3) -1 raisedTo: 5/3) isFloat ].! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'sd 6/5/2005 08:44'! testTwoComplementRightShift "self run: #testTwoComplementRightShift" | large small | small := 2 << 16. large := 2 << 32. self assert: ((small negated bitShift: -1) ~= ((small + 1) negated bitShift: -1) == ((large negated bitShift: -1) ~= ((large + 1) negated bitShift: -1))). self assert: ((small bitShift: -1) ~= (small + 1 bitShift: -1) == ((large bitShift: -1) ~= (large + 1 bitShift: -1))).! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'SeanDeNigris 5/16/2012 20:37'! testBitClear self assert: (2r1111 bitClear: 2r1000) equals: 2r0111. self assert: (2r1111 bitClear: 2r0100) equals: 2r1011. self assert: (2r1111 bitClear: 2r0010) equals: 2r1101. self assert: (2r1111 bitClear: 2r0001) equals: 2r1110.! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:48'! testCreationFromBytes2 "self run: #testCreationFromBytes2" "it is illegal for a LargeInteger to be less than SmallInteger maxVal." "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal + 1) as an instance of LargePositiveInteger. " | maxSmallInt hexString byte1 byte2 byte3 byte4 builtInteger | maxSmallInt := SmallInteger maxVal. hexString := (maxSmallInt + 1) printStringHex. self assert: hexString size = 8. byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16. byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16. byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16. byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16. builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4. self assert: builtInteger = (maxSmallInt + 1). self deny: builtInteger class = SmallInteger ! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'HenrikSperreJohansen 1/19/2012 15:56'! testAsLargerPowerOfTwo "Invalid input testing" "LargeNegativeIntegers" self should: [(2 raisedTo: 80) negated asLargerPowerOfTwo] raise: DomainError. "Negative SmallIntegers" self should: [-1 asLargerPowerOfTwo] raise: DomainError. "0" self should: [0 asLargerPowerOfTwo] raise: DomainError. "Valid inputs" "Small integers" self assert: 1 asLargerPowerOfTwo equals: 1. self assert: 2 asLargerPowerOfTwo equals: 2. self assert: 3 asLargerPowerOfTwo equals: 4. self assert: 4 asLargerPowerOfTwo equals: 4. self assert: 5 asLargerPowerOfTwo equals: 8. "Large integers" self assert: ((2 raisedTo: 80) +1) asLargerPowerOfTwo equals: (2 raisedTo: 80 +1). self assert: (2 raisedTo: 80) asLargerPowerOfTwo equals: (2 raisedTo: 80). self assert: ((2 raisedTo: 80) - 1) asLargerPowerOfTwo equals: (2 raisedTo: 80)! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'StephaneDucasse 7/21/2010 18:01'! testPrintStringHex "self run: #testPrintStringHex" self assert: 0 printStringHex = '0'. self assert: 12 printStringHex = 'C'. self assert: 1234 printStringHex = '4D2'.! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:49'! testCreationFromBytes3 "self run: #testCreationFromBytes3" "it is illegal for a LargeInteger to be less than SmallInteger maxVal." "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal - 1) as an instance of SmallInteger. " | maxSmallInt hexString byte1 byte2 byte3 byte4 builtInteger | maxSmallInt := SmallInteger maxVal. hexString := (maxSmallInt - 1) printStringHex. self assert: hexString size = 8. byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16. byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16. byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16. byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16. builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4. self assert: builtInteger = (maxSmallInt - 1). self assert: builtInteger class = SmallInteger ! ! !IntegerTest methodsFor: 'tests - benchmarks' stamp: 'sd 6/5/2005 08:37'! testBenchFib self assert: (0 benchFib = 1). self assert: (1 benchFib = 1). self assert: (2 benchFib = 3). ! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'nice 1/25/2008 22:51'! testIsPowerOfTwoM6873 "This is a non regression test for http://bugs.squeak.org/view.php?id=6873" self deny: ((1 to: 80) anySatisfy: [:n | (2 raisedTo: n) negated isPowerOfTwo]) description: 'A negative integer cannot be a power of two'.! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'md 2/12/2006 14:36'! testPrimesUpTo | primes nn| primes := Integer primesUpTo: 100. self assert: primes = #(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97). "upTo: semantics means 'non-inclusive'" primes := Integer primesUpTo: 5. self assert: primes = #(2 3). "this test is green for nn>25000, see #testLargePrimesUpTo" nn := 5. self deny: (Integer primesUpTo: nn) last = nn. self assert: (Integer primesUpTo: nn + 1) last = nn.! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'nice 1/26/2008 02:22'! testTwoComplementBitLogicWithCarry "This is non regression test for http://bugs.squeak.org/view.php?id=6874" "By property of two complement, following operation is: ...111110000 this is -16 ...111101111 this is -16-1 ...111100000 this is -32, the result of bitAnd: on two complement This test used to fail with n=31 39 47.... because of bug 6874" self assert: ((2 to: 80) allSatisfy: [:n | ((2 raisedTo: n) negated bitAnd: (2 raisedTo: n) negated - 1) = (2 raisedTo: n + 1) negated]).! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'StephaneDucasse 7/21/2010 18:02'! testIntegerHex | result | result := 15 asInteger hex. self assert: result = '16rF'. result := 0 asInteger hex. self assert: result = '16r0'. result := 255 asInteger hex. self assert: result = '16rFF'. result := 90 asInteger hex. self assert: result = '16r5A'! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'GuillermoPolito 8/24/2010 19:10'! testIntegerReadsOkFromStream self assert: (Integer readFrom: '123' readStream) = 123. self assert: (Integer readFrom: '-123' readStream) = -123. self assert: (Integer readFrom: 'a3' readStream base: 16) = 163. self assert: (Integer readFrom: '-a3' readStream base: 16) = -163. self assert: (Integer readFrom: '3a' readStream base: 10) = 3.! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'fbs 2/9/2006 08:48'! testPrintOnBaseShowRadix | s | s := ReadWriteStream on: ''. 123 printOn: s base: 10 showRadix: false. self assert: (s contents = '123'). s := ReadWriteStream on: ''. 123 printOn: s base: 10 showRadix: true. self assert: (s contents = '10r123'). s := ReadWriteStream on: ''. 123 printOn: s base: 8 showRadix: false. self assert: (s contents = '173'). s := ReadWriteStream on: ''. 123 printOn: s base: 8 showRadix: true. self assert: (s contents = '8r173').! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'GuillermoPolito 8/24/2010 19:08'! testIntegerReadsOkFromString self assert: (Integer readFrom: '123') = 123. self assert: (Integer readFrom: '-123') = -123. self assert: (Integer readFrom: 'a3' base: 16) = 163. self assert: (Integer readFrom: '-a3' base: 16) = -163.! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'CamilloBruni 8/31/2013 20:23'! testDegreeSin "self run: #testDegreeSin" 45 degreeSin. "Following tests use approximate equality, because sine are generally evaluated using inexact Floating point arithmetic" self assert: (45 degreeSin squared - (1 / 2)) abs <= Float epsilon. self assert: (30 degreeSin - (1 / 2)) abs <= Float epsilon. self assert: (-30 degreeSin + (1 / 2)) abs <= Float epsilon. -360 to: 360 do: [ :i | self assert: (i degreeSin closeTo: i degreesToRadians sin) ]. "Following tests use strict equality which is a requested property of degreeSin" -10 to: 10 do: [ :k | self assert: (k * 360 + 90) degreeSin - 1 = 0. self assert: (k * 360 - 90) degreeSin + 1 = 0. self assert: (k * 360 + 180) degreeSin = 0. self assert: (k * 360) degreeSin = 0 ]! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'nice 6/12/2010 00:37'! testLog self assert: (100 log closeTo: 2). self assert: ((2 raisedTo: Float emax + 3) log closeTo: 2 log*(Float emax + 3)) description: 'Integer>>log should not overflow'! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/19/2011 22:59'! testBigReceiverInexactNthRoot " IntegerTest new testBigReceiverInexactNthRoot " "Inexact 3rd root (not a whole cube number), so a Float must be answered. However, receiver is too big for Float arithmethic." | bigNum result | bigNum := (100 factorial raisedTo: 3) + 1. "Add 1 so it is not a whole cube" self assert: bigNum asFloat isInfinite. "Otherwise, we chose a bad sample" result := bigNum nthRoot: 3. self assert: result class == Float. self deny: result isInfinite. self assert: result = 100 factorial asFloat. "No other float is closer. See following line" self assert: 100 factorial asFloat = (100 factorial+1) asFloat! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'nice 10/19/2011 21:03'! testNthRootTruncated | tooBigToBeAFloat large | tooBigToBeAFloat := 1 << 2000. self assert: (tooBigToBeAFloat nthRootTruncated: 100) equals: 1 << 20. self assert: (tooBigToBeAFloat + 1 nthRootTruncated: 100) equals: 1 << 20. self assert: (tooBigToBeAFloat - 1 nthRootTruncated: 100) equals: 1 << 20 - 1. large := -3 raisedTo: 255. self assert: (large nthRootTruncated: 17) equals: (-3 raisedTo: 15). self assert: (large + 11 nthRootTruncated: 17) equals: (-3 raisedTo: 15) + 1. self assert: (large - 11 nthRootTruncated: 17) equals: (-3 raisedTo: 15). 2 to: 10 do: [:thePower | 1 to: 10000 do: [:n | | theTruncatedRoot | theTruncatedRoot := n nthRootTruncated: thePower. self assert: (theTruncatedRoot raisedTo: thePower) <= n. self assert: (theTruncatedRoot + 1 raisedTo: thePower) > n]]! ! !IntegerTest methodsFor: 'test - rounding' stamp: 'GuillermoPolito 6/22/2012 14:52'! testRounding " self debug: #testRounding " self assert: (5 round: 2) equals: 5! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'SeanDeNigris 5/16/2012 21:08'! testBitLogic "This little suite of tests is designed to verify correct operation of most of Pharo's bit manipulation code, including two's complement representation of negative values. It was written in a hurry and is probably lacking several important checks." "self run: #testBitLogic" | n | "Shift 1 bit left then right and test for 1" 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) = 1]. "Shift -1 left then right and test for 1" 1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) = -1]. "And a single bit with -1 and test for same value" 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)]. "Verify that (n bitAnd: n negated) = n for single bits" 1 to: 100 do: [:i | n := 1 bitShift: i. self assert: (n bitAnd: n negated) = n]. "Verify that n negated = (n complemented + 1) for single bits" 1 to: 100 do: [:i | n := 1 bitShift: i. self assert: n negated = ((n bitXor: -1) + 1)]. "Verify that (n + n complemented) = -1 for single bits" 1 to: 100 do: [:i | n := 1 bitShift: i. self assert: (n + (n bitXor: -1)) = -1]. "Verify that n negated = (n complemented +1) for single bits" 1 to: 100 do: [:i | n := 1 bitShift: i. self assert: n negated = ((n bitXor: -1) + 1)].! ! !IntegerTest methodsFor: 'testing - arithmetic' stamp: 'mga 5/11/2006 15:41'! testCrossSumBase "self run: #testCrossSumBase" self assert: ( ((-20 to: 20) collect: [:each | each crossSumBase: 10]) asArray = #(2 10 9 8 7 6 5 4 3 2 1 9 8 7 6 5 4 3 2 1 0 1 2 3 4 5 6 7 8 9 1 2 3 4 5 6 7 8 9 10 2)). self assert: ( ((-20 to: 20) collect: [:each | each crossSumBase: 2]) asArray = #(2 3 2 2 1 4 3 3 2 3 2 2 1 3 2 2 1 2 1 1 0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4 1 2 2 3 2)). self should: [10 crossSumBase: 1] raise: AssertionFailure! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'SeanDeNigris 5/16/2012 21:09'! testHighBit | suite | self assert: (2r1110 highBit) equals: 4. self assert: (2r0110 highBit) equals: 3. self assert: (2r0000 highBit) equals: 0. suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}. suite := suite , (suite collect: [:e | e raisedTo: 20]). suite do: [:anInteger | | highBit shifted | highBit := 0. shifted := 1. [shifted > anInteger] whileFalse: [highBit := highBit+1. shifted := shifted bitShift: 1]. self assert: anInteger highBit = highBit].! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'GuillermoPolito 8/24/2010 19:14'! testIntegerReadsNotOkFromStream self should: [Integer readFrom: 'a23' readStream] raise: Error. self should: [Integer readFrom: '-a23' readStream] raise: Error. self should: [Integer readFrom: 'a3' readStream base: 8] raise: Error. self should: [Integer readFrom: '-a3' readStream base: 8] raise: Error.! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'md 2/12/2006 14:40'! testIsPrime "The following tests should return 'true'" self assert: 17 isPrime. self assert: 78901 isPrime. self assert: 104729 isPrime. self assert: 15485863 isPrime. self assert: 2038074743 isPrime. self assert: 29996224275833 isPrime. "The following tests should return 'false' (first 5 are Carmichael integers)" self deny: 561 isPrime. self deny: 2821 isPrime. self deny: 6601 isPrime. self deny: 10585 isPrime. self deny: 15841 isPrime. self deny: 256 isPrime. self deny: 29996224275831 isPrime.! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/29/2004 18:16'! testIntegerPadding "self run: #testIntegerPadding" self assert: (1 printStringBase: 10 length: 0 padded: false) = '1'. self assert: (1 printStringBase: 10 length: 1 padded: false) = '1'. self assert: (1 printStringBase: 10 length: 2 padded: false) = ' 1'. self assert: (1024 printStringBase: 10 length: 19 padded: false) = ' 1024'. self assert: (1024 printStringBase: 10 length: -1 padded: false) = '1024'. self assert: (1024 printStringBase: 10 length: 5 padded: false) = ' 1024'. self assert: (-1024 printStringBase: 10 length: 5 padded: false) = '-1024'. self assert: (-1024 printStringBase: 10 length: 19 padded: false) = ' -1024'. self assert: (1 printStringBase: 10 length: 0 padded: true) = '1'. self assert: (1 printStringBase: 10 length: 1 padded: true) = '1'. self assert: (1 printStringBase: 10 length: 2 padded: true) = '01'. self assert: (1024 printStringBase: 10 length: 19 padded: true) = '0000000000000001024'. self assert: (1024 printStringBase: 10 length: -1 padded: true) = '1024'. self assert: (1024 printStringBase: 10 length: 5 padded: true) = '01024'. self assert: (-1024 printStringBase: 10 length: 5 padded: true) = '-1024'. self assert: (-1024 printStringBase: 10 length: 19 padded: true) = '-000000000000001024'. self assert: (1 printStringBase: 16 length: 0 padded: false) = '1'. self assert: (1 printStringBase: 16 length: 1 padded: false) = '1'. self assert: (1 printStringBase: 16 length: 2 padded: false) = ' 1'. self assert: (2047 printStringBase: 16 length: 19 padded: false) = ' 7FF'. self assert: (2047 printStringBase: 16 length: -1 padded: false) = '7FF'. self assert: (2047 printStringBase: 16 length: 4 padded: false) = ' 7FF'. self assert: (-2047 printStringBase: 16 length: 4 padded: false) = '-7FF'. self assert: (-2047 printStringBase: 16 length: 19 padded: false) = ' -7FF'. self assert: (1 printStringBase: 16 length: 0 padded: true) = '1'. self assert: (1 printStringBase: 16 length: 1 padded: true) = '1'. self assert: (1 printStringBase: 16 length: 2 padded: true) = '01'. self assert: (2047 printStringBase: 16 length: 19 padded: true) = '00000000000000007FF'. self assert: (2047 printStringBase: 16 length: -1 padded: true) = '7FF'. self assert: (2047 printStringBase: 16 length: 4 padded: true) = '07FF'. self assert: (-2047 printStringBase: 16 length: 4 padded: true) = '-7FF'. self assert: (-2047 printStringBase: 16 length: 19 padded: true) = '-0000000000000007FF'. self assert: (1 storeStringBase: 10 length: 0 padded: false) = '1'. self assert: (1 storeStringBase: 10 length: 1 padded: false) = '1'. self assert: (1 storeStringBase: 10 length: 2 padded: false) = ' 1'. self assert: (1024 storeStringBase: 10 length: 19 padded: false) = ' 1024'. self assert: (1024 storeStringBase: 10 length: -1 padded: false) = '1024'. self assert: (1024 storeStringBase: 10 length: 5 padded: false) = ' 1024'. self assert: (-1024 storeStringBase: 10 length: 5 padded: false) = '-1024'. self assert: (-1024 storeStringBase: 10 length: 19 padded: false) = ' -1024'. self assert: (1 storeStringBase: 10 length: 0 padded: true) = '1'. self assert: (1 storeStringBase: 10 length: 1 padded: true) = '1'. self assert: (1 storeStringBase: 10 length: 2 padded: true) = '01'. self assert: (1024 storeStringBase: 10 length: 19 padded: true) = '0000000000000001024'. self assert: (1024 storeStringBase: 10 length: -1 padded: true) = '1024'. self assert: (1024 storeStringBase: 10 length: 5 padded: true) = '01024'. self assert: (-1024 storeStringBase: 10 length: 5 padded: true) = '-1024'. self assert: (-1024 storeStringBase: 10 length: 19 padded: true) = '-000000000000001024'. self assert: (1 storeStringBase: 16 length: 0 padded: false) = '16r1'. self assert: (1 storeStringBase: 16 length: 4 padded: false) = '16r1'. self assert: (1 storeStringBase: 16 length: 5 padded: false) = ' 16r1'. self assert: (2047 storeStringBase: 16 length: 19 padded: false) = ' 16r7FF'. self assert: (2047 storeStringBase: 16 length: -1 padded: false) = '16r7FF'. self assert: (2047 storeStringBase: 16 length: 7 padded: false) = ' 16r7FF'. self assert: (-2047 storeStringBase: 16 length: 7 padded: false) = '-16r7FF'. self assert: (-2047 storeStringBase: 16 length: 19 padded: false) = ' -16r7FF'. self assert: (1 storeStringBase: 16 length: 0 padded: true) = '16r1'. self assert: (1 storeStringBase: 16 length: 4 padded: true) = '16r1'. self assert: (1 storeStringBase: 16 length: 5 padded: true) = '16r01'. self assert: (2047 storeStringBase: 16 length: 19 padded: true) = '16r00000000000007FF'. self assert: (2047 storeStringBase: 16 length: -1 padded: true) = '16r7FF'. self assert: (2047 storeStringBase: 16 length: 7 padded: true) = '16r07FF'. self assert: (-2047 storeStringBase: 16 length: 7 padded: true) = '-16r7FF'. self assert: (-2047 storeStringBase: 16 length: 19 padded: true) = '-16r0000000000007FF'. ! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'SeanDeNigris 5/16/2012 20:26'! testBitShift self assert: 2r11 << 2 equals: 2r1100. self assert: (2r11 bitShift: 2) equals: 2r1100. self assert: 2r1011 >> 2 equals: 2r10. self assert: (2r1011 bitShift: -2) equals: 2r10.! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'SvenVanCaekenberghe 3/5/2014 22:16'! testPrintSeparatedByEverySignedOn | printer | printer := [ :integer :printSigned | String streamContents: [ :stream | integer printSeparatedBy: $. every: 3 signed: printSigned on: stream ] ]. self assert: (printer value: 123456789 value: false) equals: '123.456.789'. self assert: (printer value: -123456789 value: false) equals: '-123.456.789'. self assert: (printer value: 123456789 value: true) equals: '+123.456.789'. self assert: (printer value: -123456789 value: true) equals: '-123.456.789'! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'md 2/12/2006 14:36'! testLargePrimesUpTo | nn | nn := (2 raisedTo: 17) - 1. self deny: (Integer primesUpTo: nn) last = nn. self assert: (Integer primesUpTo: nn + 1) last = nn. ! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/30/2004 09:23'! testRomanPrinting self assert: 0 printStringRoman = ''. "No symbol for zero" self assert: 1 printStringRoman = 'I'. self assert: 2 printStringRoman = 'II'. self assert: 3 printStringRoman = 'III'. self assert: 4 printStringRoman = 'IV'. self assert: 5 printStringRoman = 'V'. self assert: 6 printStringRoman = 'VI'. self assert: 7 printStringRoman = 'VII'. self assert: 8 printStringRoman = 'VIII'. self assert: 9 printStringRoman = 'IX'. self assert: 10 printStringRoman = 'X'. self assert: 23 printStringRoman = 'XXIII'. self assert: 36 printStringRoman = 'XXXVI'. self assert: 49 printStringRoman = 'XLIX'. self assert: 62 printStringRoman = 'LXII'. self assert: 75 printStringRoman = 'LXXV'. self assert: 88 printStringRoman = 'LXXXVIII'. self assert: 99 printStringRoman = 'XCIX'. self assert: 100 printStringRoman = 'C'. self assert: 101 printStringRoman = 'CI'. self assert: 196 printStringRoman = 'CXCVI'. self assert: 197 printStringRoman = 'CXCVII'. self assert: 198 printStringRoman = 'CXCVIII'. self assert: 293 printStringRoman = 'CCXCIII'. self assert: 294 printStringRoman = 'CCXCIV'. self assert: 295 printStringRoman = 'CCXCV'. self assert: 390 printStringRoman = 'CCCXC'. self assert: 391 printStringRoman = 'CCCXCI'. self assert: 392 printStringRoman = 'CCCXCII'. self assert: 487 printStringRoman = 'CDLXXXVII'. self assert: 488 printStringRoman = 'CDLXXXVIII'. self assert: 489 printStringRoman = 'CDLXXXIX'. self assert: 584 printStringRoman = 'DLXXXIV'. self assert: 585 printStringRoman = 'DLXXXV'. self assert: 586 printStringRoman = 'DLXXXVI'. self assert: 681 printStringRoman = 'DCLXXXI'. self assert: 682 printStringRoman = 'DCLXXXII'. self assert: 683 printStringRoman = 'DCLXXXIII'. self assert: 778 printStringRoman = 'DCCLXXVIII'. self assert: 779 printStringRoman = 'DCCLXXIX'. self assert: 780 printStringRoman = 'DCCLXXX'. self assert: 875 printStringRoman = 'DCCCLXXV'. self assert: 876 printStringRoman = 'DCCCLXXVI'. self assert: 877 printStringRoman = 'DCCCLXXVII'. self assert: 972 printStringRoman = 'CMLXXII'. self assert: 973 printStringRoman = 'CMLXXIII'. self assert: 974 printStringRoman = 'CMLXXIV'. self assert: 1069 printStringRoman = 'MLXIX'. self assert: 1070 printStringRoman = 'MLXX'. self assert: 1071 printStringRoman = 'MLXXI'. self assert: 1166 printStringRoman = 'MCLXVI'. self assert: 1167 printStringRoman = 'MCLXVII'. self assert: 1168 printStringRoman = 'MCLXVIII'. self assert: 1263 printStringRoman = 'MCCLXIII'. self assert: 1264 printStringRoman = 'MCCLXIV'. self assert: 1265 printStringRoman = 'MCCLXV'. self assert: 1360 printStringRoman = 'MCCCLX'. self assert: 1361 printStringRoman = 'MCCCLXI'. self assert: 1362 printStringRoman = 'MCCCLXII'. self assert: 1457 printStringRoman = 'MCDLVII'. self assert: 1458 printStringRoman = 'MCDLVIII'. self assert: 1459 printStringRoman = 'MCDLIX'. self assert: 1554 printStringRoman = 'MDLIV'. self assert: 1555 printStringRoman = 'MDLV'. self assert: 1556 printStringRoman = 'MDLVI'. self assert: 1651 printStringRoman = 'MDCLI'. self assert: 1652 printStringRoman = 'MDCLII'. self assert: 1653 printStringRoman = 'MDCLIII'. self assert: 1748 printStringRoman = 'MDCCXLVIII'. self assert: 1749 printStringRoman = 'MDCCXLIX'. self assert: 1750 printStringRoman = 'MDCCL'. self assert: 1845 printStringRoman = 'MDCCCXLV'. self assert: 1846 printStringRoman = 'MDCCCXLVI'. self assert: 1847 printStringRoman = 'MDCCCXLVII'. self assert: 1942 printStringRoman = 'MCMXLII'. self assert: 1943 printStringRoman = 'MCMXLIII'. self assert: 1944 printStringRoman = 'MCMXLIV'. self assert: 2004 printStringRoman = 'MMIV'. self assert: -1 printStringRoman = '-I'. self assert: -2 printStringRoman = '-II'. self assert: -3 printStringRoman = '-III'. self assert: -4 printStringRoman = '-IV'. self assert: -5 printStringRoman = '-V'. self assert: -6 printStringRoman = '-VI'. self assert: -7 printStringRoman = '-VII'. self assert: -8 printStringRoman = '-VIII'. self assert: -9 printStringRoman = '-IX'. self assert: -10 printStringRoman = '-X'. ! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'nice 10/29/2011 15:13'! testBigReceiverInexactSqrt " IntegerTest new testBigReceiverInexactSqrt " "Inexact 3rd root (not a whole cube number), so a Float must be answered. However, receiver is too big for Float arithmethic." | bigNum result | bigNum := 100 factorial squared + 1. "Add 1 so it is not a whole square" self assert: bigNum asFloat isInfinite. "Otherwise, we chose a bad sample" result := bigNum sqrt. self assert: result class == Float. self deny: result isInfinite. self assert: result = 100 factorial asFloat. "No other float is closer. See following lines" self assert: (result successor asFraction squared - bigNum) abs >= (result asFraction squared - bigNum) abs. self assert: (result predecessor asFraction squared - bigNum) abs >= (result asFraction squared - bigNum) abs.! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'JohanBrichau 8/26/2010 14:21'! testReadFromWithError "Ensure that a string that does not represent an integer raises an error." self should: [Integer readFrom: 'invalid'] raise: Error ! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'CamilloBruni 8/31/2013 20:23'! testDegreeCos "self run: #testDegreeCos" 45 degreeCos. "Following tests use approximate equality, because cosine are generally evaluated using inexact Floating point arithmetic" self assert: (45 degreeCos squared - (1 / 2)) abs <= Float epsilon. self assert: (60 degreeCos - (1 / 2)) abs <= Float epsilon. self assert: (120 degreeCos + (1 / 2)) abs <= Float epsilon. -360 to: 360 do: [ :i | self assert: (i degreeCos closeTo: i degreesToRadians cos) ]. "Following tests use strict equality which is a requested property of degreeCos" -10 to: 10 do: [ :k | self assert: (k * 360 + 90) degreeCos = 0. self assert: (k * 360 - 90) degreeCos = 0. self assert: (k * 360 + 180) degreeCos + 1 = 0. self assert: (k * 360) degreeCos - 1 = 0 ]! ! !IntegerTest methodsFor: 'private' stamp: 'jmv 10/11/2011 08:14'! assert: a classAndValueEquals: b self assert: a class = b class. self assert: a = b! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'nice 2/15/2008 22:23'! testNumberOfDigits 2 to: 32 do: [:b | 1 to: 1000//b do: [:n | | bRaisedToN | bRaisedToN := b raisedTo: n. self assert: (bRaisedToN - 1 numberOfDigitsInBase: b) = n. self assert: (bRaisedToN numberOfDigitsInBase: b) = (n+1). self assert: (bRaisedToN + 1 numberOfDigitsInBase: b) = (n+1). self assert: (bRaisedToN negated + 1 numberOfDigitsInBase: b) = n. self assert: (bRaisedToN negated numberOfDigitsInBase: b) = (n+1). self assert: (bRaisedToN negated - 1 numberOfDigitsInBase: b) = (n+1).]]. ! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'nice 12/11/2012 19:53'! testFloorLog self assert: (100 floorLog: 10) = 2. self assert: (((2 raisedTo: Float emax + 3) floorLog: 10) = (2 log*(Float emax + 3)) floor) description: 'Integer>>floorLog: should not overflow'! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'nice 4/28/2012 16:48'! testReadFrom "Ensure remaining characters in a stream are not lost when parsing an integer." | rs i s | rs := '123s could be confused with a ScaledDecimal' readStream. i := Integer readFrom: rs. self assert: i = 123. s := rs upToEnd. self assert: 's could be confused with a ScaledDecimal' = s. rs := '123.s could be confused with a ScaledDecimal' readStream. i := Integer readFrom: rs. self assert: i = 123. s := rs upToEnd. self assert: '.s could be confused with a ScaledDecimal' = s! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:46'! testDifferentBases "self run: #testDifferentBases" "| value | 2 to: 36 do: [:each| value := 0. 1 to: each-1 do: [:n| value := value + (n * (each raisedToInteger: n))]. value := value negated. Transcript tab; show: 'self assert: (', value printString, ' printStringBase: ', each printString, ') = ''', (value printStringBase: each), '''.'; cr. Transcript tab; show: 'self assert: (', value printString, ' radix: ', each printString, ') = ''', (value radix: each), '''.'; cr. Transcript tab; show: 'self assert: ', value printString, ' printStringHex = ''', (value printStringBase: 16), '''.'; cr. Transcript tab; show: 'self assert: (', value printString, ' storeStringBase: ', each printString, ') = ''', (value storeStringBase: each), '''.'; cr. Transcript tab; show: 'self assert: ', value printString, ' storeStringHex = ''', (value storeStringBase: 16), '''.'; cr. ]. " self assert: 2r10 = 2. self assert: 3r210 = 21. self assert: 4r3210 = 228. self assert: 5r43210 = 2930. self assert: 6r543210 = 44790. self assert: 7r6543210 = 800667. self assert: 8r76543210 = 16434824. self assert: 9r876543210 = 381367044. self assert: 10r9876543210 = 9876543210. self assert: 11rA9876543210 = 282458553905. self assert: 12rBA9876543210 = 8842413667692. self assert: 13rCBA9876543210 = 300771807240918. self assert: 14rDCBA9876543210 = 11046255305880158. self assert: 15rEDCBA9876543210 = 435659737878916215. self assert: 16rFEDCBA9876543210 = 18364758544493064720. self assert: 17rGFEDCBA9876543210 = 824008854613343261192. self assert: 18rHGFEDCBA9876543210 = 39210261334551566857170. self assert: 19rIHGFEDCBA9876543210 = 1972313422155189164466189. self assert: 20rJIHGFEDCBA9876543210 = 104567135734072022160664820. self assert: 21rKJIHGFEDCBA9876543210 = 5827980550840017565077671610. self assert: 22rLKJIHGFEDCBA9876543210 = 340653664490377789692799452102. self assert: 23rMLKJIHGFEDCBA9876543210 = 20837326537038308910317109288851. self assert: 24rNMLKJIHGFEDCBA9876543210 = 1331214537196502869015340298036888. self assert: 25rONMLKJIHGFEDCBA9876543210 = 88663644327703473714387251271141900. self assert: 26rPONMLKJIHGFEDCBA9876543210 = 6146269788878825859099399609538763450. self assert: 27rQPONMLKJIHGFEDCBA9876543210 = 442770531899482980347734468443677777577. self assert: 28rRQPONMLKJIHGFEDCBA9876543210 = 33100056003358651440264672384704297711484. self assert: 29rSRQPONMLKJIHGFEDCBA9876543210 = 2564411043271974895869785066497940850811934. self assert: 30rTSRQPONMLKJIHGFEDCBA9876543210 = 205646315052919334126040428061831153388822830. self assert: 31rUTSRQPONMLKJIHGFEDCBA9876543210 = 17050208381689099029767742314582582184093573615. self assert: 32rVUTSRQPONMLKJIHGFEDCBA9876543210 = 1459980823972598128486511383358617792788444579872. self assert: 33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = 128983956064237823710866404905431464703849549412368. self assert: 34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 11745843093701610854378775891116314824081102660800418. self assert: 35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 1101553773143634726491620528194292510495517905608180485. self assert: 36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 106300512100105327644605138221229898724869759421181854980. self assert: -2r10 = -2. self assert: -3r210 = -21. self assert: -4r3210 = -228. self assert: -5r43210 = -2930. self assert: -6r543210 = -44790. self assert: -7r6543210 = -800667. self assert: -8r76543210 = -16434824. self assert: -9r876543210 = -381367044. self assert: -10r9876543210 = -9876543210. self assert: -11rA9876543210 = -282458553905. self assert: -12rBA9876543210 = -8842413667692. self assert: -13rCBA9876543210 = -300771807240918. self assert: -14rDCBA9876543210 = -11046255305880158. self assert: -15rEDCBA9876543210 = -435659737878916215. self assert: -16rFEDCBA9876543210 = -18364758544493064720. self assert: -17rGFEDCBA9876543210 = -824008854613343261192. self assert: -18rHGFEDCBA9876543210 = -39210261334551566857170. self assert: -19rIHGFEDCBA9876543210 = -1972313422155189164466189. self assert: -20rJIHGFEDCBA9876543210 = -104567135734072022160664820. self assert: -21rKJIHGFEDCBA9876543210 = -5827980550840017565077671610. self assert: -22rLKJIHGFEDCBA9876543210 = -340653664490377789692799452102. self assert: -23rMLKJIHGFEDCBA9876543210 = -20837326537038308910317109288851. self assert: -24rNMLKJIHGFEDCBA9876543210 = -1331214537196502869015340298036888. self assert: -25rONMLKJIHGFEDCBA9876543210 = -88663644327703473714387251271141900. self assert: -26rPONMLKJIHGFEDCBA9876543210 = -6146269788878825859099399609538763450. self assert: -27rQPONMLKJIHGFEDCBA9876543210 = -442770531899482980347734468443677777577. self assert: -28rRQPONMLKJIHGFEDCBA9876543210 = -33100056003358651440264672384704297711484. self assert: -29rSRQPONMLKJIHGFEDCBA9876543210 = -2564411043271974895869785066497940850811934. self assert: -30rTSRQPONMLKJIHGFEDCBA9876543210 = -205646315052919334126040428061831153388822830. self assert: -31rUTSRQPONMLKJIHGFEDCBA9876543210 = -17050208381689099029767742314582582184093573615. self assert: -32rVUTSRQPONMLKJIHGFEDCBA9876543210 = -1459980823972598128486511383358617792788444579872. self assert: -33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = -128983956064237823710866404905431464703849549412368. self assert: -34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -11745843093701610854378775891116314824081102660800418. self assert: -35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -1101553773143634726491620528194292510495517905608180485. self assert: -36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -106300512100105327644605138221229898724869759421181854980.! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'laza 3/30/2004 11:52'! testPositiveIntegerPrinting "self run: #testPositiveIntegerPrinting" self assert: 0 printString = '0'. self assert: 0 printStringHex = '0'. self assert: 0 storeStringHex = '16r0'. self assert: (2 printStringBase: 2) = '10'. self assert: (2 radix: 2) = '10'. self assert: 2 printStringHex = '2'. self assert: (2 storeStringBase: 2) = '2r10'. self assert: 2 storeStringHex = '16r2'. self assert: (21 printStringBase: 3) = '210'. self assert: (21 radix: 3) = '210'. self assert: 21 printStringHex = '15'. self assert: (21 storeStringBase: 3) = '3r210'. self assert: 21 storeStringHex = '16r15'. self assert: (228 printStringBase: 4) = '3210'. self assert: (228 radix: 4) = '3210'. self assert: 228 printStringHex = 'E4'. self assert: (228 storeStringBase: 4) = '4r3210'. self assert: 228 storeStringHex = '16rE4'. self assert: (2930 printStringBase: 5) = '43210'. self assert: (2930 radix: 5) = '43210'. self assert: 2930 printStringHex = 'B72'. self assert: (2930 storeStringBase: 5) = '5r43210'. self assert: 2930 storeStringHex = '16rB72'. self assert: (44790 printStringBase: 6) = '543210'. self assert: (44790 radix: 6) = '543210'. self assert: 44790 printStringHex = 'AEF6'. self assert: (44790 storeStringBase: 6) = '6r543210'. self assert: 44790 storeStringHex = '16rAEF6'. self assert: (800667 printStringBase: 7) = '6543210'. self assert: (800667 radix: 7) = '6543210'. self assert: 800667 printStringHex = 'C379B'. self assert: (800667 storeStringBase: 7) = '7r6543210'. self assert: 800667 storeStringHex = '16rC379B'. self assert: (16434824 printStringBase: 8) = '76543210'. self assert: (16434824 radix: 8) = '76543210'. self assert: 16434824 printStringHex = 'FAC688'. self assert: (16434824 storeStringBase: 8) = '8r76543210'. self assert: 16434824 storeStringHex = '16rFAC688'. self assert: (381367044 printStringBase: 9) = '876543210'. self assert: (381367044 radix: 9) = '876543210'. self assert: 381367044 printStringHex = '16BB3304'. self assert: (381367044 storeStringBase: 9) = '9r876543210'. self assert: 381367044 storeStringHex = '16r16BB3304'. self assert: (9876543210 printStringBase: 10) = '9876543210'. self assert: (9876543210 radix: 10) = '9876543210'. self assert: 9876543210 printStringHex = '24CB016EA'. self assert: (9876543210 storeStringBase: 10) = '9876543210'. self assert: 9876543210 storeStringHex = '16r24CB016EA'. self assert: (282458553905 printStringBase: 11) = 'A9876543210'. self assert: (282458553905 radix: 11) = 'A9876543210'. self assert: 282458553905 printStringHex = '41C3D77E31'. self assert: (282458553905 storeStringBase: 11) = '11rA9876543210'. self assert: 282458553905 storeStringHex = '16r41C3D77E31'. self assert: (8842413667692 printStringBase: 12) = 'BA9876543210'. self assert: (8842413667692 radix: 12) = 'BA9876543210'. self assert: 8842413667692 printStringHex = '80AC8ECF56C'. self assert: (8842413667692 storeStringBase: 12) = '12rBA9876543210'. self assert: 8842413667692 storeStringHex = '16r80AC8ECF56C'. self assert: (300771807240918 printStringBase: 13) = 'CBA9876543210'. self assert: (300771807240918 radix: 13) = 'CBA9876543210'. self assert: 300771807240918 printStringHex = '1118CE4BAA2D6'. self assert: (300771807240918 storeStringBase: 13) = '13rCBA9876543210'. self assert: 300771807240918 storeStringHex = '16r1118CE4BAA2D6'. self assert: (11046255305880158 printStringBase: 14) = 'DCBA9876543210'. self assert: (11046255305880158 radix: 14) = 'DCBA9876543210'. self assert: 11046255305880158 printStringHex = '273E82BB9AF25E'. self assert: (11046255305880158 storeStringBase: 14) = '14rDCBA9876543210'. self assert: 11046255305880158 storeStringHex = '16r273E82BB9AF25E'. self assert: (435659737878916215 printStringBase: 15) = 'EDCBA9876543210'. self assert: (435659737878916215 radix: 15) = 'EDCBA9876543210'. self assert: 435659737878916215 printStringHex = '60BC6392F366C77'. self assert: (435659737878916215 storeStringBase: 15) = '15rEDCBA9876543210'. self assert: 435659737878916215 storeStringHex = '16r60BC6392F366C77'. self assert: (18364758544493064720 printStringBase: 16) = 'FEDCBA9876543210'. self assert: (18364758544493064720 radix: 16) = 'FEDCBA9876543210'. self assert: 18364758544493064720 printStringHex = 'FEDCBA9876543210'. self assert: (18364758544493064720 storeStringBase: 16) = '16rFEDCBA9876543210'. self assert: 18364758544493064720 storeStringHex = '16rFEDCBA9876543210'. self assert: (824008854613343261192 printStringBase: 17) = 'GFEDCBA9876543210'. self assert: (824008854613343261192 radix: 17) = 'GFEDCBA9876543210'. self assert: 824008854613343261192 printStringHex = '2CAB6B877C1CD2D208'. self assert: (824008854613343261192 storeStringBase: 17) = '17rGFEDCBA9876543210'. self assert: 824008854613343261192 storeStringHex = '16r2CAB6B877C1CD2D208'. self assert: (39210261334551566857170 printStringBase: 18) = 'HGFEDCBA9876543210'. self assert: (39210261334551566857170 radix: 18) = 'HGFEDCBA9876543210'. self assert: 39210261334551566857170 printStringHex = '84D97AFCAE81415B3D2'. self assert: (39210261334551566857170 storeStringBase: 18) = '18rHGFEDCBA9876543210'. self assert: 39210261334551566857170 storeStringHex = '16r84D97AFCAE81415B3D2'. self assert: (1972313422155189164466189 printStringBase: 19) = 'IHGFEDCBA9876543210'. self assert: (1972313422155189164466189 radix: 19) = 'IHGFEDCBA9876543210'. self assert: 1972313422155189164466189 printStringHex = '1A1A75329C5C6FC00600D'. self assert: (1972313422155189164466189 storeStringBase: 19) = '19rIHGFEDCBA9876543210'. self assert: 1972313422155189164466189 storeStringHex = '16r1A1A75329C5C6FC00600D'. self assert: (104567135734072022160664820 printStringBase: 20) = 'JIHGFEDCBA9876543210'. self assert: (104567135734072022160664820 radix: 20) = 'JIHGFEDCBA9876543210'. self assert: 104567135734072022160664820 printStringHex = '567EF3C9636D242A8C68F4'. self assert: (104567135734072022160664820 storeStringBase: 20) = '20rJIHGFEDCBA9876543210'. self assert: 104567135734072022160664820 storeStringHex = '16r567EF3C9636D242A8C68F4'. self assert: (5827980550840017565077671610 printStringBase: 21) = 'KJIHGFEDCBA9876543210'. self assert: (5827980550840017565077671610 radix: 21) = 'KJIHGFEDCBA9876543210'. self assert: 5827980550840017565077671610 printStringHex = '12D4CAE2B8A09BCFDBE30EBA'. self assert: (5827980550840017565077671610 storeStringBase: 21) = '21rKJIHGFEDCBA9876543210'. self assert: 5827980550840017565077671610 storeStringHex = '16r12D4CAE2B8A09BCFDBE30EBA'. self assert: (340653664490377789692799452102 printStringBase: 22) = 'LKJIHGFEDCBA9876543210'. self assert: (340653664490377789692799452102 radix: 22) = 'LKJIHGFEDCBA9876543210'. self assert: 340653664490377789692799452102 printStringHex = '44CB61B5B47E1A5D8F88583C6'. self assert: (340653664490377789692799452102 storeStringBase: 22) = '22rLKJIHGFEDCBA9876543210'. self assert: 340653664490377789692799452102 storeStringHex = '16r44CB61B5B47E1A5D8F88583C6'. self assert: (20837326537038308910317109288851 printStringBase: 23) = 'MLKJIHGFEDCBA9876543210'. self assert: (20837326537038308910317109288851 radix: 23) = 'MLKJIHGFEDCBA9876543210'. self assert: 20837326537038308910317109288851 printStringHex = '1070108876456E0EF115B389F93'. self assert: (20837326537038308910317109288851 storeStringBase: 23) = '23rMLKJIHGFEDCBA9876543210'. self assert: 20837326537038308910317109288851 storeStringHex = '16r1070108876456E0EF115B389F93'. self assert: (1331214537196502869015340298036888 printStringBase: 24) = 'NMLKJIHGFEDCBA9876543210'. self assert: (1331214537196502869015340298036888 radix: 24) = 'NMLKJIHGFEDCBA9876543210'. self assert: 1331214537196502869015340298036888 printStringHex = '41A24A285154B026B6ED206C6698'. self assert: (1331214537196502869015340298036888 storeStringBase: 24) = '24rNMLKJIHGFEDCBA9876543210'. self assert: 1331214537196502869015340298036888 storeStringHex = '16r41A24A285154B026B6ED206C6698'. self assert: (88663644327703473714387251271141900 printStringBase: 25) = 'ONMLKJIHGFEDCBA9876543210'. self assert: (88663644327703473714387251271141900 radix: 25) = 'ONMLKJIHGFEDCBA9876543210'. self assert: 88663644327703473714387251271141900 printStringHex = '111374860A2C6CEBE5999630398A0C'. self assert: (88663644327703473714387251271141900 storeStringBase: 25) = '25rONMLKJIHGFEDCBA9876543210'. self assert: 88663644327703473714387251271141900 storeStringHex = '16r111374860A2C6CEBE5999630398A0C'. self assert: (6146269788878825859099399609538763450 printStringBase: 26) = 'PONMLKJIHGFEDCBA9876543210'. self assert: (6146269788878825859099399609538763450 radix: 26) = 'PONMLKJIHGFEDCBA9876543210'. self assert: 6146269788878825859099399609538763450 printStringHex = '49FBA7F30B0F48BD14E6A99BD8ADABA'. self assert: (6146269788878825859099399609538763450 storeStringBase: 26) = '26rPONMLKJIHGFEDCBA9876543210'. self assert: 6146269788878825859099399609538763450 storeStringHex = '16r49FBA7F30B0F48BD14E6A99BD8ADABA'. self assert: (442770531899482980347734468443677777577 printStringBase: 27) = 'QPONMLKJIHGFEDCBA9876543210'. self assert: (442770531899482980347734468443677777577 radix: 27) = 'QPONMLKJIHGFEDCBA9876543210'. self assert: 442770531899482980347734468443677777577 printStringHex = '14D1A80A997343640C1145A073731DEA9'. self assert: (442770531899482980347734468443677777577 storeStringBase: 27) = '27rQPONMLKJIHGFEDCBA9876543210'. self assert: 442770531899482980347734468443677777577 storeStringHex = '16r14D1A80A997343640C1145A073731DEA9'. self assert: (33100056003358651440264672384704297711484 printStringBase: 28) = 'RQPONMLKJIHGFEDCBA9876543210'. self assert: (33100056003358651440264672384704297711484 radix: 28) = 'RQPONMLKJIHGFEDCBA9876543210'. self assert: 33100056003358651440264672384704297711484 printStringHex = '6145B6E6DACFA25D0E936F51D25932377C'. self assert: (33100056003358651440264672384704297711484 storeStringBase: 28) = '28rRQPONMLKJIHGFEDCBA9876543210'. self assert: 33100056003358651440264672384704297711484 storeStringHex = '16r6145B6E6DACFA25D0E936F51D25932377C'. self assert: (2564411043271974895869785066497940850811934 printStringBase: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'. self assert: (2564411043271974895869785066497940850811934 radix: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'. self assert: 2564411043271974895869785066497940850811934 printStringHex = '1D702071CBA4A1597D4DD37E95EFAC79241E'. self assert: (2564411043271974895869785066497940850811934 storeStringBase: 29) = '29rSRQPONMLKJIHGFEDCBA9876543210'. self assert: 2564411043271974895869785066497940850811934 storeStringHex = '16r1D702071CBA4A1597D4DD37E95EFAC79241E'. self assert: (205646315052919334126040428061831153388822830 printStringBase: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'. self assert: (205646315052919334126040428061831153388822830 radix: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'. self assert: 205646315052919334126040428061831153388822830 printStringHex = '938B4343B54B550989989D02998718FFB212E'. self assert: (205646315052919334126040428061831153388822830 storeStringBase: 30) = '30rTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 205646315052919334126040428061831153388822830 storeStringHex = '16r938B4343B54B550989989D02998718FFB212E'. self assert: (17050208381689099029767742314582582184093573615 printStringBase: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (17050208381689099029767742314582582184093573615 radix: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 17050208381689099029767742314582582184093573615 printStringHex = '2FC8ECB1521BA16D24A69E976D53873E2C661EF'. self assert: (17050208381689099029767742314582582184093573615 storeStringBase: 31) = '31rUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 17050208381689099029767742314582582184093573615 storeStringHex = '16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'. self assert: (1459980823972598128486511383358617792788444579872 printStringBase: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (1459980823972598128486511383358617792788444579872 radix: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 1459980823972598128486511383358617792788444579872 printStringHex = 'FFBBCDEB38BDAB49CA307B9AC5A928398A418820'. self assert: (1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '32rVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 1459980823972598128486511383358617792788444579872 storeStringHex = '16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'. self assert: (128983956064237823710866404905431464703849549412368 printStringBase: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (128983956064237823710866404905431464703849549412368 radix: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 128983956064237823710866404905431464703849549412368 printStringHex = '584120A0328DE272AB055A8AA003CE4A559F223810'. self assert: (128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '33rWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 128983956064237823710866404905431464703849549412368 storeStringHex = '16r584120A0328DE272AB055A8AA003CE4A559F223810'. self assert: (11745843093701610854378775891116314824081102660800418 printStringBase: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (11745843093701610854378775891116314824081102660800418 radix: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 11745843093701610854378775891116314824081102660800418 printStringHex = '1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. self assert: (11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 11745843093701610854378775891116314824081102660800418 storeStringHex = '16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. self assert: (1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (1101553773143634726491620528194292510495517905608180485 radix: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 1101553773143634726491620528194292510495517905608180485 printStringHex = 'B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. self assert: (1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 1101553773143634726491620528194292510495517905608180485 storeStringHex = '16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. self assert: (106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (106300512100105327644605138221229898724869759421181854980 radix: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 106300512100105327644605138221229898724869759421181854980 printStringHex = '455D441E55A37239AB4C303189576071AF5578FFCA80504'. self assert: (106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 106300512100105327644605138221229898724869759421181854980 storeStringHex = '16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'nice 5/28/2010 21:28'! testLn self assert: (100 ln closeTo: 10 ln*2). self assert: ((2 raisedTo: Float emax + 3) ln closeTo: 2 ln*(Float emax + 3)) description: 'Integer>>ln should not overflow'! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'nice 2/15/2008 22:31'! testPrintStringBase 2 to: 32 do: [:b | 1 to: 1000//b do: [:n | | bRaisedToN | bRaisedToN := b raisedTo: n. self assert: (bRaisedToN - 1 printStringBase: b) = (String new: n withAll: (Character digitValue: b-1)). self assert: (bRaisedToN printStringBase: b) = ('1' , (String new: n withAll: $0)). self assert: (bRaisedToN negated + 1 printStringBase: b) = ('-' , (String new: n withAll: (Character digitValue: b-1))). self assert: (bRaisedToN negated printStringBase: b) = ('-1' , (String new: n withAll: $0))]]. ! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'nice 7/8/2008 02:44'! testHighBitOfMagnitude | suite | suite := (0 to: 1024) asArray , #(16rFDFD 16rFFFF 16r1000 16r1000000 16r1000001 16r70000000 16r7AFAFAFA ) , {SmallInteger maxVal . SmallInteger maxVal+1}. suite := suite , (suite collect: [:e | e raisedTo: 20]). suite do: [:anInteger | | highBit shifted | highBit := 0. shifted := 1. [shifted > anInteger] whileFalse: [highBit := highBit+1. shifted := shifted bitShift: 1]. self assert: anInteger highBitOfMagnitude = highBit. self assert: anInteger negated highBitOfMagnitude = highBit].! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'StephaneDucasse 5/28/2011 13:40'! testStringAsNumber "This covers parsing in Number>>readFrom: Trailing decimal points should be ignored." self assert: ('123' asNumber = 123). self assert: ('-123' asNumber = -123). self assert: ('123.' asNumber = 123). self assert: ('-123.' asNumber = -123). self assert: ('123This is not to be read' asNumber = 123). self assert: ('123s could be confused with a ScaledDecimal' asNumber = 123). self assert: ('123e could be confused with a Float' asNumber = 123). ! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/13/2011 21:45'! testRaisedToErrorConditions " IntegerTest new testRaisedToErrorConditions " self should: [ -2 raisedTo: 1/4 ] raise: ArithmeticError. self should: [ -2 raisedTo: 1.24 ] raise: ArithmeticError.! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'StephaneDucasse 12/1/2009 14:40'! testIsPrime2 "Not primes:" #(-100 -5 -3 -2 -1 0 1) do: [ :each | self deny: each isPrime ]. "The following tests should return 'true'" #(17 78901 104729 15485863 2038074743) do: [ :each | self assert: each isPrime ]. "The following tests should return 'false' (first 5 are Carmichael integers)" #(561 2821 6601 10585 15841 256 29996224275831) do: [ :each | self deny: each isPrime ].! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'ul 11/25/2009 02:49'! testIsProbablyPrime "Not primes:" #(-100 -5 -3 -2 -1 0 1) do: [ :each | self deny: each isProbablyPrime ]. "The following tests should return 'true'" #(17 78901 104729 15485863 2038074743 29996224275833) do: [ :each | self assert: each isProbablyPrime ]. "The following tests should return 'false' (first 5 are Carmichael integers)" #(561 2821 6601 10585 15841 256 29996224275831) do: [ :each | self deny: each isProbablyPrime ].! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'SeanDeNigris 5/16/2012 20:17'! testBitAt | trials bitSequence2 | self assert: (2r10 bitAt: 1) equals: 0. self assert: (2r10 bitAt: 2) equals: 1. self assert: ((1 to: 100) allSatisfy: [:i | (0 bitAt: i) = 0]) description: 'all bits of zero are set to zero'. self assert: ((1 to: 100) allSatisfy: [:i | (-1 bitAt: i) = 1]) description: 'In two complements, all bits of -1 are set to 1'. trials := #( '2r10010011' '2r11100100' '2r10000000' '2r0000101011011001' '2r1000101011011001' '2r0101010101011000' '2r0010011110110010' '2r0010011000000000' '2r00100111101100101000101011011001' '2r01110010011110110010100110101101' '2r10101011101011001010000010110110' '2r10101000000000000000000000000000' '2r0010101110101001110010100000101101100010011110110010100010101100' '2r1010101110101100101000001011011000100111101100101000101011011001' '2r1010101110101000000000000000000000000000000000000000000000000000'). trials do: [:bitSequence | | aNumber | aNumber := Number readFrom: bitSequence. bitSequence2 := (bitSequence size - 2 to: 1 by: -1) inject: '2r' into: [:string :i | string copyWith: (Character digitValue: (aNumber bitAt: i))]. self assert: bitSequence2 = bitSequence]. trials do: [:bitSequence | | bitInvert | bitInvert := -1 - (Number readFrom: bitSequence). bitSequence2 := (bitSequence size - 2 to: 1 by: -1) inject: '2r' into: [:string :i | string copyWith: (Character digitValue: 1 - (bitInvert bitAt: i))]. self assert: bitSequence2 = bitSequence description: '-1-x is similar to a bitInvert operation in two complement']! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'CamilloBruni 8/31/2013 20:23'! testNthRoot 1 << 2000 nthRoot: 100. self assert: (1 << 2000 nthRoot: 100) equals: 1 << 20! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'ul 11/25/2009 03:01'! testSqrtFloor #(-1234567890123 -10 -5 -1) do: [ :each | self should: [ each sqrtFloor ] raise: Error ]. #( 0 1 2 3 4 5 10 16 30 160479924 386234481 501619156 524723498 580855366 766098594 834165249 1020363860 1042083924 1049218924 1459774772895569 3050005981408238 4856589481837079 5650488387708463 7831037396100244) do: [ :each | self assert: each asFloat sqrt floor = each sqrtFloor ] ! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'nice 3/12/2014 00:16'! testNthRootExactness | inexactRoots largeExactPowersOf6 | largeExactPowersOf6 := (2 to: 100) collect: [:k | k raisedTo: 66]. inexactRoots := largeExactPowersOf6 reject: [:e | (e nthRoot: 6) isInteger]. self assert: inexactRoots isEmpty description: 'Failed to find the exact 6th root of these numbers'! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'HenrikSperreJohansen 1/19/2012 16:02'! testIsPowerOfTwo "LargeNegativeIntegers" self deny: (2 raisedTo: 80) negated isPowerOfTwo. "Negative SmallIntegers" self deny: (-1 isPowerOfTwo). " 0, incase implementation has forgotten edge case" self deny: (0 isPowerOfTwo). "Positive SmallIntegers" self assert: (1 isPowerOfTwo). self assert: (2 isPowerOfTwo). self deny: (3 isPowerOfTwo). self assert: (4 isPowerOfTwo). self deny: (5 isPowerOfTwo). " LargePositiveIntegers" self deny: ((2 raisedTo: 80) - 1) isPowerOfTwo. self assert: (2 raisedTo: 80) isPowerOfTwo. self deny: ((2 raisedTo: 80) + 1) isPowerOfTwo! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'SeanDeNigris 5/16/2012 20:34'! testBitMask self assert: (2r11 allMask: 2r11). self deny: (2r10 allMask: 2r11). self deny: (2r01 allMask: 2r11). self assert: (2r10 anyMask: 2r11). self assert: (2r01 anyMask: 2r11). self deny: (2r00 anyMask: 2r11).! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'StephaneDucasse 6/9/2012 22:58'! testNew self should: [Integer new] raise: self defaultTestError. ! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'al 7/21/2008 22:36'! testBadBase "This used to get into an endless loop. See Pharo #114" self should: [2 printStringBase: 1] raise: Error.! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'sd 6/5/2005 08:45'! testIsInteger self assert: (0 isInteger). ! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'SeanDeNigris 5/16/2012 20:42'! testBitXor self assert: (2r1100 bitXor: 2r1010) equals: 2r0110.! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'SeanDeNigris 5/16/2012 20:20'! testBitOr self assert: (2r0101 | 2r1010) equals: 2r1111. self assert: (2r0101 bitOr: 2r1010) equals: 2r1111.! ! !IntegerTest methodsFor: 'tests - bitLogic' stamp: 'SeanDeNigris 5/16/2012 20:41'! testBitString "self debug: #testBitString" self assert: 2 bitString = '0000000000000000000000000000010'. self assert: -1 bitString = '1111111111111111111111111111111'. self assert: -2 bitString = '1111111111111111111111111111110'. self assert: 2 bitStringLength = 31. "32 minus 1 for immediate encoding = 31 = 30 for number + 1 for sign" self assert: 2 bitStringLength = (SmallInteger maxVal highBit + 1).! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'md 4/21/2003 16:17'! testEven self deny: (1073741825 even). self assert: (1073741824 even). ! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/11/2011 22:09'! testExactSqrt " IntegerTest new testExactSqrt " self assert: 4 sqrt classAndValueEquals: 2. self assert: 9 sqrt classAndValueEquals: 3. self assert: Float maxExactInteger squared sqrt classAndValueEquals: Float maxExactInteger. self assert: (Float maxExactInteger+1) squared sqrt classAndValueEquals: Float maxExactInteger+1. #( 1 5 29 135 1234 567890 123123123 456456456456 98765432109876543210987654321 987123987123987123987123987123987123987123987123) do: [ :i | self assert: i squared sqrt classAndValueEquals: i ]! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'GuillermoPolito 8/24/2010 19:06'! testIntegerReadsNotOkFromString self should: [Integer readFrom: 'aaa'] raise: Error. self should: [Integer readFrom: '-aaa'] raise: Error. self should: [Integer readFrom: 'a3' base: 8] raise: Error.! ! !IntegerTest methodsFor: 'tests - instance creation' stamp: 'sd 6/5/2005 08:48'! testCreationFromBytes1 "self run: #testCreationFromBytes1" "it is illegal for a LargeInteger to be less than SmallInteger maxVal." "here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs SmallInteger maxVal as an instance of SmallInteger. " | maxSmallInt hexString byte1 byte2 byte3 byte4 builtInteger | maxSmallInt := SmallInteger maxVal. hexString := maxSmallInt printStringHex. self assert: hexString size = 8. byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16. byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16. byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16. byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16. builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4. self assert: builtInteger = maxSmallInt. self assert: builtInteger class = SmallInteger ! ! !IntegerTest methodsFor: 'tests - printing' stamp: 'StephaneDucasse 7/31/2010 19:47'! testHex self assert: 0 hex = '16r0'. self assert: 12 hex = '16rC'. self assert: 1234 hex = '16r4D2'.! ! !IntegerTest methodsFor: 'tests - mathematical functions' stamp: 'jmv 10/13/2011 09:09'! testNthRootErrorConditions " IntegerTest new testExactRaisedToErrorConditions " self should: [ -2 nthRoot: 1/4 ] raise: ArithmeticError. self should: [ -2 nthRoot: 1.24 ] raise: ArithmeticError.! ! !InteractiveResolver commentStamp: 'cwp 11/18/2009 11:56'! I resolve origins by consulting the user. I maintain a cache of the user's responses.! !InteractiveResolver methodsFor: 'resolving' stamp: 'cwp 10/27/2009 10:12'! resolve: origin ^ cache at: origin ifAbsent: [self unknownOrigin: origin] ! ! !InteractiveResolver methodsFor: 'resolving' stamp: 'EstebanLorenzano 4/2/2012 11:38'! unknownOrigin: origin | reference | ^ (next ifNotNil: [next resolve: origin]) ifNil: [reference := ResolutionRequest for: origin. reference ifNotNil: [cache at: origin put: reference]]! ! !InteractiveResolver methodsFor: 'initialization' stamp: 'cwp 10/27/2009 10:29'! initialize self flushLocalCache! ! !InteractiveResolver methodsFor: 'accessing' stamp: 'cwp 10/27/2009 10:29'! flushLocalCache cache := IdentityDictionary new! ! !InteractiveResolverTest commentStamp: 'TorstenBergmann 1/31/2014 11:36'! SUnit tests for InteractiveResolver! !InteractiveResolverTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/2/2012 11:38'! createResolver ^ InteractiveResolver new! ! !InteractiveResolverTest methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 14:26'! home ^ FileLocator imageDirectory resolve! ! !InteractiveResolverTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testCached [ resolver resolve: #home ] on: ResolutionRequest do: [ :req | req resume: self home ]. self assertOriginResolves: #home! ! !InteractiveResolverTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:38'! testNew [self assertOriginResolves: #home] on: ResolutionRequest do: [:req | req resume: self home]. ! ! !InternetConfiguration commentStamp: 'LaurentLaffont 6/8/2011 22:17'! I read several parameters related to the default web browser network preferences, through the InternetConfigPlugin VM module. For example, to get the default path where downloaded files should be placed: InternetConfiguration getDownloadPath. Seems to work only on MacOSX! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:10'! getFTPProxyUser "Return the first level FTP proxy authorisation" "InternetConfiguration getFTPProxyUser" ^self primitiveGetStringKeyedBy: 'FTPProxyUser' ! ! !InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'! useSocks "Return true if UseSocks" "InternetConfiguration useSocks" ^(self primitiveGetStringKeyedBy: 'UseSocks') = '1' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:17'! getNTPHost "Return the Network Time Protocol (NTP)" "InternetConfiguration getNTPHost" ^self primitiveGetStringKeyedBy: 'NTPHost' ! ! !InternetConfiguration class methodsFor: 'system startup' stamp: 'cami 7/22/2013 18:24'! shutDown Smalltalk os isMacOS ifTrue: [ NetworkSystemSettings useHTTPProxy: false ] ! ! !InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 9/26/2001 19:42'! usePassiveFTP "Return true if UsePassiveFTP" "InternetConfiguration usePassiveFTP" ^(self primitiveGetStringKeyedBy: 'UsePassiveFTP') = '1' ! ! !InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'! useFTPProxy "Return true if UseFTPProxy" "InternetConfiguration useFTPProxy" ^(self primitiveGetStringKeyedBy: 'UseFTPProxy') = '1' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:17'! getNewsAuthUsername "Return the user name for authorised news servers" "InternetConfiguration getNewsAuthUsername" ^self primitiveGetStringKeyedBy: 'NewsAuthUsername' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/5/2001 10:54'! getNoProxyDomains "Return a comma seperated string of domains not to proxy" "InternetConfiguration getNoProxyDomains" ^self primitiveGetStringKeyedBy: 'NoProxyDomains' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:11'! getGopherProxy "Return the Gopher proxy" "InternetConfiguration getGopherProxy" ^self primitiveGetStringKeyedBy: 'GopherProxy' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:44'! getWWWHomePage "Return the WWW home page url" "InternetConfiguration getWWWHomePage" ^self primitiveGetStringKeyedBy: 'WWWHomePage' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:02'! getFTPProxyPassword "Return the FTP proxy password" "InternetConfiguration getFTPProxyPassword" ^self primitiveGetStringKeyedBy: 'FTPProxyPassword' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:10'! getFingerHost "Return the default finger server" "InternetConfiguration getFingerHost" ^self primitiveGetStringKeyedBy: 'FingerHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:05'! getArchiePreferred "Return the preferred Archie server" "InternetConfiguration getArchiePreferred" ^self primitiveGetStringKeyedBy: 'ArchiePreferred' ! ! !InternetConfiguration class methodsFor: 'initialization' stamp: 'md 2/24/2006 15:22'! initialize "self initialize" Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self.! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:31'! getDownloadPath "Return the download path" "InternetConfiguration getDownloadPath" ^self primitiveGetStringKeyedBy: 'DownLoadPath' ! ! !InternetConfiguration class methodsFor: 'system startup' stamp: 'cami 7/22/2013 18:24'! startUp Smalltalk os isMacOS ifTrue: [ self useHTTPProxy ifTrue: [ (self getHTTPProxyHost findTokens: ':') ifNotEmpty: [ :p | NetworkSystemSettings httpProxyServer: p first; httpProxyPort: p second asInteger; useHTTPProxy: true ] ] ifFalse: [ NetworkSystemSettings useHTTPProxy: false ] ]! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:07'! getMailAccount "Return the mail account user@host.domain" "InternetConfiguration getMailAccount" ^self primitiveGetStringKeyedBy: 'MailAccount' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:31'! getMailPassword "Return the mail account Password " "InternetConfiguration getMailPassword " ^self primitiveGetStringKeyedBy: 'MailPassword' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:23'! getWhoisHost "Return the WhoisHost server" "InternetConfiguration getWhoisHost" ^self primitiveGetStringKeyedBy: 'WhoisHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'! getLDAPSearchbase "Return the LDAP thing" "InternetConfiguration getLDAPSearchbase" ^self primitiveGetStringKeyedBy: 'LDAPSearchbase' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:19'! getSMTPHost "Return the SMTP server" "InternetConfiguration getSMTPHost" ^self primitiveGetStringKeyedBy: 'SMTPHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:15'! getLDAPServer "Return the LDAP server" "InternetConfiguration getLDAPServer" ^self primitiveGetStringKeyedBy: 'LDAPServer' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:04'! getRealName "Return the RealName" "InternetConfiguration getRealName" ^self primitiveGetStringKeyedBy: 'RealName' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:36'! getOrganization "Return the Organization" "InternetConfiguration getOrganization" ^self primitiveGetStringKeyedBy: 'Organization' ! ! !InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 9/26/2001 19:41'! useHTTPProxy "Return true if UseHTTPProxy" "InternetConfiguration useHTTPProxy" ^(self primitiveGetStringKeyedBy: 'UseHTTPProxy') = '1' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:09'! getFTPProxyAccount "Return the second level FTP proxy authorisation" "InternetConfiguration getFTPProxyAccount" ^self primitiveGetStringKeyedBy: 'FTPProxyAccount' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:04'! getNewsAuthPassword "Return the Password for the authorised news servers" "InternetConfiguration getNewsAuthPassword" ^self primitiveGetStringKeyedBy: 'NewsAuthPassword' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:19'! getSocksHost "Return the Socks server" "InternetConfiguration getSocksHost" ^self primitiveGetStringKeyedBy: 'SocksHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:07'! getEmail "Return the email address of user" "InternetConfiguration getEmail" ^self primitiveGetStringKeyedBy: 'Email' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:20'! getTelnetHost "Return the TelnetHost server" "InternetConfiguration getTelnetHost" ^self primitiveGetStringKeyedBy: 'TelnetHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:00'! getFTPProxyHost "Return the FTP proxy host" "InternetConfiguration getFTPProxyHost" ^self primitiveGetStringKeyedBy: 'FTPProxyHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:44'! getWAISGateway "Return the wais gateway" "InternetConfiguration getWAISGateway" ^self primitiveGetStringKeyedBy: 'WAISGateway' ! ! !InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'! useGopherProxy "Return true if UseGopherProxy" "InternetConfiguration useGopherProxy" ^(self primitiveGetStringKeyedBy: 'UseGopherProxy') = '1' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/5/2001 23:45'! getMacintoshFileTypeAndCreatorFrom: aFileName "Return the application type and application signature for the file for the macintosh file system based on the file ending, the file does not need to exist failure to find a signature based on the file ending, or because of primitive failure turns nil" "InternetConfiguration getMacintoshFileTypeAndCreatorFrom: 'test.jpg'" | string | string := self primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName. string = '********' ifTrue: [^nil]. ^Array with: (string first: 4) with: (string last: 4) ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:16'! getNNTPHost "Return the NNTP server" "InternetConfiguration getNNTPHost" ^self primitiveGetStringKeyedBy: 'NNTPHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:37'! getPhHost "Return the PhHost server" "InternetConfiguration getPhHost" ^self primitiveGetStringKeyedBy: 'PhHost' ! ! !InternetConfiguration class methodsFor: 'system primitives' stamp: 'JMM 9/26/2001 16:31'! primitiveGetStringKeyedBy: aKey ^String new. ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:08'! getFTPHost "Return the FTPHost" "InternetConfiguration getFTPHost" ^self primitiveGetStringKeyedBy: 'FTPHost' ! ! !InternetConfiguration class methodsFor: 'system primitives' stamp: 'JMM 10/5/2001 23:44'! primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName ^'********' copy ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:11'! getGopherHost "Return the default Gopher server" "InternetConfiguration getGopherHost" ^self primitiveGetStringKeyedBy: 'GopherHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'! getHTTPProxyHost "Return the http proxy for this client." "InternetConfiguration getHTTPProxyHost" ^self primitiveGetStringKeyedBy: 'HTTPProxyHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'! getIRCHost "Return the Internet Relay Chat server" "InternetConfiguration getIRCHost" ^self primitiveGetStringKeyedBy: 'IRCHost' ! ! !InterpolatedGradientFillStyle commentStamp: 'gvc 5/18/2007 12:49'! Gradient fill style that uses proper alpha-aware interpolation.! !InterpolatedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 9/9/2013 19:33'! computePixelRampOfSize: length "Compute the pixel ramp in the receiver." | bits ramp lastColor lastIndex lastWord | ramp := colorRamp asSortedCollection:[:a1 :a2| a1 key < a2 key]. bits := Bitmap new: length. lastColor := ramp first value. lastWord := self pixelWord32Of: lastColor . lastIndex := 0. ramp do:[:assoc| | distance nextColor theta nextWord nextIndex step | nextIndex := (assoc key * length) rounded. nextColor := assoc value. nextWord := nextColor pixelWord32. distance := nextIndex - lastIndex. distance = 0 ifTrue: [distance := 1]. step := 1.0 / distance. theta := 0.0. lastIndex+1 to: nextIndex do: [:i| theta := theta + step. bits at: i put: (self interpolatedAlphaMix: theta of: lastWord and: nextWord)]. lastIndex := nextIndex. lastColor := nextColor. lastWord := nextWord]. lastIndex+1 to: length do: [:i| bits at: i put: lastWord]. ^bits! ! !InterpolatedGradientFillStyle methodsFor: 'private' stamp: 'FernandoOlivero 9/9/2013 19:33'! pixelWord32Of: aColor "Returns an integer representing the bits that appear in a single pixel of this color in a Form of depth 32. Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue. Just a little quicker if we are dealing with RGBA colors at 32 bit depth." | val rgb | rgb := aColor privateRGB . "eight bits per component; top 8 bits set to all ones (opaque alpha)" val := LargePositiveInteger new: 4. val at: 3 put: ((rgb bitShift: -22) bitAnd: 16rFF). val at: 2 put: ((rgb bitShift: -12) bitAnd: 16rFF). val at: 1 put: ((rgb bitShift: -2) bitAnd: 16rFF). val = 0 ifTrue: [val at: 1 put: 1]. "closest non-transparent black" val at: 4 put: self alpha. "opaque alpha" ^val ! ! !InterpolatedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 12:48'! interpolatedAlphaMix: ratio of: rgba1 and: rgba2 "Answer a proper interpolated value between two RGBA color words. Theta is 0..1.." | a1 a2 ra ira rgb1 rgb2 alpha br1 br2 bg1 bg2 bb1 bb2 result | a1 := rgba1 bitShift: -24. a2 := rgba2 bitShift: -24. alpha := ratio * (a2 - a1) + a1. ra := ratio * alpha. ira := (1.0 - ratio) * alpha. rgb1 := rgba1 bitAnd: 16rFFFFFF. rgb2 := rgba2 bitAnd: 16rFFFFFF. br1 := (rgb1 bitAnd: 255). br2 := (rgb2 bitAnd: 255). bg1 := ((rgb1 bitShift: -8) bitAnd: 255). bg2 := ((rgb2 bitShift: -8) bitAnd: 255). bb1 := ((rgb1 bitShift: -16) bitAnd: 255). bb2 := ((rgb2 bitShift: -16) bitAnd: 255). result := (ra * br2 + (ira * br1)) rounded // 255. result := result bitOr: ((ra * bg2 + (ira * bg1)) rounded // 255 bitShift: 8). result := result bitOr: ((ra * bb2 + (ira * bb1)) rounded // 255 bitShift: 16). ^result bitOr: (alpha rounded bitShift: 24)! ! !InterpretationError commentStamp: ''! I signal when there is an Error in the interpretation of the code in the ASTInterpreter. In my cause instance variable you can the see the original class of the Error. ! !InterpretationError methodsFor: 'private' stamp: 'CamilloBruni 12/12/2011 14:29'! isResumable ^ true! ! !InterpretationError methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 14:08'! cause ^ cause! ! !InterpretationError methodsFor: 'accessing' stamp: 'CamilloBruni 12/9/2011 14:08'! cause: anObject cause := anObject! ! !InterpretationError class methodsFor: 'signalling' stamp: 'CamilloBruni 12/9/2011 14:08'! signalFor: aCauseError ^ self new cause: aCauseError; signal! ! !InterpreterTest commentStamp: 'TorstenBergmann 2/4/2014 21:54'! Common superclass for SUnit tests of interpreter tests! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 11/2/2012 09:56'! returningBlock ^ [^ 2]! ! !InterpreterTest methodsFor: 'helper' stamp: 'CamilloBruni 3/6/2013 13:02'! returningBlockValue [ ^5 ] value! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 3/6/2013 09:50'! returningBlockArg ^ [:arg| ^arg]! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 2/26/2013 10:05'! returningTempBlock |stuff| stuff := 5. [ ^stuff] value! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 3/7/2013 09:50'! returningBlockNonRootContext2 [self returningBlock value] on: BlockCannotReturn do: [ 1 ]! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 3/5/2013 13:42'! lazyInitialization |foo| ^foo ifNil: [ foo := 5 ]! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 11/2/2012 09:57'! block ^ [2]! ! !InterpreterTest methodsFor: 'helper' stamp: 'CamilloBruni 3/6/2013 13:12'! superSendInNestedBlock [[ ^ super selector ] value ] value! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 3/4/2013 10:50'! blockTempWrite |stuff| ^[stuff := 5. stuff]! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 1/14/2013 13:05'! returningBlockInsideLoop [ ^5] whileFalse! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 3/4/2013 10:44'! blockTemp |stuff| stuff := 5. ^[stuff]! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 3/4/2013 15:15'! thisContextCopyMethod |var| var := thisContext copy. ^var! ! !InterpreterTest methodsFor: 'helper' stamp: 'CamilloBruni 3/6/2013 13:03'! unknownSuperSendInNestedBlock [[ ^ super aSelectorThatDoesNotExist ] value ] value! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 12/11/2012 09:28'! ensureNonLocalReturn: anOrderedCollection [^2] ensure: [anOrderedCollection add: 5]! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 1/14/2013 11:09'! returningLoop |index| index := 1. [index := index + 1. index = 5 ifTrue: [^index ]. index = 10] whileFalse. ^self error! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 11/2/2012 09:56'! errorBlock ^ [Error signal]! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 3/7/2013 09:44'! returningBlockNonRootContext self should: [self returningBlock value] raise: BlockCannotReturn! ! !InterpreterTest methodsFor: 'helper' stamp: 'CamilloBruni 3/6/2013 13:03'! unknownSuperSend ^ super aSelectorThatDoesNotExist! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 12/11/2012 09:30'! methodWithTemp |temp| temp := 5 + 2. ^temp! ! !InterpreterTest methodsFor: 'helper' stamp: 'ClementBera 3/4/2013 15:15'! thisContextMethod ^thisContext! ! !Interval commentStamp: ''! I represent a finite arithmetic progression.! !Interval methodsFor: 'accessing' stamp: ''! last "Refer to the comment in SequenceableCollection|last." ^stop - (stop - start \\ step)! ! !Interval methodsFor: 'private' stamp: ''! species ^Array! ! !Interval methodsFor: 'private' stamp: ''! setFrom: startInteger to: stopInteger by: stepInteger start := startInteger. stop := stopInteger. step := stepInteger! ! !Interval methodsFor: 'accessing' stamp: ''! first "Refer to the comment in SequenceableCollection|first." ^start! ! !Interval methodsFor: 'testing' stamp: 'di 12/6/1999 11:00'! rangeIncludes: aNumber "Return true if the number lies in the interval between start and stop." step >= 0 ifTrue: [^ aNumber between: start and: stop] ifFalse: [^ aNumber between: stop and: start] ! ! !Interval methodsFor: 'accessing' stamp: 'StephaneDucasse 2/20/2010 22:54'! anyOne "This message will fail for an empty Interval, super would not. (2 to: 1) anyOne should fail because empty." ^self at: 1! ! !Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:45'! + number ^ start + number to: stop + number by: step! ! !Interval methodsFor: 'accessing' stamp: ''! increment "Answer the receiver's interval increment." ^step! ! !Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:46'! - number ^ start - number to: stop - number by: step! ! !Interval methodsFor: 'accessing' stamp: ''! at: anInteger "Answer the anInteger'th element." (anInteger >= 1 and: [anInteger <= self size]) ifTrue: [^start + (step * (anInteger - 1))] ifFalse: [self errorSubscriptBounds: anInteger]! ! !Interval methodsFor: 'printing' stamp: 'sma 6/1/2000 09:50'! printOn: aStream aStream nextPut: $(; print: start; nextPutAll: ' to: '; print: stop. step ~= 1 ifTrue: [aStream nextPutAll: ' by: '; print: step]. aStream nextPut: $)! ! !Interval methodsFor: 'adding' stamp: ''! add: newObject "Adding to an Interval is not allowed." self shouldNotImplement! ! !Interval methodsFor: 'enumerating' stamp: 'dtl 5/31/2003 16:45'! permutationsDo: aBlock "Repeatly value aBlock with a single copy of the receiver. Reorder the copy so that aBlock is presented all (self size factorial) possible permutations." "(1 to: 4) permutationsDo: [:each | Transcript cr; show: each printString]" self asArray permutationsDo: aBlock ! ! !Interval methodsFor: 'sorting' stamp: 'DamienCassou 8/27/2013 21:00'! sorted ^ self increment >= 0 ifTrue: [ self copy ] ifFalse: [ self last to: self first by: self increment negated ]! ! !Interval methodsFor: 'sorting' stamp: 'DamienCassou 8/27/2013 21:00'! sorted: aSortBlockOrNil "Return a new sequenceable collection which contains the same elements as self but its elements are sorted by aSortBlockOrNil. The block should take two arguments and return true if the first element should preceed the second one. If aSortBlock is nil then <= is used for comparison. We convert the interval to an array because intervals can't be changed." ^self asArray sort: aSortBlockOrNil! ! !Interval methodsFor: 'comparing' stamp: ''! hash "Hash is reimplemented because = is implemented." ^(((start hash bitShift: 2) bitOr: stop hash) bitShift: 1) bitOr: self size! ! !Interval methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:38'! size "Answer how many elements the receiver contains." step < 0 ifTrue: [start < stop ifTrue: [^ 0] ifFalse: [^ stop - start // step + 1]] ifFalse: [stop < start ifTrue: [^ 0] ifFalse: [^ stop - start // step + 1]]! ! !Interval methodsFor: 'accessing' stamp: 'Alexandre Bergel 12/23/2009 18:52'! indexOf: anElement startingAt: startIndex ifAbsent: exceptionBlock "startIndex is an positive integer, the collection index where the search is started." "during the computation of val , floats are only used when the receiver contains floats" | index val | (self rangeIncludes: anElement) ifFalse: [^ exceptionBlock value]. val := anElement - self first / self increment. val isFloat ifTrue: [(val - val rounded) abs * 100000000 < 1 ifTrue: [index := val rounded + 1] ifFalse: [^ exceptionBlock value]] ifFalse: [val isInteger ifTrue: [index := val + 1] ifFalse: [^ exceptionBlock value]]. "finally, the value of startIndex comes into play:" ^ (index between: startIndex and: self size) ifTrue: [index] ifFalse: [exceptionBlock value]! ! !Interval methodsFor: 'printing' stamp: 'CamilloBruni 4/11/2011 15:08'! storeOn: aStream aStream nextPut: $(; store: start; nextPutAll: ' to: '; store: stop. step ~= 1 ifTrue: [aStream nextPutAll: ' by: '; store: step]. aStream nextPut: $)! ! !Interval methodsFor: 'testing' stamp: 'rhi 8/12/2003 09:52'! isInterval ^ true! ! !Interval methodsFor: 'accessing' stamp: 'stp 8/19/2000 23:52'! extent "Answer the max - min of the receiver interval." "(10 to: 50) extent" ^stop - start! ! !Interval methodsFor: 'comparing' stamp: 'rhi 8/14/2003 10:08'! = anObject ^ self == anObject ifTrue: [true] ifFalse: [anObject isInterval ifTrue: [start = anObject first and: [step = anObject increment and: [self last = anObject last]]] ifFalse: [super = anObject]]! ! !Interval methodsFor: 'enumerating' stamp: ''! collect: aBlock | nextValue result | result := self species new: self size. nextValue := start. 1 to: result size do: [:i | result at: i put: (aBlock value: nextValue). nextValue := nextValue + step]. ^ result! ! !Interval methodsFor: 'accessing' stamp: ''! at: anInteger put: anObject "Storing into an Interval is not allowed." self error: 'you can not store into an interval'! ! !Interval methodsFor: 'removing' stamp: ''! remove: newObject "Removing from an Interval is not allowed." self error: 'elements cannot be removed from an Interval'! ! !Interval methodsFor: 'enumerating' stamp: 'Alexandre Bergel 12/23/2009 18:53'! do: aBlock "Evaluate aBlock for each value of the interval. Implementation note: instead of repeatedly incrementing the value aValue := aValue + step. until stop is reached, We prefer to recompute value from start aValue := start + (index * step). This is better for floating points accuracy, while not degrading Integer and Fraction speed too much. Moreover, this is consistent with methods #at: and #size" | aValue index size | index := 0. size := self size. [index < size] whileTrue: [aValue := start + (index * step). index := index + 1. aBlock value: aValue]! ! !Interval methodsFor: 'enumerating' stamp: 'nice 4/30/2007 18:28'! reverseDo: aBlock "Evaluate aBlock for each element of my interval, in reverse order. Implementation notes: see do: for an explanation on loop detail" | aValue index | index := self size. [index > 0] whileTrue: [ index := index - 1. aValue := start + (index * step). aBlock value: aValue]! ! !Interval methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 22:03'! isSelfEvaluating ^ self class == Interval! ! !Interval class methodsFor: 'instance creation' stamp: ''! from: startInteger to: stopInteger "Answer an instance of me, starting at startNumber, ending at stopNumber, and with an interval increment of 1." ^self new setFrom: startInteger to: stopInteger by: 1! ! !Interval class methodsFor: 'accessing' stamp: 'CamilloBruni 9/5/2011 15:37'! streamSpecies ^ Array! ! !Interval class methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/18/2009 11:59'! new "Primitive. Create and answer with a new instance of the receiver (a class) with no indexable fields. Fail if the class is indexable. Override SequenceableCollection new. Essential. See Object documentation whatIsAPrimitive." self isVariable ifTrue: [ ^ self new: 0 ]. "space must be low" OutOfMemory signal. ^ self new "retry if user proceeds" ! ! !Interval class methodsFor: 'instance creation' stamp: 'nice 3/27/2008 00:17'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." | newInterval n | (n := aCollection size) <= 1 ifTrue: [ n = 0 ifTrue: [^self from: 1 to: 0]. ^self from: aCollection first to: aCollection last]. newInterval := self from: aCollection first to: aCollection last by: (aCollection last - aCollection first) // (n - 1). aCollection ~= newInterval ifTrue: [ "Give a second chance, because progression might be arithmetic, but = answer false" (newInterval hasEqualElements: aCollection) ifFalse: [ self error: 'The argument is not an arithmetic progression']]. ^newInterval " Interval newFrom: {1. 2. 3} {33. 5. -23} as: Interval {33. 5. -22} as: Interval (an error) (-4 to: -12 by: -1) as: Interval #(2 4 6) asByteArray as: Interval. "! ! !Interval class methodsFor: 'instance creation' stamp: ''! from: startInteger to: stopInteger by: stepInteger "Answer an instance of me, starting at startNumber, ending at stopNumber, and with an interval increment of stepNumber." ^self new setFrom: startInteger to: stopInteger by: stepInteger! ! !IntervalTest commentStamp: 'TorstenBergmann 2/20/2014 15:28'! SUnit tests for intervals! !IntervalTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButLast "self debug: #testAllButLast" | abf col | col := self moreThan3Elements. abf := col allButLast. self deny: abf last = col last. self assert: abf size + 1 = col size! ! !IntervalTest methodsFor: 'tests' stamp: 'stephane.ducasse 1/16/2009 21:06'! testCollectThenSelectLocal | letters vowels | letters := 'abcdefghijklmnopqrstuvwxyz'. vowels := (1 to: 26) collect: [:index | letters at: index] thenSelect: [:char | char isVowel]. self assert: (vowels hasEqualElements: 'aeiou').! ! !IntervalTest methodsFor: 'tests - begins ends with' stamp: ''! testsEndsWith self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst). self assert: (self nonEmpty endsWith: self nonEmpty). self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first)).! ! !IntervalTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceAllWith1Occurence | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . index:= firstIndexesOfOccurrence at: 1. "verify content of 'result' : " "first part of 'result'' : '" 1 to: (index -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " index to: (index + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) ]. " end part :" endPartIndexResult := index + self replacementCollection size . endPartIndexCollection := index + self oldSubCollection size . 1 to: (result size - endPartIndexResult - 1 ) do: [ :i | self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). ]. ! ! !IntervalTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElementsOfIdenticalCollectionObjects "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" self assert: (self empty hasEqualElements: self empty). self assert: (self nonEmpty hasEqualElements: self nonEmpty). ! ! !IntervalTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOf "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyWithReplacementTest self replacementCollection. self oldSubCollection. self collectionWith1TimeSubcollection. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:51'! moreThan4Elements " return a collection including at leat 4 elements" ^ nonEmpty ! ! !IntervalTest methodsFor: 'tests - subcollections access' stamp: ''! testFirstNElements "self debug: #testFirstNElements" | result | result := self moreThan3Elements first: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: Error! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0TStructuralEqualityTest self empty. self nonEmpty. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty! ! !IntervalTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithoutFirst | result | result := self nonEmpty copyWithoutFirst. self assert: result size = (self nonEmpty size - 1). 1 to: result size do: [:i | self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! !IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:13'! testEquals2 self assert: (3 to: 5) = #(3 4 5). self deny: (3 to: 5) = #(3 5). self deny: (3 to: 5) = #(). self assert: #(3 4 5) = (3 to: 5). self deny: #(3 5) = (3 to: 5). self deny: #() = (3 to: 5).! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testBefore "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). self should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] raise: Error. self should: [ self moreThan4Elements before: 66 ] raise: Error! ! !IntervalTest methodsFor: 'tests' stamp: 'Alexandre Bergel 12/23/2009 18:47'! testInfiniteLoopBug6456 "This is a non regression test against mantis bug #6456. Some Float interval size was not consistent with do: loop. Some Float Interval used to do: infinite loops" | x interval counter size | x := (1.0 timesTwoPower: Float precision). "Note: x+1 = x due to inexact arithmetic" interval := x to: x+4. size := interval size. counter := 0. interval do: [:each | self assert: (counter := counter + 1) <= size] ! ! !IntervalTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:10'! collectionOfFloat ^collectionOfFloat ! ! !IntervalTest methodsFor: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:11'! collectionWithoutEqualElements ^ nonEmpty ! ! !IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:23'! testAdd self assert: (1 to: 10) + 5 = (6 to: 15)! ! !IntervalTest methodsFor: 'tests - converting' stamp: ''! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !IntervalTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asArray sort. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !IntervalTest methodsFor: 'requirements' stamp: 'DamienCassou 8/27/2013 20:58'! unsortedCollection " retur a collection that is not yat sorted" ^ (10 to: 1 by: -2)! ! !IntervalTest methodsFor: 'tests - copy' stamp: ''! testCopyNotSame "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self nonEmpty copy. self deny: copy == self nonEmpty.! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindFirst | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. self assert: result=1. ! ! !IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:58'! firstOdd "Returns the first odd number of #collection" ^ -5! ! !IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:13'! testEquals3 self assert: (3 to: 5 by: 2) first = (3 to: 6 by: 2) first. self assert: (3 to: 5 by: 2) last = (3 to: 6 by: 2) last. self assert: (3 to: 5 by: 2) = (3 to: 6 by: 2).! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithIndexCollect | result index collection | index := 0. collection := self nonEmptyMoreThan1Element . result := collection withIndexCollect: [:each :i | self assert: i = (index := index + 1). self assert: i = (collection indexOf: each) . each] . 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. self assert: result size = collection size.! ! !IntervalTest methodsFor: 'tests - printing' stamp: ''! testPrintElementsOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !IntervalTest methodsFor: 'tests - begins ends with' stamp: ''! testsEndsWithEmpty self deny: (self nonEmpty endsWith: self empty). self deny: (self empty endsWith: self nonEmpty). ! ! !IntervalTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithSequenceable | result index element | index := self indexInNonEmpty . element := self nonEmpty at: index. result := self nonEmpty copyWith: (element ). self assert: result size = (self nonEmpty size + 1). self assert: result last = element . 1 to: (result size - 1) do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! !IntervalTest methodsFor: 'tests - concatenation' stamp: ''! testConcatenationWithEmpty | result | result:= self empty,self secondCollection . 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:i). ]. "size : " self assert: result size = ( self secondCollection size).! ! !IntervalTest methodsFor: 'requirements' stamp: 'stephane.ducasse 11/21/2008 15:39'! anotherElementNotIn ^ 42! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIterateSequencedReadableTest | res | self nonEmptyMoreThan1Element. self assert: self nonEmptyMoreThan1Element size > 1. self empty. self assert: self empty isEmpty . res := true. self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false.! ! !IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:28'! testMinus self assert: (1 to: 10) - 5 = (-4 to: 5)! ! !IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 14:44'! collectionWith1TimeSubcollection ^ collectionWithSubCollection ! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testAtOutOfBounds "self debug: #testAtOutOfBounds" self should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] raise: Error. self should: [ self moreThan4Elements at: -1 ] raise: Error! ! !IntervalTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !IntervalTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithCollect | result firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := 0. result := firstCollection with: secondCollection collect: [:a :b | ( index := index + 1). self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b. b]. 1 to: result size do:[: i | self assert: (result at:i)= (secondCollection at: i)]. self assert: result size = secondCollection size.! ! !IntervalTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:34'! testNewFrom self assert: ( (Interval newFrom: (1 to: 1)) = (1 to: 1)). self assert: ( (Interval newFrom: #(1)) = (1 to: 1)). self assert: ( (Interval newFrom: #()) = ( 1 to: 0)).! ! !IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeWithIdentityTest | anElement | self collectionWithCopyNonIdentical. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy! ! !IntervalTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiter | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:22'! elementInCollectionOfFloat ^ collectionOfFloat anyOne! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:28'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ collectionWithoutNil ! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self collectionWithoutEqualElements. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterMore | delim multiItemStream result index | "delim := ', '. multiItemStream := '' readWrite. self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. self assert: multiItemStream contents = '1, 2, 3'." delim := ', '. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. index:=1. (result findBetweenSubStrs: ', ' )do: [:each | self assert: each= ((self nonEmpty at:index)asString). index:=index+1 ].! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testDetectSequenced " testing that detect keep the first element returning true for sequenceable collections " | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. self assert: result = element. ! ! !IntervalTest methodsFor: 'tests - includes' stamp: ''! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureAsStringCommaAndDelimiterTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty. self nonEmpty1Element. self assert: self nonEmpty1Element size = 1! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:15'! collectionMoreThan1NoDuplicates " return a collection of size 5 without equal elements" ^ nonEmpty ! ! !IntervalTest methodsFor: 'as yet unclassified' stamp: ''! testSorted | result tmp unsorted | unsorted := self unsortedCollection. result := unsorted sorted. self deny: unsorted == result. tmp := result at: 1. result do: [ :each | self assert: each >= tmp. tmp := each ]! ! !IntervalTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAny: self empty). self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAny: self nonEmpty).! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:27'! elementToAdd ^ elementNotIn ! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testPairsDo | index | index:=1. self nonEmptyMoreThan1Element pairsDo: [:each1 :each2 | self assert:(self nonEmptyMoreThan1Element at:index)=each1. self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. index:=index+2]. self nonEmptyMoreThan1Element size odd ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! !IntervalTest methodsFor: 'tests - subcollections access' stamp: ''! testLastNElements "self debug: #testLastNElements" | result | result := self moreThan3Elements last: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] raise: Error! ! !IntervalTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 17:21'! accessCollection ^ -2 to: 14 by: 4! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testCollectFromTo | result | result:=self nonEmptyMoreThan1Element collect: [ :each | each ] from: 1 to: (self nonEmptyMoreThan1Element size - 1). 1 to: result size do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! !IntervalTest methodsFor: 'tests - printing' stamp: ''! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream . Transcript show: result asString. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !IntervalTest methodsFor: 'tests' stamp: 'MarcusDenker 5/2/2013 11:33'! testIntervalStoreOn "this is a test for http://bugs.squeak.org/view.php?id=4378" | interval1 interval2 | interval1 := 0 to: 1 by: 0.5s1 squared. interval2 := self class compiler evaluate: interval1 storeString. self assert: interval1 size = interval2 size! ! !IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:11'! testIsEvaluating self assert: (1 to: 10) isSelfEvaluating. self assert: (1 to: 10 by: 2) isSelfEvaluating! ! !IntervalTest methodsFor: 'test - equality' stamp: ''! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0SortingArrayedTest | tmp sorted | " an unsorted collection of number " self unsortedCollection. self unsortedCollection do: [ :each | each isNumber ]. sorted := true. self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ]. self assert: sorted = false. " a collection of number sorted in an ascending order" self sortedInAscendingOrderCollection. self sortedInAscendingOrderCollection do: [ :each | each isNumber ]. tmp := self sortedInAscendingOrderCollection at: 1. self sortedInAscendingOrderCollection do: [ :each | self assert: each >= tmp. tmp := each ]! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:40'! elementInForElementAccessing " return an element inculded in 'accessCollection '" ^ self accessCollection anyOne! ! !IntervalTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceFromToWithInsertion | result indexOfSubcollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . "verify content of 'result' : " "first part of 'result'' : '" 1 to: (indexOfSubcollection -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) ]. " end part :" (indexOfSubcollection + self replacementCollection size) to: (result size) do: [:i| self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. " verify size: " self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). ! ! !IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringMore "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' " | result resultAnd index allElementsAsString | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . index := 1. (result findBetweenSubStrs: ',' )do: [:each | index = 1 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. index:=index+1 ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size ) ifTrue: [ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] ]. i=(allElementsAsString size) ifTrue:[ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ]. ].! ! !IntervalTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res anElement | anElement := self elementToAdd . res := self nonEmpty copyWith: anElement. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: (anElement value)). self nonEmpty do: [ :each | res includes: each ]! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !IntervalTest methodsFor: 'tests' stamp: 'nice 2/3/2008 21:35'! testIndexOfBug6455 "This test is about mantis bug http://bugs.squeak.org/view.php?id=6455 It should work as long as Fuzzy inclusion test feature for Interval of Float is maintained. This is a case when tested element is near ones of actual value, but by default. Code used to work only in the case of close numbers by excess..." self assert: ((0 to: Float pi by: Float pi / 100) indexOf: Float pi * (3/100)) = 4! ! !IntervalTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAllNotIncluded "self debug: #testCopyNonEmptyWithoutAllNotIncluded" | res | res := self nonEmpty copyWithoutAll: self collectionNotIncluded. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !IntervalTest methodsFor: 'tests' stamp: 'nice 2/3/2008 21:43'! testInclusionBug6455 "This test is about mantis bug http://bugs.squeak.org/view.php?id=6455 It should work as long as Fuzzy inclusion test feature for Interval of Float is maintained. This is a case when tested element is near ones of actual value, but by default. Code used to work only in the case of close numbers by excess..." self assert: ((0 to: Float pi by: Float pi / 100) includes: Float pi * (3/100))! ! !IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:59'! doWithoutNumber ^ 6! ! !IntervalTest methodsFor: 'tests - index access' stamp: ''! testIdentityIndexOfIAbsent | collection element | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = 1. self assert: (collection identityIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 55 ]) = 55! ! !IntervalTest methodsFor: 'tests - index access' stamp: ''! testIndexOfSubCollectionStartingAt "self debug: #testIndexOfIfAbsent" | subcollection index collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. index := collection indexOfSubCollection: subcollection startingAt: 1. self assert: index = 1. index := collection indexOfSubCollection: subcollection startingAt: 2. self assert: index = 0! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:25'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ self nonEmpty ! ! !IntervalTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !IntervalTest methodsFor: 'tests' stamp: 'zz 12/7/2005 13:29'! testIsInterval self assert: (1 to: 10) isInterval. self assert: (1 to: 10 by: 2) isInterval! ! !IntervalTest methodsFor: 'tests - sorting' stamp: ''! testSortedUsingBlock | result tmp | result := self unsortedCollection sorted: [:a :b | a>b].. tmp := result at: 1. result do: [:each | self assert: each<=tmp. tmp:= each. ].! ! !IntervalTest methodsFor: 'tests - index access' stamp: ''! testIdentityIndexOf "self debug: #testIdentityIndexOf" | collection element | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureOccurrencesTest | tmp | self empty. self assert: self empty isEmpty. self collectionWithoutEqualElements. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each ]. self elementNotInForOccurrences. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIndexAccessTest | res collection element | self collectionMoreThan1NoDuplicates. self assert: self collectionMoreThan1NoDuplicates size > 1. res := true. self collectionMoreThan1NoDuplicates detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self elementInForIndexAccessing. self assert: ((collection := self collectionMoreThan1NoDuplicates) includes: (element := self elementInForIndexAccessing)). self elementNotInForIndexAccessing. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !IntervalTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := 0. firstCollection with: secondCollection do: [:a :b | ( index := index + 1). self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b.] ! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testAllButFirstDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:56'! secondCollection ^anotherCollection ! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !IntervalTest methodsFor: 'requirements' stamp: 'DamienCassou 8/27/2013 20:58'! sortedInAscendingOrderCollection " return a collection sorted in an acsending order" ^ anotherCollection! ! !IntervalTest methodsFor: 'tests - indexable access' stamp: 'delaunay 4/10/2009 16:20'! testAtWrap "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self accessCollection indexOf: self elementInForIndexAccessing. self assert: (self accessCollection atWrap: index) = self elementInForIndexAccessing. self assert: (self accessCollection atWrap: index + self accessCollection size) = self elementInForIndexAccessing. self assert: (self accessCollection atWrap: index - self accessCollection size) = self elementInForIndexAccessing. self assert: (self accessCollection atWrap: 1 + self accessCollection size) = (self accessCollection at: 1)! ! !IntervalTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !IntervalTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !IntervalTest methodsFor: 'tests - concatenation' stamp: ''! testConcatenation | result index | result:= self firstCollection,self secondCollection . "first part : " index := 1. self firstCollection do: [:each | self assert: (self firstCollection at: index)=each. index := index+1.]. "second part : " 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:index). index:=index+1]. "size : " self assert: result size = (self firstCollection size + self secondCollection size).! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testKeysAndValuesDo "| result | result:= OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| result add: (value+i)]. 1 to: result size do: [:i| self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !IntervalTest methodsFor: 'tests' stamp: 'apb 4/22/2007 12:39'! testUnevenDo | s i | s := OrderedCollection new. i := 10 to: 20 by: 3. i do: [:each | s addLast: each]. self assert: (s hasEqualElements: i)! ! !IntervalTest methodsFor: 'tests - converting' stamp: ''! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !IntervalTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOf | collection | collection := self collectionWithoutEqualElements . collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! !IntervalTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 8/31/2013 20:23'! test0CopyTest self empty. self assert: self empty size = 0. self nonEmpty. self assert: (self nonEmpty size = 0) not. self collectionWithElementsToRemove. self assert: (self collectionWithElementsToRemove size = 0) not. self elementToAdd. self collectionNotIncluded. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !IntervalTest methodsFor: 'as yet unclassified' stamp: ''! testStreamContentsProtocol | result index | result:= self collectionClass << [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:02'! indexInNonEmpty ^2.! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSequencedConcatenationTest self empty. self assert: self empty isEmpty. self firstCollection. self secondCollection! ! !IntervalTest methodsFor: 'tests - begins ends with' stamp: ''! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !IntervalTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElements "self debug: #testHasEqualElements" self deny: (self empty hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! !IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:57'! result ^ {SmallInteger . SmallInteger . SmallInteger . SmallInteger . SmallInteger . SmallInteger}! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ collectionOfFloat! ! !IntervalTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !IntervalTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !IntervalTest methodsFor: 'tests - begins ends with' stamp: ''! testsBeginsWith self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty last)). self assert: (self nonEmpty beginsWith:(self nonEmpty )). self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 16:36'! collectionClass ^ Interval! ! !IntervalTest methodsFor: 'tests' stamp: 'md 10/12/2003 20:13'! testEquals4 self assert: (3 to: 5 by: 2) = #(3 5). self deny: (3 to: 5 by: 2) = #(3 4 5). self deny: (3 to: 5 by: 2) = #(). self assert: #(3 5) = (3 to: 5 by: 2). self deny: #(3 4 5) = (3 to: 5 by: 2). self deny: #() = (3 to: 5 by: 2).! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 15:00'! nonEmpty1Element ^ nonEmpty1Element ! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0TSequencedStructuralEqualityTest self nonEmpty at: 1 "Ensures #nonEmpty is sequenceable"! ! !IntervalTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceFromToWith | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . "verify content of 'result' : " "first part of 'result' " 1 to: (indexOfSubcollection - 1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) ]. " middle part containing replacementCollection : " (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) ]. " end part :" 1 to: (result size - lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). ]. ! ! !IntervalTest methodsFor: 'tests' stamp: 'apb 4/22/2007 12:34'! testDo | s i | s := OrderedCollection new. i := (10 to: 20). i do: [ :each | s addLast: each]. self assert: (s hasEqualElements: i)! ! !IntervalTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElementsIsTrueForNonIdenticalButEqualCollections "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" self assert: (self empty hasEqualElements: self empty copy). self assert: (self empty copy hasEqualElements: self empty). self assert: (self empty copy hasEqualElements: self empty copy). self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! !IntervalTest methodsFor: 'test - equality' stamp: ''! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:57'! firstEven "Returns the first even number of #collection" ^ -2! ! !IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:20'! testRangeIncludes self assert: ((1 to: 10) rangeIncludes: 3). self assert: ((1 to: 10 by: 2) rangeIncludes: 3). self deny: ((1 to: 10) rangeIncludes: 0). self deny: ((1 to: 10) rangeIncludes: 11). self deny: ((1 to: 10 by: 2) rangeIncludes: 0). self deny: ((1 to: 10 by: 2) rangeIncludes: 11)! ! !IntervalTest methodsFor: 'tests - copy' stamp: ''! testCopySameClass "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self empty copy. self assert: copy class == self empty class.! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testAfter "self debug: #testAfter" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). self should: [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] raise: Error. self should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] raise: Error! ! !IntervalTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButFirstNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. self assert: abf size + 2 = col size! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfter | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfter: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 14:44'! oldSubCollection ^ subCollection ! ! !IntervalTest methodsFor: 'tests - sorting' stamp: ''! testIsSortedBy self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | ab]). ! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePrintTest self nonEmpty! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := firstCollection size. firstCollection reverseWith: secondCollection do: [:a :b | self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b. ( index := index - 1).] ! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyFromTo | result index collection | collection := self collectionWithoutEqualElements . index :=self indexInForCollectionWithoutDuplicates . result := collection copyFrom: index to: collection size . "verify content of 'result' : " 1 to: result size do: [:i | self assert: (result at:i)=(collection at: (i + index - 1))]. "verify size of 'result' : " self assert: result size = (collection size - index + 1).! ! !IntervalTest methodsFor: 'tests - includes' stamp: ''! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !IntervalTest methodsFor: 'tests' stamp: 'apb 4/22/2007 12:36'! testReverseUnevenDo | s i | s := OrderedCollection new. i := 10 to: 20 by: 3. i reverseDo: [:each | s addFirst: each]. self assert: (s hasEqualElements: i)! ! !IntervalTest methodsFor: 'tests - index access' stamp: ''! testIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:43'! elementNotInForElementAccessing " return an element not included in 'accessCollection' " ^ elementNotIn ! ! !IntervalTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiterLast | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ].! ! !IntervalTest methodsFor: 'tests - converting' stamp: ''! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! howMany: aSubCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp := collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: aSubCollection) ifTrue: [ nTime := nTime + 1. 1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:14'! indexInForCollectionWithoutDuplicates ^ 2.! ! !IntervalTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWith "self debug: #testCopyWith" | res anElement | anElement := self elementToAdd. res := self empty copyWith: anElement. self assert: res size = (self empty size + 1). self assert: (res includes: (anElement value))! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureConverAsSortedTest self collectionWithSortableElements. self deny: self collectionWithSortableElements isEmpty! ! !IntervalTest methodsFor: 'tests - printing' stamp: ''! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !IntervalTest methodsFor: 'tests - index access' stamp: ''! testIndexOfStartingAtIfAbsent "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:03'! testOtherNewFrom self assert: (Interval newFrom: #(1 2 3 )) = (1 to: 3). self assert: (Interval newFrom: #(33 5 -23 )) = (33 to: -23 by: -28). self should: [(Interval newFrom: #(33 5 -22 ))] raise: Error. self assert: (#(33 5 -23) as: Interval) = (33 to: -23 by: -28). self should: [( #(33 5 -22 ) as: Interval)] raise: Error. self assert: ( (-4 to: -12 by: -1) as: Interval) = (-4 to: -12 by: -1). self assert: ( Interval newFrom: (1 to: 1)) = (1 to: 1). self assert: ( Interval newFrom: (1 to: 0)) = (1 to: 0). self assert: (#(1) as: Interval) = (1 to: 1). self assert: (#() as: Interval) = (1 to: 0).! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:04'! integerCollection ^ nonEmpty ! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testAtAll "self debug: #testAtAll" " self flag: #theCollectionshouldbe102030intheFixture. self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." | result | result := self moreThan4Elements atAll: #(2 1 2 ). self assert: (result at: 1) = (self moreThan4Elements at: 2). self assert: (result at: 2) = (self moreThan4Elements at: 1). self assert: (result at: 3) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! !IntervalTest methodsFor: 'tests - indexable access' stamp: 'delaunay 4/6/2009 15:25'! testAllButLastElements "self debug: #testAllButFirst" | abf col | col := self accessCollection. abf := col allButLast: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i) ]. self assert: abf size + 2 = col size! ! !IntervalTest methodsFor: 'tests - converting' stamp: ''! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !IntervalTest methodsFor: 'tests - copying same contents' stamp: ''! testShallowCopy | result | result := self nonEmpty shallowCopy . "verify content of 'result: '" 1 to: self nonEmpty size do: [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !IntervalTest methodsFor: 'tests - index access' stamp: ''! testIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | collection | collection := self collectionMoreThan1NoDuplicates. self assert: (collection indexOf: collection first ifAbsent: [ 33 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing ifAbsent: [ 33 ]) = 33! ! !IntervalTest methodsFor: 'as yet unclassified' stamp: ''! testStreamContentsSized | result | result:= self collectionClass new: 1 streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection. result:= self collectionClass new: 1000 streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyPartOfSequenceableTest self collectionWithoutEqualElements. self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ]. self indexInForCollectionWithoutDuplicates. self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size. self empty. self assert: self empty isEmpty! ! !IntervalTest methodsFor: 'tests - converting' stamp: ''! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !IntervalTest methodsFor: 'tests - converting' stamp: ''! testAsByteArray | res | self integerCollectionWithoutEqualElements. self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ]. res := true. self integerCollectionWithoutEqualElements detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! !IntervalTest methodsFor: 'tests - converting' stamp: ''! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyWithOrWithoutSpecificElementsTest self nonEmpty. self deny: self nonEmpty isEmpty. self indexInNonEmpty. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:48'! elementNotInForIndexAccessing ^elementNotIn ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:55'! firstCollection ^ nonEmpty.! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:51'! collectionInForIncluding ^ nonEmpty copyWithout: (self nonEmpty last).! ! !IntervalTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !IntervalTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:34'! testAsInterval "This is the same as newFrom:" "self run: #testAsIntervaltestAsInterval" self assert: (#(1 2 3) as: Interval) = (1 to: 3). self assert: (#(33 5 -23) as: Interval) = (33 to: -23 by: -28). self assert: (#[2 4 6] as: Interval) = (2 to: 6 by: 2). self should: [#(33 5 -22) as: Interval] raise: Error description: 'This is not an arithmetic progression' ! ! !IntervalTest methodsFor: 'tests - index access' stamp: ''! testIndexOfSubCollectionStartingAtIfAbsent "self debug: #testIndexOfIfAbsent" | index absent subcollection collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ]. self assert: absent = false. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ]. self assert: absent = true! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpToLast: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1).! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 15:03'! elementInForIndexAccess ^ self accessCollection anyOne! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCloneTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !IntervalTest methodsFor: 'tests - printing' stamp: ''! testPrintOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. ].! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpTo | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpTo: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1). ! ! !IntervalTest methodsFor: 'tests' stamp: 'Alexandre Bergel 12/23/2009 18:46'! testInclusion "Non regression test for another bug of fuzzy inclusion" self deny: ((1.0 to: 3.0 by: 1.0 successor) includes: 3.0) description: 'The last element of this Interval is closed to 2'! ! !IntervalTest methodsFor: 'tests' stamp: 'zz 12/7/2005 13:29'! testLast self assert: (1 to:10) last = 10. self assert: (1 to:10 by:2) last = 9 ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:32'! collectionWithElementsToRemove ^ subCollectionInNonEmpty .! ! !IntervalTest methodsFor: 'tests - copying same contents' stamp: ''! testReversed | result | result := self nonEmpty reversed . "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString | delim := ', '. last := 'and'. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ]. ! ! !IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 19:01'! expectedSizeAfterReject "Number of even elements in #collection" ^ 3! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeTest | anElementIn | self nonEmpty. self deny: self nonEmpty isEmpty. self elementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self anotherElementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self empty. self assert: self empty isEmpty! ! !IntervalTest methodsFor: 'tests - includes' stamp: 'CamilloBruni 8/31/2013 20:23'! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection element | self collectionWithCopyNonIdentical. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !IntervalTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotInForOccurrences). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotInForOccurrences)! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 14:45'! replacementCollection ^ 5 to: 7.! ! !IntervalTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithoutIndex | result index | index := self indexInNonEmpty . result := self nonEmpty copyWithoutIndex: index . "verify content of 'result:'" 1 to: result size do: [:i | i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. "verify size of result : " self assert: result size=(self nonEmpty size -1).! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !IntervalTest methodsFor: 'tests' stamp: 'apb 4/22/2007 12:35'! testReverseDo | s i | s := OrderedCollection new. i := 10 to: 20. i reverseDo: [:each | s addFirst: each]. self assert: (s hasEqualElements: i)! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:31'! integerCollectionWithoutEqualElements ^ 1 to: 23.! ! !IntervalTest methodsFor: 'tests - copy' stamp: ''! testCopyEquals "self debug: #testCopySameClass" "A copy should be equivalent to the things it's a copy of" | copy | copy := self nonEmpty copy. self assert: copy = self nonEmpty.! ! !IntervalTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testAtPin "self debug: #testAtPin" self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! !IntervalTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testAtLastIfAbsent "self debug: #testAtLastIfAbsent" self assert: (self moreThan4Elements atLast: 1 ifAbsent: [ nil ]) = self moreThan4Elements last. self assert: (self moreThan4Elements atLast: self moreThan4Elements size + 1 ifAbsent: [ 222 ]) = 222! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfterLast: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !IntervalTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButLastNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButLast: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i) ]. self assert: abf size + 2 = col size! ! !IntervalTest methodsFor: 'tests' stamp: 'nice 4/29/2007 21:35'! testIndexOfBug1602 "This test is by german morales. It is about mantis bug 1602" self should: ((1 to: 5 by: 1) indexOf: 2.5) = 0. "obvious" self should: ((100000000000000 to: 500000000000000 by: 100000000000000) indexOf: 250000000000000) = 0. "same as above with 14 zeros appended"! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testAfterIfAbsent "self debug: #testAfterIfAbsent" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1) ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ifAbsent: [ 33 ]) = 33. self assert: (self moreThan4Elements after: self elementNotInForElementAccessing ifAbsent: [ 33 ]) = 33! ! !IntervalTest methodsFor: 'tests - converting' stamp: ''! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !IntervalTest methodsFor: 'test - equality' stamp: ''! testEqualSignIsTrueForEmptyButNonIdenticalCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). ! ! !IntervalTest methodsFor: 'tests - copying with or without' stamp: ''! testForceToPaddingWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). "verify content of 'result' : " 1 to: self nonEmpty size do: [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. (result size - 1) to: result size do: [:i | self assert: ( result at:i ) = ( element ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !IntervalTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/5/2008 13:08'! nonEmpty ^ nonEmpty! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindLast | element result | element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. self assert: result=self nonEmptyMoreThan1Element size. ! ! !IntervalTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyNonEmpty "self debug: #testCopyNonEmpty" | copy | copy := self nonEmpty copy. self deny: copy isEmpty. self assert: copy size = self nonEmpty size. self nonEmpty do: [:each | copy includes: each]! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testFirstSecondThird "self debug: #testFirstSecondThird" self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! !IntervalTest methodsFor: 'tests - copying with or without' stamp: ''! testForceToPaddingStartWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). "verify content of 'result' : " 1 to: 2 do: [:i | self assert: ( element ) = ( result at:(i) ) ]. 3 to: result size do: [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:07'! sizeCollection "Answers a collection whose #size is 4" ^ 1 to: 4.! ! !IntervalTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithFirst | index element result | index:= self indexInNonEmpty . element:= self nonEmpty at: index. result := self nonEmpty copyWithFirst: element. self assert: result size = (self nonEmpty size + 1). self assert: result first = element . 2 to: result size do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! !IntervalTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/5/2008 13:08'! empty ^ empty ! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testAtLast "self debug: #testAtLast" | index | self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. "tmp:=1. self do: [:each | each =self elementInForIndexAccessing ifTrue:[index:=tmp]. tmp:=tmp+1]." index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! !IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:55'! collection ^ nonEmpty! ! !IntervalTest methodsFor: 'tests - sorting' stamp: ''! testIsSorted self assert: self sortedInAscendingOrderCollection isSorted. self deny: self unsortedCollection isSorted! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !IntervalTest methodsFor: 'tests - converting' stamp: ''! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !IntervalTest methodsFor: 'tests - equality' stamp: ''! testEqualSignForSequenceableCollections "self debug: #testEqualSign" self deny: (self nonEmpty = self nonEmpty asSet). self deny: (self nonEmpty reversed = self nonEmpty). self deny: (self nonEmpty = self nonEmpty reversed).! ! !IntervalTest methodsFor: 'as yet unclassified' stamp: ''! testStreamContents | result index | result:= self collectionClass streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !IntervalTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !IntervalTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:17'! testNumericTypes (3 asNumber) to: 5 = #(3 4 5). 3.0 to: 5.0 = #(3.0 4.0 5.0). 3.0 to: 5.0 by: 0.5 = #(3.0 3.5 4.0 4.5 5.0). 3/1 to: 5/1 = #(3 4 5). 1/2 to: 5/2 by: 1/2 = #(1/2 1 3/2 2 5/2).! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureBeginsEndsWithTest self nonEmpty. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size > 1. self empty. self assert: self empty isEmpty! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testAtIfAbsent "self debug: #testAt" | absent | absent := false. self moreThan4Elements at: self moreThan4Elements size + 1 ifAbsent: [ absent := true ]. self assert: absent = true. absent := false. self moreThan4Elements at: self moreThan4Elements size ifAbsent: [ absent := true ]. self assert: absent = false! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:35'! collectionNotIncluded ^ (nonEmpty last + 1) to: (nonEmpty last +5)! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ 9! ! !IntervalTest methodsFor: 'test - equality' stamp: ''! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !IntervalTest methodsFor: 'tests - index access' stamp: ''! testIndexOf "self debug: #testIndexOf" | tmp index collection | collection := self collectionMoreThan1NoDuplicates. tmp := collection size. collection reverseDo: [ :each | each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. tmp := tmp - 1 ]. self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! !IntervalTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 8/31/2013 20:23'! test0IndexAccessingTest self accessCollection. self assert: self accessCollection size = 5. self subCollectionNotIn. self subCollectionNotIn detect: [ :each | (self accessCollection includes: each) not ] ifNone: [ self assert: false ]. self elementNotInForIndexAccessing. self deny: (self accessCollection includes: self elementNotInForIndexAccessing). self elementInForIndexAccessing. self assert: (self accessCollection includes: self elementInForIndexAccessing). self collectionOfFloat. self collectionOfFloat do: [ :each | self deny: each class = SmallInteger ]! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSubcollectionAccessTest self moreThan3Elements. self assert: self moreThan3Elements size > 2! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:48'! elementInForIndexAccessing ^ elementIn ! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSequencedElementAccessTest self moreThan4Elements. self assert: self moreThan4Elements size >= 4. self subCollectionNotIn. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self elementNotInForElementAccessing. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self elementInForElementAccessing. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !IntervalTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButFirst "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst. self deny: abf first = col first. self assert: abf size + 1 = col size! ! !IntervalTest methodsFor: 'tests - indexable access' stamp: 'delaunay 4/6/2009 15:24'! testAllButFirstElements "self debug: #testAllButFirst" | abf col | col := self accessCollection. abf := col allButFirst: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. self assert: abf size + 2 = col size! ! !IntervalTest methodsFor: 'tests' stamp: 'nice 4/29/2007 21:34'! testInclusionBug1603 "This test is by german morales. It is about mantis bug 1603" self shouldnt: ((1 to: 5 by: 1) includes: 2.5). "obvious" self shouldnt: ((100000000000000 to: 500000000000000 by: 100000000000000) includes: 250000000000000). "same as above with 14 zeros appended"! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testAllButLastDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !IntervalTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:34'! testEquals self assert: (3 to: 5) = #(3 4 5). self deny: (3 to: 5) = #(3 5). self deny: (3 to: 5) = #(). self assert: #(3 4 5) = (3 to: 5). self deny: #(3 5) = (3 to: 5). self deny: #() = (3 to: 5).! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testPairsCollect | index result | index:=0. result:=self nonEmptyMoreThan1Element pairsCollect: [:each1 :each2 | self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). ]. result do: [:each | self assert: each = true]. ! ! !IntervalTest methodsFor: 'tests - copying same contents' stamp: ''! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:52'! subCollectionNotIn ^subCollectionNotIn ! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithIndexDo "| result | result:=Array new: self nonEmptyMoreThan1Element size. self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element withIndexDo: [:value :i | indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !IntervalTest methodsFor: 'tests - copying same contents' stamp: ''! testReverse | result | result := self nonEmpty reversed. "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at: i) = (self nonEmpty at: (self nonEmpty size - i + 1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testBeforeIfAbsent "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 1) ifAbsent: [ 99 ]) = 99. self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2) ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! !IntervalTest methodsFor: 'tests' stamp: 'nice 4/19/2011 00:43'! testPermutationsDo | i oc | i := (1.234 to: 4.234). oc := OrderedCollection new. i permutationsDo: [:e | oc add: e]. self assert: (oc size = i size factorial). ^ oc! ! !IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:08'! testExtent self assert: (1 to: 10) extent = 9. self assert: (1 to: 10 by: 2) extent = 9. self assert: (1 to:-1) extent = -2! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !IntervalTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 17:25'! speciesClass ^ Array! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringOne "self assert: self oneItemCol asCommaString = '1'. self assert: self oneItemCol asCommaStringAnd = '1'." self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). ! ! !IntervalTest methodsFor: 'tests' stamp: ''! testInvalid "empty, impossible ranges" self assert: (1 to: 0) = #(). self assert: (1 to: -1) = #(). self assert: (-1 to: -2) = #(). self assert: (1 to: 5 by: -1) = #(). "always contains only start value." self assert: (1 to: 1) = #(1). self assert: (1 to: 5 by: 10) = #(1). self assert: (1 to: 0 by: -2) = #(1). ! ! !IntervalTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopySameContentsTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFromToDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 1 to: (self nonEmptyMoreThan1Element size -1) do: [:i| self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:15'! testAt self assert: ((1 to: 10) at: 1) = 1. self assert: ((1 to: 10) at: 3) = 3. self assert: ((1 to: 10 by: 2) at: 1) = 1. self assert: ((1 to: 10 by: 2) at: 3) = 5! ! !IntervalTest methodsFor: 'setup' stamp: 'cyrille.delaunay 12/18/2009 11:56'! setUp empty := (1 to: 0). one := (1 to:1). nonEmpty := -5 to: 10 by: 3. subCollectionInNonEmpty := -2 to: 4 by: 3. nonEmpty1Element:= 1to:1. anotherCollection:= 2 to: 15. collectionWithoutNil := 1 to: 3. collectResult := { SmallInteger. SmallInteger. SmallInteger.}. elementIn :=-2. elementNotIn:= 12. subCollectionNotIn:= -2 to: 1. collectionOfFloat := 1.5 to: 7.5 by: 1. subCollection := 2 to: 8. collectionWithSubCollection := 1 to: 10.! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:48'! elementNotIn ^elementNotIn! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:51'! moreThan3Elements " return a collection including atLeast 3 elements" ^ nonEmpty ! ! !IntervalTest methodsFor: 'tests - element accessing' stamp: ''! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:46'! nonEmptyMoreThan1Element ^nonEmpty .! ! !IntervalTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterOne | delim oneItemStream result | "delim := ', '. oneItemStream := '' readWrite. self oneItemCol asStringOn: oneItemStream delimiter: delim. self assert: oneItemStream contents = '1'." delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:47'! elementInForIncludesTest ^ elementIn ! ! !IntervalTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element ifAbsent: [ 99 ]) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 99 ]) = 99! ! !IntervalTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection last. self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 99 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 99 ]) = 99. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing startingAt: collection size ifAbsent: [ 99 ]) = 99! ! !IntervalTest methodsFor: 'tests - copying with replacement' stamp: ''! firstIndexesOf: aSubCollection in: collection " return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " | tmp result currentIndex | tmp:= collection. result:= OrderedCollection new. currentIndex := 1. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: aSubCollection) ifTrue: [ result add: currentIndex. 1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !InvalidDirectoryError commentStamp: 'TorstenBergmann 2/3/2014 23:09'! Error when accessing an invalid directory! !InvalidDirectoryError methodsFor: 'accessing' stamp: 'ar 5/30/2001 20:45'! pathName: badPathName pathName := badPathName! ! !InvalidDirectoryError methodsFor: 'accessing' stamp: 'ar 5/30/2001 20:44'! pathName ^pathName! ! !InvalidDirectoryError methodsFor: 'exceptiondescription' stamp: 'StephaneDucasse 8/30/2009 16:54'! defaultAction ^#()! ! !InvalidDirectoryError class methodsFor: 'exceptioninstantiator' stamp: 'ar 5/30/2001 20:49'! pathName: badPathName ^self new pathName: badPathName! ! !InvalidGlobalName commentStamp: ''! I am a warning signaled when trying to build a class with invalid name.! !InvalidGlobalName class methodsFor: 'signalling' stamp: 'MartinDias 7/24/2013 13:56'! signal: aMessage for: aName self signal: aName asString, ': ', aMessage ! ! !InvalidSlotName commentStamp: ''! I am signaled when the name of a Slot is an invalid variable name.! !InvalidSlotName class methodsFor: 'signalling' stamp: 'MartinDias 7/24/2013 13:40'! signalFor: aSymbol self signal: aSymbol asString, ' is an invalid name for a slot'! ! !InvalidSocketStatusException commentStamp: 'mir 5/12/2003 18:15'! Signals if an operation on a Socket found it in a state invalid for that operation. ! !InvalidSuperclass commentStamp: ''! I am a warning signaled when trying to build a class with an invalid superclass.! !InvalidSuperclass class methodsFor: 'signalling' stamp: 'MartinDias 7/25/2013 14:16'! signal: aMessage for: anObject self signal: anObject asString, ': ', aMessage ! ! !ItemNode commentStamp: 'TorstenBergmann 2/4/2014 21:14'! An item in the group UI! !ItemNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 2/25/2012 16:40'! rowMorphForColumn: aTreeColumn ^ self item ifNotNil: [:i | i prettyName asMorph] ! ! !ItemNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 3/15/2011 14:07'! isGroup ^ false! ! !JISX0208 commentStamp: 'yo 10/19/2004 19:52'! This class represents the domestic character encoding called JIS X 0208 used for Japanese.! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 7/21/2004 18:36'! unicodeLeadingChar ^ JapaneseEnvironment leadingChar. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'StephaneDucasse 8/22/2013 14:27'! initialize "self initialize" EncodedCharSet declareEncodedCharSet: self atIndex: 1+1. EncodedCharSet declareEncodedCharSet: self atIndex: 4+1. compoundTextSequence := String streamContents: [ :s | s nextPut: (Character value: 27). s nextPut: $$. s nextPut: $B ]! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! ucsTable ^ UCSTable jisx0208Table. ! ! !JISX0208 class methodsFor: 'accessing - displaying' stamp: 'yo 3/18/2003 11:11'! isBreakableAt: index in: text | prev | index = 1 ifTrue: [^ false]. prev := text at: index - 1. prev leadingChar ~= 1 ifTrue: [^ true]. ^ false ! ! !JISX0208 class methodsFor: 'character classification' stamp: 'yo 8/6/2003 05:30'! isLetter: char | value leading | leading := char leadingChar. value := char charCode. leading = 0 ifTrue: [^ super isLetter: char]. value := value // 94 + 1. ^ 1 <= value and: [value < 84]. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/4/2002 22:52'! printingDirection ^ #right. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! compoundTextSequence ^ compoundTextSequence! ! !JISX0208 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state | c1 c2 | state charSize: 2. state g0Leading ~= self leadingChar ifTrue: [ state g0Leading: self leadingChar. state g0Size: 2. aStream basicNextPutAll: compoundTextSequence ]. c1 := ascii // 94 + 33. c2 := ascii \\ 94 + 33. ^ aStream basicNextPut: (Character value: c1); basicNextPut: (Character value: c2)! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/2/2002 17:38'! leadingChar ^ 1. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'ar 4/12/2005 17:34'! stringFromKutenArray: anArray | s | s := WideString new: anArray size. 1 to: anArray size do: [:i | s at: i put: (self charAtKuten: (anArray at: i)). ]. ^s. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'ar 4/9/2005 22:31'! charAtKuten: anInteger | a b | a := anInteger \\ 100. b := anInteger // 100. (a > 94) | (b > 94) ifTrue: [ self error: 'character code is not valid'. ]. ^ Character leadingChar: self leadingChar code: ((b - 1) * 94) + a - 1. ! ! !JPEGColorComponent commentStamp: ''! I represent a single component of color in JPEG YCbCr color space. I can accept a list of blocks in my component from the current MCU, then stream the samples from this block for use in color conversion. I also store the running DC sample value for my component, used by the Huffman decoder. The following layout is fixed for the JPEG primitives to work: currentX currentY hSampleFactor vSampleFactor mcuBlocks > widthInBlocks heightInBlocks dctSize mcuWidth mcuHeight priorDCValue ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! id: anObject id := anObject! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:21'! dcTableIndex ^dcTableIndex! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! dcTableIndex: anInteger dcTableIndex := anInteger! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:21'! acTableIndex ^acTableIndex! ! !JPEGColorComponent methodsFor: 'sample streaming' stamp: 'lr 7/4/2009 10:42'! initializeSampleStreamBlocks: aCollection mcuBlocks := aCollection. self resetSampleStream! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:43'! qTableIndex ^qTableIndex! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! mcuWidth: mw mcuHeight: mh dctSize: ds mcuWidth := mw. mcuHeight := mh. dctSize := ds. hSampleFactor := mcuWidth // widthInBlocks. vSampleFactor := mcuHeight // heightInBlocks! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! updateDCValue: aNumber priorDCValue := priorDCValue + aNumber. ^ priorDCValue! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:09'! id ^id! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:11'! heightInBlocks ^heightInBlocks! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! priorDCValue: aNumber priorDCValue := aNumber! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:11'! widthInBlocks ^widthInBlocks! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! widthInBlocks: anInteger widthInBlocks := anInteger! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:18'! totalMcuBlocks ^ heightInBlocks * widthInBlocks! ! !JPEGColorComponent methodsFor: 'sample streaming' stamp: 'lr 7/4/2009 10:42'! nextSample | dx dy blockIndex sampleIndex sample | dx := currentX // hSampleFactor. dy := currentY // vSampleFactor. blockIndex := dy // dctSize * widthInBlocks + (dx // dctSize) + 1. sampleIndex := dy \\ dctSize * dctSize + (dx \\ dctSize) + 1. sample := (mcuBlocks at: blockIndex) at: sampleIndex. currentX := currentX + 1. currentX < (mcuWidth * dctSize) ifFalse: [ currentX := 0. currentY := currentY + 1 ]. ^ sample! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! qTableIndex: anInteger qTableIndex := anInteger! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! heightInBlocks: anInteger heightInBlocks := anInteger! ! !JPEGColorComponent methodsFor: 'sample streaming' stamp: 'lr 7/4/2009 10:42'! resetSampleStream currentX := 0. currentY := 0! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! acTableIndex: anInteger acTableIndex := anInteger! ! !JPEGHuffmanTable commentStamp: ''! I represent the table of values used to decode Huffman entropy-encoded bitstreams. From the JFIF file header entropy values, I build a derived table of codes and values for faster decoding.! !JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:31'! lookaheadBits ^lookaheadBits! ! !JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:38'! lookaheadSymbol ^lookaheadSymbol! ! !JPEGHuffmanTable methodsFor: 'computation' stamp: 'tao 10/21/97 22:44'! valueForCode: code length: length ^ values at: ((valptr at: length) + code - (mincode at: length))! ! !JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:59'! maxcode ^maxcode! ! !JPEGHuffmanTable methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! bits: anObject bits := anObject! ! !JPEGHuffmanTable methodsFor: 'computation' stamp: 'lr 7/4/2009 10:42'! makeDerivedTables | huffSize huffCode code si index lookbits | mincode := Array new: 16. maxcode := Array new: 17. valptr := Array new: 17. huffSize := OrderedCollection new. 1 to: 16 do: [ :l | 1 to: (bits at: l) do: [ :i | huffSize add: l ] ]. huffSize add: 0. code := 0. huffCode := Array new: huffSize size. si := huffSize at: 1. index := 1. [ (huffSize at: index) ~= 0 ] whileTrue: [ [ (huffSize at: index) = si ] whileTrue: [ huffCode at: index put: code. index := index + 1. code := code + 1 ]. code := code << 1. si := si + 1 ]. index := 1. 1 to: 16 do: [ :l | (bits at: l) ~= 0 ifTrue: [ valptr at: l put: index. mincode at: l put: (huffCode at: index). index := index + (bits at: l). maxcode at: l put: (huffCode at: index - 1) ] ifFalse: [ maxcode at: l put: -1 ] ]. maxcode at: 17 put: 1048575. lookaheadBits := (Array new: 1 << Lookahead) atAllPut: 0. lookaheadSymbol := Array new: 1 << Lookahead. index := 1. 1 to: Lookahead do: [ :l | 1 to: (bits at: l) do: [ :i | lookbits := ((huffCode at: index) << (Lookahead - l)) + 1. (1 << (Lookahead - l) to: 1 by: -1) do: [ :ctr | lookaheadBits at: lookbits put: l. lookaheadSymbol at: lookbits put: (values at: index). lookbits := lookbits + 1 ]. index := index + 1 ] ]! ! !JPEGHuffmanTable methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! values: anObject values := anObject! ! !JPEGHuffmanTable class methodsFor: 'initialization' stamp: 'stephane.ducasse 6/14/2009 22:52'! initialize Lookahead := 8. BitBufferSize := 16! ! !JPEGHuffmanTable class methodsFor: 'constants' stamp: 'tao 10/21/97 22:15'! lookahead ^ Lookahead! ! !JPEGReadStream commentStamp: ''! Encapsulates huffman encoded access to JPEG data. The following layout is fixed for the JPEG primitives to work: collection position readLimit bitBuffer bitsInBuffer ! !JPEGReadStream methodsFor: 'huffman trees' stamp: 'jannik.laval 5/1/2010 17:04'! createHuffmanTables: values counts: counts from: minBits to: maxBits "Create the actual tables" | table tableStart tableSize tableEnd valueIndex tableStack numValues deltaBits maxEntries lastTable lastTableStart tableIndex lastTableIndex | table := WordArray new: ((4 bitShift: minBits) max: 16). "Create the first entry - this is a dummy. It gives us information about how many bits to fetch initially." table at: 1 put: (minBits bitShift: 24) + 2. "First actual table starts at index 2" "Create the first table from scratch." tableStart := 2. "See above" tableSize := 1 bitShift: minBits. tableEnd := tableStart + tableSize. "Store the terminal symbols" valueIndex := counts at: minBits + 1. tableIndex := 0. 1 to: valueIndex do: [ :i | table at: tableStart + tableIndex put: (values at: i). tableIndex := tableIndex + 1 ]. "Fill up remaining entries with invalid entries" tableStack := OrderedCollection new: 10. "Should be more than enough" tableStack addLast: (Array with: minBits with: tableStart with: tableIndex with: minBits with: tableSize - valueIndex). "Number of bits (e.g., depth) for this table" "Start of table" "Next index in table" "Number of delta bits encoded in table" "Entries remaining in table" "Go to next value index" valueIndex := valueIndex + 1. "Walk over remaining bit lengths and create new subtables" minBits + 1 to: maxBits do: [ :bits | numValues := counts at: bits + 1. [ numValues > 0 ] whileTrue: [ "Create a new subtable" lastTable := tableStack last. lastTableStart := lastTable at: 2. lastTableIndex := lastTable at: 3. deltaBits := bits - (lastTable at: 1). "Make up a table of deltaBits size" tableSize := 1 bitShift: deltaBits. tableStart := tableEnd. tableEnd := tableEnd + tableSize. [ tableEnd > table size ] whileTrue: [ table := self growHuffmanTable: table ]. "Connect to last table" [ (table at: lastTableStart + lastTableIndex) = 0 ] assert. "Entry must be unused" table at: lastTableStart + lastTableIndex put: (deltaBits bitShift: 24) + tableStart. lastTable at: 3 put: lastTableIndex + 1. lastTable at: 5 put: (lastTable at: 5) - 1. [ (lastTable at: 5) >= 0 ] assert. "Don't exceed tableSize" "Store terminal values" maxEntries := numValues min: tableSize. tableIndex := 0. 1 to: maxEntries do: [ :i | table at: tableStart + tableIndex put: (values at: valueIndex). valueIndex := valueIndex + 1. numValues := numValues - 1. tableIndex := tableIndex + 1 ]. "Check if we have filled up the current table completely" maxEntries = tableSize ifTrue: [ "Table has been filled. Back up to the last table with space left." [ tableStack isEmpty not and: [ (tableStack last at: 5) = 0 ] ] whileTrue: [ tableStack removeLast ] ] ifFalse: [ "Table not yet filled. Put it back on the stack." tableStack addLast: (Array with: bits with: tableStart with: tableIndex with: deltaBits with: tableSize - maxEntries) "Nr. of bits in this table" "Start of table" "Index in table" "delta bits of table" "Unused entries in table" ] ] ]. ^ table copyFrom: 1 to: tableEnd - 1! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/6/2001 12:35'! nextBytes: n ^(self next: n) asByteArray! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! fillBuffer | byte | [ bitsInBuffer <= 16 ] whileTrue: [ byte := self next. (byte = 255 and: [ (self peekFor: 0) not ]) ifTrue: [ self position: self position - 1. ^ 0 ]. bitBuffer := (bitBuffer bitShift: 8) bitOr: byte. bitsInBuffer := bitsInBuffer + 8 ]. ^ bitsInBuffer! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! resetBitBuffer bitBuffer := 0. bitsInBuffer := 0! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! getBits: requestedBits | value | requestedBits > bitsInBuffer ifTrue: [ self fillBuffer. requestedBits > bitsInBuffer ifTrue: [ self error: 'not enough bits available to decode' ] ]. value := bitBuffer bitShift: requestedBits - bitsInBuffer. bitBuffer := bitBuffer bitAnd: (1 bitShift: bitsInBuffer - requestedBits) - 1. bitsInBuffer := bitsInBuffer - requestedBits. ^ value! ! !JPEGReadStream methodsFor: 'huffman trees' stamp: 'lr 7/4/2009 10:42'! decodeValueFrom: table "Decode the next value in the receiver using the given huffman table." | bits bitsNeeded tableIndex value | bitsNeeded := (table at: 1) bitShift: -24. "Initial bits needed" tableIndex := 2. "First real table" [ bits := self getBits: bitsNeeded. "Get bits" value := table at: tableIndex + bits. "Lookup entry in table" (value bitAnd: 1056964608) = 0 "Check if it is a non-leaf node" ] whileFalse: [ "Fetch sub table" tableIndex := value bitAnd: 65535. "Table offset in low 16 bit" bitsNeeded := (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit" bitsNeeded > MaxBits ifTrue: [ ^ self error: 'Invalid huffman table entry' ] ]. ^ value! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/4/2001 17:40'! reset super reset. self resetBitBuffer! ! !JPEGReadStream methodsFor: 'huffman trees' stamp: 'lr 7/4/2009 10:42'! growHuffmanTable: table | newTable | newTable := table species new: table size * 2. newTable replaceFrom: 1 to: table size with: table startingAt: 1. ^ newTable! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/6/2001 12:34'! nextByte ^self next asInteger! ! !JPEGReadStream methodsFor: 'huffman trees' stamp: 'lr 7/4/2009 10:42'! buildLookupTable: values counts: counts | min max | min := max := nil. 1 to: counts size do: [ :i | (counts at: i) = 0 ifFalse: [ min ifNil: [ min := i - 1 ]. max := i ] ]. ^ self createHuffmanTables: values counts: { 0 } , counts from: min + 1 to: max! ! !JPEGReadStream class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! initialize "JPEGReadStream initialize" MaxBits := 16! ! !JPEGReadWriter commentStamp: ''! I am a subclass of ImageReadWriter that understands JFIF file streams, and can decode JPEG images. This code is based upon the Independent Joint Photographic Experts Group (IJPEG) software, originally written in C by Tom Lane, Philip Gladstone, Luis Ortiz, Jim Boucher, Lee Crocker, Julian Minguillon, George Phillips, Davide Rossi, Ge' Weijers, and other members of the Independent JPEG Group. ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'lr 7/4/2009 10:42'! colorConvertFloatYCbCrMCU | ySampleStream crSampleStream cbSampleStream y cb cr red green blue bits | ySampleStream := currentComponents at: 1. cbSampleStream := currentComponents at: 2. crSampleStream := currentComponents at: 3. ySampleStream resetSampleStream. cbSampleStream resetSampleStream. crSampleStream resetSampleStream. bits := mcuImageBuffer bits. 1 to: bits size do: [ :i | y := ySampleStream nextSample. cb := cbSampleStream nextSample - FloatSampleOffset. cr := crSampleStream nextSample - FloatSampleOffset. red := self sampleFloatRangeLimit: y + (1.402 * cr). green := self sampleFloatRangeLimit: y - (0.34414 * cb) - (0.71414 * cr). blue := self sampleFloatRangeLimit: y + (1.772 * cb). bits at: i put: 4278190080 + (red << 16) + (green << 8) + blue ]! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 21:36'! primColorConvertIntYCbCrMCU self primColorConvertYCbCrMCU: currentComponents bits: mcuImageBuffer bits residuals: residuals ditherMask: ditherMask.! ! !JPEGReadWriter methodsFor: 'testing' stamp: 'ar 3/4/2001 00:50'! understandsImageFormat "Answer true if the image stream format is understood by this decoder." self next = 16rFF ifFalse: [^ false]. self next = 16rD8 ifFalse: [^ false]. ^ true ! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! initialSOSSetup mcuWidth := (components detectMax: [ :c | c widthInBlocks ]) widthInBlocks. mcuHeight := (components detectMax: [ :c | c heightInBlocks ]) heightInBlocks. components do: [ :c | c mcuWidth: mcuWidth mcuHeight: mcuHeight dctSize: DCTSize ]. stream resetBitBuffer! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! parseHuffmanTable | length markerStart index bits count huffVal isACTable hTable | markerStart := self position. length := self nextWord. [ self position - markerStart >= length ] whileFalse: [ index := self next. isACTable := (index bitAnd: 16) ~= 0. index := (index bitAnd: 15) + 1. index > HuffmanTableSize ifTrue: [ self error: 'image has more than ' , HuffmanTableSize printString , ' quantization tables' ]. bits := self next: 16. count := bits sum. (count > 256 or: [ count > (length - (self position - markerStart)) ]) ifTrue: [ self error: 'Huffman Table count is incorrect' ]. huffVal := self next: count. hTable := stream buildLookupTable: huffVal counts: bits. isACTable ifTrue: [ self hACTable at: index put: hTable ] ifFalse: [ self hDCTable at: index put: hTable ] ]! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/24/97 17:32'! parseNOP "don't need to do anything, here"! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 22:19'! primColorConvertGrayscaleMCU self primColorConvertGrayscaleMCU: (currentComponents at: 1) bits: mcuImageBuffer bits residuals: residuals ditherMask: ditherMask.! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! parseStartOfScan | length n id value dcNum acNum comp | length := self nextWord. n := self next. length ~= (n * 2 + 6) | (n < 1) ifTrue: [ self error: 'SOS length is incorrect' ]. currentComponents := Array new: n. 1 to: n do: [ :i | id := self next. value := self next. dcNum := value >> 4 bitAnd: 15. acNum := value bitAnd: 15. comp := components detect: [ :c | c id = id ]. comp dcTableIndex: dcNum + 1; acTableIndex: acNum + 1. currentComponents at: i put: comp ]. ss := self next. se := self next. value := self next. ah := value >> 4 bitAnd: 15. al := value bitAnd: 15. self initialSOSSetup. self perScanSetup. sosSeen := true! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'tao 10/26/97 15:43'! sampleFloatRangeLimit: aNumber ^ (aNumber rounded max: 0) min: MaxSample! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:35'! primIdctInt: anArray qt: qt ^self idctBlockInt: anArray qt: qt! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'lr 7/4/2009 10:42'! colorConvertIntYCbCrMCU | ySampleStream crSampleStream cbSampleStream y cb cr red green blue bits | ySampleStream := currentComponents at: 1. cbSampleStream := currentComponents at: 2. crSampleStream := currentComponents at: 3. ySampleStream resetSampleStream. cbSampleStream resetSampleStream. crSampleStream resetSampleStream. bits := mcuImageBuffer bits. 1 to: bits size do: [ :i | y := ySampleStream nextSample. cb := cbSampleStream nextSample - SampleOffset. cr := crSampleStream nextSample - SampleOffset. red := y + (FIXn1n40200 * cr // 65536) + (residuals at: 1). red > MaxSample ifTrue: [ red := MaxSample ] ifFalse: [ red < 0 ifTrue: [ red := 0 ] ]. residuals at: 1 put: (red bitAnd: ditherMask). red := red bitAnd: MaxSample - ditherMask. red < 1 ifTrue: [ red := 1 ]. green := y - (FIXn0n34414 * cb // 65536) - (FIXn0n71414 * cr // 65536) + (residuals at: 2). green > MaxSample ifTrue: [ green := MaxSample ] ifFalse: [ green < 0 ifTrue: [ green := 0 ] ]. residuals at: 2 put: (green bitAnd: ditherMask). green := green bitAnd: MaxSample - ditherMask. green < 1 ifTrue: [ green := 1 ]. blue := y + (FIXn1n77200 * cb // 65536) + (residuals at: 3). blue > MaxSample ifTrue: [ blue := MaxSample ] ifFalse: [ blue < 0 ifTrue: [ blue := 0 ] ]. residuals at: 3 put: (blue bitAnd: ditherMask). blue := blue bitAnd: MaxSample - ditherMask. blue < 1 ifTrue: [ blue := 1 ]. bits at: i put: 4278190080 + (red bitShift: 16) + (green bitShift: 8) + blue ]! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'lr 7/4/2009 10:42'! idctBlockInt: anArray qt: qt | ws anACTerm dcval z1 z2 z3 z4 z5 t0 t1 t2 t3 t10 t11 t12 t13 shift | ws := Array new: DCTSize2. "Pass 1: process columns from anArray, store into work array" shift := 1 bitShift: ConstBits - Pass1Bits. 1 to: DCTSize do: [ :i | anACTerm := nil. 1 to: DCTSize - 1 do: [ :row | anACTerm ifNil: [ (anArray at: row * DCTSize + i) = 0 ifFalse: [ anACTerm := row ] ] ]. anACTerm == nil ifTrue: [ dcval := (anArray at: i) * (qt at: 1) bitShift: Pass1Bits. 0 to: DCTSize - 1 do: [ :j | ws at: j * DCTSize + i put: dcval ] ] ifFalse: [ z2 := (anArray at: DCTSize * 2 + i) * (qt at: DCTSize * 2 + i). z3 := (anArray at: DCTSize * 6 + i) * (qt at: DCTSize * 6 + i). z1 := (z2 + z3) * FIXn0n541196100. t2 := z1 + (z3 * FIXn1n847759065 negated). t3 := z1 + (z2 * FIXn0n765366865). z2 := (anArray at: i) * (qt at: i). z3 := (anArray at: DCTSize * 4 + i) * (qt at: DCTSize * 4 + i). t0 := z2 + z3 bitShift: ConstBits. t1 := z2 - z3 bitShift: ConstBits. t10 := t0 + t3. t13 := t0 - t3. t11 := t1 + t2. t12 := t1 - t2. t0 := (anArray at: DCTSize * 7 + i) * (qt at: DCTSize * 7 + i). t1 := (anArray at: DCTSize * 5 + i) * (qt at: DCTSize * 5 + i). t2 := (anArray at: DCTSize * 3 + i) * (qt at: DCTSize * 3 + i). t3 := (anArray at: DCTSize + i) * (qt at: DCTSize + i). z1 := t0 + t3. z2 := t1 + t2. z3 := t0 + t2. z4 := t1 + t3. z5 := (z3 + z4) * FIXn1n175875602. t0 := t0 * FIXn0n298631336. t1 := t1 * FIXn2n053119869. t2 := t2 * FIXn3n072711026. t3 := t3 * FIXn1n501321110. z1 := z1 * FIXn0n899976223 negated. z2 := z2 * FIXn2n562915447 negated. z3 := z3 * FIXn1n961570560 negated. z4 := z4 * FIXn0n390180644 negated. z3 := z3 + z5. z4 := z4 + z5. t0 := t0 + z1 + z3. t1 := t1 + z2 + z4. t2 := t2 + z2 + z3. t3 := t3 + z1 + z4. ws at: i put: t10 + t3 >> (ConstBits - Pass1Bits). ws at: DCTSize * 7 + i put: (t10 - t3) // shift. ws at: DCTSize * 1 + i put: (t11 + t2) // shift. ws at: DCTSize * 6 + i put: (t11 - t2) // shift. ws at: DCTSize * 2 + i put: (t12 + t1) // shift. ws at: DCTSize * 5 + i put: (t12 - t1) // shift. ws at: DCTSize * 3 + i put: (t13 + t0) // shift. ws at: DCTSize * 4 + i put: (t13 - t0) // shift ] ]. "Pass 2: process rows from work array, store back into anArray" shift := 1 bitShift: ConstBits + Pass1Bits + 3. 0 to: DCTSize2 - DCTSize by: DCTSize do: [ :i | z2 := ws at: i + 3. z3 := ws at: i + 7. z1 := (z2 + z3) * FIXn0n541196100. t2 := z1 + (z3 * FIXn1n847759065 negated). t3 := z1 + (z2 * FIXn0n765366865). t0 := (ws at: i + 1) + (ws at: i + 5) bitShift: ConstBits. t1 := (ws at: i + 1) - (ws at: i + 5) bitShift: ConstBits. t10 := t0 + t3. t13 := t0 - t3. t11 := t1 + t2. t12 := t1 - t2. t0 := ws at: i + 8. t1 := ws at: i + 6. t2 := ws at: i + 4. t3 := ws at: i + 2. z1 := t0 + t3. z2 := t1 + t2. z3 := t0 + t2. z4 := t1 + t3. z5 := (z3 + z4) * FIXn1n175875602. t0 := t0 * FIXn0n298631336. t1 := t1 * FIXn2n053119869. t2 := t2 * FIXn3n072711026. t3 := t3 * FIXn1n501321110. z1 := z1 * FIXn0n899976223 negated. z2 := z2 * FIXn2n562915447 negated. z3 := z3 * FIXn1n961570560 negated. z4 := z4 * FIXn0n390180644 negated. z3 := z3 + z5. z4 := z4 + z5. t0 := t0 + z1 + z3. t1 := t1 + z2 + z4. t2 := t2 + z2 + z3. t3 := t3 + z1 + z4. anArray at: i + 1 put: (self sampleRangeLimit: (t10 + t3) // shift + SampleOffset). anArray at: i + 8 put: (self sampleRangeLimit: (t10 - t3) // shift + SampleOffset). anArray at: i + 2 put: (self sampleRangeLimit: (t11 + t2) // shift + SampleOffset). anArray at: i + 7 put: (self sampleRangeLimit: (t11 - t2) // shift + SampleOffset). anArray at: i + 3 put: (self sampleRangeLimit: (t12 + t1) // shift + SampleOffset). anArray at: i + 6 put: (self sampleRangeLimit: (t12 - t1) // shift + SampleOffset). anArray at: i + 4 put: (self sampleRangeLimit: (t13 + t0) // shift + SampleOffset). anArray at: i + 5 put: (self sampleRangeLimit: (t13 - t0) // shift + SampleOffset) ]! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! parseStartOfFile | length markerStart value n | markerStart := self position. length := self nextWord. dataPrecision := self next. dataPrecision = 8 ifFalse: [ self error: 'cannot handle ' , dataPrecision printString , '-bit components' ]. height := self nextWord. width := self nextWord. n := self next. height = 0 | (width = 0) | (n = 0) ifTrue: [ self error: 'empty image' ]. length - (self position - markerStart) ~= (n * 3) ifTrue: [ self error: 'component length is incorrect' ]. components := Array new: n. 1 to: components size do: [ :i | components at: i put: (JPEGColorComponent new id: self next; widthInBlocks: ((value := self next) >> 4 bitAnd: 15); heightInBlocks: (value bitAnd: 15); qTableIndex: self next + 1) "heightInBlocks: (((value := self next) >> 4) bitAnd: 16r0F); widthInBlocks: (value bitAnd: 16r0F);" ]! ! !JPEGReadWriter methodsFor: 'public access' stamp: 'tao 9/18/1998 08:53'! nextImage ^ self nextImageDitheredToDepth: Display depth ! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! parseNextMarker "Parse the next marker of the stream" | byte discardedBytes | discardedBytes := 0. [ (byte := self next) = 255 ] whileFalse: [ discardedBytes := discardedBytes + 1 ]. [ [ (byte := self next) = 255 ] whileTrue. byte = 0 ] whileTrue: [ discardedBytes := discardedBytes + 2 ]. discardedBytes > 0 ifTrue: [ "notifyWithLabel: 'warning: extraneous data discarded'" self ]. self perform: (JFIFMarkerParser at: byte ifAbsent: [ (self okToIgnoreMarker: byte) ifTrue: [ #skipMarker ] ifFalse: [ self error: 'marker ' , byte printStringHex , ' cannot be handled' ] ])! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/7/2001 01:02'! colorConvertMCU ^ currentComponents size = 3 ifTrue: [self useFloatingPoint ifTrue: [self colorConvertFloatYCbCrMCU] ifFalse: [self primColorConvertYCbCrMCU: currentComponents bits: mcuImageBuffer bits residuals: residuals ditherMask: ditherMask.]] ifFalse: [self primColorConvertGrayscaleMCU]! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'lr 7/4/2009 10:42'! idctBlockFloat: anArray component: aColorComponent | t0 t1 t2 t3 t4 t5 t6 t7 t10 t11 t12 t13 z5 z10 z11 z12 z13 qt ws | qt := self qTable at: aColorComponent qTableIndex. ws := Array new: DCTSize2. "Pass 1: process columns from input, store into work array" 1 to: DCTSize do: [ :i | t0 := (anArray at: i) * (qt at: i). t1 := (anArray at: DCTSize * 2 + i) * (qt at: DCTSize * 2 + i). t2 := (anArray at: DCTSize * 4 + i) * (qt at: DCTSize * 4 + i). t3 := (anArray at: DCTSize * 6 + i) * (qt at: DCTSize * 6 + i). t10 := t0 + t2. t11 := t0 - t2. t13 := t1 + t3. t12 := (t1 - t3) * DCTK1 - t13. t0 := t10 + t13. t3 := t10 - t13. t1 := t11 + t12. t2 := t11 - t12. t4 := (anArray at: DCTSize + i) * (qt at: DCTSize + i). t5 := (anArray at: DCTSize * 3 + i) * (qt at: DCTSize * 3 + i). t6 := (anArray at: DCTSize * 5 + i) * (qt at: DCTSize * 5 + i). t7 := (anArray at: DCTSize * 7 + i) * (qt at: DCTSize * 7 + i). z13 := t6 + t5. z10 := t6 - t5. z11 := t4 + t7. z12 := t4 - t7. t7 := z11 + z13. t11 := (z11 - z13) * DCTK1. z5 := (z10 + z12) * DCTK2. t10 := DCTK3 * z12 - z5. t12 := DCTK4 * z10 + z5. t6 := t12 - t7. t5 := t11 - t6. t4 := t10 + t5. ws at: i put: t0 + t7. ws at: DCTSize * 7 + i put: t0 - t7. ws at: DCTSize + i put: t1 + t6. ws at: DCTSize * 6 + i put: t1 - t6. ws at: DCTSize * 2 + i put: t2 + t5. ws at: DCTSize * 5 + i put: t2 - t5. ws at: DCTSize * 4 + i put: t3 + t4. ws at: DCTSize * 3 + i put: t3 - t4 ]. "Pass 2: process rows from the workspace" (0 to: DCTSize2 - DCTSize by: DCTSize) do: [ :i | t10 := (ws at: i + 1) + (ws at: i + 5). t11 := (ws at: i + 1) - (ws at: i + 5). t13 := (ws at: i + 3) + (ws at: i + 7). t12 := ((ws at: i + 3) - (ws at: i + 7)) * DCTK1 - t13. t0 := t10 + t13. t3 := t10 - t13. t1 := t11 + t12. t2 := t11 - t12. z13 := (ws at: i + 6) + (ws at: i + 4). z10 := (ws at: i + 6) - (ws at: i + 4). z11 := (ws at: i + 2) + (ws at: i + 8). z12 := (ws at: i + 2) - (ws at: i + 8). t7 := z11 + z13. t11 := (z11 - z13) * DCTK1. z5 := (z10 + z12) * DCTK2. t10 := DCTK3 * z12 - z5. t12 := DCTK4 * z10 + z5. t6 := t12 - t7. t5 := t11 - t6. t4 := t10 + t5. "final output stage: scale down by a factor of 8 and range-limit" anArray at: i + 1 put: (self dctFloatRangeLimit: t0 + t7). anArray at: i + 8 put: (self dctFloatRangeLimit: t0 - t7). anArray at: i + 2 put: (self dctFloatRangeLimit: t1 + t6). anArray at: i + 7 put: (self dctFloatRangeLimit: t1 - t6). anArray at: i + 3 put: (self dctFloatRangeLimit: t2 + t5). anArray at: i + 6 put: (self dctFloatRangeLimit: t2 - t5). anArray at: i + 5 put: (self dctFloatRangeLimit: t3 + t4). anArray at: i + 4 put: (self dctFloatRangeLimit: t3 - t4) ]! ! !JPEGReadWriter methodsFor: 'error handling' stamp: 'tao 10/19/97 12:25'! notSupported: aString self error: aString , ' is not currently supported'! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 17:27'! getBits: requestedBits ^stream getBits: requestedBits! ! !JPEGReadWriter methodsFor: 'preferences' stamp: 'tao 10/26/97 22:09'! useFloatingPoint ^ false! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 21:32'! primDecodeBlockInto: sampleBuffer component: comp dcTable: dcTable acTable: acTable stream: jpegStream ^self decodeBlockInto: sampleBuffer component: comp dcTable: dcTable acTable: acTable! ! !JPEGReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! qTable qTable ifNil: [ qTable := Array new: QuantizationTableSize ]. ^ qTable! ! !JPEGReadWriter methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! on: aStream super on: aStream. stream := JPEGReadStream on: stream upToEnd! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! skipMarker | length markerStart | markerStart := self position. length := self nextWord. self next: length - (self position - markerStart)! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'lr 7/4/2009 10:42'! colorConvertGrayscaleMCU | ySampleStream y bits | ySampleStream := currentComponents at: 1. ySampleStream resetSampleStream. bits := mcuImageBuffer bits. 1 to: bits size do: [ :i | y := ySampleStream nextSample + (residuals at: 2). y > MaxSample ifTrue: [ y := MaxSample ]. residuals at: 2 put: (y bitAnd: ditherMask). y := y bitAnd: MaxSample - ditherMask. y < 1 ifTrue: [ y := 1 ]. bits at: i put: 4278190080 + (y << 16) + (y << 8) + y ]! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:35'! idctBlockInt: anArray component: aColorComponent ^self idctBlockInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! parseStartOfInput restartInterval := 0. densityUnit := 0. xDensity := 1. yDensity := 1! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'tao 10/26/97 15:16'! dctFloatRangeLimit: value ^ (value / 8.0) + FloatSampleOffset.! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! parseDecoderRestartInterval | length | length := self nextWord. length = 4 ifFalse: [ self error: 'DRI length incorrect' ]. restartInterval := self nextWord! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'lr 7/4/2009 10:42'! decodeMCU | comp ci | (restartInterval ~= 0 and: [ restartsToGo = 0 ]) ifTrue: [ self processRestart ]. 1 to: mcuMembership size do: [ :i | ci := mcuMembership at: i. comp := currentComponents at: ci. self primDecodeBlockInto: (mcuSampleBuffer at: i) component: comp dcTable: (hDCTable at: comp dcTableIndex) acTable: (hACTable at: comp acTableIndex) stream: stream ]. restartsToGo := restartsToGo - 1! ! !JPEGReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! hDCTable hDCTable ifNil: [ hDCTable := Array new: HuffmanTableSize ]. ^ hDCTable! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! parseAPPn | length buffer thumbnailLength markerStart | markerStart := self position. length := self nextWord. buffer := self next: 4. buffer asString = 'JFIF' ifFalse: [ "Skip APPs that we're not interested in" stream next: length - 6. ^ self ]. self next. majorVersion := self next. minorVersion := self next. densityUnit := self next. xDensity := self nextWord. yDensity := self nextWord. thumbnailLength := self next * self next * 3. length := length - (self position - markerStart). length = thumbnailLength ifFalse: [ self error: 'APP0 thumbnail length is incorrect.' ]. self next: length! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'lr 7/4/2009 10:42'! scaleQuantizationTable: table | index | index := 1. 1 to: DCTSize do: [ :row | 1 to: DCTSize do: [ :col | table at: index put: ((table at: index) * (QTableScaleFactor at: row) * (QTableScaleFactor at: col)) rounded. index := index + 1 ] ]. ^ table! ! !JPEGReadWriter methodsFor: 'public access' stamp: 'StephaneDucasse 10/25/2013 16:17'! nextImageDitheredToDepth: depth | form xStep yStep x y bb | ditherMask := DitherMasks at: depth ifAbsent: [ self error: 'can only dither to display depths' ]. residuals := WordArray new: 3. sosSeen := false. self parseFirstMarker. [ sosSeen ] whileFalse: [ self parseNextMarker ]. form := Form extent: width @ height depth: depth. bb := BitBlt toForm: form. bb sourceForm: mcuImageBuffer. bb colorMap: (mcuImageBuffer colormapIfNeededFor: form). bb sourceRect: mcuImageBuffer boundingBox. bb combinationRule: Form over. xStep := mcuWidth * DCTSize. yStep := mcuHeight * DCTSize. y := 0. 1 to: mcuRowsInScan do: [ :row | x := 0. 1 to: mcusPerRow do: [ :col | self decodeMCU. self idctMCU. self colorConvertMCU. bb destX: x; destY: y; copyBits. x := x + xStep ]. y := y + yStep ]. ^ form! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/15/2001 18:11'! primColorConvertGrayscaleMCU: componentArray bits: bits residuals: residualArray ditherMask: mask "JPEGReaderPlugin doPrimitive: #primitiveColorConvertGrayscaleMCU." ^self colorConvertGrayscaleMCU! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:37'! primIdctBlockInt: anArray component: aColorComponent ^self primIdctInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! ! !JPEGReadWriter methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! setStream: aStream "Feed it in from an existing source" stream := JPEGReadStream on: aStream upToEnd! ! !JPEGReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! hACTable hACTable ifNil: [ hACTable := Array new: HuffmanTableSize ]. ^ hACTable! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'lr 7/4/2009 10:42'! processRestart stream resetBitBuffer. self parseNextMarker. currentComponents do: [ :c | c priorDCValue: 0 ]. restartsToGo := restartInterval! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! perScanSetup mcusPerRow := (width / (mcuWidth * DCTSize)) ceiling. mcuRowsInScan := (height / (mcuHeight * DCTSize)) ceiling. (currentComponents size = 3 or: [ currentComponents size = 1 ]) ifFalse: [ self error: 'JPEG color space not recognized' ]. mcuMembership := OrderedCollection new. currentComponents withIndexDo: [ :c :i | c priorDCValue: 0. mcuMembership addAll: ((1 to: c totalMcuBlocks) collect: [ :b | i ]) ]. mcuMembership := mcuMembership asArray. mcuSampleBuffer := (1 to: mcuMembership size) collect: [ :i | IntegerArray new: DCTSize2 ]. currentComponents withIndexDo: [ :c :i | c initializeSampleStreamBlocks: ((1 to: mcuMembership size) select: [ :j | i = (mcuMembership at: j) ] thenCollect: [ :j | mcuSampleBuffer at: j ]) ]. mcuImageBuffer := Form extent: mcuWidth @ mcuHeight * DCTSize depth: 32. restartsToGo := restartInterval! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'mir 6/13/2001 13:06'! okToIgnoreMarker: aMarker ^ (((16rE0 to: 16rEF) includes: aMarker) "unhandled APPn markers" or: [aMarker = 16rDC or: [aMarker = 16rFE]]) "DNL or COM markers" or: [aMarker = 16r99] "Whatever that is"! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'di 9/15/1998 14:30'! sampleRangeLimit: aNumber aNumber < 0 ifTrue: [^ 0]. aNumber > MaxSample ifTrue: [^ MaxSample]. ^ aNumber! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'lr 7/4/2009 10:42'! decodeBlockInto: anArray component: aColorComponent dcTable: huffmanDC acTable: huffmanAC | byte i zeroCount | byte := stream decodeValueFrom: huffmanDC. byte ~= 0 ifTrue: [ byte := self scaleAndSignExtend: (self getBits: byte) inFieldWidth: byte ]. byte := aColorComponent updateDCValue: byte. anArray atAllPut: 0. anArray at: 1 put: byte. i := 2. [ i <= DCTSize2 ] whileTrue: [ byte := stream decodeValueFrom: huffmanAC. zeroCount := byte >> 4. byte := byte bitAnd: 15. byte ~= 0 ifTrue: [ i := i + zeroCount. byte := self scaleAndSignExtend: (self getBits: byte) inFieldWidth: byte. anArray at: (JPEGNaturalOrder at: i) put: byte ] ifFalse: [ zeroCount = 15 ifTrue: [ i := i + zeroCount ] ifFalse: [ ^ self ] ]. i := i + 1 ]! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 21:36'! primColorConvertYCbCrMCU: componentArray bits: bits residuals: residualArray ditherMask: mask ^self colorConvertIntYCbCrMCU! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! parseQuantizationTable | length markerStart n prec value table | markerStart := self position. length := self nextWord. [ self position - markerStart >= length ] whileFalse: [ value := self next. n := (value bitAnd: 15) + 1. prec := value >> 4 > 0. n > QuantizationTableSize ifTrue: [ self error: 'image has more than ' , QuantizationTableSize printString , ' quantization tables' ]. table := IntegerArray new: DCTSize2. 1 to: DCTSize2 do: [ :i | value := prec ifTrue: [ self nextWord ] ifFalse: [ self next ]. table at: (JPEGNaturalOrder at: i) put: value ]. self useFloatingPoint ifTrue: [ self scaleQuantizationTable: table ]. self qTable at: n put: table ]! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'lr 7/4/2009 10:42'! idctMCU | comp fp ci | fp := self useFloatingPoint. 1 to: mcuMembership size do: [ :i | ci := mcuMembership at: i. comp := currentComponents at: ci. fp ifTrue: [ self idctBlockFloat: (mcuSampleBuffer at: i) component: comp ] ifFalse: [ self primIdctInt: (mcuSampleBuffer at: i) qt: (qTable at: comp qTableIndex) ] ]! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 01:17'! scaleAndSignExtend: aNumber inFieldWidth: w aNumber < (1 bitShift: (w - 1)) ifTrue: [^aNumber - (1 bitShift: w) + 1] ifFalse: [^aNumber]! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! parseFirstMarker | marker | self next = 255 ifFalse: [ self error: 'JFIF marker expected' ]. marker := self next. marker = 217 ifTrue: [ ^ self "halt: 'EOI encountered.'" ]. marker = 216 ifFalse: [ self error: 'SOI marker expected' ]. self parseStartOfInput! ! !JPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'MarianoMartinezPeck 3/24/2010 21:13'! understandsImageFormat: aStream (PluginBasedJPEGReadWriter understandsImageFormat: aStream) ifTrue:[^false]. aStream reset. aStream next = 16rFF ifFalse: [^ false]. aStream next = 16rD8 ifFalse: [^ false]. ^true! ! !JPEGReadWriter class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! initialize "JPEGReadWriter initialize" "general constants" DCTSize := 8. MaxSample := (2 raisedToInteger: DCTSize) - 1. SampleOffset := MaxSample // 2. FloatSampleOffset := SampleOffset asFloat. DCTSize2 := DCTSize squared. QuantizationTableSize := 4. HuffmanTableSize := 4. "floating-point Inverse Discrete Cosine Transform (IDCT) constants" ConstBits := 13. Pass1Bits := 2. DCTK1 := 2 sqrt. DCTK2 := 1.847759065. DCTK3 := 1.0823922. DCTK4 := -2.61312593. Pass1Div := 1 bitShift: ConstBits - Pass1Bits. Pass2Div := 1 bitShift: ConstBits + Pass1Bits + 3. "fixed-point Inverse Discrete Cosine Transform (IDCT) constants" FIXn0n298631336 := 2446. FIXn0n390180644 := 3196. FIXn0n541196100 := 4433. FIXn0n765366865 := 6270. FIXn0n899976223 := 7373. FIXn1n175875602 := 9633. FIXn1n501321110 := 12299. FIXn1n847759065 := 15137. FIXn1n961570560 := 16069. FIXn2n053119869 := 16819. FIXn2n562915447 := 20995. FIXn3n072711026 := 25172. "fixed-point color conversion constants" FIXn0n34414 := 22554. FIXn0n71414 := 46802. FIXn1n40200 := 91881. FIXn1n77200 := 116130. "reordering table from JPEG zig-zag order" JPEGNaturalOrder := #( 1 2 9 17 10 3 4 11 18 25 33 26 19 12 5 6 13 20 27 34 41 49 42 35 28 21 14 7 8 15 22 29 36 43 50 57 58 51 44 37 30 23 16 24 31 38 45 52 59 60 53 46 39 32 40 47 54 61 62 55 48 56 63 64 ). "scale factors for the values in the Quantization Tables" QTableScaleFactor := (0 to: DCTSize - 1) collect: [ :k | k = 0 ifTrue: [ 1.0 ] ifFalse: [ (k * Float pi / 16) cos * 2 sqrt ] ]. "dithering masks" (DitherMasks := Dictionary new) add: 0 -> 0; add: 1 -> 127; add: 2 -> 63; add: 4 -> 63; add: 8 -> 31; add: 16 -> 7; add: 32 -> 0. "dictionary of marker parsers" (JFIFMarkerParser := Dictionary new) add: 1 -> #parseNOP; add: 192 -> #parseStartOfFile; add: 196 -> #parseHuffmanTable; addAll: ((208 to: 215) collect: [ :m | Association key: m value: #parseNOP ]); add: 216 -> #parseStartOfInput; add: 217 -> #parseEndOfInput; add: 218 -> #parseStartOfScan; add: 219 -> #parseQuantizationTable; add: 221 -> #parseDecoderRestartInterval; add: 224 -> #parseAPPn; add: 225 -> #parseAPPn! ! !JPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('jpg' 'jpeg')! ! !JapaneseEnvironment commentStamp: ''! This class provides the Japanese support. Since it has been used most other than default 'latin-1' languages, this tends to be a good place to look at when you want to know what a typical subclass of LanguageEnvironment should do. ! !JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'cami 7/22/2013 18:25'! systemConverterClass | encoding | Smalltalk os isWin32 ifTrue: [^ShiftJISTextConverter]. Smalltalk os isMacOS ifTrue: [^UTF8TextConverter]. Smalltalk os isUnix ifTrue: [encoding := X11Encoding encoding. encoding ifNil: [^EUCJPTextConverter]. (encoding = 'utf-8') ifTrue: [^UTF8TextConverter]. (encoding = 'shiftjis' or: [ encoding = 'sjis' ]) ifTrue: [^ShiftJISTextConverter]. ^EUCJPTextConverter]. ^UTF8TextConverter! ! !JapaneseEnvironment class methodsFor: 'language methods' stamp: 'ar 4/9/2005 22:31'! fromJISX0208String: aString ^ aString collect: [:each | Character leadingChar: JapaneseEnvironment leadingChar code: (each asUnicode)]. ! ! !JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/21/2004 19:09'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." ^#('ja' 'ja-etoys' )! ! !JapaneseEnvironment class methodsFor: 'class initialization' stamp: 'StephaneDucasse 8/22/2013 14:29'! initialize EncodedCharSet declareEncodedCharSet: self atIndex: 5+1.! ! !JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/17/2004 21:54'! scanSelector ^ #scanJapaneseCharactersFrom:to:in:rightX:stopConditions:kern: ! ! !JapaneseEnvironment class methodsFor: 'rendering support' stamp: 'yo 3/18/2005 08:00'! isBreakableAt: index in: text | prev | index = 1 ifTrue: [^ false]. prev := text at: index - 1. prev leadingChar ~= JapaneseEnvironment leadingChar ifTrue: [^ true]. ^ (('、。，．・：；？！゛゜´｀¨＾―‐／\〜‖｜…‥’”）〕］｝〉》」』】°′″℃' includes: (text at: index)) or: ['‘“（〔［｛〈《「『【°′″℃＠§' includes: prev]) not. !]lang[(177 11 1 1 1 4 1 16 1 3 36 11 1 4 25)0,5,0,5,0,5,0,5,0,5,0,5,0,5,0! ! !JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/16/2004 14:49'! traditionalCharsetClass ^ JISX0208. ! ! !JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 21:55'! leadingChar ^ 5. ! ! !JapaneseEnvironment class methodsFor: 'language methods' stamp: 'tpr 10/3/2013 12:56'! scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX font: aFont "scanning multibyte Japanese strings" ^aFont scanMultibyteJapaneseCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX! ! !Job commentStamp: ''! A Job is a task to run and potentially notified to the user. [:job | job title: 'Let us get started'. 1to: 10 do: [:each | JobProgress progress: (0.1 * each); title: 'Youpi ', each printString . (Delay forMilliseconds: 100) wait. ] ] asJob run! !Job methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2012 15:54'! parent: aJob parent := aJob.! ! !Job methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:37'! decrement self currentValue: self currentValue - 1.! ! !Job methodsFor: 'notification-handling' stamp: 'CamilloBruni 9/1/2012 12:55'! handleJobProgress: notification notification title ifNotNil: [ title := notification title ]. notification progress ifNotNil: [ self basicProgress: notification progress ]. self announceChange.! ! !Job methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2012 15:53'! addChild: aJob children add: aJob. aJob parent: self.! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 13:46'! max ^ max! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 15:11'! children ^ children copy.! ! !Job methodsFor: 'private' stamp: 'CamilloBruni 8/30/2012 17:37'! cleanupAfterRunning isRunning := false. process := nil. self announce: JobEnd. parent ifNotNil: [ :job | job removeChild: self ].! ! !Job methodsFor: 'accessing' stamp: 'StephanEggermont 9/3/2013 15:57'! announce: anAnnouncementClass | announcement | announcement := anAnnouncementClass on: self. self announcer announce: announcement.! ! !Job methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2012 15:54'! removeChild: aJob children remove: aJob.! ! !Job methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:37'! increment self currentValue: self currentValue + 1.! ! !Job methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:36'! value ^ self currentValue.! ! !Job methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:33'! value: aNumber self currentValue: aNumber.! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 13:46'! title ^ title! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 16:11'! title: anObject title := anObject. self announceChange.! ! !Job methodsFor: 'initialization' stamp: 'CamilloBruni 8/31/2012 09:32'! initialize super initialize. min := 0. max := 100. currentValue := 0. title := ''. isRunning := false. children := OrderedCollection new.! ! !Job methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2012 09:22'! isRunning ^ isRunning! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 13:46'! currentValue ^ currentValue! ! !Job methodsFor: 'progress' stamp: 'CamilloBruni 9/1/2012 12:55'! progress: aNormalizedFloat "Set the progress: 0.0 - 1.0" self basicProgress: aNormalizedFloat. self announceChange.! ! !Job methodsFor: 'progress' stamp: 'ChristopheDemarey 4/12/2013 13:53'! progress "Avoid negative progress and divideByZero." ^ min >= max ifTrue: [ 1 ] ifFalse: [ (currentValue - min) / (max - min) ]! ! !Job methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 13:08'! migrateProgressWhileUpdatingBounds: aBlockChangingBounds "Keep the progress value consistent while we change min / max" | progress | progress := self progress. aBlockChangingBounds value. self progress: progress.! ! !Job methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:34'! label: aString self title: aString.! ! !Job methodsFor: 'notification-handling' stamp: 'CamilloBruni 9/1/2012 12:52'! handleJobStart: aJobStartNotification self addChild: aJobStartNotification job.! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 16:10'! announceChange isRunning ifFalse: [ ^ self ]. self announce: JobChange.! ! !Job methodsFor: 'progress' stamp: 'StephanEggermont 9/3/2013 15:57'! announcer ^ Job jobAnnouncer! ! !Job methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:12'! current: aNumber self currentValue: aNumber.! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 13:46'! block ^ block! ! !Job methodsFor: 'private' stamp: 'CamilloBruni 9/1/2012 12:55'! basicProgress: aNormalizedFloat "Set the progress: 0.0 - 1.0 without triggering an update" currentValue := (min + ((max - min) * aNormalizedFloat))! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 16:11'! currentValue: aNumber currentValue := aNumber. self announceChange.! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 13:46'! min ^ min! ! !Job methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 13:04'! max: aNumber self migrateProgressWhileUpdatingBounds: [ max := aNumber ].! ! !Job methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 13:05'! min: aNumber self migrateProgressWhileUpdatingBounds: [ min := aNumber ]. self announceChange.! ! !Job methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2012 13:42'! block: aBlock block := aBlock.! ! !Job methodsFor: 'running' stamp: 'CamilloBruni 10/9/2012 14:22'! run | result | [ self prepareForRunning. [ result := block cull: self ] on: JobNotification do: [ :notification | notification handle: self ]] ensure: [ self cleanupAfterRunning ]. ^ result.! ! !Job methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:35'! label ^ self title.! ! !Job methodsFor: 'debugging' stamp: 'CamilloBruni 8/31/2012 09:23'! debug ^ process debug! ! !Job methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:36'! current ^ self currentValue.! ! !Job methodsFor: 'private' stamp: 'CamilloBruni 10/5/2012 17:07'! prepareForRunning isRunning := true. JobStartNotification on: self. process := Processor activeProcess. self announce: JobStart.! ! !Job class methodsFor: 'accessing' stamp: 'MartinDias 11/26/2013 17:10'! current "Answer the current job or nil if none." ^ JobDetector signal! ! !Job class methodsFor: 'example' stamp: 'CamilloBruni 9/1/2012 20:15'! basicExample "Job basicExample" [ :job| job title: 'Simulating some progress for 1 Second'. 1 second asDelay wait. "simulate some work". job currentValue: 50. 1 second asDelay wait. "simulate some more work". job currentValue: 100. 1 second asDelay wait. "simulate some more work". ] asJob run.! ! !Job class methodsFor: 'announcing' stamp: 'StephanEggermont 9/3/2013 15:56'! jobAnnouncer ^jobAnnouncer ifNil: [ jobAnnouncer := Announcer new ]! ! !Job class methodsFor: 'example' stamp: 'CamilloBruni 9/1/2012 20:19'! basicExample2 "Job basicExample2" [[ :job| job max: 10. 1 to: 10 do: [ :i| job title: 'Fib ', i asString. "do some hard work" 40 benchFib. "update the job progress" job currentValue: i ] ] asJob run] fork.! ! !Job class methodsFor: 'example' stamp: 'CamilloBruni 8/30/2012 17:39'! exampleDebug "Job exampleDebug" | aJob | aJob := [ :job| "Set some job properties" job title: 'aTitle'; max: 10. 1 to: 10 do: [ :i| job title: 'Fib ', i asString. "do some hard work" 40 benchFib. "update the job progress" job currentValue: i. ] ] asJob. "run a different thread to interrupt the job" [ aJob run ] forkAt: Processor userBackgroundPriority. 1 second asDelay wait. "wait for the job to start properly" aJob debug ! ! !Job class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/29/2012 13:42'! block: aBlock ^ self new block: aBlock.! ! !JobChange commentStamp: ''! A JobChange is an announcement for a job change. To get notify SystemAnnouncer uniqueInstance on: JobChange send: #XXX to: whoever.! !JobChange methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 13:16'! min ^ job min! ! !JobChange methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 14:17'! job ^ job! ! !JobChange methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 14:17'! job: anObject job := anObject! ! !JobChange methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 13:16'! title ^ job title! ! !JobChange methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 13:16'! max ^ job max! ! !JobChange methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 13:16'! progress ^ job progress! ! !JobChange class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/29/2012 14:38'! on: aJob ^ self new job: aJob.! ! !JobDetector commentStamp: ''! I am a notification for getting the current job, if there is one. Usage: JobDetector signal. The result is nil when there is not a current job.! !JobDetector methodsFor: 'handling' stamp: 'MartinDias 11/26/2013 15:33'! handle: aJob self resume: aJob! ! !JobEnd commentStamp: ''! A JobChange is an announcement for a job end. A JobChange is an announcement for a job change. To get notify SystemAnnouncer uniqueInstance on: JobEnd send: #XXX to: whoever.! !JobEnd methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 14:08'! job ^ job! ! !JobEnd methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 14:08'! job: anObject job := anObject! ! !JobEnd class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/29/2012 14:38'! on: aJob ^ self new job: aJob.! ! !JobNotification commentStamp: ''! A JobNotification class is an abstract class representing the root of JobNotification.! !JobNotification methodsFor: 'handling' stamp: 'CamilloBruni 9/1/2012 12:48'! handle: aJob self subclassResponsibility! ! !JobProgress commentStamp: ''! A JobProgress is a notification to announce job progress. For example: [:job | job title: 'Let us get started'. 1to: 10 do: [:each | JobProgress progress: 0.1* each ; title: 'Youpi ', each printString . (Delay forMilliseconds: 100) wait. ] ] asJob run! !JobProgress methodsFor: 'handling' stamp: 'CamilloBruni 9/1/2012 12:52'! handle: aJob aJob handleJobProgress: self. self resume.! ! !JobProgress methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 12:51'! title ^ title! ! !JobProgress methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 12:51'! title: anObject title := anObject! ! !JobProgress methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 12:51'! progress: anObject progress := anObject! ! !JobProgress methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 12:51'! progress ^ progress! ! !JobProgress class methodsFor: 'instance-creation' stamp: 'CamilloBruni 9/1/2012 12:51'! title: aTitleString progress: aNormalizedNumber self new title: aTitleString; progress: aNormalizedNumber; signal.! ! !JobProgress class methodsFor: 'instance-creation' stamp: 'CamilloBruni 9/1/2012 12:51'! title: aTitleString self new title: aTitleString; signal.! ! !JobProgress class methodsFor: 'instance-creation' stamp: 'CamilloBruni 9/1/2012 12:51'! progress: aNormalizedNumber self new progress: aNormalizedNumber; signal.! ! !JobProgressBarMorph commentStamp: ''! A JobProgressBarMorph is a progress bar with a title and a icon to stop update. JobProgressBarMorph new openInWorld! !JobProgressBarMorph methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/30/2012 19:04'! increment ^ progressBar increment! ! !JobProgressBarMorph methodsFor: 'initialization' stamp: 'CamilloBruni 9/14/2013 16:41'! initialize super initialize. progressBar := ProgressBarMorph new. progressBar hResizing: #spaceFill. button := Smalltalk ui icons stopIcon asMorph. self extent: 200@20. self color: Color transparent; layoutPolicy: TableLayout new; listDirection: #leftToRight; cellPositioning: #leftCenter; cellInset: 3; listCentering: #center; hResizing: #spaceFill; vResizing: #shrinkWrap. self addMorphBack: progressBar; addMorphBack: button.! ! !JobProgressBarMorph methodsFor: 'evaluating' stamp: 'CamilloBruni 8/30/2012 19:04'! value ^ progressBar value! ! !JobProgressBarMorph methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/30/2012 19:04'! decrement ^ progressBar decrement! ! !JobProgressBarMorph methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/30/2012 19:04'! value: aNumber ^ progressBar value: aNumber! ! !JobProgressBarMorph methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 9/1/2012 13:18'! progress: aNormalizedNumber ^ progressBar value: aNormalizedNumber * 100! ! !JobProgressBarMorph methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 9/1/2012 13:18'! progress ^ progressBar value / 100! ! !JobProgressMorph commentStamp: ''! I combine a progress title and a JobPorgressBarMorph to a visual representation of a Job. Usually I am contained in the global instance of the SystemProgressMorph! !JobProgressMorph methodsFor: 'private' stamp: 'MarcusDenker 9/13/2013 16:18'! updateLayout labelMorph contents isEmpty ifFalse: [ self addMorphBack: labelMorph]. self addMorphBack: bar.! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 5/14/2012 19:49'! decrement bar decrement.! ! !JobProgressMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/19/2013 15:29'! close SystemProgressMorph uniqueInstance close: self. self removeDependent: SystemProgressMorph uniqueInstance.! ! !JobProgressMorph methodsFor: 'private' stamp: 'SeanDeNigris 5/23/2012 00:22'! forceRefreshOnNextChange lastRefresh := 0.! ! !JobProgressMorph methodsFor: 'private' stamp: 'Sd 11/30/2012 21:42'! result ^ result! ! !JobProgressMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 2/19/2013 16:13'! changed | msRefreshRate isTimeForRefresh | msRefreshRate := 60 "roughly 16 times per second". isTimeForRefresh := Time millisecondClockValue - self lastRefresh >= msRefreshRate. (self isInWorld and: [ isTimeForRefresh ]) ifTrue: [ super changed ].! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 5/14/2012 19:49'! increment bar increment.! ! !JobProgressMorph methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:05'! initialize super initialize. self addDependent: SystemProgressMorph uniqueInstance.! ! !JobProgressMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/19/2013 15:34'! lastRefresh ^ lastRefresh ifNil: [ lastRefresh := 0 ]! ! !JobProgressMorph methodsFor: 'private' stamp: 'SeanDeNigris 5/14/2012 15:09'! start: aNumber startValue := aNumber.! ! !JobProgressMorph methodsFor: 'API' stamp: 'BenjaminVanRyseghem 3/1/2013 17:52'! progress: aNormalizedNumber bar progress = aNormalizedNumber ifFalse: [ bar progress: aNormalizedNumber. self changed: #progressValue ].! ! !JobProgressMorph methodsFor: 'API' stamp: 'BenjaminVanRyseghem 3/1/2013 17:47'! label: aString self label isEmpty ifTrue: [ aString isEmptyOrNil ifTrue: [ ^self ]. self removeAllMorphs. self labelMorph contents: aString. self updateLayout. self changed: #width ]. self labelMorph contents = aString ifFalse: [ self labelMorph contents: aString. aString isEmptyOrNil ifTrue: [ self removeMorph: self labelMorph ]. self changed: #width ]. self changed: #width! ! !JobProgressMorph methodsFor: 'API' stamp: 'CamilloBruni 9/1/2012 13:19'! progress ^ bar progress! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 6/20/2012 23:24'! current: aNumber bar value: aNumber. self changed.! ! !JobProgressMorph methodsFor: 'private' stamp: 'Sd 11/30/2012 21:42'! max: aNumber endValue := aNumber! ! !JobProgressMorph methodsFor: 'private' stamp: 'StephaneDucasse 5/20/2012 19:39'! startAt: aNumber startValue := aNumber.! ! !JobProgressMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/19/2013 16:04'! refresh lastRefresh := Time millisecondClockValue. self width: (labelMorph width) + 25.! ! !JobProgressMorph methodsFor: 'private' stamp: 'SeanDeNigris 5/14/2012 15:23'! labelMorph ^ labelMorph.! ! !JobProgressMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/30/2012 19:27'! job: aJob job := aJob! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 5/22/2012 20:18'! label ^ self labelMorph contents.! ! !JobProgressMorph methodsFor: 'private' stamp: 'SeanDeNigris 5/23/2012 00:40'! do: aBlock self changed. "We may be in the UI thread, so this will give us a change to dsiplay ourselves before the block starts" ^ [ aBlock value: self ] ensure: [ self close ].! ! !JobProgressMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/19/2013 15:34'! initializeJob: aJob super initialize. lock := Semaphore forMutualExclusion. job := aJob. hasResult := false. lastRefresh := 0. self color: Color transparent; layoutPolicy: TableLayout new; listDirection: #topToBottom; cellPositioning: #leftCenter; listCentering: #center; hResizing: #spaceFill; vResizing: #shrinkWrap. labelMorph := StringMorph contents: job title font: StandardFonts defaultFont. bar := JobProgressBarMorph new. bar on: #mouseUp send: #debug to: self; hResizing: #spaceFill. self updateLayout.! ! !JobProgressMorph methodsFor: 'action' stamp: 'CamilloBruni 8/31/2012 09:21'! debug job isRunning ifTrue: [ job debug ].! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 5/14/2012 19:48'! current ^ bar value.! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 5/23/2012 00:25'! beComplete self close.! ! !JobProgressMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/19/2013 15:35'! result: anObject lock critical: [ hasResult := true. result := anObject ].! ! !JobProgressMorph class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/30/2012 19:31'! job: aJob ^ self new initializeJob: aJob! ! !JobStart commentStamp: ''! A JobStart is announcement announcing the start of a job execution. SystemAnnouncer uniqueInstance on: JobStart send: #XXX to: whoever.! !JobStart methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 13:56'! job ^ job! ! !JobStart methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 13:56'! job: anObject job := anObject! ! !JobStart class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/29/2012 14:38'! on: aJob ^ self new job: aJob.! ! !JobStartNotification commentStamp: ''! A JobStartNotification is the first notification raised when a job start.! !JobStartNotification methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2012 11:00'! job ^ job! ! !JobStartNotification methodsFor: 'handling' stamp: 'CamilloBruni 9/1/2012 12:52'! handle: aJob aJob handleJobStart: self. self resume.! ! !JobStartNotification methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2012 11:00'! job: anObject job := anObject! ! !JobStartNotification class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/31/2012 11:00'! on: aJob ^ (self new job: aJob) signal.! ! !JobTest commentStamp: 'TorstenBergmann 2/5/2014 08:39'! SUnit tests for Job class! !JobTest methodsFor: 'tests' stamp: 'CamilloBruni 9/1/2012 13:00'! testProgressNotification | wasRun | wasRun := false. [ :job | "job precondition" self assert: job title equals: ''. self assert: job progress equals: 0. JobProgress title: 'foo' progress: 0.5. self assert: job title equals: 'foo'. self assert: job progress equals: 0.5. wasRun := true ] asJob run. self assert: wasRun.! ! !JobTest methodsFor: 'tests' stamp: 'CamilloBruni 9/1/2012 13:00'! testProgressNotificationChildJob | wasRun | wasRun := false. [ :job | "job precondition" self assert: job title equals: ''. self assert: job progress equals: 0. [ :job2 | "job2 precondition" self assert: job2 title equals: ''. self assert: job2 progress equals: 0. "signal a JobProgress which will only affect the inner job" JobProgress title: 'foo' progress: 0.5. self assert: job2 title equals: 'foo'. self assert: job2 progress equals: 0.5. "outer job is not touched" self assert: job title equals: ''. self assert: job progress equals: 0. wasRun := true ] asJob run. self assert: job children isEmpty ] asJob run. self assert: wasRun.! ! !JobTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2012 09:32'! testProgressChangeByCurrentValue | job | job := Job new. job min: 1; max: 11. self assert: job progress equals: 0.0. job currentValue: 6. self assert: job progress equals: 0.5. job currentValue: 11. self assert: job progress equals: 1.0.! ! !JobTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2012 09:32'! testProgress | job | job := Job new. self assert: job progress equals: 0.0. job min: 0; max: 1. self assert: job progress equals: 0.0. job currentValue: 1. self assert: job progress equals: 1.0.! ! !JobTest methodsFor: 'tests' stamp: 'PavelKrivanek 11/13/2012 10:29'! tearDown Smalltalk globals at: #SystemProgressMorph ifPresent: [:spm | spm uniqueInstance bars do: [ :e | e close ]] ! ! !JobTest methodsFor: 'tests' stamp: 'CamilloBruni 8/30/2012 17:44'! testChildJob | wasRun | wasRun := false. [ :job | [ :job2 | self assert: job children size = 1. self assert: job children first = job2. wasRun := true ] asJob run. self assert: job children isEmpty ] asJob run. self assert: wasRun.! ! !JobTest methodsFor: 'tests' stamp: 'CamilloBruni 9/1/2012 12:56'! testSingleJob | wasRun | wasRun := false. [ :job | self assert: job children isEmpty. wasRun := true ] asJob run. self assert: wasRun.! ! !JobTest methodsFor: 'tests' stamp: 'MarcusDenker 12/20/2013 11:28'! testCurrent self assert: Job current isNil. [ :aJob | self assert: Job current equals: aJob. [ :anotherJob | self assert: Job current equals: anotherJob. ] asJob run. self assert: Job current equals: aJob. ] asJob run. self assert: Job current isNil. ! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! dst: anObject "Set the value of dst" dst := anObject! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 11/25/2012 04:07'! newHighlight "Anwser a new highlight." ^TextHighlightByBounds new borderWidth: 1; borderColor: self borderColor; fillWidth: true! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! dstOffset: aPoint "Set the dst offset." self dst offset: aPoint. self updateShape! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! src "Answer the value of src" ^ src! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:22'! borderColorToUse "Answer the border color to use." ^self borderColor! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:19'! wantsClick "Don't if we are transparent for now." ^(self src color isTransparent and: [self dst color isTransparent]) not! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! srcOffset: aPoint "Set the src offset" self src offset: aPoint. self updateShape! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:17'! clicked "The receiver or a highlight was clicked." self wantsClick ifFalse: [^false]. ^true! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! dstRange: anInterval "Set the dst range." self dst range: anInterval. self updateShape! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! src: anObject "Set the value of src" src := anObject! ! !JoinSection methodsFor: 'initialization' stamp: 'gvc 11/1/2006 14:20'! initialize "Initialize the receiver." super initialize. self src: JoinSide new; dst: JoinSide new; shape: Polygon new; width: 0; borderWidth: 0; borderColor: Color transparent; type: #modification! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! dstLineRange: anInterval "Set the dst lineRange." self dst lineRange: anInterval! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:16'! borderWidth: anInteger "Set the value of borderWidth" borderWidth := anInteger. self src highlight notNil ifTrue: [ self src highlight borderWidth: anInteger]. self dst highlight notNil ifTrue: [ self dst highlight borderWidth: anInteger]! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:16'! borderColor "Answer the value of borderColor" ^ borderColor! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 11/25/2012 04:08'! addHighlightsFrom: srcBlock to: dstBlock to: aCollection color: aColor "Add the highlights required for the given character blocks of a paragraph. May be up to three highlights depending on the line spans." srcBlock textLine = dstBlock textLine ifTrue: [aCollection add: (TextHighlightByBounds new color: aColor; bounds: (srcBlock topLeft corner: dstBlock bottomRight))] ifFalse: [aCollection add: (TextHighlightByBounds new color: aColor; bounds: (srcBlock topLeft corner: srcBlock textLine bottomRight)); add: (TextHighlightByBounds new fillWidth: true; color: aColor; bounds: (srcBlock bottomLeft corner: dstBlock topRight)); add: (TextHighlightByBounds new color: aColor; bounds: (dstBlock textLine topLeft corner: dstBlock bottomRight))]! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:16'! borderWidth "Answer the value of borderWidth" ^ borderWidth! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! type "Answer the value of type" ^ type! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! type: anObject "Set the value of type" type := anObject! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:18'! containsPoint: aPoint "Answer whether the receiver contains the given point." ^self shape containsPoint: aPoint! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:21'! width: anObject "Set the value of width" width := anObject. self updateShape! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:23'! drawOn: aCanvas "Draw the join on the given canvas." |v bc| (self src color isTransparent and: [self dst color isTransparent]) ifTrue: [^self]. v := self shape vertices. aCanvas drawPolygon: v fillStyle: (self fillStyleFor: self shape bounds). (self borderWidth > 0 and: [self borderColor isTransparent not]) ifTrue: [ bc := self borderColorToUse. aCanvas line: v first + (0@self borderWidth // 2) to: v second + (-1@self borderWidth // 2) width: self borderWidth color: bc; line: v third - (1@(self borderWidth // 2)) to: v fourth - (0@(self borderWidth // 2)) width: self borderWidth color: bc]! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! dstColor: aColor "Set the dst color" self dst color: aColor! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:21'! width "Answer the value of width" ^ width! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:18'! createHighlightsFrom: srcPara to: dstPara "Create and store the src and dst highlights. Use the given paragraphs to determine inline diffs." |s d si di srcText dstText diffs i sb eb line| self createHighlights. self src lineRange notEmpty ifTrue: [ line := srcPara lines at: self src lineRange first. si := line first. line := srcPara lines at: self src lineRange last. srcText := srcPara string copyFrom: si to: line last] ifFalse: [srcText := '']. self dst lineRange notEmpty ifTrue: [line := dstPara lines at: self dst lineRange first. di := line first. line := dstPara lines at: self dst lineRange last. dstText := dstPara string copyFrom: di to: line last] ifFalse: [dstText := '']. self src text: srcText. self dst text: dstText. self type = #modification ifFalse: [^self]. s := self src highlights. d := self dst highlights. diffs := (InlineTextDiffBuilder from: srcText to: dstText) buildPatchSequence aggregateRuns: [:e | e key]. diffs do: [:c | c first key = #match ifTrue: [c do: [:a | si := si + a value size. di := di + a value size]]. c first key = #insert ifTrue: [i := di. c do: [:a | di := di + a value size]. sb := dstPara characterBlockForIndex: i. eb := dstPara characterBlockForIndex: di - 1. self addHighlightsFrom: sb to: eb to: d color: (Color green alpha: 0.3)]. c first key = #remove ifTrue: [i := si. c do: [:a | si := si + a value size]. sb := srcPara characterBlockForIndex: i. eb := srcPara characterBlockForIndex: si - 1. self addHighlightsFrom: sb to: eb to: s color: (Color red alpha: 0.3)]]! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! srcLineRange: anInterval "Set the src lneRange." self src lineRange: anInterval! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:24'! drawMapOn: aCanvas in: rect scale: scale "Draw the join on the given canvas scaled into the given rectangle." self type = #match ifTrue: [^self]. aCanvas frameAndFillRectangle: (rect left @ (((self dst range first max: 0) * scale) truncated + rect top) corner: (rect right @ ((self dst range last * scale) truncated + rect top))) fillColor: (self fillStyleFor: rect) borderWidth: 1 borderColor: self borderColorToUse! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! srcRange: anInterval "Set the src range" self src range: anInterval. self updateShape! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:19'! fillStyleFor: rect "Answer the fillStyle to use for the given rectangle." ^self src color = self dst color ifTrue: [self src color] ifFalse: [(GradientFillStyle ramp: {0.0 -> self src color. 1.0 -> self dst color}) direction: rect width@0; origin: rect topLeft]! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:28'! updateHighlights "Update the highlight border colors." |bc| (self src isNil or: [self dst isNil]) ifTrue: [^self]. bc := self borderColorToUse. self src highlight notNil ifTrue: [ self src highlight borderColor: bc]. self dst highlight notNil ifTrue: [ self dst highlight borderColor: bc]! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! shape "Answer the value of shape" ^ shape! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! shape: anObject "Set the value of shape" shape := anObject! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! dst "Answer the value of dst" ^ dst! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:16'! borderColor: aColor "Set the value of borderColor" borderColor := aColor. self updateHighlights! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:18'! createHighlights "Create and store the src and dst highlights." |s d| s := OrderedCollection new. d := OrderedCollection new. s add: (self newHighlight color: self src color; borderWidth: self borderWidth; bounds: (0@self src range first corner: 0@(self src range last + 1)); borderSides: #(top left bottom)). d add: (self newHighlight color: self dst color; borderWidth: self borderWidth; bounds: (0@self dst range first corner: 0@(self dst range last + 1)); borderSides: #(top right bottom)). self src highlights: s. self dst highlights: d! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! srcColor: aColor "Set the src color." self src color: aColor! ! !JoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:19'! updateShape "Update the receiver's shape." (self src range isNil or: [self dst range isNil]) ifTrue: [^self]. self shape: (Polygon vertices: {(0@ self src range first) + self src offset. (self width @ self dst range first) + self dst offset. (self width @ self dst range last) + self dst offset. (0@self src range last) + self src offset})! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! lineRange "Answer the value of lineRange" ^ lineRange! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! offset "Answer the value of offset" ^ offset! ! !JoinSide methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 10:58'! highlight "Answer the primary highlight." ^(self highlights ifEmpty: [^nil]) first! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 11:09'! text: anObject "Set the value of text" text := anObject! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! color: anObject "Set the value of color" color := anObject! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! lineRange: anObject "Set the value of lineRange" lineRange := anObject! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! highlights "Answer the value of highlights" ^ highlights! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 11:09'! text "Answer the value of text" ^ text! ! !JoinSide methodsFor: 'initialization' stamp: 'gvc 11/1/2006 11:09'! initialize "Initialize the receiver." super initialize. self highlights: #(); offset: 0@0; range: (1 to: 1); lineRange: (1 to: 0); color: Color yellow; text: ''! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! range "Answer the value of range" ^ range! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! range: anObject "Set the value of range" range := anObject! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! color "Answer the value of color" ^ color! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! offset: anObject "Set the value of offset" offset := anObject! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! highlights: anObject "Set the value of highlights" highlights := anObject! ! !KMAltModifier commentStamp: ''! I represent the Alt key modifier. Look at my superclass for a more detailed explanaition.! !KMAltModifier methodsFor: 'printing' stamp: 'CamilloBruni 9/15/2013 20:32'! symbol ^ '⌥'! ! !KMAltModifier methodsFor: 'matching' stamp: 'CamilloBruni 3/19/2011 20:50'! matchesEvent: aKeyboardEvent ^ aKeyboardEvent altKeyPressed! ! !KMAltModifier methodsFor: 'initialization' stamp: 'CamilloBruni 3/20/2011 23:54'! initialize super initialize. identifier := #a. name := 'Alt'.! ! !KMAltModifier methodsFor: 'accessing' stamp: 'BenComan 2/23/2014 01:40'! eventCode ^64 ! ! !KMBuffer commentStamp: ''! I am a buffer of keyboard events. I am checked against key combinations to see if there is a match. I am cleared when the current morph loses focus or when a full match announcement is given.! !KMBuffer methodsFor: 'adding' stamp: 'BenjaminVanRyseghem 7/3/2012 15:43'! addEvent: anEvent buffer add: anEvent. currentEvent := anEvent.! ! !KMBuffer methodsFor: 'clearing' stamp: 'BenjaminVanRyseghem 7/3/2012 15:38'! clearBuffer currentEvent := nil. buffer removeAll.! ! !KMBuffer methodsFor: 'initialization' stamp: 'GuillermoPolito 6/24/2012 12:03'! initialize buffer := OrderedCollection new.! ! !KMBuffer methodsFor: 'accessing' stamp: 'GuillermoPolito 6/24/2012 12:08'! buffer ^buffer! ! !KMBuffer methodsFor: 'matching' stamp: 'BenjaminVanRyseghem 7/3/2012 14:55'! completeMatch currentEvent ifNotNil:[ currentEvent wasHandled: true ]. self clearBuffer.! ! !KMBuffer methodsFor: 'matching' stamp: 'BenjaminVanRyseghem 7/3/2012 15:45'! partialMatch KMLog log: 'Partial match: ', currentEvent printString. currentEvent ifNotNil:[ currentEvent wasHandled: true ].! ! !KMBuffer class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 6/24/2012 12:31'! uniqueInstance: aBuffer uniqueInstance := aBuffer.! ! !KMBuffer class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 6/24/2012 12:02'! uniqueInstance ^uniqueInstance ifNil: [ uniqueInstance := self new ].! ! !KMBuffer class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 6/24/2012 12:02'! resetUniqueInstance uniqueInstance := nil! ! !KMBuilder commentStamp: ''! I am a keymap builder that is used when configuring keymappings by pragmas. Send me the #shortcut: message with a keymap name, so I give you a specific builder to build a keymap. You can also tell me to install a category as global.! !KMBuilder methodsFor: 'keymap-building' stamp: 'GuillermoPolito 10/21/2011 01:26'! shortcut: aKeymapName ^KMKeymapBuilder for: aKeymapName platform: platform! ! !KMBuilder methodsFor: '*Deprecated30' stamp: 'GuillermoPolito 5/4/2013 16:29'! attachShortcutCategory: aByteSymbol to: aClass self deprecated: 'Static shortcuts should not be used. Configure them locally in your morph, or use #setAsGlobalCategory: to configure a globally system category'. KMRepository default attachCategoryName: aByteSymbol to: aClass.! ! !KMBuilder methodsFor: 'accessing' stamp: 'GuillermoPolito 10/21/2011 00:12'! platform: aPlatform platform := aPlatform! ! !KMBuilder methodsFor: 'keymap-building' stamp: 'GuillermoPolito 5/3/2013 15:49'! setAsGlobalCategory: aGlobalCategory KMRepository default setAsGlobalCategory: aGlobalCategory! ! !KMBuilder class methodsFor: 'instance creation' stamp: 'GuillermoPolito 10/21/2011 00:08'! keymap ^self keymap: #all! ! !KMBuilder class methodsFor: 'instance creation' stamp: 'GuillermoPolito 10/21/2011 01:15'! keymap: aPlatform (#( all Unix MacOSX Windows ) includes: aPlatform) ifFalse: [ self error: aPlatform, ' is not a valid platform' ]. ^self new platform: aPlatform; yourself! ! !KMCatcherMorph commentStamp: ''! I am a morph that captures keymappings, so they can be used for configuration/customization, or debugging.! !KMCatcherMorph methodsFor: 'event handling' stamp: 'LaurentLaffont 3/20/2014 22:27'! showContextMenu | menu | menu := MenuMorph new defaultTarget: self. edited ifTrue: [ menu add: 'accept' translated action: #accept. menu add: 'clear' translated action: #clear. menu add: 'cancel' translated action: #cancel. ]. menu popUpInWorld! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 1/20/2011 00:50'! clear self keystrokes removeAll. self showKeystrokes.! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'CamilloBruni 3/19/2011 00:09'! handlesKeyboard: event ^ focused! ! !KMCatcherMorph methodsFor: 'drawing' stamp: 'EstebanLorenzano 5/14/2013 09:43'! drawOn: aCanvas "Indicate unaccepted edits, conflicts etc." super drawOn: aCanvas. focused ifTrue: [ Smalltalk ui theme drawTextAdornmentFor: self color: Color orange on: aCanvas]! ! !KMCatcherMorph methodsFor: 'api' stamp: 'CamilloBruni 3/18/2011 23:11'! cancel edited ifFalse: [ ^ self ]. self keystrokes: OrderedCollection new. self showInitialShortcut. self initializeKeystrokes! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 1/24/2011 00:53'! keyStroke: aKeyStroke edited := true. self keystrokes add: aKeyStroke. self showKeystrokes.! ! !KMCatcherMorph methodsFor: 'accessing' stamp: 'GuillermoPolito 1/20/2011 00:02'! setMessage: aMessage labelMorph contents: aMessage! ! !KMCatcherMorph methodsFor: 'initialization' stamp: 'CamilloBruni 3/20/2011 23:49'! showInitialShortcut self setMessage: initialShortcut asString.! ! !KMCatcherMorph methodsFor: 'halos and balloon help' stamp: 'CamilloBruni 3/18/2011 23:11'! wantsBalloon ^ true! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'CamilloBruni 3/18/2011 23:11'! allowsKeymapping ^ false! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'CamilloBruni 3/19/2011 00:09'! handlesMouseDown: event ^ true! ! !KMCatcherMorph methodsFor: 'api' stamp: 'GuillermoPolito 3/19/2013 19:12'! shortcut | theKeystrokes | theKeystrokes := self keystrokes. theKeystrokes ifEmpty: [ ^ KMNoShortcut new ]. ^ theKeystrokes allButFirst inject: theKeystrokes first asKeyCombination into: [ :acum :each | acum , each asKeyCombination ]! ! !KMCatcherMorph methodsFor: 'api' stamp: 'GuillermoPolito 1/20/2011 01:28'! keystrokes: someKeystrokes keystrokes := someKeystrokes. self showKeystrokes.! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/31/2011 12:42'! keymapSetting: aSetting keymapSetting := aSetting. self initialShortcut: keymapSetting shortcut.! ! !KMCatcherMorph methodsFor: 'api' stamp: 'GuillermoPolito 1/24/2011 01:31'! accept | shortcut | shortcut := self shortcut. keymapSetting accept: shortcut. self initialShortcut: shortcut. edited := false.! ! !KMCatcherMorph methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! balloonText ^ 'Click to edit shortcut. Right click to open context menu.'! ! !KMCatcherMorph methodsFor: 'initialization' stamp: 'EstebanLorenzano 5/14/2013 09:43'! initialize super initialize. self layoutPolicy: TableLayout new. self listCentering: #center. self width: 300. self height: 25. self color: (Smalltalk ui theme textEditorDisabledFillStyleFor: self). self borderStyle: (Smalltalk ui theme textEditorDisabledBorderStyleFor: self). labelMorph := StringMorph contents: ''. self addMorph: (labelMorph). edited := false. focused := false. self initializeKeystrokes. ! ! !KMCatcherMorph methodsFor: 'api' stamp: 'CamilloBruni 3/20/2011 23:41'! shortcutString | shortcut | self keystrokes ifEmpty: [ ^ '' ]. shortcut := self shortcut. ^ shortcut asString! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'EstebanLorenzano 5/14/2013 09:43'! keyboardFocusChange: aBoolean super keyboardFocusChange: aBoolean. focused := aBoolean. focused ifTrue: [ self color: (Smalltalk ui theme textEditorNormalFillStyleFor: self) ] ifFalse: [ self color: (Smalltalk ui theme textEditorDisabledFillStyleFor: self) ]. ^ true! ! !KMCatcherMorph methodsFor: 'private' stamp: 'GuillermoPolito 1/24/2011 00:57'! showKeystrokes self setMessage: self shortcutString.! ! !KMCatcherMorph methodsFor: 'api' stamp: 'CamilloBruni 3/18/2011 23:11'! keystrokes ^ keystrokes! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'CamilloBruni 3/19/2011 00:07'! mouseDown: event super mouseDown: event. event yellowButtonPressed ifTrue: [ self showContextMenu ] ifFalse: [ World activeHand newKeyboardFocus: self ]! ! !KMCatcherMorph methodsFor: 'initialization' stamp: 'GuillermoPolito 1/24/2011 01:26'! initializeKeystrokes keystrokes := OrderedCollection new.! ! !KMCatcherMorph methodsFor: 'initialization' stamp: 'GuillermoPolito 1/24/2011 01:26'! initialShortcut: aShortcut initialShortcut := aShortcut. self showInitialShortcut. self initializeKeystrokes.! ! !KMCatcherMorph class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! for: aModel ^ (self new) keymapSetting: aModel; yourself! ! !KMCategory commentStamp: 'GuillermoPolito 12/14/2010 21:32'! I am a keymap category. I represent a set of keymaps that can be attached to a morph, so morphs can share my keymaps.! !KMCategory methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 20:50'! entriesAt: aPlatform platforms ifNil: [ platforms := Dictionary new ]. ^platforms at: aPlatform ifAbsentPut: [ KMStorage new ].! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:56'! hasKeymapNamed: aKeymapEntryName ^self allEntries hasKeymapNamed: aKeymapEntryName! ! !KMCategory methodsFor: 'associating' stamp: 'cami 7/22/2013 18:33'! platformEntries ^self entriesAt: Smalltalk os platformFamily! ! !KMCategory methodsFor: 'initialize-release' stamp: 'MarcusDenker 9/11/2013 13:29'! buildKeymapOnMethod: method self addKeymapEntry: (self perform: method selector)! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 10/21/2011 00:23'! commonEntries ^self entriesAt: #all! ! !KMCategory methodsFor: 'testing' stamp: 'GuillermoPolito 10/21/2011 00:37'! matchesCompletely: aString ^ self keymaps anySatisfy: [ :entry | entry matchesCompletely: aString ]! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:55'! addKeymapEntry: aKeymapEntry self commonEntries add: aKeymapEntry.! ! !KMCategory methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 21:02'! keymaps ^self allEntries keymaps! ! !KMCategory methodsFor: 'binding' stamp: 'BenjaminVanRyseghem 1/12/2014 22:38'! keymapForShortcut: aShortcut ^ self allEntries keymapForShortcut: aShortcut! ! !KMCategory methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! categoryName ^ name! ! !KMCategory methodsFor: 'associating' stamp: 'BenjaminVanRyseghem 1/12/2014 22:50'! removeKeymapEntry: aKeymapEntry [ self commonEntries remove: aKeymapEntry ] on: Error do: [ self platformEntries remove: aKeymapEntry ]! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:57'! keymapNamed: aKeymapEntryName ^self allEntries keymapNamed: aKeymapEntryName! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 10/21/2011 00:40'! allEntries ^self commonEntries, self platformEntries! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:57'! hasKeymapNamed: aKeymapEntryName at: aPlatform ^ (self entriesAt: aPlatform) hasKeymapNamed: aKeymapEntryName! ! !KMCategory methodsFor: 'accessing' stamp: 'GuillermoPolito 12/14/2010 00:58'! name: aCategorySymbol name := aCategorySymbol ! ! !KMCategory methodsFor: 'binding' stamp: 'MarcusDenker 9/11/2013 13:07'! bindToObject: anObject andMorph: aMorph ^ KMCategoryBinding target: anObject morph: aMorph category: self.! ! !KMCategory methodsFor: 'initialize-release' stamp: 'MarcusDenker 9/11/2013 13:21'! initialize super initialize. self class methods select: [ :m | m isShortcutDeclaration ] thenDo: [ :m | self buildKeymapOnMethod: m ]! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:58'! keymapNamed: aKeymapEntryName at: aPlatform ^(self entriesAt: aPlatform) keymapNamed: aKeymapEntryName! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:55'! addKeymapEntry: aKeymapEntry at: aPlatform (self entriesAt: aPlatform) add: aKeymapEntry! ! !KMCategory methodsFor: 'testing' stamp: 'GuillermoPolito 10/21/2011 00:37'! matches: aString ^ self keymaps anySatisfy: [ :entry | entry matches: aString ]! ! !KMCategory methodsFor: 'binding' stamp: 'MarcusDenker 9/11/2013 13:26'! installAsGlobalCategory KMRepository default setAsGlobalCategory: self! ! !KMCategory methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! name ^ name! ! !KMCategory methodsFor: 'matching' stamp: 'GuillermoPolito 10/20/2011 15:55'! onMatchWith: anEventBuffer notify: aMatchListener andDo: aBlock self keymaps do: [ :entry | entry onMatchWith: anEventBuffer notify: aMatchListener andDo: aBlock ].! ! !KMCategory methodsFor: 'binding' stamp: 'MarcusDenker 9/11/2013 13:10'! asKmCategoryIn: aKmRepository "Maybe we should validate we exist in the repository?" ^ self! ! !KMCategory class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! named: aCategorySymbol ^ (self new) name: aCategorySymbol; yourself! ! !KMCategoryBinding commentStamp: ''! I am the reification of the relation morph<->category, created when a morph gets attached a category of shortcuts.! !KMCategoryBinding methodsFor: 'accessing' stamp: 'GuillermoPolito 10/20/2011 18:37'! target: aTarget target := aTarget! ! !KMCategoryBinding methodsFor: 'accessing' stamp: 'GuillermoPolito 10/20/2011 19:05'! morph: aMorph morph := aMorph! ! !KMCategoryBinding methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/20/2012 19:19'! category ^ category! ! !KMCategoryBinding methodsFor: 'iterating' stamp: 'GuillermoPolito 5/3/2013 17:49'! nextForKmChain: aKMDispatchChain ^self target! ! !KMCategoryBinding methodsFor: 'binding' stamp: 'BenjaminVanRyseghem 1/12/2014 22:36'! keymapForShortcut: aKey ^ category keymapForShortcut: aKey! ! !KMCategoryBinding methodsFor: 'matching' stamp: 'GuillermoPolito 10/20/2011 18:53'! noMatch "do nothing" ! ! !KMCategoryBinding methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/20/2012 19:19'! morph ^ morph! ! !KMCategoryBinding methodsFor: 'printing' stamp: 'SeanDeNigris 7/17/2012 09:04'! printOn: aStream aStream nextPutAll: 'aKMCategoryTarget('; nextPutAll: (category name ifNil: 'nil' ifNotNil: [ :n | n printString ]); nextPutAll: ')'.! ! !KMCategoryBinding methodsFor: 'matching' stamp: 'BenjaminVanRyseghem 7/3/2012 14:47'! verifyMatchWith: anEventBuffer notifying: aListener thenDoing: anAction self flag: #fixme. "ugly hack with array of listeners" category onMatchWith: anEventBuffer notify: { self . aListener } " first we have to tell the dispatcher " andDo: anAction! ! !KMCategoryBinding methodsFor: 'matching' stamp: 'GuillermoPolito 10/20/2011 18:53'! partialMatch "do nothing" ! ! !KMCategoryBinding methodsFor: 'matching' stamp: 'GuillermoPolito 5/4/2013 15:40'! completeMatch: aKeymap buffer: aBuffer KMLog log: 'Complete match: ', aKeymap printString. KMBuffer uniqueInstance completeMatch. aKeymap action cull: target value cull: morph cull: aBuffer first. ! ! !KMCategoryBinding methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/20/2012 19:19'! target ^ target! ! !KMCategoryBinding methodsFor: 'accessing' stamp: 'GuillermoPolito 10/20/2011 18:37'! category: aCategory category := aCategory! ! !KMCategoryBinding class methodsFor: 'instance creation' stamp: 'GuillermoPolito 10/20/2011 19:05'! target: aTarget morph: aMorph category: aCategory ^self new target: aTarget; category: aCategory; morph: aMorph; yourself! ! !KMCategoryTarget commentStamp: ''! I am the reification of the relation morph<->category, created when a morph gets attached a category of shortcuts.! !KMCategoryTarget methodsFor: 'accessing' stamp: 'MarcusDenker 9/12/2013 09:53'! morph ^ morph! ! !KMCategoryTarget methodsFor: 'accessing' stamp: 'MarcusDenker 9/12/2013 09:53'! morph: aMorph morph := aMorph! ! !KMCategoryTarget methodsFor: 'accessing' stamp: 'MarcusDenker 9/12/2013 09:53'! target: aTarget target := aTarget! ! !KMCategoryTarget methodsFor: 'accessing' stamp: 'MarcusDenker 9/12/2013 09:53'! category ^ category! ! !KMCategoryTarget methodsFor: 'matching' stamp: 'MarcusDenker 9/12/2013 09:53'! verifyMatchWith: anEventBuffer notifying: aListener thenDoing: anAction self flag: #fixme. "ugly hack with array of listeners" category onMatchWith: anEventBuffer notify: { self . aListener } " first we have to tell the dispatcher " andDo: anAction! ! !KMCategoryTarget methodsFor: 'matching' stamp: 'MarcusDenker 9/12/2013 09:53'! partialMatch "do nothing" ! ! !KMCategoryTarget methodsFor: 'printing' stamp: 'MarcusDenker 9/12/2013 09:53'! printOn: aStream aStream nextPutAll: 'aKMCategoryTarget('; nextPutAll: (category name ifNil: 'nil' ifNotNil: [ :n | n printString ]); nextPutAll: ')'.! ! !KMCategoryTarget methodsFor: 'iterating' stamp: 'MarcusDenker 9/12/2013 09:53'! nextForKmChain: aKMDispatchChain ^self target! ! !KMCategoryTarget methodsFor: 'matching' stamp: 'MarcusDenker 9/12/2013 09:53'! completeMatch: aKeymap buffer: aBuffer KMLog log: 'Complete match: ', aKeymap printString. KMBuffer uniqueInstance completeMatch. aKeymap action cull: target value cull: morph cull: aBuffer first. ! ! !KMCategoryTarget methodsFor: 'accessing' stamp: 'MarcusDenker 9/12/2013 09:53'! target ^ target! ! !KMCategoryTarget methodsFor: 'matching' stamp: 'MarcusDenker 9/12/2013 09:53'! noMatch "do nothing" ! ! !KMCategoryTarget methodsFor: 'accessing' stamp: 'MarcusDenker 9/12/2013 09:53'! category: aCategory category := aCategory! ! !KMCategoryTarget class methodsFor: 'instance creation' stamp: 'MarcusDenker 9/12/2013 09:53'! target: aTarget morph: aMorph category: aCategory ^self new target: aTarget; category: aCategory; morph: aMorph; yourself! ! !KMCategoryTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/18/2011 23:11'! categoryContainer ^ KMFactory keymapContainer! ! !KMCategoryTest methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 9/12/2013 10:03'! testAddKeymapToCategory | categoryToAdd entry | categoryToAdd := KMCategory named: #TestCategory. entry := KMKeymap named: #Foo shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: [ "nothing" ]. self assert: (categoryToAdd allEntries) size = 0. categoryToAdd addKeymapEntry: entry. self assert: (categoryToAdd allEntries) size = 1.! ! !KMCategoryTest methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 9/12/2013 10:03'! testCreateUnexistentCategory | categoryToAdd | categoryToAdd := KMCategory named: #TestCategory. self assert: self categoryContainer categories size = 0. self categoryContainer addCategory: categoryToAdd. self assert: self categoryContainer categories size = 1. self assert: (self categoryContainer includesCategory: categoryToAdd).! ! !KMCategoryTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 3/13/2011 17:33'! testCreateExistentCategoryFails | categoryToAdd | categoryToAdd := #TestCategory. self assert: self categoryContainer categories size = 0. self categoryContainer addCategory: categoryToAdd. self assert: self categoryContainer categories size = 1. self should: [self categoryContainer addCategory: categoryToAdd] raise: Error.! ! !KMCombinationTests methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 9/24/2012 11:07'! testCombinationOfSimpleShortcuts | shortcut otherShortcut combination | shortcut := $a command. otherShortcut := $b ctrl. combination := shortcut | otherShortcut. self assert: (combination includes: shortcut). self assert: (combination includes: otherShortcut). self assert: ((combination collect: #platform) allSatisfy: [ :p | p = #all ]).! ! !KMCombinationTests methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 9/24/2012 11:16'! testWindowsDependentShortcut | shortcut | shortcut := $a ctrl win. self assert: (shortcut shortcut = $a ctrl). self assert: shortcut platform equals: #Windows.! ! !KMCombinationTests methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 9/24/2012 11:06'! testShortcutIsSimpleCombination | shortcut | shortcut := $a command. self assert: (shortcut includes: shortcut). self assert: shortcut shortcut equals: shortcut.! ! !KMCombinationTests methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 9/24/2012 11:17'! testUnixDependentShortcut | shortcut | shortcut := $a ctrl unix. self assert: (shortcut shortcut = $a ctrl). self assert: shortcut platform equals: #Unix.! ! !KMCombinationTests methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 9/24/2012 11:11'! testPlatformDependentShortcut | shortcut | shortcut := $a ctrl win. self assert: (shortcut shortcut = $a ctrl). self assert: shortcut platform equals: #Windows.! ! !KMCombinationTests methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 9/24/2012 11:22'! testMacDependentShortcut | shortcut | shortcut := $a ctrl mac. self assert: (shortcut shortcut = $a ctrl). self assert: shortcut platform equals: #MacOSX.! ! !KMCombinationTests methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 9/24/2012 11:34'! testCombinationSeveralShortcuts | shortcut platforms | platforms := Set new. shortcut := $a command mac | $a ctrl win | $a ctrl unix | $a alt. shortcut combinationsDo: [ :c | platforms add: c platform ]. self assert: (platforms includes: #MacOSX). self assert: (platforms includes: #Windows). self assert: (platforms includes: #Unix). self assert: (platforms includes: #all).! ! !KMCommandModifier commentStamp: ''! I represent the default modifier key for the current platform, late bound to Meta or Ctrl key modifier depending on the platform.! !KMCommandModifier methodsFor: 'printing' stamp: 'CamilloBruni 2/19/2014 14:11'! symbol ^ self delegatedModifier symbol! ! !KMCommandModifier methodsFor: 'initialization' stamp: 'NicolasPetton 2/13/2014 16:55'! initialize super initialize. identifier := #k. name := 'Cmd'! ! !KMCommandModifier methodsFor: 'matching' stamp: 'NicolasPetton 12/6/2013 15:54'! matchesEvent: aKeyboardEvent ^ self delegatedModifier matchesEvent: aKeyboardEvent ! ! !KMCommandModifier methodsFor: 'accessing' stamp: 'BenComan 2/22/2014 12:24'! eventCode ^ self delegatedModifier eventCode! ! !KMCommandModifier methodsFor: 'private' stamp: 'NicolasPetton 12/6/2013 15:52'! delegatedModifier ^ OSPlatform current defaultModifier ! ! !KMCompleteMatch commentStamp: ''! I am an announcement raised when there is a full match between the key buffer and a shortcut.! !KMCompleteMatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 12:55'! event ^ event! ! !KMCompleteMatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 12:55'! event: anObject event := anObject! ! !KMCompleteMatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 14:43'! source: anObject source := anObject! ! !KMCompleteMatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 14:43'! source ^ source! ! !KMCompleteMatch class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 7/3/2012 14:43'! event: event from: source ^ self new event: event; source: source; yourself! ! !KMComposedModifier commentStamp: ''! I represent a composed key modifier. I contain a collection of modifiers that should match with a keyboard event. Look at my superclass for a more detailed explanaition.! !KMComposedModifier methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 11/1/2013 17:09'! symbol ^ String streamContents: [ :stream | self modifiers do: [ :e | stream << e symbol ] ]! ! !KMComposedModifier methodsFor: 'combining' stamp: 'GuillermoPolito 5/31/2011 18:26'! command modifiers add: KMModifier command! ! !KMComposedModifier methodsFor: 'comparing' stamp: 'GuillermoPolito 5/1/2012 12:26'! hash ^ modifiers hash! ! !KMComposedModifier methodsFor: 'combining' stamp: 'GuillermoPolito 3/19/2013 20:16'! control modifiers add: KMModifier ctrl! ! !KMComposedModifier methodsFor: 'accessing' stamp: 'CamilloBruni 3/20/2011 23:59'! updateIdentifier identifier := String streamContents: [ :aStream| modifiers do: [ :modifier| aStream << modifier identifier]]. identifier := identifier asSymbol! ! !KMComposedModifier methodsFor: 'combining' stamp: 'CamilloBruni 3/19/2011 21:20'! alt modifiers add: KMModifier alt! ! !KMComposedModifier methodsFor: 'combining' stamp: 'CamilloBruni 3/20/2011 23:57'! modifiedBy: modifier modifiers add: modifier. self updateIdentifier.! ! !KMComposedModifier methodsFor: 'combining' stamp: 'CamilloBruni 3/19/2011 21:21'! shift modifiers add: KMModifier shift! ! !KMComposedModifier methodsFor: 'accessing' stamp: 'CamilloBruni 3/19/2011 21:23'! modifiers ^ modifiers! ! !KMComposedModifier methodsFor: 'combining' stamp: 'GuillermoPolito 3/19/2013 19:12'! + modified ^ modified asKeyCombination modifiedBy: self! ! !KMComposedModifier methodsFor: 'initialization' stamp: 'GuillermoPolito 2/14/2014 15:54'! initialize super initialize. modifiers := OrderedCollection new.! ! !KMComposedModifier methodsFor: 'matching' stamp: 'CamilloBruni 3/19/2011 21:18'! matchesEvent: aKeyboardEvent ^ modifiers allSatisfy: [:modifier| modifier matchesEvent: aKeyboardEvent]! ! !KMComposedModifier methodsFor: 'comparing' stamp: 'GuillermoPolito 2/14/2014 15:56'! = aShortcut (aShortcut isKindOf: self class) ifFalse: [^ false]. ^ (aShortcut modifiers includesAll: modifiers) and: [ modifiers includesAll: aShortcut modifiers ]! ! !KMComposedModifier methodsFor: 'printing' stamp: 'CamilloBruni 3/20/2011 23:47'! printOn: aStream modifiers do: [ :modifier| modifier printOn: aStream ] separatedBy: [ aStream << ' + ' ].! ! !KMComposedModifier methodsFor: 'combining' stamp: 'GuillermoPolito 3/19/2013 20:16'! ctrl self control! ! !KMCtrlModifier commentStamp: ''! I represent the Ctrl key modifier. Look at my superclass for a more detailed explanaition.! !KMCtrlModifier methodsFor: 'printing' stamp: 'CamilloBruni 9/15/2013 20:32'! symbol ^ '⌃'! ! !KMCtrlModifier methodsFor: 'matching' stamp: 'CamilloBruni 3/19/2011 20:50'! matchesEvent: aKeyboardEvent ^ aKeyboardEvent controlKeyPressed! ! !KMCtrlModifier methodsFor: 'initialization' stamp: 'GuillermoPolito 4/9/2011 23:52'! initialize super initialize. identifier := #c. name := 'Ctrl'.! ! !KMCtrlModifier methodsFor: 'accessing' stamp: 'BenComan 2/22/2014 12:24'! eventCode ^16! ! !KMDescription commentStamp: ''! A KMDescription is a window showing the description of shortcuts for a specified set of symbols reprensenting KMCategories! !KMDescription methodsFor: 'accessing' stamp: 'GuillermoPolito 5/1/2012 12:26'! categories ^ categories! ! !KMDescription methodsFor: 'accessing' stamp: 'NicolaiHess 12/11/2013 21:23'! shortcutList ^ shortcutList! ! !KMDescription methodsFor: 'initialization' stamp: 'NicolaiHess 12/11/2013 22:47'! updateShortcutList | cat items | cat := categories value at: self categoryList selectedIndex. items := (cat entriesAt: #all) keymaps collect: [ :e | collectingBlock value: e ]. shortcutList items: (items sorted: sortingBlock)! ! !KMDescription methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/6/2012 15:49'! initialExtent ^ (600@350)! ! !KMDescription methodsFor: 'initialization' stamp: 'NicolaiHess 12/11/2013 22:46'! initCategoryList: aCollection categoryList emptyList. aCollection do: [ :cat | categoryList addItemLabeled: cat name do: [ self updateShortcutList ] ]! ! !KMDescription methodsFor: 'initialization' stamp: 'NicolaiHess 12/11/2013 22:44'! initializeWidgets self instantiateModels: #( categoryList DropListModel shortcutList MultiColumnListModel okToolbar OkToolbar orderingList DropListModel ). orderingList addItemLabeled:'shortcut : description' do: [self collectShortcutDescription. self updateShortcutList]; addItemLabeled:'description : shortcut' do: [self collectDescriptionShortcut. self updateShortcutList]. shortcutList displayBlock: [ :e | e ]; allowToSelect: false. okToolbar okButton label: 'Close'; state: false! ! !KMDescription methodsFor: 'initialization' stamp: 'NicolaiHess 12/11/2013 22:45'! collectDescriptionShortcut collectingBlock := [ :e | {(e description asString) . ':' . (e shortcut asString)} ]! ! !KMDescription methodsFor: 'protocol' stamp: 'NicolaiHess 12/11/2013 22:40'! categories: aCollectionOfSymbols | cats | cats := aCollectionOfSymbols collect: [:e | KMRepository default categoryForName: e]. categories value: cats. self updateShortcutList! ! !KMDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 16:09'! okToolbar ^ okToolbar! ! !KMDescription methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize categories := nil asValueHolder. sortingBlock := [:a :b | a first < b first ]. super initialize. self collectShortcutDescription ! ! !KMDescription methodsFor: 'initialization' stamp: 'NicolaiHess 12/11/2013 22:41'! initializePresenter categories whenChangedDo: [:col | self initCategoryList:col ]. okToolbar okAction: [ self delete ].! ! !KMDescription methodsFor: 'accessing' stamp: 'NicolaiHess 12/11/2013 21:23'! categoryList ^ categoryList! ! !KMDescription methodsFor: 'initialization' stamp: 'NicolaiHess 12/11/2013 22:46'! collectShortcutDescription collectingBlock := [:e | {e shortcut asString. ':'. e description asString} ]! ! !KMDescription methodsFor: 'accessing' stamp: 'NicolaiHess 12/11/2013 21:23'! orderingList ^ orderingList! ! !KMDescription class methodsFor: 'specs' stamp: 'NicolaiHess 12/11/2013 21:22'! defaultSpec ^ SpecLayout composed newColumn: [:c | c newRow: [:r | r add: #categoryList; add: #orderingList ] height: 25; add: #shortcutList; add: #okToolbar height: 25 ]! ! !KMDescription class methodsFor: 'example' stamp: 'BenjaminVanRyseghem 4/6/2012 17:23'! example | d | d := KMDescription new. d categories: #(GlobalShortcuts MonticelloShortcuts TextEditor). d openWithSpec! ! !KMDescription class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 4/6/2012 15:46'! title ^ 'Shortcuts description'! ! !KMDispatchChain commentStamp: ''! I am an object that controls the dispatch order of keymaps given a hierarchy of morphs. ! !KMDispatchChain methodsFor: 'iterating' stamp: 'GuillermoPolito 5/3/2013 16:57'! target ^target! ! !KMDispatchChain methodsFor: 'dispatching' stamp: 'GuillermoPolito 5/4/2013 15:48'! dispatch: aKeyboardEvent self do: [ :targetToDispatch | targetToDispatch dispatch: KMBuffer uniqueInstance buffer copy. aKeyboardEvent wasHandled ifTrue: [ ^self ]. ]. "This should be a noMatch event" aKeyboardEvent wasHandled ifFalse: [ KMBuffer uniqueInstance clearBuffer ]! ! !KMDispatchChain methodsFor: 'initialize-release' stamp: 'GuillermoPolito 5/4/2013 16:13'! startOn: anInitialTarget initialTarget := anInitialTarget.! ! !KMDispatchChain methodsFor: 'iterating' stamp: 'GuillermoPolito 5/4/2013 16:12'! do: aBlock | currentTarget | currentTarget := initialTarget. [ currentTarget isNil ] whileFalse: [ aBlock value: currentTarget. currentTarget := currentTarget nextForKmChain: self. ]! ! !KMDispatchChain methodsFor: 'initialize-release' stamp: 'GuillermoPolito 5/3/2013 17:45'! dispatcher: aDispatcher dispatcher := aDispatcher. self target: dispatcher target.! ! !KMDispatchChain methodsFor: 'initialize-release' stamp: 'GuillermoPolito 5/3/2013 16:14'! target: aTarget target := aTarget! ! !KMDispatchChain class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/3/2013 17:52'! from: anInitialTarget andDispatcher: aDispatcher ^self new dispatcher: aDispatcher; startOn: anInitialTarget; yourself! ! !KMDispatchChainTest methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 9/11/2013 14:47'! testTargetDoesNotIterateTheNil | chain | chain := KMDispatchChain from: (KmGlobalDispatcher new) andDispatcher: (KMDispatcher new). chain do: [ :target | self assert: target notNil ].! ! !KMDispatchChainTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/3/2013 17:53'! testPassesOnTheTarget | chain dispatcher passed | dispatcher := KMDispatcher target: Morph new. passed := false. chain := KMDispatchChain from: (KmGlobalDispatcher new) andDispatcher: dispatcher. chain do: [ :t | t == dispatcher target ifTrue: [ passed := true ] ]. self assert: passed! ! !KMDispatchChainTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/3/2013 17:51'! testGlobalIsFirst | chain first | first := nil. chain := KMDispatchChain from: (KmGlobalDispatcher new) andDispatcher: (KMDispatcher new). chain do: [ :target | first ifNil: [ first := target ] ]. self assert: first isGlobalDispatcher.! ! !KMDispatcher commentStamp: 'GuillermoPolito 12/24/2010 19:00'! I'm an object that saves a buffer of keyevents for the morph I'm attached. I am the one that dispatches the single and multiple shortcuts. If the morph has a keymap that matches the keyboard event, I tell the keymap event to execute with the morph I'm attached.! !KMDispatcher methodsFor: 'building' stamp: 'GuillermoPolito 5/4/2013 16:00'! attachCategory: aCategory self attachCategory: aCategory targetting: morph! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'BenjaminVanRyseghem 7/3/2012 14:47'! dispatch: anEventBuffer | association match | self keymapObservers do: [ :aTarget | "nice hack to stop in the first listener" aTarget verifyMatchWith: anEventBuffer notifying: self thenDoing: [ ^self ] ]. self noMatch! ! !KMDispatcher methodsFor: 'building' stamp: 'BenjaminVanRyseghem 1/12/2014 22:40'! removeKeyCombination: aShortcut | keymap removalTarget | removalTarget := self directKeymaps. keymap := self keymapForShortcut: aShortcut. keymap ifNil: [ self targets do: [ :e | (e keymapForShortcut: aShortcut) ifNotNil: [ :s | removalTarget := e category. keymap := s ] ] ]. keymap ifNil: [ ^ self ]. removalTarget removeKeymapEntry: keymap! ! !KMDispatcher methodsFor: 'building' stamp: 'BenjaminVanRyseghem 11/12/2013 16:09'! keymapForShortcut: aShortcut ^ self directKeymaps keymapForShortcut: aShortcut! ! !KMDispatcher methodsFor: 'match' stamp: 'GuillermoPolito 6/24/2012 12:12'! noMatch! ! !KMDispatcher methodsFor: 'building' stamp: 'MarcusDenker 9/11/2013 13:07'! attachCategory: aCategoryName onProperty: aProperty self targets add: (KMCategoryBinding target: [ morph perform: aProperty ] morph: morph category: (KMRepository default categoryForName: aCategoryName) )! ! !KMDispatcher methodsFor: 'building' stamp: 'BenjaminVanRyseghem 2/20/2012 22:41'! detachKeymapCategory: aCategoryName self detachKeymapCategory: aCategoryName targetting: morph! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'MarcusDenker 9/11/2013 13:07'! perInstanceTarget ^KMCategoryBinding target: morph morph: morph category: self directKeymaps.! ! !KMDispatcher methodsFor: 'initialize' stamp: 'ThierryGoubier 9/14/2012 15:24'! resetTargets targets := nil! ! !KMDispatcher methodsFor: 'building' stamp: 'GabrielOmarCotelli 12/3/2013 17:23'! detachKeymapCategory: aCategoryName targetting: anObject self targets detect: [ :tgt | tgt target = anObject and: [ tgt category name = aCategoryName ] ] ifFound: [ :categoryTarget | self targets remove: categoryTarget ] ifNone: [ self error: 'Category ' , aCategoryName , ' is not attached to ' , morph asString ]! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'GuillermoPolito 10/20/2011 18:20'! targets ^targets ifNil: [ targets := Set new ]! ! !KMDispatcher methodsFor: 'match' stamp: 'ThierryGoubier 9/13/2012 22:08'! completeMatch: aKeymapEntry buffer: aBuffer KMLog log: morph printString, ' Complete match: ', aKeymapEntry printString. KMBuffer uniqueInstance completeMatch. self announcer announce: (KMCompleteMatch event: currentEvent from: self).! ! !KMDispatcher methodsFor: 'building' stamp: 'GuillermoPolito 8/5/2013 10:21'! bindKeyCombination: aShortcut toAction: anAction self directKeymaps addKeymapEntry: (KMKeymap shortcut: aShortcut action: anAction)! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'MarcusDenker 9/12/2013 10:03'! directKeymaps ^directKeymaps ifNil: [ directKeymaps := KMCategory new ]! ! !KMDispatcher methodsFor: 'testing' stamp: 'EstebanLorenzano 2/19/2013 14:42'! includesKeymapCategory: aCategoryName ^self includesKeymapCategory: aCategoryName targetting: morph! ! !KMDispatcher methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 14:55'! target: aTarget target := aTarget. morph := target morph. "self announcer weak on: MorphLostFocus send: #clearBuffer to: KMBuffer uniqueInstance."! ! !KMDispatcher methodsFor: 'testing' stamp: 'EstebanLorenzano 2/19/2013 14:41'! includesKeymapCategory: aCategoryName targetting: anObject ^self targets anySatisfy: [ :tgt | tgt target = anObject and: [ tgt category name = aCategoryName ] ] ! ! !KMDispatcher methodsFor: 'match' stamp: 'BenjaminVanRyseghem 7/3/2012 12:50'! announcer ^ self target announcer! ! !KMDispatcher methodsFor: 'match' stamp: 'GuillermoPolito 6/24/2012 12:19'! buffer ^ KMBuffer uniqueInstance buffer! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'GuillermoPolito 5/4/2013 15:40'! dispatchKeystroke: aKeyEvent | chain | KMLog log: aKeyEvent printString, String cr. KMBuffer uniqueInstance addEvent: aKeyEvent. chain := KMDispatchChain from: (KmGlobalDispatcher new dispatcher: self; yourself) andDispatcher: self. chain dispatch: aKeyEvent.! ! !KMDispatcher methodsFor: 'building' stamp: 'BenjaminVanRyseghem 2/20/2012 19:36'! detachAllKeymapCategories self targets removeAll! ! !KMDispatcher methodsFor: 'initialize' stamp: 'ThierryGoubier 9/14/2012 15:35'! reset self resetTargets. self resetPerInstanceTarget! ! !KMDispatcher methodsFor: '*Deprecated30' stamp: 'GuillermoPolito 8/5/2013 10:21'! on: aShortcut do: anAction Transcript show: 'You have an on:do: instead of a onKey: do: in ',thisContext sender method printString; cr. self deprecated: 'Use onKey: do: instead' on: '4 August 2013' in: 'Pharo30'. ^ self bindKeyCombination: aShortcut toAction: anAction! ! !KMDispatcher methodsFor: 'initialize' stamp: 'ThierryGoubier 9/14/2012 15:35'! resetPerInstanceTarget directKeymaps := nil! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'GuillermoPolito 5/3/2013 17:20'! dispatch: anEventBuffer inCategories: categories (self keymapObserversForCategories: categories) do: [ :aTarget | "nice hack to stop in the first listener" aTarget verifyMatchWith: anEventBuffer notifying: self thenDoing: [ ^self ] ]. self noMatch! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'MarcusDenker 9/11/2013 13:07'! keymapObserversForCategories: categories ^categories collect: [ :cat | KMCategoryBinding target: target realTarget morph: target morph category: cat ].! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'GuillermoPolito 5/4/2013 16:37'! keymapObservers | o | o := OrderedCollection with: self perInstanceTarget. o addAll: self targets. ^ o! ! !KMDispatcher methodsFor: 'building' stamp: 'MarcusDenker 9/11/2013 13:07'! attachCategory: aCategory targetting: anObject | category categoryTarget | category := aCategory asKmCategoryIn: KMRepository default. categoryTarget := category bindToObject: anObject andMorph: morph. self targets add: categoryTarget.! ! !KMDispatcher methodsFor: 'match' stamp: 'BenjaminVanRyseghem 7/3/2012 17:52'! partialMatch | event | KMBuffer uniqueInstance partialMatch. event := KMBuffer uniqueInstance currentEvent. event isKeyboard not ifTrue: [ event := nil ]. self announcer announce: (KMPartialMatch event: event from: self).! ! !KMDispatcher methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! target ^ target! ! !KMDispatcher class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/31/2011 11:02'! target: aTargetSelector morph: aMorph ^ (self new) target: (KMTarget for: aTargetSelector in: aMorph); yourself! ! !KMDispatcher class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/30/2011 01:26'! target: aTarget ^ self target: #yourself morph: aTarget! ! !KMDispatcherTestCase methodsFor: 'tests' stamp: 'MarcusDenker 9/12/2013 10:03'! testBuffering | morph flag category event1 event2 event3| category := KMCategory named: #TestBlah. KMRepository default addCategory: category. morph := BorderedMorph new. morph kmDispatcher reset. flag := false. category addKeymapEntry: (KMKeymap named: #Foo shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: [flag := true]). category addKeymapEntry: (KMKeymap named: #Bar shortcut: $p asKeyCombination, $p asKeyCombination action: []). morph attachKeymapCategory: #TestBlah. event1 := self eventKey: $a. morph kmDispatcher dispatchKeystroke: event1. self assert: morph kmDispatcher buffer size equals: 1. self assert: morph kmDispatcher buffer first equals: event1. event2 := self eventKey: $b. morph kmDispatcher dispatchKeystroke: event2. self assert: morph kmDispatcher buffer size = 2. self assert: morph kmDispatcher buffer first = event1. self assert: morph kmDispatcher buffer second = event2. event3 := self eventKey: $c. morph kmDispatcher dispatchKeystroke: event3. self assert: morph kmDispatcher buffer isEmpty. self assert: flag.! ! !KMDispatcherTestCase methodsFor: 'tests' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapContainer ^ KMRepository default! ! !KMDispatcherTestCase methodsFor: 'tests' stamp: 'MarcusDenker 9/12/2013 10:03'! testNoStaggeredTrigger "Once a key sequence is recognized by a keymapper, all other keymappers should clear their buffers" | bm1 bm2 flag1 flag2 category otherCategory bufferBefore | category := KMCategory named: #TestBlah. otherCategory := KMCategory named: #TestFoo. KMRepository default addCategory: category. KMRepository default addCategory: otherCategory. bm1 := BorderedMorph new. bm1 attachKeymapCategory: category. flag1 := false. category addKeymapEntry: ( KMKeymap named: #Foo shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: [flag1 := true]). bm2 := Morph new. bm2 attachKeymapCategory: otherCategory. flag2 := false. otherCategory addKeymapEntry: (KMKeymap named: #Bar shortcut: $a asKeyCombination, $b asKeyCombination action: [flag2 := true]). bm1 addMorphBack: bm2. bufferBefore := bm2 kmDispatcher buffer copy. {self eventKey: $a. self eventKey: $b. self eventKey: $c} do: [:e | bm2 dispatchKeystrokeForEvent: e]. flag1 ifTrue: [ bufferBefore inspect ]. self deny: flag1. self assert: flag2.! ! !KMDispatcherTestCase methodsFor: 'tests' stamp: 'MarcusDenker 9/12/2013 10:03'! testNoMultiTrigger | bm1 bm2 flag1 flag2 category otherCategory | category := KMCategory named: #TestBlah. otherCategory := KMCategory named: #TestFoo. KMRepository default addCategory: category. KMRepository default addCategory: otherCategory. bm1 := BorderedMorph new. bm1 attachKeymapCategory: #TestBlah. flag1 := false. category addKeymapEntry: (KMKeymap named: #Foo shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: [flag1 := true]). bm2 := KMMockMorph new. bm2 attachKeymapCategory: #TestFoo. flag2 := false. otherCategory addKeymapEntry: (KMKeymap named: #Bar shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: [flag2 := true]). bm1 addMorphBack: bm2. {self eventKey: $a. self eventKey: $b. self eventKey: $c} do: [:e | bm2 dispatchKeystrokeForEvent: e]. self deny: flag1. self assert: flag2.! ! !KMDispatcherTestCase methodsFor: 'tests' stamp: 'MarcusDenker 9/12/2013 10:03'! testDetach | category1 category2 morph attachedCategories | category1 := KMCategory named: #TestBlah. category2 := KMCategory named: #TestAnother. morph := BorderedMorph new. KMRepository default addCategory: category1. KMRepository default addCategory: category2. morph kmDispatcher reset. morph attachKeymapCategory: #TestBlah. morph attachKeymapCategory: #TestAnother. morph kmDispatcher targets size = 2 ifFalse: [ self error: 'should have one category attached' ]. morph detachKeymapCategory: #TestBlah. attachedCategories := morph kmDispatcher targets collect: [ :e | e category name ]. self assert: attachedCategories asArray equals: { #TestAnother }. self should: [ morph detachKeymapCategory: #NonExistent ] raise: Error.! ! !KMDispatcherTestCase class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapEventBuilderClass ^ KMFactory keymapEventBuilder! ! !KMFactory commentStamp: 'GuillermoPolito 2/24/2011 23:43'! I am a class used to access some of the main classes of Keymapping. See my class side to have an idea of what can I give you.! !KMFactory class methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapContainer ^ KMRepository default! ! !KMKeyCombination commentStamp: ''! I'm an abstract class representing a key combination. I'm can represent several cases of key presses: - simple key presses: pressing a single key, as a letter or number, or others like tab or space - modified key presses: a simple key + a modifier like shift or alt - option key presses: a list of key presses where only one of them should be valid - chained shortcuts: a sequence of shortcuts My more important protocols are: - matching: contains methods to control if a key combination is equals to other or matches a sequence of keyboard events - combining: defines simple ways to combine shorcut objects, like chaining them or modifying them For more information, look at my subclasses.! !KMKeyCombination methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/10/2014 20:32'! currentCharacter ^ ''! ! !KMKeyCombination methodsFor: 'combining' stamp: 'GuillermoPolito 3/15/2013 03:06'! | aShortcut ^KMKeyCombinationChoice withShortcuts: { self . aShortcut }! ! !KMKeyCombination methodsFor: 'comparing' stamp: 'CamilloBruni 3/18/2011 23:11'! hash ^ self species hash! ! !KMKeyCombination methodsFor: 'iterating' stamp: 'GuillermoPolito 9/24/2012 11:40'! combinationsDo: aBlock aBlock value: self! ! !KMKeyCombination methodsFor: 'keymap building' stamp: 'GuillermoPolito 4/6/2012 13:49'! named: keymapName do: anActionBlock withDescription: aDescription ^ KMKeymap named: keymapName shortcut: self action: anActionBlock description: aDescription! ! !KMKeyCombination methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 2/19/2014 11:45'! prettyPrintOn: aStream aStream << self shortcut modifier symbol. self shortcut character printOn: aStream! ! !KMKeyCombination methodsFor: 'matching' stamp: 'BenjaminVanRyseghem 11/1/2013 16:12'! matchesCompletely: aKeyboardEvent ^ self = aKeyboardEvent asKeyCombination! ! !KMKeyCombination methodsFor: 'combining' stamp: 'GuillermoPolito 3/15/2013 03:07'! mac ^KMPlatformSpecificKeyCombination with: self onPlatform: #MacOSX! ! !KMKeyCombination methodsFor: 'converting' stamp: 'GuillermoPolito 3/19/2013 19:12'! asKeyCombination ^self! ! !KMKeyCombination methodsFor: 'combining' stamp: 'GuillermoPolito 3/19/2013 19:12'! , aShortcut ^ KMKeyCombinationSequence first: self next: aShortcut asKeyCombination! ! !KMKeyCombination methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 10:59'! shortcut ^self! ! !KMKeyCombination methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 11:10'! platform ^#all! ! !KMKeyCombination methodsFor: 'matching' stamp: 'GuillermoPolito 9/24/2012 11:04'! includes: aShortcut ^self = aShortcut! ! !KMKeyCombination methodsFor: 'keymap building' stamp: 'CamilloBruni 3/18/2011 23:11'! value: aBuilder ^ self! ! !KMKeyCombination methodsFor: 'comparing' stamp: 'CamilloBruni 3/18/2011 23:11'! = aShortcut ^ aShortcut isKindOf: self species! ! !KMKeyCombination methodsFor: 'keymap building' stamp: 'GuillermoPolito 4/6/2012 13:26'! named: keymapName do: anActionBlock ^ KMKeymap named: keymapName shortcut: self action: anActionBlock! ! !KMKeyCombination methodsFor: 'converting' stamp: 'GuillermoPolito 6/28/2013 13:03'! asShortcut ^ self asKeyCombination! ! !KMKeyCombination methodsFor: 'matching' stamp: 'GuillermoPolito 10/20/2011 16:42'! matches: anEventBuffer ^ self matchesCompletely: anEventBuffer first! ! !KMKeyCombination methodsFor: 'combining' stamp: 'GuillermoPolito 3/15/2013 03:07'! win ^KMPlatformSpecificKeyCombination with: self onPlatform: #Windows! ! !KMKeyCombination methodsFor: 'combining' stamp: 'GuillermoPolito 3/15/2013 03:07'! unix ^KMPlatformSpecificKeyCombination with: self onPlatform: #Unix! ! !KMKeyCombination class methodsFor: 'instance creation' stamp: 'SeanDeNigris 1/22/2014 19:47'! fromKeyboardEvent: evt | modifier control command shift alt | control := evt controlKeyPressed. command := evt commandKeyPressed. shift := evt shiftPressed. alt := evt altKeyPressed. (shift | command | control | alt) ifFalse: [^ KMSingleKeyCombination from: evt keyCharacter ]. modifier := KMNoShortcut new. control ifTrue: [ modifier := modifier + KMModifier ctrl ]. command ifTrue: [ modifier := modifier + KMModifier command ]. shift ifTrue: [ modifier := modifier + KMModifier shift ]. alt ifTrue: [ modifier := modifier + KMModifier alt ]. ^ modifier + evt modifiedCharacter! ! !KMKeyCombinationChoice commentStamp: ''! I representing a choice between key combinations. A keyboard event will match with me when any of my key combinations matches with it.! !KMKeyCombinationChoice methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 12/11/2013 15:03'! currentCharacter | candidates | candidates := shortcuts collect: [ :each | each currentCharacter ] thenSelect: [ :each | each isNotNil ]. ^ candidates ifEmpty: [ nil ] ifNotEmpty: [ candidates first ]! ! !KMKeyCombinationChoice methodsFor: 'combining' stamp: 'GuillermoPolito 3/15/2013 03:06'! | aShortcut ^KMKeyCombinationChoice withShortcuts: (shortcuts copyWith: aShortcut)! ! !KMKeyCombinationChoice methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 2/19/2014 11:57'! prettyPrintOn: aStream (shortcuts select:[ :e | e platform = Smalltalk os platformFamily or: [ e platform = #all ] ]) do: [ :e | e prettyPrintOn: aStream ] separatedBy: [ aStream << ' | ' ]! ! !KMKeyCombinationChoice methodsFor: 'iterating' stamp: 'GuillermoPolito 9/24/2012 11:41'! combinationsDo: aBlock ^shortcuts do: aBlock! ! !KMKeyCombinationChoice methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 5/7/2013 18:25'! = another ^ shortcuts anySatisfy: [ :each | another = each ]! ! !KMKeyCombinationChoice methodsFor: 'iterating' stamp: 'GuillermoPolito 9/24/2012 11:42'! collect: aBlock ^shortcuts collect: aBlock! ! !KMKeyCombinationChoice methodsFor: 'matching' stamp: 'BenjaminVanRyseghem 11/1/2013 16:12'! matchesCompletely: anEventBuffer ^ shortcuts anySatisfy: [ :each | each matchesCompletely: anEventBuffer ]! ! !KMKeyCombinationChoice methodsFor: 'matching' stamp: 'BenjaminVanRyseghem 5/7/2013 18:26'! matches: anEventBuffer ^ shortcuts anySatisfy: [ :each | each matches: anEventBuffer ]! ! !KMKeyCombinationChoice methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 11:37'! shortcuts: someShortcuts shortcuts := someShortcuts! ! !KMKeyCombinationChoice methodsFor: 'matching' stamp: 'GuillermoPolito 9/24/2012 11:40'! includes: aShortcut ^shortcuts includes: aShortcut! ! !KMKeyCombinationChoice class methodsFor: 'instance creation' stamp: 'GuillermoPolito 9/24/2012 11:38'! withShortcuts: someShortcuts ^self new shortcuts: someShortcuts; yourself! ! !KMKeyCombinationSequence commentStamp: ''! I represent a sequence of key combinations. In order to have a match between me and a user's key presses, all user events must match all of my inner shortcuts in the same exact order. To create a sequence of key combinations use the #, message. Like for example: $a command , $b shift! !KMKeyCombinationSequence methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 2/19/2014 11:51'! prettyPrintOn: aStream shortcuts do: [ :e | e prettyPrintOn: aStream ] separatedBy: [ aStream << ' + ' ]! ! !KMKeyCombinationSequence methodsFor: 'matching' stamp: 'GuillermoPolito 3/19/2013 19:46'! beginsWith: aShortcut ^ self sequence first = aShortcut ! ! !KMKeyCombinationSequence methodsFor: 'comparing' stamp: 'CamilloBruni 3/18/2011 23:11'! hash ^ shortcuts hash! ! !KMKeyCombinationSequence methodsFor: 'accessing' stamp: 'GuillermoPolito 12/24/2010 22:39'! first: aShortcut self addShortcut: aShortcut! ! !KMKeyCombinationSequence methodsFor: 'accessing' stamp: 'GuillermoPolito 3/19/2013 19:46'! addShortcut: aShortcut self sequence add: aShortcut! ! !KMKeyCombinationSequence methodsFor: 'comparing' stamp: 'GuillermoPolito 3/19/2013 19:46'! = aShortcut ^ super = aShortcut and: [ shortcuts = aShortcut sequence ]! ! !KMKeyCombinationSequence methodsFor: 'printing' stamp: 'CamilloBruni 3/20/2011 23:44'! printOn: aStream shortcuts do: [ :shortcut| shortcut printOn: aStream] separatedBy: [ aStream nextPutAll: ' , '].! ! !KMKeyCombinationSequence methodsFor: 'matching' stamp: 'GuillermoPolito 3/19/2013 19:12'! matches: anEventBuffer |maxIndex| maxIndex := anEventBuffer size min: shortcuts size. 1 to: maxIndex do: [:index| ((shortcuts at: index) = (anEventBuffer at: index) asKeyCombination) ifFalse: [ ^ false]]. ^ true.! ! !KMKeyCombinationSequence methodsFor: 'accessing' stamp: 'GuillermoPolito 3/15/2011 00:42'! next: aShortcut self addShortcut: aShortcut! ! !KMKeyCombinationSequence methodsFor: 'combining' stamp: 'GuillermoPolito 3/19/2013 19:12'! , aShortcut self addShortcut: aShortcut asKeyCombination.! ! !KMKeyCombinationSequence methodsFor: 'accessing' stamp: 'GuillermoPolito 3/19/2013 19:46'! sequence ^ shortcuts ifNil: [ shortcuts := OrderedCollection new ]! ! !KMKeyCombinationSequence methodsFor: 'combining' stamp: 'GuillermoPolito 3/19/2013 19:46'! + aCharacter | last | last := self sequence last. self sequence removeLast. self addShortcut: last + aCharacter.! ! !KMKeyCombinationSequence class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! first: aShortcut next: anotherShortcut ^ (self new) first: aShortcut; next: anotherShortcut; yourself! ! !KMKeymap commentStamp: 'GuillermoPolito 12/14/2010 21:33'! I am the real keymap. I have an action to evaluate when my keymap sequence is pressed.! !KMKeymap methodsFor: 'comparing' stamp: 'GuillermoPolito 9/12/2011 17:49'! hash ^action hash bitXor: (shortcut hash bitXor: name hash)! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 4/6/2012 13:28'! description ^description ifNil: [ '' ]! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 11/6/2011 10:17'! shortcutHasChangedBy: aShortcut self defaultShortcut = self shortcut ifTrue: [ self shortcut: aShortcut ]. self defaultShortcut: aShortcut! ! !KMKeymap methodsFor: 'executing' stamp: 'GuillermoPolito 10/20/2011 18:58'! executeActionTargetting: target ^ self action cull: target cull: target! ! !KMKeymap methodsFor: 'matching' stamp: 'BenjaminVanRyseghem 11/1/2013 16:11'! matchesCompletely: aShortcut ^ self shortcut matchesCompletely: aShortcut! ! !KMKeymap methodsFor: 'enabling/disabling' stamp: 'SeanDeNigris 7/8/2012 23:14'! disable self shortcut: KMNoShortcut new.! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 3/14/2011 02:54'! shortcut: aShortcut shortcut := aShortcut.! ! !KMKeymap methodsFor: 'enabling/disabling' stamp: 'SeanDeNigris 7/8/2012 23:27'! reset self shortcut: self defaultShortcut.! ! !KMKeymap methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:35'! action: anAction action := anAction! ! !KMKeymap methodsFor: 'matching' stamp: 'GuillermoPolito 10/20/2011 18:56'! notifyPartialMatchTo: aListener | listeners | aListener isCollection ifTrue: [ listeners := aListener ] ifFalse: [ { aListener } ]. listeners do: [ :l | l partialMatch ].! ! !KMKeymap methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! shortcut ^ shortcut! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 9/12/2011 17:32'! hasName ^name notNil! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 10/18/2011 20:49'! defaultShortcut: aShortcut defaultShortcut := aShortcut.! ! !KMKeymap methodsFor: 'comparing' stamp: 'MarianoMartinezPeck 5/30/2012 17:12'! = aKeymap self == aKeymap ifTrue: [ ^ true ]. self species = aKeymap species ifFalse: [ ^ false ]. ^action = aKeymap action and: [ shortcut = aKeymap shortcut and: [ name = aKeymap name ] ]! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 12/26/2010 22:14'! name: aName name := aName! ! !KMKeymap methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! action ^ action! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 10/18/2011 20:49'! defaultShortcut ^defaultShortcut! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 4/6/2012 13:28'! description: aDescription description := aDescription asString! ! !KMKeymap methodsFor: 'matching' stamp: 'BenjaminVanRyseghem 7/3/2012 12:57'! notifyCompleteMatchTo: aListener buffer: aBuffer | listeners | aListener isCollection ifTrue: [ listeners := aListener ] ifFalse: [ listeners := { aListener } ]. listeners do: [ :l | l completeMatch: self buffer: aBuffer ].! ! !KMKeymap methodsFor: 'matching' stamp: 'BenjaminVanRyseghem 7/3/2012 13:42'! matches: anEventBuffer ^ anEventBuffer ifEmpty: [ false ] ifNotEmpty: [ self shortcut matches: anEventBuffer ]! ! !KMKeymap methodsFor: 'printing' stamp: 'GuillermoPolito 5/31/2011 12:50'! printOn: aStream aStream nextPutAll: self name printString; nextPutAll: ' on '; nextPutAll: self shortcut printString; nextPutAll: ' do ' ; nextPutAll: self action printString; cr. ! ! !KMKeymap methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! key ^ name! ! !KMKeymap methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! name ^ name! ! !KMKeymap methodsFor: 'matching' stamp: 'GuillermoPolito 10/20/2011 19:11'! onMatchWith: anEventBuffer notify: aMatchListener andDo: anAction (self matches: anEventBuffer) ifTrue: [ (self matchesCompletely: anEventBuffer) ifTrue: [ self notifyCompleteMatchTo: aMatchListener buffer: anEventBuffer ] ifFalse: [ self notifyPartialMatchTo: aMatchListener ]. anAction value. ] ! ! !KMKeymap class methodsFor: 'instance creation' stamp: 'GuillermoPolito 4/6/2012 13:27'! named: keymapName shortcut: aShortcut action: anAction description: aDescription ^ (self new) name: keymapName; defaultShortcut: aShortcut; shortcut: aShortcut; action: anAction; description: aDescription; yourself! ! !KMKeymap class methodsFor: 'instance creation' stamp: 'GuillermoPolito 1/21/2012 21:34'! shortcut: aShortcut action: anAction ^ (self new) defaultShortcut: aShortcut; shortcut: aShortcut; action: anAction; yourself! ! !KMKeymap class methodsFor: 'instance creation' stamp: 'GuillermoPolito 10/18/2011 20:49'! named: keymapName shortcut: aShortcut action: anAction ^ (self new) name: keymapName; defaultShortcut: aShortcut; shortcut: aShortcut; action: anAction; yourself! ! !KMKeymapBuilder commentStamp: ''! I am a specific builder to configure one shortcut.! !KMKeymapBuilder methodsFor: 'building' stamp: 'GuillermoPolito 9/24/2012 11:53'! category: aCategoryName shortcut: aShortcutCombination do: actionBlock description: aDescription "actionBlock - can take 3 optional arguments: target, morph, and keyboard event" aShortcutCombination combinationsDo: [ :combination | KMRepository default initializeKeymap: shortcutName executingOn: combination shortcut doing: actionBlock inCategory: aCategoryName platform: combination platform description: aDescription ]! ! !KMKeymapBuilder methodsFor: 'accessing' stamp: 'GuillermoPolito 10/21/2011 01:26'! platform: aPlatform platform := aPlatform! ! !KMKeymapBuilder methodsFor: 'building' stamp: 'SeanDeNigris 7/11/2012 09:51'! category: aCategoryName default: aShortcut do: actionBlock "actionBlock - can take 3 optional arguments: target, morph, and keyboard event" KMRepository default initializeKeymap: shortcutName executingOn: aShortcut doing: actionBlock inCategory: aCategoryName platform: platform! ! !KMKeymapBuilder methodsFor: 'building' stamp: 'GuillermoPolito 9/24/2012 11:43'! category: aCategoryName shortcut: aShortcutCombination do: actionBlock "actionBlock - can take 3 optional arguments: target, morph, and keyboard event" aShortcutCombination combinationsDo: [ :combination | KMRepository default initializeKeymap: shortcutName executingOn: combination shortcut doing: actionBlock inCategory: aCategoryName platform: combination platform ]! ! !KMKeymapBuilder methodsFor: 'building' stamp: 'GuillermoPolito 4/6/2012 13:23'! category: aCategoryName default: aShortcut do: anAction description: aDescription KMRepository default initializeKeymap: shortcutName executingOn: aShortcut doing: anAction inCategory: aCategoryName platform: platform description: aDescription! ! !KMKeymapBuilder methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 11:57'! shortcutName: aShortcutName shortcutName := aShortcutName! ! !KMKeymapBuilder class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 10/21/2011 00:14'! for: aShortcutName platform: aPlatform ^self new shortcutName: aShortcutName; platform: aPlatform; yourself! ! !KMKeymapTest methodsFor: 'tests' stamp: 'MarcusDenker 9/12/2013 10:03'! testExecute | bm km flag category | category := KMCategory named: #TestFoo. KMRepository default addCategory: category. bm := KMMockMorph new. bm attachKeymapCategory: #TestFoo. flag := false. category addKeymapEntry: (KMKeymap named: #Foo shortcut: $a asKeyCombination , $b asKeyCombination , $c asKeyCombination action: [ flag := true ]). category addKeymapEntry: (KMKeymap named: #Bar shortcut: $p asKeyCombination , $p asKeyCombination action: [ ]). {(self eventKey: $a). (self eventKey: $b). (self eventKey: $c)} do: [ :e | bm dispatchKeystrokeForEvent: e ]. self assert: flag! ! !KMKeymapTest methodsFor: 'tests' stamp: 'MarcusDenker 9/12/2013 10:03'! testMatching | category blockAction a b c p| a := self eventKey: $a. b := self eventKey: $b. c := self eventKey: $c. p := self eventKey: $p. blockAction := [self error: 'error']. category := KMCategory named: #testCategory. category addKeymapEntry: (KMKeymap named: #Foo shortcut: $a asKeyCombination, $b asKeyCombination, $c asKeyCombination action: blockAction). category addKeymapEntry: (KMKeymap named: #Fum shortcut: $p asKeyCombination, $p asKeyCombination action: blockAction). self assert: (category matches: {a}). self deny: (category matches: {b}). self assert: (category matches: {a. b}). self assert: (category matchesCompletely: {a. b. c}). self assert: (category matches: {p}). self assert: (category matchesCompletely: {p. p.}). self deny: (category matches: {a. p. p}). self deny: (category matches: {self eventKey: $l. self eventKey: $m. self eventKey: $n. self eventKey: $o}).! ! !KMKeymapTest methodsFor: 'tests' stamp: 'DeboraFortini 12/13/2011 17:23'! keymapContainer ^ KMRepository default! ! !KMKeymapTest class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapEventBuilderClass ^ KMFactory keymapEventBuilder! ! !KMLog commentStamp: ''! I am a simple log utility that can be enabled by sending the #setDebug and disabled by using #removeDebug. I trace the keymapping events.! !KMLog class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 11/1/2011 17:51'! removeDebug debug := false! ! !KMLog class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 11/1/2011 17:50'! log: aMessage (debug notNil and: [ debug ]) ifTrue: [ Transcript show: aMessage ]! ! !KMLog class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 11/1/2011 17:51'! setDebug debug := true! ! !KMMetaModifier commentStamp: ''! I represent the Meta or Command key modifier. Look at my superclass for a more detailed explanaition.! !KMMetaModifier methodsFor: 'printing' stamp: 'CamilloBruni 9/15/2013 20:33'! symbol ^ '⌘'! ! !KMMetaModifier methodsFor: 'initialization' stamp: 'NicolasPetton 12/6/2013 15:51'! initialize super initialize. identifier := #m. name := 'Meta'.! ! !KMMetaModifier methodsFor: 'matching' stamp: 'cami 7/22/2013 18:28'! matchesEvent: aKeyboardEvent self flag: #todo. "Command in windows and linux platforms is 'meta' key and do not have any sense (for the environment, right now). In the future we need to create a KMMetaModifier to handle properly this, and keep command as a mac-specific key" (Smalltalk os isUnix or: [ Smalltalk os isWin32 ]) ifTrue: [ ^ aKeyboardEvent controlKeyPressed ]. ^ aKeyboardEvent commandKeyPressed! ! !KMMetaModifier methodsFor: 'accessing' stamp: 'SeanDeNigris 11/22/2011 18:53'! eventCode ^ 64.! ! !KMMockMorph commentStamp: ''! I am a morph used for mock reasons.! !KMModifiedKeyCombination commentStamp: ''! I represent key combinations combining a single key + a modifier. The modifier could be a single modifier key (look at my subclasses) or a combination of them. For example, valid modified key combinations could be: - shift + a - ctrl + shift + c To create a modified key combinations use the #command, #alt, #control or #shift messages. Like for example: $a command $b shift $1 control $z alt! !KMModifiedKeyCombination methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 12/11/2013 14:58'! currentCharacter ^ self character key! ! !KMModifiedKeyCombination methodsFor: 'combining' stamp: 'GuillermoPolito 5/31/2011 18:26'! command ^ self modifiedBy: KMModifier command! ! !KMModifiedKeyCombination methodsFor: 'matching' stamp: 'BenjaminVanRyseghem 7/3/2012 15:59'! beginsWith: aKMShortcut ^ self = aKMShortcut ! ! !KMModifiedKeyCombination methodsFor: 'comparing' stamp: 'CamilloBruni 3/18/2011 23:11'! hash ^ character hash + modifier hash! ! !KMModifiedKeyCombination methodsFor: 'combining' stamp: 'GuillermoPolito 3/19/2013 20:12'! control ^ self modifiedBy: KMModifier ctrl! ! !KMModifiedKeyCombination methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! character ^ character! ! !KMModifiedKeyCombination methodsFor: 'accessing' stamp: 'GuillermoPolito 12/24/2010 22:31'! modifier: aModifier modifier := aModifier! ! !KMModifiedKeyCombination methodsFor: 'combining' stamp: 'CamilloBruni 3/19/2011 21:19'! alt ^ self modifiedBy: KMModifier alt! ! !KMModifiedKeyCombination methodsFor: 'combining' stamp: 'GuillermoPolito 5/3/2013 14:51'! modifiedBy: aModifier ^self character asKeyCombination modifiedBy: modifier + aModifier.! ! !KMModifiedKeyCombination methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! modifier ^ modifier! ! !KMModifiedKeyCombination methodsFor: 'combining' stamp: 'CamilloBruni 3/18/2011 23:11'! shift ^ self modifiedBy: KMModifier shift! ! !KMModifiedKeyCombination methodsFor: 'matching' stamp: 'GuillermoPolito 10/20/2011 15:51'! matchesEvent: aKeyboardEvent ^ (self modifier matchesEvent: aKeyboardEvent) and: [self character matchesEvent: aKeyboardEvent]! ! !KMModifiedKeyCombination methodsFor: 'comparing' stamp: 'NicolasPetton 12/6/2013 16:21'! = aShortcut super = aShortcut ifFalse: [ ^ false ]. modifier = aShortcut modifier ifFalse: [ ^ false ]. aShortcut character = character ifFalse: [ ^ false ]. ^ true! ! !KMModifiedKeyCombination methodsFor: 'printing' stamp: 'CamilloBruni 3/20/2011 23:45'! printOn: aStream modifier printOn: aStream. aStream << ' + '. character printOn: aStream.! ! !KMModifiedKeyCombination methodsFor: 'combining' stamp: 'GuillermoPolito 3/19/2013 20:12'! ctrl ^ self control! ! !KMModifiedKeyCombination methodsFor: 'accessing' stamp: 'GuillermoPolito 12/25/2010 14:22'! character: aCharacter character := aCharacter.! ! !KMModifiedKeyCombination methodsFor: 'accessing' stamp: 'SeanDeNigris 11/22/2011 18:39'! key ^ self character key.! ! !KMModifiedKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! modifier: aModifier character: aCharacter ^ (self new) modifier: aModifier; character: aCharacter; yourself! ! !KMModifier commentStamp: ''! I'm an abstract class representing a key modifier. A modifier is a key that is pressed to modify the value of a following key. For example, valid modifiers are Alt, Ctrl, Cmd (only for macosx), Shift. Additionally, I could be a composed modifier, combining several of the named above. For example, I could have a value of Alt + Ctrl.! !KMModifier methodsFor: 'accessing' stamp: 'CamilloBruni 3/20/2011 23:54'! identifier ^ identifier! ! !KMModifier methodsFor: 'matching' stamp: 'CamilloBruni 3/19/2011 20:50'! matchesEvent: aKeyboardEvent self subclassResponsibility! ! !KMModifier methodsFor: 'comparing' stamp: 'CamilloBruni 3/20/2011 23:54'! hash ^ identifier hash bitXor: name hash! ! !KMModifier methodsFor: 'comparing' stamp: 'CamilloBruni 3/20/2011 23:58'! = aShortcut super = aShortcut ifFalse: [ ^ false ]. aShortcut identifier = identifier ifFalse: [ ^ false ]. ^ true! ! !KMModifier methodsFor: 'accessing' stamp: 'SeanDeNigris 11/22/2011 19:00'! eventCode "No modifiers" ^ 0.! ! !KMModifier methodsFor: 'printing' stamp: 'CamilloBruni 3/20/2011 23:54'! printOn: aStream aStream << name! ! !KMModifier methodsFor: 'matching' stamp: 'CamilloBruni 3/19/2011 20:49'! matches: aKeyboardEvent self shouldNotImplement! ! !KMModifier methodsFor: 'combining' stamp: 'CamilloBruni 3/19/2011 21:16'! modifiedBy: modifier ^ KMComposedModifier new modifiedBy: modifier; modifiedBy: self; yourself! ! !KMModifier methodsFor: 'accessing' stamp: 'CamilloBruni 3/20/2011 23:54'! name ^ name! ! !KMModifier methodsFor: 'combining' stamp: 'GuillermoPolito 3/19/2013 19:12'! + modifier ^ modifier asKeyCombination modifiedBy: self! ! !KMModifier class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 19:49'! meta ^ KMMetaModifier new! ! !KMModifier class methodsFor: 'instance creation' stamp: 'NicolasPetton 12/6/2013 15:56'! command ^ KMCommandModifier new! ! !KMModifier class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! alt ^ KMAltModifier new! ! !KMModifier class methodsFor: 'instance creation' stamp: 'GuillermoPolito 3/19/2013 20:19'! control ^ KMCtrlModifier new! ! !KMModifier class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! shift ^ KMShiftModifier new! ! !KMModifier class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! ctrl ^ KMCtrlModifier new! ! !KMNoKeymap commentStamp: 'GuillermoPolito 2/24/2011 23:43'! I am a Null object representing the absence of a Keymap.! !KMNoKeymap methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! shortcut ^ KMNoShortcut new! ! !KMNoShortcut commentStamp: ''! I do not match with any keyboard event. I respond to the Null object pattern, since I represent the inexistance of a key combination.! !KMNoShortcut methodsFor: 'matching' stamp: 'CamilloBruni 3/20/2011 23:50'! matches: anEventBuffer ^ false! ! !KMNoShortcut methodsFor: 'combining' stamp: 'CamilloBruni 3/18/2011 23:11'! , aShortcut ^ aShortcut! ! !KMNoShortcut methodsFor: 'printing' stamp: 'CamilloBruni 3/20/2011 23:41'! printOn: aStream! ! !KMNoShortcut methodsFor: 'matching' stamp: 'CamilloBruni 3/20/2011 23:50'! matchesCompletely: anEventBuffer ^ false! ! !KMNoShortcut methodsFor: 'combining' stamp: 'CamilloBruni 3/18/2011 23:11'! + aKMModifier ^ aKMModifier! ! !KMPartialMatch commentStamp: ''! A KMPartialMatch is an announcement raised when a partial match is completed! !KMPartialMatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 12:52'! event ^ event! ! !KMPartialMatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 12:52'! event: anObject event := anObject! ! !KMPartialMatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 14:42'! source: anObject source := anObject! ! !KMPartialMatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 14:42'! source ^ source! ! !KMPartialMatch class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 7/3/2012 14:42'! event: event from: source ^ self new event: event; source: source; yourself! ! !KMPerInstanceTests methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 1/21/2012 21:37'! testAddMoreThanOneHandler | flag morph | flag := 0. morph := KMMockMorph new. morph on: $i do: [ flag := flag + 1 ]. morph on: $j do: [ flag := flag + 6 ]. { self eventKey: $i. self eventKey: $j } do: [:e | morph dispatchKeystrokeForEvent: e]. self assert: flag equals: 7.! ! !KMPlatformSpecificKeyCombination commentStamp: ''! I represent a platform specific key combination, one that should only be launched for a particular platform such as windows, unix or mac. I'm a sort of decorator of a key combination.! !KMPlatformSpecificKeyCombination methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 12/11/2013 15:04'! currentCharacter ^ (self platform = #all or: [ self platform = OSPlatform current platformFamily ]) ifTrue: [ self shortcut currentCharacter ] ifFalse: [ nil ]! ! !KMPlatformSpecificKeyCombination methodsFor: 'combining' stamp: 'GuillermoPolito 3/15/2013 03:06'! | aShortcut ^KMKeyCombinationChoice withShortcuts: { self . aShortcut }! ! !KMPlatformSpecificKeyCombination methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 2/19/2014 11:55'! prettyPrintOn: aStream self platform = #MacOSX ifTrue: [ shortcut prettyPrintOn: aStream ] ifFalse: [ shortcut printOn: aStream ]! ! !KMPlatformSpecificKeyCombination methodsFor: 'iterating' stamp: 'GuillermoPolito 9/24/2012 11:40'! combinationsDo: aBlock aBlock value: self! ! !KMPlatformSpecificKeyCombination methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/1/2013 16:13'! matchesCompletely: aCollection self platform == Smalltalk os platformFamily ifFalse: [ ^ false ]. ^ self shortcut matchesCompletely: aCollection! ! !KMPlatformSpecificKeyCombination methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 11:13'! shortcut: aShortcut shortcut := aShortcut! ! !KMPlatformSpecificKeyCombination methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/1/2013 16:13'! matches: aCollection self platform == Smalltalk os platformFamily ifFalse: [ ^ false ]. ^ self shortcut matches: aCollection! ! !KMPlatformSpecificKeyCombination methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 11:14'! shortcut ^shortcut! ! !KMPlatformSpecificKeyCombination methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 11:15'! platform ^platform! ! !KMPlatformSpecificKeyCombination methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 11:14'! platform: aPlatform platform := aPlatform! ! !KMPlatformSpecificKeyCombination class methodsFor: 'instance creation' stamp: 'GuillermoPolito 9/24/2012 11:14'! with: aShortcut onPlatform: aPlatform ^self new shortcut: aShortcut; platform: aPlatform; yourself! ! !KMPragmaKeymapBuilder commentStamp: ''! I am a singleton object, subscribed to system events, to listen to the creation of methods marked with the and keymap:> pragmas. When I listen one of those events, I reinitialize the KMRepository default instance and reload it with all declared keymaps.! !KMPragmaKeymapBuilder methodsFor: 'registrations handling' stamp: 'BenjaminVanRyseghem 4/7/2012 23:14'! collectRegistrations | menu | menu := PragmaMenuAndShortcutRegistration model: self. self pragmaCollector do: [:prg | prg methodClass theNonMetaClass perform: prg selector with: (menu platform: prg arguments; yourself) ]. self interpretRegistration: menu! ! !KMPragmaKeymapBuilder methodsFor: 'initialization' stamp: 'GuillermoPolito 12/17/2010 00:58'! initialize super initialize. pragmaKeywords := OrderedCollection new. ! ! !KMPragmaKeymapBuilder methodsFor: 'accessing' stamp: 'GuillermoPolito 12/17/2010 00:46'! model ^ model! ! !KMPragmaKeymapBuilder methodsFor: 'accessing' stamp: 'GuillermoPolito 12/17/2010 00:46'! builder ^ self! ! !KMPragmaKeymapBuilder methodsFor: 'accessing' stamp: 'GuillermoPolito 12/17/2010 00:46'! itemReceiver ^ model! ! !KMPragmaKeymapBuilder methodsFor: 'private' stamp: 'GuillermoPolito 9/24/2012 11:57'! interpretRegistration: aRegistration aRegistration items do: [:item || node | node := KMKeymapBuilder for: item shortcut platform: item platform. item help ifNil: [ node category: item category shortcut: item default do: item action ] ifNotNil:[ node category: item category shortcut: item default do: item action description: item help ]]! ! !KMPragmaKeymapBuilder methodsFor: 'initialize-release' stamp: 'GuillermoPolito 1/27/2011 18:10'! reset pragmaCollector := nil. "KeymapManager default: KeymapManager new." self collectRegistrations.! ! !KMPragmaKeymapBuilder methodsFor: 'accessing' stamp: 'GuillermoPolito 10/21/2011 00:04'! pragmaKeywords "Returns the pragmas keyword used to select pragmas (see #pragmaCollector)" ^ self class pragmas! ! !KMPragmaKeymapBuilder methodsFor: 'registrations handling' stamp: 'GuillermoPolito 10/21/2011 00:00'! pragmaCollector "Return an up-to-date pragmaCollector which contains all pragmas which keyword is self pragmaKeyword" ^ pragmaCollector ifNil: [pragmaCollector:= (PragmaCollector filter: [:prg | (self pragmaKeywords includes: prg keyword) and: [prg selector numArgs = 1]]). (self pragmaKeywords notNil and: [self pragmaKeywords notEmpty]) ifTrue: [pragmaCollector reset]. pragmaCollector whenChangedSend: #reset to: self. pragmaCollector]! ! !KMPragmaKeymapBuilder methodsFor: 'accessing' stamp: 'GuillermoPolito 12/17/2010 00:46'! model: anObject model := anObject! ! !KMPragmaKeymapBuilder methodsFor: 'initialize-release' stamp: 'GuillermoPolito 5/4/2012 23:00'! release self pragmaCollector unsubscribe: self. self pragmaCollector announcer initialize. "Hack because the announcer is not garbage collected." pragmaCollector := nil. model := nil. super release ! ! !KMPragmaKeymapBuilder class methodsFor: 'instance creation' stamp: 'CamilleTeruel 7/29/2012 18:45'! release SystemAnnouncer uniqueInstance unsubscribe: self. self uniqueInstance release! ! !KMPragmaKeymapBuilder class methodsFor: 'instance creation' stamp: 'GuillermoPolito 10/20/2011 23:55'! pragmas ^#(#keymap #keymap:)! ! !KMPragmaKeymapBuilder class methodsFor: 'instance creation' stamp: 'GuillermoPolito 7/31/2012 12:00'! initialize "KMPragmaKeymapBuilder initialize" self uniqueInstance reset.! ! !KMPragmaKeymapBuilder class methodsFor: 'private' stamp: 'GuillermoPolito 8/3/2012 14:12'! event: anEvent anEvent methodAffected ifNil: [ ^self ]. ((anEvent methodAffected pragmas collect: #keyword) includesAnyOf: self pragmas ) ifTrue: [ self uniqueInstance reset ]! ! !KMPragmaKeymapBuilder class methodsFor: 'instance creation' stamp: 'GuillermoPolito 10/20/2011 23:59'! uniqueInstance ^UniqueInstace ifNil: [ UniqueInstace := self new ]! ! !KMPragmaKeymapBuilder class methodsFor: 'system-events' stamp: 'EstebanLorenzano 8/3/2012 14:08'! registerInterestToSystemAnnouncement SystemAnnouncer uniqueInstance unsubscribe: self; on: MethodAdded, MethodModified, MethodRemoved send: #event: to: self.! ! !KMRepository commentStamp: 'GuillermoPolito 12/14/2010 21:37'! I have a singleton instance which can be accessed by executing the following: "self default" I am currently a god object to be refactored =D.! !KMRepository methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! categories ^ categories ifNil: [ categories := Dictionary new ]! ! !KMRepository methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapNamed: aKeymapName inCategory: aKeymapCategory ^ (self categoryForName: aKeymapCategory) keymapNamed: aKeymapName! ! !KMRepository methodsFor: 'global' stamp: 'GuillermoPolito 5/3/2013 15:58'! setAsGlobalCategory: aGlobalCategory | category | category := aGlobalCategory asKmCategoryIn: self. (self globalCategories includes: category) ifFalse: [ self globalCategories add: category ]! ! !KMRepository methodsFor: 'testing' stamp: 'CamilloBruni 3/18/2011 23:11'! includesCategory: aCategory ^ self categories includes: aCategory! ! !KMRepository methodsFor: 'global' stamp: 'GuillermoPolito 5/3/2013 15:55'! globalCategories ^globalCategories ifNil: [ globalCategories := OrderedCollection new ]! ! !KMRepository methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! categoryHolders ^ categoryHolders ifNil: [ categoryHolders := Dictionary new ]! ! !KMRepository methodsFor: 'keymaps' stamp: 'GuillermoPolito 3/13/2011 17:58'! attachCategoryName: aCategorySymbol to: aClass self attach: (self ensureCategoryByName: aCategorySymbol) to: aClass.! ! !KMRepository methodsFor: 'accessing' stamp: 'MarcusDenker 9/12/2013 10:03'! ensureCategoryByName: aCategorySymbol | category | (self includesCategoryNamed: aCategorySymbol) ifFalse: [ category := KMCategory named: aCategorySymbol. self addCategory: category ] ifTrue: [ category := self categoryForName: aCategorySymbol ]. ^ category! ! !KMRepository methodsFor: 'keymaps' stamp: 'GuillermoPolito 12/26/2010 22:05'! attach: aCategory to: aClass (self categoryHolders includesKey: aClass) ifFalse: [ self categoryHolders at: aClass put: Set new ]. (self categoryHolders at: aClass) add: aCategory! ! !KMRepository methodsFor: 'accessing' stamp: 'MarcusDenker 9/12/2013 10:03'! categoryForName: aCategorySymbol ^ self categories at: aCategorySymbol ifAbsentPut: [ KMCategory named: aCategorySymbol ]! ! !KMRepository methodsFor: 'accessing' stamp: 'GuillermoPolito 4/6/2012 13:25'! initializeKeymap: shortcutName executingOn: shortcut doing: action inCategory: categoryName platform: aPlatform ^self initializeKeymap: shortcutName executingOn: shortcut doing: action inCategory: categoryName platform: aPlatform description: ''! ! !KMRepository methodsFor: 'accessing' stamp: 'GuillermoPolito 3/19/2013 19:12'! initializeKeymap: shortcutName executingOn: shortcut doing: action inCategory: categoryName platform: aPlatform description: aDescription | category entry | category := self ensureCategoryByName: categoryName. (category hasKeymapNamed: shortcutName at: aPlatform) not ifTrue: [ entry := shortcut asKeyCombination named: shortcutName do: action withDescription: aDescription. category addKeymapEntry: entry at: aPlatform. ] ifFalse:[ entry := category keymapNamed: shortcutName at: aPlatform. entry shortcutHasChangedBy: shortcut asKeyCombination. entry action: action. entry description: aDescription ]! ! !KMRepository methodsFor: 'testing' stamp: 'CamilloBruni 3/18/2011 23:11'! includesCategoryNamed: aCategorySymbol ^ self categories includesKey: aCategorySymbol! ! !KMRepository methodsFor: '*Deprecated30' stamp: 'GuillermoPolito 5/4/2013 16:06'! categoriesForClass: aClass | classCategories superclassCategories | self deprecated: 'Static shortcuts are not used any more'. aClass == Object ifTrue: [ ^ Set new ]. classCategories := self categoryHolders at: aClass ifAbsent: [ Set new ]. superclassCategories := self categoriesForClass: aClass superclass. ^ classCategories union: superclassCategories! ! !KMRepository methodsFor: 'associating' stamp: 'GuillermoPolito 12/15/2010 01:59'! addCategory: aCategory (self includesCategory: aCategory) ifTrue: [ self error: 'a Category named ' , aCategory name, ' already exists.' ]. self categories at: aCategory name put: aCategory.! ! !KMRepository class methodsFor: 'instance creation' stamp: 'MarcusDenker 9/12/2013 10:03'! reset "Do not reset KMDispatchers instances, it may make the image unusable or force the user to close all the windows." "TODO: a better reset, allowing the KMDispatcher instances to reload all named, updated, keymaps from the resetted KMRepository." World setProperty: #kmDispatcher toValue: nil. self default: self new. KMCategory allSubclasses select: [ :c | c isGlobalCategory ] thenDo: [ :c | c new installAsGlobalCategory ]. KMPragmaKeymapBuilder uniqueInstance reset.! ! !KMRepository class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! default ^ Singleton ifNil: [ Singleton := self new ]! ! !KMRepository class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! default: aDefault ^ Singleton := aDefault! ! !KMRepository class methodsFor: 'cleanup' stamp: 'MarcusDenker 10/11/2013 12:31'! cleanUp self reset! ! !KMShiftModifier commentStamp: ''! I represent the Shift key modifier. Look at my superclass for a more detailed explanaition.! !KMShiftModifier methodsFor: 'printing' stamp: 'CamilloBruni 9/15/2013 20:33'! symbol ^ '⇧'! ! !KMShiftModifier methodsFor: 'matching' stamp: 'GuillermoPolito 10/20/2011 15:50'! matchesEvent: aKeyboardEvent ^ aKeyboardEvent shiftPressed! ! !KMShiftModifier methodsFor: 'initialization' stamp: 'CamilloBruni 3/20/2011 23:55'! initialize super initialize. identifier := #s. name := 'Shift'.! ! !KMShiftModifier methodsFor: 'accessing' stamp: 'BenComan 2/23/2014 01:29'! eventCode ^8! ! !KMShortcutDeclaration commentStamp: ''! I represent a shortcut declaration for the settings pharo framework.! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 9/12/2011 17:45'! realValue "Answer the value of realValue" ^ declaration ifNil: [ declaration := KMShortcutSetting for: self shortcutName in: self categoryName]! ! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 10/18/2011 20:52'! defaultValue ^self realValue defaultShortcut! ! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 10/18/2011 20:58'! realValue: aShortcut self realValue accept: aShortcut.! ! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 12:27'! categoryName: aCategoryName categoryName := aCategoryName! ! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 13:54'! shortcutName ^shortcutName! ! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 12:27'! categoryName ^categoryName! ! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 13:54'! shortcutName: aShortcutName shortcutName := aShortcutName! ! !KMShortcutHandler commentStamp: ''! I am a shortcut handler that installs keymappings in the system.! !KMShortcutHandler methodsFor: 'shortcut-handling' stamp: 'GuillermoPolito 11/7/2013 16:52'! handleKeystroke: aKeystrokeEvent inMorph: aMorph aMorph handleKeystrokeWithKeymappings: aKeystrokeEvent! ! !KMShortcutHandler class methodsFor: 'tools' stamp: 'GuillermoPolito 11/7/2013 16:59'! registerToolsOn: aToolRegistry aToolRegistry register: self new as: #shortcuts! ! !KMShortcutSetting commentStamp: ''! I represent a shortcut setting. I relate a keymap with its default shortcut and its current shortcut, so it can be mutated.! !KMShortcutSetting methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 12:46'! shortcutName: aShortcutName shortcutName := aShortcutName! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 12:43'! keymap ^ KMFactory keymapContainer keymapNamed: shortcutName inCategory: category! ! !KMShortcutSetting methodsFor: 'setting' stamp: 'GuillermoPolito 1/24/2011 01:13'! accept: aShortcut self keymap shortcut: aShortcut! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'GuillermoPolito 10/18/2011 20:52'! defaultShortcut ^ self keymap defaultShortcut! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! keystrokes ^ self keymap shortcut! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'GuillermoPolito 1/24/2011 22:02'! action: anActionBlock action := anActionBlock! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! shortcut ^ self keymap shortcut! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'GuillermoPolito 1/20/2011 00:55'! category: aCategory category := aCategory! ! !KMShortcutSetting class methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/10/2013 09:24'! settingInputWidgetForNode: aSettingNode | catcherMorph theme | theme := UITheme builder. catcherMorph := KMCatcherMorph for: aSettingNode realValue. ^ theme newRow: {catcherMorph}! ! !KMShortcutSetting class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/18/2011 23:11'! for: aShortcutName in: aCategory ^ (self new) shortcutName: aShortcutName; category: aCategory; yourself! ! !KMShortcutTest methodsFor: 'tests' stamp: 'GuillermoPolito 3/19/2013 19:12'! testSingleShortcutsMatch |a one home | a := self eventKey: $a. one := self eventKey: 1 asCharacter. home := self eventKey: Character home. self assert: ($a asKeyCombination matches: {a}). self assert: (1 asKeyCombination matches: {one}). self assert: (Character home asKeyCombination matches: {home}). self deny: ($b asKeyCombination matches: {a}). self assert: ($a asKeyCombination matchesCompletely: {a}). self assert: (1 asKeyCombination matchesCompletely: {one}).! ! !KMShortcutTest methodsFor: 'tests' stamp: 'GuillermoPolito 3/19/2013 20:28'! testCreation self assert: ($e asKeyCombination isKindOf: KMSingleKeyCombination). self assert: ($e ctrl isKindOf: KMModifiedKeyCombination). self assert: ($e ctrl alt shift command isKindOf: KMModifiedKeyCombination).! ! !KMShortcutTest methodsFor: 'tests' stamp: 'CamilloBruni 3/21/2011 21:56'! testTripleChainShortcutSucceds ^ self assert: ($e ctrl , $e ctrl , $d ctrl) = ($e ctrl , $e ctrl , $d ctrl)! ! !KMShortcutTest methodsFor: 'tests' stamp: 'CamilloBruni 3/21/2011 21:56'! testChainIntegerSucceds ^ self assert: ($e ctrl , 1) = ($e ctrl , 1)! ! !KMShortcutTest methodsFor: 'tests' stamp: 'CamilloBruni 3/21/2011 21:56'! testChainSimpleCharsSucceds ^ self assert: ($e ctrl , $e) = ($e ctrl , $e)! ! !KMShortcutTest methodsFor: 'tests' stamp: 'GuillermoPolito 1/21/2012 20:39'! testCmdShiftSucceds ^ self assert: ($1 shift ctrl matches: {self eventKey: $1 alt: false ctrl: true command: false shift: true})! ! !KMShortcutTest methodsFor: 'tests' stamp: 'CamilloBruni 3/21/2011 21:56'! testCmdIntegerSucceds ^ self assert: 1 ctrl = 1 ctrl! ! !KMShortcutTest methodsFor: 'tests' stamp: 'CamilloBruni 3/21/2011 21:56'! testBadComposedCmdShortcutFails ^ self should: [ KMModifier ctrl ctrl ] raise: Error! ! !KMShortcutTest methodsFor: 'tests' stamp: 'CamilloBruni 3/21/2011 21:56'! testComplexChainMatches |eCtrl eShift e f| f := self eventKey: $f. eCtrl := self eventKey: $e ctrl: true. eShift := self eventKey: $e shift: true. self assert: (($e ctrl, $e shift, $f) matches: {eCtrl}). self assert: (($e ctrl, $e shift, $f) matches: {eCtrl. eShift}). self assert: (($e ctrl, $e shift, $f) matches: {eCtrl. eShift. f}). self deny: (($e ctrl, $e shift, $f) matchesCompletely: {eCtrl}). self deny: (($e ctrl, $e shift, $f) matchesCompletely: {eCtrl. eShift}). self assert: (($e ctrl, $e shift, $f) matchesCompletely: {eCtrl. eShift. f}).! ! !KMShortcutTest methodsFor: 'tests' stamp: 'CamilloBruni 3/21/2011 21:56'! testCmdKeySucceds ^ self assert: $e ctrl = $e ctrl! ! !KMShortcutTest methodsFor: 'tests' stamp: 'CamilloBruni 3/21/2011 21:56'! testChainShortcutSucceds ^ self assert: ($e ctrl , $e ctrl) = ($e ctrl , $e ctrl)! ! !KMShortcutTest methodsFor: 'tests' stamp: 'CamilloBruni 3/21/2011 21:56'! testSimpleChainMatches |e eCtrl | e := self eventKey: $e. eCtrl := self eventKey: $e ctrl: true. self assert: (($e ctrl, $e) matches: {eCtrl}). self assert: ($e ctrl matches: {eCtrl. e}). self deny: (($e ctrl, $e) matches: {eCtrl. self eventKey: $a}). self deny: ($e ctrl matches: {e}).! ! !KMShortcutTest methodsFor: 'tests' stamp: 'GuillermoPolito 1/21/2012 20:39'! testModifiedShortcutsMatch |a oneShift oneCommand oneCommandShift| a := self eventKey: $a ctrl: true. oneShift := self eventKey: $1 shift: true. oneCommand := self eventKey: $1 command: true. oneCommandShift := self eventKey: $1 alt: false ctrl: false command: true shift: true. self assert: ($a ctrl matches: {a}). self assert: ($1 shift matches: {oneShift}). self assert: ($1 command matches: {oneCommand}). self assert: ($1 command shift matches: {oneCommandShift}). self deny: ($a ctrl matches: {self eventKey: $a command: true}). self deny: ($i command shift matches: {self eventKey: $i command: true}). self assert: ($i ctrl shift matches: {self eventKey: $i alt: false ctrl: true command: false shift: true}). self deny: ($i ctrl matches: {self eventKey: $i alt: false ctrl: true command: false shift: true}). self assert: ($a ctrl matchesCompletely: {a}). self assert: ($1 shift matchesCompletely: {oneShift}). self assert: ($1 command matchesCompletely: {oneCommand}). self assert: ($1 command shift matchesCompletely: {oneCommandShift}).! ! !KMShortcutTest methodsFor: 'tests' stamp: 'GuillermoPolito 2/14/2014 15:54'! testAsString self assert: $a ctrl asString = 'Ctrl + A'. self assert: $b command asString = 'Cmd + B'. self assert: $c shift asString = 'Shift + C'. self assert: $d alt asString = 'Alt + D'. self assert: $e ctrl command asString = (KMCtrlModifier new asString ,' + ' , KMCommandModifier new asString,' + E'). ! ! !KMShortcutTest methodsFor: 'tests' stamp: 'CamilloBruni 3/21/2011 21:56'! testShiftKeySucceds ^ self assert: $e shift = $e shift! ! !KMShortcutTest methodsFor: 'tests' stamp: 'BenComan 2/23/2014 01:40'! testEventCodes self assert: $s command modifier eventCode equals: OSPlatform current defaultModifier eventCode ! ! !KMSingleKeyCombination commentStamp: ''! I represent a single key press, the simplest key combination. I match with a keyboard event when that event key is the same as me and the key event is not modified. To create a single key combination use the #asShortcut message. Like for example: $a asShortcut! !KMSingleKeyCombination methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/10/2014 20:31'! currentCharacter ^ key! ! !KMSingleKeyCombination methodsFor: 'matching' stamp: 'DeboraFortini 10/18/2011 19:40'! matchesEvent: aKeyboardEvent ^ self key asLowercase = aKeyboardEvent modifiedCharacter asLowercase! ! !KMSingleKeyCombination methodsFor: 'comparing' stamp: 'CamilloBruni 3/18/2011 23:11'! hash ^ key hash! ! !KMSingleKeyCombination methodsFor: 'accessing' stamp: 'GuillermoPolito 12/25/2010 14:21'! key: aKeyString key := aKeyString.! ! !KMSingleKeyCombination methodsFor: 'comparing' stamp: 'GuillermoPolito 10/20/2011 16:30'! = aShortcut ^ super = aShortcut and: [ aShortcut key sameAs: key ]! ! !KMSingleKeyCombination methodsFor: 'printing' stamp: 'CamilloBruni 9/15/2013 21:18'! printOn: aStream aStream nextPutAll: self name asUppercase.! ! !KMSingleKeyCombination methodsFor: 'combining' stamp: 'GuillermoPolito 3/15/2013 02:52'! modifiedBy: aModifier ^ KMModifiedKeyCombination modifier: aModifier character: self! ! !KMSingleKeyCombination methodsFor: 'accessing' stamp: 'SeanDeNigris 11/22/2011 18:59'! modifier ^ KMModifier new.! ! !KMSingleKeyCombination methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! key ^ key! ! !KMSingleKeyCombination methodsFor: 'accessing' stamp: 'CamilloBruni 9/15/2013 20:19'! name ^ self key asString! ! !KMSingleKeyCombination class methodsFor: 'accessing' stamp: 'CamilloBruni 9/15/2013 20:26'! specialKeys ^specialKeys ifNil: [ specialKeys := {1->'home'. 3->'enter'. 4->'end'. 8->'backspace'. 9-> 'tab'. 11->'page up'. 12->'page down'. 27->'escape'. 28->'left arrow'. 29->'right arrow'. 30->'up arrow'. 31->'down arrow'. 127->'delete' } asDictionary.]! ! !KMSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:14'! from: aCharacterOrInteger | aCharacter | aCharacter := aCharacterOrInteger asCharacter. KMUntypeableSingleKeyCombination ifSpecialKey: aCharacter do: [ :keyCombination | ^ keyCombination ]. ^ self new key: aCharacter; yourself! ! !KMStorage commentStamp: ''! I am a storage of shortcuts. I store and provide facilities to access named and annonimous shortcuts.! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 20:57'! keymapNamed: aKmName ^namedRegistry at: aKmName! ! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 20:56'! hasKeymapNamed: aKmName ^namedRegistry includesKey: aKmName! ! !KMStorage methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/12/2013 16:19'! initialize anonymousRegistry := Set new. namedRegistry := Dictionary new.! ! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 21:01'! size ^self keymaps size! ! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 20:52'! addAll: keymaps keymaps do: [ :km | self add: km ].! ! !KMStorage methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/12/2013 16:19'! add: aKeymap aKeymap hasName ifTrue: [ namedRegistry at: aKeymap name put: aKeymap ] ifFalse: [ anonymousRegistry add: aKeymap ].! ! !KMStorage methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/12/2013 16:19'! remove: aKeymap aKeymap hasName ifTrue: [ namedRegistry removeKey: aKeymap name ] ifFalse: [ anonymousRegistry remove: aKeymap ].! ! !KMStorage methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/12/2013 16:19'! keymaps ^anonymousRegistry , namedRegistry values! ! !KMStorage methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/12/2013 16:19'! keymapForShortcut: aShortcut ^ namedRegistry detect: [ :keymap | keymap shortcut = aShortcut ] ifNone: [ anonymousRegistry detect: [ :keymap | keymap shortcut = aShortcut ] ifNone: [ nil ] ]! ! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 21:02'! , aKMStorage ^self class new addAll: self keymaps; addAll: aKMStorage keymaps.! ! !KMTarget commentStamp: 'GuillermoPolito 2/24/2011 23:44'! I am the reification of the Keymap target. I am the one that receives the actions.! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 11:18'! targetSelector ^targetSelector ifNil: [ #yourself ]! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 5/29/2011 23:50'! morph: aMorph morph := aMorph! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 11:10'! targetSelector: aTargetSelector targetSelector := aTargetSelector! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 10/20/2011 19:07'! morph ^morph! ! !KMTarget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/3/2012 12:51'! announcer ^ self morph announcer! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 5/4/2013 16:21'! dispatch: buffer morph kmDispatcher dispatch: buffer! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 6/24/2012 12:42'! ownerTarget morph owner ifNil: [ ^nil ]. ^morph owner kmDispatcher target.! ! !KMTarget methodsFor: 'iterating' stamp: 'GuillermoPolito 5/3/2013 17:10'! nextForKmChain: aKMDispatchChain ^self ownerTarget! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 11:15'! realTarget ^morph perform: self targetSelector! ! !KMTarget class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/31/2011 11:11'! for: aTarget in: aMorph ^ (self new) targetSelector: aTarget; morph: aMorph; yourself! ! !KMUntypeableSingleKeyCombination commentStamp: ''! I am an abstract class for all single key combinations that correspond to characters that cannot be typed directly.! !KMUntypeableSingleKeyCombination methodsFor: 'printing' stamp: 'CamilloBruni 9/15/2013 21:03'! symbol "I return the visual symbol for this shortcut. For instance for the Arrow Up key I contain a string with an arrow up key symbol: ↑ and now the Character arrowUp." ^ symbol! ! !KMUntypeableSingleKeyCombination methodsFor: 'accessing' stamp: 'CamilloBruni 9/15/2013 21:04'! name: aString name := aString! ! !KMUntypeableSingleKeyCombination methodsFor: 'accessing' stamp: 'CamilloBruni 9/15/2013 21:02'! name ^ name! ! !KMUntypeableSingleKeyCombination methodsFor: 'printing' stamp: 'CamilloBruni 9/15/2013 21:07'! printOn: aStream aStream nextPutAll:self name asUppercase.! ! !KMUntypeableSingleKeyCombination methodsFor: 'accessing' stamp: 'CamilloBruni 9/15/2013 21:04'! symbol: aString symbol := aString! ! !KMUntypeableSingleKeyCombination class methodsFor: 'testing' stamp: 'CamilloBruni 9/15/2013 21:14'! ifSpecialKey: aCharacter do: aBlock "Lookup if aCharacter needs to be handled by me, if so use one of the instance creation function for creating the corresponding KeyCombination." self specialKeys at: aCharacter ifPresent: [ :symbol | aBlock value: (self perform: symbol) ]! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:01'! tab ^ self key: Character tab name: 'Tab' symbol: '⇥'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:01'! escape ^ self key: Character escape name: 'Escape' symbol: '⎋'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:01'! arrowDown ^ self key: Character arrowDown name: 'Down Arrow' symbol: '↓'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:01'! end ^ self key: Character end name: 'End' symbol: '↘'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:01'! pageUp ^ self key: Character pageUp name: 'Page Up' symbol: '⇞'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:04'! key: aCharacter name: aString symbol: aVisualString ^ self new key: aCharacter; name: aString; symbol: aVisualString; yourself! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:01'! arrowLeft ^ self key: Character arrowLeft name: 'Left Arrow' symbol: '←'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'initialization' stamp: 'CamilloBruni 9/16/2013 00:22'! newSpecialKeys "Build a new dictionary that maps untypable characters to symbols for instacation creation methods on this class." | dictionary | dictionary := Dictionary new. #(home enter end backspace tab pageUp pageDown escape arrowLeft arrowRight arrowUp arrowDown delete) do: [ :symbol | dictionary at: (Character perform: symbol) put: symbol ]. ^ dictionary! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:01'! delete ^ self key: Character delete name: 'Delete' symbol: '⌦'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:01'! arrowUp ^ self key: Character arrowUp name: 'Up Arrow' symbol: '↑'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:06'! home ^ self key: Character home name: 'Home' symbol: '↖'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'accessing' stamp: 'CamilloBruni 9/15/2013 21:10'! specialKeys ^specialKeys ifNil: [ specialKeys := self newSpecialKeys ]! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:06'! pageDown ^ self key: Character pageDown name: 'Page Down' symbol: '⇟'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:01'! arrowRight ^ self key: Character arrowRight name: 'Right Arrow' symbol: '→'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:01'! backspace ^ self key: Character backspace name: 'Backspace' symbol: '⌫'! ! !KMUntypeableSingleKeyCombination class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/15/2013 21:01'! enter ^ self key: Character enter name: 'Enter' symbol: '↩'! ! !KOI8RTextConverter commentStamp: ''! A KOI8RTextConverter class is used to convert cyrillic inputs.! !KOI8RTextConverter class methodsFor: 'as yet unclassified' stamp: ''! initialize self initializeTables! ! !KOI8RTextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:53'! languageEnvironment ^RussianEnvironment! ! !KOI8RTextConverter class methodsFor: 'accessing' stamp: 'yo 12/11/2007 10:59'! encodingNames ^ #('koi8-r') copy ! ! !KOI8RTextConverter class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 21:40'! byteToUnicodeSpec "ByteTextConverter generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/MISC/KOI8-R.TXT'" ^ #( 16r2500 16r2502 16r250C 16r2510 16r2514 16r2518 16r251C 16r2524 16r252C 16r2534 16r253C 16r2580 16r2584 16r2588 16r258C 16r2590 16r2591 16r2592 16r2593 16r2320 16r25A0 16r2219 16r221A 16r2248 16r2264 16r2265 16r00A0 16r2321 16r00B0 16r00B2 16r00B7 16r00F7 16r2550 16r2551 16r2552 16r0451 16r2553 16r2554 16r2555 16r2556 16r2557 16r2558 16r2559 16r255A 16r255B 16r255C 16r255D 16r255E 16r255F 16r2560 16r2561 16r0401 16r2562 16r2563 16r2564 16r2565 16r2566 16r2567 16r2568 16r2569 16r256A 16r256B 16r256C 16r00A9 16r044E 16r0430 16r0431 16r0446 16r0434 16r0435 16r0444 16r0433 16r0445 16r0438 16r0439 16r043A 16r043B 16r043C 16r043D 16r043E 16r043F 16r044F 16r0440 16r0441 16r0442 16r0443 16r0436 16r0432 16r044C 16r044B 16r0437 16r0448 16r044D 16r0449 16r0447 16r044A 16r042E 16r0410 16r0411 16r0426 16r0414 16r0415 16r0424 16r0413 16r0425 16r0418 16r0419 16r041A 16r041B 16r041C 16r041D 16r041E 16r041F 16r042F 16r0420 16r0421 16r0422 16r0423 16r0416 16r0412 16r042C 16r042B 16r0417 16r0428 16r042D 16r0429 16r0427 16r042A )! ! !KSX1001 commentStamp: 'yo 10/19/2004 19:53'! This class represents the domestic character encoding called KS X 1001 used for Korean.! !KSX1001 class methodsFor: 'character classification' stamp: 'yo 8/6/2003 05:30'! isLetter: char | value leading | leading := char leadingChar. value := char charCode. leading = 0 ifTrue: [^ super isLetter: char]. value := value // 94 + 1. ^ 1 <= value and: [value < 84]. ! ! !KSX1001 class methodsFor: 'class methods' stamp: 'StephaneDucasse 8/22/2013 14:31'! initialize "KSX1001 initialize" EncodedCharSet declareEncodedCharSet: self atIndex: 3+1. EncodedCharSet declareEncodedCharSet: self atIndex: 12+1. compoundTextSequence := String streamContents: [ :stream | stream nextPut: Character escape. stream nextPut: $$. stream nextPut: $(. stream nextPut: $C ]! ! !KSX1001 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! compoundTextSequence ^ compoundTextSequence! ! !KSX1001 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state | c1 c2 | state charSize: 2. state g0Leading ~= self leadingChar ifTrue: [ state g0Leading: self leadingChar. state g0Size: 2. aStream basicNextPutAll: compoundTextSequence ]. c1 := ascii // 94 + 33. c2 := ascii \\ 94 + 33. ^ aStream basicNextPut: (Character value: c1); basicNextPut: (Character value: c2)! ! !KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:49'! leadingChar ^ 3. ! ! !KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! ucsTable ^ UCSTable ksx1001Table. ! ! !KernelClassesFilter commentStamp: 'TorstenBergmann 1/31/2014 11:30'! A filter for kernel classes! !KernelClassesFilter methodsFor: 'private' stamp: 'AndreiChis 9/30/2013 10:53'! kernelClassesToExclude ^ {Boolean. True. False. BlockClosure. MethodContext. Array. OrderedCollection. Set. IdentitySet. Dictionary. IdentityDictionary. Class. Metaclass. Behavior. SmallInteger. Float. Error. Exception. UndefinedObject. MessageSend}! ! !KernelClassesFilter methodsFor: 'initialization' stamp: 'AndreiChis 9/30/2013 14:00'! initialize super initialize. kernelClasses := self kernelClassesToExclude asOrderedCollection. kernelClasses := kernelClasses addAll: (kernelClasses collect: #class); yourself ! ! !KernelClassesFilter methodsFor: 'testing' stamp: 'AndreiChis 9/30/2013 11:12'! shouldDisplay: aContext ^ (kernelClasses includes: aContext receiver class) not! ! !Key commentStamp: ''! I represent a keyboard Key. I am mapped from the platform specific keycodes into a common keycode base, by using my class side methods.! !Key methodsFor: 'initialize-release' stamp: 'GuillermoPolito 5/4/2013 20:02'! withValue: aValue self withValue: aValue andName: self class unknownKeyName! ! !Key methodsFor: 'testing' stamp: 'GuillermoPolito 5/4/2013 20:03'! isUnkownKey ^self name == self class unknownKeyName! ! !Key methodsFor: 'initialize-release' stamp: 'GuillermoPolito 4/10/2013 16:18'! withValue: aValue andName: aName value := aValue. name := aName! ! !Key methodsFor: 'printing' stamp: 'GuillermoPolito 5/4/2013 20:04'! printOn: aStream aStream nextPutAll: 'Key '; nextPutAll: name; nextPutAll: ' code: ('; nextPutAll: value asString; nextPutAll: ')'.! ! !Key methodsFor: 'accessing' stamp: 'GuillermoPolito 4/10/2013 16:18'! name ^name! ! !Key class methodsFor: 'key table' stamp: 'GuillermoPolito 4/12/2013 19:57'! initializeKeyTable KeyTable := Dictionary new. #( 16r08f6 Function "XK_function" 16rff08 BackSpace "XK_BackSpace" 16rff09 Tab "XK_Tab" 16rff0a Linefeed "XK_Linefeed" 16rff0b Clear "XK_Clear" 16rff0d Return "XK_Return" 16rff13 Pause "XK_Pause" 16rff14 Scroll_Lock "XK_Scroll_Lock" 16rff15 Sys_Req "XK_Sys_Req" 16rff1b Escape "XK_Escape" 16rffff Delete "XK_Delete" 16rff50 Home "XK_Home" 16rff51 Left "XK_Left" 16rff52 Up "XK_Up" 16rff53 Right "XK_Right" 16rff54 Down "XK_Down" 16rfe03 Level3Shift "XK_ISO_Level3_Shift" 16r00a1 ExclamationDown "XK_exclamdown" 16r00bf QuestionDown "XK_questiondown" 16r00f1 NTilde "XK_ntilde" 16r00d1 CapitalNTilde "XK_ntilde" 16r00ba Masculine "XK_masculine" 16r00e7 CCedilla "XK_ccedilla" 16r00c7 CapitalCCedilla "XK_ccedilla" 16r00aa FeminineOrdinal "XK_ordfeminine" 16r00b7 MiddlePoint "XK_periodcentered" "16rff55 Prior ""XK_Prior" 16rff55 Page_Up "XK_Page_Up" "16rff56 Next" "XK_Next" 16rff56 Page_Down "XK_Page_Down" 16rff57 End "XK_End" 16rff58 Begin "XK_Begin" 16rff80 KP_Space "XK_KP_Space" 16rff89 KP_Tab "XK_KP_Tab" 16rff8d KP_Enter "XK_KP_Enter" 16rff91 KP_F1 "XK_KP_F1" 16rff92 KP_F2 "XK_KP_F2" 16rff93 KP_F3 "XK_KP_F3" 16rff94 KP_F4 "XK_KP_F4" 16rff95 KP_Home "XK_KP_Home" 16rff96 KP_Left "XK_KP_Left" 16rff97 KP_Up "XK_KP_Up" 16rff98 KP_Right "XK_KP_Right" 16rff99 KP_Down "XK_KP_Down" 16rff9a KP_Prior "XK_KP_Prior" 16rff9a KP_Page_Up "XK_KP_Page_Up" 16rff9b KP_Next "XK_KP_Next" 16rff9b KP_Page_Down "XK_KP_Page_Down" 16rff9c KP_End "XK_KP_End" 16rff9d KP_Begin "XK_KP_Begin" 16rff9e KP_Insert "XK_KP_Insert" 16rff9f KP_Delete "XK_KP_Delete" 16rffbd KP_Equal "XK_KP_Equal" 16rffaa KP_Multiply "XK_KP_Multiply" 16rffab KP_Add "XK_KP_Add" 16rffac KP_Separator "XK_KP_Separator" 16rffad KP_Subtract "XK_KP_Subtract" 16rffae KP_Decimal "XK_KP_Decimal" 16rffaf KP_Divide "XK_KP_Divide" 16rffb0 KP_0 "XK_KP_0" 16rffb1 KP_1 "XK_KP_1" 16rffb2 KP_2 "XK_KP_2" 16rffb3 KP_3 "XK_KP_3" 16rffb4 KP_4 "XK_KP_4" 16rffb5 KP_5 "XK_KP_5" 16rffb6 KP_6 "XK_KP_6" 16rffb7 KP_7 "XK_KP_7" 16rffb8 KP_8 "XK_KP_8" 16rffb9 KP_9 "XK_KP_9" 16rffbe F1 "XK_F1" 16rffbf F2 "XK_F2" 16rffc0 F3 "XK_F3" 16rffc1 F4 "XK_F4" 16rffc2 F5 "XK_F5" 16rffc3 F6 "XK_F6" 16rffc4 F7 "XK_F7" 16rffc5 F8 "XK_F8" 16rffc6 F9 "XK_F9" 16rffc7 F10 "XK_F10" 16rffc8 F11 "XK_F11" 16rffc9 F12 "XK_F12" 16rffe1 Shift_L "XK_Shift_L" 16rffe2 Shift_R "XK_Shift_R" 16rffe3 Control_L "XK_Control_L" 16rffe4 Control_R "XK_Control_R" 16rffe5 Caps_Lock "XK_Caps_Lock" 16rffe6 Shift_Lock "XK_Shift_Lock" 16rffe7 Meta_L "XK_Meta_L" 16rffe8 Meta_R "XK_Meta_R" 16rffe9 Alt_L "XK_Alt_L" 16rffea Alt_R "XK_Alt_R" 16rffeb Super_L "XK_Super_L" 16rffec Super_R "XK_Super_R" 16rffed Hyper_L "XK_Hyper_L" 16rffee Hyper_R "XK_Hyper_R" 16rfe50 dead_grave "XK_dead_grave" 16rfe51 dead_acute "XK_dead_acute" 16rfe52 dead_circumflex "XK_dead_circumflex" 16rfe53 dead_tilde "XK_dead_tilde" 16rfe53 dead_perispomeni "XK_dead_perispomeni" 16rfe54 dead_macron "XK_dead_macron" 16rfe55 dead_breve "XK_dead_breve" 16rfe56 dead_abovedot "XK_dead_abovedot" 16rfe57 dead_diaeresis "XK_dead_diaeresis" 16rfe58 dead_abovering "XK_dead_abovering" 16rfe59 dead_doubleacute "XK_dead_doubleacute" 16rfe5a dead_caron "XK_dead_caron" 16rfe5b dead_cedilla "XK_dead_cedilla" 16rfe5c dead_ogonek "XK_dead_ogonek" 16rfe5d dead_iota "XK_dead_iota" 16rfe5e dead_voiced_sound "XK_dead_voiced_sound" 16rfe5f dead_semivoiced_sound "XK_dead_semivoiced_sound" 16rfe60 dead_belowdot "XK_dead_belowdot" 16rfe61 dead_hook "XK_dead_hook" 16rfe62 dead_horn "XK_dead_horn" 16rfe63 dead_stroke "XK_dead_stroke" 16rfe64 dead_abovecomma "XK_dead_abovecomma" 16rfe64 dead_psili "XK_dead_psili" 16rfe65 dead_abovereversedcomma "XK_dead_abovereversedcomma" 16rfe65 dead_dasia "XK_dead_dasia" 16rfe66 dead_doublegrave "XK_dead_doublegrave" 16rfe67 dead_belowring "XK_dead_belowring" 16rfe68 dead_belowmacron "XK_dead_belowmacron" 16rfe69 dead_belowcircumflex "XK_dead_belowcircumflex" 16rfe6a dead_belowtilde "XK_dead_belowtilde" 16rfe6b dead_belowbreve "XK_dead_belowbreve" 16rfe6c dead_belowdiaeresis "XK_dead_belowdiaeresis" 16rfe6d dead_invertedbreve "XK_dead_invertedbreve" 16rfe6e dead_belowcomma "XK_dead_belowcomma" 16rfe6f dead_currency "XK_dead_currency" 16r0020 space "XK_space" 16r0021 exclam "XK_exclam" 16r0022 quotedbl "XK_quotedbl" 16r0023 numbersign "XK_numbersign" 16r0024 dollar "XK_dollar" 16r0025 percent "XK_percent" 16r0026 ampersand "XK_ampersand" 16r0027 apostrophe "XK_apostrophe" "16r0027 quoteright" "XK_quoteright" 16r0028 parenleft "XK_parenleft" 16r0029 parenright "XK_parenright" 16r002a asterisk "XK_asterisk" 16r002b plus "XK_plus" 16r002c comma "XK_comma" 16r002d minus "XK_minus" 16r002e period "XK_period" 16r002f slash "XK_slash" 16r0030 zero "XK_0" 16r0031 one "XK_1" 16r0032 two "XK_2" 16r0033 three "XK_3" 16r0034 four "XK_4" 16r0035 five "XK_5" 16r0036 six "XK_6" 16r0037 seven "XK_7" 16r0038 eight "XK_8" 16r0039 nine "XK_9" 16r003a colon "XK_colon" 16r003b semicolon "XK_semicolon" 16r003c less "XK_less" 16r003d equal "XK_equal" 16r003e greater "XK_greater" 16r003f question "XK_question" 16r0040 at "XK_at" 16r0041 A "XK_A" 16r0042 B "XK_B" 16r0043 C "XK_C" 16r0044 D "XK_D" 16r0045 E "XK_E" 16r0046 F "XK_F" 16r0047 G "XK_G" 16r0048 H "XK_H" 16r0049 I "XK_I" 16r004a J "XK_J" 16r004b K "XK_K" 16r004c L "XK_L" 16r004d M "XK_M" 16r004e N "XK_N" 16r004f O "XK_O" 16r0050 P "XK_P" 16r0051 Q "XK_Q" 16r0052 R "XK_R" 16r0053 S "XK_S" 16r0054 T "XK_T" 16r0055 U "XK_U" 16r0056 V "XK_V" 16r0057 W "XK_W" 16r0058 X "XK_X" 16r0059 Y "XK_Y" 16r005a Z "XK_Z" 16r005b bracketleft "XK_bracketleft" 16r005c backslash "XK_backslash" 16r005d bracketright "XK_bracketright" 16r005e asciicircum "XK_asciicircum" 16r005f underscore "XK_underscore" 16r0060 grave "XK_grave" "16r0060 quoteleft" "XK_quoteleft" 16r0061 a "XK_a" 16r0062 b "XK_b" 16r0063 c "XK_c" 16r0064 d "XK_d" 16r0065 e "XK_e" 16r0066 f "XK_f" 16r0067 g "XK_g" 16r0068 h "XK_h" 16r0069 i "XK_i" 16r006a j "XK_j" 16r006b k "XK_k" 16r006c l "XK_l" 16r006d m "XK_m" 16r006e n "XK_n" 16r006f o "XK_o" 16r0070 p "XK_p" 16r0071 q "XK_q" 16r0072 r "XK_r" 16r0073 s "XK_s" 16r0074 t "XK_t" 16r0075 u "XK_u" 16r0076 v "XK_v" 16r0077 w "XK_w" 16r0078 x "XK_x" 16r0079 y "XK_y" 16r007a z "XK_z" 16r007b braceleft "XK_braceleft" 16r007c bar "XK_bar" 16r007d braceright "XK_braceright" 16r007e asciitilde "XK_asciitilde") pairsDo: [ :keyCode :keyname | KeyTable at: keyCode put: (self basicNew withValue: keyCode andName: keyname asUppercase) ].! ! !Key class methodsFor: 'unix' stamp: 'GuillermoPolito 4/12/2013 16:29'! initializeUnixVirtualKeyTable UnixVirtualKeyTable := Dictionary new. UnixVirtualKeyTable at: Character cr asciiValue put: (self value: 16rff0d); " kVK_Return = 0x24" at: Character tab asciiValue put: (self value: 16rff09); " kVK_Tab = 0x30" at: Character space asciiValue put: (self value: 16rff80); " kVK_Space = 0x31" at: Character delete asciiValue put: (self value: 16rffff); " kVK_Delete = 0x33" at: Character escape asciiValue put: (self value: 16rff1b); " kVK_Escape = 0x35" at: 8 put: (self value: 16rff08); " kVK_Command = 0x37" at: -1 put: (self value: 16rffe7); " kVK_Command = 0x37" at: 255 put: (self value: 16rffe1); " kVK_Shift = 0x38" at: -1 put: (self value: 16rffe5); " kVK_CapsLock = 0x39" at: 247 put: (self value: 16rffe9); " kVK_Option = 0x3A" at: 251 put: (self value: 16rffe3); " kVK_Control = 0x3B" at: 254 put: (self value: 16rffe2); " kVK_RightShift = 0x3C" at: -1 put: (self value: 16rffea); " kVK_RightOption = 0x3D" at: -1 put: (self value: 16rffe4); " kVK_RightControl = 0x3E" at: -1 put: (self value: 16r08f6); " kVK_Function = 0x3F" at: -1 put: (self value: 16r48); " kVK_VolumeUp = 0x48" "Not mapped" at: -1 put: (self value: 16r49); " kVK_VolumeDown = 0x49" "Not mapped" at: -1 put: (self value: 16r4A); " kVK_Mute = 0x4A" "Not mapped" at: -1 put: (self value: 16rffbe); " kVK_F1 = 0x7A" at: -1 put: (self value: 16rffbf); " kVK_F2 = 0x78" at: -1 put: (self value: 16rffc0); " kVK_F3 = 0x63" at: -1 put: (self value: 16rffc1); " kVK_F4 = 0x76" at: -1 put: (self value: 16rffc2); " kVK_F5 = 0x60" at: -1 put: (self value: 16rffc3); " kVK_F6 = 0x61" at: -1 put: (self value: 16rffc4); " kVK_F7 = 0x62" at: -1 put: (self value: 16rffc5); " kVK_F8 = 0x64" at: -1 put: (self value: 16rffc6); " kVK_F9 = 0x65" at: -1 put: (self value: 16rffc8); " kVK_F11 = 0x67" at: -1 put: (self value: 16rffc7); " kVK_F10 = 0x6D" at: -1 put: (self value: 16rffc9); " kVK_F12 = 0x6F" at: -1 put: (self value: 16r72); " kVK_Help = 0x72" "Not mapped" at: Character home asciiValue put: (self value: 16rff50); " kVK_Home = 0x73" at: Character pageUp asciiValue put: (self value: 16rff55); " kVK_PageUp = 0x74" at: Character delete asciiValue put: (self value: 16rffff); " kVK_ForwardDelete = 0x75" at: Character end asciiValue put: (self value: 16rff57); " kVK_End = 0x77" at: Character pageDown asciiValue put: (self value: 16rff56); " kVK_PageDown = 0x79" at: Character arrowLeft asciiValue put: (self value: 16rff96); " kVK_LeftArrow = 0x7B" at: Character arrowRight asciiValue put: (self value: 16rff98); " kVK_RightArrow = 0x7C" at: Character arrowDown asciiValue put: (self value: 16rff99); " kVK_DownArrow = 0x7D" at: Character arrowUp asciiValue put: (self value: 16rff97); " kVK_UpArrow = 0x7E" at: $a asciiValue put: (self value: 16r41); "kVK_ANSI_A = 0x00" at: $b asciiValue put: (self value: 16r42); " kVK_ANSI_B = 0x0B" at: $c asciiValue put: (self value: 16r43); " kVK_ANSI_C = 0x08" at: $d asciiValue put: (self value: 16r44); " kVK_ANSI_D = 0x02" at: $e asciiValue put: (self value: 16r45); " kVK_ANSI_E = 0x0E" at: $f asciiValue put: (self value: 16r46); " kVK_ANSI_F = 0x03" at: $g asciiValue put: (self value: 16r47); " kVK_ANSI_G = 0x05" at: $h asciiValue put: (self value: 16r48); " kVK_ANSI_H = 0x04" at: $i asciiValue put: (self value: 16r49); " kVK_ANSI_I = 0x22" at: $j asciiValue put: (self value: 16r4a); " kVK_ANSI_J = 0x26" at: $k asciiValue put: (self value: 16r4b); " kVK_ANSI_K = 0x28" at: $l asciiValue put: (self value: 16r4c); " kVK_ANSI_L = 0x25" at: $m asciiValue put: (self value: 16r4d); " kVK_ANSI_M = 0x2E" at: $n asciiValue put: (self value: 16r4e); " kVK_ANSI_N = 0x2D" at: $o asciiValue put: (self value: 16r4f); " kVK_ANSI_O = 0x1F" at: $p asciiValue put: (self value: 16r50); " kVK_ANSI_P = 0x23" at: $q asciiValue put: (self value: 16r51); " kVK_ANSI_Q = 0x0C" at: $r asciiValue put: (self value: 16r52); " kVK_ANSI_R = 0x0F" at: $s asciiValue put: (self value: 16r53); " kVK_ANSI_S = 0x01" at: $t asciiValue put: (self value: 16r54); " kVK_ANSI_T = 0x11" at: $u asciiValue put: (self value: 16r55); " kVK_ANSI_U = 0x20" at: $v asciiValue put: (self value: 16r56); " kVK_ANSI_V = 0x09" at: $w asciiValue put: (self value: 16r57); " kVK_ANSI_W = 0x0D" at: $x asciiValue put: (self value: 16r58); " kVK_ANSI_X = 0x07" at: $y asciiValue put: (self value: 16r59); " kVK_ANSI_Y = 0x10" at: $z asciiValue put: (self value: 16r5a); " kVK_ANSI_Z = 0x06" at: $0 asciiValue put: (self value: 16r30); " kVK_ANSI_0 = 0x1D" at: $1 asciiValue put: (self value: 16r31); " kVK_ANSI_1 = 0x12" at: $2 asciiValue put: (self value: 16r32); " kVK_ANSI_2 = 0x13" at: $3 asciiValue put: (self value: 16r33); " kVK_ANSI_3 = 0x14" at: $4 asciiValue put: (self value: 16r34); " kVK_ANSI_4 = 0x15" at: $5 asciiValue put: (self value: 16r35); " kVK_ANSI_5 = 0x17" at: $6 asciiValue put: (self value: 16r36); " kVK_ANSI_6 = 0x16" at: $7 asciiValue put: (self value: 16r37); " kVK_ANSI_7 = 0x1A" at: $8 asciiValue put: (self value: 16r38); " kVK_ANSI_8 = 0x1C" at: $9 asciiValue put: (self value: 16r39); " kVK_ANSI_9 = 0x19" at: $- asciiValue put: (self value: 16r2d); " kVK_ANSI_Minus = 0x1B" at: $= asciiValue put: (self value: 16r3d); " kVK_ANSI_Equal = 0x18" at: $[ asciiValue put: (self value: 16r5b); " kVK_ANSI_LeftBracket = 0x21" at: $] asciiValue put: (self value: 16r5d); " kVK_ANSI_RightBracket = 0x1E" at: $' asciiValue put: (self value: 16r27); " kVK_ANSI_Quote = 0x27" at: $; asciiValue put: (self value: 16r3b); " kVK_ANSI_Semicolon = 0x29" at: $/ asciiValue put: (self value: 16r5c); " kVK_ANSI_Backslash = 0x2A" at: $, asciiValue put: (self value: 16r2c); " kVK_ANSI_Comma = 0x2B" at: $\ asciiValue put: (self value: 16r2f); " kVK_ANSI_Slash = 0x2C" at: $. asciiValue put: (self value: 16r2e); " kVK_ANSI_Period = 0x2F" at: $` asciiValue put: (self value: 16r60); " kVK_ANSI_Grave = 0x32" at: 1 put: (self value: 16rffae); " kVK_ANSI_KeypadDecimal = 0x41" at: 1 put: (self value: 16rffaa); " kVK_ANSI_KeypadMultiply = 0x43" at: 1 put: (self value: 16rffab); " kVK_ANSI_KeypadPlus = 0x45" at: 1 put: (self value: 16r47); " kVK_ANSI_KeypadClear = 0x47" "Not mapped" at: 1 put: (self value: 16rffaf); " kVK_ANSI_KeypadDivide = 0x4B" at: 1 put: (self value: 16rff8d); " kVK_ANSI_KeypadEnter = 0x4C" at: 1 put: (self value: 16rffad); " kVK_ANSI_KeypadMinus = 0x4E" at: 1 put: (self value: 16rffbd); " kVK_ANSI_KeypadEquals = 0x51" at: 1 put: (self value: 16rffb0); " kVK_ANSI_Keypad0 = 0x52" at: 1 put: (self value: 16rffb1); " kVK_ANSI_Keypad1 = 0x53" at: 1 put: (self value: 16rffb2); " kVK_ANSI_Keypad2 = 0x54" at: 1 put: (self value: 16rffb3); " kVK_ANSI_Keypad3 = 0x55" at: 1 put: (self value: 16rffb4); " kVK_ANSI_Keypad4 = 0x56" at: 1 put: (self value: 16rffb5); " kVK_ANSI_Keypad5 = 0x57" at: 1 put: (self value: 16rffb6); " kVK_ANSI_Keypad6 = 0x58" at: 1 put: (self value: 16rffb7); " kVK_ANSI_Keypad7 = 0x59" at: 1 put: (self value: 16rffb8); " kVK_ANSI_Keypad8 = 0x5B" at: 1 put: (self value: 16rffb9) " kVK_ANSI_Keypad9 = 0x5C"! ! !Key class methodsFor: 'unix' stamp: 'GuillermoPolito 4/12/2013 17:45'! unixVirtualKeyTable ^KeyTable! ! !Key class methodsFor: 'windows' stamp: 'GuillermoPolito 5/4/2013 12:58'! initializeWindowsVirtualKeyTable WindowsVirtualKeyTable := Dictionary new. WindowsVirtualKeyTable at: 16r0d put: (self value: 16rff0d); " kVK_Return = 0x24" at: 16r09 put: (self value: 16rff09); " kVK_Tab = 0x30" at: 16r20 put: (self value: 16rff80); " kVK_Space = 0x31" at: 16r2e put: (self value: 16rffff); " kVK_Delete = 0x33" at: 16r1b put: (self value: 16rff1b); " kVK_Escape = 0x35" at: 16r5B put: (self value: 16rff08); " kVK_Command = 0x37" at: 16r5c put: (self value: 16rffe7); " kVK_Command = 0x37" at: 16r10 put: (self value: 16rffe1); " kVK_Shift = 0x38" at: 16r14 put: (self value: 16rffe5); " kVK_CapsLock = 0x39" at: 16r12 put: (self value: 16rffe9); " kVK_Option = 0x3A" at: 16r11 put: (self value: 16rffe3); " kVK_Control = 0x3B" at: 16ra0 put: (self value: 16rffe2); " kVK_RightShift = 0x3C" at: 16ra5 put: (self value: 16rffea); " kVK_RightOption = 0x3D" at: 16ra3 put: (self value: 16rffe4); " kVK_RightControl = 0x3E" at: -1 put: (self value: 16r08f6); " kVK_Function = 0x3F" at: 16raf put: (self value: 16r48); " kVK_VolumeUp = 0x48" "Not mapped" at: 16rae put: (self value: 16r49); " kVK_VolumeDown = 0x49" "Not mapped" at: 16rad put: (self value: 16r4A); " kVK_Mute = 0x4A" "Not mapped" at: 16r70 put: (self value: 16rffbe); " kVK_F1 = 0x7A" at: 16r71 put: (self value: 16rffbf); " kVK_F2 = 0x78" at: 16r72 put: (self value: 16rffc0); " kVK_F3 = 0x63" at: 16r73 put: (self value: 16rffc1); " kVK_F4 = 0x76" at: 16r74 put: (self value: 16rffc2); " kVK_F5 = 0x60" at: 16r75 put: (self value: 16rffc3); " kVK_F6 = 0x61" at: 16r76 put: (self value: 16rffc4); " kVK_F7 = 0x62" at: 16r77 put: (self value: 16rffc5); " kVK_F8 = 0x64" at: 16r78 put: (self value: 16rffc6); " kVK_F9 = 0x65" at: 16r79 put: (self value: 16rffc8); " kVK_F11 = 0x67" at: 16r7a put: (self value: 16rffc7); " kVK_F10 = 0x6D" at: 16r7b put: (self value: 16rffc9); " kVK_F12 = 0x6F" at: 16r2f put: (self value: 16r72); " kVK_Help = 0x72" "Not mapped" at: 16r24 put: (self value: 16rff50); " kVK_Home = 0x73" at: 16r21 put: (self value: 16rff55); " kVK_PageUp = 0x74" at: 16r2e put: (self value: 16rffff); " kVK_ForwardDelete = 0x75" at: 16r23 put: (self value: 16rff57); " kVK_End = 0x77" at: 16r22 put: (self value: 16rff56); " kVK_PageDown = 0x79" at: 16r1c put: (self value: 16rff96); " kVK_LeftArrow = 0x7B" at: 16r1d put: (self value: 16rff98); " kVK_RightArrow = 0x7C" at: 16r1f put: (self value: 16rff99); " kVK_DownArrow = 0x7D" at: 16r1e put: (self value: 16rff97); " kVK_UpArrow = 0x7E" at: 16r41 put: (self value: 16r41); "kVK_ANSI_A = 0x00" at: 16r42 put: (self value: 16r42); " kVK_ANSI_B = 0x0B" at: 16r43 put: (self value: 16r43); " kVK_ANSI_C = 0x08" at: 16r44 put: (self value: 16r44); " kVK_ANSI_D = 0x02" at: 16r45 put: (self value: 16r45); " kVK_ANSI_E = 0x0E" at: 16r46 put: (self value: 16r46); " kVK_ANSI_F = 0x03" at: 16r47 put: (self value: 16r47); " kVK_ANSI_G = 0x05" at: 16r48 put: (self value: 16r48); " kVK_ANSI_H = 0x04" at: 16r49 put: (self value: 16r49); " kVK_ANSI_I = 0x22" at: 16r4a put: (self value: 16r4a); " kVK_ANSI_J = 0x26" at: 16r4b put: (self value: 16r4b); " kVK_ANSI_K = 0x28" at: 16r4c put: (self value: 16r4c); " kVK_ANSI_L = 0x25" at: 16r4d put: (self value: 16r4d); " kVK_ANSI_M = 0x2E" at: 16r4e put: (self value: 16r4e); " kVK_ANSI_N = 0x2D" at: 16r4f put: (self value: 16r4f); " kVK_ANSI_O = 0x1F" at: 16r50 put: (self value: 16r50); " kVK_ANSI_P = 0x23" at: 16r51 put: (self value: 16r51); " kVK_ANSI_Q = 0x0C" at: 16r52 put: (self value: 16r52); " kVK_ANSI_R = 0x0F" at: 16r53 put: (self value: 16r53); " kVK_ANSI_S = 0x01" at: 16r54 put: (self value: 16r54); " kVK_ANSI_T = 0x11" at: 16r55 put: (self value: 16r55); " kVK_ANSI_U = 0x20" at: 16r56 put: (self value: 16r56); " kVK_ANSI_V = 0x09" at: 16r57 put: (self value: 16r57); " kVK_ANSI_W = 0x0D" at: 16r58 put: (self value: 16r58); " kVK_ANSI_X = 0x07" at: 16r59 put: (self value: 16r59); " kVK_ANSI_Y = 0x10" at: 16r5a put: (self value: 16r5a); " kVK_ANSI_Z = 0x06" at: $0 asciiValue put: (self value: 16r30); " kVK_ANSI_0 = 0x1D" at: $1 asciiValue put: (self value: 16r31); " kVK_ANSI_1 = 0x12" at: $2 asciiValue put: (self value: 16r32); " kVK_ANSI_2 = 0x13" at: $3 asciiValue put: (self value: 16r33); " kVK_ANSI_3 = 0x14" at: $4 asciiValue put: (self value: 16r34); " kVK_ANSI_4 = 0x15" at: $5 asciiValue put: (self value: 16r35); " kVK_ANSI_5 = 0x17" at: $6 asciiValue put: (self value: 16r36); " kVK_ANSI_6 = 0x16" at: $7 asciiValue put: (self value: 16r37); " kVK_ANSI_7 = 0x1A" at: $8 asciiValue put: (self value: 16r38); " kVK_ANSI_8 = 0x1C" at: $9 asciiValue put: (self value: 16r39); " kVK_ANSI_9 = 0x19" at: 16rbd put: (self value: 16r2d); " kVK_ANSI_Minus = 0x1B" at: $= asciiValue put: (self value: 16r3d); " kVK_ANSI_Equal = 0x18" at: 16rdb put: (self value: 16r5b); " kVK_ANSI_LeftBracket = 0x21" at: 16rdd put: (self value: 16r5d); " kVK_ANSI_RightBracket = 0x1E" at: 1 put: (self value: 16r27); " kVK_ANSI_Quote = 0x27" at: 16rba put: (self value: 16r3b); " kVK_ANSI_Semicolon = 0x29" at: 16rbf put: (self value: 16r5c); " kVK_ANSI_Backslash = 0x2A" at: 16rbc put: (self value: 16r2c); " kVK_ANSI_Comma = 0x2B" at: 16rdc put: (self value: 16r2f); " kVK_ANSI_Slash = 0x2C" at: 16rbe put: (self value: 16r2e); " kVK_ANSI_Period = 0x2F" at: 16rc0 put: (self value: 16r60); " kVK_ANSI_Grave = 0x32" at: 16r6e put: (self value: 16rffae); " kVK_ANSI_KeypadDecimal = 0x41" at: 16r6a put: (self value: 16rffaa); " kVK_ANSI_KeypadMultiply = 0x43" at: 16r6b put: (self value: 16rffab); " kVK_ANSI_KeypadPlus = 0x45" at: 16r0c put: (self value: 16r47); " kVK_ANSI_KeypadClear = 0x47" "Not mapped" at: 16r6f put: (self value: 16rffaf); " kVK_ANSI_KeypadDivide = 0x4B" at: 16r0d put: (self value: 16rff8d); " kVK_ANSI_KeypadEnter = 0x4C" at: 16r6d put: (self value: 16rffad); " kVK_ANSI_KeypadMinus = 0x4E" at: 1 put: (self value: 16rffbd); " kVK_ANSI_KeypadEquals = 0x51" at: 16r60 put: (self value: 16rffb0); " kVK_ANSI_Keypad0 = 0x52" at: 16r61 put: (self value: 16rffb1); " kVK_ANSI_Keypad1 = 0x53" at: 16r62 put: (self value: 16rffb2); " kVK_ANSI_Keypad2 = 0x54" at: 16r63 put: (self value: 16rffb3); " kVK_ANSI_Keypad3 = 0x55" at: 16r64 put: (self value: 16rffb4); " kVK_ANSI_Keypad4 = 0x56" at: 16r65 put: (self value: 16rffb5); " kVK_ANSI_Keypad5 = 0x57" at: 16r66 put: (self value: 16rffb6); " kVK_ANSI_Keypad6 = 0x58" at: 16r67 put: (self value: 16rffb7); " kVK_ANSI_Keypad7 = 0x59" at: 16r68 put: (self value: 16rffb8); " kVK_ANSI_Keypad8 = 0x5B" at: 16r69 put: (self value: 16rffb9) " kVK_ANSI_Keypad9 = 0x5C"! ! !Key class methodsFor: 'unknownKeys' stamp: 'GuillermoPolito 5/4/2013 20:02'! unknownKeyName ^#Unknown! ! !Key class methodsFor: 'class initialization' stamp: 'GuillermoPolito 5/4/2013 12:53'! initialize self initializeKeyTable; initializeMacOSVirtualKeyTable; initializeUnixVirtualKeyTable; initializeWindowsVirtualKeyTable! ! !Key class methodsFor: 'instance creation' stamp: 'GuillermoPolito 4/10/2013 16:19'! value: aKeyValue ^KeyTable at: aKeyValue! ! !Key class methodsFor: 'macos' stamp: 'GuillermoPolito 4/10/2013 17:17'! initializeMacOSVirtualKeyTable MacosVirtualKeyTable := Dictionary new. MacosVirtualKeyTable at: 16r24 put: (self value: 16rff0d); " kVK_Return = 0x24" at: 16r30 put: (self value: 16rff09); " kVK_Tab = 0x30" at: 16r31 put: (self value: 16rff80); " kVK_Space = 0x31" at: 16r33 put: (self value: 16rffff); " kVK_Delete = 0x33" at: 16r35 put: (self value: 16rff1b); " kVK_Escape = 0x35" at: 16r37 put: (self value: 16rffe7); " kVK_Command = 0x37" at: 16r38 put: (self value: 16rffe1); " kVK_Shift = 0x38" at: 16r39 put: (self value: 16rffe5); " kVK_CapsLock = 0x39" at: 16r3A put: (self value: 16rffe9); " kVK_Option = 0x3A" at: 16r3B put: (self value: 16rffe3); " kVK_Control = 0x3B" at: 16r3C put: (self value: 16rffe2); " kVK_RightShift = 0x3C" at: 16r3D put: (self value: 16rffea); " kVK_RightOption = 0x3D" at: 16r3E put: (self value: 16rffe4); " kVK_RightControl = 0x3E" at: 16r3F put: (self value: 16r08f6); " kVK_Function = 0x3F" at: 16r48 put: (self value: 16r48); " kVK_VolumeUp = 0x48" "Not mapped" at: 16r49 put: (self value: 16r49); " kVK_VolumeDown = 0x49" "Not mapped" at: 16r4A put: (self value: 16r4A); " kVK_Mute = 0x4A" "Not mapped" at: 16r7A put: (self value: 16rffbe); " kVK_F1 = 0x7A" at: 16r78 put: (self value: 16rffbf); " kVK_F2 = 0x78" at: 16r63 put: (self value: 16rffc0); " kVK_F3 = 0x63" at: 16r76 put: (self value: 16rffc1); " kVK_F4 = 0x76" at: 16r60 put: (self value: 16rffc2); " kVK_F5 = 0x60" at: 16r61 put: (self value: 16rffc3); " kVK_F6 = 0x61" at: 16r62 put: (self value: 16rffc4); " kVK_F7 = 0x62" at: 16r64 put: (self value: 16rffc5); " kVK_F8 = 0x64" at: 16r65 put: (self value: 16rffc6); " kVK_F9 = 0x65" at: 16r67 put: (self value: 16rffc8); " kVK_F11 = 0x67" at: 16r6D put: (self value: 16rffc7); " kVK_F10 = 0x6D" at: 16r6F put: (self value: 16rffc9); " kVK_F12 = 0x6F" at: 16r72 put: (self value: 16r72); " kVK_Help = 0x72" "Not mapped" at: 16r73 put: (self value: 16rff50); " kVK_Home = 0x73" at: 16r74 put: (self value: 16rff55); " kVK_PageUp = 0x74" at: 16r75 put: (self value: 16rffff); " kVK_ForwardDelete = 0x75" at: 16r77 put: (self value: 16rff57); " kVK_End = 0x77" at: 16r79 put: (self value: 16rff56); " kVK_PageDown = 0x79" at: 16r7B put: (self value: 16rff96); " kVK_LeftArrow = 0x7B" at: 16r7C put: (self value: 16rff98); " kVK_RightArrow = 0x7C" at: 16r7D put: (self value: 16rff99); " kVK_DownArrow = 0x7D" at: 16r7E put: (self value: 16rff97); " kVK_UpArrow = 0x7E" at: 16r00 put: (self value: 16r41); "kVK_ANSI_A = 0x00" at: 16r0B put: (self value: 16r42); " kVK_ANSI_B = 0x0B" at: 16r08 put: (self value: 16r43); " kVK_ANSI_C = 0x08" at: 16r02 put: (self value: 16r44); " kVK_ANSI_D = 0x02" at: 16r0E put: (self value: 16r45); " kVK_ANSI_E = 0x0E" at: 16r03 put: (self value: 16r46); " kVK_ANSI_F = 0x03" at: 16r05 put: (self value: 16r47); " kVK_ANSI_G = 0x05" at: 16r04 put: (self value: 16r48); " kVK_ANSI_H = 0x04" at: 16r22 put: (self value: 16r49); " kVK_ANSI_I = 0x22" at: 16r26 put: (self value: 16r4a); " kVK_ANSI_J = 0x26" at: 16r28 put: (self value: 16r4b); " kVK_ANSI_K = 0x28" at: 16r25 put: (self value: 16r4c); " kVK_ANSI_L = 0x25" at: 16r2E put: (self value: 16r4d); " kVK_ANSI_M = 0x2E" at: 16r2D put: (self value: 16r4e); " kVK_ANSI_N = 0x2D" at: 16r1F put: (self value: 16r4f); " kVK_ANSI_O = 0x1F" at: 16r23 put: (self value: 16r50); " kVK_ANSI_P = 0x23" at: 16r0C put: (self value: 16r51); " kVK_ANSI_Q = 0x0C" at: 16r0F put: (self value: 16r52); " kVK_ANSI_R = 0x0F" at: 16r01 put: (self value: 16r53); " kVK_ANSI_S = 0x01" at: 16r11 put: (self value: 16r54); " kVK_ANSI_T = 0x11" at: 16r20 put: (self value: 16r55); " kVK_ANSI_U = 0x20" at: 16r09 put: (self value: 16r56); " kVK_ANSI_V = 0x09" at: 16r0D put: (self value: 16r57); " kVK_ANSI_W = 0x0D" at: 16r07 put: (self value: 16r58); " kVK_ANSI_X = 0x07" at: 16r10 put: (self value: 16r59); " kVK_ANSI_Y = 0x10" at: 16r06 put: (self value: 16r5a); " kVK_ANSI_Z = 0x06" at: 16r1D put: (self value: 16r30); " kVK_ANSI_0 = 0x1D" at: 16r12 put: (self value: 16r31); " kVK_ANSI_1 = 0x12" at: 16r13 put: (self value: 16r32); " kVK_ANSI_2 = 0x13" at: 16r14 put: (self value: 16r33); " kVK_ANSI_3 = 0x14" at: 16r15 put: (self value: 16r34); " kVK_ANSI_4 = 0x15" at: 16r17 put: (self value: 16r35); " kVK_ANSI_5 = 0x17" at: 16r16 put: (self value: 16r36); " kVK_ANSI_6 = 0x16" at: 16r1A put: (self value: 16r37); " kVK_ANSI_7 = 0x1A" at: 16r1C put: (self value: 16r38); " kVK_ANSI_8 = 0x1C" at: 16r19 put: (self value: 16r39); " kVK_ANSI_9 = 0x19" at: 16r1B put: (self value: 16r2d); " kVK_ANSI_Minus = 0x1B" at: 16r18 put: (self value: 16r3d); " kVK_ANSI_Equal = 0x18" at: 16r21 put: (self value: 16r5b); " kVK_ANSI_LeftBracket = 0x21" at: 16r1E put: (self value: 16r5d); " kVK_ANSI_RightBracket = 0x1E" at: 16r27 put: (self value: 16r27); " kVK_ANSI_Quote = 0x27" at: 16r29 put: (self value: 16r3b); " kVK_ANSI_Semicolon = 0x29" at: 16r2A put: (self value: 16r5c); " kVK_ANSI_Backslash = 0x2A" at: 16r2B put: (self value: 16r2c); " kVK_ANSI_Comma = 0x2B" at: 16r2C put: (self value: 16r2f); " kVK_ANSI_Slash = 0x2C" at: 16r2F put: (self value: 16r2e); " kVK_ANSI_Period = 0x2F" at: 16r32 put: (self value: 16r60); " kVK_ANSI_Grave = 0x32" at: 16r41 put: (self value: 16rffae); " kVK_ANSI_KeypadDecimal = 0x41" at: 16r43 put: (self value: 16rffaa); " kVK_ANSI_KeypadMultiply = 0x43" at: 16r45 put: (self value: 16rffab); " kVK_ANSI_KeypadPlus = 0x45" at: 16r47 put: (self value: 16r47); " kVK_ANSI_KeypadClear = 0x47" "Not mapped" at: 16r4B put: (self value: 16rffaf); " kVK_ANSI_KeypadDivide = 0x4B" at: 16r4C put: (self value: 16rff8d); " kVK_ANSI_KeypadEnter = 0x4C" at: 16r4E put: (self value: 16rffad); " kVK_ANSI_KeypadMinus = 0x4E" at: 16r51 put: (self value: 16rffbd); " kVK_ANSI_KeypadEquals = 0x51" at: 16r52 put: (self value: 16rffb0); " kVK_ANSI_Keypad0 = 0x52" at: 16r53 put: (self value: 16rffb1); " kVK_ANSI_Keypad1 = 0x53" at: 16r54 put: (self value: 16rffb2); " kVK_ANSI_Keypad2 = 0x54" at: 16r55 put: (self value: 16rffb3); " kVK_ANSI_Keypad3 = 0x55" at: 16r56 put: (self value: 16rffb4); " kVK_ANSI_Keypad4 = 0x56" at: 16r57 put: (self value: 16rffb5); " kVK_ANSI_Keypad5 = 0x57" at: 16r58 put: (self value: 16rffb6); " kVK_ANSI_Keypad6 = 0x58" at: 16r59 put: (self value: 16rffb7); " kVK_ANSI_Keypad7 = 0x59" at: 16r5B put: (self value: 16rffb8); " kVK_ANSI_Keypad8 = 0x5B" at: 16r5C put: (self value: 16rffb9) " kVK_ANSI_Keypad9 = 0x5C"! ! !Key class methodsFor: 'macos' stamp: 'GuillermoPolito 4/10/2013 15:41'! macOSVirtualKeyTable MacosVirtualKeyTable ifNil: [ self initializeMacOSVirtualKeyTable. ]. ^MacosVirtualKeyTable! ! !Key class methodsFor: 'unix' stamp: 'GuillermoPolito 5/5/2013 12:06'! valueForUnixPlatform: aKeyValue ^self unixVirtualKeyTable at: aKeyValue ifAbsent: [ (self basicNew withValue: aKeyValue) ] ! ! !Key class methodsFor: 'macos' stamp: 'GuillermoPolito 5/5/2013 12:06'! valueForMacOSXPlatform: aKeyValue ^self macOSVirtualKeyTable at: aKeyValue ifAbsent: [ (self basicNew withValue: aKeyValue andName: #Unknown) ] ! ! !Key class methodsFor: 'windows' stamp: 'GuillermoPolito 5/4/2013 11:33'! valueForWindowsPlatform: aKeyCode ^self windowsVirtualKeyTable at: aKeyCode ifAbsent: [ (self basicNew withValue: aKeyCode andName: #Unknown) ] ! ! !Key class methodsFor: 'windows' stamp: 'GuillermoPolito 5/4/2013 11:33'! windowsVirtualKeyTable WindowsVirtualKeyTable ifNil: [ self initializeWindowsVirtualKeyTable. ]. ^WindowsVirtualKeyTable! ! !KeyChain commentStamp: ''! A KeyChain is a holder for username/password. It can be queried by the system to prevent the user to be forced to set his or her password each time. keys have this structure: |- group1 (by example squeaksource) -> (username -> password) |- group2 (by example smalltalkhub) -> (username -> password)! !KeyChain methodsFor: 'encryption' stamp: 'CamilloBruni 7/17/2013 23:40'! reEncryptKeysBased: aFormerBase groups associations do: [:assoc || oldUsernamePassword string | oldUsernamePassword := groups at: assoc key. string := encryptorDecryptor decrypt: oldUsernamePassword password base: aFormerBase. groups at: assoc key put: ( UsernamePassword username: oldUsernamePassword username password: (self encryptPassword: string) )]! ! !KeyChain methodsFor: 'protocol' stamp: 'MarcusDenker 10/10/2013 14:02'! setPassword: aPassword | oldPassword | (password isNil or: [ self isUnlocked ]) ifFalse: [ ^ self ]. oldPassword := password. aPassword ifNil: [ password := nil ] ifNotNil: [ password := encryptor encrypt: aPassword ]. "Since the passwords are encoded using the password, if you change the password, you have to re-encrypt the passwords" self reEncryptKeysBased: oldPassword! ! !KeyChain methodsFor: 'protocol' stamp: 'CamilloBruni 7/17/2013 23:40'! userNamePasswordFor: aGroup ^ self isUnlocked ifTrue: [ | oldUsernamePassword | oldUsernamePassword := groups at: aGroup ifAbsent: [ ^ nil ]. UsernamePassword username: oldUsernamePassword username password: (self decryptPassword: (oldUsernamePassword password)) ]! ! !KeyChain methodsFor: 'encryption' stamp: 'BenjaminVanRyseghem 5/6/2012 22:10'! encryptPassword: aString ^ encryptorDecryptor encrypt: aString base: password! ! !KeyChain methodsFor: 'protocol' stamp: 'CamilloBruni 7/17/2013 23:36'! lock nextLockTime := DateAndTime new! ! !KeyChain methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:40'! initialize super initialize. groups := IdentityDictionary new. encryptor := SHA1Ecryptor new. encryptorDecryptor := DummyEcryptorDecryptor new. self lock. ! ! !KeyChain methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 13:16'! username: aString username := aString ! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/11/2012 18:04'! isLocked ^ true! ! !KeyChain methodsFor: 'protocol' stamp: 'CamilloBruni 7/17/2013 23:40'! removeUserNamePasswordFor: aGroup ^ self isUnlocked ifTrue: [ groups removeKey: aGroup ]! ! !KeyChain methodsFor: 'protocol' stamp: 'CamilloBruni 7/17/2013 23:40'! setUserName: user password: pass forGroup: group self isUnlocked ifTrue: [ groups at: group put: (UsernamePassword username: user password: (self encryptPassword: pass)). ^ true ]. ^ false! ! !KeyChain methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/9/2012 16:19'! maxAttemptsNumber ^ 3! ! !KeyChain methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 23:40'! passwordFor: aUserName ^ self isUnlocked ifTrue: [ self decryptPassword: (groups at: aUserName) ]! ! !KeyChain methodsFor: 'protocol' stamp: 'CamilloBruni 7/17/2013 23:40'! setUserName: user password: pass forGroup: group withUnlockPassword: aString (encryptor encrypt: aString) = password ifTrue: [ groups at: group put: (UsernamePassword username: user password: (self encryptPassword: pass)). ^ true ]. ^ false! ! !KeyChain methodsFor: 'private-UI' stamp: 'CamilloBruni 7/17/2013 23:40'! bindings ^ groups! ! !KeyChain methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/9/2012 16:20'! isUnlocked ^ self isUnlocked: 0! ! !KeyChain methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 23:37'! timeBetweenUnlocks ^ timeBetweenUnlocks ifNil: [ self defaultTimeBetweenUnlocks ]! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/11/2012 16:37'! unlock ^ self isUnlocked ! ! !KeyChain methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 13:16'! username ^ username! ! !KeyChain methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/6/2012 23:35'! defaultTimeBetweenUnlocks " 5 minutes " ^ Duration minutes: 5! ! !KeyChain methodsFor: 'protocol' stamp: 'CamilloBruni 7/17/2013 23:40'! setUserNamePassword: usernamePassword forGroup: group self isUnlocked ifTrue: [ groups at: group put: usernamePassword. ^ true ]. ^ false! ! !KeyChain methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 23:37'! askPasswordForKeyChain: attempt | string | password ifNil: [ ^ nextLockTime := DateAndTime new + self timeBetweenUnlocks ]. string := (Smalltalk ui theme passwordEntryIn: StandardWindow new text: 'Password for the keychain for ', username asString ,' (', (self maxAttemptsNumber - attempt) asString ,' tries left)' title: 'Password request' entryText: ''). string ifNil: [ ^ self ]. (encryptor encrypt: string) = password ifFalse: [ self logCr: (encryptor encrypt: string). self logCr: password. ^ self ]. nextLockTime := DateAndTime new + self timeBetweenUnlocks.! ! !KeyChain methodsFor: 'encryption' stamp: 'BenjaminVanRyseghem 5/6/2012 22:26'! decryptPassword: aString ^ encryptorDecryptor decrypt: aString base: password! ! !KeyChain methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 23:37'! timeBetweenUnlocks: aDuration timeBetweenUnlocks := aDuration! ! !KeyChain methodsFor: 'protocol' stamp: 'MarcusDenker 10/10/2013 14:02'! setEncryptorDecryptor: anEncryptorDecryptor | oldDecryptor | self isUnlocked ifFalse: [ ^ self ]. oldDecryptor := encryptorDecryptor. encryptorDecryptor := anEncryptorDecryptor. groups associations do: [ :assoc | | oldUsernamePassword string | oldUsernamePassword := groups at: assoc key. string := oldDecryptor decrypt: oldUsernamePassword password base: password. groups at: assoc key put: (UsernamePassword username: oldUsernamePassword username password: (self encryptPassword: string)) ]! ! !KeyChain methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 23:38'! isUnlocked: attempt nextLockTime > DateAndTime now ifTrue: [ ^ true ]. attempt = self maxAttemptsNumber ifTrue: [ ^ false ]. self askPasswordForKeyChain: attempt. ^ self isUnlocked: (attempt + 1).! ! !KeyChain methodsFor: 'protocol' stamp: 'CamilloBruni 7/17/2013 23:40'! groups ^ groups keys! ! !KeyChainViewer commentStamp: ''! A KeyChainViewer is a GUI to see and edit values of a keychain! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! ok ^ ok! ! !KeyChainViewer methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/10/2012 13:44'! initializeAdd add label: '+'; enabled: false; state: false; action: [ self addPassword ]! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:43'! removePassword list selectedItem ifNil: [ ^self ] ifNotNil: [:it | keychain value removeUserNamePasswordFor: it key. keychain valueChanged ]! ! !KeyChainViewer methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/10/2012 13:44'! initializeEdit edit label: 'edit'; enabled: false; state: false; action: [ self editPassword ]! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:43'! editPassword list selectedItem ifNil: [ ^ self ] ifNotNil: [:it || wrapper editor | keychain value ifNotNil:[:kc | kc unlock ]. wrapper := KeychainEditingWrapper new keychain: keychain value; group: it key; usernamePassword: it value. editor := KeychainEditor new keychainEditingWrapper: wrapper; yourself. self window ifNotNil: [: w | w openModal: (editor openDialogWithSpec window okAction: [ it key: wrapper group. it value: wrapper usernamePassword. keychain valueChanged. list setSelectedItem: it]; yourself) ]. ]! ! !KeyChainViewer methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/10/2012 13:44'! initializeRemove remove label: '-'; enabled: false; state: false; action: [ self removePassword ]! ! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! keychain ^ keychain! ! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! edit ^ edit! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! addPassword | wrapper editor | keychain value ifNotNil:[:kc | kc unlock ]. wrapper := KeychainEditingWrapper new keychain: keychain value; group: ''; usernamePassword: UsernamePassword new. editor := KeychainEditor new keychainEditingWrapper: wrapper; yourself. self window ifNotNil: [: w | w openModal: (editor openDialogWithSpec window okAction: [ wrapper := KeychainEditingWrapper new keychain: keychain value; group: ''; usernamePassword: UsernamePassword new ]; yourself)].! ! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! add ^ add! ! !KeyChainViewer methodsFor: 'initialize' stamp: 'CamilloBruni 7/17/2013 22:56'! initializeWidgets self instantiateModels: #( add ButtonModel edit ButtonModel list MultiColumnListModel ok OkToolbar remove ButtonModel ). self initializeAdd. self initializeEdit. self initializeRemove. ok okButton label: 'Close'. list displayBlock: [ :item | self wrapItem: item ]. keychain whenChangedDo: [:kc | add enabled: kc notNil. list resetSelection. self updateTitle. list items: kc bindings associations ]. list whenSelectedItemChanged: [:it | edit enabled: it notNil. remove enabled: it notNil ]. self focusOrder add: list; add: add; add: edit; add: remove; add: ok.! ! !KeyChainViewer methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize keychain := nil asValueHolder. super initialize.! ! !KeyChainViewer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! keychain: aKeyChain keychain value: aKeyChain! ! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! remove ^ remove! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! title ^ keychain value ifNil: [ 'Keychain editor' ] ifNotNil: [:kc | kc username ifNil: [ 'Keychain editor' ] ifNotNil: [:usr | 'Editing ', usr ,'''s keychain' ]]! ! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! list ^ list! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/10/2012 13:27'! wrapItem: anItem ^ { anItem key. anItem value username }! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/10/2012 16:18'! initialExtent ^ (320@240)! ! !KeyChainViewer class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 9/27/2013 10:48'! internSpec ^{#ContainerModel. #add:. {{#model. #list }. #layout:. #(FrameLayout bottomOffset: -50)}. #add:. {{#model. #add }. #layout:. #(FrameLayout topFraction: 1 rightFraction: 0 topOffset: -50 rightOffset: 50 bottomOffset: -25) }. #add:. {{#model. #edit }. #layout:. #(FrameLayout topFraction: 1 leftOffset: 50 topOffset: -50 rightOffset: -50 bottomOffset: -25) }. #add:. {{#model. #remove }. #layout:. #(FrameLayout leftFraction: 1 topFraction: 1 leftOffset: -50 topOffset: -50 bottomOffset: -25) }. #add:. {{#model. #ok }. #layout: . #(FrameLayout topFraction: 1 topOffset: -25) }}! ! !KeyNotFound commentStamp: 'SvenVanCaekenberghe 4/19/2011 19:41'! I am KeyNotFound, an exception indicating that a key was not found in a Dictionary.! !KeyNotFound methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/19/2011 19:38'! key ^ super object! ! !KeyNotFound methodsFor: 'private' stamp: 'MarianoMartinezPeck 5/27/2011 16:38'! standardMessageText "Generate a standard textual description" ^ String streamContents: [ :stream | stream << 'key '. stream print: self object. stream << ' not found in '. stream print: self collection class ]! ! !KeyNotFound methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/19/2011 19:38'! key: aKey super object: aKey! ! !KeyPrinterMorph commentStamp: ''! I am a morph that prints the keys in the keyboard events. KeyPrinterMorph new openInWorld! !KeyPrinterMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/4/2013 12:46'! mouseDown: event super mouseDown: event. World activeHand newKeyboardFocus: self! ! !KeyPrinterMorph methodsFor: 'initialize' stamp: 'GuillermoPolito 5/4/2013 12:53'! openInWorld self openInWindowLabeled: 'KeyPrinter'! ! !KeyPrinterMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/4/2013 12:20'! handlesKeyboard: evt ^ true! ! !KeyPrinterMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/4/2013 12:47'! handlesMouseDown: evt ^ true! ! !KeyPrinterMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/4/2013 12:50'! keyDown: anEvent UIManager default inform: anEvent key asString.! ! !KeyboardEvent commentStamp: ''! I am a keyboard event. I contain the char code of the event pressed, the modifiers pressed, and the keycode of the key pressed.! !KeyboardEvent methodsFor: 'testing' stamp: 'DenisKudryashov 7/20/2013 17:29'! hasSpecialCTRLKeyValue " 4 - Character end 1 - Character home " ^ self controlKeyPressed and: [ keyValue <= 26 & (keyValue ~= 4) & (keyValue ~= 1) ]! ! !KeyboardEvent methodsFor: '*Polymorph-Widgets' stamp: 'SeanDeNigris 1/23/2014 11:53'! isWindowNavigation ^ TaskListMorph isNavigationEvent: self.! ! !KeyboardEvent methodsFor: 'dispatching' stamp: 'ar 9/15/2000 21:13'! sentTo: anObject "Dispatch the receiver into anObject" type == #keystroke ifTrue:[^anObject handleKeystroke: self]. type == #keyDown ifTrue:[^anObject handleKeyDown: self]. type == #keyUp ifTrue:[^anObject handleKeyUp: self]. ^super sentTo: anObject.! ! !KeyboardEvent methodsFor: 'keyboard' stamp: 'nk 10/13/2004 10:43'! keyString "Answer the string value for this keystroke. This is defined only for keystroke events." ^ String streamContents: [ :s | self printKeyStringOn: s ]! ! !KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'! isKeyboard ^true! ! !KeyboardEvent methodsFor: 'initialize' stamp: 'michael.rueger 2/24/2009 14:08'! scanCode: anInt scanCode := anInt! ! !KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'! isKeystroke ^self type == #keystroke! ! !KeyboardEvent methodsFor: 'testing' stamp: 'ar 10/9/2000 00:43'! isMouseMove ^false! ! !KeyboardEvent methodsFor: 'printing' stamp: 'nk 10/13/2004 10:42'! printOn: aStream "Print the receiver on a stream" aStream nextPut: $[. aStream nextPutAll: type; nextPutAll: ' '''. self printKeyStringOn: aStream. aStream nextPut: $'. aStream nextPut: $]! ! !KeyboardEvent methodsFor: 'testing' stamp: 'SeanDeNigris 1/29/2013 11:22'! isUserInterrupt ^ UserInterruptHandler cmdDotEnabled and: [ self keyCharacter = $. and: [ self commandKeyPressed ] ]. ! ! !KeyboardEvent methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 6/28/2013 13:03'! asShortcut ^ self asKeyCombination! ! !KeyboardEvent methodsFor: '*Keys' stamp: 'cami 7/22/2013 18:27'! key ^Smalltalk os keyForValue: keyValue! ! !KeyboardEvent methodsFor: 'keyboard' stamp: 'michael.rueger 3/11/2009 11:21'! keyCharacter "Answer the character corresponding this keystroke. This is defined only for keystroke events." ^Unicode value: charCode! ! !KeyboardEvent methodsFor: 'keyboard' stamp: 'ar 9/13/2000 15:51'! keyValue "Answer the ascii value for this keystroke. This is defined only for keystroke events." ^ keyValue! ! !KeyboardEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:54'! setType: aSymbol buttons: anInteger position: pos keyValue: aValue hand: aHand stamp: stamp type := aSymbol. buttons := anInteger. position := pos. keyValue := aValue. source := aHand. wasHandled := false. timeStamp := stamp.! ! !KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'! isKeyDown ^self type == #keyDown! ! !KeyboardEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:50'! hash ^buttons hash + keyValue hash ! ! !KeyboardEvent methodsFor: 'printing' stamp: 'SeanDeNigris 1/15/2014 15:24'! storeOn: aStream aStream nextPutAll: type. aStream space. self timeStamp storeOn: aStream. aStream space. position x asInteger storeOn: aStream. aStream space. position y asInteger storeOn: aStream. aStream space. buttons storeOn: aStream. aStream space. keyValue storeOn: aStream. aStream space. charCode storeOn: aStream. aStream space. scanCode storeOn: aStream.! ! !KeyboardEvent methodsFor: '*Keymapping-KeyCombinations' stamp: 'GuillermoPolito 3/19/2013 19:12'! asKeyCombination ^ KMKeyCombination fromKeyboardEvent: self! ! !KeyboardEvent methodsFor: 'printing' stamp: 'DenisKudryashov 7/20/2013 17:32'! printKeyStringOn: aStream "Print a readable string representing the receiver on a given stream" | kc inBrackets firstBracket keyString | kc := self keyCharacter. inBrackets := false. firstBracket := [ inBrackets ifFalse: [ aStream nextPut: $<. inBrackets := true ]]. self controlKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Ctrl-' ]. self commandKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Cmd-' ]. (buttons anyMask: 32) ifTrue: [ firstBracket value. aStream nextPutAll: 'Opt-' ]. (self shiftPressed and: [ keyValue between: 1 and: 31 ]) ifTrue: [ firstBracket value. aStream nextPutAll: 'Shift-' ]. self hasSpecialCTRLKeyValue ifTrue: [aStream nextPut: (keyValue + $a asciiValue - 1) asCharacter] ifFalse: [keyString := (kc caseOf: { [ Character space ] -> [ ' ' ]. [ Character tab ] -> [ 'tab' ]. [ Character cr ] -> [ 'cr' ]. [ Character lf ] -> [ 'lf' ]. [ Character enter ] -> [ 'enter' ]. [ Character backspace ] -> [ 'backspace' ]. [ Character delete ] -> [ 'delete' ]. [ Character escape ] -> [ 'escape' ]. [ Character arrowDown ] -> [ 'down' ]. [ Character arrowUp ] -> [ 'up' ]. [ Character arrowLeft ] -> [ 'left' ]. [ Character arrowRight ] -> [ 'right' ]. [ Character end ] -> [ 'end' ]. [ Character home ] -> [ 'home' ]. [ Character pageDown ] -> [ 'pageDown' ]. [ Character pageUp ] -> [ 'pageUp' ]. [ Character euro ] -> [ 'euro' ]. [ Character insert ] -> [ 'insert' ]. } otherwise: [ String with: kc ]). keyString size > 1 ifTrue: [ firstBracket value ]. aStream nextPutAll: keyString]. inBrackets ifTrue: [aStream nextPut: $> ]! ! !KeyboardEvent methodsFor: 'keyboard' stamp: 'michael.rueger 2/25/2009 22:19'! scanCode ^scanCode! ! !KeyboardEvent methodsFor: 'comparing' stamp: 'ar 10/24/2000 17:44'! = aMorphicEvent super = aMorphicEvent ifFalse:[^false]. buttons = aMorphicEvent buttons ifFalse: [^ false]. keyValue = aMorphicEvent keyValue ifFalse: [^ false]. ^ true ! ! !KeyboardEvent methodsFor: 'private' stamp: 'michael.rueger 2/23/2009 11:49'! setType: aSymbol buttons: anInteger position: pos keyValue: aValue charCode: anInt hand: aHand stamp: stamp type := aSymbol. buttons := anInteger. position := pos. keyValue := aValue. charCode := anInt. source := aHand. wasHandled := false. timeStamp := stamp.! ! !KeyboardEvent methodsFor: '*Keymapping-KeyCombinations' stamp: 'DenisKudryashov 7/20/2013 17:28'! modifiedCharacter self flag: #hack. "Hack me. When Ctrl is pressed, the key ascii value is not right and we have to do something ugly" ^(self hasSpecialCTRLKeyValue and: [ (#(MacOSX Windows) includes: Smalltalk os current platformFamily) ]) ifTrue: [ (self keyValue + $a asciiValue - 1) asCharacter ] ifFalse: [ self keyCharacter ]! ! !KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'! isKeyUp ^self type == #keyUp! ! !KeychainEditingWrapper commentStamp: ''! A KeychainEditingWrapper is a simple wrapper for the KeychainEditor ! !KeychainEditingWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:46'! keychain: anObject keychain := anObject! ! !KeychainEditingWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:46'! group ^ group! ! !KeychainEditingWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:46'! group: anObject group := anObject! ! !KeychainEditingWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:46'! usernamePassword: anObject usernamePassword := anObject! ! !KeychainEditingWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:46'! keychain ^ keychain! ! !KeychainEditingWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:46'! usernamePassword ^ usernamePassword! ! !KeychainEditor commentStamp: ''! A KeychainEditor is a GUI for editing keychain entrie! !KeychainEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! ok | it | (it := keychainEditingWrapper value) ifNil: [ ^ self ]. it group: groupTextField getText asSymbol. it usernamePassword username: usernameTextField getText. it usernamePassword password: password.! ! !KeychainEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:21'! groupTextField ^ groupTextField! ! !KeychainEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:21'! usernameLabel ^ usernameLabel! ! !KeychainEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:21'! usernameTextField ^ usernameTextField! ! !KeychainEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/2/2012 16:51'! initializeWidgets self instantiateModels: #( groupLabel LabelModel groupTextField TextInputFieldModel setPassword ButtonModel usernameLabel LabelModel usernameTextField TextInputFieldModel ). groupLabel text: 'Group:'. groupTextField enabled: false; autoAccept: true; ghostText: 'group'. usernameLabel text: 'Username: '. usernameTextField enabled: false; autoAccept: true; ghostText: 'username'. setPassword enabled: false; state: false; label: 'set password'; action: [ self setNewPassword ]. self focusOrder add: groupTextField; add: usernameTextField! ! !KeychainEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/2/2012 16:46'! initializeDialogWindow: aWindow aWindow okAction: [ self ok ].! ! !KeychainEditor methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize keychainEditingWrapper := nil asValueHolder. super initialize.! ! !KeychainEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:21'! setPassword ^ setPassword! ! !KeychainEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/2/2012 15:21'! initializePresenter keychainEditingWrapper whenChangedDo: [:it | groupTextField enabled: it notNil. usernameTextField enabled: it notNil. setPassword enabled: (it keychain isLocked and: [ it notNil ]). it ifNotNil: [ groupTextField text: it group. usernameTextField text: it usernamePassword username. password := it usernamePassword password. self updateTitle. ]]! ! !KeychainEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! setNewPassword | it newPassword w | (it := keychainEditingWrapper value) ifNil: [ ^ self ]. it keychain unlock ifFalse: [ ^ self ]. w := PasswordInitializationDialogWindow new. self window openModal: w. newPassword := w enteredValue. newPassword ifNil: [ ^ self ]. password := it keychain encryptPassword: newPassword! ! !KeychainEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/11/2012 17:49'! keychainEditingWrapper ^ keychainEditingWrapper! ! !KeychainEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! keychainEditingWrapper: anAssociation keychainEditingWrapper value: anAssociation! ! !KeychainEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! title ^ keychainEditingWrapper value ifNil: [ 'Group editor' ] ifNotNil: [:it | it group ifEmpty: [ 'Group editor' ] ifNotEmpty: [:name | 'Editing ', name asString printString, ' group' ]]! ! !KeychainEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:21'! groupLabel ^ groupLabel! ! !KeychainEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/2/2012 16:41'! initialExtent ^ 330@150! ! !KeychainEditor class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 9/27/2013 10:47'! internSpec ^{#ContainerModel . #add: . {{#model . #groupLabel } . #layout: . #(FrameLayout rightFraction: 0 bottomFraction: 0 rightOffset: 75 bottomOffset: 25) }. #add: . {{#model . #groupTextField } .#layout: . #(FrameLayout bottomFraction: 0 leftOffset: 75 bottomOffset: 25) }. #add: . {{#model . #usernameLabel } . #layout: . #(FrameLayout rightFraction: 0 bottomFraction: 0 topOffset: 25 rightOffset: 75 bottomOffset: 50) }. #add: . {{#model . #usernameTextField } . #layout: . #(FrameLayout bottomFraction: 0 leftOffset: 75 topOffset: 25 bottomOffset: 50) }. #add: . {{#model. #setPassword } . #layout: . #(FrameLayout bottomFraction: 0 topOffset: 50 bottomOffset: 75) }}! ! !KeyedTree commentStamp: ''! Provides path based access to elements contained in the receiver and any subtrees. Example: (KeyedTree new at: 1 put: 'One'; at: 2 put: 'Two'; at: 'Tree' put: (KeyedTree new at: $a put: 'Tree-A'; at: $b put: 'Tree-B'; yourself); yourself) atPath: #('Tree' $b)! !KeyedTree methodsFor: 'printing' stamp: 'nice 1/5/2010 15:59'! putFormattedTextOn: aStream withDescriptions: aKeyedTree level: indentLevel indentString: aString "Place a print of the receiver and associated description on the given stream with the given indentation level." (self keys asSortedCollection: self sortBlock) do: [:k | | v | indentLevel timesRepeat: [aStream nextPutAll: aString]. aStream nextPutAll: k printString. v := self at: k. (v isKindOf: self class) ifTrue: [aStream cr. v putFormattedTextOn: aStream withDescriptions: (aKeyedTree at: k ifAbsent: [self class new]) level: indentLevel + 1 indentString: aString] ifFalse: [aStream nextPutAll: ' : '; nextPutAll: v printString; tab; tab; nextPutAll: (aKeyedTree at: k ifAbsent: ['nondescript']) printString. aStream cr]]! ! !KeyedTree methodsFor: 'accessing' stamp: 'gvc 2/1/2006 11:01'! atPath: anArray ifAbsentPut: aBlock "Answer the element referenced by the given key path. Answer the value of aBlock if not found after creating its path." |element| anArray isEmpty ifTrue: [^self]. element := self. anArray allButLastDo: [:key | element := element at: key ifAbsentPut: [self species new]]. ^element at: anArray last ifAbsentPut: aBlock! ! !KeyedTree methodsFor: 'accessing' stamp: 'gvc 2/1/2006 11:00'! atPath: anArray put: aBlock "Answer the value of aBlock after creating its path." |element| anArray isEmpty ifTrue: [^self]. element := self. anArray allButLastDo: [:key | element := element at: key ifAbsentPut: [self species new]]. ^element at: anArray last put: aBlock! ! !KeyedTree methodsFor: 'printing' stamp: 'gvc 1/17/2008 16:06'! formattedText "Answer a string or text representing the receiver with indentation and, possibly, markup." |str| str := String new writeStream. self putFormattedTextOn: str level: 0 indentString: ' '. ^str contents! ! !KeyedTree methodsFor: 'removing' stamp: 'gvc 10/20/2005 18:53'! removePath: anArray ifAbsent: aBlock "Remove and answer the element referenced by the given path. Answer the value of aBlock if not found." |element| anArray isEmpty ifTrue: [^self]. element := self. anArray allButLastDo: [:key | element := element at: key ifAbsent: [^aBlock value]]. ^element removeKey: anArray last ifAbsent: aBlock ! ! !KeyedTree methodsFor: 'accessing' stamp: 'gvc 12/15/2005 13:57'! allKeys "Answer an ordered collection of the keys of the receiver and any subtrees. Please no circular references!!" |answer| answer := OrderedCollection new. answer addAll: self keys. self subtrees do: [:t | answer addAll: t allKeys]. ^answer! ! !KeyedTree methodsFor: 'accessing' stamp: 'gvc 2/1/2006 11:01'! atPath: anArray ifAbsent: aBlock "Answer the element referenced by the given key path. Answer the value of aBlock if not found." |element| element := self. anArray do: [:key | element := element at: key ifAbsent: [^aBlock value]]. ^element! ! !KeyedTree methodsFor: 'accessing' stamp: 'gvc 12/15/2005 13:54'! subtrees "Answer the subtrees of the receiver." ^(self select: [:v | v isKindOf: KeyedTree]) values! ! !KeyedTree methodsFor: 'printing' stamp: 'nice 1/5/2010 15:59'! putFormattedTextOn: aStream level: indentLevel indentString: aString "Place a description of the receiver on the given stream with the given indentation level." (self keys asSortedCollection: self sortBlock) do: [:k | | v | indentLevel timesRepeat: [aStream nextPutAll: aString]. aStream nextPutAll: k printString. v := self at: k. (v isKindOf: self class) ifTrue: [aStream cr. v putFormattedTextOn: aStream level: indentLevel + 1 indentString: aString] ifFalse: [aStream nextPutAll: ' : '; nextPutAll: v printString. aStream cr]]! ! !KeyedTree methodsFor: 'copying' stamp: 'nice 1/13/2010 21:46'! postCopy "Must copy the associations, or later store will affect both the original and the copy. Copy any subtrees too!!" array := array collect: [:assoc | assoc ifNil: [nil] ifNotNil: [Association key: assoc key value: ((assoc value isKindOf: KeyedTree) ifTrue: [assoc value copy] ifFalse: [assoc value])]]! ! !KeyedTree methodsFor: 'printing' stamp: 'gvc 1/17/2008 16:23'! formattedTextWithDescriptions: aKeyedTree "Answer a string or text representing the receiver with indentation and, possibly, markup. Descriptions of each item are taken from the given tree with the same key structure as the receiver." |str| str := String new writeStream. self putFormattedTextOn: str withDescriptions: aKeyedTree level: 0 indentString: ' '. ^str contents! ! !KeyedTree methodsFor: 'adding' stamp: 'nice 1/5/2010 15:59'! merge: aKeyedTree "Merge the given tree into the receiver, overwriting or extending elements as needed." aKeyedTree keysAndValuesDo: [:k :v | | subtree | (v isKindOf: KeyedTree) ifTrue: [subtree := self at: k ifAbsentPut: [v species new]. (subtree isKindOf: KeyedTree) not ifTrue: [subtree := self at: k put: v species new]. subtree merge: v] ifFalse: [self at: k put: v]]! ! !KeyedTree methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2011 13:30'! atPath: anArray "Answer the element referenced by the give key path. Signal an error if not found." ^self atPath: anArray ifAbsent: [self errorKeyNotFound: anArray]! ! !KeyedTree methodsFor: 'accessing' stamp: 'gvc 1/17/2008 15:37'! sortBlock "Answer the block to sort tree keys with." ^[:a :b | [a <= b] on: Error do: [a class name <= b class name]]! ! !KeyedTree methodsFor: 'removing' stamp: 'CamilloBruni 4/11/2011 13:31'! removePath: anArray "Remove and answer the element referenced by the given path. Signal an error if not found." ^self removePath: anArray ifAbsent: [self errorKeyNotFound: anArray]! ! !KeyedTreeTest commentStamp: 'TorstenBergmann 2/20/2014 15:29'! SUnit tests for keyed trees! !KeyedTreeTest methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 6/9/2012 22:57'! testAtPathPut "Test the at path put method for success and failure modes." |tree t2| tree := KeyedTree new at: 1 put: (KeyedTree new at: #two put: 'One-Two'; at: #three put: 'One-Three'; yourself); at: 2 put: 'Two'; yourself. self should: [(tree atPath: #(1 two) put: #new) = #new]. self should: [(tree atPath: #(1 two)) = #new]. self should: [(tree atPath: #(1 three) put: (t2 := KeyedTree new)) = t2]. self should: [(tree atPath: #(1 three $1) put: #anotherNew) = #anotherNew]. self should: [(tree atPath: #(1 three $1)) = #anotherNew]. self should: [tree atPath: #(2 4) put: [#new]] raise: self defaultTestError. self should: [(tree atPath: #(1 four one) put: #anotherNew) = #anotherNew]. self should: [(tree atPath: #(1 four one)) = #anotherNew].! ! !KeyedTreeTest methodsFor: 'as yet unclassified' stamp: 'gvc 4/18/2006 14:35'! testRemovePathIfAbsent "Test the remove path if absent method for success and failure modes." |tree| tree := KeyedTree new at: 1 put: (KeyedTree new at: #two put: 'One-Two'; at: #three put: 'One-Three'; yourself); at: 2 put: 'Two'; yourself. self should: [(tree removePath: #(4) ifAbsent: [#none]) = #none]. self should: [(tree removePath: #(1 2 3 4) ifAbsent: [#none]) = #none]. self should: [(tree removePath: #(1 two) ifAbsent: [#none]) = 'One-Two']. self should: [(tree atPath: #(1 two) ifAbsent: []) = nil]. self should: [(tree removePath: #(2) ifAbsent: [#none]) = 'Two']. self should: [(tree atPath: #(2) ifAbsent: []) = nil].! ! !KeyedTreeTest methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 18:37'! testMerge "Test the merge method for success and failure modes." |t1 t2 m| t1 := KeyedTree new at: 1 put: (KeyedTree new at: #1 put: '1-1'; at: #2 put: '1-2'; at: #3 put: (KeyedTree new at: 1 put: '1-3-1'; at: 2 put: '1-3-2'; yourself); yourself); at: 2 put: '2'; yourself. t2 := KeyedTree new at: 1 put: (KeyedTree new at: #1 put: (KeyedTree new at: 1 put: '1-1-1'; at: 2 put: '1-1-2'; yourself); at: #2 put: '1-2*'; yourself); at: 3 put: '3'; yourself. m := t1 merge: t2. self should: [(m at: 2) = '2']. self should: [(m at: 3) = '3']. self should: [(m atPath: #(1 2)) = '1-2*']. self should: [(m atPath: #(1 1 1)) = '1-1-1']. self should: [(m atPath: #(1 1 2)) = '1-1-2']. self should: [(m atPath: #(1 3 1)) = '1-3-1']. self should: [(m atPath: #(1 3 2)) = '1-3-2'].! ! !KeyedTreeTest methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 6/9/2012 22:57'! testAtPathIfAbsentPut "Test the at path if absent put method for success and failure modes." |tree t2| tree := KeyedTree new at: 1 put: (t2 := KeyedTree new at: #two put: 'One-Two'; at: #three put: 'One-Three'; yourself); at: 2 put: 'Two'; yourself. self should: [(tree atPath: #(1) ifAbsentPut: [#new]) = t2]. self should: [(tree atPath: #(1 two) ifAbsentPut: [#new]) = 'One-Two']. self should: [(tree atPath: #(1 three) ifAbsentPut: [#new]) = 'One-Three']. self should: [(tree atPath: #(2) ifAbsentPut: [#new]) = 'Two']. self should: [tree atPath: #(2 4) ifAbsentPut: [#new]] raise: self defaultTestError. self should: [tree atPath: #(1 two three) ifAbsentPut: [#new]] raise: self defaultTestError. self should: [(tree atPath: #(1 four one) ifAbsentPut: [#anotherNew]) = #anotherNew]. self should: [(tree atPath: #(1 four one)) = #anotherNew]. self should: [(tree atPath: #(3) ifAbsentPut: [#yetAnotherNew]) = #yetAnotherNew]. self should: [(tree atPath: #(3)) = #yetAnotherNew].! ! !KeyedTreeTest methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 6/9/2012 22:57'! testRemovePath "Test the remove path method for success and failure modes." |tree| tree := KeyedTree new at: 1 put: (KeyedTree new at: #two put: 'One-Two'; at: #three put: 'One-Three'; yourself); at: 2 put: 'Two'; yourself. self should: [tree removePath: #(4)] raise: self defaultTestError. self should: [tree removePath: #(1 one)] raise: self defaultTestError. self should: [(tree removePath: #(1 two)) = 'One-Two']. self should: [(tree atPath: #(1 two) ifAbsent: []) = nil]. self should: [(tree removePath: #(2)) = 'Two']. self should: [(tree atPath: #(2) ifAbsent: []) = nil].! ! !KeyedTreeTest methodsFor: 'as yet unclassified' stamp: 'gvc 1/22/2010 13:52'! testSubtrees "Test the subtrees method for success and failure modes." |t1 t2 t3 t4| t1 := KeyedTree new at: 1 put: (t2 := KeyedTree new at: #1 put: '1-1'; at: #2 put: '1-2'; at: #3 put: (t3 := KeyedTree new at: 1 put: '1-3-1'; at: 2 put: '1-3-2'; yourself); yourself); at: 2 put: '2'; at: 3 put: (t4 := KeyedTree new at: 1 put: '1-3-1'; at: 2 put: '1-3-2'; yourself); yourself. self should: [t1 subtrees = {t2. t4}]. self should: [(t1 at: 1) subtrees = {t3}].! ! !KeyedTreeTest methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 6/9/2012 22:58'! testAtPathIfAbsent "Test the at path if absent method for success and failure modes." |tree t2| tree := KeyedTree new at: 1 put: (t2 := KeyedTree new at: #two put: 'One-Two'; at: #three put: 'One-Three'; yourself); at: 2 put: 'Two'; yourself. self should: [(tree atPath: #(1) ifAbsent: []) = t2]. self should: [(tree atPath: #(1 two) ifAbsent: []) = 'One-Two']. self should: [(tree atPath: #(1 three) ifAbsent: []) = 'One-Three']. self should: [(tree atPath: #(2) ifAbsent: []) = 'Two']. self should: [(tree atPath: #(2 4) ifAbsent: [#missing]) = #missing]. self should: [(tree atPath: #(1 two three) ifAbsent: [#missing]) = #missing] raise: self defaultTestError. self should: [(tree atPath: #(3) ifAbsent: [#missing]) = #missing].! ! !KeyedTreeTest methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 6/9/2012 22:58'! testAtPath "Test the at path method for success and failure modes." |tree t2| tree := KeyedTree new at: 1 put: (t2 := KeyedTree new at: #two put: 'One-Two'; at: #three put: 'One-Three'; yourself); at: 2 put: 'Two'; yourself. self should: [(tree atPath: #(1)) = t2]. self should: [(tree atPath: #(1 two)) = 'One-Two']. self should: [(tree atPath: #(1 three)) = 'One-Three']. self should: [(tree atPath: #(2)) = 'Two']. self should: [tree atPath: #(2 4)] raise: self defaultTestError. self should: [tree atPath: #(1 two three)] raise: self defaultTestError. self should: [tree atPath: #(3)] raise: self defaultTestError.! ! !KeyedTreeTest methodsFor: 'as yet unclassified' stamp: 'gvc 1/22/2010 13:52'! testCopy "Test the copy method for success and failure modes." |c tree t2 t3| tree := KeyedTree new at: 1 put: (t2 := KeyedTree new at: #two put: 'One-Two'; at: #three put: 'One-Three'; at: #four put: (t3 := KeyedTree new); yourself); at: 2 put: 'Two'; yourself. c := tree copy. self should: [c = tree]. self shouldnt: [c == tree]. self should: [(c at: 1) = t2]. self shouldnt: [(c at: 1) == t2]. self should: [(c atPath: #(1 four)) = t3]. self shouldnt: [(c atPath: #(1 four)) == t3].! ! !KeymapBuilderTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 3/19/2013 19:12'! testAddKeymapCreatesShortcut KMRepository default initializeKeymap: #test executingOn: $r ctrl, $r asKeyCombination, $r asKeyCombination doing: [ :receiver | "nothing" ] inCategory: #Testing platform: #all. self assert: (KMRepository default categoryForName: #Testing ) allEntries size = 1.! ! !KeymapBuilderTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 3/19/2013 19:12'! testAddKeymapCreatesCategory self assert: KMRepository default categories isEmpty. KMRepository default initializeKeymap: #test executingOn: $r ctrl, $r asKeyCombination, $r asKeyCombination doing: [ :receiver | "nothing" ] inCategory: #Testing platform: #all. self assert: (KMRepository default includesCategoryNamed: #Testing). self assert: KMRepository default categories size = 1.! ! !KeymapBuilderTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 3/19/2013 19:12'! testAttachKeymapAndExecuteExecutes | executed morphToTest | executed := false. KMFactory keymapContainer initializeKeymap: #test executingOn: $a asKeyCombination, $a asKeyCombination, $a asKeyCombination doing: [ :receiver | executed := true ] inCategory: #Testing platform: #all. " KMFactory keymapContainer attachCategoryName: #Testing to: KMMockMorph." morphToTest := KMMockMorph new. morphToTest attachKeymapCategory: #Testing. {self eventKey: $a. self eventKey: $a. self eventKey: $a} do: [:e | morphToTest dispatchKeystrokeForEvent: e]. self assert: executed.! ! !KeymapBuilderTest class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapEventBuilderClass ^ KMFactory keymapEventBuilder! ! !KmGlobalDispatcher commentStamp: ''! I am a dispatcher that dispatches the global keymappings.! !KmGlobalDispatcher methodsFor: 'testing' stamp: 'GuillermoPolito 5/3/2013 16:59'! isGlobalDispatcher ^true! ! !KmGlobalDispatcher methodsFor: 'dispatching' stamp: 'GuillermoPolito 5/3/2013 17:46'! dispatch: anEventBuffer dispatcher dispatch: anEventBuffer inCategories: KMRepository default globalCategories ! ! !KmGlobalDispatcher methodsFor: 'iterating' stamp: 'GuillermoPolito 5/3/2013 16:57'! nextForKmChain: aKMDispatchChain ^aKMDispatchChain target! ! !KmGlobalDispatcher methodsFor: 'initialize-release' stamp: 'GuillermoPolito 5/3/2013 17:22'! dispatcher: aDispatcher dispatcher := aDispatcher! ! !Komit commentStamp: ''! I am a representation of a commit. I am abstracted from Monticello to be able to be reused with other frameworks! !Komit methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 20:23'! commitOn: aSubmitter aSubmitter commitKomit: self! ! !KomitClass commentStamp: ''! I am encapsulating a class and the operations which has been append to it. I implement a flyweight DP! !KomitClass methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:04'! definition ^ definition! ! !KomitClass methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 21:41'! definitions ^ definitions ifNil: [ definitions := (self operations select: [ :each | each isClassPatch ] thenCollect: [ :each | each koDefinition ]) sorted ]! ! !KomitClass methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/21/2013 14:43'! addOperation: anOperation operations add: anOperation! ! !KomitClass methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 22:03'! operations ^ (definition ifNil: [ operations ] ifNotNil: [ {definition}, operations asOrderedCollection ]) asOrderedCollection! ! !KomitClass methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:58'! addClassDefinition: aMCRemoval self definition: aMCRemoval! ! !KomitClass methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 21:58'! definition: aMCRemoval definition := aMCRemoval! ! !KomitClass methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 21:41'! methods ^ methods ifNil: [ methods := (self operations select: [ :each | each isMethodPatch ] thenCollect: [ :each | each koMethod ]) sorted ]! ! !KomitClass methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:23'! trackedClass ^ trackedClass! ! !KomitClass methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 22:05'! koDestinationText ^ self isDirty ifTrue: [ self definition koDestinationText ] ifFalse: [ '' ]! ! !KomitClass methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 12/7/2013 10:56'! isKomitClass ^ true! ! !KomitClass methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/26/2013 10:21'! koSourceText ^ self isDirty ifFalse: [ 'No changes' ] ifTrue: [ self definition koSourceText ]! ! !KomitClass methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/22/2013 16:43'! addOrganizationDefinition: aMCModification self addOperation: aMCModification! ! !KomitClass methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/21/2013 20:55'! initialize super initialize. operations := Set new! ! !KomitClass methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:57'! printOn: aStream super printOn: aStream. aStream << '[ '. self trackedClass printOn: aStream. aStream << ' ]'.! ! !KomitClass methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:23'! trackedClass: anObject trackedClass := anObject! ! !KomitClass methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 13:51'! flush super flush. definition := nil. operations removeAll. methods ifNotNil: [ :m | m do: [ :e | e flush ] ]. methods := nil. definitions ifNotNil: [ :d | d do: [ :e | e flush ] ]. definitions := nil! ! !KomitClass methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:59'! addMethodDefinition: aMCAddition self addOperation: aMCAddition! ! !KomitClass methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 11/24/2013 21:25'! <= aKomitObject ^ self class name <= aKomitObject class name! ! !KomitClass class methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/27/2013 15:17'! initialize classes := Dictionary new.! ! !KomitClass class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/21/2013 14:48'! new self shouldNotImplement! ! !KomitClass class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 15:35'! resetCache classes removeAll! ! !KomitClass class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/21/2013 14:48'! trackedClass: trackedClass ^ classes at: trackedClass name ifAbsentPut: [ super new trackedClass: trackedClass; yourself ]! ! !KomitClass class methodsFor: 'instance creation' stamp: 'NicolaiHess 4/8/2014 20:06'! trackedClass: trackedClass forExtension: aCategory ^ classes at: trackedClass name, aCategory ifAbsentPut: [ super new trackedClass: trackedClass; yourself ]! ! !KomitClassNode commentStamp: ''! I am a node in the Komit tree representing a class! !KomitClassNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/24/2013 14:22'! getDefinitions ^ self content definitions! ! !KomitClassNode methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/24/2013 21:28'! initialize super initialize. self whenSelectedChanged: [ :aBoolean | self parentNode ifNotNil: [ :parent | parent checkChildren ]. self ifNotSilentDo: [ aBoolean ifTrue: [ self selectAllChildren ] ifFalse: [ self unselectAllChildren ] ] ]. self whenContentChanged: [ :c || childrenNode | self hasContentToShow: c isDirty. childrenNode := self getDefinitions collect: [ :each | KomitDefinitionNode new content: each; yourself ]. childrenNode addAll: (self getMethods collect: [ :each | KomitMethodNode new content: each; yourself ]). self children: [ childrenNode ] ]! ! !KomitClassNode methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 21:41'! label ^ self content trackedClass! ! !KomitClassNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/24/2013 14:21'! getMethods ^ self content methods! ! !KomitClassNode methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:58'! printOn: aStream super printOn: aStream. aStream << '[ '. self content trackedClass printOn: aStream. aStream << ' ]'.! ! !KomitClassNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 15:40'! icon self content added ifTrue: [ ^ self class addedClassIcon ]. self content modified ifTrue: [ ^ self class modifiedClassIcon ]. self content removed ifTrue: [ ^ self class deletedClassIcon ]. ^ self class defaultClassIcon! ! !KomitClassNode class methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 11/26/2013 17:22'! modifiedClassIcon ^ modifiedClassIcon ifNil: [ modifiedClassIcon := (self defaultClassIcon asFormOfDepth: 32) mergeBottomRightWith: (Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: Smalltalk ui icons overlayModificationIconContents readStream)) ].! ! !KomitClassNode class methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 11/26/2013 17:22'! deletedClassIcon ^ deletedClassIcon ifNil: [ deletedClassIcon := (self defaultClassIcon asFormOfDepth: 32) mergeBottomRightWith: (Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: Smalltalk ui icons overlayRemoveIconContents readStream)) ].! ! !KomitClassNode class methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 11/26/2013 15:33'! defaultClassIcon ^ Smalltalk ui icons classIcon! ! !KomitClassNode class methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 11/26/2013 17:22'! addedClassIcon ^ addedClassIcon ifNil: [ addedClassIcon := (self defaultClassIcon asFormOfDepth: 32) mergeBottomRightWith: (Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: Smalltalk ui icons overlayAddIconContents readStream)) ].! ! !KomitDefinition commentStamp: ''! Iam a komit object representing a change in a class definition! !KomitDefinition methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 21:09'! operation ^ operation! ! !KomitDefinition methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 16:33'! definition ^ definition! ! !KomitDefinition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 22:06'! koSourceText ^ self operation koSourceText! ! !KomitDefinition methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 11/24/2013 21:26'! <= aKomitObject ^ self definition <= aKomitObject definition! ! !KomitDefinition methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 16:32'! definition: anObject definition := anObject! ! !KomitDefinition methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:36'! isDefinition ^ true! ! !KomitDefinition methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/23/2013 21:36'! isCommitable ^ true! ! !KomitDefinition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 22:07'! koDestinationText ^ self operation koDestinationText! ! !KomitDefinition methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 17:50'! operation: anOperation operation := anOperation! ! !KomitDefinition class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/26/2013 14:28'! definition: definition ^ definitions at: definition className ifAbsentPut: [ super new definition: definition; yourself ]! ! !KomitDefinition class methodsFor: 'class initialization' stamp: 'BenjaminVanRyseghem 11/26/2013 14:29'! initialize definitions := Dictionary new! ! !KomitDefinition class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/26/2013 14:29'! new self shouldNotImplement! ! !KomitDefinitionNode commentStamp: ''! I am a node wrapping a KomitDefinition! !KomitDefinitionNode methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 15:31'! label ^ 'Class Definition'! ! !KomitDirectoryRemote commentStamp: ''! I encapsulate a gemstone repository! !KomitDirectoryRemote methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/30/2013 20:34'! label ^ self remote directory basename! ! !KomitDirectoryRemote class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/4/2013 10:16'! icon ^ 'DIR'! ! !KomitGemstoneRemote commentStamp: ''! I encapsulate a gemstone repository! !KomitGemstoneRemote methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/23/2013 13:24'! label | url | url := self remote location splitOn: '/'. ^ String streamContents: [ :stream | stream << (url at: 5) ]! ! !KomitGemstoneRemote class methodsFor: 'private-icons' stamp: 'BenjaminVanRyseghem 12/4/2013 09:54'! iconContents ^ #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 79642688 0 0 0 0 0 0 0 0 0 0 0 0 181154611 2260611104 3871289375 4273942303 3804180256 1975529505 67065173 0 0 0 0 0 0 0 0 0 2579378208 3955175455 1992175648 1086271520 2512400417 4290653983 2277453600 0 0 0 0 0 0 0 0 1237332255 4290653983 1690251297 0 0 0 3351195424 3988664095 0 0 0 90596966 2154326120 3714541415 4133971815 3630655335 2053727846 784086828 50299008 0 0 0 3334418464 3720228639 0 0 0 2271635046 4184237670 2305189478 1667721063 3026609766 4284900966 2238212200 0 0 33554431 1354706976 4290653983 2411671584 0 0 0 3731252838 2875680615 0 0 0 3563480678 3882313575 0 2461937439 3837669407 4290653983 2646486816 114644267 0 0 0 3311822438 4050085735 1281910888 0 0 493513322 610953834 97268531 3351195424 4273942303 4257099551 1321283873 0 0 0 0 912812136 4016465510 4284900966 3412551527 1248290663 0 0 0 0 566310439 3586011167 4189990688 398997281 0 0 0 0 375941224 2288478055 4066797158 4284900966 2355521126 0 0 0 0 1824468769 4290653983 1404973346 0 325806955 1567123560 661219689 0 0 342255206 3816119900 4201145957 309424497 0 0 0 1371549471 4290653983 1153380642 0 577333609 4284900966 2187748966 0 0 0 3684320829 4284900966 1147758953 0 0 0 3049140256 4072615712 280965152 0 61516458 3563480678 4117128806 1550280551 443313260 1181116006 3714867809 4285358945 2864460580 935211808 801321249 2797482016 4290653983 1707094049 0 0 0 610953834 2607179366 3848693350 4284900966 4251412327 3395708518 2141536822 4005506847 4290653983 4290653983 3904778016 1488924960 0 0 0 0 0 0 0 627533671 174483046 0 0 67065173 600126244 549400608 0 0 0 0 0)! ! !KomitHttpRemote commentStamp: ''! I encapsulate a gemstone repository! !KomitHttpRemote methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/30/2013 22:23'! label ^ self remote location! ! !KomitHttpRemote class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/4/2013 10:01'! icon ^ 'HTTP'! ! !KomitLeaf commentStamp: ''! I am an abstract class for tree leaves! !KomitLeaf methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/24/2013 13:46'! initialize super initialize. self children: [ #() ]. self hasContentToShow: true. self whenSelectedChanged: [ :aBoolean | self parentNode ifNotNil: [ :parent | parent checkChildren ] ]! ! !KomitLeaf methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2013 21:09'! icon self content added ifTrue: [ ^ Smalltalk ui icons changeAddIcon ]. self content modified ifTrue: [ ^ Smalltalk ui icons changeUpdateIcon ]. self content removed ifTrue: [ ^ Smalltalk ui icons changeRemoveIcon ]. ^ nil! ! !KomitMethod commentStamp: ''! Iam a komit object representing a change in a method! !KomitMethod methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 21:09'! operation ^ operation! ! !KomitMethod methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:36'! isMethod ^ true! ! !KomitMethod methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:24'! method: anObject method := anObject! ! !KomitMethod methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 16:25'! selector ^ self method selector! ! !KomitMethod methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:16'! koSourceText ^ self operation koSourceText! ! !KomitMethod methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/22/2013 12:45'! printOn: aStream super printOn: aStream. aStream << '[ '. self method selector printOn: aStream. aStream << ' ]'.! ! !KomitMethod methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 11/24/2013 21:26'! <= aKomitObject ^ self method selector <= aKomitObject method selector! ! !KomitMethod methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:24'! method ^ method! ! !KomitMethod methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/23/2013 21:36'! isCommitable ^ true! ! !KomitMethod methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:10'! koDestinationText ^ operation koDestinationText! ! !KomitMethod methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 17:50'! operation: anOperation operation := anOperation! ! !KomitMethod class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/25/2013 18:18'! method: aMethod ^ methods at: aMethod actualClass name, '>>', aMethod selector ifAbsentPut: [ super new method: aMethod; yourself ]! ! !KomitMethod class methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/25/2013 18:19'! initialize methods := Dictionary new! ! !KomitMethod class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/25/2013 18:18'! new self shouldNotImplement! ! !KomitMethodNode commentStamp: ''! I am a node in the Komit tree representing a method! !KomitMethodNode methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 15:31'! label ^ self content selector! ! !KomitNewSlice commentStamp: ''! I am a dummy object used to commit code in a new slice! !KomitNewSlice methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/23/2013 13:27'! label ^ 'New Slice'! ! !KomitNewSlice methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/28/2013 18:19'! remote ^ MCRepositoryGroup default repositories detect: [ :e | e description = 'http://smalltalkhub.com/mc/Pharo/Pharo30Inbox/main/' ] ifNone: [ MCRepositoryGroup default repositories detect: [ :e | e description = 'http://smalltalkhub.com/mc/Pharo/Pharo30Inbox/main' ] ]! ! !KomitNewSlice methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/26/2013 21:28'! komitOn: aKomitterUI ^ aKomitterUI newSliceFor: self! ! !KomitNewSlice class methodsFor: 'private-icons' stamp: 'BenjaminVanRyseghem 12/4/2013 10:14'! iconContents ^ #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 878481328 810847151 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777471 2675025349 4104046044 4273657575 4291485933 4273066469 3699684559 3027544004 2204605626 16777215 16777215 16777215 16777215 16777215 16777215 640645537 3160776898 4291354861 4291551726 3716264913 1012173739 16842751 16777215 16777215 978750380 2791414974 945196721 16777215 16777215 16777215 575769519 3329075401 4291289326 4290697962 2422513602 16777215 16777215 16777215 16777215 2320916567 3293601369 1147495763 3261834695 591956145 16777215 87254681 2574034116 4290304235 4290829548 2909316038 16777215 16777215 16777215 16777215 16777215 3555413791 4293216286 1559121695 222005936 3177291716 16842751 1110802091 4069573343 4290304235 4136681693 16842751 16777215 16777215 16777215 16777215 848892954 4288287511 4288352789 3349352981 16777215 2203227323 1951108536 1428453544 4288531431 4289713129 2674238409 16777215 16777215 16777215 16777215 127018020 1905009714 4287374383 4287439661 3381535020 831332138 103514282 2032959408 2435022259 4280453833 4282291914 826181037 16777215 16777215 16777215 16777215 16777215 2222863945 4286460999 4286526278 3699388996 394603587 16777215 1345290158 2770699192 4280388554 4279993794 253917098 16777215 16777215 16777215 16777215 16777215 745424483 4050666847 2473673822 325796689 16777215 16777215 1630043569 2804254141 4280388553 4279993794 388067238 16777215 16777215 16777215 16777215 16777215 1415665785 1063343477 426136186 2623886196 16777215 16777215 1176598699 2217050553 4263742667 4279861952 1596030389 16777215 16777215 16777215 16777215 16777215 190668194 2119525776 4065748366 3109512589 16777215 87254681 891452845 1277526197 3643182280 4279861952 3709699264 16777215 16777215 16777215 16777215 16777215 2353363113 3947329448 1766421925 71336127 87254681 404780458 50353578 16777215 2166720189 4279993539 4279598522 1981644726 16777215 16777215 16777215 16777215 2386069696 272662719 557222849 2788788160 1496416955 270565551 16777215 16777215 354711978 3877800390 4279466936 4229135544 924875698 16777215 16777215 16777215 959224536 2821429464 4213937877 3878195147 1646691773 16777215 16777215 16777215 16777215 321419694 3189736897 4279335349 4262557877 3374088124 1898086840 1579517631 4213805262 4179593413 3961752264 1294172342 16842751 16777215 16777215 16777215 16777215 16777215 16777215 908099249 3004989113 3726147258 4145380537 4145709502 3843784892 2552266682 757235120 16777215 16777215 16777215 16777215)! ! !KomitNode commentStamp: ''! I am an abstract class representing a node in the tree! !KomitNode methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 3/14/2014 12:11'! initialize silent := false. super initialize. self whenSelectedChanged: [ :aBoolean | self content selected: aBoolean ]. self whenIsExpandedChanged: [ :aBoolean | self content expanded: aBoolean ]. self whenContentChanged: [ :c | self silentWhile: [ self selected: c selected ]. self isExpanded: c expanded ]. self hasChildren: [ self children value isEmptyOrNil not ]! ! !KomitNode methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 12/7/2013 10:51'! hash ^ self content hash! ! !KomitNode methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 11/25/2013 16:49'! = anotherNode ^ self species = anotherNode species and: [ self content = anotherNode content ]! ! !KomitNode methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 20:36'! label self subclassResponsibility! ! !KomitNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/22/2013 13:30'! checkChildren self silentWhile: [ (self children value allSatisfy: [ :e | e selected ]) ifTrue: [ self selected: true ] ifFalse: [ self selected: false ] ]! ! !KomitNode methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 14:11'! ifNotSilentDo: aBlock silent ifFalse: aBlock! ! !KomitNode methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 13:30'! silentWhile: aBlock | oldSilent | oldSilent := silent. silent := true. aBlock value. silent := oldSilent! ! !KomitNode methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 11/24/2013 21:25'! <= aKomitNode ^ self content <= aKomitNode content! ! !KomitNode methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 20:37'! icon self subclassResponsibility! ! !KomitObject commentStamp: ''! I am an abstract super class keeping track of the state of the object (added/modified/removed)! !KomitObject methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:35'! isMethod ^ false! ! !KomitObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:24'! added: anObject added := anObject! ! !KomitObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2013 13:17'! selected: anObject selected := anObject! ! !KomitObject methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/23/2013 21:35'! isCommitable ^ false! ! !KomitObject methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:35'! isPackage ^ false! ! !KomitObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:24'! removed: anObject removed := anObject! ! !KomitObject methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 12/7/2013 10:56'! isKomitClass ^ false! ! !KomitObject methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/26/2013 14:27'! initialize super initialize. added := false. modified := false. removed := false. selected := true. expanded := false! ! !KomitObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2013 13:40'! expanded ^ expanded! ! !KomitObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:24'! modified: anObject modified := anObject! ! !KomitObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:24'! added ^ added! ! !KomitObject methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:35'! isDefinition ^ false! ! !KomitObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:24'! modified ^ modified! ! !KomitObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2013 13:40'! expanded: anObject expanded := anObject! ! !KomitObject methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 13:46'! flush added := false. modified := false. removed := false.! ! !KomitObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:24'! removed ^ removed! ! !KomitObject methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/21/2013 21:46'! isDirty ^ self added or: [ self modified or: [ self removed ] ]! ! !KomitObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2013 13:17'! selected ^ selected! ! !KomitObject methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 11/24/2013 21:25'! <= aKomitObject ^ self subclassResponsibility! ! !KomitPackage commentStamp: ''! I am a simple object used to cache the patch in order to save a bit of time! !KomitPackage methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 12/7/2013 10:51'! hash ^ self package hash! ! !KomitPackage methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/22/2013 16:48'! isEmpty ^ self package isEmpty! ! !KomitPackage methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/27/2013 16:50'! isFullyCommited ^ isFullyCommited! ! !KomitPackage methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/22/2013 16:14'! remotes ^ self package remotes! ! !KomitPackage methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:36'! isPackage ^ true! ! !KomitPackage methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 16:32'! classes ^ classes ifNil: [ | result p | p := self patch. p ifNil: [ #() ] ifNotNil: [ result := p operations collect: [ :each | each koClass ] thenSelect: [ :each | each notNil ]. classes := result asSet asOrderedCollection ] ]! ! !KomitPackage methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 22:26'! koDestinationText ^ ''! ! !KomitPackage methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/26/2013 10:22'! koSourceText ^ 'No changes'! ! !KomitPackage methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 12/9/2013 18:19'! initialize super initialize. expanded := true. isFullyCommited := true.! ! !KomitPackage methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/27/2013 16:50'! isFullyCommited: anObject isFullyCommited := anObject! ! !KomitPackage methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 11/24/2013 19:55'! = another ^ self species = another species and: [ self package = another package ]! ! !KomitPackage methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/27/2013 16:24'! package: aPackage package := aPackage. self retrievePatch! ! !KomitPackage methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:13'! printOn: aStream super printOn: aStream. aStream << '[ '. self package name printOn: aStream. aStream << ' ]'.! ! !KomitPackage methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:01'! package ^ package! ! !KomitPackage methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/9/2013 18:29'! retrievePatch dataRetriever ifNotNil: [ dataRetriever release ]. dataRetriever := DataRetriever for: [ self package patch ].! ! !KomitPackage methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/9/2013 18:20'! flush super flush. classes ifNotNil: [ classes do: [ :each | each flush ] ]. classes := nil. isFullyCommited := true. self retrievePatch! ! !KomitPackage methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/9/2013 18:29'! patch ^ dataRetriever data! ! !KomitPackage methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 11/24/2013 21:27'! <= aKomitObject ^ self package name <= aKomitObject package name! ! !KomitPackage class methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/25/2013 17:34'! initialize packages := Dictionary new! ! !KomitPackage class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/27/2013 13:42'! removePackage: package (packages removeKey: package package name ifAbsent: [ ^ self ]) flush! ! !KomitPackage class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/25/2013 17:36'! new self shouldNotImplement! ! !KomitPackage class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/25/2013 17:35'! package: package ^ packages at: package name ifAbsentPut: [ super new package: package; yourself ]! ! !KomitPackageNode commentStamp: ''! I am a node in the Komit tree representing a package! !KomitPackageNode methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 3/14/2014 12:06'! initialize super initialize. self icon: Smalltalk ui icons dirtyPackageIcon. self whenSelectedChanged: [ :aBoolean | self ifNotSilentDo: [ aBoolean ifTrue: [ self selectAllChildren ] ifFalse: [ self unselectAllChildren ] ] ]. self whenContentChanged: [ :c || childrenNode | childrenNode := self getClasses collect: [ :each | KomitClassNode new content: each; yourself ]. self children: [ childrenNode ] ]. self hasChildren: [ self isEmpty not ]! ! !KomitPackageNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/24/2013 14:17'! getClasses ^ self content classes! ! !KomitPackageNode methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 21:06'! label ^ self content package name! ! !KomitPackageNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/21/2013 15:55'! isEmpty ^ self content patch operations isEmpty! ! !KomitPackageNode methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 11/21/2013 14:13'! printOn: aStream super printOn: aStream. aStream << '[ '. self content package name printOn: aStream. aStream << ' ]'.! ! !KomitPackageNode methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 15:41'! icon ^ Smalltalk ui icons dirtyPackageIcon! ! !KomitPatch commentStamp: ''! I am a simple wrapper for patches! !KomitPatch methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 12:58'! operations ^ patch operations! ! !KomitPatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 12:51'! base: anObject base := anObject! ! !KomitPatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 13:40'! base ^ base ifNil: [ MCSnapshot empty ]! ! !KomitPatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 12:51'! patch: anObject patch := anObject! ! !KomitPatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 12:51'! patch ^ patch! ! !KomitPatch class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/26/2013 12:51'! base: base patch: patch ^ self new base: base; patch: patch; yourself! ! !KomitRemote commentStamp: ''! I am an abstract class representing a remote repository! !KomitRemote methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/26/2013 21:28'! komitOn: aKomitterUI ^ aKomitterUI newKomitFor: self! ! !KomitRemote methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 13:04'! password: aString self remote password: aString! ! !KomitRemote methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/23/2013 11:58'! remote: anObject remote := anObject! ! !KomitRemote methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/23/2013 12:05'! label ^ ''! ! !KomitRemote methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 13:04'! username: aString self remote user: aString! ! !KomitRemote methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/23/2013 11:58'! remote ^ remote! ! !KomitRemote methodsFor: 'as yet unclassified ' stamp: 'BenjaminVanRyseghem 12/4/2013 12:58'! password ^ self remote password! ! !KomitRemote methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 12:59'! username ^ self remote user! ! !KomitRemote methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 12/4/2013 09:59'! icon ^ self class icon! ! !KomitRemote class methodsFor: 'private-icons' stamp: 'BenjaminVanRyseghem 12/4/2013 10:59'! iconContents ^ nil! ! !KomitRemote class methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 12/4/2013 09:53'! icon self == KomitRemote ifTrue: [ ^ nil ]. ^ icon ifNil: [ icon := Pharo3UIThemeIcons form16x16FromContents: self iconContents ]! ! !KomitSliceUI commentStamp: ''! I am a UI used to retrieve a Slice title using its issue number! !KomitSliceUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/26/2013 23:44'! initializeWidgets issueNumber := self newTextInput. titleWidget := self newTextInput. loadingWidget := self instantiate: LoadingThenOk. titleWidget enabled: false; ghostText: 'Title'. issueNumber ghostText: 'Issue number'. issueNumber autoAccept: true; acceptBlock: [ :text | fork ifNotNil: [ fork terminate ]. loadingWidget loading. self valid: false. fork := [ | response | response := ZnEasy client url: 'http://bugs.pharo.org/issues/name/', text asString; get; response. self setTitleFrom: response ] fork ]. self focusOrder add: issueNumber! ! !KomitSliceUI methodsFor: 'initialization' stamp: 'DamienCassou 12/9/2013 14:31'! initializeDialogWindow: aWindow valid whenChangedDo: [ :b | aWindow toolbar okButton enabled: b ]. aWindow toolbar okButton enabled: false. issueNumber bindKeyCombination: Character cr control unix | $m control mac toAction: [ self valid ifTrue: [ aWindow triggerOkAction ] ]! ! !KomitSliceUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:16'! valid: aBoolean valid value: aBoolean! ! !KomitSliceUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 22:51'! titleWidget ^ titleWidget! ! !KomitSliceUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize super initialize. valid := false asValueHolder! ! !KomitSliceUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 22:51'! issueNumber ^ issueNumber! ! !KomitSliceUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 22:51'! loadingWidget ^ loadingWidget! ! !KomitSliceUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 00:10'! title ^ 'Retrieve Slice title'! ! !KomitSliceUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 13:05'! issueNumberText ^ issueNumber text! ! !KomitSliceUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/26/2013 22:59'! encodeTitle: aTitle | allowedCharacters | allowedCharacters := ($A to: $Z) , ($a to: $z) , ($0 to: $9) , (Array with: $-). ^ String streamContents: [ :stream | aTitle do: [ :character | (' _' includes: character) ifTrue: [ stream << '-' ] ifFalse: [ (allowedCharacters includes: character) ifTrue: [ stream << character ] ] ] ]! ! !KomitSliceUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:16'! valid ^ valid value! ! !KomitSliceUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2013 23:44'! setTitleFrom: aZnResponse aZnResponse isError ifTrue: [ titleWidget text: 'Error !!'. loadingWidget error ] ifFalse: [ titleWidget text: (self encodeTitle: aZnResponse entity string). self valid: true. loadingWidget ok ]! ! !KomitSliceUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 13:06'! titleText ^ titleWidget text! ! !KomitSliceUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:45'! initialExtent ^ 600@100! ! !KomitSliceUI class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/27/2013 12:50'! defaultSpec ^ SpecLayout composed newColumn: [ :col | col newRow: [ :row | row add: #loadingWidget width: self inputTextHeight; add: #issueNumber width: 90; add: #titleWidget ] height: self inputTextHeight; newRow: [ :row | ] ]; yourself! ! !KomitSmalltalkhubRemote commentStamp: ''! I encapsulate a repository stored on smalltalkhub! !KomitSmalltalkhubRemote methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/23/2013 13:02'! label | url | url := self remote location splitOn: '/'. ^ String streamContents: [ :stream | stream << (url at: 6) << ' / ' << (url at: 5) ]! ! !KomitSmalltalkhubRemote class methodsFor: 'private-icons' stamp: 'BenjaminVanRyseghem 12/4/2013 10:14'! iconContents ^ #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1337895822 3032592019 3972116374 4273842831 4022184072 3149833600 2106947668 50331392 0 0 0 0 531995755 2444926324 3686507133 4240221573 4290488201 4290685839 4290751632 4289698684 4288645481 4288578915 4289433963 4256536684 3837236839 2763494759 1018927462 0 3483597388 3937110112 4223245688 4290290046 4289895290 4288711276 4288974446 4289763703 4290421119 4290223480 4290288499 4290287725 4222324583 4068371018 4100083764 0 3533994827 4121066061 4121066060 4153109577 4170282839 4240286852 4290421118 4290684289 4290618237 4239431797 4102649431 4219235923 4284698929 4284830516 4116466476 0 3483729487 4189625722 4154884950 4154620491 4137777226 4104091212 4070144090 4070739057 4218775116 4284567861 4287661166 4290688939 4286147148 4285027894 3932180015 0 3399975248 4276543704 4241737137 4240945814 4189098089 4137909582 4086787651 4068962130 4284041774 4284896566 4291412920 4293453796 4290162076 4285225272 3646901294 0 3316154448 4276543446 4239429735 4258711991 4240682642 4259700438 4104090952 4068633164 4284567603 4285488704 4293454052 4293651176 4287660134 4285159478 3462286637 0 3232466517 4293123279 4256799860 4275555516 4222190677 4276280532 4137776970 4018498635 4284830771 4285356857 4292202696 4290490527 4288713597 4285093686 3361623341 0 3348789069 4276017097 4273907073 4275621052 4239034200 4276280532 4154620491 4018761292 4285027637 4285751100 4290293146 4293255900 4286737999 4285028150 3277473834 0 3281418061 4291871661 4292529854 4275489465 4239100249 4276280531 4154752591 4018761547 4285356600 4286014015 4292400332 4289568906 4290886575 4285028150 3377611305 33554432 3281088585 4289497949 4290156907 4275555513 4274763934 4293123540 4205149777 4102516555 4285553979 4285816891 4290161561 4293585125 4286673494 4284764980 3377216551 134217728 2204585011 4187519313 4289563743 4290222449 4289761381 4290882447 4272127057 4269827653 4285553979 4286870097 4293519588 4287265888 4285027896 4182851883 2134388254 33554432 335544320 1056964608 3075752747 4170281545 4289168469 4288905041 4288575564 4286473282 4285816895 4288120942 4287660391 4150086703 2804688407 1006632960 301989888 0 0 100663296 419430400 1124073472 2604346396 4035142719 4271666505 4269104443 4285291066 4015408939 2350848015 1006632960 369098752 67108864 0 0 0 0 0 67108864 335544320 973078528 2049318161 3243130149 1829768199 855638016 268435456 67108864 0 0 0)! ! !KomitSqueakSourceRemote commentStamp: ''! I encapsulate a repository stored on squeaksource! !KomitSqueakSourceRemote methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/23/2013 13:18'! label | url | url := self remote location splitOn: '/'. ^ String streamContents: [ :stream | stream << (url at: 4) ]! ! !KomitSqueakSourceRemote class methodsFor: 'private-icons' stamp: 'BenjaminVanRyseghem 12/4/2013 09:59'! iconContents ^ #(0 0 0 0 660364380 2203934045 3076283484 3931987293 3931987293 3076283484 2203934045 660364380 0 0 0 0 0 0 41975936 1968987228 4167065437 4286082392 4286936149 4287658835 4287658835 4286936149 4286082392 4167065437 1968987228 41975936 0 0 0 41975936 3109837916 4285228378 4287593043 4291076186 4291667804 4292127581 4292127837 4291667547 4291075931 4287593043 4285228378 3093126493 41975936 0 0 1968987228 4285228378 4271275346 4292062301 4293442400 4293381010 4292462761 4292397224 4293381010 4293507938 4292127837 4271275346 4285228378 1968987228 0 660364380 4167065437 4285883460 4283909670 4289762912 4294102666 4293774990 4293840784 4293840528 4293774991 4294037386 4290091618 4283778341 4286014789 4167065437 660364380 2220711261 4286082392 4286736698 4292524663 4286278471 4292591497 4294104990 4294104734 4294038942 4294104989 4292657289 4286804044 4292984698 4286473784 4286082392 2203934045 3076283484 4289039195 4289366087 4290749037 4293578128 4288712299 4294104995 4294104995 4294104995 4294104995 4288778091 4293577873 4290880621 4289300551 4289039195 3076283484 3931987293 4290945116 4292918906 4287461972 4294104477 4293776288 4284832325 4291671690 4292395154 4284634947 4293184153 4294104222 4287527764 4292853371 4290945115 3931987293 3931987293 4291273566 4294036614 4289829483 4294104737 4292263568 4280427042 4287857765 4289238385 4280887593 4290750848 4294038944 4289829228 4294036869 4291339356 3931987293 3076283484 4289762398 4292261495 4289434727 4286936408 4287397215 4287528544 4292460946 4292263568 4288843885 4289830520 4288580969 4290749812 4293510785 4289762398 3076283484 2203934045 4287791196 4288381524 4286015047 4285884492 4284108861 4285161032 4285884495 4284569153 4285095495 4283845946 4284897858 4286015303 4287264076 4287791196 2203934045 660364380 4167196765 4288709192 4291078000 4286278732 4290487932 4291408776 4294104995 4294104995 4289896312 4288580457 4285817928 4289434209 4288051780 4167197021 660364380 0 1968987228 4286280028 4277193860 4294037644 4294103702 4294038685 4294104993 4294170273 4294104221 4294038422 4294037389 4277259651 4286280029 1968987228 0 0 41975936 3109837916 4286411357 4292853630 4294037129 4294037902 4294103699 4294103186 4294103439 4294102922 4292853374 4286411357 3093126493 41975936 0 0 0 41975936 1968987228 4167262557 4288645727 4291079032 4293050753 4293051009 4291144311 4288645727 4167262557 1968987228 41975936 0 0 0 0 0 0 660364380 2203934045 3076283484 3931987293 3931987293 3076283484 2203934045 660364380 0 0 0 0)! ! !KomitStagingArea commentStamp: ''! I encapsulate the context just before a commit.! !KomitStagingArea methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/22/2013 16:30'! initialize super initialize. packages := OrderedCollection new.! ! !KomitStagingArea methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 19:58'! isCurrent ^ self == self class current! ! !KomitStagingArea methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/23/2013 23:34'! remotesFor: aCollection | result | result := aCollection first remotes. aCollection allButFirst do: [ :each | result := result intersection: each remotes ]. ^ result collect: [ :each | each koRemote ]! ! !KomitStagingArea methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/23/2013 21:00'! remotes | result | result := packages first remotes. packages allButFirst do: [ :each | result := result intersection: each remotes ]. ^ result collect: [ :each | each koRemote ]! ! !KomitStagingArea methodsFor: 'adding/removing' stamp: 'BenjaminVanRyseghem 11/26/2013 10:29'! removePackage: aKomitPackage self packages remove: aKomitPackage! ! !KomitStagingArea methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2013 14:19'! packages ^ packages copy! ! !KomitStagingArea methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2013 19:45'! packages: aCollection packages := aCollection asOrderedCollection! ! !KomitStagingArea methodsFor: 'adding/removing' stamp: 'BenjaminVanRyseghem 11/24/2013 19:45'! addPackage: aPackage (packages includes: aPackage) ifFalse: [ packages add: aPackage ]! ! !KomitStagingArea class methodsFor: 'instance creation' stamp: 'ChristopheDemarey 1/9/2014 15:05'! currentFilteredBy: aFilterBlock ^ current ifNil: [ | dirtyPackages | dirtyPackages := MCWorkingCopy allManagers select: [ :workingCopy | workingCopy needsSaving and: (aFilterBlock cull: workingCopy) ] thenCollect: [ :workingCopy | (KomitPackage package: workingCopy package) flush; yourself ]. current := super new packages: dirtyPackages; yourself ]! ! !KomitStagingArea class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/25/2013 17:38'! new self shouldNotImplement! ! !KomitStagingArea class methodsFor: 'instance creation' stamp: 'ChristopheDemarey 1/9/2014 15:05'! current ^ self currentFilteredBy: [ true ]! ! !KomitStagingArea class methodsFor: 'release' stamp: 'BenjaminVanRyseghem 11/24/2013 19:58'! resetCurrent current := nil! ! !KomitTreeBuilder commentStamp: ''! I am builder class used to generate the tree nodes for a package or for all the dirty packages! !KomitTreeBuilder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/23/2013 11:55'! buildRootForPackage: aPackage ^ KomitPackageNode new content: aPackage; yourself! ! !KomitTreeBuilder class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/25/2013 17:53'! rootsForStagingArea: aStagingArea ^ aStagingArea packages collect: [ :each | self buildRootForPackage: each ] thenSelect: [:each | each isEmpty not ]! ! !KomitTreeBuilder class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 16:48'! buildRootForPackage: aKOPackage ^ self new buildRootForPackage: aKOPackage! ! !KomitableObject commentStamp: ''! I represent any commitable object, mainly a simple commit or a slice! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! timestamp: anObject timestamp := anObject! ! !KomitableObject methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 13:02'! commitToMonticello Komitter resetLastMessage. KomitStagingArea resetCurrent. MCKomitSubmitter new submitCommit: self! ! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! remote: anObject remote := anObject! ! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! message: anObject message := anObject! ! !KomitableObject methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 21:08'! repository ^ self remote remote! ! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! author: anObject author := anObject! ! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! entities ^ entities! ! !KomitableObject methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! initialize super initialize. author := Author fullName. entities := Dictionary new. unselectedEntities := Dictionary new. message := ''. timestamp := DateAndTime now.! ! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! entities: aDictionary entities := aDictionary! ! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! unselectedEntities: anObject unselectedEntities := anObject! ! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! author ^ author! ! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! timestamp ^ timestamp! ! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! message ^ message! ! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! remote ^ remote! ! !KomitableObject methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 20:29'! unselectedEntities ^ unselectedEntities! ! !Komitter commentStamp: ''! I am the entry point of this project. A classic inkoation is | s k | s := KomitStagingArea forDirtyPackages. k := Komitter new. k stagingArea: s. k open. k lastCommit ! !Komitter methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 11/25/2013 17:15'! classMoved: anAnnouncement self stagingArea isCurrent ifFalse: [ ^ self ].! ! !Komitter methodsFor: 'opening' stamp: 'BenjaminVanRyseghem 12/4/2013 17:06'! openAndDo: aBlock self stagingArea packages ifEmpty: [ ^ self inform: 'No changes to commit' ]. view ifNil: [ view := KomitterUI new model: self; yourself ]. view openDialogWithSpec okAction: [ | valid | valid := view validate. valid ifTrue: [ self lastCommit: view komit ]. aBlock value. valid ]; cancelAction: [ self lastCommit: nil. view cancel ]; centered! ! !Komitter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 19:27'! remotesFor: aCollection ^ (self stagingArea remotesFor: aCollection) asOrderedCollection add: self newSlice; yourself! ! !Komitter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/23/2013 20:53'! remotes ^ self stagingArea remotes asOrderedCollection add: self newSlice; yourself! ! !Komitter methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 11/25/2013 17:15'! methodMoved: anAnnouncement self stagingArea isCurrent ifFalse: [ ^ self ].! ! !Komitter methodsFor: 'opening' stamp: 'BenjaminVanRyseghem 12/4/2013 17:06'! openAndCommitToMonticello self openAndDo: [ self lastCommit ifNotNil: [ self lastCommit commitToMonticello ]]! ! !Komitter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/23/2013 20:53'! newSlice ^ KomitNewSlice new! ! !Komitter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/23/2013 20:35'! stagingArea: anObject stagingArea value: anObject! ! !Komitter methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 11/25/2013 17:15'! methodRemoved: anAnnouncement self stagingArea isCurrent ifFalse: [ ^ self ].! ! !Komitter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize super initialize. stagingArea := nil asValueHolder. lastCommit := nil asValueHolder. "self registerToAnnouncements"! ! !Komitter methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 11/25/2013 17:15'! methodModified: anAnnouncement self stagingArea isCurrent ifFalse: [ ^ self ].! ! !Komitter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 13:00'! lastMessage ^ self class lastMessage! ! !Komitter methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 11/25/2013 17:15'! classRemoved: anAnnouncement self stagingArea isCurrent ifFalse: [ ^ self ].! ! !Komitter methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 11/25/2013 17:07'! registerToAnnouncements SystemAnnouncer uniqueInstance weak on: MCPackageModified send: #mcPackageModified: to: self; on: ClassAdded, ClassModifiedClassDefinition, ClassRenamed, ClassCommented send: #classModified: to: self; on: ClassRepackaged send: #classMoved: to: self; on: ClassRemoved send: #classRemoved: to: self; on: MethodAdded, MethodModified, MethodRecategorized send: #methodModified: to: self; on: MethodRepackaged send: #methodMoved: to: self; on: MethodRemoved send: #methodRemoved: to: self! ! !Komitter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/23/2013 22:10'! lastCommit ^ lastCommit value! ! !Komitter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/23/2013 22:10'! lastCommit: aKomit lastCommit value: aKomit! ! !Komitter methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 11/25/2013 16:45'! mcPackageModified: anAnnoucement | package | self stagingArea isCurrent ifFalse: [ ^ self ]. package := anAnnoucement package koPackage. package patch isEmpty ifTrue: [ self stagingArea removePackage: package ] ifFalse: [ self stagingArea addPackage: package ]. view ifNil: [ ^ self ]. package patch isEmpty ifTrue: [ view removeRoot: package ] ifFalse: [ view addRoot: package ]! ! !Komitter methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 11/25/2013 17:15'! classModified: anAnnouncement self stagingArea isCurrent ifFalse: [ ^ self ].! ! !Komitter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/4/2013 17:57'! stagingArea ^ stagingArea value ! ! !Komitter class methodsFor: 'icon' stamp: 'EstebanLorenzano 12/13/2013 14:45'! taskbarIcon ^ Smalltalk ui icons komitterIcon! ! !Komitter class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 12:59'! lastMessage: aString lastMessage := aString! ! !Komitter class methodsFor: 'world menu' stamp: 'BenjaminVanRyseghem 12/4/2013 18:14'! initialize World bindKeyCombination: $k command toAction: [ self openAndCommitToMonticello ]! ! !Komitter class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 12:59'! lastMessage ^ lastMessage ifNil: [ MCSaveVersionDialog previousMessages first ]! ! !Komitter class methodsFor: 'protocol' stamp: 'ChristopheDemarey 1/9/2014 15:23'! openAndCommitToMonticelloWorkingCopiesFilteredBy: aFilterBlock | stagingArea | KomitStagingArea resetCurrent. stagingArea := KomitStagingArea currentFilteredBy: aFilterBlock. ^ self new stagingArea: stagingArea; openAndCommitToMonticello; yourself! ! !Komitter class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 18:13'! openAndCommitToMonticello KomitStagingArea resetCurrent. ^ self new stagingArea: KomitStagingArea current; openAndCommitToMonticello; yourself! ! !Komitter class methodsFor: 'world menu' stamp: 'TorstenBergmann 2/12/2014 09:24'! komitterMenuOn: aBuilder (aBuilder item: #Komitter) action: [ self openAndCommitToMonticello ]; order: 0.29; parent: #Tools; help: 'Cherry pick what you commit'; icon: self taskbarIcon. aBuilder withSeparatorAfter. ! ! !Komitter class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 12:59'! resetLastMessage lastMessage := nil! ! !KomitterManager commentStamp: ''! I am used to temporarily store a version for a package while a cherry-picked slice is committed! !KomitterManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/6/2013 21:18'! reset versions := Dictionary new! ! !KomitterManager methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 12/6/2013 21:17'! initialize super initialize. versions := Dictionary new.! ! !KomitterManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/6/2013 21:16'! versionFor: aPackage ^ versions at: aPackage! ! !KomitterManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/6/2013 21:16'! storeVersion: aVersion for: aPackage versions at: aPackage put: aVersion! ! !KomitterManager class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/6/2013 21:15'! current ^ instance ifNil: [ instance := super new ]! ! !KomitterManager class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 12/6/2013 21:15'! new ^ self shouldNotImplement! ! !KomitterUI commentStamp: ''! I am a new UI to help Pharo coder to save their code with a finer granularity that a whole package! !KomitterUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/22/2013 17:26'! checkCommit ^ checkCommit! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 20:21'! validate self commitableEntities ifEmpty: [ tree takeKeyboardFocus. self inform: 'The selection should contain commitable entities'. ^ false ]. message accept. ^ true! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 15:28'! cancel message accept. Komitter lastMessage: message text! ! !KomitterUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 10:27'! commitMessage ^ commitMessage! ! !KomitterUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/22/2013 16:58'! remotes ^ remotes! ! !KomitterUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2013 12:28'! uncommittedCommitableEntitied | map | map := Dictionary new. tree roots select: [ :e | e isPartialMatch ] thenDo: [ :e || nodes | nodes := e allUnselectedItems collect: [ :each | each content ] thenSelect: [ :each | each isCommitable ]. nodes ifNotEmpty: [ map at: e content put: nodes ] ]. ^ map! ! !KomitterUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/26/2013 20:14'! populateRemotes remotes items: self model remotes asOrderedCollection; displayBlock: [ :each | each label ]; iconHolder: [ :each | each icon ]! ! !KomitterUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/30/2013 19:27'! manageRemotes ^ manageRemotes! ! !KomitterUI methodsFor: 'private-icons' stamp: 'BenjaminVanRyseghem 11/30/2013 19:26'! historyIcon ^ self class historyIcon! ! !KomitterUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/26/2013 10:16'! populateTreeFor: newModel | roots | roots := (KomitTreeBuilder rootsForStagingArea: newModel stagingArea) asOrderedCollection sorted. tree loading: false. tree beCheckList; roots: roots; expandAll; collapseAll; expandRoots. self initializeLatelyPresenter. canCommit value: true.! ! !KomitterUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 10:27'! previousMessages ^ previousMessages! ! !KomitterUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize model := nil asValueHolder. canCommit := false asValueHolder. super initialize. model whenChangedDo: [ :m | [ self populateTreeFor: m ] fork. message text: m lastMessage. self populateRemotes ]! ! !KomitterUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/27/2013 15:29'! chooseFromPreviousMessages | list index | list := MCSaveVersionDialog previousMessages collect: [:s | s truncateWithElipsisTo: 80 ]. list ifEmpty: [ UIManager default inform: 'No previous log message was entered'. ^ self ]. index := UIManager default chooseFrom: list. "no comment was selected" index isZero ifTrue: [ ^ self ]. message text: (MCSaveVersionDialog previousMessages at: index); takeKeyboardFocus! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 15:16'! title ^ 'Commit changes'! ! !KomitterUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 10:27'! message ^ message! ! !KomitterUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/23/2013 23:39'! populateRemotesFor: aCollection remotes items: (self model remotesFor: aCollection) asOrderedCollection; displayBlock: [ :each | each label ]; iconHolder: [ :each | each icon ]! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 14:52'! initialExtent ^ (700@550)! ! !KomitterUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/22/2013 14:39'! authorName ^ authorName! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 21:25'! komit "Gather all the data and create a Komit object out of them" ^ remotes selectedItem komitOn: self! ! !KomitterUI methodsFor: 'private-icons' stamp: 'BenjaminVanRyseghem 11/30/2013 19:40'! manageRemotesIcon ^ self class manageRemotesIcon! ! !KomitterUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/23/2013 23:40'! updateRemotes | roots | roots := tree roots select: [ :e | e isPartialMatch ] thenCollect: [ :e | e content ]. roots ifEmpty: [ self populateRemotes ] ifNotEmpty: [ self populateRemotesFor: roots ]! ! !KomitterUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/21/2013 21:16'! leftTextFor: aKOObject aKOObject ifNil: [ ^ '' ]. ^ aKOObject koSourceText! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 21:26'! newKomitFor: aRemote "Gather all the data and create a Komit object out of them" ^ Komit new message: message text; author: author text; timestamp: DateAndTime now; entities: self commitableEntities; unselectedEntities: self uncommittedCommitableEntitied; remote: aRemote; yourself! ! !KomitterUI methodsFor: 'initialization' stamp: 'DamienCassou 12/9/2013 14:31'! initializeDialogWindow: aWindow self bindKeyCombination: (Character cr control unix | $m control mac) toAction: [ aWindow triggerOkAction ]. aWindow toolbar okButton enabled: canCommit value. canCommit whenChangedDo: [ :b | aWindow toolbar okButton enabled: b ]. self focusOrder removeAll; add: message; add: remotes; add: aWindow toolbar; add: tree; add: previousMessages! ! !KomitterUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 12/6/2013 20:38'! initializeWidgets tree := self instantiate: TreeWithLoading. diff := self instantiate: DiffModel. message := self newText. author := self newTextInput. authorName := self newLabel. commitMessage := self newLabel. remotes := self newDropList. remoteLabel := self newLabel. checkCommit := self newCheckBox. previousMessages := self newButton. manageRemotes := self newButton. tree removeOnlyLastSelected: true; autoMultiSelection: true; columns: { TreeColumnModel new displayBlock: [:node | node label ] }. diff showOptions: false; leftText: 'No selection for diff'. authorName label: 'Author:'. commitMessage label: 'Commit message:'. remoteLabel label: 'Remote:'. checkCommit label: 'Check Lint rules (NOT YET WORKING)'; labelClickable: true; state: false; enabled: false. author text: Author fullNamePerSe; autoAccept: true. previousMessages icon: self historyIcon; action: [ self chooseFromPreviousMessages ]; bindKeyCombination: Character space asKeyCombination toAction: [ previousMessages action value ]; help: 'Previous messages'. message bindKeyCombination: Character tab asKeyCombination toAction: [ self giveFocusToNextFrom: message ]; bindKeyCombination: Character tab shift toAction: [ self giveFocusToPreviousFrom: message ]; wantsVisualFeedback: false. manageRemotes icon: self manageRemotesIcon; action: [ self openRemoteManager ]; help: 'Open the remotes manager'. self whenBuiltDo: [ checkCommit labelOnLeft. diff showOnlySource: true. message selectAll. self updateRemotes ].! ! !KomitterUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 10:27'! remoteLabel ^ remoteLabel! ! !KomitterUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 12/7/2013 10:56'! initializeLatelyPresenter tree whenHighlightedItemChanged: [ :node || item | item := node ifNil: [ nil ] ifNotNil: [ node content ]. diff leftText: (self leftTextFor: item); rightText: (self rightTextFor: item). (item isNil or: [ item added ]) ifTrue: [ diff showOnlyDestination: true ] ifFalse: [ ( item removed or: [ item isPackage or: [ (item isKomitClass and: [ item isDirty not ]) ] ] ) ifTrue: [ diff showOnlySource: true ] ifFalse: [ diff showBoth ] ] ]. tree whenSelectedItemsChanged: [ self updateRemotes ]! ! !KomitterUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/27/2013 16:57'! commitableEntities | map | map := Dictionary new. tree roots do: [ :e || nodes | e content isFullyCommited: e selected. nodes := e allSelectedItems collect: [ :each | each content ] thenSelect: [ :each | each isCommitable ]. nodes ifNotEmpty: [ map at: e content put: nodes ] ]. ^ map! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 15:40'! roots: aCollection tree roots: aCollection! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 21:26'! newSliceFor: aRemote "Gather all the data and create a Komit object out of them" ^ Slice new message: message text; author: author text; timestamp: DateAndTime now; entities: self commitableEntities; unselectedEntities: self uncommittedCommitableEntitied; remote: aRemote; yourself! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/23/2013 20:33'! model ^ model value! ! !KomitterUI methodsFor: 'private' stamp: 'ChristopheDemarey 1/8/2014 16:53'! openRemoteManager | view | view := PackageRemotesManager new packages: (tree roots collect: [ :e | self remoteNodeFor: e ]). view openDialogWithSpec centered; modalRelativeTo: self window! ! !KomitterUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/22/2013 14:33'! author ^ author! ! !KomitterUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 15:39'! tree ^ tree! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 21:23'! addRoot: aPackage | aPackageNode | aPackageNode := KomitTreeBuilder buildRootForPackage: aPackage. tree roots: (tree roots add: aPackageNode; sorted)! ! !KomitterUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/6/2013 18:40'! remoteNodeFor: e ^ TreeNodeModel new content: e content package workingCopy! ! !KomitterUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 17:15'! diff ^ diff! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 10:26'! removeRoot: aKomitPackage | roots highlight | highlight := tree highlightedItem. roots := tree roots. roots remove: (KomitPackageNode new content: aKomitPackage; yourself). tree roots: roots. highlight takeHighlight! ! !KomitterUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/21/2013 21:10'! rightTextFor: aKOObject aKOObject ifNil: [ ^ '' ]. ^ aKOObject koDestinationText! ! !KomitterUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/23/2013 20:37'! model: aModel model value: aModel! ! !KomitterUI class methodsFor: 'specs' stamp: 'MarcusDenker 4/15/2014 17:06'! defaultSpec ^ SpecLayout composed newRow: [ :row | row newColumn: [ :c1 | c1 add: #tree; newRow: [ :r | r newColumn: [ :c | c newRow: [ :row1 | row1 add: #commitMessage; add: #previousMessages width: self buttonHeight ] height: self buttonHeight; add: #message ]; newColumn: [ :c | c newRow: [:r1 | ] height: self buttonHeight; newRow: [ :r1 | r1 add: #authorName width: 50; add: #author ] height: self inputTextHeight +4 ; "add: #checkCommit height: self buttonHeight;" newRow: [ :r1 | r1 add: #remoteLabel width: 50; add: #remotes; add: #manageRemotes width: self buttonHeight ] height: self buttonHeight ] width: 250 ] height: (4*self buttonHeight + 12) ] ] bottom: 0.4; addHSplitter; newRow: [ :row | row add: #diff ] top: 0.6; yourself! ! !KomitterUI class methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 11/27/2013 17:32'! taskbarIcon ^ Komitter taskbarIcon! ! !KomitterUI class methodsFor: 'private-icons' stamp: 'BenjaminVanRyseghem 11/25/2013 20:13'! historyIconData ^ #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4286673726 4286673726 4286673726 4286673726 4286673726 0 0 0 4278217148 4278217148 4278217148 4278217148 4286673726 4286673726 0 0 4288516712 4294967295 4294967295 4294967295 4294967295 4286673726 4286673726 4278217148 4286104319 4286104319 4286104319 4278217148 4294967295 4288516712 4284839308 0 4288516712 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4278217148 4286104319 4286104319 4286104319 4278217148 4294967295 4288516712 4284839308 0 4288253803 4294967295 4291942109 4291482074 4294967295 4294967295 4294967295 4278217148 4286104319 4286104319 4286104319 4278217148 4294967295 4288253803 4284839308 0 4287925358 4294967295 4294967295 4294967295 4290759126 4290759126 4294967295 4278217148 4286038527 4286038527 4286039039 4278217148 4294967295 4287925358 4284707465 0 4287465586 4294705151 4291942109 4291482074 4294705151 4294705151 4294705151 4278216120 4285971967 4285971967 4285971967 4278216633 4294705151 4287465586 4284444294 0 4287005814 4294376959 4294376959 4294376959 4290759126 4290759126 4294376959 4278215349 4285840127 4285840127 4285840127 4278215862 4294376959 4287005814 4284115330 0 4286480763 4294114047 4291942109 4291482074 4294114047 4294114047 4294114047 4278214064 4285708287 4285643519 4285708799 4278214319 4294114047 4286480763 4283786365 0 4286086271 4293785343 4293785343 4293785343 4290759126 4290759126 4293785343 4278213034 4285641983 4285641983 4285641983 4278213034 4293785343 4286086271 4283391608 0 4285626499 4293522687 4293522687 4293522687 4293522687 4293522687 4293522687 4278211492 4285444351 4285378815 4285378815 4278212003 4293457151 4285626499 4283062642 0 4285298055 4285298055 4285298055 4285298055 4285298055 4293325311 4293325311 4278210466 4285116671 4285116671 4285181951 4278210465 4285298055 4285298055 4282733421 0 0 4282207077 4282207077 4282207077 4285035401 4285035401 4285035401 4278209949 4284918783 4284786943 4284787455 4278209949 4282141286 4282207077 4282207078 0 0 0 0 0 4282141542 4282009699 4282009699 4278209949 4284721919 4278209949 4284525311 4278209949 0 0 0 0 0 0 0 0 0 0 0 4278209949 4278209949 0 4278209949 4278209949 0 0 0 0 0 0 0 0 0 0 0 0 4278209949 0 0 4278209949 0 0 0)! ! !KomitterUI class methodsFor: 'icons' stamp: 'EstebanLorenzano 12/13/2013 14:45'! historyIcon ^ Smalltalk ui icons historyIcon ! ! !KomitterUI class methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 11/30/2013 19:40'! manageRemotesIcon ^ manageRemotesIcon ifNil: [ manageRemotesIcon := Pharo3UIThemeIcons form16x16FromContents: self manageRemotesData ]! ! !KomitterUI class methodsFor: 'private-icons' stamp: 'BenjaminVanRyseghem 11/30/2013 19:39'! manageRemotesData ^ #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4289496358 4289430823 0 0 0 0 0 0 0 0 0 0 0 0 0 4288970530 4294967295 4294957713 4289035810 0 0 0 0 0 0 0 0 4290811960 4290811960 4292065140 4288509724 4294832859 4294957713 4291666516 4289035810 0 0 0 0 0 0 0 4290549045 4294967295 4294957713 4287918102 4294832859 4294957713 4291666516 4287983638 0 0 0 0 0 0 0 4290285617 4294832859 4294957713 4287523346 4294832859 4294957713 4291666516 4287523089 0 0 0 0 0 0 0 4289956651 4294832859 4294957713 4291473003 4287194382 4294957713 4291666516 4287194382 4290811960 0 0 0 0 0 0 4289561893 4294832859 4294957713 4289562149 0 0 4287194382 4287194382 4294832859 4288706584 0 0 0 0 0 4289232928 4294832859 4294957713 4290946659 0 0 0 4290811960 4294832859 4294957713 4288706584 0 0 0 0 0 4288903963 4294957713 4289496358 4289430823 0 0 4290482995 4294832859 4294957713 4288706584 0 0 0 0 0 0 4290617694 4288970530 4294967295 4294957713 4289035810 4290022444 4294832859 4294957713 4288706584 0 0 0 0 0 0 0 4288509724 4294832859 4294957713 4291666516 4289035810 4294832859 4294957713 4288706584 0 0 0 0 0 0 0 4287918102 4294832859 4294957713 4291666516 4287983638 4294832859 4294957713 4288706584 0 0 0 0 0 0 0 4287523346 4294832859 4294957713 4291666516 4287523089 4288706584 4288706584 4288706584 0 0 0 0 0 0 0 0 4287194382 4294957713 4291666516 4287194382 0 0 0 0 0 0 0 0 0 0 0 0 0 4287194382 4287194382 0 0 0 0 0 0 0 0 0 0 0 0)! ! !KonamiCodePlugin commentStamp: ''! A KonamiCodePlugin is a plugin which run an action when the Konami code is entered! !KonamiCodePlugin methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 5/12/2011 17:22'! initialize super initialize. lastKeystrokeTime := 0. ! ! !KonamiCodePlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/4/2011 15:35'! keyPressed: ann | aChar milliSeconds slowKeyStroke | aChar := ann key keyCharacter. milliSeconds := Time millisecondClockValue. slowKeyStroke := milliSeconds - lastKeystrokeTime > 500. lastKeystrokeTime := milliSeconds. slowKeyStroke ifTrue: ["forget previous keystrokes and search in following elements" lastKeystrokes := aChar asLowercase asString.] ifFalse: ["append quick keystrokes but don't move selection if it still matches" lastKeystrokes := lastKeystrokes , aChar asLowercase asString.]. "Get rid of blanks and style used in some lists" lastKeystrokes = self konamiCode ifTrue: [ self openKonamiCode ].! ! !KonamiCodePlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/4/2011 15:44'! konamiCode ^ code ifNil: [ code := ''. { Character arrowUp. Character arrowUp. Character arrowDown. Character arrowDown. Character arrowLeft. Character arrowRight. Character arrowLeft. Character arrowRight. $b. $a } do: [:char | code := code, char asLowercase asString ]. code] ! ! !KonamiCodePlugin methodsFor: 'private' stamp: 'CamilleTeruel 12/6/2013 14:53'! openKonamiCode [ 15 timesRepeat: [ self inform: 'Congratulations: you found the Konami code!!!!!!!!!!'. (Delay forMilliseconds: 50) wait. ]] fork. ! ! !KoreanEnvironment commentStamp: ''! This class provides the Korean support. Unfortunately, we haven't tested this yet. We did have a working version in previous implementations, but not this new implementation. But as soon as we find somebody who understand the language, probably we can make it work in two days or so, as we have done for Czech support.! !KoreanEnvironment class methodsFor: 'subclass responsibilities' stamp: 'cami 7/22/2013 18:25'! systemConverterClass | encoding | Smalltalk os isWin32 ifTrue: [^EUCKRTextConverter]. Smalltalk os isMacOS ifTrue: [^UTF8TextConverter]. Smalltalk os isUnix ifTrue: [encoding := X11Encoding encoding. encoding ifNil: [^EUCKRTextConverter]. (encoding = 'utf-8') ifTrue: [^UTF8TextConverter]. ^EUCKRTextConverter]. ^UTF8TextConverter! ! !KoreanEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 18:42'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." ^#('ko' )! ! !KoreanEnvironment class methodsFor: 'class initialization' stamp: 'StephaneDucasse 8/22/2013 14:30'! initialize EncodedCharSet declareEncodedCharSet: self atIndex: 7+1.! ! !KoreanEnvironment class methodsFor: 'subclass responsibilities' stamp: 'janggoon 11/4/2008 22:11'! leadingChar ^ 7! ! !KoreanEnvironment class methodsFor: 'language methods' stamp: 'yo 3/16/2004 14:50'! traditionalCharsetClass ^ KSX1001. ! ! !LIFOQueue commentStamp: 'Igor.Stasenko 10/16/2010 03:58'! This is a thread-safe LIFO (last-in-first-out) queue (also known as stack) implementation, based on atomic operations. ! !LIFOQueue methodsFor: 'initialization' stamp: 'Igor.Stasenko 10/16/2010 03:37'! initialize | dummy | dummy := self newItem. dummy next: nil; object: dummy. head := dummy.! ! !LIFOQueue methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/16/2010 04:39'! nextIfNone: aBlock | dummy tail | dummy := self newItem. dummy object: dummy. tail := head. head := dummy. "skip over dummies" [ tail object == tail ] whileTrue: [ [ tail isCircular ] whileTrue: [ self yield ]. (tail := tail next) ifNil: [ dummy next: nil. dummy == head ifTrue: [ self signalNoMoreItems]. ^ aBlock value ] ]. dummy next: tail next. ^ tail object ! ! !LIFOQueue methodsFor: 'stack-compliant protocol' stamp: 'Igor.Stasenko 10/16/2010 04:02'! pop ^ self nextIfNone: [ self errorEmptyStack ]! ! !LIFOQueue methodsFor: 'stack-compliant protocol' stamp: 'Igor.Stasenko 10/16/2010 04:03'! errorEmptyStack self error: 'this stack is empty'! ! !LIFOQueue methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/16/2010 04:39'! next | dummy tail | dummy := self newItem. dummy object: dummy. "this is atomic" tail := head. head := dummy. "skip over dummies" [ tail object == tail ] whileTrue: [ [ tail isCircular ] whileTrue: [ self yield ]. (tail := tail next) ifNil: [ | result | "queue is empty. block until new items appear" head == dummy ifTrue: [ self signalNoMoreItems ]. [ head == dummy ] whileTrue: [ self waitForNewItems ]. dummy next: nil. result := self next. ^ result ] ]. dummy next: tail next. ^ tail object ! ! !LIFOQueue methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/16/2010 04:42'! nextPut: anObject | newItem oldHead | newItem := self newItem. newItem object: anObject. "this is atomic" oldHead := head. head := newItem. newItem next: oldHead. self signalAddedNewItem. ^ anObject! ! !LIFOQueue methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/16/2010 04:34'! fastPeek "Answer a top-most value without removing it from queue. Answer nil, if queue is empty or currently blocked by other process, which reading from queue" | item result | item := head. [ (result := item object) == item ] whileTrue: [ item isCircular ifTrue: [ ^ nil ]. (item := item next) ifNil: [ ^ nil ] ]. ^ result! ! !LIFOQueue methodsFor: 'stack-compliant protocol' stamp: 'Igor.Stasenko 10/16/2010 04:01'! push: anObject ^ self nextPut: anObject! ! !LIFOQueue methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/16/2010 03:51'! nextOrNil ^ self nextIfNone: [ nil ]! ! !LIFOQueue methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/16/2010 04:38'! peek "answer a top-most value without removing it, or nil, if queue is empty. May block if there's another process reading from queue" | item result | item := head. [ (result := item object) == item ] whileTrue: [ [ item isCircular ] whileTrue: [ self yield ]. (item := item next) ifNil: [ ^ nil ] ]. ^ result! ! !LIFOQueueTests commentStamp: 'TorstenBergmann 2/20/2014 15:30'! SUnit tests for LIFO queues! !LIFOQueueTests methodsFor: 'testing' stamp: 'Igor.Stasenko 10/16/2010 04:46'! testBasics | q | q := self newQueue. q nextPut: 5. self assert: q next = 5. q nextPut: 10. self assert: q nextOrNil = 10. self assert: q nextOrNil == nil! ! !LIFOQueueTests methodsFor: 'testing' stamp: 'Igor.Stasenko 10/16/2010 04:46'! testHeavyContention "run 10 threads, pushing new values to queue, and 10 threads pullung values from queue, at random priorities" | q sema prio pusher feeder feeders r crit done count | r := Random new. q := self newQueue. feeders := OrderedCollection new. count := 0. sema := Semaphore new. crit := Semaphore forMutualExclusion. done := Semaphore new. prio := Processor activePriority. pusher := [ sema wait. 1 to: 100 do: [:i | q nextPut: i ]. ]. feeder := [ sema wait. [ q nextOrNil ifNotNil: [ crit critical: [count := count + 1 ]]. Processor yield. count < 1000 ] whileTrue. done signal ]. 10 timesRepeat: [ | proc | proc := pusher newProcess priority: prio + (r next * 10) asInteger. proc resume. "run feeders at lower priority, otherwise they won't give a chance pushers to complete, because queue doesn't blocks the process" proc := feeder newProcess priority: prio + (r next * 10) asInteger - 10. feeders add: proc. proc resume. ]. " let them run " 20 timesRepeat: [ sema signal ]. Processor yield. done waitTimeoutSeconds: 10. feeders do: [:ea | ea terminate ]. self assert: (count = 1000 ). self assert: q nextOrNil == nil! ! !LIFOQueueTests methodsFor: 'testing' stamp: 'Igor.Stasenko 10/16/2010 04:44'! testContention1 "here is a test case that breaks the standard SharedQueue from Squeak 3.8" | q r1 r2 | q := self newQueue. q nextPut: 10. q nextPut: 5. self should: [ q nextOrNil = 5 ]. [ r1 := q next ] fork. [ r2 := q next ] fork. Processor yield. "let the above two threads block" q nextPut: 10. Processor yield. self should: [ r1 = 10 ]. self should: [ r2 = 10 ]. self should: [ q nextOrNil = nil ]. ! ! !LIFOQueueTests methodsFor: 'instance creation' stamp: 'Igor.Stasenko 10/16/2010 04:41'! newQueue ^ LIFOQueue new! ! !LRUCache commentStamp: ''! I am LRUCache. I am a Cache. I am a limited cache that evicts the least recently used entries. My implementation is properly O(1). Implementation Notes The key/value pairs in the cache are held as Associations in a DoubleLinkedList, lruList, ordered from least to most recently used. The keyIndex Dictionary maps from each key to the actual DoubleLink inside lruList holding the matching key/value pair. New pairs are added at the end of the list. In case of a hit, a pair gets promoted to the end of the list (most recently used). In case of a full cache, the first pair of the list gets evicted (least recently used). See #validateInvariantWith: where the relationship between the 2 datastructures is checked.! !LRUCache methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/9/2013 22:24'! at: key ifAbsentPut: block "If key is present in the cache, return the associated value. This is a hit and makes that key/value pair the most recently used. If key is absent, use block to compute a new value and cache it. Block can optionally take one argument, the key. This is a miss and will create a new key/value pair entry. Furthermore this could result in the least recently used key/value pair being removed when the specified maximum cache weight is exceeded." self critical: [ | association | association := keyIndex associationAt: key ifAbsent: [ | value | value := block cull: key. ^ self handleMiss: key -> value ]. ^ self handleHit: association ] ! ! !LRUCache methodsFor: 'private' stamp: 'SvenVanCaekenberghe 12/10/2013 16:40'! addWeight: value weight add: value. [ weight isBelowMaximum ] whileFalse: [ self isEmpty ifTrue: [ self error: 'Weight of single value being added exceeds maximum' ] ifFalse: [ self evict ] ]! ! !LRUCache methodsFor: 'accessing - statistics' stamp: 'SvenVanCaekenberghe 11/29/2013 21:15'! size "Return the count of items currently present." ^ keyIndex size! ! !LRUCache methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 11/29/2013 21:22'! isEmpty "Return true when the receiver contains no entries." ^ keyIndex isEmpty! ! !LRUCache methodsFor: 'private' stamp: 'SvenVanCaekenberghe 12/5/2013 17:46'! promote: link lruList removeLink: link. lruList addLast: link! ! !LRUCache methodsFor: 'private' stamp: 'SvenVanCaekenberghe 12/5/2013 17:15'! validateInvariantWith: assertable keyIndex keysAndValuesDo: [ :key :link | assertable assert: link value key = key ]. self keysAndValuesDo: [ :key :value | | link | link := keyIndex at: key. assertable assert: link value value = value. assertable assert: link value key = key ]! ! !LRUCache methodsFor: 'private' stamp: 'SvenVanCaekenberghe 12/5/2013 17:45'! handleMiss: association | link | statistics addMiss. self addWeight: association value. link := lruList addLast: association. keyIndex at: association key put: link. ^ association value! ! !LRUCache methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/16/2013 20:10'! initialize super initialize. keyIndex := Dictionary new. lruList := DoubleLinkedList new! ! !LRUCache methodsFor: 'private' stamp: 'SvenVanCaekenberghe 12/5/2013 18:16'! handleHit: association | link | statistics addHit. link := association value. self promote: link. ^ link value value! ! !LRUCache methodsFor: 'removing' stamp: 'SvenVanCaekenberghe 12/9/2013 22:23'! removeKey: key ifAbsent: block "If I currently cache key, remove the entry. Execute block when key is currently absent. Return the removed value." ^ self critical: [ (self includesKey: key) ifTrue: [ | link value | link := keyIndex removeKey: key. lruList removeLink: link. value := link value value. weight remove: value. value ] ifFalse: block ]! ! !LRUCache methodsFor: 'private' stamp: 'SvenVanCaekenberghe 12/5/2013 17:35'! evict | link value | link := lruList removeFirst. value := link value. weight remove: value value. keyIndex removeKey: value key! ! !LRUCache methodsFor: 'enumerating' stamp: 'SvenVanCaekenberghe 12/5/2013 17:35'! keysAndValuesDo: block "Execute block with each key and value present in me. This will be from least to most recently used." lruList do: [ :link | block value: link key value: link value ]! ! !LRUCache methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 11/29/2013 21:03'! includesKey: key "Return true when the receiver has a value cached for key." ^ keyIndex includesKey: key! ! !LRUCache methodsFor: 'removing' stamp: 'SvenVanCaekenberghe 12/9/2013 22:22'! removeAll "Remove all key/value pairs that I currently hold, effectiley resetting me, but not my statistics." self critical: [ lruList removeAll. keyIndex removeAll. weight reset ]! ! !LRUCacheTests commentStamp: ''! I am NeoLRUCacheTests. ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:32'! testEviction | cache | cache := self newCache. cache maximumWeight: 16. 1 to: 20 do: [ :each | cache at: each asWords ifAbsentPut: [ each ] ]. self assert: cache size equals: 16. self assert: cache totalWeight equals: 16. 5 to: 20 do: [ :each | self assert: (cache includesKey: each asWords). self assert: (cache at: each asWords ifAbsentPut: [ self fail ]) equals: each ]. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:32'! testOne | cache | cache := self newCache. cache at: #foo ifAbsentPut: [ 100 ]. self assert: (cache includesKey: #foo). self deny: cache isEmpty. self assert: cache size equals: 1. self assert: cache totalWeight equals: 1. self assert: cache hits isZero. self assert: cache misses equals: 1. self assert: cache hitRatio isZero. self deny: (cache includesKey: #bar). cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:32'! testFixedAccess | cache data keys | (cache := self newCache) maximumWeight: 4. data := (1 to: 16) collect: #asWords. data do: [ :each | cache at: each ifAbsentPut: [ each ] ]. cache validateInvariantWith: self. self assert: cache size equals: 4. (#(14 15) collect: #asWords) do: [ :each | cache at: each ifAbsentPut: [ each ] ]. self assert: cache size equals: 4. cache validateInvariantWith: self. keys := data select: [ :each | cache includesKey: each ]. keys do: [ :each | cache at: each ifAbsentPut: [ self fail ] ]. self assert: cache hits >= 4. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:33'! testOneHit | cache value | cache := self newCache. cache at: #foo ifAbsentPut: [ 100 ]. self assert: (cache includesKey: #foo). self assert: cache hits equals: 0. self assert: cache misses equals: 1. value := cache at: #foo ifAbsentPut: [ self fail ]. self assert: value equals: 100. self assert: cache hits equals: 1. self assert: cache misses equals: 1. cache validateInvariantWith: self ! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:32'! testCustomWeight | cache | (cache := self newCache) computeWeight: #sizeInMemory; maximumWeight: 64. cache at: 1 ifAbsentPut: [ ByteArray new: 1 ]. self assert: cache totalWeight equals: (ByteArray new: 1) sizeInMemory. 2 to: 10 do: [ :each | cache at: each ifAbsentPut: [ ByteArray new: each ] ]. self assert: cache size equals: 3. self assert: cache totalWeight equals: ((8 to: 10) collect: [ :each | (ByteArray new: each) sizeInMemory ]) sum. self assert: (cache at: 10 ifAbsentPut: [ self fail ]) equals: (ByteArray new: 10). self deny: (cache includesKey: 1)! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:32'! testFactory | cache | cache := self newCache. cache maximumWeight: 5. cache factory: [ :key | key * 2 ]. #( 1 2 3 4 1 5 6 7 8 1 ) do: [ :each | cache at: each ]. self assert: cache size equals: 5. self assert: cache hits equals: 2. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:32'! testFactoryStyle | cache factory | cache := self newCache. cache maximumWeight: 5. factory := [ :key | key * 2 ]. #( 1 2 3 4 1 5 6 7 8 1 ) do: [ :each | cache at: each ifAbsentPut: factory ]. self assert: cache size equals: 5. self assert: cache hits equals: 2. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:31'! test5kClasses | cache data | (cache := self newCache) maximumWeight: 1024. data := Object allSubclasses first: 5*1024. data do: [ :each | cache at: each name ifAbsentPut: [ each ] ]. cache validateInvariantWith: self. self assert: cache size equals: 1024. data shuffled do: [ :each | cache at: each name ifAbsentPut: [ each ] ]. self assert: cache size equals: 1024. cache validateInvariantWith: self. data select: [ :each | cache includesKey: each name ] thenDo: [ :each | cache at: each name ifAbsentPut: [ self fail ] ]. self assert: cache hits >= 1024. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:34'! testTwo | cache | cache := self newCache. cache at: #foo ifAbsentPut: [ 100 ]. cache at: #bar ifAbsentPut: [ 200 ]. self assert: (cache at: #foo ifAbsentPut: [ self fail ]) equals: 100. self assert: (cache at: #bar ifAbsentPut: [ self fail ]) equals: 200. self assert: cache hitRatio equals: 2/4. self assert: (cache at: #bar ifAbsentPut: [ self fail ]) equals: 200. self assert: (cache at: #foo ifAbsentPut: [ self fail ]) equals: 100. self assert: cache hitRatio equals: 4/6. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:32'! testEmpty | emptyCache | emptyCache := self newCache. self assert: emptyCache isEmpty. self assert: emptyCache size isZero. self assert: emptyCache hits isZero. self assert: emptyCache misses isZero. self assert: emptyCache hitRatio isZero. self assert: emptyCache totalWeight isZero. self deny: (emptyCache includesKey: #foo). emptyCache keysAndValuesDo: [ :key :value | self fail ]! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:33'! testPrimeFactors "[ self run: #testPrimeFactors ] bench." | cache data | cache := self newCache. cache maximumWeight: 512. cache factory: [ :key | key ]. data := Array streamContents: [ :out | 1 to: 4096 do: [ :each | each primeFactorsOn: out. out nextPut: each ] ]. data := data collect: [ :each | each asWords ]. data do: [ :each | cache at: each ]. self assert: cache totalWeight equals: 512. self assert: cache hitRatio > (7/10). cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:32'! testEnumeration | cache data keys values | cache := self newCache. data := Dictionary new. 1 to: 10 do: [ :each | data at: each asWords put: each ]. data keysAndValuesDo: [ :key :value | cache at: key ifAbsentPut: [ value ] ]. keys := Array new writeStream. values := Array new writeStream. cache keysAndValuesDo: [ :key :value | self assert: (data at: key) equals: value. keys nextPut: key. values nextPut: value ]. self assert: keys contents asSet equals: data keys asSet. self assert: values contents asSet equals: data values asSet. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:33'! testTen | cache | cache := self newCache. 1 to: 10 do: [ :each | cache at: each asWords ifAbsentPut: [ each ] ]. self assert: cache size equals: 10. 1 to: 10 do: [ :each | self assert: (cache includesKey: each asWords) ]. 1 to: 10 do: [ :each | self assert: (cache at: each asWords ifAbsentPut: [ self fail ]) equals: each ]. self assert: cache hitRatio equals: 1/2. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/11/2013 15:38'! testTenThreadSafe | cache | cache := self newCache. cache beThreadSafe. 1 to: 10 do: [ :each | cache at: each asWords ifAbsentPut: [ each ] ]. self assert: cache size equals: 10. 1 to: 10 do: [ :each | self assert: (cache at: each asWords ifAbsentPut: [ self fail ]) equals: each ]. self assert: cache hitRatio equals: 1/2. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:33'! testRemoveOne | cache | cache := self newCache. cache at: #foo ifAbsentPut: [ 100 ]. cache removeKey: #foo. self assert: cache isEmpty. self assert: cache size isZero. self assert: cache totalWeight isZero. self deny: (cache includesKey: #foo). cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:33'! testRemoveOneOfThree | cache | cache := self newCache. cache at: #x ifAbsentPut: [ 100 ]. cache at: #y ifAbsentPut: [ 200 ]. cache at: #z ifAbsentPut: [ 300 ]. cache removeKey: #y. self assert: cache size equals: 2. self assert: cache totalWeight equals: 2. self assert: (cache at: #x ifAbsentPut: [ self fail ]) equals: 100. self deny: (cache includesKey: #y). self assert: (cache at: #z ifAbsentPut: [ self fail ]) equals: 300. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/11/2013 15:46'! testFibonacci "After an idea by Jan Vrany. Recursively enter the cache and its access protection" | fibCache | fibCache := self newCache. fibCache maximumWeight: 32; beThreadSafe; factory: [ :key | key < 2 ifTrue: [ key ] ifFalse: [ (fibCache at: key - 1) + (fibCache at: key - 2) ] ]. self assert: (fibCache at: 40) equals: 102334155! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:33'! testOneHitTwice | cache value | cache := self newCache. cache at: #foo ifAbsentPut: [ 100 ]. value := cache at: #foo ifAbsentPut: [ self fail ]. self assert: value equals: 100. value := cache at: #foo ifAbsentPut: [ self fail ]. self assert: value equals: 100. self assert: cache hitRatio equals: 2/3. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:33'! testRemoveAll | cache | cache := self newCache. 1 to: 10 do: [ :each | cache at: each ifAbsentPut: [ each ] ]. cache removeAll. self assert: cache isEmpty. self assert: cache size isZero. self assert: cache totalWeight isZero. self assert: cache misses equals: 10. self assert: cache hits isZero. self deny: (cache includesKey: #1). cache keysAndValuesDo: [ :key :value | self fail ]. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:34'! testThreeHitSameOne | cache | cache := self newCache. cache at: #x ifAbsentPut: [ 100 ]. cache at: #y ifAbsentPut: [ 200 ]. cache at: #z ifAbsentPut: [ 300 ]. self assert: (cache at: #x ifAbsentPut: [ self fail ]) equals: 100. self assert: (cache at: #y ifAbsentPut: [ self fail ]) equals: 200. self assert: (cache at: #z ifAbsentPut: [ self fail ]) equals: 300. 3 timesRepeat: [ self assert: (cache at: #x ifAbsentPut: [ self fail ]) equals: 100 ]. self assert: cache hits equals: 6. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:33'! testRandomAccess | cache data random keys | (cache := self newCache) maximumWeight: 4. data := (1 to: 16) collect: #asWords. data do: [ :each | cache at: each ifAbsentPut: [ each ] ]. cache validateInvariantWith: self. self assert: cache size equals: 4. random := data shuffled. random do: [ :each | cache at: each ifAbsentPut: [ each ] ]. self assert: cache size equals: 4. cache validateInvariantWith: self. keys := data select: [ :each | cache includesKey: each ]. keys do: [ :each | cache at: each ifAbsentPut: [ self fail ] ]. self assert: cache hits >= 4. cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:32'! test6k | cache | (cache := self newCache) maximumWeight: 600. 1 to: 6000 do: [ :each | cache at: each ifAbsentPut: [ each * 2 ] ]. self assert: cache size equals: 600. self assert: (cache includesKey: 5401). self deny: (cache includesKey: 5400). cache validateInvariantWith: self! ! !LRUCacheTests methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/16/2013 20:11'! newCache ^ LRUCache new! ! !LRUCacheTests methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/2/2013 16:34'! testThree | cache | cache := self newCache. cache at: #x ifAbsentPut: [ 100 ]. cache at: #y ifAbsentPut: [ 200 ]. cache at: #z ifAbsentPut: [ 300 ]. self assert: (cache at: #x ifAbsentPut: [ self fail ]) equals: 100. self assert: (cache at: #y ifAbsentPut: [ self fail ]) equals: 200. self assert: (cache at: #z ifAbsentPut: [ self fail ]) equals: 300. self assert: cache hitRatio equals: 3/6. self assert: (cache at: #z ifAbsentPut: [ self fail ]) equals: 300. self assert: (cache at: #y ifAbsentPut: [ self fail ]) equals: 200. self assert: (cache at: #x ifAbsentPut: [ self fail ]) equals: 100. self assert: cache hitRatio equals: 6/9. cache validateInvariantWith: self! ! !LabelClicked commentStamp: ''! I am an announcement raised when someone click on the label of a CheckboxMorph! !LabelClicked methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/21/2013 23:32'! stateChanged ^ stateChanged! ! !LabelClicked methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/21/2013 23:32'! source ^ source! ! !LabelClicked methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/21/2013 23:32'! source: anObject source := anObject! ! !LabelClicked methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/21/2013 23:32'! stateChanged: anObject stateChanged := anObject! ! !LabelClicked class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/21/2013 23:32'! source: source stateChanged: stateChanged ^ self new source: source; stateChanged: stateChanged; yourself! ! !LabelModel commentStamp: ''! A LabelModel is a spec model for Labels! !LabelModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. textHolder := '' asReactiveVariable. enabledHolder := true asReactiveVariable. textHolder whenChangedDo: [ self changed: #getText ].! ! !LabelModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 17:58'! defaultColor ^ Color black! ! !LabelModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 9/25/2013 17:23'! whenLabelChanged: aBlock "Set a block to performed when the text is changed" textHolder whenChangedDo: aBlock! ! !LabelModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! label ^ textHolder value! ! !LabelModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/4/2014 18:06'! emphasis: anInteger self changed: #emphasis: with: { anInteger }! ! !LabelModel methodsFor: 'deprecated-protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 17:24'! text: aText self label: aText! ! !LabelModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! label: aText "Set the text of the label" textHolder value: aText! ! !LabelModel methodsFor: 'deprecated-protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 17:24'! text ^ self label! ! !LabelModel methodsFor: 'deprecated-protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 17:24'! whenTextChanged: aBlock self whenLabelChanged: aBlock! ! !LabelModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 13:38'! defaultSpec ^ #(LabelAdapter adapt: #(model))! ! !LabelModel class methodsFor: 'specs' stamp: ''! title ^ 'Label Morph'! ! !LabelModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:21'! adapterName ^ #LabelAdapter! ! !LabelMorph commentStamp: 'gvc 5/18/2007 12:48'! String morph with enablement support. When disabled the text will appear inset.! !LabelMorph methodsFor: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 1/23/2014 16:18'! initialColorInSystemWindow: aSystemWindow ^ Color black! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:43'! disabledStyle "Answer the value of disabledStyle" ^ disabledStyle! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 1/16/2007 15:28'! enabled "Answer the value of enabled" ^enabled! ! !LabelMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/22/2013 14:12'! disabledStyle: anObject "Set the value of disabledStyle" disabledStyle := anObject. self changed! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2010 13:37'! getTextSelector: aSymbol getTextSelector := aSymbol. self updateText! ! !LabelMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/23/2014 16:18'! adoptPaneColor: aColor! ! !LabelMorph methodsFor: 'initialization' stamp: 'gvc 8/2/2007 16:44'! initialize "Initialize the receiver." super initialize. self disabledStyle: #plain; enabled: true! ! !LabelMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 16:35'! enable "Enable the receiver." self enabled: true! ! !LabelMorph methodsFor: 'layout' stamp: 'gvc 10/26/2007 21:15'! minWidth "Answer the minmum width of the receiver. Based on font and contents." ^self valueOfProperty: #minWidth ifAbsent: [self measureContents x] "allow override"! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 3/2/2010 17:23'! enabled: aBoolean "Set the value of enabled" enabled == aBoolean ifFalse: [ enabled := aBoolean. self changed: #enabled; changed]! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2010 13:25'! getTextSelector ^ getTextSelector! ! !LabelMorph methodsFor: 'initialization' stamp: 'gvc 8/2/2007 16:51'! initWithContents: aString font: aFont emphasis: emphasisCode "Grrr, why do they do basicNew?" super initWithContents: aString font: aFont emphasis: emphasisCode. self disabledStyle: #plain; enabled: true! ! !LabelMorph methodsFor: 'drawing' stamp: 'GaryChambers 12/21/2011 12:15'! drawOn: aCanvas "Draw based on enablement." self enabled ifTrue: [aCanvas drawString: self contents in: self bounds font: self fontToUse color: self color] ifFalse: [|c| c := self theme labelDisabledColorFor: self. self disabledStyle == #inset ifTrue: [ aCanvas drawString: self contents in: (self bounds translateBy: 1) font: self fontToUse color: c muchLighter]. aCanvas drawString: self contents in: self bounds font: self fontToUse color: c]! ! !LabelMorph methodsFor: 'updating' stamp: 'gvc 7/30/2010 13:25'! update: aSymbol "Refer to the comment in View|update:." aSymbol == self getEnabledSelector ifTrue: [self updateEnabled. ^ self]. aSymbol == self getTextSelector ifTrue: [self updateText. ^ self]! ! !LabelMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 16:35'! disable "Disable the receiver." self enabled: false! ! !LabelMorph methodsFor: 'updating' stamp: 'gvc 9/8/2009 13:25'! updateEnabled "Update the enablement state." self model ifNotNil: [ self getEnabledSelector ifNotNil: [ self enabled: (self model perform: self getEnabledSelector)]]! ! !LabelMorph methodsFor: 'protocol' stamp: 'gvc 3/4/2010 15:16'! interactionState: aSymbol "Backstop here to prevent 'legacy' color handling being applied from pluggable buttons."! ! !LabelMorph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 8/31/2012 12:58'! drawOnAthensCanvas: aCanvas "Draw based on enablement." |pc| pc := self owner ifNil: [self paneColor] ifNotNil: [self owner color isTransparent ifTrue: [self owner paneColor] ifFalse: [self owner color]]. aCanvas pathTransform restoreAfter: [ "aCanvas setPaint: Color blue; drawShape: (self bounds). " aCanvas pathTransform translateX: self left Y: self top + self fontToUse ascent. aCanvas setFont: self fontToUse; setPaint: (self enabled ifTrue: [ self color ] ifFalse: [ pc muchDarker ] ); drawString: self contents. ]! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 1/16/2007 15:28'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 1/16/2007 15:52'! model "Answer the value of model" ^model! ! !LabelMorph methodsFor: 'update' stamp: 'gvc 7/30/2010 13:26'! updateText "Update the text contents." self model ifNotNil: [ self getTextSelector ifNotNil: [ self contents: (self model perform: self getTextSelector)]]! ! !LabelMorph methodsFor: 'compatibility' stamp: 'BenjaminVanRyseghem 7/13/2012 02:18'! isMorphicModel ^true! ! !LabelMorph methodsFor: 'layout' stamp: 'gvc 6/15/2007 13:17'! minHeight "Answer the receiver's minimum height. based on font height." ^self fontToUse height rounded max: super minHeight! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 1/16/2007 15:54'! model: anObject "Set my model and make me me a dependent of the given object." model ifNotNil: [model removeDependent: self]. anObject ifNotNil: [anObject addDependent: self]. model := anObject! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 1/16/2007 15:27'! getEnabledSelector: anObject "Set the value of getEnabledSelector" getEnabledSelector := anObject. self updateEnabled! ! !LanguageEnvironment commentStamp: ''! The name multilingualized suggests that you can use multiple language at one time. This is true, of course, but the system still how to manage the primary language; that provides the interpretation of data going out or coming in from outside world. It also provides how to render strings, as there rendering rule could be different in one language to another, even if the code points in a string is the same. Originally, LanguageEnvironment and its subclasses only has class side methods. After merged with Diego's Babel work, it now has instance side methods. Since this historical reason, the class side and instance side are not related well. When we talk about the interface with the outside of the Squeak world, there are three different "channels"; the keyboard input, clipboard output and input, and filename. On a not-to-uncommon system such as a Unix system localized to Japan, all of these three can have (and does have) different encodings. So we need to manage them separately. Note that the encoding in a file can be anything. While it is nice to provide a suggested guess for this 'default system file content encoding', it is not critical. Rendering support is limited basic L-to-R rendering so far. But you can provide different line-wrap rule, at least. ! !LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:31'! localeID ^id! ! !LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:32'! isoCountry ^self localeID isoCountry! ! !LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:32'! isoLanguage ^self localeID isoLanguage! ! !LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 18:55'! leadingChar ^self class leadingChar! ! !LanguageEnvironment methodsFor: 'initialization' stamp: 'mir 7/15/2004 15:31'! localeID: anID id := anID! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! canBeGlobalVarInitial: char ^ Unicode canBeGlobalVarInitial: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 12/2/2004 16:13'! isCharset ^ false. ! ! !LanguageEnvironment class methodsFor: 'initialization' stamp: 'mir 7/21/2004 19:10'! resetKnownEnvironments "LanguageEnvironment resetKnownEnvironments" KnownEnvironments := nil! ! !LanguageEnvironment class methodsFor: 'private' stamp: 'nice 1/5/2010 15:59'! initKnownEnvironments "LanguageEnvironment initKnownEnvironments" | known | known := Dictionary new. self allSubclassesDo: [:subClass | subClass supportedLanguages do: [:language | | env id | env := subClass new. id := LocaleID isoString: language. env localeID: id. known at: id put: env]]. ^known! ! !LanguageEnvironment class methodsFor: 'language methods' stamp: 'tpr 10/3/2013 12:56'! scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX font: aFont "the default for scanning multibyte characters- other more specific encodings may do something else" ^aFont scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX! ! !LanguageEnvironment class methodsFor: 'initialization' stamp: 'GuillermoPolito 6/27/2012 12:41'! initialize "LanguageEnvironment initialize" Smalltalk addToStartUpList: LanguageEnvironment ! ! !LanguageEnvironment class methodsFor: 'class initialization' stamp: 'GuillermoPolito 6/27/2012 12:41'! startUp self clearDefault.! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'! isLetter: char ^ Unicode isLetter: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! canBeNonGlobalVarInitial: char ^ Unicode canBeNonGlobalVarInitial: char. ! ! !LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:10'! systemConverterClass self subclassResponsibility. ^ Latin1TextConverter. ! ! !LanguageEnvironment class methodsFor: 'initialization' stamp: 'CamilloBruni 8/24/2012 18:05'! clearDefault SystemConverter := nil. FileNameConverter := nil. ! ! !LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'michael.rueger 2/5/2009 17:23'! fileNameConverterClass ^UTF8TextConverter! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 7/28/2004 21:34'! currentPlatform ^ Locale currentPlatform languageEnvironment. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'! isUppercase: char ^ Unicode isUppercase: char. ! ! !LanguageEnvironment class methodsFor: 'rendering support' stamp: 'yo 3/17/2004 21:54'! isBreakableAt: index in: text | char | char := text at: index. char = Character space ifTrue: [^ true]. char = Character cr ifTrue: [^ true]. ^ false. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! isDigit: char ^ Unicode isDigit: char. ! ! !LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:11'! leadingChar self subclassResponsibility. ^ 0. ! ! !LanguageEnvironment class methodsFor: 'public query' stamp: 'CamilloBruni 8/24/2012 18:05'! defaultFileNameConverter FileNameConverter ifNil: [FileNameConverter := self currentPlatform class fileNameConverterClass new]. ^ FileNameConverter! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'michael.rueger 3/15/2009 11:45'! localeID: localeID self knownEnvironments at: localeID ifPresent: [:value | ^value]. ^self knownEnvironments at: (LocaleID isoLanguage: localeID isoLanguage) ifAbsent: [self localeID: (LocaleID isoLanguage: 'en')]! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'! isLowercase: char ^ Unicode isLowercase: char. ! ! !LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 17:59'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." self subclassResponsibility! ! !LanguageEnvironment class methodsFor: 'class initialization' stamp: 'mir 7/15/2004 16:13'! localeChanged self startUp! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'StephaneDucasse 2/13/2010 12:14'! digitValueOf: char "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 otherwise. This is used to parse literal numbers of radix 2-36." ^ Unicode digitValueOf: char.! ! !LanguageEnvironment class methodsFor: 'language methods' stamp: 'yo 1/18/2005 15:56'! scanSelector ^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern: ! ! !LanguageEnvironment class methodsFor: 'public query' stamp: 'StephaneDucasse 8/2/2013 22:36'! defaultSystemConverter SystemConverter ifNil: [ SystemConverter := self currentPlatform class systemConverterClass new ]. ^ SystemConverter! ! !LanguageEnvironment class methodsFor: 'private' stamp: 'mir 7/15/2004 15:45'! knownEnvironments "LanguageEnvironment knownEnvironments" "KnownEnvironments := nil" ^KnownEnvironments ifNil: [KnownEnvironments := self initKnownEnvironments]! ! !LargeInteger commentStamp: ''! I represent integers of more than 30 bits. These values are beyond the range of SmallInteger, and are encoded here as an array of 8-bit digits. ! !LargeInteger methodsFor: 'comparing' stamp: 'ClementBera 7/24/2013 17:03'! <= anInteger "Primitive. Compare the receiver with the argument and answer true if the receiver is less than or equal to the argument. Otherwise answer false. Fail if the argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." ^super <= anInteger! ! !LargeInteger methodsFor: 'system primitives' stamp: 'ClementBera 7/24/2013 17:04'! digitAt: index "Primitive. Answer the value of an indexable field in the receiver. LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256. Fail if the argument (the index) is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." self digitLength < index ifTrue: [^0] ifFalse: [^super at: index]! ! !LargeInteger methodsFor: 'arithmetic' stamp: 'ClementBera 7/24/2013 17:04'! rem: aNumber "Remainder defined in terms of quo:. See super rem:. This is defined only to speed up case of large integers." aNumber isInteger ifTrue: [| ng rem | ng := self negative == aNumber negative == false. rem := (self digitDiv: aNumber neg: ng) at: 2. ^ rem normalize]. ^super rem: aNumber! ! !LargeInteger methodsFor: 'arithmetic' stamp: 'ClementBera 7/24/2013 17:04'! quo: anInteger "Primitive. Divide the receiver by the argument and return the result. Round the result down towards zero to make it a whole integer. Fail if the argument is 0. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." ^super quo: anInteger! ! !LargeInteger methodsFor: 'converting' stamp: 'ClementBera 7/24/2013 17:04'! as31BitSmallInt "This is only for 31 bit numbers. Keep my 31 bits the same, but put them in a small int. The small int will be negative since my 31st bit is 1. We know my 31st bit is 1 because otherwise I would already be a positive small int." self highBit = 31 ifFalse: [self error: 'more than 31 bits can not fit in a SmallInteger']. ^ self - 16r80000000! ! !LargeInteger methodsFor: 'system primitives' stamp: 'ClementBera 7/24/2013 17:04'! digitAt: index put: value "Primitive. Store the second argument (value) in the indexable field of the receiver indicated by index. Fail if the value is negative or is larger than 255. Fail if the index is not an Integer or is out of bounds. Answer the value that was stored. Essential. See Object documentation whatIsAPrimitive." ^super at: index put: value! ! !LargeInteger methodsFor: 'comparing' stamp: 'ClementBera 7/24/2013 17:03'! < anInteger "Primitive. Compare the receiver with the argument and answer true if the receiver is less than the argument. Otherwise answer false. Fail if the argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." ^super < anInteger! ! !LargeInteger methodsFor: 'converting' stamp: 'ClementBera 7/24/2013 17:04'! withAtLeastNDigits: desiredLength | new | self size >= desiredLength ifTrue: [^self]. new := self class new: desiredLength. new replaceFrom: 1 to: self size with: self startingAt: 1. ^new! ! !LargeInteger methodsFor: 'arithmetic' stamp: 'ClementBera 7/24/2013 17:03'! + anInteger "Primitive. Add the receiver to the argument and answer with an Integer result. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." ^super + anInteger! ! !LargeInteger methodsFor: 'arithmetic' stamp: 'ClementBera 7/24/2013 17:03'! - anInteger "Primitive. Subtract the argument from the receiver and answer with an Integer result. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." ^super - anInteger! ! !LargeInteger methodsFor: 'arithmetic' stamp: 'ClementBera 7/24/2013 17:03'! \\ aNumber "Primitive. Take the receiver modulo the argument. The result is the remainder rounded towards negative infinity, of the receiver divided by the argument. Fail if the argument is 0. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." aNumber isInteger ifTrue: [| neg qr q r | neg := self negative == aNumber negative == false. qr := self digitDiv: aNumber neg: neg. q := qr first normalize. r := qr last normalize. ^(q negative ifTrue: [r isZero not] ifFalse: [q isZero and: [neg]]) ifTrue: [r + aNumber] ifFalse: [r]]. ^super \\ aNumber ! ! !LargeInteger methodsFor: 'testing' stamp: 'ClementBera 7/24/2013 17:04'! isPrime "Answer true if the receiver is a prime number. Use a probabilistic implementation that is much faster for large integers, and that is correct to an extremely high statistical level of confidence (effectively deterministic)." ^ self isProbablyPrime! ! !LargeInteger methodsFor: 'arithmetic' stamp: 'ClementBera 7/24/2013 17:03'! // anInteger "Primitive. Divide the receiver by the argument and return the result. Round the result down towards negative infinity to make it a whole integer. Fail if the argument is 0. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive. " ^super // anInteger! ! !LargeInteger methodsFor: 'arithmetic' stamp: 'ClementBera 7/24/2013 17:03'! \\\ anInteger "a faster modulo method for use in DSA. Be careful if you try to use this elsewhere" ^(self digitDiv: anInteger neg: false) second! ! !LargeInteger methodsFor: 'bit manipulation' stamp: 'ClementBera 7/24/2013 17:04'! hashMultiply "Truncate to 28 bits and try again" ^(self bitAnd: 16rFFFFFFF) hashMultiply! ! !LargeInteger methodsFor: 'comparing' stamp: 'ClementBera 7/24/2013 17:03'! > anInteger "Primitive. Compare the receiver with the argument and answer true if the receiver is greater than the argument. Otherwise answer false. Fail if the argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." ^super > anInteger! ! !LargeInteger methodsFor: 'comparing' stamp: 'ClementBera 7/24/2013 17:04'! hash ^ByteArray hashBytes: self startingWith: self species hash! ! !LargeInteger methodsFor: 'testing' stamp: 'ClementBera 7/24/2013 17:04'! isLarge ^true! ! !LargeInteger methodsFor: 'system primitives' stamp: 'ClementBera 7/24/2013 17:04'! digitLength "Primitive. Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !LargeInteger methodsFor: 'comparing' stamp: 'ClementBera 7/24/2013 17:03'! >= anInteger "Primitive. Compare the receiver with the argument and answer true if the receiver is greater than or equal to the argument. Otherwise answer false. Fail if the argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." ^super >= anInteger! ! !LargeInteger methodsFor: 'bit manipulation' stamp: 'ClementBera 7/24/2013 17:04'! highBitOfMagnitude "Answer the index of the high order bit of the magnitude of the receiver, or zero if the receiver is zero. This method is used for LargeNegativeIntegers as well, since LargeIntegers are sign/magnitude." | realLength lastDigit | realLength := self digitLength. [(lastDigit := self digitAt: realLength) = 0] whileTrue: [(realLength := realLength - 1) = 0 ifTrue: [^ 0]]. ^ lastDigit highBitOfPositiveReceiver + (8 * (realLength - 1))! ! !LargeInteger methodsFor: 'converting' stamp: 'ClementBera 7/24/2013 17:09'! asFloat "Answer a Float that best approximates the value of the receiver. This algorithm is optimized to process only the significant digits of a LargeInteger. And it does honour IEEE 754 round to nearest even mode in case of excess precision (see details below)." "How numbers are rounded in IEEE 754 default rounding mode: A shift is applied so that the highest 53 bits are placed before the floating point to form a mantissa. The trailing bits form the fraction part placed after the floating point. This fractional number must be rounded to the nearest integer. If fraction part is 2r0.1, exactly between two consecutive integers, there is a tie. The nearest even integer is chosen in this case. Examples (First 52bits of mantissa are omitted for brevity): 2r0.00001 is rounded downward to 2r0 2r1.00001 is rounded downward to 2r1 2r0.1 is a tie and rounded to 2r0 (nearest even) 2r1.1 is a tie and rounded to 2r10 (nearest even) 2r0.10001 is rounded upward to 2r1 2r1.10001 is rounded upward to 2r10 Thus, if the next bit after floating point is 0, the mantissa is left unchanged. If next bit after floating point is 1, an odd mantissa is always rounded upper. An even mantissa is rounded upper only if the fraction part is not a tie." "Algorihm details: The floating point hardware can perform the rounding correctly with several excess bits as long as there is a single inexact operation. This can be obtained by splitting the mantissa plus excess bits in two part with less bits than Float precision. Note 1: the inexact flag in floating point hardware must not be trusted because in some cases the operations would be exact but would not take into account some bits that were truncated before the Floating point operations. Note 2: the floating point hardware is presumed configured in default rounding mode." | mantissa shift excess result n | "Check how many bits excess the maximum precision of a Float mantissa." excess := self highBitOfMagnitude - Float precision. excess > 7 ifTrue: ["Remove the excess bits but seven." mantissa := self bitShiftMagnitude: 7 - excess. shift := excess - 7. "An even mantissa with a single excess bit immediately following would be truncated. But this would not be correct if above shift has truncated some extra bits. Check this case, and round excess bits upper manually." ((mantissa digitAt: 1) = 2r01000000 and: [self anyBitOfMagnitudeFrom: 1 to: shift]) ifTrue: [mantissa := mantissa + 1]] ifFalse: [mantissa := self. shift := 0]. "There will be a single inexact round off at last iteration" result := (mantissa digitAt: (n := mantissa digitLength)) asFloat. [(n := n - 1) > 0] whileTrue: [ result := 256.0 * result + (mantissa digitAt: n) asFloat]. ^result timesTwoPower: shift.! ! !LargeInteger methodsFor: 'system primitives' stamp: 'ClementBera 7/24/2013 17:04'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." ^ super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !LargeInteger methodsFor: 'mathematical functions' stamp: 'ClementBera 7/24/2013 17:04'! mightBeASquare "In base 16, a square number can end only with 0,1,4 or 9 and - in case 0, only 0,1,4,9 can precede it, - in case 4, only even numbers can precede it. See http://en.wikipedia.org/wiki/Square_number So, in hex, the last byte must be one of: 00 10 40 90 x1 e4 x9 where x is any hex digit and e is any even digit Also, the receiver must be an aven power of two." | lsb | lsb := self digitAt: 1. ^(lsb = 0 and: [ self lowBit odd ]) "00 (and even power of 2)" or: [ lsb = 16r40 "40" or: [ (lsb bitAnd: 16r7) = 1 "any|1 or any|9" or: [ (lsb bitAnd: 16r1F) = 4 "even|4" or: [ (lsb bitAnd: 16r7F) = 16 ]]]] "10 or 90"! ! !LargeInteger methodsFor: 'arithmetic' stamp: 'ClementBera 7/24/2013 17:03'! * anInteger "Primitive. Multiply the receiver by the argument and answer with an Integer result. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive. " ^super * anInteger! ! !LargeInteger methodsFor: 'arithmetic' stamp: 'ClementBera 7/24/2013 17:03'! / anInteger "Primitive. Divide the receiver by the argument and answer with the result if the division is exact. Fail if the result is not a whole integer. Fail if the argument is 0. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive. " ^super / anInteger! ! !LargeInteger methodsFor: 'printing' stamp: 'ClementBera 7/24/2013 17:04'! printOn: aStream base: b nDigits: n "Append a representation of this number in base b on aStream using n digits. In order to reduce cost of LargePositiveInteger ops, split the number of digts approximatily in two Should be invoked with: 0 <= self < (b raisedToInteger: n)" | halfPower half head tail | n <= 1 ifTrue: [ n <= 0 ifTrue: [self error: 'Number of digits n should be > 0']. "Note: this is to stop an infinite loop if one ever attempts to print with a huge base This can happen because choice was to not hardcode any limit for base b We let Character>>#digitValue: fail" ^aStream nextPut: (Character digitValue: self)]. halfPower := n bitShift: -1. half := b raisedToInteger: halfPower. head := self quo: half. tail := self - (head * half). head printOn: aStream base: b nDigits: n - halfPower. tail printOn: aStream base: b nDigits: halfPower! ! !LargeNegativeInteger commentStamp: ''! Just like LargePositiveInteger, but represents a negative number.! !LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:03'! strictlyPositive "Answer whether the receiver is mathematically positive." ^ false! ! !LargeNegativeInteger methodsFor: 'mathematical functions' stamp: 'nice 7/15/2011 14:06'! ln ^DomainError signal: 'ln is only defined for x > 0' from: 0! ! !LargeNegativeInteger methodsFor: 'mathematical functions' stamp: 'jmv 10/13/2011 21:40'! sqrt "Answer the square root of the receiver." ^ DomainError signal: 'sqrt undefined for number less than zero.'! ! !LargeNegativeInteger methodsFor: 'mathematical functions' stamp: 'nice 7/15/2011 14:06'! log ^DomainError signal: 'log is only defined for x > 0' from: 0! ! !LargeNegativeInteger methodsFor: 'arithmetic' stamp: ''! negated ^ self copyto: (LargePositiveInteger new: self digitLength)! ! !LargeNegativeInteger methodsFor: 'testing' stamp: 'jm 3/27/98 06:19'! sign "Optimization. Answer -1 since receiver is less than 0." ^ -1 ! ! !LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'! negative "Answer whether the receiver is mathematically negative." ^ true! ! !LargeNegativeInteger methodsFor: '*Fuel' stamp: 'MaxLeske 2/17/2014 20:40'! fuelAccept: aGeneralMapper ^ self >= -4294967295 ifTrue: [ aGeneralMapper mapAndTraceByClusterName: self to: FLNegative32SmallIntegerCluster ] ifFalse: [ aGeneralMapper visitBytesObject: self]! ! !LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:00'! positive "Answer whether the receiver is positive or equal to 0. (ST-80 protocol). See also strictlyPositive" ^ false! ! !LargeNegativeInteger methodsFor: 'bit manipulation' stamp: 'nice 3/21/2008 01:02'! bitAt: anInteger "super would not work because we have to pretend we are in two-complement. this has to be tricky..." | digitIndex bitIndex i | digitIndex := anInteger - 1 // 8 + 1. digitIndex > self digitLength ifTrue: [^1]. bitIndex := anInteger - 1 \\ 8 + 1. i := 1. [i = digitIndex ifTrue: ["evaluate two complement (bitInvert + 1) on the digit : (if digitIndex > 1, we must still add 1 due to the carry). but x bitInvert is -1-x, bitInvert+1 is just x negated..." ^(self digitAt: digitIndex) negated bitAt: bitIndex]. (self digitAt: i) = 0] whileTrue: [ "two complement (bitInvert + 1) raises a carry: 0 bitInvert -> 2r11111111. 2r11111111 + 1 -> 0 with carry... Thus we must inquire one digit forward" i := i + 1]. "We escaped the while loop, because there is no more carry. Do a simple bitInvert without a carry" ^1 - ((self digitAt: digitIndex) bitAt: bitIndex)! ! !LargeNegativeInteger methodsFor: 'converting' stamp: 'nice 1/1/2013 15:42'! asFloat ^super asFloat negated! ! !LargeNegativeInteger methodsFor: 'converting' stamp: 'ar 5/17/2000 16:10'! normalize "Check for leading zeroes and return shortened copy if so" | sLen val len oldLen minVal | "First establish len = significant length" len := oldLen := self digitLength. [len = 0 ifTrue: [^0]. (self digitAt: len) = 0] whileTrue: [len := len - 1]. "Now check if in SmallInteger range" sLen := 4 "SmallInteger minVal digitLength". len <= sLen ifTrue: [minVal := SmallInteger minVal. (len < sLen or: [(self digitAt: sLen) < minVal lastDigit]) ifTrue: ["If high digit less, then can be small" val := 0. len to: 1 by: -1 do: [:i | val := (val *256) - (self digitAt: i)]. ^ val]. 1 to: sLen do: "If all digits same, then = minVal" [:i | (self digitAt: i) = (minVal digitAt: i) ifFalse: ["Not so; return self shortened" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]]]. ^ minVal]. "Return self, or a shortened copy" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]! ! !LargeNegativeInteger methodsFor: 'arithmetic' stamp: ''! abs ^ self negated! ! !LargeNegativeInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:10'! highBit "Answer the index of the high order bit of the receiver, or zero if the receiver is zero. Raise an error if the receiver is negative, since negative integers are defined to have an infinite number of leading 1's in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to get the highest bit of the magnitude." ^ self shouldNotImplement! ! !LargeNegativeInteger methodsFor: 'printing' stamp: 'nice 2/15/2008 21:47'! printOn: aStream base: b "Append a representation of this number in base b on aStream." aStream nextPut: $-. self abs printOn: aStream base: b! ! !LargeNegativeIntegerTest commentStamp: 'TorstenBergmann 2/5/2014 08:40'! SUnit tests for large negative integers! !LargeNegativeIntegerTest methodsFor: 'tests' stamp: 'StephaneDucasse 5/28/2011 13:52'! testEmptyTemplate "Check that an uninitialized instance behaves reasonably." | i | i := LargeNegativeInteger new: 4. self assert: i size = 4. self assert: i printString = '-0'. self assert: i normalize = 0! ! !LargePositiveInteger commentStamp: ''! I represent positive integers of more than 30 bits (ie, >= 1073741824). These values are beyond the range of SmallInteger, and are encoded here as an array of 8-bit digits. Care must be taken, when new values are computed, that any result that COULD BE a SmallInteger IS a SmallInteger (see normalize). Note that the bit manipulation primitives, bitAnd:, bitShift:, etc., = and ~= run without failure (and therefore fast) if the value fits in 32 bits. This is a great help to the simulator.! !LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:02'! strictlyPositive "Answer whether the receiver is mathematically positive." ^ true! ! !LargePositiveInteger methodsFor: 'mathematical functions' stamp: 'nice 7/15/2011 14:06'! ln "This function is defined because super ln might overflow." | res h | res := super ln. res isFinite ifTrue: [^res]. h := self highBit. ^2 ln * h + (self / (1 << h)) asFloat ln! ! !LargePositiveInteger methodsFor: 'mathematical functions' stamp: 'nice 10/29/2011 15:07'! sqrt "If we know for sure no exact solution exists, then just answer the cheap float approximation without wasting time." | selfAsFloat | self mightBeASquare ifFalse: [selfAsFloat := self asFloat. selfAsFloat isFinite ifTrue: [^self asFloat sqrt ]]. "If some exact solution might exist, or self asFloat isInfinite, call potentially expensive super" ^super sqrt! ! !LargePositiveInteger methodsFor: 'mathematical functions' stamp: 'nice 7/15/2011 14:05'! log "This function is defined because super log might overflow." | res h | res := super log. res isFinite ifTrue: [^res]. h := self highBit. ^2 log * h + (self / (1 << h)) asFloat log! ! !LargePositiveInteger methodsFor: 'testing' stamp: 'jm 3/27/98 06:19'! sign "Optimization. Answer 1 since receiver is greater than 0." ^ 1 ! ! !LargePositiveInteger methodsFor: 'arithmetic' stamp: ''! negated ^ (self copyto: (LargeNegativeInteger new: self digitLength)) normalize "Need to normalize to catch SmallInteger minVal"! ! !LargePositiveInteger methodsFor: '*Fuel' stamp: 'MarianoMartinezPeck 6/11/2012 22:47'! fuelAccept: aGeneralMapper ^ self <= 4294967295 ifTrue: [ aGeneralMapper mapAndTraceByClusterName: self to: FLPositive32SmallIntegerCluster ] ifFalse: [ aGeneralMapper visitBytesObject: self]! ! !LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'! negative "Answer whether the receiver is mathematically negative." ^ false! ! !LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:00'! positive "Answer whether the receiver is positive or equal to 0. (ST-80 protocol). See also strictlyPositive" ^ true! ! !LargePositiveInteger methodsFor: 'converting' stamp: 'ar 5/17/2000 16:09'! normalize "Check for leading zeroes and return shortened copy if so" | sLen val len oldLen | "First establish len = significant length" len := oldLen := self digitLength. [len = 0 ifTrue: [^0]. (self digitAt: len) = 0] whileTrue: [len := len - 1]. "Now check if in SmallInteger range" sLen := SmallInteger maxVal digitLength. (len <= sLen and: [(self digitAt: sLen) <= (SmallInteger maxVal digitAt: sLen)]) ifTrue: ["If so, return its SmallInt value" val := 0. len to: 1 by: -1 do: [:i | val := (val *256) + (self digitAt: i)]. ^ val]. "Return self, or a shortened copy" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]! ! !LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'nice 3/21/2008 00:09'! bitAt: anInteger "Optimize super algorithm to avoid long bit operations. Instead work on digits which are known to be SmallInteger and fast. Note that this algorithm does not work for negative integers." | digitIndex bitIndex | digitIndex := anInteger - 1 // 8 + 1. digitIndex > self digitLength ifTrue: [^0]. bitIndex := anInteger - 1 \\ 8 + 1. ^(self digitAt: digitIndex) bitAt: bitIndex! ! !LargePositiveInteger methodsFor: 'arithmetic' stamp: ''! abs! ! !LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:11'! highBit "Answer the index of the high order bit of the receiver, or zero if the receiver is zero. Raise an error if the receiver is negative, since negative integers are defined to have an infinite number of leading 1's in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to get the highest bit of the magnitude." ^ self highBitOfMagnitude! ! !LargePositiveInteger methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 14:33'! printOn: aStream base: b "Append a representation of this number in base b on aStream. In order to reduce cost of LargePositiveInteger ops, split the number in approximately two equal parts in number of digits." | halfDigits halfPower head tail nDigitsUnderestimate | "Don't engage any arithmetic if not normalized" (self digitLength = 0 or: [(self digitAt: self digitLength) = 0]) ifTrue: [ ^self normalize printOn: aStream base: b ]. nDigitsUnderestimate := b = 10 ifTrue: [((self highBit - 1) * 1233 >> 12) + 1. "This is because (2 log)/(10 log)*4096 is slightly greater than 1233"] ifFalse: [self highBit quo: b highBit]. "splitting digits with a whole power of two is more efficient" halfDigits := 1 bitShift: nDigitsUnderestimate highBit - 2. halfDigits <= 1 ifTrue: ["Hmmm, this could happen only in case of a huge base b... Let lower level fail" ^self printOn: aStream base: b nDigits: (self numberOfDigitsInBase: b)]. "Separate in two halves, head and tail" halfPower := b raisedToInteger: halfDigits. head := self quo: halfPower. tail := self - (head * halfPower). "print head" head printOn: aStream base: b. "print tail without the overhead to count the digits" tail printOn: aStream base: b nDigits: halfDigits! ! !LargePositiveIntegerTest commentStamp: 'TorstenBergmann 2/5/2014 08:40'! SUnit tests for large positive integers! !LargePositiveIntegerTest methodsFor: 'tests' stamp: 'md 3/17/2003 15:20'! testBitShift "Check bitShift from and back to SmallInts" 1 to: 257 do: [:i | self should: [((i bitShift: i) bitShift: 0-i) == i]].! ! !LargePositiveIntegerTest methodsFor: 'tests' stamp: 'StephaneDucasse 5/28/2011 13:34'! testEmptyTemplate "Check that an uninitialized instance behaves reasonably." | i | i := LargePositiveInteger new: 4. self assert: i size = 4. self assert: i printString = '0'. self assert: i normalize = 0! ! !LargePositiveIntegerTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:52'! testMultDicAddSub "self run: #testMultDicAddSub" | n f f1 | n := 100. f := 100 factorial. f1 := f*(n+1). n timesRepeat: [f1 := f1 - f]. self assert: (f1 = f). n timesRepeat: [f1 := f1 + f]. self assert: (f1 // f = (n+1)). self assert: (f1 negated = (Number readFrom: '-' , f1 printString)).! ! !LargePositiveIntegerTest methodsFor: 'tests' stamp: 'nice 3/21/2014 21:57'! testLargeSqrtFloor "This test fails if a careless implementation naivly factors out the power of two (remove the trailing zeroes up to lowBit). This was the case in a previous implementation, so this is a non regression test." | large root | large := (SmallInteger maxVal << 100 + 1) << 100. root := large sqrtFloor. self assert: root squared <= large. self assert: (root+1) squared > large.! ! !LargePositiveIntegerTest methodsFor: 'tests' stamp: 'sd 6/5/2005 08:53'! testNormalize "self run: #testNormalize" "Check normalization and conversion to/from SmallInts" self assert: ((SmallInteger maxVal + 1 - 1) == SmallInteger maxVal). self assert: (SmallInteger maxVal + 3 - 6) == (SmallInteger maxVal-3). self should: ((SmallInteger minVal - 1 + 1) == SmallInteger minVal). self assert: (SmallInteger minVal - 3 + 6) == (SmallInteger minVal+3).! ! !Latin1 commentStamp: 'yo 10/19/2004 19:53'! This class represents the domestic character encoding called ISO-8859-1, also known as Latin-1 used for Most of the Western European Languages.! !Latin1 class methodsFor: 'private' stamp: 'Alexandre.Bergel 11/20/2008 11:10'! nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state state charSize: 1. state g1Leading: 0. state g1Size: 1. aStream basicNextPutAll: rightHalfSequence. aStream basicNextPut: (Character value: ascii)! ! !Latin1 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! initialize " self initialize " compoundTextSequence := String streamContents: [ :s | s nextPut: (Character value: 27). s nextPut: $(. s nextPut: $B ]. rightHalfSequence := String streamContents: [ :s | s nextPut: (Character value: 27). s nextPut: $-. s nextPut: $A ]! ! !Latin1 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! emitSequenceToResetStateIfNeededOn: aStream forState: state state g0Leading ~= 0 ifTrue: [ state charSize: 1. state g0Leading: 0. state g0Size: 1. aStream basicNextPutAll: compoundTextSequence ] "Actually, G1 state should go back to ISO-8859-1, too."! ! !Latin1 class methodsFor: 'accessing - displaying' stamp: 'nice 11/16/2009 15:36'! isBreakableAt: index in: text | char | char := text at: index. char = Character space ifTrue: [^ true]. char = Character cr ifTrue: [^ true]. char = Character lf ifTrue: [^ true]. ^ false. ! ! !Latin1 class methodsFor: 'character classification' stamp: 'yo 8/28/2004 10:41'! isLetter: char "Answer whether the receiver is a letter." ^ Unicode isLetter: char. ! ! !Latin1 class methodsFor: 'accessing - displaying' stamp: 'yo 8/18/2003 17:32'! printingDirection ^ #right. ! ! !Latin1 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state (ascii <= 127 and: [ state g0Leading ~= 0 ]) ifTrue: [ state charSize: 1. state g0Leading: 0. state g0Size: 1. aStream basicNextPutAll: compoundTextSequence. aStream basicNextPut: (Character value: ascii). ^ self ]. ((128 <= ascii and: [ ascii <= 255 ]) and: [ state g1Leading ~= 0 ]) ifTrue: [ ^ self nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state ]. aStream basicNextPut: (Character value: ascii). ^ self! ! !Latin1 class methodsFor: 'class methods' stamp: 'yo 8/18/2003 17:32'! leadingChar ^ 0. ! ! !Latin1Environment commentStamp: ''! This class provides the support for the languages in 'Latin-1' category. Although we could have different language environments for different languages in the category, so far nobody seriously needed it. ! !Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'cami 7/22/2013 18:25'! systemConverterClass Smalltalk os isWin32 ifTrue: [^ UTF8TextConverter]. Smalltalk os isMacOSX ifTrue: [ ^ UTF8TextConverter ]. Smalltalk os isMacOS ifTrue: [^MacRomanTextConverter]. Smalltalk os isUnix ifTrue: [^ UTF8TextConverter]. ^ Latin1TextConverter ! ! !Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 10:00'! nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state ^ self traditionalCharsetClass nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state. ! ! !Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 2/24/2005 20:41'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." ^#('fr' 'es' 'ca' 'eu' 'pt' 'it' 'sq' 'rm' 'nl' 'de' 'da' 'sv' 'no' 'fi' 'fo' 'is' 'ga' 'gd' 'en' 'af' 'sw')! ! !Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 10:00'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state ^ self traditionalCharsetClass nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state.! ! !Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'! leadingChar ^ 0. ! ! !Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 09:59'! traditionalCharsetClass ^ Latin1. ! ! !Latin1TextConverter commentStamp: ''! Text converter for ISO 8859-1. An international encoding used in Western Europe.! !Latin1TextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:20'! unicodeToByte: unicodeChar ^unicodeChar charCode < 256 ifTrue: [unicodeChar] ifFalse: [0 asCharacter]! ! !Latin1TextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:20'! byteToUnicode: char ^char! ! !Latin1TextConverter class methodsFor: 'class initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 23:17'! initializeTables "Overwritten to be a noop for Latin1, we don't use #byteToUnicodeSpec although we should"! ! !Latin1TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 19:31'! languageEnvironment ^Latin1Environment! ! !Latin1TextConverter class methodsFor: 'accessing' stamp: 'tbn 1/17/2011 13:04'! encodingNames ^ #('latin-1' 'latin1' 'iso-8859-1') copy. ! ! !Latin1TextConverter class methodsFor: 'accessing' stamp: ''! byteToUnicodeSpec "ByteTextConverter generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/ISO8859/8859-1.TXT'" ^ #( nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 16r00A0 16r00A1 16r00A2 16r00A3 16r00A4 16r00A5 16r00A6 16r00A7 16r00A8 16r00A9 16r00AA 16r00AB 16r00AC 16r00AD 16r00AE 16r00AF 16r00B0 16r00B1 16r00B2 16r00B3 16r00B4 16r00B5 16r00B6 16r00B7 16r00B8 16r00B9 16r00BA 16r00BB 16r00BC 16r00BD 16r00BE 16r00BF 16r00C0 16r00C1 16r00C2 16r00C3 16r00C4 16r00C5 16r00C6 16r00C7 16r00C8 16r00C9 16r00CA 16r00CB 16r00CC 16r00CD 16r00CE 16r00CF 16r00D0 16r00D1 16r00D2 16r00D3 16r00D4 16r00D5 16r00D6 16r00D7 16r00D8 16r00D9 16r00DA 16r00DB 16r00DC 16r00DD 16r00DE 16r00DF 16r00E0 16r00E1 16r00E2 16r00E3 16r00E4 16r00E5 16r00E6 16r00E7 16r00E8 16r00E9 16r00EA 16r00EB 16r00EC 16r00ED 16r00EE 16r00EF 16r00F0 16r00F1 16r00F2 16r00F3 16r00F4 16r00F5 16r00F6 16r00F7 16r00F8 16r00F9 16r00FA 16r00FB 16r00FC 16r00FD 16r00FE 16r00FF )! ! !Latin2Environment commentStamp: ''! This class provides the support for the languages in 'Latin-2' category. Although we could have different language environments for different languages in the category, so far nobody seriously needed it. I (Yoshiki) don't have good knowledge in these language, so when Pavel Krivanek volunteered to implement the detail, it was a good test to see how flexible my m17n framework was. There are a few glitches, but with several email conversations over a few days, we managed to make it work relatively painlessly. I thought this went well. There seem that some source of headache, as Windows doesn't exactly use Latin-2 encoded characters, but a little modified version called 'code page 1250'. Similar to Japanese support, the encode interpreters are swapped based on the type of platform it is running on. ! !Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'cami 7/22/2013 18:28'! systemConverterClass Smalltalk os isWin32 ifTrue: [^CP1250TextConverter ]. ^ ISO88592TextConverter. ! ! !Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 1/19/2005 09:16'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." ^#('cs' 'hu' 'ro' 'hr' 'sk' 'sl') "Sorbian languages don't have two char code?" ! ! !Latin2Environment class methodsFor: 'class initialization' stamp: 'StephaneDucasse 8/22/2013 14:32'! initialize EncodedCharSet declareEncodedCharSet: self atIndex: 14+1.! ! !Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'nice 5/1/2011 19:22'! leadingChar ^0! ! !Latin9Environment commentStamp: ''! This class provides the support for the languages in 'Latin-9' category.! !Latin9Environment class methodsFor: 'subclass responsibilities' stamp: 'cami 7/22/2013 18:28'! systemConverterClass Smalltalk os isWin32 ifTrue: [^CP1252TextConverter ]. ^ ISO885915TextConverter. ! ! !Latin9Environment class methodsFor: 'subclass responsibilities' stamp: 'pmm 8/16/2010 10:27'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." ^#('fr' 'es' 'ca' 'eu' 'pt' 'it' 'sq' 'rm' 'nl' 'de' 'da' 'sv' 'no' 'fi' 'fo' 'is' 'ga' 'gd' 'en' 'af' 'sw')! ! !Latin9Environment class methodsFor: 'class initialization' stamp: 'StephaneDucasse 8/22/2013 14:33'! initialize EncodedCharSet declareEncodedCharSet: self atIndex: 17+1.! ! !Latin9Environment class methodsFor: 'subclass responsibilities' stamp: 'nice 5/1/2011 19:22'! leadingChar ^0! ! !LayoutAbstractScope commentStamp: ''! Layout scopes reify how classes extend the layout of their superclass.! !LayoutAbstractScope methodsFor: 'comparing' stamp: 'MartinDias 4/12/2013 13:29'! hash ^ self class hash! ! !LayoutAbstractScope methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 14:04'! atName: aName ifAbsent: aBlock self allSlotsDo: [ :slot | slot name == aName ifTrue: [ ^ slot ]]. ^ aBlock value! ! !LayoutAbstractScope methodsFor: 'reshaping' stamp: 'MartinDias 4/4/2013 20:40'! rebase: originalScope to: newScope self error: 'Should not happen'! ! !LayoutAbstractScope methodsFor: 'enumerating' stamp: 'ToonVerwaest 4/2/2011 14:27'! allSlotsDo: aBlock self subclassResponsibility! ! !LayoutAbstractScope methodsFor: 'accessing' stamp: 'CamilloBruni 4/6/2011 14:25'! ownFieldSize self subclassResponsibility! ! !LayoutAbstractScope methodsFor: 'accessing' stamp: 'CamilloBruni 4/4/2011 13:03'! atName: aName ^ self atName: aName ifAbsent: [ SlotNotFound signalForName: aName ].! ! !LayoutAbstractScope methodsFor: 'enumerating' stamp: 'CamilloBruni 4/4/2011 14:30'! allSlotsReverseDo: aBlock self subclassResponsibility! ! !LayoutAbstractScope methodsFor: 'extending' stamp: 'CamilloBruni 4/6/2011 14:28'! extend: someSlots as: type | scope fieldIndex currentParentScope nextParentScope | scope := type new: someSlots size. fieldIndex := self firstFieldIndex. currentParentScope := self. someSlots withIndexDo: [ :slot :slotIndex | |realSlot| realSlot := slot asSlot. nextParentScope := realSlot parentScopeFor: currentParentScope. nextParentScope == currentParentScope ifFalse: [ currentParentScope := nextParentScope. fieldIndex := fieldIndex + currentParentScope ownFieldSize]. realSlot index: fieldIndex. fieldIndex := fieldIndex + realSlot size. scope at: slotIndex put: realSlot ]. scope parentScope: currentParentScope. ^ scope! ! !LayoutAbstractScope methodsFor: 'testing' stamp: 'ToonVerwaest 4/2/2011 14:29'! hasFields self subclassResponsibility! ! !LayoutAbstractScope methodsFor: 'printing' stamp: 'ToonVerwaest 4/2/2011 14:29'! printSlotDefinitionOn: aStream self subclassResponsibility! ! !LayoutAbstractScope methodsFor: 'testing' stamp: 'ToonVerwaest 4/2/2011 14:29'! hasSlots self subclassResponsibility! ! !LayoutAbstractScope methodsFor: 'comparing' stamp: 'MartinDias 4/12/2013 13:29'! = other ^ self class = other class! ! !LayoutAbstractScope methodsFor: 'extending' stamp: 'ToonVerwaest 4/2/2011 14:25'! extend: someSlots ^ self extend: someSlots as: LayoutClassScope! ! !LayoutAbstractScope methodsFor: 'accessing' stamp: 'ToonVerwaest 4/2/2011 14:27'! fieldSize self subclassResponsibility! ! !LayoutAbstractScope methodsFor: 'accessing' stamp: 'ToonVerwaest 4/2/2011 14:50'! visibleSlotNames self subclassResponsibility! ! !LayoutAbstractScope methodsFor: 'enumerating' stamp: 'CamilloBruni 4/4/2011 18:31'! withParentScopesDo: aBlock self subclassResponsibility! ! !LayoutAbstractScope methodsFor: 'flattening' stamp: 'ToonVerwaest 4/2/2011 14:28'! flatten self subclassResponsibility! ! !LayoutAbstractScope methodsFor: 'extending' stamp: 'CamilloBruni 7/17/2013 13:49'! extend ^ self extend: { }! ! !LayoutAbstractScope methodsFor: 'accessing' stamp: 'ToonVerwaest 4/2/2011 18:33'! firstFieldIndex ^ self fieldSize + 1! ! !LayoutCell commentStamp: ''! I am used in table layouts to hold temporary values while the layout is being computed. Instance variables: target The morph contained in this cell cellSize The size of the cell extraSpace Additional space to add after this cell nextCell The next cell in the arrangement. Implementation note: Both, cellSize and extraSpace contains points where x - represents the primary table direction y - represents the secondary table direction ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'! hSpaceFill ^self flags anyMask: 1! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 11/10/2000 17:09'! extraSpace ^extraSpace ifNil:[0@0]! ! !LayoutCell methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:09'! size | n cell | n := 0. cell := self. [cell isNil] whileFalse: [n := n + 1. cell := cell nextCell]. ^n! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! cellSize: aPoint cellSize := aPoint! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'! hSpaceFill: aBool flags := aBool ifTrue:[self flags bitOr: 1] ifFalse:[self flags bitClear: 1]. ! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! nextCell ^nextCell! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:47'! vSpaceFill ^self flags anyMask: 2! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! cellSize ^cellSize! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! nextCell: aCell nextCell := aCell! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'! vSpaceFill: aBool flags := aBool ifTrue:[self flags bitOr: 2] ifFalse:[self flags bitClear: 2]. ! ! !LayoutCell methodsFor: 'collection' stamp: 'ar 10/28/2000 18:58'! do: aBlock aBlock value: self. nextCell ifNotNil:[nextCell do: aBlock].! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 21:30'! extraSpace: aPoint extraSpace := aPoint! ! !LayoutCell methodsFor: 'collection' stamp: 'ar 10/28/2000 21:27'! inject: thisValue into: binaryBlock "Accumulate a running value associated with evaluating the argument, binaryBlock, with the current value of the argument, thisValue, and the receiver as block arguments. For instance, to sum the numeric elements of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + next]." | nextValue | nextValue := thisValue. self do: [:each | nextValue := binaryBlock value: nextValue value: each]. ^nextValue! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:47'! flags ^flags ifNil: [ 0 ]! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 11/2/2000 17:15'! addExtraSpace: aPoint extraSpace ifNil:[extraSpace := aPoint] ifNotNil:[extraSpace := extraSpace + aPoint]! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:11'! target ^target! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! target: newTarget target := newTarget! ! !LayoutClassScope commentStamp: ''! I am layout scope for classes.! !LayoutClassScope methodsFor: 'comparing' stamp: 'MartinDias 4/12/2013 13:34'! hash | hash | hash := super hash. 1 to: self size do: [ :i | hash := (hash + (self at: i) hash) hashMultiply]. ^ hash bitXor: self parentScope hash.! ! !LayoutClassScope methodsFor: 'reshaping' stamp: 'MartinDias 4/4/2013 20:39'! rebase: originalScope to: newScope | newParent result fieldIndex | newParent := parentScope == originalScope ifTrue: [ newScope ] ifFalse: [ parentScope rebase: originalScope to: newScope ]. result := self copy. result parentScope: newParent. fieldIndex := newParent firstFieldIndex. result do: [ :slot | slot index: fieldIndex. fieldIndex := fieldIndex + slot size ]. ^ result ! ! !LayoutClassScope methodsFor: 'enumerating' stamp: 'ToonVerwaest 4/1/2011 02:11'! allSlotsDo: aBlock parentScope allSlotsDo: aBlock. self do: aBlock! ! !LayoutClassScope methodsFor: 'accessing' stamp: 'CamilloBruni 4/6/2011 14:26'! ownFieldSize |result| result := 0. self do: [ :slot | result := result + slot size ]. ^ result! ! !LayoutClassScope methodsFor: 'testing' stamp: 'CamilloBruni 4/4/2011 12:48'! hasFields self do: [ :slot | slot size > 0 ifTrue: [ ^ true ]]. ^ parentScope hasFields! ! !LayoutClassScope methodsFor: 'enumerating' stamp: 'CamilloBruni 4/4/2011 14:30'! allSlotsReverseDo: aBlock self reverseDo: aBlock. parentScope allSlotsReverseDo: aBlock.! ! !LayoutClassScope methodsFor: 'accessing' stamp: 'MartinDias 4/12/2013 13:35'! parentScope: aLayoutScope parentScope := aLayoutScope! ! !LayoutClassScope methodsFor: 'enumerating' stamp: 'CamilloBruni 10/16/2011 20:08'! withIndexDo: elementAndIndexBlock "Just like with:do: except that the iteration index supplies the second argument to the block." 1 to: self size do: [:index | elementAndIndexBlock value: (self at: index) value: index]! ! !LayoutClassScope methodsFor: 'printing' stamp: 'CamilloBruni 4/4/2011 12:48'! printSlotDefinitionOn: aStream | printedAtLeastOnSlot | aStream << '{'. printedAtLeastOnSlot := false. self do: [ :slot | slot isVisible ifTrue: [ aStream lf; tab; tab; store: slot; << '.'. printedAtLeastOnSlot := true.]]. printedAtLeastOnSlot ifTrue: [ aStream lf; tab ]. aStream << '}'.! ! !LayoutClassScope methodsFor: 'testing' stamp: 'CamilloBruni 4/4/2011 12:48'! hasSlots self size > 0 ifTrue: [ ^ true ]. ^ parentScope hasSlots! ! !LayoutClassScope methodsFor: 'comparing' stamp: 'MartinDias 4/12/2013 13:31'! = other super = other ifFalse: [ ^ false ]. self size = other size ifFalse: [ ^ false ]. 1 to: self size do: [ :index| (self at: index) = (other at: index) ifFalse: [ ^ false ]]. ^ self parentScope = other parentScope.! ! !LayoutClassScope methodsFor: 'enumerating' stamp: 'ToonVerwaest 4/1/2011 02:10'! do: aBlock 1 to: self size do: [ :index | aBlock value: (self at: index) ]! ! !LayoutClassScope methodsFor: 'accessing' stamp: 'CamilloBruni 4/6/2011 14:25'! fieldSize ^ parentScope fieldSize + self ownFieldSize.! ! !LayoutClassScope methodsFor: 'copying' stamp: 'ToonVerwaest 4/2/2011 18:26'! postCopy parentScope := parentScope copy. 1 to: self size do: [ :index | self at: index put: (self at: index) copy ]! ! !LayoutClassScope methodsFor: 'enumerating' stamp: 'CamilloBruni 4/4/2011 14:49'! reverseDo: aBlock |size| size := self size. 1 to: size do: [ :index | aBlock value: (self at: (1 + size - index)) ]! ! !LayoutClassScope methodsFor: 'flattening' stamp: 'ToonVerwaest 4/1/2011 01:56'! flatten | result | result := parentScope flatten. result addAll: self. ^ result! ! !LayoutClassScope methodsFor: 'accessing' stamp: 'CamilloBruni 4/4/2011 12:48'! visibleSlotNames | result | result := OrderedCollection new. self do: [ :slot | slot isVisible ifTrue: [ result add: slot name ]]. ^ result asArray! ! !LayoutClassScope methodsFor: 'enumerating' stamp: 'CamilloBruni 4/4/2011 18:31'! withParentScopesDo: aBlock aBlock value: self. parentScope withParentScopesDo: aBlock.! ! !LayoutClassScope methodsFor: 'printing' stamp: 'MartinDias 9/5/2013 15:49'! printOn: aStream super printOn: aStream. self allVisibleSlots printElementsOn: aStream.! ! !LayoutClassScope methodsFor: 'accessing' stamp: 'MartinDias 4/12/2013 13:48'! parentScope ^ parentScope! ! !LayoutClassScope methodsFor: 'accessing' stamp: 'CamilloBruni 4/4/2011 12:48'! allVisibleSlots | result | result := parentScope allVisibleSlots. self do: [ :slot | slot isVisible ifTrue: [ result add: slot ]]. ^ result! ! !LayoutEmptyScope commentStamp: ''! I am the last layout scope in a scope chain.! !LayoutEmptyScope methodsFor: 'testing' stamp: 'ToonVerwaest 4/2/2011 14:33'! hasSlots ^ false! ! !LayoutEmptyScope methodsFor: 'accessing' stamp: 'ToonVerwaest 4/2/2011 14:31'! fieldSize ^ 0! ! !LayoutEmptyScope methodsFor: 'accessing' stamp: 'ToonVerwaest 4/2/2011 19:11'! visibleSlotNames ^ {}! ! !LayoutEmptyScope methodsFor: 'enumerating' stamp: 'CamilloBruni 4/4/2011 18:31'! withParentScopesDo: aBlock aBlock value: self.! ! !LayoutEmptyScope methodsFor: 'enumerating' stamp: 'ToonVerwaest 4/2/2011 14:32'! allSlotsDo: aBlock! ! !LayoutEmptyScope methodsFor: 'accessing' stamp: 'CamilloBruni 4/6/2011 14:26'! ownFieldSize ^ 0! ! !LayoutEmptyScope methodsFor: 'testing' stamp: 'ToonVerwaest 4/2/2011 14:33'! hasFields ^ false! ! !LayoutEmptyScope methodsFor: 'enumerating' stamp: 'CamilloBruni 4/4/2011 14:30'! allSlotsReverseDo: aBlock! ! !LayoutEmptyScope methodsFor: 'flattening' stamp: 'ToonVerwaest 4/2/2011 14:32'! flatten ^ OrderedCollection new! ! !LayoutEmptyScope methodsFor: 'accessing' stamp: 'ToonVerwaest 4/2/2011 19:08'! allVisibleSlots ^ OrderedCollection new! ! !LayoutEmptyScope methodsFor: 'printing' stamp: 'ToonVerwaest 4/2/2011 14:33'! printSlotDefinitionOn: aStream aStream << '{}'! ! !LayoutEmptyScope class methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 01:31'! instance ^ instance ifNil: [ instance := self new ]! ! !LayoutFrame commentStamp: ''! I define a transformation frame relative to some rectangle. I'm basic data structure used for graphics. Instance variables: leftFraction topFraction rightFraction bottomFraction The fractional distance (between 0 and 1) to place the morph in its owner's bounds leftOffset topOffset rightOffset bottomOffset Fixed pixel offset to apply after fractional positioning (e.g., "10 pixel right of the center of the owner")! !LayoutFrame methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/15/2013 11:28'! generateSpecFormat ^ self asArray generateSpecFormat! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! bottomOffset ^bottomOffset! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! bottomFraction ^bottomFraction! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! rightOffset ^rightOffset! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! topFraction ^topFraction! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! leftFraction: aNumber offset: anInteger leftFraction := aNumber. leftOffset := anInteger! ! !LayoutFrame methodsFor: 'objects from disk' stamp: 'StephaneDucasse 12/24/2012 16:52'! negateBottomRightOffsets bottomOffset := bottomOffset negated. rightOffset := rightOffset negated. ! ! !LayoutFrame methodsFor: 'accessing' stamp: 'IgorStasenko 12/18/2012 16:50'! bottomRightOffset: aPoint bottomOffset := aPoint y. rightOffset := aPoint x.! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! bottomOffset: anInteger bottomOffset := anInteger! ! !LayoutFrame methodsFor: 'initialization' stamp: 'IgorStasenko 12/18/2012 16:58'! initialize "initialize defaults: - all offsets are zero - fraction frame is maximum" leftOffset := rightOffset := topOffset := bottomOffset := 0. leftFraction := topFraction := 0. rightFraction := bottomFraction := 1.! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! rightOffset: anInteger rightOffset := anInteger! ! !LayoutFrame methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 1/15/2013 11:08'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' ( '. aStream print: self leftFraction @ self topFraction; nextPutAll: ' + '; print: self leftOffset @ self topOffset ; nextPutAll: 'px corner: '; print: self rightFraction @ self bottomFraction; nextPutAll: ' + '; print: self rightOffset @ self bottomOffset ; nextPutAll: 'px ) '! ! !LayoutFrame methodsFor: 'converting' stamp: 'StephaneDucasse 12/21/2012 13:52'! asLayoutFrame ^self! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'! topOffset: anInteger topOffset := anInteger! ! !LayoutFrame methodsFor: 'accessing' stamp: 'IgorStasenko 12/18/2012 16:50'! topLeftOffset: aPoint topOffset := aPoint y. leftOffset := aPoint x.! ! !LayoutFrame methodsFor: 'accessing' stamp: 'StephaneDucasse 12/21/2012 13:14'! fromArray: anArray | str | str := anArray readStream. #( leftFraction: topFraction: rightFraction: bottomFraction: leftOffset: topOffset: rightOffset: bottomOffset: ) do: [:sel | str next ifNil: [ ^ self ] ifNotNil: [:value | self perform: sel with: value ] ]! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! bottomFraction: aNumber bottomFraction := aNumber! ! !LayoutFrame methodsFor: 'transforming' stamp: 'StephaneDucasse 12/21/2012 18:42'! transform: rect "Answer a new rectangle which is an original rectangle transformed by receiver" ^ Rectangle left: (rect left + (rect width * leftFraction) + leftOffset) rounded asInteger right: (rect right - (rect width * (1 - rightFraction)) + rightOffset) rounded asInteger top: (rect top + (rect height * topFraction) + topOffset ) rounded asInteger bottom: (rect bottom - (rect height * (1 - bottomFraction)) + bottomOffset) rounded asInteger. ! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! bottomFraction: aNumber offset: anInteger bottomFraction := aNumber. bottomOffset := anInteger! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! leftOffset ^leftOffset! ! !LayoutFrame methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 4/1/2014 12:55'! isHorizontallyResizeable ^ self rightFraction ~= self leftFraction! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! leftOffset: anInteger leftOffset := anInteger! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'! topFraction: aNumber offset: anInteger topFraction := aNumber. topOffset := anInteger! ! !LayoutFrame methodsFor: 'converting' stamp: 'StephaneDucasse 12/24/2012 17:03'! asArray ^ { leftFraction . topFraction . rightFraction . bottomFraction . leftOffset . topOffset . rightOffset . bottomOffset } ! ! !LayoutFrame methodsFor: 'accessing' stamp: ''! fractions: fractionsOrNil offsets: offsetsOrNil | fractions offsets | fractions := fractionsOrNil ifNil: [0@0 extent: 0@0]. offsets := offsetsOrNil ifNil: [0@0 extent: 0@0]. ^self topFraction: fractions top offset: offsets top; leftFraction: fractions left offset: offsets left; bottomFraction: fractions bottom offset: offsets bottom; rightFraction: fractions right offset: offsets right ! ! !LayoutFrame methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/15/2013 11:32'! generateSpec ^ self asArray generateSpec! ! !LayoutFrame methodsFor: 'accessing' stamp: 'StephaneDucasse 12/27/2012 22:44'! fractionRectangle "Return a rectangle representing the fraction part of layout frame: i.e left@top corner: right@bottom" ^ leftFraction @ topFraction corner: rightFraction @ bottomFraction ! ! !LayoutFrame methodsFor: 'accessing' stamp: 'bvr 6/1/2012 15:43'! fractions: fractionsOrNil ^ self fractions: fractionsOrNil offsets: nil! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! topFraction: aNumber topFraction := aNumber! ! !LayoutFrame methodsFor: 'testing' stamp: 'StephaneDucasse 12/27/2012 18:30'! hasNoOffsets ^ leftOffset = 0 and: [rightOffset = 0 and: [ topOffset = 0 and: [ bottomOffset = 0 ]]]. ! ! !LayoutFrame methodsFor: 'layout' stamp: 'StephaneDucasse 5/31/2013 16:19'! center: targetMorph with: anotherMorph "Change the receiver to center the targetMorph with anotherMorph. Note the targetMorph is the morph on which the receiver will be applied. anotherMorph is often the morph containing the targetMorph. " self topOffset: (anotherMorph height - targetMorph height) // 2. self leftOffset: (anotherMorph width - targetMorph width) // 2. ! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! rightFraction ^rightFraction! ! !LayoutFrame methodsFor: '*Polymorph-Widgets-override' stamp: 'StephaneDucasse 12/24/2012 16:56'! minExtentFrom: minExtent "Return the minimal extent the given bounds can be represented in." | width height widthProp heightProp | "calculate proportional area. bottom/right offsets extend in +ve direction." width := minExtent x + leftOffset - rightOffset. height := minExtent y + topOffset - bottomOffset. "calculate the effective proportion" widthProp := rightFraction - leftFraction. heightProp := bottomFraction - topFraction. "if the proportions are 0 then the minima cannot be determined and minExtent cannot be respected." width := widthProp = 0 ifTrue: [0] ifFalse: [width / widthProp]. height := heightProp = 0 ifTrue: [0] ifFalse: [height / heightProp]. ^width truncated @ height truncated! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! leftFraction: aNumber leftFraction := aNumber! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'! topOffset ^topOffset! ! !LayoutFrame methodsFor: 'layout' stamp: 'StephaneDucasse 12/21/2012 18:43'! layout: oldBounds in: newBounds "Return the proportional rectangle insetting the given bounds" ^ self transform: newBounds ! ! !LayoutFrame methodsFor: 'printing' stamp: 'StephaneDucasse 12/24/2012 18:26'! isSelfEvaluating ^ false! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! leftFraction ^leftFraction! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! rightFraction: aNumber rightFraction := aNumber! ! !LayoutFrame methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 4/1/2014 12:55'! isVerticallyResizeable ^ self bottomFraction ~= self topFraction! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! rightFraction: aNumber offset: anInteger rightFraction := aNumber. rightOffset := anInteger! ! !LayoutFrame class methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/19/2012 15:56'! identity "by default a layout frame is initialized to represent the identity transformation" ^ self new! ! !LayoutFrame class methodsFor: 'instance creation' stamp: 'ar 2/5/2002 20:06'! offsets: offsetsOrNil ^self fractions: nil offsets: offsetsOrNil! ! !LayoutFrame class methodsFor: 'instance creation' stamp: 'ar 2/5/2002 00:07'! fractions: fractionsOrNil ^self fractions: fractionsOrNil offsets: nil! ! !LayoutFrame class methodsFor: 'instance creation' stamp: 'RAA 1/8/2001 21:22'! fractions: fractionsOrNil offsets: offsetsOrNil | fractions offsets | fractions := fractionsOrNil ifNil: [0@0 extent: 0@0]. offsets := offsetsOrNil ifNil: [0@0 extent: 0@0]. ^self new topFraction: fractions top offset: offsets top; leftFraction: fractions left offset: offsets left; bottomFraction: fractions bottom offset: offsets bottom; rightFraction: fractions right offset: offsets right ! ! !LayoutFrameTest methodsFor: 'tests' stamp: 'StephaneDucasse 12/21/2012 11:24'! testSpaceFill | lf rectangle | lf := LayoutFrame identity. rectangle := lf layout: nil in: (50@10 corner: 150@70). self assert: (50@10 corner: 150@70) = rectangle! ! !LayoutFrameTest methodsFor: 'tests - conversion' stamp: 'BenjaminVanRyseghem 1/15/2013 11:14'! testAsLayoutFrame | frame | frame := #(0.66 0.5 1 0.77 1 2 3 25) asLayoutFrame. self assert: frame leftFraction equals: 0.66. self assert: frame topFraction equals: 0.5. self assert: frame leftOffset equals: 1. self assert: frame topOffset equals: 2. self assert: frame rightFraction equals: 1. self assert: frame bottomFraction equals: 0.77. self assert: frame rightOffset equals: 3. self assert: frame bottomOffset equals: 25.! ! !LayoutFrameTest methodsFor: 'tests' stamp: 'StephaneDucasse 12/21/2012 11:23'! testLeftTopAligned | lf rectangle | lf := LayoutFrame new leftOffset: 10; topOffset: 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! ! !LayoutFrameTest methodsFor: 'tests' stamp: 'StephaneDucasse 12/21/2012 11:23'! testInset | lf rectangle | lf := LayoutFrame new leftOffset: 10; topOffset: 10; rightOffset: -10; bottomOffset: -10; yourself. rectangle := lf layout: nil in: (50@10 corner: 150@70). self assert: (60@20 corner: 140@60) = rectangle! ! !LayoutFrameTest methodsFor: 'tests' stamp: 'StephaneDucasse 4/28/2010 22:18'! 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! ! !LayoutPolicy commentStamp: ''! A LayoutPolicy defines how submorphs of some morph should be arranged. Subclasses of the receiver define concrete layout policies.! !LayoutPolicy methodsFor: 'layout' stamp: 'ar 10/31/2000 19:59'! minExtentOf: aMorph in: newBounds "Return the minimal size aMorph's children would require given the new bounds" ^0@0! ! !LayoutPolicy methodsFor: 'layout' stamp: 'ar 1/27/2001 14:39'! flushLayoutCache "Flush any cached information associated with the receiver"! ! !LayoutPolicy methodsFor: 'testing' stamp: 'ar 10/29/2000 01:28'! isTableLayout ^false! ! !LayoutPolicy methodsFor: 'testing' stamp: 'ar 10/29/2000 01:28'! isProportionalLayout ^false! ! !LayoutPolicy methodsFor: 'utilities' stamp: 'ar 10/29/2000 17:31'! indexForInserting: aMorph at: aPoint in: someMorph "Return the insertion index based on the layout strategy defined for some morph. Used for drop insertion." ^1 "front-most"! ! !LayoutPolicy methodsFor: 'layout' stamp: 'ar 10/28/2000 19:12'! layout: aMorph in: newBounds "Compute the layout for the given morph based on the new bounds" ! ! !LayoutProperties commentStamp: ''! This class provides a compact bit encoding for the most commonly used layout properties.! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'! maxCellSize ^SmallInteger maxVal! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'! reverseTableCells ^false! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 16:38'! layoutInset ^0! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:59'! listDirection "Default" ^#topToBottom! ! !LayoutProperties methodsFor: 'converting' stamp: 'ar 11/14/2000 17:52'! asTableLayoutProperties ^(TableLayoutProperties new) hResizing: self hResizing; vResizing: self vResizing; disableTableLayout: self disableTableLayout; yourself! ! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! hResizing: aSymbol hResizing := aSymbol! ! !LayoutProperties methodsFor: 'testing' stamp: 'ar 11/13/2000 18:34'! includesTableProperties ^false! ! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! hResizing ^hResizing! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:58'! listCentering "Default" ^#topLeft! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:59'! listSpacing "Default" ^#none! ! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:52'! vResizing: aSymbol vResizing := aSymbol! ! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! disableTableLayout: aBool disableLayout := aBool! ! !LayoutProperties methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:00'! initialize super initialize. hResizing := vResizing := #rigid. disableLayout := false.! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:50'! cellPositioning ^#center! ! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! vResizing ^vResizing! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:55'! cellSpacing "Default" ^#none! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:53'! cellInset "Default" ^0! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:02'! wrapCentering ^#topLeft! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:02'! wrapDirection ^#none! ! !LayoutProperties methodsFor: 'initialize' stamp: 'ar 11/14/2000 17:56'! initializeFrom: defaultProvider "Initialize the receiver from a default provider" self hResizing: defaultProvider hResizing. self vResizing: defaultProvider vResizing. self disableTableLayout: defaultProvider disableTableLayout.! ! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! disableTableLayout ^disableLayout! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'! minCellSize ^0! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:01'! rubberBandCells ^false! ! !LazyClassListExample commentStamp: 'AlainPlantec 1/17/2010 08:28'! LazyClassListExample new openOn: Object ! !LazyClassListExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/15/2010 13:59'! treeMorphClass ^ LazyMorphTreeMorph ! ! !LazyListMorph commentStamp: 'efc 8/6/2005 11:34'! The morph that displays the list in a PluggableListMorph. It is "lazy" because it will only request the list items that it actually needs to display. I will cache the maximum width of my items in maxWidth to avoid this potentially expensive and frequent computation.! !LazyListMorph methodsFor: 'drawing' stamp: 'MarcusDenker 9/13/2013 16:19'! drawSelectionOn: aCanvas "Draw the selection background." selectedRow ifNil: [ ^self ]. selectedRow = 0 ifTrue: [ ^self ]. self drawBackgroundForSelectedRow: selectedRow on: aCanvas ! ! !LazyListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 9/1/2011 10:39'! drawBackgroundForRow: row on: aCanvas color: aColor | frame | "shade the background darker, if this row is selected" frame := self selectionFrameForRow: row. aCanvas fillRectangle: frame color: aColor! ! !LazyListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 9/1/2011 10:40'! drawBackgroundForSelectedRow: row on: aCanvas self drawBackgroundForRow: row on: aCanvas color: listSource selectionColorToUse! ! !LazyListMorph methodsFor: 'list access' stamp: 'BenjaminVanRyseghem 2/12/2012 00:23'! item: index "return the index-th item, using the 'listItems' cache" | newItem itemWidth | (index between: 1 and: listItems size) ifFalse: [ "there should have been an update, but there wasn't!!" ^self getListItem: index]. (listItems at: index) ifNil: [ newItem := self getListItem: index. "Update the width cache." maxWidth ifNotNil:[ itemWidth := newItem widthToDisplayInList: self. itemWidth > maxWidth ifTrue:[ maxWidth := itemWidth. self adjustWidth. ]]. listItems at: index put: newItem ]. ^listItems at: index! ! !LazyListMorph methodsFor: 'row management' stamp: 'BenjaminVanRyseghem 2/12/2012 00:23'! hUnadjustedScrollRange "Ok, this is a bit messed up. We need to return the width of the widest item in the list. If we grab every item in the list, it defeats the purpose of LazyListMorph. If we don't, then we don't know the size. This is a compromise -- find the widest of the first 30 items, then double it, This width will be updated as new items are installed, so it will always be correct for the visible items. If you know a better way, please chime in." | itemsToCheck item index | "Check for a cached value" maxWidth ifNotNil:[^maxWidth]. listItems isEmpty ifTrue: [^0]. "don't set maxWidth if empty do will be recomputed when there are some items" "Compute from scratch" itemsToCheck := 30 min: (listItems size). maxWidth := 0. "Check the first few items to get a representative sample of the rest of the list." index := 1. [index < itemsToCheck] whileTrue: [ item := self getListItem: index. "Be careful not to actually install this item" maxWidth := maxWidth max: (item widthToDisplayInList: self). index:= index + 1. ]. "Add some initial fudge if we didn't check all the items." (itemsToCheck < listItems size) ifTrue:[maxWidth := maxWidth*2]. ^maxWidth ! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 7/5/2000 18:04'! font: newFont font := (newFont ifNil: [ TextStyle default defaultFont ]). self adjustHeight. self changed.! ! !LazyListMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/29/2009 21:59'! initialize super initialize. self color: Color black. font := StandardFonts listFont. listItems := #(). selectedRow := nil. selectedRows := PluggableSet integerSet. self adjustHeight.! ! !LazyListMorph methodsFor: 'row management' stamp: 'AlainPlantec 9/11/2011 05:41'! colorForRow: row "Answer the color for the row text." ^ (self isRowSelected: row ) ifTrue: [self theme currentSettings selectionTextColor] ifFalse: [self color]! ! !LazyListMorph methodsFor: 'row management' stamp: 'gvc 7/24/2007 11:45'! selectRow: index "Select the index-th row." selectedRows add: index. self invalidRect: (self selectionFrameForRow: index)! ! !LazyListMorph methodsFor: 'list management' stamp: 'ls 10/20/2001 00:09'! rowAtLocation: aPoint "return the number of the row at aPoint" | y | y := aPoint y. y < self top ifTrue: [ ^ 1 ]. ^((y - self top // (font height)) + 1) min: listItems size max: 0! ! !LazyListMorph methodsFor: 'list management' stamp: 'ThierryGoubier 9/24/2012 15:50'! drawBoundsForRow: row "calculate the bounds that row should be drawn at. This might be outside our bounds!!" | topLeft drawBounds item width height | item := [ self getListItem: row ] on: SubscriptOutOfBounds do: [ :ex | self getListItem: (row min: self getListSize) ]. height := item heightToDisplayInList: self. width := item widthToDisplayInList: self. topLeft := self topLeft x @ (self topLeft y + ((row - 1) * height)). drawBounds := topLeft extent: width @ height. ^ drawBounds! ! !LazyListMorph methodsFor: 'accessing' stamp: 'bf 4/21/2005 15:58'! userString "Do I have a text string to be searched on?" ^ String streamContents: [:strm | 1 to: self getListSize do: [:i | strm nextPutAll: (self getListItem: i); cr]]! ! !LazyListMorph methodsFor: 'list access' stamp: 'MarcusDenker 10/3/2013 23:38'! getListSize "return the number of items in the list" ^listSource ifNil: [ 0 ] ifNotNil: [ :source | source getListSize] ! ! !LazyListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 13:06'! mouseDownRow: anInteger "Set the row that should have mouse down highlighting or nil if none." anInteger = self mouseDownRow ifTrue: [^self]. self mouseDownRowFrameChanged. self setProperty: #mouseDownRow toValue: anInteger. self mouseDownRowFrameChanged! ! !LazyListMorph methodsFor: '*Polymorph-Widgets' stamp: 'IgorStasenko 2/19/2013 14:28'! selectionFrameForRow: row "Answer the selection frame rectangle." |frame| frame := self drawBoundsForRow: row. frame := frame intersect: self bounds . frame := self bounds: frame in: listSource. frame := self bounds: ((frame left: listSource innerBounds left) right: listSource innerBounds right) from: listSource. ^frame! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 21:57'! topVisibleRowForCanvas: aCanvas "return the top visible row in aCanvas's clip rectangle" ^self rowAtLocation: aCanvas clipRect topLeft. ! ! !LazyListMorph methodsFor: 'row management' stamp: 'MarcusDenker 9/13/2013 16:19'! display: item atRow: row on: aCanvas "Display the given item at the given row on the given canvas." | itemColor backgroundColor drawBounds | drawBounds := self drawBoundsForRow: row. itemColor := self colorForRow: row. backgroundColor := self backgroundColorForRow: row. item listRenderOn: aCanvas atRow: row bounds: drawBounds color: itemColor backgroundColor: backgroundColor from: self. row = self mouseDownRow ifTrue: [ aCanvas frameRectangle: (self selectionFrameForRow: row) width: 1 colors: {itemColor. (Color transparent)} dashes: #(1 1) ]! ! !LazyListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 9/1/2011 10:39'! drawBackgroundForSearchedRow: row on: aCanvas self drawBackgroundForRow: row on: aCanvas color: listSource secondarySelectionColor! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/15/2001 22:13'! adjustHeight "private. Adjust our height to match the length of the underlying list" self height: (listItems size max: 1) * font height ! ! !LazyListMorph methodsFor: 'drawing' stamp: 'NicolasPetton 3/18/2013 17:36'! drawOn: aCanvas listItems size = 0 ifTrue: [^ self]. aCanvas fillRectangle: aCanvas clipRect color: (self theme listNormalFillStyleFor: self). "self drawSelectionOn: aCanvas." (self topVisibleRowForCanvas: aCanvas) to: (self bottomVisibleRowForCanvas: aCanvas) do: [:row | (listSource itemSelectedAmongMultiple: row) ifTrue: [ self drawBackgroundForSelectedRow: row on: aCanvas] ifFalse: [ (listSource searchedElement = row) ifTrue: [ self drawBackgroundForSearchedRow: row on: aCanvas] ifFalse: [ (listSource backgroundColorFor: row) ifNotNil: [:col | self drawBackgroundForRow: row on: aCanvas color: col ]]]. selectedRow = row ifTrue: [ self drawSelectionOn: aCanvas ]. (listSource separatorAfterARow: row) ifTrue: [ self drawSeparatorAfter: row on: aCanvas ]. self display: (self item: row) atRow: row on: aCanvas]. listSource potentialDropRow > 0 ifTrue: [self highlightPotentialDropRow: listSource potentialDropRow on: aCanvas]! ! !LazyListMorph methodsFor: 'drawing' stamp: 'sps 3/9/2004 17:06'! adjustWidth "private. Adjust our height to match the length of the underlying list" self width: ((listSource width max: self hUnadjustedScrollRange) + 20). ! ! !LazyListMorph methodsFor: 'row management' stamp: 'BenjaminVanRyseghem 2/21/2013 23:07'! backgroundColorForRow: row "Answer the color for the row text." ^ (self isRowSelected: row ) ifTrue: [ listSource selectionColorToUse ] ifFalse: [ Color white ]! ! !LazyListMorph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/11/2012 15:12'! drawOnAthensCanvas: aCanvas "self drawSelectionOn: aCanvas." 1 to: listItems size do: [:row | (listSource itemSelectedAmongMultiple: row) ifTrue: [ self athensDrawBackgroundForSelectedRow: row on: aCanvas] ifFalse: [ (listSource searchedElement = row) ifTrue: [ self athensDrawBackgroundForSearchedRow: row on: aCanvas] ifFalse: [ (listSource backgroundColorFor: row) ifNotNil: [:col | self athensDrawBackgroundForRow: row on: aCanvas color: col ]]]. selectedRow = row ifTrue: [ self athensDrawSelectionOn: aCanvas ]. (listSource separatorAfterARow: row) ifTrue: [ self athensDrawSeparatorAfter: row on: aCanvas ]. self athensDisplay: (self item: row) atRow: row on: aCanvas]. "listSource potentialDropRow > 0 ifTrue: [self athensHighlightPotentialDropRow: listSource potentialDropRow on: aCanvas]"! ! !LazyListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:12'! listSource: aListSource "set the source of list items -- typically a PluggableListMorph" listSource := aListSource. self listChanged! ! !LazyListMorph methodsFor: 'drawing' stamp: 'IgorStasenko 12/22/2012 03:07'! drawBackgroundForPotentialDrop: row on: aCanvas | selectionDrawBounds | "shade the background darker, if this row is a potential drop target" selectionDrawBounds := self drawBoundsForRow: row. selectionDrawBounds := selectionDrawBounds intersect: self bounds ifNone: [^ self ]. aCanvas fillRectangle: selectionDrawBounds color: self color muchLighter darker! ! !LazyListMorph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/11/2012 15:29'! athensDisplay: item atRow: row on: aCanvas "Display the given item at the given row on the given canvas." | c drawBounds frame attrs useDefaultFont | " drawBounds := self drawBoundsForRow: row. c := self colorForRow: row. aCanvas morphicDrawString: item asString at: drawBounds topLeft font: self font color: (self colorForRow: row)"! ! !LazyListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 9/16/2011 17:06'! drawSeparatorAfter: aRow on: aCanvas | frame rectangle height separatorColor | height := listSource separatorSize. separatorColor := listSource separatorColor. frame := self selectionFrameForRow: aRow. rectangle := (frame left@(frame bottom - height)) corner: (frame right@frame bottom). aCanvas fillRectangle: rectangle color: separatorColor! ! !LazyListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2009 14:04'! mouseDownRowFrameChanged "Invalidate frame of the current mouse down row if any." |frame row| row := self mouseDownRow ifNil: [ ^self ]. frame := self selectionFrameForRow: row. self invalidRect: frame! ! !LazyListMorph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/4/2011 16:50'! athensDrawSelectionOn: anAthensCanvas self value! ! !LazyListMorph methodsFor: 'drawing' stamp: 'IgorStasenko 12/22/2012 03:07'! highlightPotentialDropRow: row on: aCanvas | drawBounds | drawBounds := self drawBoundsForRow: row. drawBounds := drawBounds intersect: self bounds ifNone: [ ^ self ]. aCanvas frameRectangle: drawBounds color: Color blue! ! !LazyListMorph methodsFor: 'row management' stamp: 'gvc 7/24/2007 11:46'! unselectRow: index "Unselect the index-th row." selectedRows remove: index ifAbsent: [^self]. self invalidRect: (self selectionFrameForRow: index)! ! !LazyListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/12/2006 11:21'! mouseDownRow "Answer the row that should have mouse down highlighting if any." ^self valueOfProperty: #mouseDownRow! ! !LazyListMorph methodsFor: 'row management' stamp: 'gvc 7/24/2007 11:46'! selectedRow: index "Select the index-th row. if nil, remove the current selection." selectedRow ifNotNil: [self selectionFrameChanged]. selectedRow := index. selectedRow ifNotNil: [self selectionFrameChanged]! ! !LazyListMorph methodsFor: '*Polymorph-Widgets' stamp: 'GuillermoPolito 8/17/2012 15:01'! selectionFrameChanged "Invalidate frame of the current selection if any." | frame | selectedRow ifNil: [ ^self ]. selectedRow = 0 ifTrue: [ ^self ]. (selectedRow > self getListSize) ifTrue: [ ^self ]. frame := self selectionFrameForRow: selectedRow. self invalidRect: frame! ! !LazyListMorph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/9/2012 19:03'! athensDrawBackgroundForSelectedRow: row on: aCanvas aCanvas setPaint: listSource selectionColorToUse. aCanvas drawShape: (self selectionFrameForRow: row)! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 7/5/2000 18:37'! font "return the font used for drawing. The response is never nil" ^font! ! !LazyListMorph methodsFor: 'row management' stamp: 'AlainPlantec 2/11/2011 13:05'! isRowSelected: row "Answer true if the arg row is selected" ^ ((selectedRow notNil and: [row = selectedRow]) or: [listSource itemSelectedAmongMultiple: row]) ! ! !LazyListMorph methodsFor: 'row management' stamp: 'BenjaminVanRyseghem 2/28/2012 05:28'! listChanged "set newList to be the list of strings to display" listItems := Array new: self getListSize withAll: nil. self removeAllMorphs. selectedRow := nil. selectedRows := PluggableSet integerSet. maxWidth := nil. "recompute" self adjustHeight. self adjustWidth. self changed. ! ! !LazyListMorph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/9/2012 19:04'! athensDrawBackgroundForSearchedRow: row on: aCanvas aCanvas setPaint: listSource secondarySelectionColor. aCanvas drawShape: (self selectionFrameForRow: row)! ! !LazyListMorph methodsFor: 'list access' stamp: 'ls 8/19/2001 14:07'! getListItem: index "grab a list item directly from the model" ^listSource getListItem: index! ! !LazyListMorph methodsFor: 'list management' stamp: 'ls 7/7/2000 10:38'! selectedRow "return the currently selected row, or nil if none is selected" ^selectedRow! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 21:57'! bottomVisibleRowForCanvas: aCanvas "return the bottom visible row in aCanvas's clip rectangle" ^self rowAtLocation: aCanvas clipRect bottomLeft. ! ! !LazyMorphListMorph commentStamp: 'gvc 5/18/2007 12:47'! Support for morph lists in PluggableMorphListMorph.! !LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/12/2006 15:14'! display: item atRow: row on: aCanvas "Display the given item at the given row on the given canvas." |c frame| row = self mouseDownRow ifFalse: [^self]. frame := self selectionFrameForRow: row. c := self colorForRow: row. aCanvas frameRectangle: frame width: 1 colors: {c. Color transparent} dashes: #(1 1)! ! !LazyMorphListMorph methodsFor: 'initialization' stamp: 'gvc 6/13/2006 10:44'! initialize "Initialize the receiver." super initialize. self changeTableLayout; cellPositioning: #topLeft; cellInset: 2; vResizing: #shrinkWrap; hResizing: #rigid! ! !LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 13:38'! adjustHeight "private. Adjust our height to match the length of the underlying list. Automatic with table layout." ! ! !LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/22/2012 03:05'! drawSubmorphsOn: aCanvas "Display submorphs back to front" | drawBlock| submorphs isEmpty ifTrue: [^self]. drawBlock := [:canvas | | i | (self topVisibleRowForCanvas: aCanvas) to: (self bottomVisibleRowForCanvas: aCanvas) do: [ :row | i := self item: row. canvas fullDrawMorph: i]]. self clipSubmorphs ifTrue: [aCanvas clipBy: (aCanvas clipRect intersect: self clippingBounds ifNone: [ ^ self ]) during: drawBlock] ifFalse: [drawBlock value: aCanvas]! ! !LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/13/2006 11:12'! adjustWidth "private. Adjust our height to match the length of the underlying list" self width: (listSource innerBounds width max: self hUnadjustedScrollRange). ! ! !LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 12:24'! selectRow: index "select the index-th row" selectedRows add: index. self invalidRect: (self drawBoundsForRow: index)! ! !LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 13:36'! rowAtLocation: aPoint "return the number of the row at aPoint" | y | y := aPoint y. y < self top ifTrue: [ ^ 1 ]. listItems with: (1 to: listItems size) do: [:i :row | (y < i bottom) ifTrue: [^row]]. ^listItems size! ! !LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 5/3/2006 16:08'! drawBoundsForRow: row "Calculate the bounds that row should be drawn at. This might be outside our bounds!!" (row between: 1 and: listItems size) ifFalse: [^0@0 corner: 0@0]. ^(listItems at: row) bounds! ! !LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'GabrielOmarCotelli 11/30/2013 16:49'! userString "Do I have a text string to be searched on?" ^ String streamContents: [ :stream | 1 to: self getListSize do: [ :i | (self getListItem: i) submorphs detect: [ :morph | morph userString notNil ] ifFound: [ :morph | stream nextPutAll: morph userString ]. stream cr ] ]! ! !LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/20/2009 16:56'! listChanged "set newList to be the list of strings to display" listItems := (1 to: self getListSize) collect: [:i | self getListItem: i]. self removeAllMorphs. self extent: 0@0. listItems do: [:i | self addMorphBack: i]. selectedRow := nil. selectedRows := PluggableSet integerSet. maxWidth := nil. "recompute" self adjustHeight; adjustWidth. listItems do: [:i | i layoutChanged]. self changed. ! ! !LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 12/22/2012 03:05'! selectionFrameForRow: row "Answer the selection frame rectangle." |frame| frame := self drawBoundsForRow: row. frame := frame expandBy: (self cellInset // 2). self cellInset odd ifTrue: [frame := frame bottom: frame bottom + 1]. frame := frame intersect: self bounds ifNone: [ self error: 'should not happen' ]. frame := self bounds: frame in: listSource. frame := self bounds: ((frame left: listSource innerBounds left) right: listSource innerBounds right) from: listSource. ^frame! ! !LazyMorphListMorph methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 2/12/2012 00:24'! hUnadjustedScrollRange "Answer the width of the widest item." maxWidth ifNotNil:[^maxWidth]. listItems isEmpty ifTrue: [^0]. maxWidth := 0. listItems do: [:each | each ifNotNil: [maxWidth := maxWidth max: (each widthToDisplayInList: self)]]. ^maxWidth ! ! !LazyMorphTreeMorph commentStamp: ''! I am a MorphTreeMorph, but I only render the rows lazily as they appear on screen. Caveat: There is no rendering in the background. This means that if a row takes too long to render, you can experience a shorter or longer freeze when scrolling.! !LazyMorphTreeMorph methodsFor: 'lazy tree' stamp: 'AlainPlantec 11/15/2009 21:57'! indentingItemClass ^ LazyMorphTreeNodeMorph! ! !LazyMorphTreeMorph methodsFor: 'initialize - release' stamp: 'tg 11/16/2009 02:26'! lazyIncrement: anInteger lazyIncrement := anInteger ! ! !LazyMorphTreeMorph methodsFor: 'initialize - release' stamp: 'AlainPlantec 11/19/2009 17:31'! buildRowMorphsFrom: aNodeMorph self buildRowMorphsFrom: aNodeMorph increment: self lazyIncrement. ! ! !LazyMorphTreeMorph methodsFor: 'initialize - release' stamp: 'AlainPlantec 10/9/2011 00:09'! adjustSubmorphPositionsFrom: start to: stop "Fixed to not require setting item widths to 9999." | subs p | subs := self allNodeMorphs. p := (subs at: start) position. start to: subs size do: [:idx | | each h | each := subs at: idx. h := each height. each bounds: (p extent: each width@h). p := p + (0@h)]. ! ! !LazyMorphTreeMorph methodsFor: 'initialize - release' stamp: 'AlainPlantec 10/9/2011 00:10'! buildRowMorphsFromIndex: startIndex to: stopIndex | rowMorphsWidths subs | subs := self allNodeMorphs. rowMorphsWidths := self rowMorphsWidths. startIndex to: stopIndex do: [:p | (subs at: p) buildRowMorph; updateColumnMorphsWidthWith: rowMorphsWidths]. self setScrollDeltas. self adjustSubmorphPositionsFrom: startIndex to: stopIndex. self setScrollDeltas. startIndex to: stopIndex do: [:pos | (subs at: pos) drawable: true]. ! ! !LazyMorphTreeMorph methodsFor: 'initialize - release' stamp: 'AlainPlantec 10/9/2011 00:09'! buildRowMorphsFrom: aNodeMorph increment: anIncrement Cursor wait showWhile: [ | subs idx max | subs := self allNodeMorphs. idx := aNodeMorph index. max := (idx + anIncrement) min: subs size. self buildRowMorphsFromIndex: idx to: max].! ! !LazyMorphTreeMorph methodsFor: 'initialize - release' stamp: 'AlainPlantec 2/6/2010 13:42'! lazyIncrement ^ lazyIncrement ifNil: [ lazyIncrement := 20 ] ! ! !LazyMorphTreeNodeMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/15/2009 23:01'! initialize super initialize. drawable := false! ! !LazyMorphTreeNodeMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/15/2009 22:09'! initRow! ! !LazyMorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/19/2009 16:50'! drawSubmorphsOn: aCanvas drawable ifFalse: [^ self]. super drawSubmorphsOn: aCanvas. ! ! !LazyMorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/20/2009 07:27'! drawOn: aCanvas drawable ifFalse: [container buildRowMorphsFrom: self] ifTrue: [super drawOn: aCanvas] ! ! !LazyMorphTreeNodeMorph methodsFor: 'drawing' stamp: 'AlainPlantec 11/19/2009 18:33'! drawable ^ drawable ifNil: [false] ! ! !LazyMorphTreeNodeMorph methodsFor: 'drawing' stamp: 'AlainPlantec 11/16/2009 10:20'! drawable: aBoolean drawable := aBoolean. ! ! !LeafNode commentStamp: ''! I represent a leaf node of the compiler parse tree. I am abstract. Types (defined in class ParseNode): 1 LdInstType (which uses class VariableNode) 2 LdTempType (which uses class VariableNode) 3 LdLitType (which uses class LiteralNode) 4 LdLitIndType (which uses class VariableNode) 5 SendType (which uses class SelectorNode). Note that Squeak departs slightly from the Blue Book bytecode spec. In order to allow access to more than 63 literals and instance variables, bytecode 132 has been redefined as DoubleExtendedDoAnything: byte2 byte3 Operation (hi 3 bits) (lo 5 bits) 0 nargs lit index Send Literal Message 0-255 1 nargs lit index Super-Send Lit Msg 0-255 2 ignored rcvr index Push Receiver Variable 0-255 3 ignored lit index Push Literal Constant 0-255 4 ignored lit index Push Literal Variable 0-255 5 ignored rcvr index Store Receiver Variable 0-255 6 ignored rcvr index Store-pop Receiver Variable 0-255 7 ignored lit index Store Literal Variable 0-255 This has allowed bytecode 134 also to be redefined as a second extended send that can access literals up to 64 for nargs up to 3 without needing three bytes. It is just like 131, except that the extension byte is aallllll instead of aaalllll, where aaa are bits of argument count, and lll are bits of literal index.! !LeafNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:39'! code ^ code! ! !LeafNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 15:56'! key: object index: i type: type key := object. code := (self code: i type: type). index := i! ! !LeafNode methodsFor: 'initialize-release' stamp: 'ar 3/26/2004 15:44'! name: ignored key: object code: byte key := object. code := byte! ! !LeafNode methodsFor: 'code generation (closures)' stamp: 'eem 6/16/2008 09:32'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" "This is a no-op except in TempVariableNode" ^self! ! !LeafNode methodsFor: 'copying' stamp: 'eem 5/14/2008 11:25'! veryDeepFixupWith: deepCopier "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. key := (deepCopier references at: key ifAbsent: [key]). ! ! !LeafNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52'! emitCodeForEffect: stack encoder: encoder ^self! ! !LeafNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 15:24'! sizeCodeForLoad: encoder "Default is to do nothing. Subclasses may need to override." ^0! ! !LeafNode methodsFor: 'code generation' stamp: 'eem 5/19/2008 15:10'! sizeCodeForValue: encoder self subclassResponsibility! ! !LeafNode methodsFor: 'initialize-release' stamp: 'ar 3/26/2004 15:44'! key: object code: byte key := object. code := byte! ! !LeafNode methodsFor: 'code generation' stamp: 'eem 5/20/2008 15:25'! emitCodeForLoad: stack encoder: encoder "Default is to do nothing. Subclasses may need to override."! ! !LeafNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 15:57'! reserve: encoder "If this is a yet unused literal of type -code, reserve it." code < 0 ifTrue: [code := self code: (index := encoder litIndex: key) type: 0 - code]! ! !LeafNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52'! sizeCodeForEffect: encoder ^0! ! !LeafNode methodsFor: 'copying' stamp: 'eem 7/12/2008 17:24'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. "key := key. Weakly copied" code := code veryDeepCopyWith: deepCopier. index := index veryDeepCopyWith: deepCopier. ! ! !LeafNode methodsFor: 'accessing' stamp: ''! key ^key! ! !LeafNode methodsFor: 'private' stamp: 'ClementBera 7/26/2013 16:48'! code: argIndex type: type argIndex ifNil: [^type negated]. (CodeLimits at: type) > argIndex ifTrue: [^(CodeBases at: type) + argIndex]. ^type * 256 + argIndex! ! !LegacyWeakSubscription commentStamp: 'IgorStasenko 3/12/2011 21:37'! I am a subclass which work when VM does not supports finalization lists. I am about 3 times slower when it comes to finalizing items! !LegacyWeakSubscription methodsFor: 'finalization' stamp: 'IgorStasenko 3/12/2011 18:19'! register self weakRegistry add: self subscriber executor: self! ! !LegacyWeakSubscription methodsFor: 'finalization' stamp: 'MarcusDenker 10/10/2013 23:38'! unregister self subscriber ifNotNil: [:sub | self weakRegistry remove: sub ] ! ! !LegacyWeakSubscription methodsFor: 'converting' stamp: 'IgorStasenko 3/12/2011 18:32'! makeStrong | sub | sub := self subscriber. sub ifNil: [ ^ self error: 'Subscriber is nil, cannot make strong subscription' ]. self unregister. ^ self becomeForward: (AnnouncementSubscription new announcer: announcer; action: action asMessageSend; subscriber: sub; announcementClass: announcementClass) ! ! !LegacyWeakSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 20:01'! subscriber: anObject self subscriber ifNotNil: [ self error: 'subscriber already set' ]. self basicAt: 1 put: anObject. self register! ! !LegacyWeakSubscription methodsFor: 'finalization' stamp: 'IgorStasenko 3/12/2011 14:16'! weakRegistry ^ WeakRegistry default! ! !Lesson commentStamp: 'LaurentLaffont 1/15/2010 10:25'! See class side messages #welcome, #doingVSPrinting.... ! !Lesson methodsFor: 'accessing' stamp: 'LaurentLaffont 1/15/2010 09:25'! lesson ^ lesson ifNil: [lesson := '']! ! !Lesson methodsFor: 'accessing' stamp: 'LaurentLaffont 1/15/2010 09:25'! lesson: aString lesson := aString! ! !Lesson methodsFor: 'accessing' stamp: 'LaurentLaffont 1/15/2010 09:25'! title ^ title ifNil: [title := '']! ! !Lesson methodsFor: 'printing' stamp: 'LaurentLaffont 2/15/2011 22:46'! printOn: aStream super printOn: aStream. aStream nextPutAll: '('; nextPutAll: self title; nextPutAll: ')'. ! ! !Lesson methodsFor: 'accessing' stamp: 'LaurentLaffont 1/15/2010 09:25'! title: aString title := aString! ! !Lesson class methodsFor: 'instance creation' stamp: 'LaurentLaffont 1/15/2010 09:27'! title: aStringForTitle lesson: aStringForLesson ^ self new title: aStringForTitle; lesson: aStringForLesson; yourself.! ! !LessonTestInstanciation commentStamp: 'TorstenBergmann 2/12/2014 22:50'! SUnit tests for lessons! !LessonTestInstanciation methodsFor: 'tests' stamp: 'LaurentLaffont 1/21/2010 15:12'! testNewLessonHaveEmptyStringForTitleLesson | newLesson | newLesson := Lesson new. self assert: newLesson title equals: ''. self assert: newLesson lesson equals: ''.! ! !LessonTestInstanciation methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 19:02'! testTitleLessonCreation | firstLesson secondLesson | firstLesson := Lesson title: 'First lesson' lesson: 'Pharo rules!!'. secondLesson := Lesson title: 'Second lesson' lesson: 'PharoTutorial is cool'. self assert: firstLesson title equals: 'First lesson'. self assert: firstLesson lesson equals: 'Pharo rules!!'. self assert: secondLesson title equals: 'Second lesson'. self assert: secondLesson lesson equals: 'PharoTutorial is cool'.! ! !LessonView commentStamp: 'LaurentLaffont 1/15/2010 10:24'! A LessonView displays a Lesson instance! !LessonView methodsFor: 'gui' stamp: 'LaurentLaffont 1/21/2010 21:00'! shoutMorphFillMenu: aMenu ^ aMenu addAllFrom: self menu! ! !LessonView methodsFor: 'accessing' stamp: 'LaurentLaffont 1/21/2010 21:02'! window ^ window ifNil: [self open. window]! ! !LessonView methodsFor: 'accessing' stamp: 'LaurentLaffont 1/21/2010 20:58'! shoutMorph ^ shoutMorph ifNil: [self open. shoutMorph]! ! !LessonView methodsFor: 'gui' stamp: 'LaurentLaffont 1/21/2010 21:01'! close self window delete.! ! !LessonView methodsFor: 'gui' stamp: 'LaurentLaffont 1/27/2010 21:21'! menu ^ MenuMorph fromArray: { {'do it (d)' translated. #doIt}. {'print it (p)' translated. #printIt}}.! ! !LessonView methodsFor: 'gui' stamp: 'EstebanLorenzano 7/31/2013 11:16'! showLesson: aLesson withTitle: aString self window setLabel: aString. self shoutMorph selectFrom: 0 to: 0; setText: aLesson lesson. (World systemWindows includes: self window) ifFalse: [self window openInWorld] ! ! !LessonView methodsFor: 'gui' stamp: 'AlainPlantec 8/28/2011 13:54'! open shoutMorph := PluggableTextMorph on: self text: nil accept: nil readSelection: nil menu: #shoutMorphFillMenu:. shoutMorph setText: ''. window := SystemWindow labelled: 'PrStef lesson'. window addMorph: shoutMorph frame: (0@0 corner: 1@1). window openInWorld.! ! !LessonView methodsFor: 'accessing' stamp: 'LaurentLaffont 2/26/2012 14:13'! shoutAboutToStyle: aPluggableShoutMorphOrView ^ true! ! !LessonView methodsFor: 'accessing' stamp: 'LaurentLaffont 1/21/2010 21:06'! text ^ self shoutMorph text asString! ! !LimitedWriteStream commentStamp: ''! A LimitedWriteStream is a specialized WriteStream that has a maximum size of the collection it streams over. When this limit is reached a special limitBlock is executed. This can for example be used to "bail out" of lengthy streaming operations before they have finished. For a simple example take a look at the universal Object printString. The message SequenceableCollection class streamContents:limitedTo: creates a LimitedWriteStream. In this case it prevents very large (or possibly recursive) object structures to "overdo" their textual representation. ! !LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'di 6/20/97 09:07'! setLimit: sizeLimit limitBlock: aBlock "Limit the numer of elements this stream will write..." limit := sizeLimit. "Execute this (typically ^ contents) when that limit is exceded" limitBlock := aBlock! ! !LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'di 10/28/2001 12:49'! pastEndPut: anObject collection size >= limit ifTrue: [limitBlock value]. "Exceptional return" ^ super pastEndPut: anObject! ! !LimitedWriteStream methodsFor: 'accessing' stamp: 'LukasRenggli 5/8/2010 18:41'! nextPut: anObject "Ensure that the limit is not exceeded" position >= limit ifTrue: [limitBlock value] ifFalse: [ super nextPut: anObject ]. ^ anObject ! ! !LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'LukasRenggli 5/8/2010 18:42'! nextPutAll: aCollection | newEnd | collection class == aCollection class ifFalse: [ ^ super nextPutAll: aCollection ]. newEnd := position + aCollection size. newEnd > limit ifTrue: [ super nextPutAll: (aCollection copyFrom: 1 to: (limit - position max: 0)). limitBlock value. ^ aCollection ]. newEnd > writeLimit ifTrue: [ self growTo: newEnd + 10 ]. collection replaceFrom: position+1 to: newEnd with: aCollection startingAt: 1. position := newEnd. ^ aCollection! ! !LimitingLineStreamWrapper commentStamp: ''! I'm a wrapper for a stream optimized for line-by-line access using #nextLine. My instances can be nested. I read one line ahead. Reading terminates when the stream ends, or if the limitingBlock evaluated with the line answers true. To skip the delimiting line for further reading use #skipThisLine. Character-based reading (#next) is permitted, too. Send #updatePosition when switching from line-based reading. See examples at the class side. --bf 2/19/1999 12:52! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:09'! nextLine | thisLine | self atEnd ifTrue: [^nil]. thisLine := line. line := stream nextLine. ^thisLine ! ! !LimitingLineStreamWrapper methodsFor: 'testing' stamp: 'bf 11/13/1998 16:55'! atEnd ^line isNil or: [limitingBlock value: line]! ! !LimitingLineStreamWrapper methodsFor: 'stream protocol' stamp: 'bf 11/13/1998 17:00'! close ^stream close! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:48'! next "Provide character-based access" position ifNil: [^nil]. position < line size ifTrue: [^line at: (position := position + 1)]. line := stream nextLine. self updatePosition. ^ Character cr! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/13/1998 13:08'! lastLineRead "Return line last read. At stream end, this is the boundary line or nil" ^ line! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:25'! delimiter: aString "Set limitBlock to check for a delimiting string. Be unlimiting if nil" self limitingBlock: (aString caseOf: { [nil] -> [[:aLine | false]]. [''] -> [[:aLine | aLine size = 0]] } otherwise: [[:aLine | aLine beginsWith: aString]]) ! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 2/19/1999 11:45'! linesUpToEnd | elements ln | elements := OrderedCollection new. [(ln := self nextLine) isNil] whileFalse: [ elements add: ln]. ^elements! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:37'! updatePosition "Call this before doing character-based access" position := self atEnd ifFalse: [0]! ! !LimitingLineStreamWrapper methodsFor: 'printing' stamp: 'bf 11/24/1998 13:39'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' on '. stream printOn: aStream! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 16:53'! skipThisLine line := stream nextLine. self updatePosition. ! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/13/1998 13:04'! peekLine self atEnd ifTrue: [^nil]. ^ line! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'nice 1/5/2010 15:59'! upToEnd ^String streamContents: [:strm | | ln | [(ln := self nextLine) isNil] whileFalse: [ strm nextPutAll: ln; cr]]! ! !LimitingLineStreamWrapper methodsFor: 'private' stamp: 'bf 11/24/1998 14:30'! setStream: aStream delimiter: aString stream := aStream. line := stream nextLine. self delimiter: aString. "sets position" ! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:08'! limitingBlock: aBlock "The limitingBlock is evaluated with a line to check if this line terminates the stream" limitingBlock := aBlock. self updatePosition! ! !LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'bf 2/19/1999 11:48'! example1 "LimitingLineStreamWrapper example1" "Separate chunks of text delimited by a special string" | inStream msgStream messages | inStream := self exampleStream. msgStream := LimitingLineStreamWrapper on: inStream delimiter: 'From '. messages := OrderedCollection new. [inStream atEnd] whileFalse: [ msgStream skipThisLine. messages add: msgStream upToEnd]. ^messages ! ! !LimitingLineStreamWrapper class methodsFor: 'instance creation' stamp: 'bf 11/24/1998 14:31'! on: aStream delimiter: aString ^self new setStream: aStream delimiter: aString ! ! !LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'damiencassou 5/30/2008 11:45'! exampleStream ^ 'From me@somewhere From: me To: you Subject: Test Test From you@elsewhere From: you To: me Subject: Re: test okay ' readStream! ! !LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'bf 2/19/1999 12:46'! example2 "LimitingLineStreamWrapper example2" "Demo nesting wrappers - get header lines from some messages" | inStream msgStream headers headerStream | inStream := self exampleStream. msgStream := LimitingLineStreamWrapper on: inStream delimiter: 'From '. headers := OrderedCollection new. [inStream atEnd] whileFalse: [ msgStream skipThisLine. "Skip From" headerStream := LimitingLineStreamWrapper on: msgStream delimiter: ''. headers add: headerStream linesUpToEnd. [msgStream nextLine isNil] whileFalse. "Skip Body" ]. ^headers ! ! !LineMorph commentStamp: ''! This is really only a shell for creating single-segment straight-line Shapes.! !LineMorph class methodsFor: 'instance creation' stamp: 'di 8/20/2000 12:16'! new ^ self from: 0@0 to: 50@50 color: Color black width: 2! ! !LineMorph class methodsFor: 'instance creation' stamp: 'SeanDeNigris 9/17/2010 16:13'! from: startPoint to: endPoint color: lineColor width: lineWidth ^ self vertices: {startPoint. endPoint} color: Color black borderWidth: lineWidth borderColor: lineColor! ! !LineSegment commentStamp: ''! This class represents a straight line segment between two points Instance variables: start start point of the line end end point of the line ! !LineSegment methodsFor: 'accessing' stamp: 'ar 6/7/2003 00:10'! end: aPoint end := aPoint! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'! bounds "Return the bounds containing the receiver" ^(start min: end) corner: (start max: end)! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 5/23/2001 19:11'! direction ^end - start! ! !LineSegment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:12'! from: startPoint to: endPoint "Initialize the receiver" start := startPoint. end := endPoint.! ! !LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'! asBezier2Segment "Represent the receiver as quadratic bezier segment" ^Bezier2Segment from: start to: end! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'! tangentAtStart "Return the tangent for the last point" ^(end - start)! ! !LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'! asLineSegment "Represent the receiver as a straight line segment" ^self! ! !LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:08'! isStraight "Return true if the receiver represents a straight line" ^true! ! !LineSegment methodsFor: 'converting' stamp: 'ar 6/8/2003 15:38'! asBezier2Segments: error "Demote a cubic bezier to a set of approximating quadratic beziers." | pts | pts := self asBezier2Points: error. ^(1 to: pts size by: 3) collect:[:i| Bezier2Segment from: (pts at: i) via: (pts at: i+1) to: (pts at: i+2)]. ! ! !LineSegment methodsFor: 'bezier clipping' stamp: 'ar 6/8/2003 00:06'! bezierClipCurve: aCurve ^self bezierClipCurve: aCurve epsilon: 1! ! !LineSegment methodsFor: 'converting' stamp: 'ar 6/7/2003 00:08'! reversed ^self class controlPoints: self controlPoints reversed! ! !LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:12'! hasZeroLength "Return true if the receiver has zero length" ^start = end! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'! tangentAtEnd "Return the tangent for the last point" ^(end - start)! ! !LineSegment methodsFor: 'vector functions' stamp: 'pmm 3/13/2010 11:31'! curveFrom: parameter1 to: parameter2 "Create a new segment like the receiver but starting/ending at the given parametric values" | delta | delta := end - start. ^self shallowCopy from: delta * parameter1 + start to: delta * parameter2 + start! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'! start "Return the start point" ^start! ! !LineSegment methodsFor: 'printing' stamp: 'ar 11/2/1998 12:13'! printOn: aStream "Print the receiver on aStream" aStream nextPutAll: self class name; nextPutAll:' from: '; print: start; nextPutAll: ' to: '; print: end; space.! ! !LineSegment methodsFor: 'bezier clipping' stamp: 'ar 6/8/2003 00:19'! bezierClipCurve: aCurve epsilon: eps "Compute the intersection of the receiver (a line) with the given curve using bezier clipping." | tMin tMax clip newCurve | clip := self bezierClipInterval: aCurve. clip ifNil:[^#()]. "no overlap" tMin := clip at: 1. tMax := clip at: 2. newCurve := aCurve curveFrom: tMin to: tMax. newCurve length < eps ifTrue:[^Array with: (aCurve valueAt: tMin + tMax * 0.5)]. (tMin < 0.001 and:[tMax > 0.999]) ifTrue:[ "Need to split aCurve before proceeding" | curve1 curve2 | curve1 := aCurve curveFrom: 0.0 to: 0.5. curve2 := aCurve curveFrom: 0.5 to: 1.0. ^(curve1 bezierClipCurve: self epsilon: eps), (curve2 bezierClipCurve: self epsilon: eps). ]. ^newCurve bezierClipCurve: self epsilon: eps.! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:08'! length "Return the length of the receiver" ^start dist: end! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:08'! controlPoints ^{start. end}! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:08'! lineSegmentsDo: aBlock "Evaluate aBlock with the receiver's line segments" aBlock value: start value: end! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:10'! valueAtStart "Evaluate the receiver at it's start point (e.g., self valueAtEnd = (self valueAt: 0.0))" ^start! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'! controlPointsDo: aBlock aBlock value: start; value: end! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:15'! asBezier2Curves: err ^Array with: self! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'! tangentAt: parameter "Return the tangent at the given parametric value along the receiver" ^end - start! ! !LineSegment methodsFor: 'converting' stamp: 'ar 6/7/2003 20:57'! asTangentSegment ^LineSegment from: end-start to: end-start! ! !LineSegment methodsFor: 'initialize' stamp: 'ar 6/7/2003 00:09'! initializeFrom: controlPoints controlPoints size = 2 ifFalse:[self error:'Wrong number of control points']. start := controlPoints at: 1. end := controlPoints at: 2.! ! !LineSegment methodsFor: 'private' stamp: 'ar 6/7/2003 21:00'! debugDrawAt: offset | canvas | canvas := Display getCanvas. canvas translateBy: offset during:[:aCanvas| self lineSegmentsDo:[:p1 :p2| aCanvas line: p1 rounded to: p2 rounded width: 1 color: Color black. ]. ].! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 6/7/2003 00:10'! start: aPoint start := aPoint! ! !LineSegment methodsFor: 'converting' stamp: 'ar 6/8/2003 04:19'! asBezier2Points: error ^Array with: start with: start with: end! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 6/8/2003 00:54'! tangentAtMid "Return the tangent for the last point" ^(end - start)! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 17:21'! lineSegments: steps do: aBlock "Evaluate aBlock with the receiver's line segments" aBlock value: start value: end! ! !LineSegment methodsFor: 'intersection' stamp: 'nk 12/27/2003 13:00'! roundTo: quantum start := start roundTo: quantum. end := end roundTo: quantum.! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:10'! valueAtEnd "Evaluate the receiver at it's end point (e.g., self valueAtEnd = (self valueAt: 1.0))" ^end! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'! end "Return the end point" ^end! ! !LineSegment methodsFor: 'private' stamp: 'ar 6/7/2003 21:00'! debugDraw ^self debugDrawAt: 0@0.! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 5/23/2001 18:27'! sideOfPoint: aPoint "Return the side of the receiver this point is on. The method returns -1: if aPoint is left 0: if aPoint is on +1: if a point is right of the receiver." | dx dy px py | dx := end x - start x. dy := end y - start y. px := aPoint x - start x. py := aPoint y - start y. ^((dx * py) - (px * dy)) sign " (LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@-50. (LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@50. (LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@0. " ! ! !LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:07'! isLineSegment "Return true if the receiver is a line segment" ^true! ! !LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'! asIntegerSegment "Convert the receiver into integer representation" ^self species from: start asIntegerPoint to: end asIntegerPoint! ! !LineSegment methodsFor: 'intersection' stamp: 'nk 3/29/2002 22:30'! intersectionWith: anotherSegment "Copied from LineIntersections>>intersectFrom:to:with:to:" | det deltaPt alpha beta pt1Dir pt2Dir | pt1Dir := end - start. pt2Dir := anotherSegment end - anotherSegment start. det := (pt1Dir x * pt2Dir y) - (pt1Dir y * pt2Dir x). deltaPt := anotherSegment start - start. alpha := (deltaPt x * pt2Dir y) - (deltaPt y * pt2Dir x). beta := (deltaPt x * pt1Dir y) - (deltaPt y * pt1Dir x). det = 0 ifTrue:[^nil]. "no intersection" alpha * det < 0 ifTrue:[^nil]. beta * det < 0 ifTrue:[^nil]. det > 0 ifTrue:[(alpha > det or:[beta > det]) ifTrue:[^nil]] ifFalse:[(alpha < det or:[beta < det]) ifTrue:[^nil]]. "And compute intersection" ^start + (alpha * pt1Dir / (det@det))! ! !LineSegment methodsFor: 'bezier clipping' stamp: 'nice 1/5/2010 15:59'! bezierClipInterval: aCurve "Compute the new bezier clip interval for the argument, based on the fat line (the direction aligned bounding box) of the receiver. Note: This could be modified so that multiple clip intervals are returned. The idea is that for a distance curve like x x tMax---- --\-----/---\------- x x tMin------------------------- all the intersections intervals with tMin/tMax are reported, therefore minimizing the iteration count. As it is, the process will slowly iterate against tMax and then the curve will be split. " | nrm tStep pts eps inside tValue tMin tMax last lastV lastT lastInside next nextV nextT nextInside vMin vMax | eps := 0.00001. "distance epsilon" nrm := (start y - end y) @ (end x - start x). "normal direction for (end-start)" "Map receiver's control point into fat line; compute vMin and vMax" vMin := vMax := nil. self controlPointsDo:[:pt| | vValue | vValue := (nrm x * pt x) + (nrm y * pt y). "nrm dotProduct: pt." vMin == nil ifTrue:[ vMin := vMax := vValue] ifFalse:[vValue < vMin ifTrue:[vMin := vValue]. vValue > vMax ifTrue:[vMax := vValue]]]. "Map the argument into fat line; compute tMin, tMax for clip" tStep := 1.0 / aCurve degree. pts := aCurve controlPoints. last := pts at: pts size. lastV := (nrm x * last x) + (nrm y * last y). "nrm dotProduct: last." lastT := 1.0. lastInside := lastV+eps < vMin ifTrue:[-1] ifFalse:[lastV-eps > vMax ifTrue:[1] ifFalse:[0]]. "Now compute new minimal and maximal clip boundaries" inside := false. "assume we're completely outside" tMin := 2.0. tMax := -1.0. "clip interval" 1 to: pts size do:[:i| next := pts at: i. nextV := (nrm x * next x) + (nrm y * next y). "nrm dotProduct: next." false ifTrue:[ (nextV - vMin / (vMax - vMin)) printString displayAt: 0@ (i-1*20)]. nextT := i-1 * tStep. nextInside := nextV+eps < vMin ifTrue:[-1] ifFalse:[nextV-eps > vMax ifTrue:[1] ifFalse:[0]]. nextInside = 0 ifTrue:[ inside := true. tValue := nextT. tValue < tMin ifTrue:[tMin := tValue]. tValue > tMax ifTrue:[tMax := tValue]. ]. lastInside = nextInside ifFalse:["At least one clip boundary" inside := true. "See if one is below vMin" (lastInside + nextInside <= 0) ifTrue:[ tValue := lastT + ((nextT - lastT) * (vMin - lastV) / (nextV - lastV)). tValue < tMin ifTrue:[tMin := tValue]. tValue > tMax ifTrue:[tMax := tValue]. ]. "See if one is above vMax" (lastInside + nextInside >= 0) ifTrue:[ tValue := lastT + ((nextT - lastT) * (vMax - lastV) / (nextV - lastV)). tValue < tMin ifTrue:[tMin := tValue]. tValue > tMax ifTrue:[tMax := tValue]. ]. ]. last := next. lastT := nextT. lastV := nextV. lastInside := nextInside. ]. inside ifTrue:[^Array with: tMin with: tMax] ifFalse:[^nil]! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'! degree ^1! ! !LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:07'! isBezier2Segment "Return true if the receiver is a quadratic bezier segment" ^false! ! !LineSegment methodsFor: 'testing' stamp: 'ar 6/8/2003 01:03'! isArcSegment "Answer whether I approximate an arc segment reasonably well" | mid v1 v2 d1 d2 center | start = end ifTrue:[^false]. mid := self valueAt: 0.5. v1 := (start + mid) * 0.5. v2 := (mid + end) * 0.5. d1 := mid - start. d1 := d1 y @ d1 x negated. d2 := end - mid. d2 := d2 y @ d2 x negated. center := LineSegment intersectFrom: v1 with: d1 to: v2 with: d2. "Now see if the tangents are 'reasonably close' to the circle" d1 := (start - center) normalized dotProduct: self tangentAtStart normalized. d1 abs > 0.02 ifTrue:[^false]. d1 := (end - center) normalized dotProduct: self tangentAtEnd normalized. d1 abs > 0.02 ifTrue:[^false]. d1 := (mid - center) normalized dotProduct: self tangentAtMid normalized. d1 abs > 0.02 ifTrue:[^false]. ^true! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'! valueAt: parameter "Evaluate the receiver at the given parametric value" ^start + (end - start * parameter)! ! !LineSegment class methodsFor: 'geometry' stamp: 'nk 8/19/2003 17:17'! fromPoints: pts ^self from: pts first to: pts third via: pts second! ! !LineSegment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:10'! from: startPoint to: endPoint ^self new from: startPoint to: endPoint! ! !LineSegment class methodsFor: 'utilities' stamp: 'ar 6/8/2003 00:49'! intersectFrom: startPt with: startDir to: endPt with: endDir "Compute the intersection of two lines, e.g., compute alpha and beta for startPt + (alpha * startDir) = endPt + (beta * endDir). Reformulating this yields (alpha * startDir) - (beta * endDir) = endPt - startPt. or (alpha * startDir) + (-beta * endDir) = endPt - startPt. or (alpha * startDir x) + (-beta * endDir x) = endPt x - startPt x. (alpha * startDir y) + (-beta * endDir y) = endPt y - startPt y. which is trivial to solve using Cramer's rule. Note that since we're really only interested in the intersection point we need only one of alpha or beta since the resulting intersection point can be computed based on either one." | det deltaPt alpha | det := (startDir x * endDir y) - (startDir y * endDir x). det = 0.0 ifTrue:[^nil]. "There's no solution for it" deltaPt := endPt - startPt. alpha := (deltaPt x * endDir y) - (deltaPt y * endDir x). alpha := alpha / det. "And compute intersection" ^startPt + (alpha * startDir)! ! !LineSegment class methodsFor: 'geometry' stamp: 'nk 8/19/2003 17:15'! from: startPoint to: endPoint via: via (startPoint = via or: [ endPoint = via ]) ifTrue: [ ^self new from: startPoint to: endPoint ]. ^Bezier2Segment from: startPoint to: endPoint via: via! ! !LineSegment class methodsFor: 'instance creation' stamp: 'ar 6/7/2003 00:09'! controlPoints: anArray "Create a new instance of the receiver from the given control points" anArray size = 2 ifTrue:[^LineSegment new initializeFrom: anArray]. anArray size = 3 ifTrue:[^Bezier2Segment new initializeFrom: anArray]. anArray size = 4 ifTrue:[^Bezier3Segment new initializeFrom: anArray]. self error:'Unsupported'.! ! !LinearGradientPaint commentStamp: ''! I represent a linear gradient paint. My start and stop points defining the position and direction of gradient fill in user space coordinates, so that the ramp color at 0 maps to starting point and ramp color at 1 maps to stop point of linear gradient. Also check the comment of my superclass to know better how and when you can use me. ! !LinearGradientPaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/12/2013 09:56'! start: anObject start := anObject! ! !LinearGradientPaint methodsFor: 'accessing' stamp: 'FernandoOlivero 1/13/2012 23:10'! stop ^ stop! ! !LinearGradientPaint methodsFor: 'accessing' stamp: 'IgorStasenko 4/12/2013 09:56'! stop: anObject stop := anObject! ! !LinearGradientPaint methodsFor: 'accessing' stamp: 'FernandoOlivero 1/13/2012 23:10'! start ^ start! ! !LinearGradientPaint methodsFor: 'converting' stamp: 'IgorStasenko 4/12/2013 10:14'! asAthensPaintOn: aCanvas ^ aCanvas surface createLinearGradient: self colorRamp start: self start stop: self stop! ! !LinearGradientPaint class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/12/2013 09:56'! from: aStartPoint to: aStopPoint | p | p := self new. p initializeFrom: aStartPoint to: aStopPoint. ^ p! ! !Link commentStamp: ''! An instance of me is a simple record of a pointer to another Link. I am an abstract class; my concrete subclasses, for example, Process, can be stored in a LinkedList structure.! !Link methodsFor: 'converting' stamp: 'HenrikSperreJohansen 10/18/2009 15:59'! asLink ^self! ! !Link methodsFor: 'accessing' stamp: ''! nextLink: aLink "Store the argument, aLink, as the link to which the receiver refers. Answer aLink." ^nextLink := aLink! ! !Link methodsFor: 'accessing' stamp: ''! nextLink "Answer the link to which the receiver points." ^nextLink! ! !Link class methodsFor: 'instance creation' stamp: 'apb 10/3/2000 15:55'! nextLink: aLink "Answer an instance of me referring to the argument, aLink." ^self new nextLink: aLink; yourself! ! !LinkedList commentStamp: 'HenrikSperreJohansen 10/18/2009 16:09'! A LinkedList is a sequential collection of objects where adjecent objects are linked by pointer. Using the message sequence addFirst:/removeLast causes the receiver to behave as a stack; using addLast:/removeFirst causes the receiver to behave as a queue. A LinkedList can be used to hold two different kinds of objecs: (a) Objects inheriting frm Link (b) Any objects. If you attempt to add any object into a LinkedList that is not a Link, it will automatically be wrapped by a ValueLink. A LinkedList therefore behaves very much like any collection, except that certain calls such as atIndex: are linear rather than constant time.! !LinkedList methodsFor: 'removing' stamp: 'HenrikSperreJohansen 10/18/2009 18:10'! removeAllSuchThat: aBlock "Evaluate aBlock for each element and remove all that elements from the receiver for that aBlock evaluates to true. For LinkedLists, it's safe to use do:." self do: [:each | (aBlock value: each) ifTrue: [self remove: each]]! ! !LinkedList methodsFor: 'enumerating' stamp: 'HenrikSperreJohansen 10/19/2009 11:03'! linksDo: aBlock | aLink | aLink := firstLink. [aLink == nil ] whileFalse: [ aBlock value: aLink. aLink := aLink nextLink]! ! !LinkedList methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 10/18/2009 17:20'! last "Answer the last link. Create an error notification if the receiver is empty." ^self lastLink value! ! !LinkedList methodsFor: 'enumerating' stamp: 'ajh 8/6/2002 16:39'! species ^ Array! ! !LinkedList methodsFor: 'private' stamp: 'HenrikSperreJohansen 10/18/2009 17:43'! linkOf: anObject ifAbsent: errorBlock self linksDo: [:el | el value = anObject ifTrue: [^ el]]. ^ errorBlock value! ! !LinkedList methodsFor: 'removing' stamp: 'HenrikSperreJohansen 10/18/2009 17:43'! removeLink: aLink ^self removeLink: aLink ifAbsent: [self error: 'no such method!!']! ! !LinkedList methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 10/18/2009 17:20'! first "Answer the first link. Create an error notification if the receiver is empty." ^self firstLink value! ! !LinkedList methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 3/21/2013 13:02'! at: index putLink: aLink | previousLink nextLink | "Please don't put a link which is already in the list, or you will create an infinite loop" (self validIndex: index) ifFalse: [^ self errorOutOfBounds]. index = 1 ifTrue: [aLink nextLink: self firstLink nextLink. firstLink := aLink. aLink nextLink ifNil: [lastLink := aLink]. ^ aLink]. previousLink := self linkAt: index - 1. nextLink := previousLink nextLink nextLink. nextLink ifNil: [ aLink nextLink: self lastLink ] ifNotNil: [ aLink nextLink: nextLink. ]. previousLink nextLink: aLink. nextLink ifNil: [ lastLink := aLink. aLink nextLink: nil. ]. ^ aLink! ! !LinkedList methodsFor: 'copying' stamp: 'HenrikSperreJohansen 10/18/2009 13:02'! copyWithout: oldElement |newInst| newInst := self class new. self do: [:each | each = oldElement ifFalse: [newInst add: each]]. ^newInst! ! !LinkedList methodsFor: 'adding' stamp: 'HenrikSperreJohansen 10/18/2009 16:58'! addLast: aLinkOrObject "Add aLink to the end of the receiver's list. Answer aLink." |aLink| aLink := aLinkOrObject asLink. self isEmpty ifTrue: [firstLink := aLink] ifFalse: [lastLink nextLink: aLink]. lastLink := aLink. ^aLink! ! !LinkedList methodsFor: 'private' stamp: 'HenrikSperreJohansen 10/19/2009 11:58'! validIndex: index ^index > 0 and: [index <= self size]! ! !LinkedList methodsFor: 'private' stamp: 'HenrikSperreJohansen 10/18/2009 17:40'! linkOf: anObject ^ self linkOf: anObject ifAbsent: [self error: 'No such element']! ! !LinkedList methodsFor: 'adding' stamp: 'HenrikSperreJohansen 10/18/2009 16:48'! add: link after: otherLinkOrObject "Add otherLink after link in the list. Answer aLink." | otherLink savedLink | otherLink := self linkAt: (self indexOf: otherLinkOrObject). ^self add: link afterLink: otherLink! ! !LinkedList methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 10/18/2009 15:36'! at: index ^(self linkAt: index) value! ! !LinkedList methodsFor: 'adding' stamp: 'HenrikSperreJohansen 10/18/2009 14:58'! add: aLinkOrObject "Add aLink to the end of the receiver's list. Answer aLink." ^self addLast: aLinkOrObject! ! !LinkedList methodsFor: 'removing' stamp: 'HenrikSperreJohansen 10/18/2009 18:33'! removeLink: aLink ifAbsent: aBlock "Remove aLink from the receiver. If it is not there, answer the result of evaluating aBlock." | tempLink | aLink == firstLink ifTrue: [firstLink := aLink nextLink. aLink == lastLink ifTrue: [lastLink := nil]] ifFalse: [tempLink := firstLink. [tempLink == nil ifTrue: [^aBlock value]. tempLink nextLink == aLink] whileFalse: [tempLink := tempLink nextLink]. tempLink nextLink: aLink nextLink. aLink == lastLink ifTrue: [lastLink := tempLink]]. "Not nilling the link enables us to delete while iterating" "aLink nextLink: nil." ^aLink! ! !LinkedList methodsFor: 'private' stamp: 'HenrikSperreJohansen 10/18/2009 17:08'! linkAt: index ifAbsent: errorBlock | i | i := 0. self linksDo: [:link | (i := i + 1) = index ifTrue: [^ link]]. ^ errorBlock value! ! !LinkedList methodsFor: 'adding' stamp: 'HenrikSperreJohansen 10/18/2009 16:48'! add: link before: otherLinkOrObject "Add otherLink after link in the list. Answer aLink." | otherLink savedLink | otherLink := self linkAt: (self indexOf: otherLinkOrObject). ^self add: link beforeLink: otherLink! ! !LinkedList methodsFor: 'copying' stamp: 'HenrikSperreJohansen 10/19/2009 15:09'! copyWith: newElement ^self copy add: newElement; yourself! ! !LinkedList methodsFor: 'adding' stamp: 'HenrikSperreJohansen 10/18/2009 16:37'! add: aLinkOrObject beforeLink: otherLink | currentLink| firstLink == otherLink ifTrue: [^ self addFirst: aLinkOrObject]. currentLink := firstLink. [currentLink == nil] whileFalse: [ currentLink nextLink == otherLink ifTrue: [ | aLink | aLink := aLinkOrObject asLink. aLink nextLink: currentLink nextLink. currentLink nextLink: aLink. ^ aLink ]. currentLink := currentLink nextLink. ]. ^ self errorNotFound: otherLink! ! !LinkedList methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 10/19/2009 14:42'! swap: ix1 with: ix2 "Reimplemented, super would create an infinite loop" | minIx maxIx link1Prev link2Prev link1 link2 link1Next link2Next newLink2Next | ((self validIndex: ix1) and: [self validIndex: ix2]) ifFalse: [^ self errorOutOfBounds]. "Get edge case out of the way" ix1 = ix2 ifTrue: [^ self ]. "Sort indexes to make boundary-checks easier" minIx := ix1 min: ix2. maxIx := ix2 max: ix1. link1Prev := (minIx = 1) ifFalse: [self linkAt: minIx -1]. link1 := link1Prev ifNotNil: [ link1Prev nextLink] ifNil: [self linkAt: minIx]. link1Next := link1 nextLink. link2Prev := self linkAt: maxIx -1. link2 := link2Prev nextLink. link2Next := link2 nextLink. "Link at start being swapped" link1 = firstLink ifTrue: [firstLink := link2.] ifFalse: [link1Prev nextLink: link2]. "Link at end being swapped" link2 = lastLink ifTrue: [lastLink := link1] ifFalse: []. "Links being swapped adjacent" newLink2Next := (link1 nextLink = link2) ifTrue: [link1] ifFalse: [link2Prev nextLink: link1. link1Next]. link1 nextLink: link2Next. link2 nextLink: newLink2Next. ! ! !LinkedList methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 10/18/2009 17:20'! firstLink "Answer the first link. Create an error notification if the receiver is empty." self emptyCheck. ^firstLink ! ! !LinkedList methodsFor: 'removing' stamp: 'MarcusDenker 3/5/2010 16:54'! removeFirst "Remove the first element and answer it. If the receiver is empty, create an error notification." | oldLink | self emptyCheck. oldLink := firstLink. firstLink == lastLink ifTrue: [firstLink := nil. lastLink := nil] ifFalse: [firstLink := oldLink nextLink]. oldLink nextLink: nil. ^oldLink value! ! !LinkedList methodsFor: 'testing' stamp: 'marcus.denker 9/14/2008 18:58'! isEmpty ^firstLink isNil! ! !LinkedList methodsFor: 'private' stamp: 'HenrikSperreJohansen 10/18/2009 17:09'! indexOf: anElement startingAt: start ifAbsent: exceptionBlock "Answer the index of the first occurence of anElement after start within the receiver. If the receiver does not contain anElement, answer the result of evaluating the argument, exceptionBlock." |currentLink index| currentLink := self linkAt: start ifAbsent: [nil]. index := start. [currentLink isNil ] whileFalse: [currentLink value = anElement value ifTrue: [^index]. currentLink := currentLink nextLink. index := index +1]. ^exceptionBlock value! ! !LinkedList methodsFor: 'removing' stamp: 'slave 01/17/2011 12:59'! remove: aLinkOrObject ifAbsent: aBlock "Remove aLink from the receiver. If it is not there, answer the result of evaluating aBlock." | link | link := self linkOf: aLinkOrObject ifAbsent: [^aBlock value]. self removeLink: link ifAbsent: [^aBlock value]. ^aLinkOrObject! ! !LinkedList methodsFor: 'adding' stamp: 'HenrikSperreJohansen 10/18/2009 17:09'! addFirst: aLinkOrObject "Add aLink to the beginning of the receiver's list. Answer aLink." |aLink| aLink := aLinkOrObject asLink. self isEmpty ifTrue: [lastLink := aLink]. aLink nextLink: firstLink. firstLink := aLink. ^aLink! ! !LinkedList methodsFor: 'private' stamp: 'HenrikSperreJohansen 10/18/2009 17:11'! linkAt: index ^self linkAt: index ifAbsent: [ self errorSubscriptBounds: index]! ! !LinkedList methodsFor: 'enumerating' stamp: 'CamilloBruni 10/20/2012 21:54'! select: aBlock "Reimplemennt #select: for speedup on linked lists. The super implemention accesses the linkes by index, thus causing an O(n^2)" | newCollection | newCollection := self class new. self do: [ :each | (aBlock value: each) ifTrue: [ newCollection add: each ]]. ^newCollection! ! !LinkedList methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 10/19/2009 10:53'! at: index put: anObject ^self at: index putLink: (self linkOf: anObject ifAbsent: [anObject asLink])! ! !LinkedList methodsFor: 'enumerating' stamp: 'HenrikSperreJohansen 10/18/2009 15:48'! do: aBlock | aLink | aLink := firstLink. [aLink == nil] whileFalse: [aBlock value: aLink value. aLink := aLink nextLink]! ! !LinkedList methodsFor: 'removing' stamp: 'MarcusDenker 3/5/2010 16:54'! removeLast "Remove the receiver's last element and answer it. If the receiver is empty, create an error notification." | oldLink aLink | self emptyCheck. oldLink := lastLink. firstLink == lastLink ifTrue: [firstLink := nil. lastLink := nil] ifFalse: [aLink := firstLink. [aLink nextLink == oldLink] whileFalse: [aLink := aLink nextLink]. aLink nextLink: nil. lastLink := aLink]. oldLink nextLink: nil. ^oldLink value! ! !LinkedList methodsFor: 'copying' stamp: 'ClementBera 7/26/2013 16:58'! postCopy | aLink | super postCopy. firstLink ifNotNil: [ aLink := firstLink := firstLink copy. [aLink nextLink isNil] whileFalse: [aLink nextLink: (aLink := aLink nextLink copy)]. lastLink := aLink].! ! !LinkedList methodsFor: 'adding' stamp: 'HenrikSperreJohansen 10/18/2009 16:39'! add: aLinkOrObject afterLink: otherLink "Add otherLink after link in the list. Answer aLink." | savedLink aLink | lastLink == otherLink ifTrue: [^ self addLast: aLinkOrObject]. savedLink := otherLink nextLink. aLink := aLinkOrObject asLink. otherLink nextLink: aLink. aLink nextLink: savedLink. ^aLink.! ! !LinkedList methodsFor: 'enumerating' stamp: 'AlainPlantec 10/12/2011 19:41'! collect: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Collect the resulting values into a collection like the receiver. Answer the new collection." | aLink newCollection | newCollection := self class new. aLink := firstLink. [aLink == nil] whileFalse: [newCollection add: (aBlock value: aLink value). aLink := aLink nextLink]. ^ newCollection! ! !LinkedList methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 10/18/2009 17:19'! lastLink "Answer the last link. Create an error notification if the receiver is empty." self emptyCheck. ^lastLink! ! !LinkedList methodsFor: 'removing' stamp: 'nice 1/10/2009 00:23'! removeAll "Implementation note: this has to be fast" firstLink := lastLink := nil! ! !LinkedList class methodsFor: 'instance creation' stamp: 'HenrikSperreJohansen 10/19/2009 15:03'! new: anInt "LinkedList don't need capacity" ^self new! ! !LinkedList class methodsFor: 'stream creation' stamp: 'CamilloBruni 9/5/2011 15:34'! new: size streamContents: aBlock ^ self withAll: (super new: size streamContents: aBlock)! ! !LinkedList class methodsFor: 'accessing' stamp: 'CamilloBruni 9/5/2011 15:38'! streamSpecies ^ Array! ! !LinkedList class methodsFor: 'instance creation' stamp: 'nice 2/8/2012 21:23'! newFrom: aCollection "Answer an instance with same elements as aCollection." ^self new addAll: aCollection; yourself! ! !LinkedListTest commentStamp: 'mk 8/3/2005 11:55'! A set of test cases which thoroughly test functionality of the LinkedList class.! !LinkedListTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element ifAbsent: [ 99 ]) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 99 ]) = 99! ! !LinkedListTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButLast "self debug: #testAllButLast" | abf col | col := self moreThan3Elements. abf := col allButLast. self deny: abf last = col last. self assert: abf size + 1 = col size! ! !LinkedListTest methodsFor: 'tests - begins ends with' stamp: ''! testsEndsWith self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst). self assert: (self nonEmpty endsWith: self nonEmpty). self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first)).! ! !LinkedListTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceAllWith1Occurence | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . index:= firstIndexesOfOccurrence at: 1. "verify content of 'result' : " "first part of 'result'' : '" 1 to: (index -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " index to: (index + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) ]. " end part :" endPartIndexResult := index + self replacementCollection size . endPartIndexCollection := index + self oldSubCollection size . 1 to: (result size - endPartIndexResult - 1 ) do: [ :i | self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). ]. ! ! !LinkedListTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOf "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyWithReplacementTest self replacementCollection. self oldSubCollection. self collectionWith1TimeSubcollection. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:52'! moreThan4Elements " return a collection including at leat 4 elements" ^ collectionWithoutEqualElements ! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testReject | res element | res := self collectionWithoutNilElements reject: [:each | each notNil not]. self assert: res size = self collectionWithoutNilElements size. element := self collectionWithoutNilElements anyOne. res := self collectionWithoutNilElements reject: [:each | each = element]. self assert: res size = (self collectionWithoutNilElements size - 1). ! ! !LinkedListTest methodsFor: 'tests - subcollections access' stamp: ''! testFirstNElements "self debug: #testFirstNElements" | result | result := self moreThan3Elements first: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: Error! ! !LinkedListTest methodsFor: 'tests - adding' stamp: ''! testTWrite | added collection elem | collection := self otherCollection . elem := self element . added := collection write: elem . self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: elem ) . self assert: (collection includes: elem ). ! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0TStructuralEqualityTest self empty. self nonEmpty. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty! ! !LinkedListTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithoutFirst | result | result := self nonEmpty copyWithoutFirst. self assert: result size = (self nonEmpty size - 1). 1 to: result size do: [:i | self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! !LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testBefore "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). self should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] raise: Error. self should: [ self moreThan4Elements before: 66 ] raise: Error! ! !LinkedListTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:04'! test03addFirst self assert: list isEmpty. list addFirst: link1. self assert: list size = 1. self assert: list first = link1. list addFirst: link2. self assert: list size = 2. self assert: list first = link2. self assert: list second = link1. list addFirst: link3. self assert: list size = 3. self assert: list first = link3. self assert: list second = link2. self assert: list third = link1. list addFirst: link4. self assert: list size = 4. self assert: list first = link4. self assert: list second = link3. self assert: list third = link2. self assert: list fourth = link1! ! !LinkedListTest methodsFor: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:11'! collectionWithoutEqualElements " return a collection not including equal elements " ^collectionWithoutEqualElements ! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testAllSatisfyEmpty self assert: ( self empty allSatisfy: [:each | false]). ! ! !LinkedListTest methodsFor: 'tests - converting' stamp: ''! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !LinkedListTest methodsFor: 'tests - copy' stamp: ''! testCopyNotSame "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self nonEmpty copy. self deny: copy == self nonEmpty.! ! !LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindFirst | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. self assert: result=1. ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithIndexCollect | result index collection | index := 0. collection := self nonEmptyMoreThan1Element . result := collection withIndexCollect: [:each :i | self assert: i = (index := index + 1). self assert: i = (collection indexOf: each) . each] . 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. self assert: result size = collection size.! ! !LinkedListTest methodsFor: 'tests - adding' stamp: ''! testTAddAll | added collection toBeAdded | collection := self collectionWithElement . toBeAdded := self otherCollection . added := collection addAll: toBeAdded . self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." self assert: (collection includesAll: toBeAdded )! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testDoSeparatedBy | string expectedString beforeFirst | string := ''. self collectionWithoutNilElements do: [ :each | string := string , each asString ] separatedBy: [ string := string , '|' ]. expectedString := ''. beforeFirst := true. self collectionWithoutNilElements do: [ :each | beforeFirst = true ifTrue: [ beforeFirst := false ] ifFalse: [ expectedString := expectedString , '|' ]. expectedString := expectedString , each asString ]. self assert: expectedString = string! ! !LinkedListTest methodsFor: 'tests - printing' stamp: ''! testPrintElementsOn | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)). ].! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testSelectThenCollect | result index selectIndex pivot | index := 0. selectIndex := 0. pivot := self collectionWithoutNilElements anyOne. result := self collectionWithoutNilElements select: [ :each | selectIndex := selectIndex + 1. "reject the first element" selectIndex > 1 ] thenCollect: [ :each | self assert: each notNil. index := index + 1. pivot ]. self assert: result ~= self collectionWithoutNilElements. self assert: selectIndex equals: self collectionWithoutNilElements size. self assert: index equals: self collectionWithoutNilElements size - 1. self assert: (self collectionWithoutNilElements occurrencesOf: pivot) equals: 1. "should be > 1 for standard collection and = 1 for those that do not allow exact duplicates" self assert: (result occurrencesOf: pivot) >= 1. ! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:10'! test07addAfter self assert: list isEmpty. list add: link1. self assert: list size = 1. self assert: list first == link1. list add: link2 after: link1. self assert: list size = 2. self assert: list first == link1. self assert: list second == link2. list add: link3 after: link1. self assert: list size = 3. self assert: list first == link1. self assert: list second == link3. self assert: list third == link2. list add: link4 after: link1. self assert: list size = 4. self assert: list first == link1. self assert: list second == link4. self assert: list third == link3. self assert: list fourth == link2! ! !LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:47'! n: number n := number. ! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:05'! test04addBefore self assert: list isEmpty. list add: link1. self assert: list size = 1. self assert: list first == link1. list add: link2 before: link1. self assert: list size = 2. self assert: list first == link2. self assert: list second == link1. list add: link3 before: link1. self assert: list size = 3. self assert: list first == link2. self assert: list second == link3. self assert: list third == link1. list add: link4 before: link1. self assert: list size = 4. self assert: list first == link2. self assert: list second == link3. self assert: list third == link4. self assert: list fourth == link1! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:52'! anotherElementNotIn " return an element included in 'collection' " ^ elementNotIn ! ! !LinkedListTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithSequenceable | result index element | index := self indexInNonEmpty . element := self nonEmpty at: index. result := self nonEmpty copyWith: (element ). self assert: result size = (self nonEmpty size + 1). self assert: result last = element . 1 to: (result size - 1) do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! !LinkedListTest methodsFor: 'tests - begins ends with' stamp: ''! testsEndsWithEmpty self deny: (self nonEmpty endsWith: self empty). self deny: (self empty endsWith: self nonEmpty). ! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIterateSequencedReadableTest | res | self nonEmptyMoreThan1Element. self assert: self nonEmptyMoreThan1Element size > 1. self empty. self assert: self empty isEmpty . res := true. self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false.! ! !LinkedListTest methodsFor: 'tests - remove' stamp: ''! testRemoveIfAbsent "self debug: #testRemoveElementThatExists" | el res | el := self elementNotIn. res := self nonEmptyWithoutEqualElements remove: el ifAbsent: [ 33 ]. self assert: res = 33! ! !LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:10'! test10removeFirst list add: link1. list add: link2. list add: link3. list add: link4. self assert: list size = 4. self assert: list first == link1. self assert: list second == link2. self assert: list third == link3. self assert: list fourth == link4. list removeFirst. self assert: list size = 3. self assert: list first == link2. self assert: list second == link3. self assert: list third == link4. list removeFirst. self assert: list size = 2. self assert: list first == link3. self assert: list second == link4. list removeFirst. self assert: list size = 1. self assert: list first == link4. list removeFirst. self assert: list isEmpty! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:37'! collectionWith1TimeSubcollection " return a collection including 'oldSubCollection' only one time " ^ self oldSubCollection ! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testSelectNoneThenDo | result | result := self collectionWithoutNilElements select: [ :each | each isNil ] thenDo: [ self fail ]. self assert: result equals: self collectionWithoutNilElements! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAtOutOfBounds "self debug: #testAtOutOfBounds" self should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] raise: Error. self should: [ self moreThan4Elements at: -1 ] raise: Error! ! !LinkedListTest methodsFor: 'tests - empty' stamp: ''! testIsEmpty self assert: (self empty isEmpty). self deny: (self nonEmpty isEmpty).! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:04'! test02addLast self assert: list isEmpty. list addLast: link1. self assert: list size = 1. self assert: list first = link1. list addLast: link2. self assert: list size = 2. self assert: list first = link1. self assert: list second = link2. list addLast: link3. self assert: list size = 3. self assert: list first = link1. self assert: list second = link2. self assert: list third = link3. list addLast: link4. self assert: list size = 4. self assert: list first = link1. self assert: list second = link2. self assert: list third = link3. self assert: list fourth = link4! ! !LinkedListTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithCollect | result firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := 0. result := firstCollection with: secondCollection collect: [:a :b | ( index := index + 1). self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b. b]. 1 to: result size do:[: i | self assert: (result at:i)= (secondCollection at: i)]. self assert: result size = secondCollection size.! ! !LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !LinkedListTest methodsFor: 'tests - empty' stamp: ''! testIfEmpty self nonEmpty ifEmpty: [ self assert: false] . self empty ifEmpty: [ self assert: true] . ! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSetAritmeticTest self collection. self deny: self collection isEmpty. self nonEmpty. self deny: self nonEmpty isEmpty. self anotherElementOrAssociationNotIn. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self collectionClass! ! !LinkedListTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiter | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)) ].! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 17:07'! collectionWithoutNilElements " return a collection that doesn't includes a nil element " ^collectionWithoutNil ! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testDetect | res element | element := self collectionWithoutNilElements anyOne . res := self collectionWithoutNilElements detect: [:each | each = element]. self assert: (res = element). ! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeWithIdentityTest | anElement | self collectionWithCopyNonIdentical. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self collectionWithoutEqualElements. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterMore | delim multiItemStream result index | "delim := ', '. multiItemStream := '' readWrite. self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. self assert: multiItemStream contents = '1, 2, 3'." delim := ', '. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. index:=1. (result findBetweenSubStrs: ', ' )do: [:each | self assert: each= ((self nonEmpty at:index)asString). index:=index+1 ].! ! !LinkedListTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementThatExists "self debug: #testRemoveElementThatExists" | el res | el := self nonEmptyWithoutEqualElements anyOne. res := self nonEmptyWithoutEqualElements remove: el. self assert: res == el! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testSelectNoneThenCollect | result | result := self collectionWithoutNilElements select: [ :each | each isNil ] thenCollect: [ :each| self fail ]. self assert: result isEmpty! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testAnySastify | element | " when all elements satisty the condition, should return true :" self assert: ( self collectionWithoutNilElements anySatisfy: [:each | each notNil ]). " when only one element satisfy the condition, should return true :" element := self collectionWithoutNilElements anyOne. self assert: ( self collectionWithoutNilElements anySatisfy: [:each | (each = element) ] ). " when all elements don't satisty the condition, should return false :" self deny: ( self collectionWithoutNilElements anySatisfy: [:each | (each notNil) not ]). ! ! !LinkedListTest methodsFor: 'tests - includes' stamp: ''! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testDetectSequenced " testing that detect keep the first element returning true for sequenceable collections " | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. self assert: result = element. ! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testDo2 "dc: Bad test, it assumes that a new instance of #speciesClass allows addition with #add:. This is not the case of Interval for which species is Array." "res := self speciesClass new. self collection do: [:each | res add: each class]. self assert: res = self result. " | collection cptElementsViewed cptElementsIn | collection := self collectionWithoutNilElements. cptElementsViewed := 0. cptElementsIn := OrderedCollection new. collection do: [ :each | cptElementsViewed := cptElementsViewed + 1. " #do doesn't iterate with the same objects than those in the collection for FloatArray( I don' t know why ) . That's why I use #includes: and not #identityIncludes: '" (collection includes: each) ifTrue: [ " the collection used doesn't include equal elements. Therefore each element viewed should not have been viewed before " ( cptElementsIn includes: each ) ifFalse: [ cptElementsIn add: each ] . ]. ]. self assert: cptElementsViewed = collection size. self assert: cptElementsIn size = collection size. ! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureAsStringCommaAndDelimiterTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty. self nonEmpty1Element. self assert: self nonEmpty1Element size = 1! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:14'! collectionMoreThan1NoDuplicates " return a collection of size 5 without equal elements" ^ collectionWithoutEqualElements! ! !LinkedListTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAny: self empty). self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAny: self nonEmpty).! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testNoneSatisfyEmpty self assert: ( self empty noneSatisfy: [:each | false]). ! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testSelect | result element | result := self collectionWithoutNilElements select: [ :each | each notNil]. self assert: result size equals: self collectionWithoutNilElements size. element := self collectionWithoutNilElements anyOne. result := self collectionWithoutNilElements select: [ :each | (each = element) not]. self assert: result size equals: (self collectionWithoutNilElements size - 1). ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'HenrikSperreJohansen 10/19/2009 14:48'! elementToAdd " return an element of type 'nonEmpy' elements'type'" ^ ValueLink value: 77! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testPairsDo | index | index:=1. self nonEmptyMoreThan1Element pairsDo: [:each1 :each2 | self assert:(self nonEmptyMoreThan1Element at:index)=each1. self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. index:=index+2]. self nonEmptyMoreThan1Element size odd ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! !LinkedListTest methodsFor: 'tests - subcollections access' stamp: ''! testLastNElements "self debug: #testLastNElements" | result | result := self moreThan3Elements last: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] raise: Error! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:46'! accessCollection ^collectionWithoutEqualElements ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testCollectFromTo | result | result:=self nonEmptyMoreThan1Element collect: [ :each | each ] from: 1 to: (self nonEmptyMoreThan1Element size - 1). 1 to: result size do: [ :i | self assert: (self nonEmptyMoreThan1Element at: i) = (result at: i) ]. self assert: result size = (self nonEmptyMoreThan1Element size - 1)! ! !LinkedListTest methodsFor: 'tests - printing' stamp: ''! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testSelectOnEmpty self assert: (self empty select: [:e | self fail]) isEmpty ! ! !LinkedListTest methodsFor: 'test - equality' stamp: ''! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:46'! elementInForElementAccessing " return an element inculded in 'accessCollection '" ^ elementIn ! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testSelectThenCollectOnEmpty self assert: (self empty select: [:e | self fail ] thenCollect: [ self fail ]) isEmpty! ! !LinkedListTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceFromToWithInsertion | result indexOfSubcollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . "verify content of 'result' : " "first part of 'result'' : '" 1 to: (indexOfSubcollection -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) ]. " end part :" (indexOfSubcollection + self replacementCollection size) to: (result size) do: [:i| self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. " verify size: " self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). ! ! !LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringMore "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' " | result resultAnd index allElementsAsString | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . index := 1. (result findBetweenSubStrs: ',' )do: [:each | index = 1 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. index:=index+1 ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size ) ifTrue: [ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] ]. i=(allElementsAsString size) ifTrue:[ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ]. ].! ! !LinkedListTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res anElement | anElement := self elementToAdd . res := self nonEmpty copyWith: anElement. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: (anElement value)). self nonEmpty do: [ :each | res includes: each ]! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !LinkedListTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAllNotIncluded "self debug: #testCopyNonEmptyWithoutAllNotIncluded" | res | res := self nonEmpty copyWithoutAll: self collectionNotIncluded. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !LinkedListTest methodsFor: 'tests - index access' stamp: ''! testIdentityIndexOfIAbsent | collection element | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = 1. self assert: (collection identityIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 55 ]) = 55! ! !LinkedListTest methodsFor: 'testing' stamp: 'nice 9/14/2009 20:57'! testRemoveAll | list2 | list add: link1. list add: link2. list add: link3. list add: link4. list2 := list copy. list removeAll. self assert: list size = 0. self assert: list2 size = 4 description: 'the copy has not been modified'! ! !LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:47'! n ^n! ! !LinkedListTest methodsFor: 'tests - index access' stamp: ''! testIndexOfSubCollectionStartingAt "self debug: #testIndexOfIfAbsent" | subcollection index collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. index := collection indexOfSubCollection: subcollection startingAt: 1. self assert: index = 1. index := collection indexOfSubCollection: subcollection startingAt: 2. self assert: index = 0! ! !LinkedListTest methodsFor: 'testing' stamp: 'zz 12/7/2005 19:08'! test22addAll | link5 link6 link7 link8 listToBeAdded | link5 := Link new. link6 := Link new. link7 := Link new. link8 := Link new. list add: link1; add: link2; add: link3; add: link4. listToBeAdded := LinkedList new. listToBeAdded add: link5; add: link6; add: link7; add: link8. list addAll: listToBeAdded. self should: [(list at: 1) == link1]. self should: [(list at: 2) == link2]. self should: [(list at: 3) == link3]. self should: [(list at: 4) == link4]. self should: [(list at: 5) == link5]. self should: [(list at: 6) == link6]. self should: [(list at: 7) == link7]. self should: [(list at: 8) == link8].! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:14'! collectionWithSortableElements " return a collection only including elements that can be sorted (understanding '<' )" ^ collection5Elements ! ! !LinkedListTest methodsFor: 'tests - index access' stamp: ''! testIdentityIndexOf "self debug: #testIdentityIndexOf" | collection element | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testBasicCollectEmpty | res | res := self empty collect: [:each | each class]. self assert: res isEmpty ! ! !LinkedListTest methodsFor: 'tests - swap' stamp: 'CamilloBruni 11/2/2012 15:58'! testSwapBasic |aList| aList := LinkedList with: 5 with: 4 with: 3 with: 2 with: 1. aList swap: 2 with: 4. self assert: (aList at: 2) equals: 2. self assert: (aList at: 4) equals: 4. ! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testRejectThenCollect | result index selectIndex pivot | index := 0. selectIndex := 0. pivot := self collectionWithoutNilElements anyOne. result := self collectionWithoutNilElements reject: [ :each | selectIndex := selectIndex + 1. "reject the first element" selectIndex = 1 ] thenCollect: [ :each | self assert: each notNil. index := index + 1. pivot ]. self assert: result ~= self collectionWithoutNilElements. self assert: selectIndex equals: self collectionWithoutNilElements size. self assert: index equals: self collectionWithoutNilElements size - 1. self assert: (self collectionWithoutNilElements occurrencesOf: pivot) equals: 1. "should be > 1 for standard collection and = 1 for those that do not allow exact duplicates" self assert: (result occurrencesOf: pivot) >= 1. ! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureOccurrencesTest | tmp | self empty. self assert: self empty isEmpty. self collectionWithoutEqualElements. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each ]. self elementNotInForOccurrences. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 8/31/2013 20:23'! test0FixtureIndexAccessTest | res | self collectionMoreThan1NoDuplicates. self assert: self collectionMoreThan1NoDuplicates size = 5. res := true. self collectionMoreThan1NoDuplicates detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self elementInForIndexAccessing. self assert: (self collectionMoreThan1NoDuplicates includes: self elementInForIndexAccessing). self elementNotInForIndexAccessing. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !LinkedListTest methodsFor: 'tests - swap' stamp: 'CamilloBruni 11/2/2012 15:58'! testSwapAdjacentStart |aList| aList := LinkedList with: 5 with: 4 with: 3 with: 2 with: 1. aList swap: 1 with: 2. self assert: (aList at: 1) equals: 4. self assert: (aList at: 2) equals: 5. self assert: aList first equals: 4.! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := 0. firstCollection with: secondCollection do: [:a :b | ( index := index + 1). self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b.] ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testAllButFirstDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAtWrap "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! !LinkedListTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !LinkedListTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureEmptyTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testDoWithout "self debug: #testDoWithout" | res element collection | collection := self collectionWithoutNilElements . res := OrderedCollection new. element := self collectionWithoutNilElements anyOne . collection do: [:each | res add: each] without: element . " verifying result :" self assert: res size = (collection size - (collection occurrencesOf: element)). res do: [:each | self assert: (collection occurrencesOf: each) = ( res occurrencesOf: each ) ]. ! ! !LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:46'! nextLink: aLink nextLink := aLink! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testKeysAndValuesDo "| result | result:= OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| result add: (value+i)]. 1 to: result size do: [:i| self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:09'! test08addAfter | l first | l := LinkedList new. first := self class new n: 1. l add: first. l add: (self class new n: 3). self assert: (l collect:[:e | e n]) asArray = #(1 3). l add: (self class new n: 2) after: first. self assert: (l collect:[:e | e n]) asArray = #(1 2 3).! ! !LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionItself "self debug: #testIntersectionItself" | result | result := (self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements). self assert: result size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (result includes: each) ]. ! ! !LinkedListTest methodsFor: 'tests - converting' stamp: ''! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0CopyTest self empty. self assert: self empty size = 0. self nonEmpty. self assert: (self nonEmpty size = 0) not. self collectionWithElementsToRemove. self assert: (self collectionWithElementsToRemove size = 0) not. self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ]. self elementToAdd. self deny: (self nonEmpty includes: self elementToAdd). self collectionNotIncluded. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !LinkedListTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOf | collection | collection := self collectionWithoutEqualElements . collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testSumNumbers |result| result:= self collectionWithoutNilElements sumNumbers: [ :ele | ele notNil ifTrue: [ 1 ] ifFalse: [ 0 ]]. self assert: self collectionWithoutNilElements size = result! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:09'! indexInNonEmpty " return an index between bounds of 'nonEmpty' " ^ self nonEmpty size! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testAllSatisfy | element | " when all element satisfy the condition, should return true : " self assert: ( self collectionWithoutNilElements allSatisfy: [:each | (each notNil) ] ). " when all element don't satisfy the condition, should return false : " self deny: ( self collectionWithoutNilElements allSatisfy: [:each | (each notNil) not ] ). " when only one element doesn't satisfy the condition' should return false'" element := self collectionWithoutNilElements anyOne. self deny: ( self collectionWithoutNilElements allSatisfy: [:each | (each = element) not] ).! ! !LinkedListTest methodsFor: 'tests - begins ends with' stamp: ''! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 12/18/2009 12:05'! result "Returns a collection of the classes of elements in #collection" ^ collectResult! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:11'! test12remove list add: link1. list add: link2. list add: link3. list add: link4. self assert: list size = 4. self assert: list first == link1. self assert: list second == link2. self assert: list third == link3. self assert: list fourth == link4. list remove: link3. self assert: list size = 3. self assert: list first == link1. self assert: list second == link2. self assert: list third == link4. list remove: link2. self assert: list size = 2. self assert: list first == link1. self assert: list second == link4. list remove: link1. self assert: list size = 1. self assert: list first == link4. list remove: link4. self assert: list isEmpty! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ collectionWithoutEqualElements! ! !LinkedListTest methodsFor: 'tests - begins ends with' stamp: ''! testsBeginsWith self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty last)). self assert: (self nonEmpty beginsWith:(self nonEmpty )). self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! !LinkedListTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:49'! collectionClass " return the class to be used to create instances of the class tested" ^ LinkedList! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 14:14'! nonEmpty1Element " return a collection of size 1 including one element" ^ nonEmpty1Element ! ! !LinkedListTest methodsFor: 'test - equality' stamp: ''! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !LinkedListTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceFromToWith | result indexOfSubcollection lastIndexOfOldSubcollection lastIndexOfReplacementCollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. lastIndexOfOldSubcollection := indexOfSubcollection + self oldSubCollection size -1. lastIndexOfReplacementCollection := indexOfSubcollection + self replacementCollection size -1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: lastIndexOfOldSubcollection with: self replacementCollection . "verify content of 'result' : " "first part of 'result' " 1 to: (indexOfSubcollection - 1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i) = (result at: i) ]. " middle part containing replacementCollection : " (indexOfSubcollection ) to: ( lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: i)=(self replacementCollection at: (i - indexOfSubcollection +1)) ]. " end part :" 1 to: (result size - lastIndexOfReplacementCollection ) do: [ :i | self assert: (result at: ( lastIndexOfReplacementCollection + i ) ) = (self collectionWith1TimeSubcollection at: ( lastIndexOfOldSubcollection + i ) ). ]. ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testDo! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:05'! test06addAfter self assert: list isEmpty. list add: link1. self assert: list size = 1. self assert: list first == link1. list add: link2 after: link1. self assert: list size = 2. self assert: list first == link1. self assert: list second == link2. list add: link3 after: link2. self assert: list size = 3. self assert: list first == link1. self assert: list second == link2. self assert: list third == link3. list add: link4 after: link3. self assert: list size = 4. self assert: list first == link1. self assert: list second == link2. self assert: list third == link3. self assert: list fourth == link4! ! !LinkedListTest methodsFor: 'tests - copying same contents' stamp: ''! testShuffled | result | result := self nonEmpty shuffled . "verify content of 'result: '" result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !LinkedListTest methodsFor: 'tests - copy' stamp: ''! testCopySameClass "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self empty copy. self assert: copy class == self empty class.! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAfter "self debug: #testAfter" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). self should: [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] raise: Error. self should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] raise: Error! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfter | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfter: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !LinkedListTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButFirstNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. self assert: abf size + 2 = col size! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:36'! oldSubCollection " return a subCollection included in collectionWith1TimeSubcollection . ex : subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)" ^ self nonEmpty ! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePrintTest self nonEmpty. self deny: self nonEmpty isEmpty! ! !LinkedListTest methodsFor: 'tests - empty' stamp: ''! testIfEmptyifNotEmpty self assert: (self empty ifEmpty: [true] ifNotEmpty: [false]). self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [true]). ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := firstCollection size. firstCollection reverseWith: secondCollection do: [:a :b | self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b. ( index := index - 1).] ! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyFromTo | result index collection | collection := self collectionWithoutEqualElements . index :=self indexInForCollectionWithoutDuplicates . result := collection copyFrom: index to: collection size . "verify content of 'result' : " 1 to: result size do: [:i | self assert: (result at:i)=(collection at: (i + index - 1))]. "verify size of 'result' : " self assert: result size = (collection size - index + 1).! ! !LinkedListTest methodsFor: 'tests - includes' stamp: ''! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !LinkedListTest methodsFor: 'tests - index access' stamp: ''! testIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:46'! elementNotInForElementAccessing " return an element not included in 'accessCollection' " ^ elementNotIn ! ! !LinkedListTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiterLast | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (tmp occurrencesOf: (allElementsAsString at:i))=(allElementsAsString occurrencesOf: (allElementsAsString at:i))]. ].! ! !LinkedListTest methodsFor: 'tests - converting' stamp: ''! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! howMany: aSubCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp := collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: aSubCollection) ifTrue: [ nTime := nTime + 1. 1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:55'! indexInForCollectionWithoutDuplicates " return an index between 'collectionWithoutEqualsElements' bounds" ^ 2! ! !LinkedListTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWith "self debug: #testCopyWith" | res anElement | anElement := self elementToAdd. res := self empty copyWith: anElement. self assert: res size = (self empty size + 1). self assert: (res includes: (anElement value))! ! !LinkedListTest methodsFor: 'tests - creating' stamp: 'nice 2/8/2012 21:41'! testCreateAs "Test that a LinkedList can be created by sending message #as: to another collection. Implementation note: this method is generic for sequenceable collection and should be traitified." | anotherCollection aLinkedList | anotherCollection := 1 to: 10. aLinkedList := anotherCollection as: LinkedList. self assert: (aLinkedList isMemberOf: LinkedList). self assert: aLinkedList size equals: anotherCollection size. aLinkedList with: anotherCollection do: [:nextElementOfLinkedList :nextElementOfAnotherCollection | self assert: nextElementOfLinkedList equals: nextElementOfAnotherCollection]! ! !LinkedListTest methodsFor: 'tests - printing' stamp: ''! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !LinkedListTest methodsFor: 'tests - index access' stamp: ''! testIndexOfStartingAtIfAbsent "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testRejectThenDo | result index rejectIndex | index := 0. rejectIndex := 0. result := self collectionWithoutNilElements reject: [ :each | rejectIndex := rejectIndex + 1. "reject the first element" rejectIndex = 1 ] thenDo: [ :each | self assert: each notNil. index := index + 1] . self assert: result equals: self collectionWithoutNilElements. self assert: rejectIndex equals: self collectionWithoutNilElements size. self assert: index equals: self collectionWithoutNilElements size - 1. ! ! !LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAtAll "self debug: #testAtAll" " self flag: #theCollectionshouldbe102030intheFixture. self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." | result | result := self moreThan4Elements atAll: #(2 1 2 ). self assert: (result at: 1) = (self moreThan4Elements at: 2). self assert: (result at: 2) = (self moreThan4Elements at: 1). self assert: (result at: 3) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! !LinkedListTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementReallyRemovesElement "self debug: #testRemoveElementReallyRemovesElement" | size | size := self nonEmptyWithoutEqualElements size. self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! !LinkedListTest methodsFor: 'tests - converting' stamp: ''! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !LinkedListTest methodsFor: 'tests - copying same contents' stamp: ''! testShallowCopy | result | result := self nonEmpty shallowCopy . "verify content of 'result: '" 1 to: self nonEmpty size do: [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !LinkedListTest methodsFor: 'tests - index access' stamp: ''! testIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | collection | collection := self collectionMoreThan1NoDuplicates. self assert: (collection indexOf: collection first ifAbsent: [ 33 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing ifAbsent: [ 33 ]) = 33! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyPartOfSequenceableTest self collectionWithoutEqualElements. self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ]. self indexInForCollectionWithoutDuplicates. self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size. self empty. self assert: self empty isEmpty! ! !LinkedListTest methodsFor: 'tests - converting' stamp: ''! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !LinkedListTest methodsFor: 'tests - converting' stamp: ''! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !LinkedListTest methodsFor: 'tests - empty' stamp: ''! testIfNotEmpty self empty ifNotEmpty: [self assert: false]. self nonEmpty ifNotEmpty: [self assert: true]. self assert: (self nonEmpty ifNotEmpty: [:s | s ]) = self nonEmpty ! ! !LinkedListTest methodsFor: 'tests' stamp: 'nice 7/28/2008 22:27'! testAddAfterLast2 "LinkedListTest new testAddAfterLast2" | l first second third fourth | l := LinkedList new. first := self class new n: 1. second := self class new n: 2. third := self class new n: 3. fourth :=self class new n: 4. l addLast: first. l addLast: second. self assert: (l collect:[:e | e n]) asArray = #(1 2). l add: third after: second. self assert: (l collect:[:e | e n]) asArray = #(1 2 3). l addLast: fourth. self assert: (l collect:[:e | e n]) asArray = #(1 2 3 4).! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:10'! elementNotInForIndexAccessing " return an element not included in 'accessCollection' " ^ elementNotIn ! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyWithOrWithoutSpecificElementsTest self nonEmpty. self deny: self nonEmpty isEmpty. self indexInNonEmpty. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testBasicCollect | res index | index := 0. res := self collectionWithoutNilElements collect: [ :each | index := index + 1. each ]. res do: [ :each | self assert: (self collectionWithoutNilElements occurrencesOf: each) = (res occurrencesOf: each)]. self assert: index equals: self collectionWithoutNilElements size. ! ! !LinkedListTest methodsFor: 'tests - empty' stamp: ''! testIsEmptyOrNil self assert: (self empty isEmptyOrNil). self deny: (self nonEmpty isEmptyOrNil).! ! !LinkedListTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collectionWithoutEqualElements difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res size equals: self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (res includes: each)]. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res equals: separateCol! ! !LinkedListTest methodsFor: 'tests - index access' stamp: ''! testIndexOfSubCollectionStartingAtIfAbsent "self debug: #testIndexOfIfAbsent" | index absent subcollection collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ]. self assert: absent = false. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ]. self assert: absent = true! ! !LinkedListTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 16:14'! collectionWithElement "Returns a collection that already includes what is returned by #element." ^ self collection! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpToLast: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1).! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testRejectThenCollectEmpty self assert: (self empty reject: [:e | self fail ] thenCollect: [ :each| self fail ]) isEmpty! ! !LinkedListTest methodsFor: 'tests - adding' stamp: ''! testTAddIfNotPresentWithElementAlreadyIn | added oldSize collection anElement | collection := self collectionWithElement . oldSize := collection size. anElement := self element . self assert: (collection includes: anElement ). added := collection addIfNotPresent: anElement . self assert: added == anElement . "test for identiy because #add: has not reason to copy its parameter." self assert: collection size = oldSize! ! !LinkedListTest methodsFor: 'tests - printing' stamp: ''! testPrintOn | aStream result allElementsAsString tmp | result:=''. aStream:= ReadWriteStream on: result. tmp:= OrderedCollection new. self nonEmpty do: [:each | tmp add: each asString]. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (tmp occurrencesOf:(allElementsAsString at:i))=(allElementsAsString occurrencesOf:(allElementsAsString at:i)).]. ].! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpTo | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpTo: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1). ! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testRejectThenDoOnEmpty self assert: (self empty reject: [:e | self fail ] thenDo: [ self fail ]) isEmpty! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testSelectThenDoOnEmpty self assert: (self empty select: [:e | self fail ] thenDo: [ self fail ]) isEmpty! ! !LinkedListTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementFromEmpty "self debug: #testRemoveElementFromEmpty" self should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] raise: Error! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:17'! collectionWithElementsToRemove " return a collection of elements included in 'nonEmpty' " ^ self nonEmpty ! ! !LinkedListTest methodsFor: 'tests - copying same contents' stamp: ''! testReversed | result | result := self nonEmpty reversed . "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at:i)=(self nonEmpty at:(self nonEmpty size-i+1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testLast "self debug: #testLast" self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! !LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString | delim := ', '. last := 'and'. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ]. ! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:10'! test11removeLast list add: link1. list add: link2. list add: link3. list add: link4. self assert: list size = 4. self assert: list first == link1. self assert: list second == link2. self assert: list third == link3. self assert: list fourth == link4. list removeLast. self assert: list size = 3. self assert: list first == link1. self assert: list second == link2. self assert: list third == link3. list removeLast. self assert: list size = 2. self assert: list first == link1. self assert: list second == link2. list removeLast. self assert: list size = 1. self assert: list first == link1. list removeFirst. self assert: list isEmpty! ! !LinkedListTest methodsFor: 'tests - adding' stamp: 'damien.pollet 10/31/2008 23:16'! testTAdd | added | added := self otherCollection add: self element. self assert: added = self element. "equality or identity ?" self assert: (self otherCollection includes: self element). ! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeTest | anElementIn | self nonEmpty. self deny: self nonEmpty isEmpty. self elementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self anotherElementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self empty. self assert: self empty isEmpty! ! !LinkedListTest methodsFor: 'tests - includes' stamp: 'CamilloBruni 8/31/2013 20:23'! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection element | self collectionWithCopyNonIdentical. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !LinkedListTest methodsFor: 'tests - empty' stamp: ''! testIfNotEmptyifEmpty self assert: (self empty ifNotEmpty: [false] ifEmpty: [true]). self assert: (self nonEmpty ifNotEmpty: [true] ifEmpty: [false]). ! ! !LinkedListTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotIn). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotIn)! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:36'! replacementCollection " return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' " ^ collectionWithoutNil ! ! !LinkedListTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithoutIndex | result index | index := self indexInNonEmpty . result := self nonEmpty copyWithoutIndex: index . "verify content of 'result:'" 1 to: result size do: [:i | i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. "verify size of result : " self assert: result size=(self nonEmpty size -1).! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseDo | result | result:= OrderedCollection new. self nonEmpty reverseDo: [: each | result add: each]. 1 to: result size do: [:i| self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! !LinkedListTest methodsFor: 'tests - copy' stamp: ''! testCopyEquals "self debug: #testCopySameClass" "A copy should be equivalent to the things it's a copy of" | copy | copy := self nonEmpty copy. self assert: copy = self nonEmpty.! ! !LinkedListTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !LinkedListTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:20'! testAddAfterLast | l last | l := LinkedList new. last := self class new n: 2. l add: (self class new n: 1). l add: last. self assert: (l collect:[:e | e n]) asArray = #(1 2). l add: (self class new n: 3) after: last. self assert: (l collect:[:e | e n]) asArray = #(1 2 3).! ! !LinkedListTest methodsFor: 'tests - adding' stamp: ''! testTAddIfNotPresentWithNewElement | added oldSize collection elem | collection := self otherCollection . oldSize := collection size. elem := self element . self deny: (collection includes: elem ). added := collection addIfNotPresent: elem . self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection size = (oldSize + 1)). ! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAtPin "self debug: #testAtPin" self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testCollectThenSelectOnEmpty self assert: (self empty collect: [:e | self fail] thenSelect: [:e | self fail ]) isEmpty! ! !LinkedListTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfterLast: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAtLastIfAbsent "self debug: #testAtLastIfAbsent" self assert: (self moreThan4Elements atLast: 1 ifAbsent: [ nil ]) = self moreThan4Elements last. self assert: (self moreThan4Elements atLast: self moreThan4Elements size + 1 ifAbsent: [ 222 ]) = 222! ! !LinkedListTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButLastNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButLast: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i) ]. self assert: abf size + 2 = col size! ! !LinkedListTest methodsFor: 'test - fixture' stamp: ''! test0FixtureIterateTest | res | self collectionWithoutNilElements. self assert: (self collectionWithoutNilElements occurrencesOf: nil) = 0. res := true. self collectionWithoutNilElements detect: [ :each | (self collectionWithoutNilElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testNoneSatisfy | element | self assert: ( self collectionWithoutNilElements noneSatisfy: [:each | each notNil not ] ). element := self collectionWithoutNilElements anyOne. self deny: ( self collectionWithoutNilElements noneSatisfy: [:each | (each = element)not ] ).! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAfterIfAbsent "self debug: #testAfterIfAbsent" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1) ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ifAbsent: [ 33 ]) = 33. self assert: (self moreThan4Elements after: self elementNotInForElementAccessing ifAbsent: [ 33 ]) = 33! ! !LinkedListTest methodsFor: 'tests - converting' stamp: ''! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !LinkedListTest methodsFor: 'tests - copying with or without' stamp: ''! testForceToPaddingWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingWith: ( element ). "verify content of 'result' : " 1 to: self nonEmpty size do: [:i | self assert: ( self nonEmpty at: i ) = ( result at:(i) ). ]. (result size - 1) to: result size do: [:i | self assert: ( result at:i ) = ( element ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:13'! test14removeIfAbsent list add: link1. self assert: list size = 1. self assert: list first == link1. list remove: link1. self assert: list isEmpty. [list remove: link1] on: Error do: [^ self]. "The execution should not get here. If yes, something went wrong." self assert: false! ! !LinkedListTest methodsFor: 'requirements' stamp: 'HenrikSperreJohansen 10/19/2009 14:58'! nonEmpty ^ nonEmpty ifNil: [nonEmpty := LinkedList with: 5 with: 4 with: 3 with: 2 with: 1 with: self element]! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindLast | element result | element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. self assert: result=self nonEmptyMoreThan1Element size. ! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testBasicCollectThenDo | result index | index := 0. result := self collectionWithoutNilElements collect: [ :each | nil ] thenDo: [ :each | self assert: each isNil. index := index + 1] . self assert: result equals: self collectionWithoutNilElements. self assert: index equals: self collectionWithoutNilElements size. ! ! !LinkedListTest methodsFor: 'tests - sequenceable' stamp: 'CamilloBruni 8/31/2013 20:23'! testAtPut | ll | ll := LinkedList new. ll add: 1. ll at: 1 put: 2. self assert: (ll at: 1) equals: 2! ! !LinkedListTest methodsFor: 'tests - remove' stamp: ''! testRemoveAllFoundIn "self debug: #testRemoveElementThatExists" | el aSubCollection res | el := self nonEmptyWithoutEqualElements anyOne. aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. res := self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureRequirementsOfTAddTest self collectionWithElement. self otherCollection. self element. self assert: (self collectionWithElement includes: self element). self deny: (self otherCollection includes: self element)! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:05'! test05addBefore self assert: list isEmpty. list add: link1. self assert: list size = 1. self assert: list first == link1. list add: link2 before: link1. self assert: list size = 2. self assert: list first == link2. self assert: list second == link1. list add: link3 before: link2. self assert: list size = 3. self assert: list first == link3. self assert: list second == link2. self assert: list third == link1. list add: link4 before: link3. self assert: list size = 4. self assert: list first == link4. self assert: list second == link3. self assert: list third == link2. self assert: list fourth == link1! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testFirstSecondThird "self debug: #testFirstSecondThird" self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testCollectOnEmpty self assert: (self empty collect: [:e | self fail]) isEmpty! ! !LinkedListTest methodsFor: 'tests - copying with or without' stamp: ''! testForceToPaddingStartWith | result element | element := self nonEmpty at: self indexInNonEmpty . result := self nonEmpty forceTo: (self nonEmpty size+2) paddingStartWith: ( element ). "verify content of 'result' : " 1 to: 2 do: [:i | self assert: ( element ) = ( result at:(i) ) ]. 3 to: result size do: [:i | self assert: ( result at:i ) = ( self nonEmpty at:(i-2) ) ]. "verify size of 'result' :" self assert: result size = (self nonEmpty size + 2).! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTRemoveTest | duplicate | self empty. self nonEmptyWithoutEqualElements. self deny: self nonEmptyWithoutEqualElements isEmpty. duplicate := true. self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ]. self assert: duplicate = false. self elementNotIn. self assert: self empty isEmpty. self deny: self nonEmptyWithoutEqualElements isEmpty. self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! !LinkedListTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithFirst | index element result | index:= self indexInNonEmpty . element:= self nonEmpty at: index. result := self nonEmpty copyWithFirst: element. self assert: result size = (self nonEmpty size + 1). self assert: result first = element . 2 to: result size do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! !LinkedListTest methodsFor: 'tests - empty' stamp: 'damien.pollet 10/31/2008 14:36'! empty ^ list! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAtLast "self debug: #testAtLast" | index | self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. "tmp:=1. self do: [:each | each =self elementInForIndexAccessing ifTrue:[index:=tmp]. tmp:=tmp+1]." index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! !LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 19:10'! collection ^ self nonEmpty! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:03'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne! ! !LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !LinkedListTest methodsFor: 'tests - swap' stamp: 'CamilloBruni 11/2/2012 15:58'! testSwapStartAndEnd |aList| aList := LinkedList with: 5 with: 4 with: 3 with: 2 with: 1. aList swap: 1 with: 5. self assert: (aList at: 1) equals: 1. self assert: (aList at: 5) equals: 5. self assert: aList first equals: 1. self assert: aList last equals: 5.! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !LinkedListTest methodsFor: 'tests - converting' stamp: ''! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testInjectInto |result| result:= self collectionWithoutNilElements inject: 0 into: [:inj :ele | ele notNil ifTrue: [ inj + 1 ]]. self assert: self collectionWithoutNilElements size = result .! ! !LinkedListTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureBeginsEndsWithTest self nonEmpty. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size > 1. self empty. self assert: self empty isEmpty! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testRejectEmpty | res | res := self empty reject: [:each | each odd]. self assert: res size = self empty size ! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testCollectThenDoOnEmpty self assert: (self empty collect: [:e | self fail] thenDo: [ self fail ]) isEmpty! ! !LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAtIfAbsent "self debug: #testAt" | absent | absent := false. self moreThan4Elements at: self moreThan4Elements size + 1 ifAbsent: [ absent := true ]. self assert: absent = true. absent := false. self moreThan4Elements at: self moreThan4Elements size ifAbsent: [ absent := true ]. self assert: absent = false! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:17'! collectionNotIncluded " return a collection for wich each element is not included in 'nonEmpty' " ^ collectionWithoutNil ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:07'! elementNotInForOccurrences " return an element notIncluded in #collectionWithoutEqualElements" ^ elementNotIn ! ! !LinkedListTest methodsFor: 'tests - swap' stamp: 'CamilloBruni 11/2/2012 15:59'! testSwapAdjacent |aList| aList := LinkedList with: 5 with: 4 with: 3 with: 2 with: 1. aList swap: 3 with: 4. self assert: (aList at: 3) equals: 2. self assert: (aList at: 4) equals: 3.! ! !LinkedListTest methodsFor: 'test - equality' stamp: ''! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !LinkedListTest methodsFor: 'tests - index access' stamp: ''! testIndexOf "self debug: #testIndexOf" | tmp index collection | collection := self collectionMoreThan1NoDuplicates. tmp := collection size. collection reverseDo: [ :each | each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. tmp := tmp - 1 ]. self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSubcollectionAccessTest self moreThan3Elements. self assert: self moreThan3Elements size > 2! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:04'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotIn ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:27'! elementInForIndexAccessing " return an element included in 'accessCollection' " ^ elementIn ! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSequencedElementAccessTest self moreThan4Elements. self assert: self moreThan4Elements size >= 4. self subCollectionNotIn. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self elementNotInForElementAccessing. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self elementInForElementAccessing. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !LinkedListTest methodsFor: 'tests - sequenceable' stamp: 'CamilloBruni 8/31/2013 20:23'! testAtPutOutsideBounds | ll | ll := LinkedList new. self should: [ ll at: 1 put: 1 ] raise: SubscriptOutOfBounds! ! !LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" | difference | self assert: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements) isEmpty. self assert: (self empty difference: self collectionWithoutEqualElements) isEmpty. difference := (self collectionWithoutEqualElements difference: self empty). self assert: difference size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each)]. ! ! !LinkedListTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButFirst "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst. self deny: abf first = col first. self assert: abf size + 1 = col size! ! !LinkedListTest methodsFor: 'tests - swap' stamp: 'CamilloBruni 11/2/2012 15:59'! testSwapAdjacentEnd |aList| aList := LinkedList with: 5 with: 4 with: 3 with: 2 with: 1. aList swap: 4 with: 5. self assert: (aList at: 4) equals: 1. self assert: (aList at: 5) equals: 2. self assert: aList last equals: 2.! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testSelectThenDo | result index selectIndex | index := 0. selectIndex := 0. result := self collectionWithoutNilElements select: [ :each | selectIndex := selectIndex + 1. "reject the first element" selectIndex > 1 ] thenDo: [ :each | self assert: each notNil. index := index + 1] . self assert: result equals: self collectionWithoutNilElements. self assert: selectIndex equals: self collectionWithoutNilElements size. self assert: index equals: self collectionWithoutNilElements size - 1. ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'HenrikSperreJohansen 10/19/2009 14:48'! element ^ link ifNil: [link := ValueLink value: 42. "so that we can recognize this link"]! ! !LinkedListTest methodsFor: 'tests - empty' stamp: ''! testNotEmpty self assert: (self nonEmpty notEmpty). self deny: (self empty notEmpty).! ! !LinkedListTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 16:22'! otherCollection ^ otherList ifNil: [otherList := LinkedList with: Link new with: Link new]! ! !LinkedListTest methodsFor: 'tests - remove' stamp: ''! testRemoveAllSuchThat "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self nonEmptyWithoutEqualElements anyOne. aSubCollection := self nonEmptyWithoutEqualElements copyWithout: el. self nonEmptyWithoutEqualElements removeAllSuchThat: [ :each | aSubCollection includes: each ]. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testAllButLastDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !LinkedListTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:20'! testAddAfter | l first | l := LinkedList new. first := self class new n: 1. l add: first. l add: (self class new n: 3). self assert: (l collect:[:e | e n]) asArray = #(1 3). l add: (self class new n: 2) after: first. self assert: (l collect:[:e | e n]) asArray = #(1 2 3).! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:30'! nonEmptyWithoutEqualElements " return a collection without equal elements " ^ collectionWithoutEqualElements ! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:12'! test13remove list add: link1. list add: link2. list add: link3. list add: link4. self assert: list size = 4. self assert: list first == link1. self assert: list second == link2. self assert: list third == link3. self assert: list fourth == link4. list remove: link1. self assert: list size = 3. self assert: list first == link2. self assert: list second == link3. self assert: list third == link4. list remove: link4. self assert: list size = 2. self assert: list first == link2. self assert: list second == link3. list remove: link2. self assert: list size = 1. self assert: list first == link3. list remove: link3. self assert: list isEmpty! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testPairsCollect | index result | index:=0. result:=self nonEmptyMoreThan1Element pairsCollect: [:each1 :each2 | self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). ]. result do: [:each | self assert: each = true]. ! ! !LinkedListTest methodsFor: 'tests - copying same contents' stamp: ''! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testRejectNoReject | res | res := self collectionWithoutNilElements reject: [:each | each notNil not]. self assert: res size = self collectionWithoutNilElements size. ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:47'! subCollectionNotIn " return a collection for which at least one element is not included in 'accessCollection' " ^ collectionWithoutNil ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithIndexDo "| result | result:=Array new: self nonEmptyMoreThan1Element size. self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element withIndexDo: [:value :i | indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !LinkedListTest methodsFor: 'tests - copying same contents' stamp: ''! testReverse | result | result := self nonEmpty reversed. "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at: i) = (self nonEmpty at: (self nonEmpty size - i + 1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testBeforeIfAbsent "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 1) ifAbsent: [ 99 ]) = 99. self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2) ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:09'! test09addAfter | l last | l := LinkedList new. last := self class new n: 2. l add: (self class new n: 1). l add: last. self assert: (l collect:[:e | e n]) asArray = #(1 2). l add: (self class new n: 3) after: last. self assert: (l collect:[:e | e n]) asArray = #(1 2 3).! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 15:32'! speciesClass ^LinkedList! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !LinkedListTest methodsFor: 'tests - set arithmetic' stamp: ''! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopySameContentsTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !LinkedListTest methodsFor: 'running' stamp: 'damien.pollet 10/31/2008 14:48'! tearDown list := nil. link1 := nil. link2 := nil. link3 := nil. link4 := nil. link := nil. nonEmpty := nil. otherList := nil. ^ super tearDown! ! !LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringOne "self assert: self oneItemCol asCommaString = '1'. self assert: self oneItemCol asCommaStringAnd = '1'." self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFromToDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 1 to: (self nonEmptyMoreThan1Element size -1) do: [:i| self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testRejectAllThenDo | result | result := self collectionWithoutNilElements reject: [ :each | each notNil ] thenDo: [ :each | self fail ]. self assert: result equals: self collectionWithoutNilElements! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 15:31'! elementNotIn ^ Link new! ! !LinkedListTest methodsFor: 'running' stamp: 'MarcusDenker 2/24/2010 22:59'! setUp super setUp. list := LinkedList new. link1 := 133. link2 := 'test'. link3 := $h. link4 := Set new. elementNotIn := Link new. collectionWithoutNil := LinkedList new add: link1; add: link2 ; add: link3; yourself. elementIn := 'thisElementIsIncluded'. collectionWithoutEqualElements := LinkedList new add: elementIn ; add: 'pewpew' ; add: 'normal links'; add: 'are no fun!!' ;add: $x ;yourself. collection5Elements := collectionWithoutEqualElements . "sameAtendAndBegining := LinkedList new add: Link new; add: Link new ; add: Link new; yourself." link := ValueLink value: 42. nonEmpty1Element := LinkedList new add: Link new; yourself. "so that we can recognize this link" "nonEmpty := LinkedList with: link with: Link new." "otherList := LinkedList with: Link new with: Link new." ! ! !LinkedListTest methodsFor: 'testing' stamp: 'mk 8/3/2005 12:04'! test01add self assert: list isEmpty. list add: link1. self assert: list size = 1. self assert: list first = link1. list add: link2. self assert: list size = 2. self assert: list first = link1. self assert: list second = link2. list add: link3. self assert: list size = 3. self assert: list first = link1. self assert: list second = link2. self assert: list third = link3. list add: link4. self assert: list size = 4. self assert: list first = link1. self assert: list second = link2. self assert: list third = link3. self assert: list fourth = link4! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:52'! moreThan3Elements " return a collection including atLeast 3 elements" ^ collectionWithoutEqualElements ! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !LinkedListTest methodsFor: 'tests - element accessing' stamp: ''! testAt "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements at: index) = self elementInForElementAccessing! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 14:09'! nonEmptyMoreThan1Element " return a collection that don't includes equl elements'" ^collectionWithoutNil ! ! !LinkedListTest methodsFor: 'tests - iterating' stamp: ''! testDetectIfNone | res element | res := self collectionWithoutNilElements detect: [:each | each notNil not] ifNone: [100]. self assert: res = 100. element := self collectionWithoutNilElements anyOne. res := self collectionWithoutNilElements detect: [:each | each = element] ifNone: [100]. self assert: res = element. ! ! !LinkedListTest methodsFor: 'as yet unclassified' stamp: ''! testRejectAllThenCollect | result | result := self collectionWithoutNilElements reject: [ :each | each notNil ] thenCollect: [ :each| self fail ]. self assert: result isEmpty! ! !LinkedListTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterOne | delim oneItemStream result | "delim := ', '. oneItemStream := '' readWrite. self oneItemCol asStringOn: oneItemStream delimiter: delim. self assert: oneItemStream contents = '1'." delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:46'! nextLink ^nextLink! ! !LinkedListTest methodsFor: 'tests - copying with replacement' stamp: ''! firstIndexesOf: aSubCollection in: collection " return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " | tmp result currentIndex | tmp:= collection. result:= OrderedCollection new. currentIndex := 1. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: aSubCollection) ifTrue: [ result add: currentIndex. 1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !LinkedListTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection last. self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 99 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 99 ]) = 99. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing startingAt: collection size ifAbsent: [ 99 ]) = 99! ! !LinkedListTest methodsFor: 'tests - remove' stamp: ''! testRemoveAllError "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self elementNotIn. aSubCollection := self nonEmptyWithoutEqualElements copyWith: el. self should: [ | res | res := self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! ! !ListComposableModelTest commentStamp: ''! testing ListComposableModel! !ListComposableModelTest methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 9/25/2013 18:24'! testWhenListChangedOldContents "access to old and new contents in whenListChanged." | list oldL newL ok | list := ListModel new. oldL := #(1 2). newL := #(1 2 3). list items: oldL. list whenListChanged: [ :aList :anOldList | self assert: oldL = anOldList. self assert: newL = aList ]. list listItems. "Call listItems to set the cache" list items: #(1 2 3)! ! !ListComposableModelTest methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 9/25/2013 18:24'! testWhenListChanged "Two stages list changed notification." 50 timesRepeat: [ | list ok | list := ListModel new. list items: #(1 2). list whenListChanged: [ :aList | ok := aList = list listItems ]. list listItems. "Call listItems to set the cache" list items: #(1 2 3). self assert: ok ]! ! !ListDialogWindow commentStamp: ''! A ListDialogWindow is a dialog window used to search an element into a list. A text field is provided to on the fly reduce the field or search! !ListDialogWindow methodsFor: 'morphic protocol' stamp: 'AlainPlantec 7/9/2013 11:19'! updateList "update the displayed list in a separate thread to avoid UI blocking" "if there is already a background thread running for the new list discard it" listCreationProcess ifNotNil: [ listCreationProcess terminate]. "no pattern given => empty list" pattern ifNil: [ ^ list :=#() ]. "fork off a possibly costly list calculation" listCreationProcess := [ list := listBlock value: pattern. "make sure the ui is updated in a synchronized manner" self defer: [self listChanged]] fork.! ! !ListDialogWindow methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/10/2013 16:52'! acceptNewEntry ^ acceptNewEntry! ! !ListDialogWindow methodsFor: 'accessing' stamp: 'CamilloBruni 9/16/2013 00:48'! answer ^ answer! ! !ListDialogWindow methodsFor: 'actions' stamp: 'JurajKubelka 11/11/2013 15:41'! ok (acceptNewEntry and: [ list isEmpty ]) ifTrue: [ self answer: self searchString ]. self answer ifNil: [ self searchAccept: self searchString ]. self cancelled: false; delete! ! !ListDialogWindow methodsFor: 'button behavior' stamp: 'BenjaminVanRyseghem 6/26/2012 23:02'! browseBlock ^ browseBlock! ! !ListDialogWindow methodsFor: 'actions' stamp: 'IgorStasenko 12/20/2012 14:56'! newContentMorph | panel | panel := PanelMorph new. panel layoutPolicy: ProportionalLayout new; layoutInset: 0; hResizing: #spaceFill; vResizing: #spaceFill. panel addMorph: self buildListMorph fullFrame: (LayoutFrame identity bottomOffset: -33). panel addMorph: self buildSearchMorph fullFrame: ((0@1 corner: 1@1) asLayoutFrame topOffset: -30). ^ panel! ! !ListDialogWindow methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 6/26/2012 23:01'! cancel self answer: nil. super cancel! ! !ListDialogWindow methodsFor: 'events' stamp: 'CamilloBruni 9/2/2011 13:13'! searchKeystroke: event |interval| searchMorph content ifNil: [ ^ false ]. (event keyCharacter = Character arrowDown ) ifTrue: [ ^ self searchKeystrokeDown ]. (event keyCharacter = Character arrowUp) ifTrue: [ ^ self searchKeystrokeUp ]. ! ! !ListDialogWindow methodsFor: 'protocol' stamp: 'ChristopheDemarey 8/29/2013 13:15'! initialFilter: aString searchMorph content: aString.! ! !ListDialogWindow methodsFor: 'item creation' stamp: 'BenjaminVanRyseghem 6/26/2012 23:01'! buildBrowseButton ^ (PluggableButtonMorph on: self getState: #state action: #browseAction) label: 'Browse'; yourself! ! !ListDialogWindow methodsFor: 'events' stamp: 'CamilloBruni 8/15/2011 22:47'! listKeystroke: event event keyCharacter = Character arrowUp ifTrue: [ ^ self listKeystrokeUp ]. event keyCharacter = Character arrowDown ifTrue: [ ^ self listKeystrokeDown ].! ! !ListDialogWindow methodsFor: 'open/close' stamp: 'BenjaminVanRyseghem 9/8/2013 16:23'! initialAnswer: aString searchMorph content: aString.! ! !ListDialogWindow methodsFor: 'actions' stamp: 'SvenVanCaekenberghe 2/1/2014 20:25'! doubleClickOk self listIndex ~= 0 ifTrue: [ self ok ]! ! !ListDialogWindow methodsFor: 'display' stamp: 'BenjaminVanRyseghem 6/26/2012 22:56'! displayItem: anItem ^ self displayBlock cull: anItem cull: self! ! !ListDialogWindow methodsFor: 'events' stamp: 'BenjaminVanRyseghem 6/26/2012 22:34'! listKeystrokeUp listIndex = 1 ifTrue: [ self listIndex: 0. self giveFocusToSearch. ^ true]. ^ false.! ! !ListDialogWindow methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 9/10/2013 16:50'! initialize list := #(). listIndex := 0. isResizeable := true. listBlock := [ :regex| #() ]. displayBlock := [:e | e printString ]. browseBlock := [:tmp | tmp browse ]. pattern := '.' asRegexIgnoringCase. acceptNewEntry := false. super initialize. ! ! !ListDialogWindow methodsFor: 'protocol' stamp: 'CamilloBruni 9/16/2013 01:07'! accept: anItem self answer: anItem. self ok.! ! !ListDialogWindow methodsFor: 'private' stamp: 'CamilloBruni 8/11/2011 05:55'! no "overwrite de default"! ! !ListDialogWindow methodsFor: 'morphic protocol' stamp: 'CamilloBruni 8/11/2011 14:50'! listIndex: aNumber listIndex := aNumber. self answer: (list at: listIndex ifAbsent: [ nil ]). self changed: #listIndex.! ! !ListDialogWindow methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/28/2012 15:50'! getList: aSymbolOrBlockWithOneArgument aSymbolOrBlockWithOneArgument isBlock ifTrue: [ listBlock := aSymbolOrBlockWithOneArgument. ^ self updateList ]. aSymbolOrBlockWithOneArgument isSymbol ifTrue: [ listBlock := [ :regex| model perform: aSymbolOrBlockWithOneArgument with: regex]. ^ self updateList]. Error signal: 'invalid argument'.! ! !ListDialogWindow methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 6/26/2012 23:01'! newButtons "Answer new buttons as appropriate." ^{self newOKButton isDefault: true. self buildBrowseButton. self newCancelButton}! ! !ListDialogWindow methodsFor: 'morphic protocol' stamp: 'CamilloBruni 8/11/2011 05:32'! list ^ list! ! !ListDialogWindow methodsFor: 'instance creation' stamp: 'ChristopheDemarey 11/27/2013 15:35'! chooseFromOwner: aMorph aMorph openModal: self. ^ self answer! ! !ListDialogWindow methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/18/2012 18:12'! answer: anObject answer := anObject! ! !ListDialogWindow methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/10/2013 16:52'! acceptNewEntry: aBoolean acceptNewEntry := aBoolean! ! !ListDialogWindow methodsFor: 'open/close' stamp: 'CamilloBruni 8/11/2011 03:30'! initialExtent ^ 300 @ 400! ! !ListDialogWindow methodsFor: 'accessing' stamp: 'CamilloBruni 9/16/2013 01:07'! searchString ^ searchMorph searchString! ! !ListDialogWindow methodsFor: 'private' stamp: 'CamilloBruni 8/11/2011 05:55'! yes "overwrite de default"! ! !ListDialogWindow methodsFor: 'button behavior' stamp: 'GabrielOmarCotelli 11/30/2013 17:01'! browseAction | aString tmp block | aString := searchMorph content. list detect: [ :item | (self displayItem: item) = aString ] ifFound: [ :item | self accept: item ]. tmp := answer. block := self browseBlock. [ block value: tmp ] fork. self cancel! ! !ListDialogWindow methodsFor: 'items creation' stamp: 'CamilloBruni 8/11/2011 06:47'! buildSearchMorph ^ searchMorph := SearchMorph new model: self; acceptSelector: #searchAccept:; updateSelector: #searchUpdate:; searchList: self class searchList; keystrokeSelector: #searchKeystroke: yourself. ! ! !ListDialogWindow methodsFor: 'morphic protocol' stamp: 'BenjaminVanRyseghem 6/28/2012 15:49'! searchUpdate: aString pattern := '.' asRegexIgnoringCase. aString isEmptyOrNil ifFalse: [ pattern := [aString asRegexIgnoringCase] on: RegexSyntaxError do: [ aString ]]. self updateList.! ! !ListDialogWindow methodsFor: 'morphic protocol' stamp: 'NicolaiHess 2/22/2014 00:53'! searchAccept: aString self searchUpdate: aString. list detect: [ :item | (self displayItem: item) = aString ] ifFound: [ :item | ^ self accept: item ]. acceptNewEntry ifTrue: [ ^ self accept: aString ] ifFalse: [ list size = 1 ifTrue: [ ^ self accept: list first ] ]. list ifNotEmpty: [ ^ self giveFocusToList ]! ! !ListDialogWindow methodsFor: 'morphic protocol' stamp: 'CamilloBruni 8/11/2011 08:02'! listIndex ^ listIndex ! ! !ListDialogWindow methodsFor: 'events' stamp: 'BenjaminVanRyseghem 6/26/2012 22:34'! listKeystrokeDown listIndex = list size ifTrue: [ self listIndex: 0. self giveFocusToSearch. ^ true]. ^ false.! ! !ListDialogWindow methodsFor: 'focus handling' stamp: 'BenjaminVanRyseghem 6/26/2012 22:34'! giveFocusToSearch searchMorph takeKeyboardFocus.! ! !ListDialogWindow methodsFor: 'display' stamp: 'BenjaminVanRyseghem 6/26/2012 22:55'! displayBlock: aBlock displayBlock := aBlock! ! !ListDialogWindow methodsFor: 'focus handling' stamp: 'BenjaminVanRyseghem 6/26/2012 22:34'! giveFocusToList list ifEmpty: [ ^ self giveFocusToSearch]. self listIndex: (( listIndex max: 1 ) min: list size). listMorph takeKeyboardFocus.! ! !ListDialogWindow methodsFor: 'events' stamp: 'BenjaminVanRyseghem 6/26/2012 22:34'! searchKeystrokeDown |interval| interval := searchMorph selectionInterval . ((interval last == searchMorph content size) and: [ interval last < interval first ]) ifFalse: [ ^ false ]. self giveFocusToList. ^ true! ! !ListDialogWindow methodsFor: 'items creation' stamp: 'SvenVanCaekenberghe 2/1/2014 20:25'! buildListMorph ^ listMorph := PluggableListMorph new hResizing: #spaceFill; vResizing: #spaceFill; on: self list: #list selected: #listIndex changeSelected: #listIndex: menu: nil keystroke: nil; keystrokeSelector: #listKeystroke:; doubleClickSelector: #doubleClickOk; wrapSelector: #displayItem:; yourself! ! !ListDialogWindow methodsFor: 'events' stamp: 'BenjaminVanRyseghem 6/26/2012 22:34'! searchKeystrokeUp (searchMorph selectionInterval last == 0) ifFalse: [ ^ false ]. self listIndex: list size. self giveFocusToList. ^ true! ! !ListDialogWindow methodsFor: 'button behavior' stamp: 'BenjaminVanRyseghem 6/26/2012 23:01'! state ^ false! ! !ListDialogWindow methodsFor: 'display' stamp: 'BenjaminVanRyseghem 6/26/2012 22:55'! displayBlock ^ displayBlock! ! !ListDialogWindow methodsFor: 'focus handling' stamp: 'CamilloBruni 8/11/2011 06:13'! defaultFocusMorph ^ searchMorph! ! !ListDialogWindow methodsFor: 'morphic protocol' stamp: 'CamilloBruni 8/11/2011 05:34'! listChanged self changed: #list.! ! !ListDialogWindow methodsFor: 'button behavior' stamp: 'BenjaminVanRyseghem 6/26/2012 23:02'! browseBlock: aBlock browseBlock := aBlock! ! !ListDialogWindow class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/26/2012 23:40'! chooseFromOwner: aMorph ^ self new chooseFromOwner: aMorph! ! !ListDialogWindow class methodsFor: 'accessing' stamp: 'CamilloBruni 8/11/2011 05:34'! searchList ^ searchList ifNil: [ searchList := OrderedCollection new ]! ! !ListItemWrapper commentStamp: ''! Contributed by Bob Arning as part of the ObjectExplorer package. ! !ListItemWrapper methodsFor: 'accessing' stamp: 'AlainPlantec 12/16/2009 21:59'! preferredColor ^ nil! ! !ListItemWrapper methodsFor: 'converting' stamp: 'RAA 3/30/1999 18:17'! asString ^item asString! ! !ListItemWrapper methodsFor: 'testing' stamp: 'GabrielOmarCotelli 11/30/2013 16:42'! hasEquivalentIn: aCollection ^ aCollection anySatisfy: [ :each | each withoutListWrapper = item withoutListWrapper ]! ! !ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:13'! acceptDroppingObject: anotherItem ^item acceptDroppingObject: anotherItem! ! !ListItemWrapper methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'! withoutListWrapper ^item withoutListWrapper! ! !ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 4/4/1999 17:58'! sendSettingMessageTo: aModel aModel perform: (self settingSelector ifNil: [^self]) with: self withoutListWrapper ! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'MarcusDenker 2/19/2010 17:32'! item: newItem item := newItem! ! !ListItemWrapper methodsFor: 'testing' stamp: 'RAA 3/31/1999 16:24'! handlesMouseOver: evt ^false! ! !ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 21:31'! settingSelector ^nil! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/30/1999 18:27'! setItem: anObject item := anObject! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 7/21/2000 10:59'! balloonText ^nil! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'gvc 10/26/2006 11:11'! model "Answer the model. It is useful!!" ^model! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'gvc 8/23/2006 15:53'! item "Answer the item. It is useful!!" ^item! ! !ListItemWrapper methodsFor: 'testing' stamp: 'RAA 3/31/1999 12:25'! canBeDragged ^true! ! !ListItemWrapper methodsFor: 'testing' stamp: 'RAA 3/31/1999 16:32'! wantsDroppedObject: anotherItem ^false! ! !ListItemWrapper methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 12/3/2013 10:59'! setItemFromBlock: aBlock self setItem: aBlock value! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/31/1999 16:44'! setItem: anObject model: aModel item := anObject. model := aModel.! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 4/1/1999 20:09'! hasContents ^self contents isEmpty not! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/31/1999 16:32'! contents ^Array new! ! !ListItemWrapper methodsFor: 'as yet unclassified ' stamp: 'AlainPlantec 9/11/2011 05:42'! highlightingColor ^self theme currentSettings selectionTextColor! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:22'! icon "Answer a form to be used as icon" ^ nil! ! !ListItemWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:44'! with: anObject model: aModel ^self new setItem: anObject model: aModel! ! !ListItemWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:28'! with: anObject ^self new setItem: anObject! ! !ListModel commentStamp: ''! A ListComposableModel is an applicative model which handle a basic list. | t | t:= ListComposableModel new. t openWithSpec. t items: (Smalltalk allClasses). self example | t | t:= ListComposableModel new. t openWithSpec. t sortingBlock: [:a :b| a name > b name]. t items: (Smalltalk allClasses). | t | t:= ListComposableModel new. t openWithSpec. t filteringBlock: [:col | col select: [:each | each name beginsWith: 'Zn']]. t sortingBlock: [:a :b| a name > b name]. t items: (Smalltalk allClasses). ! !ListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/25/2013 18:28'! listElementAt: anIndex "Return the item at index _anIndex_" ^ self listItems at: anIndex ifAbsent: [ nil ]! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:22'! resetSelection "Unselect every items" selectionHolder reset. multiSelectionHolder removeAll! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:25'! whenAllowToSelectChanged: aBlock "Set a block to value when the value of allowToSelect has changed" allowToSelect whenChangedDo: aBlock! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/6/2014 15:52'! backgroundColorBlock: aBlock "Set the block used to compute an item background" backgroundColorBlock value: aBlock! ! !ListModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 1/10/2014 09:52'! registerEvents listHolder whenChangedDo: [ self refreshListItems ]. filteringBlockHolder whenChangedDo: [ self refreshListItems ]. selectionHolder index whenChangedDo: [ self changed: #getIndex ]. multiSelection whenChangedDo: [ :b | self changed: { #setMultipleSelection: . b } ]. wrapBlockHolder whenChangedDo:[ self changed: #listElementAt: ]. backgroundColorBlock whenChangedDo: [ self refreshListItems ]. autoDeselect whenChangedDo: [ :boolean | self changed: #autoDeselect: with: { boolean }]. sortingBlockHolder whenChangedDo: [ listHolder value: (listHolder value sorted: sortingBlockHolder value). self changed: #listElementAt: ]. ! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! setSelectedIndex: anIndex "Set the index of the item you want to be selected" | idx selection | self allowToSelect ifFalse: [ ^ self ]. self okToChange ifFalse: [ ^ self ]. idx := anIndex min: self listSize. selection := self listElementAt: idx ifAbsent: [ idx := 0. nil ]. selectionHolder index value: idx. selectionHolder selection value: selection.! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:24'! whenSelectionChanged: aBlock "Set a block to value when the selection of the list has changed" selectionHolder whenChangedDo: aBlock. multiSelectionHolder whenChangedDo: aBlock.! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/6/2014 16:05'! backgroundColorFor: anItem at: index ^ self backgroundColorBlock cull: anItem cull: index! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/10/2014 09:51'! autoDeselect: aBoolean "Set if the list items can be selected again" autoDeselect value: aBoolean! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:43'! whenMultiSelectionChanged: aBlock "Set a block to value when the multiSelection value has changed" multiSelection whenChangedDo: aBlock! ! !ListModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 17:10'! initialize super initialize. selectionHolder := Object selectionReactiveVariable. listHolder := Array new asReactiveVariable. sortingBlockHolder := self defaultSortingBlock asReactiveVariable. filteringBlockHolder := self defaultFilteringBlock asReactiveVariable. wrapBlockHolder := [ :object | object asStringOrText ] asReactiveVariable. menuHolder := [ :menu :shifted | nil ] asReactiveVariable. multiSelectionHolder := IdentityDictionary new asReactiveVariable. multiSelection := false asReactiveVariable. allowToSelect := true asReactiveVariable. backgroundColorBlock := [ :item :index | Color white ] asReactiveVariable. autoDeselect := true asReactiveVariable. listAnnouncer := Announcer new. self registerEvents. self bindKeyCombination: Character space toAction: [ self clickOnSelectedItem ]! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! allowToSelect "Return whether the list items can be selected or not" ^ allowToSelect value! ! !ListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! wrapItem: anObject index: index "Return the item _anObject_ wrapped" ^ wrapBlockHolder value cull: anObject cull: index! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 10/17/2013 17:01'! whenListChanged: aBlock "Specify a block to value after the contents of the list has changed" "Basically when you set a new list of items" | block | block := [ :announcement :ann | aBlock cull: announcement newValue cull: announcement oldValue cull: announcement cull: ann ]. listAnnouncer when: ValueChanged do: block! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:24'! whenSelectedItemChanged: aBlock "Set a block to value when the select item is changed" selectionHolder selection whenChangedDo: aBlock! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! allowToSelect: aBoolean "Set if the list items can be selected or not" allowToSelect value: aBoolean. aBoolean ifFalse: [ self resetSelection ].! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 1/10/2014 09:52'! whenAutoDeselectChanged: aBlock "Set a block to value when the value of autoDeselect has changed" autoDeselect whenChangedDo: aBlock! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:22'! selectedIndex "Return the index of the selected item In the case of a multiple selection list, it returns the last selected item" ^ self getIndex! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! filteringBlock "Return the filtering of the items" ^ filteringBlockHolder value! ! !ListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/25/2013 18:28'! getSelectionStateFor: anIndex "Return the current state of the item -if selected or not - in a multiple selection list" "Answer true if the item at index _anIndex_ is selected" ^ (multiSelectionHolder at: anIndex ifAbsent: [ ^ false ]) == true! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/6/2014 15:51'! backgroundColorBlock "Return the block use to compute the background color for each item" ^ backgroundColorBlock value! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! filteringBlock: aBlock "To set the filtering of the items" filteringBlockHolder value: aBlock! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:23'! selectedItems "Return all the selected items in the case of a multiple selection list" ^ multiSelectionHolder keys select: [:index | multiSelectionHolder at: index ] thenCollect: [:index | self listElementAt: index ]! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! sortingBlock "Return the ordering of the items" ^ sortingBlockHolder value! ! !ListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! setIndex: anIndex "Set the index of the selected item when you click on an item" self allowToSelect ifFalse: [ ^ self ]. self okToChange ifFalse: [ ^ self ]. selectionHolder index value: anIndex. selectionHolder selection value: (self listElementAt: anIndex).! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! setSelectedItem: anItem "Set the item you want to be selected" | index | self okToChange ifFalse: [ ^ self ]. index := self listItems identityIndexOf: anItem ifAbsent: [ ^ self ]. selectionHolder index value: index. selectionHolder selection value: anItem! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! resetSortingBlock "Reset the sortering block with the default value which consists in not sorting" sortingBlockHolder value: self defaultSortingBlock! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:40'! whenSortingBlockChanged: aBlock "Set a block to value when the sorting block has changed" sortingBlockHolder whenChangedDo: aBlock! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/10/2014 09:51'! autoDeselect "Return whether the list items can be selected if it's already the selected item" "If true, clicking again on the selected item will unselect it" ^ autoDeselect value! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 1/6/2014 15:52'! whenDisplayBlockChanged: aBlock "Set a block to value when the filtering block has changed" wrapBlockHolder whenChangedDo: aBlock! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! sortingBlock: aBlock "To set the ordering of the items" sortingBlockHolder value: aBlock! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 17:02'! items: aList "Set the items of the list. aList is a collection of your domain specific items. Use a two stages notification (issue 7420)." | oldContents | oldContents := listHolder value. listHolder value: (aList sorted: sortingBlockHolder value). listAnnouncer announce: (ValueChanged oldValue: oldContents newValue: listHolder value)! ! !ListModel methodsFor: 'private' stamp: 'StephaneDucasse 5/17/2012 18:04'! selectedItemHolder ^ selectionHolder selection! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:21'! beSingleSelection "Make list selection single" self multiSelection: false! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! multiSelection: aBoolean "Make the list seelction become multiple if aBoolean is true. Otherwise set the selection as single" multiSelection value: aBoolean. ! ! !ListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 13:23'! refreshListItems listItemsCache := nil. ^ self changed: #listElementAt:! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:24'! updateList "Refresh the list" self changed: #listElementAt:. self resetSelection! ! !ListModel methodsFor: 'initialize' stamp: 'StephaneDucasse 4/17/2012 19:15'! defaultSortingBlock ^ [:a :b | true]! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:38'! whenFilteringBlockChanged: aBlock "Set a block to value when the filtering block block has changed" filteringBlockHolder whenChangedDo: aBlock! ! !ListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/8/2013 14:23'! clickOnSelectedItem | item | item := self selectedItem. ^ (item notNil and: [ item respondsTo: #click ]) ifTrue: [ ^ item click ]! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:34'! whenMenuChanged: aBlock "Set a block to value when the menu block has changed" menuHolder whenChangedDo: aBlock! ! !ListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/25/2013 18:29'! resetListSelection "Reset the selection manager for multiple selection lists" multiSelectionHolder removeAll! ! !ListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/25/2013 18:28'! listElementAt: anIndex ifAbsent: aBlock "Return the item at index _anIndex_" ^ self listItems at: anIndex ifAbsent: aBlock! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:21'! beMultipleSelection "Make list selection multiple" self multiSelection: true! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:07'! menu: aBlock "Set the block used to defined the menu" menuHolder value: aBlock! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! resetFilteringBlock "Reset the filtering block with the default value which consists in showing everything" filteringBlockHolder value: self defaultFilteringBlock! ! !ListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/25/2013 18:29'! setSelectionStateFor: anIndex at: aBoolean "Set the selection state of the item at index _anIndex_ in the case of multiple selection list" self allowToSelect ifFalse: [ ^ self ]. ^ multiSelectionHolder at: anIndex put: aBoolean! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! selectedItem "Return the selected item. In the case of a multiple selection list, it returns the last selected item" ^ self selectedItemHolder value! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:22'! selectedIndexes "Return the indexes of selected items on the case of a multiple selection list" ^ multiSelectionHolder keys select: [:index | multiSelectionHolder at: index ]! ! !ListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! menu: aMenu shifted: aBoolean "Build the menu when you right click on an item" ^ menuHolder value cull: aMenu cull: aBoolean! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! getList ^ listHolder value! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! menu "Return the block used to defined the menu" ^ menuHolder value! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! displayBlock: aBlock "Set the one argument block used to wrap your domain specific items. The block should return something that can be displayed in a list - like a String or a Text" wrapBlockHolder value: aBlock! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! listItems "Return the items of the list. They are your domain specific items" ^ listItemsCache ifNil: [ listItemsCache := filteringBlockHolder value value: listHolder value ] ! ! !ListModel methodsFor: 'initialize' stamp: 'SD 4/19/2012 15:26'! defaultFilteringBlock ^ [:col | col]! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! getIndex "Return the index of the selected item" ^ selectionHolder index value! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:31'! listSize "Return the size of the list" ^ self listItems size! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 1/6/2014 15:52'! whenBackgroundColorBlockChanged: aBlock "Set a block to value when the backgroundColorBlock has changed" backgroundColorBlock whenChangedDo: aBlock! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! displayBlock "Return the one argument block used to wrap your domain specific items. The block should return something that can be displayed in a list - like a String or a Text" ^ wrapBlockHolder value! ! !ListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! multiSelection "Return true if the list has a multiple selection. False if the list has a single selection" ^ multiSelection value! ! !ListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:24'! whenSelectionIndexChanged: aBlock "Set a block to value when the selection index has changed" selectionHolder index whenChangedDo: aBlock! ! !ListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 13:38'! defaultSpec ^ #(ListAdapter adapt: #(model))! ! !ListModel class methodsFor: 'example' stamp: 'StephaneDucasse 5/17/2012 18:02'! example | instance | instance := self new. instance openWithSpec. instance items: (Smalltalk allClasses).! ! !ListModel class methodsFor: 'specs' stamp: ''! title ^ 'List'! ! !ListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:21'! adapterName ^ #ListAdapter! ! !ListSelectionModel commentStamp: ''! A ListSelectionModel is a basic example to show multi selection on lists | l | l := ListSelectionModel new. l openWithSpec! !ListSelectionModel methodsFor: 'initialization' stamp: 'CamilloBruni 9/22/2013 21:36'! initializeWidgets listModel := self newList. textModel1 := self newText. textModel2 := self newText. listModel beMultipleSelection. listModel items: Smalltalk allClasses.! ! !ListSelectionModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/9/2012 17:07'! textModel1 ^ textModel1! ! !ListSelectionModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/9/2012 17:06'! listModel ^ listModel! ! !ListSelectionModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/9/2012 17:07'! textModel2 ^ textModel2! ! !ListSelectionModel methodsFor: 'update' stamp: 'AlainPlantec 7/9/2013 11:19'! updateText "update the displayed list in a separate thread to avoid UI blocking" "if there is already a background thread running for the new list discard it" textRefreshingProcess ifNotNil: [ textRefreshingProcess terminate]. "fork off a possibly costly list calculation" textRefreshingProcess := [ | indexes items | indexes := listModel selectedIndexes sort collect: [:i | i printString ]. indexes := (indexes joinUsing: '; '). items := listModel selectedItems collect: [:i | i printString ]. items := (items sort joinUsing: '; '). UIManager default defer: [ textModel1 text: indexes. textModel2 text: items]] fork.! ! !ListSelectionModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:27'! initializePresenter listModel whenSelectionChanged: [ self updateText ]! ! !ListSelectionModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 15:10'! defaultSpec ^ SpecLayout composed newColumn: [ :column | column add: #listModel; newRow: [ :row | row add: #textModel1; add: #textModel2 ] ]; yourself! ! !ListSelectionModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 15:07'! bottomSpec ^ SpecLayout composed newRow: [ :row | row add: #textModel1; add: #textModel2 ]; yourself! ! !LiteralDictionary commentStamp: ''! A LiteralDictionary, like an IdentityDictionary, has a special test for equality. In this case it is simple equality between objects of like class. This allows equal Float or String literals to be shared without the possibility of erroneously sharing, say, 1 and 1.0! !LiteralDictionary methodsFor: 'testing' stamp: 'nice 8/28/2008 19:26'! literalEquality: x and: y "Check if two literals should be considered equal and reduced to a single literal. Delegate this task to the literal themselves, they are aware of their peculiarities and know how to behave." ^ x literalEqual: y ! ! !LiteralDictionary methodsFor: 'internal' stamp: 'md 10/5/2005 15:43'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | element start finish | finish := array size. start := (anObject hash \\ finish) + 1. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element := array at: index) == nil or: [self literalEquality: element key and: anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element := array at: index) == nil or: [self literalEquality: element key and: anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !LiteralDictionaryTest commentStamp: 'TorstenBergmann 2/20/2014 15:21'! SUnit tests for literal dictionaries! !LiteralDictionaryTest methodsFor: 'tests - literal specific behavior' stamp: 'cyrille.delaunay 7/17/2009 11:17'! testIncludesWithEqualElementFromDifferentClasses | dict | dict := self classToBeTested new. dict at: 1 put: 'element1'. dict at: #key put: 1.0. self deny: (dict includesKey: 1.0). self assert: (dict includes: 1)! ! !LiteralDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 12:57'! classToBeTested ^ LiteralDictionary! ! !LiteralDictionaryTest methodsFor: 'problems' stamp: 'cyrille.delaunay 7/17/2009 11:17'! testUnCategorizedMethods "this test doesn't pass :" | categories slips | categories := self categoriesForClass: self targetClass. slips := categories select: [:each | each = #'as yet unclassified']. self should: [slips isEmpty]. ! ! !LiteralDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 12:58'! shouldInheritSelectors ^true! ! !LiteralNode commentStamp: ''! I am a parse tree leaf representing a literal string or number.! !LiteralNode methodsFor: 'testing' stamp: ''! isConstantNumber ^ key isNumber! ! !LiteralNode methodsFor: 'testing' stamp: ''! isSpecialConstant ^ code between: LdTrue and: LdMinus1+3! ! !LiteralNode methodsFor: 'printing' stamp: 'ClementBera 7/26/2013 16:48'! printOn: aStream indent: level key isVariableBinding ifTrue: [key key ifNil: [aStream nextPutAll: '###'; nextPutAll: key value soleInstance name] ifNotNil: [aStream nextPutAll: '##'; nextPutAll: key key]] ifFalse: [key storeOn: aStream]! ! !LiteralNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:19'! emitCodeForValue: stack encoder: encoder stack push: 1. (encoder if: code isSpecialLiteralForPush: [:specialLiteral| encoder genPushSpecialLiteral: specialLiteral]) ifFalse: [encoder genPushLiteral: index]! ! !LiteralNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:34'! accept: aVisitor ^aVisitor visitLiteralNode: self! ! !LiteralNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:03'! sizeCodeForValue: encoder self reserve: encoder. (encoder if: code isSpecialLiteralForPush: [:specialLiteral| ^encoder sizePushSpecialLiteral: specialLiteral]) ifFalse: [^encoder sizePushLiteral: index]! ! !LiteralNode methodsFor: 'testing' stamp: 'MarcusDenker 9/20/2013 13:27'! isLiteralNode ^ true! ! !LiteralNode methodsFor: 'testing' stamp: ''! literalValue ^key! ! !LiteralNode methodsFor: 'initialize-release' stamp: 'eem 5/14/2008 09:30'! name: literal key: object index: i type: type "For compatibility with Encoder>>name:key:class:type:set:" ^self key: object index: i type: type! ! !LiteralVariableNode commentStamp: 'TorstenBergmann 1/31/2014 11:19'! I am a parse tree leaf representing a literal variable.! !LiteralVariableNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 10:43'! emitCodeForStore: stack encoder: encoder writeNode ifNil: [^encoder genStoreLiteralVar: index]. "THIS IS WRONG!!!! THE VALUE IS LOST FROM THE STACK!!!! The various value: methods on Association ReadOnlyVariableBinding etc _do not_ return the value assigned; they return the receiver." "Should generate something more like push expr push lit push temp (index of expr) send value: pop or use e.g. valueForStore:" self flag: #bogus. writeNode emitCode: stack args: 1 encoder: encoder super: false! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'FirstnameLastname 12/11/2009 13:22'! sizeCodeForStorePop: encoder self reserve: encoder. ^encoder sizeStorePopLiteralVar: index! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:11'! emitCodeForValue: stack encoder: encoder stack push: 1. ^encoder genPushLiteralVar: index! ! !LiteralVariableNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:34'! accept: aVisitor ^aVisitor visitLiteralVariableNode: self! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'FirstnameLastname 12/11/2009 13:21'! sizeCodeForStore: encoder self reserve: encoder. ^encoder sizeStoreLiteralVar: index ! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 10:09'! emitCodeForStorePop: stack encoder: encoder writeNode ifNil: [stack pop: 1. ^encoder genStorePopLiteralVar: index]. self emitCodeForStore: stack encoder: encoder. encoder genPop. stack pop: 1.! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'nice 4/11/2011 15:15'! sizeCodeForLoad: encoder self reserve: encoder. ^writeNode ifNil: [0] ifNotNil: [encoder sizePushLiteral: index]! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:03'! sizeCodeForValue: encoder self reserve: encoder. ^encoder sizePushLiteralVar: index! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 09:44'! emitCodeForLoad: stack encoder: encoder writeNode ifNotNil: [encoder genPushLiteral: index. stack push: 1]! ! !LoadUpdatesCommandLineHandler commentStamp: ''! Usage: update [ --force ] [ --from-file= ] --force Continue loading updates with errors --from-file Use a local instead of http://updates.pharo.org An update file containing a cr-separated list of urls to .cs files Documentation: The update the image to the latest version. Usage: pharo Pharo.image update pharo Pharo.image update --from-file=udpates.list! !LoadUpdatesCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 10/26/2013 21:30'! activate self activateHelp ifTrue: [ ^ self ]. self loadUpdates. Smalltalk snapshot: true andQuit: true.! ! !LoadUpdatesCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 10/26/2013 21:52'! loadUpdates [ (self hasOption: 'from-file') ifTrue: [ self loadUpdatesFromFile ] ifFalse: [ self loadUpdates ]. ] on: UpdateFileNotLoaded do: [ self shouldForce ifFalse: [ self exitFailure ]]! ! !LoadUpdatesCommandLineHandler methodsFor: 'testing' stamp: 'CamilloBruni 10/26/2013 21:36'! shouldForce ^ self hasOption: 'force'! ! !LoadUpdatesCommandLineHandler methodsFor: 'actions' stamp: 'MarcusDenker 1/2/2014 10:38'! loadUpdatesFromFile: updatesFile updatesFile exists ifFalse: [ ^ self exitFailure: (updatesFile fullName, ' does not exist!!') ]. UpdateStreamer new updateFromFile: updatesFile. ! ! !LoadUpdatesCommandLineHandler methodsFor: 'actions' stamp: 'MarcusDenker 1/2/2014 10:38'! loadDefaultUpdates UpdateStreamer new updateFromServer.! ! !LoadUpdatesCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 1/14/2013 16:12'! loadUpdatesFromFile ^ self loadUpdatesFromFile: (self optionAt: 'from-file') asFileReference ! ! !LoadUpdatesCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 2/6/2013 18:16'! description ^ 'Load updates'! ! !LoadUpdatesCommandLineHandler class methodsFor: 'accessing' stamp: 'MarcusDenker 11/7/2012 13:57'! commandName ^ 'update'! ! !Loader commentStamp: 'LaurentLaffont 3/4/2011 22:44'! I'm an abstract class which collect some infos about package and system (versions, dirty). #currentChangedPackages instance method and #currentMajorVersionNumber class are missing and provided by my wellknown subclass ScriptLoader (see ScriptLoader comment). Stef: This is a class that was extracted from scriptLoader because I want to slowly get in place a loader infrastructure based on Metacello.! !Loader methodsFor: 'initialization' stamp: 'StephaneDucasse 9/10/2010 17:49'! initialize super initialize. PackagesBeforeLastLoad ifNil: [ PackagesBeforeLastLoad := Set new ]! ! !Loader methodsFor: 'private' stamp: 'MarcusDenker 10/21/2012 11:07'! packagesNotToSavePatternNames ^ #( 'ScriptLoader*' 'SLICE*' 'Slice*' 'slice*' ).! ! !Loader methodsFor: 'elementary steps' stamp: 'StephaneDucasse 9/10/2010 17:51'! diffPackages "return a list of packages that are new. They can be dirty or not." "self new diffPackages" | diff | diff := Set new. self currentVersionsToBeSaved do: [:each | (PackagesBeforeLastLoad includes: each) ifFalse: [diff add: each]]. ^ diff ! ! !Loader methodsFor: 'accessing' stamp: 'StephaneDucasse 9/10/2010 17:34'! currentMajorVersionNumberWithoutDot "self new currentMajorVersionNumberWithoutDot" ^ self class currentMajorVersionNumber asString copyWithout: $.! ! !Loader methodsFor: 'compute' stamp: 'StephaneDucasse 9/10/2010 17:42'! currentVersionsToBeSaved "self new currentVersionsToBeSaved" ^ self allCurrentVersions reject: [ :each | self packagesNotToSavePatternNames anySatisfy: [ :p | p match: each ] ]! ! !Loader methodsFor: 'compute' stamp: 'StephaneDucasse 9/10/2010 17:51'! currentChangedPackages "self new currentChangedPackages" ^ self currentPackages select: [:each | each needsSaving or: [ (PackagesBeforeLastLoad includes: each ancestry ancestorString) not ] ]! ! !Loader methodsFor: 'private' stamp: 'StephaneDucasse 9/10/2010 17:51'! resetPackagesBeforeLastLoad PackagesBeforeLastLoad := Set new! ! !Loader methodsFor: 'accessing' stamp: 'StephaneDucasse 9/10/2010 17:34'! currentMajorVersionNumber ^ self class currentMajorVersionNumber ! ! !Loader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 9/10/2010 17:41'! allCurrentVersions "self new allCurrentVersions" | copies names | copies := MCWorkingCopy allManagers asSortedCollection: [ :a :b | a package name <= b package name ]. names := copies collect: [:ea | ea ancestry ancestorString ]. ^ names reject: #isEmpty! ! !Loader methodsFor: 'private' stamp: 'StephaneDucasse 9/10/2010 17:51'! markPackagesBeforeNewCodeIsLoaded "Use this method to keep a log of all the packages that were loaded before loading new code. This will help the system to perform a diff and know after what to publish." "self new markPackagesBeforeNewCodeIsLoaded" PackagesBeforeLastLoad := self currentVersionsToBeSaved! ! !Loader class methodsFor: 'private' stamp: 'S 6/17/2013 13:26'! waitingCacheFolder ^ self packageToBeTestedFolderName asFileReference ensureCreateDirectory; yourself ! ! !Loader class methodsFor: 'private' stamp: 'StephaneDucasse 9/10/2010 17:22'! packageToBeTestedFolderName ^ 'packages-to-be-tested'! ! !LoadingMorph commentStamp: ''! I am a special iamge morph used to be displayed as an icon for loading! !LoadingMorph methodsFor: 'stepping and presenter' stamp: 'BenjaminVanRyseghem 11/24/2013 20:58'! step self isStepping ifFalse: [ ^ self ]. self applyState: currentState nextState.! ! !LoadingMorph methodsFor: 'stepping' stamp: 'BenjaminVanRyseghem 11/26/2013 22:29'! stepTime ^ currentState stepTime! ! !LoadingMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 22:31'! applyState: aState currentState = aState ifTrue: [ ^ self ]. currentState := aState. self image: aState image! ! !LoadingMorphState commentStamp: ''! I am the abstract super class of the loading morph state. They are used as state in a state machine for the order of the icons in the rotating animation! !LoadingMorphState methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 20:47'! nextState ^ self subclassResponsibility! ! !LoadingMorphState methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 22:30'! stepTime self subclassResponsibility! ! !LoadingMorphState methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 20:50'! image ^ self class image! ! !LoadingMorphState class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/24/2013 20:51'! imageData ^ self subclassResponsibility! ! !LoadingMorphState class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2013 22:43'! formFromContents: aByteArray | size | size := self size. ^ Form extent: size@size depth: 32 fromArray: aByteArray offset: 0@0! ! !LoadingMorphState class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/25/2013 15:43'! image ^ image ifNil: [ image := self formFromContents: self imageData ]! ! !LoadingState commentStamp: ''! I am the state used while loading! !LoadingState methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:18'! image ^ LoadingMorph new applyState: SmallCogInitialState new; yourself! ! !LoadingThenOk commentStamp: ''! Small widget displaying a small cog turning while loading, then a ok tick when loading is done! !LoadingThenOk methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:20'! ok self state: OkState new! ! !LoadingThenOk methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:20'! state: anObject state value: anObject! ! !LoadingThenOk methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize super initialize. state := ErrorState new asValueHolder. state whenChangedDo: [ :s | self rebuildForState: s ]! ! !LoadingThenOk methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2013 23:37'! newSpec ^ SpecLayout composed add: #currentImage; yourself! ! !LoadingThenOk methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:20'! state ^ state value! ! !LoadingThenOk methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:38'! currentImage ^ self state image asSpecAdapter! ! !LoadingThenOk methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:20'! loading self state: LoadingState new! ! !LoadingThenOk methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/26/2013 22:35'! initializeWidgets! ! !LoadingThenOk methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2013 23:38'! rebuildForState: aState self needRebuild: false. self buildWithSpecLayout: self newSpec. self focusOrder removeAll! ! !LoadingThenOk methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:20'! error self state: ErrorState new! ! !LoadingThenOk class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/26/2013 23:24'! defaultSpec ^ SpecLayout composed add: #currentImage; yourself! ! !LoadingThenOkState commentStamp: ''! I am an abstract class representing the state of the LoadingThenOk widget the different states are: ok, error, loading. I must define an image used to render the state! !LoadingThenOkState methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:18'! image ^ self subclassResponsibility! ! !LocalTimeZone commentStamp: ''! I am the local time zone which will use the system's current time offset dynamically. This is the default timezone.! !LocalTimeZone methodsFor: 'converting' stamp: 'CamilloBruni 8/24/2013 00:08'! asFixedTimeZone "Convert this dynamic timezone to one with a fixed offset." ^ TimeZone offset: self offset name: 'Fixed Local Time' abbreviation: self abbreviation! ! !LocalTimeZone methodsFor: 'accessing' stamp: 'CamilloBruni 8/24/2013 00:03'! abbreviation ^ String streamContents: [ :s | s nextPutAll: 'LT'; print: self offset hours; nextPut: $:. s nextPutAll: (self offset minutes printPaddedWith: $0 to: 2) ].! ! !LocalTimeZone methodsFor: 'accessing' stamp: 'CamilloBruni 8/23/2013 23:57'! name ^ 'Local Time'! ! !LocalTimeZone methodsFor: 'accessing' stamp: 'CamilloBruni 8/23/2013 23:58'! offset ^ self primOffset minutes! ! !LocalTimeZone methodsFor: 'primitives' stamp: 'CamilloBruni 8/23/2013 23:59'! primOffset "The offset from UTC in minutes, with positive offsets being towards the east. (San Francisco is in UTC -07*60 and Paris is in UTC +02*60 (daylight savings is not in effect)." ^ 0! ! !Locale commentStamp: ''! Main comment stating the purpose of this class and relevant relationship to other classes. http://www.w3.org/WAI/ER/IG/ert/iso639.htm http://www.oasis-open.org/cover/iso639a.html See also http://oss.software.ibm.com/cvs/icu/~checkout~/icuhtml/design/language_code_issues.html http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.10 ISO 3166 http://mitglied.lycos.de/buran/knowhow/codes/locales/ ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:55'! localeID ^id! ! !Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:43'! primMeasurement "Returns boolean denoting metric(true) or imperial(false)." ^true ! ! !Locale methodsFor: 'system primitives' stamp: 'jannik.laval 2/4/2010 15:11'! primShortDateFormat "Returns the short date format d day, m month, y year, double symbol is null padded, single not padded (m=6, mm=06) dddd weekday mmmm month name" ^'m/d/yy' ! ! !Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:44'! primVMOffsetToUTC "Returns the offset in minutes between the VM and UTC. If the VM does not support UTC times, this is 0. Also gives us backward compatibility with old VMs as the primitive will fail and we then can return 0." ^0! ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:41'! isoLocale "-" ^self isoCountry ifNil: [self isoLanguage] ifNotNil: [self isoLanguage , '-' , self isoCountry]! ! !Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:42'! primDigitGrouping "Returns string with e.g. '.' or ',' (thousands etc)" ^','! ! !Locale methodsFor: 'private' stamp: 'StephaneDucasse 5/28/2011 13:45'! fetchISO2Language "Locale current fetchISO2Language" | lang isoLang | lang := self primLanguage. lang ifNil: [^nil]. lang := lang copyUpTo: 0 asCharacter. lang size = 2 ifTrue: [^lang]. isoLang := ISOLanguageDefinition iso3LanguageDefinition: lang. ^isoLang ifNil: [nil] ifNotNil: [isoLang iso2]! ! !Locale methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:39'! isoCountry ^self localeID isoCountry! ! !Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:48'! primDST "Returns boolean if DST (daylight saving time) is active or not" ^false! ! !Locale methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:39'! isoLanguage ^self localeID isoLanguage! ! !Locale methodsFor: 'accessing' stamp: 'mir 8/31/2005 17:03'! determineLocale self localeID: self determineLocaleID! ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:55'! localeID: anID id := anID! ! !Locale methodsFor: 'system primitives' stamp: 'jannik.laval 2/4/2010 15:08'! primTimezone "The offset from UTC in minutes, with positive offsets being towards the east. (San Francisco is in UTC -07*60 and Paris is in UTC +02*60 (daylight savings is not in effect)." ^0! ! !Locale methodsFor: 'system primitives' stamp: 'jannik.laval 2/4/2010 15:09'! primCountry "Returns string with country tag according to ISO 639" ^'FR'! ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:52'! languageEnvironment ^LanguageEnvironment localeID: self localeID! ! !Locale methodsFor: 'accessing' stamp: 'CamilloBruni 11/6/2013 21:23'! determineLocaleID "Locale current determineLocaleID" | langCode isoLang countryCode isoCountry | langCode := self fetchISO2Language. isoLang := langCode ifNil: [^self localeID] ifNotNil: [langCode]. countryCode := self primCountry copyUpTo: 0 asCharacter. isoCountry := countryCode ifNil: [^LocaleID isoLanguage: isoLang] ifNotNil: [countryCode]. ^LocaleID isoLanguage: isoLang isoCountry: isoCountry! ! !Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:47'! primCurrencySymbol "Returns string with currency symbol" ^'$'! ! !Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:42'! primDecimalSymbol "Returns string with e.g. '.' or ','" ^'.'! ! !Locale methodsFor: 'system primitives' stamp: 'jannik.laval 2/4/2010 15:09'! primLongDateFormat "Returns the long date format d day, m month, y year, double symbol is null padded, single not padded (m=6, mm=06) dddd weekday mmmm month name" ^'dddd, mmmm d, yyyy' ! ! !Locale methodsFor: 'system primitives' stamp: 'jannik.laval 2/4/2010 15:07'! primLanguage "returns string with language tag according to ISO 639" ^'en'! ! !Locale methodsFor: 'system primitives' stamp: 'jannik.laval 2/4/2010 15:11'! primTimeFormat "Returns string time format Format is made up of h hour (h 12, H 24), m minute, s seconds, x (am/pm String) double symbol is null padded, single not padded (h=6, hh=06)" ^'h:mmx' ! ! !Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:45'! primCurrencyNotation "Returns boolean if symbol is pre- (true) or post-fix (false)" ^true! ! !Locale methodsFor: 'printing' stamp: 'tak 8/4/2005 15:18'! printOn: aStream super printOn: aStream. aStream nextPutAll: '(' , id printString , ')'! ! !Locale class methodsFor: 'system startup' stamp: 'CamilloBruni 8/24/2013 00:09'! localTimeZone ^ LocalTimeZone new! ! !Locale class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 10:59'! activated ^ Activated ifNil: [Activated := false]! ! !Locale class methodsFor: 'private' stamp: 'mir 7/28/2005 00:24'! determineCurrentLocale "For now just return the default locale. A smarter way would be to determine the current platforms default locale." "Locale determineCurrentLocale" ^self new determineLocale! ! !Locale class methodsFor: 'notification' stamp: 'mir 6/30/2004 16:15'! addLocalChangedListener: anObjectOrClass self localeChangedListeners add: anObjectOrClass! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 19:07'! switchToID: localeID "Locale switchToID: (LocaleID isoLanguage: 'de') " self switchTo: (Locale localeID: localeID)! ! !Locale class methodsFor: 'platform specific' stamp: 'cami 7/22/2013 18:28'! defaultEncodingName: languageSymbol | encodings platformName osVersion | platformName := Smalltalk os platformName. osVersion := Smalltalk os version. encodings := self platformEncodings at: languageSymbol ifAbsent: [self platformEncodings at: #default]. encodings at: platformName ifPresent: [:encoding | ^encoding]. encodings at: platformName , ' ' , osVersion ifPresent: [:encoding | ^encoding]. ^encodings at: #default! ! !Locale class methodsFor: 'initialization' stamp: 'AlainPlantec 1/5/2010 12:24'! initialize "Locale initialize" Smalltalk addToStartUpList: Locale. ! ! !Locale class methodsFor: 'private' stamp: 'mir 7/15/2004 19:44'! initKnownLocales | locales | locales := Dictionary new. "Init the locales for which we have translations" NaturalLanguageTranslator availableLanguageLocaleIDs do: [:id | locales at: id put: (Locale new localeID: id)]. ^locales! ! !Locale class methodsFor: 'initialization' stamp: 'MarcusDenker 1/24/2010 11:07'! initializePlatformEncodings "Locale initializePlatformEncodings" | platform | PlatformEncodings ifNil: [ PlatformEncodings := Dictionary new ]. platform := PlatformEncodings at: 'default' ifAbsentPut: Dictionary new. platform at: 'default' put: 'iso8859-1'; at: 'Win32 CE' put: 'utf-8'. platform := PlatformEncodings at: 'ja' ifAbsentPut: Dictionary new. platform at: 'default' put: 'shift-jis'; at: 'unix' put: 'euc-jp'; at: 'Win32 CE' put: 'utf-8'. platform := PlatformEncodings at: 'ko' ifAbsentPut: Dictionary new. platform at: 'default' put: 'euc-kr'; at: 'Win32 CE' put: 'utf-8'. platform := PlatformEncodings at: 'zh' ifAbsentPut: Dictionary new. platform at: 'default' put: 'gb2312'; at: 'unix' put: 'euc-cn'; at: 'Win32 CE' put: 'utf-8'. ! ! !Locale class methodsFor: 'accessing' stamp: 'HilaireFernandes 5/6/2010 21:31'! stringForLanguageNameIs: localeID "Answer a string for a menu determining whether the given symbol is the project's natural language" ^ (self current localeID = localeID ifTrue: [''] ifFalse: ['']) , localeID displayLanguage! ! !Locale class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 10:59'! activated: aBoolean Activated := aBoolean! ! !Locale class methodsFor: 'notification' stamp: 'mir 6/30/2004 16:15'! localeChangedListeners ^LocaleChangeListeners ifNil: [LocaleChangeListeners := OrderedCollection new]! ! !Locale class methodsFor: 'system startup' stamp: 'CamilloBruni 7/17/2012 15:55'! startUp: resuming | newID | resuming ifFalse: [^self]. DateAndTime localTimeZone: self localTimeZone. (self activated) ifTrue: [ newID := self current determineLocaleID. newID ~= LocaleID current ifTrue: [self switchToID: newID]]! ! !Locale class methodsFor: 'initialization' stamp: 'nk 8/29/2004 13:20'! platformEncodings PlatformEncodings isEmptyOrNil ifTrue: [ self initializePlatformEncodings ]. ^PlatformEncodings ! ! !Locale class methodsFor: 'private' stamp: 'mir 7/15/2004 16:44'! knownLocales "KnownLocales := nil" ^KnownLocales ifNil: [KnownLocales := self initKnownLocales]! ! !Locale class methodsFor: 'accessing' stamp: 'yo 7/28/2004 20:32'! currentPlatform "CurrentPlatform := nil" CurrentPlatform ifNil: [CurrentPlatform := self determineCurrentLocale]. ^CurrentPlatform! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:42'! isoLocale: aString ! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:31'! isoLanguage: isoLanguage isoCountry: isoCountry ^self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry)! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/13/2004 00:24'! languageSymbol: languageSymbol "Locale languageSymbol: #Deutsch" ^self isoLanguage: (LanguageSymbols at: languageSymbol)! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:30'! localeID: id ^self knownLocales at: id ifAbsentPut: [Locale new localeID: id]! ! !Locale class methodsFor: 'accessing' stamp: 'tak 10/18/2005 22:33'! currentPlatform: locale during: aBlock "Alter current language platform during a block" | backupPlatform | backupPlatform := self currentPlatform. [self currentPlatform: locale. aBlock value] ensure: [self currentPlatform: backupPlatform]! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:20'! isoLanguage: isoLanguage ^self isoLanguage: isoLanguage isoCountry: nil! ! !Locale class methodsFor: 'accessing' stamp: 'tak 8/4/2005 16:30'! switchTo: locale "Locale switchTo: Locale isoLanguage: 'de'" Current localeID = locale localeID ifFalse: [Current := locale. CurrentPlatform := locale. self localeChanged]! ! !Locale class methodsFor: 'notification' stamp: 'MarcusDenker 3/24/2011 16:36'! localeChanged! ! !Locale class methodsFor: 'accessing' stamp: 'yo 7/28/2004 20:39'! currentPlatform: locale CurrentPlatform := locale. LanguageEnvironment startUp. ! ! !Locale class methodsFor: 'accessing' stamp: 'mir 8/31/2005 17:36'! current "Current := nil" Current ifNil: [ Current := self determineCurrentLocale. "Transcript show: 'Current locale: ' , Current localeID asString; cr"]. ^Current! ! !LocaleID commentStamp: 'TorstenBergmann 1/31/2014 10:08'! The ID for localization! !LocaleID methodsFor: 'comparing' stamp: 'mir 7/15/2004 14:23'! hash ^self isoLanguage hash bitXor: self isoCountry hash! ! !LocaleID methodsFor: 'testing' stamp: 'mir 7/15/2004 14:34'! hasParent ^self isoCountry notNil! ! !LocaleID methodsFor: 'initialize' stamp: 'mir 7/15/2004 12:44'! isoLanguage: langString isoCountry: countryStringOrNil isoLanguage := langString. isoCountry := countryStringOrNil! ! !LocaleID methodsFor: 'printing' stamp: 'tak 11/15/2004 12:45'! storeOn: aStream aStream nextPut: $(. aStream nextPutAll: self class name. aStream nextPutAll: ' isoString: '. aStream nextPutAll: '''' , self printString , ''''. aStream nextPut: $). ! ! !LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:43'! isoCountry ^isoCountry! ! !LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:43'! isoLanguage ^isoLanguage! ! !LocaleID methodsFor: 'accessing' stamp: 'mir 7/21/2004 19:17'! isoString ^self asString! ! !LocaleID methodsFor: 'comparing' stamp: 'mir 7/15/2004 14:23'! = anotherObject self class == anotherObject class ifFalse: [^false]. ^self isoLanguage = anotherObject isoLanguage and: [self isoCountry = anotherObject isoCountry]! ! !LocaleID methodsFor: 'accessing' stamp: 'mir 9/1/2005 14:17'! displayCountry ^(ISOLanguageDefinition iso2Countries at: self isoCountry asUppercase ifAbsent: [ self isoCountry ]) ! ! !LocaleID methodsFor: 'printing' stamp: 'mir 7/15/2004 12:45'! printOn: stream "-" stream nextPutAll: self isoLanguage. self isoCountry ifNotNil: [stream nextPut: $-; nextPutAll: self isoCountry]! ! !LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:34'! parent ^self class isoLanguage: self isoLanguage! ! !LocaleID methodsFor: 'accessing' stamp: 'tak 3/23/2006 12:26'! displayLanguage | language | language := (ISOLanguageDefinition iso2LanguageTable at: self isoLanguage ifAbsent: [^ self isoLanguage]) language. ^ self isoCountry ifNil: [language] ifNotNil: [language , ' (' , self displayCountry , ')']! ! !LocaleID methodsFor: 'printing' stamp: 'tak 8/6/2007 12:16'! posixName "(LocaleID isoString: 'es-MX') posixName" "(LocaleID isoString: 'es') posixName" "language[_territory]" ^ self isoCountry ifNil: [self isoLanguage] ifNotNil: [self isoLanguage , '_' , self isoCountry]! ! !LocaleID class methodsFor: 'accessing' stamp: 'bf 9/26/2007 16:24'! previous ^Locale previous localeID! ! !LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/21/2004 13:59'! isoString: isoString "Parse the isoString (-) into its components and return the matching LocaleID" "LocaleID isoString: 'en' " "LocaleID isoString: 'en-us' " | parts language country | parts := isoString findTokens: #($- ). language := parts first. parts size > 1 ifTrue: [country := parts second]. ^self isoLanguage: language isoCountry: country! ! !LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/15/2004 14:35'! isoLanguage: langString ^self isoLanguage: langString isoCountry: nil! ! !LocaleID class methodsFor: 'instance creation' stamp: 'HilaireFernandes 4/30/2010 18:00'! posixName: aString ^ self isoString: (aString copyReplaceAll: '_' with: '-')! ! !LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/15/2004 12:46'! isoLanguage: langString isoCountry: countryStringOrNil ^self new isoLanguage: langString isoCountry: countryStringOrNil! ! !LocaleID class methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:09'! current ^Locale current localeID! ! !LockableTab commentStamp: ''! I am a tab which can be locked/unlocked with according action and icon! !LockableTab methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/4/2013 15:49'! showCloseIcon closeIcon show! ! !LockableTab methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/4/2013 15:42'! closeable: anObject closeable := anObject. anObject ifTrue: [ self setUnlockedIcon ] ifFalse: [ self setLockedIcon ]! ! !LockableTab methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/4/2013 15:42'! setLockedIcon closeIcon image: self class lockedIcon.! ! !LockableTab methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/4/2013 15:42'! setUnlockedIcon closeIcon image: self class closeIcon.! ! !LockableTab class methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 6/8/2013 15:54'! lockedIcon ^ Icons at: #lockedIcon ifAbsentPut: [ self lockedIconContents ]! ! !LockableTab class methodsFor: 'icons-contents' stamp: 'BenjaminVanRyseghem 6/8/2013 15:54'! lockedIconContents ^ Form extent: 12@12 depth: 32 fromArray: #(0 0 0 807082779 3175894092 4235885178 4235885178 3159116876 807082779 0 0 0 0 0 1107296256 4286545791 4290164406 3801519766 3801519766 4290230199 4286545791 1107296256 0 0 0 0 3578020932 4290295992 2284991026 335741699 335741699 2285122612 4290361785 3578020932 0 0 0 301989888 3899288170 4019755160 738197504 0 0 738197504 4019228816 3900011893 301989888 0 33554432 1478500384 4100746348 4137458844 2436709693 2035898713 2035898713 2436907072 4135814019 4102325380 1478171419 33554432 234881024 3429723501 4291611852 4292532954 4292072403 4292072403 4292072403 4292072403 4292401368 4291809231 3429723501 234881024 251658240 3480120942 4291546059 4292138196 4292269782 4292006610 4292006610 4292269782 4292138196 4291546059 3480120942 251658240 251658240 3479857770 4290559164 4291217094 4291743438 4285493103 4285493103 4291743438 4291282887 4290559164 3479857770 251658240 251658240 3479726184 4290098613 4290756543 4291151301 4286743170 4286743170 4291151301 4290756543 4290230199 3479726184 251658240 251658240 3479660391 4289967027 4290624957 4290822336 4289703855 4289703855 4290822336 4290624957 4290032820 3479726184 251658240 268435456 3530057832 4290230199 4290888129 4290888129 4291019715 4291019715 4290888129 4290888129 4290230199 3530123625 268435456 150994944 2939631415 4283979864 4284308829 4284374622 4284374622 4284374622 4284374622 4284308829 4284045657 2939697208 150994944) offset: 0@0! ! !LogicalFont commentStamp: 'LaurentLaffont 6/8/2011 22:20'! I describe a font.! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 13:37'! ascent ^self realFont ascent! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:12'! displayUnderlineOn: aGrafPort from: aPoint to: aPoint3 ^self realFont displayUnderlineOn: aGrafPort from: aPoint to: aPoint3 ! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 15:57'! setEmphasis: code emphasis := code! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/17/2007 00:27'! stretchValue: anObject "Set the value of stretchValue" stretchValue := anObject! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/28/2007 14:56'! widthOfString: aString ^self realFont widthOfString: aString! ! !LogicalFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 6/11/2012 02:17'! getGlyphWidth: aCharacter ^ self realFont getGlyphWidth: aCharacter! ! !LogicalFont methodsFor: 'initialize-release' stamp: 'tween 3/16/2007 17:42'! initialize: aFont familyName := aFont familyName. emphasis := aFont emphasis.! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 13:33'! height ^self realFont height! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 16:34'! forceItalicOrOblique self slantValue = 0 ifTrue:[slantValue := 1]! ! !LogicalFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 6/11/2012 02:17'! getPreciseHeight ^ self realFont getPreciseHeight! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/21/2007 09:16'! kerningLeft: leftChar right: rightChar ^self realFont kerningLeft: leftChar right: rightChar! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 13:58'! pointSize: aNumber pointSize := aNumber! ! !LogicalFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 6/11/2012 02:16'! getPreciseAscent ^ self realFont getPreciseAscent! ! !LogicalFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 6/11/2012 02:17'! glyphRendererOn: anAthensBalloonSurface ^ self realFont glyphRendererOn: anAthensBalloonSurface! ! !LogicalFont methodsFor: 'derivatives' stamp: 'tween 3/16/2007 15:44'! derivativeFont: newFont "add aFont as derivative, answer new basefont" (self isRegular and: [newFont isRegular not]) ifTrue: [ self derivativeFontsAt: newFont emphasis put: newFont. ^self]. "new font is base, copy everything over" self isRegular ifFalse: [newFont derivativeFontsAt: self emphasis put: self]. self derivativeFonts do: [:f | newFont derivativeFontsAt: f emphasis put: f]. derivatives := nil. ^newFont! ! !LogicalFont methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 9/13/2011 21:08'! findRealFont "for now just get a strike" "^((TextStyle named: StrikeFont defaultFontKey) fontOfPointSize: pointSize) emphasized: emphasis" ^LogicalFontManager current bestFontFor: self! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/29/2007 13:43'! hasDistinctGlyphsForAll: asciiString ^self realFont hasDistinctGlyphsForAll: asciiString! ! !LogicalFont methodsFor: 'testing' stamp: 'tween 9/29/2007 10:57'! isItalic ^self isItalicOrOblique! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'nice 10/29/2013 04:33'! xTable "Provided only for accelerating text scanning thru primitive 103 - see super." ^self realFont xTable! ! !LogicalFont methodsFor: '*system-settings-browser' stamp: 'alain.plantec 3/19/2009 10:02'! settingStoreOn: aStream aStream nextPut: $(. aStream nextPutAll: self class name. aStream nextPut: Character space. aStream nextPutAll: 'familyName: '. self familyName settingStoreOn: aStream. aStream nextPut: Character space. aStream nextPutAll: 'fallbackFamilyNames: '. self fallbackFamilyNames settingStoreOn: aStream. aStream nextPut: Character space. aStream nextPutAll: 'pointSize: '. self pointSize settingStoreOn: aStream. aStream nextPut: Character space. aStream nextPutAll: 'stretchValue: '. self stretchValue settingStoreOn: aStream. aStream nextPut: Character space. aStream nextPutAll: 'weightValue: '. self weightValue settingStoreOn: aStream. aStream nextPut: Character space. aStream nextPutAll: 'slantValue: '. self slantValue settingStoreOn: aStream. aStream nextPut: $)! ! !LogicalFont methodsFor: 'emphasis' stamp: 'tween 9/29/2007 12:45'! emphasized: code | validCode newWeight newSlant answer validCodeMask | "we only handle bold and italic here since underline/strikeout are drawn separately" validCodeMask := self class squeakWeightBold bitOr: self class squeakSlantItalic. validCode := code bitAnd: validCodeMask. validCode = 0 ifTrue:[^self]. (validCode anyMask: self class squeakWeightBold) ifTrue:[newWeight := self class weightBold max: weightValue] ifFalse:[newWeight := weightValue]. ((validCode anyMask: self class squeakSlantItalic) and:[self isItalicOrOblique not]) ifTrue:[newSlant := self class slantItalic] ifFalse:[newSlant := slantValue]. (weightValue = newWeight and:[slantValue = newSlant]) ifTrue:[^self]. (weightValue ~= newWeight and:[slantValue ~= newSlant]) ifTrue:[ boldItalicDerivative ifNotNil:[^boldItalicDerivative]] ifFalse:[ (weightValue ~= newWeight) ifTrue:[boldDerivative ifNotNil:[^boldDerivative]]. (slantValue ~= newSlant) ifTrue:[italicDerivative ifNotNil:[^italicDerivative]]]. answer := self class familyName: familyName fallbackFamilyNames: fallbackFamilyNames pointSize: pointSize stretchValue: stretchValue weightValue: newWeight slantValue: newSlant. (weightValue ~= newWeight and:[slantValue ~= newSlant]) ifTrue:[^boldItalicDerivative := answer]. (weightValue ~= newWeight) ifTrue:[^boldDerivative := answer]. (slantValue ~= newSlant) ifTrue:[^italicDerivative := answer]. ^answer ! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 10:49'! clearRealFont realFont := nil! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 16:25'! familyName ^familyName! ! !LogicalFont methodsFor: 'emphasis' stamp: 'tween 9/22/2007 12:41'! emphasis: code ^self emphasized: code! ! !LogicalFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 6/11/2012 02:16'! getPreciseDescent ^ self realFont getPreciseDescent! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/17/2007 00:27'! slantValue: anObject "Set the value of slantValue" slantValue := anObject! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/29/2007 14:04'! isSymbolFont ^self realFont isSymbolFont! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:02'! baseKern ^self realFont baseKern! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 13:57'! familyName: aString familyName := aString! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/27/2007 11:38'! familyNames "Answer an array containing the receiver's familyName followed by any fallbackFamilyNames" |answer| answer := {familyName}. fallbackFamilyNames ifNotNil:[ answer := answer, fallbackFamilyNames]. ^answer! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/29/2007 13:29'! hasGlyphsForAll: asciiString ^self realFont hasGlyphsForAll: asciiString! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 4/2/2007 22:12'! widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray ^self realFont widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 17:39'! familySizeFace "should have default in AbstractFont" ^{self familyName. self pointSize. self emphasis}! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 4/6/2007 12:58'! isSubPixelPositioned "Answer true if the receiver is currently using subpixel positioned glyphs, false otherwise. This affects how padded space sizes are calculated when composing text. Currently, only FreeTypeFonts are subPixelPositioned, and only when not Hinted" ^self realFont isSubPixelPositioned! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:03'! widthOf: anObject ^self realFont widthOf: anObject! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 13:38'! descent ^self realFont descent! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/28/2007 14:52'! widthOfString: aString from: startIndex to: stopIndex ^self realFont widthOfString: aString from: startIndex to: stopIndex! ! !LogicalFont methodsFor: 'testing' stamp: 'tween 9/29/2007 10:56'! isBold ^self isBoldOrBolder! ! !LogicalFont methodsFor: '*Text-Scanning' stamp: 'nice 10/29/2013 04:33'! scanByteCharactersFrom: startIndex to: stopIndex in: aByteString with: aCharacterScanner rightX: rightX "scan a single byte character string" ^self realFont scanByteCharactersFrom: startIndex to: stopIndex in: aByteString with: aCharacterScanner rightX: rightX! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 13:38'! isTTCFont ^self realFont isTTCFont! ! !LogicalFont methodsFor: 'emphasis' stamp: 'tween 9/29/2007 12:48'! emphasis "Answer the squeak emphasis code for the receiver. 1=bold, 2=italic, 3=bold-italic etc" | answer | answer := 0. self isBoldOrBolder ifTrue:[answer := answer + self class squeakWeightBold]. self isItalicOrOblique ifTrue:[answer := answer + self class squeakSlantItalic]. ^answer! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 21:47'! forceNotItalic "leave oblique style in place" slantValue = 1 ifTrue:[slantValue := 0].! ! !LogicalFont methodsFor: 'as yet unclassified' stamp: 'tween 3/16/2007 16:21'! maxAscii "??? what to do if realFont happens to be a StrikeFontSet?" ^SmallInteger maxVal! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 16:03'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta ^self realFont displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta! ! !LogicalFont methodsFor: 'testing' stamp: 'tween 3/16/2007 15:48'! isRegular ^emphasis = 0! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 17:04'! forceNotBold "anything other than bold (700) is not changed. we only remove boldness that can be put back with a TextAttribute bold." self weightValue = 700 ifTrue:[weightValue := 400].! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'MarcusDenker 7/9/2012 21:45'! fontArray | real | real := self realFont. ^real isFontSet ifTrue: [real fontArray] ifFalse: [{self}]! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:04'! installOn: a foregroundColor: b backgroundColor: c ^self realFont installOn: a foregroundColor: b backgroundColor: c! ! !LogicalFont methodsFor: 'emphasis' stamp: 'tween 3/16/2007 15:59'! emphasisString ^AbstractFont emphasisStringFor: emphasis! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/27/2007 11:19'! fallbackFamilyNames: aSequencableCollection fallbackFamilyNames := aSequencableCollection! ! !LogicalFont methodsFor: 'testing' stamp: 'tween 9/29/2007 10:47'! isItalicOrOblique slantValue ifNil:[slantValue := 0]. ^slantValue = 1 or:[slantValue = 2]! ! !LogicalFont methodsFor: 'printing' stamp: 'tween 8/18/2007 20:22'! printOn: aStream super printOn: aStream. aStream cr; nextPutAll: ' familyName: ', familyName asString;cr; nextPutAll: ' emphasis: ', emphasis asString;cr; nextPutAll: ' pointSize: ', pointSize asString;cr; nextPutAll: ' realFont: ', realFont asString; nextPutAll: ' weight: ', weightValue asString; nextPutAll: ' stretch: ', stretchValue asString; nextPutAll: ' slant: ', slantValue asString.! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 19:49'! realFont ^realFont ifNil:[realFont := self findRealFont]! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/27/2007 11:18'! fallbackFamilyNames ^fallbackFamilyNames! ! !LogicalFont methodsFor: 'derivatives' stamp: 'tween 3/16/2007 15:46'! derivativeFonts derivatives ifNil: [^ #()]. ^derivatives copyWithout: nil! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 19:46'! weightValue "Answer the value of weightValue" ^ weightValue ifNil:[weightValue := 400]! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:11'! displayString: aWideString on: aGrafPort from: aSmallInteger to: aSmallInteger4 at: aPoint kern: aSmallInteger6 baselineY: aSmallInteger7 ^self realFont displayString: aWideString on: aGrafPort from: aSmallInteger to: aSmallInteger4 at: aPoint kern: aSmallInteger6 baselineY: aSmallInteger7 ! ! !LogicalFont methodsFor: '*Text-Scanning' stamp: 'nice 10/29/2013 04:33'! scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX "scan a multibyte character string" ^self realFont scanMultibyteCharactersFrom: startIndex to: stopIndex in: aWideString with: aCharacterScanner rightX: rightX! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 16:32'! forceBold weightValue := (self weightValue max: 700).! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:02'! descentKern ^self realFont descentKern! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 19:46'! stretchValue "Answer the value of stretchValue" ^ stretchValue ifNil:[stretchValue := 5]! ! !LogicalFont methodsFor: 'derivatives' stamp: 'tween 3/16/2007 17:43'! derivativeFont: newFont mainFont: ignore self derivativeFont: newFont! ! !LogicalFont methodsFor: 'testing' stamp: 'tween 9/29/2007 10:48'! isBoldOrBolder ^(weightValue ifNil:[400]) >= 700! ! !LogicalFont methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 12/20/2012 13:36'! storeOn: aStream aStream nextPutAll: 'LogicalFont'; nextPutAll: ' familyName: '; nextPutAll: self familyName printString ; nextPutAll: ' pointSize: '; nextPutAll: self pointSize asString; nextPutAll: ' stretchValue: '; nextPutAll: self stretchValue asString; nextPutAll: ' weightValue: '; nextPutAll: self weightValue asString; nextPutAll: ' slantValue: '; nextPutAll: self slantValue asString.! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:13'! displayStrikeoutOn: aGrafPort from: aPoint to: aPoint3 ^self realFont displayStrikeoutOn: aGrafPort from: aPoint to: aPoint3 ! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/31/2007 17:13'! linearWidthOf: aCharacter ^self realFont linearWidthOf: aCharacter! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/17/2007 00:27'! weightValue: anObject "Set the value of weightValue" weightValue := anObject! ! !LogicalFont methodsFor: 'derivatives' stamp: 'tween 3/16/2007 15:44'! derivativeFontsAt: index put: aFont derivatives ifNil:[derivatives := Array new: 32]. derivatives at: index put: aFont! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'nice 10/29/2013 04:32'! characterToGlyphMap "Provided only for accelerating text scanning thru primitive 103 - see super." ^self realFont characterToGlyphMap! ! !LogicalFont methodsFor: '*system-settings-browser' stamp: 'AlainPlantec 12/18/2009 08:55'! withSizeIncrementedBy: anInteger ^ LogicalFont familyName: self familyName fallbackFamilyNames: self fallbackFamilyNames pointSize: self pointSize + anInteger stretchValue: self stretchValue weightValue: self weightValue slantValue: self slantValue ! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 4/5/2007 08:30'! characterFormAt: aCharacter ^self realFont characterFormAt: aCharacter! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 19:46'! slantValue "Answer the value of slantValue" ^ slantValue ifNil:[slantValue := 0]! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 16:07'! pointSize ^pointSize! ! !LogicalFont methodsFor: '*Athens-Text' stamp: 'IgorStasenko 11/20/2013 14:12'! asFreetypeFont ^ self realFont asFreetypeFont! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:59'! slantOblique ^2! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:42'! squeakWeightBold ^1! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! weightLight ^300! ! !LogicalFont class methodsFor: 'class initialization' stamp: 'tween 3/17/2007 10:50'! initialize " self initialize. " Smalltalk addToShutDownList: self. "should it be at a particular place in the list?"! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:51'! weightThin ^100! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:54'! stretchCompressed ^2! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:49'! weightUltraThin ^100! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! stretchSemiExpanded ^6! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! stretchSemiExtended ^6! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! stretchWide ^6! ! !LogicalFont class methodsFor: 'instance creation' stamp: 'tween 8/27/2007 11:26'! familyName: familyName pointSize: pointSize ^self familyName: familyName fallbackFamilyNames: nil pointSize: pointSize stretchValue: 5 weightValue: 400 slantValue: 0! ! !LogicalFont class methodsFor: 'instance creation' stamp: 'tween 8/27/2007 11:28'! familyName: familyName fallbackFamilyNames: fallbackFamilyNames pointSize: pointSize ^self familyName: familyName fallbackFamilyNames: fallbackFamilyNames pointSize: pointSize stretchValue: 5 weightValue: 400 slantValue: 0! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:59'! slantUpright ^0! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:42'! squeakSlantItalic ^2! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:53'! stretchUltraCompressed ^1! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:50'! weightExtraBold ^800! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:00'! slantKursiv ^1! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:56'! stretchExpanded ^7! ! !LogicalFont class methodsFor: 'shutdown' stamp: 'tween 4/3/2007 16:19'! shutDown: quitting self allSubInstances do: [:i | i clearRealFont].! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:58'! slantNormal ^0! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:51'! weightExtraBlack ^950! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:50'! weightUltraBold ^800! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:56'! stretchUltraExpanded ^9! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! weightNord ^900! ! !LogicalFont class methodsFor: 'instance creation' stamp: 'tween 8/27/2007 11:24'! familyName: familyName fallbackFamilyNames: fallbackFamilyNames pointSize: pointSize stretchValue: stretch weightValue: weight slantValue: slant "^self all asArray" "^(self all collect:[:each | each]) asArray" ^self all detect:[:each | each familyName = familyName and:[ each fallbackFamilyNames = fallbackFamilyNames and:[ each pointSize = pointSize and:[ each weightValue = weight and:[ each stretchValue = stretch and:[ each slantValue = slant]]]]]] ifNone:[ self new familyName: familyName; fallbackFamilyNames: fallbackFamilyNames; pointSize: pointSize; weightValue:weight; stretchValue: stretch; slantValue: slant; yourself]! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! weightMedium ^500! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:59'! slantBackslanted ^2! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:58'! slantRegular ^0! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:58'! slantRoman ^0! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:56'! stretchCondensed ^3! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:54'! stretchExtraCondensed ^2! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:51'! weightBold ^700! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:49'! weightExtraThin ^100! ! !LogicalFont class methodsFor: 'accessing' stamp: 'tween 8/11/2007 01:22'! all ^all ifNil:[ all := WeakSet new addAll: self allInstances; yourself]! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:59'! slantSlanted ^2! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! stretchExtraExpanded ^8! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:51'! weightUltraBlack ^950! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:54'! stretchNarrow ^4! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! weightHeavy ^900! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:57'! stretchRegular ^5! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:50'! weightUltraLight ^200! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:57'! stretchExtended ^7! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:58'! slantBook ^0! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:59'! slantInclined ^2! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:00'! slantItalic ^1! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:41'! squeakStretchCondensed ^8! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! stretchSemiCondensed ^4! ! !LogicalFont class methodsFor: 'instance creation' stamp: 'tween 8/27/2007 11:24'! familyName: familyName pointSize: pointSize stretchValue: stretch weightValue: weight slantValue: slant ^self familyName: familyName fallbackFamilyNames: nil pointSize: pointSize stretchValue: stretch weightValue: weight slantValue: slant! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! stretchExtraExtended ^8! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:49'! weightExtraLight ^200! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! stretchCompact ^4! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! weightBlack ^900! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:53'! weightUltra ^800! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:53'! stretchUltraCondensed ^1! ! !LogicalFont class methodsFor: 'instance creation' stamp: 'tween 8/11/2007 01:23'! new ^self all add: super new! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 12:00'! slantCursive ^1! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:56'! stretchUltraExtended ^9! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:57'! weightRegular ^400! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:52'! weightDemi ^600! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:50'! weightDemiBold ^600! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:50'! weightSemiBold ^600! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:53'! stretchExtraCompressed ^1! ! !LogicalFontManager commentStamp: 'LaurentLaffont 6/8/2011 22:20'! I reference all font families available in the system. For example: LogicalFontManager current allFamilies. FreeTypeFontSelectorDialogWindow new open. ! !LogicalFontManager methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:14'! addFontProvider: aFontProvider fontProviders addLast: aFontProvider ! ! !LogicalFontManager methodsFor: 'font lookup' stamp: 'tween 8/18/2007 10:42'! bestFontFor: aLogicalFont "look up best font from the receivers fontProviders" ^self bestFontFor: aLogicalFont whenFindingAlternativeIgnoreAll: Set new ! ! !LogicalFontManager methodsFor: 'font lookup' stamp: 'BenjaminVanRyseghem 11/28/2010 19:02'! bestFontFor: aLogicalFont whenFindingAlternativeIgnoreAll: ignoreSet "look up best real font from the receivers fontProviders. If we can't find a font, then answer an alternative real font. ignoreSet contains the LogicalFonts that we have already attempted to get an alternative real font from. We ignore those on each iteration so that we don't recurse forever" | textStyle font | aLogicalFont familyNames do:[:familyName | fontProviders do:[:p | | answer | (answer := p fontFor: aLogicalFont familyName: familyName) ifNotNil:[^answer]]. textStyle := TextStyle named: familyName. textStyle ifNotNil:[ font := textStyle fontOfPointSize: aLogicalFont pointSize. font ifNotNil:[^font emphasized: aLogicalFont emphasis]]]. "not found, so use the default TextStyle" textStyle := TextStyle default. textStyle ifNotNil:[ font := textStyle fontOfPointSize: aLogicalFont pointSize. (font isKindOf: LogicalFont) ifFalse:[^font emphasized: aLogicalFont emphasis]. (ignoreSet includes: font) ifFalse:[ ignoreSet add: font. "remember that we have visited font so that we don't loop forever" "try again using the default TextStyle's logicalFont" ^self bestFontFor: font whenFindingAlternativeIgnoreAll: ignoreSet]]. "Neither the family, nor any of the fallback families, is available. Any non-LogicalFont will do as a fallback" (TextSharedInformation select: [:each | each isKindOf: TextStyle]) do:[:ts | ((font := ts fontOfPointSize: aLogicalFont pointSize) isKindOf: LogicalFont) ifFalse:[^font emphasized: aLogicalFont emphasis]]. "There are no non-logical fonts in TextSharedInformation - let it fail by answering nil" ^nil ! ! !LogicalFontManager methodsFor: 'initialization' stamp: 'tween 3/14/2007 22:56'! initialize super initialize. fontProviders := OrderedCollection new: 10 ! ! !LogicalFontManager methodsFor: 'font families' stamp: 'GabrielOmarCotelli 12/3/2013 17:24'! allFamilies "answer an Array containing all the font families from the receiver's fontProviders, together with any TextStyle font families, sorted by family name" | answer textStyleFamilies | answer := Set new. fontProviders do: [ :each | answer addAll: each families ]. textStyleFamilies := TextStyle knownTextStylesWithoutDefault collect: [ :textStyleName | TextStyleAsFontFamily new textStyle: (TextStyle named: textStyleName); familyName: textStyleName; yourself ]. "reject any textStyles whose defaultFont also appears as a fontFamily" textStyleFamilies := textStyleFamilies reject: [ :textStyleFamily | | textStyleFamilyName | textStyleFamilyName := textStyleFamily textStyle defaultFont familyName. answer anySatisfy: [ :fontFamily | fontFamily familyName = textStyleFamilyName ] ]. answer addAll: textStyleFamilies. ^ (answer asSortedCollection: [ :a :b | a familyName <= b familyName ]) asArray! ! !LogicalFontManager class methodsFor: 'accessing' stamp: 'AlainPlantec 9/17/2011 16:52'! unload current ifNotNil: [current initialize]. current := nil. ! ! !LogicalFontManager class methodsFor: 'accessing' stamp: 'tween 3/17/2007 13:53'! current " current := nil. self current " ^current ifNil:[current := self defaultCurrent]! ! !LogicalFontManager class methodsFor: 'instance creation' stamp: 'tween 9/8/2007 14:45'! defaultCurrent ^self new addFontProvider: FreeTypeFontProvider current; yourself! ! !LoginFailedException commentStamp: 'mir 5/12/2003 17:57'! Exception for signaling login failures of protocol clients. ! !LoginFailedException methodsFor: 'exceptiondescription' stamp: 'mir 2/15/2002 13:10'! isResumable "Resumable so we can give the user another chance to login" ^true! ! !LongMessageDialogWindow commentStamp: 'gvc 9/23/2008 11:36'! Dialog window displaying a message with a single OK button. Escape/return will close. Icon is a themed information icon. Handles long messages through use of a text editor with potential for scrolling.! !LongMessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/15/2008 22:50'! entryText: anObject "Set the value of entryText" entryText := anObject. self changed: #entryText! ! !LongMessageDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/15/2008 22:52'! newContentMorph "Answer a new content morph." self iconMorph: self newIconMorph. self textMorph: self newTextMorph. ^self newGroupboxFor: ( (self newRow: {self iconMorph. self textMorph}) cellPositioning: #top; vResizing: #spaceFill)! ! !LongMessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/15/2008 22:11'! text: aStringOrText "Set the text." |t| t := aStringOrText isString ifTrue: [aStringOrText asText addAttribute: (TextFontReference toFont: self textFont); yourself] ifFalse: [aStringOrText]. self entryText: t! ! !LongMessageDialogWindow methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/3/2011 08:14'! isResizeable "Answer whether we are not we can be resized." ^true! ! !LongMessageDialogWindow methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 8/27/2011 01:13'! newTextMorph "Answer a new text editor morph." |tm| tm := (self newTextEditorFor: self getText: #entryText setText: #entryText: getEnabled: nil) styled: false; minWidth: Display width // 4; minHeight: Display height // 4; disable. ^tm! ! !LongMessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/15/2008 22:11'! entryText "Answer the value of entryText" ^ entryText! ! !LongTestCase commentStamp: 'DamirLaurent 5/2/2011 22:17'! I'm a TestCase which takes time to run. I can be disabled using #doNotRunLongTestCases and enabled again using #runLongTestCases. Tests that are long should be subclasses of myself. I also provide a setting for the SettingsBrowser! !LongTestCase class methodsFor: 'initialization' stamp: 'DamirLaurent 5/2/2011 21:32'! initialize self runLongTestCases! ! !LongTestCase class methodsFor: 'accessing' stamp: 'DamirLaurent 5/2/2011 21:33'! shouldRun "Return whether long tests should be run or not" RunLongTestCases ifNil: [self runLongTestCases]. ^ RunLongTestCases ! ! !LongTestCase class methodsFor: 'testing' stamp: 'md 2/22/2006 14:21'! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self name = #LongTestCase ! ! !LongTestCase class methodsFor: 'accessing' stamp: 'StephaneDucasse 10/18/2010 12:21'! shouldRun: aBoolean "Set whether long tests should be run or not" RunLongTestCases := aBoolean! ! !LongTestCase class methodsFor: 'settings' stamp: 'DamirLaurent 5/2/2011 21:59'! runLongTestsSettingOn: aBuilder (aBuilder setting: #shouldRun) target: self; parent: #pharoSystem; label: 'Run Long Tests' translated; description: 'Whether to run long SUnit TestCase. Tests which take long time to run should be subclasses of LongTestCase.' translated.! ! !LongTestCase class methodsFor: 'accessing' stamp: 'StephaneDucasse 10/18/2010 14:02'! allTestSelectors self shouldRun ifTrue: [ ^super testSelectors]. ^#().! ! !LongTestCase class methodsFor: 'accessing' stamp: 'StephaneDucasse 10/18/2010 12:21'! doNotRunLongTestCases "Tells the system that long tests should not be run" self shouldRun: false! ! !LongTestCase class methodsFor: 'instance creation' stamp: 'StephaneDucasse 10/18/2010 14:02'! buildSuite | suite | suite := self suiteClass new. self shouldRun ifTrue: [ self addToSuiteFromSelectors: suite]. ^suite! ! !LongTestCase class methodsFor: 'accessing' stamp: 'StephaneDucasse 10/18/2010 12:21'! runLongTestCases "Tell the system that long tests should be run" self shouldRun: true.! ! !LongTestCaseTest methodsFor: 'setup' stamp: 'StephaneDucasse 10/18/2010 12:19'! setUp longTestCaseSettingValue := LongTestCase shouldRun! ! !LongTestCaseTest methodsFor: 'testing' stamp: 'md 12/5/2004 21:28'! testLongTestCaseRun "self debug: #testLongTestCaseRun" "self run: #testLongTestCaseRun" LongTestCase runLongTestCases. LongTestCaseTestUnderTest markAsNotRun. self deny: LongTestCaseTestUnderTest hasRun. LongTestCaseTestUnderTest suite run. self assert: LongTestCaseTestUnderTest hasRun. LongTestCase doNotRunLongTestCases. ! ! !LongTestCaseTest methodsFor: 'testing' stamp: 'StephaneDucasse 10/18/2010 14:02'! testLongTestCaseDoNotRun "self debug: #testLongTestCaseDoNotRun" "self run: #testLongTestCaseDoNotRun" LongTestCase doNotRunLongTestCases. LongTestCaseTestUnderTest markAsNotRun. self deny: LongTestCaseTestUnderTest hasRun. LongTestCaseTestUnderTest suite run. self deny: LongTestCaseTestUnderTest hasRun. ! ! !LongTestCaseTest methodsFor: 'setup' stamp: 'StephaneDucasse 10/18/2010 12:20'! tearDown LongTestCase shouldRun: longTestCaseSettingValue! ! !LongTestCaseTestUnderTest methodsFor: 'testing' stamp: 'md 11/14/2004 21:30'! testWhenRunMarkTestedToTrue RunStatus := true.! ! !LongTestCaseTestUnderTest class methodsFor: 'accessing' stamp: 'md 11/14/2004 21:37'! markAsNotRun ^ RunStatus := false! ! !LongTestCaseTestUnderTest class methodsFor: 'accessing' stamp: 'sd 9/25/2004 14:02'! hasRun ^ RunStatus! ! !LookupKey commentStamp: ''! I represent a key for looking up entries in a data structure. Subclasses of me, such as Association, typically represent dictionary entries.! !LookupKey methodsFor: 'accessing' stamp: ''! key: anObject "Store the argument, anObject, as the lookup key of the receiver." key := anObject! ! !LookupKey methodsFor: 'comparing' stamp: ''! hash "Hash is reimplemented because = is implemented." ^key hash! ! !LookupKey methodsFor: 'comparing' stamp: ''! = aLookupKey self species = aLookupKey species ifTrue: [^key = aLookupKey key] ifFalse: [^false]! ! !LookupKey methodsFor: 'testing' stamp: 'ar 8/14/2001 22:39'! isVariableBinding "Return true if I represent a literal variable binding" ^true! ! !LookupKey methodsFor: 'accessing' stamp: 'ajh 9/12/2002 12:04'! canAssign ^ true! ! !LookupKey methodsFor: 'printing' stamp: ''! printOn: aStream key printOn: aStream! ! !LookupKey methodsFor: 'testing' stamp: 'ar 8/14/2003 01:52'! isSpecialReadBinding "Return true if this variable binding is read protected, e.g., should not be accessed primitively but rather by sending #value messages" ^false! ! !LookupKey methodsFor: 'comparing' stamp: ''! < aLookupKey "Refer to the comment in Magnitude|<." ^key < aLookupKey key! ! !LookupKey methodsFor: 'accessing' stamp: ''! key "Answer the lookup key of the receiver." ^key! ! !LookupKey methodsFor: 'accessing' stamp: 'ajh 3/24/2003 21:14'! name ^ self key isString ifTrue: [self key] ifFalse: [self key printString]! ! !LookupKey class methodsFor: 'instance creation' stamp: 'md 6/29/2005 16:34'! key: aKey "Answer an instance of me with the argument as the lookup up." ^self basicNew key: aKey! ! !MBAbstractInfoList commentStamp: ''! A MBAbstractInfoList is an abstraction used to hold information on groups, packages and projects. Instance Variables groups: a list of groups (MBGroupInfo instances) infoList: packages: projects: ! !MBAbstractInfoList methodsFor: 'accessing-computed' stamp: 'ChristopheDemarey 8/28/2012 14:31'! projects "Return the list of dependent packages for the last baseline" | projectSpecs | projects ifNotNil: [ ^ projects ]. projects := OrderedCollection new. self versionForInfoList ifNil: [ ^ projects ]. projectSpecs := self versionForInfoList projects. projectSpecs := projectSpecs asSortedCollection: [ :a :b | a name <= b name ]. projects addAll: (projectSpecs collect: [ :prjSpec | (MBProjectInfo named: prjSpec name packageName: prjSpec projectPackage name spec: prjSpec) configurationInfo: self configurationInfo; yourself ]). ^ projects! ! !MBAbstractInfoList methodsFor: 'updating' stamp: 'dkh 03/14/2011 07:17'! fullRecalculate self recalculate! ! !MBAbstractInfoList methodsFor: 'private' stamp: 'dkh 3/2/2011 20:03'! calculateInfoList ^self subclassResponsibility ! ! !MBAbstractInfoList methodsFor: 'updating' stamp: 'dkh 4/12/2011 10:54'! interestedInPackage: operation "potential currentVersion change" self fullRecalculate. ^true! ! !MBAbstractInfoList methodsFor: 'updating' stamp: 'dkh 3/2/2011 20:14'! interestedInPackageNamed: packageName packages notNil ifTrue: [ (self packages detect: [ :info | info interestedInPackageNamed: packageName ] ifNone: [ ]) notNil ifTrue: [ ^ true ] ]. ^ false! ! !MBAbstractInfoList methodsFor: 'updating' stamp: 'dkh 3/10/2011 18:30'! recalculate text := groups := validationResult := validationIcon := projects:= packages := nil. infoList == nil ifTrue: [ ^self ]. self announcer announce: (MBInfoListChanged changed: self). infoList := nil! ! !MBAbstractInfoList methodsFor: 'accessing-computed' stamp: 'AlexandreBergel 8/2/2011 16:37'! packages "Return the list of dependent packages for the last baseline" | packageSpecs | packages ~~ nil ifTrue: [ ^ packages ]. self versionForInfoList ifNil: [ ^ #() ]. packages := OrderedCollection new. packageSpecs := self versionForInfoList packages. packageSpecs := packageSpecs asSortedCollection: [ :a :b | a name <= b name ]. packages addAll: (packageSpecs collect: [ :pkgSpec | | packageName | (packageName := pkgSpec getFile) ifNil: [ packageName := pkgSpec name asString ]. (MBPackageInfo named: packageName packageName: pkgSpec name asString spec: pkgSpec) configurationInfo: self configurationInfo; yourself ]). ^ packages! ! !MBAbstractInfoList methodsFor: 'accessing-computed' stamp: 'AlexandreBergel 1/17/2012 17:34'! infos "Return the list of info that are displayed" ^self infoList! ! !MBAbstractInfoList methodsFor: 'updating' stamp: 'dkh 4/12/2011 10:46'! recalculateIfInterestedInPackageNamed: packageName for: operation "keep projects separate, since I'm the only one interested in projects." (self interestedInPackageNamed: packageName) ifTrue: [ ^self interestedInPackage: operation ]. projects notNil ifTrue: [ (self projects detect: [ :info | info interestedInPackageNamed: packageName ] ifNone: [ ]) notNil ifTrue: [ ^self interestedInPackage: operation ] ]. ^false! ! !MBAbstractInfoList methodsFor: 'accessing-computed' stamp: 'dkh 3/2/2011 20:29'! versionForInfoList ^self subclassResponsibility ! ! !MBAbstractInfoList methodsFor: 'accessing-computed' stamp: 'dkh 3/10/2011 16:00'! infoList infoList ~~ nil ifTrue: [ ^infoList ]. ^ infoList := self calculateInfoList! ! !MBAbstractInfoList methodsFor: 'testing' stamp: 'dkh 3/9/2011 22:15'! isDirty ^ self packages anySatisfy: [:each | each isDirty ]! ! !MBAbstractInfoList methodsFor: 'accessing-computed' stamp: 'dkh 3/6/2011 15:34'! groups "Return the list of groups for the configuration" | groupSpecs | groups ~~ nil ifTrue: [ ^ groups ]. groups := OrderedCollection new. self versionForInfoList ifNil: [ ^ groups ]. groupSpecs := self versionForInfoList groups. groupSpecs := groupSpecs asSortedCollection: [ :a :b | a name <= b name ]. groups addAll: (groupSpecs collect: [ :grpSpec | (MBGroupInfo spec: grpSpec) configurationInfo: self configurationInfo; yourself ]). ^ groups! ! !MBAbstractInfoList methodsFor: 'initialize-release' stamp: 'dkh 3/6/2011 18:38'! release | baselines versions | super release. packages := projects := groups := infoList := nil.! ! !MBAbstractPackageCommand commentStamp: ''! For grouping package commands! !MBAbstractPackageInfo commentStamp: ''! A MBAbstractPackageInfo is an abstraction to represent both project and packages. Instance Variables packageName: name of the package workingCopy: a MCWorkingCopy representing the version of the package in memory ! !MBAbstractPackageInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 9/17/2013 15:32'! cmdOpenRepositoryCommand ^ VSOpenRepositoryCommand! ! !MBAbstractPackageInfo methodsFor: 'accessing' stamp: 'AlexandreBergel 3/5/2011 22:57'! classForBrowsing self subclassResponsibility ! ! !MBAbstractPackageInfo methodsFor: 'commands' stamp: 'dkh 3/4/2011 05:00'! cmdBrowse ^ MBBrowsePackageCommand! ! !MBAbstractPackageInfo methodsFor: 'accessing' stamp: 'dkh 2/23/2011 19:02'! packageName ^packageName! ! !MBAbstractPackageInfo methodsFor: 'commands' stamp: 'dkh 3/20/2011 10:36'! cmdBrowsePackageChanges ^ MBPackageChangesCommand ! ! !MBAbstractPackageInfo methodsFor: 'accessing' stamp: 'dkh 2/27/2011 15:37'! workingCopy | pkg | workingCopy ~~ nil ifTrue: [ ^workingCopy ]. pkg := MCPackage named: self packageName. pkg hasWorkingCopy ifFalse: [ ^nil ]. ^workingCopy := pkg workingCopy! ! !MBAbstractPackageInfo methodsFor: 'accessing' stamp: 'dkh 2/23/2011 19:02'! packageName: aString packageName := aString! ! !MBAbstractPackageInfo methodsFor: 'testing' stamp: 'DaleHenrichs 2/23/2011 17:29'! isDirty | wc | wc := self workingCopy. wc ifNil: [ ^false ]. ^wc needsSaving! ! !MBAbstractPackageInfo class methodsFor: 'instance creation' stamp: 'AlexandreBergel 3/5/2011 21:57'! named: infoName packageName: packageName spec: aMetacelloSpec "Create an instance of myself named infoName for the package named packageName" | answer | self assert: [ packageName isString ]. self assert: [ packageName isSymbol not ]. answer := super new. answer name: infoName. answer packageName: packageName. answer spec: aMetacelloSpec. ^ answer! ! !MBAbstractPackageInfo class methodsFor: 'instance creation' stamp: 'AlexandreBergel 1/16/2011 01:05'! new self error: 'Please, use #named: to create an instance'! ! !MBAbstractPackageInfo class methodsFor: 'instance creation' stamp: 'dkh 2/27/2011 15:32'! named: infoName ^self named: infoName packageName: infoName spec: nil! ! !MBAbstractTest commentStamp: 'TorstenBergmann 2/20/2014 14:13'! Common superclass for test for Versionner! !MBAbstractTest methodsFor: 'accessing' stamp: 'dkh 2/23/2011 15:19'! configurationName ^'ConfigurationOfDummyConfiguration'! ! !MBAbstractTest methodsFor: 'util' stamp: 'dkh 2/23/2011 15:17'! removeClassIfExist: aSymbol Smalltalk globals at: aSymbol ifPresent: [ :cls | cls removeFromSystem ]! ! !MBAbstractTest methodsFor: 'running' stamp: 'dkh 2/23/2011 15:24'! tearDown super tearDown. configuration := nil. self removeClassIfExist: self configurationName asSymbol ! ! !MBAbstractTest methodsFor: 'running' stamp: 'dkh 2/23/2011 21:17'! setUp (Smalltalk globals includesKey: self configurationName asSymbol) ifFalse: [ MetacelloToolBox configurationNamed: self configurationName. (Smalltalk globals at: self configurationName asSymbol) compile: 'baseline10: spec spec for: #common do: [ spec blessing: #baseline. spec repository: ''http://www.squeaksource.com/Versionner''. spec package: ''Collections-Streams''. ].'. (Smalltalk globals at: self configurationName asSymbol) compile: 'default: spec spec for: #common do: [ spec blessing: #baseline. spec repository: ''http://www.squeaksource.com/Versionner''. spec package: ''Collections-Streams''. ].'. ]. configuration := (Smalltalk globals at: self configurationName asSymbol) ! ! !MBAbstractTest class methodsFor: 'testing' stamp: 'topa 4/15/2011 09:50'! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^ self name = #MBAbstractTest! ! !MBAbstractVersionInfo commentStamp: 'TorstenBergmann 2/20/2014 14:12'! Abstract info for a version in Versionner! !MBAbstractVersionInfo methodsFor: 'accessing' stamp: 'dkh 3/5/2011 17:56'! currentVersion ^self configurationInfo currentVersion! ! !MBAbstractVersionInfo methodsFor: 'testing' stamp: 'dkh 3/1/2011 21:08'! hasValidationIssues validationResult == nil ifTrue: [ ^false ]. ^validationResult notEmpty! ! !MBAbstractVersionInfo methodsFor: 'private' stamp: 'ChristopheDemarey 11/13/2013 13:33'! calculateInfoList | answer list cvs cv | answer := OrderedCollection new. cvs := ''. (cv := self versionForInfoList) ifNil: [cvs := cv versionString, ' ']. (list := self projects) ifNotEmpty: [ answer add: (MBLabelInfo new name: ' -- ', cvs, 'projects --'). answer addAll: list. answer add: (MBLabelInfo new name: '') ]. (list := self packages) ifNotEmpty: [ answer add: (MBLabelInfo new name: ' -- ', cvs, 'packages --'). answer addAll: list. answer add: (MBLabelInfo new name: '') ]. (list := self groups) ifNotEmpty: [ answer add: (MBLabelInfo new name: ' -- ', cvs, 'groups --'). answer addAll: list ]. ^ answer! ! !MBAbstractVersionInfo methodsFor: 'accessing' stamp: 'dkh 3/5/2011 17:50'! configurationInfo ^ configurationInfo! ! !MBAbstractVersionInfo methodsFor: 'accessing' stamp: 'dkh 3/2/2011 16:44'! validate validationResult == nil ifTrue: [ validationIcon := nil. validationResult := MetacelloToolBox validateProject: self project version: self version versionString ]. ^ validationResult! ! !MBAbstractVersionInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 10/24/2013 17:57'! cmdRemove ^ VSRemoveCommand! ! !MBAbstractVersionInfo methodsFor: 'accessing' stamp: 'ChristopheDemarey 2/11/2014 15:54'! configurationBasename ^ self configurationClass name configurationBaseName! ! !MBAbstractVersionInfo methodsFor: 'accessing' stamp: 'dkh 3/2/2011 16:42'! project "Answer the MetacelloProject associated with the receiver." ^self version project! ! !MBAbstractVersionInfo methodsFor: 'accessing' stamp: 'dkh 2/23/2011 12:57'! version ^ version! ! !MBAbstractVersionInfo methodsFor: 'testing' stamp: 'dkh 3/2/2011 16:43'! isStable ^ (self project hasVersion: #stable) and: [ (self project version: #stable) = self version ]! ! !MBAbstractVersionInfo methodsFor: 'testing' stamp: 'dkh 3/2/2011 16:43'! isBleedingEdge ^ (self project hasVersion: #bleedingEdge) and: [ (self project version: #bleedingEdge) = self version ]! ! !MBAbstractVersionInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 10/24/2013 17:57'! cmdLoad ^ VSLoadCommand! ! !MBAbstractVersionInfo methodsFor: 'accessing' stamp: 'dkh 3/5/2011 17:55'! configurationClass ^ self configurationInfo configurationClass! ! !MBAbstractVersionInfo methodsFor: 'accessing' stamp: 'dkh 3/19/2011 10:42'! versionString ^ self version versionString! ! !MBAbstractVersionInfo methodsFor: 'accessing-computed' stamp: 'dkh 3/2/2011 20:29'! versionForInfoList ^self version ! ! !MBAbstractVersionInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 10/24/2013 17:49'! cmdBrowse ^ VSBrowseVersionCommand! ! !MBAbstractVersionInfo methodsFor: 'accessing' stamp: 'dkh 3/5/2011 17:50'! configurationInfo: anObject configurationInfo := anObject! ! !MBAbstractVersionInfo methodsFor: 'testing' stamp: 'dkh 3/2/2011 16:44'! isDevelopment ^ (self project hasVersion: #development) and: [ (self project version: #development) = self version ]! ! !MBAbstractVersionInfo methodsFor: 'testing' stamp: 'JuanPabloSandovalAlcocer 1/8/2012 18:10'! isCurrentVersion |cv| (cv := self currentVersion) ~~ nil ifTrue: [ cv = self version ifTrue: [^ true]]. ^false.! ! !MBAbstractVersionInfo methodsFor: 'printing' stamp: 'dkh 3/6/2011 15:15'! printOn: aStream | cv | (cv := self currentVersion) ~~ nil ifTrue: [ cv = self version ifTrue: [ aStream nextPutAll: ' @ ' ] ]. super printOn: aStream. ! ! !MBAbstractVersionInfo methodsFor: 'accessing' stamp: 'dkh 2/23/2011 14:13'! version: aMetacelloVersion version := aMetacelloVersion. self name: aMetacelloVersion versionString. ! ! !MBAbstractVersionInfo class methodsFor: 'instance creation' stamp: 'dkh 3/6/2011 15:32'! version: aMetacelloVersion ^ super new version: aMetacelloVersion; yourself! ! !MBAbstractVersionInfo class methodsFor: 'instance creation' stamp: 'AlexandreBergel 3/1/2011 08:49'! new self error: 'Please use version:browser: or version: instead'! ! !MBAbstractVersionInfoTest commentStamp: 'TorstenBergmann 2/20/2014 14:20'! Abstract superclass for version info tests for Versionner! !MBAbstractVersionInfoTest class methodsFor: 'testing' stamp: 'topa 4/15/2011 14:58'! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^ self name = #MBAbstractVersionInfoTest! ! !MBAddConfigurationCommand commentStamp: 'TorstenBergmann 2/20/2014 14:09'! Command to add a configuration in Versionner! !MBAddConfigurationCommand methodsFor: 'private' stamp: 'dkh 3/4/2011 16:21'! workingCopies ^ MCWorkingCopy allManagers asSortedCollection: [ :a :b | a name <= b name]! ! !MBAddConfigurationCommand methodsFor: 'private' stamp: 'ChristopheDemarey 10/18/2012 11:01'! collectPackages: addedPackages andProjects: addedConfigurations pattern: patternString repository: repository | packagePattern package | packagePattern := self uiManager request: 'Please enter a pattern to filter package names that will be candidates to add to configuration' initialAnswer: patternString. packagePattern ifNil: [ ^ self ]. [ | packageNames workingCopies | packageNames := OrderedCollection new. workingCopies := OrderedCollection new. self workingCopies do: [ :pkg | ((packagePattern match: pkg package name) and: [ (addedPackages includes: pkg package name) not ]) ifTrue: [ packageNames add: pkg package name. workingCopies add: pkg ] ]. package := self uiManager chooseFrom: packageNames values: workingCopies title: 'Add dependent package (cancel to stop)'. package ifNotNil: [ (package package name beginsWith: 'ConfigurationOf') ifTrue: [ addedConfigurations add: package package name ] ifFalse: [ addedPackages add: package package name ]. package ancestry ancestors isEmpty ifTrue: [ (self uiManager confirm: 'The package: ' , package package name printString , ' has not been committed yet. Would you like to commit it into the ' , repository description printString, ' repository?') ifTrue: [ package repositoryGroup repositories size <= 1 ifTrue: [ package repositoryGroup addRepository: repository ]. package currentVersionInfo ] ] ]. package notNil ] whileTrue. (addedPackages isEmpty and: [ addedConfigurations isEmpty ]) ifTrue: [ self uiManager inform: 'No package or configuration added. No baseline has been created' ]! ! !MBAddConfigurationCommand methodsFor: 'private' stamp: 'ChristopheDemarey 10/18/2012 11:32'! repositoryFor: projectName | repositories repository | repositories := self repositories select: [ :repo | (repo description beginsWith: 'http:') and: [ repo description endsWith: projectName ] ]. repository := nil. (repositories anySatisfy: [ :http | http description = ('http://www.squeaksource.com/' , projectName) ]) ifFalse: [ (self uiManager confirm: 'Would you like to use http://www.squeaksource.com/' , projectName , ', for your project?') ifTrue: [ ^ MCHttpRepository location: 'http://www.squeaksource.com/' , projectName user: '' password: '' ] ]. repository isNil ifTrue: [ repository := repositories isEmpty ifTrue: [ self chooseRepositoryFromList: self repositories ] ifFalse: [ self chooseRepositoryFromList: repositories , self repositories ] ]. ^ repository! ! !MBAddConfigurationCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/18/2012 11:00'! askForClassName ^ self uiManager request: 'Name of the new Metacello configuration (e.g., ConfigurationOfYourSoftware)' translated initialAnswer: 'ConfigurationOf'! ! !MBAddConfigurationCommand methodsFor: 'documentation' stamp: 'dkh 3/4/2011 16:25'! documentation ^ 'Create a new configuration. Prompt for packages and dependent projects. Create a baseline version and an initial development version'! ! !MBAddConfigurationCommand methodsFor: 'accessing' stamp: 'dkh 4/7/2011 21:52'! title ^ 'add configuration'! ! !MBAddConfigurationCommand methodsFor: 'execute' stamp: 'TesterBob 10/11/2012 17:09'! executeAddBaselineForConfigurationNamed: aConfigurationClassName repositoryDescription: repositoryDescription versionString: versionString packages: packageNames configurations: configurationNames | baselineVersionString | baselineVersionString := versionString , '-baseline'. MetacelloToolBox createBaseline: baselineVersionString for: aConfigurationClassName repository: repositoryDescription requiredProjects: configurationNames packages: packageNames repositories: { aConfigurationClassName, repositoryDescription } dependencies: {} groups: {('default' -> packageNames)}; createDevelopment: versionString for: aConfigurationClassName importFromBaseline: baselineVersionString description: ''! ! !MBAddConfigurationCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 2/11/2014 15:55'! execute | configurationClassName versionNumber addedPackages addedConfigurations repository projectName mcPackage workingCopy configInfo| configurationClassName := self askForClassName. configurationClassName ifNil: [ ^ self ]. Smalltalk globals at: configurationClassName asSymbol ifPresent: [ :ex | ^ self error: 'Class ' , configurationClassName printString , ' already exist' ]. projectName := configurationClassName name configurationBaseName. (repository := self repositoryFor: projectName) ifNil: [ ^ self ]. versionNumber := self uiManager request: 'Enter initial version number' initialAnswer: '1.0'. versionNumber ifNil: [ ^ self ]. addedPackages := OrderedCollection new. addedConfigurations := OrderedCollection new. self collectPackages: addedPackages andProjects: addedConfigurations pattern: projectName , '*' repository: repository. self executeAddBaselineForConfigurationNamed: configurationClassName repositoryDescription: repository description versionString: versionNumber packages: addedPackages configurations: addedConfigurations. mcPackage := MCPackage named: configurationClassName. workingCopy := mcPackage workingCopy. workingCopy repositoryGroup addRepository: repository. "after all save configuration" configInfo := (MBConfigurationInfo configurationClass: (Smalltalk globals at: (configurationClassName asSymbol))) configurationRoot: (MBConfigurationRoot current); yourself. "fixing" (MBSaveConfigurationCommand target: configInfo for: requestor) executeWithMessage: 'Creating ConfigurationOf', projectName. ! ! !MBAddConfigurationCommand methodsFor: 'ordering' stamp: 'dkh 4/7/2011 22:20'! order ^'20'! ! !MBAddConfigurationCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/11/2012 17:21'! executeAddBaselineForConfigurationNamed: aConfigurationClassName repositoryDescription: repositoryDescription versionString: versionString packages: packageNames configurations: configurationNames repositories: repositories | baselineVersionString | baselineVersionString := versionString , '-baseline'. MetacelloToolBox createBaseline: baselineVersionString for: aConfigurationClassName repository: repositoryDescription requiredProjects: configurationNames packages: packageNames repositories: repositories dependencies: {} groups: {('default' -> packageNames)}; createDevelopment: versionString for: aConfigurationClassName importFromBaseline: baselineVersionString description: ''! ! !MBAddConfigurationCommandTest methodsFor: 'as yet unclassified' stamp: 'AlexandreBergel 3/27/2011 23:36'! testExecute | t v | t := false. command := MBAddConfigurationCommand target: self for: nil. [[command execute] valueSupplyingAnswer: self configurationName ] on: Error do: [:ex | t := ex messageText = 'Class #ConfigurationOfMetacello_Command_Tests already exist' ]. self assert: t. v := 10000 atRandom. self should: [[command execute] valueSupplyingAnswers: {{'Name of the new Metacello configuration (e.g., ConfigurationOfYourSoftware)' . self configurationName, v asString } . {'Enter initial version number' . '1.0'} ". {'Would you like to use http://www.squeaksource.com/Metacello_Command_Tests2, for your project?' . true}" }] raise: Exception. self deny: (Smalltalk globals includesKey: (self configurationName, v asString) asSymbol ). ! ! !MBAddRepositoryCommand commentStamp: 'TorstenBergmann 2/20/2014 14:09'! Command to add a repository in Versionner! !MBAddRepositoryCommand methodsFor: 'documentation' stamp: 'dkh 4/8/2011 11:44'! documentation ^ 'Add a Monticello repository to the default repository group.'! ! !MBAddRepositoryCommand methodsFor: 'accessing' stamp: 'dkh 4/8/2011 11:45'! title ^ 'add repository'! ! !MBAddRepositoryCommand methodsFor: 'as yet unclassified' stamp: 'ChristopheDemarey 10/19/2012 11:20'! newRepository "Create a new monticello repository" | types index | types := MCRepository allConcreteSubclasses asArray. index := self uiManager chooseFrom: (types collect: [:ea | ea description]) title: 'Repository type:'. ^ index = 0 ifFalse: [(types at: index) perform: #morphicConfigure]! ! !MBAddRepositoryCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/19/2012 11:21'! execute self newRepository ifNotNil: [:repos | MCRepositoryGroup default addRepository: repos ]. ! ! !MBAnnouncement commentStamp: 'TorstenBergmann 2/20/2014 14:04'! Common superclass for Versionner announcements! !MBAnnouncement methodsFor: 'accessing' stamp: 'dkh 03/12/2011 02:09'! configurationInfo ^nil! ! !MBBaselineInfo commentStamp: ''! A MBBaselineInfo holds information on a baselinf of a configuration. ! !MBBaselineInfo methodsFor: 'printing' stamp: 'DaleHenrichs 2/24/2011 18:23'! printOn: aStream super printOn: aStream. self isBleedingEdge ifTrue: [ aStream nextPutAll: ' #bleedingEdge' ].! ! !MBBaselineInfo methodsFor: 'commands' stamp: 'dkh 3/4/2011 04:59'! cmdCopyBaseline ^ MBCopyBaselineCommand! ! !MBBaselineInfo class methodsFor: 'accessing' stamp: 'dkh 4/10/2011 19:56'! helpLabel ^'Baseline'! ! !MBBaselineInfoTest commentStamp: 'TorstenBergmann 2/20/2014 14:19'! SUnit tests for MBBaselineInfo in Versionner! !MBBaselineInfoTest methodsFor: 'tests' stamp: 'DaleHenrichs 03/08/2011 13:49'! testCopyBaseline | configurationInfo baselineInfo | configurationInfo := MBConfigurationInfo configurationClass: configuration. baselineInfo := configurationInfo baselines detect: [:inf | inf version versionString = '1.0-baseline']. self assert: (baselineInfo isKindOf: MBBaselineInfo). [ (MBCopyBaselineCommand target: baselineInfo for: browser) copyBaselineWithNumber: '1.1'] valueSupplyingAnswer: 'this is my comment'. self assert: (configuration compiledMethodAt: #baseline11: ifAbsent: []) notNil. self assert: (configuration sourceCodeAt: #baseline11:) = 'baseline11: spec spec for: #''common'' do: [ spec blessing: #''baseline''. spec description: ''this is my comment''. spec repository: ''http://www.squeaksource.com/Versionner''. spec package: ''Collections-Streams''. ]. '! ! !MBBaselineInfoTest methodsFor: 'running' stamp: 'dkh 4/18/2011 20:22'! expectedFailures true ifTrue: [ ^#() ]. ^ #(#testcalculateInfoList)! ! !MBBaselineInfoTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/31/2012 17:45'! testcalculateInfoList "Doesn't work!! Need to use a real configuration with all information " "info := (MBBaselineInfo version: (MBVersionInfo version: (MetacelloMCVersion fromString: '1.0-baseline'))) configurationInfo: (MBConfigurationInfo configurationClass: configuration). info calculateInfoList"! ! !MBBaselineInfoTest methodsFor: 'tests' stamp: 'dkh 3/19/2011 10:42'! testInstantiation | configurationInfo baseline | self should: [ MBBaselineInfo new ] raise: Error. self shouldnt: [ configurationInfo := MBConfigurationInfo configurationClass: configuration. baseline := configurationInfo baselines detect: [:inf | inf version versionString = '1.0-baseline']. ] raise: Error. self assert: (baseline versionString = '1.0-baseline'). self assert: (info configurationInfo configurationClass == (Smalltalk at: #ConfigurationOfDummyConfiguration))! ! !MBBaselineInfoTest methodsFor: 'running' stamp: 'dkh 3/6/2011 20:33'! setUp | configurationInfo | super setUp. configurationInfo := MBConfigurationInfo configurationClass: configuration. info := configurationInfo baselines detect: [:inf | inf version versionString = '1.0-baseline'] ! ! !MBBrowsePackageCommand commentStamp: 'TorstenBergmann 2/20/2014 14:05'! Command to browse a package in versionner! !MBBrowsePackageCommand methodsFor: 'accessing' stamp: 'dkh 3/2/2011 14:05'! title ^ 'browse'! ! !MBBrowsePackageCommand methodsFor: 'documentation' stamp: 'dkh 3/2/2011 14:05'! documentation ^ 'Open a system browser on the selected project configuration or package.'! ! !MBBrowsePackageCommand methodsFor: 'execute' stamp: 'dkh 3/2/2011 14:07'! execute target classForBrowsing browse! ! !MBCheckpointDevCommand commentStamp: 'TorstenBergmann 2/20/2014 14:10'! Command for a check point in Versionner! !MBCheckpointDevCommand methodsFor: 'execute' stamp: 'AlexandreBergel 4/15/2011 10:22'! executeWithMessage: message | configClass | configClass := self configurationClass. self checkUserInRepositoryOfPackage: configClass name asString. MetacelloToolBox saveModifiedPackagesAndConfigurationIn: configClass description: message. ! ! !MBCheckpointDevCommand methodsFor: 'documentation' stamp: 'dkh 3/5/2011 13:45'! documentation ^ 'Save modified packages in their respective repository, update the configuration and save a version of the configuration in it''s repository.'! ! !MBCheckpointDevCommand methodsFor: 'ordering' stamp: 'dkh 4/7/2011 22:20'! order ^'50'! ! !MBCheckpointDevCommand methodsFor: 'accessing' stamp: 'dkh 3/5/2011 13:44'! title ^ 'checkpoint dev'! ! !MBCheckpointDevCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 2/11/2014 15:55'! execute | message configClass | configClass := self configurationClass. message := self uiManager multilineRequest: 'Enter commit message for ' , (configClass name configurationBaseName) , ' ' , (target project version: #development) versionString initialAnswer: (target project version: #development) versionString, ' ():'. message == nil ifTrue: [ ^ self ]. self executeWithMessage: message ! ! !MBCommand commentStamp: ''! MBCommand is a command design pattern for capturing actions.! !MBCommand methodsFor: 'versions' stamp: 'ChristopheDemarey 11/6/2012 16:15'! compiledMethodForVersion: aMetacelloVersion | toolbox pragma | toolbox := MetacelloToolBox new project: aMetacelloVersion project. pragma := (toolbox constructor extractAllVersionPragmas at: aMetacelloVersion versionString ifAbsent: [ ^ nil ]) first. ^pragma method! ! !MBCommand methodsFor: 'accessing' stamp: 'dkh 3/4/2011 06:16'! targetNode ^ targetNode! ! !MBCommand methodsFor: 'changes' stamp: 'ChristopheDemarey 10/19/2012 11:06'! findChangesBetween: versionSnapshot toLabel: toLabel and: ancestorVersionSnapshot fromLabel: fromLabel "View changes between 2 versions." | patch | patch := versionSnapshot patchRelativeToBase: ancestorVersionSnapshot. patch isNil ifTrue: [^ self]. patch isEmpty ifTrue: [ self uiManager inform: 'No changes' ] ifFalse: [ self viewChanges: patch from: fromLabel to: toLabel title: 'Changes between ', fromLabel, ' and ', toLabel ]! ! !MBCommand methodsFor: 'repositories' stamp: 'DaleHenrichs 03/07/2011 15:59'! checkUserInRepositoryOfPackage: packageName "Try to find the http repository of packageName. If it does not find one, then add one and ask for the username and password" | repo | (repo := self repositoryOfPackageNamed: packageName) ifNil: [ ^nil ]. self checkUserInRepository: repo. ^repo! ! !MBCommand methodsFor: 'repositories' stamp: 'dkh 4/17/2011 13:11'! configurationReferencesFrom: aRepository | map | map := Dictionary new. aRepository goferReferences do: [ :ref | (ref packageName beginsWith: 'ConfigurationOf') ifTrue: [ | nameWithBranch | nameWithBranch := ref metacelloPackageNameWithBranch at: 2. (map at: nameWithBranch ifAbsent: [map at: nameWithBranch put: OrderedCollection new]) add: ref ]]. ^map! ! !MBCommand methodsFor: 'initialize-release' stamp: 'ChristopheDemarey 11/13/2013 13:22'! initialize super initialize. ! ! !MBCommand methodsFor: 'repositories' stamp: 'dkh 3/5/2011 15:57'! repositories ^MCRepositoryGroup default repositories! ! !MBCommand methodsFor: 'accessing' stamp: 'ChristopheDemarey 10/18/2012 10:46'! title ^ 'Abstract Command'! ! !MBCommand methodsFor: 'versions' stamp: 'ChristopheDemarey 10/18/2012 17:38'! browseVersionHistory "Used to browse version history of a Configuration package or a package" target workingCopy ancestors isEmpty ifTrue: [ ^ self ]. (MCVersionHistoryBrowser new ancestry: target workingCopy ancestors first) perform: #show! ! !MBCommand methodsFor: 'utility' stamp: 'dkh 3/4/2011 05:21'! on: anObject for: aRequestor ^ self class on: anObject for: aRequestor! ! !MBCommand methodsFor: 'documentation' stamp: 'dkh 4/10/2011 19:14'! helpDocumentation ^self documentation! ! !MBCommand methodsFor: 'changes' stamp: 'ChristopheDemarey 10/19/2012 11:13'! findChangesFor: workingCopy relativeToRepository: repository | patch fromDescription | repository isNil ifTrue: [ ^ self ]. patch := workingCopy changesRelativeToRepository: repository. patch isNil ifTrue: [ ^ self ]. patch isEmpty ifTrue: [ workingCopy modified: false. self uiManager inform: 'No changes' ] ifFalse: [ workingCopy modified: true. fromDescription := workingCopy packageName , ' (' , workingCopy ancestry ancestorString , ')'. self viewChanges: patch from: fromDescription to: ('Modified {1}' translated format: {(workingCopy description)}) title: ('Changes to {1}' translated format: {fromDescription}) ]! ! !MBCommand methodsFor: 'accessing' stamp: 'dkh 3/6/2011 16:08'! requestor: aRequestor requestor := aRequestor ! ! !MBCommand methodsFor: 'utility' stamp: 'ChristopheDemarey 10/18/2012 11:02'! selectRepositoryFromWorkingCopy: workingCopy | repos repo | repos := workingCopy repositoryGroup repositories. repos size = 0 ifTrue: [ ^ self uiManager inform: 'No repositories associated with ' , target name printString ]. repo := repos size = 1 ifTrue: [ repos first ] ifFalse: [ self uiManager chooseFrom: (repos collect: [ :r | r description ]) values: repos title: 'Please choose which repository to use for diff' ]. ^ repo! ! !MBCommand methodsFor: 'utility' stamp: 'ChristopheDemarey 10/18/2012 10:57'! uiManager ^ UIManager default! ! !MBCommand methodsFor: 'accessing' stamp: 'fds 2/26/2011 20:01'! target: anObject target := anObject! ! !MBCommand methodsFor: 'utility' stamp: 'ChristopheDemarey 10/18/2012 11:01'! chooseRepositoryFromList: repos "Return the repository of the configuration. Create one (using UI) if necessary" repos size > 1 ifTrue: [ ^ self uiManager chooseFrom: (repos collect: [ :repo | repo description ]) values: repos title: 'Select repository' ]. ^ repos first! ! !MBCommand methodsFor: 'repositories' stamp: 'ChristopheDemarey 10/18/2012 15:17'! pickRepositoryFrom: repositories title: title | index | index := self uiManager chooseFrom: (repositories collect: [ :ea | ea description ]) title: title. ^ index = 0 ifFalse: [ repositories at: index ] ! ! !MBCommand methodsFor: 'repositories' stamp: 'ChristopheDemarey 2/11/2014 15:54'! repositoryOfPackageNamed: packageName "Return the repository of the configuration. Create one (using UI) if necessary" | mcPackage workingCopy repositories repository repositoryIndex username password | mcPackage := MCPackage named: packageName. workingCopy := mcPackage workingCopy. repositories := workingCopy repositoryGroup repositories reject: [ :rep | rep == MCCacheRepository default ]. repositories ifEmpty: [ | projectName answer squeakSourceURL | projectName := self configurationClass name configurationBaseName. squeakSourceURL := 'http://www.squeaksource.com/' , projectName. answer := self uiManager confirm: 'No repository associated with your project. Do you want to add ' , squeakSourceURL. answer ifFalse: [ self uiManager inform: 'Add a http repository with Monticello browser'. ^ nil ]. repository := MCHttpRepository location: squeakSourceURL user: '' password: ''. repository user isEmpty ifTrue: [ username := self username ]. repository password isEmpty ifTrue: [ password := self password ]. workingCopy repositoryGroup addRepository: (repository := MCHttpRepository location: squeakSourceURL user: username password: password) ]. repositories size > 1 ifTrue: [ repositoryIndex := self uiManager chooseFrom: (repositories collect: #printString). repositoryIndex = 0 ifTrue: [ ^ nil ]. repository := repositories at: repositoryIndex ]. repositories size = 1 ifTrue: [ repository := repositories first ]. ^ repository! ! !MBCommand methodsFor: 'accessing-computed' stamp: 'ChristopheDemarey 2/11/2014 15:54'! projectName ^ self configurationClass name configurationBaseName! ! !MBCommand methodsFor: 'repositories' stamp: 'ChristopheDemarey 10/18/2012 11:32'! password | password | password := target configurationRoot password. password ifNotNil: [ ^ password ]. password := self uiManager requestPassword: 'enter your Monticello password for '. target configurationRoot password: password. ^ password! ! !MBCommand methodsFor: 'ordering' stamp: 'fds 2/26/2011 10:46'! order ^ self title! ! !MBCommand methodsFor: 'versions' stamp: 'ChristopheDemarey 10/18/2012 11:32'! askForVersionNumber "Return a new version number as a string" | latestVersion newVersion versions | newVersion := (versions := target configurationInfo versions) isEmpty ifTrue: [ '1.0' ] ifFalse: [ latestVersion := versions first version. latestVersion versionNumber copy incrementMinorVersionNumber printString ]. ^ self uiManager request: 'enter new version number' initialAnswer: newVersion! ! !MBCommand methodsFor: 'repositories' stamp: 'ChristopheDemarey 10/18/2012 11:32'! username | username | username := target configurationRoot username. username ifNotNil: [ ^ username ]. username := self uiManager request: 'enter your Monticello username (login)'. target configurationRoot username: username. ^ username! ! !MBCommand methodsFor: 'changes' stamp: 'ChristopheDemarey 10/19/2012 11:05'! viewChanges: patch from: fromDescription to: toDescription title: title "Open a browser on the given patch." ^ ( PSMCPatchMorph forPatch: patch) fromDescription: fromDescription; toDescription: toDescription; newWindow; title: title; open ! ! !MBCommand methodsFor: 'repositories' stamp: 'dkh 3/5/2011 16:02'! pickRepository ^ self pickRepositoryFrom: self repositories. ! ! !MBCommand methodsFor: 'accessing-computed' stamp: 'ChristopheDemarey 8/23/2013 18:44'! configurationClass ^ target! ! !MBCommand methodsFor: 'documentation' stamp: 'fds 2/26/2011 10:48'! documentation self subclassResponsibility! ! !MBCommand methodsFor: 'repositories' stamp: 'ChristopheDemarey 10/18/2012 11:32'! checkUserInRepository: repository "Try to find the http repository of packageName. If it does not find one, then add one and ask for the username and password" | answerUser | (repository isKindOf: MCHttpRepository ) ifFalse: [ ^self ]. repository user ifEmpty: [ answerUser := self uiManager confirm: 'No user defined. Do you want to add one? '. answerUser ifTrue: [ repository user: self username. repository password: self password ] ]! ! !MBCommand methodsFor: 'repositories' stamp: 'ChristopheDemarey 10/18/2012 15:42'! pickRepositoryFrom: repositories ^self pickRepositoryFrom: repositories title: 'Choose repository'! ! !MBCommand methodsFor: 'execute' stamp: 'fds 2/26/2011 19:45'! execute self subclassResponsibility ! ! !MBCommand methodsFor: 'accessing' stamp: 'fds 2/26/2011 20:01'! target ^ target! ! !MBCommand methodsFor: 'accessing' stamp: 'dkh 3/4/2011 06:16'! targetNode: anObject targetNode := anObject! ! !MBCommand class methodsFor: 'testing' stamp: 'dkh 3/5/2011 17:06'! isOBCommand ^true! ! !MBCommand class methodsFor: 'util' stamp: 'ChristopheDemarey 10/18/2012 11:20'! newCommand " MBCommand newCommand " | command baseName newCommandName receiverClassIndex clss title documentation | baseName := self uiManager request: 'Enter the base name (''MB'' and ''Command'' will be automatically added'. baseName ifNil: [ ^ self ]. clss := MBCommand subclasses. receiverClassIndex := self uiManager chooseFrom: (clss collect: #name). receiverClassIndex isZero ifTrue: [ ^ self ]. newCommandName := 'MB', baseName, 'Command'. command := (clss at: receiverClassIndex) subclass: newCommandName asSymbol instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self category. documentation := self uiManager request: 'Enter the documentation'. documentation ifNil: [ ^ self ]. command compile: 'documentation ^ ''', documentation, '''' classified: 'documentation'. command compile: 'execute self subclassResponsibility ' classified: 'execute'. title := self uiManager request: 'Enter the command title'. title ifNil: [ ^ self ]. command compile: 'title ^ ''', title, '''' classified: 'accessing'. clss := MBInfo allSubclasses. receiverClassIndex := self uiManager chooseFrom: (clss collect: #name). receiverClassIndex isZero ifTrue: [ ^ self ]. (clss at: receiverClassIndex) compile: 'cmd', baseName, ' ^ ', newCommandName classified: 'commands'! ! !MBCommand class methodsFor: 'instance creation' stamp: 'dkh 3/6/2011 16:07'! target: target for: requestor ^ self new target: target; requestor: requestor; yourself! ! !MBCommand class methodsFor: 'testing' stamp: 'dkh 3/5/2011 17:06'! isMorphicCommand ^true! ! !MBCommandMetacelloTests methodsFor: 'tests' stamp: 'ChristopheDemarey 10/24/2013 17:57'! testRemoveVersionCmd02 "Remove a bleedingEdge version that is imported ... should abort the operation" | configName class configurationRoot configInfo versionInfo cmd versionString | configName := 'ConfigurationOfMBFooIssue117'. self tearDownPackages addAll: {configName}. gofer version: 'ConfigurationOfMBFooIssue117-dkh.1'. gofer load. class := Smalltalk at: configName asSymbol. versionString := (class project version: #bleedingEdge) versionString. configurationRoot := MBConfigurationRoot new. configurationRoot register. configInfo := configurationRoot configurationInfoFor: class. versionInfo := configInfo baselines detect: [ :each | each versionString = versionString ]. cmd := VSRemoveCommand target: versionInfo for: self. [ cmd execute ] valueSupplyingAnswers: {{'*is imported by another version*'. true}}. self assert: versionString = (class project version: #bleedingEdge) versionString! ! !MBCommandMetacelloTests methodsFor: 'tests' stamp: 'ChristopheDemarey 10/24/2013 17:57'! testRemoveVersionCmd03 "Remove a bleedingEdge version with no imports" | configName class configurationRoot configInfo versionInfo cmd versionString | configName := 'ConfigurationOfMBFooIssue117'. self tearDownPackages addAll: {configName}. gofer version: 'ConfigurationOfMBFooIssue117-dkh.2'. gofer load. class := Smalltalk at: configName asSymbol. versionString := (class project version: #bleedingEdge) versionString. self assert: versionString = '2.0-baseline'. configurationRoot := MBConfigurationRoot new. configurationRoot register. configInfo := configurationRoot configurationInfoFor: class. versionInfo := configInfo baselines detect: [ :each | each versionString = versionString ]. cmd := VSRemoveCommand target: versionInfo for: self. [ cmd execute ] valueSupplyingAnswers: {{'Are you sure you want to remove*'. true}}. self assert: (class project version: #bleedingEdge) versionString = '1.0-baseline'. self should: [ class project version: versionString ] raise: MetacelloVersionDoesNotExistError! ! !MBCommandMetacelloTests methodsFor: 'tests' stamp: 'dkh 3/19/2011 10:37'! testAddConfigurationCmd | versionString packageNames projectNames project version packages projects | self tearDownPackages addAll: #('ConfigurationOfMBFooTests' 'MBFooCommandTestA' 'MBFooCommandTestB'). "must be BEFORE the load" gofer version: 'MBFooCommandTestA-dkh.1'. gofer version: 'MBFooCommandTestB-dkh.1'. gofer version: 'ConfigurationOfMBFooTests-dkh.1'. gofer load. versionString := '1.0'. packageNames := #('MBFooCommandTestA' 'MBFooCommandTestB'). projectNames := #('ConfigurationOfMBFooTests'). MBAddConfigurationCommand new executeAddBaselineForConfigurationNamed: self configurationName repositoryDescription: 'dictionary://', self repositoryName asString versionString: versionString packages: packageNames configurations: projectNames. project := (Smalltalk at: self configurationName asSymbol) project. version := project version: versionString, '-baseline'. packages := version packages. self assert: packages size == 2. packages do: [:pkg | self assert: (packageNames includes: pkg name)]. projects := version projects. projects do: [:prj | self assert: (projectNames includes: prj name)]. ! ! !MBCommandMetacelloTests methodsFor: 'tests' stamp: 'ChristopheDemarey 10/24/2013 17:57'! testRemoveVersionCmd04 "Remove a bleedingEdge version with no imports" | configName class configurationRoot configInfo versionInfo cmd versionString | configName := 'ConfigurationOfMBFooIssue117'. self tearDownPackages addAll: {configName}. gofer version: 'ConfigurationOfMBFooIssue117-dkh.3'. gofer load. class := Smalltalk at: configName asSymbol. versionString := (class project version: #bleedingEdge) versionString. self assert: versionString = '2.0-baseline'. configurationRoot := MBConfigurationRoot new. configurationRoot register. configInfo := configurationRoot configurationInfoFor: class. versionInfo := configInfo baselines detect: [ :each | each versionString = versionString ]. cmd := VSRemoveCommand target: versionInfo for: self. [ cmd execute ] valueSupplyingAnswers: {{'Are you sure you want to remove*'. true}}. self should: [ class project version: #bleedingEdge ] raise: MetacelloSymbolicVersionNotDefinedError. self should: [ class project version: versionString ] raise: MetacelloVersionDoesNotExistError! ! !MBCommandMetacelloTests methodsFor: 'tests' stamp: 'ChristopheDemarey 10/24/2013 17:57'! testRemoveVersionCmd01 "Issue 117: Removing a version does not update the #development/#stable symbolic versions." | configName class configurationRoot configInfo versionInfo cmd | configName := 'ConfigurationOfMBFooIssue117'. self tearDownPackages addAll: {configName}. gofer version: 'ConfigurationOfMBFooIssue117-dkh.1'. gofer load. class := Smalltalk at: configName asSymbol. self assert: (class project version: #development) versionString = '1.0'. self assert: (class project version: #stable) versionString = '1.0'. configurationRoot := MBConfigurationRoot new. configurationRoot register. configInfo := configurationRoot configurationInfoFor: class. versionInfo := configInfo versions detect: [ :each | each versionString = '1.0' ]. cmd := VSRemoveCommand target: versionInfo for: self. [ cmd execute ] valueSupplyingAnswers: {{'Are you sure you want to remove*'. true}}. self should: [ class project version: #development ] raise: MetacelloSymbolicVersionNotDefinedError. self should: [ class project version: #stable ] raise: MetacelloSymbolicVersionNotDefinedError. self should: [ class project version: '1.0' ] raise: MetacelloVersionDoesNotExistError! ! !MBCommandMetacelloTests methodsFor: 'tests' stamp: 'dkh 3/20/2011 12:45'! testConfigurationChanges! ! !MBCommandMetacelloTests methodsFor: 'tests' stamp: 'dkh 3/19/2011 10:10'! testUsernamePassword | cmd configInfo | gofer version: 'ConfigurationOfMBFooTests-dkh.1'. gofer load. self tearDownPackages add: 'ConfigurationOfMBFooTests'. configInfo := (MBConfigurationInfo configurationClass: (Smalltalk at: #'ConfigurationOfMBFooTests')) configurationRoot: MBConfigurationRoot new. cmd := MBSaveConfigurationCommand target: configInfo for: self. [cmd username] valueSupplyingAnswer: 'ab'. [cmd password] valueSupplyingAnswer: 'foobar'. self assert: cmd username = 'ab'. self assert: cmd password = 'foobar'.! ! !MBCommandTests methodsFor: 'private' stamp: 'dkh 3/19/2011 10:13'! repositoryName ^#'Metacello_Dev_Cycle_Repository'! ! !MBCommandTests methodsFor: 'running' stamp: 'dkh 3/19/2011 10:54'! tearDown gofer := Gofer new. self tearDownPackages do: [:pkgName | (self hasPackage: pkgName) ifTrue: [ gofer package: pkgName ]]. gofer references notEmpty ifTrue: [ gofer unload ]. Smalltalk removeKey: self repositoryName ifAbsent: [ ]. Smalltalk removeKey: #'MB_Foo_Test_Repository' ifAbsent: []. Smalltalk at: self configurationName ifPresent: [:cls | cls removeFromSystem ]. MetacelloPlatform current authorName: authorName.! ! !MBCommandTests methodsFor: 'running' stamp: 'ChristopheDemarey 11/21/2013 14:06'! runCase | original | original := MetacelloPlatform current bypassGoferLoadUpdateCategories. ^ [ MetacelloPlatform current bypassGoferLoadUpdateCategories: true. [ super runCase ] ensure: [ MetacelloPlatform current bypassGoferLoadUpdateCategories: original ] ]! ! !MBCommandTests methodsFor: 'accessing' stamp: 'dkh 3/19/2011 10:04'! tearDownPackages tearDownPackages ifNil: [ tearDownPackages := OrderedCollection new ]. ^tearDownPackages! ! !MBCommandTests methodsFor: 'private' stamp: 'TesterBob 3/20/2011 13:21'! configurationName ^#'ConfigurationOfMetacello_Command_Tests'! ! !MBCommandTests methodsFor: 'running' stamp: 'dkh 3/19/2011 10:16'! setUp | repo | super setUp. gofer := Gofer new. gofer disablePackageCache. repo := MBMonticelloPackagesResource current monticelloRepository. gofer repository: repo. Smalltalk at: #'MB_Foo_Test_Repository' put: repo. repo := MCDictionaryRepository new. repo description: 'dictionary://', self repositoryName asString. Smalltalk at: self repositoryName put: repo. authorName := MetacelloPlatform current authorName. MetacelloPlatform current authorName: 'TesterBob'. ! ! !MBCommandTests methodsFor: 'running' stamp: 'dkh 3/19/2011 10:08'! hasPackage: aString | package | package := MCWorkingCopy allManagers detect: [ :each | each packageName = aString ] ifNone: [ nil ]. ^ package notNil! ! !MBConfigurationBranchTest commentStamp: 'TorstenBergmann 2/20/2014 14:16'! SUnit tests for configuration branches in Versionner! !MBConfigurationBranchTest methodsFor: 'running' stamp: 'dkh 4/17/2011 12:28'! tearDown configurationRoot ifNotNil: [ configurationRoot unregister ]. Smalltalk removeKey: #'MB_Foo_Test_Repository' ifAbsent: []. gofer := Gofer new. self tearDownPackages do: [:pkgName | (self hasPackage: pkgName) ifTrue: [ gofer package: pkgName ]]. gofer references notEmpty ifTrue: [ gofer unload ]. ! ! !MBConfigurationBranchTest methodsFor: 'tests' stamp: 'dkh 4/17/2011 13:13'! test002ConfigurationReferences "Make sure that the project and project branches show up in configuration references (for load configuration command)" | referenceMap | referenceMap := MBLoadConfigurationCommand new configurationReferencesFrom: MBMonticelloPackagesResource current monticelloRepository. self assert: (referenceMap keys includes: 'ConfigurationOfMBBranchTests.branch')! ! !MBConfigurationBranchTest methodsFor: 'tests' stamp: 'dkh 4/17/2011 12:48'! test0010BasicLoad " - make sure that the configuration can be loaded without error - make sure that version 1.0 can be loaded without error" configurationRoot unregister. self assert: (Smalltalk at: #ConfigurationOfMBBranchTests ifAbsent: []) isNil. gofer version: 'ConfigurationOfMBBranchTests-dkh.1'. gofer load. ((Smalltalk at: #ConfigurationOfMBBranchTests) project version: '1.0') load. self assert: (Smalltalk at: #MBFooTestA ifAbsent: []) notNil ! ! !MBConfigurationBranchTest methodsFor: 'running' stamp: 'dkh 4/17/2011 12:53'! tearDownPackages ^#('MBFooTests' 'ConfigurationOfMBBranchTests')! ! !MBConfigurationBranchTest methodsFor: 'tests' stamp: 'dkh 4/17/2011 12:48'! test0011BasicLoad " - make sure that the branch configuration can be loaded without error - make sure that version 1.0 can be loaded without error" configurationRoot unregister. self assert: (Smalltalk at: #ConfigurationOfMBBranchTests ifAbsent: []) isNil. gofer version: 'ConfigurationOfMBBranchTests.branch-dkh.2'. gofer load. ((Smalltalk at: #ConfigurationOfMBBranchTests) project version: '1.0') load. self assert: (Smalltalk at: #MBFooTestA ifAbsent: []) notNil ! ! !MBConfigurationBranchTest methodsFor: 'running' stamp: 'dkh 4/17/2011 12:28'! setUp | repo | super setUp. gofer := Gofer new. gofer disablePackageCache. repo := MBMonticelloPackagesResource current monticelloRepository. gofer repository: repo. Smalltalk at: #'MB_Foo_Test_Repository' put: repo. configurationRoot := MBConfigurationRoot new. configurationRoot register. ! ! !MBConfigurationBranchTest methodsFor: 'running' stamp: 'dkh 4/17/2011 12:41'! hasPackage: aString | package | package := MCWorkingCopy allManagers detect: [ :each | each packageName = aString ] ifNone: [ nil ]. ^ package notNil! ! !MBConfigurationChangesCommand commentStamp: 'TorstenBergmann 2/20/2014 14:07'! Command to browse changes on a configuration in versionner! !MBConfigurationChangesCommand methodsFor: 'accessing' stamp: 'dkh 3/20/2011 16:13'! title ^ 'changes'! ! !MBConfigurationChangesCommand methodsFor: 'documentation' stamp: 'dkh 3/20/2011 14:02'! documentation ^ 'View changes for selected configuration against version in selected repository.'! ! !MBConfigurationChangesCommand methodsFor: 'execute' stamp: 'dkh 3/20/2011 12:50'! execute "View the changes made in the working copy." | wc repo | wc := target workingCopy. (repo := self selectRepositoryFromWorkingCopy: wc) ifNil: [ ^self ]. self findChangesFor: wc relativeToRepository: repo! ! !MBConfigurationInfo commentStamp: ''! A MBConfigurationInfo holds information on a specific configuration, i.e. on the ConfigurationOf class of a project. Instance Variables baselines: list of baselines (MBBaseLineInfo instances) of this configuration. branch: ?? configurationClass: the configuration class (ConfigurationOf instance). configurationRoot: a link to the root object with all configurations. currentVersion: ?? trimVersionLists: true if ?? versions: list of versions (MBVersionInfo instances) of this configuration. workingCopy: the Metacello working copy ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'dkh 3/6/2011 15:33'! baselinesFor: aMetacelloProject "Return the list of BaselineInfo for the configuration class passed as parameter" "The returned collection is ordered. Labeled baselines are first, numbered baselines are last" | existingBaselines numberedBaselines labeledBaselines | existingBaselines := aMetacelloProject versions select: [ :vrsn | vrsn blessing == #baseline ]. existingBaselines := existingBaselines collect: [ :vrsn | (MBBaselineInfo version: vrsn) configurationInfo: self; yourself ]. numberedBaselines := existingBaselines select: [ :bInfo | ($0 to: $9) includes: bInfo name first ]. labeledBaselines := existingBaselines copyWithoutAll: numberedBaselines. ^ labeledBaselines asArray , numberedBaselines asArray reversed! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'dkh 3/6/2011 14:50'! configurationRoot ^ configurationRoot! ! !MBConfigurationInfo methodsFor: 'accessing-computed' stamp: 'ChristopheDemarey 12/11/2012 11:23'! currentVersion "Return the currentVersion of the configuration ... nil if not loaded." currentVersion == #notLoaded ifTrue: [ ^ nil ]. (currentVersion notNil and: [ currentVersion ~~ #recalculate]) ifTrue: [ ^ currentVersion ]. packages := projects := groups := text := nil. self configurationRoot ifNil: [ ^ currentVersion ]. (currentVersion := self project currentVersion) ifNil: [ currentVersion := #notLoaded. self configurationRoot announcer announce: (MBConfigurationInfoChanged changed: self). ^ nil ]. self configurationRoot announcer announce: (MBConfigurationInfoChanged changed: self). ^ currentVersion! ! !MBConfigurationInfo methodsFor: 'actions' stamp: 'dkh 2/27/2011 20:26'! validate validationResult == nil ifTrue: [ validationIcon := nil. validationResult := MetacelloToolBox validateConfiguration: self configurationClass ]. ^ validationResult! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'dkh 2/27/2011 15:28'! workingCopy | pkg | workingCopy ~~ nil ifTrue: [ ^workingCopy ]. pkg := MCPackage named: self configurationClass category asString. pkg hasWorkingCopy ifFalse: [ ^nil ]. ^workingCopy := pkg workingCopy! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'dkh 3/10/2011 11:25'! project "Answer the MetacelloProject associated with the receiver." ^ self configurationClass project! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'dkh 4/7/2011 23:57'! branch branch ifNil: [ branch := self extractBranchFrom: self workingCopy ]. ^branch! ! !MBConfigurationInfo methodsFor: 'commands' stamp: 'JuanPabloSandovalAlcocer 6/30/2012 18:07'! cmdSaveConfiguration ^ MBSaveConfigurationCommand! ! !MBConfigurationInfo methodsFor: 'updating' stamp: 'dkh 4/12/2011 10:51'! recalculateIfInterestedInPackageNamed: packageName for: operation | recalculate | recalculate := super recalculateIfInterestedInPackageNamed: packageName for: operation. (recalculate not and: [ baselines notNil ]) ifTrue: [ (self baselines detect: [ :info | info recalculateIfInterestedInPackageNamed: packageName for: operation ] ifNone: [ ]) ifNotNil: [ recalculate := true ] ]. (recalculate not and: [ versions notNil ]) ifTrue: [ (self versions detect: [ :info | info recalculateIfInterestedInPackageNamed: packageName for: operation ] ifNone: [ ]) ifNotNil: [ recalculate := true ] ]. (recalculate and: [ operation ~~ #modified ]) ifTrue: [ currentVersion == #notLoaded ifTrue: [ currentVersion := nil ]. self fullRecalculate ]! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'ChristopheDemarey 9/17/2013 18:18'! repositories "Return the repositories associated with the configuration." | mcPackage | (mcPackage := self project projectPackage) ifNil: [ ^nil ]. ^ mcPackage workingCopy ifNil: [ nil ] ifNotNilDo: [ :wc | wc repositoryGroup repositories ]! ! !MBConfigurationInfo methodsFor: 'accessing-computed' stamp: 'dkh 3/2/2011 20:29'! versionForInfoList ^self currentVersion ! ! !MBConfigurationInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 9/17/2013 15:32'! cmdOpenRepository ^ VSOpenRepositoryCommand! ! !MBConfigurationInfo methodsFor: 'printing' stamp: 'ChristopheDemarey 11/6/2012 15:28'! printOn: aStream | cv nameString wc refString branchString | [self name ifNil: [ aStream nextPutAll: ''. ^ self ]. nameString := self name configurationBaseName. (refString := self extractPackageSignatureFrom: (wc := self workingCopy)) notEmpty ifTrue: [ refString := '(' , refString , ')' ]. (branchString := self branch) notEmpty ifTrue: [ nameString := nameString, '.', branchString ]. self isDirty ifTrue: [ aStream nextPutAll: '* ' ]. aStream nextPutAll: nameString. (cv := self currentVersion) notNil ifTrue: [ aStream nextPutAll: ' ' , cv versionString ]. aStream nextPutAll: refString.] on:Error do:[].! ! !MBConfigurationInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 9/17/2013 11:37'! cmdValidateConfiguration ^ VSValidateConfigurationCommand! ! !MBConfigurationInfo methodsFor: 'testing' stamp: 'JPSA 4/20/2012 21:22'! isDirty | wc | ^ [super isDirty or: [ (wc := self workingCopy) notNil and: [ wc needsSaving ]]] on:Error do:[false].! ! !MBConfigurationInfo methodsFor: 'testing' stamp: 'dkh 3/9/2011 16:30'! currentVersionMismatch ^ (self projects anySatisfy: [ :each | each currentVersionMismatch ]) or: [ self packages anySatisfy: [ :each | each currentVersionMismatch ] ]! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'dkh 3/1/2011 21:15'! trimVersionLists: aBool trimVersionLists := aBool! ! !MBConfigurationInfo methodsFor: 'testing' stamp: 'ChristopheDemarey 12/5/2013 09:42'! hasVersion: aVersionString [ self project version: aVersionString ] on: MetacelloSymbolicVersionDoesNotExistError do: [ ^ false ]. ^ true! ! !MBConfigurationInfo methodsFor: 'private' stamp: 'dkh 3/2/2011 08:07'! trimVersionInfos: versionInfos | trimmed count marker cv | self trimVersionLists ifFalse: [ ^versionInfos ]. versionInfos size <= 10 ifTrue: [ ^versionInfos ]. trimmed := (versionInfos copyFrom: 1 to: 5) asOrderedCollection. marker := count := 0. cv := self currentVersion. 6 to: versionInfos size do: [:index | | info | info := versionInfos at: index. info isStable | info isBleedingEdge | info isDevelopment | info hasValidationIssues | (cv = info version) ifTrue: [ count - 1 >= marker ifTrue: [ trimmed add:( MBLabelInfo new name: '..') ]. trimmed add: info. marker := count. ]. count := count + 1 ]. count - 1 >= marker ifTrue: [ trimmed add:( MBLabelInfo new name: '..') ]. ^trimmed! ! !MBConfigurationInfo methodsFor: 'initialize-release' stamp: 'dkh 3/6/2011 18:37'! release super release. baselines := versions := nil.! ! !MBConfigurationInfo methodsFor: 'utils' stamp: 'dkh 4/7/2011 23:49'! extractBranchFrom: aWorkingCopy | ref | (aWorkingCopy isNil or: [ aWorkingCopy ancestors isEmpty ]) ifTrue: [ ^ '' ]. ref := GoferVersionReference name: aWorkingCopy ancestors first name. ^ ref branch! ! !MBConfigurationInfo methodsFor: 'updating' stamp: 'dkh 4/12/2011 10:43'! recalculateIfInterestedInConfigurationInfo: configInfo for: operation projects ifNil: [ ^self ]. self projects detect: [ :info | info interestedInConfigurationInfo: configInfo ] ifNone: [ ^self ]. infoList := text := projects := nil. self configurationRoot announcer announce: (MBConfigurationInfoChanged changed: self)! ! !MBConfigurationInfo methodsFor: 'updating' stamp: 'dkh 3/14/2011 11:10'! fullRecalculate super fullRecalculate. (currentVersion == #recalculate or: [ currentVersion isNil ]) ifTrue: [^self ]. currentVersion := #recalculate. ! ! !MBConfigurationInfo methodsFor: 'private' stamp: 'dkh 3/18/2011 18:42'! calculateInfoList | answer list cvs cv | answer := OrderedCollection new. [self project ifNil: [ ^answer ]] on: Error do: [:ex | ^answer ]. answer add: (MBLabelInfo new name: ' -- baselines --'). answer addAll: (self trimVersionInfos: self baselines). answer add: (MBLabelInfo new name: ''). answer add: (MBLabelInfo new name: ' -- versions --'). answer addAll: (self trimVersionInfos: self versions). answer add: (MBLabelInfo new name: ''). cvs := ''. (cv := self currentVersion) ~~ nil ifTrue: [cvs := cv versionString, ' ']. (list := self projects) notEmpty ifTrue: [ answer add: (MBLabelInfo new name: ' -- ', cvs, 'projects --'). answer addAll: list. answer add: (MBLabelInfo new name: '') ]. (list := self packages) notEmpty ifTrue: [ answer add: (MBLabelInfo new name: ' -- ', cvs, 'packages --'). answer addAll: list. answer add: (MBLabelInfo new name: '') ]. (list := self groups) notEmpty ifTrue: [ answer add: (MBLabelInfo new name: ' -- ', cvs, 'groups --'). answer addAll: list]. ^ answer! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'dkh 3/5/2011 18:03'! configurationInfo ^self ! ! !MBConfigurationInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 2/14/2014 18:01'! cmdCatalogAdder ^ VSCatalogAdderCommand! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'dkh 3/6/2011 14:50'! configurationRoot: anObject configurationRoot := anObject! ! !MBConfigurationInfo methodsFor: 'updating' stamp: 'dkh 4/7/2011 23:58'! recalculate branch := workingCopy := baselines := versions := nil. super recalculate. self configurationRoot announcer announce: (MBConfigurationInfoChanged changed: self). ! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'dkh 4/8/2011 16:14'! version ^self currentVersion! ! !MBConfigurationInfo methodsFor: 'updating' stamp: 'ChristopheDemarey 3/28/2014 14:18'! recalculateSilently branch := workingCopy := baselines := versions := nil. super recalculate. ! ! !MBConfigurationInfo methodsFor: 'actions' stamp: 'dkh 3/6/2011 14:56'! validateFull infoList := baselines := versions := nil. (self baselines, self versions) do: [:version | version validateFull ]. ^super validateFull. ! ! !MBConfigurationInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 9/17/2013 15:30'! cmdBrowseConfiguration ^ VSBrowseConfigurationCommand! ! !MBConfigurationInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 9/17/2013 15:28'! cmdUnloadConfiguration ^ VSUnloadConfigurationCommand! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'ChristopheDemarey 10/18/2012 10:49'! configurationClass "Returns the class configurationOfXXX associted to the configuration info (wrapper for the UI)" ^ configurationClass! ! !MBConfigurationInfo methodsFor: 'accessing-computed' stamp: 'ChristopheDemarey 3/6/2013 18:09'! versions "Return the versions of the configuration" | versionList devVersionString | versions ifNotNil: [ versions ifNotEmpty: [ ^ versions ] ]. versionList := self project map values. devVersionString := self project symbolicVersionMap at: #development ifAbsent: [ '' ]. versionList reject: [ :vrsn | (vrsn blessing == #baseline and: [(vrsn name == devVersionString) not]) or: [ vrsn blessing == #broken ] ]. versions := (versionList asArray sort: [:a :b | a > b ]) collect: [ :vrsn | (MBVersionInfo version: vrsn) configurationInfo: self; yourself ]. ^ versions! ! !MBConfigurationInfo methodsFor: 'accessing-computed' stamp: 'dkh 4/7/2011 23:58'! currentVersion: aVersion currentVersion := aVersion. branch := baselines := versions := infoList := packages := projects := groups := text := nil. self configurationRoot announcer announce: (MBConfigurationInfoChanged changed: self). self announcer announce: (MBInfoListChanged changed: self). ! ! !MBConfigurationInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 10/25/2013 17:53'! cmdUpdateFromItsRepository ^ VSUpdateFromItsRepositoryCommand! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'dkh 3/1/2011 21:15'! trimVersionLists trimVersionLists == nil ifTrue: [ trimVersionLists := true ]. ^trimVersionLists! ! !MBConfigurationInfo methodsFor: 'converting' stamp: 'dkh 4/5/2011 16:41'! buildStringOrText | string cv specVersion attributes wc | attributes := OrderedCollection new. [ string := super buildStringOrText ] on: Error do: [ :ex | attributes add: TextEmphasis struckOut. ^ Text string: self name asString attributes: attributes ]. ((wc := self workingCopy) notNil and: [ wc needsSaving ]) ifTrue: [ attributes add: TextEmphasis underlined ]. self currentVersion. "prime the pump" currentVersion == #notLoaded ifTrue: [ attributes notEmpty ifTrue: [ ^ Text string: string attributes: attributes ]. ^ string ]. super isDirty | self currentVersionMismatch ifTrue: [ attributes add: TextEmphasis bold ]. self currentVersion versionStatus == #somethingLoaded ifTrue: [ attributes add: TextColor red ]. attributes notEmpty ifTrue: [ ^ Text string: string attributes: attributes ]. ^ string! ! !MBConfigurationInfo methodsFor: 'accessing-computed' stamp: 'ChristopheDemarey 1/13/2014 14:34'! baselines baselines ifNotNil: [ ^baselines ]. baselines := self baselinesFor: self project. ^baselines ! ! !MBConfigurationInfo methodsFor: 'updating' stamp: 'dkh 03/12/2011 02:24'! configurationClassModified self fullRecalculate ! ! !MBConfigurationInfo methodsFor: 'accessing' stamp: 'dkh 2/23/2011 14:19'! configurationClass: aConfigurationClass configurationClass := aConfigurationClass. self name: configurationClass name asString! ! !MBConfigurationInfo class methodsFor: 'accessing' stamp: 'dkh 4/10/2011 19:56'! helpLabel ^'Configuration'! ! !MBConfigurationInfo class methodsFor: 'instance creation' stamp: 'AlexandreBergel 1/16/2011 21:14'! configurationClass: aConfiguration ^ super new configurationClass: aConfiguration; yourself! ! !MBConfigurationInfo class methodsFor: 'instance creation' stamp: 'AlexandreBergel 1/16/2011 21:13'! new self error: 'Please, use #configuration: to instantiate ', self name printString! ! !MBConfigurationInfoChanged commentStamp: 'TorstenBergmann 2/20/2014 14:05'! A configuration info changed! !MBConfigurationInfoChanged methodsFor: 'accessing' stamp: 'dkh 3/10/2011 12:55'! configurationInfo ^ configurationInfo! ! !MBConfigurationInfoChanged methodsFor: 'accessing' stamp: 'JuanPabloSandovalAlcocer 3/27/2012 10:51'! configurationInfo: anObject configurationInfo := anObject ! ! !MBConfigurationInfoChanged class methodsFor: 'instance creation' stamp: 'dkh 3/10/2011 12:56'! changed: aConfigurationInfo ^(self new) configurationInfo: aConfigurationInfo; yourself! ! !MBConfigurationInfoCommand commentStamp: 'TorstenBergmann 2/20/2014 14:07'! Common superclass for commands on configuration infos in Versionner! !MBConfigurationInfoCommand methodsFor: 'ui' stamp: 'ChristopheDemarey 10/18/2012 11:43'! showExecuteWhile: aBlock ^Cursor execute showWhile: aBlock! ! !MBConfigurationInfoCreated commentStamp: 'TorstenBergmann 2/20/2014 14:05'! A configuration info was created! !MBConfigurationInfoDeleted commentStamp: 'TorstenBergmann 2/20/2014 14:05'! A configuration info was deleted! !MBConfigurationInfoTest commentStamp: 'TorstenBergmann 2/20/2014 14:19'! SUnit tests for MBConfigurationInfo in Versionner! !MBConfigurationInfoTest methodsFor: 'tests' stamp: 'ChristopheDemarey 2/7/2014 18:29'! testInitialization | configClass conf | self should: [ MBConfigurationInfo new ] raise: Error. configClass := Smalltalk globals at: #ConfigurationOfVersionner. self shouldnt: [ conf := MBConfigurationInfo configurationClass: configClass ] raise: Error. self assert: conf name = 'ConfigurationOfVersionner'! ! !MBConfigurationInfoTest methodsFor: 'tests' stamp: 'ChristopheDemarey 1/13/2014 10:26'! testDefaultVersion self assert: (configuration selectors select: [ :s | s beginsWith: 'baseline']) size + 1 equals: info baselines size ! ! !MBConfigurationInfoTest methodsFor: 'tests' stamp: 'dkh 3/6/2011 14:56'! testBaselines "+1 is for the default: baseline" self assert: info baselines size = ((configuration selectors select: [ :s | s beginsWith: 'baseline']) size + 1). ! ! !MBConfigurationInfoTest methodsFor: 'running' stamp: 'dkh 3/4/2011 14:13'! setUp super setUp. info := MBConfigurationInfo configurationClass: configuration. ! ! !MBConfigurationPackageHistoryCommand commentStamp: 'TorstenBergmann 2/20/2014 14:07'! Command to browse package history for configurations in versionner! !MBConfigurationPackageHistoryCommand methodsFor: 'accessing' stamp: 'dkh 3/20/2011 14:16'! title ^ 'history'! ! !MBConfigurationPackageHistoryCommand methodsFor: 'documentation' stamp: 'dkh 3/20/2011 14:17'! documentation ^ 'view package history'! ! !MBConfigurationPackageHistoryCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/18/2012 17:39'! execute self browseVersionHistory! ! !MBConfigurationRoot commentStamp: ''! MB stands for Metacello Borwser. MBConfigurationRoot is the root object holding information on all available configurations in the image. Instance Variables announcer: configurations: a collection of MBConfigurationInfo. password: username: ! !MBConfigurationRoot methodsFor: 'accessing' stamp: 'dkh 3/5/2011 15:33'! configurationClasses ^ MetacelloToolBox configurationClasses! ! !MBConfigurationRoot methodsFor: 'accessing' stamp: 'dkh 3/10/2011 12:37'! announcer ^announcer ! ! !MBConfigurationRoot methodsFor: 'updating' stamp: 'ChristopheDemarey 1/2/2013 17:33'! unregister "Unregister from the dependent object. Typically used when closing the browser" SystemAnnouncer uniqueInstance unsubscribe: self. MCWorkingCopy removeDependent: self. ! ! !MBConfigurationRoot methodsFor: 'updating' stamp: 'dkh 4/7/2011 23:42'! update: anArrayOrSymbol "A package has been modified (loaded, removed, or updated). Find out if any configurations are managing the package. Update events are coming from MCWorkingCopy." | packageName operation | anArrayOrSymbol isArray ifFalse: [ ^ self ]. operation := anArrayOrSymbol at: 1. operation == #modified ifTrue: [ packageName := (anArrayOrSymbol at: 2) packageName ]. operation == #registered ifTrue: [ packageName := (anArrayOrSymbol at: 2) name ]. operation == #unregistered ifTrue: [ packageName := (anArrayOrSymbol at: 2) name ]. (packageName beginsWith: 'ConfigurationOf') ifTrue: [ | wc info | operation ~~ #modified ifTrue: [ ^ self ]. "only interested in modified" wc := anArrayOrSymbol at: 2. wc modified ifTrue: [ ^ self ]. "only interested in transtion from modified to not modified" (info := self configurationInfoFor: (Smalltalk at: packageName asSymbol ifAbsent: [ ^ self ])) isNil ifTrue: [ ^ self ]. "removed and added packages handled by the add/removal of the class" info configurationClassModified. ^ self ]. self configurations do: [ :info | info recalculateIfInterestedInPackageNamed: packageName for: operation ]! ! !MBConfigurationRoot methodsFor: 'accessing' stamp: 'dkh 3/6/2011 14:51'! configurations configurations ifNil: [ configurations := (self configurationClasses collect: [ :cls | (MBConfigurationInfo configurationClass: cls) configurationRoot: self; yourself ]) asSortedCollection: [ :a :b | a name <= b name ] ]. ^ configurations! ! !MBConfigurationRoot methodsFor: 'actions' stamp: 'dkh 3/10/2011 14:46'! removeConfigurationInfo: aConfigurationInfo aConfigurationInfo release. self configurations remove: aConfigurationInfo ifAbsent: []. self announcer announce: MBConfigurationInfoDeleted! ! !MBConfigurationRoot methodsFor: 'updating' stamp: 'ChristopheDemarey 1/2/2013 17:31'! classAdded: anEvent (anEvent classAdded name asString beginsWith: 'ConfigurationOf') ifTrue: [ self respondToEventFor: anEvent classAdded withOperation: #added ]! ! !MBConfigurationRoot methodsFor: 'updating' stamp: 'ChristopheDemarey 1/2/2013 17:32'! register "Set up dependencies" SystemAnnouncer uniqueInstance weak on: ClassAdded send: #classAdded: to: self; on: ClassModifiedClassDefinition, ClassCommented, ClassRenamed, ClassReorganized, ClassRenamed send: #classModified: to: self; on: ClassRemoved send: #classRemoved: to: self; on: MethodAdded, MethodModified , MethodRemoved send: #methodModified: to: self. MCWorkingCopy addDependent: self. ! ! !MBConfigurationRoot methodsFor: 'accessing' stamp: 'dkh 3/5/2011 15:34'! password ^ password! ! !MBConfigurationRoot methodsFor: 'updating' stamp: 'dkh 4/9/2011 21:00'! respondToEventFor: aConfigurationClass withOperation: operation "Events generated by SystemChangeNotifier and involve edits to the configuration itself." | info | operation == #added ifTrue: [ ^self addConfigurationInfoFor: aConfigurationClass ]. (info := self configurationInfoFor: aConfigurationClass) isNil ifTrue: [ ^ self ]. operation == #removed ifTrue: [ ^self removeConfigurationInfo: info ]. "operation == #modified...configuration specs potentially modified" info configurationClassModified. self configurations do: [ :configInfo | configInfo recalculateIfInterestedInConfigurationInfo: info for: operation ]! ! !MBConfigurationRoot methodsFor: 'accessing' stamp: 'dkh 3/5/2011 15:35'! username ^ username! ! !MBConfigurationRoot methodsFor: 'initialize-release' stamp: 'dkh 3/10/2011 12:37'! initialize super initialize . announcer := Announcer new! ! !MBConfigurationRoot methodsFor: 'updating' stamp: 'ChristopheDemarey 1/17/2013 10:46'! methodModified: anEvent (anEvent methodAffected class name asString beginsWith: 'ConfigurationOf') ifTrue: [ self respondToEventFor: anEvent methodAffected withOperation: #modified ]! ! !MBConfigurationRoot methodsFor: 'accessing' stamp: 'dkh 3/5/2011 15:34'! password: anObject password := anObject! ! !MBConfigurationRoot methodsFor: 'accessing' stamp: 'dkh 3/5/2011 15:35'! username: anObject username := anObject! ! !MBConfigurationRoot methodsFor: 'accessing' stamp: 'dkh 4/9/2011 18:26'! configurationInfoFor: aConfigurationClass self configurations do: [:info | info configurationClass == aConfigurationClass theNonMetaClass ifTrue: [ ^info ]]. ^nil! ! !MBConfigurationRoot methodsFor: 'actions' stamp: 'dkh 3/10/2011 12:49'! addConfigurationInfoFor: aConfigurationClass (self configurationInfoFor: aConfigurationClass) notNil ifTrue: [ ^ self ]. self configurations add: ((MBConfigurationInfo configurationClass: aConfigurationClass) configurationRoot: self; yourself). self announcer announce: MBConfigurationInfoCreated! ! !MBConfigurationRoot methodsFor: 'updating' stamp: 'ChristopheDemarey 8/28/2012 14:49'! categoryModified: anEvent "(anEvent itemClass name asString beginsWith: 'ConfigurationOf') ifTrue: [ self respondToEventFor: anEvent itemClass withOperation: #modified ]" | configName configClass configInfo | self flag: 'update only needed configurations'. "configName := 'ConfigurationOf' , (anEvent item). configClass := Smalltalk at: (configName asSymbol). configClass ifNotNilDo: [ configInfo := self configurationInfoFor: configClass. configInfo fullRecalculate ]." self configurations do: [:config | config fullRecalculate ].! ! !MBConfigurationRoot methodsFor: 'updating' stamp: 'ChristopheDemarey 1/2/2013 17:31'! classRemoved: anEvent (anEvent classRemoved name asString beginsWith: 'ConfigurationOf') ifTrue: [ self respondToEventFor: anEvent classRemoved withOperation: #removed ]! ! !MBConfigurationRoot methodsFor: 'updating' stamp: 'ChristopheDemarey 1/2/2013 17:31'! classModified: anEvent (anEvent classAffected name asString beginsWith: 'ConfigurationOf') ifTrue: [ self respondToEventFor: anEvent classAffected withOperation: #modified ]! ! !MBConfigurationRoot class methodsFor: 'accessing' stamp: 'dkh 3/10/2011 18:22'! reset "self reset" | c | Current ifNil: [ ^self ]. c := Current. Current := nil. c unregister. ! ! !MBConfigurationRoot class methodsFor: 'accessing' stamp: 'JuanPabloSandovalAlcocer 6/30/2012 23:11'! current "singleton pattern" Current ifNil: [ Current := self new. Current register ]. ^Current ! ! !MBConfigurationRootTest commentStamp: 'TorstenBergmann 2/20/2014 14:16'! SUnit tests for configurations in Versionner! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'dkh 4/5/2011 15:48'! test0021ConfigurationInfoCreated | createdValuable configClassName configInfoCreated configInfoChanged changedValuable configInfoDeleted deletedValuable | configInfoDeleted := configInfoChanged := configInfoCreated := false. createdValuable := [ :ann | configInfoCreated := true ]. changedValuable := [ :ann | configInfoChanged := true ]. deletedValuable := [ :ann | configInfoDeleted := true ]. [ configurationRoot announcer on: MBConfigurationInfoCreated do: createdValuable. configurationRoot announcer on: MBConfigurationInfoChanged do: changedValuable. configurationRoot announcer on: MBConfigurationInfoDeleted do: deletedValuable. configClassName := #ConfigurationOfMBFooTests. "load configuration" gofer version: 'ConfigurationOfMBFooTests-dkh.1'. gofer load. self assert: configInfoCreated. self assert: configInfoChanged. self deny: configInfoDeleted. ] ensure: [ configurationRoot announcer unsubscribe: createdValuable; unsubscribe: deletedValuable; unsubscribe: changedValuable ]. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/28/2012 13:58'! test0070BasicVersionLoad "Seventh test: - load configuration dkh.3 - load version 1.0. - validate package, baselines and versions state - load version 1.2 - validate new package, baselines and versions state" | configClass configClassName configInfo expected infos | gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo printString = 'MBFooTests(dkh.3)'. self assert: configInfo currentVersion isNil. "load version 1.0" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.0') load. self assert: configInfo printString = 'MBFooTests 1.0(dkh.3)'. self assert: configInfo currentVersion versionString = '1.0'. self assert: configInfo printString = 'MBFooTests 1.0(dkh.3)'. "baselines" infos := configInfo baselines. self assert: infos size = 1. expected := #('1.0-baseline #bleedingEdge'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index)]. "versions" infos := configInfo versions. self assert: infos size = 3. expected := #('1.2' '1.1' ' @ 1.0 #stable'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index)]. "packages" infos := configInfo packages. self assert: infos size = 1. expected := #('MBFooTests-dkh.1'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index)]. "load version 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self assert: configInfo printString = 'MBFooTests 1.2(dkh.3)'. "baselines" infos := configInfo baselines. self assert: infos size = 1. expected := #('1.0-baseline #bleedingEdge'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index)]. "versions" infos := configInfo versions. self assert: infos size = 3. expected := #(' @ 1.2' '1.1' '1.0 #stable'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index)]. "packages" infos := configInfo packages. self assert: infos size = 1. expected := #('MBFooTests-dkh.3'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index)]. ! ! !MBConfigurationRootTest methodsFor: 'running' stamp: 'dkh 4/17/2011 14:50'! hasPackage: aString | package | package := MCWorkingCopy allManagers detect: [ :each | each packageName = aString ] ifNone: [ nil ]. ^ package notNil! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 11/27/2013 12:34'! expectedFailures ^ #( test0021ConfigurationInfoCreated test0030BasicVersionLoad test0031ConfigurationInfoChanged test0040BasicVersionLoad test0050BasicVersionLoad test0060BasicVersionLoad test0061ConfigurationInfoChanged test0062InfoListChanged test0070BasicVersionLoad test0080BasicVersionLoad test0081BasicVersionLoad test0082ConfigurationInfoChanged test0083InfoListChanged test0090BasicVersionLoad test0091PackageMismatch test0101ConfigurationInfoDeleted test0120ConfigPackageSave ) ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/28/2012 13:34'! test0040BasicVersionLoad "Fourth test: - load configuration dkh.1 - send currentVersion to configInfo ... which record currentVersion - load version 1.0 and currentVersion should be updated to reflect fact that pacakges loaded." | configClass configClassName configInfo | gofer version: 'ConfigurationOfMBFooTests-dkh.1'. gofer load. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo printString = 'MBFooTests(dkh.1)'. self assert: configInfo currentVersion isNil. "load version 1.0" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.0') load. self assert: configInfo printString = 'MBFooTests 1.0(dkh.1)'. self assert: configInfo currentVersion versionString = '1.0'. self assert: configInfo printString = 'MBFooTests 1.0(dkh.1)'. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'dkh 3/10/2011 16:00'! test0062InfoListChanged | infoListChanged changedValuable configClassName configClass configInfo | infoListChanged := false. changedValuable := [ :ann | infoListChanged := true ]. [ configurationRoot announcer on: MBInfoListChanged do: changedValuable. "load configuration" configClassName := #ConfigurationOfMBFooTests. gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. self deny: infoListChanged. infoListChanged := false. configClassName := #ConfigurationOfMBFooTests. configClass := Smalltalk at: configClassName ifAbsent: []. configInfo := configurationRoot configurationInfoFor: configClass. "load 1.0" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.0') load. self deny: infoListChanged. infoListChanged := false. self assert: configInfo currentVersion versionString = '1.0'. configInfo infoList. "prime the pump" "load 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self assert: infoListChanged. ] ensure: [ configurationRoot announcer unsubscribe: changedValuable ]. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'dkh 3/10/2011 16:51'! test0111InfoListChanged | infoListChanged changedValuable configClassName configClass configInfo unloadGofer | infoListChanged := false. changedValuable := [ :ann | infoListChanged := true ]. [ configurationRoot announcer on: MBInfoListChanged do: changedValuable. "load configuration" gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. self deny: infoListChanged. infoListChanged := false. configClassName := #ConfigurationOfMBFooTests. configClass := Smalltalk at: configClassName ifAbsent: []. configInfo := configurationRoot configurationInfoFor: configClass. "load version 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self deny: infoListChanged. infoListChanged := false. self assert: configInfo currentVersion versionString = '1.2'. configInfo infoList. "prime the pump" "unload MBFooTests-dkh.3" unloadGofer := Gofer new. unloadGofer disablePackageCache. unloadGofer version: 'MBFooTests-dkh.3'. [ unloadGofer unload ] on: Warning do: [:ex | ex resume ]. self assert: infoListChanged. ] ensure: [ configurationRoot announcer unsubscribe: changedValuable ]. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/31/2012 17:51'! test0050BasicVersionLoad "Fifth test: - load configuration dkh.2(no events when loading version 1.1!!) - send currentVersion to configInfo ... which record currentVersion - load version 1.0 and currentVersion should be updated to reflect fact that pacakges loaded. - load version 1.1 and verify" | configClass configClassName configInfo | gofer version: 'ConfigurationOfMBFooTests-dkh.2'. gofer load. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo printString = 'MBFooTests(dkh.2)'. self assert: configInfo currentVersion isNil. "load version 1.0" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.0') load. self assert: configInfo printString = 'MBFooTests 1.0(dkh.2)'. self assert: configInfo currentVersion versionString = '1.0'. self assert: configInfo printString = 'MBFooTests 1.0(dkh.2)'. "load version 1.1" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.1') load. self flag: '...NOTE dkh.2 is identical to dkh.1and no events generated on load'. self assert: configInfo printString = 'MBFooTests 1.0(dkh.2)'. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/28/2012 14:08'! test0101ConfigurationInfoDeleted | createdValuable configClassName configInfoCreated configInfoChanged changedValuable configInfoDeleted deletedValuable configClass configInfo | configInfoDeleted := configInfoChanged := configInfoCreated := false. createdValuable := [ :ann | configInfoCreated := true ]. changedValuable := [ :ann | configInfoChanged := true ]. deletedValuable := [ :ann | configInfoDeleted := true ]. [ configurationRoot announcer on: MBConfigurationInfoCreated do: createdValuable. configurationRoot announcer on: MBConfigurationInfoChanged do: changedValuable. configurationRoot announcer on: MBConfigurationInfoDeleted do: deletedValuable. configClassName := #ConfigurationOfMBFooTests. "load configuration" gofer version: 'ConfigurationOfMBFooTests-dkh.1'. gofer load. self assert: configInfoCreated. self assert: configInfoChanged. self deny: configInfoDeleted. configInfoDeleted := configInfoChanged := configInfoCreated := false. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo printString = 'MBFooTests(dkh.1)'. "unload dkh.3" gofer unload. self deny: configInfoCreated. self assert: configInfoChanged. self assert: configInfoDeleted. configInfoDeleted := configInfoChanged := configInfoCreated := false. self assert: (configurationRoot configurations includes: configInfo) not. ] ensure: [ configurationRoot announcer unsubscribe: createdValuable; unsubscribe: deletedValuable; unsubscribe: changedValuable ]. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/28/2012 14:05'! test0100BasicConfigurationUnload "10: - load configuration dkh.3 - unload configuration" "load dkh.3" | configClassName configClass configInfo | gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo printString = 'MBFooTests(dkh.3)'. "unload dkh.3" gofer unload. self assert: (configurationRoot configurations includes: configInfo) not. ! ! !MBConfigurationRootTest methodsFor: 'running' stamp: 'dkh 3/9/2011 17:28'! tearDown configurationRoot ifNotNil: [ configurationRoot unregister ]. Smalltalk removeKey: #'MB_Foo_Test_Repository' ifAbsent: []. gofer := Gofer new. self tearDownPackages do: [:pkgName | (self hasPackage: pkgName) ifTrue: [ gofer package: pkgName ]]. gofer references notEmpty ifTrue: [ gofer unload ]. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/31/2012 17:56'! test0090BasicVersionLoad "9: - load configuration dkh.3 - load version 1.2 - edit class - verify state - revert MBFooTests-dkh.3 - validate" | configClass configClassName configInfo expected infos revertGofer | gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo printString = 'MBFooTests(dkh.3)'. self assert: configInfo currentVersion isNil. "load version 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self assert: (configInfo printString) = 'MBFooTests 1.2(dkh.3)'. self assert: configInfo currentVersion versionString = '1.2'. "modify class in MBFooTests project" (Smalltalk at: #MBFooTestA) compile: 'bar ^self' classified: 'mod'. self assert: (configInfo printString) = '* MBFooTests 1.2(dkh.3)'. self assert: configInfo asStringOrText isText. "packages" infos := configInfo packages. self assert: infos size = 1. expected := #('* MBFooTests-dkh.3'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index). self assert: info asStringOrText isText]. "revert MBFooTests-dkh.3" revertGofer := Gofer new. revertGofer disablePackageCache. gofer repositories do: [ :repo | revertGofer repository: repo ]. revertGofer version: 'MBFooTests-dkh.3'. [ revertGofer load ] on: Warning do: [:ex | ex resume ]. self assert: (configInfo printString) = '* MBFooTests 1.2(dkh.3)'. self assert: ((configInfo asStringOrText isString) or: (configInfo asStringOrText isText)). "packages" infos := configInfo packages. self assert: infos size = 1. expected := #('* MBFooTests-dkh.3'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index). self assert: ((info asStringOrText isString) or: (info asStringOrText isText))]. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'dkh 3/10/2011 08:08'! test0010BasicLoad "First test: - make sure that the configuration can be loaded without error - make sure that version 1.0 can be loaded without error" configurationRoot unregister. self assert: (Smalltalk at: #ConfigurationOfMBFooTests ifAbsent: []) isNil. gofer version: 'ConfigurationOfMBFooTests-dkh.1'. gofer load. ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.0') load. self assert: (Smalltalk at: #MBFooTestA ifAbsent: []) notNil ! ! !MBConfigurationRootTest methodsFor: 'scenarios' stamp: 'dkh 3/18/2011 19:00'! scenariosForTests " 1. select a configuration, then unload the configuration ... in OB you gtt an error because the project was undefined .... simulate by creating a ConfigurationOf class that is not a real configuration 2. add new configuration should associate the chosen repository with the configuration, too...maybe addConfigurationTest should check this 3. add new configuration then do checkpoing dev and note that dirty * is still on the label in the browser "! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/27/2012 16:40'! test0031ConfigurationInfoChanged "If you don't touch the currentVersion of a configurationInfo, then no changed event is signaled on load." | createdValuable configClassName configInfoCreated configInfoChanged changedValuable configInfoDeleted deletedValuable | configInfoDeleted := configInfoChanged := configInfoCreated := false. createdValuable := [ :ann | configInfoCreated := true ]. changedValuable := [ :ann | configInfoChanged := true ]. deletedValuable := [ :ann | configInfoDeleted := true ]. [ configurationRoot announcer on: MBConfigurationInfoCreated do: createdValuable. configurationRoot announcer on: MBConfigurationInfoChanged do: changedValuable. configurationRoot announcer on: MBConfigurationInfoDeleted do: deletedValuable. "load configuration" configClassName := #ConfigurationOfMBFooTests. gofer version: 'ConfigurationOfMBFooTests-dkh.1'. gofer load. self assert: configInfoCreated. self assert: configInfoChanged. self deny: configInfoDeleted. configInfoDeleted := configInfoChanged := configInfoCreated := false. "load 1.0" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.0') load. self deny: configInfoCreated. self assert: configInfoChanged. self deny: configInfoDeleted. ] ensure: [ configurationRoot announcer unsubscribe: createdValuable; unsubscribe: deletedValuable; unsubscribe: changedValuable ]. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'dkh 3/10/2011 16:03'! test0083InfoListChanged | infoListChanged changedValuable configClassName configClass configInfo | infoListChanged := false. changedValuable := [ :ann | infoListChanged := true ]. [ configurationRoot announcer on: MBInfoListChanged do: changedValuable. "load configuration" configClassName := #ConfigurationOfMBFooTests. gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. self deny: infoListChanged. infoListChanged := false. configClassName := #ConfigurationOfMBFooTests. configClass := Smalltalk at: configClassName ifAbsent: []. configInfo := configurationRoot configurationInfoFor: configClass. "load 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self deny: infoListChanged. infoListChanged := false. self assert: configInfo currentVersion versionString = '1.2'. configInfo infoList. "prime the pump" "modify class in MBFooTests project" (Smalltalk at: #MBFooTestA) compile: 'bar ^self' classified: 'mod'. self assert: infoListChanged. ] ensure: [ configurationRoot announcer unsubscribe: changedValuable ]. ! ! !MBConfigurationRootTest methodsFor: 'running' stamp: 'dkh 3/9/2011 17:24'! setUp | repo | super setUp. gofer := Gofer new. gofer disablePackageCache. repo := MBMonticelloPackagesResource current monticelloRepository. gofer repository: repo. Smalltalk at: #'MB_Foo_Test_Repository' put: repo. configurationRoot := MBConfigurationRoot new. configurationRoot register. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/28/2012 13:57'! test0060BasicVersionLoad "Sixth test: - load configuration dkh.3 - send currentVersion to configInfo ... which record currentVersion - load version 1.0 and currentVersion should be updated to reflect fact that pacakges loaded. - load version 1.2 and verify" | configClass configClassName configInfo | gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo printString = 'MBFooTests(dkh.3)'. self assert: configInfo currentVersion isNil. "load version 1.0" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.0') load. self assert: configInfo printString = 'MBFooTests 1.0(dkh.3)'. self assert: configInfo currentVersion versionString = '1.0'. self assert: configInfo printString = 'MBFooTests 1.0(dkh.3)'. "load version 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self assert: configInfo printString = 'MBFooTests 1.2(dkh.3)'. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/27/2012 15:48'! test0030BasicVersionLoad "Third test: - load configuration version dkh.1 - verfy that the target data structures are as expected - load version 1.0 - check that that expected changes to the data structures occur ... in this case that the package is loaded" | configClass configClassName configInfo versions versionInfo packages packageInfo text x | gofer version: 'ConfigurationOfMBFooTests-dkh.1'. gofer load. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo printString = 'MBFooTests(dkh.1)'. text := configInfo asStringOrText. self assert: text isString. self assert: text = 'MBFooTests(dkh.1)'. versions := configInfo versions. self assert: versions size = 1. versionInfo := versions first. packages := versionInfo packages. self assert: packages size = 1. packageInfo := packages first. self assert: packageInfo workingCopy isNil. self assert: packageInfo printString = 'MBFooTests ---'. text := packageInfo asStringOrText. self assert: text isString. self assert: text = 'MBFooTests ---'. "load version 1.0" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.0') load. self assert: configInfo printString = 'MBFooTests 1.0(dkh.1)'. self assert: configInfo currentVersion versionString = '1.0'. self assert: configInfo printString = 'MBFooTests 1.0(dkh.1)'. text := configInfo asStringOrText. self assert: text isString. self assert: text = 'MBFooTests 1.0(dkh.1)'. versions := configInfo versions. self assert: versions size = 1. "reacquire the packageInfo instance, since the old instance is not valid" versionInfo := versions first. packages := versionInfo packages. self assert: packages size = 1. packageInfo := packages first. self assert: packageInfo workingCopy notNil. self assert: packageInfo printString = 'MBFooTests-dkh.1'. text := packageInfo asStringOrText. self assert: text isString. self assert: text = 'MBFooTests-dkh.1'. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/28/2012 13:59'! test0081BasicVersionLoad "8.1: - load configuration dkh.3 - load version 1.2 - validate package and configInfo state - edit class - validate #recalculate variant for currentVersion" | configClass configClassName configInfo expected infos| gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo printString = 'MBFooTests(dkh.3)'. self assert: configInfo currentVersion isNil. self assert: configInfo asStringOrText = 'MBFooTests(dkh.3)'. "load version 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self assert: configInfo printString = 'MBFooTests 1.2(dkh.3)'. self assert: configInfo currentVersion versionString = '1.2'. self assert: configInfo printString = 'MBFooTests 1.2(dkh.3)'. self assert: configInfo asStringOrText = 'MBFooTests 1.2(dkh.3)'. "modify class in MBFooTests project" (Smalltalk at: #MBFooTestA) compile: 'bar ^self' classified: 'mod'. self assert: configInfo printString = '* MBFooTests 1.2(dkh.3)'. self assert: configInfo asStringOrText = '* MBFooTests 1.2(dkh.3)'. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/28/2012 14:09'! test0110BasicPackageUnload "load dkh.3" | configClassName configClass configInfo unloadGofer infos | gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo printString = 'MBFooTests(dkh.3)'. "load version 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. "unload MBFooTests-dkh.3" unloadGofer := Gofer new. unloadGofer disablePackageCache. unloadGofer version: 'MBFooTests-dkh.3'. [ unloadGofer unload ] on: Warning do: [:ex | ex resume ]. self assert: (configInfo printString) = 'MBFooTests(dkh.3)'. self assert: configInfo asStringOrText isString. "packages" infos := configInfo packages. self assert: infos size = 0. ! ! !MBConfigurationRootTest methodsFor: 'running' stamp: 'dkh 3/9/2011 17:34'! tearDownPackages ^#('MBFooTests' 'ConfigurationOfMBFooTests')! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'dkh 4/5/2011 15:52'! test0061ConfigurationInfoChanged "Touch the currentVersion of a configurationInfo, expect a changed event on load" | createdValuable configClassName configInfoCreated configInfoChanged changedValuable configInfoDeleted deletedValuable configInfo configClass | configInfoDeleted := configInfoChanged := configInfoCreated := false. createdValuable := [ :ann | configInfoCreated := true ]. changedValuable := [ :ann | configInfoChanged := true ]. deletedValuable := [ :ann | configInfoDeleted := true ]. [ configurationRoot announcer on: MBConfigurationInfoCreated do: createdValuable. configurationRoot announcer on: MBConfigurationInfoChanged do: changedValuable. configurationRoot announcer on: MBConfigurationInfoDeleted do: deletedValuable. "load configuration" configClassName := #ConfigurationOfMBFooTests. gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. self assert: configInfoCreated. self assert: configInfoChanged. self deny: configInfoDeleted. configInfoDeleted := configInfoChanged := configInfoCreated := false. configClassName := #ConfigurationOfMBFooTests. configClass := Smalltalk at: configClassName ifAbsent: []. configInfo := configurationRoot configurationInfoFor: configClass. "load 1.0" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.0') load. self deny: configInfoCreated. self assert: configInfoChanged. self deny: configInfoDeleted. configInfoDeleted := configInfoChanged := configInfoCreated := false. self assert: configInfo currentVersion versionString = '1.0'. configInfo packages. "prime the pump" "load 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self deny: configInfoCreated. self assert: configInfoChanged. self deny: configInfoDeleted. ] ensure: [ configurationRoot announcer unsubscribe: createdValuable; unsubscribe: deletedValuable; unsubscribe: changedValuable ]. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/28/2012 14:09'! test0120ConfigPackageSave "Issue 125 test - load configuration dkh.3 - load version 1.2 - modify configuration and validate - save configuration package and validate" | configClass configClassName configInfo expected infos suggestedName signature | "load configuration dkh.3" gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. "load version 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self assert: configInfo workingCopy notNil. self assert: configInfo printString = 'MBFooTests 1.2(dkh.3)'. self assert: configInfo currentVersion versionString = '1.2'. self assert: configInfo printString = 'MBFooTests 1.2(dkh.3)'. self assert: configInfo asStringOrText isString. "modify class in ConfigurationOfMBFooTests class" (Smalltalk at: #ConfigurationOfMBFooTests) compile: 'bar ^self' classified: 'mod'. self assert: configInfo printString = '* MBFooTests 1.2(dkh.3)'. self assert: configInfo asStringOrText isText. "save the configuraiton package" [ Gofer new disablePackageCache; repository: (MCDictionaryRepository new); package: configClassName asString; commit ] on: MCVersionNameAndMessageRequest do: [:ex | suggestedName := ex suggestedName. ex resume: { suggestedName. 'commit comment'}]. signature := suggestedName copyAfterLast: $-. self assert: configInfo printString = ('MBFooTests 1.2(', signature, ')'). self assert: configInfo asStringOrText isString. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 11/22/2013 11:14'! test0020BasicConfigurationLoad "Second test: - load configuration version dkh.1 - verify that config info added to root - validate that all of the data structures are correct .... based on the configuration. " | configClassName configClass configInfo baselines versions info packages text | configClassName := #ConfigurationOfMBFooTests. self assert: (Smalltalk at: configClassName ifAbsent: []) isNil. gofer version: 'ConfigurationOfMBFooTests-dkh.1'. gofer load. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. "configuration" configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo notNil. self assert: configInfo configurationClass == configClass. self assert: configInfo isDirty not. self assert: configInfo currentVersion isNil. self assert: configInfo name = configClassName asString. self assert: configInfo validate isEmpty. self assert: configInfo projects isEmpty. self assert: configInfo packages isEmpty. self assert: configInfo groups isEmpty. self assert: configInfo printString = 'MBFooTests(dkh.1)'. text := configInfo asStringOrText. self assert: text isString. self assert: text = 'MBFooTests(dkh.1)'. baselines := configInfo baselines. self assert: baselines size = 1. "baseline" info := baselines first. self assert: info version blessing == #baseline. self assert: info version versionString = '1.0-baseline'. self assert: info isDirty not. self assert: info validate isEmpty. self assert: info projects isEmpty. self assert: info groups isEmpty. packages := info packages. self assert: packages size = 1. info := packages first. self assert: info isDirty not. self assert: info packageName = 'MBFooTests'. self assert: (info spec isKindOf: MetacelloPackageSpec). self assert: info spec file = 'MBFooTests'. versions := configInfo versions. self assert: versions size = 2. "version" info := versions first. self assert: info version blessing == #release. self assert: info version versionString = '1.0'. self assert: info isDirty not. self assert: info validate isEmpty. self assert: info projects isEmpty. self assert: info groups isEmpty. packages := info packages. self assert: packages size = 1. info := packages first. self assert: info isDirty not. self assert: info packageName = 'MBFooTests'. self assert: (info spec isKindOf: MetacelloPackageSpec). self assert: info spec file = 'MBFooTests-dkh.1'. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/28/2012 13:59'! test0080BasicVersionLoad "Eighth test: - load configuration dkh.3 - load version 1.2 - validate package and configInfo state - edit class and validate" | configClass configClassName configInfo expected infos x | gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. configClassName := #ConfigurationOfMBFooTests. self assert: (configClass := Smalltalk at: configClassName ifAbsent: []) notNil. configInfo := configurationRoot configurationInfoFor: configClass. self assert: configInfo printString = 'MBFooTests(dkh.3)'. self assert: configInfo currentVersion isNil. "load version 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self assert: configInfo printString = 'MBFooTests 1.2(dkh.3)'. self assert: configInfo currentVersion versionString = '1.2'. self assert: configInfo printString = 'MBFooTests 1.2(dkh.3)'. self assert: configInfo asStringOrText isString. "versions" infos := configInfo versions. self assert: infos size = 3. expected := #(' @ 1.2' '1.1' '1.0 #stable'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index)]. "packages" infos := configInfo packages. self assert: infos size = 1. expected := #('MBFooTests-dkh.3'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index). self assert: info asStringOrText isString ]. "modify class in MBFooTests project" (Smalltalk at: #MBFooTestA) compile: 'bar ^self' classified: 'mod'. self assert: (x := configInfo printString) = '* MBFooTests 1.2(dkh.3)'. self assert: configInfo asStringOrText isText. "packages" infos := configInfo packages. self assert: infos size = 1. expected := #('* MBFooTests-dkh.3'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index). self assert: info asStringOrText isText]. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'dkh 3/10/2011 15:56'! test0032InfoListChanged | infoListChanged changedValuable | infoListChanged := false. changedValuable := [ :ann | infoListChanged := true ]. [ configurationRoot announcer on: MBInfoListChanged do: changedValuable. "load configuration" gofer version: 'ConfigurationOfMBFooTests-dkh.1'. gofer load. self deny: infoListChanged. infoListChanged := false. "load 1.0" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.0') load. self deny: infoListChanged. ] ensure: [ configurationRoot announcer unsubscribe: changedValuable ]. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'ChristopheDemarey 8/28/2012 14:05'! test0091PackageMismatch " - load configuration dkh.3 - load version 1.2 - validate package printString - load MBFooTests-dkh.4 - validate package printString " | configClass configClassName configInfo expected infos revertGofer | gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. configClassName := #ConfigurationOfMBFooTests. configClass := Smalltalk at: configClassName ifAbsent: []. configInfo := configurationRoot configurationInfoFor: configClass. "load version 1.1" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self assert: (configInfo printString) = 'MBFooTests 1.2(dkh.3)'. self assert: configInfo currentVersion versionString = '1.2'. "packages" infos := configInfo packages. self assert: infos size = 1. expected := #('MBFooTests-dkh.3'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index). self assert: info asStringOrText isString]. "load MBFooTests-dkh.4" gofer version: 'MBFooTests-dkh.4'. gofer load. "packages" infos := configInfo packages. self assert: infos size = 1. expected := #('MBFooTests-dkh.3[dkh.4]'). 1 to: infos size do: [:index | | info | info := infos at: index. self assert: info printString = (expected at: index). self assert: info asStringOrText isText]. ! ! !MBConfigurationRootTest methodsFor: 'tests' stamp: 'dkh 4/5/2011 15:52'! test0082ConfigurationInfoChanged | configInfoDeleted configInfoChanged configInfoCreated createdValuable changedValuable deletedValuable configClassName configClass configInfo | configInfoDeleted := configInfoChanged := configInfoCreated := false. createdValuable := [ :ann | configInfoCreated := true ]. changedValuable := [ :ann | configInfoChanged := true ]. deletedValuable := [ :ann | configInfoDeleted := true ]. [ configurationRoot announcer on: MBConfigurationInfoCreated do: createdValuable. configurationRoot announcer on: MBConfigurationInfoChanged do: changedValuable. configurationRoot announcer on: MBConfigurationInfoDeleted do: deletedValuable. "load configuration" gofer version: 'ConfigurationOfMBFooTests-dkh.3'. gofer load. self assert: configInfoCreated. self assert: configInfoChanged. self deny: configInfoDeleted. configInfoDeleted := configInfoChanged := configInfoCreated := false. configClassName := #ConfigurationOfMBFooTests. configClass := Smalltalk at: configClassName ifAbsent: []. configInfo := configurationRoot configurationInfoFor: configClass. "load version 1.2" ((Smalltalk at: #ConfigurationOfMBFooTests) project version: '1.2') load. self deny: configInfoCreated. self assert: configInfoChanged. self deny: configInfoDeleted. configInfoDeleted := configInfoChanged := configInfoCreated := false. self assert: configInfo currentVersion versionString = '1.2'. configInfo packages. "prime the pump" "modify class in MBFooTests project" (Smalltalk at: #MBFooTestA) compile: 'bar ^self' classified: 'mod'. self deny: configInfoCreated. self assert: configInfoChanged. self deny: configInfoDeleted. configInfoDeleted := configInfoChanged := configInfoCreated := false. ] ensure: [ configurationRoot announcer unsubscribe: createdValuable; unsubscribe: deletedValuable; unsubscribe: changedValuable ]. ! ! !MBCopyBaselineCommand commentStamp: 'TorstenBergmann 2/20/2014 14:11'! Command to copy a baseline in Versionner! !MBCopyBaselineCommand methodsFor: 'documentation' stamp: 'fds 2/26/2011 19:48'! documentation ^ 'Copy the selected baseline under a new name'! ! !MBCopyBaselineCommand methodsFor: 'accessing' stamp: 'dkh 3/20/2011 16:16'! title ^ 'copy baseline'! ! !MBCopyBaselineCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/18/2012 11:32'! copyBaselineWithNumber: baselineNumberAsString "Copy myself into a new baseline, with a different number" | sourceCode newSource newNumber newSelector comment | self assert: [ baselineNumberAsString ~= target versionString ] description: 'Cannot assign the same baseline number than me to my copy'. self assert: [ (baselineNumberAsString endsWith: 'baseline') not ] description: 'The baseline number cannot end with "-baseline". It will be automatically added.'. comment := self uiManager request: 'Enter a comment for the new baseline'. MetacelloToolBox createBaseline: baselineNumberAsString, '-baseline' for: target configurationBasename from: target versionString description: comment.! ! !MBCopyBaselineCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/18/2012 11:32'! execute | answer | answer := self uiManager request: 'give a new baseline number (the prefix "-baseline" will be added)'. answer ifNil: [ ^ self ]. self copyBaselineWithNumber: answer ! ! !MBDevCycleCommands commentStamp: 'TorstenBergmann 2/20/2014 14:09'! Common superclass for Versionner commands related to the development cycle! !MBGroupInfo commentStamp: ''! A MBGroupInfo holds information on a group defintiion. Instance Variables groupContents: an array with group contents as literals . ! !MBGroupInfo methodsFor: 'accessing' stamp: 'AlexandreBergel 3/27/2011 12:11'! groupContentsIfLoaded | version loadedPackageNames groupPackageNames | groupContents ~~ nil ifTrue: [ ^groupContents ]. groupContents := #(). self configurationInfo ifNil: [ ^ groupContents ]. (version := self configurationInfo currentVersion) ifNil: [ ^groupContents ]. loadedPackageNames := version defaultPackageNamesToLoad: #(). loadedPackageNames remove: 'default' ifAbsent: []. groupPackageNames := (version packagesForSpecNamed: self name) collect: [:spc | spc name ]. groupPackageNames do: [:nm | (loadedPackageNames includes: nm) ifFalse: [ ^groupContents ] ]. ^groupContents := self spec includes! ! !MBGroupInfo methodsFor: 'accessing' stamp: 'dkh 3/1/2011 11:51'! name: aName self shouldNotImplement! ! !MBGroupInfo methodsFor: 'accessing' stamp: 'dkh 3/1/2011 11:51'! name ^ self spec name! ! !MBGroupInfo methodsFor: '*versionner-spec-browser' stamp: 'TesterBob 10/5/2012 17:31'! accept: aVisitor ^ aVisitor visitGroup: self.! ! !MBGroupInfo methodsFor: 'printing' stamp: 'dkh 3/1/2011 20:03'! printOn: aStream | loadedPackageNames | super printOn: aStream. (loadedPackageNames := self groupContentsIfLoaded) isEmpty ifTrue: [ aStream nextPutAll: ' ---' ] ifFalse: [ aStream nextPutAll: ' [ '. loadedPackageNames do: [:pkgName | aStream nextPutAll: pkgName, ' ' ]. aStream nextPut: $] ].! ! !MBGroupInfo methodsFor: 'accessing' stamp: 'dkh 3/2/2011 21:42'! typeLabel ^'group'! ! !MBGroupInfo class methodsFor: 'accessing' stamp: 'dkh 4/10/2011 19:57'! helpLabel ^'Group'! ! !MBGroupInfoTest commentStamp: 'TorstenBergmann 2/20/2014 14:17'! SUnit tests for MBGroupInfo in Versionner! !MBGroupInfoTest methodsFor: 'tests' stamp: 'AlexandreBergel 3/27/2011 12:11'! testPrintOn | str | self shouldnt: [str := MBGroupInfo new printString] raise: Error. self assert: (str = 'nil ---'). ! ! !MBGroupInfoTest methodsFor: 'tests' stamp: 'AlexandreBergel 3/27/2011 12:11'! testgroupContentsIfLoaded self assert: MBGroupInfo new groupContentsIfLoaded isEmpty! ! !MBHelpCommand commentStamp: 'TorstenBergmann 2/20/2014 14:10'! Command to open help for Versionner! !MBHelpCommand methodsFor: 'execute' stamp: 'dkh 4/10/2011 21:20'! execute Smalltalk at: #HelpBrowser ifPresent: [ :class | ^class openOn: (Smalltalk at: #VersionnerHelp) ]. self workspaceHelp! ! !MBHelpCommand methodsFor: 'documentation' stamp: 'dkh 4/6/2011 15:10'! documentation ^ 'Open the help window'! ! !MBHelpCommand methodsFor: 'ordering' stamp: 'dkh 4/7/2011 22:20'! order ^'80'! ! !MBHelpCommand methodsFor: 'accessing' stamp: 'dkh 4/6/2011 15:11'! title ^ 'help'! ! !MBHelpCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/18/2012 11:32'! workspaceHelp | helpText | helpText := '"Versionner is a graphical tool to manage the dependencies and the version of your software. It is a complete replacement of the Monticello browser and acts as a facade for Metacello. You can use Versionner in a number of different scenarios. **1-Creating a new configuration** Press the button ''+Configuration'' and enter the name of your configuration. An initial baseline will also be produced. Your configuration and the new baseline will be listed on the left hand side of the browser. **2-Load a configuration** The first button of the browser is for loading a configuration from its corresponding SqueakSource project. For example, entering ''Pharo'' will try to load ''ConfigurationOfPharo'' from the ''Pharo'' squeaksource project. **3-Add a new baseline** A baseline defines the dependencies of your software, including the list of dependent configurations, and the list of packages that defines your applications. Selecting ''Add Baseline'' by right clicking on an existing baseline will first ask you about your squeaksource username and password will be requested. You then need to enter the version of your baseline (e.g., 0.1). The final step is to add the dependent packages. **4-Add a new version** A version defines the version of each packages used by your last baseline. At each change in your source code, you need to create a new version. Pressing ''save all and add development version'' by right clicking in a baseline or version may be the option you want to use. Versionner will try to guess what is the following number you need to use. Each unsaved dependent package is then saved. You need to enter a comment for the individual saved package. The configuration itself is then saved. At that stage, all your code is stored in squeaksource. **5-Reviewing recent changes** It may be useful to review your change, for example when you want to enter a comment when creating a version. At the bottom of the right hand side panel, you have the list of dependent packages. Modified packages will be designed with a ''*''. Right click on a package to see the difference with the last version stored in the squeaksource project. You can compare a package from the stable version of the software, or from the last commit made on squeaksource. **6-Load a baseline or a version** Simply right click on it and press ''load'' **7-Updating a configuration** In case of concurrent development, you may have to update your configuration. Right-click on the configuration, and press the corresponding menu entry. **8-Contact** Feedback are welcome. Send them to the pharo mailing list, or directly to the author alexandrebergel@me.com " '. self uiManager edit: helpText label: 'Versionner Help'! ! !MBInfo commentStamp: 'TorstenBergmann 2/20/2014 14:11'! Common superclass for Versionner infos! !MBInfo methodsFor: 'accessing' stamp: 'dkh 3/10/2011 12:37'! announcer ^self configurationRoot announcer! ! !MBInfo methodsFor: 'accessing' stamp: 'dkh 3/6/2011 14:54'! configurationRoot ^self configurationInfo configurationRoot! ! !MBInfo methodsFor: 'accessing' stamp: 'ChristopheDemarey 10/18/2012 10:50'! validate "Returns by default an empty collection of problems" ^#()! ! !MBInfo methodsFor: 'testing' stamp: 'dkh 2/27/2011 16:53'! interestedInPackageNamed: packageName ^false! ! !MBInfo methodsFor: 'accessing' stamp: 'dkh 3/6/2011 14:53'! configurationInfo ^self subclassResponsibility ! ! !MBInfo methodsFor: 'accessing' stamp: 'dkh 3/2/2011 16:39'! project "Answer the MetacelloProject associated with the receiver." ^nil! ! !MBInfo methodsFor: 'accessing' stamp: 'dkh 3/7/2011 21:45'! text: anObject text := anObject! ! !MBInfo methodsFor: 'accessing' stamp: 'dkh 3/7/2011 21:47'! text text ifNil: [ text := self buildStringOrText ]. ^text! ! !MBInfo methodsFor: 'actions' stamp: 'dkh 2/26/2011 11:46'! clearValidationIcon validationIcon := nil! ! !MBInfo methodsFor: 'accessing' stamp: 'dkh 2/26/2011 16:17'! browseValidationResults self validate explore! ! !MBInfo methodsFor: 'converting' stamp: 'dkh 3/7/2011 21:47'! asStringOrText ^self text! ! !MBInfo methodsFor: 'utils' stamp: 'dkh 3/4/2011 12:40'! repositories "Return the repositories associated with the receiver." ^#()! ! !MBInfo methodsFor: 'accessing' stamp: 'AlexandreBergel 1/1/2011 13:14'! name: aName name := aName! ! !MBInfo methodsFor: 'actions' stamp: 'dkh 2/27/2011 20:45'! validateFull self validationResult: nil. ^self validate! ! !MBInfo methodsFor: 'printing' stamp: 'AlexandreBergel 1/1/2011 14:14'! printOn: aStream self name ifNil: [ aStream nextPutAll: '' . ^ self ]. aStream nextPutAll: self name! ! !MBInfo methodsFor: 'accessing' stamp: 'dkh 2/27/2011 19:56'! validationResult: anObject validationResult := anObject! ! !MBInfo methodsFor: 'commands' stamp: 'dkh 2/28/2011 16:40'! commands ^ (self class allSelectors select: [ :k | k beginsWith: 'cmd' ]) collect: [ :k | self perform: k ]! ! !MBInfo methodsFor: 'utils' stamp: 'dkh 3/20/2011 09:40'! extractPackageSignatureFrom: aWorkingCopy | ref | (aWorkingCopy isNil or: [ aWorkingCopy ancestors isEmpty ]) ifTrue: [ ^ '' ]. ref := GoferVersionReference name: aWorkingCopy ancestors first name. ^ ref author , '.' , ref versionNumber asString! ! !MBInfo methodsFor: 'testing' stamp: 'AlexandreBergel 1/1/2011 15:08'! isDirty ^ false! ! !MBInfo methodsFor: 'accessing' stamp: 'dkh 3/7/2011 21:48'! buildStringOrText ^self printString! ! !MBInfo methodsFor: 'accessing' stamp: 'AlexandreBergel 1/1/2011 13:14'! name ^ name! ! !MBInfo class methodsFor: 'accessing' stamp: 'dkh 4/10/2011 19:55'! helpLabel self subclassResponsibility! ! !MBInfo class methodsFor: 'accessing' stamp: 'dkh 2/27/2011 19:57'! validateAll: aBool ValidateAll := aBool! ! !MBInfo class methodsFor: 'accessing' stamp: 'dkh 2/27/2011 19:57'! validateAll ValidateAll == nil ifTrue: [ ValidateAll := false ]. ^ValidateAll! ! !MBInfoListChanged commentStamp: 'TorstenBergmann 2/20/2014 14:05'! The info list changed! !MBInfoListChanged methodsFor: 'accessing' stamp: 'dkh 3/10/2011 18:29'! configurationInfo ^ configurationInfo! ! !MBInfoListChanged methodsFor: 'accessing' stamp: 'dkh 3/10/2011 18:29'! configurationInfo: anObject configurationInfo := anObject! ! !MBInfoListChanged class methodsFor: 'instance creation' stamp: 'dkh 3/10/2011 18:29'! changed: aConfigurationInfo ^(self new) configurationInfo: aConfigurationInfo; yourself! ! !MBInfoTest commentStamp: 'TorstenBergmann 2/20/2014 14:13'! Common SUnit tests for MBInfo! !MBInfoTest methodsFor: 'tests' stamp: 'dkh 3/2/2011 07:58'! testIsDirty "info is not dirty per default" self deny: MBInfo new isDirty! ! !MBInfoTest methodsFor: 'tests' stamp: 'dkh 3/4/2011 14:15'! testName | info | info := MBInfo new. self assert: (info name isNil). info name: 'foobar'. self assert: (info name = 'foobar'). self assert: (info printString = 'foobar'). ! ! !MBInspectConfigurationCommand commentStamp: 'TorstenBergmann 2/20/2014 14:08'! Command to inspect a configuration in versionner! !MBInspectConfigurationCommand methodsFor: 'accessing' stamp: 'fds 2/27/2011 10:47'! title ^ 'inspect'! ! !MBInspectConfigurationCommand methodsFor: 'documentation' stamp: 'fds 2/27/2011 10:47'! documentation ^ 'Open a Smalltalk inspector on the Configuration.'! ! !MBInspectConfigurationCommand methodsFor: 'execute' stamp: 'fds 2/27/2011 10:47'! execute target inspect! ! !MBLabelInfo commentStamp: 'TorstenBergmann 2/20/2014 14:12'! A label info! !MBLabelInfo methodsFor: 'accessing' stamp: 'dkh 2/26/2011 18:30'! validate ^nil! ! !MBLabelInfo methodsFor: 'accessing' stamp: 'dkh 3/6/2011 19:25'! validationIconSymbol ^#blank! ! !MBLabelInfo methodsFor: 'accessing' stamp: 'dkh 2/27/2011 20:02'! validationIcon ^nil! ! !MBLoadConfigurationCommand commentStamp: 'TorstenBergmann 2/20/2014 14:10'! Command to load a configuration in Versionner! !MBLoadConfigurationCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/18/2012 15:43'! askForProjectName ^ self pickRepositoryFrom: self repositories title: 'Choose the repository where project is located'! ! !MBLoadConfigurationCommand methodsFor: 'documentation' stamp: 'dkh 3/5/2011 15:27'! documentation ^ 'Load configuration from a repository'! ! !MBLoadConfigurationCommand methodsFor: 'ordering' stamp: 'dkh 4/7/2011 22:20'! order ^'10'! ! !MBLoadConfigurationCommand methodsFor: 'accessing' stamp: 'dkh 3/5/2011 15:26'! title ^ 'load configuration'! ! !MBLoadConfigurationCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 11/6/2012 15:29'! execute | projectRepository configRef configurationInfo versionInfos versionInfo version configRefMap configNames configName | projectRepository := self askForProjectName. projectRepository ifNil: [ ^ self ]. configRefMap := self configurationReferencesFrom: projectRepository. configRefMap isEmpty ifTrue: [ ^ self inform: 'No configurations found in the project repository ' , projectRepository description printString ]. configNames := configRefMap keys asSortedCollection asArray. configName := self uiManager chooseFrom: (configNames collect: [ :name | name configurationBaseName]) values: configNames title: 'Select the desired project'. configName ifNil: [ ^ self ]. configRef := (configRefMap at: configName) asSortedCollection asArray last. Gofer new repository: projectRepository; version: configRef name; load! ! !MBLoadConfigurationCommandTest methodsFor: 'tests' stamp: 'dkh 3/20/2011 14:15'! testExecute | block clsName | block := [(MBLoadConfigurationCommand target: nil) execute]. clsName := 'ConfigurationOfHomeSweetHome'. Smalltalk globals at: clsName ifPresent: [ :cls | (Smalltalk globals at: clsName) removeFromSystem ]. self should: [block valueSupplyingAnswers: { {'Name of the new Metacello configuration (e.g., ConfigurationOfYourSoftware)' . clsName} . {'Would you like to use http://www.squeaksource.com/HomeSweetHome, for your project?' . true} . {'Enter initial version number' . '1.0'} }] raise: Exception ! ! !MBLoadPackageCommand commentStamp: 'TorstenBergmann 2/20/2014 14:06'! Command to load a package in versionner! !MBLoadPackageCommand methodsFor: 'accessing' stamp: 'dkh 3/20/2011 16:15'! title ^ 'load ', target typeLabel! ! !MBLoadPackageCommand methodsFor: 'documentation' stamp: 'dkh 2/28/2011 11:53'! documentation ^ 'Perform a project load using the specified package or project as the load list.'! ! !MBLoadPackageCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/18/2012 11:32'! execute | answer | answer := self uiManager confirm: 'Are you sure you want to load using ', target packageName. answer ifTrue: [ | version | version := target configurationInfo currentVersion. version load: version defaultPackageNamesToLoad, { target packageName } ]! ! !MBLoadProjectFromArchiveCommand commentStamp: 'TorstenBergmann 2/20/2014 14:08'! Command to load project from archive in versionner! !MBLoadProjectFromArchiveCommand methodsFor: 'documentation' stamp: 'dkh 4/7/2011 19:54'! documentation ^ 'Load project from an archive.'! ! !MBLoadProjectFromArchiveCommand methodsFor: 'ordering' stamp: 'dkh 4/7/2011 22:23'! order ^'01'! ! !MBLoadProjectFromArchiveCommand methodsFor: 'accessing' stamp: 'dkh 4/7/2011 19:55'! title ^ 'load archive version'! ! !MBLoadProjectFromArchiveCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 11/6/2012 15:29'! execute | archiveRepository configRef configurationInfo versionInfos versionInfo version configRefMap configNames configName | archiveRepository := self pickRepositoryFrom: self repositories title: 'Choose the archive repository'. archiveRepository ifNil: [ ^ self ]. configRefMap := self configurationReferencesFrom: archiveRepository. configRefMap isEmpty ifTrue: [ ^ self inform: 'No configurations found in the archive repository ' , archiveRepository description printString ]. configNames := configRefMap keys. configName := self uiManager chooseFrom: (configNames collect: [ :name | name configurationBaseName]) values: configNames title: 'Select the desired project'. configName ifNil: [ ^ self ]. configRef := (configRefMap at: configName) asSortedCollection asArray last. (Gofer new) repository: archiveRepository; version: configRef name; load. configurationInfo := (MBConfigurationInfo configurationClass: (Smalltalk globals at: configRef packageName asSymbol)) configurationRoot: MBConfigurationRoot new; trimVersionLists: false; currentVersion: #notLoaded; yourself. versionInfos := configurationInfo versions. versionInfo := self uiManager chooseFrom: (versionInfos collect: [ :vrsn | vrsn printString ]) values: versionInfos title: 'Select the desired version'. versionInfo ifNil: [ ^ self ]. version := versionInfo version. version repositoryOverrides: {archiveRepository}. version load: version defaultPackageNamesToLoad! ! !MBMonticelloPackagesResource commentStamp: 'TorstenBergmann 2/20/2014 14:16'! A test resource for test purposes for Versionner! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'dkh 3/20/2011 10:09'! setUpPackagesMBFooTests "self reset" | versionInfo | versionInfo := self setUpPackageClassDefs: { #Object. #MBFooTestA. #(). #(). #(). } methodDefs: #() named: 'MBFooTests-dkh.1' ancestors: #(). versionInfo := self setUpPackageClassDefs: { #Object. #MBFooTestA. #(). #(). #(). } methodDefs: #() named: 'MBFooTests-dkh.2' ancestors: {versionInfo} . versionInfo := self setUpPackageClassDefs: { #Object. #MBFooTestA. #(). #(). #(). } methodDefs: #(MBFooTestA foo 'foo ^self') named: 'MBFooTests-dkh.3' ancestors: {versionInfo} . versionInfo := self setUpPackageClassDefs: { #Object. #MBFooTestA. #(). #(). #(). } methodDefs: #() named: 'MBFooTests-dkh.4' ancestors: {versionInfo} . ! ! !MBMonticelloPackagesResource methodsFor: 'accessing' stamp: 'dkh 3/9/2011 16:56'! monticelloRepository ^ monticelloRepository! ! !MBMonticelloPackagesResource methodsFor: 'running' stamp: 'dkh 3/9/2011 16:59'! setUpMonticelloRepository "This method builds a fake repository with the version references from #buildReferences." "self reset" monticelloRepository := MCDictionaryRepository new. ! ! !MBMonticelloPackagesResource methodsFor: 'accessing' stamp: 'dkh 3/9/2011 17:39'! project "self reset" | constructor project | "Construct Metacello project" project := MetacelloMCProject new. "Allow for customization of #projectAttributes" project projectAttributes: (Smalltalk at: #MBMonticelloPackagesResource) projectAttributes. MetacelloVersionConstructor on: self project: project. project loader: ((project loaderClass new) shouldDisablePackageCache: true; yourself). project loadType: #linear. ^project ! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBBranchTest' stamp: 'ChristopheDemarey 2/8/2013 17:40'! setUpConfigurationOfMBBranchTest2: ancestors "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfMBBranchTests.branch-dkh.2'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: reference packageName). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'isMetacelloConfig' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #isMetacelloConfig) asString. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionDevelopmentNotDefinedMBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionDevelopmentNotDefinedMBFooTest:) asString. MCMethodDefinition className: className asString selector: 'baseline10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baseline10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version11MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version11MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionStable11MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionStable11MBFooTest:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo! ! !MBMonticelloPackagesResource methodsFor: 'command tests' stamp: 'dkh 3/19/2011 14:40'! symbolicVersionBleedingEdge20baselineMBFooTest: spec "self reset" spec for: #'common' version: '2.0-baseline'.! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'dkh 3/10/2011 06:06'! version12MBFooTest: spec "self reset" spec for: #'common' do: [ spec blessing: #release. spec package: 'MBFooTests' with: 'MBFooTests-dkh.3' ]. ! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'ChristopheDemarey 2/8/2013 17:40'! setUpConfigurationOfMBFooTest1 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfMBFooTests-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: reference packageName). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'isMetacelloConfig' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #isMetacelloConfig) asString. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionDevelopmentNotDefinedMBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionDevelopmentNotDefinedMBFooTest:) asString. MCMethodDefinition className: className asString selector: 'baseline10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baseline10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionStable10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionStable10MBFooTest:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo! ! !MBMonticelloPackagesResource methodsFor: 'command tests' stamp: 'ChristopheDemarey 2/8/2013 17:40'! setUpConfigurationOfMBFooIssue117dkh3: ancestors "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfMBFooIssue117-dkh.3'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: reference packageName). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'isMetacelloConfig' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #isMetacelloConfig) asString. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionBleedingEdge20baselineMBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionBleedingEdge20baselineMBFooTest:) asString. MCMethodDefinition className: className asString selector: 'baseline10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baseline10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionStable10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionStable10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'baseline20MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baseline20MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'baseline30MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baseline30MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version11MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version11MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionStable10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionStable10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version12MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version12MBFooTest:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'dkh 3/9/2011 18:51'! version10MBFooTest: spec "self reset" spec for: #'common' do: [ spec blessing: #release. spec package: 'MBFooTests' with: 'MBFooTests-dkh.1' ]. ! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'dkh 3/10/2011 06:09'! setUpConfigurationOfMBFooTest "self reset" | versionInfo | versionInfo := self setUpConfigurationOfMBFooTest1. versionInfo := self setUpConfigurationOfMBFooTest2: { versionInfo }. versionInfo := self setUpConfigurationOfMBFooTest3: { versionInfo }. ! ! !MBMonticelloPackagesResource methodsFor: 'running' stamp: 'dkh 3/9/2011 16:56'! setUpPackageClassDefs: classDefArray named: pName ancestors: ancestors "self reset" ^self setUpPackageClassDefs: classDefArray methodDefs: #() named: pName ancestors: ancestors ! ! !MBMonticelloPackagesResource methodsFor: 'command tests' stamp: 'dkh 3/19/2011 14:41'! baseline30MBFooTest: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://MB_Foo_Test_Repository'. spec blessing: #baseline. spec package: 'MBFooTests'; yourself ]. ! ! !MBMonticelloPackagesResource methodsFor: 'command tests' stamp: 'dkh 3/19/2011 10:32'! symbolicVersionDevelopment10MBFooTest: spec "self reset" spec for: #'common' version: '1.0'.! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'dkh 3/10/2011 05:40'! symbolicVersionStable11MBFooTest: spec "self reset" spec for: #'common' version: '1.1'.! ! !MBMonticelloPackagesResource methodsFor: 'command tests' stamp: 'ChristopheDemarey 2/8/2013 17:40'! setUpConfigurationOfMBFooIssue117dkh1: ancestors "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfMBFooIssue117-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: reference packageName). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'isMetacelloConfig' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #isMetacelloConfig) asString. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionDevelopment10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionDevelopment10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'baseline10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baseline10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version11MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version11MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionStable10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionStable10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version12MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version12MBFooTest:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo! ! !MBMonticelloPackagesResource methodsFor: 'command tests' stamp: 'dkh 3/19/2011 14:28'! baseline20MBFooTest: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://MB_Foo_Test_Repository'. spec blessing: #baseline. spec package: 'MBFooTests'; yourself ]. ! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBBranchTest' stamp: 'ChristopheDemarey 2/8/2013 17:39'! setUpConfigurationOfMBBranchTest1 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfMBBranchTests-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: reference packageName). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'isMetacelloConfig' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #isMetacelloConfig) asString. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionDevelopmentNotDefinedMBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionDevelopmentNotDefinedMBFooTest:) asString. MCMethodDefinition className: className asString selector: 'baseline10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baseline10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionStable10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionStable10MBFooTest:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo! ! !MBMonticelloPackagesResource methodsFor: 'command tests' stamp: 'dkh 3/19/2011 09:56'! setUpPackagesMBCommandFooTests "self reset" self setUpPackageClassDefs: { #Object. #MBFooCommandTestA. #(). #(). #(). } methodDefs: #() named: 'MBFooCommandTestA-dkh.1' ancestors: #(). self setUpPackageClassDefs: { #Object. #MBFooCommandTestB. #(). #(). #(). } methodDefs: #() named: 'MBFooCommandTestB-dkh.1' ancestors: #(). ! ! !MBMonticelloPackagesResource methodsFor: 'running' stamp: 'dkh 4/17/2011 12:27'! setUp "self reset" super setUp. self setUpMonticelloRepository; setUpPackagesMBFooTests; setUpConfigurationOfMBFooTest; setUpPackagesMBCommandFooTests; setUpConfigurationOfMBFooIssue117; setUpConfigurationOfMBBranchTest! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'dkh 3/10/2011 05:41'! symbolicVersionDevelopmentNotDefinedMBFooTest: spec "self reset" spec for: #'common' version: #'notDefined'.! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'ChristopheDemarey 2/8/2013 17:40'! setUpConfigurationOfMBFooTest2: ancestors "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfMBFooTests-dkh.2'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: reference packageName). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'isMetacelloConfig' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #isMetacelloConfig) asString. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionDevelopmentNotDefinedMBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionDevelopmentNotDefinedMBFooTest:) asString. MCMethodDefinition className: className asString selector: 'baseline10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baseline10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version11MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version11MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionStable11MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionStable11MBFooTest:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'dkh 3/9/2011 23:16'! version11MBFooTest: spec "self reset" spec for: #'common' do: [ spec blessing: #release. spec package: 'MBFooTests' with: 'MBFooTests-dkh.2' ]. ! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'ChristopheDemarey 2/8/2013 17:40'! setUpConfigurationOfMBFooTest3: ancestors "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfMBFooTests-dkh.3'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: reference packageName). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'isMetacelloConfig' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #isMetacelloConfig) asString. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionDevelopmentNotDefinedMBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionDevelopmentNotDefinedMBFooTest:) asString. MCMethodDefinition className: className asString selector: 'baseline10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baseline10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version11MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version11MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionStable10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionStable10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version12MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version12MBFooTest:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'dkh 3/10/2011 05:40'! symbolicVersionStable10MBFooTest: spec "self reset" spec for: #'common' version: '1.0'.! ! !MBMonticelloPackagesResource methodsFor: 'running' stamp: 'EstebanLorenzano 2/12/2013 17:27'! setUpPackageClassDefs: classDefArray methodDefs: methodDefArray named: packageName ancestors: ancestors "self reset" | definitions superclassName className ivNames cvNames civNames versionInfo methodSelector methodSource basePackageName authorName | definitions := OrderedCollection new. basePackageName := packageName copyUpToLast: $-. authorName := (packageName copyAfterLast: $-) copyUpTo: $.. 1 to: classDefArray size by: 5 do: [:index | superclassName := (classDefArray at: index) asSymbol. className := (classDefArray at: index + 1) asSymbol. ivNames := (classDefArray at: index + 2). cvNames := (classDefArray at: index + 3). civNames := (classDefArray at: index + 4). definitions add: (MCOrganizationDefinition categories: (Array with: basePackageName)). definitions add: (MCClassDefinition name: className superclassName: superclassName category: basePackageName instVarNames: ivNames classVarNames: cvNames poolDictionaryNames: #() classInstVarNames: civNames comment: ''). (cvNames, ivNames) do: [:ivName | definitions addAll: { MCMethodDefinition className: className asString selector: ivName asSymbol category: 'cat' timeStamp: '' source: ivName, ' ^', ivName. MCMethodDefinition className: className asString selector: (ivName, ':') asSymbol category: 'cat' timeStamp: '' source: ivName, ': anObject ', ivName, ' := anObject'. } ]. civNames do: [:ivName | definitions addAll: { MCMethodDefinition className: className asString selector: ivName asSymbol category: 'cat' timeStamp: '' source: ivName, ' ^self class ', ivName. MCMethodDefinition className: className asString selector: (ivName, ':') asSymbol category: 'cat' timeStamp: '' source: ivName, ': anObject self class ', ivName, ': anObject'. MCMethodDefinition className: className asString classIsMeta: true selector: ivName asSymbol category: 'cat' timeStamp: '' source: ivName, ' ^', ivName. MCMethodDefinition className: className asString classIsMeta: true selector: (ivName, ':') asSymbol category: 'cat' timeStamp: '' source: ivName, ': anObject ', ivName, ' := anObject'. } ]. ivNames do: [:ivName| definitions add: (MCMethodDefinition className: className asString selector: #sampleValue category: 'cat' timeStamp: '' source: 'sampleValue ^#''', ivName, '''') ]. ]. 1 to: methodDefArray size by: 3 do: [:index | className := (methodDefArray at: index) asSymbol. methodSelector := (methodDefArray at: index + 1) asSymbol. methodSource := (methodDefArray at: index + 2). definitions add: (MCMethodDefinition className: className asString selector: methodSelector category: ('*', packageName) asString timeStamp: '' source: methodSource). ]. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MCPackage new name: basePackageName) info: (versionInfo := MCVersionInfo name: packageName id: UUID new message: 'This is a mock version' date: Date today time: Time now author: authorName ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitions asArray) dependencies: #()). ^versionInfo ! ! !MBMonticelloPackagesResource methodsFor: 'command tests' stamp: 'ChristopheDemarey 2/8/2013 17:40'! setUpConfigurationOfMBFooIssue117dkh2: ancestors "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfMBFooIssue117-dkh.2'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: reference packageName). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'isMetacelloConfig' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #isMetacelloConfig) asString. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: (self class class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #project) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionDevelopment10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionDevelopment10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'baseline10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baseline10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'baseline20MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baseline20MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version11MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version11MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'symbolicVersionStable10MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #symbolicVersionStable10MBFooTest:) asString. MCMethodDefinition className: className asString selector: 'version12MBFooTest:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version12MBFooTest:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo! ! !MBMonticelloPackagesResource methodsFor: 'command tests' stamp: 'dkh 3/23/2011 10:43'! setUpConfigurationOfMBFooIssue117 "self reset" | versionInfo | versionInfo := self setUpConfigurationOfMBFooIssue117dkh1: #(). versionInfo := self setUpConfigurationOfMBFooIssue117dkh2: #(). versionInfo := self setUpConfigurationOfMBFooIssue117dkh3: #(). ! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBFooTest' stamp: 'dkh 3/9/2011 18:51'! baseline10MBFooTest: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://MB_Foo_Test_Repository'. spec blessing: #baseline. spec package: 'MBFooTests'; yourself ]. ! ! !MBMonticelloPackagesResource methodsFor: 'ConfigurationOfMBBranchTest' stamp: 'dkh 4/17/2011 12:26'! setUpConfigurationOfMBBranchTest "self reset" | versionInfo | versionInfo := self setUpConfigurationOfMBBranchTest1. versionInfo := self setUpConfigurationOfMBBranchTest2: { versionInfo }. ! ! !MBMonticelloPackagesResource class methodsFor: 'accessing' stamp: 'dkh 3/10/2011 07:29'! isMetacelloConfig "Answer true and the Metacello tools will operate on you" ^true! ! !MBMonticelloPackagesResource class methodsFor: 'accessing' stamp: 'dkh 3/9/2011 17:17'! projectAttributes ^#()! ! !MBMonticelloPackagesResource class methodsFor: 'accessing' stamp: 'dkh 3/9/2011 17:18'! project ^self new project! ! !MBPackageChangesCommand commentStamp: 'TorstenBergmann 2/20/2014 14:06'! Command to browse package changes in versionner! !MBPackageChangesCommand methodsFor: 'utility' stamp: 'ChristopheDemarey 10/18/2012 11:32'! selectRepositoryOrSymbolicVersion: workingCopy | project symbolicVersions repos list values | project := target spec project. symbolicVersions := project symbolicVersionSymbols select: [ :each | project hasVersion: each ]. repos := workingCopy repositoryGroup repositories. list := (symbolicVersions collect: [:each | each printString]), (repos collect: [ :r | r description ]). values := symbolicVersions, repos. ^self uiManager chooseFrom: list values: values lines: {symbolicVersions size} title: 'Please choose which symbolic version or repository'. ! ! !MBPackageChangesCommand methodsFor: 'documentation' stamp: 'dkh 3/20/2011 14:01'! documentation ^ 'View changes to the package ancestor in the selected repository or the corresponding package version in the selected symbolic version.'! ! !MBPackageChangesCommand methodsFor: 'accessing' stamp: 'dkh 3/20/2011 16:41'! title ^ 'changes'! ! !MBPackageChangesCommand methodsFor: 'private' stamp: 'ChristopheDemarey 10/18/2012 11:32'! changesForSymbolicVersion: symbolicVersion workingCopy: wc | repository info ancestorVersion ref gofer resolved version packageSpec packageName ancestorVersionInfo | (repository := self selectRepositoryFromWorkingCopy: wc) ifNil: [ ^ self ]. info := target configurationInfo. version := info project version: symbolicVersion. packageSpec := version packageNamed: wc packageName ifAbsent: [ ^ self uiManager inform: 'No package to compare ', target name, ' to in version' , symbolicVersion printString ]. packageName := packageSpec file. ref := ((gofer := Gofer new) repository: repository; version: packageName) references first. (resolved := ref resolveAllWith: gofer) isEmpty ifTrue: [ ref := ((gofer := Gofer new) repository: repository; package: packageName) references first. resolved := ref resolveAllWith: gofer ]. ancestorVersionInfo := repository versionInfoFromVersionNamed: resolved last name. ancestorVersion := repository versionWithInfo: ancestorVersionInfo. self findChangesBetween: wc package snapshot toLabel: wc ancestry ancestorString , ' (' , info currentVersion versionString , ')' and: ancestorVersion snapshot fromLabel: ancestorVersion info name , ' (' , symbolicVersion printString , ' )'! ! !MBPackageChangesCommand methodsFor: 'execute' stamp: 'dkh 3/20/2011 12:50'! execute "View the changes made in the working copy." | wc repositoryOrSymbolicVersion | wc := target spec workingCopy ifNil: [ ^ self ]. wc ancestors isEmpty ifTrue: [ ^ self ]. (repositoryOrSymbolicVersion := self selectRepositoryOrSymbolicVersion: wc) ifNil: [ ^ self ]. repositoryOrSymbolicVersion isSymbol ifTrue: [ self changesForSymbolicVersion: repositoryOrSymbolicVersion workingCopy: wc] ifFalse: [ self findChangesFor: wc relativeToRepository: repositoryOrSymbolicVersion ]! ! !MBPackageHistoryCommand commentStamp: 'TorstenBergmann 2/20/2014 14:06'! Command to browse package history in versionner! !MBPackageHistoryCommand methodsFor: 'accessing' stamp: 'dkh 3/20/2011 14:03'! title ^ 'history'! ! !MBPackageHistoryCommand methodsFor: 'documentation' stamp: 'dkh 3/20/2011 14:04'! documentation ^ 'view package history'! ! !MBPackageHistoryCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/18/2012 17:39'! execute self browseVersionHistory! ! !MBPackageInfo commentStamp: 'TorstenBergmann 2/20/2014 14:12'! Infos about a package! !MBPackageInfo methodsFor: 'commands' stamp: 'DaleHenrichs 03/07/2011 15:36'! cmdSavePackage ^ MBSavePackageCommand! ! !MBPackageInfo methodsFor: 'accessing' stamp: 'dkh 3/2/2011 14:11'! classForBrowsing ^self workingCopy packageInfo classes anyOne! ! !MBPackageInfo methodsFor: 'commands' stamp: 'DaleHenrichs 03/07/2011 15:47'! cmdRevertPackage ^ MBRevertPackageCommand! ! !MBPackageInfo methodsFor: 'testing' stamp: 'dkh 3/9/2011 21:49'! interestedInPackageNamed: aString ^aString beginsWith: self packageName! ! !MBPackageInfo methodsFor: 'as yet unclassified' stamp: 'JuanPabloSandovalAlcocer 1/4/2012 15:15'! cmdLoad ^ MBLoadPackageCommand.! ! !MBPackageInfo methodsFor: 'as yet unclassified' stamp: 'JuanPabloSandovalAlcocer 1/8/2012 17:50'! versions "" |wc v| (wc := self workingCopy) isNil ifTrue: [ ^ #() ]. ^ (wc ancestry breadthFirstAncestors) collect: [ : vi| vi].! ! !MBPackageInfo methodsFor: 'utils' stamp: 'dkh 3/16/2011 06:03'! repositories "Return the repositories associated with the package." ^self spec workingCopy repositoryGroup repositories! ! !MBPackageInfo methodsFor: 'as yet unclassified' stamp: 'JuanPabloSandovalAlcocer 1/4/2012 14:04'! mbPacakgeName | string wc loadedPkgName attributes | string := ''. (wc := self workingCopy) isNil ifTrue: [ ^ string ]. attributes := OrderedCollection new. wc ancestry ancestors notEmpty ifTrue: [ loadedPkgName := wc ancestry ancestors first name. loadedPkgName = self name ifFalse: [ (self compareWorkingCopyNamed: loadedPkgName using: #<=) ifTrue: [ attributes add: TextColor red ]. attributes add: TextEmphasis bold ]]. self isDirty ifTrue: [ attributes add: TextEmphasis underlined ]. attributes notEmpty ifTrue: [ ^ Text string: string attributes: attributes ]. ^ string! ! !MBPackageInfo methodsFor: 'printing' stamp: 'JuanPabloSandovalAlcocer 1/1/2012 22:57'! printOn: aStream | wc | self isDirty ifTrue: [ aStream nextPutAll: '* ' ]. (wc := self workingCopy) isNil ifTrue: [ aStream nextPutAll: self packageName; nextPutAll: ' ---' ] ifFalse: [ wc ancestry ancestors notEmpty ifTrue: [ | loadedPkgName refString | loadedPkgName := wc ancestry ancestors first name. (refString := self extractPackageSignatureFrom: wc) notEmpty ifTrue: [ refString := '[' , refString , ']' ]. loadedPkgName = self name ifTrue: [ aStream nextPutAll: self name ] ifFalse: [ (self compareWorkingCopyNamed: loadedPkgName using: #<=) ifTrue: [ refString := Text string: refString attributes: TextColor red ]. aStream nextPutAll: self name; nextPutAll: refString ] ] ]! ! !MBPackageInfo methodsFor: 'accessing' stamp: 'AlexandreBergel 2/24/2011 14:52'! basePackageName ^ self packageName copyUpToLast: #-! ! !MBPackageInfo methodsFor: 'commands' stamp: 'dkh 3/20/2011 16:38'! cmdBrowsePackageHistory ^ MBPackageHistoryCommand ! ! !MBPackageInfo methodsFor: 'converting' stamp: 'DaleHenrichs 03/09/2011 11:03'! buildStringOrText | string wc loadedPkgName attributes | string := super buildStringOrText. (wc := self workingCopy) isNil ifTrue: [ ^ string ]. attributes := OrderedCollection new. wc ancestry ancestors notEmpty ifTrue: [ loadedPkgName := wc ancestry ancestors first name. loadedPkgName = self name ifFalse: [ (self compareWorkingCopyNamed: loadedPkgName using: #<=) ifTrue: [ attributes add: TextColor red ]. attributes add: TextEmphasis bold ]]. self isDirty ifTrue: [ attributes add: TextEmphasis underlined ]. attributes notEmpty ifTrue: [ ^ Text string: string attributes: attributes ]. ^ string! ! !MBPackageInfo methodsFor: 'testing' stamp: 'dkh 3/3/2011 07:57'! compareWorkingCopyNamed: wcName using: comarisonOperator | fileRef wcRef | fileRef := GoferResolvedReference name: self spec file. wcRef := GoferResolvedReference name: wcName. ^ wcRef compare: fileRef using: comarisonOperator! ! !MBPackageInfo methodsFor: 'testing' stamp: 'DaleHenrichs 03/09/2011 17:05'! currentVersionMismatch | wc loadedPkgName | (wc := self workingCopy) isNil ifTrue: [ ^ false ]. wc ancestry ancestors isEmpty ifTrue: [ ^ false ]. loadedPkgName := wc ancestry ancestors first name. loadedPkgName = self name ifTrue: [ ^false ]. ^ true ! ! !MBPackageInfo methodsFor: 'accessing' stamp: 'dkh 3/2/2011 21:42'! typeLabel ^'package'! ! !MBPackageInfo class methodsFor: 'accessing' stamp: 'dkh 4/10/2011 19:56'! helpLabel ^'Package'! ! !MBPackageInfoTest commentStamp: 'TorstenBergmann 2/20/2014 14:17'! SUnit tests for MBPackageInfo in Versionner! !MBPackageInfoTest methodsFor: 'tests' stamp: 'dkh 2/23/2011 21:22'! testPrintOn self assert: (package printString = 'FooBarZork ---').! ! !MBPackageInfoTest methodsFor: 'running' stamp: 'AlexandreBergel 1/16/2011 21:06'! tearDown " (Smalltalk includesKey: #TMPClass) ifTrue: [ (Smalltalk at: #TMPClass) removeFromSystem ]. "! ! !MBPackageInfoTest methodsFor: 'tests' stamp: 'ChristopheDemarey 2/28/2014 18:20'! testIsDirty "This test is likely to be bogus ... cannot just create a package for packages that don'e exist. see Metacello Issue 113" | cls | self deny: (package isDirty). self assert: (package printString = 'FooBarZork ---'). "We create a class" self deny: (Smalltalk includesKey: #TMPClass). cls := Object subclass: #TMPClass instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FooBarZork'. self assert: (package isDirty). "self assert: (package printString = 'FooBarZork ---')." (Smalltalk includesKey: #TMPClass) ifTrue: [ (Smalltalk at: #TMPClass) removeFromSystem ]. ! ! !MBPackageInfoTest methodsFor: 'tests' stamp: 'dkh 3/2/2011 08:03'! testInstantiation self should: [ MBPackageInfo new ] raise: Error. self should: [ MBPackageInfo named: #'FooBar' ] raise: AssertionFailure. self shouldnt: [ MBPackageInfo named: 'FooBar' ] raise: Error.! ! !MBPackageInfoTest methodsFor: 'running' stamp: 'dkh 3/2/2011 08:03'! setUp " (Smalltalk includesKey: #TMPClass) ifTrue: [ (Smalltalk at: #TMPClass) removeFromSystem ]. " " Smalltalk organization removeCategory: 'FooBarZork'." (MCPackage named: 'FooBarZork') unload. PackageOrganizer default unregisterPackageNamed: 'FooBarZork'. package := MBPackageInfo named: 'FooBarZork'.! ! !MBPackageInfoTest methodsFor: 'tests' stamp: 'DaleHenrichs 03/08/2011 13:41'! testWorkingCopy | orga workingCopy | self assert: (PackageOrganizer default packageNamed: 'FooBarZork' ifAbsent: []) isNil. package := MBPackageInfo named: 'FooBarZork'. workingCopy := package workingCopy. "creating a packageInfo for a package that is not currently loaded can create problems. see Metacello Issue 113" self assert: workingCopy isNil. ! ! !MBProjectInfo commentStamp: 'TorstenBergmann 2/20/2014 14:12'! Infos about a project! !MBProjectInfo methodsFor: 'accessing' stamp: 'dkh 2/26/2011 16:23'! validateIfAbsent: absentBlock ^MetacelloToolBox validateConfiguration: (Smalltalk at: self packageName asSymbol ifAbsent: absentBlock). ! ! !MBProjectInfo methodsFor: 'utils' stamp: 'dkh 3/16/2011 06:04'! repositories "Return the repositories associated with the configuration for the project." ^self spec projectPackage workingCopy repositoryGroup repositories! ! !MBProjectInfo methodsFor: 'accessing' stamp: 'dkh 3/6/2011 15:21'! currentVersion currentVersion == nil ifTrue: [ | projectClass version info | (projectClass := self spec projectClass) == nil ifTrue: [ currentVersion := ''. ^ currentVersion ]. (info := self configurationRoot configurationInfoFor: projectClass) == nil ifTrue: [ currentVersion := ''. ^ currentVersion ]. (currentVersion := info currentVersion) == nil ifTrue: [ currentVersion := ''. ^ currentVersion ]. currentVersion := currentVersion versionString ]. ^ currentVersion! ! !MBProjectInfo methodsFor: 'accessing' stamp: 'dkh 3/2/2011 14:08'! classForBrowsing ^self spec projectClass! ! !MBProjectInfo methodsFor: 'testing' stamp: 'dkh 3/6/2011 15:15'! interestedInPackageNamed: aString | projectClass version info | (projectClass := self spec projectClass) == nil ifTrue: [ ^ false ]. (aString beginsWith: projectClass name asString) ifTrue: [ ^ true ]. (info := self configurationRoot configurationInfoFor: projectClass) == nil ifTrue: [ ^ false ]. ^ info interestedInPackageNamed: aString! ! !MBProjectInfo methodsFor: 'accessing' stamp: 'dkh 2/27/2011 20:26'! validate validationResult == nil ifTrue: [ validationIcon := nil. validationResult := self validateIfAbsent: [ #() ] ]. ^ validationResult! ! !MBProjectInfo methodsFor: 'testing' stamp: 'dkh 4/9/2011 21:05'! interestedInConfigurationInfo: configInfo | projectClass | (projectClass := self spec projectClass) == nil ifTrue: [ ^ false ]. ^(self configurationRoot configurationInfoFor: projectClass) name = configInfo name ! ! !MBProjectInfo methodsFor: 'printing' stamp: 'dkh 3/3/2011 08:39'! printOn: aStream | cv specVersion | self isDirty ifTrue: [ aStream nextPutAll: '* ' ]. super printOn: aStream. (cv := self currentVersion) isEmpty ifTrue: [ aStream nextPutAll: ' ---' ] ifFalse: [ (specVersion := self spec versionOrNil) ~~ nil ifTrue: [ aStream nextPutAll: ' ' , specVersion versionString. cv asMetacelloVersionNumber = specVersion versionNumber ifFalse: [ aStream nextPutAll: ' [' , cv , ']' ] ] ]! ! !MBProjectInfo methodsFor: 'accessing' stamp: 'dkh 2/23/2011 20:46'! currentVersion: anObject currentVersion := anObject! ! !MBProjectInfo methodsFor: 'testing' stamp: 'DaleHenrichs 03/07/2011 12:32'! currentVersionMismatch | cv specVersion | (cv := self currentVersion) notEmpty ifTrue: [ (specVersion := self spec versionOrNil) ~~ nil ifTrue: [^ cv asMetacelloVersionNumber ~= specVersion versionNumber ]]. ^false! ! !MBProjectInfo methodsFor: 'converting' stamp: 'dkh 3/7/2011 21:53'! buildStringOrText | string cv projectClass info attributes specVersion | string := super buildStringOrText. attributes := OrderedCollection new. self isDirty ifTrue: [ attributes add: TextEmphasis underlined ]. (((projectClass := self spec projectClass) isNil or: [ (cv := self currentVersion) isEmpty ]) or: [ (specVersion := self spec versionOrNil) isNil ]) ifTrue: [ attributes notEmpty ifTrue: [ ^ Text string: string attributes: attributes ]. ^ string ]. self currentVersionMismatch ifTrue: [ attributes add: TextEmphasis bold ]. specVersion versionStatus == #somethingLoaded ifTrue: [ attributes add: TextColor red ]. attributes notEmpty ifTrue: [ ^ Text string: string attributes: attributes ]. ^ string! ! !MBProjectInfo methodsFor: 'accessing' stamp: 'dkh 3/2/2011 21:42'! typeLabel ^'project'! ! !MBProjectInfo class methodsFor: 'accessing' stamp: 'dkh 4/10/2011 19:56'! helpLabel ^'Project'! ! !MBRevertPackageCommand commentStamp: 'TorstenBergmann 2/20/2014 14:06'! Command to revert a package in versionner! !MBRevertPackageCommand methodsFor: 'documentation' stamp: 'DaleHenrichs 03/07/2011 15:43'! documentation ^ 'Revert the changes that have been made to this package.'! ! !MBRevertPackageCommand methodsFor: 'accessing' stamp: 'DaleHenrichs 03/07/2011 15:43'! title ^ 'revert'! ! !MBRevertPackageCommand methodsFor: 'private' stamp: 'ChristopheDemarey 10/18/2012 11:03'! pickAncestorVersionInfo | ancestors | ancestors := target workingCopy ancestry breadthFirstAncestors. ^self uiManager chooseFrom: (ancestors collect: [:ea | ea name]) values: ancestors title: 'Package:' ! ! !MBRevertPackageCommand methodsFor: 'execute' stamp: 'DaleHenrichs 03/07/2011 15:46'! execute self pickAncestorVersionInfo ifNotNilDo: [:info | (target workingCopy repositoryGroup versionWithInfo: info ifNone: [^self inform: 'No repository found for ', info name] ) load]. ! ! !MBSaveConfigurationCommand commentStamp: 'TorstenBergmann 2/20/2014 14:08'! Command to load a configuration in versionner! !MBSaveConfigurationCommand methodsFor: 'execute' stamp: 'JuanPabloSandovalAlcocer 7/11/2012 13:35'! executeWithMessage: message "execute with message" self checkUserInRepositoryOfPackage: self configurationClass name asString. MetacelloToolBox saveConfigurationPackageFor: self configurationClass name asString description: message! ! !MBSaveConfigurationCommand methodsFor: 'documentation' stamp: 'dkh 3/20/2011 16:14'! documentation ^ 'Save the configuration in its repository. Note that the dependents projects and defined packages are not saved. Use ''checkpoint dev'' command to save packages.'! ! !MBSaveConfigurationCommand methodsFor: 'accessing' stamp: 'AlexandreBergel 4/15/2011 09:26'! title ^ 'save configuration'! ! !MBSaveConfigurationCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/18/2012 11:32'! execute | message | message := self uiManager multilineRequest: 'Enter commit message' initialAnswer: ''. message == nil ifTrue: [ ^ self ]. self executeWithMessage: message! ! !MBSavePackageCommand commentStamp: 'TorstenBergmann 2/20/2014 14:06'! Command to save a package in versionner! !MBSavePackageCommand methodsFor: 'accessing' stamp: 'DaleHenrichs 03/07/2011 15:33'! title ^ 'save'! ! !MBSavePackageCommand methodsFor: 'documentation' stamp: 'DaleHenrichs 03/07/2011 15:33'! documentation ^ 'Save a new version of the mcz for the given repository in its repository.'! ! !MBSavePackageCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 8/23/2013 17:04'! execute | message repo gofer | message := self uiManager multilineRequest: 'Enter commit message' initialAnswer: ''. message == nil ifTrue: [ ^ self ]. repo := self checkUserInRepositoryOfPackage: target spec name. gofer := Gofer new. gofer disablePackageCache. gofer repository: repo. gofer package: target spec name. gofer commit: message! ! !MBSetUserCommand commentStamp: 'TorstenBergmann 2/20/2014 14:08'! Command to bset the user in Versionner! !MBSetUserCommand methodsFor: 'as yet unclassified' stamp: 'AlexandreBergel 3/28/2011 09:27'! title ^ 'set user and password'! ! !MBSetUserCommand methodsFor: 'as yet unclassified' stamp: 'AlexandreBergel 3/28/2011 09:27'! documentation ^ 'Set the user and password used when saving and loading packages and configurations.'! ! !MBSetUserCommand methodsFor: 'as yet unclassified' stamp: 'dkh 4/5/2011 21:22'! execute target configurationRoot username: nil. target configurationRoot password: nil. self username. self password.! ! !MBSpecInfo commentStamp: ''! A MBSpecInfo holds information on Metacello specifications. Instance Variables configurationInfo: the object holding information on the whole configuration. spec: the specification of this object (a MetacelloSpec). ! !MBSpecInfo methodsFor: 'commands' stamp: 'dkh 3/4/2011 05:00'! cmdLoadSpecCommand ^ MBLoadPackageCommand! ! !MBSpecInfo methodsFor: 'accessing' stamp: 'dkh 3/1/2011 11:47'! validate ^nil! ! !MBSpecInfo methodsFor: 'accessing' stamp: 'dkh 3/5/2011 18:05'! configurationInfo ^ configurationInfo! ! !MBSpecInfo methodsFor: 'accessing' stamp: 'dkh 3/2/2011 16:43'! project "Answer the MetacelloProject associated with the receiver." ^self spec project! ! !MBSpecInfo methodsFor: 'accessing' stamp: 'dkh 3/1/2011 11:47'! validationIcon ^nil! ! !MBSpecInfo methodsFor: 'accessing' stamp: 'dkh 3/1/2011 11:46'! spec: aMetacelloSpec spec := aMetacelloSpec ! ! !MBSpecInfo methodsFor: 'accessing' stamp: 'dkh 3/5/2011 18:05'! configurationInfo: anObject configurationInfo := anObject! ! !MBSpecInfo methodsFor: 'accessing' stamp: 'dkh 3/1/2011 11:57'! packageName ^self name! ! !MBSpecInfo methodsFor: 'accessing' stamp: 'dkh 3/6/2011 19:25'! validationIconSymbol ^#blank! ! !MBSpecInfo methodsFor: 'testing' stamp: 'JuanPabloSandovalAlcocer 1/1/2012 23:22'! isDirty | wc | wc := self workingCopy. wc ifNil: [ ^false ]. ^wc needsSaving! ! !MBSpecInfo methodsFor: 'testing' stamp: 'DaleHenrichs 03/07/2011 12:38'! currentVersionMismatch ^false! ! !MBSpecInfo methodsFor: 'accessing' stamp: 'dkh 3/1/2011 11:46'! spec ^spec! ! !MBSpecInfo methodsFor: 'accessing' stamp: 'dkh 3/2/2011 21:41'! typeLabel ^''! ! !MBSpecInfo class methodsFor: 'instance creation' stamp: 'DaleHenrichs 03/05/2011 11:15'! spec: aMetacelloSpec "Create an instance of myself with the given spec" ^(super new) spec: aMetacelloSpec! ! !MBSpecInfoTest commentStamp: 'TorstenBergmann 2/20/2014 14:17'! SUnit tests for MBSpecInfo in Versionner! !MBSpecInfoTest class methodsFor: 'testing' stamp: 'topa 4/15/2011 09:50'! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^ self name = #MBSpecInfoTest! ! !MBValidateAllConfigurationCommand commentStamp: 'TorstenBergmann 2/20/2014 14:09'! Command to validate all configurations in versionner! !MBValidateAllConfigurationCommand methodsFor: 'accessing' stamp: 'dkh 3/2/2011 08:38'! title ^ 'validate all configurations'! ! !MBValidateAllConfigurationCommand methodsFor: 'documentation' stamp: 'dkh 2/28/2011 20:48'! documentation ^ 'Validate all configuration.'! ! !MBValidateAllConfigurationCommand methodsFor: 'execute' stamp: 'ChristopheDemarey 10/18/2012 11:44'! execute self showExecuteWhile: [ target configurationRoot configurations doWithIndex: [ :info :index | info validateFull ] ]! ! !MBVersionCommand commentStamp: 'TorstenBergmann 2/20/2014 14:11'! Superclass for commands on versions! !MBVersionInfo commentStamp: 'TorstenBergmann 2/20/2014 14:12'! A version info! !MBVersionInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 11/13/2013 13:18'! cmdSetDescription ^ VSSetDescriptionCommand! ! !MBVersionInfo methodsFor: 'commands' stamp: 'ChristopheDemarey 11/20/2013 17:48'! cmdReleaseDevelopmentVersion ^ VSReleaseDevelopmentVersionCommand! ! !MBVersionInfo methodsFor: 'printing' stamp: 'dkh 2/24/2011 15:33'! printOn: aStream super printOn: aStream. self isDevelopment ifTrue: [ aStream nextPutAll: ' #development'. ^self ]. self isStable ifTrue: [ aStream nextPutAll: ' #stable' ].! ! !MBVersionInfo class methodsFor: 'accessing' stamp: 'dkh 4/10/2011 19:56'! helpLabel ^'Version'! ! !MCAddition commentStamp: ''! A MCAddition represents the operation to add an entity to a snapshot. ! !MCAddition methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:32'! definition ^ definition! ! !MCAddition methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:45'! fromSource ^ ''! ! !MCAddition methodsFor: 'accessing' stamp: 'LucasGiudice 9/14/2013 15:02'! toSource ^ definition diffSource! ! !MCAddition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 15:33'! selector ^ definition selector! ! !MCAddition methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:09'! targetDefinition ^ definition! ! !MCAddition methodsFor: 'testing' stamp: 'nk 2/25/2005 17:28'! isClassPatch ^definition isClassDefinition! ! !MCAddition methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:17'! targetClass ^definition actualClass ! ! !MCAddition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 15:10'! isMethodPatch ^ definition isMethodDefinition! ! !MCAddition methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:22'! isAddition ^ true! ! !MCAddition methodsFor: '*Komitter-UI' stamp: 'NicolaiHess 4/8/2014 20:02'! koClass | klass | klass := definition koClass. klass ifNil: [ ^ nil ]. definition addOperation: self on: klass. self isClassPatch ifTrue: [ klass added: true ]. ^ klass! ! !MCAddition methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/28/2011 15:25'! summary ^ definition summary! ! !MCAddition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/26/2013 14:42'! koDefinition ^ (KomitDefinition definition: self definition) operation: self; added: true; yourself! ! !MCAddition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:19'! koDestinationText ^ definition koDestinationText! ! !MCAddition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:21'! koSourceText ^ ''! ! !MCAddition methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:39'! sourceString ^(self toSource asText) addAttribute: TextColor red; yourself! ! !MCAddition methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 14:53'! basicApplyTo: anObject anObject addDefinition: definition! ! !MCAddition methodsFor: 'accessing' stamp: 'ab 8/22/2003 02:26'! inverse ^ MCRemoval of: definition! ! !MCAddition methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! intializeWithDefinition: aDefinition definition := aDefinition! ! !MCAddition methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:09'! baseDefinition ^ nil! ! !MCAddition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/25/2013 18:21'! koMethod ^ (KomitMethod method: self definition) operation: self; added: true; yourself! ! !MCAddition class methodsFor: 'instance-creation' stamp: 'cwp 11/27/2002 10:03'! of: aDefinition ^ self new intializeWithDefinition: aDefinition! ! !MCAncestry commentStamp: ''! Abstract superclass of records of ancestry.! !MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/17/2005 16:03'! withBreadthFirstAncestors ^ (Array with: self), self breadthFirstAncestors! ! !MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'! ancestorString ^ String streamContents: [:s | self ancestors do: [:ea | s nextPutAll: ea name] separatedBy: [s nextPutAll: ', ']]! ! !MCAncestry methodsFor: 'ancestry' stamp: 'bf 12/22/2004 21:55'! ancestorsDoWhileTrue: aBlock self ancestors do: [:ea | (aBlock value: ea) ifTrue: [ea ancestorsDoWhileTrue: aBlock]]! ! !MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/14/2004 15:21'! stepChildrenString ^ String streamContents: [:s | self stepChildren do: [:ea | s nextPutAll: ea name] separatedBy: [s nextPutAll: ', ']]! ! !MCAncestry methodsFor: 'ancestry' stamp: 'jrp 7/12/2004 08:16'! hasAncestor: aVersionInfo alreadySeen: aList (aList includes: self) ifTrue: [^ false]. aList add: self. ^ self = aVersionInfo or: [self ancestors anySatisfy: [:ea | ea hasAncestor: aVersionInfo alreadySeen: aList]] ! ! !MCAncestry methodsFor: 'ancestry' stamp: 'stephaneducasse 2/4/2006 20:47'! breadthFirstAncestorsDo: aBlock | seen todo next | seen := Set with: self. todo := OrderedCollection with: self. [todo isEmpty] whileFalse: [next := todo removeFirst. next ancestors do: [:ea | (seen includes: ea) ifFalse: [aBlock value: ea. seen add: ea. todo add: ea]]]! ! !MCAncestry methodsFor: 'ancestry' stamp: 'stephaneducasse 2/4/2006 20:47'! commonAncestorsWith: aVersionInfo | sharedAncestors mergedOrder sorter | sorter := MCVersionSorter new addVersionInfo: self; addVersionInfo: aVersionInfo. mergedOrder := sorter sortedVersionInfos. sharedAncestors := (sorter allAncestorsOf: self) intersection: (sorter allAncestorsOf: aVersionInfo). ^ mergedOrder select: [:ea | sharedAncestors includes: ea]! ! !MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'! allAncestorsOnPathTo: aVersionInfo ^ MCFilteredVersionSorter new target: aVersionInfo; addAllVersionInfos: self ancestors; sortedVersionInfos! ! !MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'! ancestors ^ ancestors ifNil: [#()]! ! !MCAncestry methodsFor: 'ancestry' stamp: 'nice 1/5/2010 15:59'! topologicalAncestors ^ Array streamContents: [:s | | f frontier | frontier := MCFrontier frontierOn: self. [f := frontier frontier. s nextPutAll: f. frontier removeAll: f. f isEmpty] whileFalse] ! ! !MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:57'! allAncestorsDo: aBlock self ancestors do: [:ea | aBlock value: ea. ea allAncestorsDo: aBlock]! ! !MCAncestry methodsFor: 'ancestry' stamp: 'bp 11/21/2010 18:33'! ancestorStringWithout: packageName ^ String streamContents: [:s | self ancestors do: [:ea | s nextPutAll: (ea nameWithout: packageName)] separatedBy: [s nextPutAll: ', ']]! ! !MCAncestry methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:02'! initialize super initialize. ancestors := #(). stepChildren := #()! ! !MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/17/2005 16:03'! breadthFirstAncestors ^ Array streamContents: [:s | self breadthFirstAncestorsDo: [:ea | s nextPut: ea]]! ! !MCAncestry methodsFor: 'ancestry' stamp: 'stephaneducasse 2/4/2006 20:47'! commonAncestorWith: aNode | commonAncestors | commonAncestors := self commonAncestorsWith: aNode. ^ commonAncestors at: 1 ifAbsent: [nil]! ! !MCAncestry methodsFor: 'ancestry' stamp: 'jrp 7/12/2004 08:16'! hasAncestor: aVersionInfo ^ self hasAncestor: aVersionInfo alreadySeen: OrderedCollection new! ! !MCAncestry methodsFor: 'ancestry' stamp: 'avi 2/12/2004 20:58'! isRelatedTo: aVersionInfo ^ aVersionInfo timeStamp < self timeStamp ifTrue: [self hasAncestor: aVersionInfo] ifFalse: [aVersionInfo hasAncestor: self]! ! !MCAncestry methodsFor: 'ancestry' stamp: 'avi 9/11/2004 15:08'! stepChildren ^ stepChildren ifNil: [#()]! ! !MCAncestryTest methodsFor: 'tests' stamp: 'jf 8/16/2003 20:45'! testLinearPath self assertPathTo: #b1 is: #(b3 b2)! ! !MCAncestryTest methodsFor: 'tests' stamp: 'jf 8/16/2003 20:42'! testPathToMissingAncestor self assert: (self tree allAncestorsOnPathTo: MCVersionInfo new) isEmpty! ! !MCAncestryTest methodsFor: 'building' stamp: 'jf 8/16/2003 21:21'! tree ^ self treeFrom: #(c1 ((e2 ((e1 ((a1 (('00'))))))) (a2 ((a1 (('00'))))) (b3 ((b2 ((b1 ((b0 (('00'))))))) (a1 (('00'))))) (d1)))! ! !MCAncestryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testDescendants | c1 a1 b3 q1 q2 c2 | c1 := self tree. a1 := self treeFrom: #(a1 (('00'))). b3 := self treeFrom: #(b3 ((b2 ((b1 ((b0 (('00'))))))) (a1 (('00'))))). q1 := MCWorkingAncestry new addAncestor: a1. q2 := MCWorkingAncestry new addAncestor: q1. self assert: (q2 commonAncestorWith: b3) = a1. self assert: (b3 commonAncestorWith: q2) = a1. self assert: (q2 commonAncestorWith: c1) = a1. self assert: (c1 commonAncestorWith: q2) = a1. q1 addStepChild: c1. self assert: (q2 commonAncestorWith: c1) = q1. self assert: (c1 commonAncestorWith: q2) = q1. c2 := MCWorkingAncestry new addAncestor: c1. self assert: (q2 commonAncestorWith: c2) = q1. self assert: (c2 commonAncestorWith: q2) = q1. ! ! !MCAncestryTest methodsFor: 'building' stamp: 'marcus.denker 11/10/2008 10:04'! versionForName: name in: tree (tree name = name) ifTrue: [^ tree]. tree ancestors do: [:ea | (self versionForName: name in: ea) ifNotNil: [:v | ^ v]]. ^ nil! ! !MCAncestryTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! assertCommonAncestorOf: leftName and: rightName in: options in: tree | left right ancestor | left := self versionForName: leftName in: tree. right := self versionForName: rightName in: tree. ancestor := left commonAncestorWith: right. self assert: (options includes: ancestor name)! ! !MCAncestryTest methodsFor: 'tests' stamp: 'avi 9/17/2005 21:08'! testCommonAncestors self assertCommonAncestorOf: #a2 and: #e2 is: #a1 in: self tree. self assertCommonAncestorOf: #e2 and: #b3 is: #a1 in: self tree. self assertCommonAncestorOf: #b2 and: #e2 is: #'00' in: self tree. self assertCommonAncestorOf: #a4 and: #b5 in: #(b2 a1) in: self twoPersonTree. self assertCommonAncestorOf: #b5 and: #b3 is: #b2 in: self twoPersonTree. self assertCommonAncestorOf: #b2 and: #a4 is: #b2 in: self twoPersonTree. self assertCommonAncestorOf: #b2 and: #b2 is: #b2 in: self twoPersonTree. self assertCommonAncestorOf: #b2 and: #a1 is: #a1 in: self twoPersonTree. self assertCommonAncestorOf: #a1 and: #b2 is: #a1 in: self twoPersonTree.! ! !MCAncestryTest methodsFor: 'building' stamp: 'jf 8/16/2003 22:55'! twoPersonTree ^ self treeFrom: #(c1 ((a4 ((a1) (b3 ((b2 ((a1))))))) (b5 ((b2 ((a1)))))))! ! !MCAncestryTest methodsFor: 'asserting' stamp: 'avi 9/17/2005 21:09'! assertCommonAncestorOf: leftName and: rightName is: ancestorName in: tree self assertCommonAncestorOf: leftName and: rightName in: (Array with: ancestorName) in: tree! ! !MCAncestryTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! assertNamesOf: versionInfoCollection are: nameArray | names | names := versionInfoCollection collect: [:ea | ea name]. self assert: names asArray = nameArray! ! !MCAncestryTest methodsFor: 'asserting' stamp: 'jf 8/16/2003 23:42'! assertPathTo: aSymbol is: anArray self assertNamesOf: (self tree allAncestorsOnPathTo: (self treeFrom: {aSymbol})) are: anArray! ! !MCCacheRepository commentStamp: ''! I am a special monticello directory-based repository that is used for the global monticello cache. Most other repositories will first query the default cache repository for existing files before handling the request by themselves. For instance an http repository will first check if the file is in the caceh before doing a "slow" download.! !MCCacheRepository methodsFor: 'interface' stamp: 'CamilloBruni 4/20/2012 18:10'! versionWithInfo: aVersionInfo ifAbsent: errorBlock (self allFileNamesForVersionNamed: aVersionInfo name) do: [:fileName | | version | version := self versionFromFileNamed: fileName. version info = aVersionInfo ifTrue: [^ version]]. ^ errorBlock value! ! !MCCacheRepository methodsFor: 'utility' stamp: 'CamilloBruni 7/6/2012 16:20'! disable cacheEnabled := false.! ! !MCCacheRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! cacheForPackage: aPackage packageCaches ifNil: [packageCaches := Dictionary new]. ^ packageCaches at: aPackage ifAbsentPut: [MCPackageCache new]! ! !MCCacheRepository methodsFor: 'accessing' stamp: 'avi 1/22/2004 18:29'! rescan self newFileNames do: [:ea | self versionReaderForFileNamed: ea do: [:reader | (self cacheForPackage: reader package) recordVersionInfo: reader info forFileNamed: ea. self seenFileNames add: ea]] displayingProgress: 'Scanning cache...'! ! !MCCacheRepository methodsFor: 'instance-creation' stamp: 'avi 1/22/2004 18:15'! newFileNames ^ self allFileNames difference: self seenFileNames! ! !MCCacheRepository methodsFor: 'utility' stamp: 'CamilloBruni 7/6/2012 16:20'! disableCacheDuring: aBlock self disable. aBlock ensure: [ self enable ].! ! !MCCacheRepository methodsFor: 'initialization' stamp: 'CamilloBruni 7/6/2012 16:20'! initialize cacheEnabled := true. super initialize.! ! !MCCacheRepository methodsFor: '*Komitter-Models' stamp: 'ChristopheDemarey 4/1/2014 17:35'! isCache "This is a bit hackish but we want to exclude the package cache which does not seem to be instance of a dedicated class" ^ (self description includesSubstring: 'package-cache')! ! !MCCacheRepository methodsFor: 'accessing' stamp: 'CamilloBruni 7/6/2012 16:13'! versionInfoForFileNamed: aString ^ self infoCache at: aString ifAbsentPut: [ self versionReaderForFileNamed: aString do: [:r | r info]]! ! !MCCacheRepository methodsFor: 'utility' stamp: 'CamilloBruni 7/6/2012 16:20'! enable cacheEnabled := true! ! !MCCacheRepository methodsFor: 'accessing' stamp: 'avi 1/22/2004 15:13'! packageForFileNamed: aString ^ self packageCache at: aString ifAbsentPut: [self versionReaderForFileNamed: aString do: [:r | r package]]! ! !MCCacheRepository methodsFor: 'storing' stamp: 'StephaneDucasse 8/17/2012 16:22'! basicStoreVersion: aVersion "we store a version if it is cacheable and we don't have the file already" (aVersion isCacheable and: [(self includesFileNamed: aVersion fileName) not]) ifTrue: [super basicStoreVersion: aVersion] ! ! !MCCacheRepository methodsFor: 'private' stamp: 'CamilloBruni 2/28/2012 20:10'! loadVersionFromFileNamed: aString ^ self versionReaderForFileNamed: aString do: [:r | r version]! ! !MCCacheRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! seenFileNames ^ seenFiles ifNil: [seenFiles := OrderedCollection new]! ! !MCCacheRepository methodsFor: 'storing' stamp: 'MarcusDenker 7/6/2012 16:59'! storeVersion: aVersion cacheEnabled == true ifFalse: [ ^ self ]. (self includesFileNamed: aVersion fileName) ifTrue: [ ^ self ]. ^ super storeVersion: aVersion.! ! !MCCacheRepository class methodsFor: 'utility' stamp: 'SeanDeNigris 7/17/2012 15:34'! disableCacheDuring: aBlock self uniqueInstance disableCacheDuring: aBlock! ! !MCCacheRepository class methodsFor: 'initialize-release' stamp: 'SeanDeNigris 7/17/2012 15:36'! initialize self resetIfInvalid! ! !MCCacheRepository class methodsFor: 'accessing' stamp: 'avi 10/9/2003 12:56'! description ^ nil! ! !MCCacheRepository class methodsFor: 'private' stamp: 'SeanDeNigris 7/17/2012 15:36'! resetIfInvalid "Reset if invalid" default notNil and: [default directory exists ifFalse: [default := nil]]! ! !MCCacheRepository class methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/24/2012 10:50'! default "This should be deleted as soon as Metacello is fixed" self flag: #toBeDeleted. ^ self uniqueInstance ! ! !MCCacheRepository class methodsFor: 'accessing settings' stamp: 'SeanDeNigris 7/17/2012 15:20'! cacheDirectory: directory "directory - can be an absolutePathString (to interface with the settings framework), or aFileReference" default := self new directory: directory asFileReference.! ! !MCCacheRepository class methodsFor: 'accessing settings' stamp: 'SeanDeNigris 7/17/2012 15:34'! cacheDirectory ^self uniqueInstance directory asAbsolute ! ! !MCCacheRepository class methodsFor: 'defaults' stamp: 'DamienCassou 12/20/2013 12:57'! defaultDirectory | directories | directories := {('package-cache' asFileReference). (FileLocator temp). (FileLocator home)}. directories do: [ :directory | [ ^ directory ensureCreateDirectory; yourself ] on: Error do: [ "ignore and try the next directory" ] ]. Error signal: 'Can''t create a package-cache'! ! !MCCacheRepository class methodsFor: 'accessing' stamp: 'SeanDeNigris 7/17/2012 15:38'! uniqueInstance self resetIfInvalid. ^ default ifNil: [default := self new directory: self defaultDirectory]! ! !MCChangeNotificationTest methodsFor: 'tests' stamp: 'EstebanLorenzano 9/12/2012 13:34'! testExtMethodModified | event mref | workingCopy modified: false. mref := workingCopy packageSet extensionMethods first. event := self modifiedEventFor: mref selector ofClass: mref actualClass. MCWorkingCopy methodModified: event. self assert: workingCopy modified! ! !MCChangeNotificationTest methodsFor: 'private' stamp: 'bf 5/20/2005 16:19'! foreignMethod "see testForeignMethodModified"! ! !MCChangeNotificationTest methodsFor: 'tests' stamp: 'bf 5/20/2005 19:54'! testCoreMethodModified | event | workingCopy modified: false. event := self modifiedEventFor: #one ofClass: self mockClassA. MCWorkingCopy methodModified: event. self assert: workingCopy modified! ! !MCChangeNotificationTest methodsFor: 'tests' stamp: 'bf 5/20/2005 17:00'! testForeignMethodModified | event | workingCopy modified: false. event := self modifiedEventFor: #foreignMethod ofClass: self class. MCWorkingCopy methodModified: event. self deny: workingCopy modified! ! !MCChangeNotificationTest methodsFor: 'running' stamp: 'GuillermoPolito 8/24/2012 14:25'! setUp "FIXME: Unregister Monticellomocks if it got created in another test (for example MCMethodDefinitionTest may create it implicitly). This avoids a nasty failure of MCChangeNotificationTest due to some inconsistency about the package info registered with it. If Monticellomocks was created earlier it will contain a 'regular' PackageInfo instance but the test requires it to be an MCMockPackageInfo" " MCWorkingCopy registry removeKey: (MCPackage new name: 'MonticelloMocks') ifAbsent:[]. PackageOrganizer default unregisterPackageNamed: 'MonticelloMocks'." workingCopy := MCWorkingCopy forPackage: self mockPackage.! ! !MCChangeNotificationTest methodsFor: 'events' stamp: 'GuillermoPolito 8/3/2012 13:56'! modifiedEventFor: aSelector ofClass: aClass | method | method := aClass compiledMethodAt: aSelector. ^ MethodModified methodChangedFrom: method to: method selector: aSelector inClass: aClass oldProtocol: nil newProtocol: nil requestor: nil. ! ! !MCChangeSelectionRequest commentStamp: 'TorstenBergmann 2/5/2014 13:45'! Notify about a change selection request! !MCChangeSelectionRequest methodsFor: '*MonticelloGUI' stamp: 'avi 9/14/2004 15:01'! defaultAction ^ (MCChangeSelector new patch: patch; label: label) showModally! ! !MCChangeSelectionRequest methodsFor: 'accessing' stamp: 'avi 9/14/2004 15:02'! label ^ label! ! !MCChangeSelectionRequest methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! patch: aPatch patch := aPatch! ! !MCChangeSelectionRequest methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! label: aString label := aString! ! !MCChangeSelectionRequest methodsFor: 'accessing' stamp: 'avi 9/11/2004 15:12'! patch ^ patch! ! !MCChangeSelector commentStamp: 'TorstenBergmann 2/20/2014 15:52'! Monticello selector for changes! !MCChangeSelector methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! kept ^ kept ifNil: [kept := Set new]! ! !MCChangeSelector methodsFor: 'morphic ui' stamp: 'avi 9/11/2004 16:07'! buttonSpecs ^ #((Select select 'Select these changes') (Cancel cancel 'Cancel the operation') )! ! !MCChangeSelector methodsFor: 'actions' stamp: 'avi 9/11/2004 16:26'! cancel self answer: nil! ! !MCChangeSelector methodsFor: 'selection' stamp: 'stephaneducasse 2/4/2006 20:47'! selectNone kept := Set new. self changed: #list! ! !MCChangeSelector methodsFor: 'morphic ui' stamp: 'avi 9/14/2004 15:01'! defaultLabel ^ 'Change Selector'! ! !MCChangeSelector methodsFor: 'multi-selection' stamp: 'avi 9/11/2004 16:22'! listSelectionAt: aNumber ^ self kept includes: (self items at: aNumber)! ! !MCChangeSelector methodsFor: 'actions' stamp: 'avi 9/11/2004 16:13'! innerButtonRow ^ self buttonRow: #(('Select All' selectAll 'select all changes') ('Select None' selectNone 'select no changes'))! ! !MCChangeSelector methodsFor: 'morphic ui' stamp: 'MarcusDenker 3/25/2013 13:06'! widgetSpecs ^#( ((buttonRow) (0 0 1 0) (0 0 0 30)) ((multiListMorph:selection:listSelection:menu: list selection listSelectionAt: methodListMenu:) (0 0 1 0.4) (0 30 0 0)) ((buttonRow: #(('Select All' selectAll 'select all changes') ('Select None' selectNone 'select no changes'))) (0 0.4 1 0.4) (0 0 0 30)) ((textMorph: text) (0 0.4 1 1) (0 30 0 0)) ) ! ! !MCChangeSelector methodsFor: 'multi-selection' stamp: 'stephaneducasse 2/4/2006 20:47'! listSelectionAt: aNumber put: aBoolean | item | item := self items at: aNumber. aBoolean ifTrue: [self kept add: item ] ifFalse: [self kept remove: item ifAbsent: []]! ! !MCChangeSelector methodsFor: 'emulating' stamp: 'avi 9/11/2004 16:26'! select self answer: (MCPatch operations: kept)! ! !MCChangeSelector methodsFor: 'selection' stamp: 'avi 9/14/2004 15:00'! selectAll kept addAll: self items. self changed: #list! ! !MCClassDefinition commentStamp: ''! A MCClassDefinition represents a class.! !MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/7/2003 23:35'! instanceVariablesString ^ self stringForVariablesOfType: #isInstanceVariable! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 17:41'! superclassName ^ superclassName! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'ab 12/5/2002 21:24'! description ^ Array with: name ! ! !MCClassDefinition methodsFor: 'printing' stamp: 'al 3/28/2006 23:42'! printDefinitionOn: stream stream nextPutAll: self superclassName; nextPutAll: self kindOfSubclass; nextPut: $# ; nextPutAll: self className; cr; tab. self hasTraitComposition ifTrue: [ stream nextPutAll: 'uses: '; nextPutAll: self traitCompositionString; cr; tab ]. stream nextPutAll: 'instanceVariableNames: '; store: self instanceVariablesString; cr; tab; nextPutAll: 'classVariableNames: '; store: self classVariablesString; cr; tab; nextPutAll: 'poolDictionaries: '; store: self sharedPoolsString; cr; tab; nextPutAll: 'category: '; store: self category asString! ! !MCClassDefinition methodsFor: 'comparing' stamp: 'StephaneDucasse 2/11/2012 09:14'! requirements ^superclassName == #nil ifTrue: [self poolDictionaries] ifFalse: [(Array with: superclassName), self poolDictionaries]! ! !MCClassDefinition methodsFor: 'testing' stamp: 'cwp 8/2/2003 02:54'! hasClassInstanceVariables ^ (self selectVariables: #isClassInstanceVariable) isEmpty not! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:33'! instVarNames ^ self selectVariables: #isInstanceVariable! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'ab 1/15/2003 13:42'! comment ^ comment! ! !MCClassDefinition methodsFor: 'installing' stamp: 'eem 4/30/2009 16:47'! stringForSortedVariablesOfType: aSymbol ^ String streamContents: [:stream | (self selectVariables: aSymbol) asSortedCollection do: [:ea | stream nextPutAll: ea] separatedBy: [stream space]]! ! !MCClassDefinition methodsFor: 'installing' stamp: 'cwp 2/3/2004 21:35'! stringForVariablesOfType: aSymbol ^ String streamContents: [:stream | (self selectVariables: aSymbol) do: [:ea | stream nextPutAll: ea] separatedBy: [stream space]]! ! !MCClassDefinition methodsFor: 'visiting' stamp: 'al 10/9/2005 19:33'! accept: aVisitor aVisitor visitClassDefinition: self. (self hasClassInstanceVariables or: [self hasClassTraitComposition]) ifTrue: [aVisitor visitMetaclassDefinition: self]. ! ! !MCClassDefinition methodsFor: 'testing' stamp: 'al 10/9/2005 21:59'! hasClassTraitComposition ^self classTraitCompositionString ~= '{}'! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:28'! selectVariables: aSelector ^ variables select: [:v | v perform: aSelector] thenCollect: [:v | v name]! ! !MCClassDefinition methodsFor: 'printing' stamp: 'cwp 11/24/2002 22:16'! kindOfSubclass type = #normal ifTrue: [^ ' subclass: ']. type = #words ifTrue: [^ ' variableWordSubclass: ']. type = #variable ifTrue: [^ ' variableSubclass: ']. type = #bytes ifTrue: [^ ' variableByteSubclass: ']. type = #weak ifTrue: [^ ' weakSubclass: ' ]. type = #compiledMethod ifTrue: [^ ' variableByteSubclass: ' ]. self error: 'Unrecognized class type'! ! !MCClassDefinition methodsFor: 'annotations' stamp: 'StephaneDucasse 12/30/2012 18:04'! printAnnotations: requests on: aStream "Add a string for an annotation pane, trying to fulfill the browser annotationRequests" requests do: [ :aRequest | aRequest == #requirements ifTrue: [ self requirements do: [ :req | aStream nextPutAll: req ] separatedBy: [ aStream space ]] ] separatedBy: [ aStream space ].! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:55'! traitCompositionString ^self traitComposition ifNil: ['{}'].! ! !MCClassDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 1/14/2009 13:41'! printClassDefinitionOn: stream "Print a class-side definition of the receiver on the given stream. Class instance variables and class traits." stream nextPutAll: self className; nextPutAll: ' class'; cr; tab. self hasClassTraitComposition ifTrue: [ stream nextPutAll: 'uses: '; nextPutAll: self classTraitCompositionString; cr; tab ]. stream nextPutAll: 'instanceVariableNames: '; store: self classInstanceVariablesString! ! !MCClassDefinition methodsFor: 'comparing' stamp: 'ab 5/24/2003 14:12'! provisions ^ Array with: name! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 11/24/2002 06:23'! category ^ category! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'ab 7/19/2003 18:00'! sortKey ^ self className! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:32'! classInstVarNames ^ self selectVariables: #isClassInstanceVariable! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'bf 8/29/2006 11:45'! sortedVariables "sort variables for comparison purposes" | sorted | sorted := variables select: [:var | var isOrderDependend]. sorted addAll: ((variables reject: [:var | var isOrderDependend]) asSortedCollection: [:a :b | a name <= b name]). ^sorted! ! !MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/7/2003 23:35'! classInstanceVariablesString ^ self stringForVariablesOfType: #isClassInstanceVariable! ! !MCClassDefinition methodsFor: '*Ring-Monticello' stamp: 'MartinDias 10/28/2013 16:16'! asRingDefinition | ring | ring:= (RGFactory current createClassNamed: self className) category: self category; superclassName: self superclassName; traitCompositionSource: self traitCompositionString; addInstanceVariables: self instVarNames; addClassVariables: self classVarNames; addSharedPools: self poolDictionaries; comment: self comment; stamp: self commentStamp; definitionSource: self definitionString; withMetaclass. ring theMetaClass traitCompositionSource: self classTraitCompositionString; addInstanceVariables: self classInstVarNames; definitionSource: self classDefinitionString. ^ring! ! !MCClassDefinition methodsFor: 'testing' stamp: 'ab 5/24/2003 13:49'! isCodeDefinition ^ true! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:53'! poolDictionaries ^ self selectVariables: #isPoolImport! ! !MCClassDefinition methodsFor: 'testing' stamp: 'al 10/9/2005 20:13'! hasComment ^ comment isEmptyOrNil not! ! !MCClassDefinition methodsFor: 'testing' stamp: 'al 3/29/2006 00:27'! hasTraitComposition ^self traitCompositionString ~= '{}'! ! !MCClassDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:52'! isClassDefinition ^ true! ! !MCClassDefinition methodsFor: 'initializing' stamp: 'NicoPaez 10/1/2010 10:41'! defaultCommentStamp ^ String new "The version below avoids stomping on stamps already in the image ^ (Smalltalk globals at: name ifPresent: [:c | c organization commentStamp]) ifNil: [''] " ! ! !MCClassDefinition methodsFor: 'printing' stamp: 'eem 4/30/2009 16:47'! classVariablesString ^ self stringForSortedVariablesOfType: #isClassVariable! ! !MCClassDefinition methodsFor: '*Komitter-UI' stamp: 'NicolaiHess 4/8/2014 20:01'! koClass self className ifNil: [ ^ nil ] ifNotNil: [ :cname | ^ KomitClass trackedClass: cname ]! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'lr 3/14/2010 21:13'! actualClass ^ Smalltalk globals classNamed: self className! ! !MCClassDefinition methodsFor: 'initializing' stamp: 'cwp 7/7/2003 23:19'! addVariables: aCollection ofType: aClass variables addAll: (aCollection collect: [:var | aClass name: var asString]).! ! !MCClassDefinition methodsFor: 'initializing' stamp: 'bf 8/12/2009 10:55'! initializeWithName: nameString superclassName: superclassString traitComposition: traitCompositionString classTraitComposition: classTraitCompositionString category: categoryString instVarNames: ivarArray classVarNames: cvarArray poolDictionaryNames: poolArray classInstVarNames: civarArray type: typeSymbol comment: commentString commentStamp: stampStringOrNil name := nameString asSymbol. superclassName := superclassString ifNil: ['nil'] ifNotNil: [superclassString asSymbol]. traitComposition := traitCompositionString. classTraitComposition := classTraitCompositionString. category := categoryString. name = #CompiledMethod ifTrue: [type := #compiledMethod] ifFalse: [type := typeSymbol]. comment := commentString withSqueakLineEndings. commentStamp := stampStringOrNil ifNil: [self defaultCommentStamp]. variables := OrderedCollection new. self addVariables: ivarArray ofType: MCInstanceVariableDefinition. self addVariables: cvarArray asSortedCollection ofType: MCClassVariableDefinition. self addVariables: poolArray asSortedCollection ofType: MCPoolImportDefinition. self addVariables: civarArray ofType: MCClassInstanceVariableDefinition.! ! !MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/10/2003 01:29'! source ^ self definitionString! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'nice 10/20/2009 22:03'! classVarNames ^(self selectVariables: #isClassVariable) asArray sort! ! !MCClassDefinition methodsFor: 'installing' stamp: 'EstebanLorenzano 8/3/2012 15:29'! load self createClass ifNotNil: [:class | SystemAnnouncer uniqueInstance suspendAllWhile: [ class class instanceVariableNames: self classInstanceVariablesString. self hasComment ifTrue: [class classComment: comment stamp: commentStamp]]].! ! !MCClassDefinition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:57'! addOperation: aMCRemoval on: aKOClass aKOClass addClassDefinition: aMCRemoval! ! !MCClassDefinition methodsFor: 'installing' stamp: 'NicoPaez 10/1/2010 10:21'! unload Smalltalk globals removeClassNamed: name! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 11/24/2002 22:35'! type ^ type! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 11/25/2002 06:51'! variables ^ variables! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:16'! traitComposition ^traitComposition! ! !MCClassDefinition methodsFor: 'printing' stamp: 'lr 3/20/2010 21:23'! printMetaDefinitionOn: stream stream nextPutAll: self className; nextPutAll: ' class'; cr; tab. self hasClassTraitComposition ifTrue: [ stream nextPutAll: 'uses: '; nextPutAll: self classTraitCompositionString; cr; tab ]. stream nextPutAll: ' instanceVariableNames: '; store: self classInstanceVariablesString! ! !MCClassDefinition methodsFor: 'comparing' stamp: 'stephaneducasse 2/4/2006 20:47'! hash | hash | hash := String stringHash: name initialHash: 0. hash := String stringHash: superclassName initialHash: hash. hash := String stringHash: self traitCompositionString initialHash: hash. hash := String stringHash: self classTraitComposition asString initialHash: hash. hash := String stringHash: (category ifNil: ['']) initialHash: hash. hash := String stringHash: type initialHash: hash. variables do: [ :v | hash := String stringHash: v name initialHash: hash. ]. ^ hash! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:52'! className ^ name! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 8/10/2003 16:40'! commentStamp ^ commentStamp! ! !MCClassDefinition methodsFor: 'printing' stamp: 'ab 11/16/2002 17:33'! summary ^ name! ! !MCClassDefinition methodsFor: 'initializing' stamp: 'bf 8/12/2009 10:55'! initializeWithName: nameString superclassName: superclassString category: categoryString instVarNames: ivarArray classVarNames: cvarArray poolDictionaryNames: poolArray classInstVarNames: civarArray type: typeSymbol comment: commentString commentStamp: stampStringOrNil name := nameString asSymbol. superclassName := superclassString ifNil: ['nil'] ifNotNil: [superclassString asSymbol]. category := categoryString. name = #CompiledMethod ifTrue: [type := #compiledMethod] ifFalse: [type := typeSymbol]. comment := commentString withSqueakLineEndings. commentStamp := stampStringOrNil ifNil: [self defaultCommentStamp]. variables := OrderedCollection new. self addVariables: ivarArray ofType: MCInstanceVariableDefinition. self addVariables: cvarArray asSortedCollection ofType: MCClassVariableDefinition. self addVariables: poolArray asSortedCollection ofType: MCPoolImportDefinition. self addVariables: civarArray ofType: MCClassInstanceVariableDefinition.! ! !MCClassDefinition methodsFor: 'comparing' stamp: 'nice 10/31/2009 13:11'! = aDefinition ^(super = aDefinition) and: [superclassName = aDefinition superclassName and: [self traitCompositionString = aDefinition traitCompositionString and: [self classTraitCompositionString = aDefinition classTraitCompositionString and: [category = aDefinition category and: [type = aDefinition type and: [self sortedVariables = aDefinition sortedVariables and: [comment = aDefinition comment]]]]]]]! ! !MCClassDefinition methodsFor: 'printing' stamp: 'eem 4/30/2009 16:47'! sharedPoolsString ^ self stringForSortedVariablesOfType: #isPoolImport! ! !MCClassDefinition methodsFor: 'installing' stamp: 'MartinDias 6/24/2013 15:26'! createClass | superClass class composition | superClass := superclassName == #nil ifFalse: [ Smalltalk globals at: superclassName ]. [ class := superClass classBuilder name: name inEnvironment: superClass environment subclassOf: superClass type: type instanceVariableNames: self instanceVariablesString classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: category.] on: Warning, DuplicatedVariableError do: [:ex| ex resume]. self traitComposition ifNotNil: [ composition := self class compiler evaluate: self traitComposition. ((((composition isCollection and: [ ( composition includes: nil ) not]) or: [composition isKindOf: TraitComposition ]) or: [composition isKindOf: Trait ]) or: [composition isKindOf: TraitTransformation ]) ifTrue: [ class setTraitComposition: composition asTraitComposition ] ]. self classTraitComposition ifNotNil: [ composition := self class compiler evaluate: self classTraitComposition. ((((composition isCollection and: [ ( composition includes: nil ) not]) or: [composition isKindOf: TraitComposition ]) or: [composition isKindOf: Trait ]) or: [composition isKindOf: TraitTransformation ]) ifTrue: [ class class setTraitComposition: composition asTraitComposition ] ]. ^ class! ! !MCClassDefinition methodsFor: 'printing' stamp: 'cwp 8/2/2003 02:03'! definitionString ^ String streamContents: [:stream | self printDefinitionOn: stream]! ! !MCClassDefinition methodsFor: 'storing' stamp: 'al 7/4/2006 10:14'! storeDataOn: aDataStream | instVarSize | instVarSize := (self hasTraitComposition or: [ self hasClassTraitComposition ]) ifTrue: [ self class instSize ] ifFalse: [ self class instSize - 2 ]. aDataStream beginInstance: self class size: instVarSize. 1 to: instVarSize do: [ :index | aDataStream nextPut: (self instVarAt: index) ].! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:55'! classTraitCompositionString ^self classTraitComposition ifNil: ['{}'].! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:07'! classTraitComposition ^classTraitComposition! ! !MCClassDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 1/14/2009 13:41'! classDefinitionString "Answer a string describing the class-side definition." ^String streamContents: [:stream | self printClassDefinitionOn: stream]! ! !MCClassDefinition class methodsFor: 'obsolete' stamp: 'ab 4/1/2003 01:22'! name: nameString superclassName: superclassString category: categoryString instVarNames: ivarArray classVarNames: cvarArray poolDictionaryNames: poolArray classInstVarNames: civarArray comment: commentString ^ self name: nameString superclassName: superclassString category: categoryString instVarNames: ivarArray classVarNames: cvarArray poolDictionaryNames: poolArray classInstVarNames: civarArray type: #normal comment: commentString ! ! !MCClassDefinition class methodsFor: 'obsolete' stamp: 'ab 4/1/2003 01:22'! name: nameString superclassName: superclassString category: categoryString instVarNames: ivarArray comment: commentString ^ self name: nameString superclassName: superclassString category: categoryString instVarNames: ivarArray classVarNames: #() poolDictionaryNames: #() classInstVarNames: #() comment: commentString ! ! !MCClassDefinition class methodsFor: 'instance creation' stamp: 'al 10/9/2005 19:16'! name: nameString superclassName: superclassString category: categoryString instVarNames: ivarArray classVarNames: cvarArray poolDictionaryNames: poolArray classInstVarNames: civarArray type: typeSymbol comment: commentString commentStamp: stampString ^ self instanceLike: (self new initializeWithName: nameString superclassName: superclassString traitComposition: '{}' classTraitComposition: '{}' category: categoryString instVarNames: ivarArray classVarNames: cvarArray poolDictionaryNames: poolArray classInstVarNames: civarArray type: typeSymbol comment: commentString commentStamp: stampString)! ! !MCClassDefinition class methodsFor: 'obsolete' stamp: 'cwp 8/10/2003 16:33'! name: nameString superclassName: superclassString category: categoryString instVarNames: ivarArray classVarNames: cvarArray poolDictionaryNames: poolArray classInstVarNames: civarArray type: typeSymbol comment: commentString ^ self name: nameString superclassName: superclassString category: categoryString instVarNames: ivarArray classVarNames: cvarArray poolDictionaryNames: poolArray classInstVarNames: civarArray type: typeSymbol comment: commentString commentStamp: nil! ! !MCClassDefinition class methodsFor: 'instance creation' stamp: 'al 10/10/2005 13:58'! name: nameString superclassName: superclassString traitComposition: traitCompositionString classTraitComposition: classTraitCompositionString category: categoryString instVarNames: ivarArray classVarNames: cvarArray poolDictionaryNames: poolArray classInstVarNames: civarArray type: typeSymbol comment: commentString commentStamp: stampString ^ self instanceLike: (self new initializeWithName: nameString superclassName: superclassString traitComposition: traitCompositionString classTraitComposition: classTraitCompositionString category: categoryString instVarNames: ivarArray classVarNames: cvarArray poolDictionaryNames: poolArray classInstVarNames: civarArray type: typeSymbol comment: commentString commentStamp: stampString)! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testValidTraitComposition "Related to http://code.google.com/p/pharo/issues/detail?id=2148" | d className cls | className := 'MCMockClassC'. d := MCClassDefinition name: className superclassName: 'Object' traitComposition: '{Trait1}' classTraitComposition: '{}' category: self mockCategoryName instVarNames: #() classVarNames: #() poolDictionaryNames: #() classInstVarNames: #() type: #normal comment: (self commentForClass: className) commentStamp: (self commentStampForClass: className). d load. self assert: (Smalltalk hasClassNamed: 'MCMockClassC'). cls := Smalltalk at: #MCMockClassC. self assert: (cls includesSelector: #c1). self assert: ((Smalltalk at: #MCMockClassC) traitComposition allTraits includes: Trait1)! ! !MCClassDefinitionTest methodsFor: 'running' stamp: 'Alexandre Bergel 5/22/2010 11:23'! tearDown Smalltalk globals at: #MCMockClassC ifPresent: [ :c | c removeFromSystem ]! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testDefinitionString | d | d := self mockClassA asClassDefinition. self assert: d definitionString = self mockClassA definition.! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'nice 1/5/2010 15:59'! testKindOfSubclass | classes | classes := {self mockClassA. String. MethodContext. WeakArray. Float}. classes do: [:c | | d | d := c asClassDefinition. self assert: d kindOfSubclass = c kindOfSubclass. ].! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testValidTraitComposition4 "Related to http://code.google.com/p/pharo/issues/detail?id=2598" | d className cls | className := 'MCMockClassC'. d := MCClassDefinition name: className superclassName: 'Object' traitComposition: 'Trait1 - {#c1}' classTraitComposition: '{}' category: self mockCategoryName instVarNames: #() classVarNames: #() poolDictionaryNames: #() classInstVarNames: #() type: #normal comment: (self commentForClass: className) commentStamp: (self commentStampForClass: className). d load. self assert: (Smalltalk hasClassNamed: 'MCMockClassC'). cls := Smalltalk at: #MCMockClassC. self assert: (cls selectors includesAllOf: {#c}). self deny: (cls selectors includesAnyOf: {#c1})! ! !MCClassDefinitionTest methodsFor: 'private' stamp: 'cwp 8/10/2003 17:17'! creationMessage ^ MessageSend receiver: MCClassDefinition selector: #name:superclassName:category:instVarNames:classVarNames:poolDictionaryNames:classInstVarNames:type:comment:commentStamp:! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testEquals | a b | a := self mockClass: 'ClassA' super: 'SuperA'. b := self mockClass: 'ClassA' super: 'SuperA'. self assert: a = b! ! !MCClassDefinitionTest methodsFor: 'running' stamp: 'Alexandre Bergel 5/22/2010 11:23'! setUp Smalltalk globals at: #MCMockClassC ifPresent: [ :c | c removeFromSystem ]! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'Alexandre Bergel 5/22/2010 11:22'! testCannotLoad | d | self deny: (Smalltalk hasClassNamed: 'MCMockClassC'). d := self mockClass: 'MCMockClassC' super: 'NotAnObject'. self should: [d load] raise: Error. self deny: (Smalltalk hasClassNamed: 'MCMockClassC').! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testValidTraitComposition2 "Related to http://code.google.com/p/pharo/issues/detail?id=2148" | d className cls | className := 'MCMockClassC'. d := MCClassDefinition name: className superclassName: 'Object' traitComposition: 'Trait1' classTraitComposition: '{}' category: self mockCategoryName instVarNames: #() classVarNames: #() poolDictionaryNames: #() classInstVarNames: #() type: #normal comment: (self commentForClass: className) commentStamp: (self commentStampForClass: className). d load. self assert: (Smalltalk hasClassNamed: 'MCMockClassC'). cls := Smalltalk at: #MCMockClassC. self assert: (cls includesSelector: #c1). self assert: ((Smalltalk at: #MCMockClassC) traitComposition allTraits includes: Trait1)! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testValidTraitComposition3 "Related to http://code.google.com/p/pharo/issues/detail?id=2148" | d className cls | className := 'MCMockClassC'. d := MCClassDefinition name: className superclassName: 'Object' traitComposition: 'Trait1 + Trait2' classTraitComposition: '{}' category: self mockCategoryName instVarNames: #() classVarNames: #() poolDictionaryNames: #() classInstVarNames: #() type: #normal comment: (self commentForClass: className) commentStamp: (self commentStampForClass: className). d load. self assert: (Smalltalk hasClassNamed: 'MCMockClassC'). cls := Smalltalk at: #MCMockClassC. self assert: (cls includesSelector: #c1). self assert: (cls includesSelector: #c2). self assert: ((Smalltalk at: #MCMockClassC) traitComposition allTraits includes: Trait1). self assert: ((Smalltalk at: #MCMockClassC) traitComposition allTraits includes: Trait2)! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testEqualsSensitivity | message a b defA args defB | message := self creationMessage. a := #(ClassA SuperA CategoryA #(iVarA) #(CVarA) #(PoolA) #(ciVarA) typeA 'A comment' 'A'). b := #(ClassB SuperB CategoryB #(iVarB) #(CVarB) #(PoolB) #(ciVarB) typeB 'B comment' 'B'). defA := message valueWithArguments: a. 1 to: 8 do: [:index | args := a copy. args at: index put: (b at: index). defB := message valueWithArguments: args. self deny: defA = defB.]! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testComparison | d1 d2 d3 d4 | d1 := self mockClass: 'A' super: 'X'. d2 := self mockClass: 'A' super: 'Y'. d3 := self mockClass: 'B' super: 'X'. d4 := self mockClass: 'B' super: 'X'. self assert: (d1 isRevisionOf: d2). self deny: (d1 isSameRevisionAs: d2). self assert: (d3 isRevisionOf: d4). self assert: (d3 isSameRevisionAs: d4). self deny: (d1 isRevisionOf: d3). self deny: (d4 isRevisionOf: d2).! ! !MCClassDefinitionTest methodsFor: 'private' stamp: 'cwp 8/10/2003 01:20'! classAComment ^ self class classAComment! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'pavel.krivanek 10/14/2010 16:35'! testCreation | d | d := self mockClassA asClassDefinition. self assert: d className = #MCMockClassA. self assert: d superclassName = #MCMock. self assert: d type = #normal. self assert: d category = self mockCategoryName. self assert: d instVarNames asArray = #('ivar'). self assert: d classVarNames asArray = #('CVar' 'InitializationOrder'). self assert: d classInstVarNames asArray = #(). self assert: d comment isString. self assert: d comment = self classAComment. self assert: d commentStamp = self mockClassA organization commentStamp! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'lr 3/14/2010 21:13'! testLoadAndUnload | d c | d := self mockClass: 'MCMockClassC' super: 'Object'. d load. self assert: (Smalltalk hasClassNamed: 'MCMockClassC'). c := Smalltalk globals classNamed: 'MCMockClassC'. self assert: (c isKindOf: Class). self assert: c superclass = Object. self assert: c instVarNames isEmpty. self assert: c classVarNames isEmpty. self assert: c sharedPools isEmpty. self assert: c category = self mockCategoryName. self assert: c organization classComment = (self commentForClass: 'MCMockClassC'). self assert: c organization commentStamp = (self commentStampForClass: 'MCMockClassC'). d unload. self deny: (Smalltalk hasClassNamed: 'MCMockClassC')! ! !MCClassDefinitionTest class methodsFor: 'as yet unclassified' stamp: 'lr 3/14/2010 21:13'! restoreClassAComment Smalltalk globals at: #MCMockClassA ifPresent: [ :a | a classComment: self classAComment stamp: self classACommentStamp ]! ! !MCClassDefinitionTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 17:59'! classACommentStamp ^ 'cwp 8/10/2003 16:43'! ! !MCClassDefinitionTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 01:20'! classAComment ^ 'This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.'! ! !MCClassInstanceVariableDefinition commentStamp: ''! A MCClassInstanceVariableDefinition represents a class instance variable.! !MCClassInstanceVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:31'! isClassInstanceVariable ^ true! ! !MCClassInstanceVariableDefinition class methodsFor: 'accessing' stamp: 'cwp 7/7/2003 22:59'! type ^ #classInstance! ! !MCClassTraitDefinition commentStamp: 'TorstenBergmann 2/5/2014 13:45'! A class trait definition! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 6/5/2006 14:04'! hash | hash | hash := String stringHash: baseTrait initialHash: 0. hash := String stringHash: self classTraitCompositionString initialHash: hash. ^hash ! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:24'! description ^Array with: baseTrait with: classTraitComposition! ! !MCClassTraitDefinition methodsFor: 'printing' stamp: 'CamilleTeruel 5/13/2013 18:05'! printDefinitionOn: stream stream nextPutAll: self baseTrait; nextPutAll: ' classTrait'; cr; tab; nextPutAll: 'uses: '; nextPutAll: self classTraitCompositionString! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:24'! requirements ^Array with: baseTrait! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'! sortKey ^ self baseTrait name , '.classTrait'! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'MarcusDenker 10/29/2010 11:30'! category ^ category ifNil: [(Smalltalk classOrTraitNamed: self baseTrait) ifNotNil: [:bTrait | bTrait category] ifNil: [self error: 'Can''t detect the category']] ! ! !MCClassTraitDefinition methodsFor: 'initialization' stamp: 'damiencassou 7/30/2009 12:12'! initializeWithBaseTraitName: aTraitName classTraitComposition: aString category: aCategoryString baseTrait := aTraitName. classTraitComposition := aString. category := aCategoryString! ! !MCClassTraitDefinition methodsFor: 'testing' stamp: 'adrian-lienhard 5/11/2009 16:47'! isClassDefinition "Traits are treated the same like classes." ^ true! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 12/15/2005 11:31'! className ^self baseTrait! ! !MCClassTraitDefinition methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithBaseTraitName: aTraitName classTraitComposition: aString baseTrait := aTraitName. classTraitComposition := aString.! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'! summary ^self baseTrait , ' classTrait' ! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:23'! baseTrait ^baseTrait ! ! !MCClassTraitDefinition methodsFor: 'comparing' stamp: 'SebastianTleye 7/12/2013 13:48'! = aDefinition ^ (super = aDefinition) and: [baseTrait = aDefinition baseTrait and: [self classTraitCompositionString = aDefinition classTraitCompositionString]] ! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'! source ^self definitionString! ! !MCClassTraitDefinition methodsFor: 'visiting' stamp: 'al 10/9/2005 20:23'! accept: aVisitor ^ aVisitor visitClassTraitDefinition: self.! ! !MCClassTraitDefinition methodsFor: '*Ring-Monticello' stamp: 'VeronicaUquillas 7/14/2011 11:24'! asRingDefinition ^(RGFactory current createMetatraitNamed: baseTrait) traitCompositionSource: self classTraitCompositionString; definitionSource: self definitionString; yourself! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:59'! definitionString ^self baseTrait , ' classTrait uses: ' , self classTraitCompositionString. ! ! !MCClassTraitDefinition methodsFor: 'installing' stamp: 'MarcusDenker 5/2/2013 11:34'! load self class compiler evaluate: self definitionString! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:23'! classTraitComposition ^classTraitComposition ! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/10/2005 10:12'! classTraitCompositionString ^self classTraitComposition ifNil: ['{}']. ! ! !MCClassTraitDefinition methodsFor: '*Ring-Monticello' stamp: 'VeronicaUquillas 7/20/2011 15:56'! classDefinitionString ^self definitionString! ! !MCClassTraitDefinition class methodsFor: 'instance creation' stamp: 'damiencassou 7/30/2009 12:32'! baseTraitName: aString classTraitComposition: classTraitCompositionString ^ self baseTraitName: aString classTraitComposition: classTraitCompositionString category: nil! ! !MCClassTraitDefinition class methodsFor: 'instance creation' stamp: 'damiencassou 7/30/2009 12:11'! baseTraitName: aString classTraitComposition: classTraitCompositionString category: aCategoryString ^self instanceLike: ( self new initializeWithBaseTraitName: aString classTraitComposition: classTraitCompositionString category: aCategoryString).! ! !MCClassTraitParser commentStamp: ''! MCClassTraitParser identifies classTrait. ! !MCClassTraitParser methodsFor: 'actions' stamp: 'MarcusDenker 5/18/2013 15:44'! addDefinitionsTo: aCollection | tokens definition traitCompositionString | tokens := source parseLiterals. traitCompositionString := (source readStream match: 'uses:'; upToEnd) trimBoth. definition := MCClassTraitDefinition baseTraitName: (tokens at: 1) classTraitComposition: traitCompositionString. aCollection add: definition ! ! !MCClassTraitParser class methodsFor: 'factory identification hook' stamp: 'al 10/9/2005 20:43'! pattern ^ '*classTrait*uses:*'! ! !MCClassVariableDefinition commentStamp: ''! A MCClassVariableDefinition represent a class variable.! !MCClassVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:32'! isClassVariable ^ true! ! !MCClassVariableDefinition methodsFor: 'testing' stamp: 'bf 8/29/2006 11:41'! isOrderDependend ^false! ! !MCClassVariableDefinition class methodsFor: 'accessing' stamp: 'cwp 7/7/2003 22:58'! type ^ #class! ! !MCCodeTool commentStamp: 'nk 11/10/2003 22:00'! MCCodeTool is an abstract superclass for those Monticello browsers that display code. It contains copies of the various CodeHolder methods that perform the various menu operations in the method list. ! !MCCodeTool methodsFor: 'subclassresponsibility' stamp: 'nk 11/10/2003 22:02'! selectedClass "Answer the class that is selected, or nil" self subclassResponsibility! ! !MCCodeTool methodsFor: 'menus' stamp: 'MarcusDenker 10/13/2013 07:57'! browseSendersOfMessages "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen." self systemNavigation browseAllSendersOf: (self selectedMessageName ifNil: [ ^nil ])! ! !MCCodeTool methodsFor: 'menus' stamp: 'IgorStasenko 3/6/2011 18:54'! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." | class selector compiledMethod | class := self selectedClassOrMetaClass. selector := self selectedMessageName. compiledMethod := class compiledMethodAt: selector ifAbsent: [ ^self ]. Smalltalk tools versionBrowser browseVersionsOf: compiledMethod class: class theNonMetaClass meta: class isMeta category: self selectedMessageCategoryName selector: selector! ! !MCCodeTool methodsFor: 'menus' stamp: 'MarcusDenker 2/16/2010 16:30'! classHierarchy "Create and schedule a class list browser on the receiver's hierarchy." self systemNavigation browseHierarchy: self selectedClassOrMetaClass selector: self selectedMessageName "OK if nil"! ! !MCCodeTool methodsFor: 'menus' stamp: 'nk 11/10/2003 21:26'! browseMessages "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all implementors of the selector chosen." self systemNavigation browseAllImplementorsOf: (self selectedMessageName ifNil: [ ^nil ])! ! !MCCodeTool methodsFor: 'menus' stamp: 'MarcusDenker 7/13/2012 23:51'! methodListKey: aKeystroke from: aListMorph aKeystroke caseOf: { [$b] -> [self browseMethodFull]. [$h] -> [self classHierarchy]. [$o] -> [self fileOutMessage]. [$c] -> [self copySelector]. [$n] -> [self browseSendersOfMessages]. [$m] -> [self browseMessages]. [$i] -> [self methodHierarchy]. [$v] -> [self browseVersions]} otherwise: []! ! !MCCodeTool methodsFor: 'menus' stamp: 'MarcusDenker 10/13/2012 18:06'! methodListMenu: aMenu "Build the menu for the selected method, if any." self selectedMessageName ifNil: [items notEmpty ifTrue: [aMenu addList:#(('FileOut (o)' fileOutMessage))]] ifNotNil: [ aMenu addList:#( ('Browse full (b)' browseMethodFull) ('Browse hierarchy (h)' classHierarchy) - ('FileOut (o)' fileOutMessage) ('Copy selector (c)' copySelector)). aMenu addList: #( - ('Browse senders (n)' browseSendersOfMessages) ('Browse implementors (m)' browseMessages) ('Inheritance (i)' methodHierarchy) ('Versions (v)' browseVersions) ). ]. ^ aMenu ! ! !MCCodeTool methodsFor: 'menus' stamp: 'IgorStasenko 3/6/2011 18:55'! browseMethodFull "Create and schedule a full Browser and then select the current class and message." | myClass | (myClass := self selectedClassOrMetaClass) ifNotNil: [Smalltalk tools browser fullOnClass: myClass selector: self selectedMessageName]! ! !MCCodeTool methodsFor: 'menus' stamp: 'StephaneDucasse 7/11/2010 23:05'! fileOutMessage "Put a description of the selected message on a file" | fileName | self selectedMessageName ifNotNil: [Cursor write showWhile: [self selectedClassOrMetaClass fileOutMethod: self selectedMessageName]. ^self]. items isEmpty ifTrue: [^self]. fileName := UIManager default request: 'File out on which file?' initialAnswer: 'methods'. Cursor write showWhile: [| internalStream | internalStream := WriteStream on: (String new: 1000). internalStream header; timeStamp. items do: [:patchOp| patchOp definition isMethodDefinition ifTrue: [(patchOp definition actualClass notNil and: [patchOp definition actualClass includesSelector: patchOp definition selector]) ifTrue: [patchOp definition actualClass printMethodChunk: patchOp definition selector withPreamble: true on: internalStream moveSource: false toFile: nil] ifFalse: [internalStream nextChunkPut: patchOp definition className, ' removeSelector: ', patchOp definition selector printString]]. patchOp definition isClassDefinition ifTrue: [patchOp definition actualClass ifNotNil: [internalStream nextChunkPut: patchOp definition actualClass definition. patchOp definition comment ifNotNil: [patchOp definition actualClass organization putCommentOnFile: internalStream numbered: 1 moveSource: false forClass: patchOp definition actualClass]] ifNil: [internalStream nextChunkPut: patchOp definition className, ' removeFromSystem']]]. FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true]! ! !MCCodeTool methodsFor: 'subclassresponsibility' stamp: 'nk 11/10/2003 22:02'! selectedMessageCategoryName "Answer the method category of the method that is selected, or nil" self subclassResponsibility! ! !MCCodeTool methodsFor: 'subclassresponsibility' stamp: 'nk 11/10/2003 22:02'! selectedClassOrMetaClass "Answer the class that is selected, or nil" self subclassResponsibility! ! !MCCodeTool methodsFor: 'subclassresponsibility' stamp: 'nk 11/10/2003 22:02'! selectedMessageName "Answer the name of the selected message" self subclassResponsibility! ! !MCCodeTool methodsFor: 'menus' stamp: 'MarcusDenker 10/13/2012 18:06'! classListMenu: aMenu ^aMenu addList: #( - ('Browse full (b)' browseMethodFull) ('Browse hierarchy (h)' classHierarchy) - ('Show hierarchy' methodHierarchy))! ! !MCCodeTool methodsFor: 'menus' stamp: 'stephaneducasse 2/4/2006 20:47'! copySelector "Copy the selected selector to the clipboard" | selector | (selector := self selectedMessageName) ifNotNil: [Clipboard clipboardText: selector asString]! ! !MCCodeTool methodsFor: 'menus' stamp: 'nk 7/30/2004 17:56'! methodHierarchy "Create and schedule a method browser on the hierarchy of implementors." self systemNavigation methodHierarchyBrowserForClass: self selectedClassOrMetaClass selector: self selectedMessageName! ! !MCConfiguration commentStamp: 'StephaneDucasse 11/29/2011 22:23'! An MCConfiguration specifies the configuration of a set of related Monticello packages. It maintains an ordered list of package versions and a list of repositories in which the packages may be found. An MCConfiguration may be filed out for storage as an array specification, and new instances can be created from a stored array specification. ! !MCConfiguration methodsFor: 'faking' stamp: 'bf 3/24/2005 01:19'! changes ^MCPatch operations: #()! ! !MCConfiguration methodsFor: 'updating' stamp: 'bf 5/23/2005 17:43'! updateFromImage self dependencies: (self dependencies collect: [:dep | dep package hasWorkingCopy ifTrue: [ dep package workingCopy in: [:wc | MCVersionDependency package: wc package info: wc ancestors first]] ifFalse: [dep]]). ! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/21/2005 18:40'! dependencies: aCollection dependencies := aCollection! ! !MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 16:07'! logError: aString self log cr; nextPutAll: 'ERROR: '; nextPutAll: aString; cr; flush. ! ! !MCConfiguration methodsFor: 'private' stamp: 'MarcusDenker 10/10/2013 23:26'! versionNamed: verName for: aDependency from: repo | baseName fileName ver | (repo filterFileNames: repo cachedFileNames forVersionNamed: verName) ifNotEmpty: [:cachedNames | fileName := cachedNames anyOne. ProgressNotification signal: '' extra: 'Using cached ', fileName. ver := repo versionFromFileNamed: fileName]. ver ifNil: [ baseName := self diffBaseFor: aDependency. (baseName notNil and: [baseName ~= verName and: [repo includesVersionNamed: baseName]]) ifTrue: [ fileName := (MCDiffyVersion nameForVer: verName base: baseName), '.mcd'. ProgressNotification signal: '' extra: 'Downloading ', fileName. ver := repo versionFromFileNamed: fileName]]. ver ifNil: [ fileName := verName, '.mcz'. ProgressNotification signal: '' extra: 'Downloading ', fileName. ver := repo versionFromFileNamed: fileName]. ^ver! ! !MCConfiguration methodsFor: 'private' stamp: 'bf 3/20/2006 19:10'! mergeVersionsSilently: aCollection ^self suppressMergeDialogWhile: [self mergeVersions: aCollection]! ! !MCConfiguration methodsFor: '*MonticelloGUI' stamp: 'BenjaminVanRyseghem 2/8/2012 17:09'! browse ^ (MCConfigurationBrowser new configuration: self) show! ! !MCConfiguration methodsFor: 'initialization' stamp: 'ar 5/27/2005 17:28'! initialize super initialize. log := DefaultLog.! ! !MCConfiguration methodsFor: 'actions' stamp: 'bf 3/22/2005 10:51'! fileOutOn: aStream self writerClass fileOut: self on: aStream! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:35'! repositories ^repositories ifNil: [repositories := OrderedCollection new]! ! !MCConfiguration methodsFor: 'accessing' stamp: 'ar 4/28/2005 11:55'! log: aStream log := aStream.! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:22'! fileName ^ self name, '.', self writerClass extension ! ! !MCConfiguration methodsFor: 'actions' stamp: 'bf 3/17/2006 15:55'! load "install all the versions in this configuration, even if this means to downgrade a package" | versions | versions := OrderedCollection new. self depsSatisfying: [:dep | dep isCurrent not] versionDo: [:ver | versions add: ver] displayingProgress: 'finding packages'. ^self loadVersions: versions! ! !MCConfiguration methodsFor: 'updating' stamp: 'StephaneDucasse 2/20/2010 23:07'! updateFromRepositories | oldInfos newNames sortedNames newDeps | oldInfos := self dependencies collect: [:dep | dep versionInfo]. newNames := Dictionary new. self repositories do: [ :repo | ProgressNotification signal: '' extra: 'Checking ', repo description. (repo possiblyNewerVersionsOfAnyOf: oldInfos) do: [:newName | newNames at: newName put: repo]] displayingProgress: 'Searching new versions'. sortedNames := newNames keys asSortedCollection: [:a :b | a numericSuffix > b numericSuffix]. newDeps := OrderedCollection new. self dependencies do: [:dep | | newName | newName := sortedNames detect: [:each | (each copyUpToLast: $-) = dep package name] ifNone: [nil]. newDeps add: (newName ifNil: [dep] ifNotNil: [ | repo ver | repo := newNames at: newName. ver := self versionNamed: newName for: dep from: repo. ver ifNil: [dep] ifNotNil: [MCVersionDependency package: ver package info: ver info] ]) ] displayingProgress: 'downloading new versions'. self dependencies: newDeps. ! ! !MCConfiguration methodsFor: 'actions' stamp: 'bf 3/16/2006 17:41'! merge "merge in all the versions in this configuration" | versions | versions := OrderedCollection new. self depsSatisfying: [:dep | dep isFulfilledByAncestors not] versionDo: [:ver | versions add: ver] displayingProgress: 'finding packages'. ^self mergeVersions: versions! ! !MCConfiguration methodsFor: 'private' stamp: 'MarcusDenker 10/10/2013 23:26'! depsSatisfying: selectBlock versionDo: verBlock displayingProgress: progressString | repoMap count | repoMap := Dictionary new. self repositories do: [:repo | MCRepositoryGroup default addRepository: repo. repo allVersionNames ifEmpty: [self logWarning: 'cannot read from ', repo description] ifNotEmpty: [:all | all do: [:ver | repoMap at: ver put: repo]]]. count := 0. self dependencies do: [:dep | | ver repo | ver := dep versionInfo name. repo := repoMap at: ver ifAbsent: [self logError: 'Version ', ver, ' not found in any repository'. self logError: 'Aborting'. ^count]. (selectBlock value: dep) ifTrue: [| new | new := self versionNamed: ver for: dep from: repo. new ifNil: [self logError: 'Could not download version ', ver, ' from ', repo description. self logError: 'Aborting'. ^count] ifNotNil: [ self logUpdate: dep package with: new. ProgressNotification signal: '' extra: 'Installing ', ver. verBlock value: new. count := count + 1]]. dep package workingCopy repositoryGroup addRepository: repo. ] displayingProgress: progressString. ^count! ! !MCConfiguration methodsFor: 'private' stamp: 'bf 3/16/2006 19:07'! loadVersions: aCollection | loader | aCollection isEmpty ifTrue: [^0]. loader := MCVersionLoader new. aCollection do: [:each | loader addVersion: each]. loader loadWithNameLike: self nameForChangeset. ^ aCollection size! ! !MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 15:59'! logUpdate: aPackage with: aVersion self log cr; nextPutAll: '========== ', aVersion info name, ' =========='; cr; cr; nextPutAll: aVersion info message asString; cr; flush. aPackage hasWorkingCopy ifFalse: [^self]. aPackage workingCopy ancestors do: [:each | (aVersion info hasAncestor: each) ifTrue: [(aVersion info allAncestorsOnPathTo: each) do: [:ver | self log cr; nextPutAll: '>>> ', ver name, ' <<<'; cr; nextPutAll: ver message; cr; flush]]]! ! !MCConfiguration methodsFor: 'private' stamp: 'CamilloBruni 9/15/2013 17:58'! suppressMergeDialogWhile: aBlock ^aBlock on: MCMergeResolutionRequest do: [:request | request autoMerge ]! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 6/9/2005 15:58'! log ^log ifNil: [Transcript]! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 10:50'! writerClass ^ MCMcmWriter ! ! !MCConfiguration methodsFor: 'actions' stamp: 'bf 3/17/2006 16:17'! upgradeByLoading "this differs from #load only in that newer versions in the image are not downgraded" | versions | versions := OrderedCollection new. self depsSatisfying: [:dep | dep isFulfilledByAncestors not] versionDo: [:ver | versions add: ver] displayingProgress: 'finding packages'. ^self loadVersions: versions ! ! !MCConfiguration methodsFor: 'actions' stamp: 'bf 3/20/2006 19:10'! upgradeByMerging | versions | versions := OrderedCollection new. self depsSatisfying: [:dep | dep isFulfilledByAncestors not] versionDo: [:ver | versions add: ver] displayingProgress: 'finding packages'. ^(versions noneSatisfy: [:ver | self mustMerge: ver]) ifTrue: [self loadVersions: versions] ifFalse: [self mergeVersionsSilently: versions]. ! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/23/2005 00:44'! summary ^String streamContents: [:stream | self dependencies do: [:ea | stream nextPutAll: ea versionInfo name; cr ]]! ! !MCConfiguration methodsFor: 'testing' stamp: 'bf 3/22/2005 22:56'! isCacheable ^false! ! !MCConfiguration methodsFor: 'actions' stamp: 'AlainPlantec 12/17/2009 22:59'! upgrade ^self class upgradeIsMerge ifTrue: [self upgradeByMerging] ifFalse: [self upgradeByLoading]! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:36'! repositories: aCollection repositories := aCollection! ! !MCConfiguration methodsFor: 'private' stamp: 'bf 3/16/2006 19:07'! mergeVersions: aCollection | merger | aCollection isEmpty ifTrue: [^0]. merger := MCVersionMerger new. aCollection do: [:each | merger addVersion: each]. merger mergeWithNameLike: self nameForChangeset. ^ aCollection size! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:23'! name: aString name := aString! ! !MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 16:08'! logWarning: aString self log cr; nextPutAll: 'WARNING: '; nextPutAll: aString; cr; flush. ! ! !MCConfiguration methodsFor: 'private' stamp: 'bf 5/23/2005 14:47'! mustMerge: aVersion "answer true if we have to do a full merge and false if we can simply load instead" | pkg wc current | (pkg := aVersion package) hasWorkingCopy ifFalse: [^false "no wc -> load"]. (wc := pkg workingCopy) modified ifTrue: [^true "modified -> merge"]. wc ancestors isEmpty ifTrue: [^true "no ancestor info -> merge"]. current := wc ancestors first. (aVersion info hasAncestor: current) ifTrue: [^false "direct descendant of wc -> load"]. "new branch -> merge" ^true! ! !MCConfiguration methodsFor: 'copying' stamp: 'bf 11/26/2005 20:22'! postCopy dependencies := dependencies shallowCopy. repositories := repositories shallowCopy.! ! !MCConfiguration methodsFor: 'faking' stamp: 'bf 3/24/2005 01:17'! info ^MCVersionInfo new! ! !MCConfiguration methodsFor: 'private' stamp: 'bf 3/16/2006 19:07'! nameForChangeset ^self name ifNil: [self class name]! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:23'! name ^name! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/21/2005 16:32'! dependencies ^dependencies ifNil: [dependencies := OrderedCollection new]! ! !MCConfiguration methodsFor: 'private' stamp: 'bf 6/9/2005 11:26'! diffBaseFor: aDependency | wc | aDependency package hasWorkingCopy ifFalse: [^nil]. wc := aDependency package workingCopy. wc ancestors ifEmpty: [^nil]. ^wc ancestors first name! ! !MCConfiguration class methodsFor: 'utilities' stamp: 'bf 6/13/2006 15:46'! whatChangedFrom: oldConfig to: newConfig "MCConfiguration whatChangedFrom: ReleaseBuilderPloppDeveloper config20060201PloppBeta to: ReleaseBuilderPloppDeveloper config20060215premaster" self whatChangedFrom: oldConfig to: newConfig on: Transcript. Transcript flush.! ! !MCConfiguration class methodsFor: 'accessing' stamp: 'ar 5/27/2005 17:27'! defaultLog: aStream "Set the default configuration log" DefaultLog := aStream.! ! !MCConfiguration class methodsFor: 'converting' stamp: 'bf 3/24/2005 01:44'! dependencyToArray: aDependency ^ { aDependency package name . aDependency versionInfo name . aDependency versionInfo id asString }! ! !MCConfiguration class methodsFor: 'converting' stamp: 'bf 3/24/2005 01:43'! dependencyFromArray: anArray ^MCVersionDependency package: (MCPackage named: anArray first) info: ( MCVersionInfo name: anArray second id: (UUID fromString: anArray third) message: nil date: nil time: nil author: nil ancestors: nil)! ! !MCConfiguration class methodsFor: 'utilities' stamp: 'bf 6/13/2006 15:47'! whatChangedFrom: oldConfig to: newConfig on: aStream "MCConfiguration whatChangedFrom: ReleaseBuilderPloppDeveloper config20060201PloppBeta to: ReleaseBuilderPloppDeveloper config20060215premaster" | oldDeps | oldDeps := Dictionary new. oldConfig dependencies do: [:old | oldDeps at: old package put: old]. newConfig dependencies do: [:new | | old | old := oldDeps removeKey: new package ifAbsent: [nil]. old ifNotNil: [old := old versionInfo]. self changesIn: new package from: old to: new versionInfo on: aStream. ]. oldDeps do: [:old | self changesIn: old package from: old versionInfo to: nil on: aStream. ]. ! ! !MCConfiguration class methodsFor: 'settings' stamp: 'AlainPlantec 12/17/2009 22:58'! upgradeIsMerge: aBoolean UpgradeIsMerge := aBoolean! ! !MCConfiguration class methodsFor: 'converting' stamp: 'bf 6/9/2005 14:25'! repositoryFromArray: anArray ^ MCRepositoryGroup default repositories detect: [:repo | repo description = anArray first] ifNone: [ MCHttpRepository location: anArray first user: '' password: '']! ! !MCConfiguration class methodsFor: 'utilities' stamp: 'bf 9/6/2006 19:39'! changesIn: aPackage from: oldInfo to: newInfo on: aStream | printBlock newVersion | (newInfo = oldInfo) ifTrue: [^self]. aStream cr; nextPutAll: '----------------- ', aPackage name, ' ------------------'; cr. newInfo ifNil: [^aStream cr; nextPutAll: 'REMOVED'; cr]. oldInfo ifNil: [^aStream cr; nextPutAll: 'ADDED'; cr]. "get actual version for full ancestry" newVersion := MCRepositoryGroup default versionWithInfo: newInfo. printBlock := [:ver | aStream cr; nextPutAll: (ver name copyAfterLast: $-); nextPutAll: ' (', (ver date printFormat: #(1 2 0 $. 1 1 2)), ', '. ver time print24: true showSeconds: false on: aStream. aStream nextPutAll: ')'; cr; nextPutAll: ver message; cr]. (newVersion info hasAncestor: oldInfo) ifTrue: [(newVersion info allAncestorsOnPathTo: oldInfo) reverseDo: printBlock]. newVersion info in: printBlock. aStream flush! ! !MCConfiguration class methodsFor: 'instance creation' stamp: 'bf 3/24/2005 01:51'! fromArray: anArray | configuration | configuration := self new. anArray pairsDo: [:key :value | key = #repository ifTrue: [configuration repositories add: (self repositoryFromArray: value)]. key = #dependency ifTrue: [configuration dependencies add: (self dependencyFromArray: value)]. ]. ^configuration! ! !MCConfiguration class methodsFor: 'accessing' stamp: 'ar 5/27/2005 17:27'! defaultLog "Answer the default configuration log" ^DefaultLog! ! !MCConfiguration class methodsFor: 'settings' stamp: 'AlainPlantec 12/17/2009 22:58'! upgradeIsMerge ^ UpgradeIsMerge ifNil: [UpgradeIsMerge := false]! ! !MCConfiguration class methodsFor: 'converting' stamp: 'bf 3/24/2005 01:51'! repositoryToArray: aRepository ^ {aRepository description}! ! !MCConfigurationBrowser commentStamp: 'StephaneDucasse 11/29/2011 22:23'! A MCConfigurationBrowser displays an MCConfiguration, and edits the configuration to add or remove package dependencies and repository specifications. It allows a configuration to be stored in a repository or posted to an update stream.! !MCConfigurationBrowser methodsFor: 'description' stamp: 'marcus.denker 11/10/2008 10:04'! description self selectedDependency ifNotNil: [:dep | ^ ('Package: ', dep package name, String cr, dep versionInfo summary) asText]. self selectedRepository ifNotNil: [:repo | ^repo creationTemplate ifNotNil: [repo creationTemplate asText] ifNil: [repo asCreationTemplate asText addAttribute: TextColor red]]. ^ '' ! ! !MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:45'! canRemove ^self index > 0! ! !MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'MarcusDenker 12/11/2009 07:39'! pickConfig self pickRepository ifNotNil: [:repo | | configs index | configs := Cursor wait showWhile: [ repo allFileNames select: [:ea | MCMcmReader canReadFileNamed: ea] thenCollect: [:ea | ea copyUpToLast: $.]]. configs isEmpty ifTrue: [^self inform: 'no configs found in ', repo description]. configs := configs asSortedCollection: [:a :b | (a copyAfterLast: $.) asNumber > (b copyAfterLast: $.) asNumber]. index := UIManager default chooseFrom: configs title: 'config:' translated. index = 0 ifFalse: [^Cursor wait showWhile: [ repo versionFromFileNamed: (configs at: index), '.', MCMcmReader extension]]]. ^nil! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'GuillermoPolito 5/29/2011 14:46'! installMenu | menu | menu := UIManager default newMenuIn: self for: self. menu add: 'load packages' action: #load. menu add: 'merge packages' action: #merge. menu add: 'upgrade packages' action: #upgrade. menu popUpInWorld.! ! !MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/21/2005 17:15'! includesPackage: aPackage ^self dependencies anySatisfy: [:each | each package = aPackage]! ! !MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'MarcusDenker 5/7/2012 13:17'! buttonSpecs ^ #(('Add' addDependency 'Add a dependency') ('Update' updateMenu 'Update dependencies') ('Install' installMenu 'Load/Merge/Upgrade into image') ('Up' up 'Move item up in list' canMoveUp) ('Down' down 'Move item down in list' canMoveDown) ('Remove' remove 'Remove item' canRemove) ('Migrate' migrate 'Migrate all packages to a repository') ('Store' store 'store configuration') )! ! !MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 4/19/2005 17:35'! checkMissing | missing | missing := (self dependencies collect: [:ea | ea versionInfo name]) asSet. self repositories do: [:repo | repo allVersionNames do: [:found | missing remove: found ifAbsent: []]] displayingProgress: 'searching versions'. ^missing isEmpty or: [ self selectDependency: missing anyOne. self confirm: (String streamContents: [:strm | strm nextPutAll: 'No repository found for'; cr. missing do: [:r | strm nextPutAll: r; cr]. strm nextPutAll: 'Do you still want to store?'])] ! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 17:57'! repositoryIndex ^repositoryIndex ifNil: [0]! ! !MCConfigurationBrowser methodsFor: 'description' stamp: 'marcus.denker 11/10/2008 10:04'! description: aText self selectedRepository ifNotNil: [:repo | | new | new := MCRepository readFrom: aText asString. (new class = repo class and: [new description = repo description]) ifTrue: [ repo creationTemplate: aText asString. self changed: #description] ifFalse: [ self inform: 'This does not match the previous definition!!' ] ]. ! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 4/19/2005 17:42'! merge self configuration merge. self changed: #dependencyList; changed: #description ! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:51'! list self dependencyIndex > 0 ifTrue: [^self dependencies]. self repositoryIndex > 0 ifTrue: [^self repositories]. ^#()! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! store (self checkRepositories and: [self checkDependencies]) ifFalse: [^self]. self pickName ifNotNil: [:name | self configuration name: name. self pickRepository ifNotNil: [:repo | repo storeVersion: self configuration]].! ! !MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'tbn 7/6/2010 17:05'! dependencyMenu: aMenu self fillMenu: aMenu fromSpecs: #(('Change log...' showChangeLog)). self fillMenu: aMenu fromSpecs: #(('Add dependency...' addDependency)). self selectedDependency ifNotNil: [ self fillMenu: aMenu fromSpecs: #(('Remove dependency...' remove))]. ^aMenu ! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 21:00'! updateIndex self index > 0 ifTrue: [self index: (self index min: self maxIndex)]! ! !MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/24/2005 00:45'! checkRepositories | bad | bad := self repositories reject: [:repo | repo isKindOf: MCHttpRepository]. ^bad isEmpty or: [ self selectRepository: bad first. self inform: (String streamContents: [:strm | strm nextPutAll: 'Please remove these repositories:'; cr. bad do: [:r | strm nextPutAll: r description; cr]. strm nextPutAll: '(only HTTP repositories are supported)']). false]. ! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:52'! maxIndex ^ self list size! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'GuillermoPolito 5/29/2011 14:46'! loadMenu | menu | menu := UIManager default newMenuIn: self for: self. menu add: 'update from image' action: #updateFromImage. menu add: 'update from repositories' action: #updateFromRepositories. menu popUpInWorld. ! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 5/27/2005 19:55'! dependencyIndex: anInteger dependencyIndex := anInteger. dependencyIndex > 0 ifTrue: [self repositoryIndex: 0]. self changed: #dependencyIndex; changed: #description. self changedButtons.! ! !MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 1/10/2006 17:58'! dependencyList ^self dependencies collect: [:dep | Text string: (dep isCurrent ifTrue: [dep versionInfo name] ifFalse: [':: ', dep versionInfo name]) attributes: (Array streamContents: [:attr | dep isFulfilledByAncestors ifFalse: [attr nextPut: TextEmphasis bold] ifTrue: [dep isCurrent ifFalse: [attr nextPut: TextEmphasis italic]]. ])] ! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 22:08'! add (self pickWorkingCopiesSatisfying: [:each | (self includesPackage: each package) not]) do: [:wc | wc ancestors isEmpty ifTrue: [self inform: 'You must save ', wc packageName, ' first!! Skipping this package'] ifFalse: [ self dependencies add: (MCVersionDependency package: wc package info: wc ancestors first)]]. self changed: #dependencyList; changed: #description! ! !MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'tbn 7/6/2010 17:05'! repositoryMenu: aMenu ^self fillMenu: aMenu fromSpecs: #( ('Add repository...' addRepository) )! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 21:01'! down self canMoveDown ifTrue: [ self list swap: self index with: self index + 1. self index: self index + 1. self changedList. ]. ! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 4/19/2005 17:43'! upgrade self configuration upgrade. self changed: #dependencyList; changed: #description ! ! !MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 3/23/2005 21:11'! pickRepository ^self pickRepositorySatisfying: [:ea | true] ! ! !MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/23/2005 21:15'! repositories: aCollection ^self configuration repositories: aCollection ! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 21:05'! remove self canRemove ifTrue: [ self list removeAt: self index. self changedList. self updateIndex. ]. ! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 5/27/2005 19:54'! changedButtons self changed: #canMoveDown. self changed: #canMoveUp. self changed: #canRemove.! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 21:00'! index: anInteger self dependencyIndex > 0 ifTrue: [^self dependencyIndex: anInteger]. self repositoryIndex > 0 ifTrue: [^self repositoryIndex: anInteger]. anInteger > 0 ifTrue: [self error: 'cannot select']! ! !MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/24/2005 00:47'! checkRepositoryTemplates "unused for now - we only do HTTP" | bad | bad := self repositories select: [:repo | repo creationTemplate isNil]. ^bad isEmpty or: [ self selectRepository: bad first. self inform: (String streamContents: [:strm | strm nextPutAll: 'Creation template missing for'; cr. bad do: [:r | strm nextPutAll: r description; cr]. strm nextPutAll: 'Please fill in the details first!!']). false]. ! ! !MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'DamienCassou 9/29/2009 13:00'! pickName | name | name := UIManager default request: ('Name' translated, ' (.', self configuration writerClass extension, ' will be appended' translated, '):') initialAnswer: (self configuration name ifNil: ['']). ^ name isEmptyOrNil ifFalse: [name]! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'CamilloBruni 8/3/2011 14:50'! changedList self dependencyIndex > 0 ifTrue: [ ^ self changed: #dependencyList ]. self repositoryIndex > 0 ifTrue: [ ^ self repositoryListChanged ]. self error: 'nothing selected'! ! !MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'StephaneDucasse 6/2/2012 20:34'! pickWorkingCopiesSatisfying: aBlock | copies item | copies := (self allManagers select: aBlock) asSortedCollection: [:a :b | a packageName <= b packageName]. item := UIManager default chooseFrom: ({'match ...' translated} , (copies collect: [:ea | ea packageName])) lines: #(1 ) title: 'Package:' translated. item = 1 ifTrue: [| pattern | pattern := UIManager default request: 'Packages matching:' translated initialAnswer: '*'. ^ pattern isEmptyOrNil ifTrue: [#()] ifFalse: [(pattern includes: $*) ifFalse: [pattern := '*' , pattern , '*']. copies select: [:ea | pattern match: ea packageName]]]. ^ item = 0 ifTrue: [#()] ifFalse: [{copies at: item - 1}]! ! !MCConfigurationBrowser methodsFor: 'repositories' stamp: 'CamilloBruni 8/3/2011 14:49'! addRepository (self pickRepositorySatisfying: [:ea | (self repositories includes: ea) not]) ifNotNil: [:repo | (repo isKindOf: MCHttpRepository) ifFalse: [^self inform: 'Only HTTP repositories are supported']. self repositories add: repo. self repositoryListChanged. ]! ! !MCConfigurationBrowser methodsFor: 'updating' stamp: 'bf 5/23/2005 17:44'! updateFromImage self configuration updateFromImage. self changed: #dependencyList; changed: #description ! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'StephaneDucasse 2/25/2011 18:45'! updateMenu | menu | menu := UIManager default newMenuIn: self for: self. menu add: 'update from image' action: #updateFromImage. menu add: 'update from repositories' action: #updateFromRepositories. menu popUpInWorld.! ! !MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 4/19/2005 17:36'! checkDependencies ^self checkModified and: [self checkMissing]! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 23:15'! selectRepository: aRepository self repositoryIndex: (self repositories indexOf: aRepository)! ! !MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 4/19/2005 16:51'! defaultExtent ^ 350@500! ! !MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 4/19/2005 16:02'! dependencies: aCollection self configuration dependencies: aCollection. self changed: #dependencyList; changed: #description ! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 5/27/2005 19:55'! repositoryIndex: anInteger repositoryIndex := anInteger. repositoryIndex > 0 ifTrue: [self dependencyIndex: 0]. self changed: #repositoryIndex; changed: #description. self changedButtons.! ! !MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/21/2005 14:56'! configuration: aConfiguration configuration := aConfiguration! ! !MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/23/2005 21:15'! repositoryList ^self repositories collect: [:ea | ea description] ! ! !MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:41'! repositories ^ self configuration repositories! ! !MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:44'! canMoveDown ^self index between: 1 and: self maxIndex - 1 ! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 4/19/2005 17:42'! load self configuration load. self changed: #dependencyList; changed: #description ! ! !MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'marcus.denker 11/10/2008 10:04'! selectedPackage ^ self selectedDependency ifNotNil: [:dep | dep package]! ! !MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'bf 3/23/2005 22:01'! widgetSpecs ^ #( ((buttonRow) (0 0 1 0) (0 0 0 30)) ((listMorph:selection:menu: dependencyList dependencyIndex dependencyMenu:) (0 0 1 1) (0 30 0 -180)) ((listMorph:selection:menu: repositoryList repositoryIndex repositoryMenu:) (0 1 1 1) (0 -180 0 -120)) ((textMorph: description) (0 1 1 1) (0 -120 0 0)) )! ! !MCConfigurationBrowser methodsFor: 'updating' stamp: 'bf 5/23/2005 17:44'! updateFromRepositories self configuration updateFromRepositories. self changed: #dependencyList; changed: #description ! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'MarcusDenker 12/11/2009 07:39'! showChangeLog self pickConfig ifNotNil: [:oldConfig | Transcript dependents isEmpty ifTrue: [Transcript open] ifFalse: [Transcript dependents do: [:ea | ea isSystemWindow ifTrue: [ea activate]]]. Cursor wait showWhile: [ MCConfiguration whatChangedFrom: oldConfig to: configuration on: Transcript. Transcript flush]]! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:43'! index ^self dependencyIndex max: self repositoryIndex! ! !MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 3/23/2005 22:08'! addDependency (self pickWorkingCopiesSatisfying: [:each | (self includesPackage: each package) not]) do: [:wc | wc ancestors isEmpty ifTrue: [self inform: 'You must save ', wc packageName, ' first!! Skipping this package'] ifFalse: [ self dependencies add: (MCVersionDependency package: wc package info: wc ancestors first)]]. self changed: #dependencyList; changed: #description! ! !MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 4/19/2005 17:37'! checkModified | modified | modified := self dependencies select: [:dep | dep isFulfilled and: [dep package workingCopy modified]]. ^modified isEmpty or: [ self selectDependency: modified anyOne. self confirm: (String streamContents: [:strm | strm nextPutAll: 'These packages are modified:'; cr. modified do: [:dep | strm nextPutAll: dep package name; cr]. strm nextPutAll: 'Do you still want to store?'])] ! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 23:16'! selectDependency: aDependency self dependencyIndex: (self dependencies indexOf: aDependency)! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 17:56'! dependencyIndex ^dependencyIndex ifNil: [0]! ! !MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/21/2005 16:03'! configuration ^configuration ifNil: [configuration := MCConfiguration new]! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'bf 3/23/2005 20:53'! up self canMoveUp ifTrue: [ self list swap: self index with: self index - 1. self index: self index - 1. self changedList. ].! ! !MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/23/2005 17:58'! selectedRepository ^ self repositories at: self repositoryIndex ifAbsent: []! ! !MCConfigurationBrowser methodsFor: 'actions' stamp: 'MarcusDenker 12/11/2009 07:39'! migrate "copy all packageversions in this cofiguration to a repository" | versions | versions := OrderedCollection new. configuration depsSatisfying: [:dep | dep isFulfilledByAncestors not] versionDo: [:ver | versions add: ver] displayingProgress: 'finding packages'. self pickRepository ifNotNil: [:aRepository | versions do: [:eachVersion | Transcript cr; show: '',aRepository,' storeVersion: ', eachVersion. aRepository storeVersion: eachVersion ] ] ! ! !MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'bf 3/23/2005 17:56'! selectedDependency ^ self dependencies at: self dependencyIndex ifAbsent: []! ! !MCConfigurationBrowser methodsFor: 'morphic ui' stamp: 'alain.plantec 2/6/2009 11:06'! pickRepositorySatisfying: aBlock | index list | list := MCRepositoryGroup default repositories select: aBlock. index := (UIManager default chooseFrom: (list collect: [:ea | ea description]) title: 'Repository:' translated). ^ index = 0 ifFalse: [list at: index]! ! !MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:44'! canMoveUp ^self index > 1! ! !MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/21/2005 16:35'! dependencies ^self configuration dependencies ! ! !MCConfigurationBrowser class methodsFor: 'opening' stamp: 'bf 3/21/2005 19:50'! open ^self new show! ! !MCCredentialsRequest commentStamp: ''! I am used to prompt in a UI indepentent way for a username and a password. If the user successfully entered the two strings I return an MCServerCredential if not I return nil.! !MCCredentialsRequest methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:36'! userMessagePrompt ^ 'Please enter a username for ', self url asString! ! !MCCredentialsRequest methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:35'! url: anObject url := anObject! ! !MCCredentialsRequest methodsFor: 'exceptiondescription' stamp: 'CamilloBruni 4/11/2013 17:49'! defaultAction username := UIManager default request: self userMessagePrompt initialAnswer: self username title: 'User' translated. (username isNil or: [ username isEmpty ]) ifTrue: [ ^ nil ]. password := UIManager default requestPassword: self passwordMessagePrompt. ^ MCServerCredentials user: username password: password! ! !MCCredentialsRequest methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:48'! password: anObject password := anObject! ! !MCCredentialsRequest methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:48'! username: anObject username := anObject! ! !MCCredentialsRequest methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:35'! url ^ url! ! !MCCredentialsRequest methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:48'! password ^ password! ! !MCCredentialsRequest methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:36'! passwordMessagePrompt ^ 'Please enter a password for ', self url asString! ! !MCCredentialsRequest methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:48'! username ^ username! ! !MCCredentialsRequest class methodsFor: 'signalling' stamp: 'CamilloBruni 4/11/2013 17:49'! signalUrl: aUrl username: username password: password ^ self new url: aUrl; username: username; password: password; signal! ! !MCCredentialsRequest class methodsFor: 'signalling' stamp: 'CamilloBruni 4/11/2013 17:35'! signalUrl: aUrl ^ self new url: aUrl; signal! ! !MCDataStream commentStamp: ''! This is the save-to-disk facility. A DataStream can store one or more objects in a persistent form. To handle objects with sharing and cycles, you must use a ReferenceStream instead of a DataStream. (Or SmartRefStream.) ReferenceStream is typically faster and produces smaller files because it doesn't repeatedly write the same Symbols. Here is the way to use DataStream and ReferenceStream: rr := ReferenceStream fileNamed: 'test.obj'. rr nextPut: . rr close. To get it back: rr := ReferenceStream fileNamed: 'test.obj'. := rr next. rr close. Each object to be stored has two opportunities to control what gets stored. On the high level, objectToStoreOnDataStream allows you to substitute another object on the way out. The low level hook is storeDataOn:. The read-in counterparts to these messages are comeFullyUpOnReload and (class) readDataFrom:size:. See these methods for more information about externalizing and internalizing. NOTE: A DataStream should be treated as a write-stream for writing. It is a read-stream for reading. It is not a ReadWriteStream. ! !MCDataStream methodsFor: 'other' stamp: ''! byteStream ^ byteStream! ! !MCDataStream methodsFor: 'other' stamp: 'tk 8/18/1998 08:59'! setStream: aStream reading: isReading "PRIVATE -- Initialization method." aStream binary. basePos := aStream position. "Remember where we start. Earlier part of file contains a class or method file-in. Allow that to be edited. We don't deal in absolute file locations." byteStream := aStream.! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:03'! readString | str | byteStream ascii. str := byteStream nextString. byteStream binary. ^ str ! ! !MCDataStream methodsFor: 'write and read' stamp: ''! writeFloat: aFloat "PRIVATE -- Write the contents of a Float. We support 8-byte Floats here." byteStream nextNumber: 4 put: (aFloat at: 1). byteStream nextNumber: 4 put: (aFloat at: 2). ! ! !MCDataStream methodsFor: 'write and read' stamp: 'jm 7/31/97 16:16'! writeRectangle: anObject "Write the contents of a Rectangle. See if it can be a compact Rectangle (type=15). Rectangles with values outside +/- 2047 were stored as normal objects (type=9). 17:22 tk" | ok right bottom top left acc | ok := true. (right := anObject right) > 2047 ifTrue: [ok := false]. right < -2048 ifTrue: [ok := false]. (bottom := anObject bottom) > 2047 ifTrue: [ok := false]. bottom < -2048 ifTrue: [ok := false]. (top := anObject top) > 2047 ifTrue: [ok := false]. top < -2048 ifTrue: [ok := false]. (left := anObject left) > 2047 ifTrue: [ok := false]. left < -2048 ifTrue: [ok := false]. ok := ok & left isInteger & right isInteger & top isInteger & bottom isInteger. ok ifFalse: [ byteStream skip: -1; nextPut: 9; skip: 0. "rewrite type to be normal instance" ^ anObject storeDataOn: self]. acc := ((left bitAnd: 16rFFF) bitShift: 12) + (top bitAnd: 16rFFF). byteStream nextNumber: 3 put: acc. acc := ((right bitAnd: 16rFFF) bitShift: 12) + (bottom bitAnd: 16rFFF). byteStream nextNumber: 3 put: acc.! ! !MCDataStream methodsFor: 'write and read' stamp: 'lr 3/14/2010 21:13'! readWordLike | refPosn aSymbol newClass anObject | "Can be used by any class that is bits and not bytes (WordArray, Bitmap, SoundBuffer, etc)." refPosn := self getCurrentReference. aSymbol := self next. newClass := Smalltalk globals at: aSymbol asSymbol. anObject := newClass newFromStream: byteStream. "Size is number of long words." self setCurrentReference: refPosn. "before returning to next" ^ anObject! ! !MCDataStream methodsFor: 'write and read' stamp: '6/9/97 08:32 tk'! readArray "PRIVATE -- Read the contents of an Array. We must do beginReference: here after instantiating the Array but before reading its contents, in case the contents reference the Array. beginReference: will be sent again when we return to next, but that's ok as long as we save and restore the current reference position over recursive calls to next." | count array refPosn | count := byteStream nextNumber: 4. refPosn := self beginReference: (array := Array new: count). "relative pos" 1 to: count do: [:i | array at: i put: self next]. self setCurrentReference: refPosn. "relative pos" ^ array! ! !MCDataStream methodsFor: 'write and read' stamp: ' 6/9/97'! objectAt: anInteger "PRIVATE -- Read & return the object at a given stream position. 08:18 tk anInteger is a relative file position. " | savedPosn anObject refPosn | savedPosn := byteStream position. "absolute" refPosn := self getCurrentReference. "relative position" byteStream position: anInteger + basePos. "was relative" anObject := self next. self setCurrentReference: refPosn. "relative position" byteStream position: savedPosn. "absolute" ^ anObject! ! !MCDataStream methodsFor: 'write and read' stamp: ''! readBitmap "PRIVATE -- Read the contents of a Bitmap." ^ Bitmap newFromStream: byteStream "Note that the reader knows that the size is in long words, but the data is in bytes."! ! !MCDataStream methodsFor: 'write and read' stamp: ''! writeFalse: aFalse "PRIVATE -- Write the contents of a False."! ! !MCDataStream methodsFor: 'write and read' stamp: ''! setCurrentReference: refPosn "PRIVATE -- Set currentReference to refPosn. Noop here. Cf. ReferenceStream."! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:23'! writeStringOld: aString "PRIVATE -- Write the contents of a String." | length | aString size < 16384 ifTrue: [ (length := aString size) < 192 ifTrue: [byteStream nextPut: length] ifFalse: [byteStream nextPut: (length // 256 + 192). byteStream nextPut: (length \\ 256)]. aString do: [:char | byteStream nextPut: char asciiValue]] ifFalse: [self writeByteArray: aString]. "takes more space"! ! !MCDataStream methodsFor: 'write and read' stamp: ''! getCurrentReference "PRIVATE -- Return the currentReference posn. Overridden by ReferenceStream." ^ 0! ! !MCDataStream methodsFor: 'write and read' stamp: ''! readFloat "PRIVATE -- Read the contents of a Float. This is the fast way to read a Float. We support 8-byte Floats here. Non-IEEE" | new | new := Float new: 2. "To get an instance" new at: 1 put: (byteStream nextNumber: 4). new at: 2 put: (byteStream nextNumber: 4). ^ new! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 3/4/1999 22:58'! readUser "Reconstruct both the private class and the instance. Still used??" ^ self readInstance. "Will create new unique class" ! ! !MCDataStream methodsFor: 'write and read' stamp: 'MarianoMartinezPeck 6/5/2012 15:31'! readClass ^ self error: 'Classes cannot be materialized with DataStream'! ! !MCDataStream methodsFor: 'write and read' stamp: ''! readNil "PRIVATE -- Read the contents of an UndefinedObject." ^ nil! ! !MCDataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:12'! beginReference: anObject "We're starting to read anObject. Remember it and its reference position (if we care; ReferenceStream cares). Answer the reference position." ^ 0! ! !MCDataStream methodsFor: 'other' stamp: ''! reset "Reset the stream." byteStream reset! ! !MCDataStream methodsFor: 'other' stamp: ''! next: anInteger "Answer an Array of the next anInteger objects in the stream." | array | array := Array new: anInteger. 1 to: anInteger do: [:i | array at: i put: self next]. ^ array! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 1/24/2000 23:20'! readWordArray "PRIVATE -- Read the contents of a WordArray." ^ WordArray newFromStream: byteStream "Size is number of long words."! ! !MCDataStream methodsFor: 'other' stamp: 'CamilloBruni 8/1/2012 16:05'! errorWriteReference: anInteger "PRIVATE -- Raise an error because this case of nextPut:'s perform: shouldn't be called." self error: 'This should never be called'! ! !MCDataStream methodsFor: 'write and read' stamp: ''! writeInstance: anObject "PRIVATE -- Write the contents of an arbitrary instance." ^ anObject storeDataOn: self! ! !MCDataStream methodsFor: 'write and read' stamp: 'CamilloBruni 8/1/2012 16:18'! writeUser: anObject "Write the contents of an arbitrary User instance (and its devoted class)." "If anObject is an instance of a unique user class, will lie and say it has a generic class" ^ anObject storeDataOn: self! ! !MCDataStream methodsFor: 'write and read' stamp: 'jm 8/19/1998 17:00'! readByteArray "PRIVATE -- Read the contents of a ByteArray." | count | count := byteStream nextNumber: 4. ^ byteStream next: count "assume stream is in binary mode" ! ! !MCDataStream methodsFor: 'write and read' stamp: 'lr 3/14/2010 21:13'! readMethod "PRIVATE -- Read the contents of an arbitrary instance. ASSUMES: readDataFrom:size: sends me beginReference: after it instantiates the new object but before reading nested objects. NOTE: We must restore the current reference position after recursive calls to next. Let the instance, not the class read the data. " | instSize refPosn newClass className xxHeader nLits byteCodeSizePlusTrailer newMethod lits | instSize := (byteStream nextNumber: 4) - 1. refPosn := self getCurrentReference. className := self next. newClass := Smalltalk globals at: className asSymbol. xxHeader := self next. "nArgs := (xxHeader >> 24) bitAnd: 16rF." "nTemps := (xxHeader >> 18) bitAnd: 16r3F." "largeBit := (xxHeader >> 17) bitAnd: 1." nLits := xxHeader >> 9 bitAnd: 16rFF. "primBits := ((xxHeader >> 19) bitAnd: 16r600) + (xxHeader bitAnd: 16r1FF)." byteCodeSizePlusTrailer := instSize - newClass instSize - ((nLits + 1) * 4). "0" newMethod := newClass newMethod: byteCodeSizePlusTrailer header: xxHeader. self setCurrentReference: refPosn. "before readDataFrom:size:" self beginReference: newMethod. lits := newMethod numLiterals + 1. "counting header" 2 to: lits do: [ :ii | newMethod objectAt: ii put: self next ]. lits * 4 + 1 to: newMethod basicSize do: [ :ii | newMethod basicAt: ii put: byteStream next ]. "Get raw bytes directly from the file" self setCurrentReference: refPosn. "before returning to next" ^ newMethod! ! !MCDataStream methodsFor: 'other' stamp: 'tk 3/5/2002 09:51'! nextAndClose "Speedy way to grab one object. Only use when we are inside an object binary file. Do not use for the start of a SmartRefStream mixed code-and-object file." | obj | obj := self next. self close. ^ obj! ! !MCDataStream methodsFor: 'write and read' stamp: ''! writeArray: anArray "PRIVATE -- Write the contents of an Array." byteStream nextNumber: 4 put: anArray size. self nextPutAll: anArray.! ! !MCDataStream methodsFor: 'other' stamp: 'tk 5/29/97'! rootObject "Return the object at the root of the tree we are filing out. " ^ topCall! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:27'! readStringOld ^ byteStream nextStringOld! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 7/12/1998 13:32'! readShortRef "Read an object reference from two bytes only. Original object must be in first 65536 bytes of the file. Relative to start of data. vacantRef not a possibility." ^ self objectAt: (byteStream nextNumber: 2)! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 1/5/2000 11:47'! readReference "Read the contents of an object reference. (Cf. outputReference:) File is not now positioned at this object." | referencePosition | ^ (referencePosition := (byteStream nextNumber: 4)) = self vacantRef "relative" ifTrue: [nil] ifFalse: [self objectAt: referencePosition] "relative pos"! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:06'! writeByteArray: aByteArray "PRIVATE -- Write the contents of a ByteArray." byteStream nextNumber: 4 put: aByteArray size. "May have to convert types here..." byteStream nextPutAll: aByteArray.! ! !MCDataStream methodsFor: 'other' stamp: ''! close "Close the stream." | bytes | byteStream closed ifFalse: [ bytes := byteStream position. byteStream close] ifTrue: [bytes := 'unknown']. ^ bytes! ! !MCDataStream methodsFor: 'write and read' stamp: ''! readTrue "PRIVATE -- Read the contents of a True." ^ true! ! !MCDataStream methodsFor: 'write and read' stamp: 'MarcusDenker 10/5/2013 19:13'! next "Answer the next object in the stream." | type selector anObject isARefType internalObject | type := byteStream next. type ifNil: [ byteStream close. "clean up" byteStream position = 0 ifTrue: [self error: 'The file did not exist in this directory'] ifFalse: [self error: 'Unexpected end of object file']. ^ nil]. type = 0 ifTrue: [ byteStream close. "clean up" self error: 'Expected start of object, but found 0'. ^ nil]. isARefType := self noteCurrentReference: type. selector := #(readNil readTrue readFalse readInteger "<-4" readStringOld readSymbol readByteArray "<-7" readArray readInstance readReference readBitmap "<-11" readClass readUser readFloat readRectangle readShortInst "<-16" readString readWordArray foo "foo is a replacement for readWordArrayForSegment<-19" readWordLike readMethod "<-21") at: type. selector = 0 ifTrue: [ byteStream close. self error: 'file is more recent than this system'. ^ nil]. anObject := self perform: selector. "A method that recursively calls next (readArray, readInstance, objectAt:) must save & restore the current reference position." isARefType ifTrue: [self beginReference: anObject]. "After reading the externalObject, internalize it. #readReference is a special case. Either: (1) We actually have to read the object, recursively calling next, which internalizes the object. (2) We just read a reference to an object already read and thus already interalized. Either way, we must not re-internalize the object here." selector == #readReference ifTrue: [^ anObject]. internalObject := anObject comeFullyUpOnReload: self. internalObject == String ifTrue:[ "This is a hack to figure out if we're loading a String class that really should be a ByteString. Note that these days this will no longer be necessary since we use #withClassVersion: for constructing the global thus using a different classVersion will perfectly do the trick." ((anObject globalObjectName == #String) and:[anObject constructorSelector == #yourself]) ifTrue:[ internalObject := ByteString]]. ^ self maybeBeginReference: internalObject! ! !MCDataStream methodsFor: 'write and read' stamp: 'TestRunner 1/21/2010 21:58'! writeSymbol: aSymbol "PRIVATE -- Write the contents of a Symbol." self writeString: aSymbol! ! !MCDataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:25'! noteCurrentReference: typeID "PRIVATE -- If we support references for type typeID, remember the current byteStream position so we can add the next object to the 'objects' dictionary, and return true. Else return false. This method is here to be overridden by ReferenceStream" ^ false! ! !MCDataStream methodsFor: 'write and read' stamp: ''! writeTrue: aTrue "PRIVATE -- Write the contents of a True."! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 20:57'! writeString: aString "PRIVATE -- Write the contents of a String." byteStream nextStringPut: aString.! ! !MCDataStream methodsFor: 'write and read' stamp: ''! readInteger "PRIVATE -- Read the contents of a SmallInteger." ^ byteStream nextInt32 "signed!!!!!!"! ! !MCDataStream methodsFor: 'write and read' stamp: '6/9/97 08:14 tk'! beginInstance: aClass size: anInteger "This is for use by storeDataOn: methods. Cf. Object>>storeDataOn:." "Addition of 1 seems to make extra work, since readInstance has to compensate. Here for historical reasons dating back to Kent Beck's original implementation in late 1988. In ReferenceStream, class is just 5 bytes for shared symbol. SmartRefStream puts out the names and number of class's instances variables for checking." byteStream nextNumber: 4 put: anInteger + 1. self nextPut: aClass name! ! !MCDataStream methodsFor: 'write and read' stamp: ''! nextPutAll: aCollection "Write each of the objects in aCollection to the receiver stream. Answer aCollection." ^ aCollection do: [:each | self nextPut: each]! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 3/13/98 22:16'! objectIfBlocked: anObject "We don't do any blocking" ^ anObject! ! !MCDataStream methodsFor: 'write and read' stamp: ' 6/9/97'! readRectangle "Read a compact Rectangle. Rectangles with values outside +/- 2047 were stored as normal objects (type=9). They will not come here. 17:22 tk" "Encoding is four 12-bit signed numbers. 48 bits in next 6 bytes. 17:24 tk" | acc left top right bottom | acc := byteStream nextNumber: 3. left := acc bitShift: -12. (left bitAnd: 16r800) ~= 0 ifTrue: [left := left - 16r1000]. "sign" top := acc bitAnd: 16rFFF. (top bitAnd: 16r800) ~= 0 ifTrue: [top := top - 16r1000]. "sign" acc := byteStream nextNumber: 3. right := acc bitShift: -12. (right bitAnd: 16r800) ~= 0 ifTrue: [right := right - 16r1000]. "sign" bottom := acc bitAnd: 16rFFF. (bottom bitAnd: 16r800) ~= 0 ifTrue: [bottom := bottom - 16r1000]. "sign" ^ Rectangle left: left right: right top: top bottom: bottom ! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 4/8/1999 13:11'! maybeBeginReference: internalObject "Do nothing. See ReferenceStream|maybeBeginReference:" ^ internalObject! ! !MCDataStream methodsFor: 'write and read' stamp: 'TestRunner 1/21/2010 21:44'! readSymbol "PRIVATE -- Read the contents of a Symbol." ^ self readString asSymbol! ! !MCDataStream methodsFor: 'other' stamp: 'tk 7/12/1998 13:16'! vacantRef "Answer the magic 32-bit constant we use ***ON DISK*** as a stream 'reference position' to identify a reference that's not yet filled in. This must be a value that won't be used as an ordinary reference. Cf. outputReference: and readReference. -- NOTE: We could use a different type ID for vacant-refs rather than writing object-references with a magic value. (The type ID and value are overwritten by ordinary object-references when weak refs are fullfilled.)" ^ SmallInteger maxVal! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:07'! writeBitmap: aBitmap "PRIVATE -- Write the contents of a Bitmap." aBitmap writeOn: byteStream "Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!! Reader must know that size is in long words."! ! !MCDataStream methodsFor: 'other' stamp: ''! size "Answer the stream's size." ^ byteStream size! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 2/20/1999 23:02'! typeIDFor: anObject "Return the typeID for anObject's class. This is where the tangle of objects is clipped to stop everything from going out. Classes can control their instance variables by defining objectToStoreOnDataStream. Any object in blockers is not written out. See ReferenceStream.objectIfBlocked: and DataStream nextPut:. Morphs do not write their owners. See Morph.storeDataOn: Each morph tells itself to 'prepareToBeSaved' before writing out." ^ TypeMap at: anObject class ifAbsent: [9 "instance of any normal class"] "See DataStream initialize. nil=1. true=2. false=3. a SmallInteger=4. (a String was 5). a Symbol=6. a ByteArray=7. an Array=8. other = 9. a Bitmap=11. a Metaclass=12. a Float=14. a Rectangle=15. any instance that can have a short header=16. a String=17 (new format). a WordArray=18."! ! !MCDataStream methodsFor: 'other' stamp: ''! atEnd "Answer true if the stream is at the end." ^ byteStream atEnd! ! !MCDataStream methodsFor: 'write and read' stamp: 'MarcusDenker 7/14/2012 01:31'! nextPut: anObject "Write anObject to the receiver stream. Answer anObject." | typeID selector objectToStore | typeID := self typeIDFor: anObject. (self tryToPutReference: anObject typeID: typeID) ifTrue: [^ anObject]. objectToStore := (self objectIfBlocked: anObject). objectToStore == anObject ifFalse: [typeID := self typeIDFor: objectToStore]. byteStream nextPut: typeID. selector := #(writeNil: writeTrue: writeFalse: writeInteger: writeStringOld: writeSymbol: writeByteArray: writeArray: writeInstance: errorWriteReference: writeBitmap: writeClass: writeUser: writeFloat: writeRectangle: == "<-16 short inst" writeString: writeBitmap: writeBitmap: writeWordLike: writeInstance: "CompiledMethod") at: typeID. self perform: selector with: objectToStore. ^ anObject! ! !MCDataStream methodsFor: 'write and read' stamp: 'lr 3/14/2010 21:13'! readInstance "PRIVATE -- Read the contents of an arbitrary instance. ASSUMES: readDataFrom:size: sends me beginReference: after it instantiates the new object but before reading nested objects. NOTE: We must restore the current reference position after recursive calls to next. Let the instance, not the class read the data. " | instSize aSymbol refPosn anObject newClass | instSize := (byteStream nextNumber: 4) - 1. refPosn := self getCurrentReference. aSymbol := self next. newClass := Smalltalk globals at: aSymbol asSymbol. anObject := newClass isVariable ifFalse: [ newClass basicNew ] ifTrue: [ newClass basicNew: instSize - newClass instSize ]. "Create object here" self setCurrentReference: refPosn. "before readDataFrom:size:" anObject := anObject readDataFrom: self size: instSize. self setCurrentReference: refPosn. "before returning to next" ^ anObject! ! !MCDataStream methodsFor: 'write and read' stamp: ''! writeInteger: anInteger "PRIVATE -- Write the contents of a SmallInteger." byteStream nextInt32Put: anInteger "signed!!!!!!!!!!"! ! !MCDataStream methodsFor: 'write and read' stamp: 'MarianoMartinezPeck 6/5/2012 15:32'! writeClass: aClass ^ self error: 'Classes cannot be serialized with DataStream'! ! !MCDataStream methodsFor: 'write and read' stamp: '6/9/97 08:46 tk'! outputReference: referencePosn "PRIVATE -- Output a reference to the object at integer stream position referencePosn (relative to basePos). To output a weak reference to an object not yet written, supply (self vacantRef) for referencePosn." byteStream nextPut: 10. "reference typeID" byteStream nextNumber: 4 put: referencePosn "relative position"! ! !MCDataStream methodsFor: 'write and read' stamp: ''! readFalse "PRIVATE -- Read the contents of a False." ^ false! ! !MCDataStream methodsFor: 'other' stamp: '6/9/97 08:03 di'! setStream: aStream "PRIVATE -- Initialization method." aStream binary. basePos := aStream position. "Remember where we start. Earlier part of file contains a class or method file-in. Allow that to be edited. We don't deal in absolute file locations." byteStream := aStream.! ! !MCDataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 16:59'! tryToPutReference: anObject typeID: typeID "PRIVATE -- If we support references for type typeID, and if anObject already appears in my output stream, then put a reference to the place where anObject already appears. If we support references for typeID but didn't already put anObject, then associate the current stream position with anObject in case one wants to nextPut: it again. Return true after putting a reference; false if the object still needs to be put. For DataStream this is trivial. ReferenceStream overrides this." ^ false! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 2/5/2000 21:53'! writeWordLike: aWordArray "Note that we put the class name before the size." self nextPut: aWordArray class name. aWordArray writeOn: byteStream "Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!! Reader must know that size is in long words or double-bytes."! ! !MCDataStream methodsFor: 'write and read' stamp: ''! writeNil: anUndefinedObject "PRIVATE -- Write the contents of an UndefinedObject."! ! !MCDataStream methodsFor: 'other' stamp: 'CamilloBruni 8/1/2012 16:06'! flush "Guarantee that any writes to me are actually recorded on disk." ^ byteStream flush! ! !MCDataStream methodsFor: 'other' stamp: 'tk 5/29/97'! rootObject: anObject "Return the object at the root of the tree we are filing out. " topCall := anObject! ! !MCDataStream methodsFor: 'other' stamp: 'nk 3/12/2004 21:56'! contents ^byteStream contents! ! !MCDataStream methodsFor: 'write and read' stamp: 'lr 3/14/2010 21:13'! readShortInst "Read the contents of an arbitrary instance that has a short header. ASSUMES: readDataFrom:size: sends me beginReference: after it instantiates the new object but before reading nested objects. NOTE: We must restore the current reference position after recursive calls to next. Let the instance, not the class read the data. " | instSize aSymbol refPosn anObject newClass | instSize := byteStream next - 1. "one byte of size" refPosn := self getCurrentReference. aSymbol := self readShortRef. "class symbol in two bytes of file pos" newClass := Smalltalk globals at: aSymbol asSymbol. anObject := newClass isVariable ifFalse: [ newClass basicNew ] ifTrue: [ newClass basicNew: instSize - newClass instSize ]. "Create object here" self setCurrentReference: refPosn. "before readDataFrom:size:" anObject := anObject readDataFrom: self size: instSize. self setCurrentReference: refPosn. "before returning to next" ^ anObject! ! !MCDataStream class methodsFor: 'instance creation' stamp: 'CarloTeixeira 2/26/2012 00:19'! fileNamed: fileName do: aBlock "Returns the result of aBlock." ^ self detectFile: [ self fileNamed: fileName ] do: aBlock! ! !MCDataStream class methodsFor: 'instance creation' stamp: 'MicheleLanza 10/23/2010 10:36'! oldFileNamed: aString "Here is the way to use DataStream and ReferenceStream: |rr | rr := ReferenceStream oldFileNamed: 'test.obj'. ^ rr nextAndClose. " | strm ff | ff := FileStream oldFileOrNoneNamed: aString. ff ifNil: [^ nil]. strm := self on: (ff binary). ^ strm! ! !MCDataStream class methodsFor: 'initialize-release' stamp: 'CamilloBruni 11/5/2013 17:13'! initialize "TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats. nextPut: writes these IDs to the data stream. NOTE: Changing these type ID numbers will invalidate all extant data stream files. Adding new ones is OK. Classes named here have special formats in the file. If such a class has a subclass, it will use type 9 and write correctly. It will just be slow. (Later write the class name in the special format, then subclasses can use the type also.) See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:" "MCDataStream initialize" | refTypes t | refTypes := OrderedCollection new. t := TypeMap := WeakKeyDictionary new: 80. "sparse for fast hashing" t at: UndefinedObject put: 1. refTypes add: 0. t at: True put: 2. refTypes add: 0. t at: False put: 3. refTypes add: 0. t at: SmallInteger put: 4. refTypes add: 0. t at: ByteString put: 5. refTypes add: 1. t at: ByteSymbol put: 6. refTypes add: 1. t at: ByteArray put: 7. refTypes add: 1. t at: Array put: 8. refTypes add: 1. "(type ID 9 is for arbitrary instances of any class, cf. typeIDFor:)" refTypes add: 1. "(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)" refTypes add: 0. t at: Bitmap put: 11. refTypes add: 1. t at: Metaclass put: 12. refTypes add: 0. "Type ID 13 is used for HyperSqueak User classes that must be reconstructed." refTypes add: 1. t at: Float put: 14. refTypes add: 1. t at: Rectangle put: 15. refTypes add: 1. "Allow compact Rects." "type ID 16 is an instance with short header. See beginInstance:size:" refTypes add: 1. self flag: #ByteArray. t at: ByteString put: 17. refTypes add: 1. "new String format, 1 or 4 bytes of length" t at: WordArray put: 18. refTypes add: 1. "bitmap-like" Smalltalk globals at: #SoundBuffer ifPresent: [ :class | t at: class put: 20. ]. refTypes add: 1. "And all other word arrays, both 16-bit and 32-bit. See methods in ArrayedCollection. Overridden in SoundBuffer." t at: CompiledMethod put: 21. refTypes add: 1. "special creation method" "t at: put: 22. refTypes add: 0." Smalltalk do: [ :cls | cls isBehavior ifTrue: [ cls isPointers not & cls isVariable & cls isWords ifTrue: [ (t includesKey: cls) ifFalse: [ t at: cls put: 20 ] ] ] ]! ! !MCDataStream class methodsFor: 'instance creation' stamp: 'di 2/15/98 14:03'! new ^ self basicNew! ! !MCDataStream class methodsFor: 'instance creation' stamp: 'MicheleLanza 10/23/2010 10:36'! fileNamed: aString "Here is the way to use DataStream and ReferenceStream: | rr | rr := ReferenceStream fileNamed: 'test.obj'. rr nextPut: 'Zork'. rr close. " | strm | strm := self on: (FileStream fileNamed: aString). "will be binary" strm byteStream setFileTypeToObject. "Type and Creator not to be text, so can attach correctly to an email msg" ^ strm! ! !MCDataStream class methodsFor: 'instance creation' stamp: 'MicheleLanza 10/23/2010 10:39'! readOnlyFileNamed: aString "Here is the way to use DataStream and ReferenceStream: |rr| rr := ReferenceStream fileNamed: 'test.obj'. rr nextPut: 'Zork'. rr close. " | strm | strm := self on: (FileStream readOnlyFileNamed: aString). "will be binary" strm byteStream setFileTypeToObject. "Type and Creator not to be text, so can attach correctly to an email msg" ^ strm! ! !MCDataStream class methodsFor: 'instance creation' stamp: 'MicheleLanza 10/23/2010 10:37'! newFileNamed: aString "Here is the way to use DataStream and ReferenceStream: |rr| rr := ReferenceStream fileNamed: 'test.obj'. rr nextPut: 'Zork'. rr close. " | strm | strm := self on: (FileStream newFileNamed: aString). "will be binary" strm byteStream setFileTypeToObject. "Type and Creator not to be text, so can attach correctly to an email msg" ^ strm! ! !MCDataStream class methodsFor: 'instance creation' stamp: 'CarloTeixeira 2/26/2012 00:18'! detectFile: aBlock do: anotherBlock ^aBlock value ifNil: [nil] ifNotNil: [:file| [anotherBlock value: file] ensure: [file close]]! ! !MCDataStream class methodsFor: 'instance creation' stamp: 'RAA 7/28/2000 08:38'! streamedRepresentationOf: anObject | file | file := (RWBinaryOrTextStream on: (ByteArray new: 5000)). file binary. (self on: file) nextPut: anObject. ^file contents! ! !MCDataStream class methodsFor: 'instance creation' stamp: 'di 6/24/97 00:18'! on: aStream "Open a new DataStream onto a low-level I/O stream." ^ self basicNew setStream: aStream "aStream binary is in setStream:" ! ! !MCDataStream class methodsFor: 'instance creation' stamp: 'RAA 7/28/2000 08:33'! unStream: aString ^(self on: ((RWBinaryOrTextStream with: aString) reset; binary)) next! ! !MCDataStream class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:24'! cleanUp "Re-initialize DataStream to avoid hanging onto obsolete classes" self initialize! ! !MCDataStreamTest methodsFor: 'testing' stamp: 'MarianoMartinezPeck 6/17/2012 12:37'! baseStreamType ^ MCDataStream! ! !MCDefinition commentStamp: ''! A MCDefinition is the root of inheritance of entities representing code. ! !MCDefinition methodsFor: 'comparing' stamp: 'damiencassou 11/27/2008 18:15'! isRevisionOf: aDefinition ^ (aDefinition isKindOf: MCDefinition) and: [aDefinition description = self description]! ! !MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:14'! description self subclassResponsibility! ! !MCDefinition methodsFor: 'accessing' stamp: 'ab 5/24/2003 14:12'! requirements ^ #()! ! !MCDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:51'! isClassDefinition ^false! ! !MCDefinition methodsFor: 'installing' stamp: 'avi 2/17/2004 13:19'! loadOver: aDefinition self load ! ! !MCDefinition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:11'! koDestinationText ^ self source! ! !MCDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 12/12/2008 16:18'! actualClass "Since the targetClass call on a patch operation will fail otherwise." ^nil! ! !MCDefinition methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2013 14:21'! source ^ self subclassResponsibility.! ! !MCDefinition methodsFor: 'installing' stamp: 'AdrianLienhard 1/21/2010 22:14'! addMethodAdditionTo: aCollection self load! ! !MCDefinition methodsFor: 'printing' stamp: 'ab 7/18/2003 19:43'! printOn: aStream super printOn: aStream. aStream nextPutAll: '(', self summary, ')'! ! !MCDefinition methodsFor: 'installing' stamp: 'ab 7/18/2003 21:31'! load ! ! !MCDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/1/2009 12:14'! fullClassName "Answer the className by default." ^self className! ! !MCDefinition methodsFor: 'installing' stamp: 'ab 11/14/2002 00:08'! unload! ! !MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:25'! isSameRevisionAs: aDefinition ^ self = aDefinition! ! !MCDefinition methodsFor: 'annotations' stamp: 'StephaneDucasse 12/30/2012 18:04'! printAnnotations: requests on: aStream "Add a string for an annotation pane, trying to fulfill the browser annotationRequests." aStream nextPutAll: 'not yet implemented'! ! !MCDefinition methodsFor: 'accessing' stamp: 'ab 5/24/2003 14:12'! provisions ^ #()! ! !MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:14'! hash ^ self description hash! ! !MCDefinition methodsFor: 'installing' stamp: 'avi 2/17/2004 13:19'! postloadOver: aDefinition self postload! ! !MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:04'! sortKey self subclassResponsibility ! ! !MCDefinition methodsFor: 'testing' stamp: 'bf 11/12/2004 14:46'! isClassDefinitionExtension "Answer true if this definition extends the regular class definition" ^false! ! !MCDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/1/2009 12:11'! className "Answer the class name here or nil if not applicable." ^nil! ! !MCDefinition methodsFor: 'testing' stamp: 'bf 8/12/2009 22:55'! isScriptDefinition ^false! ! !MCDefinition methodsFor: 'installing' stamp: 'ab 7/18/2003 19:48'! postload! ! !MCDefinition methodsFor: 'printing' stamp: 'ab 7/19/2003 18:23'! summary self subclassResponsibility ! ! !MCDefinition methodsFor: 'testing' stamp: 'cwp 7/11/2003 01:32'! isOrganizationDefinition ^false! ! !MCDefinition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:17'! koSourceText ^ self source! ! !MCDefinition methodsFor: 'comparing' stamp: 'nice 10/31/2009 13:08'! = aDefinition ^(aDefinition isKindOf: MCDefinition) and: [self isRevisionOf: aDefinition]! ! !MCDefinition methodsFor: 'comparing' stamp: 'SvenVanCaekenberghe 12/22/2013 16:28'! fullTimeStamp ^ DateAndTime current! ! !MCDefinition methodsFor: 'printing' stamp: 'StephaneDucasse 8/17/2012 16:31'! summarySuffixOver: previousDefinition ^self source = previousDefinition source ifTrue: [ ' (source same but rev changed)' ] ifFalse: [ ' (changed)' ]! ! !MCDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:51'! isMethodDefinition ^false! ! !MCDefinition methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2013 14:21'! diffSource ^ self source! ! !MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 17:59'! <= other ^ self sortKey <= other sortKey! ! !MCDefinition class methodsFor: 'cleanup' stamp: 'stephaneducasse 2/4/2006 20:47'! clearInstances WeakArray removeWeakDependent: Instances. Instances := nil! ! !MCDefinition class methodsFor: 'instance creation' stamp: 'CamilloBruni 2/22/2014 21:10'! instanceLike: aDefinition Instances ifNil: [ Instances := WeakSet new ]. InstancesWriteLock ifNil: [ InstancesWriteLock := Semaphore forMutualExclusion ]. ^ (Instances like: aDefinition) ifNil: [ InstancesWriteLock critical: [ Instances add: aDefinition ]]! ! !MCDefinition class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:33'! cleanUp "Flush caches" self clearInstances.! ! !MCDefinitionIndex commentStamp: 'LaurentLaffont 3/31/2011 21:06'! I'm a simple container of MCDefinitions which can be added or removed.! !MCDefinitionIndex methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:02'! initialize super initialize. definitions := Dictionary new! ! !MCDefinitionIndex methodsFor: 'accessing' stamp: 'ab 6/2/2003 00:42'! definitions ^ definitions values! ! !MCDefinitionIndex methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! definitionLike: aDefinition ifPresent: foundBlock ifAbsent: errorBlock | definition | definition := definitions at: aDefinition description ifAbsent: []. ^ definition ifNil: errorBlock ifNotNil: [foundBlock value: definition]! ! !MCDefinitionIndex methodsFor: 'adding' stamp: 'ab 6/2/2003 00:38'! addAll: aCollection aCollection do: [:ea | self add: ea]! ! !MCDefinitionIndex methodsFor: 'adding' stamp: 'StephaneDucasse 5/6/2010 08:52'! add: aDefinition ^ definitions at: aDefinition description put: aDefinition! ! !MCDefinitionIndex methodsFor: 'removing' stamp: 'ab 6/2/2003 00:40'! remove: aDefinition definitions removeKey: aDefinition description ifAbsent: []! ! !MCDefinitionIndex class methodsFor: 'instance-creation' stamp: 'ab 6/2/2003 01:29'! definitions: aCollection ^ self new addAll: aCollection! ! !MCDependencySorter commentStamp: ''! A MCDependencySorter computes the dependencies to a set of entities.! !MCDependencySorter methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! addProvision: anObject | newlySatisfied | provided add: anObject. newlySatisfied := required removeKey: anObject ifAbsent: [#()]. self addAll: newlySatisfied.! ! !MCDependencySorter methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! itemsWithMissingRequirements | items | items := Set new. required do: [:ea | items addAll: ea]. ^ items ! ! !MCDependencySorter methodsFor: 'building' stamp: 'bf 11/12/2004 14:50'! addAll: aCollection aCollection asArray sort do: [:ea | self add: ea]! ! !MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:24'! itemsRequiring: anObject ^ required at: anObject ifAbsentPut: [Set new]! ! !MCDependencySorter methodsFor: 'building' stamp: 'avi 10/7/2004 22:47'! addExternalProvisions: aCollection (aCollection intersection: self externalRequirements) do: [:ea | self addProvision: ea]! ! !MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:23'! addRequirements: aCollection for: anObject aCollection do: [:ea | self addRequirement: ea for: anObject]! ! !MCDependencySorter methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:02'! initialize super initialize. provided := Set new. required := Dictionary new. orderedItems := OrderedCollection new.! ! !MCDependencySorter methodsFor: 'sorting' stamp: 'ab 5/22/2003 23:25'! orderedItems ^ orderedItems! ! !MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:24'! addRequirement: reqObject for: itemObject (self itemsRequiring: reqObject) add: itemObject! ! !MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:15'! addToOrder: anItem orderedItems add: anItem. anItem provisions do: [:ea | self addProvision: ea].! ! !MCDependencySorter methodsFor: 'building' stamp: 'StephaneDucasse 5/6/2010 08:52'! add: anItem | requirements | requirements := self unresolvedRequirementsFor: anItem. requirements isEmpty ifTrue: [self addToOrder: anItem] ifFalse: [self addRequirements: requirements for: anItem]. ^ anItem! ! !MCDependencySorter methodsFor: 'accessing' stamp: 'dvf 9/8/2004 00:49'! externalRequirements | unloaded providedByUnloaded | unloaded := self itemsWithMissingRequirements. providedByUnloaded := (unloaded gather: [:e | e provisions]) asSet. ^ required keys reject: [:ea | providedByUnloaded includes: ea ]! ! !MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:22'! unresolvedRequirementsFor: anItem ^ anItem requirements difference: provided! ! !MCDependencySorter class methodsFor: 'instance-creation' stamp: 'ab 5/23/2003 14:17'! items: aCollection ^ self new addAll: aCollection! ! !MCDependencySorter class methodsFor: 'public' stamp: 'stephaneducasse 2/4/2006 20:47'! sortItems: aCollection | sorter | sorter := self items: aCollection. sorter externalRequirements do: [:req | sorter addProvision: req]. ^ sorter orderedItems.! ! !MCDependencySorterTest methodsFor: 'asserting' stamp: 'avi 10/7/2004 22:32'! assertItems: anArray orderAs: depOrder withRequired: missingDeps toLoad: unloadableItems self assertItems: anArray orderAs: depOrder withRequired: missingDeps toLoad: unloadableItems extraProvisions: #()! ! !MCDependencySorterTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! assertItems: anArray orderAs: depOrder withRequired: missingDeps toLoad: unloadableItems extraProvisions: provisions | order sorter items missing unloadable | items := anArray collect: [:ea | self itemWithSpec: ea]. sorter := MCDependencySorter items: items. sorter addExternalProvisions: provisions. order := (sorter orderedItems collect: [:ea | ea name]) asArray. self assert: order = depOrder. missing := sorter externalRequirements. self assert: missing asSet = missingDeps asSet. unloadable := (sorter itemsWithMissingRequirements collect: [:ea | ea name]) asArray. self assert: unloadable asSet = unloadableItems asSet! ! !MCDependencySorterTest methodsFor: 'building' stamp: 'ab 5/24/2003 14:08'! itemWithSpec: anArray ^ MCMockDependentItem new name: anArray first; provides: anArray second; requires: anArray third! ! !MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'! testCascadingUnresolved self assertItems: #( (a (x) (z)) (b () (x)) (c () ())) orderAs: #(c) withRequired: #(z) toLoad: #(a b) ! ! !MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:12'! testSimpleUnresolved self assertItems: #( (a () (z))) orderAs: #() withRequired: #(z) toLoad: #(a) ! ! !MCDependencySorterTest methodsFor: 'tests' stamp: 'avi 10/7/2004 22:35'! testExtraProvisions self assertItems: #((a (x) (z)) (b () (x))) orderAs: #(a b) withRequired: #() toLoad: #() extraProvisions: #(x z)! ! !MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'! testSimpleOrdering self assertItems: #((a (x) ()) (c () (y)) (b (y) (x))) orderAs: #(a b c) withRequired: #() toLoad: #()! ! !MCDependencySorterTest methodsFor: 'tests' stamp: 'avi 10/7/2004 22:12'! testUnusedAlternateProvider self assertItems: #( (a (x) (z)) (b () (x)) (c (x) ())) orderAs: #(c b) withRequired: #(z) toLoad: #(a) ! ! !MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'! testCycle self assertItems: #( (a (x) (y)) (b (y) (x))) orderAs: #() withRequired: #() toLoad: #(a b) ! ! !MCDependencySorterTest methodsFor: 'tests' stamp: 'ab 5/25/2003 01:11'! testMultiRequirementOrdering self assertItems: #( (a (x) (z)) (b (y) ()) (c (z) ()) (d () (x y z))) orderAs: #(b c a d) withRequired: #() toLoad: #()! ! !MCDependencySorterTest class methodsFor: 'testing' stamp: 'JorgeRessia 3/16/2010 20:26'! isUnitTest ^false! ! !MCDependentsWrapper commentStamp: 'TorstenBergmann 2/20/2014 15:53'! Specialized list item wrapper for dependents! !MCDependentsWrapper methodsFor: 'comparing' stamp: 'c 8/10/2010 22:15'! hash ^ (self item package name hash * 37) + self model hash ! ! !MCDependentsWrapper methodsFor: 'comparing' stamp: 'c 8/10/2010 22:24'! = anMCDependentsWrapper self class = anMCDependentsWrapper class ifFalse: [^ false]. ^ (self item package name = anMCDependentsWrapper item package name) and: [self model = anMCDependentsWrapper model]. ! ! !MCDependentsWrapper methodsFor: 'accessing' stamp: 'ar 2/14/2004 02:31'! hasContents ^item requiredPackages isEmpty not! ! !MCDependentsWrapper methodsFor: 'accessing' stamp: 'avi 9/10/2004 17:54'! contents | list workingCopies | workingCopies := model unsortedWorkingCopies. list := item requiredPackages collect: [:each | workingCopies detect: [:wc | wc package = each] ifNone: [nil]] thenSelect: [:x | x notNil]. ^list collect: [:each | self class with: each model: model]! ! !MCDependentsWrapper methodsFor: 'converting' stamp: 'ar 2/14/2004 02:31'! asString ^item description! ! !MCDictionaryRepository commentStamp: 'TorstenBergmann 2/5/2014 13:55'! A dictionary repository (in nemory)! !MCDictionaryRepository methodsFor: 'accessing' stamp: 'GabrielOmarCotelli 12/3/2013 17:30'! closestAncestorVersionFor: anAncestry ifNone: errorBlock ^ anAncestry breadthFirstAncestors detect: [ :ea | self includesVersionWithInfo: ea ] ifFound: [ :info | self versionWithInfo: info ] ifNone: errorBlock! ! !MCDictionaryRepository methodsFor: 'accessing' stamp: 'ab 7/26/2003 02:47'! description ^ description ifNil: ['cache']! ! !MCDictionaryRepository methodsFor: '*MonticelloGUI' stamp: 'ar 8/6/2009 18:24'! morphicOpen: aWorkingCopy | names index infos | infos := self sortedVersionInfos. infos isEmpty ifTrue: [^ self inform: 'No versions']. names := infos collect: [:ea | ea name]. index := UIManager default chooseFrom: names title: 'Open version:'. index = 0 ifFalse: [(self versionWithInfo: (infos at: index)) open]! ! !MCDictionaryRepository methodsFor: 'interface' stamp: 'ab 8/16/2003 18:22'! versionWithInfo: aVersionInfo ifAbsent: errorBlock ^ dict at: aVersionInfo ifAbsent: errorBlock! ! !MCDictionaryRepository methodsFor: 'testing' stamp: 'ab 8/21/2003 19:49'! includesVersionWithInfo: aVersionInfo ^ dict includesKey: aVersionInfo! ! !MCDictionaryRepository methodsFor: '*gofer-core-accessing' stamp: 'TestRunner 12/12/2009 11:12'! goferReferences ^ self allVersionInfos collect: [ :each | GoferResolvedReference name: each name repository: self ]! ! !MCDictionaryRepository methodsFor: '*gofer-core-accessing' stamp: 'lr 12/11/2009 22:31'! goferPriority ^ 10! ! !MCDictionaryRepository methodsFor: 'accessing' stamp: 'ab 8/20/2003 21:04'! allVersionInfos ^ dict values collect: [:ea | ea info]! ! !MCDictionaryRepository methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:02'! initialize super initialize. dict := Dictionary new. ! ! !MCDictionaryRepository methodsFor: 'accessing' stamp: 'ab 7/26/2003 02:47'! dictionary ^ dict! ! !MCDictionaryRepository methodsFor: 'comparing' stamp: 'ab 8/21/2003 12:56'! = other ^ self == other! ! !MCDictionaryRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! description: aString description := aString ! ! !MCDictionaryRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! dictionary: aDictionary dict := aDictionary! ! !MCDictionaryRepository methodsFor: 'storing' stamp: 'avi 8/26/2004 14:20'! basicStoreVersion: aVersion dict at: aVersion info put: aVersion! ! !MCDictionaryRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! sortedVersionInfos | sorter | sorter := MCVersionSorter new. self allVersionInfos do: [:ea | sorter addVersionInfo: ea]. ^ sorter sortedVersionInfos ! ! !MCDictionaryRepository methodsFor: 'interface' stamp: 'ab 7/21/2003 23:39'! includesVersionNamed: aString ^ dict anySatisfy: [:ea | ea info name = aString]! ! !MCDictionaryRepository methodsFor: '*gofer-core-accessing' stamp: 'TestRunner 12/13/2009 14:57'! goferVersionFrom: aVersionReference ^ self dictionary detect: [ :version | version info name = aVersionReference name ]! ! !MCDictionaryRepository methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! asRepositorySpecFor: aMetacelloMCProject | desc | desc := self description. desc ifNil: [ desc := 'dictionary://Metacello_Dictionary' ]. ^(aMetacelloMCProject repositorySpec) description: desc; type: 'dictionary'; yourself! ! !MCDictionaryRepository methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! versionInfoFromVersionNamed: aString | versions | versions := self dictionary values select: [:version | version info name beginsWith: aString ]. versions isEmpty ifTrue: [ ^ nil ]. versions := versions asSortedCollection: [ :a :b | ([ (a info name copyAfterLast: $.) asNumber ] on: Error do: [:ex | ex return: 0 ]) <= ([ (b info name copyAfterLast: $.) asNumber ] on: Error do: [:ex | ex return: 0 ]) ]. ^ versions last info! ! !MCDictionaryRepositoryTest methodsFor: 'utility' stamp: 'ab 7/19/2003 16:06'! deleteNode: aNode dict removeKey: aNode! ! !MCDictionaryRepositoryTest methodsFor: 'actions' stamp: 'ab 8/16/2003 17:53'! addVersion: aVersion dict at: aVersion info put: aVersion! ! !MCDictionaryRepositoryTest methodsFor: 'utility' stamp: 'stephaneducasse 2/4/2006 20:47'! dictionary ^ dict ifNil: [dict := Dictionary new]! ! !MCDictionaryRepositoryTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp repository := MCDictionaryRepository new dictionary: self dictionary! ! !MCDiffyVersion commentStamp: 'TorstenBergmann 2/6/2014 08:08'! A diffy version! !MCDiffyVersion methodsFor: 'accessing' stamp: 'avi 2/19/2004 22:03'! summary ^ '(Diff against ', self baseInfo name, ')', String cr, super summary! ! !MCDiffyVersion methodsFor: 'testing' stamp: 'bf 5/23/2005 15:42'! canOptimizeLoading "Answer wether I can provide a patch for the working copy without the usual diff pass" ^ package hasWorkingCopy and: [package workingCopy modified not and: [package workingCopy ancestors includes: self baseInfo]]! ! !MCDiffyVersion methodsFor: 'accessing' stamp: 'bf 5/30/2005 17:39'! fileName ^ (self class nameForVer: info name base: base name), '.', self writerClass extension! ! !MCDiffyVersion methodsFor: 'accessing' stamp: 'avi 2/13/2004 23:17'! writerClass ^ MCMcdWriter ! ! !MCDiffyVersion methodsFor: 'operations' stamp: 'CamilloBrui 7/8/2011 12:28'! baseSnapshot | baseVersion | baseVersion := self workingCopy repositoryGroup versionWithInfo: base. baseVersion ifNil: [ self error: 'Missing snapshot: ', self baseInfo name]. ^ baseVersion snapshot! ! !MCDiffyVersion methodsFor: 'accessing' stamp: 'avi 2/13/2004 23:17'! baseInfo ^ base! ! !MCDiffyVersion methodsFor: 'accessing' stamp: 'avi 2/13/2004 23:17'! patch ^ patch! ! !MCDiffyVersion methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! snapshot ^ snapshot ifNil: [snapshot := MCPatcher apply: patch to: self baseSnapshot]! ! !MCDiffyVersion methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithPackage: aPackage info: aVersionInfo dependencies: aCollection baseInfo: baseVersionInfo patch: aPatch patch := aPatch. base := baseVersionInfo. super initializeWithPackage: aPackage info: aVersionInfo snapshot: nil dependencies: aCollection. ! ! !MCDiffyVersion methodsFor: 'testing' stamp: 'avi 2/13/2004 23:24'! isDiffy ^ true! ! !MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 17:39'! nameForVer: versionName base: baseName | baseId | baseId := (versionName copyUpToLast: $.) = (baseName copyUpToLast: $.) ifTrue: [baseName copyAfterLast: $.] ifFalse: [(versionName copyUpToLast: $-) = (baseName copyUpToLast: $-) ifTrue: [baseName copyAfterLast: $-] ifFalse: ['@', baseName]]. ^ versionName, '(', baseId, ')'! ! !MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 18:58'! canonicalNameFor: aFileName ^(self nameForVer: (self verNameFrom: aFileName) base: (self baseNameFrom: aFileName)) , '.', MCMcdReader extension ! ! !MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 18:19'! verNameFrom: diffName ^diffName copyUpTo: $(! ! !MCDiffyVersion class methodsFor: 'instance creation' stamp: 'avi 2/13/2004 23:06'! package: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection baseVersion: aVersion ^ self package: aPackage info: aVersionInfo dependencies: aCollection baseInfo: aVersion info patch: (aSnapshot patchRelativeToBase: aVersion snapshot)! ! !MCDiffyVersion class methodsFor: 'name utilities' stamp: 'bf 5/30/2005 18:45'! baseNameFrom: diffName | baseId verName | baseId := (diffName copyAfter: $() copyUpTo: $). baseId ifEmpty: [^baseId]. (baseId beginsWith: '@') ifTrue: [^baseId copyAfter: $@]. verName := self verNameFrom: diffName. ^(baseId includes: $.) ifTrue: [(verName copyUpToLast: $-), '-', baseId] ifFalse: [(verName copyUpToLast: $.), '.', baseId] ! ! !MCDiffyVersion class methodsFor: 'instance creation' stamp: 'avi 2/13/2004 23:07'! package: aPackage info: aVersionInfo dependencies: aCollection baseInfo: baseVersionInfo patch: aPatch ^ self basicNew initializeWithPackage: aPackage info: aVersionInfo dependencies: aCollection baseInfo: baseVersionInfo patch: aPatch! ! !MCDirectoryRepository commentStamp: 'TorstenBergmann 2/5/2014 13:55'! A metacello repository in a directory ! !MCDirectoryRepository methodsFor: 'comparing' stamp: 'CamilloBruni 5/24/2012 09:36'! hash ^ directory hash! ! !MCDirectoryRepository methodsFor: 'accessing' stamp: 'CamilloBruni 5/4/2012 19:04'! description ^ directory fullName! ! !MCDirectoryRepository methodsFor: 'testing' stamp: 'SeanDeNigris 6/18/2012 15:58'! includesFileNamed: aString "HACK: speed up the cache hits" ^ (directory / aString) exists.! ! !MCDirectoryRepository methodsFor: '*Komitter-Models' stamp: 'SeanDeNigris 2/9/2014 00:12'! koRemote ^ KomitDirectoryRemote new remote: self; yourself! ! !MCDirectoryRepository methodsFor: 'i/o' stamp: 'StephaneDucasse 6/17/2013 14:11'! writeStreamForFileNamed: aString replace: shouldReplace do: aBlock | file | file := directory / aString. shouldReplace ifTrue: [ file ensureDelete ]. file writeStreamDo: [ :stream | aBlock value: stream ].! ! !MCDirectoryRepository methodsFor: 'accessing' stamp: 'ab 7/6/2003 17:49'! directory ^ directory! ! !MCDirectoryRepository methodsFor: '*MonticelloGUI' stamp: 'GuillermoPolito 5/3/2013 12:06'! openAndEditTemplateCopy ^self class morphicConfigure! ! !MCDirectoryRepository methodsFor: '*gofer-core-accessing' stamp: 'lr 12/11/2009 22:32'! goferPriority ^ 5! ! !MCDirectoryRepository methodsFor: 'accessing' stamp: 'CamilloBruni 2/28/2012 20:08'! allFileNamesForVersionNamed: aString "avoid slow default implementation and directly check for existing files" |extensions| extensions := MCReader concreteSubclasses collect: [ :class| class extension ]. ^ extensions collect: [ :extension| aString , '.', extension ] thenSelect: [ :fileName| self includesFileNamed: fileName ]! ! !MCDirectoryRepository methodsFor: 'initialization' stamp: 'CamilloBruni 5/4/2012 21:35'! initialize super initialize. directory := FileSystem workingDirectory! ! !MCDirectoryRepository methodsFor: 'interface' stamp: 'StephaneDucasse 6/17/2012 18:51'! loadAllFileNames ^ (directory entries sort: [:a :b | a modificationTime >= b modificationTime]) collect: [:ea | ea basename]! ! !MCDirectoryRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! directory: aDirectory directory := aDirectory! ! !MCDirectoryRepository methodsFor: 'testing' stamp: 'CamilloBruni 2/28/2012 20:08'! includesVersionNamed: aString "avoid slow default implementation and directly check for existing files" ^ (self allFileNamesForVersionNamed: aString) isEmpty not! ! !MCDirectoryRepository methodsFor: 'testing' stamp: 'nk 11/2/2003 10:55'! isValid ^directory exists! ! !MCDirectoryRepository methodsFor: 'i/o' stamp: 'SeanDeNigris 6/29/2012 15:49'! readStreamForFileNamed: aString do: aBlock | val | directory / aString readStreamDo: [ :stream| val := aBlock value: stream ]. ^ val! ! !MCDirectoryRepository methodsFor: '*metacello-mc' stamp: 'dkh 02/25/2013 16:13'! asRepositorySpecFor: aMetacelloMCProject "" ^ directory asRepositorySpecFor: aMetacelloMCProject! ! !MCDirectoryRepository class methodsFor: 'accessing' stamp: 'ab 7/24/2003 21:20'! description ^ 'directory'! ! !MCDirectoryRepository class methodsFor: 'accessing' stamp: 'SeanDeNigris 4/21/2010 14:38'! defaultDirectoryName: aDirectoryName DefaultDirectoryName := aDirectoryName.! ! !MCDirectoryRepository class methodsFor: 'instance creation' stamp: 'SeanDeNigris 7/12/2012 08:45'! morphicConfigure ^ (UIManager default chooseDirectoryFrom: self defaultDirectoryName asFileReference) ifNotNil: [:directory | self new directory: directory]! ! !MCDirectoryRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 5/4/2012 21:35'! defaultDirectoryName ^ DefaultDirectoryName ifNil: [ DefaultDirectoryName := FileSystem workingDirectory fullName].! ! !MCDirectoryRepositoryTest methodsFor: 'actions' stamp: 'GuillermoPolito 7/3/2012 10:25'! addVersion: aVersion | file | file := (directory / aVersion fileName) asFileReference writeStream. aVersion fileOutOn: file. file close.! ! !MCDirectoryRepositoryTest methodsFor: 'accessing' stamp: 'S 6/17/2013 13:26'! directory directory ifNil: [directory := 'mctest' asFileReference. directory ensureCreateDirectory]. ^ directory! ! !MCDirectoryRepositoryTest methodsFor: 'running' stamp: 'CamilloBruni 7/6/2012 16:08'! tearDown self directory deleteAll. ! ! !MCDirectoryRepositoryTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp repository := MCDirectoryRepository new directory: self directory! ! !MCDirtyPackageInfo commentStamp: 'TorstenBergmann 2/5/2014 13:49'! A mock for dirty package info used for testing purposes! !MCDirtyPackageInfo methodsFor: 'accessing' stamp: 'GuillermoPolito 7/6/2012 11:06'! methods ^ (Smalltalk at: #MCMockClassA) selectors select: [:ea | ea beginsWith: 'ordinal'] thenCollect: [:ea | RGMethodDefinition realClass: (Smalltalk at: #MCMockClassA) selector: ea ]! ! !MCDirtyPackageInfo methodsFor: 'accessing' stamp: 'ab 7/7/2003 23:21'! packageName ^ 'MCDirtyPackage'! ! !MCDirtyPackageInfo methodsFor: 'accessing' stamp: 'ab 7/7/2003 23:21'! classes ^ Array new: 0.! ! !MCDirtyPackageInfo class methodsFor: 'initialization' stamp: 'avi 2/22/2004 14:04'! initialize [self new register] on: MessageNotUnderstood do: []! ! !MCDirtyPackageInfo class methodsFor: 'compiling' stamp: 'cwp 7/21/2003 19:45'! wantsChangeSetLogging ^ false! ! !MCDoItParser commentStamp: ''! A MCDoItParser is a simple 'parser' which understand the addDefinitionsTo: message. Each parser can use the source and add definitions to the list of entities that is passed to them. MCDoitParser invokes automatically its subclasses to parse the correct source. Each Doit entities (entities which are defined as doits) extend this entry point to add specific behavior.! !MCDoItParser methodsFor: 'accessing' stamp: 'avi 3/10/2004 12:40'! source ^ source! ! !MCDoItParser methodsFor: 'actions' stamp: 'avi 3/10/2004 12:40'! addDefinitionsTo: aCollection self subclassResponsibility ! ! !MCDoItParser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! source: aString source := aString! ! !MCDoItParser class methodsFor: 'factory identification hook' stamp: 'StephaneDucasse 12/30/2012 18:01'! pattern "return a pattern matching expression to identify the parser corresponding to the expression. Subclasses should specialize it." ^ nil! ! !MCDoItParser class methodsFor: 'instance creation' stamp: 'marcus.denker 11/10/2008 10:04'! forDoit: aString ^ (self subclassForDoit: aString) ifNotNil: [:c | c new source: aString]! ! !MCDoItParser class methodsFor: 'testing' stamp: 'avi 3/10/2004 12:51'! isAbstract ^ self pattern isNil! ! !MCDoItParser class methodsFor: 'instance creation' stamp: 'avi 3/10/2004 12:30'! subclassForDoit: aString ^ self concreteSubclasses detect: [:ea | ea pattern match: aString] ifNone: []! ! !MCDoItParser class methodsFor: 'private' stamp: 'avi 3/10/2004 12:29'! concreteSubclasses ^ self allSubclasses reject: [:c | c isAbstract]! ! !MCEmptyPackageInfo commentStamp: 'TorstenBergmann 2/5/2014 13:49'! A mock for empty package info used for testing purposes! !MCEmptyPackageInfo methodsFor: 'accessing' stamp: 'ab 7/7/2003 23:21'! methods ^ #()! ! !MCEmptyPackageInfo methodsFor: 'accessing' stamp: 'ab 7/7/2003 23:21'! packageName ^ 'MCEmptyPackage'! ! !MCEmptyPackageInfo methodsFor: 'accessing' stamp: 'ab 7/7/2003 23:21'! classes ^ #()! ! !MCEmptyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 14:04'! initialize [self new register] on: MessageNotUnderstood do: []! ! !MCEmptyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:45'! wantsChangeSetLogging ^ false! ! !MCFileBasedRepository commentStamp: 'TorstenBergmann 2/5/2014 13:55'! A file based metacello repository! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! cache ^ cache ifNil: [cache := Dictionary new]! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'ab 8/21/2003 20:01'! allFileNamesForVersionNamed: aString ^ self filterFileNames: self readableFileNames forVersionNamed: aString! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'avi 9/17/2005 18:37'! versionInfoFromFileNamed: aString self cache at: aString ifPresent: [:v | ^ v info]. ^ self loadVersionInfoFromFileNamed: aString! ! !MCFileBasedRepository methodsFor: 'interface' stamp: 'CamilloBruni 3/2/2012 13:03'! loadAllFileNames self subclassResponsibility! ! !MCFileBasedRepository methodsFor: 'adding' stamp: 'ChristopheDemarey 8/22/2013 15:26'! addVersionInformationExtractedFrom: readableFileName to: versions | name | name := (readableFileName copyUpToLast: $.) copyUpTo: $(. name last isDigit ifTrue: [ versions add: {(name copyUpToLast: $-). "pkg name" ((name copyAfterLast: $-) copyUpTo: $.). "user" (((name copyAfterLast: $-) copyAfter: $.) asInteger ifNil: [ 0 ]). "version" readableFileName }]! ! !MCFileBasedRepository methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! canReadFileNamed: aString | reader | reader := MCVersionReader readerClassForFileNamed: aString. ^ reader notNil! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'CamilloBruni 11/6/2013 21:55'! allFileNamesOrCache cacheFileNames == true ifFalse: [ ^ self allFileNames ]. ^ allFileNames ifNil: [ allFileNames := self allFileNames]! ! !MCFileBasedRepository methodsFor: 'storing' stamp: 'stephaneducasse 2/4/2006 20:47'! basicStoreVersion: aVersion self writeStreamForFileNamed: aVersion fileName do: [:s | aVersion fileOutOn: s]. aVersion isCacheable ifTrue: [ cache ifNil: [cache := Dictionary new]. cache at: aVersion fileName put: aVersion]. ! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'bf 5/30/2005 22:52'! versionNameFromFileName: aString ^ (aString copyUpToLast: $.) copyUpTo: $(! ! !MCFileBasedRepository methodsFor: 'storing' stamp: 'avi 10/31/2003 14:32'! writeStreamForFileNamed: aString do: aBlock ^ self writeStreamForFileNamed: aString replace: false do: aBlock! ! !MCFileBasedRepository methodsFor: 'testing' stamp: 'ab 8/21/2003 00:36'! includesVersionNamed: aString ^ self allVersionNames includes: aString! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'ab 8/21/2003 00:40'! allVersionNames ^ self readableFileNames collect: [:ea | self versionNameFromFileName: ea]! ! !MCFileBasedRepository methodsFor: 'notifying' stamp: 'CamilloBruni 1/26/2012 19:50'! notifyList (self includesFileNamed: 'notify') ifFalse: [^ #()]. ^ self readStreamForFileNamed: 'notify' do: [:s | s upToEnd lines]! ! !MCFileBasedRepository methodsFor: 'private' stamp: 'SeanDeNigris 7/17/2012 15:50'! loadVersionFromFileNamed: aString (MCCacheRepository uniqueInstance includesFileNamed: aString) ifTrue: [ ^ MCCacheRepository uniqueInstance loadVersionFromFileNamed: aString]. ^ self versionReaderForFileNamed: aString do: [:r | r version]! ! !MCFileBasedRepository methodsFor: 'caching' stamp: 'bf 6/9/2005 15:47'! cachedFileNames ^cache == nil ifTrue: [#()] ifFalse: [cache keys]! ! !MCFileBasedRepository methodsFor: 'caching' stamp: 'CamilloBruni 4/20/2012 18:14'! maxCacheSize ^ 512! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'avi 9/17/2005 16:40'! closestAncestorVersionFor: anAncestry ifNone: errorBlock ^ self cacheAllFileNamesDuring: [super closestAncestorVersionFor: anAncestry ifNone: errorBlock]! ! !MCFileBasedRepository methodsFor: 'loading' stamp: 'avi 9/17/2005 18:37'! loadVersionInfoFromFileNamed: aString ^ self versionReaderForFileNamed: aString do: [:r | r info] ! ! !MCFileBasedRepository methodsFor: 'testing' stamp: 'CamilloBruni 1/26/2012 19:49'! includesFileNamed: aString "slow default implementation" ^ self allFileNames includes: aString! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'StephaneDucasse 1/24/2013 12:06'! readableFileNames | all cached new emptyFilenamelength | ".-..mcz" emptyFilenamelength := 'P-i.c.mcz' size. all := self allFileNames. "from repository" all := all reject: [ :each | each size < emptyFilenamelength]. "first stupid way to filter first level broken files. Ideally we should remove any files not following the naming pattern: PackageName-author.number[(branch)].mcz" cached := self cachedFileNames. "in memory" new := all difference: cached. ^ (cached asArray, new) select: [:ea | self canReadFileNamed: ea]! ! !MCFileBasedRepository methodsFor: '*MonticelloGUI' stamp: 'avi 2/28/2004 18:32'! morphicOpen: aWorkingCopy (MCFileRepositoryInspector repository: self workingCopy: aWorkingCopy) show! ! !MCFileBasedRepository methodsFor: 'interface' stamp: 'SeanDeNigris 7/17/2012 15:40'! versionWithInfo: aVersionInfo ifAbsent: errorBlock "get a version for the given versionInfo. always query first the packageCache and only then try to load the version from the remote location" ^ MCCacheRepository uniqueInstance versionWithInfo: aVersionInfo ifAbsent: [ (self allFileNamesForVersionNamed: aVersionInfo name) do: [:fileName | | version | version := self versionFromFileNamed: fileName. version info = aVersionInfo ifTrue: [^ version]]. ^ errorBlock value].! ! !MCFileBasedRepository methodsFor: 'caching' stamp: 'CamilloBruni 3/2/2012 13:01'! cacheAllFileNamesDuring: aBlock cacheFileNames == true ifTrue: [ ^ aBlock value ]. allFileNames := nil. cacheFileNames := true. ^ aBlock ensure: [ allFileNames := nil. cacheFileNames := false]! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'bf 3/11/2005 18:01'! possiblyNewerVersionsOfAnyOf: someVersions | pkgs | pkgs := Dictionary new. someVersions do: [:aVersionInfo | pkgs at: (aVersionInfo name copyUpToLast: $-) put: (aVersionInfo name copyAfterLast: $.) asNumber]. ^[self allVersionNames select: [:each | (pkgs at: (each copyUpToLast: $-) ifPresent: [:verNumber | verNumber < (each copyAfterLast: $.) asNumber or: [verNumber = (each copyAfterLast: $.) asNumber and: [someVersions noneSatisfy: [:v | v name = each]]]]) == true] ] on: Error do: [:ex | ex return: #()]! ! !MCFileBasedRepository methodsFor: 'caching' stamp: 'avi 9/18/2005 22:43'! resizeCache: aDictionary [aDictionary size <= self maxCacheSize] whileFalse: [aDictionary removeKey: aDictionary keys atRandom]! ! !MCFileBasedRepository methodsFor: '*monticellofiletree-core' stamp: 'dkh 4/5/2012 11:15:15'! packageDescriptionsFromReadableFileNames ^ self readableFileNames collect: [ :each | | name | name := (each copyUpToLast: $.) copyUpTo: $(. name last isDigit ifFalse: [ {name. ''. ''. each} ] ifTrue: [ | packageName author versionNumber | packageName := name copyUpToLast: $-. author := (name copyAfterLast: $-) copyUpTo: $.. versionNumber := ((name copyAfterLast: $-) copyAfter: $.) asInteger ifNil: [ 0 ]. {packageName. author. versionNumber. each} ] ]! ! !MCFileBasedRepository methodsFor: '*Versionner-Spec-Browser' stamp: 'ChristopheDemarey 1/8/2014 14:42'! location ^ self description! ! !MCFileBasedRepository methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! versionReaderForFileNamed: aString do: aBlock ^ self readStreamForFileNamed: aString do: [:s | (MCVersionReader readerClassForFileNamed: aString) ifNotNil: [:class | aBlock value: (class on: s fileName: aString)]] ! ! !MCFileBasedRepository methodsFor: '*gofer-core-accessing' stamp: 'SeanDeNigris 8/29/2012 09:38'! goferReferences | versionNames | versionNames := [ self allVersionNames ] on: MCRepositoryError do: [ :error | ^ GoferRepositoryError signal: error messageText repository: self ]. ^ versionNames collect: [ :each | GoferResolvedReference name: each repository: self ]! ! !MCFileBasedRepository methodsFor: '*monticellofiletree-core' stamp: 'dkh 4/5/2012 11:15:15'! retrieveVersionsWithPackageNames: packageNames | packageDescriptions | packageDescriptions := self packageDescriptionsFromReadableFileNames. packageNames addAll: (packageDescriptions collect: [ :packageDescription | packageDescription first ]). ^ packageDescriptions select: [ :each | (each at: 3) isNumber ]! ! !MCFileBasedRepository methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! versionInfoFromVersionNamed: aString | versions | versions := self allVersionNames select: [ :each | each beginsWith: aString ]. versions isEmpty ifTrue: [ ^ nil ]. versions := versions asSortedCollection: [ :a :b | ([ (a copyAfterLast: $.) asNumber ] on: Error do: [:ex | ex return: 0 ]) <= ([ (b copyAfterLast: $.) asNumber ] on: Error do: [:ex | ex return: 0 ]) ]. ^ self versionInfoFromFileNamed: versions last , '.mcz' ! ! !MCFileBasedRepository methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! flushCache cache := nil! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'ChristopheDemarey 8/22/2013 15:24'! versionsWithPackageNames | versions | versions := OrderedCollection new. self readableFileNames do: [ :each | self addVersionInformationExtractedFrom: each to: versions ]. ^ versions! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'ab 8/21/2003 20:01'! filterFileNames: aCollection forVersionNamed: aString ^ aCollection select: [:ea | (self versionNameFromFileName: ea) = aString] ! ! !MCFileBasedRepository methodsFor: '*gofer-core-accessing' stamp: 'lr 12/12/2009 11:29'! goferVersionFrom: aVersionReference ^ self loadVersionFromFileNamed: aVersionReference name , '.mcz'! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'CamilloBruni 4/20/2012 17:57'! allFileNames cacheFileNames == true ifFalse: [ ^ self loadAllFileNames ]. ^ allFileNames ifNil: [ allFileNames := self loadAllFileNames]! ! !MCFileBasedRepository methodsFor: 'accessing' stamp: 'CamilloBruni 4/21/2012 18:01'! versionFromFileNamed: aString | v | v := self cache at: aString ifAbsent: [ self loadVersionFromFileNamed: aString ]. self resizeCache: cache. (v notNil and: [v isCacheable]) ifTrue: [cache at: aString put: v]. ^ v! ! !MCFileBasedRepository class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:33'! cleanUp "Flush caches" self flushAllCaches.! ! !MCFileBasedRepository class methodsFor: 'actions' stamp: 'avi 2/3/2005 00:43'! flushAllCaches self allSubInstancesDo: [:ea | ea flushCache]! ! !MCFileInTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:08'! alterInitialState self mockClassA touchCVar! ! !MCFileInTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! assertInitializersCalled | cvar | cvar := self mockClassA cVar. self assert: cvar = #initialized! ! !MCFileInTest methodsFor: 'testing' stamp: 'pavel.krivanek 10/14/2010 15:41'! assertSuccessfulLoadWith: aBlock stream reset. aBlock value. self assertNoChange. self assertInitializersCalled. self assertInitializersOrder! ! !MCFileInTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 6/17/2012 12:37'! tearDown (diff isNil or: [diff isEmpty not]) ifTrue: [expected updatePackage: self mockPackage]. MCDataStream initialize! ! !MCFileInTest methodsFor: 'testing' stamp: 'avi 2/17/2004 03:21'! assertFileOutFrom: writerClass canBeFiledInWith: aBlock (writerClass on: stream) writeSnapshot: self mockSnapshot. self alterInitialState. self assertSuccessfulLoadWith: aBlock. self mockPackage unload. self assertSuccessfulLoadWith: aBlock. ! ! !MCFileInTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! assertNoChange | actual | actual := MCSnapshotResource takeSnapshot. diff := actual patchRelativeToBase: expected. self assert: diff isEmpty! ! !MCFileInTest methodsFor: 'testing' stamp: 'GuillermoPolito 8/24/2012 15:06'! testStWriter "self debug: #testStWriter" self assertFileOutFrom: MCStWriter canBeFiledInWith: [ CodeImporter evaluateReadStream: stream readStream]. ! ! !MCFileInTest methodsFor: 'testing' stamp: 'pavel.krivanek 10/14/2010 15:40'! assertInitializersOrder | initializationOrder | initializationOrder := self mockClassA initializationOrder. self assert: initializationOrder = 2. ! ! !MCFileInTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp expected := self mockSnapshot. stream := RWBinaryOrTextStream on: String new.! ! !MCFileRepositoryInspector commentStamp: 'LaurentLaffont 2/5/2011 17:35'! I'm a monticello tool composed of three panes to browse repositories and the packages they contain. You get an instance of me when you click on a repository in Monticello browser and press open. My left pane presents the packages, my right one their versions and the bottom one the commit log of the selected package versions. I underline the packages you already loaded, and highlight the ones you don't have updated to the last version. I also highlight the versions you did not load yet. Example: I can browse packages of PharoInbox with: (MCFileRepositoryInspector repository: (MCHttpRepository location: 'http://www.squeaksource.com/PharoInbox' user: '' password: '') workingCopy: nil) show. COTDC - S.Ducasse, G.Polito, L.Laffont! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:18'! versionSelection ^self versionList indexOf: selectedVersion! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! versionInfo ^ versionInfo ifNil: [versionInfo := repository versionInfoFromFileNamed: selectedVersion]! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/30/2009 09:01'! packageSelection: aNumber selectedPackage := aNumber isZero ifFalse: [ (self packageList at: aNumber) asString ]. self versionSelection: 0. self changed: #packageSelection; changed: #versionList! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'Lr 12/9/2010 17:25'! defaultExtent ^ 640 @ 480! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:17'! packageSelection ^self packageList indexOf: selectedPackage! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'BenComan 4/7/2014 23:19'! packageSearchAccept: string | aString | aString := string ifNil: [ '' ]. packagePattern = aString asLowercase ifTrue: [ ^ self ]. packagePattern := aString asLowercase. self packageListUpdate.! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'BenjaminVanRyseghem 12/6/2013 13:17'! versionSearchAccept: string | aString | aString := string ifNil: [ '' ]. versionPattern = aString asLowercase ifTrue: [ ^ self ]. versionPattern := aString asLowercase. versionProcess ifNotNil: [ versionProcess terminate ]. versionProcess := [ self changed: #versionList ] fork.! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 17:25'! packageListMenu: aMenu ^aMenu! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'CamilloBruni 3/13/2012 18:42'! packageSearchField ^ SearchMorph new model: self; setIndexSelector: #packageSearchAccept:; updateSelector: #packageSearchAccept:; searchList: self class packageSearchList; yourself! ! !MCFileRepositoryInspector methodsFor: 'actions' stamp: 'StephaneDucasse 1/23/2013 21:55'! computeLoadedAndInheritedFromManager: each each ancestors do: [ :ancestor | loaded add: ancestor name. ancestor ancestorsDoWhileTrue: [ :heir | (inherited includes: heir name) ifTrue: [ false ] ifFalse: [ inherited add: heir name. true ] ] ]! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 9/17/2005 17:21'! hasVersion ^ selectedVersion notNil! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! versionSelection: aNumber aNumber isZero ifTrue: [ selectedVersion := version := versionInfo := nil ] ifFalse: [ selectedVersion := (self versionList at: aNumber) asString. version := versionInfo := nil]. self changed: #versionSelection; changed: #summary; changed: #hasVersion! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'BenComan 4/7/2014 22:47'! packageHighlight: aString loadedPackages: loadedPackages newer ifNil: [newer := #()]. ^(loadedPackages anySatisfy: [:each | each = aString]) ifTrue: [ Text string: aString attribute: (TextEmphasis new emphasisCode: ( ((newer includes: aString) ifTrue: [5] ifFalse: [4])))] ifFalse: [aString]! ! !MCFileRepositoryInspector methodsFor: 'initialization' stamp: 'BenComan 4/7/2014 23:18'! initialize super initialize. loaded := Set new. versionPattern := ''. packagePattern := ''. packageList := #().! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'CamilloBruni 6/8/2010 23:40'! buttonSpecs ^#(('Refresh' refresh 'refresh the version-list') (Save saveChanges 'Save the local changes')) , super buttonSpecs! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'BenComan 4/7/2014 23:14'! packageListUpdate | result loadedPackages newPackageList | "Within fork, make no changes to object state until end with assignment wrapped by #defer:" packageListUpdateProcess ifNotNil: [ packageListUpdateProcess terminate ]. packageListUpdateProcess := [ versions ifNotNil: [ result := Set new: versions size. versions do: [ :each | result add: each first ]. "sort loaded packages first, then alphabetically" loadedPackages := Set new: loaded size. loaded do: [ :each | loadedPackages add: (each copyUpToLast: $-). ]. result := result asArray sort: [ :a :b | | loadedA loadedB | loadedA := loadedPackages includes: a. loadedB := loadedPackages includes: b. loadedA = loadedB ifTrue: [ a < b ] ifFalse: [ loadedA ] ]. packagePattern ifNotEmpty: [ result := result select: [ :package| package name asLowercase includesSubstring: packagePattern ]]. newPackageList := result collect: [ :each | self packageHighlight: each loadedPackages: loadedPackages ]. UIManager default defer: [ packageList := newPackageList. self changed: #packageList ] ] ] fork.! ! !MCFileRepositoryInspector methodsFor: 'actions' stamp: 'avi 9/18/2005 10:54'! load self hasVersion ifTrue: [self version isCacheable ifTrue: [version workingCopy repositoryGroup addRepository: repository]. super load. self refresh].! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'bf 5/30/2005 19:10'! versionHighlight: aString | verName | inherited ifNil: [inherited := #()]. verName := (aString copyUpToLast: $.) copyUpTo: $(. ^Text string: aString attribute: (TextEmphasis new emphasisCode: ( ((loaded includes: verName) ifTrue: [ 4 "underlined" ] ifFalse: [ (inherited includes: verName) ifTrue: [ 0 ] ifFalse: [ 1 "bold" ] ])))! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'CamilloBruni 3/13/2012 18:50'! widgetSpecs | searchBarOffset | searchBarOffset := 30 + StandardFonts defaultFont height + 10.. ^{ {{#buttonRow}. {0. 0. 1. 0}. {0. 0. 0. 30}}. {{#packageSearchField}. {0. 0. 0.5. 0}. {0. 30. 0. searchBarOffset}}. {{#listMorph:. #package}. {0. 0. 0.5. 0.6}. {0. searchBarOffset+3. 0. 0}}. {{#versionSearchField}. {0.5. 0. 1. 0}. {0. 30. 0. searchBarOffset}}. {{#listMorph:. #version}. {0.5. 0. 1. 0.6}. {0. searchBarOffset+3. 0. 0.}}. {{#textMorph:. #summary}. {0. 0.6. 1. 1}. {0. 0. 0. 0.}}}! ! !MCFileRepositoryInspector methodsFor: 'actions' stamp: 'bf 11/16/2004 11:56'! merge super merge. self refresh. ! ! !MCFileRepositoryInspector methodsFor: 'accessing' stamp: 'BenComan 4/7/2014 23:18'! packageList ^ packageList ! ! !MCFileRepositoryInspector methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/5/2013 18:17'! setRepository: aFileBasedRepository workingCopy: aWorkingCopy order := self class order. repository := aFileBasedRepository. aWorkingCopy ifNil: [ selectedPackage := self packageList isEmpty ifFalse: [self packageList first asString]] ifNotNil: [ selectedPackage := aWorkingCopy ancestry ancestorString copyUpToLast: $-. selectedPackage ifEmpty: [ selectedPackage := aWorkingCopy package name ]]. [ self refresh. MCWorkingCopy addDependent: self.] fork. ! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'tbn 7/6/2010 17:06'! orderSpecs ^{ 'Unchanged' -> nil. 'Order by package' -> [ :x :y | x first <= y first ]. 'Order by author' -> [ :x :y | x second <= y second ]. 'Order by version-string' -> [ :x :y | x third <= y third ]. 'Order by version-number' -> [ :x :y | x third asNumber >= y third asNumber ]. 'Order by filename' -> [ :x :y | x fourth <= y fourth ]. }! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! version ^ version ifNil: [Cursor wait showWhile: [version := repository versionFromFileNamed: selectedVersion]. version]! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'EstebanLorenzano 9/8/2013 11:00'! saveChanges | currentRepository workingCopy | currentRepository := repository. "This can be changed elsewhere while processing" workingCopy := MCWorkingCopy forPackage: (MCPackage new name: selectedPackage). (workingCopy newVersionIn: currentRepository) ifNotNil: [:v | (MCVersionInspector new version: v) show. Cursor wait showWhile: [currentRepository storeVersion: v]. MCCacheRepository uniqueInstance cacheAllFileNamesDuring: [currentRepository cacheAllFileNamesDuring: [v allAvailableDependenciesDo: [:dep | (currentRepository includesVersionNamed: dep info name) ifFalse: [currentRepository storeVersion: dep]]]]]! ! !MCFileRepositoryInspector methodsFor: '*monticellofiletree-core' stamp: 'BenComan 4/7/2014 22:32'! refresh | packageNames | packageNames := Set new. versions := repository retrieveVersionsWithPackageNames: packageNames. newer := Set new. inherited := Set new. loaded := Set new. MCWorkingCopy allManagers do: [ :each | | latest | each ancestors do: [ :ancestor | loaded add: ancestor name. ancestor ancestorsDoWhileTrue: [ :heir | (inherited includes: heir name) ifTrue: [ false ] ifFalse: [ inherited add: heir name. true ] ] ]. latest := (versions select: [ :v | v first = each package name ]) detectMax: [ :v | v third ]. (latest notNil and: [ each ancestors allSatisfy: [ :ancestor | | av | av := ((ancestor name copyAfterLast: $-) copyAfter: $.) asInteger. av < latest third or: [ av = latest third and: [ ((ancestor name copyAfterLast: $-) copyUpTo: $.) ~= latest second ] ] ] ]) ifTrue: [ newer add: each package name ] ]. " select: [ :each | packageNames includes: each packageName]" self packageListUpdate; changed: #versionList! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! order: anInteger self class order: (order := anInteger). self changed: #versionList.! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:06'! defaultLabel ^'Repository: ' , repository description! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'CamilloBruni 3/13/2012 18:41'! versionSearchField ^ SearchMorph new model: self; setIndexSelector: #versionSearchAccept:; updateSelector: #versionSearchAccept:; searchList: self class versionSearchList; yourself! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 21:07'! versionListMenu: aMenu 1 to: self orderSpecs size do: [ :index | aMenu addUpdating: #orderString: target: self selector: #order: argumentList: { index } ]. ^aMenu! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'BenjaminVanRyseghem 12/5/2013 16:24'! versionList | result sortBlock | result := selectedPackage ifNil: [ versions ifNil: [ ^ #() ]] ifNotNil: [ (versions ifNil: [ ^ #() ]) select: [ :each | selectedPackage = each first ] ]. sortBlock := (self orderSpecs at: order) value. sortBlock ifNotNil: [ result := result asSortedCollection: [:a :b | [sortBlock value: a value: b] on: Error do: [true]]]. versionPattern ifNotEmpty: [ result := result select: [ :package| package fourth asLowercase includesSubstring: versionPattern ]]. ^ result collect: [ :each | self versionHighlight: each fourth ]! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 21:07'! orderString: anIndex ^String streamContents: [ :stream | order = anIndex ifTrue: [ stream nextPutAll: '' ] ifFalse: [ stream nextPutAll: '' ]. stream nextPutAll: (self orderSpecs at: anIndex) key ]! ! !MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/4/2011 14:24'! versionSearchList ^ versionSearchList ifNil: [ versionSearchList := OrderedCollection new]. ! ! !MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'ClementBera 7/26/2013 16:18'! order ^ Order ifNil: [ Order := 5 ]! ! !MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! order: anInteger Order := anInteger! ! !MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/4/2011 14:24'! packageSearchList ^ packageSearchList ifNil: [ packageSearchList := OrderedCollection new]. ! ! !MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 4/24/2012 14:52'! repository: aFileBasedRepository workingCopy: aWorkingCopy ^self new setRepository: aFileBasedRepository workingCopy: aWorkingCopy; yourself! ! !MCFileTreeAbstractReader commentStamp: 'TorstenBergmann 2/20/2014 15:54'! Abstract reader superclass for FileTree! !MCFileTreeAbstractReader methodsFor: 'accessing' stamp: 'dkh 2/16/2012 14:49:00'! basicVersion ^ (MCVersion new) setPackage: self package info: self info snapshot: self snapshot dependencies: self dependencies; yourself! ! !MCFileTreeAbstractReader methodsFor: 'testing' stamp: 'dkh 8/10/2012 05:44'! hasMonticelloMetadata ^ (self fileUtils directoryExists: (self fileUtils directoryFromPath: MCFileTreeStCypressWriter monticelloMetaDirName relativeTo: packageDirectory)) or: [ (self fileUtils filePathExists: 'version' relativeTo: packageDirectory) and: [ self fileUtils filePathExists: 'package' relativeTo: packageDirectory ] ]! ! !MCFileTreeAbstractReader methodsFor: 'testing' stamp: 'dkh 3/1/2012 10:11'! noMethodMetaData ^ self packageProperties at: 'noMethodMetaData' ifAbsent: [ false ]! ! !MCFileTreeAbstractReader methodsFor: 'accessing' stamp: 'dkh 4/4/2012 17:43'! monticelloMetaDirName ^ self class monticelloMetaDirName! ! !MCFileTreeAbstractReader methodsFor: 'utilities' stamp: 'dkh 8/10/2012 07:39'! definitionFromFile: directoryEntry inDirectory: aDirectory | defs reader | directoryEntry ifNil: [ ^ nil ]. self fileUtils readStreamFor: directoryEntry name in: aDirectory do: [ :fileStream | | methodDefinition | reader := MCStReader on: fileStream. (defs := reader definitions) size <= 1 ifFalse: [ self error: 'we should be writing exactly 1 definition per file' ] ]. defs size = 0 ifTrue: [ ^ nil ]. ^ defs first! ! !MCFileTreeAbstractReader methodsFor: 'utilities' stamp: 'dkh 8/10/2012 07:43'! parseMember: fileName | directory tokens | directory := self fileUtils directoryFromPath: self monticelloMetaDirName relativeTo: packageDirectory. self fileUtils readStreamFor: fileName in: directory do: [ :fileStream | tokens := self scanner scan: fileStream ]. ^ self associate: tokens! ! !MCFileTreeAbstractReader methodsFor: 'utilities' stamp: 'dkh 8/10/2012 07:18'! loadDependencies | dependencyDir directoryPath | directoryPath := self monticelloMetaDirName , self fileUtils pathNameDelimiter asString , 'dependencies'. dependencyDir := self fileUtils directoryFromPath: directoryPath relativeTo: packageDirectory. (self fileUtils directoryExists: dependencyDir) ifFalse: [ ^ dependencies := #() ]. dependencies := OrderedCollection new. dependencyDir entries do: [ :entry | dependencies add: (MCVersionDependency package: (MCPackage named: entry name) info: (self extractInfoFrom: (self parseMember: 'dependencies' , self fileUtils pathNameDelimiter asString , entry name))) ]. dependencies := dependencies asArray! ! !MCFileTreeAbstractReader methodsFor: 'accessing' stamp: 'dkh 3/1/2012 11:56'! packageProperties packageProperties ifNil: [ packageProperties := Dictionary new. (packageDirectory entries detect: [ :entry | entry name = '.filetree' ] ifNone: [ ]) ifNotNil: [ :configEntry | configEntry readStreamDo: [ :fileStream | | jsonObject structureVersion | [ (jsonObject := MCFileTreeJsonParser parseStream: fileStream) isFloat ifTrue: [ " 0.0 - original structure 0.1 - separate files for method metaData (timestamp) and source 0.2 - no method metaData file" packageProperties := Dictionary new. structureVersion := jsonObject printShowingDecimalPlaces: 1. packageProperties at: 'noMethodMetaData' put: structureVersion = '0.2'. packageProperties at: 'separateMethodMetaAndSource' put: structureVersion = '0.1' ] ifFalse: [ packageProperties := jsonObject. ((packageProperties at: 'noMethodMetaData' ifAbsent: [ false ]) and: [ packageProperties at: 'separateMethodMetaAndSource' ifAbsent: [ false ] ]) ifTrue: [ self error: 'noMethodMetaData and separateMethodMetaAndSource cannot both be true' ] ] ] on: Error do: [ :ex | Transcript cr; show: 'Error reading package properties (.filetree): ' , packageDirectory pathName , ' :: ' , ex description ] ] ] ]. ^ packageProperties! ! !MCFileTreeAbstractReader methodsFor: 'utilities' stamp: 'dkh 3/1/2012 12:09'! addClassAndMethodDefinitionsFromDirectory: aDirectory self subclassResponsibility! ! !MCFileTreeAbstractReader methodsFor: 'testing' stamp: 'dkh 3/1/2012 10:10'! separateMethodMetaAndSource ^ self packageProperties at: 'separateMethodMetaAndSource' ifAbsent: [ false ]! ! !MCFileTreeAbstractReader methodsFor: 'utilities' stamp: 'dkh 8/10/2012 14:00'! addClassAndMethodDefinitionsFromDirectoryEntries: entries | timestamp | self noMethodMetaData ifTrue: [ timestamp := self info author , ' ' , self info date mmddyyyy , ' ' , self info time print24 ]. entries do: [ :element | element isDirectory ifTrue: [ | directory | directory := self fileUtils directoryFromEntry: element. ((self separateMethodMetaAndSource or: [ self noMethodMetaData ]) ifTrue: [ directory entries select: [ :entry | entry name endsWith: '.st' ] ] ifFalse: [ directory entries ]) do: [ :file | | definition | (definition := self definitionFromFile: file inDirectory: directory) ifNotNil: [ definition isMethodDefinition ifTrue: [ self separateMethodMetaAndSource ifTrue: [ directory fileNamed: definition selector asString , '.meta' do: [ :fileStream | definition setTimeStamp: (Author fixStamp: fileStream contents) ] ]. self noMethodMetaData ifTrue: [ definition setTimeStamp: timestamp ] ]. definitions add: definition ] ] ] ]! ! !MCFileTreeAbstractReader methodsFor: 'utilities' stamp: 'dkh 3/1/2012 12:07'! loadDefinitions | entries | definitions := OrderedCollection new. entries := packageDirectory entries. self addDefinitionFromFile: (entries detect: [ :entry | entry name beginsWith: 'categories' ] ifNone: [ ]) inDirectory: packageDirectory; addClassAndMethodDefinitionsFromDirectory: packageDirectory; addDefinitionFromFile: (entries detect: [ :entry | entry name beginsWith: 'initializers' ] ifNone: [ ]) inDirectory: packageDirectory! ! !MCFileTreeAbstractReader methodsFor: 'accessing' stamp: 'dkh 8/10/2012 05:46'! packageDirectory: aDirectoryName packageDirectory := self fileUtils directoryFromPath: aDirectoryName relativeTo: stream! ! !MCFileTreeAbstractReader methodsFor: 'utilities' stamp: 'dkh 2/16/2012 14:49:00'! addDefinitionFromFile: directoryEntry inDirectory: aDirectory (self definitionFromFile: directoryEntry inDirectory: aDirectory) ifNotNil: [ :def | definitions add: def ]! ! !MCFileTreeAbstractReader methodsFor: 'accessing' stamp: 'dkh 8/10/2012 05:39'! fileUtils ^ MCFileTreeFileUtils current! ! !MCFileTreeAbstractReader class methodsFor: 'reading' stamp: 'dkh 2/16/2012 14:49:00'! on: s fileName: f ^ (self on: s) packageDirectory: f; yourself! ! !MCFileTreeAbstractReader class methodsFor: 'accessing' stamp: 'dkh 4/4/2012 17:43'! monticelloMetaDirName ^ '.'! ! !MCFileTreeAbstractStWriter commentStamp: 'TorstenBergmann 2/20/2014 15:56'! Abstract superclass for FileTree writers! !MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: 'dkh 4/5/2012 11:15:15'! visitClassDefinition: definition self subclassResponsibility! ! !MCFileTreeAbstractStWriter methodsFor: 'initialize-release' stamp: 'dkh 4/5/2012 11:15:15'! writeDefinitions: aCollection "the correct initialization order is unknown if some classes are missing in the image" self writeBasicDefinitions: aCollection! ! !MCFileTreeAbstractStWriter methodsFor: 'writing' stamp: 'topa 7/22/2013 13:26'! writeClassTraitDefinition: definition stWriter visitClassTraitDefinition: definition. ! ! !MCFileTreeAbstractStWriter methodsFor: 'private' stamp: 'dkh 4/5/2012 11:15:15'! directoryForDirectoryNamed: directoryNameOrPath ^ directoryNameOrPath = '.' ifTrue: [ stream packageFileDirectory ] ifFalse: [ stream subPackageFileDirectoryFor: directoryNameOrPath ]! ! !MCFileTreeAbstractStWriter methodsFor: 'private' stamp: 'dkh 4/5/2012 11:15:15'! monticelloMetaDirName ^ self class monticelloMetaDirName! ! !MCFileTreeAbstractStWriter methodsFor: 'private' stamp: 'dkh 07/07/2013 22:12'! repository ^ stream repository! ! !MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: 'dkh 4/5/2012 11:15:15'! visitMetaclassDefinition: definition "handled by class definition" ! ! !MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: 'dkh 4/5/2012 11:15:15'! visitMethodDefinition: definition self subclassResponsibility! ! !MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: 'dkh 4/5/2012 11:15:15'! visitOrganizationDefinition: defintion self writeInDirectoryName: self monticelloMetaDirName fileName: 'categories' extension: '.st' visit: [ defintion categories do: [ :cat | stWriter writeCategory: cat ] ]! ! !MCFileTreeAbstractStWriter methodsFor: 'initialize-release' stamp: 'dkh 4/5/2012 11:15:15'! writeInitializers self writeInDirectoryName: self monticelloMetaDirName fileName: 'initializers' extension: '.st' visit: [ stWriter writePresentInitializers; writeAbsentInitializers ]! ! !MCFileTreeAbstractStWriter methodsFor: 'initialize-release' stamp: 'dkh 4/5/2012 11:15:15'! writePropertiesFile self writeInDirectoryName: '.' fileName: '' extension: '.filetree' visit: [ stWriter writeProperties ]! ! !MCFileTreeAbstractStWriter methodsFor: 'initialize-release' stamp: 'topa 7/22/2013 00:13'! initialize stWriter := MCFileTreePackageStructureStWriter new initializers: (initializers := Set new); yourself. orderedClassNames := OrderedCollection new. orderedTraitNames := OrderedCollection new.! ! !MCFileTreeAbstractStWriter methodsFor: 'private' stamp: 'dkh 4/5/2012 11:15:15'! setFileStream: file stWriter stream: file! ! !MCFileTreeAbstractStWriter methodsFor: 'writing' stamp: 'dkh 4/5/2012 11:15:15'! writeMethodDefinition: definition stWriter visitMethodDefinition: definition! ! !MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: 'topa 7/22/2013 00:05'! visitTraitDefinition: definition self subclassResponsibility! ! !MCFileTreeAbstractStWriter methodsFor: 'writing' stamp: 'topa 7/22/2013 13:55'! writeClassDefinition: definition stWriter writeClassDefinition: definition. (definition hasClassInstanceVariables or: [definition hasClassTraitComposition]) ifTrue: [ stWriter writeMetaclassDefinition: definition ]. definition hasComment ifTrue: [ stWriter writeClassComment: definition ]! ! !MCFileTreeAbstractStWriter methodsFor: 'private' stamp: 'dkh 4/5/2012 11:15:15'! fileNameForSelector: selector ^ (selector == #'/' ifTrue: [ 'encoded slash' ] ifFalse: [ (selector includes: $/) ifTrue: [ 'encoded' , selector copyReplaceAll: '/' with: ' slash ' ] ifFalse: [ selector ] ]) asString! ! !MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: 'dkh 07/07/2013 19:32:57'! visitScriptDefinition: definition self flag: #'skippedForNow'! ! !MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: 'dkh 04/07/2012 10:32'! writeInDirectoryName: directoryNameOrPath fileName: fileName extension: ext visit: visitBlock | directory | directory := self directoryForDirectoryNamed: directoryNameOrPath. self fileUtils writeStreamFor: fileName , ext in: directory do: [ :fileStream | fileStream lineEndConvention: #'lf'. self setFileStream: fileStream. visitBlock value ]! ! !MCFileTreeAbstractStWriter methodsFor: 'visiting' stamp: 'topa 7/22/2013 14:35'! visitClassTraitDefinition: definition self subclassResponsibility! ! !MCFileTreeAbstractStWriter methodsFor: 'initialize-release' stamp: 'dkh 4/5/2012 11:15:15'! writeBasicDefinitions: aCollection "the correct initialization order is unknown if some classes are missing in the image" self writePropertiesFile. stWriter acceptVisitor: self forDefinitions: aCollection. self writeInitializers! ! !MCFileTreeAbstractStWriter methodsFor: 'writing' stamp: 'topa 7/22/2013 00:16'! writeTraitDefinition: definition stWriter writeClassDefinition: definition. definition hasComment ifTrue: [stWriter writeClassComment: definition].! ! !MCFileTreeAbstractStWriter methodsFor: 'accessing' stamp: 'dkh 08/10/2012 02:55:31'! fileUtils ^ MCFileTreeFileUtils current! ! !MCFileTreeAbstractStWriter class methodsFor: 'accessing' stamp: 'dkh 4/5/2012 11:15:15'! monticelloMetaDirName ^ '.'! ! !MCFileTreeAbstractStWriter class methodsFor: 'accessing' stamp: 'dkh 4/5/2012 11:15:15'! readerClass ^ MCStReader! ! !MCFileTreeAbstractStWriter class methodsFor: 'writing' stamp: 'dkh 4/5/2012 11:15:15'! on: aStream MCFileTreePackageStructureStWriter useCypressWriter ifTrue: [ ^ MCFileTreeStCypressWriter new stream: aStream ]. ^ (MCFileTreePackageStructureStWriter useSnapShotWriter ifTrue: [ MCFileTreeStSnapshotWriter ] ifFalse: [ MCFileTreeStWriter ]) new stream: aStream! ! !MCFileTreeFileSystemUtils commentStamp: 'TorstenBergmann 2/20/2014 15:54'! Utility class! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/8/2012 21:48'! directoryExists: aDirectory ^ aDirectory isDirectory! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 06:47'! directoryName: aDirectory ^ aDirectory basename! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/9/2012 15:38'! resolvePath: path in: aDirectory ^ aDirectory resolveString: path! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/8/2012 19:19'! pathNameDelimiter ^ DiskStore activeClass delimiter! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 13:47'! directoryFromEntry: directoryEntry ^ directoryEntry asFileReference! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 05:14'! directoryFromPath: directoryPath relativeTo: aDirectory ^ aDirectory resolveString: directoryPath! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/9/2012 09:46'! writeStreamFor: filePath in: aDirectory do: aBlock (aDirectory resolveString: filePath) writeStreamDo: aBlock! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 06:31'! readStreamFor: filePath in: aDirectory do: aBlock "temporary hack for Pharo-1.4" ^ (aDirectory resolveString: filePath) readStreamDo: [ :fileStream | | stream | stream := ReadStream on: fileStream contents asString. stream reset. aBlock value: stream ]! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'ChristopheDemarey 7/22/2013 11:48'! ensureFilePathExists: fileNameOrPath relativeTo: aDirectory (aDirectory resolveString: fileNameOrPath) parent ensureCreateDirectory! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/8/2012 22:12'! deleteAll: aDirectory ^ aDirectory deleteAll! ! !MCFileTreeFileSystemUtils class methodsFor: 'initialization' stamp: 'dkh 8/9/2012 08:29'! initialize "self initialize" self install! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/9/2012 09:33'! parentDirectoryOf: aDirectory ^ aDirectory parent! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/8/2012 22:09'! default ^ DiskStore activeClass createDefault defaultWorkingDirectory asFileReference! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/9/2012 15:43'! filePathExists: filePath relativeTo: aDirectory ^ (aDirectory resolveString: filePath) isFile! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 09:29'! directoryFromPath: directoryPath ^ (AbsolutePath from: directoryPath delimiter: self pathNameDelimiter) asFileReference! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 07:50'! directoryPathString: aDirectory ^ aDirectory pathString! ! !MCFileTreeFileSystemUtils class methodsFor: 'utilities' stamp: 'ChristopheDemarey 7/22/2013 11:48'! ensureDirectoryExists: aDirectory aDirectory ensureCreateDirectory! ! !MCFileTreeFileUtils commentStamp: 'TorstenBergmann 2/20/2014 15:59'! Utility class for file access! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 09:59'! directoryExists: aDirectory self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 09:59'! directoryName: aDirectory self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 10:00'! resolvePath: path in: aDirectory self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/9/2012 09:15'! buildPathFrom: pathCollection ^ String streamContents: [ :stream | pathCollection do: [ :element | stream nextPutAll: element ] separatedBy: [ stream nextPut: self pathNameDelimiter ] ]! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 10:00'! pathNameDelimiter self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 09:59'! directoryFromPath: directoryPath relativeTo: aDirectory self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 10:00'! writeStreamFor: filePath in: aDirectory do: aBlock self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 10:00'! readStreamFor: filePath in: aDirectory do: aBlock self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 09:59'! ensureFilePathExists: fileNameOrPath relativeTo: aDirectory self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 09:59'! deleteAll: aDirectory self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 10:00'! parentDirectoryOf: aDirectory self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 09:59'! default self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'initialization' stamp: 'dkh 8/8/2012 22:37'! install Current := self! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 10:00'! filePathExists: filePath relativeTo: aDirectory self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 09:59'! ensureDirectoryExists: aDirectory self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 09:59'! directoryPathString: aDirectory self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'utilities' stamp: 'dkh 8/10/2012 09:59'! directoryFromPath: directoryPath self subclassResponsibility! ! !MCFileTreeFileUtils class methodsFor: 'accessing' stamp: 'dkh 8/8/2012 22:36'! current ^ Current! ! !MCFileTreeJsonParser commentStamp: 'TorstenBergmann 2/20/2014 15:59'! JSON parser! !MCFileTreeJsonParser methodsFor: 'creating' stamp: 'dkh 2/16/2012 14:39:25'! createString: aString "Create a string literal. Subclasses might want to refine this implementation." ^ aString! ! !MCFileTreeJsonParser methodsFor: 'adding' stamp: 'dkh 2/16/2012 14:39:25'! addValue: anObject to: aCollection "Add anObject to aCollection. Subclasses might want to refine this implementation." ^ aCollection copyWith: anObject! ! !MCFileTreeJsonParser methodsFor: 'creating' stamp: 'dkh 2/16/2012 14:39:25'! createTrue "Create the true literal. Subclasses might want to refine this implementation." ^ true! ! !MCFileTreeJsonParser methodsFor: 'parsing' stamp: 'dkh 2/16/2012 14:39:25'! parseValue | char | stream atEnd ifFalse: [ char := stream peek. char = ${ ifTrue: [ ^ self parseObject ]. char = $[ ifTrue: [ ^ self parseArray ]. char = $" ifTrue: [ ^ self parseString ]. (char = $- or: [ char between: $0 and: $9 ]) ifTrue: [ ^ self parseNumber ]. (self match: 'true') ifTrue: [ ^ self createTrue ]. (self match: 'false') ifTrue: [ ^ self createFalse ]. (self match: 'null') ifTrue: [ ^ self createNull ] ]. self error: 'invalid input'! ! !MCFileTreeJsonParser methodsFor: 'creating' stamp: 'dkh 2/16/2012 14:39:25'! createObject "Create an empty object. Subclasses might want to refine this implementation." ^ Dictionary new! ! !MCFileTreeJsonParser methodsFor: 'private' stamp: 'dkh 2/16/2012 14:39:25'! match: aString "Tries to match aString, consume input and answer true if successful." | position | position := stream position. aString do: [ :each | (stream atEnd or: [ stream next ~= each ]) ifTrue: [ stream position: position. ^ false ] ]. self whitespace. ^ true! ! !MCFileTreeJsonParser methodsFor: 'parsing' stamp: 'dkh 2/16/2012 14:39:25'! parseObject | result | self expect: '{'. result := self createObject. (self match: '}') ifTrue: [ ^ result ]. [ stream atEnd ] whileFalse: [ result := self addProperty: self parseProperty to: result. (self match: '}') ifTrue: [ ^ result ]. self expect: ',' ]. self error: 'end of object expected'! ! !MCFileTreeJsonParser methodsFor: 'parsing-internal' stamp: 'dkh 2/16/2012 14:39:25'! parseNumber | negated number | negated := stream peek = $-. negated ifTrue: [ stream next ]. number := self parseNumberInteger. (stream peek = $.) ifTrue: [ stream next. number := number + self parseNumberFraction ]. (stream peek = $e or: [ stream peek = $E ]) ifTrue: [ stream next. number := number * self parseNumberExponent ]. negated ifTrue: [ number := number negated ]. ^ self whitespace; createNumber: number! ! !MCFileTreeJsonParser methodsFor: 'parsing-internal' stamp: 'dkh 4/6/2012 15:56:14'! parseNumberInteger | number | number := 0. [ stream atEnd not and: [ stream peek isDigit ] ] whileTrue: [ number := 10 * number + (stream next charCode - 48) ]. ^ number! ! !MCFileTreeJsonParser methodsFor: 'parsing-internal' stamp: 'dkh 4/6/2012 15:56:14'! parseNumberFraction | number power | number := 0. power := 1.0. [ stream atEnd not and: [ stream peek isDigit ] ] whileTrue: [ number := 10 * number + (stream next charCode - 48). power := power * 10.0 ]. ^ number / power! ! !MCFileTreeJsonParser methodsFor: 'parsing-internal' stamp: 'dkh 4/6/2012 15:56:14'! parseCharacterHexDigit | digit | stream atEnd ifFalse: [ digit := stream next charCode. (digit between: 48 and: 57) ifTrue: [ ^ digit - 48 ]. "$0" "$9" (digit between: 65 and: 70) ifTrue: [ ^ digit - 55 ]. "$A" "$F" (digit between: 97 and: 102) ifTrue: [ ^ digit - 87 ] "$a" "$f" ]. self error: 'hex-digit expected'! ! !MCFileTreeJsonParser methodsFor: 'creating' stamp: 'dkh 2/16/2012 14:39:25'! createArray "Create an empty collection. Subclasses might want to refine this implementation." ^ Array new! ! !MCFileTreeJsonParser methodsFor: 'parsing-internal' stamp: 'dkh 2/16/2012 14:39:25'! parseCharacterHex | value | value := self parseCharacterHexDigit. 3 timesRepeat: [ value := (value << 4) + self parseCharacterHexDigit ]. ^ Character codePoint: value! ! !MCFileTreeJsonParser methodsFor: 'parsing' stamp: 'dkh 2/16/2012 14:39:25'! parse | result | result := self whitespace; parseValue. stream atEnd ifFalse: [ self error: 'end of input expected' ]. ^ result! ! !MCFileTreeJsonParser methodsFor: 'creating' stamp: 'dkh 2/16/2012 14:39:25'! createFalse "Create the false literal. Subclasses might want to refine this implementation." ^ false! ! !MCFileTreeJsonParser methodsFor: 'parsing-internal' stamp: 'dkh 2/16/2012 14:39:25'! parseString | result | self expect: '"'. result := WriteStream on: String new. [ stream atEnd or: [ stream peek = $" ] ] whileFalse: [ result nextPut: self parseCharacter ]. ^ self expect: '"'; createString: result contents! ! !MCFileTreeJsonParser methodsFor: 'adding' stamp: 'dkh 2/16/2012 14:39:25'! addProperty: anAssociation to: anObject "Add the property anAssociation described with key and value to anObject. Subclasses might want to refine this implementation." ^ anObject add: anAssociation; yourself! ! !MCFileTreeJsonParser methodsFor: 'private' stamp: 'dkh 2/16/2012 14:39:25'! whitespace "Strip whitespaces from the input stream." [ stream atEnd not and: [ stream peek isSeparator ] ] whileTrue: [ stream next ]! ! !MCFileTreeJsonParser methodsFor: 'parsing-internal' stamp: 'dkh 2/16/2012 14:39:25'! parseCharacter | char | (char := stream next) = $\ ifFalse: [ ^ char ]. (char := stream next) = $" ifTrue: [ ^ char ]. char = $\ ifTrue: [ ^ char ]. char = $/ ifTrue: [ ^ char ]. char = $b ifTrue: [ ^ Character backspace ]. char = $f ifTrue: [ ^ Character newPage ]. char = $n ifTrue: [ ^ Character lf ]. char = $r ifTrue: [ ^ Character cr ]. char = $t ifTrue: [ ^ Character tab ]. char = $u ifTrue: [ ^ self parseCharacterHex ]. self error: 'invalid escape character \' , (String with: char)! ! !MCFileTreeJsonParser methodsFor: 'creating' stamp: 'dkh 2/16/2012 14:39:25'! createNull "Create the null literal. Subclasses might want to refine this implementation." ^ nil! ! !MCFileTreeJsonParser methodsFor: 'private' stamp: 'dkh 2/16/2012 14:39:25'! expect: aString "Expects aString and consume input, throw an error otherwise." ^ (self match: aString) ifFalse: [ self error: aString , ' expected' ]! ! !MCFileTreeJsonParser methodsFor: 'parsing-internal' stamp: 'dkh 4/6/2012 15:56:14'! parseNumberExponent | number negated | number := 0. negated := stream peek = $-. (negated or: [ stream peek = $+ ]) ifTrue: [ stream next ]. [ stream atEnd not and: [ stream peek isDigit ] ] whileTrue: [ number := 10 * number + (stream next charCode - 48) ]. negated ifTrue: [ number := number negated ]. ^ 10 raisedTo: number! ! !MCFileTreeJsonParser methodsFor: 'creating' stamp: 'dkh 2/16/2012 14:39:25'! createProperty: aKey with: aValue "Create an empty attribute value pair. Subclasses might want to refine this implementation." ^ aKey -> aValue! ! !MCFileTreeJsonParser methodsFor: 'parsing-internal' stamp: 'dkh 2/16/2012 14:39:25'! parseProperty | name value | name := self parseString. self expect: ':'. value := self parseValue. ^ self createProperty: name with: value.! ! !MCFileTreeJsonParser methodsFor: 'parsing' stamp: 'dkh 2/16/2012 14:39:25'! parseArray | result | self expect: '['. result := self createArray. (self match: ']') ifTrue: [ ^ result ]. [ stream atEnd ] whileFalse: [ result := self addValue: self parseValue to: result. (self match: ']') ifTrue: [ ^ result ]. self expect: ',' ]. self error: 'end of array expected'! ! !MCFileTreeJsonParser methodsFor: 'initialization' stamp: 'dkh 2/16/2012 14:39:25'! initializeOn: aStream self initialize. stream := aStream! ! !MCFileTreeJsonParser methodsFor: 'creating' stamp: 'dkh 2/16/2012 14:39:25'! createNumber: aString "Create a number literal. Subclasses might want to refine this implementation." ^ aString asNumber! ! !MCFileTreeJsonParser class methodsFor: 'accessing' stamp: 'dkh 2/16/2012 14:39:25'! parse: aString ^ self parseStream: aString readStream! ! !MCFileTreeJsonParser class methodsFor: 'instance creation' stamp: 'dkh 2/16/2012 14:39:25'! on: aStream ^ self basicNew initializeOn: aStream! ! !MCFileTreeJsonParser class methodsFor: 'instance creation' stamp: 'dkh 2/16/2012 14:39:25'! new self error: 'Instantiate the parser with a stream.'! ! !MCFileTreeJsonParser class methodsFor: 'accessing' stamp: 'dkh 2/16/2012 14:39:25'! parseStream: aStream ^ (self on: aStream) parse! ! !MCFileTreePackageStructureStWriter commentStamp: 'TorstenBergmann 2/20/2014 15:59'! Writer for a package structure! !MCFileTreePackageStructureStWriter methodsFor: 'visiting' stamp: 'dkh 2/29/2012 13:46'! acceptVisitor: aVisitor forDefinitions: aCollection (MCDependencySorter sortItems: aCollection) do: [ :ea | ea accept: aVisitor ] displayingProgress: 'Writing definitions...'! ! !MCFileTreePackageStructureStWriter methodsFor: 'accessing' stamp: 'dkh 2/29/2012 13:45'! initializers: aCollection initializers := aCollection! ! !MCFileTreePackageStructureStWriter methodsFor: 'accessing' stamp: 'dkh 2/29/2012 13:46'! presentInitializers ^ initializers select: [ :each | Smalltalk hasClassNamed: each key ]! ! !MCFileTreePackageStructureStWriter methodsFor: 'writing' stamp: 'dkh 2/29/2012 13:42'! writeDefinitions: aCollection "the correct initialization order is unknown if some classes are missing in the image" initializers := Set new. self acceptVisitor: self forDefinitions: aCollection; writePresentInitializers; writeAbsentInitializers! ! !MCFileTreePackageStructureStWriter methodsFor: 'writing' stamp: 'dkh 2/29/2012 13:45'! writePresentInitializers | orderedClasses presentInitializers | presentInitializers := self presentInitializers. orderedClasses := (Class superclassOrder: (presentInitializers collect: [ :each | Smalltalk classOrTraitNamed: each key ])) collect: [ :each | each name ]. orderedClasses do: [ :className | stream nextPutAll: (presentInitializers detect: [ :each | each key = className ]) value contents ]! ! !MCFileTreePackageStructureStWriter methodsFor: 'writing' stamp: 'dkh 2/29/2012 13:45'! writeAbsentInitializers (self absentInitializers asSortedCollection: [ :a :b | a key <= b key ]) do: [ :association | stream nextPutAll: association value contents ]! ! !MCFileTreePackageStructureStWriter methodsFor: 'writing' stamp: 'dkh 2/29/2012 14:48'! writeClassDefinition: definition self chunkContents: [ :s | definition printDefinitionOn: s ]! ! !MCFileTreePackageStructureStWriter methodsFor: 'writing' stamp: 'dkh 2/16/2012 14:49:00'! writeMethodPreamble: definition stream cr; nextPut: $!!; nextPutAll: definition fullClassName; nextPutAll: ' methodsFor: '; nextPutAll: definition category asString printString; nextPutAll: '!!'; cr! ! !MCFileTreePackageStructureStWriter methodsFor: 'writing' stamp: 'dkh 3/1/2012 14:21'! writeProperties stream nextPut: ${; cr; nextPutAll: ' "noMethodMetaData" : true,'; cr; nextPutAll: ' "separateMethodMetaAndSource" : false'; cr; nextPut: $}; cr! ! !MCFileTreePackageStructureStWriter methodsFor: 'accessing' stamp: 'dkh 2/29/2012 13:46'! absentInitializers ^ initializers reject: [ :each | Smalltalk hasClassNamed: each key ]! ! !MCFileTreePackageStructureStWriter class methodsFor: 'accessing' stamp: 'dkh 3/1/2012 10:30'! useSnapShotWriter ^ MCFileTreeRepository defaultPackageExtension = '.pkg'! ! !MCFileTreePackageStructureStWriter class methodsFor: 'accessing' stamp: 'dkh 4/5/2012 10:37'! useCypressWriter "MCFileTreeRepository defaultPackageExtension:'.package'" "MCFileTreeRepository defaultPackageExtension:'.pkg'" ^ true! ! !MCFileTreeRepository commentStamp: 'TorstenBergmann 2/20/2014 16:23'! A file tree repository! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 07/08/2013 10:59:46'! versionFromFileNamed: aString ^ self loadVersionFromFileNamed: aString! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 07/10/2013 11:43:55'! flushCache "force properties to be reread ... if the directory exists, otherwise let nature take it's course" super flushCache. directory ifNotNil: [ (MCFileTreeFileUtils current directoryExists: directory) ifTrue: [ repositoryProperties := nil. self repositoryProperties ] ]! ! !MCFileTreeRepository methodsFor: 'descriptions' stamp: 'dkh 2/16/2012 14:49:00'! description ^ self class description , super description! ! !MCFileTreeRepository methodsFor: 'accessing' stamp: 'dkh 07/10/2013 11:43:55'! defaultRepositoryProperties ^ Dictionary new at: 'packageExtension' put: self class defaultPackageExtension; at: 'propertyFileExtension' put: self propertyFileExtension; yourself! ! !MCFileTreeRepository methodsFor: 'private' stamp: 'dkh 07/10/2013 11:43:55'! propertyFileExtension: propertyFileExtension self class validatePropertyFileExtension: propertyFileExtension. self repositoryProperties at: 'propertyFileExtension' put: propertyFileExtension. self writeRepositoryProperties! ! !MCFileTreeRepository methodsFor: 'actions' stamp: 'dkh 8/10/2012 07:56'! versionInfoForPackageDirectory: packageDirectory ^ ((MCReader readerClassForFileNamed: (self fileUtils directoryName: packageDirectory)) on: (self fileUtils parentDirectoryOf: packageDirectory) fileName: (self fileUtils directoryName: packageDirectory)) loadVersionInfo; info! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 07/08/2013 10:59:46'! allFileNamesForVersionNamed: aString ^ self filterFileNames: self readableFileNames forVersionNamed: aString! ! !MCFileTreeRepository methodsFor: 'accessing' stamp: 'dkh 8/10/2012 07:54'! repositoryProperties repositoryProperties ifNil: [ repositoryProperties := Dictionary new. (self fileUtils directoryExists: directory) ifFalse: [ self error: 'filetree:// repository ' , (self fileUtils directoryPathString: self directory) printString , ' does not exist.' ]. (self directory entries detect: [ :entry | entry name = '.filetree' ] ifNone: [ ]) ifNil: [ repositoryProperties := self defaultRepositoryProperties. self writeRepositoryProperties ] ifNotNil: [ :configEntry | configEntry readStreamDo: [ :fileStream | repositoryProperties := MCFileTreeJsonParser parseStream: fileStream ] ] ]. ^ repositoryProperties! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 07/08/2013 10:59:46'! versionInfoFromFileNamed: aString ^ self loadVersionInfoFromFileNamed: aString! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 2/29/2012 10:15'! canReadFileNamed: aString ^ (aString endsWith: self packageExtension) or: [ (aString endsWith: '.tree') or: [ "Cypress format" aString endsWith: '.package' ] ]! ! !MCFileTreeRepository methodsFor: '*metacello-filetree' stamp: 'dkh 5/16/2012 21:21:27'! metacelloProjectClassFor: aScriptEngine aScriptEngine versionString isEmptyOrNil ifFalse: [ "If we have a version in the script, then a BaselineOf is not being referenced...use a MetacelloMCProject see https://github.com/dalehenrich/metacello-work/issues/7" ^ super metacelloProjectClassFor: aScriptEngine ]. ^ MetacelloMCBaselineProject! ! !MCFileTreeRepository methodsFor: 'accessing' stamp: 'dkh 2/16/2012 14:49:00'! readonly readonly ifNil: [ readonly := false ]. ^ readonly! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 4/5/2012 10:33'! basicStoreVersion: aVersion self readonly ifTrue: [ ^ self error: 'The filetree repository: ' , self description printString , ' was created read only.' ]. MCFileTreeWriter fileOut: aVersion on: self! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 2/16/2012 14:49:00'! versionNameFromFileName: aString | description | description := self packageDescriptionFromPackageDirectory: (self fileDirectoryOn: aString). ^ description first , '-' , description second , '.' , description third printString! ! !MCFileTreeRepository methodsFor: 'actions' stamp: 'dkh 6/27/2012 20:14'! packageDescriptionFromPackageDirectory: packageDirectory | filename info extension | filename := self fileUtils current directoryName: packageDirectory. extension := filename copyFrom: (filename lastIndexOf: $.) to: filename size. ^ ((self packageExtension ~= '.package' and: [ (self fileUtils filePathExists: 'version' relativeTo: packageDirectory) and: [ self fileUtils filePathExists: 'package' relativeTo: packageDirectory ] ]) or: [ | dir | dir := self fileUtils directoryFromPath: MCFileTreeStCypressWriter monticelloMetaDirName relativeTo: packageDirectory. self fileUtils directoryExists: dir ]) ifTrue: [ info := self versionInfoForPackageDirectory: packageDirectory. self parseName: info name extension: extension ] ifFalse: [ {(filename copyFrom: 1 to: (filename lastIndexOf: $.) - 1). 'cypress'. 1. filename} ]! ! !MCFileTreeRepository methodsFor: 'actions' stamp: 'dkh 2/16/2012 14:49:00'! packageDescriptionsFromReadableFileNames ^ ((self readableFileNames collect: [ :fileName | self fileDirectoryOn: fileName ]) select: [ :packageDirectory | self fileUtils directoryExists: packageDirectory ]) collect: [ :packageDirectory | self packageDescriptionFromPackageDirectory: packageDirectory ]! ! !MCFileTreeRepository methodsFor: 'i/o' stamp: 'dkh 2/16/2012 14:49:00'! readStreamForFileNamed: aString do: aBlock ^ aBlock value: self directory! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 2/16/2012 14:49:00'! cachedFileNames ^ #()! ! !MCFileTreeRepository methodsFor: 'accessing' stamp: 'dkh 2/16/2012 14:49:00'! readonly: anObject readonly := anObject! ! !MCFileTreeRepository methodsFor: 'interface' stamp: 'dkh 07/08/2013 10:59:46'! versionWithInfo: aVersionInfo ifAbsent: errorBlock (self allFileNamesForVersionNamed: aVersionInfo name) ifNotEmpty: [ :aCollection | ^ self versionFromFileNamed: aCollection first ]. ^ errorBlock value! ! !MCFileTreeRepository methodsFor: 'i/o' stamp: 'dkh 2/16/2012 14:49:00'! writeStreamForFileNamed: aString replace: aBoolean do: aBlock self error: 'we do not open a single stream, but write multiple files'! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 8/10/2012 09:44'! writeRepositoryProperties self fileUtils writeStreamFor: '.filetree' in: self directory do: [ :fileStream | | keyCount propertyCount | repositoryProperties ifNil: [ repositoryProperties := self defaultRepositoryProperties ]. keyCount := repositoryProperties size. propertyCount := 0. fileStream lineEndConvention: #'lf'. fileStream nextPutAll: '{'. repositoryProperties keysAndValuesDo: [ :propertyName :propertyValue | propertyCount := propertyCount + 1. fileStream nextPut: $"; nextPutAll: propertyName asString; nextPutAll: '" : "'; nextPutAll: propertyValue asString; nextPut: $"; yourself. propertyCount < keyCount ifTrue: [ fileStream nextPutAll: ','; cr ] ]. fileStream nextPutAll: ' }' ] ! ! !MCFileTreeRepository methodsFor: 'private' stamp: 'dkh 07/10/2013 11:43:55'! propertyFileExtension ^ self repositoryProperties at: 'propertyFileExtension' ifAbsent: [ self class defaultPropertyFileExtension ]! ! !MCFileTreeRepository methodsFor: 'private' stamp: 'dkh 2/29/2012 11:39'! parseName: aString extension: extension ^ self class parseName: aString extension: extension! ! !MCFileTreeRepository methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 1/5/2014 15:46'! isRemote ^ true! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 07/08/2013 10:59:46'! filterFileNames: aCollection forVersionNamed: aString ^ aCollection select: [:ea | (self versionNameFromFileName: ea) = aString]! ! !MCFileTreeRepository methodsFor: 'private' stamp: 'dkh 2/29/2012 10:11'! packageExtension ^ self repositoryProperties at: 'packageExtension' ifAbsent: [ self class defaultPackageExtension ]! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 3/7/2012 17:09:47'! directory: aDirectory super directory: aDirectory. repositoryProperties := nil. "force properties to be reloaded from new location" self repositoryProperties "NOW"! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 07/08/2013 10:59:46'! allFileNames ^ (self directory entries select: [ :entry | entry isDirectory and: [ self canReadFileNamed: entry name ] ]) collect: [ :entry | entry name ]! ! !MCFileTreeRepository methodsFor: 'as yet unclassified' stamp: 'dkh 07/08/2013 10:59:46'! goferVersionFrom: aVersionReference "until we no longer find .tree directories in the wild" ((self readableFileNames collect: [ :fileName | self fileDirectoryOn: fileName ]) select: [ :packageDirectory | self fileUtils directoryExists: packageDirectory ]) collect: [ :packageDirectory | (self versionInfoForPackageDirectory: packageDirectory) name = aVersionReference name ifTrue: [ ^ self loadVersionFromFileNamed: (self fileUtils directoryName: packageDirectory) ] ]. ^ nil! ! !MCFileTreeRepository methodsFor: 'actions' stamp: 'dkh 6/16/2012 09:02'! fileDirectoryOn: directoryPath ^ self fileUtils directoryFromPath: directoryPath relativeTo: self directory! ! !MCFileTreeRepository methodsFor: 'accessing' stamp: 'dkh 2/16/2012 14:49:00'! asRepositorySpecFor: aMetacelloMCProject ^ aMetacelloMCProject repositorySpec description: self description; type: 'filetree'; yourself! ! !MCFileTreeRepository methodsFor: 'accessing' stamp: 'dkh 8/10/2012 14:55:31.237'! fileUtils ^ MCFileTreeFileUtils current! ! !MCFileTreeRepository class methodsFor: 'accessing' stamp: 'dkh 07/10/2013 11:43:55'! validatePropertyFileExtension: aString "see Issue #90: https://github.com/dalehenrich/filetree/issues/90" (#('.json' '.ston') includes: aString) ifFalse: [ self error: 'Unsupported property file extension: ' , aString printString ]! ! !MCFileTreeRepository class methodsFor: 'instance creation' stamp: 'dkh 2/16/2012 14:49:00'! description ^ 'filetree://'! ! !MCFileTreeRepository class methodsFor: 'accessing' stamp: 'dkh 07/10/2013 11:43:55'! defaultPropertyFileExtension defaultPropertyFileExtension ifNil: [ defaultPropertyFileExtension := '.json' ]. ^ defaultPropertyFileExtension! ! !MCFileTreeRepository class methodsFor: 'accessing' stamp: 'dkh 07/10/2013 11:43:55'! defaultPropertyFileExtension: aString "self defaultPropertyFileExtension:'.ston'" self validatePropertyFileExtension: aString. defaultPropertyFileExtension := aString! ! !MCFileTreeRepository class methodsFor: 'utility' stamp: 'dkh 2/16/2012 14:49:00'! parseName: aString extension: extension "picked up from GoferVersionReference>>parseName:" | info basicName package branch author versionNumber packageName | basicName := aString last isDigit ifTrue: [ aString ] ifFalse: [ (aString copyUpToLast: $.) copyUpTo: $( ]. package := basicName copyUpToLast: $-. (package includes: $.) ifFalse: [ branch := '' ] ifTrue: [ branch := '.' , (package copyAfter: $.). package := package copyUpTo: $. ]. author := (basicName copyAfterLast: $-) copyUpToLast: $.. versionNumber := (basicName copyAfterLast: $-) copyAfterLast: $.. (versionNumber notEmpty and: [ versionNumber allSatisfy: [ :each | each isDigit ] ]) ifTrue: [ versionNumber := versionNumber asNumber ] ifFalse: [ versionNumber := 0 ]. packageName := package , branch. ^ {packageName. author. versionNumber. (packageName , extension)}! ! !MCFileTreeRepository class methodsFor: 'utility' stamp: 'dkh 2/29/2012 09:40:37'! parseName: aString ^ self parseName: aString extension: self defaultPackageExtension! ! !MCFileTreeRepository class methodsFor: 'accessing' stamp: 'dkh 4/4/2012 14:36'! defaultPackageExtension: aString ".tree and .pkg are the only two formats supported at the moment" "self defaultPackageExtension:'.package'" (#('.tree' '.pkg' '.package') includes: aString) ifFalse: [ self error: 'Unsupported package extension: ' , aString printString ]. defaultPackageExtension := aString! ! !MCFileTreeRepository class methodsFor: 'accessing' stamp: 'dkh 4/4/2012 14:27'! defaultPackageExtension ".tree, .pkg, .package are the only formats supported at the moment: .tree - original structure .pkg - snapshot structure .package - cypress structure" defaultPackageExtension ifNil: [ defaultPackageExtension := MCFileTreePackageStructureStWriter useCypressWriter ifTrue: [ '.package' ] ifFalse: [ '.pkg' ] ]. ^ defaultPackageExtension! ! !MCFileTreeStCypressReader commentStamp: 'TorstenBergmann 2/20/2014 15:57'! Reader for Cypress format see https://github.com/CampSmalltalk/Cypress! !MCFileTreeStCypressReader methodsFor: 'utilities' stamp: 'dkh 8/10/2012 14:00'! addExtensionClassAndMethodDefinitionsFromEntry: classEntry | classDirectory classPropertiesDict methodPropertiesDict entries | classDirectory := self fileUtils directoryFromEntry: classEntry. ((entries := classDirectory entries) detect: [ :entry | self isPropertyFile: entry] ifNone: [ ]) ifNotNil: [ :propertyEntry | propertyEntry readStreamDo: [ :fileStream | classPropertiesDict := MCFileTreeJsonParser parseStream: fileStream ] ]. methodPropertiesDict := Dictionary new. (entries detect: [ :entry | self isMethodPropertyFile: entry] ifNone: [ ]) ifNotNil: [ :propertyEntry | propertyEntry readStreamDo: [ :fileStream | "Issue 33: https://github.com/dalehenrich/filetree/issues/33" methodPropertiesDict := MCFileTreeJsonParser parseStream: fileStream ] ]. self addMethodDefinitionsForClass: (classPropertiesDict at: 'name') methodProperties: methodPropertiesDict in: entries! ! !MCFileTreeStCypressReader methodsFor: 'accessing' stamp: 'dkh 6/27/2012 20:19'! basicVersion self hasMonticelloMetadata ifTrue: [ ^ super basicVersion ]. ^ MCVersion new setPackage: self package info: self info snapshot: self snapshot dependencies: #(); yourself! ! !MCFileTreeStCypressReader methodsFor: 'utilities' stamp: 'topa 7/22/2013 14:41'! addTraitAndMethodDefinitionsFromEntry: classEntry | classDirectory classPropertiesDict classComment entries methodPropertiesDict | classDirectory := self fileUtils directoryFromEntry: classEntry. ((entries := classDirectory entries) detect: [:entry | self isPropertyFile: entry] ifNone: [ ]) ifNotNil: [ :propertyEntry | propertyEntry readStreamDo: [ :fileStream | classPropertiesDict := MCFileTreeJsonParser parseStream: fileStream ] ]. (entries detect: [ :entry | entry name = 'README.md' ] ifNone: [ ]) ifNotNil: [ :commentEntry | commentEntry readStreamDo: [ :fileStream | classComment := fileStream contents ] ] ifNil: [ classComment := '' ]. methodPropertiesDict := Dictionary new. (entries detect: [ :entry | self isMethodPropertyFile: entry] ifNone: [ ]) ifNotNil: [ :propertyEntry | propertyEntry readStreamDo: [ :fileStream | "Issue 33: https://github.com/dalehenrich/filetree/issues/33" methodPropertiesDict := MCFileTreeJsonParser parseStream: fileStream ] ]. self addTraitDefinitionFrom: classPropertiesDict comment: classComment withSqueakLineEndings. self addMethodDefinitionsForClass: (classPropertiesDict at: 'name') methodProperties: methodPropertiesDict in: entries! ! !MCFileTreeStCypressReader methodsFor: 'utilities' stamp: 'dkh 8/10/2012 13:48'! addClassAndMethodDefinitionsFromEntry: classEntry | classDirectory classPropertiesDict classComment entries methodPropertiesDict | classDirectory := self fileUtils directoryFromEntry: classEntry. ((entries := classDirectory entries) detect: [:entry | self isPropertyFile: entry] ifNone: [ ]) ifNotNil: [ :propertyEntry | propertyEntry readStreamDo: [ :fileStream | classPropertiesDict := MCFileTreeJsonParser parseStream: fileStream ] ]. (entries detect: [ :entry | entry name = 'README.md' ] ifNone: [ ]) ifNotNil: [ :commentEntry | commentEntry readStreamDo: [ :fileStream | classComment := fileStream contents ] ]. methodPropertiesDict := Dictionary new. (entries detect: [ :entry | self isMethodPropertyFile: entry] ifNone: [ ]) ifNotNil: [ :propertyEntry | propertyEntry readStreamDo: [ :fileStream | "Issue 33: https://github.com/dalehenrich/filetree/issues/33" methodPropertiesDict := MCFileTreeJsonParser parseStream: fileStream ] ]. self addClassDefinitionFrom: classPropertiesDict comment: classComment withSqueakLineEndings. self addMethodDefinitionsForClass: (classPropertiesDict at: 'name') methodProperties: methodPropertiesDict in: entries! ! !MCFileTreeStCypressReader methodsFor: 'private' stamp: 'dkh 6/16/2013 12:47:20'! isPropertyFile: entry ^ entry name = 'properties.ston' or: [ entry name = 'properties.json']! ! !MCFileTreeStCypressReader methodsFor: 'utilities' stamp: 'ChristopheDemarey 5/31/2013 23:28'! methodSelectorFor: source ^ Object compilerClass new parseSelector: source ! ! !MCFileTreeStCypressReader methodsFor: 'utilities' stamp: 'topa 7/22/2013 15:15'! addTraitDefinitionFrom: traitPropertiesDict comment: traitComment definitions add: (MCTraitDefinition name: (traitPropertiesDict at: 'name') traitComposition: (traitPropertiesDict at: 'traitcomposition' ifAbsent: [ '{}' ]) category: (traitPropertiesDict at: 'category' ifAbsent: [ self packageNameFromPackageDirectory ]) comment: traitComment commentStamp: (traitPropertiesDict at: 'commentStamp' ifAbsent: [ '' ])). traitPropertiesDict at: 'classtraitcomposition' ifPresent: [:classTraitComposition | definitions add: (MCClassTraitDefinition baseTraitName: (traitPropertiesDict at: 'name') classTraitComposition: classTraitComposition)].! ! !MCFileTreeStCypressReader methodsFor: 'utilities' stamp: 'dkh 6/27/2012 14:18'! addClassDefinitionFrom: classPropertiesDict comment: classComment definitions add: (MCClassDefinition name: (classPropertiesDict at: 'name') superclassName: (classPropertiesDict at: 'super') traitComposition: (classPropertiesDict at: 'traitcomposition' ifAbsent: [ '{}' ]) classTraitComposition: (classPropertiesDict at: 'classtraitcomposition' ifAbsent: [ '{}' ]) category: (classPropertiesDict at: 'category' ifAbsent: [ self packageNameFromPackageDirectory ]) instVarNames: (classPropertiesDict at: 'instvars' ifAbsent: [ #() ]) classVarNames: (classPropertiesDict at: 'classvars' ifAbsent: [ #() ]) poolDictionaryNames: (classPropertiesDict at: 'pools' ifAbsent: [ #() ]) classInstVarNames: (classPropertiesDict at: 'classinstvars' ifAbsent: [ #() ]) type: (classPropertiesDict at: 'type' ifAbsent: [ 'normal' ]) asSymbol comment: classComment commentStamp: (classPropertiesDict at: 'commentStamp' ifAbsent: [ '' ]))! ! !MCFileTreeStCypressReader methodsFor: 'utilities' stamp: 'dkh 8/10/2012 14:01'! addMethodDefinitionsForClass: className methodProperties: methodProperties in: entries entries do: [ :entry | | classIsMeta | classIsMeta := false. entry name = 'class' ifTrue: [ classIsMeta := true ]. (entry name = 'instance' or: [ entry name = 'class' ]) ifTrue: [ ((self fileUtils directoryFromEntry: entry) entries select: [ :each | each name endsWith: '.st' ]) do: [ :methodEntry | methodEntry readStreamDo: [ :fileStream | | category source timestamp selector | category := fileStream nextLine. source := fileStream upToEnd. selector := self methodSelectorFor: source. timestamp := methodProperties at: (classIsMeta ifTrue: [ 'class' ] ifFalse: [ 'instance' ]) ifPresent: [ :map | map at: selector asString ifAbsent: [ ] ]. "Issue 33: https://github.com/dalehenrich/filetree/issues/33" timestamp ifNil: [ timestamp := self info author , ' ' , self info date mmddyyyy , ' ' , self info time print24 ]. definitions add: (MCMethodDefinition className: className classIsMeta: classIsMeta selector: selector category: category timeStamp: timestamp source: source) ] ] ] ]! ! !MCFileTreeStCypressReader methodsFor: 'utilities' stamp: 'topa 7/22/2013 01:41'! addClassAndMethodDefinitionsFromDirectory: aDirectory aDirectory entries do: [ :entry | (entry name endsWith: '.trait') ifTrue: [ self addTraitAndMethodDefinitionsFromEntry: entry ]. (entry name endsWith: '.class') ifTrue: [ self addClassAndMethodDefinitionsFromEntry: entry ]. (entry name endsWith: '.extension') ifTrue: [ self addExtensionClassAndMethodDefinitionsFromEntry: entry ] ]! ! !MCFileTreeStCypressReader methodsFor: 'accessing' stamp: 'dkh 8/10/2012 14:55'! packageNameFromPackageDirectory | filename | filename := self fileUtils directoryName: packageDirectory. ^ filename copyFrom: 1 to: (filename lastIndexOf: $.) - 1! ! !MCFileTreeStCypressReader methodsFor: 'accessing' stamp: '08/08/2013 15:01'! loadVersionInfo self hasMonticelloMetadata ifTrue: [ ^ info := self extractInfoFrom: (self parseMember: 'version') ]. info := MCVersionInfo name: self packageNameFromPackageDirectory , '-cypress.1' id: UUID new message: 'fabricated from a Cypress format repository' date: Date today time: Time now author: '' ancestors: #() stepChildren: #() ! ! !MCFileTreeStCypressReader methodsFor: 'accessing' stamp: 'dkh 6/27/2012 20:21'! loadPackage self hasMonticelloMetadata ifTrue: [ ^ super loadPackage ]. package := MCPackage named: self packageNameFromPackageDirectory! ! !MCFileTreeStCypressReader methodsFor: 'utilities' stamp: 'dkh 5/23/2013 21:05'! loadDefinitions | entries directory | definitions := OrderedCollection new. directory := self fileUtils directoryFromPath: self monticelloMetaDirName relativeTo: packageDirectory. (self fileUtils directoryExists: directory) ifTrue: [ entries := directory entries. self addDefinitionFromFile: (entries detect: [ :entry | entry name beginsWith: 'categories' ] ifNone: [ ]) inDirectory: directory ] ifFalse: [definitions add: (MCOrganizationDefinition categories: {self packageNameFromPackageDirectory }) ]. self addClassAndMethodDefinitionsFromDirectory: packageDirectory. (self fileUtils directoryExists: directory) ifTrue: [ self addDefinitionFromFile: (entries detect: [ :entry | entry name beginsWith: 'initializers' ] ifNone: [ ]) inDirectory: directory ]! ! !MCFileTreeStCypressReader methodsFor: 'private' stamp: 'dkh 6/16/2013 12:47:20'! isMethodPropertyFile: entry ^ entry name = 'methodProperties.ston' or: [ entry name = 'methodProperties.json']! ! !MCFileTreeStCypressReader class methodsFor: 'accessing' stamp: 'dkh 4/4/2012 14:19'! extension ^ 'package'! ! !MCFileTreeStCypressReader class methodsFor: 'accessing' stamp: 'dkh 4/4/2012 17:44'! monticelloMetaDirName ^ MCFileTreeStCypressWriter monticelloMetaDirName! ! !MCFileTreeStCypressWriter commentStamp: 'TorstenBergmann 2/20/2014 15:57'! Writer for Cypress format see https://github.com/CampSmalltalk/Cypress! !MCFileTreeStCypressWriter methodsFor: 'writing' stamp: 'dkh 07/07/2013 22:13'! writeClassDefinition: definition to: classPath self writeInDirectoryName: classPath fileName: 'README' extension: '.md' visit: [ self writeClassComment: definition ]. self writeInDirectoryName: classPath fileName: 'properties' extension: self propertyFileExtension visit: [ self writeClassDefinition: definition ]. self writeInDirectoryName: classPath fileName: 'methodProperties' extension: self propertyFileExtension visit: [ self writeMethodProperties: (self methodDefinitions at: definition className ifAbsent: [ #() ]) ]! ! !MCFileTreeStCypressWriter methodsFor: 'initialize-release' stamp: '08/08/2013 16:08'! writeDefinitions: aCollection | classDirExtension extensionClasses extensionMethodDefinitions extensionMethodMap methodHolders | self writeBasicDefinitions: aCollection. extensionClasses := OrderedCollection new. extensionMethodDefinitions := OrderedCollection new. methodHolders := self classDefinitions, self traitDefinitions. self methodDefinitions keysAndValuesDo: [ :className :extensionMethods | methodHolders at: className ifAbsent: [ extensionClasses add: className. extensionMethodDefinitions addAll: extensionMethods ] ]. extensionClasses do: [ :className | self methodDefinitions removeKey: className ]. self writeMethodHolderDefinitions: self traitDefinitions extension: '.trait' to: '' do: [ :definition :classPath | self writeTraitDefinition: definition to: classPath. ]. self writeMethodHolderDefinitions: self classDefinitions extension: '.class' to: '' do: [ :definition :classPath | self writeClassDefinition: definition to: classPath ]. classDirExtension := '.extension'. extensionMethodMap := Dictionary new. extensionMethodDefinitions do: [ :methodDefinition | | classPath methodPath | (extensionMethodMap at: methodDefinition className ifAbsent: [ extensionMethodMap at: methodDefinition className put: OrderedCollection new ]) add: methodDefinition. classPath := methodDefinition className , classDirExtension , self fileUtils pathNameDelimiter asString. self writeExtensionClassDefinition: methodDefinition to: classPath ]. extensionMethodMap keysAndValuesDo: [ :className :classMethodDefinitions | | classPath filenameMetaMap | filenameMetaMap := self fileNameMapFor: classMethodDefinitions. classMethodDefinitions do: [ :methodDefinition | | filename methodPath | filename := (filenameMetaMap at: methodDefinition classIsMeta) at: methodDefinition selector. classPath := methodDefinition className , classDirExtension , self fileUtils pathNameDelimiter asString. methodPath := classPath , (methodDefinition classIsMeta ifTrue: [ 'class' ] ifFalse: [ 'instance' ]) , self fileUtils pathNameDelimiter asString. self writeMethodDefinition: methodDefinition to: methodPath filename: filename ]. classPath := className , classDirExtension , self fileUtils pathNameDelimiter asString. self writeInDirectoryName: classPath fileName: 'methodProperties' extension: self propertyFileExtension visit: [ self writeMethodProperties: classMethodDefinitions ] ] ! ! !MCFileTreeStCypressWriter methodsFor: 'writing' stamp: 'dkh 07/18/2013 16:34'! writeMethodDefinition: methodDefinition to: methodPath filename: filename self writeInDirectoryName: methodPath fileName: filename extension: '.st' visit: [ self writeMethodDefinition: methodDefinition ]! ! !MCFileTreeStCypressWriter methodsFor: 'initialize-release' stamp: 'dkh 07/07/2013 22:14'! writePropertiesFile | properties | properties := Dictionary new. properties at: 'noMethodMetaData' put: true. properties at: 'separateMethodMetaAndSource' put: false. properties at: 'useCypressPropertiesFile' put: true. self writeInDirectoryName: '.' fileName: '' extension: '.filetree' visit: [ properties writeCypressJsonOn: fileStream ]. self writeInDirectoryName: '.' fileName: 'properties' extension: self propertyFileExtension visit: [ Dictionary new writeCypressJsonOn: fileStream ]! ! !MCFileTreeStCypressWriter methodsFor: 'private' stamp: 'ChristopheDemarey 8/28/2013 13:50'! fileNameMapFor: aMethodDefinitionCollection "https://github.com/dalehenrich/filetree/issues/92" "answer a dictionary that maps each definition selector to a filename that is guaranteed unique on case insensitive file systems. Segregate instance and class side methods. Key is true for class method map, false for instance method map" | map filenameMetaMap | map := Dictionary new. aMethodDefinitionCollection do: [ :mDef | | sel col metaKey methMap | "sort into bins by lowercase selector. " metaKey := mDef classIsMeta. methMap := map at: metaKey ifAbsent: [ map at: metaKey put: Dictionary new ]. sel := mDef selector asLowercase. col := methMap at: sel ifAbsent: [ methMap at: sel put: OrderedCollection new ]. col add: mDef ]. filenameMetaMap := Dictionary new. map keysAndValuesDo: [ :metaKey :methMap | | filenameMap | filenameMap := filenameMetaMap at: metaKey ifAbsent: [ filenameMetaMap at: metaKey put: Dictionary new ]. methMap values do: [ :col | | selector sortedCol | col size = 1 ifTrue: [ | def | "no need to distinguish filename" def := col at: 1. filenameMap at: def selector put: (self fileNameForSelector: def selector) ] ifFalse: [ "tack on postfix to guarantee file names are uniique on case insensitive file systems" sortedCol := col sorted: [ :a :b | a name <= b name ]. (1 to: sortedCol size) do: [ :index | | def filename | def := sortedCol at: index. filename := self fileNameForSelector: def selector. filename := filename , '..' , index printString. filenameMap at: def selector put: filename ] ] ] ]. ^ filenameMetaMap! ! !MCFileTreeStCypressWriter methodsFor: 'writing' stamp: 'dkh 03/22/2013 11:30'! writeClassComment: definition fileStream nextPutAll: definition comment withUnixLineEndings! ! !MCFileTreeStCypressWriter methodsFor: 'writing' stamp: 'dkh 07/18/2013 17:01'! writeMethodDefinition: methodDefinition to: methodPath self shouldNotImplement! ! !MCFileTreeStCypressWriter methodsFor: 'initialize-release' stamp: 'dkh 07/07/2013 22:15'! propertyFileExtension ^ self repository propertyFileExtension! ! !MCFileTreeStCypressWriter methodsFor: 'private' stamp: 'dkh 4/4/2012 14:01'! setFileStream: aStream super setFileStream: aStream. fileStream := aStream! ! !MCFileTreeStCypressWriter methodsFor: 'writing' stamp: 'dkh 03/22/2013 11:30'! writeMethodDefinition: definition fileStream nextPutAll: definition category; lf; nextPutAll: definition source withUnixLineEndings! ! !MCFileTreeStCypressWriter methodsFor: 'writing' stamp: 'dkh 03/22/2013 13:51'! writeClassDefinition: definition | properties | properties := Dictionary new. properties at: 'name' put: definition className. properties at: 'super' put: definition superclassName. definition traitCompositionString ifNotNil: [ :property | "Issue #48: https://github.com/dalehenrich/filetree/issues/48" property ~= '{}' ifTrue: [ properties at: 'traitcomposition' put: property ] ]. definition classTraitCompositionString ifNotNil: [ :property | "Issue #48: https://github.com/dalehenrich/filetree/issues/48" property ~= '{}' ifTrue: [ properties at: 'classtraitcomposition' put: property ] ]. properties at: 'category' put: definition category. properties at: 'instvars' put: definition instVarNames asArray. properties at: 'classvars' put: definition classVarNames asArray. properties at: 'pools' put: definition poolDictionaries asArray. properties at: 'classinstvars' put: definition classInstVarNames asArray. properties at: 'type' put: definition type asString. properties at: 'commentStamp' put: definition commentStamp. properties writeCypressJsonOn: fileStream! ! !MCFileTreeStCypressWriter methodsFor: 'writing' stamp: 'dkh 07/07/2013 22:14'! writeExtensionClassDefinition: definition to: classPath self writeInDirectoryName: classPath fileName: 'properties' extension: self propertyFileExtension visit: [ self writeExtensionClassDefinition: definition ]! ! !MCFileTreeStCypressWriter methodsFor: 'private' stamp: 'dkh 02/13/2013 17:04'! fileNameForSelector: selector ^ selector last = $: ifTrue: [ selector collect: [ :each | each = $: ifTrue: [ $. ] ifFalse: [ each ] ] ] ifFalse: [ (self class specials includes: selector first) ifFalse: [ selector ] ifTrue: [ | output specials | specials := self class specials. output := String new writeStream. output nextPut: $^. selector do: [ :each | output nextPutAll: ((specials includes: each) ifTrue: [ specials at: each ] ifFalse: [ each asString ]) ] separatedBy: [ output nextPut: $. ]. output contents ] ]! ! !MCFileTreeStCypressWriter methodsFor: 'initialize-release' stamp: 'dkh 6/12/2012 17:33:23'! writeMethodProperties: classMethodDefinitions "Issue 33: https://github.com/dalehenrich/filetree/issues/33" | properties classMethodsMap instanceMethodMap | properties := Dictionary new. properties at: 'class' put: (classMethodsMap := Dictionary new). properties at: 'instance' put: (instanceMethodMap := Dictionary new). classMethodDefinitions do: [ :methodDefinition | (methodDefinition classIsMeta ifTrue: [ classMethodsMap ] ifFalse: [ instanceMethodMap ]) at: methodDefinition selector asString put: methodDefinition timeStamp ]. properties writeCypressJsonOn: fileStream! ! !MCFileTreeStCypressWriter methodsFor: 'writing' stamp: 'dkh 4/4/2012 17:52'! writeExtensionClassDefinition: definition | properties | properties := Dictionary new. properties at: 'name' put: definition className. properties writeCypressJsonOn: fileStream! ! !MCFileTreeStCypressWriter methodsFor: 'writing' stamp: 'topa 7/22/2013 14:54'! writeTraitDefinition: definition | properties compositionString | properties := Dictionary new. properties at: 'name' put: definition className. definition traitCompositionString ifNotNil: [ :property | property ~= '{}' ifTrue: [ properties at: 'traitcomposition' put: property ] ]. " handle the classTrait case " compositionString := self classTraitDefinitions at: definition className ifPresent: [:classTraitDefinition | classTraitDefinition classTraitCompositionString ]. compositionString ifNil: [ compositionString := definition classTraitCompositionString ]. compositionString~= '{}' ifTrue: [ properties at: 'classtraitcomposition' put: compositionString ] . properties at: 'category' put: definition category. properties at: 'commentStamp' put: definition commentStamp. properties writeCypressJsonOn: fileStream! ! !MCFileTreeStCypressWriter methodsFor: 'writing' stamp: 'topa 7/22/2013 14:47'! writeTraitDefinition: definition to: classPath self writeInDirectoryName: classPath fileName: 'README' extension: '.md' visit: [ self writeClassComment: definition ]. self writeInDirectoryName: classPath fileName: 'properties' extension: self propertyFileExtension visit: [ self writeTraitDefinition: definition ]. self writeInDirectoryName: classPath fileName: 'methodProperties' extension: self propertyFileExtension visit: [ self writeMethodProperties: (self methodDefinitions at: definition className ifAbsent: [ #() ]) ]! ! !MCFileTreeStCypressWriter class methodsFor: 'accessing' stamp: 'dkh 4/4/2012 11:27'! specials ^ specials ifNil: [ specials := self initializeSpecials ]! ! !MCFileTreeStCypressWriter class methodsFor: 'accessing' stamp: 'dkh 4/4/2012 15:05'! monticelloMetaDirName ^ 'monticello.meta'! ! !MCFileTreeStCypressWriter class methodsFor: 'initialization' stamp: 'dkh 07/07/2013 15:42:23'! initialize "self initialize" "force initialization of specials ..." specials := nil! ! !MCFileTreeStCypressWriter class methodsFor: 'private' stamp: 'PeterMcLain 10/02/2012 14:47'! initializeSpecials | map | map := Dictionary new. map at: $+ put: 'plus'; at: $- put: 'minus'; at: $= put: 'equals'; at: $< put: 'less'; at: $> put: 'more'; at: $% put: 'percent'; at: $& put: 'and'; at: $| put: 'pipe'; at: $* put: 'star'; at: $/ put: 'slash'; at: $\ put: 'backslash'; at: $~ put: 'tilde'; at: $? put: 'wat'; at: $, put: 'comma'; at: $@ put: 'at'. map keys do: [ :key | map at: (map at: key) put: key ]. ^ map ! ! !MCFileTreeStReader commentStamp: 'TorstenBergmann 2/20/2014 15:58'! A reader for Smalltalk code! !MCFileTreeStReader methodsFor: 'utilities' stamp: 'dkh 3/1/2012 12:18'! addClassAndMethodDefinitionsFromDirectory: aDirectory self addClassAndMethodDefinitionsFromDirectoryEntries: aDirectory entries! ! !MCFileTreeStReader class methodsFor: 'accessing' stamp: 'dkh 3/1/2012 12:04'! extension ^ 'tree'! ! !MCFileTreeStSnapshotReader commentStamp: 'TorstenBergmann 2/20/2014 15:55'! Snapshot reader! !MCFileTreeStSnapshotReader methodsFor: 'utilities' stamp: 'dkh 8/10/2012 14:03'! addClassAndMethodDefinitionsFromDirectory: aDirectory | snapshot classes entries extensions | snapshot := self fileUtils directoryFromPath: 'snapshot' relativeTo: aDirectory. classes := self fileUtils directoryFromPath: 'classes' relativeTo: snapshot. (self fileUtils directoryExists: classes) ifTrue: [ self addClassAndMethodDefinitionsFromDirectoryEntries: (entries := classes entries). "load .st files from subdirectories (*.class) of snapshot/classes ... class defintions" entries do: [ :classDirectoryEntry | | classDirectory | classDirectory := self fileUtils directoryFromEntry: classDirectoryEntry. self addClassAndMethodDefinitionsFromDirectoryEntries: classDirectory entries "load .st files from subdirectories (class or instance) of snapshot/classes/*.class ... method definitions" ] ]. extensions := self fileUtils directoryFromPath: 'extensions' relativeTo: snapshot. (self fileUtils directoryExists: extensions) ifTrue: [ extensions entries do: [ :classDirectoryEntry | | classDirectory | classDirectory := self fileUtils directoryFromEntry: classDirectoryEntry. self addClassAndMethodDefinitionsFromDirectoryEntries: classDirectory entries "load .st files from subdirectories (class or instance) of snapshot/extensions/*.class ... method definitions" ] ]! ! !MCFileTreeStSnapshotReader class methodsFor: 'accessing' stamp: 'dkh 3/1/2012 12:06'! extension ^ 'pkg'! ! !MCFileTreeStSnapshotWriter commentStamp: 'TorstenBergmann 2/20/2014 15:57'! Snapshot writer! !MCFileTreeStSnapshotWriter methodsFor: 'accessing' stamp: 'dkh 08/08/2013 19:02:56'! classTraitDefinitions classTraitDefinitions ifNil: [ classTraitDefinitions := Dictionary new ]. ^ classTraitDefinitions! ! !MCFileTreeStSnapshotWriter methodsFor: 'visiting' stamp: 'dkh 4/5/2012 11:15:15'! visitClassDefinition: definition orderedClassNames add: definition className. self classDefinitions at: definition className put: definition! ! !MCFileTreeStSnapshotWriter methodsFor: 'writing' stamp: 'dkh 4/5/2012 11:15:15'! writeClassDefinition: definition to: classPath self writeInDirectoryName: classPath fileName: definition className extension: '.st' visit: [ self writeClassDefinition: definition ]! ! !MCFileTreeStSnapshotWriter methodsFor: 'initialize-release' stamp: 'dkh 08/08/2013 18:34'! writeDefinitions: aCollection | basePath extensionClasses extensionMethodDefinitions methodHolders | self writeBasicDefinitions: aCollection. basePath := 'snapshot' , self fileUtils pathNameDelimiter asString , 'classes' , self fileUtils pathNameDelimiter asString. extensionClasses := OrderedCollection new. extensionMethodDefinitions := OrderedCollection new. methodHolders := self classDefinitions, self traitDefinitions. self methodDefinitions keysAndValuesDo: [ :className :extensionMethods | methodHolders at: className ifAbsent: [ extensionClasses add: className. extensionMethodDefinitions addAll: extensionMethods ] ]. extensionClasses do: [ :className | self methodDefinitions removeKey: className ]. self writeMethodHolderDefinitions: self traitDefinitions extension: '.trait' to: basePath do: [ :definition :classPath | self writeTraitDefinition: definition to: classPath. self classTraitDefinitions at: definition className ifPresent: [:classTraitDefinition | self writeClassTraitDefinition: classTraitDefinition to: classPath ] ]. self writeMethodHolderDefinitions: self classDefinitions extension: '.class' to: basePath do: [ :definition :classPath | self writeClassDefinition: definition to: classPath ]. basePath := 'snapshot' , self fileUtils pathNameDelimiter asString , 'extensions' , self fileUtils pathNameDelimiter asString. extensionMethodDefinitions do: [ :methodDefinition | | methodPath | methodPath := basePath , methodDefinition className , '.class' , self fileUtils pathNameDelimiter asString , (methodDefinition classIsMeta ifTrue: [ 'class' ] ifFalse: [ 'instance' ]) , self fileUtils pathNameDelimiter asString. self writeMethodDefinition: methodDefinition to: methodPath ] ! ! !MCFileTreeStSnapshotWriter methodsFor: 'as yet unclassified' stamp: 'topa 7/22/2013 13:54'! writeMethodHolderDefinitions: aCollection extension: extension to: basePath do: aBlock aCollection keysAndValuesDo: [ :className :definition | | classPath instanceMethodPath classMethodPath filenameMetaMap theMethodDefinitions | classPath := basePath , definition className , extension , self fileUtils pathNameDelimiter asString. aBlock value: definition value: classPath. instanceMethodPath := classPath , 'instance' , self fileUtils pathNameDelimiter asString. classMethodPath := classPath , 'class' , self fileUtils pathNameDelimiter asString. theMethodDefinitions := self methodDefinitions at: className ifAbsent: [ #() ]. filenameMetaMap := self fileNameMapFor: theMethodDefinitions. theMethodDefinitions do: [ :methodDefinition | | filename | filename := (filenameMetaMap at: methodDefinition classIsMeta) at: methodDefinition selector. methodDefinition classIsMeta ifTrue: [ self writeMethodDefinition: methodDefinition to: classMethodPath filename: filename ] ifFalse: [ self writeMethodDefinition: methodDefinition to: instanceMethodPath filename: filename ] ] ] ! ! !MCFileTreeStSnapshotWriter methodsFor: 'visiting' stamp: 'dkh 4/5/2012 11:15:15'! visitMethodDefinition: definition (self methodDefinitions at: definition className ifAbsent: [ self methodDefinitions at: definition className put: OrderedCollection new ]) add: definition! ! !MCFileTreeStSnapshotWriter methodsFor: 'writing' stamp: 'dkh 4/5/2012 11:15:15'! writeMethodDefinition: methodDefinition to: methodPath | filename | filename := self fileNameForSelector: methodDefinition selector. self writeInDirectoryName: methodPath fileName: filename extension: '.st' visit: [ self writeMethodDefinition: methodDefinition ]! ! !MCFileTreeStSnapshotWriter methodsFor: 'accessing' stamp: 'dkh 08/08/2013 19:02:56'! traitDefinitions traitDefinitions ifNil: [ traitDefinitions := Dictionary new ]. ^ traitDefinitions! ! !MCFileTreeStSnapshotWriter methodsFor: 'writing' stamp: 'dkh 08/08/2013 19:02:56'! writeClassTraitDefinition: definition to: traitPath self writeInDirectoryName: traitPath fileName: definition className, '_classTrait' extension: '.st' visit: [ self writeClassTraitDefinition: definition ]! ! !MCFileTreeStSnapshotWriter methodsFor: 'visiting' stamp: 'dkh 08/08/2013 19:02:56'! visitTraitDefinition: definition orderedTraitNames add: definition className. self traitDefinitions at: definition className put: definition! ! !MCFileTreeStSnapshotWriter methodsFor: 'accessing' stamp: 'dkh 4/5/2012 11:15:15'! methodDefinitions methodDefinitions ifNil: [ methodDefinitions := Dictionary new ]. ^ methodDefinitions! ! !MCFileTreeStSnapshotWriter methodsFor: 'visiting' stamp: 'dkh 08/08/2013 19:02:56'! visitClassTraitDefinition: definition orderedTraitNames add: definition className, ' classTrait'. self classTraitDefinitions at: definition className put: definition! ! !MCFileTreeStSnapshotWriter methodsFor: 'accessing' stamp: 'dkh 4/5/2012 11:15:15'! classDefinitions classDefinitions ifNil: [ classDefinitions := Dictionary new ]. ^ classDefinitions! ! !MCFileTreeStSnapshotWriter methodsFor: 'writing' stamp: 'dkh 08/08/2013 19:02:56'! writeTraitDefinition: definition to: traitPath self writeInDirectoryName: traitPath fileName: definition className extension: '.st' visit: [ self writeTraitDefinition: definition ]! ! !MCFileTreeStWriter commentStamp: 'TorstenBergmann 2/20/2014 15:58'! A writer for Smalltalk code! !MCFileTreeStWriter methodsFor: 'visiting' stamp: 'dkh 2/29/2012 14:55'! visitMethodDefinition: definition | filename directoryname | directoryname := definition classIsMeta ifTrue: [ definition className , '_class' ] ifFalse: [ definition className ]. filename := self fileNameForSelector: definition selector. self writeInDirectoryName: directoryname fileName: filename extension: '.st' visit: [ self writeMethodDefinition: definition ]! ! !MCFileTreeStWriter methodsFor: 'visiting' stamp: 'dkh 2/29/2012 14:52'! visitClassDefinition: definition orderedClassNames add: definition className. self writeInDirectoryName: definition className fileName: definition className extension: '.st' visit: [ self writeClassDefinition: definition ]! ! !MCFileTreeStWriter methodsFor: 'visiting' stamp: 'topa 7/22/2013 13:36'! visitClassTraitDefinition: definition orderedTraitNames add: definition className, ' classTrait'. self writeInDirectoryName: definition className fileName: definition className, '_classTrait' extension: '.st' visit: [ self writeClassTraitDefinition: definition ]! ! !MCFileTreeStWriter methodsFor: 'visiting' stamp: 'topa 7/22/2013 01:12'! visitTraitDefinition: definition orderedTraitNames add: definition className. self writeInDirectoryName: definition className fileName: definition className extension: '.st' visit: [ self writeTraitDefinition: definition ]! ! !MCFileTreeVersionInfoWriter commentStamp: 'TorstenBergmann 2/20/2014 16:23'! Write for the version info! !MCFileTreeVersionInfoWriter methodsFor: 'serialization' stamp: 'dkh 5/23/2013 21:16'! writeVersionInfo: aVersionInfo (self isWritten: aVersionInfo) ifTrue: [^ stream nextPutAll: '(id '; print: aVersionInfo id asString; nextPut: $) ]. stream nextPut: $(. #(name message id date time author) do: [:sel | stream nextPutAll: sel; space; print: (((aVersionInfo perform: sel) ifNil: ['']) asString ); space ]. stream nextPutAll: 'ancestors ('. aVersionInfo ancestors do: [:ea | self writeVersionInfo: ea]. stream nextPutAll: ') stepChildren ('. aVersionInfo stepChildren do: [:ea | self writeVersionInfo: ea]. stream nextPutAll: '))'. self wrote: aVersionInfo! ! !MCFileTreeWriter commentStamp: 'TorstenBergmann 2/20/2014 16:23'! Writer for the file tree! !MCFileTreeWriter methodsFor: 'writing' stamp: 'dkh 8/10/2012 07:14'! packageFileDirectory packageFileDirectory ifNil: [ packageFileDirectory := self fileUtils directoryFromPath: directory relativeTo: stream directory ]. ^ packageFileDirectory! ! !MCFileTreeWriter methodsFor: 'visiting' stamp: 'dkh 2/16/2012 14:49:00'! writeSnapshot: aSnapshot (self snapshotWriterClass on: self) writeDefinitions: aSnapshot definitions! ! !MCFileTreeWriter methodsFor: 'visiting' stamp: 'dkh 8/10/2012 14:01'! initializePackageFileDirectoryCache cachedPackageFileDirectoryEntries := Dictionary new. self packageFileDirectory entries do: [ :entry | entry isDirectory ifTrue: [ cachedPackageFileDirectoryEntries at: entry name put: (self fileUtils directoryFromEntry: entry) ] ]! ! !MCFileTreeWriter methodsFor: 'visiting' stamp: 'dkh 8/10/2012 14:51'! writeVersion: aVersion | members | directory := (members := MCFileTreeRepository parseName: aVersion info name) last. self deleteExistingPackageStructureFor: members. self fileUtils ensureDirectoryExists: self packageFileDirectory. self initializePackageFileDirectoryCache. super writeVersion: aVersion! ! !MCFileTreeWriter methodsFor: 'writing' stamp: 'dkh 07/07/2013 22:10'! repository ^ stream! ! !MCFileTreeWriter methodsFor: 'writing' stamp: 'dkh 8/10/2012 05:26'! addString: string at: fileNameOrPath "fileNameOrPath may have one or two elements" | utils fullPath path | utils := MCFileTreeFileUtils current. path := MCFileTreePackageStructureStWriter useCypressWriter ifTrue: [ fullPath := utils buildPathFrom: {(MCFileTreeStCypressWriter monticelloMetaDirName). fileNameOrPath}. utils ensureFilePathExists: fullPath relativeTo: self packageFileDirectory. fullPath ] ifFalse: [ fileNameOrPath ]. string isEmpty ifFalse: [ utils writeStreamFor: path in: self packageFileDirectory do: [ :file | file nextPutAll: string ] ]! ! !MCFileTreeWriter methodsFor: 'visiting' stamp: 'dkh 8/10/2012 07:16'! subPackageFileDirectoryFor: directoryNameOrPath ^ cachedPackageFileDirectoryEntries at: directoryNameOrPath ifAbsentPut: [ | dir | dir := self fileUtils directoryFromPath: directoryNameOrPath relativeTo: self packageFileDirectory. self fileUtils ensureDirectoryExists: dir. dir ]! ! !MCFileTreeWriter methodsFor: 'visiting' stamp: 'dkh 8/10/2012 07:12'! deleteExistingPackageStructureFor: members "destroy .tree and .pkg directory structure .. otherwise it won't be pretty" | alternateDirName alternateDir packageDirectoryName | (self fileUtils directoryExists: self packageFileDirectory) ifTrue: [ self fileUtils deleteAll: self packageFileDirectory ]. packageDirectoryName := self fileUtils directoryName: self packageFileDirectory. alternateDirName := (packageDirectoryName endsWith: '.pkg') ifTrue: [ members first , '.tree' ] ifFalse: [ (packageDirectoryName endsWith: '.tree') ifTrue: [ members first , '.pkg' ] ifFalse: [ (packageDirectoryName endsWith: '.package') ifTrue: [ members first , '.pkg' ] ] ]. alternateDirName ifNotNil: [ alternateDir := self fileUtils directoryFromPath: alternateDirName relativeTo: stream directory. (self fileUtils directoryExists: alternateDir) ifTrue: [ self fileUtils deleteAll: alternateDir ] ]! ! !MCFileTreeWriter methodsFor: 'serializing' stamp: 'dkh 07/07/2013 15:42:23'! serializeVersionInfo: aVersionInfo infoWriter ifNil: [infoWriter := MCFileTreeVersionInfoWriter new]. ^ String streamContents: [:s | infoWriter stream: s. infoWriter writeVersionInfo: aVersionInfo]! ! !MCFileTreeWriter methodsFor: 'writing' stamp: 'dkh 2/16/2012 14:49:00'! flush ! ! !MCFileTreeWriter methodsFor: 'accessing' stamp: 'dkh 2/29/2012 13:59'! snapshotWriterClass ^ MCFileTreeAbstractStWriter! ! !MCFileTreeWriter methodsFor: 'writing' stamp: 'ChristopheDemarey 8/21/2013 16:56'! addString: string at: fileNameOrPath encodedTo: ignored "fileNameOrPath may have one or two elements" "encodeTo: arg, because FileTree uses UTF8 by default" | utils fullPath path | utils := MCFileTreeFileUtils current. path := MCFileTreePackageStructureStWriter useCypressWriter ifTrue: [ fullPath := utils buildPathFrom: {(MCFileTreeStCypressWriter monticelloMetaDirName). fileNameOrPath}. utils ensureFilePathExists: fullPath relativeTo: self packageFileDirectory. fullPath ] ifFalse: [ fileNameOrPath ]. string isEmpty ifFalse: [ utils writeStreamFor: path in: self packageFileDirectory do: [ :file | file nextPutAll: string ] ]! ! !MCFileTreeWriter methodsFor: 'accessing' stamp: 'dkh 8/10/2012 07:05'! fileUtils ^ MCFileTreeFileUtils current! ! !MCFileTreeWriter class methodsFor: 'accessing' stamp: 'dkh 3/1/2012 13:09'! readerClass "don't expect this message to be sent" self shouldNotImplement! ! !MCFilteredVersionSorter commentStamp: 'TorstenBergmann 2/6/2014 08:10'! Sort filtered versions ! !MCFilteredVersionSorter methodsFor: 'adding' stamp: 'bf 5/28/2005 01:14'! addVersionInfo: aVersionInfo (aVersionInfo hasAncestor: target) ifTrue: [super addVersionInfo: aVersionInfo] ! ! !MCFilteredVersionSorter methodsFor: 'private' stamp: 'MarianoMartinezPeck 12/25/2009 23:08'! processVersionInfo: aVersionInfo | success | aVersionInfo = target ifTrue: [^ true]. (aVersionInfo hasAncestor: target) ifFalse: [^false]. self pushLayer. success := (self knownAncestorsOf: aVersionInfo) anySatisfy: [:ea | self processVersionInfo: ea]. self popLayer. success ifTrue: [self addToCurrentLayer: aVersionInfo]. ^ success ! ! !MCFilteredVersionSorter methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! target: aVersionInfo target := aVersionInfo! ! !MCFrontier commentStamp: 'TorstenBergmann 2/5/2014 13:49'! Utility class! !MCFrontier methodsFor: 'initialization' stamp: 'avi 9/17/2005 22:11'! frontier: f bag: remaining frontier := f asOrderedCollection. bag := remaining! ! !MCFrontier methodsFor: 'advancing' stamp: 'avi 9/17/2005 22:02'! removeAll: collection collection do: [ :n | self remove: n]! ! !MCFrontier methodsFor: 'advancing' stamp: 'avi 9/17/2005 22:13'! remove: aVersionInfo frontier remove: aVersionInfo. aVersionInfo ancestors do: [ :ancestor | bag remove: ancestor. (bag occurrencesOf: ancestor) = 0 ifTrue: [frontier add: ancestor]]. ^aVersionInfo! ! !MCFrontier methodsFor: 'accessing' stamp: 'avi 9/17/2005 22:02'! frontier ^frontier! ! !MCFrontier class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'! frontierOnAll: aCollection | remaining allVersions | remaining := Bag new. allVersions := (aCollection gather: [:ea | ea withBreadthFirstAncestors]) asSet. allVersions do: [:ea | remaining addAll: ea ancestors]. ^self new frontier: aCollection bag: remaining! ! !MCFrontier class methodsFor: 'instance creation' stamp: 'avi 9/17/2005 22:07'! frontierOn: aVersionInfo and: otherVersionInfo ^ self frontierOnAll: (Array with: aVersionInfo with: otherVersionInfo)! ! !MCFrontier class methodsFor: 'instance creation' stamp: 'avi 9/17/2005 22:07'! frontierOn: aVersionInfo ^ self frontierOnAll: (Array with: aVersionInfo)! ! !MCFtpRepository commentStamp: ''! I am an monticello repository implementation for the FTP protocol.! !MCFtpRepository methodsFor: 'required' stamp: 'avi 9/17/2003 12:52'! description ^ 'ftp://', user, '@', host, '/', directory! ! !MCFtpRepository methodsFor: 'required' stamp: 'stephaneducasse 2/4/2006 20:47'! writeStreamForFileNamed: aString replace: ignoreBoolean do: aBlock | stream | stream := RWBinaryOrTextStream on: String new. aBlock value: stream. self clientDo: [:client | client binary. client putFileStreamContents: stream reset as: aString]! ! !MCFtpRepository methodsFor: '*metacello-testsplatform' stamp: 'dkh 6/12/2012 10:19:43.983'! directory ^directory! ! !MCFtpRepository methodsFor: 'interface' stamp: 'CamilloBruni 3/2/2012 13:02'! loadAllFileNames ^ self clientDo: [:client | self parseDirectoryListing: client getDirectory]! ! !MCFtpRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! password: passwordString password := passwordString! ! !MCFtpRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! directory: dirPath directory := dirPath! ! !MCFtpRepository methodsFor: 'enumerating' stamp: 'stephaneducasse 2/4/2006 20:47'! clientDo: aBlock | client | client := FTPClient openOnHostNamed: host. client loginUser: user password: password. directory isEmpty ifFalse: [client changeDirectoryTo: directory]. ^ [aBlock value: client] ensure: [client close]! ! !MCFtpRepository methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/22/2013 16:18'! isRemote ^ true! ! !MCFtpRepository methodsFor: 'parsing' stamp: 'stephaneducasse 2/4/2006 20:47'! parseDirectoryListing: aString | stream files line tokens | stream := aString readStream. files := OrderedCollection new. [stream atEnd] whileFalse: [line := stream nextLine. tokens := line findTokens: ' '. tokens size > 2 ifTrue: [files add: tokens last]]. ^ files! ! !MCFtpRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! host: hostname host := hostname! ! !MCFtpRepository methodsFor: 'required' stamp: 'nice 1/5/2010 15:59'! readStreamForFileNamed: aString do: aBlock ^ self clientDo: [:client | | stream | client binary. stream := RWBinaryOrTextStream on: String new. stream nextPutAll: (client getFileNamed: aString). aBlock value: stream reset]! ! !MCFtpRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! user: userString user := userString! ! !MCFtpRepository methodsFor: '*metacello-pharocommonplatform' stamp: 'dkh 4/30/2013 13:26'! asRepositorySpecFor: aMetacelloMCProject | dir | dir := directory. (directory at: 1) = $/ ifFalse: [ dir := '/', dir ]. ^(aMetacelloMCProject repositorySpec) description: 'ftp://', host, dir; type: 'ftp'; username: user; password: password; yourself! ! !MCFtpRepository methodsFor: '*metacello-testsplatform' stamp: 'dkh 6/12/2012 10:19:43.983'! host ^host! ! !MCFtpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:02'! fillInTheBlankRequest ^ 'FTP Repository:' ! ! !MCFtpRepository class methodsFor: 'accessing' stamp: 'avi 9/16/2003 13:57'! description ^ 'FTP'! ! !MCFtpRepository class methodsFor: 'instance creation' stamp: 'avi 9/16/2003 13:57'! host: host directory: directory user: user password: password ^ self new host: host; directory: directory; user: user; password: password! ! !MCFtpRepository class methodsFor: 'accessing' stamp: 'avi 9/16/2003 13:57'! creationTemplate ^ 'MCFtpRepository host: ''modules.squeakfoundation.org'' directory: ''mc'' user: ''squeak'' password: ''squeak''' ! ! !MCFtpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:02'! morphicConfigure ^ self fillInTheBlankConfigure! ! !MCFtpRepository class methodsFor: 'accessing' stamp: 'bkv 2/18/2004 20:38'! templateCreationSelector ^ #host:directory:user:password: ! ! !MCGemstoneRepository commentStamp: 'CamilloBruni 2/8/2012 18:10'! An explicit subclass of MCHttpRepository to provide a template for gemstone repositories.! !MCGemstoneRepository methodsFor: 'interface' stamp: 'CamilloBruni 4/23/2012 20:22'! includesVersionNamed: aString "directly do a filename check since squeaksource only stores mcz" ^ self includesFileNamed: aString, '.mcz'! ! !MCGemstoneRepository methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/23/2013 13:24'! koRemote ^ KomitGemstoneRemote new remote: self; yourself! ! !MCGemstoneRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 6/26/2013 13:37'! baseURL ^ 'http://ss3.gemtalksystems.com/ss/'! ! !MCGemstoneRepository class methodsFor: 'testing' stamp: 'CamilloBruni 6/26/2013 13:37'! isResponsibleFor: aUrl ^ (aUrl includesSubstring: 'ss3.gemstone.com/') or: [ aUrl includesSubstring: 'ss3.gemtalksystems.com/' ]! ! !MCGemstoneRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 2/8/2012 18:12'! description ^ 'ss3.gemstone.com'! ! !MCGitHubRepository methodsFor: 'initialize-release' stamp: 'dkh 08/22/2013 07:40'! hasNoLoadConflicts: anMCGitHubRepository (anMCGitHubRepository isKindOf: self class) ifFalse: [ ^ false ]. ^ self projectPath = anMCGitHubRepository projectPath and: [ self repoPath = anMCGitHubRepository repoPath ]! ! !MCGitHubRepository methodsFor: 'descriptions' stamp: 'dkh 5/16/2012 14:52:41'! description | desc | desc := self class description , self projectPath , ':' , self projectVersion. self repoPath ifNil: [ ^ desc ]. ^ desc , '/' , self repoPath! ! !MCGitHubRepository methodsFor: 'comparing' stamp: 'dkh 6/16/2012 08:57'! hash ^ self description hash! ! !MCGitHubRepository methodsFor: 'accessing' stamp: 'dkh 5/16/2012 14:52:41'! repoPath: anObject repoPath := anObject! ! !MCGitHubRepository methodsFor: 'initialize-release' stamp: 'dkh 7/24/2012 21:52'! flushForScriptGet self class flushProjectEntry: self projectPath version: self projectVersion. directory := nil! ! !MCGitHubRepository methodsFor: 'descriptions' stamp: 'dkh 6/16/2012 09:03'! directoryDescription ^ self directory pathName! ! !MCGitHubRepository methodsFor: 'accessing' stamp: 'dkh 07/01/2013 13:23'! directory directory ifNil: [ directory := self class projectDirectoryFrom: self projectPath version: self projectVersion. self repoPath ifNotNil: [ directory := MetacelloPlatform current directoryFromPath: self repoPath relativeTo: directory ] ] ifNotNil: [ (MCFileTreeFileUtils current directoryExists: directory) ifFalse: [ self flushCache. ^ self directory ] ]. ^ directory! ! !MCGitHubRepository methodsFor: 'accessing' stamp: 'dkh 5/16/2012 14:52:41'! projectVersion (projectVersion == nil or: [ projectVersion isEmpty ]) ifTrue: [ projectVersion := 'master' ]. ^ projectVersion! ! !MCGitHubRepository methodsFor: 'initialize-release' stamp: 'dkh 6/16/2012 09:09'! initialize super initialize. directory := nil. "we'll lazily create the directory instance" self readonly: true! ! !MCGitHubRepository methodsFor: 'accessing' stamp: 'dkh 5/16/2012 14:52:41'! projectPath: anObject projectPath := anObject! ! !MCGitHubRepository methodsFor: 'accessing' stamp: 'dkh 5/16/2012 14:52:41'! metacelloProjectClassFor: aScriptEngine ^ MetacelloMCBaselineProject! ! !MCGitHubRepository methodsFor: 'accessing' stamp: 'dkh 5/16/2012 14:52:41'! projectPath ^ projectPath! ! !MCGitHubRepository methodsFor: 'initialize-release' stamp: 'dkh 6/16/2012 09:11'! flushCache "the directory acts like a cache since we download the directory from github" super flushCache. self class flushDownloadCache. directory := nil! ! !MCGitHubRepository methodsFor: 'accessing' stamp: 'dkh 5/16/2012 14:52:41'! asRepositorySpecFor: aMetacelloMCProject ^ aMetacelloMCProject repositorySpec description: self description; type: 'github'; yourself! ! !MCGitHubRepository methodsFor: 'testing' stamp: 'dkh 6/16/2012 09:00'! isValid ^ true! ! !MCGitHubRepository methodsFor: 'accessing' stamp: 'dkh 5/16/2012 14:52:41'! projectVersion: anObject projectVersion := anObject! ! !MCGitHubRepository methodsFor: 'accessing' stamp: 'dkh 5/16/2012 14:52:41'! repoPath ^ repoPath! ! !MCGitHubRepository class methodsFor: 'accessing' stamp: 'dkh 7/24/2012 21:50'! downloadCacheKey: projectPath version: versionString ^ projectPath , ':::' , versionString! ! !MCGitHubRepository class methodsFor: 'private' stamp: 'ChristopheDemarey 4/29/2013 15:24'! cacheDirectoryFor: projectPath | cacheDirectory projectDirectory | cacheDirectory := self cacheDirectory. projectDirectory := MetacelloPlatform current directoryFromPath: projectPath relativeTo: cacheDirectory. MetacelloPlatform current ensureDirectoryExists: projectDirectory. ^ projectDirectory! ! !MCGitHubRepository class methodsFor: 'accessing' stamp: 'dkh 6/16/2012 08:29'! downloadCache DownloadCache ifNil: [ DownloadCache := Dictionary new ]. ^ DownloadCache! ! !MCGitHubRepository class methodsFor: 'accessing' stamp: 'dkh 5/16/2012 14:52:41'! description ^ 'github://'! ! !MCGitHubRepository class methodsFor: 'instance creation' stamp: 'dkh 5/16/2012 14:52:41'! location: locationUrl ^ self location: locationUrl version: nil! ! !MCGitHubRepository class methodsFor: 'accessing' stamp: 'dkh 5/16/2012 14:52:41'! isAbstract "abstract as far as creating new repositories interactively? yes" ^ true! ! !MCGitHubRepository class methodsFor: 'private' stamp: 'dkh 5/16/2012 14:52:41'! parseLocation: locationUrl version: versionString "self parseLocation: 'github://dalehenrich/MetacelloRepository:master/monticello/repos/itory/path' version: nil " | projectPath projectVersion repoPath headerSize desc projectDelim repoDelim versionDelim | headerSize := 'github://' size. desc := locationUrl. desc := desc copyFrom: headerSize + 1 to: desc size. projectVersion := repoPath := nil. projectDelim := desc indexOf: $/. repoDelim := desc indexOf: $/ startingAt: projectDelim + 1. (versionDelim := desc indexOf: $:) == 0 ifTrue: [ repoDelim == 0 ifTrue: [ projectPath := desc ] ifFalse: [ projectPath := desc copyFrom: 1 to: repoDelim - 1. repoPath := desc copyFrom: repoDelim + 1 to: desc size ] ] ifFalse: [ projectPath := desc copyFrom: 1 to: versionDelim - 1. repoDelim == 0 ifTrue: [ projectVersion := desc copyFrom: versionDelim + 1 to: desc size ] ifFalse: [ projectVersion := desc copyFrom: versionDelim + 1 to: repoDelim - 1. repoPath := desc copyFrom: repoDelim + 1 to: desc size ] ]. versionString ~~ nil ifTrue: [ projectVersion := versionString ]. ^ self new projectPath: projectPath; projectVersion: projectVersion; repoPath: repoPath; yourself ! ! !MCGitHubRepository class methodsFor: 'initialization' stamp: 'dkh 6/16/2012 08:25'! flushDownloadCache "self flushDownloadCache" DownloadCache := nil! ! !MCGitHubRepository class methodsFor: 'private' stamp: 'dkh 07/12/2013 11:36'! cacheDirectory: aDirectory "explicitly set CacheDirectory" CacheDirectory := aDirectory! ! !MCGitHubRepository class methodsFor: 'utility' stamp: 'dkh 07/01/2013 08:48'! projectDirectoryFrom: projectPath version: versionString | mcPlatform githubCacheDirectory projectDirectory downloadCacheKey cachePath | downloadCacheKey := self downloadCacheKey: projectPath version: versionString. mcPlatform := MetacelloPlatform current. githubCacheDirectory := mcPlatform directoryFromPath: versionString relativeTo: (self cacheDirectoryFor: projectPath). cachePath := self downloadCache at: downloadCacheKey ifAbsent: [ ]. (cachePath isNil or: [ (projectDirectory := mcPlatform directoryFromPath: cachePath relativeTo: githubCacheDirectory) exists not ]) ifTrue: [ | url archive directory zipFileName | MetacelloScriptGitHubDownloadNotification new projectPath: projectPath; versionString: versionString; signal. "for testing purposes" mcPlatform ensureDirectoryExists: githubCacheDirectory. url := 'https://github.com/' , projectPath , '/zipball/' , versionString. zipFileName := '/tmp/github-' , (downloadCacheKey select: [ :c | c isAlphaNumeric ]) , '.zip'. archive := MetacelloPlatform current downloadFile: url to: zipFileName. directory := mcPlatform directoryFromPath: (cachePath := archive members first fileName) relativeTo: githubCacheDirectory. directory exists ifFalse: [ MetacelloPlatform current extractRepositoryFrom: zipFileName to: githubCacheDirectory fullName ]. self downloadCache at: downloadCacheKey put: cachePath. projectDirectory := mcPlatform directoryFromPath: cachePath relativeTo: githubCacheDirectory ]. ^ projectDirectory! ! !MCGitHubRepository class methodsFor: 'initialization' stamp: 'dkh 07/12/2013 11:52'! initialize "self initialize" Smalltalk addToStartUpList: self. self flushDownloadCache. self resetCacheDirectoryIfInvalid! ! !MCGitHubRepository class methodsFor: 'private' stamp: 'dkh 07/12/2013 11:36'! defaultCacheDirectory | defaultDirectory cacheDirectory | defaultDirectory := MetacelloPlatform current defaultDirectory. cacheDirectory := MetacelloPlatform current directoryFromPath: 'github-cache' relativeTo: defaultDirectory. MetacelloPlatform current ensureDirectoryExists: cacheDirectory. ^ cacheDirectory! ! !MCGitHubRepository class methodsFor: 'private' stamp: 'dkh 07/12/2013 11:51'! resetCacheDirectoryIfInvalid "Reset if invalid" CacheDirectory notNil and: [ (MCFileTreeFileUtils current directoryExists: CacheDirectory) ifFalse: [ CacheDirectory := nil ] ]! ! !MCGitHubRepository class methodsFor: 'private' stamp: 'dkh 07/12/2013 11:52'! cacheDirectory self resetCacheDirectoryIfInvalid. CacheDirectory ifNil: [ CacheDirectory := self defaultCacheDirectory ]. ^ CacheDirectory! ! !MCGitHubRepository class methodsFor: 'instance creation' stamp: 'dkh 6/16/2012 09:08'! location: locationUrl version: versionString ^ self parseLocation: locationUrl version: versionString! ! !MCGitHubRepository class methodsFor: 'utility' stamp: 'dkh 7/24/2012 21:50'! flushProjectEntry: projectPath version: versionString self downloadCache removeKey: (self downloadCacheKey: projectPath version: versionString) ifAbsent: [ ]! ! !MCGitHubRepository class methodsFor: 'system startup' stamp: 'dkh 6/16/2012 08:24'! startUp: resuming "Flush the GitHub download cache" resuming ifTrue: [ self flushDownloadCache ]! ! !MCHttpRepository commentStamp: ''! I am general http repository for monticello. I support the general protocol for listing files in a remote repository.! !MCHttpRepository methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! versionReaderForFileNamed: aString readerCache ifNil: [readerCache := Dictionary new]. ^ readerCache at: aString ifAbsent: [self resizeCache: readerCache. super versionReaderForFileNamed: aString do: [:r | r ifNotNil: [readerCache at: aString put: r]]] ! ! !MCHttpRepository methodsFor: 'i/o' stamp: 'SeanDeNigris 6/20/2012 23:28'! displayProgress: label during: workBlock | nextUpdateTime | nextUpdateTime := 0. ^UIManager default displayProgress: label from: 0.0 to: 1.0 during:[:bar| [workBlock value] on: HTTPProgress do:[:ex| (ex total == nil or: [ex amount == nil]) ifFalse:[ (nextUpdateTime < Time millisecondClockValue or:[ex total = ex amount]) ifTrue:[ bar current: ex amount asFloat / ex total asFloat. nextUpdateTime := Time millisecondClockValue + 100. ]. ]. ex resume. ] ]. ! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2012 17:24'! description ^ self location! ! !MCHttpRepository methodsFor: 'converting' stamp: 'CamilloBruni 9/14/2012 17:24'! asCreationTemplate ^self class creationTemplateLocation: self location user: user password: password! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! location: aUrlString location := aUrlString! ! !MCHttpRepository methodsFor: '*keychain' stamp: 'BenjaminVanRyseghem 10/25/2012 14:53'! keyChainGroupSelector ^ #monticelloDefault! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 18:35'! project "Return a project name" ^ (self location splitOn: $/) last! ! !MCHttpRepository methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/22/2013 16:24'! isPrivatePharoRepository ^ self class pharoLocations includes: self location! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2013 23:21'! user self userAndPasswordFromSettingsDo: [:usr :pwd | ^usr]. "not in settings" user isEmptyOrNil ifFalse: [ ^user ]. #UserManager asClassIfPresent: [ :userManager | (userManager default currentUser userNamePasswordFor: self keyChainGroupSelector) ifNotNil: [ :usr | ^ usr username ]]. ^ ''! ! !MCHttpRepository methodsFor: 'actions' stamp: 'SvenVanCaekenberghe 10/27/2013 12:19'! parseFileNamesFromStream: aStream | names fullName | names := OrderedCollection new. [aStream atEnd] whileFalse: [[aStream upTo: $<. {$a. $A. nil} includes: aStream next] whileFalse. aStream upTo: $". aStream atEnd ifFalse: [ fullName := aStream upTo: $". names add: fullName urlDecoded ]]. ^ names! ! !MCHttpRepository methodsFor: 'i/o' stamp: 'CamilloBruni 6/15/2013 10:13'! loadAllFileNames | client | self displayProgress: 'Loading all file names from ', self description during: [ client := self httpClient. client ifFail: [ :exception | (exception className beginsWith: 'Zn') ifTrue: [ MCRepositoryError signal: 'Could not access ', self location, ': ', exception printString ] ifFalse: [ exception pass ] ]; url: self locationWithTrailingSlash; queryAt: 'C' put: 'M;O=D'; "legacy that some servers maybe expect" get. self assertNonBinaryResponse: client response ]. ^ self parseFileNamesFromStream: client contents readStream! ! !MCHttpRepository methodsFor: 'actions' stamp: 'CamilloBruni 9/14/2012 17:24'! locationWithTrailingSlash ^ (self location endsWith: '/') ifTrue: [self location] ifFalse: [self location, '/']! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! user: userString user := userString! ! !MCHttpRepository methodsFor: 'i/o' stamp: 'EstebanLorenzano 4/25/2013 10:50'! readStreamForFileNamed: aString do: aBlock | client | self displayProgress: 'Downloading ', aString during: [ client := self httpClient. client ifFail: [ :exception | self error: 'Could not load ', aString, ': ', exception printString ]; get: (self urlForFileNamed: aString). self assertBinaryResponse: client response. "immediately cache the version and avoid an unnecessary serialization" self cacheRawVersionNamed: aString stream: client contents ]. ^ aBlock value: client contents readStream! ! !MCHttpRepository methodsFor: 'private' stamp: 'SeanDeNigris 8/27/2012 12:05'! assertNonBinaryResponse: response response contentType isBinary ifTrue: [ MCRepositoryError signal: 'Did not expect a binary response but got ', response contentType printString ].! ! !MCHttpRepository methodsFor: 'private' stamp: 'CamilloBruni 9/18/2013 14:17'! httpClient "Return a new, specifically configured instance of the HTTP client for internal use. Note how we request GZIP compression and will signal progress." ^ ZnClient new systemPolicy; beOneShot; username: self user password: self password; signalProgress: true; yourself! ! !MCHttpRepository methodsFor: 'i/o' stamp: 'CamilloBruni 4/11/2013 17:22'! handleUnsuccessfulResponse: aZnResponse (#(403 401) includes: aZnResponse code) ifTrue: [ MCPermissionDenied signalFor: self ]. Error signal: 'Could not save version.'! ! !MCHttpRepository methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/30/2013 20:22'! koRemote ^ KomitHttpRemote new remote: self; yourself! ! !MCHttpRepository methodsFor: 'i/o' stamp: 'CamilloBruni 4/11/2013 17:19'! writeStreamForFileNamed: aString replace: ignoreBoolean do: aBlock | entity | entity := self entityStreamContents: aBlock. self displayProgress: 'Uploading ', aString during: [ self httpClient entity: entity; ifFail: [ :exception | (exception isKindOf: ZnHttpUnsuccessful) ifTrue: [ ^ self handleUnsuccessfulResponse: exception response ]. self error: 'Could not save ', aString, ': ', exception printString ]; url: (self urlForFileNamed: aString); put ]! ! !MCHttpRepository methodsFor: 'private' stamp: 'SeanDeNigris 8/27/2012 12:09'! assertBinaryResponse: response response contentType isBinary ifFalse: [ MCRepositoryError signal: 'Expected a binary response instead of ', response contentType printString ].! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:42'! credentials ^ MCServerCredentials user: self user password: self password! ! !MCHttpRepository methodsFor: 'actions' stamp: 'CamilloBruni 5/1/2013 22:51'! password self userAndPasswordFromSettingsDo: [:usr :pwd | ^pwd]. self user isEmpty ifTrue: [^password ifNil: ['']]. password isEmptyOrNil ifTrue: [ password := (UserManager default currentUser userNamePasswordFor: self keyChainGroupSelector) ifNil: [ '' ] ifNotNil: [:usr | usr password ]]. password isEmptyOrNil ifTrue: [ | answer | user isEmptyOrNil ifTrue: [ "Give the user a chance to change the login" answer := UIManager default request: 'User name for ', String cr, location initialAnswer: ''. answer isEmptyOrNil ifTrue: [^password] ifFalse: [self user: answer] ]. password := UIManager default requestPassword: 'Password for "', self user, '" at ', String cr, self location. "The user doesn't care about logging into this repo. Clear the username so they will not be prompted every time" password isEmptyOrNil ifTrue: [ user := '' ]. ]. ^ password! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2012 17:24'! location ^ location! ! !MCHttpRepository methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! versionReaderForFileNamed: aString do: aBlock ^ (self versionReaderForFileNamed: aString) ifNotNil: aBlock! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:45'! credentials: mcServerCredentials self user: mcServerCredentials username. self password: mcServerCredentials password.! ! !MCHttpRepository methodsFor: 'i/o' stamp: 'SeanDeNigris 7/17/2012 15:50'! cacheRawVersionNamed: aString stream: contents "directly forward the contents to the cache repository. this avoids and unnecessary serialization step" MCCacheRepository uniqueInstance writeStreamForFileNamed: aString replace: true do: [ :s| s nextPutAll: contents ]! ! !MCHttpRepository methodsFor: 'actions' stamp: 'SvenVanCaekenberghe 10/27/2013 11:46'! urlForFileNamed: aString ^ self locationWithTrailingSlash, aString urlEncoded! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! password: passwordString password := passwordString! ! !MCHttpRepository methodsFor: 'actions' stamp: 'CamilloBruni 9/14/2012 17:25'! userAndPasswordFromSettingsDo: aBlock "The mcSettings file in ExternalSettings preferenceDirectory should contain entries for each account: account1: *myhost.mydomain* user:password account2: *otherhost.mydomain/somerep* dXNlcjpwYXNzd29yZA== That is it must start with 'account', followed by anything to distinguish accounts, and a colon. Then comes a match expression for the repository url, and after a space the user:password string. To not have the clear text password on your disc, you can base64 encode it: (Base64MimeConverter mimeEncode: 'user:password' readStream) contents " Settings ifNotNil: [ Settings keysAndValuesDo: [:key :value | | entry userAndPassword | (key asLowercase beginsWith: 'account') ifTrue: [ entry := value findTokens: ' '. (entry first match: self location) ifTrue: [ userAndPassword := entry second. (userAndPassword includes: $:) ifFalse: [ userAndPassword := (Base64MimeConverter mimeDecodeToChars: userAndPassword readStream) contents]. userAndPassword := userAndPassword findTokens: $:. ^aBlock value: userAndPassword first value: userAndPassword second ] ] ] ]. ^nil! ! !MCHttpRepository methodsFor: 'actions' stamp: 'al 12/12/2005 11:06'! flushCache super flushCache. readerCache := nil.! ! !MCHttpRepository methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/22/2013 16:28'! isRemote ^ self isPrivatePharoRepository not! ! !MCHttpRepository methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! asRepositorySpecFor: aMetacelloMCProject ^(aMetacelloMCProject repositorySpec) description: self description; type: 'http'; yourself! ! !MCHttpRepository methodsFor: 'private' stamp: 'SvenVanCaekenberghe 6/5/2012 21:54'! entityStreamContents: aBlock "Generate output in a buffer because we need the length" | stream | stream := RWBinaryOrTextStream on: String new. aBlock value: stream. stream reset. ^ (ZnStreamingEntity type: ZnMimeType applicationOctetStream) stream: stream; contentLength: stream size; yourself! ! !MCHttpRepository class methodsFor: 'instance creation' stamp: 'MarcusDenker 3/22/2013 12:42'! inboxRepository ^ self location: 'http://smalltalkhub.com/mc/Pharo/Pharo30Inbox/main'.! ! !MCHttpRepository class methodsFor: 'accessing' stamp: 'ab 7/24/2003 21:20'! description ^ 'HTTP'! ! !MCHttpRepository class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/7/2013 14:34'! location: location ^ MCServerRegistry uniqueInstance repositoryAt: location credentialsDo: [ :username :password | (self repositoryClassFor: location) new location: location; user: username; password: password; yourself ]! ! !MCHttpRepository class methodsFor: 'instance creation' stamp: 'CamilloBruni 10/21/2012 13:26'! project: aProjectIdentifier ^ self location: self baseURL, aProjectIdentifier! ! !MCHttpRepository class methodsFor: 'creation template' stamp: 'CamilloBruni 2/15/2012 15:21'! creationTemplateLocation: location user: user password: password ^ self name, ' location: {1} user: {2} password: {3}' format: {location printString. user printString. password printString}! ! !MCHttpRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 10/21/2012 13:25'! baseURL ^ ''! ! !MCHttpRepository class methodsFor: 'testing' stamp: 'CamilloBruni 4/6/2013 23:04'! isResponsibleFor: aURLString "Override in subclasses to enable custom instances for certain URLs" ^ true! ! !MCHttpRepository class methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/22/2013 16:27'! pharoLocations "Answer the locations for both pharo and pharo inbox repositories. No commit should actually be pushed directly there" ^ #('http://smalltalkhub.com/mc/Pharo/Pharo30/main' 'http://smalltalkhub.com/mc/Pharo/Pharo30/main/' 'http://smalltalkhub.com/mc/Pharo/Pharo30Inbox/main' 'http://smalltalkhub.com/mc/Pharo/Pharo30Inbox/main/')! ! !MCHttpRepository class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/26/2012 18:22'! location: aUrl user: user password: password | result | result := self location: aUrl. user ifNotEmpty: [ result user: user; password: password ]. ^ result.! ! !MCHttpRepository class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/6/2013 23:33'! repositoryClassFor: location MCHttpRepository subclassesDo: [ :subclass | (subclass isResponsibleFor: location) ifTrue: [ ^ subclass ]]. ^ MCHttpRepository! ! !MCHttpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:00'! fillInTheBlankRequest ^ 'HTTP Repository:' ! ! !MCHttpRepository class methodsFor: 'creation template' stamp: 'CamilloBruni 10/21/2012 13:24'! creationTemplate ^self creationTemplateLocation: self baseURL user: '' password: '' ! ! !MCHttpRepository class methodsFor: 'initialization' stamp: 'bf 7/28/2005 19:44'! clearPasswords self allSubInstancesDo: [:ea | ea password: '']. ! ! !MCHttpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:01'! morphicConfigure ^ self fillInTheBlankConfigure! ! !MCInstanceVariableDefinition commentStamp: ''! A MCInstanceVariableDefinition represents an instance variable definition.! !MCInstanceVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:32'! isInstanceVariable ^ true! ! !MCInstanceVariableDefinition class methodsFor: 'accessing' stamp: 'cwp 7/7/2003 22:59'! type ^ #instance! ! !MCKomitSubmitter commentStamp: ''! I am a class dedicated to the transformation of a Komit object into a MCCommit and its submission! !MCKomitSubmitter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 13:18'! submitCommit: aKomit MCSaveVersionDialog addAsLastLogMessage: aKomit message asString. aKomit commitOn: self ! ! !MCKomitSubmitter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/29/2013 13:51'! storeDependencies: newVersion for: aKomit self retryOnCredentialRequest: [ aKomit repository storeDependencies: newVersion ] for: aKomit repository! ! !MCKomitSubmitter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/29/2013 13:50'! retryOnCredentialRequest: aBlock for: aRepository aBlock on: MCPermissionDenied do: [ :error | |credentials| credentials := MCCredentialsRequest signalUrl: aRepository location username: aRepository user password: aRepository password. credentials ifNotNil: [ aRepository credentials: credentials. ^ self retryOnCredentialRequest: aBlock for: aRepository ]]! ! !MCKomitSubmitter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/29/2013 13:51'! storeVersion: newVersion for: aKomit self retryOnCredentialRequest: [ aKomit repository storeVersion: newVersion ] for: aKomit repository! ! !MCKomitSubmitter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/6/2013 21:36'! commitSlice: aSlice | versions slice view workingCopy version packages name | slice := MCSliceInfo new. view := KomitSliceUI new. view openDialogWithSpec centered; modalRelativeTo: World. view cancelled ifTrue: [ ^ self ]. slice issueNumber: view issueNumberText. slice issueSummary: view titleText. versions := self createVersionFor: aSlice. KomitterManager current reset. packages := versions collect: [ :each | KomitterManager current storeVersion: each for: each package. each package ]. slice includedPackages: packages. workingCopy := slice makeKomitSlice. name := workingCopy silentUniqueVersionNameIn: aSlice remote remote. version := workingCopy silentlyNewSliceVersionWithName: name message: aSlice message in: aSlice remote remote. Cursor wait showWhile: [ [ self storeVersion: version for: aSlice; storeDependencies: version for: aSlice ] ensure: [ (MCVersionInspector new version: version) show ] ]! ! !MCKomitSubmitter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 21:01'! commitKomit: aKomit | versions | versions := self createVersionFor: aKomit. versions do: [ :version | Cursor wait showWhile: [ [ self storeVersion: version for: aKomit; storeDependencies: version for: aKomit ] ensure: [ (MCVersionInspector new version: version) show ] ] ]! ! !MCKomitSubmitter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/6/2013 21:26'! createVersionFor: aKomitableObject | versions currentAuthor | currentAuthor := Author fullNamePerSe. Author fullName: aKomitableObject author. [ versions := aKomitableObject entities keys collect: [ :each | | workingCopy name version patcher | workingCopy := each package workingCopy. name := workingCopy silentUniqueVersionNameIn: aKomitableObject repository. version := workingCopy silentlyNewVersionWithName: name message: aKomitableObject message in: aKomitableObject repository. workingCopy modified: each isFullyCommited not. patcher := MCPatcher snapshot: each patch base. (aKomitableObject entities at: each) do: [ :e | e operation applyTo: patcher ]. version := MCVersion package: version package info: version info snapshot: patcher patchedSnapshot dependencies: version dependencies. KomitPackage removePackage: each. version ] ] ensure: [ Author fullName: currentAuthor ]. ^ versions! ! !MCKomitSubmitter class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/26/2013 13:18'! komit: komit ^ self new komit: komit; yourself! ! !MCMcdReader commentStamp: 'TorstenBergmann 2/6/2014 08:08'! Reader for an MCD format! !MCMcdReader methodsFor: 'accessing' stamp: 'avi 2/13/2004 23:41'! basicVersion ^ MCDiffyVersion package: self package info: self info dependencies: self dependencies baseInfo: self baseInfo patch: self patch! ! !MCMcdReader methodsFor: 'loading' stamp: 'MarianoMartinezPeck 6/17/2012 12:37'! loadPatch | old new | (self zip memberNamed: 'patch.bin') ifNotNil: [:m | [^ patch := (MCDataStream on: m contentStream) next ] on: Error do: [:fallThrough ]]. definitions := OrderedCollection new. (self zip membersMatching: 'old/*') do: [:m | self extractDefinitionsFrom: m]. old := definitions asArray. definitions := OrderedCollection new. (self zip membersMatching: 'new/*') do: [:m | self extractDefinitionsFrom: m]. new := definitions asArray. ^ patch := self buildPatchFrom: old to: new. ! ! !MCMcdReader methodsFor: 'accessing' stamp: 'avi 2/14/2004 21:33'! baseInfo ^ baseInfo ifNil: [self loadBaseInfo]! ! !MCMcdReader methodsFor: 'loading' stamp: 'stephaneducasse 2/4/2006 20:47'! loadBaseInfo ^ baseInfo := self extractInfoFrom: (self parseMember: 'base')! ! !MCMcdReader methodsFor: 'accessing' stamp: 'avi 2/14/2004 21:34'! patch ^ patch ifNil: [self loadPatch]! ! !MCMcdReader methodsFor: 'loading' stamp: 'avi 2/14/2004 21:37'! buildPatchFrom: oldDefinitions to: newDefinitions ^ MCPatch fromBase: (MCSnapshot fromDefinitions: oldDefinitions) target: (MCSnapshot fromDefinitions: newDefinitions)! ! !MCMcdReader class methodsFor: 'accessing' stamp: 'avi 2/13/2004 23:09'! extension ^ 'mcd'! ! !MCMcdWriter commentStamp: 'TorstenBergmann 2/6/2014 08:08'! Writing MCD format! !MCMcdWriter methodsFor: 'writing' stamp: 'stephaneducasse 2/4/2006 20:47'! writePatch: aPatch | old new | old := OrderedCollection new. new := OrderedCollection new. aPatch operations do: [:ea | ea isRemoval ifTrue: [old add: ea definition]. ea isAddition ifTrue: [new add: ea definition]. ea isModification ifTrue: [old add: ea baseDefinition. new add: ea definition]]. self writeOldDefinitions: old. self writeNewDefinitions: new. self addString: (self serializeInBinary: aPatch) at: 'patch.bin'.! ! !MCMcdWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 01:48'! writeDefinitions: aVersion self writeBaseInfo: aVersion baseInfo. self writePatch: aVersion patch.! ! !MCMcdWriter methodsFor: 'writing' stamp: 'nicolascellier 6/2/2013 18:39'! writeOldDefinitions: aCollection self addString: (self serializeDefinitions: aCollection) at: 'old/source.', self snapshotWriterClass extension encodedTo: 'utf8'.! ! !MCMcdWriter methodsFor: 'writing' stamp: 'nicolascellier 6/2/2013 18:39'! writeNewDefinitions: aCollection self addString: (self serializeDefinitions: aCollection) at: 'new/source.', self snapshotWriterClass extension encodedTo: 'utf8'.! ! !MCMcdWriter methodsFor: 'writing' stamp: 'nicolascellier 6/2/2013 18:39'! writeBaseInfo: aVersionInfo | string | string := self serializeVersionInfo: aVersionInfo. self addString: string at: 'base' encodedTo: 'utf8'. ! ! !MCMcdWriter class methodsFor: 'accessing' stamp: 'avi 2/13/2004 23:09'! readerClass ^ MCMcdReader! ! !MCMcmReader commentStamp: 'TorstenBergmann 2/20/2014 16:24'! Reader for Metacello MCM! !MCMcmReader methodsFor: 'accessing' stamp: 'bf 3/23/2005 01:17'! configurationName ^fileName ifNotNil: [(fileName findTokens: '/\:') last copyUpToLast: $.]! ! !MCMcmReader methodsFor: 'accessing' stamp: 'bf 11/16/2005 11:01'! version ^self configuration! ! !MCMcmReader methodsFor: 'accessing' stamp: 'bf 11/16/2005 11:03'! loadConfiguration stream reset. configuration := MCConfiguration fromArray: (MCScanner scan: stream). configuration name: self configurationName. ! ! !MCMcmReader methodsFor: 'accessing' stamp: 'bf 3/23/2005 01:17'! fileName: aString fileName := aString! ! !MCMcmReader methodsFor: 'accessing' stamp: 'bf 11/16/2005 11:01'! loadVersionInfo info := self configuration! ! !MCMcmReader methodsFor: 'accessing' stamp: 'bf 11/26/2005 20:26'! configuration configuration ifNil: [self loadConfiguration]. "browser modifies configuration, but the reader might get cached" ^configuration copy! ! !MCMcmReader class methodsFor: 'accessing' stamp: 'bf 3/22/2005 10:47'! extension ^ 'mcm'! ! !MCMcmReader class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'! on: aStream fileName: aFileName | reader | reader := self on: aStream. reader fileName: aFileName. ^reader! ! !MCMcmWriter commentStamp: 'TorstenBergmann 2/20/2014 16:24'! Writer for Metacello MCM! !MCMcmWriter methodsFor: 'writing' stamp: 'bf 3/22/2005 18:00'! close stream close! ! !MCMcmWriter methodsFor: 'writing' stamp: 'bf 3/24/2005 01:50'! writeConfiguration: aConfiguration stream nextPut: $(. aConfiguration repositories do: [:ea | stream cr. stream nextPutAll: 'repository '. (MCConfiguration repositoryToArray: ea) printElementsOn: stream]. aConfiguration dependencies do: [:ea | stream cr. stream nextPutAll: 'dependency '. (MCConfiguration dependencyToArray: ea) printElementsOn: stream]. stream cr. stream nextPut: $). stream cr.! ! !MCMcmWriter class methodsFor: 'accessing' stamp: 'bf 3/22/2005 10:49'! readerClass ^ MCMcmReader! ! !MCMcmWriter class methodsFor: 'writing' stamp: 'stephaneducasse 2/4/2006 20:47'! fileOut: aConfiguration on: aStream | inst | inst := self on: aStream. inst writeConfiguration: aConfiguration. inst close. ! ! !MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'Anonymous 6/17/2013 13:16'! deleteFile self fileName asFileReference ensureDelete! ! !MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp expected := self mockVersion. self change: #one toReturn: 2.! ! !MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! assertVersionInfoPresent | dict info | dict := MczInstaller versionInfo at: self mockPackage name. info := expected info. self assertDict: dict matchesInfo: info.! ! !MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 18:15'! fileName ^ 'InstallerTest.mcz'! ! !MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 19:36'! tearDown expected snapshot updatePackage: self mockPackage. self deleteFile.! ! !MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 18:16'! fileStream ^ FileStream forceNewFileNamed: self fileName.! ! !MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! assertNoChange | actual | actual := MCSnapshotResource takeSnapshot. diff := actual patchRelativeToBase: expected snapshot. self assert: diff isEmpty! ! !MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! assertDict: dict matchesInfo: info #(name id message date time author) do: [:sel | (info perform: sel) ifNotNil: [:i | dict at: sel ifPresent: [:d | self assert: i = d]]]. info ancestors with: (dict at: #ancestors) do: [:i :d | self assertDict: d matchesInfo: i]! ! !MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 16:25'! testInstallFromFile MCMczWriter fileOut: expected on: self fileStream. MczInstaller installFileNamed: self fileName. self assertNoChange.! ! !MCMczInstallerTest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! testInstallFromStream | stream | stream := RWBinaryOrTextStream on: String new. MCMczWriter fileOut: expected on: stream. MczInstaller installStream: stream reset. self assertNoChange. self assertVersionInfoPresent. ! ! !MCMczInstallerTest class methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 12:11'! isAbstract ^ (Smalltalk hasClassNamed: #MczInstaller) not ! ! !MCMczInstallerTest class methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 6/9/2012 23:06'! suite ^ (Smalltalk hasClassNamed: #MczInstaller) ifTrue: [ super suite ] ifFalse: [ self classForTestSuite new name: self name asString ]! ! !MCMczReader commentStamp: 'TorstenBergmann 2/6/2014 08:08'! Reader for an MCZ format! !MCMczReader methodsFor: 'parsing' stamp: 'nicolascellier 6/2/2013 18:36'! contentsForMember: member ^[(member contentStreamFromEncoding: 'utf8') text contents] on: ZnInvalidUTF8 do: [:exc | "Case of legacy encoding, presumably it is latin-1. But if contents starts with a null character, it might be a case of WideString encoded in UTF-32BE" | str | str := (member contentStreamFromEncoding: 'latin1') text. exc return: ((str peek = Character null and: [ str size \\ 4 = 0 ]) ifTrue: [WideString fromByteArray: str contents asByteArray] ifFalse: [str contents])]! ! !MCMczReader methodsFor: 'utilities' stamp: 'StephaneDucasse 8/17/2012 15:50'! extractInfoFrom: dict ^MCWorkingCopy infoFromDictionary: dict cache: self infoCache! ! !MCMczReader methodsFor: 'parsing' stamp: 'nicolascellier 6/2/2013 18:37'! parseMember: memberOrName | member tokens | member := self zip member: memberOrName. tokens := (self contentsForMember: member) parseLiterals first. ^ self associate: tokens! ! !MCMczReader methodsFor: 'loading' stamp: 'stephaneducasse 2/4/2006 20:47'! loadDependencies dependencies := (self zip membersMatching: 'dependencies/*') collect: [:m | self extractDependencyFrom: m]. dependencies := dependencies asArray. ! ! !MCMczReader methodsFor: 'parsing' stamp: 'nicolascellier 5/31/2013 23:33'! extractDependencyFrom: zipMember ^ MCVersionDependency package: (MCPackage named: (zipMember fileName copyAfterLast: $/)) info: (self extractInfoFrom: (self parseMember: zipMember))! ! !MCMczReader methodsFor: 'accessing' stamp: 'CamilloBruni 4/24/2012 15:47'! zip stream closed ifTrue: [ zip := nil]. zip ifNil: [zip := ZipArchive new. zip readFrom: self stream]. ^ zip! ! !MCMczReader methodsFor: 'private' stamp: 'nicolascellier 5/31/2013 23:35'! contentStreamForMember: member ^[(member contentStreamFromEncoding: 'utf8') text] on: ZnInvalidUTF8 do: [:exc | "Case of legacy encoding, presumably it is latin-1 and we do not need to do anything But if contents starts with a null character, it might be a case of WideString encoded in UTF-32BE" | str | str := (member contentStreamFromEncoding: 'latin1') text. (str peek = Character null and: [ str size \\ 4 = 0 ]) ifTrue: [str := (WideString fromByteArray: str contents asByteArray) readStream]. exc return: str]! ! !MCMczReader methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! infoCache ^ infoCache ifNil: [infoCache := Dictionary new]! ! !MCMczReader methodsFor: 'loading' stamp: 'BenjaminVanRyseghem 8/31/2012 15:10'! loadVersionInfo info := self extractInfoFrom: (self parseMember: 'version')! ! !MCMczReader methodsFor: 'accessing' stamp: 'avi 1/22/2004 20:33'! scanner ^ MCScanner! ! !MCMczReader methodsFor: 'loading' stamp: 'stephaneducasse 2/4/2006 20:47'! loadPackage | dict | dict := self parseMember: 'package'. package := MCPackage named: (dict at: #name)! ! !MCMczReader methodsFor: 'loading' stamp: 'MarianoMartinezPeck 6/17/2012 12:37'! loadDefinitions definitions := OrderedCollection new. (self zip memberNamed: 'snapshot.bin') ifNotNil: [:m | [^ definitions := (MCDataStream on: m contentStream) next definitions] on: Error do: [:fallThrough ]]. "otherwise" (self zip membersMatching: 'snapshot/*') do: [:m | self extractDefinitionsFrom: m]. ! ! !MCMczReader methodsFor: 'parsing' stamp: 'nicolascellier 6/2/2013 18:36'! extractDefinitionsFrom: member | reader | (MCSnapshotReader readerClassForFileNamed: member fileName) ifNotNil: [:rc | reader := rc on: (self contentsForMember: member) readStream. definitions addAll: reader definitions] ! ! !MCMczReader methodsFor: 'converting' stamp: 'stephane.ducasse 3/31/2009 21:23'! associate: tokens | result | result := Dictionary new. tokens pairsDo: [:key :value | | tmp | tmp := value. value isString ifFalse: [tmp := value collect: [:ea | self associate: ea]]. value = 'nil' ifTrue: [tmp := '']. result at: key put: tmp]. ^ result! ! !MCMczReader class methodsFor: 'accessing' stamp: 'cwp 8/1/2003 14:59'! extension ^ 'mcz'! ! !MCMczReader class methodsFor: 'testing' stamp: 'cwp 8/1/2003 12:19'! supportsVersions ^ true! ! !MCMczReader class methodsFor: 'testing' stamp: 'avi 1/19/2004 14:48'! supportsDependencies ^ true! ! !MCMczWriter commentStamp: 'TorstenBergmann 2/6/2014 08:08'! Writing MCZ format! !MCMczWriter methodsFor: 'visiting' stamp: 'nicolascellier 6/2/2013 18:39'! writeSnapshot: aSnapshot self addString: (self serializeDefinitions: aSnapshot definitions) at: 'snapshot/source.', self snapshotWriterClass extension encodedTo: 'utf8'. self addString: (self serializeInBinary: aSnapshot) at: 'snapshot.bin'! ! !MCMczWriter methodsFor: 'serializing' stamp: 'MarianoMartinezPeck 6/17/2012 12:37'! serializeInBinary: aSnapshot | writer s | s := RWBinaryOrTextStream on: String new. writer := MCDataStream on: s. writer nextPut: aSnapshot. ^ s contents! ! !MCMczWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 01:48'! writeDefinitions: aVersion self writeSnapshot: aVersion snapshot! ! !MCMczWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 01:56'! writeFormat " self addString: self format at: 'format'."! ! !MCMczWriter methodsFor: 'visiting' stamp: 'avi 9/13/2004 16:49'! writeVersion: aVersion self writeFormat. self writePackage: aVersion package. self writeVersionInfo: aVersion info. self writeDefinitions: aVersion. aVersion dependencies do: [:ea | self writeVersionDependency: ea]! ! !MCMczWriter methodsFor: 'writing' stamp: 'stephaneducasse 2/4/2006 20:47'! addString: string at: path | member | member := zip addString: string as: path. member desiredCompressionMethod: ZipArchive compressionDeflated ! ! !MCMczWriter methodsFor: 'accessing' stamp: 'cwp 8/1/2003 00:06'! zip ^ zip! ! !MCMczWriter methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:03'! initialize super initialize. zip := ZipArchive new. ! ! !MCMczWriter methodsFor: 'serializing' stamp: 'CamilloBruni 7/6/2012 15:52'! serializeVersionInfo: aVersionInfo infoWriter ifNil: [infoWriter := MCVersionInfoWriter new]. ^ String streamContents: [:s | infoWriter stream: s. infoWriter writeVersionInfo: aVersionInfo]! ! !MCMczWriter methodsFor: 'visiting' stamp: 'nicolascellier 6/2/2013 18:39'! writeVersionDependency: aVersionDependency | string | string := (self serializeVersionInfo: aVersionDependency versionInfo). self addString: string at: 'dependencies/', aVersionDependency package name encodedTo: 'utf8'! ! !MCMczWriter methodsFor: 'writing' stamp: 'avi 2/17/2004 02:17'! flush zip writeTo: stream. stream close! ! !MCMczWriter methodsFor: 'accessing' stamp: 'avi 2/17/2004 01:54'! format ^ '1'! ! !MCMczWriter methodsFor: 'accessing' stamp: 'avi 2/17/2004 02:07'! snapshotWriterClass ^ MCStWriter! ! !MCMczWriter methodsFor: 'serializing' stamp: 'nicolascellier 5/31/2013 23:07'! serializeDefinitions: aCollection ^String streamContents: [:aStream | | writer | writer := self snapshotWriterClass on: aStream. writer writeDefinitions: aCollection]! ! !MCMczWriter methodsFor: 'visiting' stamp: 'nicolascellier 6/2/2013 18:39'! writePackage: aPackage self addString: (self serializePackage: aPackage) at: 'package' encodedTo: 'utf8'! ! !MCMczWriter methodsFor: 'visiting' stamp: 'nicolascellier 6/2/2013 18:39'! writeVersionInfo: aVersionInfo | string | string := self serializeVersionInfo: aVersionInfo. self addString: string at: 'version' encodedTo: 'utf8'. ! ! !MCMczWriter methodsFor: 'writing' stamp: 'nicolascellier 6/2/2013 18:39'! addString: string at: path encodedTo: encodingName | member | member := zip addString: (string convertToEncoding: encodingName) as: path. member desiredCompressionMethod: ZipArchive compressionDeflated ! ! !MCMczWriter methodsFor: 'serializing' stamp: 'cwp 8/13/2003 01:06'! serializePackage: aPackage ^ '(name ''', aPackage name, ''')'! ! !MCMczWriter class methodsFor: 'accessing' stamp: 'cwp 8/1/2003 12:35'! readerClass ^ MCMczReader! ! !MCMczWriter class methodsFor: 'writing' stamp: 'stephaneducasse 2/4/2006 20:47'! fileOut: aVersion on: aStream | inst | inst := self on: aStream. inst writeVersion: aVersion. inst flush. ! ! !MCMergeBrowser commentStamp: 'TorstenBergmann 2/20/2014 15:52'! Browser to merge changes! !MCMergeBrowser methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 18:07'! getMenu: aMenu selection ifNil: [^ aMenu]. ^ self selectionIsConflicted ifTrue: [self getConflictMenu: aMenu] ifFalse: [self getOperationMenu: aMenu]! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'ab 7/18/2003 17:52'! cancel self answer: false! ! !MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 5/16/2007 10:40'! chooseAllNewerConflicts "Notify the potential new state of canMerge." conflicts do: [ :ea | ea chooseNewer ]. self changed: #text; changed: #list; changed: #canMerge! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'ab 7/18/2003 18:41'! clearChoice self conflictSelectionDo: [selection clearChoice. self changed: #text; changed: #list]! ! !MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 5/16/2007 10:41'! chooseAllOlderConflicts "Notify the potential new state of canMerge." conflicts do: [ :ea | ea chooseOlder ]. self changed: #text; changed: #list; changed: #canMerge! ! !MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 5/16/2007 10:41'! chooseRemote "Notify the potential new state of canMerge." self conflictSelectionDo: [selection chooseRemote. self changed: #text; changed: #list; changed: #canMerge]! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'ab 7/22/2003 00:49'! innerButtonRow ^ self buttonRow: #((Keep chooseRemote 'keep the selected change' selectionIsConflicted) (Reject chooseLocal 'reject the selected change' selectionIsConflicted))! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'ab 7/18/2003 16:37'! getOperationMenu: aMenu ^ aMenu! ! !MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 5/16/2007 10:41'! chooseAllUnchosenLocal "Notify the potential new state of canMerge." conflicts do: [ :ea | ea isResolved ifFalse: [ ea chooseLocal ] ]. self changed: #text; changed: #list; changed: #canMerge! ! !MCMergeBrowser methodsFor: 'morphic ui' stamp: 'nk 10/21/2003 23:35'! buttonSpecs ^ #((Merge merge 'Proceed with the merge' canMerge) (Cancel cancel 'Cancel the merge') ('All Newer' chooseAllNewerConflicts 'Choose all newer conflict versions') ('All Older' chooseAllOlderConflicts 'Choose all older conflict versions') ('Rest Local' chooseAllUnchosenLocal 'Choose local versions of all remaining conflicts') ('Rest Remote' chooseAllUnchosenRemote 'Choose remote versions of all remaining conflicts') )! ! !MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 5/16/2007 10:41'! chooseLocal "Notify the potential new state of canMerge." self conflictSelectionDo: [selection chooseLocal. self changed: #text; changed: #list; changed: #canMerge]! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'ab 7/22/2003 00:51'! canMerge ^ merger isMerged! ! !MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 5/16/2007 10:41'! chooseAllUnchosenRemote "Notify the potential new state of canMerge." conflicts do: [ :ea | ea isResolved ifFalse: [ ea chooseRemote ] ]. self changed: #text; changed: #list; changed: #canMerge! ! !MCMergeBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 21:31'! defaultLabel ^ 'Merge Browser'! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'GuillermoPolito 9/4/2010 20:38'! merger: aMerger merger := aMerger. items := aMerger operations asSortedCollection. conflicts := aMerger conflicts sort: [:a :b | a operation <= b operation].! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'tbn 7/6/2010 17:02'! getConflictMenu: aMenu selection remoteChosen ifTrue: [aMenu add: 'Undo keep change' target: self selector: #clearChoice] ifFalse: [aMenu add: 'Keep change' target: self selector: #chooseRemote]. selection localChosen ifTrue: [aMenu add: 'Undo reject change' target: self selector: #clearChoice] ifFalse: [aMenu add: 'Reject change' target: self selector: #chooseLocal]. ^ aMenu! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'ab 7/18/2003 18:42'! conflictSelectionDo: aBlock self selectionIsConflicted ifTrue: aBlock ifFalse: [self inform: 'You must have a conflict selected']! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'ab 7/18/2003 17:52'! merge merger isMerged ifFalse: [self inform: 'You must resolve all the conflicts first'] ifTrue: [self answer: true] ! ! !MCMergeBrowser methodsFor: 'morphic ui' stamp: 'MarcusDenker 3/25/2013 13:05'! widgetSpecs "ToolBuilder doesn't know about innerButtonRow. Made explicit here." ^#( ((buttonRow) (0 0 1 0) (0 0 0 30)) ((listMorph:selection:menu: list selection methodListMenu:) (0 0 1 0.4) (0 30 0 0)) ((buttonRow: #((Keep chooseRemote 'keep the selected change' selectionIsConflicted) (Reject chooseLocal 'reject the selected change' selectionIsConflicted))) (0 0.4 1 0.4) (0 0 0 32)) ((textMorph: text) (0 0.4 1 1) (0 32 0 0)) ) ! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'CamilloBruni 8/4/2011 15:10'! selectionIsConflicted selection ifNil: [ ^ false ]. ^ selection isConflict! ! !MCMergeBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:32'! items ^ conflicts, items! ! !MCMergeBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/2/2009 13:14'! selection: aNumber "Notify change of conflicts too." super selection: aNumber. self changed: #selectionIsConflicted! ! !MCMergeBrowser class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! resolveConflictsInMerger: aMerger | inst | inst := self new merger: aMerger. ^ inst showModally ifNil: [false]! ! !MCMergeOrLoadWarning commentStamp: ''! A MCMergeOrLoadWarning is a simple warning used when amerge or a load action may override existing entities.! !MCMergeOrLoadWarning methodsFor: 'accessing' stamp: 'CamilloBruni 1/16/2012 17:42'! messageText | packageNames | packageNames := versions collect: [ :ea| ea package name ]. ^ String streamContents: [:s | s nextPutAll: 'You are about to load new versions of the following packages'; cr; nextPutAll: 'that have unsaved changes in the image:'; cr. packageNames sort do: [:name | s cr; space; space; nextPutAll: name]. s cr cr nextPutAll: 'If you continue, you will lose these changes:']! ! !MCMergeOrLoadWarning methodsFor: 'exceptionDescription' stamp: 'abc 8/8/2011 12:56'! defaultAction ^ ( UIManager default confirm: self messageText trueChoice: 'Load' translated falseChoice: 'Merge' translated cancelChoice: 'Cancel' translated default: nil ).! ! !MCMergeOrLoadWarning methodsFor: 'accessing' stamp: 'abc 8/8/2011 12:53'! versions: aCollection versions := aCollection! ! !MCMergeOrLoadWarning methodsFor: 'actions' stamp: 'CamilloBruni 9/12/2013 23:32'! cancel ^ self resume: nil! ! !MCMergeOrLoadWarning methodsFor: 'actions' stamp: 'CamilloBruni 9/12/2013 23:32'! merge ^ self resume: false! ! !MCMergeOrLoadWarning methodsFor: 'actions' stamp: 'CamilloBruni 9/12/2013 23:32'! load ^ self resume: true! ! !MCMergeOrLoadWarning class methodsFor: 'signalling' stamp: 'abc 8/8/2011 12:50'! signalFor: aVersionCollection ^ self new versions: aVersionCollection; signal! ! !MCMergeRecord commentStamp: 'TorstenBergmann 2/5/2014 13:49'! A record for merging! !MCMergeRecord methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! packageSnapshot ^ packageSnapshot ifNil: [packageSnapshot := version package snapshot]! ! !MCMergeRecord methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! mergePatch ^ mergePatch ifNil: [mergePatch := version snapshot patchRelativeToBase: self ancestorSnapshot]! ! !MCMergeRecord methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! ancestorInfo ^ ancestorInfo ifNil: [ancestorInfo := version info commonAncestorWith: version workingCopy ancestry]! ! !MCMergeRecord methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! imagePatch ^ imagePatch ifNil: [imagePatch := self packageSnapshot patchRelativeToBase: self ancestorSnapshot]! ! !MCMergeRecord methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! ancestorSnapshot ^ ancestorSnapshot ifNil: [ancestorSnapshot := version workingCopy findSnapshotWithVersionInfo: self ancestorInfo]! ! !MCMergeRecord methodsFor: 'testing' stamp: 'abc 2/13/2004 17:14'! isAncestorMerge ^ version workingCopy ancestry hasAncestor: version info! ! !MCMergeRecord methodsFor: 'accessing' stamp: 'abc 2/13/2004 15:52'! version ^ version! ! !MCMergeRecord methodsFor: 'actions' stamp: 'abc 2/13/2004 17:14'! updateWorkingCopy self isAncestorMerge ifFalse: [self imageIsClean ifTrue: [version workingCopy loaded: version] ifFalse: [version workingCopy merged: version]]! ! !MCMergeRecord methodsFor: 'testing' stamp: 'StephaneDucasse 4/27/2010 11:49'! imageIsClean | ancestors | ancestors := version workingCopy ancestors. ^ ancestors size = 1 and: [(ancestors first = self ancestorInfo) and: [self imagePatch isEmpty]]! ! !MCMergeRecord methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithVersion: aVersion version := aVersion! ! !MCMergeRecord class methodsFor: 'instance-creation' stamp: 'abc 2/13/2004 15:52'! version: aVersion ^ self basicNew initializeWithVersion: aVersion! ! !MCMergeResolutionRequest commentStamp: 'TorstenBergmann 2/5/2014 13:51'! Notify to resolve conflicts by merging! !MCMergeResolutionRequest methodsFor: 'actions' stamp: 'CamilloBruni 9/15/2013 17:52'! autoMerge "If there are not conflicts, merge, otherwise delegate to the UI" self hasConflicts ifTrue: [ self resolve ] ifFalse: [ self merge ]! ! !MCMergeResolutionRequest methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 2/7/2009 11:26'! defaultAction "Modally open a merge tool." ^self viewMerger! ! !MCMergeResolutionRequest methodsFor: '*Polymorph-Tools-Diff' stamp: 'SeanDeNigris 1/23/2014 00:02'! viewPatchMerger "Open a modal diff tools browser to perform the merge." ^ UIManager default merge: self merger informing: messageText.! ! !MCMergeResolutionRequest methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 2/9/2010 14:06'! viewMerger "Open a model browser to perform the merge and answer wheter merged." ^PSMCPatchMorph usedByDefault ifTrue: [self viewPatchMerger] ifFalse: [(MCMergeBrowser new merger: merger; label: messageText) showModally]! ! !MCMergeResolutionRequest methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/7/2012 16:13'! merger: aMerger merger := aMerger! ! !MCMergeResolutionRequest methodsFor: 'testing' stamp: 'CamilloBruni 9/15/2013 17:52'! hasConflicts ^ self merger conflicts isEmpty not! ! !MCMergeResolutionRequest methodsFor: 'accessing' stamp: 'ab 7/18/2003 18:19'! merger ^ merger! ! !MCMergeResolutionRequest methodsFor: 'actions' stamp: 'CamilloBruni 9/15/2013 17:50'! merge self resume: true! ! !MCMergeResolutionRequest methodsFor: 'actions' stamp: 'CamilloBruni 9/15/2013 17:50'! resolve self pass! ! !MCMerger commentStamp: ''! A MCMerger is an abstract responsible for performing merge operations and detecting conflicts.! !MCMerger methodsFor: 'accessing' stamp: 'ab 6/2/2003 01:11'! mergedSnapshot ^ MCPatcher apply: self to: self baseSnapshot! ! !MCMerger methodsFor: 'operations' stamp: 'StephaneDucasse 6/24/2011 15:18'! addConflictWithOperation: anOperation self operations add: anOperation beConflict! ! !MCMerger methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:34'! operations ^ #()! ! !MCMerger methodsFor: 'accessing' stamp: 'avi 10/6/2004 15:19'! provisions ^ #()! ! !MCMerger methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'! load | loader | loader := MCPackageLoader new. loader provisions addAll: self provisions. self applyTo: loader. loader load! ! !MCMerger methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 15:14'! conflicts ^ self operations select: #isConflict ! ! !MCMerger methodsFor: 'operations' stamp: 'StephaneDucasse 6/24/2011 15:05'! applyTo: anObject self isMerged ifFalse: [self error: 'You must resolve all the conflicts first']. self operations do: [:ea | ea applyTo: anObject]! ! !MCMerger methodsFor: 'testing' stamp: 'ab 6/5/2003 19:09'! isMerged ^ self conflicts allSatisfy: [:ea | ea isResolved]! ! !MCMerger methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'! loadWithNameLike: baseName | loader | loader := MCPackageLoader new. loader provisions addAll: self provisions. self applyTo: loader. loader loadWithNameLike: baseName! ! !MCMergingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testMultiPackageMerge2 | merger | conflicts := #(). merger := MCThreeWayMerger new. merger addBaseSnapshot: (self snapshotWithElements: #(a1 b1)). merger applyPatch: ((self snapshotWithElements: #()) patchRelativeToBase: (self snapshotWithElements: #(a1))). merger applyPatch: ((self snapshotWithElements: #(a1 b1)) patchRelativeToBase: (self snapshotWithElements: #(b1))). merger conflicts do: [:ea | self handleConflict: ea]. self assert: merger mergedSnapshot definitions hasElements: #(a1 b1). self assert: conflicts isEmpty! ! !MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 01:31'! testSubtractiveConflictlessMerge self assertMerge: #(a1 b1) with: #() base: #(a1) gives: #(b1) conflicts: #()! ! !MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 00:27'! testComplexConflictlessMerge self assertMerge: #(a1 b1 d1) with: #(a2 c1) base: #(a1 c1 d1) gives: #(a2 b1) conflicts: #()! ! !MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 00:28'! testAdditiveConflictlessMerge self assertMerge: #(a1 b1) with: #(a1 c1) base: #(a1) gives: #(a1 b1 c1) conflicts: #()! ! !MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:43'! testLocalRemoveRemoteModify self assertMerge: #(b1) with: #(a1 b1) base: #(a2 b1) gives: #(a1 b1) conflicts: #((a1 removed)). self assertMerge: #(b1) with: #(a2 b1) base: #(a1 b1) gives: #(a2 b1) conflicts: #((a2 removed)).! ! !MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:38'! testSimultaneousModification self assertMerge: #(a2) with: #(a3) base: #(a1) gives: #(a3) conflicts: #((a3 a2)).! ! !MCMergingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testMultiPackageMerge | merger | conflicts := #(). merger := MCThreeWayMerger new. merger addBaseSnapshot: (self snapshotWithElements: #(a1 b1)). merger applyPatch: ((self snapshotWithElements: #()) patchRelativeToBase: (self snapshotWithElements: #(a1))). merger applyPatch: ((self snapshotWithElements: #(a2 b1)) patchRelativeToBase: (self snapshotWithElements: #(b1))). merger conflicts do: [:ea | self handleConflict: ea]. self assert: merger mergedSnapshot definitions hasElements: #(a2 b1). self assert: conflicts isEmpty! ! !MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:38'! testMultipleConflicts self assertMerge: #(a1 b3 c1) with: #(a1 b2 d1) base: #(a1 b1 c2) gives: #(a1 b3 d1) conflicts: #((removed c1) (b2 b3)) ! ! !MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 00:28'! testIdenticalModification self assertMerge: #(a2 b1) with: #(a2 b1) base: #(a1 b1) gives: #(a2 b1) conflicts: #()! ! !MCMergingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testMultiPackageMerge3 | merger | conflicts := #(). merger := MCThreeWayMerger new. merger addBaseSnapshot: (self snapshotWithElements: #(a1 b1)). merger applyPatch: ((self snapshotWithElements: #(a1 b1)) patchRelativeToBase: (self snapshotWithElements: #(b1))). merger applyPatch: ((self snapshotWithElements: #()) patchRelativeToBase: (self snapshotWithElements: #(a1))). merger conflicts do: [:ea | self handleConflict: ea]. self assert: merger mergedSnapshot definitions hasElements: #(a1 b1). self assert: conflicts isEmpty! ! !MCMergingTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! assertMerge: local with: remote base: ancestor gives: result conflicts: conflictResult | merger | conflicts := #(). merger := MCThreeWayMerger base: (self snapshotWithElements: local) target: (self snapshotWithElements: remote) ancestor: (self snapshotWithElements: ancestor). merger conflicts do: [:ea | self handleConflict: ea]. self assert: merger mergedSnapshot definitions hasElements: result. self assert: conflicts asSet = conflictResult asSet.! ! !MCMergingTest methodsFor: 'emulating' stamp: 'marcus.denker 11/10/2008 10:04'! handleConflict: aConflict |l r| l := #removed. r := #removed. aConflict localDefinition ifNotNil: [:d | l := d token]. aConflict remoteDefinition ifNotNil: [:d | r := d token]. conflicts := conflicts copyWith: (Array with: r with: l). (l = #removed or: [r = #removed]) ifTrue: [aConflict chooseRemote] ifFalse: [l > r ifTrue: [aConflict chooseLocal] ifFalse: [aConflict chooseRemote]] ! ! !MCMergingTest methodsFor: 'emulating' stamp: 'ab 7/6/2003 23:48'! snapshotWithElements: anArray ^ MCSnapshot fromDefinitions: (anArray collect: [:t | self mockToken: t])! ! !MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 01:27'! testSimultaneousRemove self assertMerge: #(a1) with: #(a1) base: #(a1 b1) gives: #(a1) conflicts: #()! ! !MCMergingTest methodsFor: 'asserting' stamp: 'ab 1/15/2003 16:46'! assert: aCollection hasElements: anArray self assert: (aCollection collect: [:ea | ea token]) asSet = anArray asSet! ! !MCMergingTest methodsFor: 'tests' stamp: 'ab 6/2/2003 01:44'! testLocalModifyRemoteRemove self assertMerge: #(a2 b1) with: #(b1) base: #(a1 b1) gives: #(b1) conflicts: #((removed a2)). self assertMerge: #(a1 b1) with: #(b1) base: #(a2 b1) gives: #(b1) conflicts: #((removed a1)).! ! !MCMethodDefinition commentStamp: ''! A MCMethodDefinition represents a method definition. It captures the following information. Instance Variables category: classIsMeta: className: selector: source: timeStamp: ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/15/2002 01:11'! selector ^selector! ! !MCMethodDefinition methodsFor: 'printing' stamp: 'ab 12/5/2002 21:25'! description ^ Array with: className with: selector with: classIsMeta! ! !MCMethodDefinition methodsFor: 'comparing' stamp: 'ab 5/24/2003 14:11'! requirements ^ Array with: className! ! !MCMethodDefinition methodsFor: 'installing' stamp: 'avi 9/17/2003 22:27'! isExtensionMethod ^ category beginsWith: '*'! ! !MCMethodDefinition methodsFor: 'installing' stamp: 'avi 11/10/2003 15:45'! isOverrideMethod "this oughta check the package" ^ self isExtensionMethod and: [category endsWith: '-override']! ! !MCMethodDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'BenjaminVanRyseghem 9/28/2011 15:24'! shortSummaryPrefix ^ self definition selector asString! ! !MCMethodDefinition methodsFor: '*Komitter-UI' stamp: 'NicolaiHess 4/8/2014 20:06'! koClass self className ifNil: [ ^ nil ] ifNotNil: [ :cname | self isExtensionMethod ifTrue:[ ^ KomitClass trackedClass: cname forExtension: self category] ifFalse:[ ^ KomitClass trackedClass: cname ] ]! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'lr 3/14/2010 21:13'! actualClass ^ Smalltalk globals at: className ifPresent: [ :class | classIsMeta ifTrue: [ class classSide ] ifFalse: [ class ] ]! ! !MCMethodDefinition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:59'! addOperation: aMCAddition on: aKOClass aKOClass addMethodDefinition: aMCAddition! ! !MCMethodDefinition methodsFor: 'visiting' stamp: 'ab 7/18/2003 21:47'! accept: aVisitor ^ aVisitor visitMethodDefinition: self! ! !MCMethodDefinition methodsFor: 'installing' stamp: 'ThierryGoubier 1/13/2014 20:46'! removeSelector: aSelector fromClass: aClass "Safely remove the given selector from the target class. Be careful not to remove the selector when it has wandered to another package, but remove the category if it is empty." | newCategory | newCategory := aClass organization categoryOfElement: aSelector. newCategory ifNotNil: [ "If moved to and fro extension, ignore removal" (category beginsWith: '*') = (newCategory beginsWith: '*') ifFalse: [ ^ self ]. "Check if moved between different extension categories" ((category beginsWith: '*') and: [ category ~= newCategory ]) ifTrue: [ ^ self ] ]. aClass removeSelector: aSelector. aClass organization removeProtocolIfEmpty: category! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'stephaneDucasse 5/8/2010 19:58'! load self actualClass compile: source classified: category withStamp: timeStamp notifying: nil! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:59'! source ^ source! ! !MCMethodDefinition methodsFor: 'installing' stamp: 'ar 12/12/2009 15:40'! unload | previousVersion | self isOverrideMethod ifTrue: [previousVersion := self scanForPreviousVersion]. previousVersion ifNil: [self actualClass ifNotNil:[:class| self removeSelector: selector fromClass: class]] ifNotNil: [previousVersion fileIn] ! ! !MCMethodDefinition methodsFor: 'printing' stamp: 'al 12/3/2005 12:15'! fullClassName "Using #class selector for classes for backwards compatibility" ^ self classIsMeta ifFalse: [self className] ifTrue: [ (self actualClass isNil or: [ self actualClass isTrait ]) ifFalse: [self className, ' class'] ifTrue: [self className, ' classSide']]! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 1/15/2003 13:42'! timeStamp ^ timeStamp! ! !MCMethodDefinition methodsFor: 'testing' stamp: 'GuillermoPolito 1/11/2012 22:53'! isLoadable ^self actualClass notNil! ! !MCMethodDefinition methodsFor: 'installing' stamp: 'stephaneDucasse 5/8/2010 19:58'! addMethodAdditionTo: aCollection | methodAddition | methodAddition := MethodAddition new compile: source classified: category withStamp: timeStamp notifying: nil logSource: true inClass: self actualClass. "This might raise an exception and never return" methodAddition createCompiledMethod. aCollection add: methodAddition. ! ! !MCMethodDefinition methodsFor: 'annotations' stamp: 'StephaneDucasse 12/30/2012 18:04'! printAnnotations: requests on: aStream "Add a string for an annotation pane, trying to fulfill the browser annotationRequests." requests do: [ :aRequest | aRequest == #timeStamp ifTrue: [ aStream nextPutAll: self timeStamp ]. aRequest == #messageCategory ifTrue: [ aStream nextPutAll: self category ]. aRequest == #requirements ifTrue: [ self requirements do: [ :req | aStream nextPutAll: req ] separatedBy: [ aStream space ]]. ] separatedBy: [ aStream space ].! ! !MCMethodDefinition methodsFor: 'testing' stamp: 'ab 8/8/2003 17:05'! isInitializer ^ selector = #initialize and: [classIsMeta] ! ! !MCMethodDefinition methodsFor: 'comparing' stamp: 'stephaneducasse 2/4/2006 20:47'! hash | hash | hash := String stringHash: classIsMeta asString initialHash: 0. hash := String stringHash: source initialHash: hash. hash := String stringHash: category initialHash: hash. hash := String stringHash: className initialHash: hash. ^ hash! ! !MCMethodDefinition methodsFor: '*monticellofiletree-core' stamp: 'dkh 2/16/2012 14:49:00'! setTimeStamp: aString ^ timeStamp := aString! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:59'! category ^ category! ! !MCMethodDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:01'! sortKey ^ self className, '.', (self classIsMeta ifTrue: ['meta'] ifFalse: ['nonmeta']), '.', self selector! ! !MCMethodDefinition methodsFor: 'installing' stamp: 'PavelKrivanek 6/22/2011 09:47'! postloadOver: aDefinition super postloadOver: aDefinition. self class initializersEnabled ifTrue: [ (self isInitializer and: [ self actualClass isTrait not and: [ aDefinition isNil or: [ self source ~= aDefinition source ]]]) ifTrue: [ self actualClass theNonMetaClass initialize ] ]. "Postloading of FFI fields." self isExternalStructureFieldDefinition ifTrue: [self actualClass theNonMetaClass compileFields].! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/15/2002 01:12'! className ^className! ! !MCMethodDefinition methodsFor: 'serializing' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithClassName: classString classIsMeta: metaBoolean selector: selectorString category: catString timeStamp: timeString source: sourceString className := classString asSymbol. selector := selectorString asSymbol. category := catString asSymbol. timeStamp := timeString. classIsMeta := metaBoolean. source := sourceString withSqueakLineEndings. ! ! !MCMethodDefinition methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 9/28/2011 15:26'! summary ^ selector! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/22/2013 16:30'! fullTimeStamp ^ DateAndTime fromMethodTimeStamp: timeStamp! ! !MCMethodDefinition methodsFor: 'comparing' stamp: 'ThierryGoubier 10/25/2013 14:57'! = aDefinition ^ super = aDefinition and: [ aDefinition category = self category and: [ aDefinition source = self source ] ]! ! !MCMethodDefinition methodsFor: '*Ring-Monticello' stamp: 'VeronicaUquillas 5/12/2011 13:02'! asRingDefinition ^(RGFactory current createMethodNamed: self selector) parentName: self className; isMetaSide: self classIsMeta; protocol: self category; sourceCode: self source; stamp: self timeStamp! ! !MCMethodDefinition methodsFor: 'testing' stamp: 'ab 5/24/2003 13:49'! isCodeDefinition ^ true! ! !MCMethodDefinition methodsFor: 'installing' stamp: 'MartinDias 11/6/2013 16:04'! scanForPreviousVersion ^ SourceFiles changeRecordsFor: self asRingDefinition detect: [ :protocol | protocol ~= category ]! ! !MCMethodDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:52'! isMethodDefinition ^true! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'LucasGiudice 9/14/2013 14:58'! diffSource ^'"protocol: ', self category,'" ', self source.! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'cwp 11/25/2002 07:26'! classIsMeta ^ classIsMeta! ! !MCMethodDefinition methodsFor: 'installing' stamp: 'NicoPaez 10/1/2010 10:30'! isExternalStructureFieldDefinition "Really belongs in the FFI package, for now, include in base even if FFI is not loaded due to the dire consequences if its not here and an FFI package is loaded (incorrect field compilation can cause VM crashes). If in the future other external packages are found to need custom post-load blocks as well, a pluggable way of doing so should be investigated, but for now it's not worth the effort and coordination required with external package maintainers" ^ selector = #fields and: [classIsMeta and: [ (Smalltalk globals at: #ExternalStructure ifPresent: [:externalStructure | self actualClass theNonMetaClass inheritsFrom: externalStructure]) == true]] ! ! !MCMethodDefinition class methodsFor: 'instance creation' stamp: 'ab 4/1/2003 01:40'! className: classString selector: selectorString category: catString timeStamp: timeString source: sourceString ^ self className: classString classIsMeta: false selector: selectorString category: catString timeStamp: timeString source: sourceString! ! !MCMethodDefinition class methodsFor: 'initialization' stamp: 'ab 8/22/2003 18:14'! initialize Smalltalk addToShutDownList: self! ! !MCMethodDefinition class methodsFor: 'initialization' stamp: 'StephaneDucasse 12/28/2012 21:31'! shutDown "Free up all cached monticello method definitions" self flushMethodCache ! ! !MCMethodDefinition class methodsFor: 'instance creation' stamp: 'ab 7/26/2003 02:05'! className: classString classIsMeta: metaBoolean selector: selectorString category: catString timeStamp: timeString source: sourceString ^ self instanceLike: (self new initializeWithClassName: classString classIsMeta: metaBoolean selector: selectorString category: catString timeStamp: timeString source: sourceString)! ! !MCMethodDefinition class methodsFor: 'instance creation' stamp: 'CamilloBruni 6/2/2012 00:14'! forMethodReference: aMethodReference | definition | definition := self cachedDefinitions at: aMethodReference compiledMethod ifAbsent: []. (definition isNil or: [definition selector ~= aMethodReference selector or: [definition className ~= aMethodReference classSymbol or: [definition classIsMeta ~= aMethodReference classIsMeta or: [definition category ~= aMethodReference category]]]]) ifTrue: [ definition := self className: aMethodReference classSymbol classIsMeta: aMethodReference classIsMeta selector: aMethodReference selector category: aMethodReference category timeStamp: aMethodReference timeStampString source: aMethodReference source. self cachedDefinitions at: aMethodReference compiledMethod put: definition]. ^ definition ! ! !MCMethodDefinition class methodsFor: 'settings' stamp: 'PavelKrivanek 6/22/2011 11:40'! initializersEnabled: aBoolean InitializersEnabled := aBoolean! ! !MCMethodDefinition class methodsFor: 'initialization' stamp: 'CamilloBruni 6/2/2012 00:13'! cachedDefinitions Definitions ifNil: [ Definitions := WeakIdentityKeyDictionary new ]. ^ Definitions! ! !MCMethodDefinition class methodsFor: 'settings' stamp: 'PavelKrivanek 6/22/2011 11:40'! initializersEnabled ^ InitializersEnabled ifNil: [true]! ! !MCMethodDefinition class methodsFor: 'initialization' stamp: 'StephaneDucasse 12/28/2012 21:31'! flushMethodCache "We do not named this method flushCache because it would override an important class methods." Definitions := nil.! ! !MCMethodDefinition class methodsFor: 'instance creation' stamp: 'ThierryGoubier 10/25/2013 15:06'! instanceLike: aDefinition "The cache is playing havoc with the equality between methods. Methods of the same code but with different timestamps are considered equal. This breaks havoc with some filetree testing code which looks at timestamps." | aMCMethodDefinition | aMCMethodDefinition := super instanceLike: aDefinition. ^ aMCMethodDefinition timeStamp ~= aDefinition timeStamp ifTrue: [ Instances add: aDefinition ] ifFalse: [ aMCMethodDefinition ]! ! !MCMethodDefinition class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:34'! cleanUp "Flush caches" self shutDown.! ! !MCMethodDefinitionTest methodsFor: 'mocks' stamp: 'EstebanLorenzano 9/8/2013 11:54'! override ^ 1! ! !MCMethodDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 8/23/2011 11:47'! testPartiallyRevertOverrideMethod | definition | self class compile: 'override ^ 2' classified: '*foobarbaz'. self class compile: 'override ^ 3' classified: self mockOverrideMethodCategory. self class compile: 'override ^ 4' classified: self mockOverrideMethodCategory. definition := (RGMethodDefinition realClass: self class selector: #override) asMCMethodDefinition. self assert: definition isOverrideMethod. self assert: self override = 4. definition unload. self assert: self override = 2. self assert: (RGMethodDefinition realClass: self class selector: #override) category = '*foobarbaz'. ! ! !MCMethodDefinitionTest methodsFor: 'testing' stamp: 'GuillermoPolito 8/24/2012 13:48'! testRevertOldMethod | definition changeRecord | Object compile: 'yourself ^ self' classified: '*MonticelloMocks'. definition := (RGMethodDefinition realClass: Object selector: #yourself) asMCMethodDefinition. changeRecord := definition scanForPreviousVersion. self assert: changeRecord notNil. self assert: changeRecord category = 'accessing'. changeRecord fileIn.! ! !MCMethodDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 8/24/2011 11:47'! testRevertOverrideMethod | definition | self class compile: 'override ^ 2' classified: self mockOverrideMethodCategory. definition := (RGMethodDefinition realClass: self class selector: #override) asMCMethodDefinition. self assert: definition isOverrideMethod. self assert: self override = 2. definition unload. self assert: self override = 1. self assert: (RGMethodDefinition realClass: self class selector: #override) category = 'mocks'. ! ! !MCMethodDefinitionTest methodsFor: 'running' stamp: 'abc 8/24/2012 16:13'! tearDown self restoreMocks. (MCWorkingCopy forPackage: (MCPackage named: 'FooBarBaz')) unregister. self class compile: 'override ^ 1' classified: 'mocks'. self ownPackage modified: isModified. "FIXME: Unregister Monticellomocks if it got created implicitly. This avoids a nasty failure of MCChangeNotificationTest due to some inconsistency about whether package names are case sensitive or not. They're treated as case insensitive in some name lookups but not in others; most importantly PackageOrganizer default treats package names as being case sensitive. The package created here is Monticellomocks (lower case mocks) and an instance of PackageInfo; the package expected in MCChangeNotificationTest is MonticelloMocks and an instance of MCMockPackageInfo. Since *that* lookup is case insensitive it can find Monticellomocks instead of MonticelloMocks and fail." "PackageOrganizer default unregisterPackageNamed: 'MonticelloMocks'."! ! !MCMethodDefinitionTest methodsFor: 'running' stamp: 'cwp 11/13/2003 14:15'! ownPackage ^ MCWorkingCopy forPackage: (MCPackage named: 'Monticello')! ! !MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! testCannotLoad | definition | definition := self mockMethod: #kjahs87 class: 'NoSuchClass' source: 'kjahs87 ^self' meta: false. self should: [definition load] raise: Error. self assert: (navigation allImplementorsOf: #kjahs87) isEmpty! ! !MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! testComparison |d1 d2 d3 d4 d5 | d1 := self mockMethod: #one class: 'A' source: '1' meta: false. d2 := self mockMethod: #one class: 'A' source: '2' meta: false. d3 := self mockMethod: #one class: 'A' source: '1' meta: true. d4 := self mockMethod: #two class: 'A' source: '1' meta: false. d5 := self mockMethod: #two class: 'A' source: '1' meta: false. self assert: (d1 isRevisionOf: d2). self deny: (d1 isSameRevisionAs: d2). self deny: (d1 isRevisionOf: d3). self deny: (d1 isRevisionOf: d4). self assert: (d4 isSameRevisionAs: d5).! ! !MCMethodDefinitionTest methodsFor: 'running' stamp: 'lr 3/14/2010 21:13'! setUp navigation := (Smalltalk hasClassNamed: #SystemNavigation) ifTrue: [ (Smalltalk globals at: #SystemNavigation) new ] ifFalse: [ Smalltalk ]. isModified := self ownPackage modified! ! !MCMethodDefinitionTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! testLoadAndUnload |definition| definition := self mockMethod: #one class: 'MCMockClassA' source: 'one ^2' meta: false. self assert: self mockInstanceA one = 1. definition load. self assert: self mockInstanceA one = 2. definition unload. self deny: (self mockInstanceA respondsTo: #one)! ! !MCMock commentStamp: 'TorstenBergmann 2/5/2014 13:51'! Common superclass for mocks! !MCMock class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:40'! wantsChangeSetLogging ^ false! ! !MCMockAPoolDictionary commentStamp: 'TorstenBergmann 2/5/2014 13:52'! Mocking a pool! !MCMockASubclass methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! variables2 ^ ivar + CVar! ! !MCMockASubclass methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! variables ^ x + Y + MCMockClassA! ! !MCMockASubclass class methodsFor: 'as yet unclassified' stamp: 'pavel.krivanek 10/14/2010 16:23'! initialize InitializationOrder := InitializationOrder ifNil: [ -100 ] "let the test fail" ifNotNil: [ InitializationOrder + 1.]! ! !MCMockClassA commentStamp: 'cwp 8/10/2003 16:43'! This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.! !MCMockClassA methodsFor: 'numeric' stamp: 'GuillermoPolito 8/24/2012 15:28'! two ^ 2! ! !MCMockClassA methodsFor: 'boolean' stamp: 'GuillermoPolito 8/24/2012 15:31'! truth ^ true! ! !MCMockClassA methodsFor: 'drag''n''drop' stamp: 'avi 9/23/2003 17:14'! q! ! !MCMockClassA methodsFor: 'boolean' stamp: 'ab 7/7/2003 23:21'! moreTruth ^ true! ! !MCMockClassA methodsFor: 'numeric' stamp: ''! c ^ 'c1'! ! !MCMockClassA methodsFor: 'numeric' stamp: 'GuillermoPolito 8/24/2012 15:31'! d ^ 'd'! ! !MCMockClassA methodsFor: 'numeric' stamp: 'GuillermoPolito 8/24/2012 15:29'! a ^ 'a2'! ! !MCMockClassA methodsFor: 'numeric' stamp: 'GuillermoPolito 8/24/2012 15:29'! b ^ 'b1'! ! !MCMockClassA methodsFor: 'numeric' stamp: 'GuillermoPolito 8/24/2012 15:22'! one ^ 1! ! !MCMockClassA methodsFor: 'boolean' stamp: 'cwp 7/13/2003 02:49'! falsehood ^ false! ! !MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! touchCVar CVar := #touched! ! !MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'pavel.krivanek 10/14/2010 16:21'! initialize CVar := #initialized. InitializationOrder := 1. ! ! !MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'cwp 8/10/2003 02:31'! cVar ^ CVar! ! !MCMockClassA class methodsFor: 'as yet unclassified' stamp: '10/14/2010 15:41'! initializationOrder ^ InitializationOrder! ! !MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! one ^ 1! ! !MCMockClassB commentStamp: ''! This comment has a bang!! Bang!! Bang!!! !MCMockClassD methodsFor: 'as yet unclassified' stamp: 'cwp 7/8/2003 21:21'! one ^ 1! ! !MCMockClassE class methodsFor: 'as yet unclassified' stamp: 'cwp 7/8/2003 21:22'! two ^ 2! ! !MCMockDefinition commentStamp: 'TorstenBergmann 2/5/2014 13:46'! A mock definition used for testing purposes! !MCMockDefinition methodsFor: 'comparing' stamp: 'ab 7/7/2003 23:21'! hash ^ token hash! ! !MCMockDefinition methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! token: aString token := aString! ! !MCMockDefinition methodsFor: 'comparing' stamp: 'ab 7/7/2003 23:21'! description ^ token first! ! !MCMockDefinition methodsFor: 'comparing' stamp: 'MarianoMartinezPeck 5/30/2012 17:12'! = definition self == definition ifTrue: [ ^ true ]. self species = definition species ifFalse: [ ^ false ]. ^definition token = token! ! !MCMockDefinition methodsFor: 'printing' stamp: 'ab 7/7/2003 23:21'! printString ^ token! ! !MCMockDefinition methodsFor: 'accessing' stamp: 'ab 7/7/2003 23:21'! token ^ token! ! !MCMockDefinition methodsFor: 'printing' stamp: 'ab 7/7/2003 23:21'! summary ^ token! ! !MCMockDefinition methodsFor: 'converting' stamp: 'ab 7/7/2003 23:21'! asString ^ token! ! !MCMockDefinition class methodsFor: 'accessing' stamp: 'ab 7/7/2003 23:21'! token: aString ^ self new token: aString! ! !MCMockDefinition class methodsFor: 'compiling' stamp: 'cwp 7/21/2003 19:46'! wantsChangeSetLogging ^ false! ! !MCMockDependency methodsFor: 'comparing' stamp: 'cwp 11/7/2004 13:33'! hash ^ self name hash! ! !MCMockDependency methodsFor: 'comparing' stamp: 'cwp 11/7/2004 13:32'! = other ^ self name = other name! ! !MCMockDependency methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithTree: expr expr isSymbol ifTrue: [name := expr. children := Array new. hasResolution := true.] ifFalse: [name := expr first. expr second isSymbol ifTrue: [hasResolution := false. children := Array new] ifFalse: [hasResolution := true. children := expr second]]! ! !MCMockDependency methodsFor: 'resolving' stamp: 'cwp 11/7/2004 14:42'! hasResolution ^ hasResolution! ! !MCMockDependency methodsFor: 'mocks' stamp: 'cwp 11/7/2004 14:41'! mockVersionInfo ^ MCVersionInfo name: self name id: (self uuidForName: name) message: '' date: nil time: nil author: '' ancestors: #()! ! !MCMockDependency methodsFor: 'accessing' stamp: 'cwp 11/7/2004 14:43'! children ^ children collect: [:ea | self class fromTree: ea]! ! !MCMockDependency methodsFor: 'resolving' stamp: 'cwp 11/7/2004 14:16'! resolve ^ self hasResolution ifTrue: [MCVersion new setPackage: MCSnapshotResource mockPackage info: self mockVersionInfo snapshot: MCSnapshotResource current snapshot dependencies: self children] ifFalse: [nil]! ! !MCMockDependency methodsFor: 'mocks' stamp: 'nk 2/22/2005 21:17'! uuidForName: aName | nm id | nm := aName asString. id := '00000000-0000-0000-0000-0000000000' , (nm size = 1 ifTrue: [nm , '0'] ifFalse: [nm]). ^UUID fromString: id! ! !MCMockDependency methodsFor: 'accessing' stamp: 'cwp 11/7/2004 14:38'! name ^ name! ! !MCMockDependency class methodsFor: 'instance creation' stamp: 'cwp 11/7/2004 14:43'! fromTree: anArray ^ self new initializeWithTree: anArray! ! !MCMockDependentItem commentStamp: 'TorstenBergmann 2/5/2014 13:52'! Mock for dependency testing! !MCMockDependentItem methodsFor: 'accessing' stamp: 'ab 7/7/2003 23:21'! provisions ^ provides ifNil: [#()]! ! !MCMockDependentItem methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! name: aString name := aString! ! !MCMockDependentItem methodsFor: 'comparing' stamp: 'ab 7/7/2003 23:21'! requirements ^ requires ifNil: [#()]! ! !MCMockDependentItem methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! requires: anArray requires := anArray! ! !MCMockDependentItem methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! provides: anArray provides := anArray! ! !MCMockDependentItem methodsFor: 'accessing' stamp: 'ab 7/7/2003 23:21'! name ^ name! ! !MCMockDependentItem methodsFor: 'comparing' stamp: 'bf 5/20/2005 16:15'! <= other ^ self name <= other name! ! !MCMockRPackage commentStamp: 'cyrilledelaunay 1/24/2011 16:16'! This class should be used instead of MCMockPackageInfo in the monticello tests! !MCMockRPackage methodsFor: 'as yet unclassified' stamp: '2011-01-24T15:34:00+01:00'! includesClass: aClass ^self classes includes: aClass! ! !MCMockRPackage methodsFor: 'as yet unclassified' stamp: '2011-01-24T15:34:00+01:00'! includesSystemCategory: categoryName ^self systemCategories anySatisfy: [:cat | cat sameAs: categoryName]! ! !MCMockRPackage methodsFor: 'as yet unclassified' stamp: '2011-01-24T15:34:00+01:00'! packageName ^ 'MonticelloMocks'! ! !MCMockRPackage methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 7/4/2012 21:07'! systemCategories ^ Array with: 'MonticelloMocks'! ! !MCMockRPackage methodsFor: 'as yet unclassified' stamp: '2011-01-24T15:33:00+01:00'! classNames ^ #( MCMockClassA MCMockASubclass MCMockClassB MCMockClassD MCMockClassE MCMockClassF MCMockClassG MCMockClassH MCMockClassI )! ! !MCMockRPackage methodsFor: 'as yet unclassified' stamp: '2011-01-24T15:50:00+01:00'! name ^ self packageName! ! !MCMockRPackage methodsFor: 'as yet unclassified' stamp: '2011-01-24T15:33:00+01:00'! classes ^ self classNames select: [ :tmpName | Smalltalk globals hasClassNamed: tmpName ] thenCollect: [ :tmpName | Smalltalk globals at: tmpName ]! ! !MCMockRPackage class methodsFor: 'initialize-release' stamp: 'StephaneDucasse 6/3/2012 23:29'! initialize [self packageOrganizerClass default registerPackage: self new ] on: MessageNotUnderstood do: []! ! !MCModel2MTModelVisitor commentStamp: ''! A MCModel2MTModelVisitor visits a Metacello model to transform it to a MT Model . Instance variables: - project : the root element (an MTProject) of the target model MCModel2MTModelVisitor new visitConfiguration: ConfigurationOfVersionner withVersion: (ConfigurationOfVersionner project version: #development)! !MCModel2MTModelVisitor methodsFor: 'visiting' stamp: 'ChristopheDemarey 7/15/2013 14:48'! visitMCVersion: aVersion "visit a Metacello Version" | groups packages projects repositories | project version description: aVersion spec description value; author: aVersion spec author value; timestamp: aVersion spec timestamp value. groups := aVersion groups. groups do: [ :aGroup | self visitMCGroup: aGroup ]. packages := aVersion packages. packages do: [ :aPackage | self visitMCPackage: aPackage ]. projects := aVersion projects. projects do: [ :aProject | self visitMCProjectAsRequiredProject: aProject ]. repositories := aVersion spec repositories list. repositories ifNotEmptyDo: [:repo | project repository: repo first name]. ! ! !MCModel2MTModelVisitor methodsFor: 'visiting' stamp: 'ChristopheDemarey 12/11/2012 13:57'! visitConfiguration: aConfigurationClass "Visits a Configuration class with the current version." | currentVersion | currentVersion := aConfigurationClass project currentVersion. ^ self visitConfiguration: aConfigurationClass withVersion: currentVersion. ! ! !MCModel2MTModelVisitor methodsFor: 'visiting' stamp: 'ChristopheDemarey 12/11/2012 14:36'! visitMCProject: aProject withVersion: aVersion "visit a Metacello Project with the specified version." | version | version := MTVersion fromVersionString: aVersion versionString. project version: version. aVersion ifNotNil: [ self visitMCVersion: aVersion ].! ! !MCModel2MTModelVisitor methodsFor: 'visiting' stamp: 'ChristopheDemarey 12/11/2013 14:14'! visitMCPackage: aPackage "visit a Metacello Package" | package version | package := MTPackage new. package name: aPackage name. version := MTVersion fromVersionName: aPackage file. package version: version. package dependencies: aPackage requires asOrderedCollection. project addDependency: package. ^ package. ! ! !MCModel2MTModelVisitor methodsFor: 'visiting' stamp: 'ChristopheDemarey 2/24/2014 16:51'! visitMCProjectAsRequiredProject: aProject "visit a Metacello Project to add it as a required projet. It is quite the same as visitMCProject except that we won't dive into the project structure. aProject is an instance of MetacelloMCProjectSpec." | version requiredProject | requiredProject := MTDependantProject new. requiredProject displayName: aProject name. requiredProject name: (aProject className ifNil: [aProject name] ifNotNil: [ :className | className configurationBaseName]). requiredProject configurationClass: aProject projectClass. requiredProject repositories: (aProject repositorySpecs collect: [ :aRepoSpec | aRepoSpec description]). requiredProject dependencies: (aProject loads ifNil: [ #() ] ifNotNilDo: [ :loads | loads ]) asOrderedCollection. version := MTVersion fromVersionString: aProject versionString. requiredProject version: version. project addDependency: requiredProject. ^ requiredProject.! ! !MCModel2MTModelVisitor methodsFor: 'visiting' stamp: 'ChristopheDemarey 12/11/2013 14:14'! visitMCGroup: aGroup "visit a Metacello Group" | group | group := MTGroup new. group name: aGroup name. aGroup includes do: [ :dep | group addDependency: dep]. project addDependency: group. ^ group. ! ! !MCModel2MTModelVisitor methodsFor: 'visiting' stamp: 'StephaneDucasse 8/23/2013 14:39'! visitConfiguration: aConfigurationClass withVersionString: aVersionString "visits a Configuration class for the specified version and returns the project root object. Returns the project root object or nil if the given version is nil." project := MTProject new. project configurationClass: aConfigurationClass. self visitMCProject: aConfigurationClass project withVersion: (aConfigurationClass project version: aVersionString). ^project ! ! !MCModel2MTModelVisitor methodsFor: 'visiting' stamp: 'ChristopheDemarey 12/11/2012 13:58'! visitConfiguration: aConfigurationClass withVersion: aVersion "visits a Configuration class for the specified version and returns the project root object. Returns the project root object or nil if the given version is nil." aVersion ifNil: [ ^ nil ]. project := MTProject new. project configurationClass: aConfigurationClass. self visitMCProject: aConfigurationClass project withVersion: aVersion. ^project ! ! !MCModel2MTModelVisitorTest methodsFor: 'private' stamp: 'ChristopheDemarey 6/5/2013 13:26'! checkRequiredProjects: project | requiredProjects proj | requiredProjects := project requiredProjects. proj := requiredProjects at: 1. self assert: proj notNil. self assert: proj displayName equals: 'XMLWriter'. self assert: proj name equals: 'VersionnerTestXMLWriter'. self assert: proj version name equals: 'stable'. proj := requiredProjects at: 2. self assert: proj notNil. self assert: proj displayName equals: 'BitmapCharacterSet'. self assert: proj name equals: 'VersionnerTestBitmapCharacterSet'. self assert: proj version name equals: 'stable'. ! ! !MCModel2MTModelVisitorTest methodsFor: 'private' stamp: 'ChristopheDemarey 6/5/2013 13:24'! checkGroups: project | group | group := project groups at: 1. self assert: group notNil. self assert: group name equals: 'default'. self assert: (group dependencies hasEqualElements: #('Core' 'Tests')). group := project groups at: 2. self assert: group notNil. self assert: group name equals: 'Core'. self assert: (group dependencies hasEqualElements: #('VersionnerTestXML-Parser')). group := project groups at: 3. self assert: group notNil. self assert: group name equals: 'Tests'. self assert: (group dependencies hasEqualElements: #('VersionnerTestXML-Tests-Parser')). ! ! !MCModel2MTModelVisitorTest methodsFor: 'private' stamp: 'ChristopheDemarey 11/21/2013 17:49'! checkPackages: project | packages proj | packages := project packages. proj := packages at: 1. self assert: proj notNil. self assert: proj name equals: 'VersionnerTestXML-Parser'. self assert: proj dependencies equals: (OrderedCollection newFrom: #('BitmapCharacterSet' 'XMLWriter')). proj := packages at: 2. self assert: proj notNil. self assert: proj name equals: 'VersionnerTestXML-Tests-Parser'. self assert: proj dependencies equals: (OrderedCollection newFrom: #('VersionnerTestXML-Parser')). ! ! !MCModel2MTModelVisitorTest methodsFor: 'tests' stamp: 'ChristopheDemarey 11/21/2013 16:34'! testVisitXMLParserConfigurationWithVersion101 "test the visitor with the 1.38 version of the Versionner configuration" | visitor config project version | visitor := MCModel2MTModelVisitor new. classFactory duplicateClass: ConfigurationOfVersionnerTestXMLParserTemplate withNewName: 'ConfigurationOfVersionnerTestXMLParser'. config := (Smalltalk globals at: #ConfigurationOfVersionnerTestXMLParser). version := config project version: '1.1'. project := visitor visitConfiguration: config withVersion: version. self assert: project class equals: MTProject. self assert: project name equals: 'VersionnerTestXMLParser'. self assert: project version name equals: '1.1'. self assert: project repository equals: 'http://www.smalltalkhub.com/mc/PharoExtras/XMLParser/main'. self checkGroups: project. self checkRequiredProjects: project. self checkPackages: project.! ! !MCModel2MTModelVisitorTest methodsFor: 'tests' stamp: 'ChristopheDemarey 6/5/2013 12:40'! tearDown super tearDown. classFactory cleanUp.! ! !MCModel2MTModelVisitorTest methodsFor: 'tests' stamp: 'ChristopheDemarey 6/5/2013 12:41'! setUp super setUp. classFactory := ClassFactoryForTestCase new.! ! !MCModification commentStamp: ''! A MCModification represents the operation to modify an entity to a snapshot. ! !MCModification methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 15:33'! selector ^ obsoletion selector! ! !MCModification methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 1/14/2009 14:12'! diffToSource "Answer toSource of the modification. If a class patch then answer the toSource with the class-side definition and comment appended." ^self isClassPatch ifTrue: [self toSource, String cr, String cr, modification classDefinitionString, String cr, String cr, modification commentStamp, String cr, modification comment] ifFalse: [self toSource]! ! !MCModification methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'! targetDefinition ^ modification! ! !MCModification methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithBase: base target: target obsoletion := base. modification := target.! ! !MCModification methodsFor: '*Komitter-UI' stamp: 'NicolaiHess 4/8/2014 20:03'! koClass | klass | klass := obsoletion koClass. klass ifNil: [ ^ nil ]. obsoletion addOperation: self on: klass. self isClassPatch ifTrue: [ klass modified: true ]. ^ klass! ! !MCModification methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:11'! koDestinationText ^ modification koDestinationText! ! !MCModification methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/26/2013 14:43'! koDefinition ^ (KomitDefinition definition: self definition) operation: self; modified: true; yourself! ! !MCModification methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:46'! modification ^ modification! ! !MCModification methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:48'! obsoletion ^ obsoletion! ! !MCModification methodsFor: 'accessing' stamp: 'nk 11/10/2003 21:44'! printAnnotations: request on: aStream aStream nextPutAll: 'old: '. obsoletion printAnnotations: request on: aStream. aStream cr. aStream nextPutAll: 'new: '. modification printAnnotations: request on: aStream.! ! !MCModification methodsFor: 'accessing' stamp: 'cwp 11/28/2002 06:55'! definition ^ modification! ! !MCModification methodsFor: 'accessing' stamp: 'LucasGiudice 9/14/2013 15:18'! fromSource ^ obsoletion source! ! !MCModification methodsFor: 'accessing' stamp: 'LucasGiudice 9/14/2013 15:02'! toSource ^ modification diffSource! ! !MCModification methodsFor: 'testing' stamp: 'nk 2/25/2005 17:29'! isClassPatch ^obsoletion isClassDefinition! ! !MCModification methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:18'! targetClass ^ obsoletion actualClass! ! !MCModification methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 15:10'! isMethodPatch ^ obsoletion isMethodDefinition! ! !MCModification methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 21:17'! koSourceText ^ obsoletion koSourceText! ! !MCModification methodsFor: '*Polymorph-Tools-Diff' stamp: 'LucasGiudice 9/14/2013 15:18'! diffFromSource "Answer fromSource of the modification. If a class patch then answer the fromSource with the class-side definition and comment appended." ^self isClassPatch ifTrue: [self fromSource, String cr, String cr, obsoletion classDefinitionString, String cr, String cr, obsoletion commentStamp, String cr, obsoletion comment] ifFalse: [obsoletion diffSource]! ! !MCModification methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 14:53'! basicApplyTo: anObject anObject modifyDefinition: obsoletion to: modification! ! !MCModification methodsFor: 'accessing' stamp: 'ab 8/22/2003 02:27'! inverse ^ MCModification of: modification to: obsoletion! ! !MCModification methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/2/2009 13:26'! diff "Open a diff browser on the changes." (DiffMorph from: self fromSource to: self toSource contextClass: (self isClassPatch ifTrue: [nil] ifFalse: [self targetClass])) extent: 400@300; openInWindowLabeled: 'Diff' translated! ! !MCModification methodsFor: 'accessing' stamp: 'StephaneDucasse 8/17/2012 16:30'! summarySuffix ^ modification summarySuffixOver: obsoletion ! ! !MCModification methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'! baseDefinition ^ obsoletion! ! !MCModification methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:23'! isModification ^ true! ! !MCModification methodsFor: 'printing' stamp: 'StephaneDucasse 8/17/2012 16:30'! summarySuffixOver: previousDefinition | sourceChanged categoryChanged timeStampChanged | sourceChanged := self source ~= previousDefinition source. timeStampChanged := self timeStamp ~= previousDefinition timeStamp. categoryChanged := self category ~= previousDefinition category. sourceChanged | timeStampChanged | categoryChanged ifFalse: [ ^super summarySuffixOver: previousDefinition ]. sourceChanged ifTrue: [ ^categoryChanged ifTrue: [ ' (changed and recategorized)' ] ifFalse: [ ' (changed)' ] ]. timeStampChanged & categoryChanged ifTrue: [^ ' (recategorized and different time stamp)' ]. ^categoryChanged ifTrue: [ ' (only recategorized)' ] ifFalse: [ ' (only different time stamp)' ] ! ! !MCModification methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/25/2013 18:20'! koMethod ^ (KomitMethod method: self definition) operation: self; modified: true; yourself! ! !MCModification class methodsFor: 'instance-creation' stamp: 'cwp 11/28/2002 07:19'! of: base to: target ^ self new initializeWithBase: base target: target! ! !MCMultiPackageLoader commentStamp: ''! A PackageLoader doing some additional cross-package checks! !MCMultiPackageLoader methodsFor: 'private' stamp: 'bf 3/17/2006 15:51'! analyze | index | index := MCDefinitionIndex definitions: additions. removals removeAllSuchThat: [:removal | (index definitionLike: removal ifPresent: [:addition | obsoletions at: addition put: removal] ifAbsent: []) notNil]. super analyze! ! !MCNoChangesException commentStamp: 'TorstenBergmann 2/5/2014 13:53'! Notify that no changes have to be merged! !MCNoChangesException methodsFor: 'accessing' stamp: 'jf 8/21/2003 19:49'! defaultAction self inform: 'No changes'! ! !MCOrganizationDefinition commentStamp: ''! A MCOrganizationDefinition represents a category change. ! !MCOrganizationDefinition methodsFor: 'accessing' stamp: 'StephaneDucasse 12/30/2012 09:52'! categories "ensure the categories are sorted alphabetically, so the merge don't take it as a conflict" ^ categories! ! !MCOrganizationDefinition methodsFor: 'private' stamp: 'EstebanLorenzano 2/11/2013 14:38'! basicCommonPrefix "Answers the minimum common denominator on package names contained in the monticello package. It can answer a package in the form X-Y-, with a minus at end..." | stream | categories isEmpty ifTrue: [ ^ '' ]. stream := String new writeStream. categories first withIndexDo: [:c :index | categories do: [:each | (each at: index ifAbsent: []) = c ifFalse: [ ^ stream contents ] ]. stream nextPut: c ]. ^stream contents! ! !MCOrganizationDefinition methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/11/2013 14:30'! description ^ Array with: #organization with: self commonPrefix! ! !MCOrganizationDefinition methodsFor: 'installing' stamp: 'avi 2/22/2004 13:46'! postloadOver: oldDefinition SystemOrganization categories: (self reorderCategories: SystemOrganization categories original: (oldDefinition ifNil: [#()] ifNotNil: [oldDefinition categories]))! ! !MCOrganizationDefinition methodsFor: 'accessing' stamp: 'ab 7/19/2003 18:01'! sortKey ^ ''! ! !MCOrganizationDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'BenjaminVanRyseghem 9/28/2011 15:24'! shortSummaryPrefix ^ self definition description last! ! !MCOrganizationDefinition methodsFor: '*Komitter-UI' stamp: 'NicolaiHess 4/8/2014 20:01'! koClass self className ifNil: [ ^ nil ] ifNotNil: [ :cname | ^ KomitClass trackedClass: cname ]! ! !MCOrganizationDefinition methodsFor: 'accessing' stamp: 'StephaneDucasse 12/30/2012 09:52'! categories: anArray categories := anArray sort! ! !MCOrganizationDefinition methodsFor: 'accessing' stamp: 'ab 5/24/2003 13:55'! summary ^ categories asArray printString! ! !MCOrganizationDefinition methodsFor: 'testing' stamp: 'cwp 7/11/2003 01:33'! isOrganizationDefinition ^ true! ! !MCOrganizationDefinition methodsFor: 'comparing' stamp: 'SeanDeNigris 2/13/2013 08:41'! = aDefinition ^ (super = aDefinition) and: [ self categories size = aDefinition categories size and: [ self categories includesAllOf: aDefinition categories ] ].! ! !MCOrganizationDefinition methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/22/2013 16:42'! addOperation: aMCModification on: aKOClass ^ aKOClass addOrganizationDefinition: aMCModification! ! !MCOrganizationDefinition methodsFor: 'accessing' stamp: 'ab 7/18/2003 21:47'! accept: aVisitor ^ aVisitor visitOrganizationDefinition: self! ! !MCOrganizationDefinition methodsFor: '*Ring-Monticello' stamp: 'VeronicaUquillas 5/12/2011 13:01'! asRingDefinition ^RGFactory current createOrganization categories: self categories; yourself ! ! !MCOrganizationDefinition methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/11/2013 14:36'! commonPrefix "Answer the package common name. In ancient times, this was answering X-Y-, with a minus at the end... this was useful for the old PackageInfo framework. RPackage does not do pattern matching, thus this is not needed anymore (and provoques an error)" | prefix | prefix := self basicCommonPrefix. ^(prefix notEmpty and: [ prefix endsWith: '-' ]) ifTrue: [ prefix allButLast ] ifFalse: [ prefix ]. ! ! !MCOrganizationDefinition methodsFor: 'accessing' stamp: 'ab 7/22/2003 01:14'! source ^ String streamContents: [:s | categories do: [:ea | s nextPutAll: ea] separatedBy: [s cr]]! ! !MCOrganizationDefinition methodsFor: 'unloading' stamp: 'ChristopheDemarey 6/3/2013 16:44'! unload categories do: [ :category | (SystemOrganization isEmptyCategoryNamed: category) ifTrue: [ SystemOrganization removeCategory: category ] ]! ! !MCOrganizationDefinition methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! reorderCategories: allCategories original: oldCategories | first | first := allCategories detect: [:ea | categories includes: ea] ifNone: [^ allCategories]. ^ ((allCategories copyUpTo: first) copyWithoutAll: oldCategories, categories), categories, ((allCategories copyAfter: first) copyWithoutAll: oldCategories, categories) ! ! !MCOrganizationDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 10/30/2006 11:18'! patchWrapper "Answer a wrapper for a patch tree for the receiver." ^PSMCOrganizationChangeWrapper with: self! ! !MCOrganizationDefinition class methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/30/2012 09:59'! categories: anArray ^ self instanceLike: (self new categories: anArray)! ! !MCOrganizationTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testReordering |dec cats newCats | dec := MCOrganizationDefinition categories: #(A B C). cats := #(X Y B Z C A Q). newCats := dec reorderCategories: cats original: #(B C A). self assert: newCats asArray = #(X Y A B C Z Q).! ! !MCOrganizationTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testReorderingWithNoCategoriesInVersion |dec cats newCats | dec := MCOrganizationDefinition categories: #(). cats := #(X Y B Z C A Q). newCats := dec reorderCategories: cats original: #(). self assert: newCats asArray = cats.! ! !MCOrganizationTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testReorderingWithRemovals |dec cats newCats | dec := MCOrganizationDefinition categories: #(A B C). cats := #(X Y B Z C A Q). newCats := dec reorderCategories: cats original: #(Y B C A Q). self assert: newCats asArray = #(X A B C Z).! ! !MCOrganizationTest methodsFor: 'tests' stamp: 'GuillermoPolito 4/27/2012 15:23'! testLoadAndUnload | category | category := 'TestPackageToUnload'. SystemOrganization addCategory: category. (MCOrganizationDefinition categories: { category }) unload. self deny: (SystemOrganization includesCategory: category)! ! !MCPTest methodsFor: 'tests' stamp: 'dgd 2/14/2003 10:15'! 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! ! !MCPTest methodsFor: 'constants' stamp: 'dgd 2/14/2003 10:13'! defaultBounds "the default bounds for morphs" ^ 0 @ 0 corner: 50 @ 40 ! ! !MCPTest methodsFor: 'tests' stamp: 'gm 2/22/2003 12:58'! testIsMorphicModel "test isMorphicModel" self deny: Object new isMorphicModel. self deny: Morph new isMorphicModel. self assert: MorphicModel new isMorphicModel. ! ! !MCPTest methodsFor: 'constants' stamp: 'dgd 2/14/2003 10:13'! defaultTop "the default top for morphs" ^ self defaultBounds top ! ! !MCPackage commentStamp: ''! MCPackage represents a package. It is merely a wrapper on top of a package set or packageInfo. Strangely enough it does not inherit from MCDefinition. Its most important method is snapshot which returns a snapshot with all the entities that should be saved. ! !MCPackage methodsFor: 'comparing' stamp: 'ar 4/26/2005 21:57'! hash ^ name asLowercase hash! ! !MCPackage methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/11/2012 17:01'! packageSet ^ RPackageSet named: name! ! !MCPackage methodsFor: 'printing' stamp: 'ab 7/10/2003 01:13'! storeOn: aStream aStream nextPutAll: 'MCPackage'; space; nextPutAll: 'named: '; store: name.! ! !MCPackage methodsFor: '*RPackage-SystemIntegration' stamp: 'MarcusDenker 10/19/2012 09:47'! correspondingRPackage ^ RPackageOrganizer default packageNamed: self name asSymbol ifAbsent: [ nil ]! ! !MCPackage methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/22/2013 16:20'! remotes ^ self workingCopy remotes! ! !MCPackage methodsFor: 'working copies' stamp: 'cwp 11/13/2003 13:33'! workingCopy ^ MCWorkingCopy forPackage: self.! ! !MCPackage methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/20/2013 18:10'! baseSnapshot ^ self workingCopy baseSnapshot! ! !MCPackage methodsFor: 'working copies' stamp: 'bf 4/19/2005 16:26'! hasWorkingCopy ^ MCWorkingCopy registry includesKey: self! ! !MCPackage methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/24/2013 19:42'! koPackage ^ KomitPackage package: self! ! !MCPackage methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/16/2013 18:34'! snapshot | packageInfo definitions categories | packageInfo := self packageSet. definitions := OrderedCollection new. categories := packageInfo categoryNames asArray. categories isEmpty ifFalse: [ definitions add: (MCOrganizationDefinition categories: categories) ]. packageInfo methods do: [:ea | definitions add: ea asMCMethodDefinition] displayingProgress: [ :ea| 'Snapshotting methods...' ]. packageInfo overriddenMethods do: [:ea | definitions add: (packageInfo changeRecordForOverriddenMethod: ea) asMCMethodDefinition] displayingProgress: [ :ea| 'Searching for overrides in ', ea asString ]. packageInfo definedClasses do: [:ea | definitions addAll: ea classDefinitions] displayingProgress: [ :ea| 'Snapshotting class ', ea asString ]. (packageInfo respondsTo: #hasPreamble) ifTrue: [ packageInfo hasPreamble ifTrue: [definitions add: (MCPreambleDefinition from: packageInfo)]. packageInfo hasPostscript ifTrue: [definitions add: (MCPostscriptDefinition from: packageInfo)]. packageInfo hasPreambleOfRemoval ifTrue: [definitions add: (MCRemovalPreambleDefinition from: packageInfo)]. packageInfo hasPostscriptOfRemoval ifTrue: [definitions add: (MCRemovalPostscriptDefinition from: packageInfo)]]. ^ MCSnapshot fromDefinitions: definitions ! ! !MCPackage methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 12/6/2013 21:37'! version ^ KomitterManager current versionFor: self! ! !MCPackage methodsFor: '*Deprecated30' stamp: 'EstebanLorenzano 9/14/2012 11:32'! packageInfo self deprecated: 'Use #packageSet' on: '14 September 2012' in: '2.0'. ^ PackageInfo named: name! ! !MCPackage methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! name: aString name := aString! ! !MCPackage methodsFor: 'comparing' stamp: 'ar 4/26/2005 21:57'! = other ^ other species = self species and: [other name sameAs: name]! ! !MCPackage methodsFor: 'printing' stamp: 'nk 7/28/2003 13:30'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: name; nextPut: $)! ! !MCPackage methodsFor: 'working copies' stamp: 'cwp 11/13/2003 13:32'! unload ^ self workingCopy unload! ! !MCPackage methodsFor: 'testing' stamp: 'ChristopheDemarey 1/17/2014 18:25'! isDirty ^ self workingCopy ifNil: [ false ] ifNotNilDo: [ :wc | wc modified ]! ! !MCPackage methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/24/2013 20:25'! silentSnapshot | packageInfo definitions categories | packageInfo := self packageSet. definitions := OrderedCollection new. categories := packageInfo categoryNames asArray. categories isEmpty ifFalse: [ definitions add: (MCOrganizationDefinition categories: categories) ]. packageInfo methods do: [:ea | definitions add: ea asMCMethodDefinition]. packageInfo overriddenMethods do: [:ea | definitions add: (packageInfo changeRecordForOverriddenMethod: ea) asMCMethodDefinition]. packageInfo definedClasses do: [:ea | definitions addAll: ea classDefinitions]. (packageInfo respondsTo: #hasPreamble) ifTrue: [ packageInfo hasPreamble ifTrue: [definitions add: (MCPreambleDefinition from: packageInfo)]. packageInfo hasPostscript ifTrue: [definitions add: (MCPostscriptDefinition from: packageInfo)]. packageInfo hasPreambleOfRemoval ifTrue: [definitions add: (MCRemovalPreambleDefinition from: packageInfo)]. packageInfo hasPostscriptOfRemoval ifTrue: [definitions add: (MCRemovalPostscriptDefinition from: packageInfo)]]. ^ MCSnapshot fromDefinitions: definitions! ! !MCPackage methodsFor: 'accessing' stamp: 'ab 7/7/2003 00:57'! name ^ name! ! !MCPackage methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/26/2013 12:58'! patch | snapshot base patch | snapshot := self silentSnapshot. base := self baseSnapshot. patch := base ifNil: [ MCPatch new initializeWithTarget: self snapshot ] ifNotNil: [ MCPatch new silentInitializeWithBase: base target: snapshot ]. ^ KomitPatch base: base patch: patch! ! !MCPackage class methodsFor: 'renaming' stamp: ''! renamePackage: oldPackageName to: newPackageName "self renamePackage: 'Seaside-Squeak-Development-Core' to: 'Seaside-Pharo-Development-Core'" | oldPackage newPackage oldWorkingCopy newWorkingCopy | oldPackage := PackageInfo named: oldPackageName. newPackage := PackageInfo named: newPackageName. " rename system categories " oldPackage systemCategories do: [ :oldCategory | | newCategory | newCategory := oldCategory allButFirst: oldPackage systemCategoryPrefix size. Smalltalk organization renameCategory: oldCategory toBe: newPackage systemCategoryPrefix , newCategory ]. " rename method categories " oldPackage extensionClasses do: [ :extensionClass | (oldPackage extensionCategoriesForClass: extensionClass) do: [ :oldProtocol | | newProtocol | newProtocol := oldProtocol allButFirst: oldPackage methodCategoryPrefix size. extensionClass organization renameCategory: oldProtocol toBe: newPackage methodCategoryPrefix , newProtocol ] ]. " update monticello packages " oldWorkingCopy := MCWorkingCopy forPackage: (MCPackage named: oldPackageName). newWorkingCopy := MCWorkingCopy forPackage: (MCPackage named: newPackageName). newWorkingCopy repositoryGroup: oldWorkingCopy repositoryGroup; modified: true. " test is all methos have been caught " oldPackage methods isEmpty ifTrue: [ oldWorkingCopy unload. PackageOrganizer default unregisterPackage: oldPackage ] ifFalse: [ self error: 'Some code entities remain in the old package, please migrate manually.' ]! ! !MCPackage class methodsFor: 'instance creation' stamp: 'ab 7/10/2003 01:17'! named: aString ^ self new name: aString! ! !MCPackageCache commentStamp: 'LaurentLaffont 3/31/2011 21:06'! I'm a kind of cache for versions and filenames of packages.! !MCPackageCache methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:03'! initialize super initialize. sorter := MCVersionSorter new. fileNames := Dictionary new.! ! !MCPackageCache methodsFor: 'accessing' stamp: 'AdrianLienhard 1/21/2010 22:14'! recordVersionInfo: aVersionInfo forFileNamed: aString fileNames at: aVersionInfo put: aString. sorter addVersionInfo: aVersionInfo! ! !MCPackageCache methodsFor: 'accessing' stamp: 'avi 1/22/2004 18:21'! versionInfos ^ sorter sortedVersionInfos ! ! !MCPackageLoader commentStamp: ''! A MCPackageLoader is responsible for loading packages. It gets used by VersionLoader, so it is eventually responsible for loading everything. Instance Variables additions: Definitions that need to be added errorDefinitions: obsoletions: provisions: removals: requirements: unloadableDefinitions: methodAdditions MethodDefinitions corresponding to the Definitions in "additions" that have been added so far. ! !MCPackageLoader methodsFor: 'private' stamp: 'BertFreudenberg 12/26/2010 13:31'! flushChangesFile "The changes file is second in the SourceFiles array" (SourceFiles at: 2) ifNotNil: [:f | f flush]! ! !MCPackageLoader methodsFor: 'private' stamp: 'nk 2/23/2005 07:50'! useNewChangeSetNamedLike: baseName during: aBlock ^self useChangeSetNamed: (ChangeSet uniqueNameLike: baseName) during: aBlock! ! !MCPackageLoader methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 11:08'! validate self analyze. unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies].! ! !MCPackageLoader methodsFor: 'private' stamp: 'avi 1/24/2004 17:44'! errorDefinitionWarning ^ String streamContents: [:s | s nextPutAll: 'The following definitions had errors while loading. Press Proceed to try to load them again (they may work on a second pass):'; cr. errorDefinitions do: [:ea | s space; space; nextPutAll: ea summary; cr]] ! ! !MCPackageLoader methodsFor: 'public' stamp: 'CamilloBruni 7/17/2013 11:08'! loadWithNameLike: baseName self validate. self useNewChangeSetNamedLike: baseName during: [self basicLoad]! ! !MCPackageLoader methodsFor: 'public' stamp: 'stephaneducasse 2/4/2006 20:47'! updatePackage: aPackage withSnapshot: aSnapshot | patch packageSnap | packageSnap := aPackage snapshot. patch := aSnapshot patchRelativeToBase: packageSnap. patch applyTo: self. packageSnap definitions do: [:ea | self provisions addAll: ea provisions] ! ! !MCPackageLoader methodsFor: 'initialization' stamp: 'StephaneDucasse 9/13/2009 18:15'! initialize super initialize. additions := OrderedCollection new. removals := OrderedCollection new. obsoletions := Dictionary new. methodAdditions := OrderedCollection new. ! ! !MCPackageLoader methodsFor: 'private' stamp: 'avi 2/17/2004 13:15'! obsoletionFor: aDefinition ^ obsoletions at: aDefinition ifAbsent: [nil]! ! !MCPackageLoader methodsFor: 'private' stamp: 'StephaneDucasse 9/13/2009 18:16'! tryToLoad: aDefinition [aDefinition addMethodAdditionTo: methodAdditions] on: Error do: [errorDefinitions add: aDefinition].! ! !MCPackageLoader methodsFor: 'private' stamp: 'avi 1/24/2004 17:42'! warnAboutErrors self notify: self errorDefinitionWarning. ! ! !MCPackageLoader methodsFor: 'public' stamp: 'CamilloBruni 7/17/2013 11:08'! load self validate. self useNewChangeSetDuring: [self basicLoad]. MCMethodDefinition cachedDefinitions finalizeValues.! ! !MCPackageLoader methodsFor: 'private' stamp: 'nk 8/30/2004 08:38'! useNewChangeSetDuring: aBlock ^self useNewChangeSetNamedLike: 'MC' during: aBlock! ! !MCPackageLoader methodsFor: 'public' stamp: 'EstebanLorenzano 10/17/2012 16:54'! unloadPackage: aPackage self updatePackage: aPackage withSnapshot: MCSnapshot empty. MCMethodDefinition cachedDefinitions finalizeValues.! ! !MCPackageLoader methodsFor: 'public' stamp: 'CamilloBruni 7/17/2013 11:08'! loadWithName: baseName self validate. self useChangeSetNamed: baseName during: [self basicLoad]! ! !MCPackageLoader methodsFor: 'public' stamp: 'stephaneducasse 2/4/2006 20:47'! installSnapshot: aSnapshot | patch | patch := aSnapshot patchRelativeToBase: MCSnapshot empty. patch applyTo: self. ! ! !MCPackageLoader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! analyze | sorter | sorter := self sorterForItems: additions. additions := sorter orderedItems. requirements := sorter externalRequirements. unloadableDefinitions := sorter itemsWithMissingRequirements asSortedCollection. sorter := self sorterForItems: removals. removals := sorter orderedItems reversed.! ! !MCPackageLoader methodsFor: 'private' stamp: 'NicoPaez 10/1/2010 10:33'! provisions ^ provisions ifNil: [provisions := Set withAll: Smalltalk globals keys]! ! !MCPackageLoader methodsFor: 'patch ops' stamp: 'ab 5/24/2003 16:14'! removeDefinition: aDefinition removals add: aDefinition! ! !MCPackageLoader methodsFor: 'private' stamp: 'AlainPlantec 1/7/2010 22:20'! shouldWarnAboutErrors ^ errorDefinitions isEmpty not and: [false "should make this a setting ?"]! ! !MCPackageLoader methodsFor: 'patch ops' stamp: 'ab 5/24/2003 16:13'! addDefinition: aDefinition additions add: aDefinition! ! !MCPackageLoader methodsFor: 'private' stamp: 'ab 5/24/2003 16:52'! orderedAdditions ^ additions! ! !MCPackageLoader methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! sorterForItems: aCollection | sorter | sorter := MCDependencySorter items: aCollection. sorter addExternalProvisions: self provisions. ^ sorter! ! !MCPackageLoader methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 11:22'! basicLoadDefinitions "FIXME. Do a separate pass on loading class definitions as the very first thing. This is a workaround for a problem with the so-called 'atomic' loading (you wish!!) which isn't atomic at all but mixes compilation of methods with reshapes of classes. Since the method is not installed until later, any class reshape in the middle *will* affect methods in subclasses that have been compiled before. There is probably a better way of dealing with this by ensuring that the sort order of the definition lists superclass definitions before methods for subclasses but I need this NOW, and adding an extra pass ensures that methods are compiled against their new class definitions." additions do: [ :each | self loadClassDefinition: each ] displayingProgress: 'Loading classes...'. additions do: [ :each | self tryToLoad: each ] displayingProgress: 'Compiling methods...'. removals do: [ :each | each unload ] displayingProgress: 'Cleaning up...'. self shouldWarnAboutErrors ifTrue: [ self warnAboutErrors ]. errorDefinitions do: [ :each | each addMethodAdditionTo: methodAdditions ] displayingProgress: 'Reloading erroneous definitions...'. methodAdditions do: [ :each | each installMethod ]. methodAdditions do: [ :each | each notifyObservers ]. additions do: [ :each | each postloadOver: (self obsoletionFor: each) ] displayingProgress: 'Initializing...'. ! ! !MCPackageLoader methodsFor: 'private' stamp: 'ab 5/25/2003 01:24'! dependencyWarning ^ String streamContents: [:s | s nextPutAll: 'This package depends on the following classes:'; cr. requirements do: [:ea | s space; space; nextPutAll: ea; cr]. s nextPutAll: 'You must resolve these dependencies before you will be able to load these definitions: '; cr. unloadableDefinitions do: [:ea | s space; space; nextPutAll: ea summary; cr]] ! ! !MCPackageLoader methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 11:06'! useChangeSetNamed: baseName during: aBlock "Use the named change set, or create one with the given name." | oldChanges newChanges | oldChanges := ChangeSet current. newChanges := (ChangeSet named: baseName) ifNil: [ ChangeSet new name: baseName ]. ChangeSet newChanges: newChanges. aBlock ensure: [ ChangeSet newChanges: oldChanges ]. ! ! !MCPackageLoader methodsFor: 'private' stamp: 'MartinDias 7/25/2013 14:36'! handleLoadErrorsDuring: aBlock [aBlock on: InMidstOfFileinNotification do: [ :notification | notification resume: true ]] on: SlotClassBuilderWarning do: [ :error | error resume ]! ! !MCPackageLoader methodsFor: 'private' stamp: 'ab 5/25/2003 01:19'! orderDefinitionsForLoading: aCollection ^ (self sorterForItems: aCollection) orderedItems! ! !MCPackageLoader methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 11:20'! loadClassDefinition: aDefinition [ aDefinition isClassDefinition ifTrue: [ aDefinition load ] ] on: Error do: [ errorDefinitions add: aDefinition ].! ! !MCPackageLoader methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 11:13'! basicLoad errorDefinitions := OrderedCollection new. [ self handleLoadErrorsDuring: [ self basicLoadDefinitions ] ] ensure: [ self flushChangesFile ]! ! !MCPackageLoader methodsFor: 'private' stamp: 'ab 5/25/2003 01:22'! warnAboutDependencies self notify: self dependencyWarning! ! !MCPackageLoader methodsFor: 'patch ops' stamp: 'avi 2/17/2004 13:14'! modifyDefinition: old to: new self addDefinition: new. obsoletions at: new put: old.! ! !MCPackageLoader class methodsFor: 'public' stamp: 'ab 7/6/2003 23:30'! installSnapshot: aSnapshot self new installSnapshot: aSnapshot; load! ! !MCPackageLoader class methodsFor: 'public' stamp: 'ab 7/7/2003 12:11'! updatePackage: aPackage withSnapshot: aSnapshot self new updatePackage: aPackage withSnapshot: aSnapshot; load! ! !MCPackageLoader class methodsFor: 'public' stamp: 'bf 12/5/2004 12:00'! unloadPackage: aPackage self new unloadPackage: aPackage; loadWithNameLike: aPackage name, '-unload'! ! !MCPackageManager commentStamp: 'StephaneDucasse 4/29/2011 20:42'! MCPackageManager is a kind of package wrapper knowing if the package is dirty or not. The class side manages registered package managers. Instance Variables: package modified Class Instance Variables: registry ! !MCPackageManager methodsFor: 'operations' stamp: 'EstebanLorenzano 2/21/2014 15:33'! unregister self class registry removeKey: package ifAbsent: [ ^ self ]. self class changed: (Array with: #unregistered with: package). self announcer announce: (MCWorkingCopyDeleted workingCopy: self package: package)! ! !MCPackageManager methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithPackage: aPackage package := aPackage. self initialize.! ! !MCPackageManager methodsFor: 'system changes' stamp: 'EstebanLorenzano 9/12/2012 13:35'! update: aSymbol InMidstOfFileinNotification signal ifFalse: [ [((aSymbol = #recentMethodSubmissions) and: [self packageSet includesMethodReference: RecentMessageList uniqueInstance lastEntry]) ifTrue: [self modified: true]] on: Error do: []]! ! !MCPackageManager methodsFor: 'private' stamp: 'EstebanLorenzano 5/21/2012 17:31'! announcer ^self class announcer! ! !MCPackageManager methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/11/2012 17:01'! packageSet ^ package packageSet! ! !MCPackageManager methodsFor: 'initialization' stamp: 'StephaneDucasse 5/7/2011 18:18'! initialize super initialize. modified := false. ! ! !MCPackageManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/22/2013 15:33'! modified: aBoolean modified = aBoolean ifTrue: [ ^ self ]. modified := aBoolean. self changed: #modified. modified ifFalse: [ Smalltalk logChange: '"' , self packageName , '"' ]. self announcer announce: (MCPackageModified package: self package) ! ! !MCPackageManager methodsFor: 'accessing' stamp: 'cwp 11/13/2003 14:12'! modified ^ modified! ! !MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/7/2003 16:47'! package ^ package! ! !MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/7/2003 12:18'! packageName ^ package name! ! !MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/5/2003 23:18'! packageNameWithStar ^ modified ifTrue: ['* ', self packageName] ifFalse: [self packageName]! ! !MCPackageManager methodsFor: '*Deprecated30' stamp: 'EstebanLorenzano 9/14/2012 11:32'! packageInfo self deprecated: 'Use #packageSet' on: '14 September 2012' in: '2.0'. ^ package packageInfo! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'CamilloBruni 8/30/2012 11:19'! classMoved: anEvent self managersForPackage: anEvent oldPackage do: [ :mgr | mgr modified: true ]. self managersForPackage: anEvent newPackage do: [ :mgr | mgr modified: true ].! ! !MCPackageManager class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/22/2013 14:50'! forPackage: aPackage ^ self registry at: aPackage ifAbsent: [|mgr| mgr := self new initializeWithPackage: aPackage. self registry at: aPackage put: mgr. self announcer announce: (MCWorkingCopyCreated workingCopy: mgr package: aPackage). mgr ]! ! !MCPackageManager class methodsFor: 'private' stamp: 'EstebanLorenzano 8/3/2012 14:29'! announcer ^PrivateAnnouncer ifNil: [ SystemAnnouncer uniqueInstance ]! ! !MCPackageManager class methodsFor: 'accessing' stamp: 'ab 3/31/2003 20:45'! allManagers ^ self registry values! ! !MCPackageManager class methodsFor: 'cleaning' stamp: 'StephaneDucasse 7/11/2010 23:02'! flushObsoletePackageInfos "Flush any and all PackageInfos that are not associated with an MCPackageManager." | pkgNames | pkgNames := self allManagers collect: [:wcs| wcs packageName] as: Set. PackageOrganizer default flushObsoletePackages: [:p| p class isObsolete or:[(pkgNames includes: p packageName) not]. ].! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'EstebanLorenzano 9/12/2012 13:35'! managersForPackage: aPackage do: aBlock self registry do: [:mgr | (mgr packageSet includesSystemCategory: aPackage name) ifTrue: [ aBlock value: mgr. ] ].! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'CamilloBruni 9/22/2012 10:43'! methodMoved: anEvent self managersForPackage: anEvent oldPackage do: [ :mgr | mgr modified: true ]. self managersForPackage: anEvent newPackage do: [ :mgr | mgr modified: true ].! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'GuillermoPolito 9/21/2012 15:10'! managersForCategory: aSystemCategory do: aBlock "Got to be careful here - we might get method categories where capitalization is problematic." | cat foundOne index | foundOne := false. cat := aSystemCategory ifNil:[^nil]. "yes this happens; for example in eToy projects" "first ask PackageInfos, their package name might not match the category" self registry do: [:mgr | (mgr packageSet includesSystemCategory: aSystemCategory) ifTrue: [ aBlock value: mgr. foundOne := true. ] ]. foundOne ifTrue: [^self]. ["Loop over categories until we found a matching one" self registry at: (MCPackage named: cat) ifPresent:[:mgr| aBlock value: mgr. foundOne := true. ]. index := cat lastIndexOf: $-. index > 0]whileTrue:[ "Step up to next level package" cat := cat copyFrom: 1 to: index-1. ]. foundOne ifFalse:[ "Create a new (but only top-level)" aBlock value: (MCWorkingCopy forPackage: (MCPackage named: aSystemCategory capitalized)). ].! ! !MCPackageManager class methodsFor: 'private' stamp: 'EstebanLorenzano 5/21/2012 17:33'! announcer: anAnnouncer PrivateAnnouncer := anAnnouncer! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'EstebanLorenzano 3/19/2014 17:45'! packageRenamed: anAnnouncement self allManagers detect: [ :each | each packageName = anAnnouncement newName ] ifFound: [ :newPackage | newPackage modified: true ]. (self allManagers detect: [ :each | each packageName = anAnnouncement oldName ]) unload.! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'GuillermoPolito 8/3/2012 14:15'! methodRemoved: anEvent self managersForClass: anEvent methodClass category: anEvent protocol do:[:mgr| mgr modified: true]. ! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/27/2005 14:11'! managersForClass: aClass category: methodCategory do: aBlock (methodCategory isEmptyOrNil or:[methodCategory first ~= $*]) ifTrue:[ "Not an extension method" ^self managersForClass: aClass do: aBlock. ]. self managersForCategory: methodCategory allButFirst do: aBlock.! ! !MCPackageManager class methodsFor: 'initialize' stamp: 'CamilloBruni 8/1/2012 16:27'! initialize "Remove this later" self unregisterForNotifications.! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'GuillermoPolito 8/3/2012 13:57'! methodModified: anEvent ^self managersForClass: anEvent methodClass selector: anEvent selector do:[:mgr| mgr modified: true].! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'EstebanLorenzano 9/12/2012 13:35'! managersForClass: aClass do: aBlock self registry do: [:mgr | (mgr packageSet includesClass: aClass) ifTrue: [aBlock value: mgr]]! ! !MCPackageManager class methodsFor: 'event registration' stamp: 'EstebanLorenzano 3/19/2014 17:22'! registerInterestOnSystemChangesOnAnnouncer: anAnnouncer anAnnouncer on: RPackageRenamed send: #packageRenamed: to: self; on: ClassAdded, ClassModifiedClassDefinition, ClassRenamed, ClassCommented send: #classModified: to: self; on: ClassRepackaged send: #classMoved: to: self; on: ClassRemoved send: #classRemoved: to: self; on: MethodAdded, MethodModified, MethodRecategorized send: #methodModified: to: self; on: MethodRepackaged send: #methodMoved: to: self; on: MethodRemoved send: #methodRemoved: to: self.! ! !MCPackageManager class methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! registry ^ registry ifNil: [registry := Dictionary new]! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'BenjaminVanRyseghem 11/30/2013 14:21'! classRemoved: anEvent "Informs the registry who use to keep this class that its changed. Unlike #classModified:, class is not anymore in RPackages so it will not be found, that's why we look for system category instead if class is included or not" self registry do: [:mgr | (mgr packageSet includesSystemCategory: anEvent classAffected category) ifTrue: [ mgr modified: true ]. (mgr packageSet extensionCategoriesForClass: anEvent classAffected) ifNotEmpty: [ mgr modified: true ]. ]! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'ar 4/26/2005 21:40'! managersForClass: aClass selector: aSelector do: aBlock ^self managersForClass: aClass category: (aClass organization categoryOfElement: aSelector) do: aBlock! ! !MCPackageManager class methodsFor: '*rpackage-systemintegration' stamp: 'CamilleTeruel 7/29/2012 18:45'! unregisterForNotifications SystemAnnouncer uniqueInstance unsubscribe: self! ! !MCPackageManager class methodsFor: 'system changes' stamp: 'MartinDias 1/28/2014 16:16'! classModified: anEvent self managersForClass: anEvent classAffected do:[ :mgr | mgr modified: true ].! ! !MCPackageModified commentStamp: ''! An MCPackageModified is raised when a MCPackage is modified! !MCPackageModified methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:49'! package: anObject package := anObject! ! !MCPackageModified methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:49'! package ^ package! ! !MCPackageModified class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 13:52'! package: aMCPackage ^ self new package: aMCPackage! ! !MCPackageTest methodsFor: 'tests' stamp: 'ThierryGoubier 1/17/2014 09:57'! testUnloadWithAdditionalTracking "This is to test against another entity removing the extension protocol as well." | mock | SystemAnnouncer uniqueInstance on: MethodRemoved send: #aMethodRemoved: to: self. self assert: (SystemAnnouncer uniqueInstance hasSubscriber: self ). self mockPackage unload. self deny: (Smalltalk hasClassNamed: #MCMockClassA). self deny: (MCSnapshotTest includesSelector: #mockClassExtension). self deny: (MCSnapshotTest organization protocolNamed: self mockExtensionMethodCategory) notNil. mock := Smalltalk globals at: #MCMock. self assert: (mock subclasses detect: [ :c | c name = #MCMockClassA ] ifNone: [ ]) isNil. SystemAnnouncer uniqueInstance unsubscribe: self. self deny: (SystemAnnouncer uniqueInstance hasSubscriber: self ). ! ! !MCPackageTest methodsFor: 'private' stamp: 'ThierryGoubier 1/17/2014 10:34'! aMethodRemoved: anEvent "Force cleaning of the protocol." (anEvent protocol = self mockExtensionMethodCategory and: [ anEvent methodClass == MCSnapshotTest ]) ifTrue: [ anEvent methodClass organization removeProtocolIfEmpty: self mockExtensionMethodCategory ]! ! !MCPackageTest methodsFor: 'tests' stamp: 'ThierryGoubier 1/13/2014 20:51'! testUnload | mock | self mockPackage unload. self deny: (Smalltalk hasClassNamed: #MCMockClassA). self deny: (MCSnapshotTest includesSelector: #mockClassExtension). self deny: (MCSnapshotTest organization protocolNamed: self mockExtensionMethodCategory) notNil. mock := Smalltalk globals at: #MCMock. self assert: (mock subclasses detect: [ :c | c name = #MCMockClassA ] ifNone: [ ]) isNil! ! !MCPackageTest methodsFor: 'running' stamp: 'GuillermoPolito 8/24/2012 14:36'! tearDown self mockSnapshot install. MCDataStream initialize "MCMockClassG ends up in the DataStream TypeMap -- we need to reset"! ! !MCPatch commentStamp: 'StephaneDucasse 6/24/2011 14:11'! I represent a set of patch operations which can be applied by sending message applyTo: to my instances. ! !MCPatch methodsFor: 'accessing' stamp: 'ab 5/13/2003 12:18'! operations ^ operations! ! !MCPatch methodsFor: 'accessing' stamp: 'CamilloBruni 9/28/2011 17:27'! hasConflict ^ self operations anySatisfy: [ :change| change isConflict ]! ! !MCPatch methodsFor: 'querying' stamp: 'cwp 6/9/2003 11:53'! isEmpty ^ operations isEmpty! ! !MCPatch methodsFor: '*Komitter-Models' stamp: 'MarcusDenker 1/5/2014 15:26'! initializeWithTarget: targetSnapshot | target | target := MCDefinitionIndex definitions: targetSnapshot definitions. operations := (target definitions collect: [ :definition | MCAddition of: definition ]) asOrderedCollection.! ! !MCPatch methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/24/2013 20:27'! silentInitializeWithBase: baseSnapshot target: targetSnapshot | base target | operations := OrderedCollection new. base := MCDefinitionIndex definitions: baseSnapshot definitions. target := MCDefinitionIndex definitions: targetSnapshot definitions. target definitions do: [ :t | base definitionLike: t ifPresent: [:b | (b isSameRevisionAs: t) ifFalse: [operations add: (MCModification of: b to: t)]] ifAbsent: [operations add: (MCAddition of: t)] ]. base definitions do: [:b | target definitionLike: b ifPresent: [:t] ifAbsent: [operations add: (MCRemoval of: b)]] ! ! !MCPatch methodsFor: 'applying' stamp: 'ab 5/24/2003 16:12'! applyTo: anObject operations do: [:ea | ea applyTo: anObject]. ! ! !MCPatch methodsFor: 'intializing' stamp: 'BenjaminVanRyseghem 11/8/2013 15:41'! initializeWithBase: baseSnapshot target: targetSnapshot | base target | operations := OrderedCollection new. base := MCDefinitionIndex definitions: baseSnapshot definitions. target := MCDefinitionIndex definitions: targetSnapshot definitions. target definitions do: [ :t | base definitionLike: t ifPresent: [:b | (b isSameRevisionAs: t) ifFalse: [operations add: (MCModification of: b to: t)]] ifAbsent: [operations add: (MCAddition of: t)] ] displayingProgress: 'Diffing...'. base definitions do: [:b | target definitionLike: b ifPresent: [:t] ifAbsent: [operations add: (MCRemoval of: b)]] ! ! !MCPatch methodsFor: 'intializing' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithOperations: aCollection operations := aCollection! ! !MCPatch methodsFor: '*MonticelloGUI' stamp: 'BenjaminVanRyseghem 2/8/2012 17:10'! browse ^ (MCPatchBrowser forPatch: self) show! ! !MCPatch class methodsFor: 'instance-creation' stamp: 'avi 9/11/2004 15:49'! fromBase: baseSnapshot target: targetSnapshot ^ self new initializeWithBase: baseSnapshot target: targetSnapshot! ! !MCPatch class methodsFor: 'instance-creation' stamp: 'avi 9/11/2004 15:50'! operations: aCollection ^ self basicNew initializeWithOperations: aCollection! ! !MCPatchBrowser commentStamp: 'TorstenBergmann 2/20/2014 15:52'! The Monticello patch browser! !MCPatchBrowser methodsFor: 'actions' stamp: 'ar 7/10/2009 22:46'! revertSelection | loader | selection ifNotNil: [loader := MCPackageLoader new. selection inverse applyTo: loader. loader loadWithName: self changeSetNameForInstall ]! ! !MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: 'lr 3/14/2010 21:13'! selectedClass | definition | selection ifNil: [ ^ nil ]. (definition := selection definition) ifNil: [ ^ nil ]. definition isMethodDefinition ifFalse: [ ^ nil ]. ^ Smalltalk globals at: definition className ifAbsent: [ ]! ! !MCPatchBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'StephaneDucasse 2/10/2012 15:50'! methodListMenu: aMenu selection ifNotNil: [aMenu addList:#( ('Install' installSelection) ('Diff' diffSelection) ('Revert' revertSelection) -)]. super methodListMenu: aMenu. ^ aMenu ! ! !MCPatchBrowser methodsFor: 'text' stamp: 'ab 7/16/2003 14:27'! text: aTextOrString self changed: #text! ! !MCPatchBrowser methodsFor: 'text' stamp: 'ab 7/16/2003 14:40'! text ^ selection ifNil: [''] ifNotNil: [selection source]! ! !MCPatchBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'! invert items := items collect: [:ea | ea inverse]. self changed: #list; changed: #text; changed: #selection! ! !MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: 'stephaneducasse 2/4/2006 20:47'! selectedMessageName | definition | selection ifNil: [ ^nil ]. (definition := selection definition) ifNil: [ ^nil ]. definition isMethodDefinition ifFalse: [ ^nil ]. ^definition selector! ! !MCPatchBrowser methodsFor: 'morphic ui' stamp: 'ab 8/22/2003 02:21'! buttonSpecs ^ #((Invert invert 'Show the reverse set of changes') (Export export 'Export the changes as a change set'))! ! !MCPatchBrowser methodsFor: 'selecting' stamp: 'ab 7/16/2003 14:30'! selection ^ selection ifNil: [0] ifNotNil: [self items indexOf: selection]! ! !MCPatchBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! patch: aPatch items := aPatch operations asSortedCollection! ! !MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: 'stephaneducasse 2/4/2006 20:47'! selectedClassOrMetaClass | definition | selection ifNil: [ ^nil ]. (definition := selection definition) ifNil: [ ^nil ]. definition isMethodDefinition ifFalse: [ ^nil ]. ^definition actualClass! ! !MCPatchBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 21:31'! defaultLabel ^ 'Patch Browser'! ! !MCPatchBrowser methodsFor: 'subclassresponsibility' stamp: 'stephaneducasse 2/4/2006 20:47'! selectedMessageCategoryName | definition | selection ifNil: [ ^nil ]. (definition := selection definition) ifNil: [ ^nil ]. definition isMethodDefinition ifFalse: [ ^nil ]. ^definition category! ! !MCPatchBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 10/24/2006 15:44'! diffSelection "Open a diff browser on the selection." selection ifNotNil: [selection diff]! ! !MCPatchBrowser methodsFor: 'morphic ui' stamp: 'MarcusDenker 3/25/2013 13:06'! widgetSpecs ^#( ((listMorph:selection:menu:keystroke: list selection methodListMenu: methodListKey:from:) (0 0 1 0.4) (0 0 0 0)) ((textMorph: text) (0 0.4 1 1)) ) ! ! !MCPatchBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! installSelection | loader | selection ifNotNil: [loader := MCPackageLoader new. selection applyTo: loader. loader loadWithName: self changeSetNameForInstall ]! ! !MCPatchBrowser methodsFor: 'selecting' stamp: 'MarcusDenker 3/25/2013 13:09'! selection: aNumber selection := aNumber = 0 ifFalse: [self items at: aNumber]. self changed: #selection; changed: #text.! ! !MCPatchBrowser methodsFor: 'accessing' stamp: 'ab 7/16/2003 14:39'! list ^ self items collect: [:ea | ea summary]! ! !MCPatchBrowser methodsFor: 'actions' stamp: 'nk 2/23/2005 08:04'! changeSetNameForInstall "Answer the name of the change set into which my selection will be installed. Derive this from my label. If I have no label, use the current change set." | tokens | label ifNil: [ ^ChangeSet current name ]. tokens := label findTokens: ' '. tokens removeAllFoundIn: { 'changes'. 'between'. 'and' }. (tokens size = 3 and: [ tokens second = ' self remoteDefinition fullTimeStamp! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'AlainPlantec 1/7/2010 22:21'! printAnnotations: requests on: aStream "Add a string for an annotation pane, trying to fulfill the CodeHolder annotationRequests" self definition printAnnotations: requests on: aStream.! ! !MCPatchOperation methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 15:07'! isResolved ^ isConflict and: [ isApplicable notNil ]! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'cwp 11/28/2002 06:59'! definition ^ self subclassResponsibility ! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 15:12'! beNonConflict isConflict := false. isApplicable := true.! ! !MCPatchOperation methodsFor: 'testing' stamp: 'nk 2/25/2005 17:28'! isClassPatch ^false! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:17'! targetClass self subclassResponsibility.! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 14:54'! chooseNewer self isLocalNewer ifTrue: [ self chooseLocal ] ifFalse: [ self isRemoteNewer ifTrue: [ self chooseRemote ]]! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 14:55'! chooseRemote isApplicable := true! ! !MCPatchOperation methodsFor: 'testing' stamp: 'IgorStasenko 6/24/2011 17:28'! remoteChosen ^ isApplicable ~~ false! ! !MCPatchOperation methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 15:10'! isMethodPatch ^ self subclassResponsibility! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'CamilloBruni 8/4/2011 15:15'! summary | attribute | attribute := self isResolved ifTrue: [self remoteChosen ifTrue: [#underlined] ifFalse: [#struckOut]] ifFalse: [#bold]. ^ Text string:( self definition summary, self summarySuffix) attribute: (TextEmphasis perform: attribute)! ! !MCPatchOperation methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 14:44'! isConflict ^ isConflict == true! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'nk 2/25/2005 17:26'! sourceString ^self sourceText asString! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 14:55'! chooseOlder self isRemoteNewer ifTrue: [ self chooseLocal ] ifFalse: [ self isLocalNewer ifTrue: [ self chooseRemote ]]! ! !MCPatchOperation methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 1/14/2009 14:07'! diffFromSource "Answer fromSource of the operation for a diff tool." ^self fromSource! ! !MCPatchOperation methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 14:57'! localChosen ^ isApplicable == false ! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'cwp 11/27/2002 09:26'! inverse self subclassResponsibility! ! !MCPatchOperation methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 10/24/2006 15:40'! diff "Open a diff browser on the changes." ! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'ab 7/6/2003 00:06'! summarySuffix ^ ''! ! !MCPatchOperation methodsFor: 'testing' stamp: 'cwp 11/27/2002 09:30'! isModification ^ false! ! !MCPatchOperation methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 15:44'! koMethod ^ self subclassResponsibility! ! !MCPatchOperation methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:11'! <= other ^ self definition <= other definition! ! !MCPatchOperation methodsFor: 'accessing' stamp: 'gvc 10/30/2006 11:15'! patchWrapper "Answer a wrapper for a patch tree for the receiver." ^PSMCPatchOperationWrapper with: self! ! !MCPatchTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp |rev1 rev2| rev1 := MCSnapshotResource takeSnapshot. self change: #one toReturn: 2. rev2 := MCSnapshotResource takeSnapshot. patch := rev2 patchRelativeToBase: rev1. self change: #one toReturn: 1.! ! !MCPatchTest methodsFor: 'running' stamp: 'cwp 8/2/2003 17:24'! tearDown self restoreMocks! ! !MCPatchTest methodsFor: 'tests' stamp: 'cwp 7/14/2003 15:31'! testPatchContents self assert: patch operations size = 1. self assert: patch operations first isModification. self assert: patch operations first definition selector = #one. ! ! !MCPatcher commentStamp: 'LaurentLaffont 3/31/2011 21:05'! I can add or remove or modify definitions. My main purpose is to generate monticello snapshot out of multiple snapshots or definitions by using my most used method #apply:to:.! !MCPatcher methodsFor: 'accessing' stamp: 'ab 7/6/2003 23:48'! patchedSnapshot ^ MCSnapshot fromDefinitions: definitions definitions! ! !MCPatcher methodsFor: 'operations' stamp: 'ab 6/1/2003 14:23'! modifyDefinition: baseDefinition to: targetDefinition self addDefinition: targetDefinition! ! !MCPatcher methodsFor: 'operations' stamp: 'ab 6/2/2003 00:46'! removeDefinition: aDefinition definitions remove: aDefinition! ! !MCPatcher methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithSnapshot: aSnapshot definitions := MCDefinitionIndex definitions: aSnapshot definitions! ! !MCPatcher methodsFor: 'adding' stamp: 'ab 6/2/2003 00:46'! addDefinition: aDefinition definitions add: aDefinition! ! !MCPatcher class methodsFor: 'instance-creation' stamp: 'ab 6/1/2003 14:22'! snapshot: aSnapshot ^ self new initializeWithSnapshot: aSnapshot! ! !MCPatcher class methodsFor: 'public' stamp: 'stephaneducasse 2/4/2006 20:47'! apply: aPatch to: aSnapshot | loader | loader := self snapshot: aSnapshot. aPatch applyTo: loader. ^ loader patchedSnapshot! ! !MCPermissionDenied commentStamp: ''! I am signalled when a repositroy cannot save or access a version.! !MCPermissionDenied methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:17'! repository ^ repository! ! !MCPermissionDenied methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2013 17:17'! repository: anObject repository := anObject! ! !MCPermissionDenied class methodsFor: 'signalling' stamp: 'CamilloBruni 4/11/2013 17:17'! signalFor: aRepository ^ self new repository: aRepository; signal! ! !MCPoolImportDefinition commentStamp: ''! A MCPoolImportDefinition represents a pool definition.! !MCPoolImportDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:51'! isPoolImport ^ true! ! !MCPoolImportDefinition methodsFor: 'testing' stamp: 'bf 8/29/2006 11:41'! isOrderDependend ^false! ! !MCPoolImportDefinition class methodsFor: 'accessing' stamp: 'cwp 7/7/2003 22:59'! type ^ #pool! ! !MCPostscriptDefinition commentStamp: 'TorstenBergmann 2/5/2014 13:47'! A postscript evaluated after load! !MCPostscriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:16'! sortKey ^ 'zzz' "force to the end so it gets loaded late"! ! !MCPostscriptDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:16'! postload self evaluate! ! !MCPostscriptDefinition class methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:04'! scriptSelector ^ #postscript! ! !MCPreambleDefinition commentStamp: 'TorstenBergmann 2/5/2014 13:47'! A preamble evaluated before load! !MCPreambleDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:15'! load super load. self evaluate! ! !MCPreambleDefinition class methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:04'! scriptSelector ^ #preamble! ! !MCPseudoFileStream commentStamp: ''! A pseudo file stream which can be used for updates.! !MCPseudoFileStream methodsFor: 'accessing' stamp: 'ar 4/14/2005 19:54'! localName: aString localName := aString! ! !MCPseudoFileStream methodsFor: 'accessing' stamp: 'ar 4/14/2005 19:54'! localName ^localName! ! !MCReader commentStamp: 'TorstenBergmann 2/5/2014 13:53'! Common superclass for Monticello readers! !MCReader methodsFor: 'accessing' stamp: 'CamilloBruni 4/24/2012 15:49'! stream stream closed ifTrue: [ stream open ]. ^ stream ! ! !MCReader methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! stream: aStream stream := aStream! ! !MCReader class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'! on: aStream name: aFileName | class | class := self readerClassForFileNamed: aFileName. ^ class ifNil: [self error: 'Unsupported format: ', aFileName] ifNotNil: [class on: aStream]! ! !MCReader class methodsFor: 'instance creation' stamp: 'avi 1/21/2004 19:02'! on: aStream ^ self new stream: aStream! ! !MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:00'! canReadFileNamed: fileName ^ (fileName endsWith: self extension)! ! !MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:01'! isAbstract ^ (self respondsTo: #extension) not! ! !MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:03'! readerClassForFileNamed: fileName ^ self concreteSubclasses detect: [:c | c canReadFileNamed: fileName] ifNone: [nil]! ! !MCReader class methodsFor: 'testing' stamp: 'avi 1/21/2004 19:01'! concreteSubclasses ^ self allSubclasses reject: [:c | c isAbstract]! ! !MCRemoval commentStamp: ''! A MCRemoval represents the removal of an entity of a given snapshot.! !MCRemoval methodsFor: 'accessing' stamp: 'cwp 11/27/2002 10:02'! definition ^ definition! ! !MCRemoval methodsFor: 'accessing' stamp: 'LucasGiudice 9/14/2013 15:08'! fromSource ^ definition diffSource! ! !MCRemoval methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'! toSource ^ ''! ! !MCRemoval methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 15:34'! selector ^ definition selector! ! !MCRemoval methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'! targetDefinition ^ nil! ! !MCRemoval methodsFor: 'testing' stamp: 'nk 2/25/2005 17:28'! isClassPatch ^definition isClassDefinition! ! !MCRemoval methodsFor: 'accessing' stamp: 'nk 2/25/2005 17:23'! targetClass ^ definition actualClass! ! !MCRemoval methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 15:10'! isMethodPatch ^ definition isMethodDefinition! ! !MCRemoval methodsFor: '*Komitter-UI' stamp: 'NicolaiHess 4/8/2014 20:03'! koClass | klass | klass := definition koClass. klass ifNil: [ ^ nil ]. definition addOperation: self on: klass. self isClassPatch ifTrue: [ klass removed: true ]. ^ klass! ! !MCRemoval methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 22:06'! koDestinationText ^ ''! ! !MCRemoval methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/26/2013 14:43'! koDefinition ^ (KomitDefinition definition: self definition) operation: self; removed: true; yourself! ! !MCRemoval methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/21/2013 22:04'! koSourceText ^ definition koSourceText ! ! !MCRemoval methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:38'! sourceString ^self fromSource asText addAttribute: TextEmphasis struckOut; addAttribute: TextColor blue; yourself! ! !MCRemoval methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 14:53'! basicApplyTo: anObject anObject removeDefinition: definition! ! !MCRemoval methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:24'! isRemoval ^ true! ! !MCRemoval methodsFor: 'accessing' stamp: 'ab 8/22/2003 02:26'! inverse ^ MCAddition of: definition! ! !MCRemoval methodsFor: 'accessing' stamp: 'ab 7/6/2003 00:05'! summarySuffix ^ ' (removed)'! ! !MCRemoval methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'! baseDefinition ^ definition! ! !MCRemoval methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! intializeWithDefinition: aDefinition definition := aDefinition! ! !MCRemoval methodsFor: '*Komitter-UI' stamp: 'BenjaminVanRyseghem 11/25/2013 18:20'! koMethod ^ (KomitMethod method: self definition) operation: self; removed: true; yourself! ! !MCRemoval class methodsFor: 'instance-creation' stamp: 'cwp 11/27/2002 10:03'! of: aDefinition ^ self new intializeWithDefinition: aDefinition! ! !MCRemovalPostscriptDefinition commentStamp: 'TorstenBergmann 2/5/2014 13:48'! A postscript evaluated after unloading/removing! !MCRemovalPostscriptDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:15'! unload super unload. self evaluate! ! !MCRemovalPostscriptDefinition class methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:04'! scriptSelector ^ #postscriptOfRemoval ! ! !MCRemovalPreambleDefinition commentStamp: 'TorstenBergmann 2/5/2014 13:48'! A preamble evaluated before unloading/removing! !MCRemovalPreambleDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:15'! unload super unload. self evaluate! ! !MCRemovalPreambleDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:14'! sortKey ^ 'zzz' "force to the end so it gets unloaded early"! ! !MCRemovalPreambleDefinition class methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:04'! scriptSelector ^ #preambleOfRemoval! ! !MCRepository commentStamp: 'TorstenBergmann 2/5/2014 13:54'! A Metacello repository! !MCRepository methodsFor: 'accessing' stamp: 'avi 10/9/2003 12:53'! description ^ self class name! ! !MCRepository methodsFor: 'converting' stamp: 'bkv 2/18/2004 20:48'! asCreationTemplate ^ self creationTemplate! ! !MCRepository methodsFor: 'testing' stamp: 'avi 8/31/2004 01:08'! alwaysStoreDiffs ^ storeDiffs ifNil: [false]! ! !MCRepository methodsFor: '*metacello-core' stamp: 'dkh 7/24/2012 21:46'! flushForScriptGet "noop" ! ! !MCRepository methodsFor: '*MonticelloGUI' stamp: 'bf 4/14/2005 17:30'! openAndEditTemplateCopy ^ self class fillInTheBlankConfigure: (self asCreationTemplate ifNil: [^nil])! ! !MCRepository methodsFor: 'notifying' stamp: 'avi 8/26/2004 14:27'! notificationForVersion: aVersion ^ MCVersionNotification version: aVersion repository: self! ! !MCRepository methodsFor: '*gofer-core-accessing' stamp: 'lr 12/11/2009 22:31'! goferPriority ^ 0! ! !MCRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! doAlwaysStoreDiffs storeDiffs := true! ! !MCRepository methodsFor: 'storing' stamp: 'CamilloBruni 4/21/2012 21:12'! prepareVersionForStorage: aVersion ^ self alwaysStoreDiffs ifTrue: [ aVersion asDiffAgainst: (self closestAncestorVersionFor: aVersion info ifNone: [^ aVersion])] ifFalse: [ aVersion ]! ! !MCRepository methodsFor: 'adding' stamp: 'abc 11/8/2013 17:11'! addTo: aRepository ^ aRepository addBasicRepository: self! ! !MCRepository methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/30/2013 22:20'! isCache ^ false! ! !MCRepository methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! metacelloProjectClassFor: aScriptEngine ^ MetacelloMCProject! ! !MCRepository methodsFor: 'accessing' stamp: 'bkv 2/18/2004 20:46'! creationTemplate ^ creationTemplate! ! !MCRepository methodsFor: 'printing' stamp: 'mas 9/24/2003 04:21'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self description; nextPut: $).! ! !MCRepository methodsFor: 'storing' stamp: 'avi 8/26/2004 14:20'! basicStoreVersion: aVersion self subclassResponsibility! ! !MCRepository methodsFor: 'interface' stamp: 'ab 8/21/2003 12:40'! includesVersionNamed: aString self subclassResponsibility! ! !MCRepository methodsFor: 'testing' stamp: 'nk 11/2/2003 10:55'! isValid ^true! ! !MCRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! creationTemplate: aString self creationTemplate ifNotNil: [ self error: 'Creation template already set for this MCRepository instance.' ]. creationTemplate := aString.! ! !MCRepository methodsFor: 'notifying' stamp: 'avi 8/26/2004 14:23'! notifyList ^ #()! ! !MCRepository methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! projectVersion: aString "noop" ! ! !MCRepository methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! closestAncestorVersionFor: anAncestry ifNone: errorBlock anAncestry breadthFirstAncestorsDo: [:ancestorInfo | (self versionWithInfo: ancestorInfo) ifNotNil: [:v | ^ v]]. ^ errorBlock value! ! !MCRepository methodsFor: 'comparing' stamp: 'ab 8/21/2003 12:36'! hash ^ self description hash! ! !MCRepository methodsFor: '*MonticelloGUI' stamp: 'lr 9/26/2003 20:03'! morphicOpen: aWorkingCopy self subclassResponsibility ! ! !MCRepository methodsFor: 'interface' stamp: 'ab 8/16/2003 18:22'! versionWithInfo: aVersionInfo ifAbsent: aBlock self subclassResponsibility ! ! !MCRepository methodsFor: 'accessing' stamp: 'bf 3/10/2005 23:01'! possiblyNewerVersionsOfAnyOf: someVersions ^#()! ! !MCRepository methodsFor: '*gofer-core-accessing' stamp: 'lr 12/9/2009 20:50'! goferReferences ^ #()! ! !MCRepository methodsFor: '*monticellofiletree-core' stamp: 'dkh 4/5/2012 11:15:15'! retrieveVersionsWithPackageNames: packageNames ^ self readableFileNames collect: [ :each | | name | name := (each copyUpToLast: $.) copyUpTo: $(. name last isDigit ifFalse: [ Array with: name with: '' with: '' with: each ] ifTrue: [ Array with: (packageNames add: (name copyUpToLast: $-)) with: ((name copyAfterLast: $-) copyUpTo: $.) with: ((name copyAfterLast: $-) copyAfter: $.) asInteger with: each "pkg name" "user" "version" ] ]! ! !MCRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! doNotAlwaysStoreDiffs storeDiffs := false! ! !MCRepository methodsFor: 'comparing' stamp: 'ab 8/21/2003 12:36'! = other ^ other species = self species and: [other description = self description]! ! !MCRepository methodsFor: 'notifying' stamp: 'stephaneducasse 2/4/2006 20:47'! sendNotificationsForVersion: aVersion | notification notifyList | notifyList := self notifyList. notifyList isEmpty ifFalse: [notification := self notificationForVersion: aVersion. notifyList do: [:ea | notification notify: ea]]! ! !MCRepository methodsFor: 'storing' stamp: 'SeanDeNigris 7/17/2012 15:49'! storeDependencies: aVersion MCCacheRepository uniqueInstance cacheAllFileNamesDuring: [self cacheAllFileNamesDuring: [aVersion allAvailableDependenciesDo: [:dep | (self includesVersionNamed: dep info name) ifFalse: [self storeVersion: dep]]]]! ! !MCRepository methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/22/2013 16:17'! isRemote ^ false! ! !MCRepository methodsFor: 'interface' stamp: 'avi 10/9/2003 12:42'! versionWithInfo: aVersionInfo ^ self versionWithInfo: aVersionInfo ifAbsent: [nil]! ! !MCRepository methodsFor: '*gofer-core-accessing' stamp: 'lr 12/12/2009 11:29'! goferVersionFrom: aVersionReference self error: 'Unable to load from ' , self printString! ! !MCRepository methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! asRepositorySpecFor: aMetacelloMCProject self subclassResponsibility! ! !MCRepository methodsFor: '*MonticelloGUI' stamp: 'lr 9/26/2003 20:03'! morphicOpen self morphicOpen: nil! ! !MCRepository methodsFor: 'storing' stamp: 'CamilloBruni 4/22/2012 21:11'! storeVersion: aVersion self basicStoreVersion: (self prepareVersionForStorage: aVersion). self sendNotificationsForVersion: aVersion! ! !MCRepository class methodsFor: '*MonticelloGUI' stamp: 'CamilloBruni 10/9/2012 20:03'! fillInTheBlankConfigure: aTemplateString | chunk repo | aTemplateString ifNil: [^ false]. chunk := UIManager default multiLineRequest: self fillInTheBlankRequest initialAnswer: aTemplateString answerHeight: 150. (chunk notNil and: [ chunk notEmpty ]) ifTrue: [repo := self readFrom: chunk readStream. repo creationTemplate: chunk]. ^ repo! ! !MCRepository class methodsFor: 'accessing' stamp: 'ab 8/21/2003 00:29'! description ^ nil! ! !MCRepository class methodsFor: 'request handling' stamp: 'bkv 2/18/2004 20:58'! fillInTheBlankRequest self subclassResponsibility.! ! !MCRepository class methodsFor: 'testing' stamp: 'ab 8/21/2003 12:59'! isAbstract ^ self description isNil! ! !MCRepository class methodsFor: 'accessing' stamp: 'bkv 2/18/2004 20:59'! creationTemplate self subclassResponsibility.! ! !MCRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:05'! fillInTheBlankConfigure ^ self fillInTheBlankConfigure: self creationTemplate ! ! !MCRepository class methodsFor: 'accessing' stamp: 'ab 8/21/2003 00:30'! allConcreteSubclasses ^ self withAllSubclasses reject: [:ea | ea isAbstract]! ! !MCRepository class methodsFor: 'instance creation' stamp: 'ab 7/24/2003 21:01'! morphicConfigure ^ self new! ! !MCRepositoryAuthorizationTest methodsFor: 'tests' stamp: 'SeanDeNigris 8/27/2012 10:07'! testStoredCredentials | repo registry | [ registry := MCServerRegistry uniqueInstance. registry on: self exampleServerUrl beUser: 'myusername' withPassword: 'mypassword'. repo := MCHttpRepository location: self exampleServerUrl. self assert: repo user equals: 'myusername'. self assert: repo password equals: 'mypassword'. ] ensure: [ registry removeCredentialsFor: self exampleServerUrl ].! ! !MCRepositoryAuthorizationTest methodsFor: 'asserting' stamp: 'SeanDeNigris 8/27/2012 11:22'! assert: registry on: serverUrlString hasUser: nameString withPassword: passwordString registry repositoryAt: serverUrlString credentialsDo: [ :user :password | self assert: nameString equals: user. self assert: passwordString equals: password ].! ! !MCRepositoryAuthorizationTest methodsFor: 'tests' stamp: 'SeanDeNigris 8/27/2012 10:06'! testEmptyCredentials | repo | "Although you can do this, it's easier to use #location:. See #testNoCredentials" repo := MCHttpRepository location: self exampleServerUrl user: '' password: ''. self assert: repo user equals: ''. self assert: repo password equals: ''.! ! !MCRepositoryAuthorizationTest methodsFor: 'accessing' stamp: 'SeanDeNigris 8/27/2012 10:13'! exampleServerUrl ^ 'http://www.squeaksource.com'.! ! !MCRepositoryAuthorizationTest methodsFor: 'tests' stamp: 'SeanDeNigris 8/27/2012 10:10'! testStoredCredentialsUsesMostSpecific | repo registry nestedRepo | [ nestedRepo := self exampleServerUrl, '/ss3'. registry := MCServerRegistry uniqueInstance. registry on: self exampleServerUrl beUser: 'myusername' withPassword: 'mypassword'. registry on: nestedRepo beUser: 'myss3username' withPassword: 'myss3password'. repo := MCHttpRepository location: nestedRepo. self assert: repo user equals: 'myss3username'. self assert: repo password equals: 'myss3password'. ] ensure: [ registry removeCredentialsFor: self exampleServerUrl; removeCredentialsFor: nestedRepo ].! ! !MCRepositoryAuthorizationTest methodsFor: 'tests' stamp: 'SeanDeNigris 8/27/2012 11:24'! testOverrideStoredCredentials | repo registry | [ registry := MCServerRegistry uniqueInstance. registry on: self exampleServerUrl beUser: 'myusername' withPassword: 'mypassword'. repo := MCHttpRepository location: self exampleServerUrl user: 'user_this_time' password: 'password_this_time'. self assert: repo user equals: 'user_this_time'. self assert: repo password equals: 'password_this_time'. self assert: registry on: self exampleServerUrl hasUser: 'myusername' withPassword: 'mypassword'. ] ensure: [ registry removeCredentialsFor: self exampleServerUrl ].! ! !MCRepositoryAuthorizationTest methodsFor: 'tests' stamp: 'SeanDeNigris 8/27/2012 10:07'! testNoCredentials | repo | repo := MCHttpRepository location: self exampleServerUrl. self assert: repo user equals: ''. self assert: repo password equals: ''.! ! !MCRepositoryError commentStamp: ''! I am an MC-specific errror! !MCRepositoryGroup commentStamp: ''! A singleton class, holds the list of repositories. Can look for a requested VersionInfo among its repositories.! !MCRepositoryGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/22/2013 14:51'! removeRepository: aRepository repositories remove: aRepository ifAbsent: []! ! !MCRepositoryGroup methodsFor: 'adding' stamp: 'abc 11/8/2013 17:10'! addRepositoryGroup: aRepositoryGroup aRepositoryGroup repositoriesDo: [ :each | each addTo: self ]! ! !MCRepositoryGroup methodsFor: '*Komitter-Models' stamp: 'ChristopheDemarey 4/1/2014 17:30'! remotes ^ self repositories select: [ :each | each isCache not ]! ! !MCRepositoryGroup methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! versionWithInfo: aVersionInfo ifNone: aBlock self repositoriesDo: [:ea | (ea versionWithInfo: aVersionInfo) ifNotNil: [:v | ^ v]]. ^aBlock value! ! !MCRepositoryGroup methodsFor: 'accessing' stamp: 'abc 6/20/2008 10:02'! useCache ^ useCache ifNil: [ useCache := true ]! ! !MCRepositoryGroup methodsFor: 'adding' stamp: 'abc 11/8/2013 17:09'! addBasicRepository: aRepository ((repositories includes: aRepository) or: [ aRepository == MCCacheRepository uniqueInstance ]) ifFalse: [ repositories add: aRepository. self class default addRepository: aRepository ]. ^ aRepository! ! !MCRepositoryGroup methodsFor: 'testing' stamp: 'avi 11/7/2003 00:20'! includes: aRepository ^ self repositories includes: aRepository! ! !MCRepositoryGroup methodsFor: 'accessing' stamp: 'NorbertHartl 6/20/2008 10:11'! disableCache useCache := false! ! !MCRepositoryGroup methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:03'! initialize super initialize. repositories := OrderedCollection new! ! !MCRepositoryGroup methodsFor: 'accessing' stamp: 'SeanDeNigris 7/17/2012 15:42'! repositories ^ (self useCache ifTrue: [Array with: MCCacheRepository uniqueInstance] ifFalse: [Array new]) , repositories select: #isValid! ! !MCRepositoryGroup methodsFor: 'adding' stamp: 'abc 11/8/2013 17:10'! addTo: aRepository ^ aRepository addRepositoryGroup: self! ! !MCRepositoryGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/22/2013 14:51'! removeHTTPRepositoryLocationNamed: aRepositoryString | httpRepo others | httpRepo := repositories select: [:each | each isKindOf: MCHttpRepository]. others := repositories reject: [:each | each isKindOf: MCHttpRepository]. repositories := others, (httpRepo reject: [:each | each locationWithTrailingSlash = aRepositoryString])! ! !MCRepositoryGroup methodsFor: 'interface' stamp: 'dvf 8/10/2004 23:02'! versionWithInfo: aVersionInfo ^self versionWithInfo: aVersionInfo ifNone: [ self error: 'Could not find version ', aVersionInfo name printString,'. Maybe you need to add a repository?' ]! ! !MCRepositoryGroup methodsFor: 'interface' stamp: 'EstebanLorenzano 5/3/2013 14:22'! includesVersionNamed: aString " check for existing version name in parallel over all repositories " | results | results := Array new: self repositories size. self repositories doWithIndex: [:repository :index | " fork of test for each repository " results at: index put: (repository includesVersionNamed: aString) ]. " check if any repository included the given versionName already" ^ results anySatisfy: [:result| result = true ] ! ! !MCRepositoryGroup methodsFor: 'enumerating' stamp: 'avi 11/7/2003 00:51'! repositoriesDo: aBlock self repositories do: [:ea | [aBlock value: ea] on: Error do: []]! ! !MCRepositoryGroup methodsFor: 'adding' stamp: 'abc 11/8/2013 17:09'! addRepository: aRepository aRepository addTo: self. ^ aRepository! ! !MCRepositoryGroup class methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! default ^ default ifNil: [default := self new]! ! !MCRepositoryGroup class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 9/8/2013 10:57'! withRepositories: aCollection | group | group := self new. aCollection do: [ :each | group addRepository: each ]. ^ group ! ! !MCRepositoryInspector commentStamp: 'TorstenBergmann 2/20/2014 15:53'! Inspector for a repository! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:07'! versionSelection ^ versions indexOf: selectedVersion! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! packageSelection: aNumber selectedPackage := aNumber isZero ifFalse: [ packages at: aNumber ]. versions := repository versionsAvailableForPackage: selectedPackage. self changed: #packageSelection; changed: #versionList! ! !MCRepositoryInspector methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:50'! setRepository: aRepository workingCopy: aWorkingCopy repository := aRepository. aWorkingCopy ifNotNil: [ selectedPackage := aWorkingCopy package]. self refresh! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! defaultExtent ^450@300! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:07'! packageSelection ^ packages indexOf: selectedPackage! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! sortedVersions | sorter | sorter := MCVersionSorter new. sorter addAllVersionInfos: versions. ^ sorter sortedVersionInfos select: [:ea | versions includes: ea]! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! versionSelection: aNumber aNumber isZero ifTrue: [ selectedVersion := nil ] ifFalse: [ selectedVersion := versions at: aNumber]. self changed: #versionSelection; changed: #summary! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! packageListMenu: aMenu ^aMenu! ! !MCRepositoryInspector methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! version ^ version ifNil: [version := repository versionWithInfo: selectedVersion]! ! !MCRepositoryInspector methodsFor: 'testing' stamp: 'avi 2/28/2004 20:20'! hasVersion ^ selectedVersion notNil! ! !MCRepositoryInspector methodsFor: 'accessing' stamp: 'avi 2/28/2004 20:20'! summary ^ selectedVersion ifNotNil: [selectedVersion summary] ifNil: ['']! ! !MCRepositoryInspector methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! refresh packages := repository packages. self changed: #packageList. self packageSelection: self packageSelection. ! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! buttonSpecs ^#(('Refresh' refresh 'refresh the version-list')) , super buttonSpecs! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! defaultLabel ^'Repository: ' , repository description! ! !MCRepositoryInspector methodsFor: 'actions' stamp: 'avi 9/17/2005 17:11'! load self hasVersion ifTrue: [super load. self version workingCopy repositoryGroup addRepository: repository].! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:57'! versionListMenu: aMenu ^aMenu! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! widgetSpecs ^#( ((buttonRow) (0 0 1 0) (0 0 0 30)) ((listMorph: package) (0 0 0.5 0.6) (0 30 0 0)) ((listMorph: version) (0.5 0 1 0.6) (0 30 0 0)) ((textMorph: summary) (0 0.6 1 1) (0 0 0 0)) )! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/29/2004 11:32'! versionList ^ self sortedVersions collect: [:ea | ea name]! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:09'! packageList ^ packages collect: [:ea | ea name]! ! !MCRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 4/24/2012 14:51'! repository: aFileBasedRepository workingCopy: aWorkingCopy ^self new setRepository: aFileBasedRepository workingCopy: aWorkingCopy; yourself! ! !MCRepositoryTest methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! saveSnapshot: aSnapshot named: aString | version | version := self versionWithSnapshot: aSnapshot name: aString. repository storeVersion: version. ^ version info ! ! !MCRepositoryTest methodsFor: 'asserting' stamp: 'ab 8/16/2003 18:07'! assertVersionInfos: aCollection self assert: repository allVersionInfos asSet = aCollection asSet! ! !MCRepositoryTest methodsFor: 'tests' stamp: 'avi 2/17/2004 03:24'! testIncludesName self deny: (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev1'). self saveSnapshot1. self assert: (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev1'). self deny: (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev2'). self saveSnapshot2. self assert: (repository includesVersionNamed: 'MonticelloTest-xxx.1-rev2').! ! !MCRepositoryTest methodsFor: 'actions' stamp: 'ab 7/19/2003 16:20'! saveSnapshot2 ^ self saveSnapshot: self snapshot2 named: 'rev2'! ! !MCRepositoryTest methodsFor: 'actions' stamp: 'ab 8/16/2003 17:46'! addVersion: aVersion self subclassResponsibility ! ! !MCRepositoryTest methodsFor: 'actions' stamp: 'ab 7/19/2003 16:20'! saveSnapshot1 ^ self saveSnapshot: self snapshot1 named: 'rev1'! ! !MCRepositoryTest methodsFor: 'building' stamp: 'stephaneducasse 2/4/2006 20:47'! versionWithSnapshot: aSnapshot name: aString | info | info := self mockVersionInfo: aString. ^ MCVersion package: (MCPackage new name: aString) info: info snapshot: aSnapshot! ! !MCRepositoryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testAddAndLoad | node | node := self addVersionWithSnapshot: self snapshot1 name: 'rev1'. self assert: (self snapshotAt: node) = self snapshot1. ! ! !MCRepositoryTest methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:32'! snapshotAt: aVersionInfo ^ (repository versionWithInfo: aVersionInfo) snapshot! ! !MCRepositoryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testLoadMissingNode | node | node := MCVersionInfo new. self assertMissing: node! ! !MCRepositoryTest methodsFor: 'building' stamp: 'ab 7/10/2003 01:03'! snapshot1 ^ (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: #('y'))))! ! !MCRepositoryTest methodsFor: 'asserting' stamp: 'ab 7/19/2003 23:59'! assertMissing: aVersionInfo self assert: (repository versionWithInfo: aVersionInfo) isNil! ! !MCRepositoryTest methodsFor: 'building' stamp: 'ab 7/10/2003 01:03'! snapshot2 ^ (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: #('x'))))! ! !MCRepositoryTest methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! addVersionWithSnapshot: aSnapshot name: aString | version | version := self versionWithSnapshot: aSnapshot name: aString. self addVersion: version. ^ version info! ! !MCRepositoryTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testStoreAndLoad | node node2 | node := self saveSnapshot1. node2 := self saveSnapshot2. self assert: (self snapshotAt: node) = self snapshot1. self assert: (self snapshotAt: node2) = self snapshot2.! ! !MCRepositoryTest class methodsFor: 'testing' stamp: 'ab 7/6/2003 12:45'! isAbstract ^ self = MCRepositoryTest! ! !MCSaveVersionDialog commentStamp: 'ab 9/8/2009 08:24'! Monticello's dialog that allows the user to change the version name and to enter a message for the commit log.! !MCSaveVersionDialog methodsFor: 'accessing' stamp: 'ab 8/24/2003 20:37'! versionName ^ name! ! !MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'ab 8/24/2003 20:41'! cancel self answer: nil! ! !MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'ab 8/24/2003 20:07'! defaultExtent ^ 400@300! ! !MCSaveVersionDialog methodsFor: 'log message history' stamp: 'BenjaminVanRyseghem 11/27/2013 12:53'! maxLogMessageHistory ^ self maxLogMessageHistory! ! !MCSaveVersionDialog methodsFor: 'log message history' stamp: 'BenjaminVanRyseghem 11/24/2013 14:39'! previousMessages ^ self class previousMessages! ! !MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'CamilloBruni 11/2/2012 16:00'! accept | version aMessage | version := (self findTextMorph: #versionName) text asString. aMessage := (self findTextMorph: #logMessage) text asString. self addAsLastLogMessage: aMessage. self answer: {version. aMessage}! ! !MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'ab 9/8/2009 08:45'! buttonSpecs ^ #((Accept accept 'accept version name and log message') (Cancel cancel 'cancel saving version') ('Old log messages...' oldLogMessages 're-use a previous log message') ) ! ! !MCSaveVersionDialog methodsFor: 'log message history' stamp: 'BenjaminVanRyseghem 11/27/2013 12:54'! addAsLastLogMessage: aString self class addAsLastLogMessage: aString! ! !MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'ab 9/8/2009 08:48'! oldLogMessages | list index | list := self previousMessages collect: [:s | s truncateWithElipsisTo: 30]. list ifEmpty: [UIManager default inform: 'No previous log message was entered'. ^ self]. index := UIManager default chooseFrom: list. "no comment was selected" index isZero ifTrue: [ ^ self ]. self logMessage: (self previousMessages at: index)! ! !MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'ab 9/8/2009 08:58'! defaultLabel ^ 'Edit Version Name and Log Message:'! ! !MCSaveVersionDialog methodsFor: 'accessing' stamp: 'ab 8/24/2003 20:41'! logMessage ^ message ifNil: ['empty log message']! ! !MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'CamilloBruni 2/4/2012 12:39'! setDefaultFocus (self findTextMorph: #logMessage) takeKeyboardFocus; selectAll; acceptAction: [ :contents| TextEditorDialogWindow autoAccept ifTrue: [ self accept ]].! ! !MCSaveVersionDialog methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! versionName: aString name := aString. self changed: #versionName! ! !MCSaveVersionDialog methodsFor: 'morphic ui' stamp: 'jrp 7/2/2005 10:33'! widgetSpecs ^ #( ((textMorph: versionName) (0 0 1 0) (0 0 0 30)) ((textMorph: logMessage) (0 0 1 1) (0 30 0 -30)) ((buttonRow) (0 1 1 1) (0 -40 0 0)) )! ! !MCSaveVersionDialog methodsFor: 'accessing' stamp: 'AlexandreBergel 8/1/2008 12:18'! logMessage: aString message := aString. self changed: #logMessage! ! !MCSaveVersionDialog class methodsFor: 'history' stamp: 'BenjaminVanRyseghem 11/24/2013 14:40'! previousMessages ^ PreviousMessages ifNil: [ PreviousMessages := OrderedCollection new]! ! !MCSaveVersionDialog class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallSaveAsIcon! ! !MCSaveVersionDialog class methodsFor: 'history' stamp: 'BenjaminVanRyseghem 11/27/2013 12:54'! addAsLastLogMessage: aString ((self previousMessages size > 0) and: [self previousMessages first = aString]) ifTrue: [ ^ self ]. self previousMessages addFirst: aString. (self previousMessages size > self maxLogMessageHistory) ifTrue: [self previousMessages removeLast]! ! !MCSaveVersionDialog class methodsFor: 'history' stamp: 'BenjaminVanRyseghem 11/27/2013 12:53'! maxLogMessageHistory ^ 15! ! !MCScanner commentStamp: 'LaurentLaffont 3/31/2011 21:08'! I scan / tokenize metadata (package name, version info, ancestry, dependencies, ...) found in .mcz files. For example, try: MCScanner scan: '(name ''MyPackage-ll.6'' message ''Fix bug xxx'' id ''b21dbd73-f1c3-2746-a3cc-92f1d4edea28'')' readStream! !MCScanner methodsFor: 'actions' stamp: 'CamilloBruni 7/6/2012 15:43'! nextArray stream next. "(" ^ Array streamContents: [:s | [ stream skipSeparators. (stream peek = $)) or: [stream atEnd] ] whileFalse: [ s nextPut: self next ]. stream next = $) ifFalse: [ self error: 'Unclosed array' ]]! ! !MCScanner methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! stream: aStream stream := aStream! ! !MCScanner methodsFor: 'actions' stamp: 'avi 1/22/2004 20:09'! nextString ^ stream nextDelimited: $'! ! !MCScanner methodsFor: 'actions' stamp: 'avi 1/22/2004 20:16'! nextSymbol ^ (String streamContents: [:s | [stream peek isAlphaNumeric] whileTrue: [s nextPut: stream next]]) asSymbol ! ! !MCScanner methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! next | c | stream skipSeparators. c := stream peek. c = $# ifTrue: [c := stream next; peek]. c = $' ifTrue: [^ self nextString]. c = $( ifTrue: [^ self nextArray]. c isAlphaNumeric ifTrue: [^ self nextSymbol]. self error: 'Unknown token type'. ! ! !MCScanner class methodsFor: 'public api' stamp: 'avi 1/22/2004 20:14'! scan: aStream ^ (self new stream: aStream) next! ! !MCScanner class methodsFor: 'public api' stamp: 'avi 1/22/2004 20:32'! scanTokens: aString "compatibility" ^ Array with: (self scan: aString readStream)! ! !MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:26'! test5 self assertScans: #((a) b)! ! !MCScannerTest methodsFor: 'asserting' stamp: 'avi 1/22/2004 20:23'! assertScans: anArray self assert: (MCScanner scan: anArray printString readStream) = anArray! ! !MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:28'! test6 self should: [MCScanner scan: '(a b' readStream] raise: Error! ! !MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:23'! test4 self assertScans: #(a '23' (x () ')''q' y12)).! ! !MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:22'! test2 self assertScans: 'it''s alive'! ! !MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:23'! test3 self assert: (MCScanner scan: '(a #b c)' readStream) = #(a #b c)! ! !MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:19'! test1 self assertScans: #(a '23' (x))! ! !MCScriptDefinition commentStamp: 'TorstenBergmann 2/5/2014 13:46'! Common superclass for script definitions! !MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:12'! description ^ Array with: packageName with: self scriptSelector! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/11/2012 17:01'! packageSet ^ RPackageSet named: packageName! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'bf 10/25/2005 19:05'! sortKey ^ '!!', self scriptSelector "force to the front so it gets loaded first"! ! !MCScriptDefinition methodsFor: 'installing' stamp: 'EstebanLorenzano 9/12/2012 13:35'! installScript: aString | sel pi | sel := (self scriptSelector, ':') asSymbol. pi := self packageSet. (pi respondsTo: sel) ifTrue: [pi perform: sel with: aString]! ! !MCScriptDefinition methodsFor: 'testing' stamp: 'bf 8/12/2009 22:55'! isScriptDefinition ^true! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:12'! summary ^ packageName, ' ', self scriptSelector! ! !MCScriptDefinition methodsFor: '*Deprecated30' stamp: 'EstebanLorenzano 9/14/2012 11:32'! packageInfo self deprecated: 'Use #packageSet' on: '14 September 2012' in: '2.0'. ^ PackageInfo named: packageName! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:10'! scriptSelector ^ self class scriptSelector! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 16:54'! script ^ script! ! !MCScriptDefinition methodsFor: 'comparing' stamp: 'avi 2/28/2005 16:55'! = aDefinition ^ (super = aDefinition) and: [script = aDefinition script]! ! !MCScriptDefinition methodsFor: 'visiting' stamp: 'bf 8/12/2009 21:41'! accept: aVisitor aVisitor visitScriptDefinition: self! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'bf 8/13/2009 00:09'! packageName ^ packageName! ! !MCScriptDefinition methodsFor: 'installing' stamp: 'MarcusDenker 5/2/2013 11:34'! evaluate self class compiler evaluate: script! ! !MCScriptDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:12'! load self installScript! ! !MCScriptDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:11'! installScript self installScript: script! ! !MCScriptDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:12'! unload self installScript: nil! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:04'! source ^ script! ! !MCScriptDefinition methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithScript: aString packageName: packageString script := aString. packageName := packageString! ! !MCScriptDefinition class methodsFor: 'instance-creation' stamp: 'bf 4/4/2005 12:20'! from: aPackageInfo ^ self script: (aPackageInfo perform: self scriptSelector) contents asString packageName: aPackageInfo name! ! !MCScriptDefinition class methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:00'! scriptSelector self subclassResponsibility! ! !MCScriptDefinition class methodsFor: 'accessing' stamp: 'bf 8/13/2009 00:25'! subclassForScriptSelector: selectorString ^self allSubclasses detect: [:ea | ea scriptSelector = selectorString]! ! !MCScriptDefinition class methodsFor: 'instance-creation' stamp: 'avi 2/28/2005 16:59'! script: aString packageName: packageString ^ self instanceLike: (self new initializeWithScript: aString packageName: packageString)! ! !MCScriptDefinition class methodsFor: 'instance-creation' stamp: 'bf 8/13/2009 00:24'! scriptSelector: selectorString script: aString packageName: packageString ^ (self subclassForScriptSelector: selectorString) script: aString packageName: packageString! ! !MCScriptParser commentStamp: ''! A MCScriptParser identifies script and add MCScriptDefinition. ! !MCScriptParser methodsFor: 'actions' stamp: 'MarcusDenker 5/18/2013 15:44'! addDefinitionsTo: aCollection | tokens definition | tokens := source parseLiterals. definition := MCScriptDefinition scriptSelector: tokens second allButLast script: tokens third packageName: tokens first third. aCollection add: definition.! ! !MCScriptParser class methodsFor: 'factory identification hook' stamp: 'bf 8/13/2009 00:07'! pattern ^'(PackageInfo named: *'! ! !MCSerializationTest methodsFor: 'testing' stamp: 'avi 1/19/2004 15:14'! testMczSerialization self assertVersionsMatchWith: MCMczWriter. self assertExtensionProvidedBy: MCMczWriter. self assertVersionInfosMatchWith: MCMczWriter. self assertDependenciesMatchWith: MCMczWriter.! ! !MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! assertVersionsMatchWith: writerClass | stream readerClass expected actual | readerClass := writerClass readerClass. expected := self mockVersion. stream := RWBinaryOrTextStream on: String new. writerClass fileOut: expected on: stream. actual := readerClass versionFromStream: stream reset. self assertVersion: actual matches: expected.! ! !MCSerializationTest methodsFor: 'mocks' stamp: 'stephaneducasse 2/4/2006 20:47'! mockDiffyVersion | repos workingCopy base next | repos := MCDictionaryRepository new. workingCopy := MCWorkingCopy forPackage: self mockPackage. workingCopy repositoryGroup addRepository: repos. MCRepositoryGroup default removeRepository: repos. base := self mockVersion. repos storeVersion: base. self change: #a toReturn: 'a2'. next := self mockVersionWithAncestor: base. ^ next asDiffAgainst: base ! ! !MCSerializationTest methodsFor: 'asserting' stamp: 'CamilloBruni 8/31/2013 20:23'! assertExtensionProvidedBy: aClass aClass readerClass extension! ! !MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! assertSnapshotsMatchWith: writerClass | readerClass expected stream actual | readerClass := writerClass readerClass. expected := self mockSnapshot. stream := RWBinaryOrTextStream on: String new. (writerClass on: stream) writeSnapshot: expected. actual := readerClass snapshotFromStream: stream reset. self assertSnapshot: actual matches: expected.! ! !MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! assertVersionInfosMatchWith: writerClass | stream readerClass expected actual | readerClass := writerClass readerClass. expected := self mockVersion. stream := RWBinaryOrTextStream on: String new. writerClass fileOut: expected on: stream. actual := readerClass versionInfoFromStream: stream reset. self assert: actual = expected info.! ! !MCSerializationTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! testMcdSerialization | stream expected actual | expected := self mockDiffyVersion. stream := RWBinaryOrTextStream on: String new. MCMcdWriter fileOut: expected on: stream. actual := MCMcdReader versionFromStream: stream reset. self assertVersion: actual matches: expected.! ! !MCSerializationTest methodsFor: 'testing' stamp: 'cwp 8/3/2003 18:43'! testStSerialization self assertSnapshotsMatchWith: MCStWriter.! ! !MCSerializationTest methodsFor: 'asserting' stamp: 'IgorStasenko 4/15/2011 17:17'! assertClass: readerClass providesServices: labels | services suffix | suffix := readerClass extension. self assert: (Smalltalk tools fileList isReaderNamedRegistered: readerClass name). services := readerClass fileReaderServicesForFile: 'foo' suffix: suffix. self assert: ((services collect: [:service | service buttonLabel]) includesAllOf: labels)! ! !MCSerializationTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! assertDependenciesMatchWith: writerClass | stream readerClass expected actual | readerClass := writerClass readerClass. expected := self mockVersionWithDependencies. stream := RWBinaryOrTextStream on: String new. writerClass fileOut: expected on: stream. actual := (readerClass on: stream reset) dependencies. self assert: actual = expected dependencies.! ! !MCServerCredentials commentStamp: ''! I store a username and password. ! !MCServerCredentials methodsFor: 'accessing' stamp: 'SeanDeNigris 8/26/2012 18:33'! password ^ password.! ! !MCServerCredentials methodsFor: 'private' stamp: 'SeanDeNigris 8/26/2012 18:25'! password: aString password := aString.! ! !MCServerCredentials methodsFor: 'private' stamp: 'SeanDeNigris 8/26/2012 18:25'! username: aString username := aString.! ! !MCServerCredentials methodsFor: 'accessing' stamp: 'SeanDeNigris 8/26/2012 18:33'! username ^ username.! ! !MCServerCredentials class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/11/2013 17:33'! user: nameString password: passwordString ^ self new username: nameString; password: passwordString; yourself.! ! !MCServerCredentials class methodsFor: '*Deprecated30' stamp: 'CamilloBruni 4/11/2013 17:34'! user: nameString hasPassword: passwordString self deprecated: 'use user:password:' on: '4/11/2013' in: 'Pharo 3.0'. ^ self new username: nameString; password: passwordString; yourself.! ! !MCServerRegistry commentStamp: 'TorstenBergmann 2/5/2014 13:56'! Registry for metacello servers! !MCServerRegistry methodsFor: 'initialization' stamp: 'SeanDeNigris 8/26/2012 18:18'! initialize super initialize. registry := Dictionary new.! ! !MCServerRegistry methodsFor: 'private' stamp: 'CamilloBruni 2/19/2013 18:30'! repositoryAt: urlString credentialsDo: aBlock | possibleMatches bestMatch | possibleMatches := registry associations select: [ :e | urlString beginsWith: e key ]. possibleMatches isEmpty ifTrue: [ ^ aBlock value: '' value: '' ]. bestMatch := possibleMatches inject: possibleMatches anyOne into: [ :last :new | ((new key asUrl path size > last key asUrl path size) "this is ugly, but URL always returns a path element, even an empty one..." or: [ last key asUrl path size = 1 and: [ last key asUrl path last isEmpty ]]) ifTrue: [ new ] ifFalse: [ last ]]. ^ aBlock value: bestMatch value username value: bestMatch value password.! ! !MCServerRegistry methodsFor: 'public' stamp: 'CamilloBruni 4/11/2013 17:33'! on: repositoryUrl beUser: nameString withPassword: passwordString | credentials | credentials := MCServerCredentials user: nameString password: passwordString. registry at: repositoryUrl put: credentials.! ! !MCServerRegistry methodsFor: '*Tests-Monticello' stamp: 'SeanDeNigris 8/27/2012 10:02'! removeCredentialsFor: aString registry removeKey: aString.! ! !MCServerRegistry class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/26/2012 11:11'! uniqueInstance ^ uniqueInstance ifNil: [ uniqueInstance := self new ].! ! !MCSliceInfo commentStamp: 'TorstenBergmann 2/20/2014 15:52'! A slice info! !MCSliceInfo methodsFor: 'accessing' stamp: 'AlainPlantec 10/25/2010 09:17'! issueSummary: aString issueSummary := aString. issueSummary := self usableIssueSummary. self changed: #issueSummary. self changed: #okUnabled. ! ! !MCSliceInfo methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/26/2013 21:12'! makeKomitSlice | name issue workingCopy | issue := self usableIssueNumber. issue isEmptyOrNil ifTrue: [^ nil]. name := self usableIssueSummary. name isEmptyOrNil ifTrue: [^ nil]. name := 'SLICE-Issue-' , issue asString , '-' , name. PackageInfo registerPackageName: name. workingCopy := MCWorkingCopy forPackage: (MCPackage new name: name). self includedPackages do: [:required | workingCopy requirePackage: required ]. ^ workingCopy! ! !MCSliceInfo methodsFor: 'accessing' stamp: 'AlainPlantec 10/25/2010 02:47'! issueNumber ^ issueNumber ifNil: ['']! ! !MCSliceInfo methodsFor: 'accessing' stamp: 'AlainPlantec 10/25/2010 02:49'! usableIssueNumber | s allowed | s := ''. allowed := ($0 to: $9). self issueNumber do: [:c | (allowed includes: c) ifTrue: [s := s , c asString]]. ^ s! ! !MCSliceInfo methodsFor: 'accessing' stamp: 'AlainPlantec 10/25/2010 00:27'! includedPackages ^ includedPackages ifNil: [#()]! ! !MCSliceInfo methodsFor: 'accessing' stamp: 'DamienCassou 4/12/2011 11:27'! includedPackages: aCollection includedPackages := aCollection. self changed: #okUnabled.! ! !MCSliceInfo methodsFor: 'accessing' stamp: 'AlainPlantec 10/25/2010 02:41'! issueSummary ^ issueSummary ifNil: ['']! ! !MCSliceInfo methodsFor: 'accessing' stamp: 'AlainPlantec 10/25/2010 09:17'! issueNumber: aString issueNumber := aString. issueNumber := self usableIssueNumber. self changed: #issueNumber. self changed: #okUnabled! ! !MCSliceInfo methodsFor: 'accessing' stamp: 'AlainPlantec 10/25/2010 09:27'! usableIssueSummary | s allowed | s := ''. allowed := ($A to: $Z) , ($a to: $z) , ($0 to: $9) , (Array with: $-). self issueSummary do: [:c | ({Character space. Character tab. $_} includes: c) ifTrue: [s := s , '-'] ifFalse: [(allowed includes: c) ifTrue: [s := s , c asString]]]. ^ s! ! !MCSliceInfo methodsFor: 'slice-making' stamp: 'AlainPlantec 10/25/2010 03:06'! makeSlice | name issue workingCopy workingCopyWrapper dirtyPackages | issue := self usableIssueNumber. issue isEmptyOrNil ifTrue: [^ nil]. name := self usableIssueSummary. name isEmptyOrNil ifTrue: [^ nil]. name := 'SLICE-Issue-' , issue asString , '-' , name. PackageInfo registerPackageName: name. workingCopy := MCWorkingCopy forPackage: (MCPackage new name: name). self includedPackages do: [:required | workingCopy requirePackage: required package]. ^ workingCopy! ! !MCSliceMaker commentStamp: 'AlainPlantec 9/27/2011 11:43'! MCSliceMaker is a dialog to help you making slices. It allows you to enter the slice number, the summary and to directly select dependent dirty packages. Then a slice package is added for you in the working copy browser from which it is opened. Just copy-paste issue number and summary. All is formated for you. Instance Variables info: okToDoSlice: window: info - It is the model for the user interface okToDoSlice - true if the OK button is clicked, it is to avoid slice making in case of cancel and in the case where the close button of the window has been clicked window - my window ! !MCSliceMaker methodsFor: 'user interface' stamp: 'AlainPlantec 10/25/2010 02:16'! ok self okToDoSlice: true. window delete! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'IgorStasenko 1/16/2014 13:12'! window | sliceInfoRow buttonsRow okBtn cancelBtn issueNumberEntry issueSummaryEntry tree treeMorph issueSummaryDownloader | window := StandardWindow new model: self. window title: ' Slice Maker' translated. issueNumberEntry := self issueNumberEntryOn: window. issueSummaryDownloader := self issueSummaryDownloaderButtonOn: window. issueSummaryEntry := self issueSummaryOn: window. sliceInfoRow := PanelMorph new changeTableLayout; cellInset: 10 @ 4; layoutInset: 4 @ 4; listDirection: #leftToRight; hResizing: #shrinkWrap; vResizing: #shrinkWrap. sliceInfoRow addAllMorphs: {issueNumberEntry. window newLabel: '-'. issueSummaryDownloader. issueSummaryEntry}. buttonsRow := PanelMorph new changeTableLayout; cellInset: 10 @ 4; layoutInset: 4 @ 4; listDirection: #rightToLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap. okBtn := window newOKButtonFor: self getEnabled: #okUnabled. cancelBtn := window newCancelButtonFor: self. okBtn isDefault: true. self info addDependent: okBtn. buttonsRow addAllMorphs: {cancelBtn. okBtn}. window addMorph: sliceInfoRow fullFrame: ( (0 @ 0 corner: 1 @ 0) asLayoutFrame bottomOffset: sliceInfoRow height). tree := MorphTreeModel new rootItems: self rootItems; beCheckList; autoMultiSelection: true; wrapBlockOrSelector: #packageNameWithStar; headerLabel: 'Dirty Packages to be included in the slice'; yourself. tree onSelectionChangeSend: #selectionChanged: to: self. treeMorph := tree defaultTreeMorph buildContents; "selectAll; " "hResizing: #spaceFill;" vResizing: #spaceFill; yourself. window addMorph: treeMorph fullFrame: (LayoutFrame identity topOffset: sliceInfoRow height ; bottomOffset: buttonsRow height negated). window addMorph: buttonsRow fullFrame: ((0 @ 1 corner: 1 @ 1) asLayoutFrame topOffset: buttonsRow height negated). ^ window! ! !MCSliceMaker methodsFor: 'actions' stamp: 'DamienCassou 4/27/2012 16:30'! downloadIssueSummaryFailed self info issueSummary: '------'! ! !MCSliceMaker methodsFor: 'selecting' stamp: 'BenjaminVanRyseghem 9/17/2011 19:29'! update: aSymbol aSymbol = #okUnabled ifTrue: [ self changed: #okUnabled ]. super update: aSymbol! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'DamienCassou 4/27/2012 15:05'! issueSummaryOn: canvas | issueSummaryEntry | issueSummaryEntry := canvas window newAutoAcceptTextEntryFor: self info get: #issueSummary set: #issueSummary: class: String getEnabled: nil help: 'An identification label for the slice. Just copy-paste the Google issue Summary here' translated. issueSummaryEntry ghostText: 'Just paste the issue summary here'. ^ issueSummaryEntry! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'AlainPlantec 10/25/2010 01:35'! cancel self noSlice. window delete! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'DamienCassou 4/27/2012 15:07'! issueSummaryDownloaderButtonOn: canvas |button| button := canvas newButtonFor: self action: #downloadIssueSummary label: 'grab' help: 'Grab issue summary from tracker'. ^ button ! ! !MCSliceMaker methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 3/22/2013 14:33'! downloadIssueSummary | title | title := ZnClient new url: 'http://bugs.pharo.org/issues/name/', self issueIdString; get. self info issueSummary: title! ! !MCSliceMaker methodsFor: 'accessing' stamp: 'CamilloBruni 10/17/2012 10:17'! issueIdString ^ self issueNumber asString ! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'IgorStasenko 1/16/2014 13:09'! rootItems ^ (MCWorkingCopy allManagers sort: [ :a :b | "sort putting modified packages first in the list" (a modified = b modified) ifTrue: [ a package name <= b package name ] ifFalse: [ a modified ] ])! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'AlainPlantec 10/25/2010 01:35'! noSlice info := nil. ! ! !MCSliceMaker methodsFor: 'initialization' stamp: 'AlainPlantec 10/11/2011 11:56'! initialize super initialize. info := MCSliceInfo new. info addDependent: self. ! ! !MCSliceMaker methodsFor: 'accessing' stamp: 'AlainPlantec 10/25/2010 02:16'! okToDoSlice: aBoolean okToDoSlice := aBoolean! ! !MCSliceMaker methodsFor: 'accessing' stamp: 'AlainPlantec 10/25/2010 02:16'! resultInfo ^ self okToDoSlice ifTrue: [info]! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'AlainPlantec 10/11/2011 11:58'! openFor: anotherWindow window := self window. anotherWindow openModal: window. ^ self resultInfo! ! !MCSliceMaker methodsFor: 'selecting' stamp: 'AlainPlantec 10/11/2011 12:01'! selectionChanged: aSelectionChangedAnnounce | allManagers selectedPackages sel | allManagers := MCWorkingCopy allManagers. sel := aSelectionChangedAnnounce selection selectedItemOrItemsOrNil. selectedPackages := sel ifNil: [#()] ifNotNil: [sel collect: [:n | allManagers detect: [:m | m = n]]]. self info includedPackages: selectedPackages. self changed: #okUnabled! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'DamienCassou 4/27/2012 14:55'! issueNumberEntryOn: canvas | issueNumberEntry | issueNumberEntry := canvas newAutoAcceptTextEntryFor: self info get: #issueNumber set: #issueNumber: class: String getEnabled: nil help: 'Google project issue number' translated. issueNumberEntry hResizing: #rigid. issueNumberEntry width: (StandardFonts defaultFont widthOfString: 'Issue number0'). issueNumberEntry ghostText: 'Issue number'. ^ issueNumberEntry! ! !MCSliceMaker methodsFor: 'accessing' stamp: 'AlainPlantec 10/25/2010 00:26'! info ^ info ! ! !MCSliceMaker methodsFor: 'accessing' stamp: 'CamilloBruni 10/17/2012 10:17'! issueNumber "Return the entered issue number. Use #asInteger to trim excess data from the user input, such as whitespaces." ^ self info issueNumber asInteger! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'DamienCassou 4/12/2011 11:27'! okUnabled ^ self info usableIssueNumber isEmptyOrNil not and: [self info usableIssueSummary isEmptyOrNil not and: [self info includedPackages isEmptyOrNil not]]! ! !MCSliceMaker methodsFor: 'accessing' stamp: 'AlainPlantec 10/25/2010 02:15'! okToDoSlice ^ okToDoSlice ifNil: [false]! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'AlainPlantec 10/11/2011 13:32'! initialExtent ^ 800@400! ! !MCSliceMaker class methodsFor: 'opening' stamp: 'AlainPlantec 10/25/2010 02:09'! openFor: anotherWindow ^ self new openFor: anotherWindow! ! !MCSmalltalkhubRepository commentStamp: ''! I am specialized version of an MCHttpRepository for http://smalltalkhub.com. I support a faster mcz listing that does not rely on parsing an html size.! !MCSmalltalkhubRepository methodsFor: 'interface' stamp: 'CamilloBruni 9/14/2012 17:11'! includesFileNamed: aString "avoid the slower default method and simply do a head request " self httpClient numberOfRetries: 0; ifFail: [ :exception| exception response code = 404 ifTrue: [ ^ false ]. exception pass]; head: (self urlForFileNamed: aString). ^ true! ! !MCSmalltalkhubRepository methodsFor: 'converting' stamp: 'CamilloBruni 9/14/2012 17:20'! asCreationTemplate ^self class creationTemplateOwner: self owner project: self project user: user password: password! ! !MCSmalltalkhubRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 18:36'! project: aString project := aString! ! !MCSmalltalkhubRepository methodsFor: 'accessing' stamp: 'CamilloBruni 4/6/2013 23:12'! location: aUrlString | pathSegments | (self class isResponsibleFor: aUrlString) ifFalse: [ Error signal: 'Please provide a smalltalkhub url' ]. "extract the smalltalkhub properties from the path part in the given URL" pathSegments := aUrlString asZnUrl pathSegments reject: [ :each | each = 'mc' ]. self owner: pathSegments first. self project: pathSegments second.! ! !MCSmalltalkhubRepository methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/23/2013 12:43'! koRemote ^ KomitSmalltalkhubRemote new remote: self; yourself! ! !MCSmalltalkhubRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2012 17:25'! location ^ 'http://smalltalkhub.com/mc/', self owner, '/', self project, '/main/' ! ! !MCSmalltalkhubRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2012 17:21'! project ^ project! ! !MCSmalltalkhubRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2012 17:21'! owner ^ owner! ! !MCSmalltalkhubRepository methodsFor: 'interface' stamp: 'CamilloBruni 10/15/2012 13:36'! parseFileNamesFromStream: aNewLineDelimitedString ^ aNewLineDelimitedString ifNil: [ ^ OrderedCollection new ] ifNotNil: [ aNewLineDelimitedString subStrings: String crlf ]! ! !MCSmalltalkhubRepository methodsFor: 'interface' stamp: 'CamilloBruni 6/15/2013 10:14'! loadAllFileNames | client | client := self httpClient. client ifFail: [ :exception | self error: 'Could not access ', self location, ': ', exception printString ]; url: self locationWithTrailingSlash; queryAt: 'format' put: 'raw'; get. self assertNonBinaryResponse: client response. ^ self parseFileNamesFromStream: client contents! ! !MCSmalltalkhubRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2012 17:24'! locationWithTrailingSlash ^ self location! ! !MCSmalltalkhubRepository methodsFor: 'interface' stamp: 'CamilloBruni 9/14/2012 16:37'! includesVersionNamed: aString "directly do a filename check since squeaksource only stores mcz" ^ self includesFileNamed: aString, '.mcz'! ! !MCSmalltalkhubRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 18:36'! owner: aString owner := aString! ! !MCSmalltalkhubRepository class methodsFor: 'instance creation' stamp: 'CamilloBruni 10/9/2012 14:54'! owner: owner project: project ^ self owner: owner project: project user: String empty password: String empty! ! !MCSmalltalkhubRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2012 16:38'! description ^ 'smalltalkhub.com'! ! !MCSmalltalkhubRepository class methodsFor: 'creation template' stamp: 'CamilloBruni 9/14/2012 17:23'! creationTemplateOwner: owner project: project user: user password: password ^ String streamContents: [ :s| s nextPutAll: self name; cr; tab; nextPutAll: 'owner: '; print: owner; cr; tab; nextPutAll: 'project: '; print: project; cr; tab; nextPutAll: 'user: '; print: user; cr; tab; nextPutAll: 'password: '; print: password ].! ! !MCSmalltalkhubRepository class methodsFor: 'creation template' stamp: 'CamilloBruni 9/14/2012 17:15'! creationTemplate ^self creationTemplateOwner: '' project: '' user: '' password: '' ! ! !MCSmalltalkhubRepository class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/14/2012 17:22'! owner: owner project: project user: user password: password ^ self new owner: owner; project: project; user: user; password: password; yourself! ! !MCSmalltalkhubRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2013 14:31'! baseURL ^ self smalltalkhubUrl, 'mc/'! ! !MCSmalltalkhubRepository class methodsFor: 'testing' stamp: 'CamilloBruni 5/7/2013 14:31'! isResponsibleFor: aUrl ^ aUrl includesSubstring: self hostName! ! !MCSmalltalkhubRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2013 14:30'! smalltalkhubUrl ^ 'http://', self hostName, '/'! ! !MCSmalltalkhubRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2013 14:31'! hostName ^ 'smalltalkhub.com'! ! !MCSnapshot commentStamp: ''! MCSnapshot represents a list of entities compared to a given base entities. It holds a list of definitions (instances of MCDefinition subclasses). It can install these entities or update a package.! !MCSnapshot methodsFor: 'accessing' stamp: 'ab 12/4/2002 18:09'! definitions ^ definitions! ! !MCSnapshot methodsFor: 'comparing' stamp: 'ab 7/10/2003 01:05'! hash ^ definitions asArray hash! ! !MCSnapshot methodsFor: 'comparing' stamp: 'MarianoMartinezPeck 5/30/2012 17:12'! = other self == other ifTrue: [ ^ true ]. self species = other species ifFalse: [ ^ false ]. ^ definitions asArray = other definitions asArray! ! !MCSnapshot methodsFor: 'loading' stamp: 'ab 7/6/2003 23:31'! install MCPackageLoader installSnapshot: self! ! !MCSnapshot methodsFor: 'patching' stamp: 'ab 7/7/2003 00:37'! patchRelativeToBase: aSnapshot ^ MCPatch fromBase: aSnapshot target: self! ! !MCSnapshot methodsFor: 'loading' stamp: 'ab 7/7/2003 12:11'! updatePackage: aPackage MCPackageLoader updatePackage: aPackage withSnapshot: self! ! !MCSnapshot methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithDefinitions: aCollection definitions := aCollection.! ! !MCSnapshot class methodsFor: 'instance-creation' stamp: 'ab 7/6/2003 23:48'! fromDefinitions: aCollection ^ self new initializeWithDefinitions: aCollection! ! !MCSnapshot class methodsFor: 'instance-creation' stamp: 'ab 7/6/2003 23:48'! empty ^ self fromDefinitions: #()! ! !MCSnapshotBrowser commentStamp: 'TorstenBergmann 2/20/2014 15:52'! Browser for snapshots! !MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:53'! loadCategorySelection "Load the entire selected category" categorySelection ifNil: [ ^self ]. self methodsForSelectedClassCategory do: [ :m | m load ].! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 18:28'! classSelection ^ classSelection ifNil: [0] ifNotNil: [self visibleClasses indexOf: classSelection]! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 15:48'! packageClasses ^ items select: [:ea | ea isClassDefinition]! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 20:26'! methodSelection ^ methodSelection ifNil: [0] ifNotNil: [self visibleMethods indexOf: methodSelection]! ! !MCSnapshotBrowser methodsFor: 'menus' stamp: 'GuillermoPolito 1/11/2012 22:56'! methodListMenu: aMenu super methodListMenu: aMenu. ( self selectedMessageName notNil and: [ methodSelection isLoadable ] ) ifTrue: [ aMenu addLine; add: 'Load method' translated action: #loadMethodSelection ]. ^ aMenu! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 4/27/2010 11:50'! methodsForSelectedClass ^ items select: [:ea | (ea className = classSelection) and: [ea isMethodDefinition and: [ea classIsMeta = self switchIsClass]]].! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'cwp 7/12/2003 18:05'! switchIsClass ^ switch = #class! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'nk 11/10/2003 21:29'! selectedMessageCategoryName ^protocolSelection! ! !MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'bf 5/27/2005 19:33'! buttonSpecs ^ #(('instance' switchBeInstance 'show instance' buttonEnabled switchIsInstance) ('?' switchBeComment 'show comment' buttonEnabled switchIsComment) ('class' switchBeClass 'show class' buttonEnabled switchIsClass))! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'lr 3/14/2010 21:13'! selectedClassOrMetaClass | class | classSelection ifNil: [ ^ nil ]. class := Smalltalk globals at: classSelection ifAbsent: [ ^ nil ]. ^ self switchIsClass ifTrue: [ class class ] ifFalse: [ class ]! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'cwp 7/12/2003 18:04'! switchIsComment ^ switch = #comment.! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 19:35'! protocolSelection ^ protocolSelection ifNil: [0] ifNotNil: [self visibleProtocols indexOf: protocolSelection]! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 18:33'! categoryList ^ self visibleCategories! ! !MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:45'! loadMethodSelection methodSelection ifNil: [ ^self ]. methodSelection load.! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 20:20'! classList ^ self visibleClasses! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'CamilloBruni 7/16/2013 06:55'! visibleProtocols | methods protocols | self switchIsComment ifTrue: [^ Array new]. methods := self methodsForSelectedClass. protocols := (methods collect: [:ea | ea category]) asSet asSortedCollection. protocols add: AllProtocol defaultName. ^ protocols ! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'bf 8/21/2012 21:38'! hasExtensions ^self extensionClassNames notEmpty! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 4/27/2010 11:51'! methodsForSelectedClassCategory | visibleClasses | visibleClasses := self visibleClasses. ^ items select: [:ea | (visibleClasses includes: ea className) and: [ea isMethodDefinition and: [ea classIsMeta = self switchIsClass]]].! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 19:07'! protocolList ^ self visibleProtocols! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! switchBeComment switch := #comment. self signalSwitchChanged.! ! !MCSnapshotBrowser methodsFor: 'text' stamp: 'cwp 7/11/2003 00:30'! text: aTextOrString self changed: #text! ! !MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:46'! loadProtocolSelection protocolSelection ifNil: [ ^self ]. self methodsForSelectedProtocol do: [ :m | m load ].! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'nk 10/11/2003 16:45'! selectedMessageName ^methodSelection ifNotNil: [^ methodSelection selector ]. ! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 18:33'! categorySelection ^ categorySelection ifNil: [0] ifNotNil: [self visibleCategories indexOf: categorySelection]! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'ab 7/18/2003 15:48'! visibleClasses ^ categorySelection = self extensionsCategory ifTrue: [self extensionClassNames] ifFalse: [self packageClasses select: [:ea | ea category = categorySelection] thenCollect: [:ea | ea className]].! ! !MCSnapshotBrowser methodsFor: 'menus' stamp: 'tbn 7/6/2010 17:09'! classListMenu: aMenu classSelection ifNil: [ ^aMenu ]. super classListMenu: aMenu. aMenu addLine; add: ('Load class {1}' translated format: {classSelection}) action: #loadClassSelection. ^ aMenu! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'cwp 7/10/2003 20:23'! extensionClassNames ^ (self allClassNames difference: self packageClassNames) asSortedCollection! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/5/2003 23:41'! extensionsCategory ^ '*Extensions'! ! !MCSnapshotBrowser methodsFor: 'menus' stamp: 'tbn 7/6/2010 17:09'! categoryListMenu: aMenu categorySelection ifNotNil: [aMenu add: (categorySelection = '*Extensions' ifTrue: ['Load all extension methods' translated] ifFalse: ['Load class category {1}' translated format: {categorySelection}]) action: #loadCategorySelection]. ^ aMenu! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! switchIsInstance switch ifNil: [switch := #instance]. ^ switch = #instance.! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'CamilloBruni 7/15/2013 22:26'! visibleCategories ^ ((self packageOrganizations gather: [ :ea | ea categories ]), (self packageClasses collect: [ :ea | ea category ]), (self hasExtensions ifTrue: [{ self extensionsCategory }] ifFalse: [#()])) asSet asSortedCollection! ! !MCSnapshotBrowser methodsFor: 'text' stamp: 'lr 3/20/2010 21:25'! metaclassDefinitionString | defs | defs := items select: [:ea | (ea isClassDefinition or: [ea isClassDefinitionExtension]) and: [ea className = classSelection]]. defs isEmpty ifTrue: [^ 'This class is defined elsewhere.']. ^ String streamContents: [:stream | defs asArray sort do: [:ea | ea printClassDefinitionOn: stream] separatedBy: [stream nextPut: $.; cr] ].! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'MarcusDenker 3/25/2013 13:08'! categorySelection: aNumber categorySelection := aNumber = 0 ifFalse: [self visibleCategories at: aNumber]. self classSelection: 0. self changed: #categorySelection; changed: #classList. ! ! !MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:29'! defaultExtent ^ 650@400.! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 15:48'! packageClassNames ^ self packageClasses collect: [:ea | ea className]! ! !MCSnapshotBrowser methodsFor: 'text' stamp: 'GabrielOmarCotelli 12/3/2013 17:51'! classCommentString ^ items detect: [ :ea | ea isClassDefinition and: [ ea className = classSelection ] ] ifFound: [ :classDefinition | classDefinition comment ] ifNone: [ '' ]! ! !MCSnapshotBrowser methodsFor: 'menus' stamp: 'tbn 7/6/2010 17:10'! protocolListMenu: aMenu protocolSelection ifNotNil: [aMenu add: ('Load protocol ''{1}''' translated format: {protocolSelection}) action: #loadProtocolSelection ]. ^ aMenu! ! !MCSnapshotBrowser methodsFor: 'text' stamp: 'lr 3/20/2010 21:05'! text self switchIsComment ifTrue: [ ^ self classCommentString ]. methodSelection ifNotNil: [ ^ methodSelection source ]. protocolSelection ifNotNil: [ ^ '' ]. classSelection ifNotNil: [ ^ self switchIsClass ifTrue: [ self metaclassDefinitionString ] ifFalse: [ self classDefinitionString ] ]. categorySelection ifNil: [ ^ self scriptDefinitionString ]. ^ ''! ! !MCSnapshotBrowser methodsFor: 'menus' stamp: 'cwp 7/10/2003 18:03'! inspectSelection ^ self methodSelection inspect! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'MarcusDenker 3/25/2013 13:09'! protocolSelection: anInteger protocolSelection := (anInteger = 0 ifFalse: [self visibleProtocols at: anInteger]). self methodSelection: 0. self changed: #protocolSelection; changed: #methodList.! ! !MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'MarcusDenker 3/25/2013 13:05'! widgetSpecs ^#( ((listMorph: category) (0 0 0.25 0.4)) ((listMorph: class) (0.25 0 0.50 0.4) (0 0 0 -30)) ((listMorph: protocol) (0.50 0 0.75 0.4)) ((listMorph:selection:menu:keystroke: methodList methodSelection methodListMenu: methodListKey:from:) (0.75 0 1 0.4)) ((buttonRow) (0.25 0.4 0.5 0.4) (0 -30 0 0)) ((textMorph: text) (0 0.4 1 1)) ) ! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'StephaneDucasse 12/28/2012 19:55'! packageOrganizations ^ items select: [:ea | ea isOrganizationDefinition]! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'cwp 7/12/2003 18:57'! signalSwitchChanged self protocolSelection: 0. self changed: #switchIsInstance; changed: #switchIsComment; changed: #switchIsClass; changed: #protocolList; changed: #methodList; changed: #text.! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! methodsForSelectedProtocol | methods | protocolSelection ifNil: [^ Array new]. methods := self methodsForSelectedClass asOrderedCollection. (protocolSelection = '-- all --') ifFalse: [methods removeAllSuchThat: [:ea | ea category ~= protocolSelection]]. ^ methods ! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'lr 3/14/2010 21:13'! selectedClass classSelection ifNil: [ ^ nil ]. ^ Smalltalk globals at: classSelection ifAbsent: [ nil ]! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! switchBeInstance switch := #instance. self signalSwitchChanged.! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'MarcusDenker 3/25/2013 13:08'! methodSelection: aNumber methodSelection := aNumber = 0 ifFalse: [self visibleMethods at: aNumber]. self changed: #methodSelection; changed: #text.! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! switchBeClass switch := #class. self signalSwitchChanged.! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/13/2003 02:11'! methodList ^ self visibleMethods collect: [:ea | ea selector]! ! !MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/30/2004 15:06'! loadClassSelection classSelection ifNil: [ ^self ]. (self packageClasses detect: [ :ea | ea className = classSelection ] ifNone: [ ^self ]) load. self methodsForSelectedClass do: [ :m | m load ].! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 19:46'! visibleMethods ^ classSelection ifNil: [#()] ifNotNil: [self methodsForSelectedProtocol]! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'MarcusDenker 3/25/2013 13:08'! classSelection: aNumber classSelection := aNumber = 0 ifFalse: [self visibleClasses at: aNumber]. self protocolSelection: 0. self changed: #classSelection; changed: #protocolList; changed: #methodList. ! ! !MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 21:31'! defaultLabel ^ 'Snapshot Browser'! ! !MCSnapshotBrowser methodsFor: 'text' stamp: 'tfel 8/28/2009 20:42'! scriptDefinitionString | defs | defs := items select: [:ea | ea isScriptDefinition]. defs isEmpty ifTrue: [^'(package defines no scripts)']. ^ String streamContents: [:stream | defs asArray sort do: [:ea | stream nextPutAll: '---------- package '; nextPutAll: ea scriptSelector; nextPutAll: ' ----------'; cr; nextPutAll: ea script; cr] separatedBy: [stream cr]].! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! snapshot: aSnapshot items := aSnapshot definitions asSortedCollection. self categorySelection: 0.! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'MarcusDenker 8/18/2010 11:40'! allClassNames ^ (items select: [:ea | (ea isOrganizationDefinition | ea isScriptDefinition) not] thenCollect: [:ea | ea className]) asSet. ! ! !MCSnapshotBrowser methodsFor: 'text' stamp: 'stephaneducasse 2/4/2006 20:47'! classDefinitionString | defs | defs := items select: [:ea | (ea isClassDefinition or: [ea isClassDefinitionExtension]) and: [ea className = classSelection]]. defs isEmpty ifTrue: [^ 'This class is defined elsewhere.']. ^ String streamContents: [:stream | defs asArray sort do: [:ea | ea printDefinitionOn: stream] separatedBy: [stream nextPut: $.; cr] ].! ! !MCSnapshotBrowser class methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 18:03'! forSnapshot: aSnapshot ^ self new snapshot: aSnapshot! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:58'! allMethods ^ MCSnapshotResource current definitions select: [:def | def isMethodDefinition] thenCollect: [:def | def selector] ! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:46'! allCategories ^ Array with: model extensionsCategory with: self mockCategoryName.! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/13/2003 02:53'! falsehoodMethodSource ^ 'falsehood ^ false'! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'stephaneducasse 2/4/2006 20:47'! morphsOfClass: aMorphClass | morphs | morphs := OrderedCollection new. morph allMorphsDo: [:m | (m isKindOf: aMorphClass) ifTrue: [morphs add: m]]. ^ morphs! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 13:04'! testClassSelected self selectMockClassA. self assertAListMatches: self allCategories. self assertAListMatches: self definedClasses. self assertAListMatches: self classAProtocols. self denyAListIncludesAnyOf: self allMethods. self assertTextIs: self classADefinitionString.! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 09:19'! findButtonWithLabel: aString ^ self buttonMorphs detect: [:m | m label = aString]! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 09:14'! testThreeButtons self assertButtonExists: 'instance'. self assertButtonExists: '?'. self assertButtonExists: 'class'.! ! !MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'CamilloBruni 7/16/2013 06:52'! assertAListMatches: strings | lists | lists := self listMorphs collect: #getList. lists detect: [ :list| (list size = strings size) and: [list includesAllOf: strings]] ifNone: [ self fail: 'Could not find all "', strings asArray asString, '" ', 'in any of "', (lists collect: #asArray) asArray asString, '"' ].! ! !MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'oscar.nierstrasz 6/5/2010 14:55'! assertTextIs: aString self assert: self textMorph contents = aString.! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'! classAProtocols ^ self protocolsForClass: self mockClassA.! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'oscar.nierstrasz 6/5/2010 14:58'! classAclassDefinitionString ^ self mockClassA class definition! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:50'! testMethodSelected self clickOnListItem: self mockCategoryName. self clickOnListItem: 'MCMockClassA'. self clickOnListItem: 'boolean'. self clickOnListItem: 'falsehood'. self assertAListMatches: self allCategories. self assertAListMatches: self definedClasses. self assertAListMatches: self classAProtocols. self assertAListMatches: self classABooleanMethods. self assertTextIs: self falsehoodMethodSource.! ! !MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 09:27'! denyButtonOn: aString self deny: (self findButtonWithLabel: aString) getModelState. ! ! !MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! denyAListIncludesAnyOf: anArrayOfStrings | found | found := true. self listMorphs detect: [:m | m getList includesAnyOf: anArrayOfStrings] ifNone: [found := false]. self deny: found.! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:58'! allProtocols ^ MCSnapshotResource current definitions select: [:def | def isMethodDefinition] thenCollect: [:def | def category] ! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'oscar.nierstrasz 6/5/2010 14:58'! testClassSideClassSelected self clickOnButton: 'class'. self selectMockClassA. self assertAListMatches: self allCategories. self assertAListMatches: self definedClasses. self assertAListMatches: self classAClassProtocols. self denyAListIncludesAnyOf: self allMethods. self assertTextIs: self classAclassDefinitionString.! ! !MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! denyAListHasSelection: aString | found | found := true. self listMorphs detect: [:m | m selection = aString] ifNone: [found := false]. self deny: found.! ! !MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 01:19'! assertAListIncludes: anArrayOfStrings self listMorphs detect: [:m | m getList includesAllOf: anArrayOfStrings] ifNone: [self assert: false].! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 09:12'! buttonMorphs ^ self morphsOfClass: PluggableButtonMorph! ! !MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 09:26'! assertButtonOn: aString self assert: (self findButtonWithLabel: aString) getModelState. ! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/28/2003 22:21'! annotationTextMorph ^ (self morphsOfClass: TextMorph) first! ! !MCSnapshotBrowserTest methodsFor: 'simulating' stamp: 'stephaneducasse 2/4/2006 20:47'! clickOnListItem: aString | listMorph | listMorph := self findListContaining: aString. listMorph changeModelSelection: (listMorph getList indexOf: aString).! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 08:46'! testProtocolIsCleared self clickOnListItem: self mockCategoryName. self clickOnListItem: 'MCMockASubclass'. self clickOnListItem: 'as yet unclassified'. self clickOnListItem: 'MCMockClassA'. self denyAListHasSelection: 'as yet unclassified'.! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/13/2003 02:23'! classABooleanMethods ^ #(falsehood moreTruth truth)! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:59'! definedClasses ^ MCSnapshotResource current definitions select: [:def | def isClassDefinition] thenCollect: [:def | def className].! ! !MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'cwp 7/13/2003 09:12'! assertButtonExists: aString self buttonMorphs detect: [:m | m label = aString] ifNone: [self assert: false]. ! ! !MCSnapshotBrowserTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp model := MCSnapshotBrowser forSnapshot: MCSnapshotResource current snapshot. morph := model buildWindow.! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'oscar.nierstrasz 6/5/2010 14:58'! classADefinitionString ^ self mockClassA definition! ! !MCSnapshotBrowserTest methodsFor: 'simulating' stamp: 'cwp 7/13/2003 09:22'! clickOnButton: aString (self findButtonWithLabel: aString) performAction.! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:40'! testCategorySelected self clickOnListItem: self mockCategoryName. self assertAListMatches: self allCategories. self assertAListMatches: self definedClasses. self denyAListIncludesAnyOf: self allProtocols. self denyAListIncludesAnyOf: self allMethods. self assertTextIs: ''.! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 12:52'! testComment self clickOnButton: '?'. self assertTextIs: ''. self clickOnListItem: self mockCategoryName. self assertTextIs: ''. self clickOnListItem: 'MCMockClassA'. self assertTextIs: self classAComment.! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 02:30'! testFourColumns self assert: self listMorphs size = 4.! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 02:34'! listMorphs ^ self morphsOfClass: PluggableListMorph! ! !MCSnapshotBrowserTest methodsFor: 'selecting' stamp: 'cwp 7/13/2003 13:04'! selectMockClassA self clickOnListItem: self mockCategoryName. self clickOnListItem: 'MCMockClassA'. ! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'! classAClassProtocols ^ self protocolsForClass: self mockClassA class.! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/28/2003 22:21'! textMorph ^ (self morphsOfClass: TextMorph) last! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 09:31'! testButtonMutex self assertButtonOn: 'instance'. self denyButtonOn: '?'. self denyButtonOn: 'class'. self clickOnButton: '?'. self assertButtonOn: '?'. self denyButtonOn: 'instance'. self denyButtonOn: 'class'. self clickOnButton: 'class'. self assertButtonOn: 'class'. self denyButtonOn: '?'. self denyButtonOn: 'instance'. ! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'CamilloBruni 7/15/2013 22:29'! testMethodIsCleared self clickOnListItem: self mockCategoryName. self clickOnListItem: 'MCMockClassA'. self clickOnListItem: 'boolean'. self clickOnListItem: 'falsehood'. self clickOnListItem: AllProtocol defaultName. self denyAListHasSelection: 'falsehood'.! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'CamilloBruni 7/15/2013 22:17'! protocolsForClass: aClass ^ aClass organization categories ! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testTextPane self textMorph! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 08:52'! testProtocolSelected self clickOnListItem: self mockCategoryName. self clickOnListItem: 'MCMockClassA'. self clickOnListItem: 'boolean'. self assertAListMatches: self allCategories. self assertAListMatches: self definedClasses. self assertAListMatches: self classAProtocols. self assertAListMatches: self classABooleanMethods. self assertTextIs: ''. ! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'! classAComment ^ self mockClassA organization classComment.! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'tfel 8/28/2009 20:43'! testNoSelection self assertAListMatches: self allCategories. self denyAListIncludesAnyOf: self definedClasses. self denyAListIncludesAnyOf: self allProtocols. self denyAListIncludesAnyOf: self allMethods. "and if there I need to see the packages scripts (or none)" self assertTextIs: '(package defines no scripts)'.! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 01:28'! findListContaining: aString ^ self listMorphs detect: [:m | m getList includes: aString]! ! !MCSnapshotReader commentStamp: 'LaurentLaffont 2/23/2011 20:21'! I am an abstract class defining the interface for reading sources containing class and method definitions. I should define loadDefinitions as a subclassResponsibility, but don't. MCVersionReader could be a subclass of me for reading sources containing additional metadata, but isn't. I'm useless and can be safely removed. I'm only referenced in MCMczReader>>extractDefinitionsFrom: and it can be replaced by MCReader.! !MCSnapshotReader methodsFor: 'accessing' stamp: 'avi 1/21/2004 23:10'! snapshot ^ MCSnapshot fromDefinitions: self definitions! ! !MCSnapshotReader methodsFor: 'accessing' stamp: 'avi 1/21/2004 23:09'! definitions definitions ifNil: [self loadDefinitions]. ^ definitions! ! !MCSnapshotReader class methodsFor: 'accessing' stamp: 'avi 1/21/2004 22:56'! snapshotFromStream: aStream ^ (self on: aStream) snapshot! ! !MCSnapshotResource methodsFor: 'accessing' stamp: 'cwp 7/14/2003 14:51'! snapshot ^ snapshot! ! !MCSnapshotResource methodsFor: 'accessing' stamp: 'cwp 7/14/2003 14:50'! definitions ^ snapshot definitions! ! !MCSnapshotResource methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp snapshot := self class takeSnapshot.! ! !MCSnapshotResource class methodsFor: 'accessing' stamp: 'cwp 7/14/2003 15:19'! takeSnapshot ^ self mockPackage snapshot! ! !MCSnapshotResource class methodsFor: 'accessing' stamp: 'cwp 8/1/2003 20:18'! mockPackage ^ (MCPackage new name: self mockPackageName)! ! !MCSnapshotResource class methodsFor: 'accessing' stamp: 'GuillermoPolito 8/24/2012 13:01'! mockPackageName ^ 'MonticelloMocks'! ! !MCSnapshotTest methodsFor: '*MonticelloMocks' stamp: 'cyrilledelaunay 1/21/2011 12:10'! mockClassExtension "I change the protocol of this method to resolve the failing test: MCChangeNotificationTest >> testExtMethodModified. This test basically test that when we modified an extension method, the extended package is marked as 'modified'. The problem is that Monticello treat differently a classic method from an extension method, and this only by checking if the protocol name start with a star. Therefore, if the protocol does not match the extending package name, the extending package name will never be notified, and the test will fail. " ! ! !MCSnapshotTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testInstanceReuse | x m n y | x := (MCPackage new name: self mockCategoryName) snapshot. Smalltalk garbageCollect. n := MCDefinition allSubInstances size. y := (MCPackage new name: self mockCategoryName) snapshot. Smalltalk garbageCollect. m := MCDefinition allSubInstances size. self assert: m = n! ! !MCSnapshotTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp snapshot := self mockSnapshot.! ! !MCSnapshotTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testCreation |d| d := self mockSnapshot definitions. self assert: (d anySatisfy: [:ea | ea isClassDefinition and: [ea className = #MCMockClassA]]). self assert: (d anySatisfy: [:ea | ea isMethodDefinition and: [ea selector = #mockClassExtension]]). self assert: (d allSatisfy: [:ea | ea isClassDefinition not or: [ea category endsWith: 'Mocks']]). ! ! !MCSortingTest methodsFor: 'building' stamp: 'ab 7/19/2003 17:56'! sortKeyFor: aDefinition ^ String streamContents: [:s | aDefinition description do: [:ea | s nextPutAll: ea asString] separatedBy: [s nextPut: $.]]! ! !MCSortingTest methodsFor: 'building' stamp: 'ab 4/8/2003 18:03'! methodNamed: aSymbol class: className meta: aBoolean ^ MCMethodDefinition className: className classIsMeta: aBoolean selector: aSymbol category: '' timeStamp: '' source: ''! ! !MCSortingTest methodsFor: 'actions' stamp: 'ab 7/19/2003 18:01'! sortDefinitions: aCollection ^ aCollection asSortedCollection asArray! ! !MCSortingTest methodsFor: 'building' stamp: 'ab 4/8/2003 17:56'! classNamed: aSymbol ^ MCClassDefinition name: aSymbol superclassName: #Object category: '' instVarNames: #() comment: ''! ! !MCSortingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testSortOrder | aA aAm aB bA bB A B cA bAm cAm | aA := self methodNamed: #a class: #A meta: false. bA := self methodNamed: #b class: #A meta: false. cA := self methodNamed: #c class: #A meta: false. aAm := self methodNamed: #a class: #A meta: true. bAm := self methodNamed: #b class: #A meta: true. cAm := self methodNamed: #c class: #A meta: true. aB := self methodNamed: #a class: #B meta: false. bB := self methodNamed: #b class: #B meta: false. A := self classNamed: #A. B := self classNamed: #B. self assert: (self sortDefinitions: {aA. aAm. cAm. aB. bAm. bA. bB. A. cA. B}) = {A. aAm. bAm. cAm. aA. bA. cA. B. aB. bB}! ! !MCSortingTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testConsistentSorting | definitions shuffledAndSorted| definitions := {self methodNamed: #a class: #A meta: false. self methodNamed: #a class: #A meta: true. self methodNamed: #a class: #B meta: false. self methodNamed: #b class: #A meta: false. self methodNamed: #b class: #B meta: false. self classNamed: #A. self classNamed: #B}. shuffledAndSorted := (1 to: 100) collect: [:ea | self sortDefinitions: definitions shuffled]. self assert: shuffledAndSorted asSet size = 1. ! ! !MCSortingTest class methodsFor: 'testing' stamp: 'JorgeRessia 3/16/2010 20:26'! isUnitTest ^false! ! !MCSqueaksourceRepository commentStamp: ''! I am a specialized MCHttpRepository for http://squeaksource.com. I optimize checks for existing files by doing a head request instead of reloading the whole file list first.! !MCSqueaksourceRepository methodsFor: 'interface' stamp: 'CamilloBruni 4/23/2012 20:22'! includesVersionNamed: aString "directly do a filename check since squeaksource only stores mcz" ^ self includesFileNamed: aString, '.mcz'! ! !MCSqueaksourceRepository methodsFor: 'interface' stamp: 'CamilloBruni 9/14/2012 17:10'! includesFileNamed: aString "avoid the slower default method and simply do a head request " self httpClient numberOfRetries: 0; ifFail: [ :exception| exception response code = 404 ifTrue: [ ^ false ]. exception pass]; head: (self urlForFileNamed: aString). ^ true! ! !MCSqueaksourceRepository methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/23/2013 13:17'! koRemote ^ KomitSqueakSourceRemote new remote: self; yourself! ! !MCSqueaksourceRepository class methodsFor: 'creation template' stamp: 'CamilloBruni 10/21/2012 13:25'! baseURL ^ 'http://squeaksource.com/'! ! !MCSqueaksourceRepository class methodsFor: 'testing' stamp: 'CamilloBruni 4/6/2013 23:07'! isResponsibleFor: aUrl ^ aUrl includesSubstring: 'squeaksource.com/'! ! !MCSqueaksourceRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 2/8/2012 18:13'! description ^ 'squeaksource.com'! ! !MCStReader commentStamp: 'LaurentLaffont 3/31/2011 21:07'! I read Category/Classes/Methodes/.... definitions from Monticello source.st file format. See also MCStWriter. Example: |source| source := String streamContents: [:aStream| |writer| writer := MCStWriter on: aStream. writer writeDefinitions: {True asClassDefinition. False asClassDefinition}. ]. (MCStReader on: source readStream) definitions explore.! !MCStReader methodsFor: 'reading' stamp: 'avi 1/19/2004 21:56'! typeOfSubclass: aSymbol #( (subclass: normal) (variableSubclass: variable) (variableByteSubclass: bytes) (variableWordSubclass: words) (weakSubclass: weak) ) do: [:ea | ea first = aSymbol ifTrue: [^ ea second]]. self error: 'Unrecognized class definition'! ! !MCStReader methodsFor: 'reading' stamp: 'stephaneducasse 2/4/2006 20:47'! commentStampFor: aPseudoClass | comment | comment := aPseudoClass organization classComment. ^ [comment stamp] on: MessageNotUnderstood do: [nil]! ! !MCStReader methodsFor: 'adding' stamp: 'marcus.denker 11/10/2008 10:04'! addDefinitionsFromDoit: aString (MCDoItParser forDoit: aString) ifNotNil: [:parser | parser addDefinitionsTo: definitions]! ! !MCStReader methodsFor: 'reading' stamp: 'MarcusDenker 5/18/2013 15:44'! classDefinitionFrom: aPseudoClass | tokens traitCompositionString lastIndex classTraitCompositionString | tokens := aPseudoClass definition parseLiterals. traitCompositionString := (aPseudoClass definition readStream match: 'uses:'; upToAll: 'instanceVariableNames:') trimBoth. classTraitCompositionString := (aPseudoClass metaClass definition asString readStream match: 'uses:'; upToAll: 'instanceVariableNames:') trimBoth. traitCompositionString isEmpty ifTrue: [traitCompositionString := '{}']. classTraitCompositionString isEmpty ifTrue: [classTraitCompositionString := '{}']. lastIndex := tokens size. ^ MCClassDefinition name: (tokens at: 3) superclassName: (tokens at: 1) traitComposition: traitCompositionString classTraitComposition: classTraitCompositionString category: (tokens at: lastIndex) instVarNames: ((tokens at: lastIndex - 6) findTokens: ' ') classVarNames: ((tokens at: lastIndex - 4) findTokens: ' ') poolDictionaryNames: ((tokens at: lastIndex - 2) findTokens: ' ') classInstVarNames: (self classInstVarNamesFor: aPseudoClass) type: (self typeOfSubclass: (tokens at: 2)) comment: (self commentFor: aPseudoClass) commentStamp: (self commentStampFor: aPseudoClass)! ! !MCStReader methodsFor: 'reading' stamp: 'MarcusDenker 5/18/2013 15:44'! classInstVarNamesFor: aPseudoClass | tokens | self flag: #traits. aPseudoClass metaClass hasDefinition ifFalse: [^ #()]. tokens := aPseudoClass metaClass definition parseLiterals. "tokens size = 4 ifFalse: [self error: 'Unrecognized metaclass definition']." ^ tokens last findTokens: ' '! ! !MCStReader methodsFor: 'reading' stamp: 'MarcusDenker 5/18/2013 15:44'! categoryFromDoIt: aString | tokens | tokens := aString parseLiterals. tokens size = 3 ifFalse: [self error: 'Unrecognized category definition']. ^ tokens at: 3! ! !MCStReader methodsFor: 'reading' stamp: 'avi 3/3/2004 15:23'! methodDefinitionsFor: aPseudoClass ^ aPseudoClass selectors collect: [:ea | MCMethodDefinition className: aPseudoClass name classIsMeta: aPseudoClass isMeta selector: ea category: (aPseudoClass organization categoryOfElement: ea) timeStamp: (aPseudoClass stampAt: ea) source: (aPseudoClass sourceCodeAt: ea)]! ! !MCStReader methodsFor: 'evaluating' stamp: 'stephaneducasse 2/4/2006 20:47'! loadDefinitions | filePackage | filePackage := FilePackage new fullName: 'ReadStream'; fileInFrom: self readStream. definitions := OrderedCollection new. filePackage classes do: [:pseudoClass | pseudoClass hasDefinition ifTrue: [definitions add: (self classDefinitionFrom: pseudoClass)]. definitions addAll: (self methodDefinitionsFor: pseudoClass). definitions addAll: (self methodDefinitionsFor: pseudoClass metaClass)]. filePackage doIts do: [:ea | self addDefinitionsFromDoit: ea string]. ! ! !MCStReader methodsFor: 'evaluating' stamp: 'avi 1/21/2004 14:21'! readStream ^ ('!!!! ', stream contents) readStream! ! !MCStReader methodsFor: 'reading' stamp: 'stephaneducasse 2/4/2006 20:47'! commentFor: aPseudoClass | comment | comment := aPseudoClass organization classComment. ^ comment asString = '' ifTrue: [comment] ifFalse: [comment string]! ! !MCStReader methodsFor: 'reading' stamp: 'stephaneducasse 2/4/2006 20:47'! systemOrganizationFromRecords: changeRecords | categories | categories := changeRecords select: [:ea | 'SystemOrganization*' match: ea string] thenCollect: [:ea | (self categoryFromDoIt: ea string)]. ^ categories isEmpty ifFalse: [MCOrganizationDefinition categories: categories asArray]! ! !MCStReader class methodsFor: 'accessing' stamp: 'avi 1/20/2004 00:17'! extension ^ 'st'! ! !MCStReaderTest methodsFor: 'util' stamp: 'sd 3/20/2008 22:31'! methodWithStyle ^ '!!EventHandler methodsFor: ''copying'' stamp: ''tk 1/22/2001 17:39''!! veryDeepInner: deepCopier "ALL fields are weakly copied. Can''t duplicate an object by duplicating a button that activates it. See DeepCopier." super veryDeepInner: deepCopier. "just keep old pointers to all fields" clickRecipient := clickRecipient.!! ]style[(25 108 10 111)f1b,f1,f1LDeepCopier Comment;,f1!! !! '! ! !MCStReaderTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testMethodWithStyle | reader | reader := MCStReader on: self methodWithStyle readStream. self assert: reader definitions first isMethodDefinition.! ! !MCStReaderTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testCommentWithoutStyle | reader | reader := MCStReader on: self commentWithoutStyle readStream. self assert: (reader definitions anySatisfy: [:ea | ea isMethodDefinition]).! ! !MCStReaderTest methodsFor: 'util' stamp: 'ab 8/17/2003 16:52'! commentWithoutStyle ^ ' CharacterScanner subclass: #CanvasCharacterScanner instanceVariableNames: ''canvas fillBlt foregroundColor runX lineY '' classVariableNames: '''' poolDictionaries: '''' category: ''Morphic-Support''!! !!CanvasCharacterScanner commentStamp: '''' prior: 0!! A displaying scanner which draws its output to a Morphic canvas.!! !!CanvasCharacterScanner methodsFor: ''stop conditions'' stamp: ''ar 12/15/2001 23:27''!! setStopConditions "Set the font and the stop conditions for the current run." self setFont. stopConditions at: Space asciiValue + 1 put: (alignment = Justified ifTrue: [#paddedSpace])!! !!'! ! !MCStReaderTest methodsFor: 'util' stamp: 'cwp 8/16/2003 23:35'! commentWithStyle ^ '!!AEDesc commentStamp: '''' prior: 0!! I represent an Apple Event Descriptor. I am a low-level representation of Apple Event (and hence Applescript) information. For further Information, see Apple''s Inside Macintosh: Interapplication Communications, at http://developer.apple.com/techpubs/mac/IAC/IAC-2.html. Essentially, I represent a record comprising a one-word "string" (treating the word as fourbyte characters) representing a data type, followed by a pointer to a pointer (a handle) to the data I represent. Care must be taken to assure that the Handle data is disposed after use, or memory leaks result. At this time, I make no effort to do this automatically through finalization.!! ]style[(218 54 384)f1,f1Rhttp://developer.apple.com/techpubs/mac/IAC/IAC-2.html;,f1!! '! ! !MCStReaderTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testCommentWithStyle | reader | reader := MCStReader on: self commentWithStyle readStream. reader definitions! ! !MCStWriter commentStamp: 'LaurentLaffont 3/31/2011 21:07'! I write Category/Classes/Methods/.... definitions into Monticello source.st file format found in .mcz packages. See also MCStReader Example: String streamContents: [:aStream| |writer| writer := MCStWriter on: aStream. writer writeDefinitions: {True asClassDefinition. False asClassDefinition}. ]! !MCStWriter methodsFor: 'writing' stamp: 'avi 2/17/2004 02:25'! writeSnapshot: aSnapshot self writeDefinitions: aSnapshot definitions! ! !MCStWriter methodsFor: 'visiting' stamp: 'cwp 8/2/2003 11:02'! visitClassDefinition: definition self writeClassDefinition: definition. definition hasClassInstanceVariables ifTrue: [self writeMetaclassDefinition: definition]. definition hasComment ifTrue: [self writeClassComment: definition].! ! !MCStWriter methodsFor: 'writing' stamp: 'pavel.krivanek 10/23/2010 19:40'! writeDefinitions: aCollection "the correct initialization order is unknown if some classes are missing in the image" | presentInitializers notPresentInitializers orderedClasses | initializers := Set new. (MCDependencySorter sortItems: aCollection) do: [:ea | ea accept: self] displayingProgress: 'Writing definitions...'. presentInitializers := initializers select: [:each | Smalltalk hasClassNamed: each key ]. notPresentInitializers := initializers reject: [:each | Smalltalk hasClassNamed: each key ]. orderedClasses := (Class superclassOrder: (presentInitializers collect: [:each | Smalltalk classOrTraitNamed: each key])) collect: [:each | each name ]. orderedClasses do: [:className | stream nextPutAll: (presentInitializers detect: [:each | each key = className]) value contents]. (notPresentInitializers asSortedCollection: [:a :b | a key <= b key]) do: [:association | stream nextPutAll: association value contents ].! ! !MCStWriter methodsFor: 'visiting' stamp: 'avi 2/17/2004 02:23'! visitMethodDefinition: definition self writeMethodPreamble: definition. self writeMethodSource: definition. self writeMethodPostscript. self writeMethodInitializer: definition.! ! !MCStWriter methodsFor: 'writing' stamp: 'al 12/2/2005 15:17'! writeMetaclassDefinition: definition self chunkContents: [:str | str nextPutAll: definition className; nextPutAll: ' class'; cr; tab. definition hasClassTraitComposition ifTrue: [ str nextPutAll: 'uses: '; nextPutAll: definition classTraitCompositionString; cr; tab]. str nextPutAll: 'instanceVariableNames: '''; nextPutAll: definition classInstanceVariablesString; nextPut: $']! ! !MCStWriter methodsFor: 'writing' stamp: 'avi 9/23/2003 17:42'! writeMethodPreamble: definition stream cr; nextPut: $!!; nextPutAll: definition fullClassName; nextPutAll: ' methodsFor: '; nextPutAll: definition category asString printString; nextPutAll: ' stamp: '; nextPutAll: definition timeStamp asString printString; nextPutAll: '!!'; cr! ! !MCStWriter methodsFor: 'writing' stamp: 'ab 8/17/2003 17:09'! writeClassComment: definition stream cr; nextPut: $!!; nextPutAll: definition className; nextPutAll: ' commentStamp: '; store: definition commentStamp; nextPutAll: ' prior: 0!!'; cr; nextChunkPut: definition comment; cr.! ! !MCStWriter methodsFor: 'visiting' stamp: 'al 10/9/2005 19:40'! visitMetaclassDefinition: definition self writeMetaclassDefinition: definition! ! !MCStWriter methodsFor: 'visiting' stamp: 'cwp 8/2/2003 11:02'! visitOrganizationDefinition: defintion defintion categories do: [:cat | self writeCategory: cat]. ! ! !MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 12:43'! writeMethodPostscript stream space; nextPut: $!!; cr! ! !MCStWriter methodsFor: 'writing' stamp: 'bf 8/13/2009 00:21'! writeScriptDefinition: definition stream nextChunkPut: ( '(PackageInfo named: {1}) {2}: {3}' format: { "{1}" definition packageName printString. "{2}" definition scriptSelector. "{3}" definition script printString }); cr! ! !MCStWriter methodsFor: 'writing' stamp: 'cwp 8/4/2003 01:35'! writeMethodSource: definition stream nextChunkPut: definition source! ! !MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 01:46'! writeCategory: categoryName stream nextChunkPut: 'SystemOrganization addCategory: ', categoryName printString; cr! ! !MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 02:16'! writeClassDefinition: definition self chunkContents: [:s | definition printDefinitionOn: stream]! ! !MCStWriter methodsFor: 'visiting' stamp: 'al 10/9/2005 19:40'! visitTraitDefinition: definition self writeClassDefinition: definition. definition hasComment ifTrue: [self writeClassComment: definition].! ! !MCStWriter methodsFor: 'visiting' stamp: 'bf 8/12/2009 21:41'! visitScriptDefinition: definition self writeScriptDefinition: definition ! ! !MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 02:34'! chunkContents: aBlock stream cr; nextChunkPut: (String streamContents: aBlock); cr! ! !MCStWriter methodsFor: 'writing' stamp: 'pavel.krivanek 10/23/2010 18:51'! writeMethodInitializer: aMethodDefinition | initializationStream | aMethodDefinition isInitializer ifTrue: [ initializationStream := String new writeStream. initializationStream nextChunkPut: aMethodDefinition className, ' initialize'; cr. initializers add: (aMethodDefinition className->initializationStream)].! ! !MCStWriter methodsFor: 'visiting' stamp: 'al 10/9/2005 19:52'! visitClassTraitDefinition: definition self chunkContents: [:s | s nextPutAll: definition baseTrait; nextPutAll: ' classTrait'; cr; tab; nextPutAll: 'uses: '; nextPutAll: (definition classTraitComposition ifNil: ['{}'])] ! ! !MCStWriter class methodsFor: 'accessing' stamp: 'avi 1/20/2004 00:16'! readerClass ^ MCStReader! ! !MCStWriterTest methodsFor: 'testing' stamp: 'cwp 9/14/2003 19:39'! testClassDefinitionB writer visitClassDefinition: (self mockClassB asClassDefinition). self assertContentsOf: stream match: self expectedClassDefinitionB. ! ! !MCStWriterTest methodsFor: 'data' stamp: 'GuillermoPolito 8/24/2012 12:57'! expectedClassDefinitionA ^ ' MCMock subclass: #MCMockClassA instanceVariableNames: ''ivar'' classVariableNames: ''CVar InitializationOrder'' poolDictionaries: '''' category: ''MonticelloMocks''!! !!MCMockClassA commentStamp: ''cwp 8/10/2003 16:43'' prior: 0!! This is a mock class. The Monticello tests manipulated it to simulate a developer modifying code in the image.!! '! ! !MCStWriterTest methodsFor: 'asserting' stamp: 'MarcusDenker 9/5/2013 13:16'! assertMethodChunkIsWellFormed: chunk self class compiler source: chunk readStream; class: UndefinedObject; failBlock: [self assert: false]; translate. ! ! !MCStWriterTest methodsFor: 'asserting' stamp: 'cwp 8/2/2003 12:13'! assertAllChunksAreWellFormed stream reset. stream untilEnd: [self assertChunkIsWellFormed: stream nextChunk] displayingProgress: 'Checking syntax...'! ! !MCStWriterTest methodsFor: 'testing' stamp: 'GuillermoPolito 8/24/2012 12:57'! methodWithBangs ^ ' ^ ReadStream on: ''MCRevisionInfo packageName: ''MonticelloCompatibilityTest''!!!! MCOrganizationDeclaration categories: #( ''MonticelloMocks'')!!!! MCClassDeclaration name: #MCMockClassD superclassName: #Object category: #''MonticelloMocks'' instVarNames: #() comment: ''''!!!! MCMethodDeclaration className: #MCMockClassD selector: #one category: #''as yet unclassified'' timeStamp: ''cwp 7/8/2003 21:21'' source: ''one ^ 1''!!!! '' ' ! ! !MCStWriterTest methodsFor: 'testing' stamp: 'VeronicaUquillas 8/23/2011 11:45'! testMethodDefinition writer visitMethodDefinition: (RGMethodDefinition realClass: self mockClassA selector: #one) asMCMethodDefinition. self assertContentsOf: stream match: self expectedMethodDefinition. stream reset. self assert: stream nextChunk isAllSeparators. self assertChunkIsWellFormed: stream nextChunk. self assertMethodChunkIsWellFormed: stream nextChunk. self assert: stream nextChunk isAllSeparators ! ! !MCStWriterTest methodsFor: 'data' stamp: 'GuillermoPolito 8/24/2012 12:57'! expectedClassDefinitionB ^ ' MCMock subclass: #MCMockClassB instanceVariableNames: ''ivarb'' classVariableNames: ''CVar'' poolDictionaries: ''MCMockAPoolDictionary'' category: ''MonticelloMocks''!! MCMockClassB class instanceVariableNames: ''ciVar''!! !!MCMockClassB commentStamp: '''' prior: 0!! This comment has a bang!!!! Bang!!!! Bang!!!!!! '! ! !MCStWriterTest methodsFor: 'testing' stamp: 'VeronicaUquillas 8/23/2011 11:45'! testClassMethodDefinition writer visitMethodDefinition: (RGMethodDefinition realClass: self mockClassA class selector: #one) asMCMethodDefinition. self assertContentsOf: stream match: self expectedClassMethodDefinition. stream reset. self assert: stream nextChunk isAllSeparators. self assertChunkIsWellFormed: stream nextChunk. self assertMethodChunkIsWellFormed: stream nextChunk. self assert: stream nextChunk isAllSeparators ! ! !MCStWriterTest methodsFor: 'testing' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp stream := RWBinaryOrTextStream on: String new. writer := MCStWriter on: stream. ! ! !MCStWriterTest methodsFor: 'asserting' stamp: 'MarcusDenker 9/5/2013 13:16'! assertChunkIsWellFormed: chunk self class compiler source: chunk readStream ; class: UndefinedObject; noPattern: true; failBlock: [self assert: false]; translate.! ! !MCStWriterTest methodsFor: 'asserting' stamp: 'nk 2/22/2005 21:17'! assertContentsOf: strm match: expected | actual | actual := strm contents. self assert: actual size = expected size. actual with: expected do: [:a :e | self assert: a = e]! ! !MCStWriterTest methodsFor: 'data' stamp: 'abc 8/24/2012 16:11'! expectedMethodDefinitionWithBangs ^ ' !!MCStWriterTest methodsFor: ''testing'' stamp: ''GuillermoPolito 8/24/2012 12:57''!! methodWithBangs ^ '' ^ ReadStream on: ''''MCRevisionInfo packageName: ''''MonticelloCompatibilityTest''''!!!!!!!! MCOrganizationDeclaration categories: #( ''''MonticelloMocks'''')!!!!!!!! MCClassDeclaration name: #MCMockClassD superclassName: #Object category: #''''MonticelloMocks'''' instVarNames: #() comment: ''''''''!!!!!!!! MCMethodDeclaration className: #MCMockClassD selector: #one category: #''''as yet unclassified'''' timeStamp: ''''cwp 7/8/2003 21:21'''' source: ''''one ^ 1''''!!!!!!!! '''' '' !! !! '! ! !MCStWriterTest methodsFor: 'data' stamp: 'GuillermoPolito 8/24/2012 14:04'! expectedOrganizationDefinition ^ 'SystemOrganization addCategory: #MonticelloMocks!! '! ! !MCStWriterTest methodsFor: 'testing' stamp: 'pavel.krivanek 10/14/2010 16:41'! testInitializerDefinition |chunk lastChunk penultChunk| writer writeSnapshot: self mockSnapshot. stream reset. [stream atEnd] whileFalse: [chunk := stream nextChunk. chunk isAllSeparators ifFalse: [ penultChunk := lastChunk. lastChunk := chunk]]. self assertContentsOf: penultChunk readStream match: self expectedInitializerA. self assertContentsOf: lastChunk readStream match: self expectedInitializerASubclass! ! !MCStWriterTest methodsFor: 'testing' stamp: 'pavel.krivanek 10/14/2010 16:43'! expectedInitializerASubclass ^ 'MCMockASubclass initialize'! ! !MCStWriterTest methodsFor: 'testing' stamp: 'ab 8/8/2003 17:01'! expectedInitializerA ^ 'MCMockClassA initialize'! ! !MCStWriterTest methodsFor: 'testing' stamp: 'VeronicaUquillas 8/23/2011 11:44'! testMethodDefinitionWithBangs writer visitMethodDefinition: (RGMethodDefinition realClass: self class selector: #methodWithBangs) asMCMethodDefinition. self assertContentsOf: stream match: self expectedMethodDefinitionWithBangs. stream reset. self assert: stream nextChunk isAllSeparators. self assertChunkIsWellFormed: stream nextChunk. self assertMethodChunkIsWellFormed: stream nextChunk. self assert: stream nextChunk isAllSeparators ! ! !MCStWriterTest methodsFor: 'testing' stamp: 'cwp 8/10/2003 02:11'! testClassDefinitionA writer visitClassDefinition: (self mockClassA asClassDefinition). self assertContentsOf: stream match: self expectedClassDefinitionA. stream reset. 2 timesRepeat: [self assertChunkIsWellFormed: stream nextChunk]! ! !MCStWriterTest methodsFor: 'testing' stamp: 'EstebanLorenzano 9/12/2012 13:35'! testOrganizationDefinition | definition | definition := MCOrganizationDefinition categories: (self mockPackage packageSet systemCategories). writer visitOrganizationDefinition: definition. self assertContentsOf: stream match: self expectedOrganizationDefinition. self assertAllChunksAreWellFormed.! ! !MCStWriterTest methodsFor: 'data' stamp: 'cwp 8/2/2003 14:43'! expectedClassMethodDefinition ^ ' !!MCMockClassA class methodsFor: ''as yet unclassified'' stamp: ''ab 7/7/2003 23:21''!! one ^ 1!! !! '! ! !MCStWriterTest methodsFor: 'data' stamp: 'abc 8/24/2012 16:10'! expectedMethodDefinition ^ ' !!MCMockClassA methodsFor: ''numeric'' stamp: ''GuillermoPolito 8/24/2012 15:22''!! one ^ 1!! !! '! ! !MCSubDirectoryRepository commentStamp: 'nk 6/11/2004 18:56'! A MCDirectoryRepository that looks in subdirectories too.! !MCSubDirectoryRepository methodsFor: 'interface' stamp: 'StephaneDucasse 6/17/2012 18:52'! loadAllFileNames "sorting {entry. dirName. name}" | sorted | sorted := SortedCollection sortBlock: [:a :b | a first modificationTime >= b first modificationTime ]. self allDirectories do: [:dir | dir entries do: [:ent | ent isDirectory ifFalse: [sorted add: {ent. dir fullName. ent basename}]]]. ^ sorted collect: [:ea | ea third ]! ! !MCSubDirectoryRepository methodsFor: 'user interface' stamp: 'CamilloBruni 5/4/2012 19:04'! description ^ (directory / '*') fullName ! ! !MCSubDirectoryRepository methodsFor: 'i/o' stamp: 'nk 6/11/2004 20:34'! writeStreamForFileNamed: aString replace: aBoolean do: aBlock | file | file := aBoolean ifTrue: [FileStream forceNewFileNamed: (self findFullNameForReading: aString)] ifFalse: [FileStream newFileNamed: (self findFullNameForWriting: aString)]. aBlock value: file. file close! ! !MCSubDirectoryRepository methodsFor: 'i/o' stamp: 'stephaneducasse 2/4/2006 20:47'! readStreamForFileNamed: aString do: aBlock | file val | file := FileStream readOnlyFileNamed: (self findFullNameForReading: aString). val := aBlock value: file. file close. ^ val! ! !MCSubDirectoryRepository methodsFor: 'enumeration' stamp: 'EstebanLorenzano 8/17/2012 13:12'! allDirectories ^directory allDirectories ! ! !MCSubDirectoryRepository methodsFor: 'i/o' stamp: 'SeanDeNigris 2/5/2013 15:35'! splitNameVersionExtensionFor: aBaseName | file version | file := aBaseName asFileReference. version := (file extensions at: file extensions size - 1) asNumber. ^ { file base. version. file extension }. ! ! !MCSubDirectoryRepository methodsFor: 'i/o' stamp: 'SeanDeNigris 2/5/2013 15:21'! findFullNameForWriting: aBaseName | possible split prefix fpattern now | split := self splitNameVersionExtensionFor: aBaseName. fpattern := split first, '*'. possible := SortedCollection sortBlock: [ :a :b | a first = b first ifTrue: [ a second = b second ifFalse: [ a second < b second ] ifTrue: [ a third fullName size < b third fullName size ]] ifFalse: [ a first > b first ] ]. now := Time totalSeconds. prefix := directory pathSegments size. self allDirectories do: [:dir | | dirScore fileScore parts | parts := dir pathSegments allButFirst: prefix. dirScore := (parts select: [ :part | fpattern match: part ]) size. fileScore := (dir entries collect: [ :ent | (ent isDirectory not and: [ fpattern match: ent name ]) ifFalse: [ SmallInteger maxVal ] ifTrue: [ now - ent modificationTime ]]). "minimum age" fileScore := fileScore isEmpty ifTrue: [ SmallInteger maxVal ] ifFalse: [ fileScore min ]. possible add: { dirScore. fileScore. dir } ]. ^ (possible first third) / aBaseName! ! !MCSubDirectoryRepository methodsFor: 'i/o' stamp: 'EstebanLorenzano 8/17/2012 13:43'! findFullNameForReading: aBaseName "Answer the latest version of aBaseName" ^((directory glob: [ :each | each basename = aBaseName]) sorted: [ :a :b | a modificationTime < b modificationTime ]) first.! ! !MCSubDirectoryRepository class methodsFor: 'user interface' stamp: 'nk 6/11/2004 18:48'! description ^ 'directory with subdirectories'! ! !MCSubDirectoryRepositoryTest commentStamp: ''! I am not a subclass of MCRepositoryTest because my purpose was to show that a bug had been fixed and my author didn't feel like implementing all the reuirements of MCRepositoryTests! !MCSubDirectoryRepositoryTest methodsFor: 'tests' stamp: 'SeanDeNigris 2/5/2013 15:43'! testIssue7368 "This is not a usage example. Hopefully the ugly private method under test will be refactored out of existence soon ;)" | collection | collection := MCSubDirectoryRepository new splitNameVersionExtensionFor: 'Spec-Core-AuthorName.120.mcz'. self assert: collection first equals: 'Spec-Core-AuthorName'. self assert: collection second equals: 120. self assert: collection third equals: 'mcz'.! ! !MCSystemCategoryParser commentStamp: ''! A MCSystemCategoryParser extracts or set a category/protocol to the corresponding MCOrganizationDefinition.! !MCSystemCategoryParser methodsFor: 'accessing' stamp: 'MarcusDenker 5/18/2013 15:44'! category | tokens | tokens := source parseLiterals. tokens size = 3 ifFalse: [self error: 'Unrecognized category definition']. ^ tokens at: 3! ! !MCSystemCategoryParser methodsFor: 'actions' stamp: 'StephaneDucasse 12/30/2012 17:34'! addDefinitionsTo: aCollection | definition | definition := aCollection detect: [:ea | ea isOrganizationDefinition ] ifNone: [aCollection add: (MCOrganizationDefinition categories: #())]. definition categories: (definition categories copyWith: self category).! ! !MCSystemCategoryParser class methodsFor: 'factory identification hook' stamp: 'avi 3/10/2004 12:41'! pattern ^ 'SystemOrganization*'! ! !MCSystemSettings commentStamp: 'TorstenBergmann 2/12/2014 23:28'! Settings for Monticello! !MCSystemSettings class methodsFor: 'settings' stamp: 'SeanDeNigris 11/11/2013 18:54'! monticelloSettingsOn: aBuilder (aBuilder group: #monticello) label: 'Monticello' translated; description: 'All Monticello settings' translated; with: [ (aBuilder setting: #defaultDirectoryName) type: #Directory; target: MCDirectoryRepository; description: 'The path of a directory where you want to start out when choosing local repository locations' translated; label: 'Default local repository directory'. (aBuilder setting: #cacheDirectory) type: #Directory; target: MCCacheRepository; description: 'The path of the local repository cache' translated; label: 'Local cache directory'. ].! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 16:53'! commentStampForClass: name ^ 'tester-', name, ' 1/1/2000 00:00'! ! !MCTestCase methodsFor: 'mocks' stamp: 'GuillermoPolito 8/24/2012 13:48'! mockExtensionMethodCategory ^ '*MonticelloMocks'! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/1/2003 20:27'! mockPackage ^ MCSnapshotResource mockPackage! ! !MCTestCase methodsFor: 'mocks' stamp: 'avi 1/19/2004 15:54'! mockDependencies ^ Array with: (MCVersionDependency package: self mockEmptyPackage info: (self mockVersionInfo: 'x'))! ! !MCTestCase methodsFor: 'mocks' stamp: 'ab 1/15/2003 17:55'! mockToken: aSymbol ^ MCMockDefinition token: aSymbol! ! !MCTestCase methodsFor: 'running' stamp: 'CamilloBruni 7/6/2012 16:21'! runCase MCCacheRepository disableCacheDuring: [ ^ super runCase ].! ! !MCTestCase methodsFor: 'compiling' stamp: 'abc 2/16/2006 09:24'! compileClass: aClass source: source category: category aClass compileSilently: source classified: category! ! !MCTestCase methodsFor: 'mocks' stamp: 'ab 4/1/2003 02:02'! mockMethod: aSymbol class: className source: sourceString meta: aBoolean ^ MCMethodDefinition className: className classIsMeta: aBoolean selector: aSymbol category: 'as yet unclassified' timeStamp: '' source: sourceString! ! !MCTestCase methodsFor: 'mocks' stamp: 'lr 3/14/2010 21:13'! mockClassA ^ Smalltalk globals at: #MCMockClassA! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/30/2003 19:23'! mockVersion ^ MCVersion package: self mockPackage info: self mockVersionInfo snapshot: self mockSnapshot! ! !MCTestCase methodsFor: 'mocks' stamp: 'avi 1/19/2004 15:15'! mockVersionWithDependencies ^ MCVersion package: self mockPackage info: self mockVersionInfo snapshot: self mockSnapshot dependencies: self mockDependencies! ! !MCTestCase methodsFor: 'mocks' stamp: 'avi 2/12/2004 19:58'! mockVersionInfo ^ self treeFrom: #(d ((b ((a))) (c)))! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 16:51'! commentForClass: name ^ 'This is a comment for ', name! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 11/6/2004 16:03'! mockVersionWithAncestor: aMCVersion ^ MCVersion package: self mockPackage info: (self mockVersionInfoWithAncestor: aMCVersion info) snapshot: self mockSnapshot! ! !MCTestCase methodsFor: 'mocks' stamp: 'MiguelCoba 7/25/2009 02:01'! mockVersionInfo: tag ^ MCVersionInfo name: self mockVersionName, '-', tag asString id: UUID new message: self mockMessageString, '-', tag asString date: Date today time: Time now author: Author fullName ancestors: #() ! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 11/13/2003 13:24'! mockOverrideMethodCategory ^ self mockExtensionMethodCategory, '-override'! ! !MCTestCase methodsFor: 'compiling' stamp: 'cwp 8/2/2003 15:05'! restoreMocks self mockSnapshot updatePackage: self mockPackage! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 02:06'! mockInstanceA ^ self mockClassA new! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/30/2003 19:24'! mockMessageString ^ 'A version generated for testing purposes.'! ! !MCTestCase methodsFor: 'mocks' stamp: 'GuillermoPolito 8/24/2012 12:57'! mockCategoryName ^ 'MonticelloMocks'! ! !MCTestCase methodsFor: 'asserting' stamp: 'cwp 8/8/2003 14:58'! assertVersion: actual matches: expected self assertPackage: actual package matches: expected package. self assertVersionInfo: actual info matches: expected info. self assertSnapshot: actual snapshot matches: expected snapshot.! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 16:50'! mockClass: className super: superclassName ^ MCClassDefinition name: className superclassName: superclassName category: self mockCategoryName instVarNames: #() classVarNames: #() poolDictionaryNames: #() classInstVarNames: #() type: #normal comment: (self commentForClass: className) commentStamp: (self commentStampForClass: className)! ! !MCTestCase methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! assertSnapshot: actual matches: expected | diff | diff := actual patchRelativeToBase: expected. self assert: diff isEmpty ! ! !MCTestCase methodsFor: 'mocks' stamp: 'MiguelCoba 7/25/2009 02:01'! mockVersionInfoWithAncestor: aVersionInfo ^ MCVersionInfo name: aVersionInfo name, '-child' id: UUID new message: self mockMessageString date: Date today time: Time now author: Author fullName ancestors: {aVersionInfo} ! ! !MCTestCase methodsFor: 'mocks' stamp: 'stephaneducasse 2/4/2006 20:47'! treeFrom: anArray | name id | name := anArray first. id := '00000000-0000-0000-0000-0000000000', (name asString size = 1 ifTrue: [name asString, '0'] ifFalse: [name asString]). ^ MCVersionInfo name: name id: (UUID fromString: id) message: '' date: nil time: nil author: '' ancestors: (anArray size > 1 ifTrue: [(anArray second collect: [:ea | self treeFrom: ea])] ifFalse: [#()])! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/14/2003 15:07'! mockSnapshot ^ MCSnapshotResource current snapshot! ! !MCTestCase methodsFor: 'asserting' stamp: 'cwp 8/8/2003 14:58'! assertPackage: actual matches: expected self assert: actual = expected ! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/30/2003 19:25'! mockVersionName ^ 'MonticelloTest-xxx.1'! ! !MCTestCase methodsFor: 'asserting' stamp: 'cwp 8/8/2003 15:50'! assertVersionInfo: actual matches: expected self assert: actual name = expected name. self assert: actual message = expected message. self assert: actual ancestors size = expected ancestors size. actual ancestors with: expected ancestors do: [:a :e | self assertVersionInfo: a matches: e] ! ! !MCTestCase methodsFor: 'mocks' stamp: 'lr 3/14/2010 21:13'! mockClassB ^ Smalltalk globals at: #MCMockClassB! ! !MCTestCase methodsFor: 'compiling' stamp: 'cwp 8/10/2003 02:12'! change: aSelector toReturn: anObject self compileClass: self mockClassA source: aSelector, ' ^ ', anObject printString category: 'numeric'! ! !MCTestCase methodsFor: 'mocks' stamp: 'avi 2/22/2004 14:08'! mockEmptyPackage ^ MCPackage named: (MCEmptyPackageInfo new packageName)! ! !MCTestCase class methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 15:12'! isAbstract ^ self = MCTestCase! ! !MCTestCase class methodsFor: 'as yet unclassified' stamp: 'cwp 7/14/2003 15:05'! resources ^ Array with: MCSnapshotResource! ! !MCTestCase class methodsFor: 'testing' stamp: 'JorgeRessia 3/16/2010 20:23'! isUnitTest ^false! ! !MCThreeWayMerger commentStamp: ''! A MCThreeWayMerger is more advanced merge operation. Operations are subclasses of MCPatchOperation: addition (MCAddition), modification of an entity (MCModification ) and removal (MCRemoval). ! !MCThreeWayMerger methodsFor: 'accessing' stamp: 'avi 10/6/2004 15:19'! provisions ^ provisions! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'ab 6/2/2003 01:30'! addOperation: anOperation self operations add: anOperation! ! !MCThreeWayMerger methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! operations ^ operations ifNil: [operations := OrderedCollection new]! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'StephaneDucasse 6/24/2011 15:12'! removeDefinition: aDefinition index definitionLike: aDefinition ifPresent: [:other | other = aDefinition ifTrue: [(self modificationConflictForDefinition: aDefinition) ifNotNil: [:c | c beNonConflict. ^ self]. (self redundantAdds includes: aDefinition) ifFalse: [self addOperation: (MCRemoval of: aDefinition)]] ifFalse: [self addConflictWithOperation: (MCRemoval of: other)]] ifAbsent: []! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'StephaneDucasse 6/24/2011 15:10'! modificationConflictForDefinition: aDefinition ^ self conflicts detect: [:ea | (ea definition isRevisionOf: aDefinition) and: [ea operation isModification]] ifNone: []! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'marcus.denker 11/10/2008 10:04'! addDefinition: aDefinition index definitionLike: aDefinition ifPresent: [:other | (self removalForDefinition: aDefinition) ifNotNil: [:op | self addOperation: (MCModification of: other to: aDefinition). self removeOperation: op. ^ self]. other = aDefinition ifFalse: [self addConflictWithOperation: (MCModification of: other to: aDefinition)] ifTrue: [self redundantAdds add: aDefinition]] ifAbsent: [self addOperation: (MCAddition of: aDefinition)]! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'avi 9/19/2005 02:40'! removalForDefinition: aDefinition ^ operations ifNotNil: [operations detect: [:ea | (ea definition isRevisionOf: aDefinition) and: [ea isRemoval]] ifNone: []]! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'avi 2/13/2004 01:49'! baseSnapshot ^ (MCSnapshot fromDefinitions: index definitions)! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'avi 2/13/2004 01:52'! applyPatch: aPatch aPatch applyTo: self! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'avi 9/19/2005 02:40'! removeOperation: anOperation operations remove: anOperation! ! !MCThreeWayMerger methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:04'! initialize super initialize. index := MCDefinitionIndex new. provisions := Set new! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'avi 10/6/2004 15:18'! addBaseSnapshot: aSnapshot aSnapshot definitions do: [:ea | index add: ea. provisions addAll: ea provisions]! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'! redundantAdds ^ redundantAdds ifNil: [redundantAdds := Set new]! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'StephaneDucasse 6/24/2011 14:40'! modifyDefinition: baseDefinition to: targetDefinition index definitionLike: baseDefinition ifPresent: [:other | other = baseDefinition ifTrue: [self addOperation: (MCModification of: baseDefinition to: targetDefinition)] ifFalse: [other = targetDefinition ifFalse: [self addConflictWithOperation: (MCModification of: other to: targetDefinition)]]] ifAbsent: [self addConflictWithOperation: (MCAddition of: targetDefinition)]! ! !MCThreeWayMerger class methodsFor: 'instance-creation' stamp: 'avi 2/13/2004 01:53'! base: aSnapshot patch: aPatch aPatch isEmpty ifTrue: [MCNoChangesException signal]. ^ self new addBaseSnapshot: aSnapshot; applyPatch: aPatch; yourself ! ! !MCThreeWayMerger class methodsFor: 'instance-creation' stamp: 'ab 6/2/2003 01:09'! base: aSnapshot target: targetSnapshot ancestor: ancestorSnapshot ^ self base: aSnapshot patch: (targetSnapshot patchRelativeToBase: ancestorSnapshot)! ! !MCTool commentStamp: 'TorstenBergmann 2/20/2014 15:51'! Common superclass for Monticello tools! !MCTool methodsFor: 'morphic ui' stamp: 'nk 2/16/2004 16:50'! arrowKey: aCharacter from: aPluggableListMorph "backstop"! ! !MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! window ^ morph ifNil: [morph := self buildWindow]! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:42'! close self window delete! ! !MCTool methodsFor: 'utils' stamp: 'StephaneDucasse 6/2/2012 20:34'! allManagers ^ MCWorkingCopy allManagers ! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:10'! defaultExtent ^ 500@500! ! !MCTool methodsFor: 'morphic ui' stamp: 'nk 2/16/2004 17:03'! listMorph: listSymbol keystroke: keystrokeSymbol ^ (self listMorph: (listSymbol, 'List') asSymbol selection: (listSymbol, 'Selection') asSymbol menu: (listSymbol, 'ListMenu:') asSymbol) keystrokeActionSelector: keystrokeSymbol; yourself! ! !MCTool methodsFor: 'morphic ui' stamp: 'StephaneDucasse 12/19/2012 16:51'! buildWindow | window | window := SystemWindow labelled: self label. window model: self. self widgetSpecs do: [:spec | | send fractions offsets | send := spec first. fractions := spec at: 2 ifAbsent: [#(0 0 1 1)]. offsets := spec at: 3 ifAbsent: [#(0 0 0 0)]. window addMorph: (self perform: send first withArguments: send allButFirst) fullFrame: (LayoutFrame new leftFraction: fractions first; topFraction: fractions second; rightFraction: fractions third ; bottomFraction: fractions fourth; leftOffset: offsets first; topOffset: offsets second; rightOffset: offsets third; bottomOffset: offsets fourth)]. ^ window! ! !MCTool methodsFor: 'morphic ui' stamp: 'CamilloBruni 2/4/2012 12:25'! showModally | tb | modal := true. self window openInWorldExtent: 400 @ 400. self setDefaultFocus. [ self window world notNil ] whileTrue: [ self window outermostWorldMorph doOneCycle ]. morph := nil. ^ modalValue! ! !MCTool methodsFor: 'opening' stamp: 'CamilloBruni 2/4/2012 12:25'! showLabelled: labelString modal := false. self label: labelString. self window openInWorldExtent: self defaultExtent. self setDefaultFocus. ^ self window.! ! !MCTool methodsFor: 'morphic ui' stamp: 'AlainPlantec 12/19/2009 21:32'! defaultAnnotationPaneHeight "Answer the receiver's preferred default height for new annotation panes." ^ 25! ! !MCTool methodsFor: 'morphic ui' stamp: 'lr 7/28/2011 16:24'! buttonState ^ false! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:23'! buttonSpecs ^ #()! ! !MCTool methodsFor: 'opening' stamp: 'CamilloBruni 2/4/2012 12:25'! show "Open the tool returning the window." modal := false. self window openInWorldExtent: self defaultExtent. self setDefaultFocus. ^ self window! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 8/24/2003 20:15'! findTextMorph: aSymbol ^ morph submorphs detect: [:ea | (ea respondsTo: #getTextSelector) and: [ea getTextSelector = aSymbol]] ifNone: []! ! !MCTool methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:27'! treeMorph: listSymbol ^ self treeMorph: (listSymbol, 'Tree') asSymbol selection: (listSymbol, 'SelectionWrapper') asSymbol menu: (listSymbol, 'TreeMenu:') asSymbol! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:40'! widgetSpecs ^ #()! ! !MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! label: aString label := aString! ! !MCTool methodsFor: '*Shout-Styling' stamp: 'AlainPlantec 8/27/2011 15:59'! shoutAboutToStyle: aPluggableShoutMorphOrView ^ false! ! !MCTool methodsFor: 'morphic ui' stamp: 'nk 2/16/2004 16:50'! listMorph: listSymbol selection: selectionSymbol menu: menuSymbol keystroke: keystrokeSymbol ^ (PluggableListMorph on: self list: listSymbol selected: selectionSymbol changeSelected: (selectionSymbol, ':') asSymbol menu: menuSymbol) keystrokeActionSelector: keystrokeSymbol; yourself! ! !MCTool methodsFor: 'morphic ui' stamp: 'StephaneDucasse 2/20/2010 21:58'! initialExtent ^ 580@200! ! !MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! answer: anObject modalValue := anObject. self close.! ! !MCTool methodsFor: 'morphic ui' stamp: 'bf 5/27/2005 19:22'! buttonSelected ^ false! ! !MCTool methodsFor: 'morphic ui' stamp: 'AlainPlantec 12/16/2009 22:11'! preferredColor ^ (Color r: 0.627 g: 0.69 b: 0.976)! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:23'! getMenu: aMenu ^aMenu! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:46'! listMorph: listSymbol selection: selectionSymbol menu: menuSymbol ^ PluggableListMorph on: self list: listSymbol selected: selectionSymbol changeSelected: (selectionSymbol, ':') asSymbol menu: menuSymbol! ! !MCTool methodsFor: 'morphic ui' stamp: 'MarcusDenker 9/23/2011 10:01'! multiListMorph: listSymbol selection: selectionSymbol listSelection: listSelectionSymbol menu: menuSymbol ^ PluggableListMorph on: self list: listSymbol primarySelection: selectionSymbol changePrimarySelection: (selectionSymbol, ':') asSymbol listSelection: listSelectionSymbol changeListSelection: (listSelectionSymbol, 'put:') asSymbol menu: menuSymbol! ! !MCTool methodsFor: 'morphic ui' stamp: 'bf 3/16/2005 14:48'! findListMorph: aSymbol ^ morph submorphs detect: [:ea | (ea respondsTo: #getListSelector) and: [ea getListSelector = aSymbol]] ifNone: []! ! !MCTool methodsFor: 'morphic ui' stamp: 'lr 10/5/2003 09:09'! performButtonAction: anActionSelector enabled: anEnabledSelector (self perform: anEnabledSelector) ifTrue: [ self perform: anActionSelector ]! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:36'! textMorph: aSymbol ^ PluggableTextMorph on: self text: aSymbol accept: (aSymbol, ':') asSymbol! ! !MCTool methodsFor: 'morphic ui' stamp: 'lr 7/28/2011 16:23'! buttonRow: specArray | aRow | aRow := PanelMorph new. aRow layoutPolicy: TableLayout new; listDirection: #leftToRight. aRow hResizing: #spaceFill; vResizing: #spaceFill; rubberBandCells: true. aRow clipSubmorphs: true; borderWidth: 0. aRow layoutInset: 2@2; cellInset: 1. aRow wrapCentering: #center; cellPositioning: #leftCenter. specArray do: [:triplet | | aButton state | state := triplet at: 5 ifAbsent: [#buttonState]. aButton := PluggableButtonMorph on: self getState: state action: #performButtonAction:enabled:. aButton hResizing: #spaceFill; vResizing: #spaceFill; label: triplet first asString; getEnabledSelector: (triplet at: 4 ifAbsent: [#buttonEnabled]); arguments: (Array with: triplet second with: (triplet at: 4 ifAbsent: [#buttonEnabled])). aRow addMorphBack: aButton. aButton setBalloonText: triplet third]. ^ aRow! ! !MCTool methodsFor: 'morphic ui' stamp: 'AlainPlantec 12/16/2009 22:08'! patchworkUIThemeColor "Answer a default color for UI themes that make use of different colors for Browser, MessageList etc..." ^ (Color r: 0.627 g: 0.69 b: 0.976)! ! !MCTool methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:43'! treeMorph: listSymbol selection: selectionSymbol menu: menuSymbol ^ SimpleHierarchicalListMorph on: self list: listSymbol selected: selectionSymbol changeSelected: (selectionSymbol, ':') asSymbol menu: menuSymbol keystroke: nil! ! !MCTool methodsFor: 'accessing' stamp: 'gvc 5/11/2006 11:13'! minimumExtent "Answer the minumum extent for the tool." ^100@100! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:36'! label ^ label ifNil: [self defaultLabel]! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 18:34'! buttonRow ^ self buttonRow: self buttonSpecs! ! !MCTool methodsFor: 'morphic ui' stamp: 'CamilloBruni 2/4/2012 12:27'! setDefaultFocus "set the default focus on the morph elements. specializ this in subclasses"! ! !MCTool methodsFor: 'morphic ui' stamp: 'bf 5/27/2005 19:19'! buttonEnabled ^ true! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:46'! listMorph: listSymbol selection: selectionSymbol ^ PluggableListMorph on: self list: listSymbol selected: selectionSymbol changeSelected: (selectionSymbol, ':') asSymbol! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 22:33'! fillMenu: aMenu fromSpecs: anArray anArray do: [:pair | aMenu add: pair first target: self selector: pair second]. ^ aMenu! ! !MCTool methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 17:30'! listMorph: listSymbol ^ self listMorph: (listSymbol, 'List') asSymbol selection: (listSymbol, 'Selection') asSymbol menu: (listSymbol, 'ListMenu:') asSymbol! ! !MCTool class methodsFor: 'window color' stamp: 'AlainPlantec 12/16/2009 22:09'! patchworkUIThemeColor "Answer a default color for UI themes that make use of different colors for Browser, MessageList etc..." ^ (Color r: 0.627 g: 0.69 b: 0.976)! ! !MCTool class methodsFor: 'window color' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme "Answer the ui theme that provides controls." ^ Smalltalk ui theme ! ! !MCTraitDefinition commentStamp: ''! A MCTraitDefinition represents a trait.! !MCTraitDefinition methodsFor: '*Ring-Monticello' stamp: 'VeronicaUquillas 8/4/2011 12:11'! printMetaDefinitionOn: stream stream nextPutAll: self className, ' classTrait'; crtab; nextPutAll: 'uses: '; nextPutAll: self classTraitCompositionString.! ! !MCTraitDefinition methodsFor: 'comparing' stamp: 'al 6/5/2006 14:14'! hash | hash | hash := String stringHash: name initialHash: 0. hash := String stringHash: self traitCompositionString initialHash: hash. hash := String stringHash: (category ifNil: ['']) initialHash: hash. ^ hash ! ! !MCTraitDefinition methodsFor: 'printing' stamp: 'MartinDias 3/5/2014 18:49'! printClassDefinitionOn: stream ^ self printMetaDefinitionOn: stream! ! !MCTraitDefinition methodsFor: 'printing' stamp: 'al 6/5/2006 14:15'! printDefinitionOn: stream stream nextPutAll: 'Trait named: #', self className; cr; tab; nextPutAll: 'uses: '; nextPutAll: self traitCompositionString; cr; tab; nextPutAll: 'category: '; store: self category asString ! ! !MCTraitDefinition methodsFor: 'comparing' stamp: 'MarcusDenker 5/18/2013 15:44'! requirements "Assuming that traits in a composition can be identified by testing for the first character beeing an uppercase character (and thus not a special character such as {, # etc.)" | tokens traitNames | self hasTraitComposition ifFalse: [ ^Array new ]. tokens := self traitComposition parseLiterals. traitNames := tokens select: [:each | each first isUppercase]. ^traitNames asArray! ! !MCTraitDefinition methodsFor: 'testing' stamp: 'al 10/9/2005 20:28'! hasClassInstanceVariables ^ false ! ! !MCTraitDefinition methodsFor: 'initializing' stamp: 'al 6/5/2006 14:14'! initializeWithName: classNameString traitComposition: traitCompositionString category: categoryString comment: commentString commentStamp: commentStampString name := classNameString asSymbol. traitComposition := traitCompositionString. category := categoryString. comment := commentString withSqueakLineEndings. commentStamp := commentStampString ifNil: [self defaultCommentStamp] ! ! !MCTraitDefinition methodsFor: 'comparing' stamp: 'nice 10/31/2009 13:10'! = aDefinition self flag: #traits. "Ugly we harcoded the super superclass method. We will have to refactor the definition hierarchy" ^ (aDefinition isKindOf: MCDefinition) and: [(self isRevisionOf: aDefinition) and: [self traitCompositionString = aDefinition traitCompositionString and: [category = aDefinition category and: [comment = aDefinition comment]]]]! ! !MCTraitDefinition methodsFor: 'visiting' stamp: 'al 10/9/2005 20:28'! accept: aVisitor ^ aVisitor visitTraitDefinition: self ! ! !MCTraitDefinition methodsFor: '*Ring-Monticello' stamp: 'VeronicaUquillas 8/4/2011 14:07'! asRingDefinition | ring | ring := (RGFactory current createTraitNamed: self className) category: self category; superclassName: self superclassName; traitCompositionSource: self traitCompositionString; comment: self comment; stamp: self commentStamp; definitionSource: self definitionString; withMetaclass. ring theMetaClass traitCompositionSource: self classTraitCompositionString; definitionSource: self classDefinitionString. ^ring! ! !MCTraitDefinition methodsFor: 'visiting' stamp: 'MarcusDenker 5/2/2013 11:34'! createClass ^Trait named: name uses: (self class compiler evaluate: self traitCompositionString) category: category ! ! !MCTraitDefinition methodsFor: 'installing' stamp: 'marcus.denker 11/10/2008 10:04'! load self createClass ifNotNil: [:trait | self hasComment ifTrue: [trait classComment: comment stamp: commentStamp]]! ! !MCTraitDefinition methodsFor: '*Ring-Monticello' stamp: 'MarcusDenker 5/18/2013 15:44'! classTraitCompositionString ^self traitComposition ifNil: [ '{}' ] ifNotNil: [ :source| | tokens tcs | tcs := ''. tokens := source parseLiterals. tokens do:[ :each| each first isUppercase ifTrue: [ tcs := tcs, each, ' classTrait + ' ] ]. tcs isEmpty ifTrue: [ '{}' ] ifFalse:[ tcs copyFrom: 1 to: tcs size - 3 ] ]! ! !MCTraitDefinition methodsFor: '*Ring-Monticello' stamp: 'VeronicaUquillas 8/4/2011 11:53'! classDefinitionString "Answer a string describing the class-side definition." ^String streamContents: [:stream | self printMetaDefinitionOn: stream]! ! !MCTraitDefinition class methodsFor: 'instance-creation' stamp: 'al 10/9/2005 20:28'! name: classNameString traitComposition: traitCompositionString category: categoryString comment: commentString commentStamp: commentStamp ^ self instanceLike: (self new initializeWithName: classNameString traitComposition: traitCompositionString category: categoryString comment: commentString commentStamp: commentStamp) ! ! !MCTraitParser commentStamp: ''! A MCTraitParser extracts an MCTraitDefinition from the source.! !MCTraitParser methodsFor: 'actions' stamp: 'MarcusDenker 5/18/2013 15:44'! addDefinitionsTo: aCollection | tokens definition traitCompositionString | tokens := source parseLiterals. traitCompositionString := (source readStream match: 'uses:'; upToAll: 'category:') trimBoth. definition := MCTraitDefinition name: (tokens at: 3) traitComposition: traitCompositionString category: tokens last comment: '' commentStamp: ''. aCollection add: definition.! ! !MCTraitParser class methodsFor: 'factory identification hook' stamp: 'al 10/9/2005 21:09'! pattern ^ 'Trait named:*'! ! !MCVariableDefinition commentStamp: ''! A MCVariableDefinition represents a variable.! !MCVariableDefinition methodsFor: 'comparing' stamp: 'cwp 7/7/2003 23:02'! hash ^ name hash! ! !MCVariableDefinition methodsFor: 'comparing' stamp: 'cwp 7/7/2003 23:02'! = other ^ (self species = other species) and: [self name = other name]! ! !MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:51'! isPoolImport ^ false! ! !MCVariableDefinition methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! name: aString name := aString! ! !MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:31'! isClassInstanceVariable ^ false! ! !MCVariableDefinition methodsFor: 'printing' stamp: 'nk 7/24/2003 14:56'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self name; nextPut: $)! ! !MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:10'! isInstanceVariableDefinition ^ false! ! !MCVariableDefinition methodsFor: 'testing' stamp: 'bf 8/29/2006 11:41'! isOrderDependend ^true! ! !MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:08'! isClassInstanceVariableDefinition ^ false! ! !MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:30'! isClassVariable ^ false! ! !MCVariableDefinition methodsFor: 'accessing' stamp: 'cwp 11/25/2002 05:57'! name ^ name! ! !MCVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:31'! isInstanceVariable ^ false! ! !MCVariableDefinition class methodsFor: 'instance-creation' stamp: 'cwp 7/7/2003 23:18'! name: aString ^ self new name: aString ! ! !MCVersion commentStamp: 'TorstenBergmann 2/5/2014 13:56'! A Metacello version! !MCVersion methodsFor: 'accessing' stamp: 'CamilloBruni 9/30/2011 16:20'! loadCompletePackageSnapshot | definitions | definitions := package snapshot definitions asOrderedCollection. self dependencies do: [ :each| definitions addAll: each package snapshot definitions ] displayingProgress: [ :item| 'Loading dependencies from: ', item package name ]. ^ MCSnapshot fromDefinitions: definitions ! ! !MCVersion methodsFor: 'accessing' stamp: 'CamilloBruni 9/30/2011 16:18'! changes ^ self completeSnapshot patchRelativeToBase: self completePackageSnapshot! ! !MCVersion methodsFor: 'accessing' stamp: 'avi 2/12/2004 19:38'! workingCopy ^ package workingCopy! ! !MCVersion methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/26/2013 14:39'! silentlyInitializeWithPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection package := aPackage. info := aVersionInfo. snapshot := aSnapshot. dependencies := aCollection! ! !MCVersion methodsFor: 'actions' stamp: 'avi 2/12/2004 19:37'! adopt self workingCopy adopt: self! ! !MCVersion methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection package := aPackage. info := aVersionInfo. snapshot := aSnapshot. dependencies := aCollection. self addToCache.! ! !MCVersion methodsFor: 'accessing' stamp: 'nice 4/7/2014 22:06'! completePackageSnapshot "Answer with a snapshot of current working copy of this package and all its dependencies." ^self loadCompletePackageSnapshot! ! !MCVersion methodsFor: 'testing' stamp: 'bf 5/23/2005 15:43'! canOptimizeLoading "Answer wether I can provide a patch for the working copy without the usual diff pass" ^false! ! !MCVersion methodsFor: 'accessing' stamp: 'CamilloBruni 9/30/2011 16:12'! loadCompleteSnapshot |definitions| definitions := self snapshot definitions asOrderedCollection. self dependencies do: [ :each| definitions addAll: each resolve completeSnapshot definitions ] displayingProgress: [ :item| 'Loading dependencies from: ', item package name ]. ^ MCSnapshot fromDefinitions: definitions! ! !MCVersion methodsFor: 'actions' stamp: 'SeanDeNigris 7/17/2012 15:40'! addToCache MCCacheRepository uniqueInstance storeVersion: self! ! !MCVersion methodsFor: '*MonticelloGUI' stamp: 'BenjaminVanRyseghem 2/8/2012 17:10'! browse ^ (MCSnapshotBrowser forSnapshot: self completeSnapshot) showLabelled: 'Snapshot of ', self fileName! ! !MCVersion methodsFor: 'actions' stamp: 'avi 1/22/2004 12:44'! fileOutOn: aStream self writerClass fileOut: self on: aStream! ! !MCVersion methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! setPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection package := aPackage. info := aVersionInfo. snapshot := aSnapshot. dependencies := aCollection! ! !MCVersion methodsFor: 'accessing' stamp: 'avi 1/22/2004 12:44'! fileName ^ info name, '.', self writerClass extension! ! !MCVersion methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:19'! package ^ package! ! !MCVersion methodsFor: 'enumerating' stamp: 'cwp 11/7/2004 14:24'! withAllDependenciesDo: aBlock self allDependenciesDo: aBlock ifUnresolved: [:ignored]. aBlock value: self! ! !MCVersion methodsFor: 'actions' stamp: 'avi 1/24/2004 20:13'! load MCVersionLoader loadVersion: self! ! !MCVersion methodsFor: 'printing' stamp: 'nk 3/8/2004 23:54'! printOn: aStream super printOn: aStream. aStream nextPut: $(. aStream nextPutAll: self info name. aStream nextPut: $).! ! !MCVersion methodsFor: 'actions' stamp: 'abc 2/13/2004 15:58'! merge MCVersionMerger mergeVersion: self! ! !MCVersion methodsFor: 'converting' stamp: 'avi 2/19/2004 21:00'! asDiffAgainst: aVersion aVersion info = self info ifTrue: [self error: 'Cannot diff against self!!']. ^ MCDiffyVersion package: self package info: self info snapshot: self snapshot dependencies: self dependencies baseVersion: aVersion! ! !MCVersion methodsFor: 'enumerating' stamp: 'stephaneducasse 2/4/2006 20:47'! allDependenciesDo: aBlock ifUnresolved: failBlock | dict | dict := Dictionary new. self allDependenciesNotIn: dict do: aBlock ifUnresolved: failBlock! ! !MCVersion methodsFor: 'accessing' stamp: 'avi 1/22/2004 12:44'! writerClass ^ MCMczWriter ! ! !MCVersion methodsFor: 'accessing' stamp: 'CamilloBruni 9/30/2011 16:08'! completeSnapshot ^ completeSnapshot ifNil: [ completeSnapshot := self loadCompleteSnapshot ]! ! !MCVersion methodsFor: 'enumerating' stamp: 'cwp 11/7/2004 11:58'! allDependenciesDo: aBlock self allDependenciesDo: aBlock ifUnresolved: [:ignored | true]! ! !MCVersion methodsFor: 'testing' stamp: 'avi 2/13/2004 23:24'! isDiffy ^ false! ! !MCVersion methodsFor: 'accessing' stamp: 'adrian_lienhard 1/7/2009 17:32'! summary ^ String streamContents: [:s | s nextPutAll: info summaryHeader. (dependencies isNil or: [dependencies isEmpty]) ifFalse: [s cr; nextPutAll: 'Dependencies: '. dependencies do: [:ea | s nextPutAll: ea versionInfo name] separatedBy: [s nextPutAll: ', ']]. s cr; cr; nextPutAll: info message]! ! !MCVersion methodsFor: 'testing' stamp: 'bf 3/22/2005 23:00'! isCacheable ^true! ! !MCVersion methodsFor: 'enumerating' stamp: 'stephaneducasse 2/4/2006 20:47'! withAllDependenciesDo: aBlock ifUnresolved: failBlock | dict | dict := Dictionary new. self allDependenciesNotIn: dict do: aBlock ifUnresolved: failBlock. aBlock value: self! ! !MCVersion methodsFor: 'enumerating' stamp: 'nice 1/5/2010 15:59'! allAvailableDependenciesDo: aBlock self dependencies do: [:ea | [ | version |version := ea resolve. version allAvailableDependenciesDo: aBlock. aBlock value: version] on: Error do: []]! ! !MCVersion methodsFor: 'accessing' stamp: 'CamilloBruni 4/20/2012 18:21'! snapshot "lazily load snapshot..." snapshot isBlock ifTrue: [ snapshot := snapshot value ]. ^ snapshot! ! !MCVersion methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:28'! info ^ info! ! !MCVersion methodsFor: '*MonticelloGUI' stamp: 'ab 7/12/2003 00:19'! open (MCVersionInspector new version: self) show! ! !MCVersion methodsFor: 'accessing' stamp: 'avi 1/22/2004 00:24'! dependencies ^ dependencies ifNil: [#()]! ! !MCVersion methodsFor: 'enumerating' stamp: 'nice 1/5/2010 15:59'! allDependenciesNotIn: aDictionary do: aBlock ifUnresolved: failBlock self dependencies do: [:ea | | version | version := aDictionary at: ea ifAbsent: [ea resolve]. version ifNil: [failBlock value: ea] ifNotNil: [(aDictionary includes: version) ifFalse: [aDictionary at: ea put: version. version allDependenciesNotIn: aDictionary do: aBlock ifUnresolved: failBlock. aBlock value: version]]]! ! !MCVersion class methodsFor: 'instance creation' stamp: 'ab 7/7/2003 16:13'! package: aPackage info: aVersionInfo ^ self package: aPackage info: aVersionInfo snapshot: aPackage snapshot! ! !MCVersion class methodsFor: '*Komitter-Models' stamp: 'BenjaminVanRyseghem 11/26/2013 14:39'! silentlyPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection ^ self new silentlyInitializeWithPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection! ! !MCVersion class methodsFor: 'instance creation' stamp: 'cwp 11/7/2004 13:02'! package: aPackage info: aVersionInfo snapshot: aSnapshot ^ self package: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: #()! ! !MCVersion class methodsFor: 'instance creation' stamp: 'avi 1/19/2004 13:11'! package: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection ^ self new initializeWithPackage: aPackage info: aVersionInfo snapshot: aSnapshot dependencies: aCollection! ! !MCVersion class methodsFor: 'instance creation' stamp: 'ab 7/7/2003 16:13'! package: aPackage ^ self package: aPackage info: MCVersionInfo new! ! !MCVersionCreated commentStamp: ''! An MCVersionCreated is raised when a MCVersion is created ! !MCVersionCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:56'! nameString: anObject nameString := anObject! ! !MCVersionCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:56'! version ^ version! ! !MCVersionCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:56'! nameString ^ nameString! ! !MCVersionCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:56'! version: anObject version := anObject! ! !MCVersionCreated class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 13:56'! name: aName nameString: aString version: aMCVersion ^ self new name: aName; nameString: aString; version: aMCVersion; yourself! ! !MCVersionCreated class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/24/2011 14:57'! name: aName message: aString version: aMCVersion ^ self new name: aName; nameString: aString; version: aMCVersion; yourself! ! !MCVersionDependency commentStamp: 'TorstenBergmann 2/6/2014 08:09'! Dependencies! !MCVersionDependency methodsFor: 'testing' stamp: 'avi 3/4/2004 00:34'! isFulfilledBy: anAncestry ^ anAncestry ancestors includes: versionInfo! ! !MCVersionDependency methodsFor: 'comparing' stamp: 'avi 1/19/2004 16:06'! hash ^ versionInfo hash! ! !MCVersionDependency methodsFor: 'accessing' stamp: 'avi 2/12/2004 19:38'! repositoryGroup ^ self package workingCopy repositoryGroup! ! !MCVersionDependency methodsFor: 'accessing' stamp: 'avi 1/19/2004 15:40'! versionInfo ^ versionInfo! ! !MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'! isFulfilledByAncestors ^ package hasWorkingCopy and: [self isFulfilledByAncestorsOf: package workingCopy ancestry]! ! !MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'! isOlder "Answer true if I represent an older version of a package that is loaded." ^ package hasWorkingCopy and: [self isFulfilled not and: [ self isFulfilledByAncestors and: [package workingCopy modified not]]]! ! !MCVersionDependency methodsFor: 'testing' stamp: 'nk 7/13/2004 08:45'! isFulfilledByAncestorsOf: anAncestry ^ anAncestry hasAncestor: versionInfo! ! !MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'! isCurrent ^ package hasWorkingCopy and: [self isFulfilled and: [package workingCopy modified not]]! ! !MCVersionDependency methodsFor: 'comparing' stamp: 'avi 1/19/2004 16:12'! = other ^ other species = self species and: [other versionInfo = versionInfo and: [other package = package]]! ! !MCVersionDependency methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithPackage: aPackage info: aVersionInfo package := aPackage. versionInfo := aVersionInfo! ! !MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'! isFulfilled ^package hasWorkingCopy and: [self isFulfilledBy: package workingCopy ancestry]! ! !MCVersionDependency methodsFor: 'accessing' stamp: 'avi 1/19/2004 15:40'! package ^ package! ! !MCVersionDependency methodsFor: 'resolving' stamp: 'nk 6/13/2004 19:21'! resolve ^ self repositoryGroup versionWithInfo: versionInfo ifNone: [ MCRepositoryGroup default versionWithInfo: versionInfo ifNone: []]! ! !MCVersionDependency class methodsFor: 'instance-creation' stamp: 'avi 1/19/2004 13:13'! package: aPackage info: aVersionInfo ^ self basicNew initializeWithPackage: aPackage info: aVersionInfo! ! !MCVersionHistoryBrowser commentStamp: 'TorstenBergmann 2/20/2014 15:53'! Browser for version history! !MCVersionHistoryBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 2/3/2010 15:31'! viewChanges "View the changes between a prior version and this version." self viewChanges: (self baseSnapshot patchRelativeToBase: self selectedSnapshot) from: self selectedInfo name to: ancestry name! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/7/2003 21:27'! repositoryGroup ^ MCRepositoryGroup default! ! !MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'avi 2/13/2004 01:09'! getMenu: aMenu index < 2 ifTrue: [^ aMenu]. self fillMenu: aMenu fromSpecs: (Array with: (Array with: 'view changes -> ', ancestry name with: #viewChanges) with: #('spawn history' spawnHistory)). ^ aMenu! ! !MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:41'! defaultExtent ^ 440@169. ! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:10'! baseSnapshot ^ self snapshotForInfo: ancestry! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:39'! selectedSnapshot ^ self snapshotForInfo: self selectedInfo! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! summary | selInfo | selInfo := self selectedInfo. ^ selInfo ifNil: [''] ifNotNil: [selInfo summary]! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:38'! snapshotForInfo: aVersionInfo ^ (self repositoryGroup versionWithInfo: aVersionInfo) snapshot! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 7/11/2003 23:24'! selection ^ index ifNil: [0]! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! infos ^ infos ifNil: [infos := ancestry withBreadthFirstAncestors]! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! package: aMCPackage package := aMCPackage! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! index: anObject "Set the value of index" index := anObject! ! !MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'avi 2/13/2004 01:09'! defaultLabel ^ ancestry name, ' History'! ! !MCVersionHistoryBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 2/9/2010 14:06'! viewChanges: patch from: fromDescription to: toDescription "Open a browser on the patch." |patchLabel| patchLabel := 'Changes between {1} and {2}' translated format: {fromDescription. toDescription}. PSMCPatchMorph usedByDefault ifTrue: [((PSMCPatchMorph forPatch: patch) fromDescription: fromDescription; toDescription: toDescription; newWindow) title: patchLabel; open] ifFalse: [(MCPatchBrowser forPatch: patch) label: patchLabel; show]! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 9/17/2005 16:09'! selectedInfo ^ self infos at: self selection ifAbsent: [nil]! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! selection: aNumber index := aNumber. self changed: #selection; changed: #summary! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! ancestry: anAncestry ancestry := anAncestry! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 9/17/2005 16:10'! list ^ self infos collect: [:ea | ea name]! ! !MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'avi 2/13/2004 01:10'! spawnHistory MCVersionHistoryBrowser new ancestry: self selectedInfo; package: package; show! ! !MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'nk 7/28/2003 18:05'! widgetSpecs ^ #( ((listMorph:selection:menu: list selection getMenu:) (0 0 0.3 1)) ((textMorph: summary) (0.3 0 1 1)) )! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:41'! index "Answer the value of index" ^ index! ! !MCVersionInfo commentStamp: ''! Adds to the record of ancestry, other identifying details.! !MCVersionInfo methodsFor: 'comparing' stamp: 'ab 7/5/2003 14:09'! hash ^ id hash! ! !MCVersionInfo methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithName: vName id: aUUID message: aString date: aDate time: aTime author: initials ancestors: aCollection stepChildren: stepCollection name := vName. id := aUUID. message := aString. date := aDate. time := aTime. author := initials. ancestors := aCollection. stepChildren := stepCollection! ! !MCVersionInfo methodsFor: 'accessing' stamp: 'adrian_lienhard 1/7/2009 17:31'! summary ^ String streamContents: [:s | s nextPutAll: self summaryHeader; cr; cr; nextPutAll: self message. ]! ! !MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:24'! id ^ id ! ! !MCVersionInfo methodsFor: 'comparing' stamp: 'ab 7/5/2003 14:23'! = other ^ other species = self species and: [other hasID: id]! ! !MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:26'! author ^ author! ! !MCVersionInfo methodsFor: 'printing' stamp: 'ab 7/5/2003 18:00'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self name; nextPut: $) ! ! !MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:26'! date ^ date! ! !MCVersionInfo methodsFor: 'accessing' stamp: 'avi 9/17/2003 11:24'! timeString ^ date asString, ', ', time asString! ! !MCVersionInfo methodsFor: 'accessing' stamp: 'ab 7/12/2003 00:04'! message ^ message ifNil: ['']! ! !MCVersionInfo methodsFor: 'private' stamp: 'ab 7/5/2003 14:10'! hasID: aUUID ^ id = aUUID! ! !MCVersionInfo methodsFor: 'converting' stamp: 'StephaneDucasse 8/17/2012 15:54'! asDictionary ^ Dictionary new at: #name put: name; at: #id put: id asString; at: #message put: message; at: #date put: date; at: #time put: time; at: #author put: author; at: #ancestors put: (self ancestors collect: [:a | a asDictionary]); yourself! ! !MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:26'! time ^ time! ! !MCVersionInfo methodsFor: 'accessing' stamp: 'ab 7/11/2003 23:33'! name ^ name ifNil: ['']! ! !MCVersionInfo methodsFor: 'accessing' stamp: 'avi 9/14/2004 15:22'! summaryHeader ^ String streamContents: [:s | s nextPutAll: 'Name: '; nextPutAll: self name; cr. date ifNotNil: [s nextPutAll: 'Author: '; nextPutAll: author; cr; nextPutAll: 'Time: '; nextPutAll: date asString, ', ', time asString; cr]. id ifNotNil: [s nextPutAll: 'UUID: '; nextPutAll: id asString; cr]. s nextPutAll: 'Ancestors: '; nextPutAll: self ancestorString. self stepChildren isEmpty ifFalse: [s cr; nextPutAll: 'Backported From: '; nextPutAll: self stepChildrenString]. ]! ! !MCVersionInfo methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/22/2013 16:30'! timeStamp ^ DateAndTime date: date time: time! ! !MCVersionInfo methodsFor: 'accessing' stamp: 'BernhardPieber 11/21/2010 18:48'! nameWithout: packageName | result | result := self name. (result beginsWith: packageName , '-') ifTrue: [ result := result copyFrom: packageName size + 2 to: result size]. ^result! ! !MCVersionInfo class methodsFor: 'instance-creation' stamp: 'avi 9/11/2004 10:44'! name: vName id: id message: message date: date time: time author: author ancestors: ancestors ^ self name: vName id: id message: message date: date time: time author: author ancestors: ancestors stepChildren: #()! ! !MCVersionInfo class methodsFor: 'instance-creation' stamp: 'avi 9/11/2004 10:43'! name: vName id: id message: message date: date time: time author: author ancestors: ancestors stepChildren: stepChildren ^ self new initializeWithName: vName id: id message: message date: date time: time author: author ancestors: ancestors stepChildren: stepChildren! ! !MCVersionInfoWriter commentStamp: ''! I serialize an MCVersionInfo into a given stream. If the version info has been serialized before I output a compacted version consiting of the id. ! !MCVersionInfoWriter methodsFor: 'testing' stamp: 'avi 1/22/2004 21:10'! isWritten: aVersionInfo ^ self written includes: aVersionInfo! ! !MCVersionInfoWriter methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! written ^ written ifNil: [written := Set new]! ! !MCVersionInfoWriter methodsFor: 'serialization' stamp: 'avi 1/22/2004 21:10'! wrote: aVersionInfo self written add: aVersionInfo! ! !MCVersionInfoWriter methodsFor: 'serialization' stamp: 'IgorStasenko 11/28/2012 16:02'! writeVersionInfo: aVersionInfo (self isWritten: aVersionInfo) ifTrue: [^ stream nextPutAll: '(id '; print: aVersionInfo id asString; nextPut: $) ]. stream nextPut: $(. #(name message id date time author) do: [:sel | stream nextPutAll: sel; space; print: (((aVersionInfo perform: sel) ifNil: ['']) asString convertToEncoding: 'latin-1' ); space ]. stream nextPutAll: 'ancestors ('. aVersionInfo ancestors do: [:ea | self writeVersionInfo: ea]. stream nextPutAll: ') stepChildren ('. aVersionInfo stepChildren do: [:ea | self writeVersionInfo: ea]. stream nextPutAll: '))'. self wrote: aVersionInfo! ! !MCVersionInspector commentStamp: ''! I am a tool that visually represents an MCVersion. While I can be opened on anMCVersion, you've probably seen me most often after saving a package in the Monticello Browser. I have buttons to perform common version-related actions - like browsing, loading, and viewing changes. In my main text area, I display the following information about my version - name, author, timestamp, UUID, ancestors and log message.! !MCVersionInspector methodsFor: 'actions' stamp: 'CamilloBruni 9/30/2011 16:44'! changes "Open a patch morph for the changes." self viewChanges: self version changes from: self version workingCopy description to: self version info name! ! !MCVersionInspector methodsFor: 'accessing' stamp: 'avi 9/17/2005 17:16'! versionInfo ^ self version info! ! !MCVersionInspector methodsFor: 'morphic ui' stamp: 'avi 8/31/2003 00:45'! defaultExtent ^ 400@200! ! !MCVersionInspector methodsFor: 'accessing' stamp: 'avi 2/28/2004 20:19'! version ^ version! ! !MCVersionInspector methodsFor: 'actions' stamp: 'avi 2/28/2004 20:19'! adopt (self confirm: 'Modifying ancestry can be dangerous unless you know what you are doing. Are you sure you want to adopt ',self version info name, ' as an ancestor of your working copy?') ifTrue: [self version adopt]! ! !MCVersionInspector methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 2/8/2012 17:10'! browse ^ self version browse! ! !MCVersionInspector methodsFor: 'testing' stamp: 'lr 9/26/2003 20:15'! hasVersion ^version notNil! ! !MCVersionInspector methodsFor: 'actions' stamp: 'avi 9/17/2005 17:14'! history (MCVersionHistoryBrowser new ancestry: self versionInfo) show! ! !MCVersionInspector methodsFor: 'accessing' stamp: 'avi 9/17/2005 17:16'! summary ^self hasVersion ifTrue: [ self versionSummary ] ifFalse: [ String new ]! ! !MCVersionInspector methodsFor: 'morphic ui' stamp: 'Rik 12/17/2004 06:07'! buttonSpecs ^ #((Browse browse 'Browse this version' hasVersion) (History history 'Browse the history of this version' hasVersion) (Changes changes 'Browse the changes this version would make to the image' hasVersion) (Load load 'Load this version into the image' hasVersion) (Merge merge 'Merge this version into the image' hasVersion) (Adopt adopt 'Adopt this version as an ancestor of your working copy' hasVersion) (Copy save 'Copy this version to another repository' hasVersion) (Diff diff 'Create an equivalent version based on an earlier release' hasVersion))! ! !MCVersionInspector methodsFor: 'morphic ui' stamp: 'ar 8/6/2009 18:25'! pickRepository | index | index := UIManager default chooseFrom: (self repositories collect: [:ea | ea description]) title: 'Repository:'. ^ index = 0 ifFalse: [self repositories at: index]! ! !MCVersionInspector methodsFor: 'morphic ui' stamp: 'avi 8/31/2003 00:44'! repositories ^ MCRepositoryGroup default repositories! ! !MCVersionInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:18'! defaultLabel ^ 'Version: ', self version info name! ! !MCVersionInspector methodsFor: 'actions' stamp: 'bf 3/14/2005 15:32'! load Cursor wait showWhile: [self version load]! ! !MCVersionInspector methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! diff | ancestorVersion | self pickAncestor ifNotNil: [:ancestor | ancestorVersion := self version workingCopy repositoryGroup versionWithInfo: ancestor. (self version asDiffAgainst: ancestorVersion) open]! ! !MCVersionInspector methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 3/22/2013 15:54'! save self pickRepository ifNotNil: [ :ea | self version dependencies do: [ :each | ea storeVersion: each resolve ]. ea storeVersion: self version ]! ! !MCVersionInspector methodsFor: 'morphic ui' stamp: 'ar 8/6/2009 18:25'! pickAncestor | index versions | versions := self version info breadthFirstAncestors. index := UIManager default chooseFrom: (versions collect: [:ea | ea name]) title: 'Ancestor:'. ^ index = 0 ifFalse: [versions at: index]! ! !MCVersionInspector methodsFor: 'actions' stamp: 'avi 2/28/2004 20:19'! merge self version merge! ! !MCVersionInspector methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 18:43'! widgetSpecs ^ #( ((buttonRow) (0 0 1 0) (0 0 0 30)) ((textMorph: summary) (0 0 1 1) (0 30 0 0)) )! ! !MCVersionInspector methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 2/9/2010 14:06'! viewChanges: patch from: fromDescription to: toDescription "Open a patch morph for the changes." |title| title := 'Changes from {1} to {2}' format: {fromDescription. toDescription}. PSMCPatchMorph usedByDefault ifTrue: [((PSMCPatchMorph forPatch: patch) fromDescription: fromDescription; toDescription: toDescription; newWindow) title: title; open] ifFalse: [(MCPatchBrowser forPatch: self version changes) showLabelled: title]! ! !MCVersionInspector methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! version: aVersion version := aVersion! ! !MCVersionInspector methodsFor: 'accessing' stamp: 'avi 9/17/2005 17:16'! versionSummary ^ self version summary! ! !MCVersionInspector class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallSaveIcon! ! !MCVersionLoader commentStamp: ''! A MCVersionLoader is responsible for loading a given version. ! !MCVersionLoader methodsFor: 'checking' stamp: 'cwp 11/7/2004 17:02'! depAgeIsOk: aDependency ^ aDependency isOlder not or: [self confirm: 'load older dependency ', aDependency versionInfo name , '?']! ! !MCVersionLoader methodsFor: 'checking' stamp: 'abc 8/8/2011 12:48'! warnAboutLosingChangesTo: versionCollection ^ (MCMergeOrLoadWarning signalFor: versionCollection).! ! !MCVersionLoader methodsFor: 'checking' stamp: 'CamilloBruni 1/16/2012 17:42'! warnAboutLosingChangesTo: versionCollection ifCancel: cancelBlock ifMerge: mergeBlock | result | result := (MCMergeOrLoadWarning signalFor: versionCollection). result = false ifTrue: [ ^ mergeBlock value ]. result = nil ifTrue: [ ^ cancelBlock value ]. "otherwise we will continue loading"! ! !MCVersionLoader methodsFor: 'checking' stamp: 'cwp 11/7/2004 17:06'! confirmMissingDependency: aDependency | name | name := aDependency versionInfo name. (self confirm: 'Can''t find dependency ', name, '. ignore?') ifFalse: [self error: 'Can''t find dependency ', name]! ! !MCVersionLoader methodsFor: 'checking' stamp: 'cwp 11/7/2004 17:00'! checkIfDepIsOlder: aDependency ^ aDependency isOlder not or: [self confirm: 'load older dependency ', aDependency versionInfo name , '?']! ! !MCVersionLoader methodsFor: 'loading' stamp: 'cwp 11/7/2004 17:04'! addVersion: aVersion aVersion dependencies do: [ :ea | self addDependency: ea]. versions add: aVersion. ! ! !MCVersionLoader methodsFor: 'private' stamp: 'EstebanLorenzano 1/3/2014 09:43'! ensurePackage: mcPackage RPackageOrganizer default registerPackageNamed: mcPackage name ! ! !MCVersionLoader methodsFor: 'loading' stamp: 'CamilloBruni 1/16/2012 17:06'! loadWithNameLike: aString | loader | self checkForModificationsIfCancel: [ ^ self] ifMerge: [ ^ self mergeVersions ]. loader := versions size > 1 ifTrue: [MCMultiPackageLoader new] ifFalse: [MCPackageLoader new]. versions do: [:ea | ea canOptimizeLoading ifTrue: [ea patch applyTo: loader] ifFalse: [loader updatePackage: ea package withSnapshot: ea snapshot]]. loader loadWithNameLike: aString. versions do: [:ea | ea workingCopy loaded: ea]! ! !MCVersionLoader methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:04'! initialize super initialize. versions := OrderedCollection new! ! !MCVersionLoader methodsFor: 'checking' stamp: 'CamilloBruni 8/4/2011 12:46'! localModifications ^ versions select: [:ea | ea package workingCopy modified]. ! ! !MCVersionLoader methodsFor: 'testing' stamp: 'CamilloBruni 9/28/2011 17:15'! hasLocalModifications ^ self localModifications isEmpty not ! ! !MCVersionLoader methodsFor: 'testing' stamp: 'sd 3/16/2008 08:53'! hasVersions ^ versions isEmpty not! ! !MCVersionLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! versions ^versions! ! !MCVersionLoader methodsFor: 'loading' stamp: 'EstebanLorenzano 10/4/2013 12:48'! load RPackageSet withCacheDo: [ | version | version := versions first. self ensurePackage: version package. self loadWithNameLike: version info name ].! ! !MCVersionLoader methodsFor: 'loading' stamp: 'cwp 11/7/2004 17:06'! addDependency: aDependency | dep | aDependency isCurrent ifTrue: [^ self]. (self depAgeIsOk: aDependency) ifFalse: [^ self]. dep := aDependency resolve. dep ifNil: [self confirmMissingDependency: aDependency] ifNotNil: [(versions includes: dep) ifFalse: [self addVersion: dep]]! ! !MCVersionLoader methodsFor: 'checking' stamp: 'md 3/5/2012 14:28'! checkForModificationsIfCancel: cancelBlock ifMerge: mergeBlock | modifications | "first check if there are local packages which are dirty" modifications := self localModifications. modifications isEmpty ifTrue: [ ^ self]. "ask the user what to do.. merge | overwrite | abort" ^ self warnAboutLosingChangesTo: modifications ifCancel: cancelBlock ifMerge: mergeBlock! ! !MCVersionLoader methodsFor: 'loading' stamp: 'abc 8/8/2011 13:01'! mergeVersions |merger| merger := MCVersionMerger new. merger addVersions: self localModifications. merger merge.! ! !MCVersionLoader class methodsFor: 'public api' stamp: 'avi 1/24/2004 20:06'! loadVersion: aVersion self new addVersion: aVersion; load! ! !MCVersionMerger commentStamp: 'TorstenBergmann 2/6/2014 08:09'! Merge versions! !MCVersionMerger methodsFor: 'adding' stamp: 'CamilloBruni 8/4/2011 13:49'! addVersions: aCollection aCollection do: [ :version| self addVersion: version].! ! !MCVersionMerger methodsFor: 'initialization' stamp: 'CamilloBruni 8/4/2011 14:03'! initialize super initialize. records := OrderedCollection new. merger := MCThreeWayMerger new.! ! !MCVersionMerger methodsFor: 'actions' stamp: 'CamilloBruni 9/30/2011 16:52'! gatherChanges records do: [:ea | merger addBaseSnapshot: ea packageSnapshot]. records do: [:ea | merger applyPatch: ea mergePatch].! ! !MCVersionMerger methodsFor: 'adding' stamp: 'CamilloBruni 9/30/2011 16:53'! addVersion: aVersion records add: (MCMergeRecord version: aVersion). aVersion dependencies do: [:ea | | dep | dep := ea resolve. (records anySatisfy: [:r | r version = dep]) ifFalse: [self addVersion: dep]] displayingProgress: [ :ea| 'Searching dependency: ', ea package name]! ! !MCVersionMerger methodsFor: 'actions' stamp: 'CamilloBruni 1/16/2012 15:49'! merge self gatherChanges. self resolveConflicts ifTrue: [merger load. records do: [:ea | ea updateWorkingCopy]. ^ true]. ^ false! ! !MCVersionMerger methodsFor: 'actions' stamp: 'CamilloBruni 8/4/2011 14:03'! resolveConflicts (records allSatisfy: [:ea | ea isAncestorMerge]) ifTrue: [ MCNoChangesException signal. ^ false]. ^ ((MCMergeResolutionRequest new merger: merger) signal: 'Merging ', records first version info name) = true! ! !MCVersionMerger methodsFor: 'actions' stamp: 'CamilloBruni 9/30/2011 16:51'! mergeWithNameLike: baseName self gatherChanges. self resolveConflicts ifTrue: [merger loadWithNameLike: baseName. records do: [:ea | ea updateWorkingCopy]].! ! !MCVersionMerger class methodsFor: 'action' stamp: 'CamilloBruni 9/30/2011 16:53'! mergeVersion: aVersion self new addVersion: aVersion; mergeWithNameLike: aVersion info name! ! !MCVersionNameAndMessageRequest commentStamp: 'TorstenBergmann 2/6/2014 08:09'! Notify to requests for version name and message! !MCVersionNameAndMessageRequest methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! suggestedName: aString suggestion := aString! ! !MCVersionNameAndMessageRequest methodsFor: '*MonticelloGUI' stamp: 'AndrewBlack 9/4/2009 14:11'! defaultAction ^ MCSaveVersionDialog new versionName: suggestion; logMessage: suggestedLogComment; showModally! ! !MCVersionNameAndMessageRequest methodsFor: 'accessing' stamp: 'AndrewBlack 9/4/2009 14:16'! suggestedLogComment: aLogMessage suggestedLogComment := aLogMessage! ! !MCVersionNameAndMessageRequest methodsFor: 'accessing' stamp: 'ab 7/10/2003 01:07'! suggestedName ^ suggestion! ! !MCVersionNameAndMessageRequest methodsFor: 'accessing' stamp: 'AndrewBlack 9/4/2009 14:16'! suggestedLogComment ^ suggestedLogComment! ! !MCVersionNotification commentStamp: 'TorstenBergmann 2/6/2014 08:10'! Version notification! !MCVersionNotification methodsFor: 'error handling' stamp: 'MarcusDenker 12/16/2013 14:44'! notify: aString | message | message := self messageTo: aString. SMTPClient deliverMailFrom: message from to: (Array with: message to) text: message text usingServer: MailComposition smtpServer! ! !MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! messageTo: aString | message | message := MailMessage empty. message setField: 'from' toString: self fromAddress. message setField: 'to' toString: aString. message setField: 'subject' toString: '[MC] ', version info name. message body: (MIMEDocument contentType: 'text/plain' content: self messageText). ^ message! ! !MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 15:13'! fromAddress ^ 'monticello@beta4.com'! ! !MCVersionNotification methodsFor: 'initialize-release' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithVersion: aVersion repository: aRepository version := aVersion. repository := aRepository. ancestor := repository closestAncestorVersionFor: version info ifNone: []. changes := ancestor ifNil: [#()] ifNotNil: [(version snapshot patchRelativeToBase: ancestor snapshot) operations asSortedCollection]! ! !MCVersionNotification methodsFor: 'accessing' stamp: 'avi 8/26/2004 15:12'! messageText ^ String streamContents: [:s | s nextPutAll: 'Committed to repository: ', repository description; cr; cr. s nextPutAll: version summary. changes isEmpty ifFalse: [s cr; cr. s nextPutAll: '-----------------------------------------------------'; cr. s nextPutAll: 'Changes since ', ancestor info name, ':'; cr. changes do: [:ea | s cr; nextPutAll: ea summary; cr. s nextPutAll: ea sourceString]]]! ! !MCVersionNotification class methodsFor: 'instance creation' stamp: 'avi 8/26/2004 14:27'! version: aVersion repository: aRepository ^ self basicNew initializeWithVersion: aVersion repository: aRepository! ! !MCVersionReader commentStamp: 'TorstenBergmann 2/5/2014 13:53'! A version reader! !MCVersionReader methodsFor: 'accessing' stamp: 'CamilloBruni 4/20/2012 18:18'! basicVersion ^ MCVersion package: self package info: self info snapshot: [ self snapshot ] dependencies: self dependencies! ! !MCVersionReader methodsFor: 'accessing' stamp: 'avi 1/21/2004 23:10'! definitions definitions ifNil: [self loadDefinitions]. ^ definitions! ! !MCVersionReader methodsFor: 'loading' stamp: 'ab 8/20/2003 19:54'! loadVersionInfo self subclassResponsibility! ! !MCVersionReader methodsFor: 'accessing' stamp: 'ab 8/20/2003 19:53'! package package ifNil: [self loadPackage]. ^ package! ! !MCVersionReader methodsFor: 'accessing' stamp: 'ab 8/20/2003 19:53'! info info ifNil: [self loadVersionInfo]. ^ info! ! !MCVersionReader methodsFor: 'loading' stamp: 'ab 8/20/2003 19:54'! loadPackage self subclassResponsibility ! ! !MCVersionReader methodsFor: 'accessing' stamp: 'avi 10/9/2003 12:38'! version ^ self basicVersion! ! !MCVersionReader methodsFor: 'loading' stamp: 'ab 8/20/2003 19:54'! loadDefinitions self subclassResponsibility ! ! !MCVersionReader methodsFor: 'accessing' stamp: 'ab 8/20/2003 19:54'! snapshot ^ MCSnapshot fromDefinitions: self definitions! ! !MCVersionReader methodsFor: 'accessing' stamp: 'avi 1/19/2004 14:50'! dependencies dependencies ifNil: [self loadDependencies]. ^ dependencies! ! !MCVersionReader methodsFor: 'loading' stamp: 'avi 1/19/2004 14:50'! loadDependencies self subclassResponsibility ! ! !MCVersionReader class methodsFor: 'System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:21'! fileReaderServicesForFile: fullName suffix: suffix self isAbstract ifTrue: [^ #()]. ^ ((suffix = self extension) or: [ suffix = '*' ]) ifTrue: [self services] ifFalse: [Array new: 0] ! ! !MCVersionReader class methodsFor: '*monticello-file services' stamp: 'nk 2/25/2005 11:12'! openVersionFromStream: stream (self versionFromStream: stream) open! ! !MCVersionReader class methodsFor: '*monticello-file services' stamp: 'nk 2/25/2005 11:17'! mergeVersionStream: stream (self versionFromStream: stream) merge! ! !MCVersionReader class methodsFor: 'reading' stamp: 'StephaneDucasse 2/2/2010 22:07'! file: fileName streamDo: aBlock ^ FileStream readOnlyFileNamed: fileName do: [:file | aBlock value: file]! ! !MCVersionReader class methodsFor: 'reading' stamp: 'bf 3/23/2005 01:20'! on: s fileName: f ^ self on: s! ! !MCVersionReader class methodsFor: '*monticello-file services' stamp: 'SeanDeNigris 6/18/2012 16:56'! loadVersionStream: stream fromDirectory: directory | version repository | repository := MCDirectoryRepository new directory: directory. version := self versionFromStream: stream. version workingCopy repositoryGroup addRepository: repository. version load. ! ! !MCVersionReader class methodsFor: 'reading' stamp: 'avi 1/21/2004 22:59'! versionInfoFromStream: aStream ^ (self on: aStream) info! ! !MCVersionReader class methodsFor: 'System-FileRegistry' stamp: 'CamilloBruni 5/4/2012 21:38'! loadVersionFile: fileName | version | version := self versionFromFile: fileName. version workingCopy repositoryGroup addRepository: (MCDirectoryRepository new directory: fileName asFileReference). version load. ! ! !MCVersionReader class methodsFor: 'System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:22'! initialize "MCVersionReader initialize" Smalltalk globals at: #MczInstaller ifPresent: [ :installer | FileServices unregisterFileReader: installer ]. self concreteSubclasses do: [ :aClass | "get rid of AnObsoleteMCMcReader and AnObsoleteMCMcvReader" FileServices registerFileReader: aClass ]. FileServices registeredFileReaderClasses select: [ :ea | ea isObsolete ] thenDo: [ :ea | FileServices unregisterFileReader: ea ]! ! !MCVersionReader class methodsFor: 'System-FileRegistry' stamp: 'avi 1/21/2004 22:55'! services ^ Array with: self serviceLoadVersion with: self serviceMergeVersion with: self serviceOpenVersion! ! !MCVersionReader class methodsFor: 'reading' stamp: 'avi 1/21/2004 22:58'! versionFromStream: aStream ^ (self on: aStream) version! ! !MCVersionReader class methodsFor: '*monticello-file services' stamp: 'tbn 8/11/2010 10:20'! serviceOpenVersion ^ (SimpleServiceEntry provider: self label: 'Open version' selector: #openVersionFromStream: description: 'Open a package version' buttonLabel: 'Open') argumentGetter: [ :fileList | fileList readOnlyStream ]! ! !MCVersionReader class methodsFor: 'System-FileRegistry' stamp: 'pavel.krivanek 10/24/2010 19:38'! unload FileServices unregisterFileReader: self ! ! !MCVersionReader class methodsFor: 'reading' stamp: 'cwp 7/31/2003 23:03'! versionFromFile: fileName ^ self file: fileName streamDo: [:stream | self versionFromStream: stream]! ! !MCVersionReader class methodsFor: 'System-FileRegistry' stamp: 'cwp 8/1/2003 14:46'! openVersionFile: fileName (self versionFromFile: fileName) open! ! !MCVersionReader class methodsFor: 'System-FileRegistry' stamp: 'cwp 8/1/2003 14:46'! mergeVersionFile: fileName (self versionFromFile: fileName) merge! ! !MCVersionReader class methodsFor: '*monticello-file services' stamp: 'tbn 8/11/2010 10:19'! serviceLoadVersion ^ (SimpleServiceEntry provider: self label: 'Load version' selector: #loadVersionStream:fromDirectory: description: 'Load a package version' buttonLabel: 'Load') argumentGetter: [ :fileList | { fileList readOnlyStream . fileList directory } ]! ! !MCVersionReader class methodsFor: '*monticello-file services' stamp: 'tbn 8/11/2010 10:19'! serviceMergeVersion ^ (SimpleServiceEntry provider: self label: 'Merge version' selector: #mergeVersionStream: description: 'Merge a package version into the image' buttonLabel: 'Merge') argumentGetter: [ :fileList | fileList readOnlyStream ]! ! !MCVersionSorter commentStamp: 'TorstenBergmann 2/6/2014 08:10'! Sort versions! !MCVersionSorter methodsFor: 'adding' stamp: 'avi 9/11/2004 10:49'! addVersionInfo: aVersionInfo roots add: aVersionInfo. self registerStepChildrenOf: aVersionInfo seen: Set new! ! !MCVersionSorter methodsFor: 'private' stamp: 'avi 9/11/2004 10:39'! processVersionInfo: aVersionInfo (self addToCurrentLayer: aVersionInfo) ifTrue: [self pushLayer. (self knownAncestorsOf: aVersionInfo) do: [:ea | self processVersionInfo: ea]. self popLayer] ! ! !MCVersionSorter methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! pushLayer depthIndex := depthIndex + 1. depthIndex > layers size ifTrue: [layers add: OrderedCollection new]. ! ! !MCVersionSorter methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! popLayer depthIndex := depthIndex - 1! ! !MCVersionSorter methodsFor: 'accessing' stamp: 'ab 8/17/2003 15:53'! layers ^ layers! ! !MCVersionSorter methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:04'! initialize super initialize. stepparents := Dictionary new. roots := OrderedCollection new.! ! !MCVersionSorter methodsFor: 'adding' stamp: 'avi 9/11/2004 14:19'! addAllAncestorsOf: aVersionInfo to: aSet (aSet includes: aVersionInfo) ifTrue: [^ self]. aSet add: aVersionInfo. (self knownAncestorsOf: aVersionInfo) do: [:ea | self addAllAncestorsOf: ea to: aSet]! ! !MCVersionSorter methodsFor: 'adding' stamp: 'avi 8/31/2003 21:30'! addAllVersionInfos: aCollection aCollection do: [:ea | self addVersionInfo: ea]! ! !MCVersionSorter methodsFor: 'adding' stamp: 'stephaneducasse 2/4/2006 20:47'! addToCurrentLayer: aVersionInfo | layer | layer := layers at: depthIndex. (layer includes: aVersionInfo) ifFalse: [depths at: aVersionInfo ifPresent: [:i | i < depthIndex ifTrue: [(layers at: i) remove: aVersionInfo] ifFalse: [^ false]]. layer add: aVersionInfo. depths at: aVersionInfo put: depthIndex. ^ true]. ^ false ! ! !MCVersionSorter methodsFor: 'accessing' stamp: 'avi 9/11/2004 14:37'! knownAncestorsOf: aVersionInfo ^ aVersionInfo ancestors, (self stepParentsOf: aVersionInfo) asArray! ! !MCVersionSorter methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! allAncestorsOf: aVersionInfo | all | all := Set new. self addAllAncestorsOf: aVersionInfo to: all. ^ all! ! !MCVersionSorter methodsFor: 'private' stamp: 'avi 9/11/2004 14:34'! registerStepChildrenOf: aVersionInfo seen: aSet (aSet includes: aVersionInfo) ifTrue: [^ self]. aSet add: aVersionInfo. aVersionInfo stepChildren do: [:ea | (self stepParentsOf: ea) add: aVersionInfo]. aVersionInfo ancestors do: [:ea | self registerStepChildrenOf: ea seen: aSet].! ! !MCVersionSorter methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! sortedVersionInfos layers := OrderedCollection with: OrderedCollection new. depthIndex := 1. depths := Dictionary new. roots do: [:ea | self processVersionInfo: ea]. ^ layers gather: [:ea | ea]! ! !MCVersionSorter methodsFor: 'accessing' stamp: 'avi 9/11/2004 10:40'! stepParentsOf: aVersionInfo ^ (stepparents at: aVersionInfo ifAbsentPut: [Set new])! ! !MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:50'! testAllMissing self assert: #allDependenciesDo: orders: #(a ((b (d e)) (c missing))) as: #(d e b)! ! !MCVersionTest methodsFor: 'building' stamp: 'cwp 11/7/2004 12:29'! dependencyFromTree: sexpr ^ MCMockDependency fromTree: sexpr! ! !MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:25'! testPostOrder self assert: #allDependenciesDo: orders: #(a ((b (d e)) c)) as: #(d e b c)! ! !MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:53'! testAllAvailablePostOrder self assert: #allAvailableDependenciesDo: orders: #(a ((b (d e)) c)) as: #(d e b c)! ! !MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:29'! testWithAllUnresolved self assert: #withAllDependenciesDo:ifUnresolved: orders: #(a ((b (d e)) (c missing))) as: #(d e b a) unresolved: #(c)! ! !MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:22'! testWithAll self assert: #withAllDependenciesDo: orders: #(a ((b (d e)) c)) as: #(d e b c a)! ! !MCVersionTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp visited := OrderedCollection new.! ! !MCVersionTest methodsFor: 'building' stamp: 'cwp 11/7/2004 12:40'! versionFromTree: sexpr ^ (self dependencyFromTree: sexpr) resolve! ! !MCVersionTest methodsFor: 'asserting' stamp: 'cwp 11/7/2004 14:32'! assert: aSelector orders: sexpr as: array | expected | expected := OrderedCollection new. version := self versionFromTree: sexpr. version perform: aSelector with: [:ea | expected add: ea info name]. self assert: expected asArray = array! ! !MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:47'! testAllUnresolved self assert: #allDependenciesDo:ifUnresolved: orders: #(a ((b (d e)) (c missing))) as: #(d e b) unresolved: #(c)! ! !MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 13:55'! testDependencyOrder self assert: #allDependenciesDo: orders: #(a (b c)) as: #(b c)! ! !MCVersionTest methodsFor: 'asserting' stamp: 'md 9/6/2005 18:41'! assert: aSelector orders: sexpr as: expected unresolved: unresolved | missing | missing := OrderedCollection new. version := self versionFromTree: sexpr. version perform: aSelector with: [:ea | visited add: ea info name] with: [:ea | missing add: ea name]. self assert: visited asArray = expected. self assert: missing asArray = unresolved.! ! !MCVersionTest methodsFor: 'tests' stamp: 'cwp 11/7/2004 14:56'! testWithAllMissing self assert: #withAllDependenciesDo: orders: #(a ((b (d e)) (c missing))) as: #(d e b a)! ! !MCWorkingAncestry commentStamp: ''! The interim record of ancestry for a working copy, gets merged version added to the ancestry, and is used to create the VersionInfo when the working copy becomes a version. ! !MCWorkingAncestry methodsFor: 'adding' stamp: 'stephaneducasse 2/4/2006 20:47'! addAncestor: aNode ancestors := (self ancestors reject: [:each | aNode hasAncestor: each]) copyWith: aNode! ! !MCWorkingAncestry methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:14'! name ^ ''! ! !MCWorkingAncestry methodsFor: 'adding' stamp: 'stephaneducasse 2/4/2006 20:47'! addStepChild: aVersionInfo stepChildren := stepChildren copyWith: aVersionInfo! ! !MCWorkingAncestry methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:14'! summary ^ 'Ancestors: ', self ancestorString! ! !MCWorkingAncestry methodsFor: 'accessing' stamp: 'MiguelCoba 7/25/2009 02:01'! infoWithName: nameString message: messageString ^ MCVersionInfo name: nameString id: UUID new message: messageString date: Date today time: Time now author: Author fullName ancestors: ancestors asArray stepChildren: self stepChildren asArray! ! !MCWorkingCopy commentStamp: 'StephaneDucasse 4/29/2011 20:44'! MCWorkingCopy represents one version of a package in memory. It provides support for ancestry access, required packages and the repositories in which the package is managed. Instance Variables: versionInfo ancestry counter repositoryGroup requiredPackages ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:13'! ancestry ^ ancestry! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'bp 11/21/2010 18:33'! description ^ self packageNameWithStar, ' (', (ancestry ancestorStringWithout: self packageName), ')'! ! !MCWorkingCopy methodsFor: 'repositories' stamp: 'stephaneducasse 2/4/2006 20:47'! repositoryGroup ^ repositoryGroup ifNil: [repositoryGroup := MCRepositoryGroup new]! ! !MCWorkingCopy methodsFor: 'private' stamp: 'CamilloBruni 4/24/2012 15:22'! uniqueVersionName |versionName| counter := nil. 'Creating unique version number' displayProgressFrom: 0 to: 1 during: [ :arg| [versionName := self nextVersionName. self repositoryGroup includesVersionNamed: versionName] whileTrue ]. ^ versionName! ! !MCWorkingCopy methodsFor: 'repositories' stamp: 'stephaneducasse 2/4/2006 20:47'! repositoryGroup: aRepositoryGroup repositoryGroup := aRepositoryGroup! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'stephane.ducasse 2/6/2009 18:31'! removeRequiredPackage: aPackage requiredPackages remove: aPackage ifAbsent: [] ! ! !MCWorkingCopy methodsFor: 'private' stamp: 'bf 9/8/2005 10:58'! possiblyNewerVersions ^Array streamContents: [:strm | self repositoryGroup repositories do: [:repo | strm nextPutAll: (self possiblyNewerVersionsIn: repo)]]! ! !MCWorkingCopy methodsFor: '*Komitter' stamp: 'BenjaminVanRyseghem 11/22/2013 16:21'! remotes ^ self repositoryGroup remotes! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'SeanDeNigris 7/17/2012 15:50'! theCachedRepository ^ MCCacheRepository uniqueInstance.! ! !MCWorkingCopy methodsFor: '*Komitter' stamp: 'BenjaminVanRyseghem 11/27/2013 16:58'! silentlyNewVersionWithName: nameString message: messageString in: aRepository | info deps | info := ancestry infoWithName: nameString message: messageString. ancestry := MCWorkingAncestry new addAncestor: info. self modified: true. deps := self collectDependenciesWithMessage: messageString in: aRepository. (self repositoryGroup includes: aRepository) ifFalse: [ self repositoryGroup addRepository: aRepository ]. ^ MCVersion silentlyPackage: package info: info snapshot: package snapshot dependencies: deps! ! !MCWorkingCopy methodsFor: '*Komitter' stamp: 'BenjaminVanRyseghem 12/6/2013 21:38'! collectSliceDependenciesWithMessage: messageString in: aRepository ^ self requiredPackages collect: [:aPackage | MCVersionDependency package: aPackage info: aPackage version info ] ! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'CamilloBruni 3/2/2012 14:42'! loadRemoteDependenciesIn: aRepository "load the remote dependencies of all packages in parallel" | dependencies | dependencies := self requiredPackagesParallelCollect: [ :aPackage| (aPackage workingCopy closestAncestorSnapshotIn: aRepository) definitions.] withMessage: 'Loading remote dependencies...'. ^ dependencies inject: OrderedCollection new into: [ :all :deps| all addAll: deps ]! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! versionInfo: aVersionInfo ancestry := MCWorkingAncestry new addAncestor: aVersionInfo! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'CamilloBruni 1/19/2012 18:35'! changesRelativeToRepository: aRepository ^ self completeSnapshot patchRelativeToBase: (self closestAncestorSnapshotIn: aRepository).! ! !MCWorkingCopy methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! initialize super initialize. ancestry := MCWorkingAncestry new! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'SeanDeNigris 6/21/2012 09:07'! requiredPackagesParallelCollect: aBlock withMessage: aMessage "load the remote dependencies of all packages in parallel" | packages progress results maxConcurrentConnections connectionThrottle addSemaphore | results := OrderedCollection new. addSemaphore := Semaphore forMutualExclusion. connectionThrottle := Semaphore new. progress := 0. maxConcurrentConnections := 5. maxConcurrentConnections timesRepeat: [ connectionThrottle signal ]. "make room for maxConcurrentConnections" packages := self requiredPackages. aMessage displayProgressFrom: 0 to: packages size during: [ :bar| packages do: [ :aPackage| connectionThrottle wait. "no more than maxConcurrentConnections" [|result| [ result := aBlock value: aPackage. addSemaphore critical: [ "update the non-threadsafe collection" results add: result. bar current: (progress := progress + 1)] ] ensure: [ connectionThrottle signal. "free a connection" ]. ] fork ]]. maxConcurrentConnections timesRepeat: [ connectionThrottle wait ]. "wait for the last connection to finish" ^ results! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'EstebanLorenzano 9/8/2013 11:51'! newVersionWithMessage: aMessageString in: aRepository ^ self newVersionWithName: (self uniqueVersionNameIn: aRepository) message: aMessageString in: aRepository. "^ (self requestVersionNameAndMessageWithSuggestion: self uniqueVersionName) ifNotNil: [:pair | self newVersionWithName: pair first message: aMessageString]. "! ! !MCWorkingCopy methodsFor: 'printing' stamp: 'sd 3/15/2008 14:13'! printOn: aStream super printOn: aStream. package name ifNotNil: [ aStream nextPutAll: '(' , package name asString, ')'].! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'abc 11/8/2013 17:11'! newVersionWithName: nameString message: messageString in: aRepository | info deps | info := ancestry infoWithName: nameString message: messageString. ancestry := MCWorkingAncestry new addAncestor: info. self modified: true; modified: false. deps := self collectDependenciesWithMessage: messageString in: aRepository. (self repositoryGroup includes: aRepository) ifFalse: [ self repositoryGroup addRepository: aRepository ]. ^ MCVersion package: package info: info snapshot: package snapshot dependencies: deps! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/8/2013 11:01'! currentVersionInfo ^ (self needsSaving or: [ancestry ancestors isEmpty]) ifTrue: [ (self newVersionIn: self repositoryGroup) info] ifFalse: [ancestry ancestors first]! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 20:02'! needsSaving ^ self modified or: [self requiredPackages anySatisfy: [:ea | ea workingCopy needsSaving]]! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'EstebanLorenzano 4/15/2014 14:11'! unload "Unloads mcpackage, rpackage, classes and method extensions from this working copy" MCPackageLoader unloadPackage: self package. package packageSet unregister. self unregister. ! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/8/2013 10:39'! currentVersionInfoWithMessage: aMessageString in: aRepository ^ (self needsSaving or: [ancestry ancestors isEmpty]) ifTrue: [ (self newVersionWithMessage: aMessageString in: aRepository) info ] ifFalse: [ancestry ancestors first]! ! !MCWorkingCopy methodsFor: 'private' stamp: 'StephaneDucasse 8/14/2013 14:57'! findSnapshotWithVersionInfo: aVersionInfo "when an ancestor inside the ancestor chain is not found, does not pass nil instead. With this change we can now browse history and delta between them without having to have the complete history" "instead of asking for the user to add a new repository, or copy the the missing package we simply return an empty Snapshot by returning nil" ^ aVersionInfo ifNil: [MCSnapshot empty] ifNotNil: [(self repositoryGroup versionWithInfo: aVersionInfo ifNone: [nil]) ifNil: [MCSnapshot empty] ifNotNil: [:aVersion | aVersion snapshot]]! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'avi 2/13/2004 01:07'! notifyNoCommonAncestorWith: aVersion self notify: 'Could not find a common ancestor between (', aVersion info name, ') and (', ancestry ancestorString, '). Proceeding with this merge may cause spurious conflicts.'! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'! clearRequiredPackages requiredPackages := nil! ! !MCWorkingCopy methodsFor: 'private' stamp: 'bf 9/8/2005 10:58'! possiblyNewerVersionsIn: aRepository ^aRepository possiblyNewerVersionsOfAnyOf: self ancestors! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'CamilloBruni 1/19/2012 18:34'! completeSnapshot "return a complete snapshot of the loaded sources in this working copy. unlike snapshot this includes also the snapshots of all packages" | definitions | definitions := self snapshot definitions asOrderedCollection. self requiredPackages do: [ :aPackage| definitions addAll: aPackage workingCopy completeSnapshot definitions ] displayingProgress: [ :item| 'Loading dependencies from: ', item name ]. ^ MCSnapshot fromDefinitions: definitions! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'CamilloBruni 3/2/2012 13:32'! closestAncestorSnapshotIn: aRepository "Returns a complete Snapshot including all required packages by recurisveliy walking all required package and trying to find the closes ancestor in the given repository" | definitions ancestorVersion| ancestorVersion := aRepository closestAncestorVersionFor: ancestry ifNone: []. definitions := ancestorVersion ifNil: [ OrderedCollection new ] ifNotNil: [ ancestorVersion snapshot definitions ]. definitions addAll: (self loadRemoteDependenciesIn: aRepository). ^ MCSnapshot fromDefinitions: definitions! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'avi 2/13/2004 01:07'! adopt: aVersion ancestry addAncestor: aVersion info. self changed.! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:07'! ancestors ^ ancestry ancestors! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'CamilloBruni 9/30/2011 16:25'! snapshot ^ self package snapshot! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'EstebanLorenzano 9/8/2013 10:39'! collectDependenciesWithMessage: messageString in: aRepository ^ self requiredPackages collect: [:aPackage | MCVersionDependency package: aPackage info: (aPackage workingCopy currentVersionInfoWithMessage: messageString in: aRepository) ] ! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'EstebanLorenzano 9/8/2013 10:37'! newVersionIn: aRepository ^ (self requestVersionNameAndMessageWithSuggestion: (self uniqueVersionNameIn: aRepository)) ifNotNil: [:pair | self newVersionWithName: pair first trimBoth message: pair last in: aRepository ]. ! ! !MCWorkingCopy methodsFor: 'private' stamp: 'EstebanLorenzano 9/8/2013 10:36'! uniqueVersionNameIn: aRepository |versionName| counter := nil. 'Creating unique version number' displayProgressFrom: 0 to: 1 during: [ :arg| [versionName := self nextVersionName. aRepository includesVersionNamed: versionName] whileTrue ]. ^ versionName! ! !MCWorkingCopy methodsFor: 'private' stamp: 'avi 2/4/2004 14:11'! versionSeparator ^ $_! ! !MCWorkingCopy methodsFor: '*Komitter' stamp: 'BenjaminVanRyseghem 11/24/2013 20:30'! baseSnapshot ^ self ancestors ifEmpty: [ nil ] ifNotEmpty: [ :ancestors | self findSnapshotWithVersionInfo: ancestors first ]! ! !MCWorkingCopy methodsFor: 'private' stamp: 'ab 8/24/2003 20:38'! requestVersionNameAndMessageWithSuggestion: aString ^ (MCVersionNameAndMessageRequest new suggestedName: aString) signal! ! !MCWorkingCopy methodsFor: 'private' stamp: 'MiguelCoba 7/25/2009 02:01'! nextVersionName | branch oldName base author | branch := ''. ancestry ancestors isEmpty ifTrue: [counter ifNil: [counter := 0]. base := package name] ifFalse: [oldName := ancestry ancestors first name. oldName last isDigit ifFalse: [base := oldName] ifTrue: [ base := oldName copyUpToLast: $-. branch := ((oldName copyAfterLast: $-) copyUpToLast: $.) copyAfter: $. ]. counter ifNil: [ counter := (ancestry ancestors collect: [:each | each name last isDigit ifFalse: [0] ifTrue: [(each name copyAfterLast: $.) extractNumber]]) max]]. branch isEmpty ifFalse: [branch := '.',branch]. counter := counter + 1. author := Author fullName collect: [ :each | each isAlphaNumeric ifTrue: [ each ] ifFalse: [ $_ ] ]. ^ base , '-' , author , branch , '.' , counter asString! ! !MCWorkingCopy methodsFor: '*Komitter' stamp: 'BenjaminVanRyseghem 12/6/2013 21:25'! silentUniqueVersionNameIn: aRepository |versionName| counter := nil. [ versionName := self nextVersionName. aRepository includesVersionNamed: versionName ] whileTrue. ^ versionName! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'CamilloBruni 9/15/2013 17:51'! merge: targetVersion | ancestorInfo merger ancestorSnapshot packageSnapshot | targetVersion dependencies do: [:ea | ea resolve merge]. ancestorInfo := targetVersion info commonAncestorWith: ancestry. ancestorInfo = targetVersion info ifTrue: [^ MCNoChangesException signal]. packageSnapshot := package snapshot. ancestorSnapshot := ancestorInfo ifNotNil: [(self findSnapshotWithVersionInfo: ancestorInfo)] ifNil: [self notifyNoCommonAncestorWith: targetVersion. MCSnapshot empty]. (ancestry ancestors size = 1 and: [ancestry ancestors first = ancestorInfo and: [(packageSnapshot patchRelativeToBase: ancestorSnapshot) isEmpty]]) ifTrue: [^ targetVersion load]. merger := MCThreeWayMerger base: packageSnapshot target: targetVersion snapshot ancestor: ancestorSnapshot. ((MCMergeResolutionRequest new merger: merger) signal: 'Merging ', targetVersion info name) = true ifTrue:[ merger loadWithNameLike: targetVersion info name. ancestry addAncestor: targetVersion info ]. self changed! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 1/20/2004 16:04'! requirePackage: aPackage (self requiredPackages includes: aPackage) ifFalse: [requiredPackages add: aPackage]! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'marcus.denker 11/10/2008 10:04'! backportChangesTo: aVersionInfo | baseVersion fullPatch currentVersionInfo currentVersion newSnapshot newAncestry | currentVersionInfo := self currentVersionInfo. baseVersion := self repositoryGroup versionWithInfo: aVersionInfo. currentVersion := self repositoryGroup versionWithInfo: currentVersionInfo. fullPatch := currentVersion snapshot patchRelativeToBase: baseVersion snapshot. (MCChangeSelectionRequest new patch: fullPatch; label: 'Changes to Backport'; signal ) ifNotNil: [:partialPatch | newSnapshot := MCPatcher apply: partialPatch to: baseVersion snapshot. newAncestry := MCWorkingAncestry new addAncestor: aVersionInfo; addStepChild: currentVersionInfo; yourself. MCPackageLoader updatePackage: package withSnapshot: newSnapshot. ancestry := newAncestry. self modified: false; modified: true]! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'! loaded: aVersion ancestry := MCWorkingAncestry new addAncestor: aVersion info. requiredPackages := OrderedCollection withAll: (aVersion dependencies collect: [:ea | ea package]). self modified: false. self changed! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! requiredPackages ^ requiredPackages ifNil: [requiredPackages := OrderedCollection new]! ! !MCWorkingCopy methodsFor: '*Komitter' stamp: 'BenjaminVanRyseghem 12/6/2013 21:26'! silentlyNewSliceVersionWithName: nameString message: messageString in: aRepository | info deps | info := ancestry infoWithName: nameString message: messageString. ancestry := MCWorkingAncestry new addAncestor: info. self modified: true; modified: false. deps := self collectSliceDependenciesWithMessage: messageString in: aRepository. (self repositoryGroup includes: aRepository) ifFalse: [ self repositoryGroup addRepository: aRepository ]. ^ MCVersion silentlyPackage: package info: info snapshot: package snapshot dependencies: deps! ! !MCWorkingCopy methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! metacelloPackageNameWithBranch "answer array with package name and package name with branch name" ancestry ancestors isEmpty ifTrue: [ ^ {(package name). (package name)} ]. ^ (GoferVersionReference name: self ancestors first name) metacelloPackageNameWithBranch! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'CamilloBruni 1/19/2012 16:12'! merged: aVersion ancestry addAncestor: aVersion info. aVersion dependencies do: [:ea | self requirePackage: ea package]. self changed! ! !MCWorkingCopy class methodsFor: 'private' stamp: 'StephaneDucasse 8/17/2012 15:58'! infoFromDictionary: aDictionary cache: cache | id | id := (aDictionary at: #id) asString. ^ cache at: id ifAbsentPut: [MCVersionInfo name: (aDictionary at: #name ifAbsent: ['']) id: (UUID fromString: id) message: (aDictionary at: #message ifAbsent: ['']) date: ([Date fromString: (aDictionary at: #date)] ifError: [nil]) time: ([Time fromString: (aDictionary at: #time)] ifError: [nil]) author: (aDictionary at: #author ifAbsent: ['']) ancestors: (self ancestorsFromArray: (aDictionary at: #ancestors ifAbsent: []) cache: cache) stepChildren: (self ancestorsFromArray: (aDictionary at: #stepChildren ifAbsent: []) cache: cache)]! ! !MCWorkingCopy class methodsFor: 'private' stamp: 'avi 9/13/2004 18:00'! adoptVersionInfoFrom: anInstaller |viCache| viCache := Dictionary new. anInstaller versionInfo keysAndValuesDo: [:packageName :info | (self forPackage: (MCPackage named: packageName)) versionInfo: (self infoFromDictionary: info cache: viCache)]. [anInstaller clearVersionInfo] on: Error do: ["backwards compat"].! ! !MCWorkingCopy class methodsFor: 'initialize' stamp: 'CamilleTeruel 7/30/2012 14:09'! initialize "self initialize" registry ifNotNil: [ registry rehash ]. self registerForNotifications.! ! !MCWorkingCopy class methodsFor: 'querying' stamp: 'EstebanLorenzano 4/14/2014 16:04'! hasPackageNamed: aName " self hasPackageNamed: 'ConfigurationOfFuel' " ^ MCWorkingCopy allManagers detect: [ :each | each packageName = aName ] ifNone: [ false ].! ! !MCWorkingCopy class methodsFor: 'event registration' stamp: 'MarianoMartinezPeck 9/5/2012 15:05'! registerForNotifications "self registerForNotifications" MCPackageManager announcer: nil. SystemAnnouncer uniqueInstance unsubscribe: self. self registerInterestOnSystemChangesOnAnnouncer: SystemAnnouncer uniqueInstance.! ! !MCWorkingCopy class methodsFor: 'private' stamp: 'avi 2/17/2004 01:23'! ancestorsFromArray: anArray cache: aDictionary ^ anArray ifNotNil: [anArray collect: [:dict | self infoFromDictionary: dict cache: aDictionary]]! ! !MCWorkingCopyBrowser commentStamp: 'TorstenBergmann 2/20/2014 15:53'! Browser for working copies! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'CamilloBruni 8/3/2011 14:34'! repositoryMaxSearchSize ^self class repositoryMaxSearchSize! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'StephaneDucasse 2/11/2012 11:10'! saveRepositories FileStream forceNewFileNamed: 'MCRepositories.st' do: [:f | MCRepositoryGroup default repositoriesDo: [:r | r asCreationTemplate ifNotNil: [:template | f nextPutAll: 'MCRepositoryGroup default addRepository: (', template , ')!!'; cr]]]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'c 8/10/2010 22:58'! workingCopyListChanged self changed: #workingCopyList. self changed: #workingCopyTree. self changed: #workingCopyTreePath. self changedButtons. ! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'GuillermoPolito 5/3/2013 13:31'! repository ^ repository! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephaneDucasse 6/2/2012 20:35'! unsortedWorkingCopies ^ self allManagers ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 22:05'! workingCopySelection ^ self workingCopies indexOf: workingCopy! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! revertPackage self pickAncestorVersionInfo ifNotNil: [:info | (self repositoryGroup versionWithInfo: info ifNone: [^self inform: 'No repository found for ', info name] ) load]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'avi 9/11/2004 15:32'! inspectWorkingCopy workingCopy ifNotNil: [workingCopy inspect]! ! !MCWorkingCopyBrowser methodsFor: 'initialization' stamp: 'StephanEggermont 1/2/2014 15:37'! initialize super initialize. order := self class order. self registerToAnnouncer. workingCopyPattern := ''. repositoryPattern := ''. showOnlyRepositoriesFromWorkingCopy := true ! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'AlexandreBergel 11/11/2010 16:55'! hasAnyBaseline ^ self baseLines notEmpty! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'AndrewBlack 9/8/2009 09:29'! removeRequiredPackage | allRequiredPackages | workingCopy ifNil: [^ self]. allRequiredPackages := workingCopy requiredPackages. allRequiredPackages ifEmpty: [UIManager default inform: 'This package has no requirements'. ^ self]. (self pickWorkingCopySatisfying: [:wc | allRequiredPackages includes: wc package]) ifNotNil: [:required | workingCopy removeRequiredPackage: required package. self workingCopyListChanged]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ar 8/6/2009 18:25'! newRepository | types index | types := MCRepository allConcreteSubclasses asArray. index := UIManager default chooseFrom: (types collect: [:ea | ea description]) title: 'Repository type:'. ^ index = 0 ifFalse: [(types at: index) morphicConfigure]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'GuillermoPolito 5/29/2011 14:46'! editLoadScripts | menu | self hasWorkingCopy ifFalse: [^self]. menu := UIManager default newMenuIn: self for: self. menu add: 'edit preamble' selector: #editScript: argument: #preamble. menu add: 'edit postscript' selector: #editScript: argument: #postscript. menu add: 'edit preambleOfRemoval' selector: #editScript: argument: #preambleOfRemoval. menu add: 'edit postscriptOfRemoval' selector: #editScript: argument: #postscriptOfRemoval. menu popUpInWorld.! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'BenComan 2/18/2014 20:52'! addSlice (MCSliceMaker openFor: self window) ifNotNil: [:sliceInfo | workingCopy := sliceInfo makeSlice. workingCopy ifNotNil: [ workingCopy repositoryGroup addRepository: ScriptLoader new repository; addRepository: ScriptLoader new inboxRepository. workingCopyWrapper := MCDependentsWrapper with: workingCopy model: self. self repositorySelection: 0.]]. self workingCopyListChanged; changed: #workingCopySelection; repositoryListChanged. self changedButtons. ! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'avi 2/13/2004 01:13'! viewHistory workingCopy ifNotNil: [(MCWorkingHistoryBrowser new ancestry: workingCopy ancestry; package: workingCopy package) label: 'Version History: ', workingCopy packageName; show]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'BenjaminVanRyseghem 9/8/2011 14:07'! workingCopyListMorph "this method is not sent anymore" ^ (PluggableMultiColumnListMorph on: self list: #workingCopyList selected: #workingCopySelection changeSelected: #workingCopySelection: menu: #workingCopyListMenu:) gapSize: 40; yourself! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'avi 9/14/2004 14:57'! canBackport ^ self hasWorkingCopy and: [workingCopy needsSaving not]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'tbn 7/6/2010 17:07'! orderSpecs ^ { 'Sort alphabetically' -> [ :a :b | a package name <= b package name ]. 'Sort dirty first' -> [ :a :b | a needsSaving = b needsSaving ifTrue: [ a package name <= b package name ] ifFalse: [ a needsSaving ] ]. 'Sort dirty last' -> [ :a :b | a needsSaving = b needsSaving ifTrue: [ a package name <= b package name ] ifFalse: [ b needsSaving ] ]. 'Only dirty' -> [ :a :b | a package name <= b package name ] }! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 02:22'! repositorySelection ^ self repositories indexOf: self repository! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'EstebanLorenzano 9/12/2012 13:36'! recompilePackage workingCopy package packageSet methods do: [:ea | ea actualClass recompile: ea selector] displayingProgress: 'Recompiling...'! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 10/14/2008 14:24'! workingCopyTreeMenu: aMenu ^ self workingCopyListMenu: aMenu! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'BenjaminVanRyseghem 12/5/2013 16:21'! workingCopyTree | workingCopies | workingCopies := self workingCopies. "filter the working copy list if there is a serach string" workingCopyPattern ifNotEmpty: [ workingCopies := workingCopies select: [ :each| each package name asLowercase includesSubstring: workingCopyPattern ]]. ^ workingCopies collect: [:each| MCDependentsWrapper with: each model: self].! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 4/10/2013 11:14'! saveVersion self canSave ifFalse: [ ^ self ]. "fork the whole version creation " [ self basicSaveVersionIn: self repository ] fork! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ar 2/14/2004 02:46'! unloadPackage workingCopy unload. self workingCopySelection: 0. self workingCopyListChanged.! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'AlexandreBergel 10/27/2010 23:17'! baseLines | existingBaselines | existingBaselines := self configurationClass methods select: [:cm | cm selector beginsWith: 'baseline']. existingBaselines := (existingBaselines collect: [:m | m pragmas first argumentAt: 1]) asSortedCollection. ^ existingBaselines! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 8/3/2011 14:51'! removeRepository self repository ifNotNil: [:repos | self repositoryGroup removeRepository: repos. self repositorySelection: (1 min: self repositories size)]. self repositoryListChanged. self changedButtons. ! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'DaleHenrichs 11/5/2010 14:06'! createVersionForBlessing: blessingSelector "blessingSelector = #release or #development" | existingVersions msg initialAnswer newVersionNumber selectorName stream dependentPackages mcWorkingCopy | existingVersions := self configurationClass methods select: [:cm | cm selector beginsWith: 'version']. existingVersions := (existingVersions collect: [:m | m pragmas first argumentAt: 1]) asSortedCollection. msg := ''. existingVersions size > 4 ifTrue: [ msg := 'Last 4 versions: ', (existingVersions copyFrom: (existingVersions size - 4) to: existingVersions size) asArray printString, String cr ]. existingVersions size > 0 ifTrue: [ initialAnswer := existingVersions last, '.1' ] ifFalse: [ initialAnswer := '1.0' ]. newVersionNumber := UIManager default request: msg initialAnswer: initialAnswer. newVersionNumber ifNil: [ ^ self ]. selectorName := newVersionNumber copyWithoutAll: '.-'. stream := WriteStream on: String new. stream nextPutAll: 'version'. stream nextPutAll: selectorName. stream nextPutAll: ': spec spec for: #common do: [ spec blessing: ',blessingSelector printString,'. '. self dependentPackages do: [:pName | stream nextPutAll: ' spec package: ''', pName, ''' with: '''. mcWorkingCopy := (MCPackage named: pName) workingCopy. mcWorkingCopy needsSaving ifTrue: [ self inform: 'The configuration you want to save depends on the package ', pName, '. You first need to save this package in order to create the version'. ^ self ]. stream nextPutAll: (mcWorkingCopy ancestry ancestors first name). stream nextPutAll: '''.', String cr ]. stream nextPutAll: ' ].'. self configurationClass compile: stream contents classified: 'versions'. ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 6/21/2005 15:50'! changedButtons self changed: #hasWorkingCopy. self changed: #canSave. self changed: #canBackport. self changed: #hasRepository. ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 10/14/2008 14:25'! order: anInteger self class order: (order := anInteger). self changed: #workingCopyList; changed: #workingCopyTree! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:38'! workingCopySelectionWrapper ^workingCopyWrapper! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'DanielAviv 1/29/2013 16:43'! viewPastComments "Visualize past comments on a package." workingCopy ifNotNil: [(UIManager default edit: (String streamContents: [:s| "Ignore the initial MCWorkingAncestry instance." workingCopy ancestry topologicalAncestors allButFirst do: [:versionInfo| s nextPutAll: versionInfo summary] separatedBy: [s cr; cr"; next: 32 put: $-; cr; cr"]]) label: 'Version History: ', workingCopy packageName) ]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'CamilloBruni 8/3/2011 14:43'! workingCopySearchMaxSize ^self class workingCopySearchMaxSize! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'CamilloBruni 8/3/2011 14:51'! workingCopy: wc workingCopy := wc. self changed: #workingCopySelection; repositoryListChanged. self changedButtons. ! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'AlexandreBergel 10/27/2010 22:48'! browseConfiguration self configurationClass browse! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'CamilloBruni 8/3/2011 14:40'! repositorySearchMaxSize ^self class repositorySearchMaxSize! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'DanielUber 6/9/2012 09:39'! repositoryList |repositories| repositories := self repositories. ^ repositories collect: [:ea | ea description]! ! !MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: 'StephaneDucasse 5/19/2011 14:51'! unloadPackageMenuSpec ^ #(#('Unload package' #unloadPackage) #('Delete working copy' #deleteWorkingCopy))! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'nk 3/9/2004 14:39'! pickWorkingCopy ^self pickWorkingCopySatisfying: [ :c | true ]! ! !MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: 'StephaneDucasse 5/19/2011 14:33'! configurationMenuSpec ^ #(#('Add new baseline' #addMetacelloBaseline) #('Browse configuration' #browseConfiguration) #('Create release version' #createReleaseVersion) #('Create development version' #createDevelopmentVersion)) ! ! !MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: 'StephaneDucasse 5/19/2011 14:44'! revertPackageMenuSpec ^ #(#('Revert package...' #revertPackage) #('Recompile package' #recompilePackage) #('Backport package...' #backportChanges) #('Inspect package' #inspectWorkingCopy)) ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephaneDucasse 5/19/2011 14:52'! workingCopyListMenu: aMenu workingCopy ifNil: [ ^ aMenu ]. (workingCopy package name beginsWith: 'ConfigurationOf') ifTrue: [ self fillMenu: aMenu fromSpecs: self configurationMenuSpec. aMenu addLine ]. self fillMenu: aMenu fromSpecs: self historyMenuSpec. aMenu addLine. self fillMenu: aMenu fromSpecs: self packageMenuSpec. aMenu addLine. self fillMenu: aMenu fromSpecs: self revertPackageMenuSpec. aMenu addLine. self fillMenu: aMenu fromSpecs: self unloadPackageMenuSpec. aMenu addLine. 1 to: self orderSpecs size do: [ :index | aMenu addUpdating: #orderString: target: self selector: #order: argumentList: {index} ]. ^ aMenu ! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'Alexandre Bergel 11/4/2010 20:04'! dependentPackages "Return the list of dependent packages for the last baseline" "This method must be rewritten. It is a shame..." | lastBaseLineName lastBaseLineMethod versionConstructor versionSpec possiblePackageNames packageInfos packageNames | lastBaseLineName := self lastBaseLine. packageNames := OrderedCollection new. (self configurationClass project version: lastBaseLineName) record loadDirective packageDirectivesDo: [:directive | packageNames add: directive file ]. ^ packageNames collect: [:p | (p includes: $.) ifTrue: [ (p includes: $-) ifTrue: [ (p copyUpToLast: $-) ] ifFalse: [ (p copyUpTo: $.) ] ] ifFalse: [ p ] ] " lastBaseLineMethod := (self configurationClass methods select: [:cm | cm selector beginsWith: 'baseline']) select: [:cm | cm pragmas first arguments first = lastBaseLineName]. lastBaseLineMethod := lastBaseLineMethod first. " "This does not work!! No idea why!!" " versionConstructor := (Smalltalk at: #MetacelloVersionConstructor) new. self configurationClass new perform: lastBaseLineMethod selector with: versionConstructor. versionSpec := (Smalltalk at: #MetacelloVersionSpec) new. versionConstructor root: versionSpec " "This is probably the ugliest piece of code I ever wrote. There is really nothing to be proud of." " possiblePackageNames := ((lastBaseLineMethod literals select: [ :l | l class == ByteString ]) reject: [:l | l beginsWith: 'http']). packageInfos := PackageInfo allPackages select: [ :pi | possiblePackageNames includes: pi packageName ]. " "packageInfos now contains the package that the lastest baseline depends on" "^ packageInfos collect: #packageName" ! ! !MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: 'StephanEggermont 1/2/2014 15:43'! widgetSpecs | searchBarOffset | searchBarOffset := 30 + StandardFonts defaultFont height + 10. ^ { "send fractions offsets" {{#buttonRow}. {0. 0. 1. 0}. {0. 0. 0. 30.}}. {{#workingCopySearchField}. {0. 0. 0.5. 0.}. {0. 30. 0. searchBarOffset.}}. {{#treeMorph:. #workingCopy}. {0. 0. 0.5. 1}. {0. searchBarOffset+3. 0. 0.}}. {{#repositorySearchField}. {0.5. 0. 0.85. 0.}. {0. 30. 0. searchBarOffset.}}. {{#showOnlyRepositoriesFromWorkingCopyField}. { 0.85. 0. 1. 0.}. { 0. 30. 0. searchBarOffset .}}. {{#listMorph:. #repository}. {0.5. 0. 1. 1}. {0. searchBarOffset+3. 0. 0.}}. }.! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'AlexandreBergel 11/11/2010 16:54'! createReleaseVersion self hasAnyBaseline ifFalse: [ UIManager default inform: 'Please, define a baseline first'. ^ self ]. ^ self createVersionForBlessing: #release! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'EstebanLorenzano 9/12/2012 13:36'! editScript: scriptSymbol | script | script := workingCopy packageSet perform: scriptSymbol. script openLabel: scriptSymbol asString, ' of the Package ', workingCopy package name.! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephaneDucasse 5/19/2011 14:55'! enterIssueNumber | issue | issue := UIManager default request: 'Please give the issue number' initialAnswer: '00000'. issue isEmptyOrNil ifFalse: [ issue isAllDigits ifFalse: [ UIManager default inform: 'You must give us a number'. issue := self enterIssueNumber]]. ^ issue ! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 4/11/2013 17:28'! storeVersion: newVersion in: aRepository self retryOnCredentialRequest: [ aRepository storeVersion: newVersion ]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephaneDucasse 5/19/2011 14:52'! workingCopySelection: aNumber self workingCopy: (aNumber = 0 ifTrue: [nil] ifFalse: [self workingCopies at: aNumber]). ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephanEggermont 1/2/2014 15:33'! repositoryListMenu: aMenu self repository ifNil: [^ aMenu]. self fillMenu: aMenu fromSpecs: self repositoryMenuSpec. aMenu add: (self repository alwaysStoreDiffs ifTrue: ['Store full versions'] ifFalse: ['Store diffs']) target: self selector: #toggleDiffs. ^ aMenu ! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! repository: aRepository repository := aRepository. workingCopy ifNotNil: [self defaults at: workingCopy put: aRepository]! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'ClementBera 7/26/2013 16:50'! addMetacelloBaseline | baselineNumber existingBaselines msg selectorName addedPackages package stream packagePattern | "0 -- must have a repository selected" repository ifNil: [ UIManager default inform: 'Please select a repository and try again'. ^self ]. "1 -- Selecting baseline name" existingBaselines := self baseLines. existingBaselines size > 0 ifTrue: [msg := 'Current baselines:', String cr, (existingBaselines inject: '' into: [:sum :el | sum, el, String cr]), 'Enter a new baseline number'] ifFalse: [msg := 'Enter a new baseline number ("-baseline" will be automatically added)']. baselineNumber := UIManager default request: msg initialAnswer: '1.0'. baselineNumber ifNil: [ ^ self ]. "2 -- add package names" addedPackages := OrderedCollection new. packagePattern := UIManager default request: 'Please enter a pattern to filter package names' initialAnswer: '*'. [ | packageNames workingCopies | packageNames := OrderedCollection new. workingCopies := OrderedCollection new. self workingCopies do: [:pkg | ((packagePattern match: pkg package name) and: [ (addedPackages includes: pkg package name) not ]) ifTrue: [ packageNames add: pkg package name. workingCopies add: pkg ]]. package := UIManager default chooseFrom: packageNames values: workingCopies title: 'Add dependent package (cancel to stop)'. package ifNotNil: [addedPackages add: package package name ] ] doWhileTrue: [ package notNil ]. "3 -- Creating baseline" selectorName := baselineNumber copyWithoutAll: '.-'. stream := WriteStream on: String new. stream nextPutAll: 'baseline'. stream nextPutAll: selectorName. stream nextPutAll: ': spec spec for: #common do: [ spec blessing: #baseline. spec repository: '''. stream nextPutAll: repository description. stream nextPutAll: '''. "spec package: ''Example-Core''; package: ''Example-Tests'' with: [ spec requires: ''Example-Core'' ]" '. addedPackages do: [:pName | stream nextPutAll: ' spec package: ''', pName, '''.', String cr]. stream nextPutAll: ' ].'. self configurationClass compile: stream contents classified: 'baselines'. ! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 8/3/2011 14:50'! addMetacelloConfiguration |name| name := UIManager default request: 'Name of the new Metacello configuration (e.g., ConfigurationOfYourSoftware)' translated initialAnswer: 'ConfigurationOf'. name isEmptyOrNil ifFalse: [ "Check if the class does not exist" (Smalltalk globals includesKey: name asSymbol) ifTrue: [ self error: 'Class already exist']. "Check if metacello is loaded" (Smalltalk globals includesKey: #MetacelloConfigTemplate) ifFalse: [Gofer new squeaksource: 'MetacelloRepository'; package: 'ConfigurationOfMetacello'; load. (Smalltalk at: #ConfigurationOfMetacello) perform: #loadLatestVersion]. "Create the configuration" ((Smalltalk globals at: #MetacelloConfigTemplate) duplicateClassWithNewName: name asSymbol) category: name asString. "We create the package that has the same name" PackageInfo registerPackageName: name. "Select the package" workingCopy := MCWorkingCopy forPackage: (MCPackage new name: name). repository ifNotNil: [ workingCopy repositoryGroup addRepository: repository ]. workingCopyWrapper := nil. workingCopy modified: true. self workingCopySelection: 0. self repositorySelection: 0 ]. self workingCopyListChanged; changed: #workingCopySelection; repositoryListChanged. self changedButtons.! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:57'! workingCopySelectionWrapper: aWrapper workingCopyWrapper := aWrapper. self changed: #workingCopySelectionWrapper. self workingCopy: (aWrapper ifNotNil:[aWrapper item])! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 4/11/2013 17:50'! retryOnCredentialRequest: aBlock aBlock on: MCPermissionDenied do: [ :error | |credentials| credentials := MCCredentialsRequest signalUrl: repository location username: repository user password: repository password. credentials ifNotNil: [ self repository credentials: credentials. ^ self retryOnCredentialRequest: aBlock ]]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'BenjaminVanRyseghem 12/6/2013 13:17'! workingCopySearchAccept: string | aString | aString := string ifNil: [ '' ]. workingCopyPattern = aString asLowercase ifTrue: [ ^ self ]. workingCopyPattern := aString asLowercase. packageProcess ifNotNil: [ packageProcess terminate ]. packageProcess := [ self workingCopyListChanged ] fork.! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 8/3/2011 14:50'! addRepository: aRepository self repository: aRepository. self repositoryGroup addRepository: aRepository. self repositoryListChanged; changed: #repositorySelection. self changedButtons.! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 3/23/2010 09:57'! workingCopyTreeLabel: aWrapper ^ aWrapper asString! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 9/30/2011 16:26'! browseWorkingCopy workingCopy ifNotNil: [(MCSnapshotBrowser forSnapshot: workingCopy completeSnapshot) label: 'Snapshot Browser: ', workingCopy packageName; show]! ! !MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: 'StephaneDucasse 5/19/2011 14:41'! historyMenuSpec ^ #(#('Browse package' #browseWorkingCopy) #('View changes' #viewChanges) #('View history' #viewHistory)) ! ! !MCWorkingCopyBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'BenjaminVanRyseghem 1/6/2014 00:43'! viewChanges "View the changes made in the working copy." | patch | 'Finding changes' displayProgressFrom: 0 to: 10 during:[:bar| self canSave ifTrue:[ bar current: 1. patch := workingCopy changesRelativeToRepository: self repository]. patch ifNil: [^ self]. bar current: 3. patch isEmpty ifTrue: [ workingCopy modified: false. bar current: 10. MCNoChangesException signal ] ifFalse: [ workingCopy modified: true. bar current: 5. self viewChanges: patch from: workingCopy packageName, ' (', workingCopy ancestry ancestorString, ')' to: ('Modified {1}' translated format: {workingCopy description})]]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 8/3/2011 14:50'! addRepositoryToPackage self repository ifNotNil: [:repos | (self pickWorkingCopySatisfying: [ :p | (p repositoryGroup includes: repos) not ]) ifNotNil: [:wc | workingCopy := wc. workingCopy repositoryGroup addRepository: repos. self repository: repos. self changed: #workingCopySelection; repositoryListChanged; changed: #repositorySelection. self changedButtons]]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 8/6/2009 18:26'! pickAncestorVersionInfo | ancestors index | ancestors := workingCopy ancestry breadthFirstAncestors. index := UIManager default chooseFrom: (ancestors collect: [:ea | ea name]) title: 'Ancestor:'. ^ index = 0 ifFalse: [ ancestors at: index]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 3/23/2010 09:58'! workingCopyTreeChildren: aWrapper ^ aWrapper contents! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'CamilloBruni 3/13/2012 18:39'! workingCopySearchField ^ SearchMorph new model: self; setIndexSelector: #workingCopySearchAccept:; searchList: self class workingCopySearchList; updateSelector: #workingCopySearchAccept:; yourself ! ! !MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: 'Lr 12/9/2010 17:20'! buttonSpecs ^ #(#('+Package' #addWorkingCopy 'Add a new package and make it the working copy') #('+Config' #addMetacelloConfiguration 'Add a new metacello configuration') #('+Slice' #addSlice 'Add a slice to cleaning and nicely propose a bug fix') #('Browse' #browseWorkingCopy 'Browse the working copy of the selected package' #hasWorkingCopy) #('Changes' #viewChanges 'View the working copy''s changes relative to the installed version from the repository' #canSave) #('+Repository' #addRepository 'Add an existing repository to the list of those visible') #('Save' #saveVersion 'Save the working copy as a new version to the selected repository' #canSave) #('Open' #openRepository 'Open a browser on the selected repository' #hasRepository))! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'CamilloBruni 3/13/2012 18:39'! repositorySearchField ^ SearchMorph new model: self; setIndexSelector: #repositorySearchAccept:; updateSelector: #repositorySearchAccept:; searchList: self class repositorySearchList; yourself! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/16/2012 17:51'! addRequiredDirtyPackage | dirtyPackages | dirtyPackages := self dirtyPackages. workingCopy ifNotNil: [:wc | dirtyPackages do: [:required | wc = required ifFalse: [ wc requirePackage: required package]]]. self workingCopyListChanged! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'SeanDeNigris 7/7/2012 21:45'! workingCopyTreeMorph ^ SimpleHierarchicalListMorph on: self list: #workingCopyTree selected: #workingCopyWrapper changeSelected: #workingCopyWrapper: menu: #workingCopyListMenu:! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 4/11/2013 17:26'! storeDependencies: newVersion in: aRepository self retryOnCredentialRequest: [ aRepository storeDependencies: newVersion ]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'BenjaminVanRyseghem 12/6/2013 13:17'! repositorySearchAccept: string | aString | aString := string ifNil: [ '' ]. repositoryPattern = aString asLowercase ifTrue: [ ^ self ]. repositoryPattern := aString asLowercase. repositoryProcess ifNotNil: [ repositoryProcess terminate ]. repositoryProcess := [ self repositoryListChanged ] fork.! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'EstebanLorenzano 9/8/2013 10:37'! basicSaveVersionIn: aRepository | newVersion waitForVersion | waitForVersion := Semaphore new. UIManager default defer: [ newVersion := workingCopy newVersionIn: aRepository. waitForVersion signal ]. Processor activeProcess == UIManager default uiProcess ifFalse: [ waitForVersion wait ]. newVersion ifNil: [ ^ self ]. Cursor wait showWhile: [[ self storeVersion: newVersion in: aRepository; storeDependencies: newVersion in: aRepository.] ensure: [ (MCVersionInspector new version: newVersion) show ]]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephaneDucasse 6/2/2012 20:35'! workingCopies ^ (self orderSpecs size = order ifTrue: [ self allManagers select: [ :each | each modified ] ] ifFalse: [ self allManagers ]) asSortedCollection: (self orderSpecs at: order) value.! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 02:21'! hasRepository ^ self repository notNil! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! clearRequiredPackages workingCopy ifNotNil: [:wc | wc clearRequiredPackages. self workingCopyListChanged]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'StephanEggermont 1/2/2014 15:41'! setShowOnlyRepositoriesFromWorkingCopy: anIndex showOnlyRepositoriesFromWorkingCopy := (anIndex = 2). self repositorySelection: 0. self repositoryListChanged. ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 8/7/2003 21:22'! canSave ^ self hasWorkingCopy and: [self hasRepository]! ! !MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: 'DanielAviv 1/29/2013 16:39'! packageMenuSpec ^ #(#('Add required package' #addRequiredPackage) #('Add all dirty packages as required' #addRequiredDirtyPackage) #('Remove required package' #removeRequiredPackage) #('Clear required packages' #clearRequiredPackages) #('View past comments' #viewPastComments)) ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 00:46'! hasWorkingCopy ^ workingCopy notNil! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephanEggermont 1/2/2014 15:48'! currentShowOnlyRepositoriesFromWorkingCopy ^showOnlyRepositoriesFromWorkingCopy ifTrue: [ 2] ifFalse: [ 1] ! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! backportChanges self canBackport ifFalse: [^self]. workingCopy ifNotNil: [workingCopy needsSaving ifTrue: [^ self inform: 'You must save the working copy before backporting.']. self pickAncestorVersionInfo ifNotNil: [:baseVersionInfo | workingCopy backportChangesTo: baseVersionInfo]]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 4/6/2013 23:43'! editRepository | newRepo | newRepo := self repository openAndEditTemplateCopy. newRepo ifNotNil: [ (newRepo isKindOf: MCRepository) ifFalse: [ self inform: 'Got a ', newRepo class name, ' instead of a Monticello Repository']. self flag: 'Is this ugly? yes!!'. self repository becomeForward: newRepo ]. self repositoryListChanged! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'AlexandreBergel 10/27/2010 12:24'! configurationClass ^ Smalltalk globals at: workingCopy package name asSymbol ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 8/6/2009 18:26'! pickWorkingCopySatisfying: aBlock | copies index | copies := self workingCopies select: aBlock. copies isEmpty ifTrue: [ ^nil ]. index := UIManager default chooseFrom: (copies collect: [:ea | ea packageName]) title: 'Package:'. ^ index = 0 ifFalse: [ copies at: index]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! defaults ^ defaults ifNil: [defaults := Dictionary new]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'bf 6/3/2005 15:08'! flushAllCaches | beforeBytes afterBytes beforeVersions afterVersions | Cursor wait showWhile: [ beforeBytes := Smalltalk garbageCollect. beforeVersions := MCVersion allSubInstances size. MCFileBasedRepository flushAllCaches. afterBytes := Smalltalk garbageCollect. afterVersions := MCVersion allSubInstances size. ]. ^self inform: (beforeVersions - afterVersions) asString, ' versions flushed', String cr, (afterBytes - beforeBytes) asStringWithCommas, ' bytes reclaimed'! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephanEggermont 1/2/2014 15:42'! getShowOnlyRepositoriesFromWorkingCopySettings ^#('All' 'Package')! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephanEggermont 1/2/2014 15:48'! showOnlyRepositoriesFromWorkingCopyField ^(DropListMorph on: self list: #getShowOnlyRepositoriesFromWorkingCopySettings selected: #currentShowOnlyRepositoriesFromWorkingCopy changeSelected: #setShowOnlyRepositoriesFromWorkingCopy:) listPaneColor: Color transparent; yourself ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 10/14/2008 14:22'! orderString: anIndex ^ String streamContents: [ :stream | order = anIndex ifTrue: [ stream nextPutAll: '' ] ifFalse: [ stream nextPutAll: '' ]. stream nextPutAll: (self orderSpecs at: anIndex) key ]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'CamilloBruni 8/3/2011 14:54'! workingCopySearchAdd: aString self workingCopySearchList: (self workingCopySearchList remove: aString ifAbsent: []; yourself). self workingCopySearchList size = self workingCopySearchMaxSize ifTrue: [self workingCopySearchList removeLast]. self workingCopySearchList addFirst: aString ! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 10/18/2012 16:16'! addRepository self newRepository ifNotNil: [:repos | self addRepository: repos. workingCopy ifNil: [ repos morphicOpen: nil ]]. ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephanEggermont 1/2/2014 15:33'! repositoryGroup ^ showOnlyRepositoriesFromWorkingCopy ifTrue: [ workingCopy ifNil: [ MCRepositoryGroup default ] ifNotNil: [ workingCopy repositoryGroup ] ] ifFalse: [ MCRepositoryGroup default ] ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'bf 6/21/2005 15:56'! repositorySelection: aNumber aNumber = 0 ifTrue: [self repository: nil] ifFalse: [self repository: (self repositories at: aNumber)]. self changed: #repositorySelection. self changedButtons. ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'PatrickBarroca 6/5/2010 17:36'! defaultExtent ^ 620@200! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'AlexandreBergel 10/27/2010 23:18'! lastBaseLine ^ self baseLines last! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ar 2/14/2004 02:46'! deleteWorkingCopy workingCopy unregister. self workingCopySelection: 0. self workingCopyListChanged.! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'BenjaminVanRyseghem 12/5/2013 16:22'! repositories | repositories | repositories := self repositoryGroup repositories. "filter the repository list if there is a search string" repositoryPattern ifNotEmpty: [ repositories := repositories select: [ :each| each description asLowercase includesSubstring: repositoryPattern ]]. ^ repositories! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 3/23/2010 09:57'! workingCopyTreeHasChildren: aWrapper ^ aWrapper hasContents! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'CamilloBruni 8/3/2011 14:49'! repositoryListChanged self changed: #repositoryList.! ! !MCWorkingCopyBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 2/9/2010 14:06'! viewChanges: patch from: fromDescription to: toDescription "Open a browser on the given patch." PSMCPatchMorph usedByDefault ifTrue: [((PSMCPatchMorph forPatch: patch) fromDescription: fromDescription; toDescription: toDescription; newWindow) title: ('Changes to {1}' translated format: {fromDescription}); open] ifFalse: [(MCPatchBrowser forPatch: patch) label: 'Patch Browser: ', workingCopy description; show]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/16/2012 17:49'! addRequiredPackage | chosen | workingCopy ifNotNil: [:wc | chosen := self pickWorkingCopySatisfying: [:ea | ea ~= wc and: [(wc requiredPackages includes: ea package) not]]. chosen ifNotNil: [wc requirePackage: chosen package. self workingCopyListChanged]]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'c 8/10/2010 22:58'! workingCopyTreePath workingCopy ifNil: [^ OrderedCollection new]. ^ OrderedCollection with: workingCopyWrapper.! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'PatrickBarroca 6/7/2010 02:15'! enterSliceName | name | name := UIManager default request: 'Please describe the fix' initialAnswer: 'OneSentenceSummary'. name isEmptyOrNil ifFalse: [ name isAllAlphaNumerics ifFalse:[ UIManager default inform:'Your sentence can only be composed of alphanumerics caracters'. name := self enterSliceName]]. ^ name! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'AlexandreBergel 11/11/2010 16:54'! createDevelopmentVersion self hasAnyBaseline ifFalse: [ UIManager default inform: 'Please, define a baseline first'. ^ self ]. ^ self createVersionForBlessing: #development! ! !MCWorkingCopyBrowser methodsFor: 'updating' stamp: 'EstebanLorenzano 3/19/2014 15:52'! update: anAnnouncement self workingCopyListChanged.! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'EstebanLorenzano 1/3/2014 10:26'! addWorkingCopy | name | name := UIManager default request: 'Name of package:' translated. name isEmptyOrNil ifFalse: [ RPackageOrganizer default registerPackageNamed: name. workingCopy := MCWorkingCopy forPackage: (MCPackage new name: name). workingCopyWrapper := MCDependentsWrapper with: workingCopy model: self. self repositorySelection: 0 ]. self workingCopyListChanged; changed: #workingCopySelection; repositoryListChanged. self changedButtons.! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'MarcusDenker 9/13/2013 14:02'! workingCopyList ^ self workingCopies collect: [:ea | (workingCopy notNil and: [workingCopy requiredPackages includes: ea package]) ifTrue: [Text string: ea description] ifFalse: [ea description]]! ! !MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: 'StephaneDucasse 5/19/2011 14:38'! repositoryMenuSpec ^ #(('Open repository' #openRepository) ('Edit repository info' #editRepository) ('Add to package...' #addRepositoryToPackage) ('Remove repository' #removeRepository) ('Load repositories' #loadRepositories) ('Save repositories' #saveRepositories) ('Flush cached versions' #flushAllCaches)) ! ! !MCWorkingCopyBrowser methodsFor: 'initialization' stamp: 'ThierryGoubier 3/19/2014 17:26'! registerToAnnouncer SystemAnnouncer uniqueInstance weak on: MCVersionCreated send: #update: to: self; on: MCPackageModified send: #update: to: self; on: MCWorkingCopyCreated send: #update: to: self; on: MCWorkingCopyDeleted send: #update: to: self! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 8/3/2011 14:51'! addRepositoryToWorkingCopy workingCopy ifNotNil: [:wc | workingCopy repositoryGroup addRepository: self repository. self changed: #workingCopySelection; repositoryListChanged; changed: #repositorySelection. self changedButtons]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 10/10/2012 14:37'! openRepository self repository ifNotNil: [:repos | repos morphicOpen: workingCopy ]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'AlainPlantec 10/24/2010 22:31'! dirtyPackages ^ self workingCopies select: [:copy | copy needsSaving]. ! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 8/3/2011 14:51'! loadRepositories FileStream fileIn: 'MCRepositories.st'. self repositoryListChanged. self changedButtons. ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 23:38'! defaultLabel ^ 'Monticello Browser'! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'avi 8/31/2004 01:14'! toggleDiffs self repository alwaysStoreDiffs ifTrue: [self repository doNotAlwaysStoreDiffs] ifFalse: [self repository doAlwaysStoreDiffs]! ! !MCWorkingCopyBrowser class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/15/2013 13:49'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons iconNamed: #versionControlIcon! ! !MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/3/2011 14:40'! repositorySearchMaxSize ^ repositorySearchMaxSize ifNil: [repositorySearchMaxSize := 15] ! ! !MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/4/2011 14:53'! repositorySearchList ^ repositorySearchList ifNil: [ repositorySearchList := OrderedCollection new ].! ! !MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'lr 10/14/2008 14:21'! order: anInteger Order := anInteger! ! !MCWorkingCopyBrowser class methodsFor: 'tools registry' stamp: 'IgorStasenko 2/19/2011 04:06'! registerToolsOn: registry registry register: self as: #monticelloBrowser! ! !MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'sd 6/5/2011 19:08'! open self new show! ! !MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/4/2011 14:53'! workingCopySearchList ^ workingCopySearchList ifNil: [ workingCopySearchList := OrderedCollection new ].! ! !MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/3/2011 14:44'! workingCopySearchMaxSize ^ workingCopySearchMaxSize ifNil: [workingCopySearchMaxSize := 15] ! ! !MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'lr 10/14/2008 14:21'! order ^ Order ifNil: [ Order := 1 ]! ! !MCWorkingCopyCreated commentStamp: ''! A MCWorkingCopyCreated is a announcement raised when a new MCWorkingCopy is created! !MCWorkingCopyCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 19:56'! workingCopy ^ workingCopy! ! !MCWorkingCopyCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 19:56'! workingCopy: anObject workingCopy := anObject! ! !MCWorkingCopyCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 19:55'! package: anObject package := anObject! ! !MCWorkingCopyCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 19:55'! package ^ package! ! !MCWorkingCopyCreated class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/25/2012 19:57'! workingCopy: workingCopy ^ self new workingCopy: workingCopy; yourself! ! !MCWorkingCopyCreated class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/25/2012 19:56'! workingCopy: aWC package: package ^ self new workingCopy: aWC; package: package; yourself! ! !MCWorkingCopyDeleted commentStamp: ''! A MCWorkingCopyDeleted class is an announcement raised when a MCWorkingCopy is removed! !MCWorkingCopyDeleted methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 20:24'! workingCopy ^ workingCopy! ! !MCWorkingCopyDeleted methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 20:24'! workingCopy: anObject workingCopy := anObject! ! !MCWorkingCopyDeleted methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 20:24'! package: anObject package := anObject! ! !MCWorkingCopyDeleted methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 20:24'! package ^ package! ! !MCWorkingCopyDeleted class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/25/2012 20:24'! workingCopy: workingCopy ^ self new workingCopy: workingCopy; yourself! ! !MCWorkingCopyDeleted class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/25/2012 20:24'! workingCopy: aWC package: package ^ self new workingCopy: aWC; package: package; yourself! ! !MCWorkingCopyTest methodsFor: 'asserting' stamp: 'EstebanLorenzano 9/8/2013 11:03'! assertNameWhenSavingTo: aRepository is: aString | name | name := nil. [aRepository storeVersion: (workingCopy newVersionIn: aRepository)] on: MCVersionNameAndMessageRequest do: [:n | name := n suggestedName. n resume: (Array with: name with: '')]. self assert: name = aString! ! !MCWorkingCopyTest methodsFor: 'asserting' stamp: 'EstebanLorenzano 9/8/2013 11:03'! assertNumberWhenSavingTo: aRepository is: aNumber | name | name := nil. [aRepository storeVersion: (workingCopy newVersionIn: aRepository)] on: MCVersionNameAndMessageRequest do: [:n | name := n suggestedName. n resume: (Array with: name with: '')]. self assert: name = (self packageName, '-', Author fullName, '.', aNumber asString)! ! !MCWorkingCopyTest methodsFor: 'accessing' stamp: 'ab 7/7/2003 18:02'! description ^ self class name! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testRedundantMerge | base | base := self snapshot. self merge: base. self merge: base! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testSnapshotAndLoad | base inst | inst := self mockInstanceA. base := self snapshot. self change: #one toReturn: 2. self assert: inst one = 2. self load: base. self assert: inst one = 1.! ! !MCWorkingCopyTest methodsFor: 'running' stamp: 'MiguelCoba 7/25/2009 02:03'! tearDown workingCopy unregister. self restoreMocks. self clearPackageCache. Author fullName: savedName.! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'nice 1/5/2010 15:59'! testSelectiveBackport | inst base intermediate final | inst := self mockInstanceA. base := self snapshot. self assert: inst one = 1. self change: #one toReturn: 2. intermediate := self snapshot. self change: #two toReturn: 3. final := self snapshot. [workingCopy backportChangesTo: base info] on: MCChangeSelectionRequest do: [:e | | patch selected | patch := e patch. selected := patch operations select: [:ea | ea definition selector = #two]. e resume: (MCPatch operations: selected)]. self assert: inst one = 1. self assert: inst two = 3. self assert: workingCopy ancestry ancestors size = 1. self assert: workingCopy ancestry ancestors first = base info. self assert: workingCopy ancestry stepChildren size = 1. self assert: workingCopy ancestry stepChildren first = final info! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'CamilloBruni 2/10/2013 17:28'! testBackport | inst base final backported ancestry | inst := self mockInstanceA. base := self snapshot. self assert: inst one = 1. self change: #one toReturn: 2. self change: #two toReturn: 3. final := self snapshot. [workingCopy backportChangesTo: base info] on: MCChangeSelectionRequest do: [:e | e resume: e patch]. self assert: inst one = 2. self assert: inst two = 3. ancestry := workingCopy ancestry. self assert: ancestry ancestors size = 1. self assert: ancestry ancestors first = base info. self assert: ancestry stepChildren size = 1. self assert: ancestry stepChildren first = final info. backported := self snapshot. [workingCopy backportChangesTo: base info] on: MCChangeSelectionRequest do: [:e | e resume: e patch]. ancestry := workingCopy ancestry. self assert: ancestry ancestors size = 1. self assert: ancestry ancestors first = base info. self assert: ancestry stepChildren size = 1. self assert: ancestry stepChildren first = backported info. ! ! !MCWorkingCopyTest methodsFor: 'actions' stamp: 'EstebanLorenzano 9/8/2013 11:04'! snapshot | version | [version := workingCopy newVersionIn: workingCopy repositoryGroup] on: MCVersionNameAndMessageRequest do: [:n | n resume: (Array with: n suggestedName with: '')]. versions at: version info put: version. ^ version! ! !MCWorkingCopyTest methodsFor: 'running' stamp: 'MiguelCoba 7/25/2009 02:02'! setUp | repos1 repos2 | self clearPackageCache. repositoryGroup := MCRepositoryGroup new. repositoryGroup disableCache. workingCopy := MCWorkingCopy forPackage: self mockPackage. versions := Dictionary new. versions2 := Dictionary new. repos1 := MCDictionaryRepository new dictionary: versions. repos2 := MCDictionaryRepository new dictionary: versions2. repositoryGroup addRepository: repos1. repositoryGroup addRepository: repos2. MCRepositoryGroup default removeRepository: repos1; removeRepository: repos2. workingCopy repositoryGroup: repositoryGroup. savedName := Author fullName. Author fullName: 'abc'.! ! !MCWorkingCopyTest methodsFor: 'actions' stamp: 'avi 1/24/2004 20:13'! load: aVersion aVersion load! ! !MCWorkingCopyTest methodsFor: 'running' stamp: 'Anonymous 6/17/2013 13:16'! clearPackageCache | dir | dir := MCCacheRepository uniqueInstance directory. " (dir filesMatching: 'MonticelloMocks*') do: [:ea | ea ensureDeleted ]." (dir filesMatching: 'MonticelloTest*') do: [:ea | ea ensureDelete]. (dir filesMatching: 'rev*') do: [:ea | ea ensureDelete]. (dir filesMatching: 'foo-*') do: [:ea | ea ensureDelete]. (dir filesMatching: 'foo2-*') do: [:ea | ea ensureDelete].! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testDoubleRepeatedMerge | base motherA1 motherA2 motherB1 motherB2 inst | base := self snapshot. self change: #a toReturn: 'a1'. motherA1 := self snapshot. self change: #c toReturn: 'c1'. motherA2 := self snapshot. self load: base. self change: #b toReturn: 'b1'. motherB1 := self snapshot. self change: #d toReturn: 'd1'. motherB2 := self snapshot. self load: base. self merge: motherA1. self merge: motherB1. self change: #a toReturn: 'a2'. self change: #b toReturn: 'b2'. self snapshot. self merge: motherA2. self merge: motherB2. inst := self mockInstanceA. self assert: inst a = 'a2'. self assert: inst b = 'b2'. self assert: inst c = 'c1'. self assert: inst d = 'd1'! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testAncestorMerge | base revA revB revC | base := self snapshot. self change: #a toReturn: 'a1'. revA := self snapshot. self change: #b toReturn: 'b1'. revB := self snapshot. self change: #c toReturn: 'c1'. revC := self snapshot. self should: [self basicMerge: revA] raise: MCNoChangesException. ! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testMergeIntoUnmodifiedImage | base revA | base := self snapshot. self change: #a toReturn: 'a1'. revA := self snapshot. self load: base. self merge: revA. self assert: (workingCopy ancestors size = 1) ! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'bf 5/20/2005 18:25'! testNaming | repos version | repos := MCDictionaryRepository new. self assertNameWhenSavingTo: repos is: self packageName, '-abc.1'. self assertNameWhenSavingTo: repos is: self packageName, '-abc.2'. repos := MCDictionaryRepository new. self assertNameWhenSavingTo: repos is: self packageName, '-abc.3'. version := self snapshot. version info instVarNamed: 'name' put: 'foo-jf.32'. version load. self assertNameWhenSavingTo: repos is: 'foo-abc.33'. self assertNameWhenSavingTo: repos is: 'foo-abc.34'. version info instVarNamed: 'name' put: 'foo-abc.35'. repos storeVersion: version. self assertNameWhenSavingTo: repos is: 'foo-abc.36'. self assertNameWhenSavingTo: repos is: 'foo-abc.37'. version info instVarNamed: 'name' put: 'foo-abc.10'. repos storeVersion: version. self assertNameWhenSavingTo: repos is: 'foo-abc.38'. version info instVarNamed: 'name' put: 'foo2-ab.40'. version load. self assertNameWhenSavingTo: repos is: 'foo2-abc.41'.! ! !MCWorkingCopyTest methodsFor: 'actions' stamp: 'CamilloBruni 9/15/2013 18:17'! merge: aVersion [[self basicMerge: aVersion] on: MCMergeResolutionRequest do: [:n | n merge ]] on: MCNoChangesException do: [:n | ]! ! !MCWorkingCopyTest methodsFor: 'actions' stamp: 'avi 2/13/2004 14:30'! basicMerge: aVersion aVersion merge! ! !MCWorkingCopyTest methodsFor: 'private' stamp: 'cwp 8/2/2003 15:03'! packageName ^ self mockPackage name! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testRepeatedMerge | base mother1 mother2 inst | base := self snapshot. self change: #one toReturn: 2. mother1 := self snapshot. self change: #two toReturn: 3. mother2 := self snapshot. self load: base. self change: #truth toReturn: false. self snapshot. inst := self mockInstanceA. self assert: inst one = 1. self assert: inst two = 2. self merge: mother1. self assert: inst one = 2. self assert: inst two = 2. self change: #one toReturn: 7. self assert: inst one = 7. self assert: inst two = 2. self merge: mother2. self assert: inst one = 7. self assert: inst two = 3! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testOptimizedLoad | inst base diffy | inst := self mockInstanceA. base := self snapshot. self change: #one toReturn: 2. self assert: inst one = 2. diffy := self snapshot asDiffAgainst: base. self deny: diffy canOptimizeLoading. self load: base. self assert: inst one = 1. self assert: diffy canOptimizeLoading. self load: diffy. self assert: inst one = 2. ! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testRepositoryFallback | version | version := self snapshot. self assert: (repositoryGroup versionWithInfo: version info) == version. versions removeKey: version info. versions2 at: version info put: version. self assert: ( repositoryGroup versionWithInfo: version info) == version. versions2 removeKey: version info. self should: [repositoryGroup versionWithInfo: version info] raise: Error.! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testSimpleMerge | mother base inst | inst := self mockInstanceA. base := self snapshot. self change: #one toReturn: 2. mother := self snapshot. self load: base. self change: #two toReturn: 3. self snapshot. self assert: inst one = 1. self assert: inst two = 3. self merge: mother. self assert: inst one = 2. self assert: inst two = 3.! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testMergeIntoImageWithNoChanges | base revB revA1 | self change: #a toReturn: 'a'. base := self snapshot. self change: #b toReturn: 'b'. revB := self snapshot. self load: base. self change: #a toReturn: 'a1'. revA1 := self snapshot. self change: #a toReturn: 'a'. self snapshot. self merge: revB. self assert: (workingCopy ancestors size = 2) ! ! !MCWorkingHistoryBrowser commentStamp: 'TorstenBergmann 2/20/2014 15:53'! Browser for working history! !MCWorkingHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:37'! baseSnapshot ^ package snapshot! ! !MCWriter commentStamp: 'TorstenBergmann 2/6/2014 08:08'! Common superclass for metacello writers! !MCWriter methodsFor: 'accessing' stamp: 'cwp 8/1/2003 01:14'! stream ^ stream! ! !MCWriter methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! stream: aStream stream := aStream! ! !MCWriter class methodsFor: 'accessing' stamp: 'cwp 8/1/2003 15:00'! extension ^ self readerClass extension! ! !MCWriter class methodsFor: 'accessing' stamp: 'cwp 7/28/2003 23:46'! readerClass ^ self subclassResponsibility ! ! !MCWriter class methodsFor: 'writing' stamp: 'cwp 8/1/2003 01:16'! on: aStream ^ self new stream: aStream! ! !MD5 commentStamp: 'ul 3/3/2008 23:40'! This class implements the MD5 128-bit one-way hash function. It uses the MD5Plugin for better performance. Some methods are taken from the original version of MD5NonPrimitive.! !MD5 methodsFor: 'initialization' stamp: 'StephaneDucasse 2/3/2010 22:14'! initialize "Some magic numbers to get the process started" state := #[1 35 69 103 137 171 205 239 254 220 186 152 118 84 50 16] ! ! !MD5 methodsFor: 'private-buffers' stamp: 'StephaneDucasse 10/17/2009 17:15'! processFinalBuffer: aByteArray bitLength: bitLength "Pad the buffer until we have an even 64 bytes, then transform" | out | out := ByteArray new: 64. out replaceFrom: 1 to: aByteArray size with: aByteArray startingAt: 1. aByteArray size < 56 ifTrue: [ out at: aByteArray size + 1 put: 128. "trailing bit" self storeLength: bitLength in: out. self processBuffer: out. ^ self ]. "not enough room for the length, so just pad this one, then..." aByteArray size < 64 ifTrue: [ out at: aByteArray size + 1 put: 128 ]. self processBuffer: out. "process one additional block of padding ending with the length" out := ByteArray new: 64. "filled with zeros" aByteArray size = 64 ifTrue: [ out at: 1 put: 128 ]. self storeLength: bitLength in: out. self processBuffer: out! ! !MD5 methodsFor: 'private-buffers' stamp: 'StephaneDucasse 10/17/2009 17:15'! storeLength: bitLength in: aByteArray "Fill in the final 8 bytes of the given ByteArray with a 64-bit little-endian representation of the original message length in bits." | n i | n := bitLength. i := aByteArray size - 8 + 1. [ n > 0 ] whileTrue: [ aByteArray at: i put: (n bitAnd: 255). n := n bitShift: -8. i := i + 1 ]! ! !MD5 methodsFor: 'private-buffers' stamp: 'ul 3/3/2008 22:28'! primProcessBuffer: aByteArray withState: s self primitiveFailed! ! !MD5 methodsFor: 'accessing' stamp: 'ul 3/3/2008 22:00'! hashStream: aPositionableStream | startPosition buf bitLength | self initialize. aPositionableStream atEnd ifTrue: [ buf := ByteArray new: 64. buf at: 1 put: 128. self processBuffer: buf. ^self finalValue ]. startPosition := aPositionableStream position. [aPositionableStream atEnd] whileFalse: [ buf := aPositionableStream next: 64. (aPositionableStream atEnd not and: [buf size = 64]) ifTrue: [self processBuffer: buf] ifFalse: [ bitLength := (aPositionableStream position - startPosition) * 8. self processFinalBuffer: buf bitLength: bitLength]]. ^ self finalValue! ! !MD5 methodsFor: 'private-buffers' stamp: 'ul 3/3/2008 19:17'! processBuffer: aByteArray self primProcessBuffer: aByteArray withState: state. ! ! !MD5 methodsFor: 'private-buffers' stamp: 'ul 3/3/2008 21:34'! finalValue ^state! ! !MD5 class methodsFor: 'accessing' stamp: 'ul 3/3/2008 23:37'! blockSize ^ 64! ! !MD5 class methodsFor: 'testing' stamp: 'ul 3/3/2008 22:46'! isPluginAvailable ^false! ! !MD5 class methodsFor: 'instance creation' stamp: 'ul 3/3/2008 23:01'! new self isPluginAvailable ifTrue: [ ^self basicNew ] ifFalse: [ ^MD5NonPrimitive basicNew ]! ! !MD5 class methodsFor: 'accessing' stamp: 'ul 3/3/2008 23:37'! hashSize ^ 16! ! !MD5NonPrimitive commentStamp: ''! This class implements the MD5 128-bit one-way hash function. It relies on the ThirtyTwoBitRegister class supplied as part of the "Digital Signatures" functionality included in Squeak 2.7. As of this date (1/20/2000), the U.S. Government has lifted many of the previous restrictions on the export of encryption software, but you should check before exporting anything including this code. MD5 is commonly used for some secure Internet protocols, including authentication in HTTP, which is why I wrote it. Submitted by Duane Maxwell ! !MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 13:38'! ggA: a B: b C: c D: d M: m S: s T: t "compute a = b + ((a + g(b,c,d) + m + t) <<< s)" ^ a += (self gX: b Y: c Z: d); += m; += t; leftRotateBy: s; += b. ! ! !MD5NonPrimitive methodsFor: 'private-rounds' stamp: 'StephaneDucasse 10/17/2009 17:15'! round: data selector: selector round: round "Do one round with the given function" | shiftIndex template abcd | 1 to: 16 do: [ :i | shiftIndex := (i - 1) \\ 4 + 1. abcd := ABCDTable at: shiftIndex. template := { (abcd at: 1). (abcd at: 2). (abcd at: 3). (abcd at: 4). ((IndexTable at: round) at: i). ((ShiftTable at: round) at: shiftIndex). (SinTable at: (round - 1) * 16 + i) }. self step: data template: template selector: selector ]! ! !MD5NonPrimitive methodsFor: 'private-rounds' stamp: 'DSM 1/20/2000 17:58'! rounds: data "Perform the four rounds with different functions" #( ffA:B:C:D:M:S:T: ggA:B:C:D:M:S:T: hhA:B:C:D:M:S:T: iiA:B:C:D:M:S:T: ) doWithIndex: [ :selector :index | self round: data selector: selector round: index.] ! ! !MD5NonPrimitive methodsFor: 'private-buffers' stamp: 'len 10/15/2002 19:58'! finalValue "Concatenate the state values to produce the 128-bite result" ^ (state at: 1) asByteArray, (state at: 2) asByteArray, (state at: 3) asByteArray, (state at: 4) asByteArray! ! !MD5NonPrimitive methodsFor: 'private-functions' stamp: 'StephaneDucasse 10/17/2009 17:15'! step: data template: item selector: selector "Perform one step in the round" | args | args := { (state at: (item at: 1)). (state at: (item at: 2)). (state at: (item at: 3)). (state at: (item at: 4)). (data at: (item at: 5)). (item at: 6). (item at: 7) }. self perform: selector withArguments: args! ! !MD5NonPrimitive methodsFor: 'initialization' stamp: 'StephaneDucasse 10/17/2009 17:15'! initialize "Some magic numbers to get the process started" state := OrderedCollection newFrom: { (ThirtyTwoBitRegister new load: 1732584193). (ThirtyTwoBitRegister new load: 4023233417). (ThirtyTwoBitRegister new load: 2562383102). (ThirtyTwoBitRegister new load: 271733878) }! ! !MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 13:38'! hhA: a B: b C: c D: d M: m S: s T: t "compute a = b + ((a + h(b,c,d) + m + t) <<< s)" ^ a += (self hX: b Y: c Z: d); += m; += t; leftRotateBy: s; += b. ! ! !MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 01:48'! gX: x Y: y Z: z " compute 'xz or y(not z)'" ^ x copy bitAnd: z; bitOr: (z copy bitInvert; bitAnd: y) ! ! !MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 13:38'! ffA: a B: b C: c D: d M: m S: s T: t "compute a = b + ((a + f(b,c,d) + m + t) <<< s)" ^ a += (self fX: b Y: c Z: d); += m; += t; leftRotateBy: s; += b. ! ! !MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 01:48'! iX: x Y: y Z: z " compute 'y xor (x or (not z))'" ^ y copy bitXor: (z copy bitInvert; bitOr: x) ! ! !MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 13:39'! iiA: a B: b C: c D: d M: m S: s T: t "compute a = b + ((a + i(b,c,d) + m + t) <<< s)" ^ a += (self iX: b Y: c Z: d); += m; += t; leftRotateBy: s; += b. ! ! !MD5NonPrimitive methodsFor: 'private-buffers' stamp: 'StephaneDucasse 10/17/2009 17:15'! processBuffer: aByteArray "Process a 64-byte buffer" | saveState data | saveState := state collect: [ :item | item copy ]. data := Array new: 16. 1 to: 16 do: [ :index | data at: index put: (ThirtyTwoBitRegister new reverseLoadFrom: aByteArray at: index * 4 - 3) ]. self rounds: data. 1 to: 4 do: [ :index | (state at: index) += (saveState at: index) ]! ! !MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 01:48'! hX: x Y: y Z: z " compute 'x xor y xor z'" ^ x copy bitXor: y; bitXor: z ! ! !MD5NonPrimitive methodsFor: 'private-functions' stamp: 'DSM 1/20/2000 01:47'! fX: x Y: y Z: z " compute 'xy or (not x)z'" ^ x copy bitAnd: y; bitOr: (x copy bitInvert; bitAnd: z) ! ! !MD5NonPrimitive class methodsFor: 'class initialization' stamp: 'StephaneDucasse 10/17/2009 17:15'! initialize "MD5 initialize" "Obscure fact: those magic hex numbers that are hard to type in correctly are actually the result of a simple trigonometric function and are therefore easier to compute than proofread. Laziness is sometimes a virtue." | c | c := 2 raisedTo: 32. SinTable := Array new: 64. 1 to: 64 do: [ :i | SinTable at: i put: (ThirtyTwoBitRegister new load: (c * i sin abs) truncated) ]. ShiftTable := { #(7 12 17 22 ). #(5 9 14 20 ). #(4 11 16 23 ). #(6 10 15 21 ) }. IndexTable := { #( 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ). #( 2 7 12 1 6 11 16 5 10 15 4 9 14 3 8 13 ). #( 6 9 12 15 2 5 8 11 14 1 4 7 10 13 16 3 ). #( 1 8 15 6 13 4 11 2 9 16 7 14 5 12 3 10 ) }. ABCDTable := { #(1 2 3 4 ). #(4 1 2 3 ). #(3 4 1 2 ). #(2 3 4 1 ) }! ! !MFClassA commentStamp: 'SimonAllier 1/17/2012 10:44'! I'm a dummy class just to have a package that is not empty.! !MFClassA methodsFor: 'as yet unclassified' stamp: 'SimonAllier 5/29/2012 15:53'! method |foo| self halt.! ! !MFClassB commentStamp: 'TorstenBergmann 2/19/2014 08:33'! I'm a dummy class for test purposes ! !MFClassB methodsFor: 'as yet unclassified' stamp: 'SimonAllier 5/29/2012 15:49'! method3 |foo| self halt.! ! !MFClassB methodsFor: 'as yet unclassified' stamp: 'SimonAllier 5/29/2012 15:49'! method2 |foo|! ! !MIMEDocument commentStamp: ''! a MIME object, along with its type and the URL it was found at (if any)! !MIMEDocument methodsFor: 'compatibility' stamp: 'mir 3/4/2002 17:46'! contentType ^self mimeType asString! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 18:19'! contentStream "Answer a RWBinaryOrTextStream on the contents." contentStream ifNil: [contentStream := contents ifNil: [self contentStreamOnURI] ifNotNil: [(RWBinaryOrTextStream with: self contents) reset]]. ^contentStream! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 17:19'! mainType ^self mimeType main! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/27/2005 10:55'! uri "Answer the URL the receiver was downloaded from. It may legitimately be nil." ^uri! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 3/27/2005 10:53'! contents: contentStringOrBytes mimeType: aMimeType uri: aURI type := aMimeType. contents := contentStringOrBytes. uri := aURI! ! !MIMEDocument methodsFor: 'files' stamp: 'MarcusDenker 3/21/2011 14:34'! saveToFile: anAbsolutePathString FileStream forceNewFileNamed: anAbsolutePathString do: [ :str | str binary. str nextPutAll: (self contents) ].! ! !MIMEDocument methodsFor: 'testing' stamp: 'ls 4/30/2000 18:45'! isMultipartAlternative "whether the document is in a multipart format where the parts are alternates" ^ self contentType = 'multipart/alternative' ! ! !MIMEDocument methodsFor: 'printing' stamp: 'mir 3/26/2005 17:48'! printOn: aStream aStream nextPutAll: self class name; nextPutAll: ' ('; nextPutAll: self mimeType asString; nextPutAll: ', '. contents ifNotNil: [aStream nextPutAll: self contents size printString; nextPutAll: ' bytes)'] ifNil: [aStream nextPutAll: 'unknown size)'].! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/26/2005 11:13'! discardContents contents := nil. self discardContentStream! ! !MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:48'! type "Deprecated. Use contentType instead." ^ self contentType! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 16:24'! type: mimeType type := mimeType! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 17:19'! mimeType ^type! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 3/27/2005 10:53'! contentStream: aStream mimeType: aMimeType uri: aUri type := aMimeType. contentStream := aStream. uri := aUri! ! !MIMEDocument methodsFor: 'testing' stamp: 'sbw 1/21/2001 11:13'! isGif ^ self mainType = 'image' and: [self subType = 'gif']! ! !MIMEDocument methodsFor: 'accessing' stamp: 'asasa 8/31/2010 20:40'! url "Answer the URL the receiver was downloaded from. It may legitimately be nil." ^ uri ifNotNil:[uri asString asUrl]! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 11/8/2005 13:39'! privateContent: aString contents := aString! ! !MIMEDocument methodsFor: 'testing' stamp: 'st 9/18/2004 23:38'! isPnm ^ self mainType = 'image' and: [self subType = 'pnm']! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 3/24/2005 17:37'! getContentFromStream | streamContents | streamContents := self contentStream contents. self discardContentStream. ^streamContents! ! !MIMEDocument methodsFor: 'testing' stamp: 'st 9/18/2004 23:37'! isPng ^ self mainType = 'image' and: [self subType = 'png']! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 3/27/2005 10:50'! contentStreamOnURI ^self uri contentStream! ! !MIMEDocument methodsFor: 'accessing' stamp: 'damiencassou 5/30/2008 15:52'! parts "Return the parts of this message. There is a far more reliable implementation of parts in MailMessage, but for now we are continuing to use this implementation" | parseStream currLine separator msgStream messages | self isMultipart ifFalse: [ ^ #() ]. parseStream := self content readStream. currLine := ''. [ '--*' match: currLine ] whileFalse: [ currLine := parseStream nextLine ]. separator := currLine copy. msgStream := LimitingLineStreamWrapper on: parseStream delimiter: separator. messages := OrderedCollection new. [ parseStream atEnd ] whileFalse: [ messages add: msgStream upToEnd. msgStream skipThisLine ]. ^ messages collect: [ :e | MailMessage from: e ]! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 3/26/2005 11:12'! discardContentStream contentStream ifNotNil: [contentStream close]. contentStream := nil! ! !MIMEDocument methodsFor: 'compatibility' stamp: 'mir 3/22/2005 22:55'! content ^self contents! ! !MIMEDocument methodsFor: 'testing' stamp: 'ls 4/30/2000 18:07'! isMultipart ^self mainType = 'multipart'! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/27/2005 10:53'! uri: aURI uri := aURI! ! !MIMEDocument methodsFor: 'testing' stamp: 'sbw 1/21/2001 11:15'! isJpeg ^ self mainType = 'image' and: [self subType = 'jpeg' | (self subType = 'jpg')]! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/24/2005 17:26'! contents "Answer the receiver's raw data. If we have a stream to read from. Read in the data, cache it and discard the stream." contents ifNil: [contents := self getContentFromStream]. ^contents! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 17:19'! subType ^self mimeType sub! ! !MIMEDocument class methodsFor: 'instance creation' stamp: 'mir 3/27/2005 10:54'! contents: content mimeType: aMimeType "create a MIMEDocument with the given content-type and content" "MIMEDocument mimeType: 'text/plain' asMIMEType content: 'This is a test'" ^self contents: content mimeType: aMimeType uri: nil! ! !MIMEDocument class methodsFor: 'compatibility' stamp: 'michael.rueger 2/25/2009 12:36'! defaultContentType ^self defaultMIMEType asString! ! !MIMEDocument class methodsFor: 'compatibility' stamp: 'michael.rueger 2/25/2009 13:05'! guessTypeFromExtension: ext "guesses a content type from the extension" ^self guessTypeFromName: ext! ! !MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'! contentTypeHtml ^'text/html'! ! !MIMEDocument class methodsFor: 'compatibility' stamp: 'michael.rueger 2/25/2009 13:05'! guessContentTypeFromExtension: ext "guesses a content type from the extension" ^(self guessTypeFromExtension: ext) asString! ! !MIMEDocument class methodsFor: 'compatibility' stamp: 'SvenVanCaekenberghe 10/22/2013 11:41'! contentType: aMIMEType content: content "create a MIMEDocument with the given content-type and content" "MIMEDocument contentType: 'text/plain' content: 'This is a test'" ^ self new privateContent: content; type: aMIMEType asZnMimeType; yourself! ! !MIMEDocument class methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 10/22/2013 11:37'! defaultMIMEType ^ ZnMimeType default! ! !MIMEDocument class methodsFor: 'compatibility' stamp: 'michael.rueger 2/25/2009 12:29'! resetMIMEdatabase "no-op for catching Kom override"! ! !MIMEDocument class methodsFor: 'instance creation' stamp: 'mir 3/27/2005 10:57'! contents: content mimeType: aMimeType uri: aURL "create a MIMEDocument with the given content-type and content" "MIMEDocument mimeType: 'text/plain' asMIMEType content: 'This is a test'" ^self new contents: content mimeType: aMimeType uri: aURL! ! !MIMEDocument class methodsFor: 'compatibility' stamp: 'SvenVanCaekenberghe 10/22/2013 11:42'! contentType: type content: content url: url ^ self contents: content mimeType: type asZnMimeType uri: url! ! !MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 12:25'! contentTypeFormData ^'application/x-www-form-urlencoded'! ! !MIMEDocument class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 10/22/2013 11:41'! contentStream: aStream ^ self contentStream: aStream mimeType: self defaultMIMEType! ! !MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'! contentTypeXml ^'text/xml'! ! !MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'! contentTypePlainText ^'text/plain'! ! !MIMEDocument class methodsFor: 'compatibility' stamp: 'SvenVanCaekenberghe 10/22/2013 12:34'! guessTypeFromName: url "guesses a content type from the url" | extension | extension := url asString copyAfterLast: $.. ^ ZnMimeType forFilenameExtension: extension ifAbsent: [ nil ]! ! !MIMEDocument class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 10/22/2013 11:42'! contents: aString ^ self contents: aString mimeType: self defaultMIMEType! ! !MIMEDocument class methodsFor: 'instance creation' stamp: 'mir 3/27/2005 10:52'! contentStream: aStream mimeType: aMimeType "create a MIMEDocument with the given content-type and contentStream" "MIMEDocument mimeType: 'text/plain' asMIMEType contentStream: (ReadStream on: 'This is a test')" ^self contentStream: aStream mimeType: aMimeType uri: aStream uri! ! !MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 12:25'! contentTypeMultipart ^'multipart/form-data'! ! !MIMEDocument class methodsFor: 'instance creation' stamp: 'ls 7/23/1998 22:59'! content: aString ^self contentType: self defaultContentType content: aString! ! !MIMEDocument class methodsFor: 'instance creation' stamp: 'mir 3/27/2005 10:52'! contentStream: aStream mimeType: aMimeType uri: aURI "create a MIMEDocument with the given content-type and contentStream" "MIMEDocument mimeType: 'text/plain' asMIMEType contentStream: (ReadStream on: 'This is a test')" ^self new contentStream: aStream mimeType: aMimeType uri: aURI! ! !MIMEHeaderValue commentStamp: ''! I contain the value portion of a MIME-compatible header. I must be only initialized with the value and not the field name. E.g. in processing Subject: This is the subject the MIMEHeaderValue should be given only 'This is the subject' For traditional non-MIME headers, the complete value returned for mainValue and paramaters returns an empty collection. For MIME headers, both mainValue and parameters are used.! !MIMEHeaderValue methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 10:01'! asHeaderValue | strm | strm := (String new: 20) writeStream. strm nextPutAll: mainValue. parameters associationsDo: [:e | strm nextPut: $; ; nextPutAll: e key; nextPutAll: '="'; nextPutAll: e value , '"']. ^ strm contents! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:13'! mainValue: anObject mainValue := anObject! ! !MIMEHeaderValue methodsFor: 'printing' stamp: 'ls 2/10/2001 12:37'! printOn: aStream super printOn: aStream. aStream nextPutAll: ': '. aStream nextPutAll: self asHeaderValue! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:18'! parameters ^parameters! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:11'! parameters: anObject parameters := anObject! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'ls 2/10/2001 13:06'! parameterAt: aParameter put: value parameters at: aParameter put: value! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:55'! mainValue ^mainValue! ! !MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 1/8/2012 14:45'! fromMIMEHeader: aString "This is the value of a MIME header field and so is parsed to extract the various parts" | parts newValue parms | newValue := self new. parts := (aString findTokens: ';') readStream. newValue mainValue: parts next. parms := Dictionary new. parts do: [ :e | | separatorPos parmValue parmName | separatorPos := e findAnySubStr: '=' startingAt: 1. separatorPos <= e size ifTrue: [ parmName := (e copyFrom: 1 to: separatorPos - 1) trimBoth asLowercase. parmValue := (e copyFrom: separatorPos + 1 to: e size) trimBoth withoutQuoting. parms at: parmName put: parmValue ] ]. newValue parameters: parms. ^ newValue! ! !MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 12:02'! fromTraditionalHeader: aString "This is a traditional non-MIME header (like Subject:) and so should be stored whole" | newValue | newValue := self new. newValue mainValue: aString. newValue parameters: #(). ^newValue. ! ! !MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 12:19'! forField: aFName fromString: aString "Create a MIMEHeaderValue from aString. How it is parsed depends on whether it is a MIME specific field or a generic header field." (aFName beginsWith: 'content-') ifTrue: [^self fromMIMEHeader: aString] ifFalse: [^self fromTraditionalHeader: aString] ! ! !MIMELocalFileDocument commentStamp: ''! For local files, we do not read the entire contents unless we absolutely have to.! !MIMELocalFileDocument methodsFor: 'accessing' stamp: 'ar 4/24/2001 16:27'! contentStream ^contentStream ifNil:[super contentStream]! ! !MIMELocalFileDocument methodsFor: 'accessing' stamp: 'michael.rueger 1/8/2009 19:20'! contentStream: aFileStream contentStream := aFileStream. contents := nil.! ! !MIMELocalFileDocument methodsFor: 'accessing' stamp: 'michael.rueger 1/8/2009 19:19'! content ^contents ifNil:[contents := contentStream contentsOfEntireFile].! ! !MIMELocalFileDocument class methodsFor: 'instance creation' stamp: 'ar 4/24/2001 16:31'! contentType: aString contentStream: aStream ^(self contentType: aString content: nil) contentStream: aStream! ! !MIMEType commentStamp: ''! I am deprecated and have been replaced by ZnMimeType. I guess and represent the content type of a file. For a description of what is MIME, see http://en.wikipedia.org/wiki/Internet_media_type http://en.wikipedia.org/wiki/MIME Examples: MIMEType forFileNameReturnMimeTypesOrDefault: 'index.html'. MIMEType fromMIMEString: 'application/zip'.! !MIMEType methodsFor: 'converting' stamp: 'SvenVanCaekenberghe 10/22/2013 12:37'! asMIMEType ^ self asZnMimeType ! ! !MIMEType methodsFor: 'comparing' stamp: 'JMM 7/26/2006 16:26'! beginsWith: aString ^self printString beginsWith: aString! ! !MIMEType methodsFor: 'comparing' stamp: 'mir 12/17/2005 14:17'! hash ^self main hash bitXor: self sub hash! ! !MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! main: mainType main := mainType! ! !MIMEType methodsFor: 'comparing' stamp: 'mir 3/6/2002 12:11'! = anotherObject anotherObject class == self class ifFalse: [^false]. ^self main = anotherObject main and: [self sub = anotherObject sub]! ! !MIMEType methodsFor: 'accessing' stamp: 'mir 2/16/2006 23:33'! parameters: params parameters := params! ! !MIMEType methodsFor: 'printing' stamp: 'mir 3/4/2002 16:14'! printOn: stream stream nextPutAll: main; nextPut: $/ ; nextPutAll: sub! ! !MIMEType methodsFor: '*zinc-resource-meta-core' stamp: 'SvenVanCaekenberghe 10/15/2013 14:28'! asZnMimeType ^ ZnMimeType main: self main sub: self sub ! ! !MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! sub: subType sub := subType! ! !MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! main ^main! ! !MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! sub ^sub! ! !MIMEType class methodsFor: 'accessing' stamp: 'JMM 10/2/2006 12:38'! huntForDashAndRemove: aString | n | (n := aString lastIndexOf: $-) > 0 ifTrue: [^aString copyFrom: n+1 to: aString size]. ^aString ! ! !MIMEType class methodsFor: 'accessing' stamp: 'JMM 12/2/2007 14:32'! simpleSuffixForMimeType: mimeType ^(self defaultSuffixes at: mimeType printString ifAbsent: [self huntForDashAndRemove: mimeType sub]) asSymbol! ! !MIMEType class methodsFor: 'instance creation' stamp: 'JMM 12/1/2007 12:19'! forFileNameReturnSingleMimeTypeOrNil: fileName | types | types := self forFileNameReturnMimeTypesOrNil: fileName. types ifNotNil: [^types first]. ^nil! ! !MIMEType class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/4/2012 20:29'! forFileNameReturnMimeTypesOrNil: fileName " Disabled for now as the default Pharo image does not have FFI included. Should probably be moved into a future version of the directory plugin. SmalltalkImage current platformName = 'Mac OS' ifTrue: [type := MacUTI callGetMimeTypeOrNilForFileExtension: ext. type ifNil: [fileType := (FileDirectory default getMacFileTypeAndCreator: fileName) at: 1. (fileType = '????' or: [fileType = ((ByteArray new: 4 withAll:0) asString asByteString)]) ifTrue: [^self forExtensionReturnMimeTypesOrNil: ext]. consider := MacUTI callGetMimeTypeOrNilForOSType: fileType. consider ifNotNil: [^Array with: consider]] ifNotNil: [^Array with: type]]. " ^self forExtensionReturnMimeTypesOrNil: fileName asFileReference extension! ! !MIMEType class methodsFor: 'class initialization' stamp: 'MarcusDenker 1/24/2010 11:09'! standardMIMETypes2 "MIMEType standardMimeTypes2" "We had to split this method because of the 256 literal limit in methods." | mimeTypes | mimeTypes := Dictionary new: 100. mimeTypes at: 'nc' put: #('application/x-netcdf'); at: 'o' put: #('application/octet-stream'); at: 'oda' put: #('application/oda'); at: 'ogg' put: #('audio/ogg'); at: 'otf' put: #('application/x-fontopentype'); at: 'otto' put: #('application/x-fontopentype'); at: 'pbm' put: #('image/x-portable-bitmap'); at: 'pcf' put: #('application/x-fontbitmap'); at: 'pdf' put: #('application/pdf'); at: 'pfa' put: #('application/x-fontpostscripttype1'); at: 'pfb' put: #('application/x-fontpostscripttype1'); at: 'pgm' put: #('image/x-portable-graymap'); at: 'pgp' put: #('application/x-pgp-plugin'); at: 'pgr' put: #('text/parsnegar-document'); at: 'pl' put: #('text/plain'); at: 'png' put: #('image/png'); at: 'pnm' put: #('image/x-portable-anymap'); at: 'pot' put: #('application/vnd.ms-powerpoint'); at: 'ppa' put: #('application/vnd.ms-powerpoint'); at: 'ppm' put: #('image/x-portable-pixmap'); at: 'pps' put: #('application/vnd.ms-powerpoint'); at: 'ppt' put: #('application/mspowerpoint'); at: 'ppz' put: #('application/vnd.ms-powerpoint'); at: 'pr' put: #('application/x-squeak-project'); at: 'ps' put: #('application/postscript'); at: 'pwz' put: #('application/vnd.ms-powerpoint'); at: 'qt' put: #('video/quicktime'); at: 'ra' put: #('audio/x-realaudio'); at: 'ram' put: #('audio/x-pn-realaudio'); at: 'ras' put: #('image/x-cmu-rast'); at: 'rgb' put: #('image/x-rgb'); at: 'rm' put: #('audio/x-pn-realaudio'); at: 'roff' put: #('application/x-troff'); at: 'rpm' put: #('audio/x-pn-realaudio-plugin'); at: 'rtc' put: #('application/rtc'); at: 'rtf' put: #('text/rtf' 'application/rtf'); at: 'rtx' put: #('application/rtf'); at: 'saveme' put: #('application/octet-stream'); at: 'sfnt' put: #('application/x-fontsuitcase'); at: 'sh' put: #('application/x-sh'); at: 'shar' put: #('application/x-shar'); at: 'sit' put: #('application/x-stuffit'); at: 'snd' put: #('audio/basic'); at: 'spx' put: #('audio/x-speex'); at: 'src' put: #('application/x-wais-source'); at: 'sts' put: #('application/x-squeak-source'); at: 'suit' put: #('application/x-fontsuitcase'); at: 'sv4cpio' put: #('application/x-sv4cpio'); at: 'sv4crc' put: #('application/x-sv4crc'); at: 'swf' put: #('application/x-shockwave-flash'); at: 't' put: #('application/x-troff'); at: 'tar' put: #('application/x-tar'); at: 'tbk' put: #('application/toolbook'); at: 'tex' put: #('application/x.tex'); at: 'texi' put: #('application/x-texinfo'); at: 'texinfo' put: #('application/x-texinfo'); at: 'text' put: #('text/plain'); at: 'tfil' put: #('application/x-fontsuitcase'); at: 'tif' put: #('image/tiff'); at: 'tiff' put: #('image/tiff'); at: 'tr' put: #('application/x-troff'); at: 'tsv' put: #('text/tab-separated-values'); at: 'ttc' put: #('application/x-fonttruetype'); at: 'ttcf' put: #('application/x-fonttruetype'); at: 'ttf' put: #('application/x-fonttruetype'); at: 'txt' put: #('text/plain'); at: 'ua' put: #('text/plain'); at: 'ustar' put: #('audio/basic'); at: 'uu' put: #('application/octet-stream'); at: 'vgm' put: #('video/x-videogram'); at: 'vgp' put: #('video/x-videogram-plugin'); at: 'vgx' put: #('video/x-videogram'); at: 'viv' put: #('video/vnd.vivo'); at: 'vivo' put: #('video/vnd.vivo'); at: 'vrml' put: #('model/vrml'); at: 'wav' put: #('audio/wav' 'audio/x-wav'); at: 'wid' put: #('application/x-DemoShield'); at: 'wiz' put: #('application/msword'); at: 'wlt' put: #('application/x-mswallet'); at: 'wm' put: #('video/x-ms-wm'); at: 'wma' put: #('audio/x-ms-wma'); at: 'wmv' put: #('video/x-ms-wmv'); at: 'wrl' put: #('model/vrml'); at: 'wsrc' put: #('application/x-wais-source'); at: 'xbm' put: #('image/x-xbitmap'); at: 'xlb' put: #('application/vnd.ms-excel'); at: 'xls' put: #('application/vnd.ms-excel'); at: 'xml' put: #('text/xml' 'text/html'); at: 'xpm' put: #('image/x-xpixmap'); at: 'xul' put: #('application/vnd.mozilla.xul+xml'); at: 'xwd' put: #('image/x-xwindowdump'); at: 'z' put: #('application/x-compress'); at: 'zip' put: #('application/zip'); at: 'zpa' put: #('application/pcphoto'). ^mimeTypes ! ! !MIMEType class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 15:23'! defaultText ^self main: 'text' sub: 'plain'! ! !MIMEType class methodsFor: 'accessing' stamp: 'mir 3/4/2002 16:15'! mimeMappings ^StandardMIMEMappings! ! !MIMEType class methodsFor: 'class initialization' stamp: 'MarcusDenker 1/24/2010 11:09'! initializeDefaultSuffixes "MIMEType initializeDefaultSuffixes" DefaultSuffixes := Dictionary new: 43. DefaultSuffixes at: 'application/freeloader' put: 'frl'; at: 'application/gzip' put: 'gz'; at: 'application/ips' put: 'ips'; at: 'application/mac-binhex40' put: 'hqx'; at: 'application/mac-compactpro' put: 'cpt'; at: 'application/ms-word-document' put: 'doc'; at: 'application/msword' put: 'doc'; at: 'application/octet-stream' put: 'o'; at: 'application/oda' put: 'oda'; at: 'application/olescript' put: 'axs'; at: 'application/pcphoto' put: 'zpa'; at: 'application/pdf' put: 'pdf'; at: 'application/postscript' put: 'ps'; at: 'application/rtc' put: 'rtc'; at: 'application/rtf' put: 'rtf'; at: 'application/toolbook' put: 'tbk'; at: 'application/vnd.ms-excel' put: 'xls'; at: 'application/vnd.ms-powerpoint' put: 'pps'; at: 'application/x-DemoShield' put: 'wid'; at: 'application/x-authorware-map' put: 'aas'; at: 'application/x-bcpio' put: 'bcpio'; at: 'application/x-chat' put: 'chat'; at: 'application/x-compress' put: 'z'; at: 'application/x-connector' put: 'con'; at: 'application/x-cpio' put: 'cpio'; at: 'application/x-csh' put: 'csh'; at: 'application/x-dvi' put: 'dvi'; at: 'application/x-expandedbook' put: 'ebk'; at: 'application/x-fontbitmap' put: 'pcf'; at: 'application/x-fontdataforktruetype' put: 'dfont'; at: 'application/x-fontopentype' put: 'otf'; at: 'application/x-fontpostscripttype1' put: 'pfa'; at: 'application/x-fontsuitcase' put: 'suit'; at: 'application/x-fonttruetype' put: 'ttf'; at: 'application/x-gtar' put: 'gtar'; at: 'application/x-hdf' put: 'hdf'; at: 'application/x-javascript' put: 'js'; at: 'application/x-latex' put: 'latex'; at: 'application/x-msaddr' put: 'adr'; at: 'application/x-mswallet' put: 'wlt'; at: 'application/x-netcdf' put: 'cdf'; at: 'application/x-pgp-plugin' put: 'pgp'; at: 'application/x-sh' put: 'sh'; at: 'application/x-shar' put: 'shar'; at: 'application/x-shockwave-flash' put: 'swf'; at: 'application/x-stuffit' put: 'sit'; at: 'application/x-sv4cpio' put: 'sv4cpio'; at: 'application/x-sv4crc' put: 'sv4crc'; at: 'application/x-tar' put: 'tar'; at: 'application/x-texinfo' put: 'texi'; at: 'application/x-troff' put: 'tr'; at: 'application/x-troff-man' put: 'man'; at: 'application/x-troff-me' put: 'me'; at: 'application/x-troff-ms' put: 'ms'; at: 'application/x-wais-source' put: 'wsrc'; at: 'application/x.tex' put: 'tex'; at: 'application/zip' put: 'zip'; at: 'audio/aiff' put: 'aiff'; at: 'audio/basic' put: 'au'; at: 'audio/midi' put: 'midi'; at: 'audio/mpeg' put: 'mp3'; at: 'audio/wav' put: 'wav'; at: 'audio/x-aiff' put: 'aiff'; at: 'audio/x-dspeech' put: 'cht'; at: 'audio/x-midi' put: 'mid'; at: 'audio/x-mp4-audio' put: 'm4'; at: 'audio/x-ms-wma' put: 'wma'; at: 'audio/x-pn-realaudio' put: 'ram'; at: 'audio/x-pn-realaudio-plugin' put: 'rpm'; at: 'audio/x-quicktime-protected' put: 'm4p'; at: 'audio/x-quicktime-protected-b' put: 'm4b'; at: 'audio/x-realaudio' put: 'ra'; at: 'audio/x-wav' put: 'wav'; at: 'i-world/i-vrml' put: 'ivr'; at: 'image/bmp' put: 'bmp'; at: 'image/gif' put: 'gif'; at: 'image/ief' put: 'ief'; at: 'image/jpeg' put: 'jpg'; at: 'image/png' put: 'png'; at: 'image/tiff' put: 'tiff'; at: 'image/vnd' put: 'dxf'; at: 'image/vnd' put: 'dwg'; at: 'image/x-cmu-rast' put: 'ras'; at: 'image/x-freehand' put: 'fhc'; at: 'image/x-portable-anymap' put: 'pnm'; at: 'image/x-portable-bitmap' put: 'pbm'; at: 'image/x-portable-graymap' put: 'pgm'; at: 'image/x-portable-pixmap' put: 'ppm'; at: 'image/x-rgb' put: 'rgb'; at: 'image/x-xbitmap' put: 'xbm'; at: 'image/x-xwindowdump' put: 'xwd'; at: 'message/rfc822' put: 'mime'; at: 'model/vrml' put: 'vrml'; at: 'text/css' put: 'css'; at: 'text/html' put: 'html'; at: 'text/parsnegar-document' put: 'pgr'; at: 'text/plain' put: 'text'; at: 'text/rtf' put: 'rtf'; at: 'text/tab-separated-values' put: 'tsv'; at: 'text/x-css' put: 'css'; at: 'text/x-setext' put: 'etx'; at: 'text/xml' put: 'xml'; at: 'video/avi' put: 'avi'; at: 'video/mov' put: 'mov'; at: 'video/mpeg' put: 'mpeg'; at: 'video/mpg' put: 'mpg'; at: 'video/quicktime' put: 'qt'; at: 'video/vnd.vivo' put: 'vivo'; at: 'video/x-mp4-video' put: 'mp4v'; at: 'video/x-mpeg' put: 'mpeg'; at: 'video/x-ms-asf' put: 'asf'; at: 'video/x-ms-asf' put: 'asx'; at: 'video/x-ms-wm' put: 'wm'; at: 'video/x-ms-wmv' put: 'wmv'; at: 'video/x-sgi.movie' put: 'movie'; at: 'video/x-videogram' put: 'vgm'; at: 'video/x-videogram-plugin' put: 'vgp'. ^DefaultSuffixes "| stream reverse | stream := StandardFileStream forceNewFileNamed: 'foobar.txt'. reverse := OrderedCollection new. MIMEType mimeMappings associationsDo: [:m | m value do: [:e | reverse add: m key->e]]. sorted := SortedCollection sortBlock: [:n1 :n2 | n1 value printString <= n2 value printString]. sorted addAll: reverse. sorted do: [:s | stream nextPutAll: ' at: '''. stream nextPutAll: s value printString. stream nextPutAll: ''' put: '''. stream nextPutAll: s key. stream nextPutAll: ''';';cr]. stream close." ! ! !MIMEType class methodsFor: 'instance creation' stamp: 'mir 2/16/2006 23:33'! main: mainType sub: subType parameters: parameters ^self new main: mainType; sub: subType; parameters: parameters! ! !MIMEType class methodsFor: 'instance creation' stamp: 'michael.rueger 2/9/2009 15:02'! forExtensionReturnMimeTypesOrNil: fileExtension | loweredFileExtension | loweredFileExtension := fileExtension asLowercase. " Disabled for now as the default Pharo image does not have FFI included. Should probably be moved into a future version of the directory plugin. SmalltalkImage current platformName = 'Mac OS' ifTrue: [loweredFileExtension = '' ifTrue: [^nil]. mime := MacUTI callGetMimeTypeOrNilForFileExtension: loweredFileExtension]. mime ifNotNil: [^Array with: mime]. " ^self mimeMappings at: loweredFileExtension ifAbsent: [^nil]! ! !MIMEType class methodsFor: 'class initialization' stamp: 'michael.rueger 2/24/2009 18:42'! initialize "MIMEType initialize" self initializeStandardMIMETypes. self initializeDefaultSuffixes! ! !MIMEType class methodsFor: 'class initialization' stamp: 'MarcusDenker 1/24/2010 11:10'! standardMIMETypes "We had to split this method because of the 256 literal limit in methods. Please keep it in alphabetical order for easier maintenance." "MIMEType standardMIMETypes" | mimeTypes | mimeTypes := self standardMIMETypes2. mimeTypes at: 'a' put: #('application/octet-stream'); at: 'aam' put: #('application/x-authorware-map'); at: 'aas' put: #('application/x-authorware-map'); at: 'adr' put: #('application/x-msaddr'); at: 'ai' put: #('application/postscript'); at: 'aif' put: #('audio/x-aiff'); at: 'aifc' put: #('audio/x-aiff'); at: 'aiff' put: #('audio/aiff' 'audio/x-aiff'); at: 'arc' put: #('application/octet-stream'); at: 'asf' put: #('video/x-ms-asf'); at: 'asx' put: #('video/x-ms-asf'); at: 'au' put: #('audio/basic'); at: 'avi' put: #('video/avi'); at: 'axs' put: #('application/olescript'); at: 'bcpio' put: #('application/x-bcpio'); at: 'bdf' put: #('application/x-fontbitmap'); at: 'bin' put: #('application/octet-stream'); at: 'bmp' put: #('image/bmp'); at: 'c' put: #('text/plain'); at: 'cdf' put: #('application/x-netcdf'); at: 'chat' put: #('application/x-chat'); at: 'cht' put: #('audio/x-dspeech'); at: 'class' put: #('application/octet-stream'); at: 'con' put: #('application/x-connector'); at: 'cpio' put: #('application/x-cpio'); at: 'cpp' put: #('text/plain'); at: 'cpt' put: #('application/mac-compactpro'); at: 'csh' put: #('application/x-csh'); at: 'css' put: #('text/css' 'text/x-css'); at: 'dfon' put: #('application/x-fontdataforktruetype'); at: 'dfont' put: #('application/x-fontdataforktruetype'); at: 'dms' put: #('application/octet-stream'); at: 'doc' put: #('application/ms-word-document' 'application/msword'); at: 'dot' put: #('application/msword'); at: 'dump' put: #('application/octet-stream'); at: 'dus' put: #('audio/x-dspeech'); at: 'dvi' put: #('application/x-dvi'); at: 'dwg' put: #('image/vnd'); at: 'dxf' put: #('image/vnd'); at: 'ebk' put: #('application/x-expandedbook'); at: 'eps' put: #('application/postscript'); at: 'etx' put: #('text/x-setext'); at: 'exe' put: #('application/octet-stream'); at: 'ffil' put: #('application/x-fontsuitcase'); at: 'fh4' put: #('image/x-freehand'); at: 'fh5' put: #('image/x-freehand'); at: 'fhc' put: #('image/x-freehand'); at: 'frl' put: #('application/freeloader'); at: 'gif' put: #('image/gif'); at: 'gtar' put: #('application/x-gtar'); at: 'gtaru' put: #('application/x-gtar'); at: 'gz' put: #('application/gzip'); at: 'h' put: #('text/plain'); at: 'hdf' put: #('application/x-hdf'); at: 'hqx' put: #('application/mac-binhex40' 'application/octet-stream'); at: 'htm' put: #('text/html' 'text/plain'); at: 'html' put: #('text/html' 'text/plain'); at: 'ief' put: #('image/ief'); at: 'ips' put: #('application/ips'); at: 'ivr' put: #('i-world/i-vrml'); at: 'java' put: #('text/plain'); at: 'jfif' put: #('image/jpeg'); at: 'jfif-tbnl' put: #('image/jpeg'); at: 'jpe' put: #('image/jpeg'); at: 'jpeg' put: #('image/jpeg'); at: 'jpg' put: #('image/jpeg'); at: 'js' put: #('application/x-javascript'); at: 'latex' put: #('application/x-latex'); at: 'lha' put: #('application/octet-stream'); at: 'lwfn' put: #('application/x-fontpostscripttype1'); at: 'lzh' put: #('application/octet-stream'); at: 'm4' put: #('audio/x-mp4-audio'); at: 'm4b' put: #('audio/x-quicktime-protected-b'); at: 'm4p' put: #('audio/x-quicktime-protected'); at: 'm4v' put: #('video/x-mp4-video'); at: 'man' put: #('application/x-troff-man'); at: 'me' put: #('application/x-troff-me'); at: 'mid' put: #('audio/midi' 'audio/x-midi'); at: 'midi' put: #('audio/midi'); at: 'mime' put: #('message/rfc822'); at: 'mov' put: #('video/mov'); at: 'movie' put: #('video/x-sgi-movie' 'video/x-sgi.movie'); at: 'mp2' put: #('audio/mpeg'); at: 'mp3' put: #('audio/mpeg' 'audio/x-mpeg'); at: 'mp4' put: #('video/x-mp4-video'); at: 'mp4v' put: #('video/x-mp4-video'); at: 'mpe' put: #('video/mpeg'); at: 'mpeg' put: #('video/mpeg' 'video/x-mpeg'); at: 'mpg' put: #('video/mpg' 'video/mpeg' 'video/x-mpeg'); at: 'mpga' put: #('audio/mpeg'); at: 'ms' put: #('application/x-troff-ms'); at: 'mv' put: #('video/x-sgi-movie'). ^mimeTypes! ! !MIMEType class methodsFor: 'instance creation' stamp: 'mir 3/6/2002 13:07'! contentTypeURLEncoded ^self main: 'application' sub: 'x-www-form-urlencoded'! ! !MIMEType class methodsFor: 'instance creation' stamp: 'mir 2/16/2006 23:33'! fromMIMEString: mimeString | idx main rest sub parameters | idx := mimeString indexOf: $/. idx = 0 ifTrue: [self error: 'Illegal mime type string "' , mimeString , '".']. main := mimeString copyFrom: 1 to: idx-1. rest := mimeString copyFrom: idx+1 to: mimeString size. idx := mimeString indexOf: $;. idx = 0 ifTrue: [sub := rest] ifFalse: [ sub := rest copyFrom: 1 to: idx. parameters := rest copyFrom: idx+1 to: rest size]. ^self main: main sub: sub parameters: parameters ! ! !MIMEType class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 10/22/2013 12:36'! forFileNameReturnMimeTypesOrDefault: fileName | mimeTypes | mimeTypes := self forFileNameReturnMimeTypesOrNil: fileName. mimeTypes ifNil: [ ^ Array with: self defaultStream ]. ^ mimeTypes! ! !MIMEType class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 15:25'! defaultStream ^self main: 'application' sub: 'octet-stream'! ! !MIMEType class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 17:06'! defaultHTML ^self main: 'text' sub: 'html'! ! !MIMEType class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 10/22/2013 12:44'! new self deprecated: 'MIMEType has been replaced with ZnMimeType' on: '20131022' in: '3.0'. ^ super new! ! !MIMEType class methodsFor: 'class initialization' stamp: 'SvenVanCaekenberghe 10/22/2013 12:35'! initializeStandardMIMETypes "MIMEType initializeStandardMIMETypes" StandardMIMEMappings := Dictionary new. self standardMIMETypes keysAndValuesDo:[:extension :mimeStrings | StandardMIMEMappings at: extension asString asLowercase put: (mimeStrings collect: [:mimeString | self fromMIMEString: mimeString]). ].! ! !MIMEType class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 15:22'! main: mainType sub: subType ^self new main: mainType; sub: subType! ! !MIMEType class methodsFor: 'accessing' stamp: 'michael.rueger 2/24/2009 18:42'! defaultSuffixes "MIMEType defaultSuffixes" ^DefaultSuffixes! ! !MIMEType class methodsFor: 'accessing' stamp: 'JMM 12/2/2007 14:31'! suffixForMimeType: mimeType ^self defaultSuffixes at: mimeType printString ifAbsent: [mimeType sub]! ! !MIMEType class methodsFor: 'instance creation' stamp: 'JMM 12/1/2007 23:02'! forFileNameReturnSingleMimeTypeOrDefault: fileName | types | types := self forFileNameReturnMimeTypesOrDefault: fileName. ^types first! ! !MOPTestClassA methodsFor: 'local' stamp: ''! c3 ^ 'Trait3>>c3'! ! !MOPTestClassA methodsFor: 'local' stamp: ''! c ^ 'Trait3>>c'! ! !MOPTestClassA methodsFor: 'trait2 - c' stamp: ''! c2 ^ 'Trait2>>c2'! ! !MOPTestClassB methodsFor: 'trait1 - c' stamp: ''! c1 ^ 'Trait1>>c1'! ! !MOPTestClassB methodsFor: 'trait1 - c' stamp: ''! c ^ 'Trait1>>c'! ! !MOPTestClassB methodsFor: 'trait2 - c' stamp: ''! c2 ^ 'Trait2>>c2'! ! !MOPTestClassC methodsFor: 'local' stamp: 'stephane.ducasse 10/7/2008 16:57'! c ^ 'C>>c'! ! !MOPTestClassC methodsFor: 'trait2 - c' stamp: ''! c2 ^ 'Trait2>>c2'! ! !MOPTestClassD methodsFor: 'trait2 - c' stamp: ''! c3 ^ 'Trait2>>c2'! ! !MOPTestClassD methodsFor: 'trait2 - c' stamp: ''! c ^ 'Trait2>>c'! ! !MOPTestClassD methodsFor: 'trait2 - c' stamp: ''! c2 ^ 'Trait2>>c2'! ! !MOPTraitTest methodsFor: 'tests' stamp: 'matthew_fulmer 7/29/2009 14:24'! testSelector "self debug: #testSelector" "The selector of a compiled method should be its name. An aliased method should have the name of its alias name." self assert: (MOPTestClassA>>#c) selector = #c. self assert: (MOPTestClassC>>#c) selector = #c. self assert: (Trait3>>#c) selector = #c. self assert: (Trait3>>#c2) selector = #c2. self assert: (MOPTestClassD>>#c3) selector = #c3.! ! !MOPTraitTest methodsFor: 'tests' stamp: 'matthew_fulmer 7/29/2009 14:24'! testOrigin "self debug: #testClass" "The origin of a compiledMethod is its defining class or trait." self assert: (MOPTestClassC>>#c) origin = MOPTestClassC. self assert: (MOPTestClassA>>#c) origin = Trait3. self assert: (Trait3>>#c2) origin = Trait2. self assert: (MOPTestClassA>>#c2) origin = Trait2. self assert: (MOPTestClassB>>#c) origin = Trait1. self assert: (MOPTestClassD>>#c3) origin = Trait2. self assert: (MOPTestClassD>>#c2) origin = Trait2.! ! !MOPTraitTest methodsFor: 'tests' stamp: 'matthew_fulmer 7/29/2009 14:24'! testClass "self debug: #testClass" "The class of a compiled method is the class that contains it. A compiled method is shared." "methodClass could call -> methodClassOrTrait" self assert: (Trait1>>#c) methodClass = Trait1. self assert: (Trait2>>#c) methodClass = Trait2. self assert: (MOPTestClassC>>#c) methodClass = MOPTestClassC. self assert: (MOPTestClassC>>#c2) methodClass = MOPTestClassC. self assert: (MOPTestClassD>>#c) methodClass = MOPTestClassD. self assert: (MOPTestClassD>>#c2) methodClass = MOPTestClassD. self assert: (MOPTestClassD>>#c3) methodClass = MOPTestClassD. self assert: (MOPTestClassA>>#c2) methodClass = MOPTestClassA. ! ! !MTDependantProject commentStamp: ''! A dependant project represents an external projetc you are dependending on. Instance Variables - configurationClass : the configurationClass this project represents - repository : The core repository URL of this project! !MTDependantProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 1/31/2013 10:27'! displayName ^ displayName! ! !MTDependantProject methodsFor: 'displaying' stamp: 'ChristopheDemarey 7/26/2013 17:02'! displayString ^ version ifNil: [ displayName ] ifNotNil: [ version name ifNil: [ displayName ] ifNotNil: [displayName, ' (', version name, ')' ] ]! ! !MTDependantProject methodsFor: '*Versionner-Spec-Browser' stamp: 'ChristopheDemarey 6/21/2013 10:44'! treeNodeClass ^ VSProjectLeafNode! ! !MTDependantProject methodsFor: 'visiting' stamp: 'ChristopheDemarey 12/6/2013 16:48'! acceptVisitor: anMTProjectVisitor anMTProjectVisitor visitDependantProject: self! ! !MTDependantProject methodsFor: '*Versionner-Spec-Browser' stamp: 'ChristopheDemarey 2/24/2014 15:47'! editVersion | availableVersions index | configurationClass ifNil: [ UIManager inform: 'Cannot find the configuration class for ' , name. ^ self ]. availableVersions := configurationClass project versions select: [ :aVersion | aVersion blessing ~= #baseline ] thenCollect: [ :aVersion | aVersion versionString ]. availableVersions := configurationClass project symbolicVersionSymbols , availableVersions. index := UIManager default chooseFrom: availableVersions title: 'Available versions in ', name. (index = 0) ifFalse: [ | versionString | versionString := availableVersions at: index. self version: (MTVersion fromVersionString: versionString) ]! ! !MTDependantProject methodsFor: 'displaying' stamp: 'ChristopheDemarey 2/17/2014 15:58'! repositories: aRepositoryList "Set a list of repository URLs for this project." repositories := aRepositoryList asOrderedCollection.! ! !MTDependantProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 11/30/2012 14:55'! configurationClass ^ configurationClass! ! !MTDependantProject methodsFor: 'initialize-release' stamp: 'ChristopheDemarey 12/12/2013 14:53'! initialize repositories := OrderedCollection new. dependencies := OrderedCollection new.! ! !MTDependantProject methodsFor: 'comparing' stamp: 'ChristopheDemarey 2/24/2014 18:15'! = other (super = other) ifFalse: [ ^false ]. (self configurationClass = other configurationClass) ifFalse: [ ^false ]. (self displayName = other displayName) ifFalse: [ ^false ]. (self repositories hasEqualElements: other repositories) ifFalse: [ ^false ]. ^ true! ! !MTDependantProject methodsFor: '*Versionner-Spec-Browser' stamp: 'ChristopheDemarey 1/17/2014 18:39'! editRepositories | packageName repoManager | packageName := configurationClass package name. repoManager := VersionnerRepositoriesManager newWithPackage: packageName. repoManager selectedChangedBlock: [:remote :selected | selected ifTrue: [ self repositories add: remote location ] ifFalse: [ self repositories remove: remote location ] ]; open; yourself.! ! !MTDependantProject methodsFor: 'displaying' stamp: 'ChristopheDemarey 6/5/2013 10:42'! repositories ^ repositories! ! !MTDependantProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 1/31/2013 10:27'! displayName: anObject displayName := anObject! ! !MTDependantProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 11/30/2012 14:55'! configurationClass: anObject configurationClass := anObject! ! !MTDependantProject class methodsFor: 'instantiation' stamp: 'ChristopheDemarey 1/17/2014 18:46'! newWithWorkingCopy: anMBConfigurationInfo "Create a new dependent project with the given project." | requiredProject version | requiredProject := self new name: anMBConfigurationInfo name configurationBaseName; configurationClass: anMBConfigurationInfo configurationClass; yourself. requiredProject displayName: requiredProject name. requiredProject editRepositories. version := (anMBConfigurationInfo hasVersion: #stable) ifTrue: [ #stable ] ifFalse: [ #bleedingEdge ]. requiredProject version: (MTVersion fromVersionString: version). ^ requiredProject! ! !MTDependantProjectTest commentStamp: ''! Test clas for a dependant project! !MTDependantProjectTest methodsFor: 'private' stamp: 'ChristopheDemarey 12/12/2013 11:26'! referenceDependency | version | version := MTVersion new name: '1.0'; yourself. ^ (MTDependantProject newNamed: 'LibXYZ') configurationClass: self class; repositories: #('http://smalltalkhub.com/mc/dummy/XYZ/main', 'http://github.com/XYZ'); displayName: 'XYZ'; parent: nil; version: version; yourself.! ! !MTDependantProjectTest methodsFor: 'tests' stamp: 'ChristopheDemarey 12/12/2013 12:44'! testEquals | dependency otherDependency | dependency := self referenceDependency. otherDependency := self referenceDependency. self assert: otherDependency equals: dependency. otherDependency := self referenceDependency name: 'toto'; yourself. self deny: otherDependency = dependency. otherDependency := self referenceDependency parent: self; yourself. self deny: otherDependency = dependency. otherDependency := self referenceDependency configurationClass: Object; yourself. self deny: otherDependency = dependency. otherDependency := self referenceDependency repositories: #('http://smalltalkhub.com/mc/dummy/XYZ/main', 'http://github.com/LibXYZ'); yourself. self deny: otherDependency = dependency.! ! !MTDependency commentStamp: ''! A MTDependency is an abstraction for project dependencies. Instance Variables - name : The dependency name - repository : The repository URL used to find this dependency - version : The specific version describes by the dependency - platforms : If not nil, the dependency is only applicable to specified platforms - dependencies : A dependency could have dependencies - project : The project root node - parent: The owner of the dependency.! !MTDependency methodsFor: 'accessing' stamp: 'ChristopheDemarey 11/30/2012 13:10'! version: aVersion "Set the specific version used for this dependency" version := aVersion.! ! !MTDependency methodsFor: 'accessing' stamp: 'ChristopheDemarey 12/11/2013 14:08'! parent: anObject parent := anObject! ! !MTDependency methodsFor: 'accessing' stamp: 'ChristopheDemarey 6/12/2013 10:17'! dependencies: aCollection dependencies := aCollection.! ! !MTDependency methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/19/2013 18:39'! displayName ^ self name! ! !MTDependency methodsFor: 'displaying' stamp: 'ChristopheDemarey 11/30/2012 17:49'! displayString "Pretty print to display a dependency." self subclassResponsibility .! ! !MTDependency methodsFor: 'accessing' stamp: 'ChristopheDemarey 12/11/2013 17:23'! project | myparent | myparent := self parent. [ myparent isNotNil ] whileTrue: [ [ myparent := myparent parent ] on: MessageNotUnderstood do: [ ^ myparent ] ]. ^ myparent! ! !MTDependency methodsFor: '*Versionner-Spec-Browser' stamp: 'ChristopheDemarey 6/21/2013 10:41'! treeNodeClass "get the Node class to use to display this dependency in a a TreeModel." self shouldBeImplemented ! ! !MTDependency methodsFor: 'accessing' stamp: 'ChristopheDemarey 12/13/2012 16:04'! version "Get the specific version used for this dependency" ^version.! ! !MTDependency methodsFor: 'visiting' stamp: 'ChristopheDemarey 12/6/2013 16:44'! acceptVisitor: aMTProjectVisitor self subclassResponsibility! ! !MTDependency methodsFor: 'initialize-release' stamp: 'TesterBob 11/27/2012 15:36'! initialize dependencies := OrderedCollection new. ! ! !MTDependency methodsFor: 'comparing' stamp: 'ChristopheDemarey 12/12/2013 12:42'! = other (self name = other name) ifFalse: [ ^false ]. (self version = other version) ifFalse: [ ^false ]. (self parent = other parent) ifFalse: [ ^false ]. "(self platforms = other platforms) ifFalse: [ ^false ]." ^true! ! !MTDependency methodsFor: 'accessing' stamp: 'ChristopheDemarey 11/14/2012 18:19'! name: anObject name := anObject! ! !MTDependency methodsFor: 'printing' stamp: 'ChristopheDemarey 11/30/2012 13:12'! printOn: aStream "Pretty print for dependencies" aStream nextPutAll: self name.! ! !MTDependency methodsFor: 'protocol' stamp: 'ChristopheDemarey 9/10/2013 00:27'! remove "search if I am present in other groups and remove myself from these groups, then remove myself from project dependencies" (self project groups select: [ :aGroup | aGroup dependencies includes: name ]) do: [ :aGroup | aGroup removeDependency: name]. self project dependencies: (self project dependencies reject: [ :dep | dep = self]). self project announcer announce: (MTProjectModelChanged project: self)! ! !MTDependency methodsFor: 'accessing' stamp: 'ChristopheDemarey 12/11/2013 14:07'! parent ^ parent! ! !MTDependency methodsFor: 'protocol' stamp: 'ChristopheDemarey 9/10/2013 00:21'! removeDependency: aDependency dependencies remove: aDependency ifAbsent: [ ]! ! !MTDependency methodsFor: 'accessing' stamp: 'ChristopheDemarey 11/27/2012 11:48'! name ^ name! ! !MTDependency methodsFor: 'protocol' stamp: 'ChristopheDemarey 12/11/2013 17:20'! addDependency: aDependency (dependencies includes: aDependency) ifFalse: [ [ aDependency parent: self ] on: MessageNotUnderstood do: [ "ignore" ]. dependencies add: aDependency ] ! ! !MTDependency methodsFor: 'accessing' stamp: 'ChristopheDemarey 12/7/2012 13:42'! dependencies ^ dependencies! ! !MTDependency methodsFor: 'displaying' stamp: 'ChristopheDemarey 2/21/2013 16:31'! asString "Pretty print to display a dependency." ^ self displayString.! ! !MTDependency class methodsFor: 'instantiation' stamp: 'ChristopheDemarey 1/24/2013 17:16'! newNamed: aName "Create a new dependency with the given name." ^ self new name: aName.! ! !MTDependencyTest methodsFor: 'as yet unclassified' stamp: 'ChristopheDemarey 6/27/2013 15:58'! testRemove (project dependencyNamed: 'XML-Writer-Core') remove. self assert: ((project dependencyNamed: 'XML-Writer-Core') = nil).! ! !MTDependencyTest methodsFor: 'as yet unclassified' stamp: 'ChristopheDemarey 12/11/2013 18:25'! testProject | dependency | dependency := project dependencyNamed: 'Core'. self assert: dependency project equals: project. dependency := (project dependencyNamed: 'XML-Writer-Core'). self assert: dependency project equals: project. dependency := (project dependencyNamed: 'Collections-Support'). self assert: dependency project equals: project. ! ! !MTDependencyTest methodsFor: 'as yet unclassified' stamp: 'ChristopheDemarey 6/27/2013 16:00'! testRemoveGroup (project dependencyNamed: 'Core') remove. self assert: (project dependencyNamed: 'Core') = nil. self assert: ((project dependencyNamed: 'default') dependencies includes: 'Core') not! ! !MTDependencyTest methodsFor: 'as yet unclassified' stamp: 'ChristopheDemarey 6/27/2013 15:44'! setUp | visitor | visitor := MCModel2MTModelVisitor new. version := ConfigurationOfVersionnerTestXMLWriter project version: '2.1.0'. project := visitor visitConfiguration: ConfigurationOfVersionnerTestXMLWriter withVersion: version. ! ! !MTDevelopmentWorkfow commentStamp: ''! This class is used to manage the development workflow for a dedicated project. ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 2/7/2014 14:53'! setStableBlessingFor: versionName (MetacelloToolBox configurationNamed: project name) modifyVersionMethodForVersion: versionName versionSpecsDo: [ :attr :versionSpec | attr == #common ifTrue: [ versionSpec blessing: #stable ]. true ]; commitMethod! ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 3/28/2014 10:51'! standardizeDevVersionString: aDevVersionString aDevVersionString := aDevVersionString copyReplaceAll: 'baseline-' with: ''. aDevVersionString := aDevVersionString copyReplaceAll: '-baseline' with: ''. aDevVersionString := aDevVersionString copyReplaceAll: 'baseline' with: ''. ^ aDevVersionString , '-baseline'! ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 2/21/2014 16:16'! createBaseline: baselineVersionString "Create a new baseline with information given by the project" MetacelloToolBox createBaseline: baselineVersionString for: project configurationClass name repository: project repository requiredProjects: (project requiredProjects collect: [ :each | each name ]) packages: (project packages collect: [ :aPackage | aPackage name ]) repositories: #() dependencies: project dependenciesMap groups: (project groups collect: [ :aGroup | aGroup name -> aGroup dependencies ]) requiredProjectSpecs: self requiredProjectSpecs! ! !MTDevelopmentWorkfow methodsFor: 'accessing' stamp: 'ChristopheDemarey 6/25/2013 10:02'! project: anObject project := anObject! ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 11/21/2013 18:26'! createInitialDevelopment: versionString "Create an initial development version with an empty configuration and return the configuration class." | toolbox | toolbox := MetacelloToolBox configurationNamed: project name. "Only a static method available on the toolbox to create baselines" MetacelloToolBox createBaseline: versionString for: toolbox project configuration class name repository: project repository requiredProjects: #() packages: #() repositories: #() dependencies: #() groups: #(). toolbox symbolicVersionMethod: #development; addSymbolicSection: #common version: versionString; commitMethod. ^toolbox project configuration class! ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 9/16/2013 11:45'! notifyConfigurationModified (MBConfigurationRoot current configurationInfoFor: project configurationClass class) configurationClassModified! ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 2/6/2014 13:51'! developmentVersion: devVersionString platformAttribute: platformAttribute "Set the #development symbolic version to the given version, using the given platformAttribute." (MetacelloToolBox configurationNamed: project name) symbolicVersionMethod: #development; addSymbolicSection: platformAttribute version: devVersionString; commitMethod. ! ! !MTDevelopmentWorkfow methodsFor: 'protocol' stamp: 'ChristopheDemarey 2/7/2014 14:21'! createInitialDevelopment "Create an initial development version for an empty configuration." ^ self createInitialDevelopment: '0.1-baseline'! ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 11/27/2013 13:10'! developmentVersionNumber: aDevelopmentVersionString | versionNumber | versionNumber := aDevelopmentVersionString copyReplaceAll: 'baseline' with: ''. versionNumber := versionNumber copyReplaceAll: '-' with: ''. ^ versionNumber! ! !MTDevelopmentWorkfow methodsFor: 'accessing' stamp: 'ChristopheDemarey 6/25/2013 10:02'! project ^ project! ! !MTDevelopmentWorkfow methodsFor: 'protocol' stamp: 'ChristopheDemarey 2/25/2014 15:56'! updateDevelopment "Update development baseline with information present in the project." | baseline versionString | versionString := self developmentVersion versionString. self isDevelopmentUsedInRelease ifTrue: [ self createNextDevelopment: self nextDevelopmentVersionString ] ifFalse: [ baseline := MetacelloToolBox compiledMethodForVersion: self developmentVersion. baseline methodClass class removeSelector: baseline selector. self createBaseline: versionString ]. self notifyConfigurationModified! ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 2/21/2014 16:16'! requiredProjectSpecs ^ project requiredProjects collect: [ :requiredProject | VersionnerToolBox projectSpecFromRequiredProject: requiredProject ].! ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 2/25/2014 15:32'! isDevelopmentUsedInRelease | devVersion allProjectVersions | devVersion := self developmentVersion. devVersion ifNil: [ ^ false ]. (devVersion blessing = #baseline) ifFalse: [ ^false ]. allProjectVersions := project configurationClass project versions. ^ allProjectVersions detect: [ :aVersion | aVersion importedVersions includes: devVersion versionString ] ifFound: [ true ] ifNone: [ false ]! ! !MTDevelopmentWorkfow methodsFor: 'protocol' stamp: 'ChristopheDemarey 2/6/2014 15:43'! developmentVersion ^ project configurationClass project version: #development! ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 6/25/2013 10:24'! createBaseline "Create a new baseline with information given by the project" |lastBaseline baselineVersionString| lastBaseline := self configurationClass baselines detect: [:aBaseline | aBaseline isBleedingEdge]. baselineVersionString := (lastBaseline name asInteger +1) asString. ^ self createBaseline: baselineVersionString.! ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 3/28/2014 11:03'! nextDevelopmentVersionString: aDevelopmentVersionString | versionNumber lastPointIndex newVersionNumber | versionNumber := self developmentVersionNumber: aDevelopmentVersionString. lastPointIndex := versionNumber lastIndexOf: $. ifAbsent: [ nil ]. newVersionNumber := lastPointIndex ifNil: [ versionNumber + 1 ] ifNotNil: [ | newMinorVersion | newMinorVersion := (versionNumber allButFirst: lastPointIndex) asInteger + 1. (versionNumber copyFrom: 1 to: lastPointIndex) , (newMinorVersion asString) ]. ^ self standardizeDevVersionString: newVersionNumber ! ! !MTDevelopmentWorkfow methodsFor: 'protocol' stamp: 'ChristopheDemarey 7/5/2013 22:24'! createNextDevelopment: newDevVersionString "Create the next baseline that will be used as development version." self createBaseline: newDevVersionString. self developmentVersion: newDevVersionString platformAttribute: #common.! ! !MTDevelopmentWorkfow methodsFor: 'protocol' stamp: 'ChristopheDemarey 4/1/2014 16:59'! nextDevelopmentVersionString | newVersionString | newVersionString := self developmentVersion versionString. [ project configurationClass project hasVersion: newVersionString ] whileTrue: [ newVersionString := self nextDevelopmentVersionString: newVersionString ]. ^ newVersionString! ! !MTDevelopmentWorkfow methodsFor: 'private' stamp: 'ChristopheDemarey 3/28/2014 11:31'! version: versionString ^ project configurationClass project version: versionString! ! !MTDevelopmentWorkfow methodsFor: 'protocol' stamp: 'ChristopheDemarey 3/19/2014 11:50'! releaseDevelopment: versionName "Release the development baseline (will give a version method) with the given version name." | devVersionString | devVersionString := self developmentVersion versionString. MetacelloToolBox createVersion: versionName for: project name from: devVersionString description: 'version ' , versionName. self setStableBlessingFor: versionName. MetacelloToolBox stableVersion: versionName for: project name platformAttribute: #common. "keep the development version pointing to the baseline" self developmentVersion: devVersionString platformAttribute: #common. self notifyConfigurationModified! ! !MTDevelopmentWorkfow class methodsFor: 'initialization' stamp: 'ChristopheDemarey 6/25/2013 10:00'! newWithProject: project "Create a new instance dedicated to the project given as parameter." ^ self new project: project; yourself! ! !MTDevelopmentWorkfowTest methodsFor: 'tests' stamp: 'ChristopheDemarey 11/21/2013 17:56'! testNewProjectWithInitialVersionInRepository | projectName configClass | projectName := 'VersionnerTest'. project := MTProject newNamed: projectName withInitialVersion: '0.1' inRepository: ''. self assert: (project configurationClass notNil) description: 'Project configuration class is nil.'. self shouldnt: [configClass := Smalltalk globals at: (project configurationClass name)] raise: KeyNotFound description: 'Cannot find the Configuration class in the image.'. self assert: project name equals: projectName. configClass removeFromSystem. ! ! !MTDevelopmentWorkfowTest methodsFor: 'tests' stamp: 'ChristopheDemarey 3/28/2014 11:02'! testNextDevelopmentVersionString | workflow | workflow := MTDevelopmentWorkfow new. self assert: (workflow nextDevelopmentVersionString: '1.0-baseline') equals: '1.1-baseline'. self assert: (workflow nextDevelopmentVersionString: '1.0') equals: '1.1-baseline'. self assert: (workflow nextDevelopmentVersionString: 'baseline-0.9') equals: '0.10-baseline'.! ! !MTDevelopmentWorkfowTest methodsFor: 'tests' stamp: 'ChristopheDemarey 3/28/2014 10:59'! testStandardizeDevVersionString | workflow | workflow := MTDevelopmentWorkfow new. self assert: (workflow standardizeDevVersionString: '1.0-baseline') equals: '1.0-baseline'. self assert: (workflow standardizeDevVersionString: 'baseline-1.3') equals: '1.3-baseline'.! ! !MTDevelopmentWorkfowTest methodsFor: 'tests' stamp: 'ChristopheDemarey 2/7/2014 14:57'! testCreateInitialDevelopment | version configuration | project := MTProject newNamed: 'Z' withInitialVersion: '0.1' inRepository: 'http://smalltalkhub.com/mc/demarey/Versionner/main'. configuration := project configurationClass. visitor := MCModel2MTModelVisitor new. self shouldnt: [ version := configuration project version: #development] raise: MetacelloSymbolicVersionDoesNotExistError description: 'Cannot find the #development symbolic version in the metacello description'. self assert: configuration project development versionString equals: '0.1-baseline'. "configuration removeFromSystem."! ! !MTDevelopmentWorkfowTestWithXMLParser methodsFor: 'tests' stamp: 'ChristopheDemarey 11/21/2013 18:34'! testCreateNextDevelopment project devWorkflow createNextDevelopment: '999'. self assert: (project configurationClass selectors includes: #'baseline999:').! ! !MTDevelopmentWorkfowTestWithXMLParser methodsFor: 'utility' stamp: 'ChristopheDemarey 2/25/2014 15:23'! setDevelopment: aVersionString project configurationClass compile: 'development: spec spec for: #''common'' version: ''' , aVersionString , '''.'! ! !MTDevelopmentWorkfowTestWithXMLParser methodsFor: 'tests' stamp: 'ChristopheDemarey 2/25/2014 15:24'! testIsDevelopmentUsedInRelease | workflow | workflow := project devWorkflow. self assert: workflow isDevelopmentUsedInRelease equals: false. self setDevelopment: '1.0-baseline'. self assert: workflow isDevelopmentUsedInRelease equals: true. self setDevelopment: '2.0-baseline'. self assert: workflow isDevelopmentUsedInRelease equals: false. self setDevelopment: '1.1'. self assert: workflow isDevelopmentUsedInRelease equals: false. ! ! !MTDevelopmentWorkfowTestWithXMLParser methodsFor: 'tests' stamp: 'ChristopheDemarey 11/21/2013 17:52'! testCreateBaseline | baselineName baseline | baselineName := '84.1'. project devWorkflow createBaseline: baselineName. "Visit the created baseline" baseline := project configurationClass project version: baselineName. project := visitor visitConfiguration: project configurationClass withVersion: baseline. self assert: project notNil. self assert: project name equals: 'VersionnerTestXMLParser'. self assert: project version name equals: baselineName. ! ! !MTDevelopmentWorkfowTestWithXMLParser methodsFor: 'running' stamp: 'ChristopheDemarey 6/25/2013 13:19'! tearDown classFactory cleanUp.! ! !MTDevelopmentWorkfowTestWithXMLParser methodsFor: 'running' stamp: 'ChristopheDemarey 6/25/2013 13:19'! setUp "Create a model of the project version we want to work on." | version | "create a copy of the class to don't pollute the configuration with code generated for tests purposes" classFactory := ClassFactoryForTestCase new. class := classFactory duplicateClass: ConfigurationOfVersionnerTestXMLParserTemplate withNewName: #ConfigurationOfVersionnerTestXMLParser. visitor := MCModel2MTModelVisitor new. version := class project version: '1.1'. project := visitor visitConfiguration: class withVersion: version. ! ! !MTGroup commentStamp: ''! A MTGroup is a convenient way to group software dependencies (instances of MTDependency). Instance Variables - dependencies : A collection of dependencies defiing the group. ! !MTGroup methodsFor: 'displaying' stamp: 'ChristopheDemarey 11/30/2012 17:50'! displayString ^ name! ! !MTGroup methodsFor: '*Versionner-Spec-Browser' stamp: 'ChristopheDemarey 6/21/2013 10:44'! treeNodeClass ^ VSGroupLeafNode! ! !MTGroup methodsFor: 'protocol' stamp: 'ChristopheDemarey 12/11/2013 18:26'! addDependency: aDependency super addDependency: aDependency. self project ifNotNil: [ self project announcer announce: (MTProjectModelChanged project: self) ].! ! !MTGroup methodsFor: 'visiting' stamp: 'ChristopheDemarey 12/6/2013 16:49'! acceptVisitor: anMTProjectVisitor anMTProjectVisitor visitGroup: self! ! !MTModelComparator commentStamp: ''! A comparator that can be used to compare a whole dependency graph.! !MTModelComparator methodsFor: 'comparing' stamp: 'ChristopheDemarey 3/14/2014 18:28'! is: anMTProject equalsTo: anOtherMTProject | referenceModelIterator modelToCompareIterator | referenceModelIterator := MTProjectBFSIterator on: anMTProject. modelToCompareIterator := MTProjectBFSIterator on: anOtherMTProject. [ true ] whileTrue: [ | referenceElement elementToCompare | referenceElement := referenceModelIterator next. elementToCompare := modelToCompareIterator next. (referenceElement = elementToCompare ) ifFalse: [ ^false ]. referenceModelIterator hasNext ifFalse: [ ^ modelToCompareIterator hasNext not ] ] ! ! !MTModelComparator class methodsFor: 'protocol' stamp: 'ChristopheDemarey 12/12/2013 13:34'! is: anMTProject equalsTo: anOtherMTProject ^self new is: anMTProject equalsTo: anOtherMTProject! ! !MTModelComparatorTest methodsFor: 'tests' stamp: 'ChristopheDemarey 3/14/2014 18:29'! testIsEqualsTo | projectA projectB | projectA := self referenceModel. projectB := self referenceModel. self deny: projectA == projectB. self assert: (MTModelComparator is: projectA equalsTo: projectB). projectB removeDependencyNamed: 'PackageA2'. self deny: (MTModelComparator is: projectA equalsTo: projectB). projectB :=self referenceModel. projectB removeDependencyNamed: 'LibXYZ'. self deny: (MTModelComparator is: projectA equalsTo: projectB). projectB := self referenceModel. projectB removeDependencyNamed: 'All'. self deny: (MTModelComparator is: projectA equalsTo: projectB). projectB := self referenceModel. (projectB dependencyNamed: 'All') removeDependency: (projectB dependencyNamed: 'SmallGroup'). self deny: (MTModelComparator is: projectA equalsTo: projectB). projectB := self referenceModel. (projectB dependencyNamed: 'LibXYZ') addDependency: 'Core'. self deny: (MTModelComparator is: projectA equalsTo: projectB). projectA := MTProjectExampleBuilder projectC. projectB := MTProjectExampleBuilder projectC. (projectB dependencyNamed: 'LibXYZ') addDependency: 'Core'. self deny: (MTModelComparator is: projectA equalsTo: projectB). self deny: (MTModelComparator is: projectB equalsTo: projectA).! ! !MTModelComparatorTest methodsFor: 'private' stamp: 'ChristopheDemarey 12/12/2013 14:42'! referenceModel ^ MTProjectExampleBuilder projectA! ! !MTPackage commentStamp: ''! A MTPackage represents an internal depedency of a project, i.e a package located in the same MCPackage. Note: Metacello allows to describe external dependencies. In this case, transitive dependencies are not fetched. As this is not the good way to express dependencies, it is not supported here!!! !MTPackage methodsFor: 'displaying' stamp: 'ChristopheDemarey 1/24/2013 17:31'! displayString ^ version ifNil: [ name ] ifNotNilDo: [ :aVersion | name, ' (', aVersion author , '.', aVersion name asString, ')' ].! ! !MTPackage methodsFor: '*Versionner-Spec-Browser' stamp: 'ChristopheDemarey 6/21/2013 10:44'! treeNodeClass ^VSPackageLeafNode! ! !MTPackage methodsFor: 'visiting' stamp: 'ChristopheDemarey 12/6/2013 16:50'! acceptVisitor: anMTProjectVisitor anMTProjectVisitor visitPackage: self! ! !MTPlatform commentStamp: ''! A MTPlatform reprensents targeted platforms (ex: pharo1.4.x, pharo2.x) ! !MTProject commentStamp: ''! A project represents a software development project, and more presicely, its depdendencies (also known as configuration). Note: Need to add extra methods with "for:" parameter to handle platforms (e.g. for: #'pharo' do) Instance Variables - configurationClass : the configurationClass this project represents - repository : The core repository URL of this project - packages : internal packages (MTPackage) the project depends on - groups : definitions of set of dependencies (MTGroups) - depedentProjects : list of external projects this project depends on (list of project names) ! !MTProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/19/2013 18:41'! dependencyNamed: aDependencyName "Get a depedency from its name" ^ dependencies detect: [ :aDependency | (aDependency name = aDependencyName) or: [ aDependency displayName = aDependencyName ] ] ifNone: [ nil ] ! ! !MTProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 12/12/2012 14:05'! name ^ name! ! !MTProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/23/2013 17:17'! announcer ^ announcer ifNil: [announcer := Announcer new]! ! !MTProject methodsFor: 'accessing' stamp: 'TesterBob 11/27/2012 15:31'! groups "Filter dependencies to only get groups" ^ self dependenciesFilteredBy: MTGroup .! ! !MTProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 6/26/2013 18:03'! dependencies: aDependencyList dependencies := aDependencyList! ! !MTProject methodsFor: 'setting' stamp: 'ChristopheDemarey 12/12/2012 15:03'! version: aMTVersion version := aMTVersion! ! !MTProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 1/30/2013 15:00'! repository ^ repository ! ! !MTProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 12/12/2012 15:04'! version ^ version! ! !MTProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 6/6/2013 12:53'! currentBaseline | baselines | baselines := self configurationClass project versions select: [:aVersion | aVersion blessing == #baseline]. ^baselines last! ! !MTProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 6/25/2013 13:25'! devWorkflow ^ devWorkflow ifNil: [ devWorkflow := MTDevelopmentWorkfow newWithProject: self ] ifNotNil: [ :myself | myself ]! ! !MTProject methodsFor: 'visiting' stamp: 'ChristopheDemarey 12/6/2013 17:20'! acceptVisitor: anMTProjectVisitor anMTProjectVisitor visitProject: self. dependencies do: [ :dependency | dependency acceptVisitor: anMTProjectVisitor ]! ! !MTProject methodsFor: 'accessing' stamp: 'TesterBob 11/27/2012 15:31'! packages "Filter dependencies to only get packages" ^ self dependenciesFilteredBy: MTPackage .! ! !MTProject methodsFor: 'accessing' stamp: 'TesterBob 11/27/2012 15:32'! requiredProjects "Filter dependencies to only get RquiredProject" ^ self dependenciesFilteredBy: MTDependantProject .! ! !MTProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 11/30/2012 16:17'! configurationClass ^ configurationClass! ! !MTProject methodsFor: 'initialize-release' stamp: 'TesterBob 11/27/2012 15:42'! initialize dependencies := OrderedCollection new. ! ! !MTProject methodsFor: 'comparing' stamp: 'ChristopheDemarey 12/12/2013 09:38'! = other (self name = other name) ifFalse: [ ^false ]. (self version = other version) ifFalse: [ ^false ]. (self configurationClass = other configurationClass) ifFalse: [ ^false ]. (self repository = other repository) ifFalse: [ ^false ]. ^true! ! !MTProject methodsFor: 'accessing' stamp: 'TesterBob 11/27/2012 15:41'! name: anObject name := anObject! ! !MTProject methodsFor: 'protocol' stamp: 'ChristopheDemarey 6/27/2013 15:48'! removeDependencyNamed: aDependencyName "Remove a depedency from the configuration" (self dependencyNamed: aDependencyName) remove! ! !MTProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 1/31/2013 10:54'! repository: aRepositoryURL repository := aRepositoryURL.! ! !MTProject methodsFor: 'accessing' stamp: 'ChristopheDemarey 6/25/2013 10:45'! dependenciesMap ^ self packages collect: [ :aPackage | aPackage name -> aPackage dependencies ]! ! !MTProject methodsFor: 'private' stamp: 'TesterBob 11/27/2012 15:30'! dependenciesFilteredBy: aClass "Filter dependencies to only get Class instances" ^dependencies select: [ :each | each class = aClass ].! ! !MTProject methodsFor: 'setting' stamp: 'ChristopheDemarey 12/11/2013 14:11'! addDependency: aDependency "Add a dependency to the configuration (will create a new baseline)." dependencies add: aDependency. aDependency parent: self. self announcer announce: (MTProjectModelChanged project: self).! ! !MTProject methodsFor: 'accessing' stamp: 'TesterBob 11/27/2012 15:27'! dependencies ^dependencies .! ! !MTProject methodsFor: 'protocol' stamp: 'ChristopheDemarey 3/6/2013 16:25'! configurationClass: aConfigurationClass configurationClass := aConfigurationClass. self name: configurationClass name configurationBaseName. ! ! !MTProject class methodsFor: 'instance creation' stamp: 'ChristopheDemarey 3/28/2014 16:29'! newNamed: projectName withInitialVersion: version inRepository: repositoryURL "Create the skeleton of a new project (alos known as configuration)" | project | project := self new. project name: projectName. project repository: repositoryURL. project configurationClass: project devWorkflow createInitialDevelopment. ^ project. ! ! !MTProject class methodsFor: 'instance creation' stamp: 'ChristopheDemarey 4/2/2014 15:19'! newFromVersion: aMetacelloVersion inConfiguration: aConfigurationClass ^ MCModel2MTModelVisitor new visitConfiguration: aConfigurationClass withVersion: aMetacelloVersion! ! !MTProjectBFSIterator commentStamp: ''! BFS (see http://en.wikipedia.org/wiki/Breadth-first_search) iterator for an MTProject graph. We avoid to visit already visited children of a node.! !MTProjectBFSIterator methodsFor: 'initialization' stamp: 'ChristopheDemarey 12/11/2013 11:35'! initialize queue := SharedQueue new. alreadyVisited := Set new.! ! !MTProjectBFSIterator methodsFor: 'protocol' stamp: 'ChristopheDemarey 12/11/2013 13:20'! hasNext ^ queue isEmpty not ! ! !MTProjectBFSIterator methodsFor: 'accessing' stamp: 'ChristopheDemarey 12/11/2013 13:07'! project: anMTProject project := anMTProject. self reset! ! !MTProjectBFSIterator methodsFor: 'protocol' stamp: 'ChristopheDemarey 12/11/2013 13:11'! next | currentElement | currentElement := queue nextOrNil. currentElement ifNotNil: [ ((self hasChildNodes: currentElement) and: [ self isNotVisited: currentElement ]) ifTrue: [ queue nextPutAll: currentElement dependencies. alreadyVisited add: currentElement ] ]. ^ currentElement! ! !MTProjectBFSIterator methodsFor: 'protocol' stamp: 'ChristopheDemarey 12/11/2013 13:07'! reset self initialize. queue nextPut: project! ! !MTProjectBFSIterator methodsFor: 'private' stamp: 'ChristopheDemarey 12/11/2013 13:03'! isNotVisited: aNode ^ (alreadyVisited includes: aNode) not! ! !MTProjectBFSIterator methodsFor: 'private' stamp: 'ChristopheDemarey 12/12/2013 17:34'! hasChildNodes: aNode | dependencies | [ dependencies := aNode dependencies ] on: MessageNotUnderstood do: [ ^false ]. ^ dependencies size > 0! ! !MTProjectBFSIterator class methodsFor: 'instance creation' stamp: 'ChristopheDemarey 12/10/2013 13:43'! on: anMTProject ^ self new project: anMTProject; yourself.! ! !MTProjectBFSIteratorTest methodsFor: 'tests' stamp: 'ChristopheDemarey 12/11/2013 13:17'! testNext | iterator currentElement | iterator := MTProjectBFSIterator on: MTProjectExampleBuilder projectA. currentElement := iterator next. self assert: (currentElement isKindOf: MTProject). self assert: currentElement name equals: 'A'. (1 to: 5) do: [ :i | currentElement := iterator next. self assert: (currentElement isKindOf: MTPackage). self assert: currentElement name equals: 'PackageA' , i asString ]. currentElement := iterator next. self assert: (currentElement isKindOf: MTDependantProject). self assert: currentElement name equals: 'LibXYZ'. currentElement := iterator next. self assert: (currentElement isKindOf: MTGroup). self assert: currentElement name equals: 'SmallGroup'. currentElement := iterator next. self assert: (currentElement isKindOf: MTGroup). self assert: currentElement name equals: 'All'. (1 to: 5) do: [ :i | currentElement := iterator next. self assert: (currentElement isKindOf: MTPackage). self assert: currentElement name equals: 'PackageA' , i asString ]. currentElement := iterator next. self assert: (currentElement isKindOf: MTGroup). self assert: currentElement name equals: 'SmallGroup'. currentElement := iterator next. self assert: (currentElement isKindOf: MTDependantProject). self assert: currentElement name equals: 'LibXYZ'. self assert: iterator hasNext not. self assert: iterator next isNil! ! !MTProjectExampleBuilder commentStamp: ''! A MTProjectExampleBuilder is used to create some MTProjects with dummy data or tests purposes. ! !MTProjectExampleBuilder class methodsFor: 'building projects' stamp: 'ChristopheDemarey 3/14/2014 18:25'! projectC | project | project := MTProject newNamed: 'C' withInitialVersion: '0.1' inRepository: 'http://smalltalkhub.com/mc/dummy/C/main'. project addDependency: (MTDependantProject newNamed: 'LibXYZ'). ^ project! ! !MTProjectExampleBuilder class methodsFor: 'building projects' stamp: 'ChristopheDemarey 12/10/2013 13:39'! projectB | project allGroup smallGroup | project := MTProject newNamed: 'B' withInitialVersion: '0.2' inRepository: 'http://smalltalkhub.com/mc/dummy/A/main'. (1 to: 4) do: [ :i | project addDependency: (MTPackage newNamed: 'PackageA' , i asString) ]. project addDependency: (MTDependantProject newNamed: 'LibXYZ'). smallGroup := MTGroup newNamed: 'SmallGroup'. project packages do: [ :package | smallGroup addDependency: package ]. project addDependency: smallGroup. allGroup := MTGroup newNamed: 'All'. allGroup addDependency: smallGroup. project addDependency: allGroup. ^ project! ! !MTProjectExampleBuilder class methodsFor: 'building projects' stamp: 'ChristopheDemarey 12/10/2013 13:39'! projectA | project allGroup smallGroup | project := MTProject newNamed: 'A' withInitialVersion: '0.1' inRepository: 'http://smalltalkhub.com/mc/dummy/A/main'. (1 to: 5) do: [ :i | project addDependency: (MTPackage newNamed: 'PackageA' , i asString) ]. project addDependency: (MTDependantProject newNamed: 'LibXYZ'). smallGroup := MTGroup newNamed: 'SmallGroup'. project packages do: [ :package | smallGroup addDependency: package ]. project addDependency: smallGroup. allGroup := MTGroup newNamed: 'All'. allGroup addDependency: smallGroup. allGroup addDependency: project requiredProjects first. project addDependency: allGroup. ^ project! ! !MTProjectModelChanged commentStamp: ''! A MTAnnouncement is used to signal a change on a MTProject model.! !MTProjectModelChanged methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/23/2013 17:22'! project: anObject project := anObject! ! !MTProjectModelChanged methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/23/2013 17:22'! project ^ project! ! !MTProjectModelChanged class methodsFor: 'creation' stamp: 'ChristopheDemarey 7/23/2013 18:00'! project: anObject ^ self new project: anObject; yourself! ! !MTProjectTest commentStamp: ''! Test class for MTProject! !MTProjectTest methodsFor: 'tests' stamp: 'ChristopheDemarey 12/12/2013 10:28'! testEquals | projectA projectB | projectA := MTProjectExampleBuilder projectA. projectB := MTProjectExampleBuilder projectA. self deny: projectA == projectB. self assert: projectA equals: projectB. projectB name: 'B'. self deny: projectA == projectB. projectB := MTProjectExampleBuilder projectA. projectB version: MTVersion new. self deny: projectA == projectB. projectB := MTProjectExampleBuilder projectA. projectB configurationClass: self class. self deny: projectA == projectB. projectB := MTProjectExampleBuilder projectA. projectB repository: 'http://localhost'. self deny: projectA == projectB.! ! !MTVersion commentStamp: ''! A MTVersion describes a specific version of a dependency. Instance Variables - author : the version author - versionString : a version String that can be used to load the described version (e.g ConfigurationOfXXX project version: versionString) - description : the version description - timestamp : the commit time of this version - project : a reference to the described project! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/15/2013 14:10'! timestamp: anObject timestamp := anObject! ! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/15/2013 14:10'! description ^ description! ! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 11/30/2012 16:15'! project "Get the project this version is refering to. May be a project or a required project" ^ project! ! !MTVersion methodsFor: 'visiting' stamp: 'ChristopheDemarey 12/6/2013 16:54'! acceptVisitor: anMTProjectVisitor anMTProjectVisitor visitVersion: self.! ! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 11/30/2012 11:44'! author: anObject author := anObject! ! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/25/2013 15:23'! versionString ^ versionString! ! !MTVersion methodsFor: 'comparing' stamp: 'ChristopheDemarey 12/12/2013 12:42'! = other (self name = other name) ifFalse: [ ^false ]. (self author = other author) ifFalse: [ ^false ]. (self versionString = other versionString) ifFalse: [ ^false ]. (self description = other description) ifFalse: [ ^false ]. (self timestamp = other timestamp) ifFalse: [ ^false ]. (self project = other project) ifFalse: [ ^false ]. ^true.! ! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 11/30/2012 11:44'! author ^ author! ! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/15/2013 14:10'! description: anObject description := anObject! ! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 12/7/2012 14:34'! mcVersion "Get the MetacelloMCVersion object representing this version" | configurationClass | configurationClass := project configurationClass. configurationClass project version: versionString. ! ! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 11/30/2012 11:39'! name: aName name := aName.! ! !MTVersion methodsFor: 'printing' stamp: 'ChristopheDemarey 11/30/2012 16:26'! printOn: aStream "Pretty print for a version" aStream "nextPutAll: name ; nextPut: $- ; nextPutAll: author ; nextPut: $. ;" nextPutAll: versionString asString .! ! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 7/15/2013 14:10'! timestamp ^ timestamp! ! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 12/13/2012 16:08'! versionString: aVersionString versionString := aVersionString. name := aVersionString.! ! !MTVersion methodsFor: 'accessing' stamp: 'ChristopheDemarey 12/13/2012 16:04'! name ^name.! ! !MTVersion class methodsFor: 'instance creation' stamp: 'ChristopheDemarey 7/25/2013 15:21'! fromVersionName: aVersionName "Create a new version from a versionName (a file reference)." | version names | names := MetacelloCommonMCSpecLoader nameComponentsFrom: aVersionName. version := self new. version name: names first. version author: (names at: 2). version versionString: (names at: 3). ^ (version versionString = 0) ifTrue: [ nil ] ifFalse: [ version ] ! ! !MTVersion class methodsFor: 'instance creation' stamp: 'ChristopheDemarey 11/30/2012 15:57'! fromVersionString: aVersionString "Create a new version from a versionString." | version | version := self new. version versionString: aVersionString . ^ version ! ! !MacOSClipboard commentStamp: 'TorstenBergmann 1/31/2014 10:28'! The clipboard for MacOS! !MacOSClipboard methodsFor: 'private' stamp: 'michael.rueger 3/2/2009 12:51'! addUF8StringClipboardData: aString | ba | self clearClipboard. ba := aString convertToWithConverter: (UTF8TextConverter new). self addClipboardData: ba dataFormat: 'public.utf8-plain-text' ! ! !MacOSPlatform commentStamp: ''! I am a an object representing a Mac OS (pre OSX) platform. Use myself to access platform specific features. ! !MacOSPlatform methodsFor: '*System-Clipboard' stamp: 'CamilloBruni 5/9/2013 22:27'! clipboardClass ^MacOSClipboard! ! !MacOSPlatform methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2013 22:28'! isMacOS ^ true! ! !MacOSPlatform methodsFor: '*Keys' stamp: 'CamilloBruni 5/9/2013 22:27'! keyForValue: aKeyValue ^Key valueForMacOSXPlatform: aKeyValue.! ! !MacOSPlatform methodsFor: 'accessing' stamp: 'cami 7/22/2013 18:33'! family ^#MacOS! ! !MacOSPlatform methodsFor: '*Files' stamp: 'DamienCassou 11/15/2013 18:10'! potentialLocationsOfSourcesFile ^ { "Take care of .app that have a 'Resources' folder as a sibling of the vm binary" Smalltalk vm fullPath asFileReference parent parent / 'Resources'. Smalltalk vm directory. Smalltalk vm fullPath asFileReference parent. FileLocator systemApplicationSupport. FileLocator userApplicationSupport. }! ! !MacOSPlatform methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/12/2013 14:22'! lineEnding ^ String lf! ! !MacOSPlatform methodsFor: '*Keymapping-KeyCombinations' stamp: 'CamilloBruni 11/29/2013 17:09'! defaultModifier ^ KMModifier meta! ! !MacOSPlatform class methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2013 22:38'! isMacOS ^ self currentPlatformName = 'Mac OS'! ! !MacOSPlatform class methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2013 22:38'! isActivePlatform ^ self isMacOS and: [ self currentVersion asNumber < 1000 ]! ! !MacOSResolver commentStamp: 'cwp 11/18/2009 11:57'! I am an expert on Mac OS X filesystem conventions. I resolve origins according to these conventions.! !MacOSResolver methodsFor: 'origins' stamp: 'DamienCassou 11/7/2013 17:12'! preferences ^ self home / 'Library' / 'Preferences'! ! !MacOSResolver methodsFor: 'origins' stamp: 'CamilloBruni 11/8/2013 18:35'! systemApplicationSupport ^ self systemLibrary / 'Application Support'! ! !MacOSResolver methodsFor: 'origins' stamp: 'DamienCassou 7/4/2013 15:47'! home ^ self directoryFromEnvVariableNamed: 'HOME'! ! !MacOSResolver methodsFor: 'origins' stamp: 'DamienCassou 7/4/2013 15:45'! cache ^ self library / 'Caches'! ! !MacOSResolver methodsFor: 'origins' stamp: 'cwp 10/27/2009 21:45'! desktop ^ self home / 'Desktop'! ! !MacOSResolver methodsFor: 'origins' stamp: 'CamilloBruni 11/8/2013 18:35'! userApplicationSupport ^self userLibrary / 'Application Support'! ! !MacOSResolver methodsFor: 'origins' stamp: 'CamilloBruni 11/8/2013 19:06'! systemLibrary ^ FileSystem disk root / 'Library'! ! !MacOSResolver methodsFor: 'origins' stamp: 'cwp 10/27/2009 21:50'! documents ^ self home / 'Documents'! ! !MacOSResolver methodsFor: 'origins' stamp: 'CamilloBruni 11/8/2013 18:37'! library ^ self userLibrary! ! !MacOSResolver methodsFor: 'resolving' stamp: 'CamilloBruni 11/8/2013 19:07'! supportedOrigins ^ super supportedOrigins , #(userApplicationSupport systemApplicationSupport systemLibrary userLibrary)! ! !MacOSResolver methodsFor: 'origins' stamp: 'CamilloBruni 11/8/2013 18:35'! userLibrary ^ self home / 'Library'! ! !MacOSResolver methodsFor: 'origins' stamp: 'DamienCassou 12/20/2013 11:58'! temp ^ '/tmp' asFileReference! ! !MacOSResolver class methodsFor: 'accessing' stamp: 'cwp 10/27/2009 10:59'! platformName ^ 'Mac OS'! ! !MacOSXPlatform commentStamp: ''! I am a an object representing a MacOSX platform. Use myself to access platform specific features. Please keep me polymorphic to the the other platform objects. To get the current platform, you can evaluate: OSPlatform current.! !MacOSXPlatform methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2013 22:28'! isMacOSX ^ true! ! !MacOSXPlatform methodsFor: 'accessing' stamp: 'cami 7/22/2013 18:33'! family ^#MacOSX! ! !MacOSXPlatform class methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2013 22:39'! isActivePlatform ^ self isMacOS and: [ self currentVersion asNumber >= 1000 ]! ! !MacRomanTextConverter commentStamp: ''! Text converter for Mac Roman. An encoding used for the languages originated from Western Europe area.! !MacRomanTextConverter class methodsFor: 'as yet unclassified' stamp: ''! initialize self initializeTables! ! !MacRomanTextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 19:31'! languageEnvironment ^Latin1Environment! ! !MacRomanTextConverter class methodsFor: 'accessing' stamp: 'yo 8/4/2003 12:33'! encodingNames ^ #('mac-roman' ) copy ! ! !MacRomanTextConverter class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 21:41'! byteToUnicodeSpec "ByteTextConverter generateByteToUnicodeSpec: 'http://unicode.org/Public/MAPPINGS/VENDORS/APPLE/ROMAN.TXT'" ^ #( 16r00C4 16r00C5 16r00C7 16r00C9 16r00D1 16r00D6 16r00DC 16r00E1 16r00E0 16r00E2 16r00E4 16r00E3 16r00E5 16r00E7 16r00E9 16r00E8 16r00EA 16r00EB 16r00ED 16r00EC 16r00EE 16r00EF 16r00F1 16r00F3 16r00F2 16r00F4 16r00F6 16r00F5 16r00FA 16r00F9 16r00FB 16r00FC 16r2020 16r00B0 16r00A2 16r00A3 16r00A7 16r2022 16r00B6 16r00DF 16r00AE 16r00A9 16r2122 16r00B4 16r00A8 16r2260 16r00C6 16r00D8 16r221E 16r00B1 16r2264 16r2265 16r00A5 16r00B5 16r2202 16r2211 16r220F 16r03C0 16r222B 16r00AA 16r00BA 16r03A9 16r00E6 16r00F8 16r00BF 16r00A1 16r00AC 16r221A 16r0192 16r2248 16r2206 16r00AB 16r00BB 16r2026 16r00A0 16r00C0 16r00C3 16r00D5 16r0152 16r0153 16r2013 16r2014 16r201C 16r201D 16r2018 16r2019 16r00F7 16r25CA 16r00FF 16r0178 16r2044 16r20AC 16r2039 16r203A 16rFB01 16rFB02 16r2021 16r00B7 16r201A 16r201E 16r2030 16r00C2 16r00CA 16r00C1 16r00CB 16r00C8 16r00CD 16r00CE 16r00CF 16r00CC 16r00D3 16r00D4 16rF8FF 16r00D2 16r00DA 16r00DB 16r00D9 16r0131 16r02C6 16r02DC 16r00AF 16r02D8 16r02D9 16r02DA 16r00B8 16r02DD 16r02DB 16r02C7 )! ! !MacStore commentStamp: ''! I'm a specific store for OSX file systems! !MacStore methodsFor: 'public' stamp: 'CamilloBruni 5/9/2012 13:11'! mimeTypesAt: aPath "Return a list of MIME types applicable to the receiver. This default implementation uses the file name extension to figure out what we're looking at but specific subclasses may use other means of figuring out what the type of some file is. Some systems like the macintosh use meta data on the file to indicate data type" "| typeCreator type | typeCreator := self getMacFileTypeAndCreator: ((self fullNameFor: fileName)). type := (typeCreator at: 1) asLowercase. ^TypeToMimeMappings at: type ifAbsent:[super mimeTypesFor: fileName]" self flag: 'TODO: properly implement the mac os version'. ^ super mimeTypesAt: aPath! ! !MacStore class methodsFor: 'current' stamp: 'CamilloBruni 5/10/2012 15:43'! isActiveClass ^ Smalltalk os isMacOS! ! !Magnitude commentStamp: 'sd 9/4/2005 10:14'! I'm the abstract class Magnitude that provides common protocol for objects that have the ability to be compared along a linear dimension, such as dates or times. Subclasses of Magnitude include Date, ArithmeticValue, and Time, as well as Character and LookupKey. My subclasses should implement < aMagnitude = aMagnitude hash Here are some example of my protocol: 3 > 4 5 = 6 100 max: 9 7 between: 5 and: 10 ! !Magnitude methodsFor: 'comparing' stamp: ''! min: aMin max: aMax ^ (self min: aMin) max: aMax! ! !Magnitude methodsFor: 'hash' stamp: ''! hash "Hash must be redefined whenever = is redefined." ^self subclassResponsibility! ! !Magnitude methodsFor: 'testing' stamp: ''! = aMagnitude "Compare the receiver with the argument and answer with true if the receiver is equal to the argument. Otherwise answer false." ^self subclassResponsibility! ! !Magnitude methodsFor: 'testing' stamp: ''! > aMagnitude "Answer whether the receiver is greater than the argument." ^aMagnitude < self! ! !Magnitude methodsFor: 'testing' stamp: 'nice 12/31/2008 04:06'! >= aMagnitude "Answer whether the receiver is greater than or equal to the argument." ^aMagnitude <= self! ! !Magnitude methodsFor: 'comparing' stamp: ''! min: aMagnitude "Answer the receiver or the argument, whichever has the lesser magnitude." self < aMagnitude ifTrue: [^self] ifFalse: [^aMagnitude]! ! !Magnitude methodsFor: 'testing' stamp: ''! < aMagnitude "Answer whether the receiver is less than the argument." ^self subclassResponsibility! ! !Magnitude methodsFor: 'comparing' stamp: ''! max: aMagnitude "Answer the receiver or the argument, whichever has the greater magnitude." self > aMagnitude ifTrue: [^self] ifFalse: [^aMagnitude]! ! !Magnitude methodsFor: 'testing' stamp: ''! between: min and: max "Answer whether the receiver is less than or equal to the argument, max, and greater than or equal to the argument, min." ^self >= min and: [self <= max]! ! !Magnitude methodsFor: 'comparing' stamp: 'BenjaminVanRyseghem 6/10/2013 17:49'! compareWith: anotherMagnitude ifLesser: lesserBlock ifEqual: equalBlock ifGreater: greaterBlock self < anotherMagnitude ifTrue: lesserBlock ifFalse: [ self = anotherMagnitude ifTrue: equalBlock ifFalse: greaterBlock ]! ! !Magnitude methodsFor: 'testing' stamp: ''! <= aMagnitude "Answer whether the receiver is less than or equal to the argument." ^(self > aMagnitude) not! ! !Magnitude class methodsFor: '*Polymorph-Widgets-Themes' stamp: 'YuriyTymchuk 12/20/2013 11:18'! systemIcon ^ Smalltalk ui icons iconNamed: #magnitudeIcon! ! !MailAddressParser commentStamp: ''! Parse mail addresses. The basic syntax is: addressList := MailAddressParser addressesIn: aString This currently only returns the bare addresses, but it could also return a list of the address "source codes". For example, if you give it "Joe , ", it will currently return a list ('joe@foo' 'jane'). It would be nice to also get a list ('Joe ' '').! !MailAddressParser methodsFor: 'parsing' stamp: 'ls 10/23/1998 13:39'! grabBasicAddress "grad an address of the form a.b@c.d.e" self startNewAddress. "grab either the domain if specified, or the domain if not" self addToAddress. [tokens isEmpty not and: [ tokens last type = $.] ] whileTrue: ["add name-dot pairs of tokens" self addToAddress. (#(Atom QuotedString ) includes: tokens last type) ifFalse: [self error: 'bad token in address: ' , tokens last text]. self addToAddress]. (tokens isEmpty or: [tokens last type ~= $@]) ifTrue: ["no domain specified" self finishAddress] ifFalse: ["that was the domain. check that no QuotedString's slipped in" curAddrTokens do: [:tok | tok type = #QuotedString ifTrue: [self error: 'quote marks are not allowed within a domain name (' , tok text , ')']]. "add the @ sign" self addToAddress. "add the local part" (#(Atom QuotedString ) includes: tokens last type) ifFalse: [self error: 'invalid local part for address: ' , tokens last text]. self addToAddress. "add word-dot pairs if there are any" [tokens isEmpty not and: [tokens last type = $.]] whileTrue: [self addToAddress. (tokens isEmpty not and: [#(Atom QuotedString ) includes: tokens last type]) ifTrue: [self addToAddress]]. self finishAddress]! ! !MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:30'! finishAddress "we've finished one address. Bundle it up and add it to the list of addresses" | address | address := String streamContents: [ :str | curAddrTokens do: [ :tok | str nextPutAll: tok text ] ]. addresses addFirst: address. curAddrTokens := nil.! ! !MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:08'! grabAddressWithRoute "grad an address of the form 'Descriptive Text " self startNewAddress. tokens removeLast. "remove the >" "grab until we see a $<" [ tokens isEmpty ifTrue: [ self error: '<> are not matched' ]. tokens last type = $< ] whileFalse: [ self addToAddress ]. tokens removeLast. "remove the <" self removePhrase. self finishAddress! ! !MailAddressParser methodsFor: 'parsing' stamp: 'bf 3/12/2000 20:06'! grabAddresses "grab all the addresses in the string" | token | "remove comments" tokens removeAllSuchThat: [:t | t type == #Comment]. "grab one address or address group each time through this loop" [ "remove commas" [ tokens isEmpty not and: [ tokens last type = $, ] ] whileTrue: [ tokens removeLast ]. "check whether any tokens are left" tokens isEmpty ] whileFalse: [ token := tokens last. "delegate, depending on what form the address is in" "the from can be determined from the last token" token type = $> ifTrue: [ self grabAddressWithRoute ] ifFalse: [ (#(Atom DomainLiteral QuotedString) includes: token type) ifTrue: [ self grabBasicAddress ] ifFalse: [ token type = $; ifTrue: [ self grabGroupAddress ] ifFalse: [ ^self error: 'un-recognized address format' ] ] ] ]. ^addresses! ! !MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:08'! removePhrase "skip most characters to the left of this" [ tokens isEmpty not and: [ #(Atom QuotedString $. $@) includes: (tokens last type) ] ] whileTrue: [ tokens removeLast ]. ! ! !MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:31'! addToAddress "add the last token to the address. removes the token from the collection" curAddrTokens addFirst: (tokens removeLast)! ! !MailAddressParser methodsFor: 'initialization' stamp: 'ls 9/13/1998 01:25'! initialize: tokenList tokens := tokenList asOrderedCollection copy. addresses := OrderedCollection new.! ! !MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:07'! grabGroupAddress "grab an address of the form 'phrase : address, address, ..., address;'" "I'm not 100% sure what this format means, so I'm just returningthe list of addresses between the : and ; -ls (if this sounds right to someone, feel free to remove this comment :)" "remove the $; " tokens removeLast. "grab one address each time through this loop" [ "remove commas" [ tokens isEmpty not and: [ tokens last type = $, ] ] whileTrue: [ tokens removeLast ]. tokens isEmpty ifTrue: [ "no matching :" ^self error: 'stray ; in address list'. ]. tokens last type = $: ] whileFalse: [ "delegate to either grabAddressWithRoute, or grabBasicAddress. nested groups are not allowed" tokens last type = $> ifTrue: [ self grabAddressWithRoute ] ifFalse: [ (#(Atom DomainLiteral QuotedString) includes: tokens last type) ifTrue: [ self grabBasicAddress ] ifFalse: [ ^self error: 'un-recognized address format' ] ] ]. tokens removeLast. "remove the :" self removePhrase.! ! !MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:30'! startNewAddress "set up data structures to begin a new address" (curAddrTokens ~~ nil) ifTrue: [ self error: 'starting new address before finishing the last one!!' ]. curAddrTokens := OrderedCollection new. ! ! !MailAddressParser class methodsFor: 'parsing' stamp: 'ls 9/13/1998 01:34'! addressesIn: aString "return a collection of the bare addresses listed in aString" | tokens | tokens := MailAddressTokenizer tokensIn: aString. ^(self new initialize: tokens) grabAddresses! ! !MailAddressParserTest commentStamp: ''! This is the unit test for the class MailAddressParser. 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 - there is a chapter in the PharoByExample book (http://pharobyexample.org) - the sunit class category! !MailAddressParserTest methodsFor: 'tests' stamp: 'sd 6/5/2005 10:31'! testAddressesIn | testString correctAnswer | testString := 'joe@lama.com, joe2@lama.com joe3@lama.com joe4 , Not an Address , joe.(annoying (nested) comment)literal@[1.2.3.4], "an annoying" group : joe1@groupie, joe2@groupie, "Joey" joe3@groupy, "joe6"."joe8"@group.com;, Lex''s email account '. correctAnswer := #('joe@lama.com' 'joe2@lama.com' 'joe3@lama.com' 'joe4' 'joe5@address' 'joe.literal@[1.2.3.4]' 'joe1@groupie' 'joe2@groupie' '"Joey"' 'joe3@groupy' '"joe6"."joe8"@group.com' 'lex') asOrderedCollection. self assert: ((MailAddressParser addressesIn: testString) = correctAnswer).! ! !MailAddressToken commentStamp: ''! a single token from an RFC822 mail address. Used internally in MailAddressParser! !MailAddressToken methodsFor: 'access' stamp: 'ls 9/12/1998 20:42'! type ^type! ! !MailAddressToken methodsFor: 'private' stamp: 'ls 9/12/1998 20:24'! type: type0 text: text0 type := type0. text := text0.! ! !MailAddressToken methodsFor: 'printing' stamp: 'ls 9/12/1998 20:40'! printOn: aStream aStream nextPut: $[. aStream nextPutAll: self type asString. aStream nextPut: $|. aStream nextPutAll: self text. aStream nextPut: $].! ! !MailAddressToken methodsFor: 'access' stamp: 'ls 9/12/1998 20:42'! text ^text! ! !MailAddressToken class methodsFor: 'instance creation' stamp: 'ls 9/12/1998 20:31'! type: type text: text ^self new type: type text: text! ! !MailAddressTokenizer commentStamp: ''! Divides an address into tokens, as specified in RFC 822. Used by MailAddressParser.! !MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:53'! atEnd ^self peek == nil! ! !MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:51'! next | ans | cachedToken ifNil: [ ^self nextToken ]. ans := cachedToken. cachedToken := nil. ^ans! ! !MailAddressTokenizer methodsFor: 'initialization' stamp: 'ls 9/12/1998 20:13'! initialize: aString text := aString. pos := 1.! ! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:44'! nextSpecial | c | c := self nextChar. ^MailAddressToken type: c text: c asString.! ! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'bf 3/12/2000 19:53'! nextToken | c | self skipSeparators. c := self peekChar. c ifNil: [ ^nil ]. c = $( ifTrue: [ ^self nextComment ]. c = $" ifTrue: [ ^self nextQuotedString ]. c = $[ ifTrue: [ ^self nextDomainLiteral ]. (CSSpecials includes: c) ifTrue: [ ^self nextSpecial ]. ^self nextAtom! ! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:15'! peekChar ^text at: pos ifAbsent: [ nil ]! ! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'MarcusDenker 10/9/2013 16:32'! nextComment | start nestLevel paren | start := pos. pos := pos + 1. nestLevel := 1. [ nestLevel > 0 ] whileTrue: [ pos := text indexOfAnyOf: CSParens startingAt: pos ifAbsent: [ 0 ]. pos = 0 ifTrue: [ self error: 'unterminated comment. ie, more (''s than )''s' ]. paren := self nextChar. nestLevel := paren = $( ifTrue: [ nestLevel + 1 ] ifFalse: [ nestLevel - 1 ] ]. ^ MailAddressToken type: #Comment text: (text copyFrom: start to: pos - 1)! ! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:14'! skipSeparators pos := text indexOfAnyOf: CSNonSeparators startingAt: pos ifAbsent: [ text size + 1 ].! ! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:52'! nextChar self atEndOfChars ifTrue: [ ^nil ]. pos := pos + 1. ^text at: (pos-1)! ! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/13/1998 01:39'! nextDomainLiteral | start end | start := pos. end := text indexOf: $] startingAt: start ifAbsent: [ 0 ]. end = 0 ifTrue: [ "not specified" self error: 'saw [ without a matching ]' ]. pos := end+1. ^MailAddressToken type: #DomainLiteral text: (text copyFrom: start to: end)! ! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'PeterHugossonMiller 9/3/2009 10:02'! nextQuotedString | res c | res := String new writeStream. res nextPut: self nextChar. "record the starting quote" [ self atEndOfChars ] whileFalse: [ c := self nextChar. c = $\ ifTrue: [ res nextPut: c. res nextPut: self nextChar ] ifFalse: [ c = $" ifTrue: [ res nextPut: c. ^MailAddressToken type: #QuotedString text: res contents ] ifFalse: [ res nextPut: c ] ] ]. "hmm, never saw the final quote mark" ^MailAddressToken type: #QuotedString text: (res contents, '"')! ! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:51'! atEndOfChars ^pos > text size! ! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:44'! nextAtom | start end | start := pos. pos := text indexOfAnyOf: CSNonAtom startingAt: start ifAbsent: [ text size + 1]. end := pos - 1. ^MailAddressToken type: #Atom text: (text copyFrom: start to: end)! ! !MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:53'! peek cachedToken ifNil: [ cachedToken := self nextToken. ]. ^cachedToken ! ! !MailAddressTokenizer class methodsFor: 'initialization' stamp: 'stephane.ducasse 7/3/2009 21:34'! initialize "Initalize class variables using MailAddressTokenizer initialize" | atomChars | CSParens := CharacterSet empty. CSParens addAll: '()'. CSSpecials := CharacterSet empty. CSSpecials addAll: '()<>@,;:\".[]'. CSNonSeparators := CharacterSet separators complement. "(from RFC 2822)" atomChars := CharacterSet empty. atomChars addAll: ($A to: $Z). atomChars addAll: ($a to: $z). atomChars addAll: ($0 to: $9). atomChars addAll: '!!#$%^''*+-/=?^_`{|}~'. CSNonAtom := atomChars complement.! ! !MailAddressTokenizer class methodsFor: 'instance creation' stamp: 'MarcusDenker 10/9/2013 16:35'! forString: aString ^self basicNew initialize: aString! ! !MailAddressTokenizer class methodsFor: 'instance creation' stamp: 'ls 9/13/1998 01:34'! tokensIn: aString "return a collection of the tokens in aString" ^(self forString: aString) upToEnd! ! !MailComposition commentStamp: ''! a message being composed. When finished, it will be submitted via a Celeste.! !MailComposition methodsFor: 'private' stamp: 'nice 1/5/2010 15:59'! breakLines: aString atWidth: width "break lines in the given string into shorter lines" | result atAttachment | result := (String new: (aString size * 50 // 49)) writeStream. atAttachment := false. aString asString linesDo: [ :line | | start end | (line beginsWith: '====') ifTrue: [ atAttachment := true ]. atAttachment ifTrue: [ "at or after an attachment line; no more wrapping for the rest of the message" result nextPutAll: line. result cr ] ifFalse: [ (line beginsWith: '>') ifTrue: [ "it's quoted text; don't wrap it" result nextPutAll: line. result cr. ] ifFalse: [ "regular old line. Wrap it to multiple lines" start := 1. "output one shorter line each time through this loop" [ start + width <= line size ] whileTrue: [ "find the end of the line" end := start + width - 1. [end >= start and: [ (line at: (end+1)) isSeparator not ]] whileTrue: [ end := end - 1 ]. end < start ifTrue: [ "a word spans the entire width!!" end := start + width - 1 ]. "copy the line to the output" result nextPutAll: (line copyFrom: start to: end). result cr. "get ready for next iteration" start := end+1. (line at: start) isSeparator ifTrue: [ start := start + 1 ]. ]. "write out the final part of the line" result nextPutAll: (line copyFrom: start to: line size). result cr. ]. ]. ]. ^result contents! ! !MailComposition methodsFor: 'access' stamp: 'MarcusDenker 12/16/2013 14:44'! smtpServer ^self class smtpServer! ! !MailComposition methodsFor: 'interface' stamp: 'dvf 5/11/2002 01:23'! sendMailMessage: aMailMessage self messageText: aMailMessage text! ! !MailComposition methodsFor: 'interface' stamp: 'abc 5/11/2012 13:28'! addAttachment | fileSelected| textEditor ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]]. fileSelected := UIManager default chooseFileMatching: nil. fileSelected ifNil: [^ self]. fileSelected writeStreamDo: [ :stream| stream binary. self messageText: ((MailMessage from: self messageText asString) addAttachmentFrom: stream withName: fileSelected basename; text)] ! ! !MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:47'! messageText: aText "change the current text" messageText := aText. self changed: #messageText. ^true! ! !MailComposition methodsFor: 'interface' stamp: 'alain.plantec 5/30/2008 13:43'! open "open an interface" self openInMorphic ! ! !MailComposition methodsFor: 'access' stamp: 'alain.plantec 6/19/2008 09:45'! submit | message | "submit the message" textEditor ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]]. message := MailMessage from: messageText asString. self breakLinesInMessage: message. SMTPClient deliverMailFrom: message from to: (Array with: message to) text: message text usingServer: self smtpServer. morphicWindow ifNotNil: [morphicWindow delete]. ! ! !MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:06'! messageText "return the current text" ^messageText. ! ! !MailComposition methodsFor: 'interface' stamp: 'alain.plantec 6/10/2008 22:30'! openInMorphic "open an interface for sending a mail message with the given initial text" | textMorph buttonsList sendButton attachmentButton | morphicWindow := SystemWindow labelled: 'Mister Postman'. morphicWindow model: self. textEditor := textMorph := PluggableTextMorph on: self text: #messageText accept: #messageText: readSelection: nil menu: #menuGet:shifted:. morphicWindow addMorph: textMorph frame: (0 @ 0.1 corner: 1 @ 1). buttonsList := AlignmentMorph newRow. sendButton := PluggableButtonMorph on: self getState: nil action: #submit. sendButton hResizing: #spaceFill; vResizing: #spaceFill; label: 'send message'; setBalloonText: 'Accept any unaccepted edits and add this to the queue of messages to be sent'; onColor: Color white offColor: Color white. buttonsList addMorphBack: sendButton. attachmentButton := PluggableButtonMorph on: self getState: nil action: #addAttachment. attachmentButton hResizing: #spaceFill; vResizing: #spaceFill; label: 'add attachment'; setBalloonText: 'Send a file with the message'; onColor: Color white offColor: Color white. buttonsList addMorphBack: attachmentButton. morphicWindow addMorph: buttonsList frame: (0 @ 0 extent: 1 @ 0.1). morphicWindow openInWorld! ! !MailComposition methodsFor: 'private' stamp: 'ls 2/10/2001 14:08'! breakLinesInMessage: message "reformat long lines in the specified message into shorter ones" message body mainType = 'text' ifTrue: [ "it's a single-part text message. reformat the text" | newBodyText | newBodyText := self breakLines: message bodyText atWidth: 72. message body: (MIMEDocument contentType: message body contentType content: newBodyText). ^self ]. message body isMultipart ifTrue: [ "multipart message; process the top-level parts. HACK: the parts are modified in place" message parts do: [ :part | part body mainType = 'text' ifTrue: [ | newBodyText | newBodyText := self breakLines: part bodyText atWidth: 72. part body: (MIMEDocument contentType: part body contentType content: newBodyText) ] ]. message regenerateBodyFromParts. ].! ! !MailComposition methodsFor: 'interface' stamp: 'tbn 7/29/2010 22:08'! menuGet: aMenu shifted: shifted aMenu addList: { {'Find...(f)' translated. #find}. {'Find again (g)' translated. #findAgain}. {'Set search string (h)' translated. #setSearchString}. #-. {'Accept (s)' translated. #accept}. {'Send message' translated. #submit}}. ^aMenu.! ! !MailComposition class methodsFor: 'smtp server' stamp: 'MarcusDenker 12/16/2013 14:43'! setSmtpServer "Set the SMTP server used to send outgoing messages via" SmtpServer ifNil: [SmtpServer := '']. SmtpServer := UIManager default request: 'What is your mail server for outgoing mail?' initialAnswer: SmtpServer. ! ! !MailComposition class methodsFor: 'smtp server' stamp: 'MarcusDenker 12/16/2013 14:43'! setSmtpServer: aString SmtpServer := aString! ! !MailComposition class methodsFor: 'smtp server' stamp: 'MarcusDenker 12/16/2013 14:43'! smtpServer "Answer the server for sending email" self isSmtpServerSet ifFalse: [self setSmtpServer]. SmtpServer isEmpty ifTrue: [ self error: 'no SMTP server specified' ]. ^SmtpServer! ! !MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 01:25'! sendMailMessage: aMailMessage | newComposition | newComposition := self new. newComposition messageText: aMailMessage text; open! ! !MailComposition class methodsFor: 'smtp server' stamp: 'MarcusDenker 12/16/2013 14:43'! isSmtpServerSet ^ SmtpServer notNil and: [SmtpServer notEmpty] ! ! !MailMessage commentStamp: ''! I represent an Internet mail or news message. text - the raw text of my message body - the body of my message, as a MIMEDocument fields - a dictionary mapping lowercased field names into collections of MIMEHeaderValue's parts - if I am a multipart message, then this is a cache of my parts! !MailMessage methodsFor: 'multipart' stamp: 'ls 3/18/2001 16:26'! decoderClass | encoding | encoding := self fieldNamed: 'content-transfer-encoding' ifAbsent: [^ nil]. encoding := encoding mainValue. encoding asLowercase = 'base64' ifTrue: [^ Base64MimeConverter]. encoding asLowercase = 'quoted-printable' ifTrue: [^ QuotedPrintableMimeConverter]. ^ nil! ! !MailMessage methodsFor: 'parsing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:45'! reportField: aString to: aBlock "Evaluate the given block with the field name a value in the given field. Do nothing if the field is malformed." | s fieldName fieldValue | (aString includes: $:) ifFalse: [ ^ self ]. s := aString readStream. fieldName := (s upTo: $:) asLowercase. "fieldname must be lowercase" fieldValue := s upToEnd trimBoth. fieldValue isEmpty ifFalse: [ aBlock value: fieldName value: fieldValue ]! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'bkv 6/23/2003 14:17'! regenerateBodyFromParts "regenerate the message body from the multiple parts" | bodyText | bodyText := String streamContents: [ :str | str cr. parts do: [ :part | str cr; nextPutAll: '--'; nextPutAll: self attachmentSeparator; cr; nextPutAll: part text ]. str cr; nextPutAll: '--'; nextPutAll: self attachmentSeparator; nextPutAll: '--'; cr ]. body := MIMEDocument contentType: 'multipart/mixed' content: bodyText. text := nil. "text needs to be reformatted"! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'sbw 1/21/2001 19:47'! viewBody "open a viewer on the body of this message" self containsViewableImage ifTrue: [^ self viewImageInBody]. (StringHolder new contents: self bodyTextFormatted; yourself) openLabel: (self name ifNil: ['(a message part)'])! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 5/7/2001 11:22'! atomicParts "Answer all of the leaf parts of this message, including those of multipart included messages" self body isMultipart ifFalse: [^ OrderedCollection with: self]. ^ self parts inject: OrderedCollection new into: [:col :part | col , part atomicParts]! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 3/18/2001 16:24'! subject ^(self fieldNamed: 'subject' ifAbsent: [ ^'' ]) mainValue! ! !MailMessage methodsFor: 'parsing' stamp: 'CamilloBruni 8/22/2013 19:46'! readDateFrom: aStream "Parse a date from the given stream and answer nil if the date can't be parsed. The date may be in any of the following forms: (5 April 1982; 5-APR-82) (April 5, 1982) (4/5/82) In addition, the date may be preceded by the day of the week and an optional comma, such as: Tue, November 14, 1989" | day month year | self skipWeekdayName: aStream. aStream peek isDigit ifTrue: [day := Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. aStream peek isLetter ifTrue: "month name or weekday name" [month := (String new: 10) writeStream. [aStream peek isLetter] whileTrue: [month nextPut: aStream next]. month := month contents. day ifNil: "name/number..." [[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. (aStream peek isDigit) ifFalse: [^nil]. day := Integer readFrom: aStream]] ifFalse: "number/number..." [month := Date nameOfMonth: day. day := Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. (aStream peek isDigit) ifFalse: [^nil]. year := Integer readFrom: aStream. ^Date year: year month: month day: day! ! !MailMessage methodsFor: 'multipart' stamp: 'TonyFleig 11/28/2010 12:55'! addPart: bodyString contentType: aContentTypeString | newPart | newPart := MailMessage empty. newPart setField: 'content-type' toString: aContentTypeString. newPart body: (MIMEDocument contentType: aContentTypeString content: bodyString). self addPart: newPart. ! ! !MailMessage methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:06'! initialize "initialize as an empty message" super initialize. text := String cr. fields := Dictionary new. body := MIMEDocument contentType: 'text/plain' content: String cr! ! !MailMessage methodsFor: 'multipart' stamp: 'TonyFleig 11/28/2010 12:55'! addMixedPart: bodyString contentType: aContentTypeString | newPart | newPart := MailMessage empty. newPart setField: 'content-type' toString: aContentTypeString. newPart body: (MIMEDocument contentType: aContentTypeString content: bodyString). self addMixedPart: newPart. ! ! !MailMessage methodsFor: 'multipart' stamp: 'TonyFleig 11/28/2010 12:54'! addAlternativePart: newPart self makeMultipart: 'alternative' with: newPart. ! ! !MailMessage methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 6/28/2010 12:22'! time | dateField | dateField := (self fieldNamed: 'date' ifAbsent: [ ^0 ]) mainValue. ^ [self timeFrom: dateField] ifError: [Date today asSeconds]. ! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'nice 1/5/2010 15:59'! asSendableText "break lines in the given string into shorter lines" | result atAttachment width aString pastHeader | width := 72. aString := self text. result := (String new: aString size * 50 // 49) writeStream. pastHeader := false. atAttachment := false. aString asString linesDo: [:line | | end start | line isEmpty ifTrue: [pastHeader := true]. pastHeader ifTrue: ["(line beginsWith: '--==') ifTrue: [atAttachment := true]." atAttachment ifTrue: ["at or after an attachment line; no more wrapping for the rest of the message" result nextPutAll: line. result cr] ifFalse: [(line beginsWith: '>') ifTrue: ["it's quoted text; don't wrap it" result nextPutAll: line. result cr] ifFalse: ["regular old line. Wrap it to multiple lines " start := 1. "output one shorter line each time through this loop" [start + width <= line size] whileTrue: ["find the end of the line" end := start + width - 1. [end >= start and: [(line at: end + 1) isSeparator not]] whileTrue: [end := end - 1]. end < start ifTrue: ["a word spans the entire width!! " end := start + width - 1]. "copy the line to the output" result nextPutAll: (line copyFrom: start to: end). result cr. "get ready for next iteration" start := end + 1. (line at: start) isSeparator ifTrue: [start := start + 1]]. "write out the final part of the line" result nextPutAll: (line copyFrom: start to: line size). result cr]]] ifFalse: [result nextPutAll: line. result cr]]. ^ result contents! ! !MailMessage methodsFor: 'sending' stamp: 'SeanDeNigris 12/2/2011 12:02'! sendOn: serverString SMTPClient deliver: self usingServer: serverString.! ! !MailMessage methodsFor: 'multipart' stamp: 'TonyFleig 11/28/2010 12:54'! addAlternativePart: bodyString contentType: aContentTypeString | newPart | newPart := MailMessage empty. newPart setField: 'content-type' toString: aContentTypeString. newPart body: (MIMEDocument contentType: aContentTypeString content: bodyString). self addAlternativePart: newPart. ! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 3/18/2001 16:27'! fields "return the internal fields structure. This is private and subject to change!!" ^ fields! ! !MailMessage methodsFor: 'parsing' stamp: 'damiencassou 5/30/2008 15:52'! headerFieldsNamed: fieldName do: aBlock "Evalue aBlock once for each header field which matches fieldName. The block is valued with one parameter, the value of the field" self fieldsFrom: text readStream do: [ :fName :fValue | (fieldName sameAs: fName) ifTrue: [ aBlock value: fValue ] ]! ! !MailMessage methodsFor: 'accessing' stamp: 'mdr 3/21/2001 15:28'! from ^(self fieldNamed: 'from' ifAbsent: [ ^'' ]) mainValue! ! !MailMessage methodsFor: 'parsing' stamp: 'CamilloBruni 8/22/2013 19:50'! timeFrom: aString "Parse the date and time (rfc822) and answer the result as the number of seconds since the start of 1980." | s t rawDelta delta plusOrMinus | s := aString readStream. "date part" t := ((self readDateFrom: s) ifNil: [ Date today ]) asSeconds. [ s atEnd or: [ s peek isAlphaNumeric ] ] whileFalse: [ s next ]. "time part" s atEnd ifFalse: [ "read time part (interpreted as local, regardless of sender's timezone)" s peek isDigit ifTrue: [ t := t + (Time readFrom: s) asSeconds ] ]. s skipSeparators. "Check for a numeric time zone offset" ('+-' includes: s peek) ifTrue: [ plusOrMinus := s next. rawDelta := s peek isDigit ifTrue: [ Integer readFrom: s ] ifFalse: [ 0 ]. delta := (rawDelta // 100 * 60 + (rawDelta \\ 100)) * 60. t := plusOrMinus = $+ ifTrue: [ t - delta ] ifFalse: [ t + delta ] ]. "We ignore text time zone offsets like EST, GMT, etc..." ^ t - (Date year: 1980 day: 1) asSeconds "MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 -500'" "MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 --500'" "MailMessage new timeFrom: 'on, 04 apr 2001 14:57:32'"! ! !MailMessage methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 1/8/2012 15:24'! from: aString "Parse aString to initialize myself." | parseStream contentType bodyText contentTransferEncoding | text := aString trimRight, String cr. parseStream := text readStream. contentType := 'text/plain'. contentTransferEncoding := nil. fields := Dictionary new. "Extract information out of the header fields" self fieldsFrom: parseStream do: [ :fName :fValue | "NB: fName is all lowercase" fName = 'content-type' ifTrue: [ contentType := (fValue copyUpTo: $;) asLowercase ]. fName = 'content-transfer-encoding' ifTrue: [ contentTransferEncoding := fValue asLowercase ]. (fields at: fName ifAbsentPut: [ OrderedCollection new: 1 ]) add: (MIMEHeaderValue forField: fName fromString: fValue) ]. "Extract the body of the message" bodyText := parseStream upToEnd. contentTransferEncoding = 'base64' ifTrue: [ bodyText := Base64MimeConverter mimeDecodeToChars: bodyText readStream. bodyText := bodyText contents ]. contentTransferEncoding = 'quoted-printable' ifTrue: [ bodyText := bodyText decodeQuotedPrintable ]. body := MIMEDocument contentType: contentType content: bodyText! ! !MailMessage methodsFor: 'initialization' stamp: 'mdr 4/11/2001 11:59'! setField: fieldName toString: fieldValue ^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! ! !MailMessage methodsFor: 'multipart' stamp: 'TonyFleig 11/28/2010 12:55'! makeMultipart: subType with: newPart "if I am not multipart already, then become a multipart message with one part" | multipartHeader | body isMultipart ifFalse: [ parts := Array with: newPart. "fix up our header" multipartHeader := MIMEHeaderValue fromMIMEHeader: 'multipart/',subType. multipartHeader parameterAt: 'boundary' put: self class generateSeparator . self setField: 'content-type' to: multipartHeader. self setField: 'mime-version' to: (MIMEHeaderValue fromMIMEHeader: '1.0'). self removeFieldNamed: 'content-transfer-encoding'] ifTrue: [ self parts. parts := parts copyWith: newPart. ]. "regenerate everything" self regenerateBodyFromParts. text := nil.! ! !MailMessage methodsFor: 'multipart' stamp: 'SvenVanCaekenberghe 1/8/2012 15:24'! parseParts "private -- parse the parts of the message and store them into a collection" "If this is not multipart, store an empty collection" | parseStream msgStream messages separator | self body isMultipart ifFalse: [ parts := #(). ^ self ]. "If we can't find a valid separator, handle it as if the message is not multipart" separator := self attachmentSeparator. separator ifNil: [ Transcript show: 'Ignoring bad attachment separater'; cr. parts := #(). ^ self ]. separator := '--' , separator trimRight. parseStream := self bodyText readStream. msgStream := LimitingLineStreamWrapper on: parseStream delimiter: separator. msgStream limitingBlock: [ :aLine | aLine trimRight = separator or: [ "Match the separator" aLine trimRight = (separator , '--') ] ]. "or the final separator with --" "Throw away everything up to and including the first separator" msgStream upToEnd. msgStream skipThisLine. "Extract each of the multi-parts as strings" messages := OrderedCollection new. [ parseStream atEnd ] whileFalse: [ messages add: msgStream upToEnd. msgStream skipThisLine ]. parts := messages collect: [ :e | MailMessage from: e ]! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'mdr 5/7/2001 11:07'! excerpt "Return a short excerpt of the text of the message" ^ self bodyText withSeparatorsCompacted truncateWithElipsisTo: 60! ! !MailMessage methodsFor: 'printing/formatting' stamp: ''! format "Replace the text of this message with a formatted version." "NOTE: This operation discards extra header fields." text := self formattedText.! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 3/22/2001 09:06'! attachmentSeparator ^(self fieldNamed: 'content-type' ifAbsent: [^nil]) parameters at: 'boundary' ifAbsent: [^nil]! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:36'! fieldsNamed: aString separatedBy: separationString "return all fields with the specified name, concatenated together with separationString between each element. Return an empty string if no fields with the specified name are present" | matchingFields | matchingFields := self fieldsNamed: aString ifAbsent: [ ^'' ]. ^String streamContents: [ :str | matchingFields do: [ :field | str nextPutAll: field mainValue ] separatedBy: [ str nextPutAll: separationString ]]. ! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:28'! hasFieldNamed: aString ^fields includesKey: aString asLowercase! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 3/18/2001 16:26'! name "return a default name for this part, if any was specified. If not, return nil" | type nameField disposition | "try in the content-type: header" type := self fieldNamed: 'content-type' ifAbsent: [nil]. (type notNil and: [(nameField := type parameters at: 'name' ifAbsent: [nil]) notNil]) ifTrue: [^ nameField]. "try in content-disposition:" disposition := self fieldNamed: 'content-disposition' ifAbsent: [nil]. (disposition notNil and: [(nameField := disposition parameters at: 'filename' ifAbsent: [nil]) notNil]) ifTrue: [^ nameField]. "give up" ^ nil! ! !MailMessage methodsFor: 'initialization' stamp: 'ls 2/10/2001 12:48'! body: newBody "change the body" body := newBody. text := nil.! ! !MailMessage methodsFor: 'multipart' stamp: 'TonyFleig 11/28/2010 12:55'! addMixedPart: newPart self makeMultipart: 'mixed' with: newPart. ! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'ls 4/30/2000 18:52'! formattedText "Answer a version of my text suitable for display. This cleans up the header, decodes HTML, and things like that" ^ self cleanedHeader asText, String cr , self bodyTextFormatted! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 2/10/2001 12:49'! text "the full, unprocessed text of the message" text ifNil: [ self regenerateText ]. ^text! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'nk 6/12/2004 09:36'! viewImageInBody | stream image | stream := self body contentStream. image := Form fromBinaryStream: stream. (World drawingClass withForm: image) openInWorld! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 4/11/2001 12:06'! makeMultipart "if I am not multipart already, then become a multipart message with one part" | part multipartHeader | body isMultipart ifTrue: [ ^self ]. "set up the new message part" part := MailMessage empty. part body: body. (self hasFieldNamed: 'content-type') ifTrue: [ part setField: 'content-type' to: (self fieldNamed: 'content-type' ifAbsent: ['']) ]. parts := Array with: part. "fix up our header" multipartHeader := MIMEHeaderValue fromMIMEHeader: 'multipart/mixed'. multipartHeader parameterAt: 'boundary' put: self class generateSeparator . self setField: 'content-type' to: multipartHeader. self setField: 'mime-version' to: (MIMEHeaderValue fromMIMEHeader: '1.0'). self removeFieldNamed: 'content-transfer-encoding'. "regenerate everything" self regenerateBodyFromParts. text := nil.! ! !MailMessage methodsFor: 'parsing' stamp: 'HenrikSperreJohansen 6/12/2010 02:38'! readStringLineFrom: aStream "Read and answer the next line from the given stream. Consume the carriage return but do not append it to the string." ^aStream nextLine! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:32'! fieldNamed: aString ifAbsent: aBlock | matchingFields | "return the value of the field with the specified name. If there is more than one field, then return the first one" matchingFields := fields at: aString asLowercase ifAbsent: [ ^aBlock value ]. ^matchingFields first! ! !MailMessage methodsFor: 'printing' stamp: 'ls 11/11/2001 13:27'! printOn: aStream "For text parts with no filename show: 'text/plain: first line of text...' for attachments/filenamed parts show: 'attachment: filename.ext'" | name | aStream nextPutAll: ((name := self name) ifNil: ['Text: ' , self excerpt] ifNotNil: ['File: ' , name])! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 4/11/2001 12:04'! addAttachmentFrom: aStream withName: aName "add an attachment, encoding with base64. aName is the option filename to encode" | newPart | self makeMultipart. self parts. "make sure parts have been parsed" "create the attachment as a MailMessage" newPart := MailMessage empty. newPart setField: 'content-type' toString: 'application/octet-stream'. newPart setField: 'content-transfer-encoding' toString: 'base64'. aName ifNotNil: [ | dispositionField | dispositionField := MIMEHeaderValue fromMIMEHeader: 'attachment'. dispositionField parameterAt: 'filename' put: aName. newPart setField: 'content-disposition' to: dispositionField ]. newPart body: (MIMEDocument contentType: 'application/octet-stream' content: aStream upToEnd). "regenerate our text" parts := parts copyWith: newPart. self regenerateBodyFromParts. text := nil.! ! !MailMessage methodsFor: 'testing' stamp: 'kfr 11/5/2004 17:32'! containsViewableImage ^self body isJpeg | self body isGif | self body isPng! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:21'! fieldsNamed: aString ifAbsent: aBlock "return a list of all fields with the given name" ^fields at: aString asLowercase ifAbsent: aBlock! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'lr 3/14/2010 21:13'! bodyTextFormatted "Answer a version of the text in my body suitable for display. This will parse multipart forms, decode HTML, and other such things" "check for multipart" self body isMultipart ifTrue: [ "check for alternative forms" self body isMultipartAlternative ifTrue: [ "it's multipart/alternative. search for a part that we can display, biasing towards nicer formats" #('text/html' 'text/plain') do: [ :format | self parts do: [ :part | part body contentType = format ifTrue: [ ^ part bodyTextFormatted ] ] ]. "couldn't find a desirable part to display; just display the first part" ^ self parts first bodyTextFormatted ]. "not alternative parts. put something for each part" ^ Text streamContents: [ :str | self parts do: [ :part | ((#('text' 'multipart') includes: part body mainType) or: [ part body contentType = 'message/rfc822' ]) ifTrue: [ "try to inline the message part" str nextPutAll: part bodyTextFormatted ] ifFalse: [ | descript | str cr. descript := part name ifNil: [ 'attachment' ]. str nextPutAll: (Text string: '[' , descript , ']' attribute: (TextMessageLink message: part)) ] ] ] ]. "check for HTML" self body contentType = 'text/html' ifTrue: [ Smalltalk globals at: #HtmlParser ifPresent: [ :htmlParser | ^ (htmlParser parse: body content readStream) formattedText ] ]. "check for an embedded message" self body contentType = 'message/rfc822' ifTrue: [ ^ (MailMessage from: self body content) formattedText ]. "nothing special--just return the text" ^ body content! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 3/18/2001 16:34'! cc ^self fieldsNamed: 'cc' separatedBy: ', '! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 3/18/2001 16:35'! to ^self fieldsNamed: 'to' separatedBy: ', '! ! !MailMessage methodsFor: 'initialization' stamp: 'ls 3/18/2001 16:20'! setField: fieldName to: aFieldValue "set a field. If any field of the specified name exists, it will be overwritten" fields at: fieldName asLowercase put: (OrderedCollection with: aFieldValue). text := nil.! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'PeterHugossonMiller 9/3/2009 10:03'! cleanedHeader "Reply with a cleaned up version email header. First show fields people would normally want to see (in a regular order for easy browsing), and then any other fields not explictly excluded" | new priorityFields omittedFields | new := (String new: text size) writeStream. priorityFields := #('Date' 'From' 'Subject' 'To' 'Cc' ). omittedFields := MailMessage omittedHeaderFields. "Show the priority fields first, in the order given in priorityFields" priorityFields do: [ :pField | "We don't check whether the priority field is in the omitted list!!" self headerFieldsNamed: pField do: [ :fValue | new nextPutAll: pField , ': ' , fValue decodeMimeHeader; cr ] ]. "Show the rest of the fields, omitting the uninteresting ones and ones we have already shown" omittedFields := omittedFields , priorityFields. self fieldsFrom: text readStream do: [ :fName :fValue | ((fName beginsWith: 'x-') or: [ omittedFields anySatisfy: [ :omitted | fName sameAs: omitted ] ]) ifFalse: [ new nextPutAll: fName , ': ' , fValue; cr ] ]. ^ new contents! ! !MailMessage methodsFor: 'parsing' stamp: 'PeterHugossonMiller 9/3/2009 10:03'! skipWeekdayName: aStream "If the given stream starts with a weekday name or its abbreviation, advance the stream to the first alphaNumeric character following the weekday name." | position name abbrev | aStream skipSeparators. (aStream peek isDigit) ifTrue: [^self]. (aStream peek isLetter) ifTrue: [position := aStream position. name := (String new: 10) writeStream. [aStream peek isLetter] whileTrue: [name nextPut: aStream next]. abbrev := (name contents copyFrom: 1 to: (3 min: name position)). abbrev := abbrev asLowercase. (#('sun' 'mon' 'tue' 'wed' 'thu' 'fri' 'sat') includes: abbrev asLowercase) ifTrue: ["found a weekday; skip to the next alphanumeric character" [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]] ifFalse: ["didn't find a weekday so restore stream position" aStream position: position]].! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'nice 1/5/2010 15:59'! regenerateText "regenerate the full text from the body and headers" text := String streamContents: [ :str | | encodedBodyText | "first put the header" fields keysAndValuesDo: [ :fieldName :fieldValues | fieldValues do: [ :fieldValue | str nextPutAll: fieldName capitalized; nextPutAll: ': '; nextPutAll: fieldValue asHeaderValue; cr ] ]. "skip a line between header and body" str cr. "put the body, being sure to encode it according to the header" encodedBodyText := body content. self decoderClass ifNotNil: [ encodedBodyText := (self decoderClass mimeEncode: encodedBodyText readStream) upToEnd ]. str nextPutAll: encodedBodyText ]! ! !MailMessage methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 15:17'! recipientList ^ (self to findTokens: $,) collect: [ :e | e trimLeft ]! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 1/3/1999 15:48'! body "return just the body of the message" ^body! ! !MailMessage methodsFor: 'multipart' stamp: 'ls 4/30/2000 18:22'! parts parts ifNil: [self parseParts]. ^ parts! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:30'! removeFieldNamed: name "remove all fields with the specified name" fields removeKey: name ifAbsent: []! ! !MailMessage methodsFor: 'accessing' stamp: 'CamilloBruni 8/22/2013 19:50'! date "Answer a date string for this message." ^(Date fromSeconds: self time + (Date year: 1980 day: 1 ) asSeconds) printFormat: #(2 1 3 47 1 2)! ! !MailMessage methodsFor: 'multipart' stamp: 'JB 2/12/2010 15:27'! save "save the part to a file" | fileName file | fileName := self name ifNil: ['attachment' , MailMessage dateTimeSuffix]. (fileName includes: $.) ifFalse: [ #(isJpeg 'jpg' isGif 'gif' isPng 'png' isPnm 'pnm') pairsDo: [ :s :e | (self body perform: s) ifTrue: [fileName := fileName, '.', e] ] ]. fileName := UIManager default request: 'File name for save?' initialAnswer: fileName. fileName isEmptyOrNil ifTrue: [^ nil]. file := FileStream newFileNamed: fileName. file nextPutAll: self bodyText. file close! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 1/3/1999 15:52'! bodyText "return the text of the body of the message" ^body content! ! !MailMessage methodsFor: 'parsing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:45'! fieldsFrom: aStream do: aBlock "Invoke the given block with each of the header fields from the given stream. The block arguments are the field name and value. The streams position is left right after the empty line separating header and body." | savedLine line s | savedLine := self readStringLineFrom: aStream. [ aStream atEnd ] whileFalse: [ line := savedLine. line isEmpty ifTrue: [ ^ self ]. "quit when we hit a blank line" [ savedLine := self readStringLineFrom: aStream. savedLine size > 0 and: [ savedLine first isSeparator ] ] whileTrue: [ "lines starting with white space are continuation lines" s := savedLine readStream. s skipSeparators. line := line , ' ' , s upToEnd ]. self reportField: line trimBoth to: aBlock ]. "process final header line of a body-less message" savedLine isEmpty ifFalse: [ self reportField: savedLine trimBoth to: aBlock ]! ! !MailMessage class methodsFor: 'utilities' stamp: 'SeanDeNigris 12/3/2011 13:36'! dateStampNow "Return the current date and time formatted per RFC5322 e.g. 'Thu, 18 Feb 1999 20:38:51 -0500'" ^ DateAndTime now asEmailString.! ! !MailMessage class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 18:08'! empty "return a message with no text and no header" ^self new! ! !MailMessage class methodsFor: 'instance creation' stamp: 'SeanDeNigris 12/2/2011 11:53'! from: senderString to: recipients about: subjectString asFollows: bodyString | recipientsString | recipientsString := String streamContents: [ :str | recipients do: [ :e | str nextPutAll: e ] separatedBy: [ str nextPutAll: ', ' ] ]. ^ (self from: Character lf asString, bodyString) setField: 'from' toString: senderString; setField: 'date' toString: self dateStampNow; setField: 'subject' toString: subjectString; setField: 'to' toString: recipientsString.! ! !MailMessage class methodsFor: 'preferences' stamp: 'mdr 7/9/2001 13:23'! omittedHeaderFields "Reply a list of fields to omit when displaying a nice simple message" "Note that heads of the form X-something: value are filtered programatically. This is done since we don't want any of them and it is impossible to predict them in advance." ^ #( 'comments' 'priority' 'disposition-notification-to' 'content-id' 'received' 'return-path' 'newsgroups' 'message-id' 'path' 'in-reply-to' 'sender' 'fonts' 'mime-version' 'status' 'content-type' 'content-transfer-encoding' 'errors-to' 'keywords' 'references' 'nntp-posting-host' 'lines' 'return-receipt-to' 'precedence' 'originator' 'distribution' 'content-disposition' 'importance' 'resent-to' 'resent-cc' 'resent-message-id' 'resent-date' 'resent-sender' 'resent-from' 'delivered-to' 'user-agent' 'content-class' 'thread-topic' 'thread-index' 'list-help', 'list-post', 'list-subscribe', 'list-id', 'list-unsubscribe', 'list-archive' ) ! ! !MailMessage class methodsFor: 'utilities' stamp: 'PavelKrivanek 12/3/2013 15:07'! dateTimeSuffix "Answer a string which indicates the date and time, intended for use in building fileout filenames, etc." ^self monthDayTime24StringFrom: Time primUTCSecondsClock! ! !MailMessage class methodsFor: 'utilities' stamp: 'ls 4/30/2000 22:58'! generateSeparator "generate a separator usable for making MIME multipart documents. A leading -- will *not* be included" ^'==CelesteAttachment' , (10000 to: 99999) atRandom asString , '=='.! ! !MailMessage class methodsFor: 'utilities' stamp: 'JB 2/12/2010 15:27'! monthDayTime24StringFrom: aSecondCount | aDate aTime | "From the date/time represented by aSecondCount, produce a string which indicates the date and time in the compact form ddMMMhhmm where dd is a two-digit day-of-month, MMM is the alpha month abbreviation and hhmm is the time on a 24-hr clock. Utilities monthDayTime24StringFrom: Time primSecondsClock " aDate := Date fromSeconds: aSecondCount. aTime := Time fromSeconds: aSecondCount \\ 86400. ^ (aDate dayOfMonth asTwoCharacterString), (aDate monthName copyFrom: 1 to: 3), (aTime hhmm24)! ! !MailMessage class methodsFor: 'instance creation' stamp: 'SeanDeNigris 12/2/2011 11:22'! from: aString "Initialize a new instance from the given string." ^ self new from: aString! ! !MailMessageTest commentStamp: 'TorstenBergmann 2/5/2014 10:12'! SUnit tests for MailMessage! !MailMessageTest methodsFor: 'tests' stamp: 'SeanDeNigris 12/6/2011 16:26'! testSimpleCreate | message | message := MailMessage from: 'community@world.st' to: { 'pharo-project@lists.gforge.inria.fr'. 'pharo-users@lists.gforge.inria.fr' } about: 'Great Progress' asFollows: 'Pharo is getting so cool!!'. self assert: (message text matchesRegex: 'Date\: [[:alpha:]]+, \d+ [[:alpha:]]+ \d+ \d\d\:\d\d\:\d\d [-+]\d\d\d\d From\: community@world.st Subject\: Great Progress To\: pharo-project@lists.gforge.inria.fr, pharo-users@lists.gforge.inria.fr Pharo is getting so cool!! ').! ! !MailMessageTest methodsFor: 'tests' stamp: 'TonyFleig 11/28/2010 13:48'! testMultiPartMixed | m txt html part1 part2 | txt := 'This is plain text.'. html := 'This is html.'. m := MailMessage empty. m addMixedPart: txt contentType: 'text/plain'. m addMixedPart: html contentType: 'text/html'. self assert: (((m fields at: 'content-type') at: 1) mainValue asLowercase = 'multipart/mixed'). self assert: (m parts size = 2). part1 := m parts at: 1. part2 := m parts at: 2. self assert: (((part1 fields at: 'content-type') at: 1) mainValue asLowercase = 'text/plain'). self assert: ((part1 body content) = txt). self assert: (((part2 fields at: 'content-type') at: 1) mainValue asLowercase = 'text/html'). self assert: ((part2 body content) = html). ! ! !MailMessageTest methodsFor: 'tests' stamp: 'SeanDeNigris 12/2/2011 13:31'! testRecipientList | message | message := MailMessage from: 'To: pharo-project@lists.gforge.inria.fr, pharo-users@lists.gforge.inria.fr'. self assert: (message recipientList size = 2). self assert: (message recipientList first = 'pharo-project@lists.gforge.inria.fr'). self assert: (message recipientList second = 'pharo-users@lists.gforge.inria.fr').! ! !MailMessageTest methodsFor: 'tests' stamp: 'TonyFleig 11/28/2010 13:12'! testMultiPartAlternative | m txt html part1 part2 | txt := 'This is plain text.'. html := 'This is html.'. m := MailMessage empty. m addAlternativePart: txt contentType: 'text/plain'. m addAlternativePart: html contentType: 'text/html'. self assert: (((m fields at: 'content-type') at: 1) mainValue asLowercase = 'multipart/alternative'). self assert: (m parts size = 2). part1 := m parts at: 1. part2 := m parts at: 2. self assert: (((part1 fields at: 'content-type') at: 1) mainValue asLowercase = 'text/plain'). self assert: ((part1 body content) = txt). self assert: (((part2 fields at: 'content-type') at: 1) mainValue asLowercase = 'text/html'). self assert: ((part2 body content) = html). ! ! !MailMessageTest methodsFor: 'tests' stamp: 'SeanDeNigris 12/6/2011 14:36'! testCreateFromString | text message | text := 'Date: Tue, 20 Feb 2001 13:52:53 +0300 From: mdr@scn.rg (Me Ru) Subject: RE: Windows 2000 on your laptop To: "Greg Y" cc: cc1@scn.org, cc1also@test.org To: to2@no.scn.org, to2also@op.org cc: cc2@scn.org Hmmm... Good. I will try to swap my German copy for something in English, and then do the deed. Oh, and expand my RAM to 128 first. Mike '. message := MailMessage from: text. self assert: message text = text. self assert: message subject = 'RE: Windows 2000 on your laptop'. self assert: message from = 'mdr@scn.rg (Me Ru)'. self assert: message date = '2/20/01'. self assert: message time = 667133573. self assert: message to = '"Greg Y" , to2@no.scn.org, to2also@op.org'. self assert: message cc = 'cc1@scn.org, cc1also@test.org, cc2@scn.org'.! ! !MailSender commentStamp: 'TorstenBergmann 2/3/2014 23:09'! A mail sender! !MailSender class methodsFor: 'deprecated' stamp: 'CamilloBruni 10/15/2013 22:01'! sendMessage: aMailMessage self default ifNotNil: [self default sendMailMessage: aMailMessage]! ! !MailSender class methodsFor: 'deprecated' stamp: 'CamilloBruni 10/15/2013 22:01'! setSmtpServer: aString SmtpServer := aString! ! !MailSender class methodsFor: 'deprecated' stamp: 'CamilloBruni 10/15/2013 22:01'! smtpServer "Answer the server for sending email" self isSmtpServerSet ifFalse: [self setSmtpServer]. SmtpServer isEmpty ifTrue: [ self error: 'no SMTP server specified' ]. ^SmtpServer! ! !MailSender class methodsFor: 'deprecated' stamp: 'CamilloBruni 10/15/2013 22:01'! userName "Answer the user name to be used in composing messages." (UserName isNil or: [UserName isEmpty]) ifTrue: [self setUserName]. UserName isEmpty ifTrue: [ self error: 'no user name specified' ]. ^UserName! ! !MailSender class methodsFor: 'deprecated' stamp: 'CamilloBruni 10/15/2013 22:01'! isSmtpServerSet ^ SmtpServer notNil and: [SmtpServer notEmpty] ! ! !MailSender class methodsFor: 'deprecated' stamp: 'CamilloBruni 10/15/2013 22:01'! setSmtpServer "Set the SMTP server used to send outgoing messages via" SmtpServer ifNil: [SmtpServer := '']. SmtpServer := UIManager default request: 'What is your mail server for outgoing mail?' initialAnswer: SmtpServer. ! ! !MailSender class methodsFor: 'deprecated' stamp: 'CamilloBruni 10/15/2013 22:01'! setUserName "Change the user's email name for use in composing messages." (UserName isNil) ifTrue: [UserName := '']. UserName := UIManager default request: 'What is your email address?\(This is the address other people will reply to you)' withCRs initialAnswer: UserName. UserName ifNotNil: [UserName := UserName]! ! !MailtoUrl commentStamp: ''! a URL specifying a mailing address; activating it triggers a mail-sender to start up, if one is present.! !MailtoUrl methodsFor: 'downloading' stamp: 'dvf 5/11/2002 01:00'! composeText "Answer the template for a new message." ^ String streamContents: [:str | str nextPutAll: 'From: '. str nextPutAll: MailSender userName; cr. str nextPutAll: 'To: '. str nextPutAll: locator asString; cr. str nextPutAll: 'Subject: '; cr. str cr].! ! !MailtoUrl methodsFor: 'downloading' stamp: 'dvf 5/11/2002 00:47'! activate "Activate a Celeste window for the receiver" MailSender sendMessage: (MailMessage from: self composeText)! ! !MailtoUrl class methodsFor: 'constants' stamp: 'SeanDeNigris 1/29/2011 19:33'! schemeName ^ 'mailto'! ! !ManifestASTCore commentStamp: ''! I stores metadata on true and false positive critics. These meta data are used by the SmalllintManifestChecker and the critics Browser! !ManifestASTCore class methodsFor: 'meta data' stamp: 'StephaneDucasse 3/29/2013 18:06'! ruleRefersToClassRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#'RBLiteralNode class' #literalToken: #true)) #'2013-03-29T18:06:27.069+01:00') )! ! !ManifestASTCore class methodsFor: 'meta data' stamp: 'StephaneDucasse 3/29/2013 18:06'! ruleSendsDifferentSuperRuleV1TODO ^ #(#(#(#RGMethodDefinition #(#RBMessageNode #replaceSourceWithMessageNode: #false)) #'2013-03-29T18:06:27.369+01:00') )! ! !ManifestASTCore class methodsFor: 'meta data' stamp: 'StephaneDucasse 3/29/2013 18:06'! ruleLongMethodsRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#RBParser #parseBlockArgsInto: #false)) #'2013-03-29T18:06:27.028000001+01:00') #(#(#RGMethodDefinition #(#RBParser #patchLiteralArrayToken #false)) #'2013-03-29T18:06:27.030000002+01:00') #(#(#RGMethodDefinition #(#RBConfigurableFormatter #needsParenthesisFor: #false)) #'2013-03-29T18:06:27.030000009+01:00') #(#(#RGMethodDefinition #(#RBParser #parsePrimitiveObject #false)) #'2013-03-29T18:06:27.028000002+01:00') #(#(#RGMethodDefinition #(#RBFormatter #needsParenthesisFor: #false)) #'2013-03-29T18:06:27.028+01:00') #(#(#RGMethodDefinition #(#RBFormatter #formatMessage:cascade: #false)) #'2013-03-29T18:06:27.03+01:00') #(#(#RGMethodDefinition #(#'RBConfigurableFormatter class' #initialize #true)) #'2013-03-29T18:06:27.030000001+01:00') #(#(#RGMethodDefinition #(#RBParseTreeRewriter #visitCascadeNode: #false)) #'2013-03-29T18:06:27.030000004+01:00') #(#(#RGMethodDefinition #(#RBParser #parseStatementList:into: #false)) #'2013-03-29T18:06:27.030000005+01:00') #(#(#RGMethodDefinition #(#'RBConfigurableFormatter class' #settingsOn: #true)) #'2013-03-29T18:06:27.030000006+01:00') #(#(#RGMethodDefinition #(#RBProgramNode #matchList:index:against:index:inContext: #false)) #'2013-03-29T18:06:27.030000008+01:00') #(#(#RGMethodDefinition #(#RBMessageNode #replaceSourceWithMessageNode: #false)) #'2013-03-29T18:06:27.030000003+01:00') #(#(#RGMethodDefinition #(#RBParser #parseCascadeMessage #false)) #'2013-03-29T18:06:27.030000007+01:00') )! ! !ManifestASTCore class methodsFor: 'meta data' stamp: 'StephaneDucasse 3/29/2013 18:06'! rejectRules ^ #('LawOfDemeterRule')! ! !ManifestASTCore class methodsFor: 'meta data' stamp: 'StephaneDucasse 3/29/2013 18:06'! rejectClasses ^ #()! ! !ManifestASTCore class methodsFor: 'meta data' stamp: 'StephaneDucasse 3/29/2013 18:06'! ruleEquivalentSuperclassMethodsRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#RBProgramNode #isBlock #false)) #'2013-03-29T18:06:26.929+01:00') )! ! !ManifestFuel commentStamp: 'TorstenBergmann 2/3/2014 23:17'! Manifest for Fuel package! !ManifestFuel class methodsFor: 'meta data' stamp: 'MartinDias 2/25/2013 14:50'! ruleIfTrueBlocksRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#FLLightGeneralMapper #visitSubstitution:by:onRecursionDo: #false)) #'2013-02-25T14:50:01.650000001+01:00') )! ! !ManifestFuel class methodsFor: 'meta data' stamp: 'MartinDias 2/25/2013 14:13'! rejectRules ^ #()! ! !ManifestFuel class methodsFor: 'meta data' stamp: 'MartinDias 2/25/2013 14:13'! rejectClasses ^ #()! ! !ManifestFuel class methodsFor: 'meta data' stamp: 'MartinDias 2/25/2013 14:50'! ruleConsistencyCheckRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#Float #serializeOn: #false)) #'2013-02-25T14:50:01.564000001+01:00') )! ! !ManifestManifestCore commentStamp: ''! I stores metadata on true and false positive critics. These meta data are used by the SmalllintManifestChecker and the critics Browser! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'StephaneDucasse 1/6/2014 20:51'! ruleContainsRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#TheManifestBuilder #commentOfFalsePositive:onRule:version: #false)) #'2013-02-01T15:29:52.876+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #commentOfToDo:onRule:version: #false)) #'2013-02-01T15:29:52.876000001+01:00') #(#(#RGMethodDefinition #(#SmalllintManifestChecker #criticsOf: #false)) #'2013-02-08T16:35:58.019+01:00') )! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'StephaneDucasse 1/6/2014 20:51'! ruleBadMessageRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#TheManifestBuilder #hasTruePositiveOf:version: #false)) #'2013-02-01T15:29:51.978000008+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #hasFalsePositiveOf:version: #false)) #'2013-02-01T15:29:51.978000006+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #rejectRules #false)) #'2013-02-01T15:29:51.978000007+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #hasToDoOf:version: #false)) #'2013-02-01T15:29:51.978000005+01:00') )! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'StephaneDucasse 1/6/2014 20:51'! ruleCodeCruftLeftInMethodsRuleV1TODO ^ #(#(#(#RGMethodDefinition #(#TheManifestBuilder #hash #false)) #'2013-02-06T15:08:33.234+01:00') )! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'StephaneDucasse 1/6/2014 20:51'! ruleImplementedNotSentRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#TheManifestBuilder #addTruePositive:of:version: #false)) #'2013-02-01T15:29:52.678000007+01:00') #(#(#RGMethodDefinition #(#SmalllintManifestChecker #isTruePositive:forRuleId:versionId: #false)) #'2013-02-01T15:29:52.678000011+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #removeManifestOf: #false)) #'2013-02-01T15:29:52.678000012+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #dateOfToDo:onRule:version: #false)) #'2013-02-01T15:29:52.678000013+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #dateOfTruePositive:onRule:version: #false)) #'2013-02-01T15:29:52.67800001+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #removeAllManifest #false)) #'2013-02-01T15:29:52.678000006+01:00') #(#(#RGMethodDefinition #(#'RBLintRule class' #uniqueIdentifierNumber #true)) #'2013-02-01T15:29:52.678000008+01:00') #(#(#RGMethodDefinition #(#TheManifestBuilder #installTruePositiveOf:version: #false)) #'2013-02-01T15:29:52.678000009+01:00') )! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'SimonAllier 3/22/2013 15:13'! rejectRules ^ #('LawOfDemeterRule' 'MethodHasNoTimeStampRule')! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! rejectClasses ^ #()! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! ruleEquivalentSuperclassMethodsRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#'RBEqualNotUsedRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000004+01:00') #(#(#RGMethodDefinition #(#'RBEndTrueFalseRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000018+01:00') #(#(#RGMethodDefinition #(#'RBBlockLintRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000009+01:00') #(#(#RGMethodDefinition #(#'RBDetectContainsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000036+01:00') #(#(#RGMethodDefinition #(#'RBMethodModifierSuperRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000029+01:00') #(#(#RGMethodDefinition #(#'RBExcessiveArgumentsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000001+01:00') #(#(#RGMethodDefinition #(#'RBVariableNotDefinedRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000007+01:00') #(#(#RGMethodDefinition #(#'RBVariableAssignedLiteralRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000009+01:00') #(#(#RGMethodDefinition #(#'RBDetectIfNoneRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000028+01:00') #(#(#RGMethodDefinition #(#'RBPlatformDependentUserInteractionRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000006+01:00') #(#(#RGMethodDefinition #(#'RBMissingSuperSendsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000048+01:00') #(#(#RGMethodDefinition #(#'RBOnlyReadOrWrittenVariableRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000005+01:00') #(#(#RGMethodDefinition #(#'RBMinMaxRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.465000002+01:00') #(#(#RGMethodDefinition #(#'RBAbstractClassRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000051+01:00') #(#(#RGMethodDefinition #(#'RBUnoptimizedAndOrRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000019+01:00') #(#(#RGMethodDefinition #(#'RBMethodModifierFinalRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000053+01:00') #(#(#RGMethodDefinition #(#'RBUsesAddRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000011+01:00') #(#(#RGMethodDefinition #(#'RBUnclassifiedMethodsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000024+01:00') #(#(#RGMethodDefinition #(#'RBEquivalentSuperclassMethodsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.465000001+01:00') #(#(#RGMethodDefinition #(#'RBBooleanPrecedenceRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000005+01:00') #(#(#RGMethodDefinition #(#'RBReturnsBooleanAndOtherRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000017+01:00') #(#(#RGMethodDefinition #(#'RBLongMethodsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000035+01:00') #(#(#RGMethodDefinition #(#'RBCascadedNextPutAllsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000007+01:00') #(#(#RGMethodDefinition #(#'RBReturnsIfTrueRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000002+01:00') #(#(#RGMethodDefinition #(#'RBInstVarInSubclassesRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.46000004+01:00') #(#(#RGMethodDefinition #(#'RBSearchingLiteralRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000062+01:00') #(#(#RGMethodDefinition #(#'RBContainsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000016+01:00') #(#(#RGMethodDefinition #(#'RBAssignmentInIfTrueRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000012+01:00') #(#(#RGMethodDefinition #(#'RBTransformationRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000057+01:00') #(#(#RGMethodDefinition #(#'RBJustSendsSuperRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000015+01:00') #(#(#RGMethodDefinition #(#'RBSentNotImplementedRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000045+01:00') #(#(#RGMethodDefinition #(#'RBAssignmentWithoutEffectRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000025+01:00') #(#(#RGMethodDefinition #(#'RBExcessiveVariablesRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000016+01:00') #(#(#RGMethodDefinition #(#'RBGuardingClauseRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000043+01:00') #(#(#RGMethodDefinition #(#'RBVariableReferencedOnceRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000024+01:00') #(#(#RGMethodDefinition #(#'RBMethodSourceContainsLinefeedsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.46000005+01:00') #(#(#RGMethodDefinition #(#'RBExtraBlockRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000012+01:00') #(#(#RGMethodDefinition #(#'RBGuardClauseRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000009+01:00') #(#(#RGMethodDefinition #(#'RBExcessiveMethodsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000026+01:00') #(#(#RGMethodDefinition #(#'RBUnpackagedCodeRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000054+01:00') #(#(#RGMethodDefinition #(#'RBUnwindBlocksRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000003+01:00') #(#(#RGMethodDefinition #(#'RBUndeclaredReferenceRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000041+01:00') #(#(#RGMethodDefinition #(#'RBMissingSubclassResponsibilityRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000055+01:00') #(#(#RGMethodDefinition #(#'RBSubclassResponsibilityNotDefinedRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000014+01:00') #(#(#RGMethodDefinition #(#'RBParseTreeLintRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000022+01:00') #(#(#RGMethodDefinition #(#'RBEqualsTrueRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000059+01:00') #(#(#RGMethodDefinition #(#'RBLiteralArrayCharactersRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000063+01:00') #(#(#RGMethodDefinition #(#'RBTempVarOverridesInstVarRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.46000003+01:00') #(#(#RGMethodDefinition #(#'RBPrecedenceRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000064+01:00') #(#(#RGMethodDefinition #(#'RBSizeCheckRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.465+01:00') #(#(#RGMethodDefinition #(#'RBNotEliminationRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000025+01:00') #(#(#RGMethodDefinition #(#'RBUnconditionalRecursionRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000017+01:00') #(#(#RGMethodDefinition #(#'RBTemporaryVariableCapitalizationRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.45800002+01:00') #(#(#RGMethodDefinition #(#'RBAtIfAbsentRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000049+01:00') #(#(#RGMethodDefinition #(#'RBSendsDifferentSuperRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000065+01:00') #(#(#RGMethodDefinition #(#'RBEmptyExceptionHandlerRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463+01:00') #(#(#RGMethodDefinition #(#'RBCollectSelectNotUsedRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.45800003+01:00') #(#(#RGMethodDefinition #(#'RBToDoWithIncrementRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.46000006+01:00') #(#(#RGMethodDefinition #(#'RBIfTrueBlocksRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000061+01:00') #(#(#RGMethodDefinition #(#'RBAddRemoveDependentsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000031+01:00') #(#(#RGMethodDefinition #(#'RBTempsReadBeforeWrittenRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000027+01:00') #(#(#RGMethodDefinition #(#'RBExcessiveInheritanceRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000006+01:00') #(#(#RGMethodDefinition #(#'RBModifiesCollectionRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000023+01:00') #(#(#RGMethodDefinition #(#'RBBadMessageRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000001+01:00') #(#(#RGMethodDefinition #(#'RBNoClassCommentRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000013+01:00') #(#(#RGMethodDefinition #(#'RBUnnecessaryAssignmentRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000015+01:00') #(#(#RGMethodDefinition #(#'RBCollectionProtocolRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000028+01:00') #(#(#RGMethodDefinition #(#'RBStringConcatenationRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000008+01:00') #(#(#RGMethodDefinition #(#'RBThreeElementPointRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000026+01:00') #(#(#RGMethodDefinition #(#'RBTranslateLiteralsInMenusRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000013+01:00') #(#(#RGMethodDefinition #(#'RBOverridesSpecialMessageRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000031+01:00') #(#(#RGMethodDefinition #(#'RBToDoRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000037+01:00') #(#(#RGMethodDefinition #(#'RBSuperSendsNewRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000039+01:00') #(#(#RGMethodDefinition #(#'RBClassNotReferencedRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000008+01:00') #(#(#RGMethodDefinition #(#'RBOnlyReadOrWrittenTemporaryRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000058+01:00') #(#(#RGMethodDefinition #(#'RBYourselfNotUsedRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000015+01:00') #(#(#RGMethodDefinition #(#'RBUnreferencedVariablesRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000046+01:00') #(#(#RGMethodDefinition #(#'RBAssignmentInBlockRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.46+01:00') #(#(#RGMethodDefinition #(#'RBReturnInEnsureRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000018+01:00') #(#(#RGMethodDefinition #(#'RBAllAnyNoneSatisfyRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000021+01:00') #(#(#RGMethodDefinition #(#'RBIfTrueReturnsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000044+01:00') #(#(#RGMethodDefinition #(#'RBUsesTrueRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000012+01:00') #(#(#RGMethodDefinition #(#'RBMethodHasNoTimeStampRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000004+01:00') #(#(#RGMethodDefinition #(#'RBImplementedNotSentRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000006+01:00') #(#(#RGMethodDefinition #(#'RBRefersToClassRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.46000001+01:00') #(#(#RGMethodDefinition #(#'RBCompositeLintRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000003+01:00') #(#(#RGMethodDefinition #(#'RBInstanceVariableCapitalizationRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000032+01:00') #(#(#RGMethodDefinition #(#'RBClassNameInSelectorRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000011+01:00') #(#(#RGMethodDefinition #(#'RBMissingTranslationsInMenusRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000003+01:00') #(#(#RGMethodDefinition #(#'RBBasicLintRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000004+01:00') #(#(#RGMethodDefinition #(#'RBFileBlocksRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.46000002+01:00') #(#(#RGMethodDefinition #(#'RBClassVariableCapitalizationRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000008+01:00') #(#(#RGMethodDefinition #(#'RBBetweenAndRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000002+01:00') #(#(#RGMethodDefinition #(#'RBSendsDeprecatedMethodToGlobalRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000038+01:00') #(#(#RGMethodDefinition #(#'RBCollectionMessagesToExternalObjectRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.46300001+01:00') #(#(#RGMethodDefinition #(#'RBCollectionCopyEmptyRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000014+01:00') #(#(#RGMethodDefinition #(#'RBUnoptimizedToDoRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000027+01:00') #(#(#RGMethodDefinition #(#'RBInconsistentMethodClassificationRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000021+01:00') #(#(#RGMethodDefinition #(#'RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000019+01:00') #(#(#RGMethodDefinition #(#'RBFloatEqualityComparisonRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000023+01:00') #(#(#RGMethodDefinition #(#'RBLiteralArrayContainsCommaRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000022+01:00') #(#(#RGMethodDefinition #(#'RBUnderscoreAssignmentRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000018+01:00') #(#(#RGMethodDefinition #(#'RBMissingYourselfRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000029+01:00') #(#(#RGMethodDefinition #(#'RBWhileTrueRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.45800001+01:00') #(#(#RGMethodDefinition #(#'RBLawOfDemeterRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000005+01:00') #(#(#RGMethodDefinition #(#'RBToDoCollectRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000034+01:00') #(#(#RGMethodDefinition #(#'RBAsOrderedCollectionNotNeededRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000017+01:00') #(#(#RGMethodDefinition #(#'RBMethodModifierOverrideRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000047+01:00') #(#(#RGMethodDefinition #(#'RBUtilityMethodsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000052+01:00') #(#(#RGMethodDefinition #(#'RBSuperSendsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000056+01:00') #(#(#RGMethodDefinition #(#'RBEqualNilRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000042+01:00') #(#(#RGMethodDefinition #(#'RBConsistencyCheckRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000011+01:00') #(#(#RGMethodDefinition #(#'RBDefinesEqualNotHashRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000013+01:00') #(#(#RGMethodDefinition #(#'RBCodeCruftLeftInMethodsRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.458000007+01:00') #(#(#RGMethodDefinition #(#'RBUncommonMessageSendRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.460000033+01:00') #(#(#RGMethodDefinition #(#'RBClassInstVarNotInitializedRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000014+01:00') #(#(#RGMethodDefinition #(#'RBSendsUnknownMessageToGlobalRule class' #identifierMinorVersionNumber #true)) #'2013-02-01T15:29:56.463000016+01:00') )! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'StephaneDucasse 1/6/2014 20:51'! ruleConsistencyCheckRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#TheManifestBuilder #addItem:wihtComment:selector: #false)) #'2013-02-01T15:29:51.672000001+01:00') #(#(#RGMethodDefinition #(#'RGMetaclassDefinition class' #manifestReadOn: #true)) #'2013-02-01T15:29:51.672000002+01:00') #(#(#RGMethodDefinition #(#'RGMethodDefinition class' #manifestReadOn: #true)) #'2013-02-01T15:29:51.672000003+01:00') )! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'SimonAllier 3/22/2013 15:13'! ruleClassNotReferencedRuleV1FalsePositive ^ #(#(#(#RGClassDefinition #(#RBRemoveAssignmentWithoutEffectRule)) #'2013-03-22T15:13:33.961+01:00') )! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'SimonAllier 3/22/2013 11:32'! ruleSentNotImplementedRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#ClassDescription #criticNameOn: #false)) #'2013-03-22T11:32:46.828+01:00') )! ! !ManifestManifestCriticBrowser commentStamp: ''! ManifestManifestCriticBrowser is the manifest for the Manifest-CriticBrowser package itself.! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'CamilloBruni 9/18/2013 22:54'! ruleBadMessageRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#SingleCodeCriticResultList #perform:orSendTo: #false)) #'2013-02-01T15:29:51.915000005+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'CamilleTeruel 9/18/2013 10:41'! ruleMissingYourselfRuleV1FalsePositive ^ #()! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'CamilleTeruel 9/18/2013 10:41'! ruleCollectionMessagesToExternalObjectRuleV1FalsePositive ^ #()! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 3/22/2013 15:13'! rejectRules ^ #('LawOfDemeterRule' 'MethodHasNoTimeStampRule')! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! rejectClasses ^ #()! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'CamilloBruni 9/18/2013 22:54'! ruleEquivalentSuperclassMethodsRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#SingleCodeCriticResultList #perform:orSendTo: #false)) #'2013-02-01T15:29:56.387000008+01:00') #(#(#RGMethodDefinition #(#'SelectRuleBrowser class' #defaultSpec #true)) #'2013-02-01T15:29:56.387000009+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/6/2013 15:08'! ruleGuardClauseRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#CriticBrowser #onWindowClosed #false)) #'2013-02-06T15:08:32.377+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'CamilloBruni 9/18/2013 22:54'! ruleReturnsIfTrueRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#SingleCodeCriticResultList #iconFor: #false)) #'2013-02-01T15:29:51.740000004+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! ruleSubclassResponsibilityNotDefinedRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#SelectBrowser #nextAction #false)) #'2013-02-01T15:29:53.049+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'CamilleTeruel 9/18/2013 10:41'! ruleSentNotImplementedRuleV1FalsePositive ^ #()! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'CamilloBruni 9/18/2013 22:54'! ruleCodeCruftLeftInMethodsRuleV1TODO ^ #(#(#(#RGMethodDefinition #(#SingleCodeCriticResultList #addCriticWithCommentToFalsePositive #false)) #'2013-02-06T15:08:32.572+01:00') #(#(#RGMethodDefinition #(#SingleCodeCriticResultList #addCriticWithCommentToToDo #false)) #'2013-02-06T15:08:32.572000001+01:00') #(#(#RGMethodDefinition #(#SingleCodeCriticResultList #removeRuleToFalsePositive #false)) #'2013-03-21T14:07:34.827+01:00') #(#(#RGMethodDefinition #(#SingleCodeCriticResultList #addRuleToFalsePositive #false)) #'2013-03-21T14:07:34.827000001+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! ruleImplementedNotSentRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#'CommentFalsePositiveWindow class' #openOnCritic:onRule: #true)) #'2013-02-01T15:29:52.617000004+01:00') #(#(#RGMethodDefinition #(#CriticWorkingConfiguration #logInManifest: #false)) #'2013-02-01T15:29:52.617000005+01:00') #(#(#RGMethodDefinition #(#CriticsCache #addCritic:forRule: #false)) #'2013-02-01T15:29:52.617000006+01:00') #(#(#RGMethodDefinition #(#'CommentToDoWindow class' #openOnCritic:onRule: #true)) #'2013-02-01T15:29:52.617000007+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimomAllier 3/25/2013 16:31'! ruleMissingSubclassResponsibilityRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#SelectPackageBrowser #addItems #false)) #'2013-03-25T16:31:39.782000002+01:00') #(#(#RGMethodDefinition #(#SelectRuleBrowser #addAllItems #false)) #'2013-03-25T16:31:39.782000003+01:00') #(#(#RGMethodDefinition #(#SelectPackageBrowser #removeAllItems #false)) #'2013-03-25T16:31:39.782000005+01:00') #(#(#RGMethodDefinition #(#SelectPackageBrowser #removeItems #false)) #'2013-03-25T16:31:39.782000006+01:00') #(#(#RGMethodDefinition #(#SelectRuleBrowser #removeAllItems #false)) #'2013-03-25T16:31:39.782000004+01:00') #(#(#RGMethodDefinition #(#SelectRuleBrowser #addItems #false)) #'2013-03-25T16:31:39.782+01:00') #(#(#RGMethodDefinition #(#SelectRuleBrowser #removeItems #false)) #'2013-03-25T16:31:39.782000001+01:00') #(#(#RGMethodDefinition #(#SelectPackageBrowser #addAllItems #false)) #'2013-03-25T16:31:39.782000007+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'CamilloBruni 9/18/2013 22:54'! ruleOnlyReadOrWrittenVariableRuleV1FalsePositive ^ #(#(#(#RGClassDefinition #(#CriticBrowser)) #'2013-02-01T15:29:52.299+01:00') #(#(#RGClassDefinition #(#SelectBrowser)) #'2013-02-01T15:29:52.299000001+01:00') #(#(#RGClassDefinition #(#SingleCodeCriticResultList)) #'2013-02-01T15:29:52.301+01:00') #(#(#RGClassDefinition #(#ResetWindow)) #'2013-02-01T15:29:52.296000003+01:00') #(#(#RGClassDefinition #(#SelectPackageBrowser)) #'2013-02-01T15:29:52.296000002+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'CamilleTeruel 9/18/2013 10:41'! ruleTemporaryVariableCapitalizationRuleV1FalsePositive ^ #()! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'CamilleTeruel 9/18/2013 10:41'! ruleOnlyReadOrWrittenTemporaryRuleV1FalsePositive ^ #()! ! !ManifestManifestTests commentStamp: 'TorstenBergmann 2/19/2014 08:33'! The manifest for Manifest-Tests package! !ManifestManifestTests class methodsFor: 'meta data' stamp: ''! rejectRules ^ #()! ! !ManifestManifestTests class methodsFor: 'meta data' stamp: ''! rejectClasses ^ #()! ! !ManifestOpalCompilerCore class methodsFor: 'meta data' stamp: 'MarcusDenker 12/18/2012 17:42'! ruleImplementedNotSentRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#OCASTTranslatorForEffect #emitIfFalse: #false)) #'2012-12-18T17:41:36.969+01:00') #(#(#RGMethodDefinition #(#OCASTTranslatorForEffect #emitIfTrue: #false)) #'2012-12-18T17:41:39.446+01:00') #(#(#RGMethodDefinition #(#OCASTTranslatorForEffect #emitIfNotNil: #false)) #'2012-12-18T17:41:41.777+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitCaseOf: #false)) #'2012-12-18T17:42:01.724+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitToByDo: #false)) #'2012-12-18T17:42:03.557+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitToDo: #false)) #'2012-12-18T17:42:05.34+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitIfNotNil: #false)) #'2012-12-18T17:42:07.349+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitIfNil: #false)) #'2012-12-18T17:42:09.472+01:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitCaseOfOtherwise: #false)) #'2012-12-18T17:42:11.795+01:00') )! ! !ManifestOpalCompilerCore class methodsFor: 'meta data' stamp: 'MarcusDenker 5/23/2013 08:43'! ruleBadMessageRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#OCASTTranslator #initialize #false)) #'2013-05-23T08:43:44.793471+02:00') #(#(#RGMethodDefinition #(#OCASTTranslator #emitCaseOf: #false)) #'2013-05-23T08:43:44.793471+02:00') #(#(#RGMethodDefinition #(#OpalCompiler #evaluate #false)) #'2013-05-23T08:43:44.793471+02:00') )! ! !ManifestOpalCompilerCore class methodsFor: 'meta data' stamp: 'MarcusDenker 5/23/2013 08:43'! rejectRules ^ #('SearchingLiteralRule' 'ExcessiveArgumentsRule' 'LongMethodsRule' 'ClassInstVarNotInitializedRule' 'UsesAddRule' 'ExcessiveMethodsRule' 'MissingYourselfRule' 'ExcessiveVariablesRule' 'TempsReadBeforeWrittenRule' 'AbstractClassRule' 'IfTrueReturnsRule')! ! !ManifestOpalCompilerCore class methodsFor: 'meta data' stamp: 'MarcusDenker 12/18/2012 17:41'! rejectClasses ^ #()! ! !ManifestOpalCompilerCore class methodsFor: 'meta data' stamp: 'MarcusDenker 12/18/2012 17:44'! ruleEqualsTrueRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#IRBytecodeGenerator #returnConstant: #false)) #'2012-12-18T17:44:03.941+01:00') )! ! !ManifestOpalCompilerCore class methodsFor: 'meta data' stamp: 'MarcusDenker 9/20/2013 15:19'! ruleMethodHasNoTimeStampRuleV1TruePositive ^ #(#(#(#RGMethodDefinition #(#OCSemanticWarning #correctIn: #false)) #'2012-12-18T17:43:05.023+01:00') #(#(#RGMethodDefinition #(#OCAbstractLocalVariable #isUninitialized #false)) #'2012-12-18T17:43:10.236+01:00') #(#(#RGMethodDefinition #(#IRPrinter #pushRemoteTemp:inVector: #false)) #'2012-12-19T08:07:38.013+01:00') )! ! !ManifestOpalCompilerCore class methodsFor: 'meta data' stamp: 'MarcusDenker 12/19/2012 08:10'! ruleTempsReadBeforeWrittenRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#IRSequence #absorbJumpToSingleInstr: #false)) #'2012-12-19T08:10:39.177+01:00') )! ! !ManifestOpalCompilerCore class methodsFor: 'meta data' stamp: 'MarcusDenker 12/19/2012 08:13'! ruleVariableAssignedLiteralRuleV1FalsePositive ^ #(#(#(#RGClassDefinition #(#IRMethod)) #'2012-12-19T08:13:54.508+01:00') )! ! !ManifestOpalCompilerCore class methodsFor: 'meta data' stamp: 'MarcusDenker 12/18/2012 17:43'! ruleAssignmentInIfTrueRuleV1TruePositive ^ #(#(#(#RGMethodDefinition #(#OpalCompiler #from:class:context:notifying: #false)) #'2012-12-18T17:43:24.703000001+01:00') )! ! !ManifestOpalCompilerCore class methodsFor: 'meta data' stamp: 'MarcusDenker 12/19/2012 08:17'! ruleToDoCollectRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#IRBytecodeScope #args #false)) #'2012-12-19T08:16:58.474000001+01:00') #(#(#RGMethodDefinition #(#IRBytecodeScope #temps #false)) #'2012-12-19T08:17:19.677+01:00') )! ! !ManyTestResourceTestCase commentStamp: 'TorstenBergmann 2/12/2014 23:14'! SUnit tests for handling of many test resources! !ManyTestResourceTestCase methodsFor: 'running' stamp: 'nfr 1/3/2010 18:07'! testTearDownOrder | myResourceSetUpOrder myResourceReverseTearDownOrder | myResourceReverseTearDownOrder := OrderedCollection new: 7. myResourceSetUpOrder := (OrderedCollection new: 7) add: SimpleTestResource; add: SimpleTestResourceA1; add: SimpleTestResourceA2; add: SimpleTestResourceA; add: SimpleTestResourceB1; add: SimpleTestResourceB; yourself. self assert: (myResourceSetUpOrder allSatisfy: [:each | each isAvailable]) description: 'At test start, not all my resources were set up'. self class resources do: [:each | each resetOrAddResourcesTo: myResourceReverseTearDownOrder]. self assert: myResourceReverseTearDownOrder = myResourceSetUpOrder description: 'Wrong order for tearDown'. self assert: (myResourceSetUpOrder allSatisfy: [:each | each isAvailable]) description: 'At test start, not all my resources were set up'! ! !ManyTestResourceTestCase methodsFor: 'utility' stamp: 'NiallRoss 7/18/2010 11:52'! clearOuterResourceStateDuring: aBlock "This self-testing test must clear the outer state of its resources before starting and after finishing, so that it can construct test cases and suites of itself and test them." self assert: SimpleTestResourceA1 isAlreadyAvailable description: 'The resource was not set up for the test'. SimpleTestResourceA reset. SimpleTestResourceB reset. SimpleTestResourceA1 reset. self deny: SimpleTestResourceA1 isAlreadyAvailable description: 'The resource was still set up before we began the run'. ^[super clearOuterResourceStateDuring: aBlock] ensure: [self deny: SimpleTestResourceA1 isAlreadyAvailable description: 'The resource was still set up after we finished the run'. self deny: SimpleTestResourceB1 isAlreadyAvailable description: 'The resource was still set up after we finished the run'. SimpleTestResourceA isAvailable. self assert: SimpleTestResourceA1 isAlreadyAvailable description: 'The resource was not set up again after the test'. SimpleTestResourceB isAvailable. self assert: SimpleTestResourceB1 isAlreadyAvailable description: 'The resource was not set up again after the test']! ! !ManyTestResourceTestCase class methodsFor: 'testing' stamp: ' 17/7/10 17:28'! shouldInheritSelectors ^true! ! !ManyTestResourceTestCase class methodsFor: 'accessing' stamp: 'nfr 1/3/2010 18:13'! resources ^super resources , (Array with: SimpleTestResourceA with: SimpleTestResourceB)! ! !Margin commentStamp: ''! MorphMargin represents a margin (for now of rectangle-based operations). It can be expressed as different objects: - A number. When specified using a number, it sets all the four values to be the same. - A point. When specified as a point, pairs top/bottom and left/right take their values from a point y and x. - Four numbers. They represent all the four directions. - A rectangle. (do not use this version because it is proposed just for migration and it may force you to crea) In the future we may add an API (#margin) for singular margin.! !Margin methodsFor: 'initialization' stamp: 'StephaneDucasse 9/7/2013 09:32'! fromRectangle: aRectangle "Pay attention do not use this method but prefer top:left:bottom:right:" self setTop: aRectangle top left: aRectangle left bottom: aRectangle bottom right: aRectangle right! ! !Margin methodsFor: 'private' stamp: 'StephaneDucasse 9/7/2013 09:00'! setTop: topNumber left: leftNumber bottom: bottomNumber right: rightNumber top := topNumber. left := leftNumber. bottom := bottomNumber. right := rightNumber.! ! !Margin methodsFor: 'accessing' stamp: 'StephaneDucasse 9/7/2013 11:37'! width ^ self right - self left.! ! !Margin methodsFor: 'accessing' stamp: 'StephaneDucasse 9/7/2013 09:02'! left ^ left! ! !Margin methodsFor: 'operations' stamp: 'StephaneDucasse 9/7/2013 10:57'! insetRectangle: aRectangle "Answer a rectangle whose size has been reduced by the receiver. The limitation is that since a rectangle topleft is always less than its bottomright you may have a some cases that are not possible to express. For that you should use a margin object instead of a rectangle." | l r t b| l := aRectangle left + self left. r :=aRectangle right - self right. t := aRectangle top + self top. b := aRectangle bottom - self bottom. ^ Rectangle origin: l @t extent: (r - l @ (b - t )) ! ! !Margin methodsFor: 'accessing' stamp: 'StephaneDucasse 9/7/2013 09:02'! top ^ top! ! !Margin methodsFor: 'operations' stamp: 'StephaneDucasse 9/7/2013 10:57'! expandRectangle: aRectangle "Answer a rectangle whose size has been expanded by the receiver which represents each rectangle corner." | l r t b | l := aRectangle left - self left. r :=aRectangle right + self right. t := aRectangle top - self top. b := aRectangle bottom + self bottom. ^ Rectangle origin: l @t extent: ((r - l ) @ (b - t )) ! ! !Margin methodsFor: 'accessing' stamp: 'StephaneDucasse 9/7/2013 09:02'! bottom ^ bottom! ! !Margin methodsFor: 'accessing' stamp: 'StephaneDucasse 9/7/2013 11:37'! height ^ self bottom - self top.! ! !Margin methodsFor: 'accessing' stamp: 'StephaneDucasse 9/7/2013 09:02'! right ^ right! ! !Margin methodsFor: 'initialization' stamp: 'StephaneDucasse 9/7/2013 09:01'! initialize super initialize. self setTop: 0 left: 0 bottom: 0 right: 0 ! ! !Margin methodsFor: 'initialization' stamp: 'StephaneDucasse 9/7/2013 08:58'! fromNumber: anInteger self setTop: anInteger left: anInteger bottom: anInteger right: anInteger! ! !Margin methodsFor: 'initialization' stamp: 'StephaneDucasse 9/7/2013 09:08'! fromPoint: aPoint self setTop: aPoint y left: aPoint x bottom: aPoint y right: aPoint x! ! !Margin methodsFor: 'printing' stamp: 'StephaneDucasse 9/7/2013 09:18'! printOn: aStream aStream nextPutAll: 'MorphMargin'; nextPutAll: ' top: '; nextPutAll: top printString; nextPutAll: ' left: '; nextPutAll: left printString; nextPutAll: ' bottom: '; nextPutAll: bottom printString; nextPutAll: ' right: '; nextPutAll: right printString. ! ! !Margin methodsFor: 'accessing' stamp: 'StephaneDucasse 9/7/2013 12:55'! rightBottom ^ right @ bottom! ! !Margin methodsFor: 'converting' stamp: 'StephaneDucasse 9/7/2013 11:26'! asMargin ^ self ! ! !Margin methodsFor: 'testing' stamp: 'StephaneDucasse 9/7/2013 10:29'! isZero ^ (0 = top) and: [ (0 = left) and: [ (0 = right) and: [ 0 = bottom]]]! ! !Margin methodsFor: 'operations' stamp: 'StephaneDucasse 9/7/2013 12:55'! extendRectangle: aRectangle "Answer a rectangle whose size has been expanded (without changing its origin) by the receiver which represents each rectangle corner." ^ Rectangle origin: aRectangle origin corner: aRectangle corner + self rightBottom ! ! !Margin class methodsFor: 'instance creation' stamp: 'StephaneDucasse 9/7/2013 09:13'! top: topNumber left: leftNumber bottom: bottomNumber right: rightNumber ^ self new setTop: topNumber left: leftNumber bottom: bottomNumber right: rightNumber ! ! !Margin class methodsFor: 'instance creation' stamp: 'StephaneDucasse 9/7/2013 11:24'! left: leftNumber top: topNumber right: rightNumber bottom: bottomNumber ^ self new setTop: topNumber left: leftNumber bottom: bottomNumber right: rightNumber ! ! !Margin class methodsFor: 'will be deprecated' stamp: 'StephaneDucasse 9/7/2013 09:34'! fromRectangle: aRectangle "Create a margin with four values based on aRectangle using exactly top, left, bottom, right semantics. Pay attention that most of the time you should not use this method but prefer top:left:bottom:right:. The reason is that using rectangle may force you to create rectangles with negative extent which is totally wrong and bogus." ^ self new fromRectangle: aRectangle; yourself! ! !Margin class methodsFor: 'instance creation' stamp: 'StephaneDucasse 9/7/2013 09:03'! fromNumber: aNumber "Create a margin whose four values are the same and based on anInteger" ^ self new fromNumber: aNumber; yourself! ! !Margin class methodsFor: 'instance creation' stamp: 'StephaneDucasse 9/7/2013 09:10'! fromPoint: aPoint "Create a margin whose values are based on the point value: top and bottom are y and left right are x." ^ self new fromPoint: aPoint; yourself! ! !MarginBorder commentStamp: 'gvc 5/18/2007 12:46'! Border with customisable inner margin.! !MarginBorder methodsFor: 'accessing' stamp: 'gvc 10/17/2006 11:06'! frameRectangle: aRectangle on: aCanvas "Reduce width by the margin." aCanvas frameAndFillRectangle: aRectangle fillColor: Color transparent borderWidth: (self width - self margin max: 0) topLeftColor: self topLeftColor bottomRightColor: self bottomRightColor.! ! !MarginBorder methodsFor: 'initialization' stamp: 'gvc 10/17/2006 11:05'! initialize "Initialize the receiver." super initialize. self margin: 0! ! !MarginBorder methodsFor: 'accessing' stamp: 'gvc 10/17/2006 11:07'! drawLineFrom: startPoint to: stopPoint on: aCanvas "Reduce the width by the margin." | lineColor | lineColor := (stopPoint truncated quadrantOf: startPoint truncated) > 2 ifTrue: [self topLeftColor] ifFalse: [self bottomRightColor]. aCanvas line: startPoint to: stopPoint width: (self width - self margin max: 0) color: lineColor! ! !MarginBorder methodsFor: 'accessing' stamp: 'gvc 10/17/2006 11:04'! margin "Answer the value of margin" ^ margin! ! !MarginBorder methodsFor: 'accessing' stamp: 'gvc 10/17/2006 11:04'! margin: anObject "Set the value of margin" margin := anObject! ! !Matrix commentStamp: ''! I represent a two-dimensional array. Structure: nrows : a non-negative integer saying how many rows there are. ncols : a non-negative integer saying how many columns there are. contents : an Array holding the elements in row-major order. That is, for a 2x3 array the contents are (11 12 13 21 22 23). Element-wise matrix arithmetic works; you can freely mix matrices and numbers but don't try to mix matrices and arrays (yet). Matrix multiplication, using the symbol +* (derived from APL's +.x), works between (Matrix or Array) +* (Matrix or Array). Don't try to use a number as an argument of +*. Matrix * Number and Number * Matrix work fine, so you don't need +* with numbers. ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/22/2002 00:15'! with: aCollection collect: aBlock "aCollection must support #at:at: and be at least as large as the receiver." ^self withIndicesCollect: [:each :row :column | aBlock value: each value: (aCollection at: row at: column)] ! ! !Matrix methodsFor: 'testing' stamp: 'raok 11/22/2002 13:03'! isSequenceable "LIE so that arithmetic on matrices will work. What matters for arithmetic is not that there should be random indexing but that the structure should be stable and independent of the values of the elements. #isSequenceable is simply the wrong question to ask." ^true! ! !Matrix methodsFor: 'private' stamp: 'raok 10/21/2002 22:40'! indexForRow: row andColumn: column (row between: 1 and: nrows) ifFalse: [self error: '1st subscript out of range']. (column between: 1 and: ncols) ifFalse: [self error: '2nd subscript out of range']. ^(row-1) * ncols + column! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'! withIndicesCollect: aBlock |i r| i := 0. r := contents shallowCopy. 1 to: nrows do: [:row | 1 to: ncols do: [:column | i := i+1. r at: i put: (aBlock value: (r at: i) value: row value: column)]]. ^self class rows: nrows columns: ncols contents: r ! ! !Matrix methodsFor: 'private' stamp: 'raok 10/21/2002 22:47'! rowAndColumnForIndex: index |t| t := index - 1. ^(t // ncols + 1)@(t \\ ncols + 1)! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 10/21/2002 23:32'! atRow: row (row between: 1 and: nrows) ifFalse: [self error: '1st subscript out of range']. ^contents copyFrom: (row-1)*ncols+1 to: row*ncols! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:43'! atRandom: aGenerator ^contents atRandom: aGenerator! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asOrderedCollection ^contents asOrderedCollection! ! !Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:27'! shuffled ^self class rows: nrows columns: ncols contents: (contents shuffled)! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! reject: aBlock self shouldNotImplement! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:22'! swapRow: anIndex withRow: anotherIndex |a b| a := self indexForRow: anIndex andColumn: 1. b := self indexForRow: anotherIndex andColumn: 1. ncols timesRepeat: [ contents swap: a with: b. a := a + 1. b := b + 1]. ! ! !Matrix methodsFor: '*Collections-arithmetic' stamp: 'raok 11/28/2002 14:22'! preMultiplyByArray: a "Answer a +* self where a is an Array." nrows = 1 ifFalse: [self error: 'dimensions do not conform']. ^Matrix rows: a size columns: ncols tabulate: [:row :col | (a at: row) * (contents at: col)] ! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/22/2002 12:42'! atRow: row put: aCollection |p| aCollection size = ncols ifFalse: [self error: 'wrong row size']. p := (self indexForRow: row andColumn: 1)-1. aCollection do: [:each | contents at: (p := p+1) put: each]. ^aCollection! ! !Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:24'! identityIncludes: anObject ^contents identityIncludes: anObject! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:37'! at: row at: column ^contents at: (self indexForRow: row andColumn: column)! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! asFloatArray ^contents asFloatArray! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:48'! identityIndexOf: anElement ifAbsent: anExceptionBlock ^self rowAndColumnForIndex: (contents identityIndexOf: anElement ifAbsent: [^anExceptionBlock value]) ! ! !Matrix methodsFor: 'testing' stamp: 'CamilloBruni 9/8/2011 14:23'! includesAll: aCollection ^contents includesAll: aCollection! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! asWordArray ^contents asWordArray! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! difference: aCollection "Union is in because the result is always a Set. Difference and intersection are out because the result is like the receiver, and with irregular seleection that cannot be." self shouldNotImplement! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:48'! identityIndexOf: anElement ^self identityIndexOf: anElement ifAbsent: [0@0] ! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:51'! indicesInject: start into: aBlock |current| current := start. 1 to: nrows do: [:row | 1 to: ncols do: [:column | current := aBlock value: current value: row value: column]]. ^current! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:57'! asArray ^contents shallowCopy! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'jannik.laval 5/1/2010 16:19'! transposed [nrows = ncols] assert. ^self indicesCollect: [:row :column | self at: column at: row]! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:43'! atRandom ^contents atRandom ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:44'! columnCount ^ncols! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:49'! replaceAll: oldObject with: newObject contents replaceAll: oldObject with: newObject! ! !Matrix methodsFor: 'copying' stamp: 'jannik.laval 5/1/2010 16:18'! ,, aMatrix "Answer a new matrix having the same number of columns as the receiver and aMatrix, its rows being the rows of the receiver followed by the rows of aMatrix." [ncols = aMatrix columnCount] assert. ^self class rows: nrows + aMatrix rowCount columns: ncols contents: contents , aMatrix privateContents ! ! !Matrix methodsFor: 'private' stamp: 'raok 11/22/2002 12:56'! privateContents "Only used in #, #,, and #= so far. It used to be called #contents, but that clashes with Collection>>contents." ^contents! ! !Matrix methodsFor: 'copying' stamp: 'jannik.laval 5/1/2010 16:18'! , aMatrix "Answer a new matrix having the same number of rows as the receiver and aMatrix, its columns being the columns of the receiver followed by the columns of aMatrix." |newCont newCols anArray oldCols a b c| [nrows = aMatrix rowCount] assert. newCont := Array new: self size + aMatrix size. anArray := aMatrix privateContents. oldCols := aMatrix columnCount. newCols := ncols + oldCols. a := b := c := 1. 1 to: nrows do: [:r | newCont replaceFrom: a to: a+ncols-1 with: contents startingAt: b. newCont replaceFrom: a+ncols to: a+newCols-1 with: anArray startingAt: c. a := a + newCols. b := b + ncols. c := c + oldCols]. ^self class rows: nrows columns: newCols contents: newCont ! ! !Matrix methodsFor: 'copying' stamp: 'MaxLeske 10/30/2013 13:35'! shuffledBy: aRandom ^self class rows: nrows columns: ncols contents: (contents copy shuffleBy: aRandom)! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asIdentitySet ^contents asIdentitySet! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'! withIndicesDo: aBlock |i| i := 0. 1 to: nrows do: [:row | 1 to: ncols do: [:column | aBlock value: (contents at: (i := i+1)) value: row value: column]]. ! ! !Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 12:32'! atRows: r1 to: r2 columns: c1 to: c2 put: aMatrix "Set the [r1..r2][c1..c2] submatrix of the receiver from the [1..r2-r1+1][1..c2-c1+1] submatrix of aMatrix. As long as aMatrix responds to at:at: and accepts arguments in the range shown, we don't care if it is bigger or even if it is a Matrix at all." |rd cd| rd := r1 - 1. cd := c1 - 1. r1 to: r2 do: [:r | c1 to: c2 do: [:c | self at: r at: c put: (aMatrix at: r-rd at: c-cd)]]. ^aMatrix ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:40'! at: row at: column put: value ^contents at: (self indexForRow: row andColumn: column) put: value! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 10/23/2002 20:41'! diagonal "Answer (1 to: (nrows min: ncols)) collect: [:i | self at: i at: i]" |i| i := ncols negated. ^(1 to: (nrows min: ncols)) collect: [:j | contents at: (i := i + ncols + 1)]! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asCharacterSet ^contents asCharacterSet! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:41'! collect: aBlock "Answer a new matrix with transformed elements; transformations should be independent." ^self class rows: nrows columns: ncols contents: (contents collect: aBlock)! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:52'! swap: r1 at: c1 with: r2 at: c2 contents swap: (self indexForRow: r1 andColumn: c1) with: (self indexForRow: r2 andColumn: c2)! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! asIntegerArray ^contents asIntegerArray! ! !Matrix methodsFor: 'accessing' stamp: 'raok 11/28/2002 14:14'! at: r at: c ifInvalid: v "If r,c is a valid index for this matrix, answer the corresponding element. Otherwise, answer v." (r between: 1 and: nrows) ifFalse: [^v]. (c between: 1 and: ncols) ifFalse: [^v]. ^contents at: (r-1)*ncols + c ! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:53'! with: aCollection do: aBlock "aCollection must support #at:at: and be at least as large as the receiver." self withIndicesDo: [:each :row :column | aBlock value: each value: (aCollection at: row at: column)]. ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:42'! atAllPut: value contents atAllPut: value! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'! withIndicesInject: start into: aBlock |i current| i := 0. current := start. 1 to: nrows do: [:row | 1 to: ncols do: [:column | current := aBlock value: current value: (contents at: (i := i+1)) value: row value: column]]. ^current! ! !Matrix methodsFor: 'copying' stamp: 'nice 10/5/2009 09:09'! postCopy super postCopy. contents := contents copy! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asByteArray ^contents asByteArray! ! !Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 13:13'! indexOf: anElement "If there are integers r, c such that (self at: r at: c) = anElement, answer some such r@c, otherwise answer 0@0. This kind of perverse result is provided by analogy with SequenceableCollection>>indexOf:. The order in which the receiver are searched is UNSPECIFIED except that it is the same as the order used by #indexOf:ifAbsent: and #readStream." ^self indexOf: anElement ifAbsent: [0@0] ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 13:10'! indexOf: anElement ifAbsent: anExceptionBlock "If there are integers r, c such that (self at: r at: c) = anElement, answer some such r@c, otherwise answer the result of anExceptionBlock." ^self rowAndColumnForIndex: (contents indexOf: anElement ifAbsent: [^anExceptionBlock value]) ! ! !Matrix methodsFor: 'removing' stamp: 'klub 9/14/2009 16:34'! removeAll self shouldNotImplement! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:55'! with: aCollection inject: startingValue into: aBlock "aCollection must support #at:at: and be at least as large as the receiver." ^self withIndicesInject: startingValue into: [:value :each :row :column | aBlock value: value value: each value: (aCollection at: row at: column)]! ! !Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:25'! occurrencesOf: anObject ^contents occurrencesOf: anObject! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:44'! rowCount ^nrows! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:37'! anyOne ^contents anyOne! ! !Matrix methodsFor: '*Collections-arithmetic' stamp: 'raok 10/22/2002 20:02'! preMultiplyByMatrix: m "Answer m +* self where m is a Matrix." |s| nrows = m columnCount ifFalse: [self error: 'dimensions do not conform']. ^Matrix rows: m rowCount columns: ncols tabulate: [:row :col | s := 0. 1 to: nrows do: [:k | s := (m at: row at: k) * (self at: k at: col) + s]. s]! ! !Matrix methodsFor: '*Collections-arithmetic' stamp: 'raok 10/22/2002 20:01'! +* aCollection "Premultiply aCollection by self. aCollection should be an Array or Matrix. The name of this method is APL's +.x squished into Smalltalk syntax." ^aCollection preMultiplyByMatrix: self ! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:21'! swapColumn: anIndex withColumn: anotherIndex |a b| a := self indexForRow: 1 andColumn: anIndex. b := self indexForRow: 1 andColumn: anotherIndex. nrows timesRepeat: [ contents swap: a with: b. a := a + ncols. b := b + ncols]. ! ! !Matrix methodsFor: 'private' stamp: 'jannik.laval 5/1/2010 16:18'! rows: rows columns: columns contents: anArray [rows isInteger and: [rows >= 0]] assert. [columns isInteger and: [columns >= 0]] assert. [rows * columns = anArray size] assert. nrows := rows. ncols := columns. contents := anArray. ^self! ! !Matrix methodsFor: 'adding' stamp: 'raok 10/21/2002 22:53'! add: newObject self shouldNotImplement! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:59'! asSortedCollection ^contents asSortedCollection! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/22/2002 12:41'! atColumn: column |p| p := (self indexForRow: 1 andColumn: column)-ncols. ^(1 to: nrows) collect: [:row | contents at: (p := p+ncols)] ! ! !Matrix methodsFor: 'comparing' stamp: 'raok 11/22/2002 13:14'! hash "I'm really not sure what would be a good hash function here. The essential thing is that it must be compatible with #=, and this satisfies that requirement." ^contents hash! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:49'! size ^contents size! ! !Matrix methodsFor: 'printing' stamp: 'raok 10/21/2002 23:22'! storeOn: aStream aStream nextPut: $(; nextPutAll: self class name; nextPutAll: ' rows: '; store: nrows; nextPutAll: ' columns: '; store: ncols; nextPutAll: ' contents: '; store: contents; nextPut: $)! ! !Matrix methodsFor: 'removing' stamp: 'raok 10/21/2002 22:54'! remove: anObject ifAbsent: anExceptionBlock self shouldNotImplement! ! !Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 13:09'! atRows: rs columns: cs "Answer a Matrix obtained by slicing the receiver. rs and cs should be sequenceable collections of positive integers." ^self class rows: rs size columns: cs size tabulate: [:r :c | self at: (rs at: r) at: (cs at: c)]! ! !Matrix methodsFor: 'converting' stamp: 'damiencassou 5/30/2008 11:45'! readStream "Answer a ReadStream that returns all the elements of the receiver in some UNSPECIFIED order." ^ contents readStream! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! intersection: aCollection "Union is in because the result is always a Set. Difference and intersection are out because the result is like the receiver, and with irregular seleection that cannot be." self shouldNotImplement! ! !Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 12:37'! at: row at: column incrementBy: value "Array2D>>at:at:add: was the origin of this method, but in Smalltalk add: generally suggests adding an element to a collection, not doing a sum. This method, and SequenceableCollection>>at:incrementBy: that supports it, have been renamed to reveal their intention more clearly." ^contents at: (self indexForRow: row andColumn: column) incrementBy: value! ! !Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:23'! includes: anObject ^contents includes: anObject! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! select: aBlock self shouldNotImplement! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asSet ^contents asSet! ! !Matrix methodsFor: 'comparing' stamp: 'raok 11/22/2002 12:58'! = aMatrix ^aMatrix class == self class and: [ aMatrix rowCount = nrows and: [ aMatrix columnCount = ncols and: [ aMatrix privateContents = contents]]]! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:40'! do: aBlock "Pass elements to aBlock one at a time in row-major order." contents do: aBlock! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/23/2002 20:57'! indicesCollect: aBlock |r i| r := Array new: nrows * ncols. i := 0. 1 to: nrows do: [:row | 1 to: ncols do: [:column | r at: (i := i+1) put: (aBlock value: row value: column)]]. ^self class rows: nrows columns: ncols contents: r! ! !Matrix methodsFor: 'testing' stamp: 'CamilloBruni 9/8/2011 14:23'! includesAny: aCollection ^contents includesAny: aCollection! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:49'! indicesDo: aBlock 1 to: nrows do: [:row | 1 to: ncols do: [:column | aBlock value: row value: column]].! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:57'! asBag ^contents asBag! ! !Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 12:30'! atRows: r1 to: r2 columns: c1 to: c2 "Answer a submatrix [r1..r2][c1..c2] of the receiver." |rd cd| rd := r1 - 1. cd := c1 - 1. ^self class rows: r2-rd columns: c2-cd tabulate: [:r :c| self at: r+rd at: c+cd] ! ! !Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 13:05'! atRows: r1 to: r2 columns: c1 to: c2 ifInvalid: element "Answer a submatrix [r1..r2][c1..c2] of the receiver. Portions of the result outside the bounds of the original matrix are filled in with element." |rd cd| rd := r1 - 1. cd := c1 - 1. ^self class rows: r2-rd columns: c2-cd tabulate: [:r :c| self at: r+rd at: c+cd ifInvalid: element] ! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:21'! atColumn: column put: aCollection |p| aCollection size = nrows ifFalse: [self error: 'wrong column size']. p := (self indexForRow: 1 andColumn: column)-ncols. aCollection do: [:each | contents at: (p := p+ncols) put: each]. ^aCollection ! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:59'! asSortedCollection: aBlock ^contents asSortedCollection: aBlock! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:06'! new: dim "Answer a dim*dim matrix. Is this an abuse of #new:? The argument is NOT a size." ^self rows: dim columns: dim! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:59'! identity: n |r| r := self zeros: n. 1 to: n do: [:i | r at: i at: i put: 1]. ^r! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 11/25/2002 12:51'! new: dim element: element "Answer a dim*dim matrix with all elements set to element. Is this an abuse of #new:? The argument is NOT a size." ^self rows: dim columns: dim element: element! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:04'! rows: rows columns: columns ^self rows: rows columns: columns contents: (Array new: rows*columns)! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:58'! column: aCollection "Should this be called #fromColumn:?" ^self rows: aCollection size columns: 1 contents: aCollection asArray shallowCopy! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 19:54'! new: dim tabulate: aBlock "Answer a dim*dim matrix where it at: i at: j is aBlock value: i value: j." ^self rows: dim columns: dim tabulate: aBlock! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 19:51'! rows: rows columns: columns tabulate: aBlock "Answer a new Matrix of the given dimensions where result at: i at: j is aBlock value: i value: j" |a i| a := Array new: rows*columns. i := 0. 1 to: rows do: [:row | 1 to: columns do: [:column | a at: (i := i+1) put: (aBlock value: row value: column)]]. ^self rows: rows columns: columns contents: a ! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:09'! diagonal: aCollection |r i| r := self zeros: aCollection size. i := 0. aCollection do: [:each | i := i+1. r at: i at: i put: each]. ^r! ! !Matrix class methodsFor: 'private' stamp: 'raok 10/21/2002 23:06'! rows: rows columns: columns contents: contents ^self new rows: rows columns: columns contents: contents! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:59'! row: aCollection "Should this be called #fromRow:?" ^self rows: 1 columns: aCollection size contents: aCollection asArray shallowCopy! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:08'! ones: n ^self new: n element: 1 ! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:09'! zeros: n ^self new: n element: 0! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:10'! rows: rows columns: columns element: element ^self rows: rows columns: columns contents: ((Array new: rows*columns) atAllPut: element; yourself)! ! !MatrixTest commentStamp: 'TorstenBergmann 2/20/2014 15:30'! SUnit tests for matrix! !MatrixTest methodsFor: 'tests - accessing' stamp: 'dc 3/3/2007 17:47'! testAtAt self should:[matrix1 at: 2 at: 3] raise: Error. self should:[matrix1 at: 3 at: 2] raise: Error. self should:[matrix1 at: 3 at: 3] raise: Error. self should:[matrix1 at: 0 at: 1] raise: Error. self should:[matrix1 at: 1 at: 0] raise: Error. self should:[matrix1 at: 0 at: 0] raise: Error. self assert: (matrix1 at: 1 at: 1) = 1! ! !MatrixTest methodsFor: 'tests - accessing' stamp: 'dc 3/3/2007 17:52'! testReplaceAll matrix1 replaceAll: 1 with: 10. self assert: (matrix1 at:1 at:1) = 10. self assert: (matrix1 at:2 at:1) = 2. self assert: (matrix1 at:1 at:2) = 3. self assert: (matrix1 at:2 at:2) = 4.! ! !MatrixTest methodsFor: 'tests - accessing' stamp: 'dc 3/3/2007 17:53'! testSwap matrix1 swap: 1 at: 2 with: 1 at: 1. self assert: (matrix1 at: 1 at: 1) = 3. self assert: (matrix1 at: 1 at: 2) = 1.! ! !MatrixTest methodsFor: 'tests - accessing' stamp: 'jannik.laval 5/2/2010 07:40'! testTransposed | transposedMatrix | transposedMatrix := matrix1 transposed. self assert: (transposedMatrix at:1 at:1) = 1. self assert: (transposedMatrix at:1 at:2) = 2. self assert: (transposedMatrix at:2 at:1) = 3. self assert: (transposedMatrix at:2 at:2) = 4! ! !MatrixTest methodsFor: 'tests - copying' stamp: 'dc 3/3/2007 17:48'! testCopy | copyMatrix | copyMatrix := matrix1 copy. self assert: matrix1 = copyMatrix ! ! !MatrixTest methodsFor: 'tests - testing' stamp: 'dc 3/3/2007 17:49'! testIncludes self assert: ((1 to: 4) allSatisfy: [:i | matrix1 includes: i]) ! ! !MatrixTest methodsFor: 'tests - arithmetic' stamp: 'dc 3/3/2007 17:50'! testMultiply | result | self should: [matrix1 preMultiplyByMatrix: (Matrix new: 3)]raise: Error. result := matrix2 preMultiplyByMatrix: matrix1. self assert: (result at: 1 at: 1) = 15. self assert: (result at: 1 at: 2) = 31. self assert: (result at: 2 at: 1) = 22. self assert: (result at: 2 at: 2) = 46! ! !MatrixTest methodsFor: 'testing' stamp: 'dc 3/3/2007 17:58'! setUp matrix1 := Matrix new: 2. matrix1 at:1 at:1 put: 1. matrix1 at:1 at:2 put: 3. matrix1 at:2 at:1 put: 2. matrix1 at:2 at:2 put: 4. matrix2 := Matrix new: 2. matrix2 at:1 at:1 put: 3. matrix2 at:1 at:2 put: 7. matrix2 at:2 at:1 put: 4. matrix2 at:2 at:2 put: 8.! ! !MatrixTransform2x3 commentStamp: ''! This class represents a transformation for points, that is a combination of scale, offset, and rotation. It is implemented as a 2x3 matrix containing the transformation from the local coordinate system in the global coordinate system. Thus, transforming points from local to global coordinates is fast and cheap whereas transformations from global to local coordinate systems are relatively expensive. Implementation Note: It is assumed that the transformation deals with Integer points. All transformations will return Integer coordinates (even though float points may be passed in here).! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a21: value self at: 4 put: value! ! !MatrixTransform2x3 methodsFor: 'composing' stamp: 'lr 7/4/2009 10:42'! composedWithLocal: aTransformation into: result "Return the composition of the receiver and the local transformation passed in. Store the composed matrix into result." | a11 a12 a13 a21 a22 a23 b11 b12 b13 b21 b22 b23 matrix | matrix := aTransformation asMatrixTransform2x3. a11 := self a11. b11 := matrix a11. a12 := self a12. b12 := matrix a12. a13 := self a13. b13 := matrix a13. a21 := self a21. b21 := matrix a21. a22 := self a22. b22 := matrix a22. a23 := self a23. b23 := matrix a23. result a11: a11 * b11 + (a12 * b21). result a12: a11 * b12 + (a12 * b22). result a13: a13 + (a11 * b13) + (a12 * b23). result a21: a21 * b11 + (a22 * b21). result a22: a21 * b12 + (a22 * b22). result a23: a23 + (a21 * b13) + (a22 * b23). ^ result! ! !MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'StephaneDucasse 3/17/2010 21:12'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." | w b1 b2 b3 b4 | Smalltalk isLittleEndian ifTrue: [ 1 to: self basicSize do: [ :i | w := self basicAt: i. b1 := w digitAt: 1. b2 := w digitAt: 2. b3 := w digitAt: 3. b4 := w digitAt: 4. w := (b1 << 24) + (b2 << 16) + (b3 << 8) + b4. self basicAt: i put: w ] ]! ! !MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/2/1998 23:19'! offset ^self a13 @ self a23! ! !MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:06'! byteSize ^self basicSize * self bytesPerBasicElement! ! !MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 2/2/2001 15:47'! localPointToGlobal: aPoint "Transform aPoint from local coordinates into global coordinates" ^(self transformPoint: aPoint) rounded! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a13: value self at: 3 put: value! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a22 ^self at: 5! ! !MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 2/2/2001 15:47'! isPureTranslation "Return true if the receiver specifies no rotation or scaling." ^self a11 = 1.0 and:[self a12 = 0.0 and:[self a22 = 0.0 and:[self a21 = 1.0]]]! ! !MatrixTransform2x3 methodsFor: 'composing' stamp: 'RAA 9/20/2000 13:10'! composedWithLocal: aTransformation "Return the composition of the receiver and the local transformation passed in" aTransformation isMatrixTransform2x3 ifFalse:[^super composedWithLocal: aTransformation]. ^self composedWithLocal: aTransformation asMatrixTransform2x3 into: self class new! ! !MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 11/2/1998 23:15'! isMatrixTransform2x3 "Return true if the receiver is 2x3 matrix transformation" ^true! ! !MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! at: index ^Float fromIEEE32Bit: (self basicAt: index)! ! !MatrixTransform2x3 methodsFor: 'printing' stamp: 'ar 11/2/1998 23:11'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(; cr; print: self a11; tab; print: self a12; tab; print: self a13; cr; print: self a21; tab; print: self a22; tab; print: self a23; cr; nextPut:$).! ! !MatrixTransform2x3 methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setOffset: aPoint "Set the raw offset in the receiver" | pt | pt := aPoint asPoint. self a13: pt x asFloat. self a23: pt y asFloat! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a11 ^self at: 1! ! !MatrixTransform2x3 methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! inverseTransformation "Return the inverse transformation of the receiver. The inverse transformation is computed by first calculating the inverse offset and then computing transformations for the two identity vectors (1@0) and (0@1)" | r1 r2 r3 m | r3 := self invertPoint: 0 @ 0. r1 := (self invertPoint: 1 @ 0) - r3. r2 := (self invertPoint: 0 @ 1) - r3. m := self species new. m a11: r1 x; a12: r2 x; a13: r3 x; a21: r1 y; a22: r2 y; a23: r3 y. ^ m! ! !MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'lr 7/4/2009 10:42'! transformDirection: aPoint "Transform aPoint from local coordinates into global coordinates" | x y | x := aPoint x * self a11 + (aPoint y * self a12). y := aPoint x * self a21 + (aPoint y * self a22). ^ x @ y! ! !MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:04'! bytesPerBasicElement "Answer the number of bytes that each of my basic elements requires. In other words: self basicSize * self bytesPerBasicElement should equal the space required on disk by my variable sized representation." ^4! ! !MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 2/2/2001 15:47'! globalBounds: srcRect toLocal: dstRect "Transform aRectangle from global coordinates into local coordinates" ^super globalBoundsToLocal: srcRect! ! !MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 2/2/2001 15:47'! globalPointToLocal: aPoint "Transform aPoint from global coordinates into local coordinates" ^(self invertPoint: aPoint) rounded! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a23: value self at: 6 put: value! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a12: value self at: 2 put: value! ! !MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:40'! localBoundsToGlobal: aRectangle "Transform aRectangle from local coordinates into global coordinates" ^self localBounds: aRectangle toGlobal: Rectangle new! ! !MatrixTransform2x3 methodsFor: 'comparing' stamp: 'lr 7/4/2009 10:42'! hash | result | result := 0. 1 to: self size do: [ :i | result := result + (self basicAt: i) ]. ^ result bitAnd: 536870911! ! !MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 2/2/2001 15:47'! isIdentity "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself." ^self isPureTranslation and:[self a13 = 0.0 and:[self a23 = 0.0]]! ! !MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'ar 8/6/2001 17:52'! writeOn: aStream aStream nextWordsPutAll: self.! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a21 ^self at: 4! ! !MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 2/2/2001 15:47'! localBounds: srcRect toGlobal: dstRect "Transform aRectangle from local coordinates into global coordinates" ^super localBoundsToGlobal: srcRect! ! !MatrixTransform2x3 methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setScale: aPoint "Set the raw scale in the receiver" | pt | pt := aPoint asPoint. self a11: pt x asFloat. self a22: pt y asFloat! ! !MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'lr 7/4/2009 10:42'! transformPoint: aPoint "Transform aPoint from local coordinates into global coordinates" | x y | x := aPoint x * self a11 + (aPoint y * self a12) + self a13. y := aPoint x * self a21 + (aPoint y * self a22) + self a23. ^ x @ y! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a12 ^self at: 2! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a11: value self at: 1 put: value! ! !MatrixTransform2x3 methodsFor: 'initialize' stamp: 'ar 11/2/1998 23:17'! setIdentiy "Initialize the receiver to the identity transformation (e.g., not affecting points)" self a11: 1.0; a12: 0.0; a13: 0.0; a21: 0.0; a22: 1.0; a23: 0.0.! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a22: value self at: 5 put: value! ! !MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! at: index put: value value isFloat ifTrue:[self basicAt: index put: value asIEEE32BitWord] ifFalse:[self at: index put: value asFloat]. ^value! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a13 ^self at: 3! ! !MatrixTransform2x3 methodsFor: 'comparing' stamp: 'lr 7/4/2009 10:42'! = aMatrixTransform2x3 | length | self class = aMatrixTransform2x3 class ifFalse: [ ^ false ]. length := self size. length = aMatrixTransform2x3 size ifFalse: [ ^ false ]. 1 to: self size do: [ :i | (self at: i) = (aMatrixTransform2x3 at: i) ifFalse: [ ^ false ] ]. ^ true! ! !MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/2/1998 23:05'! offset: aPoint self a13: aPoint x asFloat. self a23: aPoint y asFloat.! ! !MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:40'! globalBoundsToLocal: aRectangle "Transform aRectangle from global coordinates into local coordinates" ^self globalBounds: aRectangle toLocal: Rectangle new! ! !MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'lr 7/4/2009 10:42'! invertPoint: aPoint "Transform aPoint from global coordinates into local coordinates" | x y det a11 a12 a21 a22 detX detY | x := aPoint x asFloat - self a13. y := aPoint y asFloat - self a23. a11 := self a11. a12 := self a12. a21 := self a21. a22 := self a22. det := a11 * a22 - (a12 * a21). det = 0.0 ifTrue: [ ^ 0 @ 0 ]. "So we have at least a valid result" det := 1.0 / det. detX := x * a22 - (a12 * y). detY := a11 * y - (x * a21). ^ (detX * det) @ (detY * det)! ! !MatrixTransform2x3 methodsFor: 'private' stamp: 'ar 11/2/1998 23:17'! setAngle: angle "Set the raw rotation angle in the receiver" | rad s c | rad := angle degreesToRadians. s := rad sin. c := rad cos. self a11: c. self a12: s negated. self a21: s. self a22: c.! ! !MatrixTransform2x3 methodsFor: 'converting' stamp: 'ar 11/2/1998 15:34'! asMatrixTransform2x3 ^self! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a23 ^self at: 6! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 22:50'! identity ^self new setScale: 1.0! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 7/9/1998 20:09'! new ^self new: 6! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 02:49'! withAngle: angle ^self new setAngle: angle! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 23:17'! withRotation: angle ^self new setAngle: angle! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/12/1998 01:25'! transformFromLocal: localBounds toGlobal: globalBounds ^((self withOffset: (globalBounds center)) composedWithLocal: (self withScale: (globalBounds extent / localBounds extent) asFloatPoint)) composedWithLocal: (self withOffset: localBounds center negated) " ^(self identity) setScale: (globalBounds extent / localBounds extent) asFloatPoint; setOffset: localBounds center negated asFloatPoint; composedWithGlobal:(self withOffset: globalBounds center asFloatPoint) "! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 02:52'! withOffset: aPoint ^self identity setOffset: aPoint! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'mir 6/12/2001 15:34'! newFromStream: s "Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk." self isPointers | self isWords not ifTrue: [^ super newFromStream: s]. "super may cause an error, but will not be called." ^ s nextWordsInto: (self new: 6)! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 02:49'! withScale: aPoint ^self new setScale: aPoint! ! !MatrixTransformMorph commentStamp: ''! MatrixTransformMorph is similar to TransformMorph but uses a MatrixTransform2x3 instead of a MorphicTransform. It is used by clients who want use the BalloonEngine for vector-based scaling instead of the standard WarpBlt pixel-based mechanism.! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:55'! hasNoScaleOrRotation ^true! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/16/1998 01:19'! changeRotationCenter: evt with: rotHandle | pos | pos := evt cursorPoint. rotHandle referencePosition: pos. self referencePosition: pos.! ! !MatrixTransformMorph methodsFor: 't-rotating' stamp: ''! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'! lastRotationDegrees: deg deg = 0.0 ifTrue:[self removeProperty: #lastRotationDegrees] ifFalse:[self setProperty: #lastRotationDegrees toValue: deg]! ! !MatrixTransformMorph methodsFor: 'drawing' stamp: 'ar 5/29/1999 09:01'! drawSubmorphsOn: aCanvas aCanvas asBalloonCanvas transformBy: self transform during:[:myCanvas| super drawSubmorphsOn: myCanvas].! ! !MatrixTransformMorph methodsFor: 'rotate scale and flex' stamp: 'ar 11/15/1998 21:55'! addFlexShell "No flex shell necessary" self lastRotationDegrees: 0.0.! ! !MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 10/6/2000 15:37'! transformedBy: aTransform self transform: (self transform composedWithGlobal: aTransform).! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 9/11/2000 21:16'! transform ^ transform ifNil: [MatrixTransform2x3 identity]! ! !MatrixTransformMorph methodsFor: 'geometry etoy' stamp: 'ar 6/12/2001 05:07'! rotationCenter: aPoint super rotationCenter: (self transform globalPointToLocal: bounds origin + (bounds extent * aPoint))! ! !MatrixTransformMorph methodsFor: 't-rotating' stamp: ''! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !MatrixTransformMorph methodsFor: 'updating' stamp: 'ar 11/12/2000 18:51'! changed ^self invalidRect: (self fullBounds insetBy: -1)! ! !MatrixTransformMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:38'! initialize "initialize the state of the receiver" super initialize. "" transform := MatrixTransform2x3 identity! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'! removeFlexShell "Do nothing"! ! !MatrixTransformMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 21:51'! transform: aMatrixTransform transform := aMatrixTransform. self computeBounds.! ! !MatrixTransformMorph methodsFor: 'geometry testing' stamp: 'ar 11/15/1998 21:52'! fullContainsPoint: aPoint | p | self visible ifFalse:[^false]. (self fullBounds containsPoint: aPoint) ifFalse:[^false]. (self containsPoint: aPoint) ifTrue:[^true]. p := self transform globalPointToLocal: aPoint. submorphs do:[:m| (m fullContainsPoint: p) ifTrue:[^true]. ]. ^false! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'AlainPlantec 5/8/2010 00:03'! rotationDegrees: degrees | last delta | last := self lastRotationDegrees. delta := degrees - last. self rotateBy: delta. self lastRotationDegrees: degrees.! ! !MatrixTransformMorph methodsFor: 'drawing' stamp: 'md 2/27/2006 09:51'! visible: aBoolean "set the 'visible' attribute of the receiver to aBoolean" extension ifNil: [aBoolean ifTrue: [^ self]]. self assureExtension visible: aBoolean! ! !MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 21:52'! handleBoundsChange: aBlock | oldBounds newBounds | oldBounds := bounds. aBlock value. newBounds := bounds. self boundsChangedFrom: oldBounds to: newBounds.! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'fbs 11/26/2004 10:59'! innerAngle ^ (self transform a11 @ self transform a21) degrees! ! !MatrixTransformMorph methodsFor: 'geometry etoy' stamp: 'AlainPlantec 5/7/2010 23:55'! setDirectionFrom: aPoint | delta degrees | delta := (self transformFromWorld globalPointToLocal: aPoint) - super rotationCenter. degrees := delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! !MatrixTransformMorph methodsFor: 'geometry testing' stamp: 'ar 1/15/1999 16:34'! containsPoint: aPoint self visible ifFalse:[^false]. (bounds containsPoint: aPoint) ifFalse: [^ false]. self hasSubmorphs ifTrue: [self submorphsDo: [:m | (m fullContainsPoint: (self transform globalPointToLocal: aPoint)) ifTrue: [^ true]]. ^ false] ifFalse: [^ true]! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'mdr 12/19/2001 10:49'! rotateBy: delta | pt m | delta = 0.0 ifTrue:[^self]. self changed. pt := self transformFromWorld globalPointToLocal: self referencePosition. m := MatrixTransform2x3 withOffset: pt. m := m composedWithLocal: (MatrixTransform2x3 withAngle: delta). m := m composedWithLocal: (MatrixTransform2x3 withOffset: pt negated). self transform: (transform composedWithLocal: m). self changed.! ! !MatrixTransformMorph methodsFor: 't-rotating' stamp: ''! prepareForRotating "If I require a flex shell to rotate, then wrap it in one and return it. Polygons, eg, may override to do nothing." ^ self addFlexShell! ! !MatrixTransformMorph methodsFor: 'geometry' stamp: 'mdr 12/19/2001 10:48'! boundsChangedFrom: oldBounds to: newBounds oldBounds extent = newBounds extent ifFalse:[ transform := transform composedWithGlobal: (MatrixTransform2x3 withOffset: oldBounds origin negated). transform := transform composedWithGlobal: (MatrixTransform2x3 withScale: newBounds extent / oldBounds extent). transform := transform composedWithGlobal: (MatrixTransform2x3 withOffset: newBounds origin). ]. transform offset: transform offset + (newBounds origin - oldBounds origin)! ! !MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 21:52'! extent: extent self handleBoundsChange:[super extent: extent]! ! !MatrixTransformMorph methodsFor: 'drawing' stamp: 'ar 11/15/1998 22:20'! drawOn: aCanvas! ! !MatrixTransformMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:44'! invalidRect: rect from: aMorph aMorph == self ifTrue:[super invalidRect: rect from: self] ifFalse:[super invalidRect: (self transform localBoundsToGlobal: rect) from: aMorph].! ! !MatrixTransformMorph methodsFor: 'menus' stamp: 'jcg 11/1/2001 13:03'! setRotationCenterFrom: aPoint super setRotationCenterFrom: (self transformFromWorld localPointToGlobal: aPoint) ! ! !MatrixTransformMorph methodsFor: 'geometry etoy' stamp: 'AlainPlantec 5/7/2010 23:54'! heading "Return the receiver's heading (in eToy terms)" ^ self forwardDirection + self innerAngle! ! !MatrixTransformMorph methodsFor: 'halos and balloon help' stamp: 'SeanDeNigris 1/29/2013 13:57'! balloonHelpTextForHandle: aHandle (aHandle eventHandler mouseSelectorsInclude: #changeRotationCenter:with:) ifTrue:[^'set center of rotation']. ^super balloonHelpTextForHandle: aHandle! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'! lastRotationDegrees ^(self valueOfProperty: #lastRotationDegrees) ifNil:[0.0].! ! !MatrixTransformMorph methodsFor: 'initialize' stamp: 'wiz 11/6/2005 16:58'! asFlexOf: aMorph "Initialize me with position and bounds of aMorph, and with an offset that provides centered rotation." self addMorph: aMorph. self setRotationCenterFrom: aMorph center . self lastRotationDegrees: 0.0. self computeBounds! ! !MatrixTransformMorph methodsFor: 'geometry etoy' stamp: 'ar 6/12/2001 05:11'! rotationCenter | pt | pt := self transform localPointToGlobal: super rotationCenter. ^pt - bounds origin / bounds extent asFloatPoint! ! !MatrixTransformMorph methodsFor: 'layout' stamp: 'nice 1/5/2010 15:59'! fullBounds fullBounds ifNil:[ fullBounds := self bounds. submorphs do:[:m| | subBounds | subBounds := (self transform localBoundsToGlobal: m fullBounds). fullBounds := fullBounds quickMerge: subBounds. ]. ]. ^fullBounds! ! !MatrixTransformMorph methodsFor: 'geometry' stamp: 'nice 1/5/2010 15:59'! computeBounds | box | (submorphs isNil or:[submorphs isEmpty]) ifTrue:[^self]. box := nil. submorphs do:[:m| | subBounds | subBounds := self transform localBoundsToGlobal: m bounds. box ifNil:[box := subBounds] ifNotNil:[box := box quickMerge: subBounds]. ]. box ifNil:[box := 0@0 corner: 20@20]. fullBounds := bounds := box! ! !MatrixTransformMorph methodsFor: 'event handling' stamp: 'ar 9/12/2000 01:22'! transformFrom: uberMorph (owner isNil or:[self == uberMorph]) ifTrue:[^self transform]. ^(owner transformFrom: uberMorph) asMatrixTransform2x3 composedWithLocal: self transform! ! !MatrixTransformMorph methodsFor: 't-rotating' stamp: ''! rotationDegrees "Default implementation." ^ 0.0 ! ! !MatrixTransformMorph methodsFor: 'private' stamp: 'ar 6/12/2001 06:38'! privateFullMoveBy: delta self privateMoveBy: delta. transform offset: transform offset + delta.! ! !MaybeContextInstanceVariableNode commentStamp: ''! This class conspires to arrange that inst var access for contexts is done exclusively using the long-form instance variabl;e access bytecodes. See InstructionStream class>>variablesAndOffsetsDo:. A virtual machine can benefit in performance by organizing method and block activations using a more conventional stack organization than by using first-class activation records (contexts). But such a virtual machine is also cabable of hiding the stack and making it appear as if contexts are still used. This means the system has better performance but still has all the benefits of first-class activation records. To pull this off the VM needs to intercept any and all accesses to context objects so that it can make contexts function as proxy objects for stack frames. Without help from the image such a virtual machine based on an interpreter would have to perform an expensive check on all instance variable accesses to determine if the instance variable was that of a context serving as a proxy for a stack frame. A simple hack is to take advantage of the short and long forms of instance variable access bytecodes. The BlueBook instruction set (and likely any bytecode set evolved from it) has short form bytecodes for fetching and storing the first few bytecodes (BlueBook fetch first 16, store first 8). Contexts typically have at most 6 instance variables. If we arrange to use the long-form bytecodes for all context inst var accesses then we only have to check for context inst var access in long-form bytecodes, and then only if the index is within the context inst var range. This effectively makes the check free because on modern processors checking an index fetched from memory into a register against a constant costs far less than the memry read to fetch the index.! !MaybeContextInstanceVariableNode methodsFor: 'accessing' stamp: 'eem 6/19/2008 09:27'! code "Answer a bogus code to avoid creating quick methods. See MethodNode>>generate:ifQuick:" ^LoadLong! ! !MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:08'! emitCodeForStore: stack encoder: encoder encoder genStoreInstVarLong: index! ! !MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:07'! sizeCodeForStorePop: encoder ^encoder sizeStorePopInstVarLong: index! ! !MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:08'! emitCodeForValue: stack encoder: encoder stack push: 1. ^encoder genPushInstVarLong: index! ! !MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:57'! sizeCodeForStore: encoder ^encoder sizeStoreInstVarLong: index! ! !MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 6/19/2008 09:36'! emitCodeForStorePop: stack encoder: encoder encoder genStorePopInstVarLong: index. stack pop: 1! ! !MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:53'! sizeCodeForValue: encoder ^encoder sizePushInstVarLong: index! ! !MczInstaller commentStamp: 'TorstenBergmann 1/31/2014 10:14'! An installer for Monticello files with the *.mcz extension. MczInstaller installFileNamed: 'MyKillerApp-Core-Author.1.mcz'! !MczInstaller methodsFor: 'installation' stamp: 'nicolascellier 6/2/2013 18:38'! installMember: member self useNewChangeSetDuring: [ CodeImporter evaluateReadStream: (self contentsForMember: member) readStream. ]! ! !MczInstaller methodsFor: 'parsing' stamp: 'nicolascellier 6/2/2013 18:36'! contentsForMember: member ^[(member contentStreamFromEncoding: 'utf8') text contents] on: ZnInvalidUTF8 do: [:exc | "Case of legacy encoding, presumably it is latin-1. But if contents starts with a null character, it might be a case of WideString encoded in UTF-32BE" | str | str := (member contentStreamFromEncoding: 'latin1') text. exc return: ((str peek = Character null and: [ str size \\ 4 = 0 ]) ifTrue: [WideString fromByteArray: str contents asByteArray] ifFalse: [str contents])]! ! !MczInstaller methodsFor: 'utilities' stamp: 'avi 2/17/2004 02:53'! checkDependencies | dependencies unmet | dependencies := (zip membersMatching: 'dependencies/*') collect: [:member | self extractInfoFrom: (self parseMember: member)]. unmet := dependencies reject: [:dep | self versions: Versions anySatisfy: (dep at: #id)]. ^ unmet isEmpty or: [ self confirm: (String streamContents: [:s| s nextPutAll: 'The following dependencies seem to be missing:'; cr. unmet do: [:each | s nextPutAll: (each at: #name); cr]. s nextPutAll: 'Do you still want to install this package?'])]! ! !MczInstaller methodsFor: 'utilities' stamp: 'bf 2/9/2004 15:00'! versions: aVersionList anySatisfy: aDependencyID ^ aVersionList anySatisfy: [:version | aDependencyID = (version at: #id) or: [self versions: (version at: #ancestors) anySatisfy: aDependencyID]]! ! !MczInstaller methodsFor: 'utilities' stamp: 'avi 2/17/2004 03:26'! extractInfoFrom: dict dict at: #id put: (UUID fromString: (dict at: #id)). dict at: #date ifPresent: [:d | d isEmpty ifFalse: [dict at: #date put: (Date fromString: d)]]. dict at: #time ifPresent: [:t | t isEmpty ifFalse: [dict at: #time put: (Time readFrom: t readStream)]]. dict at: #ancestors ifPresent: [:a | dict at: #ancestors put: (a collect: [:ea | self extractInfoFrom: ea])]. ^ dict! ! !MczInstaller methodsFor: 'accessing' stamp: 'avi 2/17/2004 02:55'! stream: aStream stream := aStream! ! !MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/13/2003 02:17'! extractVersionInfo ^ self extractInfoFrom: (self parseMember: 'version')! ! !MczInstaller methodsFor: 'utilities' stamp: 'nicolascellier 6/2/2013 18:37'! parseMember: memberOrName | member tokens | member := self zip member: memberOrName. tokens := (self contentsForMember: member) parseLiterals first. ^ self associate: tokens! ! !MczInstaller methodsFor: 'private' stamp: 'nicolascellier 5/31/2013 23:35'! contentStreamForMember: member ^[(member contentStreamFromEncoding: 'utf8') text] on: ZnInvalidUTF8 do: [:exc | "Case of legacy encoding, presumably it is latin-1 and we do not need to do anything But if contents starts with a null character, it might be a case of WideString encoded in UTF-32BE" | str | str := (member contentStreamFromEncoding: 'latin1') text. (str peek = Character null and: [ str size \\ 4 = 0 ]) ifTrue: [str := (WideString fromByteArray: str contents asByteArray) readStream]. exc return: str]! ! !MczInstaller methodsFor: 'accessing' stamp: 'md 6/11/2013 10:00'! zip ^zip! ! !MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/13/2003 01:58'! extractPackageName ^ (self parseMember: 'package') at: #name. ! ! !MczInstaller methodsFor: 'installation' stamp: 'avi 2/17/2004 02:56'! install | sources | zip := ZipArchive new. zip readFrom: stream. self checkDependencies ifFalse: [^false]. self recordVersionInfo. sources := (zip membersMatching: 'snapshot/*') asSortedCollection: [:a :b | a fileName < b fileName]. sources do: [:src | self installMember: src].! ! !MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/7/2003 19:18'! recordVersionInfo Versions at: self extractPackageName put: self extractVersionInfo! ! !MczInstaller methodsFor: 'utilities' stamp: 'bf 2/9/2004 13:56'! useNewChangeSetDuring: aBlock | changeHolder oldChanges newChanges | changeHolder := (ChangeSet respondsTo: #newChanges:) ifTrue: [ChangeSet] ifFalse: [Smalltalk]. oldChanges := (ChangeSet respondsTo: #current) ifTrue: [ChangeSet current] ifFalse: [Smalltalk changes]. newChanges := ChangeSet new name: (ChangeSet uniqueNameLike: self extractPackageName). changeHolder newChanges: newChanges. [aBlock value] ensure: [changeHolder newChanges: oldChanges].! ! !MczInstaller methodsFor: 'utilities' stamp: 'stephane.ducasse 3/31/2009 21:10'! associate: tokens | result | result := Dictionary new. tokens pairsDo: [:key :value | | tmp | tmp := value. value isString ifFalse: [tmp := value collect: [:ea | self associate: ea]]. value = 'nil' ifTrue: [tmp := '']. result at: key put: tmp]. ^ result! ! !MczInstaller class methodsFor: 'System-FileRegistry' stamp: 'cwp 8/7/2003 18:49'! extension ^ 'mcz'! ! !MczInstaller class methodsFor: 'System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:21'! fileReaderServicesForFile: fileName suffix: suffix ^({ self extension. '*' } includes: suffix) ifTrue: [ self services ] ifFalse: [#()]. ! ! !MczInstaller class methodsFor: 'installing' stamp: 'cwp 8/7/2003 17:56'! installStream: aStream (self on: aStream) install! ! !MczInstaller class methodsFor: 'versioninfo' stamp: 'avi 2/17/2004 02:49'! versionInfo ^ Versions! ! !MczInstaller class methodsFor: 'versioninfo' stamp: 'avi 1/19/2004 13:13'! clearVersionInfo Versions := Dictionary new! ! !MczInstaller class methodsFor: 'System-FileRegistry' stamp: 'cwp 8/7/2003 18:54'! loadVersionFile: fileName self installFileNamed: fileName ! ! !MczInstaller class methodsFor: 'System-FileRegistry' stamp: 'avi 3/7/2004 14:51'! initialize self clearVersionInfo. self registerForFileList.! ! !MczInstaller class methodsFor: 'System-FileRegistry' stamp: 'ab 8/8/2003 18:01'! services ^ Array with: self serviceLoadVersion! ! !MczInstaller class methodsFor: 'versioninfo' stamp: 'cwp 8/11/2003 23:49'! storeVersionInfo: aVersion Versions at: aVersion package name put: aVersion info asDictionary! ! !MczInstaller class methodsFor: 'installing' stamp: 'cwp 8/7/2003 18:13'! installFileNamed: aFileName self installStream: (FileStream readOnlyFileNamed: aFileName)! ! !MczInstaller class methodsFor: 'instance creation' stamp: 'cwp 8/7/2003 17:56'! on: aStream ^ self new stream: aStream! ! !MczInstaller class methodsFor: 'System-FileRegistry' stamp: 'tbn 8/11/2010 10:20'! serviceLoadVersion ^ SimpleServiceEntry provider: self label: 'Load' selector: #loadVersionFile: description: 'Load a package version'! ! !MczInstaller class methodsFor: 'System-FileRegistry' stamp: 'IgorStasenko 4/15/2011 17:17'! registerForFileList Smalltalk globals at: #MCReader ifAbsent: [ Smalltalk tools fileList registerFileReader: self ]! ! !MemoryFileSystemDirectory commentStamp: ''! I represent a memory file system entry for a directory! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 6/17/2013 10:42'! fileEntryRemove: aFileName ^ self fileEntryRemove: aFileName ifAbsent: [ FileDoesNotExist signalWith: aFileName ]! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 20:02'! entries ^ entries! ! !MemoryFileSystemDirectory methodsFor: 'creation' stamp: 'S 6/17/2013 13:32'! ensureCreateFile: aFileName ^ self fileEntryAt: aFileName put: (MemoryFileSystemFile named: aFileName)! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 6/17/2013 10:40'! fileEntryRemove: aFileName ifAbsent: absentBlock | deletedEntry | deletedEntry := entries removeKey: aFileName ifAbsent: [ ^ absentBlock value ]. modificationTime := DateAndTime now. ^ deletedEntry! ! !MemoryFileSystemDirectory methodsFor: 'testing' stamp: 'CamilloBruni 6/22/2012 20:02'! isDirectory ^ true! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 14:47'! fileEntryAt: aFileName ifAbsent: aBlock ^ entries at: aFileName ifAbsent: aBlock! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 14:54'! fileSize ^ 0! ! !MemoryFileSystemDirectory methodsFor: 'enumeration' stamp: 'MarcusDenker 10/7/2013 21:24'! fileEntriesDo: aBlock entries keys sort do: [ :fileName| aBlock value: (entries at: fileName)].! ! !MemoryFileSystemDirectory methodsFor: 'initialization' stamp: 'CamilloBruni 6/22/2012 20:00'! initialize super initialize. entries := Dictionary new.! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 5/24/2013 14:03'! fileEntriesIncludes: aFileName ^ entries includesKey: aFileName! ! !MemoryFileSystemDirectory methodsFor: 'creation' stamp: 'S 6/17/2013 13:33'! ensureCreateDirectory: aDirectoryName ^ self fileEntryAt: aDirectoryName put: (MemoryFileSystemDirectory named: aDirectoryName)! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 5/24/2013 13:59'! fileEntryAt: aFileName ^ entries at: aFileName! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 5/24/2013 13:55'! fileEntryAt: aFileName put: anEntry ^ entries at: aFileName ifAbsentPut: [ self modified. anEntry ]! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 14:48'! fileEntryAt: aFileName ifPresent: aBlock ^ entries at: aFileName ifPresent: aBlock! ! !MemoryFileSystemEntry commentStamp: ''! I am an abstract file system entry for a memory file system. My subclasses should specialize on the kind of file they are.! !MemoryFileSystemEntry methodsFor: 'accessing' stamp: 'PavelKrivanek 11/23/2012 12:21'! fileSize self subclassResponsibility ! ! !MemoryFileSystemEntry methodsFor: 'initialization' stamp: 'CamilloBruni 6/22/2012 20:27'! initialize creationTime := modificationTime := DateAndTime now. super initialize! ! !MemoryFileSystemEntry methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 14:46'! basename: aString basename := aString! ! !MemoryFileSystemEntry methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 19:59'! modificationTime: anObject modificationTime := anObject! ! !MemoryFileSystemEntry methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 19:59'! creationTime ^ creationTime! ! !MemoryFileSystemEntry methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 22:05'! modified modificationTime := DateAndTime now.! ! !MemoryFileSystemEntry methodsFor: 'testing' stamp: 'CamilloBruni 6/22/2012 20:13'! isFile ^ self isDirectory not! ! !MemoryFileSystemEntry methodsFor: 'testing' stamp: 'PavelKrivanek 11/23/2012 12:21'! isDirectory self subclassResponsibility! ! !MemoryFileSystemEntry methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 14:46'! basename ^ basename! ! !MemoryFileSystemEntry methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 19:59'! modificationTime ^ modificationTime! ! !MemoryFileSystemEntry class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 7/10/2012 14:53'! named: aFileName ^ self new basename: aFileName; yourself! ! !MemoryFileSystemFile commentStamp: ''! I represent a memory file system entry for a regular file! !MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: 'CamilloBruni 6/22/2012 22:15'! copyFrom: from to: position ^ bytes copyFrom: from to: position! ! !MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: 'CamilloBruni 6/23/2012 19:58'! grow self grownBy: self sizeIncrement! ! !MemoryFileSystemFile methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 22:01'! updateSize: newSize size := newSize. modificationTime := nil.! ! !MemoryFileSystemFile methodsFor: 'streams-compatibility' stamp: 'MaxLeske 1/25/2014 23:04'! binaryReadStream ^ ReadStream on: bytes from: 1 to: size! ! !MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: 'CamilloBruni 6/22/2012 21:25'! at: first write: aCollection startingAt: start count: count | last | last := first + count - 1. last > bytes size ifTrue: [ self grownBy: last - size ]. bytes replaceFrom: first to: last with: aCollection startingAt: start. size := last! ! !MemoryFileSystemFile methodsFor: 'testing' stamp: 'CamilloBruni 6/22/2012 20:02'! isDirectory ^ false! ! !MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: 'DamienCassou 11/27/2013 17:44'! readStream ^ ReadStream on: bytes asString from: 1 to: size! ! !MemoryFileSystemFile methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 20:57'! sizeIncrement ^ (bytes size min: 20) max: 1024! ! !MemoryFileSystemFile methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 14:54'! fileSize ^ size! ! !MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: 'CamilloBruni 6/22/2012 20:54'! at: index read: aCollection startingAt: start count: count | max stop | max := size - index + 1 min: count. stop := start + max - 1. aCollection replaceFrom: start to: stop with: bytes startingAt: index. ^ stop - start + 1! ! !MemoryFileSystemFile methodsFor: 'initialization' stamp: 'CamilloBruni 6/22/2012 20:53'! initialize super initialize. bytes := #[]. size := 0! ! !MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: 'CamilloBruni 6/22/2012 20:53'! at: index put: anObject index > bytes size ifTrue: [ self grow ]. bytes at: index put: (anObject isCharacter ifTrue: [ anObject codePoint ] ifFalse: [ anObject ]). size := size max: index! ! !MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: 'CamilloBruni 6/22/2012 20:54'! at: index self flag: #todo. "out of bounds checks?" ^ bytes at: index! ! !MemoryFileSystemFile methodsFor: 'stream-protocol' stamp: 'CamilloBruni 6/22/2012 22:16'! writeStream self flag: #todo. "need a nicer abstraction here to keep a shared bytes without calling grownBy on every at:put:" ^ WriteStream on: self from: 1 to: size! ! !MemoryFileSystemFile methodsFor: 'accessing' stamp: 'CamilloBruni 6/23/2012 18:48'! bytes ^ bytes! ! !MemoryFileSystemFile methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 22:10'! grownBy: length bytes := bytes grownBy: length. self modified.! ! !MemoryFileSystemFile methodsFor: 'accessing' stamp: 'CamilloBruni 6/23/2012 18:48'! internalSize ^ bytes size! ! !MemoryFileSystemFile methodsFor: 'accessing' stamp: 'CamilloBruni 6/23/2012 20:16'! truncate self truncateTo: size! ! !MemoryFileSystemFile methodsFor: 'accessing' stamp: 'nice 11/17/2013 23:03'! truncateTo: aSize bytes size = aSize ifFalse: [bytes := bytes size < aSize ifTrue: [(ByteArray new: aSize) replaceFrom: 1 to: bytes size with: bytes startingAt: 1] ifFalse: [bytes copyFrom: 1 to: aSize]]. size := bytes size. self modified.! ! !MemoryFileSystemTest commentStamp: 'TorstenBergmann 1/31/2014 11:48'! SUnit tests for MemoryFileSystem! !MemoryFileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 11:42'! testEqual | other | other := self createFileSystem. self deny: filesystem = other! ! !MemoryFileSystemTest methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 4/3/2012 13:04'! createFileSystem ^ FileSystem memory! ! !MemoryHandle commentStamp: ''! I provide "primitives" for doing IO on files in a MemoryFileSystem. I delegate most of my actions to the MemoryFile. This way there is only one place needed where the data is stored.! !MemoryHandle methodsFor: 'stream-protocol' stamp: 'CamilloBruni 6/23/2012 19:57'! copyFrom: from to: position ^ entry copyFrom: from to: position! ! !MemoryHandle methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 20:56'! grow entry grow! ! !MemoryHandle methodsFor: 'public' stamp: 'CamilloBruni 6/23/2012 18:48'! size "return the size for the interna" ^ entry internalSize! ! !MemoryHandle methodsFor: 'public' stamp: 'CamilloBruni 6/23/2012 20:06'! close self isOpen ifFalse: [ ^ self ]. self truncate. entry := nil.! ! !MemoryHandle methodsFor: 'testing' stamp: 'CamilloBruni 6/22/2012 20:57'! isOpen ^ entry notNil! ! !MemoryHandle methodsFor: 'streams-compatibility' stamp: 'MaxLeske 1/25/2014 23:03'! binaryReadStream ^ entry binaryReadStream! ! !MemoryHandle methodsFor: 'public' stamp: 'CamilloBruni 6/22/2012 20:55'! at: first write: aCollection startingAt: start count: count writable ifFalse: [ self primitiveFailed ]. entry at: first write: aCollection startingAt: start count: count.! ! !MemoryHandle methodsFor: 'stream-protocol' stamp: 'DamienCassou 11/27/2013 17:35'! readStream "Return a readstream on my contents. Using myself as target collection allows to share the internal bytearray between multiple streams." ^ entry readStream! ! !MemoryHandle methodsFor: 'public' stamp: 'CamilloBruni 6/22/2012 20:55'! at: index read: aCollection startingAt: start count: count ^ entry at: index read: aCollection startingAt: start count: count ! ! !MemoryHandle methodsFor: 'public' stamp: 'CamilloBruni 6/22/2012 20:52'! at: index put: anObject ^ entry at: index put: anObject! ! !MemoryHandle methodsFor: 'public' stamp: 'CamilloBruni 6/22/2012 20:52'! at: index ^ entry at: index! ! !MemoryHandle methodsFor: 'stream-protocol' stamp: 'CamilloBruni 7/10/2012 14:54'! writeStream "Return a writestream on my contents. Using myself as target collection allows to share the internal bytearray between multiple streams." ^ WriteStream on: self from: 1 to: entry fileSize! ! !MemoryHandle methodsFor: 'public' stamp: 'CamilloBruni 6/22/2012 20:56'! flush self truncate! ! !MemoryHandle methodsFor: 'public' stamp: 'CamilloBruni 6/22/2012 20:57'! open entry := self basicOpen.! ! !MemoryHandle methodsFor: 'stream-protocol' stamp: 'CamilloBruni 6/23/2012 18:47'! grownBy: length entry grownBy: length! ! !MemoryHandle methodsFor: 'public' stamp: 'CamilloBruni 6/22/2012 20:58'! truncate entry truncate! ! !MemoryHandle methodsFor: 'public' stamp: 'CamilloBruni 6/23/2012 20:16'! truncateTo: anInteger entry truncateTo: anInteger! ! !MemoryHandleTest commentStamp: 'TorstenBergmann 1/31/2014 11:49'! SUnit tests for memory handles, the tests may be found in superclass! !MemoryHandleTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/3/2012 12:51'! createFileSystem ^ FileSystem memory! ! !MemoryStore commentStamp: ''! I'm a specific store for memory file system! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 20:04'! basicIsFile: aMemoryFileSystemEntry ^ aMemoryFileSystemEntry isFile! ! !MemoryStore methodsFor: 'private' stamp: 'DamienCassou 6/8/2013 10:52'! copy: sourcePath ifAbsent: absentBlock to: destinationPath ifPresent: presentBlock fileSystem: aFilesystem | sourceNode destinationNode | sourceNode := self nodeAt: sourcePath ifPresent: [ :source | source ] ifAbsent: [ ^ absentBlock value]. sourceNode isDirectory ifTrue: [ ^ absentBlock value ]. destinationNode := self nodeAt: destinationPath parent ifPresent: [ :destination | destination ] ifAbsent: [ ^ self signalDirectoryDoesNotExist: destinationPath parent ]. destinationNode isFile ifTrue: [ self signalDirectoryDoesNotExist: destinationPath parent ]. (destinationNode fileEntriesIncludes: destinationPath basename) ifTrue: [ "cannot overwrite existing file"^ presentBlock value ]. destinationNode fileEntryAt: destinationPath basename put: (sourceNode copy basename: destinationPath basename; yourself) ! ! !MemoryStore methodsFor: 'private' stamp: 'S 6/17/2013 13:32'! createFile: aPath ^ self nodeAt: aPath parent ifPresent: [ :entry | entry isDirectory ifTrue: [ entry ensureCreateFile: aPath basename ]] ifAbsent: [ self signalDirectoryDoesNotExist: aPath parent ]! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 14:52'! nodeAt: aPath ifPresent: presentBlock ifAbsent: absentBlock | current | current := self root. aPath do: [ :segment | current isDirectory ifTrue: [ current := current fileEntryAt: segment ifAbsent: [ ^ absentBlock value ]] ifFalse: [ ^ absentBlock value ]]. ^ presentBlock value: current! ! !MemoryStore methodsFor: 'accessing' stamp: 'cwp 2/18/2011 12:46'! root ^ root! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 5/5/2013 01:13'! basicEntry: entry nodesDo: aBlock entry fileEntriesDo: aBlock! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 21:13'! basicSize: aMemoryFileSystemEntry ^ aMemoryFileSystemEntry fileSize! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 14:52'! replaceFile: path in: aBlock ^ self nodeAt: path parent ifPresent: [ :entry | | old new | entry isDirectory ifFalse: [ self signalFileDoesNotExist: path ]. old := entry fileEntryAt: path basename ifAbsent: [ self signalFileDoesNotExist: path ]. new := aBlock value: old. entry fileEntryAt: path basename put: new ] ifAbsent: [ self signalFileDoesNotExist: path ]! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 21:06'! basicOpen: path writable: aBoolean ^ self nodeAt: path ifPresent: [ :aMemoryFileSystemEntry | aMemoryFileSystemEntry ] ifAbsent: [ aBoolean ifFalse: [ self signalFileDoesNotExist: path ] ifTrue: [ self createFile: path ] ]! ! !MemoryStore methodsFor: 'public' stamp: 'S 6/17/2013 13:33'! createDirectory: path | parent | parent := path parent. ^ self nodeAt: parent ifPresent: [ :entry | entry fileEntryAt: path basename ifPresent: [ :node | node isDirectory ifTrue: [ self signalDirectoryExists: path ] ifFalse: [ self signalFileExists: path ] ]. entry ensureCreateDirectory: path basename ] ifAbsent: [ self signalDirectoryDoesNotExist: parent ]! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 5/5/2013 01:17'! basicEntry: directoryEntry path: aPath nodesDo: aBlock directoryEntry fileEntriesDo: aBlock! ! !MemoryStore methodsFor: 'public' stamp: 'CamilloBruni 5/24/2013 14:05'! rename: sourcePath to: destinationPath | sourceEntry destinationParentEntry newName | sourceEntry := self nodeAt: sourcePath. newName := destinationPath basename. destinationParentEntry := self nodeAt: destinationPath parent. destinationParentEntry isDirectory ifFalse: [ Error signal: 'Copy destination has to be a directory' ]. destinationParentEntry fileEntryAt: newName ifPresent: [ Error signal: 'Destination file exists already' ]. destinationParentEntry fileEntryAt: newName put: sourceEntry. sourceEntry basename: newName. (self nodeAt: sourcePath parent) fileEntryRemove: sourcePath basename ! ! !MemoryStore methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 14:51'! basenameFromEntry: aMemoryFileSystemEntry ^ aMemoryFileSystemEntry basename! ! !MemoryStore methodsFor: 'initialization' stamp: 'CamilloBruni 6/22/2012 20:16'! initialize root := MemoryFileSystemDirectory new! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 21:18'! basicPosixPermissions: anEntry ^ 8r777! ! !MemoryStore methodsFor: 'private' stamp: 'EstebanLorenzano 8/2/2012 15:39'! basicIsSymlink: aNode ^false! ! !MemoryStore methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/3/2012 09:36'! handleClass ^ MemoryHandle ! ! !MemoryStore methodsFor: 'public' stamp: 'CamilloBruni 6/22/2012 21:21'! openFileStream: path writable: isWriteStream | entry | entry := self basicOpen: path writable: isWriteStream. ^ isWriteStream ifTrue: [ entry writeStream ] ifFalse: [ entry readStream ]! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 20:57'! basicCreationTime: aMemoryFileSystemEntry ^ aMemoryFileSystemEntry creationTime! ! !MemoryStore methodsFor: 'public' stamp: 'CamilloBruni 5/10/2012 16:02'! checkName: aString fixErrors: fixErrors aString ifEmpty: [ self error: 'zero length file name' ]. ^ aString! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 20:30'! basicIsDirectory: aMemoryFileSystemEntry ^ aMemoryFileSystemEntry isDirectory! ! !MemoryStore methodsFor: 'printing' stamp: 'CamilloBruni 9/5/2012 17:43'! forReferencePrintOn: aStream aStream nextPutAll: 'memory://'! ! !MemoryStore methodsFor: 'public' stamp: 'CamilloBruni 6/17/2013 10:51'! delete: path self nodeAt: path parent ifPresent: [ :dict | dict fileEntryRemove: path basename ifAbsent: [ FileDoesNotExist signalWith: path ]] ifAbsent: [ DirectoryDoesNotExist signalWith: path parent ]! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 20:57'! basicModificationTime: aMemoryFileSystemEntry ^ aMemoryFileSystemEntry modificationTime! ! !MemoryStore class methodsFor: 'public' stamp: 'CamilloBruni 5/7/2012 01:20'! isCaseSensitive ^ true! ! !MemoryStore class methodsFor: 'public' stamp: 'CamilloBruni 5/7/2012 01:11'! separator ^ $:! ! !MemoryStore class methodsFor: 'public' stamp: 'cwp 2/18/2011 17:19'! delimiter ^ $/! ! !MenuCapturingMorph commentStamp: 'SeanDeNigris 2/20/2014 08:47'! It's difficult to test whether menus appear because the test might block the UI thread and prevent it. I use Morphic stepping to monitor the world for a new menu. If I find one, you can get it by sending me #menu.! !MenuCapturingMorph methodsFor: 'menu' stamp: 'SeanDeNigris 12/14/2011 14:06'! menu ^ menu.! ! !MenuCapturingMorph methodsFor: 'stepping and presenter' stamp: 'SeanDeNigris 12/14/2011 14:08'! step menu := World submorphs detect: [ :m | m isKindOf: MenuMorph ] ifNone: [ menu ]. menu isNil ifFalse: [ menu delete. self delete ].! ! !MenuGroupModel commentStamp: ''! I am a group of menu items. I am part of a menu, and groups items by meaning! !MenuGroupModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 18:33'! autoRefresh: aBoolean autoRefresh value: aBoolean! ! !MenuGroupModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. items := OrderedCollection new asReactiveVariable. autoRefresh := nil asReactiveVariable. autoRefresh whenChangedDo: [ :aBoolean | self menuItems do: [ :each | each autoRefresh: aBoolean ] ]! ! !MenuGroupModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 14:07'! menuItems ^ items value! ! !MenuGroupModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/1/2013 14:09'! buildWithSpecLayout: aSpecLayout "Build the widget using the spec name provided as argument" | widget | widget := SpecInterpreter interpretASpec: aSpecLayout model: self. widget := widget asWidget. self announce: (WidgetBuilt model: self widget: widget). ^ widget! ! !MenuGroupModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/1/2013 18:34'! addMenuItem: aMenuItem items add: aMenuItem. self autoRefresh ifNotNil: [ aMenuItem autoRefresh: self autoRefresh ]! ! !MenuGroupModel methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 1/11/2014 20:11'! isEmpty ^ items isEmpty! ! !MenuGroupModel methodsFor: 'protocol-building' stamp: 'BenjaminVanRyseghem 11/29/2013 15:01'! fromSpec: aSpec aSpec addToMenuGroupModel: self! ! !MenuGroupModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 15:34'! addItem: aBlock | item | item := MenuItemModel new. aBlock value: item. self addMenuItem: item! ! !MenuGroupModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 18:33'! autoRefresh ^ autoRefresh value! ! !MenuGroupModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/1/2013 16:25'! defaultSpec ^ #(MenuGroupAdapter adapt: #(model))! ! !MenuGroupModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:22'! adapterName ^ #MenuGroupAdapter! ! !MenuItemModel commentStamp: ''! I represent a menu item. I have a name, a description, an icon, a shortcut, and an action to perform (aBlock). I can also have a sub menu. (and usually I do NOT have an action AND a sub menu)! !MenuItemModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/1/2013 15:08'! state: aBoolean state value: aBoolean! ! !MenuItemModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! subMenu: aMenuModel subMenu value: aMenuModel! ! !MenuItemModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 18:14'! description ^ description value! ! !MenuItemModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/1/2013 15:08'! enabled ^ enabled value! ! !MenuItemModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/10/2014 15:19'! performMenuActionWith: aMenuItem | en | en := self enabled. en isBlock ifTrue: [ en := en value ]. en ifFalse: [ ^ self ]. action value cull: aMenuItem! ! !MenuItemModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! shortcut: aShortcut shortcut value: aShortcut! ! !MenuItemModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/1/2013 15:07'! action: aBlock action value: aBlock! ! !MenuItemModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! shortcut ^ shortcut value! ! !MenuItemModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/1/2013 18:30'! autoRefresh: aBlock autoRefresh value: aBlock! ! !MenuItemModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/29/2013 15:26'! icon: anIcon icon value: anIcon! ! !MenuItemModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/1/2013 15:08'! state ^ state value! ! !MenuItemModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! subMenu ^ subMenu value! ! !MenuItemModel methodsFor: 'protocol-building' stamp: 'BenjaminVanRyseghem 11/29/2013 15:02'! fromSpec: aSpec aSpec addToMenuItemModel: self! ! !MenuItemModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/1/2013 15:10'! action ^ action value! ! !MenuItemModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. action := [] asReactiveVariable. enabled := true asReactiveVariable. state := nil asReactiveVariable. description := nil asReactiveVariable. name := '' asReactiveVariable. shortcut := nil asReactiveVariable. subMenu := nil asReactiveVariable. autoRefresh := false asReactiveVariable. icon := nil asReactiveVariable! ! !MenuItemModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! name: aString name value: aString! ! !MenuItemModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 18:14'! description: aString description value: aString! ! !MenuItemModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/1/2013 18:30'! autoRefresh ^ autoRefresh value! ! !MenuItemModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/1/2013 15:08'! enabled: aBoolean enabled value: aBoolean! ! !MenuItemModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! name ^ name value! ! !MenuItemModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 17:56'! icon ^ icon value! ! !MenuItemModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/1/2013 16:25'! defaultSpec ^ #(MenuItemAdapter adapt: #(model))! ! !MenuItemModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:22'! adapterName ^ #MenuItemAdapter! ! !MenuItemMorph commentStamp: 'StephaneDucasse 4/22/2012 16:43'! I represent an item in a menu. Instance variables: isEnabled True if the menu item can be executed. subMenu The submenu to activate automatically when the user mouses over the item. isSelected True if the item is currently selected. target The target of the associated action. selector The associated action. arguments The arguments for the associated action. icon An optional icon form to be displayed to my left. ! !MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:19'! hasIcon "Answer whether the receiver has an icon." ^ icon notNil! ! !MenuItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/17/2008 14:43'! enabled "Delegate to exisitng method." ^self isEnabled! ! !MenuItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'MarcusDenker 12/11/2009 07:40'! themeChanged "Also pass on to the submenu if any." super themeChanged. self subMenu ifNotNil: [:m | m themeChanged]! ! !MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:38'! activateOwnerMenu: evt "Activate our owner menu; e.g., pass control to it" owner ifNil:[^false]. "not applicable" (owner fullContainsPoint: evt position) ifFalse:[^false]. owner activate: evt. ^true! ! !MenuItemMorph methodsFor: 'selecting' stamp: 'dgd 9/9/2004 21:26'! isSelected ^ isSelected ! ! !MenuItemMorph methodsFor: 'private' stamp: 'StephaneDucasse 4/23/2012 12:26'! offImage "Return the form to be used for indicating an off marker" | form | form := Form extent: (self fontToUse ascent-2) asPoint depth: 16. (form getCanvas) frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.9) borderWidth: 1 borderColor: Color black. ^form! ! !MenuItemMorph methodsFor: 'events' stamp: 'jm 11/4/97 07:15'! handlesMouseDown: evt ^ true ! ! !MenuItemMorph methodsFor: 'private' stamp: 'dgd 3/31/2006 12:16'! upArrow ^ ColorForm mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 270)asFormOfDepth: 8)! ! !MenuItemMorph methodsFor: 'events' stamp: 'ar 9/16/2000 14:40'! handlesMouseOver: anEvent ^true! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'sw 10/3/2002 20:50'! allWordingsNotInSubMenus: verbotenSubmenuContentsList "Answer a collection of the wordings of all items and subitems, but omit the stay-up item, and also any items in any submenu whose tag is in verbotenSubmenuContentsList" self isStayUpItem ifTrue:[^ #()]. subMenu ifNotNil: [^ (verbotenSubmenuContentsList includes: self contents asString) ifTrue: [#()] ifFalse: [subMenu allWordingsNotInSubMenus: verbotenSubmenuContentsList]]. ^ Array with: self contents asString! ! !MenuItemMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'! defaultBounds "answer the default bounds for the receiver" ^ 0 @ 0 extent: 10 @ 10! ! !MenuItemMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/29/2009 22:02'! initialize "initialize the state of the receiver" super initialize. "" contents := ''. hasFocus := false. isEnabled := true. subMenu := nil. isSelected := false. target := nil. selector := nil. arguments := nil. font := StandardFonts menuFont. self hResizing: #spaceFill; vResizing: #shrinkWrap! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 18:38'! contents: aString withMarkers: aBool inverse: inverse "Set the menu item entry. If aBool is true, parse aString for embedded markers." | markerIndex marker | self contentString: nil. "get rid of old" aBool ifFalse: [^super contents: aString]. self removeAllMorphs. "get rid of old markers if updating" self hasIcon ifTrue: [ self icon: nil ]. self flag: #CleanYesNoOnOffAfter. (aString isKindOf: Association) ifTrue: [ super contents: aString value. marker := aString key ifTrue: [self onImage] ifFalse: [self offImage]] ifFalse: [ (aString notEmpty and: [aString first = $<]) ifFalse: [^super contents: aString]. markerIndex := aString indexOf: $>. markerIndex = 0 ifTrue: [^super contents: aString]. marker := (aString copyFrom: 1 to: markerIndex) asLowercase. (#('' '' '' '') includes: marker) ifFalse: [^super contents: aString]. self contentString: aString. "remember actual string" marker := (marker = '' or: [marker = '']) ~= inverse ifTrue: [self onImage] ifFalse: [self offImage]. super contents: (aString copyFrom: markerIndex + 1 to: aString size)]. "And set the marker" marker := ImageMorph new form: marker. marker position: self left @ (self top + 2). self addMorphFront: marker! ! !MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 18:09'! subMenuMarker "private - answer the form to be used as submenu marker" self isInDockingBar ifFalse: [^ self rightArrow]. "" owner isFloating ifTrue: [^ self bottomArrow]. owner isAdheringToTop ifTrue: [^ self bottomArrow]. owner isAdheringToBottom ifTrue: [^ self upArrow]. owner isAdheringToLeft ifTrue:[^ self rightArrow]. owner isAdheringToRight ifTrue:[^ self leftArrow]. "" ^ self rightArrow! ! !MenuItemMorph methodsFor: 'copying' stamp: 'dgd 3/22/2003 14:56'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. isEnabled := isEnabled veryDeepCopyWith: deepCopier. subMenu := subMenu veryDeepCopyWith: deepCopier. isSelected := isSelected veryDeepCopyWith: deepCopier. icon := icon veryDeepCopyWith: deepCopier. "target := target. Weakly copied" "selector := selector. a Symbol" arguments := arguments! ! !MenuItemMorph methodsFor: 'private' stamp: 'StephaneDucasse 4/23/2012 12:26'! onImage "Return the form to be used for indicating an on marker" | form | form := Form extent: (self fontToUse ascent-2) asPoint depth: 16. (form getCanvas) frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.8) borderWidth: 1 borderColor: Color black; fillRectangle: (form boundingBox insetBy: 2) fillStyle: Color black. ^form! ! !MenuItemMorph methodsFor: 'events' stamp: 'StephaneDucasse 6/26/2013 14:39'! invokeWithEvent: evt "Perform the action associated with the given menu item." | w | self isEnabled ifFalse: [^ self]. owner ifNotNil:[self isStayUpItem ifFalse:[ self flag: #workAround. "The tile system invokes menus straightforwardly so the menu might not be in the world." (w := self world) ifNotNil:[ owner deleteIfPopUp: evt. "Repair damage before invoking the action for better feedback" w displayWorldSafely]]]. selector ifNil:[^self]. Cursor normal showWhile: [ | selArgCount | "show cursor in case item opens a new MVC window" (selArgCount := selector numArgs) = 0 ifTrue: [target perform: selector] ifFalse: [selArgCount = arguments size ifTrue: [target perform: selector withArguments: arguments] ifFalse: [target perform: selector withArguments: (arguments copyWith: evt)]]. self changed].! ! !MenuItemMorph methodsFor: 'private' stamp: 'AlainPlantec 12/19/2009 14:13'! selectionFillStyle "answer the fill style to use with the receiver is the selected element" Display depth <= 2 ifTrue: [^ Color gray]. ^ self theme settings menuSelectionColor. ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! target: anObject target := anObject. ! ! !MenuItemMorph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/9/2004 20:25'! noteNewOwner: aMorph "I have just been added as a submorph of aMorph" super noteNewOwner: aMorph. self updateLayoutInDockingBar! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 16:57'! contents: aString withMarkers: aBool ^self contents: aString withMarkers: aBool inverse: false! ! !MenuItemMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 11/1/2013 17:34'! drawOn: aCanvas | stringColor stringBounds | (isSelected and: [ isEnabled ]) ifTrue: [aCanvas fillRectangle: self bounds fillStyle: self selectionFillStyle. stringColor := color negated] ifFalse: [stringColor := color]. stringBounds := bounds. self isInDockingBar ifTrue: [stringBounds := stringBounds left: stringBounds left + 4]. self hasIcon ifTrue: [| iconForm | iconForm := self iconForm. aCanvas translucentImage: iconForm at: stringBounds left @ (self top + (self height - iconForm height // 2)). stringBounds := stringBounds left: stringBounds left + iconForm width + 2]. self hasMarker ifTrue: [stringBounds := stringBounds left: stringBounds left + self submorphBounds width + 8]. stringBounds := stringBounds top: stringBounds top + stringBounds bottom - self fontToUse height // 2. aCanvas drawString: self contents in: stringBounds font: self fontToUse color: stringColor. self hasSubMenu ifTrue: [| subMenuMarker subMenuMarkerPosition | subMenuMarker := self subMenuMarker. subMenuMarkerPosition := self right - subMenuMarker width @ (self top + self bottom - subMenuMarker height // 2). self isInDockingBar ifTrue: [subMenuMarkerPosition := subMenuMarkerPosition - (4 @ -1)]. aCanvas paintImage: subMenuMarker at: subMenuMarkerPosition]! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:18'! hasSubMenu: aMenuMorph subMenu ifNil:[^false]. subMenu == aMenuMorph ifTrue:[^true]. ^subMenu hasSubMenu: aMenuMorph! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 16:58'! contentString ^self valueOfProperty: #contentString! ! !MenuItemMorph methodsFor: 'private' stamp: 'dgd 3/31/2006 12:15'! bottomArrow ^ ColorForm mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 90) asFormOfDepth:8)! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! selector: aSymbol selector := aSymbol. ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/20/2010 00:23'! icon: aForm "change the the receiver's icon" icon := aForm. "self height: self minHeight. self width: self minWidth"! ! !MenuItemMorph methodsFor: 'events' stamp: 'dgd 9/9/2004 20:37'! mouseEnter: evt "The mouse entered the receiver" owner ifNotNil: [owner stayUp ifFalse: [self mouseEnterDragging: evt]]. self isInDockingBar ifTrue:[ (owner selectedItem notNil and:[owner selectedItem ~~ self]) ifTrue:[owner selectItem: self event: evt.]. ]. ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'GuillermoPolito 9/1/2010 18:44'! contentString: aString aString ifNil: [self removeProperty: #contentString] ifNotNil: [self setProperty: #contentString toValue: aString]! ! !MenuItemMorph methodsFor: 'grabbing' stamp: 'GuillermoPolito 5/29/2011 14:47'! aboutToBeGrabbedBy: aHand "Don't allow the receiver to act outside a Menu" | menu box | (owner notNil and:[owner submorphs size = 1]) ifTrue:[ "I am a lonely menuitem already; just grab my owner" owner stayUp: true. ^owner aboutToBeGrabbedBy: aHand]. box := self bounds. menu := UIManager default newMenuIn: self for: nil. menu addMorphFront: self. menu bounds: box. menu stayUp: true. self isSelected: false. ^menu! ! !MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 17:10'! iconForm "private - answer the form to be used as the icon" ^ isEnabled ifTrue: [self icon] ifFalse: [self icon asGrayScale]! ! !MenuItemMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 02:05'! deleteIfPopUp: evt "Recurse up for nested pop ups" owner ifNotNil:[owner deleteIfPopUp: evt].! ! !MenuItemMorph methodsFor: 'rounding' stamp: 'dgd 9/1/2004 18:11'! wantsRoundedCorners ^ self isInDockingBar ifTrue: [true] ifFalse: [super wantsRoundedCorners]! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'RAA 1/18/2001 18:24'! isStayUpItem ^selector == #toggleStayUp: or: [selector == #toggleStayUpIgnore:evt:]! ! !MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:37'! activateSubmenu: evt "Activate our submenu; e.g., pass control to it" subMenu ifNil:[^false]. "not applicable" (subMenu fullContainsPoint: evt position) ifFalse:[^false]. subMenu activate: evt. self removeAlarm: #deselectTimeOut:. ^true! ! !MenuItemMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'gvc 2/26/2010 04:58'! deselectTimeOut: evt "Deselect timout. Now really deselect" owner selectedItem == self ifTrue: [ self isInDockingBar ifTrue: [evt hand releaseMouseFocus: owner] ifFalse: [evt hand newMouseFocus: owner]. owner selectItem: nil event: evt ].! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! selector ^ selector ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! subMenu: aMenuMorph subMenu := aMenuMorph. self changed. ! ! !MenuItemMorph methodsFor: 'selecting' stamp: 'ar 10/10/2000 01:39'! deselect: evt self isSelected: false. subMenu ifNotNil: [ owner ifNotNil:[owner activeSubmenu: nil]. self removeAlarm: #deselectTimeOut:].! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! isEnabled ^ isEnabled ! ! !MenuItemMorph methodsFor: 'events' stamp: 'dgd 9/9/2004 21:20'! mouseUp: evt "Handle a mouse up event. Menu items get activated when the mouse is over them. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu." evt hand mouseFocus == owner ifFalse:[^self]. self contentString ifNotNil:[ self contents: self contentString withMarkers: true inverse: true. self refreshWorld. (Delay forMilliseconds: 200) wait]. self isInDockingBar ifTrue:[ owner rootMenu selectItem: nil event: evt ] ifFalse:[ self deselect: evt ]. self invokeWithEvent: evt. ! ! !MenuItemMorph methodsFor: 'grabbing' stamp: 'GuillermoPolito 5/29/2011 14:47'! duplicateMorph: evt "Make and return a duplicate of the receiver's argument" | dup menu | dup := self duplicate isSelected: false. menu := UIManager default newMenuIn: self for: nil. menu addMorphFront: dup. menu bounds: self bounds. menu stayUp: true. evt hand grabMorph: menu from: owner. "duplicate was ownerless so use #grabMorph:from: here" ^menu! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 3/22/2003 14:45'! icon "answer the receiver's icon" ^ icon! ! !MenuItemMorph methodsFor: 'selecting' stamp: 'dgd 9/13/2004 20:29'! adjacentTo self isInDockingBar ifFalse: [^ {self bounds topRight + (10 @ 0). self bounds topLeft}]. "" owner isFloating ifTrue: [^ {self bounds bottomLeft + (5 @ 5)}]. owner isAdheringToTop ifTrue: [^ {self bounds bottomLeft + (5 @ 5)}]. owner isAdheringToLeft ifTrue: [^ {self bounds topRight + (5 @ 5)}]. "" owner isAdheringToBottom ifTrue: [^ {self bounds topLeft + (5 @ 5)}]. owner isAdheringToRight ifTrue: [^ {self bounds topLeft + (5 @ -5)}]. "" ^ {self bounds bottomLeft + (3 @ 5)}! ! !MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 19:24'! updateLayoutInDockingBar self isInDockingBar ifFalse: [^ self]. "" owner isVertical ifTrue: ["" self hResizing: #spaceFill. self vResizing: #shrinkWrap] ifFalse: ["" self hResizing: #shrinkWrap. self vResizing: #spaceFill]. self extent: self minWidth @ self minHeight! ! !MenuItemMorph methodsFor: 'selecting' stamp: 'ar 9/18/2000 11:09'! isSelected: aBoolean isSelected := aBoolean. self changed. ! ! !MenuItemMorph methodsFor: 'copying' stamp: 'sw 9/25/2002 03:24'! veryDeepFixupWith: deepCopier "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. target := deepCopier references at: target ifAbsent: [target]. arguments notNil ifTrue: [arguments := arguments collect: [:each | deepCopier references at: each ifAbsent: [each]]]! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:40'! hasSubMenu "Return true if the receiver has a submenu" ^subMenu notNil! ! !MenuItemMorph methodsFor: 'change reporting' stamp: 'dgd 9/1/2004 18:29'! ownerChanged "The receiver's owner, some kind of a pasteup, has changed its layout." super ownerChanged. self updateLayoutInDockingBar! ! !MenuItemMorph methodsFor: 'nil' stamp: 'jm 11/4/97 07:46'! isEnabled: aBoolean isEnabled = aBoolean ifTrue: [^ self]. isEnabled := aBoolean. self color: (aBoolean ifTrue: [Color black] ifFalse: [Color gray]). ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! subMenu ^ subMenu ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:22'! itemWithWording: wording "If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil." (self contents asString sameAs: wording) ifTrue:[^self]. subMenu ifNotNil:[^subMenu itemWithWording: wording]. ^nil! ! !MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 00:24'! mouseEnterDragging: evt "The mouse entered the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu." evt hand mouseFocus == owner ifTrue:[owner selectItem: self event: evt]! ! !MenuItemMorph methodsFor: 'layout' stamp: 'MarcusDenker 9/7/2010 17:40'! minWidth | subMenuWidth iconWidth markerWidth | subMenuWidth := self hasSubMenu ifTrue: [10] ifFalse: [0]. iconWidth := self hasIcon ifTrue: [self icon width + 2] ifFalse: [0]. markerWidth := self hasMarker ifTrue: [self submorphBounds width + 8] ifFalse: [0]. ^ (self fontToUse widthOfString: contents) + subMenuWidth + iconWidth + markerWidth + 10! ! !MenuItemMorph methodsFor: 'events' stamp: 'sw 2/7/2001 00:03'! doButtonAction "Called programattically, this should trigger the action for which the receiver is programmed" self invokeWithEvent: nil! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:19'! hasIconOrMarker "Answer whether the receiver has an icon or a marker." ^ self hasIcon or: [ submorphs isEmpty not ]! ! !MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 22:45'! handleMouseUp: anEvent "The handling of control between menu item requires them to act on mouse up even if not the current focus. This is different from the default behavior which really only wants to handle mouse ups when they got mouse downs before" anEvent wasHandled ifTrue:[^self]. "not interested" anEvent hand releaseMouseFocus: self. anEvent wasHandled: true. anEvent blueButtonChanged ifTrue:[self blueButtonUp: anEvent] ifFalse:[self mouseUp: anEvent].! ! !MenuItemMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 14:52'! mouseLeaveDragging: evt "The mouse left the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu." owner ifNil: [^self]. evt hand mouseFocus == owner ifFalse: [^self]. "If we have a submenu, make sure we've got some time to enter it before actually leaving the menu item" subMenu isNil ifTrue: [owner selectItem: nil event: evt] ifFalse: [self addAlarm: #deselectTimeOut: with: evt after: 500]! ! !MenuItemMorph methodsFor: 'events' stamp: 'ar 9/18/2000 21:46'! handlesMouseOverDragging: evt ^true! ! !MenuItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/17/2008 14:43'! enabled: aBoolean "Delegate to exisitng method." self isEnabled: aBoolean! ! !MenuItemMorph methodsFor: 'rounding' stamp: 'dgd 9/1/2004 18:11'! roundedCorners "Return a list of those corners to round" self isInDockingBar ifFalse: [^ super roundedCorners]. "" owner isFloating ifTrue: [^ #(1 4 )]. owner isAdheringToTop ifTrue: [^ #(1 4 )]. owner isAdheringToBottom ifTrue: [^ #(2 3 )]. owner isAdheringToLeft ifTrue: [^ #(1 2 )]. owner isAdheringToRight ifTrue: [^ #(3 4 )]. "" ^ #(1 2 3 4 )! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:25'! hasMarker "Answer whether the receiver has a marker morph." ^ submorphs isEmpty not! ! !MenuItemMorph methodsFor: 'nil' stamp: 'di 2/23/98 16:24'! deselectItem | item | self isSelected: false. subMenu ifNotNil: [subMenu deleteIfPopUp]. (owner isKindOf: MenuMorph) ifTrue: [item := owner popUpOwner. (item isKindOf: MenuItemMorph) ifTrue: [item deselectItem]]. ! ! !MenuItemMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 18:07'! rightArrow ^ SubMenuMarker! ! !MenuItemMorph methodsFor: 'private' stamp: 'dgd 3/31/2006 12:16'! leftArrow ^ ColorForm mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 180)asFormOfDepth: 8)! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! arguments: aCollection arguments := aCollection. ! ! !MenuItemMorph methodsFor: 'meta actions' stamp: 'ar 10/10/2000 02:13'! wantsHaloFromClick "Only if I'm not a lonely submenu" ^owner notNil and:[owner submorphs size > 1]! ! !MenuItemMorph methodsFor: 'selecting' stamp: 'dgd 9/1/2004 18:52'! select: evt self isSelected: true. owner activeSubmenu: subMenu. subMenu ifNotNil: [ subMenu delete. subMenu popUpAdjacentTo: self adjacentTo forHand: evt hand from: self. subMenu selectItem: nil event: evt].! ! !MenuItemMorph methodsFor: 'layout' stamp: 'dgd 9/4/2004 15:49'! minHeight | iconHeight | iconHeight := self hasIcon ifTrue: [self icon height + 2] ifFalse: [0]. ^ self fontToUse height max: iconHeight ! ! !MenuItemMorph methodsFor: '*Polymorph-Widgets-override' stamp: 'SeanDeNigris 1/19/2011 20:57'! mouseDown: evt "Handle a mouse down event. Menu items get activated when the mouse is over them." evt shiftPressed ifTrue: [^ super mouseDown: evt]. "enable label editing" (self isInDockingBar and:[isSelected] "and:[owner selectedItem == self]") ifTrue:[ evt hand newMouseFocus: nil. owner selectItem: nil event: evt. ] ifFalse:[ evt hand newMouseFocus: owner. "Redirect to menu for valid transitions" owner selectItem: self event: evt. ] ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/17/2000 18:32'! contents: aString ^self contents: aString withMarkers: true! ! !MenuItemMorph methodsFor: 'events' stamp: 'sw 5/5/2001 00:25'! mouseLeave: evt "The mouse has left the interior of the receiver..." owner ifNotNil: [owner stayUp ifFalse: [self mouseLeaveDragging: evt]]! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! arguments ^ arguments ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! target ^ target! ! !MenuItemMorph class methodsFor: 'initialization' stamp: 'jm 11/16/97 09:17'! initialize "MenuItemMorph initialize" | f | f := Form extent: 5@9 fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648) offset: 0@0. SubMenuMarker := ColorForm mappingWhiteToTransparentFrom: f. ! ! !MenuLineMorph methodsFor: 'private' stamp: 'dgd 9/1/2004 19:20'! updateLayoutInDockingBar self isInDockingBar ifFalse: [^ self]. "" owner isVertical ifFalse: ["" self hResizing: #shrinkWrap. self vResizing: #spaceFill] ifTrue: ["" self hResizing: #spaceFill. self vResizing: #shrinkWrap]. self extent: self minWidth @ self minHeight! ! !MenuLineMorph methodsFor: 'initialization' stamp: 'ar 11/8/2000 23:09'! initialize super initialize. self hResizing: #spaceFill; vResizing: #spaceFill.! ! !MenuLineMorph methodsFor: 'drawing' stamp: 'FernandoOlivero 4/12/2011 09:53'! drawOn: aCanvas | baseColor | baseColor := self theme currentSettings autoMenuColor ifTrue: [owner color twiceDarker] ifFalse: [ self theme currentSettings flatMenu ifFalse: [owner color] ifTrue: [owner color twiceDarker]]. self theme currentSettings flatMenu ifFalse: [ aCanvas fillRectangle: (bounds topLeft corner: bounds rightCenter) color: baseColor twiceDarker . aCanvas fillRectangle: (bounds leftCenter corner: bounds bottomRight) color: baseColor twiceLighter ] ifTrue: [ aCanvas fillRectangle: (bounds topLeft corner: bounds bottomRight) color: baseColor]! ! !MenuLineMorph methodsFor: 'layout' stamp: 'AlainPlantec 12/13/2009 18:20'! minHeight "answer the receiver's minHeight" ^ self isInDockingBar ifTrue: [owner isVertical ifTrue: [2] ifFalse: [10]] ifFalse: [2]! ! !MenuLineMorph methodsFor: 'layout' stamp: 'dgd 9/1/2004 19:21'! minWidth "answer the receiver's minWidth" ^ self isInDockingBar ifTrue: [owner isVertical ifTrue: [10] ifFalse: [2]] ifFalse: [10]! ! !MenuLineMorph methodsFor: 'change reporting' stamp: 'dgd 9/1/2004 19:12'! ownerChanged "The receiver's owner, some kind of a pasteup, has changed its layout." super ownerChanged. self updateLayoutInDockingBar! ! !MenuLineMorph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/1/2004 19:12'! noteNewOwner: aMorph "I have just been added as a submorph of aMorph" super noteNewOwner: aMorph. self updateLayoutInDockingBar! ! !MenuModel commentStamp: ''! I am a simple model describing a menu. I only contains a list of menu groups. Each group is separated by a splitter! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/12/2013 09:47'! neglect: aModel aModel neglectMenuModel: self! ! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 15:38'! applyTo: aModel aModel applyMenuModel: self! ! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 14:14'! menuGroups ^ groups value! ! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 15:35'! addGroup: aBlock | group | group := MenuGroupModel new. aBlock value: group. self addMenuGroup: group! ! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/18/2014 23:08'! buildWithSpecAsPopup ^ self buildWithSpec: #popup! ! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 18:33'! autoRefresh: aBoolean autoRefresh value: aBoolean! ! !MenuModel methodsFor: 'initialize' stamp: 'CamilloBruni 2/19/2014 14:32'! initialize super initialize. groups := OrderedCollection new asReactiveVariable. title := nil asReactiveVariable. icon := nil asReactiveVariable. autoRefresh := nil asReactiveVariable. autoRefresh whenChangedDo: [ :aBoolean | self menuGroups do: [ :each | each autoRefresh: aBoolean ] ]! ! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 14:36'! icon: anIcon icon value: anIcon! ! !MenuModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/1/2013 18:34'! addMenuGroup: aMenuGroup groups add: aMenuGroup. self autoRefresh ifNotNil: [ aMenuGroup autoRefresh: self autoRefresh ]! ! !MenuModel methodsFor: 'printing' stamp: 'StephaneDucasse 11/11/2013 19:19'! printOn: aStream super printOn: aStream. self title value ifNotNil: [:t | aStream nextPutAll: ' ''', t , '''' ]! ! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 14:36'! title ^ title value! ! !MenuModel methodsFor: 'protocol-building' stamp: 'BenjaminVanRyseghem 11/29/2013 15:00'! fromSpec: aSpec aSpec addToMenuModel: self! ! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 14:36'! title: aString title value: aString! ! !MenuModel methodsFor: 'protocol-building' stamp: 'BenjaminVanRyseghem 11/29/2013 16:14'! addAllFromPragma: pragma target: target self fromSpec: (PragmaMenuBuilder pragmaKeyword: pragma model: target) menuSpec! ! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 18:33'! autoRefresh ^ autoRefresh value! ! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/18/2014 23:08'! openWithSpecAt: aPosition self buildWithSpecAsPopup. self changed: #openAt: with: { aPosition }! ! !MenuModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 14:36'! icon ^ icon value! ! !MenuModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/1/2013 16:24'! defaultSpec ^ #(MenuAdapter adapt: #(model))! ! !MenuModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/18/2014 23:04'! popup ^ #(MenuAdapter adaptAsPopup: #(model))! ! !MenuModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:22'! adapterName ^ #MenuAdapter! ! !MenuMorph commentStamp: ''! Instance variables: defaultTarget The default target for creating menu items selectedItem The currently selected item in the receiver stayUp True if the receiver should stay up after clicks popUpOwner The menu item that automatically invoked the receiver, if any. activeSubMenu The currently active submenu.! !MenuMorph methodsFor: 'private' stamp: 'ar 10/7/2000 21:08'! invokeMetaMenu: evt stayUp ifFalse:[^self]. "Don't allow this" ^super invokeMetaMenu: evt! ! !MenuMorph methodsFor: '*SUnit-UITesting' stamp: 'SeanDeNigris 12/1/2011 22:47'! choose: aString | item | item := self itemWithWording: aString. item ifNil: [ self error: 'Menu does not have "', aString, '" item' ]. item simulateClick.! ! !MenuMorph methodsFor: 'control' stamp: 'BenjaminVanRyseghem 10/18/2013 10:59'! popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean "Present this menu at the given point under control of the given hand." | evt | aWorld submorphs select: [ :each | (each isKindOf: MenuMorph) and: [each stayUp not]] thenCollect: [ :menu | menu delete]. self items isEmpty ifTrue: [^ self]. self layoutItems. "precompute width" self positionAt: aPoint relativeTo: (selectedItem ifNil: [self items first]) inWorld: aWorld. aWorld addMorphFront: self. "Acquire focus for valid pop up behavior" hand newMouseFocus: self. aBoolean ifTrue: [hand newKeyboardFocus: self]. evt := hand lastEvent. (evt isKeyboard or: [evt isMouse and: [evt anyButtonPressed not]]) ifTrue: ["Select first item if button not down" self moveSelectionDown: 1 event: evt]. self updateColor. self changed! ! !MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 14:01'! add: wordingString icon: aForm subMenu: aMenuMorph "Append the given submenu with the given label." ^ self add: wordingString icon: aForm help: nil subMenu: aMenuMorph! ! !MenuMorph methodsFor: 'invoking' stamp: 'AlainPlantec 12/19/2009 23:23'! invokeAt: aPoint in: aWorld "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." ^ self invokeAt: aPoint in: aWorld allowKeyboard: self menuKeyboardControl! ! !MenuMorph methodsFor: 'construction' stamp: 'BenjaminVanRyseghem 3/28/2011 15:45'! add: aString target: target selector: aSymbol argument: arg "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument." ^ self add: aString target: target selector: aSymbol argumentList: (Array with: arg) ! ! !MenuMorph methodsFor: 'construction' stamp: 'gvc 10/17/2008 15:17'! addWithLabel: aLabel enablementSelector: enablementSelector target: target selector: aSymbol argumentList: argList "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is constant, and the optional enablementSelector determines whether or not the item should be enabled." self addToggle: aLabel target: target selector: aSymbol getStateSelector: nil enablementSelector: enablementSelector argumentList: argList! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 14:28'! color: aColor "Set the receiver's color. Remember the base color in the case of a gradient background." super color: aColor. self setProperty: #basicColor toValue: aColor! ! !MenuMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 5/8/2013 14:54'! initialize super initialize. self setDefaultParameters. self listDirection: #topToBottom. self hResizing: #shrinkWrap. self vResizing: #shrinkWrap. defaultTarget := nil. selectedItem := nil. stayUp := false. popUpOwner := nil. self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber. self theme currentSettings preferRoundCorner ifTrue: [ self useRoundedCorners ]! ! !MenuMorph methodsFor: 'control' stamp: 'alain.plantec 2/9/2009 12:20'! displayAt: aPoint during: aBlock "Add this menu to the Morphic world during the execution of the given block." ActiveWorld addMorph: self centeredNear: aPoint. self world displayWorld. "show myself" aBlock value. self delete! ! !MenuMorph methodsFor: 'construction' stamp: 'BenjaminVanRyseghem 3/28/2011 15:45'! add: aString selector: aSymbol argument: arg ^ self add: aString target: defaultTarget selector: aSymbol argumentList: (Array with: arg) ! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 7/1/1999 22:21'! title: aString "Add a title line at the top of this menu." self addTitle: aString! ! !MenuMorph methodsFor: 'menu' stamp: 'BenjaminVanRyseghem 4/12/2011 15:32'! setInvokingView: invokingView "Re-work every menu item of the form perform: to the form perform: orSendTo: . This supports MVC's vectoring of non-model messages to the editPane." self items do: [:item | item hasSubMenu ifTrue: [ item subMenu setInvokingView: invokingView] ifFalse: [ item arguments isEmptyOrNil ifTrue: "only the simple messages" [item arguments: (Array with: item selector with: invokingView). item selector: #perform:orSendTo:]]]! ! !MenuMorph methodsFor: 'private' stamp: 'NicolaiHess 12/20/2013 13:33'! setTitleParametersFor: aMenuTitle | menuTitleColor menuTitleBorderColor | self theme currentSettings preferRoundCorner ifTrue: [aMenuTitle useRoundedCorners]. menuTitleColor := self theme currentSettings autoMenuColor ifTrue: [self color darker] ifFalse: [self theme menuTitleColorFor: ((UIManager default respondsTo: #modalMorph) ifTrue: [UIManager default modalMorph] ifFalse: [nil])]. menuTitleBorderColor := self theme currentSettings menuTitleBorderColor. aMenuTitle color: menuTitleColor; borderWidth: 0; borderColor: menuTitleBorderColor; vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #topLeft; maxCellSize:World width /2; clipSubmorphs:true; layoutInset: 0. ! ! !MenuMorph methodsFor: 'construction' stamp: 'nk 4/6/2002 22:41'! addStayUpItemSpecial "Append a menu item that can be used to toggle this menu's persistent." "This variant is resistant to the MVC compatibility in #setInvokingView:" (self valueOfProperty: #hasTitlebarWidgets ifAbsent: [ false ]) ifTrue: [ ^self ]. self addStayUpIcons.! ! !MenuMorph methodsFor: 'events' stamp: 'AlexandreBergel 11/11/2013 15:18'! recordFiltering: matchString self setProperty: #matchString toValue: matchString! ! !MenuMorph methodsFor: 'construction' stamp: 'BenjaminVanRyseghem 3/28/2011 15:01'! add: aString target: anObject selector: aSymbol "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." ^ self add: aString target: anObject selector: aSymbol argumentList: EmptyArray. ! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/12/2006 15:32'! addToggle: aString target: anObject selector: aSymbol "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." self addToggle: aString target: anObject selector: aSymbol getStateSelector: nil argumentList: EmptyArray! ! !MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/13/2004 13:36'! hasItems "Answer if the receiver has menu items" ^ submorphs anySatisfy: [:each | each isKindOf: MenuItemMorph] ! ! !MenuMorph methodsFor: 'drawing' stamp: 'StephaneDucasse 4/27/2010 11:52'! drawOn: aCanvas "Draw the menu. Add keyboard-focus feedback if appropriate" super drawOn: aCanvas. (ActiveHand notNil and: [ActiveHand keyboardFocus == self and: [self rootMenu hasProperty: #hasUsedKeyboard]]) ifTrue: [ aCanvas frameAndFillRectangle: self innerBounds fillColor: Color transparent borderWidth: self theme settings menuBorderWidth borderColor: self theme settings menuKeyboardFocusColor ]. ! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/16/2007 12:59'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !MenuMorph methodsFor: 'actions' stamp: 'di 10/28/1999 09:50'! deleteIfPopUp "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu." stayUp ifFalse: [self topRendererOrSelf delete]. (popUpOwner notNil and: [popUpOwner isKindOf: MenuItemMorph]) ifTrue: [ popUpOwner isSelected: false. (popUpOwner owner isKindOf: MenuMorph) ifTrue: [popUpOwner owner deleteIfPopUp]]. ! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 11/5/1998 21:13'! balloonTextForLastItem: balloonText submorphs last setBalloonText: balloonText! ! !MenuMorph methodsFor: 'construction' stamp: 'EstebanLorenzano 1/31/2013 19:25'! addAllFrom: aMenuMorph "This is a fast add..." submorphs := submorphs, (aMenuMorph submorphs collect: [ :each | each copy privateOwner: self; yourself ]). menuItems := submorphs copy asOrderedCollection! ! !MenuMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/28/2012 18:10'! delete activeSubMenu ifNotNil:[activeSubMenu delete]. ^super delete! ! !MenuMorph methodsFor: 'control' stamp: 'EstebanLorenzano 5/14/2013 09:44'! layoutItems "decorate aMenu with icons" | maxIconWidth | maxIconWidth := 0. self items do: [:item | item icon ifNotNil: [maxIconWidth := maxIconWidth max: item icon width]. item hasSubMenu ifTrue: [item subMenu layoutItems]]. maxIconWidth isZero ifFalse: [self addBlankIconsIfNecessary: (Smalltalk ui icons blankIconOfWidth: maxIconWidth)]. ! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'GuillermoPolito 5/23/2012 11:39'! keyboardFocusChange: aBoolean "Notify change due to green border for keyboard focus" super keyboardFocusChange: aBoolean. self changed! ! !MenuMorph methodsFor: 'construction' stamp: 'MartinDias 10/24/2013 16:40'! addList: aList "Add the given items to this menu, where each item is a pair ( ).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help. The optional fourth element provide the icon selector" aList do: [:tuple | (tuple == #-) ifTrue: [self addLine] ifFalse: [self add: tuple first capitalized action: tuple second. (tuple size > 2 and: [tuple third notNil]) ifTrue: [self balloonTextForLastItem: tuple third]. (tuple size > 3 and: [tuple fourth notNil]) ifTrue: [self lastItem icon: (Smalltalk ui icons iconNamed: tuple fourth)]]]! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'StephaneDucasse 2/9/2010 22:36'! displayFiltered: evt | matchStr allItems matches feedbackMorph | matchStr := self valueOfProperty: #matchString. allItems := self submorphs select: [:m | m isKindOf: MenuItemMorph]. matches := allItems select: [:m | | isMatch | isMatch := matchStr isEmpty or: [ m contents includesSubstring: matchStr caseSensitive: false]. m isEnabled: isMatch. isMatch]. feedbackMorph := self valueOfProperty: #feedbackMorph. feedbackMorph ifNil: [ feedbackMorph := TextMorph new autoFit: true; color: Color darkGray. self addLine; addMorphBack: feedbackMorph lock. self setProperty: #feedbackMorph toValue: feedbackMorph. self fullBounds. "Lay out for submorph adjacency"]. feedbackMorph contents: '<', matchStr, '>'. matchStr isEmpty ifTrue: [ feedbackMorph delete. self submorphs last delete. self removeProperty: #feedbackMorph]. " This method is invoked with evt = nil from MenuMorph >> removeMatchString. The current implementation can't select an item without an event. " (evt notNil and: [ matches size >= 1 ]) ifTrue: [self selectItem: matches first event: evt] ! ! !MenuMorph methodsFor: 'control' stamp: 'AlainPlantec 11/16/2010 08:59'! deleteIfPopUp: evt "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu." stayUp ifFalse: [self topRendererOrSelf delete]. (popUpOwner notNil) ifTrue: [ popUpOwner isSelected: false. popUpOwner deleteIfPopUp: evt]. evt ifNotNil:[evt hand releaseMouseFocus: self].! ! !MenuMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! items ^ submorphs select: [:m | m isKindOf: MenuItemMorph] ! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 6/11/1999 17:26'! addUpdating: aWordingSelector target: aTarget action: aSymbol self addUpdating: aWordingSelector target: aTarget selector: aSymbol argumentList: EmptyArray ! ! !MenuMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:57'! mouseUp: evt "Handle a mouse up event. Note: This might be sent from a modal shell." (self fullContainsPoint: evt position) ifFalse:[ "Mouse up outside. Release eventual focus and delete if pop up." evt hand releaseMouseFocus: self. ^self deleteIfPopUp: evt]. stayUp ifFalse:[ "Still in pop-up transition; keep focus" evt hand newMouseFocus: self].! ! !MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 17:56'! activatedFromDockingBar: aDockingBar activatorDockingBar := aDockingBar! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! modalSelection ^self valueOfProperty: #modalSelection ifAbsent:[nil]! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 8/28/2000 18:02'! addWithLabel: aLabel enablement: anEnablementSelector action: aSymbol self addWithLabel: aLabel enablementSelector: anEnablementSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray ! ! !MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 13:35'! addTitle: aString icon: aForm "Add a title line at the top of this menu." self addTitle: aString icon: aForm updatingSelector: nil updateTarget: nil ! ! !MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 13:19'! defaultTarget ^defaultTarget! ! !MenuMorph methodsFor: 'accessing' stamp: 'GuillermoPolito 9/1/2010 18:44'! lastSelection "Return the label of the last selected item or nil." ^selectedItem ifNotNil: [selectedItem selector].! ! !MenuMorph methodsFor: 'copying' stamp: 'ar 9/18/2000 09:34'! veryDeepFixupWith: deepCopier "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals." super veryDeepFixupWith: deepCopier. defaultTarget := deepCopier references at: defaultTarget ifAbsent: [defaultTarget]. popUpOwner := deepCopier references at: popUpOwner ifAbsent: [popUpOwner]. activeSubMenu := deepCopier references at: activeSubMenu ifAbsent:[activeSubMenu].! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 6/19/1999 23:09'! addTitle: aString "Add a title line at the top of this menu." self addTitle: aString updatingSelector: nil updateTarget: nil! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'nice 1/5/2010 15:59'! moveSelectionDown: direction event: evt "Move the current selection up or down by one, presumably under keyboard control. direction = +/-1" | index | index := (submorphs indexOf: selectedItem ifAbsent: [1-direction]) + direction. submorphs do: "Ensure finite" [:unused | | m | m := submorphs atWrap: index. ((m isKindOf: MenuItemMorph) and: [m isEnabled]) ifTrue: [^ self selectItem: m event: evt]. "Keep looking for an enabled item" index := index + direction sign]. ^ self selectItem: nil event: evt! ! !MenuMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 3/22/2010 21:20'! lastItem submorphs reverseDo: [ :each | (each isKindOf: MenuItemMorph) ifTrue: [ ^each ] ]. ^submorphs last! ! !MenuMorph methodsFor: 'construction' stamp: 'BenjaminVanRyseghem 3/28/2011 15:46'! add: wordingString help: helpString action: aSymbol "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." | morph | morph := self add: wordingString target: defaultTarget selector: aSymbol argumentList: EmptyArray. self balloonTextForLastItem:helpString. ^ morph! ! !MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 10:07'! popUpOwner: aMenuItemMorph "Set the current pop-up owner" popUpOwner := aMenuItemMorph. ! ! !MenuMorph methodsFor: 'filtering' stamp: 'AlexandreBergel 11/11/2013 15:18'! getFiltering: matchString ^ self valueOfProperty: #matchString ifAbsentPut: [ String new ]! ! !MenuMorph methodsFor: 'accessing' stamp: 'nice 1/5/2010 15:59'! itemWithWording: wording "If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil." self items do:[:anItem | | found | found := anItem itemWithWording: wording. found ifNotNil:[^found]]. ^ nil! ! !MenuMorph methodsFor: 'accessing' stamp: 'sw 12/4/2001 21:23'! commandKeyHandler: anObject "Set the receiver's commandKeyHandler. Whatever you set here needs to be prepared to respond to the message #commandKeyTypedIntoMenu: " self setProperty: #commandKeyHandler toValue: anObject! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'MarcusDenker 7/13/2012 16:04'! addToggle: aString target: anObject selector: aSymbol getStateSelector: stateSymbol enablementSelector: enableSymbol argumentList: argList "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." |item| item := ToggleMenuItemMorph new contents: aString; target: anObject; selector: aSymbol; arguments: argList; getStateSelector: stateSymbol; enablementSelector: enableSymbol. ^ self addMenuItem: item. ! ! !MenuMorph methodsFor: 'menu' stamp: 'GuillermoPolito 8/9/2010 21:23'! doButtonAction "Do the receiver's inherent button action. Makes sense for the kind of MenuMorph that is a wrapper for a single menu-item -- pass it on the the item" self hasItems ifTrue: [self menuItems first doButtonAction]! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/24/2004 13:40'! moveUp: evt ^self moveSelectionDown: -1 event: evt! ! !MenuMorph methodsFor: 'menu' stamp: 'alain.plantec 2/6/2009 15:30'! addItem | string sel | string := UIManager default request: 'Label for new item?' translated. string isEmpty ifTrue: [^ self]. sel := UIManager default request: 'Selector?' translated. sel isEmpty ifFalse: [sel := sel asSymbol]. self add: string action: sel. ! ! !MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 10:06'! popUpOwner "Return the current pop-up owner that is the menu item that automatically initiated the receiver." ^ popUpOwner ! ! !MenuMorph methodsFor: 'menu' stamp: 'RAA 1/18/2001 18:21'! toggleStayUp: evt "Toggle my 'stayUp' flag and adjust the menu item to reflect its new state." self items do: [:item | item isStayUpItem ifTrue: [self stayUp: stayUp not. stayUp ifTrue: [item contents: 'dismiss this menu'] ifFalse: [item contents: 'keep this menu up']]]. evt hand releaseMouseFocus: self. stayUp ifFalse: [self topRendererOrSelf delete]. ! ! !MenuMorph methodsFor: 'events' stamp: 'GabrielOmarCotelli 11/30/2013 16:52'! updateColor "Update the color of the menu." self theme preferGradientFill ifFalse: [ ^ self ]. self fillStyle: (self theme menuFillStyleFor: self). "update the title color" self allMorphs detect: [ :each | each hasProperty: #titleString ] ifFound: [ :title | title fillStyle: (self theme menuTitleFillStyleFor: title) ]! ! !MenuMorph methodsFor: 'construction' stamp: 'gvc 10/17/2008 11:45'! add: aString subMenu: aMenuMorph target: target selector: aSymbol argumentList: argList "Append the given submenu with the given label." self addToggle: aString target: target selector: aSymbol getStateSelector: nil enablementSelector: nil argumentList: argList. self lastItem subMenu: aMenuMorph! ! !MenuMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:52'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. aCustomMenu add: 'add title...' translated action: #addTitle. aCustomMenu add: 'set target...' translated action: #setTarget:. defaultTarget ifNotNil: [ aCustomMenu add: 'add item...' translated action: #addItem]. aCustomMenu add: 'add line' translated action: #addLine. (self items count:[:any| any hasSubMenu]) > 0 ifTrue:[aCustomMenu add: 'detach submenu' translated action: #detachSubMenu:].! ! !MenuMorph methodsFor: 'invoking' stamp: 'alain.plantec 2/9/2009 14:20'! invokeAt: aPoint in: aWorld allowKeyboard: aBoolean "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." | w originalFocusHolder | originalFocusHolder := aWorld primaryHand keyboardFocus. self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean. w := aWorld outermostWorldMorph. "containing hand" [self isInWorld] whileTrue: [w doOneSubCycle]. self delete. originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder]. ^ selectedItem ifNotNil: [selectedItem target] ! ! !MenuMorph methodsFor: 'menu' stamp: 'wiz 3/14/2006 23:40'! updateItemsWithTarget: aTarget orWithHand: aHand "re-target all existing items" self items do: [:item | item target ifNotNil: [ item target isHandMorph ifTrue: [item target: aHand] ifFalse: [item target: aTarget] ] ]! ! !MenuMorph methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2009 21:02'! embeddable: aBoolean embeddable := aBoolean! ! !MenuMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:35'! activate: evt "Receiver should be activated; e.g., so that control passes correctly." evt hand newMouseFocus: self.! ! !MenuMorph methodsFor: 'private' stamp: 'sw 5/1/2002 01:39'! positionAt: aPoint relativeTo: aMenuItem inWorld: aWorld "Note: items may not be laid out yet (I found them all to be at 0@0), so we have to add up heights of items above the selected item." | i yOffset sub delta | self fullBounds. "force layout" i := 0. yOffset := 0. [(sub := self submorphs at: (i := i + 1)) == aMenuItem] whileFalse: [yOffset := yOffset + sub height]. self position: aPoint - (2 @ (yOffset + 8)). "If it doesn't fit, show it to the left, not to the right of the hand." self right > aWorld worldBounds right ifTrue: [self right: aPoint x + 1]. "Make sure that the menu fits in the world." delta := self bounds amountToTranslateWithin: (aWorld worldBounds withHeight: ((aWorld worldBounds height - 18) max: (ActiveHand position y) + 1)). delta = (0 @ 0) ifFalse: [self position: self position + delta]! ! !MenuMorph methodsFor: 'construction' stamp: 'nk 2/15/2004 16:19'! addService: aService for: serviceUser "Append a menu item with the given service. If the item is selected, it will perform the given service." aService addServiceFor: serviceUser toMenu: self.! ! !MenuMorph methodsFor: 'menu' stamp: 'RAA 1/19/2001 15:10'! toggleStayUpIgnore: ignored evt: evt "This variant is resistant to the MVC compatibility in #setInvokingView:" self toggleStayUp: evt. ! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'dgd 9/9/2004 21:48'! removeMatchString "Remove the matchString, if any." self setProperty: #matchString toValue: String new. self displayFiltered: nil! ! !MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/1/2004 17:57'! wasActivatedFromDockingBar "answer true if the receiver was activated from a docking bar" ^ activatorDockingBar notNil! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/9/2006 09:25'! addToggle: aString target: anObject selector: aSymbol getStateSelector: stateSymbol "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." self addToggle: aString target: anObject selector: aSymbol getStateSelector: stateSymbol argumentList: EmptyArray! ! !MenuMorph methodsFor: 'events' stamp: 'mtf 9/20/2007 05:37'! mouseDown: evt "Handle a mouse down event." "Overridden to not grab on mouse down" (stayUp or:[self fullContainsPoint: evt position]) ifFalse:[^self deleteIfPopUp: evt]. "click outside" self comeToFront! ! !MenuMorph methodsFor: 'private' stamp: 'ar 2/10/2001 00:37'! morphicLayerNumber "helpful for insuring some morphs always appear in front of or behind others. smaller numbers are in front" ^self valueOfProperty: #morphicLayerNumber ifAbsent: [ stayUp ifTrue:[100] ifFalse:[10] ]! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! modalSelection: anObject self setProperty: #modalSelection toValue: anObject. self isModalInvokationDone: true! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! isModalInvokationDone: aBool self setProperty: #isModalInvokationDone toValue: aBool ! ! !MenuMorph methodsFor: 'menu' stamp: 'alain.plantec 2/9/2009 17:48'! removeStayUpBox | box ext | submorphs isEmpty ifTrue: [^self]. (submorphs first isAlignmentMorph) ifFalse: [^self]. box := submorphs first submorphs last. ext := box extent. (box isKindOf: IconicButton) ifTrue: [box labelGraphic: (Form extent: ext depth: 8); shedSelvedge; borderWidth: 0; lock]. box extent: ext.! ! !MenuMorph methodsFor: 'construction' stamp: 'BenjaminVanRyseghem 3/28/2011 15:01'! add: aString target: target selector: aSymbol argumentList: argList "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument." ^ self addToggle: aString target: target selector: aSymbol getStateSelector: nil enablementSelector: nil argumentList: argList! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/16/2008 16:37'! themeChanged "Update the colour if specified." self color: (self theme menuColorFor: nil). super themeChanged! ! !MenuMorph methodsFor: 'events' stamp: 'NicolaiHess 4/5/2014 00:09'! keyStroke: evt "Handle keboard item matching." | matchString char asc selectable help | help := self theme builder newBalloonHelp: 'Enter text to\narrow selection down\to matching items ' withCRs for: self corner: #topLeft. help popUpForHand: self activeHand. (self rootMenu hasProperty: #hasUsedKeyboard) ifFalse: [self rootMenu setProperty: #hasUsedKeyboard toValue: true. self changed]. (evt commandKeyPressed and: [self commandKeyHandler notNil]) ifTrue: [self commandKeyHandler commandKeyTypedIntoMenu: evt. ^self deleteIfPopUp: evt]. char := evt keyCharacter. asc := char asciiValue. char = Character cr ifTrue: [selectedItem ifNotNil: [selectedItem hasSubMenu ifTrue: [evt hand newMouseFocus: selectedItem subMenu. ^evt hand newKeyboardFocus: selectedItem subMenu] ifFalse: ["self delete." ^selectedItem invokeWithEvent: evt]]. (selectable := self items) size = 1 ifTrue: [^selectable first invokeWithEvent: evt]. ^self]. asc = 27 ifTrue: ["escape key" self valueOfProperty: #matchString ifPresentDo: [:str | str isEmpty ifFalse: ["If filtered, first ESC removes filter" self setProperty: #matchString toValue: String new. self selectItem: nil event: evt. ^self displayFiltered: evt]]. "If a stand-alone menu, just delete it" popUpOwner ifNil: [^self delete]. "If a sub-menu, then deselect, and return focus to outer menu" ^ self deselectAndFocusOutermenuOn: evt]. "Left arrow key - If we are in a submenu, then we remove myself (i.e., the current morph) and move the focus to the owner popup" (asc = 28) ifTrue: [ "If a stand-alone menu, do nothing" popUpOwner ifNil: [^self]. "If a sub-menu, then deselect, and return focus to outer menu" ^ self deselectAndFocusOutermenuOn: evt]. "Right arrow key - If the selected menu item has a submenu, then we move the focus to the submenu " (asc = 29) ifTrue: ["right arrow key" (selectedItem notNil and: [selectedItem hasSubMenu]) ifTrue: [evt hand newMouseFocus: selectedItem subMenu. selectedItem subMenu moveSelectionDown: 1 event: evt. ^evt hand newKeyboardFocus: selectedItem subMenu]]. asc = 30 ifTrue: [^self moveSelectionDown: -1 event: evt]. "up arrow key" asc = 31 ifTrue: [^self moveSelectionDown: 1 event: evt]. "down arrow key" asc = 11 ifTrue: [^self moveSelectionDown: -5 event: evt]. "page up key" asc = 12 ifTrue: [^self moveSelectionDown: 5 event: evt]. "page down key" "If we reach this point, it means that we are editing the filter associated to each menu. " "In case ther eis no filter associated to the menu, we simply create one" matchString := self valueOfProperty: #matchString ifAbsentPut: [ String new ]. "If we press the backspace, then we simply remove the last character from matchString" (char = Character backspace and: [ matchString notEmpty ]) ifTrue: [ matchString := matchString allButLast. self recordFiltering: matchString. self displayFiltered: evt. ]. "No need to go further if the character is not alphanumeric, i.e., not useful for filtering" char isAlphaNumeric ifFalse: [ ^ self ]. matchString := matchString, char asString. self recordFiltering: matchString. self displayFiltered: evt. help := BalloonMorph string: 'Enter text to\narrow selection down\to matching items ' withCRs for: self corner: #topLeft. help popUpForHand: self activeHand. ! ! !MenuMorph methodsFor: 'construction' stamp: 'BenjaminVanRyseghem 10/18/2013 10:57'! addTitle: aString icon: aForm updatingSelector: aSelector updateTarget: aTarget "Add a title line at the top of this menu Make aString its initial contents. If aSelector is not nil, then periodically obtain fresh values for its contents by sending aSelector to aTarget.." "Overridden to support menu dragging from the title-bar" | title titleContainer | title := AlignmentMorph newColumn. self setTitleParametersFor: title. "" aForm isNil ifTrue: [titleContainer := title] ifFalse: [| pair | pair := AlignmentMorph newRow. pair color: Color transparent. pair hResizing: #shrinkWrap. pair layoutInset: 0. "" pair addMorphBack: aForm asMorph. "" titleContainer := AlignmentMorph newColumn. titleContainer color: Color transparent. titleContainer vResizing: #shrinkWrap. titleContainer wrapCentering: #center. titleContainer cellPositioning: #topCenter. titleContainer layoutInset: 0. pair addMorphBack: titleContainer. "" title addMorphBack: pair]. "" aSelector ifNil: ["" aString asString linesDo: [:line | titleContainer addMorphBack: (StringMorph contents: line font: StandardFonts menuFont)]] ifNotNil: [| stringMorph | stringMorph := (aTarget perform: aSelector) asStringMorph. stringMorph font: StandardFonts menuFont. stringMorph lock. titleContainer addMorphBack: stringMorph]. "" title setProperty: #titleString toValue: aString. self addMorphFront: title. "" title useSquareCorners. title on: #mouseDown send: #mouseDownInTitle: to: self. (self hasProperty: #needsTitlebarWidgets) ifTrue: [self addStayUpIcons]! ! !MenuMorph methodsFor: 'control' stamp: 'StephaneDucasse 5/27/2010 22:23'! popUpForHand: hand in: aWorld | p | "Present this menu under control of the given hand." p := hand position truncated. ^self popUpAt: p forHand: hand in: aWorld ! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 6/11/1999 16:49'! addUpdating: aWordingSelector action: aSymbol self addUpdating: aWordingSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray ! ! !MenuMorph methodsFor: 'control' stamp: 'ar 10/5/2000 19:31'! popUpInWorld: aWorld "Present this menu under control of the given hand." ^self popUpAt: aWorld primaryHand position forHand: aWorld primaryHand in: aWorld ! ! !MenuMorph methodsFor: 'construction' stamp: 'gvc 10/17/2008 11:55'! add: wordingString icon: aForm help: helpString subMenu: aMenuMorph "Append the given submenu with the given label." self addToggle: wordingString target: nil selector: nil. self lastItem icon: aForm; subMenu: aMenuMorph. helpString isNil ifFalse: [self lastItem setBalloonText: helpString].! ! !MenuMorph methodsFor: 'events' stamp: 'ar 9/18/2000 10:13'! handlesMouseDown: evt ^true! ! !MenuMorph methodsFor: 'modal control' stamp: 'AlainPlantec 12/19/2009 23:23'! invokeModal "Invoke this menu and don't return until the user has chosen a value. See example below on how to use modal menu morphs." ^ self invokeModal: self menuKeyboardControl "Example: | menu sub entry | menu := MenuMorph new. 1 to: 3 do: [:i | entry := 'Line', i printString. sub := MenuMorph new. menu add: entry subMenu: sub. #('Item A' 'Item B' 'Item C') do:[:subEntry| sub add: subEntry target: menu selector: #modalSelection: argument: {entry. subEntry}]]. menu invokeModal. " ! ! !MenuMorph methodsFor: 'accessing' stamp: 'di 12/10/2001 22:11'! rootMenu popUpOwner ifNil: [^ self]. popUpOwner owner ifNil: [^ self]. ^ popUpOwner owner rootMenu! ! !MenuMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 5/8/2013 14:20'! defaultBounds ^ 0 @ 0 corner: 40 @ 10! ! !MenuMorph methodsFor: 'construction' stamp: 'nk 11/25/2003 09:59'! addTranslatedList: aList "Add the given items to this menu, where each item is a pair ( ).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help. The first and third items will be translated." aList do: [:tuple | (tuple == #-) ifTrue: [self addLine] ifFalse: [self add: tuple first translated action: tuple second. tuple size > 2 ifTrue: [self balloonTextForLastItem: tuple third translated ]]]! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'GabrielOmarCotelli 11/30/2013 16:51'! selectMoreItem: evt | allItems | allItems := self submorphs select: [ :m | m isKindOf: MenuItemMorph ]. allItems detect: [ :m | m contents size >= 4 and: [ (m contents first: 4) asString = 'more' ] ] ifFound: [ :more | self selectItem: more event: evt. selectedItem invokeWithEvent: evt ] ifNone: [ self flash ]! ! !MenuMorph methodsFor: 'invoking' stamp: 'IgorStasenko 1/2/2012 18:10'! informUserAt: aPoint during: aBlock "Add this menu to the Morphic world during the execution of the given block. " | title w | title := self allMorphs detect: [:ea | ea hasProperty: #titleString]. title := title submorphs first. self visible: false. w := ActiveWorld. aBlock value: [:string | self visible ifFalse: [w addMorph: self centeredNear: aPoint. self visible: true]. title contents: string. self setConstrainedPosition: self activeHand cursorPoint hangOut: false. self changed. w displayWorld "show myself"]. self delete. w displayWorld! ! !MenuMorph methodsFor: 'control' stamp: 'alain.plantec 2/9/2009 14:29'! popUpEvent: evt in: aWorld "Present this menu in response to the given event." | aHand aPosition | aHand := evt ifNotNil: [evt hand] ifNil: [ActiveHand]. aPosition := aHand position truncated. ^ self popUpAt: aPosition forHand: aHand in: aWorld ! ! !MenuMorph methodsFor: 'construction' stamp: 'EstebanLorenzano 1/31/2013 19:25'! addAllFromPragma: aString target: anObject self addAllFrom: (PragmaMenuBuilder pragmaKeyword: aString model: anObject) menu ! ! !MenuMorph methodsFor: 'copying' stamp: 'GuillermoPolito 8/9/2010 21:27'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. "defaultTarget := defaultTarget. Weakly copied" selectedItem := selectedItem veryDeepCopyWith: deepCopier. stayUp := stayUp veryDeepCopyWith: deepCopier. popUpOwner := popUpOwner. "Weakly copied" activeSubMenu := activeSubMenu. "Weakly copied" activatorDockingBar := activatorDockingBar. "Weakly copied" menuItems := menuItems. ! ! !MenuMorph methodsFor: 'accessing' stamp: 'sw 12/4/2001 21:22'! commandKeyHandler "Answer the receiver's commandKeyHandler" ^ self valueOfProperty: #commandKeyHandler ifAbsent: [nil]! ! !MenuMorph methodsFor: 'construction' stamp: 'StephaneDucasse 4/22/2012 16:39'! addUpdating: wordingSelector target: target selector: aSymbol argumentList: argList "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the initial wording of the menu item is obtained by sending the wordingSelector to the target. If the wording prefixed with or , the on/off state of the menu item will reflect it." |aString str| aString := (MessageSend receiver: target selector: wordingSelector) valueWithEnoughArguments: argList. self flag: #CleanYesNoOnOffAfter. (aString isKindOf: Association) ifTrue: [aString := aString value] ifFalse: [ str := aString readStream. (str skipTo: $>) ifTrue: [aString := str upToEnd]]. self addToggle: aString target: target selector: aSymbol getStateSelector: wordingSelector enablementSelector: nil argumentList: argList ! ! !MenuMorph methodsFor: 'construction' stamp: 'BenjaminVanRyseghem 3/28/2011 15:48'! addLine "Append a divider line to this menu. Suppress duplicate lines." self hasItems ifFalse: [^ nil]. (self lastSubmorph isKindOf: MenuLineMorph) ifFalse: [^ self addMorphBack: MenuLineMorph new]. ^ nil! ! !MenuMorph methodsFor: 'accessing' stamp: 'dgd 9/13/2004 19:59'! addBlankIconsIfNecessary: anIcon "If any of my items have an icon, ensure that all do by using anIcon for those that don't" self items reject: [:each | each hasIconOrMarker] thenDo: [:each | each icon: anIcon]! ! !MenuMorph methodsFor: 'menu' stamp: 'wiz 1/16/2006 21:26'! target: aMorph "Set defaultTarget since thats what we got. For the sake of targetSighting which assumes #target is a word we know." defaultTarget := aMorph! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'GuillermoPolito 8/9/2010 21:25'! menuItems ^menuItems ifNil:[menuItems:= OrderedCollection new]. ! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'sw 12/4/2001 20:13'! handlesKeyboard: evt "Answer whether the receiver handles the keystroke represented by the event" ^ evt anyModifierKeyPressed not or: [evt commandKeyPressed and: [self commandKeyHandler notNil]]! ! !MenuMorph methodsFor: 'construction' stamp: 'nk 4/6/2002 22:41'! addStayUpItem "Append a menu item that can be used to toggle this menu's persistence." (self valueOfProperty: #hasTitlebarWidgets ifAbsent: [ false ]) ifTrue: [ ^self ]. self addStayUpIcons.! ! !MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:18'! hasSubMenu: aMenuMorph self items do: [:each | (each hasSubMenu: aMenuMorph) ifTrue:[^true]]. ^ false ! ! !MenuMorph methodsFor: 'menu' stamp: 'MarcusDenker 2/22/2010 09:27'! setTarget: evt "Set the default target object to be used for add item commands, and re-target all existing items to the new target or the the invoking hand." | oldDefaultTarget | oldDefaultTarget := defaultTarget . oldDefaultTarget ~~ defaultTarget ifTrue: [self updateItemsWithTarget: defaultTarget orWithHand: evt hand ]. ! ! !MenuMorph methodsFor: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:29'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation! ! !MenuMorph methodsFor: 'menu' stamp: 'nk 3/31/2002 18:36'! removeStayUpItems | stayUpItems | stayUpItems := self items select: [ :item | item isStayUpItem ]. stayUpItems do: [ :ea | ea delete ]. ! ! !MenuMorph methodsFor: 'accessing' stamp: 'alain.plantec 2/9/2009 16:16'! stayUp: aBoolean stayUp := aBoolean. aBoolean ifTrue: [ self removeStayUpBox ].! ! !MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'! defaultTarget: anObject "Set the default target for adding menu items." defaultTarget := anObject. ! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/24/2004 13:41'! moveDown: evt ^self moveSelectionDown: 1 event: evt! ! !MenuMorph methodsFor: 'control' stamp: 'sw 12/17/2001 16:43'! popUpNoKeyboard "Present this menu in the current World, *not* allowing keyboard input into the menu" ^ self popUpAt: ActiveHand position forHand: ActiveHand in: ActiveWorld allowKeyboard: false! ! !MenuMorph methodsFor: 'modal control' stamp: 'sw 2/3/2002 14:26'! invokeModal: allowKeyboardControl "Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu" ^ self invokeModalAt: ActiveHand position in: ActiveWorld allowKeyboard: allowKeyboardControl! ! !MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'! add: aString action: aSymbol "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." self add: aString target: defaultTarget selector: aSymbol argumentList: EmptyArray. ! ! !MenuMorph methodsFor: 'menu' stamp: 'DamienCassou 9/23/2009 08:46'! addTitle | string | string := UIManager default request: 'Title for this menu?' translated. string isEmptyOrNil ifTrue: [^ self]. self addTitle: string. ! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'rr 3/24/2004 13:45'! filterListWith: char | matchString | matchString := self valueOfProperty: #matchString ifAbsentPut: [String new]. matchString := char = Character backspace ifTrue: [matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] ifFalse: [matchString copyWith: char]. self setProperty: #matchString toValue: matchString! ! !MenuMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 11/1/2013 14:43'! addIfNeededTitle: aTitle andIcon: anIcon (aTitle notNil or: [ anIcon notNil ]) ifTrue: [ self addTitle: aTitle icon: anIcon ]! ! !MenuMorph methodsFor: 'control' stamp: 'sw 2/18/2001 00:52'! popUpInWorld "Present this menu in the current World" ^ self popUpInWorld: self currentWorld! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 11/20/2007 13:34'! addToggle: aString selector: aSymbol "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." self addToggle: aString target: defaultTarget selector: aSymbol getStateSelector: nil argumentList: EmptyArray! ! !MenuMorph methodsFor: 'construction' stamp: 'BenjaminVanRyseghem 3/28/2011 15:45'! add: aString target: aTarget action: aSymbol ^ self add: aString target: aTarget selector: aSymbol argumentList: EmptyArray ! ! !MenuMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! stayUp ^ stayUp ! ! !MenuMorph methodsFor: 'events' stamp: 'di 12/5/2001 10:26'! handleFocusEvent: evt "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." self processEvent: evt. "Need to handle keyboard input if we have the focus." evt isKeyboard ifTrue: [^ self handleEvent: evt]. "We need to handle button clicks outside and transitions to local popUps so throw away everything else" (evt isMouseOver or:[evt isMouse not]) ifTrue:[^self]. "What remains are mouse buttons and moves" evt isMove ifFalse:[^self handleEvent: evt]. "handle clicks outside by regular means" "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." selectedItem ifNotNil:[(selectedItem activateSubmenu: evt) ifTrue:[^self]]. "Note: The following does not traverse upwards but it's the best I can do for now" popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: evt) ifTrue:[^self]].! ! !MenuMorph methodsFor: 'construction' stamp: 'dgd 9/13/2004 14:01'! add: aString subMenu: aMenuMorph "Append the given submenu with the given label." self add: aString icon: nil subMenu: aMenuMorph! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/29/2007 16:28'! adoptPaneColor: paneColor "Change our color." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self color: paneColor! ! !MenuMorph methodsFor: 'construction' stamp: 'HenrikSperreJohansen 6/12/2010 02:35'! labels: labelList lines: linesArray selections: selectionsArray "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:." "Labels can be either a sting with embedded crs, or a collection of strings." | labelArray | labelArray := (labelList isString) ifTrue: [labelList lines] ifFalse: [labelList]. 1 to: labelArray size do: [:i | self add: (labelArray at: i) action: (selectionsArray at: i). (linesArray includes: i) ifTrue: [self addLine]]! ! !MenuMorph methodsFor: 'private' stamp: 'AlainPlantec 12/14/2009 11:08'! setDefaultParameters "change the receiver's appareance parameters" self color: self theme settings derivedMenuColor; borderWidth: self theme settings menuBorderWidth; borderColor: self theme settings menuBorderColor. self theme settings flatMenu ifFalse: [ self borderStyle: BorderStyle thinGray. self hasDropShadow: true; shadowColor: self theme settings menuShadowColor; shadowOffset: 1 @ 1]. self layoutInset: 3. self cellInset: 0@1. ! ! !MenuMorph methodsFor: 'private' stamp: 'ar 9/18/2000 12:12'! selectedItem ^selectedItem! ! !MenuMorph methodsFor: 'control' stamp: 'NicolaiHess 4/5/2014 00:09'! deselectAndFocusOutermenuOn: anEvent "deselect and return focus to outer menu" self selectItem: nil event: anEvent. anEvent hand newMouseFocus: popUpOwner owner. ^ anEvent hand newKeyboardFocus: popUpOwner owner! ! !MenuMorph methodsFor: 'menu' stamp: 'alain.plantec 2/8/2009 19:27'! detachSubMenu: evt | possibleTargets item subMenu index | possibleTargets := self items select:[:any| any hasSubMenu]. possibleTargets size > 0 ifTrue:[ index := UIManager default chooseFrom: (possibleTargets collect:[:t| t contents asString]) title: 'Which menu?' translated. index = 0 ifTrue:[^self]]. item := possibleTargets at: index. subMenu := item subMenu. subMenu ifNotNil: [ item subMenu: nil. item delete. subMenu stayUp: true. subMenu popUpOwner: nil. subMenu addTitle: item contents. evt hand attachMorph: subMenu]. ! ! !MenuMorph methodsFor: 'modal control' stamp: 'ClementBera 9/30/2013 11:01'! invokeModalAt: aPoint in: aWorld allowKeyboard: aBoolean "Invoke this menu and don't return until the user has chosen a value. See senders of this method for finding out how to use modal menu morphs." | w originalFocusHolder | originalFocusHolder := aWorld primaryHand keyboardFocus. self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean. self isModalInvokationDone: false. w := aWorld outermostWorldMorph. "containing hand" [self isInWorld and: [ self isModalInvokationDone not ] ] whileTrue: [w doOneSubCycle]. self delete. originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder]. ^ self modalSelection! ! !MenuMorph methodsFor: 'rounding' stamp: 'dgd 9/1/2004 18:12'! roundedCorners "Return a list of those corners to round" self wasActivatedFromDockingBar ifTrue: ["" activatorDockingBar isFloating ifTrue: [^ #(2 3 )]. activatorDockingBar isAdheringToTop ifTrue: [^ #(2 3 )]. activatorDockingBar isAdheringToBottom ifTrue: [^ #(1 4 )]. activatorDockingBar isAdheringToLeft ifTrue: [^ #(3 4 )]. activatorDockingBar isAdheringToRight ifTrue: [^ #(1 2 )]]. ^ super roundedCorners! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/9/2006 09:45'! addToggle: aString target: anObject selector: aSymbol getStateSelector: stateSymbol enablementSelector: enableSymbol "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." self addToggle: aString target: anObject selector: aSymbol getStateSelector: stateSymbol enablementSelector: enableSymbol argumentList: EmptyArray! ! !MenuMorph methodsFor: 'construction' stamp: 'FernandoOlivero 4/12/2011 09:53'! addStayUpIcons "Add the titlebar with buttons." |title closeBox pinBox titleBarArea titleString spacer1 spacer2| title := submorphs detect: [:ea | ea hasProperty: #titleString] ifNone: [self setProperty: #needsTitlebarWidgets toValue: true. ^self]. closeBox := IconicButton new target: self; actionSelector: #delete; labelGraphic: self theme menuCloseForm; color: Color transparent; extent: 18 @ 18; borderWidth: 0. pinBox := IconicButton new target: self; actionSelector: #stayUp:; arguments: {true}; labelGraphic: self theme menuPinForm; color: Color transparent; extent: 18 @ 18; borderWidth: 0. closeBox setBalloonText: 'Close this menu' translated. pinBox setBalloonText: 'Keep this menu up' translated. spacer1 := AlignmentMorph newSpacer: Color transparent. spacer1 width: 14; hResizing: #rigid. spacer2 := AlignmentMorph newSpacer: Color transparent. spacer2 width: 14; hResizing: #rigid. titleBarArea := AlignmentMorph newRow vResizing: #shrinkWrap; layoutInset: 2; color: title color; addMorphBack: closeBox; addMorphBack: spacer1; addMorphBack: title; addMorphBack: spacer2; addMorphBack: pinBox. title color: Color transparent. titleString := title findDeepSubmorphThat: [:each | each respondsTo: #font:] ifAbsent: []. titleString font: StandardFonts windowTitleFont. self theme currentSettings preferRoundCorner ifTrue: [ titleBarArea roundedCorners: #(1 4); useRoundedCorners]. self addMorphFront: titleBarArea. titleBarArea setProperty: #titleString toValue: (title valueOfProperty: #titleString). title removeProperty: #titleString. self setProperty: #hasTitlebarWidgets toValue: true. self removeProperty: #needsTitlebarWidgets. self removeStayUpItems! ! !MenuMorph methodsFor: 'control' stamp: 'AlainPlantec 12/19/2009 23:23'! popUpAt: aPoint forHand: hand in: aWorld "Present this menu at the given point under control of the given hand. Allow keyboard input into the menu." ^ self popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: self menuKeyboardControl! ! !MenuMorph methodsFor: 'construction' stamp: 'dgd 4/3/2006 13:01'! addTitle: aString updatingSelector: aSelector updateTarget: aTarget "Add a title line at the top of this menu Make aString its initial contents. If aSelector is not nil, then periodically obtain fresh values for its contents by sending aSelector to aTarget.." ^ self addTitle: aString icon: nil updatingSelector: aSelector updateTarget: aTarget! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'mtf 9/19/2007 12:26'! mouseDownInTitle: evt "Handle a mouse down event in the title bar." "Grab the menu and drag it to some other place" evt hand grabMorph: self.! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 3/28/2011 15:00'! addMenuItem: anItem self addMorphBack: anItem. ^ self menuItems add: anItem. ! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:33'! isModalInvokationDone ^self valueOfProperty: #isModalInvokationDone ifAbsent:[false]! ! !MenuMorph methodsFor: 'control' stamp: 'StephaneDucasse 5/28/2011 13:40'! wantsToBeDroppedInto: aMorph "Return true if it's okay to drop the receiver into aMorph. A single-item MenuMorph is in effect a button rather than a menu, and as such should not be reluctant to be dropped into another object." ^ (aMorph isWorldMorph or: [submorphs size = 1]) or: [self embeddable]! ! !MenuMorph methodsFor: 'control' stamp: 'AlainPlantec 12/14/2009 22:11'! activeSubmenu: aSubmenu activeSubMenu ifNotNil: [activeSubMenu delete]. activeSubMenu := aSubmenu. aSubmenu ifNotNil: [activeSubMenu activatedFromDockingBar: nil]! ! !MenuMorph methodsFor: 'construction' stamp: 'StephaneDucasse 3/5/2010 14:41'! addServices: services for: served extraLines: linesArray services withIndexDo: [:service :i | self addService: service for: served. submorphs last setBalloonText: service description. (linesArray includes: i) | service usingLineAfter ifTrue: [self addLine]]. ! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/9/2006 09:39'! addToggle: aString target: anObject selector: aSymbol getStateSelector: stateSymbol argumentList: argList "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." self addToggle: aString target: anObject selector: aSymbol getStateSelector: stateSymbol enablementSelector: nil argumentList: argList! ! !MenuMorph methodsFor: 'accessing' stamp: 'HilaireFernandes 11/19/2010 17:02'! embeddable ^ embeddable ifNil: [embeddable := false]. ! ! !MenuMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 14:23'! justDroppedInto: aMorph event: evt | halo | super justDroppedInto: aMorph event: evt. halo := evt hand halo. (halo notNil and:[halo target hasOwner: self]) ifTrue:[ "Grabbed single menu item" self addHalo: evt. ]. stayUp ifFalse:[evt hand newMouseFocus: self].! ! !MenuMorph methodsFor: 'control' stamp: 'alain.plantec 2/9/2009 12:41'! selectItem: aMenuItem event: anEvent selectedItem ifNotNil:[selectedItem deselect: anEvent]. selectedItem := aMenuItem. selectedItem ifNotNil:[selectedItem select: anEvent].! ! !MenuMorph methodsFor: 'events' stamp: 'nice 1/5/2010 15:59'! popUpAdjacentTo: rightOrLeftPoint forHand: hand from: sourceItem "Present this menu at the given point under control of the given hand." | tryToPlace selectedOffset | hand world startSteppingSubmorphsOf: self. popUpOwner := sourceItem. self fullBounds. self updateColor. "ensure layout is current" selectedOffset := (selectedItem ifNil: [self items first]) position - self position. tryToPlace := [:where :mustFit | | delta | self position: where - selectedOffset. delta := self fullBoundsInWorld amountToTranslateWithin: sourceItem worldBounds. (delta x = 0 or: [mustFit]) ifTrue: [delta = (0 @ 0) ifFalse: [self position: self position + delta]. sourceItem world addMorphFront: self. ^ self]]. tryToPlace value: rightOrLeftPoint first value: false; value: rightOrLeftPoint last - (self width @ 0) value: false; value: rightOrLeftPoint first value: true! ! !MenuMorph class methodsFor: 'utilities' stamp: 'MarcusDenker 9/13/2013 16:32'! 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." "MenuMorph confirm: 'Are you sure?' trueChoice: 'yes, I''m ' falseChoice: 'no, I just thought'" | menu aBlock result | (ProvideAnswerNotification signal: queryString) ifNotNil: [ :answer | ^ trueChoice = answer ]. aBlock := [ :v | result := v ]. menu := self new. menu addTitle: queryString icon: Smalltalk ui icons confirmIcon. menu add: trueChoice target: aBlock selector: #value: argument: true. menu add: falseChoice target: aBlock selector: #value: argument: false. [ menu invokeAt: ActiveHand position in: ActiveWorld allowKeyboard: true. result isNil ] whileTrue. ^ result! ! !MenuMorph class methodsFor: 'images' stamp: 'alain.plantec 2/9/2009 16:44'! pushPinImage "Answer the push-pin image, creating and caching it at this time if it is absent" ^ PushPinImage ifNil: [PushPinImage := Form extent: 16 @ 16 depth: 32 fromArray: #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4289374634 4280690213 4282467139 4281811785 4286217083 0 0 0 0 0 0 0 0 0 0 0 4279900698 4289771447 4283150819 4278686942 4278602609 4281216819 4292862175 0 0 0 0 0 0 0 0 4292598747 4278519045 4291812321 4278425828 4278229220 4278360034 4278533726 4281676595 0 0 0 0 0 0 0 0 4293059298 4278781959 4289902007 4280591330 4278294757 4278359779 4278618315 4278454800 4287730065 0 0 0 0 4293717228 4289835441 4291743438 4288782753 4278782730 4283980117 4287155693 4278294756 4278360036 4278425831 4278725183 4281348657 0 0 0 4293190884 4281413937 4281677109 4278387459 4278584069 4278457889 4278717198 4285372595 4278753764 4278359781 4278556389 4278468957 4278650887 0 0 0 4286019447 4284243036 4283914071 4278781702 4285033581 4279932888 4278683597 4278490589 4278490848 4278620633 4278621404 4278591793 4279242768 0 0 0 4283519312 4285295466 4290165174 4290164405 4294638071 4282232039 4278491363 4278620380 4278723896 4278519564 4278389263 4278387459 4285427310 0 0 0 4285887863 4280431419 4286696174 4290634484 4286170860 4278818529 4278619863 4278661191 4278913293 4285493359 4284177243 4288585374 4294177779 0 0 0 4291480781 4278322439 4278614713 4278490852 4278622435 4278613940 4278458404 4278321667 4278518531 4288914340 0 0 0 0 0 0 0 4281018922 4278464064 4278359263 4278491102 4278724669 4278518276 4278387461 4278321666 4282532418 0 0 0 0 0 0 4292730333 4279045132 4278584327 4278665827 4278489307 4278621404 4278480807 4278595138 4278453252 4281677109 0 0 0 0 0 0 4284900966 4278848010 4283650898 4278781962 4278523682 4278726730 4278592304 4278454027 4278519045 4287861651 0 0 0 0 0 0 4280887593 4290493371 0 4290822079 4284308832 4280163615 4279439633 4281611320 4288322202 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ) offset: 0 @ 0]! ! !MenuMorph class methodsFor: 'utilities' stamp: 'AlainPlantec 11/5/2011 14:30'! chooseFrom: aList lines: linesArray title: queryString "Choose an item from the given list. Answer the index of the selected item." "MenuMorph chooseFrom: #('Hello' 'Pharoers' 'Here' 'We' 'Go') lines: #(2 4) title: 'What''s up?'" | menu result | (ProvideAnswerNotification signal: queryString) ifNotNil:[:answer | 1 to: aList size do:[:i| (aList at: i) = answer ifTrue:[^i]]. ^0]. result := 0. menu := self new. menu addTitle: queryString. 1 to: aList size do:[:i| menu add: (aList at: i) asString target: [:v| result := v] selector: #value: argument: i. (linesArray includes: i) ifTrue: [menu addLine]]. menu invokeAt: ActiveHand position in: ActiveWorld allowKeyboard: true. ^result! ! !MenuMorph class methodsFor: 'utilities' stamp: 'AlainPlantec 11/5/2011 14:30'! chooseFrom: aList values: valueList lines: linesArray title: queryString "Choose an item from the given list. Answer the index of the selected item." "MenuMorph chooseFrom: #('Hello' 'Pharoers' 'Here' 'We' 'Go') values: #('Ph' 'Pha' 'Pharo' 'Yeah' 'YeahYeah') lines: #(2 4) title: 'What''s up?'" | menu result | (ProvideAnswerNotification signal: queryString) ifNotNil:[:answer | 1 to: aList size do:[:i| (aList at: i) = answer ifTrue:[^answer]]. ^nil]. result := nil. menu := self new. menu addTitle: queryString. 1 to: aList size do:[:i| menu add: (aList at: i) asString target: [:v| result := v] selector: #value: argument: (valueList at: i). (linesArray includes: i) ifTrue:[menu addLine]]. menu invokeAt: ActiveHand position in: ActiveWorld allowKeyboard: true. ^result! ! !MenuMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 1/5/2010 12:27'! initialize "MenuMorph initialize" PushPinImage := nil! ! !MenuMorph class methodsFor: 'example' stamp: 'StephaneDucasse 1/29/2010 22:19'! example "MenuMorph example openInHand" | menu | menu := MenuMorph new. menu addStayUpItem. menu add: 'apples' action: #apples. menu add: 'oranges' action: #oranges. menu addLine. menu addLine. "extra lines ignored" menu add: 'peaches' action: #peaches. menu addLine. menu add: 'pears' action: #pears. menu addLine. ^ menu ! ! !MenuMorph class methodsFor: 'images' stamp: 'jrp 7/27/2005 23:11'! closeBoxImage "Supplied here because we don't necessarily have ComicBold" ^ CloseBoxImage ifNil: [CloseBoxImage := SystemWindow closeBoxImage]! ! !MenuMorph class methodsFor: 'utilities' stamp: 'StephaneDucasse 1/29/2010 22:28'! 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." "MenuMorph confirm: 'Are you sure?'" ^ self confirm: queryString trueChoice: 'Yes' translated falseChoice: 'No' translated! ! !MenuMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 10/19/2010 23:17'! fromArray: anArray "Construct a menu from anArray. See #addList comment" ^ self new addList: anArray. ! ! !MenuMorph class methodsFor: 'utilities' stamp: 'StephaneDucasse 1/29/2010 22:28'! confirm: queryString 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." "MenuMorph confirm: 'Reboot universe now' orCancel:[^'Nevermind'] " | choice | choice := self chooseFrom: {'Yes' translated. 'No' translated. 'Cancel' translated} lines: #() title: queryString. choice = 1 ifTrue: [^ true]. choice = 2 ifTrue: [^ false]. ^ cancelBlock value! ! !MenuMorph class methodsFor: 'instance creation' stamp: 'jm 5/14/1998 17:21'! entitled: aString "Answer a new instance of me with the given title." ^ self new addTitle: aString ! ! !MenuRegistration commentStamp: 'AlainPlantec 2/16/2010 23:17'! A MenuRegistration stores the declaration of a menu item. It is mainly an handler for a PluggableMenuItemSpec. A menu item is declared withing a particular method tagged with a pragma. This kind-of method takes a builder as argument and its evaluation results in the building of a MenuRegistration sub-tree which is stored in the builder. As an example: MenuRegistrationExample class>>myOwnCoolToolRegistrationOn: aBuilder (aBuilder item: #MyOwnCoolTool) label: 'My own cool tool'; target: Workspace; selector: #openContents: ; arguments: #('yep, my own cool tool can be opened from the world menu !! :)') Evaluating this method results in the creation of a MenuRegistration which name is #MyOwnCoolTool. Thus, the resulting sub-tree is only made of a root node. After it has be built, this root node is recorded in the builder. To experiment this, just evaluate the following code: ------------- | builder | builder := PragmaMenuBuilder new. MenuRegistrationExample myOwnCoolToolRegistrationOn: builder. builder explore ------------- Using pragma allows the menu builder to dynamically discover which are the methods to evaluate in order to build a menu. Thus, a resulting menu is built by evaluating a set of methods which share the same pragma keyword. In the following example, all method having are evaluated for the building of the resulting menu: --------------- (PragmaMenuBuilder pragmaKeyword: 'worldMenuExample' model: nil) menu popUpInWorld --------------- Within a method, three kind of declarations can be used: (1) item by item (2) an item with a sub-menu and (3) a group. 1 - item by item menu registration declaration: This kind of declaring is for the setting of one menu item and only one within a method. 1.1 - A simple menu item with an action In the following example, a menu item with the name #'Browser' and a action which consists in sending #openClassBrowser to StandardToolSet is declared: AClassSomewhere class>>openBrowserOn: aBuilder (aBuilder item: #'Browser') target: StandardToolSet; selector: #openClassBrowser. A simple action without any argument can also be set with a block: (aBuilder item: #'Browser') action: [StandardToolSet openClassBrowser] You can also indicate a balloon help string and a particular icon: (aBuilder item: #'Browser') action: [StandardToolSet openClassBrowser]; help: 'Open a system browser'; icon: MenuIcons smallSystemBrowserIcon If the action needs one or several arguments, you can also give it/them as follow: (aBuilder item: #'Save and quit') target: SmalltalkImage current; selector: #snapshot:andQuit:. arguments: #(true true) By default, the item label is set with the item name but it can be explicitly given as follow: (aBuilder item: #'Browser') label: 'System browser'; target: StandardToolSet; selector: #openClassBrowser. 1.2 - Placing the menu item in a menu The resulting menu item of previous example will be placed at the root of the menu. In order to declare another place for it, you have to explicitly set its parent name. As an example, consider the following item which declares a simple entry with no action. Such item is typically used as a root for a sub-menu tree: AClassSomewhere class>>openToolsOn: aBuilder (aBuilder item: #'Tools') Now, a sub-menu item for #Tools can be declared separately, within another method by using the #parent: message: AnotherClassSomewhere class>>myToolsOn: aBuilder (aBuilder item: #'CoolTool') label: 'Cool tool'; parent: #Tools; Note that the argument of #parent: must be the name of another item. If it is not the case, then the parent name indication is simply ignored. 1.3 - Item ordering If no ordering setting is indicated, items ordering is unpredicable (it depends on method retrieving order). If one want an item to appear at a certain position, it is possible to set it by sending #order: to a MenuRegistration. The #order: message takes a float as argument. As an example, see the two following declarations, in the resulting menu, Wozy is placed before 'Wozy configuration' AnotherClassSomewhere class>>myWozySystemOpenOn: aBuilder (aBuilder item: #'Wozy') parent: #CoolTool; order: 1.0 AnotherClassSomewhere class>>myWozySystemConfigOn: aBuilder (aBuilder item: #'Wozy configuration') parent: #CoolTool; order: 2.0 2) Item with a submenu The one menu item - one declaring method way can be ugly. When a set a menu items are known to be put all-together, it is possible to declare the sub-tree in one method. The following example show such a sub-tree with the #Tools item at root and four sub-items declared in a single method. Note a menu target declared for the root is shared by all sub-items. In that case, it also remains possible for a sub-item to declare its own target. AClassSomewhere class>>openToolsOn: aBuilder (aBuilder item: #'Tools') target: StandardToolSet; "The target is shared by all children" with: [ "My sub-menu are given here" (aBuilder item: #'System browser') selector: #openClassBrowser. (aBuilder item: #Workspace) selector: #openWorkspace. (aBuilder item: #'Test Runner') selector: #openTestRunner. (aBuilder item: #'Monticello Browser') selector: #openMonticelloBrowser] 3) group of menu items When you want some items to be shown always grouped together, you can use a group. Its declaring is like an item with a submenu except that you are using the message #group: instead of #item:. The consequence is that only the children are shown in the menu. Of course, #label and #icon: are ignored for a group. Here is an example: AClassSomewhere class>>mostUsedToolsOn: aBuilder (aBuilder group: #MostUsedTools) "My name can be also used as parent name" withSeparatorAfter; "A separator will be added after my last child" order: 0; "the entire group will be placed at the top" target: StandardToolSet; "The target is shared by all children" with: [ (aBuilder item: #'System browser') selector: #openClassBrowser. (aBuilder item: #Workspace) selector: #openWorkspace. (aBuilder item: #'Test Runner') selector: #openTestRunner. (aBuilder item: #'Monticello Browser') selector: #openMonticelloBrowser] --------------------------- Instance Variables isGroup: itemList: order: owner: parentName: spec: isGroup - if true, then this item is ignored and flatten itemList - all my MenuRegistration (my sub-menus or my elements if i'm a group) order - my order in the owner list owner - my owner parentName - the declared parent name which serve as basis for PragmaBenuBuilder>>#arrangeRegistrations spec - my PluggableMenuItemSpec ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/13/2010 12:59'! target ^ self spec action ifNotNil: [:action | action receiver] ! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/10/2010 21:03'! parent: aSymbol self parentName: aSymbol! ! !MenuRegistration methodsFor: 'accessing' stamp: 'StephaneDucasse 6/5/2011 22:43'! buildMenuSpec: aMenu "recursiveley build the menu spec aMenu passed as argument" self itemList ifNotNil: [:l | | m | m := isGroup ifFalse: [PluggableMenuSpec withModel: nil] ifTrue: [aMenu]. (l reject: [:i | i precondition value not]) do: [:i | i buildMenuSpec: m]. isGroup ifFalse: [self spec subMenu: m]]. isGroup ifTrue: [self spec separator ifTrue: [self itemList ifNotNil: [self itemList last spec separator: true]]] ifFalse: [aMenu items add: self spec]! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/16/2010 16:45'! addItem: anItem "Add a MenuRegistration" self ensureItemList add: anItem! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/16/2010 11:42'! isGroup: aBoolean isGroup := aBoolean! ! !MenuRegistration methodsFor: 'sub item creating' stamp: 'AlainPlantec 2/16/2010 13:08'! item: aSymbol "set my name and my label with aSymbol (the label and the name as the same by default) and register myself as a child of my owner" ^ (self builder newSubItem) name: aSymbol; label: aSymbol asString ! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/16/2010 16:45'! itemList "Return my children" ^ itemList ! ! !MenuRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/24/2012 20:29'! itemNamed: aName "Return the MenuRegistration named aName or nil if none is found" | result | self name = aName ifTrue: [^ self]. result := self itemList ifNotNil: [:l | l detect: [:item | (item itemNamed: aName) notNil] ifNone: []]. ^ result ifNil: [ nil ] ifNotNil: [ result itemNamed: aName ]! ! !MenuRegistration methodsFor: 'initialization' stamp: 'AlainPlantec 2/11/2010 16:35'! initialize super initialize. isGroup := false! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'StephaneDucasse 12/11/2013 10:33'! enabledBlock ^ self spec enabledBlock ! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/15/2010 11:17'! itemList: aCollection "Set the list of MenuRegistration" itemList := aCollection! ! !MenuRegistration methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 1/24/2012 20:17'! printOn: aStream super printOn: aStream. aStream << ' ( ' << self name asString << ' ) '! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/16/2010 16:45'! ensureItemList "Return the list of MenuRegistration instances" ^ itemList ifNil: [itemList := OrderedCollection new]! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/12/2010 16:04'! help: anHelpText "set the help text" self spec help: anHelpText! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/12/2010 16:06'! label: aLabel "set the label that is shown in the menu" self spec label: aLabel! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'BenjaminVanRyseghem 4/6/2012 18:48'! enabled: aBooleanOrABlock aBooleanOrABlock == true ifTrue: [ self spec enabled: true. ^ self ]. aBooleanOrABlock == false ifTrue: [ self spec enabled: false. ^ self ]. self spec enabled: (aBooleanOrABlock cull: self model).! ! !MenuRegistration methodsFor: 'sub item creating' stamp: 'AlainPlantec 2/16/2010 13:43'! newSubItem | reg | reg := self class owner: self. self addItem: reg. ^ reg! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/13/2010 13:28'! target: anObject "set the target for the action" self spec action ifNil: [self spec action: (MessageSend receiver: (anObject ifNil: [owner itemReceiver]) selector: nil)] ifNotNil: [self spec action receiver: anObject]! ! !MenuRegistration methodsFor: 'initialize-release' stamp: 'AlainPlantec 2/15/2010 11:21'! release itemList := nil. super release ! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'EstebanLorenzano 1/30/2013 16:55'! keyText: aString self spec keyText: aString! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/16/2010 19:37'! assignOrderWithBlock: aBlock "Compute recursively MenuRegistration order" self itemList ifNotNil: [self itemList: (aBlock value: self itemList). self itemList do: [:rded | rded assignOrderWithBlock: aBlock]]! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:52'! builder ^ owner builder! ! !MenuRegistration methodsFor: 'sub item creating' stamp: 'AlainPlantec 2/16/2010 11:42'! group: aSymbol ^ (self item: aSymbol) isGroup: true! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/15/2010 11:05'! removeItem: anItem "Remove a MenuRegistration" self itemList remove: anItem ! ! !MenuRegistration methodsFor: 'sub item creating' stamp: 'AlainPlantec 2/16/2010 11:47'! with: aBlock self builder currentRoot: self while: aBlock! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/10/2010 13:54'! parentName ^ parentName! ! !MenuRegistration methodsFor: 'initialize-release' stamp: 'AlainPlantec 2/18/2010 11:53'! reset itemList ifNotNil: [ itemList do: [:i | i reset]. itemList := nil]. spec := nil ! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'BenjaminVanRyseghem 4/6/2012 18:27'! action: aMessageSendOrABlock "set the action of the menu" aMessageSendOrABlock isBlock ifTrue: [ self target: aMessageSendOrABlock. self selector: #cull:. self arguments: {self model}] ifFalse: [ self selector: aMessageSendOrABlock] ! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/11/2010 08:15'! order ^ order! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 4/10/2010 09:31'! precondition ^ precondition ifNil: [[true]]! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/13/2010 12:59'! arguments: anArray "set the arguments for an item with an action" self spec action ifNil: [self spec action: (MessageSend receiver: self itemReceiver selector: nil arguments: anArray)] ifNotNil: [self spec action arguments: anArray]! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/10/2010 13:54'! parentName: aSymbol parentName := aSymbol! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/11/2010 08:15'! owner ^ owner! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/13/2010 12:58'! selector: aSymbol "set the selector for item with an action" self spec action ifNil: [self spec action: (MessageSend receiver: self itemReceiver selector: aSymbol)] ifNotNil: [self spec action selector: aSymbol]! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/12/2010 22:23'! icon: aForm "set the icon that is shown in the menu" self spec icon: aForm! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/12/2010 16:09'! withSeparatorAfter "add a separator line after me" self spec separator: true! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/12/2010 16:07'! name: aSymbol "set my name (should be unique over all menu items" self spec name: aSymbol! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/15/2010 11:05'! order: aNumber "Set the value of order" order := aNumber! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/12/2010 16:06'! label "return my label" ^ self spec label! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:58'! itemReceiver ^ self target ifNil: [owner itemReceiver]! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/11/2010 08:15'! owner: anItem owner := anItem! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'BenjaminVanRyseghem 3/31/2011 01:50'! enabledBlock: aBlock self spec enabledBlock: aBlock! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/16/2010 16:51'! sort: aSortBlock "Sort the tree recursively" self itemList ifNotNil: [ self itemList: (self itemList asSortedCollection: aSortBlock). self itemList do: [:rded | rded sort: aSortBlock] ]! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/16/2010 16:49'! collectMisplacedItemsIn: aCollection "Select recursively all MenuRegistration with a parentName different from its owner name. This is possible since a parent name can be given in order to force a menu item placement. If my parentName is not the same as my owner name then it means that I'm not in the right place and that my placement has to be resolved" self parentName ifNotNil: [owner ifNil: [aCollection add: self] ifNotNil: [owner name = self parentName ifFalse: [aCollection add: self]]]. self itemList ifNotNil: [:l | l do: [:item | item collectMisplacedItemsIn: aCollection]]! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/12/2010 16:07'! name "returns my name which is used as a key (should unique over all the menu items" ^ self spec name! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 4/10/2010 09:31'! precondition: aValuable precondition := aValuable! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:54'! model ^ self builder model! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/12/2010 16:08'! spec "return my PluggableMenuItemSpec" ^ spec ifNil: [spec := PluggableMenuItemSpec new]! ! !MenuRegistration class methodsFor: 'instance creation' stamp: 'AlainPlantec 2/16/2010 12:20'! owner: aMenuRegistration ^ self new owner: aMenuRegistration! ! !MenuRegistrationExample commentStamp: 'AlainPlantec 2/17/2010 01:10'! I'm here to show you how to use the menu registration. See class side methods and try it with: ---------------- (PragmaMenuBuilder pragmaKeyword: 'worldMenuExample' model: nil) menu popUpInWorld ---------------- ! !MenuRegistrationExample class methodsFor: 'menu actions' stamp: 'StephaneDucasse 3/17/2010 21:13'! saveAndQuit Smalltalk snapshot: true andQuit: true! ! !MenuRegistrationExample class methodsFor: 'menu declaring' stamp: 'IgorStasenko 4/15/2011 17:19'! mostUsedToolsOn: aBuilder (aBuilder group: #MostUsedTools) withSeparatorAfter; order: 0; target: Smalltalk tools; with: [ (aBuilder item: #'System browser') selector: #openClassBrowser; icon: Smalltalk tools browser taskbarIcon. (aBuilder item: #Workspace) selector: #openWorkspace; icon: Smalltalk tools workspace taskbarIcon. (aBuilder item: #'Monticello Browser') selector: #openMonticelloBrowser; icon: Smalltalk tools monticelloBrowser taskbarIcon]! ! !MenuRegistrationExample class methodsFor: 'menu declaring' stamp: 'StephaneDucasse 3/17/2010 21:13'! quitItemsOn: aBuilder (aBuilder group: #QuitPharo) order: 9999; with: [{ {'Save'. {Smalltalk. #saveSession}. 'save the current version of the image on disk'}. {'Save as...'. {self. #saveAs}. 'save the current version of the image on disk under a new name.'}. {'Save and quit'. {self. #saveAndQuit}. 'save the current image on disk, and quit Pharo.'}. {'Quit'. {self. #quitSession}. 'quit Pharo.'} } do: [:triplet | (aBuilder item: triplet first asSymbol) target: triplet second first; selector: triplet second second; help: (triplet size > 2 ifTrue: [triplet third] ifFalse: [nil])]]! ! !MenuRegistrationExample class methodsFor: 'menu declaring' stamp: 'IgorStasenko 4/15/2011 17:18'! myOwnCoolToolRegistrationOn: aBuilder (aBuilder item: #MyOwnCoolTool) parent: #Tools; label: 'My own cool tool'; target: Smalltalk tools workspace; selector: #openContents: ; arguments: #('yep, my own cool tool can be opened from the world menu !! :)') ! ! !MenuRegistrationExample class methodsFor: 'menu actions' stamp: 'StephaneDucasse 3/17/2010 21:13'! quitSession Smalltalk snapshot: (self confirm: 'Save changes before quitting?' translated orCancel: [ ^ self ]) andQuit: true! ! !MenuRegistrationExample class methodsFor: 'menu declaring' stamp: 'AlainPlantec 2/12/2010 15:02'! pragmaKeyword ^ 'worldMenuExample'! ! !MenuRegistrationExample class methodsFor: 'menu declaring' stamp: 'IgorStasenko 4/15/2011 17:18'! myOwnCoolMenuRegistrationOn: aBuilder (aBuilder item: #MyOwnCoolMenu) parent: #Tools; "place me as a child of the #Tools node (declared by #toolsOn:)" label: 'The coolest tool here'; with: [ (aBuilder item: #MyOwnCoolTool) label: 'My own cool tool also here'; target: Smalltalk tools workspace; selector: #openContents: ; arguments: #('yep, my own cool tool can be also opened from a world sub-menu !! :)')]! ! !MenuRegistrationExample class methodsFor: 'menu actions' stamp: 'StephaneDucasse 6/11/2012 18:12'! saveAs Smalltalk saveAs.! ! !MenuRegistrationExample class methodsFor: 'menu declaring' stamp: 'EstebanLorenzano 5/14/2013 09:44'! toolsOn: aBuilder (aBuilder item: #Tools) order: 1.0; target: Smalltalk tools; icon: Smalltalk ui icons smallDoItIcon; withSeparatorAfter; with: [(aBuilder item: #Transcript) selector: #openTranscript; icon: Smalltalk tools transcript taskbarIcon. (aBuilder item: #'File Browser') selector: #openFileList; icon: Smalltalk tools fileList taskbarIcon. (aBuilder item: #'Process Browser') selector: #openProcessBrowser; icon: Smalltalk tools processBrowser taskbarIcon; withSeparatorAfter]! ! !MenuRegistrationExample class methodsFor: 'menu declaring' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme "Answer the ui theme that provides controls." ^ Smalltalk ui theme ! ! !MenuSpec methodsFor: 'accessing' stamp: 'StephaneDucasse 6/10/2011 22:09'! help "Answer the message to get the help texts of this element." ^ help! ! !MenuSpec methodsFor: 'accessing' stamp: 'StephaneDucasse 6/10/2011 22:10'! name: anObject name := anObject! ! !MenuSpec methodsFor: 'accessing' stamp: 'StephaneDucasse 6/10/2011 22:09'! help: aSymbol "Indicate the message to retrieve the help texts of this element." help := aSymbol! ! !MenuSpec methodsFor: 'accessing' stamp: 'StephaneDucasse 6/10/2011 22:10'! name ^ name! ! !MergeDiffMorph methodsFor: 'actions' stamp: 'gvc 11/1/2006 14:15'! compositeText "Answer the composite text based on the selection state of the joins." ^self joinMorph compositeText ! ! !MergeDiffMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:17'! allowJoinClicks: anObject "Set the value of allowJoinClicks" allowJoinClicks := anObject! ! !MergeDiffMorph methodsFor: 'initialization' stamp: 'gvc 1/8/2009 18:17'! initialize "Initialize the receiver." super initialize. self allowJoinClicks: true! ! !MergeDiffMorph methodsFor: 'actions' stamp: 'gvc 11/1/2006 14:15'! update: aspect "A join has probably changed its selection state." super update: aspect. aspect == #joinClicked ifTrue: [self changed; changed: #selectedDifferences]! ! !MergeDiffMorph methodsFor: 'actions' stamp: 'gvc 11/1/2006 14:15'! newJoinMorph "Answer a new join morph." ^super newJoinMorph when: #joinClicked send: #update: to: self with: #joinClicked! ! !MergeDiffMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:17'! allowJoinClicks "Answer the value of allowJoinClicks" ^ allowJoinClicks! ! !MergeDiffMorph methodsFor: 'obsolete' stamp: 'gvc 7/6/2007 15:38'! indicateSrc "Change the indicators of the joins to the src side." self joinMappings do: [:section | section selectionState: #src]. self changed; changed: #selectedDifferences! ! !MergeDiffMorph methodsFor: 'actions' stamp: 'gvc 1/8/2009 18:17'! calculatedJoinMappings "Specify click allowance for each section." ^super calculatedJoinMappings do: [:j | j allowClick: self allowJoinClicks]! ! !MergeDiffMorph methodsFor: 'obsolete' stamp: 'gvc 7/6/2007 15:37'! indicateDst "Change the indicators of the joins to the dst side." self joinMappings do: [:section | section selectionState: #dst]. self changed; changed: #selectedDifferences! ! !MergeDiffMorph methodsFor: 'actions' stamp: 'gvc 11/1/2006 14:13'! joinSectionClass "Answer the class to use for a new join section." ^MergeJoinSection! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 1/8/2009 18:04'! wantsClick "Allow if explictly enabled and super." ^self allowClick and: [super wantsClick]! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/30/2006 15:25'! selected: aBoolean "Set the value of selected" selected := aBoolean. self updateHighlights; changed: #selected! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 4/29/2011 00:36'! drawOn: aCanvas "Draw the join on the given canvas." super drawOn: aCanvas. self stateIcon ifNotNil: [:i | aCanvas translucentImage: i at: self stateIconBounds topLeft]! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:22'! borderColorToUse "Answer the border color to use based on the selection state." ^self selected ifTrue: [self selectedBorderColor] ifFalse: [super borderColorToUse]! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/31/2006 13:00'! selectionState "Answer the value of selectionState" ^ selectionState! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/31/2006 13:03'! stateIcons: anObject "Set the value of stateIcons" stateIcons := anObject! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:01'! selectionStates "Answer the valid selection states in order." ^#(src dst both neither)! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 12:10'! appendToCompositeText: aText "If appropriate append the relevant src or dst text to the given text." self selectionState == #src ifTrue: [^aText append: self src text]. self selectionState == #dst ifTrue: [^aText append: self dst text]. self selectionState == #both ifTrue: [ ^aText append: self src text; append: self dst text]! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:14'! stateIcon "Answer the state icon to use." self wantsClick ifFalse: [^nil]. ^self stateIcons at: (self selectionStates indexOf: self selectionState)! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:09'! clicked "The receiver or a highlight was clicked." self wantsClick ifFalse: [^false]. self selectNextState. ^true! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/25/2006 17:43'! selectedBorderColor "Answer the value of selectedBorderColor" ^ selectedBorderColor! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:04'! allowClick: anObject "Set the value of allowClick" allowClick := anObject! ! !MergeJoinSection methodsFor: 'initialization' stamp: 'gvc 1/8/2009 18:05'! initialize "Initialize the receiver." self allowClick: true; selected: false; selectionState: #dst; stateIcons: self defaultStateIcons; selectedBorderColor: Color black. super initialize! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 13:03'! selectNextState "Set the selection state to the next one with wraparound." self selectionState: ( self selectionStates at: ( (self selectionStates indexOf: self selectionState) \\ self selectionStates size + 1))! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/25/2006 17:47'! selected "Answer the value of selected" ^ selected! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! defaultStateIcons "Answer the default state icons." ^{ Smalltalk ui icons smallBackIcon. Smalltalk ui icons smallForwardIcon. Smalltalk ui icons smallOkIcon. Smalltalk ui icons smallCancelIcon }! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/25/2006 17:43'! selectedBorderColor: anObject "Set the value of selectedBorderColor" selectedBorderColor := anObject! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 13:44'! stateIconBounds "Answer the bounds of the state icon." |i| i := self stateIcon ifNil: [^nil]. ^self shape bounds center - (i extent // 2) extent: i extent! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:04'! allowClick "Answer the value of allowClick" ^ allowClick! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/31/2006 13:03'! stateIcons "Answer the value of stateIcons" ^ stateIcons! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/31/2006 13:00'! selectionState: anObject "Set the value of selectionState" selectionState := anObject! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:18'! containsPoint: aPoint "Answer whether the receiver contains the given point." ^(super containsPoint: aPoint) or: [ self stateIcon notNil and: [self stateIconBounds containsPoint: aPoint]]! ! !Message commentStamp: ''! I represent a selector and its argument values. Generally, the system does not use instances of Message for efficiency reasons. However, when a message is not understood by its receiver, the interpreter will make up an instance of me in order to capture the information involved in an actual message transmission. This instance is sent it as an argument with the message doesNotUnderstand: to the receiver.! !Message methodsFor: 'accessing' stamp: ''! selector "Answer the selector of the receiver." ^selector! ! !Message methodsFor: 'comparing' stamp: 'eem 11/27/2008 13:17'! analogousCodeTo: anObject "For MethodPropertires comparison." ^self class == anObject class and: [selector == anObject selector and: [args = anObject arguments and: [lookupClass == anObject lookupClass]]]! ! !Message methodsFor: 'printing' stamp: 'sma 6/1/2000 10:01'! storeOn: aStream "Refer to the comment in Object|storeOn:." aStream nextPut: $(; nextPutAll: self class name; nextPutAll: ' selector: '; store: selector; nextPutAll: ' arguments: '; store: args; nextPut: $)! ! !Message methodsFor: 'sending' stamp: 'HernanMoralesDurand 1/26/2014 08:32'! sentTo: receiver "answer the result of sending this message to receiver" ^ lookupClass ifNil: [ receiver perform: selector withArguments: args] ifNotNil: [ receiver perform: selector withArguments: args inSuperclass: lookupClass]! ! !Message methodsFor: 'sending' stamp: 'ajh 1/22/2003 11:51'! sendTo: receiver "answer the result of sending this message to receiver" ^ receiver perform: selector withArguments: args! ! !Message methodsFor: 'private' stamp: ''! setSelector: aSymbol arguments: anArray selector := aSymbol. args := anArray! ! !Message methodsFor: 'private' stamp: 'ajh 9/23/2001 04:59'! lookupClass: aClass lookupClass := aClass! ! !Message methodsFor: 'accessing' stamp: ''! argument: newValue "Change the first argument to newValue and answer self" args at: 1 put: newValue! ! !Message methodsFor: 'testing' stamp: 'JuanVuletich 10/11/2010 20:33'! hasArguments ^args size > 0! ! !Message methodsFor: 'printing' stamp: 'ajh 10/9/2001 15:31'! printOn: stream args isEmpty ifTrue: [^ stream nextPutAll: selector]. args with: selector keywords do: [:arg :word | stream nextPutAll: word. stream space. arg printOn: stream. stream space. ]. stream skip: -1. ! ! !Message methodsFor: 'accessing' stamp: ''! argument "Answer the first (presumably sole) argument" ^args at: 1! ! !Message methodsFor: 'accessing' stamp: 'ajh 10/9/2001 16:32'! lookupClass ^ lookupClass! ! !Message methodsFor: 'accessing' stamp: 'eem 1/3/2009 10:42'! numArgs "Answer the number of arguments in this message" ^args size! ! !Message methodsFor: 'private' stamp: 'ajh 3/9/2003 19:25'! setSelector: aSymbol selector := aSymbol. ! ! !Message methodsFor: 'accessing' stamp: ''! arguments "Answer the arguments of the receiver." ^args! ! !Message methodsFor: 'accessing' stamp: ''! sends: aSelector "answer whether this message's selector is aSelector" ^selector == aSelector! ! !Message class methodsFor: 'instance creation' stamp: ''! selector: aSymbol arguments: anArray "Answer an instance of me with selector, aSymbol, and arguments, anArray." ^self new setSelector: aSymbol arguments: anArray! ! !Message class methodsFor: 'instance creation' stamp: ''! selector: aSymbol "Answer an instance of me with unary selector, aSymbol." ^self new setSelector: aSymbol arguments: (Array new: 0)! ! !Message class methodsFor: 'instance creation' stamp: ''! selector: aSymbol argument: anObject "Answer an instance of me whose selector is aSymbol and single argument is anObject." ^self new setSelector: aSymbol arguments: (Array with: anObject)! ! !MessageAsTempNode commentStamp: ''! This node represents accesses to temporary variables for do-its in the debugger. Since they execute in another context, they must send a message to the original context to access the value of the temporary variable in that context.! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 10/12/1999 17:29'! code "Allow synthetic temp nodes to be sorted by code" ^ arguments first literalValue! ! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:38'! asStorableNode: encoder "This node is a message masquerading as a temporary variable. It currently has the form {homeContext tempAt: offset}. We need to generate code for {expr storeAt: offset inTempFrame: homeContext}, where the expr, the block argument, is already on the stack. This, in turn will get turned into {homeContext tempAt: offset put: expr} at runtime if nobody disturbs storeAt:inTempFrame: in Object (not clean)" ^ MessageAsTempNode new receiver: nil "suppress code generation for reciever already on stack" selector: #storeAt:inTempFrame: arguments: (arguments copyWith: receiver) precedence: precedence from: encoder! ! !MessageAsTempNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52'! sizeCodeForStorePop: encoder "This node has the form {expr storeAt: offset inTempFrame: homeContext}, where the expr, the block argument, is already on the stack." ^self sizeCodeForEffect: encoder! ! !MessageAsTempNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52'! emitCodeForStorePop: stack encoder: encoder "This node has the form {expr storeAt: offset inTempFrame: homeContext}, where the expr, the block argument, is already on the stack." ^self emitCodeForEffect: stack encoder: encoder! ! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'eem 6/24/2008 11:50'! store: expr from: encoder "ctxt tempAt: n -> ctxt tempAt: n put: expr (see Assignment). For assigning into temps of a context being debugged." selector key ~= #namedTempAt: ifTrue: [^self error: 'cant transform this message']. ^ MessageAsTempNode new receiver: receiver selector: #namedTempAt:put: arguments: (arguments copyWith: expr) precedence: precedence from: encoder! ! !MessageBrowser commentStamp: ''! A MessageBrowser is a UI to browse a list of method, regardless of what they could be. example: MessageBrowser new openWithSpec; messages: (SystemNavigation new allSendersOf: #at:) yourself! !MessageBrowser methodsFor: 'text selection' stamp: ''! autoSelect: aSelector textModel readSelectionBlock: [:text | self searchedString: aSelector in: text ]! ! !MessageBrowser methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! highlightSearchedString: string | searchedString interval firstIndex | searchedString := searchedStringHolder value. searchedString ifNil: [ ^ 0 to: 0 ]. (searchedString includes: $:) ifTrue: [ | list | list := searchedString subStrings: ':'. list size = 1 ifTrue: [" binary selector " firstIndex := string findString: searchedString. interval := firstIndex to: (firstIndex+searchedString size-1)] ifFalse: [| lastIndex | firstIndex := string findString: list first,':'. lastIndex := string findString: list last,':' startingAt: firstIndex+ (list first size -1). interval := firstIndex to: (lastIndex + list last size)]] ifFalse: [ " unary selector " firstIndex := string findString: searchedString. interval := firstIndex to: (firstIndex+searchedString size-1)]. ^ interval! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:51'! inspectMethod self currentMethod ifNotNil: [ :m | m inspect ]! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/21/2013 00:00'! resetSelection listModel resetSelection! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:59'! browseVersions self currentMethod ifNotNil: [ :method | model browseVersionsFrom: method compiledMethod ]! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/14/2012 11:41'! setSelectedIndex: anIndex listModel setSelectedIndex: anIndex ! ! !MessageBrowser methodsFor: 'initialization' stamp: 'GuillermoPolito 8/5/2013 10:21'! registerListShortcutsFor: aWidget aWidget bindKeyCombination: $b command toAction: [ self browseMethod ]. aWidget bindKeyCombination: $i command toAction: [ self inspectMethod ]. aWidget bindKeyCombination: $m command toAction: [ self browseMessages ]. aWidget bindKeyCombination: $n command toAction: [ self browseSendersOfMessage ]. aWidget bindKeyCombination: $n shift command toAction: [ self browseClassRefs ]. aWidget bindKeyCombination: $v command toAction: [ self browseVersions ]. aWidget bindKeyCombination: $x command toAction: [ self removeMethods ].! ! !MessageBrowser methodsFor: 'accessing' stamp: ''! listModel ^ listModel! ! !MessageBrowser methodsFor: 'announcements' stamp: 'NicolaiHess 1/24/2014 15:57'! methodRemoved: anAnnouncement | item | self isDisplayed ifFalse: [ ^ self ]. refreshingBlockHolder ifNil: [ ^ self ]. item := anAnnouncement methodRemoved. "Item is a compiled methed, where the list is populated with RGMethod" "(refreshingBlockHolder contents cull: item cull: anAnnouncement cull: self) ifFalse: [ ^ self ]." self okToChange ifFalse: [ ^ self ]. UIManager default defer: [ ((item methodClass notNil) and:[item methodClass isObsolete not]) ifTrue:[ | sel itm | sel := listModel selectedIndex. itm := listModel selectedItem. (itm notNil and: [ itm methodClass = item methodClass and: [ itm selector = item selector ] ]) ifTrue: [ textModel hasUnacceptedEdits: false ]. self messages: (listModel listItems remove: item asFullRingDefinition ifAbsent: [ nil ]; yourself). listModel setSelectedIndex: sel ] ]! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:52'! browseClass self currentMethod ifNotNil: [ :method | method methodClass browse ]! ! !MessageBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize textConverterHolder := SourceMethodConverter new asReactiveVariable. model := AbstractTool new. maxClassSize = nil. searchedStringHolder := '' asReactiveVariable. topologicSortHolder := true asReactiveVariable. super initialize. askOkToClose:= true asReactiveVariable. self windowIcon: self taskbarIcon. self registerToAnnouncements. self announcer when: WidgetBuilt send: #buildUpdateTitle to: self! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! refreshingBlock: aBlock refreshingBlockHolder value: aBlock! ! !MessageBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! textConverter ^ textConverterHolder value! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! title: aString titleHolder value: aString.! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! topologicSort ^ topologicSortHolder value! ! !MessageBrowser methodsFor: 'accessing' stamp: ''! textModel ^ textModel! ! !MessageBrowser methodsFor: 'initialization' stamp: 'EstebanLorenzano 9/4/2013 20:51'! buildUpdateTitle "Trying to have a clean subscription, this method is called in #initialize" self updateTitle. textModel text: textModel getText.! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/7/2012 13:17'! messages: aCollection self cacheHierarchyForClasses: aCollection. listModel items: (cachedHierarchy keys sort: [:a :b | self sortClassesInCachedHierarchy: a b: b]) asOrderedCollection. listModel listSize > 1 ifTrue: [ listModel setSelectedIndex: 1 ].! ! !MessageBrowser methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 6/14/2012 11:47'! whenSelectedItemChanged: aBlock listModel whenSelectedItemChanged: aBlock ! ! !MessageBrowser methodsFor: 'private' stamp: ''! maxClassSize ^ maxClassSize ifNil:[| elt stm | elt := (listModel getList detectMax: [:e | e methodClass name size + (cachedHierarchy at: e) size]). stm := String streamContents: [:t | 3 to: (cachedHierarchy at: elt) size do: [:i | t << ' ']. t << elt methodClass name ]. maxClassSize := StandardFonts listFont widthOfString: stm ]. ! ! !MessageBrowser methodsFor: 'announcements' stamp: 'NicolaiHess 1/24/2014 15:56'! methodAdded: anAnnouncement | item | self isDisplayed ifFalse: [ ^ self ]. refreshingBlockHolder ifNil: [ ^ self ]. item := anAnnouncement method. (refreshingBlockHolder value cull: item cull: anAnnouncement cull: self) ifFalse: [ ^ self ]. UIManager default defer: [ ((item methodClass notNil) and:[item methodClass isObsolete not]) ifTrue:[ | sel text boolean | boolean := textModel hasUnacceptedEdits. boolean ifTrue: [ text := textModel pendingText ]. sel := listModel selectedItem. self messages: (listModel listItems add: item asFullRingDefinition; yourself). listModel setSelectedItem: sel. boolean ifTrue: [ textModel pendingText: text ] ] ]! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:55'! removeMethods self currentMethod ifNotNil: [ :method | model removeMethod: method inClass: method methodClass ]! ! !MessageBrowser methodsFor: 'text selection' stamp: 'AlexandreBergel 1/29/2013 16:23'! findFirstOccurrenceOf: searchedString in: textToSearchIn "Return the first index of aString in textToSearchIn " | firstIndex | firstIndex := textToSearchIn findString: searchedString startingAt: 1. [ (firstIndex > 1) and: [ (textToSearchIn at: (firstIndex - 1)) isAlphaNumeric ] ] whileTrue: [ firstIndex := textToSearchIn findString: searchedString startingAt: firstIndex +1 ]. ^ firstIndex! ! !MessageBrowser methodsFor: 'initialization' stamp: 'EstebanLorenzano 1/31/2013 19:25'! setListMenu listModel menu: [ :menu | menu addAllFromPragma:'messageBrowserListMenu' target: self ].! ! !MessageBrowser methodsFor: 'testing' stamp: ''! sortClassesInCachedHierarchy: a b: b "Bullshitty name, Thanks Camillo" | index aa bb minSize| aa := cachedHierarchy at: a. bb := cachedHierarchy at: b. minSize := aa size min: bb size. 1 to: minSize do: [ :i | |compare| compare := (aa at: i) name compare: (bb at: i) name. compare ~~ 2 ifTrue: [ ^ compare == 1 ]]. ^ aa size < bb size! ! !MessageBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initializeWidgets self instantiateModels: #( listModel MultiColumnListModel textModel TextModel toolbarModel MethodToolbar ). listModel displayBlock: [ :item | self wrapItem: item ]. textModel aboutToStyle: true. textModel whenBuiltDo: [ :ann | ann widget font: self codeFont ]. refreshingBlockHolder := [ :item | true ] asReactiveVariable. self setListMenu; initializeDropList; setFocus. ! ! !MessageBrowser methodsFor: 'text selection' stamp: 'AlexandreBergel 1/29/2013 16:24'! searchedString: searchedString in: aString "Return the interval that corresponds to the portion of aString " "This method takes care of finding complete match to searchedString. " | string interval firstIndex | searchedString ifNil: [ ^ 0 to: 0 ]. aString isEmptyOrNil ifTrue: [ ^0 to: 0 ]. string := aString asString. interval := 0 to: 0. (searchedString includes: $:) ifTrue: [ | list | list := searchedString subStrings: ':'. list size = 1 ifTrue: [" binary selector " firstIndex := self findFirstOccurrenceOf: searchedString in: string. firstIndex isZero ifFalse: [ interval := firstIndex to: (firstIndex+searchedString size-1) ] ] ifFalse: [ | lastIndex | firstIndex := self findFirstOccurrenceOf: list first, ':' in: string. firstIndex >0 ifTrue: [ lastIndex := string findString: list last,':' startingAt: firstIndex+ (list first size -1). interval := firstIndex to: (lastIndex + list last size) ] ] ] ifFalse: [ " unary selector " firstIndex := self findFirstOccurrenceOf: searchedString in: string. firstIndex > 0 ifTrue: [ interval := firstIndex to: (firstIndex+searchedString size - 1) ] ]. ^ interval! ! !MessageBrowser methodsFor: 'announcements' stamp: 'NicolaiHess 1/19/2014 11:46'! methodModified: anAnnouncement | item oldItem sel index | self isDisplayed ifFalse: [ ^ self ]. refreshingBlockHolder ifNil: [ ^ self ]. item := anAnnouncement newMethod. oldItem := anAnnouncement oldMethod. sel := listModel selectedItem. sel ifNil: [ ^ self ]. (sel notNil and: [(sel methodClass = oldItem methodClass and: [ sel selector = oldItem selector ])]) ifFalse: [ ^ self ]. (refreshingBlockHolder value cull: item cull: anAnnouncement cull: self) ifFalse: [ ^ self ]. index := listModel selectedIndex . UIManager default defer: [ | text list edits | edits := textModel hasUnacceptedEdits. edits ifTrue: [ text := textModel pendingText ]. list := listModel listItems remove: sel ifAbsent: []; add: item asFullRingDefinition; "to ensure it's still as RGMethod" yourself. self messages: list. listModel setSelectedIndex: index. edits ifTrue: [ textModel pendingText: text. textModel hasEditingConflicts: true ]. ]! ! !MessageBrowser methodsFor: 'private' stamp: 'EstebanLorenzano 10/11/2013 16:53'! codeFont ^ StandardFonts codeFont! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/14/2012 10:15'! sortingBlock: aBlock listModel sortingBlock: aBlock! ! !MessageBrowser methodsFor: 'protocolBrowser interface' stamp: 'BenjaminVanRyseghem 6/13/2012 14:42'! openSubProtocolForClass: aClass self messages: (self collectMethodsFrom: aClass til: Object). self title: 'Sub protocol of ', aClass name. self openWithSpec.! ! !MessageBrowser methodsFor: 'messageList interface' stamp: 'BenjaminVanRyseghem 5/14/2012 02:00'! open self openWithSpec! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! topologicSort: aBoolean ^ topologicSortHolder value: aBoolean! ! !MessageBrowser methodsFor: 'announcements-registration' stamp: 'EstebanLorenzano 8/3/2012 14:11'! registerToAnnouncements SystemAnnouncer uniqueInstance weak on: MethodAdded send: #methodAdded: to: self; on: MethodModified send: #methodModified: to: self; on: MethodRecategorized send: #methodRecategorized: to: self; on: MethodRemoved send: #methodRemoved: to: self! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:57'! browseSendersOfMessage self currentMethod ifNotNil: [ :method | model browseSendersOfMessagesFrom: method selector ]! ! !MessageBrowser methodsFor: 'private' stamp: 'LeoGassman 11/7/2013 11:49'! wrapItem: anItem | s | s :=String streamContents: [ :aStream | 3 to: (cachedHierarchy at: anItem) size do: [:i | aStream << ' ']. aStream << anItem methodClass name << ' ('. anItem isFromTrait ifTrue: [ aStream << anItem compiledMethod origin name; space ]. aStream << (anItem category ifNil: ['']) <<')']. ^ {s. anItem selector. '[',anItem package name,']'.}.! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/30/2013 00:01'! browseClassRefs self currentMethod ifNotNil: [ :method | model browseClassRefsOf: method methodClass ]! ! !MessageBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! textConverter: aTextConverter textConverterHolder value: (aTextConverter method: self textConverter method). textModel aboutToStyle: self textConverter shouldShout . textModel text: self textConverter getText.! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:58'! browseMessages self currentMethod ifNotNil: [ :method | model browseMessagesFrom: method selector ]! ! !MessageBrowser methodsFor: 'testing' stamp: ''! cacheHierarchyForClasses: aCollection cachedHierarchy := self buildHierarchyForMessages: aCollection.! ! !MessageBrowser methodsFor: 'protocol' stamp: ''! selectedMessage ^ listModel selectedItem! ! !MessageBrowser methodsFor: 'protocolBrowser interface' stamp: 'BenjaminVanRyseghem 6/13/2012 14:42'! openFullProtocolForClass: aClass self messages: (self collectMethodsFrom: aClass til: nil). self title: 'Full protocol of ', aClass name. self openWithSpec.! ! !MessageBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 9/9/2013 10:02'! initializeDropList toolbarModel addItemLabeled: 'Source' do: [ self textConverter: SourceMethodConverter new ]; addItemLabeled: 'Byte Code' do: [ self textConverter: ByteCodeMethodConverter new ]; addItemLabeled: 'Time stamp' do: [ self textConverter: TimeStampMethodConverter new ]! ! !MessageBrowser methodsFor: 'protocolBrowser interface' stamp: 'BenjaminVanRyseghem 6/13/2012 10:46'! collectMethodsFrom: aClass til: superClass | methods class | methods := OrderedCollection new. class := aClass. methods addAll: class methods. [ class superclass = superClass ] whileFalse: [ class := class superclass. methods addAll: class methods ]. ^ methods ! ! !MessageBrowser methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! title ^ titleHolder value , ' [' , listModel listSize printString , ']'! ! !MessageBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 12/29/2012 15:33'! initializePresenter listModel whenSelectedItemChanged: [:item | toolbarModel method: item. textModel behavior: (item ifNil: [ nil ] ifNotNil: [ item methodClass ]). textModel doItReceiver: textModel behavior. textModel text: (self textConverter method: item; getText)]. listModel whenListChanged: [ self updateTitle ]. titleHolder whenChangedDo: [ self updateTitle ]. textModel acceptBlock: [ :text :notifyer | self accept: text notifying: notifyer ].! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/14/2012 10:55'! messages ^ listModel listItems! ! !MessageBrowser methodsFor: 'private-focus' stamp: 'BenjaminVanRyseghem 2/8/2013 14:17'! ensureKeyBindingsFor: aWidget self registerListShortcutsFor: listModel! ! !MessageBrowser methodsFor: 'announcements' stamp: ''! methodRecategorized: aMethod! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/14/2012 11:34'! selectedItem ^ listModel selectedItem! ! !MessageBrowser methodsFor: 'private' stamp: ''! initialExtent ^ (500 min: (World extent x)) @ (550 min: (World extent y))! ! !MessageBrowser methodsFor: 'icons' stamp: 'EstebanLorenzano 5/14/2013 14:51'! taskbarIcon ^ Smalltalk ui icons referencesIcon! ! !MessageBrowser methodsFor: 'accessing' stamp: 'CamilloBruni 1/29/2013 23:50'! currentMethod ^ self selectedMessage! ! !MessageBrowser methodsFor: 'protocol' stamp: ''! selectedMessage: aMessage listModel setSelectedItem: aMessage.! ! !MessageBrowser methodsFor: 'protocol' stamp: 'CamilloBruni 8/24/2012 16:47'! setRefreshingBlockForSendersOf: aSelector | specialFlag specialByte | specialFlag := Smalltalk hasSpecialSelector: aSelector ifTrueSetByte: [ :b | specialByte := b ]. self refreshingBlock: [:method | (method refersToLiteral: aSelector) or: [ specialFlag and: [ method scanFor: specialByte ]]]! ! !MessageBrowser methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 6/14/2012 10:12'! buildHierarchyForMessages: messages | result classes | result := IdentityDictionary new. self topologicSort ifFalse: [ messages do: [:m | result at: m put: {} ]. ^ result ]. classes := (messages collect: #methodClass) asSet. messages do: [:message || level class | class := message methodClass. level := OrderedCollection new. class allSuperclassesDo: [:superClass | (classes includes: superClass) ifTrue: [ level addFirst: superClass ]]. level addLast: class. level addLast: message selector. result at: message put: level ]. ^ result! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/13/2012 10:48'! displayBlock: aBlock ^ listModel displayBlock: aBlock! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:52'! browseMethod self currentMethod ifNotNil: [ :method | method browse ]! ! !MessageBrowser methodsFor: 'private' stamp: 'EstebanLorenzano 6/26/2013 18:05'! accept: text notifying: notifyer listModel selectedItem ifNotNil: [:message | message methodClass compile: text classified: message protocol notifying: notifyer ]! ! !MessageBrowser methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/31/2013 12:12'! model ^model! ! !MessageBrowser methodsFor: 'protocol' stamp: ''! setRefreshingBlockForImplementorsOf: aSelector self refreshingBlock: [:message | message selector = aSelector ].! ! !MessageBrowser methodsFor: 'accessing' stamp: ''! toolbarModel ^ toolbarModel! ! !MessageBrowser methodsFor: 'initialization' stamp: ''! setFocus self focusOrder add: listModel; add: toolbarModel; add: textModel! ! !MessageBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 6/18/2012 06:09'! defaultSpec | delta | delta := 13. ^ SpecLayout composed add: #listModel origin: 0@0 corner: 1@0.5 offsetOrigin: 0@0 offsetCorner: 0@(delta negated); add: #toolbarModel origin: 0@0.5 corner: 1@0.5 offsetOrigin: 0@(delta negated) offsetCorner: 0@delta; add: #textModel origin: 0@0.5 corner: 1@1 offsetOrigin: 0@delta offsetCorner: 0@0; yourself! ! !MessageBrowser class methodsFor: 'instance creation' stamp: ''! browseImplementors: aCollection of: aSymbol named: aName ^ self new setRefreshingBlockForImplementorsOf: aSymbol; messages: aCollection; title: aName; yourself! ! !MessageBrowser class methodsFor: 'messageList interface' stamp: 'BenjaminVanRyseghem 5/14/2012 02:00'! on: aMessageList named: aString ^ self new messages: aMessageList methodReferenceList; title: aString; yourself! ! !MessageBrowser class methodsFor: 'instance creation' stamp: ''! browseMessages: aCollection refreshingBlock: aBlock named: anObject ^ self new refreshingBlock: aBlock; messages: aCollection; yourself! ! !MessageBrowser class methodsFor: 'instance creation' stamp: ''! browseSenders: aCollection of: aSymbol named: aName ^ self new setRefreshingBlockForSendersOf: aSymbol; messages: aCollection; title: aName; autoSelect: aSymbol; yourself! ! !MessageBrowser class methodsFor: 'protocolBrowser interface' stamp: 'BenjaminVanRyseghem 6/13/2012 10:51'! openFullProtocolForClass: aClass "Open a browser on the methods understood by aClass including the methods from Object and ProtoObject" self new openFullProtocolForClass: aClass! ! !MessageBrowser class methodsFor: 'tool registration' stamp: 'LeoGassman 11/7/2013 15:23'! openMessageList: messageList name: aString autoSelect: aSelector refreshingBlockSelector:aRefreshingBlockSelector " Tool registry compitibility " | title | aString last = $] ifTrue: [ title := aString substrings allButLast joinUsing: ' ' ] ifFalse: [ title := aString ]. ^ (self on: messageList named: title autoSelect: aSelector refreshingBlockSelector:aRefreshingBlockSelector) openWithSpec! ! !MessageBrowser class methodsFor: 'specs' stamp: ''! title ^ 'Message Browser'! ! !MessageBrowser class methodsFor: 'tool registration' stamp: 'EstebanLorenzano 5/11/2012 11:42'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #messageList! ! !MessageBrowser class methodsFor: 'protocolBrowser interface' stamp: 'BenjaminVanRyseghem 6/13/2012 10:38'! openSubProtocolForClass: aClass "Open a browser on the methods understood by aClass excluding the methods from Object and ProtoObject" self new openSubProtocolForClass: aClass! ! !MessageBrowser class methodsFor: 'instance creation' stamp: ''! on: aList named: aString autoSelect: aSelector ^ self new messages: aList; title: aString; autoSelect: aSelector; yourself! ! !MessageBrowser class methodsFor: 'tool registration' stamp: 'LeoGassman 11/7/2013 14:50'! openMessageList: messageList name: aString autoSelect: aSelector self openMessageList: messageList name: aString autoSelect: aSelector refreshingBlockSelector: nil.! ! !MessageBrowser class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:32'! messageBrowserListMenu: aBuilder | target model message | target := aBuilder model. model := target model. target selectedMessage ifNil: [ ^self ]. message := target selectedMessage compiledMethod. (aBuilder item: #'Browse full...') keyText: 'b'; action: [ Smalltalk tools browser fullOnClass: message methodClass selector: message selector ]. (aBuilder item: #'Inspect method...') keyText: 'i'; action: [ message inspect ]; withSeparatorAfter. (aBuilder item: #'Remove method...') keyText: 'x'; action: [ model removeMethod: message inClass: message methodClass ]. (aBuilder item: #'Toggle Breakpoint') action: [ model toggleBreakOnEntryIn: message ]; withSeparatorAfter. (aBuilder item: #'Senders of...') keyText: 'n'; action: [ model browseSendersOfMessagesFrom: message selector ]. (aBuilder item: #'Implementors of...') keyText: 'm'; action: [ model browseMessagesFrom: message selector ]. (aBuilder item: #'Users of...') keyText: 'N'; action: [ model browseClassRefsOf: message methodClass ]. (aBuilder item: #'Versions...') keyText: 'v'; action: [ model browseVersionsFrom: message ]. ! ! !MessageBrowser class methodsFor: 'specs' stamp: 'CamilloBruni 3/1/2014 03:24'! testSpec ^ SpecLayout composed newColumn: [:col | col add: #listModel; addSplitter; add: #toolbarModel height: self buttonHeight; add: #textModel ] ! ! !MessageBrowser class methodsFor: 'instance creation' stamp: 'LeoGassman 11/7/2013 18:13'! on: aList named: aString autoSelect: aSelector refreshingBlockSelector:aRefreshingBlockSelector |out| out := self new messages: aList; title: aString; autoSelect: aSelector; yourself. aRefreshingBlockSelector ifNotNil:[(out perform:aRefreshingBlockSelector with:aSelector)]. ^out! ! !MessageBrowserTest commentStamp: ''! A MessageBrowserTest is a test class for testing the behavior of MessageBrowser! !MessageBrowserTest methodsFor: 'tests substrings' stamp: 'AlexandreBergel 1/29/2013 15:51'! testFindingTextWithoutJunkcharacter | intervalResult | intervalResult := MessageBrowser new searchedString: #LayoutFrame in: 'foo asLayoutFrame LayoutFrame '. self assert: (intervalResult = (20 to: 30))! ! !MessageBrowserTest methodsFor: 'tests' stamp: 'AlexandreBergel 1/29/2013 15:28'! testFindingText | intervalResult | intervalResult := MessageBrowser new searchedString: #LayoutFrame in: 'foo LayoutFrame asLayoutFrame '. self assert: (intervalResult = (5 to: 15))! ! !MessageBrowserTest methodsFor: 'tests' stamp: 'AlexandreBergel 1/29/2013 15:42'! testFindingTextWithColumn | intervalResult | intervalResult := MessageBrowser new searchedString: #foo:bar: in: 'zork self foo: 3 bar: 5. self foo: 3 bar: 6 '. self assert: (intervalResult = (11 to: 21))! ! !MessageBrowserTest methodsFor: 'tests' stamp: 'AlexandreBergel 1/29/2013 15:41'! testFindingTextWithOneColumn | intervalResult | intervalResult := MessageBrowser new searchedString: #foo: in: 'zork self foo: 3. self foo: 6 '. self assert: (intervalResult = (11 to: 14))! ! !MessageBrowserTest methodsFor: 'tests' stamp: 'AlexandreBergel 1/29/2013 15:32'! testFindingNotExistingText | intervalResult | intervalResult := MessageBrowser new searchedString: #foo in: 'zork hello world '. self assert: (intervalResult = (0 to: 0))! ! !MessageCatcher commentStamp: ''! Any message sent to me is returned as a Message object. "Message catcher" creates an instance of me. ! !MessageCatcher methodsFor: 'private' stamp: 'ajh 7/7/2004 18:22'! privAccumulator: collection accumulator := collection! ! !MessageCatcher methodsFor: 'private' stamp: 'ajh 7/7/2004 18:22'! privAccumulator ^ accumulator! ! !MessageCatcher methodsFor: 'reflective operations' stamp: 'ajh 7/7/2004 18:22'! doesNotUnderstand: aMessage accumulator ifNotNil: [accumulator add: aMessage]. ^ aMessage! ! !MessageDialogWindow commentStamp: 'gvc 5/18/2007 13:27'! Dialog window displaying a message with a single OK button. Escape/return will close. Icon is a themed information icon.! !MessageDialogWindow methodsFor: 'private' stamp: 'SeanDeNigris 7/24/2012 21:12'! lineLengths ^ self textLines collect: [ :line | self textFont widthOfString: line ].! ! !MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/29/2007 13:28'! iconMorph: anObject "Set the value of iconMorph" iconMorph := anObject! ! !MessageDialogWindow methodsFor: 'theme' stamp: 'AlainPlantec 10/25/2010 11:15'! themeChanged "Update the icon." super themeChanged. self iconMorph image: self icon ! ! !MessageDialogWindow methodsFor: 'private' stamp: 'SeanDeNigris 7/24/2012 21:09'! textLines ^ self textMorph text asString lines.! ! !MessageDialogWindow methodsFor: 'open/close' stamp: 'CamilloBruni 10/7/2012 22:26'! initialExtent "Answer the initial extent for the receiver. Adjust the text if the text would be wider than 1/4 the display width." |ext| ext := super initialExtent. self textMorph width > (Display width - 50) ifTrue: [ self textMorph wrapFlag: true; hResizing: #rigid; extent: (Display width - 50) @ 0. ext := super initialExtent]. ^ext! ! !MessageDialogWindow methodsFor: 'actions' stamp: 'gvc 8/29/2007 13:29'! newContentMorph "Answer a new content morph." self iconMorph: self newIconMorph. self textMorph: self newTextMorph. ^self newGroupboxFor: (self newRow: {self iconMorph. self textMorph})! ! !MessageDialogWindow methodsFor: 'theme' stamp: 'gvc 9/12/2007 17:47'! playOpenSound "Play the themed sound for opening. Do nothing at present, done by the UIManager."! ! !MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/27/2006 10:26'! textMorph: anObject "Set the value of textMorph" textMorph := anObject! ! !MessageDialogWindow methodsFor: 'private' stamp: 'StephaneDucasse 5/23/2013 18:38'! newIconMorph "Answer an icon for the receiver." ^ImageMorph new form: self icon! ! !MessageDialogWindow methodsFor: 'accessing' stamp: 'SeanDeNigris 7/24/2012 21:12'! minimumWidth ^ (self lineLengths max + 100) min: Display width.! ! !MessageDialogWindow methodsFor: 'accessing' stamp: 'GaryChambers 1/20/2012 16:37'! text: aStringOrText "Set the text." |t| t := aStringOrText isString ifTrue: [aStringOrText asText addAttribute: (TextFontReference toFont: self textFont); yourself] ifFalse: [aStringOrText]. t addAttribute: TextAlignment centered; addAttribute: (TextColor color: self textMorph textColor). self textMorph newContents: t ! ! !MessageDialogWindow methodsFor: 'private' stamp: 'GaryChambers 12/6/2011 10:09'! newTextMorph "Answer a text morph." ^self newText: ' '! ! !MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/17/2006 14:19'! textFont "Answer the text font." ^textFont! ! !MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/29/2007 13:29'! iconMorph "Answer the value of iconMorph" ^ iconMorph! ! !MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/27/2006 10:26'! textMorph "Answer the value of textMorph" ^ textMorph! ! !MessageDialogWindow methodsFor: 'actions' stamp: 'gvc 1/12/2007 15:15'! newButtons "Answer new buttons as appropriate." ^{self newOKButton isDefault: true}! ! !MessageDialogWindow methodsFor: 'accessing' stamp: 'GaryChambers 12/6/2011 10:08'! textFont: aFont "Set the text font." textFont := aFont. self textMorph ifNotNil: [:m | m font: aFont]! ! !MessageDialogWindow methodsFor: 'visual properties' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon "Answer an icon for the receiver." ^ Smalltalk ui icons infoIcon! ! !MessageDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallInfoIcon! ! !MessageList commentStamp: 'BenjaminVanRyseghem 11/29/2010 11:31'! MessageList is a simple object that holds a set of ordered method definitions. See MessageList example for an example. MessageList example Instance Variables: methodReferenceList ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:26'! versionsHistoryList ^ versionsHistoryList! ! !MessageList methodsFor: 'method version' stamp: 'VeronicaUquillas 9/3/2011 20:26'! priorVersionOfAMethod: aMethodReference | tempList | tempList := self methodReferenceList select:[:each | (each className = aMethodReference className) & (each name = aMethodReference name)]. ^ tempList detect: [:each | (self versionOfAMethod: each) = ((self versionOfAMethod: aMethodReference) -1)] ifNone: [aMethodReference].! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:26'! versionsHistoryList: anObject versionsHistoryList := anObject! ! !MessageList methodsFor: 'private' stamp: ''! byClassSelector ^ #groupedByClass! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! methodReferenceList ^ methodReferenceList! ! !MessageList methodsFor: 'building dictionary' stamp: 'VeronicaUquillas 8/31/2011 23:45'! buildByDate: aBlock "Return an association where key is a Dictionary and value is the list sorted" | result tempList | result := Dictionary new. tempList := self methodReferenceList copy sort: aBlock. tempList do: [:each | | key1 key2 value | key1 := each timeStamp asDate. key2 := each realClass. value := each. (result includesKey: key1) ifFalse: [result at: key1 put: Dictionary new]. ((result at: key1) includesKey: key2) ifFalse: [(result at: key1) at: key2 put: OrderedCollection new]. ((result at: key1) at: key2) add: value]. ^(Association key: result value: tempList)! ! !MessageList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/10/2011 14:38'! findIndexOfVersionOf: aMethodReference | list timeStamp| timeStamp := aMethodReference timeStamp. list := self versionsHistoryList. list size = 1 ifTrue: [^1]. 1 to: list size - 1 do: [:i || current next | current := list at: i. next := list at: (i+1). ((current value <= timeStamp asDateAndTime) & (next value asDateAndTime> timeStamp asDateAndTime)) ifTrue: [^i]]. ^list size.! ! !MessageList methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/29/2010 11:27'! initialize "Initialization" super initialize. useAsASet := false. methodReferenceList := OrderedCollection new. self clearAll. environment := self environment. versionsHistoryList := SortedCollection new sortBlock: [:a :b | a value < b value]. self addFirstVersion. sortedMethodReferencesList := OrderedCollection new.! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! sortedMethodReferencesList ^sortedMethodReferencesList! ! !MessageList methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 1/11/2011 14:10'! groupedByDateAscending "update the instance variable" self groupedByDateAscendingSilently. self updateView.! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! dictionary: aDictionary dictionary := aDictionary! ! !MessageList methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 11/29/2010 11:28'! groupedByDateAscendingSilently "update the instance variable" | association | association := self buildByDate: [:m1 :m2 | m1 timeStamp <= m2 timeStamp]. self dictionary: association key. self sortedMethodReferencesList: association value. self sortingSelector: self byDateAscendingSelector.! ! !MessageList methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 11/29/2010 11:28'! groupedByClassSilently "update the instance variable" | association | association := self buildByClass. self dictionary: association key. self sortedMethodReferencesList: association value. self sortingSelector: self byClassSelector.! ! !MessageList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/29/2010 11:30'! checkCurrentHighestUpdate: aMethodReference | highestUpdate | highestUpdate := SystemVersion current highestUpdate. (self versionsHistoryList isEmpty or: [highestUpdate > self versionsHistoryList last key highestUpdate]) ifTrue: [ self addVersion: (Association key: SystemVersion current value: aMethodReference timeStamp)]! ! !MessageList methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 5/9/2011 14:47'! addMethodReference: aMethodReference at: index self addMethodReferenceSilently: aMethodReference at: index. self updateView.! ! !MessageList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:29'! isSortedByDateAscending ^self sortingSelector = self byDateAscendingSelector ! ! !MessageList methodsFor: 'private' stamp: 'StephaneDucasse 5/15/2011 18:01'! isEmpty ^ self methodReferenceList isEmpty! ! !MessageList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:29'! isSortedByDateDescending ^self sortingSelector = self byDateDescendingSelector ! ! !MessageList methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 12/16/2010 15:29'! addMethodReference: aMethodReference self addMethodReferenceSilently: aMethodReference. self updateView.! ! !MessageList methodsFor: 'actions' stamp: 'SvenVanCaekenberghe 12/22/2013 16:33'! addFirstVersion | systemVersion date association | systemVersion := SystemVersion new date: '1 January 1901'. date := DateAndTime new. association := Association key: systemVersion value: date. self versionsHistoryList add: association! ! !MessageList methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 1/11/2011 14:09'! groupedByPackage "update the instance variable" self groupedByPackageSilently. self updateView! ! !MessageList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/20/2011 15:51'! level2Selectors ^#( #groupedByClass #groupedByVersion)! ! !MessageList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/29/2010 11:30'! findVersionOf: aMethodReference | index | index := self findIndexOfVersionOf: aMethodReference. ^(self versionsHistoryList at: index) key! ! !MessageList methodsFor: 'actions' stamp: 'StephaneDucasse 5/15/2011 18:21'! revertLastMethodSubmission "If the most recent method submission was a method change, revert that change, and if it was a submission of a brand-new method, remove that method." "self new revertLastMethodSubmission" | changeRecords lastSubmission theClass theSelector | self isEmpty ifTrue: [^ Beeper beep]. lastSubmission := self lastEntry. theClass := lastSubmission actualClass ifNil: [^ Beeper beep]. theSelector := lastSubmission selector. changeRecords := theClass changeRecordsAt: theSelector. changeRecords isEmptyOrNil ifTrue: [^ Beeper beep]. changeRecords size = 1 ifTrue: ["method has no prior version, so reverting in this case means removing" theClass removeSelector: theSelector] ifFalse: [changeRecords second fileIn].! ! !MessageList methodsFor: 'private' stamp: ''! byDateAscendingSelector ^ #groupedByDateAscending! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:26'! dictionary dictionary ifNil: [self groupedByClass]. ^dictionary! ! !MessageList methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 1/11/2011 14:09'! groupedByDateDescending "update the instance variable" self groupedByDateDescendingSilently. self updateView.! ! !MessageList methodsFor: 'method version' stamp: 'VeronicaUquillas 9/3/2011 20:26'! versionOfAMethod: aMethodReference | tempList | tempList := self methodReferenceList select: [:each | (each className = aMethodReference className) & (each name = aMethodReference name)]. tempList := tempList sort: [:m1 :m2 | m1 timeStamp < m2 timeStamp]. ^ tempList indexOf: aMethodReference ifAbsent: [0]! ! !MessageList methodsFor: 'building dictionary' stamp: 'VeronicaUquillas 9/1/2011 16:05'! buildByPackage "Return an association where key is a Dictionary and value is the list sorted" | result tempList | result := Dictionary new. tempList := self methodReferenceList copy sort: [:m1 :m2 | m2 timeStamp <= m1 timeStamp]. tempList do: [:each | | class key1 key2 value | class := self environment classNamed: each theNonMetaClassName. key1 := class category. key2 := each actualClass. value := each. (result includesKey: key1) ifFalse: [result at: key1 put: Dictionary new]. ((result at: key1) includesKey: key2) ifFalse: [(result at: key1) at: key2 put: OrderedCollection new]. ((result at: key1)at: key2) add: value]. ^(Association key: result value: tempList)! ! !MessageList methodsFor: '*RecentSubmissions-UI' stamp: 'BenjaminVanRyseghem 11/1/2011 07:37'! open "opens the system window for recent messages" | browser | browser := MessageListBrowser on: self. browser open.! ! !MessageList methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 1/11/2011 14:10'! groupedByVersion "update the instance variable" self groupedByVersionSilently. self updateView! ! !MessageList methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 11/29/2010 11:29'! groupedByDateDescendingSilently "update the instance variable" | association | association := self buildByDate: [:m1 :m2 | m2 timeStamp <= m1 timeStamp]. self dictionary: association key. self sortedMethodReferencesList: association value. self sortingSelector: self byDateDescendingSelector.! ! !MessageList methodsFor: '*RecentSubmissions-UI' stamp: ''! icon ^ self class icon! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! sortedMethodReferencesList: anObject sortedMethodReferencesList := anObject! ! !MessageList methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 11/29/2010 11:28'! reSort ^ self perform: (self sortingSelector,'Silently') asSymbol! ! !MessageList methodsFor: 'accessing' stamp: ''! lastEntry ^lastEntry! ! !MessageList methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 11/29/2010 11:28'! addVersion: anAssociation self versionsHistoryList add: anAssociation. self updateView! ! !MessageList methodsFor: 'private' stamp: ''! byDateDescendingSelector ^ #groupedByDateDescending! ! !MessageList methodsFor: 'accessing' stamp: ''! level (self level2Selectors includes: (self sortingSelector)) ifTrue: [^2]. (self level3Selectors includes: (self sortingSelector)) ifTrue: [^3]. self error: 'The selector isn''t classified'! ! !MessageList methodsFor: 'private' stamp: ''! byPackageSelector ^ #groupedByPackage! ! !MessageList methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/29/2010 11:29'! environment ^Smalltalk globals! ! !MessageList methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 11/29/2010 11:29'! groupedByVersionSilently "update the instance variable" | association | association := self buildByVersion. self dictionary: association key. self sortedMethodReferencesList: association value. self sortingSelector: self byVersionSelector.! ! !MessageList methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 1/11/2011 14:32'! groupedByClass "update the instance variable" self groupedByClassSilently. self updateView! ! !MessageList methodsFor: '*RecentSubmissions-UI' stamp: 'BenjaminVanRyseghem 1/11/2011 14:06'! title ^'Message List'! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:26'! useAsASet ^ useAsASet! ! !MessageList methodsFor: 'actions' stamp: 'VeronicaUquillas 8/26/2011 10:55'! addMethodReferenceSilently: aMethodReference at: index self useAsASet ifTrue: [ self methodReferenceList removeAllSuchThat: [:each | each fullName = aMethodReference fullName]]. self checkCurrentHighestUpdate: aMethodReference. self methodReferenceList at: index put: aMethodReference. lastEntry := aMethodReference.! ! !MessageList methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 11/29/2010 11:29'! groupedByPackageSilently "update the instance variable" | association | association := self buildByPackage. self dictionary: association key. self sortedMethodReferencesList: association value. self sortingSelector: self byPackageSelector.! ! !MessageList methodsFor: 'actions' stamp: ''! removeMethodReference: aMethodReference self methodReferenceList remove: aMethodReference. self updateView.! ! !MessageList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/20/2011 15:51'! level3Selectors ^#( #groupedByDateAscending #groupedByDateDescending #groupedByPackage).! ! !MessageList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/3/2011 11:33'! size ^ self methodReferenceList size! ! !MessageList methodsFor: '*RecentSubmissions-UI' stamp: 'BenjaminVanRyseghem 11/29/2010 10:56'! updateView self changed: #sortingSelector. self changed: #sortedMethodReferencesList. self changed: #dictionary. self triggerEvent: #changed.! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:26'! useAsASet: anObject useAsASet := anObject. anObject ifTrue: [ self methodReferenceList: ((self methodReferenceList reversed asSet) asOrderedCollection)]. self updateView! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! sortingSelector sortingSelector ifNil: [^ #groupedByClass]. ^sortingSelector ! ! !MessageList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:29'! isSortedByClass ^ self sortingSelector = self byClassSelector ! ! !MessageList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:30'! isSortedByVersion ^self sortingSelector = self byVersionSelector ! ! !MessageList methodsFor: 'actions' stamp: 'VeronicaUquillas 8/26/2011 10:55'! addMethodReferenceSilently: aMethodReference self useAsASet ifTrue: [ self methodReferenceList removeAllSuchThat: [:each | each fullName = aMethodReference fullName]]. self checkCurrentHighestUpdate: aMethodReference. self methodReferenceList add: aMethodReference. lastEntry := aMethodReference.! ! !MessageList methodsFor: 'private' stamp: ''! byVersionSelector ^ #groupedByVersion! ! !MessageList methodsFor: 'private' stamp: 'StephaneDucasse 5/15/2011 18:04'! zork ^ 34! ! !MessageList methodsFor: 'building dictionary' stamp: 'VeronicaUquillas 9/1/2011 14:54'! buildByClass "Return an association where key is a Dictionary and value is the list sorted" | result tempList | result := Dictionary new. tempList := self methodReferenceList copy sort: [:m1 :m2 | m2 timeStamp <= m1 timeStamp]. tempList do: [:each | | key value | key := each realClass. value := each. (result includesKey: key) ifFalse: [result at: key put: OrderedCollection new]. (result at: key) add: value]. ^(Association key: result value: tempList)! ! !MessageList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:30'! isSortedByPackage ^self sortingSelector = self byPackageSelector ! ! !MessageList methodsFor: 'actions' stamp: ''! clearAll self methodReferenceList: OrderedCollection new. self updateView.! ! !MessageList methodsFor: 'building dictionary' stamp: 'BenjaminVanRyseghem 11/29/2010 10:11'! buildByVersion "Return an association where key is a Dictionary and value is the list sorted" | result tempList | result := Dictionary new. tempList := self methodReferenceList copy sort: [:m1 :m2 | m2 timeStamp <= m1 timeStamp]. tempList do: [:each | | key value systemVersion | systemVersion := self findVersionOf: each. key := systemVersion version, ' - ',systemVersion highestUpdate asString.. value := each. (result includesKey: key) ifFalse: [result at: key put: OrderedCollection new]. (result at: key) add: value]. ^(Association key: result value: tempList)! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! methodReferenceList: anObject methodReferenceList := anObject! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! sortingSelector: anObject sortingSelector := anObject.! ! !MessageList class methodsFor: 'instance creation' stamp: ''! with: aCollection. ^self new methodReferenceList: aCollection.! ! !MessageList class methodsFor: 'example' stamp: 'BenjaminVanRyseghem 9/17/2011 16:54'! example1 "This is the new version of the method" Transcript show: 'This is the new version of the method' ;cr.! ! !MessageList class methodsFor: '*Polymorph-Widgets' stamp: ''! taskbarIcon ^ self icon! ! !MessageList class methodsFor: 'example' stamp: 'BenjaminVanRyseghem 11/1/2011 07:43'! example "self example" | oldSource newSource t1 t2 t3 ml mlb | oldSource := 'example1 "This is the old version of the method" Transcript show: ''This is the old version of the method'' ;cr.'. newSource := 'example1 "This is the new version of the method" Transcript show: ''This is the new version of the method'' ;cr.'. t1 := RGMethodDefinition realClass: MessageList class selector: #example. MessageList class compile: oldSource classified: 'example'. t2 := RGMethodDefinition realClass: MessageList class selector: #example1. "here you can modify MessageList >> initialize to see the difference" MessageList class compile: newSource classified: 'example'. t3 := RGMethodDefinition realClass: MessageList class selector: #example1. ml := MessageList new addMethodReference: t1; addMethodReference: t2; addMethodReference: t3. mlb := MessageListBrowser byDateAscendingOn: ml. mlb open! ! !MessageList class methodsFor: 'toBeRemovedWithStringHolder' stamp: 'StephaneDucasse 9/17/2011 15:34'! isPseudoSelector: aSelector "Answer whether the given selector is a special marker" self flag: #toRemoveWhenStringHolderIsGone. ^ #(Comment Definition Hierarchy) includes: aSelector! ! !MessageList class methodsFor: 'setting' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon ^ Smalltalk ui icons smallInfoIcon! ! !MessageListAbstractNode commentStamp: ''! A MessageListAbstractNode is an abstract node model. Instance Variables ! !MessageListAbstractNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! includes: aNode ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:09'! isMethod ^ self item isMethod.! ! !MessageListAbstractNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! inspectableContents ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'comparing' stamp: 'AlainPlantec 2/13/2011 17:46'! = anotherNode anotherNode species = self species ifTrue: [^ self item = anotherNode item] ifFalse: [^ false].! ! !MessageListAbstractNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! originalIndex ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'action' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! removeMe ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'action' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! printList: aStream ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:09'! isInspectable ^self subclassResponsibility ! ! !MessageListAbstractNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! getClass ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'overrided' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! doubleClick ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 20:29'! environment self model ifNotNil: [:m| ^m environment]. self error: 'The model should probably not be nil'! ! !MessageListBrowser commentStamp: 'BenjaminVanRyseghem 8/31/2010 01:43'! MessageListBrowser is the UI for instances of MessageList Instance Variables: messageList dictionary originalList selectedMorph treeMorph textArea dropList preference sortingSelector ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:46'! promptForRemove: aNode "Ask if it is OK to remove the node" | list | list := WriteStream on: ''. list nextPutAll: 'Are you sure you want to remove : '. aNode printList: list. list nextPutAll: ' ?'. self format: list contents. ^(self confirm: list contents translated) ! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 3/20/2012 14:20'! byteCodeLabel ^ 'Byte Code'! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 3/20/2012 14:35'! getPreferencesList preferenceList ifNotNil: [ ^ preferenceList ]. ^ preferenceList := { self sourceItem. self byteCodeItem. self diffItem. self versionItem. self infoItem. }! ! !MessageListBrowser methodsFor: 'menus' stamp: 'EstebanLorenzano 1/31/2013 19:24'! msgPaneMenu: aMenu shifted: shifted | donorMenu | donorMenu := shifted ifTrue: [SmalltalkEditor shiftedYellowButtonMenu] ifFalse: [SmalltalkEditor yellowButtonMenu]. ^ aMenu addAllFrom: donorMenu! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 3/20/2012 14:55'! getDisplayList sortingList ifNotNil: [ ^ sortingList ]. ^ sortingList := { self byClassItem. self byVersionItem. self byDateAscendingItem. self byDateDescendingItem. self byPackageItem. } ! ! !MessageListBrowser methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 11/29/2010 11:17'! originalIndex: aMethodeReference "must respect the original order because the dictionary is automaticaly sorted" | tempList | tempList := self originalList. 1 to: (tempList size) do:[:i | (tempList at: i) == aMethodeReference ifTrue: [^i]]. self error: 'Index not found'. ^0! ! !MessageListBrowser methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 11/29/2010 11:14'! buildButtonRevert ^(PluggableButtonMorph on: self getState: #revertButtonState action: #revertButtonAction label: #revertButtonLabel) hResizing: #spaceFill! ! !MessageListBrowser methodsFor: 'menus' stamp: 'AlainPlantec 2/13/2011 15:30'! browseSelectedMorph self selectedNode ifNotNil: [ :node | node doubleClick].! ! !MessageListBrowser methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 11/29/2010 11:13'! buildButtonRemove ^(PluggableButtonMorph on: self getState: #removeButtonState action: #removeButtonAction label: #removeButtonLabel) hResizing: #spaceFill! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:11'! originalList ^ self model sortedMethodReferencesList! ! !MessageListBrowser methodsFor: 'droplist-items' stamp: ''! byteCodeItem ^ DropListItem named: self byteCodeLabel do: [ wrapper := ByteCodeMethodConverter method: wrapper method ]! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 11/29/2010 11:12'! byPackageLabel ^'By Package'! ! !MessageListBrowser methodsFor: 'text' stamp: 'BenjaminVanRyseghem 3/16/2012 02:50'! compileMethod: aString | method class | self preference = self sourceLabel ifFalse: [ textArea flash. ^ self yourself ]. self textArea hasUnacceptedEdits: false. method := self getMethod: self selectedNode ifAbsent: ["use the information from the tree" class := self selectedNode getClass. nil]. method ifNotNil: [:m | class := m methodClass]. class compile: aString. self changed: #textToDisplay.! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 11/29/2010 11:12'! byDateDescendingLabel ^'By Date Descending'! ! !MessageListBrowser methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 3/20/2012 14:26'! buildPreferenceDropList: aWindow ^ DropListMorph new useSelectionIndex: false; wrapSelector: #wrapPreference:; on: self list: #getPreferencesList selected: #preference changeSelected: #preference:; hResizing: #spaceFill; vResizing: #spaceFill; hResizing: #rigid; width: 125; yourself! ! !MessageListBrowser methodsFor: 'text' stamp: 'BenjaminVanRyseghem 3/16/2012 02:24'! displayInformationFrom: aMessageListInspectableNode ^ wrapper getTextFor: aMessageListInspectableNode item! ! !MessageListBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/20/2012 14:56'! initialize super initialize. wrapper := SourceMethodConverter new. self preference: self getPreferencesList first. self sortingSelector: self getDisplayList first.! ! !MessageListBrowser methodsFor: 'droplist-items' stamp: ''! byDateAscendingItem ^ DropListItem named: self byDateAscendingLabel do: [ self model ifNotNil: [:m | m groupedByDateAscending ]]! ! !MessageListBrowser methodsFor: 'droplist-items' stamp: ''! byDateDescendingItem ^ DropListItem named: self byDateDescendingLabel do: [ self model ifNotNil: [:m | m groupedByDateDescending ]]! ! !MessageListBrowser methodsFor: 'droplist' stamp: ''! wrapPreference: anItem ^ anItem label! ! !MessageListBrowser methodsFor: '*necompletion-extensions' stamp: 'SeanDeNigris 6/24/2012 09:34'! selectedClassOrMetaClass ^ self selectedItem methodClass.! ! !MessageListBrowser methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 11/29/2010 11:16'! doubleClick self selectedNode ifNotNil: [:n | n doubleClick]! ! !MessageListBrowser methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 11/29/2010 11:13'! buildButtonBrowse ^(PluggableButtonMorph on: self getState: #browseButtonState action: #browseButtonAction label: #browseButtonLabel) hResizing: #spaceFill! ! !MessageListBrowser methodsFor: '*Shout-Styling' stamp: 'BenjaminVanRyseghem 3/16/2012 02:21'! shoutAboutToStyle: aPluggableShoutMorphOrView | cls | self selectedNode ifNil: [^false]. cls := self selectedNode isInspectable ifTrue: [self selectedNode getClass]. aPluggableShoutMorphOrView classOrMetaClass: cls. ^ wrapper shouldShout! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 11/29/2010 11:13'! sortingSelectorHelpText ^'Set the way to sort items' ! ! !MessageListBrowser methodsFor: 'droplist-items' stamp: ''! byVersionItem ^ DropListItem named: self byVersionLabel do: [ self model ifNotNil: [:m | m groupedByVersion ]]! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 17:32'! emptySelection self selection: nil! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 11/29/2010 11:11'! preference ^ preference! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:10'! removeButtonAction self removeSelectedMorph! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 11/29/2010 11:12'! byVersionLabel ^'By Version'! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 3/20/2012 14:20'! infoLabel ^'Change Date'! ! !MessageListBrowser methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 3/16/2012 04:26'! rootNodeClassFromItem: anItem "the class used to build node" ^self model useAsASet ifTrue:[ MessageListInspectableNode ] ifFalse: [ MessageListNonInspectableNode ]! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 14:39'! dictionary | result | result := self model dictionary. result ifEmpty: [self selection: nil]. ^result! ! !MessageListBrowser methodsFor: 'items creation' stamp: 'AlainPlantec 10/8/2011 14:21'! treeMorph ^ super defaultTreeMorph doubleClickSelector: #doubleClick; autoDeselection: true; getMenuSelector: #menu:shifted: ! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 11/29/2010 11:13'! versionLabel ^'Version'! ! !MessageListBrowser methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 11/29/2010 11:13'! buildButtonClear ^(PluggableButtonMorph on: self getState: #clearButtonState action: #clearButtonAction label: #clearButtonLabel) hResizing: #spaceFill! ! !MessageListBrowser methodsFor: 'display' stamp: 'BenjaminVanRyseghem 11/1/2011 07:37'! open | win | win := StandardWindow new model: self. win title: self model title. self addAllItems: win. win themeChanged. win openInWorld. ^ win! ! !MessageListBrowser methodsFor: 'droplist-items' stamp: ''! versionItem ^ DropListItem named: self versionLabel do: [ wrapper := VersionMethodReferenceConverter methodReference: wrapper method referencesList: self originalList ]! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:09'! clearButtonAction self promptForClear ifTrue: [self model clearAll]! ! !MessageListBrowser methodsFor: 'text' stamp: 'ClementBera 7/26/2013 16:51'! textToDisplay ^ self selectedNode ifNotNil: [ self selectedNode isInspectable ifTrue: [^self displayInformationFrom: self selectedNode]]! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 17:27'! model: aModel model := aModel. model when: #changed send: #updateView to: self. ! ! !MessageListBrowser methodsFor: 'private' stamp: ''! sortBlock self model isSortedByDateAscending ifTrue: [ ^ [:a :b | a < b ]]. self model isSortedByDateDescending ifTrue: [ ^ [:a :b | b < a ]]. ^ [:a :b | a asString < b asString ]! ! !MessageListBrowser methodsFor: 'display' stamp: ''! icon ^ self model icon! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 3/20/2012 14:20'! diffLabel ^'Diffs'! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'AlainPlantec 2/13/2011 15:22'! browseButtonState ^self selectedItem isNil.! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:11'! textArea ^ textArea! ! !MessageListBrowser methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 11/29/2010 11:16'! level ^ self model level.! ! !MessageListBrowser methodsFor: 'droplist-items' stamp: ''! byPackageItem ^ DropListItem named: self byPackageLabel do: [ self model ifNotNil: [:m | m groupedByPackage ]]! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 11/29/2010 11:13'! preferenceHelpText ^'Choose way to show'! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 3/20/2012 14:20'! sourceLabel ^'Source'! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:11'! environment ^ self model environment! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'MarcusDenker 7/29/2013 16:38'! revertButtonAction (self revertButtonState not and: [self textArea hasUnacceptedEdits not]) ifTrue: [self compileMethod: self textArea getText asString.] ifFalse: [UIManager default alert: 'The source code must have not been modified']! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:11'! textArea: anObject textArea := anObject! ! !MessageListBrowser methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/5/2011 14:04'! textMorphClass ^ PluggableTextMorph! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 11/29/2010 11:12'! byClassLabel ^'By Class'! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:10'! clearButtonLabel ^'Clear List'! ! !MessageListBrowser methodsFor: 'display' stamp: 'AlainPlantec 10/18/2013 10:31'! updateTree | prevSelected | prevSelected := self selectedItem. self updateList. prevSelected ifNotNil: [self selectItems: (Array with: prevSelected)] ! ! !MessageListBrowser methodsFor: 'droplist-items' stamp: ''! sourceItem ^ DropListItem named: self sourceLabel do: [ wrapper := SourceMethodConverter method: wrapper method ]! ! !MessageListBrowser methodsFor: '*necompletion-extensions' stamp: 'SeanDeNigris 6/24/2012 09:25'! isCodeCompletionAllowed ^ true.! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 3/20/2012 14:26'! preference: anObject preference := anObject. anObject value. self changed: #textToDisplay.! ! !MessageListBrowser methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 5/13/2011 13:36'! buildToolbar: aWindow "create the buttons toolbar" | toolbar | toolbar := aWindow newToolbar: { self buildDisplayDropList: aWindow. self buildButtonBrowse. self buildButtonRevert. self buildButtonRemove. self buildButtonClear. self buildPreferenceDropList: aWindow.}. ^toolbar hResizing: #shrinkWrap! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/16/2012 02:43'! selection: aSelection | item | super selection: aSelection. item := self selectedNode. item ifNotNil: [ item := item item ]. wrapper method: item. self changed: #textToDisplay. self updateTextArea ! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:09'! browseButtonLabel ^'Browse'! ! !MessageListBrowser methodsFor: 'droplist-items' stamp: ''! infoItem ^ DropListItem named: self infoLabel do: [ wrapper := TimeStampMethodConverter method: wrapper method ]! ! !MessageListBrowser methodsFor: 'items creation' stamp: 'sd 3/25/2012 20:49'! buildTextArea | text | text := self textMorphClass on: self text: #textToDisplay accept: #compileMethod: readSelection: nil menu: #msgPaneMenu:shifted:. text visible: false; askBeforeDiscardingEdits: true. text font: StandardFonts codeFont. ^ text! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 16:44'! clearButtonState ^self model dictionary isEmpty.! ! !MessageListBrowser methodsFor: 'menus' stamp: 'AlainPlantec 2/13/2011 17:20'! menu: menu shifted: b menu add: 'Browse' translated target: self selector: #browseSelectedMorph. menu add: 'Remove' target: self selector: #removeSelectedMorph. menu add: 'Expand All' target: self selector: #expandAll. menu add: 'Collapse All' target: self selector: #collapseAll.. ^menu! ! !MessageListBrowser methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 3/16/2012 05:08'! rootItems self model useAsASet ifTrue: [^ self originalList sort: self sortBlock ] ifFalse: [^ (self dictionary keys select: [:each | each isNil not]) sorted: self sortBlock ] "with some test, the class may be nil oO"! ! !MessageListBrowser methodsFor: '*Polymorph-Widgets' stamp: ''! taskbarIcon ^ self model taskbarIcon! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 11/29/2010 11:12'! byDateAscendingLabel ^'By Date Ascending'! ! !MessageListBrowser methodsFor: 'display' stamp: 'AlainPlantec 10/8/2011 14:45'! updateView self model ifNotNil: [:m | self changed: #dictionary. self changed: #originalList. m reSort. self updateTree] ! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'AlainPlantec 2/13/2011 15:28'! removeSelectedMorph self selectedNode ifNotNil: [:n | (self promptForRemove: n) ifTrue: [n removeMe]]! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 3/20/2012 14:56'! sortingSelector ^ sortingSelector! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:09'! browseButtonAction self browseSelectedMorph! ! !MessageListBrowser methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 3/20/2012 14:26'! buildDisplayDropList: aWindow ^ DropListMorph new useSelectionIndex: false; wrapSelector: #wrapDropListItem:; on: self list: #getDisplayList selected: #sortingSelector changeSelected: #sortingSelector:; hResizing: #spaceFill; vResizing: #spaceFill; hResizing: #rigid; width: 150; setBalloonText: self sortingSelectorHelpText; yourself! ! !MessageListBrowser methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 11/29/2010 11:16'! getMethod: aMessageListInspectableNode | methodReference | methodReference := (self getMethodReference: aMessageListInspectableNode) . ^ methodReference compiledMethod. ! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:10'! promptForClear "Ask if it is OK to remove all the nodes" ^(self confirm: 'Do you really want to clear the list ?' translated) ! ! !MessageListBrowser methodsFor: 'text' stamp: 'ClementBera 7/26/2013 16:51'! updateTextArea self textArea ifNil: [^self]. self selectedNode ifNil: [self textArea visible: false] ifNotNil: [ (self selectedNode isInspectable) ifTrue: [self textArea visible: true] ifFalse: [self textArea hide]]! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:10'! removeButtonLabel ^'Remove'! ! !MessageListBrowser methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/29/2010 11:45'! format: aString | list size result | size := 0. list := aString subStrings: String cr. list do: [:line || addedCharacter tempSize| addedCharacter := ''. line first == $- ifTrue: [addedCharacter := ' ']. tempSize := (addedCharacter, line) size. (tempSize > size) ifTrue: [size := tempSize]]! ! !MessageListBrowser methodsFor: 'items addition' stamp: 'StephaneDucasse 12/19/2012 16:53'! addAllItems: aWindow | width toolbar btnFont | toolbar := self buildToolbar: aWindow. btnFont := StandardFonts buttonFont. aWindow addMorph: (self treeMorph buildContents; yourself) fullFrame: (0@0 corner: 1@0.5) asLayoutFrame. aWindow addMorph: toolbar fullFrame: ((0@0.5 corner: 1@0.5) asLayoutFrame bottomOffset: (btnFont height + 14)). self textArea: self buildTextArea. aWindow addMorph: self textArea fullFrame: ((0@0.5 corner: 1@1) asLayoutFrame topOffset: (btnFont height + 14))! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'AlainPlantec 2/13/2011 15:24'! removeButtonState ^self selectedItem isNil.! ! !MessageListBrowser methodsFor: 'tree' stamp: 'VeronicaUquillas 9/3/2011 20:25'! getMethod: aMessageListInspectableNode ifAbsent: aBlock | methodReference | methodReference := (self getMethodReference: aMessageListInspectableNode) . ^ methodReference realClass methodDict at: methodReference name ifAbsent: aBlock. ! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 10:22'! model ^model! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 15:28'! isComment | node | node := self selectedNode. ^(node isInspectable) & (node item = 'Comment'). ! ! !MessageListBrowser methodsFor: 'tree' stamp: ''! getMethodReference: aMessageListInspectableNode ^aMessageListInspectableNode item.! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:10'! revertButtonLabel ^'Revert'! ! !MessageListBrowser methodsFor: 'droplist-items' stamp: ''! byClassItem ^ DropListItem named: self byClassLabel do: [ self model ifNotNil: [:m | m groupedByClass ]]! ! !MessageListBrowser methodsFor: 'droplist-items' stamp: ''! diffItem ^ DropListItem named: self diffLabel do: [ wrapper := DiffMethodReferenceConverter methodReference: wrapper method referencesList: self originalList ]! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'AlainPlantec 2/13/2011 15:29'! revertButtonState ^self selectedNode notNil and: [self selectedNode isInspectable not] ! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 3/20/2012 14:56'! sortingSelector: anObject anObject value. sortingSelector := anObject. self updateView.! ! !MessageListBrowser methodsFor: 'droplist' stamp: ''! wrapDropListItem: anItem ^ anItem label! ! !MessageListBrowser class methodsFor: 'deprecated' stamp: 'StephaneDucasse 11/26/2010 16:58'! byDateDescendingOn: aMessageList ^self on: aMessageList groupedUsing: aMessageList byDateDescendingSelector.! ! !MessageListBrowser class methodsFor: 'deprecated' stamp: 'StephaneDucasse 11/26/2010 16:58'! byClassOn: aMessageList ^self on: aMessageList groupedUsing: aMessageList byClassSelector! ! !MessageListBrowser class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/29/2010 10:23'! on: aMessageList ^self new model: aMessageList ! ! !MessageListBrowser class methodsFor: 'deprecated' stamp: 'StephaneDucasse 11/26/2010 16:58'! byDateAscendingOn: aMessageList ^self on: aMessageList groupedUsing: aMessageList byDateAscendingSelector! ! !MessageListBrowser class methodsFor: 'deprecated' stamp: 'BenjaminVanRyseghem 9/17/2011 16:53'! on: aMessageList groupedUsing: aSelector aMessageList perform: aSelector. ^self new model: aMessageList. ! ! !MessageListInspectableNode commentStamp: 'TorstenBergmann 2/20/2014 13:46'! Node model for inspectable nodes! !MessageListInspectableNode methodsFor: 'overrided' stamp: 'VeronicaUquillas 8/31/2011 23:51'! asString ^ self item ifNotNil: [self item fullName ] ! ! !MessageListInspectableNode methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 17:48'! inspectableContents ^ OrderedCollection with: self! ! !MessageListInspectableNode methodsFor: 'accessing' stamp: ''! originalIndex ^self model originalIndex: (self item)! ! !MessageListInspectableNode methodsFor: 'action' stamp: 'VeronicaUquillas 9/3/2011 20:12'! printList: aStream aStream nextPutAll: self item fullName! ! !MessageListInspectableNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:17'! isInspectable ^true! ! !MessageListInspectableNode methodsFor: 'accessing' stamp: 'VeronicaUquillas 9/3/2011 20:14'! getClass ^self item realClass! ! !MessageListInspectableNode methodsFor: 'overrided' stamp: 'BenjaminVanRyseghem 11/29/2010 11:17'! doubleClick self item browse! ! !MessageListInspectableNode methodsFor: 'testing' stamp: ''! includes: aNode ^ self = aNode complexContents.! ! !MessageListNonInspectableNode commentStamp: 'TorstenBergmann 2/20/2014 13:47'! Node model for non-inspectable nodes! !MessageListNonInspectableNode methodsFor: 'overrided' stamp: 'AlainPlantec 2/13/2011 20:18'! asString ^ self item ifNotNil: [self level = 1 ifTrue: [self model level = 2 ifTrue: [self item name asString] ifFalse: [self model level = 3 ifTrue: [self item asString]]] ifFalse: [self item name asString]] ! ! !MessageListNonInspectableNode methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 17:49'! inspectableContents | result | result := OrderedCollection new. self contents do: [:each | result addAll: each inspectableContents]. ^ result.! ! !MessageListNonInspectableNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:51'! dictionary dictionary ifNil: [ self parentNode ifNil: [ self model level = 2 ifTrue: [dictionary := self model dictionary]. self model level = 3 ifTrue:[dictionary := self model dictionary at: self item]] ifNotNil: [dictionary := self model dictionary at: (self parentNode item)]]. ^dictionary! ! !MessageListNonInspectableNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/16/2012 04:31'! childrenItems self level = 1 ifTrue: [ self model level = 2 ifTrue:[ ^ self dictionary at: self item ]. self model level = 3 ifTrue:[ ^ self dictionary keys sort:[:a :b | a asString < b asString ]]] ifFalse: [ ^ self dictionary at: self item ] ! ! !MessageListNonInspectableNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:17'! childNodeClassFromItem: anItem self level = 1 ifTrue: [ self model level = 2 ifTrue:[^MessageListInspectableNode]. self model level = 3 ifTrue:[^self class]] ifFalse: [^MessageListInspectableNode] ! ! !MessageListNonInspectableNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:18'! originalIndex | methodReference | self level = 1 ifTrue: [ self model level = 2 ifTrue: [methodReference := (self childrenItems first)]. self model level = 3 ifTrue: [ methodReference := (self dictionary associations first value first).]] ifFalse: [ methodReference := (self childrenItems first)]. ^self model originalIndex: methodReference ! ! !MessageListNonInspectableNode methodsFor: 'action' stamp: 'BenjaminVanRyseghem 11/29/2010 11:18'! printList: aStream | tab | tab := '- '. aStream nextPutAll: self item asString; nextPutAll: ' :'. self contents do: [:each | aStream nextPutAll: ' '. aStream nextPutAll: tab. each printList: aStream] ! ! !MessageListNonInspectableNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:18'! isInspectable ^false! ! !MessageListNonInspectableNode methodsFor: 'action' stamp: ''! removeMe self contents do: [:each | each removeMe].! ! !MessageListNonInspectableNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:18'! getClass self level = 1 ifTrue: [ self model level = 2 ifTrue:[^self item]. self model level = 3 ifTrue:[^self error: 'You shouldn''t ask the class of a package']] ifFalse: [^self item]! ! !MessageListNonInspectableNode methodsFor: 'overrided' stamp: 'StephaneDucasse 10/15/2011 20:59'! doubleClick | class | self level = 1 ifTrue: [ self model level = 2 ifTrue:[class := self getClass]. self model level = 3 ifTrue:[class := (self childNodeFromItem: (self childrenItems first)) getClass]] ifFalse: [ class := self getClass]. Smalltalk tools browser fullOnClass: class selector: nil ! ! !MessageListNonInspectableNode methodsFor: 'testing' stamp: 'GabrielOmarCotelli 12/3/2013 17:53'! includes: aNode ^ self = aNode complexContents or: [ self contents anySatisfy: [ :each | each includes: aNode ] ]! ! !MessageNode commentStamp: ''! I represent a receiver and its message. Precedence codes: 1 unary 2 binary 3 keyword 4 other If special>0, I compile special code in-line instead of sending messages with literal methods as remotely copied contexts.! !MessageNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 09:57'! sizeCodeForIfNil: encoder value: forValue | theNode theSize theSelector | equalNode := encoder encodeSelector: #==. sizes := Array new: 1. theNode := arguments first. theSelector := #ifNotNil:. forValue ifTrue: [sizes at: 1 put: (theSize := (encoder sizePop + (theNode sizeCodeForEvaluatedValue: encoder))). ^(receiver sizeCodeForValue: encoder) + encoder sizeDup + (encoder sizePushSpecialLiteral: nil) + (equalNode sizeCode: encoder args: 1 super: false) + (self sizeCode: encoder forBranchOn: selector key == theSelector dist: theSize) + theSize] ifFalse: [sizes at: 1 put: (theSize := (theNode sizeCodeForEvaluatedEffect: encoder)). ^(receiver sizeCodeForValue: encoder) + (encoder sizePushSpecialLiteral: nil) + (equalNode sizeCode: encoder args: 1 super: false) + (self sizeCode: encoder forBranchOn: selector key == theSelector dist: theSize) + theSize]! ! !MessageNode methodsFor: 'printing' stamp: 'RAA 2/15/2001 19:25'! macroPrinter special > 0 ifTrue: [^MacroPrinters at: special]. ^nil ! ! !MessageNode methodsFor: 'testing' stamp: 'md 7/27/2006 19:09'! isMessage ^true! ! !MessageNode methodsFor: 'macro transformations' stamp: ''! transformBoolean: encoder ^self checkBlock: (arguments at: 1) as: 'argument' from: encoder! ! !MessageNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:14'! printWhileOn: aStream indent: level self printReceiver: receiver on: aStream indent: level. (arguments isEmpty not and: [arguments first isJust: NodeNil]) ifTrue: [selector := SelectorNode new key: (selector key == #whileTrue: ifTrue: [#whileTrue] ifFalse: [#whileFalse]) code: #macro. arguments := Array new]. self printKeywords: selector key arguments: arguments on: aStream indent: level! ! !MessageNode methodsFor: 'code generation' stamp: 'eem 8/15/2010 10:23'! emitCodeForEffect: stack encoder: encoder "For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly." special > 0 ifTrue: [pc := 0. self perform: (MacroEmitters at: special) with: stack with: encoder with: false] ifFalse: [super emitCodeForEffect: stack encoder: encoder]! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 5/23/2008 13:14'! noteSpecialSelector: selectorSymbol "special > 0 denotes specially treated (potentially inlined) messages. " special := MacroSelectors indexOf: selectorSymbol. ! ! !MessageNode methodsFor: 'code generation' stamp: 'GuillermoPollito 2/8/2013 15:10'! sizeCodeForWhile: encoder value: forValue "L1: ... Bfp(L2) ... Jmp(L1) L2: nil (nil for value only); justStmt, wholeLoop, justJump." | cond theArguments stmt stmtSize loopSize branchSize | cond := receiver. theArguments := arguments ifEmpty: [ Array with: (BlockNode withJust: NodeNil) ]. stmt := theArguments at: 1. stmtSize := (stmt sizeCodeForEvaluatedEffect: encoder) + (encoder sizeJumpLong: 1). branchSize := self sizeCode: encoder forBranchOn: ((selector key == #whileFalse:) or: [ selector key == #whileFalse ]) "Btp for whileFalse" dist: stmtSize. loopSize := (cond sizeCodeForEvaluatedValue: encoder) + branchSize + stmtSize. sizes := Array with: stmtSize with: loopSize. ^loopSize + (forValue ifTrue: [encoder sizePushSpecialLiteral: nil] ifFalse: [0])! ! !MessageNode methodsFor: 'initialize-release' stamp: 'nice 3/2/2011 23:57'! receiver: rcvr selector: selNode arguments: args precedence: p "Decompile." self receiver: rcvr arguments: args precedence: p. originalSelector := selNode key. selNode code == #macro ifTrue: [self noteSpecialSelector: selNode key] ifFalse: [special := 0]. selector := selNode. "self pvtCheckForPvtSelector: encoder" "We could test code being decompiled, but the compiler should've checked already. And where to send the complaint?"! ! !MessageNode methodsFor: 'code generation' stamp: 'GuillermoPollito 2/8/2013 15:11'! emitCodeForWhile: stack encoder: encoder value: forValue "L1: ... Bfp(L2)|Btp(L2) ... Jmp(L1) L2: " | cond theArguments stmt stmtSize loopSize | cond := receiver. theArguments := arguments ifEmpty: [ Array with: (BlockNode withJust: NodeNil) ]. stmt := theArguments at: 1. stmtSize := sizes at: 1. loopSize := sizes at: 2. cond emitCodeForEvaluatedValue: stack encoder: encoder. self emitCodeForBranchOn: ((selector key == #whileFalse:) or: [ selector key == #whileFalse ]) "Bfp for whileTrue" dist: stmtSize pop: stack encoder: encoder. "Btp for whileFalse" pc := encoder methodStreamPosition. stmt emitCodeForEvaluatedEffect: stack encoder: encoder. self emitCodeForJump: 0 - loopSize encoder: encoder. forValue ifTrue: [encoder genPushSpecialLiteral: nil. stack push: 1]! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 9/6/2009 19:19'! transformIfFalseIfTrue: encoder ^(self checkBlock: (arguments at: 1) as: 'False arg' from: encoder) and: [(self checkBlock: (arguments at: 2) as: 'True arg' from: encoder) and: [selector := SelectorNode new key: #ifTrue:ifFalse: code: #macro. arguments swap: 1 with: 2. arguments do: [:arg| arg noteOptimizedIn: self]. true]]! ! !MessageNode methodsFor: 'printing' stamp: 'eem 5/6/2008 13:56'! printCaseOn: aStream indent: level "receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]" | braceNode otherwise extra | braceNode := arguments first. otherwise := arguments last. (arguments size = 1 or: [otherwise isJustCaseError]) ifTrue: [otherwise := nil]. receiver printOn: aStream indent: level precedence: 3. aStream nextPutAll: ' caseOf: '. braceNode isVariableReference ifTrue: [braceNode printOn: aStream indent: level] ifFalse: [aStream nextPutAll: '{'; crtab: level + 1. braceNode casesForwardDo: [:keyNode :valueNode :last | keyNode printOn: aStream indent: level + 1. aStream nextPutAll: ' -> '. valueNode isComplex ifTrue: [aStream crtab: level + 2. extra := 1] ifFalse: [extra := 0]. valueNode printOn: aStream indent: level + 1 + extra. last ifTrue: [aStream nextPut: $}] ifFalse: [aStream nextPut: $.; crtab: level + 1]]]. otherwise notNil ifTrue: [aStream crtab: level + 1; nextPutAll: ' otherwise: '. extra := otherwise isComplex ifTrue: [aStream crtab: level + 2. 1] ifFalse: [0]. otherwise printOn: aStream indent: level + 1 + extra]! ! !MessageNode methodsFor: 'printing' stamp: 'di 5/1/2000 23:20'! printIfNil: aStream indent: level self printReceiver: receiver on: aStream indent: level. ^self printKeywords: selector key arguments: (Array with: arguments first) on: aStream indent: level! ! !MessageNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:35'! accept: aVisitor ^aVisitor visitMessageNode: self! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 9/6/2009 13:30'! transformIfTrue: encoder (self transformBoolean: encoder) ifTrue: [arguments := Array with: ((arguments at: 1) noteOptimizedIn: self) with: ((BlockNode withJust: NodeNil) noteOptimizedIn: self). ^true] ifFalse: [^false]! ! !MessageNode methodsFor: 'testing' stamp: 'eem 9/23/2008 14:06'! isNilIf ^(special between: 3 and: 4) and: [(arguments first returns or: [arguments first isJust: NodeNil]) and: [(arguments last returns or: [arguments last isJust: NodeNil])]]! ! !MessageNode methodsFor: 'testing' stamp: 'nice 4/2/2011 19:00'! ensureCanCascade: encoder special > 0 ifTrue: [special := 0. selector := encoder encodeSelector: originalSelector. arguments := originalArguments. receiver isBlockNode ifTrue: [receiver deoptimize]. arguments do: [:each| each isBlockNode ifTrue: [each deoptimize]]]! ! !MessageNode methodsFor: 'code generation' stamp: 'nice 2/3/2011 21:12'! emitCodeForRepeat: stack encoder: encoder value: forValue " L1: ... Jmp(L1)" | loopSize | loopSize := sizes at: 1. receiver emitCodeForEvaluatedEffect: stack encoder: encoder. self emitCodeForJump: 0 - loopSize encoder: encoder. forValue ifTrue: [encoder genPushSpecialLiteral: nil. stack push: 1]! ! !MessageNode methodsFor: 'code generation' stamp: 'nice 2/20/2012 20:49'! sizeCodeForToDo: encoder value: forValue " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: " | loopSize initStmt test block incStmt blockSize initSize limitInit | block := arguments at: 3. initStmt := arguments at: 4. test := arguments at: 5. incStmt := arguments at: 6. limitInit := arguments at: 7. initSize := forValue ifTrue: [initStmt sizeCodeForValue: encoder.] ifFalse: [initStmt sizeCodeForEffect: encoder]. limitInit == nil ifFalse: [initSize := initSize + (limitInit sizeCodeForEffect: encoder)]. blockSize := (block sizeCodeForEvaluatedEffect: encoder) + (incStmt sizeCodeForEffect: encoder) + (encoder sizeJumpLong: -1). loopSize := (test sizeCodeForValue: encoder) + (self sizeCode: encoder forBranchOn: false dist: blockSize) + blockSize. sizes := Array with: blockSize with: loopSize. ^initSize + loopSize! ! !MessageNode methodsFor: 'testing' stamp: 'eem 7/20/2009 09:31'! isOptimized ^special > 0! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 9/6/2009 19:18'! transformOr: encoder (self transformBoolean: encoder) ifTrue: [arguments := Array with: ((BlockNode withJust: NodeTrue) noteOptimizedIn: self) with: ((arguments at: 1) noteOptimizedIn: self). ^true] ifFalse: [^false]! ! !MessageNode methodsFor: 'testing' stamp: ''! isMessage: selSymbol receiver: rcvrPred arguments: argsPred "Answer whether selector is selSymbol, and the predicates rcvrPred and argsPred evaluate to true with respect to receiver and the list of arguments. If selSymbol or either predicate is nil, it means 'don't care'. Note that argsPred takes numArgs arguments. All block arguments are ParseNodes." ^(selSymbol isNil or: [selSymbol==selector key]) and: [(rcvrPred isNil or: [rcvrPred value: receiver]) and: [(argsPred isNil or: [argsPred valueWithArguments: arguments])]]! ! !MessageNode methodsFor: 'printing' stamp: 'ul 11/15/2010 11:53'! printToDoOn: aStream indent: level | limitNode | self printReceiver: receiver on: aStream indent: level. (arguments last == nil or: [(arguments last isMemberOf: AssignmentNode) not]) ifTrue: [limitNode := arguments first] ifFalse: [limitNode := arguments last value]. (selector key = #to:by:do: and: [(arguments at: 2) isConstantNumber and: [(arguments at: 2) key = 1]]) ifTrue: [self printKeywords: #to:do: arguments: (Array with: limitNode with: (arguments at: 3)) on: aStream indent: level] ifFalse: [self printKeywords: selector key arguments: (Array with: limitNode) , arguments allButFirst on: aStream indent: level]! ! !MessageNode methodsFor: 'code generation' stamp: 'nice 12/27/2009 03:11'! sizeCodeForCase: encoder value: forValue | braceNode sizeIndex elseSize allReturn | forValue not ifTrue: [^super sizeCodeForEffect: encoder]. equalNode := encoder encodeSelector: #=. braceNode := arguments first. sizes := Array new: 2 * braceNode numElements. sizeIndex := sizes size. elseSize := arguments size = 2 ifTrue: [arguments last sizeCodeForEvaluatedValue: encoder] "otherwise: [...]" ifFalse: [caseErrorNode := encoder encodeSelector: #caseError. (NodeSelf sizeCodeForValue: encoder) + (caseErrorNode sizeCode: encoder args: 0 super: false)]. "self caseError" "There must be at least one branch around the otherwise/caseError so the decompiler can identify the end of the otherwise/caseError." allReturn := true. "assume every case ends with a return" braceNode casesForwardDo: [:keyNode :valueNode :last | valueNode returns ifFalse: [allReturn := false]]. braceNode casesReverseDo: [:keyNode :valueNode :last | | thenSize | sizes at: sizeIndex put: elseSize. thenSize := valueNode sizeCodeForEvaluatedValue: encoder. last ifFalse: [thenSize := thenSize + encoder sizePop]. valueNode returns ifFalse: [thenSize := thenSize + (self sizeCode: encoder forJump: elseSize)]. (last and: [allReturn]) ifTrue: [thenSize := thenSize + (self sizeCode: encoder forJump: elseSize)]. sizes at: sizeIndex-1 put: thenSize. last ifFalse: [elseSize := elseSize + encoder sizeDup]. elseSize := elseSize + (keyNode sizeCodeForEvaluatedValue: encoder) + (equalNode sizeCode: encoder args: 1 super: false) + (self sizeCode: encoder forBranchOn: false dist: thenSize) + thenSize. sizeIndex := sizeIndex - 2]. ^(receiver sizeCodeForValue: encoder) + elseSize! ! !MessageNode methodsFor: 'initialize-release' stamp: 'MarcusDenker 2/16/2010 09:05'! receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range "Compile." encoder noteSourceRange: range forNode: self. ^self receiver: rcvr selector: selName arguments: args precedence: p from: encoder! ! !MessageNode methodsFor: 'printing' stamp: ''! precedence ^precedence! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 9/6/2009 19:17'! transformWhile: encoder (self checkBlock: receiver as: 'receiver' from: encoder) ifFalse: [^false]. arguments size = 0 ifTrue: "transform bodyless form to body form" [selector := SelectorNode new key: (special = 10 ifTrue: [#whileTrue:] ifFalse: [#whileFalse:]) code: #macro. arguments := Array with: ((BlockNode withJust: NodeNil) noteOptimizedIn: self). receiver noteOptimizedIn: self. ^true]. ^(self transformBoolean: encoder) and: [receiver noteOptimizedIn: self. arguments first noteOptimizedIn: self. true]! ! !MessageNode methodsFor: 'equation translation' stamp: 'RAA 2/14/2001 14:07'! receiver: val "14 feb 2001 - removed return arrow" receiver := val! ! !MessageNode methodsFor: 'initialize-release' stamp: 'tk 10/26/2000 15:37'! selector: sel selector := sel! ! !MessageNode methodsFor: 'code generation' stamp: 'eem 8/15/2010 10:23'! emitCodeForValue: stack encoder: encoder "For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly." special > 0 ifTrue: [pc := 0. self perform: (MacroEmitters at: special) with: stack with: encoder with: true] ifFalse: [receiver ~~ nil ifTrue: [receiver emitCodeForValue: stack encoder: encoder]. arguments do: [:argument | argument emitCodeForValue: stack encoder: encoder]. pc := encoder methodStreamPosition + 1. "debug pc is first byte of the send, i.e. the next byte". selector emitCode: stack args: arguments size encoder: encoder super: receiver == NodeSuper]! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 9/6/2009 13:33'! transformAnd: encoder (self transformBoolean: encoder) ifTrue: [arguments := Array with: ((arguments at: 1) noteOptimizedIn: self) with: ((BlockNode withJust: NodeFalse) noteOptimizedIn: self). ^true] ifFalse: [^false]! ! !MessageNode methodsFor: 'visiting' stamp: 'eem 9/23/2008 21:52'! argumentsInEvaluationOrder "Answer the receivers arguments in evaluation order. If the receiver is a transformed to:do: node this will undo the misordering done by the transformation." ^(special > 0 and: [(MacroTransformers at: special) == #transformToDo: and: [arguments size >= 7]]) "arguments are in a weid order and may be nil in a transformed to:do: loop. sigh... c.f. emitCodeForToDo:encoder:value:" ifTrue: [(arguments at: 7) "limitInit" ifNil: [{ (arguments at: 4). "initStmt" (arguments at: 5). "test" (arguments at: 3). "block" (arguments at: 6) "incStmt" }] ifNotNil: [:limitInit| { limitInit. (arguments at: 4). "initStmt" (arguments at: 5). "test" (arguments at: 3). "block" (arguments at: 6) "incStmt" }]] ifFalse: [arguments]! ! !MessageNode methodsFor: 'private' stamp: 'acg 1/28/2000 00:57'! ifNilReceiver ^receiver! ! !MessageNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:28'! emitCodeForIfNil: stack encoder: encoder value: forValue | theNode theSize ifNotNilSelector | theNode := arguments first. theSize := sizes at: 1. ifNotNilSelector := #ifNotNil:. receiver emitCodeForValue: stack encoder: encoder. forValue ifTrue: [encoder genDup. stack push: 1]. encoder genPushSpecialLiteral: nil. stack push: 1. equalNode emitCode: stack args: 1 encoder: encoder. self emitCodeForBranchOn: (selector key == ifNotNilSelector) dist: theSize pop: stack encoder: encoder. pc := encoder methodStreamPosition. forValue ifTrue: [encoder genPop. stack pop: 1. theNode emitCodeForEvaluatedValue: stack encoder: encoder] ifFalse: [theNode emitCodeForEvaluatedEffect: stack encoder: encoder]! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 9/6/2009 19:19'! transformIfFalse: encoder (self transformBoolean: encoder) ifTrue: [arguments := Array with: ((BlockNode withJust: NodeNil) noteOptimizedIn: self) with: ((arguments at: 1) noteOptimizedIn: self). ^true] ifFalse: [^false]! ! !MessageNode methodsFor: 'testing' stamp: 'eem 2/3/2011 09:08'! canCascade ^receiver ~~ NodeSuper! ! !MessageNode methodsFor: 'code generation' stamp: 'nice 2/20/2012 20:50'! emitCodeForToDo: stack encoder: encoder value: forValue " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: " | loopSize initStmt limitInit test block incStmt blockSize | initStmt := arguments at: 4. limitInit := arguments at: 7. test := arguments at: 5. block := arguments at: 3. incStmt := arguments at: 6. blockSize := sizes at: 1. loopSize := sizes at: 2. limitInit == nil ifFalse: [limitInit emitCodeForEffect: stack encoder: encoder]. "This will return the receiver of to:do: which is the initial value of the loop" forValue ifTrue: [initStmt emitCodeForValue: stack encoder: encoder.] ifFalse: [initStmt emitCodeForEffect: stack encoder: encoder]. test emitCodeForValue: stack encoder: encoder. self emitCodeForBranchOn: false dist: blockSize pop: stack encoder: encoder. pc := encoder methodStreamPosition. block emitCodeForEvaluatedEffect: stack encoder: encoder. incStmt emitCodeForEffect: stack encoder: encoder. self emitCodeForJump: 0 - loopSize encoder: encoder.! ! !MessageNode methodsFor: 'code generation' stamp: 'PeterHugossonMiller 9/2/2009 16:13'! emitCodeForCase: stack encoder: encoder value: forValue | braceNode sizeStream allReturn | forValue ifFalse: [^super emitCodeForEffect: stack encoder: encoder]. braceNode := arguments first. sizeStream := sizes readStream. receiver emitCodeForValue: stack encoder: encoder. "There must be at least one branch around the otherwise/caseError so the decompiler can identify the end of the otherwise/caseError." allReturn := true. "assume every case ends with a return" braceNode casesForwardDo: [:keyNode :valueNode :last | | thenSize elseSize | thenSize := sizeStream next. elseSize := sizeStream next. last ifFalse: [encoder genDup. stack push: 1]. keyNode emitCodeForEvaluatedValue: stack encoder: encoder. equalNode emitCode: stack args: 1 encoder: encoder. self emitCodeForBranchOn: false dist: thenSize pop: stack encoder: encoder. last ifFalse: [encoder genPop. stack pop: 1]. valueNode emitCodeForEvaluatedValue: stack encoder: encoder. last ifTrue: [stack pop: 1]. valueNode returns ifFalse: [self emitCodeForJump: elseSize encoder: encoder. allReturn := false]. (last and: [allReturn]) ifTrue: [self emitCodeForJump: elseSize encoder: encoder]]. arguments size = 2 ifTrue: [arguments last emitCodeForEvaluatedValue: stack encoder: encoder] "otherwise: [...]" ifFalse: [NodeSelf emitCodeForValue: stack encoder: encoder. caseErrorNode emitCode: stack args: 0 encoder: encoder]! ! !MessageNode methodsFor: 'macro transformations' stamp: 'nice 1/12/2011 22:07'! toDoFromWhileWithInit: initStmt "Return nil, or a to:do: expression equivalent to this whileTrue:" | variable increment limit toDoBlock body test | (selector key == #whileTrue: and: [initStmt isAssignmentNode and: [initStmt variable isTemp]]) ifFalse: [^nil]. body := arguments last statements. variable := initStmt variable. increment := body last toDoIncrement: variable. (increment == nil or: [receiver statements size ~= 1]) ifTrue: [^nil]. test := receiver statements first. "Note: test chould really be checked that <= or >= comparison jibes with the sign of the (constant) increment" (test isMessageNode and: [(limit := test toDoLimit: variable) notNil]) ifFalse: [^nil]. "The block must not overwrite the limit" (limit isVariableNode and: [body anySatisfy: [:e | e isAssignmentNode and: [e variable = limit]]]) ifTrue: [^nil]. toDoBlock := BlockNode statements: body allButLast returns: false. toDoBlock arguments: (Array with: variable). variable scope: -1. variable beBlockArg. ^MessageNode new receiver: initStmt value selector: (SelectorNode new key: #to:by:do: code: #macro) arguments: (Array with: limit with: increment with: toDoBlock) precedence: precedence! ! !MessageNode methodsFor: 'macro transformations' stamp: 'nice 2/3/2011 20:58'! transformRepeat: encoder "answer true if this #repeat message can be optimized" ^(self checkBlock: receiver as: 'receiver' from: encoder) and: [receiver noteOptimizedIn: self. true]! ! !MessageNode methodsFor: 'testing' stamp: ''! toDoIncrement: variable (receiver = variable and: [selector key = #+]) ifFalse: [^ nil]. arguments first isConstantNumber ifTrue: [^ arguments first] ifFalse: [^ nil]! ! !MessageNode methodsFor: 'macro transformations' stamp: 'ul 2/26/2011 21:58'! transformCase: encoder | caseNode | caseNode := arguments first. (caseNode isMemberOf: BraceNode) ifFalse: [ ^false ]. (caseNode blockAssociationCheck: encoder) ifFalse: [ ^false ]. (arguments size = 1 or: [ self checkBlock: arguments last as: 'otherwise arg' from: encoder ]) ifFalse: [ ^false ]. caseNode elements do: [ :messageNode | messageNode receiver noteOptimizedIn: self. messageNode arguments first noteOptimizedIn: self ]. arguments size = 2 ifTrue: [ arguments last noteOptimizedIn: self ]. ^true! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 9/7/2010 14:56'! transformToDo: encoder " var := rcvr. L1: [var <= arg1] Bfp(L2) [block body. var := var + inc] Jmp(L1) L2: " | limit increment block initStmt test incStmt limitInit blockVar myRange blockRange limitIsAssignedTo | "First check for valid arguments" ((arguments last isMemberOf: BlockNode) and: [arguments last numberOfArguments = 1 and: [arguments last firstArgument isVariableReference "As with debugger remote vars"]]) ifFalse: [^false]. arguments size = 3 ifTrue: [increment := arguments at: 2. (increment isConstantNumber and: [increment literalValue ~= 0]) ifFalse: [^false]] ifFalse: [increment := encoder encodeLiteral: 1]. (limit := arguments at: 1) isVariableReference ifTrue: [limitIsAssignedTo := false. arguments last nodesDo: [:node| (node isAssignmentNode and: [node variable = limit]) ifTrue: [limitIsAssignedTo := true]]. limitIsAssignedTo ifTrue: [^false]]. arguments size < 3 ifTrue: "transform to full form" [selector := SelectorNode new key: #to:by:do: code: #macro]. "Now generate auxiliary structures" myRange := encoder rawSourceRanges at: self ifAbsent: [1 to: 0]. block := arguments last. blockRange := encoder rawSourceRanges at: block ifAbsent: [1 to: 0]. blockVar := block firstArgument. initStmt := AssignmentNode new variable: blockVar value: receiver. limit isVariableReference | limit isConstantNumber ifTrue: [limitInit := nil] ifFalse: "Need to store limit in a var" [limit := encoder bindBlockArg: blockVar key, 'LimiT' within: block. limit scope: -2. "Already done parsing block; flag so it won't print" block addArgument: limit. limitInit := AssignmentNode new variable: limit value: arguments first]. test := MessageNode new receiver: blockVar selector: (increment key > 0 ifTrue: [#<=] ifFalse: [#>=]) arguments: (Array with: limit) precedence: precedence from: encoder sourceRange: (myRange first to: blockRange first). incStmt := AssignmentNode new variable: blockVar value: (MessageNode new receiver: blockVar selector: #+ arguments: (Array with: increment) precedence: precedence from: encoder) from: encoder sourceRange: (myRange last to: myRange last). arguments := (Array with: limit with: increment with: block), (Array with: initStmt with: test with: incStmt with: limitInit). block noteOptimizedIn: self. ^true! ! !MessageNode methodsFor: 'testing' stamp: 'John M McIntosh 3/2/2009 19:58'! isMessageNode ^true! ! !MessageNode methodsFor: 'private' stamp: 'jmv 3/3/2011 08:53'! receiver: rcvr arguments: args precedence: p receiver := rcvr. arguments := args. originalArguments := arguments copy. sizes := Array new: arguments size. precedence := p! ! !MessageNode methodsFor: 'equation translation' stamp: ''! selector ^selector! ! !MessageNode methodsFor: 'testing' stamp: ''! toDoLimit: variable (receiver = variable and: [selector key = #<= or: [selector key = #>=]]) ifTrue: [^ arguments first] ifFalse: [^ nil]! ! !MessageNode methodsFor: 'code generation (closures)' stamp: 'eem 8/4/2009 11:58'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" "Assignments within optimized loops are tricky. Because a loop repeats a write to a temporary in an optimized loop effectively occurs after the loop. To handle this collect the set of temps assigned to in optimized loops and add extra writes after traversing the optimized loop constituents." | writtenToTemps | self isOptimizedLoop ifTrue: [{ receiver }, arguments do: [:node| (node notNil and: [node isBlockNode and: [node optimized]]) ifTrue: [assignmentPools at: node put: Set new]]]. "receiver is nil in cascades" receiver == nil ifFalse: [receiver analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools]. arguments do: [:node| node == nil ifFalse: "last argument of optimized to:do: can be nil" [node analyseTempsWithin: scopeBlock rootNode: rootNode assignmentPools: assignmentPools]]. "Add assignments representing subsequent iterations and redo the closure analysis for the written-to temps." self isOptimizedLoop ifTrue: [writtenToTemps := Set new. { receiver }, arguments do: [:node| (node notNil and: [node isBlockNode and: [node optimized]]) ifTrue: [(assignmentPools removeKey: node) do: [:temp| temp isBlockArg ifFalse: "ignore added assignments to to:do: loop args" [writtenToTemps add: temp. temp addWriteWithin: node at: rootNode locationCounter]]]]. writtenToTemps isEmpty ifFalse: [(writtenToTemps asSortedCollection: ParseNode tempSortBlock) do: [:each| each analyseClosure: rootNode]. (writtenToTemps collect: [:each| each definingScope]) do: [:blockNode| blockNode ifHasRemoteTempNodeEnsureInitializationStatementExists: rootNode]]]! ! !MessageNode methodsFor: 'code generation' stamp: 'nice 3/31/2011 00:25'! sizeCodeForValue: encoder | total | special > 0 ifTrue: [encoder noteOptimizedSelector: originalSelector. ^self perform: (MacroSizers at: special) with: encoder with: true]. receiver == NodeSuper ifTrue: [selector := selector copy "only necess for splOops"]. total := selector sizeCode: encoder args: arguments size super: receiver == NodeSuper. receiver == nil ifFalse: [total := total + (receiver sizeCodeForValue: encoder)]. sizes := arguments collect: [:arg | | argSize | argSize := arg sizeCodeForValue: encoder. total := total + argSize. argSize]. ^total! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 9/6/2009 19:19'! transformIfNil: encoder "vb: Removed the original transformBoolean: which amounds to a test we perform in each of the branches below." (MacroSelectors at: special) = #ifNotNil: ifTrue: [(self checkBlock: arguments first as: 'ifNotNil arg' from: encoder maxArgs: 1) ifFalse: [^false]. "Transform 'ifNotNil: [stuff]' to 'ifNil: [nil] ifNotNil: [stuff]'. Slightly better code and more consistent with decompilation." self noteSpecialSelector: #ifNil:ifNotNil:. selector := SelectorNode new key: (MacroSelectors at: special) code: #macro. arguments := Array with: ((BlockNode withJust: NodeNil) noteOptimizedIn: self) with: (arguments first noteOptimizedIn: self). (self transform: encoder) ifFalse: [self error: 'compiler logic error']. ^true]. (self checkBlock: arguments first as: 'ifNil arg' from: encoder) ifFalse: [^false]. arguments first noteOptimizedIn: self. ^true! ! !MessageNode methodsFor: 'testing' stamp: 'eem 9/26/2008 12:39'! isReturningIf ^((special between: 3 and: 4) "ifTrue:ifFalse:/ifFalse:ifTrue:" or: [special between: 17 and: 18]) "ifNil:ifNotNil:/ifNotNil:ifNil:" and: [arguments first returns and: [arguments last returns]]! ! !MessageNode methodsFor: 'macro transformations' stamp: ''! transform: encoder special = 0 ifTrue: [^false]. (self perform: (MacroTransformers at: special) with: encoder) ifTrue: [^true] ifFalse: [special := 0. ^false]! ! !MessageNode methodsFor: 'testing' stamp: ''! isComplex ^(special between: 1 and: 10) or: [arguments size > 2 or: [receiver isComplex]]! ! !MessageNode methodsFor: 'printing' stamp: 'di 5/1/2000 23:20'! printIfNilNotNil: aStream indent: level self printReceiver: receiver ifNilReceiver on: aStream indent: level. (arguments first isJust: NodeNil) ifTrue: [^ self printKeywords: #ifNotNil: arguments: { arguments second } on: aStream indent: level]. (arguments second isJust: NodeNil) ifTrue: [^ self printKeywords: #ifNil: arguments: { arguments first } on: aStream indent: level]. ^ self printKeywords: #ifNil:ifNotNil: arguments: arguments on: aStream indent: level! ! !MessageNode methodsFor: 'printing' stamp: 'nice 2/3/2011 20:57'! printRepeatOn: aStream indent: level self printReceiver: receiver on: aStream indent: level. ^self printKeywords: selector key arguments: (Array new) on: aStream indent: level! ! !MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 16:12'! printOn: aStream indent: level "may not need this check anymore - may be fixed by the #receiver: change" special ifNil: [^aStream nextPutAll: '** MessageNode with nil special **']. special > 0 ifTrue: [^self perform: self macroPrinter with: aStream with: level]. self printReceiver: receiver on: aStream indent: level. selector isForFFICall ifTrue: [aStream space. selector printAsFFICallWithArguments: arguments on: aStream indent: 0] ifFalse: [self printKeywords: selector key arguments: arguments on: aStream indent: level]! ! !MessageNode methodsFor: 'private' stamp: 'vb 4/15/2007 09:10'! checkBlock: node as: nodeName from: encoder ^self checkBlock: node as: nodeName from: encoder maxArgs: 0! ! !MessageNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:12'! emitCodeForIf: stack encoder: encoder value: forValue | thenExpr thenSize elseExpr elseSize | thenSize := sizes at: 1. elseSize := sizes at: 2. (forValue not and: [elseSize * thenSize > 0]) ifTrue: "Two-armed IFs forEffect share a single pop" [^super emitCodeForEffect: stack encoder: encoder]. thenExpr := arguments at: 1. elseExpr := arguments at: 2. receiver emitCodeForValue: stack encoder: encoder. forValue ifTrue: "Code all forValue as two-armed" [self emitCodeForBranchOn: false dist: thenSize pop: stack encoder: encoder. pc := encoder methodStreamPosition. thenExpr emitCodeForEvaluatedValue: stack encoder: encoder. stack pop: 1. "then and else alternate; they don't accumulate" thenExpr returns not ifTrue: "...not ifTrue: avoids using ifFalse: alone during this compile)" "Elide jump over else after a return" [self emitCodeForJump: elseSize encoder: encoder]. elseExpr emitCodeForEvaluatedValue: stack encoder: encoder] ifFalse: "One arm is empty here (two-arms code forValue)" [thenSize > 0 ifTrue: [self emitCodeForBranchOn: false dist: thenSize pop: stack encoder: encoder. pc := encoder methodStreamPosition. thenExpr emitCodeForEvaluatedEffect: stack encoder: encoder] ifFalse: [self emitCodeForBranchOn: true dist: elseSize pop: stack encoder: encoder. pc := encoder methodStreamPosition. elseExpr emitCodeForEvaluatedEffect: stack encoder: encoder]]! ! !MessageNode methodsFor: 'printing' stamp: 'eem 5/6/2008 13:57'! printIfOn: aStream indent: level receiver ifNotNil: [receiver printOn: aStream indent: level + 1 precedence: precedence]. (arguments last isJust: NodeNil) ifTrue: [^self printKeywords: #ifTrue: arguments: (Array with: arguments first) on: aStream indent: level]. (arguments last isJust: NodeFalse) ifTrue: [^self printKeywords: #and: arguments: (Array with: arguments first) on: aStream indent: level]. (arguments first isJust: NodeNil) ifTrue: [^self printKeywords: #ifFalse: arguments: (Array with: arguments last) on: aStream indent: level]. (arguments first isJust: NodeTrue) ifTrue: [^self printKeywords: #or: arguments: (Array with: arguments last) on: aStream indent: level]. self printKeywords: #ifTrue:ifFalse: arguments: arguments on: aStream indent: level! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 9/6/2009 19:18'! transformIfNilIfNotNil: encoder "vb: Changed to support one-argument ifNotNil: branch. In the 1-arg case we transform the receiver to (var := receiver) which is further transformed to (var := receiver) == nil ifTrue: .... ifFalse: ... This does not allow the block variable to shadow an existing temp, but it's no different from how to:do: is done." | ifNotNilArg | ifNotNilArg := arguments at: 2. ((self checkBlock: (arguments at: 1) as: 'Nil arg' from: encoder) and: [self checkBlock: ifNotNilArg as: 'NotNil arg' from: encoder maxArgs: 1]) ifFalse: [^false]. ifNotNilArg numberOfArguments = 1 ifTrue: [receiver := AssignmentNode new variable: ifNotNilArg firstArgument value: receiver]. selector := SelectorNode new key: #ifTrue:ifFalse: code: #macro. receiver := MessageNode new receiver: receiver selector: #== arguments: (Array with: NodeNil) precedence: 2 from: encoder. arguments do: [:arg| arg noteOptimizedIn: self]. ^true! ! !MessageNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:09'! printReceiver: rcvr on: aStream indent: level rcvr ifNil: [^ self]. "Force parens around keyword receiver of kwd message" rcvr printOn: aStream indent: level precedence: precedence! ! !MessageNode methodsFor: 'testing' stamp: 'eem 7/20/2009 10:44'! isOptimizedLoop ^special > 0 and: [#(transformWhile: transformToDo:) includes: (MacroTransformers at: special)]! ! !MessageNode methodsFor: 'code generation' stamp: 'nice 2/3/2011 21:10'! sizeCodeForRepeat: encoder value: forValue "L1: ... Jmp(L1) nil (nil for value only);" | loopSize | loopSize := (receiver sizeCodeForEvaluatedEffect: encoder) + (encoder sizeJumpLong: 1). sizes := Array with: loopSize. ^loopSize + (forValue ifTrue: [encoder sizePushSpecialLiteral: nil] ifFalse: [0])! ! !MessageNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:15'! sizeCodeForIf: encoder value: forValue | thenExpr elseExpr branchSize thenSize elseSize | thenExpr := arguments at: 1. elseExpr := arguments at: 2. (forValue or: [(thenExpr isJust: NodeNil) or: [elseExpr isJust: NodeNil]]) not "(...not ifTrue: avoids using ifFalse: alone during this compile)" ifTrue: "Two-armed IFs forEffect share a single pop" [^super sizeCodeForEffect: encoder]. forValue ifTrue: "Code all forValue as two-armed" [elseSize := elseExpr sizeCodeForEvaluatedValue: encoder. thenSize := (thenExpr sizeCodeForEvaluatedValue: encoder) + (thenExpr returns ifTrue: [0] "Elide jump over else after a return" ifFalse: [self sizeCode: encoder forJump: elseSize]). branchSize := self sizeCode: encoder forBranchOn: false dist: thenSize] ifFalse: "One arm is empty here (two-arms code forValue)" [(elseExpr isJust: NodeNil) ifTrue: [elseSize := 0. thenSize := thenExpr sizeCodeForEvaluatedEffect: encoder. branchSize := self sizeCode: encoder forBranchOn: false dist: thenSize] ifFalse: [thenSize := 0. elseSize := elseExpr sizeCodeForEvaluatedEffect: encoder. branchSize := self sizeCode: encoder forBranchOn: true dist: elseSize]]. sizes := Array with: thenSize with: elseSize. ^(receiver sizeCodeForValue: encoder) + branchSize + thenSize + elseSize! ! !MessageNode methodsFor: 'equation translation' stamp: ''! receiver ^receiver! ! !MessageNode methodsFor: 'printing' stamp: 'di 5/30/2000 23:17'! printOn: strm indent: level precedence: outerPrecedence | parenthesize | parenthesize := precedence > outerPrecedence or: [outerPrecedence = 3 and: [precedence = 3 "both keywords"]]. parenthesize ifTrue: [strm nextPutAll: '('. self printOn: strm indent: level. strm nextPutAll: ')'] ifFalse: [self printOn: strm indent: level]! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 9/6/2009 13:30'! transformIfTrueIfFalse: encoder ^(self checkBlock: (arguments at: 1) as: 'True arg' from: encoder) and: [(self checkBlock: (arguments at: 2) as: 'False arg' from: encoder) and: [arguments do: [:arg| arg noteOptimizedIn: self]. true]]! ! !MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 15:41'! printKeywords: key arguments: args on: aStream indent: level | keywords indent arg kwd doCrTab | args size = 0 ifTrue: [aStream space; nextPutAll: key. ^self]. keywords := key keywords. doCrTab := args size > 2 or: [{receiver} , args anySatisfy: [:thisArg | thisArg notNil and: [thisArg isBlockNode or: [thisArg isMessageNode and: [thisArg precedence >= 3]]]]]. 1 to: (args size min: keywords size) do: [:i | arg := args at: i. kwd := keywords at: i. doCrTab ifTrue: [aStream crtab: level+1. indent := 1] "newline after big args" ifFalse: [aStream space. indent := 0]. aStream nextPutAll: kwd; space. arg printOn: aStream indent: level + 1 + indent precedence: (precedence = 2 ifTrue: [1] ifFalse: [precedence])]! ! !MessageNode methodsFor: 'cascading' stamp: ''! cascadeReceiver "Nil out rcvr (to indicate cascade) and return what it had been." | rcvr | rcvr := receiver. receiver := nil. ^rcvr! ! !MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 14:51'! printParenReceiver: rcvr on: aStream indent: level rcvr isBlockNode ifTrue: [^rcvr printOn: aStream indent: level]. aStream nextPut: $(. rcvr printOn: aStream indent: level. aStream nextPut: $) ! ! !MessageNode methodsFor: 'equation translation' stamp: 'tk 10/27/2000 15:11'! arguments: list arguments := list! ! !MessageNode methodsFor: 'private' stamp: 'ul 2/20/2011 17:17'! checkBlock: node as: nodeName from: encoder maxArgs: maxArgs "Answer true if node is a BlockNode with at most maxArgs arguments. This check is required in order to inline some special messages. Notify some undue usage of these special messages." node isBlockNode ifFalse: [ ^false ]. node numberOfArguments <= maxArgs ifTrue: [ ^true ]. ^encoder notify: '<- ', nodeName , ' of ' , (MacroSelectors at: special) , ' has too many arguments'! ! !MessageNode methodsFor: 'macro transformations' stamp: 'eem 9/6/2009 13:30'! transformIfNotNilIfNil: encoder "vb: Changed to support one-argument ifNotNil: branch. In the 1-arg case we transform the receiver to (var := receiver) which is further transformed to (var := receiver) == nil ifTrue: .... ifFalse: ... This does not allow the block variable to shadow an existing temp, but it's no different from how to:do: is done." | ifNotNilArg | ifNotNilArg := arguments at: 1. ((self checkBlock: ifNotNilArg as: 'NotNil arg' from: encoder maxArgs: 1) and: [self checkBlock: (arguments at: 2) as: 'Nil arg' from: encoder]) ifFalse: [^false]. ifNotNilArg numberOfArguments = 1 ifTrue: [receiver := AssignmentNode new variable: ifNotNilArg firstArgument value: receiver]. selector := SelectorNode new key: #ifTrue:ifFalse: code: #macro. receiver := MessageNode new receiver: receiver selector: #== arguments: (Array with: NodeNil) precedence: 2 from: encoder. arguments swap: 1 with: 2. arguments do: [:arg| arg noteOptimizedIn: self]. ^true! ! !MessageNode methodsFor: 'initialize-release' stamp: 'ClementBera 7/26/2013 16:52'! receiver: rcvr selector: aSelector arguments: args precedence: p from: encoder "Compile." self receiver: rcvr arguments: args precedence: p. originalSelector := aSelector. self noteSpecialSelector: aSelector. (self transform: encoder) ifTrue: [selector ifNil: [selector := SelectorNode new key: (MacroSelectors at: special) code: #macro]] ifFalse: [selector := encoder encodeSelector: aSelector. rcvr == NodeSuper ifTrue: [encoder noteSuper]]. ! ! !MessageNode methodsFor: 'equation translation' stamp: ''! arguments ^arguments! ! !MessageNode methodsFor: 'code generation' stamp: 'nice 3/31/2011 00:24'! sizeCodeForEffect: encoder special > 0 ifTrue: [encoder noteOptimizedSelector: originalSelector. ^self perform: (MacroSizers at: special) with: encoder with: false]. ^super sizeCodeForEffect: encoder! ! !MessageNode class methodsFor: 'class initialization' stamp: 'nice 2/3/2011 21:27'! initialize "MessageNode initialize" MacroSelectors := #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: and: or: whileFalse: whileTrue: whileFalse whileTrue to:do: to:by:do: caseOf: caseOf:otherwise: ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil: repeat ). MacroTransformers := #( transformIfTrue: transformIfFalse: transformIfTrueIfFalse: transformIfFalseIfTrue: transformAnd: transformOr: transformWhile: transformWhile: transformWhile: transformWhile: transformToDo: transformToDo: transformCase: transformCase: transformIfNil: transformIfNil: transformIfNilIfNotNil: transformIfNotNilIfNil: transformRepeat: ). MacroEmitters := #( emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: emitCodeForWhile:encoder:value: emitCodeForWhile:encoder:value: emitCodeForWhile:encoder:value: emitCodeForWhile:encoder:value: emitCodeForToDo:encoder:value: emitCodeForToDo:encoder:value: emitCodeForCase:encoder:value: emitCodeForCase:encoder:value: emitCodeForIfNil:encoder:value: emitCodeForIfNil:encoder:value: emitCodeForIf:encoder:value: emitCodeForIf:encoder:value: emitCodeForRepeat:encoder:value:). MacroSizers := #( sizeCodeForIf:value: sizeCodeForIf:value: sizeCodeForIf:value: sizeCodeForIf:value: sizeCodeForIf:value: sizeCodeForIf:value: sizeCodeForWhile:value: sizeCodeForWhile:value: sizeCodeForWhile:value: sizeCodeForWhile:value: sizeCodeForToDo:value: sizeCodeForToDo:value: sizeCodeForCase:value: sizeCodeForCase:value: sizeCodeForIfNil:value: sizeCodeForIfNil:value: sizeCodeForIf:value: sizeCodeForIf:value: sizeCodeForRepeat:value:). MacroPrinters := #( printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent: printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: printToDoOn:indent: printToDoOn:indent: printCaseOn:indent: printCaseOn:indent: printIfNil:indent: printIfNil:indent: printIfNilNotNil:indent: printIfNilNotNil:indent: printRepeatOn:indent:)! ! !MessageNotUnderstood commentStamp: ''! This exception is provided to support Object>>doesNotUnderstand:.! !MessageNotUnderstood methodsFor: 'initialization' stamp: 'stephane.ducasse 12/22/2008 13:50'! initialize super initialize. reachedDefaultHandler := false ! ! !MessageNotUnderstood methodsFor: 'accessing' stamp: 'stephane.ducasse 12/22/2008 13:50'! defaultAction reachedDefaultHandler := true. super defaultAction.! ! !MessageNotUnderstood methodsFor: 'accessing' stamp: 'stephane.ducasse 12/22/2008 13:51'! reachedDefaultHandler ^reachedDefaultHandler! ! !MessageNotUnderstood methodsFor: 'accessing' stamp: 'pnm 8/16/2000 15:03'! message: aMessage message := aMessage! ! !MessageNotUnderstood methodsFor: 'accessing' stamp: 'tfei 6/4/1999 18:27'! message "Answer the selector and arguments of the message that failed." ^message! ! !MessageNotUnderstood methodsFor: 'accessing' stamp: 'ClementBera 9/27/2013 17:58'! messageText "Return an exception's message text." ^ messageText ifNil: [message ifNil: [super messageText] ifNotNil: [ message lookupClass == UndefinedObject ifTrue: ['receiver of "{1}" is nil' translated format: {message selector asString}] ifFalse: [message lookupClass printString, '>>', message selector asString]]]! ! !MessageNotUnderstood methodsFor: 'accessing' stamp: 'ajh 10/9/2001 16:38'! receiver: obj receiver := obj! ! !MessageNotUnderstood methodsFor: 'accessing' stamp: 'ajh 10/9/2001 16:39'! receiver "Answer the receiver that did not understand the message" ^ receiver! ! !MessageNotUnderstood methodsFor: 'private' stamp: 'tfei 6/4/1999 18:30'! isResumable "Determine whether an exception is resumable." ^true! ! !MessageSend commentStamp: 'DF 5/25/2006 19:54'! Instances of MessageSend encapsulate message sends to objects. Arguments can be either predefined or supplied when the message send is performed. Use #value to perform a message send with its predefined arguments and #valueWithArguments: if additonal arguments have to supplied. Structure: receiver Object -- object receiving the message send selector Symbol -- message selector arguments Array -- bound arguments! !MessageSend methodsFor: 'evaluating' stamp: 'IgorStasenko 3/12/2011 16:16'! cull: arg1 cull: arg2 ^ selector numArgs < 2 ifTrue: [ self cull: arg1] ifFalse: [ self value: arg1 value: arg2 ]! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! selector ^ selector! ! !MessageSend methodsFor: 'comparing' stamp: 'sma 3/11/2000 10:35'! hash ^ receiver hash bitXor: selector hash! ! !MessageSend methodsFor: 'evaluating' stamp: 'IgorStasenko 3/12/2011 16:22'! value: anObject1 value: anObject2 ^ receiver perform: selector with: anObject1 with: anObject2! ! !MessageSend methodsFor: 'evaluating' stamp: 'IgorStasenko 3/12/2011 16:22'! value: anObject1 value: anObject2 value: anObject3 ^ receiver perform: selector with: anObject1 with: anObject2 with: anObject3! ! !MessageSend methodsFor: 'evaluating' stamp: 'IgorStasenko 3/12/2011 16:15'! cull: arg ^ selector numArgs = 0 ifTrue: [ self value ] ifFalse: [ self value: arg ]. ! ! !MessageSend methodsFor: 'evaluating' stamp: 'IgorStasenko 3/12/2011 16:23'! cull: arg1 cull: arg2 cull: arg3 ^ selector numArgs < 3 ifTrue: [ self cull: arg1 cull: arg2 ] ifFalse: [ self value: arg1 value: arg2 value: arg3 ]! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! receiver: anObject receiver := anObject! ! !MessageSend methodsFor: 'converting' stamp: 'nk 12/20/2002 17:54'! asMinimalRepresentation ^self! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:40'! arguments: anArray arguments := anArray! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! receiver ^ receiver! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! selector: aSymbol selector := aSymbol! ! !MessageSend methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 16:51'! valueWithArguments: anArray ^ receiver perform: selector withArguments: (self collectArguments: anArray)! ! !MessageSend methodsFor: 'evaluating' stamp: 'PavelKrivanek 6/24/2012 18:28'! value "Send the message and answer the return value" (receiver class isObsolete) ifTrue: [^ nil]. (receiver isBehavior and: [receiver isObsolete]) ifTrue: [^ nil]. arguments ifNil: [^ receiver perform: selector]. ^ receiver perform: selector withArguments: (self collectArguments: arguments)! ! !MessageSend methodsFor: 'comparing' stamp: 'sma 2/29/2000 20:43'! = anObject ^ anObject species == self species and: [receiver == anObject receiver and: [selector == anObject selector and: [arguments = anObject arguments]]]! ! !MessageSend methodsFor: 'evaluating' stamp: 'nk 3/11/2001 11:42'! valueWithEnoughArguments: anArray "call the selector with enough arguments from arguments and anArray" | args | args := Array new: selector numArgs. args replaceFrom: 1 to: (arguments size min: args size) with: arguments startingAt: 1. args size > arguments size ifTrue: [ args replaceFrom: arguments size + 1 to: (arguments size + anArray size min: args size) with: anArray startingAt: 1. ]. ^ receiver perform: selector withArguments: args! ! !MessageSend methodsFor: 'printing' stamp: 'SqR 7/14/2001 11:36'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(. selector printOn: aStream. aStream nextPutAll: ' -> '. receiver printOn: aStream. aStream nextPut: $)! ! !MessageSend methodsFor: 'accessing' stamp: 'eem 1/3/2009 10:42'! numArgs "Answer the number of arguments in this message" ^arguments size! ! !MessageSend methodsFor: 'evaluating' stamp: 'PavelKrivanek 6/24/2012 18:29'! value: anObject (receiver class isObsolete) ifTrue: [^ nil]. (receiver isBehavior and: [receiver isObsolete]) ifTrue: [^ nil]. ^ receiver perform: selector with: anObject! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! arguments ^ arguments! ! !MessageSend methodsFor: 'testing' stamp: 'nk 4/25/2002 08:04'! isMessageSend ^true ! ! !MessageSend methodsFor: 'testing' stamp: 'nk 7/21/2003 15:16'! isValid ^true! ! !MessageSend methodsFor: 'converting' stamp: 'IgorStasenko 3/12/2011 17:49'! asWeakMessageSend ^ WeakMessageSend receiver: receiver selector: selector arguments: arguments copy! ! !MessageSend methodsFor: 'private' stamp: 'reThink 2/18/2001 17:33'! collectArguments: anArgArray "Private" | staticArgs | staticArgs := self arguments. ^(anArgArray size = staticArgs size) ifTrue: [anArgArray] ifFalse: [(staticArgs isEmpty ifTrue: [ staticArgs := Array new: selector numArgs] ifFalse: [staticArgs copy] ) replaceFrom: 1 to: (anArgArray size min: staticArgs size) with: anArgArray startingAt: 1]! ! !MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:44'! receiver: anObject selector: aSymbol ^ self receiver: anObject selector: aSymbol arguments: #()! ! !MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:39'! receiver: anObject selector: aSymbol arguments: anArray ^ self new receiver: anObject; selector: aSymbol; arguments: anArray! ! !MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:44'! receiver: anObject selector: aSymbol argument: aParameter ^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter)! ! !MessageSendDebugAction commentStamp: ''! A MessageSendDebugAction is an action that sends a message to a receiver with the right amount of arguments. To specify the receiver subclasses have to override the method #receiver. Furthermoe subclasses must specify an id. The selector is optional as the id will be used if no selector is present/ Instance Variables id: selector: id - xxxxx selector - xxxxx ! !MessageSendDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:01'! id ^ id! ! !MessageSendDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:01'! id: aSymbol id := aSymbol ! ! !MessageSendDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:02'! selector ^ selector ifNil: [ self id ]! ! !MessageSendDebugAction methodsFor: 'actions' stamp: 'AndreiChis 9/24/2013 18:03'! executeAction self receiver perform: self selector withEnoughArguments: self arguments! ! !MessageSendDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:03'! arguments ^ #()! ! !MessageSendDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:04'! receiver ^ nil! ! !MessageSendDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:02'! selector: aSymbol selector := aSymbol! ! !MessageTally commentStamp: 'StephaneDucasse 9/27/2009 10:42'! My instances observe and report the amount of time spent in methods. NOTE: a higher-level user interface (combining the MessageTally result tree with a method browser) is available from TimeProfileBrowser. Note that TimeProfileBrowser was not fancy with the different setting possibilities. TimeProfileBrowser spyOn: [20 timesRepeat: [Transcript show: 100 factorial printString]] Strategies ----------- MessageTally provides two different strategies available for profiling: * spyOn: and friends use a high-priority Process to interrupt the block or process being spied on at periodic intervals. The interrupted call stack is then examined for caller information. See below for an example showing different settings * tallySends: and friends use the interpreter simulator to run the block, recording every method call. The two give you different results: * spyOn: gives you a view of where the time is being spent in your program, at least on a rough statistical level (assuming you've run the block for long enough and have a high enough poll rate). If you're trying to optimize your code, start here and optimize the methods where most of the time is being spent first. * tallySends: gives you accurate counts of how many times methods get called, and by exactly which route. If you're debugging, or trying to figure out if a given method is getting called too many times, this is your tool. Q: How do you interpret MessageTally>>tallySends A: The methods #tallySends and #spyOn: measure two very different quantities, but broken down in the same who-called-who format. #spyOn: is approximate, but more indicative of real time spent, whereas #tallySends is exact and a precise record of how many times each method got executed. Examples ---------- Here you can see all the processes computation time [1000 timesRepeat: [3.14159 printString. Processor yield]] fork. [1000 timesRepeat: [30 factorial. Processor yield]] fork. [1000 timesRepeat: [30 factorial. Processor yield]] fork. MessageTally spyAllOn: [ (Delay forMilliseconds: 100) wait] Settings --------- You can change the printing format (that is, the whitespace and string compression) by using these instance methods: maxClassNameSize: maxClassPlusSelectorSize: maxTabs: You can change the default polling period (initially set to 1) by calling MessageTally defaultPollPeriod: numberOfMilliseconds To understand the difference ---------------------------------- Here we see all the processes [1000 timesRepeat: [ 100 timesRepeat: [120 factorial]. (Delay forMilliseconds: 10) wait ]] forkAt: 45 named: '45'. MessageTally spyAllOn: [10000 timesRepeat: [1.23 printString]] Here we only see the execution of the expression [10000 timesRepeat: [1.23 printString] [1000 timesRepeat: [ 100 timesRepeat: [120 factorial]. (Delay forMilliseconds: 10) wait ]] forkAt: 45 named: '45'. MessageTally spyOn: [10000 timesRepeat: [1.23 printString]] Here we only check the exact message sends: this is not a pc-sampling approach [1000 timesRepeat: [ 100 timesRepeat: [120 factorial]. (Delay forMilliseconds: 10) wait ]] forkAt: 45 named: '45'. MessageTally tallySends: [10000 timesRepeat: [1.23 printString]] ! !MessageTally methodsFor: 'tallying' stamp: 'jmv 3/4/2009 10:37'! tally: context in: aProcess by: count "Explicitly tally the specified context and its stack." | sender | "Add to this node if appropriate" context method == method ifTrue: [^self bumpBy: count]. "No sender? Add new branch to the tree." (sender := context home sender) ifNil: [ ^ (self bumpBy: count) tallyPath: context in: aProcess by: count]. "Find the node for the sending context (or add it if necessary)" ^ (self tally: sender in: aProcess by: count) tallyPath: context in: aProcess by: count! ! !MessageTally methodsFor: 'comparing' stamp: ''! < aMessageTally "Refer to the comment in Magnitude|<." ^tally > aMessageTally tally! ! !MessageTally methodsFor: 'initialization' stamp: 'Alexandre Bergel 3/15/2010 21:08'! initialize "We do not do a super initialize since it is not strickly necessary and more importantly MessageTally must be instantiated quickly" "super initialize." maxClassNameSize := self class defaultMaxClassNameSize. maxClassPlusSelectorSize := self class defaultMaxClassPlusSelectorSize. maxTabs := self class defaultMaxTabs. reportOtherProcesses := true. time := 0. tally := 0.! ! !MessageTally methodsFor: 'private' stamp: ''! class: aClass method: aMethod class := aClass. method := aMethod. tally := 0. receivers := Array new: 0! ! !MessageTally methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:47'! time "Answer the receiver's run time." ^time! ! !MessageTally methodsFor: 'accessing' stamp: 'Alexandre Bergel 3/5/2010 17:19'! theClass "Return the class of the object receiver related to this tally" ^ class! ! !MessageTally methodsFor: 'printing' stamp: 'jmv 9/24/2009 15:49'! fullPrintOn: aStream threshold: perCent | threshold | threshold := (perCent asFloat / 100 * tally) rounded. aStream nextPutAll: '**Tree**'; cr. self rootPrintOn: aStream total: tally totalTime: time threshold: threshold. aStream nextPut: Character newPage; cr. aStream nextPutAll: '**Leaves**'; cr. self leavesPrintOn: aStream threshold: threshold! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! maxClassNameSize: aNumber maxClassNameSize := aNumber! ! !MessageTally methodsFor: 'tallying' stamp: ''! bumpBy: count tally := tally + count! ! !MessageTally methodsFor: 'tallying' stamp: 'MarcusDenker 1/23/2011 09:15'! tallyPath: context in: aProcess by: count | aMethod path | aMethod := context method. "Find the correct child (if there)" receivers do: [ :oldTally | (oldTally method == aMethod and: [oldTally process == aProcess]) ifTrue: [path := oldTally]]. "Add new child if needed" path ifNil:[ path := self class new class: context receiver class method: aMethod; process: aProcess; reportOtherProcesses: reportOtherProcesses; maxClassNameSize: maxClassNameSize; maxClassPlusSelectorSize: maxClassPlusSelectorSize; maxTabs: maxTabs. receivers := receivers copyWith: path]. ^ path bumpBy: count! ! !MessageTally methodsFor: 'accessing' stamp: 'Alexandre Bergel 3/4/2010 19:19'! reportOtherProcesses ^ reportOtherProcesses! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'! maxClassNameSize ^maxClassNameSize! ! !MessageTally methodsFor: 'collecting leaves' stamp: 'jmv 9/24/2009 16:07'! leavesInto: leafDict fromSender: senderTally | rcvrs | rcvrs := self sonsOver: 0. rcvrs size = 0 ifTrue: [ self into: leafDict fromSender: senderTally ] ifFalse: [ (reportOtherProcesses not and: [ rcvrs anyOne process isNil ]) ifTrue: [ ^self]. rcvrs do: [ :node | node isPrimitives ifTrue: [ node leavesInto: leafDict fromSender: senderTally ] ifFalse: [ node leavesInto: leafDict fromSender: self ]]]! ! !MessageTally methodsFor: 'comparing' stamp: 'MarcusDenker 1/23/2011 09:14'! isPrimitives "Detect pseudo node used to carry tally of local hits" ^ receivers isNil! ! !MessageTally methodsFor: 'tallying' stamp: 'Alexandre Bergel 3/5/2010 17:37'! tally: context by: count "Explicitly tally the specified context and its stack." | sender | "Add to this node if appropriate" context method == method ifTrue: [^self bumpBy: count]. "No sender? Add new branch to the tree." (sender := context home sender) ifNil: [ ^ (self bumpBy: count) tallyPath: context by: count]. "Find the node for the sending context (or add it if necessary)" ^ (self tally: sender by: count) tallyPath: context by: count! ! !MessageTally methodsFor: 'printing' stamp: 'jmv 9/24/2009 15:47'! leavesPrintExactOn: aStream | dict | dict := IdentityDictionary new: 100. self leavesInto: dict fromSender: nil. dict asSortedCollection do: [ :node | node printOn: aStream total: tally totalTime: nil tallyExact: true. node printSenderCountsOn: aStream ]! ! !MessageTally methodsFor: 'accessing' stamp: 'stp 05/08/1999 12:06'! tally "Answer the receiver's number of tally." ^tally! ! !MessageTally methodsFor: 'private' stamp: 'jmv 9/25/2009 08:48'! close Timer ifNotNil: [ Timer terminate ]. Timer := nil. class := method := tally := receivers := nil! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'! maxClassPlusSelectorSize ^maxClassPlusSelectorSize! ! !MessageTally methodsFor: 'collecting leaves' stamp: ''! bump: hitCount tally := tally + hitCount! ! !MessageTally methodsFor: 'printing' stamp: 'jmv 9/24/2009 15:49'! fullPrintExactOn: aStream aStream nextPutAll: '**Tree**'; cr. self treePrintOn: aStream tabs: OrderedCollection new thisTab: '' total: tally totalTime: time tallyExact: true orThreshold: nil. aStream nextPut: Character newPage; cr. aStream nextPutAll: '**Leaves**'; cr. self leavesPrintExactOn: aStream! ! !MessageTally methodsFor: 'private' stamp: 'MarcusDenker 1/23/2011 09:15'! copyWithTally: hitCount ^ (self class new class: class method: method) reportOtherProcesses: reportOtherProcesses; process: process; bump: hitCount! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'! maxTabs ^maxTabs! ! !MessageTally methodsFor: 'initialize-release' stamp: 'MarcusDenker 3/22/2013 12:57'! spyAllEvery: millisecs on: aBlock "Create a spy and spy on the given block at the specified rate." "Spy all the system processes" | myDelay time0 | aBlock isBlock ifFalse: [ self error: 'spy needs a block here' ]. self class: aBlock receiver class method: aBlock method. "set up the probe" myDelay := Delay forMilliseconds: millisecs. time0 := Time millisecondClockValue. gcStats := Smalltalk vm getParameters. Timer ifNotNil: [ self error: 'it seems a tally is already running' ]. Timer := [ [true] whileTrue: [ | startTime observedProcess | startTime := Time millisecondClockValue. myDelay wait. observedProcess := Processor preemptedProcess. self tally: observedProcess suspendedContext in: observedProcess "tally can be > 1 if ran a long primitive" by: (Time millisecondClockValue - startTime) // millisecs]. nil] newProcess. Timer priority: Processor timingPriority-1. "activate the probe and evaluate the block" Timer resume. ^ aBlock ensure: [ "cancel the probe and return the value" "Could have already been terminated. See #terminateTimerProcess" Timer ifNotNil: [ Timer terminate. Timer := nil ]. "Collect gc statistics" Smalltalk vm getParameters keysAndValuesDo: [ :idx :gcVal | gcVal isNumber ifTrue: [ gcStats at: idx put: (gcVal - (gcStats at: idx))]]. time := Time millisecondClockValue - time0]! ! !MessageTally methodsFor: 'comparing' stamp: 'StephaneDucasse 1/29/2013 13:16'! sonsOver: threshold "Returns all the sons that are not below a certain threshold. threshold is a number." | hereTally sons | (receivers isNil or: [ receivers size = 0 ]) ifTrue: [ ^#() ]. hereTally := tally. sons := receivers select: [ :son | "subtract subNode tallies for primitive hits here" hereTally := hereTally - son tally. son tally > threshold ]. hereTally > threshold ifTrue: [ | last | last := self class new class: class method: method. last process: process. last reportOtherProcesses: reportOtherProcesses. ^sons copyWith: (last primitives: hereTally)]. ^sons! ! !MessageTally methodsFor: 'printing' stamp: 'ClementBera 7/26/2013 16:52'! printOn: aStream total: total totalTime: totalTime tallyExact: isExact isExact ifTrue: [ | myTally | myTally := tally. receivers == nil ifFalse: [receivers do: [:r | myTally := myTally - r tally]]. aStream print: myTally; space] ifFalse: [ | percentage | percentage := tally asFloat / total * 100.0. aStream nextPutAll: (percentage printShowingDecimalPlaces: 1); nextPutAll: '% {'; print: (percentage * totalTime / 100) rounded; nextPutAll: 'ms} ']. receivers ifNil: [ aStream nextPutAll: 'primitives'; cr] ifNotNil: [ | className aSelector aClass | aSelector := method selector. aClass := method methodClass. className := aClass name contractTo: self maxClassNameSize. aStream nextPutAll: class name; nextPutAll: (aClass = class ifTrue: ['>>'] ifFalse: ['(' , aClass name , ')>>']); nextPutAll: (aSelector contractTo: self maxClassPlusSelectorSize - className size); cr]! ! !MessageTally methodsFor: 'printing' stamp: 'MarcusDenker 9/24/2013 14:12'! treePrintOn: aStream tabs: tabs thisTab: myTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold | sons sonTab | tabs do: [:tab | aStream nextPutAll: tab]. tabs size > 0 ifTrue: [self printOn: aStream total: total totalTime: totalTime tallyExact: isExact]. sons := isExact ifTrue: [receivers] ifFalse: [self sonsOver: threshold]. sons isEmpty ifFalse: [tabs addLast: myTab. sons := sons asSortedCollection. 1 to: sons size do: [:i | sonTab := i < sons size ifTrue: [' |'] ifFalse: [' ']. (sons at: i) treePrintOn: aStream tabs: (tabs size < self maxTabs ifTrue: [tabs] ifFalse: [(tabs select: [:x | x = '[']) copyWith: '[']) thisTab: sonTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold]. tabs removeLast]! ! !MessageTally methodsFor: 'printing' stamp: 'LucFabresse 10/1/2010 15:40'! printOn: aStream | aSelector className aClass | (class isNil or: [method isNil]) ifTrue: [^super printOn: aStream]. aSelector := method selector. className := method methodClass name. aStream nextPutAll: (aClass name contractTo: self maxClassNameSize); nextPutAll: '('; nextPutAll: (className contractTo: self maxClassNameSize); nextPutAll: ')'; nextPutAll: ' >> '; nextPutAll: (aSelector contractTo: self maxClassPlusSelectorSize - className size)! ! !MessageTally methodsFor: 'collecting leaves' stamp: 'MarcusDenker 1/23/2011 09:13'! bump: hitCount fromSender: senderTally "Add this hitCount to the total, and include a reference to the sender responsible for the increment" self bump: hitCount. senders ifNil: [senders := OrderedCollection new]. senderTally ifNotNil: [senders add: (senderTally copyWithTally: hitCount)]! ! !MessageTally methodsFor: 'reporting' stamp: 'jmv 9/24/2009 15:35'! report: strm cutoff: threshold tally = 0 ifTrue: [strm nextPutAll: ' - no tallies obtained'] ifFalse: [strm nextPutAll: ' - '; print: tally; nextPutAll: ' tallies, ', time printString, ' msec.'; cr; cr. self fullPrintOn: strm threshold: threshold]. time isZero ifFalse: [self reportGCStatsOn: strm].! ! !MessageTally methodsFor: 'accessing' stamp: 'ar 3/3/2009 19:29'! process: aProcess process := aProcess! ! !MessageTally methodsFor: 'reporting' stamp: 'jmv 3/4/2009 09:27'! report: strm "Print a report, with cutoff percentage of each element of the tree (leaves, roots, tree), on the stream, strm." self report: strm cutoff: 1! ! !MessageTally methodsFor: 'reporting' stamp: 'CamilloBruni 10/21/2012 15:08'! reportGCStatsOn: str | oldSpaceEnd youngSpaceEnd memoryEnd fullGCs fullGCTime incrGCs incrGCTime tenureCount upTime rootOverflows | upTime := time. oldSpaceEnd := gcStats at: 1. youngSpaceEnd := gcStats at: 2. memoryEnd := gcStats at: 3. fullGCs := gcStats at: 7. fullGCTime := gcStats at: 8. incrGCs := gcStats at: 9. incrGCTime := gcStats at: 10. tenureCount := gcStats at: 11. rootOverflows := gcStats at: 22. str cr. str nextPutAll: '**Memory**'; cr. str nextPutAll: ' old '. oldSpaceEnd printWithCommasSignedOn: str. str nextPutAll: ' bytes'; cr. str nextPutAll: ' young '. (youngSpaceEnd - oldSpaceEnd) printWithCommasSignedOn: str. str nextPutAll: ' bytes'; cr. str nextPutAll: ' used '. youngSpaceEnd printWithCommasSignedOn: str. str nextPutAll: ' bytes'; cr. str nextPutAll: ' free '. (memoryEnd - youngSpaceEnd) printWithCommasSignedOn: str. str nextPutAll: ' bytes'; cr. str cr. str nextPutAll: '**GCs**'; cr. str nextPutAll: ' full '; print: fullGCs; nextPutAll: ' totalling '. fullGCTime printWithCommasOn: str. str nextPutAll: 'ms ('; print: ((fullGCTime / upTime * 100) roundTo: 1.0); nextPutAll: '% uptime)'. fullGCs = 0 ifFalse: [str nextPutAll: ', avg '; print: ((fullGCTime / fullGCs) roundTo: 1.0); nextPutAll: 'ms']. str cr. str nextPutAll: ' incr '; print: incrGCs; nextPutAll: ' totalling '. incrGCTime printWithCommasOn: str. str nextPutAll: 'ms ('; print: ((incrGCTime / upTime * 100) roundTo: 1.0); nextPutAll: '% uptime)'. incrGCs = 0 ifFalse: [str nextPutAll:', avg '; print: ((incrGCTime / incrGCs) roundTo: 1.0); nextPutAll: 'ms']. str cr. str nextPutAll: ' tenures '. tenureCount printWithCommasOn: str. tenureCount = 0 ifFalse: [str nextPutAll: ' (avg '; print: (incrGCs / tenureCount) asInteger; nextPutAll: ' GCs/tenure)']. str cr. str nextPutAll: ' root table '. rootOverflows printWithCommasOn: str. str nextPutAll:' overflows'. str cr. ! ! !MessageTally methodsFor: 'comparing' stamp: 'jmv 8/20/2009 08:20'! hash "Hash is reimplemented because = is implemented." ^method hash! ! !MessageTally methodsFor: 'comparing' stamp: ''! > aMessageTally "Refer to the comment in Magnitude|>." ^tally < aMessageTally tally! ! !MessageTally methodsFor: 'initialize-release' stamp: 'MarcusDenker 2/23/2013 10:15'! spyEvery: millisecs on: aBlock "Create a spy and spy on the given block at the specified rate." "Spy only on the active process (in which aBlock is run)" | myDelay time0 observedProcess | aBlock isBlock ifFalse: [ self error: 'spy needs a block here' ]. self class: aBlock receiver class method: aBlock method. "set up the probe" observedProcess := Processor activeProcess. myDelay := Delay forMilliseconds: millisecs. time0 := Time millisecondClockValue. gcStats := Smalltalk vm getParameters. Timer ifNotNil: [ self error: 'it seems a tally is already running' ]. Timer := [ [ true ] whileTrue: [ | startTime | startTime := Time millisecondClockValue. myDelay wait. self tally: Processor preemptedProcess suspendedContext in: (observedProcess == Processor preemptedProcess ifTrue: [observedProcess] ifFalse: [nil]) "tally can be > 1 if ran a long primitive" by: (Time millisecondClockValue - startTime) // millisecs]. nil] newProcess. Timer priority: Processor timingPriority-1. "activate the probe and evaluate the block" Timer resume. ^ aBlock ensure: [ "cancel the probe and return the value" "Could have already been terminated. See #terminateTimerProcess" Timer ifNotNil: [ Timer terminate. Timer := nil ]. "Collect gc statistics" Smalltalk vm getParameters keysAndValuesDo: [ :idx :gcVal | gcVal isNumber ifTrue: [ gcStats at: idx put: (gcVal - (gcStats at: idx))]]. time := Time millisecondClockValue - time0]! ! !MessageTally methodsFor: 'accessing' stamp: 'Alexandre Bergel 3/5/2010 17:18'! method "Return the compiled method associated to this tally" ^method! ! !MessageTally methodsFor: 'initialize-release' stamp: 'MarcusDenker 3/22/2013 12:57'! spyEvery: millisecs onProcess: aProcess forMilliseconds: msecDuration "Create a spy and spy on the given process at the specified rate." | myDelay time0 endTime observedProcess sem | (aProcess isKindOf: Process) ifFalse: [self error: 'spy needs a Process here']. self class: aProcess suspendedContext receiver class method: aProcess suspendedContext method. "set up the probe" observedProcess := aProcess. myDelay := Delay forMilliseconds: millisecs. time0 := Time millisecondClockValue. endTime := time0 + msecDuration. sem := Semaphore new. gcStats := Smalltalk vm getParameters. Timer ifNotNil: [ self error: 'it seems a tally is already running' ]. Timer := [ [ | startTime | startTime := Time millisecondClockValue. myDelay wait. self tally: Processor preemptedProcess suspendedContext in: (observedProcess == Processor preemptedProcess ifTrue: [ observedProcess ] ifFalse: [nil]) "tally can be > 1 if ran a long primitive" by: (Time millisecondClockValue - startTime) // millisecs. startTime < endTime ] whileTrue. sem signal. ] newProcess. Timer priority: Processor timingPriority-1. "activate the probe and evaluate the block" Timer resume. "activate the probe and wait for it to finish" sem wait. "Collect gc statistics" Smalltalk vm getParameters keysAndValuesDo: [ :idx :gcVal | gcVal isNumber ifTrue: [ gcStats at: idx put: (gcVal - (gcStats at: idx)) ] ]. time := Time millisecondClockValue - time0! ! !MessageTally methodsFor: 'comparing' stamp: 'Alexandre Bergel 3/5/2010 17:17'! = aMessageTally self species == aMessageTally species ifFalse: [^ false]. ^ aMessageTally method == method and: [ aMessageTally process == process ]! ! !MessageTally methodsFor: 'private' stamp: ''! primitives: anInteger tally := anInteger. receivers := nil! ! !MessageTally methodsFor: 'collecting leaves' stamp: 'MarcusDenker 1/23/2011 09:15'! into: leafDict fromSender: senderTally | leafNode | leafNode := leafDict at: method ifAbsentPut: [ (self class new class: class method: method) process: process; reportOtherProcesses: reportOtherProcesses ]. leafNode bump: tally fromSender: senderTally! ! !MessageTally methodsFor: 'printing' stamp: 'jmv 2/6/2010 10:09'! printSenderCountsOn: aStream | mergedSenders | mergedSenders := IdentityDictionary new. senders do: [ :node | | mergedNode | mergedNode := mergedSenders at: node method ifAbsent: [ nil ]. mergedNode ifNil: [ mergedSenders at: node method put: node ] ifNotNil: [ mergedNode bump: node tally ]]. mergedSenders asSortedCollection do: [ :node | 10 to: node tally printString size by: -1 do: [ :i | aStream space]. node printOn: aStream total: tally totalTime: nil tallyExact: true]! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! maxClassPlusSelectorSize: aNumber maxClassPlusSelectorSize := aNumber! ! !MessageTally methodsFor: 'accessing' stamp: 'jmv 9/24/2009 16:02'! reportOtherProcesses: aBoolean reportOtherProcesses := aBoolean! ! !MessageTally methodsFor: 'accessing' stamp: 'Alexandre Bergel 3/15/2010 21:02'! receivers ^ receivers ! ! !MessageTally methodsFor: 'tallying' stamp: 'MarcusDenker 1/23/2011 09:15'! tallyPath: context by: count | aMethod path | aMethod := context method. "Find the correct child (if there)" receivers do: [ :oldTally | oldTally method == aMethod ifTrue: [path := oldTally]]. "Add new child if needed" path ifNil: [ path := self class new class: context receiver class method: aMethod. path reportOtherProcesses: reportOtherProcesses. receivers := receivers copyWith: path]. ^ path bumpBy: count! ! !MessageTally methodsFor: 'printing' stamp: 'jmv 9/24/2009 15:48'! leavesPrintOn: aStream threshold: threshold | dict | dict := IdentityDictionary new: 100. self leavesInto: dict fromSender: nil. (dict asOrderedCollection select: [:node | node tally > threshold]) asSortedCollection do: [:node | node printOn: aStream total: tally totalTime: time tallyExact: false ]! ! !MessageTally methodsFor: 'printing' stamp: 'jmv 2/6/2010 10:19'! rootPrintOn: aStream total: total totalTime: totalTime threshold: threshold | groups | groups := (self sonsOver: threshold) groupBy: [ :aTally | aTally process] having: [ :g | true ]. groups do: [ :g | | sons p | sons := g asArray sort. p := g anyOne process. (reportOtherProcesses or: [ p notNil ]) ifTrue: [ aStream nextPutAll: '--------------------------------'; cr. aStream nextPutAll: 'Process: ', (p ifNil: [ 'other processes'] ifNotNil: [ p browserPrintString]); cr. aStream nextPutAll: '--------------------------------'; cr. sons do: [ :son | son treePrintOn: aStream tabs: OrderedCollection new thisTab: '' total: total totalTime: totalTime tallyExact: false orThreshold: threshold]]. ]! ! !MessageTally methodsFor: 'accessing' stamp: 'Alexandre Bergel 3/5/2010 17:19'! process "Return the profiled process" ^process! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! maxTabs: aNumber maxTabs := aNumber! ! !MessageTally class methodsFor: 'spying' stamp: 'jmv 9/24/2009 15:59'! spyOn: aBlock " Spy on aBlock, in the current process. Can include or not statistics on other processes in the report. [1000 timesRepeat: [ 100 timesRepeat: [120 factorial]. (Delay forMilliseconds: 10) wait ]] forkAt: 45 named: '45'. MessageTally spyOn: [10000 timesRepeat: [1.23 printString]] " ^self spyOn: aBlock reportOtherProcesses: false! ! !MessageTally class methodsFor: 'spying' stamp: 'Alexandre Bergel 3/16/2010 15:23'! spyOn: aBlock reportOtherProcesses: aBoolean " Spy on aBlock, in the current process. Can include or not statistics on other processes in the report. [1000 timesRepeat: [ 100 timesRepeat: [120 factorial]. (Delay forMilliseconds: 10) wait ]] forkAt: 45 named: '45'. MessageTally spyOn: [10000 timesRepeat: [1.23 printString]] reportOtherProcesses: true " ^ self spyOn: aBlock reportOtherProcesses: aBoolean cutoff: 1! ! !MessageTally class methodsFor: 'public' stamp: 'jmv 9/24/2009 16:02'! spyOn: aBlock toFileNamed: fileName reportOtherProcesses: aBoolean "Spy on the evaluation of aBlock. Write the data collected on a file named fileName." | file value node | node := self new. node reportOtherProcesses: aBoolean. value := node spyEvery: self defaultPollPeriod on: aBlock. file := FileStream newFileNamed: fileName. node report: file; close. file close. ^value! ! !MessageTally class methodsFor: 'spying' stamp: 'Alexandre Bergel 3/16/2010 15:23'! spyAllOn: aBlock "Spy on all the processes in the system [1000 timesRepeat: [3.14159 printString. Processor yield]] fork. [1000 timesRepeat: [20 factorial. Processor yield]] fork. [1000 timesRepeat: [20 factorial. Processor yield]] fork. MessageTally spyAllOn: [ (Delay forMilliseconds: 100) wait] " ^ self spyAllOn: aBlock cutoff: 1! ! !MessageTally class methodsFor: 'public' stamp: 'Alexandre Bergel 3/5/2010 17:41'! tallySends: aBlock " MessageTally tallySends: [3.14159 printString] " "This method uses the simulator to count the number of calls on each method invoked in evaluating aBlock. If receiver is not nil, then only sends to that receiver are tallied. Results are presented as leaves, sorted by frequency, preceded, optionally, by the whole tree." ^ self tallySendsTo: nil inBlock: aBlock showTree: true! ! !MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:41'! defaultPollPeriod "Answer the number of milliseconds between interrupts for spyOn: and friends. This should be faster for faster machines." ^DefaultPollPeriod ifNil: [ DefaultPollPeriod := 1 ]! ! !MessageTally class methodsFor: 'defaults' stamp: 'jmv 3/2/2009 12:32'! defaultMaxTabs "Return the default number of tabs after which leading white space is compressed" ^120! ! !MessageTally class methodsFor: 'spying' stamp: 'MarcusDenker 1/23/2011 09:09'! spyOn: aBlock reportOtherProcesses: aBoolean cutoff: aNumber openResultWindow: openResultWindow closeAfter: closeAfter | node | node := self new. node reportOtherProcesses: aBoolean. node spyEvery: self defaultPollPeriod on: aBlock. openResultWindow ifTrue: [ (CodeHolder new contents: (String streamContents: [:s | node report: s cutoff: aNumber])) openLabel: 'Spy Results' wrap: false ]. closeAfter ifTrue: [ node close ]. ^ node ! ! !MessageTally class methodsFor: 'spying' stamp: 'jmv 2/19/2010 14:41'! spyOnProcess: aProcess forMilliseconds: msecDuration reportOtherProcesses: aBoolean " Spy on aProcess for a certain amount of time | p1 p2 | p1 := [100000 timesRepeat: [3.14159 printString. Processor yield]] newProcess. p2 := [100000 timesRepeat: [3.14159 printString. Processor yield]] newProcess. p1 resume. p2 resume. (Delay forMilliseconds: 100) wait. MessageTally spyOnProcess: p1 forMilliseconds: 1000 reportOtherProcesses: true " | node | node := self new. node reportOtherProcesses: aBoolean. node spyEvery: self defaultPollPeriod onProcess: aProcess forMilliseconds: msecDuration. (CodeHolder new contents: (String streamContents: [:s | node report: s])) openLabel: 'Spy Results' wrap: false! ! !MessageTally class methodsFor: 'spying' stamp: ''! time: aBlock ^ Time millisecondsToRun: aBlock! ! !MessageTally class methodsFor: 'spying' stamp: 'Alexandre Bergel 3/16/2010 15:24'! spyOn: aBlock reportOtherProcesses: aBoolean cutoff: aNumber " Spy on aBlock, in the current process. Can include or not statistics on other processes in the report. [1000 timesRepeat: [ 100 timesRepeat: [120 factorial]. (Delay forMilliseconds: 10) wait ]] forkAt: 45 named: '45'. MessageTally spyOn: [10000 timesRepeat: [1.23 printString]] reportOtherProcesses: true " ^ self spyOn: aBlock reportOtherProcesses: aBoolean cutoff: aNumber openResultWindow: true closeAfter: true! ! !MessageTally class methodsFor: 'spying' stamp: 'ClementBera 7/26/2013 16:18'! tallySendsTo: receiver inBlock: aBlock showTree: treeOption closeAfter: closeAfter openResultWindow: openResultWindow " MessageTally tallySends: [3.14159 printString] " "This method uses the simulator to count the number of calls on each method invoked in evaluating aBlock. If receiver is not nil, then only sends to that receiver are tallied. Results are presented as leaves, sorted by frequency, preceded, optionally, by the whole tree." | prev tallies startTime totalTime | startTime := Time millisecondClockValue. tallies := self new class: aBlock receiver class method: aBlock method. tallies reportOtherProcesses: true. "Do NOT filter nodes with nil process" prev := aBlock. thisContext sender runSimulated: aBlock contextAtEachStep: [:current | current == prev ifFalse: ["call or return" prev sender ifNotNil: ["call only" (receiver isNil or: [current receiver == receiver]) ifTrue: [tallies tally: current by: 1]]. prev := current]]. totalTime := Time millisecondClockValue - startTime // 1000.0 roundTo: 0.01. openResultWindow ifTrue: [ (CodeHolder new contents: (String streamContents: [:s | s nextPutAll: 'This simulation took ' , totalTime printString , ' seconds.'; cr. treeOption ifTrue: [ tallies fullPrintExactOn: s ] ifFalse: [ tallies leavesPrintExactOn: s ]. ])) openLabel: 'Spy Results' wrap: false ]. closeAfter ifTrue: [ tallies close ]. ^ tallies! ! !MessageTally class methodsFor: 'spying' stamp: 'Alexandre Bergel 3/16/2010 15:21'! spyOn: aBlock reportOtherProcesses: aBoolean cutoff: aNumber openResultWindow: openResultWindow ^ self spyOn: aBlock reportOtherProcesses: aBoolean cutoff: aNumber openResultWindow: openResultWindow closeAfter: true! ! !MessageTally class methodsFor: 'spying' stamp: 'jmv 2/19/2010 14:41'! spyOnProcess: aProcess forMilliseconds: msecDuration toFileNamed: fileName reportOtherProcesses: aBoolean "Spy on the evaluation of aProcess. Write the data collected on a file named fileName. Will overwrite fileName" | file node | node := self new. node reportOtherProcesses: aBoolean. node spyEvery: self defaultPollPeriod onProcess: aProcess forMilliseconds: msecDuration. file := FileStream fileNamed: fileName. node report: file. file close! ! !MessageTally class methodsFor: 'spying' stamp: 'Alexandre Bergel 3/16/2010 15:21'! spyOnProcess: aProcess forMilliseconds: msecDuration ^self spyOnProcess: aProcess forMilliseconds: msecDuration reportOtherProcesses: false ! ! !MessageTally class methodsFor: 'defaults' stamp: 'StephaneDucasse 11/11/2010 22:29'! defaultMaxClassPlusSelectorSize "Return the default maximum width of the class plus selector together (not counting the '>>')" ^100! ! !MessageTally class methodsFor: 'spying' stamp: 'Alexandre Bergel 3/4/2010 18:47'! tallySendsTo: receiver inBlock: aBlock showTree: treeOption ^ self tallySendsTo: receiver inBlock: aBlock showTree: treeOption closeAfter: true! ! !MessageTally class methodsFor: 'defaults' stamp: 'StephaneDucasse 11/11/2010 22:29'! defaultMaxClassNameSize "Return the default maximum width of the class name alone" ^50! ! !MessageTally class methodsFor: 'private' stamp: 'jmv 2/19/2010 14:43'! terminateTimerProcess Timer ifNotNil: [ Timer terminate ]. Timer := nil! ! !MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:41'! defaultPollPeriod: numberOfMilliseconds "Set the default number of milliseconds between interrupts for spyOn: and friends. This should be faster for faster machines." DefaultPollPeriod := numberOfMilliseconds! ! !MessageTally class methodsFor: 'spying' stamp: 'Alexandre Bergel 3/16/2010 15:20'! spyOn: aBlock cutoff: aNumber ^self spyOn: aBlock reportOtherProcesses: false cutoff: aNumber! ! !MessageTally class methodsFor: 'spying' stamp: 'Alexandre Bergel 3/5/2010 17:41'! tallySendsTo: receiver inBlock: aBlock showTree: treeOption closeAfter: closeAfter ^ self tallySendsTo: receiver inBlock: aBlock showTree: treeOption closeAfter: closeAfter openResultWindow: true! ! !MessageTally class methodsFor: 'spying' stamp: 'Alexandre Bergel 3/16/2010 15:19'! spyAllOn: aBlock cutoff: aNumber | node result | node := self new. node reportOtherProcesses: true. "Irrelevant in this case. All processes will be reported on their own." result := node spyAllEvery: self defaultPollPeriod on: aBlock. (CodeHolder new contents: (String streamContents: [:s | node report: s cutoff: aNumber; close])) openLabel: 'Spy Results' wrap: false. ^ result! ! !MessageTallyTest commentStamp: 'TorstenBergmann 2/4/2014 20:46'! SUnit tests for MessageTally! !MessageTallyTest methodsFor: 'tallying' stamp: 'Alexandre Bergel 3/5/2010 17:29'! testTallyShouldNotContainsAReturn "The block passed to MessageTally should not have a ^ " self should: [ MessageTally tallySendsTo: nil inBlock: [ ^ 3.14159 printString ] showTree: true closeAfter: false openResultWindow: false ] raise: Error. ! ! !MessageTallyTest methodsFor: 'tallying' stamp: 'MarcusDenker 12/8/2011 15:34'! testTallySends " self debug: #testTallySends " | tally thisMethod activeProcess allProcesses numberOfProcesses processUsedByTally tallyForPrintString tallyForPrintStringBase tallyForSmallIntegerStar | allProcesses := Process allInstances. numberOfProcesses := allProcesses size. tally := MessageTally tallySendsTo: nil inBlock: [ 3.14159 printString ] showTree: true closeAfter: false openResultWindow: false. "tally is for this test method" thisMethod := self class >> #testTallySends. self assert: (tally hash = thisMethod hash). self assert: (tally method == thisMethod). self assert: (tally theClass == self class). processUsedByTally := tally process. self deny: (allProcesses includes: processUsedByTally). "Below is specialized for the execution ' 3.14159 printString '. Any method change in the execution flow of printString will turn this test to yellow" self assert: (tally tally >= 50). "The tally is not close, therefore the tree may be crawled over" self assert: (tally receivers isArray). self assert: (tally receivers size = 2). "--------" tallyForPrintString := tally receivers second. "Since 3.14159 is a float" self assert: (tallyForPrintString theClass == Float). "the executed method is Number>>printString" self assert: (tallyForPrintString method == ( Number>>#printString)). self assert: (tallyForPrintString tally >= 50). "--------" tallyForPrintStringBase := tallyForPrintString receivers first. "The receiver is still a Float" self assert: (tallyForPrintString theClass == Float). "the executed method is Number>>printStringBase: this time" self assert: (tallyForPrintStringBase method == ( Number>>#printStringBase:)). self assert: (tallyForPrintStringBase tally >= 50). "The method printStringBase: calls two methods: SequenceableCollection class >> streamContents: and Float >> printOn:base:" self assert: (tallyForPrintStringBase receivers size = 2). "streamContents: is been tallied 13 times and printOn:base: 59 times" self assert: (tallyForPrintStringBase receivers size = 2). self assert: (tallyForPrintStringBase receivers first tally) = 13. self assert: (tallyForPrintStringBase receivers second tally) >= 50. "We close to explicitely release reference of the process, the class and methods" tally close. ! ! !MessageTallyTest methodsFor: 'basic' stamp: 'Alexandre Bergel 3/4/2010 18:44'! testInstantiation | messageTally | messageTally := MessageTally new. self assert: (messageTally time = 0). self assert: (messageTally tally = 0)! ! !MessageTallyTest methodsFor: 'sampling' stamp: 'Alexandre Bergel 3/15/2010 21:03'! testSampling1 | tally | tally := MessageTally spyOn: [ 1000 timesRepeat: [ 3.14159 printString ] ] reportOtherProcesses: false cutoff: 1 openResultWindow: false closeAfter: false. "No process is accessible from the tally, the reason is that using the sampling method execute the block in the current process" self assert: (tally process isNil). ! ! !MessageTallyTest methodsFor: 'tallying' stamp: 'Alexandre Bergel 3/5/2010 17:53'! testClosedTally | tally | tally := MessageTally tallySendsTo: nil inBlock: [ 3.14159 printString ] showTree: true closeAfter: true openResultWindow: false. "The tally is closed, therefore nothing may be accessed" self assert: (tally receivers isNil)! ! !Metacello commentStamp: 'dkh 7/28/2012 20:04'! # Metacello User Guide In this guide we'll take a walk through a couple of common development scenarios and highlight some of the features of the *Metacello Scripting API*. *For installatation and more detailed documentation on the Metacello Scripting API, see the [Metcello Scripting API Documentation][1].* ## Introduction The number one job of the *Metacello Scripting API* is to simplify the job of loading projects into your image. As you are probably all too aware, today it's a two step process where you first load the configuration into your image using [Gofer][2] and then load your project using Metacello: ```Smalltalk Gofer new package: 'ConfigurationOfSeaside30'; squeaksource: 'MetacelloRepository'; load. ((Smalltalk at: #ConfigurationOfSeaside30) version: #stable) load. ``` In the early days of Metacello (and Gofer) this was a great improvement over the alternatives, but today, 3 years after the introduction of Metacello, there should be a better way...and there is. Using the *Metacello Scripting API* the above expression reduces to the following: ```Smalltalk Metacello new configuration: 'Seaside30'; load. ``` ## Loading In this example of the [`load` command][5] we are leveraging a couple of default values, namely the `version` of the project and the `repository` where the **ConfigurationOfSeaside** package can be found: ```Smalltalk Metacello new configuration: 'Seaside30'; load. ``` Here is a variant of the same expression with the (current) default values explicitly specified: ```Smalltalk Metacello new configuration: 'Seaside30'; version: #stable; squeaksource: 'MetacelloRepository'; load. ``` The `version` attribute can be any legal [version number][10]. `squeaksource` is a [repository shortcut][4]. You can also specify the full [repository description][3] as follows: ```Smalltalk Metacello new configuration: 'Seaside30'; version: #stable; repository: 'http://www.squeaksource.com/MetacelloRepository'; load. ``` ##Listing Once you've loaded one or more projects into your image, you may want to list them. The following is an example of the [`list` command][6]: ```Smalltalk Metacello image configuration: [:spec | true ]; list. ``` The `image` message tells Metacello that you'd like to look at only loaded configurations. The *block* argument to the `configuration:` message is used to *select* against the list of loaded [MetacelloProjectSpec][7] instances in the [registry][8]. The `list` command itself returns a list of [MetacelloProjectSpec][7] instances that can be printed, inspected or otherwise manipulated. In addition to a *select block*, you can specify a *select collection* specifying the names of the projects you'd like to select: ```Smalltalk Metacello registry configuration: #('Seaside30' 'MetacelloPreview'); list. ``` The `registry` message tells Metacello that you'd like to look at all projects in the [registry][8] whether or not they are loaded. The *collection* argument to the `configuration:` message is used to *select* against the list of project names in the [registry][8]. The `list` command can also be used to look at configurations in Monticello repositories. For example: ```Smalltalk Metacello new configuration: [:spec | spec name beginsWith: 'Seaside']; squeaksource: 'MetacelloRepository'; list. ``` lists the configurations whose names (sans the `ConfigurationOf`) begin with `Seaside` in the `MetacelloRepositry` in the [Squeaksource](http://www.squeaksource.com) repostory. ## Getting Once you've loaded a project into your image the next logical step is upgrading your project to a new version. Let's say that a new `#stable` version of Seaside30 has been released and that you want to upgrade. This is a two step process: * [get a new version of the configuration][11] * [load the new version][12] ### Get a new version of the configuration The following expression gets the latest version of the configuration: ```Smalltalk Metacello image configuration: 'Seaside30'; get. ``` By using the `image` message, you can leverage the fact that the [registry][8] remembers from which repository you loaded the original version of the configuration. The `get` command simply downloads the latest version of the configuration package from the repository. You may download the configuration from a different repository: ```Smalltalk Metacello image configuration: 'Seaside30'; squeaksource: 'Seaside30; get. ``` The `get` command will update the [registry][8] with the new repository location information. You may also use the `get` command to load a configuration for a project into your image without actually loading the project itself: ```Smalltalk Metacello image configuration: 'SeasideRest'; squeaksource: 'Seaside30'; get. ``` The 'SeasideRest' project information will be registered in the [registry][8] and marked as *unloaded*. ### Load the new version Once you've got a new copy of the Seaside30 configuration loaded into your image, you may upgrade your image with the following expression: ```Smalltalk Metacello image configuration: 'Seaside30'; version: #stable; load. ``` By using the `image` message, you are asking Metacello to look the project up in the [registry][8] before performing the operation, so it isn't necessary to supply all of the project details for every command operation. Of course, the `load` command updates the [registry][8]. If you want to load a project for which you've already done a `get` (like the SeasideRest project earlier), you can do the following: ```Smalltalk Metacello registry configuration: 'SeasideRest'; version: #stable; load. ``` In this case you use the `registry` message to indicate that you are interested in both *loaded* and *unloaded* projects. ##Locking Let's say that you are using an older version of Seaside30 (say 3.0.5) instead of the #stable version (3.0.7) and that your application doesn't work with newer versions of Seaside30 (you've tried and it's more work to get you application to work with the newer version of Seaside30 than it's worth). Let's also say that you want to try out something in the SeasideRest project, but when you try loading SeasideRest, you end up having Seaside 3.0.7 loaded as well. This is an unfortunate side effect of Metacello trying to *do the right thing*, only in your case it is the wrong thing. Fortunately, the [`lock` command][9] can give you control. First you need to `lock` the Seaside30 project: ```Smalltalk Metacello image configuration: 'Seaside30'; lock. ``` The `image` message tells Metacello to do a lookup in the list of loaded projects and then to put a lock on the loaded version of the project. If you want you can specify which version of the project you want locked: ```Smalltalk Metacello image configuration: 'Seaside30'; version: '3.0.5'; lock. ``` After a project is locked an error (**MetacelloLockedProjectError**) is thrown when you attempt to load a project that has a dependency upon a different version of Seaside30. The error is thrown before any packages are actually loaded. ### Bypassing locks Let's say that you want to load the SeasideRest project even though it may require a version of Seaside30 that is later than the version that you have locked. To do that you need to suppress the upgrade of the Seaside30 project during the load of the SeasideRest project and you can do that with the use of the `onUpgrade:` message: ```Smalltalk Metacello new configuration: 'SeasideRest'; version: #stable; onUpgrade: [:ex :existing :new | existing baseName = 'Seaside30' ifTrue: [ ex disallow ]. ex pass ]; load. ``` The `onUpgrade:` block tells Metacello to disallow the upgrade of any project whose `baseName` is `Seaside30` and to continue with the load. Of course if there are any explicit dependencies between SeasideRest and the later version of Seaside30 (missing classes, etc.) then you may very well get load errors or errors while using the SeasideRest, but that's the price you pay for not upgrading. ### Upgrading a locked project If you want to explicitly upgrade a locked project, you can use the `load` command. The following command will upgrade Seaside30 to version 3.0.6 even if it is locked: ```Smalltalk Metacello image configuration: 'Seaside30'; version: '3.0.6'; lock. ``` The newly loaded of the project will continue to be locked. [1]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md [2]: http://www.lukas-renggli.ch/blog/gofer [3]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#repository-descriptions [4]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#repository-shortcuts [5]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#loading [6]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#listing [7]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#metacelloprojectspec [8]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#metacello-project-registry [9]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#locking [10]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloScriptingAPI.md#metacello-version-numbers [11]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloUserGuide.md#get-a-new-version-of-the-configuration [12]: https://github.com/dalehenrich/metacello-work/blob/master/docs/MetacelloUserGuide.md#load-the-new-version! !Metacello methodsFor: 'api options' stamp: 'dkh 6/13/2012 16:05'! ignoreImage "ignore image state" self addStatement: #'ignoreImage:' args: {true}! ! !Metacello methodsFor: 'api options' stamp: 'dkh 07/24/2013 15:22'! onWarning: aBlock self addStatement: #'onWarning:' args: {aBlock}! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 7/17/2012 16:50'! squeaksource: projectName self repository: 'http://www.squeaksource.com/' , projectName! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 7/17/2012 16:46'! ss3: projectName self squeaksource3: projectName! ! !Metacello methodsFor: 'api projectSpec' stamp: 'dkh 7/12/2012 13:46'! configuration: projectName self addStatement: #'configurationArg:' args: {projectName}! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 07/25/2013 15:17'! squeaksource3: projectName self repository: 'http://ss3.gemtalksystems.com/ss/' , projectName! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 7/17/2012 16:48'! impara: projectName self repository: 'http://source.impara.de/' , projectName! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 07/25/2013 15:21'! filetreeDirectory: directoryName self repository: 'filetree://' , directoryName! ! !Metacello methodsFor: 'api actions' stamp: 'dkh 7/17/2012 10:53'! lock "lock projects in registry" self addStatement: #'lock' args: #(). ^ self execute! ! !Metacello methodsFor: 'api actions' stamp: 'dkh 7/19/2012 07:40'! record: required self addStatement: #'record:' args: {required}. ^ self execute! ! !Metacello methodsFor: 'api options' stamp: 'dkh 07/24/2013 17:09'! onLock: aBlock self addStatement: #'onLock:' args: {aBlock}! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 7/17/2012 16:48'! renggli: projectName self repository: 'http://source.lukas-renggli.ch/' , projectName! ! !Metacello methodsFor: 'accessing' stamp: 'dkh 5/31/2012 17:57:13'! statements statements ifNil: [ statements := OrderedCollection new ]. ^ statements! ! !Metacello methodsFor: 'accessing' stamp: 'dkh 5/31/2012 17:57:13'! statements: anObject statements := anObject! ! !Metacello methodsFor: 'api actions' stamp: 'dkh 7/23/2012 15:56'! load self addStatement: #'load:' args: #(#()). ^ self execute! ! !Metacello methodsFor: 'accessing' stamp: 'dkh 7/13/2012 09:12'! executorSpec executorSpec ifNil: [ executorSpec := #'MetacelloScriptApiExecutor' -> 'batch' ]. ^ executorSpec! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 7/17/2012 16:49'! saltypickle: projectName self repository: 'http://squeak.saltypickle.com/' , projectName! ! !Metacello methodsFor: 'api actions' stamp: 'dkh 7/13/2012 16:35'! list "list projects in registry" self addStatement: #'list' args: #(). ^ self execute! ! !Metacello methodsFor: 'accessing' stamp: 'dkh 7/13/2012 09:13'! executorSpec: anAssoc executorSpec := anAssoc! ! !Metacello methodsFor: 'api actions' stamp: 'dkh 7/23/2012 15:55'! fetch self addStatement: #'fetch:' args: #(#()). ^ self execute! ! !Metacello methodsFor: 'api projectSpec' stamp: 'dkh 7/12/2012 13:45'! baseline: projectName self addStatement: #'baselineArg:' args: {projectName}! ! !Metacello methodsFor: 'api options' stamp: 'dkh 7/23/2012 16:17'! cacheRepository: aRepositoryDescription self addStatement: #'cacheRepository:' args: {aRepositoryDescription}! ! !Metacello methodsFor: 'api projectSpec' stamp: 'dkh 7/12/2012 13:46'! version: versionString self addStatement: #'versionArg:' args: {versionString}! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 07/25/2013 15:20'! smalltalkhubUser: userName project: projectName self repository: 'http://smalltalkhub.com/mc/' , userName , '/' , projectName , '/main'! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 07/25/2013 15:26'! githubUser: userName project: projectName commitish: commitish path: path | branchOrCommitOrTag | branchOrCommitOrTag := commitish. branchOrCommitOrTag isEmpty ifTrue: [ branchOrCommitOrTag := 'master' ]. self repository: 'github://' , userName , '/' , projectName , ':' , branchOrCommitOrTag , '/' , path! ! !Metacello methodsFor: 'api projectSpec' stamp: 'dkh 7/12/2012 13:46'! project: projectName self addStatement: #'projectArg:' args: {projectName}! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 7/17/2012 16:50'! wiresong: projectName self repository: 'http://source.wiresong.ca/' , projectName! ! !Metacello methodsFor: 'private' stamp: 'dkh 5/31/2012 17:57:13'! addStatement: selector args: args self statements add: selector -> args! ! !Metacello methodsFor: 'accessing' stamp: 'dkh 7/13/2012 09:16'! scriptExecutor ^ (self class scriptExecutorClass: self executorSpec) new! ! !Metacello methodsFor: 'api options' stamp: 'dkh 7/23/2012 19:27'! repositoryOverrides: aRepositoryDescriptionCollection self addStatement: #'repositoryOverrides:' args: {aRepositoryDescriptionCollection}! ! !Metacello methodsFor: 'api actions' stamp: 'dkh 7/17/2012 12:31'! unlock "unlock projects in registry" self addStatement: #'unlock' args: #(). ^ self execute! ! !Metacello methodsFor: 'api options' stamp: 'dkh 6/8/2012 14:03:46'! onDowngrade: aBlock self addStatement: #'onDowngrade:' args: {aBlock}! ! !Metacello methodsFor: 'api actions' stamp: 'dkh 5/31/2012 17:57:13'! load: required self addStatement: #'load:' args: {required}. ^ self execute! ! !Metacello methodsFor: 'api actions' stamp: 'dkh 7/23/2012 15:49'! fetch: required self addStatement: #'fetch:' args: {required}. ^ self execute! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 7/17/2012 16:49'! squeakfoundation: projectName self repository: 'http://source.squeakfoundation.org/' , projectName! ! !Metacello methodsFor: 'api actions' stamp: 'dkh 5/31/2012 17:57:13'! get "resolve project name in given repository and return an instance of MetacelloProject resolved from a ConfigurationOf or BaselineOf" self addStatement: #'get' args: #(). ^ self execute! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 7/17/2012 16:46'! blueplane: projectName self repository: 'http://squeaksource.blueplane.jp/' , projectName! ! !Metacello methodsFor: 'api projectSpec' stamp: 'dkh 7/12/2012 13:45'! className: className self addStatement: #'classNameArg:' args: {className}! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 7/17/2012 16:48'! croquet: projectName self repository: 'http://hedgehog.software.umn.edu:8888/' , projectName! ! !Metacello methodsFor: 'private' stamp: 'dkh 7/12/2012 14:29'! execute | script | script := self statements. self statements: nil. ^ self scriptExecutor execute: script! ! !Metacello methodsFor: 'api actions' stamp: 'dkh 07/25/2013 15:45'! locked "list of locked projects in registry" ^ self project: [ :projectSpec | projectSpec isLocked ]; list! ! !Metacello methodsFor: 'api options' stamp: 'dkh 6/7/2012 15:34'! onConflict: aBlock self addStatement: #'onConflict:' args: {aBlock}! ! !Metacello methodsFor: 'api actions' stamp: 'dkh 7/23/2012 15:56'! record self addStatement: #'record:' args: #(#()). ^ self execute! ! !Metacello methodsFor: 'api repository shortcuts' stamp: 'dkh 06/28/2013 16:52'! gemsource: projectName self repository: 'http://seaside.gemtalksystems.com/ss/' , projectName! ! !Metacello methodsFor: 'api options' stamp: 'dkh 6/7/2012 15:33'! onUpgrade: aBlock self addStatement: #'onUpgrade:' args: {aBlock}! ! !Metacello methodsFor: 'api projectSpec' stamp: 'dkh 7/12/2012 13:46'! repository: repositoryDescription self addStatement: #'repositoryArg:' args: {repositoryDescription}! ! !Metacello methodsFor: 'api options' stamp: 'dkh 5/31/2012 17:57:13'! silently "no progress bars" self addStatement: #'silently:' args: {true}! ! !Metacello class methodsFor: 'instance creation' stamp: 'dkh 7/13/2012 09:13'! registry ^ self new executorSpec: #'MetacelloScriptRegistryExecutor' -> 'batch'; yourself! ! !Metacello class methodsFor: 'private' stamp: 'dkh 7/13/2012 09:08'! scriptExecutorClass ^ self scriptExecutorClass: {(#'MetacelloScriptApiExecutor' -> 'batch')}! ! !Metacello class methodsFor: 'instance creation' stamp: 'dkh 7/16/2012 10:12'! image ^ self new executorSpec: #'MetacelloScriptImageExecutor' -> 'batch'; yourself! ! !Metacello class methodsFor: 'private' stamp: 'dkh 7/13/2012 09:15'! scriptExecutorClass: anExecutorSpec Smalltalk at: anExecutorSpec key ifAbsent: [ ConfigurationOf ensureMetacello: anExecutorSpec value ]. ^ Smalltalk at: anExecutorSpec key! ! !Metacello class methodsFor: 'instance creation' stamp: 'dkh 07/27/2013 08:45'! registrations ^ MetacelloProjectRegistration registry registrations! ! !Metacello class methodsFor: 'instance creation' stamp: 'dkh 6/13/2012 16:09'! classic "set the options such that the load performed will be identical to the classic ConfigurationOf load: (ConfigurationOfExample project version: '1.0') load #classic forces Metacello to look at image state to determine which version of a project is loaded instead of using the registry to tell us explicitly which version of a project is loaded .. image state is not PRECISE" "useCurrentVersion is a 'private' option for enforcing classic rules, so it's not part of scripting api" ^ self new onUpgrade: [ :ex | ex allow ]; onConflict: [ :ex | ex allow ]; addStatement: #'useCurrentVersion:' args: {true}; yourself! ! !MetacelloAbstractConstructor methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! configurationClass ^self subclassResponsibility! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'dkh 6/5/2012 19:01:24'! extractVersionPragmas | aDict | aDict := Dictionary new. self extractPragmas: #version: into: aDict. ^aDict! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'dkh 6/5/2012 19:01:24'! extractCommonDefaultSymbolicVersionPragmas | aDict | aDict := Dictionary new. self extractPragmas: #defaultSymbolicVersion: for: ConfigurationOf into: aDict. ^aDict! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'dkh 6/5/2012 19:01:24'! extractVersionImportPragmas | aDict | aDict := Dictionary new. self extractPragmas: #version:imports: into: aDict. ^aDict! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'dkh 6/5/2012 19:01:24'! extractAllVersionPragmas | aDict | aDict := Dictionary new. self extractPragmas: #version: into: aDict. self extractPragmas: #version:imports: into: aDict. ^aDict! ! !MetacelloAbstractConstructor methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! extractPragmas: pragmaKeyword into: versionDict ^self extractPragmas: pragmaKeyword for: self configurationClass into: versionDict ! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'dkh 6/5/2012 19:01:24'! extractSymbolicVersionPragmas | aDict | aDict := Dictionary new. self extractPragmas: #symbolicVersion: into: aDict. ^aDict! ! !MetacelloAbstractConstructor methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! extractPragmas: pragmaKeyword for: aClass into: versionDict | versionString pragmas | (Pragma allNamed: pragmaKeyword in: aClass) do: [:pragma | versionString := pragma argumentAt: 1. pragmas := versionDict at: versionString ifAbsent: [ | list | list := OrderedCollection new. versionDict at: versionString put: list. list ]. pragmas add: pragma ]. ! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'dkh 6/5/2012 19:01:24'! extractDefaultSymbolicVersionPragmas | aDict | aDict := Dictionary new. self extractPragmas: #defaultSymbolicVersion: into: aDict. ^aDict! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc-querying' stamp: 'dkh 6/8/2012 14:04:22'! file "MetacelloPackageSpec compatibility" ^nil! ! !MetacelloAbstractPackageSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodCascadeOn: aStream member: aMember last: lastCascade indent: indent self subclassResponsibility ! ! !MetacelloAbstractPackageSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! setIncludes: aCollection includes := aCollection! ! !MetacelloAbstractPackageSpec methodsFor: 'adding' stamp: 'dkh 6/5/2012 19:01:24'! addToMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: (aMetacelloPackagesSpec addMember name: self name; spec: self; yourself)! ! !MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! requires: aCollection aCollection setRequiresInMetacelloPackage: self! ! !MetacelloAbstractPackageSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! setRequires: aCollection requires := aCollection! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolveToPackagesIn: aVersionSpec visited: visited ^self subclassResponsibility! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc-querying' stamp: 'dkh 6/30/2012 12:32'! repository self deprecated: 'Use repositories or repositorySpecs'. ^ nil! ! !MetacelloAbstractPackageSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeSpec: anotherSpec | newSpec map anotherRequires anotherIncludes anotherAnswers | newSpec := super mergeSpec: anotherSpec. map := anotherSpec mergeMap. anotherSpec name ~~ nil ifTrue: [ newSpec name: anotherSpec name ]. (anotherRequires := map at: #requires) ~~ nil ifTrue: [ newSpec setRequires: self requires, anotherRequires ]. (anotherIncludes := map at: #includes) ~~ nil ifTrue: [ newSpec setIncludes: self includes, anotherIncludes ]. (anotherAnswers := map at: #answers) ~~ nil ifTrue: [ newSpec setAnswers: self answers, anotherAnswers ]. ^newSpec ! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: aLoader gofer: gofer ^self subclassResponsibility! ! !MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! includes includes == nil ifTrue: [ includes := #() ]. ^includes! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! forceUpdatePackageSpec: updatedSpecs using: anMCLoader ^self updatePackageSpec: updatedSpecs using: anMCLoader! ! !MetacelloAbstractPackageSpec methodsFor: 'removing' stamp: 'dkh 6/5/2012 19:01:24'! removeFromMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: (aMetacelloPackagesSpec removeMember name: self name; spec: self; yourself)! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! packagesNeedSavingVisited: visitedProjects using: repos into: aCollection "noop by default" ! ! !MetacelloAbstractPackageSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! setAnswers: aCollection answers := aCollection! ! !MetacelloAbstractPackageSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeMap | map | map := super mergeMap. map at: #requires put: requires. map at: #includes put: includes. map at: #answers put: answers. ^map! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolveToAllPackagesIn: aVersionSpec into: packages visited: visited visited visit: self doing: [:spec | self visitingWithPackages: packages. (spec includes, spec requires) do: [:pkgName | (aVersionSpec packageNamed: pkgName) projectDo: [:prj | (prj resolveToAllPackagesIn: aVersionSpec visited: visited) do: [:pkg | packages at: pkg name put: pkg ]] packageDo: [:pkg | packages at: pkg name put: pkg. (pkg resolveToAllPackagesIn: aVersionSpec visited: visited) do: [:rpkg | packages at: rpkg name put: rpkg ] ] groupDo: [:grp | grp resolveToAllPackagesIn: aVersionSpec into: packages visited: visited ]]]! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! updatePackageRepositoriesFor: aVersionSpec "noop by default" ^true ! ! !MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! requires requires == nil ifTrue: [ requires := #() ]. ^requires! ! !MetacelloAbstractPackageSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! nonOverridable ^#( includes requires answers )! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc-querying' stamp: 'dkh 6/8/2012 14:04:22'! isPackageLoaded ^false! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! updateForSpawnMethod: sourceSpec "This means that this spec was used in a baseline and will be used in a version .... drop all information that isn't useful" answers := name := requires := includes := nil! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc-querying' stamp: 'dkh 03/12/2013 20:25'! getFile "MetacelloPackageSpec compatibility" ^ nil! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! repositorySpecs ^#()! ! !MetacelloAbstractPackageSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodBodyOn: aStream hasName: hasName cascading: cascading indent: indent | hasCascading hasRequires hasIncludes hasAnswers | hasCascading := cascading. hasRequires := self requires isEmpty not. hasIncludes := self includes isEmpty not. hasAnswers := self answers isEmpty not. hasRequires ifTrue: [ hasName | hasIncludes | hasAnswers | hasCascading ifTrue: [ aStream cr; tab: indent ]. aStream nextPutAll: 'requires: #('. self requires do: [:str | aStream nextPutAll: str printString, ' ' ]. hasIncludes | hasAnswers | hasCascading ifTrue: [ aStream nextPutAll: ');' ] ifFalse: [ aStream nextPut: $) ]]. hasIncludes ifTrue: [ hasName | hasRequires | hasAnswers | hasCascading ifTrue: [ aStream cr; tab: indent ]. aStream nextPutAll: 'includes: #('. self includes do: [:str | aStream nextPutAll: str printString, ' ' ]. hasAnswers | hasCascading ifTrue: [ aStream nextPutAll: ');' ] ifFalse: [ aStream nextPut: $) ]]. hasAnswers ifTrue: [ hasName | hasRequires | hasIncludes | hasCascading ifTrue: [ aStream cr; tab: indent ]. aStream nextPutAll: 'supplyingAnswers: #( '. self answers do: [:ar | aStream nextPutAll: '#( '. ar do: [:val | (val isString or: [ val isNumber or: [ val isSymbol or: [ val isCharacter ]]]) ifTrue: [ aStream nextPutAll: val printString, ' ' ]. val == true ifTrue: [ aStream nextPutAll: 'true ' ]. val == false ifTrue: [ aStream nextPutAll: 'false ' ]]. aStream nextPutAll: ') ' ]. hasCascading ifTrue: [ aStream nextPutAll: ');' ] ifFalse: [ aStream nextPut: $) ]]. ! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! updatePackageSpec: updatedSpecs using: anMCLoader "Add pkg copy to updatedSpecs if the file in current image is different from the receiver's file" ! ! !MetacelloAbstractPackageSpec methodsFor: 'testing' stamp: 'dkh 6/30/2012 13:21'! hasRepository ^ false! ! !MetacelloAbstractPackageSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodOn: aStream for: aValue selector: selector cascading: cascading cascade: cascade indent: indent | valuePrintString | aValue == nil ifTrue: [ ^self ]. cascading ifTrue: [ aStream cr; tab: indent ]. valuePrintString := aValue value isSymbol ifTrue: [ '#' , aValue value asString printString ] ifFalse: [ aValue value printString ]. aStream nextPutAll: selector, valuePrintString. cascade ifTrue: [ aStream nextPut: $; ] ! ! !MetacelloAbstractPackageSpec methodsFor: 'visiting' stamp: 'dkh 6/5/2012 19:01:24'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock self subclassResponsibility! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc-querying' stamp: 'dkh 6/8/2012 14:04:22'! version "MetacelloPackageSpec compatibility" ^nil! ! !MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! includes: aCollection aCollection setIncludesInMetacelloPackage: self! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolveToAllPackagesIn: aVersionSpec visited: visited | packages | packages := Dictionary new. self resolveToAllPackagesIn: aVersionSpec into: packages visited: visited. ^packages values asOrderedCollection ! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! visitingWithPackages: packages "noop"! ! !MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! name: aString ((aString at: 1) isSeparator or: [ (aString at: aString size) isSeparator ]) ifTrue: [ self error: 'Names are not allowed to have leading or trailing blanks: ' , aString printString ]. name := aString! ! !MetacelloAbstractPackageSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! label ^self name! ! !MetacelloAbstractPackageSpec methodsFor: 'copying' stamp: 'dkh 6/5/2012 19:01:24'! postCopy super postCopy. requires := requires copy. includes := includes copy. answers := answers copy. ! ! !MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! answers answers == nil ifTrue: [ answers := #() ]. ^answers! ! !MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! referencedSpec ^self! ! !MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! answers: aListOfPairs self setAnswers: aListOfPairs! ! !MetacelloAbstractPackageSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! includesForPackageOrdering ^#()! ! !MetacelloAbstractPackageSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeIntoMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: (aMetacelloPackagesSpec mergeMember name: self name; spec: self; yourself)! ! !MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! name ^name! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolveToLoadableSpec ^self! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:36'! root ^root! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoryForProject: aString username: username password: password self repositoryForSpec: aString username: username password: password! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! project: aString overrides: aBlock self root project: aString overrides: aBlock constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! project project == nil ifTrue: [ project := self projectClass new ]. ^ project! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! postLoadDoItForVersion: aSymbol self postLoadDoItForSpec: aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! timestampForVersion: aBlockOrStringOrDateAndTime aBlockOrStringOrDateAndTime setTimestampInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! postLoadDoItForPackage: aSymbol self postLoadDoItForSpec: aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! projectForVersion: aString overrides: aBlock | spec projectSpec | projectSpec := self project projectSpec name: aString; yourself. spec := self project projectReferenceSpec name: aString; projectReference: projectSpec; yourself. self root packages add: spec. self with: projectSpec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! supplyingAnswers: aCollection self root supplyingAnswers: aCollection constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:37'! root: aMetacelloSpec root := aMetacelloSpec! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoryForVersion: aString username: username password: password self repositoryForSpec: aString username: username password: password! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! description: aBlockOrString "Define description field of version spec (MetacelloMCVersionSpec). If is a String, the version spec blessing is set to the String. It is recommended to use a Symbol. If is a Block, the specifications in are applied to the blessing spec (MetacelloValueHolderSpec). Not Recommended!! spec description: 'Descriptive comment'. spec description: [ spec value: 'Descriptive comment'. " self root description: aBlockOrString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! authorForVersion: aBlockOrString aBlockOrString setAuthorInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: '*metacello-mc-accessing' stamp: 'dkh 6/8/2012 14:04:22'! projectClass ^ MetacelloMCProject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! projectPackage: aBlock "projectPackage spec data folded into project spec" self root projectPackage: aBlock constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoriesForPackage: aBlock self repositoriesForSpec: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! valueForValueHolder: anObject self root value: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! repository: description username: username password: password self root repository: description username: username password: password constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'private' stamp: 'DaleHenrichs 11/12/2010 12:28'! evaluatePragma: pragma currentContext := pragma. [ self configuration perform: pragma selector with: self ] ensure: [ currentContext := nil ]! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'dkh 9/5/2012 06:26:03.064'! baseline: aString self root baseline: aString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! removeGroupForVersion: aString | spec | spec := self project groupSpec name: aString; yourself. self root packages remove: spec! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'DaleHenrichs 12/4/2010 09:56'! addAttribute: anAttribute self attributeOrder add: anAttribute! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 11:38'! for: attributeListOrSymbol do: aBlock "conditional version support" attributeListOrSymbol setForDo: aBlock withInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'initialization' stamp: 'dkh 10/5/2009 16:42'! reset attributeMap := attributeOrder := nil! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setDescriptionWithString: aString self root description: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! group: aString overrides: aStringOrCollection self root group: aString overrides: aStringOrCollection constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'dkh 9/5/2012 06:26:03.064'! baseline: aString with: aBlockOrString self root baseline: aString with: aBlockOrString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! preLoadDoIt: aSymbol self root preLoadDoIt: aSymbol constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! name: anObject self root name: anObject constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'DaleHenrichs 03/12/2011 22:10'! setProject: aProject project := aProject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! preLoadDoItForPackage: aSymbol self preLoadDoItForSpec: aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! versionStringForProject: anObject self root versionString: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoryForProject: anObject self repositoryForSpec: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! package: aString overrides: aBlock self root package: aString overrides: aBlock constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! package: packageName with: aBlockOrString "Define specification for package . If is a String (or Symbol), the String is expected to be a version (or symbolic version). If is a Block, the specifications in are applied to the project: spec package: 'MyPackage' with: '1.0'. spec package: 'MyPackage' with: [ spec file:'MyPackage-dkh.1'. spec repository: '/opt/gemstone/repository'. " self root package: packageName with: aBlockOrString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoryForRepositories: aString username: username password: password self repositoryForVersion: aString username: username password: password! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setProject: aString withString: versionString | spec projectSpec | projectSpec := (self project projectSpec) name: aString; versionString: versionString; yourself. spec := (self project projectReferenceSpec) name: aString; projectReference: projectSpec; yourself. self root packages merge: spec. ! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! group: aString with: aStringOrCollection self root group: aString with: aStringOrCollection constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! removeProjectForVersion: aString | spec | spec := self project projectReferenceSpec name: aString; yourself. self root packages remove: spec! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:26'! configuration: aConfig configuration := aConfig! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! versionForProject: anObject self versionStringForProject: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! operatorForProject: anObject self root operator: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! operator: anObject self root operator: anObject constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! postLoadDoItForProject: aSymbol self postLoadDoItForSpec: aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoryForSpec: aString username: username password: password self root repository: aString username: username password: password! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! postLoadDoItForSpec: aSymbol self validateDoItSelector: aSymbol. self root postLoadDoIt: aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! projectForVersion: aString self project: aString with: ''! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! supplyingAnswersForPackage: anObject self root answers: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoryForPackage: aString username: username password: password self repositoryForSpec: aString username: username password: password! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setTimestampWithString: aString self root timestamp: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! file: aString "Define file field of a package spec (MetacelloPackageSpec) or project spec (MetacelloMCProjectSpec). For a package spec, the file: field is optional in a baseline. In a baseline, the file field may be used to specify a package branch for the package: spec package: 'MyPackage' with: [ spec file: 'MyPackage.gemstone'. ]'. The file: field is required in a version. In a version, the file field defines the explicit version of the package to be loaded: spec package: 'MyPackage' with: [ spec file: 'MyPackage.gemstone-dkh.1'. ]'. The following may be used as a short cut for specifying the file field in a version: spec package: 'MyPackage' with: 'MyPackage.gemstone-dkh.1'. For a project spec, the file field specifies the name of the Monticello package that contains the configuration. If you are using the convention of naming the class and package usingthe 'ConfigurationOf' prefix, then there is no need to specify the file field: spec project: 'MyProject' with: [ spec file: 'ConfigurationMyProject'. It should only be used when the package name for the configuration is different from the name of the project: spec project: 'MyProject' with: [ spec file: 'MyProject-Metacello'. " self root file: aString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'DaleHenrichs 9/22/2010 16:43'! symbolicVersion ^symbolicVersion! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setPackage: aString withString: aFile | spec | spec := (self project packageSpec) name: aString; file: aFile; yourself. self root packages merge: spec. ! ! !MetacelloAbstractVersionConstructor methodsFor: 'validation' stamp: 'DaleHenrichs 11/12/2010 10:28'! validateDoItSelector: anObject anObject == nil ifTrue: [ ^ self ]. anObject isSymbol ifFalse: [ self error: 'Invalid message selector for doit: ', anObject printString ]. ! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:28'! attributeMap attributeMap == nil ifTrue: [ attributeMap := Dictionary new ]. ^attributeMap! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 03/12/2011 22:11'! project: aString self root project: aString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! project: aString copyFrom: oldSpecName with: aBlock self root project: aString copyFrom: oldSpecName with: aBlock constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setBlessingWithBlock: aBlock | spec | (spec := self root getBlessing) == nil ifTrue: [ spec := self project valueHolderSpec. self root setBlessing: spec ]. self with: spec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! projectForVersion: aString copyFrom: oldSpecName with: aBlock | spec projectSpec | projectSpec := self project projectSpec name: aString; yourself. spec := self project projectReferenceSpec name: aString; projectReference: projectSpec; yourself. self root packages copy: oldSpecName to: spec. self with: projectSpec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoryForRepositories: anObject self repositoryForSpec: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoryForVersion: anObject self repositoryForSpec: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! projectPackageForProject: aBlock self with: self root during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! includes: anObject self root includes: anObject constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! preLoadDoItForSpec: aSymbol self validateDoItSelector: aSymbol. self root preLoadDoIt: aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoryForPackage: anObject self repositoryForSpec: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! repository: anObject self root repository: anObject constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! classNameForProject: aString self root className: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! packageForVersion: packageName with: aBlockOrString aBlockOrString setPackage: packageName withInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! preLoadDoItForVersion: aSymbol self preLoadDoItForSpec: aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! configurationForVersion: aString with: aBlock aBlock setConfiguration: aString withInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! nameForProject: aString self root name: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! author: aBlockOrString "Define author field of version spec (MetacelloMCVersionSpec). If is a String, the version spec author is set to the String. If is a Block, the specifications in are applied to the author spec (MetacelloValueHolderSpec). Not Recommended!! spec author: 'dkh'. spec author: [ spec value: 'dkh'. ]. " self root author: aBlockOrString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! value: anObject self root value: anObject constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! package: aString self root package: aString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! blessingForVersion: aBlockOrString aBlockOrString setBlessingInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/5/2009 16:41'! attributeOrder attributeOrder == nil ifTrue: [ attributeOrder := OrderedCollection new ]. ^attributeOrder! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! packageForVersion: aString | spec | spec := self project packageSpec name: aString; yourself. self root packages add: spec! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'dkh 9/5/2012 06:26:03.064'! import: aString "import names defined in baseline to be used when loading the version spec baseline: 'Sample' with: [ spec repository: 'github://dalehenrich/sample:master/repository' ]. spec import: 'Sample' ] " self root import: aString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! fileForProject: aString self root file: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! version: anObject self root version: anObject constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'dkh 9/5/2012 06:26:03.064'! configuration: aString with: aBlockOrString self root configuration: aString with: aBlockOrString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'dkh 9/7/2012 13:11'! setFor: attributeList version: aString "conditional symbolicVersion support" attributeList asMetacelloAttributeList do: [ :attribute | self attributeMap at: attribute put: aString. self addAttribute: attribute ]! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! timestamp: aBlockOrStringOrDateAndTime "Define timestamp field of version spec (MetacelloMCVersionSpec). If is a String, the version spec timetamp is set to the String. If is a DateAndTime, the version spec timetamp is set to the printString of the DateAndTime. If is a Block, the specifications in are applied to the timestamp spec (MetacelloValueHolderSpec). Not Recommended!! spec timestamp: '10/7/2009 14:40'. spec timestamp: DateAndTime now'. spec timestamp: [ spec value: '10/7/2009 14:40'. ]. " self root timestamp: aBlockOrStringOrDateAndTime constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'dkh 9/7/2012 13:11'! setFor: attributeList do: aBlock "conditional version support" attributeList asMetacelloAttributeList do: [ :attribute | | blockList | blockList := self attributeMap at: attribute ifAbsent: [ self attributeMap at: attribute put: (blockList := OrderedCollection new) ]. blockList add: aBlock. self addAttribute: attribute ]! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! removeProject: aString self root removeProject: aString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! fileForPackage: aString self root file: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setDescriptionWithBlock: aBlock | spec | (spec := self root getDescription) == nil ifTrue: [ spec := self project valueHolderSpec. self root setDescription: spec ]. self with: spec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! baselineForVersion: aString with: aBlock aBlock setBaseline: aString withInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! includesForPackage: anObject self root includes: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! repositories: aBlock self root repositories: aBlock constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 11:41'! configurationClass ^self configuration class! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! groupForVersion: aString with: aStringOrCollection | spec | spec := self project groupSpec name: aString; includes: aStringOrCollection; yourself. self root packages merge: spec! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! postLoadDoIt: aSymbol self root postLoadDoIt: aSymbol constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! versionString: anObject self root versionString: anObject constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 11:37'! for: attributeListOrSymbol version: aString "conditional symbolicVersion support" attributeListOrSymbol setForVersion: aString withInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! preLoadDoItForProject: aSymbol self preLoadDoItForSpec: aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoryForSpec: anObject self root repository: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! removePackage: aString self root removePackage: aString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'DaleHenrichs 9/22/2010 16:43'! symbolicVersion: aSymbol symbolicVersion := aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! descriptionForVersion: aBlockOrString aBlockOrString setDescriptionInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! loadsForProject: anObject self root loads: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoriesForSpec: aBlock self with: self root repositories during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setPackage: aString withBlock: aBlock | spec | spec := (self project packageSpec) name: aString; yourself. self root packages merge: spec. self with: spec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! removeGroup: aString self root removeGroup: aString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setTimestampWithBlock: aBlock | spec | (spec := self root getTimestamp) == nil ifTrue: [ spec := self project valueHolderSpec. self root setTimestamp: spec ]. self with: spec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setProject: aString withBlock: aBlock | spec projectSpec | projectSpec := self project projectSpec name: aString; yourself. spec := self project projectReferenceSpec name: aString; projectReference: projectSpec; yourself. self root packages merge: spec. self with: projectSpec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! requires: anObject self root requires: anObject constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! projectForVersion: aString with: aBlockOrString aBlockOrString setProject: aString withInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! setBaseline: aString withBlock: aBlock | projectSpec | projectSpec := self setBaseline: aString. self with: projectSpec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! versionForVersion: anObject self versionStringForVersion: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! versionStringForVersion: anObject self versionStringForProject: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! removePackageForVersion: aString | spec | spec := self project packageSpec name: aString; yourself. self root packages remove: spec! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! setConfiguration: aString withBlock: aBlock | spec projectSpec | projectSpec := self project configurationOfProjectSpec name: aString; yourself. spec := self project projectReferenceSpec name: aString; projectReference: projectSpec; yourself. self root packages merge: spec. self with: projectSpec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! groupForVersion: aString overrides: aStringOrCollection | spec | spec := self project groupSpec name: aString; includes: aStringOrCollection; yourself. self root packages add: spec! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! setBaseline: aString | spec projectSpec | projectSpec := self project baselineOfProjectSpec name: aString; className: 'BaselineOf' , aString; yourself. spec := self project projectReferenceSpec name: aString; projectReference: projectSpec; yourself. self root packages merge: spec. ^ projectSpec! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! loads: anObject self root loads: anObject constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoriesForProject: aBlock self repositoriesForSpec: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setAuthorWithBlock: aBlock | spec | (spec := self root getAuthor) == nil ifTrue: [ spec := self project valueHolderSpec. self root setAuthor: spec ]. self with: spec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:26'! configuration ^configuration! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setBlessingWithString: aString self root blessing: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'private' stamp: 'dkh 10/3/2009 16:31'! with: aMetacelloSpec during: aBlock | previousRoot | previousRoot := self root. self root: aMetacelloSpec. aBlock ensure: [ self root: previousRoot ]! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! importForVersion: aString self root import: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! requiresForPackage: anObject self root requires: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setAuthorWithString: aString self root author: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! packageForVersion: aString overrides: aBlock | spec | spec := self project packageSpec name: aString; yourself. self root packages add: spec. self with: spec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! className: aString "Define className field of a project spec (MetacelloMCProjectSpec). spec project: 'CoolBrowser' with: [ spec className: 'ConfigurationOfCoolBrowser'. ]. The className field is OPTIONAL in the project spec. If omitted, the className will be created by prepending 'ConfigurationOf' to the project name. " self root className: aString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! baselineForVersion: aString self setBaseline: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'api spec callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! repositoriesForVersion: aBlock self repositoriesForSpec: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! blessing: aBlockOrString "Define blessing field of version spec (MetacelloMCVersionSpec). If is a String, the version spec blessing is set to the String. It is recommended to use a Symbol. If is a Block, the specifications in are applied to the blessing spec (MetacelloValueHolderSpec). Not Recommended!! spec blessing: #release. spec blessing: [ spec value: #release. ]. The blessing should typically be set to one of three values: #baseline - indicating that the version spec is specifying a baseline version #development - indicating that the version spec is not stabilized and will change over time #release - indicating that the version spec has stabilized and will NOT change over time " self root blessing: aBlockOrString constructor: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! project: aString with: aBlockOrString self root project: aString with: aBlockOrString constructor: self! ! !MetacelloAbstractVersionConstructor class methodsFor: 'method generation' stamp: 'dkh 6/5/2012 19:01:24'! symbolicMethodSelectorAndPragma: selector symbolicVersionSymbol: symbolicVersionSymbol on: strm strm nextPutAll: selector asString , ' spec'; cr; tab; nextPutAll: ''; cr! ! !MetacelloAddMemberSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock addBlock value: self! ! !MetacelloAddMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! methodUpdateSelector ^#overrides:! ! !MetacelloAddMemberSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! applyToList: aListSpec aListSpec add: self! ! !MetacelloAllowConflictingProjectUpgrade methodsFor: 'handlers' stamp: 'dkh 6/7/2012 15:50'! handleResolutionFor: aScriptEngine ^ aScriptEngine handleConflict: self! ! !MetacelloAllowConflictingProjectUpgrade methodsFor: 'accessing' stamp: 'dkh 07/29/2013 16:44'! operationString ^ 'load with conflicts'! ! !MetacelloAllowConflictingProjectUpgrade methodsFor: 'exception handling' stamp: 'dkh 7/18/2012 11:06'! defaultAction ^ MetacelloConflictingProjectError signal: 'Load Conflict between existing ' , self existingProjectRegistration printString , ' and ' , self newProjectRegistration printString! ! !MetacelloAllowLockedProjectChange methodsFor: 'handlers' stamp: 'dkh 07/24/2013 16:58'! handleResolutionFor: aScriptEngine ^ aScriptEngine handleLock: self! ! !MetacelloAllowLockedProjectChange methodsFor: 'accessing' stamp: 'dkh 07/24/2013 17:00'! operationString: aString operationString := aString! ! !MetacelloAllowLockedProjectChange methodsFor: 'accessing' stamp: 'dkh 07/24/2013 17:00'! operationString ^ operationString! ! !MetacelloAllowLockedProjectChange methodsFor: 'exception handling' stamp: 'dkh 07/30/2013 07:51'! defaultAction Warning signal: 'LOCK ENFORCED: Attempt to ' , self operationString printString , ' new project: ' , self newProjectRegistration printString printString , ' when existing project: ' , self existingProjectRegistration printString printString , ' is locked. New project not loaded. Use #onLock: to intercept.'. ^ self disallow! ! !MetacelloAllowLockedProjectChange methodsFor: 'private' stamp: 'dkh 07/25/2013 04:42'! checkAllowed "noop ... if user decided to allow lock to be broken, then so be it" ! ! !MetacelloAllowProjectDowngrade methodsFor: 'handlers' stamp: 'dkh 7/18/2012 16:46'! handleOnDownGrade: onDownGradeBlock onUpgrade: onUpgradeBlock ^ onDownGradeBlock cull: self cull: self existingProjectRegistration cull: self newProjectRegistration! ! !MetacelloAllowProjectDowngrade methodsFor: 'handlers' stamp: 'dkh 6/8/2012 10:41'! handleResolutionFor: aScriptEngine ^ aScriptEngine handleDowngrade: self! ! !MetacelloAllowProjectDowngrade methodsFor: 'accessing' stamp: 'dkh 07/29/2013 16:49'! operationString ^ 'downgrade to'! ! !MetacelloAllowProjectUpgrade methodsFor: 'handlers' stamp: 'dkh 7/18/2012 16:46'! handleOnDownGrade: onDownGradeBlock onUpgrade: onUpgradeBlock ^ onUpgradeBlock cull: self cull: self existingProjectRegistration cull: self newProjectRegistration! ! !MetacelloAllowProjectUpgrade methodsFor: 'handlers' stamp: 'dkh 6/7/2012 15:50'! handleResolutionFor: aScriptEngine ^ aScriptEngine handleUpgrade: self! ! !MetacelloAllowProjectUpgrade methodsFor: 'accessing' stamp: 'dkh 07/29/2013 16:49'! operationString ^ 'upgrade to'! ! !MetacelloAllowProjectUpgrade methodsFor: 'exception handling' stamp: 'dkh 7/18/2012 16:43'! defaultAction "Default for Upgrade is to allow" self checkAllowed. ^ self newProjectRegistration! ! !MetacelloAlternateResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpMonticelloRepository "This method builds a fake repository with the version references from #buildReferences." monticelloRepository := MCDictionaryRepository new. versionReferences do: [ :reference | monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)) with: (MCClassDefinition name: reference packageName asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: ''))) dependencies: #()) ]! ! !MetacelloAlternateResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpVersionReferences "self reset" versionReferences := OrderedCollection new. versionReferences add: (GoferVersionReference name: 'GoferBar-dkh.24'); add: (GoferVersionReference name: 'GoferBar-dkh.25'); add: (GoferVersionReference name: 'GoferFoo-dkh.75'); add: (GoferVersionReference name: 'GoferFoo-dkh.104')! ! !MetacelloAlternateResource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! versionReferences ^ versionReferences! ! !MetacelloAlternateResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUp super setUp. self setUpVersionReferences; setUpMonticelloRepository! ! !MetacelloAlternateResource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! monticelloRepository ^ monticelloRepository! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline60MethodSourceFoo ^(self class sourceCodeAt: #baseline60Foo:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! version20Foo: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec blessing: #release. spec package: 'GoferBar' with: 'GoferBar-dkh.1'; package: 'GoferFoo' with: 'GoferFoo-dkh.4'; package: 'GoferBeau' with: 'GoferBeau-dkh.15'; package: 'GoferFaux' with: 'GoferFaux-tg.30'; yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline62MethodSourceProjectIssue86 ^(self class sourceCodeAt: #baseline62ProjectIssue86:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline62Foo: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with:'GoferFoo-lr.4'; package: 'GoferBar' with: 'GoferBar-lr.1'; package: 'GoferFaux' with: 'GoferFaux-tg.34'; package: 'GoferBeau' with: 'GoferBeau-dkh.55'; yourself. spec group: '1' with: #('GoferFoo' 'GoferBar'); group: '2' with: #('GoferFoo' ); yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline25Foo: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec blessing: #baseline. spec package: 'GoferFoo' with: [spec requires: 'GoferFan' ]; yourself. spec project: 'GoferFan' with: [ "requires GoferBeau" spec className: 'MetacelloTestConfigurationOfAtomicFan'; versionString: '2.0-baseline'; loads: 'GoferFan'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! monticelloRepository ^ monticelloRepository! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! linearProjectMethodSource ^(self class sourceCodeAt: #project) asString copyReplaceAll: 'atomic' with: 'linear' ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: 'dkh 6/12/2012 15:41:23.319'! postLoad31baselineMethodSource ^(self class sourceCodeAt: #postLoad31baseline) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! project "self reset" | constructor project | "Construct Metacello project" constructor := MetacelloVersionConstructor on: self. project := constructor project. project loader: ((project loaderClass new) shouldDisablePackageCache: true; yourself). project loadType: #atomic. ^project ! ! !MetacelloAtomicConfigurationResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpMonticelloRepository "This method builds a fake repository with the version references from #buildReferences." "self reset" monticelloRepository := MCDictionaryRepository new. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! version51MethodSourceFoo ^(self class sourceCodeAt: #version51Foo:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: 'dkh 6/12/2012 15:41:23.319'! version50Umbrella: spec "self reset" spec for: #common do: [ spec project: 'Umbrella' with: [ spec className: 'MetacelloTestConfigurationOfLinearFoo'; versionString: '5.0'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline60ProjectIssue86: spec "projects and packages" "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'A' with: [ spec className: 'MetacelloTestConfigurationOfLinearFoo'; versionString: '6.0'; loads: #('1'); repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; project: 'B' with: [ spec className: 'MetacelloTestConfigurationOfLinearFoo'; versionString: '6.0'; loads: #('2'); repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! projectMethodSource ^(self class sourceCodeAt: #project) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: 'dkh 6/12/2012 15:41:23.319'! version51Umbrella: spec "self reset" spec for: #common do: [ spec project: 'Umbrella' with: [ spec className: 'MetacelloTestConfigurationOfLinearFoo'; versionString: '5.1'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: 'dkh 6/12/2012 15:41:23.319'! version50MethodSourceUmbrella ^(self class sourceCodeAt: #version50Umbrella:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfUmbrellaA "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfUmbrellaA-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'version50Umbrella:' category: 'cat' timeStamp: '' source: self version50MethodSourceUmbrella)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline20MethodSourceFan ^(self class sourceCodeAt: #baseline20Fan:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! projectClassMethodSource ^(self class class sourceCodeAt: #project) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfAtomicFan "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfAtomicFan-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baseline20Fan:' category: 'cat' timeStamp: '' source: self baseline20MethodSourceFan). (MCMethodDefinition className: className asString selector: 'baseline31Fan:' category: 'cat' timeStamp: '' source: self baseline31MethodSourceFan). (MCMethodDefinition className: className asString selector: 'postLoad31baseline' category: 'cat' timeStamp: '' source: self postLoad31baselineMethodSource)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! version50MethodSourceFoo ^(self class sourceCodeAt: #version50Foo:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline31MethodSourceFan ^(self class sourceCodeAt: #baseline31Fan:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: 'dkh 6/12/2012 15:41:23.319'! postLoad31baseline "Throw an error if GoferFar isn't loaded" Smalltalk at: #GoferFar ifAbsent: [ self error: 'GoferFar should be loaded' ]! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline61Foo: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with:'GoferFoo-lr.4'; package: 'GoferBar' with: 'GoferBar-lr.1'; package: 'GoferFaux' with: 'GoferFaux-tg.34'; package: 'GoferBeau' with: 'GoferBeau-dkh.55'; yourself. spec group: '1' with: #('GoferFoo' 'GoferBar'); group: '2' with: #('GoferFoo' 'GoferBeau'); yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! version20MethodSourceFoo ^(self class sourceCodeAt: #version20Foo:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue86 "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue86-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self linearProjectMethodSource). (MCMethodDefinition className: className asString selector: 'baseline60ProjectIssue86:' category: 'cat' timeStamp: '' source: self baseline60MethodSourceProjectIssue86). (MCMethodDefinition className: className asString selector: 'baseline61ProjectIssue86:' category: 'cat' timeStamp: '' source: self baseline61MethodSourceProjectIssue86). (MCMethodDefinition className: className asString selector: 'baseline62ProjectIssue86:' category: 'cat' timeStamp: '' source: self baseline62MethodSourceProjectIssue86)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline31Fan: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec postLoadDoIt: #postLoad31baseline. spec package: 'GoferBar'; package: 'GoferBeau' with: [ spec requires: 'GoferBar'; includes: #('GoferFoo' ) ]; package: 'GoferFar' with: [ spec requires: #('GoferFoo' ) ]; yourself. spec project: 'GoferFoo' with: [ "requires GoferBeau" spec className: 'MetacelloTestConfigurationOfLinearFoo'; versionString: '2.0'; loads: 'GoferFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline60Foo: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with:'GoferFoo-lr.4'; package: 'GoferBar' with: 'GoferBar-lr.1'; package: 'GoferFaux' with: 'GoferFaux-tg.34'; package: 'GoferBeau' with: 'GoferBeau-dkh.55'; yourself. spec group: '1' with: #('GoferFoo' 'GoferBar'); group: '2' with: #('1' 'GoferFaux'); yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline62ProjectIssue86: spec "projects and packages" "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'A' with: [ spec className: 'MetacelloTestConfigurationOfLinearFoo'; versionString: '6.2'; loads: #('1'); repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; project: 'B' with: [ spec className: 'MetacelloTestConfigurationOfLinearFoo'; versionString: '6.2'; loads: #('2'); repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! version51Foo: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec blessing: #release. spec package: 'GoferUmbrella' with: 'GoferUmbrella-lr.5'; yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline60MethodSourceProjectIssue86 ^(self class sourceCodeAt: #baseline60ProjectIssue86:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline20Fan: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec blessing: #baseline. spec package: 'GoferFan'; yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfUmbrellaB "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfUmbrellaB-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'version51Umbrella:' category: 'cat' timeStamp: '' source: self version51MethodSourceUmbrella)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline20Foo: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec blessing: #baseline. spec package: 'GoferBar'; package: 'GoferFoo'; package: 'GoferBeau'; package: 'GoferFaux'; yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline62MethodSourceFoo ^(self class sourceCodeAt: #baseline62Foo:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUp super setUp. self setUpMonticelloRepository; setUpConfigurationOfAtomicFoo; setUpConfigurationOfLinearFoo; setUpConfigurationOfAtomicFan; setUpConfigurationOfUmbrellaA; setUpConfigurationOfUmbrellaB; setUpConfigurationOfProjectIssue86; yourself! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline25MethodSourceFoo ^(self class sourceCodeAt: #baseline25Foo:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfAtomicFoo "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfAtomicFoo-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baseline20Foo:' category: 'cat' timeStamp: '' source: self baseline20MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'baseline25Foo:' category: 'cat' timeStamp: '' source: self baseline25MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'version20Foo:' category: 'cat' timeStamp: '' source: self version20MethodSourceFoo)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline61MethodSourceFoo ^(self class sourceCodeAt: #baseline61Foo:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline61MethodSourceProjectIssue86 ^(self class sourceCodeAt: #baseline61ProjectIssue86:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfUmbrella' stamp: 'dkh 6/12/2012 15:41:23.319'! version51MethodSourceUmbrella ^(self class sourceCodeAt: #version51Umbrella:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfLinearFoo "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfLinearFoo-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self linearProjectMethodSource). (MCMethodDefinition className: className asString selector: 'baseline20Foo:' category: 'cat' timeStamp: '' source: self baseline20MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'version20Foo:' category: 'cat' timeStamp: '' source: self version20MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'version50Foo:' category: 'cat' timeStamp: '' source: self version50MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'version51Foo:' category: 'cat' timeStamp: '' source: self version51MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'baseline60Foo:' category: 'cat' timeStamp: '' source: self baseline60MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'baseline61Foo:' category: 'cat' timeStamp: '' source: self baseline61MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'baseline62Foo:' category: 'cat' timeStamp: '' source: self baseline62MethodSourceFoo)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline20MethodSourceFoo ^(self class sourceCodeAt: #baseline20Foo:) asString ! ! !MetacelloAtomicConfigurationResource methodsFor: 'Issue 86' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline61ProjectIssue86: spec "projects and packages" "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'A' with: [ spec className: 'MetacelloTestConfigurationOfLinearFoo'; versionString: '6.1'; loads: #('1'); repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; project: 'B' with: [ spec className: 'MetacelloTestConfigurationOfLinearFoo'; versionString: '6.1'; loads: #('2'); repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloAtomicConfigurationResource methodsFor: 'ConfigurationOfAtomicFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! version50Foo: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec blessing: #release. spec package: 'GoferUmbrella' with: 'GoferUmbrella-dkh.4'; yourself ]. ! ! !MetacelloAtomicConfigurationResource class methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! project ^self new project! ! !MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! postloads postloads == nil ifTrue: [ postloads := OrderedCollection new ]. ^ postloads! ! !MetacelloAtomicLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! finalizeLoad: aGofer "load the accumulated packages (if any), reset the package list" | pkgLoads | self preloads do: [:directive | super loadPreloadDirective: directive ]. preloads := nil. (pkgLoads := self packageloads) notEmpty ifTrue: [ self loader loadingSpecLoader loadPackageDirectives: pkgLoads gofer: aGofer. self packageloads: nil ]. self postloads do: [:directive | super loadPostloadDirective: directive ]. postloads := nil! ! !MetacelloAtomicLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! directivesDo: aBlock aBlock value: self. self preloads do: [:directive | directive directivesDo: aBlock ]. self loadDirectives do: [:directive | directive directivesDo: aBlock ]. self postloads do: [:directive | directive directivesDo: aBlock ]. ! ! !MetacelloAtomicLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: aLoaderDirective gofer: aGofer self loadDirectives isEmpty ifTrue: [ ^self ]. aLoaderDirective loadAtomicLoadDirective: self gofer: aGofer. ! ! !MetacelloAtomicLoadDirective methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! loadPostloadDirective: aPostloadDirective "accumulate postloads" self postloads add: aPostloadDirective! ! !MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! packageloads packageloads == nil ifTrue: [ packageloads := OrderedCollection new ]. ^ packageloads! ! !MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! packageloads: anObject packageloads := anObject! ! !MetacelloAtomicLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! prepostLoadDirectivesDo: aBlock self preloads do: [:directive | directive prepostLoadDirectivesDo: aBlock ]. self loadDirectives do: [:directive | directive prepostLoadDirectivesDo: aBlock ]. self postloads do: [:directive | directive prepostLoadDirectivesDo: aBlock ].! ! !MetacelloAtomicLoadDirective methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! loadPreloadDirective: aPreloadDirective "accumulate preloads" self preloads add: aPreloadDirective! ! !MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! title ^'atomic load'! ! !MetacelloAtomicLoadDirective methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! loadPackageDirective: aPackageLoadDirective gofer: aGofer "accumulate packages" self packageloads add: aPackageLoadDirective! ! !MetacelloAtomicLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadAtomicLoadDirective: aLoaderDirective gofer: aGofer aLoaderDirective loadDirectives do: [:directive | directive loadUsing: self gofer: aGofer ]. ! ! !MetacelloAtomicLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadLinearLoadDirective: aLoaderDirective gofer: aGofer self finalizeLoad: aGofer. super loadLinearLoadDirective: aLoaderDirective gofer: aGofer! ! !MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! preloads preloads == nil ifTrue: [ preloads := OrderedCollection new ]. ^ preloads! ! !MetacelloAtomicLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! prepostLoadsDo: aBlock self preloads do: [:directive | directive prepostLoadDo: aBlock ]. self loadDirectives do: [:directive | directive prepostLoadDo: aBlock ]. self postloads do: [:directive | directive prepostLoadDo: aBlock ]. ! ! !MetacelloAtomicMonticelloResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpVersionReferences "self reset" versionReferences := OrderedCollection new. versionReferences add: ((GoferVersionReference name: 'GoferFan-dkh.1') -> #GoferFar); add: ((GoferVersionReference name: 'GoferBar-dkh.1') -> #Object); add: ((GoferVersionReference name: 'GoferFoo-dkh.4') -> #GoferBeau); add: ((GoferVersionReference name: 'GoferFoo-dkh.5') -> #GoferBeau); add: ((GoferVersionReference name: 'GoferBeau-dkh.15') -> #GoferBar); add: ((GoferVersionReference name: 'GoferFaux-tg.30') -> #Object); add: ((GoferVersionReference name: 'GoferFar-dkh.4') -> #GoferFoo); add: ((GoferVersionReference name: 'GoferBarDependency-dkh.4') -> #Object); add: ((GoferVersionReference name: 'GoferFooDependency-lr.4') -> #Object); add: ((GoferVersionReference name: 'GoferBarDependency-lr.30') -> #Object); add: ((GoferVersionReference name: 'GoferFooDependency-lr.30') -> #Object); add: ((GoferVersionReference name: 'GoferBarDependency-lr.35') -> #Object); add: ((GoferVersionReference name: 'GoferFooDependency-lr.35') -> #Object); yourself ! ! !MetacelloAtomicMonticelloResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpNewerDependency "self reset" | reference | reference := GoferVersionReference name: 'GoferUmbrella-lr.5'. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)) with: (MCClassDefinition name: (reference packageName copyWithout: $-) asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: ''))) dependencies: (Array with: (MCVersionDependency package: (MetacelloTestsMCPackage new name: 'GoferBarDependency') info: (monticelloRepository versionInfoFromVersionNamed: 'GoferBarDependency-lr.35')) with: (MCVersionDependency package: (MetacelloTestsMCPackage new name: 'GoferFooDependency') info: (monticelloRepository versionInfoFromVersionNamed: 'GoferFooDependency-lr.35'))))! ! !MetacelloAtomicMonticelloResource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! monticelloRepository ^ monticelloRepository! ! !MetacelloAtomicMonticelloResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpMonticelloRepository "This method builds a fake repository with the version references from #buildReferences." monticelloRepository := MCDictionaryRepository new. versionReferences do: [ :assoc | | reference superclassName | reference := assoc key. superclassName := assoc value. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)) with: (MCClassDefinition name: (reference packageName copyWithout: $-) asSymbol superclassName: superclassName category: reference packageName asSymbol instVarNames: #() comment: ''))) dependencies: #()) ]! ! !MetacelloAtomicMonticelloResource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! versionReferences ^ versionReferences! ! !MetacelloAtomicMonticelloResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUp super setUp. self setUpVersionReferences; setUpMonticelloRepository; setUpDependency; setUpNewerDependency! ! !MetacelloAtomicMonticelloResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpDependency "self reset" | reference | reference := GoferVersionReference name: 'GoferUmbrella-dkh.4'. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)) with: (MCClassDefinition name: (reference packageName copyWithout: $-) asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: ''))) dependencies: (Array with: (MCVersionDependency package: (MetacelloTestsMCPackage new name: 'GoferBarDependency') info: (monticelloRepository versionInfoFromVersionNamed: 'GoferBarDependency-lr.30')) with: (MCVersionDependency package: (MetacelloTestsMCPackage new name: 'GoferFooDependency') info: (monticelloRepository versionInfoFromVersionNamed: 'GoferFooDependency-lr.30'))))! ! !MetacelloBaseConfiguration commentStamp: 'dkh 5/30/2012 13:50'! You should be using ConfigurationOf instead of MetacelloBaseConfiguration. The class is being kept around because many extant Metacello configurations use MetacelloBaseConfiguration as a sentinel class to indicate whether or not Metacello is loaded.. Once the Metacello scripting API becomes prevalent (the api has it's own ensureMetacello logic) this class can be removed.! !MetacelloBaselineConstructor commentStamp: 'dkh 5/4/2012 17:05'! ##MetacelloBaselineConstructor **MetacelloBaselineConstructor** extracts the #baseline pragma from a **BaselineOfConfiguration** and produces a **MetacelloVersion**:. ```Smalltalk MetacelloBaselineConstructor on: BaselineOfExample ``` ! !MetacelloBaselineConstructor methodsFor: 'pragma extraction' stamp: 'dkh 6/5/2012 19:01:24'! extractBaselinePragmaFor: aClass | pragmas | pragmas := Pragma allNamed: #'baseline' in: aClass. pragmas isEmpty ifTrue: [ ^ self error: 'No #baseline pragma found' ]. ^ pragmas first! ! !MetacelloBaselineConstructor methodsFor: 'initialization' stamp: 'dkh 6/5/2012 19:01:24'! on: aConfig self calculate: aConfig project: nil! ! !MetacelloBaselineConstructor methodsFor: 'private' stamp: 'dkh 6/18/2012 15:05'! calculate: aConfig project: aProject | pragma versionMap versionSpec | self configuration: aConfig. pragma := self extractBaselinePragmaFor: aConfig class. self setProject: (aProject ifNil: [ [ aConfig class project ] on: MessageNotUnderstood do: [ :ex | ex return: nil ] ]). versionSpec := self project versionSpec. self root: versionSpec. self evaluatePragma: pragma. versionMap := Dictionary new. self project attributes do: [ :attribute | | blockList | (blockList := self attributeMap at: attribute ifAbsent: [ ]) ~~ nil ifTrue: [ blockList do: [ :block | self with: versionSpec during: block ] ] ]. versionSpec versionString: self project singletonVersionName. versionMap at: versionSpec versionString put: versionSpec createVersion. self project map: versionMap. self project configuration: aConfig! ! !MetacelloBaselineConstructor methodsFor: 'initialization' stamp: 'dkh 6/5/2012 19:01:24'! on: aConfig project: aProject self calculate: aConfig project: aProject! ! !MetacelloBaselineConstructor methodsFor: '*metacello-mc-accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectClass ^ MetacelloMCBaselineProject! ! !MetacelloBaselineConstructor class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! on: aConfig ^ self new on: aConfig; yourself! ! !MetacelloBaselineConstructor class methodsFor: 'instance creation' stamp: 'dkh 6/18/2012 14:49'! on: aConfig project: aProject ^ self new on: aConfig project: aProject; yourself! ! !MetacelloBaselineSpecGenerator methodsFor: 'accessing' stamp: 'dkh 7/16/2012 11:28'! projectSpecLookupBlock ^ [ :projectName | {(MetacelloProjectRegistration projectSpecForClassNamed: (MetacelloScriptEngine baselineNameFrom: projectName) ifAbsent: [ ])} ]! ! !MetacelloBaselineSpecGenerator methodsFor: 'accessing' stamp: 'dkh 7/16/2012 10:43'! projectSpecCreationBlock ^ [ :projectName | {(MetacelloMCBaselineProject new baselineOfProjectSpec name: projectName)} ]! ! !MetacelloBaselineSpecGenerator methodsFor: 'accessing' stamp: 'dkh 7/16/2012 10:44'! projectSpecListBlock ^ [ MetacelloProjectRegistration baselineProjectSpecs ]! ! !MetacelloCachingGoferResolvedReference methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! workingCopy "Answer a working copy or throw an error if not present." | pName | cachedVersion == nil ifTrue: [ ^super workingCopy ]. pName := cachedVersion package name. ^MCWorkingCopy allManagers detect: [ :each | pName = each packageName ] ifNone: [ self error: 'Working copy for ' , self name , ' not found' ]! ! !MetacelloCachingGoferResolvedReference methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! version "Answer a Monticello version of the receiver." cachedVersion == nil ifTrue: [ cachedVersion := super version ]. ^cachedVersion! ! !MetacelloCannotUpdateReleasedVersionError methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! isResumable "Determine whether an exception is resumable." ^ true! ! !MetacelloCleanNotification methodsFor: 'signaling' stamp: 'dkh 6/5/2012 19:01:24'! signal: aMetacelloVersion self version: aMetacelloVersion. ^ self signal! ! !MetacelloCleanNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! version: anObject version := anObject! ! !MetacelloCleanNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! version ^ version! ! !MetacelloCleanNotification class methodsFor: 'exceptioninstantiator' stamp: 'dkh 6/5/2012 19:01:24'! signal: aMetacelloVersion ^ self new signal: aMetacelloVersion! ! !MetacelloClearStackCacheNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! cacheNames ^ cacheNames! ! !MetacelloClearStackCacheNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! cacheNames: anArray cacheNames := anArray! ! !MetacelloClearStackCacheNotification methodsFor: 'signaling' stamp: 'dkh 6/5/2012 19:01:24'! signal: anArray "Signal the occurrence of an exceptional condition with a specified cacheName." self cacheNames: anArray. ^ self signal! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! ignoreImage ^self loaderPolicy ignoreImage! ! !MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! doingLoads: aBlock "escape mechanism for recording and null loaders to skip doing loaderlike things" aBlock value! ! !MetacelloCommonMCSpecLoader methodsFor: 'packages' stamp: 'dkh 6/8/2012 14:04:22'! nameComponentsFrom: aVersionName ^self class nameComponentsFrom: aVersionName! ! !MetacelloCommonMCSpecLoader methodsFor: 'versionInfo' stamp: 'dkh 6/8/2012 14:04:22'! currentVersionInfoFor: packageSpec | cacheKey vi | cacheKey := packageSpec file. ^MetacelloPlatform current stackCacheFor: #currentVersionInfo at: cacheKey doing: [ :cache | vi := packageSpec currentVersionInfo. cache at: cacheKey put: vi ]. ! ! !MetacelloCommonMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! resolvePackageSpecReferences: packageSpec gofer: gofer | versionReference references localGofer | localGofer := gofer. self hasRepositoryOverrides not ifTrue: [ packageSpec repositorySpecs notEmpty ifTrue: [ localGofer := MetacelloGofer new. (self repositoriesFrom: packageSpec repositorySpecs) do: [:repo | localGofer repository: repo ]]]. (packageSpec getFile == nil or: [ self shouldDisablePackageCache ]) ifTrue: [ "don't use package-cache when trying to get latest version" localGofer disablePackageCache ]. versionReference := packageSpec goferLoaderReference. references := versionReference resolveAllWith: localGofer. localGofer enablePackageCache. ^references! ! !MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadPackageDirectives: pkgLoads gofer: aGofer MetacelloPlatform current do: [ | goferLoad loadBlock answers | goferLoad := MetacelloGoferLoad on: aGofer. answers := OrderedCollection new. pkgLoads do: [:packageLoadDirective | | resolvedReference | aGofer disablePackageCache. "for good luck:)" (resolvedReference := self resolvePackageSpec: packageLoadDirective spec gofer: aGofer) ~~ nil ifTrue: [ goferLoad addResolved: resolvedReference. answers addAll: packageLoadDirective spec answers. packageLoadDirective resolvedReference: resolvedReference ]]. Transcript cr; show: 'Starting atomic load'. loadBlock := [ "pkgLoads do: [:packageLoadDirective | mcLoader preLoad: packageLoadDirective spec ]." goferLoad execute. pkgLoads do: [:packageLoadDirective | packageLoadDirective resolvedReference == nil ifTrue: [ Transcript cr; tab; show: 'Already Loaded -> ', packageLoadDirective file ] ifFalse: [ Transcript cr; tab; show: 'Loaded -> ', packageLoadDirective file, ' --- ', packageLoadDirective repository description, ' --- ', packageLoadDirective resolvedReference repository description. packageLoadDirective resolvedReference workingCopy repositoryGroup addRepository: packageLoadDirective repository ]]. MetacelloPlatform current clearCurrentVersionCache. "pkgLoads do: [:packageLoadDirective | packageLoadDirective resolvedReference ~~ nil ifTrue: [mcLoader postLoad: packageLoadDirective spec ]]"]. answers notEmpty ifTrue: [ loadBlock valueSupplyingMetacelloAnswers: answers ] ifFalse: [ loadBlock value]. Transcript cr; show: 'Finished atomic load' ] displaying: 'Atomic Load...'. ! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadingSpecLoader ^self! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! shouldDisablePackageCache disablePackageCache == nil ifTrue: [ disablePackageCache := false ]. ^ disablePackageCache! ! !MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! linearLoadPackageSpec: packageSpec gofer: gofer self subclassResponsibility! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! operator: aSymbol operator := aSymbol! ! !MetacelloCommonMCSpecLoader methodsFor: 'initialize-release' stamp: 'dkh 6/8/2012 14:04:22'! initialize self loaderPolicy! ! !MetacelloCommonMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! linearLoadPackageSpecs: packageSpecs repositories: repositories | gofer | gofer := MetacelloGofer new. repositories do: [:repo | gofer repository: repo ]. packageSpecs do: [:pkg | pkg loadUsing: self gofer: gofer ]. ! ! !MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: 'dkh 7/5/2012 20:26'! loadPackageDirective: aPackageLoadDirective gofer: aGofer | packageSpec | packageSpec := aPackageLoadDirective spec. MetacelloPlatform current do: [ | loadBlock goferLoad answers resolvedReference | aGofer disablePackageCache. "for good luck:)" resolvedReference := self resolvePackageSpec: packageSpec gofer: aGofer. resolvedReference isNil ifTrue: [ "Package version already loaded into image" ^ self ]. loadBlock := [ "mcLoader preLoad: packageSpec." goferLoad := MetacelloGoferLoad on: aGofer. goferLoad addResolved: resolvedReference. goferLoad execute. MetacelloPlatform current clearCurrentVersionCache "mcLoader postLoad: packageSpec" ]. (answers := packageSpec answers) notEmpty ifTrue: [ loadBlock valueSupplyingMetacelloAnswers: answers ] ifFalse: [ loadBlock value ]. resolvedReference workingCopy repositoryGroup addRepository: aPackageLoadDirective repository. Transcript cr; show: 'Loaded -> ' , resolvedReference name , ' --- ' , aPackageLoadDirective repository description , ' --- ' , resolvedReference repository description ] displaying: 'Loading ' , packageSpec file! ! !MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! load | repos | repos := self repositoriesFrom: self spec repositorySpecs. ^ self loadType == #atomic ifTrue: [self atomicLoadPackageSpecs: self spec packageSpecsInLoadOrder repositories: repos] ifFalse: ["assume #linear" self linearLoadPackageSpecs: self spec packageSpecsInLoadOrder repositories: repos ] ! ! !MetacelloCommonMCSpecLoader methodsFor: 'versionInfo' stamp: 'dkh 6/8/2012 14:04:22'! ancestorsFor: packageSpec | cacheKey vi | cacheKey := packageSpec file. ^MetacelloPlatform current stackCacheFor: #ancestors at: cacheKey doing: [ :cache | vi := packageSpec ancestors. cache at: cacheKey put: vi ]. ! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loaderPolicy: anObject loaderPolicy := anObject! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! recordingSpecLoader ^(MetacelloNullRecordingMCSpecLoader on: self spec) shouldDisablePackageCache: self shouldDisablePackageCache; loaderPolicy: self loaderPolicy copy; yourself! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repositoryMap ^self loaderPolicy repositoryMap! ! !MetacelloCommonMCSpecLoader methodsFor: 'repositories' stamp: 'dkh 6/8/2012 14:04:22'! repositoriesFrom: aMetacelloMVRepositorySpecs ^self repositoriesFrom: aMetacelloMVRepositorySpecs ignoreOverrides: false! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! operator operator == nil ifTrue: [ ^#= ]. ^operator! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! fetchingSpecLoader ^self! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! shouldDisablePackageCache: anObject disablePackageCache := anObject! ! !MetacelloCommonMCSpecLoader methodsFor: 'repositories' stamp: 'dkh 6/8/2012 14:04:22'! repositoriesFrom: aMetacelloMVRepositorySpecs ignoreOverrides: ignoreOverrides | repositories repos | (ignoreOverrides not and: [self hasRepositoryOverrides]) ifTrue: [ ^self loaderPolicy overrideRepositories ]. repositories := MCRepositoryGroup default repositories. repos := OrderedCollection new. aMetacelloMVRepositorySpecs do: [:aSpec | | description repo | description := aSpec description. (repo := repositories detect: [:rep | rep description = description ] ifNone: [ aSpec createRepository ]) ~~ nil ifTrue: [ repos add: repo ]]. ^repos ! ! !MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! doLoad self subclassResponsibility! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! ensureSpecLoader ^ self! ! !MetacelloCommonMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/17/2012 19:52'! retryingResolvePackageSpecReferences: packageSpec gofer: gofer | retryCount references repositoryError | retryCount := 0. references := #(). [ references isEmpty and: [ retryCount < 3 ] ] whileTrue: [ retryCount > 0 ifTrue: [ Transcript cr; show: '...RETRY->' , packageSpec file ]. references := [ self resolvePackageSpecReferences: packageSpec gofer: gofer ] on: Error , GoferRepositoryError do: [ :ex | self class retryPackageResolution ifFalse: [ ex pass ]. retryCount >= 2 ifTrue: [ (ex isKindOf: GoferRepositoryError) ifTrue: [ "ignore repository errors at this point, in case an alternate repository is in the list " Transcript cr; show: 'gofer repository error: ' , ex description printString , '...ignoring'. repositoryError := ex. ex resume: #() ] ifFalse: [ ex pass ] ]. ex return: #() ]. retryCount := retryCount + 1 ]. references isEmpty ifTrue: [ Transcript cr; show: '...FAILED->' , packageSpec file. (MetacelloPackageSpecResolutionError new packageSpec: packageSpec; repositories: gofer repositories; repositoryError: repositoryError; yourself) signal ]. ^ references! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loaderPolicy loaderPolicy == nil ifTrue: [ loaderPolicy := MetacelloLoaderPolicy new ]. ^loaderPolicy! ! !MetacelloCommonMCSpecLoader methodsFor: 'doits' stamp: 'dkh 6/8/2012 14:04:22'! preLoad: packageOrVersionSpec self subclassResponsibility! ! !MetacelloCommonMCSpecLoader methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! hasRepositoryOverrides ^self loaderPolicy hasRepositoryOverrides! ! !MetacelloCommonMCSpecLoader methodsFor: 'doits' stamp: 'dkh 6/8/2012 14:04:22'! postLoad: packageOrVersionSpec "subclassResponsibility, but it gets called during an upgrade, so leave it as NOOP"! ! !MetacelloCommonMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! resolvePackageSpec: packageSpec gofer: gofer | references resolvedReference mcVersion loadedVersionInfos | references := self retryingResolvePackageSpecReferences: packageSpec gofer: gofer. resolvedReference := references last asMetacelloCachingResolvedReference. mcVersion := resolvedReference version. (loadedVersionInfos := self ancestorsFor: packageSpec) ~~ nil ifTrue: [ loadedVersionInfos do: [:info | info name = mcVersion info name ifTrue: [ "package already loaded, don't load again" ^nil ]]]. ^resolvedReference! ! !MetacelloCommonMCSpecLoader methodsFor: 'testing' stamp: 'dkh 07/28/2013 16:10'! ensureForDevelopment ^ true! ! !MetacelloCommonMCSpecLoader class methodsFor: 'accessing' stamp: 'dkh 6/17/2012 19:51'! retryPackageResolution "if true, errors during #retryingResolvePackageSpecReferences:gofer: are caught and the resolution is retried 3 times. After the thrid time, a MetacelloPackageSpecResolutionError is thrown if false, an error during #retryingResolvePackageSpecReferences:gofer: will be passed, likely resulting in a walkback ... useful for debugging." RetryPackageResolution ifNil: [ RetryPackageResolution := true ]. ^ RetryPackageResolution! ! !MetacelloCommonMCSpecLoader class methodsFor: 'accessing' stamp: 'dkh 6/17/2012 19:48'! retryPackageResolution: aBool RetryPackageResolution := aBool! ! !MetacelloCommonMCSpecLoader class methodsFor: 'utilities' stamp: 'dkh 6/8/2012 14:04:22'! nameComponentsFrom: aVersionName | ar | ar := (aVersionName last isDigit and: [ (aVersionName indexOf: $.) > 0 ])ifFalse: [Array with: aVersionName with: '' with: 0 with: aVersionName with: self] ifTrue: [ | vrsn str | str := ((aVersionName copyAfterLast: $-) copyAfterLast: $.). vrsn := str isEmpty ifTrue: [0] ifFalse: [str asInteger]. Array with: (aVersionName copyUpToLast: $-) "base pkg name" with: ((aVersionName copyAfterLast: $-) copyUpTo: $.) "user" with: vrsn "version" with: aVersionName with: self ]. ^ar! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'test alpha/numeric version numbers' stamp: 'dkh 6/22/2012 14:40'! testAlphaNumericVersion2 self assert: ((self versionClass fromString: '2.9.0-alpha.2') < (self versionClass fromString: '2.9.0-alpha.3')). ! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'test alpha/numeric version numbers' stamp: 'dkh 6/22/2012 14:40'! testAlphaNumericVersion4 self assert: ((self versionClass fromString: '2.9.9-alpha.2') < (self versionClass fromString: '2.9.9')). ! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 14:36'! testVersion04 | v1 v2 | v1 := self versionClass fromString: '1.0.1'. v2 := self versionClass fromString: '1.0.0'. self assert: (v1 > v2)! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 14:39'! testVersion22 self assert: (MetacelloVersionNumber fromString: '3.0.0') collapseZeros size = 1. self assert: (MetacelloVersionNumber fromString: '3.0.0') = (MetacelloVersionNumber fromString: '3.0'). self assert: (MetacelloVersionNumber fromString: '3.0') = (MetacelloVersionNumber fromString: '3.0.0'). ! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'test alpha/numeric version numbers' stamp: 'dkh 6/22/2012 15:02'! testAlphaNumericVersion1 "Use numeric comparison for pure numbers. If you non-numeric version separate with '-'" | x y | self assert: ((x := self versionClass fromString: '2.9.0') < (y := self versionClass fromString: '2.10.0')). ! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'private' stamp: 'dkh 6/22/2012 12:13'! versionClass ^ self subclassResponsibility! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'test alpha/numeric version numbers' stamp: 'dkh 6/22/2012 14:40'! testAlphaNumericVersion3 self assert: ((self versionClass fromString: '2.9.9-alpha.2') < (self versionClass fromString: '2.9.10')). ! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 14:39'! testVersion25 self assert: ((MetacelloVersionNumber fromString: '1.0-beta.24.0.1') < (MetacelloVersionNumber fromString: '1.0-beta.28')). ! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 14:36'! testVersion02 | v1 v2 | v1 := self versionClass fromString: '1.1.1'. v2 := self versionClass fromString: '1.0.0'. self assert: (v1 = v1). self assert: (v2 = v2). self assert: (v1 > v2)! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 14:36'! testVersion01 self assert: ((self versionClass fromString: '1.1.1') versionString = '1.1.1')! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 14:37'! testVersion14 self assert: ((self versionClass fromString: '2.9.0-alpha02') < (self versionClass fromString: '2.9.0-alpha03')). ! ! !MetacelloCommonVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 14:39'! testVersion23 self assert: (MetacelloVersionNumber fromString: '3.0.0.-rc.1') = (MetacelloVersionNumber fromString: '3.0.0-rc.1'). self assert: (MetacelloVersionNumber fromString: '3.0') > (MetacelloVersionNumber fromString: '3.0-rc.1'). self assert: (MetacelloVersionNumber fromString: '3') > (MetacelloVersionNumber fromString: '3-rc.1'). self assert: (MetacelloVersionNumber fromString: '3.-rc.1') = (MetacelloVersionNumber fromString: '3.0.0-rc.1'). self assert: (MetacelloVersionNumber fromString: '3.0.-rc.1') = (MetacelloVersionNumber fromString: '3.0.0-rc.1'). self assert: (MetacelloVersionNumber fromString: '3') > (MetacelloVersionNumber fromString: '3.0-rc.1'). self assert: (MetacelloVersionNumber fromString: '3.0') > (MetacelloVersionNumber fromString: '3.0.0-rc.1'). ! ! !MetacelloCommonVersionNumberTestCase class methodsFor: 'testing' stamp: 'dkh 6/22/2012 12:13'! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^ self name = #'MetacelloCommonVersionNumberTestCase'! ! !MetacelloConfigTemplate commentStamp: ''! Copy me to create a new configuration or edit and evaluate the following doits. "Create configuration class and initial baseline method" MetacelloToolBox createBaseline: '1.0-baseline' for: 'MyProject' repository: 'http://www.example.com/MyProjectRepository' requiredProjects: #('Gofer') packages: #('MyProject-Core' 'MyProject-Tests') dependencies: {('MyProject-Core' -> #('Gofer')). ('MyProject-Tests' -> #('MyProject-Core'))} groups: {('default' -> #('Core')). ('Core' -> #('MyProject-Core')). ('Tests' -> #('MyProject-Tests'))}. "create initial development method from the baseline" MetacelloToolBox createDevelopment: '1.0' for: 'MyProject' importFromBaseline: '1.0-baseline' description: 'initial version'. ! !MetacelloConfigTemplate methodsFor: 'accessing' stamp: 'SeanDeNigris 7/12/2012 09:41'! customProjectAttributes "Edit to return a collection of any custom attributes e.g. for conditional loading: Array with: #'Condition1' with: #'Condition2. For more information see: http://code.google.com/p/metacello/wiki/CustomProjectAttrributes" ^ #().! ! !MetacelloConfigTemplate methodsFor: 'accessing' stamp: 'CamilloBruni 1/10/2014 17:25'! project ^ project ifNil: [ "Bootstrap Metacello if it is not already loaded" (self class baseConfigurationClassIfAbsent: []) ensureMetacello. "Construct Metacello project" project := MetacelloMCProject new projectAttributes: self customProjectAttributes. (Smalltalk at: #MetacelloVersionConstructor) on: self project: project. project loadType: #linear. "change to #atomic if desired" project ]! ! !MetacelloConfigTemplate class methodsFor: 'private' stamp: 'DaleHenrichs 11/2/2010 16:51'! baseConfigurationClassIfAbsent: aBlock ^Smalltalk at: #MetacelloBaseConfiguration ifAbsent: [ self ensureMetacelloBaseConfiguration. Smalltalk at: #MetacelloBaseConfiguration ifAbsent: aBlock ]. ! ! !MetacelloConfigTemplate class methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! validate "Check the configuration for Errors, Critical Warnings, and Warnings (see class comment for MetacelloMCVersionValidator for more information). Errors identify specification issues that will result in unexpected behaviour when you load the configuration. Critical Warnings identify specification issues that may result in unexpected behavior when you load the configuration. Warnings identify specification issues that are technically correct, but are worth take a look at." "self validate" self ensureMetacello. ^ ((Smalltalk at: #MetacelloToolBox) validateConfiguration: self debug: #() recurse: false) explore! ! !MetacelloConfigTemplate class methodsFor: 'metacello tool support' stamp: 'dkh 6/8/2012 14:04:22'! isMetacelloConfig "Answer true and the Metacello tools will operate on you" ^true! ! !MetacelloConfigTemplate class methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! loadBleedingEdge "Load the latest versions of the mcz files defined for this project. It is not likely that the #bleedingEdge has been tested." "self loadBleedingEdge" ^(self project version: #bleedingEdge) load! ! !MetacelloConfigTemplate class methodsFor: 'private' stamp: 'DaleHenrichs 11/4/2010 10:23'! ensureMetacelloBaseConfiguration Smalltalk at: #MetacelloBaseConfiguration ifAbsent: [ | repository version | repository := MCHttpRepository location: 'http://seaside.gemstone.com/ss/metacello' user: '' password: ''. repository versionReaderForFileNamed: 'Metacello-Base-DaleHenrichs.2.mcz' do: [ :reader | version := reader version. version load. version workingCopy repositoryGroup addRepository: repository ] ]! ! !MetacelloConfigTemplate class methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! load "Load the #stable version defined for this platform. The #stable version is the version that is recommended to be used on this platform." "self load" ^(self project version: #stable) load! ! !MetacelloConfigTemplate class methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! DevelopmentSupport "See the methods in the 'development support' category on the class-side of MetacelloBaseConfiguration. Decide what development support methods you would like to use and copy them the the class-side of your configuration." ! ! !MetacelloConfigTemplate class methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! project ^self new project! ! !MetacelloConfigTemplate class methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! ensureMetacello (self baseConfigurationClassIfAbsent: []) ensureMetacello! ! !MetacelloConfigTemplate class methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! loadDevelopment "Load the #development version defined for this platform. The #development version will change over time and is not expected to be stable." "self loadDevelopment" ^(self project version: #development) load! ! !MetacelloConfigTemplateExample commentStamp: ''! Copy me to create a new configuration or edit and evaluate the following doits. "Create configuration class and initial baseline method" MetacelloToolBox createBaseline: '1.0-baseline' for: 'MyProject' repository: 'http://www.example.com/MyProjectRepository' requiredProjects: #('Gofer') packages: #('MyProject-Core' 'MyProject-Tests') dependencies: {('MyProject-Core' -> #('Gofer')). ('MyProject-Tests' -> #('MyProject-Core'))} groups: {('default' -> #('Core')). ('Core' -> #('MyProject-Core')). ('Tests' -> #('MyProject-Tests'))}. "create initial development method from the baseline" MetacelloToolBox createDevelopment: '1.0' for: 'MyProject' importFromBaseline: '1.0-baseline' description: 'initial version'. ! !MetacelloConfigTemplateExample methodsFor: 'baselines' stamp: 'ChristopheDemarey 1/15/2014 11:32'! baseline10: spec "Baselines are used by convention in Metacello and essentially are nothing else than normal versions. Name the baseline after the first version it was introduced. In this case 1.0-baseline was introduced the first time with the 1.0 version defined in the #version10 method. Metacello only uses the following tag to figure out the name of this baseline:" "Using #common makes this dependency declaration available for all Smalltalks. If you need more fine-grained control you can add several #for:do: sections for other releases." spec for: #common do: [ spec blessing: #baseline. "specify the default repository for your project's packages" spec repository: 'http://smalltalkhub.com/mc/JohnDoe/MyProject/main'. "use separate methods for external projects" self fuelMetalevel: spec; fileSystemLegacy: spec. "specify the dependencies between packages and projects" spec "a package without dependencies:" package: 'MyProject-Core'; package: 'MyProject-Tests' with: [ "Specfiy dependencies using the #requires: directive, you can refer to any name here, in this case to an external project" spec requires: #('MyProject-Core' 'FuelMetalevel' 'FileSystemLegacy')]. "using groups certain packages and projects can be loaded conditionally" spec "load the tests by default" group: 'default' with: #('core' 'test'); group: 'test' with: #('MyProject-Tests'); group: 'core' with: #('MyProject-Core')]! ! !MetacelloConfigTemplateExample methodsFor: 'versions' stamp: 'ChristopheDemarey 1/15/2014 11:32'! versionDevelopment: spec "version specification for the current development branch, see #version10 for a complete explanation of a version declaration. In this case the 'dev' version uses the same baselin as version '1.0':" "Update this configuration regulrarly with intermediate releases. If a version is more stable or should stay accessible copy this 'dev' definition and give it a proper version name on its own. For example, in this case you might want to split a new version '1.1' by copying over this definition." spec for: #common do: [ spec description: 'Development Version'; blessing: #development; author: 'John Doe'; timestamp: '2013-05-09'. spec package: 'MyProject-Core' with: 'MyProject-Core-JohnDoe.152'; package: 'MyProject-Tests' with: 'MyProject-Tests-JohnDoe.173'; "note that for the 'dev' version we rely on the #development version of the external FuleMetalevel project" project: 'FuelMetalevel' with: #development ].! ! !MetacelloConfigTemplateExample methodsFor: 'accessing' stamp: 'ChristopheDemarey 1/15/2014 11:32'! customProjectAttributes "Edit to return a collection of any custom attributes e.g. for conditional loading: Array with: #'Condition1' with: #'Condition2. For more information see: http://code.google.com/p/metacello/wiki/CustomProjectAttrributes" ^ #().! ! !MetacelloConfigTemplateExample methodsFor: 'tags' stamp: 'ChristopheDemarey 1/15/2014 11:32'! stable: spec "Symbolic versions can be used to introduce an indirection to a version number. The real name used by Metacello is only defined by the following pragma:" "If another version is stable for a differen Smalltalk use a specific name" "spec for: #'pharo1.4.x' version: '0.9'" "Specfiy which exact version you want to load" spec for: #'common' version: '1.0'. ! ! !MetacelloConfigTemplateExample methodsFor: 'tags' stamp: 'ChristopheDemarey 1/15/2014 11:32'! development: spec "By convention the development branch should point to a fixed version that is regularly updated and might contain unstable code. The name used by Metacello is only defined by the following pragma:" "For the development tag refer to a fixed version which you update if you commit new code. Note that you can refer here to any other version name from this configuration" spec for: #'common' version: 'dev'. ! ! !MetacelloConfigTemplateExample methodsFor: 'external projects' stamp: 'ChristopheDemarey 1/15/2014 11:32'! fuelMetalevel: spec "Specify a dependency on an external project which has it's own configuration. The given project name can be chosen freely, for simplicity use the same name as the configuration or the conditional group you load." spec project: 'FuelMetalevel' with: [ spec repository: 'http://ss3.gemstone.com/ss/Fuel'; className: 'ConfigurationOfFuel'; "if you want to load by default a special group usse the #loads: message plus a group name of the external configuration" loads: #FuelMetalevel ].! ! !MetacelloConfigTemplateExample methodsFor: 'external projects' stamp: 'ChristopheDemarey 1/15/2014 11:32'! fileSystemLegacy: spec "This is an example of an external project which does not have a configuration yet. Note that the package name is only used in the Metacello configuration and does not have be exactly the same as the Monticello project/version name." spec package: 'FileSystemLegacy' with: [ spec repository: 'http://smalltalkhub.com/mc/PharoExtras/FileSystemLegacy/main'; "if you do not specify a version, automatically the newest version is chose." file: 'FileSystem-Legacy-JohanBrichau.2' ]! ! !MetacelloConfigTemplateExample methodsFor: 'accessing' stamp: 'ChristopheDemarey 1/15/2014 11:32'! project ^ project ifNil: [ "Bootstrap Metacello if it is not already loaded" (self class baseConfigurationClassIfAbsent: []) ensureMetacello. "Construct Metacello project" project := MetacelloMCProject new projectAttributes: self customProjectAttributes. (Smalltalk at: #MetacelloVersionConstructor) on: self project: project. project loadType: #linear. "change to #atomic if desired" project ]! ! !MetacelloConfigTemplateExample methodsFor: 'versions' stamp: 'ChristopheDemarey 1/15/2014 11:32'! version10: spec "The name for this version is solely defined by the following pragma:" "Baselines are used to define more complex setups for your project. If you want to use external projects and have fine-graind control of the dependencies between packages use the #imports: part. See the #baseline10: for more details." "Using #for:do: with the #common release specifier the following version declaration is valid for all platforms." spec for: #common do: [ spec description: 'Version 1.0 the current stable release'; blessing: #release; author: 'John Doe'; timestamp: '2013-05-01'. "Specify the versions for each package and external project defined in the baseline, here the 1.0-baseline defined in the baseline10 method." spec "For standard Monticello packages simply refere to the full version name without the extension:" package: 'MyProject-Core' with: 'MyProject-Core-JohnDoe.52'; package: 'MyProject-Tests' with: 'MyProject-Tests-JohnDoe.73'; "External projects versions are specified using #project:with:. Note the project name referes to the name used in the Metacello declaration. FuelMetalevel is defined in the #fuelMetalevel: method." project: 'FuelMetalevel' with: #stable ]. "If you want to specify different version on other platforms add another #for:do: block with a different version identifier."! ! !MetacelloConfigTemplateExample class methodsFor: 'private' stamp: 'ChristopheDemarey 1/15/2014 11:32'! baseConfigurationClassIfAbsent: aBlock ^Smalltalk at: #MetacelloBaseConfiguration ifAbsent: [ self ensureMetacelloBaseConfiguration. Smalltalk at: #MetacelloBaseConfiguration ifAbsent: aBlock ]. ! ! !MetacelloConfigTemplateExample class methodsFor: 'development support' stamp: 'ChristopheDemarey 1/15/2014 11:32'! validate "Check the configuration for Errors, Critical Warnings, and Warnings (see class comment for MetacelloMCVersionValidator for more information). Errors identify specification issues that will result in unexpected behaviour when you load the configuration. Critical Warnings identify specification issues that may result in unexpected behavior when you load the configuration. Warnings identify specification issues that are technically correct, but are worth take a look at." "self validate" self ensureMetacello. ^ ((Smalltalk at: #MetacelloToolBox) validateConfiguration: self debug: #() recurse: false) explore! ! !MetacelloConfigTemplateExample class methodsFor: 'metacello tool support' stamp: 'ChristopheDemarey 1/15/2014 11:32'! isMetacelloConfig "Answer true and the Metacello tools will operate on you" ^true! ! !MetacelloConfigTemplateExample class methodsFor: 'loading' stamp: 'ChristopheDemarey 1/15/2014 11:32'! loadBleedingEdge "Load the latest versions of the mcz files defined for this project. It is not likely that the #bleedingEdge has been tested." "self loadBleedingEdge" ^(self project version: #bleedingEdge) load! ! !MetacelloConfigTemplateExample class methodsFor: 'private' stamp: 'ChristopheDemarey 1/15/2014 11:32'! ensureMetacelloBaseConfiguration Smalltalk at: #MetacelloBaseConfiguration ifAbsent: [ | repository version | repository := MCHttpRepository location: 'http://seaside.gemstone.com/ss/metacello' user: '' password: ''. repository versionReaderForFileNamed: 'Metacello-Base-DaleHenrichs.2.mcz' do: [ :reader | version := reader version. version load. version workingCopy repositoryGroup addRepository: repository ] ]! ! !MetacelloConfigTemplateExample class methodsFor: 'loading' stamp: 'ChristopheDemarey 1/15/2014 11:32'! load "Load the #stable version defined for this platform. The #stable version is the version that is recommended to be used on this platform." "self load" ^(self project version: #stable) load! ! !MetacelloConfigTemplateExample class methodsFor: 'development support' stamp: 'ChristopheDemarey 1/15/2014 11:32'! DevelopmentSupport "See the methods in the 'development support' category on the class-side of MetacelloBaseConfiguration. Decide what development support methods you would like to use and copy them the the class-side of your configuration." ! ! !MetacelloConfigTemplateExample class methodsFor: 'accessing' stamp: 'ChristopheDemarey 1/15/2014 11:32'! project ^self new project! ! !MetacelloConfigTemplateExample class methodsFor: 'private' stamp: 'ChristopheDemarey 1/15/2014 11:32'! ensureMetacello (self baseConfigurationClassIfAbsent: []) ensureMetacello! ! !MetacelloConfigTemplateExample class methodsFor: 'loading' stamp: 'ChristopheDemarey 1/15/2014 11:32'! loadDevelopment "Load the #development version defined for this platform. The #development version will change over time and is not expected to be stable." "self loadDevelopment" ^(self project version: #development) load! ! !MetacelloConfigurationBrowser commentStamp: ''! Metacello is a configuration language for packages. It allows one to define dependencies between packages as well as between complete projects. MetacelloConfigurationBrowser is simple tool to browse and load Metacello configurations from particular repositories typically named 'MetaRepoForPharoXY' (where X denotes the Pharo major version and Y denotes the minor version. e.g. MetaRepoForPharo30 is Pharo 3.0) MetaRepoForPharoXY is the short form of MetacelloRepositoriesForPharoXY since the source limits the length of the project name. The default repository is configured by #pharoDistributionRepository as...! !MetacelloConfigurationBrowser methodsFor: 'initialize-release' stamp: 'tbn 6/19/2013 21:47'! initialExtent ^ (400 min: (World extent x)) @ (350 min: (World extent y))! ! !MetacelloConfigurationBrowser methodsFor: 'icons' stamp: 'TorstenBergmann 2/12/2014 09:34'! taskbarIcon ^ Smalltalk ui icons configIcon! ! !MetacelloConfigurationBrowser methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 22:56'! initialize super initialize. self windowIcon: self taskbarIcon. ! ! !MetacelloConfigurationBrowser methodsFor: 'accessing' stamp: 'tbn 6/20/2013 08:14'! toolbarModel ^ toolbarModel! ! !MetacelloConfigurationBrowser methodsFor: 'accessing' stamp: 'BenComan 12/18/2013 00:47'! aboutText ^ super aboutText, String crlf, MetacelloConfigurationBrowserPane pharoDistributionRepository . ! ! !MetacelloConfigurationBrowser methodsFor: 'initialize-release' stamp: 'TorstenBergmann 7/4/2013 08:44'! initializeWidgets self instantiateModels: #( configBrowserModel #MetacelloConfigurationBrowserPane toolbarModel #MetacelloConfigurationBrowserToolbar). ! ! !MetacelloConfigurationBrowser methodsFor: 'actions' stamp: 'TorstenBergmann 7/3/2013 21:28'! installConfiguration configBrowserModel installConfiguration! ! !MetacelloConfigurationBrowser methodsFor: 'actions' stamp: 'TorstenBergmann 7/3/2013 21:29'! loadConfiguration configBrowserModel loadConfiguration! ! !MetacelloConfigurationBrowser methodsFor: 'accessing' stamp: 'TorstenBergmann 7/3/2013 20:59'! configBrowserModel ^ configBrowserModel! ! !MetacelloConfigurationBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/7/2013 11:46'! configurationSearchField ^ SearchMorph new model: self; setIndexSelector: #configurationSearchAccept:; updateSelector: #configurationSearchAccept:; searchList: self class configurationSearchList; asSpecAdapter! ! !MetacelloConfigurationBrowser methodsFor: 'accessing' stamp: 'TorstenBergmann 7/17/2013 14:18'! configurationSearchAccept: aString aString isEmptyOrNil ifTrue: [ self configBrowserModel configurationPattern: nil ] ifFalse: [ self configBrowserModel configurationPattern: ([ aString asRegexIgnoringCase ] on: RegexSyntaxError do: [ aString ])]. ! ! !MetacelloConfigurationBrowser class methodsFor: 'specs' stamp: 'TorstenBergmann 7/17/2013 13:37'! defaultSpec | delta searchBarOffset | searchBarOffset := 5 + StandardFonts defaultFont height + 10. delta := 25. ^ SpecLayout composed add: #configBrowserModel origin: 0@0 corner: 1@1 offsetOrigin: 0@searchBarOffset offsetCorner: 0@(delta negated); add: #toolbarModel origin: 0@1 corner: 1@1 offsetOrigin: 0@(delta negated) offsetCorner: 0@0; add: #configurationSearchField origin: 0@0 corner: 1@0 offsetOrigin: 0@0 offsetCorner: 0@searchBarOffset; yourself! ! !MetacelloConfigurationBrowser class methodsFor: 'private accessing' stamp: 'CamilloBruni 7/17/2013 22:21'! configurationSearchList ^ configurationSearchList ifNil: [ configurationSearchList := OrderedCollection new ].! ! !MetacelloConfigurationBrowser class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 9/5/2013 14:33'! open ^ self new openWithSpec; yourself ! ! !MetacelloConfigurationBrowser class methodsFor: 'registration' stamp: 'TorstenBergmann 2/12/2014 09:34'! menuCommandOn: aBuilder (aBuilder item: 'Configuration Browser') parent: #Tools; order: 0.20; action: [self new openWithSpec]; icon: Smalltalk ui icons configIcon! ! !MetacelloConfigurationBrowser class methodsFor: 'accessing' stamp: 'tbn 6/20/2013 08:13'! title ^'Configuration browser'! ! !MetacelloConfigurationBrowserPane commentStamp: ''! A MetacelloConfigurationBrowserPane is xxxxxxxxx. Instance Variables configurationList: configurationPattern: configurations: repository: configurationList - the list model to display configurations configurationPattern - a pattern to filter configurations in the configurationList configurations - a sorted list of available configurations in the repository repository - the repository to use ! !MetacelloConfigurationBrowserPane methodsFor: 'updating' stamp: 'TorstenBergmann 7/3/2013 21:10'! updateList |selected| selected := self configurationList selectedIndex. self configurationList updateList. self configurationList setSelectedIndex: selected.! ! !MetacelloConfigurationBrowserPane methodsFor: 'initialization' stamp: 'tbn 6/19/2013 22:31'! initConfigurationList "Display in format name (author.version)" configurationList displayBlock: [:item | |tokens| tokens := (item findTokens: '-.'). (tokens first allButFirst: 15), ' (',tokens second ,'.', tokens third, ')' ]. "Display loaded with a special icon (assuming the mcz is named like the class" configurationList icons: [:e | (Smalltalk includesKey: (e findTokens: '-.') first asSymbol) ifTrue: [ Smalltalk ui icons configIconLoaded ] ifFalse: [ Smalltalk ui icons configIcon ]]. ! ! !MetacelloConfigurationBrowserPane methodsFor: 'accessing' stamp: 'TorstenBergmann 7/17/2013 13:58'! configurations configurations ifNil: [ configurations := self class retrieveConfigurationsFrom: self repository ]. ^configurations! ! !MetacelloConfigurationBrowserPane methodsFor: 'accessing' stamp: 'TorstenBergmann 7/3/2013 21:38'! selectedConfigurationClass ^Smalltalk at: self selectedConfigurationName asSymbol ifAbsent: [ nil ]! ! !MetacelloConfigurationBrowserPane methodsFor: 'accessing' stamp: 'TorstenBergmann 7/3/2013 20:47'! repository ^repository! ! !MetacelloConfigurationBrowserPane methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 10/7/2013 11:53'! initializeWidgets self instantiateModels: #(configurationList IconListModel). self focusOrder add: configurationList. configurationList menu: [ :aMenu | self configurationListMenu: aMenu ]. self initConfigurationList. self repository: self availableRepositories first! ! !MetacelloConfigurationBrowserPane methodsFor: 'actions' stamp: 'TorstenBergmann 7/3/2013 21:28'! installConfiguration self loadConfigurationWithStable: true. self updateList! ! !MetacelloConfigurationBrowserPane methodsFor: 'actions' stamp: 'TorstenBergmann 7/3/2013 21:28'! loadConfiguration self loadConfigurationWithStable: false. self updateList! ! !MetacelloConfigurationBrowserPane methodsFor: 'accessing' stamp: 'TorstenBergmann 7/3/2013 21:31'! selectedConfiguration ^self configurationList selectedItem! ! !MetacelloConfigurationBrowserPane methodsFor: 'private accessing' stamp: 'tbn 6/19/2013 21:29'! configurationList ^configurationList ! ! !MetacelloConfigurationBrowserPane methodsFor: 'actions' stamp: 'TorstenBergmann 10/31/2013 12:27'! refreshRepository self repository: self repository. self configurationPattern: configurationPattern ! ! !MetacelloConfigurationBrowserPane methodsFor: 'accessing' stamp: 'TorstenBergmann 7/17/2013 14:18'! configurationPattern: aPattern "Sets a filter pattern" configurationPattern := aPattern. self configurationList items: (aPattern isNil ifTrue: [self configurations] ifFalse: [self configurations select: [ :each| configurationPattern search: each ]]). self updateList ! ! !MetacelloConfigurationBrowserPane methodsFor: 'private testing' stamp: 'TorstenBergmann 7/3/2013 21:36'! hasSelection ^self selectedConfiguration notNil! ! !MetacelloConfigurationBrowserPane methodsFor: 'accessing' stamp: 'TorstenBergmann 7/19/2013 09:47'! repository: aRepositoryUrl "clear config cache for new repositories" repository = aRepositoryUrl ifFalse: [ configurations := nil ]. repository := aRepositoryUrl. self configurationList items: self configurations. self window ifNotNil: [:w | w title: aRepositoryUrl ]! ! !MetacelloConfigurationBrowserPane methodsFor: 'private accessing' stamp: 'TorstenBergmann 7/4/2013 08:47'! availableRepositories ^Array with: self class pharoDistributionRepository with: 'http://ss3.gemtalksystems.com/ss/MetaRepoForPharo20' with: 'http://www.squeaksource.com/MetacelloRepository' ! ! !MetacelloConfigurationBrowserPane methodsFor: 'actions' stamp: 'cami 7/22/2013 18:28'! switchRepository | dialog | dialog := ListDialogWindow new getList: [ :r| self availableRepositories ]; displayBlock: [:e | e ]; title: 'Repository Search'; yourself. dialog browseBlock: [ :el | el ifNotNil: [ "only available onWin until other platforms can open a URL too" Smalltalk os isWin32 ifTrue: [ NBWin32Shell shellBrowse: el ] ]]. (dialog openModal) cancelled ifFalse: [ dialog listIndex > 0 ifTrue: [ self repository: (self availableRepositories at: dialog listIndex) ]]! ! !MetacelloConfigurationBrowserPane methodsFor: 'accessing' stamp: 'TorstenBergmann 7/3/2013 21:44'! selectedConfigurationName self selectedConfiguration ifNil: [ ^String empty ]. ^self selectedConfiguration readStream upTo: $-.! ! !MetacelloConfigurationBrowserPane methodsFor: 'private' stamp: 'TorstenBergmann 7/3/2013 21:37'! loadConfigurationWithStable: loadStable "Load the configuration and (depending on the flag) load the latest stable version" | configName | self hasSelection ifFalse: [ ^self ]. configName := self selectedConfigurationName. Gofer new url: self repository; package: configName; load. loadStable ifFalse: [^self]. "Now load the latest stable version" self selectedConfigurationClass project stableVersion load.! ! !MetacelloConfigurationBrowserPane methodsFor: 'private accessing' stamp: 'tbn 2/18/2013 20:20'! configurationList: aList configurationList := aList! ! !MetacelloConfigurationBrowserPane methodsFor: 'menu' stamp: 'TorstenBergmann 1/30/2014 09:28'! configurationListMenu: aMenu aMenu target: self. aMenu title: 'Configuration'. self selectedConfiguration ifNotNil: [ aMenu add: 'Install Stable Version' action: #installConfiguration. self selectedConfigurationClass isNil ifTrue: [ aMenu add: 'Load Configuration' action: #loadConfiguration ] ifFalse: [ aMenu add: 'Browse Configuration Class' action: #browseConfiguration ]. aMenu addLine ]. aMenu add: 'Switch Repository' action: #switchRepository; add: 'Refresh' action: #refreshRepository. ^aMenu! ! !MetacelloConfigurationBrowserPane methodsFor: 'actions' stamp: 'TorstenBergmann 7/3/2013 21:37'! browseConfiguration self hasSelection ifFalse: [ ^self ]. self selectedConfigurationClass browse! ! !MetacelloConfigurationBrowserPane class methodsFor: 'spec' stamp: 'BenjaminVanRyseghem 5/14/2013 18:07'! defaultSpec ^ SpecLayout composed add: #configurationList; yourself! ! !MetacelloConfigurationBrowserPane class methodsFor: 'example' stamp: 'tbn 2/18/2013 21:33'! example " self example " ^self new openWithSpec; repository: self pharoDistribution; yourself! ! !MetacelloConfigurationBrowserPane class methodsFor: 'accessing' stamp: 'tbn 2/18/2013 21:30'! title ^'Configurations'! ! !MetacelloConfigurationBrowserPane class methodsFor: 'accessing' stamp: 'TorstenBergmann 7/4/2013 08:46'! pharoDistributionRepository "Returns the correct pharo distribution url" ^'http://smalltalkhub.com/mc/Pharo/MetaRepoForPharo', SystemVersion current major asString, SystemVersion current minor asString, '/main'! ! !MetacelloConfigurationBrowserPane class methodsFor: 'accessing' stamp: 'MarcusDenker 10/15/2013 18:16'! retrieveConfigurationsFrom: locationString " self retrieveConfigurationsFrom: self pharoDistribution " | repo reductionMap split configName author version last topMostItems | repo := MCHttpRepository location: locationString. "Reduce to display only the latest" reductionMap := Dictionary new. (repo allVersionNames reverse select: [ :each | each beginsWith: 'ConfigurationOf' ]) do: [:each | split := each findTokens: '-.'. configName := split first. author := split second. version := Integer readFrom: split last. last := reductionMap at: configName ifAbsentPut: [ author -> version]. version > last value ifTrue: [ reductionMap at: configName put: (author -> version) ] ]. topMostItems := SortedCollection sortBlock: [:e1 :e2 | e1 asString <= e2 asString ]. reductionMap keysAndValuesDo: [:key :val | topMostItems add: (key, '-', val key, '.', val value asString) ]. ^topMostItems! ! !MetacelloConfigurationBrowserToolbar commentStamp: ''! A MetacelloConfigurationBrowserToolbar is a toolbar for the configuration browser. Instance Variables installModel: loadModel: installModel - button model to install a configuration loadModel - button model to load a configuration ! !MetacelloConfigurationBrowserToolbar methodsFor: 'initialization' stamp: 'SeanDeNigris 11/9/2013 13:30'! setLoadModel loadModel state: false; label: 'Load Configuration'; action: [ self loadConfiguration ]. ! ! !MetacelloConfigurationBrowserToolbar methodsFor: 'initialization' stamp: 'SeanDeNigris 11/9/2013 13:30'! setInstallModel installModel state: false; label: 'Install Stable Version'; action: [ self installConfiguration ]. ! ! !MetacelloConfigurationBrowserToolbar methodsFor: 'initialization' stamp: 'tbn 6/20/2013 08:25'! initializeWidgets self instantiateModels: #( loadModel ButtonModel installModel ButtonModel). self setLoadModel. self setInstallModel . self focusOrder add: loadModel; add: installModel! ! !MetacelloConfigurationBrowserToolbar methodsFor: 'actions' stamp: 'TorstenBergmann 7/17/2013 14:17'! installConfiguration owner installConfiguration ! ! !MetacelloConfigurationBrowserToolbar methodsFor: 'actions' stamp: 'TorstenBergmann 7/17/2013 14:17'! loadConfiguration owner loadConfiguration ! ! !MetacelloConfigurationBrowserToolbar methodsFor: 'initialization' stamp: 'tbn 6/20/2013 08:23'! installModel ^installModel ! ! !MetacelloConfigurationBrowserToolbar methodsFor: 'initialization' stamp: 'tbn 6/20/2013 08:23'! loadModel ^loadModel! ! !MetacelloConfigurationBrowserToolbar class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/7/2013 11:44'! defaultSpec ^ SpecLayout composed newRow: [ :row | row add: #installModel; add: #loadModel ]; yourself! ! !MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue136 "self reset" | versionInfo | versionInfo := self setUpConfigurationOfProjectIssue136dkh1. versionInfo := self setUpConfigurationOfProjectIssue136dkh2: {versionInfo}. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfFan "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfFan-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline20Fan:' category: 'cat' timeStamp: '' source: self baseline20MethodSourceFan. MCMethodDefinition className: className asString selector: 'baseline30Fan:' category: 'cat' timeStamp: '' source: self baseline30MethodSourceFan. MCMethodDefinition className: className asString selector: 'baseline35Fan:' category: 'cat' timeStamp: '' source: self baseline35MethodSourceFan. MCMethodDefinition className: className asString selector: 'baseline40Fan:' category: 'cat' timeStamp: '' source: self baseline40MethodSourceFan. MCMethodDefinition className: className asString selector: 'baseline50Fan:' category: 'cat' timeStamp: '' source: self baseline50MethodSourceFan. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline10D: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'C' with: [ spec className: 'MetacelloTestConfigurationOfIssue77C'; loads: #('GoferFoo'); versionString: '1.3'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; package: 'GoferBar' with: [ spec file:'GoferBar-lr.1' ]; group: 'default' with: #('GoferBar'); yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 07/19/2013 22:50'! baseline35Foo: spec "self reset" spec for: #'common' do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with: 'GoferFoo-lr.1'; package: 'GoferBar' with: 'GoferBar-lr.1'; package: 'GoferFaux' with: 'GoferFaux-tg.31'; package: 'GoferBeau' with: 'GoferBeau-dkh.54'; yourself. spec group: '1' with: #('GoferFoo' 'GoferBar'); group: '2' with: #('GoferFoo' 'GoferFaux'); yourself ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline50MethodSourceFoo ^(self class sourceCodeAt: #baseline50Foo:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! project "self reset" | constructor project | "Construct Metacello project" project := MetacelloMCProject new. "Allow for customization of #projectAttributes" project projectAttributes: MetacelloConfigurationResource projectAttributes. MetacelloVersionConstructor on: self project: project. project loader: ((project loaderClass new) shouldDisablePackageCache: true; yourself). project loadType: #linear. ^project ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue119dkh2: ancestors "version 2.0" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.2'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baselineVersion20Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion20Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version20Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version20Issue119:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version117ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core' overrides: [ spec preLoadDoIt: #'alternatePreloadForCore'. ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFeaux' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40Feaux: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GeauxFoo' with:'GeauxFoo-lr.1'; package: 'GeauxBar' with: 'GeauxBar.branch-lr.2'; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! projectMethodSource ^(self class sourceCodeAt: #project) asString ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion30Issue119: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo ' with: [ spec versionString: #'bleedingEdge'; className: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself. spec package: 'GoferBar' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 125' stamp: 'dkh 9/11/2012 15:14'! baselineVersion30Issue125: spec spec for: #(#'attribute1' #'attribute2') do: [ spec description: 'MetacelloConfigurationResource>>baselineVersion30Issue125:'. spec package: 'GoferFaux' with: [ spec requires: 'GoferFoo' ]; package: 'GoferBeau' with: [ spec requires: 'GoferFaux' ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! version42SymbolicMethodSourceSymbolic ^(self class sourceCodeAt: #version42Symbolic:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version132ProjectToolBox: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. ]. spec for: #'level1_1' do: [ spec package: 'GoferBeau' with: 'GoferBeau-dkh.15'. spec for: #'level2_1' do: [ spec package: 'GoferBeau' with: 'GoferBeau-dkh.25'. spec for: #'level3_1' do: [ spec package: 'GoferBeau' with: 'GoferBeau-dkh.53'. ]. ]. spec for: #'level2_2' do: [ spec package: 'GoferBeau' with: 'GoferBeau-dkh.54'. spec for: #'level3_2' do: [ spec package: 'GoferBeau' with: 'GoferBeau-dkh.55'. ]. ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFee' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectFee "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectFee-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline40ProjectFee:' category: 'cat' timeStamp: '' source: self baseline40MethodSourceProjectFee. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFum' stamp: 'dkh 7/19/2012 07:32'! setUpConfigurationOfProjectFum "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectFum-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baseline10ProjectFum:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baseline10ProjectFum:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! version41SymbolicMethodSourceSymbolic ^(self class sourceCodeAt: #version41Symbolic:) asString ! ! !MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40ProjectInfinite: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Loop' with: [ spec className: 'MetacelloTestConfigurationOfProjectLoop'; versionString: '4.0'; loads: 'GeauxBeau'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself. spec package: 'GeauxBar' with: [ spec file: 'GeauxBar.branch-lr.2'; requires: 'Loop'; yourself ]; package: 'GoferBar' with: 'GoferBar-lr.1'; yourself ].! ! !MetacelloConfigurationResource methodsFor: 'Issue 125' stamp: 'dkh 9/11/2012 15:33'! setUpConfigurationOfProjectIssue125 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue125-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'version30Issue125:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version30Issue125:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion20Issue125:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion20Issue125:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion30Issue125:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion30Issue125:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFeaux' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfFeaux "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfFeaux-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline40Feaux:' category: 'cat' timeStamp: '' source: self baseline40MethodSourceFeaux. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! stableVersionC: spec "self reset" spec for: #'common' do: [ spec version: '4.2']. spec for: #'platformVersion1.x' do: [ spec version: '4.0']. spec for: #'platformVersion1.0.x' do: [ spec version: '4.1']. spec for: #'platformVersion1.1.x' do: [ spec version: '4.2']. spec for: #'platformVersion1.2.x' do: [ spec version: '4.3']. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: 'dkh 05/10/2013 17:13'! version10Issue156: spec "https://github.com/dalehenrich/metacello-work/issues/156" spec for: #'common' do: [ spec configuration: 'Goo' with: [ spec versionString: '3.0.0'; repository: 'dictionary://Metacello_MczConfiguration_Test_Repository' ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! version40Issue119: spec spec for: #'common' do: [ spec blessing: #'development'. spec project: 'Foo' with: '2.0'. spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue154dkh1 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfMetacelloProjectIssue154-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baselineVersion10Issue154:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion10Issue154:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion11Issue154:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion11Issue154:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion12Issue154:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion12Issue154:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion13Issue154:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion13Issue154:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion20Issue154:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion20Issue154:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion30Issue154:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion30Issue154:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline20Fan: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '2.0'; loads: #('GoferFaux' 'GoferBeau'); file: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; project: 'Far' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '2.0'; loads: #('GoferBeau'); file: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline50Fan: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '5.0'; loads: #('GoferFaux' 'GoferBeau'); file: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion10Issue154: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec project: 'MetacelloExample' with: [ spec className: 'ConfigurationOfMetacelloExample'; versionString: '1.0'; projectPackage: [ spec name: 'ConfigurationOfMetacelloExample'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue171dkh1 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue171-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baselineVersion20Issue171:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion20Issue171:') asString). (MCMethodDefinition className: className asString selector: 'version20Issue171:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version20Issue171:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version100ProjectToolBox: spec spec for: #'common' do: [ spec blessing: #'testBlessing'. spec package: 'Example-Core' with: [ spec includes: #('Example-AddOn' ); file: 'Example-Core-anon.1'; repository: 'http://www.example.com/or'; preLoadDoIt: #'preloadForCore'; postLoadDoIt: #'postloadForCore:package:'. ]; package: 'Example-AddOn' with: [ spec requires: #('Example-Core' ). ]; package: 'Example-Tests' with: [ spec requires: #('Example-AddOn' ). ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion11Issue154: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec project: 'MetacelloExample' with: [ spec className: 'ConfigurationOfMetacelloExample'; versionString: '1.0'; projectPackage: [ spec name: 'MetacelloExampleTestConfigurationIssue154'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue119dkh7: ancestors "versions 5.0" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.7'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baselineVersion40Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion40Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version50Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version50Issue119:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 05/11/2013 08:50'! setUpIssue156ConfigurationOfProjectGoo "https://github.com/dalehenrich/metacello-work/issues/156" "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'ConfigurationOfProjectGoo-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString selector: 'version10Issue156:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version10Issue156:') asString). (MCMethodDefinition className: className asString selector: 'version11Issue156:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version11Issue156:') asString). (MCMethodDefinition className: className asString selector: 'version20Issue156:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version20Issue156:') asString). (MCMethodDefinition className: className asString selector: 'version30Issue156:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version30Issue156:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion20Issue154: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec project: 'MetacelloExample' with: [ spec className: 'ConfigurationOfMetacelloExample'; versionString: '1.0'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version133ProjectToolBox: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. ]. spec for: #'level1_1' do: [ spec package: 'GoferBar' with: 'GoferBar-jf.1'. spec for: #'level2_1' do: [ spec package: 'GoferFoo' with: 'GoferFoo-lr.1'. spec for: #'level3_1' do: [ spec package: 'GoferFaux' with: 'GoferFaux-tg.30'. ]. ]. spec for: #'level2_2' do: [ spec package: 'GeauxBar' with: 'GeauxBar.branch-lr.2'. spec for: #'level3_2' do: [ spec package: 'GeauxBeau' with: 'GeauxBeau-dkh.55'. ]. ]. ]. spec for: #'pharo' do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFix' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline60Fix: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with: 'GoferFoo-lr.4'; package: 'GoferBar' with: 'GoferBar-lr.1'; package: 'GoferFaux' with: 'GoferFaux-tg.35'; yourself. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: 'dkh 6/12/2012 15:41:23.319'! version21Issue171: spec spec for: #'common' do: [ spec blessing: #'development'. spec project: 'Foo' with: '2.0'. spec package: 'GeauxFoo' with: 'GeauxFoo-lr.1' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline30MethodSourceFoo ^(self class sourceCodeAt: #baseline30Foo:) asString ! ! !MetacelloConfigurationResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpMonticelloRepository "This method builds a fake repository with the version references from #buildReferences." "self reset" monticelloRepository := MCDictionaryRepository new. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! version41Symbolic: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec blessing: #release. spec package: 'GoferBeau' with: 'GoferBeau-dkh.25'; package: 'GoferFaux' with:'GoferFaux-tg.31'; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFix' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline60MethodSourceFix ^(self class sourceCodeAt: #baseline60Fix:) asString ! ! !MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40MethodSourceProjectIssue95 ^(self class sourceCodeAt: #baseline40ProjectIssue95:) asString ! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline12MethodSourceC ^(self class sourceCodeAt: #baseline12C:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline20MethodSourceFan ^(self class sourceCodeAt: #baseline20Fan:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version118ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core' with: [ spec preLoadDoIt: #'alternatePreloadForCore'. ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpIssue77D "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfIssue77D-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline10D:' category: 'cat' timeStamp: '' source: self baseline10MethodSourceD. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 05/10/2013 17:13'! baselineGooIssue156Baseline: spec "https://github.com/dalehenrich/metacello-work/issues/156" spec for: #'common' do: [ spec package: 'GoferFoo' with: 'GoferFoo-lr.1'; package: 'GoferBar' with: 'GoferBar.branch-lr.1'; package: 'GoferFaux' with: 'GoferFaux-tg.30'; package: 'GoferBeau' with: 'GoferBeau-dkh.53'; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: 'dkh 6/12/2012 15:41:23.319'! version20Issue171: spec spec for: #'common' do: [ spec blessing: #'development'. spec project: 'Foo' with: '2.0'. spec package: 'GeauxFoo' with: 'GeauxFoo-lr.1' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue119dkh5: ancestors "versions, 4.0, 4.1, 4.2, 4.3, 4.4" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.5'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baselineVersion40Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion40Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version40Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version40Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version41Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version41Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version42Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version42Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version43Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version43Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version44Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version44Issue119:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! preloadDoItMethodSource ^(self class sourceCodeAt: #preloadDoIt) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline50MethodSourceFan ^(self class sourceCodeAt: #baseline50Fan:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version135ProjectToolBox: spec spec for: #'common' do: [ spec repositories: [ spec repository: 'http://www.example.com/ab'; repository: 'http://www.example.com/ac' ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline20MethodSourceFoo ^(self class sourceCodeAt: #baseline20Foo:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFoe' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectFoe "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectFoe-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline40ProjectFoe:' category: 'cat' timeStamp: '' source: self baseline40MethodSourceProjectFoe. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version116ProjectToolBox: spec spec for: #'common' do: [ spec project: 'Example Project' with: [ spec preLoadDoIt: #'alternatePreloadForCore' ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version114ProjectToolBox: spec spec for: #'common' do: [ spec project: 'Example Project' with: [ spec className: 'MetacelloExampleProjectConfig'; versionString: '1.0-baseline'; preLoadDoIt: #'preloadForProject'; postLoadDoIt: #'postloadForProject'; repository: 'http://www.example.com/ob' ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! version42Symbolic: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec blessing: #release. spec package: 'GoferBeau' with: 'GoferBeau-dkh.53'; package: 'GoferFaux' with:'GoferFaux-tg.32'; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFix' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline61MethodSourceFix ^(self class sourceCodeAt: #baseline61Fix:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version111ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core'. spec for: #'nested' do: [ spec package: 'Example-Base'. ]. ]. spec for: #'extra' do: [ spec package: 'Example-Test'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline10MethodSourceD ^(self class sourceCodeAt: #baseline10D:) asString ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion10Issue119: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo ' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself. spec package: 'GoferBar ' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! projectClassMethodSource ^(self class class sourceCodeAt: #project) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! version40Symbolic: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec blessing: #release. spec package: 'GoferBeau' with: 'GoferBeau-dkh.15'; package: 'GoferFaux' with:'GoferFaux-tg.30'; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion40Issue119: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec versionString: #'bleedingEdge'; className: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself. spec package: 'GoferBar' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue95 "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue95-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline40ProjectIssue95:' category: 'cat' timeStamp: '' source: self baseline40MethodSourceProjectIssue95. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion10Issue136: spec spec for: #'common' do: [ spec blessing: #baseline. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferBeau'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpIssue77C "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfIssue77C-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline12C:' category: 'cat' timeStamp: '' source: self baseline12MethodSourceC. MCMethodDefinition className: className asString selector: 'baseline13C:' category: 'cat' timeStamp: '' source: self baseline13MethodSourceC. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40MethodSourceFan ^(self class sourceCodeAt: #baseline40Fan:) asString ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue119dkh1 "version 1.0" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baselineVersion10Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion10Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version10Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version10Issue119:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! version43Issue119: spec spec for: #'common' do: [ spec blessing: #'development'. spec project: 'Foo ' with: '2.0'. spec package: 'GoferBar ' with: 'GoferBar-jf.1' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion21Issue171: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo' ]; yourself. spec package: 'GeauxFoo' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version113ProjectToolBox: spec spec for: #'outer' do: [ spec package: 'Example-Core' with: 'Example-Core-dkh.1'; package: 'Example-Test' with: 'Example-Test-dkh.1'. spec for: #'nested' do: [ spec package: 'Example-Core' with: 'Example-Core-dkh.2'. ]. ]. spec for: #'extra' do: [ spec package: 'Example-Core' with: 'Example-Core-dkh.3'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue171 "self reset" | versionInfo | versionInfo := self setUpConfigurationOfProjectIssue171dkh1. versionInfo := self setUpConfigurationOfProjectIssue171dkh2: {versionInfo}! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFie' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40ProjectFie: spec "just projects" "self reset" spec for: #common do: [ spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '4.0'; file: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; project: 'Feaux' with: [ spec className: 'MetacelloTestConfigurationOfFeaux'; versionString: '4.0'; file: 'MetacelloTestConfigurationOfFeaux'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version112ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core'. spec for: #'nested' do: [ spec package: 'Example-Base'; package: 'Example-Test-Nested'. ]. ]. spec for: #'extra' do: [ spec package: 'Example-Test'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version115ProjectToolBox: spec spec for: #'common' do: [ spec project: 'Example Project' with: [ spec preLoadDoIt: #'alternatePreloadForCore' ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! version41Issue119: spec spec for: #'common' do: [ spec blessing: #'development'. spec project: 'Foo ' with: '2.0'. spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40ProjectLoop: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Infinite' with: [ spec className: 'MetacelloTestConfigurationOfProjectInfinite'; versionString: '4.0'; loads: 'GoferBar'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; package: 'GoferFaux' with: [ spec file:'GoferFaux-tg.30'; requires: 'Infinite'; yourself ]; package: 'GeauxBeau' with: [ spec file: 'GeauxBeau-dkh.55'; yourself ]; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version108ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core'; package: 'Example-Tests' with: [ spec requires: #('Example-Core' ). ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline30Fan: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '3.0'; loads: #('GoferFaux' 'GoferBeau'); file: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline35MethodSourceFan ^(self class sourceCodeAt: #baseline35Fan:) asString ! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline12C: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with: 'GoferFoo-lr.1'; package: 'GeauxBeau' with: 'GeauxBeau-dkh.55'; yourself. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFix' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline61Fix: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with: 'GoferFoo-lr.4'; package: 'GoferBar' with: 'GoferBar-lr.1'; package: 'GoferBeau' with: 'GoferBeau-dkh.53'; package: 'GoferFaux' with: 'GoferFaux-tg.31'; yourself. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue119dkh3: ancestors "version 3.0" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.3'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baselineVersion30Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion30Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version30Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version30Issue119:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectToolBox "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectToolBox-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'postloadDoIt' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'postloadDoIt') asString). (MCMethodDefinition className: className asString selector: 'preloadDoIt' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'preloadDoIt') asString). (MCMethodDefinition className: className asString selector: 'symbolicVersionExplicitlyDoesNotExistProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'symbolicVersionExplicitlyDoesNotExistProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version100ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version100ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version101ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version101ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version102ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version102ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version103ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version103ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version104ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version104ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version105ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version105ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version106ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version106ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version107ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version107ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version108ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version108ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version109ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version109ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version110ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version110ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version111ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version111ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version112ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version112ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion113ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion113ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version113ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version113ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version114ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version114ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version115ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version115ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version116ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version116ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version117ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version117ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version118ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version118ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version119ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version119ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version120ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version120ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version121ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version121ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version122ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version122ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version123ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version123ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion124ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion124ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version124ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version124ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version125ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version125ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version126ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version126ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version127ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version127ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version128ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version128ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version129ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version129ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version130ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version130ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version131ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version131ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version132ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version132ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version133ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version133ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version134ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version134ProjectToolBox:') asString). (MCMethodDefinition className: className asString selector: 'version135ProjectToolBox:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version135ProjectToolBox:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! version43SymbolicMethodSourceSymbolic ^(self class sourceCodeAt: #version43Symbolic:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline30Foo: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with: [ spec preLoadDoIt: #preloadDoIt; file: 'GoferFoo-lr.1' ]; package: 'GoferBar' with: 'GoferBar.branch-lr.1'; package: 'GoferFaux' with: 'GoferFaux-tg.30'; package: 'GoferBeau' with: 'GoferBeau-dkh.53'; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 05/11/2013 08:33'! baselineGoo300Issue156Configuration: spec "https://github.com/dalehenrich/metacello-work/issues/156" spec for: #'common' do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferGoo' with: 'GoferFoo-lr.1'; package: 'GoferBar' with: 'GoferBar.branch-lr.1'; package: 'GoferFaux' with: 'GoferFaux-tg.30'; package: 'GoferBeau' with: 'GoferBeau-dkh.53'; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectLoop "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectLoop-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline40ProjectLoop:' category: 'cat' timeStamp: '' source: self baseline40MethodSourceProjectLoop. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue154 "self reset" | versionInfo | versionInfo := self setUpConfigurationOfMetacelloExampledkh1. versionInfo := self setUpConfigurationOfProjectIssue154dkh1! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 05/10/2013 17:13'! setUpIssue156BaselineOfGoo "https://github.com/dalehenrich/metacello-work/issues/156" "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'BaselineOfGoo-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString selector: 'baselineGooIssue156Baseline:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineGooIssue156Baseline:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue136dkh2: ancestors "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue136-dkh.2'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baselineVersion10Issue136:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baselineVersion10Issue136:) asString. MCMethodDefinition className: className asString selector: 'version10Issue136:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10Issue136:) asString. MCMethodDefinition className: className asString selector: 'version11Issue136:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version11Issue136:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version105ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core' with: [ spec repository: 'http://www.example.com/ob'. ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline10MethodSourceB ^(self class sourceCodeAt: #baseline10B:) asString ! ! !MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue115dkh1 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue115-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baselineVersion10Issue115:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baselineVersion10Issue115:) asString. MCMethodDefinition className: className asString selector: 'version10Issue115:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10Issue115:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo! ! !MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: 'dkh 6/12/2012 15:41:23.319'! version11Issue136: spec spec for: #'common' do: [ spec blessing: #development. spec package: 'GoferBeau' with: 'GoferBeau-dkh.25'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version104ProjectToolBox: spec spec for: #'common' do: [ spec preLoadDoIt: nil. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpIssue95 "self reset" self setUpConfigurationOfProjectInfinite; setUpConfigurationOfProjectLoop; setUpConfigurationOfProjectIssue95; yourself ! ! !MetacelloConfigurationResource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! monticelloRepository ^ monticelloRepository! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue119dkh6: ancestors "versions 1.0, 2.0. 3.0,4.0, 4.1, 4.2, 4.3, 4.4" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.6'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baselineVersion10Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion10Issue119:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion20Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion20Issue119:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion30Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion30Issue119:') asString). (MCMethodDefinition className: className asString selector: 'baselineVersion40Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion40Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version10Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version10Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version20Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version20Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version30Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version30Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version40Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version40Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version41Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version41Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version42Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version42Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version43Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version43Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version44Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version44Issue119:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue171dkh2: ancestors "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue171-dkh.2'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baselineVersion21Issue171:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion21Issue171:') asString). (MCMethodDefinition className: className asString selector: 'version21Issue171:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version21Issue171:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 07/28/2013 10:40'! setUpIssue156ConfigurationOfProjectSoo "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'ConfigurationOfProjectSoo-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString selector: 'version10Issue156:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version10Issue156:') asString). (MCMethodDefinition className: className asString selector: 'version11Issue156:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version11Issue156:') asString). (MCMethodDefinition className: className asString selector: 'version20Issue156:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version20Issue156:') asString). (MCMethodDefinition className: className asString selector: 'version30Issue156:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version30Issue156:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: 'dkh 05/10/2013 17:13'! version11Issue156: spec "https://github.com/dalehenrich/metacello-work/issues/156" spec for: #'common' do: [ spec baseline: 'Goo' with: [ spec repository: 'dictionary://Metacello_MczConfiguration_Test_Repository' ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! version42Issue119: spec spec for: #'common' do: [ spec blessing: #'development'. spec project: 'Foo' with: '2.0'. spec package: 'GoferBar ' with: 'GoferBar-jf.1' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFie' stamp: 'dkh 6/26/2012 14:56'! setUpConfigurationOfProjectFie "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectFie-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baseline15ProjectFie:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baseline15ProjectFie:') asString). (MCMethodDefinition className: className asString selector: 'baseline25ProjectFie:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baseline25ProjectFie:') asString). (MCMethodDefinition className: className asString selector: 'baseline35ProjectFie:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baseline35ProjectFie:') asString). (MCMethodDefinition className: className asString selector: 'baseline40ProjectFie:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baseline40ProjectFie:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion10Issue115: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec versionString: #'bleedingEdge'; className: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself. spec package: 'GeauxFoo' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline13MethodSourceC ^(self class sourceCodeAt: #baseline13C:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version129ProjectToolBox: spec spec for: #'common' do: [ spec project: 'Example Project' with: [ spec className: 'MetacelloExampleProjectConfig'; versionString: '1.0-baseline'; preLoadDoIt: #'preloadDoIt'; postLoadDoIt: #'postloadDoIt'; repository: 'http://www.example.com/ob' ]; project: 'Copy Project' copyFrom: 'Example Project' with: [ spec preLoadDoIt: nil; postLoadDoIt: nil ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version126ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core' with: [ spec preLoadDoIt: nil; postLoadDoIt: nil. ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version101ProjectToolBox: spec spec for: #'common' do: [ spec blessing: #'testBlessing'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version102ProjectToolBox: spec spec for: #'common' do: [ spec preLoadDoIt: #'preloadForCore'. spec postLoadDoIt: #'postloadForCore:package:'. spec package: 'Example-Core' with: [ spec includes: #('Example-AddOn' ). ]; package: 'Example-AddOn' with: [ spec requires: #('Example-Core' ). ]; package: 'Example-Tests' with: [ spec requires: #('Example-AddOn' ). ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFie' stamp: 'dkh 6/26/2012 14:48'! baseline25ProjectFie: spec "self reset" spec for: #'common' do: [ spec configuration: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '3.5'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; import: 'Foo' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! version44Issue119: spec spec for: #'common' do: [ spec blessing: #'development'. spec project: 'Foo' with: 2.0. spec package: 'GoferBar ' with: 'GoferBar-jf.1' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 125' stamp: 'dkh 9/11/2012 15:13'! baselineVersion20Issue125: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec description: 'MetacelloConfigurationResource>>baselineVersion20Issue125:'. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo'; package: 'GoferBar' with: [ spec requires: 'GoferFoo' ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40MethodSourceProjectInfinite ^(self class sourceCodeAt: #baseline40ProjectInfinite:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version107ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core' with: [ spec supplyingAnswers: #( #( 'preload' 'preload answer' ) #( 'postload' 'postload answer' ) ); preLoadDoIt: #'preloadForSupplyingAnswers'; postLoadDoIt: #'postloadForSupplyingAnswers'. ]; package: 'Example-Tests' with: [ spec supplyingAnswers: #( #( 'string' 'preload answer' ) #( 'symbol' #'abc def' ) #( 'integer' 1 ) #( 'boolean' true ) #( 'another boolean' false ) #( 'character' $a ) ). ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version122ProjectToolBox: spec spec for: #'common' do: [ spec project: 'Example Project' with: [ spec className: 'MetacelloExampleProjectConfig'; repository: 'http://www.example.com/ob' ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40Fan: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '4.0'; loads: #('GoferFaux' 'GoferBeau'); file: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version134ProjectToolBox: spec spec for: #'common' do: [ ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFoe' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40MethodSourceProjectFoe ^(self class sourceCodeAt: #baseline40ProjectFoe:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFee' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40MethodSourceProjectFee ^(self class sourceCodeAt: #baseline40ProjectFee:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! postloadDoIt "self reset" Smalltalk at: #'Metacello_Configuration_Test_POST_DoIt_Result' put: true! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version103ProjectToolBox: spec spec for: #'common' do: [ spec preLoadDoIt: #'alternatePreloadForCore'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFie' stamp: 'dkh 6/26/2012 16:25'! baseline15ProjectFie: spec "self reset" "shouldn't affect anything ... the import: should only take effect on a load" spec for: #'common' do: [ spec configuration: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '3.5'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; import: 'Foo' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version127ProjectToolBox: spec spec for: #'common' do: [ spec project: 'Example Project' with: [ spec className: 'MetacelloExampleProjectConfig'; versionString: '1.0-baseline'; preLoadDoIt: #'preloadDoIt'; postLoadDoIt: #'postloadDoIt'; repository: 'http://www.example.com/ob' ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpIssue77 "self reset" self setUpIssue77B; setUpIssue77C; setUpIssue77D ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion20Issue119: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec versionString: #'bleedingEdge'; className: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself. spec package: 'GoferBar ' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline35Fan: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '3.5'; loads: #('GoferFaux' 'GoferBeau'); file: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFum' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfFum "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfFum-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline40ProjectFum:' category: 'cat' timeStamp: '' source: self baseline40MethodSourceProjectFum. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! symbolicVersionExplicitlyDoesNotExistProjectToolBox: spec spec for: #'common' version: #'notDefined'! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 9/13/2012 15:54'! bleedingEdgeVersion: spec "self reset" spec for: #'common' version: '4.0'! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFie' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline35ProjectFie: spec "just projects" "self reset" spec for: #common do: [ spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '3.5'; file: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; project: 'Feaux' with: [ spec className: 'MetacelloTestConfigurationOfFeaux'; versionString: '4.0'; file: 'MetacelloTestConfigurationOfFeaux'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! version10Issue119: spec spec for: #'common' do: [ spec blessing: #'development'. spec project: 'Foo' with: '2.0'. spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFum' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40MethodSourceProjectFum ^(self class sourceCodeAt: #baseline40ProjectFum:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version119ProjectToolBox: spec spec for: #'common' do: [ spec project: 'Example Project' overrides: [ spec className: 'MetacelloExampleProjectConfig'; versionString: '1.0-baseline'; preLoadDoIt: #'alternatePreloadForCore'; repository: 'http://www.example.com/ob' ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version109ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core'; package: 'Example-Tests' with: [ spec includes: #('Example-Core' ). ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: 'dkh 6/12/2012 15:41:23.319'! version10MetacelloExample: spec spec for: #'common' do: [ spec blessing: #'release'. spec package: 'GoferFoo' with: 'GoferFoo-lr.2' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! version40SymbolicMethodSourceSymbolic ^(self class sourceCodeAt: #version40Symbolic:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 05/11/2013 08:38'! baselineGoo500Issue156Configuration: spec "https://github.com/dalehenrich/metacello-work/issues/156" spec for: #'common' do: [ spec baseline: 'Goo' with: [ spec repository: 'dictionary://Metacello_MczConfiguration_Test_Repository' ]; import: 'Goo' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue115 "self reset" | versionInfo | versionInfo := self setUpConfigurationOfProjectIssue115dkh1. versionInfo := self setUpConfigurationOfProjectIssue115dkh2: {versionInfo}. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpIssue77B "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfIssue77B-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline10B:' category: 'cat' timeStamp: '' source: self baseline10MethodSourceB. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! version30Issue119: spec spec for: #'common' do: [ spec blessing: #'development'. spec project: 'Foo' with: '2.0'. spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFum' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40ProjectFum: spec "master" "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Feaux' with: [ spec className: 'MetacelloTestConfigurationOfFeaux'; versionString: '4.0'; file: 'MetacelloTestConfigurationOfFeaux'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '4.0'; file: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; project: 'ProjectFie' with: [ spec className: 'MetacelloTestConfigurationOfProjectFie'; versionString: '4.0'; file: 'MetacelloTestConfigurationOfProjectFie'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; project: 'ProjectFee' with: [ spec className: 'MetacelloTestConfigurationOfProjectFee'; versionString: '4.0'; file: 'MetacelloTestConfigurationOfProjectFee'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion124ProjectToolBox: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec repository: 'http://www.example.com/aa'. ]. spec for: #'common' do: [ spec repository: 'http://www.example.com/ab'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version110ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core'; package: 'Example-Base'; package: 'Example-Test1' with: [ spec requires: #('Example-Base' ); includes: #('Example-Core' ). ]; package: 'Example-Test2' with: [ spec includes: #('Example-Core' ); supplyingAnswers: #( #( 'captionMatch' 'answer' ) ). ]; package: 'Example-Test3' with: [ spec requires: #('Example-Base' ); supplyingAnswers: #( #( 'captionMatch' 'answer' ) ). ]; package: 'Example-Test4' with: [ spec requires: #('Example-Base' ); includes: #('Example-Core' ); supplyingAnswers: #( #( 'captionMatch' 'answer' ) ). ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version106ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core' with: [ spec repositories: [ spec repository: 'http://www.example.com/ob'; repository: 'http://www.example.com/or' ]. ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! version50Issue119: spec spec for: #'common' do: [ spec blessing: #'development'. spec project: 'Foo' with: '1.0'. spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFix' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfFix "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfFix-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline60Fix:' category: 'cat' timeStamp: '' source: self baseline60MethodSourceFix. MCMethodDefinition className: className asString selector: 'baseline61Fix:' category: 'cat' timeStamp: '' source: self baseline61MethodSourceFix. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! version20Issue119: spec spec for: #'common' do: [ spec blessing: #'development'. spec project: 'Foo' with: '2.0'. spec package: 'GoferBar' with: 'GoferBar-jf.1' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! version43Symbolic: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec blessing: #development. spec package: 'GoferBeau' with: 'GoferBeau-dkh.54'; package: 'GoferFaux' with:'GoferFaux-tg.33'; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 07/19/2013 22:50'! baseline40Foo: spec "self reset" spec for: #'common' do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with: 'GoferFoo-lr.1'; package: 'GoferBar' with: 'GoferBar-lr.1'; package: 'GoferFaux' with: 'GoferFaux-tg.32'; package: 'GoferBeau' with: 'GoferBeau-dkh.55'; yourself. spec group: '1' with: #('GoferFoo' 'GoferBar'); group: '2' with: #('GoferFoo' 'GoferFaux'); yourself ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion30Issue154: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec project: 'MetacelloExample' with: [ spec className: 'ConfigurationOfMetacelloExample'; versionString: '1.0'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: 'dkh 6/12/2012 15:41:23.319'! version11Issue115: spec spec for: #'common' do: [ spec blessing: #development. spec project: 'Foo' with: ''. spec package: 'GeauxFoo' with: 'GeauxFoo-lr.1'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 05/11/2013 08:37'! baselineGoo400Issue156Configuration: spec "https://github.com/dalehenrich/metacello-work/issues/156" spec for: #'common' do: [ spec baseline: 'Goo' with: [ spec repository: 'dictionary://Metacello_MczConfiguration_Test_Repository' ]; import: 'Goo' ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFan' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline30MethodSourceFan ^(self class sourceCodeAt: #baseline30Fan:) asString ! ! !MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfMetacelloExampledkh1 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfMetacelloExample-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baselineVersion10MetacelloExample:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion10MetacelloExample:') asString). (MCMethodDefinition className: className asString selector: 'version10MetacelloExample:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version10MetacelloExample:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! preloadDoIt "self reset" Smalltalk at: #'Metacello_Configuration_Test_DoIt_Result' put: true! ! !MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: 'dkh 6/12/2012 15:41:23.319'! version10Issue115: spec spec for: #'common' do: [ spec blessing: #development. spec project: 'Foo' . spec package: 'GeauxFoo' with: 'GeauxFoo-lr.1'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 171' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion20Issue171: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself. spec package: 'GeauxFoo' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue119dkh4: ancestors "version 4.0" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue119-dkh.4'. className := reference packageName asSymbol. definitionArray := {(MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString selector: 'baselineVersion40Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineVersion40Issue119:') asString). (MCMethodDefinition className: className asString selector: 'version40Issue119:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version40Issue119:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline10B: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'C' with: [ spec className: 'MetacelloTestConfigurationOfIssue77C'; loads: #('GoferFoo'); versionString: '1.2'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; package: 'GoferBeau' with: 'GoferBeau-dkh.53'; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 9/13/2012 15:55'! setUpConfigurationOfFoo "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfFoo-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'Object' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'bleedingEdgeVersion:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'bleedingEdgeVersion:') asString). (MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource). (MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource). (MCMethodDefinition className: className asString selector: 'baseline20Foo:' category: 'cat' timeStamp: '' source: self baseline20MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'baseline30Foo:' category: 'cat' timeStamp: '' source: self baseline30MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'baseline35Foo:' category: 'cat' timeStamp: '' source: self baseline35MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'baseline40Foo:' category: 'cat' timeStamp: '' source: self baseline40MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'baseline50Foo:' category: 'cat' timeStamp: '' source: self baseline50MethodSourceFoo). (MCMethodDefinition className: className asString selector: 'preloadDoIt' category: 'cat' timeStamp: '' source: self preloadDoItMethodSource)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! stableVersionD: spec "self reset" spec for: #'common' version: '4.2'. spec for: #'platformVersion1.x' version: '4.0'. spec for: #'platformVersion1.0.x' version: '4.1'. spec for: #'platformVersion1.1.x' version: '4.2'. spec for: #'platformVersion1.2.x' version: '4.3'. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline35MethodSourceFoo ^(self class sourceCodeAt: #baseline35Foo:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFee' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40ProjectFee: spec "projects and packages" "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '4.0'; file: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself. spec package: 'GeauxFaux' with: 'GeauxFaux-tg.32'; package: 'GeauxBeau' with: 'GeauxBeau-dkh.55'; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version120ProjectToolBox: spec spec for: #'common' do: [ spec project: 'Copied Example' copyFrom: 'Example Project' with: [ spec preLoadDoIt: #'alternatePreloadForCore' ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion13Issue154: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec project: 'MetacelloExample' with: [ spec className: 'ConfigurationOfMetacelloExample'; versionString: '1.0'; projectPackage: [ spec file: 'MetacelloExampleTestConfigurationIssue154.gemstone'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 05/10/2013 17:13'! setUpConfigurationOfProjectIssue156 "https://github.com/dalehenrich/metacello-work/issues/156" "self reset" self setUpIssue156BaselineOfGoo; setUpIssue156ConfigurationOfGoo! ! !MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion12Issue154: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec project: 'MetacelloExample' with: [ spec className: 'ConfigurationOfMetacelloExample'; versionString: '1.0'; projectPackage: [ spec name: 'MetacelloExampleTestConfigurationIssue154'; file: 'MetacelloExampleTestConfigurationIssue154.gemstone'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFeaux' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40MethodSourceFeaux ^(self class sourceCodeAt: #baseline40Feaux:) asString ! ! !MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue115dkh2: ancestors "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue115-dkh.2'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baselineVersion10Issue115:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baselineVersion10Issue115:) asString. MCMethodDefinition className: className asString selector: 'version10Issue115:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10Issue115:) asString. MCMethodDefinition className: className asString selector: 'version11Issue115:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version11Issue115:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version130ProjectToolBox: spec spec for: #'common' do: [ spec project: 'Example Project' with: [ spec className: 'MetacelloExampleProjectConfig'; versionString: '1.0-baseline'; preLoadDoIt: #'preloadDoIt'; postLoadDoIt: #'postloadDoIt'; repository: 'http://www.example.com/ob' ]; project: 'Copy Project' copyFrom: 'Example Project' with: [ spec repository: 'http://www.example.com/or' ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFoe' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40ProjectFoe: spec "projects and packages" "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '4.0'; loads: '1'; file: 'MetacelloTestConfigurationOfFoo'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectInfinite "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectInfinite-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baseline40ProjectInfinite:' category: 'cat' timeStamp: '' source: self baseline40MethodSourceProjectInfinite. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'Issue 154' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion10MetacelloExample: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: 'dkh 05/11/2013 08:49'! version20Issue156: spec "https://github.com/dalehenrich/metacello-work/issues/156" spec for: #'common' do: [ spec configuration: 'Goo' with: [ spec versionString: '4.0.0'; repository: 'dictionary://Metacello_MczConfiguration_Test_Repository' ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 05/11/2013 08:38'! setUpIssue156ConfigurationOfGoo "https://github.com/dalehenrich/metacello-work/issues/156" "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'ConfigurationOfGoo-dkh.1'. className := reference packageName asSymbol. definitionArray := {(MCOrganizationDefinition categories: (Array with: className)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: className instVarNames: #() comment: ''). (MCMethodDefinition className: className asString selector: 'baselineGoo300Issue156Configuration:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineGoo300Issue156Configuration:') asString). (MCMethodDefinition className: className asString selector: 'baselineGoo400Issue156Configuration:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineGoo400Issue156Configuration:') asString). (MCMethodDefinition className: className asString selector: 'baselineGoo500Issue156Configuration:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineGoo500Issue156Configuration:') asString)}. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #())! ! !MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40MethodSourceProjectLoop ^(self class sourceCodeAt: #baseline40ProjectLoop:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version121ProjectToolBox: spec spec for: #'common' do: [ spec blessing: #'testBlessing'. spec repository: 'http://www.example.com/vor'. spec package: 'Example-Core' with: [ spec includes: #('Example-AddOn' ); file: 'Example-Core-anon.1'; repository: 'http://www.example.com/or'; preLoadDoIt: #'preloadForCore'; postLoadDoIt: #'postloadForCore:package:'. ]; package: 'Example-AddOn' with: [ spec requires: #('Example-Core' ). ]; package: 'Example-Tests' with: [ spec requires: #('Example-AddOn' ). ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 77' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline13C: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with: 'GoferFoo-lr.4'; package: 'GeauxBeau' with: 'GeauxBeau-dkh.56'; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: 'dkh 6/12/2012 15:41:23.319'! version10Issue136: spec spec for: #'common' do: [ spec blessing: #development. spec package: 'GoferBeau' with: 'GoferBeau-dkh.15'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline50Foo: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with:'GoferFoo-lr.2'; package: 'GoferBar' with: 'GoferBar-lr.1'; package: 'GoferFaux' with: 'GoferFaux-tg.34'; package: 'GoferBeau' with: 'GoferBeau-dkh.55'; yourself. spec group: '1' with: #('GoferFoo' 'GoferBar'); group: '2' with: #('GoferFoo' 'GoferFaux'); yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 115' stamp: 'dkh 05/11/2013 08:51'! version30Issue156: spec "https://github.com/dalehenrich/metacello-work/issues/156" spec for: #'common' do: [ spec configuration: 'Goo' with: [ spec versionString: '5.0.0'; repository: 'dictionary://Metacello_MczConfiguration_Test_Repository' ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'Issue 95' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40ProjectIssue95: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec project: 'Loop' with: [ spec className: 'MetacelloTestConfigurationOfProjectLoop'; versionString: '4.0'; loads: 'GoferFaux'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; project: 'Infinite' with: [ spec className: 'MetacelloTestConfigurationOfProjectInfinite'; versionString: '4.0'; loads: 'GeauxBar'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ].! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfSymbolic "self reset" | reference className definitionArray | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfSymbolic-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'stableVersionD:' category: 'cat' timeStamp: '' source: self stableVersionDMethodSourceSymbolic. MCMethodDefinition className: className asString selector: 'version40Symbolic:' category: 'cat' timeStamp: '' source: self version40SymbolicMethodSourceSymbolic. MCMethodDefinition className: className asString selector: 'version41Symbolic:' category: 'cat' timeStamp: '' source: self version41SymbolicMethodSourceSymbolic. MCMethodDefinition className: className asString selector: 'version42Symbolic:' category: 'cat' timeStamp: '' source: self version42SymbolicMethodSourceSymbolic. MCMethodDefinition className: className asString selector: 'version43Symbolic:' category: 'cat' timeStamp: '' source: self version43SymbolicMethodSourceSymbolic. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()) ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version125ProjectToolBox: spec spec for: #'common' do: [ spec package: 'Example-Core' with: [ spec preLoadDoIt: #'preloadDoIt'; postLoadDoIt: #'postloadDoIt'. ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 119' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue119 "self reset" | versionInfo | versionInfo := self setUpConfigurationOfProjectIssue119dkh1. versionInfo := self setUpConfigurationOfProjectIssue119dkh2: {versionInfo}. versionInfo := self setUpConfigurationOfProjectIssue119dkh3: {versionInfo}. versionInfo := self setUpConfigurationOfProjectIssue119dkh4: {versionInfo}. versionInfo := self setUpConfigurationOfProjectIssue119dkh5: {versionInfo}. versionInfo := self setUpConfigurationOfProjectIssue119dkh6: {versionInfo}. versionInfo := self setUpConfigurationOfProjectIssue119dkh7: {versionInfo}! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfSymbolic' stamp: 'dkh 6/12/2012 15:41:23.319'! stableVersionDMethodSourceSymbolic ^(self class sourceCodeAt: #stableVersionD:) asString ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version131ProjectToolBox: spec spec for: #'common' do: [ spec blessing: #'baseline'. ]. spec for: #'level1_1' do: [ spec package: 'Example-Core' with: [ spec repository: 'http://www.example.com/1'. ]; package: 'Example-Core' with: [ spec repository: 'http://www.example.com/2'. ]; package: 'Example-Core' with: [ spec repository: 'http://www.example.com/3'. ]. spec for: #'level2_1' do: [ spec package: 'Example-Core' with: [ spec repository: 'http://www.example.com/4'. ]. spec for: #'level3_1' do: [ spec package: 'Example-Core' with: [ spec repository: 'http://www.example.com/5'. ]. ]. ]. spec for: #'level2_2' do: [ spec package: 'Example-Core' with: [ spec repository: 'http://www.example.com/6'. ]. spec for: #'level3_2' do: [ spec package: 'Example-Core' with: [ spec repository: 'http://www.example.com/7'. ]. ]. ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version124ProjectToolBox: spec spec for: #'common' do: [ spec repository: 'http://www.example.com/ac'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline20Foo: spec "self reset" spec for: #common do: [ spec repository: 'dictionary://Metacello_Gofer_Test_Repository'. spec package: 'GoferFoo' with: 'GoferFoo-lr.1'; package: 'GoferBar' with: 'GoferBar.branch-lr.1'; package: 'GoferFaux' with: 'GoferFaux-tg.30'; package: 'GoferBeau' with: 'GoferBeau-dkh.25'; yourself ]. ! ! !MetacelloConfigurationResource methodsFor: 'running' stamp: 'dkh 07/28/2013 10:40'! setUp "self reset" super setUp. self setUpMonticelloRepository; setUpConfigurationOfFoo; setUpConfigurationOfFeaux; setUpConfigurationOfProjectFie; setUpConfigurationOfProjectFee; setUpConfigurationOfFum; setUpConfigurationOfProjectFoe; setUpConfigurationOfFan; setUpConfigurationOfFix; setUpIssue77; setUpIssue95; setUpConfigurationOfSymbolic; setUpConfigurationOfProjectToolBox; setUpConfigurationOfProjectIssue115; setUpConfigurationOfProjectIssue136; setUpConfigurationOfProjectIssue119; setUpConfigurationOfProjectIssue171; setUpConfigurationOfProjectIssue154; setUpConfigurationOfProjectIssue156; setUpIssue156ConfigurationOfProjectGoo; setUpIssue156ConfigurationOfProjectSoo; setUpConfigurationOfProjectFum; setUpConfigurationOfProjectIssue125; yourself! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfFoo' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline40MethodSourceFoo ^(self class sourceCodeAt: #baseline40Foo:) asString ! ! !MetacelloConfigurationResource methodsFor: 'Issue 136' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfProjectIssue136dkh1 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MetacelloTestConfigurationOfProjectIssue136-dkh.1'. className := reference packageName asSymbol. definitionArray := { MCOrganizationDefinition categories: (Array with: className). MCClassDefinition name: className superclassName: #Object category: className instVarNames: #() comment: ''. MCMethodDefinition className: className asString classIsMeta: true selector: 'project' category: 'cat' timeStamp: '' source: self projectClassMethodSource. MCMethodDefinition className: className asString selector: 'project' category: 'cat' timeStamp: '' source: self projectMethodSource. MCMethodDefinition className: className asString selector: 'baselineVersion10Issue136:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #baselineVersion10Issue136:) asString. MCMethodDefinition className: className asString selector: 'version10Issue136:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #version10Issue136:) asString. }. monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^versionInfo! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectFum' stamp: 'dkh 7/19/2012 07:30'! baseline10ProjectFum: spec "self reset" spec for: #'common' do: [ spec project: 'Foo' with: [ spec className: 'MetacelloTestConfigurationOfFoo'; versionString: '5.0'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; project: 'Fie' with: [ spec className: 'MetacelloTestConfigurationOfProjectFie'; versionString: '2.5'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ]; yourself ]! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version123ProjectToolBox: spec spec for: #'common' do: [ spec project: 'Example Project' with: [ spec className: 'MetacelloExampleProjectConfig'; repository: 'http://www.example.com/ob'; repository: 'http://www.example.com/or' ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineVersion113ProjectToolBox: spec spec for: #'outer' do: [ spec package: 'Example-Core'; package: 'Example-Test'. ]. ! ! !MetacelloConfigurationResource methodsFor: 'ConfigurationOfProjectToolBox' stamp: 'dkh 6/12/2012 15:41:23.319'! version128ProjectToolBox: spec spec for: #'common' do: [ spec project: 'Example Project' with: [ spec preLoadDoIt: nil; postLoadDoIt: nil ]. ]. ! ! !MetacelloConfigurationResource methodsFor: 'Issue 125' stamp: 'dkh 9/11/2012 15:46'! version30Issue125: spec spec for: #'common' do: [ spec blessing: #'release'. spec description: 'MetacelloConfigurationResource>>version30Issue125:'. spec package: 'GoferFoo' with: 'GoferFoo-lr.4'; package: 'GoferBar' with: 'GoferBar-jf.1'; yourself ]. spec for: #'attribute1' do: [ spec package: 'GoferFaux' with: 'GoferFaux-tg.32'; package: 'GoferBeau' with: 'GoferBeau-dkh.55'; yourself ]. spec for: #'attribute2' do: [ spec package: 'GoferFaux' with: 'GoferFaux-tg.33'; package: 'GoferBeau' with: 'GoferBeau-dkh.56'; yourself ]! ! !MetacelloConfigurationResource class methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectAttributes ProjectAttributes == nil ifTrue: [ ^#() ]. ^ProjectAttributes! ! !MetacelloConfigurationResource class methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! project ^self new project! ! !MetacelloConfigurationResource class methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectAttributes: aCollection ProjectAttributes := aCollection! ! !MetacelloConfigurationSpecGenerator methodsFor: 'accessing' stamp: 'dkh 7/16/2012 11:28'! projectSpecLookupBlock ^ [ :projectName | {(MetacelloProjectRegistration projectSpecForClassNamed: (MetacelloScriptEngine configurationNameFrom: projectName) ifAbsent: [ ])} ]! ! !MetacelloConfigurationSpecGenerator methodsFor: 'accessing' stamp: 'dkh 7/16/2012 10:43'! projectSpecCreationBlock ^ [ :projectName | {(MetacelloMCProject new configurationOfProjectSpec name: projectName)} ]! ! !MetacelloConfigurationSpecGenerator methodsFor: 'accessing' stamp: 'dkh 7/16/2012 10:45'! projectSpecListBlock ^ [ MetacelloProjectRegistration configurationProjectSpecs ]! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson10 ^Lesson title: 'Lesson 10' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #baseline10:. Smalltalk tools browse: MetacelloTutorialConfig selector: #version10:. "In #baseline10: we''ve added two things: the ''Example-AddOnTests'' package and a specification for groups. The ''Example-AddOnTests'' package has been added to make the idea of needing to group packages a little more appealing. The package requires ''Example-AddOn'' and ''Example-Tests''. With two Test packages it would be convenient to be able to load all of the tests with a simple expression like the following:" (MetacelloTutorialConfig project version: ''1.0'') load: { ''Tests''. }. "instead of having to explicitly list all of the test projects like this:" (MetacelloTutorialConfig project version: ''1.0'') load: { ''Example-Tests''. ''Example-AddOnTests''. }. "This becomes especially useful if over time the project evolves to have more component and test packages. The ''default'' group is special in that when a ''default'' group is defined, the #load method loads the members of the ''default'' group instead of loading all of the packages:" (MetacelloTutorialConfig project version: ''1.0'') load. "If you want to load all of the packages in a project, then the pseudo group ''ALL'' may be used as follows:" (MetacelloTutorialConfig project version: ''1.0'') load: ''ALL''. ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson11Timestamp ^Lesson title: 'Lesson 11 (Timestamp)' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version11:. "The timestamp of a version can be defined:" (MetacelloTutorialConfig project version: ''1.1'') timestamp. "When using the OB-Metacello tools the timestamp field is automatically updated to reflect the current DateAndTime that the update was made. The timestamp is a String" ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson06 ^Lesson title: 'Lesson 6' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version06:. "In version 0.6 we''ve added dependency information in the form of the #requires: directive. Both ''Example-Tests'' and ''Example-AddOn'' require ''Example-Core'' to be loaded before they are loaded. Print the following expressions to see that the requires directives are being followed:" (MetacelloTutorialConfig project version: ''0.5'') load: { ''Example-Tests''. }. (MetacelloTutorialConfig project version: ''0.6'') load: { ''Example-Tests''. }. (MetacelloTutorialConfig project version: ''0.6'') load: ''Example-AddOn''. (MetacelloTutorialConfig project version: ''0.6'') load: { ''Example-AddOn''. ''Example-Tests''. }. "With version 0.6 we are mixing structural information (required packages and repository) with the dynamic file version info. It is expected that over time the file version info will change from version to version while the structural information will remain relatively static." ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:13'! lesson02 ^Lesson title: 'Lesson 2' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version02:. "For version 0.2, we''ve simply updated the package version to ''Example-Core-anon.9'', which can be confirmed by printing the following expression:" (MetacelloTutorialConfig project version: ''0.2'') spec. ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'tutorial' stamp: 'DaleHenrichs 11/15/2010 12:10'! tutorial ^ #(#lesson01 #lesson02 #lesson03 #lesson04 #lesson05 #lesson06 #lesson07 #lesson08 #lesson10 #lesson11 #lesson11Author #lesson11Blessing #lesson11Descripton #lesson11Timestamp #lesson12DoIts #lesson13)! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson05 ^Lesson title: 'Lesson 5' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version05:. "For version 0.5 we''ve added an additional package to the mix: ''Example-AddOn'':" (MetacelloTutorialConfig project version: ''0.5'') spec. "Of course, the point of specifiying packages in Metacello is to be able to load versions. Here are a couple examples of loading versions of the Tutorial. If you print the result of each expression, you will see the list of packages in load order (note that for the tutorial, we are using the MetacelloNullRecordingMCSpecLoader. This class records which packages are loaded and the order that they are loaded in among other things instead of actually loading the packages." (MetacelloTutorialConfig project version: ''0.1'') load. (MetacelloTutorialConfig project version: ''0.4'') load. (MetacelloTutorialConfig project version: ''0.5'') load. "You will note that in each case, all of the packages associated with the version are loaded, which is the default. If you want to load a subset of the packages in a project, you may list the packages that you are interested in as an argument to the #load: method:" (MetacelloTutorialConfig project version: ''0.5'') load: { ''Example-Tests''. ''Example-Core'' }. "Note that the ordering of the packages is based on the order in which the packages are specified. If you evaluate the following expression:" (MetacelloTutorialConfig project version: ''0.5'') load: { ''Example-Tests''. }. "Only the package is ''Example-Tests''. By default the packages are ordered, but there are no implicit dependencies." ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson08 ^Lesson title: 'Lesson 8' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version08:. "In version 0.8 we''ve simply updated the package versions, which can be seen by comparing the results of loading version 0.7 and 0.8:" (MetacelloTutorialConfig project version: ''0.7'') load. (MetacelloTutorialConfig project version: ''0.8'') load. ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:13'! lesson01 ^Lesson title: 'Lesson 1' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version01:. "Version 0.1 represents the simplest version specification possible. In the method #version01, version 0.1 is defined with a single package ''Example-Core-anon.8'' that is loaded from the repository ''http://www.example.com/Example''. Looking at this method you will notice a couple of things. Immediately after the method selector you see the pragma definition: The pragma indicates that the version created in this method should be associated with version ''0.1'' of the Tutorial project. Looking a little closer you see that the argument to the method, , is the only variable in the method and it is used as the receiver to four different messages: - #for:do: - #package:with: - #file: - #repository: With the evaluation of each block expression, a new object is pushed on a stack and the messages within the block are sent to the object on the top of the stack. So the method should be read as: Create version ''0.1''. The #common code for version ''0.1'' (#for:do:) consists of a package named ''Example-Core'' (#package:with:) whose file attribute is ''Example-Core-anon.8'' (#file:) and whose repository attribute is ''http://www.example.com/Example'' (#repository:). We can see the spec created for version 0.1 by printing the following expression:" (MetacelloTutorialConfig project version: ''0.1'') spec. "Note that in creating version ''0.1'' the #common attribute is extracted out. In addition to #common, there are pre-defined attributes for each of the platforms upon which Metacello runs (#pharo, #squeak, #gemstone and #squeakCommon). #squeakCommon is used for both #pharo and #squeak." ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'intro' stamp: 'DaleHenrichs 11/15/2010 12:14'! introductionText ^'Convers basic Metacello configuration specifications: 1. Open a code browser on the MetacelloTutorialConfig class:" MetacelloTutorialConfig browse. "2. In the browser view the ''--all--'' category. 3. Have fun!!"'! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson04 ^Lesson title: 'Lesson 4' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version04:. "The specification for version 0.4 is basically the same as version 0.3. Instead of listing a repository with each package we specify a project repository that applies to all packages. Compare the printStrings for the specs for each version:" (MetacelloTutorialConfig project version: ''0.3'') spec. (MetacelloTutorialConfig project version: ''0.4'') spec. ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson07 ^Lesson title: 'Lesson 7' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #baseline07:. Smalltalk tools browse: MetacelloTutorialConfig selector: #version07:. "For version 0.7, we are ceating a baseline version specification which is expected to be used across several versions and the version specification which is restricted to the file versions. In method #baseline07: the structure of version ''0.7-baseline'' is specified. The repository is listed, the packages are listed and the required packages are defined. We''ll cover the #blessing: in a later lesson. In method #version07: the file versions are specified. You will note that the pragma as an #imports: component that specifies the list of versions that this version (version ''0.7'') is based upon. In fact, if you print the spec for ''0.7-baseline'' and then print the spec for ''0.7'' you can see that ''0.7'' is a composition of both versions:" (MetacelloTutorialConfig project version: ''0.7-baseline'') spec. (MetacelloTutorialConfig project version: ''0.7'') spec. "Of course if you print the ''0.6'' spec and the ''0.7'' spec you can see that they specify exactly the same information in a slightly different way:" (MetacelloTutorialConfig project version: ''0.6'') spec. (MetacelloTutorialConfig project version: ''0.7'') spec. "and if you load each of the versions, you will see that they load the same packages, in the same order:" (MetacelloTutorialConfig project version: ''0.6'') load. (MetacelloTutorialConfig project version: ''0.7'') load. "Finally, even though version ''0.7-baseline'' does not have explicit package versions, you may load the version. When the ''real'' loader encounters a package name (without version information) it will attempt to load the latest version of the package from the repository. With the MetacelloNullRecordingMCSpecLoader the packages names are ''loaded'':" (MetacelloTutorialConfig project version: ''0.7-baseline'') load. "Of course when a number of developers are working on a project it may be useful to load a #baseline version so that you get the latest work from all of the project members. " ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson11Author ^Lesson title: 'Lesson 11 (Author)' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version11:. "The author of a version can be defined:" (MetacelloTutorialConfig project version: ''1.1'') author. "When using the OB-Metacello tools the author field is automatically updated to reflect the current author as defined in the image." ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:13'! lesson03 ^Lesson title: 'Lesson 3' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version03:. "For version 0.3, we''ve updated the package version to ''Example-Core-anon.10'' and added an additional package ''Example-Tests-anon.3'', which can be confirmed by printing the following expression:" (MetacelloTutorialConfig project version: ''0.3'') spec "As is often the case, the two packages share the same repository, so specifying a repository with each package is redundant." ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson11 ^Lesson title: 'Lesson 11' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version11:. "In version 0.11 we''ve defined a couple of attributes that are expected to be used all of the time in a version specification: #blessing: #description: #author: #timestamp: The following lessons cover each of these attributes in more detail. " ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson11Descripton ^Lesson title: 'Lesson 11 (Description)' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version11:. "A description can be defined for a version:" (MetacelloTutorialConfig project version: ''1.1'') description. ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:15'! lesson13 ^Lesson title: 'Lesson 12 (DoIts)' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #baseline13:. Smalltalk tools browse: MetacelloTutorialConfig selector: #version13:. "For version 1.3 we are adding a platform specific package ''Example-Platform''. ''Example-Platform'' requires ''Example-Core''. On GemStone, Pharo and Squeak, a branch of the ''Example-Platform'' package will be loaded: ''Example-Platform.gemstone'', ''Example-Platform.pharo'', ''Example-Platform.squeak'' respectively will be loaded. Consequently we''ve updated the baselines with #baseline13: to reflect the structural changes and #version13: reflects the package versions. The platform-specific versions and branches are defined in the #for:do: block for the corresponding platforms: #gemstone, #pharo, #squeak (in both methods) The result of the following expression will depend on the platform upon which you are running:" (MetacelloTutorialConfig project version: ''1.3'') load. "Note that when you execute the following expresson to load ''Example-Core'' that the correct ''Example-Platform'' is loaded as well:" (MetacelloTutorialConfig project version: ''1.3'') load: ''Example-Core''. "If you look at the specification for ''Example-Core'' (in #baseline13:) you will note that ''Example-Core'' #includes: ''Example-Platform''. The #includes: directive means that the package ''Example-Platform'' should be loaded whenever the ''Example-Core'' package is loaded. Also note when you evaluate the following expression that the ''Example-Platform'' package is loaded before ''Example-Tests'' as if ''Example-Tests'' #requires: ''Example-Platform'':" (MetacelloTutorialConfig project version: ''1.3'') load: ''Example-Tests''. "When you use the #includes: directive, you are not only specifying that the listed packages should be loaded when the parent package is loaded, but that the #included: packages should be loaded _before_ any packages that require the parent package." ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson12DoIts ^Lesson title: 'Lesson 12 (DoIts)' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version12:. Smalltalk tools browse: MetacelloTutorialConfig selector: #preloadForCore. Smalltalk tools browse: MetacelloTutorialConfig selector: #postloadForCore:package:. "Occassionally, you find that you need to perform an expression either before a package is loaded, or after a package is loaded. To do that in Metacello, you can define a preLoadDoIt selector and a postLoadDoIt selector:" (MetacelloTutorialConfig project version: ''1.2'') spec. "If you open a Transcript and execute the following expression, you will see that the pre load and post load methods were executed:" (MetacelloTutorialConfig project version: ''1.2'') load. "The pre/post load methods may take 0, 1 or 2 args. The loader is the first optional argument and the loaded packageSpec is the second optional argument." ProfStef next. '! ! !MetacelloConfigurationTutorialPart1 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:14'! lesson11Blessing ^Lesson title: 'Lesson 11 (Blessing)' lesson: ' Smalltalk tools browse: MetacelloTutorialConfig selector: #version11:. "A version can be tagged with a blessing like #alpha, #beta, #release, #development or any other tag that you find useful. The blessing for version 1.1 is #development" (MetacelloTutorialConfig project version: ''1.1'') blessing. "The default blessing is #release, so even though we didn''t specify a blessing for version 0.5, the blessing is set:" (MetacelloTutorialConfig project version: ''0.5'') blessing. "For version 1.1, it is important to explicitly set the blessing, because it imports version ''1.0-baseline'' whose blessing is #baseline:" (MetacelloTutorialConfig project version: ''1.0-baseline'') blessing. "Blessings can be used as a filter. For example, you will notice that the result of the following expression is version 0.6, because #stableVersion answers the latest version whose blessing is _not_ #development, #broken, or #blessing: " MetacelloTutorialConfig project stableVersion. MetacelloTutorialConfig project stableVersion load. "The blessing of version 1.1 is #development. To find the latest #development version you would execute this expression:" MetacelloTutorialConfig project latestVersion: #development. (MetacelloTutorialConfig project latestVersion: #development) load. "You can get the very last version independent of blessing by executing this expression:" MetacelloTutorialConfig project bleedingEdge. MetacelloTutorialConfig project bleedingEdge load. "In general, the #development blessing should be used for any version that is unstable. Once a version has stabilized, a different blessing should be applied. The following expression will load the latest version of all of the packages for the latest #baseline version:" (MetacelloTutorialConfig project latestVersion: #baseline) load. "Since the latest #baseline version should reflect the most up-to-date project structure, executing the previous expression should load the absolute bleeding edge of the project. " ProfStef next. '! ! !MetacelloConfigurationTutorialPart2 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:15'! lesson10 ^Lesson title: 'Lesson 10' lesson: ' Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #baseline10:. Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #version10:. "In lesson07 it was obvious that we copied the configuration information from MetacelloTutorialConfig and adapted it to our project. There is a better way. In #baseline10: we''ve created a project reference for the Example project. The #className: specifies the name of the class that contains the project metadata. If the class is not present in the image, then we know that we need to load the configuration for the project. The #file: and #repository: specifications give us the information needed to load the project metadata from a repository. Finally, the #versionString: and #loads: tell us which version of the project to load and which packages to load from the project. We''ve named the project reference ''Example ALL'' and in the specification for the ''Project-Core'' package, we''ve specified that ''Example ALL'' is required:" (MetacelloProjectRefTutorialConfig project version: ''1.0'') load. "Note that the entire Example project is loaded before ''Project-Core''" ProfStef next. ' ! ! !MetacelloConfigurationTutorialPart2 methodsFor: 'intro' stamp: 'DaleHenrichs 11/15/2010 12:14'! introductionText ^'Covers project reference specifications: 1. Open a code browser on the MetacelloTutorialConfig class:" MetacelloTutorialConfig browse. "2. In the browser view the ''--all--'' category. 3. Have fun!!"'! ! !MetacelloConfigurationTutorialPart2 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:15'! lesson12 ^Lesson title: 'Lesson 12' lesson: ' Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #baseline11:. Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #baseline12:. Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #version12:. "In #baseline11: there is redundant information for each of the project references. In #baseline12: we use the #project:copyFrom:with: method to eliminate the need to specify the bulk of the project information twice. Evaluate and compare the results of the following expressions:" (MetacelloProjectRefTutorialConfig project version: ''1.1'') load: ''Project-Core''. (MetacelloProjectRefTutorialConfig project version: ''1.2'') load: ''Project-Core''. (MetacelloProjectRefTutorialConfig project version: ''1.1'') load: ''Project-Tests''. (MetacelloProjectRefTutorialConfig project version: ''1.2'') load: ''Project-Tests''. ProfStef next. '! ! !MetacelloConfigurationTutorialPart2 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:15'! lesson07 ^Lesson title: 'Lesson 7' lesson: ' Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #baseline07:. Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #version07:. "NOTE: you should run through the lessons in Part 1 first. In this configuration we are defining a project that utilizes the packages from the Example project (MetacelloTutorialConfig): ''Example-Core'', ''Example-AddOn'', ''Example-Tests'' and 2 packages specific to the project: ''Project-Core'' and ''Project-Tests'':" (MetacelloProjectRefTutorialConfig project version: ''0.7'') load. ProfStef next. '! ! !MetacelloConfigurationTutorialPart2 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:16'! lesson14 ^Lesson title: 'Lesson 14' lesson: ' Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #baseline14:. Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #version14:. "In this lesson we''ll cover the querying API for Metacello. The querying API is useful for analyzing the contents and structure of a version. To start with we''ll look at version ''1.4'' of the MetacelloProjectRefTutorialConfig. You can list the packages in the version:" (MetacelloProjectRefTutorialConfig project version: ''1.4'') packages. "The list project references:" (MetacelloProjectRefTutorialConfig project version: ''1.4'') projects. "And the groups:" (MetacelloProjectRefTutorialConfig project version: ''1.4'') groups. "You can access individual packages/project refs/groups using the #packageNamed: method. Here you can access the package named: ''Project-Core'':" (MetacelloProjectRefTutorialConfig project version: ''1.4'') packageNamed: ''Project-Core''. "The project reference named ''Example Default'':" (MetacelloProjectRefTutorialConfig project version: ''1.4'') packageNamed: ''Example Default''. "The group named ''Core'':" (MetacelloProjectRefTutorialConfig project version: ''1.4'') packageNamed: ''Core''. "Each of the attributes of the package can be accessed (#requires, #includes, #file, #repository, #preLoadDoIt, and #postLoadDoit). For example:" ((MetacelloProjectRefTutorialConfig project version: ''1.4'') packageNamed: ''Project-Core'') requires. "Each of the attributes of the project can be accessed (#className, #versionString, #operator, #loads, #file, and #repository). For example:" ((MetacelloProjectRefTutorialConfig project version: ''1.4'') packageNamed: ''Example Default'') repository. "Each of the attributes of the group can be accessed (#includes). For example:" ((MetacelloProjectRefTutorialConfig project version: ''1.4'') packageNamed: ''default'') includes. "When looking at the ''Core'' group, there is only one package listed:" (MetacelloProjectRefTutorialConfig project version: ''1.4'') packageNamed: ''Core''. "In the case of the ''Core'' group, it is defined in terms of the ''default'', which isn''t very useful. When looking at the contents of groups you''d like to see the complete list of packages, without having to explicitly expanding each group you encounter. #packagesForSpecNamed: does just that:" (MetacelloProjectRefTutorialConfig project version: ''1.4'') packagesForSpecNamed: ''Core''. "If you were to load the ''Core'' package:" (MetacelloProjectRefTutorialConfig project version: ''1.4'') load: ''Core''. "You end up seeing the packages from the Example project. If you want to get the list of packages that _would_ be loaded, you can use #allPackagesForSpecNamed:. For example:" (MetacelloProjectRefTutorialConfig project version: ''1.4'') allPackagesForSpecNamed: ''Core''. "If you use #allPackagesForSpecNamed: with a project refernce name, you''ll see the packages that _would_ be loaded:" (MetacelloProjectRefTutorialConfig project version: ''1.4'') load: ''Example Default''. (MetacelloProjectRefTutorialConfig project version: ''1.4'') allPackagesForSpecNamed: ''Example Default''. "You can also send #version to a project reference. This is useful if you want to explicitly walk the tree of projects:" ((MetacelloProjectRefTutorialConfig project version: ''1.4'') packageNamed: ''Example Default'') version. ProfStef next. '! ! !MetacelloConfigurationTutorialPart2 methodsFor: 'tutorial' stamp: 'DaleHenrichs 11/15/2010 12:24'! tutorial ^ #(#lesson07 #lesson10 #lesson11 #lesson12 #lesson13 #lesson14)! ! !MetacelloConfigurationTutorialPart2 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:15'! lesson11 ^Lesson title: 'Lesson 11' lesson: ' Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #baseline11:. Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #version11:. "As is often the case, it is useful to separate the test package from the core packages for a project. In #baseline11: we''ve created two project references. The reference named ''Example Default'' loads the ''default'' group and the reference named ''Example Tests'' loads the ''Tests'' group. We then made ''Project-Core'' require ''Example Default'' and ''Project-Tests'' requires ''Project-Core'' and ''Example Tests''. Now it is possible to load just the core packages:" (MetacelloProjectRefTutorialConfig project version: ''1.1'') load: ''Project-Core''. "or the whole enchilada including tests:" (MetacelloProjectRefTutorialConfig project version: ''1.1'') load: ''Project-Tests''. ProfStef next. '! ! !MetacelloConfigurationTutorialPart2 methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:15'! lesson13 ^Lesson title: 'Lesson 13' lesson: ' Smalltalk tools browse: MetacelloProjectRefTutorialConfig selector: #version13:. "In #version13: we are importing the ''1.2-baseline'', but changing the Example project version to 1.3, so project versions can be updated in the verson method jus like package versions. Evaluate and compare the results of these expressions:" (MetacelloProjectRefTutorialConfig project version: ''1.2'') load: ''Project-Core''. (MetacelloProjectRefTutorialConfig project version: ''1.3'') load: ''Project-Core''. (MetacelloProjectRefTutorialConfig project version: ''1.2'') load: ''Project-Tests''. (MetacelloProjectRefTutorialConfig project version: ''1.3'') load: ''Project-Tests''. "It is worth noting that in version 1.3 of the Example project, the platform-specific ''Example-Platform'' was introduced and nothing special had to be done in the project reference to get the package included." ProfStef next. '! ! !MetacelloCopyMemberSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock copyBlock value: self! ! !MetacelloCopyMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! sourceName: aString sourceName := aString! ! !MetacelloCopyMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! sourceName ^sourceName! ! !MetacelloCopyMemberSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! applyToList: aListSpec aListSpec copy: self! ! !MetacelloCopyMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! methodUpdateSelector ^#copy:! ! !MetacelloCoreIssue125TestCase methodsFor: 'tests' stamp: 'dkh 05/11/2013 10:58'! testForDoListAtrribute2Active "https://github.com/dalehenrich/metacello-work/issues/125" | project version expected actual | project := self projectWith: #(#'attribute2'). version := project version: '3.0-baseline'. expected := 'spec blessing: #''baseline''. spec preLoadDoIt: #''preloadForCore''. spec postLoadDoIt: #''postloadForCore:package:''. spec project: ''Example Project'' with: [ spec className: ''ConfigurationOfExampleProject''; versionString: ''1.0-baseline''; preLoadDoIt: #''preloadForProject''; postLoadDoIt: #''postloadForProject''; loads: #(''core'' ) ]; project: ''Extra Project'' with: [ spec className: ''ConfigurationOfExtraProject''; versionString: ''1.0-baseline''; preLoadDoIt: #''preloadForProject''; postLoadDoIt: #''postloadForProject''; loads: #(''core'' ) ]. spec group: ''Core'' with: #(''Example Project'' ); group: ''Core'' with: #(''Extra Project'' ).'. actual := version spec printString. self assert: expected = actual! ! !MetacelloCoreIssue125TestCase methodsFor: 'accessing' stamp: 'dkh 9/11/2012 14:57'! projectWith: projectAttributes | project | "Construct Metacello project" project := MetacelloProject new. project projectAttributes: projectAttributes. MetacelloVersionConstructor on: self project: project. ^ project! ! !MetacelloCoreIssue125TestCase methodsFor: 'baselines' stamp: 'dkh 9/11/2012 14:59'! baseline200: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec preLoadDoIt: #'preloadForCore'; postLoadDoIt: #'postloadForCore:package:'. spec project: 'Example Project' with: [ spec className: 'ConfigurationOfExampleProject'; versionString: '1.0-baseline'; preLoadDoIt: #'preloadForProject'; postLoadDoIt: #'postloadForProject'; loads: #('core'); yourself ]; yourself. spec group: 'Core' with: #('Example Project') ]! ! !MetacelloCoreIssue125TestCase methodsFor: 'baselines' stamp: 'dkh 9/11/2012 14:57'! baseline300: spec spec for: #(#'attribute1' #'attribute2') do: [ spec project: 'Extra Project' with: [ spec className: 'ConfigurationOfExtraProject'; versionString: '1.0-baseline'; preLoadDoIt: #'preloadForProject'; postLoadDoIt: #'postloadForProject'; loads: #('core'); yourself ]; yourself. spec group: 'Core' with: #('Extra Project') ]! ! !MetacelloCoreIssue125TestCase methodsFor: 'tests' stamp: 'dkh 05/11/2013 11:02'! testForDoListNotActive "https://github.com/dalehenrich/metacello-work/issues/125" | project version expected actual | project := self projectWith: #(). version := project version: '3.0-baseline'. expected := 'spec blessing: #''baseline''. spec preLoadDoIt: #''preloadForCore''. spec postLoadDoIt: #''postloadForCore:package:''. spec project: ''Example Project'' with: [ spec className: ''ConfigurationOfExampleProject''; versionString: ''1.0-baseline''; preLoadDoIt: #''preloadForProject''; postLoadDoIt: #''postloadForProject''; loads: #(''core'' ) ]. spec group: ''Core'' with: #(''Example Project'' ).'. actual := version spec printString. self assert: expected = actual! ! !MetacelloCoreIssue125TestCase methodsFor: 'accessing' stamp: 'dkh 9/11/2012 14:57'! project ^self projectWith: #()! ! !MetacelloCoreIssue125TestCase methodsFor: 'tests' stamp: 'dkh 05/11/2013 10:59'! testForDoListAttribute1Atrribute2Active "https://github.com/dalehenrich/metacello-work/issues/125" | project version expected actual | project := self projectWith: #(#'attribute1' #'attribute2'). version := project version: '3.0-baseline'. expected := 'spec blessing: #''baseline''. spec preLoadDoIt: #''preloadForCore''. spec postLoadDoIt: #''postloadForCore:package:''. spec project: ''Example Project'' with: [ spec className: ''ConfigurationOfExampleProject''; versionString: ''1.0-baseline''; preLoadDoIt: #''preloadForProject''; postLoadDoIt: #''postloadForProject''; loads: #(''core'' ) ]; project: ''Extra Project'' with: [ spec className: ''ConfigurationOfExtraProject''; versionString: ''1.0-baseline''; preLoadDoIt: #''preloadForProject''; postLoadDoIt: #''postloadForProject''; loads: #(''core'' ) ]; project: ''Extra Project'' with: [ spec className: ''ConfigurationOfExtraProject''; versionString: ''1.0-baseline''; preLoadDoIt: #''preloadForProject''; postLoadDoIt: #''postloadForProject''; loads: #(''core'' ) ]. spec group: ''Core'' with: #(''Example Project'' ); group: ''Core'' with: #(''Extra Project'' ); group: ''Core'' with: #(''Extra Project'' ).'. actual := version spec printString. self assert: expected = actual! ! !MetacelloCoreIssue125TestCase methodsFor: 'tests' stamp: 'dkh 05/11/2013 10:54'! testForDoListAtrribute1Active "https://github.com/dalehenrich/metacello-work/issues/125" | project version expected actual | project := self projectWith: #(#'attribute1'). version := project version: '3.0-baseline'. expected := 'spec blessing: #''baseline''. spec preLoadDoIt: #''preloadForCore''. spec postLoadDoIt: #''postloadForCore:package:''. spec project: ''Example Project'' with: [ spec className: ''ConfigurationOfExampleProject''; versionString: ''1.0-baseline''; preLoadDoIt: #''preloadForProject''; postLoadDoIt: #''postloadForProject''; loads: #(''core'' ) ]; project: ''Extra Project'' with: [ spec className: ''ConfigurationOfExtraProject''; versionString: ''1.0-baseline''; preLoadDoIt: #''preloadForProject''; postLoadDoIt: #''postloadForProject''; loads: #(''core'' ) ]. spec group: ''Core'' with: #(''Example Project'' ); group: ''Core'' with: #(''Extra Project'' ).'. actual := version spec printString. self assert: expected = actual! ! !MetacelloCoreSymbolicVersionTest methodsFor: 'baselines' stamp: 'dkh 9/11/2012 11:25'! baseline10: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec project: 'Example Project' with: [ spec className: 'MetacelloExampleProjectConfig'; versionString: '1.0-baseline'; preLoadDoIt: #'preloadForProject'; postLoadDoIt: #'postloadForProject'; yourself ] ]! ! !MetacelloCoreSymbolicVersionTest methodsFor: 'accessing' stamp: 'dkh 9/11/2012 11:23'! projectWith: projectAttributes | project | "Construct Metacello project" project := MetacelloProject new. project projectAttributes: projectAttributes. MetacelloVersionConstructor on: self project: project. ^ project! ! !MetacelloCoreSymbolicVersionTest methodsFor: 'tests' stamp: 'dkh 9/11/2012 11:27'! testBleedingEdgeMethod | project version | project := self projectWith: #(#'platformVersion1.x'). self assert: (project version: #'bleedingEdge') = project bleedingEdge! ! !MetacelloCoreSymbolicVersionTest methodsFor: 'versions' stamp: 'dkh 9/11/2012 11:26'! bleedingEdge: spec spec for: #'platformVersion1.x' version: '1.0-baseline'! ! !MetacelloCoreSymbolicVersionTest methodsFor: 'baselines' stamp: 'dkh 9/11/2012 11:25'! baseline20: spec spec for: #'common' do: [ spec blessing: #'baseline'. spec project: 'Example Project' with: [ spec className: 'MetacelloExampleProjectConfig'; versionString: '1.0-baseline'; preLoadDoIt: #'preloadForProject'; postLoadDoIt: #'postloadForProject'; yourself ] ]! ! !MetacelloCoreSymbolicVersionTest methodsFor: 'tests' stamp: 'dkh 9/11/2012 11:27'! testBasicStableVersion | project version wc expected actual | project := self projectWith: #(#'platformVersion1.x'). version := project version: #'stable'. expected := 'spec blessing: #''release''. spec project: ''Example Project'' with: [ spec className: ''MetacelloExampleProjectConfig''; versionString: ''1.0-baseline''; preLoadDoIt: #''preloadForProject''; postLoadDoIt: #''postloadForProject'' ].'. actual := version spec printString. self assert: expected = actual! ! !MetacelloCoreSymbolicVersionTest methodsFor: 'accessing' stamp: 'dkh 9/11/2012 11:23'! project ^self projectWith: #()! ! !MetacelloCoreSymbolicVersionTest methodsFor: 'tests' stamp: 'dkh 9/11/2012 11:28'! testStableVersionMethod | project version | project := self projectWith: #(#'platformVersion1.x'). self assert: (project version: #'stable') = project stableVersion! ! !MetacelloCoreSymbolicVersionTest methodsFor: 'tests' stamp: 'dkh 9/11/2012 11:29'! testBasicBleedingEdgeVersion | project version wc expected actual | project := self projectWith: #(#'platformVersion1.x'). version := project version: #'bleedingEdge'. expected := 'spec blessing: #''baseline''. spec project: ''Example Project'' with: [ spec className: ''MetacelloExampleProjectConfig''; versionString: ''1.0-baseline''; preLoadDoIt: #''preloadForProject''; postLoadDoIt: #''postloadForProject'' ].'. actual := version spec printString. self assert: expected = actual! ! !MetacelloCoreSymbolicVersionTest methodsFor: 'versions' stamp: 'dkh 9/11/2012 11:26'! version10: spec spec for: #'common' do: [ spec blessing: #'release' ]! ! !MetacelloCoreSymbolicVersionTest methodsFor: 'versions' stamp: 'dkh 9/11/2012 11:26'! stableVersion: spec spec for: #'platformVersion1.x' version: '1.0'! ! !MetacelloCoreVersionQueryTestCase methodsFor: 'baselines' stamp: 'dkh 9/11/2012 11:38'! baseline10: spec spec for: #'common' do: [ spec project: 'UTF8' with: [ spec className: 'MetacelloVersionQueryMiscConfig'; versionString: '1.0-baseline'; loads: #('Misc-UTF8') ]. spec group: 'Core' with: #('UTF8'); group: 'Tests' with: #('UTF8'); group: 'Recursive' with: #('Core' 'Recursive') "recursive group definition" ]! ! !MetacelloCoreVersionQueryTestCase methodsFor: 'accessing' stamp: 'dkh 9/11/2012 11:36'! projectWith: projectAttributes | project | "Construct Metacello project" project := MetacelloProject new. project projectAttributes: projectAttributes. MetacelloVersionConstructor on: self project: project. ^ project! ! !MetacelloCoreVersionQueryTestCase methodsFor: 'baselines' stamp: 'dkh 9/11/2012 12:03'! baseline20: spec spec for: #'common' do: [ spec project: 'UTF8' with: [ spec className: 'MetacelloVersionQueryMiscConfig'; versionString: #'stable'; loads: #('Misc-UTF8') ]. spec project: 'UTF9' with: [ spec className: 'MetacelloVersionQueryOtherConfig'; versionString: '1.0-baseline'; loads: #('Misc-UTF8') ]. spec group: 'Core' with: #('UTF8' 'UTF9'); group: 'Tests' with: #('UTF8'); group: 'Recursive' with: #('Core' 'Recursive') "recursive group definition" ]! ! !MetacelloCoreVersionQueryTestCase methodsFor: 'baselines' stamp: 'dkh 9/11/2012 12:07'! baseline11: spec spec for: #'common' do: [ spec project: 'UTF7' with: [ spec className: 'MetacelloVersionQueryMiscConfig'; versionString: '1.0-baseline'; loads: #('Misc-UTF7') ]. spec group: 'Core' with: #('UTF7'); group: 'Tests' with: #('UTF7'); yourself ]! ! !MetacelloCoreVersionQueryTestCase methodsFor: 'tests' stamp: 'dkh 9/11/2012 11:36'! testBaseline10Groups | project version expected list | project := self project. version := project version: '1.0-baseline'. expected := #('Core' 'Tests' 'Recursive'). list := version groups. self assert: list size = expected size. list do: [ :pkg | self assert: (expected includes: pkg name) ]! ! !MetacelloCoreVersionQueryTestCase methodsFor: 'accessing' stamp: 'dkh 9/11/2012 11:36'! project ^self projectWith: #()! ! !MetacelloCoreVersionQueryTestCase methodsFor: 'tests' stamp: 'dkh 9/11/2012 12:08'! testDifference | project expected fromVersionString toVersionString report actual | project := self project. fromVersionString := '1.1-baseline'. toVersionString := '2.0-baseline'. report := (project version: fromVersionString) difference: (project version: toVersionString). report from: fromVersionString; to: toVersionString; configuration: 'Test Configuration'. expected := 'Test Configuration ''1.1-baseline'' to ''2.0-baseline'' Additions: UTF9 '''' to ''1.0-baseline'' Modifications: UTF8 ''1.0-baseline'' to ''stable'' Removals: UTF7 ''1.0-baseline'' to '''' '. actual := report printString. self assert: expected = actual! ! !MetacelloCoreVersionQueryTestCase methodsFor: 'tests' stamp: 'dkh 9/11/2012 11:40'! testBaseline10ResolveToLoadableSpecs01 | project version expected list | project := self project. version := project version: '1.0-baseline'. expected := #('UTF8'). list := version resolveToLoadableSpecs: #('UTF8'). self assert: list size = expected size. list do: [ :pkg | self assert: (expected includes: pkg name) ]. expected := #('UTF8'). list := version resolveToLoadableSpecs: #('Recursive'). self assert: list size = expected size. list do: [ :pkg | self assert: (expected includes: pkg name) ]! ! !MetacelloCoreVersionQueryTestCase methodsFor: 'tests' stamp: 'dkh 9/11/2012 11:38'! testBaseline10Projects | project version expected list | project := self project. version := project version: '1.0-baseline'. expected := #('UTF8'). list := version projects. self assert: list size = expected size. list do: [ :pkg | self assert: (expected includes: pkg name) ]! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'private' stamp: 'DaleHenrichs 1/5/2011 15:16'! repositoryName ^#'Metacello_Dev_Cycle_Repository'! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'tests' stamp: 'DaleHenrichs 12/18/2010 12:38'! testCreateNewBaseline | expected output | self createConfiguration; createDevelopment; validateAndSave; releaseDevelopment; createNewDevelopment; createNewBaseline; yourself. expected := self versionCommonBaselineSpecString. Smalltalk at: self configurationName ifPresent: [ :cl | output := (cl project version: '1.1-baseline') versionSpec printString. self assert: output = expected ]! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'tests' stamp: 'DaleHenrichs 12/18/2010 12:15'! testReleaseDevelopment | repo repoVersionsSize altRepo altRepoVersionsSize output expected | repo := Smalltalk at: self repositoryName. repoVersionsSize := repo allVersionInfos size. altRepo := Smalltalk at: self alternatRepositoryName. altRepoVersionsSize := altRepo allVersionInfos size. self createConfiguration; createDevelopment; validateAndSave; releaseDevelopment; yourself. self assert: repo allVersionInfos size = (repoVersionsSize + 2). self assert: altRepo allVersionInfos size = (altRepoVersionsSize + 1). expected := self version10ReleaseVersionSpecString. Smalltalk at: self configurationName ifPresent: [ :cl | | versionSpec | versionSpec := (cl project version: '1.0') versionSpec. versionSpec timestamp: ''. output := versionSpec printString. self assert: output = expected. self should: [ cl project version: #development ] raise: Error. versionSpec := (cl project version: #stable) versionSpec. versionSpec timestamp: ''. output := versionSpec printString. self assert: output = expected ]! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'private' stamp: 'dkh 3/7/2012 15:59:13'! version11CommonVersionSpecString ^ ' spec description: ''''. spec author: ''TesterBob''. spec timestamp: ''''. spec repository: ''dictionary://Metacello_Dev_Cycle_Repository''. spec project: ''MetacelloTestConfigurationOfFoo'' with: [ spec className: ''MetacelloTestConfigurationOfFoo''; versionString: #''bleedingEdge''; repository: ''dictionary://Metacello_Dev_Cycle_Repository'' ]; project: ''MetacelloTestConfigurationOfFoo'' with: ''4.0''. spec package: ''GeauxFaux'' with: [ spec requires: #(''MetacelloTestConfigurationOfFoo'' ). ]; package: ''GeauxBeau'' with: [ spec requires: #(''GeauxFaux'' ). ]; package: ''GeauxFaux'' with: ''GeauxFaux-tg.32''; package: ''GeauxBeau'' with: ''GeauxBeau-dkh.55''. spec group: ''default'' with: #(''Core'' ); group: ''Core'' with: #(''GeauxFaux'' ); group: ''Tests'' with: #(''GeauxBeau'' ); group: ''Core Tests'' with: #(''Core'' ''Tests'' ).'! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'running' stamp: 'ChristopheDemarey 5/24/2013 15:05'! runCase | original | original := MetacelloPlatform current bypassGoferLoadUpdateCategories. [ MetacelloPlatform current bypassGoferLoadUpdateCategories: true. ^ MetacelloPlatform current suspendSystemUpdateEventsDuring: [ super runCase ] ] ensure: [ MetacelloPlatform current bypassGoferLoadUpdateCategories: original ]! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'tests' stamp: 'DaleHenrichs 12/17/2010 16:24'! testValidateAndSave | repo allVersionsSize | repo := Smalltalk at: self repositoryName. allVersionsSize := repo allVersionInfos size. self createConfiguration; createDevelopment; validateAndSave; yourself. self assert: (MetacelloToolBox validateConfiguration: (Smalltalk at: self configurationName)) isEmpty. self assert: repo allVersionInfos size = (allVersionsSize + 1)! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'lessons' stamp: 'DaleHenrichs 12/18/2010 12:31'! createNewBaseline MetacelloToolBox createNewBaselineVersionIn: (Smalltalk at: self configurationName) description: ''. ! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'tests' stamp: 'DaleHenrichs 12/18/2010 12:38'! testCreateConfiguration | expected output | self createConfiguration. expected := self versionCommonBaselineSpecString. Smalltalk at: self configurationName ifPresent: [ :cl | output := (cl project version: '1.0-baseline') versionSpec printString. self assert: output = expected ]! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'lessons' stamp: 'dkh 3/7/2012 15:59:13'! createConfiguration MetacelloToolBox createBaseline: '1.0-baseline' for: self configurationName asString repository: 'dictionary://' , self repositoryName asString requiredProjects: #('MetacelloTestConfigurationOfFoo') packages: #('GeauxFaux' 'GeauxBeau') repositories: {('MetacelloTestConfigurationOfFoo' -> {('dictionary://' , self repositoryName asString)})} dependencies: {('GeauxFaux' -> #('MetacelloTestConfigurationOfFoo')). ('GeauxBeau' -> #('GeauxFaux'))} groups: {('default' -> #('Core')). ('Core' -> #('GeauxFaux')). ('Tests' -> #('GeauxBeau')). ('Core Tests' -> #('Core' 'Tests'))}! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'lessons' stamp: 'DaleHenrichs 01/24/2011 14:14'! validateAndSave | wc | MetacelloToolBox validateConfiguration: (Smalltalk at: self configurationName). PackageInfo registerPackageName: self configurationName asString. "register workingCopy for gofer to use" wc := MCWorkingCopy forPackage: (MetacelloTestsMCPackage new name: self configurationName asString). (wc repositoryGroup respondsTo: #disableCache) ifTrue: [wc repositoryGroup perform: #disableCache]. Gofer new disablePackageCache; repository: (Smalltalk at: self repositoryName); package: self configurationName asString; commit: 'Initial configuration'. "fix it so that the directory repository is used for subsequent saves" wc := (Smalltalk at: self configurationName) project projectPackage workingCopy. wc repositoryGroup addRepository: (Smalltalk at: self repositoryName). MetacelloToolBox saveConfigurationPackageFor: self configurationName asString description: 'commit message'. ! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'lessons' stamp: 'dkh 1/16/2011 10:54'! createNewDevelopment MetacelloToolBox createNewDevelopmentVersionIn: (Smalltalk at: self configurationName) description: ''. ! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'private' stamp: 'DaleHenrichs 12/18/2010 12:17'! version10ReleaseVersionSpecString ^'spec blessing: #''release''.', self version10CommonVersionSpecString! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'private' stamp: 'dkh 3/7/2012 15:59:13'! version10CommonVersionSpecString ^ ' spec description: ''initial version''. spec author: ''TesterBob''. spec timestamp: ''''. spec repository: ''dictionary://Metacello_Dev_Cycle_Repository''. spec project: ''MetacelloTestConfigurationOfFoo'' with: [ spec className: ''MetacelloTestConfigurationOfFoo''; versionString: #''bleedingEdge''; repository: ''dictionary://Metacello_Dev_Cycle_Repository'' ]; project: ''MetacelloTestConfigurationOfFoo'' with: ''4.0''. spec package: ''GeauxFaux'' with: [ spec requires: #(''MetacelloTestConfigurationOfFoo'' ). ]; package: ''GeauxBeau'' with: [ spec requires: #(''GeauxFaux'' ). ]; package: ''GeauxFaux'' with: ''GeauxFaux-tg.32''; package: ''GeauxBeau'' with: ''GeauxBeau-dkh.55''. spec group: ''default'' with: #(''Core'' ); group: ''Core'' with: #(''GeauxFaux'' ); group: ''Tests'' with: #(''GeauxBeau'' ); group: ''Core Tests'' with: #(''Core'' ''Tests'' ).'! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'running' stamp: 'dkh 4/18/2011 18:21'! tearDown | aGofer | super tearDown. aGofer := Gofer new. self tearDownPackages: aGofer. aGofer references notEmpty ifTrue: [ aGofer metacelloUnload ]. Smalltalk removeKey: self repositoryName ifAbsent: [ ]. Smalltalk removeKey: self alternatRepositoryName ifAbsent: [ ]. Smalltalk removeKey: #'Metacello_Gofer_Test_Repository' ifAbsent: []. Smalltalk removeKey: #'Metacello_Configuration_Test_Repository' ifAbsent: []. Smalltalk at: self configurationName ifPresent: [ :cl | cl removeFromSystem ]. self tempRepositories do: [:repo | MCRepositoryGroup default removeRepository: repo ]. (self hasPackage: self configurationName asString) ifTrue: [ (Gofer new) package: self configurationName asString; metacelloUnload ]. MetacelloPlatform current authorName: authorName.! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'accessing' stamp: 'dkh 4/18/2011 18:20'! tempRepositories tempRepositories ifNil: [ tempRepositories := OrderedCollection new ]. ^tempRepositories! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'private' stamp: 'DaleHenrichs 12/18/2010 12:16'! version10DevelopmentVersionSpecString ^'spec blessing: #''development''.', self version10CommonVersionSpecString! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'tests' stamp: 'DaleHenrichs 12/18/2010 12:15'! testCreateDevelopment | expected output | self createConfiguration; createDevelopment; yourself. expected := self version10DevelopmentVersionSpecString. Smalltalk at: self configurationName ifPresent: [ :cl | | versionSpec | versionSpec := (cl project version: '1.0') versionSpec. versionSpec timestamp: ''. output := versionSpec printString. self assert: output = expected. versionSpec := (cl project version: #development) versionSpec. versionSpec timestamp: ''. output := versionSpec printString. self assert: output = expected ]! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'running' stamp: 'dkh 4/18/2011 18:21'! setUp | repo gofer | super setUp. repo := MCDictionaryRepository new. repo description: 'dictionary://', self repositoryName asString. self tempRepositories add: repo. Smalltalk at: self repositoryName put: repo. repo := MCDictionaryRepository new. repo description: 'dictionary://', self alternatRepositoryName asString. self tempRepositories add: repo. Smalltalk at: self alternatRepositoryName put: repo. Smalltalk at: self configurationName ifPresent: [:cl | cl removeFromSystem ]. repo := MetacelloConfigurationResource current monticelloRepository. self tempRepositories add: repo. Smalltalk at: #'Metacello_Configuration_Test_Repository' put: repo. gofer := Gofer new repository: repo; package: 'MetacelloTestConfigurationOfProjectFee'; metacelloLoad. repo := MetacelloMonticelloResource current monticelloRepository. repo description: 'dictionary://Metacello_Gofer_Test_Repository'. self tempRepositories add: repo. Smalltalk at: #'Metacello_Gofer_Test_Repository' put: repo. (Smalltalk at: #MetacelloTestConfigurationOfProjectFee) new project load: '4.0'. authorName := MetacelloPlatform current authorName. MetacelloPlatform current authorName: 'TesterBob'. ! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'tests' stamp: 'DaleHenrichs 01/16/2011 14:38'! testCreateNewDevelopment | expected output cl versionSpec report | self createConfiguration; createDevelopment; validateAndSave; releaseDevelopment; createNewDevelopment; yourself. cl := Smalltalk at: self configurationName. expected := self version10ReleaseVersionSpecString. versionSpec := (cl project version: '1.0') versionSpec. versionSpec timestamp: ''. output := versionSpec printString. self assert: output = expected. expected := self version11DevelopmentVersionSpecString. versionSpec := (cl project version: '1.1') versionSpec. versionSpec timestamp: ''. output := versionSpec printString. self assert: output = expected. versionSpec := (cl project version: #development) versionSpec. versionSpec timestamp: ''. output := versionSpec printString. self assert: output = expected. report := MetacelloToolBox compareVersionsIn: cl. #(additions modifications removals) do: [:key | self assert: (report perform: key) keys size = 0 ]. self assert: (report configuration) = self configurationName asString. self assert: (report from) = '1.0'. self assert: (report to) = '1.1'.! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'private' stamp: 'DaleHenrichs 1/5/2011 15:16'! alternatRepositoryName ^#'Metacello_Dev_Cycle_Alternate_Repository'! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'private' stamp: 'dkh 3/7/2012 15:59:13'! versionCommonBaselineSpecString ^ 'spec blessing: #''baseline''. spec repository: ''dictionary://Metacello_Dev_Cycle_Repository''. spec project: ''MetacelloTestConfigurationOfFoo'' with: [ spec className: ''MetacelloTestConfigurationOfFoo''; versionString: #''bleedingEdge''; repository: ''dictionary://Metacello_Dev_Cycle_Repository'' ]. spec package: ''GeauxFaux'' with: [ spec requires: #(''MetacelloTestConfigurationOfFoo'' ). ]; package: ''GeauxBeau'' with: [ spec requires: #(''GeauxFaux'' ). ]. spec group: ''default'' with: #(''Core'' ); group: ''Core'' with: #(''GeauxFaux'' ); group: ''Tests'' with: #(''GeauxBeau'' ); group: ''Core Tests'' with: #(''Core'' ''Tests'' ).'! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'private' stamp: 'DaleHenrichs 12/18/2010 12:21'! version11DevelopmentVersionSpecString ^'spec blessing: #''development''.', self version11CommonVersionSpecString! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'running' stamp: 'DaleHenrichs 12/18/2010 11:58'! tearDownPackages: aGoferInstance (self hasPackage: 'GoferFoo') ifTrue: [ aGoferInstance package: 'GoferFoo' ]. (self hasPackage: 'GoferBar') ifTrue: [ aGoferInstance package: 'GoferBar' ]. (self hasPackage: 'GoferFaux') ifTrue: [ aGoferInstance package: 'GoferFaux' ]. (self hasPackage: 'GoferBeau') ifTrue: [ aGoferInstance package: 'GoferBeau' ]. (self hasPackage: 'GeauxFaux') ifTrue: [ aGoferInstance package: 'GeauxFaux' ]. (self hasPackage: 'GeauxBeau') ifTrue: [ aGoferInstance package: 'GeauxBeau' ]. (self hasPackage: 'MetacelloTestConfigurationOfFoo') ifTrue: [ aGoferInstance package: 'MetacelloTestConfigurationOfFoo' ]. (self hasPackage: 'MetacelloTestConfigurationOfProjectFee') ifTrue: [ aGoferInstance package: 'MetacelloTestConfigurationOfProjectFee' ]. ! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'private' stamp: 'DaleHenrichs 01/16/2011 14:27'! configurationName ^#'ConfigurationOfMetacello_Dev_Cycle'! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:06.921'! defaultTimeout "I don't want no stkinkin' timeouts" ^60000! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'lessons' stamp: 'DaleHenrichs 12/17/2010 16:35'! releaseDevelopment MetacelloToolBox releaseDevelopmentVersionIn: (Smalltalk at: self configurationName) description: '- release version 1.0'. MetacelloToolBox copyConfiguration: (Smalltalk at: self configurationName) to: 'dictionary://', self alternatRepositoryName asString! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'lessons' stamp: 'DaleHenrichs 12/17/2010 16:10'! createDevelopment MetacelloToolBox createDevelopment: '1.0' for: self configurationName asString importFromBaseline: '1.0-baseline' description: 'initial version'. ! ! !MetacelloDevelopmentCycleTutorialTests methodsFor: 'private' stamp: 'DaleHenrichs 12/17/2010 16:25'! hasPackage: aString | package | package := MCWorkingCopy allManagers detect: [ :each | each packageName = aString ] ifNone: [ nil ]. ^ package notNil! ! !MetacelloDevelopmentProcess methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:16'! createDevelopmentVersion ^Lesson title: '2. Create development version' lesson: '"After the configuration and initial baseline version have been created, define the initial development version:" MetacelloToolBox createDevelopment: ''1.0'' for: ''Example'' importFromBaseline: ''1.0-baseline'' description: ''initial version''. "After evaluating the above expression, take a look at the #version10: method in ConfigurationOfExample:" Smalltalk tools browse: ConfigurationOfExample selector: #version10:. "The current version of the Shout project has been filled in as well as the current version of the ProfStef packages. When a new development version is created the #development symbolic version is defined as well:" Smalltalk tools browse: ConfigurationOfExample selector: #development:. "The #development version is defined as 1.0 for all platforms. Note that the #development symbolic version is used in a number of the Development Support scripts, so you want to make sure that it is kept up-to-date." ProfStef next. '! ! !MetacelloDevelopmentProcess methodsFor: 'intro' stamp: 'dkh 9/11/2012 17:16'! introductionText ^'This tutorial covers some of the methods that can be found in the MetacelloToolBox. CREATE PROJECT 1. Create configuration and baseline version 2. Create development version 3. Validate and save configuration in project repository DEVELOPMENT 4. Checkpoint save 5. Integrate code contributions 6. Compare versions RELEASE 7. Release development version 8. Create new development version For convenience, a number of the methods covered in these sections can be found in the ''development support'' category on the class-side of MetacelloBaseConfiguration." Smalltalk tools browse: MetacelloBaseConfiguration class selector: #DevelopmentProcess. "After deciding which of the development support methods you will use in your project, copy the methods of interest to the the class-side of your own configuration or implement your own ''development support'' methods using the MetacelloToolBox API:" HelpBrowser openOn: MetacelloAPIDocumentation "'! ! !MetacelloDevelopmentProcess methodsFor: 'lessons' stamp: 'dkh 9/11/2012 17:16'! createConfigurationAndBaseline ^Lesson title: '1. Create configuration' lesson: '"The MetacelloToolBox class provides programmatic support for creating and maintaining your configuration. Use the following expression to create your configuration class and initial baseline version. Edit the expression to specifiy the required projects, packages, dependencies and groups for your project:" MetacelloToolBox createBaseline: ''1.0-baseline'' for: ''Example'' repository: ''http://www.squeaksource.com/ProfStef'' requiredProjects: #(''Shout'') packages: #(''ProfStef-Core'' ''ProfStef-Tests'') dependencies: {(''ProfStef-Core'' -> #(''Shout'')). (''ProfStef-Tests'' -> #(''ProfStef-Core''))} groups: {(''default'' -> #(''Core'')). (''Core'' -> #(''ProfStef-Core'')). (''Tests'' -> #(''ProfStef-Tests'')). (''Core Tests'' -> #(''Core'' ''Tests''))}. "After evaluating the above expression, browse the configuration:" Smalltalk tools browse: ConfigurationOfExample selector: #baseline10:. "Edit the #baseline10 method in the browser to fine tune the baseline specification." ProfStef next. '! ! !MetacelloDevelopmentProcess methodsFor: 'lessons' stamp: 'DaleHenrichs 12/17/2010 12:24'! createNewDevelopmentVersion ^Lesson title: '8. Create new development version' lesson: '"After releasing a version it isn''t a bad idea to open a new development version for the next phase of development:" MetacelloToolBox createNewDevelopmentVersionIn: ConfigurationOfExample description: ''- aim at implementing new features''. "The above expression uses the #release version as a template for the new version with the #release minor version number incremented." ProfStef next. '! ! !MetacelloDevelopmentProcess methodsFor: 'tutorial' stamp: 'DaleHenrichs 12/17/2010 12:16'! tutorial ^#( createConfigurationAndBaseline createDevelopmentVersion validateAndSaveConfiguration checkpointSave integrateCodeContributions compareVersions releaseVersion createNewDevelopmentVersion)! ! !MetacelloDevelopmentProcess methodsFor: 'lessons' stamp: 'DaleHenrichs 12/17/2010 11:28'! checkpointSave ^Lesson title: '4. Checkpoint save' lesson: '"After having done development for awhile, you may want to checkpoint your work to share with others, test in another development environment or just to backup your work. You can save the modified mcz files, update the development version spec with the new mcz file names and then save the configuration:" MetacelloToolBox saveModifiedPackagesAndConfigurationIn: ConfigurationOfExample description: ''- fixed Issue 1090''. "Or you can arrange to just save the modified mcz files and update the development version spec with the new mcz file names:" MetacelloToolBox saveModifiedPackagesIn: ConfigurationOfExample description: ''- fixed Issue 1090''. ProfStef next. '! ! !MetacelloDevelopmentProcess methodsFor: 'lessons' stamp: 'DaleHenrichs 1/14/2011 12:21'! compareVersions ^Lesson title: '6. Compare versions' lesson: '"Occasionally, it is useful to view the mcz and project version changes between the #development symbolic version and the #stable symbolic version:" (MetacelloToolBox compareVersionsIn: ConfigurationOfExample) inspect. ProfStef next. '! ! !MetacelloDevelopmentProcess methodsFor: 'lessons' stamp: 'DaleHenrichs 12/17/2010 12:14'! releaseVersion ^Lesson title: '7. Release development version' lesson: '"When you ready to release the #development version of your project, the following things need to be done: 1. Change #blessing of version to #release 2. Set the #development symbolic version to #notFound (no longer in development) 3. Set the #stable symbolic version to the current #development version 4. Save the configuration 5. Copy the configuration to http://www.squeaksource.com/MetacelloRepository (optional). Steps 1-4 are performed by the following expression:" MetacelloToolBox releaseDevelopmentVersionIn: ConfigurationOfExample description: ''- release version 1.0''. "If you want to copy the saved configuration to another repository, use the following expression:" MetacelloToolBox copyConfiguration: ConfigurationOfExample to: ''http://www.example.com/MetacelloRepository''. ProfStef next. '! ! !MetacelloDevelopmentProcess methodsFor: 'lessons' stamp: 'DaleHenrichs 12/17/2010 11:37'! integrateCodeContributions ^Lesson title: '5. Integrate code contributions' lesson: '"If other developers have commited new versions of the packages in your project you can integrate the changes into your configuration by first loading the latest packages in your project:" (ConfigurationOfExample project version: #baseline) load. "Then updating the mcz file specifications in #development version:" MetacelloToolBox updateToLatestPackageVersionsIn: ConfigurationOfExample description: ''- integrated code from Barney and Fred''. "Then checkpoint the configuration:" MetacelloToolBox saveConfigurationPackageFor: ''Example'' description: ''- integrated code from Barney and Fred''. ProfStef next. '! ! !MetacelloDevelopmentProcess methodsFor: 'lessons' stamp: 'DaleHenrichs 12/17/2010 11:09'! validateAndSaveConfiguration ^Lesson title: '3. Validate and save configuration in project repository' lesson: '"Before saving a configuration into the project repository, the configuration should be validated and any Critical Issues should be addressed:" (MetacelloToolBox validateConfiguration: ConfigurationOfExample) explore. "Use Gofer to save the configuration to your project repository:" Gofer new url: ''http://www.example.com/ExampleRepository''; package: ''ConfigurationOfExample''; commit: ''Initial configuration''. "Once you''ve done your initial commit, you can use the following expression to save the configuration to your project repository:" MetacelloToolBox saveConfigurationPackageFor: ''Example'' description: ''commit message''. "Note that MetacelloToolBox class>>saveConfigurationPackageFor:description: validates the configuration before saving." ProfStef next. '! ! !MetacelloDevelopmentProcess class methodsFor: 'tutorial metainfo' stamp: 'DaleHenrichs 12/17/2010 10:31'! title ^'Metacello Development Cycle'! ! !MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! alternateRepository "MetacelloAlternateResource reset" ^ MetacelloAlternateResource current monticelloRepository! ! !MetacelloDictionaryRepositoryTest methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectWith: projectAttributes | project | "Construct Metacello project" project := MetacelloMCProject new. project projectAttributes: projectAttributes. MetacelloVersionConstructor on: self project: project. project loader: ((project loaderClass new) shouldDisablePackageCache: true; yourself). project loadType: self loadType. ^project ! ! !MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! configurationRepository "MetacelloConfigurationResource reset" ^ MetacelloConfigurationResource current monticelloRepository! ! !MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! doSilently ^true! ! !MetacelloDictionaryRepositoryTest methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! monticelloRepository "MetacelloMonticelloResource reset" ^ MetacelloMonticelloResource current monticelloRepository! ! !MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: 'ChristopheDemarey 4/29/2013 16:22'! runCase | original | (self doSilently) ifFalse: [ ^super runCase ]. original := MetacelloPlatform current bypassGoferLoadUpdateCategories. [ MetacelloPlatform current bypassGoferLoadUpdateCategories: true. ^ MetacelloPlatform current suspendSystemUpdateEventsDuring: [ super runCase ] ] ensure: [ MetacelloPlatform current bypassGoferLoadUpdateCategories: original ]! ! !MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! tearDown | aGofer | super tearDown. aGofer := Gofer new. self tearDownPackages: aGofer. aGofer references notEmpty ifTrue: [ aGofer metacelloUnload ]. Smalltalk removeKey: #'Metacello_Gofer_Test_Repository' ifAbsent: []. Smalltalk removeKey: #'Metacello_Configuration_Test_Repository' ifAbsent: []. Smalltalk removeKey: #'Metacello_Configuration_Test_Alternate_Repository' ifAbsent: []. self tempRepositories do: [:repo | MCRepositoryGroup default removeRepository: repo ]. ! ! !MetacelloDictionaryRepositoryTest methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! project | constructor project | "Construct Metacello project" constructor := MetacelloVersionConstructor on: self. project := constructor project. project loader: ((project loaderClass new) shouldDisablePackageCache: true; yourself). project loadType: self loadType. ^project! ! !MetacelloDictionaryRepositoryTest methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! tempRepositories tempRepositories ifNil: [ tempRepositories := OrderedCollection new ]. ^tempRepositories! ! !MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUp | repo | super setUp. MetacelloConfigurationResource projectAttributes: nil. repo := self monticelloRepository. self tempRepositories add: repo. gofer repository: repo. Smalltalk at: #'Metacello_Gofer_Test_Repository' put: repo. repo := self alternateRepository. self tempRepositories add: repo. Smalltalk at: #'Metacello_Configuration_Test_Alternate_Repository' put: repo. repo := self configurationRepository. self tempRepositories add: repo. Smalltalk at: #'Metacello_Configuration_Test_Repository' put: repo. ! ! !MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! tearDownPackages: aGoferInstance (self hasPackage: 'GoferFoo') ifTrue: [ aGoferInstance package: 'GoferFoo' ]. (self hasPackage: 'GoferBar') ifTrue: [ aGoferInstance package: 'GoferBar' ]. (self hasPackage: 'GoferFaux') ifTrue: [ aGoferInstance package: 'GoferFaux' ]. (self hasPackage: 'GoferBeau') ifTrue: [ aGoferInstance package: 'GoferBeau' ]. (self hasPackage: 'MetacelloTestConfigurationOfFoo') ifTrue: [ aGoferInstance package: 'MetacelloTestConfigurationOfFoo' ]. ! ! !MetacelloDictionaryRepositoryTest methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! defaultTimeout "I don't want no stkinkin' timeouts" ^60000! ! !MetacelloDictionaryRepositoryTest methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! loadType ^#linear! ! !MetacelloDictionaryRepositoryTest methodsFor: 'utilities' stamp: 'dkh 6/12/2012 15:41:23.319'! hasPackage: aString | package | package := MCWorkingCopy allManagers detect: [ :each | each packageName = aString ] ifNone: [ nil ]. ^ package notNil! ! !MetacelloDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! packageDo: aBlock ! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! prepostLoadDo: aBlock ! ! !MetacelloDirective methodsFor: 'initialize-release' stamp: 'dkh 6/8/2012 14:04:22'! spec: packageOrVersionSpec loader: aLoader spec := packageOrVersionSpec. loader := aLoader! ! !MetacelloDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loader ^loader! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! directivesDo: aBlock aBlock value: self! ! !MetacelloDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: aLoaderDirective gofer: aGofer self subclassResponsibility! ! !MetacelloDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loader: aLoader loader := aLoader! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! prepostLoadDirectivesDo: aBlock ! ! !MetacelloDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! addTo: aLoaderDirective aLoaderDirective add: self! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! packageDirectivesDo: aBlock ! ! !MetacelloDirective methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! label ^self spec label! ! !MetacelloDirective methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! printOn: aStream self printOn: aStream indent: 0! ! !MetacelloDirective methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! printString "Explicit override of superclass implementation. When you are printing a loadDirective it is annoying to have it truncated." ^String streamContents: [:s | self printOn: s]! ! !MetacelloDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! title self subclassResponsibility! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! versionDirectivesDepthFirstDo: aBlock ! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! versionDirectivesDo: aBlock ! ! !MetacelloDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! postLoadDo: aBlock ! ! !MetacelloDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! preLoadDo: aBlock! ! !MetacelloDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! versionDo: aBlock ! ! !MetacelloDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! spec ^spec! ! !MetacelloDirective methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! printOn: aStream indent: indent indent timesRepeat: [ aStream tab ]. aStream nextPutAll: self title; nextPutAll: ' : '; nextPutAll: self label. ! ! !MetacelloDirective class methodsFor: 'instance creation' stamp: 'dkh 6/8/2012 14:04:22'! postLoadSpec: packageOrVersionSpec loader: aLoader ^MetacelloPostLoadDirective new spec: packageOrVersionSpec loader: aLoader! ! !MetacelloDirective class methodsFor: 'instance creation' stamp: 'dkh 6/8/2012 14:04:22'! preLoadSpec: packageOrVersionSpec loader: aLoader ^MetacelloPreLoadDirective new spec: packageOrVersionSpec loader: aLoader! ! !MetacelloDirective class methodsFor: 'instance creation' stamp: 'dkh 6/8/2012 14:04:22'! loader: aLoader ^self new loader: aLoader! ! !MetacelloDirective class methodsFor: 'instance creation' stamp: 'dkh 6/8/2012 14:04:22'! loadPackage: aPackageSpec externalReference: externalReference loader: aLoader ^MetacelloPackageLoadDirective new spec: aPackageSpec externalReference: externalReference loader: aLoader! ! !MetacelloEnsureFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! scheduleFetchFor: packageSpec cachedReference: reference "reference already in the cache during fetch ...schedule a load directive for reference, so ensured load will come from cache" ^ self scheduleFetchFor: packageSpec reference: reference message: 'Fetched -> (cached) ' , reference name , ' --- ' , reference repository description , ' --- ' , reference repository description! ! !MetacelloEnsureFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! ensureSpecLoader ^ self! ! !MetacelloEnsureFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! scheduleFetchFor: packageSpec nearestReference: reference "latest version in repository already matches the cached reference...schedule a load directive for reference, so ensured load will come from cache" ^ self scheduleFetchFor: packageSpec reference: reference message: 'Fetched -> (nearest) ' , reference name , ' --- ' , reference repository description , ' --- ' , reference repository description! ! !MetacelloErrorInProjectConstructionNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! exception: anObject exception := anObject! ! !MetacelloErrorInProjectConstructionNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString ^ versionString! ! !MetacelloErrorInProjectConstructionNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! exception ^ exception! ! !MetacelloErrorInProjectConstructionNotification methodsFor: 'exception description' stamp: 'dkh 6/5/2012 19:01:24'! defaultAction "Answer false if you want the version recorded in the errorMap. Answer true if you want to go ahead and throw the error" ^ false! ! !MetacelloErrorInProjectConstructionNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString: anObject versionString := anObject! ! !MetacelloErrorInProjectConstructionNotification class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! versionString: aString exception: anException ^ self new versionString: aString; exception: anException; signal! ! !MetacelloExampleProjectConfig methodsFor: 'baselines' stamp: 'dkh 6/12/2012 15:41:23.319'! baseline10: spec spec for: #common do: [ spec package: 'Example-Core'; package: 'Example-AddOn' with: [ spec requires: #('Example-Core' ) ]; package: 'Example-Tests' with: [ spec requires: #('Example-AddOn' ) ]; package: 'Example-TestsUI' with: [ spec requires: #('Example-UI' 'Example-Tests' ) ]; package: 'Example-UI' with: [ spec requires: #('Example-AddOn' ) ]]. ! ! !MetacelloExplicitLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! explicitLoadUsing: aLoaderDirective gofer: aGofer aLoaderDirective loadLinearLoadDirective: self gofer: aGofer. ! ! !MetacelloExplicitLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: aLoaderDirective gofer: aGofer aLoaderDirective loadExplicitLoadDirective: self gofer: aGofer. ! ! !MetacelloExplicitLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! title ^'explicit load'! ! !MetacelloExplicitLoadDirective methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isExplicit ^true! ! !MetacelloExplicitLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! explicitLoadWithPolicy: aLoadPolicy | gofer | gofer := MetacelloGofer new. gofer disablePackageCache. gofer repository: aLoadPolicy cacheRepository. self explicitLoadUsing: self gofer: gofer! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! explicitLoadPackageSpecs: packageSpecs repositories: repositories | directive | directive := self loaderPolicy pushExplicitLoadDirectivesDuring: [ super linearLoadPackageSpecs: packageSpecs repositories: repositories ] for: self. directive explicitLoadWithPolicy: self loaderPolicy.! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! scheduleFetchFor: packageSpec nearestReference: reference "latest version in repository already matches the cached reference...no need to schedule fetch" ^ self! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! atomicLoadPackageSpecs: packageSpecs repositories: repositories self loaderPolicy pushAtomicLoadDirectivesDuring: [ super linearLoadPackageSpecs: packageSpecs repositories: repositories ] for: self ! ! !MetacelloFetchingMCSpecLoader methodsFor: 'versionInfo' stamp: 'dkh 6/8/2012 14:04:22'! currentVersionInfoFor: packageSpec ^self loadData currentVersionInfoFor: packageSpec ifAbsent: [ super currentVersionInfoFor: packageSpec ]! ! !MetacelloFetchingMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! doLoad self loaderPolicy copy load! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadData ^self loaderPolicy loadData! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadingSpecLoader ^(MetacelloLoadingMCSpecLoader on: self spec) shouldDisablePackageCache: self shouldDisablePackageCache; loaderPolicy: self loaderPolicy copy; yourself! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! ensureSpecLoader ^ (MetacelloEnsureFetchingMCSpecLoader on: self spec) shouldDisablePackageCache: self shouldDisablePackageCache; loaderPolicy: self loaderPolicy; "explicitly share the loaderPolicy" yourself! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! actionLabel ^'Fetching '! ! !MetacelloFetchingMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! linearLoadPackageSpec: packageSpec gofer: gofer MetacelloPlatform current do: [ | references nearestReference cachedReference externalReference mcVersion loadedVersionInfos | "check to see if mcz file is already in cacheRepository" cachedReference := self resolvePackageSpec: packageSpec cachedGofer: self loaderPolicy cacheGofer. (cachedReference ~~ nil and: [ packageSpec getFile ~~ nil ]) ifTrue: [ cachedReference name = packageSpec file ifTrue: [ "exact match between packageSpec file and cache" ^ self scheduleFetchFor: packageSpec cachedReference: cachedReference ] ]. "look up mcz file" references := self retryingResolvePackageSpecReferences: packageSpec gofer: gofer. nearestReference := references last asMetacelloCachingResolvedReference. "If the mcz is already in the cacheRepository, no need to copy" (cachedReference ~~ nil and: [ cachedReference name = nearestReference name ]) ifTrue: [ "latest reference in repository matches cachedReference ... " ^ self scheduleFetchFor: packageSpec nearestReference: nearestReference ]. "If the mcz is already loaded into the image, no need to copy" (self ignoreImage not and: [ (loadedVersionInfos := self ancestorsFor: packageSpec) ~~ nil ]) ifTrue: [ loadedVersionInfos do: [ :info | info name = nearestReference name ifTrue: [ ^ self ] ] ]. externalReference := (references select: [ :ref | ref name = nearestReference name ]) first asMetacelloCachingResolvedReference. self repositoryMap at: externalReference name put: externalReference repository. (self resolveDependencies: externalReference nearest: nearestReference into: (OrderedCollection with: nearestReference)) do: [ :reference | | pSpec l | mcVersion := reference version. (l := (GoferVersionReference name: reference name) resolveAllWith: self loaderPolicy cacheGofer) isEmpty ifTrue: [ self cacheRepository storeVersion: mcVersion. reference == nearestReference ifTrue: [ pSpec := packageSpec ] ifFalse: [ pSpec := packageSpec project packageSpec. pSpec name: mcVersion package name ]. self loadData addVersion: mcVersion versionInfo: mcVersion info resolvedReference: reference packageSpec: pSpec ] ]. self scheduleFetchFor: packageSpec externalReference: externalReference ] displaying: 'Fetching ' , packageSpec file! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! cacheRepository ^self loaderPolicy cacheRepository! ! !MetacelloFetchingMCSpecLoader methodsFor: 'doits' stamp: 'dkh 6/8/2012 14:04:22'! preLoad: packageOrVersionSpec (MetacelloDirective preLoadSpec: packageOrVersionSpec loader: self) addTo: self loadDirective ! ! !MetacelloFetchingMCSpecLoader methodsFor: 'doits' stamp: 'dkh 6/8/2012 14:04:22'! postLoad: packageOrVersionSpec (MetacelloDirective postLoadSpec: packageOrVersionSpec loader: self) addTo: self loadDirective ! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! resolveDependencies: aResolvedReference nearest: nearestReference into: aCollection | block retryCount coll notDone | self flag: 'Not used, but retained to avoid upgrade issues'. block := [ :dependency | | reference | reference := MetacelloCachingGoferResolvedReference name: dependency versionInfo name repository: aResolvedReference repository. coll add: reference. Transcript cr; show: 'Fetched dependency -> ', reference name, ' --- ', reference repository description. self resolveDependencies: reference nearest: reference into: coll]. retryCount := 0. notDone := true. coll := OrderedCollection new. [ notDone and: [ retryCount < 3 ]] whileTrue: [ retryCount > 0 ifTrue: [ Transcript cr; show: '...RETRY' ]. [ "ensure that all resolved references have cached their version while wrapped by error handler" aCollection do: [:each | each version ]. nearestReference version dependencies do: block. notDone := false ] on: Error do: [:ex | retryCount := retryCount + 1. retryCount >= 3 ifTrue: [ ex pass ]. coll := OrderedCollection new ]]. aCollection addAll: coll. ^aCollection! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! ensuredMap ^self loaderPolicy ensuredMap! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! linearLoadPackageSpecs: packageSpecs repositories: repositories self loaderPolicy pushLinearLoadDirectivesDuring: [ super linearLoadPackageSpecs: packageSpecs repositories: repositories ] for: self! ! !MetacelloFetchingMCSpecLoader methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! printOn: aStream super printOn: aStream. aStream nextPut: $(. self loadDirective printOn: aStream. aStream nextPut: $)! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! scheduleFetchFor: packageSpec externalReference: reference ^ self scheduleFetchFor: packageSpec reference: reference message: 'Fetched -> ' , reference name , ' --- ' , reference repository description , ' --- ' , reference repository description! ! !MetacelloFetchingMCSpecLoader methodsFor: 'versionInfo' stamp: 'dkh 6/8/2012 14:04:22'! ancestorsFor: packageSpec ^self loadData ancestorsFor: packageSpec ifAbsent: [ super ancestorsFor: packageSpec ]! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadDirective ^self loaderPolicy loadDirective! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! resolvePackageSpec: packageSpec cachedGofer: gofer | versionReference references | versionReference := packageSpec goferLoaderReference. (references := versionReference resolveAllWith: gofer) isEmpty ifTrue: [ ^nil ]. ^references last asMetacelloCachingResolvedReference. ! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! scheduleFetchFor: packageSpec reference: reference message: message self loaderPolicy resetCacheGofer. self preLoad: packageSpec. (MetacelloDirective loadPackage: packageSpec externalReference: reference loader: self) addTo: self loadDirective. self postLoad: packageSpec. Transcript cr; show: message! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! scheduleFetchFor: packageSpec cachedReference: reference "reference already in the cache during fetch ...no need to schedule fetch" ^ self! ! !MetacelloGenericProjectSpec methodsFor: 'scripting' stamp: 'dkh 04/02/2013 20:22'! hasNoLoadConflicts: aMetacelloProjectSpec "'projectPackage repositories'" ^ (super hasNoLoadConflicts: aMetacelloProjectSpec) and: [ (self repositories isEmpty or: [ aMetacelloProjectSpec repositories isEmpty ]) or: [ self repositories hasNoLoadConflicts: aMetacelloProjectSpec repositories ] ]! ! !MetacelloGenericProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/15/2012 13:37'! compareEqual: aMetacelloProjectSpec "'projectPackage repositories'" ^ (super compareEqual: aMetacelloProjectSpec) and: [ self repositories compareEqual: aMetacelloProjectSpec repositories ]! ! !MetacelloGenericProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! projectPackage: aBlock constructor: aVersionConstructor aVersionConstructor projectPackageForProject: aBlock! ! !MetacelloGenericProjectSpec methodsFor: 'querying' stamp: 'dkh 6/30/2012 12:32'! repository | specs | self deprecated: 'Use repositories or repositorySpecs'. (specs := self repositorySpecs) isEmpty ifTrue: [ ^ nil ]. ^ specs first! ! !MetacelloGenericProjectSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeSpec: anotherSpec | newSpec map anotherRepositories | newSpec := super mergeSpec: anotherSpec. map := anotherSpec mergeMap. (anotherRepositories := map at: #'repositories') ~~ nil ifTrue: [ newSpec repositories: (self getRepositories == nil ifTrue: [ anotherRepositories ] ifFalse: [ self repositories mergeSpec: anotherRepositories ]) ]. ^ newSpec! ! !MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! getRepositories "raw access to iv" ^ repositories! ! !MetacelloGenericProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/5/2012 19:01:24'! metacelloRegistrationHash "projectPackage (ignored) repositories" ^ super metacelloRegistrationHash bitXor: self repositories metacelloRegistrationHash! ! !MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! repositories repositories ifNil: [ repositories := self project repositoriesSpec ]. ^ repositories! ! !MetacelloGenericProjectSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeMap | map | map := super mergeMap. map at: #'repositories' put: repositories. ^ map! ! !MetacelloGenericProjectSpec methodsFor: 'loading' stamp: 'dkh 6/5/2012 19:01:24'! load (MetacelloLookupProjectSpecForLoad new projectSpec: self; yourself) signal performLoad! ! !MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: 'dkh 7/19/2012 16:02'! projectPackage: aProjectPackage self shouldBeMutable. projectPackage := aProjectPackage! ! !MetacelloGenericProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! repository: aString username: username password: password constructor: aVersionConstructor aVersionConstructor repositoryForProject: aString username: username password: password! ! !MetacelloGenericProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! repository: anObject constructor: aVersionConstructor aVersionConstructor repositoryForProject: anObject! ! !MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! repository: aString username: username password: password self repositories repository: aString username: username password: password. self projectPackage: nil! ! !MetacelloGenericProjectSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! nonOverridable ^ super nonOverridable , #(#'projectPackage' #'repositories')! ! !MetacelloGenericProjectSpec methodsFor: 'testing' stamp: 'dkh 6/30/2012 13:18'! hasRepository ^ self repositorySpecs notEmpty! ! !MetacelloGenericProjectSpec methodsFor: 'querying' stamp: 'dkh 6/30/2012 14:19'! repositoryDescriptions ^ self repositorySpecs collect: [ :repoSpec | repoSpec description ]! ! !MetacelloGenericProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! repositorySpecs repositories ifNil: [ ^ #() ]. ^ self repositories map values! ! !MetacelloGenericProjectSpec methodsFor: 'loading' stamp: 'dkh 6/5/2012 19:01:24'! loadVersion: aVersionOrNil self subclassResponsibility! ! !MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: 'dkh 7/19/2012 16:02'! repositories: anObject self shouldBeMutable. repositories := anObject. self projectPackage: nil! ! !MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectPackage self subclassResponsibility! ! !MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! name: aString super name: aString. self projectPackage: nil! ! !MetacelloGenericProjectSpec methodsFor: 'copying' stamp: 'dkh 6/5/2012 19:01:24'! postCopy super postCopy. repositories := repositories copy. projectPackage := nil! ! !MetacelloGenericProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! repositories: aBlock constructor: aVersionConstructor aVersionConstructor repositoriesForProject: aBlock! ! !MetacelloGenericProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! repository: aStringOrMetacelloRepositorySpec self repositories repository: aStringOrMetacelloRepositorySpec. self projectPackage: nil! ! !MetacelloGenericProjectSpec methodsFor: 'scripting' stamp: 'dkh 7/17/2012 07:04'! mergeScriptRepository: anotherSpec self repositories: anotherSpec repositories! ! !MetacelloGenericProjectSpec methodsFor: 'loading' stamp: 'dkh 6/5/2012 19:01:24'! determineCurrentVersionForLoad self subclassResponsibility! ! !MetacelloGofer methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! basicReferencesIn: aRepository ((aRepository isKindOf: MCDictionaryRepository) or: [aRepository isKindOf: MCDirectoryRepository]) ifTrue: [ "No need to cache references for a dictionary repository" ^ super basicReferencesIn: aRepository ]. "Use cache for network-based repositories - the contents of repository is cached based on first access and is _not_ updated afterword, so any mcz files added after the initial cache is created won't be seen" ^ MetacelloPlatform current stackCacheFor: #goferRepository cacheClass: IdentityDictionary at: aRepository doing: [ :cache | ^ cache at: aRepository put: (super basicReferencesIn: aRepository) ]! ! !MetacelloGofer methodsFor: 'operations' stamp: 'dkh 6/8/2012 14:04:22'! interactiveCommit ^ self execute: MetacelloGoferCommit! ! !MetacelloGoferCommit methodsFor: 'running' stamp: 'ChristopheDemarey 9/11/2013 13:21'! execute: aWorkingCopy | version | version := MetacelloPlatform current newVersionForWorkingCopy: aWorkingCopy. self gofer repositories do: [ :repository | repository storeVersion: version ]! ! !MetacelloGoferLoad methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! updateRepositories "Noop for Metacello...done by loader itself" ! ! !MetacelloGoferLoad methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! updateCategories MetacelloPlatform current bypassGoferLoadUpdateCategories ifFalse: [ super updateCategories ]! ! !MetacelloGoferPackage methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! findWorkingCopy "Answer a working copy, or nil if the package is not loaded." | wcs | wcs := MCWorkingCopy allManagers select: [ :each | self matchesWorkingCopy: each ]. wcs isEmpty ifTrue: [ ^nil ]. ^wcs detectMax: [:ea | ea package name size ]! ! !MetacelloGoferPackage methodsFor: 'initialization' stamp: 'dkh 6/8/2012 14:04:22'! initializeName: aString packageFilename: packagefilename name := aString. packageFilename := packagefilename! ! !MetacelloGoferPackage methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! packageFilename ^packageFilename! ! !MetacelloGoferPackage methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! matchesWorkingCopy: aWorkingCopy "check that the working copy package name matches the package file name and that the first ancestor's package file name matches the packageName" | pFilename | (pFilename := self packageFilename) == nil ifTrue: [ ^self error: 'cannot match working copy' ]. (self class packageFileName: pFilename matchesPackageName: aWorkingCopy package name) ifTrue: [ aWorkingCopy ancestry ancestors isEmpty ifTrue: [ ^true ]. ^self class packageFileName: aWorkingCopy ancestry ancestors first name matchesPackageName: self packageName ]. ^false ! ! !MetacelloGoferPackage methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! workingCopy workingCopy == nil ifTrue: [ workingCopy := self findWorkingCopy ]. ^workingCopy! ! !MetacelloGoferPackage methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! currentVersionInfo | wc | (wc := self workingCopy) ~~ nil ifTrue: [ wc ancestry ancestors isEmpty not ifTrue: [ ^wc ancestry ancestors first ]]. ^nil! ! !MetacelloGoferPackage methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! ancestors | wc | (wc := self workingCopy) ~~ nil ifTrue: [ wc ancestry ancestors isEmpty not ifTrue: [ ^wc ancestry ancestors ]]. ^nil! ! !MetacelloGoferPackage methodsFor: 'private' stamp: 'dkh 6/30/2012 07:54'! matches: aLoadableReference "does Monticello-style #versionInfoFromVersionNamed: matching" | pFilename refFilename char | ((pFilename := self packageFilename) == nil or: [ self name = self packageFilename ]) ifTrue: [ ^ super matches: aLoadableReference ]. aLoadableReference name = pFilename ifTrue: [ ^ true ]. (aLoadableReference name beginsWith: pFilename) ifFalse: [ ^ false ]. refFilename := aLoadableReference metacelloPackageNameWithBranch at: 2. refFilename = pFilename ifTrue: [ ^ true ]. pFilename size < refFilename size ifTrue: [ (refFilename beginsWith: pFilename) ifFalse: [ ^ false ]. (char := pFilename at: pFilename size) ~= $- ifTrue: [ char := refFilename at: pFilename size + 1 ] ] ifFalse: [ (pFilename beginsWith: refFilename) ifFalse: [ ^ false ]. (char := refFilename at: refFilename size) ~= $- ifTrue: [ char := pFilename at: refFilename size + 1 ] ]. ^ char = $. or: [ char = $- ]! ! !MetacelloGoferPackage class methodsFor: 'package name matching' stamp: 'dkh 6/8/2012 14:04:22'! packageFileName: pkgFileName matchesPackageName: wcPkgName ^(pkgFileName beginsWith: wcPkgName) ifTrue: [ (pkgFileName size = wcPkgName size) or: [ ((pkgFileName at: wcPkgName size + 1) = $-) or: [ ((pkgFileName at: wcPkgName size + 1) = $.) or: [ (pkgFileName at: wcPkgName size + 1) isDigit ]]]] ifFalse: [ pkgFileName size >= wcPkgName size ifTrue: [ ^false ]. (wcPkgName beginsWith: pkgFileName) ifFalse: [ ^false ]. ^(wcPkgName at: pkgFileName size + 1) = $. ] ! ! !MetacelloGoferPackage class methodsFor: 'instance creation' stamp: 'dkh 6/8/2012 14:04:22'! name: aString packageFilename: packageFilename ^ self basicNew initializeName: aString packageFilename: packageFilename! ! !MetacelloGroupSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolveToLoadableSpec ^nil! ! !MetacelloGroupSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodCascadeOn: aStream member: aMember last: lastCascade indent: indent aMember methodUpdateSelector == #remove: ifTrue: [ aStream nextPutAll: 'removeGroup: ', self name printString. ] ifFalse: [ aStream nextPutAll: 'group: ', self name printString; space; nextPutAll: aMember methodUpdateSelector asString, ' #('. self includes do: [:str | aStream nextPutAll: str printString, ' ' ]. aStream nextPut: $) ]. lastCascade ifTrue: [ aStream nextPut: $. ] ifFalse: [ aStream nextPut: $;; cr ]. ! ! !MetacelloGroupSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! requires: aCollection self shouldNotImplement! ! !MetacelloGroupSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolveToPackagesIn: aVersionSpec visited: visited | packages | packages := Dictionary new. self resolveToPackagesIn: aVersionSpec into: packages visited: visited. ^packages values asOrderedCollection ! ! !MetacelloGroupSpec methodsFor: 'visiting' stamp: 'dkh 6/5/2012 19:01:24'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock groupBlock value: self! ! !MetacelloGroupSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: aLoader gofer: gofer "noop"! ! !MetacelloGroupSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! answers: aListOfPairs self shouldNotImplement! ! !MetacelloGroupSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodOn: aStream indent: indent aStream tab: indent; nextPutAll: 'spec '; cr; tab: indent + 1; nextPutAll: 'name: ', self name printString, ';'. self configMethodBodyOn: aStream hasName: true cascading: false indent: indent + 1. aStream nextPut: $. ! ! !MetacelloGroupSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolveToPackagesIn: aVersionSpec into: packages visited: visited visited visit: self doing: [:aSpec | | map | map := aVersionSpec packages map. aSpec includes do: [:pkgName | (aVersionSpec packageNamed: pkgName forMap: map ifAbsent: []) projectDo: [:ignored | ] packageDo: [:pkg | packages at: pkg name put: pkg ] groupDo: [:grp | grp resolveToPackagesIn: aVersionSpec into: packages visited: visited ]]]! ! !MetacelloGroupSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testGroupSpec | group | group := self groupSpec name: 'Platform'; includes: 'Core'; yourself. self assert: group name = 'Platform'. self assert: (group includes includes: 'Core'). group := self groupSpec name: 'Platform'; includes: #('Core'); yourself. self assert: group name = 'Platform'. self assert: (group includes includes: 'Core'). self should: [ group requires: #() ] raise: Error. self should: [ group answers: #() ] raise: Error. group projectDo: [ :ignored | self assert: false ] packageDo: [ :ignored | self assert: false ] groupDo: [ :grp | self assert: group == grp ]! ! !MetacelloGroupSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testGroupMergeSpec | groupA groupB group | groupA := self groupSpec name: 'Platform'; includes: 'Core'; yourself. groupB := self groupSpec name: 'Platform'; includes: 'Tests'; yourself. group := groupA mergeSpec: groupB. self assert: (group includes includes: 'Core'). self assert: (group includes includes: 'Tests')! ! !MetacelloIssue108Resource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpMonticelloRepository "This method builds a fake repository with the version references from #buildReferences." monticelloRepository := MCDictionaryRepository new. versionReferences do: [ :reference | monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)) with: (MCClassDefinition name: (reference packageName copyWithout: $-) asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: ''))) dependencies: #()) ]! ! !MetacelloIssue108Resource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpVersionReferences "self reset" versionReferences := OrderedCollection new. versionReferences add: (GoferVersionReference name: 'GoferBar.gemstone-dkh.68'); add: (GoferVersionReference name: 'GoferBar.gemstone-dkh.69'); add: (GoferVersionReference name: 'GoferBar.gemstone-dkh.70'); add: (GoferVersionReference name: 'GoferBar-dkh.68'); add: (GoferVersionReference name: 'GoferBar-dkh.69'); add: (GoferVersionReference name: 'GoferBar-dkh.70'); yourself ! ! !MetacelloIssue108Resource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! versionReferences ^ versionReferences! ! !MetacelloIssue108Resource methodsFor: 'running' stamp: 'dkh 05/09/2013 12:02'! setUp "https://code.google.com/p/metacello/issues/detail?id=108" super setUp. self setUpVersionReferences; setUpMonticelloRepository! ! !MetacelloIssue108Resource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! monticelloRepository ^ monticelloRepository! ! !MetacelloLinearLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! title ^'linear load'! ! !MetacelloLinearLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: aLoaderDirective gofer: aGofer self loadDirectives isEmpty ifTrue: [ ^self ]. aLoaderDirective loadLinearLoadDirective: self gofer: aGofer. ! ! !MetacelloLoadData methodsFor: 'versionInfo' stamp: 'dkh 6/8/2012 14:04:22'! ancestorsFor: packageSpec ifAbsent: aBlock ^self versionInfoMap at: packageSpec file ifAbsent: [ self packageNameMap at: packageSpec name ifAbsent: aBlock ]! ! !MetacelloLoadData methodsFor: 'versionInfo' stamp: 'dkh 6/8/2012 14:04:22'! currentVersionInfoFor: packageSpec ifAbsent: aBlock ^self versionInfoMap at: packageSpec file ifAbsent: [ self packageNameMap at: packageSpec name ifAbsent: aBlock ]! ! !MetacelloLoadData methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! do: aBlock self dataMap valuesDo: [:ar | aBlock value: (ar at: 1) value: (ar at: 2) value: (ar at: 3) ]! ! !MetacelloLoadData methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! dataMap dataMap == nil ifTrue: [ dataMap := Dictionary new ]. ^dataMap! ! !MetacelloLoadData methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isEmpty ^self dataMap isEmpty! ! !MetacelloLoadData methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! packageNameMap packageNameMap == nil ifTrue: [ packageNameMap := Dictionary new ]. ^packageNameMap! ! !MetacelloLoadData methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! addVersion: version versionInfo: versionInfo resolvedReference: resolvedReference packageSpec: packageSpec | vis | "check for duplicates and use the one that is being added" (vis := self packageNameMap at: packageSpec name ifAbsent: [ ]) ~~ nil ifTrue: [ "remove old references" vis do: [ :vi | self dataMap removeKey: vi name. self versionInfoMap removeKey: vi name ] ]. self dataMap at: version info name put: {version. resolvedReference. packageSpec}. self versionInfoMap at: versionInfo name put: {versionInfo}. self packageNameMap at: packageSpec name put: {versionInfo}! ! !MetacelloLoadData methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! versionInfoMap versionInfoMap == nil ifTrue: [ versionInfoMap := Dictionary new ]. ^versionInfoMap! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! cacheRepository: anMCRepository cacheRepository := anMCRepository. "getting a new repository, so wipe out the cacheGofer and ensureMap" ensuredMap := cacheGofer := nil! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! ignoreImage ^ ignoreImage! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repositoryMap: anObject repositoryMap := anObject! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! ensuredMap: anObject ensuredMap := anObject! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! silently: anObject silently := anObject! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadData loadData == nil ifTrue: [ loadData := MetacelloLoadData new ]. ^loadData ! ! !MetacelloLoaderPolicy methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! pushLinearLoadDirectivesDuring: aBlock for: aLoader self pushLoadDirective: (MetacelloLinearLoadDirective loader: aLoader) during: aBlock. ! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! cacheGofer cacheGofer == nil ifTrue: [ "don't use a caching Gofer here, since we expect the contents to change during a fetch operation" cacheGofer := Gofer new. cacheGofer disablePackageCache. cacheGofer repository: self cacheRepository. ]. ^ cacheGofer! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! cacheRepository cacheRepository == nil ifTrue: [ cacheRepository := MCDictionaryRepository new ]. ^ cacheRepository! ! !MetacelloLoaderPolicy methodsFor: 'initialize-release' stamp: 'dkh 6/8/2012 14:04:22'! initialize self repositoryMap; cacheRepository; ensuredMap. ignoreImage := false ! ! !MetacelloLoaderPolicy methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! hasRepositoryOverrides ^self overrideRepositories ~~ nil! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! ignoreImage: anObject ignoreImage := anObject! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! ensuredMap ensuredMap == nil ifTrue: [ ensuredMap := Dictionary new ]. ^ensuredMap! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! silently silently == nil ifTrue: [ silently := false ]. ^ silently! ! !MetacelloLoaderPolicy methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! load overrideRepositories := Array with: self cacheRepository. "ensure that hasRepositoryOverrides is true" self loadDirective loadWithPolicy: self! ! !MetacelloLoaderPolicy methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! pushExplicitLoadDirectivesDuring: aBlock for: aLoader | directive | directive := MetacelloExplicitLoadDirective loader: aLoader. self pushLoadDirective: directive during: aBlock. ^directive! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadDirective loadDirective == nil ifTrue: [ loadDirective := MetacelloLinearLoadDirective new ]. ^ loadDirective! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! overrideRepositories ^ overrideRepositories! ! !MetacelloLoaderPolicy methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! pushLoadDirective: aLoaderDirective during: aBlock | oldRoot | self loadDirective add: aLoaderDirective. oldRoot := loadDirective. loadDirective := aLoaderDirective. aBlock ensure: [ loadDirective := oldRoot ]. ! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repositoryMap repositoryMap == nil ifTrue: [ repositoryMap := Dictionary new ]. ^repositoryMap! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! resetCacheGofer cacheGofer := nil! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! overrideRepositories: anObject overrideRepositories := anObject! ! !MetacelloLoaderPolicy methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! pushAtomicLoadDirectivesDuring: aBlock for: aLoader self pushLoadDirective: (MetacelloAtomicLoadDirective loader: aLoader) during: aBlock. ! ! !MetacelloLoaderPolicy class methodsFor: 'instance creation' stamp: 'dkh 6/8/2012 14:04:22'! overrideRepositories: aCollection ^self new overrideRepositories: aCollection ! ! !MetacelloLoadingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! fetchingSpecLoader ^(MetacelloFetchingMCSpecLoader on: self spec) shouldDisablePackageCache: self shouldDisablePackageCache; loaderPolicy: self loaderPolicy copy; yourself! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! repositoryFor: pkgSpec with: gofer ^([self resolveSpec: pkgSpec with: gofer] on: Error do: [:ignored | ^nil ]) repository! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! goferCommitPackageUsing: repositorySpecs commitMessage: commitMessage | gofer repoSpecs wc | repoSpecs := self spec repositorySpecs notEmpty ifTrue: [ self spec repositorySpecs ] ifFalse: [ repositorySpecs ]. gofer := MetacelloGofer new. gofer disablePackageCache. wc := self spec workingCopy. repositorySpecs do: [:repoSpec | | repo | repo := repoSpec createRepository. (wc possiblyNewerVersionsIn: repo) notEmpty ifTrue: [ self notify: 'There are possibly newer versions of the package ', self spec name printString, ' in the repository ', repo description printString, '. Cancel and manually merge if you want to pick up the changes from the later version.' ]. gofer repository: repo ]. gofer package: self spec name. gofer commit: commitMessage. ^true! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! resolveSpec: pkgSpec from: repositorySpecs | gofer | gofer := MetacelloGofer new. gofer disablePackageCache. (self repositoriesFrom: repositorySpecs ignoreOverrides: true) do: [:repo | gofer repository: repo ]. ^self resolveSpec: pkgSpec with: gofer! ! !MetacelloLoadingMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! doLoad "NOOP"! ! !MetacelloLoadingMCSpecLoader methodsFor: 'packages' stamp: 'dkh 6/8/2012 14:04:22'! latestPackage: aString fromRepository: repositorySpecs | gofer | gofer := MetacelloGofer new. gofer disablePackageCache. (self repositoriesFrom: repositorySpecs) do: [:repo | gofer repository: repo ]. ^([(GoferPackageReference name: aString) resolveWith: gofer] on: Error do: [:ignored | ^ nil ]) name ! ! !MetacelloLoadingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! actionLabel ^'Loading '! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! goferCommitBranchPackage: branchName using: repositorySpecs commitMessage: commitMessage | gofer repoSpecs wc | repoSpecs := self spec repositorySpecs notEmpty ifTrue: [ self spec repositorySpecs ] ifFalse: [ repositorySpecs ]. gofer := MetacelloGofer new. gofer disablePackageCache. wc := self spec workingCopy. repositorySpecs do: [ :repoSpec | | repo | repo := repoSpec createRepository. (wc possiblyNewerVersionsIn: repo) notEmpty ifTrue: [ self notify: 'There are possibly newer versions of the package ' , self spec name printString , ' in the repository ' , repo description printString , '. Cancel and manually merge if you want to pick up the changes from the later version.' ]. gofer repository: repo ]. gofer package: self spec name. [ gofer interactiveCommit ] on: MCVersionNameAndMessageRequest do: [ :ex | | ref | ref := GoferVersionReference name: ex suggestedName. ex resume: {(ref packageName , '.' , branchName , '-' , ref author , '.' , ref versionNumber printString). commitMessage} ]. ^ true! ! !MetacelloLoadingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! linearLoadPackageSpec: packageSpec gofer: gofer MetacelloPlatform current do: [ | loadBlock goferLoad answers resolvedReference repo | resolvedReference := self resolvePackageSpec: packageSpec gofer: gofer. resolvedReference isNil ifTrue: [ "Package version already loaded into image" ^self ]. loadBlock := [ self preLoad: packageSpec. goferLoad := MetacelloGoferLoad on: MetacelloGofer new. goferLoad addResolved: resolvedReference. goferLoad execute. MetacelloPlatform current clearCurrentVersionCache. self postLoad: packageSpec ]. (answers := packageSpec answers) notEmpty ifTrue: [ loadBlock valueSupplyingMetacelloAnswers: answers ] ifFalse: [ loadBlock value]. repo := resolvedReference repository. self hasRepositoryOverrides ifTrue: [ repo := self loaderPolicy repositoryMap at: resolvedReference name ifAbsent: [ resolvedReference repository ]. resolvedReference workingCopy repositoryGroup addRepository: repo ] ifFalse: [ resolvedReference workingCopy repositoryGroup addRepository: resolvedReference repository ]. Transcript cr; show: 'Loaded -> ', resolvedReference name, ' --- ', repo description, ' --- ', resolvedReference repository description ] displaying: 'Loading ', packageSpec file! ! !MetacelloLoadingMCSpecLoader methodsFor: 'doits' stamp: 'dkh 6/8/2012 14:04:22'! preLoad: packageOrVersionSpec | block | (block := packageOrVersionSpec preLoadDoItBlock) ~~ nil ifTrue: [ block valueWithPossibleArgs: { self. packageOrVersionSpec. } ]! ! !MetacelloLoadingMCSpecLoader methodsFor: 'doits' stamp: 'dkh 6/8/2012 14:04:22'! postLoad: packageOrVersionSpec | block | (block := packageOrVersionSpec postLoadDoItBlock) ~~ nil ifTrue: [ block valueWithPossibleArgs: { self. packageOrVersionSpec. } ]! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! packagesNeedSavingUsing: repositorySpecs into: aCollection | wc repoSpecs repo | (wc := self spec workingCopy) == nil ifTrue: [ ^self ]. (wc ancestry ancestors notEmpty and: [ wc modified not]) ifTrue: [ ^self ]. repoSpecs := self spec repositorySpecs notEmpty ifTrue: [ self spec repositorySpecs ] ifFalse: [ repositorySpecs ]. repo := (self spec getFile == nil or: [ wc ancestry ancestors isEmpty ]) ifTrue: [ (self repositoriesFrom: repoSpecs ignoreOverrides: true) first ] ifFalse: [ ([ self resolveSpec: self spec from: repoSpecs ] on: Error do: [:ignored | ^self ]) repository ]. aCollection add: self spec -> repo! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'ChristopheDemarey 9/11/2013 13:21'! savePackageUsing: repositorySpecs | wc repo repoSpecs newVersion | (wc := self spec workingCopy) == nil ifTrue: [ ^false ]. (wc ancestry ancestors notEmpty and: [ wc modified not]) ifTrue: [ ^false ]. repoSpecs := self spec repositorySpecs notEmpty ifTrue: [ self spec repositorySpecs ] ifFalse: [ repositorySpecs ]. (self spec getFile == nil or: [ wc ancestry ancestors isEmpty ]) ifTrue: [ repo := (self repositoriesFrom: repoSpecs ignoreOverrides: true) first ] ifFalse: [ [ | newer | repo := (self resolveSpec: self spec from: repoSpecs) repository. newer := wc possiblyNewerVersionsIn: repo. newer isEmpty not ifTrue: [ (MetacelloPlatform current confirm: 'CAUTION!! These versions in the repository may be newer:', String cr, newer printString, String cr, 'Do you really want to save this version?') ifFalse: [ ^false ]] ] on: Error do: [:ignored | ^false ] ]. (newVersion := MetacelloPlatform current newVersionForWorkingCopy: wc) == nil ifTrue: [ ^false ]. repo storeVersion: newVersion. ^true! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! repositoryFor: pkgSpec from: repositorySpecs ^([self resolveSpec: pkgSpec from: repositorySpecs] on: Error do: [:ignored | ^nil ]) repository! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! copySpec: pkgSpec from: repositorySpecs to: repository | gofer | gofer := MetacelloGofer new. (self repositoriesFrom: repositorySpecs) do: [:repo | gofer repository: repo ]. ^self copySpec: pkgSpec with: gofer to: repository! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! copySpec: pkgSpec with: gofer to: aRepository | repository resolvedReference | [resolvedReference := pkgSpec goferLoaderReference resolveWith: gofer] on: Error do: [:ignored | ^nil ]. repository := MCRepositoryGroup default repositories detect: [ :each | each = aRepository ] ifNone: [ aRepository ]. repository storeVersion: resolvedReference version. ^resolvedReference repository! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! resolveSpec: pkgSpec with: gofer ^pkgSpec goferLoaderReference resolveWith: gofer! ! !MetacelloLookupBaselineSpecForEnsureLoad methodsFor: 'handlers' stamp: 'dkh 7/27/2012 00:30'! handleResolutionFor: aScriptEngine ^ aScriptEngine handleLookupBaselineSpecForEnsureLoad: self! ! !MetacelloLookupBaselineSpecForEnsureLoad methodsFor: 'exception description' stamp: 'dkh 7/27/2012 00:36'! defaultAction "Answer if you want to ensure the load of the baseline ... default is to load the baseline" ^ true! ! !MetacelloLookupProjectSpec commentStamp: 'dkh 6/1/2012 10:02'! **MetacelloLookupProjectSpec** is signalled to allow a handler to substitute a different (equivalent) project spec for fetching or loading purposes! !MetacelloLookupProjectSpec methodsFor: 'handlers' stamp: 'dkh 6/7/2012 16:21'! handleResolutionFor: aScriptEngine ^ aScriptEngine handleLookupProjectSpec: self! ! !MetacelloLookupProjectSpecForLoad commentStamp: 'dkh 6/1/2012 10:55'! **MetacelloLookupProjectSpecForLoad** ends up returning an instance of **MetacelloProjectSpecForLoad**! !MetacelloLookupProjectSpecForLoad methodsFor: 'handlers' stamp: 'dkh 6/7/2012 16:23'! handleResolutionFor: aScriptEngine ^ aScriptEngine handleLookupProjectSpecForLoad: self! ! !MetacelloLookupProjectSpecForLoad methodsFor: 'exception description' stamp: 'dkh 6/5/2012 19:01:24'! defaultAction "Result of signal should be the MetacelloProjectSpecForLoad to be used to perform the load. Create a MetacelloProjectSpecForLoad and use the overrideProjectSpec: if you want to supply a different projectSpec" ^ MetacelloProjectSpecForLoad new projectSpec: self projectSpec; yourself! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! determineCurrentVersionForLoad ^ self version! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asProjectRegistration ^ MetacelloProjectRegistration fromMCBaselineProjectSpec: self! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asProjectSpec ^ self copyForScriptingInto: (MetacelloMCProjectSpec for: self project asConfigurationProject)! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! canDowngradeTo: aProjectSpec "cannot upgrade between baselines" ^ false! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! versionString: anObject constructor: aVersionConstructor self error: 'versionString: not allowed in a baseline project spec'! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'loading' stamp: 'dkh 07/16/2013 15:06'! ensureConfigurationLoaded: vrsn ensured: ensured "answer true if the configuration should be reloaded" "see Issue #181 for details ... basically we always want to consider loading the baseline from a project reference, especially if the two project specs are not the same..." "https://github.com/dalehenrich/metacello-work/issues/181" ^ true! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'merging' stamp: 'dkh 6/8/2012 14:04:22'! mergeSpec: anotherSpec ^ super mergeSpec: anotherSpec asBaselineProjectSpec! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! projectLabel ^ 'baseline'! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! version self projectClass == nil ifTrue: [ ^ nil ]. ^ self projectClassProject version! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! constructClassName ^ 'BaselineOf' , self name! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! versionString ^ versionString ifNil: [ self version ifNotNil: [:v | v versionString] ]! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'mutability' stamp: 'dkh 7/19/2012 20:42'! copyForRegistration: aMetacelloProjectRegistration onWrite: aBlock | copy | aMetacelloProjectRegistration baselineProjectSpecIfPresent: [ :spec | copy := spec copy. aBlock value: copy. aMetacelloProjectRegistration baselineProjectSpec: copy ] ifAbsent: [ aMetacelloProjectRegistration configurationProjectSpecIfPresent: [ :spec | copy := spec copy. aBlock value: copy. aMetacelloProjectRegistration configurationProjectSpec: copy ] ifAbsent: [ aBlock value: nil ] ]! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'importing' stamp: 'dkh 6/26/2012 16:34'! mergeImportLoads: aLoadList aLoadList ifNotNil: [ :otherLoads | self loads ifNil: [ loads := otherLoads ] ifNotNil: [ loads := loads , otherLoads ] ]! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! version: anObject constructor: aVersionConstructor self error: 'version: not allowed in a baseline project spec'! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! canUpgradeTo: aProjectSpec "cannot upgrade between baselines" ^ false! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'private' stamp: 'dkh 07/28/2013 08:06'! hasConflictWithConfiguration: aConfigurationProjectSpec self name = aConfigurationProjectSpec name ifFalse: [ ^ true ]. self project configuration className = aConfigurationProjectSpec project configuration className ifFalse: [ ^ true ]. ^ ((self repositories isEmpty or: [ aConfigurationProjectSpec repositories isEmpty ]) or: [ self repositories hasNoLoadConflicts: aConfigurationProjectSpec repositories ]) not! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asBaselineProjectSpec ^ self! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! hasClassName ^ className ~~ nil and: [ className ~= self constructClassName ]! ! !MetacelloMCBaselineOfProjectSpec methodsFor: 'scripting' stamp: 'dkh 7/23/2012 14:29'! validateVersionString: issues withDefaultVersionString: ignored self versionString ifNotNil: [ :vs | | prj | prj := self project asBaselineProject. vs ~= prj singletonVersionName ifTrue: [ issues add: (MetacelloValidationError configurationClass: self projectClass reasonCode: #'invalidVersionString' callSite: #'validateForScriptLoad:withDefaultVersionString:withDefaultRepositoryDecription:' explanation: 'version field is incorrect, should be: ' , prj singletonVersionName printString) ] ]! ! !MetacelloMCBaselineProject commentStamp: 'dkh 5/5/2012 08:47'! The **MetacelloMCBaselineProject** is a wrapper for the **BaselineOf** version specification for file-based repositories. There is a single version in a **MetacelloMCBaselineProject**, named *'baseline'*. A typical **BaselineOf** is specification: ```Smalltalk baseline: spec spec package: 'External-Core'; package: 'External-Tests' with: [ spec requires: 'External-Core' ]; yourself. spec group: 'Core' with: #('External-Core'); group: 'default' with: #('Core'); group: 'Tests' with: #('External-Tests'); yourself ``` The `` pragma marks the method containing the baseline specification.! !MetacelloMCBaselineProject methodsFor: 'as yet unclassified' stamp: 'dkh 7/2/2012 16:42'! setBaselineRepositoryDescription: aListOrRepositoryDescriptions "set #version repositories to < aListOrRepositoryDescriptions>. Should be the directory where the BaselineOf is located." aListOrRepositoryDescriptions do: [:desc | self version spec repository: desc]! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 7/20/2012 12:12'! currentVersion ^ self version isSomethingLoaded ifTrue: [ self version ] ifFalse: [ nil ]! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! latestVersion ^ self version! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! lastVersion ^ self version! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! symbolicVersionSymbols ^ nil! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! version ^ self version: self singletonVersionName! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! development ^ nil! ! !MetacelloMCBaselineProject methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asBaselineProject ^ self! ! !MetacelloMCBaselineProject methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! projectForScriptEngine: aMetacelloScriptEngine unconditionalLoad: aBool ^ aMetacelloScriptEngine getBaselineProjectUnconditionalLoad: aBool! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/13/2012 13:51'! singletonVersionName ^ self class singletonVersionName! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! latestVersionMatching: versionPatternString excludedBlessings: excluded ^ nil! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 05/15/2013 21:02'! versions ^ [ {(self version)} ] on: MetacelloVersionDoesNotExistError do: [ :ex | ^ #() ]! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! currentVersionAgainst: resolvedPackageAndProjectNames ^ nil! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! latestVersionMatching: versionPatternString includedBlessings: included excludedBlessings: excludedBlessings ^ nil! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! bleedingEdge ^ nil! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! latestVersionMatching: versionPatternString includedBlessings: included ^ nil! ! !MetacelloMCBaselineProject methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asConfigurationProject ^ MetacelloMCProject new! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! stableVersion ^ nil! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! hasVersion: versionString ^ versionString = 'baseline'! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! latestVersionMatching: versionPatternString ^ nil! ! !MetacelloMCBaselineProject methodsFor: 'versions' stamp: 'dkh 6/8/2012 14:04:22'! latestVersion: blessing ^ nil! ! !MetacelloMCBaselineProject class methodsFor: 'accessing' stamp: 'dkh 6/13/2012 13:51'! singletonVersionName ^ 'baseline'! ! !MetacelloMCBaselineProject class methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! versionConstructorClass ^ MetacelloBaselineConstructor! ! !MetacelloMCConfigurationOfProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asProjectRegistration ^ MetacelloProjectRegistration fromMCConfigurationProjectSpec: self! ! !MetacelloMCConfigurationOfProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asProjectSpec ^ self copyForScriptingInto: (MetacelloMCProjectSpec for: self project asConfigurationProject)! ! !MetacelloMCConfigurationOfProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asConfigurationProjectSpec ^ self! ! !MetacelloMCConfigurationOfProjectSpec methodsFor: 'mutability' stamp: 'dkh 7/19/2012 20:42'! copyForRegistration: aMetacelloProjectRegistration onWrite: aBlock | copy | aMetacelloProjectRegistration configurationProjectSpecIfPresent: [ :spec | copy := spec copy. aBlock value: copy. aMetacelloProjectRegistration configurationProjectSpec: copy ] ifAbsent: [ aMetacelloProjectRegistration baselineProjectSpecIfPresent: [ :spec | copy := spec copy. aBlock value: copy. aMetacelloProjectRegistration baselineProjectSpec: copy ] ifAbsent: [ aBlock value: nil ] ]! ! !MetacelloMCConfigurationOfProjectSpec methodsFor: 'merging' stamp: 'dkh 6/8/2012 14:04:22'! mergeSpec: anotherSpec ^ super mergeSpec: anotherSpec asConfigurationProjectSpec! ! !MetacelloMCConfigurationOfProjectSpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! projectLabel ^ 'configuration'! ! !MetacelloMCConfigurationOfProjectSpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! hasClassName ^ className ~~ nil and: [ className ~= self constructClassName ]! ! !MetacelloMCConfigurationOfProjectSpec methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! constructClassName ^ 'ConfigurationOf' , self name! ! !MetacelloMCGroupSpecTestCase methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectClass ^ MetacelloMCProject! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testAddPackageD "used by MetacelloAbstractVersionConstructor>>package: and MetacelloAbstractVersionConstructor>>package:overrides:" | packages | packages := self packagesSpec. packages add: 'Platform'. packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testMergePackageA "used by MetacelloAbstractVersionConstructor>>package:with:" | packages package | packages := self packagesSpec. packages add: (self packageSpec name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). packages merge: (self packageSpec name: 'Package'; requires: 'AndAnotherPackage'; includes: 'AndIncludedPackage'; answers: #(#('xpostload' 'xpostload answer')); file: 'Package-dkh.2'; yourself). package := packages packageNamed: 'Package' ifAbsent: [ self assert: false ]. self assert: package name = 'Package'. self assert: package requires = #('AnotherPackage' 'AndAnotherPackage'). self assert: package includes = #('IncludedPackage' 'AndIncludedPackage'). self assert: package answers = #(#('preload' 'preload answer') #('postload' 'postload answer') #('xpostload' 'xpostload answer')). self assert: package file = 'Package-dkh.2'. self assert: package preLoadDoIt value == #'preLoadDoIt'. self assert: package postLoadDoIt value == #'postLoadDoIt'! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testRemovePackageA "used by MetacelloAbstractVersionConstructor>>removePackage:" | packages removed | packages := self packagesSpec. packages add: (self packageSpec name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). packages remove: (self packageSpec name: 'Package'; yourself). removed := false. packages packageNamed: 'Package' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testMergePackageD "used by MetacelloAbstractVersionConstructor>>package:with:" | packages | packages := self packagesSpec. packages add: 'Platform'; merge: 'Tests'. packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. packages packageNamed: 'Tests' ifAbsent: [ self assert: false ]! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testAddPackageC "used by MetacelloAbstractVersionConstructor>>package: and MetacelloAbstractVersionConstructor>>package:overrides:" | packages | packages := self packagesSpec. packages add: {'Platform'. 'Base'. 'Tests'}. packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. packages packageNamed: 'Base' ifAbsent: [ self assert: false ]. packages packageNamed: 'Tests' ifAbsent: [ self assert: false ]! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testAddPackageA "used by MetacelloAbstractVersionConstructor>>package: and MetacelloAbstractVersionConstructor>>package:overrides:" | packages package | packages := self packagesSpec. packages add: (self packageSpec name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). packages add: (self packageSpec name: 'Package'; requires: 'AndAnotherPackage'; includes: 'AndIncludedPackage'; answers: #(#('postload' 'postload answer')); file: 'Package-dkh.2'; yourself). package := packages packageNamed: 'Package' ifAbsent: [ self assert: false ]. self assert: package name = 'Package'. self assert: package requires = #('AndAnotherPackage'). self assert: package includes = #('AndIncludedPackage'). self assert: package answers = #(#('postload' 'postload answer')). self assert: package file = 'Package-dkh.2'. self assert: package preLoadDoIt value == nil. self assert: package postLoadDoIt value == nil! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testCopyToPackage "not currently used by MetacelloAbstractVersionConstructor" | packages package | packages := self packagesSpec. packages add: (self packageSpec name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). packages copy: 'Package' to: (self packageSpec name: 'PackageCopy'; yourself). package := packages packageNamed: 'PackageCopy' ifAbsent: [ self assert: false ]. self assert: package name = 'PackageCopy'. self assert: package requires = #('AnotherPackage'). self assert: package includes = #('IncludedPackage'). self assert: package answers = #(#('preload' 'preload answer') #('postload' 'postload answer')). self assert: package file = 'Package-dkh.1'. self assert: package preLoadDoIt value == #'preLoadDoIt'. self assert: package postLoadDoIt value == #'postLoadDoIt'! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectClass ^ MetacelloMCProject! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testAddPackageB "used by MetacelloAbstractVersionConstructor>>package: and MetacelloAbstractVersionConstructor>>package:overrides:" | packages package | packages := self packagesSpec. packages add: {(self packageSpec name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). (self packageSpec name: 'Package'; requires: 'AndAnotherPackage'; includes: 'AndIncludedPackage'; answers: #(#('postload' 'postload answer')); file: 'Package-dkh.2'; yourself)}. package := packages packageNamed: 'Package' ifAbsent: [ self assert: false ]. self assert: package name = 'Package'. self assert: package requires = #('AndAnotherPackage'). self assert: package includes = #('AndIncludedPackage'). self assert: package answers = #(#('postload' 'postload answer')). self assert: package file = 'Package-dkh.2'. self assert: package preLoadDoIt value == nil. self assert: package postLoadDoIt value == nil! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testMergePackageB "used by MetacelloAbstractVersionConstructor>>package:with:" | packages package | packages := self packagesSpec. packages add: (self packageSpec name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). packages merge: {(self packageSpec name: 'Package'; requires: 'AndAnotherPackage'; includes: 'AndIncludedPackage'; answers: #(#('xpostload' 'xpostload answer')); file: 'Package-dkh.2'; yourself)}. package := packages packageNamed: 'Package' ifAbsent: [ self assert: false ]. self assert: package name = 'Package'. self assert: package requires = #('AnotherPackage' 'AndAnotherPackage'). self assert: package includes = #('IncludedPackage' 'AndIncludedPackage'). self assert: package answers = #(#('preload' 'preload answer') #('postload' 'postload answer') #('xpostload' 'xpostload answer')). self assert: package file = 'Package-dkh.2'. self assert: package preLoadDoIt value == #'preLoadDoIt'. self assert: package postLoadDoIt value == #'postLoadDoIt'! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testRemovePackageC "used by MetacelloAbstractVersionConstructor>>removePackage:" | packages removed | packages := self packagesSpec. packages add: (self packageSpec name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). packages remove: {'Package'}. removed := false. packages packageNamed: 'Package' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testRemovePackageB "used by MetacelloAbstractVersionConstructor>>removePackage:" | packages removed | packages := self packagesSpec. packages add: (self packageSpec name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). packages remove: {(self packageSpec name: 'Package'; yourself)}. removed := false. packages packageNamed: 'Package' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloMCPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testRemovePackageD "used by MetacelloAbstractVersionConstructor>>removePackage:" | packages removed | packages := self packagesSpec. packages add: (self packageSpec name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). packages remove: 'Package'. removed := false. packages packageNamed: 'Package' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aLoadedPackageIsCurrent ^ aLoadedPackageIsCurrent! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aLoadedProjectIsCurrent: aBoolean aLoadedProjectIsCurrent := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isLoadedMatchConstraints: matchBlock "all loaded projects and packages match constraints (at least one package loaded)" | matchStatus | matchStatus := #loadedMatchConstraints. (self evaluateStatus: #(#allLoadedToSpec #loadedToSpec #loadedMatchConstraints)) ifTrue: [ aPackageIsLoaded & aProjectIsLoaded ifTrue: [ (aLoadedPackageIsExact | aLoadedPackageIsCurrent & aLoadedPackageIsNotCurrent not and: [ aLoadedProjectIsExact | aLoadedProjectIsCurrent & aLoadedProjectIsNotCurrent not ]) ifTrue: [ matchBlock value: matchStatus ] ] ifFalse: [ aPackageIsLoaded ifTrue: [ aLoadedPackageIsExact | aLoadedPackageIsCurrent & aLoadedPackageIsNotCurrent not ifTrue: [ matchBlock value: matchStatus ] ] ifFalse: [ hasNoPackage & (aLoadedProjectIsExact | aLoadedProjectIsCurrent) & aLoadedProjectIsNotCurrent not ifTrue: [ matchBlock value: matchStatus ] ] ] ]! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aProjectIsLoaded ^aProjectIsLoaded! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isAllLoadedToSpec: matchBlock "all projects and packages are loaded and match specification" (self evaluateStatus: #(#allLoadedToSpec)) ifTrue: [ ((hasNoPackage or: [ aPackageIsLoaded & aPackageNotLoaded not & aLoadedPackageIsExact & aLoadedPackageIsNotCurrent not & aLoadedPackageIsCurrent not ]) and: [ hasNoProject or: [ aProjectIsLoaded & aProjectNotLoaded not & aLoadedProjectIsExact & aLoadedProjectIsNotCurrent not & aLoadedProjectIsCurrent not ] ]) ifTrue: [ matchBlock value: #allLoadedToSpec ] ]! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aPackageNotLoaded: aBoolean aPackageNotLoaded := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! hasNoProject ^ hasNoProject! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! hasNoProject: aBoolean hasNoProject := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aPackageIsLoaded ^aPackageIsLoaded! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aLoadedPackageIsNotCurrent ^ aLoadedPackageIsNotCurrent! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! abort ^ abort! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aLoadedPackageIsExact: aBoolean aLoadedPackageIsExact := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! hasNoPackage: aBoolean hasNoPackage := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'initialization' stamp: 'dkh 6/8/2012 14:04:22'! initialize super initialize. hasNoPackage := hasNoProject := true. aProjectIsLoaded := aPackageIsLoaded := false. aLoadedProjectIsExact := aLoadedPackageIsExact := false. aLoadedProjectIsCurrent := aLoadedPackageIsCurrent := false. aLoadedProjectIsNotCurrent := aLoadedPackageIsNotCurrent := false. aProjectNotLoaded := aPackageNotLoaded := false. vrsnStatus := Set new. abort := false! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! hasNoPackage ^ hasNoPackage! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aPackageIsLoaded: aBoolean aPackageIsLoaded := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aLoadedProjectIsNotCurrent: aBoolean aLoadedProjectIsNotCurrent := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aPackageNotLoaded ^aPackageNotLoaded! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! vrsnStatus ^vrsnStatus! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aProjectIsLoaded: aBoolean aProjectIsLoaded := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aLoadedPackageIsNotCurrent: aBoolean aLoadedPackageIsNotCurrent := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aLoadedPackageIsExact ^ aLoadedPackageIsExact! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aProjectNotLoaded ^aProjectNotLoaded! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aLoadedProjectIsExact ^ aLoadedProjectIsExact! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'evaulation' stamp: 'dkh 6/8/2012 14:04:22'! evaluateStatus: validStatusList ^self abort ifTrue: [ false ] ifFalse: [ (self hasNoProject or: [ self vrsnStatus isEmpty ]) ifTrue: [ true ] ifFalse: [ | valid | valid := true. vrsnStatus do: [ :status | (validStatusList includes: status) ifFalse: [ valid := false ] ]. valid ] ]! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! abort: aBoolean abort := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aLoadedPackageIsCurrent: aBoolean aLoadedPackageIsCurrent := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isSomethingLoaded: somethingLoadedBlock "at least one package loaded" (self evaluateStatus: #(#allLoadedToSpec #loadedToSpec #loadedMatchConstraints #somethingLoaded)) ifTrue: [ aPackageIsLoaded ifTrue: [ somethingLoadedBlock value: #somethingLoaded ] ]! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isLoadedToSpec: matchBlock "all loaded projects and packages match specifications (at least one package loaded)" | matchStatus | matchStatus := #loadedToSpec. (self evaluateStatus: #(#allLoadedToSpec #loadedToSpec)) ifTrue: [ aPackageIsLoaded & aProjectIsLoaded ifTrue: [ (aLoadedPackageIsExact & aLoadedPackageIsCurrent not & aLoadedPackageIsNotCurrent not and: [ aLoadedProjectIsExact & aLoadedProjectIsCurrent not & aLoadedProjectIsNotCurrent not ]) ifTrue: [ matchBlock value: matchStatus ] ] ifFalse: [ aPackageIsLoaded ifTrue: [ aLoadedPackageIsExact & aLoadedPackageIsCurrent not & aLoadedPackageIsNotCurrent not ifTrue: [ matchBlock value: matchStatus ] ] ifFalse: [ hasNoPackage & aLoadedProjectIsExact & aLoadedProjectIsCurrent not & aLoadedProjectIsNotCurrent not ifTrue: [ matchBlock value: matchStatus ] ] ] ]! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aProjectNotLoaded: aBoolean aProjectNotLoaded := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aLoadedProjectIsExact: aBoolean aLoadedProjectIsExact := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! aLoadedProjectIsNotCurrent ^ aLoadedProjectIsNotCurrent! ! !MetacelloMCPartiallyLoadedStatus class methodsFor: 'instance creation' stamp: 'dkh 6/8/2012 14:04:22'! new ^ self basicNew initialize! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! packagesNeedSaving: aVersionString "Answer a collection of associations (package -> repository) representing the packages reachable from this project that need to be saved" | packages | packages := Set new. (self version: aVersionString) spec packagesNeedSavingVisited: (Set with: self configuration class name asString) into: packages. ^packages! ! !MetacelloMCProject methodsFor: 'repository creation' stamp: 'dkh 6/8/2012 14:04:22'! createRepository: aRepositorySpec ^ MetacelloPlatform current createRepository: aRepositorySpec! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/8/2012 14:04:22'! repositoriesSpecClass ^MetacelloRepositoriesSpec! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/8/2012 14:04:22'! defaultLoaderClass ^MetacelloLoadingMCSpecLoader! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/8/2012 14:04:22'! packageSpecClass ^MetacelloPackageSpec! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! fetchProject: aLoaderPolicy "fetch the latest version of the configuration package" | mcLoader | (mcLoader := self loader) == nil ifTrue: [ mcLoader := self project loaderClass on: nil ]. mcLoader loaderPolicy: aLoaderPolicy. mcLoader doingLoads: [ MCWorkingCopy managersForClass: self configuration class do: [:mgr | | pkg | pkg := self packageSpec. mgr repositoryGroup repositories do: [:repo | pkg repositories repository: (repo asRepositorySpecFor: self) ]. pkg name: mgr packageName. pkg fetchUsing: mcLoader. ^true ]]. ^true ! ! !MetacelloMCProject methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! projectForScriptEngine: aMetacelloScriptEngine unconditionalLoad: aBool ^ aMetacelloScriptEngine getConfigurationProjectUnconditionalLoad: aBool! ! !MetacelloMCProject methodsFor: 'repository updating' stamp: 'dkh 6/8/2012 14:04:22'! updatePackageRepositoriesFor: versionString | versionSpec | (versionSpec := (self version: versionString) versionSpec) packageSpecsInLoadOrder do: [:pkgSpec | pkgSpec updatePackageRepositoriesFor: versionSpec ]. ^true! ! !MetacelloMCProject methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! pragmaKeywords ^super pragmaKeywords, #(projectPackage:attribute: packages:attribute: repositories:attribute: )! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/8/2012 14:04:22'! projectSpecClass ^MetacelloMCProjectSpec! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! updateProject: aLoaderPolicy "load the latest version of the configuration package" "WARNING: don't forget to refresh your project instance after doing an #updateProject, otherwise your instance won't reflect the info in the freshly loaded configuration" | mcLoader | (mcLoader := self loader) == nil ifTrue: [ mcLoader := self project loaderClass on: nil ]. mcLoader loaderPolicy: aLoaderPolicy. mcLoader doingLoads: [ MCWorkingCopy managersForClass: self configuration class do: [ :mgr | | pkg ar | pkg := self packageSpec. mgr repositoryGroup repositories do: [ :repo | pkg repositories repository: (repo asRepositorySpecFor: self) ]. ar := mgr metacelloPackageNameWithBranch. pkg name: (ar at: 1). (ar at: 2) notEmpty ifTrue: [ pkg file: (ar at: 2) ]. pkg load. ^ true ] ]. ^ true! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/8/2012 14:04:22'! configurationOfProjectSpecClass ^ MetacelloMCConfigurationOfProjectSpec! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/8/2012 14:04:22'! repositorySpecClass ^MetacelloRepositorySpec! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! fetchProject "fetch the latest version of the configuration package" ^self fetchProject: MetacelloLoaderPolicy new! ! !MetacelloMCProject methodsFor: 'as yet unclassified' stamp: 'dkh 7/2/2012 16:41'! setBaselineRepositoryDescription: aListOrRepositoryDescriptions "noop " ! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/8/2012 14:04:22'! packageSpec ^self packageSpecClass for: self! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/8/2012 14:04:22'! repositoriesSpec ^self repositoriesSpecClass for: self! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! saveProject | pkgSpec | (pkgSpec := self projectPackage) == nil ifTrue: [ ^false ]. ^pkgSpec savePackage! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/8/2012 14:04:22'! versionSpecClass ^MetacelloMCVersionSpec! ! !MetacelloMCProject methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asBaselineProject ^ MetacelloMCBaselineProject new! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! projectPackage MCWorkingCopy managersForClass: self configuration class do: [:mgr | | pkgSpec repo | pkgSpec := self packageSpec name: mgr packageName; yourself. mgr ancestors notEmpty ifTrue: [ pkgSpec file: mgr ancestors first name ]. repo := mgr repositoryGroup repositories detect: [:each | each ~~ MCCacheRepository default ] ifNone: [ Transcript cr; show: 'Using cache repository for ', self label, ' project package'. MCCacheRepository default ]. pkgSpec repository: (repo asRepositorySpecFor: self). ^pkgSpec]. ^nil! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/8/2012 14:04:22'! baselineOfProjectSpecClass ^ MetacelloMCBaselineOfProjectSpec! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! goferCommitProject: commitMessage | pkgSpec | (pkgSpec := self projectPackage) == nil ifTrue: [ ^false ]. ^pkgSpec goferCommitPackage: commitMessage! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! updateProject "load the latest version of the configuration package" "WARNING: don't forget to refresh your project instance after doing an #updateProject, otherwise your instance won't reflect the info in the freshly loaded configuration" ^self updateProject: MetacelloLoaderPolicy new! ! !MetacelloMCProject methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asConfigurationProject ^ self! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! goferBranch: branchName project: commitMessage | pkgSpec | pkgSpec := self projectPackage. pkgSpec file: pkgSpec name , '.' , branchName. ^ pkgSpec goferBranchPackage: branchName message: commitMessage! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/8/2012 14:04:22'! repositorySpec ^self repositorySpecClass for: self! ! !MetacelloMCProjectReferenceSpecTestCase methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectClass ^ MetacelloMCProject! ! !MetacelloMCProjectSpec methodsFor: 'loading' stamp: 'dkh 07/29/2013 07:16'! ensureLoadedForDevelopmentUsing: mcLoader "for #development projects, always need latest version of package when contemplating a load" | ensured | ensured := mcLoader ensuredMap at: self name ifAbsent: [ nil ]. self projectClass ~~ nil ifTrue: [ | vrsn | vrsn := self versionOrNil. vrsn ~~ nil ifTrue: [ (self ensureConfigurationLoaded: vrsn ensured: ensured) ifTrue: [ mcLoader ensureForDevelopment ifTrue: [ | pc | (pc := self projectClass) ~~ nil ifTrue: [ MetacelloClearStackCacheNotification signal: #(#'currentVersion' #'currentVersionAgainst:' #'currentVersionInfo' #'versionConstructor' #'loadableSpecNames') , {pc} ]. self ensureLoadUsing: mcLoader ] ifFalse: [ self projectPackage fetchUsing: mcLoader ]. mcLoader ensuredMap at: self name put: #'latest' ]. ^ self ] ]. ensured == nil ifTrue: [ "projectClass == nil or version == nil" mcLoader ensureForDevelopment ifTrue: [ | pc | (pc := self projectClass) ~~ nil ifTrue: [ MetacelloClearStackCacheNotification signal: #(#'currentVersion' #'currentVersionAgainst:' #'currentVersionInfo' #'versionConstructor' #'loadableSpecNames') , {pc} ]. self ensureLoadUsing: mcLoader ] ifFalse: [ self fetchUsing: mcLoader ]. mcLoader ensuredMap at: self name put: #'present' ]! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'dkh 9/10/2012 16:05'! file file ifNil: [ ^ self className ]. ^ file! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asProjectRegistration (self className beginsWith: 'BaselineOf') ifTrue: [ ^ MetacelloProjectRegistration fromMCBaselineProjectSpec: self ]. ^ MetacelloProjectRegistration fromMCConfigurationProjectSpec: self! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asConfigurationProjectSpec ^ self copyForScriptingInto: (MetacelloMCConfigurationOfProjectSpec for: self project asConfigurationProject)! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! canDowngradeTo: aMetacelloProjectSpec ^ (super canDowngradeTo: aMetacelloProjectSpec) and: [ self file = aMetacelloProjectSpec file ]! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/15/2012 13:40'! compareEqual: aMetacelloProjectSpec "'projectPackage repositories'" ^ (super compareEqual: aMetacelloProjectSpec) and: [ self file = aMetacelloProjectSpec file ]! ! !MetacelloMCProjectSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! fetchUsing: aLoader (MetacelloLookupProjectSpec new projectSpec: self; yourself) signal projectPackage fetchUsing: aLoader! ! !MetacelloMCProjectSpec methodsFor: 'as yet unclassified' stamp: 'dkh 07/28/2013 09:45'! hasConflictWithBaseline: aBaselineProjectSpec "baseline may not trump a configuration" ^ false! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 04/02/2013 20:23'! hasNoLoadConflicts: aMetacelloProjectSpec "'projectPackage repositories'" ^ (super hasNoLoadConflicts: aMetacelloProjectSpec) and: [ self file = aMetacelloProjectSpec file ]! ! !MetacelloMCProjectSpec methodsFor: 'loading' stamp: 'dkh 7/7/2012 07:16'! determineCurrentVersionForLoad "don't use self currentVersion, because we are interested in the currentVersion of the project as loaded in image, not the current version relative to our load list" | prjct version currentVersion packageAndProjectNames cvs | self projectClass == nil ifTrue: [ ^ nil ]. (version := self versionOrNil) == nil ifTrue: [ ^ nil ]. version blessing == #'baseline' ifTrue: [ ^ version ]. self loader ignoreImage ifTrue: [ ^ version ]. prjct := self projectClass new project. prjct loader: self loader. (currentVersion := prjct currentVersion) == nil ifTrue: [ ^ nil ]. (cvs := currentVersion versionStatus) == #'somethingLoaded' ifTrue: [ ^ nil ]. (#(#'allLoadedToSpec' #'loadedToSpec' #'loadedMatchConstraints') includes: (cvs := currentVersion versionStatus)) ifTrue: [ (currentVersion perform: self operator with: version) ifTrue: [ "load currentVersion" ^ currentVersion ]. "load version" ^ nil ]. version = currentVersion ifTrue: [ ^ currentVersion ]. "I don't believe that it is possible to reach this point in the method, so I will be interested if I run across a case that produces this error" (MetacelloProjectSpecLoadConflict projectSpec: self) signal: 'Project load conflict for' , prjct label printString , ' between current version ' , currentVersion printString , '(' , cvs asString , ') and specified version ' , version printString , '. Press resume to continue with load anyway'. ^ nil! ! !MetacelloMCProjectSpec methodsFor: 'loading' stamp: 'dkh 07/16/2013 15:05'! ensureConfigurationLoaded: vrsn ensured: ensured "answer true if the configuration should be reloaded" vrsn blessing == #'development' ifTrue: [ ensured ~~ #'latest' ifTrue: [ ^ MetacelloScriptEnsureProjectLoadedForDevelopment signal ] ]. ^ false! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! metacelloRegistrationHash "file" ^ String stringHash: self file initialHash: super metacelloRegistrationHash! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 7/27/2012 04:59'! versionForScriptEngine: aMetacelloScriptEngine | prj | prj := self projectClass ifNil: [ self project ] ifNotNil: [ self projectClassProject ]. ^ ((prj projectForScriptEngine: aMetacelloScriptEngine) version: self versionString) silently: aMetacelloScriptEngine silently; ignoreImage: aMetacelloScriptEngine ignoreImage; cacheRepository: aMetacelloScriptEngine cacheRepository; repositoryOverrides: aMetacelloScriptEngine repositoryOverrides! ! !MetacelloMCProjectSpec methodsFor: 'mutability' stamp: 'dkh 7/19/2012 20:26'! copyForRegistration: aMetacelloProjectRegistration onWrite: aBlock self subclassResponsibility! ! !MetacelloMCProjectSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! updatePackageSpec: updatedSpecs "Add project copy to updatedSpecs if the current version of the project is different from the receiver's version" | prj currentVersion spec | className == nil ifTrue: [ ^ self ]. prj := self projectClassProject. (currentVersion := prj currentVersion) = self versionOrNil ifTrue: [ ^ self ]. currentVersion == nil ifTrue: [ ^ self ]. spec := self copy. spec versionString: currentVersion versionString. updatedSpecs at: spec name put: spec! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! projectClass self className == nil ifTrue: [ ^ nil ]. ^ Smalltalk at: self className asSymbol ifAbsent: [ ]! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! canUpgradeTo: aMetacelloProjectSpec ^ (super canUpgradeTo: aMetacelloProjectSpec) and: [ self file = aMetacelloProjectSpec file ]! ! !MetacelloMCProjectSpec methodsFor: 'testing' stamp: 'dkh 6/14/2012 15:53'! allPackagesLoaded: aLoader "answer true if all of the packages (excluding projects) are loaded" | vrsn pkgs | (vrsn := self versionOrNil) == nil ifTrue: [ ^ false ]. pkgs := OrderedCollection new. (self loadListForVersion: vrsn) do: [ :nm | vrsn packages do: [ :pkg | (pkg isPackageLoaded: aLoader) ifFalse: [ ^ false ] ] ]. ^ true! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asBaselineProjectSpec ^ self copyForScriptingInto: (MetacelloMCBaselineOfProjectSpec for: self project asBaselineProject)! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 7/19/2012 16:03'! file: aString self shouldBeMutable. file := aString. self projectPackage: nil! ! !MetacelloMCProjectSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! file: aString constructor: aVersionConstructor aVersionConstructor fileForProject: aString! ! !MetacelloMCProjectSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isPossibleBaseline | vrsn | (vrsn := self versionOrNil) == nil ifTrue: [ ^false ]. (vrsn allPackagesForSpecNamed: (self loadListForVersion: vrsn)) do: [:pkg | pkg workingCopy == nil ifTrue: [ ^false ]]. ^true! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! packageFileSpecFor: aMetacelloPackagesSpec ^(aMetacelloPackagesSpec project projectReferenceSpec) name: self name; projectReference: self copy; yourself. ! ! !MetacelloMCProjectSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! updateForSpawnMethod: sourceSpec "This means that this spec was used in a baseline and will be used in a version .... drop all information that isn't useful" repositories := className := operator := loads := projectPackage := nil. sourceSpec ~~ nil ifTrue: [ versionString := sourceSpec versionString ].! ! !MetacelloMCProjectSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isPartiallyLoaded: aLoader | vrsn | (vrsn := self versionOrNil) == nil ifTrue: [ ^false ]. (self loadListForVersion: vrsn) do: [:nm | (vrsn packagesForSpecNamed: nm ) do: [:pkg | (pkg isPackageLoaded: aLoader) ifTrue: [ ^true ]]]. ^false! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! asProjectSpec ^ self! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! getFile "raw access to iv" ^ file! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! relativeCurrentVersion "currentVersion calculated relative to the loadList" | vrsn expanded loadList | (vrsn := self versionOrNil) == nil ifTrue: [ ^ nil ]. expanded := [ vrsn expandToLoadableSpecNames: (loadList := self loadListForVersion: vrsn) ] on: Error do: [ :ex | vrsn blessing == #'development' ifTrue: [ self ensureLoadUsing: self loader. vrsn := self versionOrNil. ex return: (vrsn expandToLoadableSpecNames: loadList) ]. ex pass ]. ^ self projectClassProject currentVersionAgainst: expanded! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! version "Empty version string means use latestVersion or #bleedingEdge" self projectClass == nil ifTrue: [ ^ nil ]. ^ self versionString == nil ifTrue: [ | vrsn | "Eventually it will become an error to not specify a project reference version as default: #stable is the preferred default" "self deprecated: 'Must specify a project reference version.'." self flag: 'deprecate after version 1.0'. (vrsn := self projectClassProject latestVersion) == nil ifTrue: [ self projectClassProject version: #bleedingEdge ] ifFalse: [ vrsn ] ] ifFalse: [ self projectClassProject version: self versionString ]! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadedPackageNames: aLoader | vrsn pkgs | (vrsn := self versionOrNil) == nil ifTrue: [ ^#() ]. pkgs := OrderedCollection new. (self loadListForVersion: vrsn) do: [:nm | (vrsn packagesForSpecNamed: nm ) do: [:pkg | (pkg isPackageLoaded: aLoader) ifTrue: [ pkgs add: pkg name ]]]. ^pkgs! ! !MetacelloMCProjectSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! loadVersion: aVersionOrNil "Load the correct version of the project" | vrsn mcLoader list | self ensureProjectLoaded. vrsn := aVersionOrNil. vrsn == nil ifTrue: [ [ vrsn := self version ] on: MetacelloVersionDoesNotExistError do: [ :ex | ^ (MetacelloProjectSpecLoadError projectSpec: self) versionDoesNotExistException: ex; signal: 'No version found for ' , self versionString printString , ' of ' , self className asString , ' because: ' , ex description ] ]. mcLoader := self loader copy. mcLoader operator: self operator. vrsn loader: mcLoader. list := (mcLoader ignoreImage ifTrue: [ self loadListForVersion: vrsn ] ifFalse: [ vrsn packageAndProjectNamesToLoad: (self loadListForVersion: vrsn) loader: mcLoader ]) asSet. MetacelloPlatform current useStackCacheDuring: [ :dict | | projectCache cachedList | projectCache := dict at: self projectClass ifAbsent: [ dict at: self projectClass put: Dictionary new ]. (cachedList := projectCache at: vrsn ifAbsent: [ ]) == nil ifTrue: [ projectCache at: vrsn put: list ] ifFalse: [ (cachedList size = list size and: [ cachedList includesAllOf: list ]) ifTrue: [ "no need to refetch list ... recursion stoppper (Issue 95)" ^ self ] ifFalse: [ projectCache at: vrsn put: list ] ]. vrsn versionString ~= self versionString ifTrue: [ Transcript show: ' [' , vrsn versionString , ']' ]. mcLoader preLoad: self. vrsn fetchRequiredFromArray: list. "do the load" (MetacelloProjectSpecLoadedNotification new projectSpec: (self copy versionString: vrsn versionString)) signal. mcLoader postLoad: self ] defaultDictionary: Dictionary new! ! !MetacelloMCProjectSpec methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! resolveToAllPackagesIn: aVersionSpec visited: visited | vrsn | visited pushProject: [ visited visit: self doing: [ :spec | spec ensureProjectLoaded. vrsn := spec version. ^ vrsn allPackagesForSpecNamed: (self loadListForVersion: vrsn) ifAbsent: [ self error: 'invalid loads: spec' ] ] ]. ^ #()! ! !MetacelloMCProjectSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! compareRelativeCurrentVersion: anOperator targetVersionStatus: targetVersionStatus using: anMCLoader | cv vrsn | (vrsn := self versionOrNil) == nil ifTrue: [ ^false ]. (cv := self relativeCurrentVersion) == nil ifTrue: [ ^false ]. (targetVersionStatus includes: cv versionStatus) ifTrue: [ ^cv perform: anOperator with: vrsn ]. ^false ! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! projectPackage projectPackage ifNil: [ self className ifNil: [ ^ nil ]. projectPackage := self project packageSpec. projectPackage name: self className. self getFile ifNotNil: [ projectPackage file: self file ]. projectPackage repositories: self getRepositories ]. ^ projectPackage! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! className: aString super className: aString. self projectPackage: nil! ! !MetacelloMCProjectSpec methodsFor: 'testing' stamp: 'dkh 6/13/2012 16:30'! compareCurrentVersion: anOperator targetVersionStatus: targetVersionStatus using: anMCLoader ^ (MetacelloLookupProjectSpecForLoad new projectSpec: self; yourself) signal performCurrentVersionTestAgainst: self versionOrNil operator: anOperator targetVersionStatus: targetVersionStatus using: anMCLoader! ! !MetacelloMCProjectSpec methodsFor: 'loading' stamp: 'dkh 03/13/2013 15:18'! ensureProjectLoaded "Ensure that the MetacelloProject is loaded in image. projectClass == nil or requested version non-existent warrants a project package load." "answer true if the projectClass exists" (self projectClass == nil or: [ self versionOrNil == nil or: [ (loader notNil or: [ self isMutable ]) and: [ self loader ignoreImage ] ] ]) ifTrue: [ | pc | (pc := self projectClass) ~~ nil ifTrue: [ MetacelloClearStackCacheNotification signal: #(#'currentVersion' #'currentVersionAgainst:' #'currentVersionInfo' #'versionConstructor' #'loadableSpecNames') , {pc} ]. self projectPackage ifNil: [ ^ true ]. self ensureLoadUsing: self loader ]. ^ self projectClass ~~ nil! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadPackageList | vrsn pkgs | (vrsn := self versionOrNil) == nil ifTrue: [ ^#() ]. pkgs := OrderedCollection new. (self loadListForVersion: vrsn) do: [:nm | pkgs addAll: ((vrsn packagesForSpecNamed: nm ) collect: [:each | each name ])]. ^pkgs! ! !MetacelloMCProjectSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! ensureLoadUsing: aLoader (MetacelloLookupProjectSpec new projectSpec: self; yourself) signal projectPackage ensureLoadUsing: aLoader! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! copyForScriptingInto: aProjectSpec ^aProjectSpec setName: name; className: className; versionString: versionString; operator: operator; setLoads: loads; preLoadDoIt: preLoadDoIt; postLoadDoIt: postLoadDoIt; repositories: repositories copy; file: file! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 7/23/2012 11:17'! validateForScriptLoad: aScriptEngine withDefaultVersionString: defaultVersionString withDefaultRepositoryDecription: defaultRepositoryDecription | issues callSite | issues := OrderedCollection new. callSite := #'validateForScriptLoad:withDefaultVersionString:withDefaultRepositoryDecription:'. self name ifNil: [ issues add: (MetacelloValidationError configurationClass: self projectClass reasonCode: #'incompleteProjectSpec' callSite: callSite explanation: 'name field required') ]. self className ifNil: [ issues add: (MetacelloValidationError configurationClass: self projectClass reasonCode: #'incompleteProjectSpec' callSite: callSite explanation: 'className field required') ]. self repositories isEmpty ifTrue: [ defaultRepositoryDecription ifNotNil: [ self repository: defaultRepositoryDecription ] ifNil: [ issues add: (MetacelloValidationError configurationClass: self projectClass reasonCode: #'incompleteProjectSpec' callSite: callSite explanation: 'repository field required') ] ]. self validateVersionString: issues withDefaultVersionString: defaultVersionString. ^ issues! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'dkh 7/2/2012 16:40'! projectClassProject "indirection needed when projectClass is _not_ a subclass of MetacelloProject" ^ self projectClass new project setBaselineRepositoryDescription: self repositoryDescriptions; yourself! ! !MetacelloMCProjectSpec methodsFor: 'scripting' stamp: 'dkh 7/23/2012 11:56'! validateVersionString: issues withDefaultVersionString: defaultVersionString self versionString ifNil: [ defaultVersionString ifNotNil: [ self versionString: defaultVersionString ] ifNil: [ issues add: (MetacelloValidationError configurationClass: self projectClass reasonCode: #'incompleteProjectSpec' callSite: #'validateForScriptLoad:withDefaultVersionString:withDefaultRepositoryDecription:' explanation: 'version field required') ] ]! ! !MetacelloMCProjectSpecTestCase methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectClass ^ MetacelloMCProject! ! !MetacelloMCProjectSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testMCProjectMergeSpec | projectA projectB project packageA packageB repository | projectA := self projectSpec name: 'Project'; projectPackage: self project packageSpec; className: 'ConfigurationOfProject'; repository: 'http://example.com/repository' username: 'dkh' password: 'password'; repository: '/opt/gemstone/repository'; yourself. projectB := self projectSpec name: 'Project'; projectPackage: self project packageSpec; className: 'ConfigurationOfProjectB'; repository: 'http://example.com/repository' username: 'DaleHenrichs' password: 'secret'; repository: '/opt/gemstone/repo'; yourself. project := projectA mergeSpec: projectB. self assert: project name = 'Project'. self assert: project className = 'ConfigurationOfProjectB'. self assert: project projectPackage name = project className. self assert: project projectPackage file = project className. repository := project repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'directory'. repository := project repositories map at: '/opt/gemstone/repo' ifAbsent: [ self assert: false ]. self assert: repository type = 'directory'. repository := project repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'http'. self assert: repository username = 'DaleHenrichs'. self assert: repository password = 'secret'! ! !MetacelloMCProjectSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testMCProjectSpec | project repository | project := self projectSpec. project name: 'Project'; projectPackage: self project packageSpec; className: 'ConfigurationOfProject'; repository: 'http://example.com/repository' username: 'dkh' password: 'password'; repository: '/opt/gemstone/repository'; yourself. self assert: project name = 'Project'. self assert: project className = 'ConfigurationOfProject'. self assert: project projectPackage name = project className. self assert: project projectPackage file = project className. repository := project repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'directory'. repository := project repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'http'. self assert: repository username = 'dkh'. self assert: repository password = 'password'! ! !MetacelloMCTestsAbstractConfig methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! project | constructor | ^project ifNil: [ "Construct Metacello project" constructor := MetacelloVersionConstructor on: self. project := constructor project. project loader: MetacelloNullRecordingMCSpecLoader new. project]. ! ! !MetacelloMCValueHolderSpecTestCase methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectClass ^ MetacelloMCProject! ! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! silently: aBool "by default silently is false" self loaderPolicy silently: aBool! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! currentlyLoadedClassesInVersion ^self spec currentlyLoadedClassesInVersion! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! loader: aLoader self versionSpec loader: aLoader! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! currentlyLoadedExtensionClassesInVersion ^self spec currentlyLoadedExtensionClassesInVersion! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! fetchRequiredFromArray: anArray | originalLoader displayString newLoader | originalLoader := self versionSpec loader. newLoader := originalLoader fetchingSpecLoader. displayString := newLoader actionLabel , self versionNumber printString , ' of ' , self spec projectLabel. MetacelloPlatform current do: [ [ self versionSpec loader: newLoader. MetacelloPlatform current useStackCacheDuring: [ :dict | ^ self executeLoadFromArray: anArray ] defaultDictionary: Dictionary new ] ensure: [ self versionSpec loader: originalLoader ] ] displaying: displayString! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 9/11/2012 10:16'! packages "Answers the list of packages associated with this version" | packages | packages := OrderedCollection new. self spec projectDo: [:ignored | ] packageDo: [:pkg | packages add: pkg ] groupDo: [:ignored | ]. ^packages ! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! record: required ^required recordRequiredForMetacelloMCVersion: self ! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! packagesForSpecNamed: aString ifAbsent: aBlock "resolves list of packages associated with the named spec. If the spec is a packages, answer a list including only the package. #requires: and #includes: fields in the package are ignored. If the spec is a project, answers an empty list. If the spec is a group, answers the list of packages in the #includes: field of the group. Groups in the #includes: field are expanded following the transitive closure on groups" "If there is no spec named , aBlock is evaluated" | pkgSpec | pkgSpec := self spec packageNamed: aString ifAbsent: aBlock. ^pkgSpec resolveToPackagesIn: self spec visited: MetacelloVisitedPackages new! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 9/11/2012 11:53'! packageAndProjectNamesToLoad: defaultList loader: aLoader "Answer the list of packages and projects to be loaded: packages already loaded plust defaultList" | loadedPackageNames projectMap loadedProjectNames list | loadedPackageNames := ((self packages select: [:pkg | pkg isPackageLoaded: aLoader ]) collect: [:pkg | pkg name ]) asSet, defaultList. projectMap := Dictionary new. self projects do: [:prj | prj className ~~ nil ifTrue: [ | coll loaded | coll := projectMap at: prj className ifAbsent: [ coll := OrderedCollection new. projectMap at: prj className put: coll. coll]. (loaded := prj loadedPackageNames: aLoader) isEmpty ifFalse: [ coll add: prj -> (loaded -> prj loadPackageList) ]]]. loadedProjectNames := Set new. projectMap keysAndValuesDo: [:prjClass :coll | coll size <= 1 ifTrue: [ coll do: [:assoc | loadedProjectNames add: assoc key name ]] ifFalse: [ "multiple project references against the same configuration ... only count project as loaded if there is an exact match for loaded projects... See http://code.google.com/p/metacello/issues/detail?id=86" coll do: [:assoc | | loaded packageList | loaded := assoc value key. "loaded packages from project" packageList := assoc value value. "loadlist for project" (packageList difference: loaded) isEmpty ifTrue: [ loadedProjectNames add: assoc key name ]]]]. list := loadedPackageNames, loadedProjectNames. list isEmpty ifTrue: [ ^self spec defaultPackageNames]. ^list! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! load ^self doLoadRequiredFromArray: self spec defaultPackageNames! ! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loaderPolicy: anObject loaderPolicy := anObject! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! allPackagesForSpecNamed: aStringOrArray ifAbsent: aBlock "resolves list of packages associated with the named spec. If the spec is a packages, answer a list including the package and the transitive closure on its #requires: and #includes: fields. If the spec is a project, answer a list of the packages associated with the project, following the transitive closure on packages reachable starting with the #loads: field. If the spec is a group, answers the list of packages in the #includes: field of the group. Groups in the #includes: field are expanded following the transitive closure on groups" "In essence, this query answers the list of all packages that would be loaded if the package named were loaded." "If there is no spec named , aBlock is evaluated" ^aStringOrArray resolvePackageSpecsNamedForMetacelloMCVersion: self visited: MetacelloVisitedPackages new ifAbsent: aBlock ! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! fetch ^self doFetchRequiredFromArray: self spec defaultPackageNames! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! loadRequiredFromArray: anArray | displayString | displayString := 'Loading ', self versionNumber printString, ' of ', self spec projectLabel. MetacelloPlatform current do: [ ^self executeLoadFromArray: anArray ] displaying: displayString! ! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! cacheRepository: repository "by default cacheRepository is an MCDictionaryRepository" self loaderPolicy cacheRepository: repository! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 9/11/2012 11:53'! defaultPackageNamesToLoad: defaultList "Answer the list of packages and projects to be loaded: packages already loaded plust defaultList" ^ self packageAndProjectNamesToLoad: defaultList loader: self loader! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! doFetchRequiredFromArray: anArray | oldPolicy oldBypassProgress displayString | displayString := self versionNumber printString, ' of ', self spec projectLabel. Transcript cr; show: 'Fetching ', displayString, '...'. oldPolicy := loaderPolicy. oldBypassProgress := MetacelloPlatform current bypassProgressBars. self loaderPolicy silently ifTrue: [ MetacelloPlatform current bypassProgressBars: true ]. [ | ans | ans := self fetchRequiredFromArray: anArray. Transcript cr; show: '...finished ', self versionNumber printString. ^ans ] ensure: [ MetacelloPlatform current bypassProgressBars: oldBypassProgress. loaderPolicy := oldPolicy ] ! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! doRecordRequiredFromArray: anArray | originalLoader oldPolicy displayString oldBypassProgress | displayString := self versionNumber printString, ' of ', self spec projectLabel. Transcript cr; show: 'Recording ', displayString, '...'. originalLoader := self versionSpec loader. oldPolicy := loaderPolicy. oldBypassProgress := MetacelloPlatform current bypassProgressBars. self loaderPolicy silently ifTrue: [ MetacelloPlatform current bypassProgressBars: true ]. [ MetacelloPlatform current do: [ | ans | self versionSpec loader: originalLoader recordingSpecLoader. ans := (self executeLoadFromArray: anArray) copy. Transcript cr; show: '...finished ', self versionNumber printString. ^ans ] displaying: 'Recording ', displayString ] ensure: [ MetacelloPlatform current bypassProgressBars: oldBypassProgress. self versionSpec loader: originalLoader. loaderPolicy := oldPolicy ]! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 9/10/2012 15:43'! computeVersionStatus " #allLoadedToSpec - all projects and packages are loaded and match specification #loadedToSpec - all loaded projects and packages match specifications (at least one package loaded) #loadedMatchConstraints - all loaded projects and packages match constraints (at least one package loaded) #somethingLoaded - at least one package loaded " self spec computeVersionStatus: [ :status | ^ status ]. ^ #noStatus! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! doLoadRequiredFromArray: anArray | displayString oldPolicy oldBypassProgress | displayString := self versionNumber printString, ' of ', self spec projectLabel. Transcript cr; show: 'Loading ', displayString, '...'. oldPolicy := loaderPolicy. oldBypassProgress := MetacelloPlatform current bypassProgressBars. self loaderPolicy silently ifTrue: [ MetacelloPlatform current bypassProgressBars: true ]. [ | fetchLoader | fetchLoader := self fetchRequiredFromArray: (self defaultPackageNamesToLoad: anArray). MetacelloPlatform current do: [ fetchLoader doLoad ] displaying: 'Loading ', displayString. Transcript cr; show: '...finished ', self versionNumber printString. ^fetchLoader ] ensure: [ MetacelloPlatform current bypassProgressBars: oldBypassProgress. loaderPolicy := oldPolicy ] ! ! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repositoryOverrides: repositoriesCollection self loaderPolicy overrideRepositories: repositoriesCollection! ! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loaderPolicy loaderPolicy == nil ifTrue: [ loaderPolicy := MetacelloLoaderPolicy new ]. ^ loaderPolicy! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! allPackagesForSpecs: pkgSpecs visited: visited | coll | coll := Dictionary new. pkgSpecs do: [:pkgSpec | (pkgSpec resolveToAllPackagesIn: self spec visited: visited) do: [:pkg | coll at: pkg name put: pkg ]]. ^ coll values asOrderedCollection ! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! fetch: required ^required fetchRequiredForMetacelloMCVersion: self ! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! load: required ^required loadRequiredForMetacelloMCVersion: self ! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 9/11/2012 11:53'! defaultPackageNamesToLoad "Answer the list of packages and projects to be loaded --> packages already loaded" ^ self defaultPackageNamesToLoad: self spec defaultPackageNames! ! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! ignoreImage: aBool "by default ignoreImage is false" self loaderPolicy ignoreImage: aBool! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! record ^self doRecordRequiredFromArray: self spec defaultPackageNames! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! executeLoadFromArray: anArray | loader mcLoader | loader := MetacelloMCVersionSpecLoader on: self spec. loader required: anArray. loaderPolicy notNil ifTrue: [ loader loaderPolicy: loaderPolicy ]. ^loader load! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! allPackagesForSpecNamed: aStringOrArray "resolves list of packages associated with the named spec. If the spec is a packages, answer a list including the package and the transitive closure on its #requires: and #includes: fields. If the spec is a project, answer a list of the packages associated with the project, following the transitive closure on packages reachable starting with the #loads: field. If the spec is a group, answers the list of packages in the #includes: field of the group. Groups in the #includes: field are expanded following the transitive closure on groups" "In essence, this query answers the list of all packages that would be loaded if the package named were loaded." "If there is no spec named , answers an empty list" ^self allPackagesForSpecNamed: aStringOrArray ifAbsent: [ ^#() ]! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! packagesForSpecNamed: aString "resolves list of packages associated with the named spec. If the spec is a packages, answer a list including only the package. #requires: and #includes: fields in the package are ignored. If the spec is a project, answers an empty list. If the spec is a group, answers the list of packages in the #includes: field of the group. Groups in the #includes: field are expanded following the transitive closure on groups" "If there is no spec named , answers an empty list" ^self packagesForSpecNamed: aString ifAbsent: [ ^#() ]! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'dkh 9/11/2012 13:42'! packageNames "leave reference to packages for upgrade purposes" packages == nil ifTrue: [ ^ super packageNames ]. ^ self packages map keys asSet! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isSomethingLoaded "at least one package loaded" self isPartiallyCurrent isSomethingLoaded: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isLoadedMatchConstraintsAgainst: resolvedPackageAndProjectNames "all loaded projects and packages match constraints (at least one package loaded)" (self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames) isLoadedMatchConstraints: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'dkh 05/08/2013 09:32'! currentlyLoadedClassesInVersion | classes | classes := Set new. self projectDo: [ :ignored | ] packageDo: [ :packageSpec | | wc | wc := [ packageSpec workingCopy ] on: Error do: [ :ex | ex return: nil ]. wc ~~ nil ifTrue: [ classes addAll: (MetacelloPlatform current packageInfoFor: wc) classes ] ] groupDo: [ :ignored | ]. ^ classes! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isAllLoadedToSpecAgainst: resolvedPackageAndProjectNames "all projects and packages are loaded and match specification" (self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames) isAllLoadedToSpec: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! specListProjectDo: projectBlock packageDo: packageBlock groupDo: groupBlock self packages specListDo: [:pkgSpec | pkgSpec projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock ]! ! !MetacelloMCVersionSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! package: packageName with: aBlockOrString constructor: aVersionConstructor aVersionConstructor packageForVersion: packageName with: aBlockOrString! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isAllLoadedToSpec "all projects and packages are loaded and match specification" self isPartiallyCurrent isAllLoadedToSpec: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'merging' stamp: 'dkh 9/11/2012 12:12'! mergeSpec: anotherSpec | newSpec map anotherRepositories | newSpec := super mergeSpec: anotherSpec. map := anotherSpec mergeMap. (anotherRepositories := map at: #'repositories') isEmpty not ifTrue: [ newSpec repositories: (self repositories isEmpty ifTrue: [ anotherRepositories ] ifFalse: [ self repositories mergeSpec: anotherRepositories ]) ]. ^ newSpec! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isLoadedToSpecAgainst: resolvedPackageAndProjectNames "all loaded projects and packages match specifications (at least one package loaded)" (self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames) isLoadedToSpec: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'dkh 05/08/2013 09:32'! currentlyLoadedExtensionClassesInVersion | classes | classes := Dictionary new. self projectDo: [ :ignored | ] packageDo: [ :packageSpec | | wc | wc := [ packageSpec workingCopy ] on: Error do: [ :ex | ex return: nil ]. wc ~~ nil ifTrue: [ | packageInfo | packageInfo := MetacelloPlatform current packageInfoFor: wc. packageInfo extensionClasses do: [ :cl | classes at: cl put: (packageInfo extensionCategoriesForClass: cl) ] ] ] groupDo: [ :ignored | ]. ^ classes! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/11/2012 13:41'! packages "leave reference to packages for upgrade purposes" packages == nil ifTrue: [ ^ super packages ]. ^ packages! ! !MetacelloMCVersionSpec methodsFor: 'printing' stamp: 'dkh 9/10/2012 15:57'! configMethodOn: aStream last: last indent: indent | spec hasRepositories hasPackageSpecs hasImport | hasRepositories := (spec := self repositoriesSpec) ~~ nil and: [ spec list isEmpty not ]. hasImport := self import ~~ nil. hasPackageSpecs := false. self packagesSpec list do: [ :member | member spec projectDo: [ :proj | member spec name ~~ nil ifTrue: [ hasPackageSpecs := true ] ] packageDo: [ :package | member spec name ~~ nil ifTrue: [ hasPackageSpecs := true ] ] groupDo: [ :group | member spec name ~~ nil ifTrue: [ hasPackageSpecs := true ] ] ]. self configMethodBasicOn: aStream last: (hasRepositories | hasPackageSpecs | hasImport) not indent: indent. hasImport ifTrue: [ self configMethodValueOn: aStream for: self import selector: 'import:' last: (hasRepositories | hasPackageSpecs) not indent: indent ]. hasRepositories ifTrue: [ spec map values size = 1 ifTrue: [ aStream tab: indent; nextPutAll: 'spec repository: '; nextPutAll: spec map values first description printString , '.'. hasPackageSpecs ifTrue: [ aStream cr ] ] ifFalse: [ self configMethodOn: aStream for: spec selector: 'repositories:' last: hasPackageSpecs not indent: indent ] ]. self configPackagesSpecMethodOn: aStream indent: indent. last ifFalse: [ aStream cr ]! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isPartiallyCurrent ^self isPartiallyCurrentAgainst: (self expandToLoadableSpecNames: #('ALL'))! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isSomethingLoadedAgainst: resolvedPackageAndProjectNames "at least one package loaded" (self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames) isSomethingLoaded: [ :ignored | ^ true ]. ^ false ! ! !MetacelloMCVersionSpec methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! versionClass ^MetacelloMCVersion! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repositories repositories == nil ifTrue: [ repositories := self project repositoriesSpec ]. ^ repositories! ! !MetacelloMCVersionSpec methodsFor: 'merging' stamp: 'dkh 9/11/2012 12:11'! mergeMap | map | map := super mergeMap. map at: #'repositories' put: self repositories. ^ map! ! !MetacelloMCVersionSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! removePackage: aString constructor: aVersionConstructor aVersionConstructor removePackageForVersion: aString! ! !MetacelloMCVersionSpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! configSpawnMethodOn: aStream indent: indent super configSpawnMethodOn: aStream indent: indent. self configPackagesSpecMethodOn: aStream indent: indent.! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repository: aString username: username password: password self repositoriesSpec repository: aString username: username password: password! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'dkh 9/11/2012 11:57'! difference: otherVersionSpec "Return a dictionary of additions, removals and modifications" | report myProjectSpecs myPackageSpecs otherProjectSpecs otherPackageSpecs | report := MetacelloVersionDiffReport new. myProjectSpecs := Dictionary new. myPackageSpecs := Dictionary new. self projectDo: [ :projectSpec | myProjectSpecs at: projectSpec name put: projectSpec ] packageDo: [ :packageSpec | myPackageSpecs at: packageSpec name put: packageSpec ] groupDo: [ :ignored | ]. otherProjectSpecs := Dictionary new. otherPackageSpecs := Dictionary new. otherVersionSpec projectDo: [ :projectSpec | otherProjectSpecs at: projectSpec name put: projectSpec ] packageDo: [ :packageSpec | otherPackageSpecs at: packageSpec name put: packageSpec ] groupDo: [ :ignored | ]. myProjectSpecs valuesDo: [ :myProjectSpec | | otherProjectSpec | otherProjectSpec := otherProjectSpecs at: myProjectSpec name ifAbsent: [ ]. otherProjectSpec == nil ifTrue: [ report removals at: myProjectSpec name put: {(myProjectSpec versionString). ''} ] ifFalse: [ myProjectSpec versionString = otherProjectSpec versionString ifFalse: [ report modifications at: myProjectSpec name put: {(myProjectSpec versionString). (otherProjectSpec versionString)} ] ] ]. otherProjectSpecs valuesDo: [ :otherProjectSpec | (myProjectSpecs at: otherProjectSpec name ifAbsent: [ ]) == nil ifTrue: [ report additions at: otherProjectSpec name put: {''. (otherProjectSpec versionString)} ] ]. myPackageSpecs valuesDo: [ :myPackageSpec | | otherPackageSpec | otherPackageSpec := otherPackageSpecs at: myPackageSpec name ifAbsent: [ ]. otherPackageSpec == nil ifTrue: [ report removals at: myPackageSpec name put: {(myPackageSpec file). ''} ] ifFalse: [ myPackageSpec file = otherPackageSpec file ifFalse: [ report modifications at: myPackageSpec name put: {(myPackageSpec file). (otherPackageSpec file)} ] ] ]. otherPackageSpecs valuesDo: [ :otherPackageSpec | (myPackageSpecs at: otherPackageSpec name ifAbsent: [ ]) == nil ifTrue: [ report additions at: otherPackageSpec name put: {''. (otherPackageSpec file)} ] ]. ^ report! ! !MetacelloMCVersionSpec methodsFor: 'merging' stamp: 'dkh 9/11/2012 12:11'! nonOverridable ^ super nonOverridable , #(#'repositories')! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isPartiallyCurrentAgainst: resolvedPackageAndProjectNames | mcLoader status | status := MetacelloMCPartiallyLoadedStatus new. mcLoader := self loader. self specsNamed: resolvedPackageAndProjectNames projectDo: [ :prj | | vrsn currentVersion | status hasNoProject: false. vrsn := prj versionOrNil. vrsn ~~ nil ifTrue: [ (currentVersion := prj relativeCurrentVersion) ~~ nil ifTrue: [ status vrsnStatus add: currentVersion versionStatus ] ]. currentVersion ~~ nil ifTrue: [ status aProjectIsLoaded: true. (currentVersion perform: #= with: vrsn) ifTrue: [ status aLoadedProjectIsExact: true ] ifFalse: [ (currentVersion perform: prj projectReference operator with: vrsn) ifTrue: [ status aLoadedProjectIsCurrent: true ] ifFalse: [ status aLoadedProjectIsNotCurrent: true ] ] ] ifFalse: [ status aProjectNotLoaded: true ] ] packageDo: [ :pkg | status hasNoPackage: false. pkg currentPackageLoaded: [ :versionInfos :file | | wcName wcRef fileRef exact current | status aPackageIsLoaded: true. versionInfos isEmpty ifTrue: [ status aLoadedPackageIsNotCurrent: true ] ifFalse: [ exact := current := false. versionInfos do: [ :vi | wcName := vi name. fileRef := GoferResolvedReference name: file. wcRef := GoferResolvedReference name: wcName. (wcRef compare: fileRef using: #=) ifTrue: [ exact := true ] ]. exact ifTrue: [ status aLoadedPackageIsExact: true ] ifFalse: [ versionInfos do: [ :vi | wcName := vi name. fileRef := GoferResolvedReference name: file. wcRef := GoferResolvedReference name: wcName. (wcRef compare: fileRef using: #>=) ifTrue: [ current := true ] ]. current ifTrue: [ status aLoadedPackageIsCurrent: true ] ifFalse: [ status aLoadedPackageIsNotCurrent: true ] ] ] ] notLoaded: [ status aPackageNotLoaded: true ] using: mcLoader ] groupDo: [ :ignoredGroup | "if we encounter a group, trouble" status abort: true. ^ status ]. ^ status! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isPossibleBaseline self projectDo: [:prj | prj isPossibleBaseline ifFalse: [ ^false ]] packageDo: [:pkg | pkg isPackageLoaded ifFalse: [ ^false ]] groupDo: [:ignored | ]. ^true! ! !MetacelloMCVersionSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! updateForSpawnMethod: sourceSpec "This means that this spec was used in a baseline and will be used in a version .... drop all information that isn't useful" repositories := preLoadDoIt := postLoadDoIt := nil. ! ! !MetacelloMCVersionSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! repositorySpecs ^self repositories map values! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'dkh 9/11/2012 12:26'! packageSpecsInLoadOrderForMap: packageMap | loadOrder pkgs packageNames importNames importProjectSpec importSpec | loadOrder := self packageSpecsInLoadOrder. importNames := (packageNames := (packageMap values collect: [ :pkg | pkg name ]) asSet) copy. self import ifNil: [ ^ loadOrder select: [ :pkg | packageNames includes: pkg name ] ]. loadOrder do: [ :pkg | importNames remove: pkg name ifAbsent: [ ] ]. pkgs := OrderedCollection new. importProjectSpec := loadOrder detect: [ :pkg | pkg name = self import ]. loadOrder do: [ :pkg | (packageNames includes: pkg name) ifTrue: [ pkgs add: pkg ]. pkg name = self import ifTrue: [ "insert the imports at this point" importNames do: [ :importedName | pkgs add: (importSpec := importProjectSpec copy name: importedName; mergeImportLoads: {importedName}; yourself). importSpec projectReference name: importedName ] ] ]. ^ pkgs! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isLoadedMatchConstraints "all loaded projects and packages match constraints (at least one package loaded)" self isPartiallyCurrent isLoadedMatchConstraints: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! computeVersionStatus: matchBlock self computeVersionStatus: (self expandToLoadableSpecNames: #('ALL')) matchBlock: matchBlock! ! !MetacelloMCVersionSpec methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! specsNamed: packageAndProjectNames projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock | map | map := self packages map. packageAndProjectNames do: [:name | | pkgSpec | (pkgSpec := map at: name ifAbsent: [ ]) ~~ nil ifTrue: [ pkgSpec projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock ]]! ! !MetacelloMCVersionSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! package: aString overrides: aBlock constructor: aVersionConstructor aVersionConstructor packageForVersion: aString overrides: aBlock! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repositoriesSpec ^self repositories! ! !MetacelloMCVersionSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! packagesNeedSavingVisited: visitedProjects into: aCollection self packages map valuesDo: [:pkg | pkg packagesNeedSavingVisited: visitedProjects using: self repositories map values into: aCollection ]. ! ! !MetacelloMCVersionSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! updatedPackageSpecs | updatedSpecs mcLoader | updatedSpecs := Dictionary new. mcLoader := self loader. self packages map valuesDo: [:pkg | pkg updatePackageSpec: updatedSpecs using: mcLoader]. ^updatedSpecs! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repositories: anObject repositories := anObject! ! !MetacelloMCVersionSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! forceUpdatedPackageSpecs | updatedSpecs mcLoader | updatedSpecs := Dictionary new. mcLoader := self loader. self packages map valuesDo: [:pkg | pkg forceUpdatePackageSpec: updatedSpecs using: mcLoader]. ^updatedSpecs! ! !MetacelloMCVersionSpec methodsFor: 'copying' stamp: 'dkh 9/11/2012 13:42'! postCopy super postCopy. repositories := repositories copy. packages := packages copy "leave reference to packages for upgrade purposes"! ! !MetacelloMCVersionSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! package: aString constructor: aVersionConstructor aVersionConstructor packageForVersion: aString! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repository: aString self repositoriesSpec add: aString! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isLoadedToSpec "all loaded projects and packages match specifications (at least one package loaded)" self isPartiallyCurrent isLoadedToSpec: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! computeVersionStatus: resolvedPackageAndProjectNames matchBlock: matchBlock | status | status := resolvedPackageAndProjectNames isNil ifTrue: [ self isPartiallyCurrent ] ifFalse: [ self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames ]. status isAllLoadedToSpec: matchBlock. status isLoadedToSpec: matchBlock. status isLoadedMatchConstraints: matchBlock. status isSomethingLoaded: matchBlock! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! operator ^self loader operator! ! !MetacelloMCVersionSpecLoader methodsFor: 'spec compatibility' stamp: 'dkh 6/8/2012 14:04:22'! repositorySpecs | repositoryMap | repositoryMap := self versionSpec repositories ~~ nil ifTrue: [ self versionSpec repositories map ] ifFalse: [ Dictionary new ]. ^repositoryMap values.! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loader loader == nil ifTrue: [ loader := self versionSpec loader copy. loader spec: self. loaderPolicy notNil ifTrue: [ loader loaderPolicy: loaderPolicy] ]. ^loader! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! required: anObject required := anObject! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! project ^self versionSpec project! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! packages ^packages! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loaderPolicy ^ loaderPolicy! ! !MetacelloMCVersionSpecLoader methodsFor: 'spec compatibility' stamp: 'dkh 6/26/2012 12:11'! packageSpecsInLoadOrder ^ self versionSpec packageSpecsInLoadOrderForMap: packages! ! !MetacelloMCVersionSpecLoader methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! repositories ^self repositorySpecs! ! !MetacelloMCVersionSpecLoader methodsFor: 'spec compatibility' stamp: 'dkh 6/8/2012 14:04:22'! versionString ^self versionSpec versionString! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! label ^self versionSpec label! ! !MetacelloMCVersionSpecLoader methodsFor: 'loading' stamp: 'dkh 6/26/2012 11:50'! load | mcLoader | packages := Dictionary new. self resolveToLoadableSpecs. mcLoader := self loader. packages values do: [ :pkg | pkg ensureLoadedForDevelopmentUsing: mcLoader. mcLoader ignoreImage ifFalse: [ (pkg compareCurrentVersion: self operator targetVersionStatus: #(#'allLoadedToSpec') using: mcLoader) ifTrue: [ packages removeKey: pkg name ] ] ]. packages notEmpty ifTrue: [ mcLoader preLoad: self versionSpec. mcLoader load. mcLoader postLoad: self versionSpec ]. ^ mcLoader! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! versionSpec ^ versionSpec! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loaderPolicy: anObject loaderPolicy := anObject! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! required required == nil ifTrue: [ ^#() ]. ^ required! ! !MetacelloMCVersionSpecLoader methodsFor: 'private' stamp: 'dkh 6/26/2012 16:12'! resolveToLoadableSpecs self versionSpec resolveToLoadableSpecs: required forLoad: true map: packages! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! versionSpec: anObject versionSpec := anObject! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! name ^self versionSpec name! ! !MetacelloMCVersionSpecLoader methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! resolvePackageNames packages := Dictionary new. self resolveToLoadableSpecs. ^packages values collect: [:pkg | pkg name ]! ! !MetacelloMCVersionSpecLoader class methodsFor: 'instance creation' stamp: 'dkh 6/8/2012 14:04:22'! on: aVersionSpec ^(self new) versionSpec: aVersionSpec; yourself! ! !MetacelloMCVersionSpecTestCase methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectClass ^ MetacelloMCProject! ! !MetacelloMCVersionSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testMCVersionSpec | version projectReferenceSpec group package repository | version := self versionSpec blessing: #'baseline'; versionString: '1.0'; repository: 'http://example.com/repository' username: 'dkh' password: 'password'; repository: '/opt/gemstone/repository'; yourself. version packages add: (self packageSpec name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself); add: (self groupSpec name: 'Platform'; includes: 'Core'; yourself); add: (self projectSpec name: 'Project'; className: 'ConfigurationOfProjectA'; versionString: #'stable'; loads: #('MyPackage' 'MyTests'); preLoadDoIt: #'preLoadDoItB'; postLoadDoIt: #'postLoadDoItB'; yourself); yourself. self assert: version blessing value = #'baseline'. self assert: version versionString value = '1.0'. repository := version repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'directory'. repository := version repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'http'. self assert: repository username = 'dkh'. self assert: repository password = 'password'. package := version packages packageNamed: 'Package' ifAbsent: [ self assert: false ]. self assert: package name = 'Package'. group := version packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. self assert: (group includes includes: 'Core'). projectReferenceSpec := version packages packageNamed: 'Project' ifAbsent: [ self assert: false ]. self assert: projectReferenceSpec projectName = 'Project'. self assert: projectReferenceSpec versionString = #'stable'. version projectDo: [ :prjct | prjct == projectReferenceSpec ] packageDo: [ :pkg | pkg == package ] groupDo: [ :grp | grp == group ]! ! !MetacelloMCVersionSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testMCVersionMergeSpec | versionA versionB version repository package group projectReferenceSpec | versionA := self versionSpec blessing: #'baseline'; versionString: '1.0'; repository: 'http://example.com/repository' username: 'dkh' password: 'password'; repository: '/opt/gemstone/repository'; yourself. versionA packages merge: (self packageSpec name: 'Package'; requires: 'AnotherPackage'; yourself); merge: (self groupSpec name: 'Platform'; includes: 'Core'; yourself); merge: (self projectReferenceSpec name: 'Project'; projectReference: (self projectSpec name: 'Project'; projectPackage: self project packageSpec; className: 'ConfigurationOfProjectA'; repository: 'http://example.com/repository' username: 'dkh' password: 'password'; repository: '/opt/gemstone/repository'; yourself)); yourself. versionB := self versionSpec blessing: #'release'; versionString: '1.1'; repository: 'http://example.com/repository' username: 'DaleHenrichs' password: 'secret'; repository: '/opt/gemstone/repo'; yourself. versionB packages merge: (self packageSpec name: 'Package'; requires: 'AndAnotherPackage'; yourself); merge: (self groupSpec name: 'Platform'; includes: 'Tests'; yourself); merge: (self projectReferenceSpec name: 'Project'; projectReference: (self projectSpec name: 'Project'; projectPackage: self project packageSpec; className: 'ConfigurationOfProjectA'; repository: 'http://example.com/repository' username: 'DaleHenrichs' password: 'secret'; repository: '/opt/gemstone/repo'; yourself)); yourself. version := versionA mergeSpec: versionB. self assert: version blessing value = #'release'. self assert: version versionString value = '1.1'. repository := version repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'directory'. repository := version repositories map at: '/opt/gemstone/repo' ifAbsent: [ self assert: false ]. self assert: repository type = 'directory'. repository := version repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'http'. self assert: repository username = 'DaleHenrichs'. self assert: repository password = 'secret'. package := version packages packageNamed: 'Package' ifAbsent: [ self assert: false ]. self assert: package name = 'Package'. projectReferenceSpec := version packages packageNamed: 'Project' ifAbsent: [ self assert: false ]. self assert: projectReferenceSpec projectName = 'Project'. repository := projectReferenceSpec repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'directory'. repository := projectReferenceSpec repositories map at: '/opt/gemstone/repo' ifAbsent: [ self assert: false ]. self assert: repository type = 'directory'. repository := projectReferenceSpec repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'http'. self assert: repository username = 'DaleHenrichs'. self assert: repository password = 'secret'. group := version packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. self assert: (group includes includes: 'Core'). self assert: (group includes includes: 'Tests')! ! !MetacelloMCVersionValidator commentStamp: 'dkh 1/26/2012 09:49'! Performs configuration validation. For programmatically decoding reason codes use: MetacellMCVersionValidator fullDescriptionForReasonCode: Warning reason codes: #notDevelopmentVersion - the symbolic version #development refers to a non-development literal version. #loadWarning - Warning signalled during load [load validation]. #onlyBaselineVersion - one or more baseline versions have been defined, but no non-baseline versions are defined. #stableDevelopmentVersion - a version whose blessing is #development has been declared as a #stable version Critical Warning reason codes: #duplicateVersionDefinitions - there are multiple pragma methods specifying the same version #loadDeprecation - deprecation warning signalled while loading configuration [load validation] #missingRecommendedProjectSpecField - missing recommended fields in project reference (versionString). The versionString should be specified so that #bleedingEdge loads will be predictable and repeatable #noLoadableVersions - no non #baseline versions defined in configuration #noTests - no test cases defined in loaded configuration [load validation] #noVersionSpecified - no version defined for the project reference or package. The version specified in the baseline or the latest version of the project or package in the repository will be used. #packageNameMismatch - the name in the packageSpec does not match the name of the mcz file #projectClassNameFileMismatch - the class name of the configuration does not match the mcz file containing the configuration #testDeprecation - deprecation warning signalled while running configuration tests [load validation] Error reason codes: #cannotResolveVersion - the version (project reference or symbolic version) was not found in the specified configuration #duplicateNames - multiple independent definitions for an entity with same name (project, package, or group) #incompleteProjectSpec - missing required fields in project reference (className and/or repository) #incorrectVersionString - the version declared in pragma doesn't match version in versionSpec #invalidDoItSelector - doit select must be a Symbol #invalidVersionString - versionString must be a String #loadError - error occured while loading configuration [load validation] #missingVersionImport - version specified in import pragma not defined in configuration #noVersionsDefined - no usable baseline or version defined in configuration ... configuration cannot be loaded #projectCreationError - error occured while resolving project reference #shadowedNames - name duplication between packages and projects #testFailures - test failures while running tests [load validation] #versionCompositionError - error while creating versionSpec from pragmas ! !MetacelloMCVersionValidator methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! errorReasonCodes ^ super errorReasonCodes, #(#loadError #testFailures )! ! !MetacelloMCVersionValidator methodsFor: 'private' stamp: 'dkh 6/30/2012 13:24'! validateVersionSpec: versionSpec versionSpec blessing value == #'broken' ifTrue: [ ^ self ]. versionSpec projectDo: [ :projectSpec | | referencedProjectSpec | projectSpec versionString == nil ifTrue: [ self recordValidationCriticalWarning: 'No version specified for the project reference ' , projectSpec name printString , ' in version ' , versionSpec versionString printString versionString: versionSpec versionString callSite: #'validateVersionSpec:' reasonCode: #'noVersionSpecified' ]. referencedProjectSpec := projectSpec referencedSpec. versionSpec blessing value == #'baseline' ifTrue: [ referencedProjectSpec hasRepository ifTrue: [ (referencedProjectSpec file beginsWith: referencedProjectSpec className) ifFalse: [ self recordValidationCriticalWarning: 'The class name of project ' , referencedProjectSpec className printString , ' does not match the file name ' , referencedProjectSpec file printString , ' in version ' , versionSpec versionString printString versionString: versionSpec versionString callSite: #'validateVersionSpec:' reasonCode: #'projectClassNameFileMismatch' ] ] ifFalse: [ self recordValidationError: 'The specification for the project reference ' , projectSpec name printString , ' in version ' , versionSpec versionString printString , ' is missing the required repository field' versionString: versionSpec versionString callSite: #'validateVersionSpec:' reasonCode: #'incompleteProjectSpec' ] ]. referencedProjectSpec ensureProjectLoaded ifTrue: [ [ projectSpec version ] on: MetacelloVersionDoesNotExistError do: [ :ex | | explanation | explanation := projectSpec versionString == nil ifTrue: [ 'the default version' ] ifFalse: [ 'version ' , projectSpec versionString printString ]. self recordValidationError: 'Cannot resolve ' , explanation , ' for the project reference ' , projectSpec name printString , ' in version ' , versionSpec versionString printString versionString: versionSpec versionString callSite: #'validateVersionSpec:' reasonCode: #'cannotResolveVersion' ] ] ] packageDo: [ :packageSpec | (packageSpec file beginsWith: packageSpec name) ifFalse: [ self recordValidationCriticalWarning: 'The name of package ' , packageSpec name printString , ' does not match the file name ' , packageSpec file printString , ' in version ' , versionSpec versionString printString versionString: versionSpec versionString callSite: #'validateVersionSpec:' reasonCode: #'packageNameMismatch' ]. packageSpec file = packageSpec name ifTrue: [ self recordValidationCriticalWarning: 'No version specified for the package ' , packageSpec name printString , ' in version ' , versionSpec versionString printString versionString: versionSpec versionString callSite: #'validateVersionSpec:' reasonCode: #'noVersionSpecified' ] ] groupDo: [ :ignored | ]. self validateBaselineVersionSpec: versionSpec! ! !MetacelloMCVersionValidator methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! validateProjectLoad | issues project versions currentVersion collectedIssues | (issues := self validateProject select: [ :issue | issue isError ]) notEmpty ifTrue: [ ^ issues ]. project := self configurationClass project. collectedIssues := issues. versions := project versions select: [ :version | validationReport := nil. version blessing ~~ #broken and: [ version blessing ~~ #baseline and: [ (issues := (self validateProject: project version: version versionString) select: [ :issue | issue isCritical ]) isEmpty ] ] ]. validationReport := collectedIssues. versions isEmpty ifTrue: [ self recordValidationCriticalWarning: 'No non #baseline versions available in ' , self configurationClass name asString callSite: #validateProjectLoad reasonCode: #noLoadableVersions. ^ self validationReport ]. (currentVersion := project currentVersion) ~~ nil ifTrue: [ | index | index := versions indexOf: currentVersion. versions := versions copyFrom: index to: versions size ]. versions do: [ :version | self validateCleanLoadAndTestsForVersion: version loads: #('ALL') ]. ^ self validationReport! ! !MetacelloMCVersionValidator methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! validateProjectVersionLoad: versionString loads: loadList | issues project currentVersion version | (issues := (self validateProjectVersion: versionString) select: [ :issue | issue isError ]) notEmpty ifTrue: [ ^ issues ]. project := self configurationClass project. version := project version: versionString ifAbsent: [ self recordValidationError: 'Version ' , versionString printString , ' does not exist.' callSite: #validateProjectVersionLoad:loads: reasonCode: #cannotResolveVersion. ^ self validationReport ]. version blessing = #broken ifTrue: [ self error: 'The specified version is #broken' ]. self validateCleanLoadAndTestsForVersion: version loads: loadList. ^ self validationReport! ! !MetacelloMCVersionValidator methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! validateCleanLoadAndTestsForVersion: version loads: loadList | cleanLoad cleanTests | cleanTests := cleanLoad := false. [ self validateVersionLoad: version loads: loadList. cleanLoad := true ] on: Error , Warning do: [ :ex | (ex isKindOf: Error) ifTrue: [ self recordValidationError: 'Error while loading version ' , version versionString printString , ' in ' , self configurationClass name asString , ' ' , ex description versionString: version versionString callSite: #validateCleanLoadAndTestsForVersion:loads: reasonCode: #loadError ]. (ex isKindOf: Warning) ifTrue: [ (ex isKindOf: Deprecation) ifTrue: [ self recordValidationCriticalWarning: 'Deprecation while loading version ' , version versionString printString , ' in ' , self configurationClass name asString , ' ' , ex description versionString: version versionString callSite: #validateCleanLoadAndTestsForVersion:loads: reasonCode: #loadDeprecation ] ifFalse: [ self recordValidationWarning: 'Warning while loading version ' , version versionString printString , ' in ' , self configurationClass name asString , ' ' , ex description versionString: version versionString callSite: #validateCleanLoadAndTestsForVersion:loads: reasonCode: #loadWarning. Smalltalk at: #UndeclaredVariableWarning ifPresent: [ :undeclaredWrning | (ex isKindOf: undeclaredWrning) ifTrue: [ ex resume: true ] ]. ex resume ] ] ]. cleanLoad ifTrue: [ cleanTests := [ self validateVersionTests: version ] on: Deprecation do: [ :ex | | message | message := 'Deprecation warning while running tests for version ' , version versionString printString , ' in ' , self configurationClass name asString , ' ' , ex description. "Deprecation warning for release tests is the same as a test failure" self recordValidationCriticalWarning: message versionString: version versionString callSite: #validateCleanLoadAndTestsForVersion:loads: reasonCode: #testDeprecation. ex return: false ]. cleanTests ifTrue: [ MetacelloCleanLoadAndTestsNotification signal: version ] ifFalse: [ MetacelloCleanLoadNotification signal: version ] ]! ! !MetacelloMCVersionValidator methodsFor: 'validation' stamp: 'dkh 7/2/2012 17:32'! validateBaselineVersionSpec: versionSpec | projectNames packageNames groupNames versionMessage | self validateDoIts: versionSpec versionString: versionSpec versionString errorMessage: ' version ' , versionSpec versionString printString. projectNames := Set new. packageNames := Set new. groupNames := Set new. versionMessage := ' in version ' , versionSpec versionString printString. versionSpec projectDo: [ :projectSpec | projectSpec resolveProjectSpec className == nil ifTrue: [ self recordValidationError: 'Missing required field (className:) for project reference ' , projectSpec name printString , ' in version ' , versionSpec versionString printString versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'incompleteProjectSpec' ]. projectSpec resolveProjectSpec versionString == nil ifTrue: [ self recordValidationCriticalWarning: 'Missing recommended field (versionString:) for project reference ' , projectSpec name printString , ' in version ' , versionSpec versionString printString versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'missingRecommendedProjectSpecField' ]. projectSpec hasRepository ifTrue: [ (self recurse and: [ projectSpec versionString ~~ nil ]) ifTrue: [ | project | projectSpec resolveProjectSpec ensureProjectLoaded. project := self validateProjectCreationFrom: projectSpec resolveProjectSpec projectClass onError: [ :ex | self recordValidationError: 'Error creating project reference: ' , ex description versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'projectCreationError'. nil ]. project ~~ nil ifTrue: [ self validationReport addAll: (self class validateProject: project version: projectSpec versionString debug: self debug recurse: self recurse visited: self visited) ] ] ] ifFalse: [ self recordValidationError: 'Missing required field (repository:) for project reference ' , projectSpec name printString , ' in version ' , versionSpec versionString printString versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'incompleteProjectSpec' ]. self validateDoIts: projectSpec versionString: versionSpec versionString errorMessage: projectSpec name printString , versionMessage. (projectNames includes: projectSpec name) ifTrue: [ self recordValidationError: 'Duplicate projects named' , projectSpec name printString , versionMessage versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'duplicateNames' ] ifFalse: [ projectNames add: projectSpec name ] ] packageDo: [ :packageSpec | self validateDoIts: packageSpec versionString: versionSpec versionString errorMessage: packageSpec name printString , versionMessage. (packageNames includes: packageSpec name) ifTrue: [ self recordValidationError: 'Duplicate packages named' , packageSpec name printString , versionMessage versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'duplicateNames' ] ifFalse: [ projectNames add: packageSpec name ] ] groupDo: [ :groupSpec | (groupNames includes: groupSpec name) ifTrue: [ self recordValidationError: 'Duplicate groups named' , groupSpec name printString , versionMessage versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'duplicateNames' ] ifFalse: [ projectNames add: groupSpec name ] ]. (packageNames intersection: projectNames) notEmpty ifTrue: [ self recordValidationError: 'Names duplicated between packages and projects' , versionMessage versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'shadowedNames' ]. (groupNames intersection: projectNames) notEmpty ifTrue: [ self recordValidationError: 'Names duplicated between groups and projects' , versionMessage versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'shadowedNames' ]. (projectNames intersection: packageNames) notEmpty ifTrue: [ self recordValidationError: 'Names duplicated between projects and packages' , versionMessage versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'shadowedNames' ]. (groupNames intersection: packageNames) notEmpty ifTrue: [ self recordValidationError: 'Names duplicated between groups and packages' , versionMessage versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'shadowedNames' ]. (projectNames intersection: groupNames) notEmpty ifTrue: [ self recordValidationError: 'Names duplicated between projects and groups' , versionMessage versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'shadowedNames' ]. (packageNames intersection: groupNames) notEmpty ifTrue: [ self recordValidationError: 'Names duplicated between packages and groups' , versionMessage versionString: versionSpec versionString callSite: #'validateBaselineVersionSpec:' reasonCode: #'shadowedNames' ]! ! !MetacelloMCVersionValidator methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! validateVersionLoad: version loads: loadList | list | list := loadList asOrderedCollection. list isEmpty ifTrue: [ list add: 'default' ]. (version groups includes: 'Tests') ifTrue: [ list add: 'Tests' ]. version load: list! ! !MetacelloMCVersionValidator methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! criticalWarningReasonCodes ^ super criticalWarningReasonCodes , #(#noLoadableVersions #noTests #testDeprecation #loadDeprecation #noVersionSpecified #'missingRecommendedProjectSpecField' )! ! !MetacelloMCVersionValidator methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! warningReasonCodes ^ super warningReasonCodes, #(#loadWarning #notDevelopmentVersion #stableDevelopmentVersion)! ! !MetacelloMCVersionValidator methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! validateVersionTests: version | testCases cleanTests | testCases := IdentitySet new. cleanTests := true. version currentlyLoadedClassesInVersion do: [ :class | ((class inheritsFrom: TestCase) and: [ class isAbstract not ]) ifTrue: [ testCases add: class ] ]. testCases do: [ :testCase | | testResults | testResults := testCase suite run. testResults defects notEmpty ifTrue: [ self recordValidationError: 'Test failures in tests ' , testCase name asString , ' for ' , version versionString printString , ' in ' , self configurationClass name asString , ' ' , testResults printString versionString: version versionString callSite: #validateVersionTests: reasonCode: #testFailures. cleanTests := false ] ]. testCases isEmpty ifTrue: [ self recordValidationCriticalWarning: 'No test cases for ' , version versionString printString , ' in ' , self configurationClass name asString versionString: version versionString callSite: #validateVersionTests: reasonCode: #noTests. cleanTests := false ]. ^ cleanTests! ! !MetacelloMCVersionValidator methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! validateVersionSpecForSymbolicVersion: versionSpec symbolicVersion: symbolicVersionString | blessing | versionSpec blessing value == #broken ifTrue: [ ^ self ]. blessing := versionSpec blessing value. (symbolicVersionString == #development and: [ blessing ~~ #development ]) ifTrue: [ self recordValidationWarning: 'Symbolic version ' , symbolicVersionString printString , ' refers to a version' , versionSpec versionString printString , ' whose blessing ' , blessing printString , ' is not #development' versionString: versionSpec versionString callSite: #validateVersionSpecForSymbolicVersion:symbolicVersion: reasonCode: #notDevelopmentVersion ]! ! !MetacelloMCVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/8/2012 14:04:22'! validateConfigurationLoad: configurationClass ^ ((self new) configurationClass: configurationClass; yourself) validateProjectLoad! ! !MetacelloMCVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/8/2012 14:04:22'! validateConfigurationLoad: configurationClass version: versionString loads: loadList ^ ((self new) configurationClass: configurationClass; yourself) validateProjectVersionLoad: versionString loads: loadList! ! !MetacelloMCVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/8/2012 14:04:22'! validateConfigurationLoad: configurationClass version: versionString ^self validateConfigurationLoad: configurationClass version: versionString loads: #() ! ! !MetacelloMCVersionValidator class methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! populateReasonCodeDescriptions "update MetacelloMCVersionValidator class comment to include any changes to descriptions" | dict | dict := super populateReasonCodeDescriptions. dict at: #'notDevelopmentVersion' put: 'the symbolic version #development refers to a non-development literal version.'; at: #'loadWarning' put: 'Warning signalled during load [load validation].'; at: #'stableDevelopmentVersion' put: 'a version whose blessing is #development has been declared as a #stable version.'. "Warnings" dict at: #'loadDeprecation' put: 'deprecation warning signalled while loading configuration [load validation].'; at: #'missingRecommendedProjectSpecField' put: 'missing recommended fields in project reference (versionString). The versionString should be specified so that #bleedingEdge loads will be predictable and repeatable.'; at: #'noLoadableVersions' put: 'no non #baseline versions defined in configuration.'; at: #'noTests' put: 'no test cases defined in loaded configuration [load validation].'; at: #'noVersionSpecified' put: 'no version defined for the project reference or package. The version specified in the baseline or the latest version of the project or package in the repository will be used.'; at: #'testDeprecation' put: 'deprecation warning signalled while running configuration tests [load validation].'. "Critical Warnings" dict at: #'loadError' put: 'error occured while loading configuration [load validation].'; at: #'testFailures' put: 'test failures while running tests [load validation].'. "Errors" ^ dict! ! !MetacelloMemberListSpec methodsFor: 'enumeration' stamp: 'dkh 6/5/2012 19:01:24'! detect: aBlock ifNone: exceptionBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the first element for which aBlock evaluates to true. If none evaluate to true, then evaluate the argument, exceptionBlock." self do: [ :each | (aBlock value: each) ifTrue: [ ^ each ] ]. ^ exceptionBlock value! ! !MetacelloMemberListSpec methodsFor: 'enumeration' stamp: 'dkh 6/5/2012 19:01:24'! detect: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the first element for which aBlock evaluates to true." ^ self detect: aBlock ifNone: [ self error: 'Object is not in the collection.' ]! ! !MetacelloMemberListSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! mapCopy: aMemberSpec into: map | spec | spec := map at: aMemberSpec sourceName ifAbsent: [ ]. spec == nil ifTrue: [ ^ self error: 'Source spec named ' , aMemberSpec sourceName printString , ' not found' ] ifFalse: [ spec aboutToCopy. map at: aMemberSpec name put: (spec copy mergeSpec: aMemberSpec spec copy) ]! ! !MetacelloMemberListSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeSpec: anotherSpec | newSpec val | newSpec := super mergeSpec: anotherSpec. newSpec list: self list copy. anotherSpec list do: [:groupMember | groupMember applyToList: newSpec ]. ^newSpec! ! !MetacelloMemberListSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! clearMemberMap memberMap := nil.! ! !MetacelloMemberListSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! mapMerge: aMemberSpec into: map | spec | spec := map at: aMemberSpec name ifAbsent: []. spec == nil ifTrue: [ map at: aMemberSpec name put: aMemberSpec spec copy ] ifFalse: [ map at: aMemberSpec name put: (spec mergeSpec: aMemberSpec spec)]! ! !MetacelloMemberListSpec methodsFor: 'enumeration' stamp: 'dkh 6/5/2012 19:01:24'! specListDetect: aBlock ifNone: exceptionBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the first element for which aBlock evaluates to true. If none evaluate to true, then evaluate the argument, exceptionBlock." self specListDo: [ :each | (aBlock value: each) ifTrue: [ ^ each ] ]. ^ exceptionBlock value! ! !MetacelloMemberListSpec methodsFor: 'enumeration' stamp: 'dkh 6/5/2012 19:01:24'! specListDo: aBlock self list do: [:member | aBlock value: member spec ]! ! !MetacelloMemberListSpec methodsFor: 'enumeration' stamp: 'dkh 6/5/2012 19:01:24'! specListSelect: aBlock | newCollection | newCollection := OrderedCollection new. self specListDo: [:each | (aBlock value: each) ifTrue: [newCollection add: each]]. ^newCollection! ! !MetacelloMemberListSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! add: aSpec self subclassResponsibility! ! !MetacelloMemberListSpec methodsFor: 'adding' stamp: 'dkh 6/5/2012 19:01:24'! addMember: aMember self list add: aMember. self clearMemberMap ! ! !MetacelloMemberListSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! copy: aMemberSpec self addMember: aMemberSpec! ! !MetacelloMemberListSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! list list == nil ifTrue: [ list := OrderedCollection new ]. ^list! ! !MetacelloMemberListSpec methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isEmpty ^self list isEmpty! ! !MetacelloMemberListSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! mapRemove: aMemberSpec into: map map removeKey: aMemberSpec name ifAbsent: []! ! !MetacelloMemberListSpec methodsFor: 'toolbox support' stamp: 'dkh 9/12/2012 14:16'! deleteSpec: aSpec "remove the spec from list" | member | member := self list detect: [ :aMember | aMember spec = aSpec ] ifNone: [ ^ self ]. self list remove: member! ! !MetacelloMemberListSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! mapAdd: aMemberSpec into: map map at: aMemberSpec name put: aMemberSpec spec! ! !MetacelloMemberListSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! map | map | memberMap ~~ nil ifTrue: [ ^memberMap ]. map := Dictionary new. self list do: [:member | member applyAdd: [:memberSpec | self mapAdd: memberSpec into: map ] copy: [:memberSpec | self mapCopy: memberSpec into: map ] merge: [:memberSpec | self mapMerge: memberSpec into: map ] remove: [:memberSpec | self mapRemove: memberSpec into: map ]]. memberMap := map. ^memberMap! ! !MetacelloMemberListSpec methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! notEmpty ^self list notEmpty! ! !MetacelloMemberListSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! copy: specNamed to: aSpec self subclassResponsibility! ! !MetacelloMemberListSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! list: aCollection list := aCollection. self clearMemberMap! ! !MetacelloMemberListSpec methodsFor: 'enumeration' stamp: 'dkh 6/5/2012 19:01:24'! select: aBlock | newCollection | newCollection := OrderedCollection new. self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]]. ^newCollection! ! !MetacelloMemberListSpec methodsFor: 'enumeration' stamp: 'dkh 6/5/2012 19:01:24'! collect: aBlock | newCollection | newCollection :=OrderedCollection new. self do: [:each | newCollection add: (aBlock value: each)]. ^ newCollection! ! !MetacelloMemberListSpec methodsFor: 'enumeration' stamp: 'dkh 6/5/2012 19:01:24'! do: aBlock self map values do: aBlock! ! !MetacelloMemberListSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! merge: aSpec self subclassResponsibility! ! !MetacelloMemberListSpec methodsFor: 'copying' stamp: 'dkh 6/5/2012 19:01:24'! postCopy super postCopy. list := list copy. self clearMemberMap! ! !MetacelloMemberListSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! remove: aSpec self subclassResponsibility! ! !MetacelloMemberListSpec methodsFor: 'enumeration' stamp: 'dkh 6/5/2012 19:01:24'! specListDetect: aBlock "Evaluate aBlock with each of the receiver's elements as the argument. Answer the first element for which aBlock evaluates to true." ^ self specListDetect: aBlock ifNone: [ self error: 'Object is not in the collection.' ]! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! sourceName ^self name! ! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! addToMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: self! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! methodUpdateSelector ^self subclassResponsibility! ! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! removeFromMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: self! ! !MetacelloMemberSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock self subclassResponsibility ! ! !MetacelloMemberSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! applyToList: aListSpec self subclassResponsibility! ! !MetacelloMemberSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodCascadeOn: aStream last: lastCascade indent: indent self spec configMethodCascadeOn: aStream member: self last: lastCascade indent: indent! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! name: aString name := aString! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! spec: aMetacelloSpec spec := aMetacelloSpec! ! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! removeFromMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: self ! ! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: self ! ! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! mergeIntoMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: self! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! name ^name! ! !MetacelloMemberSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodOn: aStream indent: indent aStream nextPutAll: self class name asString, ' member: ('. self spec configMethodOn: aStream indent: indent. aStream nextPutAll: ')'.! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! spec ^spec! ! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! addToMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: self! ! !MetacelloMergeMemberSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock mergeBlock value: self ! ! !MetacelloMergeMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! methodUpdateSelector ^#with:! ! !MetacelloMergeMemberSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! applyToList: aListSpec aListSpec merge: self! ! !MetacelloMethodSection methodsFor: 'testing' stamp: 'dkh 9/13/2012 19:12'! includesAttributeFrom: attributeCollection ^ (attributeCollection asSet intersection: self attributes asSet) notEmpty! ! !MetacelloMethodSection methodsFor: 'accessing' stamp: 'dkh 9/7/2012 10:45'! attribute self deprecated: 'Use attributes instead'. self attributes size > 1 ifTrue: [ self error: 'invalid use of attribute' ]. self attributes isEmpty ifTrue: [ ^ nil ]. ^ self attributes first! ! !MetacelloMethodSection methodsFor: 'accessing' stamp: 'dkh 9/7/2012 06:42'! attributes attributes ifNil: [ attributes := OrderedCollection new ]. ^ attributes! ! !MetacelloMethodSection methodsFor: 'accessing' stamp: 'dkh 9/7/2012 10:49'! attribute: anObject self deprecated: 'Use attributes: instead'. self attributes size > 1 ifTrue: [ self error: 'invalid use of attribute:' ]. attributes := OrderedCollection with: anObject! ! !MetacelloMethodSection methodsFor: 'printing' stamp: 'dkh 9/12/2012 09:46'! attributePrintString | stream | stream := WriteStream on: String new. self attributes size = 1 ifTrue: [ stream nextPutAll: '#' , attributes first asString printString ] ifFalse: [ stream nextPutAll: '#('. self attributes do: [ :attribute | stream nextPutAll: '#' , attribute asString printString; space ]. stream nextPut: $) ]. ^ stream contents! ! !MetacelloMethodSection methodsFor: 'accessing' stamp: 'dkh 9/8/2012 05:41'! attributes: aCollectionOrSymbol attributes := aCollectionOrSymbol asMetacelloAttributeList! ! !MetacelloMethodSectionPath methodsFor: 'conversion' stamp: 'dkh 9/7/2012 14:00'! asAttributeOrPath self size = 1 ifTrue: [ | attribute | attribute := self at: 1. ^ attribute size = 1 ifTrue: [ attribute at: 1 ] ifFalse: [ attribute ] ]. ^ self! ! !MetacelloMethodSectionPath methodsFor: 'conversion' stamp: 'dkh 9/7/2012 13:41'! asMetacelloAttributePath ^ self! ! !MetacelloMethodSpec methodsFor: 'method generation' stamp: 'dkh 6/5/2012 19:01:24'! methodSource self subclassResponsibility! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! selector ^ selector! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString ^ versionString! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! category ^ category! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! project: anObject project := anObject! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString: aStringOrSymbol versionString := aStringOrSymbol! ! !MetacelloMethodSpec methodsFor: 'method generation' stamp: 'dkh 6/5/2012 19:01:24'! compileMethod (project configuration class compile: self methodSource classified: self category) == nil ifTrue: [ self error: 'Error compiling the method' ]! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! project ^ project! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! methodSections methodSections == nil ifTrue: [ methodSections := OrderedCollection new ]. ^ methodSections! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! selector: anObject selector := anObject! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! methodSections: anObject methodSections := anObject! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! category: anObject category := anObject! ! !MetacelloMonticelloResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpMonticelloRepository "This method builds a fake repository with the version references from #buildReferences." monticelloRepository := MCDictionaryRepository new. versionReferences do: [ :reference | monticelloRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)) with: (MCClassDefinition name: (reference packageName copyWithout: $-) asSymbol superclassName: #Object category: reference packageName asSymbol instVarNames: #() comment: ''))) dependencies: #()) ]! ! !MetacelloMonticelloResource methodsFor: 'running' stamp: 'dkh 07/19/2013 22:53'! setUpVersionReferences "self reset" versionReferences := OrderedCollection new. versionReferences add: (GoferVersionReference name: 'GoferBar.branch-lr.1'); add: (GoferVersionReference name: 'GoferBar.branch-lr.2'); add: (GoferVersionReference name: 'GoferBar-jf.1'); add: (GoferVersionReference name: 'GoferBar-lr.1'); add: (GoferVersionReference name: 'GoferFoo-lr.1'); add: (GoferVersionReference name: 'GoferFoo-lr.2'); add: (GoferVersionReference name: 'GoferFoo-lr.4'); add: (GoferVersionReference name: 'GoferBeau-dkh.15'); add: (GoferVersionReference name: 'GoferBeau-dkh.25'); add: (GoferVersionReference name: 'GoferBeau-dkh.53'); add: (GoferVersionReference name: 'GoferBeau-dkh.54'); add: (GoferVersionReference name: 'GoferBeau-dkh.55'); add: (GoferVersionReference name: 'GoferBeau-dkh.56'); add: (GoferVersionReference name: 'GoferFaux-tg.30'); add: (GoferVersionReference name: 'GoferFaux-tg.31'); add: (GoferVersionReference name: 'GoferFaux-tg.32'); add: (GoferVersionReference name: 'GoferFaux-tg.33'); add: (GoferVersionReference name: 'GoferFaux-tg.34'); add: (GoferVersionReference name: 'GoferFaux-tg.35'); add: (GoferVersionReference name: 'GeauxBar.branch-lr.2'); add: (GoferVersionReference name: 'GeauxFoo-lr.1'); add: (GoferVersionReference name: 'GeauxFaux-tg.32'); add: (GoferVersionReference name: 'GeauxBeau-dkh.55'); add: (GoferVersionReference name: 'GeauxBeau-dkh.56'); add: (GoferVersionReference name: 'ConfigurationOfNautilusWithoutPackages-dkh.55'); add: (GoferVersionReference name: 'ConfigurationOfNautilusWithoutPackages-dkh.56'); add: (GoferVersionReference name: 'ConfigurationOfNautilusWithoutPackages-dkh.57'); add: (GoferVersionReference name: 'ConfigurationOfNautilus-dkh.56'); add: (GoferVersionReference name: 'ConfigurationOfGlamourSeaside-dkh.55'); add: (GoferVersionReference name: 'ConfigurationOfGlamourSeaside-dkh.56'); add: (GoferVersionReference name: 'ConfigurationOfGlamourSeaside-dkh.57'); add: (GoferVersionReference name: 'ConfigurationOfGlamour-dkh.56'); yourself! ! !MetacelloMonticelloResource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! versionReferences ^ versionReferences! ! !MetacelloMonticelloResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUp super setUp. self setUpVersionReferences; setUpMonticelloRepository! ! !MetacelloMonticelloResource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! monticelloRepository ^ monticelloRepository! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! doingLoads: aBlock "escape mechanism for recording and null loaders to skip doing loaderlike things" ! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'versionInfo' stamp: 'dkh 6/8/2012 14:04:22'! currentVersionInfoFor: packageSpec ^self loadData currentVersionInfoFor: packageSpec ifAbsent: [ nil ] ! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! resolveRecordingPackageSpecReference: packageSpec gofer: gofer | externalPackageReference | externalPackageReference := packageSpec file == nil ifTrue: [ GoferPackageReference name: packageSpec name ] ifFalse: [ GoferResolvedReference name: packageSpec file repository: nil ]. packageSpec repositorySpecs isEmpty ifTrue: [ self repositoryMap at: externalPackageReference packageName put: (gofer repositories reject: [:repo | repo = MCCacheRepository default ]) ] ifFalse: [ self repositoryMap at: externalPackageReference packageName put: (packageSpec repositorySpecs collect: [:repoSpec | repoSpec createRepository ]) ]. ^externalPackageReference! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadPackageDirectives: pkgLoads gofer: aGofer "Noop"! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadingSpecLoader ^self! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! packages | packages | packages := OrderedCollection new. self loadDirective packageDirectivesDo: [:directive | packages add: directive spec ]. ^packages! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! resolvePackageSpecReferences: packageSpec gofer: gofer | versionReference references localGofer | localGofer := gofer. self hasRepositoryOverrides not ifTrue: [ packageSpec repositorySpecs notEmpty ifTrue: [ localGofer := MetacelloGofer new. (self repositoriesFrom: packageSpec repositorySpecs) do: [:repo | localGofer repository: repo ]]]. (packageSpec getFile == nil or: [ self shouldDisablePackageCache ]) ifTrue: [ "don't use package-cache when trying to get latest version" localGofer disablePackageCache ]. versionReference := packageSpec goferLoaderReference. references := versionReference resolveAllWith: localGofer. localGofer enablePackageCache. ^references! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! actionLabel ^'Recording '! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! beforeLoads beforeLoads == nil ifTrue: [ beforeLoads := OrderedCollection new ]. ^beforeLoads! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! linearLoadPackageSpec: packageSpec gofer: gofer MetacelloPlatform current do: [ | externalReference loadBlock answers fake | externalReference := self resolveRecordingPackageSpecReference: packageSpec gofer: gofer. loadBlock := [ self preLoad: packageSpec. (MetacelloDirective loadPackage: packageSpec externalReference: externalReference loader: self) addTo: self loadDirective. self postLoad: packageSpec ]. (answers := packageSpec answers) notEmpty ifTrue: [ loadBlock valueSupplyingMetacelloAnswers: answers ] ifFalse: [ loadBlock value ]. fake := packageSpec copy. fake name: fake file. self loadData addVersion: fake versionInfo: fake resolvedReference: externalReference packageSpec: packageSpec ] displaying: 'Recording ', packageSpec file! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'doits' stamp: 'dkh 6/8/2012 14:04:22'! preLoad: packageOrVersionSpec self evalDoits ifFalse: [ ^self ]. packageOrVersionSpec preLoadDoItBlock ~~ nil ifTrue: [ self beforeLoads add: packageOrVersionSpec name, ' load' ]. super preLoad: packageOrVersionSpec! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'doits' stamp: 'dkh 6/8/2012 14:04:22'! postLoad: packageOrVersionSpec self evalDoits ifFalse: [ ^self ]. packageOrVersionSpec postLoadDoItBlock ~~ nil ifTrue: [ self afterLoads add: packageOrVersionSpec name, ' load' ]. super postLoad: packageOrVersionSpec! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! afterLoads afterLoads == nil ifTrue: [ afterLoads := OrderedCollection new ]. ^afterLoads! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! evalDoits evalDoits == nil ifTrue: [ evalDoits := false ]. ^evalDoits! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadPackageDirective: aPackageLoadDirective gofer: aGofer "Noop"! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadedPackages | packages | packages := OrderedCollection new. self loadDirective packageDirectivesDo: [:directive | packages add: directive file ]. ^packages! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! evalDoits: aBool evalDoits := aBool! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadedRepositories | repos | repos := OrderedCollection new. self repositoryMap values collect: [:coll | repos addAll: coll ]. ^repos! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! recordingSpecLoader ^self! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! ensureForDevelopment ^false! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! file ^self externalReference name! ! !MetacelloPackageLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! packageDo: aBlock aBlock value: self! ! !MetacelloPackageLoadDirective methodsFor: 'initialize-release' stamp: 'dkh 6/8/2012 14:04:22'! spec: aPackageSpec externalReference: anExternalReference loader: aLoader super spec: aPackageSpec loader: aLoader. externalReference := anExternalReference! ! !MetacelloPackageLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! packageDirectivesDo: aBlock aBlock value: self! ! !MetacelloPackageLoadDirective methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! label ^self file! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! resolvedReference: anObject resolvedReference := anObject! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! externalReference ^ externalReference! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! packageName ^self externalReference packageName! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! title ^'load'! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repository ^self externalReference repository! ! !MetacelloPackageLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: aLoaderDirective gofer: aGofer aLoaderDirective loadPackageDirective: self gofer: aGofer! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! resolvedReference ^ resolvedReference! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! file file == nil ifTrue: [ ^self name ]. ^file ! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! setPreLoadDoIt: aSymbol preLoadDoIt := aSymbol! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 6/30/2012 13:30'! repository self deprecated: 'Use repositories or repositorySpecs'. self repositorySpecs isEmpty ifTrue: [ ^ nil ]. ^ self repositorySpecs first! ! !MetacelloPackageSpec methodsFor: 'merging' stamp: 'dkh 6/8/2012 14:04:22'! mergeSpec: anotherSpec | newSpec map anotherPackages anotherRepositories | newSpec := super mergeSpec: anotherSpec. map := anotherSpec mergeMap. (anotherRepositories := map at: #repositories) notEmpty ifTrue: [ newSpec repositories: (self repositories isEmpty ifTrue: [ anotherRepositories ] ifFalse: [ self repositories mergeSpec: anotherRepositories ]) ]. ^newSpec! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: aLoader gofer: gofer ^aLoader linearLoadPackageSpec: self gofer: gofer! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! preLoadDoIt ^preLoadDoIt! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! forceUpdatePackageSpec: updatedSpecs using: anMCLoader self updatePackageSpec: updatedSpecs force: true using: anMCLoader! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! getPostLoadDoIt ^postLoadDoIt! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! postLoadDoIt ^postLoadDoIt! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! packagesNeedSavingVisited: visitedProjects using: repos into: aCollection ^self loader packagesNeedSavingUsing: repos into: aCollection! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! getName "raw access to iv" ^ name! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! getRepositories "raw access to iv" ^ repositories! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! goferBranchPackage: branchName message: commitMessage "uses gofer to do commit ... non-interactive" | latestFile pkgSpec | (file notNil and: [ (self name, '.', branchName) = self file ]) ifTrue: [ latestFile := self loader latestPackage: self file fromRepository: self repositorySpecs. pkgSpec := self copy. latestFile ~~ nil ifTrue: [ pkgSpec file: latestFile. pkgSpec goferCommitPackage: commitMessage. ^ self ] ]. self loader goferCommitBranchPackage: branchName using: self repositorySpecs commitMessage: commitMessage! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! updatePackageRepositories: repositorySpecs | resolvedPackageRef | Transcript cr; show: ' Looking up version -> ', self file. resolvedPackageRef := self loader resolveSpec: self from: repositorySpecs. Transcript cr; show: 'Update repositoryGroup -> ', resolvedPackageRef name, ' ' , resolvedPackageRef repository description. resolvedPackageRef version workingCopy repositoryGroup addRepository: resolvedPackageRef repository ! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! updatePackageRepositoriesFor: aVersionSpec "Don't update the repository unless the package is loaded in the image" self workingCopy == nil ifTrue: [ ^self ]. self updatePackageRepositories: self repositorySpecs, aVersionSpec repositorySpecs. ! ! !MetacelloPackageSpec methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! extractNameFromFile file == nil ifTrue: [ ^nil ]. ^(self loader nameComponentsFrom: self file) first! ! !MetacelloPackageSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! postLoadDoIt: aSymbol constructor: aVersionConstructor aVersionConstructor postLoadDoItForPackage: aSymbol! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repository: aString username: username password: password self repositories repository: aString username: username password: password! ! !MetacelloPackageSpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! configMethodBodyOn: aStream hasName: hasName indent: indent | hasFile hasRepositories hasPreLoadDoIt hasPostLoadDoIt hasRequiresOrIncludesOrAnswers | hasFile := file ~~ nil. hasRepositories := self repositorySpecs size > 0. hasPreLoadDoIt := self getPreLoadDoIt ~~ nil. hasPostLoadDoIt := self getPostLoadDoIt ~~ nil. hasRequiresOrIncludesOrAnswers := (self requires isEmpty and: [ self includes isEmpty and: [self answers isEmpty ]]) not. hasRequiresOrIncludesOrAnswers ifTrue: [ self configMethodBodyOn: aStream hasName: hasName cascading: hasFile | hasRepositories | hasPreLoadDoIt | hasPostLoadDoIt indent: indent ]. self configMethodOn: aStream for: file selector: 'file: ' cascading: hasName | hasRepositories | hasPreLoadDoIt | hasPostLoadDoIt | hasRequiresOrIncludesOrAnswers cascade: hasRepositories | hasPreLoadDoIt | hasPostLoadDoIt indent: indent. hasRepositories ifTrue: [ (self repositorySpecs size > 1) ifTrue: [ hasName | hasFile | hasPreLoadDoIt | hasPostLoadDoIt | hasRequiresOrIncludesOrAnswers ifTrue: [ aStream cr; tab: indent. ]. aStream nextPutAll: 'repositories: ['; cr; tab: indent + 1; nextPutAll: 'spec'; cr. self repositories configMethodCascadeOn: aStream indent: indent + 1. aStream nextPutAll: ' ]' ] ifFalse: [ hasName | hasFile | hasPreLoadDoIt | hasPostLoadDoIt | hasRequiresOrIncludesOrAnswers ifTrue: [ aStream cr; tab: indent ]. self repositories configMethodCascadeOn: aStream indent: indent ]. hasPreLoadDoIt | hasPostLoadDoIt ifTrue: [ aStream nextPut: $; ] ]. self configMethodOn: aStream for: self getPreLoadDoIt selector: 'preLoadDoIt: ' cascading: hasName | hasFile | hasRepositories | hasPostLoadDoIt | hasRequiresOrIncludesOrAnswers cascade: hasPostLoadDoIt indent: indent. self configMethodOn: aStream for: self getPostLoadDoIt selector: 'postLoadDoIt: ' cascading: hasName | hasFile | hasRepositories | hasPreLoadDoIt | hasRequiresOrIncludesOrAnswers cascade: false indent: indent. aStream nextPut: $.! ! !MetacelloPackageSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! file: aString constructor: aVersionConstructor aVersionConstructor fileForPackage: aString! ! !MetacelloPackageSpec methodsFor: 'merging' stamp: 'dkh 6/8/2012 14:04:22'! nonOverridable ^super nonOverridable, #( repositories)! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! getFile "raw access to iv" ^file! ! !MetacelloPackageSpec methodsFor: 'testing' stamp: 'dkh 6/30/2012 13:23'! hasRepository ^ self repositorySpecs notEmpty! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! repositorySpecs ^self repositories map values! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! setPostLoadDoIt: aSymbol postLoadDoIt := aSymbol! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! updatePackageSpec: updatedSpecs using: anMCLoader "Add pkg copy to updatedSpecs if the file in current image is different from the receiver's file" self updatePackageSpec: updatedSpecs force: false using: anMCLoader! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! fetchPackage: aLoaderPolicy self fetchUsing: (self loader loaderPolicy: aLoaderPolicy; yourself)! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! preLoadDoIt: anObject anObject setPreLoadDoItInMetacelloSpec: self! ! !MetacelloPackageSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! preLoadDoIt: aSymbol constructor: aVersionConstructor aVersionConstructor preLoadDoItForPackage: aSymbol! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! repositories: anObject repositories := anObject! ! !MetacelloPackageSpec methodsFor: 'gofer' stamp: 'dkh 6/8/2012 14:04:22'! workingCopyName | wc | (wc := self workingCopy) == nil ifTrue: [ ^nil ]. wc ancestry ancestors isEmpty not ifTrue: [ ^wc ancestry ancestors first name ]. ^nil! ! !MetacelloPackageSpec methodsFor: 'copying' stamp: 'dkh 6/8/2012 14:04:22'! postCopy super postCopy. goferPackage := nil. repositories := repositories copy. ! ! !MetacelloPackageSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! compareCurrentVersion: anOperator targetVersionStatus: statusIgnored using: anMCLoader self currentPackageLoaded: [:bool | ^bool ] comparing: anOperator notLoaded: [:ignored | ^false ] using: anMCLoader ! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! postLoadDoIt: anObject anObject setPostLoadDoItInMetacelloSpec: self! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! ensureLoadUsing: mcLoader self explicitLoadUsing: mcLoader ensureSpecLoader! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! name name == nil ifTrue: [ name := self extractNameFromFile ]. ^name! ! !MetacelloPackageSpec methodsFor: 'testing' stamp: 'dkh 07/19/2013 15:50'! currentPackageLoaded: loadedBlock comparing: comarisonOperator notLoaded: notLoadedBlock using: anMCLoader "Use currentVersionInfoFor: because it involves the loader and returns versionInfo for a planned load (atomic loaders) or currently loaded package" | wcName vis | vis := anMCLoader ancestorsFor: self. vis notNil ifTrue: [ | fileRef wcRef | self getFile == nil ifTrue: [ ^ loadedBlock value: false ]. vis do: [ :vi | wcName := vi name. fileRef := GoferVersionReference name: self file. fileRef versionNumber = 0 ifTrue: [ "a shame that GoferVersionReference doesn't have better method for recognizing a missing verion number" "fix for: https://github.com/dalehenrich/metacello-work/issues/185" ^ loadedBlock value: false ]. wcRef := GoferVersionReference name: wcName. (wcRef compare: fileRef using: comarisonOperator) ifTrue: [ ^ loadedBlock value: true ] ]. ^ loadedBlock value: false ]. ^ notLoadedBlock value: true! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! ensureLoadedForDevelopmentUsing: mcLoader "noop" ^true! ! !MetacelloPackageSpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! configMethodCascadeOn: aStream member: aMember last: lastCascade indent: indent aMember methodUpdateSelector == #remove: ifTrue: [ aStream nextPutAll: 'removePackage: ', self name printString ] ifFalse: [ self configShortCutMethodBodyOn: aStream member: aMember indent: indent ]. lastCascade ifTrue: [ aStream nextPut: $. ] ifFalse: [ aStream nextPut: $;; cr ]! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! fetchUsing: mcLoader | fetchingSpecLoader | fetchingSpecLoader := mcLoader fetchingSpecLoader. fetchingSpecLoader linearLoadPackageSpecs: (Array with: self) repositories: (fetchingSpecLoader repositoriesFrom: self repositorySpecs). ! ! !MetacelloPackageSpec methodsFor: 'gofer' stamp: 'dkh 6/8/2012 14:04:22'! workingCopyNameFor: anMCLoader | vi | (vi := anMCLoader currentVersionInfoFor: self) == nil ifTrue: [ ^nil ]. ^vi name! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! goferLoaderReference ^file == nil ifTrue: [ GoferPackageReference name: self name ] ifFalse: [ "does Monticello-style #versionInfoFromVersionNamed: matching" MetacelloGoferPackage name: self name packageFilename: self file ]! ! !MetacelloPackageSpec methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! resolveToPackagesIn: aVersionSpec visited: visited ^{ self } ! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: mcLoader self loader doingLoads: [ self explicitLoadUsing: mcLoader ] ! ! !MetacelloPackageSpec methodsFor: 'gofer' stamp: 'dkh 6/8/2012 14:04:22'! workingCopy ^self goferPackage workingCopy! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! packageSpecsInLoadOrder ^{ self. }! ! !MetacelloPackageSpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! configShortCutMethodBodyOn: aStream member: aMember indent: indent | hasFile hasRepositories hasPreLoadDoIt hasPostLoadDoIt hasRequiresOrIncludesOrAnswers | hasFile := file ~~ nil. hasRepositories := self repositorySpecs size > 0. hasPreLoadDoIt := self getPreLoadDoIt ~~ nil. hasPostLoadDoIt := self getPostLoadDoIt ~~ nil. hasRequiresOrIncludesOrAnswers := (self requires isEmpty and: [ self includes isEmpty and: [self answers isEmpty ]]) not. hasRepositories | hasPreLoadDoIt | hasPostLoadDoIt | hasRequiresOrIncludesOrAnswers ifTrue: [ aStream nextPutAll: 'package: ', self name printString, ' '; nextPutAll: aMember methodUpdateSelector asString, ' ['; cr. aStream tab: indent + 1; nextPutAll: 'spec '. self configMethodBodyOn: aStream hasName: false indent: indent + 2. aStream nextPutAll: ' ]'. ^self ]. aStream nextPutAll: 'package: ', self name printString. hasFile ifTrue: [ aStream nextPutAll: ' with: ', file printString ]! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! repositories repositories == nil ifTrue: [ repositories := self project repositoriesSpec ]. ^ repositories! ! !MetacelloPackageSpec methodsFor: 'merging' stamp: 'dkh 6/8/2012 14:04:22'! mergeMap | map | map := super mergeMap. map at: #file put: file. map at: #repositories put: self repositories. map at: #preLoadDoIt put: preLoadDoIt. map at: #postLoadDoIt put: postLoadDoIt. ^map! ! !MetacelloPackageSpec methodsFor: 'gofer' stamp: 'dkh 6/8/2012 14:04:22'! currentVersionInfo ^self goferPackage currentVersionInfo! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! load self explicitLoadUsing: self loader! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! goferPackage goferPackage == nil ifTrue: [ goferPackage := MetacelloGoferPackage name: self name packageFilename: self file ]. ^goferPackage! ! !MetacelloPackageSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! repository: aString username: username password: password constructor: aVersionConstructor aVersionConstructor repositoryForPackage: aString username: username password: password! ! !MetacelloPackageSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! compareWorkingCopyNamed: wcName using: comarisonOperator | fileRef wcRef | fileRef := GoferResolvedReference name: self file. wcRef := GoferResolvedReference name: wcName. ^ wcRef compare: fileRef using: comarisonOperator! ! !MetacelloPackageSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! repository: anObject constructor: aVersionConstructor aVersionConstructor repositoryForPackage: anObject! ! !MetacelloPackageSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! supplyingAnswers: anObject constructor: aVersionConstructor aVersionConstructor supplyingAnswersForPackage: anObject! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! fetch self fetchUsing: self loader! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! file: aString file := aString! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! isPackageLoaded ^self isPackageLoaded: self loader! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 9/12/2012 12:14'! updateForSpawnMethod: sourceSpec "This means that this spec was used in a baseline and will be used in a version .... drop all information that isn't useful" | nm fl | nm := name. fl := file. fl == nil ifTrue: [ "if only name has been set, then force the file to be non-nil, if any attribute besides file is set, then leave file nil" {answers. requires. includes. repositories. preLoadDoIt. postLoadDoIt} detect: [ :each | each ~~ nil ] ifNone: [ fl := name ] ]. super updateForSpawnMethod: sourceSpec. file := repositories := goferPackage := preLoadDoIt := postLoadDoIt := nil. name := nm. file := fl. ^ file == nil! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 7/2/2012 18:49'! repositoryDescriptions ^ self repositorySpecs collect: [ :repoSpec | repoSpec description ]! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! isPackageLoaded: aLoader ^(self workingCopyNameFor: aLoader) ~~ nil! ! !MetacelloPackageSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! requires: anObject constructor: aVersionConstructor aVersionConstructor requiresForPackage: anObject! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! goferCommitPackage: commitMessage "uses gofer to do commit ... non-interactive" | latestFile pkgSpec | ^(file notNil and: [ self name = self file ]) ifTrue: [ latestFile := self loader latestPackage: self name fromRepository: self repositorySpecs. pkgSpec := self copy. pkgSpec file: latestFile. pkgSpec goferCommitPackage: commitMessage ] ifFalse: [ self loader goferCommitPackageUsing: self repositorySpecs commitMessage: commitMessage ] ! ! !MetacelloPackageSpec methodsFor: 'visiting' stamp: 'dkh 6/8/2012 14:04:22'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock packageBlock value: self! ! !MetacelloPackageSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! includes: anObject constructor: aVersionConstructor aVersionConstructor includesForPackage: anObject! ! !MetacelloPackageSpec methodsFor: 'gofer' stamp: 'dkh 6/8/2012 14:04:22'! ancestors ^self goferPackage ancestors! ! !MetacelloPackageSpec methodsFor: 'visiting' stamp: 'dkh 6/8/2012 14:04:22'! visitingWithPackages: packages packages at: self name put: self! ! !MetacelloPackageSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! compareRelativeCurrentVersion: anOperator targetVersionStatus: statusIgnored using: anMCLoader ^self compareCurrentVersion: anOperator targetVersionStatus: statusIgnored using: anMCLoader ! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! explicitLoadUsing: mcLoader | wc fetchingSpecLoader | ((wc := self workingCopy) ~~ nil and: [ wc needsSaving ]) ifTrue: [ (MetacelloSkipDirtyPackageLoad signal: self) ifTrue: [ Transcript cr; show: 'Skipping load of modified package: ', self file. ^self] ifFalse: [Transcript cr; show: 'Load over modified package: ', self file] ]. "fetch and explicitly load it" fetchingSpecLoader := mcLoader fetchingSpecLoader. fetchingSpecLoader explicitLoadPackageSpecs: (Array with: self) repositories: (fetchingSpecLoader repositoriesFrom: self repositorySpecs). ! ! !MetacelloPackageSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! repositories: aBlock constructor: aVersionConstructor aVersionConstructor repositoriesForPackage: aBlock! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! savePackage "Interactive save ... prompted for commit message and package name unless MCVersionNameAndMessageRequest handled" | latestFile pkgSpec | ^(file notNil and: [ self name = self file ]) ifTrue: [ latestFile := self loader latestPackage: self name fromRepository: self repositorySpecs. pkgSpec := self copy. pkgSpec file: latestFile. pkgSpec savePackage ] ifFalse: [ self loader savePackageUsing: self repositorySpecs ] ! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! repository: aStringOrMetacelloRepositorySpec self repositories repository: aStringOrMetacelloRepositorySpec! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! info "test compatibility method" ^self! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! copySpecTo: aRepositorySpec "Copy current mcz file to the repository named in aRepositorySpec" self loader copySpec: self from: self repositorySpecs to: aRepositorySpec createRepository! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 6/8/2012 14:04:22'! updatePackageSpec: updatedSpecs force: force using: anMCLoader "Add pkg copy to updatedSpecs if the file in current image is different from the receiver's file" | viName | (force not and: [ self getFile == nil ]) ifTrue: [ ^ self ]. "no file explicitly specified in this spec" (viName := self workingCopyNameFor: anMCLoader) == nil ifTrue: [ ^ self ]. "no working copy" viName ~= self file ifTrue: [ | spec | spec := self copy. spec file: viName. updatedSpecs at: spec name put: spec ] ifFalse: [ updatedSpecs at: self name put: #uptodate ]! ! !MetacelloPackageSpec methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! includesForPackageOrdering ^self includes! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! getPreLoadDoIt ^preLoadDoIt! ! !MetacelloPackageSpec methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! currentPackageLoaded: loadedBlock notLoaded: notLoadedBlock using: anMCLoader "Use currentVersionInfoFor: because it involves the loader and returns versionInfo for a planned load (atomic loaders) or currently loaded package" | wcName vis | vis := anMCLoader ancestorsFor: self. vis notNil ifTrue: [ self getFile == nil ifTrue: [ ^ loadedBlock value: #() value: self file ]. ^ loadedBlock value: vis value: self file ]. ^ notLoadedBlock value! ! !MetacelloPackageSpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! configMethodOn: aStream indent: indent | hasRepositories hasPreLoadDoIt hasPostLoadDoIt hasRequiresOrIncludesOrAnswers hasFile | hasFile := file ~~ nil. hasRepositories := self repositorySpecs size > 0. hasPreLoadDoIt := self getPreLoadDoIt ~~ nil. hasPostLoadDoIt := self getPostLoadDoIt ~~ nil. hasRequiresOrIncludesOrAnswers := (self requires isEmpty and: [ self includes isEmpty and: [self answers isEmpty ]]) not. aStream tab: indent; nextPutAll: 'spec '. hasFile | hasRepositories | hasPreLoadDoIt | hasPostLoadDoIt | hasRequiresOrIncludesOrAnswers ifTrue: [ aStream cr; tab: indent + 1; nextPutAll: 'name: ', self name printString; nextPut: $;. self configMethodBodyOn: aStream hasName: true indent: indent + 1 ] ifFalse: [ aStream nextPutAll: 'name: ', self name printString ]! ! !MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! repositories: anObject repositories := anObject! ! !MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! repositoryError ^ repositoryError! ! !MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! repositories ^ repositories! ! !MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! description "Return a textual description of the exception." ^ 'Could not resolve: ' , packageSpec name , ' [' , packageSpec file , ']' , ' in' , self repositoryString , (repositoryError == nil ifTrue: [ '' ] ifFalse: [ "report repository error to user here, since failure here is likely to be due to earlier repository error" ' ERROR: ' , repositoryError description printString ])! ! !MetacelloPackageSpecResolutionError methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! repositoryString | repositoryString | repositoryString := ''. self repositories do: [ :repo | repositoryString := repositoryString , ' ' , repo description ]. ^ repositoryString! ! !MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! packageSpec ^ packageSpec! ! !MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! packageSpec: anObject packageSpec := anObject! ! !MetacelloPackageSpecResolutionError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! repositoryError: anObject repositoryError := anObject! ! !MetacelloPackageSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testPackageMergeSpec | packageA packageB package repository | packageA := self packageSpec name: 'Package'; name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; repository: 'http://example.com/repository' username: 'dkh' password: 'password'; repository: '/opt/gemstone/repository'; yourself. packageB := self packageSpec name: 'Package'; requires: 'AndAnotherPackage'; includes: 'AndIncludedPackage'; answers: #(#('xpostload' 'xpostload answer')); file: 'Package-dkh.2'; repository: 'http://example.com/repository' username: 'DaleHenrichs' password: 'secret'; repository: '/opt/gemstone/repo'; yourself. package := packageA mergeSpec: packageB. self assert: package name = 'Package'. self assert: package requires = #('AnotherPackage' 'AndAnotherPackage'). self assert: package includes = #('IncludedPackage' 'AndIncludedPackage'). self assert: package answers = #(#('preload' 'preload answer') #('postload' 'postload answer') #('xpostload' 'xpostload answer')). self assert: package file = 'Package-dkh.2'. self assert: package preLoadDoIt value == #'preLoadDoIt'. self assert: package postLoadDoIt value == #'postLoadDoIt'. repository := package repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'directory'. repository := package repositories map at: '/opt/gemstone/repo' ifAbsent: [ self assert: false ]. self assert: repository type = 'directory'. repository := package repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'http'. self assert: repository username = 'DaleHenrichs'. self assert: repository password = 'secret'! ! !MetacelloPackageSpecTestCase methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectClass ^ MetacelloMCProject! ! !MetacelloPackageSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testPackageSpec | package repository | package := self packageSpec name: 'Package'; requires: 'AnotherPackage'; includes: 'IncludedPackage'; answers: #(#('preload' 'preload answer') #('postload' 'postload answer')); file: 'Package-dkh.1'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; repository: 'http://example.com/repository' username: 'dkh' password: 'password'; repository: '/opt/gemstone/repository'; yourself. self assert: package name = 'Package'. self assert: package requires = #('AnotherPackage'). self assert: package includes = #('IncludedPackage'). self assert: package answers = #(#('preload' 'preload answer') #('postload' 'postload answer')). self assert: package file = 'Package-dkh.1'. self assert: package preLoadDoIt value == #'preLoadDoIt'. self assert: package postLoadDoIt value == #'postLoadDoIt'. repository := package repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'directory'. repository := package repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository type = 'http'. self assert: repository username = 'dkh'. self assert: repository password = 'password'! ! !MetacelloPackagesSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! copy: specNamed to: spec self addMember: (self copyMember name: spec name; sourceName: specNamed; spec: spec; yourself) ! ! !MetacelloPackagesSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! add: aSpec aSpec addToMetacelloPackages: self! ! !MetacelloPackagesSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! merge: aSpec aSpec mergeIntoMetacelloPackages: self! ! !MetacelloPackagesSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! packageNamed: aString ifAbsent: aBlock ^self map at: aString ifAbsent: aBlock! ! !MetacelloPackagesSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! applyIncludesTo: orderedSpecs for: pkgSpec firstTime: firstTime | movedSpecs baseIndex includedSpec result | movedSpecs := Set new. baseIndex := orderedSpecs indexOf: pkgSpec. pkgSpec includesForPackageOrdering do: [:includedSpecName | includedSpec := orderedSpecs detect: [:spec | spec name = includedSpecName ] ifNone: []. (self slideIn: orderedSpecs spec: includedSpec baseIndex: baseIndex seen: IdentitySet new firstTime: firstTime) ifTrue: [ movedSpecs add: includedSpec name ]]. ^ movedSpecs! ! !MetacelloPackagesSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! remove: aSpec aSpec removeFromMetacelloPackages: self! ! !MetacelloPackagesSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! sortPackageSpecs: orderedSpecs for: packageSpec | packageIndex moved movePackage targetPackage targetIndex targetPackages | packageIndex := orderedSpecs indexOf: packageSpec. moved := movePackage := false. targetPackages := packageSpec requires. targetPackages do: [:targetPackageName | targetPackage := orderedSpecs detect: [:each | each name = targetPackageName ] ifNone: []. targetIndex := orderedSpecs indexOf: targetPackage. movePackage := movePackage or: [ packageIndex <= targetIndex ]]. movePackage ifTrue: [ moved := true. orderedSpecs remove: packageSpec ifAbsent: [ ^self error: 'unexpected error removing package' ]. targetIndex := 0. targetPackages do: [:targetPackageName | (targetPackage := orderedSpecs detect: [:each | each name = targetPackageName ] ifNone: []) ~~ nil ifTrue: [ targetIndex := targetIndex max: (orderedSpecs indexOf: targetPackage) ]]. targetIndex == 0 ifTrue: [ orderedSpecs add: packageSpec beforeIndex: packageIndex ] ifFalse: [ orderedSpecs add: packageSpec afterIndex: targetIndex ]]. ^moved! ! !MetacelloPackagesSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodOn: aStream indent: indent | packageSpecs | packageSpecs := self map values. packageSpecs size = 0 ifTrue: [ ^aStream nextPutAll: 'spec add: []' ]. packageSpecs size = 1 ifTrue: [ aStream tab: indent; nextPutAll: 'spec add: ['; cr. packageSpecs first configMethodOn: aStream indent: indent + 1. aStream nextPut: $]; cr ] ifFalse: [ aStream tab: indent; nextPutAll: 'spec'. 1 to: packageSpecs size do: [:index | | packageSpec | packageSpec := packageSpecs at: index. aStream tab: indent + 1; nextPutAll: 'add: ['; cr. packageSpec configMethodOn: aStream indent: indent + 2. aStream nextPut: $]. index < packageSpecs size ifTrue: [ aStream nextPut: $; ]. aStream cr ]]! ! !MetacelloPackagesSpec methodsFor: 'accessing' stamp: 'dkh 9/6/2012 03:05'! packageSpecsInLoadOrder | orderedSpecs moved lastMovedSpecs count terminationLimit map specsWithIncludes firstTime | "specification order is the default order" map := self map. orderedSpecs := OrderedCollection new. self list do: [ :member | | spec | spec := map at: member name ifAbsent: [ ]. (spec == nil or: [ orderedSpecs includes: spec ]) ifFalse: [ orderedSpecs add: spec ] ]. orderedSpecs isEmpty ifTrue: [ ^ orderedSpecs ]. moved := true. count := 0. terminationLimit := orderedSpecs size * 2. [ moved ] whileTrue: [ count := count + 1. count > terminationLimit ifTrue: [ "Cheap termination hack - an APPARENT loop" self error: 'Apparent loop in before/after dependency definitions' ]. moved := false. orderedSpecs do: [ :packageSpec | moved := moved or: [ self sortPackageSpecs: orderedSpecs for: packageSpec ] ] ]. lastMovedSpecs := Set new. moved := true. count := 0. specsWithIncludes := orderedSpecs select: [ :pkgSpec | pkgSpec includesForPackageOrdering isEmpty not ]. firstTime := true. [ moved ] whileTrue: [ | result | count := count + 1. "count > terminationLimit" count > 14 ifTrue: [ "Cheap termination hack - an APPARENT loop" self error: 'Apparent loop in before/after dependency definitions' ]. moved := false. result := Set new. specsWithIncludes do: [ :packageSpec | result addAll: (self applyIncludesTo: orderedSpecs for: packageSpec firstTime: firstTime) ]. result size = lastMovedSpecs size ifTrue: [ result do: [ :name | (lastMovedSpecs includes: name) ifFalse: [ moved := true ] ] ] ifFalse: [ moved := true ]. lastMovedSpecs := result. firstTime := false ]. ^ orderedSpecs! ! !MetacelloPackagesSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! slideIn: orderedSpecs spec: targetSpec baseIndex: baseIndex seen: seen firstTime: firstTime | targetIndex requires targetRequires targetRequiresIndexes minIndex baseSpec required | (seen includes: targetSpec) ifTrue: [ ^false ]. targetIndex := orderedSpecs indexOf: targetSpec. baseIndex >= targetIndex ifTrue: [ ^false ]. required := false. baseSpec := orderedSpecs at: baseIndex. baseIndex + 1 to: targetIndex - 1 do: [:index | | spec | spec := orderedSpecs at: index. (spec requires includes: baseSpec name) ifTrue: [ required := true ]]. firstTime ifFalse: [ required ifFalse: [ ^false ]]. requires := targetSpec requires. targetRequires := orderedSpecs select: [:spec | requires includes: spec name]. targetRequiresIndexes := targetRequires collect: [:spec | orderedSpecs indexOf: spec]. targetRequiresIndexes add: baseIndex. minIndex := targetRequiresIndexes detectMax: [:each | each]. minIndex + 1 < targetIndex ifTrue: [ orderedSpecs remove: targetSpec. orderedSpecs add: targetSpec afterIndex: minIndex. seen add: targetSpec ] ifFalse: [ ^self slideIn: orderedSpecs spec: (orderedSpecs at: minIndex) baseIndex: 1 seen: seen firstTime: firstTime]. ^true ! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testMergeGroupB "used by MetacelloAbstractVersionConstructor>>group:with:" | packages group | packages := self packagesSpec. packages add: (self groupSpec name: 'Platform'; includes: 'Core'; yourself). packages merge: {(self groupSpec name: 'Platform'; includes: 'Tests'; yourself)}. group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. self assert: (group includes includes: 'Core'). self assert: (group includes includes: 'Tests')! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testAddProjectA "used by MetacelloAbstractVersionConstructor>>project:overrides:" | packages project projectReferenceSpec | packages := self packagesSpec. packages add: (self projectSpec name: 'Project'; className: 'ConfigurationOfProjectA'; versionString: #'stable'; loads: #('MyPackage' 'MyTests'); preLoadDoIt: #'preLoadDoItB'; postLoadDoIt: #'postLoadDoItB'; yourself). packages add: (self projectSpec name: 'Project'; className: 'ConfigurationOfProject'; versionString: '1.0'; operator: #'<'; loads: #('MyPackage'); preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ]. self assert: projectReferenceSpec projectName = 'Project'. self assert: projectReferenceSpec versionString = '1.0'. self should: [ projectReferenceSpec includes: #() ] raise: Error. self should: [ projectReferenceSpec requires: #() ] raise: Error. self should: [ projectReferenceSpec answers: #() ] raise: Error. projectReferenceSpec projectDo: [ :prjct | self assert: projectReferenceSpec == prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]. project := projectReferenceSpec referencedSpec. self assert: project name = 'Project'. self assert: project className = 'ConfigurationOfProject'. self assert: project versionString = '1.0'. self assert: project operator == #'<'. self assert: project loads = #('MyPackage'). self assert: project preLoadDoIt value == #'preLoadDoIt'. self assert: project postLoadDoIt value == #'postLoadDoIt'. project projectDo: [ :prjct | self assert: project == prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testRemoveProjectA "used by MetacelloAbstractVersionConstructor>>removeProject:" | packages project projectReferenceSpec removed | packages := self packagesSpec. packages add: (self projectSpec name: 'Project'; className: 'ConfigurationOfProject'; versionString: '1.0'; operator: #'<'; loads: #('MyPackage'); preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ]. project := projectReferenceSpec referencedSpec. self assert: project name = 'Project'. self assert: project className = 'ConfigurationOfProject'. self assert: project versionString = '1.0'. self assert: project operator == #'<'. self assert: project loads = #('MyPackage'). self assert: project preLoadDoIt value == #'preLoadDoIt'. self assert: project postLoadDoIt value == #'postLoadDoIt'. packages remove: (self projectReferenceSpec name: 'Project'; yourself). removed := false. packages packageNamed: 'Project' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testAddGroupA "used by MetacelloAbstractVersionConstructor>>group:overrides:" | packages group | packages := self packagesSpec. packages add: (self groupSpec name: 'Platform'; includes: 'Core'; yourself). packages add: (self groupSpec name: 'Platform'; includes: 'Tests'; yourself). group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. self deny: (group includes includes: 'Core'). self assert: (group includes includes: 'Tests')! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testRemoveGroupC "used by MetacelloAbstractVersionConstructor>>removeGroup:" | packages group removed | packages := self packagesSpec. packages add: {(self groupSpec name: 'Platform'; includes: 'Core'; yourself). (self groupSpec name: 'Base'; includes: 'Base'; yourself). (self groupSpec name: 'Tests'; includes: 'Tests'; yourself)}. packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. packages packageNamed: 'Base' ifAbsent: [ self assert: false ]. packages packageNamed: 'Tests' ifAbsent: [ self assert: false ]. packages remove: 'Tests'. packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. packages packageNamed: 'Base' ifAbsent: [ self assert: false ]. removed := false. packages packageNamed: 'Tests' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testMergeGroupA "used by MetacelloAbstractVersionConstructor>>group:with:" | packages group | packages := self packagesSpec. packages add: (self groupSpec name: 'Platform'; includes: 'Core'; yourself). packages merge: (self groupSpec name: 'Platform'; includes: 'Tests'; yourself). group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. self assert: (group includes includes: 'Core'). self assert: (group includes includes: 'Tests')! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testMergeProjectB "used by MetacelloAbstractVersionConstructor>>project:with:" | packages project projectReferenceSpec referenceSpec | packages := self packagesSpec. project := self projectSpec name: 'Project'; className: 'ConfigurationOfProjectA'; versionString: #'stable'; loads: #('MyPackage' 'MyTests'); preLoadDoIt: #'preLoadDoItB'; postLoadDoIt: #'postLoadDoItB'; yourself. referenceSpec := self project projectReferenceSpec name: project name; projectReference: project; yourself. packages add: referenceSpec. project := self projectSpec name: 'Project'; className: 'ConfigurationOfProject'; versionString: '1.0'; operator: #'<'; loads: #('MyPackage'); preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself. referenceSpec := self project projectReferenceSpec name: project name; projectReference: project; yourself. packages merge: {referenceSpec}. projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ]. project := projectReferenceSpec referencedSpec. self assert: project name = 'Project'. self assert: project className = 'ConfigurationOfProject'. self assert: project versionString = '1.0'. self assert: project operator == #'<'. self assert: project loads = #('MyPackage'). self assert: project preLoadDoIt value == #'preLoadDoIt'. self assert: project postLoadDoIt value == #'postLoadDoIt'. project projectDo: [ :prjct | self assert: project == prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testRemoveProjectB "used by MetacelloAbstractVersionConstructor>>removeProject:" | packages project projectReferenceSpec removed | packages := self packagesSpec. packages add: (self projectSpec name: 'Project'; className: 'ConfigurationOfProject'; versionString: '1.0'; operator: #'<'; loads: #('MyPackage'); preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself). projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ]. project := projectReferenceSpec referencedSpec. self assert: project name = 'Project'. self assert: project className = 'ConfigurationOfProject'. self assert: project versionString = '1.0'. self assert: project operator == #'<'. self assert: project loads = #('MyPackage'). self assert: project preLoadDoIt value == #'preLoadDoIt'. self assert: project postLoadDoIt value == #'postLoadDoIt'. packages remove: {(self projectReferenceSpec name: 'Project'; yourself)}. removed := false. packages packageNamed: 'Project' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testAddGroupB "used by MetacelloAbstractVersionConstructor>>group:overrides:" | packages group | packages := self packagesSpec. packages add: {(self groupSpec name: 'Platform'; includes: 'Core'; yourself). (self groupSpec name: 'Platform'; includes: 'Tests'; yourself)}. group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. self deny: (group includes includes: 'Core'). self assert: (group includes includes: 'Tests')! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testCopyToGroup "not currently used by MetacelloAbstractVersionConstructor" | packages group | packages := self packagesSpec. packages add: (self groupSpec name: 'Platform'; includes: 'Core'; yourself). packages merge: (self groupSpec name: 'Platform'; includes: 'Tests'; yourself). group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. self assert: (group includes includes: 'Core'). self assert: (group includes includes: 'Tests'). group := self groupSpec name: 'PlatformCopy'; includes: 'Copy'; yourself. packages copy: 'Platform' to: group. group := packages packageNamed: 'PlatformCopy' ifAbsent: [ self assert: false ]. self assert: (group includes includes: 'Core'). self assert: (group includes includes: 'Copy'). self assert: (group includes includes: 'Tests')! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testRemoveGroupA "used by MetacelloAbstractVersionConstructor>>removeGroup:" | packages group removed | packages := self packagesSpec. packages add: (self groupSpec name: 'Platform'; includes: 'Core'; yourself). packages merge: (self groupSpec name: 'Platform'; includes: 'Tests'; yourself). group := packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. self assert: (group includes includes: 'Core'). self assert: (group includes includes: 'Tests'). packages remove: (self groupSpec name: 'Platform'; includes: 'Core'; yourself). removed := false. packages packageNamed: 'Platform' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testCopyToProject "used by MetacelloAbstractVersionConstructor>>project:copyFrom:with:" | packages project referenceSpec | packages := self packagesSpec. packages add: (self projectSpec name: 'Project'; className: 'ConfigurationOfProjectA'; versionString: #'stable'; loads: #('MyPackage' 'MyTests'); preLoadDoIt: #'preLoadDoItB'; postLoadDoIt: #'postLoadDoItB'; yourself). project := self projectSpec name: 'ProjectCopy'; yourself. referenceSpec := self project projectReferenceSpec name: 'ProjectCopy'; projectReference: project; yourself. packages copy: 'Project' to: referenceSpec. project := (packages packageNamed: 'ProjectCopy' ifAbsent: [ self assert: false ]) referencedSpec. self assert: project name = 'ProjectCopy'. self assert: project className = 'ConfigurationOfProjectA'. self assert: project versionString = #'stable'. self assert: project operator == #'>='. self assert: project loads = #('MyPackage' 'MyTests'). self assert: project preLoadDoIt value == #'preLoadDoItB'. self assert: project postLoadDoIt value == #'postLoadDoItB'! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testMergeProjectA "used by MetacelloAbstractVersionConstructor>>project:with:" | packages project projectReferenceSpec referenceSpec | packages := self packagesSpec. project := self projectSpec name: 'Project'; className: 'ConfigurationOfProjectA'; versionString: #'stable'; loads: #('MyPackage' 'MyTests'); preLoadDoIt: #'preLoadDoItB'; postLoadDoIt: #'postLoadDoItB'; yourself. referenceSpec := self project projectReferenceSpec name: project name; projectReference: project; yourself. packages add: referenceSpec. project := self projectSpec name: 'Project'; className: 'ConfigurationOfProject'; versionString: '1.0'; operator: #'<'; loads: #('MyPackage'); preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself. referenceSpec := self project projectReferenceSpec name: project name; projectReference: project; yourself. packages merge: referenceSpec. projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ]. project := projectReferenceSpec referencedSpec. self assert: project name = 'Project'. self assert: project className = 'ConfigurationOfProject'. self assert: project versionString = '1.0'. self assert: project operator == #'<'. self assert: project loads = #('MyPackage'). self assert: project preLoadDoIt value == #'preLoadDoIt'. self assert: project postLoadDoIt value == #'postLoadDoIt'. project projectDo: [ :prjct | self assert: project == prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testRemoveGroupB "used by MetacelloAbstractVersionConstructor>>removeGroup:" | packages group removed | packages := self packagesSpec. packages add: {(self groupSpec name: 'Platform'; includes: 'Core'; yourself). (self groupSpec name: 'Base'; includes: 'Base'; yourself). (self groupSpec name: 'Tests'; includes: 'Tests'; yourself)}. packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. packages packageNamed: 'Base' ifAbsent: [ self assert: false ]. packages packageNamed: 'Tests' ifAbsent: [ self assert: false ]. packages remove: {'Base'. 'Tests'}. packages packageNamed: 'Platform' ifAbsent: [ self assert: false ]. removed := false. packages packageNamed: 'Base' ifAbsent: [ removed := true ]. self assert: removed. removed := false. packages packageNamed: 'Tests' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloPackagesSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testAddProjectB "used by MetacelloAbstractVersionConstructor>>project:overrides:" | packages project projectReferenceSpec | packages := self packagesSpec. packages add: {(self projectSpec name: 'Project'; className: 'ConfigurationOfProjectA'; versionString: #'stable'; loads: #('MyPackage' 'MyTests'); preLoadDoIt: #'preLoadDoItB'; postLoadDoIt: #'postLoadDoItB'; yourself). (self projectSpec name: 'Project'; className: 'ConfigurationOfProject'; versionString: '1.0'; operator: #'<'; loads: #('MyPackage'); preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself)}. projectReferenceSpec := packages packageNamed: 'Project' ifAbsent: [ self assert: false ]. self assert: projectReferenceSpec projectName = 'Project'. self assert: projectReferenceSpec versionString = '1.0'. self should: [ projectReferenceSpec includes: #() ] raise: Error. self should: [ projectReferenceSpec requires: #() ] raise: Error. self should: [ projectReferenceSpec answers: #() ] raise: Error. projectReferenceSpec projectDo: [ :prjct | self assert: projectReferenceSpec == prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]. project := projectReferenceSpec referencedSpec. self assert: project name = 'Project'. self assert: project className = 'ConfigurationOfProject'. self assert: project versionString = '1.0'. self assert: project operator == #'<'. self assert: project loads = #('MyPackage'). self assert: project preLoadDoIt value == #'preLoadDoIt'. self assert: project postLoadDoIt value == #'postLoadDoIt'. project projectDo: [ :prjct | self assert: project == prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]! ! !MetacelloPharo30Platform commentStamp: ''! Class used to abstract specific code for the Pharo 3.0 platform. ! !MetacelloPharo30Platform methodsFor: 'monticello' stamp: 'ChristopheDemarey 9/12/2013 10:28'! newVersionForWorkingCopy: aWorkingCopy ^aWorkingCopy newVersionIn: aWorkingCopy repositoryGroup! ! !MetacelloPharo30Platform methodsFor: 'system' stamp: 'ChristopheDemarey 5/27/2013 16:18'! suspendSystemUpdateEventsDuring: aBlock "Wraps call to the system evetn manager to tell it that we want to suspend events during execution of aBlock" "From Pharo2, we cannot suspend system events since missing events brak the image (rpackage at least should be notified." "SystemAnnouncer uniqueInstance suspendAllWhile: aBlock" ^ aBlock value ! ! !MetacelloPharo30Platform methodsFor: 'pharo 2.0 compat' stamp: 'dkh 5/8/2013 09:40'! packageInfoFor: aMCWorkingCopy "MCPackageManager>>packageInfo is deprecated in Pharo2.0" ^ aMCWorkingCopy packageSet! ! !MetacelloPharo30Platform methodsFor: 'github support' stamp: 'ChristopheDemarey 9/19/2013 11:02'! downloadFile: url to: outputFileName "download a Zip file from into " outputFileName asFileReference ensureDelete. ZnClient new url: url; downloadTo: outputFileName. ^ ZipArchive new readFrom: outputFileName asFileReference! ! !MetacelloPharo30Platform methodsFor: 'file system' stamp: 'ChristopheDemarey 4/29/2013 15:14'! directoryFromPath: adirectoryPath relativeTo: anotherDirectoryPath "Get a handle on the following path: anotherDirectoryPath/adirectoryPath" ^ anotherDirectoryPath resolveString: adirectoryPath! ! !MetacelloPharo30Platform methodsFor: 'file system' stamp: 'ChristopheDemarey 4/29/2013 13:16'! fileHandleOn: aPath "Get an handle on a file." ^ aPath asFileReference! ! !MetacelloPharo30Platform methodsFor: 'github support' stamp: 'ChristopheDemarey 9/19/2013 10:35'! extractRepositoryFrom: zipFile to: directory "unzip into " ZipArchive new readFrom: zipFile; extractAllTo: directory asFileReference.! ! !MetacelloPharo30Platform methodsFor: 'file system' stamp: 'ChristopheDemarey 4/29/2013 15:58'! fileDirectoryClass ^FileSystem! ! !MetacelloPharo30Platform methodsFor: 'file system' stamp: 'ChristopheDemarey 5/29/2013 18:16'! parentDirectoryOf: aFileHandler "Get the parent directory of this file." ^ aFileHandler parent! ! !MetacelloPharo30Platform methodsFor: 'file system' stamp: 'ChristopheDemarey 5/27/2013 17:43'! recursiveDelete: aDirectory "delete this directory and all children of it" ^ aDirectory deleteAll! ! !MetacelloPharo30Platform methodsFor: 'utilities' stamp: 'ChristopheDemarey 5/31/2013 13:02'! string: aString includesSubstring: aSubstring "abstract String>>includesSubstring: to have the same message on all supported platforms." ^aString includesSubstring: aSubstring! ! !MetacelloPharo30Platform methodsFor: 'file system' stamp: 'ChristopheDemarey 4/29/2013 14:17'! defaultDirectory "Get the image default directory" ^FileLocator imageDirectory asFileReference! ! !MetacelloPharo30Platform methodsFor: 'file system' stamp: 'ChristopheDemarey 5/14/2013 17:44'! fileFromPath: aFileName relativeTo: aDirectoryPath "Get a handle on the following path: anotherDirectoryPath/aFileName" ^ aDirectoryPath / aFileName! ! !MetacelloPharo30Platform methodsFor: 'file system' stamp: 'ChristopheDemarey 7/22/2013 11:20'! ensureDirectoryExists: aDirectoryHandle "Ensure the directory exists." ^ aDirectoryHandle ensureCreateDirectory ; yourself! ! !MetacelloPharo30Platform methodsFor: 'file system' stamp: 'ChristopheDemarey 5/14/2013 17:55'! readStreamOn: aFileHandle do: aBlock "Get a read stream on the file handle and execute some actions on it." ^ aFileHandle readStreamDo: aBlock! ! !MetacelloPharo30Platform class methodsFor: 'initialize-release' stamp: 'ChristopheDemarey 4/29/2013 14:22'! initialize self select ! ! !MetacelloPharoCommonPlatform commentStamp: ''! MetacelloPharoPlatform contains all Pharo specific code to load Metacello.! !MetacelloPharoCommonPlatform methodsFor: 'attributes' stamp: 'ChristopheDemarey 4/30/2013 09:24'! defaultPlatformAttributes | attributes versionString | ((Smalltalk respondsTo: #image) and: [ Smalltalk image respondsTo: #metacelloPlatformAttributes ]) ifTrue: [ ^ Smalltalk image metacelloPlatformAttributes ]. attributes := OrderedCollection with: #squeakCommon with: #pharo. Smalltalk at: #SystemVersion ifPresent: [ :cl | versionString := cl current version. (((versionString beginsWith: 'Pharo-1') or: [ versionString beginsWith: 'PharoCore1' ]) or: [ versionString beginsWith: 'Pharo1' ]) ifTrue: [ attributes add: #'pharo1.x'. ((versionString beginsWith: 'Pharo-1.0') or: [ versionString beginsWith: 'PharoCore1.0' ]) ifTrue: [ attributes add: #'pharo1.0.x' ] ifFalse: [ ((versionString beginsWith: 'Pharo-1.1') or: [ versionString beginsWith: 'Pharo1.1' ]) ifTrue: [ attributes add: #'pharo1.1.x' ] ifFalse: [ ((versionString beginsWith: 'Pharo-1.2') or: [ versionString beginsWith: 'Pharo1.2' ]) ifTrue: [ attributes add: #'pharo1.2.x' ] ifFalse: [ (versionString beginsWith: 'Pharo1.3') ifTrue: [ attributes add: #'pharo1.3.x' ] ] ] ] ] ]. ^ attributes! ! !MetacelloPharoCommonPlatform methodsFor: 'utilities' stamp: 'ChristopheDemarey 4/30/2013 09:23'! authorName ^Author fullName! ! !MetacelloPharoCommonPlatform methodsFor: 'notification' stamp: 'ChristopheDemarey 4/30/2013 09:24'! collection: aCollection do: aBlock displaying: aString self bypassProgressBars ifTrue: [ ^super collection: aCollection do: aBlock displaying: aString ]. aCollection do: aBlock displayingProgress: aString! ! !MetacelloPharoCommonPlatform methodsFor: 'repository creation' stamp: 'ChristopheDemarey 4/30/2013 09:24'! createRepository: aRepositorySpec | type | type := aRepositorySpec type. type = 'ftp' ifTrue: [ | description headerSize index host directory | description := aRepositorySpec description. headerSize := 'ftp://' size. index := description indexOf: $/ startingAt: headerSize + 1. host := description copyFrom: headerSize + 1 to: index - 1. directory := description copyFrom: index + 1 to: description size. ^ MCFtpRepository host: host directory: directory user: aRepositorySpec username password: aRepositorySpec password]. ^ super createRepository: aRepositorySpec! ! !MetacelloPharoCommonPlatform methodsFor: 'github support' stamp: 'CamilloBruni 10/15/2013 21:35'! downloadFile: url to: outputFileName "download from into " | in out err proc archive zipfile | in := (' -L ' , url) readStream. out := FileStream forceNewFileNamed: outputFileName. err := FileStream forceNewFileNamed: '/tmp/curl.err'. proc := #OSProcess asClass thisOSProcess forkJob: '/usr/bin/curl' arguments: {'-L'. url} environment: nil descriptors: (Array with: nil with: out with: err). proc ifNil: [ #OSProcess asClass noAccessorAvailable ]. [ proc isRunning ] whileTrue: [ (Delay forMilliseconds: 100) wait ]. out close. err close. archive := ZipArchive new. zipfile := #FileDirectory asClass on: outputFileName. zipfile containingDirectory readOnlyFileNamed: zipfile localName do: [ :fileStream | archive readFrom: fileStream ]. ^ archive! ! !MetacelloPharoCommonPlatform methodsFor: 'utilities' stamp: 'ChristopheDemarey 4/30/2013 09:25'! timestamp ^Date today mmddyyyy, ' ', ((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! ! !MetacelloPharoCommonPlatform methodsFor: 'reflection' stamp: 'CamilleTeruel 11/21/2013 12:43'! copyClass: oldClass as: newName inCategory: newCategoryName | copysName class newDefinition | copysName := newName asSymbol. copysName = oldClass name ifTrue: [ ^ oldClass ]. (Smalltalk includesKey: copysName) ifTrue: [ ^ self error: copysName , ' already exists' ]. newDefinition := oldClass definition copyReplaceAll: '#' , oldClass name asString with: '#' , copysName asString printString. newDefinition := newDefinition copyReplaceAll: 'category: ' , (SystemOrganization categoryOfElement: oldClass name) asString printString with: 'category: ' , newCategoryName printString. class := self class compiler evaluate: newDefinition logged: true. class class instanceVariableNames: oldClass class instanceVariablesString. class copyAllCategoriesFrom: oldClass. class class copyAllCategoriesFrom: oldClass class. class category: newCategoryName. ^ class! ! !MetacelloPharoCommonPlatform methodsFor: 'github support' stamp: 'MarcusDenker 10/16/2013 10:39'! extractRepositoryFrom: zipFile to: directory "unzip into " | out err proc errorMessage | out := FileStream forceNewFileNamed: '/tmp/zip.out'. err := FileStream forceNewFileNamed: '/tmp/zip.err'. errorMessage := ''. [ proc := #OSProcess asClass thisOSProcess forkJob: '/usr/bin/unzip' arguments: {'-u'. zipFile. '-d'. directory} environment: nil descriptors: (Array with: nil with: out with: err). proc ifNil: [ self noAccessorAvailable ]. [ proc isRunning ] whileTrue: [ (Delay forMilliseconds: 100) wait ] ] ensure: [ out close. err close ]. FileStream fileNamed: '/tmp/zip.err' do: [ :fileStream | (errorMessage := fileStream contentsOfEntireFile) notEmpty ifTrue: [ self error: 'unzip failure: ' , errorMessage printString ] ]! ! !MetacelloPharoCommonPlatform methodsFor: 'utilities' stamp: 'ChristopheDemarey 4/30/2013 09:23'! authorName: aString Author fullName: aString! ! !MetacelloPharoCommonPlatform methodsFor: 'repository creation' stamp: 'ChristopheDemarey 4/30/2013 09:25'! extractTypeFromDescription: description (description beginsWith: 'ftp://') ifTrue: [ ^'ftp' ]. ^super extractTypeFromDescription: description! ! !MetacelloPharoPlatform methodsFor: 'attributes' stamp: 'dkh 9/8/2011 14:48'! defaultPlatformAttributes | attributes versionString | ((Smalltalk respondsTo: #image) and: [ Smalltalk image respondsTo: #metacelloPlatformAttributes ]) ifTrue: [ ^ Smalltalk image metacelloPlatformAttributes ]. attributes := OrderedCollection with: #squeakCommon with: #pharo. Smalltalk at: #SystemVersion ifPresent: [ :cl | versionString := cl current version. (((versionString beginsWith: 'Pharo-1') or: [ versionString beginsWith: 'PharoCore1' ]) or: [ versionString beginsWith: 'Pharo1' ]) ifTrue: [ attributes add: #'pharo1.x'. ((versionString beginsWith: 'Pharo-1.0') or: [ versionString beginsWith: 'PharoCore1.0' ]) ifTrue: [ attributes add: #'pharo1.0.x' ] ifFalse: [ ((versionString beginsWith: 'Pharo-1.1') or: [ versionString beginsWith: 'Pharo1.1' ]) ifTrue: [ attributes add: #'pharo1.1.x' ] ifFalse: [ ((versionString beginsWith: 'Pharo-1.2') or: [ versionString beginsWith: 'Pharo1.2' ]) ifTrue: [ attributes add: #'pharo1.2.x' ] ifFalse: [ (versionString beginsWith: 'Pharo1.3') ifTrue: [ attributes add: #'pharo1.3.x' ] ] ] ] ] ]. ^ attributes! ! !MetacelloPharoPlatform methodsFor: 'utilities' stamp: 'dkh 10/7/2009 10:54'! authorName ^Author fullName! ! !MetacelloPharoPlatform methodsFor: 'notification' stamp: 'DaleHenrichs 3/11/2010 19:28'! collection: aCollection do: aBlock displaying: aString self bypassProgressBars ifTrue: [ ^super collection: aCollection do: aBlock displaying: aString ]. aCollection do: aBlock displayingProgress: aString! ! !MetacelloPharoPlatform methodsFor: 'repository creation' stamp: 'dkh 12/7/2009 14:48'! createRepository: aRepositorySpec | type | type := aRepositorySpec type. type = 'ftp' ifTrue: [ | description headerSize index host directory | description := aRepositorySpec description. headerSize := 'ftp://' size. index := description indexOf: $/ startingAt: headerSize + 1. host := description copyFrom: headerSize + 1 to: index - 1. directory := description copyFrom: index + 1 to: description size. ^ MCFtpRepository host: host directory: directory user: aRepositorySpec username password: aRepositorySpec password]. ^ super createRepository: aRepositorySpec! ! !MetacelloPharoPlatform methodsFor: 'utilities' stamp: 'dkh 10/7/2009 11:01'! timestamp ^Date today mmddyyyy, ' ', ((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! ! !MetacelloPharoPlatform methodsFor: 'notification' stamp: 'EstebanLorenzano 7/19/2013 15:58'! do: aBlock displaying: aString self bypassProgressBars ifTrue: [ ^super do: aBlock displaying: aString ]. aString displayProgressFrom: 0 to: 2 during: [ :bar | bar current: 1. RPackageSet withCacheDo: [ aBlock value ]. bar current: 2 ]! ! !MetacelloPharoPlatform methodsFor: 'reflection' stamp: 'MarcusDenker 8/28/2013 10:46'! copyClass: oldClass as: newName inCategory: newCategoryName | copysName class newDefinition | copysName := newName asSymbol. copysName = oldClass name ifTrue: [ ^ oldClass ]. (Smalltalk includesKey: copysName) ifTrue: [ ^ self error: copysName , ' already exists' ]. newDefinition := oldClass definition copyReplaceAll: '#' , oldClass name asString with: '#' , copysName asString printString. newDefinition := newDefinition copyReplaceAll: 'category: ' , (SystemOrganization categoryOfElement: oldClass name) asString printString with: 'category: ' , newCategoryName printString. class := Smalltalk compiler source: newDefinition; logged: true; evaluate. class class instanceVariableNames: oldClass class instanceVariablesString. class copyAllCategoriesFrom: oldClass. class class copyAllCategoriesFrom: oldClass class. class category: newCategoryName. ^ class! ! !MetacelloPharoPlatform methodsFor: 'repository creation' stamp: 'dkh 12/7/2009 14:07'! extractTypeFromDescription: description (description beginsWith: 'ftp://') ifTrue: [ ^'ftp' ]. ^super extractTypeFromDescription: description! ! !MetacelloPharoPlatform methodsFor: 'utilities' stamp: 'DaleHenrichs 1/5/2011 16:59'! authorName: aString Author fullName: aString! ! !MetacelloPharoPlatform class methodsFor: 'initialize-release' stamp: 'dkh 8/20/2009 15:33'! initialize "implmented to force initialize on load" super initialize! ! !MetacelloPlatform methodsFor: 'monticello' stamp: 'dkh 09/23/2013 13:59'! newVersionForWorkingCopy: aWorkingCopy ^ aWorkingCopy newVersion! ! !MetacelloPlatform methodsFor: 'notification' stamp: 'dkh 6/5/2012 19:01:24'! collection: aCollection do: aBlock displaying: aString aCollection do: aBlock! ! !MetacelloPlatform methodsFor: 'repository creation' stamp: 'ChristopheDemarey 4/29/2013 13:22'! createRepository: aRepositorySpec | type | type := aRepositorySpec type. type = 'http' ifTrue: [ ^ MCHttpRepository location: aRepositorySpec description user: aRepositorySpec username password: aRepositorySpec password ]. type = 'directory' ifTrue: [ ^ MCDirectoryRepository new directory: (self fileHandleOn: aRepositorySpec description) ]. Smalltalk at: #'MCFileTreeRepository' ifPresent: [ :cl | type = 'filetree' ifTrue: [ | description headerSize | description := aRepositorySpec description. headerSize := 'filetree://' size. ^ cl new directory: (self fileHandleOn: (aRepositorySpec description copyFrom: headerSize + 1 to: description size)) ] ]. Smalltalk at: #'MCGitHubRepository' ifPresent: [ :cl | type = 'github' ifTrue: [ ^ cl location: aRepositorySpec description ] ]. type = 'dictionary' ifTrue: [ | description headerSize globalName | description := aRepositorySpec description. headerSize := 'dictionary://' size. globalName := (description copyFrom: headerSize + 1 to: description size) asSymbol. ^ Smalltalk at: globalName ifAbsent: [ Smalltalk at: globalName put: (MCDictionaryRepository new description: description; yourself) ] ]. ^ nil! ! !MetacelloPlatform methodsFor: 'github support' stamp: 'dkh 7/7/2012 07:37'! downloadFile: url to: outputFileName "download from into " self subclassResponsibility! ! !MetacelloPlatform methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! bypassGoferLoadUpdateCategories: anObject bypassGoferLoadUpdateCategories := anObject! ! !MetacelloPlatform methodsFor: 'file system' stamp: 'ChristopheDemarey 4/29/2013 15:37'! fileHandleOn: aPath "Get an handle on a file." ^ self fileDirectoryClass on: aPath! ! !MetacelloPlatform methodsFor: 'repository creation' stamp: 'dkh 6/5/2012 19:01:24'! extractTypeFromDescription: description description == nil ifTrue: [ ^ nil ]. ((description beginsWith: '/') or: [ description second = $: ]) ifTrue: [ ^ 'directory' ]. (description beginsWith: 'dictionary://') ifTrue: [ ^ 'dictionary' ]. (description beginsWith: 'filetree://') ifTrue: [ ^ 'filetree' ]. (description beginsWith: 'github://') ifTrue: [ ^ 'github' ]. ^ 'http'! ! !MetacelloPlatform methodsFor: 'utilities' stamp: 'dkh 6/5/2012 19:01:24'! authorName: aString "Primarily used for testing" self subclassResponsibility! ! !MetacelloPlatform methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! bypassProgressBars bypassProgressBars == nil ifTrue: [ bypassProgressBars := false ]. ^ bypassProgressBars! ! !MetacelloPlatform methodsFor: 'file system' stamp: 'ChristopheDemarey 5/29/2013 18:16'! parentDirectoryOf: aFileHandler "Get the parent directory of this file." ^ aFileHandler containingDirectory! ! !MetacelloPlatform methodsFor: 'scripting' stamp: 'dkh 7/23/2012 11:05'! defaultRepositoryDescription ^ 'http://www.squeaksource.com/MetacelloRepository'! ! !MetacelloPlatform methodsFor: 'file system' stamp: 'ChristopheDemarey 5/27/2013 17:42'! recursiveDelete: aDirectory "delete this directory and all children of it" ^ aDirectory recursiveDelete! ! !MetacelloPlatform methodsFor: 'utilities' stamp: 'ChristopheDemarey 5/31/2013 13:02'! string: aString includesSubstring: aSubstring "abstract String>>includesSubstring: to have the same message on all supported platforms." ^aString includesSubString: aSubstring! ! !MetacelloPlatform methodsFor: 'user interaction' stamp: 'dkh 6/5/2012 19:01:24'! confirm: aString ^(Smalltalk hasClassNamed: #UIManager) ifTrue: [ (Smalltalk classNamed: #UIManager) default perform: #confirm: with: aString ] ifFalse: [ "throw warning and answer true, if no way to announce" Warning signal: aString. true ]! ! !MetacelloPlatform methodsFor: 'reflection' stamp: 'dkh 6/5/2012 19:01:24'! copyClass: oldClass as: newName inCategory: newCategoryName self subclassResponsibility! ! !MetacelloPlatform methodsFor: 'as yet unclassified' stamp: 'dkh 07/01/2013 08:49'! downloadErrorFileNameFor: zipFileName ^ '/tmp/curl-' , (zipFileName select: [ :c | c isAlphaNumeric ]) , '.err'! ! !MetacelloPlatform methodsFor: 'caching' stamp: 'dkh 6/5/2012 19:01:24'! stackCacheFor: cacheName at: key doing: aBlock ^self stackCacheFor: cacheName cacheClass: Dictionary at: key doing: aBlock! ! !MetacelloPlatform methodsFor: 'file system' stamp: 'ChristopheDemarey 4/29/2013 15:17'! ensureDirectoryExists: aDirectoryHandle "Ensure the directory exists." ^ aDirectoryHandle assureExistence ; yourself! ! !MetacelloPlatform methodsFor: 'file system' stamp: 'ChristopheDemarey 5/14/2013 18:04'! readStreamOn: aFileHandle do: aBlock "Get a read stream on the file handle and execute some actions on it." | stream | stream := aFileHandle readStream. ^ [ aBlock value: stream ] ensure: [ stream close ]! ! !MetacelloPlatform methodsFor: 'attributes' stamp: 'ChristopheDemarey 5/31/2013 14:04'! defaultPlatformAttributes | versionString | Smalltalk at: #SystemVersion ifPresent: [:cl | versionString := cl current version. (versionString beginsWith: 'Pharo') ifTrue: [ ^ #(#squeakCommon #pharo ) ]. (versionString beginsWith: 'Squeak') ifTrue: [^ #(#squeakCommon #squeak )]. "see http://code.google.com/p/metacello/issues/detail?id=146" (self string: versionString includesSubstring: 'Pharo') ifTrue: [ ^ #(#squeakCommon #pharo ) ]. (versionString includesSubstring: 'Squeak') ifTrue: [^ #(#squeakCommon #squeak )]. self error: 'Unrecognized version of Squeak/Pharo: ', versionString ]. ^ #(#gemstone )! ! !MetacelloPlatform methodsFor: 'reflection' stamp: 'dkh 6/5/2012 19:01:24'! globalNamed: globalName ^Smalltalk at: globalName! ! !MetacelloPlatform methodsFor: 'utilities' stamp: 'dkh 6/5/2012 19:01:24'! authorName Smalltalk at: #Author ifPresent: [:cl | ^cl perform: #initials ]. ^'no developer initials'! ! !MetacelloPlatform methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! bypassGoferLoadUpdateCategories bypassGoferLoadUpdateCategories == nil ifTrue: [ bypassGoferLoadUpdateCategories := false ]. ^ bypassGoferLoadUpdateCategories! ! !MetacelloPlatform methodsFor: 'transactions' stamp: 'dkh 6/5/2012 19:01:24'! transact: aBlock "On GemStone, we want to optionally abort before command execution and commit after common execution. Other plaforms don't need to do anything special. Returning out of block, skips commit." aBlock value! ! !MetacelloPlatform methodsFor: 'repository creation' stamp: 'dkh 05/08/2013 09:33'! packageInfoFor: aMCWorkingCopy ^ aMCWorkingCopy packageInfo ! ! !MetacelloPlatform methodsFor: 'caching' stamp: 'dkh 6/5/2012 19:01:24'! primeStackCacheFor: cacheName doing: noArgBlock defaultDictionary: aDictionary self deprecated: 'use #primeStackCacheWith:doing:'. self useStackCacheDuring: [:dict | | cache | cache := dict at: cacheName ifAbsent: []. cache == nil ifTrue: [ cache := Dictionary new. dict at: cacheName put: cache ]. ^noArgBlock value ] defaultDictionary: aDictionary! ! !MetacelloPlatform methodsFor: 'notification' stamp: 'dkh 6/5/2012 19:01:24'! do: aBlock displaying: aString aBlock value! ! !MetacelloPlatform methodsFor: 'system' stamp: 'CamilloBruni 10/15/2013 21:37'! suspendSystemUpdateEventsDuring: aBlock "Wraps call to the system evetn manager to tell it that we want to suspend events during execution of aBlock" (Smalltalk at: #SystemChangeNotifier) uniqueInstance doSilently: aBlock! ! !MetacelloPlatform methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! bypassProgressBars: anObject bypassProgressBars := anObject! ! !MetacelloPlatform methodsFor: 'file system' stamp: 'ChristopheDemarey 4/29/2013 15:11'! directoryFromPath: adirectoryPath relativeTo: anotherDirectoryPath "Get a handle on the following path: anotherDirectoryPath/adirectoryPath" ^ anotherDirectoryPath directoryNamed: adirectoryPath! ! !MetacelloPlatform methodsFor: 'github support' stamp: 'dkh 7/7/2012 07:36'! extractRepositoryFrom: zipFile to: directory "unzip into " self subclassResponsibility! ! !MetacelloPlatform methodsFor: 'github support' stamp: 'CamilloBruni 10/15/2013 21:36'! fileDirectoryClass ^Smalltalk at: #FileDirectory! ! !MetacelloPlatform methodsFor: 'caching' stamp: 'dkh 6/5/2012 19:01:24'! stackCacheFor: cacheName cacheClass: cacheClass at: key doing: aBlock self useStackCacheDuring: [:dict | | cache | cache := dict at: cacheName ifAbsent: []. cache ~~ nil ifTrue: [ | value hasEntry | hasEntry := true. value := cache at: key ifAbsent: [ hasEntry := false ]. hasEntry ifTrue: [ ^value ]] ifFalse: [ cache := cacheClass new. dict at: cacheName put: cache ]. ^aBlock value: cache ] defaultDictionary: nil! ! !MetacelloPlatform methodsFor: 'caching' stamp: 'dkh 6/5/2012 19:01:24'! clearCurrentVersionCache MetacelloClearStackCacheNotification signal: #(#currentVersion #currentVersionAgainst: #currentVersionInfo)! ! !MetacelloPlatform methodsFor: 'caching' stamp: 'dkh 6/5/2012 19:01:24'! useStackCacheDuring: aBlock defaultDictionary: defaultDictionary | dict | dict := MetacelloStackCacheNotification signal. dict == nil ifTrue: [ dict := defaultDictionary == nil ifTrue: [ Dictionary new ] ifFalse: [ defaultDictionary ] ]. [ ^ aBlock value: dict ] on: MetacelloStackCacheNotification , MetacelloClearStackCacheNotification do: [ :ex | (ex isKindOf: MetacelloStackCacheNotification) ifTrue: [ ex resume: dict ]. (ex isKindOf: MetacelloClearStackCacheNotification) ifTrue: [ | keys | keys := ex cacheNames. keys ifNil: [ keys := dict keys ]. keys do: [ :k | (dict includesKey: k) ifTrue: [ | c | c := dict at: k. c keys do: [ :ck | c removeKey: ck ]. dict removeKey: k ] ]. ex resume ] ]! ! !MetacelloPlatform methodsFor: 'utilities' stamp: 'dkh 6/5/2012 19:01:24'! timestamp ^DateAndTime now printString! ! !MetacelloPlatform methodsFor: 'file system' stamp: 'ChristopheDemarey 4/29/2013 14:17'! defaultDirectory "Get the image default directory" ^self fileDirectoryClass default! ! !MetacelloPlatform methodsFor: 'tests' stamp: 'dkh 6/5/2012 19:01:24'! defaultTimeout "squeak compatability" ^60! ! !MetacelloPlatform methodsFor: 'reflection' stamp: 'dkh 6/5/2012 19:01:24'! globalNamed: globalName ifAbsent: absentBlock ^Smalltalk at: globalName ifAbsent: absentBlock! ! !MetacelloPlatform methodsFor: 'caching' stamp: 'dkh 6/5/2012 19:01:24'! primeStackCacheWith: aDictionary doing: noArgBlock self useStackCacheDuring: [:dict | ^noArgBlock value ] defaultDictionary: aDictionary! ! !MetacelloPlatform class methodsFor: 'initialize-release' stamp: 'dkh 05/05/2013 13:39'! initialize "noop ... use #select" ! ! !MetacelloPlatform class methodsFor: 'initialize-release' stamp: 'dkh 05/05/2013 13:39'! select Current := self new! ! !MetacelloPlatform class methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! current Current ifNil: [Current := MetacelloPlatform new]. ^ Current! ! !MetacelloPlatform class methodsFor: 'initialize-release' stamp: 'dkh 05/05/2013 13:39'! unselect MetacelloPlatform current class = self ifTrue: [ Current := nil ]! ! !MetacelloPostLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! addTo: aLoaderDirective spec postLoadDoIt value ~~ nil ifTrue: [ aLoaderDirective add: self ]! ! !MetacelloPostLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: aLoaderDirective gofer: aGofer aLoaderDirective loadPostloadDirective: self. ! ! !MetacelloPostLoadDirective methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! label ^super label, ' >> ', self spec postLoadDoIt value asString! ! !MetacelloPostLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! title ^'postload'! ! !MetacelloPostLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! postLoadDo: aBlock aBlock value: self! ! !MetacelloPreLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! addTo: aLoaderDirective spec preLoadDoIt value ~~ nil ifTrue: [ aLoaderDirective add: self ]! ! !MetacelloPreLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: aLoaderDirective gofer: aGofer aLoaderDirective loadPreloadDirective: self. ! ! !MetacelloPreLoadDirective methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! label ^super label, ' >> ', self spec preLoadDoIt value asString! ! !MetacelloPreLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! title ^'preload'! ! !MetacelloPreLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! preLoadDo: aBlock aBlock value: self! ! !MetacelloPrePostLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! prepostLoadDo: aBlock aBlock value: self! ! !MetacelloPrePostLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! evaluateSupplyingAnswers: loadBlock | answers | (answers := self spec answers) notEmpty ifTrue: [ loadBlock valueSupplyingMetacelloAnswers: answers ] ifFalse: [ loadBlock value]! ! !MetacelloPrePostLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! prepostLoadDirectivesDo: aBlock aBlock value: self! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! latestVersion: blessing ^(self map values select: [:version | blessing = version blessing ]) detectMax: [:version | version ]! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! currentVersion | cacheKey cv | cacheKey := self configuration class. ^ MetacelloPlatform current stackCacheFor: #currentVersion at: cacheKey doing: [ :cache | cv := self currentVersionAgainst: nil. ^ cache at: cacheKey put: cv ]! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! platformAttributes ^self projectPlatformAttributes! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! groupSpec ^self groupSpecClass for: self! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! defaultLoaderClass ^MetacelloSpecLoader! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! lastVersion | coll | coll := (self map values asArray sort: [:a :b | a <= b ]) asOrderedCollection. coll isEmpty ifTrue: [ ^nil ]. ^coll last! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! loaderClass loaderClass == nil ifTrue: [ loaderClass := self defaultLoaderClass ]. ^loaderClass! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! project ^self! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! projectPlatformAttributes | list aBlock | list := OrderedCollection new. (aBlock := self projectAttributes) ~~ nil ifTrue: [ list addAll: aBlock value ]. ^self defaultPlatformAttributes, list! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! errorMap ^ errorMap! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! development ^self version: #development! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! errorMap: anObject errorMap ifNil: [ errorMap := Dictionary new ]. errorMap := anObject! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! packagesSpecClass ^MetacelloPackagesSpec! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! groupSpecClass ^MetacelloGroupSpec! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! lookupVersion: aVersionString ifAbsent: aBlock "please use version:...this is a private method" ^ self map at: aVersionString ifAbsent: [ (MetacelloVersionDefinitionError project: self project versionString: aVersionString) exception: (self errorMap at: aVersionString ifAbsent: [ ^ aBlock value ]); signal ]! ! !MetacelloProject methodsFor: 'scripting' stamp: 'dkh 6/5/2012 19:01:24'! projectForScriptEngine: aMetacelloScriptEngine unconditionalLoad: aBool ^ self subclassResponsibility! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! projectAttributes: aList projectAttributes := aList! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! versionSpec ^self versionSpecClass for: self! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! latestVersionMatching: versionPatternString includedBlessings: included excludedBlessings: excludedBlessings | excluded | excluded := excludedBlessings asSet copy. excluded removeAllFoundIn: included. ^(self map values select: [:version | (included isEmpty or: [ included includes: version blessing ]) and: [ (excluded includes: version blessing) not and: [ version versionNumber match: versionPatternString ]]]) detectMax: [:version | version ]! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! valueHolderSpecClass ^MetacelloValueHolderSpec! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! pragmaKeywords ^#(version:attribute: blessing:attribute: description:attribute: required:attribute: groups:attribute: doits:attribute:)! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! loaderClass: aMetacelloSpecLoader loaderClass := aMetacelloSpecLoader! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! packagesSpec ^self packagesSpecClass for: self! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! hasVersion: versionString self version: versionString ifAbsent: [ ^false ]. ^true! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! version: aVersionString | vrsn | aVersionString isSymbol ifTrue: [ | symbolicVersionString | symbolicVersionString := self symbolicVersionMap at: aVersionString ifAbsent: [ (MetacelloSymbolicVersionDoesNotExistError project: self project versionString: aVersionString) signal ]. symbolicVersionString == #'notDefined' ifTrue: [ (MetacelloSymbolicVersionNotDefinedError project: self project versionString: aVersionString) signal ]. ^ self lookupVersion: symbolicVersionString ifAbsent: [ (MetacelloSymbolicVersionDoesNotExistError project: self project versionString: symbolicVersionString) signal ] ]. ^ self lookupVersion: aVersionString ifAbsent: [ (MetacelloVersionDoesNotExistError project: self project versionString: aVersionString) signal ]! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! latestVersionMatching: versionPatternString "Answer whether the version number of the receiver matches the given pattern string. A Metacello version number is made up of version sequences delimited by the characters $. and $-. The $. introduces a numeric version sequence and $- introduces an alphanumeric version sequence. A version pattern is made up of version pattern match sequences. also delimited by the characters $. and $-.. Each pattern match sequence is tested against the corresponding version sequence of the receiver, using the 'standard' pattern matching rules. All sequences must answer true for a match. The special pattern sequence '?' is a match for the corresponding version sequence and all subsequent version sequences. '?' as the version pattern matches all versions. No more version pattern sequences are permitted once the '?' sequence is used. If used, it is the last version pattern sequence." ^self latestVersionMatching: versionPatternString includedBlessings: #() excludedBlessings: self excludeFromLatestVersion ! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! defaultPlatformAttributes ^ MetacelloPlatform current defaultPlatformAttributes! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! projectSpecClass ^ MetacelloProjectSpec! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! baselineOfVersionSpecClass ^ self subclassResponsibility! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! loader ^loader! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! symbolicVersionMap: aDictionary symbolicVersionMap := aDictionary ! ! !MetacelloProject methodsFor: 'scripting' stamp: 'dkh 6/5/2012 19:01:24'! projectForScriptEngine: aMetacelloScriptEngine ^ self projectForScriptEngine: aMetacelloScriptEngine unconditionalLoad: false! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! map versionMap ifNil: [ ^ Dictionary new ]. ^ versionMap! ! !MetacelloProject methodsFor: 'loading' stamp: 'dkh 6/5/2012 19:01:24'! load: aVersionString ^(self version: aVersionString) load ! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! versionSpecClass ^MetacelloVersionSpec! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! baselineOfProjectSpecClass ^ self subclassResponsibility! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! map: aDictionary versionMap := aDictionary! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! latestVersionMatching: versionPatternString includedBlessings: included ^self latestVersionMatching: versionPatternString includedBlessings: included excludedBlessings: self excludeFromLatestVersion ! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! projectReferenceSpec ^self projectReferenceSpecClass for: self! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! loadType "#atomic or #linear" loadType == nil ifTrue: [ ^#atomic ]. ^loadType! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! projectSpec ^self projectSpecClass for: self! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! defaultBlessing ^#release! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! latestVersion | excluded | " self deprecated: 'Please use #stableVersion instead.'. " self flag: 'deprecate after version 1.0'. excluded := self excludeFromLatestVersion. ^(self map values select: [:version | (excluded includes: version blessing) not ]) detectMax: [:version | version ]! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! version: aVersionString ifAbsent: aBlock ^[ self version: aVersionString ] on: MetacelloVersionDoesNotExistError do: [:ex | aBlock value ].! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! configuration: anObject configuration := anObject! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! excludeFromLatestVersion ^#(structural development broken baseline) ! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! symbolicVersionSymbols ^self symbolicVersionMap keys asArray sort: [:a :b | a <= b ]! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! loader: aLoader loader := aLoader! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! valueHolderSpec ^self valueHolderSpecClass for: self! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! sortedAndFilteredVersions ^(self map values asArray sort: [:a :b | a >= b ]) select: [:vrsn | (#(structural broken baseline) includes: vrsn blessing) not ]. ! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/22/2012 12:41'! versionNumberClass: aClass versionNumberClass := aClass! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! latestVersionMatching: versionPatternString excludedBlessings: excluded ^self latestVersionMatching: versionPatternString includedBlessings: #() excludedBlessings: excluded ! ! !MetacelloProject methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! printOn: aStream | label | self configuration class printOn: aStream. aStream nextPut: $(. self versions do: [ :vrsn | aStream nextPutAll: vrsn versionString. vrsn spec ~~ nil ifTrue: [ (label := vrsn spec projectLabel) isEmpty ifFalse: [ aStream nextPutAll: ' [' , label , ']' ] ]. aStream nextPut: $,; space ]. aStream nextPut: $)! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! currentVersionAgainst: resolvedPackageAndProjectNames | cacheKey | cacheKey := resolvedPackageAndProjectNames isNil ifTrue: [ Array with: self configuration class with: nil ] ifFalse: [ Array with: self configuration class with: (resolvedPackageAndProjectNames sort: [ :a :b | a <= b ]) ]. ^ MetacelloPlatform current stackCacheFor: #currentVersionAgainst: at: cacheKey doing: [ :cache | | cv versions latestSomethingLoaded | cv := nil. versions := self sortedAndFilteredVersions. versions do: [ :version | | status matchBlock | status := resolvedPackageAndProjectNames isNil ifTrue: [ version spec isPartiallyCurrent ] ifFalse: [ version spec isPartiallyCurrentAgainst: resolvedPackageAndProjectNames ]. matchBlock := [ :matchStatus | cv := version copy. cv versionStatus: matchStatus. ^ cache at: cacheKey put: cv ]. status isAllLoadedToSpec: matchBlock. status isLoadedToSpec: matchBlock. status isLoadedMatchConstraints: matchBlock. status isSomethingLoaded: [ :matchStatus | latestSomethingLoaded isNil ifTrue: [ cv := version copy. cv versionStatus: matchStatus. latestSomethingLoaded := cv ] ] ]. latestSomethingLoaded ifNotNil: [ ^ cache at: cacheKey put: latestSomethingLoaded ]. ^ cache at: cacheKey put: nil ]! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! bleedingEdge ^self version: #bleedingEdge! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! stableVersion ^self version: #stable! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! configurationOfProjectSpecClass ^ self subclassResponsibility! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! projectReferenceSpecClass ^MetacelloProjectReferenceSpec! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! configurationOfProjectSpec ^ self configurationOfProjectSpecClass for: self! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! configuration ^ configuration! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! projectAttributes projectAttributes ~~ nil ifTrue: [ ^projectAttributes ]. ^#()! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/22/2012 12:41'! versionNumberClass versionNumberClass ifNil: [ versionNumberClass := MetacelloVersionNumber ]. ^ versionNumberClass! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 6/5/2012 19:01:24'! versions ^self map values asArray sort: [:a :b | a <= b ]! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! attributes ^(OrderedCollection with: #common) addAll: self platformAttributes; yourself ! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! label ^self configuration class name! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! symbolicVersionMap ^symbolicVersionMap ! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! loadType: aSymbol "#atomic or #linear" loadType := aSymbol! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2012 19:01:24'! baselineOfProjectSpec ^ self baselineOfProjectSpecClass for: self! ! !MetacelloProject class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! new | inst | inst := self basicNew. ^inst configuration: inst; yourself! ! !MetacelloProject class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! on: aConfig ^self basicNew configuration: aConfig; yourself! ! !MetacelloProject class methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionConstructorClass ^ MetacelloVersionConstructor! ! !MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson10 " [ see method: #baseline10: #version10: ] In lesson07 it was obvious that we copied the configuration information from MetacelloTutorialConfig and adapted it to our project. There is a better way. In #baseline10: we've created a project reference for the Example project. The #className: specifies the name of the class that contains the project metadata. If the class is not present in the image, then we know that we need to load the configuration for the project. The #file: and #repository: specifications give us the information needed to load the project metadata from a repository. Finally, the #versionString: and #loads: tell us which version of the project to load and which packages to load from the project. We've named the project reference 'Example ALL' and in the specification for the 'Project-Core' package, we've specified that 'Example ALL' is required: (MetacelloProjectRefTutorialConfig project version: '1.0') load. Note that the entire Example project is loaded before 'Project-Core' "! ! !MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version14: spec spec for: #common do: [ spec blessing: #beta. spec description: 'Add groups and Project-Extra'. spec project: 'Example Default' with: '1.3'; project: 'Example Tests' with: '1.3'. spec package: 'Project-Core' with: 'Project-Core-anon.2'; package: 'Project-Tests' with: 'Project-Tests-anon.2'; package: 'Project-Extra' with: 'Project-Extra-anon.1'.]. ! ! !MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson12 " [ see method: #baseline11: #baseline12: #version12: ] In #baseline11: there is redundant information for each of the project references. In #baseline12: we use the #project:copyFrom:with: method to eliminate the need to specify the bulk of the project information twice. Evaluate and compare the results of the following expressions: (MetacelloProjectRefTutorialConfig project version: '1.1') load: 'Project-Core'. (MetacelloProjectRefTutorialConfig project version: '1.2') load: 'Project-Core'. (MetacelloProjectRefTutorialConfig project version: '1.1') load: 'Project-Tests'. (MetacelloProjectRefTutorialConfig project version: '1.2') load: 'Project-Tests'. "! ! !MetacelloProjectRefTutorialConfig methodsFor: 'baselines' stamp: 'dkh 3/18/2011 14:15:41'! baseline11: spec spec for: #common do: [ spec blessing: #baseline. spec repository: 'http://www.example.com/Project'. spec project: 'Example Default' with: [ spec className: 'MetacelloTutorialConfig'; versionString: '1.1'; loads: #('default' ); file: 'Metacello-Tutorial'; repository: 'http://seaside.gemstone.com/ss/metacello' ]; project: 'Example Tests' with: [ spec className: 'MetacelloTutorialConfig'; versionString: '1.1'; loads: #('Tests' ); file: 'Metacello-Tutorial'; repository: 'http://seaside.gemstone.com/ss/metacello' ]. spec package: 'Project-Core' with: [ spec requires: 'Example Default' ]; package: 'Project-Tests' with: [ spec requires: #('Project-Core' 'Example Tests' ).].]. ! ! !MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson14 " [ see method: #baseline14: #version14: ] In this lesson we'll cover the querying API for Metacello. The querying API is useful for analyzing the contents and structure of a version. To start with we'll look at version '1.4' of the MetacelloProjectRefTutorialConfig. You can list the packages in the version: (MetacelloProjectRefTutorialConfig project version: '1.4') packages The list project references: (MetacelloProjectRefTutorialConfig project version: '1.4') projects And the groups: (MetacelloProjectRefTutorialConfig project version: '1.4') groups You can access individual packages/project refs/groups using the #packageNamed: method. Here you can access the package named: 'Project-Core': (MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Project-Core' The project reference named 'Example Default': (MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Example Default' The group named 'Core': (MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Core' Each of the attributes of the package can be accessed (#requires, #includes, #file, #repository, #preLoadDoIt, and #postLoadDoit). For example: ((MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Project-Core') requires Each of the attributes of the project can be accessed (#className, #versionString, #operator, #loads, #file, and #repository). For example: ((MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Example Default') repository Each of the attributes of the group can be accessed (#includes). For example: ((MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'default') includes When looking at the 'Core' group, there is only one package listed: (MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Core' In the case of the 'Core' group, it is defined in terms of the 'default', which isn't very useful. When looking at the contents of groups you'd like to see the complete list of packages, without having to explicitly expanding each group you encounter. #packagesForSpecNamed: does just that: (MetacelloProjectRefTutorialConfig project version: '1.4') packagesForSpecNamed: 'Core' If you were to load the 'Core' package: (MetacelloProjectRefTutorialConfig project version: '1.4') load: 'Core' You end up seeing the packages from the Example project. If you want to get the list of packages that _would_ be loaded, you can use #allPackagesForSpecNamed:. For example: (MetacelloProjectRefTutorialConfig project version: '1.4') allPackagesForSpecNamed: 'Core' If you use #allPackagesForSpecNamed: with a project refernce name, you'll see the packages that _would_ be loaded: (MetacelloProjectRefTutorialConfig project version: '1.4') load: 'Example Default' (MetacelloProjectRefTutorialConfig project version: '1.4') allPackagesForSpecNamed: 'Example Default' You can also send #version to a project reference. This is useful if you want to explicitly walk the tree of projects: ((MetacelloProjectRefTutorialConfig project version: '1.4') packageNamed: 'Example Default') version "! ! !MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version11: spec spec for: #common do: [ spec blessing: #beta. spec package: 'Project-Core' with: 'Project-Core-anon.1'; package: 'Project-Tests' with: 'Project-Tests-anon.1'.]. ! ! !MetacelloProjectRefTutorialConfig methodsFor: 'baselines' stamp: 'dkh 3/18/2011 14:15:41'! baseline14: spec spec for: #common do: [ spec description: 'Add groups and Project-Extra, extending 1.2-baseline'. spec package: 'Project-Core' with: [ spec includes: 'Project-Extra' ]; package: 'Project-Extra' with: [ spec requires: 'Project-Core' ]. spec group: 'default' with: #('Project-Core' 'Project-Extra' ); group: 'Core' with: #('default' ); group: 'Tests' with: #('Project-Tests' ).]. ! ! !MetacelloProjectRefTutorialConfig methodsFor: 'accessing' stamp: 'dkh 3/18/2011 14:15:41'! project "NOTE: The MetacelloNullRecordingMCSpecLoader is being used to prevent packages from being loaded, see MetacelloConfigTemplate>>project for an example #project method that loads the package for real" ^ project ifNil: [ | constructor loader | "Construct Metacello project" constructor := (Smalltalk at: #MetacelloVersionConstructor) on: self. project := constructor project. loader := MetacelloNullRecordingMCSpecLoader new. loader evalDoits: true. project loader: loader. project ]! ! !MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version10: spec spec for: #common do: [ spec blessing: #beta. spec package: 'Project-Core' with: 'Project-Core-anon.1'; package: 'Project-Tests' with: 'Project-Tests-anon.1'.]. ! ! !MetacelloProjectRefTutorialConfig methodsFor: 'baselines' stamp: 'dkh 3/18/2011 14:15:41'! baseline10: spec spec for: #common do: [ spec blessing: #baseline. spec repository: 'http://www.example.com/Project'. spec project: 'Example ALL' with: [ spec className: 'MetacelloTutorialConfig'; versionString: '1.0'; loads: #('ALL' ); file: 'MetacelloTutorialConfig'; repository: 'http://seaside.gemstone.com/ss/metacello' ]. spec package: 'Project-Core' with: [ spec requires: 'Example ALL' ]; package: 'Project-Tests' with: [ spec requires: 'Project-Core' ].]. ! ! !MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson07 " [ see method: #baseline07: #version07: ] NOTE: you should run through the lessons in MetacellTutorialConfig first. In this configuration we are defining a project that utilizes the packages from the Example project (MetacelloTutorialConfig): 'Example-Core', 'Example-AddOn', 'Example-Tests' and 2 packages specific to the project: 'Project-Core' and 'Project-Tests': (MetacelloProjectRefTutorialConfig project version: '0.7') load. "! ! !MetacelloProjectRefTutorialConfig methodsFor: 'baselines' stamp: 'dkh 3/18/2011 14:15:41'! baseline12: spec spec for: #common do: [ spec blessing: #baseline. spec repository: 'http://www.example.com/Project'. spec project: 'Example Default' with: [ spec className: 'MetacelloTutorialConfig'; versionString: '1.2'; loads: #('default' ); file: 'Metacello-Tutorial'; repository: 'http://seaside.gemstone.com/ss/metacello' ]; project: 'Example Tests' copyFrom: 'Example Default' with: [ spec loads: #('Tests' ).]. spec package: 'Project-Core' with: [ spec requires: 'Example Default' ]; package: 'Project-Tests' with: [ spec requires: #('Project-Core' 'Example Tests' ).].]. ! ! !MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson11 " [ see method: #baseline11: #version11: ] As is often the case, it is useful to separate the test package from the core packages for a project. In #baseline11: we've created two project references. The reference named 'Example Default' loads the 'default' group and the reference named 'Example Tests' loads the 'Tests' group. We then made 'Project-Core' require 'Example Default' and 'Project-Tests' requires 'Project-Core' and 'Example Tests'. Now it is possible to load just the core packages: (MetacelloProjectRefTutorialConfig project version: '1.1') load: 'Project-Core'. or the whole enchilada including tests: (MetacelloProjectRefTutorialConfig project version: '1.1') load: 'Project-Tests'. "! ! !MetacelloProjectRefTutorialConfig methodsFor: 'baselines' stamp: 'dkh 3/18/2011 14:15:41'! baseline07: spec spec for: #common do: [spec blessing: #baseline. spec repository: 'http://www.example.com/Project'. spec package: 'Project-Core' with: [ spec requires: 'Example-Core' ]; package: 'Project-Tests' with: [ spec requires: #('Project-Core' 'Example-Tests' )]; package: 'Example-Core' with: [ spec repository: 'http://www.example.com/Example']; package: 'Example-Tests' with: [ spec requires: 'Example-Core'; repository: 'http://www.example.com/Example']; package: 'Example-AddOn' with: [ spec requires: 'Example-Core'; repository: 'http://www.example.com/Example']]! ! !MetacelloProjectRefTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson13 " [ see method: #version13: ] In #version13: we are importing the '1.2-baseline', but changing the Example project version to 1.3, so project versions can be updated in the verson method jus like package versions. Evaluate and compare the results of these expressions: (MetacelloProjectRefTutorialConfig project version: '1.2') load: 'Project-Core'. (MetacelloProjectRefTutorialConfig project version: '1.3') load: 'Project-Core'. (MetacelloProjectRefTutorialConfig project version: '1.2') load: 'Project-Tests'. (MetacelloProjectRefTutorialConfig project version: '1.3') load: 'Project-Tests'. It is worth noting that in version 1.3 of the Example project, the platform-specific 'Example-Platform' was introduced and nothing special had to be done in the project reference to get the package included. "! ! !MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version12: spec spec for: #common do: [ spec blessing: #beta. spec package: 'Project-Core' with: 'Project-Core-anon.1'; package: 'Project-Tests' with: 'Project-Tests-anon.1'.]. ! ! !MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version13: spec spec for: #common do: [ spec blessing: #beta. spec description: 'Import functionality from the example project, different packages'. spec package: 'Project-Core' with: 'Project-Core-anon.1'; package: 'Project-Tests' with: 'Project-Tests-anon.1'; project: 'Example Default' with: '1.3'; project: 'Example Tests' with: '1.3']. ! ! !MetacelloProjectRefTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version07: spec spec for: #common do: [ spec blessing: #release. spec package: 'Project-Core' with: 'Project-Core-anon.1'; package: 'Project-Tests' with: 'Project-Tests-anon.1'; package: 'Example-Core' with: 'Example-Core-anon.12'; package: 'Example-Tests' with: 'Example-Tests-anon.3'; package: 'Example-AddOn' with: 'Example-AddOn-anon.1'.]. ! ! !MetacelloProjectRefTutorialConfig class methodsFor: 'accessing' stamp: 'dkh 3/18/2011 14:15:41'! project ^self new project! ! !MetacelloProjectRefTutorialConfig class methodsFor: 'private' stamp: 'dkh 3/18/2011 14:15:41'! ensureMetacello "Bootstrap Gofer (if necessary), bootstrap ConfigurationOfMetacello (using old Gofer API), then load the latest version of Metacello itself." Smalltalk at: #MetacelloProject ifAbsent: [ Smalltalk at: #Gofer ifAbsent: [ "Current version of Gofer from which to bootstrap - as of 1.0-beta.15" self bootstrapPackage: 'Gofer-lr.83' from: 'http://seaside.gemstone.com/ss/metacello' ]. Smalltalk at: #Gofer ifPresent: [:goferClass | | gofer | gofer := goferClass new url: 'http://seaside.gemstone.com/ss/metacello'; yourself. [ gofer addPackage: 'ConfigurationOfMetacello' ] on: Warning do: [:ex | ex resume ]. gofer load ]. "load 'default' group of Metacello" (Smalltalk at: #ConfigurationOfMetacello) perform: #load ]! ! !MetacelloProjectRefTutorialConfig class methodsFor: 'metacello tool support' stamp: 'dkh 3/18/2011 14:15:41'! isMetacelloConfig "Answer true and the Metacello tools will operate on you" ^true! ! !MetacelloProjectRefTutorialConfig class methodsFor: 'private' stamp: 'dkh 3/18/2011 14:15:41'! bootstrapPackage: aString from: aPath | repository version | repository := MCHttpRepository location: aPath user: '' password: ''. repository versionReaderForFileNamed: aString , '.mcz' do: [:reader | version := reader version. version load. version workingCopy repositoryGroup addRepository: repository]! ! !MetacelloProjectReferenceSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodCascadeOn: aStream member: aMember last: lastCascade indent: indent aMember methodUpdateSelector == #'remove:' ifTrue: [ aStream nextPutAll: 'removeProject: ' , self name printString ] ifFalse: [ self projectReference == nil ifTrue: [ ^ self ]. aStream nextPutAll: self projectLabel , ': ' , self projectName printString , ' '. (aMember methodUpdateSelector == #'copy:' and: [ self projectReference hasNonVersionStringField ]) ifTrue: [ aStream nextPutAll: 'copyFrom: ' , aMember sourceName printString , ' ' ]. self projectReference configShortCutMethodOn: aStream member: aMember indent: indent + 1 ]. lastCascade ifTrue: [ aStream nextPut: $. ] ifFalse: [ aStream nextPut: $;; cr ]! ! !MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! versionOrNil ^self projectReference versionOrNil! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! requires: aCollection self shouldNotImplement! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolveToPackagesIn: aVersionSpec visited: visited ^#()! ! !MetacelloProjectReferenceSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeSpec: anotherSpec | newSpec map anotherProjectReference | newSpec := super mergeSpec: anotherSpec. map := anotherSpec mergeMap. (anotherProjectReference := map at: #projectReference) ~~ nil ifTrue: [ newSpec projectReference: (newSpec projectReference == nil ifTrue: [ anotherProjectReference ] ifFalse: [ newSpec projectReference mergeSpec: anotherProjectReference ])]. ^newSpec! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! loadUsing: aLoader gofer: ignored | required | required := self resolveToLoadableSpec. required loader: aLoader. ^required load! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectLabel ^ self projectReference projectLabel! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! packagesNeedSavingVisited: visitedProjects using: repos into: aCollection | prjct clsName vrsn | prjct := self resolveToLoadableSpec. (visitedProjects includes: (clsName := prjct className)) ifTrue: [ ^self ]. visitedProjects add: clsName. (vrsn := self versionOrNil) == nil ifTrue: [ ^self ]. vrsn spec packagesNeedSavingVisited: visitedProjects into: aCollection! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolveProjectSpec ^self projectReference! ! !MetacelloProjectReferenceSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeMap | map | map := super mergeMap. map at: #projectReference put: projectReference. ^map! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolveToAllPackagesIn: aVersionSpec into: packages visited: visited (self resolveProjectSpec resolveToAllPackagesIn: aVersionSpec visited: visited) do: [:pkg | packages at: pkg put: pkg ]! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! versionString ^self projectReference versionString! ! !MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! repositories ^ self referencedSpec repositories! ! !MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! projectReference ^ projectReference! ! !MetacelloProjectReferenceSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! nonOverridable ^super nonOverridable, #( projectReference )! ! !MetacelloProjectReferenceSpec methodsFor: 'testing' stamp: 'dkh 6/30/2012 13:22'! hasRepository ^ self projectReference hasRepository! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! updateForSpawnMethod: sourceSpec "This means that this spec was used in a baseline and will be used in a version .... drop all information that isn't useful" | nm | nm := name. self projectReference updateForSpawnMethod: sourceSpec. super updateForSpawnMethod: sourceSpec. name := nm. ! ! !MetacelloProjectReferenceSpec methodsFor: 'loading' stamp: 'dkh 6/5/2012 19:01:24'! repositorySpecs ^self repositories map values! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! updatePackageSpec: updatedSpecs using: anMCLoader "Add project copy to updatedSpecs if the current version of the project is different from the receiver's version" self projectReference updatePackageSpec: updatedSpecs! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectReference: anObject projectReference := anObject! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectName ^self projectReference name! ! !MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! relativeCurrentVersion ^self projectReference relativeCurrentVersion! ! !MetacelloProjectReferenceSpec methodsFor: 'visiting' stamp: 'dkh 6/5/2012 19:01:24'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock projectBlock value: self! ! !MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! version ^self projectReference version! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! includes: aCollection self shouldNotImplement! ! !MetacelloProjectReferenceSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! aboutToCopy self projectReference className! ! !MetacelloProjectReferenceSpec methodsFor: 'copying' stamp: 'dkh 6/5/2012 19:01:24'! postCopy super postCopy. projectReference := projectReference copy. ! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! repository: aStringOrMetacelloRepositorySpec ^ self projectReference repository: aStringOrMetacelloRepositorySpec! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! referencedSpec ^self projectReference! ! !MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! versionString: aString ^self projectReference versionString: aString! ! !MetacelloProjectReferenceSpec methodsFor: 'importing' stamp: 'dkh 6/26/2012 10:48'! mergeImportLoads: aLoadList self projectReference mergeImportLoads: aLoadList! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! answers: aListOfPairs self shouldNotImplement! ! !MetacelloProjectReferenceSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodOn: aStream indent: indent aStream tab: indent; nextPutAll: 'spec '; cr; tab: indent + 1; nextPutAll: 'name: ', self name printString; nextPut: $;; cr; tab: indent + 1; nextPutAll: 'projectReference: '; nextPut: $[; cr. aStream tab: indent + 2; nextPutAll: 'spec'. self projectReference ifNotNil: [ self projectReference configMethodBodyOn: aStream indent: indent + 2]. aStream nextPutAll: ' ].'! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! resolveToLoadableSpec ^self resolveProjectSpec resolveToLoadableSpec! ! !MetacelloProjectReferenceSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testProjectReferenceSpec | projectReference project | projectReference := self projectReferenceSpec name: 'Project'; projectReference: (project := self projectSpec name: 'Project'; className: 'ConfigurationOfProjectA'; versionString: #'stable'; yourself); yourself. self assert: projectReference name = 'Project'. self assert: projectReference projectName = 'Project'. self assert: projectReference projectReference == project. self should: [ projectReference includes: #() ] raise: Error. self should: [ projectReference requires: #() ] raise: Error. self should: [ projectReference answers: #() ] raise: Error. projectReference projectDo: [ :prjct | self assert: projectReference == prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]! ! !MetacelloProjectReferenceSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testProjectReferenceMergeSpec | projectReferenceA projectReferenceB projectReference project | projectReferenceA := self projectReferenceSpec name: 'Project'; projectReference: (self projectSpec name: 'Project'; className: 'ConfigurationOfProjectA'; versionString: #'stable'; yourself); yourself. projectReferenceB := self projectReferenceSpec name: 'Project'; projectReference: (self projectSpec name: 'Project'; className: 'ConfigurationOfProjectB'; versionString: '1.0'; yourself); yourself. projectReference := projectReferenceA mergeSpec: projectReferenceB. self assert: projectReference name = 'Project'. self assert: projectReference projectName = 'Project'. project := projectReference projectReference. self assert: project className = 'ConfigurationOfProjectB'. self assert: project versionString = '1.0'! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 07/29/2013 10:30'! projectSpec ^ self configurationProjectSpecIfPresent: [ :spec | spec ] ifAbsent: [ self baselineProjectSpec ]! ! !MetacelloProjectRegistration methodsFor: 'lookup' stamp: 'dkh 7/19/2012 20:58'! lookupConfigurationSpec configurationProjectSpec ifNotNil: [ :spec | ^ spec ]. ^ baselineProjectSpec! ! !MetacelloProjectRegistration methodsFor: 'mutability' stamp: 'dkh 7/19/2012 15:11'! immutable mutable := false! ! !MetacelloProjectRegistration methodsFor: 'testing' stamp: 'dkh 7/18/2012 11:39'! canDowngradeTo: aProjectRegistration "true if there are no load conflicts OR if the load conflicts involved two cofigurations ONLY and a downgrade is allowed" (self hasLoadConflicts: aProjectRegistration) ifFalse: [ ^ true ]. configurationProjectSpec ifNotNil: [ aProjectRegistration configurationProjectSpec ifNotNil: [ configurationProjectSpec ensureProjectLoaded. ^ configurationProjectSpec canDowngradeTo: aProjectRegistration configurationProjectSpec ] ]. ^ false! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 7/19/2012 16:03'! projectName: anObject self shouldBeMutable. projectName := anObject! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 07/24/2012 17:49'! baselineProjectSpecIfPresent: presentBlock ifAbsent: absentBlock ^ baselineProjectSpec ifNotNil: [ presentBlock cull: baselineProjectSpec ] ifNil: absentBlock ! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! configurationProjectSpecIfAbsent: absentBlock ^ configurationProjectSpec ifNil: absentBlock! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 7/19/2012 16:03'! loadedInImage: anObject self shouldBeMutable. loadedInImage := anObject! ! !MetacelloProjectRegistration methodsFor: 'querying' stamp: 'dkh 6/24/2012 13:57'! currentlyLoadedClassesInProject | classes | classes := Set new. self configurationProjectSpecIfPresent: [ :spec | classes addAll: spec currentlyLoadedClassesInVersion ] ifAbsent: [ ]. self baselineProjectSpecIfPresent: [ :spec | classes addAll: spec currentlyLoadedClassesInVersion ] ifAbsent: [ ]. ^ classes! ! !MetacelloProjectRegistration methodsFor: 'mutability' stamp: 'dkh 7/19/2012 15:11'! mutable mutable := true! ! !MetacelloProjectRegistration methodsFor: 'registration' stamp: 'dkh 7/19/2012 11:25'! registerProject "unconditionally register ... use with care" self class registry registerProjectRegistration: self! ! !MetacelloProjectRegistration methodsFor: 'registration' stamp: 'dkh 7/19/2012 11:33'! unregisterProject self class registry unregisterProjectRegistration: self! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 07/26/2013 15:55'! baselineProjectSpec "only one of baselineProjectSpec or configurationProjectSpec should ever be set" ^ baselineProjectSpec! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 07/26/2013 16:01'! baselineProjectSpec: anObject "only one of baselineProjectSpec or configurationProjectSpec should ever be set" self shouldBeMutable. baselineProjectSpec := anObject! ! !MetacelloProjectRegistration methodsFor: 'printing' stamp: 'dkh 6/30/2012 14:24'! printOn: aStream | label versionString descriptions | self configurationProjectSpecIfPresent: [ :spec | label := spec className. versionString := spec versionString ] ifAbsent: [ "baseline" label := self baselineProjectSpec className. versionString := '[baseline]' ]. aStream nextPutAll: label; space; nextPutAll: versionString. (descriptions := self repositoryDescriptions) isEmpty ifTrue: [ ^ self ]. aStream nextPutAll: ' from '. descriptions size = 1 ifTrue: [ aStream nextPutAll: descriptions first ] ifFalse: [ aStream nextPut: ${. descriptions do: [ :description | aStream nextPutAll: description ]. aStream nextPut: $} ]! ! !MetacelloProjectRegistration methodsFor: 'testing' stamp: 'dkh 7/19/2012 21:03'! canUpgradeTo: aProjectRegistration "true if there are no load conflicts OR if the load conflicts involved two cofigurations ONLY and an upgrade is allowed" (self hasLoadConflicts: aProjectRegistration) ifFalse: [ ^ true ]. configurationProjectSpec ifNotNil: [ aProjectRegistration configurationProjectSpec ifNotNil: [ configurationProjectSpec copy ensureProjectLoaded. ^ configurationProjectSpec canUpgradeTo: aProjectRegistration configurationProjectSpec ] ]. ^ false! ! !MetacelloProjectRegistration methodsFor: 'testing' stamp: 'dkh 07/26/2013 16:05'! isValid " has a name and one or the other of the projectSpecs is non-nil" "only one of baselineProjectSpec or configurationProjectSpec should ever be set" projectName ifNil: [ ^ false ]. ^ (configurationProjectSpec notNil and: [ baselineProjectSpec isNil ]) or: [ baselineProjectSpec notNil and: [ configurationProjectSpec isNil ] ]! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 07/26/2013 16:01'! configurationProjectSpec "only one of baselineProjectSpec or configurationProjectSpec should ever be set" ^ configurationProjectSpec! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! baselineProjectSpecIfAbsent: absentBlock ^ baselineProjectSpec ifNil: absentBlock! ! !MetacelloProjectRegistration methodsFor: 'mutability' stamp: 'dkh 7/19/2012 15:11'! isMutable mutable ifNil: [ ^ true ]. ^ mutable! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 6/30/2012 14:25'! repositoryDescriptions ^ (self configurationProjectSpecIfAbsent: [ self baselineProjectSpec ]) repositoryDescriptions! ! !MetacelloProjectRegistration methodsFor: 'comparision' stamp: 'dkh 6/5/2012 19:01:24'! hash ^ ((String stringHash: projectName initialHash: 0) bitXor: configurationProjectSpec metacelloRegistrationHash) bitXor: baselineProjectSpec metacelloRegistrationHash! ! !MetacelloProjectRegistration methodsFor: 'mutability' stamp: 'dkh 7/19/2012 16:06'! shouldBeMutable self isMutable ifTrue: [ ^ self ]. self error: 'Not allowed to modify an immutable object'! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 7/16/2012 12:23'! loadedInImage loadedInImage ifNil: [ loadedInImage := false ]. ^ loadedInImage! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectName ^ projectName! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 6/13/2012 13:52'! version ^ (self configurationProjectSpecIfAbsent: [ ^ MetacelloMCBaselineProject singletonVersionName ]) versionString! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 07/24/2012 17:38'! configurationProjectSpecIfPresent: presentBlock ifAbsent: absentBlock ^ configurationProjectSpec ifNotNil: [ presentBlock cull: configurationProjectSpec ] ifNil: absentBlock! ! !MetacelloProjectRegistration methodsFor: 'lookup' stamp: 'dkh 7/19/2012 20:58'! lookupBaselineSpec baselineProjectSpec ifNotNil: [ :spec | ^ spec ]. ^ configurationProjectSpec! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 6/7/2012 17:37'! baseName ^ MetacelloScriptEngine baseNameOf: (configurationProjectSpec ifNil: [ baselineProjectSpec ]) className! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 07/26/2013 16:01'! configurationProjectSpec: anObject "only one of baselineProjectSpec or configurationProjectSpec should ever be set" self shouldBeMutable. configurationProjectSpec := anObject! ! !MetacelloProjectRegistration methodsFor: 'comparision' stamp: 'dkh 6/5/2012 19:01:24'! = aRegistration aRegistration class == self class ifFalse: [ ^ false ]. ^ (configurationProjectSpec registrationsCompareEqual: aRegistration configurationProjectSpec) and: [ baselineProjectSpec registrationsCompareEqual: aRegistration baselineProjectSpec ]! ! !MetacelloProjectRegistration methodsFor: 'copying' stamp: 'dkh 7/19/2012 15:12'! postCopy super postCopy. mutable := nil! ! !MetacelloProjectRegistration methodsFor: 'lookup' stamp: 'dkh 05/10/2013 08:28'! lookupSpec: aProjectSpec self configurationProjectSpec ifNotNil: [ :spec | spec className = aProjectSpec className ifTrue: [ ^ spec ] ]. self baselineProjectSpec ifNotNil: [ :spec | spec className = aProjectSpec className ifTrue: [ ^ spec ] ]. ^ nil! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 7/17/2012 12:36'! locked locked ifNil: [ locked := false ]. ^ locked! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 07/26/2013 16:42'! merge: aProjectRegistration " ... merge is done when a spec has been loaded into the image" "only one of baselineProjectSpec or configurationProjectSpec should ever be set" self shouldBeMutable. (self isValid and: [ aProjectRegistration isValid ]) ifFalse: [ self error: 'Invalid registrations' ]. aProjectRegistration configurationProjectSpec ifNotNil: [ "use aProjectRegistration's configurationProjectSpec and nil my baselineProjectSpec" configurationProjectSpec := aProjectRegistration configurationProjectSpec. baselineProjectSpec := nil. ^ self ]. aProjectRegistration baselineProjectSpec ifNotNil: [ "use aProjectRegistration's baselineProjectSpec and nil my configurationProjectSpec" configurationProjectSpec := nil. baselineProjectSpec := aProjectRegistration baselineProjectSpec ]! ! !MetacelloProjectRegistration methodsFor: 'mutability' stamp: 'dkh 7/19/2012 16:45'! copyOnWrite: aBlock "assume that only registered projects are immutable ... otherwise you'll get an error" | copy | self class registry registrationFor: self ifPresent: [ :existing | ] ifAbsent: [ aBlock value: self. ^ self ]. self unregisterProject. copy := self copy. aBlock value: copy. copy registerProject. ^ copy! ! !MetacelloProjectRegistration methodsFor: 'accessing' stamp: 'dkh 7/19/2012 16:03'! locked: anObject self shouldBeMutable. locked := anObject! ! !MetacelloProjectRegistration methodsFor: 'testing' stamp: 'dkh 07/28/2013 08:07'! hasLoadConflicts: aProjectRegistration "5 combinations of loads with no load conflicts: No configs and baselines = configs = and no baselines configs = and baselines = configs = and no baseline loaded (self) with a baseline to load (aProjectRegistration) config loaded (self), no config to load (aProjectRegistration) and no baseline loaded(self) with a baseline to load (aProjectRegistration) " self isValid ifFalse: [ self error: 'Invalid projectRegistration: ' , self printString ]. aProjectRegistration isValid ifFalse: [ self error: 'Invalid projectRegistration: ' , aProjectRegistration printString ]. configurationProjectSpec ifNil: [ aProjectRegistration configurationProjectSpec notNil ifTrue: [ ^ baselineProjectSpec hasConflictWithConfiguration: aProjectRegistration configurationProjectSpec ] ] ifNotNil: [ aProjectRegistration configurationProjectSpec ifNotNil: [ (aProjectRegistration configurationProjectSpec hasLoadConflicts: configurationProjectSpec) ifTrue: [ ^ true ] ] ]. ^ baselineProjectSpec ifNil: [ ^ configurationProjectSpec hasConflictWithBaseline: aProjectRegistration baselineProjectSpec ] ifNotNil: [ baselineProjectSpec hasLoadConflicts: aProjectRegistration baselineProjectSpec ]! ! !MetacelloProjectRegistration class methodsFor: 'accessing' stamp: 'dkh 7/19/2012 11:52'! resetRegistry Registry := nil! ! !MetacelloProjectRegistration class methodsFor: 'accessing' stamp: 'dkh 6/13/2012 13:37'! configurationClasses "Return a set of the Metacello configuration classes that have been loaded into the image." "self configurationClasses" | answer | answer := IdentitySet new. ConfigurationOf allSubclasses do: [ :cl | (cl == BaselineOf or: [ cl inheritsFrom: BaselineOf ]) ifFalse: [ answer add: cl ] ]. Object allSubclasses do: [ :cl | (answer includes: cl) ifFalse: [ (([ cl isMetacelloConfig ] on: Error do: [ :ex | ex return: false ]) and: [ cl name asString beginsWith: 'ConfigurationOf' ]) ifTrue: [ answer add: cl ] ] ]. ^ answer! ! !MetacelloProjectRegistration class methodsFor: 'registration' stamp: 'dkh 7/19/2012 21:33'! registerProjectSpec: aProjectSpec ifPresent: presentBlock | newRegistration | newRegistration := aProjectSpec asProjectRegistration. ^ self registry registrationFor: newRegistration ifPresent: [ :existing | presentBlock value: existing value: newRegistration ] ifAbsent: [ newRegistration registerProject ]! ! !MetacelloProjectRegistration class methodsFor: 'accessing' stamp: 'dkh 6/13/2012 13:18'! baselineClasses "Return a set of the Metacello baseline classes that have been loaded into the image." "self baselineClasses" ^ BaselineOf allSubclasses! ! !MetacelloProjectRegistration class methodsFor: 'accessing' stamp: 'dkh 7/19/2012 11:47'! configurationProjectSpecs "MetacelloProjectRegistration configurationProjectSpecs" ^ self registry configurationProjectSpecs! ! !MetacelloProjectRegistration class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! fromMCBaselineProjectSpec: aProjectSpec ^ self new projectName: aProjectSpec name; baselineProjectSpec: aProjectSpec; yourself! ! !MetacelloProjectRegistration class methodsFor: 'querying' stamp: 'dkh 7/19/2012 12:01'! registrationForProjectSpec: aProjectSpec ifAbsent: absentBlock ifPresent: presentBlock | newRegistration | newRegistration := aProjectSpec asProjectRegistration. self registry registrationFor: newRegistration ifPresent: [ :existing | ^ presentBlock value: existing value: newRegistration ] ifAbsent: [ ^ absentBlock value: newRegistration ]! ! !MetacelloProjectRegistration class methodsFor: 'mutability' stamp: 'dkh 7/20/2012 11:37'! copyRegistryWhile: aBlock "install copy of registry for duration of execution." "registrations will be copied on write during execution." "Unconditionally revert to the original version of the registry. Otherwise leave the new copy installed." | oldRegistry newRegistry | oldRegistry := self registry. newRegistry := self registry copy. self registry: newRegistry. aBlock ensure: [ "install old version of registry" self registry: oldRegistry ]! ! !MetacelloProjectRegistration class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! fromMCConfigurationProjectSpec: aProjectSpec ^ self new projectName: aProjectSpec name; configurationProjectSpec: aProjectSpec; yourself! ! !MetacelloProjectRegistration class methodsFor: 'accessing' stamp: 'dkh 7/19/2012 11:51'! primeRegistryFromImage "MetacelloProjectRegistration primeRegistryFromImage" self registry primeRegistryFromImage! ! !MetacelloProjectRegistration class methodsFor: 'querying' stamp: 'dkh 7/19/2012 12:47'! registrationForClassNamed: aClassName ifAbsent: absentBlock ^ self registry registrationForClassNamed: aClassName ifAbsent: absentBlock! ! !MetacelloProjectRegistration class methodsFor: 'accessing' stamp: 'dkh 7/19/2012 11:17'! registry Registry ifNil: [ Registry := MetacelloProjectRegistry new ]. ^ Registry! ! !MetacelloProjectRegistration class methodsFor: 'accessing' stamp: 'dkh 7/19/2012 11:18'! baselineProjectSpecs "MetacelloProjectRegistration baselineProjectSpecs" ^ self registry baselineProjectSpecs! ! !MetacelloProjectRegistration class methodsFor: 'mutability' stamp: 'dkh 7/20/2012 11:37'! copyRegistryRestoreOnErrorWhile: aBlock "install copy of registry for duration of execution." "registrations will be copied on write during execution." "if does not return control to this context, revert to the original version of the registry. Otherwise leave the new copy installed." | oldRegistry newRegistry | oldRegistry := self registry. newRegistry := self registry copy. self registry: newRegistry. aBlock ensure: [ "install old version of registry" self registry: oldRegistry ]. self registry: newRegistry "if control returned, install newRegistry"! ! !MetacelloProjectRegistration class methodsFor: 'accessing' stamp: 'dkh 7/19/2012 11:17'! registry: aMetacelloProjectRegistry Registry := aMetacelloProjectRegistry! ! !MetacelloProjectRegistration class methodsFor: 'querying' stamp: 'dkh 7/19/2012 11:34'! projectSpecForClassNamed: aClassName ifAbsent: absentBlock ^ self registry projectSpecForClassNamed: aClassName ifAbsent: absentBlock! ! !MetacelloProjectRegistration class methodsFor: 'accessing' stamp: 'dkh 7/14/2012 07:47'! projectSpecs "MetacelloProjectRegistration projectSpecs" ^ self configurationProjectSpecs , self baselineProjectSpecs! ! !MetacelloProjectRegistry methodsFor: 'accessing' stamp: 'dkh 7/19/2012 11:13'! projectSpecs "MetacelloProjectRegistration projectSpecs" ^ self configurationProjectSpecs , self baselineProjectSpecs! ! !MetacelloProjectRegistry methodsFor: 'accessing' stamp: 'dkh 05/10/2013 16:42'! isEmpty ^ self configurationProjectSpecs isEmpty and: [ self baselineProjectSpecs isEmpty ]! ! !MetacelloProjectRegistry methodsFor: 'initialization' stamp: 'dkh 07/29/2013 16:18'! primeRegistryFromImage: configurationClasses baselineClasses: baselineClasses "MetacelloProjectRegistration primeRegistryFromImage" baselineClasses do: [ :cl | (self baselineRegistry includesKey: cl name asString) ifFalse: [ "not registered" (self primeRegistryCurrentVersionFor: cl) ifNotNil: [ :version | | projectSpec | projectSpec := (version project projectSpec name: (MetacelloScriptEngine baseNameOf: cl name asString); repositories: version project projectPackage repositories copy; yourself) asBaselineProjectSpec. self primeRegisterLoadedProjectSpec: projectSpec ] ] ]. configurationClasses do: [ :cl | (self configurationRegistry includesKey: cl name asString) ifFalse: [ "not registered" (self primeRegistryCurrentVersionFor: cl) ifNotNil: [ :version | | projectSpec repos projectPackage project | project := version project. projectPackage := project projectPackage. repos := nil. projectPackage ~~ nil ifTrue: [ repos := projectPackage repositories copy ]. projectSpec := (version project projectSpec name: (MetacelloScriptEngine baseNameOf: cl name asString); className: cl name asString; versionString: version versionString; repositories: repos; yourself) asConfigurationProjectSpec. self primeRegisterLoadedProjectSpec: projectSpec ] ] ]! ! !MetacelloProjectRegistry methodsFor: 'accessing' stamp: 'dkh 7/19/2012 11:13'! configurationRegistry configurationRegistry ifNil: [ configurationRegistry := Dictionary new ]. ^ configurationRegistry! ! !MetacelloProjectRegistry methodsFor: 'initialization' stamp: 'dkh 07/27/2013 08:36'! primeRegisterLoadedProjectSpec: projectSpec MetacelloProjectRegistration registrationForProjectSpec: projectSpec ifAbsent: [ :new | new loadedInImage: true; registerProject ] ifPresent: [ :existing :new | existing copyOnWrite: [ :existingCopy | existingCopy loadedInImage: true. existing locked ifFalse: [ "lock takes precedence when priming from image" existingCopy merge: new ] ] ]! ! !MetacelloProjectRegistry methodsFor: 'registration' stamp: 'dkh 7/19/2012 11:33'! unregisterProjectRegistration: aMetacelloProjectRegistration aMetacelloProjectRegistration configurationProjectSpec ifNotNil: [ :spec | self configurationRegistry removeKey: spec className ifAbsent: [ self error: 'unexpectedly missing project registration' ] ]. aMetacelloProjectRegistration baselineProjectSpec ifNotNil: [ :spec | self baselineRegistry removeKey: spec className ifAbsent: [ self error: 'unexpectedly missing project registration' ] ]! ! !MetacelloProjectRegistry methodsFor: 'registration' stamp: 'dkh 7/19/2012 15:27'! registerProjectRegistration: aMetacelloProjectRegistration "unconditionally register ... use with care" aMetacelloProjectRegistration configurationProjectSpec ifNotNil: [ :spec | self configurationRegistry at: spec className ifPresent: [ :existing | (existing configurationProjectSpec registrationsCompareEqual: spec) ifFalse: [ Transcript cr; show: 'REGISTRATION OF INCOMPATABLE PROJECTS: ' , existing printString , ' REPLACED BY ' , aMetacelloProjectRegistration printString ] ]. spec immutable. self configurationRegistry at: spec className put: aMetacelloProjectRegistration ]. aMetacelloProjectRegistration baselineProjectSpec ifNotNil: [ :spec | self baselineRegistry at: spec className ifPresent: [ :existing | (existing baselineProjectSpec registrationsCompareEqual: spec) ifFalse: [ Transcript cr; show: 'REGISTRATION OF INCOMPATABLE PROJECTS: ' , existing printString , ' REPLACED BY ' , aMetacelloProjectRegistration printString ] ]. spec immutable. self baselineRegistry at: spec className put: aMetacelloProjectRegistration ]. aMetacelloProjectRegistration immutable! ! !MetacelloProjectRegistry methodsFor: 'copying' stamp: 'dkh 7/20/2012 11:13'! postCopy super postCopy. baselineRegistry := self baselineRegistry copy. configurationRegistry := self configurationRegistry copy! ! !MetacelloProjectRegistry methodsFor: 'initialization' stamp: 'dkh 07/29/2013 16:58'! primeRegistryCurrentVersionFor: cl ^ [ cl project currentVersion ] on: Error do: [ :ex | Warning signal: 'Error finding current version of ' , cl name asString , '. Probably an invalid specification.'. nil ]! ! !MetacelloProjectRegistry methodsFor: 'initialization' stamp: 'dkh 07/26/2013 07:16'! primeRegistryFromImage "MetacelloProjectRegistration primeRegistryFromImage" self primeRegistryFromImage: MetacelloProjectRegistration configurationClasses baselineClasses: MetacelloProjectRegistration baselineClasses! ! !MetacelloProjectRegistry methodsFor: 'querying' stamp: 'dkh 7/19/2012 12:45'! registrationForClassNamed: aClassName ifAbsent: absentBlock | baseName | baseName := MetacelloScriptEngine baseNameOf: aClassName. self configurationRegistry at: aClassName ifPresent: [ :registration | ^ registration ]. self baselineRegistry at: aClassName ifPresent: [ :registration | ^ registration ]. self configurationRegistry at: 'ConfigurationOf' , baseName ifPresent: [ :registration | ^ registration ]. self baselineRegistry at: 'BaselineOf' , baseName ifPresent: [ :registration | ^ registration ]. ^ absentBlock value! ! !MetacelloProjectRegistry methodsFor: 'accessing' stamp: 'dkh 7/19/2012 11:09'! baselineProjectSpecs "MetacelloProjectRegistration baselineProjectSpecs" | projectSpecs | projectSpecs := OrderedCollection new. self baselineRegistry keysAndValuesDo: [ :className :registration | projectSpecs add: (self projectSpecForClassNamed: className ifAbsent: [ self error: 'not expected' ]) ]. ^ projectSpecs asArray! ! !MetacelloProjectRegistry methodsFor: 'accessing' stamp: 'dkh 7/19/2012 11:11'! baselineRegistry baselineRegistry ifNil: [ baselineRegistry := Dictionary new ]. ^ baselineRegistry! ! !MetacelloProjectRegistry methodsFor: 'accessing' stamp: 'dkh 07/27/2013 08:45'! registrations ^ self baselineRegistry values , self configurationRegistry values! ! !MetacelloProjectRegistry methodsFor: 'registration' stamp: 'dkh 7/19/2012 11:30'! registrationFor: aMetacelloProjectRegistration ifPresent: presentBlock ifAbsent: absentBlock | baseName | baseName := aMetacelloProjectRegistration baseName. aMetacelloProjectRegistration configurationProjectSpec ifNotNil: [ :spec | self configurationRegistry at: spec className ifPresent: [ :existing | ^ presentBlock value: existing ] ]. aMetacelloProjectRegistration baselineProjectSpec ifNotNil: [ :spec | self baselineRegistry at: spec className ifPresent: [ :existing | ^ presentBlock value: existing ] ]. self configurationRegistry at: 'ConfigurationOf' , baseName ifPresent: [ :existing | ^ presentBlock value: existing ]. self baselineRegistry at: 'BaselineOf' , baseName ifPresent: [ :existing | ^ presentBlock value: existing ]. ^ absentBlock value! ! !MetacelloProjectRegistry methodsFor: 'querying' stamp: 'dkh 7/19/2012 11:14'! projectSpecForClassNamed: aClassName ifAbsent: absentBlock ^ (self configurationRegistry at: aClassName ifAbsent: [ ^ (self baselineRegistry at: aClassName ifAbsent: [^absentBlock value]) baselineProjectSpec ]) configurationProjectSpec! ! !MetacelloProjectRegistry methodsFor: 'accessing' stamp: 'dkh 7/19/2012 12:11'! configurationProjectSpecs "MetacelloProjectRegistration configurationProjectSpecs" | projectSpecs | projectSpecs := OrderedCollection new. self configurationRegistry keysAndValuesDo: [ :className :registration | projectSpecs add: (self projectSpecForClassNamed: className ifAbsent: [ self error: 'not expected' ]) ]. ^ projectSpecs asArray! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 9/10/2012 16:05'! file ^ self className! ! !MetacelloProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! loads: anObject constructor: aVersionConstructor aVersionConstructor loadsForProject: anObject! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 07/29/2013 11:18'! canDowngradeTo: aMetacelloProjectSpec (self className = aMetacelloProjectSpec className and: [ self operator == aMetacelloProjectSpec operator ]) ifFalse: [ ^ false ]. self versionOrNil == nil ifTrue: [ "https://github.com/dalehenrich/metacello-work/issues/198#issuecomment-21737458" ^ true ]. ^ (self compareVersions: aMetacelloProjectSpec usingOperator: self operator) not! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! getOperator ^operator! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 07/13/2013 14:22'! compareEqual: aMetacelloProjectSpec "name className versionString operator loads preLoadDoIt postLoadDoIt" ^ self className = aMetacelloProjectSpec className and: [ (self compareVersionsEqual: aMetacelloProjectSpec) and: [ self operator == aMetacelloProjectSpec operator and: [ self loads = aMetacelloProjectSpec loads and: [ self preLoadDoIt value == aMetacelloProjectSpec preLoadDoIt value and: [ self postLoadDoIt value == aMetacelloProjectSpec postLoadDoIt value ] ] ] ] ]! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/24/2012 11:39'! currentlyLoadedClassesInVersion self versionOrNil ifNotNil: [ :vrsn | ^ vrsn currentlyLoadedClassesInVersion ]. ^ #()! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 7/21/2012 14:12'! mergeScriptLoads: aSpec self shouldBeMutable. aSpec loads ifNotNil: [ :otherLoads | self loads ifNil: [ loads := otherLoads ] ifNotNil: [ loads := (loads , otherLoads) asSet asArray ] ]. self loader: aSpec loader! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 7/19/2012 15:09'! setPreLoadDoIt: aSymbol self shouldBeMutable. preLoadDoIt := aSymbol! ! !MetacelloProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! versionString: anObject constructor: aVersionConstructor aVersionConstructor versionStringForProject: anObject! ! !MetacelloProjectSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! projectLabel ^ 'project'! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! preLoadDoIt ^preLoadDoIt! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! getPostLoadDoIt ^postLoadDoIt! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! postLoadDoIt ^postLoadDoIt! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! getRepositories "raw access to iv" ^ nil! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/5/2012 19:01:24'! metacelloRegistrationHash "name className versionString operator loads preLoadDoIt postLoadDoIt" | hash | hash := String stringHash: name initialHash: 0. hash := String stringHash: self className initialHash: hash. hash := String stringHash: self versionString initialHash: hash. hash := String stringHash: self operator asString initialHash: hash. hash := String stringHash: self preLoadDoIt asString initialHash: hash. hash := String stringHash: self postLoadDoIt asString initialHash: hash. ^ hash bitXor: loads hash! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! versionString ^ versionString! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 7/19/2012 10:19'! unregisterProject ^ MetacelloProjectRegistration registrationForProjectSpec: self ifAbsent: [ ] ifPresent: [ :existing :new | existing unregisterProject ]! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 07/25/2013 15:43'! isLocked ^ self registration locked! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 07/29/2013 11:18'! canUpgradeTo: aMetacelloProjectSpec (self className = aMetacelloProjectSpec className and: [ self operator == aMetacelloProjectSpec operator ]) ifFalse: [ ^ false ]. self versionOrNil == nil ifTrue: [ "https://github.com/dalehenrich/metacello-work/issues/198#issuecomment-21737458" ^ true ]. ^ self compareVersions: aMetacelloProjectSpec usingOperator: self operator! ! !MetacelloProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! postLoadDoIt: aSymbol constructor: aVersionConstructor aVersionConstructor postLoadDoItForProject: aSymbol! ! !MetacelloProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! className: aString constructor: aVersionConstructor aVersionConstructor classNameForProject: aString! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! getFile "raw access to iv" ^ nil! ! !MetacelloProjectSpec methodsFor: 'testing' stamp: 'dkh 9/10/2012 15:49'! hasRepository ^ false! ! !MetacelloProjectSpec methodsFor: 'printing' stamp: 'dkh 6/30/2012 13:25'! configShortCutMethodOn: aStream member: aMember indent: indent | hasVersionString hasOperator hasProjectPackage hasLoads hasClassName hasPreLoadDoIt hasPostLoadDoIt | hasClassName := self hasClassName. hasVersionString := self versionString ~~ nil. hasOperator := operator ~~ nil. hasProjectPackage := self hasRepository or: [ hasClassName & (self getFile ~~ nil or: [ className ~= self name ]) ]. hasLoads := self loads ~~ nil. hasPreLoadDoIt := self getPreLoadDoIt ~~ nil. hasPostLoadDoIt := self getPostLoadDoIt ~~ nil. hasClassName | hasOperator | hasProjectPackage | hasLoads | hasPreLoadDoIt | hasPostLoadDoIt ifTrue: [ (aMember methodUpdateSelector == #'copy:' or: [ aMember methodUpdateSelector == #'with:' ]) ifTrue: [ aStream nextPutAll: 'with: ['; cr ] ifFalse: [ aStream nextPutAll: 'overrides: ['; cr ]. aStream tab: indent; nextPutAll: 'spec'. self configMethodBodyOn: aStream indent: indent. aStream nextPutAll: ' ]'. ^ self ]. hasVersionString ifTrue: [ | vs | vs := self versionString. aStream nextPutAll: 'with: '. vs isSymbol ifTrue: [ aStream nextPut: $# ]. aStream nextPutAll: vs asString printString ]! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 7/19/2012 15:09'! setPostLoadDoIt: aSymbol self shouldBeMutable. postLoadDoIt := aSymbol! ! !MetacelloProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! operator: anObject constructor: aVersionConstructor aVersionConstructor operatorForProject: anObject! ! !MetacelloProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! name: aString constructor: aVersionConstructor aVersionConstructor nameForProject: aString! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! preLoadDoIt: anObject anObject setPreLoadDoItInMetacelloSpec: self! ! !MetacelloProjectSpec methodsFor: 'testing' stamp: 'dkh 9/11/2012 09:24'! hasNonVersionStringField | hasVersionString hasOperator hasProjectPackage hasLoads hasClassName hasPreLoadDoIt hasPostLoadDoIt | hasClassName := self hasClassName. hasVersionString := self versionString ~~ nil. hasOperator := operator ~~ nil. hasProjectPackage := (self file ~~ nil and: [ hasClassName and: [ self className ~= self name ] ]) or: [ self hasRepository ]. hasLoads := self loads ~~ nil. hasPreLoadDoIt := self getPreLoadDoIt ~~ nil. hasPostLoadDoIt := self getPostLoadDoIt ~~ nil. ^ hasClassName | hasOperator | hasProjectPackage | hasLoads | hasPreLoadDoIt | hasPostLoadDoIt! ! !MetacelloProjectSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! constructClassName ^ nil! ! !MetacelloProjectSpec methodsFor: 'private' stamp: 'dkh 7/19/2012 16:02'! setLoads: aCollection self shouldBeMutable. loads := aCollection! ! !MetacelloProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! preLoadDoIt: aSymbol constructor: aVersionConstructor aVersionConstructor preLoadDoItForProject: aSymbol! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! projectPackage ^nil! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 7/19/2012 16:03'! name: aString ((aString at: 1) isSeparator or: [ (aString at: aString size) isSeparator ]) ifTrue: [ self error: 'Names are not allowed to have leading or trailing blanks: ' , aString printString ]. self shouldBeMutable. name := aString! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! postLoadDoIt: anObject anObject setPostLoadDoItInMetacelloSpec: self! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 7/19/2012 15:09'! versionString: anObject self shouldBeMutable. versionString := anObject! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! name ^name! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 07/13/2013 14:21'! compareVersionsEqual: aMetacelloProjectSpec | vrsn otherVrsn | vrsn := self versionOrNil. otherVrsn := aMetacelloProjectSpec versionOrNil. vrsn ifNil: [ ^ vrsn = otherVrsn ]. otherVrsn ifNil: [ ^ false ]. ^ vrsn versionNumber = otherVrsn versionNumber! ! !MetacelloProjectSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! hasClassName ^ className ~~ nil! ! !MetacelloProjectSpec methodsFor: 'as yet unclassified' stamp: 'dkh 04/02/2013 20:28'! hasLoadConflicts: aMetacelloProjectSpec ^ (self hasNoLoadConflicts: aMetacelloProjectSpec) not! ! !MetacelloProjectSpec methodsFor: 'printing' stamp: 'dkh 9/10/2012 16:17'! configMethodBodyOn: aStream indent: indent | hasVersionString hasOperator hasProjectPackage hasLoads hasClassName hasPreLoadDoIt hasPostLoadDoIt | hasClassName := self hasClassName. hasVersionString := self versionString ~~ nil. hasOperator := operator ~~ nil. hasProjectPackage := self hasRepository or: [ hasClassName & (self getFile ~~ nil) ]. hasLoads := self loads ~~ nil. hasPreLoadDoIt := self getPreLoadDoIt ~~ nil. hasPostLoadDoIt := self getPostLoadDoIt ~~ nil. hasClassName ifTrue: [ hasVersionString | hasOperator | hasProjectPackage | hasLoads ifTrue: [ aStream cr; tab: indent + 1 ] ifFalse: [ aStream space ]. aStream nextPutAll: 'className: ' , self className printString. hasVersionString | hasPreLoadDoIt | hasPostLoadDoIt | hasOperator | hasLoads | hasProjectPackage ifTrue: [ aStream nextPut: $; ] ]. hasVersionString ifTrue: [ | vs | hasClassName | hasOperator | hasProjectPackage | hasLoads | hasPreLoadDoIt | hasPostLoadDoIt ifTrue: [ aStream cr; tab: indent + 1 ] ifFalse: [ aStream space ]. vs := self versionString. aStream nextPutAll: 'versionString: '. vs isSymbol ifTrue: [ aStream nextPut: $# ]. aStream nextPutAll: vs asString printString. hasPreLoadDoIt | hasPostLoadDoIt | hasOperator | hasProjectPackage | hasLoads ifTrue: [ aStream nextPut: $; ] ]. hasPreLoadDoIt ifTrue: [ hasClassName | hasOperator | hasProjectPackage | hasLoads | hasPreLoadDoIt ifTrue: [ aStream cr; tab: indent + 1 ] ifFalse: [ aStream space ]. aStream nextPutAll: 'preLoadDoIt: '. self preLoadDoIt value isSymbol ifTrue: [ aStream nextPut: $#; nextPutAll: self preLoadDoIt value asString printString ] ifFalse: [ aStream nextPutAll: self preLoadDoIt value asString ]. hasPostLoadDoIt | hasOperator | hasProjectPackage | hasLoads ifTrue: [ aStream nextPut: $; ] ]. hasPostLoadDoIt ifTrue: [ hasClassName | hasOperator | hasProjectPackage | hasLoads | hasPostLoadDoIt ifTrue: [ aStream cr; tab: indent + 1 ] ifFalse: [ aStream space ]. aStream nextPutAll: 'postLoadDoIt: '. self postLoadDoIt value isSymbol ifTrue: [ aStream nextPut: $#; nextPutAll: self postLoadDoIt value asString printString ] ifFalse: [ aStream nextPutAll: self postLoadDoIt value asString ]. hasOperator | hasProjectPackage | hasLoads ifTrue: [ aStream nextPut: $; ] ]. hasOperator ifTrue: [ hasClassName | hasVersionString | hasProjectPackage | hasLoads | hasPreLoadDoIt | hasPostLoadDoIt ifTrue: [ aStream cr; tab: indent + 1 ] ifFalse: [ aStream space ]. aStream nextPutAll: 'operator: #' , self operator asString printString. hasProjectPackage | hasLoads ifTrue: [ aStream nextPut: $; ] ]. hasLoads ifTrue: [ hasClassName | hasVersionString | hasOperator | hasProjectPackage | hasPreLoadDoIt | hasPostLoadDoIt ifTrue: [ aStream cr; tab: indent + 1 ] ifFalse: [ aStream space ]. aStream nextPutAll: 'loads: #('. self loads do: [ :str | aStream nextPutAll: str printString , ' ' ]. aStream nextPut: $). hasProjectPackage ifTrue: [ aStream nextPut: $; ] ]. hasProjectPackage ifTrue: [ | hasName hasRepo | hasRepo := self hasRepository. hasName := self file ~= self className. hasName ifTrue: [ hasClassName | hasVersionString | hasOperator | hasLoads | hasPreLoadDoIt | hasPostLoadDoIt ifTrue: [ aStream cr; tab: indent + 1 ] ifFalse: [ aStream space ]. aStream nextPutAll: 'file: ' , self file printString. hasRepo ifTrue: [ aStream nextPut: $; ] ]. hasRepo ifTrue: [ | repos | repos := self repositories map values. repos size = 1 ifTrue: [ hasClassName | hasVersionString | hasOperator | hasLoads | hasPreLoadDoIt | hasPostLoadDoIt | hasName ifTrue: [ aStream cr; tab: indent + 1 ] ifFalse: [ aStream space ]. repos first configMethodCascadeOn: aStream lastCascade: true ] ifFalse: [ aStream cr. self repositories configMethodCascadeOn: aStream indent: indent ] ] ]! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! getClassName "raw access to iv" ^ className! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 07/13/2013 14:22'! hasNoLoadConflicts: aMetacelloProjectSpec "same as compareEqual:, except if versionString and/or repositories are not specified for either one, then there are not conflicts" ^ self className = aMetacelloProjectSpec className and: [ ((self versionString == nil or: [ aMetacelloProjectSpec versionString == nil ]) or: [ self compareVersionsEqual: aMetacelloProjectSpec ]) and: [ self operator == aMetacelloProjectSpec operator ] ]! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! versionKey "suitable for using as a unique key for the receiver's version in a dictionary" ^ self version versionKey! ! !MetacelloProjectSpec methodsFor: 'adding' stamp: 'dkh 6/5/2012 19:01:24'! addToMetacelloPackages: aMetacelloPackagesSpec | spec | spec := (aMetacelloPackagesSpec project projectReferenceSpec) name: self name; projectReference: self copy; yourself. aMetacelloPackagesSpec addMember: (aMetacelloPackagesSpec addMember name: spec name; spec: spec; yourself) ! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! loads ^ loads! ! !MetacelloProjectSpec methodsFor: 'private' stamp: 'dkh 9/11/2012 11:50'! resolveToLoadableSpec ^self copy! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! versionOrNil ^[ self version ] on: MetacelloVersionDoesNotExistError do: [:ex | ^nil ]. ! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 7/19/2012 16:03'! operator: anObject " #= #~= #> #< #>= #<= #~> " self shouldBeMutable. operator := anObject! ! !MetacelloProjectSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeMap | map | map := super mergeMap. map at: #name put: name. map at: #className put: className. map at: #versionString put: versionString. map at: #operator put: operator. map at: #loads put: loads. map at: #preLoadDoIt put: preLoadDoIt. map at: #postLoadDoIt put: postLoadDoIt. ^map! ! !MetacelloProjectSpec methodsFor: 'loading' stamp: 'dkh 6/5/2012 19:01:24'! load self subclassResponsibility! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! loads: aCollection aCollection setLoadsInMetacelloProject: self! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! operator operator == nil ifTrue: [ ^#>= ]. ^ operator! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 07/29/2013 11:18'! compareVersions: aMetacelloProjectSpec usingOperator: anOperator ^ aMetacelloProjectSpec versionOrNil == nil ifTrue: [ "https://github.com/dalehenrich/metacello-work/issues/199#issuecomment-21739622" aMetacelloProjectSpec versionString asMetacelloVersionNumber perform: anOperator with: self version versionNumber ] ifFalse: [ ^ aMetacelloProjectSpec version perform: anOperator with: self version ]! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! className className ifNil: [ self name ifNotNil: [ self className: self constructClassName ] ]. ^ className! ! !MetacelloProjectSpec methodsFor: 'visiting' stamp: 'dkh 6/5/2012 19:01:24'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock projectBlock value: self! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 7/17/2012 11:19'! registration ^ MetacelloProjectRegistration registrationForProjectSpec: self ifAbsent: [ :ignored | ] ifPresent: [ :existing :new | existing ]! ! !MetacelloProjectSpec methodsFor: 'private' stamp: 'dkh 7/19/2012 16:02'! setName: aStringOrNil self shouldBeMutable. name := aStringOrNil! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! version self subclassResponsibility! ! !MetacelloProjectSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! label ^self name! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 7/19/2012 16:03'! className: aString self shouldBeMutable. className := aString! ! !MetacelloProjectSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! version: anObject constructor: aVersionConstructor aVersionConstructor versionForProject: anObject! ! !MetacelloProjectSpec methodsFor: 'scripting' stamp: 'dkh 6/6/2012 16:05'! registrationsCompareEqual: aMetacelloProjectSpec "name className versionString operator loads preLoadDoIt postLoadDoIt" ^ self className = aMetacelloProjectSpec className and: [ self versionString = aMetacelloProjectSpec versionString and: [ self operator == aMetacelloProjectSpec operator ] ]! ! !MetacelloProjectSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! loadListForVersion: vrsn ^ (self loads == nil or: [self loads isEmpty]) ifTrue: [vrsn spec defaultPackageNames] ifFalse: [self loads]! ! !MetacelloProjectSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodOn: aStream indent: indent aStream tab: indent; nextPutAll: 'spec '; cr; tab: indent + 1; nextPutAll: 'name: ', self name printString, ';'. self configMethodBodyOn: aStream indent: indent. aStream nextPut: $.! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! getPreLoadDoIt ^preLoadDoIt! ! !MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectSpec ^ projectSpec! ! !MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: 'dkh 6/13/2012 15:40'! useDetermineVersionForLoad useDetermineVersionForLoad ifNil: [ useDetermineVersionForLoad := true ]. ^ useDetermineVersionForLoad! ! !MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! overrideProjectSpec: anObject overrideProjectSpec := anObject! ! !MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectSpec: anObject projectSpec := anObject! ! !MetacelloProjectSpecForLoad methodsFor: 'operations' stamp: 'dkh 07/10/2013 22:36'! performCurrentVersionTestAgainst: vrsn operator: anOperator targetVersionStatus: targetVersionStatus using: anMCLoader "answer true if the current state of image is to be left as is" | currentVersion existing new | vrsn ifNil: [ ^ false ]. self useDetermineVersionForLoad ifTrue: [ | prjct cv | self hasOverride ifTrue: [ self error: 'unexpected logic combination: useDeterminVersionForLoad & hasOverride' ]. prjct := self projectSpec projectClassProject. prjct loader: anMCLoader. (cv := prjct currentVersion) == nil ifTrue: [ ^ false ]. (targetVersionStatus includes: cv versionStatus) ifTrue: [ ^ cv perform: anOperator with: vrsn ]. ^ false ]. (self hasOverride not or: [ targetVersionStatus ~= #(#'allLoadedToSpec') ]) ifTrue: [ ^ false ]. (self overrideProjectSpec allPackagesLoaded: anMCLoader) ifFalse: [ "roughly equivalent to versionStatus test above (#'allLoadedToSpec')" ^ false ]. (self overrideProjectSpec isPartiallyLoaded: self overrideProjectSpec copy loader) ifFalse: [ "if the project is not loaded at all" ^ false ]. (currentVersion := self overrideProjectSpec versionOrNil) ifNil: [ ^ false ]. currentVersion = vrsn ifTrue: [ ^ true ]. existing := self overrideProjectSpec asProjectRegistration. new := self projectSpec asProjectRegistration. ^ currentVersion > vrsn ifTrue: [ "answer false if downgrade allowed" (MetacelloAllowProjectDowngrade new existingProjectRegistration: existing; newProjectRegistration: new; signal) == existing ] ifFalse: [ "answer false if upgrade allowed" (MetacelloAllowProjectUpgrade new existingProjectRegistration: existing; newProjectRegistration: new; signal) == existing ]! ! !MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: 'dkh 6/13/2012 15:39'! useDetermineVersionForLoad: anObject useDetermineVersionForLoad := anObject! ! !MetacelloProjectSpecForLoad methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! overrideProjectSpec ^ overrideProjectSpec! ! !MetacelloProjectSpecForLoad methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! hasOverride ^ self overrideProjectSpec ~~ nil! ! !MetacelloProjectSpecForLoad methodsFor: 'operations' stamp: 'dkh 6/14/2012 17:39'! performLoad | displayString spec | spec := self projectSpec. displayString := 'Project: ' , spec name. spec versionString ~~ nil ifTrue: [ displayString := displayString , ' ' , spec versionString ]. Transcript cr; show: displayString. self hasOverride ifTrue: [ | override | override := self overrideProjectSpec copy. override mergeScriptLoads: spec. override loadVersion: nil ] ifFalse: [ spec loadVersion: (self useDetermineVersionForLoad ifTrue: [ spec determineCurrentVersionForLoad ] ifFalse: [ spec versionOrNil ]) ]! ! !MetacelloProjectSpecGenerator methodsFor: 'accessing' stamp: 'dkh 7/16/2012 11:27'! projectSpecLookupBlock ^ [ :projectName | {(MetacelloProjectRegistration projectSpecForClassNamed: (MetacelloScriptEngine baselineNameFrom: projectName) ifAbsent: [ ]). (MetacelloProjectRegistration projectSpecForClassNamed: (MetacelloScriptEngine configurationNameFrom: projectName) ifAbsent: [ ])} ]! ! !MetacelloProjectSpecGenerator methodsFor: 'accessing' stamp: 'dkh 7/16/2012 10:44'! projectSpecListBlock ^ [ MetacelloProjectRegistration projectSpecs ]! ! !MetacelloProjectSpecGenerator methodsFor: 'accessing' stamp: 'dkh 7/16/2012 10:42'! projectSpecCreationBlock ^ [ :projectName | {(MetacelloMCProject new projectSpec name: projectName)} ]! ! !MetacelloProjectSpecGenerator methodsFor: 'accessing' stamp: 'dkh 7/16/2012 10:34'! target ^ target! ! !MetacelloProjectSpecGenerator methodsFor: 'accessing' stamp: 'dkh 7/16/2012 10:34'! target: anObject target := anObject! ! !MetacelloProjectSpecLoadConflict methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! possibleVersions "not applicable to a Conflict error" self shouldNotImplement! ! !MetacelloProjectSpecLoadConflict methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString "not applicable to a Conflict error" self shouldNotImplement! ! !MetacelloProjectSpecLoadConflict methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! isResumable "Determine whether an exception is resumable." ^ true! ! !MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectSpec ^projectSpec! ! !MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString ^ self versionDoesNotExistException versionString! ! !MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectSpec: aMetacelloMCProjectSpec projectSpec := aMetacelloMCProjectSpec! ! !MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionDoesNotExistException ^ versionDoesNotExistException! ! !MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionDoesNotExistException: anObject versionDoesNotExistException := anObject! ! !MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! possibleVersions ^ self versionDoesNotExistException possibleVersions! ! !MetacelloProjectSpecLoadError methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! isResumable "Determine whether an exception is resumable." ^ false! ! !MetacelloProjectSpecLoadError class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! projectSpec: aMetacelloMCProjectSpec ^self new projectSpec: aMetacelloMCProjectSpec; yourself! ! !MetacelloProjectSpecLoadedNotification commentStamp: 'dkh 6/1/2012 09:32'! **MetacelloLoadProjectSpecVersionNotification** is signalled to indicate that the given project spec was loaded into the image.! !MetacelloProjectSpecLoadedNotification methodsFor: 'handlers' stamp: 'dkh 6/7/2012 16:19'! handleResolutionFor: aScriptEngine ^ aScriptEngine handleProjectSpecLoaded: self! ! !MetacelloProjectSpecLoadedNotification methodsFor: 'exception description' stamp: 'dkh 6/5/2012 19:01:24'! defaultAction ^ nil! ! !MetacelloProjectSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testProjectSpec | project | project := self projectSpec. project name: 'Project'; className: 'ConfigurationOfProject'; versionString: '1.0'; versionString: #'stable'; operator: #'<'; operator: nil; loads: 'MyPackage'; loads: #('MyPackage' 'MyTests'); preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself. self assert: project name = 'Project'. self assert: project className = 'ConfigurationOfProject'. self assert: project versionString = #'stable'. self assert: project operator == #'>='. self assert: project loads = #('MyPackage' 'MyTests'). self assert: project preLoadDoIt value == #'preLoadDoIt'. self assert: project postLoadDoIt value == #'postLoadDoIt'. self should: [ project includes: #() ] raise: Error. self should: [ project requires: #() ] raise: Error. self should: [ project answers: #() ] raise: Error. project projectDo: [ :prjct | self assert: project == prjct ] packageDo: [ :ignored | self assert: false ] groupDo: [ :ignored | self assert: false ]. self should: [ project preLoadDoIt: '' ] raise: Error. self should: [ project postLoadDoIt: '' ] raise: Error! ! !MetacelloProjectSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testProjectMergeSpec | projectA projectB project | projectA := self projectSpec name: 'Project'; className: 'ConfigurationOfProject'; versionString: '1.0'; loads: #('MyPackage'); preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself. projectB := self projectSpec name: 'Project'; className: 'ConfigurationOfProjectB'; versionString: #'stable'; operator: #'<'; loads: #('MyPackage' 'MyTests'); preLoadDoIt: #'preLoadDoItB'; postLoadDoIt: #'postLoadDoItB'; yourself. project := projectA mergeSpec: projectB. self assert: project name = 'Project'. self assert: project className = 'ConfigurationOfProjectB'. self assert: project versionString = #'stable'. self assert: project operator == #'<'. self assert: project loads = #('MyPackage' 'MyTests'). self assert: project preLoadDoIt value == #'preLoadDoItB'. self assert: project postLoadDoIt value == #'postLoadDoItB'! ! !MetacelloReferenceConfig methodsFor: 'baseline 1.0' stamp: 'dkh 1/26/2012 11:26:02'! baseline10: spec spec for: #common do: [ "alternate methods for specifying author, blessing, description, timestamp, preLoadDoIt, postLoadDoit (not recommended)" spec blessing: [ spec value: #baseline. ]. spec description: [ spec value: 'Descriptive comment'. ]. spec author: [ spec value: 'dkh'. ]. spec timestamp: [ spec value: '10/7/2009 14:40'. ]. spec timestamp: [ spec value: (DateAndTime fromString: '10/7/2009 14:40'). ]. "recommended methods for specifying author, blessing, description, timestamp, preLoadDoIt, postLoadDoit" "#development, #baseline, #release, #beta, etc." spec blessing: #baseline. spec description: 'Descriptive comment'. spec author: 'dkh'. spec timestamp: (DateAndTime fromString: '10/7/2009 14:40'). spec timestamp: '10/7/2009 14:40'. spec "Before loading packages or projects in this version, send #preloadForVersion to an instance of this config" preLoadDoIt: #preloadForVersion; "After loading packages or projects in this version, send #postloadForVersion to an instance of this config" postLoadDoIt: #postloadForVersion. spec repository: 'http://www.example.com/rr'. spec repository: 'http://www.example.com/private' username: 'foo' password: 'bar'. spec repositories: [ "One or more repositories may be defined (MCReposioryGroup). Previous forms useful when specifying a single reposiory." spec "directory-based repositories" repository: '/opt/mc/repository'; repository: 'c:\pharo\myapp\repo\'; "ftp-based repository ... note, supported in Pharo/Squeak only" repository: 'ftp://ftp.example.com/repo'; "dictionary-based repository ... repository stored at `Smalltalk at: #GlobalName`" repository: 'dictionary://GlobalName'; repository: 'http://www.example.com/rr'; repository: 'http://www.example.com/ar'; repository: 'http://www.example.com/private' username: 'foo' password: 'bar' ]. spec "Create or update a project reference named 'UI Support'" project: 'UI Support' with: [ "One or more of the following attributes may be defined or changed" spec "OPTIONAL: Name of config class (i.e., ConfigurationOfXXX), if not specified, className is assumed to be the name of the project prependended with 'ConfigurationOf'" className: 'ConfigurationOfUI'; "Version of project to be loaded. if theversionString is not specified, then the latest version of the project is used." versionString: '1.0'; "Before loading this project, send #preloadForProject to an instance of this config" preLoadDoIt: #preloadForProject; "After loading this project, send #postloadForProject to an instance of this config" postLoadDoIt: #postloadForProject; "OPTIONAL: Version comparison operator #= #~= #> #< #>= #<= #~> " operator: #~>; "OPTIONAL: List of packages to be loaded from project" loads: #('UI-Core' ); "Optional: Name of package containing the config, by convention same as className" file: 'ConfigurationOfUI'; "Repository where package resides" repository: 'http://www.example.com/r' ]; "Create a new project reference to replace existing project reference" project: 'UI Support' overrides: [ "One or more of the following attributes may be defined" spec className: 'ConfigurationOfUINew'; versionString: '1.0'; operator: #>=; loads: #('UI-Core' 'UI-Tests' ); repository: 'http://www.example.com/r' username: 'foo' password: 'bar' ]; "Create project reference named 'UI Tests'" project: 'UI Tests' "based on c copy of 'UI Support' project" copyFrom: 'UI Support' with: [ "One or more of the following attributes may be changed" spec className: 'ConfigurationOfUI'; versionString: '1.0'; operator: #~>; loads: #('UI-Core' 'UI-Tests' ); repository: 'http://www.example.com/r']; "Change the versionString for 'UI Support' to '1.0.1'" project: 'UI Support' with: '1.0.1'; "Remove the project reference 'UI Tests'" removeProject: 'UI Tests'; "Multiple repositories for configuration - config may be found in either repository. Secondary repository is useful when primary repository may not be available" project: 'UI Multi' with: [ spec className: 'ConfigurationOfMulti'; repository: 'http://www.example.com/r'; repository: 'http://www.example.com/s' ]. "Create or update 'Example-AddOn' package" spec package: 'Example-AddOn' with: [ "One or more of the following attributes may be defined or changed" spec "'Example-Core' must be loaded before 'Example-AddOn'" requires: #('Example-Core' ); "When 'Example-AddOn' is loaded, load 'Example-UI'" includes: #('Example-UI' ); "Explicitly oad version 'Example-AddOn-anon.3' of the package" file: 'Example-AddOn-anon.3'; repositories: [ spec "Load 'Example-AddOn' from the 'http://www.example.com/yar'" repository: 'http://www.example.com/yar'; "or 'http://www.example.com/yas' repositores" repository: 'http://www.example.com/yas']; "Before loading 'Example-AddOn' send #preloadForAddOn to an instance of this config" preLoadDoIt: #preloadForAddOn; "After loading 'Example-AddOn' send #postloadForAddOn to an instance of this config" postLoadDoIt: #postloadForAddOn ]; "Create a new package to replace existing package" package: 'Example-AddOn' overrides: [ "One or more of the following attributes may be defined" spec requires: #('Example-Core' 'UI Support' ); includes: #('Example-UI' ); file: 'Example-AddOn-anon.7'; supplyingAnswers: #( #('list of packages' 'Kernel* Collection*')); repository: 'http://www.example.com/or' username: 'foo' password: 'bar' ; preLoadDoIt: #preloadForAddOn; postLoadDoIt: #postloadForAddOn ]; "Change the package version loaded" package: 'Example-AddOn' with:'Example-AddOn-anon.5'; "Create 'Example-Core' package in project" package: 'Example-Core'; package: 'Example-Tests' with: [ spec requires: #('Example-Core' ) ]; package: 'Example-TestsUI' with: [ spec requires: #('Example-UI' ) ]; package: 'Example-UI' with: [ spec requires: #('Example-AddOn' ) ]; "Remove the package 'Example-Tests'" removePackage: 'Example-Tests'. spec "Create or update the group 'default', adding 'Example-Core' and 'Example-AddOn' to the group." group: 'default' with: #('Example-Core' 'Example-AddOn' ); "Create the group 'default' to replace existing group, consisting of 'Example-Core' and 'Example-AddOn'" group: 'default' overrides: #('Example-Core' 'Example-Tests' ); "Remove the group 'default'" removeGroup: 'default' ]. ! ! !MetacelloReferenceConfig methodsFor: 'accessing' stamp: 'dkh 1/26/2012 11:26:02'! project ^ project ifNil: [ | constructor | "Construct Metacello project" constructor := (Smalltalk at: #MetacelloVersionConstructor) on: self. project := constructor project ]! ! !MetacelloReferenceConfig class methodsFor: 'accessing' stamp: 'dkh 05/07/2013 16:05'! project "force new version as workaround for https://code.google.com/p/smalltalk-hub/issues/detail?id=21" ^ self new project! ! !MetacelloRemoveMemberSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock removeBlock value: self ! ! !MetacelloRemoveMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! methodUpdateSelector ^#remove:! ! !MetacelloRemoveMemberSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! applyToList: aListSpec aListSpec remove: self! ! !MetacelloRepositoriesSpec methodsFor: 'scripting' stamp: 'dkh 6/8/2012 14:04:22'! metacelloRegistrationHash ^ ((self map values sort: [ :a :b | a description <= b description ]) collect: [ :each | each description ]) hash! ! !MetacelloRepositoriesSpec methodsFor: 'scripting' stamp: 'dkh 07/16/2013 19:15'! hasNoLoadConflicts: aMetacelloProjectSpec | repositorySpecs anotherRepositorySpecs | repositorySpecs := self map values sort: [ :a :b | a description <= b description ]. anotherRepositorySpecs := aMetacelloProjectSpec map values sort: [ :a :b | a description <= b description ]. repositorySpecs size ~= anotherRepositorySpecs size ifTrue: [ ^ false ]. 1 to: repositorySpecs size do: [ :index | | repoSpec anotherRepoSpec | repoSpec := repositorySpecs at: index. anotherRepoSpec := anotherRepositorySpecs at: index. (repoSpec hasNoLoadConflicts: anotherRepoSpec) ifFalse: [ ^ false ] ]. ^ true! ! !MetacelloRepositoriesSpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! configMethodCascadeOn: aStream indent: indent | repositorySpecs | repositorySpecs := self map values sort: [:a :b | a description <= b description ]. repositorySpecs size = 1 ifTrue: [ repositorySpecs first configMethodCascadeOn: aStream lastCascade: true ] ifFalse: [ 1 to: repositorySpecs size do: [:index | | repositorySpec | aStream tab: indent + 1. (repositorySpecs at: index) configMethodCascadeOn: aStream lastCascade: index >= repositorySpecs size ]]! ! !MetacelloRepositoriesSpec methodsFor: 'scripting' stamp: 'dkh 6/15/2012 13:40'! compareEqual: aMetacelloProjectSpec | repositorySpecs anotherRepositorySpecs | repositorySpecs := (self map values sort: [ :a :b | a description <= b description ]) collect: [ :each | each description ]. anotherRepositorySpecs := (aMetacelloProjectSpec map values sort: [ :a :b | a description <= b description ]) collect: [ :each | each description ]. ^ repositorySpecs = anotherRepositorySpecs! ! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! add: aStringOrSpec aStringOrSpec addToMetacelloRepositories: self! ! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! merge: aRepositorySpec aRepositorySpec mergeIntoMetacelloRepositories: self! ! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! remove: aRepositorySpec aRepositorySpec removeFromMetacelloRepositories: self! ! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! repository: aStringOrSpec aStringOrSpec addToMetacelloRepositories: self! ! !MetacelloRepositoriesSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! repository: aString username: username password: password constructor: aVersionConstructor aVersionConstructor repositoryForRepositories: aString username: username password: password! ! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! repository: description username: username password: password | spec | spec := (self project repositorySpec) description: description; username: username; password: password; yourself. self addMember: (self addMember name: spec name; spec: spec; yourself)! ! !MetacelloRepositoriesSpec methodsFor: 'construction' stamp: 'dkh 6/8/2012 14:04:22'! repository: anObject constructor: aVersionConstructor aVersionConstructor repositoryForRepositories: anObject! ! !MetacelloRepositoriesSpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! configMethodOn: aStream indent: indent aStream tab: indent; nextPutAll: 'spec'; cr. self configMethodCascadeOn: aStream indent: indent! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testCopyTo | repositories | repositories := self repositoriesSpec. repositories add: (self repositorySpec description: 'http://example.com/repository'; username: 'dkh'; password: 'password'; yourself). self should: [ repositories copy: 'http://example.com/repository' to: (self repositorySpec description: 'http://example.com/alternate/repository'; yourself) ] raise: Error! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testAddE | repositories repository | repositories := self repositoriesSpec. repositories repository: 'http://example.com/repository' username: 'dkh' password: 'password'; repository: '/opt/gemstone/repository'. repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository description = 'http://example.com/repository'. self assert: repository type = 'http'. repository := repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ]. self assert: repository description = '/opt/gemstone/repository'. self assert: repository type = 'directory'! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testAddC | repositories repository | repositories := self repositoriesSpec. repositories add: #('http://example.com/repository' '/opt/gemstone/repository'). repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository description = 'http://example.com/repository'. self assert: repository type = 'http'. repository := repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ]. self assert: repository description = '/opt/gemstone/repository'. self assert: repository type = 'directory'! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testAddB | repositories repository | repositories := self repositoriesSpec. repositories add: (self repositorySpec description: 'http://example.com/repository'; username: 'dkh'; password: 'password'; yourself); add: '/opt/gemstone/repository'. repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository description = 'http://example.com/repository'. self assert: repository type = 'http'. self assert: repository username = 'dkh'. self assert: repository password = 'password'. repository := repositories map at: '/opt/gemstone/repository' ifAbsent: [ self assert: false ]. self assert: repository description = '/opt/gemstone/repository'. self assert: repository type = 'directory'! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testAddA | repositories repository | repositories := self repositoriesSpec. repositories add: (self repositorySpec description: 'http://example.com/repository'; username: 'dkh'; password: 'password'; yourself); add: (self repositorySpec description: 'http://example.com/repository'; username: 'DaleHenrichs'; password: 'secret'; yourself). repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository description = 'http://example.com/repository'. self assert: repository type = 'http'. self assert: repository username = 'DaleHenrichs'. self assert: repository password = 'secret'! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testRemoveA | repositories removed | repositories := self repositoriesSpec. repositories add: (self repositorySpec description: 'http://example.com/repository'; username: 'dkh'; password: 'password'; yourself). repositories remove: (self repositorySpec description: 'http://example.com/repository'; yourself). removed := false. repositories map at: 'http://example.com/repository' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testRemoveB | repositories removed | repositories := self repositoriesSpec. repositories add: (self repositorySpec description: 'http://example.com/repository'; username: 'dkh'; password: 'password'; yourself). repositories remove: {(self repositorySpec description: 'http://example.com/repository'; yourself)}. removed := false. repositories map at: 'http://example.com/repository' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testAddF | repositories repository | repositories := self repositoriesSpec. repositories repository: (self repositorySpec description: 'http://example.com/repository'; username: 'dkh'; password: 'password'; yourself); repository: (self repositorySpec description: 'http://example.com/repository'; username: 'DaleHenrichs'; password: 'secret'; yourself). repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository description = 'http://example.com/repository'. self assert: repository type = 'http'. self assert: repository username = 'DaleHenrichs'. self assert: repository password = 'secret'! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testMergeC | repositories repository | repositories := self repositoriesSpec. repositories add: (self repositorySpec description: 'http://example.com/repository'; username: 'dkh'; password: 'password'; yourself); merge: {(self repositorySpec description: 'http://example.com/repository'; password: 'secret'; yourself). (self repositorySpec description: 'http://example.com/repository'; username: 'DaleHenrichs'; yourself)}. repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository description = 'http://example.com/repository'. self assert: repository type = 'http'. self assert: repository username = 'DaleHenrichs'. self assert: repository password = 'secret'! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testMergeA | repositories repository | repositories := self repositoriesSpec. repositories add: (self repositorySpec description: 'http://example.com/repository'; username: 'dkh'; password: 'password'; yourself); merge: (self repositorySpec description: 'http://example.com/repository'; username: 'DaleHenrichs'; password: 'secret'; yourself). repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository description = 'http://example.com/repository'. self assert: repository type = 'http'. self assert: repository username = 'DaleHenrichs'. self assert: repository password = 'secret'! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testMergeB | repositories repository | repositories := self repositoriesSpec. repositories add: (self repositorySpec description: 'http://example.com/repository'; username: 'dkh'; password: 'password'; yourself); merge: 'http://example.com/repository'. repository := repositories map at: 'http://example.com/repository' ifAbsent: [ self assert: false ]. self assert: repository description = 'http://example.com/repository'. self assert: repository type = 'http'. self assert: repository username = 'dkh'. self assert: repository password = 'password'! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testRemoveC | repositories removed | repositories := self repositoriesSpec. repositories add: (self repositorySpec description: 'http://example.com/repository'; username: 'dkh'; password: 'password'; yourself). repositories remove: {'http://example.com/repository'}. removed := false. repositories map at: 'http://example.com/repository' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testRemoveD | repositories removed | repositories := self repositoriesSpec. repositories add: (self repositorySpec description: 'http://example.com/repository'; username: 'dkh'; password: 'password'; yourself). repositories remove: 'http://example.com/repository'. removed := false. repositories map at: 'http://example.com/repository' ifAbsent: [ removed := true ]. self assert: removed! ! !MetacelloRepositoriesSpecTestCase methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectClass ^ MetacelloMCProject! ! !MetacelloRepositorySpec methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! extractTypeFromDescription ^MetacelloPlatform current extractTypeFromDescription: self description! ! !MetacelloRepositorySpec methodsFor: 'mc support' stamp: 'dkh 07/16/2013 19:35'! hasNoLoadConflicts: aMetacelloProjectSpec self description = aMetacelloProjectSpec description ifTrue: [ ^ true ]. self type = 'github' ifTrue: [ ^ self createRepository hasNoLoadConflicts: aMetacelloProjectSpec createRepository ]. ^ false! ! !MetacelloRepositorySpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! description ^description! ! !MetacelloRepositorySpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! password password == nil ifTrue: [ password := '' ]. ^password! ! !MetacelloRepositorySpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! username username == nil ifTrue: [ username := '' ]. ^username! ! !MetacelloRepositorySpec methodsFor: 'mc support' stamp: 'dkh 6/8/2012 14:04:22'! createRepository | repo | repo := self project createRepository: self. ^ MCRepositoryGroup default repositories detect: [ :each | each = repo ] ifNone: [ repo ]! ! !MetacelloRepositorySpec methodsFor: 'merging' stamp: 'dkh 6/8/2012 14:04:22'! mergeMap | map | map := super mergeMap. map at: #'description' put: description. map at: #'type' put: self type. map at: #'username' put: username. map at: #'password' put: password. ^ map! ! !MetacelloRepositorySpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! password: aString password := aString! ! !MetacelloRepositorySpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! configMethodCascadeOn: aStream lastCascade: lastCascade aStream nextPutAll: 'repository: ', self description printString. (self username isEmpty not or: [ self password isEmpty not ]) ifTrue: [ aStream nextPutAll: ' username: ', self username printString, ' password: ', self password printString ]. lastCascade ifFalse: [ aStream nextPut: $;; cr ]. ! ! !MetacelloRepositorySpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! description: aString description := aString! ! !MetacelloRepositorySpec methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! removeFromMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: (aMetacelloRepositoriesSpec removeMember name: self name; spec: self; yourself)! ! !MetacelloRepositorySpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! username: aString username := aString! ! !MetacelloRepositorySpec methodsFor: 'private' stamp: 'dkh 6/8/2012 14:04:22'! mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: (aMetacelloRepositoriesSpec mergeMember name: self name; spec: self; yourself)! ! !MetacelloRepositorySpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! type type == nil ifTrue: [ type := self extractTypeFromDescription ]. ^type! ! !MetacelloRepositorySpec methodsFor: 'querying' stamp: 'dkh 6/8/2012 14:04:22'! name ^self description! ! !MetacelloRepositorySpec methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! type: aString type := aString! ! !MetacelloRepositorySpec methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! configMethodOn: aStream indent: indent aStream tab: indent; nextPutAll: 'spec '. self configMethodCascadeOn: aStream lastCascade: true! ! !MetacelloRepositorySpec methodsFor: 'adding' stamp: 'dkh 6/8/2012 14:04:22'! addToMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: (aMetacelloRepositoriesSpec addMember name: self name; spec: self; yourself)! ! !MetacelloRepositorySpecTestCase methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! projectClass ^ MetacelloMCProject! ! !MetacelloRepositorySpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testRepositorySpec | repository | repository := self repositorySpec description: '/opt/gemstone/repository'; username: 'dkh'; password: 'password'; type: 'directory'; yourself. self assert: repository name = repository description. self assert: repository description = '/opt/gemstone/repository'. self assert: repository username = 'dkh'. self assert: repository password = 'password'. self assert: repository type = 'directory'. repository := self repositorySpec description: '/opt/gemstone/repository'; yourself. self assert: repository description = '/opt/gemstone/repository'. self assert: repository type = 'directory'. repository := self repositorySpec description: 'http://example.com/repository'; yourself. self assert: repository description = 'http://example.com/repository'. self assert: repository type = 'http'! ! !MetacelloRepositorySpecTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 15:41:23.319'! testRepositoryMergeSpec | repositoryA repositoryB repository | repositoryA := self repositorySpec description: '/opt/gemstone/repository'; username: 'dkh'; password: 'password'; type: 'directory'; yourself. repositoryB := self repositorySpec description: 'http://example.com/repository'; password: 'secret'; yourself. repository := repositoryA mergeSpec: repositoryB. self assert: repository description = 'http://example.com/repository'. self assert: repository username = 'dkh'. self assert: repository password = 'secret'. self assert: repository type = 'http'! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 10:19:43.983'! testDictionaryRepository | project pkg repoSpec repo | project := self project. pkg := (project version: '1.5-baseline') packageNamed: 'Example-Core'. repoSpec := pkg repositorySpecs first. self assert: repoSpec type = 'dictionary'. repo := repoSpec createRepository. self assert: repo class == MCDictionaryRepository. self assert: repo dictionary == (Smalltalk at: #'Metacello_Platform_Test_GlobalDictionary') dictionary! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: 'BenComan 3/21/2014 22:06'! testAsRepositorySpecFor | project testBlock | project := self project. testBlock := [ :pkg :expectedType1 :expectedType2 | | repoSpec1 repo repoSpec2 | repoSpec1 := pkg repositorySpecs first. self assert: repoSpec1 type = expectedType1. repo := repoSpec1 createRepository. repoSpec2 := repo asRepositorySpecFor: project. self assert: repoSpec2 type = expectedType2. expectedType1 = expectedType2 ifTrue: [ self assert: repoSpec1 description asFileReference fullName = repoSpec2 description asFileReference fullName ] ifFalse: [ "special case for standard directory type that defaults to MCServerDirectoryRepository" self assert: (repoSpec1 description copyFrom: 'server://' size + 1 to: repoSpec1 description size) = repoSpec2 description ] ]. testBlock value: ((project version: '1.0-baseline') packageNamed: 'Example-Core') value: 'directory' value: 'directory'. testBlock value: ((project version: '1.3-baseline') packageNamed: 'Example-Core') value: 'ftp' value: 'ftp'. testBlock value: ((project version: '1.4-baseline') packageNamed: 'Example-Core') value: 'http' value: 'http'. testBlock value: ((project version: '1.5-baseline') packageNamed: 'Example-Core') value: 'dictionary' value: 'dictionary'! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'baselines' stamp: 'dkh 6/12/2012 10:19:43.983'! baseline13: spec spec for: #'squeakCommon' do: [ spec package: 'Example-Core' with: [ spec includes: 'Example-AddOn'; file: 'Example-Core-anon.1'; repository: 'ftp://ftp.example.com/examples' ] ]! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 10:19:43.983'! testHttpRepository | project pkg repoSpec repo | project := self project. pkg := (project version: '1.4-baseline') packageNamed: 'Example-Core'. repoSpec := pkg repositorySpecs first. self assert: repoSpec type = 'http'. repo := repoSpec createRepository. self assert: repo class == MCHttpRepository. self assert: repo description = 'http://example.com/examples'! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'running' stamp: 'dkh 6/12/2012 10:19:43.983'! tearDown super tearDown. Smalltalk removeKey: #'Metacello_Platform_Test_GlobalDictionary' ifAbsent: [ ]! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'baselines' stamp: 'dkh 7/12/2013 07:03'! baseline16: spec spec for: #'common' do: [ spec package: 'Example-Core' with: [ spec includes: 'Example-AddOn'; file: 'Example-Core-anon.1'; repository: 'filetree://' , MCFileTreeFileUtils current default fullName , '/temp/repo' ] ] ! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'baselines' stamp: 'dkh 6/12/2012 10:19:43.983'! baseline14: spec spec for: #'common' do: [ spec package: 'Example-Core' with: [ spec includes: 'Example-AddOn'; file: 'Example-Core-anon.1'; repository: 'http://example.com/examples' ] ]! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'accessing' stamp: 'dkh 5/7/2013 19:11'! project "force new version as workaround for https://code.google.com/p/smalltalk-hub/issues/detail?id=21" | constructor project | "Construct Metacello project" constructor := MetacelloVersionConstructor on: self. project := constructor project. project loader: MetacelloNullRecordingMCSpecLoader new. ^project! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'baselines' stamp: 'dkh 6/12/2012 10:19:43.983'! baseline15: spec spec for: #'common' do: [ spec package: 'Example-Core' with: [ spec includes: 'Example-AddOn'; file: 'Example-Core-anon.1'; repository: 'dictionary://Metacello_Platform_Test_GlobalDictionary' ] ]! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'running' stamp: 'dkh 6/12/2012 10:19:43.983'! setUp super setUp. Smalltalk at: #'Metacello_Platform_Test_GlobalDictionary' put: (MCDictionaryRepository new description: 'dictionary://Metacello_Platform_Test_GlobalDictionary'; yourself)! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: 'BenComan 3/21/2014 22:10'! testDirectoryRepository | project pkg repoSpec repo | project := self project. pkg := (project version: '1.0-baseline') packageNamed: 'Example-Core'. repoSpec := pkg repositorySpecs first. self assert: repoSpec type = 'directory'. repo := repoSpec createRepository. self assert: repo class == MCDirectoryRepository. self assert: repo description = '/opt/mcexamples' asFileReference fullName! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'baselines' stamp: 'dkh 6/12/2012 10:19:43.983'! baseline10: spec spec for: #'common' do: [ spec package: 'Example-Core' with: [ spec includes: 'Example-AddOn'; file: 'Example-Core-anon.1'; repository: '/opt/mcexamples' ] ]! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: 'DamienCassou 4/4/2014 15:30'! testFileTreeRepository "must create repository against an existing directory" | project pkg repoSpec repo fileUtils workingDir tempDir repoDir | fileUtils := MCFileTreeFileUtils current. workingDir := fileUtils default. tempDir := fileUtils directoryFromPath: 'temp' relativeTo: workingDir. [ fileUtils ensureDirectoryExists: tempDir. repoDir := fileUtils directoryFromPath: 'repo' relativeTo: tempDir. fileUtils ensureDirectoryExists: repoDir. project := self project. pkg := (project version: '1.6-baseline') packageNamed: 'Example-Core'. repoSpec := pkg repositorySpecs first. self assert: repoSpec type = 'filetree'. repo := repoSpec createRepository. self assert: repo class == (Smalltalk at: #'MCFileTreeRepository' ifAbsent: [ ]). self assert: repo description equals: ('filetree://' , (fileUtils default fullName , '/temp/repo') asFileReference fullName )] ensure: [ (fileUtils directoryExists: tempDir) ifTrue: [ fileUtils deleteAll: tempDir ] ] ! ! !MetacelloRepositorySqueakCommonTestCase methodsFor: 'tests' stamp: 'dkh 6/12/2012 10:19:43.983'! testFtpRepository | project pkg repoSpec repo | project := self project. pkg := (project version: '1.3-baseline') packageNamed: 'Example-Core'. repoSpec := pkg repositorySpecs first. self assert: repoSpec type = 'ftp'. repo := repoSpec createRepository. self assert: repo class == MCFtpRepository. self assert: repo host = 'ftp.example.com'. self assert: repo directory = 'examples'! ! !MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: 'dkh 6/7/2012 15:25'! disallow "default action" self resume: self existingProjectRegistration! ! !MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: 'dkh 7/18/2012 16:42'! defaultAction "Result of signal should be the projectRegistration to be used to perform the load ... default is to disallow" ^ self existingProjectRegistration! ! !MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: 'dkh 7/18/2012 16:40'! allow self checkAllowed. self resume: self newProjectRegistration! ! !MetacelloResolveProjectUpgrade methodsFor: 'accessing' stamp: 'dkh 5/29/2012 16:30'! newProjectRegistration: anObject newProjectRegistration := anObject! ! !MetacelloResolveProjectUpgrade methodsFor: 'private' stamp: 'dkh 07/25/2013 04:44'! checkAllowed self existingProjectRegistration locked ifTrue: [ self resume: (MetacelloAllowLockedProjectChange new operationString: self operationString; existingProjectRegistration: self existingProjectRegistration; newProjectRegistration: self newProjectRegistration; signal) ]! ! !MetacelloResolveProjectUpgrade methodsFor: 'handlers' stamp: 'dkh 7/24/2012 11:37'! handleOnDownGrade: onDownGradeBlock onUpgrade: onUpgradeBlock self subclassResponsibility! ! !MetacelloResolveProjectUpgrade methodsFor: 'accessing' stamp: 'dkh 5/29/2012 16:30'! newProjectRegistration ^ newProjectRegistration! ! !MetacelloResolveProjectUpgrade methodsFor: 'accessing' stamp: 'dkh 7/18/2012 17:08'! operationString self subclassResponsibility! ! !MetacelloResolveProjectUpgrade methodsFor: 'exception handling' stamp: 'dkh 07/25/2013 11:57'! allowEvenIfLocked "for internal ScriptEngine use only. from the Scripting API use: onLocked: [:ex | ex allow] " self resume: self newProjectRegistration! ! !MetacelloResolveProjectUpgrade methodsFor: 'accessing' stamp: 'dkh 5/29/2012 16:30'! existingProjectRegistration: anObject existingProjectRegistration := anObject! ! !MetacelloResolveProjectUpgrade methodsFor: 'accessing' stamp: 'dkh 5/29/2012 16:30'! existingProjectRegistration ^ existingProjectRegistration! ! !MetacelloScriptApiExecutor commentStamp: 'dkh 7/12/2012 14:49'! MetacelloScriptExecutor decodes script args and launches MetacelloScriptEngine to run for each projectSpec encounters...i,e., primarily here to handl array and block args to configuration:, baseline: or project:.! !MetacelloScriptApiExecutor methodsFor: 'execution callback' stamp: 'dkh 7/16/2012 15:56'! executeCollection: aCollection do: projectSpecBlock self projectSpecsFromRepositoryArg do: [ :projectSpec | (aCollection includes: (MetacelloScriptEngine baseNameOf: projectSpec className)) ifTrue: [ projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ] ]! ! !MetacelloScriptApiExecutor methodsFor: 'execution callback' stamp: 'dkh 7/16/2012 15:59'! executeBlock: selectBlock do: projectSpecBlock (self projectSpecsFromRepositoryArg select: selectBlock) do: [ :projectSpec | projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ]! ! !MetacelloScriptApiExecutor methodsFor: 'execution callback' stamp: 'dkh 7/16/2012 16:38'! projectSpecsFromRepositoryArg | spec repo projectSpecs | repositoryArg ifNil: [ ^ #() ]. spec := (projectSpecGenerator projectSpecCreationBlock value: 'xxx') first. repo := spec project createRepository: (spec project repositorySpec description: repositoryArg). projectSpecs := OrderedCollection new. ((Gofer new disablePackageCache repository: repo; allResolved) collect: [ :resolvedReference | resolvedReference packageName ]) asSet do: [ :packageName | (projectSpecGenerator projectSpecCreationBlock value: (MetacelloScriptEngine baseNameOf: packageName)) do: [ :projectSpec | projectSpec className = packageName ifTrue: [ projectSpecs add: (self applyArgsToProjectSpec: projectSpec copy) ] ] ]. ^ projectSpecs! ! !MetacelloScriptApiExecutor methodsFor: 'execution callback' stamp: 'dkh 7/16/2012 17:10'! executeString: aString do: projectSpecBlock self singleRoot: true. (projectSpecGenerator projectSpecCreationBlock value: aString) do: [ :projectSpec | projectSpec ifNotNil: [ projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ] ]! ! !MetacelloScriptEngine commentStamp: 'dkh 7/12/2012 14:48'! MetacelloScriptEngine runs the execution of the script for one projectSpec! !MetacelloScriptEngine methodsFor: 'defaults' stamp: 'dkh 7/23/2012 10:02'! defaultVersionString ^ self class defaultVersionString! ! !MetacelloScriptEngine methodsFor: 'options' stamp: 'dkh 7/12/2012 14:25'! ignoreImage ^ self options at: #'ignoreImage' ifAbsent: [ false ]! ! !MetacelloScriptEngine methodsFor: 'accessing' stamp: 'dkh 7/12/2012 14:26'! projectSpec ^ projectSpec! ! !MetacelloScriptEngine methodsFor: 'accessing' stamp: 'dkh 7/12/2012 14:25'! root ^ root! ! !MetacelloScriptEngine methodsFor: 'handlers' stamp: 'dkh 7/12/2012 14:25'! handleLookupProjectSpec: exception ^ exception resume: ((self lookupProjectSpecFor: exception projectSpec) ifNil: [ ^ exception resume: exception projectSpec ])! ! !MetacelloScriptEngine methodsFor: 'project lookup' stamp: 'dkh 7/12/2012 14:25'! getBaselineUnconditionalLoad: unconditionalLoad | spec | spec := self projectSpec. Smalltalk at: spec className asSymbol ifPresent: [ :cl | unconditionalLoad ifFalse: [ ^ cl ] ]. (spec := self lookupProjectSpecFor: spec) projectPackage load. ^ Smalltalk at: spec className asSymbol! ! !MetacelloScriptEngine methodsFor: 'options' stamp: 'dkh 7/23/2012 19:31'! repositoryOverrides ^ (self options at: #'repositoryOverrides' ifAbsent: [ ^ nil ]) collect: [ :description | (MetacelloMCProject new repositorySpec description: description) createRepository ]! ! !MetacelloScriptEngine methodsFor: 'options' stamp: 'dkh 7/12/2012 14:25'! useCurrentVersion "private option used to implement the classic mode" ^ self options at: #'useCurrentVersion' ifAbsent: [ false ]! ! !MetacelloScriptEngine methodsFor: 'handlers' stamp: 'dkh 07/24/2013 17:07'! handleNotificationsForAction: actionBlock [ [ [ actionBlock on: MetacelloLookupProjectSpec , MetacelloLookupProjectSpecForLoad , MetacelloProjectSpecLoadedNotification , MetacelloScriptEnsureProjectLoadedForDevelopment , MetacelloLookupBaselineSpecForEnsureLoad do: [ :ex | "lookup and registration handlers need to be innermost set of handlers ...they may throw option notifications" ex handleResolutionFor: self ] ] on: MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade , MetacelloAllowConflictingProjectUpgrade do: [ :ex | "option handlers need to be outermost set of handlers ... last line of defense before users are involved" ex handleResolutionFor: self ] ] on: MetacelloAllowLockedProjectChange do: [ :ex | "MetacelloAllowLockedProjectChange need to be outermost handler ... since it is signaled from second line of handlers" ex handleResolutionFor: self ] ] on: Warning do: [ :ex | "Warning is absolute outermost handler" self handleWarning: ex ]! ! !MetacelloScriptEngine methodsFor: 'project lookup' stamp: 'dkh 7/12/2012 14:25'! getBaselineProjectUnconditionalLoad: unconditionalLoad | project | project := (self getBaselineUnconditionalLoad: unconditionalLoad) project. project version spec repositories: self repositories copy. ^ project! ! !MetacelloScriptEngine methodsFor: 'options' stamp: 'dkh 7/23/2012 16:30'! cacheRepository ^ (MetacelloMCProject new repositorySpec description: (self options at: #'cacheRepository' ifAbsent: [ ^ nil ])) createRepository! ! !MetacelloScriptEngine methodsFor: 'actions api' stamp: 'dkh 04/03/2013 12:31'! lock | spec | MetacelloProjectRegistration copyRegistryRestoreOnErrorWhile: [ self setDefaultsAndValidate: self projectSpec copy. "don't add defaults" spec := self projectSpec. MetacelloProjectRegistration registrationForProjectSpec: spec ifAbsent: [ :new | new locked: true; registerProject ] ifPresent: [ :existing :new | existing copyOnWrite: [ :existingCopy | existingCopy locked: true. spec copyForRegistration: existingCopy onWrite: [ :specCopy | specCopy ifNil: [ existingCopy merge: new ] ifNotNil: [ specCopy mergeScriptRepository: spec. spec := specCopy ] ] ] ]. self root: spec ]! ! !MetacelloScriptEngine methodsFor: 'defaults' stamp: 'dkh 7/23/2012 11:09'! defaultRepositoryDescription ^ self class defaultRepositoryDescription! ! !MetacelloScriptEngine methodsFor: 'project lookup' stamp: 'dkh 7/12/2012 14:25'! getConfigurationUnconditionalLoad: unconditionalLoad | spec | spec := self projectSpec. Smalltalk at: spec className asSymbol ifPresent: [ :cl | unconditionalLoad ifFalse: [ ^ cl ] ]. (spec := self lookupProjectSpecFor: spec) projectPackage load. ^ Smalltalk at: spec className asSymbol! ! !MetacelloScriptEngine methodsFor: 'accessing' stamp: 'dkh 7/12/2012 14:25'! options options ifNil: [ options := Dictionary new ]. ^ options! ! !MetacelloScriptEngine methodsFor: 'accessing' stamp: 'dkh 7/12/2012 14:33'! options: aDictionary options := aDictionary! ! !MetacelloScriptEngine methodsFor: 'actions api' stamp: 'dkh 7/23/2012 15:53'! record: required self fetchRecord: [ :version | required isEmpty ifTrue: [ version record ] ifFalse: [ version record: required ] ] required: required! ! !MetacelloScriptEngine methodsFor: 'accessing' stamp: 'dkh 7/12/2012 14:25'! repositories ^ self projectSpec repositories! ! !MetacelloScriptEngine methodsFor: 'handlers' stamp: 'dkh 07/24/2013 15:38'! handleWarning: exception ^ (self options at: #'onWarning' ifAbsent: [ ^ exception pass ]) cull: exception! ! !MetacelloScriptEngine methodsFor: 'actions api' stamp: 'dkh 07/01/2013 06:09'! load: required onProjectDownGrade: onDownGradeBlock onProjectUpgrade: onUpgradeBlock MetacelloProjectRegistration copyRegistryRestoreOnErrorWhile: [ self handleNotificationsForAction: [ | version loadedSpec | self setDefaultsAndValidateProjectSpec. [ loadedSpec := (self lookupProjectSpecFor: self projectSpec) copy ] on: MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade do: [ :ex | ex handleOnDownGrade: onDownGradeBlock onUpgrade: onUpgradeBlock ]. version := loadedSpec versionForScriptEngine: self. self root: (required isEmpty ifTrue: [ version load ] ifFalse: [ version load: required ]) loadDirective. loadedSpec loads: required. MetacelloProjectRegistration registrationForProjectSpec: loadedSpec ifAbsent: [ :new | new loadedInImage: true; registerProject ] ifPresent: [ :existing :new | existing copyOnWrite: [ :existingCopy | existingCopy loadedInImage: true; merge: new ] ] ] ]! ! !MetacelloScriptEngine methodsFor: 'accessing' stamp: 'dkh 7/12/2012 14:25'! root: anObject root := anObject! ! !MetacelloScriptEngine methodsFor: 'project lookup' stamp: 'dkh 04/03/2013 12:34'! setDefaultsAndValidateProjectSpec "NOTE: projectSpec has defaults assigned if versionString or repository missing" self setDefaultsAndValidate: self projectSpec! ! !MetacelloScriptEngine methodsFor: 'handlers' stamp: 'dkh 7/24/2012 11:43'! handleEnsureProjectLoadedForDevelopment: exception "if useCurrentVersion resume with true, else resume with false" ^ exception resume: self useCurrentVersion! ! !MetacelloScriptEngine methodsFor: 'actions api' stamp: 'dkh 04/03/2013 12:30'! list self setDefaultsAndValidateProjectSpec. self root: self projectSpec! ! !MetacelloScriptEngine methodsFor: 'project lookup' stamp: 'dkh 7/12/2012 14:25'! getConfigurationProjectUnconditionalLoad: unconditionalLoad ^ (self getConfigurationUnconditionalLoad: unconditionalLoad) project! ! !MetacelloScriptEngine methodsFor: 'handlers' stamp: 'dkh 07/24/2013 17:08'! handleLock: exception ^ (self options at: #'onLock' ifAbsent: [ ^ exception pass ]) cull: exception cull: exception existingProjectRegistration cull: exception newProjectRegistration! ! !MetacelloScriptEngine methodsFor: 'project lookup' stamp: 'dkh 05/11/2013 07:45'! lookupProjectSpecFor: aProjectSpec "if there is no conflict, choose new spec" | registration loadedSpec | registration := MetacelloProjectRegistration registrationForProjectSpec: aProjectSpec ifAbsent: [ :new | new ] ifPresent: [ :existing :new | (existing hasLoadConflicts: new) ifTrue: [ ((existing canUpgradeTo: new) ifTrue: [ MetacelloAllowProjectUpgrade new ] ifFalse: [ (existing canDowngradeTo: new) ifTrue: [ MetacelloAllowProjectDowngrade new ] ifFalse: [ MetacelloAllowConflictingProjectUpgrade new ] ]) existingProjectRegistration: existing; newProjectRegistration: new; signal ] ifFalse: [ new ] ]. ^ registration lookupSpec: aProjectSpec! ! !MetacelloScriptEngine methodsFor: 'actions api' stamp: 'dkh 04/03/2013 12:30'! fetchRecord: fetchRecordBlock required: required MetacelloProjectRegistration copyRegistryWhile: [ self handleNotificationsForAction: [ | version loadedSpec | self setDefaultsAndValidateProjectSpec. [ loadedSpec := self lookupProjectSpecFor: self projectSpec ] on: MetacelloAllowProjectDowngrade , MetacelloAllowProjectUpgrade do: [ :notification | notification handleOnDownGrade: [ :ex :existing :new | ex allowEvenIfLocked ] onUpgrade: [ :ex :existing :new | ex allowEvenIfLocked ] ]. version := loadedSpec versionForScriptEngine: self. self root: (fetchRecordBlock value: version) loadDirective ] ]! ! !MetacelloScriptEngine methodsFor: 'handlers' stamp: 'dkh 05/11/2013 07:51'! handleLookupProjectSpecForLoad: exception "if overrideProjectSpec is nil, use currentVersion in image, ignoreImage is false" | requested override | requested := exception projectSpec. override := self useCurrentVersion ifTrue: [ "don't do lookup in registry if we expect to use the #currentVersion calculation" nil ] ifFalse: [ | registered | registered := self lookupProjectSpecFor: exception projectSpec. (registered compareEqual: requested) ifFalse: [ "counts as override, only if they differ in some aspect" override := registered ] ]. ^ exception resume: (MetacelloProjectSpecForLoad new projectSpec: requested; useDetermineVersionForLoad: self useCurrentVersion; overrideProjectSpec: override; yourself)! ! !MetacelloScriptEngine methodsFor: 'accessing' stamp: 'dkh 7/12/2012 14:26'! projectSpec: aProjectSpec projectSpec := aProjectSpec! ! !MetacelloScriptEngine methodsFor: 'accessing' stamp: 'dkh 7/12/2012 14:25'! projectName ^ self projectSpec name! ! !MetacelloScriptEngine methodsFor: 'handlers' stamp: 'dkh 05/11/2013 07:53'! handleLookupBaselineSpecForEnsureLoad: exception "if requested and registered don't compare equal, then ensure the new baseline is loaded" | requested registered | requested := exception projectSpec. registered := self lookupProjectSpecFor: exception projectSpec. ^ exception resume: (registered compareEqual: requested) not! ! !MetacelloScriptEngine methodsFor: 'actions api' stamp: 'dkh 04/03/2013 12:31'! unlock | spec | MetacelloProjectRegistration copyRegistryRestoreOnErrorWhile: [ self setDefaultsAndValidate: self projectSpec copy. "don't add defaults" spec := self projectSpec. MetacelloProjectRegistration registrationForProjectSpec: spec ifAbsent: [ :ignored | ] ifPresent: [ :existing :new | existing copyOnWrite: [ :existingCopy | existingCopy locked: false ] ]. self root: spec ]! ! !MetacelloScriptEngine methodsFor: 'handlers' stamp: 'dkh 7/12/2012 14:25'! handleDowngrade: exception ^ (self options at: #'onDowngrade' ifAbsent: [ ^ exception pass ]) cull: exception cull: exception existingProjectRegistration cull: exception newProjectRegistration! ! !MetacelloScriptEngine methodsFor: 'actions api' stamp: 'dkh 7/20/2012 16:17'! load: required self load: required onProjectDownGrade: [ :ex :existing :new | ex allowEvenIfLocked ] onProjectUpgrade: [ :ex :existing :new | ex allowEvenIfLocked ]! ! !MetacelloScriptEngine methodsFor: 'actions api' stamp: 'dkh 7/23/2012 15:53'! fetch: required self fetchRecord: [ :version | required isEmpty ifTrue: [ version fetch ] ifFalse: [ version fetch: required ] ] required: required! ! !MetacelloScriptEngine methodsFor: 'actions api' stamp: 'dkh 04/03/2013 12:30'! get " load a fresh copy from repo" | spec projectPackage | MetacelloProjectRegistration copyRegistryRestoreOnErrorWhile: [ self setDefaultsAndValidateProjectSpec. spec := self projectSpec. projectPackage := spec projectPackage. projectPackage repositorySpecs do: [ :repoSpec | repoSpec createRepository flushForScriptGet ]. projectPackage load. self root: (Smalltalk at: spec className asSymbol) project. MetacelloProjectRegistration registrationForProjectSpec: spec ifAbsent: [ :new | new registerProject ] ifPresent: [ :existing :new | existing copyOnWrite: [ :existingCopy | spec copyForRegistration: existingCopy onWrite: [ :specCopy | specCopy ifNil: [ existingCopy merge: new ] ifNotNil: [ specCopy mergeScriptRepository: spec ] ] ] ] ]! ! !MetacelloScriptEngine methodsFor: 'handlers' stamp: 'dkh 7/12/2012 14:25'! handleConflict: exception ^ (self options at: #'onConflict' ifAbsent: [ ^ exception pass ]) cull: exception cull: exception existingProjectRegistration cull: exception newProjectRegistration! ! !MetacelloScriptEngine methodsFor: 'options' stamp: 'dkh 7/12/2012 14:25'! silently ^ self options at: #'silently' ifAbsent: [ false ]! ! !MetacelloScriptEngine methodsFor: 'handlers' stamp: 'dkh 7/12/2012 14:25'! handleUpgrade: exception ^ (self options at: #'onUpgrade' ifAbsent: [ ^ exception pass ]) cull: exception cull: exception existingProjectRegistration cull: exception newProjectRegistration! ! !MetacelloScriptEngine methodsFor: 'handlers' stamp: 'dkh 7/19/2012 20:48'! handleProjectSpecLoaded: exception MetacelloProjectRegistration registrationForProjectSpec: exception projectSpec ifAbsent: [ :new | new loadedInImage: true; registerProject ] ifPresent: [ :existing :new | "unconditionally merge new with existing (updates registration)" existing copyOnWrite: [ :existingCopy | existingCopy loadedInImage: true; merge: new ] ]. exception resume! ! !MetacelloScriptEngine methodsFor: 'project lookup' stamp: 'dkh 04/03/2013 12:29'! setDefaultsAndValidate: aProjectSpec "NOTE: aProjectSpec has defaults assigned if versionString or repository missing" | issues | issues := aProjectSpec validateForScriptLoad: self withDefaultVersionString: self defaultVersionString withDefaultRepositoryDecription: self defaultRepositoryDescription. issues isEmpty ifTrue: [ ^ self ]. (MetacelloValidationFailure issues: issues message: 'Project spec validation failure') signal! ! !MetacelloScriptEngine class methodsFor: 'defaults' stamp: 'dkh 7/23/2012 10:03'! defaultVersionString DefaultVersionString ifNil: [ DefaultVersionString := #'stable' ]. ^ DefaultVersionString! ! !MetacelloScriptEngine class methodsFor: 'utility' stamp: 'dkh 07/14/2013 12:00'! baselineProjectNameOf: baselineClassName ^ (baselineClassName beginsWith: 'BaselineOf') ifTrue: [ baselineClassName copyFrom: 'BaselineOf' size + 1 to: baselineClassName size ] ifFalse: [ baselineClassName ]! ! !MetacelloScriptEngine class methodsFor: 'defaults' stamp: 'dkh 7/23/2012 11:09'! defaultRepositoryDescription DefaultRepositoryDescription ifNil: [ DefaultRepositoryDescription := MetacelloPlatform current defaultRepositoryDescription ]. ^ DefaultRepositoryDescription! ! !MetacelloScriptEngine class methodsFor: 'utility' stamp: 'dkh 07/14/2013 12:01'! baseNameOf: className ^ (className beginsWith: 'BaselineOf') ifTrue: [ className copyFrom: 'BaselineOf' size + 1 to: className size ] ifFalse: [ (className beginsWith: 'ConfigurationOf') ifTrue: [ className copyFrom: 'ConfigurationOf' size + 1 to: className size ] ifFalse: [ className ] ]! ! !MetacelloScriptEngine class methodsFor: 'utility' stamp: 'dkh 07/14/2013 12:01'! configurationProjectNameOf: configurationClassName ^ (configurationClassName beginsWith: 'ConfigurationOf') ifTrue: [ configurationClassName copyFrom: 'ConfigurationOf' size + 1 to: configurationClassName size ] ifFalse: [ configurationClassName ]! ! !MetacelloScriptEngine class methodsFor: 'utility' stamp: 'dkh 7/12/2012 15:04'! baselineNameFrom: baseName "Return the fully-qualified configuration class name." ^ (baseName indexOfSubCollection: 'BaselineOf') > 0 ifTrue: [ baseName ] ifFalse: [ 'BaselineOf' , baseName ]! ! !MetacelloScriptEngine class methodsFor: 'utility' stamp: 'dkh 7/12/2012 15:04'! configurationNameFrom: baseName "Return the fully-qualified configuration class name." ^ (baseName indexOfSubCollection: 'ConfigurationOf') > 0 ifTrue: [ baseName ] ifFalse: [ 'ConfigurationOf' , baseName ]! ! !MetacelloScriptEnsureProjectLoadedForDevelopment methodsFor: 'handlers' stamp: 'dkh 7/24/2012 11:42'! handleResolutionFor: aScriptEngine ^ aScriptEngine handleEnsureProjectLoadedForDevelopment: self! ! !MetacelloScriptEnsureProjectLoadedForDevelopment methodsFor: 'exception handling' stamp: 'dkh 7/24/2012 11:40'! defaultAction "Go ahead and download a new copy of configuration because blessing is #development" ^ true! ! !MetacelloScriptExecutor commentStamp: 'dkh 7/12/2012 14:49'! MetacelloScriptExecutor decodes script args and launches MetacelloScriptEngine to run for each projectSpec encounters...i,e., primarily here to handl array and block args to configuration:, baseline: or project:.! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! repositoryArg: anObject repositoryArg := anObject! ! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! baselineArg: anObject baselineArg := anObject! ! !MetacelloScriptExecutor methodsFor: 'options api' stamp: 'dkh 07/24/2013 18:37'! onWarning: aBlock self options at: #'onWarning' put: aBlock! ! !MetacelloScriptExecutor methodsFor: 'options api' stamp: 'dkh 7/13/2012 09:31'! silently: aBool self options at: #'silently' put: aBool! ! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! versionArg ^ versionArg! ! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! classNameArg: anObject classNameArg := anObject! ! !MetacelloScriptExecutor methodsFor: 'execution' stamp: 'dkh 7/16/2012 17:10'! execute: statements statements do: [ :assoc | assoc value ifNil: [ self perform: assoc key ] ifNotNil: [ self perform: assoc key withArguments: assoc value ] ]. projectSpecGenerator := self projectSpecGenerator. projectSpecGenerator target execute: [ :projectSpec | | engine | engine := MetacelloScriptEngine new options: self options copy; projectSpec: projectSpec; yourself. engine perform: actionArg key withArguments: actionArg value. engine root ifNotNil: [ :root | self roots add: root ] ] against: self. ^ (self singleRoot and: [ self roots size == 1 ]) ifTrue: [ self roots first ] ifFalse: [ self roots ]! ! !MetacelloScriptExecutor methodsFor: 'execution callback' stamp: 'dkh 7/16/2012 17:09'! executeString: aString do: projectSpecBlock self singleRoot: true. ((projectSpecGenerator projectSpecLookupBlock value: aString) select: self projectSpecSelectBlock) do: [ :projectSpec | projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ]! ! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! baselineArg ^ baselineArg! ! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! versionArg: anObject versionArg := anObject! ! !MetacelloScriptExecutor methodsFor: 'actions api' stamp: 'dkh 7/17/2012 10:53'! lock actionArg := #'lock' -> #()! ! !MetacelloScriptExecutor methodsFor: 'accessing' stamp: 'dkh 7/16/2012 17:09'! singleRoot: aBool singleRoot := aBool! ! !MetacelloScriptExecutor methodsFor: 'actions api' stamp: 'dkh 7/19/2012 07:45'! record: required actionArg := #'record:' -> {required}! ! !MetacelloScriptExecutor methodsFor: 'options api' stamp: 'dkh 07/24/2013 17:10'! onLock: aBlock self options at: #'onLock' put: aBlock! ! !MetacelloScriptExecutor methodsFor: 'accessing' stamp: 'dkh 7/13/2012 09:02'! options options ifNil: [ options := Dictionary new ]. ^ options! ! !MetacelloScriptExecutor methodsFor: 'execution callback' stamp: 'dkh 7/16/2012 14:57'! executeCollection: aCollection do: projectSpecBlock aCollection do: [ :projectName | ((projectSpecGenerator projectSpecLookupBlock value: projectName) select: self projectSpecSelectBlock) do: [ :projectSpec | projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ] ]! ! !MetacelloScriptExecutor methodsFor: 'actions api' stamp: 'dkh 7/16/2012 10:17'! list actionArg := #'list' -> #()! ! !MetacelloScriptExecutor methodsFor: 'options api' stamp: 'dkh 7/23/2012 16:18'! cacheRepository: aRepositoryDescription self options at: #'cacheRepository' put: aRepositoryDescription! ! !MetacelloScriptExecutor methodsFor: 'accessing' stamp: 'dkh 7/16/2012 17:09'! singleRoot singleRoot ifNil: [ singleRoot := false ]. ^ singleRoot! ! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! classNameArg ^ classNameArg! ! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! projectArg: anObject projectArg := anObject! ! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! repositoryArg ^ repositoryArg! ! !MetacelloScriptExecutor methodsFor: 'accessing' stamp: 'dkh 7/13/2012 09:02'! roots roots ifNil: [ roots := OrderedCollection new ]. ^ roots! ! !MetacelloScriptExecutor methodsFor: 'options api' stamp: 'dkh 7/23/2012 19:28'! repositoryOverrides: aRepositoryDescriptionList self options at: #'repositoryOverrides' put: aRepositoryDescriptionList! ! !MetacelloScriptExecutor methodsFor: 'actions api' stamp: 'dkh 7/17/2012 12:31'! unlock actionArg := #'unlock' -> #()! ! !MetacelloScriptExecutor methodsFor: 'actions api' stamp: 'dkh 7/16/2012 10:17'! load: required actionArg := #'load:' -> {required}! ! !MetacelloScriptExecutor methodsFor: 'actions api' stamp: 'dkh 7/23/2012 15:58'! fetch: required actionArg := #'fetch:' -> {required}! ! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! configurationArg ^ configurationArg! ! !MetacelloScriptExecutor methodsFor: 'options api' stamp: 'dkh 7/13/2012 09:31'! ignoreImage: aBool self options at: #'ignoreImage' put: aBool! ! !MetacelloScriptExecutor methodsFor: 'execution' stamp: 'dkh 7/13/2012 09:33'! applyArgsToProjectSpec: aProjectSpec classNameArg ifNotNil: [ aProjectSpec className: classNameArg ]. versionArg ifNotNil: [ aProjectSpec versionString: versionArg ]. repositoryArg ifNotNil: [ aProjectSpec repository: repositoryArg ]. ^ aProjectSpec! ! !MetacelloScriptExecutor methodsFor: 'actions api' stamp: 'dkh 7/16/2012 10:17'! get actionArg := #'get' -> #()! ! !MetacelloScriptExecutor methodsFor: 'options api' stamp: 'dkh 7/13/2012 09:31'! onConflict: aBlock self options at: #'onConflict' put: aBlock! ! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! configurationArg: anObject configurationArg := anObject! ! !MetacelloScriptExecutor methodsFor: 'options api' stamp: 'dkh 7/13/2012 09:31'! onDowngrade: aBlock self options at: #'onDowngrade' put: aBlock! ! !MetacelloScriptExecutor methodsFor: 'execution' stamp: 'dkh 7/16/2012 11:06'! projectSpecGenerator baselineArg ifNotNil: [ configurationArg ifNotNil: [ self error: ' baseline: and configuration: are both be specified' ]. projectArg ifNotNil: [ self error: ' baseline: and project are both be specified' ]. ^ MetacelloBaselineSpecGenerator new target: baselineArg; yourself ]. configurationArg ifNotNil: [ baselineArg ifNotNil: [ self error: ' baseline: and configuration: are both be specified' ]. projectArg ifNotNil: [ self error: ' configuration and project are both be specified' ]. ^ MetacelloConfigurationSpecGenerator new target: configurationArg; yourself ]. projectArg ifNotNil: [ configurationArg ifNotNil: [ self error: ' project and configuration: are both be specified' ]. baselineArg ifNotNil: [ self error: ' baseline: and project are both be specified' ]. ^ MetacelloProjectSpecGenerator new target: projectArg; yourself ]. self error: 'project, baseline, or configuration not specified'! ! !MetacelloScriptExecutor methodsFor: 'execution callback' stamp: 'dkh 7/16/2012 11:34'! projectSpecSelectBlock ^ [ :projectSpec | true ]! ! !MetacelloScriptExecutor methodsFor: 'execution callback' stamp: 'dkh 7/16/2012 14:56'! executeBlock: selectBlock do: projectSpecBlock ((projectSpecGenerator projectSpecListBlock value select: selectBlock) select: self projectSpecSelectBlock) do: [ :projectSpec | projectSpecBlock value: (self applyArgsToProjectSpec: projectSpec copy) ]! ! !MetacelloScriptExecutor methodsFor: 'options api' stamp: 'dkh 7/13/2012 09:31'! onUpgrade: aBlock self options at: #'onUpgrade' put: aBlock! ! !MetacelloScriptExecutor methodsFor: 'args' stamp: 'dkh 7/13/2012 09:30'! projectArg ^ projectArg! ! !MetacelloScriptExecutor methodsFor: 'options api' stamp: 'dkh 7/13/2012 09:31'! useCurrentVersion: aBool "private option used to implement the classic mode" self options at: #'useCurrentVersion' put: aBool! ! !MetacelloScriptGitHubDownloadNotification methodsFor: 'accessing' stamp: 'dkh 7/24/2012 22:11'! projectPath: anObject projectPath := anObject! ! !MetacelloScriptGitHubDownloadNotification methodsFor: 'accessing' stamp: 'dkh 7/24/2012 22:11'! versionString ^ versionString! ! !MetacelloScriptGitHubDownloadNotification methodsFor: 'accessing' stamp: 'dkh 7/24/2012 22:11'! projectPath ^ projectPath! ! !MetacelloScriptGitHubDownloadNotification methodsFor: 'accessing' stamp: 'dkh 7/24/2012 22:11'! versionString: anObject versionString := anObject! ! !MetacelloScriptImageExecutor methodsFor: 'execution callback' stamp: 'dkh 7/16/2012 14:53'! projectSpecSelectBlock ^ [ :projectSpec | projectSpec ifNil: [ false ] ifNotNil: [ MetacelloProjectRegistration registrationForProjectSpec: projectSpec ifAbsent: [ false ] ifPresent: [ :existingRegistration :newRegistration | existingRegistration loadedInImage ] ] ]! ! !MetacelloScriptNotification methodsFor: 'handlers' stamp: 'dkh 6/7/2012 16:07'! handleResolutionFor: aScriptEngine self subclassResponsibility! ! !MetacelloScriptProjectSpecNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectSpec ^ projectSpec! ! !MetacelloScriptProjectSpecNotification methodsFor: 'exception description' stamp: 'dkh 6/5/2012 19:01:24'! defaultAction "Result of signal should be the projectSpec to be used to perform the load" ^ self projectSpec! ! !MetacelloScriptProjectSpecNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectSpec: anObject projectSpec := anObject! ! !MetacelloScriptRegistryExecutor methodsFor: 'actions api' stamp: 'dkh 7/13/2012 09:36'! reset ! ! !MetacelloScriptRegistryExecutor methodsFor: 'execution callback' stamp: 'dkh 07/28/2013 10:07'! projectSpecSelectBlock ^ [ :projectSpec | projectSpec notNil ]! ! !MetacelloScriptRegistryExecutor methodsFor: 'actions api' stamp: 'dkh 7/13/2012 09:37'! remove ! ! !MetacelloScriptRegistryExecutor methodsFor: 'actions api' stamp: 'dkh 7/20/2012 12:00'! prime ! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 06/29/2013 12:27'! configurationGithubReferenceXXX: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configurationGithubReferenceXXX:'. spec configuration: 'External' with: [ spec version: '0.9.0'; repository: 'http://ss3.gemtalksystems.com/ss/external' ] ]! ! !MetacelloScriptingResource methodsFor: 'issue 63' stamp: 'dkh 07/20/2013 03:59'! configuration097Issue185: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configuration0957Issue185:'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomIssue185SHA4 , '/repository' ]; import: 'External' ]! ! !MetacelloScriptingResource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! configurationRepository ^ configurationRepository! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineGithubReferenceXX "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfGithubRefXX-dkh.1'. className := #'BaselineOfGithubRefXX'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'baselineGithubReferenceXX:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineGithubReferenceXX:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 84' stamp: 'dkh 7/24/2012 20:20'! setUpConfigurationNextedIssue84dkh1 "see https://github.com/dalehenrich/metacello-work/issues/84" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfNestedIssue84-dkh.1'. className := #'ConfigurationOfNestedIssue84'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'version10NestedIssue84:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version10NestedIssue84:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionNumberClass' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionNumberClass') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 63' stamp: 'dkh 07/16/2013 14:11'! configuration091Issue181: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configuration091Issue181:'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ]; import: 'External' ]! ! !MetacelloScriptingResource methodsFor: 'issue 32' stamp: 'dkh 6/18/2012 15:07'! setUpBaselineIssue32 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfIssue32-dkh.1'. className := #'BaselineOfIssue32'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'postloadDoIt' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'postloadDoIt') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'preloadDoIt' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'preloadDoIt') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'baselineIssue32:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineIssue32:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 63' stamp: 'dkh 07/16/2013 14:11'! configuration092Issue181: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configuration092Issue181:'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomIssue181SHA , '/repository' ]; import: 'External' ]! ! !MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: 'dkh 6/22/2012 17:23'! conflictOf11: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>conflictOf11:'. spec author: 'dkh'. spec timestamp: '6/1/2012 14:46' ]. spec for: #'custom' do: [ spec configuration: 'ExternalX' with: [ spec version: '0.9.0'; repository: 'dictionary://Metacello_Conflict_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'invalid configurations' stamp: 'dkh 6/22/2012 17:24'! invalidConfiguration30: spec spec for: #'common' do: [ spec blessing: #'release'. spec description: 'MetacelloScriptingResource>>invalidConfiguration30: ... missing repository:'. spec project: 'External' with: [ spec className: 'ConfigurationOfExternal'; version: '0.9.0' ] ]! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 6/22/2012 17:25'! versionOfXXX: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>versionOfXXX:'. spec author: 'dkh'. spec timestamp: '5/4/2012 14:16'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 7/21/2012 14:32'! setUpConfigurationOfExternalIV "see https://github.com/dalehenrich/metacello-work/issues/6" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfExternalIV-dkh.1'. className := #'ConfigurationOfExternalIV'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionOfIV:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionOfIV:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 63' stamp: 'dkh 07/16/2013 14:11'! configuration091Issue63: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configuration091Issue63:'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ]; import: 'External' ]! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/22/2012 17:22'! configurationGithubReferenceIV: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configurationGithubReferenceIV:'. spec project: 'External' with: [ spec className: 'ConfigurationOfExternal'; version: '0.9.0'; repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'issue 32' stamp: 'dkh 6/22/2012 17:24'! version10Issue47: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>version10Issue47:'. spec author: 'dkh'. spec timestamp: '6/18/2012 14:34'. spec baseline: 'Issue32' ]. spec for: #'custom' do: [ spec baseline: 'Issue32' with: [ spec repository: 'dictionary://Metacello_External_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'issue 32' stamp: 'dkh 6/22/2012 18:11'! version10Issue59: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>version10Issue59:'. spec author: 'dkh'. spec timestamp: '6/18/2012 14:34'. spec baseline: 'Issue32' ]. spec for: #'custom' do: [ spec baseline: 'Issue32' with: [ spec repository: 'dictionary://Metacello_External_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineOfExternalXX "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfExternalXX-dkh.1'. className := #'BaselineOfExternalXX'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'externalBaselineXX:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'externalBaselineXX:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'external core' stamp: 'dkh 07/26/2013 09:48'! setUpExternalCoreX "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'External-CoreX-dkh.1'. className := #'ExternalCoreX'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'Object' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'externalAuthorName' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'externalAuthorName') asString). (MCMethodDefinition className: 'Object' classIsMeta: true selector: 'isExternal' category: '*external-corex' timeStamp: '' source: (self class sourceCodeAt: #'isExternal') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineGithubReferenceVI "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfGithubRefVI-dkh.1'. className := #'BaselineOfGithubRefVI'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configurationGithubReferenceXXX:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configurationGithubReferenceXXX:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! externalRepository ^ externalRepository! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/22/2012 17:22'! configurationGithubReferenceX: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configurationGithubReferenceX:'. spec project: 'External' with: [ spec className: 'ConfigurationOfExternal'; version: '0.9.0'; repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'issue 59' stamp: 'dkh 6/22/2012 18:13'! setUpConfigurationIssue59 "see https://github.com/dalehenrich/metacello-work/issues/59" "Use MetacelloVersionNumber instead of MetacelloSematicVersionNumber" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfIssue59-dkh.1'. className := #'ConfigurationOfIssue59'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'version10Issue59:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version10Issue59:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionNumberClass' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionNumberClass') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'external core' stamp: 'dkh 6/12/2012 15:41:23.319'! externalAuthorName ^ 'dkh'! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineGithubReferenceVII: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>baselineGithubReferenceVII:'. spec baseline: 'External Core' with: [ spec className: 'BaselineOfExternal'; loads: 'Core'; repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ]; project: 'External Tests' copyFrom: 'External Core' with: [ spec loads: 'Tests' ] ]! ! !MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpMarianosImage "className: test case seehttps://github.com/dalehenrich/metacello-work/issues/24" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'MarianosImage-dkh.1'. className := #'MarianosImage'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionOfMariano:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionOfMariano:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 32' stamp: 'dkh 6/18/2012 14:37'! postloadDoIt "self reset" Smalltalk at: #'Metacello_Configuration_Test_POST_DoIt_Result' put: true! ! !MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: 'dkh 7/21/2012 14:20'! setUpConfigurationOfExternalXX "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfExternalXX-dkh.1'. className := #'ConfigurationOfExternalXX'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionOfXX:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionOfXX:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'sample repository' stamp: 'dkh 6/12/2012 15:41:23.319'! isSample ^ false! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/22/2012 17:22'! configurationGithubReferenceV: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configurationGithubReferenceV:'. spec project: 'External' with: [ spec className: 'ConfigurationOfExternal'; version: '0.9.0'; loads: 'Core'; repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ]; project: 'External Tests' copyFrom: 'External' with: [ spec loads: 'Tests' ] ]! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 6/12/2012 15:41:23.319'! versionOfX091: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>versionOfX091:'. spec author: 'dkh'. spec timestamp: '5/4/2012 14:16' ]. spec for: #'custom' do: [ spec baseline: 'ExternalX' with: [ spec repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineOfExternalX "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfExternalX-dkh.1'. className := #'BaselineOfExternalX'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'externalBaselineX:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'externalBaselineX:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 84' stamp: 'dkh 8/3/2012 17:24'! setUpConfigurationNextedIssue84 "see https://github.com/dalehenrich/metacello-work/issues/84" "self reset" | versionInfo | versionInfo := self setUpConfigurationNextedIssue84dkh1. self setUpConfigurationNextedIssue84dkh2: {versionInfo}! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: 'dkh 6/12/2012 15:41:23.319'! externalBaselineX: spec spec description: 'MetacelloScriptingResource>>externalBaselineX:'. spec package: 'External-CoreX'; package: 'External-TestsX' with: [ spec requires: 'External-CoreX' ]; yourself. spec group: 'Core' with: #('External-CoreX'); group: 'default' with: #('Core'); group: 'Tests' with: #('External-TestsX'); yourself! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineGithubReferenceVIII "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfGithubRefVIII-dkh.1'. className := #'BaselineOfGithubRefVIII'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'baselineGithubReferenceV:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineGithubReferenceV:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'invalid configurations' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpInvalidConfigurations "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfInvalidConfigurations-dkh.1'. className := #'ConfigurationOfInvalidConfigurations'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'invalidConfiguration10:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'invalidConfiguration10:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'invalidConfiguration20:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'invalidConfiguration20:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'invalidConfiguration30:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'invalidConfiguration30:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 32' stamp: 'dkh 6/22/2012 17:24'! version09Issue32: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>baselineOfIssue32:'. spec author: 'dkh'. spec timestamp: '6/18/2012 14:34' ]. spec for: #'custom' do: [ spec baseline: 'Issue32' with: [ spec repository: 'dictionary://Metacello_External_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'invalid configurations' stamp: 'dkh 6/22/2012 17:23'! invalidConfiguration10: spec spec for: #'common' do: [ spec blessing: #'release'. spec description: 'MetacelloScriptingResource>>invalidConfiguration10: ... missing className:'. spec project: 'External' with: [ spec version: '0.9.0'; repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'external core' stamp: 'ChristopheDemarey 9/12/2013 18:36'! setUpExternalCore "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'External-Core-dkh.1'. className := #'ExternalCore'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'Object' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'externalAuthorName' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'externalAuthorName') asString). (MCMethodDefinition className: 'Object' classIsMeta: true selector: 'isExternal' category: '*external-core' timeStamp: '' source: (self class sourceCodeAt: #'isExternal') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 07/29/2013 07:34'! setUpConfigurationExternalRef "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfExternalRef-dkh.1'. className := #'ConfigurationOfExternalRef'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configurationExternalRef090:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configurationExternalRef090:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configurationExternalRef091:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configurationExternalRef091:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'locking' stamp: 'dkh 7/20/2012 16:50'! setUpLockConfigurations "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfLockConfigurations-dkh.1'. className := #'ConfigurationOfLockConfigurations'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'lockConfiguration10:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'lockConfiguration10:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'lockConfiguration11:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'lockConfiguration11:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 07/26/2013 09:58'! versionOfExternal091: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>versionOfExternal091:'. spec author: 'dkh'. spec timestamp: '5/4/2012 14:16'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'issue 59' stamp: 'dkh 6/22/2012 18:07'! versionNumberClass ^ MetacelloVersionNumber! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 7/21/2012 14:21'! versionOfIV: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>baselineOfIV:'. spec author: 'dkh'. spec timestamp: '5/4/2012 14:16' ]. spec for: #'custom' do: [ spec baseline: 'ExternalX' with: [ spec repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 07/29/2013 13:46'! setUpConfigurationOfExternaldkh1 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfExternal-dkh.1'. className := #'ConfigurationOfExternal'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionOfExternal090:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionOfExternal090:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: 'dkh 6/12/2012 15:41:23.319'! externalBaselineXXX: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>externalBaselineXXX:'. spec package: 'External-CoreX'; package: 'External-TestsX' with: [ spec requires: 'External-CoreX' ]; yourself. spec group: 'Core' with: #('External-CoreX'); group: 'default' with: #('Core'); group: 'Tests' with: #('External-TestsX'); yourself ]. spec for: #'custom' do: [ spec package: 'External-UIX'. spec group: 'UI' with: #('External-UIX') ]! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineOfExternalXXX "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfExternalXXX-dkh.1'. className := #'BaselineOfExternalXXX'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'externalBaselineXXX:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'externalBaselineXXX:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 7/21/2012 14:03'! stableVersionOfX: spec "self reset" spec for: #'common' version: '0.9.0'! ! !MetacelloScriptingResource methodsFor: 'issue 63' stamp: 'dkh 07/16/2013 14:11'! configuration092Issue63: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configuration092Issue63:'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ]; package: 'GoferBar' with: [ spec file: 'GoferBar-lr.1'; repository: 'dictionary://Metacello_Gofer_Test_Repository' ]; package: 'GoferFoo' with: [ spec file: 'GoferFoo-lr.2'; requires: 'External'; repository: 'dictionary://Metacello_Gofer_Test_Repository' ]; import: 'External' ]! ! !MetacelloScriptingResource methodsFor: 'external core' stamp: 'dkh 6/12/2012 15:41:23.319'! isExternal ^ false! ! !MetacelloScriptingResource methodsFor: 'issue 84' stamp: 'dkh 7/24/2012 20:11'! version10NestedIssue84: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>version10NestedIssue84:'. spec author: 'dkh'. spec timestamp: '7/24/2012 19:23'. spec repository: 'dictionary://Metacello_Configuration_Test_Repository'. spec package: 'External-CoreX' ]! ! !MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: 'dkh 6/22/2012 17:23'! conflictOf10: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>conflictOf10:'. spec author: 'dkh'. spec timestamp: '6/1/2012 14:46' ]. spec for: #'custom' do: [ spec configuration: 'ExternalX' with: [ spec version: '0.9.1'; repository: 'dictionary://Metacello_Conflict_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 7/21/2012 14:16'! setUpConfigurationOfExternalXXX "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfExternalXXX-dkh.1'. className := #'ConfigurationOfExternalXXX'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionOfXXX:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionOfXXX:') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 63' stamp: 'dkh 07/19/2013 15:32'! setUpConfiguration181 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfIssue181-dkh.1'. className := #'ConfigurationOfIssue181'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configuration091Issue181:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configuration091Issue181:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configuration092Issue181:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configuration092Issue181:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configuration093Issue185:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configuration093Issue185:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configuration094Issue185:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configuration094Issue185:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configuration095Issue185:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configuration095Issue185:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configuration096Issue185:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configuration096Issue185:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configuration097Issue185:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configuration097Issue185:') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 63' stamp: 'dkh 07/20/2013 03:58'! configuration094Issue185: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configuration094Issue185:'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomIssue185SHA1 , '/repository' ]; import: 'External' ]! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 7/21/2012 14:16'! setUpConfigurationOfExternalXdkh1 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfExternalX-dkh.1'. className := #'ConfigurationOfExternalX'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'stableVersionOfX:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'stableVersionOfX:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionOfX090:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionOfX090:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: 'dkh 6/22/2012 17:23'! conflictOf12: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>conflictOf12:'. spec author: 'dkh'. spec timestamp: '6/1/2012 14:46' ]. spec for: #'custom' do: [ spec configuration: 'ExternalX' with: [ spec operator: #'='; version: '0.9.2'; repository: 'dictionary://Metacello_Conflict_Test_Repository' "#= forces conflict" ] ]! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineGithubReferenceV: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>baselineGithubReferenceV:'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 07/29/2013 07:47'! configurationExternalRef090: spec spec for: #'common' do: [ spec blessing: #'version'. spec description: 'MetacelloScriptingResource>>configurationExternalRef090:'. spec project: 'External' with: [ spec className: 'ConfigurationOfExternal'; version: '0.9.0'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 07/29/2013 13:46'! setUpConfigurationOfExternaldkh2 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfExternal-dkh.2'. className := #'ConfigurationOfExternal'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionOfExternal090:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionOfExternal090:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionOfExternal091:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionOfExternal091:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: 'dkh 6/22/2012 17:24'! versionOfMariano: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>versionOfMariano:'. spec author: 'dkh'. spec timestamp: '5/31/2012 16:04' ]. spec for: #'custom' do: [ spec baseline: 'ExternalX' with: [ spec repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'issue 32' stamp: 'dkh 6/18/2012 14:37'! preloadDoIt "self reset" Smalltalk at: #'Metacello_Configuration_Test_DoIt_Result' put: true! ! !MetacelloScriptingResource methodsFor: 'accessing' stamp: 'dkh 6/12/2012 15:41:23.319'! sampleRepository ^ sampleRepository! ! !MetacelloScriptingResource methodsFor: 'issue 32' stamp: 'dkh 6/18/2012 15:47'! setUpConfigurationIssue32 "see https://github.com/dalehenrich/metacello-work/issues/32" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfIssue32-dkh.1'. className := #'ConfigurationOfIssue32'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'version10Issue47:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version10Issue47:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'version09Issue32:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version09Issue32:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 63' stamp: 'dkh 07/20/2013 03:59'! configuration096Issue185: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configuration0956Issue185:'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomIssue185SHA3 , '/repository' ]; import: 'External' ]! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/22/2012 17:22'! configurationGithubReferenceXX: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configurationGithubReferenceXX:'. spec configuration: 'External' with: [ spec version: '0.9.0'; repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'sample repository' stamp: 'dkh 6/12/2012 15:41:23.319'! sampleAuthorName ^ (Smalltalk at: #'ExternalCore') new externalAuthorName! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineGithubReferenceIV "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfGithubRefIV-dkh.1'. className := #'BaselineOfGithubRefIV'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configurationGithubReferenceX:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configurationGithubReferenceX:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 63' stamp: 'dkh 6/26/2012 16:45'! setUpConfiguration63 "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfIssue63-dkh.1'. className := #'ConfigurationOfIssue63'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configuration091Issue63:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configuration091Issue63:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configuration092Issue63:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configuration092Issue63:') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'locking' stamp: 'dkh 7/20/2012 16:48'! lockConfiguration11: spec spec for: #'common' do: [ spec blessing: #'release'. spec description: 'MetacelloScriptingResource>>lockConfiguration10: '. spec configuration: 'ExternalX' with: [ spec version: '0.9.1'; repository: 'dictionary://Metacello_Config_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 6/22/2012 17:24'! versionOfX090: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>versionOfX090:'. spec author: 'dkh'. spec timestamp: '5/4/2012 14:16' ]. spec for: #'custom' do: [ spec baseline: 'ExternalX' with: [ spec repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineGithubReferenceVI: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>baselineGithubReferenceVI:'. spec baseline: 'External Core' with: [ spec className: 'BaselineOfExternal'; loads: 'Core'; repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ]; baseline: 'External Tests' with: [ spec className: 'BaselineOfExternal'; loads: 'Tests'; repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'issue 63' stamp: 'dkh 07/20/2013 03:58'! configuration095Issue185: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configuration095Issue185:'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomIssue185SHA2 , '/repository' ]; import: 'External' ]! ! !MetacelloScriptingResource methodsFor: 'external repository' stamp: 'dkh 6/12/2012 15:41:23.319'! customProjectAttributes ^ #(#custom)! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 06/29/2013 12:27'! baselineGithubReferenceIV: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>baselineGithubReferenceIV:'. spec baseline: 'External' with: [ spec repository: 'http://ss3.gemtalksystems.com/ss/external' ] ]! ! !MetacelloScriptingResource methodsFor: 'locking' stamp: 'dkh 7/20/2012 16:48'! lockConfiguration10: spec spec for: #'common' do: [ spec blessing: #'release'. spec description: 'MetacelloScriptingResource>>lockConfiguration10: '. spec configuration: 'ExternalX' with: [ spec version: '0.9.0'; repository: 'dictionary://Metacello_Config_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'baseline:with:' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpConfigurationOfConflict "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfConflict-dkh.1'. className := #'ConfigurationOfConflict'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'conflictOf10:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'conflictOf10:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'conflictOf11:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'conflictOf11:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'conflictOf12:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'conflictOf12:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineGithubReferenceIX "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfGithubRefIX-dkh.1'. className := #'BaselineOfGithubRefIX'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configurationGithubReferenceIV:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configurationGithubReferenceIV:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineGithubReferenceXIII "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfGithubRefXIII-dkh.1'. className := #'BaselineOfGithubRefXIII'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'baselineGithubReferenceVII:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineGithubReferenceVII:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 32' stamp: 'dkh 6/18/2012 14:38'! baselineIssue32: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>baselineIssue32:'. spec package: 'External-CoreX'; package: 'External-TestsX' with: [ spec requires: 'External-CoreX' ]; preLoadDoIt: #'preloadDoIt'; postLoadDoIt: #'postloadDoIt'; yourself. spec group: 'Core' with: #('External-CoreX'); group: 'default' with: #('Core'); group: 'Tests' with: #('External-TestsX'); yourself ]! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 07/29/2013 07:47'! configurationExternalRef091: spec spec for: #'common' do: [ spec blessing: #'version'. spec description: 'MetacelloScriptingResource>>configurationExternalRef090:'. spec project: 'External' with: [ spec className: 'ConfigurationOfExternal'; version: '0.9.1'; repository: 'dictionary://Metacello_Configuration_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 7/21/2012 14:16'! setUpConfigurationOfExternalXdkh2: ancestors "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfExternalX-dkh.2'. className := #'ConfigurationOfExternalX'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'stableVersionOfX:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'stableVersionOfX:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionOfX090:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionOfX090:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionOfX091:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionOfX091:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 63' stamp: 'dkh 07/19/2013 12:52'! configuration093Issue185: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>configuration093Issue185:'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomIssue185SHA , '/repository' ]; import: 'External' ]! ! !MetacelloScriptingResource methodsFor: 'issue 84' stamp: 'dkh 7/24/2012 19:21'! setUpConfigurationIssue84 "see https://github.com/dalehenrich/metacello-work/issues/84" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfIssue84-dkh.1'. className := #'ConfigurationOfIssue84'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'version10Issue84:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version10Issue84:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'invalid configurations' stamp: 'dkh 6/22/2012 17:23'! invalidConfiguration20: spec spec for: #'common' do: [ spec blessing: #'release'. spec description: 'MetacelloScriptingResource>>invalidConfiguration20: ... missing version:'. spec project: 'External' with: [ spec className: 'ConfigurationOfExternal'; repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalConfigurationSHA , '/repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 7/21/2012 14:17'! setUpConfigurationOfExternalX "self reset" | versionInfo | versionInfo := self setUpConfigurationOfExternalXdkh1. versionInfo := self setUpConfigurationOfExternalXdkh2: {versionInfo}! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineGithubReferenceV "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfGithubRefV-dkh.1'. className := #'BaselineOfGithubRefV'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configurationGithubReferenceXX:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configurationGithubReferenceXX:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineGithubReferenceXII "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfGithubRefXII-dkh.1'. className := #'BaselineOfGithubRefXII'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'baselineGithubReferenceVI:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineGithubReferenceVI:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'sample repository' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpSampleCore "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'Sample-CoreX-dkh.1'. className := #'SampleCoreX'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'Object' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: true selector: 'sampleAuthorName' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'sampleAuthorName') asString). (MCClassDefinition name: #'Object' superclassName: #'ProtoObject' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: 'Object' classIsMeta: true selector: 'isSample' category: '*sample-core' timeStamp: '' source: (self class sourceCodeAt: #'isSample') asString)}. sampleRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'issue 84' stamp: 'dkh 7/24/2012 19:34'! version10Issue84: spec spec for: #'common' do: [ spec blessing: #'release'. spec description: 'MetacelloScriptingResource>>version10Issue84:'. spec author: 'dkh'. spec timestamp: '7/24/2012 19:23'. spec configuration: 'NestedIssue84' with: [ spec version: '1.0.0'; repository: 'dictionary://Metacello_Config_Test_Repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 07/26/2013 10:08'! versionOfExternal090: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>versionOfExternal090:'. spec repository: 'dictionary://Metacello_Configuration_Test_Repository'. spec package: 'External-Core' with: 'External-Core-dkh.1'; yourself ]! ! !MetacelloScriptingResource methodsFor: 'running' stamp: 'dkh 07/29/2013 07:34'! setUp "self reset" super setUp. self setUpRepositories; setUpExternalCore; setUpExternalCoreX; setUpSampleCore; setUpBaselineOfExternalX; setUpBaselineOfExternalXX; setUpBaselineOfExternalXXX; setUpConfigurationOfExternaldkh1; setUpConfigurationOfExternaldkh2; setUpConfigurationExternalRef; setUpConfigurationOfExternalX; setUpConfigurationOfExternalXX; setUpConfigurationOfExternalXXX; setUpConfigurationOfExternalIV; setUpBaselineGithubReferenceXX; setUpBaselineGithubReferenceIV; setUpBaselineGithubReferenceV; setUpBaselineGithubReferenceVI; setUpBaselineGithubReferenceVII; setUpBaselineGithubReferenceVIII; setUpBaselineGithubReferenceIX; setUpBaselineGithubReferenceXI; setUpBaselineGithubReferenceXII; setUpBaselineGithubReferenceXIII; setUpMarianosImage; setUpConfigurationOfConflict; setUpInvalidConfigurations; setUpConfigurationIssue32; setUpBaselineIssue32; setUpConfigurationIssue59; setUpConfiguration63; setUpLockConfigurations; setUpConfigurationIssue84; setUpConfigurationNextedIssue84; setUpConfiguration181; yourself! ! !MetacelloScriptingResource methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpRepositories "self reset" configurationRepository := MCDictionaryRepository new. externalRepository := MCDictionaryRepository new. sampleRepository := MCDictionaryRepository new! ! !MetacelloScriptingResource methodsFor: 'external configurations' stamp: 'dkh 6/22/2012 17:25'! versionOfXX: spec spec for: #'common' do: [ spec blessing: #'development'. spec description: 'MetacelloScriptingResource>>versionOfXX:'. spec author: 'dkh'. spec timestamp: '5/4/2012 14:16' ]. spec for: #'custom' do: [ spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! baselineGithubReferenceXX: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>baselineGithubReferenceXX:'. spec baseline: 'External' with: [ spec repository: 'github://dalehenrich/external:' , MetacelloScriptingResource externalCustomSHA , '/repository' ] ]! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - external' stamp: 'dkh 6/12/2012 15:41:23.319'! externalBaselineXX: spec spec for: #'common' do: [ spec description: 'MetacelloScriptingResource>>externalBaselineXX:'. spec package: 'External-CoreX'; package: 'External-TestsX' with: [ spec requires: 'External-CoreX' ]; yourself. spec group: 'Core' with: #('External-CoreX'); group: 'default' with: #('Core'); group: 'Tests' with: #('External-TestsX'); yourself ]! ! !MetacelloScriptingResource methodsFor: 'issue 84' stamp: 'dkh 7/24/2012 20:37'! setUpConfigurationNextedIssue84dkh2: ancestors "see https://github.com/dalehenrich/metacello-work/issues/84" "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'ConfigurationOfNestedIssue84-dkh.2'. className := #'ConfigurationOfNestedIssue84'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'ConfigurationOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'version10NestedIssue84:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'version10NestedIssue84:') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'versionNumberClass' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'versionNumberClass') asString). (MCMethodDefinition className: className asString classIsMeta: false selector: 'customProjectAttributes' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'customProjectAttributes') asString)}. configurationRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: ancestors) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineGithubReferenceXI "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfGithubRefXI-dkh.1'. className := #'BaselineOfGithubRefXI'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'configurationGithubReferenceV:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'configurationGithubReferenceV:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource methodsFor: 'baseline pragma - github reference' stamp: 'dkh 6/12/2012 15:41:23.319'! setUpBaselineGithubReferenceVII "self reset" | reference className definitionArray versionInfo | reference := GoferVersionReference name: 'BaselineOfGithubRefVII-dkh.1'. className := #'BaselineOfGithubRefVII'. definitionArray := {(MCOrganizationDefinition categories: (Array with: reference packageName asSymbol)). (MCClassDefinition name: className superclassName: #'BaselineOf' category: reference packageName instVarNames: #() comment: ''). (MCMethodDefinition className: className asString classIsMeta: false selector: 'baselineGithubReferenceIV:' category: 'cat' timeStamp: '' source: (self class sourceCodeAt: #'baselineGithubReferenceIV:') asString)}. externalRepository basicStoreVersion: (MCVersion new setPackage: (MetacelloTestsMCPackage new name: reference packageName) info: (versionInfo := MCVersionInfo name: reference name id: UUID new message: 'This is a mock version' date: Date today time: Time now author: reference author ancestors: #()) snapshot: (MCSnapshot fromDefinitions: definitionArray) dependencies: #()). ^ versionInfo! ! !MetacelloScriptingResource class methodsFor: 'accessing' stamp: 'dkh 07/20/2013 03:58'! externalCustomIssue185SHA1 "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)" "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break" ^ '96cf2ed0a252ce55b7fd5ec4bedf3ad999ca6d23'! ! !MetacelloScriptingResource class methodsFor: 'accessing' stamp: 'dkh 6/22/2012 17:26'! externalCustomSHA "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)" "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break" "self reset" ^ '1ac58502ade7814e1590f71d615cca434b1a4fd5'! ! !MetacelloScriptingResource class methodsFor: 'accessing' stamp: 'dkh 07/20/2013 03:58'! externalCustomIssue185SHA2 "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)" "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break" ^ '9e79d0e165bd51f7476d10a07968706f6034a6e6'! ! !MetacelloScriptingResource class methodsFor: 'accessing' stamp: 'dkh 07/20/2013 03:58'! externalCustomIssue185SHA3 "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)" "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break" ^ '11dfa72bc4a956ce0cb5a7603ea39f5abf73ff1c'! ! !MetacelloScriptingResource class methodsFor: 'accessing' stamp: 'dkh 07/16/2013 14:08'! externalCustomIssue181SHA "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)" "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break" ^ '36ac04abfc3a173de9432a134a718bf14b0a6968'! ! !MetacelloScriptingResource class methodsFor: 'accessing' stamp: 'dkh 6/22/2012 17:37'! externalConfigurationSHA "SHA of commit on 'configuration' branch that should be used with this version of tests (https://github.com/dalehenrich/external)" "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break" "self reset" ^ 'd91949731736bf48879781c29c7365feca461cde'! ! !MetacelloScriptingResource class methodsFor: 'accessing' stamp: 'dkh 07/19/2013 12:56'! externalCustomIssue185SHA "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)" "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break" ^ '29efb3d9cb86da55402a543cbef5771e39f864e7'! ! !MetacelloScriptingResource class methodsFor: 'accessing' stamp: 'dkh 07/20/2013 03:58'! externalCustomIssue185SHA4 "SHA of commit on 'custom' branch that should be used with this version of tests (https://github.com/dalehenrich/external)" "it's too dangerous to use the HEAD of a branch in tests, because over time the HEAD will change to match latest testing needs, but old tests will likely break" ^ 'e36dcd023518f4d2a209a482097f5a8ef745ef25'! ! !MetacelloSemanticVersionNumber commentStamp: 'dkh 6/24/2012 18:20'! MetacelloSemanticVersionNumber conforms to version 2.0.0-rc.1 of [Semantic Versioning 2.0.0-rc.1](http://semver.org/) The most important thing that you need to know is that: **A normal version number MUST take the form X.Y.Z where X, Y, and Z are non-negative integers.** **Semantic Versioning Specification** extracted from [Semantic versioning 2.0.0-rc.1](https://github.com/mojombo/semver/blob/3c7f2e8df747ea0ca15208fdfc90e3275240184f/semver.md): Semantic Versioning Specification (SemVer) ------------------------------------------ The key words "MUST", "MUST NOT", "REQUIRED", "SHALL", "SHALL NOT", "SHOULD", "SHOULD NOT", "RECOMMENDED", "MAY", and "OPTIONAL" in this document are to be interpreted as described in RFC 2119. 1. Software using Semantic Versioning MUST declare a public API. This API could be declared in the code itself or exist strictly in documentation. However it is done, it should be precise and comprehensive. 1. A normal version number MUST take the form X.Y.Z where X, Y, and Z are non-negative integers. X is the major version, Y is the minor version, and Z is the patch version. Each element MUST increase numerically by increments of one. For instance: 1.9.0 -> 1.10.0 -> 1.11.0. 1. Once a versioned package has been released, the contents of that version MUST NOT be modified. Any modifications must be released as a new version. 1. Major version zero (0.y.z) is for initial development. Anything may change at any time. The public API should not be considered stable. 1. Version 1.0.0 defines the public API. The way in which the version number is incremented after this release is dependent on this public API and how it changes. 1. Patch version Z (x.y.Z | x > 0) MUST be incremented if only backwards compatible bug fixes are introduced. A bug fix is defined as an internal change that fixes incorrect behavior. 1. Minor version Y (x.Y.z | x > 0) MUST be incremented if new, backwards compatible functionality is introduced to the public API. It MUST be incremented if any public API functionality is marked as deprecated. It MAY be incremented if substantial new functionality or improvements are introduced within the private code. It MAY include patch level changes. Patch version MUST be reset to 0 when minor version is incremented. 1. Major version X (X.y.z | X > 0) MUST be incremented if any backwards incompatible changes are introduced to the public API. It MAY include minor and patch level changes. Patch and minor version MUST be reset to 0 when major version is incremented. 1. A pre-release version MAY be denoted by appending a hyphen and a series of dot separated identifiers immediately following the patch version. Identifiers MUST be comprised of only ASCII alphanumerics and dash [0-9A-Za-z-]. Pre-release versions satisfy but have a lower precedence than the associated normal version. Examples: 1.0.0-alpha, 1.0.0-alpha.1, 1.0.0-0.3.7, 1.0.0-x.7.z.92. 1. A build version MAY be denoted by appending a plus sign and a series of dot separated identifiers immediately following the patch version or pre-release version. Identifiers MUST be comprised of only ASCII alphanumerics and dash [0-9A-Za-z-]. Build versions satisfy and have a higher precedence than the associated normal version. Examples: 1.0.0+build.1, 1.3.7+build.11.e0f985a. 1. Precedence MUST be calculated by separating the version into major, minor, patch, pre-release, and build identifiers in that order. Major, minor, and patch versions are always compared numerically. Pre-release and build version precedence MUST be determined by comparing each dot separated identifier as follows: identifiers consisting of only digits are compared numerically and identifiers with letters or dashes are compared lexically in ASCII sort order. Numeric identifiers always have lower precedence than non-numeric identifiers. Example: 1.0.0-alpha < 1.0.0-alpha.1 < 1.0.0-beta.2 < 1.0.0-beta.11 < 1.0.0-rc.1 < 1.0.0-rc.1+build.1 < 1.0.0 < 1.0.0+0.3.7 < 1.3.7+build < 1.3.7+build.2.b8f12d7 < 1.3.7+build.11.e0f985a. About ----- The Semantic Versioning specification is authored by [Tom Preston-Werner](http://tom.preston-werner.com), inventor of Gravatars and cofounder of GitHub. If you'd like to leave feedback, please [open an issue on GitHub](https://github.com/mojombo/semver/issues). License ------- Creative Commons - CC BY 3.0 http://creativecommons.org/licenses/by/3.0/ ! !MetacelloSemanticVersionNumber methodsFor: 'copying' stamp: 'dkh 6/21/2012 17:59'! copyFrom: start to: stop "Answer a copy of a subset of the receiver, starting from element at index start until element at index stop." | newSize new j | newSize := stop - start + 1. new := self species new: newSize. j := 0. start to: stop do: [:i | new at: j + 1 put: (self at: i). j := j + 1 ]. ^new! ! !MetacelloSemanticVersionNumber methodsFor: 'enumerating' stamp: 'dkh 6/21/2012 17:59'! do: elementBlock separatedBy: separatorBlock "Evaluate the elementBlock for all elements in the receiver, and evaluate the separatorBlock between." | beforeFirst | beforeFirst := true. self do: [:each | beforeFirst ifTrue: [beforeFirst := false] ifFalse: [separatorBlock value]. elementBlock value: each]! ! !MetacelloSemanticVersionNumber methodsFor: 'comparing' stamp: 'dkh 6/21/2012 17:59'! ~> aMetacelloVersionNumber aMetacelloVersionNumber size == 1 ifTrue: [ ^false ]. ^self >= aMetacelloVersionNumber and: [ self < aMetacelloVersionNumber approximateBase ]! ! !MetacelloSemanticVersionNumber methodsFor: 'comparing' stamp: 'dkh 6/21/2012 19:52'! < aMetacelloVersionNumber aMetacelloVersionNumber species = self species ifFalse: [ ^ false ]. ^ self compareLessThan: aMetacelloVersionNumber! ! !MetacelloSemanticVersionNumber methodsFor: 'private' stamp: 'dkh 6/22/2012 15:20'! compareLessThan: aMetacelloVersionNumber | myComponents otherComponents defaultResult | aMetacelloVersionNumber species = self species ifFalse: [ ^ false ]. myComponents := self normalVersion. otherComponents := aMetacelloVersionNumber normalVersion. defaultResult := true. (self compareEqualTo: myComponents other: otherComponents) ifTrue: [ defaultResult := false ] ifFalse: [ (self compareLessThan: myComponents other: otherComponents version: #'normal') ifFalse: [ ^ false ] ]. myComponents := self preReleaseVersion. otherComponents := aMetacelloVersionNumber preReleaseVersion. (self compareEqualTo: myComponents other: otherComponents) ifTrue: [ myComponents size > 0 ifTrue: [ defaultResult := false ] ] ifFalse: [ ^ self compareLessThan: myComponents other: otherComponents version: #'preRelease' ]. myComponents := self buildVersion. otherComponents := aMetacelloVersionNumber buildVersion. ^ (self compareEqualTo: myComponents other: otherComponents) ifTrue: [ defaultResult ] ifFalse: [ self compareLessThan: myComponents other: otherComponents version: #'build' ]! ! !MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: 'dkh 6/21/2012 21:06'! buildVersion buildVersion ifNil: [ buildVersion := #() ]. ^ buildVersion! ! !MetacelloSemanticVersionNumber methodsFor: 'comparing' stamp: 'dkh 6/22/2012 14:57'! match: aVersionPattern "Answer whether the version number of the receiver matches the given pattern string. A Metacello version number is made up of version sequences delimited by the characters $. and $-. The $. introduces a numeric version sequence and $- introduces an alphanumeric version sequence. A version pattern is made up of version pattern match sequences. also delimited by the characters $. and $-.. Each pattern match sequence is tested against the corresponding version sequence of the receiver, using the 'standard' pattern matching rules. All sequences must answer true for a match. The special pattern sequence '?' is a match for the corresponding version sequence and all subsequent version sequences. '?' as the version pattern matches all versions. No more version pattern sequences are permitted once the '?' sequence is used. If used, it is the last version pattern sequence. " | patternVersion mySize patternSize components | patternVersion := (self class fromString: aVersionPattern forPattern: true) versionComponents. components := self versionComponents. mySize := components size. patternSize := patternVersion size. mySize = patternSize ifFalse: [ mySize < patternSize ifTrue: [ ^ false ]. (patternVersion at: patternSize) ~= '?' ifTrue: [ ^ false ]. mySize := patternSize ]. 1 to: mySize do: [ :i | | pattern | pattern := (patternVersion at: i) asString. pattern = '?' ifTrue: [ i = mySize ifFalse: [ ^ self error: 'Invalid version match pattern: ' , aVersionPattern printString ] ] ifFalse: [ (pattern match: (components at: i) asString) ifFalse: [ ^ false ] ] ]. ^ true! ! !MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: 'dkh 6/21/2012 21:05'! buildVersion: anObject buildVersion := anObject! ! !MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: 'dkh 6/21/2012 17:59'! versionString | strm | strm := WriteStream on: String new. self printOn: strm. ^strm contents! ! !MetacelloSemanticVersionNumber methodsFor: 'converting' stamp: 'dkh 6/21/2012 18:02'! asMetacelloSemanticVersionNumber ^ self! ! !MetacelloSemanticVersionNumber methodsFor: 'private' stamp: 'dkh 6/22/2012 11:02'! compareEqualTo: aMetacelloVersionNumber aMetacelloVersionNumber species = self species ifFalse: [ ^ false ]. (self compareEqualTo: self normalVersion other: aMetacelloVersionNumber normalVersion) ifFalse: [ ^ false ]. (self compareEqualTo: self preReleaseVersion other: aMetacelloVersionNumber preReleaseVersion) ifFalse: [ ^ false ]. ^ self compareEqualTo: self buildVersion other: aMetacelloVersionNumber buildVersion! ! !MetacelloSemanticVersionNumber methodsFor: 'private' stamp: 'dkh 6/21/2012 21:26'! compareEqualTo: myComponents other: otherComponents | mySize | mySize := myComponents size. mySize = otherComponents size ifFalse: [ ^ false ]. 1 to: mySize do: [ :i | (myComponents at: i) = (otherComponents at: i) ifFalse: [ ^ false ] ]. ^ true! ! !MetacelloSemanticVersionNumber methodsFor: 'printing' stamp: 'dkh 6/21/2012 21:17'! printOn: aStream self print: self normalVersion prefix: nil on: aStream. self print: self preReleaseVersion prefix: $- on: aStream. self print: self buildVersion prefix: $+ on: aStream! ! !MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: 'dkh 6/21/2012 17:59'! approximateBase | base | base := self copyFrom: 1 to: self size - 1. base at: base size put: (base at: base size) + 1. ^base! ! !MetacelloSemanticVersionNumber methodsFor: 'private' stamp: 'dkh 6/22/2012 14:44'! versionComponents ^ self normalVersion , self preReleaseVersion , self buildVersion! ! !MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: 'dkh 6/21/2012 21:06'! preReleaseVersion preReleaseVersion ifNil: [ preReleaseVersion := #() ]. ^ preReleaseVersion! ! !MetacelloSemanticVersionNumber methodsFor: 'private' stamp: 'dkh 6/22/2012 15:28'! compareLessThan: myComponents other: otherComponents version: version | mySize aSize commonSize count more | mySize := myComponents size. aSize := otherComponents size. commonSize := mySize min: aSize. count := 0. more := true. [ more and: [ count < commonSize ] ] whileTrue: [ (myComponents at: count + 1) = (otherComponents at: count + 1) ifTrue: [ count := count + 1 ] ifFalse: [ more := false ] ]. count < commonSize ifTrue: [ ^ (myComponents at: count + 1) metacelloSemanticVersionComponentLessThan: (otherComponents at: count + 1) ]. mySize < aSize ifTrue: [ mySize = 0 ifTrue: [ #'preRelease' == version ifTrue: [ ^ false ]. ^ true ]. (myComponents at: commonSize) = (otherComponents at: commonSize) ifFalse: [ ^ true ]. ^ true ] ifFalse: [ mySize = aSize ifTrue: [ ^ false ]. aSize = 0 ifTrue: [ #'build' == version ifTrue: [ ^ false ]. ^ true ]. (myComponents at: commonSize) = (otherComponents at: commonSize) ifFalse: [ ^ false ]. ^ true ]! ! !MetacelloSemanticVersionNumber methodsFor: 'printing' stamp: 'dkh 07/09/2012 16:15'! asString "Answer a string that represents the receiver." ^ self printString! ! !MetacelloSemanticVersionNumber methodsFor: 'comparing' stamp: 'dkh 6/22/2012 16:10'! hash ^ self versionComponents hash! ! !MetacelloSemanticVersionNumber methodsFor: 'operations' stamp: 'dkh 6/21/2012 17:59'! decrementMinorVersionNumber | int | self size to: 1 by: -1 do: [ :index | (int := self at: index) isString ifFalse: [ int > 0 ifTrue: [ self at: index put: int - 1 ]. ^ self ] ]! ! !MetacelloSemanticVersionNumber methodsFor: 'operations' stamp: 'dkh 6/21/2012 17:59'! incrementMinorVersionNumber | int | self size to: 1 by: -1 do: [:index | (int := self at: index) isString ifFalse: [ self at: index put: int + 1. ^self ]].! ! !MetacelloSemanticVersionNumber methodsFor: 'comparing' stamp: 'dkh 6/21/2012 19:53'! = aMetacelloVersionNumber aMetacelloVersionNumber species = self species ifFalse: [ ^ false ]. ^ self compareEqualTo: aMetacelloVersionNumber! ! !MetacelloSemanticVersionNumber methodsFor: 'enumerating' stamp: 'dkh 6/21/2012 17:59'! do: aBlock "Refer to the comment in Collection|do:." 1 to: self size do: [:index | aBlock value: (self at: index)]! ! !MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: 'dkh 6/21/2012 21:05'! preReleaseVersion: anObject preReleaseVersion := anObject! ! !MetacelloSemanticVersionNumber methodsFor: 'printing' stamp: 'dkh 6/21/2012 21:16'! print: components prefix: prefixChar on: aStream | beforeFirst | beforeFirst := true. components do: [ :component | beforeFirst ifTrue: [ beforeFirst := false. prefixChar ifNotNil: [ aStream nextPut: prefixChar ] ] ifFalse: [ aStream nextPut: $. ]. aStream nextPutAll: component asString ]! ! !MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: 'dkh 6/21/2012 21:05'! normalVersion: anObject normalVersion := anObject! ! !MetacelloSemanticVersionNumber methodsFor: 'accessing' stamp: 'dkh 6/21/2012 21:06'! normalVersion normalVersion ifNil: [ normalVersion := #() ]. ^ normalVersion! ! !MetacelloSemanticVersionNumber class methodsFor: 'private' stamp: 'dkh 6/21/2012 18:43'! isSemanticIdentifier: aString "whether the receiver is composed entirely of alphanumerics" aString do: [ :c | c isAlphaNumeric ifFalse: [ c = $- ifFalse: [ ^ false ] ] ]. ^ true! ! !MetacelloSemanticVersionNumber class methodsFor: 'private' stamp: 'dkh 6/22/2012 14:53'! extractNumericComponent: subString forPattern: forPattern "$. separated components are integers" | number | forPattern ifTrue: [ ^ subString ]. number := [ subString asNumber ] on: Error do: [ :ex | ex return: subString ]. ^ number asString = subString ifTrue: [ number ] ifFalse: [ subString ]! ! !MetacelloSemanticVersionNumber class methodsFor: 'instance creation' stamp: 'dkh 6/22/2012 14:50'! fromString: aString ^ self fromString: aString forPattern: false! ! !MetacelloSemanticVersionNumber class methodsFor: 'instance creation' stamp: 'dkh 6/22/2012 16:48'! fromString: aString forPattern: forPattern | new tokens preRelease build versionString identifierCount normalEnd preReleaseEnd normalComponents preReleaseComponents buildComponents | normalComponents := OrderedCollection new. preReleaseComponents := OrderedCollection new. buildComponents := OrderedCollection new. preRelease := aString indexOf: $- startingAt: 1. build := aString indexOf: $+ startingAt: 1. (build > 0 and: [ preRelease > build ]) ifTrue: [ preRelease := 0 ]. normalEnd := preRelease = 0 ifTrue: [ build = 0 ifTrue: [ aString size ] ifFalse: [ build - 1 ] ] ifFalse: [ preRelease - 1 ]. versionString := aString copyFrom: 1 to: normalEnd. identifierCount := 0. (versionString findTokens: '.') do: [ :subString | | integer | forPattern ifTrue: [ integer := subString ] ifFalse: [ integer := subString asInteger. integer < 0 ifTrue: [ self error: 'invalid version number: normal version component must be integer ' , subString printString ] ]. normalComponents add: integer. identifierCount := identifierCount + 1 ]. (forPattern not and: [ identifierCount ~= 3 ]) ifTrue: [ self error: 'invalid version number: normal version must have only 3 components' ]. preReleaseEnd := build = 0 ifTrue: [ aString size ] ifFalse: [ build - 1 ]. preRelease > 0 ifTrue: [ versionString := aString copyFrom: preRelease + 1 to: preReleaseEnd. (versionString findTokens: '.') do: [ :subString | (forPattern or: [ self isSemanticIdentifier: subString ]) ifFalse: [ self error: 'invalid version number: preRelease version component must be one of [0-9A-Za-z-]' ]. preReleaseComponents add: (self extractNumericComponent: subString forPattern: forPattern) ] ]. build > 0 ifTrue: [ versionString := aString copyFrom: build + 1 to: aString size. (versionString findTokens: '.') do: [ :subString | (forPattern or: [ self isSemanticIdentifier: subString ]) ifFalse: [ self error: 'invalid version number: build version component must be one of [0-9A-Za-z-]' ]. buildComponents add: (self extractNumericComponent: subString forPattern: forPattern) ] ]. ^ self new normalVersion: normalComponents; preReleaseVersion: preReleaseComponents; buildVersion: buildComponents; yourself! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/21/2012 18:08'! validateSemanticVersionStrings: versionStrings | versions version | versions := versionStrings collect: [ :each | each asMetacelloSemanticVersionNumber ]. version := versions at: 1. 2 to: versions size do: [ :index | | nextVersion | nextVersion := versions at: index. self assert: version < nextVersion. version := nextVersion ]! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 15:34'! testSemanticVersioning self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0-rc.1+build.2' '1.0.0-rc.2+build.0'). self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0+build.0'). self validateSemanticVersionStrings: #('1.0.0-alpha' '1.0.0-1'). self validateSemanticVersionStrings: #('1.0.0-1' '1.0.0+alpha'). self validateSemanticVersionStrings: #('1.0.0-alpha' '1.0.0+1'). self validateSemanticVersionStrings: #('1.0.0+alpha' '1.0.0+1'). self validateSemanticVersionStrings: #('1.0.0--' '1.0.0-a'). self validateSemanticVersionStrings: #('1.0.0+-' '1.0.0+a'). self validateSemanticVersionStrings: #('1.0.0-rc.1' '1.0.0' '1.0.0+build.1'). self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0-rc.1+build.2' '1.0.0-rc.2+build.3'). self validateSemanticVersionStrings: #('1.0.0-rc.1' '1.0.0-rc.1+build.2' '1.0.0-rc.2'). self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0-rc.1+build.2' '1.0.0-rc.2'). self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0-rc.1+build.2' '1.0.0-rc.2+build.2'). self validateSemanticVersionStrings: #('1.0.0-rc.1+build.1' '1.0.0' '1.0.0+build.0'). self validateSemanticVersionStrings: #('1.0.0+10000' '1.0.0+a'). self validateSemanticVersionStrings: #('1.0.0-10000' '1.0.0-a')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/21/2012 18:08'! testSemanticVersioningSpecItem11 "[Semantic Versioning 2.0.0-rc.1](http://semver.org/)" self validateSemanticVersionStrings: #('1.0.0+build.1' '1.3.7+build.11.e0f985a')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:55'! testVersion09 | v1 v2 | v1 := self versionClass fromString: '1.0.0'. v2 := self versionClass fromString: '0.7.0'. self assert: v1 >= v2. self assert: v2 <= v1! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/21/2012 18:11'! testSemanticVersioningSubsetCompliance "subset of sample versions that are compatible with MetacellVersionNumber syntax" self validateSemanticVersionStrings: #('1.0.0-alpha' '1.0.0-alpha.1' '1.0.0-beta.2' '1.0.0-beta.11' '1.0.0-rc.1' '1.0.0')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:56'! testVersion16 self assert: (self versionClass fromString: '1.0.0-beta.0') < (self versionClass fromString: '1.0.0')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 11:29'! testLessThanComparison self assert: '1.0.0-rc.1+build.1' asMetacelloSemanticVersionNumber < '1.0.0' asMetacelloSemanticVersionNumber. self assert: '1.0.0-rc.1+build.1' asMetacelloSemanticVersionNumber < '1.0.0+build.0' asMetacelloSemanticVersionNumber. self assert: '1.0.0-alpha.1' asMetacelloSemanticVersionNumber < '1.0.0-0.3.7' asMetacelloSemanticVersionNumber. self assert: '1.0.0-alpha' asMetacelloSemanticVersionNumber < '1.0.0-alpha.1' asMetacelloSemanticVersionNumber. self assert: '1.0.0+-' asMetacelloSemanticVersionNumber < '1.0.0+a' asMetacelloSemanticVersionNumber. self assert: '1.0.0-0.3.7' asMetacelloSemanticVersionNumber < '1.0.0-x.7.z.92' asMetacelloSemanticVersionNumber! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 09:00'! testEqualityComparison self deny: '1.0.0+-' asMetacelloSemanticVersionNumber = '1.0.0--' asMetacelloSemanticVersionNumber. self sampleVersionStrings do: [ :versionString | self assert: versionString asMetacelloSemanticVersionNumber = versionString asMetacelloSemanticVersionNumber ]! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/21/2012 18:08'! testSemanticVersioningSpecItem10 "[Semantic Versioning 2.0.0-rc.1](http://semver.org/)" self validateSemanticVersionStrings: #('1.0.0-alpha' '1.0.0-alpha.1' '1.0.0-0.3.7' '1.0.0-x.7.z.92')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 11:18'! sampleVersionStrings ^ #('1.0.0+-' '1.0.0-alpha' '1.0.0-alpha.1' '1.0.0-0.3.7' '1.0.0-x.7.z.92') , #('1.0.0+build.1' '1.3.7+build.11.e0f985a') , #('1.0.0-alpha' '1.0.0-alpha.1' '1.0.0-beta.2' '1.0.0-beta.11' '1.0.0-rc.1' '1.0.0-rc.1+build.1' '1.0.0' '1.0.0+0.3.7' '1.3.7+build' '1.3.7+build.2.b8f12d7' '1.3.7+build.11.e0f985a') , #('1.0.0-alp-h-a' '1.0.0-r-c.1' '1.0.0+alp-h-a' '1.0.0+r-c.1')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'test matching' stamp: 'dkh 6/22/2012 16:50'! testStandardMatch self assert: ((self versionClass fromString: '1.0.0+alpha5.0') match: '1.0.0+alpha#.0'). self assert: ((self versionClass fromString: '1.1.1') match: '*.*.*'). self deny: ((self versionClass fromString: '1.1.1') match: '*.*'). self assert: ((self versionClass fromString: '1.1.0') match: '1.1.*'). self assert: ((self versionClass fromString: '1.1.0') match: '1.#.*'). self deny: ((self versionClass fromString: '1.10.0+build.0') match: '1.#.*'). self assert: ((self versionClass fromString: '1.0.0-alpha5.0') match: '1.0.0-alpha#.0'). self assert: ((self versionClass fromString: '1.0.0-alpha5+build5.0') match: '1.0.0-alpha5+build#.0'). self deny: ((self versionClass fromString: '1.0.0-alpha10.0') match: '1.0.0-alpha#.0')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/21/2012 18:08'! testSemanticVersioningSpecItem12 "According to [Semantic Versioning 2.0.0-rc.1](http://semver.org/), the following expression should be true: 1.0.0-alpha < 1.0.0-alpha.1 < 1.0.0-beta.2 < 1.0.0-beta.11 < 1.0.0-rc.1 < 1.0.0-rc.1+build.1 < 1.0.0 < 1.0.0+0.3.7 < 1.3.7+build < 1.3.7+build.2.b8f12d7 < 1.3.7+build.11.e0f985a" self validateSemanticVersionStrings: #('1.0.0-alpha' '1.0.0-alpha.1' '1.0.0-beta.2' '1.0.0-beta.11' '1.0.0-rc.1' '1.0.0-rc.1+build.1' '1.0.0' '1.0.0+0.3.7' '1.3.7+build' '1.3.7+build.2.b8f12d7' '1.3.7+build.11.e0f985a')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'test matching' stamp: 'dkh 6/22/2012 15:00'! testSpecialMatch self assert: ((self versionClass fromString: '1.1.0') match: '?'). self assert: ((self versionClass fromString: '1.0.0-alpha') match: '?'). self assert: ((self versionClass fromString: '1.0.0-rc.1+build.1') match: '?'). self assert: ((self versionClass fromString: '1.1.0') match: '*.*.?'). self assert: ((self versionClass fromString: '1.3.7+build.2.b8f12d7') match: '?'). self assert: ((self versionClass fromString: '1.3.7+build.11.e0f985a') match: '?'). self deny: ((self versionClass fromString: '1.1.0') match: '*.*.*-?'). self deny: ((self versionClass fromString: '1.1.0') match: '*.*.*+?'). self assert: ((self versionClass fromString: '1.1.1') match: '*.?')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:50'! testVersion10 | x y | self assert: (x := (({(self versionClass fromString: '1.0.0'). (self versionClass fromString: '0.7.0'). (self versionClass fromString: '0.8.0'). (self versionClass fromString: '0.9.0'). (self versionClass fromString: '1.0.1')} sort: [ :a :b | a <= b ]) collect: [ :each | each versionString ]) asArray) = (y := #('0.7.0' '0.8.0' '0.9.0' '1.0.0' '1.0.1'))! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:55'! testVersion15 self assert: (self versionClass fromString: '1.0.0-beta.0') < (self versionClass fromString: '1.0.0-beta.1')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:57'! testVersion17 self assert: (self versionClass fromString: '1.0.0') > (self versionClass fromString: '1.0.0-0'). self assert: (self versionClass fromString: '1.0.0') > (self versionClass fromString: '1.0.0-beta.0'). self assert: (self versionClass fromString: '1.0.0') > (self versionClass fromString: '1.0.0-beta')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:51'! testVersion18 | x y | self deny: (x := self versionClass fromString: '1.0.0') < (y := self versionClass fromString: '1.0.0-0'). self assert: (x := self versionClass fromString: '1.0.0') > (y := self versionClass fromString: '1.0.0-0'). self assert: (x := self versionClass fromString: '1.0.0') < (y := self versionClass fromString: '1.0.0+0'). self deny: (x := self versionClass fromString: '1.0.0') > (y := self versionClass fromString: '1.0.0+0')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'private' stamp: 'dkh 6/22/2012 14:41'! versionClass ^ MetacelloSemanticVersionNumber! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 08:59'! testPrinting | x vrsn | self sampleVersionStrings do: [ :versionString | self assert: versionString = (x := (vrsn := versionString asMetacelloSemanticVersionNumber) printString) ]! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'test matching' stamp: 'dkh 6/22/2012 12:15'! testInvalidSpecialMatch self should: [ (self versionClass fromString: '1.1.1') match: '?.?.?' ] raise: Error! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:54'! testVersion05 | v1 v2 | v1 := self versionClass fromString: '3.0.0'. v2 := self versionClass fromString: '2.0.0'. self assert: v1 > v2! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:55'! testVersion12 self deny: (self versionClass fromString: '1.0.0') <= (self versionClass fromString: '0.7.0')! ! !MetacelloSemanticVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:57'! testVersion19 self assert: (self versionClass fromString: '1.0.0-beta.0') < (self versionClass fromString: '1.0.0')! ! !MetacelloSkipDirtyPackageLoad methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! packageSpec: aMetacelloPackageSpec packageSpec := aMetacelloPackageSpec! ! !MetacelloSkipDirtyPackageLoad methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! packageSpec ^packageSpec! ! !MetacelloSkipDirtyPackageLoad methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! defaultAction "Default action is to skip the load of a dirty package" ^true! ! !MetacelloSkipDirtyPackageLoad class methodsFor: 'signalling' stamp: 'dkh 6/5/2012 19:01:24'! signal: aMetacelloPackageSpec ^(self new packageSpec: aMetacelloPackageSpec) signal! ! !MetacelloSpec methodsFor: 'mutability' stamp: 'dkh 7/19/2012 15:03'! immutable mutable := false! ! !MetacelloSpec methodsFor: 'spec creation' stamp: 'dkh 6/5/2012 19:01:24'! mergeMember ^MetacelloMergeMemberSpec for: self project! ! !MetacelloSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeSpec: aSpec | newSpec nonOverridable | self validateMergeForSpec: aSpec. newSpec := self copy. nonOverridable := self nonOverridable. aSpec mergeMap keysAndValuesDo: [ :key :value | (nonOverridable includes: key) ifFalse: [ value ~~ nil ifTrue: [ newSpec instVarNamed: key asString put: value ] ] ]. ^ newSpec! ! !MetacelloSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! project ^project! ! !MetacelloSpec methodsFor: 'accessing' stamp: 'dkh 7/19/2012 15:07'! loader: aLoader "We're interested in propogating the loader state, _except_ for the spec" self shouldBeMutable. loader := aLoader copy. loader spec: self! ! !MetacelloSpec methodsFor: 'doits' stamp: 'dkh 6/5/2012 19:01:24'! postLoadDoIt "noop unless non-nil value returned" ^nil! ! !MetacelloSpec methodsFor: 'doits' stamp: 'dkh 6/5/2012 19:01:24'! preLoadDoIt "noop unless non-nil value returned" ^nil! ! !MetacelloSpec methodsFor: 'mutability' stamp: 'dkh 7/19/2012 15:03'! mutable mutable := true! ! !MetacelloSpec methodsFor: 'doits' stamp: 'dkh 6/5/2012 19:01:24'! postLoadDoItBlock ^self doItBlock: self postLoadDoIt value ! ! !MetacelloSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodOn: aStream self configMethodOn: aStream indent: 0 ! ! !MetacelloSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeMap ^Dictionary new. ! ! !MetacelloSpec methodsFor: 'initialization' stamp: 'dkh 7/19/2012 15:09'! for: aProject self shouldBeMutable. project := aProject! ! !MetacelloSpec methodsFor: 'doits' stamp: 'dkh 6/5/2012 19:01:24'! preLoadDoItBlock ^self doItBlock: self preLoadDoIt value ! ! !MetacelloSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! printOn: aStream self configMethodOn: aStream indent: 0 ! ! !MetacelloSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! validateMergeForSpec: aSpec aSpec class = self class ifFalse: [ self error: 'The project spec ' , self name printString , ' in project ' , self project label , ' has incompatible specs. ' , aSpec class name asString , ' and ' , self class name asString , ' are not compatible.' ]! ! !MetacelloSpec methodsFor: 'spec creation' stamp: 'dkh 6/5/2012 19:01:24'! addMember ^MetacelloAddMemberSpec for: self project! ! !MetacelloSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! nonOverridable ^#()! ! !MetacelloSpec methodsFor: 'mutability' stamp: 'dkh 7/19/2012 15:03'! isMutable mutable ifNil: [ ^ true ]. ^ mutable! ! !MetacelloSpec methodsFor: 'mutability' stamp: 'dkh 7/19/2012 15:06'! shouldBeMutable self isMutable ifTrue: [ ^ self ]. self error: 'Not allowed to modify an immutable object'! ! !MetacelloSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! loader loader == nil ifTrue: [ | prjctLoader | (prjctLoader := self project loader) == nil ifTrue: [ self loader: (self project loaderClass on: self) ] ifFalse: [ self loader: prjctLoader ]]. ^loader! ! !MetacelloSpec methodsFor: 'doits' stamp: 'dkh 6/5/2012 19:01:24'! doItBlock: selector selector == nil ifTrue: [ ^nil ]. selector numArgs = 0 ifTrue: [ ^[ self project configuration perform: selector ] ]. selector numArgs = 1 ifTrue: [ ^[:aLoader | self project configuration perform: selector with: aLoader ] ]. selector numArgs = 2 ifTrue: [ ^[:aLoader :pkgSpec | self project configuration perform: selector with: aLoader with: pkgSpec ] ]. ^nil ! ! !MetacelloSpec methodsFor: 'spec creation' stamp: 'dkh 6/5/2012 19:01:24'! copyMember ^MetacelloCopyMemberSpec for: self project! ! !MetacelloSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! aboutToCopy ! ! !MetacelloSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! label ^self printString! ! !MetacelloSpec methodsFor: 'copying' stamp: 'dkh 7/19/2012 21:12'! postCopy super postCopy. mutable := nil. loader ~~ nil ifTrue: [ self loader: loader ]. ! ! !MetacelloSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! answers ^#()! ! !MetacelloSpec methodsFor: 'spec creation' stamp: 'dkh 6/5/2012 19:01:24'! removeMember ^MetacelloRemoveMemberSpec for: self project! ! !MetacelloSpec methodsFor: 'mutability' stamp: 'dkh 7/19/2012 16:44'! copyOnWrite: aBlock "assume that only registered projects are immutable ... otherwise you'll get an error" | copy | copy := self copy. aBlock value: copy. ^ copy! ! !MetacelloSpec methodsFor: 'importing' stamp: 'dkh 6/26/2012 16:34'! mergeImportLoads: aLoadList self error: 'import: can only be used with baseline project specs'! ! !MetacelloSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodOn: aStream indent: indent self subclassResponsibility ! ! !MetacelloSpec class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! for: aVersionMap ^(self platformClass new) for: aVersionMap; yourself! ! !MetacelloSpec class methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! platformClass ^self! ! !MetacelloSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! spec: aMetacelloPackagesSpec spec := aMetacelloPackagesSpec! ! !MetacelloSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! project ^self spec project! ! !MetacelloSpecLoader methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! unload self subclassResponsibility! ! !MetacelloSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! loadType "#atomic or #linear" ^self project loadType! ! !MetacelloSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! spec ^spec! ! !MetacelloSpecLoader methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! load self subclassResponsibility! ! !MetacelloSpecLoader class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! on: aMetacelloPackagesSpec ^(self new) spec: aMetacelloPackagesSpec; yourself! ! !MetacelloSpecTestCase methodsFor: 'specs' stamp: 'dkh 5/4/2012 20:37:12'! projectSpec ^ self project projectSpec! ! !MetacelloSpecTestCase methodsFor: 'accessing' stamp: 'dkh 5/4/2012 20:37:12'! projectWith: projectAttributes | project | "Construct Metacello project" project := self projectClass new. project projectAttributes: projectAttributes. MetacelloVersionConstructor on: self project: project. project loader: MetacelloNullRecordingMCSpecLoader new. ^ project! ! !MetacelloSpecTestCase methodsFor: 'specs' stamp: 'dkh 5/4/2012 20:37:12'! groupSpec ^ self project groupSpec! ! !MetacelloSpecTestCase methodsFor: '*metacello-testsmccore' stamp: 'dkh 6/12/2012 15:41:23.319'! packageSpec ^ self project packageSpec! ! !MetacelloSpecTestCase methodsFor: 'accessing' stamp: 'dkh 5/4/2012 20:37:12'! projectClass ^ MetacelloProject! ! !MetacelloSpecTestCase methodsFor: 'specs' stamp: 'dkh 5/4/2012 20:37:12'! versionSpec ^ self project versionSpec! ! !MetacelloSpecTestCase methodsFor: 'accessing' stamp: 'dkh 5/4/2012 20:37:12'! project ^ self projectWith: #()! ! !MetacelloSpecTestCase methodsFor: 'specs' stamp: 'dkh 5/4/2012 20:37:12'! packagesSpec ^ self project packagesSpec! ! !MetacelloSpecTestCase methodsFor: '*metacello-testsmccore' stamp: 'dkh 6/12/2012 15:41:23.319'! repositoriesSpec ^ self project repositoriesSpec! ! !MetacelloSpecTestCase methodsFor: 'specs' stamp: 'dkh 5/4/2012 20:37:12'! projectReferenceSpec ^ self project projectReferenceSpec! ! !MetacelloSpecTestCase methodsFor: 'specs' stamp: 'dkh 5/4/2012 20:37:12'! valueHolderSpec ^ self project valueHolderSpec! ! !MetacelloSpecTestCase methodsFor: '*metacello-testsmccore' stamp: 'dkh 6/12/2012 15:41:23.319'! repositorySpec ^ self project repositorySpec! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testClearCache MetacelloPlatform current stackCacheFor: #cached at: #key doing: [:cache | | value | cache at: #x put: 1. self assert: (cache at: #x ifAbsent: []) == 1. MetacelloClearStackCacheNotification signal. self assert: (cache at: #x ifAbsent: []) == nil ] ! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testCollectionCacheKey | x | self assert: (Array with: self class with: (Array with: 'faux' with: 'foobar')) = (Array with: self class with: (Array with: 'faux' with: 'foobar')). self deny: (Array with: self class with: (Array with: 'faux' with: 'foobar')) = (Array with: self class with: (Array with: 'faux' with: 'foobar' with: 'foobaz')). self assert: (x := self collectionCacheKey) == 6. ! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! cachedReturnOfValue ^MetacelloPlatform current stackCacheFor: #cached at: #key doing: [:cache | | value | value := cache at: #x ifAbsent: [ 0 ]. value > 5 ifTrue: [ cache at: #key put: value ] ifFalse: [ value := value + 1. cache at: #x put: value ]. self cachedReturnOfValue ] ! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! directReturnOfValue ^MetacelloPlatform current stackCacheFor: #direct at: #key doing: [:cache | | value | value := cache at: #x ifAbsent: [ 0 ]. value > 5 ifTrue: [ ^value ]. value := value + 1. cache at: #x put: value. self directReturnOfValue ] ! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testCacheNil | x | self assert: (x := self cacheNil) == nil! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! cacheNil ^MetacelloPlatform current stackCacheFor: #cacheNil at: #key doing: [:cache | | value | cache at: #key put: nil. self cacheNil ] ! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testMixedStack | x | self assert: (x := self mixedStack) == 4! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testDefaultDictionary | defaultDictionary | defaultDictionary := Dictionary new. MetacelloPlatform current useStackCacheDuring: [:dict | self cachedReturnOfValue; collectionCacheKey; cacheNil; directReturnOfValue; mixedStack; mixedStackCall ] defaultDictionary: defaultDictionary. self assert: (defaultDictionary includesKey: #cached). self assert: (defaultDictionary includesKey: #cacheNil). self assert: (defaultDictionary includesKey: #collection). self assert: (defaultDictionary includesKey: #direct). self assert: (defaultDictionary includesKey: #mixed). self assert: (defaultDictionary includesKey: #mixedStack). ! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testCachedReturn | x | self assert: (x := self cachedReturnOfValue) == 6! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! collectionCacheKey | key | key := Array with: self class with: (Array with: #x with: #y). ^MetacelloPlatform current stackCacheFor: #collection at: key doing: [:cache | | value | value := cache at: #x ifAbsent: [ 0 ]. value > 5 ifTrue: [ cache at: key put: value ] ifFalse: [ value := value + 1. cache at: #x put: value ]. self collectionCacheKey ] ! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! mixedStack ^MetacelloPlatform current stackCacheFor: #mixed at: #key doing: [:cache | | value | value := cache at: #x ifAbsent: [ 0 ]. value > 3 ifTrue: [ ^value ]. value := value + 1. cache at: #x put: value. self assert: self directReturnOfValue == 6. self assert: self mixedStackCall == 4. self mixedStack ] ! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testDirectReturn | x | self assert: (x := self directReturnOfValue) == 6! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testPrimeStackCache | cached collection cacheNil direct mixed mixedStack block defaultDictionary | defaultDictionary := Dictionary new. block := [ cached := Dictionary new. collection := Dictionary new. cacheNil := Dictionary new. direct := Dictionary new. mixed := Dictionary new. mixedStack := Dictionary new. MetacelloPlatform current useStackCacheDuring: [ :dict | self cachedReturnOfValue ] defaultDictionary: cached. MetacelloPlatform current useStackCacheDuring: [ :dict | self collectionCacheKey ] defaultDictionary: collection. MetacelloPlatform current useStackCacheDuring: [ :dict | self cacheNil ] defaultDictionary: cacheNil. MetacelloPlatform current useStackCacheDuring: [ :dict | self directReturnOfValue ] defaultDictionary: direct. MetacelloPlatform current useStackCacheDuring: [ :dict | self mixedStack ] defaultDictionary: mixed. MetacelloPlatform current useStackCacheDuring: [ :dict | self mixedStackCall ] defaultDictionary: mixedStack ]. "Test without priming stack cache ... each defaultDictionary is used independently" block value. self assert: ((cached at: #cached) at: #key) == 6. self assert: ((collection at: #collection) at: #x) == 6. self assert: ((cacheNil at: #cacheNil) at: #key) == nil. self assert: ((direct at: #direct) at: #x) == 6. self assert: ((mixed at: #cached) at: #key) == 6. self assert: ((mixed at: #mixed) at: #x) == 4. self assert: ((mixed at: #mixedStack) at: #x) == 4. self assert: ((mixed at: #direct) at: #x) == 6. self assert: ((mixedStack at: #cached) at: #key) == 6. self assert: ((mixedStack at: #mixedStack) at: #x) == 4. "Prime stack cache with defaultDictionary .... all values should be stored there instead of individual defaults." MetacelloPlatform current primeStackCacheWith: defaultDictionary doing: block. self assert: ((defaultDictionary at: #cached) at: #key) == 6. self assert: ((defaultDictionary at: #collection) at: #x) == 6. self assert: ((defaultDictionary at: #cacheNil) at: #key) == nil. self assert: ((defaultDictionary at: #direct) at: #x) == 6. self assert: ((defaultDictionary at: #cached) at: #key) == 6. self assert: ((defaultDictionary at: #mixed) at: #x) == 4. self assert: ((defaultDictionary at: #mixedStack) at: #x) == 4. self assert: ((defaultDictionary at: #direct) at: #x) == 6. self assert: ((defaultDictionary at: #cached) at: #key) == 6. self assert: ((defaultDictionary at: #mixedStack) at: #x) == 4! ! !MetacelloStackCacheTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! mixedStackCall ^MetacelloPlatform current stackCacheFor: #mixedStack at: #key doing: [:cache | | value | value := cache at: #x ifAbsent: [ 0 ]. value > 3 ifTrue: [ ^value ]. value := value + 1. cache at: #x put: value. self assert: self cachedReturnOfValue == 6. self mixedStackCall ] ! ! !MetacelloSymbolicVersionDoesNotExistError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! possibleVersions ^ self project symbolicVersionSymbols! ! !MetacelloSymbolicVersionDoesNotExistError methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! description "Return a textual description of the exception." ^ 'The symbolic version ' , self versionString printString , ' is not defined in ' , self project label , ' for the current platform. Possible symbolic version values include: ' , self possibleVersions printString! ! !MetacelloSymbolicVersionMethodSpec methodsFor: 'method generation' stamp: 'dkh 9/7/2012 10:44'! methodSource | strm | strm := WriteStream on: String new. self symbolicMethodSelectorAndPragma: self selector symbolicVersionSymbol: self versionString on: strm. (self methodSections asArray sort: [ :a :b | a attributes first <= b attributes first ]) do: [ :methodSection | | vs | strm cr; tab; nextPutAll: 'spec for: ' , methodSection attributePrintString , ' version: '. vs := methodSection versionString. vs isSymbol ifTrue: [ strm nextPut: $# ]. strm nextPutAll: vs asString printString , '.'; cr ]. ^ strm contents! ! !MetacelloSymbolicVersionMethodSpec methodsFor: 'method generation' stamp: 'dkh 6/5/2012 19:01:24'! symbolicMethodSelectorAndPragma: aSelector symbolicVersionSymbol: symbolicVersionSymbol on: strm strm nextPutAll: aSelector asString , ' spec'; cr; tab; nextPutAll: ''; cr! ! !MetacelloSymbolicVersionMethodSpec methodsFor: 'adding' stamp: 'dkh 9/9/2012 07:33'! addMethodSection: attribute versionString: aString self methodSections add: (MetacelloSymbolicVersionSpec new attributes: attribute asMetacelloAttributeList; versionString: aString; yourself)! ! !MetacelloSymbolicVersionMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString: aStringOrSymbol aStringOrSymbol isSymbol ifFalse: [ self error: 'Version symbol ', aStringOrSymbol printString, ' for symbolic version method must be a Symbol' ]. super versionString: aStringOrSymbol! ! !MetacelloSymbolicVersionNotDefinedError methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! description "Return a textual description of the exception." ^ 'The symbolic version ' , self versionString printString , ' is EXPLICITLY not defined in ' , self project label , ' for the current platform (i.e., symbolic version defined as #notDefined).'! ! !MetacelloSymbolicVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString ^ versionString! ! !MetacelloSymbolicVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString: anObject versionString := anObject! ! !MetacelloTestsGoferCleanup methodsFor: 'cleaning' stamp: 'dkh 6/12/2012 15:41:23.319'! cleanupProtocols: aWorkingCopy "Not needed - for faster test running"! ! !MetacelloTestsGoferUnload methodsFor: 'unloading' stamp: 'dkh 6/12/2012 15:41:23.319'! unloadClasses: aWorkingCopy "skip this so that tests run faster"! ! !MetacelloTestsGoferUnload methodsFor: 'running' stamp: 'dkh 6/12/2012 15:41:23.319'! execute self workingCopies do: [ :copy | self unload: copy ]. self model load. self gofer metacelloCleanup. self workingCopies do: [ :copy | self unregister: copy ]! ! !MetacelloTestsMCPackage methodsFor: 'accessing' stamp: 'dkh 6/17/2013 16:41:23.319'! packageSet "Aiming for speeding up the running of the tests" ^ MetacelloTestsPackageSet named: name ! ! !MetacelloTestsMCPackage methodsFor: 'accessing' stamp: 'dkh 6/17/2013 16:24:12'! packageInfo "Aiming for speeding up the running of the tests" ^ MetacelloTestsPackageSet named: name ! ! !MetacelloTestsPackageSet commentStamp: ''! This class is used to speed up Metacello tests. ! !MetacelloTestsPackageSet methodsFor: 'listing' stamp: 'EstebanLorenzano 5/29/2013 16:09'! extensionMethods "Test packages don't extend classes and skipping this operation is a significant performance gain for running tests" ^ #()! ! !MetacelloTestsPackageSet methodsFor: 'listing' stamp: 'EstebanLorenzano 5/29/2013 16:09'! overriddenMethods "Test packages don't override methods and skipping this operation is a significant performance gain for running tests" ^ #()! ! !MetacelloToolBox commentStamp: ''! MetacelloToolbox implements a toolbox API for Metacello. The toolbox methods on the class-side implement scripts for a number of commonly performed Metacello development tasks. The methods should be used in development scripts or GUI tools so that a common implementation is preserved across the toolset.! !MetacelloToolBox methodsFor: 'private' stamp: 'dkh 3/7/2012 17:08:50'! buildMapFrom: mapList for: packageList | map | map := Dictionary new. mapList do: [ :assoc | | pkgName pkgSpec | pkgName := assoc key. (packageList includes: pkgName) ifFalse: [ self error: 'package ' , pkgName printString , ' not found in packages.' ]. map at: pkgName put: assoc value ]. ^ map! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 9/8/2012 05:05'! modifySection: sectionAttributeOrPath sectionIndex: sectionIndex repository: repositoryDescription requiredProjects: newProjectList packages: newPackageList dependencies: dependecies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: newGroups versionSpecsDo: aBlock " repositoryDescription - metacello repository string newProjectList - collection of project base names (without ConfigurationOf prefix) newPackageList - collection of package base names dependencies - collection of associations where key is name of package and value is collection of required packages and projects includes - collection of associations where key is name of package and value is collection of included packages and projects files - collection of associations where key is name of package and value is name of file repositories - collection of associations where key is name of package and value is collection of repository descriptions preLoadDoIts - collection of associations where key is name of package and value is preload doit selector postLoadDoIts - collection of associations where key is name of package and value is postload doit selector supplyingAnswers - collection of associations where key is name of package and value is the supplyingAnswers array newGroups - collection of associations where key is the name of the group and value is the collection of group members " | versionSpec dependencyMap includesMap filesMap repositoriesMap preLoadDoItsMap postLoadDoItsMap supplyingAnswersMap groups packageList newGroupNames | versionSpec := (self methodSpec findMethodSection: sectionAttributeOrPath asMetacelloAttributePath sectionIndex: sectionIndex) versionSpec. repositoryDescription ~~ nil ifTrue: [ versionSpec repository: repositoryDescription ]. newProjectList do: [ :projectName | (versionSpec packages specListDetect: [ :spec | spec name = projectName ] ifNone: [ ]) == nil ifTrue: [ versionSpec packages merge: (self createProjectReferenceSpec: projectName) ] ifFalse: [ self error: 'Project named: ' , projectName printString , ' already exists.' ] ]. packageList := OrderedCollection new. groups := OrderedCollection new. newGroupNames := OrderedCollection new. versionSpec projectDo: [ :ignored | ] packageDo: [ :pkg | packageList add: pkg name ] groupDo: [ :group | groups add: group name -> group includes. newGroupNames add: group name ]. newPackageList do: [ :packageName | (packageList includes: packageName) ifTrue: [ self error: 'Package named: ' , packageName printString , ' already exists.' ] ifFalse: [ packageList add: packageName ] ]. newGroups do: [ :assoc | (newGroupNames includes: assoc key) ifTrue: [ self error: 'Group named: ' , assoc key printString , ' already exists.' ] ifFalse: [ groups add: assoc ] ]. dependencyMap := self buildMapFrom: dependecies for: packageList. includesMap := self buildMapFrom: includes for: packageList. filesMap := self buildMapFrom: files for: packageList. repositoriesMap := self buildMapFrom: repositories for: packageList. preLoadDoItsMap := self buildMapFrom: preLoadDoIts for: packageList. postLoadDoItsMap := self buildMapFrom: postLoadDoIts for: packageList. supplyingAnswersMap := self buildMapFrom: supplyingAnswers for: packageList. packageList do: [ :packageName | | spec | (newPackageList includes: packageName) ifTrue: [ spec := self createPackageSpec: packageName. versionSpec packages merge: spec ] ifFalse: [ spec := versionSpec packages specListDetect: [ :spc | spc name = packageName ] ]. dependencyMap at: packageName ifPresent: [ :dependencyList | spec setRequires: spec requires , dependencyList ]. includesMap at: packageName ifPresent: [ :includesList | spec setIncludes: spec includes , includesList ]. filesMap at: packageName ifPresent: [ :file | spec file: file ]. repositoriesMap at: packageName ifPresent: [ :repositoriesList | repositoriesList do: [ :repoString | spec repository: repoString ] ]. preLoadDoItsMap at: packageName ifPresent: [ :preLoad | spec preLoadDoIt: preLoad ]. postLoadDoItsMap at: packageName ifPresent: [ :postLoad | spec postLoadDoIt: postLoad ]. supplyingAnswersMap at: packageName ifPresent: [ :answer | spec answers: answer ] ]. groups do: [ :assoc | | spec | (newGroupNames includes: assoc key) ifFalse: [ spec := self createGroupSpec: assoc key. versionSpec packages merge: spec. spec setIncludes: spec includes , assoc value ] ]. aBlock value: versionSpec! ! !MetacelloToolBox methodsFor: 'spec creation' stamp: 'dkh 3/7/2012 17:08:50'! createGroupSpec: baseName ^ (self project groupSpec) name: baseName; yourself! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! abortMethod project := project configuration class project. "recalculate project" methodSpec := nil! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! addSection: sectionAttributeOrPath repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependecies groups: groups versionSpecsDo: aBlock " repositoryDescription - metacello repository string projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names dependencies - collection of associations where key is name of package and value is collection of required packages and projects groups - collection of associations where key is the name of the group and value is the collection of group members " self addSection: sectionAttributeOrPath repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependecies includes: #() files: #() repositories: #() preLoadDoIts: #() postLoadDoIts: #() supplyingAnswers: #() groups: groups versionSpecsDo: aBlock! ! !MetacelloToolBox methodsFor: 'private' stamp: 'dkh 3/7/2012 17:08:50'! ensureMetacello "noop for now"! ! !MetacelloToolBox methodsFor: 'accessing' stamp: 'dkh 3/7/2012 17:08:50'! project ^project! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 9/13/2012 16:43'! updateVersionMethodForVersion: inputVersionStringOrSymbol updateProjects: updateProjects updatePackages: updatePackages versionSpecsDo: aBlock ^ self updateVersionMethodForVersion: inputVersionStringOrSymbol projectAttributes: project attributes updateProjects: updateProjects updatePackages: updatePackages versionSpecsDo: aBlock! ! !MetacelloToolBox methodsFor: 'private' stamp: 'dkh 3/7/2012 17:08:50'! clearVersionSpec: versionSpec fullVersionSpec: fullVersionSpec updateProjects: updateProjects updatePackages: updatePackages versionSpec specListProjectDo: [ :spec | updateProjects ifTrue: [ | fullProjectReferenceSpec fullProjectSpec | (fullProjectReferenceSpec := fullVersionSpec packageNamed: spec name) ~~ nil ifTrue: [ fullProjectSpec := fullProjectReferenceSpec projectReference. fullProjectSpec versionString == nil ifTrue: [ spec projectReference versionString: '' ] ] ] ] packageDo: [ :spec | updatePackages ifTrue: [ spec getFile ~~ nil ifTrue: [ spec file: '' ] ] ] groupDo: [ :ignored | ]! ! !MetacelloToolBox methodsFor: 'testing' stamp: 'dkh 3/7/2012 17:08:50'! hasMethodForSymbolicVersion: versionSymbol ^(self constructor extractSymbolicVersionPragmas at: versionSymbol ifAbsent: [ ^ false ]) size > 0 ! ! !MetacelloToolBox methodsFor: 'validation' stamp: 'dkh 3/7/2012 17:08:50'! validateConfiguration | issues | issues := (MetacelloMCVersionValidator validateConfiguration: project configuration class recurse: false) select: [ :issue | issue isCritical ]. issues notEmpty ifTrue: [ MetacelloValidationFailure issues: issues message: 'There are critical issues in the configuration' ]! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! imports: importList self methodSpec imports: importList! ! !MetacelloToolBox methodsFor: 'private' stamp: 'dkh 05/15/2013 20:39'! baselineNameFrom: baseName ^ self class baselineNameFrom: baseName! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! createVersionMethod: selector inCategory: category forVersion: versionString methodSpec := (MetacelloVersionMethodSpec new) project: project; selector: selector; category: category; versionString: versionString; yourself.! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 05/15/2013 20:17'! baselineNamed: baseName | baselineName | "Check if the class does not exist" baselineName := self baselineNameFrom: baseName. (Smalltalk includesKey: baselineName asSymbol) ifFalse: [ "Create the configuration class" self ensureMetacello. BaselineOf subclass: baselineName instVarNames: #() classVars: #() classInstVars: #() poolDictionaries: #() category: baselineName. PackageInfo registerPackageName: baselineName ]. project := (MetacelloPlatform current globalNamed: baselineName asSymbol) project! ! !MetacelloToolBox methodsFor: 'private' stamp: 'dkh 9/13/2012 16:18'! editVersionSpecsForImport: constructor projectAttributes: projectAttributes active: activeSection fullVersionSpec: fullVersionSpec updateProjects: updateProjects updatePackages: updatePackages visited: visitedSpecs updated: updatedSpecs | fileSpecified encounteredPackageSpecs | fileSpecified := Bag new. encounteredPackageSpecs := Bag new. constructor methodSectionsInEvaluationOrder: projectAttributes reverse do: [ :methodSection | "collect packageSpec names ... interested in singletons" methodSection versionSpec specListProjectDo: [ :spec | ] packageDo: [ :spec | encounteredPackageSpecs add: spec name. (spec copy updateForSpawnMethod: spec) ifFalse: [ fileSpecified add: spec name ] ] groupDo: [ :spec | ] ]. constructor methodSectionsInEvaluationOrder: projectAttributes reverse do: [ :methodSection | | versionSpec attributePath packageSpecsToDelete | versionSpec := methodSection versionSpec. attributePath := methodSection attributePath. versionSpec updateForSpawnMethod: versionSpec. packageSpecsToDelete := OrderedCollection new. versionSpec specListProjectDo: [ :spec | spec updateForSpawnMethod: spec ] packageDo: [ :spec | encounteredPackageSpecs remove: spec name. (spec updateForSpawnMethod: spec) ifTrue: [ "no file speced" ((fileSpecified includes: spec name) or: [ encounteredPackageSpecs includes: spec name ]) ifTrue: [ "already specified somewhere else, need to delete this spec from version spec OR we're deleting all but first occurence" packageSpecsToDelete add: spec ] ifFalse: [ "file hasn't been specified, so specify now" spec file: spec name. fileSpecified add: spec name ] ] ifFalse: [ "file specified" (fileSpecified occurrencesOf: spec name) > 1 ifTrue: [ "multiple specifications for file ... delete all but first occurence" packageSpecsToDelete add: spec. fileSpecified remove: spec name ] ] ] groupDo: [ :spec | spec updateForSpawnMethod: spec ]. packageSpecsToDelete do: [ :spec | versionSpec deleteSpec: spec ]. activeSection ifTrue: [ self updateVersionSpec: versionSpec fullVersionSpec: fullVersionSpec updateProjects: updateProjects updatePackages: updatePackages visited: visitedSpecs updated: updatedSpecs ] ifFalse: [ self clearVersionSpec: versionSpec fullVersionSpec: fullVersionSpec updateProjects: updateProjects updatePackages: updatePackages ] ]! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! updateVersionMethodForVersion: inputVersionStringOrSymbol versionSpecsDo: aBlock ^ self updateVersionMethodForVersion: inputVersionStringOrSymbol updateProjects: true updatePackages: true versionSpecsDo: aBlock! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 9/7/2012 07:50'! addSymbolicSection: attribute version: versionString self methodSpec methodSections do: [ :methodSection | methodSection attributes = {attribute} ifTrue: [ methodSection versionString: versionString. ^ self ] ]. self methodSpec addMethodSection: attribute versionString: versionString! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! configurationNamed: baseName | configurationName | "Check if the class does not exist" configurationName := self configurationNameFrom: baseName. (Smalltalk includesKey: configurationName asSymbol) ifFalse: [ self ensureMetacello. "Create the configuration class" MetacelloPlatform current copyClass: (MetacelloPlatform current globalNamed: #MetacelloConfigTemplate) as: configurationName asSymbol inCategory: configurationName asString. "Create the package that has the same name" PackageInfo registerPackageName: configurationName ]. project := (MetacelloPlatform current globalNamed: configurationName asSymbol) project! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! modifiedPackageSpecs: versionStringOrSymbol packageSpecsDo: aBlock | versionSpec | versionSpec := (self project version: versionStringOrSymbol) spec. versionSpec projectDo: [ :ignored | ] packageDo: [ :packageSpec | | wc | wc := packageSpec workingCopy. wc ~~ nil ifTrue: [ wc modified ifTrue: [ aBlock value: versionSpec value: packageSpec value: wc ] ] ] groupDo: [ :ignored | ]! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! modifySymbolicVersionMethodFor: versionSymbol ^self modifySymbolicVersionMethodFor: versionSymbol symbolicVersionSpecsDo: [:symbolicVersionSpec | true ]. ! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! symbolicVersionMethod: versionSymbol (self hasMethodForSymbolicVersion: versionSymbol) ifTrue: [ self modifySymbolicVersionMethodFor: versionSymbol ] ifFalse: [ self createSymbolicVersionMethod: versionSymbol asString , ':' inCategory: 'symbolic versions' forVersion: versionSymbol ]. ! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 9/13/2012 19:13'! updateVersionMethodForVersion: inputVersionStringOrSymbol projectAttributes: projectAttributes updateProjects: updateProjects updatePackages: updatePackages versionSpecsDo: aBlock | constructor updatedSpecs fullVersionSpec version coll pragma imports blessing reversed addedSections visitedSpecs sourceVersionString keptSections | updatedSpecs := Set new. version := project version: inputVersionStringOrSymbol. sourceVersionString := version versionString. "resolve symbolic version" blessing := version blessing. blessing == #'release' ifTrue: [ MetacelloCannotUpdateReleasedVersionError signal: 'Should not update a version that has been released (resume to continue update).' ]. fullVersionSpec := version spec. constructor := self constructor. coll := constructor extractAllVersionPragmas at: sourceVersionString ifAbsent: [ ^ updatedSpecs ]. coll size > 1 ifTrue: [ self error: 'More than one pragma defining ' , sourceVersionString printString ]. pragma := coll at: 1. imports := pragma numArgs = 2 ifTrue: [ pragma argumentAt: 2 ] ifFalse: [ #() ]. methodSpec := MetacelloVersionMethodSpec new project: project; selector: pragma selector; category: (project configuration class whichCategoryIncludesSelector: pragma selector); versionString: sourceVersionString; imports: imports; yourself. constructor extractMethodSectionsFor: sourceVersionString. addedSections := Dictionary new. visitedSpecs := Set new. keptSections := IdentitySet new. constructor methodSectionsInEvaluationOrder: projectAttributes reverse do: [ :methodSection | | versionSpec | versionSpec := methodSection versionSpec. (blessing ~~ #'baseline' and: [ methodSection includesAttributeFrom: projectAttributes ]) ifTrue: [ self updateVersionSpec: versionSpec fullVersionSpec: fullVersionSpec updateProjects: updateProjects updatePackages: updatePackages visited: visitedSpecs updated: updatedSpecs ]. (aBlock value: methodSection attributeOrPath value: versionSpec) ifTrue: [ keptSections add: methodSection topParent ] ]. constructor methodSections do: [ :methodSection | (methodSection includesAttributeFrom: projectAttributes) ifTrue: [ (keptSections includes: methodSection) ifTrue: [ self methodSpec methodSections add: methodSection ] ] ifFalse: [ self methodSpec methodSections add: methodSection ] ]. ^ updatedSpecs! ! !MetacelloToolBox methodsFor: 'validation' stamp: 'dkh 3/7/2012 17:08:50'! validateVersion: versionStringOrSymbol | issues | issues := (MetacelloMCVersionValidator validateProject: project version: versionStringOrSymbol) select: [ :issue | issue isError ]. issues notEmpty ifTrue: [ MetacelloValidationFailure issues: issues message: 'There are error issues with version ' , versionStringOrSymbol printString ]! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 9/7/2012 13:33'! addSection: sectionAttributeOrPath repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependecies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: groups versionSpecsDo: aBlock " repositoryDescription - metacello repository string projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names dependencies - collection of associations where key is name of package and value is collection of required packages and projects includes - collection of associations where key is name of package and value is collection of included packages and projects files - collection of associations where key is name of package and value is name of file repositories - collection of associations where key is name of package and value is collection of repository descriptions preLoadDoIts - collection of associations where key is name of package and value is preload doit selector postLoadDoIts - collection of associations where key is name of package and value is postload doit selector supplyingAnswers - collection of associations where key is name of package and value is the supplyingAnswers array groups - collection of associations where key is the name of the group and value is the collection of group members " | versionSpec dependencyMap includesMap filesMap repositoriesMap preLoadDoItsMap postLoadDoItsMap supplyingAnswersMap | versionSpec := self createVersionSpec: self methodSpec versionString. repositoryDescription ~~ nil ifTrue: [ versionSpec repository: repositoryDescription ]. dependencyMap := self buildMapFrom: dependecies for: packageList. includesMap := self buildMapFrom: includes for: packageList. filesMap := self buildMapFrom: files for: packageList. repositoriesMap := self buildMapFrom: repositories for: packageList , projectList. preLoadDoItsMap := self buildMapFrom: preLoadDoIts for: packageList. postLoadDoItsMap := self buildMapFrom: postLoadDoIts for: packageList. supplyingAnswersMap := self buildMapFrom: supplyingAnswers for: packageList. projectList do: [ :projectName | | spec | spec := self createProjectReferenceSpec: projectName. repositoriesMap at: projectName ifPresent: [ :repositoriesList | repositoriesList do: [ :repoString | spec repository: repoString ] ]. versionSpec packages merge: spec ]. packageList do: [ :packageName | | spec | spec := self createPackageSpec: packageName. dependencyMap at: packageName ifPresent: [ :dependencyList | spec requires: dependencyList ]. includesMap at: packageName ifPresent: [ :includesList | spec includes: includesList ]. filesMap at: packageName ifPresent: [ :file | spec file: file ]. repositoriesMap at: packageName ifPresent: [ :repositoriesList | repositoriesList do: [ :repoString | spec repository: repoString ] ]. preLoadDoItsMap at: packageName ifPresent: [ :preLoad | spec preLoadDoIt: preLoad ]. postLoadDoItsMap at: packageName ifPresent: [ :postLoad | spec postLoadDoIt: postLoad ]. supplyingAnswersMap at: packageName ifPresent: [ :answer | spec answers: answer ]. versionSpec packages merge: spec ]. groups do: [ :assoc | | spec | spec := self createGroupSpec: assoc key. spec includes: assoc value. versionSpec packages merge: spec ]. aBlock value: versionSpec. self methodSpec addMethodSection: sectionAttributeOrPath asMetacelloAttributePath versionSpec: versionSpec! ! !MetacelloToolBox methodsFor: 'spec creation' stamp: 'dkh 3/7/2012 17:08:50'! createConfiguration: baseName | configurationName | "Check if the class does not exist" configurationName := (baseName beginsWith: 'ConfigurationOf') ifTrue: [ baseName ] ifFalse: [ 'ConfigurationOf' , baseName ]. (Smalltalk includesKey: configurationName asSymbol) ifFalse: [ self ensureMetacello. "Create the configuration class" MetacelloPlatform current copyClass: (MetacelloPlatform current globalNamed: #MetacelloConfigTemplate) as: configurationName asSymbol inCategory: configurationName asString. "Create the package that has the same name" PackageInfo registerPackageName: configurationName ]. ^(MetacelloPlatform current globalNamed: configurationName asSymbol) project! ! !MetacelloToolBox methodsFor: 'spec creation' stamp: 'dkh 3/7/2012 17:08:50'! createProjectReferenceSpec: projectBaseName | configurationName projectReferenceProject versionString | configurationName := self configurationNameFrom: projectBaseName. projectReferenceProject := (MetacelloPlatform current globalNamed: configurationName asSymbol ifAbsent: [ self error: 'The configuration ' , configurationName printString , ' for the project ' , projectBaseName printString , ' is not currently loaded into the image.' ]) project. versionString := (projectReferenceProject hasVersion: #'stable') ifTrue: [ #'stable' ] ifFalse: [ #'bleedingEdge' ]. ^ project projectReferenceSpec name: projectBaseName; projectReference: (project projectSpec name: projectBaseName; className: configurationName; versionString: versionString; yourself); yourself! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 9/14/2012 09:47'! importFrom: inputVersionStringOrSymbol projectAttributes: projectAttributes inactiveAttributes: inactiveAttributesList updateProjects: updateProjects updatePackages: updatePackages versionSpecsDo: aBlock | constructor updatedSpecs fullVersionSpec version visitedSpecs fromVersionString attributeSet | constructor := self constructor. updatedSpecs := Set new. visitedSpecs := Set new. version := project version: inputVersionStringOrSymbol. fromVersionString := version versionString. "resolve symbolic versions" fullVersionSpec := version spec. self methodSpec imports: {fromVersionString}. constructor extractMethodSectionsFor: fromVersionString. self editVersionSpecsForImport: constructor projectAttributes: projectAttributes active: true fullVersionSpec: fullVersionSpec updateProjects: updateProjects updatePackages: updatePackages visited: visitedSpecs updated: updatedSpecs. attributeSet := projectAttributes. inactiveAttributesList do: [ :inactiveAttributes | self editVersionSpecsForImport: constructor projectAttributes: inactiveAttributes active: false fullVersionSpec: fullVersionSpec updateProjects: updateProjects updatePackages: updatePackages visited: visitedSpecs updated: updatedSpecs. attributeSet := attributeSet , projectAttributes ]. attributeSet := attributeSet asSet. constructor methodSectionsDo: [ :methodSection | | versionSpec attributePath | versionSpec := methodSection versionSpec. attributePath := methodSection attributePath. (methodSection includesAttributeFrom: attributeSet) ifFalse: [ versionSpec updateForSpawnMethod: versionSpec. versionSpec specListProjectDo: [ :spec | spec updateForSpawnMethod: spec ] packageDo: [ :spec | spec updateForSpawnMethod: spec ] groupDo: [ :spec | spec updateForSpawnMethod: spec ]. self clearVersionSpec: versionSpec fullVersionSpec: fullVersionSpec updateProjects: updateProjects updatePackages: updatePackages ]. (aBlock value: attributePath asAttributeOrPath value: versionSpec) ifTrue: [ self methodSpec addMethodSection: attributePath versionSpec: versionSpec ] ]! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 9/13/2012 16:05'! importFrom: inputVersionStringOrSymbol updateProjects: updateProjects updatePackages: updatePackages versionSpecsDo: aBlock ^ self importFrom: inputVersionStringOrSymbol projectAttributes: project attributes inactiveAttributes: #() updateProjects: updateProjects updatePackages: updatePackages versionSpecsDo: aBlock! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 9/8/2012 05:04'! modifySection: sectionAttributeOrPath repository: repositoryDescription requiredProjects: newProjectList packages: newPackageList dependencies: dependecies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: newGroups versionSpecsDo: aBlock " repositoryDescription - metacello repository string newProjectList - collection of project base names (without ConfigurationOf prefix) newPackageList - collection of package base names dependencies - collection of associations where key is name of package and value is collection of required packages and projects includes - collection of associations where key is name of package and value is collection of included packages and projects files - collection of associations where key is name of package and value is name of file repositories - collection of associations where key is name of package and value is collection of repository descriptions preLoadDoIts - collection of associations where key is name of package and value is preload doit selector postLoadDoIts - collection of associations where key is name of package and value is postload doit selector supplyingAnswers - collection of associations where key is name of package and value is the supplyingAnswers array newGroups - collection of associations where key is the name of the group and value is the collection of group members " self modifySection: sectionAttributeOrPath sectionIndex: 1 repository: repositoryDescription requiredProjects: newProjectList packages: newPackageList dependencies: dependecies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: newGroups versionSpecsDo: aBlock! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! modifyVersionMethodForVersion: inputVersionStringOrSymbol ^ self modifyVersionMethodForVersion: inputVersionStringOrSymbol versionSpecsDo: [ :attribute :versionSpec | true ]! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! modifyVersionMethodForVersion: inputVersionStringOrSymbol versionSpecsDo: aBlock ^ self updateVersionMethodForVersion: inputVersionStringOrSymbol updateProjects: false updatePackages: false versionSpecsDo: aBlock! ! !MetacelloToolBox methodsFor: 'accessing' stamp: 'dkh 3/7/2012 17:08:50'! project: aMetacelloProject project := aMetacelloProject! ! !MetacelloToolBox methodsFor: 'spec creation' stamp: 'dkh 3/7/2012 17:08:50'! createVersionSpec: versionString | versionSpec | versionSpec := project versionSpec. versionSpec versionString: versionString. ^ versionSpec! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! addSection: sectionAttributeOrPath repository: repositoryDescription requiredProjects: projectList packages: packageList repositories: repositories dependencies: dependecies groups: groups versionSpecsDo: aBlock " repositoryDescription - metacello repository string projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names repositories - collection of associations where key is name of package and value is collection of repository descriptions dependencies - collection of associations where key is name of package and value is collection of required packages and projects groups - collection of associations where key is the name of the group and value is the collection of group members " self addSection: sectionAttributeOrPath repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependecies includes: #() files: #() repositories: repositories preLoadDoIts: #() postLoadDoIts: #() supplyingAnswers: #() groups: groups versionSpecsDo: aBlock! ! !MetacelloToolBox methodsFor: 'accessing' stamp: 'dkh 3/7/2012 17:08:50'! constructor | constructor | constructor := MetacelloToolBoxConstructor new. constructor configuration: project configuration class new. ^constructor! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 9/8/2012 05:17'! addSectionsFrom: inputVersionStringOrSymbol forBaseline: forBaseline updateProjects: updateProjects updatePackages: updatePackages versionSpecsDo: aBlock | constructor updatedSpecs projectAttributes fullVersionSpec version coll pragma imports visitedSpecs fromVersionString | constructor := self constructor. updatedSpecs := Set new. visitedSpecs := Set new. projectAttributes := project attributes. version := project version: inputVersionStringOrSymbol. fromVersionString := version versionString. fullVersionSpec := version spec. fullVersionSpec := version spec. coll := constructor extractAllVersionPragmas at: fromVersionString ifAbsent: [ ^ nil ]. coll size > 1 ifTrue: [ self error: 'More than one pragma defining ' , fromVersionString printString ]. pragma := coll at: 1. imports := pragma numArgs = 2 ifTrue: [ pragma argumentAt: 2 ] ifFalse: [ #() ]. methodSpec imports: imports. constructor extractMethodSectionsFor: fromVersionString. constructor methodSections do: [ :methodSection | | versionSpec attributeList | versionSpec := methodSection versionSpec. attributeList := methodSection attributes. forBaseline ifFalse: [ (projectAttributes includes: attributeList) ifTrue: [ self updateVersionSpec: versionSpec fullVersionSpec: fullVersionSpec updateProjects: updateProjects updatePackages: updatePackages visited: visitedSpecs updated: updatedSpecs ] ]. (aBlock value: methodSection attributeOrPath value: versionSpec) ifTrue: [ self methodSpec addMethodSection: methodSection attributePath versionSpec: versionSpec ] ]! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! commitMethod | skipValidation isues | skipValidation := false. self methodSpec ifNil: [ ^self ]. self methodSpec compileMethod. project := project configuration class project. "recalculate project" [ project version: self methodSpec versionString ] on: MetacelloSymbolicVersionDoesNotExistError do: [ :ex | "symbolic versions can be removed" skipValidation := true ]. skipValidation ifFalse: [ self validateVersion: self methodSpec versionString ]. methodSpec := nil! ! !MetacelloToolBox methodsFor: 'spec creation' stamp: 'dkh 3/7/2012 17:08:50'! createPackageSpec: baseName ^ (project packageSpec) name: baseName; yourself! ! !MetacelloToolBox methodsFor: 'private' stamp: 'dkh 9/13/2012 16:55'! updateVersionSpec: versionSpec fullVersionSpec: fullVersionSpec updateProjects: updateProjects updatePackages: updatePackages visited: visitedSpecs updated: updatedSpecs versionSpec specListProjectDo: [ :spec | (updateProjects and: [ (visitedSpecs includes: spec name) not ]) ifTrue: [ | fullProjectSpec | fullProjectSpec := (fullVersionSpec packageNamed: spec name) projectReference. (fullProjectSpec versionString ~~ nil and: [ fullProjectSpec versionString ~~ #'stable' and: [ fullProjectSpec projectClass ~~ nil ] ]) ifTrue: [ | cv | cv := fullProjectSpec projectClassProject currentVersion. cv ~~ nil ifTrue: [ cv versionString ~= fullProjectSpec versionString ifTrue: [ spec projectReference versionString: cv versionString. updatedSpecs add: spec name ] ] ifFalse: [ "set to an empty string as a place holder, since we know we should have a version, but we are unable to figure out the version" spec projectReference versionString: ''. updatedSpecs add: spec name ] ] ] ] packageDo: [ :spec | (updatePackages and: [ (visitedSpecs includes: spec name) not ]) ifTrue: [ spec getFile ~~ nil ifTrue: [ | viName | spec file = '' ifTrue: [ spec file: spec name ]. (viName := spec workingCopyNameFor: spec loader) ~~ nil ifTrue: [ viName ~= spec file ifTrue: [ spec file: viName. updatedSpecs add: spec name ]. visitedSpecs add: spec name ] ] ] ] groupDo: [ :ignored | ]! ! !MetacelloToolBox methodsFor: '*Versionner-Core-DependenciesModel' stamp: 'ChristopheDemarey 2/21/2014 16:01'! addSection: sectionAttributeOrPath repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependecies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: groups versionSpecsDo: aBlock requiredProjectSpecs: requiredProjectSpecs " repositoryDescription - metacello repository string projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names dependencies - collection of associations where key is name of package and value is collection of required packages and projects includes - collection of associations where key is name of package and value is collection of included packages and projects files - collection of associations where key is name of package and value is name of file repositories - collection of associations where key is name of package and value is collection of repository descriptions preLoadDoIts - collection of associations where key is name of package and value is preload doit selector postLoadDoIts - collection of associations where key is name of package and value is postload doit selector supplyingAnswers - collection of associations where key is name of package and value is the supplyingAnswers array groups - collection of associations where key is the name of the group and value is the collection of group members requiredProjectSpecs - collection of already computed required project specs. " | versionSpec dependencyMap includesMap filesMap repositoriesMap preLoadDoItsMap postLoadDoItsMap supplyingAnswersMap | versionSpec := self createVersionSpec: self methodSpec versionString. repositoryDescription ~~ nil ifTrue: [ versionSpec repository: repositoryDescription ]. dependencyMap := self buildMapFrom: dependecies for: packageList. includesMap := self buildMapFrom: includes for: packageList. filesMap := self buildMapFrom: files for: packageList. repositoriesMap := self buildMapFrom: repositories for: packageList , projectList. preLoadDoItsMap := self buildMapFrom: preLoadDoIts for: packageList. postLoadDoItsMap := self buildMapFrom: postLoadDoIts for: packageList. supplyingAnswersMap := self buildMapFrom: supplyingAnswers for: packageList. requiredProjectSpecs do: [ :projectSpec | versionSpec packages merge: projectSpec ]. packageList do: [ :packageName | | spec | spec := self createPackageSpec: packageName. dependencyMap at: packageName ifPresent: [ :dependencyList | spec requires: dependencyList ]. includesMap at: packageName ifPresent: [ :includesList | spec includes: includesList ]. filesMap at: packageName ifPresent: [ :file | spec file: file ]. repositoriesMap at: packageName ifPresent: [ :repositoriesList | repositoriesList do: [ :repoString | spec repository: repoString ] ]. preLoadDoItsMap at: packageName ifPresent: [ :preLoad | spec preLoadDoIt: preLoad ]. postLoadDoItsMap at: packageName ifPresent: [ :postLoad | spec postLoadDoIt: postLoad ]. supplyingAnswersMap at: packageName ifPresent: [ :answer | spec answers: answer ]. versionSpec packages merge: spec ]. groups do: [ :assoc | | spec | spec := self createGroupSpec: assoc key. spec includes: assoc value. versionSpec packages merge: spec ]. aBlock value: versionSpec. self methodSpec addMethodSection: sectionAttributeOrPath asMetacelloAttributePath versionSpec: versionSpec! ! !MetacelloToolBox methodsFor: 'accessing' stamp: 'dkh 3/7/2012 17:08:50'! methodSpec ^methodSpec! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 9/9/2012 07:36'! modifySymbolicVersionMethodFor: versionSymbol symbolicVersionSpecsDo: aBlock | constructor coll pragma | constructor := self constructor. coll := constructor extractSymbolicVersionPragmas at: versionSymbol ifAbsent: [ ^ nil ]. coll size > 1 ifTrue: [ self error: 'More than one pragma defining ' , versionSymbol printString ]. pragma := coll at: 1. methodSpec := MetacelloSymbolicVersionMethodSpec new project: project; selector: pragma selector; category: (project configuration class whichCategoryIncludesSelector: pragma selector); versionString: versionSymbol; yourself. (constructor extractSymbolicVersionSpecsFor: versionSymbol) do: [ :symbolicVersionSpec | (aBlock value: symbolicVersionSpec) ifTrue: [ self methodSpec addMethodSection: symbolicVersionSpec attributes versionString: symbolicVersionSpec versionString ] ]! ! !MetacelloToolBox methodsFor: 'spec creation' stamp: 'dkh 3/7/2012 17:08:50'! createVersion: versionString | version | [ version := project version: versionString ] on: MetacelloVersionDoesNotExistError do: [ :ex | | versionSpec | versionSpec := self createVersionSpec: versionString. version := versionSpec createVersion. project map == nil ifTrue: [ project map: Dictionary new ]. project map at: versionString put: version ]. ^version! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! commitConfiguration: commitComment! ! !MetacelloToolBox methodsFor: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! createSymbolicVersionMethod: selector inCategory: category forVersion: versionSymbol | constructor | methodSpec := (MetacelloSymbolicVersionMethodSpec new) project: project; selector: selector; category: category; versionString: versionSymbol; yourself. constructor := self constructor. self methodSpec methodSections: (constructor extractSymbolicVersionSpecsFor: versionSymbol) asOrderedCollection. ! ! !MetacelloToolBox methodsFor: 'private' stamp: 'dkh 3/7/2012 17:08:50'! configurationNameFrom: baseName ^self class configurationNameFrom: baseName! ! !MetacelloToolBox class methodsFor: 'tool support' stamp: 'dkh 3/7/2012 17:08:50'! compiledMethodForVersion: aMetacelloVersion | toolbox pragma | toolbox := MetacelloToolBox new project: aMetacelloVersion project. pragma := (toolbox constructor extractAllVersionPragmas at: aMetacelloVersion versionString ifAbsent: [ ^ nil ]) first. ^pragma method! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! createDevelopment: developmentVersionString for: configurationBasename from: existingDevelopmentVersionString imports: imports description: aString "Create a new development version based on the specifications in an existing version, but override the imports for the new version. Modify the #development symbolic version to reference the new version." | toolbox | toolbox := self createVersion: developmentVersionString for: configurationBasename from: existingDevelopmentVersionString description: aString. toolbox modifyVersionMethodForVersion: developmentVersionString; imports: imports; commitMethod. ^ toolbox! ! !MetacelloToolBox class methodsFor: 'utility' stamp: 'dkh 3/7/2012 17:08:50'! configurationNameFrom: baseName "Return the fully-qualified configuration class name." ^ MetacelloScriptEngine configurationNameFrom: baseName! ! !MetacelloToolBox class methodsFor: 'utility' stamp: 'dkh 3/7/2012 17:08:50'! platformAttributes "Answer the list of platform attributes for the current platform" ^MetacelloPlatform current defaultPlatformAttributes! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! createBaseline: baselineVersionString for: configurationBasename from: existingBaselineVersionString description: aString "Create a new baseline version based on the specification in an existing baseline" ^ self createBaseline: baselineVersionString for: configurationBasename from: existingBaselineVersionString description: aString versionSpecsDo: [ :attribute :versionSpec | true ]! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! updateDevelopment: developmentVersionString for: configurationBasename updateProjects: updateProjects description: message "Update packageSpecs and (conditionally) the project specs in the given version to reflect the new mcz file and project versions." | toolbox updatedSpecs | toolbox := self configurationNamed: configurationBasename. updatedSpecs := toolbox updateVersionMethodForVersion: developmentVersionString updateProjects: updateProjects updatePackages: true versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ "update the author, description and timeStamp" versionSpec author: MetacelloPlatform current authorName; timestamp: MetacelloPlatform current timestamp. self appendDescription: message to: versionSpec ]. true ]. updatedSpecs notEmpty ifTrue: [ toolbox commitMethod ]. ^ updatedSpecs! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! createBaseline: baselineVersionString for: configurationBasename from: existingBaselineVersionString description: aString versionSpecsDo: versionSpecBlock "Create a new baseline version based on the specification in an existing baseline. Evaluate for each section." | toolbox | (toolbox := self configurationNamed: configurationBasename) createVersionMethod: 'baseline' , (self stripVersionStringForSelector: baselineVersionString) , ':' inCategory: 'baselines' forVersion: baselineVersionString; addSectionsFrom: existingBaselineVersionString forBaseline: true updateProjects: false updatePackages: false versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ aString notEmpty ifTrue: [ versionSpec description: aString ] ]. versionSpecBlock value: attribute value: versionSpec ]; commitMethod. ^ toolbox! ! !MetacelloToolBox class methodsFor: 'load validation' stamp: 'dkh 3/7/2012 17:08:50'! validatePlatformLoad: platformAttribute for: configurationBasename "Validate, Load, and run tests for all versions of the given configuration. Return list of issues." | issues configurationClass toolbox cleanDevelopmentLoads cleanLoadAndTests stableVersion | configurationClass := Smalltalk at: (self configurationNameFrom: configurationBasename) asSymbol. cleanDevelopmentLoads := OrderedCollection new. cleanLoadAndTests := OrderedCollection new. issues := [ MetacelloMCVersionValidator validateConfigurationLoad: configurationClass ] on: MetacelloCleanNotification do: [ :ex | (ex isKindOf: MetacelloCleanLoadAndTestsNotification) ifTrue: [ cleanLoadAndTests add: ex version ]. ((ex isKindOf: MetacelloCleanLoadNotification) and: [ ex version blessing == #development ]) ifTrue: [ cleanDevelopmentLoads add: ex version ]. ex resume ]. (cleanDevelopmentLoads isEmpty and: [ cleanLoadAndTests isEmpty ]) ifTrue: [ self inform: 'Failed validation with no versions load clean'. ^ issues ]. toolbox := self configurationNamed: configurationBasename. cleanLoadAndTests notEmpty ifTrue: [ toolbox symbolicVersionMethod: #stable; addSymbolicSection: platformAttribute version: (stableVersion := cleanLoadAndTests last) versionString; commitMethod ]. stableVersion notNil ifTrue: [ stableVersion blessing == #development ifTrue: [ issues add: (MetacelloValidationWarning configurationClass: configurationClass reasonCode: #stableDevelopmentVersion callSite: #validatePlatformLoad:for: explanation: 'Development version ' , stableVersion versionString printString , ' is marked as #stableVersion for ' , configurationClass name asString) ]. cleanDevelopmentLoads := cleanDevelopmentLoads select: [ :version | version > stableVersion ] ]. cleanDevelopmentLoads notEmpty ifTrue: [ toolbox symbolicVersionMethod: #development; addSymbolicSection: platformAttribute version: cleanDevelopmentLoads last versionString; commitMethod ] ifFalse: [ toolbox symbolicVersionMethod: #development; addSymbolicSection: platformAttribute version: #notDefined; commitMethod ]. ^ issues! ! !MetacelloToolBox class methodsFor: 'utility' stamp: 'dkh 05/15/2013 20:36'! baselineNameFrom: baseName "Return the fully-qualified baseline class name." ^ MetacelloScriptEngine baselineNameFrom: baseName! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! compareVersion: fromVersionString for: configurationBasename to: toVersionString "Return a MetacelloMCVersionDiffReport that whose fields #additions #removals #modifications refer to a dictionary whose keys are package names and whose values are a 2 element array. The first element is the mcz file name for the first version and the second element is the mcz file name for second version. There are also fields for the name of the configuration (#configuration), the #from version string and the #to version string. The printString of the version report should provide all of the necessary info for a developer." | toolbox report | toolbox := self configurationNamed: configurationBasename. report := (toolbox project version: fromVersionString) difference: (toolbox project version: toVersionString). report from: fromVersionString; to: toVersionString; configuration: configurationBasename. ^ report! ! !MetacelloToolBox class methodsFor: 'validation' stamp: 'dkh 3/7/2012 17:08:50'! validateProject: aMetacelloProject version: versionString debug: debugList recurse: aBool "Check a specific version in the configuration for Errors, Critical Warnings, and Warnings (see class comment for MetacelloMCVersionValidator for more information). " ^ MetacelloMCVersionValidator validateProject: aMetacelloProject version: versionString debug: debugList recurse: aBool! ! !MetacelloToolBox class methodsFor: 'utility' stamp: 'dkh 07/18/2013 07:42'! baseNameOf: configurationClassName "Return the baseName for the given configuration class name." ^ (configurationClassName beginsWith: 'ConfigurationOf') ifTrue: [ configurationClassName copyFrom: 'ConfigurationOf' size + 1 to: configurationClassName size ] ifFalse: [ configurationClassName ]! ! !MetacelloToolBox class methodsFor: 'deprecated' stamp: 'dkh 3/7/2012 17:08:50'! createBaseline: baselineVersionString for: configurationBasename repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependencies groups: groups "Create a new baseline version based on the specified project structure. repositoryDescription - metacello repository string projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names dependencies - collection of associations where key is name of package and value is collection of required packages and projects groups - collection of associations where key is the name of the group and value is the collection of group members " self deprecated: 'Use createBaseline:for: repository:requiredProjects:packages:repositories:dependencies:groups: instead'. ^ self createBaseline: baselineVersionString for: configurationBasename repository: repositoryDescription requiredProjects: projectList packages: packageList repositories: #() dependencies: dependencies groups: groups! ! !MetacelloToolBox class methodsFor: 'help' stamp: 'dkh 3/7/2012 17:08:50'! helpTopicFor: aConfigurationClass | topic pages page helpTopicClass | (helpTopicClass := self helpTopicClass) ifNil: [^self error: 'Help system not installed']. topic := helpTopicClass named: (self baseNameOfConfiguration: aConfigurationClass). pages := (aConfigurationClass respondsTo: #helpPages) ifTrue: [ aConfigurationClass perform: #helpPages ] ifFalse: [ #(#helpIntro #helpInstallation #helpGettingStarted) ]. pages do: [ :pageSelectorOrClass | page := (Smalltalk hasClassNamed: pageSelectorOrClass asString) ifTrue: [ (Smalltalk classNamed: pageSelectorOrClass asString) perform: #asHelpTopic ] ifFalse: [ [ aConfigurationClass perform: pageSelectorOrClass ] on: MessageNotUnderstood do: [ :ex | self defaultTopic: pageSelectorOrClass for: aConfigurationClass ] ]. topic perform: #addSubtopic: with: page ]. ^ topic! ! !MetacelloToolBox class methodsFor: 'development support' stamp: 'dkh 3/7/2012 17:08:50'! releaseDevelopmentVersionIn: aConfigurationClass description: commitMessage "Release #development version: set version blessing to #release, update the #development and #stable symbolic version methods and save the configuration." | version | version := aConfigurationClass project version: #development. self releaseVersion: version versionString for: aConfigurationClass name asString; saveConfigurationPackageFor: aConfigurationClass name asString description: commitMessage! ! !MetacelloToolBox class methodsFor: 'development support' stamp: 'dkh 3/7/2012 17:08:50'! createNewBaselineVersionIn: aConfigurationClass description: creationMessage versionSpecsDo: versionSpecBlock "Create a new baseline version based upon #stable version's baseline. Evaluate for each section. A new baseline should be created if new packages or projects have been added or package dependencies have changed." | currentVersion existingBaselineVersionString baselineVersionNumber | currentVersion := aConfigurationClass project version: #stable. existingBaselineVersionString := currentVersion importedVersions first. baselineVersionNumber := existingBaselineVersionString asMetacelloVersionNumber incrementMinorVersionNumber. self createBaseline: baselineVersionNumber versionString for: aConfigurationClass name asString from: existingBaselineVersionString description: creationMessage versionSpecsDo: versionSpecBlock! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! updateDevelopment: developmentVersionString for: configurationBasename updatePackages: updatePackages description: message "Update project specs and (conditionally) the package specs in the given version to reflect the new mcz file and project versions." | toolbox updatedSpecs | toolbox := self configurationNamed: configurationBasename. updatedSpecs := toolbox updateVersionMethodForVersion: developmentVersionString updateProjects: true updatePackages: updatePackages versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ "update the author, description and timeStamp" versionSpec author: MetacelloPlatform current authorName; timestamp: MetacelloPlatform current timestamp. self appendDescription: message to: versionSpec ]. true ]. updatedSpecs notEmpty ifTrue: [ toolbox commitMethod ]. ^ updatedSpecs! ! !MetacelloToolBox class methodsFor: 'help' stamp: 'dkh 3/7/2012 17:08:50'! defaultTopic: pageSelector for: aConfigurationClass | topic stream helpTopicClass | (helpTopicClass := self helpTopicClass) ifNil: [^self error: 'Help system not installed']. stream := WriteStream on: String new. pageSelector == #helpInstallation ifTrue: [ stream nextPutAll: 'To install this configuration, execute the following expression in a workspace:'; cr; tab. (aConfigurationClass project hasVersion: #stable) ifTrue: [ stream nextPutAll: '(', aConfigurationClass name asString, ' project version: #stable) load.' ] ifFalse: [ (aConfigurationClass respondsTo: #load) ifTrue: [ stream nextPutAll: aConfigurationClass name asString , ' load.' ] ifFalse: [ stream nextPutAll: aConfigurationClass name asString, ' project latestVersion load.' ]]. ^ helpTopicClass perform: #title:contents: withArguments: { 'Installing'. stream contents} ]. pageSelector == #helpIntro ifTrue: [ stream nextPutAll: 'I am a Metacello configuration for the ', (MetacelloToolBox baseNameOfConfiguration: aConfigurationClass), ' project.'. ^ helpTopicClass perform: #title:contents: withArguments: { 'Intro' . stream contents} ]. pageSelector == #helpGettingStarted ifTrue: [ stream nextPutAll: 'I guess you''re on your own:).'. ^ helpTopicClass perform: #title:contents: withArguments: { 'Getting Started' .stream contents} ]. ! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! updateDescription: developmentVersionString for: configurationBasename description: message "Update description" ^ (self configurationNamed: configurationBasename) updateVersionMethodForVersion: developmentVersionString updateProjects: false updatePackages: false versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ "update the author, description and timeStamp" versionSpec author: MetacelloPlatform current authorName; timestamp: MetacelloPlatform current timestamp. self appendDescription: message to: versionSpec ]. true ]; commitMethod! ! !MetacelloToolBox class methodsFor: '*Versionner-Core-DependenciesModel' stamp: 'ChristopheDemarey 2/21/2014 15:58'! createBaseline: baselineVersionString for: configurationBasename repository: repositoryDescription requiredProjects: projectList packages: packageList repositories: repositories dependencies: dependencies groups: groups requiredProjectSpecs: requiredProjectSpecs "Create a new baseline version based on the specified project structure. repositoryDescription - metacello repository string projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names repositories - collection of associations where key is name of package and value is collection of repository descriptions dependencies - collection of associations where key is name of package and value is collection of required packages and projects groups - collection of associations where key is the name of the group and value is the collection of group members loads - collection of associations where key is name of a project and value is collection of packages/groups to load. " | toolbox | (toolbox := self configurationNamed: configurationBasename) createVersionMethod: 'baseline' , (self stripVersionStringForSelector: baselineVersionString) , ':' inCategory: 'baselines' forVersion: baselineVersionString; addSection: #'common' repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependencies includes: #() files: #() repositories: repositories preLoadDoIts: #() postLoadDoIts: #() supplyingAnswers: #() groups: groups versionSpecsDo: [ :versionSpec | versionSpec blessing: #'baseline' ] requiredProjectSpecs: requiredProjectSpecs; commitMethod. ^ toolbox! ! !MetacelloToolBox class methodsFor: 'utility' stamp: 'dkh 3/7/2012 17:08:50'! baseNameOfConfiguration: aConfigurationClass "Return the baseName for the given configuration class." ^self baseNameOf: aConfigurationClass name asString! ! !MetacelloToolBox class methodsFor: 'load validation' stamp: 'dkh 3/7/2012 17:08:50'! validatePlatformLoad: platformAttribute for: configurationBasename version: versionString "Load, and run tests for the given version of the configuration. Mark as #stable, if load and tests are clean. Return list of issues." | issues configurationClass toolbox cleanLoadAndTests stableVersion | configurationClass := Smalltalk at: (self configurationNameFrom: configurationBasename) asSymbol. cleanLoadAndTests := OrderedCollection new. issues := [ MetacelloMCVersionValidator validateConfigurationLoad: configurationClass version: versionString ] on: MetacelloCleanNotification do: [ :ex | (ex isKindOf: MetacelloCleanLoadAndTestsNotification) ifTrue: [ cleanLoadAndTests add: ex version ]. ex resume ]. toolbox := self configurationNamed: configurationBasename. cleanLoadAndTests isEmpty ifTrue: [ ^issues ]. stableVersion := cleanLoadAndTests last. toolbox symbolicVersionMethod: #stable; addSymbolicSection: platformAttribute version: stableVersion versionString; commitMethod. stableVersion blessing == #development ifTrue: [ issues add: (MetacelloValidationWarning configurationClass: configurationClass reasonCode: #stableDevelopmentVersion callSite: #validatePlatformLoad:for:version: explanation: 'Development version ' , stableVersion versionString printString , ' is marked as #stableVersion for ' , configurationClass name asString) ]. ^ issues! ! !MetacelloToolBox class methodsFor: 'utility' stamp: 'dkh 3/7/2012 17:08:50'! checkForCriticalValidationIssues: configurationBasename "Validate the named configuration and filter out all non-critical issues." ^ (MetacelloMCVersionValidator validateConfiguration: (Smalltalk at: (self configurationNameFrom: configurationBasename) asSymbol)) select: [ :issue | issue isCritical ]! ! !MetacelloToolBox class methodsFor: 'private' stamp: 'dkh 3/7/2012 17:08:50'! stripVersionStringForSelector: versionString ^((versionString copyWithout: $.) copyWithout: $-) copyReplaceAll: 'baseline' with: '' ! ! !MetacelloToolBox class methodsFor: 'validation' stamp: 'dkh 3/7/2012 17:08:50'! validateConfiguration: configurationClass debug: debugList recurse: aBool "Check the configuration for Errors, Critical Warnings, and Warnings (see class comment for MetacelloMCVersionValidator for more information). " ^ MetacelloMCVersionValidator validateConfiguration: configurationClass debug: debugList recurse: aBool! ! !MetacelloToolBox class methodsFor: 'utility' stamp: 'dkh 6/13/2012 13:07'! configurationClasses "Return a set of the Metacello configuration classes that have been loaded into the image." ^ MetacelloProjectRegistration configurationClasses! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 9/7/2012 13:34'! modifyVersion: sourceVersionString section: sectionAttributeOrPath for: configurationBasename repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependencies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: groups "Modify a new version based on the specified project structure. repositoryDescription - metacello repository string projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names dependencies - collection of associations where key is name of package and value is collection of required packages and projects includes - collection of associations where key is name of package and value is collection of included packages and projects files - collection of associations where key is name of package and value is name of file repositories - collection of associations where key is name of package and value is collection of repository descriptions preLoadDoIts - collection of associations where key is name of package and value is preload doit selector postLoadDoIts - collection of associations where key is name of package and value is postload doit selector supplyingAnswers - collection of associations where key is name of package and value is the supplyingAnswers array groups - collection of associations where key is the name of the group and value is the collection of group members " | toolbox | (toolbox := self configurationNamed: configurationBasename) modifyVersionMethodForVersion: sourceVersionString versionSpecsDo: [:attribute :versionSpec | true ]; modifySection: sectionAttributeOrPath asMetacelloAttributePath repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependencies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: groups versionSpecsDo: [ :versionSpec | true ]; commitMethod. ^ toolbox! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! modifyVersion: sourceVersionString for: configurationBasename projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock "Modify the project, package and/or group specifications for the given version" self modifyVersion: sourceVersionString for: configurationBasename versionSpecsDo: [ :attribute :versionSpec | versionSpec specListProjectDo: [ :spec | projectBlock value: attribute value: versionSpec value: spec ] packageDo: [ :spec | packageBlock value: attribute value: versionSpec value: spec ] groupDo: [ :spec | groupBlock value: attribute value: versionSpec value: spec ]. true ]! ! !MetacelloToolBox class methodsFor: 'development support' stamp: 'dkh 3/7/2012 17:08:50'! createNewDevelopmentVersionIn: aConfigurationClass description: creationMessage "Create a new development version using the #stable version as model." | currentVersion developmentVersion | currentVersion := aConfigurationClass project version: #stable. developmentVersion := currentVersion versionNumber copy incrementMinorVersionNumber. self createDevelopment: developmentVersion versionString for: aConfigurationClass name asString from: currentVersion versionString imports: currentVersion importedVersions description: creationMessage! ! !MetacelloToolBox class methodsFor: 'instance creation' stamp: 'dkh 05/15/2013 20:15'! baselineNamed: baseName ^ self new baselineNamed: baseName; yourself! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! releaseEarlyAccessVersion: earlyAccessVersionString for: configurationBasename from: developmentVersionString "Update the #development and #earlyAccess symbolic versions." | toolbox message previousEarlyAccessVersion previousEarlyAccessSeparator index earlyAccessDescription | self flag: 'Make this more general purpose'. toolbox := self configurationNamed: configurationBasename. message := (toolbox project version: developmentVersionString) description. previousEarlyAccessVersion := (MetacelloVersionNumber fromString: earlyAccessVersionString) decrementMinorVersionNumber asString. previousEarlyAccessSeparator := '---' , previousEarlyAccessVersion , '---'. (index := message indexOfSubCollection: previousEarlyAccessSeparator) > 0 ifTrue: [ index + previousEarlyAccessSeparator size + 1 <= message size ifTrue: [ earlyAccessDescription := message copyFrom: index + previousEarlyAccessSeparator size + 1 to: message size ] ]. toolbox createVersionMethod: 'version' , (self stripVersionStringForSelector: earlyAccessVersionString) , ':' inCategory: 'versions' forVersion: earlyAccessVersionString; addSectionsFrom: developmentVersionString forBaseline: false updateProjects: true updatePackages: true versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ "update the author, blessing, description and timeStamp" versionSpec author: MetacelloPlatform current authorName; description: earlyAccessDescription; blessing: #development; timestamp: MetacelloPlatform current timestamp ]. true ]; commitMethod. toolbox symbolicVersionMethod: #earlyAccess; addSymbolicSection: #common version: earlyAccessVersionString; commitMethod. toolbox modifyVersionMethodForVersion: developmentVersionString versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ "update the author, description and timeStamp" versionSpec author: MetacelloPlatform current authorName; timestamp: MetacelloPlatform current timestamp. self appendDescription: '---' , earlyAccessVersionString , '---' to: versionSpec ]. true ]; commitMethod. ^ toolbox! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'ChristopheDemarey 3/18/2014 16:31'! createDevelopment: developmentVersionString for: configurationBasename importFromBaseline: baselineVersionString description: aString "Create a new development version based on the specifications in an existing baseline version. Modify the #development symbolic version to reference the new version." | toolbox | (toolbox := self configurationNamed: configurationBasename) createVersionMethod: 'version' , (self stripVersionStringForSelector: developmentVersionString) , ':' inCategory: 'versions' forVersion: developmentVersionString; importFrom: baselineVersionString updateProjects: false updatePackages: true versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ "update the author, blessing, description and timeStamp" versionSpec author: MetacelloPlatform current authorName; blessing: #development; description: aString; timestamp: MetacelloPlatform current timestamp ]. true ]; commitMethod. toolbox symbolicVersionMethod: #development; addSymbolicSection: #common version: developmentVersionString; commitMethod. ^ toolbox! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! createBaseline: baselineVersionString for: configurationBasename repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependencies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: groups "Create a new baseline version based on the specified project structure. repositoryDescription - metacello repository string projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names dependencies - collection of associations where key is name of package and value is collection of required packages and projects includes - collection of associations where key is name of package and value is collection of included packages and projects files - collection of associations where key is name of package and value is name of file repositories - collection of associations where key is name of package and value is collection of repository descriptions preLoadDoIts - collection of associations where key is name of package and value is preload doit selector postLoadDoIts - collection of associations where key is name of package and value is postload doit selector supplyingAnswers - collection of associations where key is name of package and value is the supplyingAnswers array groups - collection of associations where key is the name of the group and value is the collection of group members " | toolbox | (toolbox := self configurationNamed: configurationBasename) createVersionMethod: 'baseline' , (self stripVersionStringForSelector: baselineVersionString) , ':' inCategory: 'baselines' forVersion: baselineVersionString; addSection: #common repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependencies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: groups versionSpecsDo: [ :versionSpec | versionSpec blessing: #baseline ]; commitMethod. ^ toolbox! ! !MetacelloToolBox class methodsFor: 'development support' stamp: 'dkh 3/7/2012 17:08:50'! createNewBaselineVersionIn: aConfigurationClass description: creationMessage "Create a new baseline version based upon #stable version's baseline. A new baseline should be created if new packages or projects have been added or package dependencies have changed." | currentVersion existingBaselineVersionString baselineVersionNumber | currentVersion := aConfigurationClass project version: #stable. existingBaselineVersionString := currentVersion importedVersions first. baselineVersionNumber := existingBaselineVersionString asMetacelloVersionNumber incrementMinorVersionNumber. self createBaseline: baselineVersionNumber versionString for: aConfigurationClass name asString from: existingBaselineVersionString description: creationMessage! ! !MetacelloToolBox class methodsFor: 'validation' stamp: 'dkh 3/7/2012 17:08:50'! descriptionForValidationReasonCode: reasonCode "Description of validation reasonCode" ^MetacelloMCVersionValidator descriptionForReasonCode: reasonCode! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! saveModifiedDevelopmentPackages: developmentVersionString for: configurationBasename description: commitMessage "Save modified mcz files associated with the project. Then update given version to reflect the new mcz file versions." | toolbox modifiedPackages cacheRepository | modifiedPackages := Dictionary new. (toolbox := self configurationNamed: configurationBasename) modifiedPackageSpecs: developmentVersionString packageSpecsDo: [ :versionSpec :packageSpec :monticelloWorkingCopy | | repositories repositoryGroup wcRepositoryGroup | wcRepositoryGroup := monticelloWorkingCopy repositoryGroup. repositoryGroup := MCRepositoryGroup new. repositories := packageSpec repositories collect: [ :each | each createRepository ]. repositories isEmpty ifTrue: [ repositories := versionSpec repositories collect: [ :repoSpec | repoSpec createRepository ]. wcRepositoryGroup repositories notEmpty ifTrue: [ repositories := repositories select: [ :repo | wcRepositoryGroup includes: repo ] ]. repositories isEmpty ifTrue: [ repositories := monticelloWorkingCopy repositoryGroup repositories reject: [ :repo | repo = MCCacheRepository default ] ] ]. repositories do: [ :repo | (monticelloWorkingCopy possiblyNewerVersionsIn: repo) notEmpty ifTrue: [ self notify: 'There are possibly newer versions of the package ', packageSpec name printString, ' in the repository ', repo description printString, '. Cancel and manually merge if you want to pick up the changes from the later version.' ]. repositoryGroup addRepository: repo ]. modifiedPackages at: packageSpec name put: repositoryGroup ]. cacheRepository := MCCacheRepository default. modifiedPackages isEmpty ifTrue: [ self notify: 'Empty modified packages list' "actually here for debugging purposes" ]. modifiedPackages keysAndValuesDo: [ :packageName :repositoryGroup | | gofer repositoryList packageSpec | gofer := Gofer new. gofer disablePackageCache. (repositoryGroup repositories reject: [:repo | repo = cacheRepository ]) do: [ :repository | gofer repository: repository ]. gofer package: packageName. gofer commit: commitMessage ]. ^ modifiedPackages! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! stableVersion: stableVersionString for: configurationBasename platformAttribute: platformAttribute "Set the #stable symbolic version to the given version, using the given platformAttribute." (MetacelloToolBox configurationNamed: configurationBasename) symbolicVersionMethod: #stable; addSymbolicSection: platformAttribute version: stableVersionString; commitMethod. ! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! createDevelopment: developmentVersionString for: configurationBasename from: existingDevelopmentVersionString description: aString "Create a new development version based on the specifications in an existing development version. Modify the #development symbolic version to reference the new version." | toolbox | (toolbox := self configurationNamed: configurationBasename) createVersionMethod: 'version' , (self stripVersionStringForSelector: developmentVersionString) , ':' inCategory: 'versions' forVersion: developmentVersionString; addSectionsFrom: existingDevelopmentVersionString forBaseline: false updateProjects: true updatePackages: true versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ "update the author, blessing, description and timeStamp" versionSpec author: MetacelloPlatform current authorName; description: aString; blessing: #development; timestamp: MetacelloPlatform current timestamp ]. true ]; commitMethod. toolbox symbolicVersionMethod: #development; addSymbolicSection: #common version: developmentVersionString; commitMethod. ^ toolbox! ! !MetacelloToolBox class methodsFor: 'development support' stamp: 'dkh 3/7/2012 17:08:50'! compareVersionsIn: aConfigurationClass "Compare the current #stable version to current #development version" | developmentVersion previousVersion | developmentVersion := aConfigurationClass project version: #development. previousVersion := aConfigurationClass project version: #stable. ^self compareVersion: previousVersion versionString for: aConfigurationClass name asString to: developmentVersion versionString ! ! !MetacelloToolBox class methodsFor: 'instance creation' stamp: 'dkh 3/7/2012 17:08:50'! configurationNamed: baseName ^self new configurationNamed: baseName; yourself! ! !MetacelloToolBox class methodsFor: 'validation' stamp: 'dkh 3/7/2012 17:08:50'! copyConfiguration: aConfigurationClass to: metacelloRepositoryString "Copy the current configuration mcz file to the given repository (i.e., http: //... or directory://, etc.)" | project | project := aConfigurationClass project. project projectPackage copySpecTo: ((project repositorySpec) description: metacelloRepositoryString; yourself)! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! createBranch: branchName for: configurationBasename description: commitMessage "Create a new branch for the project and save the configuration to it's repository." | toolbox criticalIssues | branchName isEmpty ifTrue: [ ^self saveConfigurationPackageFor: configurationBasename description: commitMessage ]. (criticalIssues := self checkForCriticalValidationIssues: configurationBasename) isEmpty ifTrue: [ toolbox := self configurationNamed: configurationBasename. toolbox project goferBranch: branchName project: commitMessage. ^toolbox ]. self error: 'There are critical issues in configuration ' , configurationBasename printString, '. Configuration not saved'. ^nil! ! !MetacelloToolBox class methodsFor: 'development support' stamp: 'dkh 3/7/2012 17:08:50'! modifyDevelopmentVersionIn: aConfigurationClass imports: imports requiredProjects: projectList packages: packageList description: message "Modify #development version's baseline version based on the given structure imports - imports array projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names " | developmentVersion files | developmentVersion := aConfigurationClass project version: #development. files := OrderedCollection new. packageList do: [:packageName | files add: packageName -> packageName ]. self modifyVersion: developmentVersion versionString section: #common for: aConfigurationClass name asString repository: nil requiredProjects: projectList packages: packageList dependencies: #() includes: #() files: files repositories: #() preLoadDoIts: #() postLoadDoIts: #() supplyingAnswers: #() groups: #(). (self configurationNamed: aConfigurationClass name asString) modifyVersionMethodForVersion: developmentVersion versionString; imports: imports; commitMethod. self updateDevelopment: developmentVersion versionString for: aConfigurationClass name asString updateProjects: false description: message! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! releaseVersion: developmentVersionString for: configurationBasename blessingAttribute: attribute platformAttribute: platformAttribute "Set the blessing to #release and set the #stable symbolic version to the given version, using the given attributes for each." | toolbox | (toolbox := self configurationNamed: configurationBasename) modifyVersionMethodForVersion: developmentVersionString versionSpecsDo: [ :attr :versionSpec | attr == attribute ifTrue: [ versionSpec blessing: #release ]. true ]; commitMethod; symbolicVersionMethod: #development; addSymbolicSection: platformAttribute version: #notDefined; commitMethod; symbolicVersionMethod: #stable; addSymbolicSection: platformAttribute version: developmentVersionString; commitMethod. ^ toolbox! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! modifySymbolicVersion: symbolicVersionSymbol for: configurationBasename attribute: attribute to: versionString "Set the value of the symbolic version for the given attribute to the given version string" | toolbox | (toolbox := self configurationNamed: configurationBasename) modifySymbolicVersionMethodFor: symbolicVersionSymbol; addSymbolicSection: attribute version: versionString; commitMethod. ^ toolbox! ! !MetacelloToolBox class methodsFor: 'development support' stamp: 'dkh 3/7/2012 17:08:50'! saveModifiedPackagesAndConfigurationIn: aConfigurationClass description: commitMessage "Save modified mcz files, update and then save the configuration." | version | version := aConfigurationClass project version: #development. self saveModifiedDevelopmentPackages: version versionString for: aConfigurationClass name asString description: commitMessage. (self updateDevelopment: version versionString for: aConfigurationClass name asString updateProjects: false description: commitMessage) isEmpty ifTrue: [ self updateDescription: version versionString for: aConfigurationClass name asString description: commitMessage ]. self saveConfigurationPackageFor: aConfigurationClass name asString description: commitMessage! ! !MetacelloToolBox class methodsFor: 'development support' stamp: 'dkh 3/7/2012 17:08:50'! updateToLatestPackageVersionsIn: aConfigurationClass description: descriptionString "Update the #development version to match currently loaded mcz files." "self updateToLatestPackageVersions: '- fixed a bug'" ^self updateDevelopment: #development for: aConfigurationClass name asString updateProjects: false description: descriptionString! ! !MetacelloToolBox class methodsFor: 'validation' stamp: 'dkh 3/7/2012 17:08:50'! validateConfiguration: configurationClass "Check the configuration for Errors, Critical Warnings, and Warnings (see class comment for MetacelloMCVersionValidator for more information). " ^ self validateConfiguration: configurationClass debug: #() recurse: false! ! !MetacelloToolBox class methodsFor: 'development support' stamp: 'dkh 3/7/2012 17:08:50'! createNewBaselineVersionIn: aConfigurationClass requiredProjects: projectList packages: packageList dependencies: dependencies groups: groups "Create a new baseline version based upon #stable version's baseline, modify the baseline based on the provided structural additions: projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names dependencies - collection of associations where key is name of package and value is collection of required packages and projects groups - collection of associations where key is the name of the group and value is the collection of group members " | currentVersion existingBaselineVersionString baselineVersionNumber | currentVersion := aConfigurationClass project version: #development. existingBaselineVersionString := currentVersion importedVersions first. baselineVersionNumber := existingBaselineVersionString asMetacelloVersionNumber incrementMinorVersionNumber. self createBaseline: baselineVersionNumber versionString for: aConfigurationClass name asString from: existingBaselineVersionString description: ''. self modifyVersion: baselineVersionNumber versionString section: #common for: aConfigurationClass name asString repository: nil requiredProjects: projectList packages: packageList dependencies: dependencies includes: #() files: #() repositories: #() preLoadDoIts: #() postLoadDoIts: #() supplyingAnswers: #() groups: groups! ! !MetacelloToolBox class methodsFor: 'development support' stamp: 'dkh 3/7/2012 17:08:50'! modifyBaselineVersionIn: aConfigurationClass repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependencies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: groups "Modify #development version's baseline version based on the given structure repositoryDescription - metacello repository string projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names dependencies - collection of associations where key is name of package and value is collection of required packages and projects includes - collection of associations where key is name of package and value is collection of included packages and projects files - collection of associations where key is name of package and value is name of file repositories - collection of associations where key is name of package and value is collection of repository descriptions preLoadDoIts - collection of associations where key is name of package and value is preload doit selector postLoadDoIts - collection of associations where key is name of package and value is postload doit selector supplyingAnswers - collection of associations where key is name of package and value is the supplyingAnswers array groups - collection of associations where key is the name of the group and value is the collection of group members " | currentVersion existingBaselineVersionString | currentVersion := aConfigurationClass project version: #development. existingBaselineVersionString := currentVersion importedVersions first. self modifyVersion: existingBaselineVersionString section: #common for: aConfigurationClass name asString repository: repositoryDescription requiredProjects: projectList packages: packageList dependencies: dependencies includes: includes files: files repositories: repositories preLoadDoIts: preLoadDoIts postLoadDoIts: postLoadDoIts supplyingAnswers: supplyingAnswers groups: groups! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! releaseVersion: developmentVersionString for: configurationBasename "Set the #common blessing to #release and set the #common #stable symbolic version to the given version." ^ self releaseVersion: developmentVersionString for: configurationBasename blessingAttribute: #common platformAttribute: #common! ! !MetacelloToolBox class methodsFor: 'development support' stamp: 'dkh 3/7/2012 17:08:50'! saveModifiedPackagesIn: aConfigurationClass description: commitMessage "Save modified mcz files and update the configuration." | version | version := aConfigurationClass project version: #development. self saveModifiedDevelopmentPackages: version versionString for: aConfigurationClass name asString description: commitMessage; updateDevelopment: version versionString for: aConfigurationClass name asString updateProjects: false description: commitMessage! ! !MetacelloToolBox class methodsFor: 'help' stamp: 'dkh 3/7/2012 17:08:50'! helpTopicClass ^Smalltalk at: #HelpTopic ifAbsent: []! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! createBaseline: baselineVersionString for: configurationBasename repository: repositoryDescription requiredProjects: projectList packages: packageList repositories: repositories dependencies: dependencies groups: groups "Create a new baseline version based on the specified project structure. repositoryDescription - metacello repository string projectList - collection of project base names (without ConfigurationOf prefix) packageList - collection of package base names repositories - collection of associations where key is name of package and value is collection of repository descriptions dependencies - collection of associations where key is name of package and value is collection of required packages and projects groups - collection of associations where key is the name of the group and value is the collection of group members " | toolbox | (toolbox := self configurationNamed: configurationBasename) createVersionMethod: 'baseline' , (self stripVersionStringForSelector: baselineVersionString) , ':' inCategory: 'baselines' forVersion: baselineVersionString; addSection: #'common' repository: repositoryDescription requiredProjects: projectList packages: packageList repositories: repositories dependencies: dependencies groups: groups versionSpecsDo: [ :versionSpec | versionSpec blessing: #'baseline' ]; commitMethod. ^ toolbox! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! createVersion: targetVersionString for: configurationBasename from: sourceVersionString description: aString "Create a new version based on the specifications in the given version. If the new version string contains 'baseline', then create a new baseline version. If the given version is a baseline, then create a new version based on the given baseline. If the given version is a non-baseline version, then create a new version based on the given version." | toolbox sourceVersion | toolbox := self configurationNamed: configurationBasename. sourceVersion := toolbox project version: sourceVersionString. ^ (targetVersionString indexOfSubCollection: 'baseline') > 0 ifTrue: [ "create baseline version from baseline version" sourceVersion blessing ~~ #baseline ifTrue: [ self error: 'Cannot create a baseline version ' , sourceVersionString printString , ' from a non-baseline version ' , targetVersionString printString ]. self createBaseline: targetVersionString for: configurationBasename from: sourceVersionString description: aString ] ifFalse: [ sourceVersion blessing == #baseline ifTrue: [ "create development version version from baseline version" self createDevelopment: targetVersionString for: configurationBasename importFromBaseline: sourceVersion versionString description: aString ] ifFalse: [ "create development version version from development version" self createDevelopment: targetVersionString for: configurationBasename from: sourceVersion versionString description: aString ] ]! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! modifyVersion: sourceVersionString for: configurationBasename versionSpecsDo: aBlock "Modify the version specifications for the given version" (self configurationNamed: configurationBasename) modifyVersionMethodForVersion: sourceVersionString versionSpecsDo: aBlock; commitMethod! ! !MetacelloToolBox class methodsFor: 'validation' stamp: 'dkh 3/7/2012 17:08:50'! validateProject: aMetacelloProject version: versionString "Check a specific version in the configuration for Errors, Critical Warnings, and Warnings (see class comment for MetacelloMCVersionValidator for more information). " ^ self validateProject: aMetacelloProject version: versionString debug: #() recurse: false ! ! !MetacelloToolBox class methodsFor: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! saveConfigurationPackageFor: configurationBasename description: commitMessage "Save mcz file that contains the configuration to it's repository." | toolbox criticalIssues | (criticalIssues := self checkForCriticalValidationIssues: configurationBasename) isEmpty ifTrue: [ toolbox := self configurationNamed: configurationBasename. toolbox project goferCommitProject: commitMessage. ^toolbox ]. self error: 'There are critical issues in configuration ' , configurationBasename printString, '. Configuration not saved'. ^nil! ! !MetacelloToolBox class methodsFor: 'private' stamp: 'dkh 3/7/2012 17:08:50'! appendDescription: aString to: versionSpec aString isEmpty ifTrue: [ ^ self ]. ^ versionSpec description value isEmpty ifTrue: [ versionSpec description: aString ] ifFalse: [ | strm | strm := WriteStream on: String new. strm nextPutAll: versionSpec description value; cr; nextPutAll: aString. versionSpec description: strm contents ]! ! !MetacelloToolBoxConstructor methodsFor: 'api callbacks' stamp: 'dkh 9/7/2012 13:12'! setFor: attributeList version: aString "conditional symbolicVersion support" self methodSections add: (MetacelloSymbolicVersionSpec new attributes: attributeList asMetacelloAttributeList; versionString: aString; yourself)! ! !MetacelloToolBoxConstructor methodsFor: 'private' stamp: 'DaleHenrichs 12/23/2010 15:21'! methodSection: methodSection do: aBlock methodSection methodSections do: aBlock. methodSection methodSections do: [ :ms | self methodSection: ms do: aBlock ]! ! !MetacelloToolBoxConstructor methodsFor: 'accessing' stamp: 'dkh 9/13/2012 16:09'! methodSectionAttributes | attributes | attributes := Set new. self methodSectionsDo: [ :methodSection | attributes addAll: methodSection attributes ]. ^ attributes! ! !MetacelloToolBoxConstructor methodsFor: 'api callbacks' stamp: 'dkh 9/7/2012 13:12'! setFor: attributeList do: aBlock "conditional version support" | methodSection | methodSection := MetacelloVersionMethodSection new attributes: attributeList asMetacelloAttributeList; block: aBlock; yourself. currentSection ~~ nil ifTrue: [ currentSection addMethodSection: methodSection ] ifFalse: [ self methodSections add: methodSection ]! ! !MetacelloToolBoxConstructor methodsFor: 'private' stamp: 'DaleHenrichs 12/22/2010 09:56'! evaluateMethodSection: methodSection version: sourceVersionString | versionSpec | versionSpec := self project versionSpec. versionSpec versionString: sourceVersionString. methodSection versionSpec: versionSpec. currentSection := methodSection. self with: versionSpec during: methodSection block. methodSection methodSections do: [ :ms | self evaluateMethodSection: ms version: sourceVersionString ]! ! !MetacelloToolBoxConstructor methodsFor: 'extraction' stamp: 'DaleHenrichs 12/22/2010 11:07'! extractMethodSectionsFor: sourceVersionString | coll pragma | coll := self extractAllVersionPragmas at: sourceVersionString ifAbsent: [ ^ #() ]. coll size > 1 ifTrue: [ self error: 'More than one pragma defining ' , sourceVersionString printString ]. pragma := coll at: 1. self evaluatePragma: pragma. self methodSections do: [ :methodSection | self evaluateMethodSection: methodSection version: sourceVersionString ]. ! ! !MetacelloToolBoxConstructor methodsFor: 'private' stamp: 'dkh 9/7/2012 10:43'! methodSection: methodSection inEvaluationOrder: attributes do: aBlock | selected | selected := IdentitySet new. attributes do: [ :attribute | methodSection methodSections do: [ :ms | (ms attributes includes: attribute) ifTrue: [ selected add: ms ] ] ]. selected do: aBlock. attributes size == 1 ifTrue: [ ^ self ]. selected do: [ :ms | self methodSection: ms inEvaluationOrder: (attributes copyFrom: 2 to: attributes size) do: aBlock ]! ! !MetacelloToolBoxConstructor methodsFor: 'initialization' stamp: 'DaleHenrichs 11/18/2010 16:40'! reset super reset. "not needed, but included for completeness" methodSections := nil! ! !MetacelloToolBoxConstructor methodsFor: 'enumeration' stamp: 'DaleHenrichs 12/23/2010 15:10'! methodSectionsDo: aBlock self methodSection: self do: aBlock ! ! !MetacelloToolBoxConstructor methodsFor: 'extraction' stamp: 'DaleHenrichs 11/15/2010 10:06'! extractSymbolicVersionSpecsFor: sourceVersionSymbol | coll versionSpec pragma | coll := self extractSymbolicVersionPragmas at: sourceVersionSymbol ifAbsent: [ ^ #() ]. coll size > 1 ifTrue: [ self error: 'More than one pragma defining ' , sourceVersionSymbol printString ]. pragma := coll at: 1. self evaluatePragma: pragma. ^ self methodSections ! ! !MetacelloToolBoxConstructor methodsFor: 'enumeration' stamp: 'dkh 9/7/2012 10:40'! methodSectionsInEvaluationOrder: attributes do: aBlock "breadth first traversal ... to collect selected sections, then evaluate individual sections in attribute order" | selected processed | selected := IdentitySet new. self methodSection: self inEvaluationOrder: attributes do: [ :methodSection | selected add: methodSection ]. processed := IdentitySet new. attributes do: [ :attribute | | list | list := OrderedCollection new. selected do: [ :methodSection | (processed includes: methodSection) ifFalse: [ (methodSection attributes includes: attribute) ifTrue: [ list add: methodSection. processed add: methodSection ] ] ]. list do: aBlock ]! ! !MetacelloToolBoxConstructor methodsFor: 'private' stamp: 'DaleHenrichs 11/14/2010 02:08'! methodSections methodSections == nil ifTrue: [ methodSections := OrderedCollection new ]. ^methodSections! ! !MetacelloToolBoxTutorial methodsFor: 'lessons' stamp: 'DaleHenrichs 1/14/2011 12:22:17'! releaseVersion10 ^Lesson title: 'Release version 1.0' lesson: '" 1. Create configuration 2. Prepare to modify the version method for version 1.0: - the project and package versions are not updated 3. Change the blessing to #release for the #common attribute 4. Note that the return value for the #attributeBlocksDo: block is true. If the return value is false, the versionSpec would not be included in the updated mehtod. 5. Compile and validate the #version10: method . 6. Remove version 1.0 from the definition of the #development symbolic version - the version is no longer in development - the return value for the #methodSectionsDo: block (like the #versionSpecsDo: block) determins whether the methodSection is carried forward or not 7. Compile and validate the #development: method 8. Prepare to define the symbolic version method #stable: 9. Define version 1.0 as the #stable symbolic version for #common 10. Compile and validate the #stable: method" "1" (MetacelloToolBox configurationNamed: ''Example'') "2." modifyVersionMethodForVersion: ''1.0'' versionSpecsDo: [ :attribute :versionSpec | attribute == #common "3." ifTrue: [ versionSpec blessing: #release ]. "4." true ]; "5." commitMethod; "6." modifySymbolicVersionMethodFor: #development symbolicVersionSpecsDo: [ :methodSection | methodSection versionString ~= ''1.0'' ]; "7." commitMethod; "8." createSymbolicVersionMethod: ''stable:'' inCategory: ''symbolic versions'' forVersion: #stable; "9." addSymbolicSection: #common version: ''1.0''; "10." commitMethod. "After evaluating the above expression, take a look at the updated method #version10, where you will see that the blessing has been updated to #release. Look at the #development: method (which should be empty) and the #stable: method" ProfStef next. ' ! ! !MetacelloToolBoxTutorial methodsFor: 'lessons' stamp: 'DaleHenrichs 1/14/2011 12:22:17'! intro ^Lesson title: 'Intro' lesson: '"The lessons in this section cover some of the same material that was covered in the development process tutorial, but we take a closer look at the implementation using the instance-side protocol instead of the class-side protocol" ProfStef next. ' ! ! !MetacelloToolBoxTutorial methodsFor: 'intro' stamp: 'DaleHenrichs 1/14/2011 12:22:17'! introductionText ^'Dive down into the MetacelloToolBox API to take a closer look at the implementation of the development support methods.'! ! !MetacelloToolBoxTutorial methodsFor: 'lessons' stamp: 'DaleHenrichs 1/14/2011 12:22:17'! create10Baseline ^Lesson title: 'Create 1.0 Baseline' lesson: '" 1. Create configuration - class named ConfigurationOfExample created if it does not already exist. 2. Prepare to define baseline version method - selector, category and version number defined 3. Define baseline project structure - repository - external project ''Shout'' - packages ''ProfStef-Core'' and ''ProfStef-Tests'', plus dependencies 4. Compile the #baseline10: method - version method compiled and validated " "1." (MetacelloToolBox configurationNamed: ''Example'') "2." createVersionMethod: ''baseline10:'' inCategory: ''baselines'' forVersion: ''1.0-baseline''; "3." addSection: #common repository: ''http://www.squeaksource.com/ProfStef'' requiredProjects: #(''Shout'') packages: #(''ProfStef-Core'' ''ProfStef-Tests'') dependencies: {(''ProfStef-Core'' -> #(''Shout'')). (''ProfStef-Tests'' -> #(''ProfStef-Core''))} groups: {(''default'' -> #(''Core'')). (''Core'' -> #(''ProfStef-Core'')). (''Tests'' -> #(''ProfStef-Tests'')). (''Core Tests'' -> #(''Core'' ''Tests''))} versionSpecsDo: [ :versionSpec | versionSpec blessing: #baseline ]; "4." commitMethod. "After evaluating the above expression, browse the configuration:" ConfigurationOfExample browse. "and look at the generated method #baseline10:. Note that the symbolic version #bleedingEdge is used for the Shout project." ProfStef next. ' ! ! !MetacelloToolBoxTutorial methodsFor: 'lessons' stamp: 'DaleHenrichs 1/14/2011 12:22:17'! open10ForDevelopment ^Lesson title: 'Open version 1.0 for development' lesson: '" 1. Create configuration - always start a toolbox expression this way 2. Prepare to define version method #version10: - similar expression used to create baseline method 3. Import specification from version 1.0-baseline - specs that are not needed in a version are dropped - import is added to pragma - with #updateProjects set to true, the current version of the project Shout will set - with #updatePackages set to true, the current mcz files for the packages ProfStef-Core ProfStef-Tests will be set 4. Define desired versionSpec attributes - current author and timestamp - set blessing to #development - set the description - return value of true in block, means the versionSpec is added to current method being defined 5. Compile the #version10: method - compile and validate 6. Prepare to define symbolic version method #development: 7. Define symbolic version - symbolic version #development maps to version 1.0 for the #common attributes - multiple addSymbolicSection: expressions may be used 8. Compile the #development: method - compile and validate" | description | description := ''- fixed a bug''. "1." (MetacelloToolBox configurationNamed: ''Example'') "2." createVersionMethod: ''version10:'' inCategory: ''versions'' forVersion: ''1.0''; "3." importFrom: ''1.0-baseline'' updateProjects: true updatePackages: true versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ "4." versionSpec author: MetacelloPlatform current authorName; blessing: #development; description: description; timestamp: MetacelloPlatform current timestamp ]. true ]; "5." commitMethod; "6." createSymbolicVersionMethod: ''development:'' inCategory: ''symbolic versions'' forVersion: #development; "7." addSymbolicSection: #common version: ''1.0''; "8." commitMethod. "After evaluating the above expression, take a look at the generated methods: - #version10: - #development:" ProfStef next. ' ! ! !MetacelloToolBoxTutorial methodsFor: 'tutorial' stamp: 'DaleHenrichs 1/14/2011 12:22:17'! tutorial ^#( intro create10Baseline open10ForDevelopment updateVersion10 releaseVersion10 open11ForDevelopment create11Baseline releaseVersion11PharoOnly )! ! !MetacelloToolBoxTutorial methodsFor: 'lessons' stamp: 'DaleHenrichs 1/14/2011 12:22:17'! open11ForDevelopment ^Lesson title: 'Open version 1.1 for development' lesson: '" 1. Create configuration 2. Prepare to define version method #version11: 3. Use version 1.0 as basis for version 1.1. basically a copy. Differs from import. 4. Update project and package versions - with #updateProjects set to true, the current version of the project Shout will set - with #updatePackages set to true, the current mcz files for the packages ProfStef-Core ProfStef-Tests will be set 5. Define desired versionSpec attributes - current author and timestamp - set blessing to #development - set the description 6. Compile and validate the #version11: method 7. Prepare to modify symbolic version method #development: - keep all of the existing symbolic version specs in the method 8. Define/change the symbolic version for #development to 1.1 9. Compile and validate the #development: method" | description | description := ''''. "1." (MetacelloToolBox configurationNamed: ''Example'') "2." createVersionMethod: ''version11:'' inCategory: ''versions'' forVersion: ''1.1''; "3." addSectionsFrom: ''1.0'' forBaseline: false "4." updateProjects: true updatePackages: true versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ "5." versionSpec author: MetacelloPlatform current authorName; description: description; blessing: #development; timestamp: MetacelloPlatform current timestamp ]. true ]; "6." commitMethod; "7." modifySymbolicVersionMethodFor: #development symbolicVersionSpecsDo: [ :symbolicVersionSpec | true ]; "8." addSymbolicSection: #common version: ''1.1''; "9." commitMethod. "After evaluating the above expression, take a look at the generated methods: - #version11: - #development:" ProfStef next. ' ! ! !MetacelloToolBoxTutorial methodsFor: 'lessons' stamp: 'DaleHenrichs 1/14/2011 12:22:17'! updateVersion10 ^Lesson title: 'Update specs for version 1.0' lesson: '" 1. Create configuration 2. Prepare to update the version method for version 1.0: - with #updateProjects set to true, the current version of the project Shout will set - with #updatePackages set to true, the current mcz files for the packages ProfStef-Core ProfStef-Tests will be set 3. Define desired versionSpec attributes - current author and timestamp 4. Append the #logEntry to the version descripttion 5. Compile the #version10: method - compile and validate" | logEntry | logEntry := ''- fixed a bug''. "1." (MetacelloToolBox configurationNamed: ''Example'') "2." updateVersionMethodForVersion: ''1.0'' versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ "3." versionSpec author: MetacelloPlatform current authorName; timestamp: MetacelloPlatform current timestamp. "4." versionSpec description value isEmpty ifTrue: [ versionSpec description: logEntry ] ifFalse: [ | strm | strm := WriteStream on: String new. strm nextPutAll: versionSpec description value; cr; nextPutAll: logEntry. versionSpec description: strm contents ] ]. true ]; "5." commitMethod. "After evaluating the above expression, take a look at the updated method #version10. Unless you changed the packages that were loaded in your image, you should just see the #timestamp and #description fields updated." ProfStef next. ' ! ! !MetacelloToolBoxTutorial methodsFor: 'lessons' stamp: 'DaleHenrichs 1/14/2011 12:22:17'! create11Baseline ^Lesson title: 'Create 1.1 Baseline' lesson: '" 1. Create configuration 2. Prepare to define baseline version method 3. Copy specs from 1.0-baseline. This is a copy not an import, so all specs are preserved - with #updateProjects set to false, the version of the project Shout is preserved - with #updatePackages set to false, the specification of the mcz files for the packages ProfStef-Core ProfStef-Tests are preserved (typically not specified) 4. Add and additional section for the attribute #pharo - the package ProfStefBrowser and it''s dependencies are added - the package is added to the UI group 5. Compile and validate #baseline11: method 6. Prepare to modify the method defining version 1.1. - false as return value in block means that all existing version specs in 1.1 are dropped on floor. Basically just the method name and pragma are preserved 7. Import the versionSpecs from 1.1-baseline into version 1.1 8. Compile and validate the #version11: method 9. Prepare to modify the method defining symbolic version #development. Preserve existing symbolic version specs 10. add symbolic version spec for #pharo 11. Compile and validate the #development: method " | description | description := ''''. "1." (MetacelloToolBox configurationNamed: ''Example'') "2" createVersionMethod: ''baseline11:'' inCategory: ''baselines'' forVersion: ''1.1-baseline''; "3." addSectionsFrom: ''1.0-baseline'' forBaseline: true updateProjects: false updatePackages: false versionSpecsDo: [ :attribute :versionSpec | true ]; "4" addSection: #pharo repository: nil requiredProjects: #() packages: #(''ProfStefBrowser'') dependencies: {(''ProfStefBrowser'' -> #(''ProfStef-Core''))} groups: {(''UI'' -> #(''ProfStefBrowser''))} versionSpecsDo: [ :versionSpec | ]; "5." commitMethod; "6." modifyVersionMethodForVersion: ''1.1'' versionSpecsDo: [ :attribute :versionSpec | false ]; "7." importFrom: ''1.1-baseline'' updateProjects: true updatePackages: true versionSpecsDo: [ :attribute :versionSpec | attribute == #common ifTrue: [ "update the author, blessing and timeStamp" versionSpec author: MetacelloPlatform current authorName; blessing: #development; description: description; timestamp: MetacelloPlatform current timestamp ]. true ]; "8." commitMethod; "9" modifySymbolicVersionMethodFor: #development symbolicVersionSpecsDo: [ :symbolicVersionSpec | true ]; "10." addSymbolicSection: #pharo version: ''1.1''; "11." commitMethod. "Look at the generated methods: #baseline11: #version11: #development:" ProfStef next. ' ! ! !MetacelloToolBoxTutorial methodsFor: 'lessons' stamp: 'DaleHenrichs 1/14/2011 12:22:17'! releaseVersion11PharoOnly ^Lesson title: 'Release version 1.1 (#pharo only)' lesson: '" 1. Create configuration 2. Prepare to modify the version method for version 1.1: 3. Change the blessing to #release for the #pharo attribute 4. Compile and validate the #version11: method . 5. Remove version 1.0 from the definition of the #development symbolic version 6. Compile and validate the #development: method 7. Prepare to define the symbolic version method #stable: 8. Define version 1.1 as the #stable symbolic version for #common 9. Compile and validate the #stable: method" "1." (MetacelloToolBox configurationNamed: ''Example'') "2." modifyVersionMethodForVersion: ''1.1'' versionSpecsDo: [ :attribute :versionSpec | attribute == #pharo "3." ifTrue: [ versionSpec blessing: #release ]. true ]; "4." commitMethod; "5." modifySymbolicVersionMethodFor: #development symbolicVersionSpecsDo: [ :symbolicVersionSpec | symbolicVersionSpec attribute ~~ #pharo ]; "6." commitMethod; "7." modifySymbolicVersionMethodFor: #stable symbolicVersionSpecsDo: [ :symbolicVersionSpec | true ]; "8." addSymbolicSection: #pharo version: ''1.1''; "9." commitMethod. "After evaluating the above expression, take a look at the generated methods: #version11: #development: #stable: " ProfStef next. ' ! ! !MetacelloToolBoxTutorial class methodsFor: 'tutorial metainfo' stamp: 'DaleHenrichs 1/14/2011 12:22:17'! title ^'Inside Metacello Toolbox API'! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version02: spec spec for: #common do: [ spec package: 'Example-Core' with: [ spec file: 'Example-Core-anon.9'; repository: 'http://www.example.com/Example' ] ]. ! ! !MetacelloTutorialConfig methodsFor: 'baselines' stamp: 'dkh 3/18/2011 14:15:41'! baseline13: spec spec for: #common do: [ spec blessing: #baseline. spec repository: 'http://www.example.com/Example'. spec package: 'Example-Core' with: [ spec includes: #('Example-Platform' ) ]; package: 'Example-Tests' with: [ spec requires: 'Example-Core' ]; package: 'Example-AddOn' with: [ spec requires: 'Example-Core' ]; package: 'Example-Platform' with: [ spec requires: 'Example-Core' ]; package: 'Example-AddOnTests' with: [ spec requires: #('Example-AddOn' 'Example-Tests' ) ]. spec group: 'default' with: #('Example-Core' 'Example-AddOn' ); group: 'Tests' with: #('Example-Tests' 'Example-AddOnTests' ) ]. spec for: #gemstone do: [ spec package: 'Example-Platform' with: 'Example-Platform.gemstone'.]. spec for: #pharo do: [ spec package: 'Example-Platform' with: 'Example-Platform.pharo'.]. spec for: #squeak do: [ spec package: 'Example-Platform' with: 'Example-Platform.squeak'.].! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson02 " [ see method: #version02: ] For version 0.2, we've simply updated the package version to 'Example-Core-anon.9', which can be confirmed by printing the following expression: (MetacelloTutorialConfig project version: '0.2') spec "! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson14 " STILL UNDER CONSTRUCTION: Open your browsers on the class MetacelloProjectRefTutorial to continue the tutorial. "! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson05 " [ see method: #version05: ] For version 0.5 we've added an additional package to the mix: 'Example-AddOn': (MetacelloTutorialConfig project version: '0.5') spec Of course, the point of specifiying packages in Metacello is to be able to load versions. Here are a couple examples of loading versions of the Tutorial. If you print the result of each expression, you will see the list of packages in load order (note that for the tutorial, we are using the MetacelloNullRecordingMCSpecLoader. This class records which packages are loaded and the order that they are loaded in among other things instead of actually loading the packages. (MetacelloTutorialConfig project version: '0.1') load. (MetacelloTutorialConfig project version: '0.4') load. (MetacelloTutorialConfig project version: '0.5') load. You will note that in each case, all of the packages associated with the version are loaded, which is the default. If you want to load a subset of the packages in a project, you may list the packages that you are interested in as an argument to the #load: method: (MetacelloTutorialConfig project version: '0.5') load: { 'Example-Tests'. 'Example-Core' }. Note that the ordering of the packages is based on the order in which the packages are specified. If you evaluate the following expression: (MetacelloTutorialConfig project version: '0.5') load: { 'Example-Tests'. }. Only the package is 'Example-Tests'. By default the packages are ordered, but there are no implicit dependencies. "! ! !MetacelloTutorialConfig methodsFor: 'accessing' stamp: 'dkh 3/18/2011 14:15:41'! project "NOTE: The MetacelloNullRecordingMCSpecLoader is being used to prevent packages from being loaded, see MetacelloConfigTemplate>>project for an example #project method that loads the package for real" ^ project ifNil: [ | constructor loader | "Construct Metacello project" constructor := (Smalltalk at: #MetacelloVersionConstructor) on: self. project := constructor project. loader := MetacelloNullRecordingMCSpecLoader new. loader evalDoits: true. project loader: loader. project ]! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson08 " [ see method: #version08: ] In version 0.8 we've simply updated the package versions, which can be seen by comparing the results of loading version 0.7 and 0.8: (MetacelloTutorialConfig project version: '0.7') load. (MetacelloTutorialConfig project version: '0.8') load. "! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson01 " [ see metod: #version01: ] Version 0.1 represents the simplest version specification possible. In the method #version01, version 0.1 is defined with a single package 'Example-Core-anon.8' that is loaded from the repository 'http://www.example.com/Example'. Looking at this method you will notice a couple of things. Immediately after the method selector you see the pragma definition: The pragma indicates that the version created in this method should be associated with version '0.1' of the Tutorial project. Looking a little closer you see that the argument to the method, , is the only variable in the method and it is used as the receiver to four different messages: - #for:do: - #package:with: - #file: - #repository: With the evaluation of each block expression, a new object is pushed on a stack and the messages within the block are sent to the object on the top of the stack. So the method should be read as: Create version '0.1'. The #common code for version '0.1' (#for:do:) consists of a package named 'Example-Core' (#package:with:) whose file attribute is 'Example-Core-anon.8' (#file:) and whose repository attribute is 'http://www.example.com/Example' (#repository:). We can see the spec created for version 0.1 by printing the following expression: (MetacelloTutorialConfig project version: '0.1') spec Note that in creating version '0.1' the #common attribute is extracted out. In addition to #common, there are pre-defined attributes for each of the platforms upon which Metacello runs (#pharo, #squeak, #gemstone and #squeakCommon). #squeakCommon is used for both #pharo and #squeak. "! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version04: spec spec for: #common do: [ spec repository: 'http://www.example.com/Example'. spec package: 'Example-Core' with: 'Example-Core-anon.10'; package: 'Example-Tests' with: 'Example-Tests-anon.3' ]. ! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version06: spec spec for: #common do: [ spec repository: 'http://www.example.com/Example'. spec package: 'Example-Core' with: 'Example-Core-anon.12'; package: 'Example-Tests' with: [ spec file: 'Example-Tests-anon.3'; requires: 'Example-Core' ]; package: 'Example-AddOn' with: [ spec file: 'Example-AddOn-anon.1'; requires: 'Example-Core' ]]. ! ! !MetacelloTutorialConfig methodsFor: 'baselines' stamp: 'dkh 3/18/2011 14:15:41'! baseline10: spec spec for: #common do: [ spec blessing: #baseline. spec repository: 'http://www.example.com/Example'. spec package: 'Example-Core'; package: 'Example-Tests' with: [ spec requires: 'Example-Core' ]; package: 'Example-AddOn' with: [ spec requires: 'Example-Core' ]; package: 'Example-AddOnTests' with: [ spec requires: #('Example-AddOn' 'Example-Tests' ) ]. spec group: 'default' with: #('Example-Core' 'Example-AddOn' ); group: 'Tests' with: #('Example-Tests' 'Example-AddOnTests' ) ]. ! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson07 " [ see method: #baseline07: and #version07: ] For version 0.7, we are ceating a baseline version specification which is expected to be used across several versions and the version specification which is restricted to the file versions. In method #baseline07: the structure of version '0.7-baseline' is specified. The repository is listed, the packages are listed and the required packages are defined. We'll cover the #blessing: in a later lesson. In method #version07: the file versions are specified. You will note that the pragma as an #imports: component that specifies the list of versions that this version (version '0.7') is based upon. In fact, if you print the spec for '0.7-baseline' and then print the spec for '0.7' you can see that '0.7' is a composition of both versions: (MetacelloTutorialConfig project version: '0.7-baseline') spec. (MetacelloTutorialConfig project version: '0.7') spec. Of course if you print the '0.6' spec and the '0.7' spec you can see that they specify exactly the same information in a slightly different way: (MetacelloTutorialConfig project version: '0.6') spec. (MetacelloTutorialConfig project version: '0.7') spec. and if you load each of the versions, you will see that they load the same packages, in the same order: (MetacelloTutorialConfig project version: '0.6') load. (MetacelloTutorialConfig project version: '0.7') load. Finally, even though version '0.7-baseline' does not have explicit package versions, you may load the version. When the 'real' loader encounters a package name (without version information) it will attempt to load the latest version of the package from the repository. With the MetacelloNullRecordingMCSpecLoader the packages names are 'loaded': (MetacelloTutorialConfig project version: '0.7-baseline') load. Of course when a number of developers are working on a project it may be useful to load a #baseline version so that you get the latest work from all of the project members. "! ! !MetacelloTutorialConfig methodsFor: 'doits' stamp: 'dkh 3/18/2011 14:15:41'! preloadForCore Transcript cr; show: '#preloadForCore executed'.! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version01: spec spec for: #common do: [ spec package: 'Example-Core' with: [ spec file: 'Example-Core-anon.8'; repository: 'http://www.example.com/Example' ] ]. ! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version08: spec spec for: #common do: [ spec package: 'Example-Core' with: 'Example-Core-anon.15'; package: 'Example-Tests' with: 'Example-Tests-anon.6'; package: 'Example-AddOn' with: 'Example-AddOn-anon.2' ]. ! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson11 " [ see method: #version11: ] In version 0.11 we've defined a couple of attributes that are expected to be used all of the time in a version specification: #blessing: #description: #author: #timestamp: The following lessons cover each of these attributes in more detail. "! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version13: spec spec for: #common do: [ spec blessing: #development. spec description: 'Add in doits for Example-Core'. spec author: 'dkh'. spec timestamp: '10/13/2009 14:27'. spec package: 'Example-Core' with: 'Example-Core-anon.17'; package: 'Example-Tests' with: 'Example-Tests-anon.6'; package: 'Example-AddOn' with: 'Example-AddOn-anon.1'; package: 'Example-AddOnTests' with: 'Example-AddOnTests-anon.1' ]. spec for: #gemstone do: [ spec package: 'Example-Platform' with: 'Example-Platform.gemstone-dkh.4'.]. spec for: #pharo do: [ spec package: 'Example-Platform' with: 'Example-Platform.pharo-dkh.7'.]. spec for: #squeak do: [ spec package: 'Example-Platform' with: 'Example-Platform.squeak-dkh.3'.].! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson13 " [ see methods: #baseline13: #version13: ] For version 1.3 we are adding a platform specific package 'Example-Platform'. 'Example-Platform' requires 'Example-Core'. On GemStone, Pharo and Squeak, a branch of the 'Example-Platform' package will be loaded: 'Example-Platform.gemstone', 'Example-Platform.pharo', 'Example-Platform.squeak' respectively will be loaded. Consequently we've updated the baselines with #baseline13: to reflect the structural changes and #version13: reflects the package versions. The platform-specific versions and branches are defined in the #for:do: block for the corresponding platforms: #gemstone, #pharo, #squeak (in both methods) The result of the following expression will depend on the platform upon which you are running: (MetacelloTutorialConfig project version: '1.3') load. Note that when you execute the following expresson to load 'Example-Core' that the correct 'Example-Platform' is loaded as well: (MetacelloTutorialConfig project version: '1.3') load: 'Example-Core'. If you look at the specification for 'Example-Core' (in #baseline13:) you will note that 'Example-Core' #includes: 'Example-Platform'. The #includes: directive means that the package 'Example-Platform' should be loaded whenever the 'Example-Core' package is loaded. Also note when you evaluate the following expression that the 'Example-Platform' package is loaded before 'Example-Tests' as if 'Example-Tests' #requires: 'Example-Platform': (MetacelloTutorialConfig project version: '1.3') load: 'Example-Tests'. When you use the #includes: directive, you are not only specifying that the listed packages should be loaded when the parent package is loaded, but that the #included: packages should be loaded _before_ any packages that require the parent package. "! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson11Blessing " [ see method: #version11: ] A version can be tagged with a blessing like #alpha, #beta, #release, #development or any other tag that you find useful. The blessing for version 1.1 is #development (MetacelloTutorialConfig project version: '1.1') blessing. The default blessing is #release, so even though we didn't specify a blessing for version 0.5, the blessing is set: (MetacelloTutorialConfig project version: '0.5') blessing. For version 1.1, it is important to explicitly set the blessing, because it imports version '1.0-baseline' whose blessing is #baseline: (MetacelloTutorialConfig project version: '1.0-baseline') blessing. Blessings can be used as a filter. For example, you will notice that the result of the following expression is version 0.6, because #stableVersion answers the latest version whose blessing is _not_ #development, #broken, or #blessing: MetacelloTutorialConfig project stableVersion. MetacelloTutorialConfig project stableVersion load. The blessing of version 1.1 is #development. To find the latest #development version you would execute this expression: MetacelloTutorialConfig project latestVersion: #development. (MetacelloTutorialConfig project latestVersion: #development) load. You can get the very last version independent of blessing by executing this expression: MetacelloTutorialConfig project bleedingEdge. MetacelloTutorialConfig project bleedingEdge load. In general, the #development blessing should be used for any version that is unstable. Once a version has stabilized, a different blessing should be applied. The following expression will load the latest version of all of the packages for the latest #baseline version: (MetacelloTutorialConfig project latestVersion: #baseline) load. Since the latest #baseline version should reflect the most up-to-date project structure, executing the previous expression should load the absolute bleeding edge of the project. "! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson10 " [ see method: #baseline10: #version10: ] In #baseline10: we've added two things: the 'Example-AddOnTests' package and a specification for groups. The 'Example-AddOnTests' package has been added to make the idea of needing to group packages a little more appealing. The package requires 'Example-AddOn' and 'Example-Tests'. With two Test packages it would be convenient to be able to load all of the tests with a simple expression like the following: (MetacelloTutorialConfig project version: '1.0') load: { 'Tests'. }. instead of having to explicitly list all of the test projects like this: (MetacelloTutorialConfig project version: '1.0') load: { 'Example-Tests'. 'Example-AddOnTests'. }. This becomes especially useful if over time the project evolves to have more component and test packages. The 'default' group is special in that when a 'default' group is defined, the #load method loads the members of the 'default' group instead of loading all of the packages: (MetacelloTutorialConfig project version: '1.0') load. If you want to load all of the packages in a project, then the pseudo group 'ALL' may be used as follows: (MetacelloTutorialConfig project version: '1.0') load: 'ALL'. "! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson11Timestamp " [ see method: #version11: ] The timestamp of a version can be defined: (MetacelloTutorialConfig project version: '1.1') timestamp. When using the OB-Metacello tools the timestamp field is automatically updated to reflect the current DateAndTime that the update was made. The timestamp is a String "! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson06 " [ see method: #version06: ] In version 0.6 we've added dependency information in the form of the #requires: directive. Both 'Example-Tests' and 'Example-AddOn' require 'Example-Core' to be loaded before they are loaded. Print the following expressions to see that the requires directives are being followed: (MetacelloTutorialConfig project version: '0.5') load: { 'Example-Tests'. }. (MetacelloTutorialConfig project version: '0.6') load: { 'Example-Tests'. }. (MetacelloTutorialConfig project version: '0.6') load: 'Example-AddOn'. (MetacelloTutorialConfig project version: '0.6') load: { 'Example-AddOn'. 'Example-Tests'. }. With version 0.6 we are mixing structural information (required packages and repository) with the dynamic file version info. It is expected that over time the file version info will change from version to version while the structural information will remain relatively static. "! ! !MetacelloTutorialConfig methodsFor: 'doits' stamp: 'dkh 3/18/2011 14:15:41'! postloadForCore: loader package: packageSpec Transcript cr; show: '#postloadForCore executed, Loader: ', loader printString, ' spec: ', packageSpec printString.! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version11: spec spec for: #common do: [ spec blessing: #development. spec description: 'Example of a complete version specification'. spec author: 'dkh'. spec timestamp: '10/12/2009 09:26'. spec package: 'Example-Core' with: 'Example-Core-anon.15'; package: 'Example-Tests' with: 'Example-Tests-anon.4'; package: 'Example-AddOn' with: 'Example-AddOn-anon.1'; package: 'Example-AddOnTests' with: 'Example-AddOnTests-anon.1' ]. ! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version05: spec spec for: #common do: [ spec repository: 'http://www.example.com/Example'. spec package: 'Example-Core' with: 'Example-Core-anon.11'; package: 'Example-Tests' with: 'Example-Tests-anon.3'; package: 'Example-AddOn' with: 'Example-AddOn-anon.1' ]. ! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version10: spec spec for: #common do: [ spec package: 'Example-Core' with: 'Example-Core-anon.14'; package: 'Example-Tests' with: 'Example-Tests-anon.3'; package: 'Example-AddOn' with: 'Example-AddOn-anon.1'; package: 'Example-AddOnTests' with: 'Example-AddOnTests-anon.1' ]. ! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson04 " [ see method: #version04: ] The specification for version 0.4 is basically the same as version 0.3. Instead of listing a repository with each package we specify a project repository that applies to all packages. Compare the printStrings for the specs for each version: (MetacelloTutorialConfig project version: '0.3') spec (MetacelloTutorialConfig project version: '0.4') spec "! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson11Author " [ see method: #version11: ] The author of a version can be defined: (MetacelloTutorialConfig project version: '1.1') author. When using the OB-Metacello tools the author field is automatically updated to reflect the current author as defined in the image. "! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson03 " [ see method: #version03: ] For version 0.3, we've updated the package version to 'Example-Core-anon.10' and added an additional package 'Example-Tests-anon.3', which can be confirmed by printing the following expression: (MetacelloTutorialConfig project version: '0.3') spec As is often the case, the two packages share the same repository, so specifying a repository with each package is redundant. "! ! !MetacelloTutorialConfig methodsFor: 'baselines' stamp: 'dkh 3/18/2011 14:15:41'! baseline07: spec spec for: #common do: [ spec blessing: #baseline. spec repository: 'http://www.example.com/Example'. spec package: 'Example-Core'; package: 'Example-Tests' with: [ spec requires: 'Example-Core' ]; package: 'Example-AddOn' with: [ spec requires: 'Example-Core' ] ]. ! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson11Descripton " [ see method: #version11: ] A description can be defined for a version: (MetacelloTutorialConfig project version: '1.1') description. "! ! !MetacelloTutorialConfig methodsFor: 'lessons' stamp: 'dkh 3/18/2011 14:15:41'! lesson12DoIts " [ see methods: #version12: #preloadForCore #postloadForCore:package: ] Occassionally, you find that you need to perform an expression either before a package is loaded, or after a package is loaded. To do that in Metacello, you can define a preLoadDoIt selector and a postLoadDoIt selector: (MetacelloTutorialConfig project version: '1.2') spec. If you open a Transcript and execute the following expression, you will see that the pre load and post load methods were executed: (MetacelloTutorialConfig project version: '1.2') load. The pre/post load methods may take 0, 1 or 2 args. The loader is the first optional argument and the loaded packageSpec is the second optional argument. "! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version03: spec spec for: #common do: [ spec package: 'Example-Core' with: [ spec file: 'Example-Core-anon.10'; repository: 'http://www.example.com/Example' ]; package: 'Example-Tests' with: [ spec file: 'Example-Tests-anon.3'; repository: 'http://www.example.com/Example' ]]. ! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version07: spec spec for: #common do: [ spec package: 'Example-Core' with: 'Example-Core-anon.12'; package: 'Example-Tests' with: 'Example-Tests-anon.3'; package: 'Example-AddOn' with: 'Example-AddOn-anon.1' ]. ! ! !MetacelloTutorialConfig methodsFor: 'versions' stamp: 'dkh 3/18/2011 14:15:41'! version12: spec spec for: #common do: [ spec blessing: #development. spec description: 'Add in doits for Example-Core'. spec author: 'dkh'. spec timestamp: '10/12/2009 09:26'. spec package: 'Example-Core' with: [ spec file: 'Example-Core-anon.16'; preLoadDoIt: #preloadForCore; postLoadDoIt: #postloadForCore:package: ]; package: 'Example-Tests' with: 'Example-Tests-anon.5'; package: 'Example-AddOn' with: 'Example-AddOn-anon.1'; package: 'Example-AddOnTests' with: 'Example-AddOnTests-anon.1' ]. ! ! !MetacelloTutorialConfig class methodsFor: 'accessing' stamp: 'dkh 3/18/2011 14:15:41'! project ^self new project! ! !MetacelloTutorialConfig class methodsFor: 'private' stamp: 'dkh 3/18/2011 14:15:41'! ensureMetacello "Bootstrap Gofer (if necessary), bootstrap ConfigurationOfMetacello (using old Gofer API), then load the latest version of Metacello itself." Smalltalk at: #MetacelloProject ifAbsent: [ Smalltalk at: #Gofer ifAbsent: [ "Current version of Gofer from which to bootstrap - as of 1.0-beta.15" self bootstrapPackage: 'Gofer-lr.83' from: 'http://seaside.gemstone.com/ss/metacello' ]. Smalltalk at: #Gofer ifPresent: [:goferClass | | gofer | gofer := goferClass new url: 'http://seaside.gemstone.com/ss/metacello'; yourself. [ gofer addPackage: 'ConfigurationOfMetacello' ] on: Warning do: [:ex | ex resume ]. gofer load ]. "load 'default' group of Metacello" (Smalltalk at: #ConfigurationOfMetacello) perform: #load ]! ! !MetacelloTutorialConfig class methodsFor: 'metacello tool support' stamp: 'dkh 3/18/2011 14:15:41'! isMetacelloConfig "Answer true and the Metacello tools will operate on you" ^true! ! !MetacelloTutorialConfig class methodsFor: 'private' stamp: 'dkh 3/18/2011 14:15:41'! bootstrapPackage: aString from: aPath | repository version | repository := MCHttpRepository location: aPath user: '' password: ''. repository versionReaderForFileNamed: aString , '.mcz' do: [:reader | version := reader version. version load. version workingCopy repositoryGroup addRepository: repository]! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/17/2009 10:18'! test08 | project versionSpec loadedPackages version loader | project := self project. version := project version: '0.8'. self assert: version blessing == #baseline. versionSpec := version spec. self assert: (versionSpec packages map includesKey: 'Example-Core'). self assert: (versionSpec packages map at: 'Example-Core') file = 'Example-Core-anon.15'. self assert: (versionSpec packages map at: 'Example-Tests') file = 'Example-Tests-anon.6'. self assert: (versionSpec packages map at: 'Example-AddOn') file = 'Example-AddOn-anon.2'. self assert: versionSpec packages map keys size = 3. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'. loader := version load. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 3. self assert: (loadedPackages indexOf: 'Example-Core-anon.15') > 0. self assert: (loadedPackages indexOf: 'Example-Tests-anon.6') > (loadedPackages indexOf: 'Example-Core-anon.15'). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.2') > (loadedPackages indexOf: 'Example-Core-anon.15'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests-project ref' stamp: 'DaleHenrichs 3/11/2010 21:16'! testProjectRef13 | project loadedPackages loader platformPackage | project := self projectRefProject. loader := (project version: '1.3') load. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 9. self assert: (loadedPackages indexOf: 'Example-Core-anon.17') > 0. self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.17'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Example-Tests-anon.6') > (loadedPackages indexOf: 'Example-Core-anon.17'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.6'). platformPackage := loadedPackages detect: [:pkgName | pkgName beginsWith: 'Example-Platform']. self assert: (loadedPackages indexOf: 'Example-Tests-anon.6') > (loadedPackages indexOf: platformPackage). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: platformPackage). self assert: (loadedPackages indexOf: platformPackage) > (loadedPackages indexOf: 'Example-Core-anon.17'). self assert: (loadedPackages indexOf: 'Project-Core-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.17'). self assert: (loadedPackages indexOf: 'Project-Core-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Project-Core-anon.1'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.6'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Example-AddOnTests-anon.1'). ! ! !MetacelloTutorialTestCase methodsFor: 'private' stamp: 'dkh 10/17/2009 13:17'! project ^MetacelloTutorialConfig project! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 1/2/2010 14:07'! test02 | project versionSpec | project := self project. versionSpec := (project version: '0.2') spec. self assert: (versionSpec packages map includesKey: 'Example-Core'). self assert: (versionSpec packages map at: 'Example-Core') file = 'Example-Core-anon.9'. self assert: versionSpec packages map keys size = 1. self assert: (versionSpec packages map at: 'Example-Core') repositorySpecs first description = 'http://www.example.com/Example'! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/17/2009 17:28'! test11 | project versionSpec loadedPackages version loader | project := self project. version := project version: '1.1'. self assert: version blessing == #development. versionSpec := version spec. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'. loader := version load: 'ALL'. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 4. self assert: (loadedPackages indexOf: 'Example-Core-anon.15') > 0. self assert: (loadedPackages indexOf: 'Example-Tests-anon.4') > (loadedPackages indexOf: 'Example-Core-anon.15'). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.15'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.4'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests-project ref' stamp: 'dkh 7/18/2012 12:54'! testProjectRef10 | project loadedPackages loader | project := self projectRefProject. loader := (project version: '1.0') load. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 6. self assert: (loadedPackages indexOf: 'Example-Core-anon.14') > 0. self assert: (loadedPackages indexOf: 'Example-Tests-anon.3') > (loadedPackages indexOf: 'Example-Core-anon.14'). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.14'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.11'). self assert: (loadedPackages indexOf: 'Project-Core-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.14'). self assert: (loadedPackages indexOf: 'Project-Core-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.3'). self assert: (loadedPackages indexOf: 'Project-Core-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Project-Core-anon.1') > (loadedPackages indexOf: 'Example-AddOnTests-anon.1'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Project-Core-anon.1')! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/17/2009 10:19'! test10c | project versionSpec loadedPackages version loader | project := self project. version := project version: '1.0'. self assert: version blessing == #baseline. versionSpec := version spec. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'. loader := version load: 'Tests'. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 4. self assert: (loadedPackages indexOf: 'Example-Core-anon.14') > 0. self assert: (loadedPackages indexOf: 'Example-Tests-anon.3') > (loadedPackages indexOf: 'Example-Core-anon.14'). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.14'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.3'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests-project ref' stamp: 'TestRunner 10/19/2009 13:26'! testProjectRef07 | project loadedPackages loader | project := self projectRefProject. loader := (project version: '0.7') load. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 5. self assert: (loadedPackages indexOf: 'Example-Core-anon.12') > 0. self assert: (loadedPackages indexOf: 'Project-Core-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.12'). self assert: (loadedPackages indexOf: 'Example-Tests-anon.3') > (loadedPackages indexOf: 'Example-Core-anon.12'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Project-Core-anon.1'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.3'). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.12'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/17/2009 10:17'! test06 | project versionSpec loadedPackages loader | project := self project. versionSpec := (project version: '0.6') spec. self assert: (versionSpec packages map includesKey: 'Example-Core'). self assert: (versionSpec packages map at: 'Example-Core') file = 'Example-Core-anon.12'. self assert: (versionSpec packages map at: 'Example-Tests') file = 'Example-Tests-anon.3'. self assert: (versionSpec packages map at: 'Example-AddOn') file = 'Example-AddOn-anon.1'. self assert: versionSpec packages map keys size = 3. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'. loader := (project version: '0.6') load. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 3. self assert: (loadedPackages indexOf: 'Example-Core-anon.12') > 0. self assert: (loadedPackages indexOf: 'Example-Tests-anon.3') > (loadedPackages indexOf: 'Example-Core-anon.12'). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.12'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/17/2009 10:19'! test10b | project versionSpec loadedPackages version loader | project := self project. version := project version: '1.0'. self assert: version blessing == #baseline. versionSpec := version spec. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'. loader := version load: 'ALL'. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 4. self assert: (loadedPackages indexOf: 'Example-Core-anon.14') > 0. self assert: (loadedPackages indexOf: 'Example-Tests-anon.3') > (loadedPackages indexOf: 'Example-Core-anon.14'). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.14'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.3'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'DaleHenrichs 11/3/2010 10:01'! test11Blessing | project | project := self project. self assert: ((project version: '1.1') blessing) == #development. self assert: ((project version: '0.5') blessing) == #release. self assert: ((project version: '1.0-baseline') blessing) == #baseline. self assert: (project latestVersion: #release) versionString = '0.6'. ! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/13/2009 14:56'! test04 | project versionSpec | project := self project. versionSpec := (project version: '0.4') spec. self assert: (versionSpec packages map includesKey: 'Example-Core'). self assert: (versionSpec packages map at: 'Example-Core') file = 'Example-Core-anon.10'. self assert: (versionSpec packages map at: 'Example-Tests') file = 'Example-Tests-anon.3'. self assert: versionSpec packages map keys size = 2. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/17/2009 10:18'! test07a | project versionSpec loadedPackages version loader | project := self project. version := project version: '0.7-baseline'. self assert: version blessing == #baseline. versionSpec := version spec. self assert: (versionSpec packages map includesKey: 'Example-Core'). self assert: (versionSpec packages map at: 'Example-Core') file = 'Example-Core'. self assert: (versionSpec packages map at: 'Example-Tests') file = 'Example-Tests'. self assert: (versionSpec packages map at: 'Example-AddOn') file = 'Example-AddOn'. self assert: versionSpec packages map keys size = 3. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'. loader := version load. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 3. self assert: (loadedPackages indexOf: 'Example-Core') > 0. self assert: (loadedPackages indexOf: 'Example-Tests') > (loadedPackages indexOf: 'Example-Core'). self assert: (loadedPackages indexOf: 'Example-AddOn') > (loadedPackages indexOf: 'Example-Core'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/17/2009 17:29'! test13 | project versionSpec loadedPackages version platformPackage loader | project := self project. version := project version: '1.3'. self assert: version blessing == #development. versionSpec := version spec. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'. loader := version load: 'ALL'. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 5. self assert: (loadedPackages indexOf: 'Example-Core-anon.17') > 0. self assert: (loadedPackages indexOf: 'Example-Tests-anon.6') > (loadedPackages indexOf: 'Example-Core-anon.17'). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.17'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.6'). platformPackage := loadedPackages detect: [:pkgName | pkgName beginsWith: 'Example-Platform']. self assert: (loadedPackages indexOf: 'Example-Tests-anon.6') > (loadedPackages indexOf: platformPackage). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: platformPackage). self assert: (loadedPackages indexOf: platformPackage) > (loadedPackages indexOf: 'Example-Core-anon.17'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests-project ref' stamp: 'DaleHenrichs 3/11/2010 21:15'! testProjectRef11 | project loadedPackages loader | project := self projectRefProject. loader := (project version: '1.1') load. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 8. self assert: (loadedPackages indexOf: 'Example-Core-anon.15') > 0. self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.15'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Example-Tests-anon.4') > (loadedPackages indexOf: 'Example-Core-anon.15'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.4'). self assert: (loadedPackages indexOf: 'Project-Core-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.15'). self assert: (loadedPackages indexOf: 'Project-Core-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Project-Core-anon.1'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.4'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Example-AddOnTests-anon.1'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 1/2/2010 14:07'! test01 | project versionSpec | project := self project. versionSpec := (project version: '0.1') spec. self assert: (versionSpec packages map includesKey: 'Example-Core'). self assert: (versionSpec packages map at: 'Example-Core') file = 'Example-Core-anon.8'. self assert: versionSpec packages map keys size = 1. self assert: (versionSpec packages map at: 'Example-Core') repositorySpecs first description = 'http://www.example.com/Example'! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/13/2009 15:57'! test11Author | project | project := self project. self assert: ((project version: '1.1') author) = 'dkh'. ! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/17/2009 10:19'! test10a | project versionSpec loadedPackages version loader | project := self project. version := project version: '1.0'. self assert: version blessing == #baseline. versionSpec := version spec. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'. loader := version load. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 2. self assert: (loadedPackages indexOf: 'Example-Core-anon.14') > 0. self assert: (loadedPackages indexOf: 'Example-Tests-anon.3') = 0. self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.14'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') = 0. ! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/17/2009 10:17'! test07 | project versionSpec loadedPackages version loader | project := self project. version := project version: '0.7'. self assert: version blessing == #baseline. versionSpec := version spec. self assert: (versionSpec packages map includesKey: 'Example-Core'). self assert: (versionSpec packages map at: 'Example-Core') file = 'Example-Core-anon.12'. self assert: (versionSpec packages map at: 'Example-Tests') file = 'Example-Tests-anon.3'. self assert: (versionSpec packages map at: 'Example-AddOn') file = 'Example-AddOn-anon.1'. self assert: versionSpec packages map keys size = 3. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'. loader := version load. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 3. self assert: (loadedPackages indexOf: 'Example-Core-anon.12') > 0. self assert: (loadedPackages indexOf: 'Example-Tests-anon.3') > (loadedPackages indexOf: 'Example-Core-anon.12'). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.12'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/13/2009 15:36'! test05 | project versionSpec | project := self project. versionSpec := (project version: '0.5') spec. self assert: (versionSpec packages map includesKey: 'Example-Core'). self assert: (versionSpec packages map at: 'Example-Core') file = 'Example-Core-anon.11'. self assert: (versionSpec packages map at: 'Example-Tests') file = 'Example-Tests-anon.3'. self assert: (versionSpec packages map at: 'Example-AddOn') file = 'Example-AddOn-anon.1'. self assert: versionSpec packages map keys size = 3. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/13/2009 15:59'! test11Descripton | project | project := self project. self assert: ((project version: '1.1') description) = 'Example of a complete version specification'. ! ! !MetacelloTutorialTestCase methodsFor: 'tests-project ref' stamp: 'dkh 07/09/2012 16:17'! testProjectRef14 | project version string | project := self projectRefProject. version := project version: '1.4'. self shouldnt: [ version packages ] raise: Error. self shouldnt: [ version projects ] raise: Error. self shouldnt: [ version groups ] raise: Error. string := (version packageNamed: 'Project-Core') printString. self assert: string = 'spec name: ''Project-Core''; requires: #(''Example Default'' ); includes: #(''Project-Extra'' ); file: ''Project-Core-anon.2''.'. string := (version packageNamed: 'Example Default') printString. self assert: string = 'spec name: ''Example Default''; className: ''MetacelloTutorialConfig''; versionString: ''1.3''; loads: #(''default'' ); file: ''Metacello-Tutorial''; repository: ''http://seaside.gemstone.com/ss/metacello''.'. string := (version packageNamed: 'Core') printString. self assert: string = 'spec name: ''Core''; includes: #(''default'' ).'. self shouldnt: [ (version packageNamed: 'Project-Core') requires ] raise: Error. self assert: ((version packageNamed: 'Example Default') repositoryDescriptions) asArray = #('http://seaside.gemstone.com/ss/metacello'). self shouldnt: [ (version packageNamed: 'default') requires ] raise: Error. self shouldnt: [ version packagesForSpecNamed: 'Core' ] raise: Error. self shouldnt: [ version load: 'Core' ] raise: Error. self shouldnt: [ version allPackagesForSpecNamed: 'Core' ] raise: Error. self shouldnt: [ version load: 'Example Default' ] raise: Error. self shouldnt: [ version allPackagesForSpecNamed: 'Example Default' ] raise: Error. self shouldnt: [ (version packageNamed: 'Example Default') version ] raise: Error! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 1/2/2010 14:07'! test03 | project versionSpec | project := self project. versionSpec := (project version: '0.3') spec. self assert: (versionSpec packages map includesKey: 'Example-Core'). self assert: (versionSpec packages map at: 'Example-Core') file = 'Example-Core-anon.10'. self assert: (versionSpec packages map at: 'Example-Tests') file = 'Example-Tests-anon.3'. self assert: versionSpec packages map keys size = 2. self assert: (versionSpec packages map at: 'Example-Core') repositorySpecs first description = 'http://www.example.com/Example'! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/17/2009 10:20'! test10d | project versionSpec loadedPackages version loader | project := self project. version := project version: '1.0'. self assert: version blessing == #baseline. versionSpec := version spec. self assert: (versionSpec repositories map at: 'http://www.example.com/Example') description = 'http://www.example.com/Example'. loader := version load: { 'Example-Tests'. 'Example-AddOnTests'. }. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 4. self assert: (loadedPackages indexOf: 'Example-Core-anon.14') > 0. self assert: (loadedPackages indexOf: 'Example-Tests-anon.3') > (loadedPackages indexOf: 'Example-Core-anon.14'). self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.14'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.3'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'DaleHenrichs 12/21/2010 11:47'! test12 | project versionSpec | project := self project. versionSpec := (project version: '1.2') spec. self assert: (versionSpec packages map at: 'Example-Core') preLoadDoIt value == #preloadForCore. self assert: (versionSpec packages map at: 'Example-Core') postLoadDoIt value == #postloadForCore:package:. (project version: '1.2') load "execute without error"! ! !MetacelloTutorialTestCase methodsFor: 'private' stamp: 'dkh 10/17/2009 13:18'! projectRefProject ^MetacelloProjectRefTutorialConfig project! ! !MetacelloTutorialTestCase methodsFor: 'tests-project ref' stamp: 'DaleHenrichs 3/11/2010 21:15'! testProjectRef12 | project loadedPackages loader | project := self projectRefProject. loader := (project version: '1.2') load. loadedPackages := loader loadedPackages asArray. self assert: loadedPackages size = 8. self assert: (loadedPackages indexOf: 'Example-Core-anon.16') > 0. self assert: (loadedPackages indexOf: 'Example-AddOn-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.16'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Example-Tests-anon.5') > (loadedPackages indexOf: 'Example-Core-anon.16'). self assert: (loadedPackages indexOf: 'Example-AddOnTests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.5'). self assert: (loadedPackages indexOf: 'Project-Core-anon.1') > (loadedPackages indexOf: 'Example-Core-anon.16'). self assert: (loadedPackages indexOf: 'Project-Core-anon.1') > (loadedPackages indexOf: 'Example-AddOn-anon.1'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Project-Core-anon.1'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Example-Tests-anon.5'). self assert: (loadedPackages indexOf: 'Project-Tests-anon.1') > (loadedPackages indexOf: 'Example-AddOnTests-anon.1'). ! ! !MetacelloTutorialTestCase methodsFor: 'tests' stamp: 'dkh 10/13/2009 15:58'! test11Timestamp | project | project := self project. self assert: ((project version: '1.1') timestamp) = '10/12/2009 09:26'. ! ! !MetacelloValidationCriticalWarning commentStamp: ''! MetacelloValidationCriticalWarning indicates that there is a logical inconsistency that may not be intentional and that could cause incorrect loads! !MetacelloValidationCriticalWarning methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! label ^'Critical Warning'! ! !MetacelloValidationCriticalWarning methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isCriticalWarning ^true! ! !MetacelloValidationError commentStamp: ''! MetacelloValidationError indicates that errors are to be expected if an attempt to use the configuration/version is made! !MetacelloValidationError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! label ^'Error'! ! !MetacelloValidationError methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isError ^true! ! !MetacelloValidationFailure methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! issues: anObject issues := anObject! ! !MetacelloValidationFailure methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! issues ^ issues! ! !MetacelloValidationFailure class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! issues: anObject message: aString ^ self new issues: anObject; signal: aString! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! explanation ^ explanation! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! explanation: aString explanation := aString! ! !MetacelloValidationIssue methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isCritical ^self isError or: [ self isCriticalWarning ]! ! !MetacelloValidationIssue methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isWarning ^false! ! !MetacelloValidationIssue methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isError ^false! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! callSite: anObject callSite := anObject! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! reasonCode reasonCode == nil ifTrue: [ reasonCode := #none ]. ^ reasonCode! ! !MetacelloValidationIssue methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isCriticalWarning ^false! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! configurationClass ^ configurationClass! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! callSite ^ callSite! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! label ^''! ! !MetacelloValidationIssue methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! printOn: aStream aStream nextPutAll: self label; nextPut: $:; space; nextPutAll: self explanation. self reasonCode ~~ #none ifTrue: [ aStream space; nextPut: ${; space; nextPutAll: self reasonCode asString; space; nextPut: $} ]. (self configurationClass ~~ nil or: [ self callSite ~~ nil ]) ifTrue: [ aStream space; nextPut: $[; space. self configurationClass ~~ nil ifTrue: [ aStream nextPutAll: self configurationClass name asString; space ]. self callSite ~~ nil ifTrue: [ aStream nextPutAll: self callSite name asString; space ]. aStream nextPut: $] ]! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! reasonCode: anObject reasonCode := anObject! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! configurationClass: aClass configurationClass := aClass! ! !MetacelloValidationIssue class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! configurationClass: aClass reasonCode: aSymbol callSite: aCallSite explanation: aString ^(self new) configurationClass: aClass; reasonCode: aSymbol; callSite: aCallSite; explanation: aString; yourself! ! !MetacelloValidationNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! issue: anObject issue := anObject! ! !MetacelloValidationNotification methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! issue ^ issue! ! !MetacelloValidationNotification methodsFor: 'signaling' stamp: 'dkh 6/5/2012 19:01:24'! signal: aMetacelloValidationIssue self issue: aMetacelloValidationIssue. ^ self signal! ! !MetacelloValidationNotification class methodsFor: 'exceptioninstantiator' stamp: 'dkh 6/5/2012 19:01:24'! signal: aMetacelloValidationIssue ^ self new signal: aMetacelloValidationIssue! ! !MetacelloValidationWarning commentStamp: ''! MetacelloValidationWarning indicates that there is a logical inconsistency that is not likely to cause any functional problems! !MetacelloValidationWarning methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! label ^'Warning'! ! !MetacelloValidationWarning methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isWarning ^true! ! !MetacelloValueHolderSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! value ^ value! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! setDescriptionInMetacelloVersion: aMetacelloVersionSpec aMetacelloVersionSpec setDescription: self! ! !MetacelloValueHolderSpec methodsFor: 'merging' stamp: 'dkh 6/5/2012 19:01:24'! mergeMap | map | map := super mergeMap. map at: #value put: value. ^map! ! !MetacelloValueHolderSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! value: anObject value := anObject! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! setPreLoadDoItInMetacelloSpec: aMetacelloSpec aMetacelloSpec setPreLoadDoIt: self! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! setAuthorInMetacelloVersion: aMetacelloVersionSpec aMetacelloVersionSpec setAuthor: self! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! setBlessingInMetacelloVersion: aMetacelloVersionSpec aMetacelloVersionSpec setBlessing: self! ! !MetacelloValueHolderSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! value: anObject constructor: aVersionConstructor aVersionConstructor valueForValueHolder: anObject! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! setPostLoadDoItInMetacelloSpec: aMetacelloSpec aMetacelloSpec setPostLoadDoIt: self! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! setTimestampInMetacelloVersion: aMetacelloVersionSpec aMetacelloVersionSpec setTimestamp: self! ! !MetacelloValueHolderSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodOn: aStream indent: indent aStream tab: indent; nextPutAll: 'spec value: ', self value printString! ! !MetacelloValueHolderSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testValueHolderMergeSpec | valueHolderA valueHolderB valueHolder | valueHolderA := self valueHolderSpec value: 'an Object'; yourself. valueHolderB := self valueHolderSpec value: 1.1; yourself. valueHolder := valueHolderA mergeSpec: valueHolderB. self assert: valueHolder value = 1.1! ! !MetacelloValueHolderSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testValueHolderSpec | valueHolder | valueHolder := self valueHolderSpec value: 'an Object'; yourself. self assert: valueHolder value = 'an Object'! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! blessing ^ self basicSpec blessing value! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionNumber: aVersionNumber versionNumber := aVersionNumber! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! description ^ self basicSpec description value! ! !MetacelloVersion methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isSomethingLoaded "at least one project or package has been loaded" ^self spec isSomethingLoaded! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! versionKey "version printString, without the versionStatus decorations, suitable for using as a unique key for the receiver in a dictionary" ^ String streamContents: [ :aStream | | label | self versionNumber printOn: aStream. self basicSpec ~~ nil ifTrue: [ (label := self projectLabel) isEmpty ifFalse: [ aStream nextPutAll: ' [' , label , ']' ] ] ]! ! !MetacelloVersion methodsFor: 'comparing' stamp: 'dkh 6/5/2012 19:01:24'! ~> aMetacelloVersion aMetacelloVersion species = self species ifFalse: [ ^false ]. ^self versionNumber ~> aMetacelloVersion versionNumber! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionStatus versionStatus == nil ifTrue: [ versionStatus := self computeVersionStatus]. ^versionStatus! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 9/11/2012 12:09'! expandToLoadableSpecNames: nameList "Just like #resolveToLoadableSpecs:, but returns list of spec names instead of specs" ^self spec expandToLoadableSpecNames: nameList! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 9/11/2012 10:16'! projects "Answers the list of projects associated with this version" | projects | projects := OrderedCollection new. self spec projectDo: [:prj | projects add: prj projectReference ] packageDo: [:ignored | ] groupDo: [:ignored | ]. ^projects ! ! !MetacelloVersion methodsFor: 'comparing' stamp: 'dkh 6/5/2012 19:01:24'! < aMetacelloVersion aMetacelloVersion species = self species ifFalse: [ ^false ]. ^self versionNumber < aMetacelloVersion versionNumber! ! !MetacelloVersion methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isAllLoadedToSpec "all projects and packages are loaded and match specification" ^self spec isAllLoadedToSpec! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! importedVersions: aCollection importedVersions := aCollection! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! project ^ self basicSpec project! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectLabel ^ self basicSpec projectLabel! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 9/11/2012 10:35'! packageNamed: aString ^self packageNamed: aString ifAbsent: [ ^nil ]. ! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! spec: aMetacellVersionSpec spec := aMetacellVersionSpec! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! versionString ^self versionNumber versionString! ! !MetacelloVersion methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! printOn: aStream | label vs | (#(structural broken) includes: self blessing) not ifTrue: [ (vs := self versionStatus) == #'somethingLoaded' ifTrue: [ aStream nextPutAll: '<>' ]. vs == #'loadedMatchConstraints' ifTrue: [ aStream nextPutAll: '>=' ]. vs == #'loadedToSpec' ifTrue: [ aStream nextPut: $~ ] ]. self versionNumber printOn: aStream. self basicSpec ~~ nil ifTrue: [ (label := self projectLabel) isEmpty ifFalse: [ aStream nextPutAll: ' [' , label , ']' ] ] ! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionStatus: aSymbol versionStatus := aSymbol! ! !MetacelloVersion methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! load ^self subclassResponsibility! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionSpec ^self spec! ! !MetacelloVersion methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! unload ^self spec unload! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! versionNumber ^versionNumber! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 9/11/2012 11:53'! difference: aMetacelloVersion "Return a a dictionary of additions, removals and modifications" ^self spec difference: aMetacelloVersion spec! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! importedVersions importedVersions == nil ifTrue: [ importedVersions := #() ]. ^importedVersions! ! !MetacelloVersion methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isPossibleBaseline ^self spec isPossibleBaseline! ! !MetacelloVersion methodsFor: 'comparing' stamp: 'dkh 6/5/2012 19:01:24'! hash ^self versionNumber hash! ! !MetacelloVersion methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isLoadedMatchConstraints "all loaded projects and packages match constraints" ^self spec isLoadedMatchConstraints! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! loader ^self spec loader! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 9/11/2012 10:35'! packageNamed: aString ifAbsent: aBlock | pkg | (pkg := self spec packageNamed: aString ifAbsent: []) == nil ifTrue: [ ^aBlock value ]. ^pkg referencedSpec! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 9/11/2012 11:40'! resolveToLoadableSpecs: nameList "Resolves names in namelist to the list of packages and projects in the version that would be loaded. Projects are not traversed during the transitive closure. The scope is that of the version itself. If the spec is a package, answer a list including the package and the transitive closure on its #requires: and #includes: fields. If the spec is a project, answer the project. If the spec is a group, answers the list of packages in the #includes: field of the group. Groups in the #includes: field are expanded following the transitive closure on groups" ^self spec resolveToLoadableSpecs: nameList! ! !MetacelloVersion methodsFor: 'private' stamp: 'dkh 9/10/2012 15:43'! computeVersionStatus ^ #'noStatus'! ! !MetacelloVersion methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! load: required ^self subclassResponsibility! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/22/2012 12:38'! versionNumberFrom: aString ^ self versionNumber class fromString: aString! ! !MetacelloVersion methodsFor: 'comparing' stamp: 'dkh 6/5/2012 19:01:24'! = aMetacelloVersion aMetacelloVersion species = self species ifFalse: [ ^false ]. ^self versionNumber = aMetacelloVersion versionNumber! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! author ^self spec author value! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! timestamp ^ self basicSpec timestamp value! ! !MetacelloVersion methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isLoadedToSpec "all loaded projects and packages match specifications" ^self spec isLoadedToSpec! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! basicSpec ^ self spec! ! !MetacelloVersion methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! name ^self versionString! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! spec ^spec! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 9/11/2012 10:16'! groups "Answers the list of groups associated with this version" | groups | groups := OrderedCollection new. self spec projectDo: [:ignored | ] packageDo: [:ignored | ] groupDo: [:grp | groups add: grp ]. ^groups ! ! !MetacelloVersion class methodsFor: 'instance creation' stamp: 'dkh 6/22/2012 12:34'! fromSpec: aMetacelloVersionSpec ^ (self new versionNumber: aMetacelloVersionSpec versionNumber) spec: aMetacelloVersionSpec; yourself! ! !MetacelloVersion class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! fromString: aString ^self new versionNumber: aString asMetacelloVersionNumber! ! !MetacelloVersionConstructor methodsFor: 'deprecated' stamp: 'dkh 6/5/2012 19:01:24'! prepareForMethodUpdate: aConfig sourceVersion: sourceVersionString forceUpdate: forceUpdate generating: generateBlock | pragmaDict versionSpecs pragmaMap updatedPackageSpecs updatedPackageSpecsMap reversed pragmaColl seenUpdatedPackageSpecs | self deprecated: 'see MetacelloToolBox for replacement methods'. self configuration: aConfig. versionSpecs := Dictionary new. pragmaMap := Dictionary new. pragmaDict := self extractAllVersionPragmas. pragmaColl := pragmaDict at: sourceVersionString ifAbsent: [ ^ self ]. pragmaColl do: [ :pragma | | specs versionSpec | specs := Dictionary new. self evaluatePragma: pragma. self attributeMap keysAndValuesDo: [ :attribute :blockList | versionSpec := self project versionSpec. versionSpec versionString: sourceVersionString. specs at: attribute put: versionSpec. blockList do: [ :block | self with: versionSpec during: block ] ]. versionSpecs at: pragma selector put: {specs. (self attributeOrder). nil}. pragmaMap at: pragma selector put: pragma. self reset ]. versionSpecs keysAndValuesDo: [ :selector :ar | updatedPackageSpecsMap := Dictionary new. seenUpdatedPackageSpecs := Dictionary new. ar at: 3 put: updatedPackageSpecsMap. reversed := aConfig project attributes reverse. reversed do: [ :attribute | | vs | (vs := (ar at: 1) at: attribute ifAbsent: [ ]) ~~ nil ifTrue: [ updatedPackageSpecs := forceUpdate ifTrue: [ vs forceUpdatedPackageSpecs ] ifFalse: [ vs updatedPackageSpecs ]. updatedPackageSpecs associations do: [ :assoc | | filename | (filename := seenUpdatedPackageSpecs at: assoc key ifAbsent: [ ]) == nil ifTrue: [ assoc value == #uptodate ifTrue: [ "#uptodate means that the spec is up-to-date and we mark it as seen so that the spec is not update for a 'later' spec" seenUpdatedPackageSpecs at: assoc key put: #uptodate ] ifFalse: [ seenUpdatedPackageSpecs at: assoc key put: assoc value file ] ] ifFalse: [ "if the spec was already seen as up-to-date or the file is the same as the one already seen don't propogate the file" (filename == #uptodate or: [ assoc value == #uptodate or: [ filename = assoc value file ] ]) ifTrue: [ updatedPackageSpecs removeKey: assoc key ] ] ]. updatedPackageSpecsMap at: attribute put: updatedPackageSpecs ] ]. "clear out #uptodate markers" updatedPackageSpecsMap valuesDo: [ :d | d associations do: [ :assoc | assoc value == #uptodate ifTrue: [ d removeKey: assoc key ] ] ]. "remove shadowed packages" 1 to: reversed size do: [ :index | | attribute d | attribute := reversed at: index. ((d := updatedPackageSpecsMap at: attribute ifAbsent: [ ]) ~~ nil and: [ d keys size > 0 ]) ifTrue: [ index + 1 to: reversed size do: [ :shadowIndex | d keysDo: [ :key | | dict | (dict := updatedPackageSpecsMap at: (reversed at: shadowIndex) ifAbsent: [ ]) ~~ nil ifTrue: [ dict removeKey: key ifAbsent: [ ] ] ] ] ] ]. updatedPackageSpecsMap keys do: [ :key | | d | d := updatedPackageSpecsMap at: key. d isEmpty ifTrue: [ updatedPackageSpecsMap removeKey: key ] ]. "ready to generate source for method" generateBlock value: selector value: pragmaMap value: ar value: updatedPackageSpecsMap ]! ! !MetacelloVersionConstructor methodsFor: 'initialization' stamp: 'dkh 6/22/2012 12:43'! calculate: aConfig project: aProject | versionMap symbolicVersionMap executionBlock pragmaDict | self setProject: aProject. self configuration: aConfig. versionMap := Dictionary new. symbolicVersionMap := Dictionary new. executionBlock := self specResolverBlock. self collectAllVersionsFromVersionPragmasInto: versionMap using: executionBlock. pragmaDict := self extractVersionImportPragmas. self verifyVersionImportPragmas: pragmaDict definedIn: versionMap. self collectAllVersionsFromVersionImportPragmasInto: versionMap using: executionBlock satisfiedPragmas: pragmaDict. self collectAllSymbolicVersionsFromVersionPragmasInto: symbolicVersionMap using: self symbolicVersionResolverBlock. self project map: versionMap. self project errorMap: self errorMap. self project symbolicVersionMap: symbolicVersionMap. self project configuration: aConfig. "now that we have a nearly complete project, we can collect the defaultSymbolicVersions, which expect the project to be fully constructed" self collectDefaultSymbolicVersionsFromVersionPragmasFrom: self extractDefaultSymbolicVersionPragmas into: symbolicVersionMap using: self defaultSymbolicVersionResolverBlock. "Pick up defaults from MetacelloBaseConfiguration" self collectDefaultSymbolicVersionsFromVersionPragmasFrom: self extractCommonDefaultSymbolicVersionPragmas into: symbolicVersionMap using: self commonDefaultSymbolicVersionResolverBlock. "now resolive symbolicVersions defined as symbolicVersions" symbolicVersionMap copy keysAndValuesDo: [ :symbolic :original | | versionString visited | versionString := original. visited := Set new. [ visited add: versionString. versionString isSymbol and: [ versionString ~~ #'notDefined' ] ] whileTrue: [ versionString := symbolicVersionMap at: versionString ifAbsent: [ self error: 'Cannot resolve symbolic version ' , original printString ]. (visited includes: versionString) ifTrue: [ self error: 'Loop detected resolving symbolic version ' , original printString ] ]. symbolicVersionMap at: symbolic put: versionString ]! ! !MetacelloVersionConstructor methodsFor: 'initialization' stamp: 'dkh 6/5/2012 19:01:24'! on: aConfig project: aProject | cacheKey cachedProject | cacheKey := aConfig class. cachedProject := MetacelloPlatform current stackCacheFor: #'versionConstructor' at: cacheKey doing: [ :cache | self calculate: aConfig project: aProject. cache at: cacheKey put: self project. ^ self ]. aProject map: cachedProject map. aProject errorMap: cachedProject errorMap. aProject symbolicVersionMap: cachedProject symbolicVersionMap. aProject configuration: aConfig. self setProject: aProject! ! !MetacelloVersionConstructor methodsFor: 'deprecated' stamp: 'dkh 6/5/2012 19:01:24'! spawnPackageMethodIn: aConfig category: methodCategory named: newSelector sourceVersion: sourceVersionString targetVersion: targetVersionString blessing: blessing self deprecated: 'see MetacelloToolBox class>>createBaseline:for:from:description: for replacement method'. self prepareForMethodUpdate: aConfig sourceVersion: sourceVersionString forceUpdate: blessing ~~ #baseline generating: [:selector :pragmaMap :ar :updatedPackageSpecsMap | | strm | strm := WriteStream on: String new. strm nextPutAll: newSelector asString, ' spec'; cr; tab; nextPutAll: '';cr. (ar at: 2) do: [:attribute | | vs d | vs := (ar at: 1) at: attribute. (d := updatedPackageSpecsMap at: attribute ifAbsent: []) ~~ nil ifTrue: [ vs packagesSpec list do: [:member | | x | x := d at: member spec name ifAbsent: []. member spec updateForSpawnMethod: x ]] ifFalse: [ vs packagesSpec list do: [:member | member spec updateForSpawnMethod: member spec copy ]]. strm cr; tab; nextPutAll: 'spec for: ', attribute printString, ' do: ['; cr. attribute == #common ifTrue: [ vs author: MetacelloPlatform current authorName; timestamp: MetacelloPlatform current timestamp. blessing ~~ nil ifTrue: [ vs blessing: blessing ]]. vs configSpawnMethodOn: strm indent: 2. strm nextPutAll: '].']. (aConfig class compile: strm contents classified: methodCategory) == nil ifTrue: [ self error: 'Error compiling the method' ]]. ^true ! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! symbolicVersionResolverBlock ^ [ :symbolicVrsn :pragma | | result | result := nil. (pragma argumentAt: 1) = symbolicVrsn ifTrue: [ self symbolicVersion: symbolicVrsn. self evaluatePragma: pragma. self project attributes do: [ :attribute | | versionString | versionString := self attributeMap at: attribute ifAbsent: [ ]. versionString ~~ nil ifTrue: [ result := versionString ] ] ]. result ]! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! collectAllVersionsFromVersionPragmasInto: versionMap using: executionBlock | defined versionPragmaDict | versionPragmaDict := self extractVersionPragmas. versionPragmaDict keysAndValuesDo: [ :versionString :pragmaColl | | versionSpec | versionSpec := self project versionSpec. versionSpec versionString: versionString. defined := false. [ pragmaColl do: [ :pragma | executionBlock value: versionSpec value: pragma. defined := true ] ] on: Error do: [ :ex | (MetacelloErrorInProjectConstructionNotification versionString: versionSpec versionString exception: ex) ifTrue: [ ^ ex pass ] ifFalse: [ self errorMap at: versionSpec versionString put: ex. defined := false ] ]. defined ifTrue: [ self validateVersionString: versionString againstSpec: versionSpec. versionMap at: versionSpec versionString put: versionSpec createVersion ]. self reset ]! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! defaultSymbolicVersionResolverBlock: receiver ^ [ :symbolicVrsn :pragma | | result | result := nil. (pragma argumentAt: 1) = symbolicVrsn ifTrue: [ self symbolicVersion: symbolicVrsn. result := [ receiver perform: pragma selector ] on: MetacelloVersionDoesNotExistError do: [ :ex | ex return: nil ] ]. result ]! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'dkh 9/6/2012 03:05'! collectAllVersionsFromVersionImportPragmasInto: versionMap using: executionBlock satisfiedPragmas: pragmaDict | defined done completed count | done := false. completed := IdentitySet new. count := 0. [ count := count + 1. count > 10000 ifTrue: [ self error: 'Apparent loop in import expansion' ]. done ] whileFalse: [ done := true. pragmaDict keysAndValuesDo: [ :versionString :pragmaColl | | versionSpec | versionSpec := nil. defined := false. [ pragmaColl do: [ :pragma | (completed includes: pragma) ifFalse: [ | imports | done := false. imports := pragma argumentAt: 2. imports detect: [ :importedVersion | (versionMap includesKey: importedVersion) not ] ifNone: [ imports do: [ :importedVersion | | version | (version := versionMap at: importedVersion ifAbsent: [ ]) ~~ nil ifTrue: [ defined := true. completed add: pragma. versionSpec == nil ifTrue: [ versionSpec := version spec copy ] ifFalse: [ versionSpec := versionSpec mergeSpec: version spec copy ]. versionSpec versionString: versionString. executionBlock value: versionSpec value: pragma ] ] ] ] ] ] on: Error do: [ :ex | (MetacelloErrorInProjectConstructionNotification versionString: versionSpec versionString exception: ex) ifTrue: [ ^ ex pass ] ifFalse: [ self errorMap at: versionSpec versionString put: ex. done := true. defined := false ] ]. defined ifTrue: [ | version importedVersions | importedVersions := OrderedCollection new. version := versionSpec createVersion. pragmaColl do: [ :pragma | importedVersions addAll: (pragma argumentAt: 2) ]. version importedVersions: importedVersions. self validateVersionString: versionString againstSpec: versionSpec. versionMap at: versionSpec versionString put: version ]. self reset ] ]! ! !MetacelloVersionConstructor methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! errorMap errorMap ifNil: [ errorMap := Dictionary new ]. ^ errorMap! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! verifyVersionImportPragmas: pragmaDict definedIn: versionMap pragmaDict copy keysAndValuesDo: [ :versionString :pragmaColl | [ pragmaColl do: [ :pragma | (pragma argumentAt: 2) do: [ :importedVersion | versionMap at: importedVersion ifAbsent: [ pragmaDict at: importedVersion ifAbsent: [ ^ self error: 'The imported version:' , importedVersion printString , ' for version: ' , versionString , ' referenced from the method: ' , pragma selector printString , ' in configuration ' , configuration class printString , ' has not been defined.' ] ] ] ] ] on: Error do: [ :ex | (MetacelloErrorInProjectConstructionNotification versionString: versionString exception: ex) ifTrue: [ ^ ex pass ] ifFalse: [ pragmaDict removeKey: versionString. self errorMap at: versionString put: ex ] ] ]! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! collectAllSymbolicVersionsFromVersionPragmasInto: symbolicVersionMap using: executionBlock | defined versionPragmaDict versionString | versionPragmaDict := self extractSymbolicVersionPragmas. versionPragmaDict keysAndValuesDo: [ :versionSymbol :pragmaColl | defined := false. pragmaColl do: [ :pragma | defined := true. versionString := executionBlock value: versionSymbol value: pragma ]. defined ifTrue: [ versionString == nil ifFalse: [ symbolicVersionMap at: versionSymbol put: versionString ]]. self reset ]! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! commonDefaultSymbolicVersionResolverBlock ^ self defaultSymbolicVersionResolverBlock: (ConfigurationOf new project: self project) ! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! defaultSymbolicVersionResolverBlock ^ self defaultSymbolicVersionResolverBlock: self configuration ! ! !MetacelloVersionConstructor methodsFor: 'initialization' stamp: 'dkh 6/5/2012 19:01:24'! on: aConfig | cacheKey | cacheKey := aConfig class. project := MetacelloPlatform current stackCacheFor: #versionConstructor at: cacheKey doing: [ :cache | self calculate: aConfig project: nil. cache at: cacheKey put: self project ]. self setProject: project.! ! !MetacelloVersionConstructor methodsFor: 'deprecated' stamp: 'dkh 6/5/2012 19:01:24'! updatePackageMethodIn: aConfig sourceVersion: sourceVersionString self deprecated: 'see MetacelloToolBox class>>updateDevelopment:for:updateProjects:description: for replacement method'. self prepareForMethodUpdate: aConfig sourceVersion: sourceVersionString forceUpdate: false generating: [:selector :pragmaMap :ar :updatedPackageSpecsMap | | strm pragma | updatedPackageSpecsMap isEmpty ifTrue: [ ^false ]. strm := WriteStream on: String new. strm nextPutAll: selector asString, ' spec'; cr; tab; nextPutAll: '';cr. (ar at: 2) do: [:attribute | | vs d | vs := (ar at: 1) at: attribute. (d := updatedPackageSpecsMap at: attribute ifAbsent: []) ~~ nil ifTrue: [ vs packagesSpec list do: [:member | member spec file ~~ nil ifTrue: [ | x | (((x := d at: member spec name ifAbsent: []) ~~ nil) and: [ x ~~ #uptodate ]) ifTrue: [ member spec file: x file ]]]]. strm cr; tab; nextPutAll: 'spec for: ', attribute printString, ' do: ['; cr. attribute == #common ifTrue: [ vs author: MetacelloPlatform current authorName; timestamp: MetacelloPlatform current timestamp ]. vs configMethodOn: strm indent: 2. strm nextPutAll: '].']. (aConfig class compile: strm contents classified: (aConfig class whichCategoryIncludesSelector: pragma selector)) == nil ifTrue: [ self error: 'Error compiling the method' ]]. ^true ! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! specResolverBlock ^ [ :versionSpec :pragma | (pragma argumentAt: 1) = versionSpec versionString ifTrue: [ self evaluatePragma: pragma. self project attributes do: [ :attribute | | blockList | (blockList := self attributeMap at: attribute ifAbsent: [ ]) ~~ nil ifTrue: [ blockList do: [ :block | self with: versionSpec during: block ] ] ] ] ]! ! !MetacelloVersionConstructor methodsFor: 'validation' stamp: 'dkh 6/5/2012 19:01:24'! validateVersionString: versionString againstSpec: versionSpec versionString = versionSpec versionString ifFalse: [ MetacelloValidationNotification signal: (MetacelloValidationError configurationClass: self configurationClass reasonCode: #incorrectVersionString callSite: #validateVersionString:againstSpec explanation: 'The version declared in the pragma ', versionString printString , ' does not match the version in the spec ' , versionSpec versionString printString) ]. ! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! collectDefaultSymbolicVersionsFromVersionPragmasFrom: versionPragmaDict into: symbolicVersionMap using: executionBlock | defined versionString | versionPragmaDict keysAndValuesDo: [ :versionSymbol :pragmaColl | defined := false. symbolicVersionMap at: versionSymbol ifAbsent: [ "process the defaultSymbolicVersion only if the symbolicVersion is not defined yet" pragmaColl do: [ :pragma | defined := true. versionString := executionBlock value: versionSymbol value: pragma ]. defined ifTrue: [ versionString == nil ifFalse: [ symbolicVersionMap at: versionSymbol put: versionString ] ]. self reset ] ]! ! !MetacelloVersionConstructor class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! on: aConfig ^(self new) on: aConfig; yourself! ! !MetacelloVersionConstructor class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! on: aConfig project: aProject ^(self new) on: aConfig project: aProject; yourself! ! !MetacelloVersionConstructor class methodsFor: 'deprecated' stamp: 'dkh 6/5/2012 19:01:24'! spawnPackageMethodIn: aConfig category: methodCategory named: newSelector sourceVersion: sourceVersionString targetVersion: targetVersionString blessing: blessing self deprecated: 'see MetacelloToolBox class>>createDevelopment:for:importFromBaseline:description: for a similar example'. ^self new spawnPackageMethodIn: aConfig category: methodCategory named: newSelector sourceVersion: sourceVersionString targetVersion: targetVersionString blessing: blessing! ! !MetacelloVersionConstructor class methodsFor: 'deprecated' stamp: 'dkh 6/5/2012 19:01:24'! updatePackageMethodIn: aConfig sourceVersion: sourceVersionString self deprecated: 'see MetacelloToolBox class>>updateDevelopment:for:updateProjects:description: for a similar example'. ^self new updatePackageMethodIn: aConfig sourceVersion: sourceVersionString! ! !MetacelloVersionConstructor class methodsFor: 'deprecated' stamp: 'dkh 6/5/2012 19:01:24'! spawnPackageMethodIn: aConfig named: newSelector sourceVersion: sourceVersionString targetVersion: targetVersionString blessing: blessing self deprecated: 'see MetacelloToolBox class>>createDevelopment:for:importFromBaseline:description: for a similar example'. ^self new spawnPackageMethodIn: aConfig category: 'versions' named: newSelector sourceVersion: sourceVersionString targetVersion: targetVersionString blessing: blessing! ! !MetacelloVersionConstructor class methodsFor: 'deprecated' stamp: 'dkh 6/5/2012 19:01:24'! spawnPackageMethodIn: aConfig named: newSelector sourceVersion: sourceVersionString targetVersion: targetVersionString self deprecated: 'see MetacelloToolBox class>>createDevelopment:for:importFromBaseline:description: for a similar example'. ^self spawnPackageMethodIn: aConfig category: 'versions' named: newSelector sourceVersion: sourceVersionString targetVersion: targetVersionString blessing: #development! ! !MetacelloVersionDefinitionError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! exception: anObject exception := anObject! ! !MetacelloVersionDefinitionError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! exception ^ exception! ! !MetacelloVersionDefinitionError methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! description "Return a textual description of the exception." ^ 'The version ' , self versionString printString , ' is not defined in ' , self project label , ' for the current platform, because an exception occurred while creating the version:. ' , self exception description , '. Evaluate the following to see the error: ''[' , self project configuration class name asString , ' project ] on: MetacelloErrorInProjectConstructionNotification do: [:ex | ex resume: true ].''' , ' Possible versions include: ' , self possibleVersions printString! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! modifications: anObject modifications := anObject! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! to: anObject to := anObject! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! from ^ from! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! configuration ^ configuration! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! modifications modifications ifNil: [ modifications := Dictionary new ]. ^ modifications! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! configuration: anObject configuration := anObject! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! from: anObject from := anObject! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! removals removals ifNil: [ removals := Dictionary new ]. ^ removals! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! additions: anObject additions := anObject! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! removals: anObject removals := anObject! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! to ^ to! ! !MetacelloVersionDiffReport methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! additions additions ifNil: [ additions := Dictionary new ]. ^ additions! ! !MetacelloVersionDiffReport methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! printOn: aStream | printBlock | printBlock := [ :pkgName :ar | aStream tab: 2; nextPutAll: pkgName asString; cr. aStream tab: 3; nextPutAll: (ar at: 1) asString printString; nextPutAll: ' to '; nextPutAll: (ar at: 2) asString printString; cr ]. aStream nextPutAll: self configuration asString; space; nextPutAll: from asString printString; nextPutAll: ' to '; nextPutAll: to asString printString; cr. aStream tab; nextPutAll: 'Additions:'; cr. self additions keysAndValuesDo: printBlock. aStream tab; nextPutAll: 'Modifications:'; cr. self modifications keysAndValuesDo: printBlock. aStream tab; nextPutAll: 'Removals:'; cr. self removals keysAndValuesDo: printBlock! ! !MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! possibleVersions ^ self project symbolicVersionSymbols , (self project versions collect: [ :each | each versionString ])! ! !MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! project ^ project! ! !MetacelloVersionDoesNotExistError methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! description "Return a textual description of the exception." ^ 'Version ' , self versionString printString , ' is not defined in ' , self project label , '. Possible versions include: ' , self possibleVersions printString! ! !MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString ^ versionString! ! !MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! project: anObject project := anObject! ! !MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString: anObject versionString := anObject! ! !MetacelloVersionDoesNotExistError class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! project: aMetacelloProject versionString: aVersionString ^(self new) project: aMetacelloProject; versionString: aVersionString; yourself! ! !MetacelloVersionLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! finalizeLoad: aGofer "nothing special for linear loads"! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! directivesDo: aBlock aBlock value: self. self loadDirectives do: [:directive | directive directivesDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadDirectives loadDirectives == nil ifTrue: [ loadDirectives := OrderedCollection new ]. ^ loadDirectives! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! prepostLoadDirectivesDo: aBlock self loadDirectives do: [:directive | directive prepostLoadDirectivesDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! loadPreloadDirective: aPreloadDirective | block | (block := aPreloadDirective spec preLoadDoItBlock) ~~ nil ifTrue: [ aPreloadDirective evaluateSupplyingAnswers: [ block valueWithPossibleArgs: (Array with: aPreloadDirective loader with: aPreloadDirective spec) ]. Transcript cr; show: 'Evaluated -> ', aPreloadDirective spec label, ' >> ', aPreloadDirective spec preLoadDoIt value asString]! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! versionDirectivesDepthFirstDo: aBlock self loadDirectives do: [:directive | directive versionDirectivesDepthFirstDo: aBlock ]. aBlock value: self. ! ! !MetacelloVersionLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! add: aDirective self loadDirectives add: aDirective! ! !MetacelloVersionLoadDirective methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! loadPackageDirective: aPackageLoadDirective gofer: aGofer aPackageLoadDirective loader loadingSpecLoader loadPackageDirective: aPackageLoadDirective gofer: aGofer! ! !MetacelloVersionLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadAtomicLoadDirective: aLoaderDirective gofer: aGofer aLoaderDirective loadDirectives do: [:directive | directive loadUsing: aLoaderDirective gofer: aGofer ]. aLoaderDirective finalizeLoad: aGofer.! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! versionDirectivesDo: aBlock aBlock value: self. self loadDirectives do: [:directive | directive versionDirectivesDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! packagesDo: aBlock self loadDirectives do: [:directive | directive packageDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! versionDo: aBlock aBlock value: self. ! ! !MetacelloVersionLoadDirective methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! printOn: aStream indent: indent super printOn: aStream indent: indent. self printLoadDirectivesOn: aStream indent: indent! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! versionsDo: aBlock self loadDirectives do: [:directive | directive versionDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'loading' stamp: 'dkh 6/8/2012 14:04:22'! loadPostloadDirective: aPostloadDirective | block | (block := aPostloadDirective spec postLoadDoItBlock) ~~ nil ifTrue: [ aPostloadDirective evaluateSupplyingAnswers: [ block valueWithPossibleArgs: (Array with: aPostloadDirective loader with: aPostloadDirective spec) ]. Transcript cr; show: 'Evaluated -> ', aPostloadDirective spec label, ' >> ', aPostloadDirective spec postLoadDoIt value asString]! ! !MetacelloVersionLoadDirective methodsFor: 'testing' stamp: 'dkh 6/8/2012 14:04:22'! isExplicit ^false! ! !MetacelloVersionLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadExplicitLoadDirective: aLoaderDirective gofer: aGofer "load has already been performed, no need to load again"! ! !MetacelloVersionLoadDirective methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! printLoadDirectivesOn: aStream indent: indent self loadDirectives do: [:each | aStream cr. each printOn: aStream indent: indent + 1 ].! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! packageDirectivesDo: aBlock self loadDirectives do: [:directive | directive packageDirectivesDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'printing' stamp: 'dkh 6/8/2012 14:04:22'! label self spec == nil ifTrue: [ ^'' ]. ^self spec label! ! !MetacelloVersionLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadLinearLoadDirective: aLoaderDirective gofer: aGofer aLoaderDirective loadDirectives do: [:directive | directive loadUsing: aLoaderDirective gofer: aGofer ]. aLoaderDirective finalizeLoad: aGofer.! ! !MetacelloVersionLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! loadDirectives: anObject loadDirectives := anObject! ! !MetacelloVersionLoadDirective methodsFor: 'actions' stamp: 'dkh 6/8/2012 14:04:22'! loadWithPolicy: aLoadPolicy | gofer | gofer := MetacelloGofer new. gofer disablePackageCache. gofer repository: aLoadPolicy cacheRepository. self loadUsing: self gofer: gofer! ! !MetacelloVersionLoadDirective methodsFor: 'accessing' stamp: 'dkh 6/8/2012 14:04:22'! spec "Expected to be a MetacelloVersionSpec" (spec == nil and: [ self loader ~~ nil ]) ifTrue: [ ^[ self loader spec versionSpec ] on: MessageNotUnderstood do: [:ex | ex return: self loader spec ]]. ^spec! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'dkh 6/8/2012 14:04:22'! prepostLoadsDo: aBlock self loadDirectives do: [:directive | directive prepostLoadDo: aBlock ].! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 9/7/2012 13:54'! attributePath | path | path := MetacelloMethodSectionPath with: self attributes. ^ self parent == nil ifTrue: [ path ] ifFalse: [ self parent attributePath , path ]! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! parent: anObject parent := anObject! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! addMethodSection: methodSection methodSection parent: self. self methodSections add: methodSection! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 03/12/2013 20:14'! printOn: aStream aStream nextPutAll: self class name asString; nextPut: $(. self versionSpec printOn: aStream. aStream nextPut: $)! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 9/8/2012 06:02'! attributeOrPath ^ self parent == nil ifTrue: [ self attributes size == 1 ifTrue: [ self attributes first ] ifFalse: [ self attributes ] ] ifFalse: [ self attributePath ]! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! block ^ block! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! parent ^ parent! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionSpec ^ versionSpec! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! topParent self parent == nil ifTrue: [ ^ self ]. ^ self parent topParent! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! methodSections methodSections ifNil: [ methodSections := OrderedCollection new ]. ^methodSections! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionSpec: anObject versionSpec := anObject! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! block: anObject block := anObject! ! !MetacelloVersionMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! imports imports == nil ifTrue: [ imports := #() ]. ^ imports! ! !MetacelloVersionMethodSpec methodsFor: 'method generation' stamp: 'dkh 9/7/2012 07:03'! methodSource | strm | strm := WriteStream on: String new. self methodSelectorAndPragma: self selector imports: self imports versionString: self versionString on: strm. self methodSection: self pre: [ :methodSection :indent | strm cr; tab: indent; nextPutAll: 'spec for: ' , methodSection attributePrintString , ' do: ['; cr. methodSection versionSpec configMethodOn: strm last: methodSection methodSections isEmpty indent: indent + 1 ] last: false post: [ :methodSection :indent :last | strm nextPutAll: ' ].'. (last or: [ indent = 1 or: [ methodSection methodSections isEmpty and: [ indent = 1 ] ] ]) ifTrue: [ strm cr ] ] indent: 0. ^ strm contents! ! !MetacelloVersionMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! imports: anObject imports := anObject! ! !MetacelloVersionMethodSpec methodsFor: 'adding' stamp: 'dkh 9/8/2012 05:10'! findMethodSection: attributeOrPath sectionIndex: sectionIndex | attributePath index sections found | attributePath := attributeOrPath asMetacelloAttributePath. index := 1. sections := self methodSections. found := true. [ found ] whileTrue: [ found := false. sections do: [ :ms | ms attributes = (attributePath at: index) ifTrue: [ index == attributePath size ifTrue: [ ^ ms ]. sections := ms methodSections. index := index + 1. found := true ] ] ]. self error: 'Method section for attribute: ' , attributePath printString , ' not found.'! ! !MetacelloVersionMethodSpec methodsFor: 'method generation' stamp: 'dkh 6/5/2012 19:01:24'! methodSelectorAndPragma: aSelector imports: importList versionString: aString on: strm strm nextPutAll: aSelector asString , ' spec'; cr; tab; nextPutAll: ''; cr! ! !MetacelloVersionMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString: aStringOrSymbol aStringOrSymbol isSymbol ifTrue: [ self error: 'Version string ', aStringOrSymbol printString, ' for version method must be a String' ]. super versionString: aStringOrSymbol! ! !MetacelloVersionMethodSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! methodSection: methodSection pre: preBlock last: last post: postBlock indent: indent | list | methodSection ~~ self ifTrue: [ preBlock value: methodSection value: indent ]. list := methodSection methodSections. 1 to: list size do: [ :index | | ms | ms := list at: index. self methodSection: ms pre: preBlock last: index ~= list size post: postBlock indent: indent + 1 ]. methodSection ~~ self ifTrue: [ postBlock value: methodSection value: indent value: last ]! ! !MetacelloVersionMethodSpec methodsFor: 'adding' stamp: 'dkh 9/8/2012 05:47'! addMethodSection: attributePath versionSpec: versionSpec | attributeList methodSection index sections found | attributeList := attributePath last. methodSection := MetacelloVersionMethodSection new attributes: attributeList; versionSpec: versionSpec; yourself. attributePath size > 1 ifTrue: [ index := 1. sections := self methodSections. found := true. [ found ] whileTrue: [ found := false. sections do: [ :ms | ms attributes = (attributePath at: index) ifTrue: [ index == (attributePath size -1) ifTrue: [ ms methodSections add: methodSection. ^ self ]. sections := ms methodSections. index := index + 1. found := true ] ] ]. self error: 'Method section for attribute: ' , (attributePath at: index) printString , ' not found.' ] ifFalse: [ self methodSections add: methodSection ]! ! !MetacelloVersionNumber commentStamp: 'dkh 6/22/2012 12:00'! # Metacello version format Thanks to [Mozilla Toolkit version format](https://developer.mozilla.org/en/Toolkit_version_format) for inspiration. ##Version Format A version string consists of one or more version parts, separated with dots or dashes. A version part with a leading dot is numeric. A version part with a leading dash is string. The rationale behind splitting a version part into a sequence of strings and numbers is that when comparing version parts, the numeric parts are compared as numbers, e.g. '1.0-pre.1' < '1.0-pre.10', while the strings are compared bytewise. See the next section for details on how versions are compared. ##Comparing versions When two version strings are compared, their version parts are compared left to right. Empty parts are ignored. If at some point a version part of one version string is greater than the corresponding version part of another version string, then the first version string is greater than the other one. If a version string has extra parts and the common parts are equal, the shorter version string is less than the longer version string (1.0 is less than 1.0.0). Otherwise, the version strings are equal. ##Comparing version parts Version parts are also compared left to right, A string-part that exists is always less-then a nonexisting string-part (1.6-a is less than 1.6). Examples ``` 1 == 1. < 1.0 == 1..--0 < 1.1-a < 1.1-aa < 1.1-ab < 1.1-b < 1.1-c < 1.1-pre < 1.1-pre.0 < 1.1-pre.1-a < 1.1-pre.1-aa < 1.1-pre.1-b < 1.1-pre.1 < 1.1-pre.2 < 1.1-pre.10 < 1.1 < 1.1.0 < 1.1.00 < 1.10 < 2.0 ```! !MetacelloVersionNumber methodsFor: 'copying' stamp: 'dkh 6/5/2012 19:01:24'! copyFrom: start to: stop "Answer a copy of a subset of the receiver, starting from element at index start until element at index stop." | newSize new j | newSize := stop - start + 1. new := self species new: newSize. j := 0. start to: stop do: [:i | new at: j + 1 put: (self at: i). j := j + 1 ]. ^new! ! !MetacelloVersionNumber methodsFor: 'enumerating' stamp: 'dkh 6/5/2012 19:01:24'! do: elementBlock separatedBy: separatorBlock "Evaluate the elementBlock for all elements in the receiver, and evaluate the separatorBlock between." | beforeFirst | beforeFirst := true. self do: [:each | beforeFirst ifTrue: [beforeFirst := false] ifFalse: [separatorBlock value]. elementBlock value: each]! ! !MetacelloVersionNumber methodsFor: 'comparing' stamp: 'dkh 6/5/2012 19:01:24'! hash "Returns a numeric hash key for the receiver." | mySize interval hashValue | (mySize := self size) == 0 ifTrue: [ ^15243 ]. "Choose an interval so that we sample at most 5 elements of the receiver" interval := ((mySize - 1) // 4) max: 1. hashValue := 4459. 1 to: mySize by: interval do: [ :i | | anElement | anElement := self at: i. (anElement isKindOf: SequenceableCollection) ifTrue: [ hashValue := (hashValue bitShift: -1) bitXor: anElement size. ] ifFalse: [ hashValue := (hashValue bitShift: -1) bitXor: anElement hash. ]. ]. ^ hashValue abs ! ! !MetacelloVersionNumber methodsFor: 'operations' stamp: 'dkh 6/5/2012 19:01:24'! decrementMinorVersionNumber | int | self size to: 1 by: -1 do: [ :index | (int := self at: index) isString ifFalse: [ int > 0 ifTrue: [ self at: index put: int - 1 ]. ^ self ] ]! ! !MetacelloVersionNumber methodsFor: 'comparing' stamp: 'dkh 6/5/2012 19:01:24'! ~> aMetacelloVersionNumber aMetacelloVersionNumber size == 1 ifTrue: [ ^false ]. ^self >= aMetacelloVersionNumber and: [ self < aMetacelloVersionNumber approximateBase ]! ! !MetacelloVersionNumber methodsFor: 'operations' stamp: 'dkh 6/5/2012 19:01:24'! incrementMinorVersionNumber | int | self size to: 1 by: -1 do: [:index | (int := self at: index) isString ifFalse: [ self at: index put: int + 1. ^self ]].! ! !MetacelloVersionNumber methodsFor: 'comparing' stamp: 'dkh 6/5/2012 19:01:24'! < aMetacelloVersionNumber | condensed aCondensed | aMetacelloVersionNumber species = self species ifFalse: [ ^ false ]. condensed := self collapseZeros. aCondensed := aMetacelloVersionNumber collapseZeros. (condensed ~~ self or: [ aCondensed ~~ aMetacelloVersionNumber ]) ifTrue: [ ^ condensed compareLessThan: aCondensed ]. ^ self compareLessThan: aMetacelloVersionNumber! ! !MetacelloVersionNumber methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! compareLessThan: aMetacelloVersionNumber | mySize aSize commonSize count more | mySize := self size. aSize := aMetacelloVersionNumber size. commonSize := mySize min: aSize. count := 0. more := true. [ more and: [ count < commonSize ]] whileTrue: [ (self at: count + 1) = (aMetacelloVersionNumber at: count + 1) ifTrue: [ count := count + 1 ] ifFalse: [ more := false ]]. count < commonSize ifTrue: [ ^(self at: count + 1) metacelloVersionComponentLessThan: (aMetacelloVersionNumber at: count + 1) ]. mySize < aSize ifTrue: [ mySize = 0 ifTrue: [ ^true ]. "if the versions at commonSize are equal and the next version slot in aMetacelloVersionNumber is a string, then it's considered that I'm > aMetacelloVersionNumber (i.e., '2.9.9' is greater than '2.9.9-alpha.2')" (self at: commonSize) = (aMetacelloVersionNumber at: commonSize) ifFalse: [ ^true ]. ^(aMetacelloVersionNumber at: commonSize+1) isString not] ifFalse: [ mySize = aSize ifTrue: [ ^false ]. aSize <= 0 ifTrue: [ ^false ]. "if the versions at commonSize are equal and the next version slot is a string, then it's considered that I'm < aMetacelloVersionNumber (i.e., '2.9.9-alpha.2' is less than '2.9.9')" (self at: commonSize) = (aMetacelloVersionNumber at: commonSize) ifFalse: [ ^false ]. ^(self at: commonSize+1) isString] ! ! !MetacelloVersionNumber methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! collapseZeros "the rule must be that zeros can be collapsed as long as the series of zeros ends in a string term" | collection newSize new j lastElementIsStringOrZero canCollapse | (self size = 0 or: [ self at: 1 ]) == 0 ifTrue: [ ^ self ]. collection := OrderedCollection new. lastElementIsStringOrZero := true. canCollapse := true. self size to: 1 by: -1 do: [ :i | | element | element := self at: i. (canCollapse and: [ element == 0 ]) ifTrue: [ lastElementIsStringOrZero ifFalse: [ canCollapse := false. collection addFirst: element.]] ifFalse: [ collection addFirst: element. canCollapse := lastElementIsStringOrZero := element isString ] ]. collection size = self size ifTrue: [ ^ self ]. newSize := collection size. new := self species new: newSize. j := 0. collection do: [ :element | new at: j + 1 put: element. j := j + 1 ]. ^ new! ! !MetacelloVersionNumber methodsFor: 'comparing' stamp: 'dkh 6/5/2012 19:01:24'! match: aVersionPattern "Answer whether the version number of the receiver matches the given pattern string. A Metacello version number is made up of version sequences delimited by the characters $. and $-. The $. introduces a numeric version sequence and $- introduces an alphanumeric version sequence. A version pattern is made up of version pattern match sequences. also delimited by the characters $. and $-.. Each pattern match sequence is tested against the corresponding version sequence of the receiver, using the 'standard' pattern matching rules. All sequences must answer true for a match. The special pattern sequence '?' is a match for the corresponding version sequence and all subsequent version sequences. '?' as the version pattern matches all versions. No more version pattern sequences are permitted once the '?' sequence is used. If used, it is the last version pattern sequence. " | patternVersion mySize patternSize | patternVersion := aVersionPattern asMetacelloVersionNumber. mySize := self size. patternSize := patternVersion size. mySize = patternSize ifFalse: [ mySize < patternSize ifTrue: [ ^false ]. (patternVersion at: patternSize) ~= '?' ifTrue: [ ^false ]. mySize := patternSize ]. 1 to: mySize do: [:i | | pattern | pattern := (patternVersion at: i) asString. pattern = '?' ifTrue: [i = mySize ifFalse: [ ^self error: 'Invalid version match pattern: ', aVersionPattern printString ]] ifFalse: [ (pattern match: (self at: i) asString) ifFalse: [ ^false ]]]. ^true " '1.1.1' asMetacelloVersionNumber match: '*.*.*'. -> true '1.1.1' asMetacelloVersionNumber match: '*.#.*'. -> true '1.10.1' asMetacelloVersionNumber match: '*.#.*'. -> false '1.1.1' asMetacelloVersionNumber match: '*.*'. -> false '1.1.1' asMetacelloVersionNumber match: '*.?'. -> true '1.0' asMetacelloVersionNumber match: '1.?'. -> true '2.0' asMetacelloVersionNumber match: '1.?'. -> false '1.1.1' asMetacelloVersionNumber match: '?'. -> true '1' asMetacelloVersionNumber match: '*.?'. -> false '1-alpha5.0' asMetacelloVersionNumber match: '1-alpha*.?'. -> true '1-alpha15.0.1' asMetacelloVersionNumber match: '1-alpha*.?'. -> true '1.1' asMetacelloVersionNumber match: '?.?'. -> ERROR: invalid version match pattern " ! ! !MetacelloVersionNumber methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString | strm | strm := WriteStream on: String new. self printOn: strm. ^strm contents! ! !MetacelloVersionNumber methodsFor: 'comparing' stamp: 'dkh 6/5/2012 19:01:24'! = aMetacelloVersionNumber | condensed aCondensed | aMetacelloVersionNumber species = self species ifFalse: [ ^ false ]. condensed := self collapseZeros. aCondensed := aMetacelloVersionNumber collapseZeros. (condensed ~~ self or: [ aCondensed ~~ aMetacelloVersionNumber ]) ifTrue: [ ^ condensed compareEqualTo: aCondensed ]. ^ self compareEqualTo: aMetacelloVersionNumber! ! !MetacelloVersionNumber methodsFor: 'converting' stamp: 'dkh 6/5/2012 19:01:24'! asMetacelloVersionNumber ^self! ! !MetacelloVersionNumber methodsFor: 'enumerating' stamp: 'dkh 6/5/2012 19:01:24'! do: aBlock "Refer to the comment in Collection|do:." 1 to: self size do: [:index | aBlock value: (self at: index)]! ! !MetacelloVersionNumber methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! compareEqualTo: aMetacelloVersionNumber | mySize | aMetacelloVersionNumber species = self species ifFalse: [ ^false ]. mySize := self size. mySize = aMetacelloVersionNumber size ifFalse: [ ^false ]. 1 to: mySize do: [:i | (self at: i) = (aMetacelloVersionNumber at: i) ifFalse: [ ^false ]]. ^true! ! !MetacelloVersionNumber methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! printOn: aStream | beforeFirst | beforeFirst := true. self do: [:each | beforeFirst ifTrue: [beforeFirst := false] ifFalse: [ each isString ifTrue: [ aStream nextPut: $- ] ifFalse: [ aStream nextPut: $. ] ]. aStream nextPutAll: each asString ] ! ! !MetacelloVersionNumber methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! approximateBase | base | base := self copyFrom: 1 to: self size - 1. base at: base size put: (base at: base size) + 1. ^base! ! !MetacelloVersionNumber methodsFor: 'printing' stamp: 'dkh 07/09/2012 16:15'! asString "Answer a string that represents the receiver." ^ self printString! ! !MetacelloVersionNumber class methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! extractNumericComponent: subString "$. separated components are integers" | number | number := [subString asNumber] on: Error do: [:ex | ex return: subString ]. ^number asString = subString ifTrue: [ number ] ifFalse: [ subString ]! ! !MetacelloVersionNumber class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! fromString: aString | new components | components := OrderedCollection new. (aString findTokens: '.') do: [:subString | | strs | strs := subString findTokens: '-'. "first subString token could be an integer" components add: (self extractNumericComponent: strs first). strs size > 1 ifTrue: [ "remaining are uncoditionally Strings, because of leading $-" components addAll: strs allButFirst ]]. new := self new: components size. 1 to: components size do: [:i | new at: i put: (components at: i) ]. ^new! ! !MetacelloVersionNumberTestCase methodsFor: 'test approximately greater than' stamp: 'dkh 5/4/2012 20:37:12'! testApproxVersion02 self deny: '1.1' asMetacelloVersionNumber ~> '1' asMetacelloVersionNumber! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testCollapseZeros self assert: (MetacelloVersionNumber fromString: '1.0-beta.24.0.1') collapseZeros printString = '1-beta.24.0.1'. self assert: (MetacelloVersionNumber fromString: '1.0-beta.24.0.0.1') collapseZeros printString = '1-beta.24.0.0.1'. self assert: (MetacelloVersionNumber fromString: '1.0.0-beta.24.0.0.1') collapseZeros printString = '1-beta.24.0.0.1'. ! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testVersion03 | v1 v2 | v1 := self versionClass fromString: '1.0.0.1'. v2 := self versionClass fromString: '1.0.0'. self assert: (v1 > v2)! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:54'! testVersion16 self assert: (self versionClass fromString: '1.0-beta.0') < (self versionClass fromString: '1.0'). self assert: (self versionClass fromString: '1.0-beta.0') < (self versionClass fromString: '1.0.0'). self assert: (self versionClass fromString: '1.0-beta.0') < (self versionClass fromString: '1.0.0.0')! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:53'! testVersion17 self assert: ((self versionClass fromString: '1.0') = (self versionClass fromString: '1.0.0')). self assert: ((self versionClass fromString: '1') = (self versionClass fromString: '1.0')). self assert: ((self versionClass fromString: '1') > (self versionClass fromString: '1-0')). self assert: ((self versionClass fromString: '1') > (self versionClass fromString: '1.0-beta.0')). self assert: ((self versionClass fromString: '1') > (self versionClass fromString: '1-beta.0')). self assert: ((self versionClass fromString: '1') > (self versionClass fromString: '1-beta')). ! ! !MetacelloVersionNumberTestCase methodsFor: 'test matching' stamp: 'dkh 5/4/2012 20:37:12'! testStandardMatch self assert: ((self versionClass fromString: '1.1.1') match: '*.*.*'). self deny: ((self versionClass fromString: '1.1.1') match: '*.*'). self assert: ((self versionClass fromString: '1.1.0') match: '1.1.*'). self assert: ((self versionClass fromString: '1.1.0') match: '1.#.*'). self deny: ((self versionClass fromString: '1.10.0') match: '1.#.*'). self assert: ((self versionClass fromString: '1-alpha5.0') match: '1-alpha#.0'). self assert: ((self versionClass fromString: '1.alpha5.0') match: '1-alpha#.0'). self assert: ((self versionClass fromString: '1.alpha5.0') match: '1.alpha#.0'). self deny: ((self versionClass fromString: '1-alpha10.0') match: '1-alpha#.0'). ! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testVersion21 self deny: (MetacelloVersionNumber fromString: '') > (MetacelloVersionNumber fromString: '0'). self assert: (MetacelloVersionNumber fromString: '') < (MetacelloVersionNumber fromString: '0'). self assert: (MetacelloVersionNumber fromString: '') = (MetacelloVersionNumber fromString: ''). ! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 15:10'! testVersion10 | x y | self assert: ((x := (({ self versionClass fromString: '1.0'. self versionClass fromString: '0.7'. self versionClass fromString: '0.8'. self versionClass fromString: '0.9'. self versionClass fromString: '1.0.1' } sort: [:a :b | a <= b ]) collect: [:each | each versionString ]) asArray) = (y := #( '0.7' '0.8' '0.9' '1.0' '1.0.1')))! ! !MetacelloVersionNumberTestCase methodsFor: 'private' stamp: 'dkh 5/4/2012 20:37:12'! versionClass ^MetacelloVersionNumber! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testVersion20 self assert: (MetacelloVersionNumber fromString: '') printString = ''. ! ! !MetacelloVersionNumberTestCase methodsFor: 'test matching' stamp: 'dkh 5/4/2012 20:37:12'! testInvalidSpecialMatch self should: [ ((self versionClass fromString: '1.1') match: '?.?') ] raise: Error. ! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testVersion08 | v1 v2 | v1 := self versionClass fromString: '1.0a6'. v2 := self versionClass fromString: '1.0a5'. self assert: (v1 > v2)! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testVersion06 | v1 v2 | v1 := self versionClass fromString: '3.'. v2 := self versionClass fromString: '2'. self assert: (v1 > v2)! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:52'! testVersion12 self deny: ((self versionClass fromString: '1.0') <= (self versionClass fromString: '0.7'))! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:53'! testVersion19 self assert: ((self versionClass fromString: '1.0-beta.0') < (self versionClass fromString: '1')). ! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testVersion11 | v1 v2 | v1 := self versionClass fromString: '1.0.1b'. v2 := self versionClass fromString: '1.0.1a'. self assert: (v1 >= v2). self assert: (v2 <= v1)! ! !MetacelloVersionNumberTestCase methodsFor: 'test approximately greater than' stamp: 'dkh 5/4/2012 20:37:12'! testApproxVersion03 self assert: '1.1' asMetacelloVersionNumber ~> '1.1' asMetacelloVersionNumber! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:52'! testVersion09 | v1 v2 | v1 := self versionClass fromString: '1.0'. v2 := self versionClass fromString: '0.7'. self assert: (v1 >= v2). self assert: (v2 <= v1)! ! !MetacelloVersionNumberTestCase methodsFor: 'test approximately greater than' stamp: 'dkh 5/4/2012 20:37:12'! testApproxVersion01 self assert: '1.1.1' asMetacelloVersionNumber ~> '1.1' asMetacelloVersionNumber! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:52'! testVersion15 self assert: ((self versionClass fromString: '1.0-beta.0') < (self versionClass fromString: '1.0-beta.1')). ! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testVersion24 self assert: (MetacelloVersionNumber fromString: '3.0.3.-rc.1') ~= (MetacelloVersionNumber fromString: '3.0.0.3-rc.1'). self assert: (MetacelloVersionNumber fromString: '1.0.0.1.0.0') = (MetacelloVersionNumber fromString: '1.0.0.1'). self assert: (MetacelloVersionNumber fromString: '1.0.0.1') ~= (MetacelloVersionNumber fromString: '1..1'). ! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testVersion13 self deny: ((self versionClass fromString: '0.8') <= (self versionClass fromString: '0.7')). self deny: ((self versionClass fromString: '0.8.1.8') <= (self versionClass fromString: '0.7.0.5')). ! ! !MetacelloVersionNumberTestCase methodsFor: 'test matching' stamp: 'dkh 5/4/2012 20:37:12'! testSpecialMatch self assert: ((self versionClass fromString: '1.1') match: '?'). self assert: ((self versionClass fromString: 'alpha') match: '?'). self assert: ((self versionClass fromString: '1.1.1.1.1') match: '?'). self assert: ((self versionClass fromString: '1.alpha5') match: '?'). self assert: ((self versionClass fromString: '1.1') match: '*.?'). self assert: ((self versionClass fromString: '1.1') match: '?'). self assert: ((self versionClass fromString: '10.1.1.1.1') match: '?'). self deny: ((self versionClass fromString: '1.1') match: '*.*.?'). self assert: ((self versionClass fromString: '1.1.1') match: '*.?'). ! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 15:10'! testVersion18 self deny: ((self versionClass fromString: '1.0') < (self versionClass fromString: '1')). self deny: ((self versionClass fromString: '1.0') < (self versionClass fromString: '1-0')). ! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:52'! testVersion05 | v1 v2 | v1 := self versionClass fromString: '3'. v2 := self versionClass fromString: '2'. self assert: (v1 > v2)! ! !MetacelloVersionNumberTestCase methodsFor: 'tests' stamp: 'dkh 6/22/2012 16:52'! testVersion07 | v1 v2 | v1 := self versionClass fromString: '3.0.0'. v2 := self versionClass fromString: '2'. self assert: (v1 > v2)! ! !MetacelloVersionSpec methodsFor: 'printing' stamp: 'dkh 9/10/2012 15:58'! configPackagesSpecMethodOn: aStream indent: indent | projectSpecs packageSpecs groupSpecs | projectSpecs := OrderedCollection new. packageSpecs := OrderedCollection new. groupSpecs := OrderedCollection new. self packagesSpec list do: [:member | member spec projectDo: [:proj | member spec name ~~ nil ifTrue: [ projectSpecs add: member ]] packageDo: [:package | member spec name ~~ nil ifTrue: [ packageSpecs add: member ]] groupDo: [:group | member spec name ~~ nil ifTrue: [ groupSpecs add: member ]]]. projectSpecs isEmpty not ifTrue: [ aStream tab: indent; nextPutAll: 'spec '. projectSpecs size > 1 ifTrue: [ aStream cr; tab: indent + 1 ]. 1 to: projectSpecs size do: [:index | (projectSpecs at: index) configMethodCascadeOn: aStream last: index == projectSpecs size indent: indent + 1. index ~= projectSpecs size ifTrue: [ aStream tab: indent + 1 ]]]. packageSpecs isEmpty not ifTrue: [ projectSpecs isEmpty not ifTrue: [ aStream cr ]. aStream tab: indent; nextPutAll: 'spec '. packageSpecs size > 1 ifTrue: [ aStream cr; tab: indent + 1 ]. 1 to: packageSpecs size do: [:index | (packageSpecs at: index) configMethodCascadeOn: aStream last: index == packageSpecs size indent: indent + 1. index ~= packageSpecs size ifTrue: [ aStream tab: indent + 1 ]]]. groupSpecs isEmpty not ifTrue: [ projectSpecs isEmpty not | packageSpecs isEmpty not ifTrue: [ aStream cr ]. aStream tab: indent; nextPutAll: 'spec '. groupSpecs size > 1 ifTrue: [ aStream cr; tab: indent + 1 ]. 1 to: groupSpecs size do: [:index | (groupSpecs at: index) configMethodCascadeOn: aStream last: index == groupSpecs size indent: indent + 1. index ~= groupSpecs size ifTrue: [ aStream tab: indent + 1 ]]]. ! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! description: aBlockOrString constructor: aVersionConstructor aVersionConstructor descriptionForVersion: aBlockOrString! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! description description == nil ifTrue: [ ^self project valueHolderSpec value: ''; yourself]. ^ description! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 9/10/2012 15:40'! packageNames packageList == nil ifTrue: [ ^ #() ]. ^ self packages map keys asSet! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/11/2012 12:13'! import ^ importName! ! !MetacelloVersionSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodValueOn: aStream for: spec selector: selector last: last indent: indent | valuePrintString | spec == nil ifTrue: [ ^ self ]. valuePrintString := spec value isSymbol ifTrue: [ '#' , spec value asString printString ] ifFalse: [ spec value printString ]. aStream tab: indent; nextPutAll: 'spec ' , selector , ' ' , valuePrintString , '.'. last ifFalse: [ aStream cr ]! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! setPreLoadDoIt: aSymbol preLoadDoIt := aSymbol! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:24'! versionString: anObject constructor: aVersionConstructor aVersionConstructor versionStringForVersion: anObject! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! projectLabel ^self project label! ! !MetacelloVersionSpec methodsFor: 'merging' stamp: 'dkh 9/11/2012 14:18'! mergeSpec: anotherSpec | newSpec map anotherPackages | newSpec := super mergeSpec: anotherSpec. map := anotherSpec mergeMap. (anotherPackages := map at: #'packageList') isEmpty not ifTrue: [ newSpec packages: (self packages isEmpty ifTrue: [ anotherPackages ] ifFalse: [ self packages mergeSpec: anotherPackages ]) ]. ^ newSpec! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! preLoadDoIt ^preLoadDoIt! ! !MetacelloVersionSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! createVersion ^self versionClass fromSpec: self! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! author: anObject anObject setAuthorInMetacelloVersion: self! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! getPostLoadDoIt ^postLoadDoIt! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! postLoadDoIt ^postLoadDoIt! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 9/11/2012 10:36'! packageNamed: aString ^self packageNamed: aString ifAbsent: [ nil ]! ! !MetacelloVersionSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! versionClass ^MetacelloVersion! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 6/5/2012 19:01:24'! versionString versionString == nil ifTrue: [ ^'' ]. ^ versionString! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:23'! project: aString copyFrom: oldSpecName with: aBlock constructor: aVersionConstructor aVersionConstructor projectForVersion: aString copyFrom: oldSpecName with: aBlock! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! description: anObject anObject setDescriptionInMetacelloVersion: self! ! !MetacelloVersionSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodOn: aStream for: spec selector: selector last: last indent: indent spec == nil ifTrue: [ ^ self ]. aStream tab: indent; nextPutAll: 'spec ' , selector , ' ['; cr. spec configMethodOn: aStream indent: indent + 1. aStream nextPutAll: ' ].'. last ifFalse: [ aStream cr ]! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:24'! removeProject: aString constructor: aVersionConstructor aVersionConstructor removeProjectForVersion: aString! ! !MetacelloVersionSpec methodsFor: 'loading' stamp: 'dkh 9/11/2012 11:49'! resolveToLoadableSpec: aString forLoad: forLoad forMap: map packages: packageMap | package | package := self packageNamed: aString forLoad: forLoad forMap: map ifAbsent: [ ^ self error: 'Name not found: ' , aString ]. packageMap at: package name put: package. ^ {package}! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! getDescription ^description! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! postLoadDoIt: aSymbol constructor: aVersionConstructor aVersionConstructor postLoadDoItForVersion: aSymbol! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/11/2012 10:38'! import: anObject importName := anObject! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/10/2012 15:54'! packagesSpec ^self packages! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 9/11/2012 11:57'! difference: otherVersionSpec "Return a dictionary of additions, removals and modifications" | report myProjectSpecs otherProjectSpecs | report := MetacelloVersionDiffReport new. myProjectSpecs := Dictionary new. self projectDo: [ :projectSpec | myProjectSpecs at: projectSpec name put: projectSpec ] packageDo: [ :ignored | ] groupDo: [ :ignored | ]. otherProjectSpecs := Dictionary new. otherVersionSpec projectDo: [ :projectSpec | otherProjectSpecs at: projectSpec name put: projectSpec ] packageDo: [ :ignored | ] groupDo: [ :ignored | ]. myProjectSpecs valuesDo: [ :myProjectSpec | | otherProjectSpec | otherProjectSpec := otherProjectSpecs at: myProjectSpec name ifAbsent: [ ]. otherProjectSpec == nil ifTrue: [ report removals at: myProjectSpec name put: {(myProjectSpec versionString). ''} ] ifFalse: [ myProjectSpec versionString = otherProjectSpec versionString ifFalse: [ report modifications at: myProjectSpec name put: {(myProjectSpec versionString). (otherProjectSpec versionString)} ] ] ]. otherProjectSpecs valuesDo: [ :otherProjectSpec | (myProjectSpecs at: otherProjectSpec name ifAbsent: [ ]) == nil ifTrue: [ report additions at: otherProjectSpec name put: {''. (otherProjectSpec versionString)} ] ]. ^ report! ! !MetacelloVersionSpec methodsFor: 'merging' stamp: 'dkh 9/11/2012 12:11'! nonOverridable ^ super nonOverridable , #(#'packageList')! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! timestamp: anObject anObject setTimestampInMetacelloVersion: self! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! blessing: aBlockOrString constructor: aVersionConstructor aVersionConstructor blessingForVersion: aBlockOrString! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! setPostLoadDoIt: aSymbol postLoadDoIt := aSymbol! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! preLoadDoIt: anObject anObject setPreLoadDoItInMetacelloSpec: self! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:23'! configuration: aString with: aBlockOrString constructor: aVersionConstructor aVersionConstructor configurationForVersion: aString with: aBlockOrString! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/10/2012 15:39'! packages: anObject packageList := anObject! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! preLoadDoIt: aSymbol constructor: aVersionConstructor aVersionConstructor preLoadDoItForVersion: aSymbol! ! !MetacelloVersionSpec methodsFor: 'copying' stamp: 'dkh 9/10/2012 15:40'! postCopy super postCopy. blessing := blessing copy. description := description copy. author := author copy. timestamp := timestamp copy. packageList := packageList copy! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! postLoadDoIt: anObject anObject setPostLoadDoItInMetacelloSpec: self! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! timestamp timestamp == nil ifTrue: [ ^self project valueHolderSpec value: ''; yourself]. ^ timestamp! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionString: anObject versionString := anObject! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! setDescription: anObject description := anObject! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! blessing blessing == nil ifTrue: [ ^self project valueHolderSpec value: self project defaultBlessing; yourself]. ^ blessing! ! !MetacelloVersionSpec methodsFor: 'loading' stamp: 'dkh 9/11/2012 12:09'! expandToLoadableSpecNames: nameList | cacheKey names | cacheKey := Array with: self label with: nameList. ^MetacelloPlatform current stackCacheFor: #loadableSpecNames at: cacheKey doing: [ :cache | names := (self resolveToLoadableSpecs: nameList) collect: [:spec | spec name ]. cache at: cacheKey put: names ]. ! ! !MetacelloVersionSpec methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isPartiallyCurrent: notLoadedMatters useEquality: useEquality self subclassResponsibility! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! getAuthor ^author! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:22'! group: aString with: aStringOrCollection constructor: aVersionConstructor aVersionConstructor groupForVersion: aString with: aStringOrCollection! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 9/11/2012 10:36'! packageNamed: aString forMap: map ifAbsent: absentBlock "import: only allowed to be used with baseline project specs" ^ self packageNamed: aString forLoad: true forMap: map ifAbsent: absentBlock! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/10/2012 15:39'! packages packageList == nil ifTrue: [ packageList := self project packagesSpec ]. ^ packageList! ! !MetacelloVersionSpec methodsFor: 'printing' stamp: 'dkh 9/10/2012 15:58'! configMethodOn: aStream last: last indent: indent | spec hasPackageSpecs | hasPackageSpecs := false. self packagesSpec list do: [ :member | member spec projectDo: [ :proj | member spec name ~~ nil ifTrue: [ hasPackageSpecs := true ] ] packageDo: [ :package | member spec name ~~ nil ifTrue: [ hasPackageSpecs := true ] ] groupDo: [ :group | member spec name ~~ nil ifTrue: [ hasPackageSpecs := true ] ] ]. self configMethodBasicOn: aStream last: hasPackageSpecs not indent: indent. self configPackagesSpecMethodOn: aStream indent: indent. last ifFalse: [ aStream cr ]! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 9/11/2012 10:09'! packageSpecsInLoadOrder ^ self packages packageSpecsInLoadOrder! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:23'! project: aString constructor: aVersionConstructor aVersionConstructor projectForVersion: aString! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:24'! import: aString constructor: aVersionConstructor aVersionConstructor importForVersion: aString! ! !MetacelloVersionSpec methodsFor: 'merging' stamp: 'dkh 9/11/2012 14:20'! mergeMap | map | map := super mergeMap. map at: #'versionString' put: versionString. map at: #'blessing' put: blessing. map at: #'description' put: description. map at: #'author' put: author. map at: #'timestamp' put: timestamp. map at: #'preLoadDoIt' put: preLoadDoIt. map at: #'postLoadDoIt' put: postLoadDoIt. map at: #'packageList' put: self packages. ^ map! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! timestamp: aBlockOrStringOrDateAndTime constructor: aVersionConstructor aVersionConstructor timestampForVersion: aBlockOrStringOrDateAndTime! ! !MetacelloVersionSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configSpawnMethodOn: aStream indent: indent self configMethodValueOn: aStream for: self getBlessing selector: 'blessing:' last: false indent: indent. self configMethodValueOn: aStream for: self getAuthor selector: 'author:' last: false indent: indent. self configMethodValueOn: aStream for: self getTimestamp selector: 'timestamp:' last: false indent: indent. ! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! repository: aString username: username password: password constructor: aVersionConstructor aVersionConstructor repositoryForVersion: aString username: username password: password! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! getBlessing ^blessing! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! repository: anObject constructor: aVersionConstructor aVersionConstructor repositoryForVersion: anObject! ! !MetacelloVersionSpec methodsFor: 'private' stamp: 'dkh 6/22/2012 12:35'! versionNumber ^ self project versionNumberClass fromString: self versionString! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:23'! baseline: aString with: aBlockOrString constructor: aVersionConstructor aVersionConstructor baselineForVersion: aString with: aBlockOrString! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:22'! group: aString overrides: aStringOrCollection constructor: aVersionConstructor aVersionConstructor groupForVersion: aString overrides: aStringOrCollection! ! !MetacelloVersionSpec methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isPossibleBaseline self subclassResponsibility! ! !MetacelloVersionSpec methodsFor: 'loading' stamp: 'dkh 9/11/2012 11:49'! resolveToLoadableSpecs: required forLoad: forLoad map: packageMap | reqd allReqd map newReqd spec | reqd := required copy. allReqd := Set new. map := self packages map. [ reqd isEmpty ] whileFalse: [ newReqd := Set new. reqd do: [ :req | (self resolveToLoadableSpec: req forLoad: forLoad forMap: map packages: packageMap) do: [ :loadableSpec | newReqd addAll: loadableSpec requires. newReqd addAll: loadableSpec includes ] ]. allReqd addAll: reqd. newReqd removeAllFoundIn: allReqd. reqd := newReqd ]. packageMap keys do: [ :pkgName | (spec := (packageMap at: pkgName) resolveToLoadableSpec) == nil ifTrue: [ packageMap removeKey: pkgName ] ifFalse: [ packageMap at: pkgName put: (packageMap at: pkgName) resolveToLoadableSpec ] ]! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:24'! project: aString with: aBlockOrString constructor: aVersionConstructor aVersionConstructor projectForVersion: aString with: aBlockOrString! ! !MetacelloVersionSpec methodsFor: 'printing' stamp: 'dkh 9/10/2012 15:56'! configMethodBasicOn: aStream last: last indent: indent | values lastIndex lastBlock | last ifTrue: [ "need to calculate last statement with a value" values := {(self getBlessing). (self getDescription). (self getPreLoadDoIt). (self getPostLoadDoIt). (self getAuthor). (self getTimestamp)}. 1 to: values size do: [ :index | (values at: index) ~~ nil ifTrue: [ lastIndex := index ] ]. lastBlock := [ :arg | arg = lastIndex ] ] ifFalse: [ lastBlock := [ :arg | false ] ]. self configMethodValueOn: aStream for: self getBlessing selector: 'blessing:' last: (lastBlock value: 1) indent: indent. self configMethodValueOn: aStream for: self getDescription selector: 'description:' last: (lastBlock value: 2) indent: indent. self configMethodValueOn: aStream for: self getPreLoadDoIt selector: 'preLoadDoIt:' last: (lastBlock value: 3) indent: indent. self configMethodValueOn: aStream for: self getPostLoadDoIt selector: 'postLoadDoIt:' last: (lastBlock value: 4) indent: indent. self configMethodValueOn: aStream for: self getAuthor selector: 'author:' last: (lastBlock value: 5) indent: indent. self configMethodValueOn: aStream for: self getTimestamp selector: 'timestamp:' last: (lastBlock value: 6) indent: indent! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 9/11/2012 10:36'! packageNamed: aString ifAbsent: aBlock ^self packageNamed: aString forMap: self packages map ifAbsent: aBlock! ! !MetacelloVersionSpec methodsFor: 'loading' stamp: 'dkh 9/11/2012 11:49'! resolveToLoadableSpecs: nameList "Resolves names in namelist to the list of packages and projects in the version that would be loaded. Projects are not traversed during the transitive closure. The scope is that of the version itself. If the spec is a package, answer a list including the package and the transitive closure on its #requires: and #includes: fields. If the spec is a project, answer the project. If the spec is a group, answers the list of packages in the #includes: field of the group. Groups in the #includes: field are expanded following the transitive closure on groups" | map | map := Dictionary new. self resolveToLoadableSpecs: nameList forLoad: false map: map. ^ map values! ! !MetacelloVersionSpec methodsFor: 'toolbox support' stamp: 'dkh 9/12/2012 14:26'! deleteSpec: aSpec "remove the spec from packages" self packages deleteSpec: aSpec! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! setBlessing: anObject blessing := anObject! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 9/11/2012 10:37'! packageNamed: aString forLoad: forLoad forMap: map ifAbsent: absentBlock | importSpec | ^ map at: aString ifAbsent: [ (forLoad and: [ self import notNil ]) ifTrue: [ "expect the 'missing' name to be satisfied within context of imported project" importSpec := (map at: self import ifAbsent: absentBlock) copy name: aString; mergeImportLoads: {aString}; yourself. importSpec projectReference name: aString. importSpec ] ifFalse: [ (aString = 'default' or: [ aString = 'ALL' ]) ifTrue: [ self project groupSpec name: aString; includes: self packageNames; yourself ] ifFalse: [ absentBlock value ] ] ]! ! !MetacelloVersionSpec methodsFor: 'enumerating' stamp: 'dkh 9/11/2012 10:08'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock self packageSpecsInLoadOrder do: [:pkgSpec | pkgSpec projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock ]! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! getTimestamp ^timestamp! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! setAuthor: anObject author := anObject! ! !MetacelloVersionSpec methodsFor: 'loading' stamp: 'dkh 9/11/2012 12:13'! defaultPackageNames "if there is a package named 'default' (a group) then it defines the default package names, otherwise answer a list of all of the package names in this version" self packages packageNamed: 'default' ifAbsent: [ ^self packageNames ]. ^#('default')! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:24'! removeGroup: aString constructor: aVersionConstructor aVersionConstructor removeGroupForVersion: aString! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:23'! baseline: aString constructor: aVersionConstructor aVersionConstructor baselineForVersion: aString! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! repositories: aBlock constructor: aVersionConstructor aVersionConstructor repositoriesForVersion: aBlock! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! author author == nil ifTrue: [ ^self project valueHolderSpec value: ''; yourself]. ^ author! ! !MetacelloVersionSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! label ^self versionString, ' [', self projectLabel, ']'! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! blessing: anObject anObject setBlessingInMetacelloVersion: self! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 9/10/2012 15:24'! project: aString overrides: aBlock constructor: aVersionConstructor aVersionConstructor projectForVersion: aString overrides: aBlock! ! !MetacelloVersionSpec methodsFor: 'construction' stamp: 'dkh 6/5/2012 19:01:24'! author: aBlockOrString constructor: aVersionConstructor aVersionConstructor authorForVersion: aBlockOrString! ! !MetacelloVersionSpec methodsFor: 'printing' stamp: 'dkh 6/5/2012 19:01:24'! configMethodOn: aStream indent: indent self configMethodOn: aStream last: true indent: indent! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! getPreLoadDoIt ^preLoadDoIt! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! setTimestamp: anObject timestamp := anObject! ! !MetacelloVersionSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testVersionMergeSpec | versionA versionB version | versionA := self versionSpec blessing: #'baseline'; versionString: '1.0'; description: 'A description'; author: 'dkh'; timestamp: '1/24/2012 09:59'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself. versionB := self versionSpec blessing: #'release'; versionString: '1.1'; description: 'A FULL description'; author: 'DaleHenrichs'; timestamp: '1/24/2012 10:22'; preLoadDoIt: #'preLoadDoItB'; postLoadDoIt: #'postLoadDoItB'; yourself. version := versionA mergeSpec: versionB. self assert: version blessing value = #'release'. self assert: version versionString value = '1.1'. self assert: version description value = 'A FULL description'. self assert: version author value = 'DaleHenrichs'. self assert: version timestamp value = '1/24/2012 10:22'. self assert: version preLoadDoIt value == #'preLoadDoItB'. self assert: version postLoadDoIt value == #'postLoadDoItB'! ! !MetacelloVersionSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testVersionSpec | version | version := self versionSpec blessing: #'baseline'; versionString: '1.0'; description: 'A description'; author: 'dkh'; timestamp: '1/24/2012 09:59'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself. self assert: version blessing value = #'baseline'. self assert: version versionString value = '1.0'. self assert: version description value = 'A description'. self assert: version author value = 'dkh'. self assert: version timestamp value = '1/24/2012 09:59'. self assert: version preLoadDoIt value == #'preLoadDoIt'. self assert: version postLoadDoIt value == #'postLoadDoIt'. self should: [ version preLoadDoIt: '' ] raise: Error. self should: [ version postLoadDoIt: '' ] raise: Error! ! !MetacelloVersionSpecTestCase methodsFor: 'tests' stamp: 'dkh 5/4/2012 20:37:12'! testVersionSpecCreateVersion | spec version | spec := self versionSpec blessing: #'baseline'; versionString: '1.0'; description: 'A description'; author: 'dkh'; timestamp: '1/24/2012 09:59'; preLoadDoIt: #'preLoadDoIt'; postLoadDoIt: #'postLoadDoIt'; yourself. version := spec createVersion. self assert: version class == spec versionClass. self assert: version spec == spec. self assert: version versionNumber asString = '1.0'. self assert: version blessing = #'baseline'. self assert: version versionString = '1.0'. self assert: version description = 'A description'. self assert: version author = 'dkh'. self assert: version timestamp = '1/24/2012 09:59'! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! errorReasonCodes ^ #(#'duplicateNames' #'shadowedNames' #'invalidDoItSelector' #'invalidVersionString' #'missingVersionImport' #'projectCreationError' #'noVersionsDefined' #'cannotResolveVersion' #'incompleteProjectSpec' #'incorrectVersionString' #'versionCompositionError' #'versionCreationError')! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! validateProjectCreationFrom: aConfigurationClass onError: aBlock [ ^ aConfigurationClass project ] on: Error , MetacelloValidationNotification , MetacelloErrorInProjectConstructionNotification do: [ :ex | (ex isKindOf: MetacelloValidationNotification) ifTrue: [ self validationReport add: ex issue. ex resume ]. (ex isKindOf: MetacelloErrorInProjectConstructionNotification) ifTrue: [ self recordValidationError: 'Error creating version: ' , ex versionString , ' error: ' , ex exception description , ' to reproduce evalutate the following: ''[' , self configurationClass name asString , ' project ] on: MetacelloErrorInProjectConstructionNotification do: [:ex | ex resume: true ]''' callSite: #'validateProjectCreationFrom:onError:' reasonCode: #'versionCreationError'. ex resume: false ]. ^ aBlock value: ex ]! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! configurationClass: anObject configurationClass := anObject! ! !MetacelloVersionValidator methodsFor: 'validation' stamp: 'dkh 6/5/2012 19:01:24'! validate "Issue 5: []no shadowing of names across project/package/group boundaries Issue 6: []package version supplied for each package []no released (stable/bleedingEdge) versions (only development version) package spec used instead of project spec in baseline (ConfigurationOfPharo-DaleHenrichs.50) Issue 20: []pre and post load doits must be symbols, not blocks Others: []symbolic versions can be resolved. []Ensure that versions are Strings and symbolic versions are symbols. []Ensure that imported versions are defined." self validatePragmas. ^self validateProject! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! validateBaselineVersionSpec: versionSpec self subclassResponsibility! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! validateDoIts: aSpec versionString: versionString errorMessage: errorMessage | ar | ar := { #preLoadDoIt. 'preLoadDoIt selector for '. #postLoadDoIt. 'postLoadDoIt selector for '. }. 1 to: ar size by: 2 do: [ :i | | selector | selector := (aSpec perform: (ar at: i)) value. selector ~~ nil ifTrue: [ selector isSymbol ifFalse: [ self recordValidationError: (ar at: i + 1) , errorMessage , ' is not a symbol' versionString: versionString callSite: #validateDoIts:versionString:errorMessage: reasonCode: #invalidDoItSelector ] ] ]! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! validationReport: anObject validationReport := anObject! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! validateVersionSpec: versionSpec self subclassResponsibility! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! validatePragmas "Ensure that versions are Strings and symbolic versions are symbols. Ensure that imported versions are defined" | versionPragmas versionImportPragmas symbolicVersionPragmas versionStrings | versionPragmas := self extractVersionPragmas. versionImportPragmas := self extractVersionImportPragmas. symbolicVersionPragmas := self extractSymbolicVersionPragmas. versionStrings := Set new. versionPragmas keys , versionImportPragmas keys , symbolicVersionPragmas keys do: [ :versionString | (versionStrings includes: versionString) ifTrue: [ self recordValidationCriticalWarning: 'version ' , versionString printString , ' is defined multiple times.' versionString: versionString callSite: #'validatePragmas' reasonCode: #'duplicateVersionDefinitions' ] ifFalse: [ versionStrings add: versionString ] ]. versionPragmas keysAndValuesDo: [ :versionString :pragmaList | versionString isString ifFalse: [ self recordValidationError: 'version ' , versionString printString , ' is not a String.' versionString: versionString callSite: #'validatePragmas' reasonCode: #'invalidVersionString' ]. pragmaList size > 1 ifTrue: [ self recordValidationCriticalWarning: 'version ' , versionString printString , ' is defined multiple times.' versionString: versionString callSite: #'validatePragmas' reasonCode: #'duplicateVersionDefinitions' ] ]. symbolicVersionPragmas keysAndValuesDo: [ :versionString :pragmaList | versionString isSymbol ifFalse: [ self recordValidationError: 'symbolic version ' , versionString printString , ' is not a Symbol.' versionString: versionString callSite: #'validatePragmas' reasonCode: #'invalidVersionString' ]. pragmaList size > 1 ifTrue: [ self recordValidationCriticalWarning: 'version ' , versionString printString , ' is defined multiple times.' versionString: versionString callSite: #'validatePragmas' reasonCode: #'duplicateVersionDefinitions' ] ]. versionImportPragmas keysAndValuesDo: [ :versionString :pragmaList | versionString isString ifFalse: [ self recordValidationError: 'version ' , versionString printString , ' is not a String.' versionString: versionString callSite: #'validatePragmas' reasonCode: #'invalidVersionString' ]. pragmaList size > 1 ifTrue: [ self recordValidationCriticalWarning: 'version ' , versionString printString , ' is defined multiple times.' versionString: versionString callSite: #'validatePragmas' reasonCode: #'duplicateVersionDefinitions' ]. pragmaList do: [ :versionImportPragma | (versionImportPragma arguments at: 2) do: [ :importedVersionString | (versionStrings includes: importedVersionString) ifFalse: [ self recordValidationError: 'version ' , importedVersionString printString , ' referenced in import list of version ' , versionString printString , ' has not been defined.' versionString: versionString callSite: #'validatePragmas' reasonCode: #'missingVersionImport' ] ] ] ]! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! recurse recurse == nil ifTrue: [ recurse := false ]. ^ recurse! ! !MetacelloVersionValidator methodsFor: 'pragma extraction' stamp: 'dkh 6/5/2012 19:01:24'! extractExcludedValidations | exclusionDict | exclusionDict := Dictionary new. (Pragma allNamed: #excludedValidationIssues: in: self configurationClass) do: [:pragma | | exclusions | exclusions := pragma argumentAt: 1. 1 to: exclusions size by: 2 do: [:index | exclusionDict at: (exclusions at: index) put: (exclusions at: index + 1) ]]. ^exclusionDict! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! warningReasonCodes ^ #(#onlyBaselineVersion )! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! recordValidationCriticalWarning: aString versionString: versionString callSite: callSite reasonCode: aSymbol "reasonCodes: #packageNameMismatch #projectClassNameFileMismatch #duplicateVersionDefinitions #duplicateAttributeBlocks " (self criticalWarningReasonCodes includes: aSymbol) ifFalse: [ self error: 'Unknown critical warning reason code' ]. ((self exludededValidations at: versionString ifAbsent: [ #() ]) includes: aSymbol) ifTrue: [ ^self ]. (self debug includes: #criticalWarning) ifTrue: [ self halt: 'Debug triggered for critical warning: ', aString ]. self validationReport add: (MetacelloValidationCriticalWarning configurationClass: (self recurse ifTrue: [ self configurationClass ] ifFalse: [ nil ]) reasonCode: aSymbol callSite: callSite explanation: aString)! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! validateVersionSpecForSymbolicVersion: versionSpec symbolicVersion: symbolicVersionString self subclassResponsibility! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! debug: aCollection "Any combination of: #error, #criticalWarning, #warning" debug := aCollection! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! visited: anIdentitySet visited := anIdentitySet! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! recordValidationError: aString versionString: versionString callSite: callSite reasonCode: aSymbol "reasonCodes: #noVersionForSymbolicVersion #duplicateNames #shadowedNames #invalidDoItSelector #invalidVersionString #missingVersionImport #projectCreationError #noVersionsDefined #cannotResolveVersion #incompleteProjectSpec #incorrectVersionString " (self errorReasonCodes includes: aSymbol) ifFalse: [ self error: 'Unknown error reason code' ]. ((self exludededValidations at: versionString ifAbsent: [ #() ]) includes: aSymbol) ifTrue: [ ^self ]. (self debug includes: #error) ifTrue: [ self halt: 'Debug triggered for error: ', aString ]. self validationReport add: (MetacelloValidationError configurationClass: (self recurse ifTrue: [ self configurationClass ] ifFalse: [ nil ]) reasonCode: aSymbol callSite: callSite explanation: aString)! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! visited visited == nil ifTrue: [ visited := IdentitySet new ]. ^visited! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! validationReport validationReport == nil ifTrue: [ validationReport := OrderedCollection new ]. ^ validationReport! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! criticalWarningReasonCodes ^ #(#'packageNameMismatch' #'projectClassNameFileMismatch' #'duplicateVersionDefinitions')! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! recordValidationCriticalWarning: aString callSite: callSite reasonCode: aSymbol ^self recordValidationCriticalWarning: aString versionString: nil callSite: callSite reasonCode: aSymbol ! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! recordValidationWarning: aString versionString: versionString callSite: callSite reasonCode: aSymbol "reasonCodes: #onlyBaselineVersion #noVersionSpecified " (self warningReasonCodes includes: aSymbol) ifFalse: [ self error: 'Unknown warning reason code' ]. ((self exludededValidations at: versionString ifAbsent: [ #() ]) includes: aSymbol) ifTrue: [ ^self ]. (self debug includes: #warning) ifTrue: [ self halt: 'Debug triggered for critical warning: ', aString ]. self validationReport add: (MetacelloValidationWarning configurationClass: (self recurse ifTrue: [ self configurationClass ] ifFalse: [ nil ]) reasonCode: aSymbol callSite: callSite explanation: aString)! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! configurationClass ^ configurationClass! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! exludededValidations exludededValidations == nil ifTrue: [ exludededValidations := self extractExcludedValidations ]. ^exludededValidations! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! validateProjectVersion: versionString | project | project := self validateProjectCreationFrom: self configurationClass onError: [ :ex | self recordValidationError: 'Error creating project: ' , ex description , ' to reproduce evalutate the following: ''' , self configurationClass name asString , ' project''' callSite: #validateProject reasonCode: #projectCreationError. ^ self validationReport ]. ^ self validateProject: project version: versionString! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! recordValidationWarning: aString callSite: callSite reasonCode: aSymbol ^self recordValidationWarning: aString versionString: nil callSite: callSite reasonCode: aSymbol ! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! recordValidationError: aString callSite: callSite reasonCode: aSymbol ^self recordValidationError: aString versionString: nil callSite: callSite reasonCode: aSymbol ! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! debug debug == nil ifTrue: [ debug := #() ]. ^ debug! ! !MetacelloVersionValidator methodsFor: 'validation' stamp: 'dkh 6/5/2012 19:01:24'! validateProject: project version: versionString | version spec | (self visited includes: project configuration class) ifTrue: [ ^ self validationReport ]. self visited add: project configuration class. [ version := project version: versionString ] on: Error do: [ :ex | self recordValidationError: 'Could not resolve version ' , versionString printString , ' due to error: ' , ex description versionString: versionString callSite: #validateProject:version: reasonCode: #cannotResolveVersion. ^ self validationReport ]. spec := version spec. [ spec blessing value == #baseline ifTrue: [ self validateBaselineVersionSpec: spec ] ifFalse: [ self validateVersionSpec: spec ] ] on: Error do: [ :ex | self recordValidationError: 'Error composing version ' , version versionString printString , ': ' , ex description versionString: version versionString callSite: #validateProject:version: reasonCode: #versionCompositionError ]. ^ self validationReport! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! validateProject | project | project := self validateProjectCreationFrom: self configurationClass onError: [ :ex | self recordValidationError: 'Error creating project: ' , ex description , ' to reproduce evalutate the following: ''' , self configurationClass name asString , ' project''' callSite: #validateProject reasonCode: #projectCreationError. ^ self validationReport ]. ^ self validateProject: project! ! !MetacelloVersionValidator methodsFor: 'validation' stamp: 'dkh 6/5/2012 19:01:24'! validateProject: project | hasNoBaseline hasNoVersion | (self visited includes: project configuration class) ifTrue: [ ^ self validationReport ]. self visited add: project configuration class. hasNoBaseline := hasNoVersion := true. project versions do: [ :version | | spec | spec := version spec. [ spec blessing value == #baseline ifTrue: [ hasNoBaseline := false. self validateBaselineVersionSpec: spec ] ifFalse: [ hasNoVersion := false. self validateVersionSpec: spec ] ] on: Error do: [ :ex | self recordValidationError: 'Error composing version ' , version versionString printString , ': ' , ex description versionString: version versionString callSite: #validateProject: reasonCode: #versionCompositionError ] ]. project symbolicVersionMap keys do: [ :symbolicVersion | | version | version := [ project version: symbolicVersion ] on: Error , MetacelloSymbolicVersionNotDefinedError do: [ :ex | "MetacelloSymbolicVersionNotDefinedError are explicitly not defined, so are not validation errors" (ex isKindOf: MetacelloSymbolicVersionNotDefinedError) ifFalse: [ self recordValidationError: 'symbolic version ' , symbolicVersion printString , ' does not resolve to a literal version.' callSite: #validatePragmas reasonCode: #cannotResolveVersion ]. ex return: nil ]. version ~~ nil ifTrue: [ self validateVersionSpecForSymbolicVersion: version spec symbolicVersion: symbolicVersion ] ]. hasNoVersion ifTrue: [ hasNoBaseline ifTrue: [ self recordValidationError: 'No usable baseline or versions defined.' callSite: #validatePragmas reasonCode: #noVersionsDefined ] ifFalse: [ self recordValidationWarning: 'Only baseline defined (no version defined).' callSite: #validatePragmas reasonCode: #onlyBaselineVersion ] ]. ^ self validationReport! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! recurse: anObject recurse := anObject! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! validateConfiguration: configurationClass debug: debugList recurse: aBool ^ ((self new) configurationClass: configurationClass; debug: debugList; recurse: aBool; yourself) validate! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! validateProject: aMetacelloProject ^self validateProject: aMetacelloProject debug: #() recurse: false! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! validateProject: aMetacelloProject recurse: aBool ^self validateProject: aMetacelloProject debug: #() recurse: aBool! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! validateProject: aMetacelloProject version: versionString debug: debugList recurse: aBool ^ ((self new) configurationClass: aMetacelloProject configuration class; debug: debugList; recurse: aBool; yourself) validateProject: aMetacelloProject version: versionString! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! validateConfiguration: configurationClass ^self validateConfiguration: configurationClass debug: #() recurse: false! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! validateProject: aMetacelloProject version: versionString debug: debugList ^self validateProject: aMetacelloProject version: versionString debug: debugList recurse: false ! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! validateProject: aMetacelloProject debug: debugList recurse: aBool ^ ((self new) recurse: aBool; debug: debugList; configurationClass: aMetacelloProject configuration class; yourself) validateProject: aMetacelloProject! ! !MetacelloVersionValidator class methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! populateReasonCodeDescriptions "update MetacelloMCVersionValidator class comment to include any changes to descriptions" | dict | dict := Dictionary new. dict at: #'onlyBaselineVersion' put: 'one or more baseline versions have been defined, but no non-baseline versions are defined.'. dict at: #'duplicateVersionDefinitions' put: 'there are multiple pragma methods specifying the same version.'; at: #'packageNameMismatch' put: 'the name in the packageSpec does not match the name of the mcz file.'; at: #'projectClassNameFileMismatch' put: 'the class name of the configuration does not match the mcz file containing the configuration.'; at: #'cannotResolveVersion' put: 'the version (project reference or symbolic version) was not found in the specified configuration.'. dict at: #'duplicateNames' put: 'multiple independent definitions for an entity with same name (project, package, or group).'; at: #'incompleteProjectSpec' put: 'missing required fields in project reference (repository, className).'; at: #'incorrectVersionString' put: 'the version declared in pragma doesn''t match version in versionSpec.'; at: #'invalidDoItSelector' put: 'doit select must be a Symbol.'; at: #'invalidVersionString' put: 'versionString must be a String.'; at: #'missingVersionImport' put: 'version specified in import pragma not defined in configuration.'; at: #'noVersionsDefined' put: 'no usable baseline or version defined in configuration ... configuration cannot be loaded.'; at: #'projectCreationError' put: 'error occured while resolving project reference.'; at: #'versionCreationError' put: 'error occured while resolving version specification, error will be thrown if an attempt is made to use the version.'; at: #'shadowedNames' put: 'name duplication between packages and projects.'; at: #'versionCompositionError' put: 'error while creating versionSpec from pragmas.'. ^ dict! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! validateProject: aMetacelloProject version: versionString debug: debugList recurse: aBool visited: visitied ^(self new configurationClass: aMetacelloProject configuration class; debug: debugList; recurse: aBool; visited: visitied; yourself) validateProject: aMetacelloProject version: versionString! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! validateProject: aMetacelloProject version: versionString ^self validateProject: aMetacelloProject version: versionString debug: #() recurse: false ! ! !MetacelloVersionValidator class methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! descriptionForReasonCode: reasonCode ^ self reasonCodeDescriptions at: reasonCode ifAbsent: [ self error: 'Unknown reasonCode: ' , reasonCode printString ]! ! !MetacelloVersionValidator class methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! reasonCodeDescriptions reasonCodeDescriptions ifNil: [ reasonCodeDescriptions := self populateReasonCodeDescriptions ]. ^reasonCodeDescriptions! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'dkh 6/5/2012 19:01:24'! validateConfiguration: configurationClass recurse: aBool ^self validateConfiguration: configurationClass debug: #() recurse: aBool! ! !MetacelloVisitedPackages methodsFor: 'visiting' stamp: 'dkh 6/8/2012 14:04:22'! visit: aSpec doing: aBlock aSpec projectDo: [:spec | (projects includes: spec name) ifTrue: [ ^self ]. projects add: spec name ] packageDo: [:spec | (packages includes: spec name) ifTrue: [ ^self ]. packages add: spec name ] groupDo: [:spec | (groups includes: spec name) ifTrue: [ ^self ]. groups add: spec name ]. aBlock value: aSpec! ! !MetacelloVisitedPackages methodsFor: 'initialize-release' stamp: 'dkh 6/8/2012 14:04:22'! initialize groups := Set new. packages := Set new. projects := Set new.! ! !MetacelloVisitedPackages methodsFor: 'visiting' stamp: 'dkh 6/8/2012 14:04:22'! pushProject: aBlock | oldGroups oldPackages oldProjects | oldGroups := groups. oldPackages := packages. oldProjects := projects. groups := Set new. packages := Set new. ^aBlock ensure: [ groups := oldGroups. packages := oldPackages. projects := oldProjects ]! ! !Metaclass commentStamp: ''! My instances add instance-specific behavior to various class-describing objects in the system. This typically includes messages for initializing class variables and instance creation messages particular to a class. There is only one instance of a particular Metaclass, namely the class which is being described. A Metaclass shares the class variables of its instance. [Subtle] In general, the superclass hierarchy for metaclasses parallels that for classes. Thus, Integer superclass == Number, and Integer class superclass == Number class. However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus, Object superclass == nil, and Object class superclass == Class. [Subtle detail] A class is know by name to an environment. Typically this is the SystemDictionary named Smalltalk. If we ever make lightweight classes that are not in Smalltalk, they must be in some environment. Specifically, the code that sets 'wasPresent' in name:inEnvironment:subclassOf:instanceVariableNames:variable:words:pointers:classVariableNames:poolDictionaries:category:comment:changed: must continue to work.! !Metaclass methodsFor: 'testing' stamp: ''! isObsolete "Return true if the receiver is obsolete" ^self soleInstance == nil "Either no thisClass" or:[self soleInstance classSide ~~ self "or I am not the class of thisClass" or:[self soleInstance isObsolete]] "or my instance is obsolete"! ! !Metaclass methodsFor: 'composition' stamp: ''! assertConsistantCompositionsForNew: aTraitComposition "Applying or modifying a trait composition on the class side of a behavior has some restrictions." | baseTraits notAddable message | baseTraits := aTraitComposition traits select: [:each | each isBaseTrait]. baseTraits isEmpty ifFalse: [ notAddable := (baseTraits reject: [:each | each classSide methodDict isEmpty]). notAddable isEmpty ifFalse: [ message := String streamContents: [:stream | stream nextPutAll: 'You can not add the base trait(s)'; cr. notAddable do: [:each | stream nextPutAll: each name] separatedBy: [ stream nextPutAll: ', ']. stream cr; nextPutAll: 'to this composition because it/they define(s) methods on the class side.']. ^TraitCompositionException signal: message]]. (self instanceSide traitComposition traits asSet = (aTraitComposition traits select: [:each | each isClassTrait] thenCollect: [:each | each baseTrait]) asSet) ifFalse: [ ^TraitCompositionException signal: 'You can not add or remove class side traits on the class side of a composition. (But you can specify aliases or exclusions for existing traits or add a trait which does not have any methods on the class side.)']! ! !Metaclass methodsFor: 'accessing' stamp: ''! soleInstance "The receiver has only one instance. Answer it." ^thisClass! ! !Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 12:38'! traitComposition: aTraitComposition traitComposition := aTraitComposition! ! !Metaclass methodsFor: 'initialize-release' stamp: 'ar 7/13/1999 04:52'! adoptInstance: oldInstance from: oldMetaClass "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary." thisClass class == self ifTrue:[^self error:'Metaclasses have only one instance']. oldMetaClass isMeta ifFalse:[^self error:'Argument must be Metaclass']. oldInstance class == oldMetaClass ifFalse:[^self error:'Not the class of argument']. ^thisClass := self newInstanceFrom: oldInstance variable: self isVariable size: self instSize map: (self instVarMappingFrom: oldMetaClass)! ! !Metaclass methodsFor: '*Manifest-Core' stamp: ''! criticTheNonMetaclassClass ^self theNonMetaClass ! ! !Metaclass methodsFor: 'initialize' stamp: ''! initializeFrom: anotherClassTrait self traitComposition: self traitComposition copyTraitExpression. self methodDict: self methodDict copy. self localSelectors: self localSelectors copy. self basicOrganization: self organization copy.! ! !Metaclass methodsFor: '*Ring-Core-Kernel' stamp: ''! asFullRingDefinition ^ self theNonMetaClass asFullRingDefinition theMetaClass! ! !Metaclass methodsFor: 'compiling' stamp: ''! bindingOf: varName ^self theNonMetaClass classBindingOf: varName! ! !Metaclass methodsFor: 'class hierarchy' stamp: ''! addSubclass: aClass "Do nothing."! ! !Metaclass methodsFor: 'accessing' stamp: ''! category ^ self theNonMetaClass category! ! !Metaclass methodsFor: '*Tools-Debugger' stamp: 'SeanDeNigris 5/28/2013 17:46'! canonicalArgumentName ^ 'aClass'.! ! !Metaclass methodsFor: 'accessing parallel hierarchy' stamp: 'SebastianTleye 7/12/2013 14:42'! classClass ^self! ! !Metaclass methodsFor: 'accessing parallel hierarchy' stamp: 'SebastianTleye 7/12/2013 14:42'! baseClass ^thisClass.! ! !Metaclass methodsFor: 'composition' stamp: ''! uses: aTraitCompositionOrArray | copyOfOldTrait newComposition | copyOfOldTrait := self copy. newComposition := aTraitCompositionOrArray asTraitComposition. self assertConsistantCompositionsForNew: newComposition. self setTraitComposition: newComposition. SystemAnnouncer uniqueInstance traitDefinitionChangedFrom: copyOfOldTrait to: self.! ! !Metaclass methodsFor: 'instance variables' stamp: ''! addInstVarNamed: aString "Add the argument, aString, as one of the receiver's instance variables." | fullString | fullString := String streamContents: [:strm | self instVarNames do: [:aString2 | strm nextPutAll: aString2; space]. strm nextPutAll: aString]. self instanceVariableNames: fullString! ! !Metaclass methodsFor: 'compiling' stamp: ''! binding "return an association that can be used as the binding To share it between methods, reuse an existing one if possible" ^self methodDict ifEmpty: [nil -> self] ifNotEmpty: [:dict | dict anyOne classBinding]! ! !Metaclass methodsFor: 'copying' stamp: 'nice 12/29/2010 10:21'! postCopy "Don't share the reference to the sole instance." super postCopy. thisClass := nil.! ! !Metaclass methodsFor: 'class hierarchy' stamp: ''! addObsoleteSubclass: aClass "Do nothing."! ! !Metaclass methodsFor: '*Ring-Core-Kernel' stamp: ''! asRingDefinition ^ self theNonMetaClass asRingDefinition theMetaClass! ! !Metaclass methodsFor: 'initialize-release' stamp: ''! uses: aTraitCompositionOrArray instanceVariableNames: instVarString | newComposition newMetaClass copyOfOldMetaClass | copyOfOldMetaClass := self copy. newMetaClass := self instanceVariableNames: instVarString. newComposition := aTraitCompositionOrArray asTraitComposition. newMetaClass assertConsistantCompositionsForNew: newComposition. newMetaClass setTraitComposition: newComposition. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfOldMetaClass to: newMetaClass! ! !Metaclass methodsFor: 'accessing' stamp: ''! name "Answer a String that is the name of the receiver, either 'Metaclass' or the name of the receiver's class followed by ' class'." thisClass == nil ifTrue: [^'a Metaclass'] ifFalse: [^thisClass name , ' class']! ! !Metaclass methodsFor: 'pool variables' stamp: ''! sharedPools ^OrderedCollection new.! ! !Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'! basicLocalSelectors: aSetOrNil localSelectors := aSetOrNil! ! !Metaclass methodsFor: 'testing' stamp: ''! isAnonymous ^self soleInstance isAnonymous ! ! !Metaclass methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:31'! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! ! !Metaclass methodsFor: 'compiling' stamp: ''! acceptsLoggingOfCompilation "Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set. The metaclass follows the rule of the class itself." ^ self theNonMetaClass acceptsLoggingOfCompilation! ! !Metaclass methodsFor: 'class hierarchy' stamp: ''! removeSubclass: aClass "Do nothing."! ! !Metaclass methodsFor: 'instance variables' stamp: ''! removeInstVarNamed: aString "Remove the argument, aString, as one of the receiver's instance variables." | newArray newString | (self instVarNames includes: aString) ifFalse: [self error: aString , ' is not one of my instance variables']. newArray := self instVarNames copyWithout: aString. newString := ''. newArray do: [:aString2 | newString := aString2 , ' ' , newString]. self instanceVariableNames: newString! ! !Metaclass methodsFor: 'testing' stamp: 'MarcusDenker 10/17/2013 12:08'! isClass ^ true! ! !Metaclass methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitMetaclass: self ! ! !Metaclass methodsFor: 'class hierarchy' stamp: ''! obsoleteSubclasses "Answer the receiver's subclasses." self theNonMetaClass == nil ifTrue:[^#()]. ^self theNonMetaClass obsoleteSubclasses select:[:aSubclass| aSubclass isMeta not] thenCollect:[:aSubclass| aSubclass class] "Metaclass allInstancesDo: [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! ! !Metaclass methodsFor: 'accessing' stamp: 'ar 7/11/1999 05:19'! environment ^thisClass environment! ! !Metaclass methodsFor: 'fileIn/Out' stamp: ''! fileOutInitializerOn: aStream (self includesSelector: #initialize) ifTrue: [aStream cr. aStream nextChunkPut: self soleInstance name , ' initialize'].! ! !Metaclass methodsFor: 'initialize-release' stamp: 'MartinDias 6/24/2013 15:26'! instanceVariableNames: instVarString "Declare additional named variables for my instance." ^thisClass classBuilder class: self instanceVariableNames: instVarString! ! !Metaclass methodsFor: 'accessing instances and variables' stamp: ''! classVarNames "Answer a set of the names of the class variables defined in the receiver's instance." self theNonMetaClass ifNil: [ ^ Set new ]. ^self theNonMetaClass classVarNames! ! !Metaclass methodsFor: 'copying' stamp: 'tk 8/19/1998 16:16'! veryDeepCopyWith: deepCopier "Return self. Must be created, not copied. Do not record me."! ! !Metaclass methodsFor: 'composition' stamp: ''! noteNewBaseTraitCompositionApplied: aTraitComposition "The argument is the new trait composition of my base trait - add the new traits or remove non existing traits on my class side composition. (Each class trait in my composition has its base trait on the instance side of the composition - manually added traits to the class side are always base traits.)" | newComposition traitsFromInstanceSide | traitsFromInstanceSide := self traitComposition traits select: [:each | each isClassTrait] thenCollect: [:each | each baseTrait]. newComposition := self traitComposition copyTraitExpression. (traitsFromInstanceSide copyWithoutAll: aTraitComposition traits) do: [:each | newComposition removeFromComposition: each classTrait]. (aTraitComposition traits copyWithoutAll: traitsFromInstanceSide) do: [:each | newComposition add: (each classTrait)]. self setTraitComposition: newComposition! ! !Metaclass methodsFor: 'class hierarchy' stamp: ''! subclassesDo: aBlock "Evaluate aBlock for each of the receiver's immediate subclasses." self theNonMetaClass subclassesDo:[:aSubclass| "The following test is for Class class which has to exclude the Metaclasses being subclasses of Class." aSubclass isMeta ifFalse:[aBlock value: aSubclass class]].! ! !Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 12:35'! traitComposition traitComposition ifNil: [traitComposition := TraitComposition new]. ^traitComposition! ! !Metaclass methodsFor: 'fileIn/Out' stamp: 'al 7/4/2009 17:45'! definition "Refer to the comment in ClassDescription|definition." ^ String streamContents: [:strm | strm print: self. (self hasTraitComposition and: [self traitComposition notEmpty]) ifTrue: [ strm crtab; nextPutAll: 'uses: '; print: self traitComposition ]. strm crtab; nextPutAll: 'instanceVariableNames: '; store: self instanceVariablesString]! ! !Metaclass methodsFor: 'accessing hierarchy protocol' stamp: ''! hasClassSide ^false! ! !Metaclass methodsFor: 'fileIn/Out' stamp: ''! nonTrivial "Answer whether the receiver has any methods or instance variables." ^ self instVarNames notEmpty or: [self hasMethods or: [self hasTraitComposition]]! ! !Metaclass methodsFor: 'testing' stamp: ''! isMeta ^ true! ! !Metaclass methodsFor: 'fileIn/Out' stamp: 'MarcusDenker 5/7/2013 23:32'! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. (aBool and:[moveSource not and: [self includesSelector: #initialize]]) ifTrue: [aFileStream cr. aFileStream cr. aFileStream nextChunkPut: thisClass name , ' initialize'. aFileStream cr]! ! !Metaclass methodsFor: 'compiling' stamp: ''! possibleVariablesFor: misspelled continuedFrom: oldResults ^ self theNonMetaClass possibleVariablesFor: misspelled continuedFrom: oldResults ! ! !Metaclass methodsFor: 'testing' stamp: ''! canZapMethodDictionary "Return true if it is safe to zap the method dictionary on #obsolete" self soleInstance == nil ifTrue:[^true] ifFalse:[^self soleInstance canZapMethodDictionary]! ! !Metaclass methodsFor: 'pool variables' stamp: ''! classPool "Answer the dictionary of class variables." ^self theNonMetaClass classPool! ! !Metaclass methodsFor: 'instance creation' stamp: 'nk 11/9/2003 10:00'! new "The receiver can only have one instance. Create it or complain that one already exists." thisClass class ~~ self ifTrue: [^thisClass := self basicNew] ifFalse: [self error: 'A Metaclass should only have one instance!!']! ! !Metaclass methodsFor: 'compiling' stamp: ''! wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself." ^ self theNonMetaClass wantsChangeSetLogging! ! !Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 13:16'! basicLocalSelectors "Direct accessor for the instance variable localSelectors. Since localSelectors is lazily initialized, this may return nil, which means that all selectors are local." ^ localSelectors! ! !Metaclass methodsFor: 'compiling' stamp: ''! wantsRecompilationProgressReported "The metaclass follows the rule of the class itself." ^ self theNonMetaClass wantsRecompilationProgressReported! ! !Metaclass methodsFor: '*NativeBoost-Core' stamp: 'Igor.Stasenko 9/28/2010 08:00'! externalTypeAlias: aName "redirect request to my instance side" ^ self instanceSide externalTypeAlias: aName! ! !Metaclass methodsFor: 'testing' stamp: ''! isSelfEvaluating ^self isObsolete not! ! !Metaclass methodsFor: 'class hierarchy' stamp: ''! subclasses "Answer the receiver's subclasses." self theNonMetaClass == nil ifTrue:[^#()]. ^self theNonMetaClass subclasses select:[:aSubclass| aSubclass isMeta not] thenCollect:[:aSubclass| aSubclass class] "Metaclass allInstancesDo: [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! ! !MetaclassTest commentStamp: 'TorstenBergmann 2/5/2014 08:40'! Sunit tests for metaclasses! !MetaclassTest methodsFor: 'tests' stamp: 'MarcusDenker 11/3/2013 11:42'! testMetaclassAndTraitClassRespectsPolymorphismRules | repeatedMethodsThatDoNotAccessInstanceVariables differentMethodsWithSameSelector | "If the method is in Metaclass and ClassTrait it must access some instance variable, otherwise the method can be implemented in TApplyingOnClassSide" repeatedMethodsThatDoNotAccessInstanceVariables := self repeatedMethodsThatDoNotAccessInstanceVariablesBetween: Metaclass and: ClassTrait. self assert: repeatedMethodsThatDoNotAccessInstanceVariables size = 0. "If the method is in Metaclass and ClassTrait, and they have different implementations, it must be declared in TApplyingOnClassSide as an explicitRequirement method" differentMethodsWithSameSelector := self differentMethodsWithSameSelectorBetween: Metaclass and: ClassTrait. differentMethodsWithSameSelector do: [ :selector | (TApplyingOnClassSide >> selector) sourceCode. self assert: (TApplyingOnClassSide >> selector) isRequired ]. "Only a few methods are allowed to belong to one class and not to the other It would be excelent to remove these methods somehow, but is NOT good idea add methods to this list" "basicLocalSelectors basicLocalSelectors: localSelectors localSelectors: traitComposition traitComposition: -> accessors to instance variables that do not belong to ClassTrait baseClass classClass -> they have their equivalent for ClassTraits (baseTrait classTrait) environment postCopy -> the implementation for ClassTrait is in TBehavior veryDeepCopyWith: -> the implementation for ClassTraits is in Object fileOutOn:moveSource:toFile: fileOutOn:moveSource:toFile:initializing: -> the implementation for ClassTraits is in TClassDescription" self assert: (Metaclass localSelectors difference: ClassTrait localSelectors) = {#externalTypeAlias:. #baseClass. #basicLocalSelectors:. #basicLocalSelectors. #classClass. #isClass. #environment. #fileOutOn:moveSource:toFile:. #fileOutOn:moveSource:toFile:initializing:. #postCopy. #traitComposition. #traitComposition:. #veryDeepCopyWith:} asSet. "initializeWithBaseTrait: asMCDefinition -> has no equivalent in classes baseTrait isClassTrait classTrait baseTrait isBaseTrait classTrait: -> they have their equivalent for Metaclasses compile:classified:withStamp:notifying:logSource: -> the implementation for Metaclasses is in TClassDescription copy -> the implementation for Metaclasses is in Object" self assert: (ClassTrait localSelectors difference: Metaclass localSelectors) = {#initializeWithBaseTrait:. #asMCDefinition. #baseTrait:. #isClassTrait. #classTrait. #baseTrait. #compile:classified:withStamp:notifying:logSource:. #isBaseTrait. #copy. #classTrait:} asSet! ! !MethodAdded commentStamp: 'cyrilledelaunay 1/18/2011 13:06'! This announcement is emited when we add a method to a class or a trait using: => Behavior >> compile: or TraitBehavior >> compile:! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 18:10'! method: aCompiledMethod method := aCompiledMethod! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 18:12'! protocol ^ protocol! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 18:12'! selector ^ selector! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 18:12'! method ^ method! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 18:12'! methodClass ^ methodClass! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:38'! methodClass: aClass methodClass := aClass! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:38'! selector: aSelector selector := aSelector! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 14:11'! methodAffected ^ self method! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:38'! protocol: aProtocolName protocol := aProtocolName! ! !MethodAdded class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/1/2012 18:22'! method: aCompiledMethod selector: aSelector protocol: aProtocolName class: aClass self flag: #look. "Is it ok to send an event with no requestor?" ^self method: aCompiledMethod selector: aSelector protocol: aProtocolName class: aClass requestor: nil! ! !MethodAdded class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/1/2012 18:23'! method: aCompiledMethod selector: aSelector protocol: aProtocolName class: aClass requestor: aRequestor ^self new method: aCompiledMethod; selector: aSelector; protocol: aProtocolName; methodClass: aClass; yourself! ! !MethodAdded class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/1/2012 18:08'! method: aCompiledMethod selector: aSelector class: aClass self flag: #look. "Is it ok to send an event with no protocol?" ^self method: aCompiledMethod selector: aSelector protocol: nil class: aClass requestor: nil! ! !MethodAddition commentStamp: 'rej 2/25/2007 19:30'! I represent the addition of a method to a class. I can produce the CompiledMethod, install it, and then notify the system that the method has been added. This allows Monticello to implement atomic addition. A loader can compile all classes and methods first and then install all methods only after they have been all compiled, and in a way that executes little code.ß! !MethodAddition methodsFor: 'operations' stamp: 'rej 2/25/2007 22:09'! installMethod myClass addSelectorSilently: selector withMethod: compiledMethod. ! ! !MethodAddition methodsFor: 'operations' stamp: 'MarcusDenker 4/30/2013 10:17'! writeSourceToLog logSource ifTrue: [ myClass logMethodSource: text forMethod: compiledMethod inCategory: category withStamp: changeStamp ]. ! ! !MethodAddition methodsFor: 'accessing' stamp: 'PavelKrivanek 12/6/2012 22:54'! priorCategoryOrNil: anObject priorCategoryOrNil := anObject! ! !MethodAddition methodsFor: 'operations' stamp: 'MarcusDenker 9/5/2013 15:41'! createCompiledMethod compiledMethod := myClass compiler source: text asString; requestor: requestor; category: category; failBlock: [ ^nil ]; compile. selector := compiledMethod selector. self writeSourceToLog. priorMethodOrNil := myClass compiledMethodAt: selector ifAbsent: [ nil ]. priorCategoryOrNil := myClass organization categoryOfElement: selector! ! !MethodAddition methodsFor: 'notifying' stamp: 'ClementBera 7/26/2013 16:53'! notifyObservers SystemAnnouncer uniqueInstance suspendAllWhile: [myClass organization classify: selector under: category]. priorMethodOrNil ifNil: [SystemAnnouncer uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: myClass requestor: requestor] ifNotNil: [ SystemAnnouncer uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: myClass requestor: requestor. priorCategoryOrNil = category ifFalse: [ SystemAnnouncer uniqueInstance selector: selector recategorizedFrom: priorCategoryOrNil to: category inClass: myClass] ]. "The following code doesn't seem to do anything." myClass instanceSide noteCompilationOf: selector meta: myClass isClassSide. ! ! !MethodAddition methodsFor: 'compilation' stamp: 'rej 2/25/2007 20:36'! compile: aString classified: aString1 withStamp: aString2 notifying: aRequestor logSource: aBoolean inClass: aClass text := aString. category := aString1. changeStamp := aString2. requestor := aRequestor. logSource := aBoolean. myClass := aClass! ! !MethodAddition methodsFor: 'accessing' stamp: 'PavelKrivanek 12/6/2012 22:54'! priorCategoryOrNil ^ priorCategoryOrNil! ! !MethodAddition methodsFor: 'compilation' stamp: 'rej 2/26/2007 10:51'! compile "This method is the how compiling a method used to work. All these steps were done at once. This method should not normally be used, because the whole point of MethodAddition is to let you first create a compiled method and then install the method later." self createCompiledMethod. self installMethod. self notifyObservers. ^selector! ! !MethodBrowser commentStamp: ''! A MethodBrowser is a simple browser using Spec to display a list of methods and their source code | si | si := MethodBrowser new. si openWithSpec. si methods: Object methodDict values! !MethodBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/12/2012 19:35'! acceptBlock: aBlock textModel acceptBlock: aBlock! ! !MethodBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/6/2012 20:46'! wrapWith: aBlock listModel displayBlock: aBlock! ! !MethodBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:33'! initializePresenter listModel whenSelectedItemChanged: [:selection | selection ifNil: [ textModel text: ''. textModel behavior: nil. toolbarModel method: nil ] ifNotNil: [:m | textModel text: m sourceCode. textModel behavior: m methodClass. toolbarModel method: m ]]. self acceptBlock: [:t | self listModel selectedItem inspect ]. self wrapWith: [:item | item methodClass name,'>>#', item selector ].! ! !MethodBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/4/2012 14:42'! action ^ textModel actionToPerformHolder content! ! !MethodBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/31/2012 13:10'! methods: aList "Here I reroute my entry point to the list model's entry point" self listModel items: aList! ! !MethodBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/13/2012 16:24'! sortingBlock: aBlock listModel sortingBlock: aBlock ! ! !MethodBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/12/2012 19:32'! displayBlock: aBlock listModel displayBlock: aBlock! ! !MethodBrowser methodsFor: 'initialization' stamp: 'CamilloBruni 9/22/2013 21:34'! initializeWidgets listModel := self newList. textModel := self newText. toolbarModel := self instantiate: MethodToolbar. self focusOrder add: listModel; add: toolbarModel; add: textModel. textModel aboutToStyle: true.! ! !MethodBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/14/2011 14:51'! textModel ^ textModel! ! !MethodBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/14/2011 14:51'! listModel ^ listModel! ! !MethodBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/18/2012 01:58'! toolbarModel ^ toolbarModel! ! !MethodBrowser methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 1/17/2012 03:16'! takeKeyboardFocus ^ self listModel takeKeyboardFocus! ! !MethodBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 15:51'! defaultSpec | delta | delta := 15. ^ SpecLayout composed add: #listModel origin: 0@0 corner: 1@0.5 offsetOrigin: 0@0 offsetCorner: 0@(delta negated); add: #toolbarModel origin: 0@0.5 corner: 1@0.5 offsetOrigin: 0@(delta negated) offsetCorner: 0@delta; add: #textModel origin: 0@0.5 corner: 1@1 offsetOrigin: 0@delta offsetCorner: 0@0; yourself! ! !MethodBrowser class methodsFor: 'example' stamp: 'MarcusDenker 5/6/2013 17:11'! example | mb | mb := MethodBrowser new. mb openWithSpec. mb methods: Object methods! ! !MethodBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/31/2012 13:36'! title ^ 'Method Browser'! ! !MethodBrowser class methodsFor: 'specs' stamp: 'bvr 6/4/2012 17:27'! defaultSpec2 ^{ #Panel. #changeTableLayout. #listDirection:. #bottomToTop. #addMorph:. {#model. #listModel.}. #addMorph:. {#model. #textModel.}. #vResizing:. #spaceFill. #hResizing:. #spaceFill.}! ! !MethodChangeRecord commentStamp: ''! MethodChangeRecords are used to record method changes. Here is a simple summary of the relationship between the changeType symbol and the recording of prior state | prior == nil | prior not nil --------- |---------------------------- |-------------------- add | add | change --------- |---------------------------- |-------------------- remove | addedThenRemoved | remove Structure: changeType symbol -- as summarized above currentMethod method This is the current version of the method. It can be used to assert this change upon entry to a layer. infoFromRemoval -- an array of size 2. The first element is the source index of the last version of the method. The second element is the category in which it was defined, so it can be put back there if re-accepted from a version browser. Note that the above states each have an associated revoke action: add --> remove change --> change back remove --> add back addedThenRemoved --> no change However all of these are accomplished trivially by restoring the original method dictionary.! !MethodChangeRecord methodsFor: 'accessing' stamp: 'di 4/1/2000 12:02'! changeType ^ changeType! ! !MethodChangeRecord methodsFor: 'infos' stamp: 'di 4/1/2000 11:05'! noteMethodInfoFromRemoval: info "Store an array with the source index of the last version of the method, and the category in which it was defined (so it can be put back there if re-accepted from a version browser)." infoFromRemoval := info! ! !MethodChangeRecord methodsFor: 'all changes' stamp: 'di 4/4/2000 11:05'! noteChangeType: newChangeType (changeType == #addedThenRemoved and: [newChangeType == #change]) ifTrue: [changeType := #add] ifFalse: [changeType := newChangeType]! ! !MethodChangeRecord methodsFor: 'infos' stamp: 'di 4/1/2000 12:02'! methodInfoFromRemoval "Return an array with the source index of the last version of the method, and the category in which it was defined (so it can be put back there if re-accepted from a version browser)." (changeType == #remove or: [changeType == #addedThenRemoved]) ifTrue: [^ infoFromRemoval] ifFalse: [^ nil]! ! !MethodChangeRecord methodsFor: 'printing' stamp: 'di 4/1/2000 12:02'! printOn: strm super printOn: strm. strm nextPutAll: ' ('; print: changeType; nextPutAll: ')'! ! !MethodClassifier commentStamp: ''! I am a method classifier that sets the protocl of methods using some simple rules. Example Usage: MethodClassifier classify: MyClass >> #mySelector! !MethodClassifier methodsFor: 'initialization' stamp: 'CamilloBruni 1/30/2013 21:02'! initialize self buildPrefixDictionary.! ! !MethodClassifier methodsFor: 'initialization' stamp: 'EstebanLorenzano 1/15/2014 11:27'! buildPrefixDictionary prefixMapping := Dictionary new. prefixMapping at: 'test' put: 'tests'; at: 'bench' put: 'benchmarking'; at: 'copy' put: 'copying'; at: 'initialize' put: 'initialization'; at: 'accept' put: 'visitor'; at: 'visit' put: 'visitor'; at: 'signal' put: 'signalling'; at: 'parse' put: 'parsing'; at: 'add' put: 'adding'; at: 'is' put: 'testing'; at: 'as' put: 'converting'; at: 'new' put: 'instance creation'.! ! !MethodClassifier methodsFor: 'classification-rules' stamp: 'CamilloBruni 1/30/2013 22:11'! classifyInSuperclassProtocol: aMethod | currentClass | currentClass := aMethod methodClass. [ currentClass superclass isNil ] whileFalse: [ currentClass := currentClass superclass. (currentClass includesSelector: aMethod selector) ifTrue: [ aMethod protocol: (currentClass >> aMethod selector) protocol. ^ true ]]. ^ false.! ! !MethodClassifier methodsFor: 'classification-rules' stamp: 'CamilloBruni 1/30/2013 21:40'! classifyAccessor: aMethod " If the method is a setter or getter for a " | names selector | names := aMethod methodClass allInstVarNames. selector := aMethod selector. (selector endsWith: ':') ifTrue: [ "selector might be a setter" selector := selector allButLast ]. (names includes: selector) ifFalse: [ ^ false ]. aMethod protocol: 'accessing'. ^ true.! ! !MethodClassifier methodsFor: 'classification-rules' stamp: 'EstebanLorenzano 5/28/2013 14:10'! classifyByOtherImplementors: aMethod | protocolBag | protocolBag := Bag new. aMethod implementors ifEmpty: [ ^ false ] ifNotEmpty: [ :methods | methods do: [ :method | self flag: 'TODO: at some point we should have first-class protocols which will tell whether they are extensions...'. ((method protocol beginsWith: '*') or: [ method protocol = Protocol unclassified ]) ifFalse: [ protocolBag add: method protocol ]] without: aMethod ]. protocolBag ifEmpty: [ ^ false ]. aMethod protocol: protocolBag sortedCounts first value. ^ true! ! !MethodClassifier methodsFor: 'classification' stamp: 'StephaneDucasse 8/29/2013 22:03'! classifyAll: aCollectionOfMethods aCollectionOfMethods do: [ :method | self classify: method ]! ! !MethodClassifier methodsFor: 'classification' stamp: 'CamilloBruni 1/30/2013 21:47'! classify: aMethod (self classifyAccessor: aMethod) ifTrue: [ ^ aMethod category ]. (self classifyInSuperclassProtocol: aMethod) ifTrue: [ ^ aMethod category ]. (self classifyByKnownPrefix: aMethod) ifTrue: [ ^ aMethod category ]. (self classifyByOtherImplementors: aMethod) ifTrue: [ ^ aMethod category ].! ! !MethodClassifier methodsFor: 'classification-rules' stamp: 'CamilloBruni 1/30/2013 22:13'! classifyByKnownPrefix: aMethod prefixMapping keysAndValuesDo: [ :prefix :protocol | (aMethod selector beginsWith: prefix) ifTrue: [ aMethod protocol: protocol. ^ true ]]. ^ false.! ! !MethodClassifier class methodsFor: 'classification' stamp: 'CamilloBruni 1/30/2013 21:45'! classify: aMethod ^ self new classify: aMethod! ! !MethodClassifier class methodsFor: 'classification' stamp: 'StephaneDucasse 8/29/2013 22:03'! classifyAll: aCollectionOfMethods ^ self new classifyAll: aCollectionOfMethods! ! !MethodContainsBreakpointAction commentStamp: ''! A MethodContainsBreakpointAction is the action corresponding to the fact that the method contains a breakpoint! !MethodContainsBreakpointAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/24/2013 11:01'! actionStateToCache "Return the state of the icon for caching purpose" ^ icon! ! !MethodContainsBreakpointAction methodsFor: 'order' stamp: 'EstebanLorenzano 5/14/2013 09:44'! privateActionIcon "Return the icon for this action" ^ Smalltalk ui icons iconNamed: #breakpointIcon! ! !MethodContainsBreakpointAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/24/2013 11:02'! isActionHandled "Return true if the provided method fits this action requirement" ^ method hasBreakpoint! ! !MethodContainsBreakpointAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:56'! actionOrder "Return the priority of this action" ^ 400! ! !MethodContainsFlagsAction commentStamp: ''! Action when the method contains a flag! !MethodContainsFlagsAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:52'! actionStateToCache "Return the state of the icon for caching purpose" ^ icon! ! !MethodContainsFlagsAction methodsFor: 'order' stamp: 'EstebanLorenzano 5/14/2013 09:44'! privateActionIcon "Return the icon for this action" ^ Smalltalk ui icons iconNamed: #flagIcon! ! !MethodContainsFlagsAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:41'! isActionHandled "Return true if the provided method fits this action requirement" ^ method containsFlag! ! !MethodContainsFlagsAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/24/2013 11:03'! actionOrder "Return the priority of this action" ^ 300! ! !MethodContainsHaltAction commentStamp: ''! Action when the method contains a halt! !MethodContainsHaltAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:52'! actionStateToCache "Return the state of the icon for caching purpose" ^ icon! ! !MethodContainsHaltAction methodsFor: 'order' stamp: 'EstebanLorenzano 5/14/2013 09:44'! privateActionIcon "Return the icon for this action" ^ Smalltalk ui icons iconNamed: #haltIcon! ! !MethodContainsHaltAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:41'! isActionHandled ^ method containsHalt! ! !MethodContainsHaltAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:57'! actionOrder "Return the priority of this action" ^ 100! ! !MethodContext commentStamp: ''! Instance variables: receiver: (self) closureOrNil: nil if I'm a method context the blockClosure being executed if I'm a block context method method being executed if I'm a method context method holding the block if I'm a block context variable fields: temporary variables (including arguments) My instances hold all the dynamic state associated with the execution of either a method activation resulting from a message send or a block activation resulting from a block evaluation. MethodContexts, though normal in their variable size, are actually only used in two sizes, small and large, which are determined by the temporary space required by the method being executed. MethodContexts must only be created using the method newForMethod:. Note that it is impossible to determine the real object size of a MethodContext except by asking for the frameSize of its method. Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector. Any store into stackp other than by the primitive method stackp: is potentially fatal.! !MethodContext methodsFor: 'closure support' stamp: 'ar 6/28/2003 00:15'! contextTag "Context tags may be used for referring to contexts instead of contexts themselves as they can be copied and will continue to work in other processes (continuations). By default, we use the context itself to as its tag." ^self! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'BernardoContreras 1/22/2012 16:55'! cannotReturn: result closureOrNil notNil ifTrue: [^self cannotReturn: result to: self home sender]. Smalltalk tools debugger openContext: thisContext label: 'computation has been terminated' contents: nil! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 4/25/2009 09:50'! hasMethodReturn ^closureOrNil hasMethodReturn! ! !MethodContext methodsFor: 'closure support' stamp: 'md 1/20/2006 17:17'! asContext ^ self! ! !MethodContext methodsFor: 'instruction decoding' stamp: 'ClementBera 9/19/2013 15:37'! respondsToUnknownBytecode "This method is triggerred by the VM when the interpreter tries to execute an unknown bytecode" | unknownBytecode | unknownBytecode := self method at: self pc. self error: 'VM cannot run unknown bytecode ', unknownBytecode printString ! ! !MethodContext methodsFor: '*OpalCompiler-Core' stamp: 'CamilleTeruel 2/14/2014 15:21'! isPushLiteralNil: aPC ^ (self method at: aPC) = 115! ! !MethodContext methodsFor: 'private' stamp: 'eem 4/26/2012 10:17'! endPC ^closureOrNil ifNil: [self method endPC] ifNotNil: [closureOrNil endPC]! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 7/22/2008 11:57'! home "Answer the context in which the receiver was defined." closureOrNil == nil ifTrue: [^self]. ^closureOrNil outerContext home! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'CamilloBruni 7/17/2013 21:58'! isHandlerContext "is this context for method that is marked?" ^method primitive = 199! ! !MethodContext methodsFor: 'initialize-release' stamp: 'HenrikSperreJohansen 6/11/2010 21:03'! privRefresh "Reinitialize the receiver so that it is in the state it was at its creation." closureOrNil ifNotNil: [pc := closureOrNil startpc. self stackp: closureOrNil numArgs + closureOrNil numCopiedValues. 1 to: closureOrNil numCopiedValues do: [:i | self tempAt: closureOrNil numArgs + i put: (closureOrNil at: i)]] ifNil: [pc := method initialPC. self stackp: method numTemps. method numArgs+1 to: method numTemps do: [:i | self tempAt: i put: nil]]! ! !MethodContext methodsFor: 'testing' stamp: 'MarcusDenker 5/10/2013 21:37'! isExecutingBlock "for compatibility" ^self isBlockContext ! ! !MethodContext methodsFor: 'system simulation' stamp: 'CamilloBruni 7/17/2013 22:00'! pushArgs: arguments from: senderContext "Helps simulate action of the value primitive for closures. This is used by ContextPart>>runSimulated:contextAtEachStep:" closureOrNil ifNil: [self error: 'context needs a closure!!'] ifNotNil: [ "See BlockClosure>>asContextWithSender:" stackp ~= (closureOrNil numArgs + closureOrNil numCopiedValues) ifTrue: [ self error: 'stack pointer is incorrect!!' ]]. 1 to: closureOrNil numArgs do: [:i | self at: i put: (arguments at: i)]. sender := senderContext! ! !MethodContext methodsFor: 'accessing' stamp: 'IgorStasenko 12/29/2010 19:10'! contextClass "The context class of a message send should be the one of the method to be evaluated, because if that method has some super sends, the method lookup won't work as expected'" ^self method methodClass! ! !MethodContext methodsFor: 'testing' stamp: 'MarcusDenker 5/10/2013 21:35'! isBlockContext "Is this executing a block versus a method? In the new closure implemetation this is true if closureOrNil is not nil, in which case it should be holding a BlockClosure." ^closureOrNil isClosure! ! !MethodContext methodsFor: 'printing' stamp: 'CamilloBruni 2/13/2012 23:21'! printDebugOn: aStream "print a condensed for of the stack. For methods simply print Class >> selector For blocks only print the first line" | blockSource blockSourceSize | super printOn: aStream. self outerContext ifNil: [ ^ self ]. "print the block..." aStream nextPutAll: ' in Block: '. blockSource := closureOrNil printStringLimitedTo: 50. blockSourceSize := blockSource size. blockSource := blockSource copyUpTo: Character cr. aStream nextPutAll: blockSource. blockSource size < blockSourceSize ifTrue: [ aStream nextPutAll: '...' ].! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'CamilloBruni 7/17/2013 22:00'! receiver: anObject receiver := anObject! ! !MethodContext methodsFor: '*AST-Interpreter-Extension' stamp: 'ClementBera 10/18/2012 10:24'! asASTInterpreterContext ^ (self isBlockContext ifTrue: [ AIBlockContext ] ifFalse: [ AIMethodContext ]) fromVMContext: self ! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 8/20/2008 09:29'! tempAt: index put: value "Store the argument, value, as the temporary variable whose index is the argument, index. Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive. Override the default at:put: primitive to give latitude to the VM in context management." ^self at: index put: value! ! !MethodContext methodsFor: '*Fuel' stamp: 'MartinDias 3/26/2012 19:17'! cleanCopy ^ self class sender: nil receiver: receiver method: method arguments: #()! ! !MethodContext methodsFor: 'accessing' stamp: 'CamilleTeruel 12/19/2012 16:39'! tempNamed: aName "Returns the value of the temporaries, aName." "Implementation notes: temporary initialization in blocks simply uses pushNil to allocate and initialize each temp. So if one inspects [|a|a:=2] and sends it self method symbolic you get: 13 <8F 00 00 05> closureNumCopied: 0 numArgs: 0 bytes 17 to 21 17 <73> pushConstant: nil 18 <77> pushConstant: 2 19 <81 40> storeIntoTemp: 0 21 <7D> blockReturn 22 <7C> returnTop And when we check self asContext pc we get 17, which is *before* the nil is pushed. Therefore we should pay attention when querying a temporary if the temporary allocation was executed." | index | index := self tempNames indexOf: aName. ^ index > stackp ifTrue: [ nil ] ifFalse: [ self namedTempAt: index ]! ! !MethodContext methodsFor: '*DebuggerModel' stamp: 'AndreiChis 7/20/2013 09:18'! messageName "Answer the message selector of this context. If the method is unbound we can still usefully answer its old selector." | selector | selector := self methodSelector. ^(selector ~~ self method selector and: [selector beginsWith: 'DoIt']) ifTrue: [self method selector] ifFalse: [selector]! ! !MethodContext methodsFor: 'instruction decoding' stamp: 'jannik.laval 5/1/2010 16:19'! blockReturnTop "Simulate the interpreter's action when a ReturnTopOfStackToCaller bytecode is encountered in the receiver. This should only happen in a closure activation." [closureOrNil isClosure] assert. ^self return: self pop from: self! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 8/20/2008 09:28'! tempAt: index "Answer the value of the temporary variable whose index is the argument, index. Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive. Override the default at: primitive to give latitude to the VM in context management." ^self at: index! ! !MethodContext methodsFor: '*FuelTests' stamp: 'MarianoMartinezPeck 5/22/2011 23:07'! initializeWith: aPc stackPtr: aStackPtr method: aMethod receiver: aReceiver sender: aSender pc := aPc. stackp := aStackPtr. method := aMethod. receiver := aReceiver. sender := aSender. ! ! !MethodContext methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 21:57'! instVarAt: index put: value index = 3 ifTrue: [ self stackp: value. ^ value]. ^ super instVarAt: index put: value! ! !MethodContext methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 5/2/2012 22:15'! tempNamed: aName put: anObject ^self namedTempAt: (self tempNames indexOf: aName) put: anObject! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'ar 6/28/2003 00:10'! restartWithNewReceiver: obj self swapReceiver: obj; restart! ! !MethodContext methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitMethodContext: self! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 7/22/2008 11:57'! closure ^closureOrNil! ! !MethodContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/10/2013 21:36'! activeOuterContext "If executing closure, search senders for the activation in which the receiver's closure was created (the receiver's outerContext). If the outerContext is not found on the sender chain answer nil." | outerContext | self isBlockContext ifFalse: [^self]. self sender ifNil: [^nil]. outerContext := self outerContext. ^self sender findContextSuchThat: [:ctxt | ctxt = outerContext]! ! !MethodContext methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2013 21:59'! printOn: aStream self outerContext ifNil: [super printOn: aStream] ifNotNil: [ :outerContext | aStream nextPutAll: closureOrNil printString,' in '. outerContext printOn: aStream ]! ! !MethodContext methodsFor: 'accessing' stamp: 'ClementBera 9/27/2013 17:56'! outerContext "Answer the context within which the receiver is nested." ^closureOrNil ifNotNil: [closureOrNil outerContext]! ! !MethodContext methodsFor: '*OpalCompiler-Core' stamp: 'CamilleTeruel 2/14/2014 15:16'! isBlockReturn: aPC ^ (self method at: aPC) = 125! ! !MethodContext methodsFor: '*OpalCompiler-Core' stamp: 'CamilleTeruel 2/14/2014 16:15'! sourceNode "Return the source node of the method or the block corresponding to the receiver" ^ (method sourceNodeForPC: self neighborPCWithCorrectMapping) enclosingMethodOrBlockNode "Uncomment the following once the pc->AST mapping is fixed" "^ (method sourceNodeForPC: (pc ifNil: [ self startpc ])) enclosingMethodOrBlockNode"! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'CamilloBruni 7/17/2013 22:01'! swapReceiver: newReceiver receiver := newReceiver! ! !MethodContext methodsFor: 'initialize-release' stamp: 'jannik.laval 5/1/2010 16:19'! privRefreshWith: aCompiledMethod "Reinitialize the receiver as though it had been for a different method. Used by a Debugger when one of the methods to which it refers is recompiled." aCompiledMethod isCompiledMethod ifFalse: [self error: 'method can only be set to aCompiledMethod']. method := aCompiledMethod. [closureOrNil == nil] assert. "was: receiverMap := nil." self privRefresh! ! !MethodContext methodsFor: 'private' stamp: 'eem 7/22/2008 12:00'! startpc ^closureOrNil ifNil: [self method initialPC] ifNotNil: [closureOrNil startpc]! ! !MethodContext methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2013 21:58'! printDetails: stream "Put my class>>selector and instance variables and arguments and temporaries on the stream. Protect against errors during printing." | errorMessage string position | self printOn: stream. stream cr. stream tab; nextPutAll: 'Receiver: '. errorMessage := '<>'. stream nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [errorMessage]). stream cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. string := [(self tempsAndValuesLimitedTo: 80 indent: 2) padRightTo:1 with: $x] ifError: [errorMessage]. stream nextPutAll: (string allButLast). stream cr; tab; nextPutAll: 'Receiver''s instance variables: '; cr. position := stream position. [receiver longPrintOn: stream limitedTo: 80 indent: 2] ifError: [ stream nextPutAll: errorMessage]. position = stream position ifTrue: ["normal printString for an Array (it has no inst vars)" stream nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [errorMessage])]. stream peekLast == Character cr ifFalse: [stream cr].! ! !MethodContext methodsFor: 'private' stamp: 'eem 4/25/2012 10:48'! aboutToReturn: result through: firstUnwindContext "Called from VM when an unwindBlock is found between self and its home. Return to home's sender, executing unwind blocks on the way." self methodReturnContext return: result through: firstUnwindContext! ! !MethodContext methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 22:01'! setSender: newSender receiver: newReceiver method: newMethod arguments: arguments "Create the receiver's initial state." sender := newSender. receiver := newReceiver. method := newMethod. closureOrNil := nil. pc := method initialPC. self stackp: method numTemps. 1 to: arguments size do: [ :i | self at: i put: (arguments at: i)]! ! !MethodContext methodsFor: 'accessing' stamp: ''! method ^method! ! !MethodContext methodsFor: 'instruction decoding' stamp: 'CamilloBruni 7/17/2013 22:00'! pushConsArrayWithElements: numElements | array | array := Array new: numElements. numElements to: 1 by: -1 do: [ :i | array at: i put: self pop ]. self push: array! ! !MethodContext methodsFor: 'testing' stamp: 'SeanDeNigris 5/24/2013 11:07'! callChainAnySatisfy: aBlock (aBlock value: self) ifTrue: [ ^ true ]. self sender ifNil: [ ^ false ]. ^ self sender callChainAnySatisfy: aBlock.! ! !MethodContext methodsFor: 'accessing' stamp: 'MarcusDenker 5/10/2013 21:36'! activeHome "If executing closure, search senders for the activation of the original (outermost) method that (indirectly) created my closure (the closureHome). If the closureHome is not found on the sender chain answer nil." | methodReturnContext | self isBlockContext ifFalse: [^self]. self sender ifNil: [^nil]. methodReturnContext := self methodReturnContext. ^self sender findContextSuchThat: [:ctxt | ctxt = methodReturnContext]! ! !MethodContext methodsFor: '*DebuggerModel' stamp: 'AndreiChis 7/20/2013 09:22'! classOrMetaClass ^ self methodClass! ! !MethodContext methodsFor: 'accessing' stamp: ''! receiver "Refer to the comment in ContextPart|receiver." ^receiver! ! !MethodContext methodsFor: '*OpalCompiler-Core' stamp: 'CamilleTeruel 2/14/2014 16:04'! neighborPCWithCorrectMapping "Answer a pc inside the enclosing block or mathod that is correctly mapped to an AST node" "This is an ugly and temporary fix for Pharo 3. Must be removed as soon as mappings are fixed" | neighborPC | neighborPC := self isDead ifTrue: [ self startpc ] ifFalse: [ pc ]. "There is a pushLiteral: nil bytecode for each temps in a block. There is a 'pushTemp:' bytecode for each copied value of a block. These bytecodes are not mapped to any IR. We skip both" [ self isPushLiteralNil: neighborPC ] whileTrue: [ neighborPC := neighborPC + 1 ]. [ self isPushTemp: neighborPC ] whileTrue: [ neighborPC := neighborPC + 1 ]. "The block return ir instruction is mapped to the block instead of the sequence AST node. So we go just before it" (self isBlockReturn: neighborPC) ifTrue: [ neighborPC := neighborPC - 1 ]. ^ neighborPC! ! !MethodContext methodsFor: '*FuelTests' stamp: 'MarianoMartinezPeck 4/20/2012 21:40'! assertWellMaterializedInto: aMethodContext in: aTestCase aTestCase assert: self ~~ aMethodContext. aTestCase assert: (self class == aMethodContext class). aTestCase assert: self tempNames = aMethodContext tempNames. aTestCase assert: pc = aMethodContext pc. aTestCase assert: stackp = aMethodContext stackPtr. closureOrNil isNil ifTrue: [ aTestCase assert: aMethodContext closure isNil ] ifFalse: [ closureOrNil assertWellMaterializedInto: aMethodContext closure in: aTestCase ]. aTestCase assert: receiver = aMethodContext receiver. aTestCase assert: (method isEqualRegardlessTrailerTo: aMethodContext method). sender isNil ifTrue: [ aTestCase assert: aMethodContext sender isNil ] ifFalse: [ sender assertWellMaterializedInto: aMethodContext sender in: aTestCase ]! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 7/22/2008 11:58'! methodReturnContext "Answer the context from which an ^-return should return from." closureOrNil == nil ifTrue: [^self]. ^closureOrNil outerContext methodReturnContext! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 4/26/2012 10:51'! numArgs "Answer the number of arguments for this activation." ^closureOrNil ifNil: [method numArgs] ifNotNil: [closureOrNil numArgs]! ! !MethodContext methodsFor: 'accessing' stamp: 'md 4/27/2006 15:12'! hasInstVarRef "Answer whether the receiver references an instance variable." ^self method hasInstVarRef.! ! !MethodContext methodsFor: 'private' stamp: 'CamilloBruni 7/17/2013 22:01'! setSender: newSender receiver: newReceiver method: newMethod closure: newClosure startpc: startpc "Create the receiver's initial state." sender := newSender. receiver := newReceiver. method := newMethod. closureOrNil := newClosure. pc := startpc. stackp := 0! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 4/26/2012 10:58'! numTemps "Answer the number of temporaries for this activation; this includes the number of arguments, and for blocks, the number of copied values." ^closureOrNil ifNil: [method numTemps] ifNotNil: [closureOrNil numTemps]! ! !MethodContext methodsFor: 'accessing' stamp: ''! removeSelf "Nil the receiver pointer and answer its former value." | tempSelf | tempSelf := receiver. receiver := nil. ^tempSelf! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'CamilloBruni 7/17/2013 21:58'! isUnwindContext "is this context for method that is marked?" ^method primitive = 198! ! !MethodContext methodsFor: '*OpalCompiler-Core' stamp: 'CamilleTeruel 2/14/2014 15:42'! isPushTemp: aPC ^ (self method at: aPC) between: 16 and: 31! ! !MethodContext class methodsFor: 'hacks' stamp: 'ar 9/17/2008 16:24'! allInstancesDo: aBlock "Only count until thisContext" | inst next | inst := self someInstance. [inst == thisContext] whileFalse:[ next := inst nextInstance. aBlock value: inst. inst := next]! ! !MethodContext class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:06'! sender: s receiver: r method: m arguments: args "Answer an instance of me with attributes set to the arguments." ^(self newForMethod: m) setSender: s receiver: r method: m arguments: args! ! !MethodContext class methodsFor: '*Spec-Inspector' stamp: 'TorstenBergmann 2/4/2014 21:31'! inspectorClass ^ EyeMethodContextInspector! ! !MethodContextTest commentStamp: 'tlk 5/31/2004 16:07'! I am an SUnit Test of MethodContext and its super type, ContextPart. See also BlockContextTest. See pages 430-437 of A. Goldberg and D. Robson's Smalltalk-80 The Language (aka the purple book), which deal with Contexts. My fixtures are from their example. (The Squeak byte codes are not quite the same as Smalltalk-80.) My fixtures are: aReceiver - just some arbitrary object, "Rectangle origin: 100@100 corner: 200@200" aSender - just some arbitrary object, thisContext aCompiledMethod - just some arbitrary method, "Rectangle rightCenter". aMethodContext - just some arbitray context ... ! !MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 17:08'! testMethodIsBottomContext self assert: aMethodContext bottomContext = aSender. self assert: aMethodContext secondFromBottom = aMethodContext.! ! !MethodContextTest methodsFor: 'tests' stamp: 'md 2/9/2007 19:08'! testTempNamedPut | oneTemp | oneTemp := 1. self assert: (thisContext tempNamed: 'oneTemp') = oneTemp. thisContext tempNamed: 'oneTemp' put: 2. self assert: (thisContext tempNamed: 'oneTemp') = 2.! ! !MethodContextTest methodsFor: 'tests' stamp: 'MarcusDenker 3/8/2012 17:19'! testClosureRestart "Test that various combinations of closures are restarted with the expected values" "no args, no remote temps blocks are not tested, as I don't know how to do that programatically without ending up looping endlessly" self should: [self privRestartBlockTest] notTakeMoreThan: 0.1 second. self should: [self privRestartArgBlockTest] notTakeMoreThan: 0.1 second. "self should: [self privRestartBlockArgsNoRemoteTempsTest] notTakeMoreThan: 0.1 second" "FAILING!!"! ! !MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 17:10'! testFindContextSuchThat self assert: (aMethodContext findContextSuchThat: [:each| true]) printString = aMethodContext printString. self assert: (aMethodContext hasContext: aMethodContext). ! ! !MethodContextTest methodsFor: 'running' stamp: 'tlk 5/31/2004 16:18'! setUp super setUp. aCompiledMethod := Rectangle methodDict at: #rightCenter. aReceiver := 100@100 corner: 200@200. aSender := thisContext. aMethodContext := MethodContext sender: aSender receiver: aReceiver method: aCompiledMethod arguments: #(). ! ! !MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/30/2004 13:35'! testActivateReturnValue self assert: ((aSender activateReturn: aMethodContext value: #()) isKindOf: MethodContext). self assert: ((aSender activateReturn: aMethodContext value: #()) receiver = aMethodContext).! ! !MethodContextTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/30/2012 12:13'! testSetUp "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" self deny: aMethodContext isDead. self assert: aMethodContext home = aMethodContext. self assert: aMethodContext receiver = aReceiver. self assert: (aMethodContext method isKindOf: CompiledMethod). self assert: aMethodContext method = aCompiledMethod. self assert: aMethodContext methodNode selector = #rightCenter. self assert: aMethodContext client printString = 'MethodContextTest>>#testSetUp'. ! ! !MethodContextTest methodsFor: 'private' stamp: 'StephaneDucasse 5/28/2011 14:04'! privRestartArgBlockTest "This tests may loop endlessly if incorrect, so call it from another method testing it does not time out" |firstTimeThrough | firstTimeThrough := true. self assert: 30 equals: ([:a | |b| self assert: 10 = a . self assert: nil == b. b := a + 20. firstTimeThrough ifTrue: [ firstTimeThrough := false. thisContext restart.]. b] value: 10) ! ! !MethodContextTest methodsFor: 'private' stamp: 'StephaneDucasse 5/28/2011 14:04'! privRestartBlockTest "This tests may loop endlessly if incorrect, so call it from another method testing it does not time out" |a firstTimeThrough | firstTimeThrough := true. a := 10. self assert: 30 equals: [|b| self assert: 10 = a . self assert: nil == b. b := a + 20. firstTimeThrough ifTrue: [ firstTimeThrough := false. thisContext restart.]. b] value ! ! !MethodContextTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/30/2012 12:13'! testMethodContext self assert: aMethodContext home notNil. self assert: aMethodContext receiver notNil. self assert: (aMethodContext method isKindOf: CompiledMethod).! ! !MethodContextTest methodsFor: 'private' stamp: 'StephaneDucasse 5/28/2011 14:04'! privRestartBlockArgsNoRemoteTempsTest "This tests may loop endlessly if incorrect, so call it from another method testing it does not time out" self assert: 30 equals: ([:a :first | |b| self assert: 10 = a . self assert: nil == b. b := a + 20. first ifTrue: [ "Cheat and modify one of the args so we will not loop endlessly" thisContext tempAt: 2 put: false. thisContext restart.]. b] value: 10 value: true) ! ! !MethodContextTest methodsFor: 'tests' stamp: 'mada 5/3/2012 18:57'! testTempNamed | oneTemp context | oneTemp := 1. self assert: (thisContext tempNamed: 'oneTemp') = oneTemp. context := self class contextWithTempForTesting. self assert: (context tempNamed: 'string') = 'test' ! ! !MethodContextTest methodsFor: 'tests' stamp: 'tlk 5/31/2004 16:55'! testReturn "Why am I overriding setUp? Because sender must be thisContext, i.e, testReturn, not setUp." aMethodContext := MethodContext sender: thisContext receiver: aReceiver method: aCompiledMethod arguments: #(). self assert: (aMethodContext return: 5) = 5.! ! !MethodContextTest class methodsFor: 'closures for testing' stamp: 'mada 5/3/2012 18:57'! contextWithTempForTesting | string | string := 'test'. ^ [self class. string asUppercase] asContext. ! ! !MethodDeclaration commentStamp: ''! I represent the declaration of a method. My contents are the source code to import, and the category reader is the object who knows the class, category and timestamp where to install the method. Sending me the message #import makes me install the method into the class.! !MethodDeclaration methodsFor: 'importing' stamp: 'StephaneDucasse 12/1/2013 21:56'! importFor: requestor self existsBehavior ifFalse: [ self handleMissingBehavior ]. requestor ifNotNil: [ requestor contents ifNil: [ requestor contents: contents ] ]. ^ self targetClass compile: contents classified: categoryName withStamp: stamp notifying: requestor! ! !MethodDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 20:13'! stamp: aMethodStamp stamp := aMethodStamp! ! !MethodDeclaration methodsFor: 'importing' stamp: 'StephaneDucasse 12/4/2013 20:19'! handleMissingBehavior "self error: ('Cannot install method in unexistent behavior {1}' format: {(behaviorName asString)})" (MissingClassError className: behaviorName asString) signal! ! !MethodDeclaration methodsFor: 'importing' stamp: 'CamilloBruni 7/17/2013 15:23'! import ^ self importFor: nil! ! !MethodDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 20:13'! category: aCategoryName categoryName := aCategoryName! ! !MethodDeclaration class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 20:40'! contents: someContents behaviorName: behaviorName isMeta: isMeta category: categoryName stamp: stamp ^self new contents: someContents; behaviorName: behaviorName; isMeta: isMeta; category: categoryName; stamp: stamp; yourself! ! !MethodDefaultAction commentStamp: ''! Action by default, empty icon! !MethodDefaultAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 13:04'! actionStateToCache "Return the state of the icon for caching purpose" ^ icon! ! !MethodDefaultAction methodsFor: 'order' stamp: 'EstebanLorenzano 5/14/2013 09:44'! privateActionIcon "Return the icon for this action" ^ Smalltalk ui icons iconNamed: #emptyIcon! ! !MethodDefaultAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 13:04'! isActionHandled "Return true if the provided method fits this action requirement" ^ true! ! !MethodDefaultAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:57'! actionOrder "Return the priority of this action" ^ 9999999999999999999999999999! ! !MethodDefinitionAcceptor commentStamp: ''! I am an acceptor in the context of method definition! !MethodDefinitionAcceptor methodsFor: 'protocol' stamp: 'EstebanLorenzano 5/28/2013 14:39'! accept: source notifying: aController | protocol method | protocol := self model selectedCategory. method := self model selectedMethod. protocol ifNil: [ protocol := method ifNil: [ Protocol unclassified ] ifNotNil: [ method protocol ] ]. self model compileAMethodFromCategory: protocol withSource: source notifying: aController! ! !MethodDictionary commentStamp: 'StephaneDucasse 2/27/2010 22:35'! I'm a special dictionary holding methods. I am just like a normal Dictionary, except that I am implemented differently. Each Class has an instance of MethodDictionary to hold the correspondence between selectors (names of methods) and methods themselves. In a normal Dictionary, the instance variable 'array' holds an array of Associations. Since there are thousands of methods in the system, these Associations waste space. Each MethodDictionary is a variable object, with the list of keys (selector Symbols) in the variable part of the instance. The variable 'array' holds the values, which are CompiledMethods.! !MethodDictionary methodsFor: 'removing' stamp: 'MarianoMartinezPeck 9/27/2011 20:08'! removeAll "Remove all elements from this collection. Preserve the capacity" | newSelf | tally = 0 ifTrue: [^self]. newSelf := self species newForCapacity: self basicSize. self copyFrom: newSelf! ! !MethodDictionary methodsFor: 'private' stamp: 'MarcusDenker 9/30/2011 10:19'! grow | newSelf | newSelf := self species newForCapacity: self basicSize * 2. 1 to: self basicSize do: [:i | (self basicAt: i) ifNotNil: [ :key | newSelf at: key put: (array at: i)]]. self becomeForward: newSelf! ! !MethodDictionary methodsFor: 'testing' stamp: 'StephaneDucasse 5/28/2011 14:00'! isHealthy "Test that selector hashes match their positions stored in dictionary, answer true if everything ok, false otherwise MethodDictionary allInstances select: [:dict | dict isHealthy not ] " 1 to: self basicSize do: [:i | | selector | selector := self basicAt: i. selector ifNotNil: [ (self scanFor: selector) == i ifFalse: [ ^ false ]]]. ^ true! ! !MethodDictionary methodsFor: 'private' stamp: 'ul 11/13/2009 13:46'! swap: oneIndex with: otherIndex | element | element := self basicAt: oneIndex. self basicAt: oneIndex put: (self basicAt: otherIndex). self basicAt: otherIndex put: element. array swap: oneIndex with: otherIndex ! ! !MethodDictionary methodsFor: 'private' stamp: 'MarianoMartinezPeck 9/18/2011 19:14'! compactWithoutBecome "Return a copy of self which has the highest possible load factor (between 37.5% and 75%)." | newInstance | newInstance := self species new: self size. 1 to: self basicSize do: [ :index | (self basicAt: index) ifNotNil: [ :key | newInstance at: key put: (array at: index) ] ]. ^newInstance! ! !MethodDictionary methodsFor: 'private' stamp: 'MarianoMartinezPeck 9/27/2011 20:07'! rehash | newInstance | newInstance := self species newForCapacity: self basicSize. 1 to: self basicSize do: [ :index | (self basicAt: index) ifNotNil: [ :key | newInstance at: key put: (array at: index) ] ]. self copyFrom: newInstance! ! !MethodDictionary methodsFor: 'private' stamp: 'GuillermoPolito 8/21/2010 19:19'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | element start finish | finish := array size. start := (anObject basicIdentityHash \\ finish) + 1. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element := self basicAt: index) isNil or: [element == anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element := self basicAt: index) isNil or: [element == anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !MethodDictionary methodsFor: 'enumeration' stamp: 'StephaneDucasse 8/25/2010 22:15'! associationsDo: aBlock tally = 0 ifTrue: [^ self]. 1 to: self basicSize do: [:i | (self basicAt: i) ifNotNil: [ :key | aBlock value: (Association key: key value: (array at: i))]]! ! !MethodDictionary methodsFor: 'accessing' stamp: 'GuillermoPolito 8/21/2010 19:16'! keyAtValue: value ifAbsent: exceptionBlock "Answer the key whose value equals the argument, value. If there is none, answer the result of evaluating exceptionBlock." 1 to: self basicSize do: [:index | value = (array at: index) ifTrue: [(self basicAt: index) ifNotNil: [ :theKey | ^ theKey]]]. ^ exceptionBlock value! ! !MethodDictionary methodsFor: '*FuelTests' stamp: 'MarianoMartinezPeck 4/20/2012 21:29'! isEqualRegardlessMethodsTrailerTo: aMethodDictionary "Two dictionaries are equal if (a) they are the same 'kind' of thing. (b) they have the same set of keys. (c) for each (common) key, they have the same value" self == aMethodDictionary ifTrue: [ ^ true ]. (aMethodDictionary isDictionary) ifFalse: [^false]. self size = aMethodDictionary size ifFalse: [^false]. self associationsDo: [:assoc| ((aMethodDictionary at: assoc key ifAbsent: [^false]) isEqualRegardlessTrailerTo: assoc value) ifFalse: [^false]]. ^true ! ! !MethodDictionary methodsFor: 'removing' stamp: 'MarianoMartinezPeck 9/18/2011 18:52'! removeKey: key ifAbsent: errorBlock "The interpreter might be using this MethodDictionary while this method is running!! Therefore we perform the removal in a copy, and then atomically copy that copy" | copy removedValue | copy := self copy. removedValue := copy removeDangerouslyKey: key ifAbsent: [^ errorBlock value]. self copyFrom: copy. ^ removedValue! ! !MethodDictionary methodsFor: 'accessing' stamp: 'nice 5/1/2011 18:39'! at: key ifPresent: aBlock ^(array at: (self findElementOrNil: key)) ifNotNil: [ :value | aBlock cull: value ]! ! !MethodDictionary methodsFor: 'accessing' stamp: 'MarcusDenker 8/16/2010 12:49'! associationAt: key ifAbsent: aBlock "Answer the association with the given key. If key is not found, return the result of evaluating aBlock." ^(array at: (self scanFor: key)) ifNil: [ aBlock value ] ifNotNil: [ :value | key -> value ]! ! !MethodDictionary methodsFor: 'enumeration' stamp: 'GuillermoPolito 8/21/2010 19:17'! keysDo: aBlock tally = 0 ifTrue: [^ self]. 1 to: self basicSize do: [:i | (self basicAt: i) ifNotNil: [ :key | aBlock value: key]]! ! !MethodDictionary methodsFor: 'accessing' stamp: 'StephaneDucasse 8/25/2010 22:14'! add: anAssociation ^ self at: anAssociation key put: anAssociation value! ! !MethodDictionary methodsFor: 'accessing' stamp: 'GuillermoPolito 8/21/2010 19:14'! at: key ifAbsent: aBlock | index | index := self findElementOrNil: key. (self basicAt: index) ifNil: [ ^ aBlock value ]. ^ array at: index! ! !MethodDictionary methodsFor: 'private' stamp: 'MarianoMartinezPeck 9/18/2011 19:13'! compact "Make sure that I have the highest possible load factor (between 37.5% and 75%)." | newInstance | newInstance := self compactWithoutBecome. newInstance capacity = self capacity ifTrue: [ self copyFrom: newInstance ] ifFalse: [ self becomeForward: newInstance ]! ! !MethodDictionary methodsFor: 'enumeration' stamp: 'GuillermoPolito 8/21/2010 19:17'! valuesDo: aBlock tally = 0 ifTrue: [^ self]. 1 to: self basicSize do: [:i | (array at: i) ifNotNil: [ :value | aBlock value: value]]! ! !MethodDictionary methodsFor: 'accessing' stamp: 'GuillermoPolito 8/21/2010 19:15'! at: key put: value "Set the value at key to be value." | index | index := self findElementOrNil: key. (self basicAt: index) ifNil: [tally := tally + 1. self basicAt: index put: key] ifNotNil: [(array at: index) flushCache]. array at: index put: value. self fullCheck. ^ value! ! !MethodDictionary methodsFor: 'private' stamp: 'StephaneDucasse 8/25/2010 22:01'! postCopy array := array copy! ! !MethodDictionary methodsFor: 'private' stamp: 'GuillermoPolito 8/21/2010 19:19'! removeDangerouslyKey: key ifAbsent: aBlock "This is not really dangerous. But if normal removal were done WHILE a MethodDict were being used, the system might crash. So instead we make a copy, then do this operation (which is NOT dangerous in a copy that is not being used), and then use the copy after the removal." | index element | index := self findElementOrNil: key. (self basicAt: index) ifNil: [ ^ aBlock value ]. element := array at: index. array at: index put: nil. self basicAt: index put: nil. tally := tally - 1. self fixCollisionsFrom: index. ^ element! ! !MethodDictionary methodsFor: 'enumeration' stamp: 'GuillermoPolito 8/21/2010 19:16'! keysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values passed to the block" tally = 0 ifTrue: [^ self]. 1 to: self basicSize do: [:i | (self basicAt: i) ifNotNil: [ :key | aBlock value: key value: (array at: i)] ]! ! !MethodDictionary methodsFor: 'accessing' stamp: 'GuillermoPolito 8/21/2010 19:15'! keyAtIdentityValue: value ifAbsent: exceptionBlock "Answer the key whose value equals the argument, value. If there is none, answer the result of evaluating exceptionBlock." 1 to: self basicSize do: [:index | value == (array at: index) ifTrue: [(self basicAt: index) ifNotNil: [ :theKey | ^ theKey]]]. ^ exceptionBlock value! ! !MethodDictionary methodsFor: 'private' stamp: 'nice 11/14/2009 15:33'! fixCollisionsFrom: start "The element at start has been removed and replaced by nil. This method moves forward from there, relocating any entries that had been placed below due to collisions with this one." | key index | index := start. [ (key := self basicAt: (index := index \\ array size + 1)) == nil ] whileFalse: [ | newIndex | (newIndex := self findElementOrNil: key) = index ifFalse: [ self swap: index with: newIndex ] ]! ! !MethodDictionary class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 9/27/2011 20:06'! new: numberOfElements "Create an instance large enough to hold numberOfElements methods without growing." ^self newForCapacity: (self sizeFor: numberOfElements)! ! !MethodDictionary class methodsFor: 'initialization' stamp: 'MarianoMartinezPeck 9/18/2011 19:05'! compactAllInstances | instancesToExchange newInstances | instancesToExchange := Array streamContents: [ :oldStream | newInstances := Array streamContents: [ :newStream | self allInstances do: [ :each | | newInstance | newInstance := each compactWithoutBecome. newInstance capacity = each capacity ifTrue: [ each copyFrom: newInstance ] ifFalse: [ oldStream nextPut: each. newStream nextPut: newInstance ] ] ] ]. instancesToExchange elementsForwardIdentityTo: newInstances! ! !MethodDictionary class methodsFor: 'sizing' stamp: 'MarianoMartinezPeck 1/18/2012 19:11'! sizeFor: numberOfElements "Return the minimum capacity of a dictionary that can hold numberOfElements elements. At least 25% of the array must be empty and the return value must be a nonnegative power of 2. Notice that the max: 1 is because a MethodDictionaries can never be entirely empty, as the #grow method requires it not to be (since it does self basicSize * 2)" ^(numberOfElements * 4 // 3 max: 1) asLargerPowerOfTwo ! ! !MethodDictionary class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 9/27/2011 20:05'! new "Create a new instance with 32 slots, which can hold at most 24 methods before growing is necessary." ^self newForCapacity: 32! ! !MethodDictionary class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 9/27/2011 20:06'! newForCapacity: capacity "Create an instance with the given capacity which must be a power of two." ^(self basicNew: capacity) initialize: capacity ! ! !MethodDictionaryTest commentStamp: 'TorstenBergmann 2/5/2014 08:40'! SUnit tests for MethodDictionary! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:31'! emptyDict ^ self empty! ! !MethodDictionaryTest methodsFor: 'test - removing' stamp: ''! testKeysAndValuesRemove | oldSize collection keyIn | collection := self nonEmptyDict . oldSize := collection size. keyIn := collection keys anyOne. collection keysAndValuesRemove: [:key :value | key == self keyNotInNonEmptyDict ]. self assert: (collection size = (oldSize )). collection keysAndValuesRemove: [:key :value | key == keyIn ]. self assert: (collection size = (oldSize - 1)). self should: [ collection at: keyIn ] raise: Error.! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:15'! testAtExistantKeyReturnsOkCompiledMethod | methodSelector method | methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation. method := self class methodDict at: methodSelector ifAbsent: [self error]. self assert: method class = CompiledMethod.! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'TestRunner 12/25/2009 08:30'! nonEmptyDict ^ nonEmptyDict ! ! !MethodDictionaryTest methodsFor: 'tests' stamp: 'TestRunner 12/25/2009 08:23'! testKeyAtValueIfAbsentLocalyDefined " self debug: #testKeyAtValueIfAbsentLocalyDefined " self assert: (self class methodDict keyAtValue: (self class >> #testKeyAtValueIfAbsentLocalyDefined) ifAbsent: []) == #testKeyAtValueIfAbsentLocalyDefined. self assert: (self class methodDict keyAtValue: (Object >> #printOn:) ifAbsent: [#notFound]) == #notFound! ! !MethodDictionaryTest methodsFor: 'setUps' stamp: 'GuillermoPolito 8/28/2010 19:59'! modifiedMethodDictionaryCopy | copy | copy := self class methodDict copy. copy at: #methodAddedToIncreaseTheDict put: Object >> #=. ^copy.! ! !MethodDictionaryTest methodsFor: 'tests - Dictionary keys values associations access' stamp: ''! testKeysSortedSafely | collection result | collection := self nonEmpty. result := collection keysSortedSafely. result do: [ :key | collection at: key ]. self assert: result size = collection size. self should: [ result detect: [ :each | (result occurrencesOf: each) > 1 ] ] raise: Error. self assert: result asArray isSorted! ! !MethodDictionaryTest methodsFor: 'helpers' stamp: 'Alexandre Bergel 12/25/2009 08:21'! aValue ^ self class >> #aValue! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:25'! empty ^ MethodDictionary new! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'TestRunner 12/25/2009 08:37'! keyNotInNonEmptyDict " return a key not included in nonEmptyDict" ^ #keyNotInNonEmptyDict! ! !MethodDictionaryTest methodsFor: 'test - removing' stamp: ''! testRemoveKeyIfAbsent | collection oldSize keyIn value result | collection := self nonEmptyDict . oldSize := collection size. keyIn := collection keys anyOne. value := collection at: keyIn . result := collection removeKey: keyIn ifAbsent: [888]. self assert: result = value. self assert: (collection size = (oldSize - 1)). self should: [ (collection at: keyIn )] raise: Error. self assert: (collection removeKey: self keyNotInNonEmptyDict ifAbsent: [888] ) = 888.! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:31'! newEmptyDict ^ MethodDictionary new! ! !MethodDictionaryTest methodsFor: 'test - removing' stamp: ''! testRemoveKey "self debug: #testRemoveKey" | collection oldSize keyIn | collection := self nonEmptyDict . oldSize := collection size. keyIn := collection keys anyOne. collection removeKey: keyIn . self assert: (collection size = (oldSize - 1)). self should: [ (collection at: keyIn )] raise: Error. self should: [collection removeKey: self keyNotInNonEmptyDict ] raise: Error! ! !MethodDictionaryTest methodsFor: 'tests' stamp: 'MarcusDenker 5/10/2013 00:25'! testIncludesKeyLocalyDefined " self debug: #testIncludesKeyLocalyDefined " self assert: (self class includesSelector: #testIncludesKeyLocalyDefined).! ! !MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !MethodDictionaryTest methodsFor: 'tests - Dictionary keys values associations access' stamp: ''! testAssociations | collection result | collection := self nonEmpty . result := collection associations. self assert: result size = collection size. result do: [:assoc | self assert: (assoc value) = (collection at: assoc key) ]. "keys do: [ :key | self assert: ( result at: key ) = ( collection at: key )] ." ! ! !MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !MethodDictionaryTest methodsFor: 'assertions' stamp: 'GuillermoPolito 8/28/2010 19:53'! assertPreservesCapacity: oldDictionary comparedTo: rehashedDictionary self assert: oldDictionary capacity = rehashedDictionary capacity.! ! !MethodDictionaryTest methodsFor: 'tests - Dictionary keys values associations access' stamp: ''! testValues | collection result | collection := self nonEmpty . result := collection values. self assert: result size = collection size. result do: [:each | self assert: (collection occurrencesOf:each ) = (result occurrencesOf: each) ]. ! ! !MethodDictionaryTest methodsFor: 'tests - integrity' stamp: 'CamilloBruni 3/23/2013 12:09'! testAllMethodDictionariesAreHealthy self assert: (MethodDictionary allInstances select: [:dict | dict isHealthy not ]) isEmpty.! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:33'! testIdentityKeyAtNonExistantValueReturnsFailBlock | methodSelector result aMethod error | methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation. error := #error. result := self class methodDict keyAtIdentityValue: self ifAbsent: [error]. self assert: result = error.! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:29'! testKeyAtExistantValueCopyReturnsOkKey | methodSelector result aMethod | methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation. aMethod := (self class >> methodSelector) copy. result := self class methodDict keyAtValue: aMethod ifAbsent: [self error]. self assert: result = methodSelector.! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:28'! testKeyAtNonexistantValueExecutesFailBlock | methodSelector result error | methodSelector := #inexistant:method:larala:. error := #error. result := self class methodDict keyAtValue: self ifAbsent: [error]. self assert: result = error.! ! !MethodDictionaryTest methodsFor: 'tests - Dictionary keys values associations access' stamp: ''! testKeys | collection result | collection := self nonEmpty. result := collection keys. result do: [ :key | collection at: key ]. self assert: result size = collection size. self should: [ result detect: [ :each | (result occurrencesOf: each) > 1 ] ] raise: Error! ! !MethodDictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryKeysValuesAssociationsAccess self nonEmpty. self deny: self nonEmpty isEmpty! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:33'! testIdentityKeyAtExistantValueReturnsOkKey | methodSelector result aMethod | methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation. aMethod := self class >> methodSelector. result := self class methodDict keyAtIdentityValue: aMethod ifAbsent: [self error]. self assert: result = methodSelector.! ! !MethodDictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureDictionaryRemovingTest self nonEmptyDict. self deny: self nonEmptyDict isEmpty. self keyNotInNonEmptyDict. self deny: (self nonEmptyDict keys includes: self keyNotInNonEmptyDict)! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:22'! testGrowPreservesElements | methodDictionary oldCapacity growedMethodDictionary | methodDictionary := self class methodDict copy. growedMethodDictionary := methodDictionary copy; grow; yourself. self assertPreservesElements: methodDictionary comparedTo: growedMethodDictionary. self assertPreservesElements: growedMethodDictionary comparedTo: methodDictionary.! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:29'! anotherElementNotIn " return an element different of 'elementNotIn' not included in 'nonEmpty' " ^ self class >> #anotherElementNotIn! ! !MethodDictionaryTest methodsFor: 'helpers' stamp: 'Alexandre Bergel 12/25/2009 08:21'! anotherValue ^ self class >> #anotherValue! ! !MethodDictionaryTest methodsFor: 'tests - rehashing' stamp: 'MarianoMartinezPeck 9/27/2011 20:09'! testRehashPreservesElements | oldDictionary rehashedDictionary | oldDictionary := self modifiedMethodDictionaryCopy. rehashedDictionary := oldDictionary copy rehash. self assertPreservesElements: oldDictionary comparedTo: rehashedDictionary. self assertPreservesElements: rehashedDictionary comparedTo: oldDictionary.! ! !MethodDictionaryTest methodsFor: 'assertions' stamp: 'GuillermoPolito 8/28/2010 21:09'! assertPreservesElements: oldDictionary comparedTo: newDictionary self assert: (oldDictionary keys allSatisfy: [ :key | (newDictionary includesKey: key) & ((newDictionary at: key) == (oldDictionary at: key)) ])! ! !MethodDictionaryTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeTest | anElementIn | self nonEmpty. self deny: self nonEmpty isEmpty. self elementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self anotherElementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self empty. self assert: self empty isEmpty! ! !MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotIn). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotIn)! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'TestRunner 12/25/2009 08:35'! keyNotIn " return a key not included in nonEmpty" ^ #bouba! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:16'! testAssociationAtNonexistantKeyExecutesFailBlock | methodSelector result error | methodSelector := #inexistant:method:larala:. error := #error. result := self class methodDict associationAt: methodSelector ifAbsent: [error]. self assert: result = error.! ! !MethodDictionaryTest methodsFor: 'tests' stamp: 'MarcusDenker 2/21/2010 12:52'! testBehaviorLocalyDefined "method not acquired from a trait or from its superclass" " self debug: #testBehavior " self assert: (Object methodDict isKindOf: MethodDictionary). self assert: (Object selectors asSortedCollection = Object selectors asSortedCollection).! ! !MethodDictionaryTest methodsFor: 'requirement' stamp: 'Alexandre Bergel 12/25/2009 08:22'! speciesClass ^ MethodDictionary! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:33'! testIdentityKeyAtExistantValueCopyReturnsFailBlock | methodSelector result aMethod error | methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation. error := #error. aMethod := (self class >> methodSelector) copy. result := self class methodDict keyAtIdentityValue: aMethod ifAbsent: [error]. self assert: result = error.! ! !MethodDictionaryTest methodsFor: 'helpers' stamp: 'Alexandre Bergel 12/25/2009 08:20'! anIndex ^ #aMethodName! ! !MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 20:59'! testAssociationAtExistantKeyReturnsOkAssociation | methodSelector association | methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation. association := self class methodDict associationAt: methodSelector ifAbsent: [self error]. self assert: association key = methodSelector. self assert: association value = (self class >> methodSelector).! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:15'! testAtNonexistantKeyExecutesFailBlock | methodSelector result error | methodSelector := #inexistant:method:larala:. error := #error. result := self class methodDict at: methodSelector ifAbsent: [error]. self assert: result = error.! ! !MethodDictionaryTest methodsFor: 'tests - removing' stamp: 'GuillermoPolito 8/28/2010 19:26'! testRemoveAllPreservesCapacity | methodSelector dictionary oldSize | methodSelector := #testRemoveAllPreservesCapacity. dictionary := MethodDictionary new. dictionary at: methodSelector put: self class >> methodSelector. oldSize := dictionary basicSize. dictionary removeAll. self assert: oldSize = dictionary basicSize.! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:29'! elementNotIn "return an element not included in 'nonEmpty' " ^ self class >> #elementNotIn! ! !MethodDictionaryTest methodsFor: 'running' stamp: 'Alexandre Bergel 12/25/2009 08:28'! setUp super setUp. nonEmptyDict := MethodDictionary new. nonEmptyDict at: #setUp put: (self class >> #setUp). nonEmptyDict at: #nonEmpty put: (self class >> #nonEmpty).! ! !MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !MethodDictionaryTest methodsFor: 'test - removing' stamp: ''! testRemove self should: [self nonEmptyDict remove: nil] raise: Error. self should: [self nonEmptyDict remove: nil ifAbsent: ['What ever here']] raise: Error.! ! !MethodDictionaryTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAny: self empty). self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAny: self nonEmpty).! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:29'! testKeyAtExistantValueReturnsOkKey | methodSelector result aMethod | methodSelector := #testAssociationAtExistantKeyReturnsOkAssociation. aMethod := self class >> methodSelector. result := self class methodDict keyAtValue: aMethod ifAbsent: [self error]. self assert: result = methodSelector.! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:32'! nonEmptyDifferentFromNonEmptyDict " return a dictionary for which all keys are not included in nonEmptyDict" ^ MethodDictionary new at: #nonEmptyDifferentFromNonEmptyDict put: (self class >> #nonEmptyDifferentFromNonEmptyDict)! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:19'! testGrowDoublesCapacity | methodDictionary oldCapacity | methodDictionary := MethodDictionary new. oldCapacity := methodDictionary capacity. methodDictionary grow. self assert: oldCapacity * 2 = methodDictionary capacity.! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:27'! nonEmpty ^ nonEmptyDict! ! !MethodDictionaryTest methodsFor: 'tests - others' stamp: 'GuillermoPolito 8/28/2010 21:10'! testAssociationsDoGoesOverEntireDictionary | associations | associations := MethodDictionary new. self class methodDict associationsDo:[ :association | associations add: association ]. self assertPreservesElements: self class methodDict comparedTo: associations.! ! !MethodDictionaryTest methodsFor: 'tests - rehashing' stamp: 'MarianoMartinezPeck 9/27/2011 20:09'! testRehashPreservesCapacity | oldDictionary rehashedDictionary | oldDictionary := self modifiedMethodDictionaryCopy. rehashedDictionary := oldDictionary copy rehash. self assertPreservesCapacity: oldDictionary comparedTo: rehashedDictionary.! ! !MethodFinder commentStamp: 'sd 4/21/2011 17:22'! Find a method in the system from a set of examples. Done by brute force, trying every possible selector. Errors are skipped over using ( [3 + 'xyz'] ifError: [^ false] ). Submit an array of the form ((data1 data2) answer (data1 data2) answer). MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10). answer: 'data1 + data2' More generally, use the brace notation to construct live examples. The program tries data1 as the receiver, and tries all other permutations of the data for the receiver and args, and tries leaving out one argument, and uses all selectors data understands, and uses all selectors in all od data's superclasses. Floating point values must be precise to 0.01 percent, or (X * 0.0001). If you get an error, you have probably discovered a selector that needs to be removed from the Approved list. See MethodFinder.initialize. Please email the Pharo Team. Only considers 0, 1, 2, and 3 argument messages. The argument data may have 1 to 5 entries, but only a max of 4 used at a time. For now, we only test messages that use given number of args or one fewer. For example, this data (100 true 0.6) would test the receiver plus two args, and the receiver plus one arg, but not any other patterns. Three sets of selectors: Approved, AddAndRemove, and Blocks selectors. When testing a selector in AddAndRemove, deepCopy the receiver. We do not handle selectors that modify an argument (printOn: etc.). Blocks is a set of (selector argNumber) where that argument must be a block. For perform, the selector is tested. It must be in the Approved list. do: is not on the Approved list. It does not produce a result that can be tested. Type 'do' into the upper pane of the Selector Finder to find messages list that. Implementation Notes arguments of the load: method are structured as follows: - Odd list entries are data for it, even ones are the answers. nil input means data and answers were supplied already." "(MethodFinder new) load: #( (4 3) 7 (-10 5) -5 (-3 11) 8) ! !MethodFinder methodsFor: 'argument permutation maps' stamp: 'tk 5/24/1999 16:31'! permuteArgs "Run through ALL the permutations. First one was as presented." data first size <= 1 ifTrue: [^ false]. "no other way" mapList ifNil: [self makeAllMaps]. mapStage := mapStage + 1. mapStage > mapList size ifTrue: [^ false]. argMap := mapList at: mapStage. self mapData. ^ true ! ! !MethodFinder methodsFor: 'argument permutation maps' stamp: 'tk 5/18/1999 14:46'! makeAllMaps "Make a giant list of all permutations of the args. To find the function, we will try these permutations of the input data. receiver, args." | ii | mapList := Array new: argMap size factorial. ii := 1. argMap permutationsDo: [:perm | mapList at: ii put: perm copy. ii := ii + 1]. mapStage := 1. "about to be bumped"! ! !MethodFinder methodsFor: 'tests' stamp: 'ar 4/10/2005 18:48'! test2: anArray "look for bad association" anArray do: [:sub | sub class == Association ifTrue: [ (#('true' '$a' '2' 'false') includes: sub value printString) ifFalse: [ self error: 'bad assn']. (#('3' '5.6' 'x' '''abcd''') includes: sub key printString) ifFalse: [ self error: 'bad assn']. ]. sub class == Array ifTrue: [ sub do: [:element | element isString ifTrue: [element first asciiValue < 32 ifTrue: [ self error: 'store into string in data']]. element class == Association ifTrue: [ element value class == Association ifTrue: [ self error: 'bad assn']]]]. sub class == Date ifTrue: [sub year isInteger ifFalse: [ self error: 'stored into input date!!!!']]. sub class == Dictionary ifTrue: [ sub size > 0 ifTrue: [ self error: 'store into dictionary']]. sub class == OrderedCollection ifTrue: [ sub size > 4 ifTrue: [ self error: 'store into OC']]. ].! ! !MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:49'! constDiv | const subTest got | "See if (data1 // C) is the answer" const := ((thisData at: 1) at: 1) // (answers at: 1). "May not be right!!" got := (subTest := MethodFinder new copy: self addArg: const) searchForOne isEmpty not. got ifFalse: [^ false]. "replace data2 with const in expressions" subTest expressions do: [:exp | expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. selector addAll: subTest selectors. ^ true! ! !MethodFinder methodsFor: 'initialize' stamp: 'sd 4/21/2011 16:06'! copy: mthFinder addArg: aConstant "Copy inputs and answers, add an additional data argument to the inputs. The same constant for every example" | more | more := Array with: aConstant. data := mthFinder data collect: [:argList | argList, more]. answers := mthFinder answers. self load: nil. ! ! !MethodFinder methodsFor: 'find a constant' stamp: 'tk 12/29/2000 22:34'! allNumbers "Return true if all answers and all data are numbers." answers do: [:aa | aa isNumber ifFalse: [^ false]]. thisData do: [:vec | vec do: [:nn | nn isNumber ifFalse: [^ false]]]. ^ true! ! !MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:48'! constPlus | const subTest got | "See if (data1 + C) is the answer" const := (answers at: 1) - ((thisData at: 1) at: 1). got := (subTest := MethodFinder new copy: self addArg: const) searchForOne isEmpty not. got ifFalse: [^ false]. "replace data2 with const in expressions" subTest expressions do: [:exp | expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. selector addAll: subTest selectors. ^ true! ! !MethodFinder methodsFor: 'public api' stamp: 'ar 4/10/2005 18:48'! findMessage "Control the search." data do: [:alist | (alist isKindOf: SequenceableCollection) ifFalse: [ ^ OrderedCollection with: 'first and third items are not Arrays']]. Approved ifNil: [self initialize]. "Sets of allowed selectors" expressions := OrderedCollection new. self search: true. "multi" expressions isEmpty ifTrue: [^ OrderedCollection with: 'no single method does that function']. expressions isString ifTrue: [^ OrderedCollection with: expressions]. ^ expressions! ! !MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/18/2001 22:46'! constMod | subTest low | "See if mod, (data1 \\ C) is the answer" low := answers max. low+1 to: low+20 do: [:const | subTest := MethodFinder new copy: self addArg: const. (subTest testPerfect: #\\) ifTrue: [ expressions add: 'data1 \\ ', const printString. selector add: #\\. ^ true]]. ^ false! ! !MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:49'! constMult | const subTest got | "See if (data1 * C) is the answer" ((thisData at: 1) at: 1) = 0 ifTrue: [^ false]. const := ((answers at: 1) asFloat / ((thisData at: 1) at: 1)) reduce. got := (subTest := MethodFinder new copy: self addArg: const) searchForOne isEmpty not. got ifFalse: [^ false]. "replace data2 with const in expressions" subTest expressions do: [:exp | expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. selector addAll: subTest selectors. ^ true! ! !MethodFinder methodsFor: 'search' stamp: 'sd 4/21/2011 17:09'! testPerfect: aSelector "Try this selector!! Return true if it answers every example perfectly. Take the args in the order they are. Do not permute them. Survive errors. later cache arg lists." | sz argList val rec activeSel perform | perform := aSelector beginsWith: 'perform:'. sz := argMap size. 1 to: thisData size do: [:ii | "each example set of args" argList := (thisData at: ii) copyFrom: 2 to: sz. perform ifFalse: [activeSel := aSelector] ifTrue: [activeSel := argList first. "what will be performed" ((Approved includes: activeSel) or: [AddAndRemove includes: activeSel]) ifFalse: [^ false]. "not approved" aSelector == #perform:withArguments: ifTrue: [activeSel numArgs = (argList at: 2) basicSize "avoid error" ifFalse: [^ false]] ifFalse: [activeSel numArgs = (aSelector numArgs - 1) ifFalse: [^ false]]]. 1 to: sz do: [:num | (Blocks includes: (Array with: activeSel with: num)) ifTrue: [ (argList at: num) isBlock ifFalse: [^ false]]]. rec := (AddAndRemove includes: activeSel) ifTrue: [(thisData at: ii) first isSymbol ifTrue: [^ false]. "vulnerable to modification" (thisData at: ii) first copyTwoLevel] "protect from damage" ifFalse: [(thisData at: ii) first]. val := [[rec perform: aSelector withArguments: argList] ifError: [:aString :aReceiver | ^ false]] on: Deprecation do: [:depr | "We do not want to list deprecated methods" ^false.]. ((answers at: ii) closeTo: val) ifFalse: [^ false]. ]. ^ true! ! !MethodFinder methodsFor: 'initialize' stamp: 'BenComan 2/7/2014 23:49'! initialize "The methods we are allowed to use. (MethodFinder new initialize) " super initialize. Approved := Set new. AddAndRemove := Set new. Blocks := Set new. "These modify an argument and are not used by the MethodFinder: longPrintOn: printOn: storeOn: sentTo: storeOn:base: printOn:base: absPrintExactlyOn:base: absPrintOn:base: absPrintOn:base:digitCount: writeOn: writeScanOn: possibleVariablesFor:continuedFrom: printOn:format:" "Object" #("in class, instance creation" newFrom: "accessing" at: basicAt: basicSize in: size yourself "testing" ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: isColor isFloat isFraction isInteger isMorph isNil isNumber isPoint isText isTransparent isWebBrowser notNil pointsTo: wantsSteps "comparing" = == hash identityHash ~= ~~ "copying" copy shallowCopy "dependents access" canDiscardEdits dependents hasUnacceptedEdits "updating" changed changed: okToChange update: windowIsClosing "printing" fullPrintString isLiteral longPrintString printString storeString "class membership" class isKindOf: isMemberOf: respondsTo: "error handling" "user interface" addModelMenuItemsTo:forMorph:hand: defaultBackgroundColor defaultLabel fullscreenSize initialExtent modelWakeUp "system primitives" instVarAt: instVarNamed: "private" "associating" -> "converting" as: asOrderedCollection asString "casing" caseOf: caseOf:otherwise: "binding" bindingOf: "macpal" contentsChanged currentEvent currentHand currentWorld flash "flagging" flag: "translation support" "objects from disk" "finalization" ) do: [:sel | Approved add: sel]. #(at:add: at:put: basicAt:put: "NOT instVar:at:" "message handling" perform: perform:orSendTo: perform:with: perform:with:with: perform:with:with:with: perform:withArguments: perform:withArguments:inSuperclass: ) do: [:sel | AddAndRemove add: sel]. "Boolean, True, False, UndefinedObject" #("logical operations" & eqv: not xor: | "controlling" and: ifFalse: ifFalse:ifTrue: ifTrue: ifTrue:ifFalse: or: "copying" "testing" isEmptyOrNil) do: [:sel | Approved add: sel]. "Behavior" #("initialize-release" "accessing" format methodDict sourceCodeTemplate subclassDefinerClass "testing" instSize instSpec isBits isBytes isFixed isPointers isVariable isWeak isWords "copying" "printing" printHierarchy "creating class hierarchy" "creating method dictionary" "instance creation" basicNew basicNew: new new: "accessing class hierarchy" allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses subclasses superclass withAllSubclasses withAllSuperclasses "accessing method dictionary" allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: firstCommentAt: lookupSelector: selectors selectorsDo: selectorsWithArgs: "slow but useful ->" sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent: "accessing instances and variables" allClassVarNames allInstVarNames allSharedPools classVarNames instVarNames instanceCount sharedPools someInstance subclassInstVarNames "testing class hierarchy" inheritsFrom: kindOfSubclass "testing method dictionary" canUnderstand: classThatUnderstands: hasMethods includesSelector: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichSelectorsStoreInto: "enumerating" "user interface" "private" indexIfCompact) do: [:sel | Approved add: sel]. "ClassDescription" #("initialize-release" "accessing" isMeta name theNonMetaClass "copying" "printing" classVariablesString instanceVariablesString sharedPoolsString "instance variables" checkForInstVarsOK: "method dictionary" "organization" category organization whichCategoryIncludesSelector: "compiling" acceptsLoggingOfCompilation wantsChangeSetLogging "fileIn/Out" definition "private" ) do: [:sel | Approved add: sel]. "Class" #("initialize-release" "accessing" classPool "testing" "copying" "class name" "instance variables" "class variables" classVarAt: classVariableAssociationAt: "pool variables" "compiling" "subclass creation" "fileIn/Out" ) do: [:sel | Approved add: sel]. "Metaclass" #("initialize-release" "accessing" isSystemDefined soleInstance "copying" "instance creation" "instance variables" "pool variables" "class hierarchy" "compiling" "fileIn/Out" nonTrivial ) do: [:sel | Approved add: sel]. "Context, BlockContext" #(receiver client method receiver tempAt: "debugger access" pc selector sender shortStack sourceCode tempNames tempsAndValues "controlling" "printing" "system simulation" "initialize-release" "accessing" hasMethodReturn home numArgs "evaluating" value value:ifError: value:value: value:value:value: value:value:value:value: valueWithArguments: "controlling" "scheduling" "instruction decoding" "printing" "private" "system simulation" ) do: [:sel | Approved add: sel]. #(value: "<- Association has it as a store" ) do: [:sel | AddAndRemove add: sel]. "Message" #("inclass, instance creation" selector: selector:argument: selector:arguments: "accessing" argument argument: arguments sends: "printing" "sending" ) do: [:sel | Approved add: sel]. #("private" setSelector:arguments:) do: [:sel | AddAndRemove add: sel]. "Magnitude" #("comparing" < <= > >= between:and: "testing" max: min: min:max: ) do: [:sel | Approved add: sel]. "Date, Time" #("in class, instance creation" fromDays: fromSeconds: fromString: today "in class, general inquiries" dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: nameOfDay: nameOfMonth: "accessing" day leap monthIndex monthName weekday year "arithmetic" addDays: subtractDate: subtractDays: "comparing" "inquiries" dayOfMonth daysInMonth daysInYear daysLeftInYear firstDayOfMonth previous: "converting" asSeconds "printing" mmddyyyy printFormat: "private" weekdayIndex "in class, instance creation" fromSeconds: now "in class, general inquiries" dateAndTimeFromSeconds: millisecondClockValue millisecondsToRun: totalSeconds "accessing" hours minutes seconds "arithmetic" addTime: subtractTime: "comparing" "printing" intervalString print24 "converting") do: [:sel | Approved add: sel]. #("private" ) do: [:sel | AddAndRemove add: sel]. "Number" #("in class" readFrom:base: "arithmetic" * + - / // \\ abs negated quo: reciprocal rem: "mathematical functions" arcCos arcSin arcTan arcTan: cos exp floorLog: ln log log: raisedTo: raisedToInteger: sin sqrt squared tan "truncation and round off" ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated "comparing" "testing" even isDivisibleBy: isInfinite isNaN isZero negative odd positive sign strictlyPositive "converting" @ asInteger asNumber asPoint asSmallAngleDegrees degreesToRadians radiansToDegrees "intervals" to: to:by: "printing" printStringBase: storeStringBase: ) do: [:sel | Approved add: sel]. "Integer" #("in class" primesUpTo: "testing" isPowerOfTwo "arithmetic" alignedTo: "comparing" "truncation and round off" normalize "enumerating" timesRepeat: "mathematical functions" degreeCos degreeSin factorial gcd: lcm: take: "bit manipulation" << >> allMask: anyMask: bitAnd: bitClear: bitInvert bitInvert32 bitOr: bitShift: bitXor: lowBit noMask: "converting" asCharacter asColorOfDepth: asFloat asFraction asHexDigit "printing" asStringWithCommas hex hex8 radix: "system primitives" lastDigit replaceFrom:to:with:startingAt: "private" "benchmarks" ) do: [:sel | Approved add: sel]. "SmallInteger, LargeNegativeInteger, LargePositiveInteger" #("arithmetic" "bit manipulation" highBit "testing" "comparing" "copying" "converting" "printing" "system primitives" digitAt: digitLength "private" fromString:radix: ) do: [:sel | Approved add: sel]. #(digitAt:put: ) do: [:sel | AddAndRemove add: sel]. "Float" #("arithmetic" "mathematical functions" reciprocalFloorLog: reciprocalLogBase2 timesTwoPower: "comparing" "testing" "truncation and round off" exponent fractionPart integerPart significand significandAsInteger "converting" asApproximateFraction asIEEE32BitWord asTrueFraction "copying") do: [:sel | Approved add: sel]. "Fraction, Random" #(denominator numerator reduced next nextValue) do: [:sel | Approved add: sel]. #(setNumerator:denominator:) do: [:sel | AddAndRemove add: sel]. "Collection" #("accessing" anyOne "testing" includes: includesAllOf: includesAnyOf: includesSubstringAnywhere: isEmpty isSequenceable occurrencesOf: "enumerating" collect: collect:thenSelect: count: detect: detect:ifNone: detectMax: detectMin: detectSum: inject:into: reject: select: select:thenCollect: intersection: "converting" asBag asCharacterSet asSet asSortedCollection asSortedCollection: "printing" "private" maxSize "arithmetic" "math functions" average max median min range sum) do: [:sel | Approved add: sel]. #("adding" add: addAll: addIfNotPresent: "removing" remove: remove:ifAbsent: removeAll: removeAllFoundIn: removeAllSuchThat: remove:ifAbsent:) do: [:sel | AddAndRemove add: sel]. "SequenceableCollection" #("comparing" hasEqualElements: "accessing" allButFirst allButLast at:ifAbsent: atAll: atPin: atWrap: fifth first first: fourth identityIndexOf: identityIndexOf:ifAbsent: indexOf: indexOf:ifAbsent: indexOf:startingAt:ifAbsent: indexOfSubCollection:startingAt: indexOfSubCollection:startingAt:ifAbsent: last second sixth third "removing" "copying" , copyAfterLast: copyAt:put: copyFrom:to: copyReplaceAll:with: copyReplaceFrom:to:with: copyUpTo: copyUpToLast: copyWith: copyWithout: copyWithoutAll: forceTo:paddingWith: shuffled sort: "enumerating" collectWithIndex: findFirst: findLast: pairsCollect: with:collect: withIndexCollect: polynomialEval: "converting" asArray asDictionary asFloatArray asIntegerArray asStringWithCr asWordArray reversed ) do: [:sel | Approved add: sel]. #( swap:with:) do: [:sel | AddAndRemove add: sel]. "ArrayedCollection, Bag" #("private" defaultElement "sorting" isSorted "accessing" cumulativeCounts sortedCounts sortedElements "testing" "adding" add:withOccurrences: "removing" "enumerating" ) do: [:sel | Approved add: sel]. #( mergeSortFrom:to:by: sort sort: add: add:withOccurrences: "private" setDictionary ) do: [:sel | AddAndRemove add: sel]. "Other messages that modify the receiver" #(atAll:put: atAll:putAll: atAllPut: atWrap:put: replaceAll:with: replaceFrom:to:with: removeFirst removeLast) do: [:sel | AddAndRemove add: sel]. self initialize2. " MethodFinder new initialize. MethodFinder new organizationFiltered: Set " ! ! !MethodFinder methodsFor: 'argument permutation maps' stamp: 'tk 4/24/1999 19:29'! argMap ^ argMap ! ! !MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:47'! constLinear | const subTest got denom num slope offset | "See if (data1 * C1) + C2 is the answer. In the form #(C2 C1) polynomialEval: data1 " denom := ((thisData at: 2) at: 1) - ((thisData at: 1) at: 1). denom = 0 ifTrue: [^ false]. "will divide by it" num := (answers at: 2) - (answers at: 1). slope := (num asFloat / denom) reduce. offset := ((answers at: 2) - (((thisData at: 2) at: 1) * slope)) reduce. const := Array with: offset with: slope. got := (subTest := MethodFinder new copy: self addArg: const) searchForOne isEmpty not. got ifFalse: [^ false]. "replace data2 with const in expressions" subTest expressions do: [:exp | expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. selector addAll: subTest selectors. ^ true! ! !MethodFinder methodsFor: 'search' stamp: 'tk 4/12/2001 10:47'! insertConstants "see if one of several known expressions will do it. C is the constant we discover here." "C data1+C data1*C data1//C (data1*C1 + C2) (data1 = C) (data1 ~= C) (data1 <= C) (data1 >= C) (data1 mod C)" thisData size >= 2 ifFalse: [^ false]. "need 2 examples" (thisData at: 1) size = 1 ifFalse: [^ false]. "only one arg, data1" self const ifTrue: [^ true]. self constUsingData1Value ifTrue: [^ true]. "(data1 ?? const), where const is one of the values of data1" " == ~~ ~= = <= >= " self allNumbers ifFalse: [^ false]. self constMod ifTrue: [^ true]. self constPlus ifTrue: [^ true]. self constMult ifTrue: [^ true]. self constDiv ifTrue: [^ true]. self constLinear ifTrue: [^ true]. ^ false! ! !MethodFinder methodsFor: 'accessing' stamp: 'tk 12/29/2000 13:39'! data ^ data! ! !MethodFinder methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 10/27/2013 12:18'! initialize2 "The methods we are allowed to use. (MethodFinder new initialize) " "Set" #("in class" sizeFor: "testing" "adding" "removing" "enumerating" "private" array findElementOrNil: "accessing" someElement) do: [:sel | Approved add: sel]. "Dictionary, IdentityDictionary, IdentitySet" #("accessing" associationAt: associationAt:ifAbsent: at:ifPresent: keyAtIdentityValue: keyAtIdentityValue:ifAbsent: keyAtValue: keyAtValue:ifAbsent: keys "testing" includesKey: ) do: [:sel | Approved add: sel]. #(removeKey: removeKey:ifAbsent: ) do: [:sel | AddAndRemove add: sel]. "LinkedList, Interval, MappedCollection" #("in class" from:to: from:to:by: "accessing" contents) do: [:sel | Approved add: sel]. #( "adding" addFirst: addLast:) do: [:sel | AddAndRemove add: sel]. "OrderedCollection, SortedCollection" #("accessing" after: before: "copying" copyEmpty "removing" "enumerating" "private" "accessing" sortBlock) do: [:sel | Approved add: sel]. #("adding" add:after: add:afterIndex: add:before: addAllFirst: addAllLast: addFirst: addLast: "removing" removeAt: removeFirst removeLast "accessing" sortBlock:) do: [:sel | AddAndRemove add: sel]. "Character" #("in class, instance creation" allCharacters digitValue: new separators "accessing untypeable characters" backspace cr enter lf linefeed nbsp newPage space tab "constants" alphabet characterTable "accessing" asciiValue digitValue "comparing" "testing" isAlphaNumeric isDigit isLetter isLowercase isSafeForHTTP isSeparator isSpecial isUppercase isVowel tokenish "copying" "converting" asLowercase asUppercase ) do: [:sel | Approved add: sel]. "String" #("in class, instance creation" crlf "primitives" findFirstInString:inSet:startingAt: indexOfAscii:inString:startingAt: "internet" "accessing" byteAt: endsWithDigit findAnySubStr:startingAt: findBetweenSubStrs: findDelimiters:startingAt: findString:startingAt: findString:startingAt:caseSensitive: findTokens: findTokens:includes: findTokens:keep: #includesSubstring: includesSubstring:caseSensitive: indexOf:startingAt: indexOfAnyOf: indexOfAnyOf:ifAbsent: indexOfAnyOf:startingAt: indexOfAnyOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: skipAnySubStr:startingAt: skipDelimiters:startingAt: startsWithDigit "comparing" alike: beginsWith: caseSensitiveLessOrEqual: charactersExactlyMatching: compare: endsWith: endsWithAnyOf: sameAs: startingAt:match:startingAt: "copying" copyReplaceTokens:with: padLeftTo: padRightTo: padLeftTo:with: padRightTo:with: "converting" asByteArray asDate asFileName asLegalSelector asText asTime asUrl capitalized compressWithTable: contractTo: correctAgainst: initialIntegerOrNil keywords quoted withoutPeriodSuffix splitInteger stemAndNumericSuffix substrings surroundedBySingleQuotes truncateWithElipsisTo: trimBoth withFirstCharacterDownshifted withNoLineLongerThan: withSeparatorsCompacted withoutLeadingDigits trimRight trimLeft "displaying" "printing" "system primitives" compare:with:collated: "Celeste" withCRs "internet" decodeMimeHeader decodeQuotedPrintable withInternetLineEndings withSqueakLineEndings withoutQuoting urlEncoded UrlDecoded "testing" isAllSeparators lastSpacePosition "paragraph support" indentationIfBlank: "arithmetic" ) do: [:sel | Approved add: sel]. #(byteAt:put: translateToLowercase match:) do: [:sel | AddAndRemove add: sel]. "Symbol" #("in class, private" hasInterned:ifTrue: "access" morePossibleSelectorsFor: possibleSelectorsFor: selectorsContaining: thatStarts:skipping: "accessing" "comparing" "copying" "converting" "printing" "testing" isInfix isKeyword isUnary) do: [:sel | Approved add: sel]. "Array" #("comparing" "converting" "printing" "private" hasLiteralSuchThat:) do: [:sel | Approved add: sel]. "Array2D" #("access" at:at: atCol: atCol:put: atRow: extent extent:fromArray: height width width:height:type:) do: [:sel | Approved add: sel]. #(at:at:add: at:at:put: atRow:put: ) do: [:sel | AddAndRemove add: sel]. "ByteArray" #("accessing" doubleWordAt: wordAt: "platform independent access" longAt:bigEndian: shortAt:bigEndian: unsignedLongAt:bigEndian: unsignedShortAt:bigEndian: "converting") do: [:sel | Approved add: sel]. #(doubleWordAt:put: wordAt:put: longAt:put:bigEndian: shortAt:put:bigEndian: unsignedLongAt:put:bigEndian: unsignedShortAt:put:bigEndian: ) do: [:sel | AddAndRemove add: sel]. "FloatArray" "Dont know what happens when prims not here" false ifTrue: [#("accessing" "arithmetic" *= += -= /= "comparing" "primitives-plugin" primAddArray: primAddScalar: primDivArray: primDivScalar: primMulArray: primMulScalar: primSubArray: primSubScalar: "primitives-translated" primAddArray:withArray:from:to: primMulArray:withArray:from:to: primSubArray:withArray:from:to: "converting" "private" "user interface") do: [:sel | Approved add: sel]. ]. "IntegerArray, WordArray" "RunArray" #("in class, instance creation" runs:values: scanFrom: "accessing" runLengthAt: "adding" "copying" "private" runs values) do: [:sel | Approved add: sel]. #(coalesce repeatLast:ifEmpty: repeatLastIfEmpty: ) do: [:sel | AddAndRemove add: sel]. "Stream -- many operations change its state" #("testing" atEnd) do: [:sel | Approved add: sel]. #("accessing" next: nextMatchAll: nextMatchFor: upToEnd next:put: nextPut: nextPutAll: "printing" print: ) do: [:sel | AddAndRemove add: sel]. "PositionableStream" #("accessing" contentsOfEntireFile originalContents peek peekFor: "testing" "positioning" position ) do: [:sel | Approved add: sel]. #(nextDelimited: nextLine upTo: position: reset resetContents setToEnd skip: skipTo: upToAll: ) do: [:sel | AddAndRemove add: sel]. "Because it is so difficult to test the result of an operation on a Stream (you have to supply another Stream in the same state), we don't support Streams beyond the basics. We want to find the messages that convert Streams to other things." "ReadWriteStream" #("file status" closed) do: [:sel | Approved add: sel]. #("accessing" next: on: ) do: [:sel | AddAndRemove add: sel]. "WriteStream" #("in class, instance creation" on:from:to: with: with:from:to: ) do: [:sel | Approved add: sel]. #("positioning" resetToStart "character writing" crtab crtab:) do: [:sel | AddAndRemove add: sel]. "LookupKey, Association, Link" #("accessing" key nextLink) do: [:sel | Approved add: sel]. #(key: key:value: nextLink:) do: [:sel | AddAndRemove add: sel]. "Point" #("in class, instance creation" r:degrees: x:y: "accessing" x y "comparing" "arithmetic" "truncation and round off" "polar coordinates" degrees r theta "point functions" bearingToPoint: crossProduct: dist: dotProduct: eightNeighbors flipBy:centerAt: fourNeighbors grid: nearestPointAlongLineFrom:to: nearestPointOnLineFrom:to: normal normalized octantOf: onLineFrom:to: onLineFrom:to:within: quadrantOf: rotateBy:centerAt: transposed unitVector "converting" asFloatPoint asIntegerPoint corner: extent: rect: "transforming" adhereTo: rotateBy:about: scaleBy: scaleFrom:to: translateBy: "copying" "interpolating" interpolateTo:at:) do: [:sel | Approved add: sel]. "Rectangle" #("in class, instance creation" center:extent: encompassing: left:right:top:bottom: merging: origin:corner: origin:extent: "accessing" area bottom bottomCenter bottomLeft bottomRight boundingBox center corner corners innerCorners left leftCenter origin right rightCenter top topCenter topLeft topRight "comparing" "rectangle functions" adjustTo:along: amountToTranslateWithin: areasOutside: bordersOn:along: encompass: expandBy: extendBy: forPoint:closestSideDistLen: insetBy: insetOriginBy:cornerBy: intersect: merge: pointNearestTo: quickMerge: rectanglesAt:height: sideNearestTo: translatedToBeWithin: withBottom: withHeight: withLeft: withRight: withSide:setTo: withTop: withWidth: "testing" containsPoint: containsRect: hasPositiveExtent intersects: isTall isWide "truncation and round off" "transforming" align:with: centeredBeneath: newRectFrom: squishedWithin: "copying" ) do: [:sel | Approved add: sel]. "Color" #("in class, instance creation" colorFrom: colorFromPixelValue:depth: gray: h:s:v: r:g:b: r:g:b:alpha: r:g:b:range: "named colors" black blue brown cyan darkGray gray green lightBlue lightBrown lightCyan lightGray lightGreen lightMagenta lightOrange lightRed lightYellow magenta orange red transparent veryDarkGray veryLightGray veryVeryDarkGray veryVeryLightGray white yellow "other" indexedColors pixelScreenForDepth: quickHighLight: "access" alpha blue brightness green hue luminance red saturation "equality" "queries" isBitmapFill isBlack isGray isSolidFill isTranslucent isTranslucentColor "transformations" alpha: dansDarker darker lighter mixed:with: muchLighter slightlyDarker slightlyLighter veryMuchLighter alphaMixed:with: "groups of shades" darkShades: lightShades: mix:shades: wheel: "printing" shortPrintString "other" colorForInsets rgbTriplet "conversions" asB3DColor asColor balancedPatternForDepth: bitPatternForDepth: closestPixelValue1 closestPixelValue2 closestPixelValue4 closestPixelValue8 dominantColor halfTonePattern1 halfTonePattern2 indexInMap: pixelValueForDepth: pixelWordFor:filledWith: pixelWordForDepth: scaledPixelValue32 "private" privateAlpha privateBlue privateGreen privateRGB privateRed "copying" ) do: [:sel | Approved add: sel]. " For each selector that requires a block argument, add (selector argNum) to the set Blocks." "ourClasses := #(Object Boolean True False UndefinedObject Behavior ClassDescription Class Metaclass MethodContext BlockContext Message Magnitude Date Time Number Integer SmallInteger LargeNegativeInteger LargePositiveInteger Float Fraction Random Collection SequenceableCollection ArrayedCollection Bag Set Dictionary IdentityDictionary IdentitySet LinkedList Interval MappedCollection OrderedCollection SortedCollection Character String Symbol Array Array2D ByteArray FloatArray IntegerArray WordArray RunArray Stream PositionableStream ReadWriteStream WriteStream LookupKey Association Link Point Rectangle Color). ourClasses do: [:clsName | cls := Smalltalk at: clsName. (cls selectors) do: [:aSel | ((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [ (cls formalParametersAt: aSel) withIndexDo: [:tName :ind | (tName endsWith: 'Block') ifTrue: [ Blocks add: (Array with: aSel with: ind)]]]]]. " #((timesRepeat: 1 ) (indexOf:ifAbsent: 2 ) (pairsCollect: 1 ) (mergeSortFrom:to:by: 3 ) (ifNotNil:ifNil: 1 ) (ifNotNil:ifNil: 2 ) (ifNil: 1 ) (at:ifAbsent: 2 ) (ifNil:ifNotNil: 1 ) (ifNil:ifNotNil: 2 ) (ifNotNil: 1) (identityIndexOf:ifAbsent: 2 ) (sort: 1 ) (sortBlock: 1 ) (detectMax: 1 ) (repeatLastIfEmpty: 1 ) (allSubclassesWithLevelDo:startingLevel: 1 ) (keyAtValue:ifAbsent: 2 ) (in: 1 ) (ifTrue: 1 ) (or: 1 ) (select: 1 ) (inject:into: 2 ) (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFalse:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sort: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (collectWithIndex: 1 ) (compiledMethodAt:ifAbsent: 2 ) (detectSum: 1 ) (indexOfSubCollection:startingAt:ifAbsent: 3 ) (findFirst: 1 ) (sourceMethodAt:ifAbsent: 2 ) (collect:thenSelect: 1 ) (collect:thenSelect: 2 ) (select:thenCollect: 1 ) (select:thenCollect: 2 ) (ifFalse: 1 ) (indexOfAnyOf:startingAt:ifAbsent: 3 ) (indentationIfBlank: 1 ) ) do: [:anArray | Blocks add: anArray]. self initialize3. " MethodFinder new initialize. MethodFinder new organizationFiltered: TranslucentColor class " "Do not forget class messages for each of these classes" ! ! !MethodFinder methodsFor: 'argument permutation maps' stamp: 'tk 4/24/1999 19:29'! thisData ^ thisData ! ! !MethodFinder methodsFor: 'initialize' stamp: 'sd 4/21/2011 16:06'! cleanInputs: dataAndAnswerString "Find and remove common mistakes. Complain when ill formed." | fixed ddd rs places | ddd := dataAndAnswerString. fixed := false. rs := (ddd , ' ') readStream. places := OrderedCollection new. [ rs upToAll: '#true'. rs atEnd ] whileFalse: [ places addFirst: rs position - 4 ]. places do: [ :pos | ddd := ddd copyReplaceFrom: pos to: pos with: ''. fixed := true ]. "remove #" rs := ddd readStream. places := OrderedCollection new. [ rs upToAll: '#false'. rs atEnd ] whileFalse: [ places addFirst: rs position - 5 ]. places do: [ :pos | ddd := ddd copyReplaceFrom: pos to: pos with: ''. fixed := true ]. "remove #" fixed ifTrue: [ self inform: '#(true false) are Symbols, not Booleans. Next time use { true. false }.' ]. fixed := false. rs := ddd readStream. places := OrderedCollection new. [ rs upToAll: '#nil'. rs atEnd ] whileFalse: [ places addFirst: rs position - 3 ]. places do: [ :pos | ddd := ddd copyReplaceFrom: pos to: pos with: ''. fixed := true ]. "remove #" fixed ifTrue: [ self inform: '#nil is a Symbol, not the authentic UndefinedObject. Next time use nil instead of #nil' ]. ^ ddd! ! !MethodFinder methodsFor: 'find a constant' stamp: 'nice 1/5/2010 15:59'! constUsingData1Value | subTest | "See if (data1 <= C) or (data1 >= C) is the answer" "quick test" ((answers at: 1) class superclass == Boolean) ifFalse: [^ false]. 2 to: answers size do: [:ii | ((answers at: ii) class superclass == Boolean) ifFalse: [^ false]]. thisData do: [:datums | | const got | const := datums first. "use data as a constant!!" got := (subTest := MethodFinder new copy: self addArg: const) searchForOne isEmpty not. got ifTrue: [ "replace data2 with const in expressions" subTest expressions do: [:exp | expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. selector addAll: subTest selectors. ^ true]]. ^ false! ! !MethodFinder methodsFor: 'initialize' stamp: 'sd 4/21/2011 17:10'! initialize3 "additional selectors to consider" #(asWords threeDigitName ) do: [:sel | Approved add: sel].! ! !MethodFinder methodsFor: 'accessing' stamp: 'tk 12/29/2000 13:20'! expressions ^ expressions! ! !MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/18/2001 22:45'! const | const | "See if (^ constant) is the answer" "quick test" ((const := answers at: 1) closeTo: (answers at: 2)) ifFalse: [^ false]. 3 to: answers size do: [:ii | (const closeTo: (answers at: ii)) ifFalse: [^ false]]. expressions add: '^ ', const printString. selector add: #yourself. ^ true! ! !MethodFinder methodsFor: 'argument permutation maps' stamp: 'sd 4/21/2011 17:01'! mapData "Force the data through the map (permutation) to create the data to test." thisData := data collect: [:realData | argMap collect: [:ind | realData at: ind]]. ! ! !MethodFinder methodsFor: 'search' stamp: 'tk 1/8/2001 17:53'! searchForOne "Look for and return just one answer" expressions := OrderedCollection new. self search: false. "non-multi" ^ expressions ! ! !MethodFinder methodsFor: 'search' stamp: 'sd 4/21/2011 17:51'! handleExceptionalSelectors "Handle some very slippery selectors. asSymbol -- want to be able to produce it, but do not want to make every string submitted into a Symbol!!" | aSel | answers first isSymbol ifFalse: [^ self]. thisData first first isString ifFalse: [^ self]. aSel := #asSymbol. (self testPerfect: aSel) ifTrue: [ selector add: aSel. expressions add: (String streamContents: [:strm | strm nextPutAll: 'data', argMap first printString. aSel keywords doWithIndex: [:key :ind | strm nextPutAll: ' ',key. (key last == $:) | (key first isLetter not) ifTrue: [strm nextPutAll: ' data', (argMap at: ind+1) printString]]])]. ! ! !MethodFinder methodsFor: 'find a constant' stamp: 'md 11/14/2003 16:47'! constEquiv | const subTest got jj | "See if (data1 = C) or (data1 ~= C) is the answer" "quick test" ((answers at: 1) class superclass == Boolean) ifFalse: [^ false]. 2 to: answers size do: [:ii | ((answers at: ii) class superclass == Boolean) ifFalse: [^ false]]. const := (thisData at: 1) at: 1. got := (subTest := MethodFinder new copy: self addArg: const) searchForOne isEmpty not. got ifFalse: ["try other polarity for ~~ " (jj := answers indexOf: (answers at: 1) not) > 0 ifTrue: [ const := (thisData at: jj) at: 1. got := (subTest := MethodFinder new copy: self addArg: const) searchForOne isEmpty not]]. got ifFalse: [^ false]. "replace data2 with const in expressions" subTest expressions do: [:exp | expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. selector addAll: subTest selectors. ^ true! ! !MethodFinder methodsFor: 'public api' stamp: 'sd 4/21/2011 17:33'! load: dataWithAnswers "Find a function that takes the data and gives the answers. Odd list entries are data for it, even ones are the answers. nil input means data and answers were supplied already." "(MethodFinder new) load: #( (4 3) 7 (-10 5) -5 (-3 11) 8); findMessage " dataWithAnswers ifNotNil: [ data := Array new: dataWithAnswers size // 2. 1 to: data size do: [:ii | data at: ii put: (dataWithAnswers at: ii*2-1)]. answers := Array new: data size. 1 to: answers size do: [:ii | answers at: ii put: (dataWithAnswers at: ii*2)]]. data do: [:list | (list isKindOf: SequenceableCollection) ifFalse: [ ^ self error: 'first and third items are not Arrays']. ]. argMap := (1 to: data first size) asArray. data do: [:list | list size = argMap size ifFalse: [ self error: 'data arrays must all be the same size']]. argMap size > 4 ifTrue: [self error: 'No more than a receiver and three arguments allowed']. thisData := data copy. mapStage := mapList := nil. ! ! !MethodFinder methodsFor: 'tests' stamp: 'StephaneDucasse 8/15/2013 18:27'! testFromTuple: nth "verify that the methods allowed don't crash the system. Try N of each of the fundamental types. up to 4 of each kind." | objects nonRepeating even other aa cnt | objects := #((1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four') (x + rectangle: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3) ). objects := objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}. {Point class. SmallInteger class. Association class. Array class}. "{ 4 blocks }." {Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}. {'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}. {Dictionary new. Dictionary new. Dictionary new. Dictionary new}. {#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection. #($a 3 d) asOrderedCollection. #() asOrderedCollection}. {3->true. 5.6->$a. #x->2. 'abcd'->false}. {9 @ 3 extent: 5 @ 4. 0 @ 0 extent: 45 @ 9. -3 @ -7 extent: 2 @ 2. 4 @ 4 extent: 16 @ 16}. {Color red. Color blue. Color black. Color gray}}. self test2: objects. "rec+0, rec+1, rec+2, rec+3 need to be tested. " cnt := 0. nth to: 4 do: [:take | nonRepeating := OrderedCollection new. objects do: [:each | nonRepeating addAll: (each copyFrom: 1 to: take)]. "all combinations of take, from nonRepeating" even := true. nonRepeating combinations: take atATimeDo: [:tuple | even ifTrue: [other := tuple shallowCopy] ifFalse: [self load: (aa := Array with: tuple with: 1 with: other with: 7). (cnt := cnt+1) \\ 50 = 0 ifTrue: [ Transcript cr; show: aa first printString]. self search: true. self test2: aa. self test2: nonRepeating. "self test2: objects"]. even := even not]. ].! ! !MethodFinder methodsFor: 'accessing' stamp: 'tk 12/29/2000 13:39'! answers ^ answers! ! !MethodFinder methodsFor: 'accessing' stamp: 'tk 1/4/2001 17:18'! selectors "Note the inst var does not have an S on the end" ^ selector! ! !MethodFinder methodsFor: 'search' stamp: 'sd 4/21/2011 17:51'! simpleSearch "Run through first arg's class' selectors, looking for one that works." | class supers listOfLists | self handleExceptionalSelectors. class := thisData first first class. "Cache the selectors for the receiver class" (class == cachedClass and: [cachedArgNum = ((argMap size) - 1)]) ifTrue: [listOfLists := cachedSelectorLists] ifFalse: [ supers := class withAllSuperclasses. listOfLists := OrderedCollection new. supers do: [:cls | listOfLists add: (cls selectorsWithArgs: (argMap size) - 1)]. cachedClass := class. cachedArgNum := (argMap size) - 1. cachedSelectorLists := listOfLists]. listOfLists do: [:selectorList | selectorList do: [:aSel | (selector includes: aSel) ifFalse: [ ((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [ (self testPerfect: aSel) ifTrue: [ selector add: aSel. expressions add: (String streamContents: [:strm | strm nextPutAll: 'data', argMap first printString. aSel keywords doWithIndex: [:key :ind | strm nextPutAll: ' ',key. (key last == $:) | (key first isLetter not) ifTrue: [strm nextPutAll: ' data', (argMap at: ind+1) printString]]]) ]]]]]. ! ! !MethodFinder methodsFor: 'public api' stamp: 'sd 4/21/2011 17:48'! search: multi "if Multi is true, collect all selectors that work." selector := OrderedCollection new. "list of them" self simpleSearch. multi not & (selector isEmpty not) ifTrue: [^ selector]. [self permuteArgs] whileTrue: [self simpleSearch. multi not & (selector isEmpty not) ifTrue: [^ selector]]. self insertConstants. ^ #()! ! !MethodFinder class methodsFor: 'instance creation' stamp: 'sd 4/21/2011 17:57'! methodFor: dataAndAnswers "Return an expression that computes these answers." | resultOC resultString | resultOC := self new load: dataAndAnswers; findMessage. resultString := String streamContents: [:strm | resultOC do: [:exp | strm nextPut: $(; nextPutAll: exp; nextPut: $); space]]. ^ resultString! ! !MethodFinderTest commentStamp: 'sd 4/21/2011 16:54'! To do: - radix should be returned ! !MethodFinderTest methodsFor: 'test examples' stamp: 'sd 4/21/2011 18:10'! testMethodFor "self debug: #testMethodFor" self assert: (MethodFinder methodFor: {#(1). true. #(2). false. #(5). true. #(10). false}) = '(data1 odd) (data1 anyMask: 1) (data1 allMask: 1) '! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'YuriyTymchuk 12/20/2013 16:55'! testSubstraction "self debug: #testSubstraction" self assert: (MethodFinder new load: #((14 3) 11 (-10 5) -15 (4 -3) 7)) searchForOne asArray equals: #('data1 - data2'). self assert: (MethodFinder new load: #(((12 4 8)) 24 ((1 3 6)) 10 ) ) searchForOne asArray equals: #('data1 sum') ! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'YuriyTymchuk 12/20/2013 16:50'! testSearchForOne "self debug: #testSearchForOne" self assert: (MethodFinder new load: #(('abcd') $a ('TedK') $T)) searchForOne asArray equals: #('data1 first' 'data1 anyOne') ! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'YuriyTymchuk 12/20/2013 17:11'! testGreaterThanANumber "self debug: #testGreaterThanANumber" self assert: (MethodFinder new load: {#(7). true. #(4.1). true. #(1.5). false}) searchForOne asArray equals: #('data1 >= 4.1'). self assert: (MethodFinder new load: {#(4 3). true. #(-7 3). false. #(5 1). true. #(5 5). false}) searchForOne asArray equals: #('data1 > data2'). self assert: (MethodFinder new load: #((36) 7 (50) 10)) searchForOne asArray equals: #( 'data1 // 5' 'data1 quo: 5')! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'sd 4/21/2011 16:10'! testDegreeSin "self debug: #testDegreeSin" self assert: (MethodFinder new load: #( (0) 0 (30) 0.5 (45) 0.707106 (90) 1)) searchForOne asArray = #('data1 degreeSin') ! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'sd 4/21/2011 16:12'! testIfTrueIfFalse "self debug: #testIfTrueIfFalse" self assert: (MethodFinder new load: { { true. [3]. [4]}. 3. { false. [0]. [6]}. 6}) searchForOne asArray = #('data1 ifTrue: data2 ifFalse: data3') ! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'YuriyTymchuk 12/20/2013 17:00'! testPower "self debug: #testPower" self assert:(MethodFinder new load: #((7) 2 (4) 2 )) searchForOne asArray equals: #('^ 2')! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'sd 4/21/2011 16:57'! testReciprocal "self debug: #testReciprocal" self assert: (MethodFinder new load: #((5) 0.2 (2) 0.5)) searchForOne asArray = #('data1 reciprocal') ! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'sd 4/21/2011 16:56'! testPointY "self debug: #testPointY" self assert: (MethodFinder new load: {{Point x: 3 y: 4}. 4. {Point x: 1 y: 5}. 5}) searchForOne asArray = #('data1 max' 'data1 y'). self assert: (MethodFinder new load: {{Point x: 5 y: 4}. 4. {Point x: 1 y: 5}. 5}) searchForOne asArray = #( 'data1 y').! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'YuriyTymchuk 12/20/2013 17:03'! testPolynomial "self debug: #testPolynomial" self assert: (MethodFinder new load: #( ((2 3) 2) 8 ((2 3) 5) 17 )) searchForOne asArray equals: #('data1 polynomialEval: data2'). self assert: (MethodFinder new load: #((2) 8 (5) 17 )) searchForOne asArray equals: #('#(2 3) polynomialEval: data1') ! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'sd 4/21/2011 16:13'! testIsOdd "self debug: #testIsOdd" self assert: (MethodFinder new load: {#(1). true. #(2). false. #(5). true. #(10). false}) searchForOne asArray = #('data1 odd')! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'sd 4/21/2011 18:08'! testAllNumbers "self debug: #testAllNumbers" self assert: (MethodFinder new load: #((5) 0.2 (2) 0.5)) allNumbers. self deny: (MethodFinder new load: #(('' $A) 'A')) allNumbers! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'YuriyTymchuk 12/20/2013 16:52'! testSearchForAccessAtOne "self debug: #testSearchForAccessAtOne" self assert: (MethodFinder new load: #(('abcd' 1) $a ('Ted ' 3) $d )) searchForOne asArray equals: #('data1 at: data2' 'data1 atPin: data2' 'data1 atWrap: data2') ! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'sd 4/21/2011 17:07'! testIsRadix "self debug: #testIsRadix" self assert: ((MethodFinder new load: #((4 2) '2r100' (255 16) '16rFF' (14 8) '8r16')) searchForOne) asArray = #('data1 storeStringBase: data2') "Apparently the system should find : the #('data1 radix: data2' 'data1 printStringBase: data2' 'data1 storeStringBase: data2')"! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'YuriyTymchuk 12/20/2013 17:06'! testDivision "self debug: #testDivision" self assert: (MethodFinder new load: #((7 5) 2 (4 5) 4 (-9 4) 3)) searchForOne asArray equals: #('data1 \\ data2'). self assert: (MethodFinder new load: #((35) 3 (17) 1 (5) 5)) searchForOne asArray equals: #('data1 \\ 8'). self assert: (MethodFinder new load: #((12 4 8) 2 (1 3 6) 2 (5 2 16) 8) ) searchForOne asArray equals: #().! ! !MethodFinderTest methodsFor: 'test examples' stamp: 'YuriyTymchuk 12/20/2013 16:58'! testAbs "self debug: #testAbs" self assert: (MethodFinder new load: #((4) 4 (-10) 10 (-3) 3 (2) 2 (-6) 6 (612) 612)) searchForOne asArray equals: #('data1 abs')! ! !MethodFromTraitAction commentStamp: ''! Action when the method comes from a trait! !MethodFromTraitAction methodsFor: 'order' stamp: 'EstebanLorenzano 5/14/2013 09:44'! privateActionIcon "Return the icon for this action" ^ IconicButton new target: method originMethod; actionSelector: #browse; labelGraphic: (Smalltalk ui icons iconNamed: #traitIcon) ; color: Color transparent; extent: 12 @ 12; helpText: 'Browse the trait'; borderWidth: 0! ! !MethodFromTraitAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:57'! actionOrder "Return the priority of this action" ^ 200! ! !MethodFromTraitAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:41'! isActionHandled ^ method isFromTrait! ! !MethodHighlightingTests commentStamp: 'TorstenBergmann 1/31/2014 11:23'! SUnit tests for method highlighting! !MethodHighlightingTests methodsFor: 'tests' stamp: 'AdrianLienhard 10/17/2009 16:43'! testMethodHighlighting | map before after method retpc | "Test the highlighting of the asXML method. Test the highlighting of the return statement which should include the whole block supplied to streamContents:." "DebuggerMethodMap voidMapCache" "DebuggerMethodMap forMethod: MethodHighlightingTests >> #asXML" method := MethodHighlightingTests >> #asXML. map := DebuggerMethodMap forMethod: method. retpc := method endPC. before := map rangeForPC: retpc contextIsActiveContext: false. map instVarNamed: 'abstractSourceRanges' put: nil. after := map rangeForPC: retpc contextIsActiveContext: false. self assert: before size > 500. self assert: before = after! ! !MethodHighlightingTests methodsFor: 'tests' stamp: 'nice 1/5/2010 15:59'! asXML "This method is just used as an example for #testMethodHighlighting." ^String streamContents:[:s| | writer | writer := nil. writer xmlDeclaration: '1.0'. writer startTag: 'recording'; endTag. writer tag: 'creator' pcData: creator. writer tag: 'timestamp' pcData: timeStamp. writer tag: 'duration' pcData: duration. writer startTag: 'tracks'; endTag. tracks do:[:tdata| writer startTag: 'track'; attribute: 'type' value: tdata value; endTag. writer pcData: tdata key. writer endTag: 'track'. ]. writer endTag: 'tracks'. writer endTag: 'recording'. ]. ! ! !MethodIsATraitExplicitRequirementAction commentStamp: ''! Action when the method is a explicitRequired! !MethodIsATraitExplicitRequirementAction methodsFor: 'order' stamp: 'SebastianTleye 8/22/2013 14:00'! isActionHandled ^method isRequired and: [ method methodClass ~= method origin ]! ! !MethodIsATraitExplicitRequirementAction methodsFor: 'order' stamp: 'SebastianTleye 8/22/2013 13:50'! privateActionIcon "Return the icon for this action" "^ Smalltalk ui icons iconNamed: #traitRequiredMethodIcon" ^ IconicButton new target: method originMethod; actionSelector: #browse; labelGraphic: (Smalltalk ui icons iconNamed: #traitRequiredMethodIcon) ; color: Color transparent; extent: 12 @ 12; helpText: 'Browse the trait'; borderWidth: 0! ! !MethodIsATraitExplicitRequirementAction methodsFor: 'order' stamp: 'SebastianTleye 8/22/2013 11:14'! actionOrder ^150.! ! !MethodIsAbstractAction commentStamp: ''! Action when the method is abstract! !MethodIsAbstractAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:59'! actionStateToCache "Return the state of the icon for caching purpose" ^ icon! ! !MethodIsAbstractAction methodsFor: 'order' stamp: 'EstebanLorenzano 5/14/2013 09:44'! privateActionIcon "Return the icon for this action" ^ Smalltalk ui icons iconNamed: #abstractIcon! ! !MethodIsAbstractAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:58'! isActionHandled ^ method isAbstract! ! !MethodIsAbstractAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:57'! actionOrder "Return the priority of this action" ^ 700! ! !MethodIsTestAction commentStamp: ''! Aciton when the method is a test! !MethodIsTestAction methodsFor: 'order' stamp: 'EstebanLorenzano 5/14/2013 09:44'! privateActionIcon "Return the icon for this action" | testIcon | testIcon := Smalltalk ui icons iconNamed: #testNotRunIcon. method hasPassedTest ifTrue: [ testIcon := Smalltalk ui icons iconNamed: #testGreenIcon ]. method hasFailedTest ifTrue: [ testIcon := Smalltalk ui icons iconNamed: #testYellowIcon ]. method hasErrorTest ifTrue: [ testIcon := Smalltalk ui icons iconNamed: #testRedIcon ]. ^ IconicButton new target: self browser; actionSelector: #runTestForAMethod:notifying:; arguments: {method. true}; labelGraphic: testIcon; color: Color transparent; helpText: 'Run the test'; extent: 12 @ 12; borderWidth: 0! ! !MethodIsTestAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:57'! actionOrder "Return the priority of this action" ^ 0! ! !MethodIsTestAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:41'! isActionHandled ^ method isTestMethod! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 17:19'! exampleTempNamedTempCopyingNestedBlock ^[| b | b := 1. [ | a | a := 2. a := b . (DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext ] value] value! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 17:02'! exampleTempNamedPutCopying | b | b := 1. ^[ | a | a := b . (DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext put: 2. thisContext tempNamed: 'b' ] value! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 17:38'! exampleTempNamedTempCopyingNestedBlockPROBLEM | a | a := 2. ^[| b | b := 1. [ a := b . (DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext ] value] value! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 17:07'! exampleTempNamedTempVectorNestedBlock | a | a := 1. ^[| b | b := a. [ b := 2 . (DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext ] value] value! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 17:04'! exampleTempNamedPutTempVector | b | b := 1. ^[ | a | b := 2 . (DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext put: 3. thisContext tempNamed: 'b' ] value! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 16:54'! exampleTempNamedTempVector | b | b := 1. ^[ | a | b := 2 . (DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext ] value! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 17:13'! exampleSimpleTemp | b | b := 1. ^(DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 16:57'! exampleTempNamedCopying2 | b | b := 1. ^[ | a | a := b . (DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext ] value! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 17:03'! exampleTempNamedPutCopying2 | b | b := 1. ^[ | a | a := b . (DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext put: 2. thisContext outerContext tempNamed: 'b' ] value! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 16:56'! exampleTempNamedTempVector2 | b | b := 1. ^[ | a | b := 2 . (DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext outerContext ] value! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 17:05'! exampleTempNamedPutTempVector2 | b | b := 1. ^[ | a | b := 2 . (DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext put: 3. thisContext outerContext tempNamed: 'b' ] value! ! !MethodMapExamples methodsFor: 'examples' stamp: 'MarcusDenker 12/19/2012 17:00'! exampleTempNamedCopying | b | b := 1. ^[ | a | a := b . (DebuggerMethodMapOpal forMethod: thisContext method) tempNamed: 'b' in: thisContext ] value! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 18:01'! testExampleTempNamedPutCopying2 self assert: (self compileAndRunExample: #exampleTempNamedPutCopying2) equals: 2! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 18:03'! testExampleTempNamedTempVector2 self assert: (self compileAndRunExample: #exampleTempNamedTempVector2) equals: 2! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 18:01'! testExampleTempNamedPutTempVector self assert: (self compileAndRunExample: #exampleTempNamedPutTempVector) equals: 3.! ! !MethodMapTests methodsFor: 'util' stamp: 'MarcusDenker 12/20/2012 15:14'! compileAndRunExample: aSelector | cm | cm := self compileMethod: MethodMapExamples>>aSelector. ^cm valueWithReceiver: MethodMapExamples new arguments: #().! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 18:02'! testExampleTempNamedPutCopying self assert: (self compileAndRunExample: #exampleTempNamedPutCopying) equals: 2.! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 18:03'! testExampleTempNamedTempVector self assert: (self compileAndRunExample: #exampleTempNamedTempVector) equals: 2! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 17:38'! testExampleTempNamedTempVectorNestedBlock self assert: (self compileAndRunExample: #exampleTempNamedTempVectorNestedBlock ) equals: 2.! ! !MethodMapTests methodsFor: 'testing - source mapping' stamp: 'md 1/17/2013 16:47'! testSourceMappingBlock | method range highlight | method := MethodMapExamples>>#exampleTempNamedCopying. range := (DebuggerMethodMapOpal forMethod: (self compileMethod: method)) rangeForPC: 42. highlight := method sourceCode copyFrom: range first to: range last. self assert: highlight equals: 'b'. range := (DebuggerMethodMapOpal forMethod: (self compileMethod: method)) rangeForPC: 43. highlight := method sourceCode copyFrom: range first to: range last. self assert: highlight equals: 'a := b'. range := (DebuggerMethodMapOpal forMethod: (self compileMethod: method)) rangeForPC: 44. highlight := method sourceCode copyFrom: range first to: range last. self assert: highlight equals:'DebuggerMethodMapOpal'. range := (DebuggerMethodMapOpal forMethod: (self compileMethod: method)) rangeForPC: 45. highlight := method sourceCode copyFrom: range first to: range last. self assert: highlight equals:'thisContext'. range := (DebuggerMethodMapOpal forMethod: (self compileMethod: method)) rangeForPC: 46. highlight := method sourceCode copyFrom: range first to: range last. self assert: highlight equals: 'method'.! ! !MethodMapTests methodsFor: 'testing - ast mapping' stamp: 'MarcusDenker 4/19/2013 13:00'! testThisContextSourceNode self assert: (thisContext sourceNode isKindOf: RBMethodNode). self assert: ([thisContext sourceNode] value isKindOf: RBBlockNode). self assert: ([true ifTrue: [thisContext sourceNode]]value isKindOf: RBBlockNode). ! ! !MethodMapTests methodsFor: 'testing - ast mapping' stamp: 'CamilleTeruel 1/28/2014 14:13'! testBlockSourceNode | sourceNode | sourceNode := [ 1 + 2 ] sourceNode. self assert: sourceNode equals: (RBParser parseExpression: '[ 1 + 2 ]'). ! ! !MethodMapTests methodsFor: 'testing - ast mapping' stamp: 'CamilleTeruel 1/28/2014 14:12'! testBlockWithEnclosedBlockSourceNode | sourceNode | sourceNode := [ [ ] ] sourceNode. self assert: sourceNode equals: (RBParser parseExpression: '[ [ ] ]'). ! ! !MethodMapTests methodsFor: 'testing - ast mapping' stamp: 'CamilleTeruel 2/7/2014 17:47'! inlinedBlockSourceNode 1 to: 1 do: [ :i | ^ thisContext sourceNode ]. ! ! !MethodMapTests methodsFor: 'util' stamp: 'MarcusDenker 12/20/2012 15:13'! compileMethod: aMethod ^aMethod parseTree generate: aMethod trailer. ! ! !MethodMapTests methodsFor: 'testing - ast mapping' stamp: 'MarcusDenker 4/29/2013 15:04'! testBlockAndContextSourceNode |block blockNodeViaContext blockNodeViaClosure | block := [blockNodeViaContext := thisContext sourceNode]. block value. blockNodeViaClosure := block sourceNode. self assert: blockNodeViaContext == blockNodeViaClosure ! ! !MethodMapTests methodsFor: 'testing - ast mapping' stamp: 'CamilleTeruel 1/28/2014 14:37'! testDeadContextSourceNode | deadContext | deadContext := self deadContext. self assert: deadContext isDead. self assert: deadContext sourceNode equals: (self class>>#deadContext) ast ! ! !MethodMapTests methodsFor: 'testing - source mapping' stamp: 'md 1/17/2013 16:47'! testSimpleSourceMapping | method range highlight | method := Object>>('ha', 'lt') asSymbol. range := (DebuggerMethodMapOpal forMethod: (self compileMethod: method)) rangeForPC: 23. highlight := method sourceCode copyFrom: range first to: range last. self assert: highlight equals: 'now'. ! ! !MethodMapTests methodsFor: 'testing - ast mapping' stamp: 'CamilleTeruel 1/28/2014 14:14'! testBlockWithTempsSourceNode | sourceNode | sourceNode := [ | t1 t2 | ] sourceNode. self assert: sourceNode equals: (RBParser parseExpression: '[ | t1 t2 | ]'). ! ! !MethodMapTests methodsFor: 'testing - ast mapping' stamp: 'CamilleTeruel 1/28/2014 14:37'! deadContext ^ thisContext! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 17:32'! testExampleSimpleTemp self assert: (self compileAndRunExample: #exampleSimpleTemp) equals: 1! ! !MethodMapTests methodsFor: 'testing - ast mapping' stamp: 'MarcusDenker 4/29/2013 15:03'! testMethodSourceNodeAtPC self assert: (((Object>>#halt) sourceNodeForPC: 22) isKindOf: RBMessageNode). ! ! !MethodMapTests methodsFor: 'testing - ast mapping' stamp: 'CamilleTeruel 2/7/2014 17:48'! testThisContextSourceNodeInInlinedMessage | inlinedBlockSourceNode | inlinedBlockSourceNode := self inlinedBlockSourceNode. self assert: (inlinedBlockSourceNode isKindOf: RBBlockNode). self assert: inlinedBlockSourceNode equals: (RBParser parseExpression: '[ :i | ^ thisContext sourceNode ]')! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 18:02'! testExampleTempNamedCopying self assert: (self compileAndRunExample: #exampleTempNamedCopying) equals: 1! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 18:02'! testExampleTempNamedCopying2 self assert: (self compileAndRunExample: #exampleTempNamedCopying2) equals: 1! ! !MethodMapTests methodsFor: 'testing - ast mapping' stamp: 'CamilleTeruel 2/7/2014 17:54'! testBlockWithArgAndEnclosedBlockSourceNode | sourceNode | sourceNode := [ :arg | [ arg ] ] sourceNode. self assert: sourceNode equals: (RBParser parseExpression: '[ :arg | [ arg ] ]'). ! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 18:02'! testExampleTempNamedPutTempVector2 self assert: (self compileAndRunExample: #exampleTempNamedPutTempVector2) equals: 3! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 18:04'! testTempNamedTempCopyingNestedBlock self assert: (self compileAndRunExample: #exampleTempNamedTempCopyingNestedBlock) equals: 1.! ! !MethodMapTests methodsFor: 'testing - temp access' stamp: 'MarcusDenker 12/19/2012 17:39'! testTempNamedTempCopyingNestedBlockPROBLEM self assert: (self compileAndRunExample: #exampleTempNamedTempCopyingNestedBlockPROBLEM) equals: 1.! ! !MethodModification commentStamp: ''! I collect and provide the information to update methods when a class changed.! !MethodModification methodsFor: 'initialization' stamp: 'ToonVerwaest 3/28/2011 19:47'! initialize addedSlots := Dictionary new! ! !MethodModification methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 20:06'! addedSlotNamed: name ifAbsent: aBlock ^ addedSlots at: name ifAbsent: aBlock! ! !MethodModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:15'! installRemovedSlot: removedSlot modificationMap at: removedSlot oldFieldIndex put: removedSlot! ! !MethodModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:15'! installModifiedSlot: modifiedSlot modificationMap at: modifiedSlot oldFieldIndex put: modifiedSlot! ! !MethodModification methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 19:48'! installAddedSlot: addedSlot addedSlots at: addedSlot name put: addedSlot! ! !MethodModified commentStamp: 'BenjaminVanRyseghem 4/1/2011 16:04'! This announcement is emited when we RE-compile a method in a class or a trait, with: ClassDescription >> compile: or TraitDescription >> compile:. If the method is not yet registered in the class or the trait, the announcement will not be emitted. The action of renaming a method will be handled by SystemMethodRemovedAnnouncement and SystemMethodAddedAnnouncement, since this refactoring is concretely composed by removing the old method and add a new with the new name ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 14:02'! selector ^ selector! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:55'! newMethod: aCompiledMethod newMethod := aCompiledMethod.! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! oldProtocol: anObject oldProtocol := anObject! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:55'! newMethod ^ newMethod! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! oldProtocol ^ oldProtocol! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:55'! oldMethod: aCompiledMethod oldMethod := aCompiledMethod.! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! methodClass ^ methodClass! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! newProtocol: anObject newProtocol := anObject! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! selector: anObject selector := anObject! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 14:11'! methodAffected ^self newMethod! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:52'! oldMethod ^ oldMethod! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! methodClass: anObject methodClass := anObject! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! newProtocol ^ newProtocol! ! !MethodModified class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 09:45'! methodChangedFrom: oldMethod to: newMethod selector: selector inClass: aClass oldProtocol: oldProtocol newProtocol: newProtocol requestor: aRequestor ^self new oldMethod: oldMethod; newMethod: newMethod; selector: selector; methodClass: aClass; oldProtocol: oldProtocol; newProtocol: newProtocol; yourself! ! !MethodNameEditor commentStamp: ''! A MethodNameEditor is an editor to set the name of a method. This class is imported from OB. Maybe it should be redone with Spec, but since it works well, I will not put more energy here.! !MethodNameEditor methodsFor: 'morphic' stamp: ''! update self changed: #argumentList; changed: #argumentIndex. self changed: #isUpEnabled; changed: #isDownEnabled; changed: #isOkEnabled. labelMorph contents: self methodName printString! ! !MethodNameEditor methodsFor: 'accessing' stamp: ''! selector ^ self methodName selector! ! !MethodNameEditor methodsFor: 'grips' stamp: 'BenjaminVanRyseghem 4/25/2012 13:54'! addEdgeGrips "Should add these to the front!!" | l r lh | lh := self labelHeight. l := WindowEdgeGripMorph new target: self; position: self position; edgeName: #left. l layoutFrame topOffset: lh negated + 22. r := WindowEdgeGripMorph new target: self; position: self position; edgeName: #right. r layoutFrame topOffset: lh negated + 22. self addMorph: l; addMorph: r ! ! !MethodNameEditor methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 3/26/2012 17:19'! newContentMorph ^ (self newRow: { self newLabelGroup: { 'Selector:' -> (selectorField:=(self newTextEntryFor: self getText: #selector setText: #selector: help: nil) autoAccept: true; on: #keyStroke send: #value:value: to: [:key :morph | key keyCharacter = Character cr ifTrue: [ self ok. true]. false]; yourself). 'Arguments:' -> (self newRow: { (self newListFor: self list: #argumentList selected: #argumentIndex changeSelected: #argumentIndex: help: nil) hResizing: #spaceFill; yourself. (self newColumn: { (self newButtonFor: self action: #up label: 'up' help: nil) getEnabledSelector: #isUpEnabled. (self newButtonFor: self action: #down label: 'dn' help: nil) getEnabledSelector: #isDownEnabled }) hResizing: #shrinkWrap }). 'Preview:' -> (labelMorph := self newLabel: self methodName printString) } }) minWidth: 400; yourself! ! !MethodNameEditor methodsFor: 'morphic' stamp: ''! newOKButton ^ self newOKButtonFor: self getEnabled: #isOkEnabled! ! !MethodNameEditor methodsFor: 'actions' stamp: ''! cancel methodName := nil. ^ super cancel! ! !MethodNameEditor methodsFor: 'actions' stamp: ''! up self isUpEnabled ifFalse: [ ^ self ]. self argumentList swap: self argumentIndex with: self argumentIndex - 1. self argumentIndex: self argumentIndex - 1! ! !MethodNameEditor methodsFor: 'testing' stamp: ''! isDownEnabled ^ self argumentIndex ~= 0 and: [ self argumentIndex + 1 between: 1 and: self argumentList size ]! ! !MethodNameEditor methodsFor: 'accessing' stamp: ''! argumentIndex ^ argumentIndex! ! !MethodNameEditor methodsFor: 'accessing' stamp: ''! methodName ^ methodName! ! !MethodNameEditor methodsFor: 'accessing' stamp: ''! selector: aString self methodName selector: aString. self update! ! !MethodNameEditor methodsFor: 'actions' stamp: ''! down self isDownEnabled ifFalse: [ ^ self ]. self argumentList swap: self argumentIndex with: self argumentIndex + 1. self argumentIndex: self argumentIndex + 1! ! !MethodNameEditor methodsFor: 'testing' stamp: ''! isUpEnabled ^ self argumentIndex ~= 0 and: [ self argumentIndex - 1 between: 1 and: self argumentList size ]! ! !MethodNameEditor methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:05'! initialize super initialize. self beResizeable! ! !MethodNameEditor methodsFor: 'accessing' stamp: ''! argumentList ^ self methodName arguments! ! !MethodNameEditor methodsFor: 'focus handling' stamp: 'BenjaminVanRyseghem 3/26/2012 17:10'! defaultFocusMorph "Answer the morph that should have the keyboard focus by default when the dialog is opened." ^ selectorField ifNil: [ super defaultFocusMorph ]! ! !MethodNameEditor methodsFor: 'initialization' stamp: ''! initializeOn: aMethodName methodName := aMethodName. argumentIndex := 0. self initialize. self title: 'Method Name'! ! !MethodNameEditor methodsFor: 'grips' stamp: 'BenjaminVanRyseghem 4/25/2012 13:53'! addGrips self addEdgeGrips! ! !MethodNameEditor methodsFor: 'testing' stamp: ''! isOkEnabled ^ self methodName isValid! ! !MethodNameEditor methodsFor: 'accessing' stamp: ''! argumentIndex: anInteger argumentIndex := anInteger. self update! ! !MethodNameEditor class methodsFor: 'instance creation' stamp: ''! openOn: aMethodName ^ UITheme builder openModal: (self on: aMethodName)! ! !MethodNameEditor class methodsFor: 'instance creation' stamp: ''! on: aMethodName ^ self basicNew initializeOn: aMethodName! ! !MethodNode commentStamp: ''! I am the root of the parse tree.! !MethodNode methodsFor: 'debugger support' stamp: 'MarcusDenker 5/10/2013 12:49'! blockExtentsToTempsMap "Answer a Dictionary of blockExtent to temp locations for the current method. This is used by the debugger to locate temp vars in contexts. A temp map entry is a pair of the temp's name and its index, where an index is either an integer for a normal temp or a pair of the index of the indirect temp vector containing the temp and the index of the temp in its indirect temp vector." ^encoder blockExtentsToTempsMap ifNil: [| methNode | methNode := Parser new encoderClass: encoder class; parse: self sourceCode class: self methodClass. "As a side effect generate: creates data needed for the map." methNode generate. methNode encoder blockExtentsToTempsMap]! ! !MethodNode methodsFor: 'code generation' stamp: 'yo 8/30/2002 14:07'! selector "Answer the message selector for the method represented by the receiver." (selectorOrFalse isSymbol) ifTrue: [^selectorOrFalse]. ^selectorOrFalse key. ! ! !MethodNode methodsFor: 'code generation' stamp: 'MarcusDenke 4/29/2012 19:15'! generateWithSource "Answer a CompiledMethod with source encoded in trailer." | source | "for doits, we need to store the source pretty printed from the AST to get the return and methodName correct" self selector isDoIt ifTrue: [sourceText := self printString]. ^self generate: (CompiledMethodTrailer new sourceCode: sourceText).! ! !MethodNode methodsFor: 'source mapping' stamp: 'MarcusDenker 5/10/2013 12:50'! rawSourceRangesAndMethodDo: aBinaryBlock "Evaluate aBinaryBlock with the rawSourceRanges and method generated from the receiver." | methNode method | methNode := Parser new encoderClass: encoder class; parse: self sourceCode class: self methodClass. method := methNode generate. "set bytecodes to map to" ^aBinaryBlock value: methNode encoder rawSourceRanges value: method! ! !MethodNode methodsFor: 'code generation' stamp: 'eem 9/25/2008 15:20'! selectorNode "Answer a SelectorNode for the message selector of the method represented by the receiver." ^(selectorOrFalse isMemberOf: SelectorNode) ifTrue: [selectorOrFalse] ifFalse: [SelectorNode new key: selectorOrFalse]! ! !MethodNode methodsFor: 'debugger support' stamp: 'eem 7/1/2009 13:45'! hasGeneratedMethod ^encoder hasGeneratedMethod! ! !MethodNode methodsFor: 'printing' stamp: 'ajh 1/24/2003 17:41'! sourceText ^ sourceText ifNil: [self printString]! ! !MethodNode methodsFor: 'printing' stamp: 'ajh 1/22/2003 17:39'! methodClass ^ encoder classEncoding! ! !MethodNode methodsFor: 'accessing' stamp: 'eem 6/11/2009 17:27'! removeProperty: aSymbol properties := properties copyWithout: (Association key: aSymbol value: (properties propertyValueAt: aSymbol))! ! !MethodNode methodsFor: 'primitive error codes' stamp: 'eem 12/1/2008 14:56'! removeAndRenameLastTempIfErrorCode self primitiveErrorVariableName ifNotNil: [:primitiveErrorVariableName| temporaries last name: primitiveErrorVariableName key: primitiveErrorVariableName code: temporaries last code. temporaries removeLast].! ! !MethodNode methodsFor: 'code generation (closures)' stamp: 'eem 7/24/2008 10:04'! ensureClosureAnalysisDone block blockExtent ifNil: [temporaries := block analyseArguments: arguments temporaries: temporaries rootNode: self]! ! !MethodNode methodsFor: 'code generation (closures)' stamp: 'eem 5/29/2008 16:07'! referencedValuesWithinBlockExtent: anInterval ^(localsPool select: [:temp| temp isReferencedWithinBlockExtent: anInterval]) collect: [:temp| temp isRemote ifTrue: [temp remoteNode] ifFalse: [temp]]! ! !MethodNode methodsFor: 'converting' stamp: 'eem 8/31/2010 12:36'! preenLocalIfNotNilArg "Try and spot a (var := expr) ifNil: [...] ifNotNil: [...] where var is only used in the ifNotNil: block and convert it to expr ifNil: [...] ifNotNil: [:var| ...]. Deal both with the pretty-print case where the block already declares the variable and the decompile case where it does not." | varsToHide | varsToHide := Set new. self nodesDo: [:node| | variable | (node isMessageNode and: [node macroPrinter == #printIfNilNotNil:indent: and: [node receiver isMessageNode and: [node receiver selector key == #== and: [node receiver receiver isAssignmentNode and: [(variable := node receiver receiver variable) isTemp and: [variable isRemote not and: [variable isOnlySubnodeOf: node in: self]]]]]]]) ifTrue: [node arguments last arguments isEmpty ifTrue: [node arguments last arguments: { variable }. varsToHide add: variable] ifFalse: [self assert: node arguments last arguments asArray = { variable }]. node receiver receiver: node receiver receiver value]]. varsToHide notEmpty ifTrue: [self nodesDo: [:node| ((node == self or: [node isBlockNode]) and: [node temporaries anySatisfy: [:temp| varsToHide includes: temp]]) ifTrue: [node temporaries: (node temporaries reject: [:temp| varsToHide includes: temp])]]]! ! !MethodNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:35'! accept: aVisitor ^aVisitor visitMethodNode: self! ! !MethodNode methodsFor: 'printing' stamp: 'eem 12/1/2008 14:36'! printOn: aStream | selectorNode | selectorNode := self selectorNode. precedence = 1 ifTrue: [selectorNode isForFFICall ifTrue: [selectorNode printAsFFICallWithArguments: arguments on: aStream indent: 0] ifFalse: [aStream nextPutAll: selectorNode key]] ifFalse: [selectorNode key keywords with: arguments do: [:kwd :arg | aStream nextPutAll: kwd; space; nextPutAll: arg key; space]]. comment == nil ifFalse: [aStream crtab: 1. self printCommentOn: aStream indent: 1]. block printTemporaries: temporaries on: aStream doPrior: [aStream crtab: 1]. primitive > 0 ifTrue: [(primitive between: 255 and: 519) ifFalse: "Dont decompile quick prims e.g, ^ self or ^instVar" [aStream crtab: 1. self printPrimitiveOn: aStream]]. self printPropertiesOn: aStream. self printPragmasOn: aStream. aStream crtab: 1. block printStatementsOn: aStream indent: 0! ! !MethodNode methodsFor: 'code generation (closures)' stamp: 'ClementBera 7/26/2013 17:18'! addLocalsToPool: locals "" localsPool ifNil: [localsPool := IdentitySet new]. localsPool addAll: locals! ! !MethodNode methodsFor: 'initialize-release' stamp: ''! selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim "Initialize the receiver with respect to the arguments given." encoder := anEncoder. selectorOrFalse := selOrFalse. precedence := p. arguments := args. temporaries := temps. block := blk. primitive := prim! ! !MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 15:59'! temporaries: aSequence "For transformations etc, not used in compilation" temporaries := aSequence! ! !MethodNode methodsFor: 'printing' stamp: 'MarcusDenker 4/29/2012 09:35'! sourceCode ^ self sourceText.! ! !MethodNode methodsFor: 'accessing' stamp: 'eem 1/19/2009 10:28'! primitiveErrorVariableName "Answer the primitive error code temp name, or nil if none." (primitive isInteger and: [primitive > 0]) ifTrue: [properties pragmas do: [:pragma| | kwds ecIndex | ((kwds := pragma keyword keywords) first = 'primitive:' and: [(ecIndex := kwds indexOf: 'error:') > 0]) ifTrue: [^pragma argumentAt: ecIndex]]]. ^nil "(Parser new parse: (MethodNode sourceCodeAt: #primitiveErrorVariableName) class: Parser) primitiveErrorVariableName" "(Parser new parse: 'foo self primitiveFailed' class: Object) primitiveErrorVariableName" "(Parser new parse: 'foo self primitiveFailed' class: Object) primitiveErrorVariableName" "(Parser new parse: 'foo self primitiveFailed' class: Object) primitiveErrorVariableName" "(Parser new parse: 'foo self primitiveFailed' class: Object) primitiveErrorVariableName" "(Parser new parse: 'foo self primitiveFailed' class: Object) primitiveErrorVariableName" "(Parser new parse: 'foo self primitiveFailed' class: Object) generate"! ! !MethodNode methodsFor: 'converting' stamp: 'MarcusDenker 5/10/2013 12:55'! decompileString "Answer a string description of the parse tree whose root is the receiver." ^self formattedCode ! ! !MethodNode methodsFor: 'code generation' stamp: 'MarcusDenker 11/13/2012 18:52'! generate "The receiver is the root of a parse tree. Answer a CompiledMethod." ^self generate: CompiledMethodTrailer empty! ! !MethodNode methodsFor: 'printing' stamp: 'eem 12/1/2008 14:25'! printPropertiesOn: aStream properties ifNil: [^self]. properties propertyKeysAndValuesDo: [:prop :val| aStream crtab; nextPut: $<. prop = #on:in: ifTrue: [prop keywords with: val do: [:k :v | aStream nextPutAll: k; space; nextPutAll: v; space]] ifFalse: [prop = #on ifTrue: [aStream nextPutAll: prop; nextPutAll:': '; nextPutAll: val] ifFalse: [aStream nextPutAll: prop; nextPutAll:': '; print: val]]. aStream nextPut: $>]! ! !MethodNode methodsFor: 'code generation' stamp: 'lr 2/6/2006 23:24'! properties ^ properties! ! !MethodNode methodsFor: 'code generation' stamp: 'MarcusDenker 11/13/2012 18:51'! generate: trailer ifQuick: methodBlock | v | (primitive = 0 and: [arguments size = 0 and: [block isQuick]]) ifFalse: [^self]. v := block code. v < 0 ifTrue: [^self]. v = LdSelf ifTrue: [^methodBlock value: (CompiledMethod toReturnSelfTrailerBytes: trailer)]. (v between: LdTrue and: LdMinus1 + 3) ifTrue: [^methodBlock value: (CompiledMethod toReturnConstant: v - LdSelf trailerBytes: trailer)]. v < ((CodeBases at: LdInstType) + (CodeLimits at: LdInstType)) ifTrue: [^methodBlock value: (CompiledMethod toReturnField: v trailerBytes: trailer)]. v // 256 = 1 ifTrue: [^methodBlock value: (CompiledMethod toReturnField: v \\ 256 trailerBytes: trailer)]! ! !MethodNode methodsFor: 'initialize-release' stamp: 'tk 8/3/1999 12:47'! block ^ block! ! !MethodNode methodsFor: 'initialize-release' stamp: 'ajh 1/22/2003 17:53'! sourceText: stringOrText sourceText := stringOrText! ! !MethodNode methodsFor: 'code generation (closures)' stamp: 'eem 5/20/2008 13:43'! locationCounter ^locationCounter! ! !MethodNode methodsFor: 'initialize-release' stamp: 'ajh 1/24/2003 17:37'! selector: symbol selectorOrFalse := symbol! ! !MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 16:00'! arguments: aSequence "For transformations etc, not used in compilation" arguments := aSequence! ! !MethodNode methodsFor: 'printing' stamp: 'eem 12/1/2008 14:35'! printPragmasOn: aStream properties ifNil: [^self]. properties pragmas do: [:pragma| "Primitives are printed in printPrimitiveOn:; skip these" (Parser primitivePragmaSelectors includes: pragma keyword) ifFalse: [aStream crtab: 1. pragma printOn: aStream]]! ! !MethodNode methodsFor: 'code generation' stamp: 'MarcusDenker 11/13/2012 18:51'! generate: trailer "The receiver is the root of a parse tree. Answer an instance of aCompiledMethodClass. The argument, trailer, is arbitrary but is typically either the reference to the source code that is stored with every CompiledMethod, or an encoding of the method's temporary names." | primErrNode blkSize nLits literals stack method | self generate: trailer ifQuick: [:m | m literalAt: 2 put: encoder associationForClass; properties: properties. ^m]. primErrNode := self primitiveErrorVariableName ifNotNil: [encoder fixTemp: self primitiveErrorVariableName]. encoder supportsClosureOpcodes ifTrue: [self ensureClosureAnalysisDone. encoder rootNode: self. "this is for BlockNode>>sizeCodeForClosureValue:"]. blkSize := (block sizeCodeForEvaluatedValue: encoder) + (primErrNode ifNil: [0] ifNotNil: [primErrNode index: arguments size + temporaries size; sizeCodeForStore: encoder "The VM relies on storeIntoTemp: (129)"]). method := CompiledMethod newBytes: blkSize trailerBytes: trailer nArgs: arguments size nTemps: (encoder supportsClosureOpcodes ifTrue: [| locals | locals := arguments, temporaries, (primErrNode ifNil: [#()] ifNotNil: [{primErrNode}]). encoder noteBlockExtent: block blockExtent hasLocals: locals. locals size] ifFalse: [encoder maxTemp]) nStack: 0 nLits: (nLits := (literals := encoder allLiterals) size) primitive: primitive. nLits > 255 ifTrue: [^self error: 'Too many literals referenced']. 1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)]. encoder streamToMethod: method. stack := ParseStack new init. primErrNode ifNotNil: [primErrNode emitCodeForStore: stack encoder: encoder]. stack position: method numTemps. block emitCodeForEvaluatedValue: stack encoder: encoder. stack position ~= (method numTemps + 1) ifTrue: [^self error: 'Compiler stack discrepancy']. encoder methodStreamPosition ~= (method size - trailer size) ifTrue: [^self error: 'Compiler code size discrepancy']. method needsFrameSize: stack size - method numTemps. method properties: properties. ^method! ! !MethodNode methodsFor: 'initialize-release' stamp: 'ar 1/4/2002 00:23'! selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim properties: propDict "Initialize the receiver with respect to the arguments given." encoder := anEncoder. selectorOrFalse := selOrFalse. precedence := p. arguments := args. temporaries := temps. block := blk. primitive := prim. properties := propDict.! ! !MethodNode methodsFor: 'converting' stamp: 'eem 8/31/2010 11:54'! preen "Preen for pretty-printing and/or decompilation. i.e. post-process to cover up for inadequacies in both algorithms. Currently one case, hiding the assignment to the arg of an inlined block arg to ifNotNil:, (var := expr) ifNil: [...] ifNotNil: [...] => expr ifNil: [...] ifNotNil: [:var| ...]." self preenLocalIfNotNilArg! ! !MethodNode methodsFor: 'source mapping' stamp: 'eem 6/4/2008 19:21'! rawSourceRanges ^self rawSourceRangesAndMethodDo: [:rawSourceRanges :method| rawSourceRanges]! ! !MethodNode methodsFor: 'accessing' stamp: 'md 7/27/2006 19:12'! body ^block! ! !MethodNode methodsFor: 'code generation (closures)' stamp: 'ClementBera 7/26/2013 17:18'! noteBlockEntry: aBlock "Evaluate aBlock with the numbering for the block entry." locationCounter ifNil: [locationCounter := -1]. aBlock value: locationCounter + 1. locationCounter := locationCounter + 2! ! !MethodNode methodsFor: 'printing' stamp: 'MarcusDenker 5/10/2013 12:57'! formattedCode ^ self fullPrintString ! ! !MethodNode methodsFor: 'code generation (closures)' stamp: 'eem 6/2/2008 12:12'! noteBlockExit: aBlock "Evaluate aBlock with the numbering for the block exit." aBlock value: locationCounter + 1. locationCounter := locationCounter + 2! ! !MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 16:00'! arguments "For transformations etc, not used in compilation" ^arguments! ! !MethodNode methodsFor: 'initialize-release' stamp: 'MarcusDenker 8/28/2013 10:44'! source: stringOrText sourceText := stringOrText! ! !MethodNode methodsFor: 'printing' stamp: ''! tempNames ^ encoder tempNames! ! !MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 15:59'! temporaries "For transformations etc, not used in compilation" ^temporaries! ! !MethodNode methodsFor: 'code generation' stamp: ''! encoder ^ encoder! ! !MethodNode methodsFor: 'printing' stamp: 'MarcusDenker 12/20/2012 13:27'! printPrimitiveOn: aStream "Print the primitive on aStream" | primDecl | primitive = 0 ifTrue: [ ^ self ]. primitive = 120 ifTrue: [ "External call spec" ^ aStream print: encoder literals first ]. aStream nextPutAll: '.! ! !MethodNodeTest commentStamp: 'TorstenBergmann 1/31/2014 11:25'! SUnit tests for method nodes! !MethodNodeTest methodsFor: 'testing' stamp: 'ClementBera 6/28/2013 11:05'! testGenerateWithSource | source ast method | source := 'testMethod |hello| ^hello. ' . ast := Compiler new source: source; class: self class; failBlock: [self error: 'compilation error']; translate. method := ast generateWithSource. self assert: (method isKindOf: CompiledMethod). self assert: method trailer hasSourcePointer not. self assert: method trailer hasSource. self assert: (method sourceCode = source). ! ! !MethodOveridesAction commentStamp: ''! Action when the method overrides another one, or the method is overidden by another one or both! !MethodOveridesAction methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 1/2/2013 12:58'! actionStateToCache "Return the state of the icon for caching purpose" ^ result ifNil: [ super actionStateToCache ] ifNotNil: [ {(IconicButtonStateHolder forNautilus: result value first). (IconicButtonStateHolder forNautilus: result value second)} ]! ! !MethodOveridesAction methodsFor: 'order' stamp: 'MarcusDenker 9/27/2013 18:07'! privateActionIcon "Return the icon for this action" isOverride ifTrue: [ isOverridden ifTrue: [ result := self buildUpAndDownArrowIcon: method. ^ result key ] ifFalse: [ ^ IconicButton new target: self browser; actionSelector: #arrowUp:; arguments: {method}; labelGraphic: (Smalltalk ui icons iconNamed: #arrowUpIcon); color: Color transparent; helpText: 'Browse overriden message'; extent: 12 @ 12; borderWidth: 0 ] ] ifFalse: [ isOverridden ifTrue: [ ^ IconicButton new target: self browser; actionSelector: #arrowDown:; arguments: {method}; labelGraphic: (Smalltalk ui icons iconNamed: #arrowDownIcon); color: Color transparent; helpText: 'Browse overriding messages'; extent: 12 @ 12; borderWidth: 0 ] ]! ! !MethodOveridesAction methodsFor: 'private' stamp: 'EstebanLorenzano 5/14/2013 09:44'! buildUpAndDownArrowIcon: aMethod | container up down | container := Morph new. container extent: 12@12; color: Color transparent. up := IconicButton new target: self browser; actionSelector: #arrowUp:; arguments: { aMethod }; labelGraphic: (Smalltalk ui icons iconNamed: #arrowDoubleUpIcon); color: Color transparent; extent: 12 @ 6; helpText: 'Browse overriden message'; borderWidth: 0. down := IconicButton new target: self browser; actionSelector: #arrowDown:; arguments: { aMethod }; labelGraphic: (Smalltalk ui icons iconNamed: #arrowDoubleDownIcon); color: Color transparent; extent: 12 @ 6; helpText: 'Browse overriding messages'; borderWidth: 0. ^ (container changeTableLayout; listDirection: #topToBottom; addMorph: down; addMorph: up; yourself) -> {up. down}.! ! !MethodOveridesAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 13:07'! isActionHandled isOverridden := method isOverridden. isOverride := method isOverride. ^ isOverridden or: [ isOverride ]! ! !MethodOveridesAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:57'! actionOrder "Return the priority of this action" ^ 600! ! !MethodPragmaTest commentStamp: 'TorstenBergmann 2/5/2014 08:41'! SUnit tests for method pragmas! !MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 8/19/2006 20:44'! testCompileBinary self assertPragma: ' = 1' givesKeyword: #= arguments: #( 1 ). self assertPragma: ' , 3' givesKeyword: #, arguments: #( 3 ). self assertPragma: ' > 4' givesKeyword: #> arguments: #( 4 ). self assertPragma: ' < 5' givesKeyword: #< arguments: #( 5 ). self assertPragma: ' == 1' givesKeyword: #== arguments: #( 1 ). self assertPragma: ' <> 3' givesKeyword: #<> arguments: #( 3 ). self assertPragma: ' >< 4' givesKeyword: #>< arguments: #( 4 ). self assertPragma: ' ** 5' givesKeyword: #** arguments: #( 5 )! ! !MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'lr 1/20/2006 02:31'! testPrimitiveIndexed1 "This test useses the #instVarAt: primitive." self compile: ' ^ #inst' selector: #inst. self assert: self inst = #inst.! ! !MethodPragmaTest methodsFor: 'testing-pragma' stamp: 'lr 1/20/2006 00:35'! testArguments | pragma | pragma := Pragma keyword: #foo: arguments: #( 123 ). self assert: pragma arguments = #( 123 ).! ! !MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! testCompileArray self assertPragma: 'foo: #()' givesKeyword: #foo: arguments: #( () ). self assertPragma: 'foo: #( foo )' givesKeyword: #foo: arguments: #( ( foo ) ). self assertPragma: 'foo: #( foo: )' givesKeyword: #foo: arguments: #( ( foo: ) ). self assertPragma: 'foo: #( 12 )' givesKeyword: #foo: arguments: #( ( 12 ) ). self assertPragma: 'foo: #( true )' givesKeyword: #foo: arguments: #( ( true ) ). ! ! !MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! testCompileEmpty self assertPragma: 'foo' givesKeyword: #foo arguments: #().! ! !MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! testCompileNumber self assertPragma: 'foo: 123' givesKeyword: #foo: arguments: #( 123 ). self assertPragma: 'foo: -123' givesKeyword: #foo: arguments: #( -123 ). self assertPragma: 'foo: 12.3' givesKeyword: #foo: arguments: #( 12.3 ). self assertPragma: 'foo: -12.3' givesKeyword: #foo: arguments: #( -12.3 ).! ! !MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'CamilloBruni 2/26/2014 16:51'! testPrimitiveNamed1 "This test useses the #primitiveDirectoryLookup primitive." self compile: ' ^ #lookup' selector: #lookup. self assert: self lookup equals: #lookup. ! ! !MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/21/2006 13:01'! testAllNamedInSortedUsing | pragmasCompiled pragmasDetected | pragmasCompiled := self pragma: #foo: selector: #bar times: 5. pragmasDetected := Pragma allNamed: #foo: in: self class sortedUsing: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]. self assert: pragmasDetected = (pragmasCompiled sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]).! ! !MethodPragmaTest methodsFor: 'testing' stamp: 'lr 3/19/2007 11:38'! testWithArgumentsDo | pragma wasHere | pragma := Pragma keyword: #add:after: arguments: #( 1 2 ). self assert: (pragma withArgumentsDo: [ :a :b | self assert: a = 1; assert: b = 2. wasHere := true ]). self assert: wasHere! ! !MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:15'! testAllNamedInSortedByArgument | pragmasCompiled pragmasDetected | pragmasCompiled := self pragma: #foo: selector: #bar times: 5. pragmasDetected := Pragma allNamed: #foo: in: self class sortedByArgument: 1. self assert: pragmasDetected = (pragmasCompiled sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])! ! !MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! testCompileString self assertPragma: 'foo: ''''' givesKeyword: #foo: arguments: #( '' ). self assertPragma: 'foo: ''bar''' givesKeyword: #foo: arguments: #( 'bar' ).! ! !MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'CamilloBruni 2/26/2014 16:08'! testPrimitiveNamed2 "This test useses the #primPathNameDelimiter primitive." self compile: ' ^ #delim' selector: #delim. self assert: self delim equals: FilePluginPrims new delimiter. ! ! !MethodPragmaTest methodsFor: 'testing-pragma' stamp: 'lr 1/20/2006 00:36'! testMessage | pragma message | pragma := Pragma keyword: #foo: arguments: #( 123 ). message := pragma message. self assert: message selector = #foo:. self assert: message arguments = #( 123 ).! ! !MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'MartinMcClure 3/18/2010 21:55'! testPrimitiveIndexed2 "This test useses the #identityHash primitive." self compile: ' ^ #idHash' selector: #idHash. self assert: self idHash = self basicIdentityHash.! ! !MethodPragmaTest methodsFor: 'testing-method' stamp: 'lr 1/20/2006 07:54'! testSelector | pragma | pragma := self pragma: 'foo' selector: #bar. self assert: pragma selector == #bar.! ! !MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 1/20/2006 08:11'! pragma: aSymbol selector: aSelector times: anInteger ^ (self compile: (String streamContents: [ :stream | (1 to: anInteger) asArray shuffled do: [ :each | stream nextPut: $<; nextPutAll: aSymbol; space; print: each; nextPut: $>; cr ] ]) selector: aSelector) pragmas.! ! !MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 10/5/2006 09:49'! testCompileValue self assertPragma: 'foo: true' givesKeyword: #foo: arguments: #( true ). self assertPragma: 'foo: false' givesKeyword: #foo: arguments: #( false ). self assertPragma: 'foo: nil' givesKeyword: #foo: arguments: #( nil )! ! !MethodPragmaTest methodsFor: 'testing' stamp: 'lr 3/19/2007 11:40'! testArgumentAt | pragma | pragma := Pragma keyword: #value:value:value: arguments: #( 3 2 1 ). self assert: (pragma argumentAt: 1) = 3. self assert: (pragma argumentAt: 2) = 2. self assert: (pragma argumentAt: 3) = 1! ! !MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:19'! testAllNamedIn | pragmasCompiled pragmasDetected | pragmasCompiled := self pragma: #foo: selector: #bar times: 5. pragmasDetected := Pragma allNamed: #foo: in: self class. self assert: pragmasDetected = pragmasCompiled. pragmasDetected := Pragma allNamed: #foo: in: Object. self assert: pragmasDetected isEmpty.! ! !MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 2/6/2006 20:48'! pragma: aString selector: aSelector ^ (self compile: '<' , aString , '>' selector: aSelector) pragmas first.! ! !MethodPragmaTest methodsFor: 'testing-pragma' stamp: 'lr 1/20/2006 00:35'! testKeyword | pragma | pragma := Pragma keyword: #foo: arguments: #( 123 ). self assert: pragma keyword = #foo:.! ! !MethodPragmaTest methodsFor: 'testing' stamp: 'lr 3/19/2007 11:38'! testSendTo | pragma wasHere | pragma := Pragma keyword: #value:value: arguments: #( 1 2 ). self assert: (pragma sendTo: [ :a :b | self assert: a = 1; assert: b = 2. wasHere := true ]). self assert: wasHere! ! !MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'CamilloBruni 2/26/2014 16:52'! testPrimitiveNamedErrorCode2 "This test useses the #primitiveDirectoryLookup primitive." self compile: ' ^ errorCode' selector: #lookup. self assert: self lookup equals: nil. ! ! !MethodPragmaTest methodsFor: 'running' stamp: 'lr 1/20/2006 02:15'! tearDown (self class organization listAtCategoryNamed: self methodCategory) do: [ :each | self class removeSelectorSilently: each ]. self class organization removeCategory: self methodCategory.! ! !MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 07:39'! testCompileFull self assertPragma: 'foo: 1' givesKeyword: #foo: arguments: #( 1 ). self assertPragma: 'foo: 1 bar: 2' givesKeyword: #foo:bar: arguments: #( 1 2 ).! ! !MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:18'! testAllNamedFromTo | pragmasCompiled pragmasDetected | pragmasCompiled := self pragma: #foo: selector: #bar times: 5. pragmasDetected := Pragma allNamed: #foo: from: self class to: Object. self assert: pragmasDetected = pragmasCompiled. pragmasDetected := Pragma allNamed: #foo: from: Object to: Object. self assert: pragmasDetected isEmpty.! ! !MethodPragmaTest methodsFor: 'testing-method' stamp: 'md 2/18/2006 19:59'! testMethodClass | pragma | pragma := self pragma: 'foo' selector: #bar. self assert: pragma methodClass == self class.! ! !MethodPragmaTest methodsFor: 'testing' stamp: 'lr 3/19/2007 11:42'! testNumArgs | pragma | pragma := Pragma keyword: #value arguments: #(). self assert: pragma numArgs = 0. pragma := Pragma keyword: #+ arguments: #( 1 ). self assert: pragma numArgs = 1. pragma := Pragma keyword: #value:value: arguments: #( 1 2 ). self assert: pragma numArgs = 2! ! !MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 1/20/2006 02:23'! compile: aString selector: aSelector self class compileSilently: aSelector , String lf , aString classified: self methodCategory. ^ self class >> aSelector.! ! !MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'CamilloBruni 8/31/2013 20:23'! testCompileTemps "Pragmas should be placeable before and after temps." self assert: (self compile: '| temps | ' selector: #zork) pragmas notEmpty. self assert: (self compile: ' | temps |' selector: #zork) pragmas notEmpty! ! !MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'CamilloBruni 2/26/2014 16:52'! testPrimitiveNamedErrorCode1 "This test useses the #primitiveDirectoryLookup primitive." self compile: ' ^ errorCode' selector: #lookup. self assert: self lookup equals: nil. ! ! !MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:17'! testAllNamedFromToSortedByArgument | pragmasCompiled pragmasDetected | pragmasCompiled := self pragma: #foo: selector: #bar times: 5. pragmasDetected := Pragma allNamed: #foo: from: self class to: Object sortedByArgument: 1. self assert: pragmasDetected = (pragmasCompiled sort: [ :a :b | (a argumentAt: 1) < (b argumentAt: 1) ])! ! !MethodPragmaTest methodsFor: 'testing-finding' stamp: 'lr 1/20/2006 08:17'! testAllNamedFromToSortedUsing | pragmasCompiled pragmasDetected | pragmasCompiled := self pragma: #foo: selector: #bar times: 5. pragmasDetected := Pragma allNamed: #foo: from: self class to: Object sortedUsing: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]. self assert: pragmasDetected = (pragmasCompiled sort: [ :a :b | (a argumentAt: 1) > (b argumentAt: 1) ]).! ! !MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! testCompileSymbol self assertPragma: 'foo: #bar' givesKeyword: #foo: arguments: #( bar ). self assertPragma: 'foo: #bar:' givesKeyword: #foo: arguments: #( bar: ). self assertPragma: 'foo: #bar:zork:' givesKeyword: #foo: arguments: #( bar:zork: ).! ! !MethodPragmaTest methodsFor: 'testing-method' stamp: 'lr 1/20/2006 07:54'! testMethod | pragma | pragma := self pragma: 'foo' selector: #bar. self assert: pragma method == (self class >> #bar).! ! !MethodPragmaTest methodsFor: 'utilities' stamp: 'MarcusDenker 5/1/2013 16:55'! assertPragma: aString givesKeyword: aSymbol arguments: anArray | pragma | pragma := self pragma: aString selector: #zork. self assert: pragma keyword = aSymbol. self assert: pragma arguments = anArray. ! ! !MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'MarcusDenker 5/23/2013 09:48'! testCompileInvalid "Invalid pragmas should properly raise an error." self should: [ self compile: '<>' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '<1>' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '<#123>' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '<<1>' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '<=2>' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '< =1 = >' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '< =1 =2 >' selector: #zork ] raise: SyntaxErrorNotification.! ! !MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 1/20/2006 11:50'! methodCategory ^ #generated! ! !MethodPragmaTest methodsFor: 'testing-compiler' stamp: 'lr 1/20/2006 02:25'! testCompileCharacter self assertPragma: 'foo: $a' givesKeyword: #foo: arguments: #( $a ). self assertPragma: 'foo: $ ' givesKeyword: #foo: arguments: #( $ ).! ! !MethodPragmaTest methodsFor: 'testing-compiled' stamp: 'lr 2/6/2006 21:03'! testNoPragma | method | method := self compile: '' selector: #foo. self assert: method pragmas = #().! ! !MethodRecategorized commentStamp: 'cyrilledelaunay 1/18/2011 15:03'! This announcement will be emitted when: => a non-empty protocol is renamed in a class or a trait (using ClassOrganizer >> renameCategory:toBe:). If the protocol does not contain any method, the announcement will not be emitted. Therefore, if we rename a non-empty protocol, both SystemMethodRecategorizedAnnouncement and SystemClassReorganizedAnnouncement will be emitted => a method is removed from a category of a class or a trait (using ClassOrganizer >> removeElement:) => a method is RE-categorized in a protocol of a trait or a class, using Organizer>>classify:under:. If the method is classify under its current protocol, the announcement will not be emitted! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! newProtocol ^ newProtocol! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! selector ^ selector! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! methodRecategorized ^ methodRecategorized! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! oldProtocol: anObject oldProtocol := anObject! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! oldProtocol ^ oldProtocol! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! methodRecategorized: anObject methodRecategorized := anObject! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! methodClass ^ methodClass! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! methodClass: anObject methodClass := anObject! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! newProtocol: anObject newProtocol := anObject! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! selector: anObject selector := anObject! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 14:10'! methodAffected ^self methodRecategorized! ! !MethodRecategorized class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 09:59'! method: aCompiledMethod selector: aSelector class: aClass newProtocol: aNewProtocol oldProtocol: anOldProtocol ^self new methodRecategorized: aCompiledMethod; selector: aSelector; methodClass: aClass; newProtocol: aNewProtocol; oldProtocol: anOldProtocol; yourself! ! !MethodRecompileStrategy commentStamp: ''! I am simple update strategy that recompiles all methods.! !MethodRecompileStrategy methodsFor: 'updating' stamp: 'CamilleTeruel 12/18/2013 13:37'! updateClassLiteralKeysIn: aClass aClass isMeta ifTrue: [ ^ self ]. aClass methodsDo: [ :method | method classBinding: (aClass environment bindingOf: aClass name) ]! ! !MethodRecompileStrategy methodsFor: 'updating' stamp: 'CamilleTeruel 12/18/2013 14:00'! transform: oldClass to: newClass using: aMethodModification newClass compileAllFrom: oldClass. ! ! !MethodRemoved commentStamp: 'cyrilledelaunay 1/18/2011 14:43'! This announcement will be emitted when a method is removed from a trait or a class, using ClassDescription >>removeSelector: or TraitDescription >> removeSelector. ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:48'! methodClass: anObject methodClass := anObject! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:49'! selector ^selector! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:48'! protocol ^ protocol! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:48'! selector: anObject selector := anObject! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 14:10'! methodAffected ^self methodRemoved! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:48'! methodRemoved: anObject methodRemoved := anObject! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:48'! methodRemoved ^ methodRemoved! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:49'! methodClass ^methodClass! ! !MethodRemoved methodsFor: 'accessing' stamp: 'MartinDias 2/11/2013 14:09'! methodOrigin: anObject methodOrigin := anObject ! ! !MethodRemoved methodsFor: 'accessing' stamp: 'MartinDias 2/11/2013 14:09'! methodOrigin ^ methodOrigin! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:48'! protocol: anObject protocol := anObject! ! !MethodRemoved methodsFor: 'testing' stamp: 'MartinDias 2/11/2013 14:09'! isProvidedByATrait ^ self methodOrigin ~= self methodClass ! ! !MethodRemoved class methodsFor: 'instance creation' stamp: 'MartinDias 2/11/2013 14:10'! methodRemoved: aCompiledMethod selector: aSelector protocol: aProtocol class: aClass origin: anOrigin ^self new methodRemoved: aCompiledMethod; selector: aSelector; protocol: aProtocol; methodClass: aClass; methodOrigin: anOrigin; yourself! ! !MethodRepackaged commentStamp: 'TorstenBergmann 2/12/2014 22:57'! Notify about repackaging of a method! !MethodRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! methodRepackaged: anObject methodRepackaged := anObject! ! !MethodRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! oldPackage: anObject oldPackage := anObject! ! !MethodRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! methodRepackaged ^ methodRepackaged! ! !MethodRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! oldPackage ^ oldPackage! ! !MethodRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! newPackage ^ newPackage! ! !MethodRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! newPackage: anObject newPackage := anObject! ! !MethodRepackaged class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/17/2012 17:20'! methodRepackaged: aMethod oldPackage: oldPackage newPackage: newPackage ^self new methodRepackaged: aMethod; oldPackage: oldPackage; newPackage: newPackage; yourself.! ! !MethodToolbar commentStamp: ''! A MethodToolbar is xxxxxxxxx. | b | b := MethodToolbar new. b openWithSpec. b method: (ButtonModel>>#state:). b method: nil! !MethodToolbar methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! sendersMethod methodHolder value ifNotNil: [:aMethod | self model browseSendersOfMessagesFrom: aMethod selector ]! ! !MethodToolbar methodsFor: 'private' stamp: 'StephaneDucasse 12/19/2012 16:55'! addAll: aWindow withSpec: aSpec aWindow addMorph: (self buildWithSpec: aSpec) fullFrame: ((0@0 corner: 1@0) asLayoutFrame bottomOffset: 30). ! ! !MethodToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! method: aMethod methodHolder value: aMethod! ! !MethodToolbar methodsFor: 'initialization' stamp: ''! setImplementorsModel implementorsModel state: false; label: 'Implementors'; action: [ self implementorsMethod ]. ! ! !MethodToolbar methodsFor: 'initialization' stamp: ''! setVersionModel versionModel state: false; label: 'Version'; action: [ self versionMethod ]. ! ! !MethodToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/9/2013 10:02'! addItemLabeled: aString do: aBlock dropListModel addItemLabeled: aString do: aBlock! ! !MethodToolbar methodsFor: 'initialization' stamp: ''! registerForChanges methodHolder whenChangedDo: [:contents || boolean | boolean := contents ifNil: [ false ] ifNotNil: [ true ]. browseModel state: boolean. sendersModel state: boolean. versionModel state: boolean. implementorsModel state: boolean]! ! !MethodToolbar methodsFor: 'initialization' stamp: ''! setFocusOrder self focusOrder add: browseModel; add: sendersModel; add: implementorsModel; add: versionModel. ! ! !MethodToolbar methodsFor: 'initialization' stamp: ''! setSendersModel sendersModel state: false; label: 'Senders'; action: [ self sendersMethod ]. ! ! !MethodToolbar methodsFor: 'accessing' stamp: ''! browseModel ^ browseModel! ! !MethodToolbar methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/28/2013 23:38'! implementorsModel ^ implementorsModel! ! !MethodToolbar methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! browseMethod methodHolder value ifNotNil: [:aMethod | aMethod browse ]! ! !MethodToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 10/1/2013 15:42'! initializeWidgets browseModel := self newButton. sendersModel := self newButton. implementorsModel := self newButton. versionModel := self newButton. dropListModel := self newDropList. self setFocusOrder; setBrowseModel; setVersionModel; setSendersModel; setImplementorsModel ! ! !MethodToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize methodHolder := nil asReactiveVariable. model := AbstractTool new. super initialize.! ! !MethodToolbar methodsFor: 'accessing' stamp: ''! model ^ model! ! !MethodToolbar methodsFor: 'accessing' stamp: ''! versionModel ^ versionModel! ! !MethodToolbar methodsFor: 'accessing' stamp: ''! dropListModel ^ dropListModel! ! !MethodToolbar methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! implementorsMethod methodHolder value ifNotNil: [:aMethod | self model browseMessagesFrom: aMethod selector ]! ! !MethodToolbar methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! versionMethod methodHolder value ifNotNil: [:aMethod | self model browseVersionsFrom: aMethod ]! ! !MethodToolbar methodsFor: 'initialization' stamp: ''! setBrowseModel browseModel state: false; label: 'Browse'; action: [ self browseMethod ]. ! ! !MethodToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/9/2013 10:09'! emptyDropList dropListModel emptyList! ! !MethodToolbar methodsFor: 'accessing' stamp: ''! sendersModel ^ sendersModel! ! !MethodToolbar class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 9/29/2013 13:46'! defaultSpec ^ SpecLayout composed newRow: [ :row | row add: #(model browseModel); add: #(model sendersModel); add: #(model implementorsModel); add: #(model versionModel); add: #(model dropListModel) ]; yourself! ! !MethodToolbar class methodsFor: 'specs' stamp: ''! title ^ 'Toolbar'! ! !MethodWidget commentStamp: ''! MethodWidget is the basic implementation of a wiget managing methods! !MethodWidget methodsFor: 'selection' stamp: ''! resetMethodsListSelection methodsSelection removeAll! ! !MethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/14/2012 12:17'! updateList self update: #getMethodItem:! ! !MethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/27/2012 23:02'! resetSelection self methodsSelection removeAll! ! !MethodWidget methodsFor: 'protocol' stamp: ''! vScrollValue ^ methodsList scrollValue y! ! !MethodWidget methodsFor: 'private' stamp: ''! selectMethod: aMethod methodsSelection at: aMethod put: true! ! !MethodWidget methodsFor: 'selection' stamp: ''! selectedMethodIndex: anInteger | aMethod | aMethod := self getMethods at: anInteger ifAbsent: [ nil ]. self selectedMethod: aMethod. self changed: #selectedMethodIndex.! ! !MethodWidget methodsFor: 'item creation' stamp: 'EstebanLorenzano 2/6/2013 17:13'! buildMethodsList methodsList := PluggableIconListMorph new basicWrapSelector: #methodWrapper:; keystrokeSelector: #keyPressedOnElement:; getIconSelector: #methodIconFor:; resetListSelector: #resetMethodsListSelection; getListSizeSelector: #methodListSize; autoDeselect: true; dragEnabled: true; hResizing: #spaceFill; vResizing: #spaceFill; model: self; getIndexSelector: #selectedMethodIndex; setIndexSelector: #selectedMethodIndex:; getSelectionListSelector: #methodSelectionAt:; setSelectionListSelector: #methodSelectionAt:put:; getMenuSelector: #elementsMenu:shifted:; beMultipleSelection. Nautilus populateMethodList ifTrue: [ methodsList getListElementSelector: #getMethodItem: ] ifFalse: [ methodsList basicGetListElementSelector: #getMethodItem: ]. ^ methodsList.! ! !MethodWidget methodsFor: 'initialization' stamp: 'NorbertHartl 3/28/2013 12:46'! initialize super initialize. methodsSelection := IdentityDictionary new.! ! !MethodWidget methodsFor: 'selection' stamp: ''! selectedMethods | associations | associations := self methodsSelection associations select: [:assoc | assoc value == true ] thenCollect: [:assoc | assoc key ]. ^ associations reject: [:each | each isNil ]! ! !MethodWidget methodsFor: 'testing' stamp: ''! resetMethodCache methods := nil! ! !MethodWidget methodsFor: 'protocol' stamp: 'SeanDeNigris 7/7/2012 21:03'! getMethods ^ methods ifNil: [ methods := self loadMethods ].! ! !MethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/23/2012 18:57'! label: aString "methodsGroup label: aString"! ! !MethodWidget methodsFor: 'private' stamp: ''! takeKeyboardFocus methodsList takeKeyboardFocus! ! !MethodWidget methodsFor: 'selection' stamp: ''! methodSelectionAt: anIndex | elt assoc | elt := self getMethods at: anIndex ifAbsent: [ ^ false ]. (methodsSelection keys identityIncludes: elt) ifFalse: [ ^ false]. assoc := methodsSelection associationAt: elt ifAbsent: [ ^ false ]. assoc key selector = elt selector ifTrue: [ ^ assoc value ] ifFalse: [ ^ false ]! ! !MethodWidget methodsFor: 'private' stamp: 'EstebanLorenzano 5/28/2013 14:40'! loadMethods ^ self model showGroups ifTrue: [ self model selectedCategories ifEmpty: [ self model methodsForCategoryInGroup: self model allLabel ] ifNotEmpty: [:cat | self model methodsForCategoriesInGroup: cat ]] ifFalse: [ self model selectedCategories ifEmpty: [ self model methodsForCategory: self model allLabel ] ifNotEmpty: [:cat | self model methodsForCategories: cat ]]! ! !MethodWidget methodsFor: 'private' stamp: ''! deselectMethod: aMethod methodsSelection at: aMethod put: false! ! !MethodWidget methodsFor: 'selection' stamp: ''! methodSelectionAt: anIndex put: aBoolean | element | element := self getMethods at: anIndex ifAbsent: [ ^ self ]. methodsSelection at: element put: aBoolean.! ! !MethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/25/2012 11:15'! keyPressedOnElement: anEvent | aCharacter | aCharacter := anEvent keyCharacter. aCharacter == self model class nextFocusKey ifTrue: [ ^ self model giveFocusTo: self model sourceTextArea ]. aCharacter == self model class previousFocusKey ifTrue: [ ^ self model giveFocusTo: self model categoryWidget ]. ! ! !MethodWidget methodsFor: 'protocol' stamp: 'MarcusDenker 11/21/2013 13:34'! removeAllFromMethodsIconsCache: aMethod self methodsIconsCache keysDo: [ :method | " for overrides " method selector = aMethod selector ifTrue: [ MethodsIconsCache removeKey: method ifAbsent: [ ] ] ]! ! !MethodWidget methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/14/2013 08:21'! methodWrapper: anItem | package selector result emphasis | selector := anItem selector. package := self model selectedPackage. result := selector asMorph. emphasis := 0. anItem protocol asString first = $* ifTrue: [ | item | item := anItem protocol allButFirst asLowercase. ((item = package name asLowercase) or: [ (item beginsWith: package name asLowercase) and: [( item at: (package name size +1)) =$-]]) ifFalse: [ result := selector asMorph color: self model extensionColor ; yourself ]] ifFalse: [ (package extendedClasses includes: anItem methodClass) ifTrue: [ result := selector asMorph color: self model extensionColor ; yourself ]]. anItem isFromTrait ifTrue: [ | trait | trait := anItem origin. selector := selector, ' (', trait name ,')'. result := selector asMorph. emphasis := emphasis + 2 ]. self model showInstance ifFalse: [ emphasis := emphasis + 1 ]. ^ result emphasis: emphasis.! ! !MethodWidget methodsFor: 'private' stamp: ''! methodListSize ^ self getMethods size! ! !MethodWidget methodsFor: 'protocol' stamp: ''! methodsSelection ^ methodsSelection! ! !MethodWidget methodsFor: 'selection' stamp: ''! selectedMethodIndex ^ self getMethods identityIndexOf: self selectedMethod ifAbsent: [ 0 ].! ! !MethodWidget methodsFor: 'protocol' stamp: ''! vScrollValue: aNumber ^ methodsList vScrollValue: aNumber! ! !MethodWidget methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/14/2012 13:10'! hasFocus ^ methodsList hasKeyboardFocus! ! !MethodWidget methodsFor: 'private' stamp: ''! methodsLabel ^ self showInstance ifTrue: ['Instance methods' asText ] ifFalse: ['Class methods' asText allBold ]! ! !MethodWidget methodsFor: 'private' stamp: ''! getMethodItem: anIndex ^ self getMethods at: anIndex! ! !MethodWidget class methodsFor: 'menu' stamp: 'cb 3/7/2014 12:59'! elementsMenu: aBuilder | selectedMethods selectedMethod tmp target | target := aBuilder model. selectedMethods := target selectedMethods. selectedMethod := target selectedMethod. (aBuilder item: #'Find Method...') keyText: 'f, m' if: Nautilus useOldStyleKeys not; keyText: 'f' if: Nautilus useOldStyleKeys; action: [ target findMethod ]; order: 0; help: 'Search for a method by name'. target selectedMethod ifNotNil: [ (aBuilder item: #'ToggleBreakPoint') action: [ target toggleBreakPoint ]; order: 199; label: (selectedMethod hasBreakpoint ifFalse: [ 'Add breakpoint (experimental)'] ifTrue: [ 'Remove breakpoint (experimental)'] )]. tmp := ((aBuilder item: #'Browse full') keyText: 'b, f' if: Nautilus useOldStyleKeys not; keyText: 'b' if: Nautilus useOldStyleKeys; action: [ target fullBrowse ]; order: 200; yourself). target selectedMethod ifNil: [ tmp withSeparatorAfter. ^ target ]. (aBuilder item: #'Generate test and jump') keyText: 'h, j' if: Nautilus useOldStyleKeys not; keyText: 'j' if: Nautilus useOldStyleKeys; action: [ target generateTestMethodsAndFocus: true ]; order: 300. (aBuilder item: #'Generate test') keyText: 'h, J' if: Nautilus useOldStyleKeys not; keyText: 'J' if: Nautilus useOldStyleKeys; action: [ target generateTestMethodsAndFocus: false ]; order: 400; withSeparatorAfter. (target selectedMethods allSatisfy: [:meth | meth isTestMethod ]) ifTrue: [ (aBuilder item: #'Run tests') keyText: 'j, m' if: Nautilus useOldStyleKeys not; keyText: 't' if: Nautilus useOldStyleKeys; action: [ target runTestForMethods: selectedMethods notifying: true ]; order: 1000 ]. target selectedMethod correspondingTestMethod notNil ifTrue: [ (aBuilder item: #'Debug tests') keyText: 'd' if: Nautilus useOldStyleKeys not; action: [ target debugTest ]; order: 1001 ]. (aBuilder item: #'Senders of...') keyText: 'b, n' if: Nautilus useOldStyleKeys not; keyText: 'n' if: Nautilus useOldStyleKeys; action: [ target browseSendersOfMessages ]; order: 1100; enabledBlock: [ target enableMethodSingleSelection ]. (aBuilder item: #'Implementors of...') keyText: 'b, m' if: Nautilus useOldStyleKeys not; keyText: 'm' if: Nautilus useOldStyleKeys; action: [ target browseMessages ]; order: 1200; enabledBlock: [ target enableMethodSingleSelection ]. (aBuilder item: #'Inheritance') keyText: 'b, i' if: Nautilus useOldStyleKeys not; keyText: 'i' if: Nautilus useOldStyleKeys; action: [ target methodHierarchy ]; order: 1300; enabledBlock: [ target enableMethodSingleSelection ]. (aBuilder item: #'Versions') keyText: 'b, v' if: Nautilus useOldStyleKeys not; keyText: 'v' if: Nautilus useOldStyleKeys; action: [ target browseVersions ]; order: 1400; enabledBlock: [ target enableMethodSingleSelection ]; withSeparatorAfter. (aBuilder item: #'Categorize method') keyText: 'm, m' if: Nautilus useOldStyleKeys not; action: [ target categorizeMethod ]; order: 1500. (aBuilder item: #'Move to package...') action: [ target moveMethodToPackage ]; order: 1600. (aBuilder item: #'Remove...') keyText: 'x, m' if: Nautilus useOldStyleKeys not; keyText: 'x' if: Nautilus useOldStyleKeys; action: [ target removeMethods ]; order: 1700; icon: (Smalltalk ui icons iconNamed: #removeIcon); withSeparatorAfter. (aBuilder item: #'Add in group...') keyText: 'n, e, m' if: Nautilus useOldStyleKeys not; action: [ target addMethodsInGroup ]; order: 1800. (aBuilder item: #'File Out') action: [ target fileOutMethods ]; order: 1900! ! !MethodWidget class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 4/6/2012 16:57'! buildMethodShortcutsOn: aBuilder (aBuilder shortcut: #fullBrowse) category: #NautilusMethodShortcuts default: $b command do: [ :target | target fullBrowse ] description: 'Open a new browser on the selection'. (aBuilder shortcut: #restrictedBrowseClass) category: #NautilusMethodShortcuts default: $b command shift do: [ :target | target restrictedBrowseClass ] description: 'Open a restricted browser'. (aBuilder shortcut: #categorizeMethod) category: #NautilusMethodShortcuts default: $c command shift do: [ :target | target categorizeMethod ] description: 'Recategorize the selected methods'. (aBuilder shortcut: #addMethodsInGroup) category: #NautilusMethodShortcuts default: $e command do: [ :target | target addMethodsInGroup ] description: 'Add the selected methods in a group'. (aBuilder shortcut: #findMethod) category: #NautilusMethodShortcuts default: $f command do: [ :target | target findMethod ] description: 'Find a method'. (aBuilder shortcut: #methodHierarchy) category: #NautilusMethodShortcuts default: $i command do: [ :target | target enableMethodSingleSelection ifTrue: [ target methodHierarchy ]] description: 'Spawn selected method hierarchy'. (aBuilder shortcut: #generateTestMethodsAndFocus) category: #NautilusMethodShortcuts default: $j command do: [ :target | target generateTestMethodsAndFocus: true ] description: 'Generate test methods for the selected methods and jump to them'. (aBuilder shortcut: #generateTestMethods) category: #NautilusMethodShortcuts default: $j command shift do: [ :target | target generateTestMethodsAndFocus: false ] description: 'Generate test methods for the selected methods'. (aBuilder shortcut: #browseMessages) category: #NautilusMethodShortcuts default: $m command do: [ :target | target enableMethodSingleSelection ifTrue: [ target browseMessages ]] description: 'Browse implementors'. (aBuilder shortcut: #browseSendersOfMessages) category: #NautilusMethodShortcuts default: $n command do: [ :target | target enableMethodSingleSelection ifTrue: [ target browseSendersOfMessages ]] description: 'Browse senders'. (aBuilder shortcut: #runTestFor) category: #NautilusMethodShortcuts default: $t command do: [ :target | target runTestForMethods: target selectedMethods notifying: true] description: 'Run the selected test methods'. (aBuilder shortcut: #browseVersions) category: #NautilusMethodShortcuts default: $v command do: [ :target | target enableMethodSingleSelection ifTrue: [ target browseVersions ]] description: 'Browse version'. (aBuilder shortcut: #removeMethods) category: #NautilusMethodShortcuts default: $x command do: [ :target | target removeMethods ] description: 'Remove the selected methods'.! ! !MethodWithCorrespondingTestAction commentStamp: ''! Action when the method has a corresponding test method! !MethodWithCorrespondingTestAction methodsFor: 'order' stamp: 'EstebanLorenzano 5/14/2013 09:44'! privateActionIcon "Return the icon for this action" | testIcon | testIcon := Smalltalk ui icons iconNamed: #testNotRunIcon. testMethod hasPassedTest ifTrue: [ testIcon := Smalltalk ui icons iconNamed: #testGreenIcon ]. testMethod hasFailedTest ifTrue: [ testIcon := Smalltalk ui icons iconNamed: #testYellowIcon ]. testMethod hasErrorTest ifTrue: [ testIcon := Smalltalk ui icons iconNamed: #testRedIcon ]. ^ IconicButton new target: self browser; actionSelector: #runTestForAMethod:notifying:; arguments: { method. true}; labelGraphic: testIcon; color: Color transparent; extent: 12 @ 12; helpText: 'Run the test'; borderWidth: 0! ! !MethodWithCorrespondingTestAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:57'! actionOrder "Return the priority of this action" ^ 500! ! !MethodWithCorrespondingTestAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:41'! isActionHandled ^ (testMethod := method correspondingTestMethod) notNil! ! !MimeConverter commentStamp: 'LaurentLaffont 6/8/2011 22:18'! I'm the base class for converting some data from a MIME type to another. Subclasses should implement #mimeDecode and #mimeEncode.! !MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:53'! mimeStream ^mimeStream! ! !MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'! mimeStream: anObject mimeStream := anObject! ! !MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:55'! dataStream ^dataStream! ! !MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'! dataStream: anObject dataStream := anObject! ! !MimeConverter methodsFor: 'conversion' stamp: 'bf 11/12/1998 13:30'! mimeDecode "Do conversion reading from mimeStream writing to dataStream" self subclassResponsibility! ! !MimeConverter methodsFor: 'conversion' stamp: 'bf 11/12/1998 13:31'! mimeEncode "Do conversion reading from dataStream writing to mimeStream" self subclassResponsibility! ! !MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:40'! mimeEncode: aCollectionOrStream ^ String streamContents: [:out | self mimeEncode: aCollectionOrStream to: out]! ! !MimeConverter class methodsFor: 'convenience' stamp: 'damiencassou 5/30/2008 11:45'! mimeEncode: aCollectionOrStream to: outStream self new dataStream: (aCollectionOrStream isStream ifTrue: [ aCollectionOrStream ] ifFalse: [ aCollectionOrStream readStream ]); mimeStream: outStream; mimeEncode! ! !MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:47'! forEncoding: encodingString "Answer a converter class for the given encoding or nil if unknown" encodingString ifNil: [^nil]. ^ encodingString asLowercase caseOf: { ['base64'] -> [Base64MimeConverter]. ['quoted-printable'] -> [QuotedPrintableMimeConverter]} otherwise: []. ! ! !MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:43'! mimeDecode: aStringOrStream as: contentsClass ^ contentsClass streamContents: [:out | self mimeDecode: aStringOrStream to: out]! ! !MimeConverter class methodsFor: 'convenience' stamp: 'damiencassou 5/30/2008 11:45'! mimeDecode: aStringOrStream to: outStream self new mimeStream: (aStringOrStream isStream ifTrue: [ aStringOrStream ] ifFalse: [ aStringOrStream readStream ]); dataStream: outStream; mimeDecode! ! !MissingClassError commentStamp: ''! I'm a specialized error that is invoked when trying to load a method for a non existing class. By default this exception is not resumable but it can be set and used for example as follow: [ FileStream fileIn: aFile ] on: MissingClassError do: [ :exception | exception defineClass. exception asResumable. exception resume. ] So we give the possibility to compile and resume compution. The method defineClass defines a simple class inheriting from Object (or from the class specified using #superclassName:) The idea is that if later the effective class is loaded its definition will override this one. ! !MissingClassError methodsFor: 'accessing' stamp: 'StephaneDucasse 12/4/2013 20:20'! superclassName: aString superclassName := aString ! ! !MissingClassError methodsFor: 'accessing' stamp: 'StephaneDucasse 12/4/2013 20:21'! superclassName ^ superclassName ifNil: [ superclassName := 'Object' ] ! ! !MissingClassError methodsFor: 'testing' stamp: 'StephaneDucasse 12/1/2013 21:55'! isResumable "Determine whether an exception is resumable. By default not but can be resumable using accessors at exception raising time." ^ resumable ifNil: [ super isResumable ]! ! !MissingClassError methodsFor: 'actions' stamp: 'StephaneDucasse 12/4/2013 20:19'! asResumable "When sent to the receiver, this one turns into a resumable exception allowing for example to define missing class on the fly." resumable := true.! ! !MissingClassError methodsFor: 'accessing' stamp: 'StephaneDucasse 12/1/2013 21:59'! className: aString className := aString! ! !MissingClassError methodsFor: 'actions' stamp: 'MarcusDenker 12/7/2013 23:50'! defineClass Smalltalk compiler evaluate: self superclassName, ' subclass: #', className, ' instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''Stub-Classes'''! ! !MissingClassError class methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/1/2013 21:58'! className: aString ^ self new className: aString; yourself! ! !MockContainer commentStamp: ''! I'm only a fake container, since in some cases to build a context we use the wraped model, and build a full container isn't so simple... ! !MockContainer methodsFor: 'accessing' stamp: 'GiselaDecuzzi 4/29/2013 15:21'! model ^ model.! ! !MockContainer methodsFor: 'accessing' stamp: 'GiselaDecuzzi 4/29/2013 15:21'! model: anObject model := anObject! ! !MockContainer class methodsFor: 'as yet unclassified' stamp: 'GiselaDecuzzi 4/29/2013 15:23'! for: model ^ self new model: model; yourself.! ! !MockExceptionWithPassAction commentStamp: ''! I am Exception used in the Weak collection tests which has a custom pass action. Instead of using the Exception's default pass mechanism I will call a customized block.! !MockExceptionWithPassAction methodsFor: 'handling' stamp: 'IgorStasenko 5/23/2011 13:07'! pass ^ passAction cull: self! ! !MockExceptionWithPassAction methodsFor: 'accessing' stamp: 'IgorStasenko 5/23/2011 13:07'! passAction: aValuable passAction := aValuable! ! !MockFinalizerAction commentStamp: ''! I am test object used for the WeakRegisty tests. Upon finalization I trigger a custom finalizationAction (usually a Block)! !MockFinalizerAction methodsFor: 'accessing' stamp: 'CamilloBruni 4/25/2013 16:20'! finalize finalizationAction value! ! !MockFinalizerAction methodsFor: 'accessing' stamp: 'CamilloBruni 4/25/2013 16:20'! finalizeValues finalizationAction value! ! !MockFinalizerAction methodsFor: 'accessing' stamp: 'CamilloBruni 4/25/2013 16:20'! finalizationAction: aValuable finalizationAction := aValuable! ! !MockLessonView commentStamp: 'TorstenBergmann 2/12/2014 22:48'! A LessonView mock for testing purposes! !MockLessonView methodsFor: 'accessing' stamp: 'LaurentLaffont 1/21/2010 16:09'! lesson ^ lesson! ! !MockLessonView methodsFor: 'gui' stamp: 'DannyChan 2/1/2010 22:02'! showTutorialNode: aTutorialNode lesson:= aTutorialNode lessonInstance. title := aTutorialNode title.! ! !MockLessonView methodsFor: 'accessing' stamp: 'LaurentLaffont 1/21/2010 16:10'! title ^ title! ! !MockLessonView methodsFor: 'gui' stamp: 'LaurentLaffont 1/21/2010 16:10'! showLesson: aLesson withTitle: aString lesson := aLesson. title := aString.! ! !MockSocketStream commentStamp: 'TorstenBergmann 2/5/2014 10:10'! A test mock for socket streams! !MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 13:08'! outStream ^outStream! ! !MockSocketStream methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:08'! initialize super initialize. self resetInStream. self resetOutStream.! ! !MockSocketStream methodsFor: 'stream out' stamp: 'fbs 3/22/2004 13:07'! sendCommand: aString self outStream nextPutAll: aString; nextPutAll: String crlf.! ! !MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:09'! nextLineCrLf ^(self upToAll: String crlf).! ! !MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:10'! nextLine ^self nextLineCrLf! ! !MockSocketStream methodsFor: 'stream in' stamp: 'PeterHugossonMiller 9/3/2009 10:05'! resetInStream inStream := String new writeStream.! ! !MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:09'! upToAll: delims ^self inStream upToAll: delims.! ! !MockSocketStream methodsFor: 'testing' stamp: 'fbs 3/22/2004 13:08'! atEnd ^self inStream atEnd.! ! !MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 12:51'! atEnd: aBoolean atEnd := aBoolean.! ! !MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 13:29'! inStream ^inStream! ! !MockSocketStream methodsFor: 'stream out' stamp: 'PeterHugossonMiller 9/3/2009 10:05'! resetOutStream outStream := String new writeStream.! ! !MockSocketStream class methodsFor: 'instance creation' stamp: 'fbs 3/22/2004 12:46'! on: socket ^self basicNew initialize! ! !MockSourceEditor commentStamp: 'TorstenBergmann 1/31/2014 11:25'! A mock object mocking a source editor! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 13:43'! cut text := (text first: selectionStart-1), (text copyFrom: selectionEnd+1 to: text size). selectionStart := selectionStart - 1. selectionEnd := selectionStart! ! !MockSourceEditor methodsFor: 'initialization' stamp: 'PavelKrivanek 11/8/2012 13:22'! initialize super initialize. selectionStart := selectionEnd := 0.! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 13:31'! insertAndSelect: aString at: anInteger text := (text first: anInteger-1), (' ' , aString) asText, (text copyFrom: anInteger to: text size). selectionStart := anInteger. selectionEnd := anInteger + aString size ! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 13:25'! selection ^ self text copyFrom: selectionStart to: selectionEnd! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 13:24'! selectionInterval ^ Interval from: selectionStart to: selectionEnd.! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 12:49'! editor ^ self! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 13:23'! selectFrom: start to: end selectionStart := start. selectionEnd := end. ! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 12:48'! contents: aText text := aText! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 13:43'! startIndex ^ selectionStart! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 13:25'! selectionAsStream ^ ReadStream on: (self text copyFrom: selectionStart to: selectionEnd)! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 12:49'! text ^ text! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 13:23'! notify: aString at: anInteger in: aStream | pos | pos := self selectionInterval notEmpty ifTrue: [selectionStart + anInteger - 1 ] ifFalse: [anInteger]. self insertAndSelect: aString at: (pos max: 1)! ! !MockTranscript methodsFor: 'initialization' stamp: 'JorgeRessia 3/4/2010 21:19'! initialize super initialize. stream := String new writeStream.! ! !MockTranscript methodsFor: 'streaming' stamp: 'JorgeRessia 3/4/2010 21:19'! show: anObject stream nextPutAll: anObject asString ! ! !MockTranscript methodsFor: 'accessing' stamp: 'JorgeRessia 3/4/2010 21:19'! contents ^stream contents ! ! !MockTranscript methodsFor: 'streaming' stamp: 'JorgeRessia 3/4/2010 21:19'! cr stream cr! ! !MockTutorial commentStamp: 'TorstenBergmann 2/12/2014 22:49'! Mocking a tutorial for test purposes! !MockTutorial methodsFor: 'lesson' stamp: 'LaurentLaffont 1/21/2010 15:15'! thirdLesson ^ Lesson title: 'third' lesson: 'Third lesson'.! ! !MockTutorial methodsFor: 'lesson' stamp: 'LaurentLaffont 1/21/2010 15:15'! secondLesson ^ Lesson title: 'second' lesson: 'Second lesson'.! ! !MockTutorial methodsFor: 'tutorial' stamp: 'LaurentLaffont 1/21/2010 15:14'! tutorial ^ #( firstLesson secondLesson thirdLesson )! ! !MockTutorial methodsFor: 'lesson' stamp: 'LaurentLaffont 1/21/2010 15:15'! firstLesson ^ Lesson title: 'first' lesson: 'First lesson'.! ! !MockTutorial2 commentStamp: 'TorstenBergmann 2/12/2014 22:49'! Mocking another tutorial for test purposes! !Model commentStamp: ''! Provides a superclass for classes that function as models. The only behavior provided is fast dependents maintenance, which bypasses the generic DependentsFields mechanism. 1/23/96 sw! !Model methodsFor: '*UI-Basic-keyboard' stamp: 'nk 6/29/2004 14:46'! arrowKey: aChar from: view "backstop; all the PluggableList* classes actually handle arrow keys, and the models handle other keys." ^false! ! !Model methodsFor: '*Tools-Base' stamp: 'alain.plantec 6/10/2008 20:22'! containingWindow "Answer the window that holds the receiver. The dependents technique is odious and may not be airtight, if multiple windows have the same model. " ^ self dependents detect: [:d | (d isSystemWindow) and: [d model == self]] ifNone: []! ! !Model methodsFor: 'dependents' stamp: 'BenjaminVanRyseghem 7/29/2013 14:21'! removeDependent: anObject "Remove the given object as one of the receiver's dependents." | newDependents | newDependents := self dependents reject: [:each | each == anObject]. self myDependents: (newDependents isEmpty ifFalse: [ newDependents ]). ^ anObject! ! !Model methodsFor: '*Tools-Base' stamp: 'MarcusDenker 3/18/2011 16:03'! topView "Find the first top view on me. Is there any danger of their being two with the same model? Any danger from ungarbage collected old views? Ask if schedulled?" dependents ifNil: [^ nil]. dependents do: [:v | (v isSystemWindow and: [v isInWorld]) ifTrue: [^ v]]. ^ nil! ! !Model methodsFor: '*UI-Basic-menus' stamp: 'tk 4/17/1998 17:28'! selectedClass "All owners of TextViews are asked this during a doIt" ^ nil! ! !Model methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 7/24/2013 13:36'! update: anAspect ^ self! ! !Model methodsFor: 'dependents' stamp: 'BenjaminVanRyseghem 7/29/2013 14:12'! addDependent: anObject "Make the given object one of the receiver's dependents." (self dependents includes: anObject) ifFalse: [self myDependents: (self dependents copyWithDependent: anObject)]. ^ anObject! ! !Model methodsFor: 'copying' stamp: ''! veryDeepFixupWith: deepCopier "See if the dependents are being copied also. If so, point at the new copies. (The dependent has self as its model.) Dependents handled in class Object, when the model is not a Model, are fixed up in Object veryDeepCopy." | originalDependents refs | super veryDeepFixupWith: deepCopier. originalDependents := dependents. originalDependents ifNil: [ ^self. ]. dependents := nil. refs := deepCopier references. originalDependents do: [:originalDependent | | newDependent | newDependent := refs at: originalDependent ifAbsent: []. newDependent ifNotNil: [self addDependent: newDependent]]! ! !Model methodsFor: 'dependents' stamp: 'BenjaminVanRyseghem 12/6/2013 10:59'! dependents "Answer a collection of objects that are 'dependent' on the receiver; that is, all objects that should be notified if the receiver changes." ^ self myDependents ifNil: [#()]! ! !Model methodsFor: 'dependents-private' stamp: 'BenjaminVanRyseghem 7/29/2013 14:07'! myDependents: aCollectionOrNil dependents := aCollectionOrNil! ! !Model methodsFor: '*Polymorph-Widgets' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme ^ Smalltalk ui theme! ! !Model methodsFor: '*UI-Basic-menus' stamp: 'zz 3/2/2004 23:49'! step "Default for morphic models is no-op"! ! !Model methodsFor: '*UI-Basic-menus' stamp: 'sw 12/15/2000 13:21'! trash: ignored "Whatever the user submits to the trash, it need not be saved." ^ true! ! !Model methodsFor: 'dependents-private' stamp: 'BenjaminVanRyseghem 7/31/2013 14:12'! actAsExecutor "Prepare the receiver to act as executor for any resources associated with it" self breakDependents! ! !Model methodsFor: '*UI-Basic-edits' stamp: 'BenjaminVanRyseghem 7/29/2013 14:22'! canDiscardEdits "Answer true if none of the views on this model has unaccepted edits that matter." dependents ifNil: [ ^ true ]. self dependents do: [:each | each canDiscardEdits ifFalse: [ ^ false ] ] without: self. ^ true! ! !Model methodsFor: '*UI-Basic-menus' stamp: 'sw 12/15/2000 13:21'! trash "What should be displayed if a trash pane is restored to initial state" ^ ''! ! !Model methodsFor: '*UI-Basic-edits' stamp: 'EstebanLorenzano 9/21/2012 13:22'! hasUnacceptedEdits "Answer true if any of the views on this model has unaccepted edits." dependents ifNil: [^ false]. self dependents do: [:each | self flag: #fixMe. "The check for #respondsTo: is a hack necessary just because the old Browser uses it wrong. We need to change this after old Browser removal" ((each respondsTo: #hasUnacceptedEdits) and: [ each hasUnacceptedEdits ]) ifTrue: [^ true]] without: self. ^ false ! ! !Model methodsFor: 'dependents-private' stamp: 'BenjaminVanRyseghem 7/29/2013 14:16'! myDependents ^ dependents! ! !Model methodsFor: '*UI-Basic-menus' stamp: 'StephaneDucasse 3/18/2010 21:23'! initialExtent ^ RealEstateAgent standardWindowExtent! ! !Model class methodsFor: '*UI-Basic-window color' stamp: ''! patchworkUIThemeColor "Answer a default color for UI themes that make use of different colors for Browser, MessageList etc..." ^ Color gray whiter whiter lighter! ! !ModelDependentDialogWindow commentStamp: 'gvc 5/18/2007 12:44'! DialogWindow that updates content based upon its model.! !ModelDependentDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 15:27'! model: anObject "Set the model and add the panel for it." super model: anObject. self paneMorphs copy do: [:p | p delete]. self addMainPanel! ! !ModelDependentDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 15:27'! addInitialPanel "Don't until the model is set."! ! !ModelList commentStamp: 'BenjaminVanRyseghem 1/21/2014 16:35'! I am a simple list widget I am used to expose the construction of a spec UI in the Spec documentation.! !ModelList methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/21/2014 16:29'! initializeWidgets list := self newList. list items: (AbstractWidgetModel allSubclasses sorted: [:a :b | a name < b name ]). self focusOrder add: list! ! !ModelList methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 1/21/2014 15:19'! whenSelectedItemChanged: aBlock list whenSelectedItemChanged: aBlock! ! !ModelList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 16:32'! title ^ 'Widgets'! ! !ModelList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2014 15:17'! list ^ list! ! !ModelList class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/21/2014 15:18'! defaultSpec ^ SpecLayout composed add: #list; yourself! ! !ModifiedField commentStamp: ''! I encapsulate the modification of a slot. The two use-cases are: slot renaming or a changed slot type. Both cases enforce recompilation of all the methods accessing the corresponding variable. This is unlike the ShiftedField modification which is only used when the type of the slot does not change.! !ModifiedField methodsFor: 'installing' stamp: 'ToonVerwaest 3/28/2011 17:08'! installOn: aModification aModification installModifiedSlot: self! ! !ModifiedField methodsFor: 'accessing' stamp: 'CamilloBruni 3/28/2011 18:50'! originalSlot ^ originalSlot! ! !ModifiedField methodsFor: 'migrating' stamp: 'ToonVerwaest 3/30/2011 13:54'! migrateAt: index to: newInstance from: oldInstance newInstance instVarAt: index put: (oldInstance instVarAt: self oldFieldIndex)! ! !ModifiedField methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 17:14'! newFieldIndex ^ newSlot index + fieldIndex! ! !ModifiedField methodsFor: 'accessing' stamp: 'CamilloBruni 3/28/2011 18:50'! originalSlot: anObject originalSlot := anObject! ! !ModifiedField methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 16:34'! newSlot ^ newSlot! ! !ModifiedField methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 16:34'! newSlot: anObject newSlot := anObject! ! !ModifiedField methodsFor: 'accessing' stamp: 'ToonVerwaest 3/28/2011 17:14'! oldFieldIndex ^ originalSlot index + fieldIndex! ! !MondrianPlugin commentStamp: ''! A MondrianPlugin is a plugin which switch the code pane with a morph when a package is selwcted! !MondrianPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 8/21/2011 17:31'! classSelected: anAnnouncement | container | container := self model ui ifNotNil: [:view | view sourceCodeContainer ] ifNil: [ ^ self] . anAnnouncement itemClass ifNil: [ subMorphs ifNil: [ subMorphs := container submorphs ]. container removeAllMorphs. container addMorph: (self remplacementMorphUsing: anAnnouncement)] ifNotNil: [ subMorphs ifNotNil: [ container removeAllMorphs. subMorphs reverse do: [:each | container addMorph: each ]]]! ! !MondrianPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 8/21/2011 16:53'! registerTo: aModel aModel announcer on: NautilusClassSelected send: #classSelected: to: self! ! !MondrianPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 8/21/2011 17:03'! remplacementMorphUsing: anAnnouncement ^ Morph new color: Color blue; yourself! ! !MondrianPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 2/17/2012 16:49'! description ^ 'When a package is selected, replace the text morph by a morph. The purpose of this plugin is to be overriden'! ! !Monitor commentStamp: 'md 3/3/2006 09:19'! A monitor provides process synchronization that is more high level than the one provided by a Semaphore. Similar to the classical definition of a Monitor it has the following properties: 1) At any time, only one process can execute code inside a critical section of a monitor. 2) A monitor is reentrant, which means that the active process in a monitor never gets blocked when it enters a (nested) critical section of the same monitor. 3) Inside a critical section, a process can wait for an event that may be coupled to a certain condition. If the condition is not fulfilled, the process leaves the monitor temporarily (in order to let other processes enter) and waits until another process signals the event. Then, the original process checks the condition again (this is often necessary because the state of the monitor could have changed in the meantime) and continues if it is fulfilled. 4) The monitor is fair, which means that the process that is waiting on a signaled condition the longest gets activated first. 5) The monitor allows you to define timeouts after which a process gets activated automatically. Basic usage: Monitor>>critical: aBlock Critical section. Executes aBlock as a critical section. At any time, only one process can execute code in a critical section. NOTE: All the following synchronization operations are only valid inside the critical section of the monitor!! Monitor>>wait Unconditional waiting for the default event. The current process gets blocked and leaves the monitor, which means that the monitor allows another process to execute critical code. When the default event is signaled, the original process is resumed. Monitor>>waitWhile: aBlock Conditional waiting for the default event. The current process gets blocked and leaves the monitor only if the argument block evaluates to true. This means that another process can enter the monitor. When the default event is signaled, the original process is resumed, which means that the condition (argument block) is checked again. Only if it evaluates to false, does execution proceed. Otherwise, the process gets blocked and leaves the monitor again... Monitor>>waitUntil: aBlock Conditional waiting for the default event. See Monitor>>waitWhile: aBlock. Monitor>>signal One process waiting for the default event is woken up. Monitor>>signalAll All processes waiting for the default event are woken up. Using non-default (specific) events: Monitor>>waitFor: aSymbol Unconditional waiting for the non-default event represented by the argument symbol. Same as Monitor>>wait, but the process gets only reactivated by the specific event and not the default event. Monitor>>waitWhile: aBlock for: aSymbol Confitional waiting for the non-default event represented by the argument symbol. Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific event and not the default event. Monitor>>waitUntil: aBlock for: aSymbol Confitional waiting for the non-default event represented by the argument symbol. See Monitor>>waitWhile:for: aBlock. Monitor>>signal: aSymbol One process waiting for the given event is woken up. If there is no process waiting for this specific event, a process waiting for the default event gets resumed. Monitor>>signalAll: aSymbol All process waiting for the given event or the default event are woken up. Monitor>>signalReallyAll All processes waiting for any events (default or specific) are woken up. Using timeouts Monitor>>waitMaxMilliseconds: anInteger Monitor>>waitFor: aSymbol maxMilliseconds: anInteger Same as Monitor>>wait (resp. Monitor>>waitFor:), but the process gets automatically woken up when the specified time has passed. Monitor>>waitWhile: aBlock maxMilliseconds: anInteger Monitor>>waitWhile: aBlock for: aSymbol maxMilliseconds: anInteger Same as Monitor>>waitWhile: (resp. Monitor>>waitWhile:for:), but the process gets automatically woken up when the specified time has passed. Monitor>>waitUntil: aBlock maxMilliseconds: anInteger Monitor>>waitUntil: aBlock for: aSymbol maxMilliseconds: anInteger Same as Monitor>>waitUntil: (resp. Monitor>>waitUntil:for:), but the process gets automatically woken up when the specified time has passed.! !Monitor methodsFor: 'waiting-basic' stamp: 'fbs 3/24/2004 14:39'! waitWhile: aBlock "Conditional waiting for the default event. The current process gets blocked and leaves the monitor only if the argument block evaluates to true. This means that another process can enter the monitor. When the default event is signaled, the original process is resumed, which means that the condition (argument block) is checked again. Only if it evaluates to false, does execution proceed. Otherwise, the process gets blocked and leaves the monitor again..." ^ self waitWhile: aBlock for: nil! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:03'! waitFor: aSymbolOrNil maxMilliseconds: anIntegerOrNil "Same as Monitor>>waitFor:, but the process gets automatically woken up when the specified time has passed." self checkOwnerProcess. self waitInQueue: (self queueFor: aSymbolOrNil) maxMilliseconds: anIntegerOrNil.! ! !Monitor methodsFor: 'accessing' stamp: 'NS 7/1/2002 20:02'! cleanup self checkOwnerProcess. self critical: [self privateCleanup].! ! !Monitor methodsFor: 'private' stamp: 'StephaneDucasse 10/19/2010 14:01'! queueDict ^ queueDict ifNil: [queueDict := IdentityDictionary new]. ! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! waitWhile: aBlock maxSeconds: aNumber "Same as Monitor>>waitWhile:, but the process gets automatically woken up when the specified time has passed." ^ self waitWhile: aBlock maxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! waitUntil: aBlock for: aSymbolOrNil maxSeconds: aNumber "Same as Monitor>>waitUntil:for:, but the process gets automatically woken up when the specified time has passed." ^ self waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! waitWhile: aBlock for: aSymbolOrNil maxSeconds: aNumber "Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the specified time has passed." ^ self waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'private' stamp: 'ClementBera 7/26/2013 17:19'! exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil | lock delay | lock := queuesMutex critical: [anOrderedCollection addLast: Semaphore new]. self exit. anIntegerOrNil ifNil: [ lock wait ] ifNotNil: [ delay := MonitorDelay signalLock: lock afterMSecs: anIntegerOrNil inMonitor: self queue: anOrderedCollection. lock wait. delay unschedule. ]. self enter.! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:04'! waitMaxMilliseconds: anIntegerOrNil "Same as Monitor>>wait, but the process gets automatically woken up when the specified time has passed." ^ self waitFor: nil maxMilliseconds: anIntegerOrNil! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 13:17'! waitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil.! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! waitUntil: aBlock maxSeconds: aNumber "Same as Monitor>>waitUntil:, but the process gets automatically woken up when the specified time has passed." ^ self waitUntil: aBlock maxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 13:17'! waitWhile: aBlock inQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil [aBlock value] whileTrue: [self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil].! ! !Monitor methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:08'! initialize super initialize. mutex := Semaphore forMutualExclusion. queuesMutex := Semaphore forMutualExclusion. nestingLevel := 0.! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:42'! isOwnerProcess ^ Processor activeProcess == ownerProcess! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! waitUntil: aBlock maxMilliseconds: anIntegerOrNil "Same as Monitor>>waitUntil:, but the process gets automatically woken up when the specified time has passed." ^ self waitUntil: aBlock for: nil maxMilliseconds: anIntegerOrNil! ! !Monitor methodsFor: 'signaling-default' stamp: 'NS 7/1/2002 21:57'! signal "One process waiting for the default event is woken up." ^ self signal: nil! ! !Monitor methodsFor: 'signaling-specific' stamp: 'NS 4/13/2004 15:12'! signal: aSymbolOrNil "One process waiting for the given event is woken up. If there is no process waiting for this specific event, a process waiting for the default event gets resumed." | queue | self checkOwnerProcess. queue := self queueFor: aSymbolOrNil. queue isEmpty ifTrue: [queue := self defaultQueue]. self signalQueue: queue.! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:40'! checkOwnerProcess self isOwnerProcess ifFalse: [self error: 'Monitor access violation'].! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! waitWhile: aBlock maxMilliseconds: anIntegerOrNil "Same as Monitor>>waitWhile:, but the process gets automatically woken up when the specified time has passed." ^ self waitWhile: aBlock for: nil maxMilliseconds: anIntegerOrNil! ! !Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 21:58'! waitFor: aSymbolOrNil "Unconditional waiting for the non-default event represented by the argument symbol. Same as Monitor>>wait, but the process gets only reactivated by the specific event and not the default event." ^ self waitFor: aSymbolOrNil maxMilliseconds: nil! ! !Monitor methodsFor: 'private' stamp: 'Lukas Renggli 11/2/2009 00:29'! queueFor: aSymbol aSymbol ifNil: [^self defaultQueue]. ^self queueDict at: aSymbol ifAbsentPut: [OrderedCollection new]! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:34'! signalLock: aSemaphore inQueue: anOrderedCollection queuesMutex critical: [ aSemaphore signal. anOrderedCollection remove: aSemaphore ifAbsent: []. ].! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:06'! defaultQueue defaultQueue ifNil: [defaultQueue := OrderedCollection new]. ^ defaultQueue! ! !Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 22:01'! waitUntil: aBlock for: aSymbolOrNil "Confitional waiting for the non-default event represented by the argument symbol. See Monitor>>waitWhile:for: aBlock." ^ self waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: nil! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:14'! privateCleanup queuesMutex critical: [ defaultQueue isEmpty ifTrue: [defaultQueue := nil]. queueDict ifNotNil: [ queueDict copy keysAndValuesDo: [:id :queue | queue isEmpty ifTrue: [queueDict removeKey: id]]. queueDict isEmpty ifTrue: [queueDict := nil]. ]. ].! ! !Monitor methodsFor: 'synchronization' stamp: 'nice 12/26/2009 00:10'! critical: aBlock "Critical section. Executes aBlock as a critical section. At any time, only one process can be executing code in a critical section. NOTE: All the following synchronization operations are only valid inside the critical section of the monitor!!" ^[ self enter. aBlock value] ensure: [self exit].! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: anIntegerOrNil "Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the specified time has passed." self checkOwnerProcess. self waitWhile: aBlock inQueue: (self queueFor: aSymbolOrNil) maxMilliseconds: anIntegerOrNil.! ! !Monitor methodsFor: 'signaling-default' stamp: 'NS 7/1/2002 21:57'! signalAll "All processes waiting for the default event are woken up." ^ self signalAll: nil! ! !Monitor methodsFor: 'signaling-specific' stamp: 'NS 7/1/2002 22:02'! signalReallyAll "All processes waiting for any events (default or specific) are woken up." self checkOwnerProcess. self signalAll. self queueDict valuesDo: [:queue | self signalAllInQueue: queue].! ! !Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 22:01'! waitWhile: aBlock for: aSymbolOrNil "Confitional waiting for the non-default event represented by the argument symbol. Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific event and not the default event." ^ self waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: nil! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:04'! waitFor: aSymbolOrNil maxSeconds: aNumber "Same as Monitor>>waitFor:, but the process gets automatically woken up when the specified time has passed." ^ self waitFor: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! waitMaxSeconds: aNumber "Same as Monitor>>wait, but the process gets automatically woken up when the specified time has passed." ^ self waitMaxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'waiting-basic' stamp: 'NS 7/1/2002 21:56'! waitUntil: aBlock "Conditional waiting for the default event. See Monitor>>waitWhile: aBlock." ^ self waitUntil: aBlock for: nil! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: anIntegerOrNil "Same as Monitor>>waitUntil:for:, but the process gets automatically woken up when the specified time has passed." ^ self waitWhile: [aBlock value not] for: aSymbolOrNil maxMilliseconds: anIntegerOrNil! ! !Monitor methodsFor: 'signaling-specific' stamp: 'NS 7/1/2002 22:02'! signalAll: aSymbolOrNil "All process waiting for the given event or the default event are woken up." | queue | self checkOwnerProcess. queue := self queueFor: aSymbolOrNil. self signalAllInQueue: self defaultQueue. queue ~~ self defaultQueue ifTrue: [self signalAllInQueue: queue].! ! !Monitor methodsFor: 'waiting-basic' stamp: 'NS 7/1/2002 21:55'! wait "Unconditional waiting for the default event. The current process gets blocked and leaves the monitor, which means that the monitor allows another process to execute critical code. When the default event is signaled, the original process is resumed." ^ self waitMaxMilliseconds: nil! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:38'! exit nestingLevel := nestingLevel - 1. nestingLevel < 1 ifTrue: [ ownerProcess := nil. mutex signal ].! ! !Monitor methodsFor: 'private' stamp: 'StephaneDucasse 10/19/2010 14:05'! signalAllInQueue: anOrderedCollection queuesMutex critical: [ anOrderedCollection removeAllSuchThat: [ :each | each signal. true ] ]! ! !Monitor methodsFor: 'private' stamp: 'StephaneDucasse 10/19/2010 14:03'! signalQueue: anOrderedCollection queuesMutex critical: [ anOrderedCollection isEmpty ifFalse: [ anOrderedCollection removeFirst signal ] ]! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:37'! enter self isOwnerProcess ifTrue: [ nestingLevel := nestingLevel + 1. ] ifFalse: [ mutex wait. ownerProcess := Processor activeProcess. nestingLevel := 1. ].! ! !MonitorDelay commentStamp: 'NS 4/13/2004 16:51'! This is a specialization of the class Delay that is used for the implementation of the class Monitor.! !MonitorDelay methodsFor: 'private' stamp: 'NS 4/13/2004 16:26'! setDelay: anInteger forSemaphore: aSemaphore monitor: aMonitor queue: anOrderedCollection monitor := aMonitor. queue := anOrderedCollection. self setDelay: anInteger forSemaphore: aSemaphore.! ! !MonitorDelay methodsFor: 'private' stamp: 'NS 4/13/2004 16:22'! signalWaitingProcess "The delay time has elapsed; signal the waiting process." beingWaitedOn := false. monitor signalLock: delaySemaphore inQueue: queue. ! ! !MonitorDelay class methodsFor: 'instance creation' stamp: 'NS 4/13/2004 16:25'! signalLock: aSemaphore afterMSecs: anInteger inMonitor: aMonitor queue: anOrderedCollection anInteger < 0 ifTrue: [self error: 'delay times cannot be negative']. ^ (self new setDelay: anInteger forSemaphore: aSemaphore monitor: aMonitor queue: anOrderedCollection) schedule! ! !MonitorTest commentStamp: 'TorstenBergmann 2/5/2014 08:41'! SUnit tests for monitors! !MonitorTest methodsFor: 'examples' stamp: 'md 3/19/2006 21:15'! testExample1 | producer1 producer2 monitor goal work counter goalReached finished | goal := (1 to: 1000) asOrderedCollection. work := OrderedCollection new. counter := 0. goalReached := false. finished := Semaphore new. monitor := Monitor new. producer1 := [ [monitor critical: [monitor waitUntil: [counter \\5 = 0]. goalReached or: [work add: (counter := counter + 1)]. goalReached := counter >= goal size. monitor signal ]. goalReached ] whileFalse. finished signal. ]. producer2 := [ [monitor critical: [monitor waitWhile: [counter \\5 = 0]. goalReached or: [work add: (counter := counter + 1)]. goalReached := counter >= goal size. monitor signal]. goalReached ] whileFalse. finished signal ]. producer1 forkAt: Processor userBackgroundPriority. producer2 forkAt: Processor userBackgroundPriority. finished wait; wait. self assert: goal = work! ! !MonitorTest methodsFor: 'examples' stamp: 'md 3/19/2006 21:19'! testExample2 "Here is a second version that does not use a semaphore to inform the forking process about termination of both forked processes" | producer1 producer2 monitor goal work counter goalReached activeProducers| goal := (1 to: 1000) asOrderedCollection. work := OrderedCollection new. counter := 0. goalReached := false. activeProducers := 0. monitor := Monitor new. producer1 := [ monitor critical: [activeProducers := activeProducers + 1]. [monitor critical: [monitor waitUntil: [counter \\5 = 0]. goalReached or: [work add: (counter := counter + 1)]. " Transcript show: 'P1 '; show: counter printString; show: ' '; show: activeProducers printString; cr." goalReached := counter >= goal size. monitor signal ]. goalReached ] whileFalse. monitor critical: [activeProducers := activeProducers - 1. monitor signal: #finish]. ] . producer2 := [monitor critical: [activeProducers := activeProducers + 1]. [monitor critical: [monitor waitWhile: [counter \\5 = 0]. goalReached or: [work add: (counter := counter + 1)]. goalReached := counter >= goal size. monitor signal]. goalReached ] whileFalse. monitor critical: [ activeProducers := activeProducers - 1. monitor signal: #finish]. ]. producer1 forkAt: Processor userBackgroundPriority. producer2 forkAt: Processor userBackgroundPriority. monitor critical: [ monitor waitUntil: [activeProducers = 0 & (goalReached)] for: #finish. ]. self assert: goal = work ! ! !Month commentStamp: 'brp 5/13/2003 09:48'! I represent a month.! !Month methodsFor: 'accessing' stamp: 'brp 5/13/2003 09:05'! previous ^ self class starting: (self start - 1) ! ! !Month methodsFor: 'conversion' stamp: 'brp 5/13/2003 09:04'! asMonth ^ self ! ! !Month methodsFor: 'testing' stamp: 'brp 5/13/2003 09:05'! name ^ self monthName ! ! !Month methodsFor: 'accessing' stamp: 'brp 5/13/2003 09:05'! daysInMonth ^ self duration days.! ! !Month methodsFor: 'printing' stamp: 'brp 5/13/2003 09:05'! printOn: aStream aStream nextPutAll: self monthName, ' ', self year printString.! ! !Month methodsFor: 'accessing' stamp: 'brp 5/13/2003 09:05'! index ^ self monthIndex ! ! !Month class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/22/2013 19:41'! month: month "Create a Month in the current year for the given . may be a number or a String with the name of the month." ^ self year: DateAndTime now year month: month ! ! !Month class methodsFor: 'accessing' stamp: 'brp 5/13/2003 09:02'! nameOfMonth: anIndex ^ MonthNames at: anIndex.! ! !Month class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/22/2013 19:42'! readFrom: aStream | m y c | m := (ReadWriteStream with: '') reset. [(c := aStream next) isSeparator] whileFalse: [m nextPut: c]. [(c := aStream next) isSeparator] whileTrue. y := (ReadWriteStream with: '') reset. y nextPut: c. [aStream atEnd] whileFalse: [y nextPut: aStream next]. ^ self year: y contents asNumber month: (Month indexOfMonth: m contents) "Month readFrom: 'July 1998' readStream" ! ! !Month class methodsFor: 'accessing' stamp: 'brp 7/27/2003 16:27'! daysInMonth: indexOrName forYear: yearInteger | index | index := indexOrName isInteger ifTrue: [indexOrName] ifFalse: [self indexOfMonth: indexOrName]. ^ (DaysInMonth at: index) + ((index = 2 and: [Year isLeapYear: yearInteger]) ifTrue: [1] ifFalse: [0])! ! !Month class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/22/2013 18:53'! starting: aDateAndTime duration: aDuration "Override - a each month has a defined duration" | start adjusted days | start := aDateAndTime asDateAndTime. adjusted := DateAndTime year: start year month: start month day: 1. days := self daysInMonth: adjusted month forYear: adjusted year. ^ super starting: adjusted duration: (Duration days: days)! ! !Month class methodsFor: 'accessing' stamp: 'brp 8/23/2003 09:29'! indexOfMonth: aMonthName 1 to: 12 do: [ :i | (aMonthName, '*' match: (MonthNames at: i)) ifTrue: [^i] ]. self error: aMonthName , ' is not a recognized month name'.! ! !Month class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/22/2013 18:50'! current ^ self starting: DateAndTime now! ! !Month class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/22/2013 19:37'! year: year month: month "Create a Month for the given and . may be a number or a String with the name of the month. should be with 4 digits." ^ self starting: (DateAndTime year: year month: month day: 1) ! ! !Month class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/22/2013 19:37'! month: month year: year ^ self year: year month: month! ! !MonthTest commentStamp: 'brp 7/26/2003 22:44'! This is the unit test for the class Month. ! !MonthTest methodsFor: 'tests' stamp: 'brp 8/23/2003 16:08'! testInquiries self assert: month index = 7; assert: month name = #July; assert: month duration = (31 days). ! ! !MonthTest methodsFor: 'tests' stamp: 'CamilloBruni 8/22/2013 19:42'! testInstanceCreation | m1 m2 | m1 := Month starting: '4 July 1998' asDate. m2 := Month year: 1998 month: #July . self assert: month = m1; assert: month = m2! ! !MonthTest methodsFor: 'coverage' stamp: 'brp 7/26/2003 23:29'! selectorsToBeIgnored | deprecated private special | deprecated := #(). private := #( #printOn: ). special := #( #next ). ^ super selectorsToBeIgnored, deprecated, private, special.! ! !MonthTest methodsFor: 'running' stamp: 'brp 8/6/2003 19:37'! tearDown super tearDown. month := nil.! ! !MonthTest methodsFor: 'coverage' stamp: 'brp 7/27/2003 12:42'! classToBeTested ^ Month! ! !MonthTest methodsFor: 'tests' stamp: 'brp 7/26/2003 22:46'! testReadFrom | m | m := Month readFrom: 'July 1998' readStream. self assert: m = month! ! !MonthTest methodsFor: 'running' stamp: 'CamilloBruni 8/22/2013 19:42'! setUp super setUp. month := Month year: 1998 month: 7.! ! !MonthTest methodsFor: 'tests' stamp: 'brp 1/30/2005 09:35'! testEnumerating | weeks | weeks := OrderedCollection new. month weeksDo: [ :w | weeks add: w start ]. 0 to: 4 do: [ :i | weeks remove: (Week starting: ('29 June 1998' asDate addDays: i * 7)) start ]. self assert: weeks isEmpty! ! !MonthTest methodsFor: 'tests' stamp: 'brp 7/26/2003 23:02'! testPreviousNext | n p | n := month next. p := month previous. self assert: n year = 1998; assert: n index = 8; assert: p year = 1998; assert: p index = 6. ! ! !MonthTest methodsFor: 'tests' stamp: 'brp 7/26/2003 22:50'! testPrinting self assert: month printString = 'July 1998'. ! ! !MonthTest methodsFor: 'tests' stamp: 'StephaneDucasse 6/9/2012 22:57'! testIndexOfMonth "self debug: #testIndexOfMonth" | m | m := #(#January #February #March #April #May #June #July #August #September #October #November #December). m withIndexDo: [:item :index | self assert: (Month indexOfMonth: item) = index]. self should: [Month indexOfMonth: 1] raise: self defaultTestError. self should: [Month indexOfMonth: #Marsh] raise: self defaultTestError. "notice the misspell!!!!" self should: [Month indexOfMonth: #UnexistingMonth] raise: self defaultTestError.! ! !MonthTest methodsFor: 'tests' stamp: 'brp 7/26/2003 22:52'! testConverting self assert: month asDate = '1 July 1998' asDate! ! !MonthTest methodsFor: 'tests' stamp: 'StephaneDucasse 6/9/2012 22:56'! testNameOfMonth | m | m := #(#January #February #March #April #May #June #July #August #September #October #November #December). m withIndexDo: [:item :index | self assert: (Month nameOfMonth: index) = item]. self should: [Month nameOfMonth: 0] raise: self defaultTestError. self should: [Month nameOfMonth: 13] raise: self defaultTestError. self should: [Month nameOfMonth: #January] raise: self defaultTestError.! ! !MonticelloRepositoryBrowser commentStamp: ''! MonticelloRepositoryBrowser example! !MonticelloRepositoryBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 4/17/2012 18:04'! workingCopies ^ workingCopies! ! !MonticelloRepositoryBrowser methodsFor: 'menu' stamp: 'StephaneDucasse 4/17/2012 18:48'! orderString: anIndex ^ String streamContents: [ :stream | order = anIndex ifTrue: [ stream nextPutAll: '' ] ifFalse: [ stream nextPutAll: '' ]. stream nextPutAll: (self orderSpecs at: anIndex) key ]! ! !MonticelloRepositoryBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 6/2/2012 20:29'! allManagers ^ self class allManagers ! ! !MonticelloRepositoryBrowser methodsFor: 'menu' stamp: 'StephaneDucasse 4/17/2012 18:35'! orderSpecs ^ { 'Sort alphabetically' -> [ :a :b | a package name <= b package name ]. 'Sort dirty first' -> [ :a :b | a needsSaving = b needsSaving ifTrue: [ a package name <= b package name ] ifFalse: [ a needsSaving ] ]. 'Sort dirty last' -> [ :a :b | a needsSaving = b needsSaving ifTrue: [ a package name <= b package name ] ifFalse: [ b needsSaving ] ]. 'Only dirty' -> [ :a :b | a package name <= b package name ]}! ! !MonticelloRepositoryBrowser methodsFor: 'private' stamp: 'StephaneDucasse 4/17/2012 19:11'! defaultOrderingBlock ^ (self orderSpecs at: self class order) value! ! !MonticelloRepositoryBrowser methodsFor: 'menu' stamp: 'StephaneDucasse 6/2/2012 20:29'! workingCopiesFromMC ^ (self orderSpecs size = order ifTrue: [ self allManagers select: [ :each | each modified ] ] ifFalse: [ self allManagers ]) asSortedCollection: (self orderSpecs at: order) value.! ! !MonticelloRepositoryBrowser methodsFor: 'private' stamp: 'StephaneDucasse 4/17/2012 18:20'! repositoriesOfWorkingCopy: aWorkingCopy ^ aWorkingCopy isNil ifFalse: [ aWorkingCopy repositoryGroup repositories] ifTrue: [ self allRepositories] ! ! !MonticelloRepositoryBrowser methodsFor: 'menu' stamp: 'StephaneDucasse 4/19/2012 18:17'! workingCopiesMenu: aMenu aMenu target: self; add: 'Browse working copy' action: #browseWorkingCopy. 1 to: self orderSpecs size do: [ :index | aMenu addUpdating: #orderString: target: self selector: #order: argumentList: {index} ]. ^ aMenu! ! !MonticelloRepositoryBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 4/19/2012 18:20'! workingCopy ^ workingCopies selectedItem! ! !MonticelloRepositoryBrowser methodsFor: 'menu' stamp: 'StephaneDucasse 4/17/2012 18:49'! order ^ order! ! !MonticelloRepositoryBrowser methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 9/25/2013 18:24'! initializeWidgets self instantiateModels: #( repositories #ListModel workingCopies #ListModel). workingCopies sortingBlock: self defaultOrderingBlock. workingCopies displayBlock: [ :item | item description ]. workingCopies menu: [ :aMenu | self workingCopiesMenu: aMenu ]. repositories displayBlock: [ :item | item description ]. repositories items: self allRepositories. "so that when we tab we go from working copies to repositories" self focusOrder add: workingCopies; add: repositories! ! !MonticelloRepositoryBrowser methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 22:57'! initialize super initialize. order := self class order! ! !MonticelloRepositoryBrowser methodsFor: 'actions' stamp: 'StephaneDucasse 4/19/2012 18:19'! openRepository self repository ifNotNil: [:repos | repos morphicOpen: self workingCopy ]! ! !MonticelloRepositoryBrowser methodsFor: 'menu' stamp: 'SD 4/19/2012 16:16'! order: anInteger order := anInteger. self workingCopies sortingBlock: (self orderSpecs at: order) value. self order = 4 "dirty only" ifTrue: [self workingCopies filteringBlock: [:col | col select: #modified]] ifFalse: [self workingCopies resetFilteringBlock]. ! ! !MonticelloRepositoryBrowser methodsFor: 'private' stamp: 'StephaneDucasse 4/17/2012 18:31'! allRepositories ^ MCRepositoryGroup default repositories! ! !MonticelloRepositoryBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 4/17/2012 18:04'! repositories ^ repositories! ! !MonticelloRepositoryBrowser methodsFor: 'actions' stamp: 'StephaneDucasse 4/19/2012 18:21'! newRepository | types index | types := MCRepository allConcreteSubclasses asArray. index := UIManager default chooseFrom: (types collect: [:ea | ea description]) title: 'Repository type:'. ^ index = 0 ifFalse: [(types at: index) morphicConfigure]! ! !MonticelloRepositoryBrowser methodsFor: 'protocol' stamp: 'SD 4/19/2012 16:12'! workingCopies: aCollection "Set the value of the list widget" workingCopies items: aCollection ! ! !MonticelloRepositoryBrowser methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 6/12/2012 18:41'! initializePresenter workingCopies whenSelectedItemChanged: [ :item | repositories items: (self repositoriesOfWorkingCopy: item) ].! ! !MonticelloRepositoryBrowser methodsFor: 'actions' stamp: 'StephaneDucasse 4/19/2012 18:20'! browseWorkingCopy | workingCopy | workingCopy := self workingCopy. workingCopy ifNotNil: [ (MCSnapshotBrowser forSnapshot: workingCopy completeSnapshot) label: 'Snapshot Browser: ' , workingCopy packageName; show ]! ! !MonticelloRepositoryBrowser methodsFor: 'initialize' stamp: 'StephaneDucasse 4/17/2012 18:06'! initialExtent ^ 600@200! ! !MonticelloRepositoryBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 9/27/2013 10:48'! defaultSpec ^ { #ContainerModel. #add: . {{#model . #workingCopies} . #layout: . #(FrameLayout rightFraction: 0.5)} . #add: . {{#model . #repositories } . #layout: . #(FrameLayout leftFraction: 0.5)} }! ! !MonticelloRepositoryBrowser class methodsFor: 'utils' stamp: 'StephaneDucasse 4/17/2012 18:42'! order: anInteger Order := anInteger! ! !MonticelloRepositoryBrowser class methodsFor: 'utils' stamp: 'StephaneDucasse 6/2/2012 20:29'! allManagers ^ MCWorkingCopy allManagers ! ! !MonticelloRepositoryBrowser class methodsFor: 'utils' stamp: 'StephaneDucasse 4/17/2012 18:41'! order ^ Order ifNil: [ Order := 1 ]! ! !MonticelloRepositoryBrowser class methodsFor: 'example' stamp: 'StephaneDucasse 6/2/2012 20:29'! example "self example" self new openWithSpec ; workingCopies: (self allManagers)! ! !MonticelloRepositoryBrowser class methodsFor: 'spec' stamp: 'StephaneDucasse 4/17/2012 18:07'! title ^ 'Monticello Browser'! ! !Morph commentStamp: 'efc 2/26/2003 20:01'! A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://minnow.cc.gatech.edu/squeak/30. Morphs exist in a tree, rooted at a World (generally a PasteUpMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets drawn. To hide a Morph and its submorphs, set its #visible property to false using the #visible: method. The World (screen) coordinate system is used for most coordinates, but can be changed if there is a TransformMorph somewhere in the owner chain. My instance variables have accessor methods (e.g., #bounds, #bounds:). Most users should use the accessor methods instead of using the instance variables directly. Structure: instance var Type Description bounds Rectangle A Rectangle indicating my position and a size that will enclose me. owner Morph My parent Morph, or nil for the top-level Morph, which is a or nil world, typically a PasteUpMorph. submorphs Array My child Morphs. fullBounds Rectangle A Rectangle minimally enclosing me and my submorphs. color Color My primary color. Subclasses can use this in different ways. extension MorphExtension Allows extra properties to be stored without adding a or nil storage burden to all morphs. By default, Morphs do not position their submorphs. Morphs may position their submorphs directly or use a LayoutPolicy to automatically control their submorph positioning. Although Morph has some support for BorderStyle, most users should use BorderedMorph if they want borders.! !Morph methodsFor: 'submorphs-accessing' stamp: 'ar 9/9/2000 17:31'! morphsInFrontOverlapping: aRectangle do: aBlock "Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle." ^self morphsInFrontOf: nil overlapping: aRectangle do: aBlock! ! !Morph methodsFor: 'text-anchor' stamp: 'StephaneDucasse 4/22/2012 16:50'! hasDocumentAnchorString ^ (self textAnchorType == #document) -> 'Document' translated! ! !Morph methodsFor: 'submorphs-accessing' stamp: ''! submorphCount ^ submorphs size! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/25/2008 17:35'! mouseWheel: evt "Handle a mouseWheel event."! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'GaryChambers 12/2/2011 12:00'! basicTheme: aUITheme "Set the current theme for the receiver." self theme = aUITheme ifFalse: [ self setProperty: #theme toValue: aUITheme]! ! !Morph methodsFor: 'testing' stamp: 'ar 12/3/2001 12:33'! shouldDropOnMouseUp | former | former := self formerPosition ifNil:[^false]. ^(former dist: self position) > 10! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'LC 9/28/1999 19:12'! findDeepSubmorphThat: block1 ifAbsent: block2 self allMorphsDo: [:m | (block1 value: m) == true ifTrue: [^ m]]. ^ block2 value! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'ar 9/9/2000 17:31'! morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock "Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle. someMorph is either an immediate child of the receiver or nil (in which case all submorphs of the receiver are enumerated)." self submorphsDo:[:m| m == someMorph ifTrue:["Try getting out quickly" owner ifNil:[^self]. ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock]. (m fullBoundsInWorld intersects: aRectangle) ifTrue:[aBlock value: m]]. owner ifNil:[^self]. ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock.! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'! vResizing: aSymbol "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are: #rigid - do not resize the receiver #spaceFill - resize to fill owner's available space #shrinkWrap - resize to fit children " self assureLayoutProperties vResizing: aSymbol. self layoutChanged. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:30'! balloonFont: aFont ^ self setProperty: #balloonFont toValue: aFont! ! !Morph methodsFor: 'menus' stamp: 'StephaneDucasse 4/22/2012 16:53'! lockedString "Answer the string to be shown in a menu to represent the 'locked' status" ^ (self isLocked) -> 'be locked' translated! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:53'! highlightedForDrop ^(self valueOfProperty: #highlightedForDrop) == true! ! !Morph methodsFor: 'meta-actions' stamp: 'yo 3/15/2005 14:45'! blueButtonDown: anEvent "Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph." | h tfm doNotDrag | h := anEvent hand halo. "Prevent wrap around halo transfers originating from throwing the event back in" doNotDrag := false. h ifNotNil:[ (h innerTarget == self) ifTrue:[doNotDrag := true]. (h innerTarget hasOwner: self) ifTrue:[doNotDrag := true]. (self hasOwner: h target) ifTrue:[doNotDrag := true]]. tfm := (self transformedFrom: nil) inverseTransformation. "cmd-drag on flexed morphs works better this way" h := self addHalo: (anEvent transformedBy: tfm). h ifNil: [^ self]. doNotDrag ifTrue:[^self]. "Initiate drag transition if requested" anEvent hand waitForClicksOrDrag: h event: (anEvent transformedBy: tfm) selectors: { nil. nil. nil. #dragTarget:. } threshold: 5. "Pass focus explicitly here" anEvent hand newMouseFocus: h.! ! !Morph methodsFor: 'rotate scale and flex' stamp: 'AlainPlantec 5/8/2010 00:33'! removeFlexShell self isFlexed ifTrue: [self owner removeFlexShell]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 5/7/2010 23:29'! addOptionalHandlesTo: aHalo box: box ! ! !Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 14:51'! defaultEventDispatcher "Return the default event dispatcher to use with events that are directly sent to the receiver" ^MorphicEventDispatcher new! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 8/31/2004 16:53'! dockingBars "Answer the receiver's dockingBars" ^ self submorphs select: [:each | each isDockingBar] ! ! !Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 19:05'! isInWorld "Return true if this morph is in a world." ^self world notNil! ! !Morph methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/28/2012 00:58'! simulateKeyStroke: aCharacter | event | event := KeyboardEvent new setType: #keystroke buttons: 0 position: 0@0 keyValue: aCharacter charCode charCode: aCharacter charCode hand: ActiveHand stamp: 0. self keyStroke: event! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'! hasSubmorphs ^submorphs notEmpty! ! !Morph methodsFor: 'geometry' stamp: 'IgorStasenko 12/22/2012 03:13'! overlapsShadowForm: itsShadow bounds: itsBounds "Answer true if itsShadow and my shadow overlap at all" | andForm overlapExtent | overlapExtent := (itsBounds intersect: self fullBounds ifNone: [ ^ false ]) extent. overlapExtent > (0 @ 0) ifFalse: [^ false]. andForm := self shadowForm. overlapExtent ~= self fullBounds extent ifTrue: [andForm := andForm contentsOfArea: (0 @ 0 extent: overlapExtent)]. andForm := andForm copyBits: (self fullBounds translateBy: itsShadow offset negated) from: itsShadow at: 0 @ 0 clippingBox: (0 @ 0 extent: overlapExtent) rule: Form and fillColor: nil. ^ andForm bits anySatisfy: [:w | w ~= 0]! ! !Morph methodsFor: 'geometry' stamp: 'di 7/24/97 11:55'! align: aPoint1 with: aPoint2 "Translate by aPoint2 - aPoint1." ^ self position: self position + (aPoint2 - aPoint1)! ! !Morph methodsFor: 'layout-properties' stamp: 'md 2/27/2006 09:59'! layoutFrame "Layout specific. Return the layout frame describing where the receiver should appear in a proportional layout" ^ extension ifNotNil: [extension layoutFrame]! ! !Morph methodsFor: 'rounding' stamp: 'MarcusDenker 10/26/2011 14:58'! useRoundedCorners self cornerStyle: #rounded! ! !Morph methodsFor: 'events-processing' stamp: 'CamilleTeruel 12/6/2013 14:36'! handleUnknownEvent: anEvent "An event of an unknown type was sent to the receiver. What shall we do?!!" self inform: 'Unknown event: ', anEvent printString. anEvent printString displayAt: 0@0. anEvent wasHandled: true.! ! !Morph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/11/2012 16:51'! drawOnAthensCanvas: anAthensCanvas | border | border := self borderStyle. anAthensCanvas setPaint: self fillStyle. anAthensCanvas drawShape: self bounds. "Fill the given rectangle." anAthensCanvas drawShape: (self bounds insetBy: border width). (anAthensCanvas setStrokePaint: border color) width: border width. anAthensCanvas drawShape: (self bounds insetBy: (border width /2 asFloat)). "aBorderStyle frameRectangle: aRectangle on: self " ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 14:29'! focusBounds "Answer the bounds for drawing the focus indication." ^self bounds! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'MarcusDenker 12/11/2009 07:40'! navigateFocusForward "Change the keyboard focus to the next morph." self nextMorphWantingFocus ifNotNil: [:m | m takeKeyboardFocus] ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/15/2009 13:35'! shadowOffsetRectangle "Answer a rectangle describing the offsets to the receiver's bounds for a drop shadow." ^self shadowOffset negated corner: self shadowOffset! ! !Morph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 11/23/2013 21:17'! setModal: aSystemWindow |area mySysWin keyboardFocus| keyboardFocus := self activeHand keyboardFocus. mySysWin := self isSystemWindow ifTrue: [self] ifFalse: [self ownerThatIsA: SystemWindow]. mySysWin ifNil: [mySysWin := self]. mySysWin modalLockTo: aSystemWindow. area := RealEstateAgent maximumUsableArea. aSystemWindow extent: aSystemWindow initialExtent. aSystemWindow position = (0@0) ifTrue: [aSystemWindow position: self activeHand position - (aSystemWindow extent // 2)]. aSystemWindow bounds: (aSystemWindow bounds translatedToBeWithin: area). [ |aWidget | aWidget := aSystemWindow. [aWidget world notNil] whileTrue: [ aWidget outermostWorldMorph doOneCycle]] ensure: [mySysWin modalUnlockFrom: aSystemWindow. self activeHand newKeyboardFocus: keyboardFocus]. ^aSystemWindow! ! !Morph methodsFor: 'stepping and presenter' stamp: 'ar 2/12/2001 17:04'! step "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message. The generic version dispatches control to the player, if any. The nasty circumlocation about owner's transformation is necessitated by the flexing problem that the player remains in the properties dictionary both of the flex and the real morph. In the current architecture, only the top renderer's pointer to the player should actually be honored for the purpose of firing." ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'GuillermoPolito 5/3/2012 21:05'! delete "Remove the receiver as a submorph of its owner and make its new owner be nil." self removeHalo. self activeHand releaseKeyboardFocus: self; releaseMouseFocus: self. owner ifNotNil:[ self privateDelete. self announceDeleted. ].! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/25/2008 17:34'! handlesMouseWheel: evt "Do I want to receive mouseWheel events?." ^false! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 8/6/2013 16:23'! allowsKeymapping: aBoolean ^ self setProperty: #allowsKeymapping toValue: aBoolean! ! !Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:48'! changeParagraphAnchor "Change the anchor from/to paragraph anchoring" | newType | newType := self textAnchorType == #paragraph ifTrue: [#document] ifFalse: [#paragraph]. owner isTextMorph ifTrue: [owner anchorMorph: self at: self position type: newType]! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/28/2001 08:39'! actWhen "Answer when the receiver, probably being used as a button, should have its action triggered" ^ self valueOfProperty: #actWhen ifAbsentPut: [#buttonDown]! ! !Morph methodsFor: 'stepping and presenter' stamp: 'ar 12/15/2000 00:00'! stopStepping "Stop getting sent the 'step' message." | w | w := self world. w ifNotNil: [w stopStepping: self]. ! ! !Morph methodsFor: 'testing' stamp: 'AlainPlantec 5/5/2010 17:55'! isFlexed "Return true if the receiver is currently flexed" ^ owner notNil and: [owner isFlexMorph]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:13'! formerPosition ^self valueOfProperty: #formerPosition! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:01'! point: aPoint from: aReferenceMorph owner ifNil: [^ aPoint]. ^ (owner transformFrom: aReferenceMorph) globalPointToLocal: aPoint. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/25/2001 10:23'! actWhen: aButtonPhase "Set the receiver's actWhen trait" self setProperty: #actWhen toValue: aButtonPhase! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'! wrapCentering: aSymbol "Layout specific. This property describes how the rows/columns in a list-like layout should be centered. #topLeft - center at start of secondary direction #bottomRight - center at end of secondary direction #center - center in the middle of secondary direction #justified - insert extra space inbetween rows/columns " self assureTableProperties wrapCentering: aSymbol. self layoutChanged.! ! !Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 23:10'! layoutBounds "Return the bounds for laying out children of the receiver" | inset box | inset := self layoutInset. box := self innerBounds. inset isZero ifTrue:[^box]. ^box insetBy: inset.! ! !Morph methodsFor: 'visual properties' stamp: 'nk 8/28/2003 15:56'! defaultBitmapFillForm ^ImageMorph defaultForm. ! ! !Morph methodsFor: 'copying' stamp: 'tk 2/3/2001 14:29'! veryDeepFixupWith: deepCopier "If some fields were weakly copied, fix new copy here." "super veryDeepFixupWith: deepCopier. Object has no fixups, so don't call it" "If my owner is being duplicated too, then store his duplicate. If I am owned outside the duplicated tree, then I am no longer owned!!" owner := deepCopier references at: owner ifAbsent: [nil]. ! ! !Morph methodsFor: 'event handling' stamp: 'tbn 3/12/2010 01:55'! handleWindowEvent: anEvent "Handle an event concerning our host window" anEvent wasHandled ifTrue:[^self]. "not interested" (self wantsWindowEvent: anEvent) ifFalse:[^self]. anEvent wasHandled: true. self windowEvent: anEvent. ! ! !Morph methodsFor: 'utilities' stamp: 'cb 6/25/2013 13:24'! embedInWindow | window worldToUse | worldToUse := self world. "I'm assuming we are already in a world" window := (SystemWindow labelled: self defaultLabel) model: nil. window bounds: ((self position - ((0@window labelHeight) + window borderWidth)) corner: self bottomRight + window borderWidth). window addMorph: self frame: (0@0 extent: 1@1). window updatePaneColors. worldToUse addMorph: window. window activate! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:24'! wantsDroppedMorph: aMorph event: evt "Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. Note that for a successful drop operation both parties need to agree. The symmetric check is done automatically via aMorph wantsToBeDroppedInto: self." ^self dropEnabled! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:06'! disableTableLayout: aBool "Layout specific. Disable laying out the receiver in table layout" self assureLayoutProperties disableTableLayout: aBool. self layoutChanged.! ! !Morph methodsFor: 'layout-properties' stamp: 'tk 10/30/2001 18:39'! vResizeToFit: aBoolean aBoolean ifTrue:[ self vResizing: #shrinkWrap. ] ifFalse:[ self vResizing: #rigid. ].! ! !Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:33'! mouseEnterDragging: evt "Handle a mouseEnterDragging event, meaning the mouse just entered my bounds with a button pressed or laden with submorphs. The default response is to let my eventHandler, if any, handle it, or else to do nothing." self eventHandler ifNotNil: [^ self eventHandler mouseEnterDragging: evt fromMorph: self]. ! ! !Morph methodsFor: 'rotate scale and flex' stamp: 'ar 11/24/1998 14:19'! keepsTransform "Return true if the receiver will keep it's transform while being grabbed by a hand." ^false! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:02'! wrapCentering "Layout specific. This property describes how the rows/columns in a list-like layout should be centered. #topLeft - center at start of secondary direction #bottomRight - center at end of secondary direction #center - center in the middle of secondary direction #justified - insert extra space inbetween rows/columns " | props | props := self layoutProperties. ^props ifNil:[#topLeft] ifNotNil:[props wrapCentering].! ! !Morph methodsFor: 'button' stamp: 'sw 2/6/2001 23:09'! doButtonAction "If the receiver has a button-action defined, do it now. The default button action of any morph is, well, to do nothing. Note that there are several ways -- too many ways -- for morphs to have button-like actions. This one refers not to the #mouseUpCodeToRun feature, nor does it refer to the Player-scripting mechanism. Instead it is intended for morph classes whose very nature is to be buttons -- this method provides glue so that arbitrary buttons on the UI can be 'fired' programatticaly from user scripts"! ! !Morph methodsFor: 'utilities' stamp: 'sw 10/23/1998 12:00'! addTransparentSpacerOfSize: aPoint self addMorphBack: (self transparentSpacerOfSize: aPoint)! ! !Morph methodsFor: 'menus' stamp: 'StephaneDucasse 4/22/2012 16:35'! stickinessString "Answer the string to be shown in a menu to represent the stickiness status" ^ (self isSticky) -> 'resist being picked up' translated! ! !Morph methodsFor: 'events-processing' stamp: 'ar 1/10/2001 21:35'! handleDropFiles: anEvent "Handle a drop from the OS." anEvent wasHandled ifTrue:[^self]. "not interested" (self wantsDropFiles: anEvent) ifFalse:[^self]. anEvent wasHandled: true. self dropFiles: anEvent. ! ! !Morph methodsFor: 'announcements' stamp: 'StephaneDucasse 8/22/2013 23:38'! onAnnouncement: anAnnouncement do: aValuable self announcer when: anAnnouncement do: aValuable.! ! !Morph methodsFor: 'event handling' stamp: 'sw 5/6/1998 12:54'! wouldAcceptKeyboardFocus "Answer whether a plain mouse click on the receiver should result in a text selection there" ^ false! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:40'! morphsAt: aPoint "Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself. The order is deepest embedding first." ^self morphsAt: aPoint unlocked: false! ! !Morph methodsFor: 'menus' stamp: 'sw 11/27/2001 07:17'! addCustomMenuItems: aCustomMenu hand: aHandMorph "Add morph-specific items to the given menu which was invoked by the given hand. This method provides is invoked both from the halo-menu and from the control-menu regimes." ! ! !Morph methodsFor: 'structure' stamp: 'marcus.denker 7/24/2009 14:07'! outermostWorldMorph ^World.! ! !Morph methodsFor: 'drop shadows' stamp: 'HenrikSperreJohansen 5/21/2010 13:34'! changeShadowColor "Change the shadow color of the receiver -- triggered, e.g. from a menu" (UIManager default chooseColor: self shadowColor) ifNotNil: [:nc | self shadowColor: nc]. ! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'! changeDisableTableLayout self disableTableLayout: self disableTableLayout not. self layoutChanged.! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! cellSpacingString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self cellSpacing! ! !Morph methodsFor: 'structure' stamp: 'ClementBera 7/30/2013 11:05'! world ^owner ifNotNil: [owner world]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/9/2009 17:44'! focusIndicatorCornerRadius "Answer the corner radius preferred for the focus indicator for the receiver for themes that support this." ^self theme focusIndicatorCornerRadiusFor: self ! ! !Morph methodsFor: 'thumbnail' stamp: 'dgd 9/12/2004 20:33'! iconOrThumbnail "Answer an appropiate form to represent the receiver" ^ self icon ifNil: [ | maxExtent fb |maxExtent := 320 @ 240. fb := self fullBounds. fb area <= (maxExtent x * maxExtent y) ifTrue: [self imageForm] ifFalse: [self imageFormForRectangle: (fb topLeft extent: maxExtent)] ] ! ! !Morph methodsFor: 'wiw support' stamp: 'RAA 6/29/2000 10:49'! addMorphInLayer: aMorph submorphs do: [ :each | each == aMorph ifTrue: [^self]. aMorph morphicLayerNumber < each morphicLayerNumber ifTrue: [ ^self addMorph: aMorph inFrontOf: each ]. ]. self addMorphBack: aMorph ! ! !Morph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 7/31/2013 14:14'! removeDependent: anObject self flag: #GSoC. "Flag added by Benjamin Van Ryseghem the July 22, 2013 to remember to remove this line in a while" [ super removeDependent: anObject ] on: Error do: []. self announcer unsubscribe: anObject! ! !Morph methodsFor: 'menus' stamp: 'ar 11/29/2001 19:57'! changeDirectionHandles ^self wantsDirectionHandles: self wantsDirectionHandles not! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'! listDirection "Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are: #leftToRight #rightToLeft #topToBottom #bottomToTop indicating the direction in which any layout should take place" | props | props := self layoutProperties. ^props ifNil:[#topToBottom] ifNotNil:[props listDirection].! ! !Morph methodsFor: 'events-processing' stamp: 'ar 10/5/2000 19:25'! rejectDropEvent: anEvent "This hook allows the receiver to repel a drop operation currently executed. The method is called prior to checking children so the receiver must validate that the event was really designated for it. Note that the ordering of the tests below is designed to avoid a (possibly expensive) #fullContainsPoint: test. If the receiver doesn't want to repel the morph anyways we don't need to check after all." (self repelsMorph: anEvent contents event: anEvent) ifFalse:[^self]. "not repelled" (self fullContainsPoint: anEvent position) ifFalse:[^self]. "not for me" "Throw it away" anEvent wasHandled: true. anEvent contents rejectDropMorphEvent: anEvent.! ! !Morph methodsFor: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:52'! hasNoLayoutString ^ (self layoutPolicy isNil) -> 'no layout' translated! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/27/2007 18:11'! lastSubmorphRecursive "Answer recursive last submorph of the receiver." ^self hasSubmorphs ifTrue: [self lastSubmorph lastSubmorphRecursive] ifFalse: [self]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 5/7/2010 21:44'! halo ^ self outermostWorldMorph ifNotNil: [:w | w haloMorphs detect: [:h | h target == self] ifNone: []]! ! !Morph methodsFor: 'structure' stamp: 'di 11/12/2000 16:18'! ownerThatIsA: aClass "Return the first enclosing morph that is a kind of aClass, or nil if none" ^ self firstOwnerSuchThat: [:m | m isKindOf: aClass]! ! !Morph methodsFor: 'accessing' stamp: 'sw 8/4/97 12:05'! lock self lock: true! ! !Morph methodsFor: 'halos and balloon help' stamp: 'md 2/27/2006 09:54'! setBalloonText: stringOrText maxLineLength: aLength "Set receiver's balloon help text. Pass nil to remove the help." (extension isNil and: [stringOrText isNil]) ifTrue: [^ self]. self assureExtension balloonText: (stringOrText ifNotNil: [stringOrText asString withNoLineLongerThan: aLength])! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 10/20/2011 18:09'! attachKeymapCategory: aCategoryName targetting: anObject self kmDispatcher attachCategory: aCategoryName targetting: anObject! ! !Morph methodsFor: 'miscellaneous' stamp: 'sw 7/20/2001 00:15'! setExtentFromHalo: anExtent "The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed" self extent: anExtent! ! !Morph methodsFor: 'drawing' stamp: 'ar 3/17/2001 15:56'! highlightForMouseDown: aBoolean aBoolean ifTrue:[self setProperty: #highlightedForMouseDown toValue: aBoolean] ifFalse:[self removeProperty: #highlightedForMouseDown. self resetExtension]. self changed! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 21:06'! initializeShortcuts: aKMDispatcher "Where we may attach keymaps or even on:do: local shortcuts if needed." aKMDispatcher attachCategory: #MorphFocusCtrlNavigation! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 19:22'! relativeTextAnchorPosition: aPoint ^self setProperty: #relativeTextAnchorPosition toValue: aPoint! ! !Morph methodsFor: 'accessing' stamp: 'MarcusDenker 9/7/2010 16:59'! balloonText "Answer balloon help text or nil, if no help is available. NB: subclasses may override such that they programatically construct the text, for economy's sake, such as model phrases in a Viewer" extension ifNil: [^nil]. ^extension balloonText ifNotNil: [:text | text asString withNoLineLongerThan: self theme settings maxBalloonHelpLineLength]! ! !Morph methodsFor: 'drawing' stamp: 'JW 7/12/2005 20:12'! shadowForm "Return a form representing the 'shadow' of the receiver - e.g., all pixels that are occupied by the receiver are one, all others are zero." | canvas | canvas := (Display defaultCanvasClass extent: self fullBounds extent depth: 1) asShadowDrawingCanvas: Color black. "Color black represents one for 1bpp" canvas translateBy: bounds topLeft negated during:[:tempCanvas| tempCanvas fullDrawMorph: self]. ^ canvas form offset: bounds topLeft ! ! !Morph methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/28/2012 00:59'! simulateKeyStrokes: aString aString do: [:c | self simulateKeyStroke: c ].! ! !Morph methodsFor: 'events-processing' stamp: 'BenjaminVanRyseghem 1/18/2012 18:58'! handleMouseMove: anEvent "System level event handling." anEvent wasHandled ifTrue:[^self]. "not interested" "Rules say that by default a morph gets #mouseMove iff * the hand is not dragging anything, + and some button is down, + and the receiver is the current mouse focus." (anEvent hand hasSubmorphs) ifTrue:[^self]. (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self]. anEvent wasHandled: true. self mouseMove: anEvent. (self handlesMouseStillDown: anEvent) ifTrue:[ "Step at the new location" self startStepping: #handleMouseStillDown: at: Time millisecondClockValue arguments: {anEvent copy resetHandlerFields} stepTime: self mouseStillDownStepRate ]. ^ self eventHandler ifNotNil: [:handler | handler mouseMove: anEvent fromMorph: self ] ! ! !Morph methodsFor: 'layout' stamp: 'StephaneDucasse 6/2/2013 14:18'! fullBounds "Return the bounding box of the receiver and all its children. Recompute the layout if necessary." fullBounds ifNotNil: [ ^ fullBounds ]. "Errors at this point can be critical so make sure we catch 'em all right" self computeFullBounds. "This should do it unless you don't screw up the bounds" ^ fullBounds! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 6/24/2012 23:27'! widthToDisplayInTree: aTree ^ self minExtent x! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:57'! assureTableProperties | props | props := self layoutProperties. props == self ifTrue:[props := nil]. props ifNil:[ props := TableLayoutProperties new initializeFrom: self. self layoutProperties: props]. props includesTableProperties ifFalse:[self layoutProperties: (props := props asTableLayoutProperties)]. ^props! ! !Morph methodsFor: 'geometry' stamp: 'ar 12/14/2000 13:48'! bounds: newBounds | oldExtent newExtent | oldExtent := self extent. newExtent := newBounds extent. (oldExtent dotProduct: oldExtent) <= (newExtent dotProduct: newExtent) ifTrue:[ "We're growing. First move then resize." self position: newBounds topLeft; extent: newExtent. ] ifFalse:[ "We're shrinking. First resize then move." self extent: newExtent; position: newBounds topLeft. ].! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:56'! cellSpacing: aSymbol "Layout specific. This property describes how the cell size for each element in a list should be computed. #globalRect - globally equal rectangular cells #globalSquare - globally equal square cells #localRect - locally (e.g., per row/column) equal rectangular cells #localSquare - locally (e.g., per row/column) equal square cells #none - cells are sized based on available row/column constraints " self assureTableProperties cellSpacing: aSymbol. self layoutChanged.! ! !Morph methodsFor: 'caching' stamp: 'md 4/3/2006 12:02'! releaseCachedState "Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'." self borderStyle releaseCachedState. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:29'! balloonFont ^ self valueOfProperty: #balloonFont ifAbsent: [self defaultBalloonFont]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/29/2008 16:06'! toggleVisible "Toggle the visibility of the receiver." self visible ifTrue: [self hide] ifFalse: [self show]! ! !Morph methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:28'! borderWidth ^self borderStyle width! ! !Morph methodsFor: 'events-processing' stamp: 'BenjaminVanRyseghem 1/18/2012 19:06'! handleMouseEnter: anEvent "System level event handling." (anEvent isDraggingEvent) ifTrue:[ (self handlesMouseOverDragging: anEvent) ifTrue:[ anEvent wasHandled: true. self mouseEnterDragging: anEvent]. ^ self eventHandler ifNotNil: [:handler | handler mouseEnterDragging: anEvent fromMorph: self ]]. self wantsBalloon ifTrue:[anEvent hand triggerBalloonFor: self after: self balloonHelpDelayTime]. (self handlesMouseOver: anEvent) ifTrue:[ anEvent wasHandled: true. self mouseEnter: anEvent ]. ^ self eventHandler ifNotNil: [:handler | handler mouseEnter: anEvent fromMorph: self ].! ! !Morph methodsFor: 'testing' stamp: 'nk 10/13/2003 18:36'! isLineMorph ^false! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 15:24'! wantsKeyboardFocusNavigation "Answer whether the receiver would like keyboard focus when navigated to by keyboard." ^self wantsKeyboardFocus! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:14'! bottom: aNumber " Move me so that my bottom is at the y-coordinate aNumber. My extent (width & height) are unchanged " self position: (bounds left @ (aNumber - self height))! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:09'! changeLayoutInset: evt | handle | handle := HandleMorph new forEachPointDo:[:newPoint | self layoutInset: (newPoint - evt cursorPoint) asIntegerPoint // 5]. evt hand attachMorph: handle. handle startStepping. ! ! !Morph methodsFor: 'drop shadows' stamp: 'RAA 1/19/2001 07:51'! addDropShadow self hasDropShadow ifTrue:[^self]. self changed. self hasDropShadow: true. self shadowOffset: 3@3. self layoutChanged. self changed.! ! !Morph methodsFor: 'accessing' stamp: 'ar 12/27/2001 17:56'! couldHaveRoundedCorners ^ true! ! !Morph methodsFor: 'stepping and presenter' stamp: 'ar 12/15/2000 00:00'! stopSteppingSelector: aSelector "Stop getting sent the given message." | w | w := self world. w ifNotNil: [w stopStepping: self selector: aSelector]. ! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:17'! bottom " Return the y-coordinate of my bottom side " ^ bounds bottom! ! !Morph methodsFor: 'event handling' stamp: 'nk 3/10/2004 19:47'! handlerForMouseDown: anEvent "Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event." anEvent blueButtonPressed ifTrue: [^ self handlerForBlueButtonDown: anEvent]. anEvent yellowButtonPressed ifTrue: [^ self handlerForYellowButtonDown: anEvent]. anEvent controlKeyPressed ifTrue: [^ self handlerForMetaMenu: anEvent]. (self handlesMouseDown: anEvent) ifFalse: [^ nil]. "not interested" anEvent handler ifNil: [^ self ]. "Same priority but I am innermost" "Nobody else was interested" ^self mouseDownPriority >= anEvent handler mouseDownPriority ifTrue: [ self] ifFalse: [ nil]! ! !Morph methodsFor: 'geometry' stamp: 'ar 9/22/2000 20:12'! referencePosition "Return the current reference position of the receiver" | box | box := self bounds. ^box origin + (self rotationCenter * box extent). ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:05'! mouseDownOnHelpHandle: anEvent "The mouse went down in the show-balloon handle" | str | anEvent shiftPressed ifTrue: [^ self editBalloonHelpText]. str := self balloonText. str ifNil: [str := self noHelpString]. self showBalloon: str hand: anEvent hand. ! ! !Morph methodsFor: 'geometry' stamp: 'bf 1/5/2000 19:08'! screenLocation "For compatibility only" ^ self fullBounds origin! ! !Morph methodsFor: 'testing' stamp: 'stephane.ducasse 11/14/2008 21:48'! renameTo: aName "Set The morph name." self topRendererOrSelf setNameTo: aName. ^aName! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:24'! separateDragAndDrop "Conversion only. Separate the old #dragNDropEnabled into #dragEnabled and #dropEnabled and remove the old property." | dnd | (self hasProperty: #dragNDropEnabled) ifFalse:[^self]. dnd := (self valueOfProperty: #dragNDropEnabled) == true. self dragEnabled: dnd. self dropEnabled: dnd. self removeProperty: #dragNDropEnabled. ! ! !Morph methodsFor: 'visual properties' stamp: 'nk 8/28/2003 15:57'! useBitmapFill "Make receiver use a solid fill style (e.g., a simple color)" | fill | self fillStyle isBitmapFill ifTrue:[^self]. "Already done" fill := BitmapFillStyle fromForm: self defaultBitmapFillForm. "Note: Must fix the origin due to global coordinates" fill origin: self bounds origin. self fillStyle: fill.! ! !Morph methodsFor: 'stepping and presenter' stamp: 'ar 1/31/2001 13:07'! startStepping "Start getting sent the 'step' message." self startStepping: #stepAt: at: Time millisecondClockValue arguments: nil stepTime: nil.! ! !Morph methodsFor: 'geometry' stamp: 'SeanDeNigris 5/4/2013 11:17'! fitInWorld self bounds: (self bounds translatedAndSquishedToBeWithin: self world bounds).! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/11/2007 15:04'! taskbarThumbnail "Answer a new taskbar thumbnail for the receiver." ^self taskThumbnailOfSize: self taskbarThumbnailExtent! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'RAA 12/15/2000 19:34'! addMorphCentered: aMorph aMorph position: bounds center - (aMorph extent // 2). self addMorphFront: aMorph. ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:20'! dragNDropEnabled "Note: This method is only useful for dragEnabled == dropEnabled at all times" self separateDragAndDrop. ^self dragEnabled and:[self dropEnabled]! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:02'! pointFromWorld: aPoint ^self point: aPoint from: self world! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:45'! addMorph: newMorph inFrontOf: aMorph "Add a morph to the list of submorphs in front of the specified morph" ^self privateAddMorph: newMorph atIndex: ((submorphs indexOf: aMorph) max: 1).! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'sw 7/3/1998 18:47'! submorphWithProperty: aSymbol ^ submorphs detect: [:aMorph | aMorph hasProperty: aSymbol] ifNone: [nil]! ! !Morph methodsFor: 'events-processing' stamp: 'BenjaminVanRyseghem 6/28/2012 12:58'! handleMouseDown: anEvent "System level event handling." anEvent wasHandled ifTrue:[^self]. "not interested" anEvent hand removePendingBalloonFor: self. anEvent wasHandled: true. (anEvent controlKeyPressed and: [self cmdGesturesEnabled and: [ anEvent shiftPressed]]) ifTrue: [ self invokeMetaMenu: anEvent. ^ self eventHandler ifNotNil: [:handler | handler mouseDown: anEvent fromMorph: self ].]. "Make me modal during mouse transitions" anEvent hand newMouseFocus: self event: anEvent. anEvent blueButtonChanged ifTrue:[^self blueButtonDown: anEvent]. self mouseDown: anEvent. anEvent hand removeHaloFromClick: anEvent on: self. (self handlesMouseStillDown: anEvent) ifTrue:[ self startStepping: #handleMouseStillDown: at: Time millisecondClockValue + self mouseStillDownThreshold arguments: {anEvent copy resetHandlerFields} stepTime: self mouseStillDownStepRate ].! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:18'! dropEnabled: aBool ^self enableDrop: aBool! ! !Morph methodsFor: 'accessing' stamp: 'IgorStasenko 12/22/2012 03:10'! visibleClearArea "Answer the receiver visible clear area. The intersection between the clear area and the viewbox." ^ self viewBox intersect: self clearArea ifNone: [ (0@0 corner: 0@0 ) ]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/27/2009 13:47'! preferredButtonCornerStyle "Answer the preferred button corner style for submorphs. Answer nil for no preference." ^nil! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/17/2006 10:36'! visible: aBoolean "set the 'visible' attribute of the receiver to aBoolean. Must update owner layout since its full bounds may depend on the receiver extending beyond its bounds." (extension isNil and:[aBoolean]) ifTrue: [^ self]. self visible == aBoolean ifTrue: [^ self]. self assureExtension visible: aBoolean. self changed. owner ifNotNil: [owner layoutChanged]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/23/2009 13:23'! handlesDropShadowInHand "Answer whether the receiver will handle drop shadow drawing when picked up in the hand." ^false! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/28/2008 17:21'! handleMouseWheel: anEvent "System level event handling." anEvent wasHandled ifTrue:[^self]. (self handlesMouseWheel: anEvent) ifTrue:[ anEvent wasHandled: true. self mouseWheel: anEvent]! ! !Morph methodsFor: 'meta-actions' stamp: 'sw 11/27/2001 14:59'! resizeFromMenu "Commence an interaction that will resize the receiver" self resizeMorph: ActiveEvent! ! !Morph methodsFor: 'drop shadows' stamp: 'marcus.denker 8/24/2008 22:50'! shadowOffset "Return the current shadow offset" extension ifNil: [^0@0]. ^self valueOfProperty: #shadowOffset ifAbsent:[0@0]! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 03:00'! wrapDirectionString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self wrapDirection ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'nk 10/16/2003 14:02'! removeAllMorphsIn: aCollection "greatly speeds up the removal of *lots* of submorphs" | set myWorld | set := IdentitySet new: aCollection size * 4 // 3. aCollection do: [:each | each owner == self ifTrue: [ set add: each]]. myWorld := self world. (fullBounds notNil or:[myWorld notNil]) ifTrue:[self invalidRect: self fullBounds]. set do: [:m | myWorld ifNotNil: [ m outOfWorld: myWorld ]. m privateOwner: nil]. submorphs := submorphs reject: [ :each | set includes: each]. set do: [ :m | self removedMorph: m ]. self layoutChanged. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/15/2000 16:16'! hasHalo ^self hasProperty: #hasHalo.! ! !Morph methodsFor: 'events-processing' stamp: 'ar 9/18/2000 19:14'! processEvent: anEvent using: defaultDispatcher "This is the central entry for dispatching events in morphic. Given some event and a default dispatch strategy, find the right receiver and let him handle it. WARNING: This is a powerful hook. If you want to use a different event dispatcher from the default, here is the place to hook it in. Depending on how the dispatcher is written (e.g., whether it calls simply #processEvent: or #processEvent:using:) you can change the dispatch strategy for entire trees of morphs. Similarly, you can disable entire trees of morphs from receiving any events whatsoever. Read the documentation in class MorphicEventDispatcher before playing with it. " (self rejectsEvent: anEvent) ifTrue:[^#rejected]. ^defaultDispatcher dispatchEvent: anEvent with: self! ! !Morph methodsFor: 'menu' stamp: 'dgd 9/18/2004 18:35'! wantsYellowButtonMenu: aBoolean "Change the receiver to wants or not a yellow button menu" self setProperty: #wantsYellowButtonMenu toValue: aBoolean! ! !Morph methodsFor: 'naming' stamp: 'yo 12/3/2004 17:02'! setNameTo: aName | nameToUse nameString | nameToUse := aName ifNotNil: [(nameString := aName asString) notEmpty ifTrue: [nameString] ifFalse: ['*']]. self setNamePropertyTo: nameToUse "no Texts here!!"! ! !Morph methodsFor: 'drawing' stamp: 'Henrik Sperre Johansen 3/15/2009 00:03'! areasRemainingToFill: aRectangle "Pushed up from BorderedMorph, all cases tested for there are supported by basic Morph." "Morphs which achieve translucency by other means than fillStyle will have to reimplement this" "Fixed here to test the fillStyle rather than color for translucency. Since can have a translucent fillStyle while the (calculated) color is not." self fillStyle isTranslucent ifTrue: [^ Array with: aRectangle]. self wantsRoundedCorners ifTrue: [(self borderWidth > 0 and: [self borderColor isColor and: [self borderColor isTranslucent]]) ifTrue: [^ aRectangle areasOutside: (self innerBounds intersect: self boundsWithinCorners)] ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]] ifFalse: [(self borderWidth > 0 and: [self borderColor isColor and: [self borderColor isTranslucent]]) ifTrue: [^ aRectangle areasOutside: self innerBounds] ifFalse: [^ aRectangle areasOutside: self bounds]]! ! !Morph methodsFor: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:52'! hasRubberBandCellsString ^ (self rubberBandCells) -> 'rubber band cells' translated! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/15/2001 16:33'! resistsRemoval "Answer whether the receiver is marked as resisting removal" ^ self hasProperty: #resistsRemoval! ! !Morph methodsFor: 'halos and balloon help' stamp: 'BenjaminVanRyseghem 5/4/2013 12:54'! addHalo: evt | halo prospectiveHaloClass | Smalltalk tools userManager canShowMorphHalo ifFalse: [ ^ self ]. prospectiveHaloClass := Smalltalk globals at: self haloClass ifAbsent: [ HaloMorph ]. halo := prospectiveHaloClass new. halo bounds: (halo worldBoundsForMorph: self). halo popUpFor: self event: evt. ^ halo! ! !Morph methodsFor: 'menu' stamp: 'AlainPlantec 11/5/2011 14:27'! buildYellowButtonMenu: aHand "build the morph menu for the yellow button" | menu | menu := UIManager default newMenuIn: self for: self. self addNestedYellowButtonItemsTo: menu event: ActiveEvent. ^ menu! ! !Morph methodsFor: 'initialize' stamp: 'RAA 10/18/2000 12:33'! openCenteredInWorld self fullBounds; position: Display extent - self extent // 2; openInWorld.! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 3/14/2011 00:03'! dispatchKeystrokeForEvent: evt self kmDispatcher dispatchKeystroke: evt ! ! !Morph methodsFor: 'rotate scale and flex' stamp: 'AlainPlantec 5/8/2010 00:13'! rotationCenter "Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." ^self valueOfProperty: #rotationCenter ifAbsent: [0.5@0.5] ! ! !Morph methodsFor: 'Morphic-Base-Worlds' stamp: 'dgd 9/27/2004 11:45'! viewBox ^ self pasteUpMorph viewBox! ! !Morph methodsFor: 'accessing' stamp: 'tk 1/31/2002 10:25'! insetColor owner ifNil:[^self color]. ^ self colorForInsets! ! !Morph methodsFor: '*SUnit-UITesting' stamp: 'SeanDeNigris 12/1/2011 22:08'! simulateClick self simulateClickWith: MouseEvent redButton.! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 16:15'! defaultBalloonColor ^ Display depth <= 2 ifTrue: [Color white] ifFalse: [BalloonMorph balloonColor]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 14:59'! focusColor "Answer the keyboard focus indication color." ^self borderStyle color contrastingColor! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/12/2009 18:14'! roundedCorners: anArray "Set the corners to round." anArray = #(1 2 3 4) ifTrue: [self removeProperty: #roundedCorners] ifFalse: [self setProperty: #roundedCorners toValue: anArray]. self changed! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:44'! highlight "The receiver is being asked to appear in a highlighted state. Mostly used for textual morphs" self color: self highlightColor! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/16/2007 11:26'! changed "Report that the area occupied by this morph should be redrawn. Fixed to include submorphs outside the outerBounds." ^fullBounds ifNil: [self invalidRect: self privateFullBounds] ifNotNil: [self invalidRect: fullBounds]! ! !Morph methodsFor: 'accessing' stamp: 'nk 4/14/2004 17:48'! borderWidth: aNumber | style | style := self borderStyle. style width = aNumber ifTrue: [ ^self ]. style style = #none ifTrue: [ self borderStyle: (SimpleBorder width: aNumber color: Color transparent) ] ifFalse: [ style width: aNumber. self changed ]. ! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:05'! boundsInWorld ^self bounds: self bounds in: self world! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'! cellInset "Layout specific. This property specifies an extra inset for each cell in the layout." | props | props := self layoutProperties. ^props ifNil:[0] ifNotNil:[props cellInset].! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! changeMinCellSize: evt | handle | handle := HandleMorph new forEachPointDo:[:newPoint | self minCellSize: (newPoint - evt cursorPoint) asIntegerPoint]. evt hand attachMorph: handle. handle startStepping. ! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:54'! minWidth "answer the receiver's minWidth" ^ self valueOfProperty: #minWidth ifAbsent: [2]! ! !Morph methodsFor: 'meta-actions' stamp: 'ar 10/12/2000 17:07'! handlerForMetaMenu: evt "Return the prospective handler for invoking the meta menu. By default, the top-most morph in the innermost world gets this menu" self isWorldMorph ifTrue:[^self]. evt handler ifNotNil:[evt handler isWorldMorph ifTrue:[^self]]. ^nil! ! !Morph methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:28'! borderColor ^self borderStyle color! ! !Morph methodsFor: 'menus' stamp: 'EstebanLorenzano 5/14/2013 09:44'! addExportMenuItems: aMenu hand: aHandMorph "Add export items to the menu" aMenu ifNotNil: [ | aSubMenu | aSubMenu := UIManager default newMenuIn: self for: self. aSubMenu add: 'BMP file' translated action: #exportAsBMP. aSubMenu add: 'GIF file' translated action: #exportAsGIF. aSubMenu add: 'JPEG file' translated action: #exportAsJPEG. aSubMenu add: 'PNG file' translated action: #exportAsPNG. aMenu add: 'export...' translated icon: Smalltalk ui icons smallExportIcon subMenu: aSubMenu. aMenu lastItem icon: Smalltalk ui icons smallExportIcon ]. ! ! !Morph methodsFor: 'announcements' stamp: 'GuillermoPolito 5/1/2012 17:01'! announcer ^self valueOfProperty: #announcer ifAbsentPut: [ Announcer new ]! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:01'! reverseTableCells "Layout specific. This property describes if the cells should be treated in reverse order of submorphs." | props | props := self layoutProperties. ^props ifNil:[false] ifNotNil:[props reverseTableCells].! ! !Morph methodsFor: 'geometry' stamp: ''! center ^ bounds center! ! !Morph methodsFor: 'accessing' stamp: 'sw 10/23/1998 12:01'! beTransparent self color: Color transparent! ! !Morph methodsFor: 'geometry' stamp: 'sw 10/25/1999 23:33'! referencePositionInWorld: aPoint | localPosition | localPosition := owner ifNil: [aPoint] ifNotNil: [(owner transformFrom: self world) globalPointToLocal: aPoint]. self referencePosition: localPosition ! ! !Morph methodsFor: 'menus' stamp: 'sw 2/3/2000 00:14'! adjustedCenter "Provides a hook for objects to provide a reference point other than the receiver's center,for the purpose of centering a submorph under special circumstances, such as BalloonMorph" ^ self center! ! !Morph methodsFor: 'drawing' stamp: 'sw 6/4/2000 22:02'! boundingBoxOfSubmorphs | aBox | aBox := bounds origin extent: self minimumExtent. "so won't end up with something empty" submorphs do: [:m | m visible ifTrue: [aBox := aBox quickMerge: m fullBounds]]. ^ aBox ! ! !Morph methodsFor: 'rounding' stamp: 'gvc 9/11/2009 17:28'! cornerStyle: aSymbol "This method makes it possible to set up desired corner style. aSymbol has to be one of: #square #rounded" aSymbol == self cornerStyle ifFalse:[ self assureExtension. extension cornerStyle: aSymbol. self changed]! ! !Morph methodsFor: 'drop shadows' stamp: 'StephaneDucasse 4/22/2012 16:51'! hasDropShadowString ^ (self hasDropShadow) -> 'show shadow' translated! ! !Morph methodsFor: 'visual properties' stamp: 'ar 6/18/1999 06:57'! useSolidFill "Make receiver use a solid fill style (e.g., a simple color)" self fillStyle isSolidFill ifTrue:[^self]. "Already done" self fillStyle: self fillStyle asColor. "Try minimizing changes"! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'! listSpacing "Layout specific. This property describes how the heights for different rows in a table layout should be handled. #equal - all rows have the same height #none - all rows may have different heights " | props | props := self layoutProperties. ^props ifNil:[#none] ifNotNil:[props listSpacing].! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:23'! defaultBalloonFont ^ BalloonMorph balloonFont! ! !Morph methodsFor: 'Morphic-Base-Worlds' stamp: 'sw 8/30/1998 09:47'! topPasteUp "If the receiver is in a world, return that; otherwise return the outermost pasteup morph" ^ self outermostMorphThat: [:m | m isKindOf: PasteUpMorph]! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! topCenter ^ bounds topCenter! ! !Morph methodsFor: 'menu' stamp: 'nk 3/10/2004 19:49'! addMyYellowButtonMenuItemsToSubmorphMenus "Answer true if I have items to add to the context menus of my submorphs" ^true! ! !Morph methodsFor: 'meta-actions' stamp: 'wiz 7/17/2004 22:17'! potentialTargets "Return the potential targets for the receiver. This is derived from Morph>>potentialEmbeddingTargets." owner ifNil:[^#()]. ^owner morphsAt: self referencePosition behind: self unlocked: true not! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'alain.plantec 6/8/2009 23:41'! allMorphsInto: aSet "Return a set of all submorphs. Don't forget the hidden ones. Consider only objects that are in memory (see allNonSubmorphMorphs)." submorphs do: [:m | m allMorphsInto: aSet]. self allNonSubmorphMorphs do: [:m | (aSet includes: m) ifFalse: ["Stop infinite recursion" m allMorphsInto: aSet]]. aSet add: self. ^ aSet! ! !Morph methodsFor: 'accessing' stamp: 'tk 2/15/2001 15:55'! color ^ color "has already been set to ((self valueOfProperty: #fillStyle) asColor)"! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:06'! fullBoundsInWorld ^self bounds: self fullBounds in: self world! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'AlainPlantec 12/1/2010 09:39'! dismissViaHalo "The user has clicked in the delete halo-handle. This provides a hook in case some concomitant action should be taken, or if the particular morph is not one which should be put in the trash can, for example." self setProperty: #lastPosition toValue: self positionInWorld. self dismissMorph! ! !Morph methodsFor: 'menus' stamp: 'StephaneDucasse 4/22/2012 16:51'! hasDragAndDropEnabledString "Answer a string to characterize the drag & drop status of the receiver" ^ (self dragNDropEnabled) -> 'accept drops' translated! ! !Morph methodsFor: 'accessing' stamp: 'gvc 1/11/2007 12:21'! enabled "Answer whether the receiver is enabled." ^true! ! !Morph methodsFor: 'geometry' stamp: 'jm 8/3/97 15:50'! bounds "Return the bounds of this morph." "Note: It is best not to override this method because many methods in Morph and its subclasses use the instance variable directly rather than 'self bounds'. Instead, subclasses should be sure that the bounds instance variable is correct." ^ bounds ! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/22/2000 18:03'! transformedBy: aTransform aTransform isIdentity ifTrue:[^self]. aTransform isPureTranslation ifTrue:[ ^self position: (aTransform localPointToGlobal: self position). ]. ^self addFlexShell transformedBy: aTransform! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 12:30'! taskbarTask "Answer a new taskbar task for the receiver. Answer nil if not required." ^nil! ! !Morph methodsFor: 'event handling' stamp: 'ar 9/14/2000 18:23'! keyDown: anEvent "Handle a key down event. The default response is to do nothing."! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'FernandoOlivero 4/12/2011 09:55'! showBalloon: msgString hand: aHand "Pop up a balloon containing the given string, first removing any existing BalloonMorphs in the world." |w h| (w := self world) ifNil: [^self]. h := aHand ifNil: [w activeHand]. ( self theme builder newBalloonHelp: msgString for: self balloonHelpAligner) popUpFor: self hand: h! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'BenjaminVanRyseghem 11/12/2013 16:14'! removeKeyCombination: aShortcut self kmDispatcher removeKeyCombination: aShortcut! ! !Morph methodsFor: 'event handling' stamp: 'nk 2/14/2004 18:42'! handlesMouseDown: evt "Do I want to receive mouseDown events (mouseDown:, mouseMove:, mouseUp:)?" "NOTE: The default response is false, except if you have added sensitivity to mouseDown events using the on:send:to: mechanism. Subclasses that implement these messages directly should override this one to return true." self eventHandler ifNotNil: [^ self eventHandler handlesMouseDown: evt]. ^ false! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 2/7/2000 11:27'! balloonHelpAligner "Answer the morph to which the receiver's balloon help should point" ^ (self valueOfProperty: #balloonTarget) ifNil: [self]! ! !Morph methodsFor: 'events-processing' stamp: 'GuillermoPolito 4/22/2012 17:19'! handleKeyUp: anEvent "System level event handling." anEvent wasHandled ifTrue:[^self]. (self handlesKeyUp: anEvent) ifFalse:[^self]. anEvent wasHandled: true. ^self keyUp: anEvent! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! changeMaxCellSize: evt | handle | handle := HandleMorph new forEachPointDo:[:newPoint | self maxCellSize: (newPoint - evt cursorPoint) asIntegerPoint]. evt hand attachMorph: handle. handle startStepping. ! ! !Morph methodsFor: 'other events' stamp: 'sw 8/1/2001 14:09'! menuButtonMouseLeave: event "The mouse left a menu-button area; restore standard cursor" event hand showTemporaryCursor: nil! ! !Morph methodsFor: 'announcements' stamp: 'ThierryGoubier 1/8/2014 14:40'! doAnnounce: anAnnouncement "Take care of not creating the announcer when announcing. If the announcer doesn't exist then this means nobody has expressed an interest in the message." "Do not override announce: for now, there is a need to refactor the announcements code in at least SystemWindow and ExpanderMorph." (self valueOfProperty: #announcer ifAbsent: [ ^ self ]) announce: anAnnouncement! ! !Morph methodsFor: 'classification' stamp: 'di 5/7/1998 01:21'! isAlignmentMorph ^ false! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/29/2008 16:18'! toggleVisibleAndRaise "Toggle the visibility of the receiver, brining to the front if becoming visible." self visible ifTrue: [self hide] ifFalse: [self comeToFront; show]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 4/8/98 13:26'! wantsHaloFor: aSubMorph ^ false! ! !Morph methodsFor: 'initialize' stamp: 'sw 3/21/2000 14:46'! openInHand "Attach the receiver to the current hand in the current morphic world" self currentHand attachMorph: self! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'ar 8/13/2003 11:32'! noteNewOwner: aMorph "I have just been added as a submorph of aMorph"! ! !Morph methodsFor: 'stepping and presenter' stamp: 'sw 7/19/1998 11:51'! startSteppingIn: aWorld "Start getting sent the 'step' message in aWorld" self step. "one to get started!!" aWorld ifNotNil: [aWorld startStepping: self]. self changed! ! !Morph methodsFor: 'event handling' stamp: 'CamilloBruni 2/4/2012 14:43'! yellowButtonActivity: shiftState "Find me or my outermost owner that has items to add to a yellow button menu. shiftState is true if the shift was pressed. Otherwise, build a menu that contains the contributions from myself and my interested submorphs, and present it to the user." | menu | self isWorldMorph ifFalse: [| outerOwner | outerOwner := self outermostOwnerWithYellowButtonMenu. outerOwner ifNil: [^ false]. outerOwner == self ifFalse: [^ outerOwner yellowButtonActivity: shiftState]]. menu := self buildYellowButtonMenu: ActiveHand. menu addTitle: self externalName icon: (self iconOrThumbnailOfSize: 28). menu popUpInWorld: self currentWorld. ^ true! ! !Morph methodsFor: 'testing' stamp: 'dgd 8/31/2004 15:00'! isDockingBar "Return true if the receiver is a docking bar" ^ false! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ClementBera 7/30/2013 11:04'! removeHalo "remove the surrounding halo (if any)" self halo ifNotNil: [self primaryHand removeHalo]! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'! changeProportionalLayout | layout | ((layout := self layoutPolicy) notNil and:[layout isProportionalLayout]) ifTrue:[^self]. "already proportional layout" self layoutPolicy: ProportionalLayout new. self layoutChanged.! ! !Morph methodsFor: 'halos and balloon help' stamp: 'em 3/24/2005 10:05'! noHelpString ^ 'Help not yet supplied' translated! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'GaryChambers 6/10/2011 12:00'! isWindowActive: aSystemWindow "Answer whether the given window is active. Implement in morphs that are designed to embed system windows. Delegate to owner." ^self owner ifNil: [true] ifNotNil: [:o | o isWindowActive: aSystemWindow]! ! !Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:43'! isSteppingSelector: aSelector "Return true if the receiver is currently stepping in its world" | aWorld | ^ (aWorld := self world) ifNil: [false] ifNotNil: [aWorld isStepping: self selector: aSelector]! ! !Morph methodsFor: 'meta-actions' stamp: 'MarcusDenker 3/27/2011 17:12'! maybeDuplicateMorph "Maybe duplicate the morph" ^self duplicate openInHand! ! !Morph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 14:36'! transformFrom: uberMorph "Return a transform to be used to map coordinates in a morph above me into my childrens coordinates, or vice-versa. This is used to support scrolling, scaling, and/or rotation. This default implementation just returns my owner's transform or the identity transform if my owner is nil. Note: This method cannot be used to map into the receiver's coordinate system!!" (self == uberMorph or: [owner isNil]) ifTrue: [^IdentityTransform new]. ^owner transformFrom: uberMorph! ! !Morph methodsFor: 'structure' stamp: 'ar 9/14/2000 16:47'! allOwnersDo: aBlock "Evaluate aBlock with all owners of the receiver" owner ifNotNil:[^owner withAllOwnersDo: aBlock].! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'ThierryGoubier 9/14/2012 22:21'! kmDispatcher "When creating the KMDispatcher instance, load default shortcuts." ^ self valueOfProperty: #kmDispatcher ifAbsentPut: [ | kmd | kmd := KMDispatcher target: self. self initializeShortcuts: kmd. kmd ]! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:16'! left " Return the x-coordinate of my left side " ^ bounds left! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:58'! listCentering "Layout specific. This property describes how the rows/columns in a list-like layout should be centered. #topLeft - center at start of primary direction #bottomRight - center at end of primary direction #center - center in the middle of primary direction #justified - insert extra space inbetween rows/columns " | props | props := self layoutProperties. ^props ifNil:[#topLeft] ifNotNil:[props listCentering].! ! !Morph methodsFor: 'drawing' stamp: 'MarcusDenker 10/21/2013 14:22'! show "Make sure this morph is on-stage." self visible ifTrue: [ ^ self ]. self visible: true. self changed! ! !Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:35'! initializeExtension "private - initializes the receiver's extension" extension := MorphExtension new! ! !Morph methodsFor: 'menus' stamp: 'sw 8/30/1998 09:42'! snapToEdgeIfAppropriate | edgeSymbol oldBounds aWorld | (edgeSymbol := self valueOfProperty: #edgeToAdhereTo) ifNotNil: [oldBounds := bounds. self adhereToEdge: edgeSymbol. bounds ~= oldBounds ifTrue: [(aWorld := self world) ifNotNil: [aWorld viewBox ifNotNil: [aWorld displayWorld]]]]! ! !Morph methodsFor: 'announcements' stamp: 'ThierryGoubier 1/8/2014 14:36'! announceKeyboardFocusChange: gotFocus | announcement | announcement := gotFocus ifTrue: [ MorphGotFocus morph: self ] ifFalse: [ MorphLostFocus morph: self ]. self doAnnounce: announcement. Morph announcer announce: announcement.! ! !Morph methodsFor: 'drawing' stamp: 'gvc 9/11/2009 17:59'! clipSubmorphs: aBool "Drawing specific. If this property is set, clip the receiver's submorphs to the receiver's clipping bounds." self invalidRect: self fullBounds. aBool == self clipSubmorphs ifFalse:[ self assureExtension. extension clipSubmorphs: aBool. self invalidRect: self fullBounds]! ! !Morph methodsFor: 'drawing' stamp: 'jm 6/11/97 17:21'! imageForm ^ self imageFormForRectangle: self fullBounds ! ! !Morph methodsFor: 'menus' stamp: 'CamilleTeruel 12/6/2013 14:38'! setArrowheads "Let the user edit the size of arrowheads for this object" | aParameter result | aParameter := self renderedMorph valueOfProperty: #arrowSpec ifAbsent: [PolygonMorph defaultArrowSpec]. result := Morph obtainArrowheadFor: 'Head size for arrowheads: ' translated defaultValue: aParameter asString. result ifNotNil: [self renderedMorph setProperty: #arrowSpec toValue: result] ifNil: [ self inform: 'Invalid input']! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 2/6/2001 22:12'! justGrabbedFrom: formerOwner "The receiver was just grabbed from its former owner and is now attached to the hand. By default, we pass this message on if we're a renderer." (self isRenderer and:[self hasSubmorphs]) ifTrue:[self firstSubmorph justGrabbedFrom: formerOwner].! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'! wrapDirection "Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are: #leftToRight #rightToLeft #topToBottom #bottomToTop #none indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa." | props | props := self layoutProperties. ^props ifNil:[#none] ifNotNil:[props wrapDirection].! ! !Morph methodsFor: 'debug and other' stamp: 'RAA 5/24/2000 18:20'! resumeAfterStepError "Resume stepping after an error has occured." self startStepping. "Will #step" self removeProperty:#errorOnStep. "Will remove prop only if #step was okay" ! ! !Morph methodsFor: 'menus' stamp: 'GuillermoPolito 5/29/2011 14:48'! addMiscExtrasTo: aMenu "Add a submenu of miscellaneous extra items to the menu." | subMenu | subMenu := UIManager default newMenuIn: self for: self. (self isWorldMorph not and: [(self renderedMorph isSystemWindow) not]) ifTrue: [subMenu add: 'put in a window' translated action: #embedInWindow]. self isWorldMorph ifFalse: [subMenu add: 'adhere to edge...' translated action: #adhereToEdge. subMenu addLine]. subMenu add: 'add mouse up action' translated action: #addMouseUpAction; add: 'remove mouse up action' translated action: #removeMouseUpAction. subMenu addLine. aMenu add: 'extras...' translated subMenu: subMenu! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 9/18/2000 18:34'! wantsToBeDroppedInto: aMorph "Return true if it's okay to drop the receiver into aMorph. This check is symmetric to #wantsDroppedMorph:event: to give both parties a chance of figuring out whether they like each other." ^true! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/25/2008 22:42'! focusChanged "Report that the area occupied by the morph's focus indicator should be redrawn. Optimized for border-only (no fill)." |rects fm| fm := self focusIndicatorMorph. fm fillStyle isTransparent ifTrue: [fm borderWidth > 0 ifTrue: [ rects := fm bounds areasOutside: (fm bounds insetBy: fm borderWidth). rects do: [:r | self invalidRect: r]]] ifFalse: [self invalidRect: fm bounds]! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:21'! layoutProperties: newProperties "Return the current layout properties associated with the receiver" self layoutProperties == newProperties ifTrue:[^self]. self assureExtension layoutProperties: newProperties. ! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:12'! topRight: aPoint " Move me so that my top right corner is at aPoint. My extent (width & height) are unchanged " self position: ((aPoint x - bounds width) @ (aPoint y)) ! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/26/2001 16:18'! borderStyleForSymbol: aStyleSymbol "Answer a suitable BorderStyle for me of the type represented by a given symbol" | aStyle existing | aStyle := BorderStyle borderStyleForSymbol: aStyleSymbol asSymbol. aStyle ifNil: [self error: 'bad style']. existing := self borderStyle. aStyle width: existing width; baseColor: existing baseColor. ^ (self canDrawBorder: aStyle) ifTrue: [aStyle] ifFalse: [nil]! ! !Morph methodsFor: '*Deprecated30' stamp: 'StephaneDucasse 10/13/2013 21:56'! hasTranslucentColor "Answer true if this any of this morph is translucent but not transparent." self deprecated: 'Use isTranslucentButNotTransparent' on: '14/10/2013' in: #Pharo30. ^ self isTranslucentButNotTransparent! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 12/1/2010 09:35'! rejectDropMorphEvent: evt "The receiver has been rejected, and must be put back somewhere. There are three cases: (1) It remembers its former owner and position, and goes right back there (2) It remembers its former position only, in which case it was torn off from a parts bin, and the UI is that it floats back to its donor position and then vanishes." self formerOwner notNil ifTrue: [^ self slideBackToFormerSituation: evt]. self formerPosition "Position but no owner -- can just make it vanish" ifNotNil: [^ self vanishAfterSlidingTo: self formerPosition event: evt].! ! !Morph methodsFor: 'structure' stamp: 'wiz 12/7/2006 15:12'! renderedMorph "This now gets overridden by rendering morphs." ^self! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 18:36'! textAnchorType ^self valueOfProperty: #textAnchorType ifAbsent:[#document]! ! !Morph methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:52'! color: aColor "Set the receiver's color. Directly set the color if appropriate, else go by way of fillStyle" (aColor isColor or: [aColor isKindOf: InfiniteForm]) ifFalse:[^ self fillStyle: aColor]. color = aColor ifFalse: [self assureExtension. extension fillStyle: nil. color := aColor. self changed]! ! !Morph methodsFor: 'drawing' stamp: 'ar 9/1/2000 14:23'! imageForm: depth forRectangle: rect | canvas | canvas := Display defaultCanvasClass extent: rect extent depth: depth. canvas translateBy: rect topLeft negated during:[:tempCanvas| tempCanvas fullDrawMorph: self]. ^ canvas form offset: rect topLeft! ! !Morph methodsFor: 'meta-actions' stamp: 'MarcusDenker 11/28/2009 14:34'! invokeMetaMenuAt: aPoint event: evt | morphs target | morphs := self morphsAt: aPoint. (morphs includes: self) ifFalse: [morphs := morphs copyWith: self]. morphs size = 1 ifTrue: [morphs anyOne invokeMetaMenu: evt] ifFalse: [target := UIManager default chooseFrom: (morphs collect: [:t | t class name asString]) values: morphs. target ifNil: [^ self]. target invokeMetaMenu: evt]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'GaryChambers 12/2/2011 12:00'! theme: aUITheme "Set the current theme for the receiver." self theme = aUITheme ifFalse: [ self basicTheme: aUITheme. self themeChanged]! ! !Morph methodsFor: 'menus' stamp: 'sw 2/21/2000 15:21'! collapse CollapsedMorph new beReplacementFor: self! ! !Morph methodsFor: 'drawing' stamp: 'dgd 2/16/2003 20:02'! clipLayoutCells "Drawing/layout specific. If this property is set, clip the submorphs of the receiver by its cell bounds." ^ self valueOfProperty: #clipLayoutCells ifAbsent: [false]! ! !Morph methodsFor: 'meta-actions' stamp: 'MarcusDenker 11/28/2009 14:34'! inspectAt: aPoint event: evt | morphs target | morphs := self morphsAt: aPoint. (morphs includes: self) ifFalse:[morphs := morphs copyWith: self]. target := UIManager default chooseFrom: (morphs collect: [:t |t class name asString]) values: morphs title: ('inspect whom? (deepest at top)' translated). target ifNil:[^self]. target inspectInMorphic: evt! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:22'! width: aNumber " Set my width; my position (top-left corner) and height will remain the same " self extent: aNumber asInteger@self height. ! ! !Morph methodsFor: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:50'! hasDisableTableLayoutString ^ (self disableTableLayout) -> 'disable layout in tables' translated! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/28/2008 16:17'! rejectsEvent: anEvent "Return true to reject the given event. Rejecting an event means neither the receiver nor any of it's submorphs will be given any chance to handle it. If the event is a mouse wheel event then only reject if the receiver is not visible." (anEvent isMouse and: [anEvent isMouseWheel]) ifTrue: [^self visible not]. ^self isLocked or: [self visible not]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:27'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^ false! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'GuillermoPolito 9/1/2010 18:41'! formerPosition: formerPosition formerPosition ifNil: [self removeProperty: #formerPosition] ifNotNil: [self setProperty: #formerPosition toValue: formerPosition]! ! !Morph methodsFor: 'classification' stamp: ''! isWorldOrHandMorph ^ self isWorldMorph or: [self isHandMorph]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'StephaneDucasse 11/1/2009 19:24'! privateMoveBy: delta "Private!! Use 'position:' instead." | fill border| bounds := bounds translateBy: delta. fullBounds ifNotNil: [fullBounds := fullBounds translateBy: delta]. fill := self fillStyle. fill isOrientedFill ifTrue: [fill origin: fill origin + delta]. border := self borderStyle. (border hasFillStyle and: [border fillStyle isOrientedFill]) ifTrue: [ border fillStyle origin: border fillStyle origin + delta]! ! !Morph methodsFor: 'events-processing' stamp: 'StephaneDucasse 7/18/2010 16:22'! mouseDownPriority "Return the default mouse down priority for the receiver" ^ 0 ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:06'! previousMorphInWindow "Answer the next morph in the window. Traverse from the receiver to its previous sibling's last submorph (recursive) or owner's previous sibling's last submorph (recursive) etc." ^self submorphBefore notNil ifTrue: [self submorphBefore lastSubmorphRecursive] ifFalse: [self owner]! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:08'! bottomLeft: aPoint " Move me so that my bottom left corner is at aPoint. My extent (width & height) are unchanged " self position: ((aPoint x) @ (aPoint y - self height)). ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'RAA 7/21/2000 11:10'! boundsForBalloon "some morphs have bounds that are way too big" ^self boundsInWorld! ! !Morph methodsFor: 'naming' stamp: 'gm 2/22/2003 13:16'! name: aName (aName isString) ifTrue: [self setNameTo: aName]! ! !Morph methodsFor: 'event handling' stamp: 'sw 4/2/98 14:16'! hasFocus ^ false! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 14:54'! balloonColor ^ self valueOfProperty: #balloonColor ifAbsent: [self defaultBalloonColor]! ! !Morph methodsFor: 'geometry' stamp: 'ClementBera 7/30/2013 11:03'! goHome | box fb | owner ifNil: [^ self]. self visible ifFalse: [^ self]. box := owner visibleClearArea. fb := self fullBounds. fb left < box left ifTrue: [self left: box left - fb left + self left]. fb right > box right ifTrue: [self right: box right - fb right + self right]. fb top < box top ifTrue: [self top: box top - fb top + self top]. fb bottom > box bottom ifTrue: [self bottom: box bottom - fb bottom + self bottom]. ! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! listDirection: aSymbol "Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are: #leftToRight #rightToLeft #topToBottom #bottomToTop indicating the direction in which any layout should take place" self assureTableProperties listDirection: aSymbol. self layoutChanged.! ! !Morph methodsFor: 'event handling' stamp: 'tbn 3/12/2010 01:55'! windowEvent: anEvent "Host window event"! ! !Morph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:28'! wantsDropFiles: anEvent "Return true if the receiver wants files dropped from the OS." ^false! ! !Morph methodsFor: 'thumbnail' stamp: 'dgd 9/13/2004 12:43'! iconOrThumbnailOfSize: aNumberOrPoint "Answer an appropiate form to represent the receiver" ^ self iconOrThumbnail scaledIntoFormOfSize: aNumberOrPoint ! ! !Morph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 11/7/2012 19:16'! testAthensRender | surf | surf := AthensCairoSurface extent: Display extent. surf drawDuring: [:can | " can pathTransform scaleBy: 0.5; rotateByDegrees: 30." self fullDrawOnAthensCanvas: can ]. Display getCanvas drawImage: surf asForm at: 0@0 ! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:07'! localPointToGlobal: aPoint ^self point: aPoint in: nil! ! !Morph methodsFor: 'copying' stamp: 'AlainPlantec 12/1/2010 09:35'! prepareToBeSaved "Prepare this morph to be saved to disk. Subclasses should nil out any instance variables that holds state that should not be saved, such as cached Forms. Note that this operation may take more drastic measures than releaseCachedState; for example, it might discard the transcript of an interactive chat session." self releaseCachedState. self formerOwner: nil. self formerPosition: nil. fullBounds := nil! ! !Morph methodsFor: 'private' stamp: 'AlainPlantec 10/3/2011 01:21'! privateAddAllMorphs: aCollection atIndex: index "Private. Add aCollection of morphs to the receiver" | myWorld otherSubmorphs | myWorld := self world. otherSubmorphs := submorphs copyWithoutAll: aCollection. (index between: 0 and: otherSubmorphs size) ifFalse: [^ self error: 'index out of range']. index = 0 ifTrue:[ submorphs := aCollection asArray, otherSubmorphs] ifFalse:[ index = otherSubmorphs size ifTrue:[ submorphs := otherSubmorphs, aCollection] ifFalse:[ submorphs := otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. aCollection do: [:m | | itsOwner itsWorld | itsOwner := m owner. itsOwner ifNotNil: [ itsWorld := m world. (itsWorld == myWorld) ifFalse: [ itsWorld ifNotNil: [self privateInvalidateMorph: m]. m outOfWorld: itsWorld]. (itsOwner ~~ self) ifTrue: [ m owner privateRemove: m. m owner removedMorph: m ]]. m privateOwner: self. myWorld ifNotNil: [self privateInvalidateMorph: m]. (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. itsOwner == self ifFalse: [ self addedMorph: m. m noteNewOwner: self ]. ]. self layoutChanged. ! ! !Morph methodsFor: 'drop shadows' stamp: 'RAA 11/7/2000 15:54'! hasRolloverBorder: aBool aBool ifTrue:[self setProperty: #hasRolloverBorder toValue: true] ifFalse:[self removeProperty: #hasRolloverBorder]! ! !Morph methodsFor: 'meta-actions' stamp: 'GuillermoPolito 5/29/2011 14:48'! addEmbeddingMenuItemsTo: aMenu hand: aHandMorph "Construct a menu offerring embed targets for the receiver. If the incoming menu is is not degenerate, add the constructed menu as a submenu; in any case, answer the embed-target menu" | menu potentialEmbeddingTargets | potentialEmbeddingTargets := self potentialEmbeddingTargets. potentialEmbeddingTargets size > 1 ifFalse:[^ self]. menu := UIManager default newMenuIn: self for: self. potentialEmbeddingTargets reverseDo: [:m | menu add: (m class name asString) target: m selector: #addMorphFrontFromWorldPosition: argument: self topRendererOrSelf. menu lastItem icon: (m iconOrThumbnailOfSize: 16). self owner == m ifTrue:[menu lastItem emphasis: 1]. ]. aMenu add:'embed into' translated subMenu: menu. ^ menu! ! !Morph methodsFor: 'geometry' stamp: 'sw 6/11/1999 18:48'! center: aPoint self position: (aPoint - (self extent // 2))! ! !Morph methodsFor: 'change reporting' stamp: 'IgorStasenko 12/22/2012 03:13'! invalidRect: aRectangle from: aMorph | damageRect | aRectangle hasPositiveExtent ifFalse: [ ^self ]. damageRect := aRectangle. aMorph == self ifFalse:[ "Clip to receiver's clipping bounds if the damage came from a child" self clipSubmorphs ifTrue:[damageRect := aRectangle intersect: self clippingBounds ifNone: [ ^ self ]]]. owner ifNotNil: [owner invalidRect: damageRect from: self].! ! !Morph methodsFor: 'accessing' stamp: 'usmanbhatti 3/6/2012 19:23'! halosEnabled ^ self class halosEnabled! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'michael.rueger 3/9/2009 18:48'! goBehind owner addMorphBack: self. ! ! !Morph methodsFor: 'debug and other' stamp: 'sw 2/6/2001 22:35'! mouseUpCodeOrNil "If the receiver has a mouseUpCodeToRun, return it, else return nil" ^ self valueOfProperty: #mouseUpCodeToRun ifAbsent: [nil]! ! !Morph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:02'! mouseStillDownThreshold "Return the number of milliseconds after which mouseStillDown: should be sent" ^200! ! !Morph methodsFor: 'meta-actions' stamp: 'mir 3/17/2006 18:01'! dismissMorph: evt self dismissMorph! ! !Morph methodsFor: 'geometry' stamp: 'tk 9/8/97 10:44'! bottomLeft ^ bounds bottomLeft! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:15'! left: aNumber " Move me so that my left side is at the x-coordinate aNumber. My extent (width & height) are unchanged " self position: (aNumber @ bounds top)! ! !Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 18:58'! setShadowOffset: evt | handle | handle := HandleMorph new forEachPointDo: [:newPoint | self shadowPoint: newPoint]. evt hand attachMorph: handle. handle startStepping. ! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! rightCenter ^ bounds rightCenter! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'dgd 9/1/2004 16:26'! deleteDockingBars "Delete the receiver's docking bars" self dockingBars do: [:each | each delete]! ! !Morph methodsFor: 'wiw support' stamp: 'RAA 7/19/2000 20:44'! morphicLayerNumber "helpful for insuring some morphs always appear in front of or behind others. smaller numbers are in front" ^(owner isNil or: [owner isWorldMorph]) ifTrue: [ self valueOfProperty: #morphicLayerNumber ifAbsent: [100] ] ifFalse: [ owner morphicLayerNumber ]. "leave lots of room for special things"! ! !Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 19:06'! topRendererOrSelf "Answer the topmost renderer for this morph, or this morph itself if it has no renderer. See the comment in Morph>isRenderer." | top topsOwner | owner ifNil: [^self]. self isWorldMorph ifTrue: [^self]. "ignore scaling of this world" top := self. topsOwner := top owner. [topsOwner notNil and: [topsOwner isRenderer]] whileTrue: [top := topsOwner. topsOwner := top owner]. ^top! ! !Morph methodsFor: 'event handling' stamp: 'GuillermoPolito 3/15/2013 16:17'! keyStroke: anEvent "Handle a keystroke event. The default response is to let my eventHandler, if any, handle it." ^false! ! !Morph methodsFor: 'geometry' stamp: 'di 9/30/1998 12:11'! positionInWorld ^ self pointInWorld: self position. ! ! !Morph methodsFor: 'deferred message' stamp: 'AlainPlantec 7/9/2013 11:26'! defer: aValuable self owner ifNotNil: [:o | o defer: aValuable] ifNil: [ UIManager default defer: aValuable ]! ! !Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:31'! hasExtension "answer whether the receiver has extention" ^ extension notNil! ! !Morph methodsFor: 'event handling' stamp: 'ar 10/22/2000 17:08'! mouseStillDown: evt "Handle a mouse move event. The default response is to let my eventHandler, if any, handle it." self eventHandler ifNotNil: [self eventHandler mouseStillDown: evt fromMorph: self]. ! ! !Morph methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:51'! highlightColor: aColor self setProperty: #highlightColor toValue: aColor! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:55'! cellSpacing "Layout specific. This property describes how the cell size for each element in a list should be computed. #globalRect - globally equal rectangular cells #globalSquare - globally equal square cells #localRect - locally (e.g., per row/column) equal rectangular cells #localSquare - locally (e.g., per row/column) equal square cells #none - cells are sized based on available row/column constraints " | props | props := self layoutProperties. ^props ifNil:[#none] ifNotNil:[props cellSpacing].! ! !Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 17:58'! containsPoint: aPoint event: anEvent "Return true if aPoint is considered to be inside the receiver for the given event. The default implementation treats locked children as integral part of their owners." (self fullBounds containsPoint: aPoint) ifFalse:[^false]. (self containsPoint: aPoint) ifTrue:[^true]. self submorphsDo:[:m| (m isLocked and:[m fullContainsPoint: ((m transformedFrom: self) globalPointToLocal: aPoint)]) ifTrue:[^true]]. ^false! ! !Morph methodsFor: 'testing' stamp: ''! isMorph ^ true! ! !Morph methodsFor: 'meta-actions' stamp: 'MarcusDenker 9/13/2013 15:50'! potentialEmbeddingTargets "Return the potential targets for embedding the receiver" | oneUp topRend | (oneUp := (topRend := self topRendererOrSelf) owner) ifNil: [ ^ #() ]. ^ (oneUp morphsAt: topRend referencePosition behind: topRend unlocked: true) reject: [ :m | m isFlexMorph ]! ! !Morph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 7/23/2013 12:33'! changed: anAspect with: anObject self flag: #GSoC. "Flag added by Benjamin Van Ryseghem the July 22, 2013 to remember to remove this line in a while" [ super changed: anAspect ] on: Exception do: []. self announcer announce: (MorphChangedWithArguments new morph: self; selector: anAspect; arguments: anObject)! ! !Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:16'! toggleDropShadow self hasDropShadow ifTrue:[self removeDropShadow] ifFalse:[self addDropShadow].! ! !Morph methodsFor: 'text-anchor' stamp: 'StephaneDucasse 4/22/2012 16:51'! hasInlineAnchorString ^ (self textAnchorType == #inline)-> 'Inline' translated! ! !Morph methodsFor: 'event handling' stamp: 'ar 10/28/2000 22:18'! handlesKeyboard: evt "Return true if the receiver wishes to handle the given keyboard event" self eventHandler ifNotNil: [^ self eventHandler handlesKeyboard: evt]. ^ false ! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:01'! point: aPoint in: aReferenceMorph owner ifNil: [^ aPoint]. ^ (owner transformFrom: aReferenceMorph) localPointToGlobal: aPoint. ! ! !Morph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:28'! dropFiles: anEvent "Handle a number of files dropped from the OS" ! ! !Morph methodsFor: 'initialize' stamp: 'alain.plantec 6/10/2008 18:35'! openInWorld "Add this morph to the world." self openInWorld: self currentWorld! ! !Morph methodsFor: 'drawing' stamp: 'ar 11/4/2000 23:39'! changeClipSubmorphs self clipSubmorphs: self clipSubmorphs not.! ! !Morph methodsFor: 'menus' stamp: 'di 12/21/2000 17:18'! setToAdhereToEdge: anEdge anEdge ifNil: [^ self]. anEdge == #none ifTrue: [^ self removeProperty: #edgeToAdhereTo]. self setProperty: #edgeToAdhereTo toValue: anEdge. ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/24/2009 13:43'! morphicLayerNumberWithin: anOwner "Helpful for insuring some morphs always appear in front of or behind others. Smaller numbers are in front. Fixed here to call #morphicLayerNumber rather than access property directly." ^self morphicLayerNumber! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:20'! changeTableLayout | layout | ((layout := self layoutPolicy) notNil and:[layout isTableLayout]) ifTrue:[^self]. "already table layout" self layoutPolicy: TableLayout new. self layoutChanged.! ! !Morph methodsFor: 'drawing' stamp: 'CamilloBruni 5/29/2012 16:51'! fullDrawOn: aCanvas "Draw the full Morphic structure on the given Canvas" self visible ifFalse: [^ self]. (aCanvas isVisible: self fullBounds) ifFalse:[^self]. (self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas]. [ "Note: At some point we should generalize this into some sort of multi-canvas so that we can cross-optimize some drawing operations." "Pass 1: Draw eventual drop-shadow" self hasDropShadow ifTrue: [ self drawDropShadowOn: aCanvas ]. (self hasRolloverBorder and: [(aCanvas seesNothingOutside: self bounds) not]) ifTrue: [self drawRolloverBorderOn: aCanvas]. "Pass 2: Draw receiver itself" aCanvas roundCornersOf: self during:[ (aCanvas isVisible: self bounds) ifTrue:[aCanvas drawMorph: self]. self drawSubmorphsOn: aCanvas. self drawDropHighlightOn: aCanvas. self drawMouseDownHighlightOn: aCanvas] ] on: Error do: [:err | self setProperty: #errorOnDraw toValue: true. self setProperty: #drawError toValue: err freeze. ^ self drawErrorOn: aCanvas ]! ! !Morph methodsFor: 'event handling' stamp: 'RAA 6/19/2000 07:13'! transformFromOutermostWorld "Return a transform to map world coordinates into my local coordinates" "self isWorldMorph ifTrue: [^ MorphicTransform identity]." ^ self transformFrom: self outermostWorldMorph! ! !Morph methodsFor: 'layout' stamp: 'StephaneDucasse 5/31/2013 19:18'! computeBounds [ self doLayoutIn: self layoutBounds ] on: Error do: [ :ex | "This should do it unless you don't screw up the bounds" fullBounds := bounds. ex pass ]! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:44'! rootMorphsAt: aPoint "Return the list of root morphs containing the given point, excluding the receiver. ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds" self flag: #arNote. "check this at some point" ^ self submorphs select: [:m | (m fullContainsPoint: aPoint) and: [m isLocked not]]! ! !Morph methodsFor: 'meta-actions' stamp: 'MarcusDenker 11/7/2009 18:50'! maybeDuplicateMorph: evt ^self duplicateMorph: evt! ! !Morph methodsFor: 'event handling' stamp: 'StephaneDucasse 7/2/2013 16:26'! moveOrResizeFromKeystroke: anEvent "move or resize the receiver based on a keystroke" | dir | anEvent keyValue = 28 ifTrue: [ dir := -1 @ 0 ]. anEvent keyValue = 29 ifTrue: [ dir := 1 @ 0 ]. anEvent keyValue = 30 ifTrue: [ dir := 0 @ -1 ]. anEvent keyValue = 31 ifTrue: [ dir := 0 @ 1 ]. dir notNil ifTrue: [ anEvent controlKeyPressed ifTrue: [ dir := dir * 10 ]. anEvent shiftPressed ifTrue: [ self extent: self extent + dir ] ifFalse: [ self position: self position + dir ] ]! ! !Morph methodsFor: 'event handling' stamp: 'CamilloBruni 8/1/2012 16:02'! click: evt "Handle a single-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing." ^ self eventHandler ifNotNil: [self eventHandler click: evt fromMorph: self].! ! !Morph methodsFor: 'event handling' stamp: 'sw 11/16/1998 08:07'! suspendEventHandler self eventHandler ifNotNil: [self setProperty: #suspendedEventHandler toValue: self eventHandler. self eventHandler: nil]. submorphs do: [:m | m suspendEventHandler]. "All those rectangles"! ! !Morph methodsFor: 'text-anchor' stamp: 'StephaneDucasse 4/22/2012 16:52'! hasParagraphAnchorString ^ (self textAnchorType == #paragraph) -> 'Paragraph' translated! ! !Morph methodsFor: '*SUnit-UITesting' stamp: 'SeanDeNigris 12/9/2011 14:07'! simulateClickWith: buttons "Did you know there's #simulateClick (left), #simulateMiddleClick, and #simulateRightClick? buttons - look at MouseEvent's class-side for button types" | noButtons | noButtons := 0. { #mouseDown->buttons. #mouseUp->noButtons } do: [ :type | self activeHand handleEvent: (MouseButtonEvent new setType: type key position: (self pointInWorld: self center) "Some Morphs report local coords" which: (noButtons bitXor: buttons) buttons: type value hand: self activeHand stamp: Time millisecondClockValue) ].! ! !Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:34'! adjustLayoutBounds "Adjust the receivers bounds depending on the resizing strategy imposed" | hFit vFit box myExtent extent | hFit := self hResizing. vFit := self vResizing. (hFit == #shrinkWrap or:[vFit == #shrinkWrap]) ifFalse:[^self]. "not needed" box := self layoutBounds. myExtent := box extent. extent := self submorphBounds corner - box origin. hFit == #shrinkWrap ifTrue:[myExtent := extent x @ myExtent y]. vFit == #shrinkWrap ifTrue:[myExtent := myExtent x @ extent y]. "Make sure we don't get smaller than minWidth/minHeight" myExtent x < self minWidth ifTrue:[ myExtent := (myExtent x max: (self minWidth - self bounds width + self layoutBounds width)) @ myExtent y]. myExtent y < self minHeight ifTrue:[ myExtent := myExtent x @ (myExtent y max: (self minHeight - self bounds height + self layoutBounds height))]. self layoutBounds: (box origin extent: myExtent).! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:16'! right " Return the x-coordinate of my right side " ^ bounds right! ! !Morph methodsFor: 'undo' stamp: 'CamilleTeruel 12/6/2013 14:38'! undoMove: cmd redo: redo owner: formerOwner bounds: formerBounds predecessor: formerPredecessor "Handle undo and redo of move commands in morphic" self owner ifNil: [ ^ self inform: 'No owner' ]. formerOwner ifNotNil: [formerPredecessor ifNil: [formerOwner addMorphFront: self] ifNotNil: [formerOwner addMorph: self after: formerPredecessor]]. self bounds: formerBounds. (self isSystemWindow) ifTrue: [self activate]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:13'! formerOwner ^self valueOfProperty: #formerOwner! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:31'! firstSubmorph ^submorphs first! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! bottomCenter ^ bounds bottomCenter! ! !Morph methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:09'! borderStyle extension ifNil: [^BorderStyle default trackColorFrom: self]. ^(extension borderStyle ifNil: [BorderStyle default]) trackColorFrom: self! ! !Morph methodsFor: 'geometry testing' stamp: ''! containsPoint: aPoint ^ self bounds containsPoint: aPoint! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/12/2009 18:12'! roundedCorners "Return a list of those corners to round. 1-4 | | 2-3 Returned array contains `codes' of those corners, which should be rounded. 1 denotes top-left corner 2 denotes bottom-left corner 3 denotes bottom-right corner 4 denotes top-right corner. Thus, if this method returned #(2 3) that would mean that bottom (left and right) corners would be rounded whereas top (left and right) corners wouldn't be rounded. This method returns #(1 2 3 4) and that means that all the corners should be rounded." ^self valueOfProperty: #roundedCorners ifAbsent: [#(1 2 3 4)]! ! !Morph methodsFor: 'announcements' stamp: 'GuillermoPolito 5/1/2012 19:50'! onAnnouncement: anAnnouncement send: aMessageSelector to: anObject self announcer on: anAnnouncement send: aMessageSelector to: anObject.! ! !Morph methodsFor: 'copying' stamp: 'tk 2/14/2001 12:47'! deepCopy self error: 'Please use veryDeepCopy'. ! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 19:25'! eventHandler: anEventHandler "Note that morphs can share eventHandlers and all is OK. " self assureExtension eventHandler: anEventHandler! ! !Morph methodsFor: 'Morphic-Base-Pluggable Widgets' stamp: 'BenjaminVanRyseghem 5/7/2012 15:03'! beginsWith: aString fromList: aMorph | string | string := self userString ifNil: [(self submorphs collect: [:m | m userString]) detect: [:us | us notNil] ifNone: ['']]. ^ string asString beginsWith: aString fromList: aMorph! ! !Morph methodsFor: 'structure' stamp: 'ar 3/18/2001 00:11'! activeHand ^ActiveHand! ! !Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:43'! removeMouseUpAction self primaryHand showTemporaryCursor: nil. self removeProperty: #mouseUpCodeToRun. #(mouseUp mouseEnter mouseLeave mouseDown) do: [ :sym | self on: sym send: #yourself to: nil. ] ! ! !Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! addAlarm: aSelector with: arg1 at: scheduledTime "Add an alarm (that is an action to be executed once) with the given set of parameters" ^self addAlarm: aSelector withArguments: (Array with: arg1) at: scheduledTime! ! !Morph methodsFor: 'drawing' stamp: 'tk 8/2/1998 14:33'! doesOwnRotation "Some morphs don't want to TransformMorph to rotate their images, but we do" ^ false! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 18:54'! changeClipLayoutCells self invalidRect: self fullBounds. self clipLayoutCells: self clipLayoutCells not. self invalidRect: self fullBounds.! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/12/2007 10:12'! initialColorInSystemWindow: aSystemWindow "Answer the colour the receiver should be when added to a SystemWindow." ^Color white! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/10/2007 10:07'! window "Answer the receiver's window." ^self ownerThatIsA: SystemWindow! ! !Morph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 9/6/2013 12:12'! athensSurface ^ owner ifNil: [ nil ] ifNotNil: [ owner athensSurface ]! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 11/7/2013 16:52'! handleKeystrokeWithKeymappings: aKeystrokeEvent self allowsKeymapping ifTrue: [ self dispatchKeystrokeForEvent: aKeystrokeEvent. ].! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'StephaneDucasse 12/21/2012 18:11'! addMorph: aMorph fullFrame: aLayoutFrame aMorph layoutFrame: aLayoutFrame asLayoutFrame. aMorph hResizing: #spaceFill; vResizing: #spaceFill. self addMorph: aMorph. ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 12:55'! drawKeyboardFocusOn: aCanvas "Draw the keyboard focus indication." self focusIndicatorMorph drawOn: aCanvas! ! !Morph methodsFor: 'testing' stamp: 'StephaneDucasse 10/13/2013 21:49'! isTranslucentButNotTransparent "Answer true if this any of this morph is translucent but not transparent." ^ color isColor and: [ color isTranslucentButNotTransparent ] ! ! !Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:48'! removeProperty: aSymbol "removes the property named aSymbol if it exists" extension ifNil: [^ self]. extension removeProperty: aSymbol! ! !Morph methodsFor: 'drawing' stamp: 'LC 5/18/2000 08:48'! highlightedForMouseDown ^(self valueOfProperty: #highlightedForMouseDown) == true! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/20/2007 10:31'! defaultTaskbarThumbnailExtent "Answer the default size of a taskbar thumbnail for the receiver." ^320@320! ! !Morph methodsFor: 'layout' stamp: 'StephaneDucasse 6/2/2013 14:18'! computeFullBounds [ self doLayoutIn: self layoutBounds ] on: Error do: [ :ex | "This should do it unless you don't screw up the bounds" fullBounds := bounds. ex pass ]! ! !Morph methodsFor: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:52'! hasReverseCellsString ^ (self reverseTableCells) -> 'reverse table cells' translated! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'mir 1/4/2001 11:02'! startDrag: anItem with: anObject self currentHand attachMorph: anObject! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/8/2007 09:58'! optimalExtent "Answer the submorphBounds extent plus twice our border width." ^self submorphBounds extent + (self borderWidth * 2)! ! !Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:34'! fullReleaseCachedState "Release the cached state of the receiver and its full submorph tree." self allMorphsDo: [:m | m releaseCachedState]. ! ! !Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 21:13'! handleEvent: anEvent "Handle the given event" ^anEvent sentTo: self.! ! !Morph methodsFor: 'event handling' stamp: 'GuillermoPolito 4/22/2012 17:20'! handlesKeyStroke: evt ^self handlesKeyboard: evt! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:06'! globalPointToLocal: aPoint ^self point: aPoint from: nil! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 7/29/2013 14:17'! myDependents "Improved performance dependents." ^ (self valueOfProperty: #myDependents) ifNil: [ #() ]! ! !Morph methodsFor: 'layout-menu' stamp: 'GuillermoPolito 5/29/2011 14:50'! addTableLayoutMenuItems: aMenu hand: aHand | menu sub | menu := UIManager default newMenuIn: self for: self. menu addUpdating: #hasReverseCellsString action: #changeReverseCells. menu addUpdating: #hasClipLayoutCellsString action: #changeClipLayoutCells. menu addUpdating: #hasRubberBandCellsString action: #changeRubberBandCells. menu addLine. menu add: 'change cell inset...' translated action: #changeCellInset:. menu add: 'change min cell size...' translated action: #changeMinCellSize:. menu add: 'change max cell size...' translated action: #changeMaxCellSize:. menu addLine. sub := UIManager default newMenuIn: self for: self. #(leftToRight rightToLeft topToBottom bottomToTop) do:[:sym| sub addUpdating: #listDirectionString: target: self selector: #changeListDirection: argumentList: (Array with: sym)]. menu add: 'list direction' translated subMenu: sub. sub := UIManager default newMenuIn: self for: self. #(none leftToRight rightToLeft topToBottom bottomToTop) do:[:sym| sub addUpdating: #wrapDirectionString: target: self selector: #wrapDirection: argumentList: (Array with: sym)]. menu add: 'wrap direction' translated subMenu: sub. sub := UIManager default newMenuIn: self for: self. #(center topLeft topRight bottomLeft bottomRight topCenter leftCenter rightCenter bottomCenter) do:[:sym| sub addUpdating: #cellPositioningString: target: self selector: #cellPositioning: argumentList: (Array with: sym)]. menu add: 'cell positioning' translated subMenu: sub. sub := UIManager default newMenuIn: self for: self. #(topLeft bottomRight center justified) do:[:sym| sub addUpdating: #listCenteringString: target: self selector: #listCentering: argumentList: (Array with: sym)]. menu add: 'list centering' translated subMenu: sub. sub := UIManager default newMenuIn: self for: self. #(topLeft bottomRight center justified) do:[:sym| sub addUpdating: #wrapCenteringString: target: self selector: #wrapCentering: argumentList: (Array with: sym)]. menu add: 'wrap centering' translated subMenu: sub. sub := UIManager default newMenuIn: self for: self. #(none equal) do:[:sym| sub addUpdating: #listSpacingString: target: self selector: #listSpacing: argumentList: (Array with: sym)]. menu add: 'list spacing' translated subMenu: sub. sub := UIManager default newMenuIn: self for: self. #(none localRect localSquare globalRect globalSquare) do:[:sym| sub addUpdating: #cellSpacingString: target: self selector: #cellSpacing: argumentList: (Array with: sym)]. menu add: 'cell spacing' translated subMenu: sub. aMenu ifNotNil:[aMenu add: 'table layout' translated subMenu: menu]. ^menu! ! !Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:50'! outermostMorphThat: conditionBlock "Return the outermost containing morph for which aBlock is true, or nil if none" | outermost | self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [outermost := m]]. ^ outermost! ! !Morph methodsFor: 'menus' stamp: 'sw 9/21/2000 22:50'! lockUnlockMorph "If the receiver is locked, unlock it; if unlocked, lock it" self isLocked ifTrue: [self unlock] ifFalse: [self lock]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'GuillermoPolito 9/1/2010 18:40'! formerOwner: aMorphOrNil aMorphOrNil ifNil: [self removeProperty: #formerOwner] ifNotNil: [self setProperty: #formerOwner toValue: aMorphOrNil]! ! !Morph methodsFor: 'event handling' stamp: 'CamilloBruni 10/10/2012 13:37'! keyboardFocusChange: gotFocus "The message is sent to a morph when its keyboard focus change. The given argument indicates that the receiver is gaining keyboard focus (versus losing) the keyboard focus. Morphs that accept keystrokes should change their appearance in some way when they are the current keyboard focus. This default implementation does nothing." self announceKeyboardFocusChange: gotFocus! ! !Morph methodsFor: 'initialize' stamp: 'sma 4/22/2000 20:28'! openInWindowLabeled: aString ^self openInWindowLabeled: aString inWorld: self currentWorld! ! !Morph methodsFor: 'events-processing' stamp: 'BenjaminVanRyseghem 1/18/2012 18:59'! handleMouseStillDown: anEvent "Called from the stepping mechanism for morphs wanting continuously repeated 'yes the mouse is still down, yes it is still down, yes it has not changed yet, no the mouse is still not up, yes the button is down' etc messages" (anEvent hand mouseFocus == self) ifFalse:[^self stopSteppingSelector: #handleMouseStillDown:]. self mouseStillDown: anEvent. ^ self eventHandler ifNotNil: [:handler | handler mouseStillDown: anEvent fromMorph: self ] ! ! !Morph methodsFor: 'events-removing' stamp: 'rw 4/25/2002 07:18'! releaseActionMap "Release the action map" self removeProperty: #actionMap! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 12/16/2001 21:08'! addMorphFrontFromWorldPosition: aMorph ^self addMorphFront: aMorph fromWorldPosition: aMorph positionInWorld.! ! !Morph methodsFor: 'text-anchor' stamp: 'GuillermoPolito 5/29/2011 14:50'! addTextAnchorMenuItems: topMenu hand: aHand | aMenu | aMenu := UIManager default newMenuIn: self for: self. aMenu addUpdating: #hasInlineAnchorString action: #changeInlineAnchor. aMenu addUpdating: #hasParagraphAnchorString action: #changeParagraphAnchor. aMenu addUpdating: #hasDocumentAnchorString action: #changeDocumentAnchor. topMenu ifNotNil:[topMenu add: 'text anchor' subMenu: aMenu]. ^aMenu! ! !Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:46'! assureExtension "creates an extension for the receiver if needed" extension ifNil: [self initializeExtension]. ^ extension! ! !Morph methodsFor: 'halos and balloon help' stamp: 'stephane.ducasse 9/20/2008 21:57'! preferredDuplicationHandleSelector "Answer the selector, either #addMakeSiblingHandle: or addDupHandle:, to be offered as the default in a halo open on me" ^ #addDupHandle:! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 11:51'! highlightForDrop self highlightForDrop: true! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'nice 1/5/2010 15:59'! morphsAt: aPoint behind: aMorph unlocked: aBool "Return all morphs at aPoint that are behind frontMorph; if aBool is true return only unlocked, visible morphs." | isBack all tfm | all := (aMorph isNil or: [owner isNil]) ifTrue: ["Traverse down" (self fullBounds containsPoint: aPoint) ifFalse: [^#()]. (aBool and: [self isLocked or: [self visible not]]) ifTrue: [^#()]. nil] ifFalse: ["Traverse up" tfm := self transformedFrom: owner. all := owner morphsAt: (tfm localPointToGlobal: aPoint) behind: self unlocked: aBool. WriteStream with: all]. isBack := aMorph isNil. self submorphsDo: [:m | | found | isBack ifTrue: [tfm := m transformedFrom: self. found := m morphsAt: (tfm globalPointToLocal: aPoint) behind: nil unlocked: aBool. found notEmpty ifTrue: [all ifNil: [all := Array new writeStream]. all nextPutAll: found]]. m == aMorph ifTrue: [isBack := true]]. (isBack and: [self containsPoint: aPoint]) ifTrue: [all ifNil: [^Array with: self]. all nextPut: self]. ^all ifNil: [#()] ifNotNil: [all contents]! ! !Morph methodsFor: '*SUnit-UITesting' stamp: 'SeanDeNigris 12/9/2011 13:56'! simulateMiddleClick self simulateClickWith: MouseEvent blueButton.! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'sw 4/9/98 14:26'! submorphNamed: aName ^ self submorphNamed: aName ifNone: [nil]! ! !Morph methodsFor: 'menus' stamp: 'GuillermoPolito 5/29/2011 14:50'! adhereToEdge | menu | menu := UIManager default newMenuIn: self for: self. #(top right bottom left - center - topLeft topRight bottomRight bottomLeft - none) do: [:each | each == #- ifTrue: [menu addLine] ifFalse: [menu add: each asString translated selector: #setToAdhereToEdge: argument: each]]. menu popUpEvent: self currentEvent in: self world! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/2/2009 13:24'! layoutChanged "Fixed to always flush layout cache - finally tracked down layout anomalies due to cached extents in layout policies not being flushed, the previous (incorrect) assumption being that it did not matter if layout was to be recomputed (fullBounds being nil). Recomputing of the layout apparently does not flush so must be done here." | layout | fullBounds := nil. layout := self layoutPolicy. layout ifNotNil:[layout flushLayoutCache]. owner ifNotNil: [owner layoutChanged]. "note: does not send #ownerChanged here - we'll do this when computing the new layout"! ! !Morph methodsFor: 'printing' stamp: 'MarcusDenker 10/28/2010 14:02'! printOn: aStream super printOn: aStream. aStream nextPutAll: '('. aStream print: self identityHash; nextPutAll: ')'! ! !Morph methodsFor: 'meta-actions' stamp: 'MarcusDenker 11/7/2009 18:52'! copyToPasteBuffer: evt ^evt hand copyToPasteBuffer: self.! ! !Morph methodsFor: 'updating' stamp: 'IgorStasenko 8/27/2013 16:25'! handleUpdate: aMorphChangedAnnouncement ^ aMorphChangedAnnouncement deliverTo: self! ! !Morph methodsFor: 'rounding' stamp: 'AlainPlantec 12/20/2009 00:20'! roundedCornersString "Answer the string to put in a menu that will invite the user to switch to the opposite corner-rounding mode" ^ (self wantsRoundedCorners ifTrue: ['' translated] ifFalse: ['' translated]) , ('round corners' translated)! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:01'! rubberBandCells "Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow." | props | props := self layoutProperties. ^props ifNil:[false] ifNotNil:[props rubberBandCells].! ! !Morph methodsFor: 'drawing' stamp: 'CamilloBruni 5/29/2012 17:13'! drawErrorOn: aCanvas "The morph (or one of its submorphs) had an error in its drawing method." aCanvas frameAndFillRectangle: bounds fillColor: Color red borderWidth: 1 borderColor: Color yellow. aCanvas line: bounds topLeft to: bounds bottomRight width: 1 color: Color yellow. aCanvas line: bounds topRight to: bounds bottomLeft width: 1 color: Color yellow. self valueOfProperty: #drawError ifPresentDo: [ :error| | trace stringBounds | trace := String streamContents: [ :s| error signalerContext shortDebugStackOn: s]. stringBounds := bounds insetBy: 5. trace linesDo: [ :aString| aCanvas drawString: aString in: stringBounds. stringBounds := stringBounds top: stringBounds top + (TextStyle defaultFont pixelSize * 1.2) ]]! ! !Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! addAlarm: aSelector withArguments: args after: delayTime "Add an alarm (that is an action to be executed once) with the given set of parameters" ^self addAlarm: aSelector withArguments: args at: Time millisecondClockValue + delayTime! ! !Morph methodsFor: 'debug and other' stamp: 'ClementBera 10/25/2013 13:58'! deleteAnyMouseActionIndicators self changed. self removeProperty: #mouseActionIndicatorMorphs. self hasRolloverBorder: false. self removeProperty: #rolloverWidth. self removeProperty: #rolloverColor. self layoutChanged. self changed. ! ! !Morph methodsFor: 'user interface' stamp: 'tak 3/15/2005 17:36'! becomeModal self currentWorld ifNotNil: [self currentWorld modalWindow: self]! ! !Morph methodsFor: 'menu' stamp: 'MarcusDenker 12/2/2013 14:14'! hasYellowButtonMenu "Answer true if I have any items at all for a context (yellow button) menu." ^ self wantsYellowButtonMenu or: [self modelOrNil ifNil: [false] ifNotNil: [:aModel | aModel hasModelYellowButtonMenuItems]]! ! !Morph methodsFor: 'Morphic-Base-Widgets' stamp: 'BenjaminVanRyseghem 2/12/2012 00:22'! widthToDisplayInList: aList ^ self minExtent x! ! !Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:28'! isStepping "Return true if the receiver is currently stepping in its world" | aWorld | ^ (aWorld := self world) ifNil: [false] ifNotNil: [aWorld isStepping: self]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 11:34'! nextMorphInWindow "Answer the next morph in the window. Traverse from the receiver to its first child or next sibling or owner's next sibling etc." ^self hasSubmorphs ifTrue: [self submorphs first] ifFalse: [self nextMorphAcrossInWindow]! ! !Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:48'! setProperty: aSymbol toValue: anObject "change the receiver's property named aSymbol to anObject" anObject ifNil: [^ self removeProperty: aSymbol]. self assureExtension setProperty: aSymbol toValue: anObject! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 5/7/2010 22:53'! okayToRotateEasily "Answer whether it is appropriate for a rotation handle to be shown for the receiver. This is a hook -- at present nobody declines." ^ self respondsTo: #prepareForRotating! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/20/2009 18:42'! boundsWithinCorners "Changed to be more realistic..." ^self bounds insetBy: 2! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:00'! minCellSize "Layout specific. This property specifies the minimal size of a table cell." | props | props := self layoutProperties. ^props ifNil:[0] ifNotNil:[props minCellSize].! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 17:21'! hasKeyboardFocus "Answer whether the receiver has keyboard focus." ^((self world ifNil: [^false]) activeHand ifNil: [^false]) keyboardFocus = self! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 5/7/2010 22:56'! wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" (#(addDismissHandle:) includes: aSelector) ifTrue: [^ self resistsRemoval not]. (#( addDragHandle: ) includes: aSelector) ifTrue: [^ self okayToBrownDragEasily]. (#(addGrowHandle: addScaleHandle:) includes: aSelector) ifTrue: [^ self okayToResizeEasily]. (#( addRotateHandle: ) includes: aSelector) ifTrue: [^ self okayToRotateEasily]. (#(addRecolorHandle:) includes: aSelector) ifTrue: [^ self renderedMorph wantsRecolorHandle]. ^ true ! ! !Morph methodsFor: 'thumbnail' stamp: 'sw 6/16/1999 11:29'! permitsThumbnailing ^ true! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/6/2000 15:13'! grabTransform "Return the transform for the receiver which should be applied during grabbing" ^owner ifNil:[IdentityTransform new] ifNotNil:[owner grabTransform]! ! !Morph methodsFor: 'layout-menu' stamp: 'GuillermoPolito 5/29/2011 14:48'! addCellLayoutMenuItems: aMenu hand: aHand "Cell (e.g., child) related items" | menu sub | menu := UIManager default newMenuIn: self for: self. menu addUpdating: #hasDisableTableLayoutString action: #changeDisableTableLayout. menu addLine. sub := UIManager default newMenuIn: self for: self. #(rigid shrinkWrap spaceFill) do:[:sym| sub addUpdating: #hResizingString: target: self selector: #hResizing: argumentList: (Array with: sym)]. menu add:'horizontal resizing' translated subMenu: sub. sub := UIManager default newMenuIn: self for: self. #(rigid shrinkWrap spaceFill) do:[:sym| sub addUpdating: #vResizingString: target: self selector: #vResizing: argumentList: (Array with: sym)]. menu add:'vertical resizing' translated subMenu: sub. aMenu ifNotNil:[aMenu add: 'child layout' translated subMenu: menu]. ^menu! ! !Morph methodsFor: 'initialize' stamp: 'dgd 3/7/2003 15:06'! defaultBounds "answer the default bounds for the receiver" ^ 0 @ 0 corner: 50 @ 40! ! !Morph methodsFor: 'Morphic-Base-Worlds' stamp: 'dgd 9/1/2004 16:10'! clearArea "Answer the clear area of the receiver. It means the area free of docking bars." | visTop visBottom visLeft visRight | visTop := self top. visBottom := self bottom. visLeft := self left. visRight := self right. self dockingBars do: [:each | (each isAdheringToTop and: [each bottom > visTop]) ifTrue: [visTop := each bottom]. (each isAdheringToBottom and: [each top < visBottom]) ifTrue: [visBottom := each top]. (each isAdheringToLeft and: [each right > visLeft]) ifTrue: [visLeft := each right]. (each isAdheringToRight and: [each left < visRight]) ifTrue: [visRight := each left] ]. ^ Rectangle left: visLeft right: visRight top: visTop bottom: visBottom ! ! !Morph methodsFor: 'testing' stamp: 'MarcusDenker 3/21/2010 20:16'! isFullOnScreen "Answer if the receiver is full contained in the owner visible area." owner ifNil: [^ true]. self visible ifFalse: [^ true]. ^ owner clearArea containsRect: self fullBounds! ! !Morph methodsFor: 'geometry' stamp: 'di 2/23/98 11:36'! worldBounds ^ self world bounds! ! !Morph methodsFor: 'drawing' stamp: 'sw 11/26/2003 17:43'! flashBounds "Flash the receiver's bounds -- does not use the receiver's color, thus works with StringMorphs and SketchMorphs, etc., for which #flash is useless. No senders initially, but useful to send this from a debugger or inspector" 5 timesRepeat: [Display flash: self boundsInWorld andWait: 120]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'StephaneDucasse 5/23/2013 18:34'! taskThumbnailOfSize: thumbExtent "Answer a new task thumbnail for the receiver." |f t r| r := self bounds scaledAndCenteredIn: (0@0 extent: thumbExtent). f := Form extent: r extent depth: Display depth. t := MatrixTransform2x3 withScale: f extent / self extent. f getCanvas transformBy: t clippingTo: f boundingBox during: [:c | c translateBy: self topLeft negated during: [:ct | self fullDrawOn: ct]] smoothing: 2. ^ImageMorph new form: f! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'adrian_lienhard 7/19/2009 17:35'! vanishAfterSlidingTo: aPosition event: evt | aForm aWorld startPoint endPoint | aForm := self imageForm offset: 0@0. aWorld := self world. startPoint := evt hand fullBounds origin. self delete. aWorld displayWorld. endPoint := aPosition. aForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15.! ! !Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:48'! firstOwnerSuchThat: conditionBlock self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [^ m]]. ^ nil ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/7/2000 08:29'! addMorph: aMorph asElementNumber: aNumber "Add the given morph so that it becomes the aNumber'th element of my submorph list. If aMorph is already one of my submorphs, reposition it" (submorphs includes: aMorph) ifTrue: [aMorph privateDelete]. (aNumber <= submorphs size) ifTrue: [self addMorph: aMorph inFrontOf: (submorphs at: aNumber)] ifFalse: [self addMorphBack: aMorph] ! ! !Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! addAlarm: aSelector with: arg1 with: arg2 after: delayTime "Add an alarm (that is an action to be executed once) with the given set of parameters" ^self addAlarm: aSelector withArguments: (Array with: arg1 with: arg2) after: delayTime! ! !Morph methodsFor: 'geometry' stamp: 'sw 10/25/1999 16:49'! referencePositionInWorld ^ self pointInWorld: self referencePosition ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/7/1999 21:55'! addHalo: evt from: formerHaloOwner "Transfer a halo from the former halo owner to the receiver" ^self addHalo: evt! ! !Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! addAlarm: aSelector with: arg1 with: arg2 at: scheduledTime "Add an alarm (that is an action to be executed once) with the given set of parameters" ^self addAlarm: aSelector withArguments: (Array with: arg1 with: arg2) at: scheduledTime! ! !Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:42'! startSteppingSelector: aSelector "Start getting sent the 'step' message." self startStepping: aSelector at: Time millisecondClockValue arguments: nil stepTime: nil.! ! !Morph methodsFor: 'stepping and presenter' stamp: 'sw 10/11/1999 12:59'! stopSteppingSelfAndSubmorphs self allMorphsDo: [:m | m stopStepping] ! ! !Morph methodsFor: 'geometry' stamp: 'sw 6/4/2000 21:59'! minimumExtent | ext | "This returns the minimum extent that the morph may be shrunk to. Not honored in too many places yet, but respected by the resizeToFit feature, at least. copied up from SystemWindow 6/00" (ext := self valueOfProperty: #minimumExtent) ifNotNil: [^ ext]. ^ 100 @ 80! ! !Morph methodsFor: 'geniestubs' stamp: 'nk 3/11/2004 17:30'! mouseStillDownStepRate "At what rate do I want to receive #mouseStillDown: notifications?" ^1! ! !Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:52'! beUnsticky "If the receiver is marked as sticky, make it now be unsticky" extension ifNotNil: [extension sticky: false]! ! !Morph methodsFor: 'private' stamp: 'MarcusDenker 10/22/2013 14:56'! privateFullMoveBy: delta "Private!! Relocate me and all of my subMorphs by recursion. Subclasses that implement different coordinate systems may override this method." self privateMoveBy: delta. submorphs do: [:each | each privateFullMoveBy: delta]. ! ! !Morph methodsFor: 'menus' stamp: 'DamienCassou 9/29/2009 13:01'! exportAsGIF | fName | fName := UIManager default request:'Please enter the name' translated initialAnswer: self externalName,'.gif'. fName isEmptyOrNil ifTrue:[^self]. GIFReadWriter putForm: self imageForm onFileNamed: fName.! ! !Morph methodsFor: 'menus' stamp: 'StephaneDucasse 4/22/2012 16:50'! hasDirectionHandlesString ^ (self wantsDirectionHandles) -> 'direction handles' translated! ! !Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 08:53'! valueOfProperty: aSymbol "answer the value of the receiver's property named aSymbol" ^ extension ifNotNil: [extension valueOfProperty: aSymbol]! ! !Morph methodsFor: 'drawing' stamp: 'sw 10/10/1999 23:25'! refreshWorld | aWorld | (aWorld := self world) ifNotNil: [aWorld displayWorldSafely] ! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 10/31/2000 20:45'! vResizingString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self vResizing! ! !Morph methodsFor: 'meta-actions' stamp: 'ar 11/4/2000 17:56'! duplicateMorph: evt "Make and return a duplicate of the receiver's argument" | dup | dup := self duplicate. evt hand grabMorph: dup from: owner. "duplicate was ownerless so use #grabMorph:from: here" ^dup! ! !Morph methodsFor: 'events-processing' stamp: 'ar 10/4/2000 18:48'! handleFocusEvent: anEvent "Handle the given event. This message is sent if the receiver currently has the focus and is therefore receiving events directly from some hand." ^self handleEvent: anEvent! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'ClementBera 7/30/2013 11:04'! myDependents: aCollectionOrNil "Improved performance dependents." aCollectionOrNil ifNil: [self removeProperty: #myDependents] ifNotNil: [self setProperty: #myDependents toValue: aCollectionOrNil]! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:09'! bottomRight: aPoint " Move me so that my bottom right corner is at aPoint. My extent (width & height) are unchanged " self position: ((aPoint x - bounds width) @ (aPoint y - self height)) ! ! !Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 18:59'! shadowColor ^self valueOfProperty: #shadowColor ifAbsent:[Color black]! ! !Morph methodsFor: 'menu' stamp: 'sw 11/27/2001 15:21'! addBorderStyleMenuItems: aMenu hand: aHandMorph "Probably one could offer border-style items even if it's not a borderedMorph, so this remains a loose end for the moment" ! ! !Morph methodsFor: 'initialize' stamp: 'GuillermoPolito 5/1/2012 20:01'! openInWorld: aWorld "Add this morph to the requested World." (aWorld visibleClearArea origin ~= (0@0) and: [self position = (0@0)]) ifTrue: [self position: aWorld visibleClearArea origin]. aWorld addMorph: self. aWorld startSteppingSubmorphsOf: self. self announceOpened.! ! !Morph methodsFor: 'change reporting' stamp: 'ar 8/12/2003 21:50'! addedMorph: aMorph "Notify the receiver that the given morph was just added." ! ! !Morph methodsFor: 'geometry' stamp: 'nk 4/27/2003 16:16'! intersects: aRectangle "Answer whether aRectangle, which is in World coordinates, intersects me." ^self fullBoundsInWorld intersects: aRectangle! ! !Morph methodsFor: 'visual properties' stamp: 'gvc 9/11/2009 16:39'! fillStyle: aFillStyle "Set the current fillStyle of the receiver. Optimized for no change." self assureExtension. extension fillStyle = aFillStyle ifTrue: [^self]. "no change optimization" extension fillStyle: aFillStyle. color := aFillStyle asColor. self changed! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:50'! enableDrag: aBoolean self setProperty: #dragEnabled toValue: aBoolean! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/29/2008 15:14'! paneColor: aColor "Explicitly set the pane color for the reveiver." self setProperty: #paneColor toValue: aColor. self adoptPaneColor! ! !Morph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:04'! mouseMove: evt "Handle a mouse move event. The default response is to let my eventHandler, if any, handle it." self eventHandler ifNotNil: [self eventHandler mouseMove: evt fromMorph: self]. ! ! !Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:31'! handlesMouseOverDragging: evt "Return true if I want to receive mouseEnterDragging: and mouseLeaveDragging: when the hand drags something over me (button up or button down), or when the mouse button is down but there is no mouseDown recipient. The default response is false, except if you have added sensitivity to mouseEnterLaden: or mouseLeaveLaden:, using the on:send:to: mechanism." "NOTE: If the hand state matters in these cases, it may be tested by constructs such as event anyButtonPressed event hand hasSubmorphs" self eventHandler ifNotNil: [^ self eventHandler handlesMouseOverDragging: evt]. ^ false! ! !Morph methodsFor: 'events-processing' stamp: 'ar 9/16/2000 14:22'! handleListenEvent: anEvent "Handle the given event. This message is sent if the receiver is a registered listener for the given event." ^anEvent sentTo: self.! ! !Morph methodsFor: 'events-processing' stamp: 'ar 4/23/2001 17:24'! handleMouseOver: anEvent "System level event handling." anEvent hand mouseFocus == self ifTrue:[ "Got this directly through #handleFocusEvent: so check explicitly" (self containsPoint: anEvent position event: anEvent) ifFalse:[^self]]. anEvent hand noticeMouseOver: self event: anEvent! ! !Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:48'! changeInlineAnchor "Change the anchor from/to line anchoring" | newType | newType := self textAnchorType == #inline ifTrue: [#paragraph] ifFalse: [#inline]. owner isTextMorph ifTrue: [owner anchorMorph: self at: self position type: newType]! ! !Morph methodsFor: 'layout' stamp: 'ClementBera 7/30/2013 11:04'! minWidth: aNumber aNumber ifNil: [self removeProperty: #minWidth] ifNotNil: [self setProperty: #minWidth toValue: aNumber]. self layoutChanged! ! !Morph methodsFor: '*SUnit-UITesting' stamp: 'SeanDeNigris 12/1/2011 22:08'! simulateRightClick self simulateClickWith: MouseEvent yellowButton.! ! !Morph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 7/24/2013 13:35'! update: anAspect ^ self! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/9/2007 12:25'! paneColor "Answer the window's pane color or our color otherwise." ^self paneColorOrNil ifNil: [self color]! ! !Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:10'! programmedMouseLeave: anEvent for: aMorph self deleteAnyMouseActionIndicators. ! ! !Morph methodsFor: 'menus' stamp: 'MarcusDenker 11/28/2009 14:25'! transferStateToRenderer: aRenderer "Transfer knownName, and visible over to aRenderer, which is being imposed above me as a transformation shell" aRenderer simplySetVisible: self visible ! ! !Morph methodsFor: 'events-alarms' stamp: 'ar 9/14/2000 12:15'! addAlarm: aSelector withArguments: args at: scheduledTime "Add an alarm (that is an action to be executed once) with the given set of parameters" | scheduler | scheduler := self alarmScheduler. scheduler ifNotNil:[scheduler addAlarm: aSelector withArguments: args for: self at: scheduledTime].! ! !Morph methodsFor: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:52'! hasProportionalLayoutString | layout | ^ ((layout := self layoutPolicy) notNil and: [layout isProportionalLayout]) -> 'proportional layout' translated! ! !Morph methodsFor: 'drawing' stamp: 'GaryChambers 9/8/2011 14:55'! drawDropShadowOn: aCanvas aCanvas translateBy: self shadowOffset during: [ :shadowCanvas | shadowCanvas roundShadowCornersOf: self during: [ (shadowCanvas isVisible: self bounds) ifTrue: [ shadowCanvas fillRectangle: self bounds fillStyle: self shadowColor ] ] ]. ! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'! wrapDirection: aSymbol "Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are: #leftToRight #rightToLeft #topToBottom #bottomToTop #none indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa." self assureTableProperties wrapDirection: aSymbol. self layoutChanged. ! ! !Morph methodsFor: 'structure' stamp: ''! owner "Returns the owner of this morph, which may be nil." ^ owner! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'! cellPositioning "Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are: #topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center which align the receiver's bounds with the cell at the given point." | props | props := self layoutProperties. ^props ifNil:[#center] ifNotNil:[props cellPositioning].! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:06'! morphsAt: aPoint unlocked: aBool "Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself. The order is deepest embedding first." | mList | mList := Array new writeStream. self morphsAt: aPoint unlocked: aBool do:[:m| mList nextPut: m]. ^mList contents! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/14/2009 17:53'! nextMorphWantingFocus "Answer the next morph that wants keyboard focus." |m| m := self nextMorphInWindow ifNil: [^nil]. [m = self or: [m wantsKeyboardFocusNavigation]] whileFalse: [m := m nextMorphInWindow]. ^m wantsKeyboardFocusNavigation ifTrue: [m] ! ! !Morph methodsFor: 'drop shadows' stamp: 'ar 11/12/2000 18:57'! removeDropShadow self hasDropShadow ifFalse:[^self]. self changed. self hasDropShadow: false. fullBounds ifNotNil:[fullBounds := self privateFullBounds]. self changed.! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:50'! dragEnabled "Get this morph's ability to add and remove morphs via drag-n-drop." ^(self valueOfProperty: #dragEnabled) == true ! ! !Morph methodsFor: 'event handling' stamp: 'GuillermoPolito 11/7/2013 16:57'! handleKeystroke: anEvent "System level event handling." anEvent wasHandled ifTrue: [^ self]. Smalltalk tools shortcuts handleKeystroke: anEvent inMorph: self. anEvent wasHandled ifTrue: [^ self]. (self handlesKeyStroke: anEvent) ifFalse: [^ self]. anEvent wasHandled: true. self keyStroke: anEvent. ^ self eventHandler ifNotNil: [:handler | handler keyStroke: anEvent fromMorph: self ].! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/26/2010 02:11'! layoutInBounds: cellBounds "Layout specific. Apply the given bounds to the receiver after being layed out in its owner." | box aSymbol delta | cellBounds = self bounds ifTrue:[^self]. "already up to date. Fixed here to use bounds rather than fullBounds for the check." cellBounds extent = self bounds extent "nice fit. Fixed here to use bounds rather than fullBounds for the check." ifTrue:[^self position: cellBounds origin]. box := bounds. self hResizing == #shrinkWrap ifTrue:[box := box origin extent: self minExtent x @ box height]. self vResizing == #shrinkWrap ifTrue:[box := box origin extent: box width @ self minExtent y]. "match #spaceFill constraints" self hResizing == #spaceFill ifTrue:[box := box origin extent: cellBounds width @ box height]. self vResizing == #spaceFill ifTrue:[box := box origin extent: box width @ cellBounds height]. "align accordingly" aSymbol := (owner ifNil:[self]) cellPositioning. box := box align: (box perform: aSymbol) with: (cellBounds perform: aSymbol). "and install new bounds" self bounds: box.! ! !Morph methodsFor: 'event handling' stamp: 'sw 11/16/1998 08:06'! restoreSuspendedEventHandler | savedHandler | (savedHandler := self valueOfProperty: #suspendedEventHandler) ifNotNil: [self eventHandler: savedHandler]. submorphs do: [:m | m restoreSuspendedEventHandler] ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'ClementBera 7/30/2013 11:04'! minExtent "Layout specific. Return the minimum size the receiver can be represented in. Implementation note: When this message is sent from an owner trying to lay out its children it will traverse down the morph tree and recompute the minimal arrangement of the morphs based on which the minimal extent is returned. When a morph with some layout strategy is encountered, the morph will ask its strategy to compute the new arrangement. However, since the final size given to the receiver is unknown at the point of the query, the assumption is made that the current bounds of the receiver are the base on which the layout should be computed. This scheme prevents strange layout changes when for instance, a table is contained in another table. Unless the inner table has been resized manually (which means its bounds are already enlarged) the arrangement of the inner table will not change here. Thus the entire layout computation is basically an iterative process which may have different results depending on the incremental changes applied. Fixed for shrinkWrap." | layout minExtent extra hFit vFit | hFit := self hResizing. vFit := self vResizing. (hFit == #rigid and: [vFit == #rigid]) ifTrue: ["The receiver will not adjust to parents layout by growing or shrinking, which means that an accurate layout defines the minimum size." ^self fullBounds extent max: self minWidth @ self minHeight]. "An exception -- a receiver with #shrinkWrap constraints but no children is being treated #rigid (the equivalent to a #spaceFill receiver in a non-layouting owner)" self hasSubmorphs ifFalse: [hFit == #shrinkWrap ifTrue: [hFit := #rigid]. vFit == #shrinkWrap ifTrue: [vFit := #rigid]]. layout := self layoutPolicy. layout ifNil: [minExtent := 0 @ 0] ifNotNil: [minExtent := layout minExtentOf: self in: self layoutBounds]. hFit == #rigid ifTrue: [minExtent := self fullBounds extent x @ minExtent y] ifFalse: [extra := self bounds width - self layoutBounds width. minExtent := (minExtent x + extra) @ minExtent y]. minExtent := vFit == #rigid ifTrue: [minExtent x @ self fullBounds extent y] ifFalse: [extra := self bounds height - self layoutBounds height. minExtent x @ (minExtent y + extra)]. minExtent := minExtent max: self minWidth @ self minHeight. ^minExtent! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'! bounds: aRectangle in: referenceMorph "Return the receiver's bounds as seen by aMorphs coordinate frame" owner ifNil: [^ aRectangle]. ^(owner transformFrom: referenceMorph) localBoundsToGlobal: aRectangle ! ! !Morph methodsFor: 'change reporting' stamp: 'ar 8/12/2003 22:26'! privateInvalidateMorph: aMorph "Private. Invalidate the given morph after adding or removing. This method is private because a) we're invalidating the morph 'remotely' and b) it forces a fullBounds computation which should not be necessary for a general morph c) the morph may or may not actually invalidate anything (if it's not in the world nothing will happen) and d) the entire mechanism should be rewritten." aMorph fullBounds. aMorph changed! ! !Morph methodsFor: 'structure' stamp: 'di 11/13/2000 01:00'! allOwners "Return the owners of the reciever" ^ Array streamContents: [:strm | self allOwnersDo: [:m | strm nextPut: m]]! ! !Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! addAlarm: aSelector after: delayTime "Add an alarm (that is an action to be executed once) with the given set of parameters" ^self addAlarm: aSelector withArguments: #() after: delayTime! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:18'! dragEnabled: aBool ^self enableDrag: aBool! ! !Morph methodsFor: 'rotate scale and flex' stamp: 'AlainPlantec 5/7/2010 21:27'! prepareForScaling "If this morph requires a flex shell to scale, then wrap it in one and return it. Polygons, eg, may override to return themselves." ^ self addFlexShell! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sma 12/23/1999 13:24'! editBalloonHelpText "Modify the receiver's balloon help text." self editBalloonHelpContent: self balloonText! ! !Morph methodsFor: 'visual properties' stamp: 'nk 2/27/2003 11:48'! useGradientFill "Make receiver use a solid fill style (e.g., a simple color)" | fill color1 color2 | self fillStyle isGradientFill ifTrue:[^self]. "Already done" color1 := self color asColor. color2 := color1 negated. fill := GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}. fill origin: self topLeft. fill direction: 0 @ self bounds extent y. fill normal: self bounds extent x @ 0. fill radial: false. self fillStyle: fill! ! !Morph methodsFor: 'layout-menu' stamp: 'GuillermoPolito 5/29/2011 14:48'! addLayoutMenuItems: topMenu hand: aHand | aMenu | aMenu := UIManager default newMenuIn: self for: self. aMenu addUpdating: #hasNoLayoutString action: #changeNoLayout. aMenu addUpdating: #hasProportionalLayoutString action: #changeProportionalLayout. aMenu addUpdating: #hasTableLayoutString action: #changeTableLayout. aMenu addLine. aMenu add: 'change layout inset...' translated action: #changeLayoutInset:. aMenu addLine. self addCellLayoutMenuItems: aMenu hand: aHand. self addTableLayoutMenuItems: aMenu hand: aHand. topMenu ifNotNil:[topMenu add: 'layout' translated subMenu: aMenu]. ^aMenu! ! !Morph methodsFor: 'debug and other' stamp: 'gm 2/22/2003 13:41'! addMouseUpActionWith: codeToRun ((codeToRun isMessageSend) not and: [codeToRun isEmptyOrNil]) ifTrue: [^self]. self setProperty: #mouseUpCodeToRun toValue: codeToRun. self on: #mouseUp send: #programmedMouseUp:for: to: self. self on: #mouseDown send: #programmedMouseDown:for: to: self. self on: #mouseEnter send: #programmedMouseEnter:for: to: self. self on: #mouseLeave send: #programmedMouseLeave:for: to: self! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 8/5/2013 10:21'! bindKeyCombination: aShortcut toAction: anAction self kmDispatcher bindKeyCombination: aShortcut asKeyCombination toAction: anAction! ! !Morph methodsFor: 'wiw support' stamp: 'ar 3/18/2001 00:14'! shouldGetStepsFrom: aWorld ^self world == aWorld! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:17'! top " Return the y-coordinate of my top side " ^ bounds top! ! !Morph methodsFor: 'debug and other' stamp: 'dgd 2/22/2003 19:05'! ownerChain "Answer a list of objects representing the receiver and all of its owners. The first element is the receiver, and the last one is typically the world in which the receiver resides" | c next | c := OrderedCollection with: self. next := self. [(next := next owner) notNil] whileTrue: [c add: next]. ^c asArray! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/11/2007 15:03'! taskbarThumbnailExtent "Answer the size of a taskbar thumbnail for the receiver." ^self extent min: self defaultTaskbarThumbnailExtent! ! !Morph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 1/18/2012 18:53'! mouseEnter: evt "Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it." ^ self eventHandler ifNotNil: [self eventHandler mouseEnter: evt fromMorph: self]. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 12/19/2009 23:30'! balloonHelpDelayTime "Return the number of milliseconds before a balloon help should be put up on the receiver. The balloon help will only be put up if the receiver responds to #wantsBalloon by returning true." ^ self theme settings balloonHelpDelayTime! ! !Morph methodsFor: 'halos and balloon help' stamp: 'MarcusDenker 11/7/2009 21:51'! okayToAddDismissHandle "Answer whether a halo on the receiver should offer a dismiss handle. This provides a hook for making it harder to disassemble some strucures even momentarily" ^self resistsRemoval not! ! !Morph methodsFor: 'debug and other' stamp: 'BenjaminVanRyseghem 9/29/2013 14:54'! buildDebugMenu: aHand "Answer a debugging menu for the receiver. The hand argument is seemingly historical and plays no role presently" | aMenu | aMenu := UIManager default newMenuIn: self for: self. aMenu addStayUpItem. (self hasProperty: #errorOnDraw) ifTrue: [aMenu add: 'start drawing again' translated action: #resumeAfterDrawError.]. (self hasProperty: #drawError) ifTrue: [aMenu add: 'debug drawing error' translated action: #debugDrawError. aMenu addLine]. (self hasProperty: #errorOnStep) ifTrue: [aMenu add: 'start stepping again' translated action: #resumeAfterStepError. aMenu addLine]. aMenu add: 'inspect morph' translated action: #inspectInMorphic:. aMenu lastItem icon: Smalltalk ui icons smallInspectItIcon. aMenu add: 'inspect owner chain' translated action: #inspectOwnerChain. aMenu lastItem icon: Smalltalk ui icons smallInspectItIcon. self isMorphicModel ifTrue: [ aMenu add: 'inspect model' translated target: self model action: #inspect. aMenu lastItem icon: Smalltalk ui icons smallInspectItIcon ]. aMenu add: 'explore morph' translated target: self selector: #explore. aMenu lastItem icon: Smalltalk ui icons smallInspectItIcon. aMenu addLine. aMenu add: 'browse morph class' translated target: self selector: #browseHierarchy. (self isMorphicModel) ifTrue: [aMenu add: 'browse model class' target: self model selector: #browseHierarchy]. ^ aMenu! ! !Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:47'! resetExtension "reset the extension slot if it is not needed" (extension notNil and: [extension isDefault]) ifTrue: [extension := nil] ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 11/15/1998 23:42'! addMorphFront: aMorph fromWorldPosition: wp self addMorphFront: aMorph. aMorph position: (self transformFromWorld globalPointToLocal: wp)! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/21/2008 16:51'! passivate "Mark the receiver and submorphs as passive (background)." self submorphsDo: [:m | m passivate]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 14:52'! wantsRecolorHandle "Answer whether the receiver would like a recoloring halo handle to be put up. Since this handle also presently affords access to the property-sheet, it is presently always allowed, even though SketchMorphs don't like regular recoloring" ^ true ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/1/2000 10:16'! submorphIndexOf: aMorph "Assuming aMorph to be one of my submorphs, answer where it occurs in my submorph list" ^ submorphs indexOf: aMorph ifAbsent: [nil]! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:57'! beSticky "make the receiver sticky" self assureExtension sticky: true! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:35'! submorphsDo: aBlock submorphs do: aBlock! ! !Morph methodsFor: 'menu' stamp: 'marcus.denker 11/10/2008 10:04'! addModelYellowButtonItemsTo: aCustomMenu event: evt "Give my models a chance to add their context-menu items to aCustomMenu." self model ifNotNil: [:mod | mod addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: self hand: evt hand]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'MarcusDenker 12/11/2009 07:40'! navigateFocusBackward "Change the keyboard focus to the previous morph." self previousMorphWantingFocus ifNotNil: [:m | m takeKeyboardFocus] ! ! !Morph methodsFor: 'rotate scale and flex' stamp: 'ClementBera 7/30/2013 11:05'! rotationCenter: aPointOrNil "Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." aPointOrNil ifNil: [self removeProperty: #rotationCenter] ifNotNil:[self setProperty: #rotationCenter toValue: aPointOrNil] ! ! !Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:47'! otherProperties "answer the receiver's otherProperties" ^ extension ifNotNil: [extension otherProperties]! ! !Morph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 7/31/2013 14:10'! actAsExecutor "Prepare the receiver to act as executor for any resources associated with it" self breakDependents! ! !Morph methodsFor: 'accessing' stamp: 'StephaneDucasse 4/22/2012 16:35'! resistsRemoval: aBoolean "Set the receiver's resistsRemoval property as indicated" aBoolean ifTrue: [ self setProperty: #resistsRemoval toValue: true ] ifFalse: [ self removeProperty: #resistsRemoval ]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/29/2008 14:56'! paneColorOrNil "Answer the window's pane color or nil otherwise." ^self valueOfProperty: #paneColor ifAbsent: [ (self owner ifNil: [^nil]) paneColorOrNil]! ! !Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:38'! mouseLeaveDragging: evt "Handle a mouseLeaveLaden event, meaning the mouse just left my bounds with a button pressed or laden with submorphs. The default response is to let my eventHandler, if any, handle it; else to do nothing." self eventHandler ifNotNil: [self eventHandler mouseLeaveDragging: evt fromMorph: self]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 14:55'! balloonColor: aColor ^ self setProperty: #balloonColor toValue: aColor! ! !Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 17:14'! processEvent: anEvent "Process the given event using the default event dispatcher." ^self processEvent: anEvent using: self defaultEventDispatcher! ! !Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 19:03'! hasDropShadow: aBool aBool ifTrue:[self setProperty: #hasDropShadow toValue: true] ifFalse:[self removeProperty: #hasDropShadow]! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! rubberBandCells: aBool "Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow." self assureTableProperties rubberBandCells: aBool. self layoutChanged.! ! !Morph methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:09'! borderStyle: newStyle newStyle = self borderStyle ifFalse:[ (self canDrawBorder: newStyle) ifFalse:[ "Replace the suggested border with a simple one" ^self borderStyle: (BorderStyle width: newStyle width color: (newStyle trackColorFrom: self) color)]. self assureExtension. self extension borderStyle: newStyle. self changed].! ! !Morph methodsFor: 'event handling' stamp: 'KTT 6/1/2004 11:41'! keyUp: anEvent "Handle a key up event. The default response is to do nothing."! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'! boundsIn: referenceMorph "Return the receiver's bounds as seen by aMorphs coordinate frame" ^self bounds: self bounds in: referenceMorph! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:21'! layoutPolicy: aLayoutPolicy "Layout specific. Return the layout policy describing how children of the receiver should appear." self layoutPolicy == aLayoutPolicy ifTrue:[^self]. self assureExtension layoutPolicy: aLayoutPolicy. self layoutChanged.! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 8/5/2013 10:27'! on: aShortcut do: anAction ^ self bindKeyCombination: aShortcut toAction: anAction ! ! !Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 09:47'! hasProperty: aSymbol "Answer whether the receiver has the property named aSymbol" extension ifNil: [^ false]. ^extension hasProperty: aSymbol! ! !Morph methodsFor: 'accessing' stamp: 'di 2/6/2001 14:02'! borderWidthForRounding ^ self borderWidth! ! !Morph methodsFor: 'events-processing' stamp: 'GuillermoPolito 4/22/2012 17:20'! handleKeyDown: anEvent "System level event handling." anEvent wasHandled ifTrue:[^self]. (self handlesKeyDown: anEvent) ifFalse:[^self]. anEvent wasHandled: true. ^self keyDown: anEvent! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'tk 12/15/1998 14:23'! abandon "Like delete, but we really intend not to use this morph again. Clean up a few things." self delete! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'nice 1/5/2010 15:59'! morphsAt: aPoint unlocked: aBool do: aBlock "Evaluate aBlock with all the morphs starting at the receiver which appear at aPoint. If aBool is true take only visible, unlocked morphs into account." (self fullBounds containsPoint: aPoint) ifFalse:[^self]. (aBool and:[self isLocked or:[self visible not]]) ifTrue:[^self]. self submorphsDo:[:m| | tfm | tfm := m transformedFrom: self. m morphsAt: (tfm globalPointToLocal: aPoint) unlocked: aBool do: aBlock]. (self containsPoint: aPoint) ifTrue:[aBlock value: self].! ! !Morph methodsFor: 'structure' stamp: 'alain.plantec 6/19/2008 09:34'! containingWindow "Answer a window that contains the receiver" ^ self ownerThatIsA: SystemWindow! ! !Morph methodsFor: 'initialize' stamp: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color blue! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 22:01'! removedMorph: aMorph "Notify the receiver that aMorph was just removed from its children" ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/16/2009 11:15'! expandFullBoundsForDropShadow: aRectangle "Return an expanded rectangle for an eventual drop shadow." ^(aRectangle expandBy: self shadowOffsetRectangle) quickMerge: aRectangle! ! !Morph methodsFor: 'structure' stamp: 'ar 9/14/2000 16:48'! withAllOwnersDo: aBlock "Evaluate aBlock with the receiver and all of its owners" aBlock value: self. owner ifNotNil:[^owner withAllOwnersDo: aBlock].! ! !Morph methodsFor: 'structure' stamp: 'di 11/12/2000 16:13'! nearestOwnerThat: conditionBlock "Return the first enclosing morph for which aBlock evaluates to true, or nil if none" ^ self firstOwnerSuchThat: conditionBlock ! ! !Morph methodsFor: 'accessing' stamp: 'wiz 11/6/2005 17:10'! simplySetVisible: aBoolean "Set the receiver's visibility property. This mild circumlocution is because my TransfomationMorph #visible: method would also set the visibility flag of my flexee, which in this case is pointless because it's the flexee that calls this. This appears in morph as a backstop for morphs that don't inherit from TFMorph" self visible: aBoolean! ! !Morph methodsFor: 'drop shadows' stamp: 'ClementBera 9/30/2013 11:00'! shadowOffset: aPoint "Set the current shadow offset" (aPoint isNil or:[(aPoint x isZero) and: [ aPoint y isZero ]]) ifTrue:[ self removeProperty: #shadowOffset ] ifFalse:[ self setProperty: #shadowOffset toValue: aPoint ].! ! !Morph methodsFor: 'rounding' stamp: 'ar 12/25/2001 19:44'! toggleCornerRounding self cornerStyle == #rounded ifTrue: [self cornerStyle: #square] ifFalse: [self cornerStyle: #rounded]. self changed! ! !Morph methodsFor: 'creation' stamp: 'tk 2/6/1999 22:43'! asMorph ^ self! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/10/2007 13:40'! dialogWindow "Answer the receiver's dialog window." ^self ownerThatIsA: DialogWindow! ! !Morph methodsFor: '*Spec-Core' stamp: 'IgorStasenko 12/19/2012 17:40'! ensureLayoutAndAddMorph: aMorph aMorph layoutFrame ifNil: [ aMorph layoutFrame: LayoutFrame identity]. self addMorph: aMorph ! ! !Morph methodsFor: 'accessing' stamp: 'tk 12/16/1998 11:54'! userString "Do I have a text string to be searched on?" ^ nil! ! !Morph methodsFor: '*Tools-Inspecting' stamp: 'CamilloBruni 5/7/2013 23:37'! scaledIntoFormOfSize: aSmallInteger ^ self imageForm scaledIntoFormOfSize: aSmallInteger ! ! !Morph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 1/18/2012 18:46'! doubleClickTimeout: evt "Handle a double-click timeout event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing." ^ self eventHandler ifNotNil: [self eventHandler doubleClickTimeout: evt fromMorph: self].! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/4/97 14:30'! submorphsBehind: aMorph do: aBlock | behind | behind := false. submorphs do: [:m | m == aMorph ifTrue: [behind := true] ifFalse: [behind ifTrue: [aBlock value: m]]]. ! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'BenjaminVanRyseghem 2/20/2012 19:35'! detachAllKeymapCategories self kmDispatcher detachAllKeymapCategories! ! !Morph methodsFor: 'halos and balloon help' stamp: 'SeanDeNigris 1/29/2013 13:57'! balloonHelpTextForHandle: aHandle "Answer a string providing balloon help for the given halo handle" (aHandle eventHandler mouseSelectorsInclude: #doRecolor:with:) ifTrue: [^ 'Change color']. (aHandle eventHandler mouseSelectorsInclude: #mouseDownInDimissHandle:with:) ifTrue: [^ 'Remove from screen' translated]. #(#(#addFullHandles 'More halo handles') #(#chooseEmphasisOrAlignment 'Emphasis & alignment') #(#chooseFont 'Change font') #(#chooseNewGraphicFromHalo 'Choose a new graphic') #(#chooseStyle 'Change style') #(#doDebug:with: 'Debug') #(#doDirection:with: 'Choose forward direction') #(#doDup:with: 'Duplicate') #(#doMenu:with: 'Menu') #(#doGrab:with: 'Pick up') #(#mouseDownInCollapseHandle:with: 'Collapse') #(#mouseDownOnHelpHandle: 'Help') #(#prepareToTrackCenterOfRotation:with: 'Move object or set center of rotation') #(#startDrag:with: 'Move') #(#startGrow:with: 'Change size') #(#startRot:with: 'Rotate') #(#startScale:with: 'Change scale')#(#trackCenterOfRotation:with: 'Set center of rotation') ) do: [:pair | (aHandle eventHandler mouseSelectorsInclude: pair first) ifTrue: [^ pair last]]. ^ 'unknown halo handle' translated! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 15:22'! wantsKeyboardFocus "Answer whether the receiver would like keyboard focus in the general case (mouse action normally)." ^self takesKeyboardFocus and: [ self visible and: [self enabled]]! ! !Morph methodsFor: 'accessing' stamp: 'RAA 2/19/2001 17:38'! toggleLocked self lock: self isLocked not! ! !Morph methodsFor: 'debug and other' stamp: 'CamilloBruni 5/29/2012 16:51'! resumeAfterDrawError self changed. self removeProperty:#errorOnDraw. self removeProperty:#drawError. self changed.! ! !Morph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 9/2/2012 21:44'! fullDrawOnAthensCanvas: anAthensCanvas "Draw the full Morphic structure on the given Canvas" self visible ifFalse: [^ self]. (anAthensCanvas isVisible: self fullBounds) ifFalse: [^self]. (self hasProperty: #errorOnDraw) ifTrue: [^self "drawErrorOn: aCanvas" ]. (anAthensCanvas isVisible: self bounds) ifTrue: [ anAthensCanvas draw: self ]. submorphs isEmpty ifTrue: [^self]. self clipSubmorphs ifTrue: [ | clip | clip := self clippingBounds. anAthensCanvas clipBy: clip during: [ submorphs reverseDo: [:m | anAthensCanvas fullDrawMorph: m ] ] ] ifFalse: [ submorphs reverseDo: [:m | anAthensCanvas fullDrawMorph: m ] ] ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/6/2007 15:35'! focusIndicatorMorph "Answer the focus indicator morph for the receiver." ^self theme focusIndicatorMorphFor: self! ! !Morph methodsFor: 'announcements' stamp: 'ThierryGoubier 1/8/2014 14:36'! announceOpened self doAnnounce: (MorphOpened morph: self). self submorphs do: #announceOpened! ! !Morph methodsFor: 'events-processing' stamp: 'AlainPlantec 12/1/2010 09:33'! handleDropMorph: anEvent "Handle a dropping morph." | aMorph localPt | aMorph := anEvent contents. "Do a symmetric check if both morphs like each other" ((self wantsDroppedMorph: aMorph event: anEvent) "I want her" and: [aMorph wantsToBeDroppedInto: self]) "she wants me" ifFalse: [^ self]. anEvent wasHandled: true. "Transform the morph into the receiver's coordinate frame. This is currently incomplete since it only takes the offset into account where it really should take the entire transform." localPt := (self transformedFrom: anEvent hand world) "full transform down" globalPointToLocal: aMorph referencePosition. aMorph referencePosition: localPt. self acceptDroppingMorph: aMorph event: anEvent. aMorph justDroppedInto: self event: anEvent. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 12/19/2009 23:41'! wantsDirectionHandles: aBool self setProperty: #wantsDirectionHandles toValue: aBool ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/16/2008 16:57'! tabKey: event "Check for tab key activity and change focus as appropriate." event controlKeyPressed ifFalse: [ event keyCharacter = Character tab ifTrue: [ event shiftPressed ifTrue: [self navigateFocusBackward] ifFalse: [self navigateFocusForward]. ^true]]. ^false! ! !Morph methodsFor: 'structure' stamp: 'RAA 6/13/2000 15:01'! primaryHand | outer | outer := self outermostWorldMorph ifNil: [^ nil]. ^ outer activeHand ifNil: [outer firstHand]! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! reverseTableCells: aBool "Layout specific. This property describes if the cells should be treated in reverse order of submorphs." self assureTableProperties reverseTableCells: aBool. self layoutChanged.! ! !Morph methodsFor: 'meta-actions' stamp: 'MarcusDenker 7/9/2012 15:31'! dismissMorph "This is called from an explicit halo destroy/delete action." | w | w := self world ifNil:[^self]. w deleteAllHalos; stopStepping: self. self delete! ! !Morph methodsFor: 'Morphic-Base-Widgets' stamp: 'BenjaminVanRyseghem 5/21/2013 18:02'! listRenderOn: aCanvas atRow: aRow bounds: drawBounds color: drawColor backgroundColor: backgroundColor from: aMorph self bounds: drawBounds. self fullDrawOn: aCanvas. (aMorph submorphs includes: self) ifFalse: [ aMorph addMorph: self ]! ! !Morph methodsFor: 'event handling' stamp: 'GuillermoPolito 7/24/2012 13:08'! on: eventName send: selector to: recipient withValue: value "NOTE: selector must take 3 arguments, of which value will be the *** FIRST ***" self eventHandler ifNil: [self eventHandler: MorphicEventHandler new]. self eventHandler on: eventName send: selector to: recipient withValue: value ! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/26/2001 16:16'! setBorderStyle: aSymbol "Set the border style of my costume" | aStyle | aStyle := self borderStyleForSymbol: aSymbol. aStyle ifNil: [^ self]. (self canDrawBorder: aStyle) ifTrue: [self borderStyle: aStyle]! ! !Morph methodsFor: 'copying' stamp: 'tk 1/6/1999 17:27'! veryDeepCopyWith: deepCopier "Copy me and the entire tree of objects I point to. An object in the tree twice is copied once, and both references point to him. deepCopier holds a dictionary of objects we have seen. See veryDeepInner:, veryDeepFixupWith:" self prepareToBeSaved. ^ super veryDeepCopyWith: deepCopier! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:41'! disableDragNDrop self enableDragNDrop: false! ! !Morph methodsFor: 'geometry' stamp: 'MarianoMartinezPeck 8/24/2012 15:26'! extent: aPoint |newExtent| newExtent := aPoint rounded. (bounds extent closeTo: newExtent) ifTrue: [^ self]. self changed. bounds := (bounds topLeft extent: newExtent). self layoutChanged. self changed. ! ! !Morph methodsFor: 'classification' stamp: ''! isHandMorph ^ false! ! !Morph methodsFor: 'geometry' stamp: 'di 6/12/97 11:07'! topLeft ^ bounds topLeft! ! !Morph methodsFor: 'drawing' stamp: 'md 2/27/2006 08:49'! visible "answer whether the receiver is visible" extension ifNil: [^ true]. ^ extension visible! ! !Morph methodsFor: 'Morphic-Base-Widgets' stamp: 'BenjaminVanRyseghem 7/25/2012 11:42'! heightToDisplayInList: aList ^ self minExtent y! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:52'! minHeight "answer the receiver's minHeight" ^ self valueOfProperty: #minHeight ifAbsent: [2]! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:56'! assureLayoutProperties | props | props := self layoutProperties. props == self ifTrue:[props := nil]. props ifNil:[ props := LayoutProperties new initializeFrom: self. self layoutProperties: props]. ^props! ! !Morph methodsFor: 'rotate scale and flex' stamp: 'nk 9/4/2004 11:00'! scale: newScale "Backstop for morphs that don't have to do something special to set their scale" ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/18/2006 11:58'! adoptPaneColor "Adopt our pane color." self adoptPaneColor: self paneColor! ! !Morph methodsFor: '*Morphic-Base' stamp: 'MarcusDenker 10/21/2013 14:21'! defaultLabel "Answer the default label to be used" ^ self printString truncateTo: 40! ! !Morph methodsFor: 'events-accessing' stamp: 'gvc 9/11/2009 17:43'! actionMap "Answer an action map" ^self updateableActionMap! ! !Morph methodsFor: 'event handling' stamp: 'CamilloBruni 8/1/2012 16:04'! doubleClick: evt "Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing." ^ self eventHandler ifNotNil: [self eventHandler doubleClick: evt fromMorph: self].! ! !Morph methodsFor: 'layout-properties' stamp: 'dgd 2/16/2003 20:02'! spaceFillWeight "Layout specific. This property describes the relative weight that should be given to the receiver when extra space is distributed between different #spaceFill cells." ^ self valueOfProperty: #spaceFillWeight ifAbsent: [1]! ! !Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:34'! root "Return the root of the composite morph containing the receiver. The owner of the root is either nil, a WorldMorph, or a HandMorph. If the receiver's owner is nil, the root is the receiver itself. This method always returns a morph." (owner isNil or: [owner isWorldOrHandMorph]) ifTrue: [^self]. ^owner root! ! !Morph methodsFor: 'geometry' stamp: 'ar 9/27/2000 14:04'! referencePosition: aPosition "Move the receiver to match its reference position with aPosition" | newPos intPos | newPos := self position + (aPosition - self referencePosition). intPos := newPos asIntegerPoint. newPos = intPos ifTrue:[self position: intPos] ifFalse:[self position: newPos].! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:10'! topLeft: aPoint " Move me so that my top left corner is at aPoint. My extent (width & height) are unchanged " self position: aPoint ! ! !Morph methodsFor: 'menus' stamp: 'sw 2/3/2000 00:12'! adjustedCenter: c "Set the receiver's position based on the #adjustedCenter protocol for adhereToEdge. By default this simply sets the receiver's center. Though there are (at its inception anyway) no other implementors of this method, it is required in use with the #adhereToEdge when the centering of a submorph is to be with reference to a rectangle other than the receiver's center." self center: c! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 9/6/2004 14:17'! mainDockingBars "Answer the receiver's main dockingBars" ^ self dockingBars select: [:each | each hasProperty: #mainDockingBarTimeStamp]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:51'! enableDrop: aBoolean self setProperty: #dropEnabled toValue: aBoolean! ! !Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:53'! eventHandler "answer the receiver's eventHandler" ^ extension ifNotNil: [extension eventHandler] ! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'tk 10/20/2000 13:13'! submorphBefore "Return the submorph after (behind) me, or nil" | ii | owner ifNil: [^ nil]. ^ (ii := owner submorphIndexOf: self) = 1 ifTrue: [nil] ifFalse: [owner submorphs at: ii-1]. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:44'! addMorph: newMorph behind: aMorph "Add a morph to the list of submorphs behind the specified morph" ^self privateAddMorph: newMorph atIndex: (submorphs indexOf: aMorph) + 1. ! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:48'! cellPositioningString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self cellPositioning! ! !Morph methodsFor: 'printing' stamp: 'jm 5/28/1998 18:00'! printStructureOn: aStream indent: tabCount tabCount timesRepeat: [aStream tab]. self printOn: aStream. aStream cr. self submorphsDo: [:m | m printStructureOn: aStream indent: tabCount + 1]. ! ! !Morph methodsFor: 'geometry testing' stamp: 'MarcusDenker 10/21/2013 14:22'! fullContainsPoint: aPoint (self fullBounds containsPoint: aPoint) ifFalse: [ ^ false ]. "quick elimination" (self containsPoint: aPoint) ifTrue: [ ^ true ]. "quick acceptance" ^ submorphs anySatisfy: [ :m | m fullContainsPoint: aPoint ]! ! !Morph methodsFor: 'layout' stamp: 'nice 1/5/2010 15:59'! submorphBounds "Private. Compute the actual full bounds of the receiver" | box | submorphs do: [:m | | subBox | (m visible) ifTrue: [ subBox := m fullBounds. box ifNil:[box := subBox copy] ifNotNil:[box := box quickMerge: subBox]]]. box ifNil:[^self bounds]. "e.g., having submorphs but not visible" ^ box origin asIntegerPoint corner: box corner asIntegerPoint ! ! !Morph methodsFor: 'layout' stamp: 'ClementBera 7/30/2013 11:04'! minHeight: aNumber aNumber ifNil: [self removeProperty: #minHeight] ifNotNil: [self setProperty: #minHeight toValue: aNumber]. self layoutChanged! ! !Morph methodsFor: 'menus' stamp: 'DamienCassou 9/29/2009 13:01'! exportAsJPEG "Export the receiver's image as a JPEG" | fName | fName := UIManager default request: 'Please enter the name' translated initialAnswer: self externalName,'.jpeg'. fName isEmptyOrNil ifTrue: [^ self]. self imageForm writeJPEGfileNamed: fName! ! !Morph methodsFor: 'private' stamp: ''! privateSubmorphs: aCollection "Private!! Should only be used by methods that maintain the ower/submorph invariant." submorphs := aCollection.! ! !Morph methodsFor: 'events-processing' stamp: 'BenjaminVanRyseghem 1/18/2012 18:58'! handleMouseLeave: anEvent "System level event handling." anEvent hand removePendingBalloonFor: self. anEvent isDraggingEvent ifTrue:[ (self handlesMouseOverDragging: anEvent) ifTrue:[ anEvent wasHandled: true. self mouseLeaveDragging: anEvent]. ^ self eventHandler ifNotNil: [:handler | handler mouseLeave: anEvent fromMorph: self ]]. (self handlesMouseOver: anEvent) ifTrue:[ anEvent wasHandled: true. self mouseLeave: anEvent ]. ^ self eventHandler ifNotNil: [:handler | handler mouseLeave: anEvent fromMorph: self ]! ! !Morph methodsFor: 'meta-actions' stamp: 'BernardoContreras 1/18/2012 23:06'! showActions "Put up a message list browser of all the code that this morph would run for mouseUp, mouseDown, mouseMove, mouseEnter, mouseLeave, and mouseLinger." | list cls selector adder | list := SortedCollection new. adder := [:mrClass :mrSel | list add: (RGMethodDefinition realClass: mrClass selector: mrSel)]. "the eventHandler" self eventHandler ifNotNil: [list := self eventHandler methodRefList. (self eventHandler handlesMouseDown: nil) ifFalse: [adder value: HandMorph value: #grabMorph:]]. "If not those, then non-default raw events" #(#keyStroke: #mouseDown: #mouseEnter: #mouseLeave: #mouseMove: #mouseUp: #doButtonAction ) do: [:sel | cls := self class whichClassIncludesSelector: sel. cls ifNotNil: ["want more than default behavior" cls == Morph ifFalse: [adder value: cls value: sel]]]. "The mechanism on a Button" (self respondsTo: #actionSelector) ifTrue: ["A button" selector := self actionSelector. cls := self target class whichClassIncludesSelector: selector. cls ifNotNil: ["want more than default behavior" cls == Morph ifFalse: [adder value: cls value: selector]]]. Smalltalk tools messageList openMessageList: list name: 'Actions of ' , self printString autoSelect: ''! ! !Morph methodsFor: 'drawing' stamp: 'IgorStasenko 7/18/2011 17:48'! drawOn: aCanvas aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle! ! !Morph methodsFor: 'private' stamp: 'MarcusDenker 10/21/2013 14:22'! privateAddMorph: aMorph atIndex: index | oldIndex myWorld itsWorld oldOwner | (index between: 1 and: submorphs size + 1) ifFalse: [ ^ self error: 'index out of range' ]. myWorld := self world. oldOwner := aMorph owner. (oldOwner == self and: [ (oldIndex := submorphs indexOf: aMorph) > 0 ]) ifTrue: [ "aMorph's position changes within in the submorph chain" oldIndex < index ifTrue: [ "moving aMorph to back" submorphs replaceFrom: oldIndex to: index - 2 with: submorphs startingAt: oldIndex + 1. submorphs at: index - 1 put: aMorph ] ifFalse: [ "moving aMorph to front" oldIndex - 1 to: index by: -1 do: [ :i | submorphs at: i + 1 put: (submorphs at: i) ]. submorphs at: index put: aMorph ] ] ifFalse: [ "adding a new morph" oldOwner ifNotNil: [ itsWorld := aMorph world. itsWorld ifNotNil: [ self privateInvalidateMorph: aMorph ]. itsWorld == myWorld ifFalse: [ aMorph outOfWorld: itsWorld ]. oldOwner privateRemove: aMorph. oldOwner removedMorph: aMorph ]. aMorph privateOwner: self. submorphs := submorphs copyReplaceFrom: index to: index - 1 with: (Array with: aMorph). itsWorld == myWorld ifFalse: [ aMorph intoWorld: myWorld ] ]. myWorld ifNotNil: [ self privateInvalidateMorph: aMorph ]. self layoutChanged. oldOwner == self ifFalse: [ self addedMorph: aMorph. aMorph noteNewOwner: self ]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 6/24/2012 23:27'! heightToDisplayInTree: aTree ^ self minExtent y! ! !Morph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:50'! invalidRect: damageRect ^self invalidRect: damageRect from: self! ! !Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 12:33'! unlock self lock: false! ! !Morph methodsFor: 'meta-actions' stamp: 'SeanDeNigris 4/24/2012 19:49'! handlerForBlueButtonDown: anEvent "Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event. Note: Halos handle blue button events themselves so we will only be asked if there is currently no halo on top of us. Check whtehr halods are enabled (for deployment)." self wantsHaloFromClick ifFalse:[^nil]. self class cycleHalosBothDirections ifTrue: [ anEvent handler ifNil:[^self]. (anEvent handler isKindOf: PasteUpMorph) ifTrue:[^self] ]. (anEvent shiftPressed) ifFalse:[^nil] "let outer guy have it" ifTrue:[^self] "let me have it" ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'di 10/18/2004 21:50'! removeMorph: aMorph "Remove the given morph from my submorphs" | aWorld | aMorph owner == self ifFalse:[^self]. aWorld := self world. aWorld ifNotNil:[ aMorph outOfWorld: aWorld. self privateInvalidateMorph: aMorph. ]. self privateRemove: aMorph. aMorph privateOwner: nil. self removedMorph: aMorph. ! ! !Morph methodsFor: 'drawing' stamp: 'LC 5/18/2000 08:51'! highlightForMouseDown self highlightForMouseDown: true! ! !Morph methodsFor: 'private' stamp: ''! privateOwner: aMorph "Private!! Should only be used by methods that maintain the ower/submorph invariant." owner := aMorph.! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'efc 8/6/2005 11:35'! submorphs "This method returns my actual submorphs collection. Modifying the collection directly could be dangerous; make a copy if you need to alter it." ^ submorphs ! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! changeRubberBandCells self rubberBandCells: self rubberBandCells not.! ! !Morph methodsFor: 'drawing' stamp: 'IgorStasenko 12/22/2012 03:14'! drawSubmorphsOn: aCanvas "Display submorphs back to front" | drawBlock | submorphs isEmpty ifTrue: [^self]. drawBlock := [:canvas | submorphs reverseDo: [:m | canvas fullDrawMorph: m]]. self clipSubmorphs ifTrue: [aCanvas clipBy: (aCanvas clipRect intersect: self clippingBounds ifNone: [ ^ self ]) during: drawBlock] ifFalse: [drawBlock value: aCanvas]! ! !Morph methodsFor: 'drop shadows' stamp: 'dgd 2/16/2003 21:42'! hasDropShadow "answer whether the receiver has DropShadow" ^ self valueOfProperty: #hasDropShadow ifAbsent: [false]! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:03'! pointInWorld: aPoint ^self point: aPoint in: self world! ! !Morph methodsFor: 'drawing' stamp: 'ar 10/29/2000 19:22'! clipLayoutCells: aBool "Drawing/layout specific. If this property is set, clip the submorphs of the receiver by its cell bounds." aBool == false ifTrue:[self removeProperty: #clipLayoutCells] ifFalse:[self setProperty: #clipLayoutCells toValue: aBool]. self changed.! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:52'! dropHighlightColor ^ Color blue! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'ClementBera 10/3/2013 10:29'! submorphThat: block1 ifNone: block2 ^ submorphs detect: [:m | (block1 value: m) == true] ifNone: block2 ! ! !Morph methodsFor: 'accessing' stamp: 'MarcusDenker 10/3/2013 23:47'! highlightColor ^ (self valueOfProperty: #highlightColor) ifNotNil: [:val | val ifNil: [self error: 'nil highlightColor']] ifNil: [owner ifNil: [self color] ifNotNil: [owner highlightColor]]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 14:50'! okayToBrownDragEasily "Answer whether it it okay for the receiver to be brown-dragged easily -- i.e. repositioned within its container without extracting it. At present this is just a hook -- nobody declines." ^ true " ^ (self topRendererOrSelf owner isKindOf: PasteUpMorph) and: [self layoutPolicy isNil]"! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'BenjaminVanRyseghem 2/20/2012 19:23'! detachKeymapCategory: aCategoryName self kmDispatcher detachKeymapCategory: aCategoryName.! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'dgd 2/22/2003 14:30'! comeToFront | outerMorph | outerMorph := self topRendererOrSelf. (outerMorph owner isNil or: [outerMorph owner hasSubmorphs not]) ifTrue: [^self]. outerMorph owner firstSubmorph == outerMorph ifFalse: [outerMorph owner addMorphFront: outerMorph]! ! !Morph methodsFor: 'change reporting' stamp: 'sw 9/10/1998 08:18'! colorChangedForSubmorph: aSubmorph "The color associated with aSubmorph was changed through the UI; react if needed"! ! !Morph methodsFor: 'geometry' stamp: 'sw 6/4/2000 22:00'! minimumExtent: aPoint "Remember a minimumExtent, for possible future use" self setProperty: #minimumExtent toValue: aPoint ! ! !Morph methodsFor: 'private' stamp: ''! privateBounds: boundsRect "Private!! Use position: and/or extent: instead." fullBounds := nil. bounds := boundsRect.! ! !Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:16'! programmedMouseEnter: anEvent for: aMorph aMorph addMouseActionIndicatorsWidth: 10 color: (Color blue alpha: 0.3). ! ! !Morph methodsFor: 'drop shadows' stamp: 'ar 11/12/2000 18:58'! shadowPoint: newPoint self changed. self shadowOffset: newPoint - self center // 5. fullBounds ifNotNil:[fullBounds := self privateFullBounds]. self changed.! ! !Morph methodsFor: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:49'! hasClipLayoutCellsString ^ (self clipLayoutCells) -> 'clip to cell size' translated! ! !Morph methodsFor: 'event handling' stamp: 'mir 5/23/2000 17:43'! startDrag: evt "Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing." self eventHandler ifNotNil: [self eventHandler startDrag: evt fromMorph: self].! ! !Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:15'! maybeAddCollapseItemTo: aMenu "If appropriate, add a collapse item to the given menu" | anOwner | (anOwner := self topRendererOrSelf owner) ifNotNil: [anOwner isWorldMorph ifTrue: [aMenu add: 'collapse' translated target: self action: #collapse]]! ! !Morph methodsFor: 'geometry' stamp: ''! width ^ bounds width! ! !Morph methodsFor: 'accessing' stamp: 'sw 8/15/97 23:59'! unlockContents self submorphsDo: [:m | m unlock]! ! !Morph methodsFor: 'wiw support' stamp: 'nice 1/5/2010 15:59'! addMorphInFrontOfLayer: aMorph | targetLayer | targetLayer := aMorph morphicLayerNumberWithin: self. submorphs do: [ :each | | layerHere | each == aMorph ifTrue: [^self]. layerHere := each morphicLayerNumberWithin: self. "the <= is the difference - it insures we go to the front of our layer" targetLayer <= layerHere ifTrue: [ ^self addMorph: aMorph inFrontOf: each ]. ]. self addMorphBack: aMorph. ! ! !Morph methodsFor: 'accessing' stamp: 'nk 4/15/2004 07:50'! doesBevels "To return true means that this object can show bevelled borders, and therefore can accept, eg, #raised or #inset as valid borderColors. Must be overridden by subclasses that do not support bevelled borders." ^ false! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'! changeNoLayout self layoutPolicy ifNil:[^self]. "already no layout" self layoutPolicy: nil. self layoutChanged.! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'nice 1/5/2010 15:59'! submorphNamed: aName ifNone: aBlock "Find the first submorph with this name, or a button with an action selector of that name" self submorphs do: [:button | | sub args | (button respondsTo: #actionSelector) ifTrue: [button actionSelector == aName ifTrue: [^button]]. ((button respondsTo: #arguments) and: [(args := button arguments) notNil]) ifTrue: [(args at: 2 ifAbsent: [nil]) == aName ifTrue: [^button]]. (button isAlignmentMorph) ifTrue: [(sub := button submorphNamed: aName ifNone: [nil]) ifNotNil: [^sub]]]. ^aBlock value! ! !Morph methodsFor: 'debug and other' stamp: 'nice 1/5/2010 15:59'! allStringsAfter: aSubmorph "return an OrderedCollection of strings of text in my submorphs. If aSubmorph is non-nil, begin with that container." | list ok | list := OrderedCollection new. ok := aSubmorph isNil. self allMorphsDo: [:sub | | string | ok ifFalse: [ok := sub == aSubmorph]. "and do this one too" ok ifTrue: [(string := sub userString) ifNotNil: [string isString ifTrue: [list add: string] ifFalse: [list addAll: string]]]]. ^list! ! !Morph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/3/2013 10:58'! mouseDown: evt "Handle a mouse down event. The default response is to let my eventHandler, if any, handle it." self eventHandler ifNotNil: [self eventHandler mouseDown: evt fromMorph: self] ! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'tk 10/20/2000 13:12'! submorphAfter "Return the submorph after (behind) me, or nil" | ii | owner ifNil: [^ nil]. ^ (ii := owner submorphIndexOf: self) = owner submorphs size ifTrue: [nil] ifFalse: [owner submorphs at: ii+1]. ! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/4/97 14:29'! submorphsInFrontOf: aMorph do: aBlock | behind | behind := false. submorphs do: [:m | m == aMorph ifTrue: [behind := true] ifFalse: [behind ifFalse: [aBlock value: m]]]. ! ! !Morph methodsFor: 'event handling' stamp: 'ar 10/22/2000 17:06'! handlesMouseStillDown: evt "Return true if the receiver wants to get repeated #mouseStillDown: messages between #mouseDown: and #mouseUp" self eventHandler ifNotNil: [^ self eventHandler handlesMouseStillDown: evt]. ^ false ! ! !Morph methodsFor: 'menus' stamp: 'ar 11/2/2000 15:04'! changeDragAndDrop ^self enableDragNDrop: self dragNDropEnabled not! ! !Morph methodsFor: 'debug and other' stamp: 'CamilloBruni 5/29/2012 17:17'! debugDrawError (self valueOfProperty: #drawError) debug.! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 11:26'! themeChanged "The current theme has changed. Update any dependent visual aspects." self submorphsDo: [:m | m themeChanged]. self changed! ! !Morph methodsFor: 'event handling' stamp: 'AlainPlantec 12/19/2009 23:25'! tabAmongFields ^ self theme settings tabAmongFields or: [self hasProperty: #tabAmongFields] ! ! !Morph methodsFor: 'menus' stamp: 'marcus.denker 11/19/2008 13:44'! addToggleItemsToHaloMenu: aMenu "Add standard true/false-checkbox items to the memu" #( (resistsRemovalString toggleResistsRemoval 'whether I should be reistant to easy deletion via the pink X handle' true) (stickinessString toggleStickiness 'whether I should be resistant to a drag done by mousing down on me' true) (lockedString lockUnlockMorph 'when "locked", I am inert to all user interactions' true) (hasClipSubmorphsString changeClipSubmorphs 'whether the parts of objects within me that are outside my bounds should be masked.' false) (hasDirectionHandlesString changeDirectionHandles 'whether direction handles are shown with the halo' false) (hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me' false) ) do: [:each | aMenu addUpdating: each first action: each second. aMenu balloonTextForLastItem: each third translated]. self couldHaveRoundedCorners ifTrue: [aMenu addUpdating: #roundedCornersString action: #toggleCornerRounding. aMenu balloonTextForLastItem: 'whether my corners should be rounded' translated]! ! !Morph methodsFor: 'testing' stamp: 'WilliamSix 1/14/2013 19:43'! shouldFlex ^ self isFlexMorph.! ! !Morph methodsFor: 'visual properties' stamp: 'gvc 9/11/2009 16:35'! fillStyle "Return the current fillStyle of the receiver." ^extension ifNil: [^color] ifNotNil: [extension fillStyle ifNil: [color]]! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:57'! hResizing "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are: #rigid - do not resize the receiver #spaceFill - resize to fill owner's available space #shrinkWrap - resize to fit children " | props | props := self layoutProperties. ^props ifNil:[#rigid] ifNotNil:[props hResizing].! ! !Morph methodsFor: 'utilities' stamp: 'sw 10/23/1998 11:50'! transparentSpacerOfSize: aPoint ^ (Morph new extent: aPoint) color: Color transparent! ! !Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! addAlarm: aSelector at: scheduledTime "Add an alarm (that is an action to be executed once) with the given set of parameters" ^self addAlarm: aSelector withArguments: #() at: scheduledTime! ! !Morph methodsFor: 'printing' stamp: 'bf 7/17/2003 12:53'! clipText "Copy the text in the receiver or in its submorphs to the clipboard" | content | "My own text" content := self userString. "Or in my submorphs" content ifNil: [ | list | list := self allStringsAfter: nil. list notEmpty ifTrue: [ content := String streamContents: [:stream | list do: [:each | stream nextPutAll: each; cr]]]]. "Did we find something?" content ifNil: [self flash "provide feedback"] ifNotNil: [Clipboard clipboardText: content].! ! !Morph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/1/2013 13:47'! asSpecAdapter ^ MorphicGenericAdapter morph: self! ! !Morph methodsFor: 'meta-actions' stamp: 'ar 10/6/2000 16:37'! grabMorph: evt evt hand grabMorph: self! ! !Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 08:50'! valueOfProperty: aSymbol ifAbsent: aBlock "if the receiver possesses a property of the given name, answer its value. If not then evaluate aBlock and answer the result of this block evaluation" ^ extension ifNotNil: [extension valueOfProperty: aSymbol ifAbsent: aBlock] ifNil: [aBlock value]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:41'! enableDragNDrop self enableDragNDrop: true! ! !Morph methodsFor: 'event handling' stamp: 'tk 9/6/2000 12:42'! click "Pretend the user clicked on me." (self handlesMouseDown: nil) ifTrue: [ self mouseDown: nil. self mouseUp: nil].! ! !Morph methodsFor: 'copying' stamp: 'pmm 3/13/2010 11:32'! veryDeepInner: deepCopier "The inner loop, so it can be overridden when a field should not be traced." "super veryDeepInner: deepCopier. know Object has no inst vars" bounds := bounds shallowCopy. "Points are shared with original" "owner := owner. special, see veryDeepFixupWith:" submorphs := submorphs veryDeepCopyWith: deepCopier. "each submorph's fixup will install me as the owner" "fullBounds := fullBounds. fullBounds is shared with original!!" color := color veryDeepCopyWith: deepCopier. "color, if simple, will return self. may be complex" extension := (extension veryDeepCopyWith: deepCopier)! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 12/12/2009 09:54'! addWorldHandlesTo: aHaloMorph box: box aHaloMorph haloBox: box. HaloMorph haloSpecificationsForWorld do: [:aSpec | aHaloMorph perform: aSpec addHandleSelector with: aSpec]. aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! ! !Morph methodsFor: 'accessing-backstop' stamp: 'wiz 2/14/2006 19:02'! target: aMorph "Morphs with targets will override. This backstop does nothing." "This is here because targeting meta-actions are taken at morph level. Do not remove."! ! !Morph methodsFor: 'event handling' stamp: 'sw 8/29/2000 14:57'! wouldAcceptKeyboardFocusUponTab "Answer whether the receiver is in the running as the new keyboard focus if the tab key were hit at a meta level. This provides the leverage for tabbing among fields of a card, for example." ^ false! ! !Morph methodsFor: 'drawing' stamp: 'StephaneDucasse 4/22/2012 16:50'! hasClipSubmorphsString "Answer a string that represents the clip-submophs checkbox" ^ (self clipSubmorphs) -> 'provide clipping' translated! ! !Morph methodsFor: 'drawing' stamp: 'panda 4/28/2000 11:59'! drawDropHighlightOn: aCanvas self highlightedForDrop ifTrue: [ aCanvas frameRectangle: self fullBounds color: self dropHighlightColor].! ! !Morph methodsFor: 'drawing' stamp: 'ar 10/29/2000 19:16'! clippingBounds "Return the bounds to which any submorphs should be clipped if the property is set" ^self innerBounds! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 6/24/2012 23:39'! treeRenderOn: aCanvas bounds: drawBounds color: drawColor font: aFont from: aMorph self bounds: drawBounds. aMorph addMorphBack: self. ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/11/2006 09:38'! modalUnlockFrom: aSystemWindow "Unlock the receiver as a modal owner of the given window." self unlock! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:06'! hResizing: aSymbol "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are: #rigid - do not resize the receiver #spaceFill - resize to fill owner's available space #shrinkWrap - resize to fit children " self assureLayoutProperties hResizing: aSymbol. self layoutChanged. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 12/12/2009 07:10'! transferHalo: event from: formerHaloOwner "Progressively transfer the halo to the next likely recipient" | localEvt w target | self flag: #workAround. "For halo's distinction between 'target' and 'innerTarget' we need to bypass any renderers." (formerHaloOwner == self and:[self isRenderer and:[self wantsHaloFromClick not]]) ifTrue:[ event shiftPressed ifTrue:[ target := owner. localEvt := event transformedBy: (self transformedFrom: owner). ] ifFalse:[ target := self renderedMorph. localEvt := event transformedBy: (target transformedFrom: self). ]. ^target transferHalo: localEvt from: target]. " formerHaloOwner == self ifTrue:[^ self removeHalo]." "Never transfer halo to top-most world" (self isWorldMorph and:[owner isNil]) ifFalse:[ (self wantsHaloFromClick and:[formerHaloOwner ~~ self]) ifTrue:[^self addHalo: event from: formerHaloOwner]]. event shiftPressed ifTrue:[ "Pass it outwards" owner ifNotNil:[^owner transferHalo: event from: formerHaloOwner]. "We're at the top level; throw the event back in to find recipient" formerHaloOwner removeHalo. ^self processEvent: event copy resetHandlerFields. ]. self submorphsDo:[:m| localEvt := event transformedBy: (m transformedFrom: self). (m fullContainsPoint: localEvt position) ifTrue:[^m transferHalo: event from: formerHaloOwner]. ]. "We're at the bottom most level; throw the event back up to the root to find recipient" formerHaloOwner removeHalo. (w := self world) ifNil: [ ^self ]. localEvt := event transformedBy: (self transformedFrom: w) inverseTransformation. ^ w processEvent: localEvt resetHandlerFields. ! ! !Morph methodsFor: 'printing' stamp: 'StephaneDucasse 8/2/2011 22:46'! colorString: aColor aColor ifNil: [ ^'nil' ]. ^aColor name ifNil: [ aColor storeString ] ifNotNil: [ :colorName | 'Color ', colorName ]! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/10/2003 18:31'! privateDelete "Remove the receiver as a submorph of its owner" owner ifNotNil:[owner removeMorph: self].! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/28/2000 17:54'! hasHalo: aBool aBool ifTrue:[self setProperty: #hasHalo toValue: true] ifFalse:[self removeProperty: #hasHalo]! ! !Morph methodsFor: 'geometry' stamp: 'sw 10/9/1998 08:56'! positionSubmorphs self submorphsDo: [:aMorph | aMorph snapToEdgeIfAppropriate]! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! changeListDirection: aSymbol | listDir wrapDir | self listDirection: aSymbol. (self wrapDirection == #none) ifTrue:[^self]. "otherwise automatically keep a valid table layout" listDir := self listDirection. wrapDir := self wrapDirection. (listDir == #leftToRight or:[listDir == #rightToLeft]) ifTrue:[ wrapDir == #leftToRight ifTrue:[^self wrapDirection: #topToBottom]. wrapDir == #rightToLeft ifTrue:[^self wrapDirection: #bottomToTop]. ] ifFalse:[ wrapDir == #topToBottom ifTrue:[^self wrapDirection: #leftToRight]. wrapDir == #bottomToTop ifTrue:[^self wrapDirection: #rightToLeft]. ]. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:54'! addMorph: newMorph after: aMorph "Add the given morph as one of my submorphs, inserting it after anotherMorph" ^self privateAddMorph: newMorph atIndex: (submorphs indexOf: aMorph)+1! ! !Morph methodsFor: 'debug and other' stamp: 'alain.plantec 2/6/2009 15:31'! addMouseUpAction | codeToRun oldCode | oldCode := self valueOfProperty: #mouseUpCodeToRun ifAbsent: ['']. codeToRun := UIManager default request: 'MouseUp expression:' translated initialAnswer: oldCode. self addMouseUpActionWith: codeToRun! ! !Morph methodsFor: 'rounding' stamp: 'ar 12/22/2001 22:45'! wantsRoundedCorners "Return true if the receiver wants its corners rounded" ^ self cornerStyle == #rounded! ! !Morph methodsFor: 'accessing - properties' stamp: 'md 2/27/2006 08:49'! valueOfProperty: aSymbol ifPresentDo: aBlock "If the receiver has a property of the given name, evaluate aBlock on behalf of the value of that property" extension ifNil: [^ self]. ^ aBlock value: (extension valueOfProperty: aSymbol ifAbsent: [^ self])! ! !Morph methodsFor: 'menu' stamp: 'AlainPlantec 12/10/2009 13:05'! wantsYellowButtonMenu "Answer true if the receiver wants a yellow button menu" self valueOfProperty: #wantsYellowButtonMenu ifPresentDo: [:value | ^ value]. self isInSystemWindow ifTrue: [^ false]. ^ self defaultYellowButtonMenuEnabled! ! !Morph methodsFor: 'debug and other' stamp: 'RAA 1/19/2001 07:51'! addMouseActionIndicatorsWidth: anInteger color: aColor self deleteAnyMouseActionIndicators. self changed. self hasRolloverBorder: true. self setProperty: #rolloverWidth toValue: anInteger@anInteger. self setProperty: #rolloverColor toValue: aColor. self layoutChanged. self changed. ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:46'! toggleDragNDrop "Toggle this morph's ability to add and remove morphs via drag-n-drop." self enableDragNDrop: self dragNDropEnabled not. ! ! !Morph methodsFor: 'layout' stamp: 'IgorStasenko 12/22/2012 03:11'! privateFullBounds "Private. Compute the actual full bounds of the receiver" | box | submorphs isEmpty ifTrue: [^self outerBounds]. box := self outerBounds copy. box := box quickMerge: (self clipSubmorphs ifTrue: [self submorphBounds intersect: self clippingBounds ifNone: [ self clippingBounds ]] ifFalse: [self submorphBounds]). ^box origin asIntegerPoint corner: box corner asIntegerPoint! ! !Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:46'! privateExtension: aMorphExtension "private - change the receiver's extension" extension := aMorphExtension! ! !Morph methodsFor: 'accessing' stamp: 'AlainPlantec 10/17/2009 17:11'! wantsToBeTopmost "Answer if the receiver want to be one of the topmost objects in its owner" ^ false! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 12/19/2009 23:40'! setBalloonText: stringOrText "Set receiver's balloon help text. Pass nil to remove the help." self setBalloonText: stringOrText maxLineLength: self theme settings maxBalloonHelpLineLength! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'AlainPlantec 2/17/2010 14:53'! allMorphs "Return a collection containing all morphs in this composite morph (including the receiver)." | all | all := (Array new: submorphs size) writeStream. self allMorphsDo: [:m | all nextPut: m]. ^ all contents! ! !Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 08:53'! toggleStickiness "togle the receiver's Stickiness" extension ifNil: [^ self beSticky]. extension sticky: extension sticky not! ! !Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:35'! layoutProportionallyIn: newBounds "Layout specific. Apply the given bounds to the receiver." | box frame | frame := self layoutFrame ifNil:[^self]. "before applying the proportional values make sure the receiver's layout is computed" self fullBounds. "sigh..." "compute the cell size the receiver has given its layout frame" box := frame layout: self bounds in: newBounds. (box = self bounds) ifTrue:[^self]. "no change" ^self layoutInBounds: box.! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! changeReverseCells self reverseTableCells: self reverseTableCells not.! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:05'! listCentering: aSymbol "Layout specific. This property describes how the rows/columns in a list-like layout should be centered. #topLeft - center at start of primary direction #bottomRight - center at end of primary direction #center - center in the middle of primary direction #justified - insert extra space inbetween rows/columns " self assureTableProperties listCentering: aSymbol. self layoutChanged.! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/11/2006 09:37'! modalLockTo: aSystemWindow "Lock the receiver as a modal owner of the given window." self lock! ! !Morph methodsFor: 'stepping and presenter' stamp: ''! start "Start running my script. For ordinary morphs, this means start stepping." self startStepping. ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'GuillermoPolito 5/1/2012 20:04'! openInWindowLabeled: aString inWorld: aWorld "Changed to include the inset margin in the bound calculation." | window extent | window := (SystemWindow labelled: aString) model: nil. window " guess at initial extent" bounds: (RealEstateAgent initialFrameFor: window initialExtent: self fullBounds extent world: aWorld); addMorph: self frame: (0@0 extent: 1@1); updatePaneColors. " calculate extent after adding in case any size related attributes were changed. Use fullBounds in order to trigger re-layout of layout morphs" extent := self fullBounds extent + (window borderWidth@window labelHeight) + window borderWidth + (window class borderWidth * 2 @ (window class borderWidth + 1)). "include inset margin" window extent: extent. aWorld addMorph: window. window activate. aWorld startSteppingSubmorphsOf: window. window announceOpened. ^window ! ! !Morph methodsFor: 'announcements' stamp: 'ThierryGoubier 1/8/2014 14:35'! announceDeleted self doAnnounce: (MorphDeleted morph: self). self submorphs do: #announceDeleted! ! !Morph methodsFor: 'classification' stamp: 'ar 12/16/2001 18:28'! isTextMorph ^false! ! !Morph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/31/2013 17:45'! enabled: aBoolean "does nothing" ! ! !Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:16'! programmedMouseDown: anEvent for: aMorph aMorph addMouseActionIndicatorsWidth: 15 color: (Color blue alpha: 0.7). ! ! !Morph methodsFor: 'drawing' stamp: 'IgorStasenko 7/18/2011 18:44'! drawRolloverBorderOn: aCanvas | colorToUse offsetToUse myShadow newForm f | colorToUse := self valueOfProperty: #rolloverColor ifAbsent: [Color blue alpha: 0.5]. offsetToUse := self valueOfProperty: #rolloverWidth ifAbsent: [10 @ 10]. self hasRolloverBorder: false. myShadow := self shadowForm. self hasRolloverBorder: true. myShadow offset: 0 @ 0. f := ColorForm extent: myShadow extent depth: 1. myShadow displayOn: f. f colors: {Color transparent. colorToUse}. newForm := Form extent: offsetToUse * 2 + myShadow extent depth: 32. (WarpBlt current toForm: newForm) sourceForm: f; cellSize: 1; combinationRule: 3; copyQuad: f boundingBox innerCorners toRect: newForm boundingBox. aCanvas translateBy: offsetToUse negated during: [:shadowCanvas | (shadowCanvas asShadowDrawingCanvas: colorToUse) paintImage: newForm at: self position] ! ! !Morph methodsFor: 'layout-menu' stamp: 'StephaneDucasse 4/23/2012 10:21'! layoutMenuPropertyString: aSymbol from: currentSetting | wording | wording := String streamContents: [:stream | | index | index := 1. aSymbol keysAndValuesDo: [:idx :ch | ch isUppercase ifTrue: [stream nextPutAll: (aSymbol copyFrom: index to: idx - 1) asLowercase. stream nextPutAll: ' '. index := idx]]. index < aSymbol size ifTrue: [stream nextPutAll: (aSymbol copyFrom: index to: aSymbol size) asLowercase]]. ^ (aSymbol == currentSetting) -> wording translated! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/15/2001 12:21'! toggleResistsRemoval "Toggle the resistsRemoval property" self resistsRemoval ifTrue: [self removeProperty: #resistsRemoval] ifFalse: [self setProperty: #resistsRemoval toValue: true]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:06'! showBalloon: msgString "Pop up a balloon containing the given string, first removing any existing BalloonMorphs in the world." | w | self showBalloon: msgString hand: ((w := self world) ifNotNil:[w activeHand]).! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:39'! cellPositioning: aSymbol "Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are: #topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center which align the receiver's bounds with the cell at the given point." self assureTableProperties cellPositioning: aSymbol. self layoutChanged.! ! !Morph methodsFor: 'copying' stamp: 'tk 2/19/2001 18:21'! copy ^ self veryDeepCopy! ! !Morph methodsFor: 'stepping and presenter' stamp: ''! stop "Stop running my script. For ordinary morphs, this means stop stepping." self stopStepping. ! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'SeanDeNigris 7/9/2012 23:40'! hasKeymapCategoryNamed: aString ^ self kmDispatcher targets anySatisfy: [ :e | e category name = aString ].! ! !Morph methodsFor: 'drop shadows' stamp: 'AlainPlantec 12/14/2009 11:09'! shadowColor: aColor self shadowColor = aColor ifFalse: [self changed]. self setProperty: #shadowColor toValue: aColor.! ! !Morph methodsFor: 'copying' stamp: 'MarcusDenker 9/13/2013 16:20'! duplicate "Make and return a duplicate of the receiver" | newMorph topRend | ((topRend := self topRendererOrSelf) ~~ self) ifTrue: [^ topRend duplicate]. newMorph := self veryDeepCopy. newMorph arrangeToStartStepping. newMorph privateOwner: nil. "no longer in world" ^newMorph! ! !Morph methodsFor: 'layout' stamp: 'MarcusDenker 10/3/2013 23:34'! doLayoutIn: layoutBounds "Compute a new layout based on the given layout bounds." "Note: Testing for #bounds or #layoutBounds would be sufficient to figure out if we need an invalidation afterwards but #outerBounds is what we need for all leaf nodes so we use that." | box priorBounds | priorBounds := self outerBounds. submorphs isEmpty ifTrue: [^fullBounds := priorBounds]. "Send #ownerChanged to our children" submorphs do: [:m | m ownerChanged]. self layoutPolicy ifNotNil: [:layout | layout layout: self in: layoutBounds]. self adjustLayoutBounds. fullBounds := self privateFullBounds. box := self outerBounds. box = priorBounds ifFalse: [self invalidRect: (priorBounds quickMerge: box)]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'BenjaminVanRyseghem 6/21/2013 17:53'! justDroppedInto: aMorph event: anEvent "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph" | aWindow | (self formerOwner notNil and: [self formerOwner ~~ aMorph]) ifTrue: [self removeHalo]. self formerOwner: nil. self formerPosition: nil. (aWindow := aMorph ownerThatIsA: SystemWindow) ifNotNil: [aWindow isActive ifFalse: [aWindow activate]]. "An object launched by certain parts-launcher mechanisms should end up fully visible..." (self hasProperty: #beFullyVisibleAfterDrop) ifTrue: [aMorph == ActiveWorld ifTrue: [self goHome]. self removeProperty: #beFullyVisibleAfterDrop]. ! ! !Morph methodsFor: 'menus' stamp: 'wiz 10/19/2006 00:35'! adhereToEdge: edgeSymbol | edgeMessage | (owner isNil or: [owner isHandMorph]) ifTrue: [^self]. (owner class canUnderstand: edgeSymbol) ifFalse: [^self]. (self class canUnderstand: ( edgeMessage := (edgeSymbol , ':') asSymbol )) ifFalse: [^self]. self perform: edgeMessage withArguments: (Array with: (owner perform: edgeSymbol))! ! !Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:34'! alarmScheduler "Return the scheduler being responsible for triggering alarms" ^self world! ! !Morph methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:12'! cmdGesturesEnabled ^ self class cmdGesturesEnabled! ! !Morph methodsFor: 'event handling' stamp: 'GuillermoPolito 4/22/2012 17:19'! handlesKeyDown: evt ^self handlesKeyboard: evt! ! !Morph methodsFor: 'initialize' stamp: 'ar 1/31/2001 13:58'! outOfWorld: aWorld "The receiver has just appeared in a new world. Notes: * aWorld can be nil (due to optimizations in other places) * owner is still valid Important: Keep this method fast - it is run whenever morphs are removed." aWorld ifNil:[^self]. "ar 1/31/2001: We could explicitly stop stepping the receiver here but for the sake of speed I'm for now relying on the lazy machinery in the world itself." "aWorld stopStepping: self." self submorphsDo:[:m| m outOfWorld: aWorld]. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 12/19/2009 23:40'! wantsDirectionHandles ^self valueOfProperty: #wantsDirectionHandles ifAbsent:[false]! ! !Morph methodsFor: 'geometry' stamp: 'ar 11/12/2000 22:06'! outerBounds "Return the 'outer' bounds of the receiver, e.g., the bounds that need to be invalidated when the receiver changes." | box | box := self bounds. self hasDropShadow ifTrue:[box := self expandFullBoundsForDropShadow: box]. self hasRolloverBorder ifTrue:[box := self expandFullBoundsForRolloverBorder: box]. ^box! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'GaryChambers 11/15/2011 13:15'! theme "Answer the current theme for the receiver." (self valueOfProperty: #theme) ifNotNil: [:t | ^ t]. ^(self owner ifNil: [self class]) theme! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! minCellSize: aPoint "Layout specific. This property specifies the minimal size of a table cell." self assureTableProperties minCellSize: aPoint. self layoutChanged.! ! !Morph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:09'! initialize "initialize the state of the receiver" super initialize. owner := nil. submorphs := EmptyArray. bounds := self defaultBounds. color := self defaultColor! ! !Morph methodsFor: 'drawing' stamp: 'ar 11/8/2000 19:29'! expandFullBoundsForRolloverBorder: aRectangle | delta | delta := self valueOfProperty: #rolloverWidth ifAbsent: [10@10]. ^aRectangle expandBy: delta. ! ! !Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:53'! isLocked "answer whether the receiver is Locked" extension ifNil: [^ false]. ^ extension locked! ! !Morph methodsFor: 'utilities' stamp: 'AlainPlantec 12/16/2009 12:27'! embeddedInMorphicWindowLabeled: labelString | window | window := (SystemWindow labelled: labelString) model: nil. window setStripeColorsFrom: (self theme windowColorFor: self). window addMorph: self frame: (0@0 extent: 1@1). ^ window! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'BenjaminVanRyseghem 2/20/2012 19:23'! detachKeymapCategory: aCategoryName targetting: anObject self kmDispatcher detachKeymapCategory: aCategoryName targetting: anObject! ! !Morph methodsFor: 'submorphs-accessing' stamp: ''! submorphsReverseDo: aBlock submorphs reverseDo: aBlock.! ! !Morph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:11'! useDefaultFill "Make receiver use a solid fill style (e.g., a simple color)" self fillStyle: self defaultColor.! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/21/2007 14:35'! takeKeyboardFocus "Make the receiver the keyboard focus for the active hand." self activeHand newKeyboardFocus: self! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/21/2008 16:50'! activate "Mark the receiver and submorphs as active (foreground)." self submorphsDo: [:m | m activate]! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! listCenteringString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self listCentering! ! !Morph methodsFor: 'meta-actions' stamp: 'GuillermoPolito 5/29/2011 14:50'! buildHandleMenu: aHand "Build the morph menu for the given morph's halo's menu handle. This menu has two sections. The first section contains commands that are interpreted by the hand; the second contains commands provided by the target morph. This method allows the morph to decide which items should be included in the hand's section of the menu." | menu | menu := UIManager default newMenuIn: self for: self. menu addStayUpItem. menu addLine. self addStandardHaloMenuItemsTo: menu hand: aHand. menu defaultTarget: aHand. self addAddHandMenuItemsForHalo: menu hand: aHand. menu defaultTarget: self. self addCustomHaloMenuItems: menu hand: aHand. menu defaultTarget: aHand. ^ menu ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 8/12/2003 23:35'! slideBackToFormerSituation: evt | slideForm formerOwner formerPosition aWorld startPoint endPoint trans | formerOwner := self formerOwner. formerPosition := self formerPosition. aWorld := evt hand world. trans := formerOwner transformFromWorld. slideForm := trans isPureTranslation ifTrue: [self imageForm offset: 0 @ 0] ifFalse: [((TransformationMorph new asFlexOf: self) transform: trans) imageForm offset: 0 @ 0]. startPoint := evt hand fullBounds origin. endPoint := trans localPointToGlobal: formerPosition. owner removeMorph: self. aWorld displayWorld. slideForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15. formerOwner addMorph: self. self position: formerPosition. self justDroppedInto: formerOwner event: evt! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:06'! morphsInFrontOverlapping: aRectangle "Return all top-level morphs in front of someMorph that overlap with the given rectangle." | morphList | morphList := Array new writeStream. self morphsInFrontOf: nil overlapping: aRectangle do:[:m | morphList nextPut: m]. ^morphList contents! ! !Morph methodsFor: '*Athens-Examples' stamp: 'IgorStasenko 5/6/2013 18:08'! openInSceneView ^ AthensSceneView new scene: (AthensMorphScene new morph:self); openInWindow! ! !Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:55'! valueOfProperty: aSymbol ifAbsentPut: aBlock "If the receiver possesses a property of the given name, answer its value. If not, then create a property of the given name, give it the value obtained by evaluating aBlock, then answer that value" ^ self assureExtension valueOfProperty: aSymbol ifAbsentPut: aBlock! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 10:36'! isTaskbar "Answer false in the general case." ^false! ! !Morph methodsFor: 'Morphic-Base-Worlds' stamp: 'sw 7/1/1998 18:02'! pasteUpMorph "Answer the closest containing morph that is a PasteUp morph" ^ self ownerThatIsA: PasteUpMorph! ! !Morph methodsFor: 'accessing' stamp: 'dgd 3/7/2003 15:24'! raisedColor "Return the color to be used for shading raised borders. The default is my own color, but it might want to be, eg, my owner's color. Whoever's color ends up prevailing, the color itself gets the last chance to determine, so that when, for example, an InfiniteForm serves as the color, callers won't choke on some non-Color object being returned" (color isColor and: [color isTransparent and: [owner notNil]]) ifTrue: [^ owner raisedColor]. ^ color asColor raisedColor! ! !Morph methodsFor: 'events-accessing' stamp: 'gvc 9/11/2009 17:43'! updateableActionMap "Answer an updateable action map, saving it in my #actionMap property" | actionMap | self assureExtension. actionMap := extension actionMap. actionMap ifNil: [actionMap := self createActionMap. extension actionMap: actionMap]. ^actionMap! ! !Morph methodsFor: 'Morphic-Base-MorphTreeWidget' stamp: 'AlainPlantec 9/30/2011 15:59'! rowMorphForNode: aNode inColumn: aColumn | rm | rm := Morph new color: Color transparent; layoutPolicy: RowLayout new; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: aColumn container columnInset @ aColumn container rowInset; listDirection: #leftToRight; cellPositioning: #leftCenter; cellInset: 4@0; yourself. rm addMorph: self. aColumn isFirstColumn ifTrue: [ | icon | icon := aColumn container iconBlock value: aNode. icon ifNotNil: [ rm addMorph: icon asMorph ]. "for first column we don't use horizontal inset" rm layoutInset: 0 @ aColumn container rowInset. ]. ^ rm ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/17/2007 17:44'! taskbarButtonFor: aTaskBar "Answer a new task bar button for the receiver. Answer nil if not required." ^nil! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 18:37'! textAnchorType: aSymbol aSymbol == #document ifTrue:[^self removeProperty: #textAnchorType] ifFalse:[^self setProperty: #textAnchorType toValue: aSymbol].! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'pmm 3/13/2010 11:32'! copyWithoutSubmorph: sub "Needed to get a morph to draw without one of its submorphs. NOTE: This must be thrown away immediately after use." ^ self shallowCopy privateSubmorphs: (submorphs copyWithout: sub)! ! !Morph methodsFor: 'meta-actions' stamp: 'StephaneDucasse 6/28/2013 11:26'! resizeMorph: evt | handle | handle := HandleMorph new forEachPointDo: [ :newPoint | self extent: newPoint - self bounds topLeft ]. evt hand attachMorph: handle. handle startStepping! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/11/2000 18:24'! defersHaloOnClickTo: aSubMorph "If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true" "May want to add a way (via a property) for morphs to assert true here -- this would let certain kinds of morphs that are unusually reluctant to take the halo on initial click" ^ false ! ! !Morph methodsFor: 'event handling' stamp: 'SeanDeNigris 1/31/2014 18:32'! mouseUp: evt "Handle a mouse up event. The default response is to let my eventHandler, if any, handle it." ^ self eventHandler ifNotNil: [self eventHandler mouseUp: evt fromMorph: self]. ! ! !Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'! addAlarm: aSelector with: arg1 after: delayTime "Add an alarm (that is an action to be executed once) with the given set of parameters" ^self addAlarm: aSelector withArguments: (Array with: arg1) after: delayTime! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 23:29'! addAllMorphs: aCollection after: anotherMorph ^self privateAddAllMorphs: aCollection atIndex: (submorphs indexOf: anotherMorph ifAbsent: [submorphs size])! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/15/2000 14:16'! spaceFillWeight: aNumber "Layout specific. This property describes the relative weight that should be given to the receiver when extra space is distributed between different #spaceFill cells." aNumber = 1 ifTrue:[self removeProperty: #spaceFillWeight] ifFalse:[self setProperty: #spaceFillWeight toValue: aNumber]. self layoutChanged.! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'BenjaminVanRyseghem 3/19/2011 22:09'! findSubmorphBinary: aBlock "Use binary search for finding a specific submorph of the receiver. Caller must be certain that the ordering holds for the submorphs." ^submorphs findBinary: aBlock do: [ :found | found ] ifNone: [:a :b | ]! ! !Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:58'! lock: aBoolean "change the receiver's lock property" (extension isNil and: [aBoolean not]) ifTrue: [^ self]. self assureExtension locked: aBoolean! ! !Morph methodsFor: 'accessing' stamp: 'StephaneDucasse 10/13/2013 21:50'! wantsToBeCachedByHand "Return true if the receiver wants to be cached by the hand when it is dragged around. Note: The default implementation queries all submorphs since subclasses may have shapes that do not fill the receiver's bounds completely." self isTranslucentButNotTransparent ifTrue: [ ^ false ]. self submorphsDo: [ :m | m wantsToBeCachedByHand ifFalse: [ ^ false ] ]. ^ true! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 12:02'! resetHighlightForDrop self highlightForDrop: false! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 11:32'! nextMorphAcrossInWindow "Answer the next morph in the window. Traverse from the receiver to its next sibling or owner's next sibling etc." ^self submorphAfter ifNil: [ (self owner ifNil: [^self]) nextMorphAcrossInWindow]! ! !Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:33'! acceptDroppingMorph: aMorph event: evt "This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. This default implementation just adds the given morph to the receiver." | layout | layout := self layoutPolicy. layout ifNil:[^self addMorph: aMorph]. self privateAddMorph: aMorph atIndex: (layout indexForInserting: aMorph at: evt position in: self).! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/7/1999 18:57'! addHalo "Invoke a halo programatically (e.g., not from a meta gesture)" ^self addHalo: nil! ! !Morph methodsFor: 'drawing' stamp: 'gvc 9/11/2009 17:59'! clipSubmorphs "Drawing specific. If this property is set, clip the receiver's submorphs to the receiver's clipping bounds." extension ifNil: [^false]. ^extension clipSubmorphs ifNil: [false]! ! !Morph methodsFor: 'geometry' stamp: 'di 6/12/97 11:17'! bottomRight ^ bounds bottomRight! ! !Morph methodsFor: 'structure' stamp: 'ar 10/3/2000 15:36'! hasOwner: aMorph "Return true if the receiver has aMorph in its owner chain" aMorph ifNil:[^true]. self allOwnersDo:[:m| m = aMorph ifTrue:[^true]]. ^false! ! !Morph methodsFor: 'layout-properties' stamp: 'MarcusDenker 10/3/2013 23:32'! layoutInset "Return the extra inset for layouts" ^ self layoutProperties ifNil: [ 0 ] ifNotNil: [ :props | props layoutInset ]! ! !Morph methodsFor: 'menus' stamp: 'ar 9/22/2000 20:14'! setRotationCenterFrom: aPoint self rotationCenter: (aPoint - self bounds origin) / self bounds extent asFloatPoint.! ! !Morph methodsFor: 'menu' stamp: 'MarcusDenker 9/7/2010 17:41'! addTitleForHaloMenu: aMenu aMenu addTitle: self externalName icon: (self iconOrThumbnailOfSize: 28)! ! !Morph methodsFor: 'events-alarms' stamp: 'ar 9/14/2000 12:14'! removeAlarm: aSelector "Remove the given alarm" | scheduler | scheduler := self alarmScheduler. scheduler ifNotNil:[scheduler removeAlarm: aSelector for: self].! ! !Morph methodsFor: 'drawing' stamp: 'di 9/9/1998 22:25'! imageFormForRectangle: rect ^ self imageForm: Display depth forRectangle: rect ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 23:28'! addAllMorphs: aCollection ^self privateAddAllMorphs: aCollection atIndex: submorphs size! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/29/2001 06:29'! okayToResizeEasily "Answer whether it is appropriate to have the receiver be easily resized by the user from the halo" ^ true "This one was too jarring, not that it didn't most of the time do the right thing but because some of the time it didn't, such as in a holder. If we pursue this path, the test needs to be airtight, obviously... ^ (self topRendererOrSelf owner isKindOf: PasteUpMorph) and: [self layoutPolicy isNil]"! ! !Morph methodsFor: 'structure' stamp: 'dgd 9/1/2004 17:17'! isInDockingBar "answer if the receiver is in a menu bar" ^ (owner notNil) and: [owner isDockingBar]! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'rhi 9/10/2000 12:12'! findA: aClass "Return the first submorph of the receiver that is descended from the given class. Return nil if there is no such submorph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart." ^self submorphs detect: [:p | p isKindOf: aClass] ifNone: [nil]! ! !Morph methodsFor: 'menus' stamp: 'MarcusDenker 9/28/2013 15:50'! inspectInMorphic: evt Smalltalk tools inspector inspect: self! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:08'! changeCellInset: evt | handle | handle := HandleMorph new forEachPointDo:[:newPoint | self cellInset: (newPoint - evt cursorPoint) asIntegerPoint // 5]. evt hand attachMorph: handle. handle startStepping. ! ! !Morph methodsFor: 'menus' stamp: 'DamienCassou 9/29/2009 13:01'! exportAsPNG | fName | fName := UIManager default request:'Please enter the name' translated initialAnswer: self externalName,'.png'. fName isEmptyOrNil ifTrue:[^self]. PNGReadWriter putForm: self imageForm onFileNamed: fName.! ! !Morph methodsFor: 'event handling' stamp: 'fbs 1/7/2005 15:43'! preferredKeyboardBounds ^ self bounds: self bounds in: World. ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/13/2007 15:25'! preferredCornerStyle "Answer the preferred corner style." ^#square! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:15'! right: aNumber " Move me so that my right side is at the x-coordinate aNumber. My extent (width & height) are unchanged " self position: ((aNumber - bounds width) @ bounds top)! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:54'! addMorphFront: aMorph ^self privateAddMorph: aMorph atIndex: 1! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 8/6/2013 16:23'! allowsKeymapping ^ self valueOfProperty: #allowsKeymapping ifAbsent: [ true]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 10:36'! taskbars "Answer the receiver's taskbars." ^self submorphs select: [:each | each isTaskbar]! ! !Morph methodsFor: 'geometry' stamp: ''! height ^ bounds height! ! !Morph methodsFor: 'halos and balloon help' stamp: 'SeanDeNigris 1/29/2013 13:10'! addHandlesTo: aHaloMorph box: box "Add halo handles to the halo. Apply the halo filter if appropriate" aHaloMorph haloBox: box. HaloMorph currentHaloSpecifications do: [:aSpec | | wantsIt aSelector | aSelector := aSpec addHandleSelector. (wantsIt := self wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph) ifTrue: [(#(addDupHandle:) includes: aSelector) ifTrue: [wantsIt := self preferredDuplicationHandleSelector = aSelector]]. wantsIt ifTrue: [aHaloMorph perform: aSelector with: aSpec]]. aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! ! !Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:59'! withAllOwners "Return the receiver and all its owners" ^ Array streamContents: [:strm | self withAllOwnersDo: [:m | strm nextPut: m]]! ! !Morph methodsFor: 'layout' stamp: 'ar 10/31/2000 21:09'! layoutBounds: aRectangle "Set the bounds for laying out children of the receiver. Note: written so that #layoutBounds can be changed without touching this method" | outer inner | outer := self bounds. inner := self layoutBounds. bounds := aRectangle origin + (outer origin - inner origin) corner: aRectangle corner + (outer corner - inner corner).! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! leftCenter ^ bounds leftCenter! ! !Morph methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:23'! menuKeyboardControl ^ self theme settings menuKeyboardControl! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! listDirectionString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self listDirection! ! !Morph methodsFor: 'private' stamp: 'di 10/18/2004 21:49'! privateRemove: aMorph "Private!! Should only be used by methods that maintain the ower/submorph invariant." submorphs := submorphs copyWithout: aMorph. self layoutChanged.! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:27'! allMorphsDo: aBlock "Evaluate the given block for all morphs in this composite morph (including the receiver)." submorphs do: [:m | m allMorphsDo: aBlock]. aBlock value: self! ! !Morph methodsFor: 'stepping and presenter' stamp: 'stephane.ducasse 11/27/2008 22:31'! stepAt: millisecondClockValue "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message. The millisecondClockValue parameter gives the value of the millisecond clock at the moment of dispatch. Default is to dispatch to the parameterless step method for the morph, but this protocol makes it possible for some morphs to do differing things depending on the clock value" self step ! ! !Morph methodsFor: 'debug and other' stamp: 'MarcusDenker 2/25/2010 08:47'! programmedMouseUp: anEvent for: aMorph | aCodeString | self deleteAnyMouseActionIndicators. aCodeString := self valueOfProperty: #mouseUpCodeToRun ifAbsent: [^self]. (self fullBounds containsPoint: anEvent cursorPoint) ifFalse: [^self]. aCodeString value. ! ! !Morph methodsFor: 'layout-properties' stamp: 'StephaneDucasse 12/21/2012 18:15'! layoutFrame: aLayoutFrame "Layout specific. Return the layout frame describing where the receiver should appear in a proportional layout" self layoutFrame == aLayoutFrame ifTrue: [^self]. self assureExtension layoutFrame: aLayoutFrame asLayoutFrame. self layoutChanged.! ! !Morph methodsFor: 'visual properties' stamp: 'dgd 1/7/2005 19:31'! fillWithRamp: rampSpecsOrColor oriented: aRatio rampSpecsOrColor isColor ifTrue: [self color: rampSpecsOrColor". self borderColor: rampSpecsOrColor muchDarker"] ifFalse: [| fill | fill := GradientFillStyle ramp: rampSpecsOrColor. fill origin: self bounds topLeft. fill direction: (self bounds extent * aRatio) truncated. fill radial: false. self fillStyle: fill. self borderColor: (rampSpecsOrColor first value mixed: 0.5 with: rampSpecsOrColor last value) muchDarker]! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:02'! vResizing "Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are: #rigid - do not resize the receiver #spaceFill - resize to fill owner's available space #shrinkWrap - resize to fit children " | props | props := self layoutProperties. ^props ifNil:[#rigid] ifNotNil:[props vResizing].! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 19:47'! relativeTextAnchorPosition ^self valueOfProperty: #relativeTextAnchorPosition! ! !Morph methodsFor: 'meta-actions' stamp: 'ar 9/15/2000 20:25'! blueButtonUp: anEvent "Ignored. Theoretically we should never get here since control is transferred to the halo on #blueButtonDown: but subclasses may implement this differently."! ! !Morph methodsFor: 'geometry' stamp: ''! position ^ bounds topLeft! ! !Morph methodsFor: 'drop shadows' stamp: 'dgd 2/16/2003 21:58'! hasRolloverBorder "answer whether the receiver has RolloverBorder" ^ self valueOfProperty: #hasRolloverBorder ifAbsent: [false]! ! !Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:27'! arrangeToStartStepping "Arrange to start getting sent the 'step' message, but don't do that initial #step call that startStepping does" self arrangeToStartSteppingIn: self world! ! !Morph methodsFor: 'layout-properties' stamp: 'md 2/27/2006 10:00'! layoutPolicy "Layout specific. Return the layout policy describing how children of the receiver should appear." ^ extension ifNotNil: [ extension layoutPolicy]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'StephaneDucasse 6/5/2011 22:38'! openModal: aSystemWindow "Open the given window locking the receiver until it is dismissed. Answer the system window. Restore the original keyboard focus when closed." |area mySysWin keyboardFocus| keyboardFocus := self activeHand keyboardFocus. mySysWin := self isSystemWindow ifTrue: [self] ifFalse: [self ownerThatIsA: SystemWindow]. mySysWin ifNil: [mySysWin := self]. mySysWin modalLockTo: aSystemWindow. area := RealEstateAgent maximumUsableArea. aSystemWindow extent: aSystemWindow initialExtent. aSystemWindow position = (0@0) ifTrue: [aSystemWindow position: self activeHand position - (aSystemWindow extent // 2)]. aSystemWindow bounds: (aSystemWindow bounds translatedToBeWithin: area). [ |aWidget | aWidget := aSystemWindow openAsIs. [aWidget world notNil] whileTrue: [ aWidget outermostWorldMorph doOneCycle]] ensure: [mySysWin modalUnlockFrom: aSystemWindow. self activeHand newKeyboardFocus: keyboardFocus]. ^aSystemWindow! ! !Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:02'! removeLink: actionCode self eventHandler ifNotNil: [self eventHandler on: actionCode send: nil to: nil]! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'! lastSubmorph ^submorphs last! ! !Morph methodsFor: 'button' stamp: 'marcus.denker 8/24/2008 21:42'! firedMouseUpCode "If the user has special mouseUpCodeToRun, then fire it once right now and return true, else return false" | evt | (self world isNil or: [self mouseUpCodeOrNil isNil]) ifTrue: [^false]. evt := MouseEvent basicNew setType: nil position: self center buttons: 0 hand: self world activeHand. self programmedMouseUp: evt for: self. ^true! ! !Morph methodsFor: 'updating' stamp: 'StephaneDucasse 8/8/2013 21:03'! breakDependents self flag: #GSoC. "Flag added by Benjamin Van Ryseghem the July 22, 2013 to remember to remove this line in a while" [ super breakDependents ] on: Error do: []. self removeProperty: #announcer! ! !Morph methodsFor: 'change reporting' stamp: 'sw 7/8/1998 13:21'! ownerChanged "The receiver's owner, some kind of a pasteup, has changed its layout." self snapToEdgeIfAppropriate! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:22'! height: aNumber " Set my height; my position (top-left corner) and width will remain the same " self extent: self width@aNumber asInteger. ! ! !Morph methodsFor: 'macpal' stamp: 'GaryChambers 12/21/2011 11:10'! flash | fs w | fs := self fillStyle. self fillStyle: Color black. (w := self world) ifNotNil: [w displayWorldSafely]. self fillStyle: fs! ! !Morph methodsFor: 'event handling' stamp: 'fbs 1/7/2005 15:42'! preferredKeyboardPosition ^ (self bounds: self bounds in: World) topLeft. ! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:14'! top: aNumber " Move me so that my top is at the y-coordinate aNumber. My extent (width & height) are unchanged " self position: (bounds left @ aNumber)! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! listSpacingString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self listSpacing! ! !Morph methodsFor: 'user interface' stamp: 'tak 3/15/2005 17:10'! doCancel self delete! ! !Morph methodsFor: 'events-processing' stamp: 'SeanDeNigris 1/31/2014 18:38'! handleMouseUp: anEvent "System level event handling." anEvent wasHandled ifTrue: [^self]. "not interested" anEvent hand mouseFocus == self ifFalse: [^self]. "Not interested in other parties" anEvent hand releaseMouseFocus: self. anEvent wasHandled: true. ^ anEvent blueButtonChanged ifTrue: [ self blueButtonUp: anEvent. self eventHandler ifNotNil: [:handler | handler mouseUp: anEvent fromMorph: self]] ifFalse: [ | result | result := self mouseUp: anEvent. self stopSteppingSelector: #handleMouseStillDown:. result ].! ! !Morph methodsFor: 'structure' stamp: 'sw 8/29/2000 14:55'! morphPreceding: aSubmorph "Answer the morph immediately preceding aSubmorph, or nil if none" | anIndex | anIndex := submorphs indexOf: aSubmorph ifAbsent: [^ nil]. ^ anIndex > 1 ifTrue: [submorphs at: (anIndex - 1)] ifFalse: [nil]! ! !Morph methodsFor: 'debug and other' stamp: 'EstebanLorenzano 5/14/2013 09:44'! addDebuggingItemsTo: aMenu hand: aHandMorph aMenu add: 'debug...' translated subMenu: (self buildDebugMenu: aHandMorph). aMenu lastItem icon: Smalltalk ui icons smallDebugIcon! ! !Morph methodsFor: 'private' stamp: 'tk 8/30/1998 09:58'! privateFullBounds: boundsRect "Private!! Computed automatically." fullBounds := boundsRect.! ! !Morph methodsFor: 'converting' stamp: ''! asDraggableMorph ^self! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! listSpacing: aSymbol "Layout specific. This property describes how the heights for different rows in a table layout should be handled. #equal - all rows have the same height #none - all rows may have different heights " self assureTableProperties listSpacing: aSymbol. self layoutChanged.! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 03:00'! wrapCenteringString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self wrapCentering! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'alain.plantec 6/8/2009 23:44'! allNonSubmorphMorphs "Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy" ^ OrderedCollection new! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'sw 8/15/97 22:03'! submorphsSatisfying: aBlock ^ submorphs select: [:m | (aBlock value: m) == true]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/25/2000 17:43'! wantsHaloFromClick ^ true! ! !Morph methodsFor: 'menu' stamp: 'GuillermoPolito 5/29/2011 14:49'! addNestedYellowButtonItemsTo: aMenu event: evt "Add items to aMenu starting with me and proceeding down through my submorph chain, letting any submorphs that include the event position contribute their items to the bottom of the menu, separated by a line." | underMouse | self addYellowButtonMenuItemsTo: aMenu event: evt. underMouse := self submorphThat: [:each | each containsPoint: evt position] ifNone: [^ self]. (underMouse addMyYellowButtonMenuItemsToSubmorphMenus and: [underMouse hasYellowButtonMenu]) ifTrue: [| submenu | aMenu addLine. submenu := UIManager default newMenuIn: underMouse for: underMouse. underMouse addNestedYellowButtonItemsTo: submenu event: evt. aMenu add: underMouse externalName icon: (underMouse iconOrThumbnailOfSize: 16) subMenu: submenu ] ! ! !Morph methodsFor: 'initialize' stamp: 'cb 6/25/2013 13:24'! openInWindow ^self openInWindowLabeled: self defaultLabel ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'sw 1/11/1999 20:07'! repelsMorph: aMorph event: ev ^ false! ! !Morph methodsFor: 'menus' stamp: 'GuillermoPolito 5/29/2011 14:48'! addHaloActionsTo: aMenu "Add items to aMenu representing actions requestable via halo" | subMenu | subMenu := UIManager default newMenuIn: self for: self. subMenu addTitle: self externalName. subMenu addStayUpItemSpecial. subMenu addLine. subMenu add: 'delete' translated action: #dismissViaHalo. subMenu balloonTextForLastItem: 'Delete this object -- warning -- can be destructive!!' translated. self maybeAddCollapseItemTo: subMenu. subMenu add: 'grab' translated action: #openInHand. subMenu balloonTextForLastItem: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' translated. subMenu addLine. subMenu add: 'resize' translated action: #resizeFromMenu. subMenu balloonTextForLastItem: 'Change the size of this object' translated. subMenu add: 'duplicate' translated action: #maybeDuplicateMorph. subMenu balloonTextForLastItem: 'Hand me a copy of this object' translated. subMenu addLine. subMenu add: 'set color' translated target: self renderedMorph action: #changeColor. subMenu balloonTextForLastItem: 'Change the color of this object' translated. subMenu addLine. subMenu add: 'inspect' translated target: self action: #inspect. subMenu balloonTextForLastItem: 'Open an Inspector on this object' translated. aMenu add: 'halo actions...' translated subMenu: subMenu ! ! !Morph methodsFor: 'menus' stamp: 'StephaneDucasse 3/3/2010 15:49'! addStandardHaloMenuItemsTo: aMenu hand: aHandMorph "Add standard halo items to the menu" self isWorldMorph ifTrue: [^ self addWorldHaloMenuItemsTo: aMenu hand: aHandMorph]. aMenu add: 'send to back' translated action: #goBehind. aMenu add: 'bring to front' translated action: #comeToFront. self addEmbeddingMenuItemsTo: aMenu hand: aHandMorph. aMenu addLine. self addFillStyleMenuItems: aMenu hand: aHandMorph. self addBorderStyleMenuItems: aMenu hand: aHandMorph. self addDropShadowMenuItems: aMenu hand: aHandMorph. self addLayoutMenuItems: aMenu hand: aHandMorph. self addHaloActionsTo: aMenu. owner isTextMorph ifTrue:[self addTextAnchorMenuItems: aMenu hand: aHandMorph]. aMenu addLine. self addToggleItemsToHaloMenu: aMenu. aMenu addLine. self addExportMenuItems: aMenu hand: aHandMorph. self addMiscExtrasTo: aMenu. self addDebuggingItemsTo: aMenu hand: aHandMorph. aMenu addLine. aMenu defaultTarget: aHandMorph. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/15/2000 16:13'! haloClass "Answer the name of the desired kind of HaloMorph to launch on behalf of the receiver" ^ #HaloMorph ! ! !Morph methodsFor: 'classification' stamp: 'jm 5/7/1998 13:45'! isRenderer "A *renderer* morph transforms the appearance of its submorph in some manner. For example, it might supply a drop shadow or scale and rotate the morph it encases. Answer true if this morph acts as a renderer. This default implementation returns false." "Details: A renderer is assumed to have a single submorph. Renderers may be nested to concatenate their transformations. It is useful to be able to find the outer-most renderer. This can be done by ascending the owner chain from the rendered morph. To find the morph being rendered, one can descend through the (singleton) submorph lists of the renderer chain until a non-renderer is encountered." ^ false ! ! !Morph methodsFor: 'meta-actions' stamp: 'BenjaminVanRyseghem 5/4/2013 12:55'! invokeMetaMenu: evt | menu | Smalltalk tools userManager canShowMorphHalo ifFalse: [ ^ self ]. menu := self buildMetaMenu: evt. menu addTitle: self externalName. self world ifNotNil: [ menu popUpEvent: evt in: self world ]! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'! bounds: aRectangle from: referenceMorph "Return the receiver's bounds as seen by aMorphs coordinate frame" owner ifNil: [^ aRectangle]. ^(owner transformFrom: referenceMorph) globalBoundsToLocal: aRectangle ! ! !Morph methodsFor: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:53'! hasTableLayoutString | layout | ^ ((layout := self layoutPolicy) notNil and: [layout isTableLayout]) -> 'table layout' translated! ! !Morph methodsFor: 'geometry' stamp: 'tk 7/14/2001 11:11'! setConstrainedPosition: aPoint hangOut: partiallyOutside "Change the position of this morph and and all of its submorphs to aPoint, but don't let me go outside my owner's bounds. Let me go within two pixels of completely outside if partiallyOutside is true." | trialRect delta boundingMorph bRect | owner ifNil:[^self]. trialRect := aPoint extent: self bounds extent. boundingMorph := self topRendererOrSelf owner. delta := boundingMorph ifNil: [0@0] ifNotNil: [ bRect := partiallyOutside ifTrue: [boundingMorph bounds insetBy: self extent negated + boundingMorph borderWidth + (2@2)] ifFalse: [boundingMorph bounds]. trialRect amountToTranslateWithin: bRect]. self position: aPoint + delta. self layoutChanged "So that, eg, surrounding text will readjust" ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 12/19/2009 23:17'! wantsBalloon "Answer true if receiver wants to show a balloon help text is a few moments." ^ (self balloonText notNil) and: [self balloonHelpEnabled]! ! !Morph methodsFor: 'meta-actions' stamp: 'wiz 11/9/2006 23:04'! potentialTargetsAt: aPoint "Return the potential targets for the receiver. This is derived from Morph>>potentialEmbeddingTargets." | realOwner | realOwner := self topRendererOrSelf owner ifNil: [^ #()]. ^ realOwner morphsAt: aPoint ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'di 9/14/1998 07:31'! handlesMouseOver: evt "Do I want to receive mouseEnter: and mouseLeave: when the button is up and the hand is empty? The default response is false, except if you have added sensitivity to mouseEnter: or mouseLeave:, using the on:send:to: mechanism." self eventHandler ifNotNil: [^ self eventHandler handlesMouseOver: evt]. ^ false! ! !Morph methodsFor: 'viewer' stamp: 'AlainPlantec 1/14/2010 09:41'! externalName ^ self assureExtension externalName ifNil: [super externalName]! ! !Morph methodsFor: 'selected object' stamp: 'dgd 8/28/2004 16:30'! selectedObject "answer the selected object for the hand or nil is none" ^ self primaryHand selectedObject! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:51'! dropEnabled "Get this morph's ability to add and remove morphs via drag-n-drop." ^(self valueOfProperty: #dropEnabled) == true ! ! !Morph methodsFor: 'classification' stamp: ''! isWorldMorph ^ false! ! !Morph methodsFor: 'event handling' stamp: 'sw 3/8/1999 00:17'! cursorPoint ^ self currentHand lastEvent cursorPoint! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 12:01'! highlightForDrop: aBoolean self setProperty: #highlightedForDrop toValue: aBoolean. self changed! ! !Morph methodsFor: 'card in a stack' stamp: 'stephane.ducasse 11/15/2008 14:34'! tabHitWithEvent: anEvent "The tab key was hit. The keyboard focus has referred this event to me, though this perhaps seems rather backwards. Anyway, the assumption is that I have the property #tabAmongFields, so now the task is to tab to the next field." | currentFocus fieldList anIndex itemToHighlight | currentFocus := anEvent hand keyboardFocus. fieldList := self allMorphs select: [:aMorph | (aMorph wouldAcceptKeyboardFocusUponTab) and: [aMorph isLocked not]]. fieldList isEmpty ifTrue:[^ self]. anIndex := fieldList indexOf: currentFocus ifAbsent: [nil]. itemToHighlight := fieldList atWrap: (anIndex ifNotNil: [anEvent shiftPressed ifTrue: [anIndex - 1] ifFalse: [anIndex + 1]] ifNil: [1]). anEvent hand newKeyboardFocus: itemToHighlight. self flag: #arNote. "really???" itemToHighlight editor selectAll. itemToHighlight invalidRect: itemToHighlight bounds ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'nk 10/16/2003 14:08'! removeAllMorphs | oldMorphs myWorld | myWorld := self world. (fullBounds notNil or:[myWorld notNil]) ifTrue:[self invalidRect: self fullBounds]. submorphs do: [:m | myWorld ifNotNil: [ m outOfWorld: myWorld ]. m privateOwner: nil]. oldMorphs := submorphs. submorphs := EmptyArray. oldMorphs do: [ :m | self removedMorph: m ]. self layoutChanged. ! ! !Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:22'! extension "answer the recevier's extension" ^ extension! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 5/4/2013 16:02'! attachKeymapCategory: aCategory self kmDispatcher attachCategory: aCategory.! ! !Morph methodsFor: 'menus' stamp: 'DamienCassou 9/29/2009 13:01'! exportAsBMP | fName | fName := UIManager default request:'Please enter the name' translated initialAnswer: self externalName,'.bmp'. fName isEmptyOrNil ifTrue:[^self]. self imageForm writeBMPfileNamed: fName.! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 3/1/2000 11:39'! comeToFrontAndAddHalo self comeToFront. self addHalo! ! !Morph methodsFor: 'meta-actions' stamp: 'EstebanLorenzano 5/14/2013 09:44'! buildMetaMenu: evt "Build the morph menu. This menu has two sections. The first section contains commands that are handled by the hand; the second contains commands handled by the argument morph." | menu | menu := UIManager default newMenuIn: self for: self. menu addStayUpItem. menu add: 'grab' translated action: #grabMorph:. menu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:. self maybeAddCollapseItemTo: menu. menu add: 'delete' translated action: #dismissMorph:. menu addLine. menu add: 'copy text' translated action: #clipText. menu addLine. menu add: 'go behind' translated action: #goBehind. menu add: 'add halo' translated action: #addHalo:. menu add: 'duplicate' translated action: #maybeDuplicateMorph:. self addEmbeddingMenuItemsTo: menu hand: evt hand. menu add: 'resize' translated action: #resizeMorph:. "Give the argument control over what should be done about fill styles" self addFillStyleMenuItems: menu hand: evt hand. self addDropShadowMenuItems: menu hand: evt hand. self addLayoutMenuItems: menu hand: evt hand. menu addUpdating: #hasClipSubmorphsString target: self selector: #changeClipSubmorphs argumentList: #(). menu addLine. menu add: 'inspect' translated selector: #inspectAt:event: argument: evt position. menu add: 'explore' translated action: #explore. menu lastItem icon: Smalltalk ui icons smallInspectItIcon. menu addLine.. menu add: 'show actions' translated action: #showActions. menu addLine. self addDebuggingItemsTo: menu hand: evt hand. self addCustomMenuItems: menu hand: evt hand. ^ menu ! ! !Morph methodsFor: 'geometry' stamp: ''! extent ^ bounds extent! ! !Morph methodsFor: 'private' stamp: ''! privateSubmorphs "Private!! Use 'submorphs' instead." ^ submorphs! ! !Morph methodsFor: 'other events' stamp: 'sw 8/1/2001 14:08'! menuButtonMouseEnter: event "The mouse entered a menu-button area; show the menu cursor temporarily" event hand showTemporaryCursor: Cursor menu! ! !Morph methodsFor: 'accessing' stamp: 'nk 9/4/2004 10:49'! scaleFactor ^self valueOfProperty: #scaleFactor ifAbsent: [ 1.0 ] ! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'SeanDeNigris 1/29/2013 11:23'! navigationKey: event "Check for tab key activity and change focus as appropriate. Check for menu key to do popup." event isUserInterrupt ifTrue: [ ^ true ]. (event keyCharacter = Character escape and: [ event anyModifierKeyPressed]) ifTrue: [ ^ self yellowButtonActivity: false ]. self window ifNotNil: [:win | (win handlesKeyStroke: event) ifTrue: [ (win keyStroke: event) ifTrue: [^true]]]. ^false! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 12/1/2010 09:32'! aboutToBeGrabbedBy: aHand "The receiver is being grabbed by a hand. Perform necessary adjustments (if any) and return the actual morph that should be added to the hand." | extentToHandToHand | self formerOwner: owner. self formerPosition: self position. (extentToHandToHand := self valueOfProperty: #expandedExtent) ifNotNil: [self removeProperty: #expandedExtent. self extent: extentToHandToHand]. ^self "Grab me"! ! !Morph methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:16'! balloonHelpEnabled ^ self theme settings balloonHelpEnabled! ! !Morph methodsFor: 'event handling' stamp: 'GuillermoPolito 4/22/2012 17:19'! handlesKeyUp: evt ^self handlesKeyboard: evt! ! !Morph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 7/22/2013 15:32'! changed: anAspect self flag: #GSoC. "Flag added by Benjamin Van Ryseghem the July 22, 2013 to remember to remove this line in a while" [ super changed: anAspect ] on: Exception do: []. self announcer announce: (MorphChanged new morph: self; selector: anAspect)! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 10/31/2000 20:45'! hResizingString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self hResizing! ! !Morph methodsFor: 'naming' stamp: 'dgd 2/16/2003 21:57'! setNamePropertyTo: aName "change the receiver's externalName" self assureExtension externalName: aName! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 10/25/1999 23:34'! replaceSubmorph: oldMorph by: newMorph | index itsPosition w | oldMorph stopStepping. itsPosition := oldMorph referencePositionInWorld. index := submorphs indexOf: oldMorph. oldMorph privateDelete. self privateAddMorph: newMorph atIndex: index. newMorph referencePositionInWorld: itsPosition. (w := newMorph world) ifNotNil: [w startSteppingSubmorphsOf: newMorph]! ! !Morph methodsFor: 'initialize' stamp: 'ar 1/31/2001 13:57'! intoWorld: aWorld "The receiver has just appeared in a new world. Note: * aWorld can be nil (due to optimizations in other places) * owner is already set * owner's submorphs may not include receiver yet. Important: Keep this method fast - it is run whenever morphs are added." aWorld ifNil:[^self]. self wantsSteps ifTrue:[aWorld startStepping: self]. self submorphsDo:[:m| m intoWorld: aWorld]. ! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'! maxCellSize "Layout specific. This property specifies the maximum size of a table cell." | props | props := self layoutProperties. ^props ifNil:[SmallInteger maxVal] ifNotNil:[props maxCellSize].! ! !Morph methodsFor: 'rotate scale and flex' stamp: 'sw 3/30/2005 03:44'! addFlexShell "Wrap a rotating and scaling shell around this morph." | oldHalo flexMorph myWorld anIndex | myWorld := self world. oldHalo := self halo. anIndex := self owner submorphIndexOf: self. self owner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self) asElementNumber: anIndex. self transferStateToRenderer: flexMorph. oldHalo ifNotNil: [oldHalo setTarget: flexMorph]. myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: flexMorph]. ^ flexMorph! ! !Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:57'! isSticky "answer whether the receiver is Sticky" extension ifNil: [^ false]. ^ extension sticky! ! !Morph methodsFor: 'drop shadows' stamp: 'GuillermoPolito 5/29/2011 14:48'! addDropShadowMenuItems: aMenu hand: aHand | menu | menu := UIManager default newMenuIn: self for: self. menu addUpdating: #hasDropShadowString action: #toggleDropShadow. menu addLine. menu add: 'shadow color...' translated target: self selector: #changeShadowColor. menu add: 'shadow offset...' translated target: self selector: #setShadowOffset:. aMenu add: 'drop shadow' translated subMenu: menu.! ! !Morph methodsFor: 'menus' stamp: 'sw 6/12/2001 21:08'! presentHelp "Present a help message if there is one available" self inform: 'Sorry, no help has been provided here yet.'! ! !Morph methodsFor: 'drawing' stamp: ' 9/3/2000 13:55'! drawMouseDownHighlightOn: aCanvas self highlightedForMouseDown ifTrue: [ aCanvas frameRectangle: self fullBounds color: self color darker darker].! ! !Morph methodsFor: 'menus' stamp: 'SeanDeNigris 1/23/2014 00:23'! changeColor | dialog | dialog := ColorSelectorDialogWindow new title: 'Choose color'; selectedColor: self color. self openModal: dialog. dialog cancelled ifFalse: [self fillStyle: dialog selectedColor] ! ! !Morph methodsFor: 'user interface' stamp: 'MarianoMartinezPeck 8/24/2012 15:28'! initialExtent | ext | (ext := self valueOfProperty: #initialExtent) ifNotNil: [^ ext]. ^700@500! ! !Morph methodsFor: 'layout-properties' stamp: 'md 2/27/2006 09:58'! layoutProperties "Return the current layout properties associated with the receiver" ^ extension ifNotNil: [ extension layoutProperties]! ! !Morph methodsFor: 'rotate scale and flex' stamp: 'AlainPlantec 5/7/2010 23:44'! degreesOfFlex "Return any rotation due to flexing" "NOTE: because renderedMorph, which is used by the halo to set heading, goes down through dropShadows as well as transformations, we need this method (and its other implems) to come back up through such a chain." ^ 0.0! ! !Morph methodsFor: 'private' stamp: 'jm 5/29/1998 21:28'! privateColor: aColor color := aColor. ! ! !Morph methodsFor: 'updating' stamp: 'IgorStasenko 8/27/2013 16:29'! addDependent: anObject self announcer weak on: MorphChanged , MorphChangedWithArguments send: #handleUpdate: to: anObject. ^ anObject! ! !Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:36'! startStepping: aSelector at: scheduledTime arguments: args stepTime: stepTime "Start stepping the receiver" | w | w := self world. w ifNotNil: [ w startStepping: self at: scheduledTime selector: aSelector arguments: args stepTime: stepTime. self changed].! ! !Morph methodsFor: 'submorphs-add/remove' stamp: ''! addMorph: aMorph self addMorphFront: aMorph.! ! !Morph methodsFor: 'accessing - properties' stamp: 'tk 10/9/2002 08:30'! setProperties: aList "Set many properties at once from a list of prop, value, prop, value" 1 to: aList size by: 2 do: [:ii | self setProperty: (aList at: ii) toValue: (aList at: ii+1)].! ! !Morph methodsFor: 'menus' stamp: 'dgd 9/22/2004 20:30'! model ^ nil ! ! !Morph methodsFor: 'menu' stamp: 'nk 3/10/2004 19:51'! outermostOwnerWithYellowButtonMenu "Answer me or my outermost owner that is willing to contribute menu items to a context menu. Don't include the world." | outermost | outermost := self outermostMorphThat: [ :ea | ea isWorldMorph not and: [ ea hasYellowButtonMenu ]]. ^outermost ifNil: [ self hasYellowButtonMenu ifTrue: [ self ] ifFalse: []] ! ! !Morph methodsFor: 'menus' stamp: 'sw 11/27/2001 14:36'! addAddHandMenuItemsForHalo: aMenu hand: aHandMorph "The former charter of this method was to add halo menu items that pertained specifically to the hand. Over time this charter has withered, and most morphs reimplement this method simply to add their morph-specific menu items. So in the latest round, all other implementors in the standard image have been removed. However, this is left here as a hook for the benefit of existing code in client uses." ! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:56'! disableTableLayout "Layout specific. Disable laying out the receiver in table layout" | props | props := self layoutProperties. ^props ifNil:[false] ifNotNil:[props disableTableLayout].! ! !Morph methodsFor: 'drawing' stamp: 'nk 9/1/2004 15:08'! imageForm: depth backgroundColor: aColor forRectangle: rect | canvas | canvas := Display defaultCanvasClass extent: rect extent depth: depth. canvas translateBy: rect topLeft negated during:[:tempCanvas| tempCanvas fillRectangle: rect color: aColor. tempCanvas fullDrawMorph: self]. ^ canvas form offset: rect topLeft! ! !Morph methodsFor: 'event handling' stamp: 'nk 3/10/2004 19:48'! handlerForYellowButtonDown: anEvent "Return the (prospective) handler for a mouse down event with the yellow button pressed. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event." (self hasYellowButtonMenu or: [ self handlesMouseDown: anEvent ]) ifFalse: [ ^ nil]. "Not interested." anEvent handler ifNil: [^ self]. "Nobody else was interested" "Same priority but I am innermost." ^ self mouseDownPriority >= anEvent handler mouseDownPriority ifFalse: [nil ] ifTrue: [self]! ! !Morph methodsFor: 'meta-actions' stamp: 'HenrikSperreJohansen 5/21/2010 13:33'! changeColorTarget: anObject selector: aSymbol originalColor: aColor hand: aHand "Put up a color picker for changing some kind of color." (UIManager default chooseColor: aColor) ifNotNil: [:nc | anObject perform: aSymbol with: nc]. ! ! !Morph methodsFor: 'geometry' stamp: 'sma 2/5/2000 13:58'! screenRectangle "For compatibility only" ^ self fullBounds! ! !Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:47'! changeDocumentAnchor "Change the anchor from/to document anchoring" | newType | newType := self textAnchorType == #document ifTrue: [#paragraph] ifFalse: [ #document]. owner isTextMorph ifTrue: [owner anchorMorph: self at: self position type: newType]! ! !Morph methodsFor: 'visual properties' stamp: 'gvc 9/11/2009 17:27'! cornerStyle "Returns one of the following symbols: #square #rounded according to the current corner style." self assureExtension. ^extension cornerStyle ifNil: [#square]! ! !Morph methodsFor: 'geometry' stamp: 'ar 12/22/2001 22:43'! innerBounds "Return the inner rectangle enclosed by the bounds of this morph excluding the space taken by its borders. For an unbordered morph, this is just its bounds." ^ self bounds insetBy: self borderWidth! ! !Morph methodsFor: 'geometry' stamp: 'wiz 11/25/2004 12:54'! position: aPoint "Change the position of this morph and and all of its submorphs. " | delta box | delta := aPoint asNonFractionalPoint - bounds topLeft. (delta x = 0 and: [delta y = 0]) ifTrue: [^ self]. "Null change" box := self fullBounds. (delta dotProduct: delta) > 100 ifTrue: ["e.g., more than 10 pixels moved" self invalidRect: box. self invalidRect: (box translateBy: delta)] ifFalse: [self invalidRect: (box merge: (box translateBy: delta))]. self privateFullMoveBy: delta. owner ifNotNil: [owner layoutChanged]! ! !Morph methodsFor: 'menus' stamp: 'StephaneDucasse 4/22/2012 16:53'! resistsRemovalString "Answer the string to be shown in a menu to represent the 'resistsRemoval' status" ^ (self resistsRemoval) -> 'resist being deleted' translated! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'sw 1/9/2001 12:30'! findDeeplyA: aClass "Return a morph in the submorph tree of the receiver that is descended from the given class. Return nil if there is no such morph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart." ^ (self allMorphs copyWithout: self) detect: [:p | p isKindOf: aClass] ifNone: [nil]! ! !Morph methodsFor: 'menu' stamp: 'AlainPlantec 12/19/2009 23:13'! addYellowButtonMenuItemsTo: aMenu event: evt "Populate aMenu with appropriate menu items for a yellow-button (context menu) click." aMenu defaultTarget: self. self defaultYellowButtonMenuEnabled ifFalse: [^ self]. aMenu addStayUpItem. self addModelYellowButtonItemsTo: aMenu event: evt. self cmdGesturesEnabled ifTrue: [ aMenu addLine. aMenu add: 'inspect' translated action: #inspect]. aMenu addLine. self isWorldMorph ifFalse: [aMenu add: 'delete' translated action: #delete]. self world selectedObject == self ifTrue: [aMenu add: 'halo off' translated action: #removeHalo] ifFalse: [aMenu add: 'halo on' translated action: #addHalo]. (self isWorldMorph or: [self wantsToBeTopmost]) ifFalse: [ aMenu addLine. aMenu add: 'send to back' translated action: #goBehind. aMenu add: 'bring to front' translated action: #comeToFront. self addEmbeddingMenuItemsTo: aMenu hand: evt hand]. self isWorldMorph ifFalse: [ self isFullOnScreen ifFalse: [aMenu add: 'move onscreen' translated action: #goHome]]. self addLayoutMenuItems: aMenu hand: evt hand. (owner notNil and: [owner isTextMorph]) ifTrue: [self addTextAnchorMenuItems: aMenu hand: evt hand]. self isWorldMorph ifFalse: [ aMenu addLine. self addToggleItemsToHaloMenu: aMenu]. aMenu addLine. self isWorldMorph ifFalse: [aMenu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:]. (self allStringsAfter: nil) isEmpty ifFalse: [aMenu add: 'copy text' translated action: #clipText]. self addExportMenuItems: aMenu hand: evt hand. aMenu addLine. aMenu add: 'adhere to edge...' translated action: #adhereToEdge. self addCustomMenuItems: aMenu hand: evt hand! ! !Morph methodsFor: 'meta-actions' stamp: 'MarcusDenker 11/28/2009 14:25'! targetWith: evt "Some other morph become target of the receiver" | newTarget | newTarget := UIManager default chooseFrom: (self potentialTargets collect: [:t | t class name asString]) values: self potentialTargets title: (self externalName, ' targets...' translated). newTarget ifNil:[^self]. self target: newTarget.! ! !Morph methodsFor: 'event handling' stamp: ''! transformFromWorld "Return a transform to map world coordinates into my local coordinates" ^ self transformFrom: nil! ! !Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:26'! arrangeToStartSteppingIn: aWorld "Start getting sent the 'step' message in aWorld. Like startSteppingIn:, but without the initial one to get started'" aWorld ifNotNil: [aWorld startStepping: self. self changed]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 18:36'! dragSelectionColor ^ Color magenta! ! !Morph methodsFor: 'accessing' stamp: 'sw 10/23/1999 22:35'! modelOrNil ^ nil! ! !Morph methodsFor: 'event handling' stamp: 'GuillermoPolito 7/24/2012 13:07'! on: eventName send: selector to: recipient self eventHandler ifNil: [self eventHandler: MorphicEventHandler new]. self eventHandler on: eventName send: selector to: recipient! ! !Morph methodsFor: 'accessing' stamp: 'ar 8/15/2001 22:40'! colorForInsets "Return the color to be used for shading inset borders. The default is my own color, but it might want to be, eg, my owner's color. Whoever's color ends up prevailing, the color itself gets the last chance to determine, so that when, for example, an InfiniteForm serves as the color, callers won't choke on some non-Color object being returned" (color isColor and:[color isTransparent and:[owner notNil]]) ifTrue:[^owner colorForInsets]. ^ color colorForInsets ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:21'! enableDragNDrop: aBoolean "Set both properties at once" self separateDragAndDrop. self enableDrag: aBoolean. self enableDrop: aBoolean.! ! !Morph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:14'! canDrawBorder: aBorderStyle "Return true if the receiver can be drawn with the given border style." ^true! ! !Morph methodsFor: 'structure' stamp: 'dgd 9/18/2004 15:56'! isInSystemWindow "answer if the receiver is in a system window" ^ owner isMorph and:[owner isSystemWindow or:[owner isInSystemWindow]]! ! !Morph methodsFor: 'drawing' stamp: 'di 7/8/1998 12:42'! imageFormDepth: depth ^ self imageForm: depth forRectangle: self fullBounds ! ! !Morph methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 11/28/2013 17:21'! centerWidget: aWindow aWindow fullBounds; center: self center! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 10/29/1999 17:38'! setCenteredBalloonText: aString self setBalloonText: aString. self setProperty: #helpAtCenter toValue: true! ! !Morph methodsFor: 'menus' stamp: 'MarcusDenker 10/26/2011 14:49'! addFillStyleMenuItems: aMenu hand: aHand "Add the items for changing the current fill style of the Morph" | menu | menu := UIManager default newMenuIn: self for: self. self fillStyle addFillStyleMenuItems: menu hand: aHand from: self. menu addLine. menu add: 'solid fill' translated action: #useSolidFill. menu add: 'gradient fill' translated action: #useGradientFill. menu add: 'bitmap fill' translated action: #useBitmapFill. menu add: 'default fill' translated action: #useDefaultFill. aMenu add: 'fill style' translated subMenu: menu. ! ! !Morph methodsFor: 'thumbnail' stamp: 'dgd 9/12/2004 21:12'! icon "Answer a form with an icon to represent the receiver" ^ self valueOfProperty: #icon! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/8/2007 13:41'! previousMorphWantingFocus "Answer the previous morph that wants keyboard focus." |m| m := self previousMorphInWindow ifNil: [^nil]. [m = self or: [m wantsKeyboardFocusNavigation]] whileFalse: [m := m previousMorphInWindow ifNil: [^nil]]. ^m wantsKeyboardFocusNavigation ifTrue: [m] ! ! !Morph methodsFor: 'geometry' stamp: 'sw 2/16/1999 22:05'! shiftSubmorphsOtherThan: listNotToShift by: delta | rejectList | rejectList := listNotToShift ifNil: [OrderedCollection new]. (submorphs copyWithoutAll: rejectList) do: [:m | m position: (m position + delta)]! ! !Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 08:33'! sticky: aBoolean "change the receiver's sticky property" extension sticky: aBoolean! ! !Morph methodsFor: 'halos and balloon help' stamp: 'StephaneDucasse 9/7/2011 21:23'! editBalloonHelpContent: aString | reply | reply := UIManager default multiLineRequest: 'Edit the balloon help text for ' translated, self externalName initialAnswer: (aString ifNil: [self noHelpString] ifNotNil: [aString]) answerHeight: 200. reply ifNil: [^ self]. "User cancelled out of the dialog" (reply isEmpty or: [reply asString = self noHelpString]) ifTrue: [self setBalloonText: nil] ifFalse: [self setBalloonText: reply]! ! !Morph methodsFor: 'menus' stamp: 'sw 4/27/1998 03:44'! addCustomHaloMenuItems: aMenu hand: aHandMorph "Add morph-specific items to the given menu which was invoked by the given hand from the halo. To get started, we defer to the counterpart method used with the option-menu, but in time we can have separate menu choices for halo-menus and for option-menus" self addCustomMenuItems: aMenu hand: aHandMorph! ! !Morph methodsFor: 'accessing' stamp: 'ar 12/18/2001 20:09'! adoptPaneColor: paneColor self submorphsDo:[:m| m adoptPaneColor: paneColor].! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'! cellInset: aNumber "Layout specific. This property specifies an extra inset for each cell in the layout." self assureTableProperties cellInset: aNumber. self layoutChanged.! ! !Morph methodsFor: 'events-processing' stamp: 'marcus.denker 8/24/2008 22:02'! transformedFrom: uberMorph "Return a transform to map coordinates of uberMorph, a morph above me in my owner chain, into the coordinates of MYSELF not any of my children." "self flag: #arNote." "rename this method" owner ifNil:[^IdentityTransform basicNew]. ^ (owner transformFrom: uberMorph)! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'! maxCellSize: aPoint "Layout specific. This property specifies the maximum size of a table cell." self assureTableProperties maxCellSize: aPoint. self layoutChanged.! ! !Morph methodsFor: 'Morphic-Base-Worlds' stamp: 'dgd 8/28/2004 18:43'! pasteUpMorphHandlingTabAmongFields "Answer the nearest PasteUpMorph in my owner chain that has the tabAmongFields property, or nil if none" | aPasteUp | aPasteUp := self owner. [aPasteUp notNil] whileTrue: [aPasteUp tabAmongFields ifTrue: [^ aPasteUp]. aPasteUp := aPasteUp owner]. ^ nil! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 10/20/2011 23:33'! attachKeymapCategory: aCategoryName onProperty: aProperty self kmDispatcher attachCategory: aCategoryName onProperty: aProperty! ! !Morph methodsFor: 'classification' stamp: 'jm 4/17/1998 00:44'! isFlexMorph ^ false ! ! !Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 16:38'! layoutInset: aNumber "Return the extra inset for layouts" self assureTableProperties layoutInset: aNumber. self layoutChanged.! ! !Morph methodsFor: 'user interface' stamp: 'StephaneDucasse 5/13/2012 20:49'! doFastReframe: ptName | newBounds | "For fast display, only higlight the rectangle during loop" newBounds := self boundsInWorld newRectButtonPressedDo: [:f :pt | f withSideOrCorner: ptName setToPoint: pt minExtent: self minimumExtent]. Display deferUpdatesIn: Display boundingBox while: [ self bounds: newBounds]. ^newBounds.! ! !Morph methodsFor: 'drawing' stamp: 'MarcusDenker 10/21/2013 14:22'! hide owner ifNil: [ ^ self ]. self visible ifFalse: [ ^ self ]. self visible: false. self changed! ! !Morph methodsFor: 'geometry' stamp: 'sw 8/20/97 23:04'! topRight ^ bounds topRight! ! !Morph methodsFor: 'debug and other' stamp: 'sw 11/5/1998 20:31'! inspectOwnerChain self ownerChain inspectWithLabel: 'Owner chain for ', self printString! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:03'! deleteBalloon "If I am showing a balloon, delete it." | w | w := self world ifNil:[^self]. w deleteBalloonTarget: self.! ! !Morph methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 13:03'! defaultYellowButtonMenuEnabled ^ self class defaultYellowButtonMenuEnabled! ! !Morph methodsFor: 'testing' stamp: 'StephaneDucasse 7/18/2010 16:33'! wantsSteps "Return true if the receiver overrides the default Morph step method." "Details: Find first class in superclass chain that implements #step and return true if it isn't class Morph." | c | c := self class. [c includesSelector: #step] whileFalse: [c := c superclass]. ^ c ~= Morph! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:55'! addMorphBack: aMorph ^self privateAddMorph: aMorph atIndex: submorphs size+1! ! !Morph methodsFor: 'accessing' stamp: 'nk 4/15/2004 10:55'! borderColor: aColorOrSymbolOrNil "Unfortunately, the argument to borderColor could be more than just a color. It could also be a symbol, in which case it is to be interpreted as a style identifier. But I might not be able to draw that kind of border, so it may have to be ignored. Or it could be nil, in which case I should revert to the default border." | style newStyle | style := self borderStyle. style baseColor = aColorOrSymbolOrNil ifTrue: [^ self]. aColorOrSymbolOrNil isColor ifTrue: [style style = #none "default border?" ifTrue: [self borderStyle: (SimpleBorder width: 0 color: aColorOrSymbolOrNil)] ifFalse: [style baseColor: aColorOrSymbolOrNil. self changed]. ^ self]. self borderStyle: ( ({ nil. #none } includes: aColorOrSymbolOrNil) ifTrue: [BorderStyle default] ifFalse: [ "a symbol" self doesBevels ifFalse: [ ^self ]. newStyle := (BorderStyle perform: aColorOrSymbolOrNil) color: style color; width: style width; yourself. (self canDrawBorder: newStyle) ifTrue: [newStyle] ifFalse: [style]])! ! !Morph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 1/18/2012 18:54'! mouseLeave: evt "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it." ^ self eventHandler ifNotNil: [self eventHandler mouseLeave: evt fromMorph: self]. ! ! !Morph methodsFor: 'event handling' stamp: 'sw 11/3/97 02:11'! wantsKeyboardFocusFor: aSubmorph "Answer whether a plain mouse click on aSubmorph, a text-edit-capable thing, should result in a text selection there" ^ false! ! !Morph methodsFor: 'rotate scale and flex' stamp: 'ar 2/16/1999 18:59'! newTransformationMorph ^TransformationMorph new! ! !Morph class methodsFor: '*Spec-Inspector' stamp: 'CamilloBruni 9/22/2013 19:40'! additionalInspectorClasses ^ super additionalInspectorClasses, { EyeViewHierarchyInspector. EyeMorphViewer }! ! !Morph class methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:12'! cmdGesturesEnabled ^ CmdGesturesEnabled ifNil: [CmdGesturesEnabled := true]! ! !Morph class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/25/2013 18:27'! announcer ^ announcer ifNil: [ announcer := Announcer new ].! ! !Morph class methodsFor: 'settings' stamp: 'usmanbhatti 3/6/2012 19:23'! halosEnabled ^ HalosEnabled ifNil: [ HalosEnabled := true ]! ! !Morph class methodsFor: 'settings' stamp: 'SeanDeNigris 4/24/2012 19:51'! cycleHalosBothDirections ^ CycleHalosBothDirections ifNil: [ CycleHalosBothDirections := false ].! ! !Morph class methodsFor: '*Polymorph-Widgets' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme "Answer the ui theme that provides controls." ^ Smalltalk ui theme! ! !Morph class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 13:09'! defaultYellowButtonMenuEnabled ^ DefaultYellowButtonMenuEnabled ifNil: [DefaultYellowButtonMenuEnabled := false]! ! !Morph class methodsFor: 'initialize-release' stamp: ''! initialize "Morph initialize" "this empty array object is shared by all morphs with no submorphs:" EmptyArray := Array new. ! ! !Morph class methodsFor: 'misc' stamp: 'MarcusDenker 10/21/2013 14:22'! morphsUnknownToTheirOwners "Return a list of all morphs (other than HandMorphs) whose owners do not contain them in their submorph lists" "Morph morphsUnknownToTheirOwners" | problemMorphs | problemMorphs := OrderedCollection new. self allSubInstances do: [ :m | | itsOwner | (m isHandMorph not and: [ (itsOwner := m owner) notNil and: [ (itsOwner submorphs includes: m) not ] ]) ifTrue: [ problemMorphs add: m ] ]. ^ problemMorphs! ! !Morph class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 13:02'! defaultYellowButtonMenuEnabled: aBoolean DefaultYellowButtonMenuEnabled := aBoolean! ! !Morph class methodsFor: 'settings' stamp: 'BenjaminVanRyseghem 3/6/2012 19:38'! halosEnabled: aBoolean HalosEnabled := aBoolean! ! !Morph class methodsFor: 'settings' stamp: 'SeanDeNigris 4/24/2012 19:52'! cycleHalosBothDirections: aBoolean CycleHalosBothDirections := aBoolean.! ! !Morph class methodsFor: '*Polymorph-Widgets-Themes' stamp: 'YuriyTymchuk 12/20/2013 11:19'! systemIcon ^ Smalltalk ui icons iconNamed: #morphIcon! ! !Morph class methodsFor: 'instance creation' stamp: ''! newBounds: bounds ^ self new privateBounds: bounds! ! !Morph class methodsFor: 'initialize-release' stamp: 'IgorStasenko 4/15/2011 17:22'! unload Smalltalk tools fileList unregisterFileReader: self ! ! !Morph class methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:12'! cmdGesturesEnabled: aBoolean CmdGesturesEnabled := aBoolean! ! !Morph class methodsFor: 'misc' stamp: 'PeterHugossonMiller 9/2/2009 16:13'! obtainArrowheadFor: aPrompt defaultValue: defaultPoint "Allow the user to supply a point to serve as an arrowhead size. Answer nil if we fail to get a good point" | result | result := UIManager default request: aPrompt initialAnswer: defaultPoint asString. result isEmptyOrNil ifTrue: [^ nil]. ^ [(Point readFrom: result readStream)] on: Error do: [:ex | nil].! ! !Morph class methodsFor: 'instance creation' stamp: 'sw 8/4/97 12:05'! newSticky ^ self new beSticky! ! !Morph class methodsFor: 'instance creation' stamp: 'jm 5/29/1998 21:28'! newBounds: bounds color: color ^ (self new privateBounds: bounds) privateColor: color ! ! !Morph class methodsFor: 'settings' stamp: 'GuillermoPolito 3/19/2013 19:12'! morphNavigationShortcutsOn: aBuilder "Basic, general navigation shortcut among morphs. #MorphNoCtrl will not work for TextMorphs." (aBuilder shortcut: #navigateFocusForwardCtrl) category: #MorphFocusCtrlNavigation default: Character tab ctrl asKeyCombination do: [ :target :morph :event | morph navigateFocusForward ]. (aBuilder shortcut: #navigateFocusBackwardCtrl) category: #MorphFocusCtrlNavigation default: Character tab shift ctrl asKeyCombination do: [ :target :morph :event | morph navigateFocusBackward ]. (aBuilder shortcut: #navigateFocusForward) category: #MorphFocusNavigation default: Character tab asKeyCombination do: [ :target :morph :event | morph navigateFocusForward ]. (aBuilder shortcut: #navigateFocusBackward) category: #MorphFocusNavigation default: Character tab shift asKeyCombination do: [ :target :morph :event | morph navigateFocusBackward ]! ! !MorphAnnouncement commentStamp: ''! I am an abstract announcement for morphic events. I carry the morph where the event has ocurred. My subclasses should add information for more precise events.! !MorphAnnouncement methodsFor: 'accessing' stamp: 'GuillermoPolito 5/1/2012 19:47'! morph ^ morph! ! !MorphAnnouncement methodsFor: 'accessing' stamp: 'GuillermoPolito 5/1/2012 19:47'! morph: anObject morph := anObject! ! !MorphAnnouncement class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/1/2012 19:48'! morph: aMorph ^self new morph: aMorph; yourself! ! !MorphBugs methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2013 20:23'! adhereToEdgeTest "self new adhereToEdgeTest" "self run: #adhereToEdgeTest" | r | r := Morph new openInWorld. [ r adhereToEdge: #eternity ] ensure: [ r delete ]. r delete. ^ true! ! !MorphChanged commentStamp: ''! I am raised when a morph property changed, and should be propagated to dependents! !MorphChanged methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/22/2013 15:05'! selector ^ selector! ! !MorphChanged methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/22/2013 15:05'! selector: anObject selector := anObject! ! !MorphChanged methodsFor: 'delivering' stamp: 'IgorStasenko 8/27/2013 16:27'! deliverTo: aHandler ^ aHandler update: selector ! ! !MorphChangedWithArguments commentStamp: ''! I am an announcement raised when a Morph changed and need to propagate the information to dependents. In addition, I also propagate a value! !MorphChangedWithArguments methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/23/2013 12:32'! arguments: anObject arguments := anObject! ! !MorphChangedWithArguments methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/23/2013 12:32'! arguments ^ arguments! ! !MorphChangedWithArguments methodsFor: 'delivering' stamp: 'IgorStasenko 8/27/2013 16:28'! deliverTo: aHandler ^ aHandler update: selector with: arguments ! ! !MorphDeleted commentStamp: ''! I'm an announcement raised when a morph is deleted. Subscribe to me when you want to do things after the morph is opened. Take into account that when a morph is deleted, all it's children also get deleted and they raise a similar announcement.! !MorphDropListMorph commentStamp: 'gvc 5/18/2007 12:43'! Drop list supporting morphs in list.! !MorphDropListMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 4/24/2012 15:22'! font "Answer the content font" ^self listFont! ! !MorphDropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/17/2006 13:35'! updateContents "Update the contents." |item| self contentMorph removeAllMorphs. self listSelectionIndex > 0 ifTrue: [item := (self list at: self listSelectionIndex) copy hResizing: #spaceFill; vResizing: #rigid. self contentMorph addMorph: item]! ! !MorphDropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 9/29/2006 11:58'! updateContentColor: paneColor "Change the content text color." ! ! !MorphDropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/17/2006 11:43'! listMorphClass "Answer the class for a new list morph" ^PluggableMorphListMorph! ! !MorphDropListMorph methodsFor: 'as yet unclassified' stamp: 'gvc 6/17/2006 12:11'! newContentMorph "Answer a new content morph" ^Morph new changeTableLayout; listDirection: #leftToRight; wrapCentering: #center; vResizing: #spaceFill; hResizing: #spaceFill; layoutInset: 2; color: Color transparent; borderWidth: 0; clipSubmorphs: true; lock! ! !MorphDropListMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 4/24/2012 15:22'! font: aFont "Set the list font" self listFont: aFont! ! !MorphEventSubscription commentStamp: 'GuillermoPolito 4/22/2012 19:17'! I represent a subscription to an event. I'm kind of an announcement, that's why I will be replaced by them soon :)! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:36'! selector ^ selector! ! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:39'! valueParameter: anObject valueParameter := anObject! ! !MorphEventSubscription methodsFor: 'events-triggering' stamp: 'GuillermoPolito 4/22/2012 18:40'! click: anEvent fromMorph: aMorph ^self notify: anEvent from: aMorph! ! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:36'! recipient ^ recipient! ! !MorphEventSubscription methodsFor: 'events-triggering' stamp: 'GuillermoPolito 4/22/2012 18:41'! mouseEnter: anEvent fromMorph: aMorph ^self notify: anEvent from: aMorph! ! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:36'! selector: anObject selector := anObject! ! !MorphEventSubscription methodsFor: 'events-triggering' stamp: 'GuillermoPolito 4/22/2012 18:40'! doubleClick: anEvent fromMorph: aMorph ^self notify: anEvent from: aMorph! ! !MorphEventSubscription methodsFor: 'events-triggering' stamp: 'GuillermoPolito 4/22/2012 18:41'! mouseLeave: anEvent fromMorph: aMorph ^self notify: anEvent from: aMorph! ! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:36'! event ^ event! ! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:36'! event: anEvent event := anEvent! ! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:36'! recipient: anObject recipient := anObject! ! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:39'! valueParameter ^ valueParameter! ! !MorphEventSubscription methodsFor: 'events-triggering' stamp: 'GuillermoPolito 4/22/2012 18:42'! doubleClickTimeout: anEvent fromMorph: aMorph ^self notify: anEvent from: aMorph! ! !MorphEventSubscription methodsFor: 'events-triggering' stamp: 'GuillermoPolito 4/22/2012 18:39'! notify: anEvent from: sourceMorph | arity | recipient ifNil: [^ self]. arity := selector numArgs. arity = 0 ifTrue: [^ recipient perform: selector]. arity = 1 ifTrue: [^ recipient perform: selector with: anEvent]. arity = 2 ifTrue: [^ recipient perform: selector with: anEvent with: sourceMorph]. arity = 3 ifTrue: [^ recipient perform: selector with: valueParameter with: anEvent with: sourceMorph]. self error: 'Event handling selectors must be Symbols and take 0-3 arguments'! ! !MorphEventSubscription class methodsFor: 'instance creation' stamp: 'GuillermoPolito 4/22/2012 18:35'! on: anEvent send: aSelector to: anObject ^self new event: anEvent; selector: aSelector; recipient: anObject; yourself! ! !MorphEventSubscription class methodsFor: 'instance creation' stamp: 'GuillermoPolito 4/22/2012 19:21'! on: anEvent send: aMessageSelector to: anObject withValue: aValue ^self new event: anEvent; selector: aMessageSelector; recipient: anObject; valueParameter: aValue; yourself! ! !MorphExtension commentStamp: ''! MorphExtension provides access to extra instance state that is not required in most simple morphs. This allows simple morphs to remain relatively lightweight while still admitting more complex structures as necessary. The otherProperties field takes this policy to the extreme of allowing any number of additional named attributes, albeit at a certain cost in speed and space.! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:00'! valueOfProperty: aSymbol "answer the value of the receiver's property named aSymbol" ^ self valueOfProperty: aSymbol ifAbsent: []! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:47'! sticky: aBoolean "change the receiver's sticky property" sticky := aBoolean! ! !MorphExtension methodsFor: 'other' stamp: 'ClementBera 7/30/2013 11:07'! isDefault "Return true if the receiver is a default and can be omitted" locked == true ifTrue: [^ false]. visible == false ifTrue: [^ false]. sticky == true ifTrue: [^ false]. balloonText ifNotNil: [^ false]. externalName ifNotNil: [^ false]. eventHandler ifNotNil: [^ false]. otherProperties ifNotNil: [otherProperties isEmpty ifFalse: [^ false]]. ^ true! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 18:10'! cornerStyle "Answer the value of cornerStyle" ^cornerStyle! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:41'! assureOtherProperties "creates an otherProperties for the receiver if needed" otherProperties ifNil: [self initializeOtherProperties]. ^ otherProperties! ! !MorphExtension methodsFor: 'connectors-copying' stamp: 'nk 5/1/2004 17:39'! veryDeepFixupWith: deepCopier "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. otherProperties ifNil: [ ^self ]. "Properties whose values are only copied weakly replace those values if they were copied via another path" self copyWeakly do: [ :propertyName | otherProperties at: propertyName ifPresent: [ :property | otherProperties at: propertyName put: (deepCopier references at: property ifAbsent: [ property ])]]. ! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 18:12'! fillStyle "Answer the value of fillStyle" ^ fillStyle! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:37'! removeOtherProperties "Remove the 'other' properties" otherProperties := nil! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:51'! eventHandler "answer the receiver's eventHandler" ^ eventHandler ! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:43'! removeProperty: aSymbol "removes the property named aSymbol if it exists" otherProperties ifNil: [^ self]. otherProperties removeKey: aSymbol ifAbsent: []. otherProperties isEmpty ifTrue: [self removeOtherProperties]! ! !MorphExtension methodsFor: 'viewer' stamp: 'di 8/10/1998 14:47'! externalName ^ externalName! ! !MorphExtension methodsFor: 'initialization' stamp: 'StephaneDucasse 7/18/2010 16:28'! initialize locked := false. visible := true. sticky := false. ! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:04'! otherProperties "answer the receiver's otherProperties" ^ otherProperties! ! !MorphExtension methodsFor: 'printing' stamp: 'MarcusDenker 10/21/2013 14:23'! printOn: aStream "Append to the argument, aStream, a sequence of characters that identifies the receiver." super printOn: aStream. aStream space; nextPut: $(; print: self identityHash; nextPut: $). locked == true ifTrue: [ aStream nextPutAll: ' [locked] ' ]. visible == false ifTrue: [ aStream nextPutAll: '[not visible] ' ]. sticky == true ifTrue: [ aStream nextPutAll: ' [sticky] ' ]. balloonText ifNotNil: [ aStream nextPutAll: ' [balloonText] ' ]. externalName ifNotNil: [ aStream nextPutAll: ' [externalName = ' , externalName; nextPutAll: ' ] ' ]. eventHandler ifNotNil: [ aStream nextPutAll: ' [eventHandler = ' , eventHandler printString; nextPutAll: '] ' ]. (otherProperties isNil or: [ otherProperties isEmpty ]) ifTrue: [ ^ self ]. aStream nextPutAll: ' [other: '. self otherProperties keysDo: [ :aKey | aStream nextPutAll: ' (' , aKey , ' -> ' , (self otherProperties at: aKey) printString; nextPutAll: ')' ]. aStream nextPut: $]! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:43'! valueOfProperty: aSymbol ifAbsent: aBlock "if the receiver possesses a property of the given name, answer its value. If not then evaluate aBlock and answer the result of this block evaluation" otherProperties ifNil: [^ aBlock value]. ^ otherProperties at: aSymbol ifAbsent: [^ aBlock value]! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 16:55'! fillStyle: anObject "Set the value of fillStyle" fillStyle := anObject! ! !MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:55'! visible: newValue visible := newValue! ! !MorphExtension methodsFor: 'connectors-copying' stamp: 'MarcusDenker 9/7/2010 17:00'! veryDeepInner: deepCopier "Copy all of my instance variables. Some otherProperties need to be not copied at all, but shared. Their names are given by copyWeakly. Some otherProperties should not be copied or shared. Their names are given by propertyNamesNotCopied. This is special code for the dictionary. See DeepCopier, and veryDeepFixupWith:." | namesOfWeaklyCopiedProperties weaklyCopiedValues | super veryDeepInner: deepCopier. locked := locked veryDeepCopyWith: deepCopier. visible := visible veryDeepCopyWith: deepCopier. sticky := sticky veryDeepCopyWith: deepCopier. balloonText := balloonText veryDeepCopyWith: deepCopier. externalName := externalName veryDeepCopyWith: deepCopier. eventHandler := eventHandler veryDeepCopyWith: deepCopier. "has its own restrictions" fillStyle := fillStyle veryDeepCopyWith: deepCopier. layoutPolicy := layoutPolicy veryDeepCopyWith: deepCopier. layoutFrame := layoutFrame veryDeepCopyWith: deepCopier. layoutProperties := layoutProperties veryDeepCopyWith: deepCopier. borderStyle := borderStyle veryDeepCopyWith: deepCopier. cornerStyle := cornerStyle veryDeepCopyWith: deepCopier. actionMap := actionMap veryDeepCopyWith: deepCopier. clipSubmorphs := clipSubmorphs veryDeepCopyWith: deepCopier. otherProperties ifNil: [ ^self ]. otherProperties := otherProperties copy. self propertyNamesNotCopied do: [ :propName | otherProperties removeKey: propName ifAbsent: [] ]. namesOfWeaklyCopiedProperties := self copyWeakly. weaklyCopiedValues := namesOfWeaklyCopiedProperties collect: [ :propName | otherProperties removeKey: propName ifAbsent: [] ]. "Now copy all the others." otherProperties := otherProperties veryDeepCopyWith: deepCopier. "And replace the weak ones." namesOfWeaklyCopiedProperties with: weaklyCopiedValues do: [ :name :value | value ifNotNil: [ otherProperties at: name put: value ]]. ! ! !MorphExtension methodsFor: 'accessing' stamp: 'di 8/14/1998 13:07'! sticky ^ sticky! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 18:10'! borderStyle "Answer the value of borderStyle" ^borderStyle! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:08'! borderStyle: anObject "Set the value of borderStyle" borderStyle := anObject! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 18:12'! layoutProperties ^layoutProperties! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 18:10'! layoutFrame ^layoutFrame! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 18:10'! clipSubmorphs "Answer the value of clipSubmorphs" ^clipSubmorphs! ! !MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:55'! balloonText: newValue balloonText := newValue! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:58'! clipSubmorphs: anObject "Set the value of clipSubmorphs" clipSubmorphs := anObject! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 16:47'! layoutPolicy: aLayoutPolicy layoutPolicy := aLayoutPolicy! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:39'! actionMap: anObject "Set the value of actionMap" actionMap := anObject! ! !MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:56'! eventHandler: newValue eventHandler := newValue! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:23'! cornerStyle: anObject "Set the value of cornerStyle" cornerStyle := anObject! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:28'! valueOfProperty: aSymbol ifAbsentPut: aBlock "If the receiver possesses a property of the given name, answer its value. If not, then create a property of the given name, give it the value obtained by evaluating aBlock, then answer that value" ^self assureOtherProperties at: aSymbol ifAbsentPut: aBlock! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 16:45'! layoutFrame: aLayoutFrame layoutFrame := aLayoutFrame! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'ClementBera 7/30/2013 11:07'! sortedPropertyNames "answer the receiver's property names in a sorted way" | props | props := (Array new: 10) writeStream. locked == true ifTrue: [props nextPut: #locked]. visible == false ifTrue: [props nextPut: #visible]. sticky == true ifTrue: [props nextPut: #sticky]. balloonText ifNotNil: [props nextPut: #balloonText]. externalName ifNotNil: [props nextPut: #externalName]. eventHandler ifNotNil: [props nextPut: #eventHandler]. otherProperties ifNotNil: [otherProperties associationsDo: [:a | props nextPut: a key]]. ^props contents sort: [:s1 :s2 | s1 <= s2]! ! !MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:52'! balloonText ^ balloonText! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'ClementBera 7/30/2013 11:07'! hasProperty: aSymbol "Answer whether the receiver has the property named aSymbol" | property | otherProperties ifNil: [^ false]. property := otherProperties at: aSymbol ifAbsent: []. property ifNil: [^ false]. property == false ifTrue: [^ false]. ^ true! ! !MorphExtension methodsFor: 'other' stamp: 'alain.plantec 2/6/2009 17:09'! inspectElement "Create and schedule an Inspector on the otherProperties and the named properties." | key obj | key := UIManager default chooseFrom: self sortedPropertyNames values: self sortedPropertyNames title: 'Inspect which property?' translated. key ifNil: [^ self]. obj := otherProperties at: key ifAbsent: ['nOT a vALuE']. obj = 'nOT a vALuE' ifTrue: [(self perform: key) inspect "named properties"] ifFalse: [obj inspect]! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:41'! visible "answer whether the receiver is visible" ^ visible! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:49'! setProperty: aSymbol toValue: abObject "change the receiver's property named aSymbol to anObject" self assureOtherProperties at: aSymbol put: abObject! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:38'! locked "answer whether the receiver is Locked" ^ locked! ! !MorphExtension methodsFor: 'connectors-copying' stamp: 'nk 5/1/2004 17:23'! propertyNamesNotCopied "list of names of properties whose values should be deleted when veryDeepCopying a morph. See DeepCopier." ^ #(connectedConstraints connectionHighlights highlightedTargets) "add yours to this list" ! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 16:47'! layoutProperties: newProperties "Return the current layout properties associated with the receiver" layoutProperties := newProperties! ! !MorphExtension methodsFor: 'connectors-copying' stamp: 'StephaneDucasse 4/3/2011 22:27'! copyWeakly "list of names of properties whose values should be weak-copied when veryDeepCopying a morph. See DeepCopier." ^ #(formerOwner) "add yours to this list" "formerOwner should really be nil at the time of the copy, but this will work just fine."! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:48'! locked: aBoolean "change the receiver's locked property" locked := aBoolean! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 18:12'! layoutPolicy ^layoutPolicy! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'marcus.denker 9/17/2008 17:39'! initializeOtherProperties "private - initializes the receiver's otherProperties" otherProperties := SmallIdentityDictionary new! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:57'! externalName: aString "change the receiver's externalName" externalName := aString! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:41'! actionMap "Answer the value of actionMap" ^actionMap ifNil: [self valueOfProperty: #actionMap ifAbsent: []]! ! !MorphGotFocus commentStamp: ''! I'm an announcement raised when a morph gets keyboard focus. ! !MorphHandlingMiddleButton commentStamp: 'SeanDeNigris 2/20/2014 08:53'! I log when the middle mouse button has been clicked on me, which is useful for testing.! !MorphHandlingMiddleButton methodsFor: 'meta-actions' stamp: 'SeanDeNigris 12/14/2011 15:17'! handlerForBlueButtonDown: anEvent ^ self.! ! !MorphHandlingMiddleButton methodsFor: 'initialization' stamp: 'SeanDeNigris 12/14/2011 15:24'! initialize super initialize. receivedBlueButtonUp := receivedBlueButtonDown := false.! ! !MorphHandlingMiddleButton methodsFor: 'meta-actions' stamp: 'SeanDeNigris 12/14/2011 15:18'! blueButtonDown: anEvent receivedBlueButtonDown := true.! ! !MorphHandlingMiddleButton methodsFor: 'meta-actions' stamp: 'SeanDeNigris 12/14/2011 15:18'! blueButtonUp: anEvent receivedBlueButtonUp := true.! ! !MorphHandlingMiddleButton methodsFor: 'testing' stamp: 'SeanDeNigris 12/14/2011 15:21'! wasClickedWithMiddleButton ^ receivedBlueButtonDown and: [ receivedBlueButtonUp ].! ! !MorphListItemWrapper methodsFor: 'converting' stamp: 'dgd 9/26/2004 18:26'! asString "Answer the string representation of the receiver" ^ item externalName! ! !MorphListItemWrapper methodsFor: 'accessing' stamp: 'marcus.denker 11/19/2008 13:47'! contents "Answer the receiver's contents" | tentative submorphs | tentative := item submorphs collect: [:each | each renderedMorph]. submorphs := tentative reject: [:each | each isKindOf: HaloMorph]. ^ submorphs collect: [:each | self class with: each]! ! !MorphListItemWrapper methodsFor: 'accessing' stamp: 'MarcusDenker 9/7/2010 17:42'! icon "Answer a form to be used as icon" ^ item iconOrThumbnailOfSize: 28.! ! !MorphLostFocus commentStamp: ''! I'm an announcement raised when a morph losts keyboard focus.! !MorphOpened commentStamp: ''! I'm an announcement raised when a morph is opened. Subscribe to me when you want to do things after the morph is opened. Take into account that when a morph is opened, all it's children also get opened and they raise a similar announcement.! !MorphTest commentStamp: ''! 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 methodsFor: 'initialization' stamp: 'tak 1/21/2005 11:12'! setUp morph := Morph new! ! !MorphTest methodsFor: 'initialization' stamp: 'StephaneDucasse 11/6/2009 17:55'! tearDown morph delete. ! ! !MorphTest methodsFor: 'testing - initialization' stamp: 'CamilloBruni 8/31/2013 20:23'! testOpenInWorld morph openInWorld! ! !MorphTest methodsFor: 'testing - into/outof world' stamp: 'ar 8/4/2003 00:11'! 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). ! ! !MorphTest methodsFor: 'testing - classification' stamp: 'md 4/16/2003 17:11'! testIsMorph self assert: (morph isMorph).! ! !MorphTest methodsFor: 'testing - into/outof world' stamp: 'ar 8/4/2003 00:12'! 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). ! ! !MorphTest methodsFor: 'testing - geometry' stamp: 'Alexandre Bergel 8/2/2010 12:27'! testExtent " self debug: #testExtent " | m1 m2 v1 v2 v3 b1 b2 | m1 := Morph new. m2 := Morph new. v1 := 100.000001. v2 := 100.000001000001. v3 := 100.000001000002. m1 extent: v1@v1. b1 := m1 bounds. m2 extent: v2@v3. b2 := m2 bounds. self assert: (b2 = b1). ! ! !MorphTest methodsFor: 'testing - into/outof world' stamp: 'ar 8/10/2003 18:30'! 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). ! ! !MorphTreeChangeRequest methodsFor: 'accessing' stamp: 'AlainPlantec 5/27/2012 09:08'! arguments ^ arguments ifNil: [Array new]! ! !MorphTreeChangeRequest methodsFor: 'accessing' stamp: 'AlainPlantec 5/26/2012 19:12'! action: aSymbol action := aSymbol! ! !MorphTreeChangeRequest methodsFor: 'accessing' stamp: 'AlainPlantec 5/27/2012 09:09'! arguments: anArray arguments := anArray! ! !MorphTreeChangeRequest methodsFor: 'accessing' stamp: 'AlainPlantec 5/28/2012 14:32'! change: aTreeMorph action ifNil: [^self]. (aTreeMorph respondsTo: action) ifTrue: [aTreeMorph perform: action withEnoughArguments: self arguments]! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/26/2012 19:23'! updateList ^ self new action: #updateList! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/27/2012 08:41'! deselectAll ^ self new action: #deselectAll! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 10/17/2013 09:20'! enabled ^ self new action: #enabledFromModel! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/27/2012 09:15'! expandAll ^ self new action: #expandAll! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 10/18/2013 10:56'! expandItemPath: anItemPath ^ self new action: #expandItemPath:; arguments: (Array with: anItemPath)! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/27/2012 10:03'! selectItems: itemsList ^ self new action: #selectItems:; arguments: (Array with: itemsList)! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/27/2012 09:10'! collapseAll ^ self new action: #collapseAll! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/27/2012 09:17'! expandAllFromNode: aNode ^ self new action: #expandAllFromNode:; arguments: (Array with: aNode)! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/27/2012 08:37'! updateSelectionFromModel ^ self new action: #updateSelectionFromModel! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/27/2012 11:01'! pageSize: anInteger ^ self new action: #pageSize:; arguments: (Array with: anInteger)! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/27/2012 10:09'! expandRoots ^ self new action: #expandRoots! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 6/3/2012 08:59'! expandNodePath: aNodePath ^ self new action: #expandNodePath:; arguments: (Array with: aNodePath)! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/27/2012 11:02'! chunkSize: anInteger ^ self new action: #chunkSize:; arguments: (Array with: anInteger)! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/27/2012 08:43'! selectAll ^ self new action: #selectAll! ! !MorphTreeChangeRequest class methodsFor: 'instance creation' stamp: 'AlainPlantec 10/17/2013 08:43'! collapseNodePath: aNodePath ^ self new action: #collapseNodePath:; arguments: (Array with: aNodePath) ! ! !MorphTreeChunkPager methodsFor: 'accessing' stamp: 'MarcusDenker 10/28/2010 14:03'! computedHeightFromContents | h | h := 0. self submorphsDo: [:sm | h := h max: sm height]. ^ h max: (self preferedFont height + 8) ! ! !MorphTreeChunkPager methodsFor: 'navigation' stamp: 'AlainPlantec 1/22/2010 23:18'! nextPage | last | nextPageAllowed ifTrue: [[nextPageAllowed := false. pageSizeEditor ifNotNil: [pageSizeEditor acceptTextInModel]. self changed: #pageSize. treeMorph scroller hasSubmorphs ifTrue: [last := treeMorph scroller lastSubmorph]. self nextPage: (self lastIndex + pageSize min: self nodeList size). last ifNotNil: [| b1 b2 | b2 := (treeMorph bounds: treeMorph innerBounds in: self world) bottom - treeMorph vExtraScrollRange. b1 := last boundsInWorld bottom. treeMorph scrollBy: 0 @ (b2 - b1)]. self buildPanel] ensure: [nextPageAllowed := true]] ! ! !MorphTreeChunkPager methodsFor: 'navigation' stamp: 'AlainPlantec 1/21/2010 12:10'! lastIndex ^ lastIndex ifNil: [lastIndex := self pageSize]! ! !MorphTreeChunkPager methodsFor: 'navigation' stamp: 'AlainPlantec 1/21/2010 12:10'! lastIndex: anIndex lastIndex := anIndex! ! !MorphTreeChunkPager methodsFor: 'initailize-release' stamp: 'AlainPlantec 1/23/2010 00:46'! buildPanel | widgets nextButton lastPageButton searchEditor | self removeAllMorphs. pageSize ifNil: [^ self]. self atBottom: (((treeMorph scrollValue y <= self verticalScrollbarFrontier)) and: [treeMorph vIsScrollable]) not. widgets := OrderedCollection new. (self nodeList size > self lastIndex and: [self atBottom]) ifTrue: [ pageSizeEditor := self textEntryLabel: 'Page size' get: #pageSize set: #chunkSizeInput: help: 'Change the page size or the number of pages if the input begins with "/"' translated class: String. pageSizeEditor hResizing: #rigid. pageSizeEditor width: (self preferedFont widthOfString: '10000'). widgets add: pageSizeEditor. nextButton := self buttonLabel: self class smallToRightIcon actionSelector: #nextPage arguments: {} getEnabled: #notOnLastPage help: 'Next page'. widgets add: nextButton. lastPageButton := self buttonLabel: self class smallToRightEndIcon actionSelector: #fullList arguments: {} getEnabled: #notOnLastPage help: 'Last page'. widgets add: lastPageButton. widgets add: (self spacer: 10)]. self withSearch ifTrue: [searchEditor := self textEntryLabel: '' get: #pageSearchText set: #pageSearchText: help: 'Enter a text correspondig to your search' translated class: String. searchEditor ghostText: 'Searched text'. widgets add: searchEditor. widgets add: (self spacer: 10)]. widgets add: (self spacer: 1). widgets add: (LabelMorph contents: (self lastIndex asString, ' / ', self nodeList size asString) font: self preferedFont). self addAllMorphs: widgets. self updateContents! ! !MorphTreeChunkPager methodsFor: 'testing' stamp: 'AlainPlantec 1/21/2010 11:44'! notOnLastPage ^ self onLastPage not! ! !MorphTreeChunkPager methodsFor: 'accessing' stamp: 'AlainPlantec 1/22/2010 10:59'! atBottom: aBoolean atBottom ~= aBoolean ifTrue: [atBottom := aBoolean] ! ! !MorphTreeChunkPager methodsFor: 'navigation' stamp: 'SvenVanCaekenberghe 1/8/2012 14:46'! chunkSizeInput: aString | input newPageSize | input := aString trimBoth. input ifEmpty: [treeMorph flash. ^ false]. newPageSize := Integer readFromString: input. newPageSize > 0 ifTrue: [self changePageSize: newPageSize. self nextPage. pageSizeEditor ifNotNil: [pageSizeEditor takeKeyboardFocus]] ifFalse: [treeMorph flash. ^ false]. ^ true! ! !MorphTreeChunkPager methodsFor: 'initailize-release' stamp: 'AlainPlantec 1/21/2010 21:54'! updateContents treeMorph vIsScrollable ifFalse: [self atBottom: true]. super updateContents! ! !MorphTreeChunkPager methodsFor: 'navigation' stamp: 'AlainPlantec 1/21/2010 21:42'! fullList self lastIndex < self nodeList size ifTrue: [self nextPage: self nodeList size]! ! !MorphTreeChunkPager methodsFor: 'initialization' stamp: 'AlainPlantec 1/22/2010 16:17'! initialize super initialize. nextPageAllowed := true! ! !MorphTreeChunkPager methodsFor: 'accessing' stamp: 'tg 1/21/2010 23:26'! currentNodelist ^ self nodeList copyFrom: 1 to: (self lastIndex min: self nodeList size)! ! !MorphTreeChunkPager methodsFor: 'accessing' stamp: 'AlainPlantec 1/22/2010 10:38'! computedHeight ^ self nodeList size > self lastIndex ifTrue: [super computedHeight ] ifFalse:[0]! ! !MorphTreeChunkPager methodsFor: 'testing' stamp: 'AlainPlantec 1/21/2010 12:10'! onLastPage ^ self lastIndex = self nodeList size! ! !MorphTreeChunkPager methodsFor: 'user interface' stamp: 'AlainPlantec 1/22/2010 10:57'! verticalScrollbarFrontier ^ 0.98! ! !MorphTreeChunkPager methodsFor: 'accessing' stamp: 'AlainPlantec 1/21/2010 11:44'! atBottom ^ atBottom ifNil: [atBottom := false]! ! !MorphTreeChunkPager methodsFor: 'user interface' stamp: 'MarcusDenker 9/13/2013 15:51'! vScrollBarValue: scrollValue | old | old := atBottom. self atBottom: scrollValue >= self verticalScrollbarFrontier. old ~= atBottom ifTrue: [ self buildPanel ]! ! !MorphTreeChunkPager methodsFor: 'navigation' stamp: 'ThierryGoubier 2/8/2013 16:27'! nextPage: newLast | addedNodeList | newLast > self lastIndex ifFalse: [ ^ self ]. self lastIndex < self nodeList size ifTrue: [ addedNodeList := self nodeList copyFrom: 1 to: newLast. self lastIndex: newLast. treeMorph scroller removeAllMorphs. treeMorph addSubmorphsFromNodeList: addedNodeList previouslyExpanded: treeMorph currentlyExpanded ]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/11/2009 09:47'! container ^ container! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/26/2009 11:29'! defaultRowMorph ^ Morph new color: Color red; borderWidth: 0; extent: 0@0; yourself ! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'BenjaminVanRyseghem 11/2/2013 17:32'! rowMorphFor: aNode | rowMorph | rowMorph := self rowMorphGetSelector ifNil: [aNode rowMorphForColumn: self] ifNotNil: [self rowMorphGetterBlock value: aNode value: self container]. rowMorph := rowMorph asMorph. rowMorph ifNotNil: [rowMorph borderWidth: 0] ifNil: [rowMorph := self defaultRowMorph]. ^ rowMorph rowMorphForNode: aNode inColumn: self ! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/11/2009 10:16'! startWidth: anInteger currentWidth := anInteger! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/9/2009 15:26'! header ^ header ifNil: [header := (Morph new extent: 0@0) color: Color transparent]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/17/2009 18:52'! color: aColor color := aColor! ! !MorphTreeColumn methodsFor: 'geometry' stamp: 'AlainPlantec 11/4/2009 21:52'! height ^ header ifNil: [0] ifNotNil: [header height]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 2/1/2010 19:30'! headerButtonLabel: aLabel font: aFont self headerButton. self header label: aLabel font: aFont. ! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/17/2009 19:11'! isPotentialDropTarget ^ isPotentialDropTarget ifNil: [isPotentialDropTarget := false]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 1/31/2010 22:22'! contentWidth | w | w := 0. self container allNodeMorphs do: [:n | w := w max: (n columnMorphAt: self index) width]. ^ w! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/9/2009 19:05'! rowMorphGetSelector: aSelector rowMorphGetSelector := aSelector! ! !MorphTreeColumn methodsFor: 'testing' stamp: 'IgorStasenko 4/6/2011 16:31'! isFirstColumn ^ container columns first = self! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 2/1/2010 19:30'! headerButtonLabel: aLabel font: aFont target: aReceiver actionSelector: aSelector arguments: aCollection self headerButton. self header label: aLabel font: aFont. self header actionSelector: aSelector. self header target: aReceiver. self header arguments: aCollection ! ! !MorphTreeColumn methodsFor: 'accessing' stamp: 'StephaneDucasse 5/23/2013 18:40'! thumbnailOfSize: thumbExtent "Answer a new thumbnail for the receiver." |f t r| r := self header fullBounds scaledAndCenteredIn: (0@0 extent: thumbExtent). f := Form extent: r extent depth: Display depth. t := MatrixTransform2x3 withScale: 1.0. f getCanvas transformBy: t clippingTo: f boundingBox during: [:c | c translateBy: self visibleBounds topLeft negated during: [:ct | self container fullDrawOn: ct]] smoothing: 6. ^ImageMorph new form: f! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/11/2009 10:15'! currentWidth ^ currentWidth ifNil: [currentWidth := self defaultWidth]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 1/27/2010 16:26'! itemStringGetter: aSelectorOrAValuable rowMorphGetSelector := aSelectorOrAValuable isSymbol ifTrue: [[:node | (node complexContents item perform: aSelectorOrAValuable) asMorph]] ifFalse: [[:node | (aSelectorOrAValuable value: node complexContents item) asMorph]]! ! !MorphTreeColumn methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2009 08:01'! asDraggableMorph ^ self thumbnailOfSize: self header fullBounds extent ! ! !MorphTreeColumn methodsFor: 'initialize-release' stamp: 'AlainPlantec 11/3/2009 22:16'! release container := nil. header := nil. super release.! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/11/2009 21:07'! index ^ self container columns indexOf: self! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/18/2009 11:48'! shrinkWrap: aBoolean shrinkWrap := aBoolean! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 9/30/2011 17:10'! headerButton self header: ((MorphTreeColumnButton new) layoutPolicy: RowLayout new; listDirection: #leftToRight; wrapCentering: #center; cellInset: 5@0; layoutInset: 5@0; yourself)! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 2/2/2010 14:14'! rowMorphGetterBlock ^ self rowMorphGetSelector isSymbol ifTrue: [self rowMorphGetSelector numArgs = 0 ifTrue: [[:node :cont | node perform: self rowMorphGetSelector]] ifFalse: [[:node :cont| node perform: self rowMorphGetSelector with: self container]]] ifFalse: [self rowMorphGetSelector numArgs = 2 ifTrue: [self rowMorphGetSelector] ifFalse: [[:node :cont| self rowMorphGetSelector value: node]]] ! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'BenjaminVanRyseghem 11/2/2013 18:22'! headerButtonLabel: aLabel icon: anIconForm self headerButtonLabel: aLabel font: nil. self header cellInset: 3@0. self header icon: (ImageMorph new form: anIconForm)! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'BenjaminVanRyseghem 11/2/2013 18:24'! headerButtonLabel: aLabel font: aFont icon: anIconForm target: aReceiver actionSelector: aSelector arguments: aCollection self headerButton. self header label: aLabel font: aFont. self header icon: (ImageMorph new form: anIconForm). self header actionSelector: aSelector. self header target: aReceiver. self header arguments: aCollection! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/17/2009 19:12'! asPotentialDropTarget isPotentialDropTarget := true. self container invalidRect: self visibleBounds! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/3/2009 16:38'! container: aTreeMorph container := aTreeMorph! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/18/2009 10:22'! currentWidth: anInteger self resizable ifTrue: [currentWidth := anInteger]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/17/2009 19:13'! noMorePotentialDropTarget isPotentialDropTarget := false. self container invalidRect: self visibleBounds! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/18/2009 09:52'! resizable ^ resizable ifNil: [resizable := true]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/18/2009 09:53'! resizable: aBoolean resizable := aBoolean! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/17/2009 18:54'! dataBounds ^ self visibleBounds withTop: self container topHeader bottom! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/12/2009 07:57'! visibleBounds ^ self header bounds withBottom: self container scroller bottom! ! !MorphTreeColumn methodsFor: 'testing' stamp: 'AlainPlantec 1/23/2010 12:37'! isLastColumn ^ container columns last = self! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 1/27/2010 16:28'! itemMorphGetter: aSelectorOrAValuable rowMorphGetSelector := aSelectorOrAValuable isSymbol ifTrue: [[:node | node complexContents item perform: aSelectorOrAValuable]] ifFalse: [[:node | aSelectorOrAValuable value: node complexContents item]]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/11/2009 20:55'! header: aMorph header := aMorph clipSubmorphs: true; yourself. header model: self! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/18/2009 11:48'! shrinkWrap ^ shrinkWrap ifNil: [shrinkWrap := false]! ! !MorphTreeColumn methodsFor: 'accessing' stamp: 'AlainPlantec 10/3/2011 09:59'! nodeStringGetter: aSelectorOrAValuable rowMorphGetSelector := aSelectorOrAValuable isSymbol ifTrue: [[:node | (node complexContents perform: aSelectorOrAValuable) asMorph]] ifFalse: [[:node | (aSelectorOrAValuable value: node complexContents ) asMorph]]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/11/2009 10:15'! defaultWidth ^ 100! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/17/2009 19:44'! color ^ color ifNil: [self container columnColors at: ((self index \\ 2) + 1)]! ! !MorphTreeColumn methodsFor: 'converting' stamp: 'AlainPlantec 11/18/2009 10:07'! drawColumnOn: aCanvas self isPotentialDropTarget ifTrue: [aCanvas frameAndFillRectangle: self dataBounds fillColor: ((Color gray alpha: 0.1) alphaMixed: 0.9 with: (self color ifNotNil: [:c | c asColor] ifNil: [Color transparent])) borderWidth: 2 borderColor: Color gray] ifFalse: [self color ifNotNil: [:c | c isColor ifTrue: [ aCanvas frameAndFillRectangle: self dataBounds fillColor: self color borderWidth: 0 borderColor: Color transparent] ifFalse: [c origin: self dataBounds topLeft. c direction: 0@self dataBounds height. aCanvas fillRectangle: self dataBounds basicFillStyle: c]]]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/9/2009 19:04'! rowMorphGetSelector ^ rowMorphGetSelector! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/18/2009 10:47'! forceWidthTo: anInteger currentWidth := anInteger! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/18/2009 10:22'! fixedWidth: anInteger currentWidth := anInteger. resizable := false! ! !MorphTreeColumnButton methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 11/12/2009 07:09'! mouseUp: evt self noMorePotentialDropTarget. super mouseUp: evt! ! !MorphTreeColumnButton methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2009 19:05'! asPotentialDropTarget self model asPotentialDropTarget! ! !MorphTreeColumnButton methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2009 19:05'! noMorePotentialDropTarget self model noMorePotentialDropTarget! ! !MorphTreeColumnButton methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/16/2013 12:28'! wantsDroppedMorph: aMorph event: anEvent ^ model container columnDropUnabled and: [(aMorph isTransferable) and: [(aMorph passenger isKindOf: MorphTreeColumn) and: [aMorph passenger ~= self model]]]! ! !MorphTreeColumnButton methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/8/2013 19:08'! icon: anIcon icon ifNotNil: [ self removeMorph: icon ]. anIcon ifNotNil: [ icon := anIcon. self addMorphFront: anIcon ]! ! !MorphTreeColumnButton methodsFor: 'initialization' stamp: 'AlainPlantec 11/11/2009 20:56'! model ^ model! ! !MorphTreeColumnButton methodsFor: 'initialization' stamp: 'AlainPlantec 2/1/2010 19:27'! initialize super initialize. self enableDragNDrop: true. self fillStyle: (Color veryLightGray lighter). self borderColor: Color veryLightGray ! ! !MorphTreeColumnButton methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 11/17/2009 19:05'! mouseEnterDragging: evt (evt hand hasSubmorphs and:[self dropEnabled]) ifFalse: ["no d&d" ^ super mouseEnterDragging: evt]. (self wantsDroppedMorph: evt hand firstSubmorph event: evt ) ifTrue:[ self asPotentialDropTarget. ].! ! !MorphTreeColumnButton methodsFor: 'event handling' stamp: 'AlainPlantec 11/11/2009 19:53'! mouseDown: anEvent | selectors | selectors := Array with: #click: with: nil with: nil with: (self dragEnabled ifTrue:[#startDrag:] ifFalse:[nil]). anEvent hand waitForClicksOrDrag: self event: anEvent selectors: selectors threshold: 10. super mouseDown: anEvent! ! !MorphTreeColumnButton methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/8/2013 20:17'! removeIcon icon ifNotNil: [ self removeMorph: icon ].! ! !MorphTreeColumnButton methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2009 12:17'! acceptDroppingMorph: aMorph event: evt self model container swapColumn: self model withColumn: aMorph passenger. evt hand releaseMouseFocus: self. self noMorePotentialDropTarget. self model container changed. Cursor normal show. ! ! !MorphTreeColumnButton methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 11/12/2009 07:09'! mouseLeaveDragging: evt self noMorePotentialDropTarget ! ! !MorphTreeColumnButton methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 11/12/2009 06:58'! handlesMouseOverDragging: evt ^ true! ! !MorphTreeColumnButton methodsFor: 'initialization' stamp: 'AlainPlantec 11/11/2009 20:56'! model: anObject model := anObject! ! !MorphTreeColumnButton methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 5/16/2013 12:23'! startDrag: anEvent | aTransferMorph | self dragEnabled ifFalse: [^ self]. (anEvent hand hasSubmorphs) ifTrue: [^ self]. oldColor ifNotNil: [ self fillStyle: oldColor. oldColor := nil]. aTransferMorph := self model transferFor: self model from: self. aTransferMorph align: aTransferMorph draggedMorph center with: anEvent position. anEvent hand grabMorph: aTransferMorph. anEvent hand releaseMouseFocus: self! ! !MorphTreeColumnButton methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/2/2013 18:20'! icon ^ icon! ! !MorphTreeListManager methodsFor: 'client list accessing' stamp: 'AlainPlantec 10/7/2011 23:41'! numSelectionsInView ^ client numSelectionsInView! ! !MorphTreeListManager methodsFor: 'selection accessing' stamp: 'AlainPlantec 10/8/2011 23:50'! selectedMorphList ^ selectedMorphList ifNil: [selectedMorphList := LinkedList new]! ! !MorphTreeListManager methodsFor: 'mouse managing' stamp: 'BenjaminVanRyseghem 12/5/2013 14:05'! mouseDown: event on: aTargetMorph "Changed to take keybaord focus." | clickedTheCheckbox | clickedTheCheckbox := self clicked: event inTheCheckboxOf: aTargetMorph. (self autoMultiSelection and: [ event shiftPressed not ]) ifTrue: [ firstClickedMorph := aTargetMorph. aTargetMorph selected ifTrue: [ self removeFromSelection: aTargetMorph. (clickedTheCheckbox not and: [ self selectOnlyLastHighlighted and: [ aTargetMorph hasContentToShow ] ]) ifTrue: [ aTargetMorph = self lastClickedMorph ifFalse: [ self addToSelection: aTargetMorph ] ] ] ifFalse: [ (clickedTheCheckbox not and: [ self selectOnlyLastHighlighted and: [ aTargetMorph hasContentToShow ] ]) ifTrue: [ aTargetMorph = self lastClickedMorph ifTrue: [ self addToSelection: aTargetMorph. clickedTheCheckbox ifFalse: [ self lastClickedMorph: aTargetMorph ] ] ] ifFalse: [ self addToSelection: aTargetMorph. clickedTheCheckbox ifFalse: [ self lastClickedMorph: aTargetMorph ] ] ] ]. (clickedTheCheckbox not and: [ event shiftPressed not or: [ firstClickedMorph isNil ] ]) ifTrue: [ firstClickedMorph := aTargetMorph ]. aTargetMorph mouseDown: event! ! !MorphTreeListManager methodsFor: 'keyboard managing' stamp: 'EstebanLorenzano 11/26/2013 13:29'! keyStroke: anEvent | char args | char := anEvent keyValue asCharacter. (self arrowEvent: anEvent key: char) ifTrue: [ ^ true ]. char = Character cr ifTrue: [ self selectSearchedElement. ^ true ]. anEvent anyModifierKeyPressed ifFalse: [ self basicKeyPressed: char. ^ true]. self keystrokeActionSelector ifNil: [ ^ false]. args := self keystrokeActionSelector numArgs. (args = 0 or: [args > 2]) ifTrue: [^ self error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'] ifFalse: [ ^ args = 1 ifTrue: [ self listModel perform: self keystrokeActionSelector with: anEvent] ifFalse: [ self listModel perform: self keystrokeActionSelector with: anEvent with: self]]! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 16:54'! selectionUpdateFromViewWhile: aBlock | prev | prev := self isSelectionUpdateFromView. isSelectionUpdateFromView := true. aBlock ensure: [isSelectionUpdateFromView := prev] ! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'BenjaminVanRyseghem 11/21/2013 18:02'! selectMorph: aNodeMorph multiple: withMultipleSelection | path mult | self lastClickedMorph: aNodeMorph. aNodeMorph isNil ifTrue: [ self emptySelection. ^ nil]. aNodeMorph selected ifTrue: [ withMultipleSelection ifTrue: [self removeFromSelection: aNodeMorph] ifFalse: [ mult := self selectedMorphList size > 1. path := aNodeMorph path collect: [:m | m complexContents]. (self autoDeselection or: [mult]) ifTrue: [ self emptySelection. mult ifTrue: [self addToSelection: aNodeMorph] ifFalse: [path := nil]]]] ifFalse: [ withMultipleSelection ifFalse: [self emptySelection]. self addToSelection: aNodeMorph. path := aNodeMorph path collect: [:m | m complexContents]]. self selectionChanged. ^ path! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'ThierryGoubier 10/1/2012 13:22'! removeFromSelection: aMorph aMorph selected ifFalse: [^false]. aMorph selected: false. aMorph unhighlight. self selectionUpdateFromViewWhile: [ | selHolder | selHolder := self newSelectionHolderWithNodePath: nil. self listModel selection: selHolder]. ^ true ! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastClickedMorph ^ lastClickedMorph! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! firstClickedMorph ^ firstClickedMorph! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! columnDropUnabled ^ columnDropUnabled! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 16:05'! listModel ^ client model! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 22:49'! removeOnlyLastSelected: aBoolean removeOnlyLastSelected := aBoolean! ! !MorphTreeListManager methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/21/2013 22:48'! initialize super initialize. lastKeystrokeTime := 0. lastKeystrokes := ''. lastSelection := 0. removeOnlyLastSelected := false! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 16:11'! isMultiple ^ multipleSelection ifNil: [ multipleSelection := false ]! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'BenjaminVanRyseghem 11/21/2013 18:02'! setSelectedMorph: aMorph | path | path := aMorph ifNotNil: [ aMorph path collect: [ :m | m complexContents ] ]. self lastClickedMorph: aMorph. self emptySelection. aMorph ifNotNil: [ self addToSelection: lastClickedMorph ]. self selectionUpdateFromViewWhile: [ self listModel selection: (self newSelectionHolderWithNodePath: path) ]! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! columnDropUnabled: aBoolean columnDropUnabled := aBoolean! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 16:24'! autoMultiSelection: aBoolean autoMultiSelection := aBoolean. aBoolean ifTrue: [self multipleSelection: true]! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 15:00'! firstClickedMorph: aNodeMorph firstClickedMorph := aNodeMorph! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 17:11'! autoDeselection ^ autoDeselection ifNil: [autoDeselection := false]! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! potentialDropMorph ^ potentialDropMorph! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 16:55'! isSelectionUpdateFromView ^ isSelectionUpdateFromView ifNil: [isSelectionUpdateFromView := false] ! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 15:00'! keystrokeActionSelector: aSelectorOrBlock keystrokeActionSelector := aSelectorOrBlock! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'BenjaminVanRyseghem 11/21/2013 18:03'! shiftSelectMorph: aNodeMorph | m | m := aNodeMorph ifNil: [self allNodeMorphs last]. self emptySelection. self searchedElement: nil. self from: firstClickedMorph to: m do: [:nd | self addToSelection: nd]. self lastClickedMorph: m. ^ m path collect: [:p | p complexContents]! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/8/2011 23:49'! emptySelection self selectedMorphList do: [:n | n unhighlight; setSelectedSilently: false]. self selectedMorphList removeAll. self selectionChanged ! ! !MorphTreeListManager methodsFor: 'keyboard managing' stamp: 'BenjaminVanRyseghem 11/21/2013 18:03'! setSelectionIndexFromKeyboard: index multiSelection: multiSelect event: anEvent "Called internally to select the index-th item." | targetMorph | index ifNil: [^ self]. index > self allNodeMorphs size ifTrue: [^self]. targetMorph := index = 0 ifTrue: [nil] ifFalse: [self allNodeMorphs at: index]. lastClickedMorph ifNotNil: [lastClickedMorph highlightForMouseDown: false]. self isCheckList ifTrue: [ (multiSelect and: [anEvent shiftPressed]) ifTrue: [self autoMultiSelect: targetMorph]] ifFalse: [ (multiSelect and: [anEvent shiftPressed]) ifTrue: [self autoMultiSelect: targetMorph] ifFalse: [self setSelectedMorph: targetMorph]]. self lastClickedMorph: (firstClickedMorph := targetMorph). anEvent shiftPressed ifTrue: [lastClickedMorph highlightForMouseDown: true]. self selectionChanged. self scrollToShow: targetMorph ! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastKeystrokes ^ lastKeystrokes! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! searchedElement ^ searchedElement! ! !MorphTreeListManager methodsFor: 'mouse managing' stamp: 'BenjaminVanRyseghem 12/5/2013 13:22'! mouseUp: event on: aNodeMorph | path cmdOrCtrl clickedTheCheckbox | "No change if model is locked" clickedTheCheckbox := self clicked: event inTheCheckboxOf: aNodeMorph. self listModel okToChange ifFalse: [^self]. self listModel okToDiscardEdits ifFalse: [^ self]. cmdOrCtrl := self commandOrCrontrolKeyPressed: event. path := (event shiftPressed and: [self isMultiple]) ifTrue: [self shiftSelectMorph: aNodeMorph] ifFalse: [ self autoMultiSelection ifTrue: [self selectedMorphList ifEmpty: [] ifNotEmpty: [:l | l last path collect: [:p | p complexContents]]] ifFalse: [self selectMorph: aNodeMorph multiple: ((cmdOrCtrl and: [self isMultiple]) or: [self autoMultiSelection]) clickedTheCheckBox: clickedTheCheckbox ]]. self selectionUpdateFromViewWhile: [ | selHolder | selHolder := self newSelectionHolderWithNodePath: path. self listModel selection: selHolder]. clickedTheCheckbox ifFalse: [ self lastClickedMorph: aNodeMorph ]. self selectionChanged. ! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 17:35'! isCheckList: aBoolean isCheckList := aBoolean! ! !MorphTreeListManager methodsFor: 'keyboard managing' stamp: 'EstebanLorenzano 11/26/2013 13:11'! basicKeyPressed: aChar | nextSelection oldSelection milliSeconds slowKeyStroke nextSelectionNodeMorph | (aChar == Character space and: [ lastClickedMorph notNil ]) ifTrue: [ self selectMorph: lastClickedMorph multiple: (self isMultiple or: [self autoMultiSelection]). self selectionUpdateFromViewWhile: [ | selHolder | selHolder := self newSelectionHolderWithNodePath: lastClickedMorph complexContents path. self listModel selection: selHolder]]. nextSelection := oldSelection := lastSelection. milliSeconds := Time millisecondClockValue. slowKeyStroke := milliSeconds - lastKeystrokeTime > 500. lastKeystrokeTime := milliSeconds. self searchedElement: nil. slowKeyStroke ifTrue: ["forget previous keystrokes and search in following elements" lastKeystrokes := aChar asLowercase asString.] ifFalse: ["append quick keystrokes but don't move selection if it still matches" lastKeystrokes := lastKeystrokes , aChar asLowercase asString.]. "Get rid of blanks and style used in some lists" nextSelectionNodeMorph := self allNodeMorphs detect: [:a | a complexContents asString trimBoth asLowercase beginsWith: lastKeystrokes] ifNone: [^ self ]. nextSelection := nextSelectionNodeMorph index. "No change if model is locked" self listModel okToChange ifFalse: [^ self]. self searchedElement: nextSelectionNodeMorph. lastSelection := nextSelection. "change scrollbarvalue" self scrollToShow: nextSelectionNodeMorph. self selectionChanged! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 15:42'! client: aMorphList client := aMorphList! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'NicolaiHess 2/11/2014 23:02'! selectedItems: aNodeItemCollection self listModel okToDiscardEdits ifFalse: [^ self]. self emptySelection. (self nodeMorphsWithAllNodeItems: aNodeItemCollection) ifNotEmpty:[:selection | self addAllToSelection: selection]. lastClickedMorph ifNil: [lastClickedMorph := self selectedMorphList ifEmpty: [] ifNotEmpty: [self selectedMorphList last]]! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 16:56'! newSelectionHolderWithNodePath: aNodePath ^ self isMultiple ifTrue: [MorphTreeMorphMultipleSelection new selectedNodePathList: (self selectedMorphList collect: [:s | s path collect: [:m | m complexContents]])] ifFalse: [MorphTreeMorphSingleSelection new selectedNodePath: aNodePath]! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/21/2013 18:22'! lastClickedMorph: aNodeMorph lastClickedMorph ifNotNil: [ lastClickedMorph complexContents lastClicked: false ]. lastClickedMorph := aNodeMorph. aNodeMorph ifNotNil: [ aNodeMorph complexContents lastClicked: true ].! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 17:19'! multipleSelection ^ multipleSelection ifNil: [multipleSelection := false]! ! !MorphTreeListManager methodsFor: 'mouse managing' stamp: 'AlainPlantec 10/7/2011 23:09'! mouseMove: evt on: aTargetMorph (aTargetMorph isNil or: [aTargetMorph highlightedForMouseDown not]) ifTrue: [self allNodeMorphs do: [:m | m highlightedForMouseDown ifTrue: [m highlightForMouseDown: false]]. aTargetMorph ifNotNil: [aTargetMorph highlightForMouseDown. (self autoMultiSelection and: [evt shiftPressed not]) ifTrue: [ self autoMultiSelect: aTargetMorph. self selectionChanged]]]! ! !MorphTreeListManager methodsFor: 'mouse managing' stamp: 'BenjaminVanRyseghem 12/6/2013 19:01'! clicked: event inTheCheckboxOf: aTargetMorph | position | aTargetMorph ifNil: [ ^ false ]. position := aTargetMorph point: event position from: client. ^ self isCheckList and: [ (aTargetMorph checkClickableZone translateBy: 2 @ 0) containsPoint: position ]! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'NicolaiHess 2/7/2014 00:39'! selectAll self allNodeMorphs isEmpty ifTrue: [^ self]. self isMultiple ifFalse: [^ self]. self addAllToSelection: self allNodeMorphs! ! !MorphTreeListManager methodsFor: 'client list accessing' stamp: 'AlainPlantec 10/7/2011 23:41'! allNodeMorphs ^ client allNodeMorphs! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 18:08'! getSelectionIndexOf: aMorph ^ aMorph ifNil: [0] ifNotNil: [aMorph index]! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastKeystrokeTime: anObject lastKeystrokeTime := anObject! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastSelection ^ lastSelection! ! !MorphTreeListManager methodsFor: 'private' stamp: 'EstebanLorenzano 11/26/2013 13:38'! selectSearchedElement self searchedElement ifNotNil: [ :selectedMorph | self setSelectedMorph: selectedMorph. self searchedElement: nil ]! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! autoDeselection: aBoolean autoDeselection := aBoolean! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! potentialDropMorph: anObject potentialDropMorph := anObject! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 23:09'! from: aNodeMorph to: anotherNodeMorph do: action | idx1 idx2 | idx1 := ((self getSelectionIndexOf: aNodeMorph) min: self allNodeMorphs size) max: 1. idx2 := ((self getSelectionIndexOf: anotherNodeMorph) min: self allNodeMorphs size) max: 1. (idx1 min: idx2) to: (idx1 max: idx2) do: [:idx | action value: (self allNodeMorphs at: idx)] ! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'BenjaminVanRyseghem 11/26/2013 10:12'! silentlySetSelectedMorph: aMorph | path | path := aMorph ifNotNil: [ aMorph path collect: [ :m | m complexContents ] ]. self isMultiple ifFalse: [ self emptySelection ]. aMorph ifNotNil: [ self addToSelection: aMorph ]. self selectionUpdateFromViewWhile: [ self listModel selection: (self newSelectionHolderWithNodePath: path) ]! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 22:48'! autoAction ^ firstClickedMorph ifNotNil: [ firstClickedMorph selected ifTrue: [#addToSelection:] ifFalse: [#removeFromSelection:]]. ! ! !MorphTreeListManager methodsFor: 'client list accessing' stamp: 'AlainPlantec 10/7/2011 23:22'! scrollToShow: aRectangle client scrollToShow: aRectangle! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 23:10'! selectMoreAtTop | first | autoTargetMorph ifNil: [^self]. first := autoTargetMorph index. first > 1 ifTrue: [ self autoMultiSelect: (self allNodeMorphs at: first - 1). self selectionChanged]! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'NicolaiHess 2/7/2014 00:39'! addAllToSelection: aCollection | selHolder | self searchedElement: nil. aCollection do: [:m | m highlight; selected: true ]. self selectionChanged. self selectionUpdateFromViewWhile: [ selHolder := self newSelectionHolderWithNodePath: (aCollection last path collect: [:m | m complexContents]). self listModel selection: selHolder] ! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! multipleSelection: anObject multipleSelection := anObject! ! !MorphTreeListManager methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 6/18/2013 16:22'! secondSelection: anItem | nodeMorph | nodeMorph := self allNodeMorphs detect: [ :e | e complexContents item == anItem ]. self searchedElement: nodeMorph. client changed.! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'BenjaminVanRyseghem 12/5/2013 13:21'! addToSelection: aMorph clickedTheCheckBox: checkBox aMorph selected ifTrue: [^false]. self searchedElement: nil. checkBox ifFalse: [ aMorph highlight ]. aMorph selected: true. ^ true! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastKeystrokeTime ^ lastKeystrokeTime! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/8/2011 22:06'! deselectAll | selHolder | self allNodeMorphs isEmpty ifTrue: [^ self]. self emptySelection. self selectionUpdateFromViewWhile: [ selHolder := self newSelectionHolderWithNodePath: nil. self listModel selection: selHolder] ! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastKeystrokes: anObject lastKeystrokes := anObject! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/8/2011 01:04'! autoMultiSelect: aTargetMorph autoTargetMorph := aTargetMorph. self autoAction ifNotNil: [:act | self from: firstClickedMorph to: aTargetMorph do: [:nd | self perform: act with: nd]. self selectionUpdateFromViewWhile: [ | selHolder | selHolder := self newSelectionHolderWithNodePath: nil. self listModel selection: selHolder]. self selectionChanged. self scrollToShow: aTargetMorph bounds]! ! !MorphTreeListManager methodsFor: 'mouse managing' stamp: 'AlainPlantec 10/8/2011 14:15'! doubleClick: anEvent on: aMorph doubleClickBlock ifNil: [^false]. doubleClickBlock value. ^ true! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! keystrokeActionSelector ^ keystrokeActionSelector! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastSelection: anObject lastSelection := anObject! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! searchedElement: anObject searchedElement := anObject! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 17:02'! updateSelectionFromModel (self listModel selection) ifNotNil: [:selHolder | self isSelectionUpdateFromView ifTrue: [ self listModel selectionChanged. self selectionChanged] ifFalse: [selHolder updateView: client forModel: self listModel]]. ! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 16:18'! autoMultiSelection ^ autoMultiSelection ifNil: [autoMultiSelection := false]! ! !MorphTreeListManager methodsFor: 'client list accessing' stamp: 'AlainPlantec 10/7/2011 23:24'! commandOrCrontrolKeyPressed: anEvent ^ client commandOrCrontrolKeyPressed: anEvent! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 23:15'! toggleExpandedState: aMorph aMorph toggleExpandedState. client innerWidgetChanged ! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 21:51'! addToSelection: aMorph aMorph selected ifTrue: [^false]. self searchedElement: nil. aMorph highlight. aMorph selected: true. ^ true! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'BenjaminVanRyseghem 12/5/2013 13:21'! selectMorph: aNodeMorph multiple: withMultipleSelection clickedTheCheckBox: checkBox | path mult | checkBox ifFalse: [ self lastClickedMorph: aNodeMorph ]. aNodeMorph isNil ifTrue: [ self emptySelection. ^ nil]. aNodeMorph selected ifTrue: [ withMultipleSelection ifTrue: [self removeFromSelection: aNodeMorph] ifFalse: [ mult := self selectedMorphList size > 1. path := aNodeMorph path collect: [:m | m complexContents]. (self autoDeselection or: [mult]) ifTrue: [ self emptySelection. mult ifTrue: [self addToSelection: aNodeMorph] ifFalse: [path := nil]]]] ifFalse: [ withMultipleSelection ifFalse: [self emptySelection]. self addToSelection: aNodeMorph clickedTheCheckBox: checkBox. path := aNodeMorph path collect: [:m | m complexContents]]. self selectionChanged. ^ path! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 17:35'! isCheckList ^ isCheckList ifNil: [isCheckList := false]! ! !MorphTreeListManager methodsFor: 'keyboard managing' stamp: 'StephanEggermont 3/21/2014 12:16'! arrowEvent: event key: aChar "Handle a keyboard navigation character. Answer true if handled, false if not." | newIndex targetMorph targetIndex multi | self allNodeMorphs ifEmpty: [ ^ false]. newIndex := nil. targetMorph := lastClickedMorph. "Give the oportunity to model to handle the keystroke event. This is an ugly HACK due to the lack of proper key handling... but I can live with it for now" targetMorph ifNotNil: [ (self listModel arrowEvent: event key: aChar target: targetMorph) ifTrue: [ ^ true ]]. targetIndex := targetMorph ifNil: [ 0 ] ifNotNil: [ targetMorph index ]. multi := (event shiftPressed and: [self isMultiple]) or: [self autoMultiSelection]. aChar = Character arrowDown ifTrue: [newIndex := targetIndex + 1]. aChar = Character arrowUp ifTrue: [newIndex := targetIndex - 1 max: 1]. aChar = Character home ifTrue: [newIndex := 1]. aChar = Character end ifTrue: [newIndex := self allNodeMorphs size]. aChar = Character pageUp ifTrue: [newIndex := targetIndex - self numSelectionsInView max: 1]. aChar = Character pageDown ifTrue: [newIndex := targetIndex + self numSelectionsInView]. aChar = Character arrowRight ifTrue: [ targetMorph ifNil: [^ false]. (targetMorph canExpand and: [targetMorph isExpanded not]) ifTrue: [ self toggleExpandedState: targetMorph. ^ true] ifFalse: [ newIndex := targetIndex + 1 ] ]. aChar = Character arrowLeft ifTrue: [ targetMorph ifNil: [^ false]. (targetMorph canExpand and: [targetMorph isExpanded]) ifTrue: [ self toggleExpandedState: targetMorph. ^ true] ifFalse: [ | parent | parent := targetMorph parent. parent ifNil: [newIndex := targetIndex - 1 max: 1] ifNotNil: [ self toggleExpandedState: parent. newIndex := parent index]]]. newIndex notNil ifTrue: [ self setSelectionIndexFromKeyboard: newIndex multiSelection: multi event: event. self selectionChanged. ^ true]. ^ false! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/11/2013 16:02'! nodeMorphsWithAllNodeItems: aNodeItemList | result | result := OrderedCollection new. self allNodeMorphs do: [:m | aNodeItemList do: [ :sel | (m expandPath: sel) ] ]. self allNodeMorphs do: [:m | aNodeItemList do: [ :sel | (m matchPath: sel) ifNotNil: [:col | result addAll: col ] ] ]. ^ result flattened! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 16:09'! selectionChanged client selectionChanged ! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! doubleClickBlock ^ doubleClickBlock! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! doubleClickBlock: aBlock doubleClickBlock := aBlock! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2013 18:16'! selectOnlyLastHighlighted ^ removeOnlyLastSelected! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 23:10'! selectMoreAtBottom | last | autoTargetMorph ifNil: [^self]. last := autoTargetMorph index. last < self allNodeMorphs size ifTrue: [ self autoMultiSelect: (self allNodeMorphs at: last + 1). self selectionChanged]! ! !MorphTreeListManager methodsFor: 'selection accessing' stamp: 'AlainPlantec 10/7/2011 15:53'! selectedMorph ^ self selectedMorphList ifNotEmpty: [ :l | l last] ifEmpty: [] ! ! !MorphTreeModel commentStamp: ''! I'm the base class for tree models. See ClassListExample for basic usage.! !MorphTreeModel methodsFor: 'announcing' stamp: 'AlainPlantec 10/17/2013 09:14'! requestView: anAnnouncement ^ self announcer announce: anAnnouncement ! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/16/2013 16:52'! enabled ^ enabled ifNil: [ enabled := true ]! ! !MorphTreeModel methodsFor: 'dialog' stamp: 'AlainPlantec 10/11/2011 10:57'! headerLabel ^ headerLabel! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:57'! keyStroke: anEvent anEvent keyString = '' ifTrue: [ self selectAll ]. anEvent keyString = '' ifTrue: [ self deselectAll ]! ! !MorphTreeModel methodsFor: 'announcing' stamp: 'AlainPlantec 10/17/2013 09:12'! onSelectionChangeSend: aSelector to: anObject self on: MorphTreeSelectionChanged send: aSelector to: anObject! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 11:25'! rootNodes ^ (self rootItems ifNil: [^nil]) collect: [:ci | self rootNodeFromItem: ci]. ! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 1/29/2010 09:33'! setSelection: aSelection selection := aSelection. ! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! selectAllNodePaths: aCollectionOfNodePath self selection: (MorphTreeMorphMultipleSelection new selectedNodePathList: aCollectionOfNodePath)! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 11/18/2009 08:17'! selection ^ selection. ! ! !MorphTreeModel methodsFor: 'dialog' stamp: 'AlainPlantec 10/2/2011 16:59'! dialogWindowIn: aWindow title: aTitle ^ self dialogWindowIn: aWindow title: aTitle selectedtems: Array new! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/16/2013 16:52'! enable self enabled: true! ! !MorphTreeModel methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/18/2013 10:25'! expandRoots self requestView: (MorphTreeChangeRequest expandRoots)! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:56'! autoMultiSelection: aBoolean autoMultiSelection := aBoolean ! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! promptForCancel "Ask if it is OK to cancel changes" ^(self confirm: 'Changes have not been saved. Is it OK to cancel changes?' translated) ! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! okToDiscardEdits ^ self canDiscardEdits or: [self promptForCancel]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:03'! isCheckList: aBoolean ^ isCheckList := aBoolean! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/16/2013 16:52'! disable self enabled: false! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:57'! headerLabel: aString headerLabel := aString! ! !MorphTreeModel methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/17/2013 12:01'! expandAllFromNode: aNode self requestView: (MorphTreeChangeRequest expandAllFromNode: aNode) ! ! !MorphTreeModel methodsFor: 'announcing' stamp: 'AlainPlantec 10/11/2011 11:50'! on: anAnnouncementClass send: aSelector to: anObject self announcer on: anAnnouncementClass send: aSelector to: anObject! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/2/2011 16:08'! selectedItems ^ selection ifNil: [OrderedCollection new] ifNotNil: [selection selectedItems]! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! selectedNode ^ self selectedNodePath ifNotNil: [:path | path ifEmpty: [nil] ifNotEmpty: [path last]]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 11:30'! treeMorphClass ^ MorphTreeMorph ! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:08'! beCheckList self isCheckList: true ! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! defaultPageSize ^ nil! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! rootNodeClassFromItem: anItem ^ MorphTreeNodeModel! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! rootNodeFromItem: anItem ^ (self rootNodeClassFromItem: anItem) with: anItem model: self! ! !MorphTreeModel methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/17/2013 10:01'! expandNodePath: aNodePath self requestView: (MorphTreeChangeRequest expandNodePath: aNodePath)! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! keyStroke: anEvent from: aTreeView! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! selectNodePath: aNodePath self selection: (MorphTreeMorphSingleSelection new selectedNodePath: aNodePath)! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 10/17/2013 10:00'! selectAll self requestView: MorphTreeChangeRequest selectAll! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:57'! multiSelection: aBoolean multiSelection := aBoolean! ! !MorphTreeModel methodsFor: 'wrapping' stamp: 'AlainPlantec 10/11/2011 10:58'! wrapItem: anItem "Here I return the display of my item, wrapped or not, using a block or a selector which will be performed directly on the item" ^ self wrapBlockOrSelector isBlock ifTrue: [wrapBlockOrSelector cull: anItem] ifFalse: [wrapBlockOrSelector isSymbol ifTrue: [| numArgs | numArgs := wrapBlockOrSelector numArgs. numArgs isZero ifTrue: [anItem perform: wrapBlockOrSelector] ifFalse: [numArgs = 1 ifTrue: [anItem perform: wrapBlockOrSelector with: anItem] ifFalse: [self error: 'Wrong number of arguments']]] ifFalse: [anItem]]! ! !MorphTreeModel methodsFor: 'updating' stamp: 'AlainPlantec 10/17/2013 09:40'! updateList self requestView: MorphTreeChangeRequest updateList ! ! !MorphTreeModel methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/17/2013 12:02'! expandAll self requestView: MorphTreeChangeRequest expandAll ! ! !MorphTreeModel methodsFor: 'dialog' stamp: 'MarcusDenker 9/13/2013 16:30'! openDialogWindowIn: aWindow title: aTitle selectedtems: aCollection | dialog | dialog := self dialogWindowIn: aWindow title: aTitle selectedtems: aCollection. aWindow openModal: dialog. ^ dialog cancelled ifFalse: [self selectedItems] ! ! !MorphTreeModel methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/17/2013 12:08'! collapseAll self requestView: MorphTreeChangeRequest collapseAll! ! !MorphTreeModel methodsFor: 'keyboard managing' stamp: 'EstebanLorenzano 3/19/2014 13:44'! arrowEvent: event key: aChar target: aMorph "Give model the capability of handle a key before is handled by MorphTreeListManager" ^ false! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:57'! wrapBlockOrSelector: aBlockOrSelector wrapBlockOrSelector := aBlockOrSelector! ! !MorphTreeModel methodsFor: 'dialog' stamp: 'AlainPlantec 10/7/2011 10:58'! openDialogWindowIn: aWindow title: aTitle ^ self openDialogWindowIn: aWindow title: aTitle selectedtems: Array new! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! selectedItem ^ self selectedNode ifNotNil: [:node | node item]! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 10/17/2013 09:40'! selection: aSelection self setSelection: aSelection. self requestView: MorphTreeChangeRequest updateSelectionFromModel ! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/17/2013 12:13'! enabled: aBoolean aBoolean ~= enabled ifTrue: [ enabled := aBoolean. self requestView: MorphTreeChangeRequest enabled]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:53'! rootItems ^ rootItems ifNil: [ rootItems := {} ]! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! menu: menu shifted: b ^ menu! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! defaultChunkSize ^ nil! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 10/17/2013 12:05'! deselectAll self requestView: MorphTreeChangeRequest deselectAll! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 22:56'! announcer ^ announcer ifNil: [announcer := Announcer new]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:54'! rootItems: aCollection rootItems := aCollection. ! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 10/17/2013 09:59'! selectItems: aListOfItems self requestView: ( MorphTreeChangeRequest selectItems: aListOfItems )! ! !MorphTreeModel methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/18/2013 10:24'! expandItemPath: anItemPath self requestView: (MorphTreeChangeRequest expandItemPath: anItemPath)! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:28'! autoMultiSelection ^ autoMultiSelection ifNil: [autoMultiSelection := false]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:57'! wrapBlockOrSelector ^ wrapBlockOrSelector ifNil: [wrapBlockOrSelector := #printString]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:03'! isCheckList ^ isCheckList ifNil: [isCheckList := false]! ! !MorphTreeModel methodsFor: 'view' stamp: 'AlainPlantec 10/11/2011 12:10'! defaultTreeMorph | col | col := MorphTreeColumn new rowMorphGetSelector: [:node | StringMorph contents: node item asString]. self headerLabel ifNotNil: [ col headerButtonLabel: self headerLabel font: nil]. ^ (self treeMorphClass on: self) columns: (Array with: col); hResizing: #spaceFill; vResizing: #spaceFill; resizerWidth: 0; columnInset: 0; rowInset: 2; keystrokeActionSelector: #keyStroke:; preferedPaneColor: Color white; multiSelection: self multiSelection; autoMultiSelection: self autoMultiSelection; itemStringGetter: [:item | self wrapItem: item]; isCheckList: self isCheckList; rowColorForEven: Color veryLightGray muchLighter odd: Color white.! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! selectedNodePath ^ self selection ifNotNil: [:s | s lastSelectedNodePath]! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 10/17/2013 09:14'! selectionChanged self requestView: (MorphTreeSelectionChanged new selection: self selection) ! ! !MorphTreeModel methodsFor: 'accessing' stamp: ''! deeplyDetect: aBlock self rootNodes do: [:sub | (sub deeplyDetect: aBlock) ifNotNil: [:found | ^ found]]. ^ nil ! ! !MorphTreeModel methodsFor: 'help-text' stamp: 'GuillermoPolito 11/7/2013 15:55'! helpText ^ nil! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:28'! multiSelection ^ multiSelection ifNil: [multiSelection := false]! ! !MorphTreeModel methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/18/2013 10:08'! collapseNodePath: aNodePath self requestView: (MorphTreeChangeRequest collapseNodePath: aNodePath)! ! !MorphTreeModel methodsFor: 'dialog' stamp: 'AlainPlantec 10/9/2011 15:01'! dialogWindowIn: aWindow title: aTitle selectedtems: aCollection | dialog treeMorph | dialog := self theme newPluggableDialogWindowIn: aWindow title: aTitle for: (treeMorph := self defaultTreeMorph). treeMorph buildContents; selectedItems: aCollection. dialog defaultFocusMorph: treeMorph. dialog minimumExtent: 300 @ 500. dialog beResizeable. ^ dialog ! ! !MorphTreeModel class methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/11/2011 11:11'! itemsList: itemsList itemsHeaderName: aName ^ self new rootItems: itemsList; headerLabel: aName; yourself! ! !MorphTreeModel class methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/11/2011 11:12'! itemsList: itemsList itemsHeaderName: aName wrapBlockOrSelector: wrapBlockOrSelector ^ self new wrapBlockOrSelector: wrapBlockOrSelector; rootItems: itemsList; headerLabel: aName; yourself! ! !MorphTreeModel class methodsFor: 'examples' stamp: 'MarcusDenker 5/6/2013 17:11'! checkListExample2 "self checkListExample2" | model | model := self new rootItems: Morph methods. model wrapBlockOrSelector: #selector; autoMultiSelection: true; headerLabel: 'Plop'; beCheckList. ^ (model openDialogWindowIn: World title: 'All Morph methods') ! ! !MorphTreeModel class methodsFor: 'examples' stamp: 'AlainPlantec 10/11/2011 11:10'! checkListExample1 "self checkListExample1" Cursor wait showWhile: [ ^ self new beCheckList; rootItems: (Object allSubclasses sort: [:a :b | a name <= b name]); headerLabel: 'Sub-classes'; openDialogWindowIn: World title: 'All Object sub-classes ready to be checked']! ! !MorphTreeModel class methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/11/2011 11:11'! itemsList: itemsList ^ self new rootItems: itemsList; yourself! ! !MorphTreeModel class methodsFor: 'examples' stamp: 'AlainPlantec 10/11/2011 14:55'! checkListExample3 "self checkListExample3" Cursor wait showWhile: [ ^ ((self new beCheckList; autoMultiSelection: true; rootItems: (Object allSubclasses sort: [:a :b | a name <= b name]); headerLabel: 'Sub-classes'; defaultTreeMorph) buildContents; embeddedInMorphicWindowLabeled: 'All Object sub-classes ready to be checked') openInWorld]! ! !MorphTreeModel class methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme ^ Smalltalk ui theme! ! !MorphTreeMorph commentStamp: 'AlainPlantec 2/13/2010 07:41'! A MorphTreeMorph is a list and a tree in one easily customizable widget. A list or tree is made of nodes. Each node can be made of whatever object . This allows the use of morphs inside the tree. A MorphTreeMorph works with a model which must use the TMorphTreeModel trait. MorphTreeModel uses it and can serves as the model or as a superclass for a specific tree model. Customizable columns: Several customizable columns can be viewed. Columns are separated by resizers used in order to increase or decrease the columns width with the mouse. A MorphTreeMorph can have a top header composed of buttons, one button per column. Such a button can have an icon and/or a title and may run some action when clicked on (a typical action is the ordering of the list). You can also allow column drag-and-drop so that a column can be dynamically moved with a simple drop. See this in action with following example: ----------- ClassListExample new openOn: Collection ----------- By default, the last column is not bounded, so that no resizer is added for it and threre exists no unused space between the last scroller and the right side of the whole tree. But, in some case one want to have a resizer also for the last column. This is the case for data grid as an example This is possible by sending #makeLastColumnBounded to the MorphTreeMorph. Try it with: ----------- SimpleGridExample new open ----------- Single and multi-selection: A MorphTreeMorph implements single and multiple selection. Multi-selection is allowed by sending #multiSelection: with true as argument. Several items can be selected with ctrl-click (or cmd-click on mac) or with shift-click (see MorphTreeMorphModel comments to see how to handle selection from the model). Try multi-selection with following example: ------------ SimplestClassListExample new openOn: Collection ------------ Double-click handling: You can allow double-click just by indicating the message to send to the model with the doubleClickSelector: selector. Try this with the package-tree example where double-clicking on a class node or or a method node open a browser on the class or on the method: ------------ PackageTreeExample new open ------------ Long list handling: For very long lists or trees, two kind of pager can be used to limit the number of items visible in the list. The idea is that when you have very long lists, you most of the time do not want to see all details but just want some visual support for what is in the list: - with a simple pager, you indicate how much items are to be seen in one page, the list items are viewed page by page, - with a chunk pager you can expand either incrementally or all-together the number of items once you get to the bottom of the existing items. See SimplestClassListWithPagerExample and SimplestClassListWithChunkExample examples. Try them with: ------------ SimplestClassListWithPagerExample new openOn: Object. SimplestClassListWithChunkExample new openOn: Object. ------------ Columns/rows coloring: MorphTreeMorph makes it possible the coloring of either the columns or the rows. A MorphTreeMorph understands #rowColorForEven:odd: for rows coloring and columnColorForEven:odd: for columns coloring with two colors passed as argument (nil means no color). See following examples: ------------- PackageTreeExample new open. "For row coloring" ClassListExample new openOn: Collection. "For column coloring" ------------- Column drag and drop A column can be dragged. Inside the tree, a column can be dropped into another one. Then, the two columns are swapped (the roughly implemented) Try it with: ------------- ClassListExample new openOn: Collection. ------------- Instance Variables autoDeselection: autoMultiSelection: columnColors: columnDropUnabled: columnInset: columnResizers: columns: doubleClickSelector: expandedToggleImage: gapAfterIcon: gapAfterToggle: getListSelector: getSelectionSelector: hasToggleAtRoot: iconReservedExtent: indentGap: keystrokeActionSelector: lastSelectedMorph: lineColor: multipleSelection: nodeList: nodeSortBlock: notExpandedToggleImage: pager: potentialDropMorph: preferedPaneColor: resizerWidth: rowColors: rowInset: scrollDeltaHeight: selectedMorphList: setSelectionSelector: shiftSelectedMorph: topHeader: topHeaderBackground: unboundLastColumn: withHLines: autoDeselection - xxxxx autoMultiSelection - xxxxx columnColors - xxxxx columnDropUnabled - xxxxx columnInset - xxxxx columnResizers - xxxxx columns - xxxxx doubleClickSelector - xxxxx expandedToggleImage - xxxxx gapAfterIcon - xxxxx gapAfterToggle - xxxxx getListSelector - xxxxx getSelectionSelector - xxxxx hasToggleAtRoot - xxxxx iconReservedExtent - xxxxx indentGap - xxxxx keystrokeActionSelector - xxxxx lastSelectedMorph - xxxxx lineColor - xxxxx multipleSelection - xxxxx nodeList - xxxxx nodeSortBlock - xxxxx notExpandedToggleImage - xxxxx pager - xxxxx potentialDropMorph - xxxxx preferedPaneColor - xxxxx resizerWidth - xxxxx rowColors - xxxxx rowInset - xxxxx scrollDeltaHeight - xxxxx selectedMorphList - xxxxx setSelectionSelector - xxxxx shiftSelectedMorph - xxxxx topHeader - xxxxx topHeaderBackground - xxxxx unboundLastColumn - xxxxx withHLines - xxxxx ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/3/2010 10:04'! treeLineDashes: anArrayOfInteger treeLineDashes := anArrayOfInteger ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/29/2009 10:08'! toggleImageHeight ^ self expandedToggleImage height max: self notExpandedToggleImage height.! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 11/18/2009 07:29'! isSingle ^ self isMultiple not! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'BenjaminVanRyseghem 11/2/2013 18:14'! columns: aListOfTreeColumn "set the columns - as a consequence, the topHeader is update (if present) and column resizers are added" self removeColumnResizers. topHeader ifNotNil: [ self removeMorph: topHeader ]. columns := aListOfTreeColumn asOrderedCollection. aListOfTreeColumn do: [:col | col container: self]. self buildTopHeader . self addColumnResizers. ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 10/29/2009 10:08'! preferedPaneColor: aColor self color: (preferedPaneColor := aColor). ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 21:24'! addColumn: aTreeColumn afterIndex: aPosition "add a column at a given index then update the list in order to take the new column into account" aTreeColumn container: self. self columns add: aTreeColumn afterIndex: aPosition. self columnsChanged. self updateColumnMorphs. self updateList ! ! !MorphTreeMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 4/21/2013 00:14'! initializeColumsFrom: aModel self columns: aModel columns! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 21:23'! addColumn: aTreeColumn "add a column" self addColumn: aTreeColumn afterIndex: self columns size! ! !MorphTreeMorph methodsFor: 'initialization' stamp: 'AlainPlantec 10/10/2011 23:16'! initialize "initialize the state of the receiver" super initialize. columnColors := Array with: Color transparent with: Color transparent. rowColors := Array with: Color transparent with: Color transparent. self borderWidth: 0. ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 21:42'! columnsChanged "A column has been added or removed or swapped with another one - rebuild all resizers and the top header" self removeColumnResizers. self removeTopHeader. self buildTopHeader. self addColumnResizers. ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 21:32'! columnResizersToFront "Column resizers should always be at top" self columnResizers do: [:cl | cl comeToFront; fillStyle: cl normalFillStyle]. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 16:16'! keystrokeActionSelector: aSelector self listManager keystrokeActionSelector: aSelector! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/16/2013 12:34'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^ self enabled! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/31/2010 22:56'! columnInset: anInteger "Change the horizontal space between a resizer and a row morph" columnInset := anInteger. ! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 21:43'! selectedItems: aNodeItemCollection self listManager selectedItems: aNodeItemCollection! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 1/31/2010 21:37'! mouseEnter: event "Changed to take keyboardFocusOnMouseDown preference into account." super mouseEnter: event. self wantsKeyboardFocus ifFalse: [^self]. self keyboardFocusOnMouseDown ifFalse: [self takeKeyboardFocus]! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'alain.plantec 10/12/2009 23:25'! notExpandedForm "Answer the form to use for unexpanded items." ^self theme treeUnexpandedForm! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 11/22/2013 12:58'! noteRemovalOfAll: aCollection "TODO: update the selection as well" scroller removeAllMorphsIn: aCollection. self listManager isCheckList ifFalse: [ self selectedMorphList do: [ :each | (aCollection includes: each) ifTrue: [ self listManager removeFromSelection: each ] ] ]. self adjustSubmorphPositions ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/10/2011 11:09'! updateContentsWithPreviouslyExpanded: aNodeList nodeList := nil. scroller removeAllMorphs. (self nodeList isNil or: [self nodeList isEmpty]) ifTrue: [nodeList := nil. ^ self emptySelection]. self addSubmorphsFromNodeList: self currentNodelist previouslyExpanded: aNodeList. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/2/2010 16:33'! withTreeLines: aBoolean self treeLineWidth: 1! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/16/2013 12:18'! fillStyleToUse "Answer the fillStyle that should be used for the receiver." ^self enabled ifTrue: [self theme listNormalFillStyleFor: self] ifFalse: [self theme listDisabledFillStyleFor: self]! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 11/26/2009 07:20'! selectNodePath: aPath aPath ifNil: [self emptySelection] ifNotNil: [self firstChild ifNotNil: [:fc | fc selectNodePath: aPath]]! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2009 15:25'! topHeaderBackground ^ topHeaderBackground ifNil: [topHeaderBackground := Color transparent]! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 16:25'! beMultiple self listManager multipleSelection: true! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 17:17'! multiSelection: aBoolean self listManager multipleSelection: aBoolean! ! !MorphTreeMorph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 2/12/2010 21:22'! resetPotentialDropMorph "release the current drop morph candidate" potentialDropMorph ifNotNil: [ potentialDropMorph resetHighlightForDrop. potentialDropMorph := nil] ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/7/2011 13:20'! notExpandedFormForMorph: aMorph ^ (aMorph selected and: [self selectionColor luminance < 0.7]) ifTrue: [self theme whiteTreeUnexpandedForm] ifFalse: [self theme treeUnexpandedForm] ! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/16/2013 12:35'! mouseUp: event "Fixed up highlight problems." | nodeMorph wasHigh | self enabled ifFalse: [ ^self ]. mouseOverAllowed := false. nodeMorph := self scrollerSubMorphFromPoint: event position. wasHigh := nodeMorph notNil ifTrue: [nodeMorph highlightedForMouseDown] ifFalse: [false]. self allNodeMorphs do: [:m | m highlightedForMouseDown ifTrue: [m highlightForMouseDown: false]]. wasHigh ifFalse: [ nodeMorph ifNotNil: [^self]]. self listManager mouseUp: event on: nodeMorph. ! ! !MorphTreeMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 10/10/2011 20:06'! newTransformMorph ^ MorphTreeTransformMorph new ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/9/2011 19:41'! collapseAll self updateContentsWithPreviouslyExpanded: Array new. ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'ThierryGoubier 10/21/2013 17:00'! headerBounds "return the bounds of each top header button (one per column)" | positions controlBounds currPos currLeft | controlBounds := OrderedCollection new. currPos := scroller left. (positions := self columnResizers asOrderedCollection collect: [ :r | r position ]) ifNotEmpty: [ | currRight | currPos := positions removeFirst x. currLeft := scroller left - scroller offset x. currRight := currPos. controlBounds add: (currLeft @ topHeader top corner: currRight @ topHeader bottom). [ positions notEmpty ] whileTrue: [ currLeft := currPos + self resizerWidth. currPos := positions removeFirst x. currRight := currPos. controlBounds add: (currLeft @ topHeader top corner: currRight @ topHeader bottom) ] ]. self columnResizers size < self columns size ifTrue: [ currLeft := currPos + self resizerWidth. controlBounds add: ((currLeft min: scroller right) @ topHeader top corner: scroller right @ topHeader bottom) ]. ^ controlBounds! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 17:12'! autoDeselection: trueOrFalse "Enable/disable autoDeselect (see class comment)" self listManager autoDeselection: trueOrFalse! ! !MorphTreeMorph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 2/12/2010 21:23'! wantsDroppedMorph: aMorph event: anEvent "Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. Note that for a successful drop operation both parties need to agree. The symmetric check is done automatically via aMorph wantsToBeDroppedInto: self." ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 10/11/2011 10:25'! maxNodeWidth ^ maxNodeWidth ifNil: [maxNodeWidth := 0]! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/7/2011 21:23'! mouseEnterDragging: evt | aMorph | (evt hand hasSubmorphs and: [self dropEnabled]) ifFalse: [^super mouseEnterDragging: evt]. (self wantsDroppedMorph: evt hand firstSubmorph event: evt) ifTrue: [ aMorph := self scrollerSubMorphFromPoint: evt position. aMorph ifNotNil:[self potentialDropMorph: aMorph]. evt hand newMouseFocus: self. "above is ugly but necessary for now"].! ! !MorphTreeMorph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 2/12/2010 21:20'! acceptDroppingMorph: aMorph event: evt "This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. This implementation relay the drop to the model then release the morph which was candidate fro a drop" self model acceptDroppingMorph: aMorph event: evt inMorph: self. self resetPotentialDropMorph. evt hand releaseMouseFocus: self. Cursor normal show. ! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'alain.plantec 10/12/2009 23:25'! mouseLeaveDragging: anEvent (self dropEnabled and:[anEvent hand hasSubmorphs]) ifFalse: ["no d&d" ^ super mouseLeaveDragging: anEvent]. self resetPotentialDropMorph. anEvent hand releaseMouseFocus: self. "above is ugly but necessary for now" ! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/31/2010 22:57'! gapAfterToggle: anInteger "set the horizontal space after the toggle" gapAfterToggle := anInteger. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 9/30/2011 16:14'! hasIconBlock ^ iconBlock notNil! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/16/2013 16:57'! enabledFromModel | val | self model ifNil: [ ^ self ]. val := self model enabled. val ~= self enabled ifTrue: [ self enabled: val ] ! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/7/2011 21:23'! scrollerSubMorphFromPoint: aPoint "Return the list element (morph) at the given point or nil if outside" | ptY | scroller hasSubmorphs ifFalse:[^nil]. ptY := (scroller firstSubmorph point: aPoint from: self) y. "note: following assumes that submorphs are vertical, non-overlapping, and ordered" scroller firstSubmorph top > ptY ifTrue:[^nil]. scroller lastSubmorph bottom < ptY ifTrue:[^nil]. "now use binary search" ^scroller findSubmorphBinary: [:item| (item top <= ptY and:[item bottom >= ptY]) ifTrue:[0] "found" ifFalse:[ (item top + item bottom // 2) > ptY ifTrue:[-1] ifFalse:[1]]]! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/7/2011 21:25'! toggleExpandedState: aMorph event: event | oldState | event yellowButtonPressed ifTrue: [ oldState := aMorph isExpanded. self allNodeMorphs copy do: [ :each | (each canExpand and: [each isExpanded = oldState]) ifTrue: [each toggleExpandedState]]] ifFalse: [aMorph toggleExpandedState]. self adjustSubmorphPositions. ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/18/2013 09:30'! expandItemPath: aNodePath (self allNodeMorphs at: 1 ifAbsent: [^self]) openItemPath: aNodePath! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 22:04'! removeColumn: aTreeColumn "Remove a column - rough implementation" self removeColumnAtIndex: (self columns indexOf: aTreeColumn)! ! !MorphTreeMorph methodsFor: 'submorphs-add/remove' stamp: 'AlainPlantec 10/6/2011 22:24'! addSubmorphsFromNodeList self addSubmorphsFromNodeList: self currentNodelist previouslyExpanded: #() ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/29/2009 10:07'! hasToggleAtRoot ^ hasToggleAtRoot ifNil: [hasToggleAtRoot := self roots anySatisfy: [:s | s hasToggle]] ! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'cami 7/22/2013 18:28'! commandOrCrontrolKeyPressed: anEvent ^ (Smalltalk os isMacOS) ifTrue: [anEvent controlKeyPressed] ifFalse: [anEvent commandKeyPressed]! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/17/2009 16:25'! minResizerX ^ scroller left + self minResizerOffset! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 1/22/2010 18:38'! expandedNodesFrom: aMorpList ^ (aMorpList select: [ :each | each isExpanded]) collect: [ :each | each complexContents]. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 11:04'! currentNodelist "The nodeList currently viewed " ^ self nodeList! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 11/17/2009 19:47'! columnColorForEven: evenColor odd: oddColor columnColors at: 2 put: oddColor. columnColors at: 1 put: evenColor. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 19:39'! doubleClickBlock: aValuableWithNoArg "set a double click action" self listManager doubleClickBlock: aValuableWithNoArg! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/29/2009 10:08'! withHLines ^ withHLines ifNil: [withHLines := false]! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 18:29'! selectedMorph ^ self listManager selectedMorph! ! !MorphTreeMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 10/10/2011 19:16'! hScrollBarValue: scrollValue | prev | prev := scroller offset x. super hScrollBarValue: scrollValue. scroller offset x ~= prev ifTrue: [ self updateColumnResizersXOffset. self updateTopHeader]! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/8/2011 22:55'! updateFromSelection: aSelection aSelection selectedNodePathList do: [:path | self selectNodePath: path]. self scrollSelectionIntoView! ! !MorphTreeMorph methodsFor: 'announce requests' stamp: 'AlainPlantec 5/27/2012 10:04'! registerRequestHandlers self model announcer on: MorphTreeChangeRequest send: #changeRequest: to: self.! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'alain.plantec 10/12/2009 23:25'! expand: aMorph to: level | allChildren | aMorph toggleExpandedState. allChildren := OrderedCollection new: 10. aMorph recursiveAddTo: allChildren. allChildren do: [:each | ((each canExpand and: [each isExpanded not]) and: [level > 0]) ifTrue: [self expand: each to: level-1]].! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/9/2011 01:23'! keyStroke: event "Process potential command keys." (self navigationKey: event) ifTrue: [^true]. (self scrollByKeyboard: event) ifTrue: [^true]. ^ self listManager keyStroke: event! ! !MorphTreeMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 10/7/2011 18:28'! scrollSelectionIntoView "make sure that the current selection is visible" self listManager selectedMorph ifNotNil: [:morph | self scrollToShow: morph bounds ]! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/8/2011 23:50'! selectedMorphList ^ self listManager selectedMorphList! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 21:46'! columnDropUnabled "return true if column drop is enabled - see also #allowColumnDrop" ^ columnDropUnabled ifNil: [columnDropUnabled := false]! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 2/17/2010 20:28'! expandAllSuchThat: aBlock self roots do: [:m | self expand: m suchThat: aBlock]. self innerWidgetChanged! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/7/2011 22:23'! mouseStillDown: anEvent (anEvent hand position y > self innerBounds bottom) ifTrue: [self listManager selectMoreAtBottom] ifFalse: [ (anEvent hand position y < self innerBounds top) ifTrue: [self listManager selectMoreAtTop] ifFalse: [super mouseStillDown: anEvent]]! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'BenjaminVanRyseghem 11/22/2013 15:33'! expandRoots "Expand all the receiver's roots" self roots do: [:each | (each canExpand and: [each isExpanded not]) ifTrue: [each toggleExpandedState]]. self innerWidgetChanged! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/16/2013 12:15'! enable self enabled: true! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 09:02'! iconBlock ^ iconBlock ifNil: [[:node | node icon]]! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 2/3/2010 09:46'! lineColor: aColor lineColorBlock := [:node | aColor] ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'MarcusDenker 10/28/2010 14:02'! expandSilently: aMorph suchThat: aBlock (aBlock value: aMorph complexContents) ifTrue: [ aMorph isExpanded ifFalse: [aMorph expand]. aMorph childrenDo: [:ch | self expandSilently: ch suchThat: aBlock]]. ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 10/1/2011 08:59'! rowMorphsWidths "Return all row morphs witdhs based on the header bounds. used when a resizer is moved horizontally or if some change implies that the list is rebuilt" | result | result := self headerBounds collect: [:b | b width]. result ifNotEmpty: [result at: 1 put: ((result at: 1) - 3 )]. ^ result ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 21:31'! columnResizerFrames "return all resizers bounds in a collection - used to update column resizers position" | xOffset frms | xOffset := 0. frms := self columns collect: [:col | xOffset := self minResizerOffset max: (xOffset + col currentWidth). scroller left + xOffset @ self top corner: scroller left + xOffset + self resizerWidth @ scroller bottom]. "If the last column is unbounded, then its frame is removed from the collection because no resizer is added for the last column" self lastColumnUnbounded ifTrue: [frms ifNotEmpty: [frms removeLast]]. ^ frms collect: [:f | f translateBy: (scroller offset x negated @ 0)]! ! !MorphTreeMorph methodsFor: 'announce requests' stamp: 'AlainPlantec 5/26/2012 00:10'! selectItemsRequest: anAnnounce self selectedItems: anAnnounce itemsToSelect ! ! !MorphTreeMorph methodsFor: 'event handling' stamp: 'alain.plantec 10/12/2009 23:25'! handlesKeyboard: evt ^true! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/13/2010 07:38'! makeLastColumnBounded "Make the last column horizontally resizable with a resizer" self lastColumnBounded ifFalse: [ unboundLastColumn := false. self columnsChanged] ! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/27/2010 11:25'! resizerWidth ^ resizerWidth ifNil:[resizerWidth := 3]! ! !MorphTreeMorph methodsFor: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:30'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation! ! !MorphTreeMorph methodsFor: 'announce requests' stamp: 'AlainPlantec 5/26/2012 00:08'! changeSelectionRequest: anAnnounce self updateSelectionFromModel! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 2/3/2012 21:42'! vExtraScrollRange "Return the amount of extra blank space to include below the bottom of the scroll content." "The classic behavior would be ^bounds height - (bounds height * 3 // 4)" "Takes into accound the top header height if present" ^ super vExtraScrollRange + self topHeaderHeight ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 21:33'! columns "Return a column definitions, if empty, return a collection with one column" ^columns ifNil: [self columns: (OrderedCollection with: MorphTreeColumn new). columns]! ! !MorphTreeMorph methodsFor: 'announce requests' stamp: 'AlainPlantec 5/28/2012 14:29'! changeRequest: anAnnounce ^ anAnnounce change: self! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'MarcusDenker 9/13/2013 16:30'! expandAllSilently: aMorph aMorph isExpanded ifFalse: [aMorph expand]. aMorph childrenDo: [:ch | self expandAllSilently: ch]. ! ! !MorphTreeMorph methodsFor: 'submorphs-add/remove' stamp: 'AlainPlantec 10/7/2011 18:52'! addSubmorphsFromNodeList: aNodeList previouslyExpanded: expandedNodeList | morphList | morphList := OrderedCollection new. self addMorphsTo: morphList from: aNodeList withExpandedItems: expandedNodeList atLevel: 0. self insertNewMorphs: morphList. self listManager updateSelectionFromModel. self roots do: [:r | r updateChildrenRecursively]. self updateColumnMorphs ! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/9/2011 01:21'! handleMouseMove: anEvent "Reimplemented because we really want #mouseMove when a morph is dragged around" anEvent wasHandled ifTrue:[^self]. (anEvent isDraggingEvent or:[ anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]]) ifFalse:[^self]. anEvent wasHandled: true. self mouseMove: anEvent. (self handlesMouseStillDown: anEvent) ifTrue: [ "Step at the new location" self startStepping: #handleMouseStillDown: at: Time millisecondClockValue + self mouseStillDownThreshold arguments: {anEvent copy resetHandlerFields} stepTime: self mouseStillDownStepRate]. ! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 21:34'! selectAll self listManager selectAll! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/31/2010 22:56'! gapAfterToggle "horizontal space after the toggle" ^ gapAfterToggle ifNil: [gapAfterToggle := 5]! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/29/2009 10:08'! toggleImageWidth ^ self expandedToggleImage width max: self notExpandedToggleImage width.! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/17/2013 09:28'! model: aTreeModel self model ifNotNil: [self model announcer unsubscribe: self]. super model: aTreeModel. self registerRequestHandlers ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/31/2011 16:25'! mouseDownHighlightColor "Answer a good color to use for drawing the mouse down highlight. Used the line color if not transparent, otherwise a contrasting color in the same way as the line color is determined. Fall back to black if all my owners are transparent." |colored | colored := self color isTransparent ifTrue: [self firstOwnerSuchThat: [:o | o isWorldOrHandMorph not and: [o color isTransparent not]]] ifFalse: [self]. colored ifNil: [^Color black]. ^colored color luminance > 0.5 ifTrue: [Color black] ifFalse: [Color white] ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 22:05'! removeColumnAtIndex: aPosition. "remove a column at a given position - rough implementation" self columns removeAt: aPosition. self columnsChanged. self updateList. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/3/2010 10:04'! treeLineDashes ^ treeLineDashes ifNil: [treeLineDashes := self theme treeLineDashes] ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 22:02'! lastColumnBounded "Return true if the last column can be resized with a resizer" ^ self lastColumnUnbounded not! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'BenjaminVanRyseghem 5/7/2013 14:19'! yellowButtonEvent: anEvent (self scrollerSubMorphFromPoint: anEvent position) ifNotNil: [:sel | sel selected ifFalse: [self listManager setSelectedMorph: sel]. ^ self yellowButtonActivity: anEvent shiftPressed ]. ^ self yellowButtonActivity: anEvent shiftPressed! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2009 13:24'! topHeaderHeight | h | self topHeader ifNil: [^ 0] ifNotNil: [:th | h := th borderWidth * 2. self columns do: [:col | h := h max: col height]. ^ h] ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2009 18:41'! topHeader ^ topHeader ! ! !MorphTreeMorph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 2/12/2010 21:22'! potentialDropMorph: aMorph "Set the morph (the MorphTreeNodeMorph) which is the current drop target candidate " potentialDropMorph := aMorph. aMorph highlightForDrop! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 11/25/2009 09:27'! selectionFrameFor: aNodeMorph "Answer the frame of aNodeMorph in the receiver" ^ aNodeMorph bounds: aNodeMorph selectionFrame in: self! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/3/2011 11:11'! privateUpdateColumnMorphs self resetRootInfo. self updateTopHeader. self innerWidgetChanged. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/29/2009 10:08'! withHLines: aBoolean withHLines := aBoolean! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 1/30/2010 09:09'! updateTopHeader self topHeader ifNotNil: [:th | | w | th width: scroller width. w := self headerBounds. th submorphsDo: [:sm | w ifNotEmpty: [sm bounds: w removeFirst; layoutInset: self columnInset @ 0]]]. ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'StephaneDucasse 5/23/2013 18:39'! expandedToggleImage ^ expandedToggleImage ifNil: [expandedToggleImage := ImageMorph new form: self expandedForm]. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/12/2010 22:02'! itemStringGetter: aValuable "Set how to get a string for the first column with a valuable which takes a row item (from a MorphTreeMorphNode point of view, its complexContents item) as argument" self columns first itemStringGetter: aValuable! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 10/11/2011 00:37'! extent: newExtent super extent: newExtent. self resizerChanged. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/15/2009 21:58'! indentingItemClass ^ MorphTreeNodeMorph! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/3/2011 00:29'! innerWidgetChanged self setScrollDeltas. self updateColumnMorphsWidth. self adjustSubmorphPositions. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/6/2011 16:58'! roots "Answer the receiver's roots" ^ self rootsFrom: self allNodeMorphs ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'MarcusDenker 10/3/2013 23:48'! lineColorForNode: aNode "Answer a good color to use for drawing the lines that connect members of the hierarchy view. Used the cached color, or derive it if necessary by finding the receiver or the first owner (up to my root) that is not transparent, then picking a contrasting color. Fall back to black if all my owners are transparent." ^ lineColorBlock ifNotNil: [lineColorBlock value: aNode] ifNil: [ | colored | colored := self color isTransparent ifTrue: [self firstOwnerSuchThat: [:o | o isWorldOrHandMorph not and: [o color isTransparent not]]] ifFalse: [self]. colored ifNil: [Color black] ifNotNil: [colored color luminance > 0.5 ifTrue: [Color black] ifFalse: [Color white]]] ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/9/2011 00:11'! firstNodeMorph "returns the first scroller submorph if not empty, or nil if empty" ^ self allNodeMorphs ifEmpty: [nil] ifNotEmpty: [scroller submorphs at: 1]! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 1/31/2010 22:23'! currentlyExpanded ^ self expandedNodesFrom: (self allNodeMorphs). ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 1/31/2010 22:53'! firstChild "returns the first scroller submorph if not empty, or nil if empty" ^ self firstNodeMorph! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/29/2009 10:08'! resetRootInfo hasToggleAtRoot := nil.! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 2/12/2011 19:32'! selectionChanged self changed ! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/7/2011 21:18'! doubleClick: anEvent | targetMorph | targetMorph := self scrollerSubMorphFromPoint: anEvent position. (self listManager doubleClick: anEvent on: targetMorph) ifFalse: [super doubleClick: anEvent] ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/3/2011 00:11'! resizerChanged self columns size > 1 ifTrue: [ self updateColumnResizersXOffset; resizeScroller; updateColumnMorphs] ifFalse: [self updateTopHeader]! ! !MorphTreeMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 11/14/2009 09:06'! scrollDeltaWidth "A guess -- assume that the width of a char is approx 1/2 the height of the font" ^ self scrollDeltaHeight // 2 ! ! !MorphTreeMorph methodsFor: 'submorphs-add/remove' stamp: 'BenjaminVanRyseghem 11/26/2013 18:29'! addMorphsAfter: parentMorph fromCollection: aCollection "Sent when expanding a node in order to add chilldren nodes after the expanded node" | priorMorph morphList subs | priorMorph := nil. morphList := OrderedCollection new. "prepare the list of nodes to be added" aCollection do: [:item | priorMorph := self indentingItemClass new initWithContents: item prior: priorMorph forList: self indentLevel: parentMorph indentLevel + 1. morphList add: priorMorph. "Was this row expanded ? if true -> expand it again " priorMorph isExpanded ifTrue: [priorMorph isExpanded: true. priorMorph addChildrenForList: self addingTo: morphList withExpandedItems: #()] ]. "Set new child morphs index" 1 to: morphList size do: [:i | | m | (m := morphList at: i) index: i + parentMorph index]. "Add the new morph list in the scroller" scroller addAllMorphs: morphList after: parentMorph. "update next morphs index" subs := self allNodeMorphs. morphList last index to: subs size do: [:pos | (subs at: pos) index: pos]. "set the new morphs widths according to columns width" self updateColumnMorphsWidth. morphList do: [ :e | e doLayoutIn: e layoutBounds ]. ^morphList ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 21:38'! swapColumnAt: oneIndex withColumnAt: anotherIndex "swap two column - very rough implementation which simply rebuild everything" self columns swap: oneIndex with: anotherIndex. self columnsChanged. self updateList. self columnResizersToFront ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 22:02'! lastColumnUnbounded "Return true if the last column can not be resized with a resizer" ^ unboundLastColumn ifNil: [unboundLastColumn := true]! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 11/20/2009 16:51'! rowColorForEven: evenColor odd: oddColor rowColors at: 2 put: oddColor. rowColors at: 1 put: evenColor. ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 11/20/2009 16:59'! rowColors ^ rowColors! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 2/2/2010 16:30'! treeLineWidth: anInteger treeLineWidth := anInteger! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/11/2011 13:30'! adjustSubmorphPositionsOf: aCollection startIdx: anIndex startPos: aStartPoint | p idx | p := aStartPoint. idx := anIndex. aCollection do: [ :each | | h | h := each height. each index: idx. each bounds: (p extent: each width @ h). maxNodeWidth := maxNodeWidth max: (each fullBounds width). idx := idx + 1. p := p + (0@h)]. self setScrollDeltas. ^ p ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 4/28/2011 22:32'! rowColorForEven: evenColor rowColors at: 1 put: evenColor. ! ! !MorphTreeMorph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 2/12/2010 21:46'! forbidColumnDrop "Do not allow column drag and drop" columnDropUnabled := false! ! !MorphTreeMorph methodsFor: 'event handling' stamp: 'AlainPlantec 10/9/2011 15:08'! handlesMouseOver: evt ^ self mouseOverAllowed ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/11/2011 01:11'! updateColumnMorphsWidth | rowMorphsWidths | self columns size > 1 ifFalse: [^ self]. rowMorphsWidths := self rowMorphsWidths. self allNodeMorphs do: [:i | i updateColumnMorphsWidthWith: rowMorphsWidths]. ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 11/15/2009 18:02'! removeTopHeader topHeader ifNotNil: [self removeMorph: topHeader. topHeader := nil] ! ! !MorphTreeMorph methodsFor: 'initialize - release' stamp: 'AlainPlantec 10/7/2011 21:27'! release lineColorBlock := nil. columnResizers := nil. preferedPaneColor := nil. expandedToggleImage := nil. notExpandedToggleImage := nil. columns ifNotNil: [ columns do: [:col | col release]. columns := nil]. listManager ifNotNil: [ listManager release. listManager := nil]. super release.! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/31/2010 22:56'! columnInset "Horizontal space between a resizer and a row morph" ^ columnInset ifNil: [columnInset := 0]! ! !MorphTreeMorph methodsFor: 'announce requests' stamp: 'AlainPlantec 5/26/2012 00:07'! changeListRequest: anAnnounce self updateList! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/8/2011 23:48'! emptySelection self listManager emptySelection! ! !MorphTreeMorph methodsFor: 'drawing' stamp: 'AlainPlantec 10/6/2011 10:19'! drawOn: aCanvas super drawOn: aCanvas. self columns do: [:col | col drawColumnOn: aCanvas]. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/16/2013 12:15'! disable self enabled: false! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/15/2009 18:16'! resizerWidth: anInteger resizerWidth := anInteger. ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 22:05'! removeColumnResizers "Remove all column resizers" self removeAllMorphsIn: self columnResizers. self columnResizers do: [:r | r release]. self columnResizers removeAll! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/17/2013 12:00'! expandAllFromNode: aNode self expandAll: ((self nodeMorphOfNode: aNode) ifNil: [^self]). self adjustSubmorphPositions ! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 2/2/2010 16:31'! treeLineWidth ^ treeLineWidth ifNil: [treeLineWidth := self theme treeLineWidth] ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/6/2011 16:57'! rootsFrom: aCollectionOfNodes "Answer the receiver's roots" ^ aCollectionOfNodes select: [:each | each indentLevel isZero]! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/11/2011 11:06'! beCheckList self isCheckList: true. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/3/2011 09:59'! nodeStringGetter: aValuable "Set how to get a string for the first column node with a valuable which takes a row MorphTreeMorphNode as argument" self columns first nodeStringGetter: aValuable! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/11/2011 10:22'! adjustSubmorphPositions maxNodeWidth := 0. ^ self adjustSubmorphPositionsOf: self allNodeMorphs startIdx: 1 startPos: 0@0 ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'alain.plantec 10/12/2009 23:25'! expandedForm "Answer the form to use for expanded items." ^self theme treeExpandedForm! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/15/2009 18:16'! indentGap: anInteger indentGap := anInteger. ! ! !MorphTreeMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/23/2012 11:40'! keyboardFocusChange: aBoolean "The message is sent to a morph when its keyboard focus changes. Update for focus feedback." super keyboardFocusChange: aBoolean. self focusChanged! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 11/17/2009 19:47'! columnColorForEven: evenColor columnColors at: 2 put: nil. columnColors at: 1 put: evenColor. ! ! !MorphTreeMorph methodsFor: 'drawing' stamp: 'AlainPlantec 10/6/2011 10:24'! drawLinesOn: aCanvas "Draw the lines for the submorphs. Modified for performance." self hasToggleAtRoot ifFalse: [^ self]. aCanvas transformBy: scroller transform clippingTo: scroller innerBounds during: [:clippedCanvas | scroller submorphsDo: [ :submorph | | last | ((submorph isExpanded and: [ (submorph nextSibling notNil and: [ clippedCanvas isVisible: (submorph fullBounds topLeft corner: submorph nextSibling fullBounds bottomRight)]) or: [ submorph nextSibling isNil and: [(last := submorph lastChild) notNil and: [ clippedCanvas isVisible: (submorph fullBounds topLeft corner: last fullBounds bottomRight)]]]]) or: [ (clippedCanvas isVisible: submorph fullBounds) or: [ (submorph nextSibling notNil and: [ clippedCanvas isVisible: submorph nextSibling fullBounds])]]) ifTrue:[ submorph drawLinesOn: clippedCanvas]]] smoothing: scroller smoothing ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 11/12/2009 21:18'! updateColumnResizersHeight self columnResizers do: [:col | | b | b := col bounds. b := b left @ self top corner: b right @ scroller bottom. col bounds: b]. ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/7/2011 13:18'! expandedFormForMorph: aMorph "Answer the form to use for expanded items." ^ ((aMorph selected) and: [self selectionColor luminance < 0.7]) ifTrue: [self theme whiteTreeExpandedForm] ifFalse: [self theme treeExpandedForm]! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 10/29/2009 10:07'! indentGap ^ indentGap ifNil: [indentGap := 20]! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/10/2011 11:07'! buildContents nodeList := nil. scroller removeAllMorphs. (self nodeList isNil or: [self nodeList isEmpty]) ifTrue: [ nodeList := nil. ^ self emptySelection]. self addSubmorphsFromNodeList. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 1/18/2010 17:49'! nodeList ^ nodeList ifNil: [nodeList := self getList] ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/9/2011 17:00'! insertNewMorphs: morphList scroller addAllMorphs: morphList. ! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 4/4/2011 16:34'! secondarySelectionColor ^ self theme settings secondarySelectionColor! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'MartinDias 2/24/2014 18:08'! startDrag: anEvent | aTransferMorph itemMorph passenger | self dragEnabled ifTrue: [itemMorph := self allNodeMorphs detect: [:any | any highlightedForMouseDown] ifNone: []]. (itemMorph isNil or: [anEvent hand hasSubmorphs]) ifTrue: [^ self]. itemMorph highlightForMouseDown: false. (self listManager selectedMorphList includes: itemMorph) ifFalse: [self listManager setSelectedMorph: itemMorph]. passenger := self model dragPassengerFor: itemMorph inMorph: self. passenger ifNotNil: [ aTransferMorph := self model transferFor: passenger from: self. "Ask the draggedMorph otherwise the transferMorph has not yet its bounds" aTransferMorph align: aTransferMorph draggedMorph center with: anEvent position. aTransferMorph dragTransferType: (self model dragTransferTypeForMorph: self). anEvent hand grabMorph: aTransferMorph]. anEvent hand releaseMouseFocus: self! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/8/2011 17:42'! getList "Answer the full list to be displayed." ^ model rootNodes. ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'MarcusDenker 10/28/2010 14:11'! expandAll: aMorph | subs | self expandAllSilently: aMorph. aMorph updateChildrenRecursively. subs := self scroller submorphs. 1 to: subs size do: [:pos | (subs at: pos) index: pos]. "set the new morphs widths according to columns width" self innerWidgetChanged. ! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/8/2011 13:50'! beSingle self listManager multipleSelection: false! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 2/11/2011 10:37'! selectionColorToUse: aColor "Set the colour for selected items." aColor = self selectionColorToUse ifTrue: [^self]. aColor ifNil: [self removeProperty: #selectionColorToUse] ifNotNil: [self setProperty: #selectionColorToUse toValue: aColor]. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 18:02'! listManager ^ listManager ifNil: [listManager := MorphTreeListManager new client: self] ! ! !MorphTreeMorph methodsFor: 'announce requests' stamp: 'AlainPlantec 5/26/2012 19:30'! nodeCollapseRequest: anAnnounce anAnnounce nodes ifEmpty: [self collapseAll] ifNotEmpty: [:nodes | self collapseNodePath: nodes] ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 11/17/2009 19:40'! columnColors ^ columnColors ! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/16/2013 12:36'! mouseDown: event "Changed to take keybaord focus." | targetMorph selectors | self enabled ifFalse: [ ^self ]. mouseOverAllowed := true. self wantsKeyboardFocus ifTrue: [self takeKeyboardFocus]. (event yellowButtonPressed and: [(self commandOrCrontrolKeyPressed: event) not]) ifTrue: ["First check for option (menu) click" ^ self yellowButtonEvent: event]. (targetMorph := self scrollerSubMorphFromPoint: event position) ifNotNil: [targetMorph hasToggle ifTrue: [(targetMorph inToggleArea: (targetMorph point: event position from: self)) ifTrue: [^ self toggleExpandedState: targetMorph event: event]]]. targetMorph ifNil: [^ super mouseDown: event]. targetMorph highlightForMouseDown. selectors := Array with: #click: with: #doubleClick: with: nil with: (self dragEnabled ifTrue: [#startDrag:]). event hand waitForClicksOrDrag: self event: event selectors: selectors threshold: 10. self listManager mouseDown: event on: targetMorph ! ! !MorphTreeMorph methodsFor: 'event handling' stamp: 'AlainPlantec 10/9/2011 01:27'! handlesMouseStillDown: anEvent "Still down event is used to scroll the selection when the mouse is outside (upon the top of below the bottom)" ^ (self innerBounds containsPoint: anEvent position) not! ! !MorphTreeMorph methodsFor: 'announce requests' stamp: 'AlainPlantec 5/26/2012 00:09'! collapseRequest: anAnnounce anAnnounce nodes ifEmpty: [^ self collapseAll] ifNotEmpty: [:nodes | self collapseNodePath: nodes] ! ! !MorphTreeMorph methodsFor: 'events' stamp: 'AlainPlantec 9/26/2011 23:46'! themeChanged "Update the selection colour." self selectionColor ifNotNil: [self selectionColor: self theme selectionColor]. super themeChanged! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/16/2013 12:15'! enabled ^ enabled ifNil: [ enabled := super enabled ]! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/6/2011 10:46'! updateColumnMorphs self privateUpdateColumnMorphs ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'MarcusDenker 10/28/2010 14:03'! expand: aMorph suchThat: aBlock (aBlock value: aMorph complexContents) ifTrue: [ aMorph isExpanded ifFalse: [aMorph expand]. aMorph childrenDo: [:ch | self expandSilently: ch suchThat: aBlock]]. self innerWidgetChanged.! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/2/2010 16:31'! withTreeLines ^ self treeLineWidth > 0! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 11/21/2013 22:50'! removeOnlyLastSelected: aBoolean self listManager removeOnlyLastSelected: aBoolean! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 10/11/2011 13:11'! innerBounds | inner | inner := super innerBounds. inner := inner withTop: self top + self topHeaderHeight. ^ inner! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/16/2013 14:12'! selectionColorToUse "Answer the colour to use for selected items." self enabled ifFalse: [ ^ self paneColor ]. ^ self valueOfProperty: #selectionColorToUse ifAbsent: [self theme settings selectionColor]. ! ! !MorphTreeMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/18/2013 20:00'! setSelectedMorph: aNodeMorph self listManager setSelectedMorph: aNodeMorph! ! !MorphTreeMorph methodsFor: 'enumeration' stamp: 'alain.plantec 10/24/2009 23:08'! childrenDo: aBlock self roots do: aBlock! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 16:19'! autoMultiSelection: aBoolean self listManager autoMultiSelection: aBoolean! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 09:03'! iconBlock: aValuableWithOneArg "A valuable which value is an icon or nil. takes a node as argument" iconBlock := aValuableWithOneArg! ! !MorphTreeMorph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 2/12/2010 21:21'! potentialDropMorph "return the morph (the MorphTreeNodeMorph) which is the current drop target candidate " ^potentialDropMorph! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/25/2010 08:34'! rowInset: anInteger rowInset := anInteger. ! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/11/2011 11:06'! isCheckList: aBoolean self listManager isCheckList: aBoolean. ! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/25/2010 08:34'! rowInset ^ rowInset ifNil: [rowInset := 0] ! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 9/26/2011 23:44'! selectionColor: aColor "Set the colour for selected items." | w | aColor ifNil: [self removeProperty: #selectionColor] ifNotNil: [self setProperty: #selectionColor toValue: aColor]. w := self ownerThatIsA: SystemWindow. self selectionColorToUse: ( (self theme settings fadedBackgroundWindows not or: [w isNil or: [w isActive]]) ifTrue: [aColor] ifFalse: [self theme unfocusedSelectionColor])! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/3/2009 17:29'! minResizerOffset ^ 20! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 11/18/2009 09:54'! updateColumnResizersXOffset self columnResizerFrames with: self columnResizers do: [:frm :resizer | resizer bounds: (frm withBottom: scroller bottom)]. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 1/31/2010 22:52'! doubleClickSelector: aSelector "set doubleClickBlock from a selector representing a message to sent to the model on double-click" self doubleClickBlock: [self model perform: aSelector]! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/10/2011 22:17'! mouseStillDownStepRate "At what rate do I want to receive #mouseStillDown: notifications?" ^10! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/18/2013 10:03'! expandNodePath: aNodePath (self allNodeMorphs at: 1 ifAbsent: [^self]) openNodePath: aNodePath! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 11/17/2009 19:47'! columnColorForOdd: oddColor columnColors at: 1 put: nil. columnColors at: 2 put: oddColor. ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'StephaneDucasse 5/23/2013 18:39'! notExpandedToggleImage ^ notExpandedToggleImage ifNil: [notExpandedToggleImage := ImageMorph new form: self notExpandedForm]. ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/17/2013 12:03'! expandAll "Expand all of the roots" self roots reverseDo: [:m | self expandAllSilently: m]. self innerWidgetChanged! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'HilaireFernandes 4/21/2013 16:52'! updateList |value| value := scrollBar value. self updateContentsWithPreviouslyExpanded: self currentlyExpanded. self vScrollValue: value! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 1/31/2010 22:26'! allNodeMorphs "all list morphs" ^ scroller submorphs ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 10/16/2013 12:24'! adoptPaneColor: paneColor "Pass on to the selection, the border" super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self color: (self preferedPaneColor ifNil: [paneColor veryMuchLighter]). ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'alain.plantec 10/12/2009 23:25'! expandAll: aMorph except: aBlock | allChildren | (aBlock value: aMorph complexContents) ifFalse: [^self]. aMorph toggleExpandedState. allChildren := OrderedCollection new: 10. aMorph recursiveAddTo: allChildren. allChildren do: [:each | (each canExpand and: [each isExpanded not]) ifTrue: [self expandAll: each except: aBlock]].! ! !MorphTreeMorph methodsFor: 'announce requests' stamp: 'AlainPlantec 5/26/2012 11:10'! nodeExpandRequest: anAnnounce anAnnounce nodes ifEmpty: [self expandAll] ifNotEmpty: [:nodes | anAnnounce recur ifTrue: [self expandAllFromNode: nodes last] ifFalse: [self expandNodePath: nodes]] ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/13/2010 08:10'! swapColumn: aColumn withColumn: anotherColumn "column swapping - this is the default behavior for column drag & drop" self swapColumnAt: aColumn index withColumnAt: anotherColumn index! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 1/11/2010 14:01'! selectionColor "Answer the colour to use for selected items." ^self valueOfProperty: #selectionColor ifAbsent: [self theme settings selectionColor] ! ! !MorphTreeMorph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 2/13/2010 08:09'! allowColumnDrop "allowing column drop means that a column can be dropped into another one. The default behavior is to swap the two columns" columnDropUnabled := true! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/16/2013 13:56'! enabled: aBoolean enabled := aBoolean. self submorphsDo: [ :sm | sm allMorphsDo: [ :m | (m respondsTo: #enabled:) ifTrue: [ m enabled: aBoolean ] ] ]. self changed: #enabled. self changed! ! !MorphTreeMorph methodsFor: 'event handling' stamp: 'alain.plantec 10/12/2009 23:25'! handlesMouseOverDragging: evt ^self dropEnabled! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/16/2013 12:35'! mouseMove: evt | targetMorph | self enabled ifFalse: [ ^self ]. targetMorph := self scrollerSubMorphFromPoint: evt position. evt hand hasSubmorphs ifFalse: [(self innerBounds containsPoint: evt position) ifTrue: [self listManager mouseMove: evt on: targetMorph]]. (self dropEnabled and: [evt hand hasSubmorphs]) ifFalse:[^super mouseMove: evt]. potentialDropMorph ifNotNil:[ (potentialDropMorph containsPoint: (potentialDropMorph point: evt position from: self)) ifTrue:[^self]]. self mouseLeaveDragging: evt. (self containsPoint: evt position) ifTrue: [self mouseEnterDragging: evt].! ! !MorphTreeMorph methodsFor: 'submorphs-add/remove' stamp: 'AlainPlantec 10/6/2011 13:04'! addMorphsTo: morphList from: aCollection withExpandedItems: expandedItems atLevel: newIndent "Sent when building the list (by #buildContents), takes into accound old expanded items: they remain expanded such that a list update don't change the list visual state" | priorMorph firstAddition | priorMorph := nil. firstAddition := nil. "also for the system progress bar" aCollection doWithIndex: [:item :idx | priorMorph := self indentingItemClass new initWithContents: item prior: priorMorph forList: self indentLevel: newIndent. firstAddition ifNil: [firstAddition := priorMorph]. morphList add: priorMorph. "Was this row expanded ? if true -> expand it again " ((item hasEquivalentIn: expandedItems) or: [priorMorph isExpanded]) ifTrue: [priorMorph isExpanded: true. priorMorph addChildrenForList: self addingTo: morphList withExpandedItems: expandedItems]]. ^ firstAddition! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 1/18/2010 17:31'! nodeList: aCollection nodeList := aCollection. ! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 21:34'! deselectAll self listManager deselectAll! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 21:32'! columnResizers "return the resizers which make it possible to resize columns horizontally with the mouse" ^ columnResizers ifNil: [ columnResizers := OrderedCollection new ]! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/18/2013 11:09'! update: aSymbol aSymbol = self nodeListSelector ifTrue: [ ^ self updateList ]. super update: aSymbol ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 2/3/2010 09:45'! lineColorBlock: aValuable lineColorBlock := aValuable ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/1/2011 12:49'! nodeListSelector ^ #rootNodes ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 22:04'! makeLastColumnUnbounded "Make the last column not horizontally resizable (no resizer for it)" unboundLastColumn := true ! ! !MorphTreeMorph methodsFor: 'column handling' stamp: 'AlainPlantec 2/12/2010 21:24'! addColumnResizers "add all needed column resizers" columnResizers := self columnResizerFrames withIndexCollect: [:frm :idx | (MorphTreeResizerMorph container: self index: idx) bounds: (frm translateBy: (scroller offset x negated @ 0))]. self addAllMorphs: columnResizers. self columnResizersToFront! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 2/1/2010 19:23'! buildTopHeader | subs | subs := OrderedCollection new. self columns do: [:col | col container: self. subs add: (col header hResizing: #rigid; layoutChanged; yourself)]. topHeader := Morph new fillStyle: self topHeaderBackground. self addMorph: topHeader. topHeader clipSubmorphs: true. topHeader borderColor: Color veryLightGray. topHeader color: Color transparent. topHeader borderWidth: 0. topHeader addAllMorphs: subs. topHeader bounds: (scroller left @ self top corner: scroller right @ (self top + self topHeaderHeight)). ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2009 10:54'! topHeaderBackground: aFillStyle topHeaderBackground := aFillStyle! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 16:18'! autoMultiSelection ^ self listManager autoMultiSelection! ! !MorphTreeMorph methodsFor: 'announce requests' stamp: 'AlainPlantec 10/18/2013 10:01'! selectItems: aNodeItemCollection self selectedItems: aNodeItemCollection ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/18/2013 09:46'! updateSelectionFromModel ^ self listManager updateSelectionFromModel! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 4/28/2011 22:32'! rowColorForOdd: oddColor rowColors at: 2 put: oddColor. ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 2/2/2010 22:24'! expandAllTo: aLevel self roots do: [:m | self expand: m to: aLevel]. self innerWidgetChanged! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/5/2010 23:04'! nodeMorphOfNode: aNode ^ self allNodeMorphs detect: [:m | m complexContents = aNode] ifNone: []! ! !MorphTreeMorph methodsFor: 'event handling' stamp: 'AlainPlantec 10/9/2011 15:07'! mouseOverAllowed ^ mouseOverAllowed ifNil: [mouseOverAllowed := false]! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/18/2013 10:07'! collapseNodePath: aPath self allNodeMorphs first collapseNodePath: aPath! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 2/3/2010 09:45'! lineColorBlock ^ lineColorBlock ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 10/29/2009 10:08'! preferedPaneColor ^ preferedPaneColor! ! !MorphTreeMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 2/17/2010 22:37'! on: anObject ^ self new model: anObject ! ! !MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 13:55'! addNodePath: aPath self selectedNodePathList add: aPath! ! !MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 07:27'! lastSelectedNodePath ^ self selectedNodePathList ifNotEmpty: [:l | l last]! ! !MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 23:01'! empty self selectedNodePathList: OrderedCollection new ! ! !MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 23:06'! removeNode: aNode self selectedNodePathList remove: aNode path ifAbsent: [] ! ! !MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 13:55'! selectedNodePathList ^ selectedNodePathList ifNil: [selectedNodePathList := OrderedCollection new]! ! !MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2009 22:05'! selectedNodePathList: aCollectionOfPath selectedNodePathList := aCollectionOfPath! ! !MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2009 18:15'! selectedNodeList ^ self selectedNodePathList ifNil: [#()] ifNotNil: [:l | l collect: [:path | path last]]! ! !MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2009 18:13'! selectedNodes ^ OrderedCollection withAll: self selectedNodeList ! ! !MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2009 18:13'! selectedItemOrItemsOrNil | theItems | theItems := self selectedNodeList collect: [ :each | each item ]. ^ theItems isEmpty ifTrue: [nil] ifFalse: [ theItems ]! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 22:29'! addNode: aNode self addNodePath: aNode path! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 13:53'! addNodePath: aPath ^ self subclassResponsibility ! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 07:26'! lastSelectedNodePath ^ self subclassResponsibility! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 1/11/2010 13:41'! lastSelectedNode ^ self lastSelectedNodePath ifNotNil: [:path | path ifEmpty: [nil] ifNotEmpty: [:p | path last]]! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 23:00'! empty self subclassResponsibility ! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 12/1/2009 06:36'! selectedNodePathList ^ self subclassResponsibility! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 23:04'! removeNode: aNode self subclassResponsibility ! ! !MorphTreeMorphSelection methodsFor: 'view updating' stamp: 'AlainPlantec 10/7/2011 17:02'! updateView: aTreeMorph forModel: aTreeModel aTreeMorph updateFromSelection: self. aTreeModel selectionChanged! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 13:28'! selectedNodes ^ self lastSelectedNode ifNotNil: [:l | OrderedCollection with: l] ifNil: [OrderedCollection new]! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 13:28'! selectedItems ^ self selectedNodes collect: [:n | n item] ! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2009 18:11'! selectedItemOrItemsOrNil ^ self lastSelectedNode isNil ifTrue: [ nil ] ifFalse: [ self lastSelectedNode item ]! ! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 13:54'! addNodePath: aPath self selectedNodePath: aPath! ! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 23:05'! removeNode: aNode self selectedNodePath = aNode path ifTrue: [self selectedNodePath: nil]! ! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 07:25'! lastSelectedNodePath ^ self selectedNodePath! ! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 23:00'! empty self selectedNodePath: nil! ! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 07:24'! selectedNodePath ^ selectedNodePath! ! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 12/1/2009 08:31'! selectedNodePathList ^ self selectedNodePath ifNil: [#()] ifNotNil: [Array with: self selectedNodePath]! ! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 07:11'! selectedNodePath: aSelectionPath selectedNodePath := aSelectionPath! ! !MorphTreeNavigationBar commentStamp: ''! I'm a pager control used to navigate in a MorphTreeMorph that has a lot of entries. You can see one of my subclass in action using: "May take a while to open" ClassListExample new open! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/21/2010 18:58'! asDisabledForm: aForm | disa | disa := aForm copy. (aForm colorsUsed reject: [:c | c = Color transparent]) do: [:c | disa replaceColor: c withColor: (c alphaMixed: 0.4 with: Color white)]. ^ disa ! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:45'! pageSize ^ pageSize! ! !MorphTreeNavigationBar methodsFor: 'private' stamp: 'AlainPlantec 1/22/2010 14:46'! handlesMouseDown: anEvent ^ true! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/22/2010 08:51'! buttonLabel: aLabel actionSelector: aSelector arguments: aCollection getEnabled: enableSelector help: helpText | b | b := (aLabel isString ifTrue: [self basicButton] ifFalse: [self basicIcon]) actionSelector: aSelector; arguments: aCollection; hResizing: #shrinkWrap; vResizing: #shrinkWrap; setBalloonText: helpText; yourself. aLabel isString ifTrue: [b label: aLabel font: self preferedFont] ifFalse: [| f | f := (enableSelector isNil or: [self perform: enableSelector]) ifTrue: [aLabel] ifFalse: [b lock. self asDisabledForm: aLabel]. b labelGraphic: f]. ^ b ! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:45'! pageSize: anInteger pageSize := anInteger! ! !MorphTreeNavigationBar methodsFor: 'initialization' stamp: 'AlainPlantec 1/22/2010 09:02'! initialize super initialize. self hResizing: #spaceFill; vResizing: #rigid; changeTableLayout; listDirection: #leftToRight; cellInset: 2 @ 0; layoutInset: 3 @ 0; listCentering: #center; clipSubmorphs: true; borderWidth: 0; borderColor: Color lightGray! ! !MorphTreeNavigationBar methodsFor: 'navigation' stamp: 'AlainPlantec 1/22/2010 15:11'! changePageSize: aNumberOrNil aNumberOrNil ifNotNil: [self updateForNewPageSize: aNumberOrNil] ifNil: [treeMorph removePager] ! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:44'! nodeList ^ treeMorph nodeList! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:46'! treeMorph: aTreeMorph treeMorph := aTreeMorph. ! ! !MorphTreeNavigationBar methodsFor: 'navigation' stamp: 'ThierryGoubier 2/8/2013 16:31'! pageOfNodeIndex: anIndex ^ (anIndex > 0 and: [anIndex <= self nodeList size]) ifTrue: [((anIndex - 1) // pageSize) + 1] ifFalse: [nil] ! ! !MorphTreeNavigationBar methodsFor: 'user interface' stamp: 'AlainPlantec 1/21/2010 11:45'! vScrollBarValue: scrollValue ! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:43'! basicButton | button | ^ (button := SimpleButtonMorph new) clipSubmorphs: true; color: self pagerColor; on: #mouseEnter send: #value to: [button borderColor: self pagerColor muchDarker]; on: #mouseLeave send: #value to: [button borderColor: self pagerColor]; target: self; layoutPolicy: TableLayout new; listDirection: #leftToRight; listCentering: #leftCenter; wrapCentering: #center; layoutInset: 2@0; cellInset: 2@0; borderWidth: 1; borderColor: self pagerColor; yourself ! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:45'! pagerColor ^ treeMorph pagerColor! ! !MorphTreeNavigationBar methodsFor: 'navigation' stamp: 'AlainPlantec 1/22/2010 10:27'! computedHeightFromContents | h | h := 0. self submorphsDo: [:sm | h := h max: sm height]. ^ h ! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/22/2010 08:52'! textEntryLabel: aLabel get: getSel set: setSel help: helpText class: aClass | pt | pt := PluggableTextFieldMorph new convertTo: aClass; alwaysAccept: true; on: self text: getSel accept: setSel readSelection: nil menu: nil; acceptOnCR: true; getEnabledSelector: nil; font: self preferedFont; cornerStyle: #square; hResizing: #spaceFill; vResizing: #rigid; borderStyle: (BorderStyle inset width: 1); color: Color white; hideScrollBarsIndefinitely; extent: 24@ (self preferedFont height + 4); setBalloonText: helpText. pt textMorph autoFit: true; wrapFlag: false; margins: (1@0 corner: 1@0). ^pt! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:46'! treeMorph: aTreeMorph pageSize: anInteger self treeMorph: aTreeMorph. self pageSize: anInteger! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/21/2010 11:48'! updateContents self bounds: self computedBounds. self color: treeMorph pagerColor. ! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:52'! buildPanel self subclassResponsibility! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 17:22'! pageSearchText: aString | founds chosen chosenNode | pageSearchText := aString. self changed: #pageSearchText. founds := OrderedCollection new. self nodeList doWithIndex: [:n :idx | (n includesSubstringAnywhere: pageSearchText) ifTrue: [founds add: idx -> n]]. founds ifEmpty: [ ^ self flash ]. founds size > 1 ifTrue: [ chosen := UIManager default chooseFrom: (founds collect: [:l | l value] ) values: (founds collect: [:l | l key] ) lines: nil title: ''. chosen ifNil: [^self]] ifFalse: [chosen := founds first key]. self currentPage: (self pageOfNodeIndex: chosen). chosenNode := self nodeList at: chosen. treeMorph scroller submorphsDo: [:sm | sm complexContents == chosenNode ifTrue: [treeMorph listManager setSelectedMorph: sm. ^ treeMorph scrollSelectionIntoView]] ! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:45'! pageSearchText ^ pageSearchText ifNil: [pageSearchText := '']! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:46'! pageSizeInput: aString | input | input := aString trimBoth. input ifEmpty: [input := '1']. (input beginsWith: '/' ) ifTrue: [ | numberOfPages | input := (input copyFrom: 2 to: input size) trimBoth. numberOfPages := Integer readFromString: input. numberOfPages > 0 ifTrue: [self changePageSize: (self nodeList size // numberOfPages)] ifFalse: [treeMorph flash. ^ false]] ifFalse: [ | newPageSize | newPageSize := Integer readFromString: input. newPageSize > 0 ifTrue: [self changePageSize: newPageSize] ifFalse: [treeMorph flash. ^ false]]. ^ true ! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/21/2010 11:52'! basicIcon | button | ^ (button := IconicButton new) clipSubmorphs: true; color: self pagerColor; on: #mouseEnter send: #value to: [button borderColor: self pagerColor muchDarker]; on: #mouseLeave send: #value to: [button borderColor: self pagerColor]; target: self; layoutPolicy: TableLayout new; listDirection: #leftToRight; listCentering: #leftCenter; wrapCentering: #center; layoutInset: 2@0; cellInset: 2@0; borderWidth: 1; borderColor: self pagerColor; yourself ! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/22/2010 08:49'! preferedFont ^ self balloonFont ! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/22/2010 09:07'! computedHeight ^ computedHeight ifNil: [computedHeight := self computedHeightFromContents + self layoutInset asPoint y + self cellInset asPoint y]! ! !MorphTreeNavigationBar methodsFor: 'private' stamp: 'AlainPlantec 1/22/2010 14:45'! mouseDown: anEvent! ! !MorphTreeNavigationBar methodsFor: 'navigation' stamp: 'AlainPlantec 1/21/2010 21:56'! updateForNewPageSize: aPageSize pageSize := aPageSize max: 1. self changed: #pageSize! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/22/2010 10:34'! spacer: hsize ^ (Morph new) color: Color transparent; extent: hsize @ (self hasSubmorphs ifTrue: [self computedHeight] ifFalse: [(self preferedFont height + 8)]); yourself! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:47'! withSearch ^ withSearch ifNil: [withSearch := false]! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:47'! withSearch: aBoolean withSearch := aBoolean. self buildPanel! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'MarcusDenker 9/13/2013 16:29'! computedBounds | tb tbw yGap | tb := treeMorph bounds. tbw := treeMorph borderWidth. yGap := self layoutInset asPoint y + self cellInset asPoint y. ^ (tb bottomLeft + (tbw @ (self computedHeight + yGap) negated)) corner: (tb bottomRight - ( (tbw * 2) @ yGap )). ! ! !MorphTreeNavigationBar class methodsFor: 'icons' stamp: 'AlainPlantec 1/20/2010 15:10'! smallToRightEndIcon ^ (Form extent: 16@16 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4287401100 4279173376 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4287401100 4279173376 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 0 0 0 0 4287401100 4279173376 0 0 0 0 0 0 0 4278190080 4287401100 4287401100 4278190080 0 0 0 4287401100 4279173376 0 0 0 0 0 0 4278190080 4287401100 4287401100 4287401100 4287401100 4278190080 0 50353408 4287401100 4279173376 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4291151301 4287401100 4287401100 4287401100 4287401100 4287401100 4278190080 0 4287401100 4279173376 4278190080 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4278190080 4287401100 4279173376 4278190080 4291151301 4291151301 4291151301 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4278190080 4287401100 4279173376 4278190080 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4278190080 4287401100 4279173376 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4291151301 4287401100 4287401100 4287401100 4287401100 4287401100 4278190080 0 4287401100 4279173376 0 0 0 0 0 0 4278190080 4287401100 4287401100 4287401100 4287401100 4278190080 0 0 4287401100 4279173376 0 0 0 0 0 0 0 4278190080 4287401100 4287401100 4278190080 0 0 0 4287401100 4279173376 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 0 0 0 0 4287401100 4279173376 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4287401100 4279173376 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4287401100 4279173376) offset: 0@0)! ! !MorphTreeNavigationBar class methodsFor: 'icons' stamp: 'AlainPlantec 1/20/2010 15:10'! smallToLeftIcon ^ (Form extent: 16@16 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 0 0 0 0 0 4278190080 4287401100 4287401100 4278190080 0 0 0 0 0 0 0 0 0 0 0 4278190080 4287401100 4287401100 4287401100 4287401100 4278190080 0 0 0 0 0 0 0 0 0 4278190080 4287401100 4287401100 4287401100 4287401100 4287401100 4291151301 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 4278190080 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4278190080 0 0 4278190080 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4291151301 4291151301 4291151301 4278190080 0 0 4278190080 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4278190080 0 0 0 4278190080 4287401100 4287401100 4287401100 4287401100 4287401100 4291151301 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 50353408 0 4278190080 4287401100 4287401100 4287401100 4287401100 4278190080 0 0 0 0 0 0 0 0 0 0 0 4278190080 4287401100 4287401100 4278190080 0 0 0 0 0 0 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0)! ! !MorphTreeNavigationBar class methodsFor: 'icons' stamp: 'AlainPlantec 1/20/2010 15:10'! smallDiezeIcon ^ (Form extent: 16@16 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4279173376 4279173376 0 0 4279173376 4279173376 0 0 0 0 0 0 0 0 0 0 4279173376 0 0 0 4279173376 0 0 0 0 0 0 0 0 0 0 0 4279173376 0 0 0 4279173376 0 0 0 0 0 0 0 0 0 0 0 4279173376 0 0 0 4279173376 0 0 0 0 0 0 0 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 0 0 0 0 0 0 0 0 4279173376 4279173376 4279173376 0 4279173376 4279173376 0 0 0 0 0 0 0 0 0 0 4279173376 0 0 0 4279173376 0 0 0 0 0 0 0 0 0 0 0 4279173376 0 0 0 4279173376 0 0 0 0 0 0 0 0 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 4279173376 0 0 0 0 0 0 0 4279173376 4279173376 4279173376 0 4279173376 4279173376 0 0 0 0 0 0 0 0 0 0 4279173376 4279173376 0 0 4279173376 4279173376 0 0 0 0 0 0 0 0 0 0 4279173376 0 0 0 4279173376 0 0 0 0 0 0 0 0 0 0 0 4279173376 0 0 0 4279173376 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0)! ! !MorphTreeNavigationBar class methodsFor: 'icons' stamp: 'AlainPlantec 1/20/2010 15:10'! smallVerticalResizingIcon ^ (Form extent: 16@16 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4283914071 0 0 0 0 4286545791 4286545791 4287401100 4287401100 4287401100 4287401100 0 0 0 0 4286545791 4290822336 4283914071 0 0 4286611584 4293256677 4293256677 4294967295 4294967295 4294967295 4294967295 4287401100 0 0 4286545791 4290822336 4290822336 4290822336 4283914071 0 4286611584 4293256677 4293256677 4294967295 4294967295 4294967295 4294967295 4287401100 0 4283914071 4283914071 4283914071 4283914071 4283914071 4283914071 4283914071 4286611584 4293256677 4293256677 4294967295 4294967295 4294967295 4294967295 4287401100 0 0 0 0 0 0 0 0 4286611584 4293256677 4293256677 4294967295 4294967295 4294967295 4294967295 4287401100 0 0 0 0 4278190080 0 0 0 4286611584 4293256677 4293256677 4294967295 4294967295 4294967295 4294967295 4287401100 0 0 0 0 4278190080 4293256677 0 0 4286611584 4293256677 4293256677 4294967295 4294967295 4294967295 4294967295 4287401100 0 0 0 0 4278190080 4293256677 0 0 4286611584 4293256677 4293256677 4294967295 4294967295 4294967295 4294967295 4287401100 0 0 0 0 4278190080 4293256677 0 0 4286611584 4293256677 4293256677 4294967295 4294967295 4294967295 4294967295 4287401100 0 0 0 0 4278190080 4293256677 0 0 4286611584 4293256677 4293256677 4294967295 4294967295 4294967295 4294967295 4287401100 0 4283914071 4283914071 4283914071 4283914071 4283914071 4283914071 4283914071 4286611584 4287401100 4287401100 4294967295 4294967295 4294967295 4294967295 4287401100 0 0 4286545791 4290822336 4290822336 4290822336 4283914071 0 0 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 0 0 0 0 4286545791 4290822336 4283914071 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4283914071 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0)! ! !MorphTreeNavigationBar class methodsFor: 'icons' stamp: 'AlainPlantec 1/20/2010 15:10'! smallToRightIcon ^ (Form extent: 16@16 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 0 0 0 0 0 0 4278190080 4287401100 4287401100 4278190080 0 0 0 0 0 0 0 0 0 0 0 4278190080 4287401100 4287401100 4287401100 4287401100 4278190080 0 50353408 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4291151301 4287401100 4287401100 4287401100 4287401100 4287401100 4278190080 0 0 0 4278190080 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4278190080 0 0 4278190080 4291151301 4291151301 4291151301 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4278190080 0 0 4278190080 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4278190080 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4291151301 4287401100 4287401100 4287401100 4287401100 4287401100 4278190080 0 0 0 0 0 0 0 0 0 4278190080 4287401100 4287401100 4287401100 4287401100 4278190080 0 0 0 0 0 0 0 0 0 0 0 4278190080 4287401100 4287401100 4278190080 0 0 0 0 0 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0)! ! !MorphTreeNavigationBar class methodsFor: 'icons' stamp: 'AlainPlantec 1/20/2010 15:05'! createIconMethods "self createIconMethods" #('smallToLeft' 'smallToRight' 'smallToLeftEnd' 'smallToRightEnd' 'smallDieze' 'smallVerticalResizing') do: [:n | | form | form := PNGReadWriter formFromFileNamed: n, '.png'. self class compile: (n, 'Icon', String cr, String tab, '^ ', form storeString) classified: #icons]! ! !MorphTreeNavigationBar class methodsFor: 'icons' stamp: 'AlainPlantec 1/20/2010 15:10'! smallToLeftEndIcon ^ (Form extent: 16@16 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4279173376 4287401100 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4279173376 4287401100 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4279173376 4287401100 0 0 0 0 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 4279173376 4287401100 0 0 0 4278190080 4287401100 4287401100 4278190080 0 0 0 0 0 0 0 4279173376 4287401100 0 0 4278190080 4287401100 4287401100 4287401100 4287401100 4278190080 0 0 0 0 0 0 4279173376 4287401100 0 4278190080 4287401100 4287401100 4287401100 4287401100 4287401100 4291151301 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4279173376 4287401100 4278190080 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4278190080 4279173376 4287401100 4278190080 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4291151301 4291151301 4291151301 4278190080 4279173376 4287401100 4278190080 4287401100 4287401100 4287401100 4287401100 4287401100 4287401100 4291151301 4291151301 4291151301 4291151301 4291151301 4291151301 4278190080 4279173376 4287401100 0 4278190080 4287401100 4287401100 4287401100 4287401100 4287401100 4291151301 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4279173376 4287401100 50353408 0 4278190080 4287401100 4287401100 4287401100 4287401100 4278190080 0 0 0 0 0 0 4279173376 4287401100 0 0 0 4278190080 4287401100 4287401100 4278190080 0 0 0 0 0 0 0 4279173376 4287401100 0 0 0 0 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 4279173376 4287401100 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4279173376 4287401100 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0)! ! !MorphTreeNavigationBar class methodsFor: 'instance creation' stamp: 'AlainPlantec 1/19/2010 18:47'! on: aTreeMorph pageSize: aPageSize ^ self new treeMorph: aTreeMorph pageSize: aPageSize! ! !MorphTreeNodeModel commentStamp: ''! I wrap an item to be displayed in a TreeMorph, so I can answer content and representation in a polymorphic way. My hierarchy usually follows TreeMorphModel one.! !MorphTreeNodeModel methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/22/2013 15:42'! hasContentToShow ^ false! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2009 11:12'! enabled ^ true! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 2/3/2010 09:52'! level ^ parentNode ifNil: [1] ifNotNil: [parentNode level + 1]! ! !MorphTreeNodeModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 13:33'! isExpanded: aBoolean! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 2/5/2010 23:00'! path ^ self pathIn: OrderedCollection new.! ! !MorphTreeNodeModel methodsFor: 'printing' stamp: 'AlainPlantec 10/8/2011 23:37'! printOn: aStream aStream nextPutAll: 'Node('. self item printOn: aStream. aStream nextPut: $)! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 2/8/2010 09:39'! childNodeClassFromItem: anItem ^ self class! ! !MorphTreeNodeModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 17:58'! lastClicked: aBoolean "Do nothing but introduce a hook"! ! !MorphTreeNodeModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 13:33'! isExpanded ^ false! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 2/5/2010 23:00'! pathIn: aCollection self parentNode ifNotNil: [(aCollection includes: self parentNode) ifFalse: [self parentNode pathIn: aCollection]]. aCollection add: self. ^ aCollection! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 2/8/2010 09:39'! childNodeFromItem: anItem ^ ((self childNodeClassFromItem: anItem) with: anItem model: model) parentNode: self; yourself! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 14:49'! parentNode: aNode parentNode := aNode! ! !MorphTreeNodeModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 17:42'! selected: aBoolean "Do nothing but introduce a hook"! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 1/18/2010 21:21'! includesSubstringAnywhere: aString ^ (Array with: self asString) includesSubstringAnywhere: aString! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 00:55'! rowMorphForColumn: aTreeColumn ^ self item ifNotNil: [:i | self asString asMorph] ! ! !MorphTreeNodeModel methodsFor: 'dependents' stamp: 'BenjaminVanRyseghem 11/22/2013 12:51'! addDependent: aDependent "Ensure to only have one dependent at every moment" dependents := #(). super addDependent: aDependent! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 1/15/2010 13:41'! parentNode ^ parentNode! ! !MorphTreeNodeModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 12:53'! selected ^ false! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 11/20/2009 21:25'! color ^ nil! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 15:43'! childrenItems ^ Array new! ! !MorphTreeNodeModel methodsFor: 'events' stamp: 'BenjaminVanRyseghem 7/2/2013 14:25'! mouseDown: event "Do not do anything"! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'GuillermoPolito 11/7/2013 15:55'! helpText ^ model helpText! ! !MorphTreeNodeModel methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/22/2013 14:59'! isPartialMatch | result | result := false. self contents do: [:each | (each selected or: [ each isPartialMatch ]) ifTrue: [ result := true ] ]. ^ result! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'CamilloBruni 2/19/2014 18:44'! name ^ self item name! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 15:26'! contents ^ self childrenItems collect: [:ci | self childNodeFromItem: ci ]! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 11/24/2009 14:07'! model: anObject model := anObject! ! !MorphTreeNodeMorph commentStamp: ''! I draw the node part of a tree.! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'AlainPlantec 9/30/2011 16:18'! hasIcon "Answer whether the receiver has an icon." ^ container hasIconBlock or: [self complexContents icon notNil]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/11/2011 15:45'! toggleImageForm ^ isExpanded ifTrue: [container expandedFormForMorph: self] ifFalse: [container notExpandedFormForMorph: self] ! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'AlainPlantec 9/28/2011 09:58'! isSelected "^ container selectedMorphList includes: self" ^ self selected! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 10/11/2013 16:07'! matchPath: anAssociation anAssociation ifNil: [ ^ nil ]. ^ anAssociation head = self complexContents withoutListWrapper ifFalse: [ nil ] ifTrue: [ | matchingChildren | anAssociation tail ifNil: [ ^ { self } ]. matchingChildren := self children collect: [:child | child matchPath: anAssociation tail ]. ^ matchingChildren select: [ :e | e notNil ] ]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! children | children | children := OrderedCollection new. self childrenDo: [:each | children add: each]. ^children! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 9/30/2011 14:33'! outerBounds "Return the 'outer' bounds of the receiver, e.g., the bounds that need to be invalidated when the receiver changes." ^ self bounds! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme "Answer the ui theme that provides controls. Done directly here to avoid performance hit of looking up in window." ^ Smalltalk ui theme! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/29/2009 16:44'! path ^ parent ifNil: [OrderedCollection with: self] ifNotNil: [(parent path) add: self; yourself]! ! !MorphTreeNodeMorph methodsFor: 'drawing' stamp: 'AlainPlantec 2/3/2010 10:05'! drawLinesToFirstChildOn: aCanvas "Draw line from me to first child. Don't bother if the first child has a toggle.." | vLineX vLineTop vLineBottom childBounds childCenter myTheme ldelta | self firstChild hasToggle ifTrue: [^self]. childBounds := self firstChild toggleRectangle. childCenter := childBounds center. vLineX := childCenter x. vLineTop := bounds bottom. ldelta := container treeLineWidth // 2. self firstChild hasToggle ifTrue: [vLineBottom := childCenter y - (childBounds height // 2) + ldelta] ifFalse: [vLineBottom := childCenter y - 2]. myTheme := self theme. aCanvas frameRectangle: (vLineX - ldelta @ vLineTop corner: (vLineX + ldelta + (container treeLineWidth \\ 2)) @ vLineBottom) width: container treeLineWidth colors: (myTheme treeLineColorsFrom: self lineColor) dashes: self treeLineDashes! ! !MorphTreeNodeMorph methodsFor: 'initialization' stamp: 'AlainPlantec 10/11/2011 00:01'! initialize "initialize the state of the receiver" super initialize. self layoutPolicy: TableLayout new; cellPositioning: #leftCenter; listDirection: #leftToRight; cellSpacing: #none; hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: Color transparent. ! ! !MorphTreeNodeMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/5/2013 12:43'! retrieveCheckIcon ^ self selected ifTrue: [ Smalltalk ui icons checkedBoxIcon ] ifFalse: [ self isPartialMatch ifTrue: [ Smalltalk ui icons partialCheckedBoxIcon ] ifFalse: [ Smalltalk ui icons uncheckedBoxIcon ] ]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 10/23/2009 15:35'! parent ^ parent! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 11/24/2013 13:39'! toggleExpandedState | toDelete | self isExpanded: self isExpanded not. toDelete := OrderedCollection new. firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: toDelete]. ]. container noteRemovalOfAll: toDelete. (isExpanded and: [complexContents hasContents]) ifFalse: [ ^self changed ]. self expand. ! ! !MorphTreeNodeMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 12/5/2013 12:44'! drawOn: aCanvas "Note that selection is rendered from the container transformMorph (see MorphTreeTransformMorph)" container withHLines ifTrue: [ aCanvas frameRectangle: self selectionFrame width: 1 colors: {Color veryLightGray. Color transparent} dashes: #(1 2)]. self hasToggle ifTrue: [self drawToggleOn: aCanvas in: self toggleRectangle]. container listManager isCheckList ifTrue: [self drawCheckOn: aCanvas ]. ! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 2/5/2010 22:50'! recursiveAddTo: aCollection firstChild ifNotNil: [firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: aCollection]]. aCollection add: self. ! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'AlainPlantec 10/7/2011 17:36'! mustTakeIntoAccountCheckSpace ^container listManager isCheckList! ! !MorphTreeNodeMorph methodsFor: 'change reporting' stamp: 'AlainPlantec 10/10/2011 23:43'! invalidRect: aRectangle ! ! !MorphTreeNodeMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/5/2013 12:44'! computeCheckTopLeft | center offset | center := self checkRectangle center. offset := (self checkWidth / 2.0) truncated. ^ (center x - offset) @ (center y - offset - 1)! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 9/28/2011 23:39'! checkWidth ^ 10! ! !MorphTreeNodeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/18/2013 10:04'! openNodePath: anArray | found | anArray isEmpty ifTrue: [^ container listManager setSelectedMorph: nil]. found := nil. self withSiblingsDo: [:each | found ifNil: [(each complexContents = anArray first or: [anArray first isNil]) ifTrue: [found := each]]]. found ifNotNil: [found isExpanded ifFalse: [found toggleExpandedState. container adjustSubmorphPositions]. found changed. anArray size = 1 ifTrue: [^ container setSelectedMorph: found]. ^ found firstChild ifNil: [container setSelectedMorph: nil] ifNotNil: [found firstChild openNodePath: anArray allButFirst]]. ^ container setSelectedMorph: nil! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'IgorStasenko 12/22/2012 03:02'! boundsForBalloon "some morphs have bounds that are way too big" container ifNil: [^super boundsForBalloon]. ^self boundsInWorld intersect: container boundsInWorld ifNone: [ self boundsInWorld ]! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'IgorStasenko 4/6/2011 16:59'! delete parent := nil. complexContents := nil. firstChild := nil. container := nil. nextSibling := nil. controls := nil. super delete. ! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'alain.plantec 3/7/2009 09:29'! isFirstItem ^owner submorphs first == self! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/22/2013 14:59'! isPartialMatch ^ self complexContents isPartialMatch! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/7/2011 21:52'! selectNodePath: anArray "select a node from a path based on wrapper node equivalence" | found | anArray isNil ifTrue: [^ self]. anArray isEmpty ifTrue: [^ self]. self withSiblingsDo: [:each | found ifNil: [(each complexContents = anArray first or: [anArray first isNil]) ifTrue: [found := each]]]. found ifNotNil: [ anArray size = 1 ifTrue: [^ container listManager addToSelection: found]. found firstChild ifNotNil: [:fc | fc selectNodePath: anArray allButFirst]]. ! ! !MorphTreeNodeMorph methodsFor: 'drawing' stamp: 'AlainPlantec 2/3/2010 07:28'! drawLinesOn: aCanvas | hasToggle | hasToggle := self hasToggle. "Draw line from toggle to text" self drawLineToggleToTextOn: aCanvas hasToggle: hasToggle. "Draw the line from my toggle to the nextSibling's toggle" self nextSibling ifNotNil: [ self drawLinesToNextSiblingOn: aCanvas hasToggle: hasToggle ]. "If I have children and am expanded, draw a line to my first child" (self firstChild notNil and: [ self isExpanded ]) ifTrue: [ self drawLinesToFirstChildOn: aCanvas]! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/7/2011 21:05'! updateChildrenRecursively self childrenDo: [:child | child parent: self. child updateChildrenRecursively] ! ! !MorphTreeNodeMorph methodsFor: 'layout' stamp: 'ThierryGoubier 10/21/2013 17:11'! layoutBounds "Return the bounds for laying out children of the receiver" | lb | lb := super layoutBounds. container ifNil: [ ^ lb ]. ^ (lb left: (lb left + self spacerWidth)) right: (lb right max: lb left + self spacerWidth) ! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/11/2011 01:04'! highlight self allMorphsDo: [:m | (m isKindOf: StringMorph) ifTrue: [m setProperty: #originalColor toValue: m color. m color: self theme currentSettings selectionTextColor]]. complexContents highlightingColor ifNotNil: [:c | self setProperty: #originalColor toValue: color. self color: c]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/10/2009 13:16'! indentGap ^ container indentGap * indentLevel! ! !MorphTreeNodeMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2013 10:07'! selectedWithoutNotifyingComplexContents: aBoolean "Only called at creation" aBoolean ifFalse: [ ^ self ]. container listManager silentlySetSelectedMorph: self. selected := aBoolean.! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2013 13:34'! isExpanded: aBoolean isExpanded := aBoolean. self complexContents isExpanded: aBoolean! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/3/2010 09:49'! lineColor "Answer a good color to use for drawing the lines that connect members of the hierarchy view. Used the cached color, or derive it if necessary by finding the receiver or the first owner (up to my root) that is not transparent, then picking a contrasting color. Fall back to black if all my owners are transparent." ^ lineColor ifNil: [lineColor := container lineColorForNode: self complexContents] ! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/10/2011 23:43'! changed "Need to invalidate the selection frame." container ifNil: [super changed] ifNotNil: [container invalidRect: self selectionFrame]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! lastChild "Answer the last child." |c| c := self firstChild ifNil: [^nil]. [c nextSibling isNil] whileFalse: [c := c nextSibling]. ^c! ! !MorphTreeNodeMorph methodsFor: 'printing' stamp: 'AlainPlantec 10/8/2011 23:37'! printOn: aStream aStream nextPutAll: 'NodeMorph('. complexContents printOn: aStream. aStream nextPut: $)! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'IgorStasenko 4/6/2011 17:10'! minWidth "Fixed to work such that guessed width is unnecessary in #adjustSubmorphPositions." | gap | gap := container ifNil: [ 0 ] ifNotNil: [ self indentGap ]. ^ gap max: super minWidth! ! !MorphTreeNodeMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 5/11/2013 23:04'! drawMouseDownHighlightOn: aCanvas "Draw with a dotted border." self highlightedForMouseDown ifTrue: [ container ifNil: [^super drawMouseDownHighlightOn: aCanvas]. aCanvas frameRectangle: self bounds width: 1 colors: {container mouseDownHighlightColor. Color transparent} dashes: #(1 1)]! ! !MorphTreeNodeMorph methodsFor: 'drag and drop' stamp: 'alain.plantec 3/7/2009 09:29'! acceptDroppingMorph: toDrop event: evt complexContents acceptDroppingObject: toDrop complexContents. toDrop delete. self highlightForDrop: false.! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 10:46'! toggleRectangle ^(bounds left + self indentGap) @ bounds top extent: (container toggleImageWidth) @ bounds height! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 10/11/2013 16:05'! expandPath: anAssociation anAssociation ifNil: [ ^ false ]. ^ anAssociation head = self complexContents withoutListWrapper ifFalse: [ false ] ifTrue: [ anAssociation tail ifNil: [ ^ true ]. (self isExpanded not and: [ self canExpand ]) ifTrue: [ self toggleExpandedState. container innerWidgetChanged ]. self children anySatisfy: [:child | child expandPath: anAssociation tail ]]! ! !MorphTreeNodeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/18/2013 09:31'! expandItemPath: anArray "Open a path." | found | anArray isEmpty ifTrue: [^ container listManager setSelectedMorph: nil]. found := nil. self withSiblingsDo: [:each | found ifNil: [(each complexContents withoutListWrapper = anArray first or: [anArray first isNil]) ifTrue: [found := each]]]. found ifNotNil: [found isExpanded ifFalse: [found toggleExpandedState]. found changed. anArray size = 1 ifTrue: [^ container listManager setSelectedMorph: found]. ^ found firstChild ifNil: [container setSelectedMorph: nil] ifNotNil: [found firstChild expandItemPath: anArray allButFirst]]. ^container setSelectedMorph: nil! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/8/2011 20:24'! closeItemPath: anArray "Close a path based on wrapper item equivalence." | found | anArray isEmpty ifTrue: [^ container listManager setSelectedMorph: nil]. found := nil. self withSiblingsDo: [:each | found ifNil: [(each complexContents withoutListWrapper = anArray first) ifTrue: [found := each]]]. found ifNotNil: [(found isExpanded and: [anArray size = 1]) ifTrue: [found toggleExpandedState. container adjustSubmorphPositions]. found changed. anArray size = 1 ifTrue: [^ container listManager setSelectedMorph: found]. ^ found firstChild ifNil: [container setSelectedMorph: nil] ifNotNil: [found firstChild closeItemPath: anArray allButFirst]]. ^container setSelectedMorph: nil! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'ThierryGoubier 10/21/2013 20:21'! spacerWidth "Such a morph composed of, left to right, some space according to the level in the tree, an expand toggle (if any), a check box (if any), and the item morphs (icon + text often). Compute here the width of the space, including the toggle (and the check box) if there is one." | baseRect | baseRect := self mustTakeIntoAccountCheckSpace ifTrue: [ self checkRectangle ] ifFalse: [ self toggleRectangle ]. ^ (self mustTakeIntoAccountToggleSpace or: [ self mustTakeIntoAccountCheckSpace ]) ifTrue: [ baseRect right + container gapAfterToggle - bounds left ] ifFalse: [ baseRect left - bounds left ]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 9/28/2011 23:37'! checkGap ^ 2! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'ThierryGoubier 10/7/2012 22:48'! selectionFrame "Answer the selection frame rectangle." ^ self bounds: self bounds in: container! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 9/28/2011 23:36'! checkRectangle | tr | tr := self toggleRectangle translateBy: (3 @ 0). ^ self mustTakeIntoAccountToggleSpace ifTrue: [(tr topRight + (self checkGap @ 0)) corner: tr bottomRight + ((self checkGap + self checkWidth) @ 0)] ifFalse: [tr] ! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2009 06:42'! rowMorphAt: anIndex ^ self submorphs seconds submorphs at: anIndex! ! !MorphTreeNodeMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 11/18/2013 10:39'! model ^ self complexContents! ! !MorphTreeNodeMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 11/18/2013 10:42'! isMorphicModel ^ true! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/5/2010 09:16'! color ^ complexContents color ifNil: [self index ifNotNil: [container rowColors at: ((self index \\ 2) + 1)]]! ! !MorphTreeNodeMorph methodsFor: 'mouse events' stamp: 'AlainPlantec 10/16/2013 13:00'! mouseDown: event container enabled ifFalse: [ ^self ]. complexContents mouseDown: event! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'ThierryGoubier 2/8/2013 16:28'! openItemPath: anArray "Open a path based on wrapper item equivalence. Generally more specific than #openPath: (string based)." | found | anArray isEmpty ifTrue: [^ container listManager setSelectedMorph: nil]. found := nil. self withSiblingsDo: [:each | found ifNil: [(each complexContents withoutListWrapper = anArray first or: [anArray first isNil]) ifTrue: [found := each]]]. found ifNotNil: [found isExpanded ifFalse: [found toggleExpandedState]. found changed. anArray size = 1 ifTrue: [^ container listManager setSelectedMorph: found]. ^ found firstChild ifNil: [container setSelectedMorph: nil] ifNotNil: [found firstChild openItemPath: anArray allButFirst]]. ^self! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/10/2011 23:53'! expand | c newChildren | isExpanded := true. (c := complexContents contents) isEmpty ifTrue: [^self changed]. newChildren := container addMorphsAfter: self fromCollection: c. firstChild := newChildren first. self updateChildren ! ! !MorphTreeNodeMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 12/5/2013 14:24'! drawCheckOn: aCanvas | topLeft icon | topLeft := self computeCheckTopLeft. icon := self retrieveCheckIcon. aCanvas drawImage: icon at: topLeft! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/22/2013 15:42'! hasContentToShow ^ self complexContents hasContentToShow! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 11/15/2009 17:18'! themeChanged! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 10/23/2009 15:36'! parent: aNodeMorph parent := aNodeMorph! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/11/2011 01:12'! withSiblingsDo: aBlock | node | node := self. [node isNil] whileFalse: [ aBlock value: node. node := node nextSibling].! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! withoutListWrapper ^complexContents withoutListWrapper! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! indentLevel ^indentLevel! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'alain.plantec 3/7/2009 09:29'! childrenDo: aBlock firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aBlock value: aNode]. ]! ! !MorphTreeNodeMorph methodsFor: 'initialization' stamp: 'AlainPlantec 10/11/2011 00:03'! initRow self buildRowMorph. self layoutChanged ! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'alain.plantec 3/7/2009 09:29'! isExpanded ^isExpanded! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 9/27/2011 00:38'! highlightForMouseDown: aBoolean aBoolean ifTrue: [self setProperty: #highlightedForMouseDown toValue: aBoolean] ifFalse: [self removeProperty: #highlightedForMouseDown]. self changed! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/22/2013 11:08'! selected: aBoolean selected = aBoolean ifTrue: [^ self]. aBoolean ifTrue: [container selectedMorphList add: self] ifFalse: [selected ifNotNil: [container selectedMorphList remove: self]]. selected := aBoolean. self complexContents selected: aBoolean! ! !MorphTreeNodeMorph methodsFor: 'drawing' stamp: 'AlainPlantec 2/11/2011 15:46'! drawToggleOn: aCanvas in: aRectangle | aForm centeringOffset | aForm := self toggleImageForm. centeringOffset := ((aRectangle height - aForm extent y) / 2.0) truncated. ^aCanvas translucentImage: aForm at: (aRectangle topLeft translateBy: 0 @ centeringOffset). ! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'alain.plantec 3/7/2009 09:29'! canExpand ^complexContents hasContents! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! balloonText ^complexContents balloonText ifNil: [super balloonText]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/20/2009 17:19'! index: anInteger index := anInteger! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/11/2011 01:08'! updateColumnMorphsWidthWith: aListOfWidths | sw | (container columns isEmpty or: [self hasSubmorphs not]) ifTrue: [^ self]. sw := self spacerWidth. 1 to: aListOfWidths size - 1 do: [:idx | | w | w := aListOfWidths at: idx. (controls at: idx) width: (w - (idx = 1 ifTrue: [sw] ifFalse: [0]))]. ! ! !MorphTreeNodeMorph methodsFor: 'layout' stamp: 'AlainPlantec 10/9/2011 18:38'! fullBounds fullBounds ifNotNil: [^ fullBounds]. ^ submorphs ifEmpty: [bounds] ifNotEmpty: [ self doLayoutIn: self layoutBounds. fullBounds]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2013 12:42'! setSelectedSilently: aBoolean selected := aBoolean. self complexContents selected: aBoolean! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/7/2011 17:23'! openPath: anArray | found | anArray isEmpty ifTrue: [^ container listManager setSelectedMorph: nil]. found := nil. self withSiblingsDo: [:each | found ifNil: [(each complexContents asString = anArray first or: [anArray first isNil]) ifTrue: [found := each]]]. found ifNil: ["try again with no case sensitivity" self withSiblingsDo: [:each | found ifNil: [(each complexContents asString sameAs: anArray first) ifTrue: [found := each]]]]. found ifNotNil: [found isExpanded ifFalse: [found toggleExpandedState. container adjustSubmorphPositions]. found changed. anArray size = 1 ifTrue: [^ container setSelectedMorph: found]. ^ found firstChild ifNil: [container setSelectedMorph: nil] ifNotNil: [found firstChild openPath: anArray allButFirst]]. ^ container setSelectedMorph: nil! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'IgorStasenko 4/6/2011 16:48'! icon "answer the receiver's icon" ^ container iconBlock value: self complexContents. ! ! !MorphTreeNodeMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/27/2013 00:05'! initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel container := hostList. self cellInset: (container resizerWidth @ 0). complexContents := anObject. anObject addDependent: self. isExpanded := anObject isExpanded. nextSibling := firstChild := nil. priorMorph ifNotNil: [priorMorph nextSibling: self]. indentLevel := newLevel. self setBalloonText: anObject helpText. self initRow. anObject selected ifTrue: [ self selectedWithoutNotifyingComplexContents: true ]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 12/2/2009 17:27'! columnMorphAt: anIndex ^ controls at: anIndex ! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'AlainPlantec 10/28/2009 22:57'! mustTakeIntoAccountToggleSpace ^ indentLevel > 0 or: [ container hasToggleAtRoot]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! nextSibling: anotherMorph nextSibling := anotherMorph! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/3/2010 10:05'! treeLineDashes ^ container treeLineDashes! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2009 19:36'! controls ^ controls! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 11/15/2009 17:18'! adoptPaneColor: aColor! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'alain.plantec 10/23/2009 12:15'! hasToggle ^ self canExpand! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! nextSibling ^nextSibling! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'AlainPlantec 10/10/2011 09:12'! inToggleArea: aPoint ^self sensitiveToggleRectangle containsPoint: aPoint! ! !MorphTreeNodeMorph methodsFor: 'mouse events' stamp: 'AlainPlantec 10/16/2013 13:00'! handleMouseUp: anEvent container enabled ifFalse: [ ^ false ]. (container commandOrCrontrolKeyPressed: anEvent) ifTrue: [^ container listManager mouseUp: anEvent on: self]. ^ super handleMouseUp: anEvent! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/8/2011 17:42'! addChildrenForList: hostList addingTo: morphList withExpandedItems: expandedItems firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aNode delete]. firstChild := nil]. complexContents hasContents ifFalse: [^self]. firstChild := hostList addMorphsTo: morphList from: complexContents contents withExpandedItems: expandedItems atLevel: indentLevel + 1. ! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/5/2010 21:58'! index ^ index ! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 09:12'! sensitiveToggleRectangle ^(bounds left + self indentGap) @ bounds top extent: (container toggleImageWidth + container gapAfterToggle) @ bounds height! ! !MorphTreeNodeMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2013 16:31'! takeHighlight container listManager lastClickedMorph: self. container selectionChanged! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 11/25/2013 16:30'! update: aSymbol aSymbol = #select ifTrue: [ ^ self selected: true ]. aSymbol = #deselect ifTrue: [ ^ self selected: false ]. aSymbol = #takeHighlight ifTrue: [ ^ self takeHighlight ]. super update: aSymbol! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'alain.plantec 3/7/2009 09:29'! isSoleItem ^self isFirstItem and: [ owner submorphs size = 1 ]! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/31/2009 08:51'! updateChildren self childrenDo: [:child | child parent: self] ! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'alain.plantec 3/7/2009 09:29'! recursiveDelete firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aNode recursiveDelete]. ]. self delete ! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! complexContents ^complexContents! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 9/28/2011 09:44'! selected ^ selected ifNil: [selected := false]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! firstChild ^firstChild! ! !MorphTreeNodeMorph methodsFor: 'initialization' stamp: 'AlainPlantec 10/11/2011 00:01'! buildRowMorph | rowControls colAndControls | controls := OrderedCollection new. colAndControls := container columns collect: [:col | | v | v := col rowMorphFor: complexContents. controls add: v. col -> v]. rowControls := OrderedCollection new. colAndControls do: [:ctrl | | col morph | col := ctrl key. morph := ctrl value. morph clipSubmorphs: true. morph vResizing: #shrinkWrap. rowControls add: morph. (morph = controls last and: [container lastColumnUnbounded]) ifFalse: [morph hResizing: #rigid]. (col resizable not and: [col shrinkWrap]) ifTrue: [col currentWidth < morph width ifTrue: [col forceWidthTo: morph width]]]. self addAllMorphs: rowControls. self layoutChanged ! ! !MorphTreeNodeMorph methodsFor: 'drawing' stamp: 'AlainPlantec 2/3/2010 10:27'! drawLineToggleToTextOn: aCanvas hasToggle: hasToggle "If I am not the only item in my container, draw the line between: - my toggle (if any) or my left edge (if no toggle) - and my text left edge. Only draw now if no toggle." | myBounds myCenter hLineY hLineLeft myTheme ldelta | self isSoleItem ifTrue: [ ^self ]. self hasToggle ifTrue: [^self]. myBounds := self toggleRectangle. myCenter := myBounds center. hLineY := myCenter y - 1. ldelta := container treeLineWidth // 2. hLineLeft := myCenter x - ldelta. "Draw line from toggle to text. Use optimised form since vertical." myTheme := self theme. aCanvas frameRectangle: (hLineLeft @ (hLineY ) corner: myBounds right + 3 + ldelta @ (hLineY + container treeLineWidth )) width: container treeLineWidth colors: (myTheme treeLineColorsFrom: (self parent ifNil: [self lineColor] ifNotNil: [self parent lineColor])) dashes: self treeLineDashes! ! !MorphTreeNodeMorph methodsFor: 'drawing' stamp: 'AlainPlantec 2/3/2010 11:41'! drawLinesToNextSiblingOn: aCanvas hasToggle: hasToggle "Draw line from me to next sibling" | myBounds nextSibBounds vLineX myCenter vLineTop vLineBottom myTheme ldelta gap | myBounds := self toggleRectangle. nextSibBounds := self nextSibling toggleRectangle. myCenter := myBounds center. vLineX := myCenter x. gap := (container notExpandedForm extent y // 2) + 1. vLineTop := myCenter y + (self hasToggle ifTrue: [gap] ifFalse: [0]). vLineBottom := nextSibBounds center y - (self nextSibling hasToggle ifTrue: [gap] ifFalse: [0]). "Draw line from me to next sibling" myTheme := self theme. ldelta := container treeLineWidth // 2. aCanvas frameRectangle: (vLineX - ldelta @ vLineTop corner: vLineX + ldelta + (container treeLineWidth \\ 2) @ vLineBottom) width: container treeLineWidth colors: (myTheme treeLineColorsFrom: self lineColor) dashes: self treeLineDashes! ! !MorphTreeNodeMorph methodsFor: 'mouse events' stamp: 'BenjaminVanRyseghem 12/5/2013 13:50'! checkClickableZone | topLeft icon | topLeft := self computeCheckTopLeft. icon := self retrieveCheckIcon. ^ topLeft corner: icon extent + topLeft! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/11/2011 01:04'! unhighlight complexContents highlightingColor ifNotNil: [ (self valueOfProperty: #originalColor ifAbsent: [Color black]) ifNotNil: [:c | self color: c]]. self allMorphsDo: [:m | (m isKindOf: StringMorph) ifTrue: [m color: (m valueOfProperty: #originalColor ifAbsent: [Color black])]]. ! ! !MorphTreeNodeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/18/2013 10:08'! collapseNodePath: anArray "Close a path based on node." | found | anArray isEmpty ifTrue: [^ container setSelectedMorph: nil]. found := nil. self withSiblingsDo: [:each | found ifNil: [(each complexContents = anArray first) ifTrue: [found := each]]]. found ifNotNil: [(found isExpanded and: [anArray size = 1]) ifTrue: [found toggleExpandedState. container adjustSubmorphPositions]. found changed. anArray size = 1 ifTrue: [^ container listManager setSelectedMorph: found]. ^ found firstChild ifNil: [container setSelectedMorph: nil] ifNotNil: [found firstChild collapseNodePath: anArray allButFirst]]. ^container setSelectedMorph: nil! ! !MorphTreePager methodsFor: 'accessing' stamp: 'AlainPlantec 1/21/2010 21:57'! setPageInterval: anInterval currentPageFirstIndex := anInterval first. self showCurrentPage. self changed: #currentPage! ! !MorphTreePager methodsFor: 'accessing' stamp: 'AlainPlantec 1/21/2010 21:20'! choosePage | choiceList chosen | choiceList := OrderedCollection new. self allIntervals doWithIndex: [:assoc :idx | | choiceString | choiceString := idx asString, ': ', (self nodeList at: assoc key) asString, ' ... ', (self nodeList at: assoc value) asString. choiceList add: idx -> choiceString]. chosen := UIManager default chooseFrom: (choiceList collect: [:c | c value]) values: (choiceList collect: [:c | c key]) lines: nil title: 'Choose a page'. chosen ifNil: [^self]. self currentPage: chosen.! ! !MorphTreePager methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 09:11'! currentPageFirstIndex ^ currentPageFirstIndex ifNil: [currentPageFirstIndex := 1]! ! !MorphTreePager methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 09:13'! nextPage self currentPageLastIndex < self nodeList size ifTrue: [currentPageFirstIndex := (currentPageFirstIndex + pageSize) min: self nodeList size. self showCurrentPage]! ! !MorphTreePager methodsFor: 'accessing' stamp: 'AlainPlantec 1/21/2010 22:09'! showCurrentPage self buildPanel. treeMorph scroller removeAllMorphs. (self nodeList isNil or: [self nodeList isEmpty]) ifTrue: [^ treeMorph emptySelection]. treeMorph addSubmorphsFromNodeList. treeMorph updateColumnMorphs. treeMorph scrollSelectionIntoView ! ! !MorphTreePager methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 09:11'! currentPage ^ self currentPageLastIndex \\ pageSize > 0 ifTrue: [(self currentPageLastIndex / pageSize) asInteger + 1] ifFalse: [(self currentPageLastIndex / pageSize) asInteger]! ! !MorphTreePager methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 09:15'! previousPage self currentPageFirstIndex > 1 ifTrue: [currentPageFirstIndex := (currentPageFirstIndex - pageSize) max: 1. self showCurrentPage]! ! !MorphTreePager methodsFor: 'navigation' stamp: 'AlainPlantec 1/22/2010 17:51'! buildPanel | widgets firstPageButton previousButton wid nextButton lastPageButton pageSizeEditor searchEditor | self removeAllMorphs. pageSize ifNil: [^ self]. self nodeList ifNil: [^ self]. widgets := OrderedCollection new. (self nodeList size > pageSize) ifTrue: [firstPageButton := self buttonLabel: self class smallToLeftEndIcon actionSelector: #currentPage: arguments: {1} getEnabled: #notOnFirstPage help: 'First page'. widgets add: firstPageButton. previousButton := self buttonLabel: self class smallToLeftIcon actionSelector: #previousPage arguments: {} getEnabled: #notOnFirstPage help: 'Previous page'. widgets add: previousButton. wid := self textEntryLabel: '' get: #currentPage set: #currentPage: help: 'Index of page to view' translated class: Integer. wid hResizing: #rigid. wid width: (self preferedFont widthOfString: '1000'). widgets add: wid. widgets add: (self buttonLabel: self class smallDiezeIcon actionSelector: #choosePage arguments: {} getEnabled: nil help: 'Choose page'). nextButton := self buttonLabel: self class smallToRightIcon actionSelector: #nextPage arguments: {} getEnabled: #notOnLastPage help: 'Next page'. widgets add: nextButton. lastPageButton := self buttonLabel: self class smallToRightEndIcon actionSelector: #currentPage: arguments: {self lastPage} getEnabled: #notOnLastPage help: 'Last page'. widgets add: lastPageButton. widgets add: (self spacer: 10)]. widgets add: (LabelMorph contents: 'Page size: ' font: self preferedFont). pageSizeEditor := self textEntryLabel: 'Page size' get: #pageSize set: #pageSizeInput: help: 'Change the page size or the number of pages if the input begins with "/"' translated class: String. pageSizeEditor hResizing: #rigid. pageSizeEditor width: (self preferedFont widthOfString: '10000'). widgets add: pageSizeEditor. self withSearch ifTrue: [searchEditor := self textEntryLabel: '' get: #pageSearchText set: #pageSearchText: help: 'Enter a text correspondig to your search' translated class: String. searchEditor ghostText: 'Searched text'. widgets add: searchEditor]. self addAllMorphs: widgets. self updateContents! ! !MorphTreePager methodsFor: 'testing' stamp: 'AlainPlantec 1/19/2010 09:13'! notOnLastPage ^ self onLastPage not! ! !MorphTreePager methodsFor: 'accessing' stamp: 'ThierryGoubier 2/8/2013 16:24'! nextPage: theIndexOfAnElement "To make sure we can go to the page of an element." self currentPage: (self pageOfNodeIndex: theIndexOfAnElement)! ! !MorphTreePager methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 09:11'! currentPage: anIndex anIndex = self currentPage ifTrue: [^ self]. anIndex = 1 ifTrue: [self setPageInterval: (1 to: (pageSize min: self nodeList size))] ifFalse: [ | lastIdx | lastIdx := (anIndex * pageSize). lastIdx <= self nodeList size ifTrue: [self setPageInterval: (((lastIdx - pageSize + 1) max: 1) to: (lastIdx))] ifFalse: [self setPageInterval: ((((self lastPage - 1) * pageSize) + 1) to: self nodeList size)]] ! ! !MorphTreePager methodsFor: 'accessing' stamp: 'AlainPlantec 1/20/2010 15:36'! allIntervals | intervals | intervals := OrderedCollection new. 1 to: self lastPage do: [:p | | start | intervals add: ((start := (((p - 1) * self pageSize) + 1)) -> (start + pageSize - 1))]. intervals last value: self nodeList size. ^ intervals! ! !MorphTreePager methodsFor: 'private' stamp: 'AlainPlantec 1/19/2010 10:37'! currentNodelist ^ self nodeList copyFrom: self currentPageFirstIndex to: self currentPageLastIndex! ! !MorphTreePager methodsFor: 'user interface' stamp: 'AlainPlantec 1/22/2010 15:12'! updateForNewPageSize: newPageSize pageSize ~= newPageSize ifTrue: [ | oldLast | oldLast := self currentPageLastIndex. pageSize := newPageSize max: 1. currentPageFirstIndex := (oldLast + 1 - pageSize) max: 1. self nodeList ifNotNil: [self showCurrentPage]] ! ! !MorphTreePager methodsFor: 'testing' stamp: 'AlainPlantec 1/19/2010 09:14'! onLastPage ^ self currentPageLastIndex = self nodeList size! ! !MorphTreePager methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 09:11'! currentPageLastIndex ^ pageSize ifNil: [self nodeList size] ifNotNil: [(self currentPageFirstIndex + pageSize - 1) min: self nodeList size]! ! !MorphTreePager methodsFor: 'testing' stamp: 'AlainPlantec 1/19/2010 09:12'! hasSeveralPages ^ self lastPage > 1! ! !MorphTreePager methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 09:12'! lastPage | p | p := (self nodeList size / pageSize) asInteger. self nodeList size \\ pageSize > 0 ifTrue: [p := p + 1]. ^ p. ! ! !MorphTreePager methodsFor: 'testing' stamp: 'AlainPlantec 1/19/2010 09:14'! onFirstPage ^ self currentPageFirstIndex = 1! ! !MorphTreePager methodsFor: 'testing' stamp: 'AlainPlantec 1/19/2010 09:13'! notOnFirstPage ^ self onFirstPage not ! ! !MorphTreeResizerMorph methodsFor: 'Polymorph-Widgets' stamp: 'AlainPlantec 11/17/2009 16:47'! themeChanged "Update the fill style." self fillStyle: self normalFillStyle. super themeChanged! ! !MorphTreeResizerMorph methodsFor: 'drawing' stamp: 'AlainPlantec 11/17/2009 17:18'! drawOn: aCanvas (owner notNil and: [owner containsPoint: self position]) ifTrue: [super drawOn: aCanvas] ! ! !MorphTreeResizerMorph methodsFor: 'Polymorph-Widgets' stamp: 'AlainPlantec 11/18/2009 10:01'! mouseUp: anEvent "Change the cursor back to normal if necessary and change the color back to normal." self canResizeColumn ifFalse: [^ self]. (self bounds containsPoint: anEvent cursorPoint) ifFalse: [anEvent hand showTemporaryCursor: nil]. self class fastSplitterResize ifTrue: [self updateFromEvent: anEvent]. traceMorph ifNotNil: [traceMorph delete. traceMorph := nil]. self adoptPaneColor: self paneColor. self triggerEvent: #mouseUp! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'alain.plantec 3/10/2009 14:09'! normalizedY: y ^y! ! !MorphTreeResizerMorph methodsFor: 'Polymorph-Widgets' stamp: 'alain.plantec 3/9/2009 12:55'! shouldDraw ^ true! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'alain.plantec 3/11/2009 07:45'! splitsTopAndBottom ^ false! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'alain.plantec 3/10/2009 14:09'! normalizedX: x ^ x! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'alain.plantec 3/9/2009 12:53'! resizeCursor ^ Cursor resizeForEdge: #left! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 11/17/2009 16:35'! updateFromEvent: anEvent "Update the splitter and attached morph positions from the mouse event. Take into account the mouse down offset." | pNew previousX newWidth minX newLeft | pNew := anEvent cursorPoint - lastMouse second. minX := index = 1 ifTrue: [container minResizerX] ifFalse: [(container columnResizers at: index - 1) right + container minResizerOffset]. newLeft := minX max: pNew x. index = 1 ifTrue: [newLeft := newLeft + 3]. self left: newLeft. previousX := index = 1 ifTrue: [container scroller left - container scroller offset x + 3] ifFalse: [(container columnResizers at: index - 1) left]. newWidth := self left - previousX. (container columns at: index) currentWidth: newWidth. container resizerChanged! ! !MorphTreeResizerMorph methodsFor: 'Polymorph-Widgets' stamp: 'AlainPlantec 11/17/2009 16:53'! adoptPaneColor: paneColor "Change our color too." super adoptPaneColor: paneColor. self fillStyle: self normalFillStyle! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 11/27/2009 22:49'! canResizeColumn ^(container columns at: index) resizable ! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 11/8/2009 12:32'! container: aTreeMorph index: anInteger container := aTreeMorph. index := anInteger! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/11/2011 22:29'! normalFillStyle "Return the normal fillstyle for the receiver." ^ self theme morphTreeSplitterNormalFillStyleFor: self! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/11/2011 22:31'! pressedFillStyle "Return the pressed fillStyle of the receiver." ^ self theme morphTreeSplitterPressedFillStyleFor: self! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 11/17/2009 16:57'! getOldColor ^ oldColor ifNil: [Color transparent]! ! !MorphTreeResizerMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/18/2009 10:01'! mouseEnter: anEvent self canResizeColumn ifFalse: [^ self]. (owner notNil and: [owner bounds containsPoint: anEvent position]) ifTrue: [super mouseEnter: anEvent]! ! !MorphTreeResizerMorph methodsFor: 'dependents access' stamp: 'AlainPlantec 11/3/2009 22:25'! delete super delete. self release. ! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'alain.plantec 3/9/2009 13:09'! setGrabbedColor "Set the color of the receiver when it is grabbed." self fillStyle: self pressedFillStyle! ! !MorphTreeResizerMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/18/2009 10:01'! mouseDown: anEvent "A mouse button has been pressed. Update the color for feedback and store the mouse position and relative offset to the receiver." | cp | self canResizeColumn ifFalse: [^ self]. (self bounds containsPoint: anEvent cursorPoint) ifTrue: [oldColor := self color. self setGrabbedColor]. cp := anEvent cursorPoint. lastMouse := {cp. cp - self position}! ! !MorphTreeResizerMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/18/2009 10:02'! mouseLeave: anEvent self canResizeColumn ifFalse: [^ self]. super mouseLeave: anEvent! ! !MorphTreeResizerMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/18/2009 10:01'! mouseMove: anEvent self canResizeColumn ifFalse: [^ self]. anEvent hand temporaryCursor ifNil: [^ self]. self class fastSplitterResize ifTrue: [traceMorph ifNil: [traceMorph := Morph newBounds: self bounds. traceMorph borderColor: Color lightGray. traceMorph borderWidth: 1. self owner addMorph: traceMorph]. traceMorph position: (anEvent cursorPoint x - lastMouse second x) @ traceMorph position y] ifFalse: [self updateFromEvent: anEvent]! ! !MorphTreeResizerMorph methodsFor: 'submorphs-add/remove' stamp: 'AlainPlantec 11/3/2009 22:26'! release traceMorph := nil. oldColor := nil. container := nil. super release. ! ! !MorphTreeResizerMorph class methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 11/8/2009 12:31'! container: aTreeList index: anInteger ^ self new container: aTreeList index: anInteger! ! !MorphTreeResizerMorph class methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 11/12/2009 19:58'! fastSplitterResize ^ true! ! !MorphTreeSelectionChanged methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:47'! selection ^ selection! ! !MorphTreeSelectionChanged methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:47'! selection: aSelection selection := aSelection! ! !MorphTreeTransformMorph methodsFor: 'drawing' stamp: 'AlainPlantec 10/16/2013 13:57'! drawSubmorphsOn: aCanvas submorphs ifEmpty: [^ self]. aCanvas transformBy: transform clippingTo: (aCanvas clipRect intersect: (owner clippingBounds) ifNone: ["we're done here" ^ self ]) during: [:myCanvas | | top bottom | top := self topVisibleRowForCanvas: myCanvas. bottom := self bottomVisibleRowForCanvas: myCanvas startingAt: top. bottom to: top by: -1 do: [:row | | m | m := submorphs basicAt: row. self drawRawColorOn: myCanvas forSubmorph: m. myCanvas fullDrawMorph: m] ] smoothing: smoothing. owner withTreeLines ifTrue: [owner drawLinesOn: aCanvas]. owner enabled ifFalse: [ aCanvas fillRectangle: owner innerBounds fillStyle: (owner paneColor alpha: 0.2) ] ! ! !MorphTreeTransformMorph methodsFor: 'change reporting' stamp: 'AlainPlantec 2/17/2010 16:02'! privateInvalidateMorph: aMorph ! ! !MorphTreeTransformMorph methodsFor: 'submorphs-add/remove' stamp: 'AlainPlantec 10/3/2011 01:28'! addAllMorphs: aCollection after: anotherMorph ^self privateAddAllMorphs: aCollection atIndex: (anotherMorph index ifNil: [submorphs size])! ! !MorphTreeTransformMorph methodsFor: 'private' stamp: 'AlainPlantec 10/11/2011 00:10'! privateAddAllMorphs: aCollection atIndex: index "Private. Add aCollection of morphs to the receiver" submorphs := Array new: submorphs size + aCollection size streamContents: [:str | 1 to: index do: [:p | str nextPut: (submorphs atWrap: p)]. str nextPutAll: aCollection. index + 1 to: submorphs size do: [:p | str nextPut: (submorphs atWrap: p)]]. aCollection do: [:m | m fullBounds. m privateOwner: self]. self layoutChanged. ! ! !MorphTreeTransformMorph methodsFor: 'drawing' stamp: 'AlainPlantec 10/10/2011 23:05'! rowAtLocation: aPoint startingAt: aPosition "return the number of the row at aPoint" | y | y := aPoint y. submorphs ifEmpty: [^ nil]. aPosition to: submorphs size do: [ :idx | | m | m := submorphs basicAt: idx. m topLeft y >= y ifTrue: [^ (idx - 1) max: 1]]. ^ submorphs size! ! !MorphTreeTransformMorph methodsFor: 'initialization' stamp: 'AlainPlantec 10/11/2011 00:07'! initialize super initialize. self smoothingOn! ! !MorphTreeTransformMorph methodsFor: 'drawing' stamp: 'AlainPlantec 10/9/2011 15:51'! topVisibleRowForCanvas: aCanvas startingAt: aPos "return the top visible row in aCanvas's clip rectangle" ^ self rowAtLocation: (aCanvas clipRect topLeft) startingAt: aPos. ! ! !MorphTreeTransformMorph methodsFor: 'testing' stamp: 'AlainPlantec 10/10/2011 17:44'! wantsSteps ^ false! ! !MorphTreeTransformMorph methodsFor: 'layout' stamp: 'AlainPlantec 10/11/2011 13:22'! localSubmorphBounds "Answer, in my coordinate system, the bounds of all my visible submorphs (or nil if no visible submorphs)" localBounds ifNil: [ self hasSubmorphs ifFalse: [^ nil]. localBounds := self firstSubmorph fullBounds topLeft corner: owner maxNodeWidth @ (self lastSubmorph fullBounds bottom + owner extraScrollRange)]. ^ localBounds ! ! !MorphTreeTransformMorph methodsFor: 'drawing' stamp: 'AlainPlantec 10/5/2011 22:37'! rowAtLocation: aPoint "return the number of the row at aPoint" | y | y := aPoint y. submorphs ifEmpty: [^ nil]. submorphs doWithIndex: [:m :idx | m topLeft y >= y ifTrue: [^ (idx - 1) max: 1]]. ^ submorphs size! ! !MorphTreeTransformMorph methodsFor: 'drawing' stamp: 'AlainPlantec 10/9/2011 16:03'! bottomVisibleRowForCanvas: aCanvas startingAt: aPos "return the bottom visible row in aCanvas's clip rectangle" ^ self rowAtLocation: (aCanvas clipRect bottomRight) startingAt: aPos ! ! !MorphTreeTransformMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/16/2009 11:05'! fullBounds "Overridden to clip submorph hit detection to my bounds." "It might be better to override doLayoutIn:, and remove this method" fullBounds ifNotNil:[^ fullBounds]. fullBounds := bounds. ^ fullBounds! ! !MorphTreeTransformMorph methodsFor: 'layout' stamp: 'AlainPlantec 10/11/2011 13:02'! submorphBounds "Private. Compute the actual full bounds of the receiver, optimized for speed" self hasSubmorphs ifFalse: [^ nil]. ^ self firstSubmorph topLeft corner: owner scroller bounds bottomLeft + (0@ owner extraScrollRange) ! ! !MorphTreeTransformMorph methodsFor: 'drawing' stamp: 'AlainPlantec 10/9/2011 03:15'! bottomVisibleRowForCanvas: aCanvas "return the bottom visible row in aCanvas's clip rectangle" ^ self rowAtLocation: (aCanvas clipRect bottomRight). ! ! !MorphTreeTransformMorph methodsFor: 'drawing' stamp: 'NicolaiHess 12/6/2013 01:09'! drawRawColorOn: aCanvas forSubmorph: aSubMorph | c frame | frame := (aSubMorph fullBounds withWidth: owner scroller innerBounds width) translateBy:(owner scroller offset x)@0. aSubMorph = owner listManager searchedElement ifTrue: [ aCanvas fillRectangle: frame color: owner secondarySelectionColor. ^ self ]. owner listManager isCheckList ifTrue: [ aSubMorph = owner listManager lastClickedMorph ifTrue: [ aCanvas fillRectangle: frame color: owner selectionColorToUse. ^ self ] ] ifFalse: [ aSubMorph selected ifTrue: [ aCanvas fillRectangle: frame color: owner selectionColorToUse. ^ self ] ]. (c := aSubMorph color) notNil ifTrue: [ c isColor ifTrue: [ aCanvas frameAndFillRectangle: frame fillColor: c borderWidth: 0 borderColor: Color transparent ] ifFalse: [ c origin: aSubMorph bounds topLeft. c direction: aSubMorph bounds width @ 0. aCanvas fillRectangle: frame basicFillStyle: c ] ]! ! !MorphTreeTransformMorph methodsFor: 'drawing' stamp: 'AlainPlantec 10/9/2011 03:16'! topVisibleRowForCanvas: aCanvas "return the top visible row in aCanvas's clip rectangle" ^ self rowAtLocation: (aCanvas clipRect topLeft). ! ! !MorphWithSubmorphsWrapper commentStamp: 'ls 3/1/2004 17:32'! Display a morph in a SimpleHierarchicalListMorph, and arrange to recursively display the morph's submorphs. The "item" that is wrapped is the morph to display.! !MorphWithSubmorphsWrapper methodsFor: 'hierarchy' stamp: 'ls 3/1/2004 17:34'! contents ^item submorphs collect: [ :m | self class with: m ]! ! !MorphWrapper commentStamp: ''! A MorphWrapper is used to wrap a morph with a layout in the goal to be easily added to another morph! !MorphWrapper methodsFor: 'accessing' stamp: ''! morph: anObject morph := anObject! ! !MorphWrapper methodsFor: 'adding' stamp: ''! addIn: aContainer aContainer addMorph: morph fullFrame: layout! ! !MorphWrapper methodsFor: 'accessing' stamp: ''! fullFrame: anObject layout := anObject! ! !MorphWrapper methodsFor: 'accessing' stamp: 'StephaneDucasse 12/21/2012 11:26'! frame: rectangle layout := rectangle asLayoutFrame! ! !MorphWrapper class methodsFor: 'instance creation' stamp: 'ClementBera 6/28/2013 10:33'! morph: morph layout: aLayout ^ self new layout: aLayout; morph: morph; yourself! ! !MorphicAdapterBindings commentStamp: ''! I am used to link the spec-adapter names to the morphic adapters! !MorphicAdapterBindings methodsFor: 'initialize' stamp: 'StephaneDucasse 3/7/2014 11:13'! initializeBindings bindings at: #ButtonAdapter put: #MorphicButtonAdapter; at: #CheckBoxAdapter put: #MorphicCheckBoxAdapter; at: #ContainerAdapter put: #MorphicContainerAdapter; at: #DiffAdapter put: #MorphicDiffAdapter; at: #DropListAdapter put: #MorphicDropListAdapter; at: #LabelAdapter put: #MorphicLabelAdapter; at: #ListAdapter put: #MorphicListAdapter; at: #IconListAdapter put: #MorphicIconListAdapter; at: #ImageAdapter put: #MorphicImageAdapter; at: #MultiColumnListAdapter put: #MorphicMultiColumnListAdapter; at: #MenuAdapter put: #MorphicMenuAdapter; at: #MenuGroupAdapter put: #MorphicMenuGroupAdapter; at: #MenuItemAdapter put: #MorphicMenuItemAdapter; at: #NewListAdapter put: #MorphicNewListAdapter; at: #RadioButtonAdapter put: #MorphicRadioButtonAdapter; at: #SliderAdapter put: #MorphicSliderAdapter; at: #TabManagerAdapter put: #MorphicTabManagerAdapter; at: #TabAdapter put: #MorphicTabAdapter; at: #TextAdapter put: #MorphicTextAdapter; at: #TextInputFieldAdapter put: #MorphicTextInputFieldAdapter; at: #TreeAdapter put: #MorphicTreeAdapter; at: #TreeColumnAdapter put: #MorphicTreeColumnAdapter; at: #TreeNodeAdapter put: #MorphicTreeNodeAdapter; at: #WindowAdapter put: #MorphicWindowAdapter; at: #TickingWindowAdapter put: #MorphicTickingWindowAdapter; at: #DialogWindowAdapter put: #MorphicDialogWindowAdapter; yourself! ! !MorphicAlarm commentStamp: 'LaurentLaffont 3/4/2011 22:45'! I represent a message to be scheduled by the WorldState. For example, you can see me in action with the following example which print 'alarm test' on Transcript one second after evaluating the code: Transcript open. MorphicUIManager currentWorld addAlarm: #show: withArguments: #('alarm test') for: Transcript at: (Time millisecondClockValue + 1000). * Note * Compared to doing: [(Delay forMilliseconds: 1000) wait. Transcript show: 'alarm test'] forkAt: Processor activeProcess priority +1. the alarm system has several distinctions: - Runs with the step refresh rate resolution. - Alarms only run for the active world. (Unless a non-standard scheduler is in use) - Alarms with the same scheduled time are guaranteed to be executed in the order they were added! !MorphicAlarm methodsFor: 'accessing' stamp: 'ar 9/11/2000 16:45'! scheduledTime: msecs "Set the time (in milliseconds) that the receiver is scheduled to be executed" scheduledTime := msecs! ! !MorphicAlarm methodsFor: 'accessing' stamp: 'ar 9/11/2000 16:44'! scheduledTime "Return the time (in milliseconds) that the receiver is scheduled to be executed" ^scheduledTime! ! !MorphicAlarm methodsFor: 'evaluating' stamp: 'GuillermoPolito 9/1/2010 18:45'! value: anArgument | nArgs | numArgs ifNil:[numArgs := selector numArgs]. nArgs := arguments ifNil:[0] ifNotNil:[arguments size]. nArgs = numArgs ifTrue:[ "Ignore extra argument" ^self value]. ^arguments ifNil: [receiver perform: selector with: anArgument] ifNotNil: [receiver perform: selector withArguments: (arguments copyWith: anArgument)]! ! !MorphicAlarm class methodsFor: 'instance creation' stamp: 'ar 9/11/2000 16:44'! scheduledAt: scheduledTime receiver: aTarget selector: aSelector arguments: argArray ^(self receiver: aTarget selector: aSelector arguments: argArray) scheduledTime: scheduledTime.! ! !MorphicButtonAdapter commentStamp: ''! SpecInterpreter interpretASpec: MorphicButtonAdapter defaultSpec model: (MorphicButtonAdapter model: ButtonModel2 new) ! !MorphicButtonAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 13:59'! state ^ self model state! ! !MorphicButtonAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 13:58'! keyStroke: anEvent fromMorph: aMorph! ! !MorphicButtonAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 1/10/2014 14:35'! menu: aMenu | menuModel | menuModel := self model menu. menuModel isBlock ifTrue: [ menuModel := menuModel value ]. ^ menuModel buildWithSpec! ! !MorphicButtonAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 13:59'! label ^ self buildLabel: self model label withIcon: self model icon! ! !MorphicButtonAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 14:04'! action self widget ifNotNil: [:m | m takeKeyboardFocus ]. self model performAction.! ! !MorphicButtonAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 14:12'! askBeforeChanging ^ self model askBeforeChanging! ! !MorphicButtonAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/15/2014 10:19'! buildLabel: text withIcon: icon icon ifNil: [ ^ text ifNil: [ '' ] ifNotNil: [ text ] ]. ^ IconicListItem text: text icon: icon ! ! !MorphicButtonAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/5/2014 15:52'! defaultSpec ^ {#PluggableButtonMorph. #color:. Color white. #on:getState:action:label:menu:. #model. #state. #action. #label. nil. #getEnabledSelector:. #enabled. #getMenuSelector:. #menu:. #hResizing:. #spaceFill. #vResizing:. #spaceFill. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #askBeforeChanging:. #(model askBeforeChanging). #setBalloonText:. { #model . #help}. #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #eventHandler:. { #EventHandler. #on:send:to:. #keyStroke. #keyStroke:fromMorph:. #model }}! ! !MorphicCheckBoxAdapter commentStamp: ''! I am an adapter to ease the bridge a CheckBoxModel and a CheckboxMorph! !MorphicCheckBoxAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 17:31'! state: aBoolean ^ self model state: aBoolean! ! !MorphicCheckBoxAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 17:31'! state ^ self model state! ! !MorphicCheckBoxAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 17:30'! label ^ self model label! ! !MorphicCheckBoxAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 17:30'! labelClickable ^ self model labelClickable! ! !MorphicCheckBoxAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 17:39'! labelOnRight ^ self widgetDo: [ :w | w listDirection: #rightToLeft ]! ! !MorphicCheckBoxAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 17:39'! labelOnLeft ^ self widgetDo: [ :w | w listDirection: #leftToRight ]! ! !MorphicCheckBoxAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/22/2013 17:40'! defaultSpec ^ {#CheckboxMorph. #color:. Color transparent. #on:selected:changeSelected:. #model. #state. #state:. #label:. { #model. #label }. #beCheckbox. #hResizing:. #spaceFill. #vResizing:. #shrinkWrap. #setBalloonText:. { #model . #help}. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #labelClickable:. { #model. #labelClickable}.}! ! !MorphicContainerAdapter commentStamp: ''! I am the adapter providing the correct container class: PanelMorph! !MorphicContainerAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 13:50'! newHSplitterAt: aPosition self widgetDo: [ :w | w newHSplitterAt: aPosition ]! ! !MorphicContainerAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 13:50'! checkSplitters self widgetDo: [ :w | w checkSplitters ]! ! !MorphicContainerAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/28/2013 17:20'! centerWidget: aWindow self widgetDo: [ :w| w centerWidget: aWindow ]! ! !MorphicContainerAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/29/2013 13:50'! newVSplitterAt: aPosition self widgetDo: [ :w | w newVSplitterAt: aPosition ]! ! !MorphicContainerAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/1/2013 13:32'! isRedrawable "This must be overriden in the adapter representing your container" ^ true! ! !MorphicContainerAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 9/29/2013 13:41'! defaultSpec ^ #(PanelMorph changeProportionalLayout vResizing: spaceFill hResizing: spaceFill )! ! !MorphicDialogWindowAdapter commentStamp: ''! I am the adapter used to bridge a DialogWindowModel and a DialogWindow! !MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 23:47'! triggerOkAction self widget ifNotNil: [:w | w toolbar triggerOkAction ]! ! !MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 15:08'! triggerCancelAction self widget ifNotNil: [:w | w toolbar triggerCancelAction ]! ! !MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 23:49'! cancelAction: aBlock ^ self widget ifNotNil: [:w | w cancelAction: aBlock ]! ! !MorphicDialogWindowAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/24/2013 15:13'! toolbarBlock ^ [ self model toolbar ]! ! !MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 13:13'! toolbar: aToolbar self widgetDo: [ :w | w toolbar: aToolbar ]! ! !MorphicDialogWindowAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 23:50'! contentMorph ^ self model contents! ! !MorphicDialogWindowAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 11:53'! open self widget openInWorld! ! !MorphicDialogWindowAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/24/2013 15:14'! buildWidget ^ super buildWidget model: self model; yourself! ! !MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 23:48'! okAction: aBlock ^ self widget ifNotNil: [:w | w okAction: aBlock ]! ! !MorphicDialogWindowAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 23:45'! okButtonEnabled: aBoolean self widget ifNotNil: [ :w | w toolbar okButton enabled: aBoolean ]! ! !MorphicDialogWindowAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/24/2013 15:14'! defaultSpec ^ #( SpecDialogWindow specWidget: #(model contentMorph) setToolbarFrom: #(model toolbarBlock) initialize)! ! !MorphicDiffAdapter commentStamp: ''! I am an adpater to bridge a DiffModel and a DiffMorph! !MorphicDiffAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 22:16'! showBoth self widgetDo: [ :w | w showBoth ]! ! !MorphicDiffAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 21:02'! showOnlyDestination: aBoolean self widgetDo: [ :w | w showOnlyDestination: aBoolean ]! ! !MorphicDiffAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 21:01'! rightText: aText self widgetDo: [ :w | w dstText: aText; updateText ]! ! !MorphicDiffAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/21/2013 18:16'! leftText ^ self model leftText! ! !MorphicDiffAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 21:02'! showOptions: aBoolean self widgetDo: [ :w | w showOptions: aBoolean ]! ! !MorphicDiffAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/21/2013 18:16'! rightText ^ self model rightText! ! !MorphicDiffAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 21:01'! contextClass: aClass self widgetDo: [ :w | w contextClass: aClass; updateText ]! ! !MorphicDiffAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/21/2013 18:18'! showOnlyDestination ^ self model showOnlyDestination! ! !MorphicDiffAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/21/2013 22:16'! showOnlySource ^ self model showOnlySource! ! !MorphicDiffAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 22:17'! showOnlySource: aBoolean self widgetDo: [ :w | w showOnlySource: aBoolean ]! ! !MorphicDiffAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 21:01'! leftText: aText self widgetDo: [ :w | w srcText: aText; updateText ]! ! !MorphicDiffAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/21/2013 18:16'! contextClass ^ self model contextClass! ! !MorphicDiffAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/21/2013 18:18'! showOptions ^ self model showOptions! ! !MorphicDiffAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/21/2013 18:18'! defaultSpec ^ {#DiffMorph. #on:. #(model). #from:to:contextClass:. {#model. #leftText}. { #model. #rightText}. { #model. #contextClass}. #hResizing:. #spaceFill. #vResizing:. #spaceFill. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #setBalloonText:. #(model help). #showOptions:. #(model showOptions). #showOnlyDestination:. #(model showOnlyDestination). #eventHandler:. { #EventHandler. #on:send:to:. #keyStroke. #keyStroke:fromMorph:. #model }}! ! !MorphicDropListAdapter commentStamp: ''! I am the adapter used to bridget a DropListModel and a DropListMorph! !MorphicDropListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/23/2013 13:04'! getIconFor: anItem ^ self model iconHolder cull: anItem model cull: anItem! ! !MorphicDropListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:03'! setIndex: anIndex ^ self model setIndex: anIndex! ! !MorphicDropListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/24/2013 15:26'! wrapItem: anItem index: anIndex | result | result := self model displayForItem: anItem. ^ result asString! ! !MorphicDropListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:03'! getIndex ^ self model getIndex! ! !MorphicDropListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/22/2013 18:31'! getList ^ self model getList! ! !MorphicDropListAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/22/2013 18:42'! defaultSpec ^ {#SpecDropListMorph. #color:. Color white. #wrapSelector:. #wrap:withIndex:. #on:list:selected:changeSelected:. #model. #getList. #getIndex. #setIndex:. #hResizing:. #spaceFill. #vResizing:. #spaceFill. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #setBalloonText:. { #model . #help}}! ! !MorphicEvent commentStamp: ''! This class represents the base for all events. Instance variables: stamp The millisecond clock time stamp (based on Time millisecondClock) source If non-nil the hand that generated the event.! !MorphicEvent methodsFor: 'transforming' stamp: 'ar 9/13/2000 15:47'! transformedBy: aMorphicTransform "Return the receiver transformed by the given transform into a local coordinate system." ! ! !MorphicEvent methodsFor: 'accessing' stamp: 'JMM 7/20/2004 22:10'! windowIndex ^windowIndex! ! !MorphicEvent methodsFor: 'dispatching' stamp: 'ar 9/15/2000 21:12'! sentTo: anObject "Dispatch the receiver into anObject" ^anObject handleUnknownEvent: self! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:19'! isKeyboard ^false! ! !MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 01:20'! wasHandled: aBool "Determine if this event was handled. May be ignored for some types of events."! ! !MorphicEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'! resetHandlerFields "Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 10/10/2000 21:27'! isKeystroke ^false! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:17'! isDropEvent ^false! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 9/14/2000 18:21'! isMouseOver ^self type == #mouseOver! ! !MorphicEvent methodsFor: 'testing' stamp: 'JMM 10/6/2004 21:23'! isMove ^false! ! !MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 16:48'! hand "Return the source that generated the event" ^source! ! !MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:29'! timeStamp "Return the millisecond clock value at which the event was generated" ^timeStamp ifNil:[timeStamp := Time millisecondClockValue]! ! !MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:34'! type "Return a symbol indicating the type this event." ^self subclassResponsibility! ! !MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 21:28'! cursorPoint "Backward compatibility. Use #position instead" ^ self position! ! !MorphicEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'! copyHandlerState: anEvent "Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events." ! ! !MorphicEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:36'! hash ^self type hash! ! !MorphicEvent methodsFor: 'private' stamp: 'ar 10/25/2000 20:53'! setTimeStamp: stamp timeStamp := stamp.! ! !MorphicEvent methodsFor: 'accessing' stamp: 'JMM 7/20/2004 22:10'! windowIndex: aValue windowIndex := aValue! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:37'! isMorphicEvent ^true! ! !MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 01:19'! wasHandled "Return true if this event was handled. May be ignored for some types of events." ^false! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:19'! isMouse ^false! ! !MorphicEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:36'! = anEvent anEvent isMorphicEvent ifFalse:[^false]. ^self type = anEvent type! ! !MorphicEvent methodsFor: 'accessing' stamp: 'wiz 12/8/2004 23:13'! position "Since cursorPoint is defined and refers to position it should be defined here as well" ^ self subclassResponsibility! ! !MorphicEvent methodsFor: 'private' stamp: 'ar 10/25/2000 21:26'! setHand: aHand source := aHand! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 9/22/2000 10:36'! isDraggingEvent ^false! ! !MorphicEvent methodsFor: 'testing' stamp: 'JMM 10/6/2004 21:35'! isWindowEvent ^false! ! !MorphicEventDispatcher commentStamp: ''! The class represents a strategy for dispatching events to some immediate child of a morph. It is used by morphs to delegate the somewhat complex action of dispatching events accurately. ! !MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:14'! dispatchMouseDown: anEvent with: aMorph "Find the appropriate receiver for the event and let it handle it. Default rules: * The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event. * When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is. * When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed. * If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event. " | globalPt localEvt index child morphs handler inside lastHandler | "Try to get out quickly" globalPt := anEvent cursorPoint. (aMorph fullBounds containsPoint: globalPt) ifFalse:[^#rejected]. "Install the prospective handler for the receiver" lastHandler := anEvent handler. "in case the mouse wasn't even in the receiver" handler := aMorph handlerForMouseDown: anEvent. handler ifNotNil:[anEvent handler: handler]. "Now give our submorphs a chance to handle the event" index := 1. morphs := aMorph submorphs. [index <= morphs size] whileTrue:[ child := morphs at: index. localEvt := anEvent transformedBy: (child transformedFrom: aMorph). (child processEvent: localEvt using: self) == #rejected ifFalse:[ "Some child did contain the point so we're part of the top-most chain." inside := false. localEvt wasHandled ifTrue:[anEvent copyHandlerState: localEvt]. index := morphs size]. index := index + 1. ]. (inside == false or:[aMorph containsPoint: anEvent cursorPoint event: anEvent]) ifTrue:[ "Receiver is in the top-most unlocked, visible chain." handler ifNotNil:[handler handleEvent: anEvent]. "Note: Re-installing the handler is not really necessary but good style." anEvent handler: lastHandler. ^self ]. "Mouse was not on receiver nor any of its children" anEvent handler: lastHandler. ^#rejected! ! !MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 01:20'! dispatchDefault: anEvent with: aMorph "Dispatch the given event. The event will be passed to the front-most visible submorph that contains the position wrt. to the event." | localEvt index child morphs inside | "See if we're fully outside aMorphs bounds" (aMorph fullBounds containsPoint: anEvent position) ifFalse:[^#rejected]. "outside" "Traverse children" index := 1. morphs := aMorph submorphs. inside := false. [index <= morphs size] whileTrue:[ child := morphs at: index. localEvt := anEvent transformedBy: (child transformedFrom: aMorph). (child processEvent: localEvt using: self) == #rejected ifFalse:[ "Not rejected. The event was in some submorph of the receiver" inside := true. localEvt wasHandled ifTrue:[anEvent copyHandlerState: localEvt]. index := morphs size. "break" ]. index := index + 1. ]. "Check for being inside the receiver" inside ifFalse:[inside := aMorph containsPoint: anEvent position event: anEvent]. inside ifTrue:[^aMorph handleEvent: anEvent]. ^#rejected ! ! !MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'tbn 3/12/2010 01:53'! dispatchWindowEvent: anEvent with: aMorph "Host window events do not have a position and are only dispatched to the World" aMorph isWorldMorph ifFalse: [^#rejected]. anEvent wasHandled ifTrue:[^self]. ^aMorph handleEvent: anEvent ! ! !MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:13'! dispatchDropEvent: anEvent with: aMorph "Find the appropriate receiver for the event and let it handle it. The dispatch is similar to the default dispatch with one difference: Morphs are given the chance to reject an entire drop operation. If the operation is rejected, no drop will be executed." | inside index morphs child localEvt | "Try to get out quickly" (aMorph fullBounds containsPoint: anEvent cursorPoint) ifFalse:[^#rejected]. "Give aMorph a chance to repel the dropping morph" aMorph rejectDropEvent: anEvent. anEvent wasHandled ifTrue:[^self]. "Go looking if any of our submorphs wants it" index := 1. inside := false. morphs := aMorph submorphs. [index <= morphs size] whileTrue:[ child := morphs at: index. localEvt := anEvent transformedBy: (child transformedFrom: aMorph). (child processEvent: localEvt using: self) == #rejected ifFalse:[ localEvt wasHandled ifTrue:[^anEvent wasHandled: true]. "done" inside := true. index := morphs size]. "break" index := index + 1. ]. inside ifFalse:[inside := aMorph containsPoint: anEvent cursorPoint event: anEvent]. inside ifTrue:[^aMorph handleEvent: anEvent]. ^#rejected! ! !MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'tbn 3/12/2010 01:53'! dispatchEvent: anEvent with: aMorph "Dispatch the given event for a morph that has chosen the receiver to dispatch its events. The method implements a shortcut for repeated dispatches of events using the same dispatcher." anEvent type == lastType ifTrue:[^self perform: lastDispatch with: anEvent with: aMorph]. "Otherwise classify" lastType := anEvent type. anEvent isMouse ifTrue:[ anEvent isMouseDown ifTrue:[ lastDispatch := #dispatchMouseDown:with:. ^self dispatchMouseDown: anEvent with: aMorph]]. anEvent type == #dropEvent ifTrue:[ lastDispatch := #dispatchDropEvent:with:. ^self dispatchDropEvent: anEvent with: aMorph]. anEvent isWindowEvent ifTrue:[ lastDispatch := #dispatchWindowEvent:with:. ^self dispatchWindowEvent: anEvent with: aMorph]. lastDispatch := #dispatchDefault:with:. ^self dispatchDefault: anEvent with: aMorph! ! !MorphicEventHandler commentStamp: 'GuillermoPolito 4/22/2012 19:16'! I'm the class in charge of handling the subscriptions to events such as clicks or key presses. I'm a provisory solution while my clients are fixed and I can be replaced by announcements! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:02'! existsSubscriptionsFor: anEvent ^(subscriptions includesKey: anEvent) and: [ (subscriptions at: anEvent) notEmpty ]! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:08'! handlesKeyDown: evt ^self existsSubscriptionsFor: #keyDown! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:57'! click: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #click from: sourceMorph! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 7/18/2012 13:04'! notifyMorphsOfEvent: anEvent ofType: eventType from: sourceMorph | result | result := false. ((subscriptions includesKey: eventType) not or: [ (subscriptions at: eventType) isEmpty ]) ifTrue: [ ^false ]. (subscriptions at: eventType) do: [ :s | result := result | ((s notify: anEvent from: sourceMorph) == true) ]. ^result! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! mouseEnterDragging: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #mouseEnterDragging from: sourceMorph! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:06'! handlesMouseDown: evt ^(self existsSubscriptionsFor: #mouseDown) or: [ (self existsSubscriptionsFor: #mouseStillDown) or: [ (self existsSubscriptionsFor: #mouseUp) or: [ (self handlesClickOrDrag: evt) or: [ self handlesGestureStart: evt]]]].! ! !MorphicEventHandler methodsFor: 'copying' stamp: 'GuillermoPolito 4/22/2012 18:13'! veryDeepFixupWith: deepCopier | old | "ALL inst vars were weakly copied. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. 1 to: self class instSize do: [:ii | old := self instVarAt: ii. self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old]) ]. ! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! keyUp: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #keyUp from: sourceMorph! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:07'! handlesMouseOver: evt ^(self existsSubscriptionsFor: #mouseEnter) or: [ self existsSubscriptionsFor: #mouseLeave ]! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:55'! startDrag: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #startDrag from: sourceMorph! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:03'! handlesGestureStart: evt ^self existsSubscriptionsFor: #gestureStart! ! !MorphicEventHandler methodsFor: 'initialization' stamp: 'GuillermoPolito 4/22/2012 18:47'! initialize subscriptions := Dictionary new.! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'SeanDeNigris 1/29/2013 13:55'! mouseSelectorsInclude: selector | mouseEventTypes allSubscriptions | mouseEventTypes := #( mouseDown mouseMove mouseStillDown mouseUp mouseEnter mouseLeave mouseEnterDragging mouseLeaveDragging doubleClick). allSubscriptions := subscriptions values gather: [ :e | e ]. ^ allSubscriptions anySatisfy: [ :e | (mouseEventTypes includes: e event) and: [ e selector = selector ] ].! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:57'! keyStroke: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #keyStroke from: sourceMorph! ! !MorphicEventHandler methodsFor: 'initialization' stamp: 'GuillermoPolito 4/22/2012 19:24'! on: eventName send: selector to: recipient withValue: value selector numArgs = 3 ifFalse: [self error: 'Warning: value parameters are passed as first of 3 arguments']. self addSubscription: (MorphEventSubscription on: eventName send: selector to: recipient withValue: value) toEvent: eventName. ! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! mouseUp: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #mouseUp from: sourceMorph! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:09'! handlesKeyStroke: evt ^self existsSubscriptionsFor: #keyStroke! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:57'! doubleClickTimeout: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #doubleClickTimeout from: sourceMorph! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:07'! handlesMouseOverDragging: evt ^(self existsSubscriptionsFor: #mouseEnterDragging ) or: [ self existsSubscriptionsFor: #mouseLeaveDragging ]! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:06'! handlesMouseMove: evt ^self existsSubscriptionsFor: #mouseMove! ! !MorphicEventHandler methodsFor: 'access' stamp: 'GuillermoPolito 4/22/2012 17:55'! allRecipients ^subscriptions collect: #recipients! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 19:24'! addSubscription: aSubscription toEvent: eventName (subscriptions includesKey: eventName) ifFalse: [ subscriptions at: eventName put: Set new. ]. (subscriptions at: eventName) add: aSubscription.! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:01'! handlesClickOrDrag: evt ^(self existsSubscriptionsFor: #click) or: [ (self existsSubscriptionsFor: #doubleClick) or: [(self existsSubscriptionsFor: #startDrag)]].! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:09'! handlesKeyboard: evt ^(self handlesKeyDown: evt) or: [ (self handlesKeyUp: evt) or: [ self handlesKeyStroke: evt ]].! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! mouseStillDown: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #mouseStillDown from: sourceMorph! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! mouseLeaveDragging: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #mouseLeaveDragging from: sourceMorph! ! !MorphicEventHandler methodsFor: 'access' stamp: 'CamilloBruni 8/1/2012 16:11'! methodRefList "Return a MethodReference for each message I can send." | list | list := OrderedCollection new. subscriptions do: [ :s | s recipient ifNotNil: [list add: (RGMethodDefinition realClass: (s recipient class whichClassIncludesSelector: s selector) selector: s selector)] ]. ^ list! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! mouseEnter: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #mouseEnter from: sourceMorph! ! !MorphicEventHandler methodsFor: 'initialization' stamp: 'GuillermoPolito 4/22/2012 19:22'! on: eventName send: selector to: recipient self addSubscription: (MorphEventSubscription on: eventName send: selector to: recipient) toEvent: eventName.! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:57'! doubleClick: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #doubleClick from: sourceMorph! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! mouseLeave: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #mouseLeave from: sourceMorph! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:08'! handlesKeyUp: evt ^self existsSubscriptionsFor: #keyUp! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:57'! keyDown: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #keyDown from: sourceMorph! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! mouseDown: event fromMorph: sourceMorph "Take double-clicks into account." ((self handlesClickOrDrag: event) and:[event redButtonPressed]) ifTrue:[ event hand waitForClicksOrDrag: sourceMorph event: event. ]. ^self notifyMorphsOfEvent: event ofType: #mouseDown from: sourceMorph! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! mouseMove: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #mouseMove from: sourceMorph! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:08'! handlesMouseStillDown: evt ^self existsSubscriptionsFor: #mouseStillDown.! ! !MorphicEventHandlerTest methodsFor: 'tests' stamp: 'GuillermoPolito 4/22/2012 18:34'! testClickFromMorph morph eventHandler on: #click send: #value to: true. self assert: ((morph click: nil) == true)! ! !MorphicEventHandlerTest methodsFor: 'tests' stamp: 'GuillermoPolito 7/18/2012 12:51'! testKeyStrokeFromMorph | keyboardEvent | keyboardEvent := KeyboardEvent new setType: #keystroke buttons: 2 position: nil keyValue: nil charCode: 65 hand: nil stamp: nil. morph eventHandler on: #keyStroke send: #value to: true. self assert: ((morph handleKeystroke: keyboardEvent) == true)! ! !MorphicEventHandlerTest methodsFor: 'tests' stamp: 'GuillermoPolito 7/18/2012 12:52'! testTwoEventHandlersAreAttached | keyboardEvent first second | keyboardEvent := KeyboardEvent new setType: #keystroke buttons: 2 position: nil keyValue: 65 charCode: 65 hand: nil stamp: nil. first := false. second := false. morph eventHandler on: #keyStroke send: #value to: [ first := true ]. morph eventHandler on: #keyStroke send: #value to: [ second := true ]. morph handleKeystroke: keyboardEvent. self assert: first. self assert: second.! ! !MorphicEventHandlerTest methodsFor: 'tests' stamp: 'GuillermoPolito 4/22/2012 18:34'! testDoubleClickTimeoutFromMorph morph eventHandler on: #doubleClickTimeout send: #value to: true. self assert: ((morph doubleClickTimeout: nil) == true)! ! !MorphicEventHandlerTest methodsFor: 'running' stamp: 'GuillermoPolito 4/22/2012 18:34'! tearDown morph := nil! ! !MorphicEventHandlerTest methodsFor: 'tests-events' stamp: 'GuillermoPolito 4/22/2012 18:34'! testMouseEnterDraggingFromMorph | event | event := MouseEvent basicNew setType: #mouseOver position: nil buttons: 2 hand: Morph new. morph eventHandler on: #mouseEnterDragging send: #value to: true. self assert: ((morph handleMouseEnter: event) == true)! ! !MorphicEventHandlerTest methodsFor: 'tests-events' stamp: 'GuillermoPolito 4/22/2012 18:34'! testMouseEnterFromMorph morph eventHandler on: #mouseEnter send: #value to: true. self assert: ((morph mouseEnter: nil) == true)! ! !MorphicEventHandlerTest methodsFor: 'tests-events' stamp: 'GuillermoPolito 4/22/2012 18:34'! testMouseLeaveFromMorph morph eventHandler on: #mouseLeave send: #value to: true. self assert: ((morph mouseLeave: nil) == true)! ! !MorphicEventHandlerTest methodsFor: 'running' stamp: 'GuillermoPolito 4/22/2012 19:15'! setUp morph := Morph new. morph eventHandler: MorphicEventHandler new! ! !MorphicEventHandlerTest methodsFor: 'tests' stamp: 'GuillermoPolito 4/22/2012 18:34'! testDoubleClickFromMorph morph eventHandler on: #doubleClick send: #value to: true. self assert: ((morph doubleClick: nil) == true)! ! !MorphicGenericAdapter commentStamp: ''! I am a generic adapter used to embed directly a Morph in spec. Be aware that when you use this, you broke Spec plateform independency and force you application to run only on top of Morphic! !MorphicGenericAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/1/2013 13:43'! morph ^ self widget! ! !MorphicGenericAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/1/2013 13:43'! morph: anObject widget := anObject! ! !MorphicGenericAdapter class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 10/1/2013 13:10'! morph: morph ^ self new morph: morph; yourself! ! !MorphicIconListAdapter commentStamp: ''! I am the adapter used to bridge an IconListModel and a PluggableIconListMorph! !MorphicIconListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:33'! getIconFor: anItem ^ self model getIconFor: anItem! ! !MorphicIconListAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 9/27/2013 10:22'! defaultSpec ^ {#PluggableIconListMorph. #color:. Color white. #model:. #model. #getListSizeSelector:. #listSize. #getListElementSelector:. #listElementAt:. #getIndexSelector:. #getIndex. #setIndexSelector:. #setIndex:. #getSelectionListSelector:. #getSelectionStateFor:. #setSelectionListSelector:. #setSelectionStateFor:at:. #getIconSelector:. #getIconFor:. #resetListSelector:. #resetListSelection. #getMenuSelector:. #menu:shifted:. #setMultipleSelection:. {#model. #multiSelection}. #wrapSelector:. #wrapItem:index:. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #setBalloonText:. { #model . #help}. #hResizing:. #spaceFill. #vResizing:. #spaceFill}! ! !MorphicImageAdapter commentStamp: ''! I am the bridge between an ImageModel and a AlphaImageMorph! !MorphicImageAdapter methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/11/2014 22:22'! adapt: aComposableModel super adapt: aComposableModel. widget on: #click send: #click to: self! ! !MorphicImageAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/11/2014 22:23'! click ^ self model action value! ! !MorphicImageAdapter methodsFor: 'widget protocol' stamp: 'BenjaminVanRyseghem 1/11/2014 22:08'! getImage ^ self model image! ! !MorphicImageAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/11/2014 22:11'! defaultSpec ^ {#AlphaImageMorph. #color:. Color transparent. #model:. #model. #getImageSelector:. #getImage. #vResizing:. #spaceFill. #hResizing:. #spaceFill. #layout:. #center. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #setBalloonText:. { #model . #help}. #update:. #getImage}! ! !MorphicLabelAdapter commentStamp: ''! I am the adapter used to bridget a LabelModel and a LabelMorph! !MorphicLabelAdapter methodsFor: 'model access' stamp: 'BenjaminVanRyseghem 9/25/2013 17:24'! getText ^ self model label! ! !MorphicLabelAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 1/4/2014 18:16'! emphasis: anInteger self widgetDo: [ :w | w emphasis: anInteger ]! ! !MorphicLabelAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/23/2014 16:19'! defaultSpec ^ {#LabelMorph. #color:. #(model color). #model:. #model. #getEnabledSelector:. #enabled. #getTextSelector:. #getText. #vResizing:. #shrinkWrap. #hResizing:. #spaceFill. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #setBalloonText:. { #model . #help}}! ! !MorphicListAdapter commentStamp: ''! I am the adapter used to bridge a ListModel and a PluggableListMorph! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:10'! acceptDroppingMorph: draggedMorph event: event inMorph: source | item index | index := source rowAtLocation: event position. item := self model getList at: index ifAbsent: [ nil ]. ^ self acceptDropBlock valueWithEnoughArguments: { draggedMorph. event. source. item. index }! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:08'! listElementAt: anIndex ^ self model listElementAt: anIndex! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:08'! getSelectionStateFor: anIndex ^ self model getSelectionStateFor: anIndex! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:08'! listElementAt: anIndex ifAbsent: aBlock ^ self model listElementAt: anIndex ifAbsent: aBlock! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:08'! resetListSelection ^ self model resetListSelection! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 1/6/2014 16:04'! backgroundColorFor: anItem at: index ^ self model backgroundColorFor: anItem at: index! ! !MorphicListAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 1/10/2014 09:53'! autoDeselect: aBoolean self widgetDo: [ :w | w autoDeselect: aBoolean ]! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:07'! getIndex ^ self model getIndex! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:14'! listSize ^ self model listSize! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:08'! setIndex: anIndex ^ self model setIndex: anIndex! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:08'! wrapItem: anObject index: index ^ self model wrapItem: anObject index: index! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 1/10/2014 09:57'! autoDeselect ^ self model autoDeselect! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:08'! setSelectionStateFor: anIndex at: aBoolean ^ self model setSelectionStateFor: anIndex at: aBoolean! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 1/6/2014 15:50'! backgroundColorFor: anItem ^ self model backgroundColorFor: anItem! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:14'! multiSelection ^ self model multiSelection! ! !MorphicListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:08'! menu: aMenu shifted: aBoolean ^ self model menu: aMenu shifted: aBoolean! ! !MorphicListAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/10/2014 09:59'! defaultSpec ^ {#PluggableListMorph. #color:. Color white. #model:. #model. #getListSizeSelector:. #listSize. #autoDeselect:. #(model autoDeselect). #getIndexSelector:. #getIndex. #setIndexSelector:. #setIndex:. #getSelectionListSelector:. #getSelectionStateFor:. #setSelectionListSelector:. #setSelectionStateFor:at:. #backgroundColoringBlockOrSelector:. #backgroundColorFor:at:. #getListElementSelector:. #listElementAt:. #resetListSelector:. #resetListSelection. #getMenuSelector:. #menu:shifted:. #setMultipleSelection:. {#model. #multiSelection}. #wrapSelector:. #wrapItem:index:. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #setBalloonText:. { #model . #help}. #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #hResizing:. #spaceFill. #vResizing:. #spaceFill}! ! !MorphicMenuAdapter commentStamp: ''! I am the adapter used to build a MenuMorph from a MenuModel! !MorphicMenuAdapter methodsFor: 'private' stamp: 'NicolaiHess 3/12/2014 10:19'! buildWidgetPopup widget := SpecInterpreter interpretASpec: self class popupSpec model: self. self menuGroups do: [ :group || items | items := group buildWithSpec. items do: [ :item | widget addMenuItem: item ] ] separatedBy: [ widget addLine ]. ^ widget! ! !MorphicMenuAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 14:37'! title ^ self model title! ! !MorphicMenuAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 1/5/2014 17:29'! openAt: aPoint self widgetDo: [ :w | w invokeAt: (aPoint + (2@7)) in: World allowKeyboard: true ]! ! !MorphicMenuAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/18/2014 23:53'! buildWidget widget := super buildWidget. widget adoptMenuModel: self model. ^ widget! ! !MorphicMenuAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/11/2014 20:11'! menuGroups ^ self model menuGroups select: [:e | e isEmpty not ]! ! !MorphicMenuAdapter methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/18/2014 23:11'! adaptAsPopup: aComposableModel model := aComposableModel. aComposableModel addDependent: self. widget := self buildWidgetPopup.! ! !MorphicMenuAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 14:37'! icon ^ self model icon! ! !MorphicMenuAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/18/2014 23:29'! defaultSpec ^ {#ToolDockingBarMorph. #hResizing:. #spaceFill. #vResizing:. #spaceFill. #borderColor:. Color transparent}! ! !MorphicMenuAdapter class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/18/2014 23:02'! adaptAsPopup: aComposableModel ^ self new adaptAsPopup: aComposableModel; yourself! ! !MorphicMenuAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/18/2014 23:03'! popupSpec ^ #(MenuMorph addIfNeededTitle:andIcon: #(model title) #(model icon))! ! !MorphicMenuGroupAdapter commentStamp: ''! I am used to compute a MenuGroupModel. There is not Morphic represenation of a MenuGroup, that is why I do not have a coresponding morph.! !MorphicMenuGroupAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/1/2013 14:06'! buildWidget ^ self menuItems collect: [ :each | each buildWithSpec ]! ! !MorphicMenuGroupAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 14:08'! menuItems ^ self model menuItems! ! !MorphicMenuItemAdapter commentStamp: ''! I am the bridge between a MenuItemModel and a ToggleMenuItemMorph! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/1/2013 17:21'! enabled | enabled | enabled := self model enabled. ^ (enabled isBlock or: [ enabled isMessageSend ]) ifTrue: [ enabled cull: self model ] ifFalse: [ enabled ]! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/1/2013 15:12'! performMenuActionWith: arguments ^ self model performMenuActionWith: arguments! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/1/2013 18:02'! shortcut | shortcut | shortcut := self model shortcut. ^ (shortcut isBlock or: [ shortcut isMessageSend ]) ifTrue: [ shortcut cull: self model ] ifFalse: [ shortcut ]! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/1/2013 15:02'! actionArguments ^ [ Array with: self ]! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 1/5/2014 16:13'! shortcutText | shortcut platform string | shortcut := self shortcut. shortcut isString ifTrue: [ shortcut := self defaultModifierShortcut ]. shortcut ifNil: [ ^ nil ]. platform := Smalltalk os platformFamily. shortcut combinationsDo: [ :each | (each platform = Smalltalk os platformFamily) ifTrue: [ shortcut := each ] ]. string := '⌘⇧'. ^ (platform = #MacOSX and: [ (StandardFonts menuFont hasGlyphsForAll: string) and: [ string allSatisfy: [ :c | (StandardFonts menuFont characterFormAt: c) width~= 0 ]]]) ifFalse: [ shortcut shortcut printString ] ifTrue: [ String streamContents: [:stream | shortcut shortcut prettyPrintOn: stream ] ]! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/1/2013 18:16'! balloonText | balloonText | balloonText := self model description. balloonText ifNil: [ ^ nil ]. ^ (balloonText isBlock or: [ balloonText isMessageSend ]) ifTrue: [ balloonText cull: self model ] ifFalse: [ balloonText ]! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/1/2013 17:20'! state | state | state := self model state. ^ (state isBlock or: [ state isMessageSend ]) ifTrue: [ state cull: self model ] ifFalse: [ state ]! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 3/4/2014 17:25:06'! subMenu | subMenu | subMenu := self model subMenu. subMenu ifNil: [ ^ nil ]. ^ (subMenu isBlock or: [ subMenu isMessageSend ]) ifTrue: [ subMenu cull: self model ] ifFalse: [ subMenu buildWithSpecAsPopup ]! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/1/2013 13:44'! action ^ self model action! ! !MorphicMenuItemAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/29/2013 15:58'! defaultModifierShortcut ^ self shortcut first isUppercase ifTrue: [ OSPlatform current defaultModifier + KMModifier shift + self shortcut first ] ifFalse: [ OSPlatform current defaultModifier + self shortcut first ]! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/1/2013 18:23'! autoRefresh | autoRefresh | autoRefresh := self model autoRefresh. ^ (autoRefresh isBlock or: [ autoRefresh isMessageSend ]) ifTrue: [ autoRefresh cull: self model ] ifFalse: [ autoRefresh ]! ! !MorphicMenuItemAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/22/2014 14:26'! buildWidget | spec | spec := self autoRefresh ifTrue: [ self class autoRefreshSpec ] ifFalse: [ self class defaultSpec ]. ^ SpecInterpreter private_interpretASpec: spec model: self selector: nil! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/1/2013 17:21'! name | name | name := self model name. ^ (name isBlock or: [ name isMessageSend ]) ifTrue: [ name cull: self model ] ifFalse: [ name ]! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/1/2013 18:25'! stateSelector ^ self state ifNil: [ nil ] ifNotNil: [ #state ]! ! !MorphicMenuItemAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/1/2013 17:56'! icon | icon | icon := self model icon. ^ (icon isBlock or: [ icon isMessageSend ]) ifTrue: [ icon cull: self model ] ifFalse: [ icon ]! ! !MorphicMenuItemAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/1/2013 18:27'! defaultSpec ^ #(ToggleMenuItemMorph contents: #(model name) target: #(model) selector: #performMenuActionWith: subMenu: #(model subMenu) argumentsBlock: #(model actionArguments) getStateSelector: #(model stateSelector) icon: #(model icon) enablementSelector: #enabled balloonText: #(model balloonText) keyText: #(model shortcutText) )! ! !MorphicMenuItemAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/1/2013 18:23'! autoRefreshSpec ^ #(UpdatingMenuItemMorph target: #(model) balloonTextSelector: #balloonText subMenuSelector: #subMenu nameSelector: #name selector: #performMenuActionWith: argumentsBlock: #(model actionArguments) getStateSelector: #state iconSelector: #icon enablementSelector: #enabled keyText: #(model shortcutText) )! ! !MorphicModel commentStamp: ''! MorphicModels are used to represent structures with state and behavior as well as graphical structure. A morphicModel is usually the root of a morphic tree depicting its appearance. The tree is constructed concretely by adding its consituent morphs to a world. When a part is named in a world, it is given a new slot in the model. When a part is sensitized, it is named, and a set of mouse-driven methods is also generated in the model. These may be edited to induce particular behavior. When a variable is added through the morphic world, it is given a slot in the model, along with a set of access methods. In addition for public variables (and this is the default for now), methods are generated and called in any outer model in which this model gets embedded, thus propagating variable changes outward.! !MorphicModel methodsFor: 'initialization' stamp: 'StephaneDucasse 7/22/2011 18:28'! model: anObject accessor: selector model := anObject. accessor := selector. open := false.! ! !MorphicModel methodsFor: 'menu' stamp: 'di 6/20/97 15:36'! openToEdits "Enable this morph's ability to add and remove morphs via drag-n-drop." open := true ! ! !MorphicModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color transparent! ! !MorphicModel methodsFor: 'drag and drop' stamp: 'di 6/22/97 23:16'! isOpen "Support drag/drop and other edits." ^ open! ! !MorphicModel methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 14:30'! keyboardFocusOnMouseDown ^ self class keyboardFocusOnMouseDown! ! !MorphicModel methodsFor: 'accessing' stamp: 'sw 10/23/1999 22:36'! modelOrNil ^ model! ! !MorphicModel methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:53'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. model ifNotNil: [model addModelMenuItemsTo: aCustomMenu forMorph: self hand: aHandMorph]. self isOpen ifTrue: [aCustomMenu add: 'close editing' translated action: #closeToEdits] ifFalse: [aCustomMenu add: 'open editing' translated action: #openToEdits]. ! ! !MorphicModel methodsFor: 'caching' stamp: 'sw 3/6/2001 11:22'! releaseCachedState "Release cached state of the receiver" (model ~~ self and: [model respondsTo: #releaseCachedState]) ifTrue: [model releaseCachedState]. super releaseCachedState! ! !MorphicModel methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'! defaultBounds "answer the default bounds for the receiver" ^ 0 @ 0 corner: 200 @ 100! ! !MorphicModel methodsFor: 'initialization' stamp: 'StephaneDucasse 7/22/2011 18:29'! initialize "initialize the state of the receiver" super initialize. open := false! ! !MorphicModel methodsFor: 'accessing' stamp: ''! model ^ model! ! !MorphicModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color yellow! ! !MorphicModel methodsFor: 'classification' stamp: 'ar 10/5/2000 16:40'! isMorphicModel ^true! ! !MorphicModel methodsFor: 'geometry' stamp: ''! newBounds: newBounds self bounds: newBounds! ! !MorphicModel methodsFor: 'menu' stamp: 'di 6/20/97 15:36'! closeToEdits "Disable this morph's ability to add and remove morphs via drag-n-drop." open := false ! ! !MorphicModel methodsFor: 'initialization' stamp: 'FernandoOlivero 5/10/2011 06:51'! model: anObject "Set my model and make me me a dependent of the given object." model ifNotNil: [model removeDependent: self]. anObject ifNotNil: [anObject addDependent: self]. model := anObject. ! ! !MorphicModel methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 14:52'! mouseOverForKeyboardFocus ^ self class mouseOverForKeyboardFocus! ! !MorphicModel class methodsFor: 'window color' stamp: 'AlainPlantec 12/16/2009 22:31'! patchworkUIThemeColor "Answer a default color for UI themes that make use of different colors for Browser, MessageList etc..." ^ Color lightGray! ! !MorphicModel class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 14:53'! mouseOverForKeyboardFocus: aBoolean MouseOverForKeyboardFocus := aBoolean! ! !MorphicModel class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 14:30'! keyboardFocusOnMouseDown ^ KeyboardFocusOnMouseDown ifNil: [KeyboardFocusOnMouseDown := true]! ! !MorphicModel class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 14:32'! keyboardFocusOnMouseDown: aBoolean KeyboardFocusOnMouseDown := aBoolean! ! !MorphicModel class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 14:53'! mouseOverForKeyboardFocus ^ MouseOverForKeyboardFocus ifNil: [MouseOverForKeyboardFocus := false]! ! !MorphicMultiColumnListAdapter commentStamp: ''! I am the adapter used to bridge a MultiColumnListModel and a PluggableMultiColumnListMorph! !MorphicMultiColumnListAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 9/27/2013 10:23'! defaultSpec ^ {#PluggableMultiColumnListMorph. #color:. Color white. #wrapSelector:. #wrapItem:index:. #model:. #model. #getListSizeSelector:. #listSize. #getIndexSelector:. #getIndex. #setIndexSelector:. #setIndex:. #getSelectionListSelector:. #getSelectionStateFor:. #setSelectionListSelector:. #setSelectionStateFor:at:. #getListElementSelector:. #listElementAt:. #resetListSelector:. #resetListSelection. #getMenuSelector:. #menu:shifted:. #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #setMultipleSelection:. {#model. #multiSelection}. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #setBalloonText:. { #model . #help}. #hResizing:. #spaceFill. #vResizing:. #spaceFill}! ! !MorphicNewListAdapter commentStamp: ''! I am the adapter used to bridge a NewListModel and a NewList! !MorphicNewListAdapter methodsFor: 'list protocol-events' stamp: 'BenjaminVanRyseghem 9/25/2013 18:52'! indexesHasBeenSelected ^ [ :indexes | self model selectedIndexes: indexes ]! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:54'! deSelectOnReclick: aBoolean self model deSelectOnReclick: aBoolean! ! !MorphicNewListAdapter methodsFor: 'list protocol-events' stamp: 'BenjaminVanRyseghem 9/25/2013 18:53'! itemHasBeenSelected ^ [ :item | self model selectedItem: item ]! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:49'! headerClickedBlock ^ [ self headerClicked ]! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:47'! separatorAfter: item at: index ^ self model separatorAfter: item at: index! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:46'! getDisplayForItem: item at: index ^ self model getDisplayForItem: item at: index! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:46'! getRawItemAt: index ^ self model getRawItemAt: index! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:47'! keyStrokeAction: anEvent ^ self model keyStrokeAction: anEvent! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:47'! unselectOnChange ^ self model unselectOnChange! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:45'! allowToSelect ^ self model allowToSelect! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:46'! getHeaderTitle ^ self model getHeaderTitle! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:46'! getListSize ^ self model getListSize! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:46'! draggedItemAtIndex: anIndex ^ self model draggedItemAtIndex: anIndex! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:47'! isMultipleSelection ^ self model isMultipleSelection! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:58'! selectedIndex ^ self model selectedIndex! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 3/4/2014 17:25:06'! getMenu: shiftKeyState ^ (self model getMenu: shiftKeyState) ifNotNil: [ :menuModel | menuModel buildWithSpecAsPopup ]! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:47'! handlesDoubleClick ^ self model handlesDoubleClick! ! !MorphicNewListAdapter methodsFor: 'list protocol-events' stamp: 'BenjaminVanRyseghem 9/25/2013 18:52'! itemsHasBeenSelected ^ [ :selection | self model selectedItems: selection ]! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:45'! acceptDroppingMorph: aMorph atIndex: index event: event inMorph: source ^ self model acceptDroppingMorph: aMorph atIndex: index event: event inMorph: source! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:47'! iconMaxSize ^ self model iconMaxSize! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:47'! iconForItem: anItem at: anIndex ^ self model iconForItem: anItem at: anIndex! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:47'! hasHeader ^ self model hasHeader! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:46'! getItems ^ self model getItems! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:50'! headerClicked ^ self model headerClicked! ! !MorphicNewListAdapter methodsFor: 'list protocol-events' stamp: 'BenjaminVanRyseghem 9/25/2013 18:52'! indexHasBeenSelected ^ [:index | self model selectedIndex: index ]! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:46'! getHeaderHeight ^ self model getHeaderHeight! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:45'! deSelectOnReclick ^ self model deSelectOnReclick! ! !MorphicNewListAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 18:46'! doubleClick: event ^ self model doubleClick: event! ! !MorphicNewListAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 3/4/2014 17:25:06'! defaultSpec ^ { #NewList. #model:. #model. #hResizing:. #spaceFill. #vResizing:. #spaceFill. #deSelectOnReclick:. #(model deSelectOnReclick). #isMultipleSelection:. #(model isMultipleSelection). #unselectOnChange:. #(model unselectOnChange). #whenSelectedIndexChangedDo:. #(model indexHasBeenSelected). #whenSelectedIndexesChangedDo:. #(model indexesHasBeenSelected). #whenSelectedItemChangedDo:. #(model itemHasBeenSelected). #whenSelectedItemsChangedDo:. #(model itemsHasBeenSelected). #whenHeaderIsClickedDo:. #(model headerClickedBlock). #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #endOfInitialization. #setIndex:. #(model selectedIndex). #hasHeader:. #(model hasHeader).}! ! !MorphicRadioButtonAdapter commentStamp: ''! I am the adapter used to link a RadioButtonModel with a CheckboxMorph (which can also act as a radio button)! !MorphicRadioButtonAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:17'! state: aBoolean ^ self model state: aBoolean! ! !MorphicRadioButtonAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:16'! state ^ self model state! ! !MorphicRadioButtonAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:15'! label ^ self model label! ! !MorphicRadioButtonAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:16'! labelClickable ^ self model labelClickable! ! !MorphicRadioButtonAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 9/28/2013 20:17'! defaultSpec ^ {#CheckboxMorph. #on:selected:changeSelected:. #model. #state. #state:. #label:. { #model. #label }. #labelClickable:. { #model. #labelClickable}. #beRadioButton. #hResizing:. #shrinkWrap. #vResizing:. #shrinkWrap. #setBalloonText:. #(model help). #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor)}! ! !MorphicShortcutHandler commentStamp: ''! I am a null shortcut handler for morphic. I register myself as a tool to be replaced by somebody else who really wants to handle shortcuts.! !MorphicShortcutHandler methodsFor: 'shortcut-handling' stamp: 'GuillermoPolito 11/7/2013 16:47'! handleKeystroke: aKeystrokeEvent inMorph: aMorph "I do nothing. I'm a null object"! ! !MorphicShortcutHandler class methodsFor: 'tools' stamp: 'GuillermoPolito 11/7/2013 16:58'! registerToolsOn: aToolRegistry aToolRegistry register: self new as: #shortcuts! ! !MorphicSliderAdapter commentStamp: ''! I am the adapter used to bridget a SliderModel and a PluggableSliderMorph! !MorphicSliderAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:19'! value ^ self model value! ! !MorphicSliderAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:22'! value: aValue ^ self model value: aValue! ! !MorphicSliderAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:19'! label ^ self model label! ! !MorphicSliderAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:18'! absoluteValue ^ self model absoluteValue! ! !MorphicSliderAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:19'! max ^ self model max! ! !MorphicSliderAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:19'! quantum ^ self model quantum! ! !MorphicSliderAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:19'! min ^ self model min! ! !MorphicSliderAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 20:20'! absoluteValue: aFloat ^ self model absoluteValue: aFloat! ! !MorphicSliderAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2014 17:01'! defaultSpec ^ SpecLayout new type: #PluggableSliderMorph; send: #model: withArguments: #( model ); send: #getValueSelector: withArguments: #(value); send: #setValueSelector: withArguments: #( value: ); send: #value: withArguments: #(#(model absoluteValue)); send: #getLabelSelector: withArguments: #( label ); send: #max: withArguments: #(#(model max)); send: #min: withArguments: #(#(model min)); send: #quantum: withArguments: #(#(model quantum)); send: #borderWidth: withArguments: #(#(model borderWidth)); send: #borderColor: withArguments: #(#(model borderColor)); send:#setBalloonText: withArguments: #(#(model help)); send: #vResizing: withArguments: #(spaceFill); send: #hResizing: withArguments: #(spaceFill); yourself! ! !MorphicTabAdapter commentStamp: ''! I am the adapter used to bridge a TabModel and a Tab! !MorphicTabAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:11'! tabSelected ^ self model tabSelected! ! !MorphicTabAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 3/4/2014 17:25:06'! selected: aBoolean self widgetDo: [ :w | w selected: aBoolean ]! ! !MorphicTabAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:06'! menu ^ self model menu! ! !MorphicTabAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:06'! label ^ self model label! ! !MorphicTabAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:07'! retrievingBlock ^ self model retrievingBlock! ! !MorphicTabAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:05'! actionsBlock ^ [ self model actions ]! ! !MorphicTabAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 10/1/2013 14:14'! closeable ^ self model closeable! ! !MorphicTabAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:07'! contents ^ self model contents! ! !MorphicTabAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:06'! icon ^ self model icon! ! !MorphicTabAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 14:30'! defaultSpec ^ SpecLayout new type: #Tab; send: #model: withArguments: #(#(model)); send: #label: withArguments: #(#(model label)); send: #icon: withArguments: #(#(model icon)); send: #retrievingBlock: withArguments: #(#(model retrievingBlock)); send: #morph: withArguments: #(#(model contents)); send: #menu: withArguments: #(#(model menu)); send: #closeable: withArguments: #(#(model closeable)); send: #setActionsFrom: withArguments: #(#(model actionsBlock)); send: #when:send:to: withArguments: #(tabSelected tabSelected model); yourself! ! !MorphicTabManagerAdapter commentStamp: ''! I am the adpater used to bridge a TabManagerModel and a TabManager! !MorphicTabManagerAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 10/1/2013 14:25'! getTabs ^ [ self model tabs collect: [ :each | each buildWithSpec asWidget ] ]! ! !MorphicTabManagerAdapter methodsFor: 'spec protocol' stamp: 'MartinDias 2/25/2014 13:06'! addTab: aTab self widgetDo: [ :w | w addTab: aTab buildWithSpec ]! ! !MorphicTabManagerAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 10/1/2013 14:45'! selectedTab: aTab self model selectedTab: aTab! ! !MorphicTabManagerAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 14:45'! defaultSpec ^ SpecLayout new type: #TabManager; send: #model: withArguments: #(#(model)); send: #setTabs: withArguments: #(#(model getTabs)); send: #when:send:to: withArguments: #(tabSelected selectedTab: model); send: #vResizing: withArguments: #(spaceFill); send: #hResizing: withArguments: #(spaceFill); yourself! ! !MorphicTextAdapter commentStamp: ''! I am the adapter used to bridge a TextModel and a PluggableTextMorph! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:23'! behavior ^ self model behavior! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:18'! selectedBehavior ^ self model selectedBehavior! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:17'! doItContext ^ self model doItContext! ! !MorphicTextAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 22:36'! setSelectionFromModel: aSelection self widget ifNotNil: [:w | w setSelection: aSelection ]! ! !MorphicTextAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 14:58'! askBeforeDiscardingEdits: aBoolean self widgetDo: [ :w | w askBeforeDiscardingEdits: aBoolean ]! ! !MorphicTextAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 1/10/2014 12:16'! setHasUnacceptedEdits: aBoolean self widgetDo: [ :w | w basicHasUnacceptedEdits: aBoolean ]! ! !MorphicTextAdapter methodsFor: '*NodeNavigation' stamp: 'GiselaDecuzzi 11/7/2013 14:18'! isWorkspace ^false! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'NicolaiHess 2/15/2014 23:13'! setSelection: interval self model setSelectionInterval: interval! ! !MorphicTextAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 21:30'! classOrMetaClass: aClass self widget classOrMetaClass: aClass! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'EstebanLorenzano 10/11/2013 15:57'! font: aFont self widgetDo: [ :w | w font: aFont ]! ! !MorphicTextAdapter methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 9/28/2013 22:02'! isCodeCompletionAllowed ^ self model isCodeCompletionAllowed! ! !MorphicTextAdapter methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 9/28/2013 22:00'! selectedClassOrMetaClass ^ self behavior! ! !MorphicTextAdapter methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 9/28/2013 22:00'! guessTypeForName: aString ^nil! ! !MorphicTextAdapter methodsFor: 'as yet unclassified ' stamp: 'BenjaminVanRyseghem 1/5/2014 14:18'! hasEditingConflicts: aBoolean self widgetDo: [ :w | w hasEditingConflicts: aBoolean ]! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:18'! readSelection ^ self model readSelection! ! !MorphicTextAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 1/10/2014 12:32'! pendingText ^ self widgetDo: [ :w | w text ]! ! !MorphicTextAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 1/10/2014 12:32'! pendingText: aText self widgetDo: [ :w | w setText: aText. w hasUnacceptedEdits: true ]! ! !MorphicTextAdapter methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 9/28/2013 22:00'! receiverClass ^ self behavior! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:19'! shoutAboutToStyle: aMorph ^ self model isAboutToStyle! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 10/1/2013 13:29'! setScrollValue: aValue self widgetDo: [ :w | w scrollValue: aValue ]! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/27/2013 14:30'! autoAccept ^ self model autoAccept! ! !MorphicTextAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 1/5/2014 14:06'! notify: errorMessage at: position in: sourceCode self widgetDo: [ :w | w notify: errorMessage at: position in: sourceCode ]! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:17'! codePaneMenu: aMenu shifted: shifted ^ self model codePaneMenu: aMenu shifted: shifted ! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/27/2013 14:54'! wantsVisualFeedback ^ self model wantsVisualFeedback! ! !MorphicTextAdapter methodsFor: 'protocol-shout' stamp: 'BenjaminVanRyseghem 9/28/2013 22:03'! isAboutToStyle ^ self model isAboutToStyle! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:17'! getText ^ self model text! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:16'! accept: aText notifying: aNotifyier self model accept: aText notifying: aNotifyier! ! !MorphicTextAdapter methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 11/7/2013 12:34'! sugsContext ^SugsMorphicTextAdapterContext model: self! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:21'! clearUserEditFlag self model text: self getText. self changed: #clearUserEdits! ! !MorphicTextAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/23/2013 23:20'! accept self widgetDo:[ :w | w accept ]! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 21:17'! doItReceiver ^ self model doItReceiver! ! !MorphicTextAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 15:56'! selectAll self widgetDo: [ :w | w selectAll ]! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 10/1/2013 13:27'! scrollValueChanged: aValue self model scrollValue: aValue step! ! !MorphicTextAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/27/2013 14:58'! askBeforeDiscardingEdits ^ self model askBeforeDiscardingEdits! ! !MorphicTextAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 1/10/2014 12:16'! hasUnacceptedEdits: aBoolean self model hasUnacceptedEdits: aBoolean! ! !MorphicTextAdapter methodsFor: 'private-shout' stamp: 'BenjaminVanRyseghem 9/28/2013 22:00'! okToStyle ^ true! ! !MorphicTextAdapter class methodsFor: 'specs' stamp: 'NicolaiHess 2/15/2014 23:13'! defaultSpec ^ SpecLayout new type: #PluggableTextMorph; send: #color: withArguments: #(#(model color)); send: #classOrMetaClass: withArguments: {#(model behavior)}; send: #on:text:accept:readSelection:menu:setSelection: withArguments: #(model getText accept:notifying: readSelection codePaneMenu:shifted: setSelection:); send: #enabled: withArguments: #(#(model enabled)); send: #askBeforeDiscardingEdits: withArguments: #(#(model askBeforeDiscardingEdits)); send: #borderWidth: withArguments: #(#(model borderWidth)); send: #autoAccept: withArguments: #(#(model autoAccept)); send: #borderColor: withArguments: #(#(model borderColor)); send:#setBalloonText: withArguments: { #(model help)}; send: #dragEnabled: withArguments: #(#(model dragEnabled)); send: #dropEnabled: withArguments: #(#(model dropEnabled)); send: #registerScrollChanges: withArguments: #(scrollValueChanged:); send: #vResizing: withArguments: #(spaceFill); send: #hResizing: withArguments: #(spaceFill); yourself! ! !MorphicTextInputFieldAdapter commentStamp: ''! I am the adapter used to bridge a TextInputFieldModel and a PluggableTextFieldMorph! !MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:07'! ghostText: aText ^ self model ghostText: aText! ! !MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:06'! entryCompletion ^ self model entryCompletion! ! !MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:07'! encrypted ^ self model encrypted! ! !MorphicTextInputFieldAdapter methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 9/28/2013 22:07'! isCodeCompletionAllowed ^ false! ! !MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:05'! accept: aText self model accept: aText! ! !MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:07'! acceptOnCR ^ self model acceptOnCR! ! !MorphicTextInputFieldAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:06'! ghostText ^ self model ghostText! ! !MorphicTextInputFieldAdapter methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/4/2014 18:09'! adapt: aModel super adapt: aModel. aModel whenBuiltDo: [ :w | w widget color: Color white ]! ! !MorphicTextInputFieldAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 14:39'! encrypted: aBoolean self widgetDo: [ :w | w encrypted: aBoolean. w changed ]! ! !MorphicTextInputFieldAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 14:50'! defaultSpec ^ {#PluggableTextFieldMorph. #convertTo:. String. #on:text:accept:readSelection:menu:. #model. #getText. #accept:. nil. nil. #entryCompletion:. { #model. #entryCompletion }. #autoAccept:. { #model. #autoAccept }. #ghostText:. { #model. #ghostText }. #enabled:. { #model. #enabled }. #encrypted:. { #model. #encrypted }. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #setBalloonText:. { #model . #help}. #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #hResizing:. #spaceFill. #vResizing:. #spaceFill. #acceptOnCR:. { #model. #acceptOnCR }. #hideScrollBarsIndefinitely.}! ! !MorphicTickingWindowAdapter commentStamp: 'StephaneDucasse 3/7/2014 10:55'! I am the adapter used to bridge a TickingWindowModel and a TickingSpecWindow! !MorphicTickingWindowAdapter methodsFor: 'stepping' stamp: 'DamienCassou 4/4/2014 14:54'! step self model step! ! !MorphicTickingWindowAdapter class methodsFor: 'specs' stamp: 'StephaneDucasse 3/7/2014 11:16'! defaultSpec ^ #( TickingSpecWindow model: model isResizeable: #(model isResizeable ))! ! !MorphicTransform commentStamp: ''! This class implements simple translation, scaling and rotation for points, as well as inverse transformations. These transformations are used in TransformMorphs (clipping scrollers) and TransformationMorphs (general flex-morph wrappers) to map, eg, global mouse coords into local coords, and to invert, eg, local damage rectangles into global damage rectangles.! !MorphicTransform methodsFor: 'accessing' stamp: ''! withScale: a "Return a copy of me with a different Scale" ^ self copy setScale: a! ! !MorphicTransform methodsFor: 'accessing' stamp: ''! offset ^ offset ! ! !MorphicTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:32'! localPointToGlobal: aPoint "Transform aPoint from global coordinates into local coordinates" ^self invert: aPoint! ! !MorphicTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:10'! composedWith: aTransform "Return a new transform that has the effect of transforming points first by the receiver and then by the argument." self isIdentity ifTrue: [^ aTransform]. aTransform isIdentity ifTrue: [^ self]. ^ CompositeTransform new globalTransform: self localTransform: aTransform! ! !MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:57'! isPureTranslation "Return true if the receiver specifies no rotation or scaling." ^ angle = 0.0 and: [scale = 1.0] ! ! !MorphicTransform methodsFor: 'composing' stamp: 'nk 3/9/2001 13:55'! composedWithLocal: aTransform aTransform isIdentity ifTrue:[^self]. self isIdentity ifTrue:[^aTransform]. aTransform isMorphicTransform ifFalse:[^super composedWithLocal: aTransform]. self isPureTranslation ifTrue:[ ^aTransform withOffset: aTransform offset + self offset]. aTransform isPureTranslation ifTrue:[ ^self withOffset: (self localPointToGlobal: aTransform offset negated) negated]. ^super composedWithLocal: aTransform.! ! !MorphicTransform methodsFor: 'accessing' stamp: ''! scale ^ scale! ! !MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setOffset: aPoint offset := aPoint! ! !MorphicTransform methodsFor: 'accessing' stamp: ''! withAngle: a "Return a copy of me with a different Angle" ^ self copy setAngle: a! ! !MorphicTransform methodsFor: 'printing' stamp: 'ar 5/19/1999 18:21'! printOn: aStream super printOn: aStream. aStream nextPut:$(; nextPutAll:'angle = '; print: angle; nextPutAll:'; scale = '; print: scale; nextPutAll:'; offset = '; print: offset; nextPut:$).! ! !MorphicTransform methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! transform: aPoint "Transform the given point from global to local coordinates." | p2 p3 | self isPureTranslation ifTrue: [ ^ aPoint + offset ]. p2 := aPoint + offset. p3 := (p2 x * angle cos - (p2 y * angle sin)) @ (p2 y * angle cos + (p2 x * angle sin)) / scale. ^ p3! ! !MorphicTransform methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:33'! inverseTransformation "Return the inverse transformation of the receiver" ^MorphicTransform offset: (self transform: 0@0) - (self transform: offset) angle: angle negated scale: scale reciprocal! ! !MorphicTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:13'! globalPointToLocal: aPoint "Transform aPoint from global coordinates into local coordinates" ^self transform: aPoint! ! !MorphicTransform methodsFor: 'transformations' stamp: 'di 10/2/1998 08:54'! invertRect: aRectangle self error: 'method name changed to emphasize enclosing bounds'. ^ self invertBoundsRect: aRectangle! ! !MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setOffset: aPoint angle: a scale: s offset := aPoint. angle := a. scale := s! ! !MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:57'! isIdentity "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself." ^ self isPureTranslation and: [offset = (0@0)] ! ! !MorphicTransform methodsFor: 'accessing' stamp: ''! angle ^ angle! ! !MorphicTransform methodsFor: 'accessing' stamp: ''! withOffset: a "Return a copy of me with a different Offset" ^ self copy setOffset: a! ! !MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setScale: aFloat scale := aFloat! ! !MorphicTransform methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! invert: aPoint "Transform the given point from local to global coordinates." | p3 p2 | self isPureTranslation ifTrue: [ ^ aPoint - offset ]. p3 := aPoint * scale. p2 := (p3 x * angle cos + (p3 y * angle sin)) @ (p3 y * angle cos - (p3 x * angle sin)). ^ p2 - offset! ! !MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 19:51'! isMorphicTransform ^true! ! !MorphicTransform methodsFor: 'initialize' stamp: 'lr 7/4/2009 10:42'! setIdentiy scale := 1.0. offset := 0 @ 0. angle := 0.0! ! !MorphicTransform methodsFor: 'converting' stamp: 'di 10/26/1999 17:03'! asMorphicTransform ^ self! ! !MorphicTransform methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! invertBoundsRect: aRectangle "Return a rectangle whose coordinates have been transformed from local back to global coordinates. NOTE: if the transformation is not just a translation, then it will compute the bounding box in global coordinates." | outerRect | self isPureTranslation ifTrue: [ ^ (self invert: aRectangle topLeft) corner: (self invert: aRectangle bottomRight) ] ifFalse: [ outerRect := Rectangle encompassing: (aRectangle innerCorners collect: [ :p | self invert: p ]). "Following asymmetry due to likely subsequent truncation" ^ outerRect topLeft - (1 @ 1) corner: outerRect bottomRight + (2 @ 2) ]! ! !MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setAngle: aFloat angle := aFloat! ! !MorphicTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:14'! asMatrixTransform2x3 ^((MatrixTransform2x3 withRotation: angle radiansToDegrees negated) composedWithLocal: (MatrixTransform2x3 withScale: scale)) offset: offset negated! ! !MorphicTransform methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! transformBoundsRect: aRectangle "Return a rectangle whose coordinates have been transformed from global to local coordinates. NOTE: if the transformation is not just a translation, then it will compute the bounding box in global coordinates." | outerRect | self isPureTranslation ifTrue: [ ^ (self transform: aRectangle topLeft) corner: (self transform: aRectangle bottomRight) ] ifFalse: [ outerRect := Rectangle encompassing: (aRectangle innerCorners collect: [ :p | self transform: p ]). "Following asymmetry due to likely subsequent truncation" ^ outerRect topLeft - (1 @ 1) corner: outerRect bottomRight + (2 @ 2) ]! ! !MorphicTransform class methodsFor: 'instance creation' stamp: ''! identity ^ self offset: 0@0 angle: 0.0 scale: 1.0! ! !MorphicTransform class methodsFor: 'instance creation' stamp: ''! new ^ self offset: 0@0 ! ! !MorphicTransform class methodsFor: 'instance creation' stamp: ''! offset: aPoint angle: a scale: s ^ self basicNew setOffset: aPoint angle: a scale: s! ! !MorphicTransform class methodsFor: 'instance creation' stamp: ''! offset: aPoint ^ self offset: aPoint angle: 0.0 scale: 1.0! ! !MorphicTreeAdapter commentStamp: ''! I am the adapter used to bridge a TreeModel and a MorphTreeMorph! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! oddRowColor ^ self model oddRowColor! ! !MorphicTreeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/8/2013 11:58'! expandAll self treeModel expandAll! ! !MorphicTreeAdapter methodsFor: 'drag and drop - private' stamp: 'BenjaminVanRyseghem 9/28/2013 23:22'! acceptDroppingMorph: draggedMorph event: event inMorph: source | item | item := self widget ifNil: [ 0 ] ifNotNil: [:w | w scrollerSubMorphFromPoint: event position ]. ^ self acceptDropBlock valueWithEnoughArguments: { draggedMorph. event. source. item }! ! !MorphicTreeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 11:49'! filterWith: aFilter self widgetDo: [ :w || nodes | nodes := w model rootNodes. nodes do: [:r | r nodeModel updateAccordingTo: aFilter]. self removeRootsSuchAs: [:n | (aFilter keepTreeNode: n) not and: [n isEmpty]]. self changed: #rootNodes ].! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! keyStroke: aKeyStroke ^ self model keyStroke: aKeyStroke! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! oddRowColor: aColor ^ self model oddRowColor: aColor! ! !MorphicTreeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/23/2013 21:58'! collapseAll self treeModel collapseAll! ! !MorphicTreeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/2/2013 18:01'! columns: newColumns self widgetDo: [ :w || columns | columns := newColumns collect: [ :each | each buildWithSpec ]. w columns: columns. w resizerChanged. w updateList ]! ! !MorphicTreeAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/8/2013 11:59'! rootNodeHolder ^ self model rootNodeHolder! ! !MorphicTreeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/23/2013 21:42'! onMorphTreeSelectionChanged: ann | items | items := (ann selection ifNil: [ #() ] ifNotNil: [:selection | selection selectedNodes ]). items := items collect: [ :each | each nodeModel ]. self model selectedItems: items! ! !MorphicTreeAdapter methodsFor: 'reflective operations' stamp: 'BenjaminVanRyseghem 9/28/2013 23:04'! doesNotUnderstand: aMessage (self treeModel respondsTo: aMessage selector) ifFalse: [ ^ super doesNotUnderstand: aMessage ]. ^ self treeModel perform: aMessage selector withArguments: aMessage arguments! ! !MorphicTreeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 15:37'! expandRoots self treeModel expandRoots! ! !MorphicTreeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 14:59'! selectAdd self widgetDo: [ :w | w selectAll ]! ! !MorphicTreeAdapter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/8/2013 11:58'! initialize super initialize. treeModel := SpecTreeModel model: self. treeModel announcer on: MorphTreeSelectionChanged send: #onMorphTreeSelectionChanged: to: self.! ! !MorphicTreeAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 23:03'! updateTree self treeModel resetRootNodes. self treeModel changed: #rootNodes.! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! evenRowColor ^ self model evenRowColor! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:42'! iconBlock ^ [:each | self iconFor: each ]! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! autoDeselection ^ self model autoDeselection! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! doubleClick ^ self model doubleClick! ! !MorphicTreeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/2/2013 19:50'! removeRootsSuchAs: aBlock self widgetDo: [ :w | w model rootNodes removeAllSuchThat: [ :node | aBlock value: node nodeModel ] ]! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 3/4/2014 17:25:06'! menu: aMenu shifted: aBoolean ^ (self model menu: aMenu shifted: aBoolean) ifNotNil: [ :menuModel | menuModel buildWithSpecAsPopup ]! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! columnInset ^ self model columnInset! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! resizerWidth ^ self model resizerWidth! ! !MorphicTreeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 9/28/2013 22:59'! setRoots: aCollection treeModel rootItems: aCollection! ! !MorphicTreeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 15:21'! isCheckList: aBoolean self widgetDo: [ :w | w isCheckList: aBoolean ]! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! rowInset ^ self model rowInset! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 23:16'! roots ^ self model roots! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 23:26'! childrenFor: aNode ^ self model childrenFor: aNode! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! autoMultiSelection ^ self model autoMultiSelection! ! !MorphicTreeAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/28/2013 22:52'! treeModel ^ treeModel! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/8/2013 11:58'! columns ^ self model columns collect: [ :each | each buildWithSpec ]! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/21/2013 15:19'! rootNodeFromItem: item | node | node := item isTreeNodeModel ifTrue: [ item ] ifFalse: [ self rootNodeHolder cull: item ]. node container: self model. ^ node buildWithSpec! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! isCheckList ^ self model isCheckList! ! !MorphicTreeAdapter methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 9/28/2013 22:54'! changed: aSymbol treeModel changed: aSymbol! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! iconFor: aNode ^ self model iconFor: aNode! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/26/2013 18:16'! selectOnlyLastHighlighted ^ self model selectOnlyLastHighlighted! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! multiSelection ^ self model multiSelection! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 23:25'! wrapItem: anItem ^ self model wrapItem: anItem! ! !MorphicTreeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/28/2013 22:40'! preferedPaneColor ^ self model preferedPaneColor! ! !MorphicTreeAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/26/2013 18:16'! defaultSpec ^ {#MorphTreeMorph. #model:. #(model treeModel). #dragEnabled:. #(model dragEnabled). #dropEnabled:. #(model dropEnabled). #initializeColumsFrom:. #(model). #hResizing:. #spaceFill. #vResizing:. #spaceFill. #autoDeselection:. #(model autoDeselection). #resizerWidth:. #(model resizerWidth). #columnInset:. #(model columnInset). #iconBlock:. #(model iconBlock). #rowInset:. #(model rowInset). #keystrokeActionSelector:. #keyStroke:. #preferedPaneColor:. #(model preferedPaneColor). #multiSelection:. #(model multiSelection). #autoMultiSelection:. #(model autoMultiSelection). #removeOnlyLastSelected:. #(model #selectOnlyLastHighlighted). #isCheckList:. #(model isCheckList). #doubleClickSelector:. #doubleClick. #getMenuSelector:. #menu:shifted:. #rowColorForEven:odd:. #(model evenRowColor). #(model oddRowColor). #buildContents }! ! !MorphicTreeColumnAdapter commentStamp: ''! I am the bridge between a TreeColumnModel and a MorphTreeColumn. Ialso add support for on the fly refresh! !MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 17:18'! performHeaderAction self headerAction cull: self model cull: self! ! !MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 19:34'! performHeaderActionSelector ^ self headerAction ifNil: [ nil ] ifNotNil: [ #performHeaderAction ]! ! !MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 17:03'! headerLabel ^ self model headerLabel! ! !MorphicTreeColumnAdapter methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 11/2/2013 17:45'! update: aSymbol aSymbol == #displayBlockChanged ifTrue: [ ^ self displayBlockChanged ]. aSymbol == #resizableChanged ifTrue: [ ^ self resizableChanged ]. aSymbol == #headerLabelChanged ifTrue: [ ^ self headerLabelChanged ]. aSymbol == #headerFontChanged ifTrue: [ ^ self headerFontChanged ]. aSymbol == #headerIconChanged ifTrue: [ ^ self headerIconChanged ]. ^ super update: aSymbol! ! !MorphicTreeColumnAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/2/2013 17:52'! headerLabelChanged self widgetDo: [ :w | w header label: self headerLabel. w container resizerChanged ]! ! !MorphicTreeColumnAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/2/2013 17:52'! headerFontChanged self widgetDo: [ :w | w header label: self headerLabel font: self headerFont. w container resizerChanged ]! ! !MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 16:54'! resizable ^ self model resizable! ! !MorphicTreeColumnAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/8/2013 20:18'! headerIconChanged self widgetDo: [ :w | self headerIcon ifNil: [ w header removeIcon ] ifNotNil: [ w header icon: (ImageMorph new form: self headerIcon) ] ]! ! !MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 16:54'! argumentBlock ^ [ Array with: self model ]! ! !MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 16:57'! headerIcon ^ self model headerIcon! ! !MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 16:57'! headerFont ^ self model headerFont! ! !MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 16:57'! headerAction ^ self model headerAction! ! !MorphicTreeColumnAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/2/2013 18:18'! displayBlockChanged self widgetDo: [ :w | w rowMorphGetSelector: self displayBlock. w container updateList ]! ! !MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 17:23'! displayBlock ^ self model displayBlock! ! !MorphicTreeColumnAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 16:55'! initialWidth ^ self model initialWidth! ! !MorphicTreeColumnAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/2/2013 17:53'! resizableChanged self widgetDo: [ :w | w resizable: self resizable ]! ! !MorphicTreeColumnAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 11/2/2013 19:34'! defaultSpec ^ #(SpecTreeColumn resizable: #(model resizable) startWidth: #(model initialWidth) setHeaderButtonLabel:font:icon:target:actionSelector: #(model headerLabel) #(model headerFont) #(model headerIcon) model #(model performHeaderActionSelector) rowMorphGetSelector: #(model displayBlock))! ! !MorphicTreeNodeAdapter commentStamp: ''! I am the bridget between a TreeNodeModel and a SpecTreeNodeModel! !MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 18:53'! container ^ self model container! ! !MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/22/2013 15:43'! hasContentToShow ^ self model hasContentToShow! ! !MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 18:55'! icon ^ self model icon! ! !MorphicTreeNodeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/22/2013 13:25'! selected: aBoolean aBoolean ifTrue: [ self select ] ifFalse: [ self deselect ]! ! !MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 12/3/2013 10:59'! itemBlock ^ [ self item ]! ! !MorphicTreeNodeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/21/2013 12:23'! updateAccordingTo: aFilter self widgetDo: [ :w | w contents do: [ :n | n nodeModel updateAccordingTo: aFilter ]. w contents removeAllSuchThat: [ :n | (aFilter keepTreeNode: n nodeModel) not and: [ n nodeModel isEmpty ] ] ]! ! !MorphicTreeNodeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/24/2013 13:39'! isExpanded: aBoolean ! ! !MorphicTreeNodeAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/30/2013 21:36'! deselect self widgetDo: [ :w | w changed: #deselect. w model selectionChanged. w dependents do: [ :e | e changed ] ]! ! !MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 3/4/2014 17:25:06'! hasChildrenBlock ^ self model hasChildren! ! !MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/24/2013 13:22'! selected ^ self model selected! ! !MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 11/2/2013 18:53'! item ^ self model content! ! !MorphicTreeNodeAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/24/2013 13:34'! buildWidget "This is done this way to prevent the recursive building of the model" ^ super buildWidget model: self container; nodeModel: self model; yourself! ! !MorphicTreeNodeAdapter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/30/2013 21:35'! select self widgetDo: [ :w | w changed: #select. w model selectionChanged. w dependents do: [ :e | e changed ] ]! ! !MorphicTreeNodeAdapter methodsFor: 'widget API' stamp: 'ChristopheDemarey 11/20/2013 14:40'! childrenBlock ^ [ self model buildChildren ]! ! !MorphicTreeNodeAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 11/25/2013 16:29'! takeHighlight self widgetDo: [ :w | w changed: #takeHighlight ]! ! !MorphicTreeNodeAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 3/4/2014 17:25:06'! defaultSpec ^ #(SpecTreeNodeModel setItemFromBlock:#(model itemBlock) icon: #(model icon) setChildren: #(model childrenBlock) hasContents: #(model hasChildrenBlock))! ! !MorphicUIBugTest commentStamp: 'wiz 1/3/2007 13:57'! A MorphicUIBugTest is a class for testing the shortcomings and repairs of the MorphicUI manager. . Instance Variables cases: 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. ! !MorphicUIBugTest methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 1/26/2011 13:54'! testOpenWorkspace "self new testOpenWorkspace" "MorphicUIBugTest run: #testOpenWorkspace" | window myLabel foundWindow myModel | myLabel := 'Workspace from ', 'SUnit test' . foundWindow := self findWindowInWorldLabeled: myLabel . self assert: ( foundWindow isNil ) . [window := UIManager default edit: '"MorphicUIBugTest run: #openWorkspaceTest"' label: myLabel] on: ErrorNonInteractive do: [:e | ^self]. window = window. foundWindow := self findWindowInWorldLabeled: myLabel . cases := Array with: foundWindow . "For teardown." myModel := (foundWindow submorphs detect: [ :each | each isMorphicModel ] ) . self assert: ( myModel model class == Workspace ) . self assert: ( foundWindow model class == Workspace ) . foundWindow delete .! ! !MorphicUIBugTest methodsFor: 'as yet unclassified' stamp: 'wiz 1/3/2007 12:16'! findWindowInWorldLabeled: aLabel ^ World submorphs detect: [ :each | each class == SystemWindow and: [ each label = aLabel ] ] ifNone: [ nil ] .! ! !MorphicUIBugTest methodsFor: 'as yet unclassified' stamp: 'wiz 1/3/2007 11:25'! tearDown "default. tests will add morphs to list. Teardown will delete." cases do: [ :each | each delete ] .! ! !MorphicUIBugTest methodsFor: 'as yet unclassified' stamp: 'wiz 6/11/2007 20:34'! setUp "default. tests will add morphs to list. Teardown will delete." cases := #() .! ! !MorphicUIManager commentStamp: 'StephaneDucasse 6/5/2011 22:19'! The Morphic ui manager. I was packaged in toolbuilder and I may change in the future. For the moment, the goal is to unload toolbuilder. ! !MorphicUIManager methodsFor: 'services' stamp: ''! questionWithoutCancel: aStringOrText "Open a question dialog." ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newWindowFor: aModel title: titleString "Answer a new window morph." ^self theme newWindowIn: self for: aModel title: titleString! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'JuanVuletich 10/26/2010 18:17'! menuClass ^MenuMorph! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newColorChooserFor: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText "Answer a color chooser with the given selectors." ^self theme newColorChooserIn: self for: aModel getColor: getSel setColor: setSel getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newGroupbox "Answer a plain groupbox." ^self theme newGroupboxIn: self! ! !MorphicUIManager methodsFor: 'services' stamp: ''! deny: aStringOrText "Open a denial dialog." ^self deny: aStringOrText title: 'Access Denied' translated! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newGroupbox: aString "Answer a groupbox with the given label." ^self theme newGroupboxIn: self label: aString! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel getEnabled: enabledSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: 0 max: 1 quantum: nil getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts path: path "Answer the result of a file open dialog with the given title, extensions to show and path." ^self fileOpen: title extensions: exts path: path preview: nil! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel labelForm: aForm help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: (AlphaImageMorph new image: aForm) help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newPanel "Answer a new panel." ^self theme newPanelIn: self! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'SeanDeNigris 6/20/2012 23:31'! informUserDuring: aBlock "Display a message as progress during execution of the given block." "UIManager default informUserDuring: [:bar| #('one' 'two' 'three') do: [:info| bar label: info. 1 to: 100 do: [:v | bar current: v. (Delay forMilliseconds: 20) wait]]]" self displayProgress: '' from: 1 to: 100 during: [:bar | aBlock value: bar]! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'StephaneDucasse 11/6/2011 12:50'! openComparisonFrom: targetMethodSource to: originalMethodSource belongingTo: aClass from: aChange labeled: aLabel inWindowLabeled: aWindowLabel | diffMorph diffBuilder difference win | PolymorphSystemSettings usePolymorphDiffMorph ifTrue: [ ^ self openPolymorphComparisonFrom: originalMethodSource to: targetMethodSource belongingTo: aClass from: aChange labeled: aLabel inWindowLabeled: aWindowLabel ]. diffBuilder := TextDiffBuilder from: originalMethodSource to: targetMethodSource. difference := diffBuilder buildDisplayPatch. win := Smalltalk tools workspace openContents: difference. win label: aLabel. ! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector help: helpText "Answer a list for the given model." ^self newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: nil help: helpText! ! !MorphicUIManager methodsFor: 'services' stamp: ''! centeredAlert: aStringOrText title: aString configure: aBlock "Open an alert dialog. Configure the dialog with the 1 argument block before opening modally." ^self theme centeredAlertIn: self text: aStringOrText title: aString configure: aBlock! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newMenuFor: aModel "Answer a new menu." ^self theme newMenuIn: self for: aModel! ! !MorphicUIManager methodsFor: 'private' stamp: 'CamilloBruni 9/14/2013 00:00'! activate activeTranscript ifNil: [ ThreadSafeTranscript install ] ifNotNil: [ Transcript := activeTranscript ]. SystemProgressMorph enable.! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'MarcusDenker 12/2/2011 16:44'! lowSpaceWatcherDefaultAction: preemptedProcess self interruptName: 'Space is low' preemptedProcess: preemptedProcess! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a checkbox (radio button appearance) with the given label." ^self theme newRadioButtonIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newAlphaImage: aForm help: helpText "Answer an alpha image morph." ^self theme newAlphaImageIn: self image: aForm help: helpText! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'StephaneDucasse 7/17/2010 13:11'! chooseFrom: aList lines: linesArray title: aString "Choose an item from the given list. Answer the index of the selected item." ^(self chooseFrom: aList values: nil lines: linesArray title: aString) ifNil: [0]! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newStack: controls "Answer a morph laid out with a stack of controls." ^self theme newStackIn: self for: controls! ! !MorphicUIManager methodsFor: 'services' stamp: ''! chooseFont "Answer the result of a font selector dialog." ^self chooseFont: nil! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 9/20/2013 20:22'! explorer: anObjectExplorer withLabel: label ^ anObjectExplorer window setLabel: label; yourself ! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector "Answer a text editor for the given model." ^self theme newTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: nil! ! !MorphicUIManager methodsFor: 'services' stamp: ''! chooseDirectory: title path: path "Answer the result of a file dialog with the given title, answer a directory." ^self theme chooseDirectoryIn: self title: title path: path! ! !MorphicUIManager methodsFor: 'accessing' stamp: 'pavel.krivanek 11/21/2008 17:30'! interactiveParser "Answer the value of interactiveParser" ^ interactiveParser! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText! ! !MorphicUIManager methodsFor: 'events' stamp: 'Pavel.Krivanek 10/28/2008 11:22'! onEventSensorStartup: anEventSensor anEventSensor flushAllButDandDEvents! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: nil label: stringOrText help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel label: stringOrText help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newPluggableDialogWindow: title for: contentMorph "Answer a new pluggable dialog with the given content." ^self theme newPluggableDialogWindowIn: self title: title for: contentMorph! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'GaryChambers 12/6/2011 10:17'! request: aStringOrText initialAnswer: defaultAnswer title: aTitle "Create an instance of me whose question is queryString with the given initial answer. Answer the string the user accepts. The title serves for the window that is opened Answer the empty string if the user cancels. Allow for interception with a ProvideAnswerNotification handler." |modalMorph| (ProvideAnswerNotification signal: aStringOrText) ifNotNil: [:answer | ^answer == #default ifTrue: [defaultAnswer] ifFalse: [answer]]. modalMorph := self modalMorph. ^(modalMorph theme textEntryIn: modalMorph text: aStringOrText title: aTitle entryText: defaultAnswer)! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newGroupbox: aString for: control "Answer a groupbox with the given label and control." ^self theme newGroupboxIn: self label: aString for: control! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'ui process' stamp: 'MarcusDenker 12/2/2011 16:31'! terminateUIProcess UIProcess suspend; terminate. UIProcess := nil "?"! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText "Answer an editable drop list for the given model." ^self theme newEditableDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: aClass default: defaultValue ghostText: ghostText getEnabled: enabledSel useIndex: useIndex help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText "Answer a morph drop list for the given model." ^self newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: nil useIndex: true help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel getLabel: labelSel help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText "Answer a morph drop list for the given model." ^self newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: true help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText "Answer a drop list for the given model." ^self theme newDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText! ! !MorphicUIManager methodsFor: 'services' stamp: ''! chooseFont: aFont "Answer the result of a font selector dialog with the given initial font." ^self theme chooseFontIn: self title: 'Font Selector' translated font: aFont! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newVerticalSeparator "Answer a vertical separator." ^self theme newVerticalSeparatorIn: self! ! !MorphicUIManager methodsFor: 'services' stamp: ''! proceed: aStringOrText "Open a proceed dialog." ^self proceed: aStringOrText title: 'Proceed' translated! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'GaryChambers 12/6/2011 10:14'! chooseFullFileNameMatching: patterns label: label "Let the user choose a file matching the given patterns" |modalMorph| modalMorph := self modalMorph. ^modalMorph theme chooseFullFileNameIn: modalMorph title: (label ifNil: ['Choose File' translated]) patterns: patterns path: nil preview: false! ! !MorphicUIManager methodsFor: 'services' stamp: ''! deny: aStringOrText title: aString "Open a denial dialog." ^self theme denyIn: self text: aStringOrText title: aString! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newHSVASelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVASelectorIn: self color: aColor help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newButtonLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new button text label." ^self theme newButtonLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !MorphicUIManager methodsFor: 'services' stamp: ''! alert: aStringOrText title: aString configure: aBlock "Open an alert dialog. Configure the dialog with the 1 argument block before opening modally." ^self theme alertIn: self text: aStringOrText title: aString configure: aBlock! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newCancelButton "Answer a new cancel button." ^self newCancelButtonFor: self! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'AlainPlantec 11/26/2010 10:19'! request: aStringOrText initialAnswer: defaultAnswer entryCompletion: anEntryCompletion ^ self request: aStringOrText initialAnswer: defaultAnswer title: 'Information Required' translated entryCompletion: anEntryCompletion ! ! !MorphicUIManager methodsFor: 'global state' stamp: 'FernandoOlivero 5/1/2011 11:40'! world ^ ActiveWorld ! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newString: aStringOrText style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: aStyle! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newHueSelector: aModel getHue: getSel setHue: setSel help: helpText "Answer a hue selector with the given selectors." ^self theme newHueSelectorIn: self for: aModel getHue: getSel setHue: setSel help: helpText! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'MarcusDenker 11/27/2012 12:21'! openDebuggerOn: process context: context label: title contents: contentsStringOrNil fullView: bool "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." | errorWasInUIProcess debugger | errorWasInUIProcess := self spawnNewProcessIfThisIsUI: process. [Smalltalk tools debugger logDebuggerStackToFile ifTrue: [Smalltalk logError: title inContext: context ]] on: Error do: []. debugger := Smalltalk tools debugger new. self defer: [[ debugger process: process controller: nil context: context. "schedule debugger in deferred UI message to address redraw problems after opening a debugger e.g. from the testrunner." "self defer: [" bool ifTrue: [debugger openFullNoSuspendLabel: title] ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]. debugger errorWasInUIProcess: errorWasInUIProcess.] on: Error do: [:ex | Smalltalk tools debugger primitiveError: 'Orginal error: ' , title asString , '. Smalltalk tools debugger error: ' , ([ex description] on: Error do: ['a ' , ex class printString]) , ':']]. process suspend. ^ debugger! ! !MorphicUIManager methodsFor: 'services' stamp: 'FernandoOlivero 4/12/2011 09:56'! chooseOrRequestFrom: labelList values: valueList lines: linesArray title: aString "Choose an item from the given list. Answer the value selected of the selected item or the new string entered." ^ self theme chooseOrRequestIn: self modalMorph title: aString labels: labelList values: valueList lines: linesArray! ! !MorphicUIManager methodsFor: 'services' stamp: 'GaryChambers 8/23/2010 12:13'! 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." ^self confirm: queryString trueChoice: trueChoice falseChoice: falseChoice cancelChoice: nil default: nil! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'MarcusDenker 4/29/2011 00:36'! onFontsChanged StringMorph allSubInstancesDo: [ :s | s layoutChanged ]. TextMorph allSubInstancesDo: [ :s | s layoutChanged ]. SystemWindow allInstancesDo: [ :w | [ w update: #relabel ] on: Error do: [ :ex | ] ]. World ifNotNil: [ :w | w changed ].! ! !MorphicUIManager methodsFor: 'accessing' stamp: 'FernandoOlivero 5/9/2011 13:14'! preferredCornerStyle ^ self theme preferredCornerStyle! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newEmbeddedMenu "Answer a new menu." ^self theme newEmbeddedMenuIn: self for: self! ! !MorphicUIManager methodsFor: 'events' stamp: 'BernardoContreras 1/22/2012 16:49'! onDebug: process context: context title: title full: bool | topCtxt | topCtxt := process isActiveProcess ifTrue: [thisContext] ifFalse: [process suspendedContext]. (topCtxt hasContext: context) ifFalse: [^ self error: 'context not in process']. Smalltalk tools debugger openOn: process context: context label: title contents: nil fullView: bool.! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 2/24/2007 20:14'! fileExistsDefaultAction: anException ^ anException fileClass fileExistsUserHandling: anException fileName! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: 0 max: 1 quantum: nil getEnabled: nil help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newButtonFor: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText "Answer a new button." ^self theme newButtonIn: self for: aModel getState: stateSel action: actionSel arguments: args getEnabled: enabledSel getLabel: labelSel help: helpText! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'SeanDeNigris 1/23/2014 00:06'! merge: merger informing: aString | mergeMorph window | mergeMorph := PSMCMergeMorph forMerger: merger. mergeMorph fromDescription: 'Working copy' translated; toDescription: aString. window := mergeMorph newWindow title: aString; yourself. self modalMorph openModal: window. ^ mergeMorph merged! ! !MorphicUIManager methodsFor: 'services' stamp: ''! fileOpen: title "Answer the result of a file open dialog with the given title." ^self fileOpen: title extensions: nil! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion ! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newTabGroup: labelsAndPages "Answer a tab group with the given tab labels associated with pages." ^self theme newTabGroupIn: self for: labelsAndPages! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newNoButtonFor: aModel "Answer a new No button." ^self theme newNoButtonIn: self for: aModel! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'GaryChambers 12/6/2011 10:18'! request: aStringOrText initialAnswer: defaultAnswer title: aTitle entryCompletion: anEntryCompletion "Create an instance of me whose question is queryString with the given initial answer. Answer the string the user accepts. The title serves for the window that is opened Answer the empty string if the user cancels. Allow for interception with a ProvideAnswerNotification handler." |modalMorph| (ProvideAnswerNotification signal: aStringOrText) ifNotNil: [:answer | ^answer == #default ifTrue: [defaultAnswer] ifFalse: [answer]]. modalMorph := self modalMorph. ^(modalMorph theme textEntryIn: modalMorph text: aStringOrText title: aTitle entryText: defaultAnswer entryCompletion: anEntryCompletion)! ! !MorphicUIManager methodsFor: 'services' stamp: ''! chooseDropList: aStringOrText list: aList "Open a drop list chooser dialog." ^self chooseDropList: aStringOrText title: 'Choose' translated list: aList! ! !MorphicUIManager methodsFor: 'services' stamp: ''! textEntry: aStringOrText title: aString entryText: defaultEntryText "Open a text entry dialog." ^self theme textEntryIn: self text: aStringOrText title: aString entryText: defaultEntryText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newImage: aForm "Answer a new image." ^self theme newImageIn: self form: aForm! ! !MorphicUIManager methodsFor: 'services' stamp: ''! alert: aStringOrText title: aString "Open an alert dialog." ^self alert: aStringOrText title: aString configure: [:d | ]! ! !MorphicUIManager methodsFor: 'services' stamp: ''! alert: aStringOrText "Open an alert dialog." ^self alert: aStringOrText title: 'Alert' translated! ! !MorphicUIManager methodsFor: 'services' stamp: ''! proceed: aStringOrText title: aString "Open a proceed dialog and answer true if not cancelled, false otherwise." ^self theme proceedIn: self text: aStringOrText title: aString! ! !MorphicUIManager methodsFor: 'services' stamp: 'FernandoOlivero 4/12/2011 09:56'! enterOrRequestFrom: labelList values: valueList lines: linesArray title: aString "Choose an item from the given list. Answer the value selected of the selected item or the new string entered." ^ self theme enterOrRequestIn: self modalMorph title: aString labels: labelList values: valueList lines: linesArray! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newAutoAcceptTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self theme newAutoAcceptTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'IgorStasenko 4/15/2011 17:26'! edit: aText label: labelString accept: anAction "Open an editor on the given string/text" ^(Smalltalk tools workspace openLabel: labelString) acceptContents: aText; acceptAction: anAction; yourself. ! ! !MorphicUIManager methodsFor: 'private' stamp: 'CamilloBruni 9/14/2013 00:00'! deactivate activeTranscript := Transcript. SystemProgressMorph disable.! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newTreeFor: aModel list: listSelector selected: getSelector changeSelected: setSelector "Answer a new tree morph." ^self theme newTreeIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newBalloonHelp: aTextStringOrMorph for: aMorph "Answer a new balloon help with the given contents for aMorph at a given corner." ^self theme newBalloonHelpIn: self contents: aTextStringOrMorph for: aMorph corner: #bottomLeft! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText "Answer a bracket slider with the given selectors." ^self theme newBracketSliderIn: self for: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newButtonFor: aModel action: actionSel label: stringOrText help: helpText "Answer a new button." ^self newButtonFor: aModel getState: nil action: actionSel arguments: nil getEnabled: nil label: stringOrText help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel font: aFont help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel font: aFont help: helpText ! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newNoButton "Answer a new No button." ^self newNoButtonFor: self! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newHSVSelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVSelectorIn: self color: aColor help: helpText! ! !MorphicUIManager methodsFor: 'ui process' stamp: 'MarcusDenker 12/2/2011 16:28'! uiProcess " Answer the currently active UI process for morphic world. Client should check explicitly if #uiProcess answers nil or not (see other implementations)" ^ UIProcess! ! !MorphicUIManager methodsFor: 'private' stamp: 'GaryChambers 9/20/2011 13:15'! openModal: aSystemWindow "Open the given window at an available position with modality. Answer the system window." ^self modalMorph openModal: aSystemWindow! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newRow: controls "Answer a morph laid out with a row of controls." ^self theme newRowIn: self for: controls! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel "Answer a text editor for the given model." ^self newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: nil! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newTitle: aString for: control "Answer a morph laid out with a column with a title." ^self theme newTitleIn: self label: aString for: control! ! !MorphicUIManager methodsFor: 'services' stamp: ''! question: aStringOrText title: aString "Open a question dialog and answer true if yes, false if no and nil if cancelled." ^self theme questionIn: self text: aStringOrText title: aString! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newGroupboxForAll: controls "Answer a plain groupbox with the given controls." ^self theme newGroupboxIn: self forAll: controls! ! !MorphicUIManager methodsFor: 'ui process' stamp: 'BernardoContreras 1/22/2012 17:00'! interruptName: labelString preemptedProcess: theInterruptedProcess "Create a Notifier on the active scheduling process with the given label." | preemptedProcess projectProcess | ActiveHand ifNotNil:[ActiveHand interrupted]. ActiveWorld := World. "reinstall active globals" ActiveHand := World primaryHand. ActiveHand interrupted. "make sure this one's interrupted too" ActiveEvent := nil. projectProcess := self uiProcess. "we still need the accessor for a while" preemptedProcess := theInterruptedProcess ifNil: [Processor preemptedProcess]. "Only debug preempted process if its priority is >= projectProcess' priority" preemptedProcess priority < projectProcess priority ifTrue:[preemptedProcess := projectProcess]. preemptedProcess suspend. Smalltalk tools debugger openInterrupt: labelString onProcess: preemptedProcess. ! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel font: aFont help: helpText entryCompletion: anEntryCompletion! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: nil! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'GaryChambers 12/6/2011 10:16'! confirm: aStringOrText orCancel: cancelBlock "Put up a question dialog (with cancel) with the text queryString. Answer true if the response is yes, false if no. Answer the value of the cancel block if cancelled. This is a modal question--the user must respond yes or no or cancel." |modalMorph| (ProvideAnswerNotification signal: aStringOrText) ifNotNil: [:answer | ^answer == #cancel ifTrue: [cancelBlock value] ifFalse: [answer]]. modalMorph := self modalMorph. ^(modalMorph theme questionIn: modalMorph text: aStringOrText title: 'Question' translated) ifNil: cancelBlock! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'Pavel.Krivanek 10/28/2008 10:46'! fontFromUser: priorFont ^ StrikeFont fromUser: priorFont allowKeyboard: true! ! !MorphicUIManager methodsFor: 'accessing' stamp: 'StephaneDucasse 7/17/2010 13:15'! modalMorph "Answer the morph that should be used to handle modality." | sender receiver foundWorld | sender := thisContext sender. foundWorld := false. [foundWorld or: [sender isNil]] whileFalse: [receiver := sender receiver. ((sender selector = #invokeWorldMenu:) or: [receiver == World and: [sender selector == #handleEvent: or: [sender selector == #findWindow:]]]) ifTrue: [foundWorld := true] ifFalse: [sender := sender sender]]. foundWorld ifTrue: [^ receiver world ifNil: [World]]. ^ SystemWindow topWindow ifNil: [World]! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel getLabel: labelSel getEnabled: enabledSel! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel help: helpText "Answer a text entry for the given model." ^self newTextEntryFor: aModel get: getSel set: setSel class: String getEnabled: nil help: helpText! ! !MorphicUIManager methodsFor: 'services' stamp: ''! chooseDirectory: title "Answer the result of a file dialog with the given title, answer a directory." ^self chooseDirectory: title path: nil! ! !MorphicUIManager methodsFor: 'services' stamp: ''! chooseDropList: aStringOrText title: aString list: aList "Open a drop list chooser dialog." ^self theme chooseDropListIn: self text: aStringOrText title: aString list: aList! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 2/24/2007 15:15'! checkForNewDisplaySize "Check whether the screen size has changed and if so take appropriate actions" Display extent = DisplayScreen actualScreenSize ifTrue: [^ Display]. DisplayScreen startUp. World restoreMorphicDisplay. ! ! !MorphicUIManager methodsFor: 'services' stamp: 'GaryChambers 12/2/2011 11:59'! chooseFullFileName: title extensions: exts path: path preview: preview "Answer the result of a file name chooser dialog with the given title, extensions to show, path and preview type." ^self theme chooseFullFileNameIn: self modalMorph title: title extensions: exts path: path preview: preview! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText "Answer a list for the given model." ^self theme newListIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newString: aStringOrText "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: #plain! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newExpander: aString forAll: controls "Answer an expander with the given label and controls." ^self theme newExpanderIn: self label: aString forAll: controls! ! !MorphicUIManager methodsFor: 'services' stamp: ''! questionWithoutCancel: aStringOrText title: aString "Open a question dialog and answer true if yes, false if no and nil if cancelled." ^self theme questionWithoutCancelIn: self text: aStringOrText title: aString! ! !MorphicUIManager methodsFor: 'events' stamp: 'AlainPlantec 9/12/2011 00:50'! onPrimitiveError: aString | message | message := String streamContents: [:s | | context | s nextPutAll: '*** System error handling failed ***'. s cr; nextPutAll: aString. context := thisContext sender sender. 20 timesRepeat: [context == nil ifFalse: [s cr; print: (context := context sender)]]]. Transcripter askForEmergencyEvaluatorOrExitWithText: message. "init hands and redisplay" World install ! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newFuzzyLabel: aString "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: nil label: aString offset: 1 alpha: 0.5 getEnabled: nil! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newRow "Answer a morph laid out as a row." ^self theme newRowIn: self for: #()! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newStack "Answer a morph laid out as a stack." ^self theme newStackIn: self for: #()! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newFuzzyLabelFor: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: aModel label: aString offset: offset alpha: alpha getEnabled: enabledSel! ! !MorphicUIManager methodsFor: 'services' stamp: ''! chooseFileName: title extensions: exts path: path preview: preview "Answer the result of a file name chooser dialog with the given title, extensions to show, path and preview type." ^self theme chooseFileNameIn: self title: title extensions: exts path: path preview: preview! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 5/4/2012 19:58'! chooseDirectory: label from: dir "Answer the user choice of a directory." | modalMorph realLabel | realLabel := label ifNil: ['Choose Directory' translated]. (ProvideAnswerNotification signal: realLabel) ifNotNil: [:answer | ^answer ]. modalMorph := self modalMorph. ^modalMorph theme chooseDirectoryIn: modalMorph title: realLabel path: (dir ifNotNil: [dir fullName])! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newRadioButtonFor: aModel getSelected: getSel setSelected: setSel label: stringOrText help: helpText "Answer a checkbox (radio button appearance) with the given label." ^self newRadioButtonFor: aModel getSelected: getSel setSelected: setSel getEnabled: nil label: stringOrText help: helpText! ! !MorphicUIManager methodsFor: 'private' stamp: 'FernandoOlivero 3/30/2011 16:26'! openPolymorphComparisonFrom: targetMethodSource to: originalMethodSource belongingTo: aClass from: aChange labeled: aLabel inWindowLabeled: aWindowLabel | diffMorph | diffMorph := DiffChangeMorph from: targetMethodSource label: aChange stamp to: originalMethodSource label: (aClass compiledMethodAt: aChange methodSelector) timeStamp contextClass: aClass. diffMorph openInWindowLabeled: aWindowLabel.! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newYesButtonFor: aModel "Answer a new yes button." ^self theme newYesButtonIn: self for: aModel! ! !MorphicUIManager methodsFor: 'services' stamp: ''! abort: aStringOrText title: aString "Open an error dialog." ^self theme abortIn: self text: aStringOrText title: aString! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: aClass getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'GaryChambers 12/6/2011 10:14'! chooseFrom: labelList values: valueList lines: linesArray title: aString "Choose an item from the given list. Answer the selected item." |modalMorph| modalMorph := self modalMorph. ^modalMorph theme chooseIn: modalMorph title: aString labels: labelList values: valueList lines: linesArray! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'StephaneDucasse 9/7/2011 22:33'! 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." ^ self request: queryString initialAnswer: defaultAnswer title: 'Provide the following information' ! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'GaryChambers 4/24/2012 13:28'! multiLineRequest: queryString initialAnswer: defaultAnswer answerHeight: answerHeight "Create a multi-line instance of me whose question is queryString with the given initial answer. 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." |modalMorph| (ProvideAnswerNotification signal: queryString) ifNotNil: [:answer | ^answer == #default ifTrue: [defaultAnswer] ifFalse: [answer]]. modalMorph := self modalMorph. ^(modalMorph theme textEditorIn: modalMorph text: queryString title: 'Information Required' translated entryText: defaultAnswer entryHeight: answerHeight) ifNotNil: [:text | text asString]! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newColorChooserFor: aModel getColor: getSel setColor: setSel help: helpText "Answer a color chooser with the given selectors." ^self theme newColorChooserIn: self for: aModel getColor: getSel setColor: setSel getEnabled: nil help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newIncrementalSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText "Answer an inremental slider with the given selectors." ^self theme newIncrementalSliderIn: self for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newLabelGroup: labelsAndControls font: aFont labelColor: aColor "Answer a morph laid out with a column of labels and a column of associated controls. Controls having a vResizing value of #spaceFill will cause their row to use #spaceFill also, otherwise #shrinkWrap." ^self theme newLabelGroupIn: self for: labelsAndControls font: aFont labelColor: aColor ! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newCloseButton "Answer a new close button." ^self newCloseButtonFor: self ! ! !MorphicUIManager methodsFor: 'ui process' stamp: 'MarcusDenker 12/6/2011 12:26'! resumeUIProcess: aProcess "Adopt aProcess as the project process -- probably because of proceeding from a debugger" UIProcess := aProcess. UIProcess resume! ! !MorphicUIManager methodsFor: 'services' stamp: 'FernandoOlivero 4/12/2011 09:57'! confirm: queryString trueChoice: trueChoice falseChoice: falseChoice cancelChoice: cancelChoice default: defaultOption "Put up a yes/no/cancel menu with caption queryString. The actual wording for the choices will be as provided in the trueChoice, falseChoice and cancelChoice parameters. defaultOption should be one of true, false or nil to set the default button. Answer true if the response is the true-choice, false if it's the false-choice, nil if the cancelChoice. This is a modal question -- the user must respond." (ProvideAnswerNotification signal: queryString) ifNotNil: [:answer | ^answer]. ^ self theme customQuestionIn: self modalMorph text: queryString yesText: trueChoice noText: falseChoice cancelText: cancelChoice default: defaultOption title: 'Question' translated! ! !MorphicUIManager methodsFor: 'services' stamp: 'StephaneDucasse 7/17/2010 13:10'! chooseFrom: aList lines: linesArray message: messageString title: aString "Choose an item from the given list. Answer the selected item." ^(self chooseFrom: aList values: nil lines: linesArray message: messageString title: aString) ifNil: [0]! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newPluggableDialogWindow: title "Answer a new pluggable dialog with the given content." ^self newPluggableDialogWindow: title for: nil! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newSVSelector: aColor help: helpText "Answer a saturation-volume selector with the given color." ^self theme newSVSelectorIn: self color: aColor help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newMenu "Answer a new menu." ^self theme newMenuIn: self for: self! ! !MorphicUIManager methodsFor: 'services' stamp: 'StephaneDucasse 7/17/2010 13:12'! chooseOrRequestFrom: aList lines: linesArray title: aString "Choose an item from the given list. Answer the value selected of the selected item or the new string entered." ^self chooseOrRequestFrom: aList values: aList lines: linesArray title: aString! ! !MorphicUIManager methodsFor: 'accessing' stamp: 'pavel.krivanek 11/21/2008 17:30'! interactiveParser: anObject "Set the value of interactiveParser" interactiveParser := anObject! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector "Answer a text editor for the given model." ^self theme newBasicTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel menu: menuSelector! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newMorphDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText "Answer a morph drop list for the given model." ^self theme newMorphDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: useIndex help: helpText! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'GaryChambers 12/6/2011 10:18'! requestPassword: aStringOrText "Request for a password. Allow for interception with a ProvideAnswerNotification handler. Answer nil if the user cancels." |modalMorph| (ProvideAnswerNotification signal: aStringOrText) ifNotNil: [:answer | ^answer == #default ifTrue: [''] ifFalse: [answer]]. modalMorph := self modalMorph. ^modalMorph theme passwordEntryIn: modalMorph text: aStringOrText title: 'Password Required' translated entryText: ''! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newButtonFor: aModel action: actionSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a new button." ^self newButtonFor: aModel getState: nil action: actionSel arguments: nil getEnabled: enabledSel label: stringOrText help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newBalloonHelp: aTextStringOrMorph for: aMorph corner: cornerSymbol "Answer a new balloon help with the given contents for aMorph at a given corner." ^self theme newBalloonHelpIn: self contents: aTextStringOrMorph for: aMorph corner: cornerSymbol! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newAlphaSelector: aModel getAlpha: getSel setAlpha: setSel help: helpText "Answer an alpha channel selector with the given selectors." ^self theme newAlphaSelectorIn: self for: aModel getAlpha: getSel setAlpha: setSel help: helpText! ! !MorphicUIManager methodsFor: 'services' stamp: ''! message: aStringOrText "Open a message dialog." ^self message: aStringOrText title: 'Information' translated! ! !MorphicUIManager methodsFor: 'services' stamp: ''! longMessage: aStringOrText title: aString "Open a (long) message dialog." ^self theme longMessageIn: self text: aStringOrText title: aString! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newCheckboxFor: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText "Answer a checkbox with the given label." ^self theme newCheckboxIn: self for: aModel getSelected: getSel setSelected: setSel getEnabled: enabledSel label: stringOrText help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newDialogPanel "Answer a new main dialog panel." ^self theme newDialogPanelIn: self! ! !MorphicUIManager methodsFor: 'services' stamp: ''! chooseColor: aColor title: title "Answer the result of a color selector dialog with the given title and initial colour." ^self theme chooseColorIn: self title: title color: aColor! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newCancelButtonFor: aModel "Answer a new cancel button." ^self theme newCancelButtonIn: self for: aModel! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newOKButton "Answer a new OK button." ^self newOKButtonFor: self! ! !MorphicUIManager methodsFor: 'events' stamp: 'CamilloBruni 2/13/2012 23:22'! onSnapshot: resuming "The resuming argument is true when image boots from disk, and false, if user just did an image snapshot." "if we resuming, check if we're still interactive " resuming ifTrue: [ Smalltalk isInteractive ifFalse: [ ^ self nonInteractiveManager onSnapshot: resuming ]. Smalltalk isHeadless ifTrue: [ ^ self headlessManager onSnapshot: resuming ]]. SystemWindow wakeUpTopWindowUponStartup! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newFuzzyLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new fuzzy label." ^self theme newFuzzyLabelIn: self for: aModel label: aString offset: 1 alpha: 0.5 getEnabled: enabledSel! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newYesButton "Answer a new Yes button." ^self newYesButtonFor: self! ! !MorphicUIManager methodsFor: 'services' stamp: ''! chooseColor "Answer the result of a color selector dialog ." ^self chooseColor: Color black! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newListFor: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText "Answer a list for the given model." ^self theme newListIn: self for: aModel list: listSelector selected: getSelector changeSelected: setSelector icon: iconSelector getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'SeanDeNigris 7/26/2011 14:27'! confirm: aStringOrText "Put up a question dialog (without cancel). Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no." ^ self confirm: aStringOrText label: 'Question' translated.! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newString: aStringOrText font: aFont style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: aFont style: aStyle! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newToolbar "Answer a toolbar." ^self theme newToolbarIn: self! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel help: helpText "Answer a drop list for the given model." ^self newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: nil useIndex: true help: helpText! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'BernardoContreras 1/22/2012 16:56'! warningDefaultAction: anException "The user should be notified of the occurrence of an exceptional occurrence and given an option of continuing or aborting the computation. The description of the occurrence should include any text specified as the argument of the #signal: message." Smalltalk tools debugger openContext: thisContext label: 'Warning' contents: anException messageText, '\\Select Proceed to continue, or close this window to cancel the operation.' withCRs. anException resume.! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 2/24/2007 15:12'! fileDoesNotExistsDefaultAction: anException ^anException readOnly ifTrue: [StandardFileStream readOnlyFileDoesNotExistUserHandling: anException fileName] ifFalse: [StandardFileStream fileDoesNotExistUserHandling: anException fileName] ! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newCloseButtonFor: aModel "Answer a new close button." ^self theme newCloseButtonIn: self for: aModel! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 10/7/2012 22:40'! inform: aStringOrText "Display a message for the user to read and then dismiss." (ProvideAnswerNotification signal: aStringOrText) ifNotNil: [:answer | ^true]. GrowlMorph openWithLabel: 'Information' translated contents: aStringOrText! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'StephaneDucasse 2/25/2011 17:53'! newMenuIn: aThemedMorph for: aModel "Answer a new menu." "UIManager default" ^self theme newMenuIn: aThemedMorph for: aModel! ! !MorphicUIManager methodsFor: 'services' stamp: ''! fileSave: title path: path "Answer the result of a file save open dialog with the given title." ^self fileSave: title extensions: nil path: path! ! !MorphicUIManager methodsFor: 'services' stamp: ''! chooseColor: aColor "Answer the result of a color selector dialog with the given color." ^self theme chooseColorIn: self title: 'Colour Selector' translated color: aColor! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newScrollPaneFor: aMorph "Answer a new scroll pane morph to scroll the given morph." ^self theme newScrollPaneIn: self for: aMorph! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newPluggableDialogWindow "Answer a new pluggable dialog." ^self newPluggableDialogWindow: 'Dialog'! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newOKButtonFor: aModel "Answer a new OK button." ^self newOKButtonFor: aModel getEnabled: nil! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'GaryChambers 12/6/2011 10:13'! chooseFileMatching: patterns label: label "Let the user choose a file matching the given patterns" |modalMorph| modalMorph := self modalMorph. ^modalMorph theme chooseFileNameIn: modalMorph title: (label ifNil: ['Choose File' translated]) patterns: patterns path: nil preview: false! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 2/24/2007 13:22'! restoreDisplay World fullRepaintNeeded! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newEditableDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel ghostText: ghostText getEnabled: enabledSel help: helpText "Answer an editable drop list for the given model." ^self theme newEditableDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel addToList: addSel class: String default: '' ghostText: ghostText getEnabled: enabledSel useIndex: false help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newGroupboxFor: control "Answer a plain groupbox with the given control." ^self theme newGroupboxIn: self for: control! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newOverflowRowForAll: aCollectionOfMorphs "Answer a new overflow row morph that provides a drop down for the given contents that are unable to fit the bounds." ^self theme newOverflowRowIn: self forAll: aCollectionOfMorphs! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'MarcusDenker 9/29/2013 15:50'! syntaxErrorNotificationDefaultAction: anException "Handle a syntax error. Note, if there is no #syntaxErrorDebugger registered, it will be silently ignored" ^Smalltalk tools using: #syntaxErrorDebugger do: [:tool | tool open: (tool syntaxError: anException)]! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'MarcusDenker 9/29/2013 09:05'! unhandledErrorDefaultAction: anException "The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated." ^Smalltalk tools debugger debugError: anException.! ! !MorphicUIManager methodsFor: 'services' stamp: ''! message: aStringOrText title: aString "Open a message dialog." ^self theme messageIn: self text: aStringOrText title: aString! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText "Answer a morph list for the given model." ^self theme newMorphListIn: self for: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'GaryChambers 12/6/2011 10:15'! confirm: questionStringOrText label: labelStringOrText "Put up a question dialog (without cancel). Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no." |modalMorph| (ProvideAnswerNotification signal: questionStringOrText) ifNotNil: [:answer | ^answer]. modalMorph := self modalMorph. ^modalMorph theme questionWithoutCancelIn: modalMorph text: questionStringOrText title: labelStringOrText.! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newBasicTextEditorFor: aModel getText: getSel setText: setSel "Answer a text editor for the given model." ^self newBasicTextEditorFor: aModel getText: getSel setText: setSel getEnabled: nil! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newImage: aForm size: aPoint "Answer a new image." ^self theme newImageIn: self form: aForm size: aPoint! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newImageFor: aModel get: getSel help: helpText "Answer a text entry for the given model." ^self theme newImageIn: self for: aModel get: getSel help: helpText! ! !MorphicUIManager methodsFor: 'services' stamp: ''! abort: aStringOrText "Open an error dialog." ^self abort: aStringOrText title: 'Error' translated! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newColorPresenterFor: aModel getColor: getSel help: helpText "Answer a color presenter with the given selectors." ^self theme newColorPresenterIn: self for: aModel getColor: getSel help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newOKButtonFor: aModel getEnabled: enabledSel "Answer a new OK button." ^self theme newOKButtonIn: self for: aModel getEnabled: enabledSel! ! !MorphicUIManager methodsFor: 'services' stamp: 'FernandoOlivero 4/12/2011 09:56'! chooseFrom: labelList values: valueList lines: linesArray message: messageString title: aString "Choose an item from the given list. Answer the selected item." ^ self theme chooseIn: self modalMorph title: aString message: messageString labels: labelList values: valueList lines: linesArray! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector help: helpText "Answer a morph list for the given model." ^self newMorphListFor: aModel list: listSelector getSelected: getSelector setSelected: setSelector getEnabled: nil help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newText: aStringOrText "Answer a new text." ^self theme newTextIn: self text: aStringOrText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion "Answer a text entry for the given model." ^self theme newTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText entryCompletion: anEntryCompletion! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newDropListFor: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel help: helpText "Answer a drop list for the given model." ^self theme newDropListIn: self for: aModel list: listSel getSelected: getSel setSelected: setSel getEnabled: enabledSel useIndex: true help: helpText! ! !MorphicUIManager methodsFor: 'services' stamp: ''! fileSave: title extensions: exts path: path "Answer the result of a file save dialog with the given title, extensions to show and path." ^self theme fileSaveIn: self title: title extensions: exts path: path! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'StephaneDucasse 9/7/2011 21:51'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint "Create an instance of me whose question is queryString with the given initial answer. Answer the string the user accepts. Answer the empty string if the user cancels." ^ self request: queryString initialAnswer: defaultAnswer ! ! !MorphicUIManager methodsFor: 'settings' stamp: 'MarcusDenker 4/29/2013 15:51'! interactiveParserFor: requestor "during Morphic loading the interactive parser must be disabled" (interactiveParser = false) ifTrue: [ ^ false ]. "can be nil" ^super interactiveParserFor: requestor! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newLabel: aString "Answer a new text label." ^self newLabelFor: nil label: aString getEnabled: nil! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newAutoAcceptTextEntryFor: aModel getText: getSel setText: setSel getEnabled: enabledSel help: helpText "Answer a text entry for the given model." ^self theme newAutoAcceptTextEntryIn: self for: aModel get: getSel set: setSel class: String getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newLabelGroup: labelsAndControls "Answer a morph laid out with a column of labels and a column of associated controls. Controls having a vResizing value of #spaceFill will cause their row to use #spaceFill also, otherwise #shrinkWrap." ^self theme newLabelGroupIn: self for: labelsAndControls! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newMultistateButton "Answer a new multistate button morph. To be usable it needs to have fill styles assigned to various states along with mouse-up/down actions." ^self theme newMultistateButtonIn: self! ! !MorphicUIManager methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts path: path preview: preview "Answer the result of a file open dialog with the given title, extensions to show, path and preview type." ^self theme fileOpenIn: self title: title extensions: exts path: path preview: preview! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newExpander: aString for: aControl "Answer an expander with the given label and control." ^self theme newExpanderIn: self label: aString forAll: {aControl}! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newWorkArea "Answer a new work area morph." ^self theme newWorkAreaIn: self! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newColumn: controls "Answer a morph laid out with a column of controls." ^self theme newColumnIn: self for: controls! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newExpander: aString "Answer an expander with the given label." ^self theme newExpanderIn: self label: aString forAll: #()! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum help: helpText "Answer a bracket slider with the given selectors." ^self newBracketSliderFor: aModel getValue: getSel setValue: setSel min: minValue max: maxValue quantum: quantum getEnabled: nil help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newToolDockingBar "Answer a tool docking bar." ^self theme newToolDockingBarIn: self! ! !MorphicUIManager methodsFor: 'services' stamp: ''! textEntry: aStringOrText title: aString "Open a text entry dialog." ^self textEntry: aStringOrText title: aString entryText: ''! ! !MorphicUIManager methodsFor: 'services' stamp: ''! fileSave: title extensions: exts "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: exts path: nil! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newSeparator "Answer an horizontal separator." ^self theme newSeparatorIn: self! ! !MorphicUIManager methodsFor: 'services' stamp: ''! fileSave: title "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: nil path: nil! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newCloseControlFor: aModel action: aValuable help: helpText "Answer a new cancel button." ^self theme newCloseControlIn: self for: aModel action: aValuable help: helpText! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newSliderFor: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText "Answer a slider with the given selectors." ^self theme newSliderIn: self for: aModel getValue: getSel setValue: setSel min: min max: max quantum: quantum getEnabled: enabledSel help: helpText! ! !MorphicUIManager methodsFor: 'services' stamp: ''! question: aStringOrText "Open a question dialog." ^self question: aStringOrText title: 'Question' translated! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 2/24/2007 13:14'! newDisplayDepthNoRestore: pixelSize "Change depths. Check if there is enough space!! , di" | area need | pixelSize = Display depth ifTrue: [^ Display "no change"]. pixelSize abs < Display depth ifFalse: ["Make sure there is enough space" area := Display boundingBox area. "pixels" 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. DisplayScreen startUp! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'JuanVuletich 11/1/2010 15:17'! currentWorld ActiveWorld ifNotNil: [^ActiveWorld]. ^World! ! !MorphicUIManager methodsFor: 'services' stamp: ''! textEntry: aStringOrText "Open a text entry dialog." ^self textEntry: aStringOrText title: 'Entry' translated! ! !MorphicUIManager methodsFor: 'services' stamp: 'StephaneDucasse 7/17/2010 13:13'! enterOrRequestFrom: aList lines: linesArray title: aString "Choose an item from the given list. Answer the value selected of the selected item or the new string entered." ^self enterOrRequestFrom: aList values: aList lines: linesArray title: aString! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newGroupbox: aString forAll: controls "Answer a groupbox with the given label and controls." ^self theme newGroupboxIn: self label: aString forAll: controls! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newButtonLabel: aString "Answer a new button text label." ^self newButtonLabelFor: nil label: aString getEnabled: nil! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newToolbar: controls "Answer a toolbar with the given controls." ^self theme newToolbarIn: self for: controls! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newToolSpacer "Answer a tool spacer." ^self theme newToolSpacerIn: self! ! !MorphicUIManager methodsFor: 'services' stamp: ''! fileOpen: title extensions: exts "Answer the result of a file open dialog with the given title and extensions to show." ^self fileOpen: title extensions: exts path: nil! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'StephaneDucasse 1/2/2012 21:30'! restoreDisplayAfter: aBlock aBlock value. World activeHand waitButton. World fullRepaintNeeded.! ! !MorphicUIManager methodsFor: 'controls' stamp: ''! newToolbarHandle "Answer a toolbar handle." ^self theme newToolbarHandleIn: self! ! !MorphicUIManager methodsFor: 'ui process' stamp: 'CamilloBruni 8/21/2013 19:17'! spawnNewProcess UIProcess := [ [World doOneCycle. Processor yield. false] whileFalse: []. ] newProcess priority: Processor userSchedulingPriority. UIProcess name: 'Morphic UI Process'. UIProcess resume! ! !MorphicUIManager class methodsFor: 'accessing' stamp: 'alain.plantec 5/30/2008 13:55'! isActiveManager "Answer whether I should act as the active ui manager" ^ true! ! !MorphicWindowAdapter commentStamp: ''! I am the adapter used to bridge a WindowModel and a SystemWindow! !MorphicWindowAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 16:24'! askOkToClose ^ self model askOkToClose! ! !MorphicWindowAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 12/10/2013 23:08'! isResizeable: aBoolean ^ self widgetDo: [ :w | w isResizeable: aBoolean ]! ! !MorphicWindowAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 16:04'! close self widget ifNotNil: [ :w | w close ].! ! !MorphicWindowAdapter methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 9/29/2013 12:30'! windowIsClosing self model windowIsClosing! ! !MorphicWindowAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 16:41'! aboutText ^ self model model ifNotNil: [ :m | m aboutText ]! ! !MorphicWindowAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 16:02'! rebuildWithSpecLayout: aSpec | sub | sub := self model window submorphs copy. self model window removeAllMorphs. sub allButLast do: [:e | self model window addMorphBack: e ]. self model addModelIn: self widget withSpecLayout: aSpec. self widget model: self! ! !MorphicWindowAdapter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. isClosedHolder := false asReactiveVariable.! ! !MorphicWindowAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 16:04'! isDisplayed ^ self widget isDisplayed! ! !MorphicWindowAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 10/19/2013 15:17'! addModelItemsToWindowMenu: aMenu self model addMenuItemsToWindowMenu: aMenu! ! !MorphicWindowAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 10/1/2013 15:16'! title 1halt. ^ self model title! ! !MorphicWindowAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 16:03'! title: aString ^ self widget ifNotNil: [:w | w title: aString ]! ! !MorphicWindowAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 16:25'! initialExtent ^ self model initialExtent! ! !MorphicWindowAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 2/18/2014 23:54:16.555818'! minimize self widgetDo: [ :w | w minimize ]! ! !MorphicWindowAdapter methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 1/5/2014 12:45'! taskbarIcon ^ self model taskbarIcon! ! !MorphicWindowAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/28/2013 17:11'! centered self widgetDo: [ :w | w fullBounds; position: Display extent - w extent // 2 ]! ! !MorphicWindowAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 2/18/2014 23:54:16.555818'! maximize self widgetDo: [ :w | w maximize ]! ! !MorphicWindowAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 16:02'! rebuildWithSpec: aSpec | sub | sub := self model window submorphs copy. self model window removeAllMorphs. sub allButLast do: [:e | self model window addMorphBack: e ]. self model addModelIn: self widget withSpec: aSpec! ! !MorphicWindowAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 12/10/2013 23:08'! isResizeable ^ self model isResizeable! ! !MorphicWindowAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/28/2013 17:18'! centeredRelativeTo: aModel self widgetDo: [ :w | aModel centerWidget: w ]! ! !MorphicWindowAdapter methodsFor: 'widget API' stamp: 'BenjaminVanRyseghem 9/25/2013 16:43'! cancelled ^ false! ! !MorphicWindowAdapter methodsFor: 'widget API' stamp: 'NicolaiHess 12/22/2013 23:33'! okToChange ^ self model okToChange! ! !MorphicWindowAdapter methodsFor: 'widget API' stamp: 'BenComan 12/18/2013 01:34'! aboutTitle ^ self model model ifNotNil: [ :m | (m respondsTo: #aboutTitle) ifTrue: [m aboutTitle] ifFalse: [m class name]].! ! !MorphicWindowAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 16:00'! open self model window openInWorld! ! !MorphicWindowAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 15:47'! addModelIn: widgetToBuild withSpec: aSpec widgetToBuild addMorph: (self model model buildWithSpec: aSpec) frame: (0@0 corner: 1@1)! ! !MorphicWindowAdapter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/25/2013 16:23'! addModelIn: widgetToBuild withSpecLayout: aSpec widgetToBuild addMorph: (self model model buildWithSpecLayout: aSpec) frame: (0@0 corner: 1@1)! ! !MorphicWindowAdapter methodsFor: 'spec protocol' stamp: 'BenjaminVanRyseghem 12/1/2013 01:07'! modalRelativeTo: aWindow self widgetDo: [ :w | aWindow setModal: w ]! ! !MorphicWindowAdapter methodsFor: 'protocol' stamp: 'ChristopheDemarey 10/18/2013 13:09'! openModal: aWindow ^ self widget ifNotNil: [:w | w openModal: aWindow asWidget ].! ! !MorphicWindowAdapter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 12/10/2013 23:08'! defaultSpec ^ #( SpecWindow model: model isResizeable: #(model isResizeable ))! ! !MouseButtonEvent commentStamp: 'TorstenBergmann 2/20/2014 18:29'! A button event from a mouse! !MouseButtonEvent methodsFor: 'printing' stamp: 'ar 10/24/2000 16:29'! storeOn: aStream super storeOn: aStream. aStream space. whichButton storeOn: aStream.! ! !MouseButtonEvent methodsFor: 'dispatching' stamp: 'ar 9/16/2000 13:05'! sentTo: anObject "Dispatch the receiver into anObject" type == #mouseDown ifTrue:[^anObject handleMouseDown: self]. type == #mouseUp ifTrue:[^anObject handleMouseUp: self]. ^super sentTo: anObject! ! !MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:59'! yellowButtonChanged "Answer true if the yellow mouse button has changed. This is the second mouse button or option+click on the Mac." ^ whichButton anyMask: 2! ! !MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:58'! blueButtonChanged "Answer true if the blue mouse button has changed. This is the third mouse button or cmd+click on the Mac." ^ whichButton anyMask: 1! ! !MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:58'! redButtonChanged "Answer true if the red mouse button has changed. This is the first mouse button." ^ whichButton anyMask: 4! ! !MouseButtonEvent methodsFor: 'accessing' stamp: 'nk 3/11/2004 17:44'! whichButton ^whichButton! ! !MouseButtonEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:55'! setType: evtType position: evtPos which: button buttons: evtButtons hand: evtHand stamp: stamp type := evtType. position := evtPos. buttons := evtButtons. source := evtHand. wasHandled := false. whichButton := button. timeStamp := stamp.! ! !MouseClickState commentStamp: ''! MouseClickState is a simple class managing the distinction between clicks, double clicks, and drag operations. It has been factored out of HandMorph due to the many instVars. Instance variables: clickClient The client wishing to receive #click:, #dblClick:, or #drag messages clickState The internal state of handling the last event (#firstClickDown, #firstClickUp, #firstClickTimedOut) firstClickDown The #mouseDown event after which the client wished to receive #click: or similar messages firstClickUp The first mouse up event which came in before the double click time out was exceeded (it is sent if there is a timout after the first mouse up event occured) firstClickTime The millisecond clock value of the first event clickSelector The selector to use for sending #click: messages dblClickSelector The selector to use for sending #doubleClick: messages dblClickTime Timout in milliseconds for a double click operation dragSelector The selector to use for sending #drag: messages dragThreshold Threshold used for determining if a #drag: message is sent (pixels!!) ! !MouseClickState methodsFor: 'initialize' stamp: 'jcg 9/21/2001 13:08'! client: aMorph click: aClickSelector dblClick: aDblClickSelector dblClickTime: timeOut dblClickTimeout: aDblClickTimeoutSelector drag: aDragSelector threshold: aNumber event: firstClickEvent clickClient := aMorph. clickSelector := aClickSelector. dblClickSelector := aDblClickSelector. dblClickTime := timeOut. dblClickTimeoutSelector := aDblClickTimeoutSelector. dragSelector := aDragSelector. dragThreshold := aNumber. firstClickDown := firstClickEvent. firstClickTime := firstClickEvent timeStamp. clickState := #firstClickDown.! ! !MouseClickState methodsFor: 'event handling' stamp: 'nk 7/26/2004 10:21'! handleEvent: evt from: aHand "Process the given mouse event to detect a click, double-click, or drag. Return true if the event should be processed by the sender, false if it shouldn't. NOTE: This method heavily relies on getting *all* mouse button events." | localEvt timedOut isDrag | timedOut := (evt timeStamp - firstClickTime) > dblClickTime. localEvt := evt transformedBy: (clickClient transformedFrom: aHand owner). isDrag := (localEvt position - firstClickDown position) r > dragThreshold. clickState == #firstClickDown ifTrue: [ "Careful here - if we had a slow cycle we may have a timedOut mouseUp event" (timedOut and:[localEvt isMouseUp not]) ifTrue:[ "timeout before #mouseUp -> keep waiting for drag if requested" clickState := #firstClickTimedOut. dragSelector ifNil:[ aHand resetClickState. self doubleClickTimeout; click "***"]. ^true]. localEvt isMouseUp ifTrue:[ (timedOut or:[dblClickSelector isNil]) ifTrue:[ self click. aHand resetClickState. ^true]. "Otherwise transfer to #firstClickUp" firstClickUp := evt copy. clickState := #firstClickUp. "If timedOut or the client's not interested in dbl clicks get outta here" self click. aHand handleEvent: firstClickUp. ^false]. isDrag ifTrue:["drag start" self doubleClickTimeout. "***" aHand resetClickState. dragSelector "If no drag selector send #click instead" ifNil: [self click] ifNotNil: [self drag: firstClickDown]. ^true]. ^false]. clickState == #firstClickTimedOut ifTrue:[ localEvt isMouseUp ifTrue:["neither drag nor double click" aHand resetClickState. self doubleClickTimeout; click. "***" ^true]. isDrag ifTrue:["drag start" aHand resetClickState. self doubleClickTimeout; drag: firstClickDown. "***" ^true]. ^false]. clickState = #firstClickUp ifTrue:[ (timedOut) ifTrue:[ "timed out after mouseUp - signal timeout and pass the event" aHand resetClickState. self doubleClickTimeout. "***" ^true]. localEvt isMouseDown ifTrue:["double click" clickState := #secondClickDown. ^false]]. clickState == #secondClickDown ifTrue: [ timedOut ifTrue:[ "timed out after second mouseDown - pass event after signaling timeout" aHand resetClickState. self doubleClickTimeout. "***" ^true]. isDrag ifTrue: ["drag start" self doubleClickTimeout. "***" aHand resetClickState. dragSelector "If no drag selector send #click instead" ifNil: [self click] ifNotNil: [self drag: firstClickDown]. ^true]. localEvt isMouseUp ifTrue: ["double click" aHand resetClickState. self doubleClick. ^false] ]. ^true ! ! !MouseClickState methodsFor: 'printing' stamp: 'nk 7/26/2004 09:13'! printOn: aStream super printOn: aStream. aStream nextPut: $[; print: clickState; nextPut: $] ! ! !MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:23'! click clickSelector ifNotNil: [clickClient perform: clickSelector with: firstClickDown]! ! !MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:24'! doubleClick dblClickSelector ifNotNil: [clickClient perform: dblClickSelector with: firstClickDown]! ! !MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 13:09'! doubleClickTimeout dblClickTimeoutSelector ifNotNil: [ clickClient perform: dblClickTimeoutSelector with: firstClickDown]! ! !MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:27'! drag: event dragSelector ifNotNil: [clickClient perform: dragSelector with: event]! ! !MouseEvent commentStamp: 'TorstenBergmann 2/20/2014 18:29'! Superclass for mouse events! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! isMouseLeave ^self type == #mouseLeave! ! !MouseEvent methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:15'! sentTo: anObject "Dispatch the receiver into anObject" type == #mouseOver ifTrue:[^anObject handleMouseOver: self]. type == #mouseEnter ifTrue:[^anObject handleMouseEnter: self]. type == #mouseLeave ifTrue:[^anObject handleMouseLeave: self]. ^super sentTo: anObject.! ! !MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! redButtonPressed "Answer true if the red mouse button is being pressed. This is the first mouse button." ^ buttons anyMask: self class redButton! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! isMouseMove ^self type == #mouseMove! ! !MouseEvent methodsFor: 'testing' stamp: 'gvc 1/28/2008 13:14'! isMouseWheel "Answer whether the receiver is a mouse wheel event." ^false! ! !MouseEvent methodsFor: 'printing' stamp: 'JMM 9/29/2004 13:25'! printOn: aStream aStream nextPut: $[. aStream nextPutAll: self cursorPoint printString; space. aStream nextPutAll: type; space. aStream nextPutAll: self modifierString. aStream nextPutAll: self buttonString. aStream nextPutAll: timeStamp printString; space. aStream nextPutAll: self windowIndex printString. aStream nextPut: $].! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! isMouseUp ^self type == #mouseUp! ! !MouseEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:51'! cursorPoint "Answer the location of the cursor's hotspot when this event occured." ^ position! ! !MouseEvent methodsFor: 'button state' stamp: 'ar 9/15/2000 22:51'! targetPoint "Answer the location of the cursor's hotspot, adjusted by the offset of the last mouseDown relative to the recipient morph." ^ position - source targetOffset! ! !MouseEvent methodsFor: 'converting' stamp: 'marcus.denker 8/24/2008 21:42'! asMouseOver "Convert the receiver into a mouse over event" ^MouseEvent basicNew setType: #mouseOver position: position buttons: buttons hand: source! ! !MouseEvent methodsFor: 'private' stamp: 'ar 10/10/2000 21:15'! setType: aSymbol "For quick conversion between event types" type := aSymbol.! ! !MouseEvent methodsFor: 'converting' stamp: 'pmm 3/13/2010 11:33'! asMouseEnter ^self shallowCopy setType: #mouseEnter! ! !MouseEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:47'! hash ^ position hash + buttons hash! ! !MouseEvent methodsFor: 'printing' stamp: 'ar 10/25/2000 22:09'! storeOn: aStream aStream nextPutAll: type. aStream space. self timeStamp storeOn: aStream. aStream space. position x storeOn: aStream. aStream space. position y storeOn: aStream. aStream space. buttons storeOn: aStream.! ! !MouseEvent methodsFor: 'converting' stamp: 'marcus.denker 8/24/2008 21:41'! asMouseMove "Convert the receiver into a mouse move" ^MouseMoveEvent basicNew setType: #mouseMove startPoint: position endPoint: position trail: {position. position} buttons: buttons hand: source stamp: Time millisecondClockValue.! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! isMouseDown ^self type == #mouseDown! ! !MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! yellowButtonPressed "Answer true if the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac." ^ buttons anyMask: self class yellowButton! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! isMouseEnter ^self type == #mouseEnter! ! !MouseEvent methodsFor: 'converting' stamp: 'pmm 3/13/2010 11:33'! asMouseLeave ^self shallowCopy setType: #mouseLeave! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:30'! isMouse ^true! ! !MouseEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:50'! = aMorphicEvent super = aMorphicEvent ifFalse:[^false]. position = aMorphicEvent position ifFalse: [^ false]. buttons = aMorphicEvent buttons ifFalse: [^ false]. ^ true ! ! !MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! blueButtonPressed "Answer true if the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac." ^ buttons anyMask: self class blueButton! ! !MouseEvent methodsFor: 'private' stamp: 'ar 9/15/2000 22:53'! setType: evtType position: evtPos buttons: evtButtons hand: evtHand type := evtType. position := evtPos. buttons := evtButtons. source := evtHand. wasHandled := false.! ! !MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! anyButtonPressed "Answer true if any mouse button is being pressed." ^ buttons anyMask: self class anyButton! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 10/5/2000 19:43'! isDraggingEvent source ifNil:[^false]. source hasSubmorphs ifTrue:[^true]. self anyButtonPressed ifTrue:[^true]. ^false! ! !MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! redButton ^ 4! ! !MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! yellowButton ^ 2! ! !MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! blueButton ^ 1! ! !MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! anyButton ^ 7! ! !MouseMoveEvent commentStamp: 'TorstenBergmann 2/20/2014 18:30'! A move event from the mouse! !MouseMoveEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:49'! hash ^ position hash + startPoint hash + buttons hash! ! !MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 16:25'! startPoint "Return the point where the movement started." ^startPoint! ! !MouseMoveEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:49'! = aMorphicEvent super = aMorphicEvent ifFalse:[^false]. position = aMorphicEvent position ifFalse: [^ false]. startPoint = aMorphicEvent startPoint ifFalse: [^ false]. buttons = aMorphicEvent buttons ifFalse: [^ false]. ^ true ! ! !MouseMoveEvent methodsFor: 'printing' stamp: 'ar 10/24/2000 16:30'! storeOn: aStream super storeOn: aStream. aStream space. self startPoint x storeOn: aStream. aStream space. self startPoint y storeOn: aStream. aStream space. "trail storeOn: aStream."! ! !MouseMoveEvent methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:15'! sentTo: anObject "Dispatch the receiver into anObject" type == #mouseMove ifTrue:[^anObject handleMouseMove: self]. ^super sentTo: anObject. ! ! !MouseMoveEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:55'! setType: evtType startPoint: evtStart endPoint: evtEnd trail: evtTrail buttons: evtButtons hand: evtHand stamp: stamp type := evtType. startPoint := evtStart. position := evtEnd. trail := evtTrail. buttons := evtButtons. source := evtHand. wasHandled := false. timeStamp := stamp.! ! !MouseMoveEvent methodsFor: 'printing' stamp: 'JMM 9/29/2004 13:25'! printOn: aStream aStream nextPut: $[. aStream nextPutAll: self startPoint printString; space. aStream nextPutAll: self endPoint printString; space. aStream nextPutAll: self type; space. aStream nextPutAll: self modifierString. aStream nextPutAll: self buttonString. aStream nextPutAll: timeStamp printString; space. aStream nextPutAll: self windowIndex printString. aStream nextPut: $].! ! !MouseMoveEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:29'! isMove ^true! ! !MouseMoveEvent methodsFor: 'transforming' stamp: 'ar 9/15/2000 22:52'! transformBy: aMorphicTransform "Transform the receiver into a local coordinate system." position := aMorphicTransform globalPointToLocal: position. startPoint := aMorphicTransform globalPointToLocal: startPoint.! ! !MouseMoveEvent methodsFor: 'transforming' stamp: 'ar 9/15/2000 22:52'! translateBy: delta "add delta to cursorPoint, and return the new event" position := position + delta. startPoint := startPoint + delta.! ! !MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:51'! endPoint "Return the point where the movement ended." ^position! ! !MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 10/24/2000 16:33'! trail "Return any immediate points that have been assembled along the move" ^trail ifNil:[#()]! ! !MouseOverHandler commentStamp: 'TorstenBergmann 2/20/2014 18:29'! Mouse over handler in a hand morph! !MouseOverHandler methodsFor: 'initialization' stamp: 'HernanWilkinson 6/12/2009 13:48'! initializeTrackedMorphs leftMorphs := OrderedCollection new. overMorphs := WriteStream on: #(). enteredMorphs := WriteStream on: #(). ! ! !MouseOverHandler methodsFor: 'event handling - private' stamp: 'HernanWilkinson 6/12/2009 13:38'! transform: anEvent from: originalEvent andSendTo: aMorph | transformedEvent | transformedEvent := anEvent transformedBy: (aMorph transformedFrom: originalEvent hand). ^ aMorph handleEvent: transformedEvent! ! !MouseOverHandler methodsFor: 'event handling - private' stamp: 'HernanWilkinson 6/12/2009 13:37'! is: anEvent withFocusOver: aMorph | focusedMorph | focusedMorph := anEvent hand mouseFocus. ^ aMorph = focusedMorph or: [ aMorph hasOwner: focusedMorph ]! ! !MouseOverHandler methodsFor: 'event handling - private' stamp: 'HernanWilkinson 6/12/2009 13:29'! initializeProcessMouseOver leftMorphs := mouseOverMorphs asIdentitySet. overMorphs := WriteStream on: (Array new: leftMorphs size). enteredMorphs := WriteStream on: #()! ! !MouseOverHandler methodsFor: 'event handling - private' stamp: 'HernanWilkinson 6/12/2009 11:56'! hasLeftMorphsChanged ^(leftMorphs isEmpty and: [ enteredMorphs position = 0 ]) not! ! !MouseOverHandler methodsFor: 'event handling - private' stamp: 'HernanWilkinson 6/12/2009 13:32'! keepLeftMorphsOrder leftMorphs size > 1 ifTrue: [ leftMorphs := mouseOverMorphs intersection: leftMorphs ] ! ! !MouseOverHandler methodsFor: 'event handling - private' stamp: 'HernanWilkinson 6/12/2009 11:41'! informMouseLeaveToLeftMorphsUsing: anEvent | asMouseLeaveEvent | asMouseLeaveEvent := anEvent asMouseLeave. leftMorphs do: [ :aLeftMorph | self inform: asMouseLeaveEvent to: aLeftMorph originatedFrom: anEvent ifNotFocusedDo: [ overMorphs nextPut: aLeftMorph ] ]! ! !MouseOverHandler methodsFor: 'event handling - private' stamp: 'HernanWilkinson 6/12/2009 11:58'! rememberOverList mouseOverMorphs := overMorphs contents. ! ! !MouseOverHandler methodsFor: 'event handling - private' stamp: 'HernanWilkinson 6/12/2009 13:36'! inform: evt to: aLeftMorph originatedFrom: anEvent ifNotFocusedDo: aBlock ^ (self is: anEvent withFocusOver: aLeftMorph) ifTrue: [ self transform: evt from: anEvent andSendTo: aLeftMorph ] ifFalse: aBlock! ! !MouseOverHandler methodsFor: 'initialization' stamp: 'HernanWilkinson 6/4/2009 14:10'! initialize mouseOverMorphs := #(). self initializeTrackedMorphs ! ! !MouseOverHandler methodsFor: 'event handling' stamp: 'HernanWilkinson 6/12/2009 13:40'! noticeMouseOver: aMorph event: anEvent "Remember that the mouse is currently over some morph" leftMorphs remove: aMorph ifAbsent: [ enteredMorphs nextPut: aMorph ]. overMorphs nextPut: aMorph. ! ! !MouseOverHandler methodsFor: 'event handling' stamp: 'HernanWilkinson 6/12/2009 13:51'! processMouseOver: anEvent self initializeProcessMouseOver. self handleAsMouseOver: anEvent. self hasLeftMorphsChanged ifTrue: [ self handleAsMouseLeave: anEvent. self handleAsMouseEnter: anEvent. self rememberOverList ]. self initializeTrackedMorphs ! ! !MouseOverHandler methodsFor: 'event handling - private' stamp: 'HernanWilkinson 6/12/2009 08:44'! handleAsMouseLeave: anEvent self keepLeftMorphsOrder. self informMouseLeaveToLeftMorphsUsing: anEvent ! ! !MouseOverHandler methodsFor: 'event handling - private' stamp: 'HernanWilkinson 6/12/2009 11:59'! handleAsMouseOver: anEvent anEvent hand handleEvent: anEvent asMouseOver. ! ! !MouseOverHandler methodsFor: 'event handling - private' stamp: 'HernanWilkinson 6/12/2009 13:33'! handleAsMouseEnter: anEvent | asMouseEnterEvent | asMouseEnterEvent := anEvent asMouseEnter. enteredMorphs := enteredMorphs contents. enteredMorphs reverseDo: [ :anEnteredMorph | self inform: asMouseEnterEvent to: anEnteredMorph originatedFrom: anEvent ifNotFocusedDo: [] ]! ! !MouseWheelEvent commentStamp: 'gvc 9/23/2008 11:46'! A mouse event generated by intercepting the keyboard events (ctrl+up/down arrow) generated by the VM in response to mouse wheel activity.! !MouseWheelEvent methodsFor: 'accessing' stamp: 'gvc 1/28/2008 15:31'! setType: evtType position: evtPos direction: dirSymbol buttons: evtButtons hand: evtHand stamp: stamp "Set the state for the receiver." type := evtType. position := evtPos. buttons := evtButtons. source := evtHand. wasHandled := false. direction := dirSymbol. timeStamp := stamp.! ! !MouseWheelEvent methodsFor: 'testing' stamp: 'gvc 1/28/2008 13:14'! isMouseWheel "Answer whether the receiver is a mouse wheel event." ^true! ! !MouseWheelEvent methodsFor: 'printing' stamp: 'GaryChambers 9/5/2011 13:44'! printOn: aStream aStream nextPut: $[. aStream nextPutAll: self cursorPoint printString; space. aStream nextPutAll: type; space. aStream nextPutAll: self direction; space. aStream nextPutAll: self modifierString. aStream nextPutAll: self buttonString. aStream nextPutAll: timeStamp printString; space. aStream nextPutAll: self windowIndex printString. aStream nextPut: $].! ! !MouseWheelEvent methodsFor: 'accessing' stamp: 'gvc 1/25/2008 17:40'! direction "Answer the value of direction" ^ direction! ! !MouseWheelEvent methodsFor: 'accessing' stamp: 'gvc 1/25/2008 17:40'! direction: anObject "Set the value of direction" direction := anObject! ! !MouseWheelEvent methodsFor: 'dispatching' stamp: 'gvc 1/25/2008 17:42'! sentTo: anObject "Dispatch the receiver into anObject" type == #mouseWheel ifTrue:[^anObject handleMouseWheel: self]. ^super sentTo: anObject. ! ! !MultiByteBinaryOrTextStream commentStamp: ''! It is similar to MultiByteFileStream, but works on in memory stream.! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'HenrikSperreJohansen 8/17/2012 11:29'! basicNext: anInteger putAll: aCollection startingAt: startIndex ^super next: anInteger putAll: aCollection startingAt: startIndex! ! !MultiByteBinaryOrTextStream methodsFor: 'filein/out' stamp: 'StephaneDucasse 2/3/2010 22:18'! setConverterForCode | current | current := converter saveStateOf: self. self position: 0. self binary. ((self next: 3) = #[239 187 191]) ifTrue: [ self converter: UTF8TextConverter new ] ifFalse: [ self converter: MacRomanTextConverter new. ]. converter restoreStateOf: self with: current. self text. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'md 10/20/2004 15:32'! basicNext: anInteger ^ super next: anInteger. ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:16'! binary isBinary := true ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNextPut: char ^ super nextPut: char. ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 8/7/2003 09:12'! converter: aConverter converter := aConverter. ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'nk 8/2/2004 17:02'! converter converter ifNil: [converter := self class defaultConverter]. ^ converter ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 16:39'! next | n | n := self converter nextFromStream: self. n ifNil: [^ nil]. isBinary and: [n isCharacter ifTrue: [^ n asciiValue]]. ^ n. ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:25'! isBinary ^ isBinary! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:25'! peekFor: item | next state | "self atEnd ifTrue: [^ false]. -- SFStream will give nil" state := converter saveStateOf: self. (next := self next) == nil ifTrue: [^ false]. item = next ifTrue: [^ true]. converter restoreStateOf: self with: state. ^ false. ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 16:33'! text isBinary := false ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 16:17'! skipSeparators [self atEnd] whileFalse: [ self basicNext isSeparator ifFalse: [ ^ self position: self position - 1]] ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 12/25/2003 16:04'! skipSeparatorsAndPeekNext "A special function to make nextChunk fast" | peek pos | [self atEnd] whileFalse: [ pos := self position. (peek := self next) isSeparator ifFalse: [ self position: pos. ^ peek. ]. ]. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicPosition: pos ^ super position: pos. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'LukasRenggli 5/8/2010 18:43'! nextPutAll: aCollection ^ self isBinary ifTrue: [ super nextPutAll: aCollection ] ifFalse: [ aCollection do: [ :each | self nextPut: each ] ]! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'PeterHugossonMiller 9/3/2009 10:07'! nextDelimited: terminator | out ch pos | out := (String new: 1000) writeStream. self atEnd ifTrue: [^ '']. pos := self position. self next = terminator ifFalse: [ "absorb initial terminator" self position: pos. ]. [(ch := self next) == nil] whileFalse: [ (ch = terminator) ifTrue: [ self peek = terminator ifTrue: [ self next. "skip doubled terminator" ] ifFalse: [ ^ out contents "terminator is not doubled; we're done!!" ]. ]. out nextPut: ch. ]. ^ out contents. ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:16'! ascii isBinary := false ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNextPutAll: aString ^ super nextPutAll: aString. ! ! !MultiByteBinaryOrTextStream methodsFor: 'filein/out' stamp: 'MarcusDenker 2/14/2010 09:30'! setEncoderForSourceCodeNamed: streamName | l | l := streamName asLowercase. ((l endsWith: 'cs') or: [ (l endsWith: 'st') or: [ (l endsWith: ('st.gz')) or: [ (l endsWith: ('st.gz'))]]]) ifTrue: [ self converter: MacRomanTextConverter new. ^ self. ]. self converter: UTF8TextConverter new. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicPeek ^ super peek ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 12/25/2003 16:04'! peek "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " | next pos | self atEnd ifTrue: [^ nil]. pos := self position. next := self next. self position: pos. ^ next. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNext: n into: aString ^ super next: n into: aString. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'LukasRenggli 5/8/2010 18:43'! nextPut: aCharacter ^ aCharacter isInteger ifTrue: [ super nextPut: aCharacter asCharacter ] ifFalse: [ self converter nextPut: aCharacter toStream: self ]! ! !MultiByteBinaryOrTextStream methodsFor: 'properties-setting' stamp: 'yo 11/14/2002 13:49'! setFileTypeToObject "do nothing. We don't have a file type"! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'nk 7/29/2004 12:02'! reset super reset. isBinary ifNil: [isBinary := false]. collection class == ByteArray ifTrue: ["Store as String and convert as needed." collection := collection asString. isBinary := true]. self converter. "ensure that we have a converter."! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'MarcusDenker 10/3/2013 23:52'! next: anInteger | multiString | self isBinary ifTrue: [^ (super next: anInteger) asByteArray]. multiString := WideString new: anInteger. 1 to: anInteger do: [:index | | character | (character := self next) ifNotNil: [ multiString at: index put: character ] ifNil: [ multiString := multiString copyFrom: 1 to: index - 1. ^ multiString ] ]. ^ multiString. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/14/2002 13:54'! padToEndWith: aChar "We don't have pages, so we are at the end, and don't need to pad."! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'monty 12/20/2013 00:29'! basicNext | nextChar | ^ isBinary ifTrue: [super next] ifFalse: [ (nextChar := super next) ifNotNil: [nextChar asCharacter]].! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:24'! nextMatchAll: aColl | save | save := converter saveStateOf: self. aColl do: [:each | (self next) = each ifFalse: [ converter restoreStateOf: self with: save. ^ false. ]. ]. ^ true. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicPosition ^ super position. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNextInto: aString ^ super nextInto: aString. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'PeterHugossonMiller 9/3/2009 10:08'! upTo: delim | out ch | out := (String new: 1000) writeStream. self atEnd ifTrue: [^ '']. [(ch := self next) isNil] whileFalse: [ (ch = delim) ifTrue: [ ^ out contents "terminator is not doubled; we're done!!" ]. out nextPut: ch. ]. ^ out contents. ! ! !MultiByteBinaryOrTextStream methodsFor: 'converting' stamp: 'yo 11/11/2002 13:16'! asBinaryOrTextStream ^ self ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'PeterHugossonMiller 9/3/2009 10:08'! upToEnd | newStream element newCollection | newCollection := self isBinary ifTrue: [ByteArray new: 100] ifFalse: [String new: 100]. newStream := newCollection writeStream. [(element := self next) notNil] whileTrue: [newStream nextPut: element]. ^ newStream contents ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'HenrikSperreJohansen 8/17/2012 11:35'! next: anInteger putAll: aCollection startingAt: startIndex (self isBinary or: [ aCollection class == ByteArray ]) ifTrue: [ ^super next: anInteger putAll: aCollection startingAt: startIndex ]. ^self converter next: anInteger putAll: aCollection startingAt: startIndex toStream: self! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 7/30/2004 06:59'! contents | ret state | state := converter saveStateOf: self. ret := self upToEnd. converter restoreStateOf: self with: state. ^ ret. ! ! !MultiByteBinaryOrTextStream class methodsFor: 'instance creation' stamp: 'ClementBera 7/26/2013 16:18'! on: aCollection encoding: encodingName | aTextConverter | encodingName ifNil: [aTextConverter := TextConverter default] ifNotNil: [aTextConverter := TextConverter newForEncoding: encodingName]. ^ (self on: aCollection) converter: aTextConverter! ! !MultiByteBinaryOrTextStream class methodsFor: 'instance creation' stamp: 'ClementBera 7/26/2013 16:27'! with: aCollection encoding: encodingName | aTextConverter | encodingName ifNil: [aTextConverter := TextConverter default] ifNotNil: [aTextConverter := TextConverter newForEncoding: encodingName]. ^ (self with: aCollection) converter: aTextConverter! ! !MultiByteBinaryOrTextStream class methodsFor: 'defaults' stamp: 'yo 2/25/2005 20:04'! defaultConverter ^ Latin1TextConverter new. ! ! !MultiByteFileStream commentStamp: ''! The central class to access the external file. The interface of this object is similar to good old StandardFileStream, but internally it asks the converter, which is a sub-instance of TextConverter, and do the text conversion. It also combined the good old CrLfFileStream. CrLfFileStream class>>new now returns an instance of MultiByteFileStream. There are several pitfalls: * You always have to be careful about the binary/text distinction. In #text mode, it usually interpret the bytes. * A few file pointer operations treat the file as uninterpreted byte no matter what. This means that if you use 'fileStream skip: -1', 'fileStream position: x', etc. in #text mode, the file position can be in the middle of multi byte character. If you want to implement some function similar to #peek for example, call the saveStateOf: and restoreStateOf: methods to be able to get back to the original state. * #lineEndConvention: and #wantsLineEndConversion: (and #binary) can cause some puzzling situation because the inst var lineEndConvention and wantsLineEndConversion are mutated. If you have any suggestions to clean up the protocol, please let me know.! !MultiByteFileStream methodsFor: 'private basic' stamp: 'HenrikSperreJohansen 8/17/2012 11:30'! basicNext: anInteger putAll: aCollection startingAt: startIndex ^super next: anInteger putAll: aCollection startingAt: startIndex! ! !MultiByteFileStream methodsFor: 'private' stamp: 'nice 1/18/2010 13:42'! setConverterForCode | current | (SourceFiles at: 2) ifNotNil: [self fullName = (SourceFiles at: 2) fullName ifTrue: [^ self]]. current := self converter saveStateOf: self. self position: 0. self binary. ((self next: 3) = #[ 16rEF 16rBB 16rBF ]) ifTrue: [ self converter: UTF8TextConverter new ] ifFalse: [ self converter: MacRomanTextConverter new. ]. converter restoreStateOf: self with: current. self text. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'md 10/17/2004 16:09'! basicNext: anInteger ^ super next: anInteger. ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'nice 5/10/2009 00:18'! converter: aConverter converter := aConverter. self installLineEndConventionInConverter ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicNextPut: char ^ super nextPut: char. ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'nice 5/10/2009 00:14'! binary super binary. self lineEndConvention: nil! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'nice 11/28/2009 13:06'! lineEndConvention: aSymbol (lineEndConvention := aSymbol) ifNotNil: [wantsLineEndConversion := true]. self installLineEndConventionInConverter! ! !MultiByteFileStream methodsFor: 'public' stamp: 'CamilloBruni 9/5/2012 11:26'! peekFor: item | next state | state := converter saveStateOf: self. (next := self next) == nil ifTrue: [^ false]. item = next ifTrue: [^ true]. converter restoreStateOf: self with: state. ^ false. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicReadInto: byteArray startingAt: startIndex count: count ^ super readInto: byteArray startingAt: startIndex count: count. ! ! !MultiByteFileStream methodsFor: 'fileIn/Out' stamp: 'HenrikSperreJohansen 2/9/2010 11:23'! basicChunk "If our buffer in collection contains an chunk with no embedded !!'s, nor any non-ascii characters, return that. This presumes the source code encoding is unambiguously ascii-compatible" | bufferIX goodString | "Not possible if read buffering disabled" collection ifNil: [^nil]. ^ ((bufferIX := (collection indexOf: $!! startingAt: position + 1) min: readLimit +1) > 0 and: [bufferIX < collection size and: [(collection at: bufferIX + 1) ~= $!! and: [goodString := collection copyFrom: position + 1 to: bufferIX - 1. goodString isAsciiString]]]) ifTrue: [ position := bufferIX. goodString]! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 2/21/2004 02:57'! ascii super ascii. self detectLineEndConvention. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicUpTo: delim ^ super upTo: delim. ! ! !MultiByteFileStream methodsFor: 'private' stamp: 'StephaneDucasse 5/3/2010 22:59'! requestDropStream: dropIndex "Needs to install proper converter" | result | result := super requestDropStream: dropIndex. result ifNotNil: [ converter ifNil: [self converter: UTF8TextConverter new]. lineEndConvention ifNil: [ self detectLineEndConvention] ]. ^result! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/24/2004 13:44'! next: n innerFor: aString | peekChar state | "if we just read a CR, and the next character is an LF, then skip the LF" aString size = 0 ifTrue: [^ aString]. (aString last = Character cr) ifTrue: [ state := converter saveStateOf: self. peekChar := self bareNext. "super peek doesn't work because it relies on #next" (peekChar notNil and: [peekChar ~= Character lf]) ifTrue: [ converter restoreStateOf: self with: state. ]. ]. ^ aString withSqueakLineEndings. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 04:00'! peek "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " | next save | self atEnd ifTrue: [^ nil]. save := converter saveStateOf: self. next := self next. converter restoreStateOf: self with: save. ^ next. ! ! !MultiByteFileStream methodsFor: 'open/close' stamp: 'HenrikSperreJohansen 11/20/2009 15:13'! open: fileName forWrite: writeMode | result | result := super open: fileName forWrite: writeMode. result ifNotNil: [ converter ifNil: [self converter: UTF8TextConverter new]. lineEndConvention ifNil: [ self detectLineEndConvention ] ]. ^result! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'ul 11/25/2009 01:22'! wantsLineEndConversion ^wantsLineEndConversion == true ! ! !MultiByteFileStream methodsFor: 'private' stamp: 'ul 11/25/2009 01:28'! installLineEndConventionInConverter converter ifNotNil: [ converter installLineEndConvention: ( (wantsLineEndConversion == true and: [ lineEndConvention notNil ]) "#doConversion is inlined here" ifTrue: [ LineEndStrings at: lineEndConvention ] ifFalse: [ nil ]) ]! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/24/2004 13:38'! bareNext ^ self converter nextFromStream: self. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:09'! basicVerbatim: aString ^ super verbatim: aString. ! ! !MultiByteFileStream methodsFor: 'open/close' stamp: 'nice 5/10/2009 00:18'! reset super reset. converter ifNil: [ self converter: UTF8TextConverter new. ]. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'ul 11/25/2009 01:28'! next: anInteger | multiString | self isBinary ifTrue: [^ super next: anInteger]. multiString := String new: anInteger. 1 to: anInteger do: [:index | | character | (character := self next) ifNotNil: [ multiString at: index put: character ] ifNil: [ multiString := multiString copyFrom: 1 to: index - 1. (wantsLineEndConversion == true and: [ lineEndConvention notNil ]) "#doConversion is inlined here" ifFalse: [ ^multiString ]. ^self next: anInteger innerFor: multiString ] ]. (wantsLineEndConversion == true and: [ lineEndConvention notNil ]) "#doConversion is inlined here" ifFalse: [ ^multiString ]. multiString := self next: anInteger innerFor: multiString. (multiString size = anInteger or: [self atEnd]) ifTrue: [ ^ multiString]. ^ multiString, (self next: anInteger - multiString size). ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'nice 12/7/2009 08:26'! upToAnyOf: delimiters do: aBlock ^self collectionSpecies new: 1000 streamContents: [ :stream | | ch | [ (ch := self next) == nil or: [ (delimiters includes: ch) and: [aBlock value: ch. true] ] ] whileFalse: [ stream nextPut: ch ] ]! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 8/28/2002 11:13'! nextMatchAll: aColl | save | save := converter saveStateOf: self. aColl do: [:each | (self next) = each ifFalse: [ converter restoreStateOf: self with: save. ^ false. ]. ]. ^ true. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicPosition ^ super position. ! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'tbn 5/10/2012 15:29'! detectLineEndConvention "Detect the line end convention used in this stream. The result may be either #cr, #lf or #crlf." | char numRead state | self isBinary ifTrue: [^ self error: 'Line end conventions are not used on binary streams']. wantsLineEndConversion == true ifFalse: [self lineEndConvention: nil. ^lineEndConvention]. self closed ifTrue: [self lineEndConvention: LineEndDefault. ^lineEndConvention]. "Default if nothing else found" numRead := 0. state := self converter saveStateOf: self. lineEndConvention := nil. [super atEnd not and: [numRead < LookAheadCount]] whileTrue: [char := self next. char = Lf ifTrue: [converter restoreStateOf: self with: state. self lineEndConvention: #lf. ^lineEndConvention]. char = Cr ifTrue: [self peek = Lf ifTrue: [self lineEndConvention: #crlf] ifFalse: [self lineEndConvention: #cr]. converter restoreStateOf: self with: state. ^ lineEndConvention]. numRead := numRead + 1]. converter restoreStateOf: self with: state. self lineEndConvention: LineEndDefault. ^ lineEndConvention! ! !MultiByteFileStream methodsFor: 'public' stamp: 'HenrikSperreJohansen 8/17/2012 11:36'! next: anInteger putAll: aCollection startingAt: startIndex (self isBinary or: [ aCollection class == ByteArray ]) ifTrue: [ ^super next: anInteger putAll: aCollection startingAt: startIndex ]. ^self converter next: anInteger putAll: aCollection startingAt: startIndex toStream: self! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicSkip: n ^ super skip: n. ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'nk 9/5/2004 12:57'! lineEndConvention ^lineEndConvention! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'nice 5/10/2009 00:17'! converter converter ifNil: [self converter: TextConverter defaultSystemConverter]. ^ converter ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'ul 12/3/2009 01:33'! next | char secondChar state | char := (converter ifNil: [ self converter ]) nextFromStream: self. (wantsLineEndConversion == true and: [ lineEndConvention notNil ]) "#doConversion is inlined here" ifTrue: [ char == Cr ifTrue: [ state := converter saveStateOf: self. secondChar := self bareNext. secondChar ifNotNil: [ secondChar == Lf ifFalse: [ converter restoreStateOf: self with: state ] ]. ^Cr ]. char == Lf ifTrue: [ ^Cr ] ]. ^char. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicSetToEnd ^ super setToEnd. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'ul 12/7/2009 23:35'! skipSeparators | state character | [ state := converter saveStateOf: self. (character := self next) ifNil: [ false ] ifNotNil: [ character isSeparator ] ] whileTrue. character ifNotNil: [ converter restoreStateOf: self with: state ]! ! !MultiByteFileStream methodsFor: 'remnant' stamp: 'kph 3/1/2009 15:50'! wantsLineEndConversion: aBoolean wantsLineEndConversion := aBoolean. lineEndConvention ifNil: [ self detectLineEndConvention ]. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'ul 12/8/2009 00:05'! skipSeparatorsAndPeekNext "Same as #skipSeparators, but returns the next character after the separators if such exists." | state character | [ state := converter saveStateOf: self. (character := self next) ifNil: [ false ] ifNotNil: [ character isSeparator ] ] whileTrue. character ifNotNil: [ converter restoreStateOf: self with: state. ^character ]. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicPosition: pos ^ super position: pos. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'LukasRenggli 5/8/2010 18:41'! nextPutAll: aCollection ^ (self isBinary or: [ aCollection class == ByteArray ]) ifTrue: [ super nextPutAll: aCollection ] ifFalse: [ self converter nextPutAll: aCollection toStream: self ]! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 03:26'! nextDelimited: terminator | out ch save | out := (String new: 1000) writeStream. self atEnd ifTrue: [^ '']. save := converter saveStateOf: self. self next = terminator ifFalse: [ "absorb initial terminator" converter restoreStateOf: self with: save. ]. [(ch := self next) == nil] whileFalse: [ (ch = terminator) ifTrue: [ self peek = terminator ifTrue: [ self next. "skip doubled terminator" ] ifFalse: [ ^ out contents "terminator is not doubled; we're done!!" ]. ]. out nextPut: ch. ]. ^ out contents. ! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/21/2004 02:56'! convertStringFromCr: aString | inStream outStream | lineEndConvention ifNil: [^ aString]. lineEndConvention == #cr ifTrue: [^ aString]. lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Cr with: Lf]. "lineEndConvention == #crlf" inStream := aString readStream. outStream := (String new: aString size) writeStream. [inStream atEnd] whileFalse: [outStream nextPutAll: (inStream upTo: Cr). (inStream atEnd not or: [aString last = Cr]) ifTrue: [outStream nextPutAll: CrLf]]. ^ outStream contents! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicNextPutAll: aString ^ super nextPutAll: aString. ! ! !MultiByteFileStream methodsFor: 'remnant' stamp: 'yo 8/28/2002 11:06'! accepts: aSymbol ^ converter accepts: aSymbol. ! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'ul 11/25/2009 01:22'! doConversion ^wantsLineEndConversion == true and: [ lineEndConvention notNil ]! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicPeek ^ super peek ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicNext: n into: aString ^ super next: n into: aString. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'LukasRenggli 5/8/2010 18:41'! nextPut: aCharacter aCharacter isInteger ifTrue: [ ^ super nextPut: aCharacter ]. (wantsLineEndConversion == true and: [ lineEndConvention notNil ]) "#doConversion is inlined here" ifTrue: [ aCharacter = Cr ifTrue: [ converter nextPutAll: (LineEndStrings at: lineEndConvention) toStream: self ] ifFalse: [ converter nextPut: aCharacter toStream: self ]. ^aCharacter ]. ^ self converter nextPut: aCharacter toStream: self ! ! !MultiByteFileStream methodsFor: 'fileIn/Out' stamp: 'JohanBrichau 6/11/2010 15:34'! nextChunk "Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character." | bufferIX goodString | self skipSeparators. ^ self parseLangTagFor: (self basicChunk ifNil: [String new: 1000 streamContents: [:stream | | character state | [(character := self next) == nil or: [character == $!! and: [state := converter saveStateOf: self.. self next ~~ $!!]]] whileFalse: [stream nextPut: character]. character ifNotNil: [converter restoreStateOf: self with: state.]]])! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicNextInto: aString ^ super nextInto: aString. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'ul 12/4/2009 19:08'! upTo: delimiter ^self collectionSpecies new: 1000 streamContents: [ :stream | | ch | [ (ch := self next) == nil or: [ ch = delimiter ] ] whileFalse: [ stream nextPut: ch ] ] ! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/21/2004 02:56'! convertStringToCr: aString | inStream outStream | lineEndConvention ifNil: [^ aString]. lineEndConvention == #cr ifTrue: [^ aString]. lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Lf with: Cr]. "lineEndConvention == #crlf" inStream := aString readStream. outStream := (String new: aString size) writeStream. [inStream atEnd] whileFalse: [outStream nextPutAll: (inStream upTo: Cr). (inStream atEnd not or: [aString last = Cr]) ifTrue: [outStream nextPut: Cr. inStream peek = Lf ifTrue: [inStream next]]]. ^ outStream contents! ! !MultiByteFileStream methodsFor: 'public' stamp: 'ul 12/6/2009 04:18'! upToEnd ^self collectionSpecies new: self size - self position streamContents: [ :stream | | element | [ (element := self next) == nil ] whileFalse: [ stream nextPut: element ] ] ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'SvenVanCaekenberghe 12/3/2012 22:59'! readInto: buffer startingAt: offset count: requestedCount "Read up to requestedCount elements into the given buffer starting at offset. Return the number of elements actually read. If I am binary or if buffer is a ByteArray, I skip decoding. Yes this is weird. This is a necessarily inefficient implementation, reading and decoding characters one by one." (self isBinary or: [ buffer class == ByteArray ]) ifTrue: [ ^ super readInto: buffer startingAt: offset count: requestedCount ]. 0 to: requestedCount - 1 do: [ :count | | element | (element := self next) ifNil: [ ^ count ]. buffer at: offset + count put: element ]. ^ requestedCount! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 8/6/2003 11:56'! fileInEncodingName: aString self converter: (TextConverter newForEncoding: aString). super fileIn. ! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:44'! initialize "MultiByteFileStream initialize" Cr := Character cr. Lf := Character lf. CrLf := String with: Cr with: Lf. LineEndStrings := Dictionary new. LineEndStrings at: #cr put: (String with: Character cr). LineEndStrings at: #lf put: (String with: Character lf). LineEndStrings at: #crlf put: (String with: Character cr with: Character lf). LookAheadCount := 2048. Smalltalk addToStartUpList: self. self startUp. ! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:45'! defaultToCRLF "MultiByteFileStream defaultToCRLF" LineEndDefault := #crlf.! ! !MultiByteFileStream class methodsFor: 'accessing' stamp: 'StephaneDucasse 10/18/2010 14:05'! lineEndDefault "Answer the default line-ending convention that will be used by default, which was determined at start-up by looking at platform attributes." ^ LineEndDefault ! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'cami 7/22/2013 18:26'! guessDefaultLineEndConvention "Lets try to guess the line end convention from what we know about the path name delimiter from FileDirectory." FileSystem disk delimiter = $: ifTrue: [^ self defaultToCR]. FileSystem disk delimiter = $/ ifTrue: [^ (Smalltalk os isMacOSX or: [Smalltalk os isUnix]) ifTrue: [ self defaultToLF] ifFalse: [ self defaultToCR]]. FileSystem disk delimiter = $\ ifTrue: [^ self defaultToCRLF]. "in case we don't know" ^ self defaultToCR! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:46'! defaultToLF "MultiByteFileStream defaultToLF" LineEndDefault := #lf. ! ! !MultiByteFileStream class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 11:43'! newFrom: aFileStream | rw n | n := aFileStream name. rw := aFileStream isReadOnly not. aFileStream close. ^self new open: n forWrite: rw. ! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:44'! startUp self guessDefaultLineEndConvention. ! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:45'! defaultToCR "MultiByteFileStream defaultToCR" LineEndDefault := #cr. ! ! !MultiByteFileStreamTest commentStamp: 'TorstenBergmann 2/5/2014 10:18'! SUnit tests for MultiByteFileStream ! !MultiByteFileStreamTest methodsFor: 'testing' stamp: 'SeanDeNigris 7/12/2012 08:44'! testBinaryUpTo "This is a non regression test for bug http://bugs.squeak.org/view.php?id=6933" "self run: #testBinaryUpTo" | foo fileName | fileName := 'foobug6933'. MultiByteFileStream forceNewFileNamed: fileName do: [ :stream | stream binary. stream nextPutAll: #[1 2 3 4] ]. foo := MultiByteFileStream oldFileNamed: fileName. [foo binary. self assert: (foo upTo: 3) = #[1 2] ] ensure: [ foo close. fileName asFileReference delete]. ! ! !MultiByteFileStreamTest methodsFor: 'testing' stamp: 'HenrikSperreJohansen 5/19/2011 10:16'! testLineEndingsWith: anEncodingName | byteMap | "Make a map of different endings, and the expected byte pattern when three cr's are added using it" byteMap := Dictionary new. byteMap at: #cr put: #[13 13 13]; at: #lf put: #[10 10 10]; at: #crlf put: #[13 10 13 10 13 10]. byteMap keysDo: [:lineEnding | FileStream forceNewFileNamed: self lineEndTestFile do: [:stream | stream lineEndConvention: lineEnding; converter: (TextConverter newForEncoding: anEncodingName). "Test 3 cases: Use of nextPut, nextPutAll:, and nextPutAll with WideStrings" stream nextPut: Character cr; nextPutAll: Character cr asString; nextPutAll: Character cr asString asWideString.]. FileStream oldFileNamed: self lineEndTestFile do: [:stream | | bytes expected| bytes := stream binary; contents. self assert: bytes equals: (byteMap at: lineEnding)]]! ! !MultiByteFileStreamTest methodsFor: 'support' stamp: 'HenrikSperreJohansen 5/19/2011 09:53'! lineEndTestFile ^'lineEndTesting.txt'! ! !MultiByteFileStreamTest methodsFor: 'testing' stamp: 'SeanDeNigris 7/12/2012 08:44'! testBasicChunk | internalStream chunkKey | internalStream := self chunkString readStream. chunkKey := OrderedCollection new. [internalStream atEnd] whileFalse: [ | chunk | chunk := internalStream nextChunk. chunkKey add: {internalStream position. chunk size. chunk}]. [self writeChunkToFile. FileStream readOnlyFileNamed: 'chunkTest.txt' do: [:fileStream | 1 to: chunkKey size do: [:ix | |chunk| chunk := fileStream nextChunk. self assert: (chunkKey at: ix) first equals: fileStream position. self assert: (chunkKey at: ix) second equals: chunk size. self assert: (chunkKey at: ix) last equals: chunk.]]. ] ensure: [ 'chunkTest.txt' asFileReference delete]! ! !MultiByteFileStreamTest methodsFor: 'testing' stamp: 'StephaneDucasse 6/17/2013 15:55'! tearDown 'foobug6933' asFileReference ensureDelete. self lineEndTestFile asFileReference ensureDelete.! ! !MultiByteFileStreamTest methodsFor: 'support' stamp: 'HenrikSperreJohansen 2/9/2010 11:10'! writeChunkToFile FileStream forceNewFileNamed: 'chunkTest.txt' do: [:stream | stream nextPutAll: self chunkString]! ! !MultiByteFileStreamTest methodsFor: 'testing' stamp: 'S 6/17/2013 13:16'! testReadIntoStartingAtCount | testString filename buffer | testString := 'élève en Français'. filename := 'test-file-' , 99 atRandom printString , '.txt'. filename asFileReference ensureDelete. filename asFileReference writeStreamDo: [ :stream | stream nextPutAll: testString; crlf ]. buffer := String new: testString size. [ filename asFileReference readStreamDo: [ :stream | self assert: (stream readInto: buffer startingAt: 1 count: testString size) equals: testString size. self assert: buffer equals: testString ] ] ensure: [ filename asFileReference ensureDelete ]! ! !MultiByteFileStreamTest methodsFor: 'support' stamp: 'HenrikSperreJohansen 5/19/2011 09:53'! chunkString "A chunk larger than buffer (currently 2048), but not long enough to fill it completely again. Therefore, buffer should contain some elements at end that are not part of the real buffer" | smallChunk chunkString | chunkString := String new: (MultiByteFileStream new ascii enableReadBuffering braceArray size * 1.3) floor. smallChunk := 'ASDFASDFASDFASDFasdfasdfasdfasdfQWERQWERQWERqwerqwerqwer!! !!'. 1 to: chunkString size by: smallChunk size do: [:ix | chunkString replaceFrom: ix to: (ix + smallChunk size -1 min: chunkString size) with: smallChunk startingAt: 1]. ^chunkString! ! !MultiCanvas commentStamp: ''! A canvas which forwards drawing commands to sub-canvases.! !MultiCanvas methodsFor: 'accessing' stamp: 'RAA 8/14/2000 10:27'! contentsOfArea: aRectangle into: aForm self apply: [ :c | (c isKindOf: FormCanvas) ifTrue: [ c contentsOfArea: aRectangle into: aForm. ^aForm ]. ]. self apply: [ :c | c contentsOfArea: aRectangle into: aForm. ^aForm. ]. ^aForm! ! !MultiCanvas methodsFor: 'accessing' stamp: 'ls 4/8/2000 22:35'! extent ^extent! ! !MultiCanvas methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:11'! initialize super initialize. canvases := Set new. extent := 600@400. depth := 32. ! ! !MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:34'! extent: newExtent "set the extent to be used with this canvas" extent := newExtent.! ! !MultiCanvas methodsFor: 'private' stamp: 'RAA 11/6/2000 14:17'! apply: aCommand self flag: #roundedRudeness. "This rudeness is to help get rounded corners to work right on RemoteCanvases. Since the RemoteCanvas has no other way to read its bits, we are grabbing them from Display for now. To support this, we need to see that the Display is written before any RemoteCanvases" canvases do: [ :canvas | (canvas isKindOf: FormCanvas) ifTrue: [aCommand value: canvas] ]. canvases do: [ :canvas | (canvas isKindOf: FormCanvas) ifFalse: [aCommand value: canvas] ]. ! ! !MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:35'! depth: newDepth "set the extent to be used with this canvas" depth := newDepth.! ! !MultiCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:48'! removeCanvas: aCanvas canvases remove: aCanvas ifAbsent: []! ! !MultiCanvas methodsFor: 'initialization' stamp: 'RAA 8/1/2000 13:50'! allocateForm: extentPoint "Allocate a new form which is similar to the receiver and can be used for accelerated blts" ^Form extent: extentPoint depth: self depth! ! !MultiCanvas methodsFor: 'accessing' stamp: 'RAA 11/7/2000 17:46'! clipRect ^super clipRect ifNil: [ 0@0 extent: 5000@5000 ].! ! !MultiCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:48'! addCanvas: aCanvas canvases add: aCanvas! ! !MultiCanvas methodsFor: 'accessing' stamp: 'ls 4/8/2000 22:35'! depth ^depth! ! !MultiColumnListModel commentStamp: ''! A MultiColumnListModel is a spec model for Multi columns list! !MultiColumnListModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 7/14/2012 16:41'! listElementAt: anIndex ^ self wrapItem: (self listItems at: anIndex) index: anIndex ! ! !MultiColumnListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! setSelectedIndex: anIndex "Set the index of the item you want to be selected" | idx selection | self allowToSelect ifFalse: [ ^ self ]. self okToChange ifFalse: [ ^ self ]. self listSize isZero ifTrue: [ ^self ]. idx := anIndex min: self listSize. selection := self listItems at: idx ifAbsent: [ idx := 0. nil ]. selectionHolder index value: idx. selectionHolder selection value: selection.! ! !MultiColumnListModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! setIndex: anIndex self allowToSelect ifFalse: [ ^ self ]. self okToChange ifFalse: [ ^ self ]. selectionHolder index value: anIndex. selectionHolder selection value: (self listItems at: anIndex ifAbsent: [ nil ]).! ! !MultiColumnListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 13:38'! defaultSpec ^ #(MultiColumnListAdapter adapt: #(model))! ! !MultiColumnListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:21'! adapterName ^ #MultiColumnListAdapter! ! !MulticolumnLazyListMorph commentStamp: ''! A variant of LazyListMorph that can display multi-column lists.! !MulticolumnLazyListMorph methodsFor: 'row management' stamp: 'BenjaminVanRyseghem 2/21/2013 23:17'! display: items atRow: row on: canvas "display the specified item, which is on the specified row; for Multicolumn lists, items will be a list of strings" | drawBounds backgroundColor | backgroundColor := self backgroundColorForRow: row. drawBounds := self drawBoundsForRow: row. drawBounds := drawBounds intersect: self bounds ifNone: [ "oh well" ^ self ]. items with: (1 to: items size) do: [ :item :index | "move the bounds to the right at each step" index > 1 ifTrue: [ drawBounds := drawBounds left: drawBounds left + listSource gapSize + (columnWidths at: index - 1) ]. item listRenderOn: canvas atRow: row bounds: drawBounds color: color backgroundColor: backgroundColor from: self ]! ! !MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 9/8/2011 12:33'! drawOn: aCanvas self getListSize = 0 ifTrue:[ ^self ]. self setColumnWidthsFor: aCanvas. self adjustWidth. super drawOn: aCanvas! ! !MulticolumnLazyListMorph methodsFor: 'scroll range' stamp: 'BenjaminVanRyseghem 2/12/2012 00:26'! widthToDisplayItem: item "This class will be removed soon, so this method will disappear" | widths | widths := item collect: [ :each | each widthToDisplayInList: self ]. ^widths sum + ((listSource gapSize + 4) * (widths size - 1)) "add in space between the columns" ! ! !MulticolumnLazyListMorph methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 7/25/2012 11:57'! drawBoundsForRow: row "calculate the bounds that row should be drawn at. This might be outside our bounds!!" | topLeft drawBounds item width height | item := self getListItem: row. height := (item collect: [:e | e heightToDisplayInList: self ]) max. width := self width. topLeft := self topLeft x @ (self topLeft y + ((row - 1) * (height))). drawBounds := topLeft extent: (width @ height). ^drawBounds! ! !MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'sps 3/23/2004 15:51'! setColumnWidthsFor: aCanvas | row topRow bottomRow | "set columnWidths for drawing on the specified canvas" columnWidths ifNil: [ columnWidths := (self item: 1) collect: [ :ignored | 0 ]. ]. topRow := (self topVisibleRowForCanvas: aCanvas) max: 1. bottomRow := (self bottomVisibleRowForCanvas: aCanvas) max: 1. topRow > bottomRow ifTrue: [ ^ self ]. topRow to: bottomRow do: [ :rowIndex | row := self item: rowIndex. columnWidths := columnWidths with: row collect: [ :currentWidth :item | | widthOfItem | widthOfItem := (font widthOfStringOrText: item). widthOfItem > currentWidth ifTrue: [ self changed. widthOfItem ] ifFalse: [ currentWidth ] ] ]! ! !MulticolumnLazyListMorph methodsFor: 'row management' stamp: 'ls 5/18/2001 16:43'! listChanged columnWidths := nil. super listChanged! ! !MulticolumnLazyListMorph methodsFor: 'list access' stamp: 'ls 5/17/2001 21:23'! getListItem: index ^listSource getListRow: index! ! !MulticolumnLazyListMorph methodsFor: 'scroll range' stamp: 'BenjaminVanRyseghem 2/19/2012 18:22'! hUnadjustedScrollRange "bvr - Introduce here the old version of the super method just waiting for this class to be deleted" | itemsToCheck item index | "Check for a cached value" maxWidth ifNotNil:[^maxWidth]. listItems isEmpty ifTrue: [^0]. "don't set maxWidth if empty do will be recomputed when there are some items" "Compute from scratch" itemsToCheck := 30 min: (listItems size). maxWidth := 0. "Check the first few items to get a representative sample of the rest of the list." index := 1. [index < itemsToCheck] whileTrue: [ item := self getListItem: index. "Be careful not to actually install this item" maxWidth := maxWidth max: (self widthToDisplayItem: item). index:= index + 1. ]. "Add some initial fudge if we didn't check all the items." (itemsToCheck < listItems size) ifTrue:[maxWidth := maxWidth*2]. ^maxWidth + 150 ! ! !MulticolumnLazyListMorph methodsFor: 'list access' stamp: 'BenjaminVanRyseghem 2/15/2012 16:52'! item: index "return the index-th item, using the 'listItems' cache" | newItem itemWidth | (index between: 1 and: listItems size) ifFalse: [ "there should have been an update, but there wasn't!!" ^self getListItem: index]. (listItems at: index) ifNil: [ newItem := self getListItem: index. maxWidth ifNotNil:[ itemWidth := self widthToDisplayItem: newItem. itemWidth > maxWidth ifTrue:[ maxWidth := itemWidth. self adjustWidth. ]]. listItems at: index put: newItem ]. ^listItems at: index! ! !MultipleMethodsEditor commentStamp: ''! A MultipleMethodsEditor is a widget to edit multiple methods in one widget! !MultipleMethodsEditor methodsFor: 'updating' stamp: 'IgorStasenko 12/19/2012 18:04'! updateLayoutForSingle current ifNil: [ ^ self ]. self addMorph: current fullFrame: LayoutFrame identity. current color: Color white. ! ! !MultipleMethodsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/5/2012 19:47'! hasSingleElement ^ editors size = 1! ! !MultipleMethodsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 19:33'! setDefault current := editors first! ! !MultipleMethodsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/5/2012 21:41'! addEditor: anEditor editors addFirst: anEditor. anEditor vResizing: #spaceFill; hResizing: #spaceFill. anEditor when: #vScroll send: #scrollFromEditor: to: self. current := anEditor. self updateScroller! ! !MultipleMethodsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 18:25'! updateButtonsStateFrom: aModel (buttonsContainer submorphs last: (editors size+1)) do:[:e | e model == aModel ifFalse: [ e model setState: false ]. e update: #state ]! ! !MultipleMethodsEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/6/2012 18:01'! newButtonFor: e value: buttonValue label: label | model | model := MultipleMethodsEditorButtonModel on: self value: buttonValue label: label target: e. ^ PluggableButtonMorph on: model getState: #state action: #action label: #label! ! !MultipleMethodsEditor methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 8/6/2012 18:00'! newAllButton | model | model := MultipleMethodsEditorAllButtonModel on: self. ^ PluggableButtonMorph on: model getState: #state action: #action label: #label! ! !MultipleMethodsEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/5/2012 22:04'! newProportionalPanelMorph | panel | panel := PanelMorph new color: Color white; changeProportionalLayout; yourself. ^ panel! ! !MultipleMethodsEditor methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 8/6/2012 17:59'! addAllButton buttonsContainer addMorph: self newAllButton! ! !MultipleMethodsEditor methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:05'! initialize super initialize. self changeProportionalLayout. self color: Color white. lock := false. buttonsContainer := PanelMorph new changeTableLayout; listDirection: #rightToLeft; hResizing: #spaceFill; vResizing: #spaceFill; yourself. editors := OrderedCollection new. container := self newProportionalPanelMorph. self updateLayoutForSingle! ! !MultipleMethodsEditor methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 8/6/2012 18:08'! updateEditorsWith: firstHeight over: totalHeight into: panel | cumulatedHeight size | size := editors size. cumulatedHeight := 0. editors doWithIndex: [ :e :i | | height newCumulatedHeight | height := i == 1 ifTrue: [ firstHeight ] ifFalse: [ e vResizing: #rigid. e height ]. newCumulatedHeight := cumulatedHeight + (height / totalHeight). panel addMorph: e fullFrame: (self layoutFor: i startingAt: cumulatedHeight finishingAt: newCumulatedHeight). i == size ifFalse: [ | below | below := editors at: i + 1. self addSplitterBetween: e and: below to: panel at: newCumulatedHeight ]. cumulatedHeight := newCumulatedHeight ]! ! !MultipleMethodsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 18:04'! setCurrent: anEditor (editors includes: anEditor) ifFalse: [ ^ self ]. current := anEditor! ! !MultipleMethodsEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/5/2012 22:04'! addHFill buttonsContainer addMorph: (Morph new hResizing: #spaceFill; height: 0; yourself)! ! !MultipleMethodsEditor methodsFor: 'protocol' stamp: 'CamilloBruni 9/17/2012 21:18'! giveFocusToDefault self hasSingleElement ifTrue: [ ^ self ]. buttonsContainer submorphs copy reversed second model action! ! !MultipleMethodsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/5/2012 19:47'! hasMultipleElements ^ editors size > 1! ! !MultipleMethodsEditor methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 8/6/2012 18:10'! updateScrollerWithMultipleElements | size panel totalHeight delta scroller firstHeight | delta := editors second font height * 2 + 10. size := editors size. firstHeight := self height - delta. totalHeight := (editors allButFirst inject: 0 into: [ :s :e | s + e height ]) + firstHeight + ((size - 1) * 4). panel := self newProportionalPanelMorph. scroller := TransformWithLayoutMorphForMultipleEditors new. container := self newScrollPaneWithScroller: scroller target: panel. container scroller changeTableLayout. self updateEditorsWith: firstHeight over: totalHeight into: panel. self addAllButton. self addButtons. self addHFill. panel hResizing: #spaceFill. panel extent: 0 @ (totalHeight - delta)! ! !MultipleMethodsEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/6/2012 18:06'! newButtonFor: e label: label | model | model := MultipleMethodsEditorButtonModel on: self label: label target: e. ^ PluggableButtonMorph on: model getState: #state action: #action label: #label! ! !MultipleMethodsEditor methodsFor: 'private' stamp: 'IgorStasenko 12/20/2012 14:43'! layoutFor: i startingAt: cumulatedHeight finishingAt: newCumulatedHeight ^ (0 @ cumulatedHeight corner: 1 @ newCumulatedHeight) asLayoutFrame topOffset: (i == 1 ifTrue: [ 0 ] ifFalse: [ 2 ]); bottomOffset: (i == editors size ifTrue: [ 0 ] ifFalse: [ -2 ])! ! !MultipleMethodsEditor methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 8/6/2012 18:23'! updateScrollerWithMultipleElementsWithoutButtons | size panel totalHeight delta scroller firstHeight | delta := editors second font height * 2 + 10. size := editors size. firstHeight := self height - delta. totalHeight := (editors allButFirst inject: 0 into: [ :s :e | s + e height ]) + firstHeight + ((size - 1) * 4). panel := self newProportionalPanelMorph. scroller := TransformWithLayoutMorphForMultipleEditors new. container := self newScrollPaneWithScroller: scroller target: panel. container scroller changeTableLayout. self updateEditorsWith: firstHeight over: totalHeight into: panel. panel hResizing: #spaceFill. panel extent: 0 @ (totalHeight - delta)! ! !MultipleMethodsEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/5/2012 21:40'! scrollFromEditor: aValue self hasMultipleElements ifFalse: [ ^ self ]. lock ifTrue: [ ^ self ]. lock := true. aValue = 0 ifTrue: [ container vScrollbar setValue: container vScrollbar value - 0.1 ]. aValue = 1 ifTrue: [ container vScrollbar setValue: container vScrollbar value + 0.1 ]. lock := false! ! !MultipleMethodsEditor methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 8/6/2012 18:13'! addButtons editors doWithIndex: [ :e :i | | button | (i == 1) ifTrue: [ button := self newButtonFor: e label: 'current'] ifFalse: [ button := self newButtonFor: e label: (i-1) printString . button setBalloonText: e balloonText ]. buttonsContainer addMorph: button ]! ! !MultipleMethodsEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/5/2012 21:49'! newScrollPaneWithScroller: scroller target: target | pane | pane := GeneralScrollPane new removeAllMorphs; scroller: scroller; yourself. pane scrollTarget: target; addMorph: scroller; resizeScroller; hScrollbarShowNever. ^ pane! ! !MultipleMethodsEditor methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 8/5/2012 22:11'! updateScrollerWithOneElement "container addMorph: current fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1))"! ! !MultipleMethodsEditor methodsFor: 'private' stamp: 'IgorStasenko 12/19/2012 18:02'! addSplitterBetween: e and: below to: panel at: newCumulatedHeight | splitter | splitter := ProportionalSplitterMorph new beSplitsTopAndBottom; yourself. splitter addLeftOrTop: e; addRightOrBottom: below. panel addMorph: splitter fullFrame: ((0 @ newCumulatedHeight corner: 1 @ newCumulatedHeight) asLayoutFrame topOffset: -2 ; bottomOffset: 2)! ! !MultipleMethodsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 19:36'! rgiveFocusToCurrent self hasSingleElement ifTrue: [ ^ self ]. self setDefault. self updateLayoutForSingleWithButtons! ! !MultipleMethodsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 00:55'! removeEditor: anEditor editors remove: anEditor. current = anEditor ifTrue: [ current := editors at: 1 ifAbsent:[ nil ]]. self updateScroller! ! !MultipleMethodsEditor methodsFor: 'updating' stamp: 'NicolaiHess 12/4/2013 11:00'! updateLayoutForSingleWithButtons current ifNil: [ ^ self ]. self addMorph: current fullFrame: (LayoutFrame identity bottomOffset: -25). self addMorph: buttonsContainer fullFrame: ((0@1 corner: 1@1) asLayoutFrame topOffset: -25). current color: Color white. ! ! !MultipleMethodsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/5/2012 21:41'! updateScroller container removeAllMorphs. buttonsContainer removeAllMorphs. self hasSingleElement ifTrue: [ self updateScrollerWithOneElement; updateLayoutForSingle] ifFalse: [ self updateScrollerWithMultipleElements; updateLayoutForMultiple ]. ! ! !MultipleMethodsEditor methodsFor: 'updating' stamp: 'IgorStasenko 12/19/2012 18:04'! updateLayoutForMultiple self addMorph: container fullFrame: (LayoutFrame identity bottomOffset: -25). self addMorph: buttonsContainer fullFrame: ((0@1 corner: 1@1) asLayoutFrame topOffset: -25).! ! !MultipleMethodsEditorAllButtonModel commentStamp: ''! I am model for multiple methods editor (the -All- button)! !MultipleMethodsEditorAllButtonModel methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:05'! initialize super initialize. state := true.! ! !MultipleMethodsEditorAllButtonModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 18:00'! model ^ model! ! !MultipleMethodsEditorAllButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 18:18'! state ^ state! ! !MultipleMethodsEditorAllButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 17:58'! label ^ 'All'! ! !MultipleMethodsEditorAllButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 18:22'! setState: aBoolean state := aBoolean! ! !MultipleMethodsEditorAllButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 18:24'! action self model updateScrollerWithMultipleElementsWithoutButtons; updateLayoutForMultiple. state := true. self changed: #state. self model updateButtonsStateFrom: self! ! !MultipleMethodsEditorAllButtonModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 18:00'! model: anObject model := anObject! ! !MultipleMethodsEditorAllButtonModel class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 8/6/2012 18:00'! on: aModel ^ self new model: aModel; yourself! ! !MultipleMethodsEditorButtonModel commentStamp: ''! A MultipleMethodsEditorButtonModel is a ButtonModel created for MultipleMethodsEditor! !MultipleMethodsEditorButtonModel methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:05'! initialize super initialize. state := false! ! !MultipleMethodsEditorButtonModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 18:02'! model ^ model! ! !MultipleMethodsEditorButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 18:18'! state ^ state! ! !MultipleMethodsEditorButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/5/2012 20:01'! label ^ label ifNil: [ '' ] ifNotNil: [:l | l ]! ! !MultipleMethodsEditorButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 18:26'! setState: aBoolean state := aBoolean! ! !MultipleMethodsEditorButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 18:17'! action self model ifNil: [ ^ self ]. self target ifNil: [ ^ self ]. self target vScrollValue: 0. self model setCurrent: self target. self model updateLayoutForSingleWithButtons. state := true. self changed: #state. self model updateButtonsStateFrom: self! ! !MultipleMethodsEditorButtonModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/5/2012 19:59'! label: anObject label := anObject! ! !MultipleMethodsEditorButtonModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 18:02'! model: anObject model := anObject! ! !MultipleMethodsEditorButtonModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/5/2012 21:42'! target ^ target! ! !MultipleMethodsEditorButtonModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/5/2012 21:42'! target: anObject target := anObject! ! !MultipleMethodsEditorButtonModel class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 8/6/2012 18:04'! on: aScroller value: value label: label target: target ^ self new model: aScroller; vScrollValue: value; label: label; target: target; yourself! ! !MultipleMethodsEditorButtonModel class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 8/6/2012 18:07'! on: aScroller label: label target: target ^ self new model: aScroller; label: label; target: target; yourself! ! !MultipleSettingDeclaration commentStamp: 'TorstenBergmann 1/31/2014 10:30'! A declaration for multiple settings! !MultipleSettingDeclaration methodsFor: 'accessing' stamp: 'AlainPlantec 9/3/2010 15:51'! domainValues ^ domainValues ifNil: [domainValues := OrderedCollection new]! ! !MultipleSettingDeclaration methodsFor: 'user interface' stamp: 'AlainPlantec 11/25/2009 22:09'! hasEditableList ^ false! ! !MultipleSettingDeclaration methodsFor: 'user interface' stamp: 'AlainPlantec 9/3/2010 17:04'! fixedDomainValueNodeForAssociation: anAssociation | s | ^ (s := (SettingDeclaration new name: anAssociation key)) target: s; selector: #default; default: anAssociation value! ! !MultipleSettingDeclaration methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2009 22:09'! domainValues: aCollection domainValues := aCollection asArray collect: [ :v | v settingFixedDomainValueNodeFrom: self]! ! !MultipleSettingDeclaration methodsFor: 'user interface' stamp: 'AlainPlantec 11/25/2009 22:09'! domainValuesLabels ^ self domainValues collect: [:f | f name]! ! !MultipleSettingDeclaration methodsFor: 'user interface' stamp: 'AlainPlantec 9/3/2010 17:04'! fixedDomainValueNodeForObject: anObject | s | ^ (s := (SettingDeclaration new name: anObject asString)) target: s; selector: #default; default: anObject! ! !MultistateButtonMorph commentStamp: 'gvc 10/21/2008 13:27'! A simple button that handles multiple fillstyle states: Normal Mouse-over Mouse-down-inside Mouse-down outside with variants being a combination of passive/active and enabled/disabled.! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:28'! enabled "Answer whether the button is rnabled." ^enabled! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:17'! activeDisabledOverUpFillStyle: aFillStyle "Set the active, disabled, over, up fill style." self stateMap atPath: #(active disabled over up) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:34'! mouseUp: evt "Handle a mouse up event." super mouseUp: evt. self enabled ifFalse: [^self]. self down: false. (self containsPoint: evt cursorPoint) ifTrue: [self triggerEvent: #up] ifFalse: [self triggerEvent: #upOutside]! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! passiveDisabledNotOverDownFillStyle: aFillStyle "Set the passive, disabled, notOver, down fill style." self stateMap atPath: #(passive disabled notOver down) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! passiveEnabledNotOverUpFillStyle: aFillStyle "Set the passive, enabled, notOver, up fill style." self stateMap atPath: #(passive enabled notOver up) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:32'! handlesMouseDown: evt "Yes." ^true! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:17'! activeEnabledOverDownFillStyle: aFillStyle "Set the active, enabled, over, down fill style." self stateMap atPath: #(active enabled over down) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:31'! over "Answer the value of over" ^ over! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 15:55'! activeEnabledNotOverDownFillStyle: aFillStyle "Set the active, enabled, notOver, down fill style." self stateMap atPath: #(active enabled notOver down) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'updating' stamp: 'gvc 9/11/2009 17:05'! changed "Update the fillStyle here." self assureExtension. extension fillStyle: self fillStyleToUse. color := self fillStyle asColor. super changed! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:27'! handlesMouseOver: anEvent "Answer true, otherwise what is all that #mouseEnter:/#mouseLeave: stuff about?" ^true! ! !MultistateButtonMorph methodsFor: 'initialization' stamp: 'gvc 10/21/2008 16:07'! initialize "Initialize the receiver." self stateMap: KeyedTree new. enabled := true. active := true. over := false. down := false. super initialize! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! over: anObject "Set the value of over" over := anObject. self changed! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:31'! mouseEnterDragging: evt "Handle a mouseEnterDragging event, meaning the mouse just entered my bounds with a button pressed or laden with submorphs." super mouseEnterDragging: evt. self over: true! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:38'! addUpAction: anActionOrBlock "Add an up event handler." self when: #up evaluate: anActionOrBlock! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! enabled: anObject "Set the value of enabled" enabled := anObject. self changed! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:34'! handlesMouseOverDragging: evt "Yes, for other states." ^true! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:30'! mouseLeaveDragging: evt "Handle a mouseLeaveLaden event, meaning the mouse just left my bounds with a button pressed or laden with submorphs." super mouseLeaveDragging: evt. self over: false! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:50'! activate "Make active." super activate. self active: true! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:16'! activeDisabledNotOverUpFillStyle: aFillStyle "Set the active, disabled, notOver, up fill style." self stateMap atPath: #(active disabled notOver up) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! passiveDisabledOverDownFillStyle: aFillStyle "Set the passive, disabled, over, down fill style." self stateMap atPath: #(passive disabled over down) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:28'! stateMap: anObject "Set the value of stateMap" stateMap := anObject! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 12:32'! extent: aPoint "Center the fill style origin." |delta| self bounds extent = aPoint ifTrue: [^self]. delta := aPoint - self extent // 2. self fillStyles do: [:fs | fs isOrientedFill ifTrue: [fs origin: fs origin + delta]]. super extent: aPoint! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! down: anObject "Set the value of down" down := anObject. self changed! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:38'! addDownAction: anActionOrBlock "Add a down event handler." self when: #down evaluate: anActionOrBlock! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:28'! active "Answer the value of active" ^ active! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! passiveDisabledNotOverUpFillStyle: aFillStyle "Set the passive, disabled, notOver, up fill style." self stateMap atPath: #(passive disabled notOver up) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! active: anObject "Set the value of active" active := anObject. self changed! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:45'! passiveEnabledOverUpFillStyle: aFillStyle "Set the passive, enabled, over, up fill style." self stateMap atPath: #(passive enabled over up) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:11'! privateMoveBy: delta "Adjust all the fill styles" super privateMoveBy: delta. (self fillStyles copyWithout: self fillStyle) do: [:fs | fs isOrientedFill ifTrue: [fs origin: fs origin + delta]]! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:31'! down "Answer the value of down" ^ down! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:39'! removeUpActions "Remove all up event handlers" self removeActionsForEvent: #up! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 15:55'! activeEnabledNotOverUpFillStyle: aFillStyle "Set the active, enabled, notOver, up fill style." self stateMap atPath: #(active enabled notOver up) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:13'! fillStyles "Answer all the fill styles" |styles| styles := OrderedCollection new. self stateMap do: [:actives | actives do: [:enableds | enableds do: [:overs | overs do: [:fs | styles add: fs]]]]. ^styles! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/1/2011 14:25'! mouseEnter: evt "Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed." super mouseEnter: evt. self over: true! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 15:55'! activeEnabledOverUpFillStyle: aFillStyle "Set the active, enabled, over, up fill style." self stateMap atPath: #(active enabled over up) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! passiveEnabledNotOverDownFillStyle: aFillStyle "Set the passive, enabled, notOver, down fill style." self stateMap atPath: #(passive enabled notOver down) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:28'! stateMap "Answer the value of stateMap" ^ stateMap! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:01'! fillStyleToUse "Answer the fill style to used based on the current state." |map| map := self active ifTrue: [self stateMap at: #active ifAbsent: [self stateMap at: #passive ifAbsent: [Dictionary new]]] ifFalse: [self stateMap at: #passive ifAbsent: [self stateMap at: #active ifAbsent: [Dictionary new]]]. map := self enabled ifTrue: [map at: #enabled ifAbsent: [map at: #disabled ifAbsent: [Dictionary new]]] ifFalse: [map at: #disabled ifAbsent: [map at: #enabled ifAbsent: [Dictionary new]]]. map := self over ifTrue: [map at: #over ifAbsent: [map at: #notOver ifAbsent: [Dictionary new]]] ifFalse: [map at: #notOver ifAbsent: [map at: #over ifAbsent: [Dictionary new]]]. ^map at: (self down ifTrue: [#down] ifFalse: [#up]) ifAbsent: [ map at: (self down ifTrue: [#up] ifFalse: [#down]) ifAbsent: [Color transparent]]! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:39'! removeDownActions "Remove all down event handlers" self removeActionsForEvent: #down! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:16'! activeDisabledNotOverDownFillStyle: aFillStyle "Set the active, disabled, notOver, down fill style." self stateMap atPath: #(active disabled notOver down) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:17'! activeDisabledOverDownFillStyle: aFillStyle "Set the active, disabled, over, down fill style." self stateMap atPath: #(active disabled over down) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:34'! mouseDown: evt "Handle a mouse down event." super mouseDown: evt. self enabled ifFalse: [^self]. self down: true. self triggerEvent: #down ! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/1/2011 14:29'! mouseLeave: evt "Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed." super mouseLeave: evt. self over: false! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:44'! passiveDisabledOverUpFillStyle: aFillStyle "Set the passive, disabled, over, up fill style." self stateMap atPath: #(passive disabled over up) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'gvc 10/21/2008 16:45'! passiveEnabledOverDownFillStyle: aFillStyle "Set the passive, enabled, over, down fill style." self stateMap atPath: #(passive enabled over down) put: aFillStyle. self changed! ! !MultistateButtonMorph methodsFor: 'visual properties' stamp: 'GaryChambers 2/15/2011 15:43'! labelGraphic: anObject "do nothing. this is a hack to make this multistate button work with a menu on a system window. Need to refactor menu boxes!!"! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:50'! passivate "Make passive." super passivate. self active: false! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:34'! initWithContents: aString font: aFont emphasis: emphasisCode "Grrr, why do they do basicNew?" colorMap := self defaultColorMap. super initWithContents: aString font: aFont emphasis: emphasisCode! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:40'! drawOn: aCanvas "Draw based on state." self enabled ifTrue: [aCanvas drawString: self contents in: self bounds font: self fontToUse color: self color] ifFalse: [self disabledStyle == #inset ifTrue: [aCanvas drawString: self contents in: (self bounds translateBy: 1) font: self fontToUse color: self disabledColor muchLighter; drawString: self contents in: self bounds font: self fontToUse color: self disabledColor] ifFalse: [aCanvas drawString: self contents in: self bounds font: self fontToUse color: self disabledColor]]! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:37'! pressedColor: aColor "Set the pressed colour." self colorMap at: #pressed put: aColor! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:24'! interactionState: aSymbol "Set the appropriate text colour." self color: (self colorMap at: aSymbol)! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:37'! selectedColor: aColor "Set the selected colour." self colorMap at: #selected put: aColor! ! !MultistateLabelMorph methodsFor: 'accessing' stamp: 'gvc 3/4/2010 15:19'! colorMap "Answer the value of colorMap" ^ colorMap! ! !MultistateLabelMorph methodsFor: 'accessing' stamp: 'gvc 3/4/2010 15:19'! colorMap: anObject "Set the value of colorMap" colorMap := anObject! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:38'! selectedDisabledColor: aColor "Set the selectedDisabled colour." self colorMap at: #selectedDisabled put: aColor! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:36'! normalColor: aColor "Set the normal colour." self colorMap at: #normal put: aColor! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:37'! selectedPressedColor: aColor "Set the selectedPressed colour." self colorMap at: #selectedPressed put: aColor! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:40'! disabledColor "Answer the disabled colour." ^self colorMap at: #disabled! ! !MultistateLabelMorph methodsFor: 'initialization' stamp: 'gvc 3/4/2010 15:20'! initialize "Set up a default colour map." colorMap := self defaultColorMap. super initialize! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:40'! disabledColor: aColor "Set the disabled colour." self colorMap at: #disabled put: aColor! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:35'! defaultColorMap "Answer the default colour map." |black grey| black := Color black. grey := Color gray. ^Dictionary new at: #normal put: black; at: #mouseOver put: black; at: #pressed put: black; at: #disabled put: grey; at: #selected put: black; at: #selectedPressed put: black; at: #selectedMouseOver put: black; at: #selectedDisabled put: grey; yourself ! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:37'! selectedMouseOverColor: aColor "Set the selectedMouseOver colour." self colorMap at: #selectedMouseOver put: aColor! ! !MultistateLabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:36'! mouseOverColor: aColor "Set the mouseOver colour." self colorMap at: #mouseOver put: aColor! ! !MustBeBooleanTests methodsFor: 'as yet unclassified' stamp: 'ClementBera 6/28/2013 13:02'! testIfTrueValue | myBooleanObject | self skip. self assert: (MyBooleanObject new ifTrue: [ 1 + 2 ]) equals: '3 sent from my boolean object'. myBooleanObject := MyBooleanObject new. self assert: (myBooleanObject ifTrue: [ 1 + 2 ]) equals: '3 sent from my boolean object'.! ! !MustBeBooleanTests methodsFor: 'as yet unclassified' stamp: 'ClementBera 6/28/2013 13:02'! testIfTrueEffect | temp fakeBool | self skip. fakeBool := MyBooleanObject new. temp := 1. fakeBool ifTrue: [ temp := 5 + 3 + 1 ]. self assert: temp equals: 9. fakeBool ifTrue: [ [ ] ]. "fakeBool ifTrue: [ 1+ 2. [ :a | a ] value: 5. 7 ]."! ! !Mutex commentStamp: ''! A Mutex is a light-weight MUTual EXclusion object being used when two or more processes need to access a shared resource concurrently. A Mutex grants ownership to a single process and will suspend any other process trying to aquire the mutex while in use. Waiting processes are granted access to the mutex in the order the access was requested. Instance variables: semaphore The (primitive) semaphore used for synchronization. owner The process owning the mutex.! !Mutex methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:11'! initialize super initialize. semaphore := Semaphore forMutualExclusion.! ! !Mutex methodsFor: 'mutual exclusion' stamp: 'das 11/3/2005 22:53'! critical: aBlock "Evaluate aBlock protected by the receiver." | activeProcess | activeProcess := Processor activeProcess. activeProcess == owner ifTrue:[^aBlock value]. ^semaphore critical:[ owner := activeProcess. aBlock ensure:[owner := nil]].! ! !MutexSet commentStamp: ''! A MutexSet helps with aquiring a set of mutexes.! !MutexSet methodsFor: 'private' stamp: 'das 11/3/2005 22:54'! pvtCritical: aBlock startingAt: index | mutex | index > array size ifTrue:[^aBlock value]. mutex := array at: index. ^mutex critical:[self pvtCritical: aBlock startingAt: index+1].! ! !MutexSet methodsFor: 'initialize' stamp: 'das 11/3/2005 22:54'! withAll: mutexList array := mutexList.! ! !MutexSet methodsFor: 'mutual exclusion' stamp: 'das 11/3/2005 22:54'! critical: aBlock "Evaluate aBlock aquiring all mutexes" ^self pvtCritical: aBlock startingAt: 1! ! !MutexSet class methodsFor: 'instance creation' stamp: 'das 11/3/2005 22:54'! withAll: mutexList ^self new withAll: mutexList! ! !MyBooleanObject methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 4/23/2013 16:03'! ifTrue: aBlock ^ aBlock value printString , ' sent from my boolean object'! ! !MyResumableTestError commentStamp: 'TorstenBergmann 2/5/2014 08:38'! A resumable error for tests! !MyResumableTestError methodsFor: 'exception description' stamp: 'tfei 6/13/1999 00:46'! isResumable ^true! ! !MyTestError commentStamp: 'TorstenBergmann 2/5/2014 08:38'! An error for tests! !MyTestNotification commentStamp: 'TorstenBergmann 2/5/2014 08:38'! A notification for tests ! !NBBasicExamples commentStamp: ''! I am a collection on examples on how to use the NativeBoost infrastructure. Check my class-side methods for more details.! !NBBasicExamples methodsFor: 'double type' stamp: 'IgorStasenko 11/23/2012 14:23'! storeDouble: aDouble at: address " This method stores a double floating point value at given memory address. an address can be an instance of NBExternalAddress, or simple ByteArray with at least 8 bytes long, which will hold a 64bit floating-point value" "We are using a pseudo-function prototype and supplying own assembler code, instead of making a call to external function. An address and aDouble arguments are pushed on stack after coercion. " ^ self nbCallout "An additional options may affect the code generation. If options are omitted, then code generator will use defaults (see NBFFICallout class>>defaultOptions)" options: #( "do not accept nil as a pointer arument. This means that passing nil as address will cause a primitive failure." - optCoerceNilToNull " accept a byte array as pointer. In our case, address to a first byte in byte array will be pushed on stack" + optAllowByteArraysPtr " accept an instance of NBExternalAddress when coercing pointer arguments. In our case, this method can accept NBExternalAddres in its address argument" + optAllowExternalAddressPtr ); function: #( void (void * address, double aDouble) ) " A pseudo-function takes 2 arguments, and having no return value. In this case, method will always answer nil object. Under cdecl calling convention, arguments are pushed on stack in reverse order, so, first pushed aDouble , then address" emit: [:gen | | asm | asm := gen asm. "Here , we expecting that an address value is on top of the stack" asm pop: EDX; "load an address value into EDX register by popping it from a stack" "now copy the floating point value (which is 8-bytes long) to the given address" mov: ESP ptr to: EAX; mov: EAX to: EDX ptr; " store first 32bit part of 64bit double value" mov: ESP ptr + 4 to: EAX; mov: EAX to: EDX ptr + 4. " store second 32bit part of 64bit double value" ] ! ! !NBBasicExamples methodsFor: 'custom type' stamp: 'IgorStasenko 11/23/2012 14:15'! encodeToUTF8: aWideString ^ self nbCallout function: #(String (NBUTF8StringExample aWideString)) emit: [:gen :proxy :asm | asm pop: asm EAX ] ! ! !NBBasicExamples methodsFor: 'double type' stamp: 'IgorStasenko 11/23/2012 14:23'! readDoubleFrom: address " This method loads the double from given external address. an address can be an instance of NBExternalAddress, or simple ByteArray with at least 8 bytes long, which holds a double floating value" "We are using a pseudo-function prototype and supplying own assembler code, instead of making a call to external function. In given example, an address argument , after coercion is pushed on stack. " ^ self nbCallout "An additional options may affect the code generation. If options are omitted, then code generator will use defaults (see NBFFICallout class>>defaultOptions)" options: #( "do not accept nil as a pointer argument. This means that passing nil as address will cause a primitive failure." - optCoerceNilToNull " accept a byte array as pointer. In our case, address to a first byte in byte array will be pushed on stack" + optAllowByteArraysPtr " accept an instance of NBExternalAddress when coercing pointer arguments. In our case, this method can accept NBExternalAddres in its address argument" + optAllowExternalAddressPtr ); cdecl; "Use cdecl C calling convention. This can be actually omitted, because it is default convention used by code generator. " function: #( double ( void * address) ) " A pseudo-function takes 1 argument, and returns double value. Under cdecl call convention, all floating point return types is returned in fp(0) CPU register" emit: [:gen | | asm | asm := gen asm. "Here , we expecting that an address value is already pushed on stack" asm pop: asm EAX; "load an address value into EAX register by popping a stack" fld: (asm EAX ptr64). "load a floating point value from memory, at base address, held in EAX register into fp(0) register, we are using #ptr64, to indicate that memory operand size is 64bits long" " return value set, we are done. A code generator will take care for emitting code, which converts a double floating point value into smalltalk object. " ] ! ! !NBBasicExamples methodsFor: 'double type' stamp: 'Igor.Stasenko 9/23/2010 04:53'! writeAndReadDoubles | d bytes result | d := 1.5 . bytes := ByteArray new: 8. self storeDouble: d at: bytes. result := self readDoubleFrom: bytes. self assert: (result = d ).! ! !NBBasicExamples methodsFor: 'double type' stamp: 'IgorStasenko 11/23/2012 14:16'! externalAddressValue: externalAddress " NBBasicExamples new externalAddressValue: (NBExternalAddress value: 10) Error message is in: #verifyClassOf:is:generator: " ^ self nbCallout function: #( ulong ( NBExternalAddress externalAddress) ) emit: [:gen :proxy :asm | asm pop: asm EAX ]! ! !NBBasicExamples methodsFor: 'object format' stamp: 'Igor.Stasenko 12/9/2010 14:29'! getObjectHeader: anObject "Answer the word, representing an object header. See Object>>nbOopHeader for implementation. This method provided only for educational purposes" ^ anObject nbOopHeader! ! !NBBasicExamples class methodsFor: 'basic-float-operations' stamp: 'IgorStasenko 11/23/2012 14:13'! swapDoubFirst: r1 withSecond: r2 ^ self nbCallout function: #( double ( double r1, double r2 )) emit: [:gen :proxy :asm | "store r1 and r2 into the FPU stack" asm fld: asm ESP ptr64. asm fld: asm ESP ptr64 + 8. "swap the two topmost FPU stack elements" asm fxch: asm ST1. ]! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:06'! primitiveFailWithMessage ^ self nbCallout function: #( oop ( void) ) emit: [:gen :proxy :asm | "Fail the native code" gen failWithMessage: 'here is a message you wanna show to users when you fail a primitive' ].! ! !NBBasicExamples class methodsFor: 'basic-external-function' stamp: 'IgorStasenko 8/24/2012 15:13'! nbGetEnv: str " This is a basic example for making an external call. This method calls a Standard C library getenv() function " ^ self nbCall: #( String getenv (String str) ) module: NativeBoost CLibrary! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:12'! returnNewArraySize3 ^ self nbCallout function: #( oop ( void )) emit: [:gen :proxy :asm | "Array -> EAX" proxy classArray. "Array new: 3 (Array oop is stored in EAX)" proxy instantiateClass: asm EAX indexableSize: 3 ]! ! !NBBasicExamples class methodsFor: 'basc-types' stamp: 'CamilloBruni 7/16/2012 10:33'! returnFloat! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:05'! primitiveFail ^ self nbCallout function: #( oop ( void) ) emit: [:gen :proxy :asm | "Fail the native code" proxy primitiveFail. ].! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:08'! returnClassOf: anObject ^ self nbCallout function: #( oop ( oop anObject ) ) emit: [:gen :proxy :asm | " anObject -> EAX " asm pop: asm EAX. "^ anObject class " proxy fetchClassOf: asm EAX. ]! ! !NBBasicExamples class methodsFor: 'basc-types' stamp: 'IgorStasenko 11/23/2012 14:12'! returnIntegerDirectOOP "here, since we put a return type 'oop', this means that NB FFI won't perform any conversion of returned value, therefore a native code must take care by itself for returning a valid oop" ^ self nbCallout function: #( oop ( void) ) emit: [:gen :proxy :asm | asm mov: (123456789 << 1) + 1 to: asm EAX ]! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:13'! returnNil ^ self nbCallout function: #( oop ( void ) ) emit: [:gen :proxy :asm | "nilObject -> EAX" proxy nilObject. ]! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:13'! returnSpecialObjectsArray ^ self nbCallout function: #( oop ( void) ) emit: [:gen :proxy :asm | "store the special objects array into EAX" proxy specialObjectsArray. ]! ! !NBBasicExamples class methodsFor: 'basc-types' stamp: 'IgorStasenko 11/23/2012 14:11'! returnInteger: a minus: b ^ self nbCallout function: #( int ( int a, int b) ) emit: [:gen :proxy :asm | " a " asm pop: asm EAX. " b " asm pop: asm EDX. "result := a - b" asm sub: asm EAX with: asm EDX ]! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:07'! returnArrayClass ^ self nbCallout function: #( oop ( void) ) emit: [:gen :proxy :asm | "Access an internal data structure via the interpreter proxy" proxy classArray. ]! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:13'! returnSelf ^ self nbCallout function: #( oop ( void) ) emit: [:gen :proxy :asm | "this is equivalent to: proxy receiverInto: asm EAX." proxy receiver. ]! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:11'! returnInstVar: aNumber from: anObject ^ self nbCallout function: #( oop ( int aNumber, oop anObject ) ) emit: [:gen :proxy :asm | "aNumber -> EAX" asm pop: asm EAX. "EAX = aNumebr-1" asm sub: asm EAX with: 1. "if signed (AKA negative jump to failure)" asm js: 'failure'. "anObject -> EDX" asm pop: asm EDX. "EAX = anObject instVarAt: aNumber" proxy fetchPointer: asm EAX ofObject: asm EDX. asm leave; ret. asm label: 'failure'. proxy primitiveFail. ]! ! !NBBasicExamples class methodsFor: 'basc-types' stamp: 'IgorStasenko 11/23/2012 14:11'! returnInteger ^ self nbCallout function: #( int ( void) ) emit: [:gen :proxy :asm | asm mov: 123456789 to: asm EAX ]! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:12'! returnMethodLiteral ^ self nbCallout function: #( oop ( void) ) emit: [:gen :proxy :asm | "store this method in EAX" proxy primitiveMethod. "the current method is in EAX EAX literalAt: 0 " proxy literal: 0 ofMethod: asm EAX. ]! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:04'! failIfNegative: anInteger ^ self nbCallout function: #( void ( int anInteger ) ) emit: [:gen :proxy :asm | "aNumber -> EAX" asm pop: asm EAX. "check if the index in EAX is negative" asm test: asm EAX with: asm EAX. "if not signed (AKA positive jump to success)" asm jns: 'success'. gen failWithMessage: 'A negative number is forbidden!!'. asm label: 'success'. ]! ! !NBBasicExamples class methodsFor: 'basc-types' stamp: 'IgorStasenko 11/23/2012 14:06'! returnAddressOf: anObject "Yes, here we demonstrating that we can obtain a pointer (address) of object in memory. But in fact it has no any practical use, because at any moment once you return from the method, a GC may be triggered and given object can be relocated into different memory region, rendering an obtained address invalid" ^ self nbCallout function: #( int ( oop anObject ) ) emit: [:gen :proxy :asm | asm pop: asm EAX. ]! ! !NBBasicExamples class methodsFor: 'basic-interpreter-proxy-interaction' stamp: 'IgorStasenko 11/23/2012 14:07'! returnAsBit: aBoolean ^ self nbCallout function: #( int ( oop aBoolean ) ) emit: [:gen :proxy :asm | " aBoolean -> EAX " asm pop: asm EAX. "^ EAX = true ifTrue: [ 1 ] ifFalse: [ 0 ] " proxy booleanValueOf: asm EAX. ]! ! !NBBool methodsFor: 'emitting code' stamp: 'StephaneDucasse 2/7/2014 16:16'! coerceReturnValue: gen "convert C Bool to true or false" | proxy asm lfalse done | proxy := gen proxy. asm := gen asm. lfalse := asm uniqueLabelName: 'false'. done := asm uniqueLabelName: 'done'. asm or: asm AL with: asm AL; je: lfalse. proxy trueObject. asm jmp: done. asm label: lfalse. proxy falseObject. asm label: done.! ! !NBBool methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 17:05'! valueSize "Answer a number of bytes, which takes a value of given type (not a pointer to it) " ^ 1! ! !NBBool methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/30/2010 13:55'! pushAsValue: gen gen asm push: (gen proxy booleanValueOf: (loader emitLoad: gen)). ! ! !NBBootstrapUlong commentStamp: 'Igor.Stasenko 5/14/2010 18:01'! A special hacky type, which storing a ulong function return value into existing byte array instance. A method, which using this type in callout should have an argument , named 'returnValueBuffer' and pass a byte array instance, big enough to store ulong there. This is essentially used during NativeBoost bootstrap, to generate & install the gall gate function, without calling any of interpreterProxy function which may cause GC.! !NBBootstrapUlong methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 11:09'! coerceReturnValue: gen | args result asm proxy | asm := gen asm. proxy := gen proxy. args := gen methodArgs. result := gen reserveTemp. asm mov: asm EAX to: result. "load a returnValueBuffer method argument oop" (NBSTMethodArgument new stackIndex: (args size - (args indexOf: #returnValueBuffer))) emitLoad: gen. proxy varBytesFirstFieldOf: asm EAX. "EAX - address , where to store result " asm mov: result to: asm ECX. asm mov: asm ECX to: asm EAX ptr32. "primitive will return nil" proxy nilObject ! ! !NBBootstrapUlong methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 17:05'! valueSize "Answer a number of bytes, which takes a value of given type (not a pointer to it) " ^ 4! ! !NBByteArrayPtr methodsFor: 'emitting code' stamp: 'IgorStasenko 8/3/2011 19:47'! pushAsPointer: gen self error: 'ByteArrayPtr is already pointer'! ! !NBByteArrayPtr methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 17:04'! valueSize "Answer a number of bytes, which takes a value of given type (not a pointer to it) " ^ self pointerSize ! ! !NBByteArrayPtr methodsFor: 'emitting code' stamp: 'CamilloBruni 7/23/2012 13:29'! pushAsValue: gen "push a pointer to first indexable field of ByteArray, which is always oop + BaseHeaderSize " | asm proxy | asm := gen asm. proxy := gen proxy. loader emitLoad: gen. asm decorateWith: 'NBByteArrayPtr>>pushAsValue:' during: [ asm add: asm EAX with: proxy objectFormat varBytesFirstField; push: asm EAX ]! ! !NBByteArraySize commentStamp: 'Igor.Stasenko 5/3/2010 13:56'! A helper type, which takes a byte array argument and pushing its size! !NBByteArraySize methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/3/2010 14:00'! coerceReturn: gen self error: 'Can''t use this type as a return value'! ! !NBByteArraySize methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/3/2010 22:44'! pushAsPointer: gen self shouldNotImplement ! ! !NBByteArraySize methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 17:04'! valueSize "Answer a number of bytes, which takes a value of given type (not a pointer to it) " ^ 4! ! !NBByteArraySize methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/3/2010 22:40'! pushAsValue: gen " push the array size " gen proxy slotSizeOf: (loader emitLoad: gen). gen asm push: gen asm EAX! ! !NBCPrinter class methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 9/27/2010 01:46'! initialize " self initialize " printFormat := '%s'.! ! !NBCPrinter class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/24/2012 16:20'! printf: aString ^ self nbCallout function: #( void printf (String printFormat, String aString) ) module: NativeBoost CLibrary! ! !NBCallbackCodeGen commentStamp: ''! The generated callback code does following: 1. Trunk 1.0. Each callback instance has unique trunk code, which is installed into external memory during callback initialization. 1.1. An external function makes a call to trunk address. 1.2. Trunk code sets the globally registered callback index to ECX register and jumps to callback entry code. 2. Entering callback 2.1. saves the VM's execution state (stack/frame pointers, reenterInterpreter jump buffer). See #saveExecutionState. 2.2. fetching the callback oop for index passed from trunk. 2.3. coercing the callback function arguments to their smalltalk equivalent and creates an array with them. See #emitArgumentsCoercion. 2.4. synthesizes a fresh method context which is an activation of #pvtEnter:stackPointer:primitiveMethod: and swaps the active context with synthesized context. See #activateCallbackContext: . 2.5. increments a global callback counter value. See #incrementCallbackCounter. 2.6. enters an interpreter loop by calling VM's #enterSmalltalkExecutiveImplementation function. 3. Leaving callback. 3.1. A leave procedure starts from method: #primLeave:stackPtr:contextOop:returnValue:primitiveMethod: , which simply jumps to provided leave address, a code, generated for leaving from given callback. 3.2. Coerce the return value from smalltalk object to it's C equivalent. See #generateCallbackLeaveCodeFor:leaveAddr:. 3.3. Swaps a currently active context with one which were before entering callback 3.4. jumps to #returnToC label in callback entry code 3.5. sets the current C stack frame back to callback enter procedure. 3.6. restores the VM execution state (an opposite to 2.1) , see #restoreExecutionState. 3.7. decrements global callback counter. 3.8. returns to external function ! !NBCallbackCodeGen methodsFor: 'callback entry code' stamp: 'IgorStasenko 5/8/2012 16:48'! generateCallbackEnterCodeFor: callbackClass gen := (NBNativeFunctionGen new callType: callbackClass callType; fnSpec: callbackClass fnSpec; yourself). callbackClass numArgs: gen fnSpec arguments size. "optUseStackPointer should be turned off!!!!!!" gen parseOptions: #( + optProxyLabels - optUseStackPointer +optReserveCallgateSpace "+optDebug" ). ^ gen generate: [:g | asm := gen asm. proxy := gen proxy. " Callback entry , jumped directly from trunk. ECX == callback index " cbIndex := gen reserveTemp. asm mov: ECX to: cbIndex. self saveExecutionState; emitArgumentsCoercion; activateCallbackContext: callbackClass. "increment callback counter value" self incrementCallbackCounter. asm label: #safetyLoop. self enterSmalltalkExecutiveImplementation. " we never reach here" asm jmp: #safetyLoop. "========================================================" "Callback return entry point. We jump here from #generateCallbackLeaveCodeFor:leaveAddr: The stack must contain: - saved EBP - EAX - EDX " asm label: #returnToC; pop: EBP. self restoreExecutionState. self decrementCallbackCounter. asm pop: EAX; pop: EDX. ].! ! !NBCallbackCodeGen methodsFor: 'global addresses' stamp: 'IgorStasenko 5/7/2012 12:36'! CStackPointerAddress ^ NativeBoost loadSymbol: 'CStackPointer' fromModule: NativeBoost VMModule! ! !NBCallbackCodeGen methodsFor: 'callback entry code' stamp: 'IgorStasenko 5/7/2012 12:48'! incrementCallbackCounter "increment callback counter value" asm mov: NativeBoost forCurrentPlatform callbackCounterAddress asUImm32 to: EAX. asm inc: EAX ptr32. ! ! !NBCallbackCodeGen methodsFor: 'callback leave code' stamp: 'CiprianTeodorov 12/11/2012 19:00'! generateCallbackLeaveCodeFor: callbackClass leaveAddr: leaveAddress gen := (NBNativeFunctionGen new callType: callbackClass callType; fnSpec: callbackClass fnSpec; yourself). callbackClass numArgs: gen fnSpec arguments size. "optUseStackPointer should be turned off!!!!!!" gen parseOptions: #( + optProxyLabels - optUseStackPointer +optReserveCallgateSpace "+optDebug" ). ^ gen generate: [:g | asm := gen asm. proxy := gen proxy. "see #primLeave:stackPtr:contextOop:returnValue:primitiveMethod: for arguments stack order " "coerce the oop to return type" proxy stackValue: 1. "******** currently only return types returned via EAX supported *********" gen fnSpec returnType coerceOopToOperand: gen ifFailedJumpTo: #failed. "keep return value(s) on stack" asm push: EDX; push: EAX. proxy stackValue: 3. "saved EBP" proxy positive32BitValueOf: EAX. asm push: EAX. proxy ifFailedJumpTo: #failed. proxy swapActiveContext: [ proxy stackValue: 2 ] restoreMethod: [ proxy stackValue: 0 ]. "swapactivecontext returns 0 on failure" asm cmp: EAX with: 0; je: #failed. asm mov: leaveAddress asUImm to: EAX; jmp: EAX. "jump to callback leave-to-C code. see #generateCallbackEnterCodeFor: " asm label: #failed. "asm int3." proxy primitiveFail. asm leave; leave; " on failure, we do leave twice, because #primLeave:stackPtr:contextOop:returnValue:primitiveMethod: creates own stack frame, and jumps to callback leave entry point but we want to return straight to VM" ret. ]. ! ! !NBCallbackCodeGen methodsFor: 'callback entry code' stamp: 'IgorStasenko 9/15/2012 19:53'! emitArgumentsCoercion " input - none, output - an arguments array in remmappable oops stack top" | args argOop i | args := gen reserveTemp. argOop := gen reserveTemp. asm decorateWith: 'emitArgumentsCoercion' during: [ proxy createInstanceOf: Array size: (gen fnSpec arguments size). proxy pushRemappableOop: EAX. i := 0. gen fnSpec arguments do: [:arg | arg type readOop: (EBP ptr + arg offset) generator: gen. asm mov: EAX to: argOop. proxy popRemappableOop. asm mov: EAX to: args. proxy storePointer: i ofObject: args withValue: argOop. i := i+1. proxy pushRemappableOop: args. ]. gen releaseTemps: 2. ]! ! !NBCallbackCodeGen methodsFor: 'misc' stamp: 'IgorStasenko 9/10/2012 13:26'! memCopy: src to: dst size: sz asm mov: src to: asm ESI; mov: dst to: asm EDI; mov: sz to: asm ECX; rep; movsb! ! !NBCallbackCodeGen methodsFor: 'global addresses' stamp: 'IgorStasenko 9/10/2012 12:49'! reenterInterpreterAddress ^ (NativeBoost loadSymbol: 'reenterInterpreter' fromModule: NativeBoost VMModule) value asUImm32 ! ! !NBCallbackCodeGen methodsFor: 'callback entry code' stamp: 'IgorStasenko 9/15/2012 14:36'! activateCallbackContext: callbackClass "Activate a callback context, which is a MethodContext sender: s receiver: r method: m arguments: args " | ctx method fld | method := callbackClass callbackEnterMethod. ctx := gen reserveTemp. fld := gen reserveTemp. proxy positive32BitIntegerFor: EBP. proxy pushRemappableOop: EAX. "push EBP -> remappable oops stack" proxy createInstanceOf: MethodContext size: method frameSize. asm mov: EAX to: ctx. "Fill the context state, which is #('sender' 'pc' 'stackp' 'method' 'closureOrNil' 'receiver')" proxy integerObjectOf: method initialPC. asm mov: ctx to: ECX; mov: EAX to: ECX ptr + (proxy ivar: #pc in: MethodContext). proxy integerObjectOf: method numTemps. asm mov: ctx to: ECX; mov: EAX to: ECX ptr + (proxy ivar: #stackp in: MethodContext). NativeBoost extraRootsRegistry emitFetchCallback: cbIndex generator: gen. "EAX - callback oop" asm mov: ctx to: ECX; mov: EAX to: ECX ptr + (proxy ivar: #receiver in: MethodContext); mov: EAX ptr + (proxy ivar: #enterMethod in: NBFFICallback) to: EDX; mov: EDX to: ECX ptr + (proxy ivar: #method in: MethodContext). proxy firstIndexableField: ECX. asm mov: EAX to: fld. proxy popRemappableOop. "pop EBP from remappable oops stack" asm mov: fld to: ECX; mov: EAX to: ECX ptr + proxy oopSize. "put stackp as 1st method argument" proxy popRemappableOop. "saved arguments array (see #emitArgumentsCoercion)" asm mov: fld to: ECX; mov: EAX to: ECX ptr. proxy primitiveMethod. asm mov: fld to: ECX; mov: EAX to: ECX ptr + (2*proxy oopSize). "save current primitive method oop" "Now we swapping the currently active VM context with the context we're just created" proxy pushRemappableOop: ctx. proxy swapActiveContext: [ ctx ] restoreMethod: [ 0 ]. " EAX <- activeContext" asm mov: EAX to: ctx. proxy popRemappableOop. "set a sender in new context to be the old context ctx - old context, EAX - new context" asm mov: ctx to: ECX. asm mov: ECX to: EAX ptr + (proxy ivar: #sender in: MethodContext). ! ! !NBCallbackCodeGen methodsFor: 'callback leave code' stamp: 'IgorStasenko 9/15/2012 19:54'! restoreExecutionState "emit code to restore execution state" asm decorateWith: 'restoreExecutionState' during: [ "restore registers & other , see corresponding #saveExecutionState" self memCopy: savedReenterInterpreter to: self reenterInterpreterAddress size: self primJumpBufSize. asm mov: savedEBX to: EBX; mov: savedESI to: ESI; mov: savedEDI to: EDI; mov: savedCStackPointer to: EAX; mov: EAX to: self CStackPointerAddress asUImm ptr; mov: savedCFramePointer to: EAX; mov: EAX to: self CFramePointerAddress asUImm ptr. ]! ! !NBCallbackCodeGen methodsFor: 'callback leave code' stamp: 'IgorStasenko 5/7/2012 12:48'! decrementCallbackCounter "increment callback counter value" asm mov: NativeBoost forCurrentPlatform callbackCounterAddress asUImm32 to: EAX. asm dec: EAX ptr32. ! ! !NBCallbackCodeGen methodsFor: 'callback entry code' stamp: 'IgorStasenko 5/7/2012 18:29'! enterSmalltalkExecutiveImplementation "call #enterSmalltalkExecutiveImplementation" | addr | addr := NativeBoost loadSymbol: 'enterSmalltalkExecutiveImplementation' fromModule: NativeBoost VMModule. asm cdeclCall: [:callInfo | asm mov: addr asUImm32 to: EAX; call: EAX. ] alignment: NativeBoost forCurrentPlatform stackAlignment ! ! !NBCallbackCodeGen methodsFor: 'global addresses' stamp: 'EstebanLorenzano 2/13/2013 16:27'! CFramePointerAddress ^ NativeBoost loadSymbol: 'CFramePointer' fromModule: NativeBoost VMModule! ! !NBCallbackCodeGen methodsFor: 'misc' stamp: 'IgorStasenko 5/7/2012 22:31'! generator: agen gen := agen. asm := gen asm. proxy := gen proxy.! ! !NBCallbackCodeGen methodsFor: 'primitives' stamp: 'IgorStasenko 9/10/2012 12:23'! primJumpBufSize self error: 'a primitive failed. (seems like you using outdated VM)'! ! !NBCallbackCodeGen methodsFor: 'callback entry code' stamp: 'IgorStasenko 9/15/2012 19:50'! saveExecutionState "emit code to save execution state" asm decorateWith: 'saveExecutionState' during: [ "save registers" savedEBX := gen reserveTemp. savedESI := gen reserveTemp. savedEDI := gen reserveTemp. savedCStackPointer := gen reserveTemp. savedCFramePointer := gen reserveTemp. savedReenterInterpreter := gen reserveTemp. asm mov: EBX to: savedEBX; mov: ESI to: savedESI; mov: EDI to: savedEDI; mov: self CStackPointerAddress asUImm ptr to: EAX; mov: EAX to: savedCStackPointer; mov: self CFramePointerAddress asUImm ptr to: EAX; mov: EAX to: savedCFramePointer; sub: asm ESP with: self primJumpBufSize; mov: ESP to: savedReenterInterpreter. self memCopy: self reenterInterpreterAddress to: savedReenterInterpreter size: self primJumpBufSize ]! ! !NBCharacterType commentStamp: ''! Character type. Represented as single byte on C side. Accepts Character/Smallint as argument, converts return value to Character instance! !NBCharacterType methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:34'! coerceReturnValue: gen | asm proxy val | "convert unsigned Char to ST Character" asm := gen asm. proxy := gen proxy. val := gen reserveTemp. asm movzx: asm EAX with: asm AL. asm mov: asm EAX to: val. proxy fetchPointer: val ofObject: (proxy characterTable). gen releaseTemps: 1! ! !NBCharacterType methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 23:34'! valueSize ^ 1! ! !NBCharacterType methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:34'! pushAsValue: gen "oop is a Character or smallint" | asm oop classChar reg proxy notSmi done | asm := gen asm. proxy := gen proxy. notSmi := asm uniqueLabelName: 'notSmi'. done := asm uniqueLabelName: 'done'. oop := gen reserveTemp. classChar := gen reserveTemp. reg := loader emitLoad: gen. asm mov: reg to: oop. reg := proxy isIntegerObject: reg. asm or: reg with: reg; je: notSmi. asm push: (proxy integerValueOf: oop); jmp: done. asm label: notSmi. reg := proxy classCharacter. asm mov: reg to: classChar. reg := proxy fetchClassOf: oop. asm cmp: reg with: classChar; jne: gen failedLabel. reg := proxy fetchInteger: 0 ofObject: oop. asm push: reg; label: done. gen releaseTemps: 2 ! ! !NBCodeGenRecursion commentStamp: ''! I am used to SIGNAL recursion error during code generation.. Do not confuse me with NBRecursionDetect notification, which is used to detect recursion. A recursion usually happens when generating code for some method requires generating code for very same method, and so it enters infinite loop! !NBCogInterpreterProxy commentStamp: ''! I am a specialized interpreter proxy for the Cog family of intererpreters! !NBCoreTests methodsFor: 'tests' stamp: 'IgorStasenko 2/20/2012 12:13'! testGettingError self nonExistedPrim: [:context | "This error produced by Cog VM, when primitive not found" self assert: (context tempAt: context method numTemps ) == #'not found' ]! ! !NBCoreTests methodsFor: 'misc' stamp: 'IgorStasenko 2/20/2012 12:01'! nonExistedPrim: aBlock | a b c| ^ aBlock value: thisContext ! ! !NBCoreTests methodsFor: 'tests' stamp: 'IgorStasenko 5/28/2012 07:00'! testRecursionDetection | result | result := false. NBRecursionDetect in: #abc during: [ result := (NBRecursionDetect signalForMethod: #abc ) ]. self assert: result == true. result := (NBRecursionDetect signalForMethod: #abc ). self assert: result == false. ! ! !NBCoreTests methodsFor: 'tests' stamp: 'IgorStasenko 3/20/2011 04:05'! testPlatformId "sometimes i forget to set platform ID, when building plugin" self assert: NativeBoost platformId ~= 0! ! !NBCoreTests methodsFor: 'misc' stamp: 'IgorStasenko 2/8/2013 15:48'! methodWithPrimitive220 ^errorCode ! ! !NBCoreTests methodsFor: 'tests' stamp: 'IgorStasenko 2/8/2013 17:10'! testPrimitive220 " Test a protocol for installing/removing native code directly. " | asm label method gen | [ ^ self ] value. " this code will crash your VM " method := self class>>#anotherMethodWithPrimitive220. NBNativeCodeGen removeNativeCodeFrom: method. method := self class>>#anotherMethodWithPrimitive220. self assert: method hasNativeCode not. asm := NativeBoost forCurrentPlatform newAssembler noStackFrame. label := asm uniqueLabelName: 'done'. gen := NBNativeCodeGen newForMethod: method. asm := gen asm. asm noStackFrame. asm push: 999. gen proxy callFn: (gen proxy functions at:#primitiveFailFor: ). asm int3; jmp: label; mov: 1 to: asm EDX; label: label. NBNativeCodeGen installNativeCode: asm bytes into: method. ( self class>>#anotherMethodWithPrimitive220 ) forceJIT. ^ self anotherMethodWithPrimitive220 ! ! !NBCoreTests methodsFor: 'misc' stamp: 'IgorStasenko 2/8/2013 16:11'! anotherMethodWithPrimitive220 ^ errorCode asString! ! !NBCoreTests methodsFor: 'misc' stamp: 'IgorStasenko 2/13/2012 13:42'! stub2 ^ NBNativeCodeGen generateCode: [:gen | self return0Code ] andRetry: thisContext! ! !NBCoreTests methodsFor: 'tests' stamp: 'IgorStasenko 5/31/2012 14:53'! testFinalization | reg objs count | reg := NBFinalizationRegistry new. count := 0. reg freeItemsDo: [:item | count := count + 1]. self assert: count = reg initialSize. objs := OrderedCollection new. 133 timesRepeat: [ reg add: (objs add: Object new) ]. count := 0. reg freeItemsDo: [:item | count := count + 1]. self assert: reg items size - count = 133. objs := nil. Smalltalk garbageCollect. count := 0. reg freeItemsDo: [:item | count := count + 1]. self assert: count = reg items size. reg reset. count := 0. reg freeItemsDo: [:item | count := count + 1]. self assert: count = reg initialSize. ! ! !NBCoreTests methodsFor: 'tests' stamp: 'IgorStasenko 8/24/2012 17:19'! testExternalResourceManagerFinalization | obj count | count := 0. obj := NBMockExternalObject new. obj data: [ count := count + 1 ]. obj registerAsExternalResource. obj := nil. Smalltalk garbageCollect; garbageCollect. self assert: (count = 1)! ! !NBCoreTests methodsFor: 'tests' stamp: 'IgorStasenko 2/20/2012 14:26'! testGenerateAndRetry NBNativeCodeGen removeNativeCodeFrom: (self class>>#stub2). [ self assert: self stub2 = 0. ] ensure: [ NBNativeCodeGen removeNativeCodeFrom: (self class>>#stub2). ]. ! ! !NBCoreTests methodsFor: 'tests' stamp: 'IgorStasenko 3/20/2011 04:12'! testHasTrailerInstalled "Make sure compiled methods trailer installed" self assert: (CompiledMethodTrailer trailerKinds includes: #NativeCodeTrailer )! ! !NBCoreTests methodsFor: 'misc' stamp: 'IgorStasenko 2/20/2012 14:08'! return0Code " a simple routine, just return 1 (smallinteger = 0)" | asm | ^ (asm := NativeBoost newAssembler ) noStackFrame; mov: 1 to: asm EAX; ret; bytes ! ! !NBCoreTests methodsFor: 'misc' stamp: 'IgorStasenko 2/13/2012 13:25'! stub ^ 100! ! !NBCoreTests methodsFor: 'tests' stamp: 'IgorStasenko 2/13/2012 14:04'! testInstallingNativeCode " Test a protocol for installing/removing native code directly. " NBNativeCodeGen removeNativeCodeFrom: (self class>>#stub). self assert: (self class>>#stub) hasNativeCode not. self assert: self stub = 100. [ NBNativeCodeGen installNativeCode: self return0Code into: (self class>>#stub). self assert: (self class>>#stub) hasNativeCode. self assert: (self stub = 0). ] ensure: [ NBNativeCodeGen removeNativeCodeFrom: (self class>>#stub). ]. self assert: (self class>>#stub) hasNativeCode not. ! ! !NBCoreTests methodsFor: 'tests' stamp: 'IgorStasenko 2/8/2013 15:51'! testPrimitive220ErrorCode " Test a protocol for installing/removing native code directly. " NBNativeCodeGen removeNativeCodeFrom: (self class>>#methodWithPrimitive220). self assert: (self class>>#methodWithPrimitive220) hasNativeCode not. "502 is error code = ErrNoNativeCodeInMethod " self methodWithPrimitive220 = 502. ! ! !NBExternalAddress commentStamp: 'IgorStasenko 2/24/2012 17:10'! My primary function is to represent a pointer (address) to memory, in cases, when a kind of data under given address does not having any special structure, which can be reflected more nicely in language. Usually i can be used to hold pointer(s) to buffers (void*), or to allocated memory region etc. I providing some basic interface for reading/writing data into memory where i pointing to, as well as some convenience methods.! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! ulongAt: zeroBasedOffset "Reads unsigned 32-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(uint32 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr32 + asm ECX to: asm EAX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! longAt: zeroBasedOffset "Reads signed 32-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(int32 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr32 + asm ECX to: asm EAX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbUInt16AtOffset: zeroBasedOffset "Reads unsigned 16-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(uint16 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr16 + asm ECX to: asm AX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbUInt64AtOffset: zeroBasedOffset "Reads unsigned 64-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(uint64 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr + asm ECX + 4 to: asm EDX; mov: asm EAX ptr + asm ECX to: asm EAX ] ! ! !NBExternalAddress methodsFor: 'string access' stamp: 'IgorStasenko 11/24/2012 17:04'! readString "sometimes we're just a pointer to string" ^ self nbCallout function: #(String (self)) emit: [:gen | gen asm pop: gen asm EAX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbFloat64AtOffset: zeroBasedOffset put: value "Store 64-bit float at ZERO-based index. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, float64 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" add: asm EAX with: asm ECX; mov: asm ESP ptr to: asm ECX; mov: asm ECX to: asm EAX ptr; mov: asm ESP ptr +4 to: asm ECX; mov: asm ECX to: asm EAX ptr +4 ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbFloat32AtOffset: zeroBasedOffset put: value "Store 32-bit float at ZERO-based index. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, float32 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; mov: asm EDX to: asm EAX ptr + asm ECX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbUInt16AtOffset: zeroBasedOffset put: value "Store unsigned 16-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, uint16 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm DX to: asm EAX ptr16 + asm ECX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbInt64AtOffset: zeroBasedOffset put: value "Store signed 64-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, int64 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value low word" mov: asm EDX to: asm EAX ptr32 + asm ECX; pop: asm EDX; "value high word" mov: asm EDX to: asm EAX ptr32 + asm ECX + 4 ] ! ! !NBExternalAddress methodsFor: 'string access' stamp: 'CiprianTeodorov 3/18/2013 22:35'! writeString: aString "write a null-terminated byte string to receiver's address" | str | str := aString copyWith: (Character value: 0). NativeBoost memCopy: str asByteArray to: self size: str size. ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbInt32AtOffset: zeroBasedOffset "Reads signed 32-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(int32 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr32 + asm ECX to: asm EAX ] ! ! !NBExternalAddress methodsFor: 'finalization' stamp: 'CamilloBruni 8/3/2012 15:27'! free NativeBoost free: self! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbInt32AtOffset: zeroBasedOffset put: value "Store signed 32-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, int32 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm EDX to: asm EAX ptr32 + asm ECX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbInt64AtOffset: zeroBasedOffset "Reads signed 64-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(int64 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr + asm ECX + 4 to: asm EDX; mov: asm EAX ptr + asm ECX to: asm EAX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! byteAt: zeroBasedOffset "Reads signed 8-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(int8 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr8 + asm ECX to: asm AL ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbUInt8AtOffset: zeroBasedOffset "Reads unsigned 8-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(uint8 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr8 + asm ECX to: asm AL ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbUInt8AtOffset: zeroBasedOffset put: value "Store unsigned 8-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, uint8 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm DL to: asm EAX ptr8 + asm ECX ] ! ! !NBExternalAddress methodsFor: 'finalization' stamp: 'CamilloBruni 8/3/2012 15:27'! finalize self free! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! byteAt: zeroBasedOffset put: value "Store signed 8-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, int8 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm DL to: asm EAX ptr8 + asm ECX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbFloat32AtOffset: zeroBasedOffset "Read 32-bit float at ZERO-based index. Note, there is no range checking " ^ self nbCallout function: #(float32 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" add: asm EAX with: asm ECX; fld: asm EAX ptr32. "load a floating point value from memory, at base address, held in EAX register into fp(0) register, we are using #ptr32, to indicate that memory operand size is 32bits long" ] ! ! !NBExternalAddress methodsFor: 'finalization' stamp: 'CamilloBruni 8/3/2012 15:30'! freeAfterUse "add ourselves to finalization registry" NBExternalResourceManager addResource: self data: self value. ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbFloat64AtOffset: zeroBasedOffset "Read 64-bit float at ZERO-based index. Note, there is no range checking " ^ self nbCallout function: #(float64 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "index" add: asm EAX with: asm ECX; fld: asm EAX ptr64. "load a floating point value from memory, at base address, held in EAX register into fp(0) register, we are using #ptr64, to indicate that memory operand size is 64bits long" ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbInt16AtOffset: zeroBasedOffset "Reads signed 16-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(int16 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr16 + asm ECX to: asm AX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbInt16AtOffset: zeroBasedOffset put: value "Store signed 16-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, int16 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm DX to: asm EAX ptr16 + asm ECX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbInt8AtOffset: zeroBasedOffset put: value "Store signed 8-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, int8 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm DL to: asm EAX ptr8 + asm ECX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbInt8AtOffset: zeroBasedOffset "Reads signed 8-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(int8 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr8 + asm ECX to: asm AL ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! ulongAt: zeroBasedOffset put: value "Store unsigned 32-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, uint32 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm EDX to: asm EAX ptr32 + asm ECX ] ! ! !NBExternalAddress methodsFor: 'comparing' stamp: 'IgorStasenko 8/4/2011 08:25'! = anObject ^ anObject class == self class and: [ anObject value = self value]! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! longAt: zeroBasedOffset put: value "Store signed 32-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, int32 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm EDX to: asm EAX ptr32 + asm ECX ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbUInt32AtOffset: zeroBasedOffset "Reads unsigned 32-bit integer from memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(uint32 (self, ulong zeroBasedOffset)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" mov: asm EAX ptr32 + asm ECX to: asm EAX ] ! ! !NBExternalAddress methodsFor: 'testing' stamp: 'IgorStasenko 8/4/2011 07:06'! notNull ^ self value ~= 0! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbUInt64AtOffset: zeroBasedOffset put: value "Store unsigned 64-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, uint64 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value low word" mov: asm EDX to: asm EAX ptr32 + asm ECX; pop: asm EDX; "value high word" mov: asm EDX to: asm EAX ptr32 + asm ECX + 4 ] ! ! !NBExternalAddress methodsFor: 'as yet unclassified' stamp: ''! nbUInt32AtOffset: zeroBasedOffset put: value "Store unsigned 32-bit integer into memory at (receiver's address + ZERO-based offset) using native byte order. Note, there is no range checking " ^ self nbCallout function: #(void (self, ulong zeroBasedOffset, uint32 value)) emit: [:gen | | asm | asm := gen asm. asm pop: asm EAX; "pointer to receiver's first byte" pop: asm ECX; "offset" pop: asm EDX; "value" mov: asm EDX to: asm EAX ptr32 + asm ECX ] ! ! !NBExternalAddress class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/4/2010 01:15'! asNBExternalType: gen ^ NBExternalAddressType new ! ! !NBExternalAddress class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/17/2010 14:53'! fromString: aString | result | result := NativeBoost allocate: aString size + 1. (self assert: result notNil). result writeString: aString. ^ result! ! !NBExternalAddress class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/18/2010 00:33'! null ^ self new! ! !NBExternalAddress class methodsFor: 'finalization' stamp: 'CamilloBruni 8/3/2012 15:32'! finalizeResourceData: anExternalAddressValue "We use an intermediate interger for address value, otherwise we would hold on to the NBExternalAddress forever" (self value: anExternalAddressValue) free! ! !NBExternalAddressTests methodsFor: 'tests' stamp: 'Igor.Stasenko 5/13/2010 22:51'! testMemoryAccess | addr | addr := NativeBoost allocate: 10. [ 1 to: 10 do: [:i | addr byteAt: i-1 put: i ]. 1 to: 10 do: [:i | self assert: (addr byteAt: i-1) = i ]. ] ensure: [ NativeBoost free: addr ] ! ! !NBExternalAddressTests methodsFor: 'tests' stamp: 'IgorStasenko 8/4/2011 07:29'! testStringAccess | addr string | addr := NativeBoost allocate: 10. [ addr writeString: 'abcde'. string := addr readString. ] ensure: [ NativeBoost free: addr ]. self assert: string = 'abcde' ! ! !NBExternalAddressTests methodsFor: 'tests' stamp: 'IgorStasenko 8/4/2011 08:25'! testAddressAndStruct | struct addr string | struct := NBTestStructure2 new. self assert: struct addr class == NBExternalAddress . addr := NativeBoost allocate: 10. [ addr writeString: 'abcde'. struct addr: addr. self assert: addr = struct addr. string := struct addr readString . ] ensure: [ NativeBoost free: addr ]. self assert: string = 'abcde' ! ! !NBExternalAddressTests methodsFor: 'tests' stamp: 'IgorStasenko 7/15/2013 15:47'! testStructCopy | struct addr struct2 | [ struct := NBTestStructure new. struct byte: 5; long: 10; short: 20. addr := NativeBoost allocate: NBTestStructure instanceSize. NativeBoost memCopy: struct address to: addr size: NBTestStructure instanceSize. struct2 := NBTestStructure fromPointer: addr. self assert: struct2 byte = 5. self assert: struct2 long = 10. self assert: struct2 short = 20. ] ensure: [ NativeBoost free: addr ] ! ! !NBExternalAddressType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 16:16'! coerceReturnValue: gen "input: address is in EAX. output: ExternalAddress instance oop in EAX creates an instance of NBExternalAddress and store the address there" | asm result | asm := gen asm. result := self createInstanceWithValue: asm EAX generator: gen. asm mov: result to: asm EAX. ! ! !NBExternalAddressType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 16:32'! createInstanceWithValue: address generator: gen "Create an instance of NBExternalAddress with given value. Answer the resulting oop in EAX" | result asm proxy | asm := gen asm. proxy := gen proxy. result := gen reserveTemp. asm mov: address to: result. proxy createInstanceOf: NBExternalAddress size: NBExternalType pointerSize. asm mov: result to: asm ECX. proxy storePointer: asm ECX intoVarbytes: asm EAX at: 0. gen releaseTemps: 1. ^ asm EAX! ! !NBExternalAddressType methodsFor: 'emitting code' stamp: 'IgorStasenko 6/28/2013 14:18'! pushAsPointer: gen "push a pointer to external address first indexable field (where address value held)" | asm proxy oop | proxy := gen proxy. asm := gen asm. oop := gen reserveTemp. loader emitLoad: gen to: oop. "we can skip class verification, if loader loads receiver, since nothing to fear there" loader isReceiver ifFalse: [ self verifyClassOf: oop is: NBExternalAddress generator: gen. ]. asm decorateWith: 'NBExternalAddressType>>pushAsPointer:' during: [ proxy varBytesFirstFieldOf: oop. asm push: asm EAX ]. gen releaseTemps: 1. ! ! !NBExternalAddressType methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/4/2010 00:56'! valueSize ^ self pointerSize! ! !NBExternalAddressType methodsFor: 'emitting code' stamp: 'IgorStasenko 5/28/2012 07:13'! pushAsValue: gen "push handle value" | asm proxy oop | proxy := gen proxy. asm := gen asm. oop := gen reserveTemp. loader emitLoad: gen to: oop. "we can skip class verification, if loader loads receiver, since nothing to fear there" loader isReceiver ifFalse: [ self verifyClassOf: oop is: NBExternalAddress generator: gen. ]. proxy varBytesFirstFieldOf: oop. self valueSize = 4 ifTrue: [ asm push: asm EAX ptr. ] ifFalse: [ self notYetImplemented ]. gen releaseTemps: 1. ! ! !NBExternalArray commentStamp: ''! I am abstract class which provides a convenient interface to work with arrays which elements are values of some external (C) type. In order to use me with concrete element type, you must create a subclass of me and initialize element type properly. Subclassing using public subclass: - if you want to create a public subclass of me, then you should make sure that in class-side #initialize method, you add self-send #initElementType: and specify the element type name to use. (And of course, initialize the class before attempting to create any instances). Subclassing with anonymous subclass: To create an anonymous subclass of me, use #ofType: protocol, i.e.: floatArrayClass := NBExternalArray ofType: 'float'. Please note that separate #at: / #at:put: methods will be automatically added in each and every subclass. Never remove them, despite they looking identical to superclass methods!! !!!!CAUTION!!!! Currently those methods do not perform any range checking for index. So, please make sure you using sane index values (1<= index <= size). Also, note, that class instance variables: elementType and elementSize, once initialized, is considered read-only. Changing them, once you created at least a single instance of your class may lead to funny consequences. Arrays in external memory vs object memory: My instances can work either with data held in object memory or in external memory. The difference is only at instantiation time: To create a new array in object memory, just use #new: protocol: myArray := floatArrayClass new: 10. "create a new array with 10 floats". To allocate a new array in external memory, use #externalNew: protocol: myArray := floatArrayClass externalNew: 10. .. myArray free. "and sure thing, do not forget to free external memory after use". To check whether array uses object memory or external memory , use #isExternal protocol. Also, you can convert any external address into NBExternalArray subclass instance, i.e. suppose some external function returns a pointer (instance of NBExternalAddress): pointer := self callSomeFunc: 1. So, in order to access memory at given address as array of 100 elements of type 'int', you can use following: myArray := (NBExternalArray ofType: 'int') onAddress: pointer size: 100. myArray at: 1. "read first element" myArray at: 2 put: 50. "write second element" myArray do: [:each | ... ] ... etc (sure thing, in the above example, the "NBExternalArray ofType: 'int' " expression is just to demonstrate the intent. It should be replaced with some variable, which you initialize only once and use many times, because creating an anonymous subclass each time would be highly ineffective ) Supported protocols: Since NBExternalTypeArray inherits from ArrayedCollection, you're free to use any protocols defined there as well as in its superclasses. There's only few additions comparing to ArrayedCollection, like #isExternal and #free . Copying: a #copy behavior is special for external arrays: A copy will always use object memory, even if original used external memory. ! !NBExternalArray methodsFor: 'accessing' stamp: 'IgorStasenko 12/7/2012 16:42'! size ^ size! ! !NBExternalArray methodsFor: 'private (code generation)' stamp: 'IgorStasenko 12/7/2012 16:44'! emitCopy: asm "Emit code to copy elementSize bytes from ESP ptr -> EAX ptr " | toCopy offset | toCopy := self class elementSize. toCopy > 8 ifTrue: [ ^ self emitCopyUsingLoop: asm ]. offset := 0. [ toCopy >= 4 ] whileTrue: [ asm mov: asm ESP ptr + offset to: asm ECX; mov: asm ECX to: asm EAX ptr + offset. toCopy := toCopy - 4. offset := offset + 4. ]. toCopy >= 2 ifTrue: [ asm mov: asm ESP ptr16 + offset to: asm CX; mov: asm CX to: asm EAX ptr16 + offset. toCopy := toCopy - 2. offset := offset + 2. ]. toCopy > 0 ifTrue: [ " last byte " asm mov: asm ESP ptr8 + offset to: asm CL; mov: asm CL to: asm EAX ptr8 + offset. ]. ! ! !NBExternalArray methodsFor: 'accessing' stamp: 'IgorStasenko 12/7/2012 16:42'! address "For external memory arrays, sometimes we may need to get an address" ^ data! ! !NBExternalArray methodsFor: 'private (code generation)' stamp: 'IgorStasenko 12/7/2012 16:44'! emitWrite " This method generates a native code for #at:put: method. The primitive will store a single value at given index in array. The value type (elementType) and its size (elementSize) controlled by class side. Note, data can be either variable-byte object (holding data in object memory), or instance of NBExternalAddress (holding data in external memory). To conform with common #at:put: behavior for collections, answer the value we're just put. !!!!!!Note: no range checking for index!!!!!! " ^ (self nbCalloutIn: thisContext sender) function: ' oop ( oop value , uint32 index , void * data , ' , self class elementType , ' value )' emit: [:gen :proxy :asm | | oop | oop := gen reserveTemp. "save value oop into temp to answer it when we done" asm pop: asm EAX; mov: asm EAX to: oop. " index " asm pop: asm EAX; dec: asm EAX; mov: self class elementSize to: asm ECX; mul: asm ECX; pop: asm ECX; "pointer to array first element " add: asm EAX with: asm ECX. " EAX now = @data + (elementSize * (index - 1 ) ) " self emitCopy: asm. "and finally, return original object " asm mov: oop to: asm EAX . ]. ! ! !NBExternalArray methodsFor: 'initialize-release' stamp: 'IgorStasenko 12/7/2012 16:43'! initializeWithSize: aSize "initialize an instance of receiver with data held in object memory heap " size := aSize. data := ByteArray new: size * self class elementSize. ! ! !NBExternalArray methodsFor: 'private (code generation)' stamp: 'IgorStasenko 12/7/2012 16:44'! emitRead " This method generates a native code for #at: method the primitive will read a single element at given index in array. the value type (elementType) and its size (elementSize) controlled by class side. Note, data (instance variable) can hold either variable-byte object (holding data in object memory), or instance of NBExternalAddress s !!!!!!Note: no range checking for index!!!!!! " ^ (self nbCalloutIn: thisContext sender) function: 'oop ( uint32 index , void * data )' emit: [:gen :proxy :asm | " index " asm pop: asm EAX; dec: asm EAX; mov: self class elementSize to: asm ECX; mul: asm ECX; pop: asm ECX; "pointer to array first element -> ECX " add: asm EAX with: asm ECX. " EAX <- @data + (elementSize * (index - 1 ) ) " "Emit code to read a value from given address and return oop" (gen resolveType: self class elementType) readOop: asm EAX ptr generator: gen. ] ! ! !NBExternalArray methodsFor: 'initialize-release' stamp: 'IgorStasenko 12/7/2012 16:43'! initializeWithAddress: anExternalAddress Size: aSize "initialize an instance of receiver with data held in external memory" size := aSize. data := anExternalAddress. ! ! !NBExternalArray methodsFor: 'accessing' stamp: 'IgorStasenko 12/7/2012 16:42'! at: index put: value "Set value at 1-based index. Note, this method used as a template for my anonymous subclasses. " ^ self emitWrite ! ! !NBExternalArray methodsFor: 'accessing' stamp: 'IgorStasenko 12/7/2012 16:42'! at: index "Answer an element using 1-based index. Note, this method used as a template for my anonymous subclasses. " ^ self emitRead! ! !NBExternalArray methodsFor: 'copying' stamp: 'IgorStasenko 12/7/2012 16:43'! postCopy self isExternal ifTrue: [ "copy the data from external memory into newly allocated byte array " | newData sz | sz := self class elementSize * size. newData := ByteArray new: sz. NativeBoost memCopy: data to: newData size: sz. data := newData. ] ifFalse: [ data := data copy. ]! ! !NBExternalArray methodsFor: 'testing' stamp: 'IgorStasenko 12/7/2012 16:44'! isExternal "answer true if data referenced by receiver located in external heap, or just in object memory " ^ data class ~= ByteArray ! ! !NBExternalArray methodsFor: 'initialize-release' stamp: 'IgorStasenko 12/7/2012 16:43'! free "A convenience method, to explicitly free external memory, symmetrical when using #externalNew: protocol for creating receiver. Do nothing if receiver is not external array. " self isExternal ifTrue: [ data free. ].! ! !NBExternalArray methodsFor: 'private (code generation)' stamp: 'IgorStasenko 12/7/2012 16:44'! emitCopyUsingLoop: asm | ssi sdi | "copy the value using loop " ssi := asm reserveTemp. sdi := asm reserveTemp. asm mov: asm ESI to: ssi; mov: asm EDI to: sdi; cld; mov: asm ESP to: asm ESI; mov: asm EAX to: asm EDI; mov: self class elementSize to: asm ECX; rep;movsb; mov: ssi to: asm ESI; mov: sdi to: asm EDI; releaseTemps: 2. ! ! !NBExternalArray class methodsFor: 'instance creation' stamp: 'IgorStasenko 12/7/2012 16:45'! new: numberOfElements ^ self basicNew initializeWithSize: numberOfElements! ! !NBExternalArray class methodsFor: 'class initialization' stamp: 'StephaneDucasse 8/13/2013 17:42'! initialize NBExternalArray allSubclassesDo: #installAccessors.! ! !NBExternalArray class methodsFor: 'accessing' stamp: 'IgorStasenko 12/7/2012 16:45'! elementSize ^ elementSize! ! !NBExternalArray class methodsFor: 'class initialization' stamp: 'IgorStasenko 6/27/2013 16:15'! initElementType: aTypeName "Initialize the element type and size. If you want to use a public subclass of me, then make sure you call this method in your class #initialize method. " elementType := aTypeName. elementSize := (NBFFICallout new requestor: self; resolveType: elementType) typeSize . self installAccessors.! ! !NBExternalArray class methodsFor: 'session management' stamp: 'IgorStasenko 4/1/2014 17:21'! updateElementSize "Update the element size, in case of session change where type is an external structure which uses different memory alignment on given platform " elementSize := (NBFFICallout new requestor: self; resolveType: elementType) typeSize . ! ! !NBExternalArray class methodsFor: 'private' stamp: 'IgorStasenko 2/3/2014 18:16'! installAccessors "Copy superclass methods, which serve as a template where generated code will be installed. Each subclass of NBExternalArray should implement (override) these key methods " Author useAuthor: 'NativeBoost' during: [ self basicAddSelector: #at: withMethod: (NBExternalArray >> #at: ) copy. self basicAddSelector: #at:put: withMethod: (NBExternalArray >> #at:put: ) copy. self organization classify: #at: under: NativeBoost automaticallyGeneratedCodeCategory. self organization classify: #at:put: under: NativeBoost automaticallyGeneratedCodeCategory. ].! ! !NBExternalArray class methodsFor: 'class factory' stamp: 'CiprianTeodorov 12/16/2012 15:50'! ofType: aTypeName "Answer an anonymous subclass of receiver, ready for use for creating array(s) with given element type." ^ self anonymousSubclassInitElementType: aTypeName! ! !NBExternalArray class methodsFor: 'private' stamp: 'IgorStasenko 12/3/2013 13:37'! anonymousSubclassInitElementType: aTypeName "create and initialize the anonymous subclass of me" ^ NBExternalArray newAnonymousSubclass initElementType: aTypeName. ! ! !NBExternalArray class methodsFor: 'instance creation' stamp: 'IgorStasenko 12/7/2012 16:45'! onAddress: anNBExternalAddress size: desiredSize ^ self basicNew initializeWithAddress: anNBExternalAddress Size: desiredSize ! ! !NBExternalArray class methodsFor: 'instance creation' stamp: 'IgorStasenko 12/7/2012 16:45'! externalNew: numberOfElements "answer a fresh instance of receiver, allocated on external memory " ^ self onAddress: (NativeBoost allocate: elementSize * numberOfElements) size: numberOfElements! ! !NBExternalArray class methodsFor: 'accessing' stamp: 'IgorStasenko 12/7/2012 16:45'! elementType ^ elementType! ! !NBExternalArray class methodsFor: 'session management' stamp: 'IgorStasenko 3/31/2014 16:21'! initializeForNewSession self allSubclassesDo: [ :each | each updateElementSize ]! ! !NBExternalArrayTest methodsFor: 'tests - class protocols' stamp: 'IgorStasenko 12/7/2012 01:22'! testAccessors "make sure a generated class has accessors installed " | cls m_at m_atput | cls := self apiClass ofType: 'int32' . self assert: (cls methodDict includesKey: #at: ). self assert: (cls methodDict includesKey: #at:put: ). m_at := cls compiledMethodAt: #at: . m_atput := cls compiledMethodAt: #at:put: . "make sure they are properly installed" self assert: m_at methodClass == cls. self assert: m_atput methodClass == cls. "make sure they are not same as in superclass " self assert: m_at ~~ (self apiClass compiledMethodAt: #at: ). self assert: m_atput ~~ (self apiClass compiledMethodAt: #at:put: ). ! ! !NBExternalArrayTest methodsFor: 'misc' stamp: 'IgorStasenko 12/7/2012 16:06'! apiClass ^ NBExternalArray ! ! !NBExternalArrayTest methodsFor: 'tests - instances' stamp: 'IgorStasenko 12/7/2012 02:45'! testExternalArray | cls array | cls := self apiClass ofType: 'int32' . [ array := cls externalNew: 10. self assert: array size equals: 10. "instantiating with #externalNew: should create an array in external memory " self assert: array isExternal equals: true. self assert: (array at: 1 put: 42) equals: 42. self assert: (array at: 1) equals: 42. self assert: (array at: 10 put: 420) equals: 420. self assert: (array at: 10) = 420. ] ensure: [ array free ] ! ! !NBExternalArrayTest methodsFor: 'tests - instances' stamp: 'IgorStasenko 12/7/2012 02:44'! testExternalCopy | cls array copy | cls := self apiClass ofType: 'int32' . [ array := cls externalNew: 10. array at: 1 put: 2. array at: 2 put: 3. copy := array copy. "#copy of external array should create a copy in object memory heap " self assert: copy isExternal equals: false. "and , of course, copies should be equal " self assert: array = copy. ] ensure: [ array free ] ! ! !NBExternalArrayTest methodsFor: 'tests - class protocols' stamp: 'IgorStasenko 12/7/2012 02:22'! testAnonymousClassCreation | cls | cls := self apiClass ofType: 'int32' . "should get an anonymous subclass" self assert: (cls inheritsFrom: self apiClass). ".. with properly initialized values" self assert: cls elementType equals: 'int32'. self assert: cls elementSize = 4 . " and, of course, they should not be the same object" self assert: cls ~~ self apiClass. ! ! !NBExternalArrayTest methodsFor: 'tests - instances' stamp: 'IgorStasenko 12/7/2012 02:22'! testBasicProtocol | cls array | cls := self apiClass ofType: 'int32' . array := cls new: 10. self assert: array size equals: 10. "instantiating with #new: should create an array in object memory " self assert: array isExternal equals: false. self assert: (array at: 1 put: 42) equals: 42. self assert: (array at: 1) equals: 42. self assert: (array at: 10 put: 420) equals: 420. self assert: (array at: 10) = 420. ! ! !NBExternalEnumFromPairsTest methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/13/2012 20:14'! cbClass ^NBTestCallbackReturnEnum1 ! ! !NBExternalEnumFromPairsTest methodsFor: 'native' stamp: 'CiprianTeodorov 12/13/2012 20:26'! primEnumToInt1: aMyEnumInst ^ NBFFICallout cdecl: {NBInt32. {self enumClass. #aMyEnumInst}} emitCall: [ :gen :proxy :asm | asm pop: asm EAX ]! ! !NBExternalEnumFromPairsTest methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/13/2012 20:27'! enumToInt: anEnum ^self primEnumToInt1: anEnum ! ! !NBExternalEnumFromPairsTest methodsFor: 'native' stamp: 'CiprianTeodorov 12/13/2012 20:25'! primExecuteCallbackEnumReturn1: anEnumCb ^ NBFFICallout cdecl: {self enumClass. {self cbClass. #anEnumCb}} emitCall: [ :gen :proxy :asm | asm pop: asm EAX. asm push: 2400 asImm. asm call: asm EAX ] options: #(#optMayGC)! ! !NBExternalEnumFromPairsTest methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/13/2012 20:25'! executeCb: anEnumCb ^self primExecuteCallbackEnumReturn1: anEnumCb ! ! !NBExternalEnumFromPairsTest methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/13/2012 20:01'! enumClass ^NBTestEnumerationFromPairs ! ! !NBExternalEnumTests methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/13/2012 20:06'! cbClass ^NBTestCallbackReturnEnum! ! !NBExternalEnumTests methodsFor: 'tests' stamp: 'CiprianTeodorov 12/13/2012 20:07'! testNotEnumMember self should: [ self enumClass TTT ] raise: MessageNotUnderstood ! ! !NBExternalEnumTests methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/11/2012 19:53'! enumClass ^NBTestEnumeration ! ! !NBExternalEnumTests methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/13/2012 20:27'! enumToInt: anEnum ^self primEnumToInt: anEnum ! ! !NBExternalEnumTests methodsFor: 'tests' stamp: 'CiprianTeodorov 12/10/2012 19:58'! testEnumIncludes self assert: (self enumClass includes: #DDD). self deny: (self enumClass includes: #EEE)! ! !NBExternalEnumTests methodsFor: 'tests' stamp: 'CiprianTeodorov 12/10/2012 19:57'! testIntToEnum self assert: (self primIntToEnum: 1) value = 1 . self assert: (self primIntToEnum: 2) value = 2. self assert: (self primIntToEnum: 3) value = 3. self assert: (self primIntToEnum: 2400) value = 2400.! ! !NBExternalEnumTests methodsFor: 'tests' stamp: 'MarcusDenker 2/27/2013 09:00'! testCallbackWrongReturn "there is an issue with callback return. If it fails I cannot see how we can catch the exception and continue" "so this test is supposed to fail for now." "In the future we might accept enumeration representation values (int/uint) and fix this" self skip. self should: [Error signal. self primExecuteCallbackEnumReturn: self callbackWrongReturn ] raise: NBNativeCodeError! ! !NBExternalEnumTests methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/23/2013 12:44'! testCallbackEnumFromInt |result| self skip. result := (self executeCb: self callback ). self assert: (result isKindOf: self enumClass ). self assert: result value = 2400. self assert: result item = #DDD. ! ! !NBExternalEnumTests methodsFor: 'native' stamp: 'CiprianTeodorov 12/13/2012 20:04'! primEnumToInt: aMyEnumInst ^ NBFFICallout cdecl: {NBInt32. {self enumClass. #aMyEnumInst}} emitCall: [ :gen :proxy :asm | asm pop: asm EAX ]! ! !NBExternalEnumTests methodsFor: 'tests' stamp: 'CiprianTeodorov 12/13/2012 19:59'! testFromIntegerFailure self should: [ self enumClass fromInteger: 234 ] raise: Error! ! !NBExternalEnumTests methodsFor: 'tests' stamp: 'CiprianTeodorov 12/10/2012 21:04'! testNewError self should: [ self enumClass new ] raise: ShouldNotImplement! ! !NBExternalEnumTests methodsFor: 'initialize-release' stamp: 'CiprianTeodorov 12/13/2012 20:02'! initialize super initialize. self enumClass initialize! ! !NBExternalEnumTests methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/24/2013 14:06'! testCallbackAAA |result| self skip: 'workaround: this crashes the VM sometimes'. result := (self executeCb: self callbackAAA ). self assert: (result isKindOf: self enumClass ). self assert: result value = 1. self assert: result item = #AAA.! ! !NBExternalEnumTests methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/23/2013 12:46'! primExecuteCallbackEnumReturn: anEnumCb "This code misssing the stack alignment before doing callback. most probably is the reason of crashing VM." self halt. ^ NBFFICallout cdecl: {self enumClass. {self cbClass. #anEnumCb}} emitCall: [ :gen :proxy :asm | asm pop: asm EAX. asm push: 2400 asImm. asm call: asm EAX ] options: #(#optMayGC)! ! !NBExternalEnumTests methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/13/2012 20:24'! executeCb: anEnumCb ^self primExecuteCallbackEnumReturn: anEnumCb ! ! !NBExternalEnumTests methodsFor: 'tests' stamp: 'CiprianTeodorov 12/10/2012 20:11'! testEnumIdents self assert: self enumClass AAA value = 1. self assert: self enumClass DDD value = 2400! ! !NBExternalEnumTests methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/13/2012 20:06'! callbackAAA ^ self cbClass on: [ :anInt | self enumClass AAA ]! ! !NBExternalEnumTests methodsFor: 'native' stamp: 'CiprianTeodorov 12/13/2012 20:05'! primIntToEnum: anInteger ^ NBFFICallout cdecl: {self enumClass. {#NBInt32. #anInteger}} emitCall: [ :gen :proxy :asm | asm pop: asm EAX. ]! ! !NBExternalEnumTests methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/13/2012 20:06'! callbackWrongReturn ^ self cbClass on: [ :anInt | "this callback will return a plain integer" self enumClass itemAt: anInt ]! ! !NBExternalEnumTests methodsFor: 'tests' stamp: 'CiprianTeodorov 12/13/2012 19:59'! testFromIntegerOk self assert: (self enumClass fromInteger: 1) value = 1 . self assert: (self enumClass fromInteger: 2) value = 2. self assert: (self enumClass fromInteger: 3) value = 3. self assert: (self enumClass fromInteger: 2400) value = 2400.! ! !NBExternalEnumTests methodsFor: 'tests' stamp: 'CiprianTeodorov 12/10/2012 19:57'! testIntToEnumNotIncluded self assert: (self primIntToEnum: 7) value = 7. self assert: (self primIntToEnum: 3) value = 3. self assert: (self primIntToEnum: 7) item isNil. self assert: (self primIntToEnum: 256) item isNil.! ! !NBExternalEnumTests methodsFor: 'tests' stamp: 'CiprianTeodorov 12/13/2012 20:27'! testEnumToInt self assert: (self enumToInt: self enumClass AAA) = 1. self assert: (self enumToInt: self enumClass BBB) = 2. self assert: (self enumToInt: self enumClass CCC) = 3. self assert: (self enumToInt: self enumClass DDD) = 2400.! ! !NBExternalEnumTests methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/13/2012 20:06'! callback ^ self cbClass on: [ :anInt | self enumClass at: (self enumClass itemAt: anInt) ]! ! !NBExternalEnumeration commentStamp: 'CiprianTeodorov 12/12/2012 23:03'! NBExternalEnumerationType reifies the enum declarations in C and offers a nice interface (especially in terms of debug/inspect). To use it just subclass the NBExternalEnumeration and add an #enumDecl method to the class side such as: NBExternalEnumeration subclass: #NBTestEnumeration instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Tests' NBTestEnumeration class>>enumDecl ^ {(#AAA -> 1). (#BBB -> 2). (#CCC -> 3). (#DDD -> 2400)} asDictionary DO NOT FORGET to call the #initialize method on your class. The rest is automatically done ;) You can use your new enum in two ways: - add it to a client class poolDictionaries list (see #NBExternalEnumTests for an example), and then just write CCC in your code -- CCC here is an item of your enum - send the name of an item to your class --- NBTestEnumeration DDD The NBExternalEnumeration implements (instance and class) some more API methods like: #itemAt: retrieves the item having a specific value --- NBTestEnumeration itemAt: 2 #includes: checks the existence of a specific item in the enum --- NBTestEnumeration includes: #AAA! !NBExternalEnumeration methodsFor: 'accessing' stamp: 'CamilloBruni 2/23/2013 13:06'! value ^value! ! !NBExternalEnumeration methodsFor: 'comparing' stamp: 'CamilloBruni 2/23/2013 13:05'! = anEnumInst ^ self class == anEnumInst class and: [ self value = anEnumInst value ]! ! !NBExternalEnumeration methodsFor: 'accessing' stamp: 'CamilloBruni 2/23/2013 13:06'! value: anObject value := anObject ! ! !NBExternalEnumeration methodsFor: 'accessing' stamp: 'CamilloBruni 2/23/2013 13:05'! item ^ self class itemAt: value! ! !NBExternalEnumeration methodsFor: 'printing' stamp: 'CamilloBruni 2/23/2013 13:06'! printOn: stream super printOn: stream. stream nextPut: $(; nextPutAll: self item printString; nextPut: $)! ! !NBExternalEnumeration class methodsFor: 'error handling' stamp: 'CiprianTeodorov 12/10/2012 20:01'! doesNotUnderstand: aMessage | v | ^ (v := self at: aMessage selector) ifNil: [ super doesNotUnderstand: aMessage ] ifNotNil: [ v ]! ! !NBExternalEnumeration class methodsFor: 'enum declaration' stamp: 'CiprianTeodorov 12/15/2012 15:19'! enumDecl ^#()! ! !NBExternalEnumeration class methodsFor: 'class initialization' stamp: 'CiprianTeodorov 2/6/2013 21:33'! initialize | unsigned | unsigned := true. self classPool: (self initializeEnum associations collect: [ :assoc | (unsigned and: [ assoc value < 0 ]) ifTrue: [ unsigned := false ]. assoc key -> (self basicNew value: assoc value) ]) asDictionary. representationType := unsigned ifTrue: [ NBUInt32 new ] ifFalse: [ NBInt32 new ]! ! !NBExternalEnumeration class methodsFor: 'instance creation' stamp: 'CiprianTeodorov 12/10/2012 19:59'! new ^self shouldNotImplement ! ! !NBExternalEnumeration class methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/10/2012 20:20'! at: anItem ^ self classPool at: anItem ifAbsent: [ nil ]! ! !NBExternalEnumeration class methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/10/2012 20:17'! itemAt: aValue ifAbsent: exceptionBlock self classPool associationsDo: [ :assoc | aValue = assoc value value ifTrue: [ ^ assoc key ] ]. ^ exceptionBlock value! ! !NBExternalEnumeration class methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/13/2012 19:57'! fromInteger: anIntegerValue | theItem | theItem := self itemAt: anIntegerValue. theItem ifNil: [ self error: 'Invalid value for ' , self name , ' enumeration' ]. ^ self at: theItem! ! !NBExternalEnumeration class methodsFor: 'converting' stamp: 'CiprianTeodorov 2/6/2013 21:34'! asNBExternalType: aTypeName ^ NBExternalEnumerationType objectClass: self representationType: self representationType! ! !NBExternalEnumeration class methodsFor: 'class initialization' stamp: 'CiprianTeodorov 12/13/2012 08:20'! initializeEnum | decl | decl := self enumDecl. decl isDictionary ifTrue: [ ^ decl ]. decl := Dictionary newFromPairs: decl. ^ decl! ! !NBExternalEnumeration class methodsFor: 'accessing' stamp: 'CiprianTeodorov 2/6/2013 21:34'! representationType ^representationType! ! !NBExternalEnumeration class methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/10/2012 20:17'! itemAt: aValue ^ self itemAt: aValue ifAbsent: [ nil ]! ! !NBExternalEnumeration class methodsFor: 'testing' stamp: 'CiprianTeodorov 12/10/2012 19:47'! includes: aSymbol ^self classPool includesKey: aSymbol ! ! !NBExternalEnumerationType methodsFor: 'emitting code' stamp: 'CiprianTeodorov 2/6/2013 21:38'! coerceReturnValue: gen "value is in EAX, get a ST Integer and place it in the value ivar" | asm proxy valueOop oop done | proxy := gen proxy. asm := gen asm. valueOop := gen reserveTemp. oop := gen reserveTemp. self representationType coerceReturnValue: gen. asm mov: asm EAX to: valueOop. proxy pushRemappableOop: valueOop. gen emitFetchClass: objectClass. proxy instantiateClass: asm EAX indexableSize: 0. "EAX <- our instance " asm mov: asm EAX to: oop. proxy popRemappableOop. asm mov: asm EAX to: valueOop. proxy storePointer: self valueIvarIndex ofObject: oop withValue: valueOop. asm mov: oop to: asm EAX. "return the oop" gen releaseTemps: 2.! ! !NBExternalEnumerationType methodsFor: 'emitting code' stamp: 'CiprianTeodorov 12/25/2012 13:29'! pushAsValue: gen "push value" |asm proxy oop| proxy := gen proxy. asm := gen asm. oop := gen reserveTemp. loader emitLoad: gen to: oop. "Special case: do not emit type checking if argument is receiver" (loader isReceiver and: [ gen requestor includesBehavior: objectClass ]) ifFalse: [ self verifyClassOf: oop is: objectClass generator: gen. ]. proxy fetchPointer: (self valueIvarIndex) ofObject: oop. "value ivar" proxy integerValueOf: asm EAX. "handle value" asm push: asm EAX. gen releaseTemps: 1. ! ! !NBExternalEnumerationType methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/25/2012 13:29'! objectClass: anObject objectClass := anObject! ! !NBExternalEnumerationType methodsFor: 'emitting code' stamp: 'CiprianTeodorov 2/6/2013 21:51'! coerceOopToOperand: gen ifFailedJumpTo: aLabel "coerce a object - oop , provided by loader and then put a result into an appropriate operand (memory/register), answer that operand" | asm proxy oop class | self assert: pointerArity = 0. asm := gen asm. proxy := gen proxy. oop := gen reserveTemp. class := gen reserveTemp. asm mov: asm EAX to: oop. gen proxy fetchClassOf: oop. asm mov: asm EAX to: class. gen emitFetchClass: self objectClass. asm cmp: asm EAX with: class; jne: aLabel. proxy fetchPointer: self valueIvarIndex ofObject: oop. "value ivar" self representationType coerceOopToOperand: gen ifFailedJumpTo: aLabel. asm push: asm EAX. gen releaseTemps: 2! ! !NBExternalEnumerationType methodsFor: 'printing' stamp: 'CiprianTeodorov 12/25/2012 13:29'! printOn: aStream aStream nextPutAll: 'External enum(' , objectClass name , ')' ! ! !NBExternalEnumerationType methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/11/2012 19:19'! representationType: anObject representationType := anObject! ! !NBExternalEnumerationType methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/25/2012 13:29'! valueIvarIndex " return a zero-based index " ^ ( objectClass instVarIndexFor: #value ifAbsent: [ self error: ' should not happen ' ] ) - 1 ! ! !NBExternalEnumerationType methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/11/2012 19:19'! representationType ^ representationType! ! !NBExternalEnumerationType methodsFor: 'emitting code' stamp: 'IgorStasenko 6/28/2013 14:19'! pushAsPointer: gen self error: 'Pointer to enumeration values are not supported'. ! ! !NBExternalEnumerationType methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/11/2012 21:45'! valueSize ^4! ! !NBExternalEnumerationType methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/25/2012 13:29'! objectClass ^ objectClass! ! !NBExternalEnumerationType class methodsFor: 'instance creation' stamp: 'CiprianTeodorov 12/25/2012 13:29'! objectClass: aClass representationType: anIntegerType ^ self new objectClass: aClass; representationType: anIntegerType! ! !NBExternalEnumerationType class methodsFor: 'instance creation' stamp: 'CiprianTeodorov 12/25/2012 13:29'! objectClass: aClass ^ self objectClass: aClass representationType: NBUInt32 new! ! !NBExternalHandle commentStamp: 'IgorStasenko 2/24/2012 17:37'! Usually, my instances representing an opaque object handle returned by external function. There's little what we can do with it, except from passing as argument to another function(s). I hold a byte array of a pointer size (typicaly 4 or 8 bytes). You can set the raw handle value with #value: and read it with #value. Note, do not subclass from me directly. If you want to represent some opaque C data structure (handle, stucture, pointer to structure etc), subclass from NBExternalObject instead. Otherwise, if you insist, override #asNBExternalType: method on class side in own subclass to provide own marshalling for instances of your subclass(es) (but it makes even less sense since once you define own #asNBExternalType:, you free to use any base class for your subclasses, unless of course you want to reuse some of my methods)! !NBExternalHandle methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 02:41'! asUnsignedLong "slow version" ^ (self at: 1) + ((self at: 2) << 8) + ((self at: 3) <<16) + ((self at: 4) << 24)! ! !NBExternalHandle methodsFor: 'accessing' stamp: 'IgorStasenko 11/24/2012 16:20'! value ^ self nbCallout function: #(size_t () ) emit: [:gen :proxy :asm | proxy receiver. proxy varBytesFirstFieldOf: asm EAX. self class instanceSize = 4 ifTrue: [ asm mov: asm EAX ptr to: asm EAX. ] ifFalse: [ "not implemented yet, sorry" self notYetImplemented. ]. ] ! ! !NBExternalHandle methodsFor: 'accessing' stamp: 'IgorStasenko 11/24/2012 16:20'! value: aPositiveInteger ^ self nbCallout function: #(oop (size_t aPositiveInteger)) emit: [:gen :proxy :asm | self class instanceSize = 4 ifTrue: [ | temp | proxy receiver. proxy varBytesFirstFieldOf: asm EAX. asm mov: asm ESP ptr to: asm EDX; mov: asm EDX to: asm EAX ptr. ] ifFalse: [ "not implemented yet, sorry" self notYetImplemented. ]. proxy receiver ] ! ! !NBExternalHandle methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 13:32'! asUImm32 ^ self asUnsignedLong asUImm32! ! !NBExternalHandle methodsFor: 'printing' stamp: 'Igor.Stasenko 4/29/2010 12:28'! printOn: aStream aStream nextPutAll: '@ 16r'; nextPutAll: (self value printStringBase: 16) ! ! !NBExternalHandle methodsFor: 'comparing' stamp: 'TorstenBergmann 8/13/2013 20:03'! = anotherExternalHandle ^self species = anotherExternalHandle species and: [ self value = anotherExternalHandle value ] ! ! !NBExternalHandle methodsFor: 'testing' stamp: 'IgorStasenko 6/2/2012 14:38'! isNull ^ self value = 0! ! !NBExternalHandle methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 13:25'! asUImm ^ self asUnsignedLong asUImm! ! !NBExternalHandle class methodsFor: 'instance creation' stamp: 'IgorStasenko 2/24/2012 17:02'! asNBExternalType: gen self error: 'use NBExternalObject instead'. "Note, do not subclass from me directly. If you want to represent any opaque C structure (stucture, pointer to structure etc), subclass from NBExternalObject instead. Otherwise, if you insist, override this method in own subclass to provide own marshalling for instances of your object(s)"! ! !NBExternalHandle class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/2/2010 14:08'! value: aValue ^ self new value: aValue! ! !NBExternalHandle class methodsFor: 'instance creation' stamp: 'IgorStasenko 5/26/2012 14:55'! new ^ self basicNew: self instanceSize ! ! !NBExternalHandle class methodsFor: 'fields description' stamp: 'IgorStasenko 5/26/2012 14:57'! instanceSize ^ NBExternalType pointerSize ! ! !NBExternalHeapManager commentStamp: 'Igor.Stasenko 9/25/2010 10:04'! This is a simplistic implementation of external heap manager. Using it , you can allocate or free external memory. - should not throw any exceptions. If allocation fails, should simply answer nil/0 ! !NBExternalHeapManager methodsFor: 'memory operations' stamp: 'Igor.Stasenko 9/25/2010 00:45'! allocate: numBytes "Allocate a numBytes on heap, answer an address to first byte of allocated memory" ^ sema critical: [ | freeBlock page | "yes, the free space search is implemented naively, by now" freeBlock := freeBlocks detect: [:block | block length >= numBytes] ifNone: [ page := self allocatePage: numBytes. page firstBlock ]. freeBlock reserve: numBytes for: self. reservedBlocks at: freeBlock address put: freeBlock. freeBlock address ] ! ! !NBExternalHeapManager methodsFor: 'memory operations' stamp: 'Igor.Stasenko 9/24/2010 23:44'! free: address sema critical: [ | block | block := reservedBlocks removeKey: address ifAbsent: [ self error: 'Unable to find a memory block with given address' ]. block makeFreeFor: self ] ! ! !NBExternalHeapManager methodsFor: 'callbacks' stamp: 'Igor.Stasenko 9/25/2010 00:48'! addFreeBlock: aMemoryBlock "Check if free block covers entire page. and if it is, then free the page" (self checkForFreePage: aMemoryBlock) ifFalse: [ freeBlocks add: aMemoryBlock ] ! ! !NBExternalHeapManager methodsFor: 'memory pages' stamp: 'Igor.Stasenko 9/25/2010 00:18'! alignToPageSize: requestedSize " pages is 4kb wide" | u align | align := self pageAlignment. ^ (u := requestedSize \\ align) > 0 ifTrue: [ requestedSize + align - u ] ifFalse: [ requestedSize ]! ! !NBExternalHeapManager methodsFor: 'memory pages' stamp: 'Igor.Stasenko 9/25/2010 00:11'! allocatePage: requestedSize | bytesToAllocate addr page | bytesToAllocate := self alignToPageSize: (self minimumPageSize max: requestedSize). addr := self primAllocatePage: bytesToAllocate. page := NBMemoryPage address: addr length: bytesToAllocate. pages at: addr put: page. ^ page ! ! !NBExternalHeapManager methodsFor: 'testing' stamp: 'Igor.Stasenko 9/24/2010 23:51'! isValidAddress: anAddress ^ self isValidAddress: anAddress size: 1! ! !NBExternalHeapManager methodsFor: 'memory pages' stamp: 'Igor.Stasenko 9/25/2010 00:35'! minimumPageSize " lets grab minimum 32kb pages" ^ 32768! ! !NBExternalHeapManager methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 00:22'! numBlocks ^ freeBlocks size + reservedBlocks size! ! !NBExternalHeapManager methodsFor: 'memory pages' stamp: 'Igor.Stasenko 9/25/2010 00:06'! pageAlignment " x86 4kb pages" ^ 4096! ! !NBExternalHeapManager methodsFor: 'abstract' stamp: 'Igor.Stasenko 9/25/2010 00:19'! primAllocatePage: numBytes self subclassResponsibility ! ! !NBExternalHeapManager methodsFor: 'callbacks' stamp: 'Igor.Stasenko 9/24/2010 23:43'! removeFreeBlock: aMemoryBlock freeBlocks remove: aMemoryBlock ifAbsent: []! ! !NBExternalHeapManager methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 00:22'! numPages ^ pages size! ! !NBExternalHeapManager methodsFor: 'initialization' stamp: 'Igor.Stasenko 9/24/2010 23:57'! initialize sema := Semaphore forMutualExclusion. pages := Dictionary new. freeBlocks := IdentitySet new. reservedBlocks := Dictionary new.! ! !NBExternalHeapManager methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 00:36'! numAllocatedBlocks ^ reservedBlocks size! ! !NBExternalHeapManager methodsFor: 'testing' stamp: 'Igor.Stasenko 9/25/2010 00:20'! isValidAddress: anAddress size: numBytes "check, if given memory range (at given address and numBytes size) is valid (currently allocated) using this heap manager " ^ sema critical: [ reservedBlocks anySatisfy: [:blk | blk address <= anAddress and: [blk address + blk length >= (anAddress + numBytes)]] ]! ! !NBExternalHeapManager methodsFor: 'memory pages' stamp: 'Igor.Stasenko 9/25/2010 00:50'! freePage: aMemoryPage pages removeKey: aMemoryPage address. freeBlocks remove: aMemoryPage firstBlock ifAbsent: []. ^ self primFreePage: aMemoryPage ! ! !NBExternalHeapManager methodsFor: 'callbacks' stamp: 'Igor.Stasenko 9/25/2010 00:47'! checkForFreePage: aMemoryBlock "Check if free block covers entire page. and if it is, then free the page" pages at: aMemoryBlock address ifPresent: [:page | page length = aMemoryBlock length ifTrue: [ self freePage: page. ^ true] ]. ^ false! ! !NBExternalHeapManager methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 00:36'! numFreeBlocks ^ freeBlocks size! ! !NBExternalHeapManager methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/24/2010 23:31'! totalAllocatedMemory | total | total := 0. sema critical: [ reservedBlocks valuesDo: [:blk | total := total + blk length ]]. ^ total! ! !NBExternalHeapManager methodsFor: 'abstract' stamp: 'Igor.Stasenko 9/25/2010 00:19'! primFreePage: aMemoryPage self subclassResponsibility ! ! !NBExternalHeapManagerTests methodsFor: 'tests' stamp: 'FernandoOlivero 10/5/2010 20:47'! testAllocate " self new testAllocate " | heap address size | size := 100. heap := self newHeap. address := heap allocate: size. self assert: ( heap isValidAddress: address size: size ) . self assert: heap totalAllocatedMemory = size. self assert: heap numPages = 1 . self assert: heap numAllocatedBlocks = 1. heap free: address. self assert: heap numAllocatedBlocks = 0. self assert: heap numPages = 0 . self assert: heap numBlocks = 0 . self assert: (heap isValidAddress: address size: size) not . self assert: heap totalAllocatedMemory = 0. ! ! !NBExternalHeapManagerTests methodsFor: 'tests' stamp: 'FernandoOlivero 10/5/2010 20:45'! testAllocate2 " self new testAllocate2 " | heap addr1 addr2 | heap := self newHeap. addr1 := heap allocate: 1. addr2 := heap allocate: 2. self assert: heap totalAllocatedMemory = 3 . self assert: heap numAllocatedBlocks = 2 . heap free: addr1. self assert: heap numAllocatedBlocks = 1. self assert: heap totalAllocatedMemory = 2 . heap free: addr2. self assert: heap numPages = 0 . self assert: heap numBlocks = 0 . self assert: heap totalAllocatedMemory = 0 . ! ! !NBExternalHeapManagerTests methodsFor: 'accessing' stamp: 'IgorStasenko 8/5/2011 07:20'! newHeap ^ NBMockExternalHeapManager new! ! !NBExternalLibraryWrapper methodsFor: 'utils' stamp: 'IgorStasenko 11/24/2012 16:22'! call: fnSpec " you can override this method if you need to" ^ (self nbCalloutIn: thisContext sender) cdecl; function: fnSpec module: self libraryNameOrHandle ! ! !NBExternalLibraryWrapper methodsFor: 'utils' stamp: 'IgorStasenko 8/20/2011 13:27'! libraryNameOrHandle "provide a handle to the receiver's library" self subclassResponsibility ! ! !NBExternalLibraryWrapper class methodsFor: 'helper' stamp: 'IgorStasenko 11/24/2012 16:23'! createSimpleMethodFor: aSpec ^ String streamContents: [ :str | str nextPutAll: aSpec asMethodSelectorAndArguments; crtab; nextPutAll: ''; cr; crtab; nextPutAll: '^ self call: '; nextPutAll: aSpec asArraySpec; cr ]! ! !NBExternalLibraryWrapper class methodsFor: 'helper' stamp: 'IgorStasenko 11/24/2012 16:23'! createArrayedMethodFor: aSpec ^ String streamContents: [:str | str nextPutAll: aSpec asMethodSelectorAndArrayOfArguments ; crtab; nextPutAll: ''; cr; crtab; nextPutAll: 'argsArray size = ', aSpec arguments size printString, ' ifFalse:[^Error signal: ''Incorrect number of arguments''].'; crtab; nextPutAll: '^ self call: '; nextPutAll: aSpec asArraySpecArrayedArgs ; cr ]. ! ! !NBExternalLibraryWrapper class methodsFor: 'helper' stamp: 'cipt 10/21/2012 20:14'! createMethodFor: aCFunctionDefinition "find the function name" | typeAndName spec source cat | "the parameter list follows the fn name " spec := NBFnSpec namedFunctionFrom: aCFunctionDefinition. spec arguments size > 15 ifTrue: [ source := self createArrayedMethodFor: spec. cat := 'automatically generated arrayed' ] ifFalse: [ source := self createSimpleMethodFor: spec. cat := 'automatically generated' ]. self compile: source classified: cat! ! !NBExternalObject commentStamp: 'IgorStasenko 2/24/2012 17:40'! I representing an external object of one kind, provided by some external library/function. My instance holds a handle, which is used to identify the external object when i am passed as an argument, or when i'm used as a return type in function signature. A typical usage of me is to create a subclass, and then use that subclass name directly in function signatures: NBExternalObject subclass: #MyExternalObject newObj := MyExternalObject newObject. MyExternalObject class>>newObject ^ self nbCall: #(MyExternalObject someExternalFunction() ) here, assume that someExternalFunction() returns some handle (or pointer) to some opaque external structure. By putting NBExternalObject subclass (MyExternalObject) as a return type into the function signature, we are telling the code generator to automatically convert the return value into an instance of a given class and initialize its handle to the value returned by the function. When used as argument type, the value, which is used to pass to the external function is value held in my handle instance variable: MyExternalObject>>compareWith: anotherExternalObject ^ self nbCall: #( void compare ( self , MyExternalObject anotherExternalObject)) The main advantage of using NBExternalObject subclass as a type name for arguments is that it provides type safety by checking the incoming argument, that it is an instance of your class, and nothing else. If not, the primitive will fail without calling the external function. ! !NBExternalObject methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/17/2010 05:03'! handle ^ handle value! ! !NBExternalObject methodsFor: 'initialization' stamp: 'Igor.Stasenko 4/29/2010 12:25'! initialize handle := NBExternalHandle new! ! !NBExternalObject methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/17/2010 05:03'! handle: aUint handle value: aUint! ! !NBExternalObject methodsFor: 'external resource management' stamp: 'IgorStasenko 6/11/2012 05:36'! registerAsExternalResource "Note, subclasses should implement #resourceData and #finalizeResourceData: on class side" NBExternalResourceManager addResource: self. ! ! !NBExternalObject methodsFor: 'printing' stamp: 'Igor.Stasenko 4/29/2010 10:21'! printOn: aStream super printOn: aStream. aStream nextPutAll: '( 0x'; nextPutAll: (handle value printStringBase: 16); space; nextPut: $)! ! !NBExternalObject methodsFor: 'testing' stamp: 'Igor.Stasenko 5/17/2010 14:33'! isNull ^ handle value = 0! ! !NBExternalObject class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/17/2010 14:29'! null ^ self new! ! !NBExternalObject class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 4/29/2010 09:18'! asNBExternalType: gen ^ NBExternalObjectType objectClass: self! ! !NBExternalObjectType commentStamp: 'Igor.Stasenko 4/29/2010 09:17'! I providing coercions for NBExternalObject and its subclasses! !NBExternalObjectType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 13:52'! valueSize ^ self pointerSize! ! !NBExternalObjectType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 11:12'! pushAsPointer: gen "push a pointer to handle value" | asm proxy oop | proxy := gen proxy. asm := gen asm. oop := gen reserveTemp. loader emitLoad: gen to: oop. "we can skip class verification, if loader loads receiver, since nothing to fear there" loader isReceiver ifFalse: [ self verifyClassOf: oop is: objectClass generator: gen. ]. proxy fetchPointer: (self handleIvarIndex) ofObject: oop. "handle ivar" proxy varBytesFirstFieldOf: asm EAX. "handle value ptr" asm push: asm EAX. gen releaseTemps: 1. ! ! !NBExternalObjectType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 09:22'! handleIvarIndex " return a zero-based index " ^ ( objectClass instVarIndexFor: #handle ifAbsent: [ self error: ' should not happen ' ] ) - 1! ! !NBExternalObjectType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 09:18'! objectClass: aClass objectClass := aClass! ! !NBExternalObjectType methodsFor: 'printing' stamp: 'Igor.Stasenko 5/18/2010 01:25'! printOn: aStream aStream nextPutAll: 'External Object(' , objectClass name , ')'! ! !NBExternalObjectType methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/29/2010 09:15'! coerceReturnPointer: gen self error: 'returning pointer to handle ?' "super coerceReturnPointer: gen"! ! !NBExternalObjectType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 09:18'! objectClass ^ objectClass! ! !NBExternalObjectType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 11:10'! coerceReturnValue: gen "handle is in EAX. first, create an instance of NBExternalHandle. Place the handle there , then create an instance of receiver and place handle oop in its handle ivar" | asm proxy result handleOop oop done | proxy := gen proxy. asm := gen asm. result := gen reserveTemp. handleOop := gen reserveTemp. oop := gen reserveTemp. done := asm uniqueLabelName: 'done'. asm mov: asm EAX to: result. gen optReturnNullAsNil ifTrue: [ | notnil | notnil := asm uniqueLabelName: 'notNil'. asm or: asm EAX with: asm EAX; jne: notnil. proxy nilObject. asm jmp: done. asm label: notnil. ]. gen emitFetchClass: NBExternalHandle. proxy instantiateClass: asm EAX indexableSize: self pointerSize. asm mov: asm EAX to: handleOop. proxy varBytesFirstFieldOf: asm EAX. asm mov: result to: asm ECX; mov: asm ECX to: asm EAX ptr. proxy pushRemappableOop: handleOop. gen receiver ifNil: [ gen emitFetchClass: objectClass. ] ifNotNil: [proxy receiver]. proxy instantiateClass: asm EAX indexableSize: 0. "EAX <- our instance " asm mov: asm EAX to: oop. proxy popRemappableOop. asm mov: asm EAX to: handleOop. proxy storePointer: self handleIvarIndex ofObject: oop withValue: handleOop. asm mov: oop to: asm EAX. "return the oop" gen releaseTemps: 3. asm label: done. ! ! !NBExternalObjectType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 11:12'! pushAsValue: gen "push handle value" | asm proxy oop | proxy := gen proxy. asm := gen asm. oop := gen reserveTemp. loader emitLoad: gen to: oop. "Special case: do not emit type checking if argument is receiver" (loader isReceiver and: [ gen requestor includesBehavior: objectClass ]) ifFalse: [ self verifyClassOf: oop is: objectClass generator: gen. ]. proxy fetchPointer: (self handleIvarIndex) ofObject: oop. "handle ivar" proxy varBytesFirstFieldOf: asm EAX. "handle value ptr" asm mov: asm EAX ptr to: asm EAX. "handle value" asm push: asm EAX. gen releaseTemps: 1. ! ! !NBExternalObjectType class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 4/29/2010 09:16'! objectClass: aClass ^ self new objectClass: aClass! ! !NBExternalResourceExecutor commentStamp: ''! i am responsible for finalizing an external resource, registered using external resource manager. When object, registered as external resource being garbage collected, i telling an object's class to finalize it's associated data (by passing an object, received from #resourceData message sent to an object at registration time). I automatically keep tracking for session change (image save/boot), and ignore finalization of resources of old sessions (since they are not longer valid, and cannot be freed since session changed). Like that, a users of NBExternalResourceManager don't need to implement a session checking logic, and need only to: a) register object as external resource: NBExternalResourceManager addResource: anObject. an object should understand the #resourceData message, which is remembered at registration point (it can be any external resource like, id, handle or memory pointer). Then, when object is garbage collected, its class will receive a message to finalize the resource data in #finalizeResourceData: The passed data is exactly same as previously returned by #resourceData method. An example: Imagine that you want to represent an external resource by keeping its handle. Object subclass: #MyExternalObject instanceVariableNames: 'handle' classVariableNames: '' poolDictionaries: '' category: 'XYZ' To let your object(s) to be managed by external resource manager, you need to register it. Usually you do it after successfully claiming an external resource: MyExternalObject>>initialize handle := self createNewExternalResource. "claim resource" self assert: self handleIsValid. "etc..." "Now, register receiver as external resource" NBExternalResourceManager addResource: self "Another form of use is: NBExternalResourceManager addResource: self data: handle. " ---- If you used #addResource: method for registration, you should provide an implementation of #resourceData method: MyExternalObject>>resourceData ^ handle "since we need only handle to identify external resource" ---- Now, for properly finalizing the external resource we should implement: MyExternalObject class>> finalizeResourceData: aHandle ^ self destroyHandle: aHandle. "do whatever is needed to destroy the handle" Note that in #finalizeResourceData: you cannot access any other properties of your instance, since it is already garbage collected. You also don't need to do a session checking, since it is done automatically by resource manager. ! !NBExternalResourceExecutor methodsFor: 'finalizing' stamp: 'IgorStasenko 5/28/2012 03:54'! finalize (NativeBoost sessionChanged: session) ifFalse: [ resourceClass finalizeResourceData: data ]! ! !NBExternalResourceExecutor methodsFor: 'initialization' stamp: 'IgorStasenko 3/23/2012 13:06'! initialize session := NativeBoost uniqueSessionObject ! ! !NBExternalResourceExecutor methodsFor: 'initialize-release' stamp: 'IgorStasenko 3/23/2012 13:04'! resourceClass: aResourceClass data: aData resourceClass := aResourceClass. data := aData! ! !NBExternalResourceManager commentStamp: ''! i am responsible for managing a finalization of external resources. When object, registered as external resource being garbage collected, i telling an object's class to finalize it's associated data (by passing an object, received from #resourceData message sent to an object at registration time). I automatically keep tracking for session change (image save/boot), and ignore finalization of resources of old sessions (since they are not longer valid, and cannot be freed since session changed). Like that, a users of NBExternalResourceManager don't need to implement a session checking logic, and need only to: a) register object as external resource: NBExternalResourceManager addResource: anObject. b) an object should understand the #resourceData message, which is remembered at registration point (it can be any external resource like, id, handle or memory pointer). Then, when object is garbage collected, its class will receive a message to finalize the resource data in #finalizeResourceData: The passed data is exactly same as previously returned by #resourceData method. An example: Imagine that you want to represent an external resource by keeping its handle. Object subclass: #MyExternalObject instanceVariableNames: 'handle' classVariableNames: '' poolDictionaries: '' category: 'XYZ' To let your object(s) to be managed by external resource manager, you need to register it. Usually you do it after successfully claiming an external resource: MyExternalObject>>initialize handle := self createNewExternalResource. "claim resource" self assert: self handleIsValid. "etc..." "Now, register receiver as external resource" NBExternalResourceManager addResource: self "Another form of use is: NBExternalResourceManager addResource: self data: handle. " ---- If you used #addResource: method for registration, you should provide an implementation of #resourceData method: MyExternalObject>>resourceData ^ handle "since we need only handle to identify external resource" ---- Now, for properly finalizing the external resource we should implement: MyExternalObject class>> finalizeResourceData: aHandle ^ self destroyHandle: aHandle. "do whatever is needed to destroy the handle" Note that in #finalizeResourceData: you cannot access any other properties of your instance, since it is already garbage collected. You also don't need to do a session checking, since it is done automatically by resource manager. ! !NBExternalResourceManager methodsFor: 'external resource management' stamp: 'IgorStasenko 3/27/2012 19:11'! addResource: anObject data: resourceData registry add: anObject executor: (NBExternalResourceExecutor new resourceClass: anObject class data: resourceData)! ! !NBExternalResourceManager methodsFor: 'initialization' stamp: 'IgorStasenko 6/2/2012 14:43'! initialize registry := NBFinalizationRegistry new! ! !NBExternalResourceManager methodsFor: 'external resource management' stamp: 'IgorStasenko 3/27/2012 19:11'! addResource: anObject ^ self addResource: anObject data: anObject resourceData ! ! !NBExternalResourceManager class methodsFor: 'accessing' stamp: 'IgorStasenko 3/23/2012 13:08'! soleInstance ^ soleInstance ifNil: [ soleInstance := self new ]! ! !NBExternalResourceManager class methodsFor: 'instance creation' stamp: 'IgorStasenko 6/2/2012 14:37'! reset soleInstance := self new.! ! !NBExternalResourceManager class methodsFor: 'resource management' stamp: 'IgorStasenko 3/28/2012 18:42'! addResource: anObject data: aData self soleInstance addResource: anObject data: aData! ! !NBExternalResourceManager class methodsFor: 'resource management' stamp: 'IgorStasenko 3/23/2012 13:13'! addResource: anObject self soleInstance addResource: anObject ! ! !NBExternalString commentStamp: 'IgorStasenko 8/10/2011 18:46'! NBExternalString type can be used to coerce squeak's String to char* back and forth. Use #String or #NBExternalString as type name. Some functions may accept null as a valid argument (if string is optional). You can set #optStringOrNull in callout options in that case. If type is used as return value type, then C string (char *) converted to ByteString instance. If return value is null, a nil will be answered instead.! !NBExternalString methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 11:12'! coerceReturnValue: gen " Copy a null-terminated C string into a newly created instance of ByteString input - char* string in EAX output - String oop in EAX " | cPtr strLen oop asm proxy notNull done | asm := gen asm. proxy := gen proxy. cPtr := gen reserveTemp. strLen := gen reserveTemp. oop := gen reserveTemp. notNull := asm uniqueLabelName: 'notNull'. done := asm uniqueLabelName: 'done'. asm mov: EAX to: cPtr. "check if return value is NULL, then answer nil instead" asm or: EAX with: EAX; jnz: notNull. proxy nilObject. asm jmp: done. asm label: notNull. "count a number of characters" asm mov: (self strLen: gen) to: strLen. proxy classString. proxy instantiateClass: EAX indexableSize: strLen. asm mov: EAX to: oop. "oop" "copy the string" proxy varBytesFirstFieldOf: EAX. asm push: ESI; push: EDI; mov: cPtr to: ESI; mov: EAX to: EDI; mov: strLen to: ECX; rep; movsb; pop: EDI; pop: ESI; mov: oop to: EAX. asm label: done. gen releaseTemps: 3. ! ! !NBExternalString methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 11:13'! prepareArgumentUsing: gen "prepare the ByteString argument. Allocate a space for string on stack, then copy string contents there and add terminating null character " | asm stringOop len loop done donePreparing notNil | asm := gen asm. loop := asm uniqueLabelName: 'loop'. done := asm uniqueLabelName: 'done'. notNil := asm uniqueLabelName: 'notNil'. donePreparing := asm uniqueLabelName: 'donePreparing'. loader emitLoad: gen. "reserve after emitting load, otherwise, if proxy using stackpointer temp, it will be clobbered" address := gen reserveTemp. stringOop := gen reserveTemp. len := gen reserveTemp. asm mov: EAX to: stringOop. gen optStringOrNull ifTrue: [ "allow passing nil as string, effectively will push null pointer as argument" gen proxy nilObject. asm cmp: EAX with: stringOop; jne: notNil; mov: 0 to: address; "null pointer" jmp: donePreparing. ]. asm label: notNil. gen proxy isBytes: stringOop. asm or: EAX with: EAX. asm jz: gen failedLabel. gen proxy byteSizeOf: stringOop. asm mov: EAX to: len. asm inc: EAX. "add 1 byte for terminating null character" gen reserveStackBytes: EAX andStoreAddrTo: address. gen proxy varBytesFirstFieldOf: stringOop. asm decorateWith: ' copy string contents to the stack ' during: [ asm push: ESI; push: EDI; mov: EAX to: ESI; mov: address to: EDI; mov: len to: ECX; " rep; movsb; -- is flat memory model has ES=DS ? " label: loop; dec: ECX; jl: done; mov: ESI ptr to: AL; mov: AL to: EDI ptr; inc: ESI; inc: EDI; jmp: loop; label: done; mov: 0 to: EDI ptr8; "store null-terminating character" pop: EDI; pop: ESI. ]. gen releaseTemps: 2. "keep the address reserved, otherwise it will be clobbered" asm label: donePreparing ! ! !NBExternalString methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/2/2010 20:38'! strLen: gen " input: EAX - pointer to char* string output: ECX - string length " | loop end asm | asm := gen asm. loop := asm uniqueLabelName: 'loop'. end := asm uniqueLabelName: 'end'. asm mov: EAX to: ECX; label: loop; cmp: ECX ptr8 with: 0; je: end; inc: ECX; jmp: loop; label: end; sub: ECX with: EAX. ^ ECX ! ! !NBExternalString methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/28/2010 20:26'! pushAsPointer: gen self error: 'Strings already passed as a pointer'.! ! !NBExternalString methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 15:56'! valueSize ^ self pointerSize "i am live and die as a pointer"! ! !NBExternalString methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/28/2010 13:44'! pushAsValue: gen gen asm push: address. ! ! !NBExternalStructure commentStamp: ''! I representing external structures to closely mimic 'struct' types in C. A C structure has transparent access to its fields: that is, a structure is transparent if you know its fields and can modify them. This is in contrast of opaque structures, which you never manipulate directly but through functions. For each struct type, you define a subclass of me, and implement the #fieldsDesc class method. The #fieldDesc method should answer an array containing enumeration of structure fields in form of type and name, much like in C syntax, for example: fieldDesc ^ #( int field1; float field2; void* field3; ). Once you define the structure fields and initialize the class, you can create the instances of it and access the fields by their name (the accessor methods are generated automatically). An external structure can be allocated in object memory, or in external memory, using #new, or #externalNew correspondingly. To test if given instance is allocated on external heap you can use #isExternal method. For passing (sub)instance of NBExternalStructure as argument to external function, the function argument type must be resolved to refer to corresponding class, e.g. if you defined class MyStructure, the external function signature must use it like 'void foo (MyStructure arg)', or if you want to preserve an original C function signature as much as close to original, use aliases for type (so type with name '_C_struct_type_name_whatever' should resolve to 'MyStructure' at the end). You can use external structure for passing by value (MyStruct param), or passing by pointer (MyStruct* param) both, depending of what external function expecting. In case if you want to pass a pointer to structure, but function signature does not explicitly uses a struct type (like 'void* someParam'), you can use #address accessor and pass it as parameter to function,e.g. someObject callExternalFunctionWith: mystruct address. Using external structure as return type: if external function returns a struct type: MyStruct foo() the marshaller creates an instance of MyStruct on object memory, then lets function modify its fields and aswers the resulting object. If function returns a pointer to structure, like 'MyStruct * foo()', then marshaller will create an instance of MyStruct as return value, and store an address returned by function as instance of NBExternalAddress in its data ivar (effectively making the structure instance external). Please be aware, that #free method can only be used if you allocated an external structure by yourself , using #externalNew , but not for instances which returned by external function or when given memory is controlled by external library or was allocated using other means.! !NBExternalStructure methodsFor: 'dnu' stamp: 'CiprianTeodorov 3/27/2013 21:47'! doesNotUnderstand: aMessage self class isInitialized ifFalse: [ "retry send after initialization" self class initializeAccessors. ^ aMessage sentTo: self ]. ^ super doesNotUnderstand: aMessage! ! !NBExternalStructure methodsFor: 'copying' stamp: 'jb 8/9/2013 17:00'! postCopy "Copy is always internal, e.g, when making copy of structure with external address, a copy will hold same data in its bytearray (in object memory) " self isExternal ifFalse: [ data := data copy ] ifTrue: [ | newData | newData := ByteArray new: self class instanceSize. NativeBoost memCopy: data to: newData size: self class instanceSize. data := newData ]! ! !NBExternalStructure methodsFor: 'initialize-release' stamp: 'jb 8/9/2013 16:08'! initializeInternal "initialize receiver with data held in object memory heap " data := ByteArray new: self class instanceSize. self initialize.! ! !NBExternalStructure methodsFor: 'printing' stamp: 'CiprianTeodorov 3/27/2013 21:47'! printOn: aStream "Append to the argument, aStream, the names and values of all the record's variables." Printing == true ifTrue: [ "since we use field accessors for printing values, debugging the code with not-yet nativised accessors leads to infinite loop" ^ aStream nextPutAll: self class name; nextPutAll: '(...)'. ]. Printing := true. [ aStream nextPutAll: self class name; nextPutAll: ' ( '; cr. self class fields namesInDeclarationOrder do: [ :field | aStream nextPutAll: field; nextPut: $:; space; tab. (self perform: field ) printOn: aStream. ] separatedBy: [ aStream cr ]. aStream cr; nextPut: $). ] ensure: [ Printing := false ]. ! ! !NBExternalStructure methodsFor: 'private' stamp: 'IgorStasenko 7/1/2013 14:01'! fieldAt: aFieldName put: value "This method is used by auto-generated accessor method(s) to generate code for accessing field(s) of external structure. Do not override" ^ NBFFICallout handleFailureIn: thisContext sender nativeCode: [:gen | self emitWrite: aFieldName generator: gen. gen bytes ] ! ! !NBExternalStructure methodsFor: 'testing' stamp: 'IgorStasenko 7/1/2013 14:15'! isExternal "answer true if data referenced by receiver located in external heap, or just in object memory " ^ data class == NBExternalAddress! ! !NBExternalStructure methodsFor: 'private' stamp: 'IgorStasenko 7/1/2013 14:01'! fieldAt: aFieldName "This method is used by auto-generated accessor method(s) to generate code for accessing field(s) of external structure. Do not override" ^ (self nbCalloutIn: thisContext sender) function: 'oop (void *data)' emit: [:gen | self emitRead: aFieldName generator: gen. ] ! ! !NBExternalStructure methodsFor: 'acccessing' stamp: 'IgorStasenko 7/1/2013 14:18'! address "Answer an object which can be used as an address, pointing to first byte of external structure." ^data! ! !NBExternalStructure methodsFor: 'private' stamp: 'IgorStasenko 7/1/2013 14:16'! emitWrite: aFieldName generator: gen | offset type asm size rcvr fieldAddr | gen requestor: self class. type := self class fields typeOf: aFieldName. offset := self class fields offsetOf: aFieldName. rcvr := gen reserveTemp. fieldAddr := gen reserveTemp. asm := gen asm. type loader: (NBSTMethodArgument new stackIndex: 0). type emitPush: gen. "push value on stack" gen proxy stackValue: 1. "receiver oop" asm mov: asm EAX to: rcvr. NBExternalStructureType new objectClass: self class; fetchStructAddressFrom: rcvr gen: gen. "now, in EAX the address to first byte of external structure" offset > 0 ifTrue: [ asm add: asm EAX with: offset ]. asm mov: asm EAX to: fieldAddr. gen emitFailureTest. "important to check if everything ok, before we write value to receiver" size := type typeSize. "just copy the value from stack to the struct field" asm mov: fieldAddr to: asm EAX. offset := 0. [ size >= 4 ] whileTrue: [ asm mov: asm ESP ptr + offset to: asm ECX; mov: asm ECX to: asm EAX ptr + offset. size := size - 4. offset := offset + 4. ]. size >= 2 ifTrue: [ asm mov: asm ESP ptr16 + offset to: asm CX; mov: asm CX to: asm EAX ptr16 + offset. size := size - 2. offset := offset + 2. ]. size > 0 ifTrue: [ " last byte " asm mov: asm ESP ptr8 + offset to: asm CL; mov: asm CL to: asm EAX ptr8 + offset. ]. "answer the receiver" asm mov: rcvr to: asm EAX. gen epilogue. gen emitFailureHandler. ^ gen ! ! !NBExternalStructure methodsFor: 'initialize-release' stamp: 'CiprianTeodorov 4/7/2013 21:38'! initializeWithAddress: anExternalAddress "initialize the receiver with data held in external memory" data := anExternalAddress. ! ! !NBExternalStructure methodsFor: 'private' stamp: 'CiprianTeodorov 3/28/2013 19:45'! emitRead: aFieldName generator: gen | offset type asm mem | gen requestor: self class. type := self class fields typeOf: aFieldName. offset := self class fields offsetOf: aFieldName. asm := gen asm. asm pop: asm EAX. "load the value" mem := asm EAX ptr + offset. "read a value from given location and return oop" type readOop: mem generator: gen. ^ gen! ! !NBExternalStructure methodsFor: 'initialize-release' stamp: 'IgorStasenko 7/1/2013 14:12'! free "A convenience method, to explicitly free external memory, symmetrical when using #externalNew protocol for creating receiver. Do nothing if receiver is not pointing to external heap. " self isExternal ifTrue: [ data free. ].! ! !NBExternalStructure class methodsFor: 'accessing' stamp: 'CiprianTeodorov 3/27/2013 21:47'! instanceSize ^ self fields totalSize ! ! !NBExternalStructure class methodsFor: 'managing accessors' stamp: 'CiprianTeodorov 3/27/2013 21:47'! noteCompilationOf: aSelector meta: isMeta initialized == true ifFalse: [ ^ self ]. isMeta ifTrue: [ "Compilation on a class side , lets get rid of native methods on instance side" (aSelector == #fieldsDesc or: [ aSelector == #byteAlignment ]) ifTrue: [ self flushNativeFieldAccessors. self rebuildFieldAccessors ]. ]. ! ! !NBExternalStructure class methodsFor: 'instance creation' stamp: 'IgorStasenko 7/1/2013 14:19'! fromPointer: externalAddress "Create an instance of receiver from given external address. " ^self basicNew initializeWithAddress: externalAddress. ! ! !NBExternalStructure class methodsFor: 'instance creation' stamp: 'IgorStasenko 7/1/2013 14:13'! externalNew "Allocate enough bytes on external heap to hold my instance data, then answer an instance which using external data. Please note, that if you create my instances on external heap, do not forget to free memory after use, e.g. struct address free. " ^ self fromPointer: (NativeBoost allocate: self instanceSize). ! ! !NBExternalStructure class methodsFor: 'ffi type' stamp: 'CiprianTeodorov 3/27/2013 21:47'! asNBExternalType: gen ^ NBExternalStructureType objectClass: self! ! !NBExternalStructure class methodsFor: 'managing accessors' stamp: 'CiprianTeodorov 5/19/2013 03:56'! removeAccessor: aSelector methodDict at: aSelector ifAbsent: [ ^ self ]. self removeSelectorSilently: aSelector. ! ! !NBExternalStructure class methodsFor: 'accessing' stamp: 'CiprianTeodorov 3/27/2013 21:47'! fieldsClass ^NBExternalStructureFields ! ! !NBExternalStructure class methodsFor: 'session management' stamp: 'IgorStasenko 3/31/2014 11:44'! initializeForNewSession self allSubclassesDo: [ :each | each updateFieldOffsets ]! ! !NBExternalStructure class methodsFor: 'testing' stamp: 'CiprianTeodorov 3/27/2013 21:47'! isInitialized ^ initialized == true! ! !NBExternalStructure class methodsFor: 'instance creation' stamp: 'IgorStasenko 7/1/2013 14:14'! new ^self basicNew initializeInternal! ! !NBExternalStructure class methodsFor: 'managing accessors' stamp: 'IgorStasenko 2/3/2014 18:16'! createAccessorsFor: fieldName "Define read/write accessors for the given field" | code | code := fieldName,' "This method was automatically generated" ^ self fieldAt: ' , fieldName printString. Author useAuthor: 'NativeBoost' during: [ self compileSilently: code classified: NativeBoost automaticallyGeneratedCodeCategory ]. code := fieldName,': anObject "This method was automatically generated" ^ self fieldAt: ' , fieldName printString , ' put: anObject'. Author useAuthor: 'NativeBoost' during: [ self compileSilently: code classified: NativeBoost automaticallyGeneratedCodeCategory ]. ! ! !NBExternalStructure class methodsFor: 'managing accessors' stamp: 'CiprianTeodorov 3/27/2013 21:47'! flushNativeFieldAccessors methodDict do: [:method | NBNativeCodeGen removeNativeCodeFrom: method ]! ! !NBExternalStructure class methodsFor: 'managing accessors' stamp: 'CiprianTeodorov 3/27/2013 21:47'! rebuildFieldAccessors currentFields ifNotNil: [ currentFields fieldNamesDo: [:field | self removeAccessor: field. self removeAccessor: field asMutator ]]. currentFields := self fieldsClass new parseFields: self fieldsDesc byteAlignment: self byteAlignment structure: self. self fields fieldNamesDo: [:fldName | self createAccessorsFor: fldName ]. ^ currentFields! ! !NBExternalStructure class methodsFor: 'session management' stamp: 'IgorStasenko 3/31/2014 12:52'! updateFieldOffsets "Update the field offsets and total structure size, in case if platform has changed and using different alignment comparing to previous session" currentFields ifNil: [ ^ self ]. currentFields updateFieldOffsetsFor: self! ! !NBExternalStructure class methodsFor: 'fields description' stamp: 'CiprianTeodorov 3/27/2013 21:47'! fieldsDesc "override this method in a subclass to get an automatically generated field accessors. The field description format is following: #( type1 name1; type2 name2; .... ) " ^ #()! ! !NBExternalStructure class methodsFor: 'accessing' stamp: 'CiprianTeodorov 3/27/2013 21:47'! offsetOf: aFieldName ^ self fields offsetOf: aFieldName! ! !NBExternalStructure class methodsFor: 'class initialization' stamp: 'CiprianTeodorov 3/27/2013 21:47'! initializeAccessors initialized := true. self rebuildFieldAccessors.! ! !NBExternalStructure class methodsFor: 'alignment' stamp: 'CiprianTeodorov 3/27/2013 21:47'! byteAlignment "default " ^ NativeBoost forCurrentPlatform pointerSize ! ! !NBExternalStructure class methodsFor: 'accessing' stamp: 'CiprianTeodorov 3/27/2013 21:47'! fields ^ currentFields ifNil: [ self rebuildFieldAccessors. currentFields ].! ! !NBExternalStructureFields methodsFor: 'parsing spec' stamp: 'CiprianTeodorov 1/19/2013 17:18'! sizeAlignedTo: anAlign with: aType totalSize := (totalSize alignedTo: anAlign) + aType typeSize! ! !NBExternalStructureFields methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 09:20'! namesInDeclarationOrder | result | result := SortedCollection sortBlock: [:a :b | a value second < b value second ]. fields associationsDo: [:each | result add: each ]. ^ result collect: [:each | each key ]! ! !NBExternalStructureFields methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 07:16'! typeOf: fieldName ^ (fields at: fieldName) at: 1! ! !NBExternalStructureFields methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 07:15'! fieldNames ^ fields keys! ! !NBExternalStructureFields methodsFor: 'parsing spec' stamp: 'CiprianTeodorov 1/19/2013 17:19'! parseFields: fieldSpec byteAlignment: byteAlign structure: structClass | stream type name gen align | stream := fieldSpec readStream. gen := NBFFICallout new requestor: structClass. fields := Dictionary new. totalSize := 0. [ stream atEnd ] whileFalse: [ | arity | type := gen resolveType: stream next. arity := 0. [stream peek = #* ] whileTrue: [ arity := arity + 1. stream next ]. type pointerArity: arity. name := stream next. name isSymbol ifFalse: [ self error: 'invalid field name']. fields at: name ifPresent: [ self error: 'duplicate field name' ]. align := type typeSize min: byteAlign. "if byte align == 1, struct is packed" "add padding between fields, if needed" self sizeAlignedTo: align with: type. self addField: name type: type. stream peek == #';' ifTrue: [ stream next ]. ]. ! ! !NBExternalStructureFields methodsFor: 'computing' stamp: 'IgorStasenko 3/31/2014 16:12'! updateFieldOffsetsFor: structClass "Recalculate field offsets based on (possibly new) platform byte alignment" | names byteAlign align type newSize | names := self namesInDeclarationOrder. newSize := 0. byteAlign := structClass byteAlignment. names do: [ :each | type := (fields at: each) first. align := type typeSize min: byteAlign. newSize := (newSize alignedTo: align) + type typeSize. fields at: each put: { type. (newSize - type typeSize)} ]. totalSize := newSize.! ! !NBExternalStructureFields methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 07:16'! offsetOf: fieldName ^ (fields at: fieldName) at: 2! ! !NBExternalStructureFields methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 07:16'! fieldNamesDo: aBlock ^ fields keysDo: [:name | aBlock value: name ]! ! !NBExternalStructureFields methodsFor: 'parsing spec' stamp: 'CiprianTeodorov 1/19/2013 17:18'! addField: aName type: aType fields at: aName put: {aType. (totalSize - aType typeSize)}! ! !NBExternalStructureFields methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 06:41'! totalSize ^ totalSize! ! !NBExternalStructureType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/5/2013 15:43'! pushAsValue: gen "pass a structure by value on stack" | asm oop bytesToCopy offset | asm := gen asm. oop := gen reserveTemp annotation: 'oop'. loader emitLoad: gen to: oop. loader isReceiver ifFalse: [ "do not check type if argument is receiver, since we already know its class" self verifyClassOf: oop is: objectClass generator: gen. ]. self fetchStructAddressFrom: oop gen: gen. "in EAX the pointer to first byte of struct" "struct size aligned to stack argument alignment" asm sub: asm ESP with: self stackSize. "generate code to copy struct contents on a stack. source is [EAX] destination is [ESP] " bytesToCopy := self valueSize. offset := 0. "first copy by 4 bytes" [ bytesToCopy >= 4 ] whileTrue: [ asm mov: asm EAX ptr32 + offset to: asm EDX; mov: asm EDX to: asm ESP ptr32 + offset. bytesToCopy := bytesToCopy - 4. offset := offset + 4. ]. "copy rest using 1-byte transfer" [ bytesToCopy > 0 ] whileTrue: [ asm mov: asm EAX ptr8 + offset to: asm DL; mov: asm DL to: asm ESP ptr8 + offset. bytesToCopy := bytesToCopy - 1. offset := offset + 1. ]. gen releaseTemps: 1. ! ! !NBExternalStructureType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 12:24'! fetchAddressFromData: dataOop gen: gen "Input: the oop of data ivar (dataOop) from an instance of NBExternalStructure subclass Output: the address of struct's first field is in EAX. 2 cases: - data is ByteArray, then use address of its first byte - data is NBExternalAddress, then use address value " | oopClass proxy asm notExternalAddress done | proxy := gen proxy. asm := gen asm. oopClass := gen reserveTemp. notExternalAddress := asm uniqueLabelName: 'notExternalAddress'. done := asm uniqueLabelName: 'done'. proxy fetchClassOf: dataOop. asm mov: asm EAX to: oopClass. gen emitFetchClass: NBExternalAddress. asm cmp: asm EAX with: oopClass. asm jne: notExternalAddress. "Data is external address. use its value" proxy fetchPointer: 0 ofObject: dataOop. asm jmp: done. "Here we assume it is var-byte object (bytearray), use address of its first byte" asm label: notExternalAddress. proxy varBytesFirstFieldOf: dataOop. asm label: done. gen releaseTemps: 1. ! ! !NBExternalStructureType methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/17/2010 18:43'! objectClass: anObject objectClass := anObject! ! !NBExternalStructureType methodsFor: 'accessing' stamp: 'CiprianTeodorov 3/28/2013 20:24'! dataIvarIndex " return a zero-based index " ^ ( objectClass instVarIndexFor: #data ifAbsent: [ self error: ' should not happen ' ] ) - 1! ! !NBExternalStructureType methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/17/2010 18:43'! objectClass ^objectClass! ! !NBExternalStructureType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/8/2013 17:38'! pushAsPointer: gen "push a pointer to structure (which should be a subinstance of NBExternalStructure)" | asm oop | asm := gen asm. oop := gen reserveTemp. "we handle only 1-arity pointers here (stuct*) , the others is handled as generic pointer" pointerArity > 1 ifTrue: [ ^ super pushAsPointer: gen]. loader emitLoad: gen to: oop. "do not verify if class is known" loader isReceiver ifFalse: [ self verifyClassOf: oop is: objectClass generator: gen. ]. self fetchStructAddressFrom: oop gen: gen. asm push: asm EAX. gen releaseTemps: 1! ! !NBExternalStructureType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 12:21'! fetchStructAddressFrom: oop gen: gen "Input: an instance of NBExternalStructure subclass in oop Output: the address of struct's first field is in EAX" | asm proxy dataOop | proxy := gen proxy. asm := gen asm. dataOop := gen reserveTemp. proxy fetchPointer: (self dataIvarIndex) ofObject: oop. asm mov: asm EAX to: dataOop. self fetchAddressFromData: dataOop gen: gen. gen releaseTemps: 1.! ! !NBExternalStructureType methodsFor: 'testing' stamp: 'CiprianTeodorov 1/28/2013 23:42'! returnViaRegisters " answer true if return-by-value for given struct are returned in registers. 1byte, 2 bytes, and 4 bytes structures are returned in EAX. 8 byte structures are returned in EDX:EAX otherwise it is assumed that caller passing a hidden argument (a pointer to struct) which callee using for filling the data " "Both Mac OS X x86 and Win32 x86 return structs of a power of two in size less than or equal to eight bytes in length in registers. Linux never does so. " ^NativeBoost platformId = NativeBoostConstants linux32PlatformId ifTrue:[false] ifFalse:[ #(1 2 4 8) includes: self valueSize]! ! !NBExternalStructureType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 16:38'! coerceReturnPointer: gen "input: pointer to struct in EAX output: instance of external structure oop pointing to given address" | asm proxy oop | asm := gen asm. proxy := gen proxy. "we only care for 1 arity e.g. 'Struct *', otherwise use generic marshalling." pointerArity > 1 ifTrue: [ ^ super coerceReturnPointer: gen ]. "first create an instance of NBExternalAddress" NBExternalAddressType new createInstanceWithValue: asm EAX generator: gen. proxy pushRemappableOop: asm EAX. oop := gen reserveTemp. proxy createInstanceOf: objectClass. asm mov: asm EAX to: oop. proxy popRemappableOop. proxy storePointer: self dataIvarIndex ofObject: oop withValue: asm EAX. "return an instance of objectClass as result" asm mov: oop to: asm EAX. gen releaseTemps: 1! ! !NBExternalStructureType methodsFor: 'emitting code' stamp: 'CiprianTeodorov 4/7/2013 19:32'! readOop: memoryOperand generator: gen "emit code to read a value from given memory operand and convert it to a corresponding ST object" | asm proxy size offset oop src | asm := gen asm. proxy := gen proxy. pointerArity > 0 ifTrue: [ asm mov: memoryOperand to: asm EAX. ^ self coerceReturn: gen. ]. "read structure from given address, copy it to newly created instance of corresponding struct class" asm lea: asm EAX with: memoryOperand. src := gen reserveTemp. asm mov: asm EAX to: src. "instantiate our struct" oop := gen reserveTemp. gen emitFetchClass: objectClass. proxy instantiateClass: asm EAX indexableSize: 0. asm mov: asm EAX to: oop. gen emitFetchClass: ByteArray. proxy instantiateClass: asm EAX indexableSize: objectClass instanceSize. proxy storePointer: self dataIvarIndex ofObject: oop withValue: asm EAX. proxy varBytesFirstFieldOf: asm EAX. asm mov: src to: asm EDX. "in EAX is pointer to first byte of struct" size := self valueSize. offset := 0. [ size >= 4 ] whileTrue: [ asm mov: asm EDX ptr + offset to: asm ECX; mov: asm ECX to: asm EAX ptr + offset. size := size - 4. offset := offset + 4. ]. size >= 2 ifTrue: [ asm mov: asm EDX ptr16 + offset to: asm CX; mov: asm CX to: asm EAX ptr16 + offset. size := size - 2. offset := offset + 2. ]. size > 0 ifTrue: [ " last byte " asm mov: asm EDX ptr8 + offset to: asm CL; mov: asm CL to: asm EAX ptr8 + offset. ]. "return an instance of objectClass as result" asm mov: oop to: asm EAX ! ! !NBExternalStructureType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 16:25'! prepareReturnValue: gen for: callinfo | asm proxy temp | asm := gen asm. proxy := gen proxy. (pointerArity = 0 and: [ self returnViaRegisters not ]) ifTrue: [ "we should instantiate a new instance of struct and push a pointer to its first byte on a stack (so C function will know where to store return value(s))" returnOop := gen reserveTemp. temp := gen reserveTemp. proxy createInstanceOf: objectClass. proxy pushRemappableOop: asm EAX. proxy createInstanceOf: ByteArray size: objectClass instanceSize. asm mov: asm EAX to: temp. proxy popRemappableOop. asm mov: asm EAX to: returnOop. proxy storePointer: self dataIvarIndex ofObject: asm EAX withValue: temp. asm mov: temp to: asm EAX. proxy varBytesFirstFieldOf: asm EAX. "in EAX is pointer to first byte of struct" asm noticePush: asm pointerSize forCall: callinfo. asm push: asm EAX. gen releaseTemps: 1. ] ! ! !NBExternalStructureType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/5/2013 15:46'! coerceReturnValue: gen | asm proxy | asm := gen asm. proxy := gen proxy. self returnViaRegisters ifTrue: [ | temp1 temp2 oop dataOop | "save struct value(s) into temps" temp1 := gen reserveTemp. asm mov: asm EAX to: temp1. objectClass instanceSize > 4 ifTrue: [ temp2 := gen reserveTemp. asm mov: asm EDX to: temp2 ]. "instantiate our struct" oop := gen reserveTemp. dataOop := gen reserveTemp. "create data buf for struct" proxy createInstanceOf: ByteArray size: objectClass instanceSize. asm mov: asm EAX to: dataOop. proxy varBytesFirstFieldOf: asm EAX. "in EAX is pointer to first byte of struct" "copy struct values into newly created instance" asm mov: temp1 to: asm ECX. asm mov: asm ECX to: asm EAX ptr. objectClass instanceSize > 4 ifTrue: [ asm mov: temp2 to: asm ECX. asm mov: asm ECX to: asm EAX ptr + 4. ]. proxy pushRemappableOop: dataOop. "now create instance and set it's data ivar " proxy createInstanceOf: objectClass. asm mov: asm EAX to: oop. proxy popRemappableOop. proxy storePointer: self dataIvarIndex ofObject: oop withValue: asm EAX. "return an instance of objectClass as result" asm mov: oop to: asm EAX ] ifFalse: [ "just return a previously instantiated struct oop" asm mov: returnOop to: asm EAX ]! ! !NBExternalStructureType methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 14:12'! valueSize ^ objectClass instanceSize ! ! !NBExternalStructureType class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/17/2010 18:42'! objectClass: aClass ^ self new objectClass: aClass! ! !NBExternalType commentStamp: 'IgorStasenko 2/15/2012 19:41'! I am an abstract class that primarily serves for generating a machine code which converting arguments and return types between Smalltalk and C worlds. My subclasses implementing a marshalling for concrete type, which is then used by FFI. Instance Variables: pointerArity loader : an instance of argument loader, which emits code to load the smalltalk argument into register. When generating the marshalling code to push a variable, my instances need this helper which, depending on where the object is (inst var, method arg, etc) gets the object in question into a register.! !NBExternalType methodsFor: 'emitting code' stamp: 'IgorStasenko 5/11/2011 17:24'! emitPush: generator pointerArity > 0 ifTrue: [ ^ self pushAsPointer: generator ]. generator coercionMayFail: self coercionMayFail. ^ self pushAsValue: generator.! ! !NBExternalType methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/11/2010 01:30'! coerceOopToOperand: gen ifFailedJumpTo: aLabel "coerce a object - oop , provided by loader and then put a result into an appropriate operand (memory/register), answer that operand" self subclassResponsibility ! ! !NBExternalType methodsFor: 'emitting code' stamp: 'IgorStasenko 5/26/2012 18:21'! loadMem: memoryOperand generator: gen. "load the value from memory operand into return value register" gen asm mov: memoryOperand to: (gen asm reg: 0 size: self typeSize). ! ! !NBExternalType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 11:35'! pointerArity ^ pointerArity! ! !NBExternalType methodsFor: 'testing' stamp: 'IgorStasenko 5/11/2011 17:26'! coercionMayFail "answer true if argument coercion ST->C may fail due to passing incomatible argument type. Some types could accept any ST object as argument and therefore never fail, and we don't need to check a primitive failuer before making a call. By default, asnwer true " ^ true! ! !NBExternalType methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 14:30'! baseTypeSize "Answer a number of bytes, which takes a value of given type (not a pointer to it) " self subclassResponsibility ! ! !NBExternalType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 09:51'! loader: aLoader loader := aLoader! ! !NBExternalType methodsFor: 'emitting code' stamp: 'IgorStasenko 7/1/2013 11:07'! pushAsPointer: gen "by default, push argument as a bytearray ptr" "may accept: - nil - variable bytes oop - external address " | asm proxy notNil done oop notExternalAddress | asm := gen asm. proxy := gen proxy. done := asm uniqueLabelName: 'done'. oop := gen reserveTemp. "load argument oop" loader emitLoad: gen to: oop. "handle nils, if we care" gen optCoerceNilToNull ifTrue: [ notNil := asm uniqueLabelName: 'notNil'. proxy nilObject. asm cmp: asm EAX with: oop; jne: notNil; xor: asm EAX with: asm EAX; jmp: done; label: notNil. ]. "handle ExternalAddress, if we care" gen optAllowExternalAddressPtr ifTrue: [ | oopClass | oopClass := gen reserveTemp. notExternalAddress := asm uniqueLabelName: 'notExternalAddress'. proxy fetchClassOf: oop. asm mov: asm EAX to: oopClass. gen emitFetchClass: NBExternalAddress. asm cmp: asm EAX with: oopClass. asm jne: notExternalAddress. proxy fetchPointer: 0 ofObject: oop. asm jmp: done. asm label: notExternalAddress. gen releaseTemps: 1. ]. "the last case is a byte/word array, simply push a pointer to first indexable field of oop" gen optAllowByteArraysPtr ifTrue: [ proxy isBytesOrWords: oop ifNotJumpTo: gen failedLabel. proxy varBytesFirstFieldOf: oop. asm jmp: done. ]. "if we get here, we fail" asm jmp: gen failedLabel. "and if we get here, we ok to proceed" asm label: done. asm push: asm EAX. gen releaseTemps: 1. ! ! !NBExternalType methodsFor: 'testing' stamp: 'Igor.Stasenko 5/1/2010 16:05'! isCallback ^ false! ! !NBExternalType methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 14:33'! stackSize "Answer a number of bytes, which takes a value of given type when pushed on stack" ^ self typeSize alignedTo: self stackArgumentAlignment ! ! !NBExternalType methodsFor: 'initialization' stamp: 'Igor.Stasenko 4/28/2010 11:34'! initialize pointerArity := 0.! ! !NBExternalType methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 01:04'! stackArgumentAlignment "a minimum number of bytes, which argument of any type can have on stack, when pushed as argument" ^ 4! ! !NBExternalType methodsFor: 'printing' stamp: 'Igor.Stasenko 4/30/2010 09:22'! printOn: aStream super printOn: aStream. pointerArity timesRepeat: [ aStream nextPut: $* ].! ! !NBExternalType methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/28/2010 17:42'! coerceReturn: gen pointerArity > 0 ifTrue: [ self coerceReturnPointer: gen ] ifFalse: [ self coerceReturnValue: gen ]. ! ! !NBExternalType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 11:35'! pointerArity: additionalArity pointerArity := pointerArity + additionalArity.! ! !NBExternalType methodsFor: 'emitting code' stamp: 'IgorStasenko 5/4/2012 17:08'! prepareReturnValue: gen for: callinfo "do some extra for preparing a function return value holder. no-op for most of the types, except external structures " ! ! !NBExternalType methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 14:28'! valueSize "Answer a number of bytes, which takes a value of given type (not a pointer to it) " self subclassResponsibility ! ! !NBExternalType methodsFor: 'error handling' stamp: 'IgorStasenko 7/12/2013 14:30'! error: aMessage ^ NBCodeGenerationError new signal: aMessage! ! !NBExternalType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 09:50'! loader ^ loader! ! !NBExternalType methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/16/2012 15:34'! typeName | tName | tName := self class name. pointerArity timesRepeat: [ tName , '*' ]. ^ tName! ! !NBExternalType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 05:49'! pointerSize "Answer a number of bytes, which takes a pointer value" ^ self class pointerSize! ! !NBExternalType methodsFor: 'emitting code' stamp: 'IgorStasenko 8/8/2011 19:54'! verifyClassOf: oop is: aClass generator: gen | asm class okLabel | asm := gen asm. okLabel := asm uniqueLabelName: 'classIsOk'. class := gen reserveTemp. gen proxy fetchClassOf: oop. asm mov: asm EAX to: class. gen emitFetchClass: aClass. asm cmp: asm EAX with: class; je: okLabel. gen failWithMessage: 'An instance of ' , aClass name , ' expected'. asm label: okLabel. gen releaseTemps: 1.! ! !NBExternalType methodsFor: 'emitting code' stamp: 'IgorStasenko 12/20/2011 14:21'! coerceReturnPointer: gen "Return a pointer to receiver. lets just return its value" | asm EAX cont done | asm := gen asm. EAX := asm EAX. cont := asm uniqueLabelName: 'cont'. done := asm uniqueLabelName: 'done'. (gen optReturnNullAsNil or: [gen optFailOnReturnNull ]) ifTrue: [ asm or: EAX with: EAX. gen optFailOnReturnNull ifTrue: [ asm jz: gen failedLabel. ] ifFalse: [ asm jnz: cont. gen proxy nilObject. asm jmp: done ] ]. asm label: cont. gen optReturnPtrAsExternalAddress ifTrue: [ (NBExternalAddress asNBExternalType: gen) coerceReturnValue: gen ] ifFalse: [ gen optReturnPtrAsInt ifFalse: [ self error: 'Function returns a pointer, but returning raw pointer value is prohibited by options' ]. gen proxy positive32BitIntegerFor: asm EAX ]. asm label: done ! ! !NBExternalType methodsFor: 'emitting code' stamp: 'IgorStasenko 9/3/2012 01:03'! readOop: memoryOperand generator: gen "emit code to read a value from given memory operand and convert it to a corresponding ST object" memoryOperand size: self typeSize. pointerArity > 0 ifTrue: [ gen asm mov: memoryOperand to: gen asm EAX ] ifFalse: [ self loadMem: memoryOperand generator: gen ]. self coerceReturn: gen! ! !NBExternalType methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/28/2010 11:41'! prepareArgumentUsing: aNBFFICallout "by default, do nothing"! ! !NBExternalType methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 17:09'! typeSize "Answer a number of bytes, which receiver type takes in memory" pointerArity > 0 ifTrue: [ ^ self pointerSize ]. ^ self valueSize ! ! !NBExternalType methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/30/2010 08:10'! coerceReturnValue: generator "emit code to coerce return value from external function call" self subclassResponsibility ! ! !NBExternalType class methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 05:49'! pointerSize "Answer a number of bytes, which takes a pointer value" self flag: #x64. ^ 4! ! !NBExternalType class methodsFor: 'public' stamp: 'IgorStasenko 6/27/2013 16:12'! sizeOf: aTypeName ^ (NBFFICallout new resolveType: aTypeName) typeSize! ! !NBExternalType class methodsFor: 'converting' stamp: 'Igor.Stasenko 4/28/2010 12:20'! asNBExternalType: gen ^ self new! ! !NBExternalTypeValue commentStamp: ''! I am a generic meta class for creating a subclasses, which instances will hold a single value of specified C type. To create a new class for some concrete C type use: myClass := NBExternalTypeValue getClassForType: 'float'. Then you can use instances of given anonymous class(es) as a value holders for type you specified: float := myClass new. ... float value: 1.5 float value etc.. By combining this with class/pool variables we have a convenient way of defining a values, which are passed by pointer to a function. For instance, imagine that we need to create a binding to a function: void getFoo( SomeType * value) which is not an unusual situation, when C function using pointer arguments for storing it's output there. And this is what NBExternalTypeValue is done for: To define a binding to this function you can: - declare a pool/class variable, named SomeType - initialize it: SomeType := NBExternalTypeValue ofType: 'SomeType' and then use it in function signature: getFoo: value ^ self nbcall: #(void getFoo ( SomeType * value )) --- and call it like: var := SomeType new. self getFoo: var. var value -> will read the value ! !NBExternalTypeValue methodsFor: 'accessing' stamp: 'CiprianTeodorov 4/9/2013 19:46'! value "Note, this method used as a template for my anonymous subclasses. " ^ self emitRead! ! !NBExternalTypeValue methodsFor: 'accessing' stamp: 'CiprianTeodorov 4/9/2013 19:46'! value: value "Note, this method used as a template for my anonymous subclasses. " ^ self emitWrite ! ! !NBExternalTypeValue methodsFor: 'printing' stamp: 'CiprianTeodorov 4/9/2013 19:19'! printOn: aStream "Append to the argument, aStream, the names and values of all the record's variables." Printing == true ifTrue: [ "since we use field accessors for printing values, debugging the code with not-yet nativised accessors leads to infinite loop" ^ aStream nextPutAll: self class name; nextPutAll: '(...)'. ]. Printing := true. [ aStream nextPutAll: self class name; nextPutAll: ' ( '; nextPutAll: self class valueType; nextPutAll: ') ('; cr. self value printOn: aStream. aStream cr; nextPut: $). ] ensure: [ Printing := false ]. ! ! !NBExternalTypeValue methodsFor: 'accessing' stamp: 'CiprianTeodorov 4/9/2013 19:41'! emitCopy: asm "Emit code to copy elementSize bytes from ESP ptr -> EAX ptr " | toCopy offset | toCopy := self class valueSize. toCopy > 8 ifTrue: [ ^ self emitCopyUsingLoop: asm ]. offset := 0. [ toCopy >= 4 ] whileTrue: [ asm mov: asm ESP ptr + offset to: asm ECX; mov: asm ECX to: asm EAX ptr + offset. toCopy := toCopy - 4. offset := offset + 4. ]. toCopy >= 2 ifTrue: [ asm mov: asm ESP ptr16 + offset to: asm CX; mov: asm CX to: asm EAX ptr16 + offset. toCopy := toCopy - 2. offset := offset + 2. ]. toCopy > 0 ifTrue: [ " last byte " asm mov: asm ESP ptr8 + offset to: asm CL; mov: asm CL to: asm EAX ptr8 + offset. ]. ! ! !NBExternalTypeValue methodsFor: 'accessing' stamp: 'IgorStasenko 7/1/2013 14:29'! emitWrite ^(self nbCalloutIn: thisContext sender) function: 'oop (oop value, ', self class valueType,' value)' emit: [ :gen :proxy :asm | |oop| oop := gen reserveTemp. asm pop: asm EAX; mov: asm EAX to: oop. proxy receiver. proxy varBytesFirstFieldOf: asm EAX. self emitCopy: asm. asm mov: oop to: asm EAX. ]! ! !NBExternalTypeValue methodsFor: 'accessing' stamp: 'CiprianTeodorov 4/9/2013 19:42'! emitCopyUsingLoop: asm | ssi sdi | "copy the value using loop " ssi := asm reserveTemp. sdi := asm reserveTemp. asm mov: asm ESI to: ssi; mov: asm EDI to: sdi; cld; mov: asm ESP to: asm ESI; mov: asm EAX to: asm EDI; mov: self class valueSize to: asm ECX; rep;movsb; mov: ssi to: asm ESI; mov: sdi to: asm EDI; releaseTemps: 2. ! ! !NBExternalTypeValue methodsFor: 'accessing' stamp: 'IgorStasenko 7/1/2013 14:29'! emitRead ^ (self nbCalloutIn: thisContext sender) function: 'oop ()' emit: [:gen :proxy :asm | proxy receiver. "receiver oop" proxy varBytesFirstFieldOf: asm EAX. (gen resolveType: self class valueType) readOop: asm EAX ptr generator: gen. ]! ! !NBExternalTypeValue class methodsFor: 'session management' stamp: 'IgorStasenko 4/1/2014 17:21'! updateValueSize "Update the size, in case of session change where type is an external structure which uses different memory alignment on given platform " valueSize := (NBFFICallout new requestor: self; resolveType: valueType) typeSize. ! ! !NBExternalTypeValue class methodsFor: 'class initialization' stamp: 'IgorStasenko 1/17/2014 20:44'! initValueType: aTypeName "Initialize the value type and size. If you want to use a public subclass of me, then make sure you call this method in your class #initialize method. " self valueType: aTypeName! ! !NBExternalTypeValue class methodsFor: 'class initialization' stamp: 'StephaneDucasse 8/13/2013 17:41'! initialize NBExternalTypeValue allSubclassesDo: #installAccessors. "like that methods are correctly regenerated"! ! !NBExternalTypeValue class methodsFor: 'accessing' stamp: 'IgorStasenko 1/17/2014 20:42'! valueType: aTypeName valueType := aTypeName. valueSize := (NBFFICallout new requestor: self; resolveType: valueType) typeSize. self installAccessors. ! ! !NBExternalTypeValue class methodsFor: 'class factory' stamp: 'IgorStasenko 1/17/2014 20:41'! getClassForType: aTypeName "Do not confuse.!! This method answers an anonymous class, a subclass of NBExternalTypeValue, which can be used for instantiation later i.e: floatTypeClass := NBExternalTypeValue ofType: 'float'. float := floatTypeClass new. float value: 1.5. float value. " ^ NBExternalTypeValue newAnonymousSubclass initValueType: aTypeName. ! ! !NBExternalTypeValue class methodsFor: 'instance creation' stamp: 'CiprianTeodorov 4/9/2013 20:50'! new ^ (self basicNew: self valueSize) initialize! ! !NBExternalTypeValue class methodsFor: 'private' stamp: 'IgorStasenko 2/3/2014 18:16'! installAccessors "Copy superclass methods, which serve as a template where generated code will be installed. Each subclass of NBTypeValue should implement (override) these key methods " Author useAuthor: 'NativeBoost' during: [ self basicAddSelector: #value withMethod: (NBExternalTypeValue >> #value ) copy. self basicAddSelector: #value: withMethod: (NBExternalTypeValue >> #value: ) copy. self organization classify: #value under: NativeBoost automaticallyGeneratedCodeCategory. self organization classify: #value: under: NativeBoost automaticallyGeneratedCodeCategory. ].! ! !NBExternalTypeValue class methodsFor: 'converting' stamp: 'IgorStasenko 6/27/2013 17:05'! asNBExternalType: gen ^gen resolveType: self valueType! ! !NBExternalTypeValue class methodsFor: 'class factory' stamp: 'CiprianTeodorov 4/9/2013 19:20'! ofType: aTypeName ^ self getClassForType: aTypeName ! ! !NBExternalTypeValue class methodsFor: 'session management' stamp: 'IgorStasenko 3/31/2014 16:24'! initializeForNewSession self allSubclassesDo: [ :each | each updateValueSize ].! ! !NBExternalTypeValue class methodsFor: 'accessing' stamp: 'CiprianTeodorov 4/9/2013 19:21'! valueType ^ valueType! ! !NBExternalTypeValue class methodsFor: 'accessing' stamp: 'CiprianTeodorov 4/9/2013 19:42'! valueSize ^valueSize! ! !NBExternalUnion class methodsFor: 'accessing' stamp: 'CiprianTeodorov 3/28/2013 20:13'! fieldsClass ^ NBExternalUnionFields! ! !NBExternalUnionFields methodsFor: 'parsing spec' stamp: 'CiprianTeodorov 1/19/2013 16:59'! sizeAlignedTo: anAlign with: aType totalSize := (totalSize alignedTo: anAlign ) max: (aType typeSize alignedTo: anAlign)! ! !NBExternalUnionFields methodsFor: 'initialization' stamp: 'CiprianTeodorov 1/19/2013 17:05'! initialize super initialize. nbFields := 0.! ! !NBExternalUnionFields methodsFor: 'accessing' stamp: 'CiprianTeodorov 1/19/2013 16:55'! offsetOf: fieldName ^ 0! ! !NBExternalUnionFields methodsFor: 'parsing spec' stamp: 'CiprianTeodorov 1/19/2013 17:05'! addField: aName type: aType fields at: aName put: {aType. (nbFields := nbFields + 1)}! ! !NBExternalUnionFields methodsFor: 'accessing' stamp: 'IgorStasenko 3/31/2014 14:53'! updateFieldOffsetsFor: unionClass "Not needed, since all fields have same offset == 0.. but we need to update total size" ! ! !NBExtraRootsRegistry commentStamp: 'Igor.Stasenko 4/29/2010 07:53'! This registry serve for instantiating an external types by native code. My sole instance is always refreshing during fresh image startup.! !NBExtraRootsRegistry methodsFor: 'accessing' stamp: 'CamilloBruni 7/23/2012 17:54'! at: aName ifAbsentPut: aBlock ^ self at: aName ifAbsent: [ self at: aName put: aBlock value ]! ! !NBExtraRootsRegistry methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/2/2010 12:52'! at: aName put: anObject "register an object under given name." | sz index | sz := array size. index := sz + 1. (pool includesKey: aName) ifTrue: [ index := pool at: aName ] ifFalse: [ pool at: aName put: index ]. (index > array size) ifTrue: [ array := array copyWith: anObject. self primAtMem: cell put: array. ]. array at: index put: anObject. ^ anObject. ! ! !NBExtraRootsRegistry methodsFor: 'callbacks support' stamp: 'Igor.Stasenko 5/18/2010 02:48'! emitFetchCallback: index generator: gen "index are one, returned from #registerCallback " | reg temp | index isMem ifTrue: [ temp := index ] ifFalse: [ temp := gen reserveTemp. gen asm mov: index to: temp ]. pool at: #callbacks ifAbsent: [ self at: #callbacks put: WeakArray new ]. reg := self emitOopAt: #callbacks generator: gen. reg := gen proxy fetchPointer: temp ofObject: reg. index isMem ifFalse: [ gen releaseTemps: 1 ]. ^ reg ! ! !NBExtraRootsRegistry methodsFor: 'code generation' stamp: 'Igor.Stasenko 5/1/2010 12:44'! emitFetchClass: aClass generator: gen (self assert: aClass isMeta not ). " no metaclasses here" "make sure we registered it" self at: aClass name put: aClass. ^ self emitOopAt: aClass name generator: gen! ! !NBExtraRootsRegistry methodsFor: 'primitives' stamp: 'IgorStasenko 11/24/2012 16:25'! primAddGCRoot: addr "add a given address as GC root" ^ self nbCallout function: #(void ( ulong addr ) ) emit: [:gen | | proxy asm | proxy := gen proxy. asm := gen asm. asm pop: asm EAX. "address" proxy addGCRoot: asm EAX. ]. ! ! !NBExtraRootsRegistry methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 06:36'! at: aName "Answer an object associated with given name." | index | index := pool at: aName. ^ array at: index! ! !NBExtraRootsRegistry methodsFor: 'callbacks support' stamp: 'Igor.Stasenko 5/5/2010 21:09'! registerCallback: aCallback "answer a zero-based index of registered callback " | index callbacks | callbacks := pool at: #callbacks ifAbsent: [ self at: #callbacks put: (WeakArray with: aCallback). ^ 0. ]. callbacks := array at: callbacks. freeCallbackIndexes ifEmpty: [ callbacks := callbacks copyWith: aCallback. self at: #callbacks put: callbacks. ^ callbacks size - 1 ]. index := freeCallbackIndexes removeLast. callbacks at: index+1 put: aCallback. ^ index ! ! !NBExtraRootsRegistry methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/14/2010 02:06'! at: aName ifAbsent: aBlock "Answer an object associated with given name." | index | index := pool at: aName ifAbsent: [ ^ aBlock value ]. ^ array at: index! ! !NBExtraRootsRegistry methodsFor: 'code generation' stamp: 'CamilloBruni 10/3/2012 14:42'! emitOopAt: aName generator: gen "emit code for fetching an oop at given name from registry" | asm proxy index | proxy := gen proxy. asm := gen asm. index := pool at: aName. asm decorateWith: 'NBExtraRootsRegistry at: ', aName printString , ' (' , index asString , ')' during: [ asm mov: cell asUImm32 to: asm EAX. asm mov: asm EAX ptr to: asm EAX. "array oop -> EAX" proxy fetchPointer: index-1 ofObject: asm EAX. ]. "EAX <- oop" ^ asm EAX! ! !NBExtraRootsRegistry methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 5/5/2010 13:46'! initialize: aMemoryCell freeCallbackIndexes := OrderedCollection new. pool := IdentityDictionary new. array := Array new. cell := aMemoryCell asUnsignedLong. self primAtMem: cell put: array. self primAddGCRoot: cell. self at: #'___seed' put: Seed. self assert: array size = 1. ! ! !NBExtraRootsRegistry methodsFor: 'callbacks support' stamp: 'Igor.Stasenko 5/14/2010 02:07'! releaseCallbackIndex: anIndex | callbacks | "release a previously registered zero-based callback index" callbacks := self at: #callbacks ifAbsent: [^ self ]. freeCallbackIndexes add: anIndex. callbacks at: anIndex+1 put: nil.! ! !NBExtraRootsRegistry methodsFor: 'primitives' stamp: 'IgorStasenko 11/24/2012 16:25'! primAtMem: addr put: anOop "write an oop to given memory address" ^ self nbCallout function: #(void ( ulong addr, oop anOop )) emit: [:gen | | proxy asm | proxy := gen proxy. asm := gen asm. asm pop: asm EAX; "address" pop: asm ECX; "oop" mov: asm ECX to: asm EAX ptr ]. ! ! !NBExtraRootsRegistry class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/2/2010 12:50'! newWithCell: aMemoryCell ^ self basicNew initialize: aMemoryCell! ! !NBExtraRootsRegistry class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/2/2010 12:50'! new self error: 'use #newWithCell:'! ! !NBFFICallback commentStamp: ''! My instances represent a callback function, which will be called by external function at some moment. To create a new callback, first, make a subclass of me and override #fnSpec method, which is an anonymous C function signature, l.e. 'int (int foo , float bar )' , which tells that given callback class implements a callback for a function which takes two arguments (foo, bar), and returns integer. (Additionally you can override a #callType method which determines a callback function calling convention. A default calling convention for callbacks is #cdecl, and others is barely used on x86 platforms). To use callbacks, you must instantiate it first by passing block as an argument: mycallback := MyCallback on: someBlock. The block is the closure which will be evaluated when callback function get called, so the block must take same number of arguments as specified in #fnSpec method, and its evaluation result must yield a value which can be converted back C type value, which you speficied as a return type of callback function. For example, if callback signature is 'int (int foo , float bar )' , we can create a callback with following block closure: mycallback := MyCallback on: [:foo :bar | (foo + bar ) asInteger ]. Passing callback as an argument to external function. For passing a callbacks as an argument to C function, you can use its class name for an argument type. For example: primStQSort: base len: size compare: qsortCallback ^ self nbCall: #(void qsort (NBExternalAddress base, ulong size, 1, NBQSortCallback qsortCallback)) module: NativeBoost CLibrary options: #( optMayGC ) as you can see , the third argument (qsortCallback) of function signature, has 'NBQSortCallback' type, which is a class name of existing NBFFICallback subclass. And, of course you are free to create any type aliases for the callback type to use different type names in signature. Just make sure that aliases are resolved correctly to an instance of NBFFICallbackType, during processing of the function signature by NBFFICallout class. !!!!Note!!!! A special care must be taken for all functions which may make callbacks!! In the above qsort() example, you can see an additional option for external call - #optMayGC, which tells a code generator to call an external function via call gate (a special stub which handling a code relocation caused by GC). Thats it, for any external functions, which may call the callback you must pass this option. Rationale: since most of external functions don't make any callbacks (and so has no chance to trigger GC), using this option by default will be an overkill, which will just spend extra CPU cycles for nothing. However, if you omit this option when calling the function(s) which may call back, expect a hard crash(es) to happen. If you unsure which external library functions may call back, you can turn on this option by default for all methods in your class by implementing #ffiCalloutOptions method at class side: MyClass class>>ffiCalloutOptions ^ #( optMayGC ) Like that, for any code generated to make external calls in methods of your class, this option will take an effect. Callback lifetime. Each time you instantiating a new callback, it reserves a small amount of external memory , which must be freed once callback is no longer used. This is done automatically, using object finalization scheme, once system detects that there is no more strong references to callback left. So, you only need to make sure that an instance of callback, which you passed to some external function will be kept around in system, as long as an external library has a pointer to it and can perform calls to it. If you lose the last reference to callback object before making sure that external library can no longer make calls to it, this will lead to an unpredictive behavior (segmentation fault, invalid instruction, memory corruption / pick your favorite). Redefining callback signature. A callback uses a lazy-initialization scheme to generate a common marshalling code which will be used by all instances of specific callback class. So, changing a callback signature (by changing its #fnSpec method) will not have an immediate effect, if you already created at least a single instance of it. To make changes take effect, you must restart an image. ! !NBFFICallback methodsFor: 'code emitting' stamp: 'IgorStasenko 9/15/2012 14:21'! primLeave: leaveAddr stackPtr: saveStackPtr contextOop: senderContext returnValue: oop primitiveMethod: aMethod "simply jump to the address, provided in leaveAddr parameter, which should be an unsigned integer value" ^ NBNativeCodeGen methodAssembly: [:gen | | proxy asm | proxy := gen proxy. asm := gen asm. proxy stackValue: 4. "leaveAddr" proxy positive32BitValueOf: EAX. asm push: EAX. proxy ifFailedJumpTo: #failed. asm pop: EAX; jmp: EAX. " jump to callback leave address " asm label: #failed. gen epilogue. ] ! ! !NBFFICallback methodsFor: 'initialization' stamp: 'IgorStasenko 9/15/2012 20:07'! initialize enterMethod := self class callbackEnterMethod. index := NativeBoost extraRootsRegistry registerCallback: self. self installTrunk. NBExternalResourceManager addResource: self data: {trunk. index }.! ! !NBFFICallback methodsFor: 'code emitting' stamp: 'IgorStasenko 5/8/2012 16:09'! pvtEnter: arguments stackPointer: savedStackPtr primitiveMethod: aMethod "Note, this is for internal use only!!!!!! do not touch this method ever!! " | result theSender | result := 0. theSender := thisContext sender. [ result := block valueWithArguments: arguments ] ensure: [ self primLeave: self class callbackLeaveAddress asUnsignedLong stackPtr: savedStackPtr contextOop: theSender returnValue: result primitiveMethod: aMethod ] ! ! !NBFFICallback methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/13/2010 22:38'! block: aBlock self class numberOfArguments = aBlock numArgs ifFalse: [ self error: 'Invalid number of arguments' ]. block := aBlock! ! !NBFFICallback methodsFor: 'trunk management' stamp: 'IgorStasenko 11/24/2012 15:44'! installTrunk | code bytes | code := self class trunkCode. bytes := code bytes. trunk := NativeBoost allocate: bytes size. NativeBoost memCopy: bytes to: trunk size: bytes size. trunk nbUInt32AtOffset: (code offsetAt: #index) put: index ! ! !NBFFICallback class methodsFor: 'accessing' stamp: 'IgorStasenko 5/8/2012 16:04'! callbackEnterAddress self checkSession. cbEnter ifNil: [ self installCallbackCode ]. ^ cbEnter address ! ! !NBFFICallback class methodsFor: 'accessing' stamp: 'IgorStasenko 5/7/2012 13:47'! callbackEnterMethod "do not override" ^ NBFFICallback compiledMethodAt: #pvtEnter:stackPointer:primitiveMethod: .! ! !NBFFICallback class methodsFor: 'private' stamp: 'IgorStasenko 5/8/2012 16:06'! checkSession session == NativeBoost uniqueSessionObject ifFalse: [ numArgs := cbEnter := cbLeave := trunkCode := nil. session := NativeBoost uniqueSessionObject. ]. ! ! !NBFFICallback class methodsFor: 'callback spec' stamp: 'IgorStasenko 9/16/2012 17:20'! fnSpec "answer an anonymous C function signature for a given callback, like #( long ( int a, int* b) )" self subclassResponsibility . ! ! !NBFFICallback class methodsFor: 'callback spec' stamp: 'Igor.Stasenko 5/13/2010 23:33'! asNBExternalType: gen ^ NBFFICallbackType new callbackClass: self! ! !NBFFICallback class methodsFor: 'accessing' stamp: 'IgorStasenko 5/8/2012 16:05'! callbackLeaveAddress self checkSession. cbLeave ifNil: [ self installCallbackCode ]. ^ cbLeave address ! ! !NBFFICallback class methodsFor: 'code generation' stamp: 'IgorStasenko 5/8/2012 16:53'! installCallbackCode | enterCodeFn leaveCodeFn leaveOffset returnAddr | cbEnter := NBCallbackCodeGen new generateCallbackEnterCodeFor: self. cbEnter install. returnAddr := cbEnter address value + (cbEnter code offsetAt: #returnToC). cbLeave := NBCallbackCodeGen new generateCallbackLeaveCodeFor: self leaveAddr: returnAddr. cbLeave install. ! ! !NBFFICallback class methodsFor: 'private' stamp: 'IgorStasenko 5/7/2012 13:40'! numArgs: int numArgs := int! ! !NBFFICallback class methodsFor: 'private' stamp: 'IgorStasenko 5/8/2012 16:06'! reset self checkSession. cbEnter ifNotNil: [ cbEnter uninstall. cbLeave uninstall. numArgs := cbEnter := cbLeave := trunkCode := nil. ]. ! ! !NBFFICallback class methodsFor: 'accessing' stamp: 'IgorStasenko 5/8/2012 03:04'! trunkCode self checkSession. ^ trunkCode ifNil: [ | asm | asm := NativeBoost newAssembler noStackFrame. "NO STACK FRAME, since we just jump to common entry point" asm mov: (0 asUImm32 label: (asm labelNamed: #index)) to: ECX; " callback index " mov: ((self callbackEnterAddress asUImm32) label: (asm labelNamed: #cbEnterAddress)) to: EAX; jmp: EAX. trunkCode := asm generatedCode. ] ! ! !NBFFICallback class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/13/2010 22:40'! new self error: 'use #on: instead'.! ! !NBFFICallback class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/11/2010 02:35'! numberOfArguments ^ numArgs! ! !NBFFICallback class methodsFor: 'callback spec' stamp: 'IgorStasenko 9/15/2012 14:24'! callType "Answer a callback function calling convention #cdecl or #stdcall " "By default, use cdecl convention" ^ #cdecl! ! !NBFFICallback class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/13/2010 22:43'! on: aBlock ^ self basicNew initialize block: aBlock! ! !NBFFICallback class methodsFor: 'finalization' stamp: 'IgorStasenko 9/15/2012 14:18'! finalizeResourceData: trunkAndIndex NativeBoost free: trunkAndIndex first. NativeBoost extraRootsRegistry releaseCallbackIndex: trunkAndIndex second. ! ! !NBFFICallbackTests methodsFor: 'tests - native callbacks' stamp: 'Igor.Stasenko 9/26/2010 05:38'! testcallbackAddress | callback addr1 addr2 | callback := self createNativeCallback. [ callback install. addr1 := callback address value. addr2 := self checkCallbackAddress: callback address. ] ensure: [ callback uninstall ]. self assert: (addr1 = addr2)! ! !NBFFICallbackTests methodsFor: 'tests' stamp: 'Igor.Stasenko 5/14/2010 01:03'! testMemCopy | mem bytes | bytes := #[ 1 2 3 4 5 6 7 8 9 10 ]. mem := NativeBoost allocate: bytes size. [ NativeBoost memCopy: bytes to: mem size: bytes size. 1 to: bytes size do: [:i | self assert: (bytes at:i) = (mem byteAt: i-1) ]. ] ensure: [ NativeBoost free: mem ]! ! !NBFFICallbackTests methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 16:26'! checkCallbackAddress: nativeCallbackAddr ^ self nbCallout function: #(ulong (NBExternalAddress nativeCallbackAddr)) emit: [:gen | gen asm pop: EAX ] " options: #( - optAllowByteArraysPtr +optAllowExternalAddressPtr ) "! ! !NBFFICallbackTests methodsFor: 'tests' stamp: 'IgorStasenko 6/27/2013 17:17'! testCBGeneratedCode | addr trunk | addr := NBQSortCallback callbackEnterAddress asUnsignedLong. trunk := NBQSortCallback trunkCode. self assert: (trunk bytes unsignedLongAt: 1+ (trunk offsetAt: #cbEnterAddress) bigEndian: false) = addr. ! ! !NBFFICallbackTests methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 16:26'! checkCallback: arr1 with: arr2 compare: nativeCallback ^ self nbCallout function: #(long (NBExternalAddress nativeCallback, byte* arr1, byte* arr2 )) emit: [:gen | gen asm pop: EAX; call: EAX ] ! ! !NBFFICallbackTests methodsFor: 'tests - native callbacks' stamp: 'Igor.Stasenko 9/26/2010 05:36'! createNativeCallback " The routine must compare the elements, then return one of the following values: < 0 elem1 less than elem2 0 elem1 equivalent to elem2 > 0 elem1 greater than elem2 " ^ NBNativeFunctionGen cdecl: #( int (byte* a, byte * b) ) emit: [:gen | | asm | asm := gen asm. asm mov: (gen arg: #b) to: EAX; mov: EAX ptr8 to: CL; mov: (gen arg: #a) to: EAX; mov: EAX ptr8 to: AL; sub: AL with: CL; movsx: EAX with: AL "sign-extend the result" ] ! ! !NBFFICallbackTests methodsFor: 'tests - native callbacks' stamp: 'sig 3/30/2012 14:55'! testNativeCallback | orig bytes callback | orig := #[ 2 5 3 10 39 4 80 ] copy. bytes := orig copy. callback := self createNativeCallback. [ callback install. self primNativeQSort: bytes compare: callback address. ] ensure: [ callback uninstall ]. self assert: (orig sort = bytes) ! ! !NBFFICallbackTests methodsFor: 'tests - language-side callback' stamp: 'IgorStasenko 6/27/2013 17:17'! testQSortCallbackST | callback orig bytes result | orig := #[ 2 5 3 10 39 4 80 ] copy. bytes := NativeBoost allocate: orig size. NativeBoost memCopy: orig to: bytes size: orig size. callback := NBQSortCallback on: [:a :b | (a byteAt: 0) - (b byteAt: 0) ]. self primStQSort: bytes len: orig size compare: callback. result := ByteArray new: orig size. NativeBoost memCopy: bytes to: result size: orig size. NativeBoost free: bytes. self assert: (orig sort = result) ! ! !NBFFICallbackTests methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 16:28'! readByte: array at: index ^ self nbCallout function: #(byte (byte * array, ulong index)) emit: [:gen | gen asm pop: EAX; pop: ECX; add: EAX with: ECX; mov: EAX ptr8 to: AL ] ! ! !NBFFICallbackTests methodsFor: 'qsort callouts' stamp: 'IgorStasenko 11/24/2012 16:27'! primStQSort: base len: size compare: qsortCallback ^ self nbCallout options: #( optMayGC ); function: #(void qsort (NBExternalAddress base, ulong size, 1, NBQSortCallback qsortCallback)) module: NativeBoost CLibrary! ! !NBFFICallbackTests methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 16:28'! readByte: array ^ self nbCallout function: #(byte (byte * array)) emit: [:gen | gen asm pop: EAX; mov: EAX ptr8 to: AL ] ! ! !NBFFICallbackTests methodsFor: 'tests - native callbacks' stamp: 'Igor.Stasenko 9/26/2010 05:38'! testInstallCallback | callback | callback := self createNativeCallback. callback install. self assert:(callback address notNil). callback uninstall.! ! !NBFFICallbackTests methodsFor: 'tests' stamp: 'Igor.Stasenko 5/4/2010 00:33'! testReadByte | arr | arr := #(240 2 3 4 ) asByteArray. self assert: (self readByte: arr) == 240! ! !NBFFICallbackTests methodsFor: 'private' stamp: 'Igor.Stasenko 5/5/2010 16:55'! dummyMethod: aParam ^ aParam! ! !NBFFICallbackTests methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 16:26'! checkEmitFetchClass " checker for fetching the class code emitting " ^ self nbCallout function: #(oop ()) emit: [:gen | gen emitFetchClass: NBExternalAddress ]! ! !NBFFICallbackTests methodsFor: 'tests' stamp: 'Igor.Stasenko 5/4/2010 00:14'! testEmitFetchClass self assert: (self checkEmitFetchClass == NBExternalAddress)! ! !NBFFICallbackTests methodsFor: 'private' stamp: 'Igor.Stasenko 9/26/2010 05:38'! benchQSort | bytes memBytes callback callback2 times | bytes := #[ 2 5 3 10 39 4 80 203 94 215 30 60 80 20 1 4 0 ]. memBytes := NativeBoost allocate: bytes size. callback := self createNativeCallback. callback2 := NBQSortCallback on: [:a :b | (a byteAt: 0) - (b byteAt: 0) ]. [ callback install. times := { [ bytes copy sort ]. [ self primNativeQSort: bytes copy compare: callback address ]. [ NativeBoost memCopy: bytes to: memBytes size: bytes size. self primStQSort: memBytes len: bytes size compare: callback2 ]. } collect: [:block | [ 100000 timesRepeat: block ] timeToRun ]. ] ensure: [ callback uninstall. NativeBoost free: memBytes ]. ^ times ! ! !NBFFICallbackTests methodsFor: 'tests - language-side callback' stamp: 'IgorStasenko 6/27/2013 17:17'! testCallbackCounter | callback orig bytes result ctr | "There was a bug in callback code, which crashed VM due to override of callgate saved method oop and return address, and GC, happened during callback" orig := #[ 2 5 55 23 67 23 ] copy. bytes := NativeBoost allocate: orig size. NativeBoost memCopy: orig to: bytes size: orig size. ctr := 0. callback := NBQSortCallback on: [:a :b | NativeBoost insideCallback ifTrue: [ ctr := ctr+ 1]. "this involves using callgate" Smalltalk garbageCollect. "this involves GC" (a byteAt: 0) - (b byteAt: 0) ]. self primStQSort: bytes len: orig size compare: callback. result := ByteArray new: orig size. NativeBoost memCopy: bytes to: result size: orig size. NativeBoost free: bytes. self assert: (ctr > 0). self assert: (orig sort = result) ! ! !NBFFICallbackTests methodsFor: 'tests - language-side callback' stamp: 'IgorStasenko 11/24/2012 16:26'! checkSTCallbackAddress: callback ^ self nbCallout function: #(void * (NBQSortCallback callback)) emit: [:gen | gen asm pop: EAX ] ! ! !NBFFICallbackTests methodsFor: 'qsort callouts' stamp: 'IgorStasenko 11/24/2012 16:27'! primNativeQSort: base compare: nativeCallback "Here, the base must be a ByteArray instance num, the number of elements in it width = 4 Call qsort function: void qsort( void *base, - array ptr size_t num, - number of elements size_t width, - size of element int (__cdecl *compare )(const void *, const void *) ); " ^ self nbCallout function: #(void qsort (byte* base, NBByteArraySize base, 1, NBExternalAddress nativeCallback)) module: NativeBoost CLibrary ! ! !NBFFICallbackTests methodsFor: 'tests' stamp: 'Igor.Stasenko 5/5/2010 17:00'! testCreateContext | context | context := MethodContext sender: nil receiver: 1 method: (self class compiledMethodAt: #dummyMethod: ) arguments: #( 55 ). ^ context! ! !NBFFICallbackTests methodsFor: 'tests - language-side callback' stamp: 'IgorStasenko 6/27/2013 17:17'! testSTCallbackInstalled | callback trunk index | callback := NBQSortCallback on: [:x :y | ]. trunk := callback trunk. index := callback index. self assert: ((NativeBoost extraRootsRegistry at: #callbacks) at: index +1) == callback. self assert: (self checkSTCallbackAddress: callback) = trunk ! ! !NBFFICallbackType commentStamp: 'Igor.Stasenko 5/4/2010 05:15'! Pushing a callback to stack! !NBFFICallbackType methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/13/2010 23:33'! callbackClass: aClass callbackClass := aClass! ! !NBFFICallbackType methodsFor: 'accessing' stamp: 'cipt 11/28/2012 19:04'! trunkIvarIndex " return a zero-based index " ^ ( callbackClass instVarIndexFor: #trunk ifAbsent: [ self error: ' should not happen ' ] ) - 1! ! !NBFFICallbackType methodsFor: 'emitting code' stamp: 'cipt 11/28/2012 19:36'! coerceReturnValue: gen "trunk is in EAX. first, create an instance of NBExternalHandle. Place the trunk there , then create an instance of receiver and place trunk oop in its trunk ivar" | asm proxy result trunkOop oop done | proxy := gen proxy. asm := gen asm. result := gen reserveTemp. trunkOop := gen reserveTemp. oop := gen reserveTemp. done := asm uniqueLabelName: 'done'. asm mov: asm EAX to: result. gen optReturnNullAsNil ifTrue: [ | notnil | notnil := asm uniqueLabelName: 'notNil'. asm or: asm EAX with: asm EAX; jne: notnil. proxy nilObject. asm jmp: done. asm label: notnil. ]. gen emitFetchClass: NBExternalAddress. proxy instantiateClass: asm EAX indexableSize: 4. asm mov: asm EAX to: trunkOop. proxy firstIndexableField: asm EAX. asm mov: result to: asm ECX; mov: asm ECX to: asm EAX ptr. proxy pushRemappableOop: trunkOop. gen emitFetchClass: callbackClass. proxy instantiateClass: asm EAX indexableSize: 0. "EAX <- our instance " asm mov: asm EAX to: oop. proxy popRemappableOop. asm mov: asm EAX to: trunkOop. proxy storePointer: self trunkIvarIndex ofObject: oop withValue: trunkOop. asm mov: oop to: asm EAX. "return the oop" gen releaseTemps: 3. asm label: done.! ! !NBFFICallbackType methodsFor: 'testing' stamp: 'Igor.Stasenko 5/13/2010 23:31'! isCallback ^ true! ! !NBFFICallbackType methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/4/2010 05:16'! valueSize ^ self pointerSize! ! !NBFFICallbackType methodsFor: 'emitting code' stamp: 'IgorStasenko 9/15/2012 14:22'! pushAsValue: gen "push the callback trunk address" | asm proxy oop | proxy := gen proxy. asm := gen asm. oop := gen reserveTemp. loader emitLoad: gen to: oop. self verifyClassOf: oop is: callbackClass generator: gen. asm mov: oop to: asm EAX. asm mov: asm EAX ptr + (proxy ivar: #trunk in: callbackClass) to: asm EAX. proxy fetchPointer: 0 ofObject: asm EAX. "callback address" asm push: asm EAX. ! ! !NBFFICallout commentStamp: ''! Callout arguments can be either: - an integer constant, boolean or nil - a type name (string or symbol) - a class name - a class variable - any other object, which responds to #asFFICalloutArgument: An object , answered by #asFFICalloutArgument: should implement a public protocol of NBExternalType Todo.... Options: argument coercion options: #coerceBoolToInt - Boolean -> C integer (0/1) #coerceNilToInt - nil -> C integer (0) #coerceFloatToInt - Float -> C integer #coerceCharToInt - Character -> C integer #noTypeChecking - do not perform any type checking for pushed arguments (dangerous, but sometimes can be useful) return value coercion options: #returnBoolAsInt - do not turn a bool(0/1) into Boolean (true/false) cdecl calling convention: 1. Function parameters are pushed on the stack in a right-to-left order. 2. Any local variables declared by the callee are allocated on the stack by subtracting the number of bytes required from esp. That is (sub esp,NUMBER_OF_BYTES). 3. Registers eax, ecx, and edx are available for use in the subprogram. 4. Registers ebx, esi, edi, and ebp must not be modified by the callee. (In fact, they may be used, but their original values must be restored before exiting the callee). 5. When the callee terminates, any local variable must be released by restoring esp to its original value (mov esp,ebp). 6. Function return values are returned in the eax register (except for floating point values, which are returned in the st0 register). 7. After the callee is over, the parameters that were pushed on the stack by the caller must be removed by the caller itself once the callee is terminated. It can be done in two ways : * pop ecx n times, where n is the number of parameters pushed (cons: a useless result is stored in ecx, and ecx's value changes) * add esp,NUMBER_OF_BYTES_PREVIOUSLY_PUSHED (1 parameter pushed = 4 bytes on a 32 bit machine)! !NBFFICallout methodsFor: 'failure code' stamp: 'IgorStasenko 8/8/2011 17:50'! errorCodeForMessage: aString ^ self class registerErrorMessage: aString! ! !NBFFICallout methodsFor: 'code generation' stamp: 'IgorStasenko 1/18/2012 16:22'! newCallInfo self optCdecl ifTrue: [ ^ asm newCdeclCall ]. self optStdcall ifTrue: [ ^ asm newStdCall ]. ! ! !NBFFICallout methodsFor: 'code generation' stamp: 'IgorStasenko 5/11/2011 17:23'! coercionMayFail: aBoolean coercionMayFail := coercionMayFail or: aBoolean ! ! !NBFFICallout methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 11:48'! fnSpec ^ fnSpec! ! !NBFFICallout methodsFor: 'argument loaders' stamp: 'cipt 10/24/2012 20:39'! indirectLoader: aLoader byIndex: anIndex ^ NBSTIndirectArgument new argumentLoader: aLoader; elementIndex: anIndex! ! !NBFFICallout methodsFor: 'code generation' stamp: 'Igor.Stasenko 5/1/2010 13:52'! callCleanup " for cdecl call type we should pop the function arguments we are pushed on stack.. but since we returning back to interpreter using leave , it will be cleaned anyways" ! ! !NBFFICallout methodsFor: 'call conventions' stamp: 'Igor.Stasenko 5/3/2010 22:28'! cdecl options add: #optCdecl! ! !NBFFICallout methodsFor: 'code generation' stamp: 'IgorStasenko 12/3/2013 02:27'! generateInstructions: aFunctionBodyBlock | instructions | proxy prepareForCallout. "prepare & push arguments" asm decorateWith: 'FFI: prepare arguments' during: [ fnSpec arguments do: [:arg | arg prepareArgumentUsing: self ] ]. self foreignCall: [:call | "do not align, if its not required" self optNoAlignment ifTrue: [ call alignment: 1]. self pushArguments. self emitFailureTest. asm decorateWith: 'FFI: performing a call' during: [ aFunctionBodyBlock valueWithPossibleArgs: { self. proxy. asm}. "if we're using custom emitcall section, don't bother to cleanup the stack " (self optEmitCall or: [self optNoCleanup]) ifTrue: [ call disableCleanup ]. ]. ]. "handle return value" asm decorateWith: 'FFI: coerce return value' during: [ fnSpec returnType coerceReturn: self ]. self epilogue. self emitFailureHandler. (self optMayGC or: [proxy usedGate ]) ifTrue: [ asm reserveExtraBytesOnStack: asm wordSize*2. ]. instructions := asm prepareInstructions. self optDebug ifTrue: [ self halt ]. ^ instructions ! ! !NBFFICallout methodsFor: 'accessing' stamp: 'IgorStasenko 8/21/2011 11:29'! namedFnSpec: namedFn fnSpec := self newSpecParser parseNamedFunction: namedFn. ! ! !NBFFICallout methodsFor: 'initialization' stamp: 'IgorStasenko 8/3/2011 06:33'! initialize super initialize. coercionMayFail := false! ! !NBFFICallout methodsFor: 'spec parsing' stamp: 'cipt 10/24/2012 20:25'! argName: argName indirectIndex: anIndex type: typeName ptrArity: ptrArity | type | argName ifNil: [ "allow nil,true,false as untyped arguments" typeName = 'nil' ifTrue: [ ^ NBFFIConst value: 0 ]. typeName = 'false' ifTrue: [ ^ NBFFIConst value: 0 ]. typeName = 'true' ifTrue: [ ^ NBFFIConst value: 1 ]. ptrArity > 0 ifTrue: [ self error: 'missing argument name' ]. "lone self" typeName = 'self' ifTrue: [ ^ (requestor asNBExternalType: self) loader: self receiverArgumentLoader ]. ^ self resolveType: typeName ]. type := self typeName: typeName ptrArity: ptrArity. type loader: (self loaderForArgNamed: argName indirectIndex: anIndex). ^ type! ! !NBFFICallout methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/26/2010 02:03'! requestor ^ requestor! ! !NBFFICallout methodsFor: 'accessing' stamp: 'IgorStasenko 7/12/2013 16:31'! sender: aSenderContext | nArgs | self requestor: aSenderContext method methodClass. nArgs := aSenderContext method numArgs. methodArgs := aSenderContext method nbArgumentNames. self receiver: aSenderContext receiver. self assert: (methodArgs size = nArgs). ! ! !NBFFICallout methodsFor: 'spec parsing' stamp: 'CiprianTeodorov 5/18/2013 21:59'! returnType: aType aType first = 'receiver' ifTrue: [ | rcvr rqstr | "check that: 1. method belongs to class side 2. method class is subclass of NBExternalObject 3. receiver is the same or subclass of the requestor -- since the requestor is the implementor" rcvr := self receiver. rqstr := self requestor soleInstance. (rcvr isBehavior and: [ (rcvr == rqstr or: [ rcvr inheritsFrom: rqstr ]) and: [ rcvr inheritsFrom: NBExternalObject ] ]) ifTrue: [ ^ self typeName: rcvr name ptrArity: aType second ] ]. self receiver: nil. "if the type is not 'receiver' then we don't need the receiver of the message so set it to nil" ^ self typeName: aType first ptrArity: aType second! ! !NBFFICallout methodsFor: 'failure code' stamp: 'IgorStasenko 8/6/2011 18:32'! failWithCode: aCode asm mov: aCode to: EAX; jmp: self failedWithCodeLabel! ! !NBFFICallout methodsFor: 'accessing' stamp: 'JavierPimas 11/16/2011 17:08'! callType: aCallType aCallType == #cdecl ifTrue: [ ^ self cdecl. ]. aCallType == #stdcall ifTrue: [ ^ self stdcall ]. self error: 'unknown call type'. ! ! !NBFFICallout methodsFor: 'code generation' stamp: 'IgorStasenko 1/18/2012 16:22'! foreignCall: aBlock callInfo := self newCallInfo. callInfo alignment: self stackAlignment. asm performingCall: callInfo in: aBlock.! ! !NBFFICallout methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/26/2010 02:04'! requestor: aRequestor requestor := aRequestor. (requestor respondsTo: #ffiCalloutOptions) ifTrue: [ self parseOptions: requestor ffiCalloutOptions ] ! ! !NBFFICallout methodsFor: 'accessing' stamp: 'IgorStasenko 8/21/2011 11:29'! anonSpec: anonFunctionSpec fnSpec := self newSpecParser parseAnonFunction: anonFunctionSpec. ! ! !NBFFICallout methodsFor: 'code generation' stamp: 'IgorStasenko 12/3/2013 02:27'! pushArguments " argument indexes pushed on ST stack are: argType ST stack C stack index index push order 1 2 2 2 1 1 3 0 0 " "both cdecl/apicall using reverse argument order on stack" fnSpec arguments notEmpty ifTrue: [ asm decorateWith: 'FFI: pushing arguments' during: [ fnSpec arguments reverseDo: [:arg | asm noticePush: arg stackSize forCall: callInfo. arg emitPush: self ] ] ]. fnSpec returnType prepareReturnValue: self for: callInfo.! ! !NBFFICallout methodsFor: 'code generation' stamp: 'IgorStasenko 8/5/2011 18:01'! receiverArgumentLoader ^ NBSTMethodArgument new stackIndex: methodArgs size; isReceiver: true ! ! !NBFFICallout methodsFor: 'type aliases' stamp: 'Igor.Stasenko 9/28/2010 08:00'! aliasForType: aTypeName | alias | alias := aTypeName. (requestor notNil and: [ requestor respondsTo: #externalTypeAlias: ]) ifTrue: [ alias := requestor externalTypeAlias: aTypeName. alias ifNil: [ alias := aTypeName ] ]. " internal aliases " TypeAliases ifNil: [ self class initTypeAliases ]. ^ TypeAliases at: alias ifAbsent: [ alias ]! ! !NBFFICallout methodsFor: 'failure code' stamp: 'IgorStasenko 8/8/2011 17:49'! failWithMessage: aString | errorCode | errorCode := self errorCodeForMessage: aString. ^ self failWithCode: errorCode ! ! !NBFFICallout methodsFor: 'argument loaders' stamp: 'cipt 10/24/2012 20:30'! loaderForArgNamed: argName indirectIndex: anIndex | loader | loader := self loaderForArgNamed: argName. anIndex isNil ifFalse: [ loader := self indirectLoader: loader byIndex: anIndex ]. ^ loader! ! !NBFFICallout methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 01:05'! methodArgs ^ methodArgs! ! !NBFFICallout methodsFor: 'failure code' stamp: 'CamilloBruni 7/23/2012 13:29'! emitFailureHandler "emit failure code only if there was a jump on failed label, and label are not already defined in code" | failLbl failWithCodeLabel | failLbl := self failedLabel. failWithCodeLabel := self failedWithCodeLabel. self assert: failLbl isSet not. self assert: failWithCodeLabel isSet not. ((asm isLabelUsed: failWithCodeLabel) or: [asm isLabelUsed: failLbl ] ) ifTrue: [ asm decorateWith: 'FFI: handle failure' during: [ (asm isLabelUsed: failWithCodeLabel) ifTrue: [ "assume that error code is passed in EAX" asm label: failWithCodeLabel. proxy primitiveFailFor: asm EAX. self epilogue ]. (asm isLabelUsed: failLbl) ifTrue: [ asm label: self failedLabel. proxy primitiveFail. self epilogue ]. ]] ! ! !NBFFICallout methodsFor: 'code generation' stamp: 'Igor.Stasenko 4/28/2010 12:46'! returnValueRegister "answer a register, which is used by functions to return value" ^ EAX! ! !NBFFICallout methodsFor: 'accessing' stamp: 'IgorStasenko 8/3/2011 08:42'! useEmitCall "set the flag that we're generating code which using custom emitCall: section" options add: #optEmitCall! ! !NBFFICallout methodsFor: 'failure code' stamp: 'IgorStasenko 8/6/2011 18:25'! failedWithCodeLabel ^ asm labelNamed: #FFICalloutFailedWithCode! ! !NBFFICallout methodsFor: 'accessing' stamp: 'CiprianTeodorov 5/18/2013 20:46'! receiver: anObject receiver := anObject! ! !NBFFICallout methodsFor: 'accessing' stamp: 'CiprianTeodorov 5/18/2013 20:46'! receiver ^ receiver! ! !NBFFICallout methodsFor: 'failure code' stamp: 'IgorStasenko 8/3/2011 06:53'! emitFailureTest "emit call to InterpreterProxy>>failed to check if there's everything ok (usually done before making a call) " coercionMayFail ifTrue: [ proxy ifFailedJumpTo: self failedLabel ]. ! ! !NBFFICallout methodsFor: 'failure code' stamp: 'IgorStasenko 8/6/2011 18:25'! failedLabel ^ asm labelNamed: #FFICalloutFailed! ! !NBFFICallout methodsFor: 'code generation' stamp: 'CamilloBruni 7/25/2012 12:43'! generate: aFunctionBodyBlock "Answer the byte array, containing the generated machine code" | generatedCode | generatedCode := AJGeneratedCode fromInstructions: (self generateInstructions: aFunctionBodyBlock). ^ generatedCode bytes ! ! !NBFFICallout methodsFor: 'spec parsing' stamp: 'Igor.Stasenko 4/30/2010 09:18'! typeName: aName ptrArity: ptrArity ^ (self resolveType: aName) pointerArity: ptrArity! ! !NBFFICallout methodsFor: 'call conventions' stamp: 'Igor.Stasenko 5/3/2010 22:27'! stdcall options add: #optStdcall! ! !NBFFICallout methodsFor: 'testing' stamp: 'Igor.Stasenko 5/18/2010 02:23'! usesMethodArguments ^ fnSpec arguments anySatisfy: [:type | type loader usesSTStack ]! ! !NBFFICallout methodsFor: 'code generation' stamp: 'IgorStasenko 11/22/2012 18:23'! generateCall: functionSpec module: aModuleNameOrHandle "Generate a foreign function callout from given function specification and a module name" | fnAddress | self namedFnSpec: functionSpec. fnAddress := requestor nbGetSymbolAddress: fnSpec functionName module: aModuleNameOrHandle. fnAddress ifNil: [ self error: 'function unavailable' ]. ^ self generateCallToAddress: [ fnAddress ] ! ! !NBFFICallout methodsFor: 'argument loaders' stamp: 'cipt 10/21/2012 20:25'! loaderFromMethodArgsNamed: argName methodArgs ifNotNil: [ | index | index := methodArgs indexOf: argName ifAbsent: [ nil ]. index ifNotNil: [ "ok, this is a method argument" ^ NBSTMethodArgument new stackIndex: methodArgs size - index ] ]. ^ nil! ! !NBFFICallout methodsFor: 'code generation' stamp: 'IgorStasenko 11/22/2012 18:10'! generateCallToAddress: aFunctionAddressBlock "Generate a foreign function callout using given function address" ^ self generate: [:gen | | fnAddress | fnAddress := aFunctionAddressBlock cull: self cull: proxy cull: asm. fnAddress ifNil: [ self error: 'function unavailable' ]. self optMayGC ifTrue: [ "a GC may be triggered during external call. Make sure we making a call via gate " asm push: fnAddress asUImm32; mov: NativeBoost callgateFunctionAddress asUImm32 to: EAX; call: EAX ] ifFalse: [ asm mov: fnAddress asUImm32 to: EAX; call: EAX. ] ] ! ! !NBFFICallout methodsFor: 'spec parsing' stamp: 'Igor.Stasenko 4/30/2010 11:27'! integerConstantArgument: int ^ NBFFIConst value: int! ! !NBFFICallout methodsFor: 'accessing' stamp: 'IgorStasenko 2/9/2012 12:38'! resolveType: aTypeName " a type name could be - a class variable name - a class name - a type name - a type name, followed by arbitrary number pointer chars - $*" | name newName resolver binding ptrArity | newName := aTypeName. ptrArity := 0. "resolve aliases and pointers" [ name := newName trimRight. newName := self aliasForType: name. newName last = $* ifTrue: [ ptrArity := ptrArity + 1. newName := newName allButLast ]. name = newName ] whileFalse. resolver := requestor ifNil: [ self class ]. binding := resolver nbBindingOf: name asSymbol. binding ifNotNil: [ ^ (binding value asNBExternalType: self) pointerArity: ptrArity ] . ^ self error: 'Unable to resolve external type: ', aTypeName. ! ! !NBFFICallout methodsFor: 'private' stamp: 'IgorStasenko 7/12/2013 16:31'! methodArgs: aMethodArgumentNames "Note: avoid setting directly, this method is only for testing purposes" methodArgs := aMethodArgumentNames! ! !NBFFICallout methodsFor: 'argument loaders' stamp: 'cipt 10/26/2012 19:26'! loaderForArgNamed: argName | loader | "try getting the argument from the method arguments" loader := self loaderFromMethodArgsNamed: argName. loader ifNil: [ "special case, receiver argument" argName = 'self' ifTrue: [ loader := self receiverArgumentLoader ]. loader ifNil: [ "Ask the requestor for the argument" loader := requestor nbFnArgument: argName generator: self. loader ifNil: [ Error signal: 'Could not find accessor for variable named "' , argName , '" in ' , method name ] ] ]. "]" ^ loader! ! !NBFFICallout methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 06:54'! newSpecParser ^ NBFnSpecParser new requestor: self ! ! !NBFFICallout class methodsFor: 'generator entry points' stamp: 'CamilloBruni 7/17/2012 14:00'! stdcall: functionSpec module: aModuleName options: anOptions "Note, this is a special method, which should be sent only from methods, which intend to use FFI callout code. All such methods should use a 'primitiveNativeCall' primitive. First argument is a function specification denoting return value type, name and arguments. " | sender | sender := thisContext sender. ^ self handleFailureIn: sender nativeCode: [ :gen | gen sender: sender; parseOptions: anOptions; stdcall; generateCall: functionSpec module: aModuleName ] ! ! !NBFFICallout class methodsFor: 'generator entry points' stamp: 'Igor.Stasenko 5/3/2010 21:48'! cdecl: functionSpec module: aModuleName "Note, this is a special method, which should be sent only from methods, which intend to use FFI callout code. All such methods should use a 'primitiveNativeCall' primitive. First argument is an array of types, where first element denotes a function return type, and rest denoting argument types. A CallEmittingBlock serves to emit an actual function call code. " | sender | sender := thisContext sender. ^ self handleFailureIn: sender nativeCode: [ :gen | gen sender: sender; cdecl; generateCall: functionSpec module: aModuleName ] ! ! !NBFFICallout class methodsFor: 'options' stamp: 'cipt 10/25/2012 19:14'! defaultOptions "see #allOptions on my instance side" ^ #( "#optCoerceNilToNull" "passing nil as a pointer-type argument, converts it to C NULL " #optAllowExternalAddressPtr "for a pointer-type argument, accept an instance of NBExternalAddress " "for a pointer-type argument, allow passing a pointer to byte arrays" #optAllowByteArraysPtr "if function returns a pointer, return nil if pointer is null" #optReturnNullAsNil "If function returns a pointer, fail primitive if pointer is null. Takes preference over #returnNullAsNil Default: disabled. " "#optFailOnReturnNull" "if function returns a pointer, convert it to unsigned integer object. Default: disabled #optReturnPtrAsInt " "If function returns a pointer, convert it to an instance of NBExternalAddress. Takes preference over #returnPtrAsInt. Default: enabled. " #optReturnPtrAsExternalAddress "directly convert between C integers and Smallintegers instead of using proxy functions. perform no range checking" "#optQuickSmi -- not yet done " "directly convert between C integers and Smallintegers instead of using proxy functions. include range checking" "#optQuickSmiSafe -- not yet done " "string conversion" "for char* parameter type, when passed an instance of ByteString, copy a ByteString's contents on a stack, append null character and pass a pointer to it" "#optAcceptStringForCharPtr --- not yet implemented" "for a function returning char* type, convert it to an instance of ByteString" "#optReturnCharPtrAsString -- not yet implemented" "for a function spec taking arguments indirectly from an array using the x@index convention check that the index is not outside x''s bounds " #optCheckIndirectArgBounds ) ! ! !NBFFICallout class methodsFor: 'generator entry points' stamp: 'CamilloBruni 10/4/2012 15:34'! cdecl: functionSpec emitCall: aCallEmittingBlock options: anOptions "Note, this is a special method, which should be sent only from methods, which intend to use FFI callout code. All such methods should use a 'primitiveNativeCall' primitive. First argument is an array of types, where first element denotes a function return type, and rest denoting argument types. A CallEmittingBlock serves to emit an actual function call code. " | sender | sender := thisContext sender. ^ self handleFailureIn: sender nativeCode: [ :gen | gen useEmitCall; sender: sender; parseOptions: anOptions; cdecl; anonSpec: functionSpec; generate: aCallEmittingBlock ] ! ! !NBFFICallout class methodsFor: 'error messages' stamp: 'IgorStasenko 2/20/2012 13:48'! signalError: errorCode ^ NBFFICalloutError signalError: errorCode ! ! !NBFFICallout class methodsFor: 'generator entry points' stamp: 'IgorStasenko 11/22/2012 13:39'! call: anonFunctionSignature convention: callConvention functionAddress: aFunctionAddressBlock options: aCodeGenerationOptions " For documentation, please look at #call:convention:functionAddress: This method differs only by having additional argument - a code generation options " | sender | sender := thisContext sender. ^ self handleFailureIn: sender nativeCode: [ :gen | gen sender: sender; callType: callConvention; parseOptions: aCodeGenerationOptions; anonSpec: anonFunctionSignature; generateCallToAddress: aFunctionAddressBlock ] ! ! !NBFFICallout class methodsFor: 'generator entry points' stamp: 'CamilloBruni 7/17/2012 13:59'! cdecl: functionSpec emitCall: aCallEmittingBlock "Note, this is a special method, which should be sent only from methods, which intend to use FFI callout code. All such methods should use a 'primitiveNativeCall' primitive. First argument is an array of types, where first element denotes a function return type, and rest denoting argument types. A CallEmittingBlock serves to emit an actual function call code. " | sender | sender := thisContext sender. ^ self handleFailureIn: sender nativeCode: [ :gen | gen useEmitCall; sender: sender; cdecl; anonSpec: functionSpec; generate: aCallEmittingBlock ] ! ! !NBFFICallout class methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 4/28/2010 16:46'! initialize Smalltalk removeFromStartUpList: self . self initTypeAliases! ! !NBFFICallout class methodsFor: 'initialize-release' stamp: 'IgorStasenko 9/3/2012 01:42'! initTypeAliases "self initTypeAliases" TypeAliases := Dictionary newFromPairs: #( "not really a type, useful only as return type or with pointers " void NBVoid " 0/!!0 <-> false/true " bool NBBool "fixed size integer types, byte order is platform dependent " int8 NBInt8 uint8 NBUInt8 int16 NBInt16 uint16 NBUInt16 int32 NBInt32 uint32 NBUInt32 int64 NBInt64 uint64 NBUInt64 " aliases to common C compiler types.. some of them are platform dependent, some is not.. to be sorted out later " signedByte int8 unsignedByte int8 signedShort int16 unsignedShort uint16 signedChar int8 unsignedChar uint8 schar int8 uchar uint8 signedLong int32 unsignedLong uint32 sbyte int8 byte uint8 short int16 ushort uint16 long int32 ulong uint32 longlong int64 ulonglong uint64 uint uint32 int int32 "unsigned for sizes.. usually same size as platform's word size" size_t NBSizeT "character type. uint8 <-> accepts Character/Smallint as argument, converts return to Character " Character NBCharacterType char NBCharacterType "Floats fixed-size. platform-dependent byte order" float16 NBFloat16 float32 NBFloat32 float64 NBFloat64 float128 NBFloat128 "Floats, C type name aliases" float float32 double float64 shortFloat float16 "Special types " oop NBOop ) ! ! !NBFFICallout class methodsFor: 'generator entry points' stamp: 'CamilloBruni 7/19/2012 17:28'! cdecl: functionSpec " A shortcut for writing cdecl: AFunctionSpecification module: NativeBoost CLibrary" | sender | sender := thisContext sender. ^ self handleFailureIn: sender nativeCode: [ :gen | gen sender: sender; cdecl; generateCall: functionSpec module: NativeBoost CLibrary ]! ! !NBFFICallout class methodsFor: 'error messages' stamp: 'IgorStasenko 8/8/2011 17:53'! registerErrorMessage: aString | newCode | CustomErrorMessages ifNil: [ CustomErrorMessages := Dictionary new. CustomErrorCodes := Dictionary new. ]. (CustomErrorMessages includesKey: aString) ifTrue: [ ^ CustomErrorMessages at: aString ]. "add new message and register code for it " newCode := 600 + CustomErrorCodes size. CustomErrorMessages at: aString put: newCode. CustomErrorCodes at: newCode put: aString. ^ newCode! ! !NBFFICallout class methodsFor: 'generator entry points' stamp: 'CamilloBruni 7/17/2012 14:01'! stdcall: functionSpec module: aModuleName "Note, this is a special method, which should be sent only from methods, which intend to use FFI callout code. All such methods should use a 'primitiveNativeCall' primitive. First argument is an array of types, where first element denotes a function return type, and rest denoting argument types. A CallEmittingBlock serves to emit an actual function call code. " | sender | sender := thisContext sender. ^ self handleFailureIn: sender nativeCode: [ :gen | gen sender: sender; stdcall; generateCall: functionSpec module: aModuleName ] ! ! !NBFFICallout class methodsFor: 'generator entry points' stamp: 'Igor.Stasenko 5/3/2010 21:50'! cdecl: functionSpec module: aModuleName options: anOptions "Note, this is a special method, which should be sent only from methods, which intend to use FFI callout code. All such methods should use a 'primitiveNativeCall' primitive. First argument is an array of types, where first element denotes a function return type, and rest denoting argument types. A CallEmittingBlock serves to emit an actual function call code. " | sender | sender := thisContext sender. ^ self handleFailureIn: sender nativeCode: [ :gen | gen sender: sender; parseOptions: anOptions; cdecl; generateCall: functionSpec module: aModuleName ] ! ! !NBFFICallout class methodsFor: 'error messages' stamp: 'IgorStasenko 8/8/2011 17:54'! messageForCode: aCode CustomErrorCodes ifNil: [ ^ nil ]. ^ CustomErrorCodes at: aCode ifAbsent: nil! ! !NBFFICallout class methodsFor: 'generator entry points' stamp: 'CamilloBruni 7/17/2012 14:01'! stdcall: functionSpec emitCall: aCallEmittingBlock "Note, this is a special method, which should be sent only from methods, which intend to use FFI callout code. All such methods should use a 'primitiveNativeCall' primitive. First argument is an array of types, where first element denotes a function return type, and rest denoting argument types. A CallEmittingBlock serves to emit an actual function call code. " | sender | sender := thisContext sender. ^ self handleFailureIn: sender nativeCode: [ :gen | gen useEmitCall; sender: sender; stdcall; anonSpec: functionSpec; generate: aCallEmittingBlock ] ! ! !NBFFICallout class methodsFor: 'generator entry points' stamp: 'IgorStasenko 11/22/2012 13:36'! call: anonFunctionSignature convention: callConvention functionAddress: aFunctionAddressBlock "Note, this is a special method, which should be sent only from methods, which intend to use FFI callout code. All such methods should use a 'primitiveNativeCall' primitive. First argument should be an anonymous function signature, describing the return type and arguments. Second argument is calling convention for the function, should be either #cdecl or #stdcall (more can be added later) Third argument is a block, which takes 0 or 1 argument (generator instance) and should return an address of function to call, either an unsigned integer value, or NBExternalAddress instance. Example of use: myMethod ^ NBFFICallout call: #( int () ) convention: #cdecl functionAddress: [:generator | NativeBoost loadSymbol: 'fork' fromModule: NativeBoost CLibrary] which is equivalent to: myMethod ^ self nbCall: #( int fork() ) This API allows users to define own custom semantics, how/where to obtain a pointer to function which needs to be called. Please note that function address block is evaluated only once during code generation, and received function address will be imprinted into generated code, so this API does not fits for cases, when function address needs to be always resolved dynamically during each activation of the method. For that , there is #cdecl:emitCall: / #stdCall:emitCall: API which allow user to provide own assembler code for calling the function. " | sender | sender := thisContext sender. ^ self handleFailureIn: sender nativeCode: [ :gen | gen sender: sender; callType: callConvention; anonSpec: anonFunctionSignature; generateCallToAddress: aFunctionAddressBlock ] ! ! !NBFFICallout class methodsFor: 'generator entry points' stamp: 'CamilloBruni 7/17/2012 14:01'! stdcall: functionSpec emitCall: aCallEmittingBlock options: anOptions "Note, this is a special method, which should be sent only from methods, which intend to use FFI callout code. All such methods should use a 'primitiveNativeCall' primitive. First argument is an array of types, where first element denotes a function return type, and rest denoting argument types. A CallEmittingBlock serves to emit an actual function call code. " | sender | sender := thisContext sender. ^ self handleFailureIn: sender nativeCode: [ :gen | gen useEmitCall; sender: sender; parseOptions: anOptions; stdcall; anonSpec: functionSpec; generate: aCallEmittingBlock ] ! ! !NBFFICalloutAPI methodsFor: 'initialization' stamp: 'IgorStasenko 11/22/2012 18:18'! initialize conv := #cdecl. options := #().! ! !NBFFICalloutAPI methodsFor: 'call conventions' stamp: 'IgorStasenko 11/22/2012 18:11'! stdcall conv := #stdcall! ! !NBFFICalloutAPI methodsFor: 'action' stamp: 'IgorStasenko 11/25/2012 15:40'! function: functionSignature address: fnAddressBlock ^ NBFFICallout handleFailureIn: context nativeCode: [:gen | gen callType: conv; sender: context; parseOptions: options; anonSpec: functionSignature; generateCallToAddress: fnAddressBlock ] ! ! !NBFFICalloutAPI methodsFor: 'accessing' stamp: 'IgorStasenko 11/22/2012 14:23'! context: anObject context := anObject! ! !NBFFICalloutAPI methodsFor: 'action' stamp: 'IgorStasenko 11/24/2012 22:38'! function: functionSignature module: moduleNameOrHandle ^ NBFFICallout handleFailureIn: context nativeCode: [:gen | gen callType: conv; sender: context; parseOptions: options; generateCall: functionSignature module: moduleNameOrHandle ]! ! !NBFFICalloutAPI methodsFor: 'options' stamp: 'IgorStasenko 11/22/2012 18:12'! options: codeGenerationOptions options := codeGenerationOptions! ! !NBFFICalloutAPI methodsFor: 'call conventions' stamp: 'IgorStasenko 11/22/2012 18:11'! cdecl conv := #cdecl! ! !NBFFICalloutAPI methodsFor: 'accessing' stamp: 'IgorStasenko 11/23/2012 13:56'! convention: aCallConvention conv := aCallConvention ! ! !NBFFICalloutAPI methodsFor: 'action' stamp: 'IgorStasenko 11/24/2012 22:38'! function: functionSignature emit: aCallEmittingBlock ^ NBFFICallout handleFailureIn: context nativeCode: [:gen | gen useEmitCall; callType: conv; sender: context; parseOptions: options; anonSpec: functionSignature; generate: aCallEmittingBlock ] ! ! !NBFFICalloutAPI methodsFor: 'accessing' stamp: 'IgorStasenko 11/22/2012 14:23'! context ^ context! ! !NBFFICalloutAPI class methodsFor: 'instance creation' stamp: 'IgorStasenko 11/22/2012 14:24'! inContext: aContext ^ self new context: aContext! ! !NBFFICalloutError commentStamp: 'IgorStasenko 2/20/2012 13:52'! My instances indicating an error during execution of FFI callout. To get a description, i look up in NBFFICallout for custom error messages , in addition to my superclass. ! !NBFFICalloutError methodsFor: 'accessing' stamp: 'IgorStasenko 2/20/2012 13:47'! description ^ NBErrorDescriptions at: errorCode ifAbsent: [ (NBFFICallout messageForCode: errorCode) ifNil: [ 'Error during FFI call: ' , errorCode asString]]. ! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'nativeboost-primitives' stamp: 'IgorStasenko 11/24/2012 17:14'! returnOopMinus1Of: anArg ^ self nbCallout options: #( + optUseStackPointer optNoAlignment +optCheckIndirectArgBounds - optDirectProxyFnAddress ); function: #( oop (oop anArg@ -1) ) emit: [:gen | gen asm mov: gen asm ESP ptr to: gen asm EAX ] ! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'error messages' stamp: 'cipt 10/26/2012 21:05'! boundsError ^'Bound checking failed on indirect argument loading'! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'nativeboost-primitives' stamp: 'CiprianTeodorov 5/18/2013 00:12'! returnOop0Of: anArg ^ self nbCallout options: #( + optUseStackPointer optNoAlignment +optCheckIndirectArgBounds - optDirectProxyFnAddress ); function: #( oop (oop anArg@0) ) emit: [:gen | gen asm mov: gen asm ESP ptr to: gen asm EAX ] ! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'nativeboost-primitives' stamp: 'IgorStasenko 11/24/2012 17:13'! returnOop2Of: anArg ^ self nbCallout options: #( + optUseStackPointer optNoAlignment +optCheckIndirectArgBounds - optDirectProxyFnAddress ); function: #( oop (oop anArg@2) ) emit: [:gen | gen asm mov: gen asm ESP ptr to: gen asm EAX ] ! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'nativeboost-primitives' stamp: 'IgorStasenko 11/24/2012 17:15'! returnOopMinus3Of: anArg ^ self nbCallout options: #( + optUseStackPointer optNoAlignment +optCheckIndirectArgBounds - optDirectProxyFnAddress ); function: #( oop (oop anArg@ -3) ) emit: [:gen | gen asm mov: gen asm ESP ptr to: gen asm EAX ] ! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'cipt 10/27/2012 12:21'! testIndirectArgumentDictionayFailure | array | array := {(1 -> 2). (3 -> 3)} asDictionary. self assert: (self returnOop1Of: array) = 2. "tally" self assert: (self returnOop2Of: array) = {nil. 1->2. nil. 3->3. nil}. "array" self should: [ self returnOop5Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self boundsError ]! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'cipt 10/26/2012 21:08'! testIndirectArgumentFloatFailure | array | array := 2.0. self should: [ self returnOop1Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self typeError ]. self should: [ self returnOop2Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self typeError ]. self should: [ self returnOop5Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self typeError ]! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'cipt 10/26/2012 20:53'! testIndirectArgumentObjectFirstBoundsFailure | array | array := Object new. self should: [ self returnOop1Of: array ] raise: NBFFICalloutError. ! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'cipt 10/26/2012 21:08'! testIndirectArgumentObjectBoundsFailure | array | array := Object new. self should: [ self returnOop2Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self boundsError ]. self should: [ self returnOop5Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self boundsError ]! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'cipt 10/26/2012 21:08'! testIndirectArgumentPointFailure | array | array := 2 @ 5. self assert: (self returnOop1Of: array) == 2. self assert: (self returnOop2Of: array) == 5. self should: [ self returnOop5Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self boundsError ]! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'cipt 10/26/2012 21:08'! testIndirectArgumentSmallIntegerFailure | array | array := 2. self should: [ self returnOop1Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self typeError ]. self should: [ self returnOop2Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self typeError ]. self should: [ self returnOop5Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self typeError ]! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'nativeboost-primitives' stamp: 'IgorStasenko 11/24/2012 17:13'! returnOop5Of: anArg ^ self nbCallout options: #( + optUseStackPointer optNoAlignment +optCheckIndirectArgBounds - optDirectProxyFnAddress ); function: #( oop (oop anArg@5) ) emit: [:gen | gen asm mov: gen asm ESP ptr to: gen asm EAX ] ! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/18/2013 00:12'! testIndirectArgumentArray0Indirect | array | array := {1. 2. 3. 4. 5}. self should: [ self returnOop0Of: array ] raise: Error withExceptionDo: [ :anEx | self assert: (anEx messageText beginsWith: self boundsError) ].! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'cipt 10/27/2012 12:43'! testNotIndirectableObjects |ok | ok := { 2. "small integer" 100 factorial. "large positive integer" 3.4. "float" 'abcd'. "bytestring" 'abcd' asByteArray. "bytearray" }. ok do:[:each | self deny: (self primIsPointers: each)].! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'error messages' stamp: 'cipt 10/26/2012 21:04'! typeError ^'Type checking failed on indirect argument loading'! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'cipt 10/27/2012 12:16'! testIndirectArgumentLargePositiveIntegerFailure | array | array := 100 factorial. self should: [ self returnOop1Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self typeError ]. self should: [ self returnOop2Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self typeError ]. self should: [ self returnOop5Of: array ] raise: NBFFICalloutError withExceptionDo: [ :anEx | self assert: anEx messageText = self typeError ]! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/18/2013 00:10'! testIndirectArgumentArrayNegativeIndirect | array | array := {1. 2. 3. 4. 5}. self should: [ self returnOopMinus1Of: array ] raise: Error withExceptionDo: [ :anEx | self assert: (anEx messageText beginsWith: self boundsError) ]. self should: [ self returnOopMinus3Of: array ] raise: Error withExceptionDo: [ :anEx | self assert: (anEx messageText beginsWith: self boundsError) ]! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'nativeboost-primitives' stamp: 'IgorStasenko 11/24/2012 17:12'! returnOop1Of: anArg ^ self nbCallout options: #( + optUseStackPointer optNoAlignment +optCheckIndirectArgBounds - optDirectProxyFnAddress ); function: #( oop (oop anArg@1) ) emit: [:gen | gen asm mov: gen asm ESP ptr to: gen asm EAX ] ! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'cipt 10/27/2012 12:41'! testIndirectableObjects |ok | ok := { Object new. {1. 2}. {1->2. 2->3} asDictionary. 2@3. }. ok do:[:each | self assert: (self primIsPointers: each)].! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'tests' stamp: 'cipt 10/26/2012 20:43'! testIndirectArgumentArrayOk | array | array := {1. 2. 3. 4. 5}. self assert: (self returnOop1Of: array) == 1. self assert: (self returnOop2Of: array) == 2. self assert: (self returnOop5Of: array) == 5! ! !NBFFICalloutIndirectArgumentTests methodsFor: 'nativeboost-primitives' stamp: 'IgorStasenko 11/24/2012 17:11'! primIsPointers: anObject ^ self nbCallout function: #(NBBool (oop anObject)) emit: [ :gen :proxy :asm | asm pop: asm EAX. proxy isPointers: asm EAX ]! ! !NBFFICalloutTests methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 17:16'! returnReceiver: x arg2: y ^ self nbCallout function: #( oop (oop self , oop x, oop y)) emit: [ :gen :proxy :asm | proxy receiver ] ! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'IgorStasenko 1/17/2014 20:47'! testPrepareArgumentsKeepsStackAligned | sp | sp := self passString: '12345'. self assert: (sp \\ NativeBoost forCurrentPlatform stackAlignment) = 0. ! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'IgorStasenko 8/6/2011 18:36'! testFailCode self assert: ( [ self nativeFailWithCode: 1234. false ] on: NBNativeCodeError do: [:ex | ex return: ex errorCode = 1234 ] ) ! ! !NBFFICalloutTests methodsFor: 'private' stamp: 'IgorStasenko 1/17/2014 12:46'! passString: str "see testPrepareArgumentsKeepsStackAligned" ^ self nbCallout function: #( uint (String str) ) emit: [ :gen :proxy :asm | asm mov: asm ESP to: asm EAX ] ! ! !NBFFICalloutTests methodsFor: 'generator callbacks' stamp: 'IgorStasenko 9/3/2012 00:12'! asNBExternalType: gen self assert: (gen respondsTo: #asm). self assert: (gen respondsTo: #proxy). self assert: (gen requestor == self). ^ NBUInt32 new! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'Igor.Stasenko 4/30/2010 12:03'! checkType: type class: typeClass value: const self assert: type class == typeClass. self assert: type value = const! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'cipt 10/26/2012 19:32'! checkType: type class: typeClass arity: ptrArity stackIndex: stackIndex elementIndex: anIndex self assert: type class == typeClass. self assert: type pointerArity = ptrArity. self assert: type loader class == NBSTIndirectArgument. self assert: type loader argumentLoader stackIndex = stackIndex. self assert: type loader elementIndex = anIndex ! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'IgorStasenko 8/10/2011 18:27'! testProxyReceiver self assert: (self returnReceiver: 10 arg2: 20) == self! ! !NBFFICalloutTests methodsFor: 'running' stamp: 'IgorStasenko 1/17/2014 12:49'! setUp self class selectors do: [ :sel | NBNativeCodeGen removeNativeCodeFrom: (self class>>sel) ]! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'IgorStasenko 9/3/2012 00:03'! testBuildingFnSpec | generator type s | generator := NBFFICallout new. CLASSVAR := 100. TYPEVAR := 'long'. generator requestor: self; methodArgs: #( 'arg1' 'arg2' 'arg3' ); cdecl; anonSpec: #( long* (int self , String arg1, void**arg2, TYPEVAR arg1, char arg3, 0, nil, true, false , CLASSVAR ) ). type := generator fnSpec returnType. self assert: (type class == NBInt32). self assert: (type pointerArity = 1). self assert: (generator fnSpec arguments size = 10). s := generator fnSpec arguments readStream. "int self" self checkType: s next class: NBInt32 arity: 0 stackIndex: 3 . "String arg1" self checkType: s next class: NBExternalString arity: 0 stackIndex: 2 . "void**arg2" self checkType: s next class: NBVoid arity: 2 stackIndex: 1. "TYPEVAR arg1" self checkType: s next class: NBInt32 arity: 0 stackIndex: 2. "char arg3" self checkType: s next class: NBCharacterType arity: 0 stackIndex: 0. "0" self checkType: s next class: NBFFIConst value: 0. "nil" self checkType: s next class: NBFFIConst value: 0. "true" self checkType: s next class: NBFFIConst value: 1. "false" self checkType: s next class: NBFFIConst value: 0. "CLASSVAR" self checkType: s next class: NBFFIConst value: 100. ! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'Igor.Stasenko 4/30/2010 12:02'! checkType: type class: typeClass arity: ptrArity stackIndex: stackIndex self assert: type class == typeClass. self assert: type pointerArity = ptrArity. self assert: type loader class == NBSTMethodArgument. self assert: type loader stackIndex = stackIndex ! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'IgorStasenko 9/3/2012 00:12'! testSupportedProtocols | gen spec arg | gen := NBFFICallout new requestor: self. CLASSVAR := self. "so we will receive #asNBExternalType: " gen anonSpec: #(CLASSVAR (CLASSVAR testIvar)). spec := gen fnSpec. self assert: spec returnType class == NBUInt32. arg := spec arguments first. self assert: arg class == NBUInt32. self assert: arg loader ='testIvar loader'. ! ! !NBFFICalloutTests methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 17:15'! arraySize2: array with: param2 ^ self nbCallout function: #(ulong (NBByteArraySize array, long param2)) emit: [:gen | "pop the array size" gen asm pop: gen asm EAX ] ! ! !NBFFICalloutTests methodsFor: 'generator callbacks' stamp: 'IgorStasenko 2/24/2012 17:53'! nbFnArgument: argName generator: gen self assert: argName = 'testIvar'. ^ 'testIvar loader'! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'IgorStasenko 11/24/2012 17:15'! nativeFailWithCode: aCode ^ self nbCallout function: #(void (uint aCode) ) emit: [:gen :proxy :asm | asm pop: asm EAX. gen failWithCode: asm EAX. ] ! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'Igor.Stasenko 5/3/2010 23:31'! testArraySize | arr | arr := ByteArray new: 100. self assert: (self arraySize: arr) = 100. self assert: (self arraySize2: arr with: 20) = 100.! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'cipt 10/24/2012 19:32'! testBuildingFnSpecWithQueries | generator type s | generator := NBFFICallout new. CLASSVAR := 100. TYPEVAR := 'long'. generator requestor: self; methodArgs: #( 'arg1' 'arg2' 'arg3' ); cdecl; anonSpec: #( long* (int self , int arg3@2, String arg1, void**arg2, TYPEVAR arg1, long **arg1@1, char arg3, 0, nil, true, false , CLASSVAR ) ). type := generator fnSpec returnType. self assert: (type class == NBInt32). self assert: (type pointerArity = 1). self assert: (generator fnSpec arguments size = 12). s := generator fnSpec arguments readStream. "int self" self checkType: s next class: NBInt32 arity: 0 stackIndex: 3 . "int arg3@2" self checkType: s next class: NBInt32 arity: 0 stackIndex: 0 elementIndex: 2. "String arg1" self checkType: s next class: NBExternalString arity: 0 stackIndex: 2 . "void**arg2" self checkType: s next class: NBVoid arity: 2 stackIndex: 1. "TYPEVAR arg1" self checkType: s next class: NBInt32 arity: 0 stackIndex: 2. "long ** arg1@1" self checkType: s next class: NBInt32 arity: 2 stackIndex: 2 elementIndex: 1. "char arg3" self checkType: s next class: NBCharacterType arity: 0 stackIndex: 0. "0" self checkType: s next class: NBFFIConst value: 0. "nil" self checkType: s next class: NBFFIConst value: 0. "true" self checkType: s next class: NBFFIConst value: 1. "false" self checkType: s next class: NBFFIConst value: 0. "CLASSVAR" self checkType: s next class: NBFFIConst value: 100. ! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'Igor.Stasenko 5/1/2010 12:02'! testUseStackPointer self assert: (self returnParamUsingStackPtr: 100) = 100. ! ! !NBFFICalloutTests methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 17:15'! arraySize: array ^ self nbCallout function: #(ulong (NBByteArraySize array)) emit: [:gen | "pop the array size" gen asm pop: gen asm EAX ] ! ! !NBFFICalloutTests methodsFor: 'tests' stamp: 'IgorStasenko 11/24/2012 17:16'! returnParamUsingStackPtr: aParam ^ self nbCallout options: #( + optUseStackPointer optNoAlignment - optDirectProxyFnAddress ); function: #( oop (oop aParam) ) emit: [:gen | gen asm mov: gen asm ESP ptr to: gen asm EAX ] ! ! !NBFFICalloutTests methodsFor: 'generator callbacks' stamp: 'IgorStasenko 3/27/2012 18:19'! nbBindingOf: aName ^ self class bindingOf: aName! ! !NBFFIConst commentStamp: 'Igor.Stasenko 5/3/2010 18:10'! My instances can be used to push an arbitrary integer value to the stack. Could be useful for purposes, when some of the external function values is known beforehead, like size of structure etc. For emitting a constant as argument for a function just put it into an argument list, like: apiCall: #( long 'IsBadWritePtr' (10) ) module: 'Kernel32.dll' here, 10 is a constant, which will be pushed on stack! !NBFFIConst methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/15/2010 22:33'! emitPush: gen gen asm push: ((gen asm imm: value) size: 4)! ! !NBFFIConst methodsFor: 'testing' stamp: 'Igor.Stasenko 5/3/2010 00:53'! isCallback ^ false! ! !NBFFIConst methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/15/2010 22:17'! value ^ value! ! !NBFFIConst methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/15/2010 22:17'! value: aValue value := aValue! ! !NBFFIConst methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/18/2010 23:07'! loader ^ self! ! !NBFFIConst methodsFor: 'testing' stamp: 'IgorStasenko 5/11/2011 17:27'! coercionMayFail "Constants are pushed as is, and there is no any coercion required, so it cannot fail anything" ^ false! ! !NBFFIConst methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/28/2010 13:54'! prepareArgumentUsing: gen "do nothing"! ! !NBFFIConst methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 11:46'! pointerArity: ptrArity ptrArity > 0 ifTrue: [ self error: 'passing pointer to constant' ]! ! !NBFFIConst methodsFor: 'testing' stamp: 'Igor.Stasenko 5/18/2010 23:08'! usesSTStack "Test, whether a receiver using an ST method's argument for converting it into a corresponding C value for pushing on stack " ^ false! ! !NBFFIConst methodsFor: 'accessing' stamp: 'IgorStasenko 8/2/2011 14:39'! stackSize ^ 4! ! !NBFFIConst class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 4/15/2010 22:18'! value: aValue ^ self new value: aValue! ! !NBFFIExternalStructTests methodsFor: 'tests' stamp: 'IgorStasenko 7/12/2013 15:00'! testStructAccess | struct | struct := NBTestStructure new. self assert: struct isExternal not. struct byte: 10. struct short: -20. struct long: 100. struct float: 1.0. struct double: 2.0. struct int64: 123456789101112. self assert: (struct byte = 10). self assert: (struct short = -20). self assert: (struct long = 100). self assert: (struct float = 1.0). self assert: (struct double = 2.0). self assert: (struct int64 = 123456789101112). ! ! !NBFFIExternalStructTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:42'! testReturnStruct9Bytes | s | NBNativeCodeGen removeNativeCodeFrom: self class >> #returnStruct9Bytes. s := self returnStruct9Bytes. self assert: s x = 1. self assert: s y = 2. self assert: s field asciiValue = 3.! ! !NBFFIExternalStructTests methodsFor: 'tests' stamp: 'IgorStasenko 7/12/2013 15:01'! testExternallyAllocatedStructure | struct struct2 | struct := NBTestStructure externalNew. self assert: struct isExternal. [ struct byte: 10. struct short: -20. struct long: 100. struct float: 1.0. struct double: 2.0. struct int64: 123456789101112. struct2 := NBTestStructure fromPointer: struct address. self assert: (struct2 byte = 10). self assert: (struct2 short = -20). self assert: (struct2 long = 100). self assert: (struct2 float = 1.0). self assert: (struct2 double = 2.0). self assert: (struct2 int64 = 123456789101112). ] ensure: [ struct free ].! ! !NBFFIExternalStructTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:42'! testReturnStruct1Byte | s | NBNativeCodeGen removeNativeCodeFrom: self class >> #returnStruct1Byte. s := self returnStruct1Byte. self assert: s field = 42.! ! !NBFFIExternalStructTests methodsFor: 'util' stamp: 'CamilloBruni 9/5/2013 15:09'! returnStruct1Byte ^ self nbCallout function: #(NBTestStructure1byte () ) emit: [:gen :proxy :asm | NativeBoost platformId ~= NativeBoostConstants linux32PlatformId ifTrue:[ asm mov: 42 to: asm EAX] ifFalse:[ asm mov: asm ESP ptr to: asm EAX; mov: 42 to: asm EAX ptr32] ] ! ! !NBFFIExternalStructTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:42'! testReturnStructWithCallback | s callback| NBNativeCodeGen removeNativeCodeFrom: self class >> #returnStructWithCallback:. callback := NBQSortCallback on: [:a :b | a < b]. s := self returnStructWithCallback: callback. self assert: s x = 1. self assert: s callback trunk = callback trunk. self assert: s y = 3.! ! !NBFFIExternalStructTests methodsFor: 'util' stamp: 'IgorStasenko 6/27/2013 15:54'! returnStructWithCallback: aCallback ^ self nbCallout function: #(NBTestStructureWithCallback (NBQSortCallback aCallback) ) emit: [:gen :proxy :asm | asm "mov: asm ESP ptr to: asm EAX;" pop: asm EAX; pop: asm EDX; "fill struct with 1, 2, 3 values" mov: 1 to: asm EAX ptr32; mov: asm EDX to: asm EAX ptr32+4; mov: 3 to: asm EAX ptr8+8; push: asm EAX ] ! ! !NBFFIExternalStructTests methodsFor: 'util' stamp: 'IgorStasenko 6/27/2013 15:52'! returnStruct9Bytes ^ self nbCallout function: #(NBTestStructure9bytes () ) emit: [:gen :proxy :asm | "the implicit pointer to return value should be pushed on stack , hence we just using ESP ptr" asm mov: asm ESP ptr to: asm EAX; "fill struct with 1, 2, 3 values" mov: 1 to: asm EAX ptr32; mov: 2 to: asm EAX ptr32+4; mov: 3 to: asm EAX ptr8+8 ] ! ! !NBFFIExternalStructTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:41'! testNestedStructure | s1 s2 | s1 := NBTestNestedStructure new. s2 := NBTestStructure1byte new. s2 field: 42. self assert: s1 oneByte field = 0. s1 oneByte: s2. self assert: s1 oneByte field = 42. ! ! !NBFFIExternalStructTests class methodsFor: 'accessing' stamp: 'CiprianTeodorov 5/19/2013 03:41'! resources ^{NBTestResources}! ! !NBFFIExternalUnionTests methodsFor: 'primitives' stamp: 'CiprianTeodorov 1/19/2013 18:20'! returnUnionWithStructChar: aChar ^ self nbCallout function: #(NBTestUnionWithStructure (char aChar) ) emit: [:gen :proxy :asm | asm pop: asm EAX; pop: asm EDX; "fill union with int" mov: asm DL to: asm EAX ptr8; push: asm EAX ] ! ! !NBFFIExternalUnionTests methodsFor: 'primitives' stamp: 'CiprianTeodorov 1/19/2013 18:15'! returnUnionWithStructInt: anInt ^ self nbCallout function: #(NBTestUnionWithStructure (int anInt) ) emit: [:gen :proxy :asm | asm pop: asm EAX; pop: asm EDX; "fill union with int" mov: asm EDX to: asm EAX ptr; push: asm EAX ] ! ! !NBFFIExternalUnionTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:43'! testReturnUnionWithStructChar | s | NBNativeCodeGen removeNativeCodeFrom: self class >> #returnUnionWithStructChar:. s := self returnUnionWithStructChar: $,. self assert: s x = $,! ! !NBFFIExternalUnionTests methodsFor: 'primitives' stamp: 'CiprianTeodorov 1/29/2013 19:39'! returnUnionUnionInt: aN ^ self nbCallout function: #(NBTestUnionWithUnion (int aN) ) emit: [:gen :proxy :asm | self return4Bytes: asm. ] ! ! !NBFFIExternalUnionTests methodsFor: 'primitives' stamp: 'CiprianTeodorov 1/29/2013 19:39'! return4Bytes: asm NativeBoost platformId ~= NativeBoostConstants linux32PlatformId ifTrue:[ asm pop: asm EAX] ifFalse:[ asm pop: asm EAX; pop: asm EDX; mov: asm EDX to: asm EAX ptr; push: asm EAX]! ! !NBFFIExternalUnionTests methodsFor: 'primitives' stamp: 'CiprianTeodorov 1/29/2013 19:39'! returnUnionWithCallback: aCallback ^ self nbCallout function: #(NBTestUnionWithCallback (NBQSortCallback aCallback) ) emit: [:gen :proxy :asm | self return4Bytes: asm. ] ! ! !NBFFIExternalUnionTests methodsFor: 'primitives' stamp: 'CiprianTeodorov 1/19/2013 18:51'! returnUnionWithStructStruct: aStructure ^ self nbCallout function: #(NBTestUnionWithStructure (NBTestStructure9bytes aStructure) ) emit: [:gen :proxy :asm | asm pop: asm EAX; pop: asm EDX; "fill union with structure" mov: asm EDX to: asm EAX ptr; pop: asm EDX; mov: asm EDX to: asm EAX ptr + 4; pop: asm EDX; mov: asm EDX to: asm EAX ptr + 8; push: asm EAX. ] ! ! !NBFFIExternalUnionTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:42'! testReturnUnion2Pointers | s ptr| NBNativeCodeGen removeNativeCodeFrom: self class >> #returnUnionPointer:. ptr := NBExternalAddress fromString: 'abcd'. s := self returnUnionPointer: ptr. self assert: s addr1 = ptr . self assert: s addr2 = ptr . self assert: s addr1 readString = 'abcd'.! ! !NBFFIExternalUnionTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:43'! testReturnUnionWithStructInt |s| NBNativeCodeGen removeNativeCodeFrom: self class >> #returnUnionWithStructInt:. s := self returnUnionWithStructInt: 300. self assert: s z = 300! ! !NBFFIExternalUnionTests methodsFor: 'primitives' stamp: 'CiprianTeodorov 1/29/2013 19:39'! returnUnionUnionChar: aChar ^ self nbCallout function: #(NBTestUnionWithUnion (char aChar) ) emit: [:gen :proxy :asm | self return4Bytes: asm. ] ! ! !NBFFIExternalUnionTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:42'! testReturnUnion1Byte | s | NBNativeCodeGen removeNativeCodeFrom: self class >> #returnUnion1Byte. s := self returnUnion1Byte. self assert: s field1 = 42. self assert: s field2 = 42! ! !NBFFIExternalUnionTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:44'! testReturnUnionWithStructStruct | s struct| NBNativeCodeGen removeNativeCodeFrom: self class >> #returnUnionWithStructStruct:. struct := NBTestStructure9bytes new. struct x: 2345. struct y: 6789. struct field: $+. s := self returnUnionWithStructStruct: struct. self assert: s struct x = struct x. self assert: s struct y = struct y. self assert: s struct field = struct field.! ! !NBFFIExternalUnionTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:44'! testUnionWithUnion |u1 u2| u1 := NBTestUnionWithUnion new. u2 := NBTestUnionIntSize new. u2 y: 300. self assert: u1 union x = 0. self assert: u1 union y = 0. self assert: u1 union field = Character null. u1 union: u2. self assert: u1 union x = 300. self assert: u1 union y = 300. self assert: u1 union field = $,.! ! !NBFFIExternalUnionTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:43'! testReturnUnionUnionDouble | s | NBNativeCodeGen removeNativeCodeFrom: self class >> #returnUnionUnionDouble:. s := self returnUnionUnionDouble: 2.3. self assert: (s z closeTo: 2.3)! ! !NBFFIExternalUnionTests methodsFor: 'primitives' stamp: 'IgorStasenko 12/3/2013 02:59'! returnUnion1Byte ^ self nbCallout function: #(NBTestUnion1Byte () ) emit: [:gen :proxy :asm | NativeBoost platformId ~= NativeBoostConstants linux32PlatformId ifTrue:[ asm mov: 42 to: asm EAX] ifFalse:[ asm mov: asm ESP ptr to: asm EAX; mov: 42 to: asm EAX ptr32] ] ! ! !NBFFIExternalUnionTests methodsFor: 'primitives' stamp: 'CiprianTeodorov 1/29/2013 19:34'! returnUnionUnionDouble: aN ^ self nbCallout function: #(NBTestUnionWithUnion (double aN) ) emit: [:gen :proxy :asm | NativeBoost platformId ~= NativeBoostConstants linux32PlatformId ifTrue:[ asm pop: asm EAX; pop: asm EDX.] ifFalse:[ asm pop: asm EAX; pop: asm ECX; pop: asm EDX; mov: asm ECX to: asm EAX ptr; mov: asm EDX to: asm EAX ptr + 4; push: asm EAX. ] ] ! ! !NBFFIExternalUnionTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:43'! testReturnUnionWithCallback | s callback| NBNativeCodeGen removeNativeCodeFrom: self class >> #returnUnionWithCallback:. callback := NBQSortCallback on: [:a :b | a < b]. s := self returnUnionWithCallback: callback. self assert: s callback trunk = callback trunk.! ! !NBFFIExternalUnionTests methodsFor: 'primitives' stamp: 'CiprianTeodorov 1/29/2013 19:39'! returnUnionPointer: aPointer ^ self nbCallout function: #(NBTestUnion2Pointers (void * aPointer) ) emit: [:gen :proxy :asm | self return4Bytes: asm. ] ! ! !NBFFIExternalUnionTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:43'! testReturnUnionUnionInt | s | NBNativeCodeGen removeNativeCodeFrom: self class >> #returnUnionUnionInt:. s := self returnUnionUnionInt: 2344. self assert: s union x = 2344! ! !NBFFIExternalUnionTests methodsFor: 'tests' stamp: 'CiprianTeodorov 5/19/2013 03:43'! testReturnUnionUnionChar | s | NBNativeCodeGen removeNativeCodeFrom: self class >> #returnUnionUnionChar:. s := self returnUnionUnionChar: $,. self assert: s x = $,! ! !NBFFIExternalUnionTests class methodsFor: 'accessing' stamp: 'CiprianTeodorov 5/19/2013 03:44'! resources ^{NBTestResources}! ! !NBFFIExternalValueTests methodsFor: 'tests' stamp: 'IgorStasenko 6/27/2013 17:33'! testOutIntArg |x value| NBTestExternalValue initialize. value := 12345678. x := NBTestExternalValue new. self outputIntArg: x value: value. self assert: x value = value.! ! !NBFFIExternalValueTests methodsFor: 'primitives' stamp: 'IgorStasenko 6/27/2013 17:14'! outputValueArg: x value: value ^ self nbCallout function: #(void (NBTestExternalValue * x, int value) ) emit: [:gen :proxy :asm | asm pop: asm EAX. asm pop: asm ECX. asm mov: asm ECX to: asm EAX ptr32. ] ! ! !NBFFIExternalValueTests methodsFor: 'tests' stamp: 'CiprianTeodorov 4/9/2013 21:11'! testValue |x value| NBTestExternalValue initialize. value := 12345678. x := NBTestExternalValue new. x value: value. self assert: x value = value.! ! !NBFFIExternalValueTests methodsFor: 'primitives' stamp: 'IgorStasenko 6/27/2013 17:33'! outputVoidArg: x value: value ^ self nbCallout function: #(void (void * x, int value) ) emit: [:gen :proxy :asm | asm pop: asm EAX. asm pop: asm ECX. asm mov: asm ECX to: asm EAX ptr32. ] ! ! !NBFFIExternalValueTests methodsFor: 'primitives' stamp: 'CiprianTeodorov 4/9/2013 21:22'! outputIntArg: x value: value ^ self nbCallout function: #(void (int* x, int value) ) emit: [:gen :proxy :asm | asm pop: asm EAX. asm pop: asm ECX. asm mov: asm ECX to: asm EAX ptr32. ] ! ! !NBFFIExternalValueTests methodsFor: 'tests' stamp: 'IgorStasenko 6/27/2013 17:32'! testOutVoidArg |x value| NBTestExternalValue initialize. value := 12345678. x := NBTestExternalValue new. self outputVoidArg: x value: value. self assert: x value = value.! ! !NBFFIExternalValueTests methodsFor: 'tests' stamp: 'IgorStasenko 6/27/2013 17:33'! testOutValueArg |x value| NBTestExternalValue initialize. value := 12345678. x := NBTestExternalValue new. self outputValueArg: x value: value. self assert: x value = value.! ! !NBFFIExternalValueTests methodsFor: 'tests' stamp: 'IgorStasenko 6/27/2013 17:38'! testOutIntoByteArray |x value| NBTestExternalValue initialize. value := 12345678. x := ByteArray new: 4. self outputVoidArg: x value: value. self assert: (x nbUInt32AtOffset: 0) = value.! ! !NBFinalizationRegistry commentStamp: ''! i am a simplified implementation of WeakRegistry, and have same public protocol. The implementation is simpler and faster, because i rely on new finalization support in VM. ! !NBFinalizationRegistry methodsFor: 'for tests only' stamp: 'IgorStasenko 5/31/2012 14:44'! freeItemsDo: aBlock | free index | sema critical: [ index := nextFreeIndex. [ index notNil ] whileTrue: [ |next item| item := items at: index. next := item nextFreeIndex. aBlock value: item. index := next ]]! ! !NBFinalizationRegistry methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 02:56'! initialSize ^ 100! ! !NBFinalizationRegistry methodsFor: 'private' stamp: 'IgorStasenko 5/31/2012 03:55'! grow "double the items array size" | oldSz | oldSz := items size. items := items grownBy: oldSz. self formatItems: oldSz+1 ! ! !NBFinalizationRegistry methodsFor: 'private' stamp: 'IgorStasenko 5/31/2012 03:58'! getFreeItem | item nextFree | nextFreeIndex ifNil: [ self grow ]. item := items at: nextFreeIndex. nextFreeIndex := item nextFreeIndex. ^ item! ! !NBFinalizationRegistry methodsFor: 'initialization' stamp: 'IgorStasenko 5/31/2012 14:51'! initialize super initialize. sema := Semaphore forMutualExclusion. self reset. WeakArray addWeakDependent: self! ! !NBFinalizationRegistry methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 02:59'! add: anObject ^ self add: anObject executor: anObject executor! ! !NBFinalizationRegistry methodsFor: 'finalizing' stamp: 'IgorStasenko 8/24/2012 17:17'! finalizeValues "Finalize any values, which happen to be stocked in finalization list, due to some weak references become garbage" sema critical: [ | item next | item := list swapWithNil. [ item notNil ] whileTrue: [ next := item next. [ item finalizeValues ] on: Exception fork: [:ex | ex pass ]. item markAsFree: nextFreeIndex. nextFreeIndex := item index. item := next. ] ]. ! ! !NBFinalizationRegistry methodsFor: 'private' stamp: 'IgorStasenko 5/31/2012 14:24'! reset sema critical: [ nextFreeIndex := nil. list := WeakFinalizationList new. items := Array new: self initialSize. self formatItems: 1. ] ! ! !NBFinalizationRegistry methodsFor: 'private' stamp: 'IgorStasenko 5/31/2012 03:57'! formatItems: startingIndex startingIndex to: items size do: [:i | | item | item := NBWeakFinalizerItem new list: list index: i freeIndex: nextFreeIndex. items at: i put: item. nextFreeIndex := i. ].! ! !NBFinalizationRegistry methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 14:55'! add: anObject executor: executor | item | "fool protection" anObject ifNil: [ self error: 'nil cannot be finalized!!!!']. sema critical: [ item := self getFreeItem. item object: anObject executor: executor ]. ^ item! ! !NBFinalizationRegistry methodsFor: 'for tests only' stamp: 'IgorStasenko 5/31/2012 14:41'! items ^ items! ! !NBFloat128 methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 15:53'! valueSize ^ 16! ! !NBFloat16 commentStamp: ''! not supported on x86 archs.. ! !NBFloat16 methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 15:53'! valueSize ^ 2! ! !NBFloat32 methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/28/2010 14:43'! coerceReturnValue: gen "return value in ST(0)" NBFloat64 new pushValue: gen. gen proxy gatedCallFn: #floatObjectOf: . ! ! !NBFloat32 methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/28/2010 18:32'! loadMem: memoryOperand generator: gen. "floats get loaded into FP stack" gen asm fld: memoryOperand. ! ! !NBFloat32 methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 15:52'! valueSize ^ 4! ! !NBFloat32 methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/20/2010 04:06'! pushAsValue: gen gen proxy pushFloatOopAsFloat32: (loader emitLoad: gen). ! ! !NBFloat64 methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 15:52'! valueSize ^ 8! ! !NBFloat64 methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 14:01'! stackSize "Answer a number of bytes, which takes a value of given type when pushed on stack" pointerArity > 0 ifTrue: [ ^ self pointerSize ]. ^ 8! ! !NBFloat64 methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/2/2010 20:41'! pushValue: gen "argument in ST(0) " | asm | asm := gen asm. asm sub: (asm ESP) with: 8. asm fstp: asm ESP ptr64 ! ! !NBFloat64 methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/28/2010 18:32'! loadMem: memoryOperand generator: gen. "floats get loaded into FP stack" gen asm fld: memoryOperand. ! ! !NBFloat64 methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/28/2010 14:43'! coerceReturnValue: gen "return value in ST(0)" self pushValue: gen. gen proxy gatedCallFn: #floatObjectOf: . ! ! !NBFloat64 methodsFor: 'emitting code' stamp: 'JavierPimas 11/17/2011 11:04'! pushAsValue: gen | proxy asm oop EAX | proxy := gen proxy. asm := gen asm. EAX := asm EAX. oop := loader emitLoad: gen. asm mov: oop to: EAX. proxy oop: EAX ifSmallInt: [ asm sar: EAX with: 1; push: EAX; push: EAX; " extra push to reserve totally 8 bytes on stack" fild: asm ESP ptr32; fstp: asm ESP ptr64 ] ifNotSmallInt: [ proxy pushFloatOopAsFloat64: EAX. ].! ! !NBFloatPtr commentStamp: 'IgorStasenko 12/21/2011 13:43'! Use to pass a pointer to instance of Float, which is C (double *) equivalent. Can be used for functions which may modify the floating-point values at specified memory pointer. NOTE: always copy float objects before passing them to such callouts.! !NBFloatPtr methodsFor: 'emitting code' stamp: 'IgorStasenko 12/21/2011 13:40'! pushAsPointer: gen self error: 'only value-type arguments allowed'! ! !NBFloatPtr methodsFor: 'accessing' stamp: 'IgorStasenko 12/21/2011 13:40'! valueSize ^ self pointerSize! ! !NBFloatPtr methodsFor: 'emitting code' stamp: 'IgorStasenko 12/21/2011 14:26'! pushAsValue: gen "argument in ST(0) " | proxy oop asm | proxy := gen proxy. asm := gen asm. oop := loader emitLoad: gen. proxy verifyCompactClassOf: oop is: Float. asm add: asm EAX with: proxy baseHeaderSize; push: asm EAX. ! ! !NBFloatType commentStamp: 'Igor.Stasenko 4/28/2010 11:54'! Abstract class for floating-point native types! !NBFnArgument commentStamp: 'Igor.Stasenko 4/30/2010 12:12'! I am abstract class, describing a function argument. My subclasses should know what code to emit in order to load an argument. ! !NBFnArgument methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/30/2010 10:46'! emitLoad: gen "emit instructions to load a function argument into default register (EAX for integral types, FP(0) for floating point)" self subclassResponsibility ! ! !NBFnArgument methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/30/2010 12:21'! emitLoad: gen to: operand "emit instructions to load a function argument into given operand" self subclassResponsibility ! ! !NBFnArgument methodsFor: 'testing' stamp: 'IgorStasenko 8/5/2011 18:02'! isReceiver "answer true if loader loads a primitive method's receiver " ^ false! ! !NBFnArgument methodsFor: 'testing' stamp: 'Igor.Stasenko 5/18/2010 02:21'! usesSTStack ^ false! ! !NBFnSpec commentStamp: 'IgorStasenko 2/15/2012 19:46'! I am used to hold a parsed function signature, describing a C function. Since all C functions having return type, arguments and name (unless it anonymous one), same structure can be used to hold an information about it in my instances. However, what objects used to represent types and arguments is up to code generator. Instance Variables: returnType functionName arguments ! !NBFnSpec methodsFor: 'adding' stamp: 'IgorStasenko 8/21/2011 02:49'! addArgument: anArgument ^ arguments add: anArgument! ! !NBFnSpec methodsFor: 'converting' stamp: 'IgorStasenko 8/19/2011 18:39'! printType: typeAndArity on: str str nextPutAll: typeAndArity first. typeAndArity second timesRepeat: [ str nextPut: $* ]. ! ! !NBFnSpec methodsFor: 'converting' stamp: 'cipt 10/21/2012 19:33'! asArraySpecArrayedArgs ^ String streamContents: [:str | |idx| str nextPutAll: '#( '. self printType: returnType on: str. str space. functionName ifNotNil: [ str nextPutAll: functionName; space ]. str nextPutAll: '( '. idx := 1. arguments do: [:arg | str nextPutAll: arg second. "type name" arg third timesRepeat: [ str nextPut: $* ]. str space; nextPutAll: 'argsArray@', idx printString; space. idx := idx + 1. ] separatedBy: [ str nextPutAll: ', ' ]. str nextPutAll: '))'. ]! ! !NBFnSpec methodsFor: 'accessing' stamp: 'IgorStasenko 8/19/2011 17:44'! arguments: anObject arguments := anObject! ! !NBFnSpec methodsFor: 'converting' stamp: 'IgorStasenko 8/19/2011 19:01'! asMethodSelectorAndArguments ^ String streamContents: [:str | str nextPutAll: functionName. arguments isEmpty ifFalse: [ arguments size = 1 ifFalse: [ str nextPut: $_; nextPutAll: arguments first first. ]. str nextPut: $: ; space; nextPutAll: arguments first first. arguments allButFirst do: [:arg | str space; nextPutAll: arg first; nextPut: $: ; space; nextPutAll: arg first ] ] ]! ! !NBFnSpec methodsFor: 'accessing' stamp: 'IgorStasenko 8/19/2011 17:44'! functionName ^ functionName! ! !NBFnSpec methodsFor: 'initialization' stamp: 'IgorStasenko 8/19/2011 17:53'! initialize arguments := OrderedCollection new! ! !NBFnSpec methodsFor: 'converting' stamp: 'cipt 10/21/2012 19:38'! asMethodSelectorAndArrayOfArguments ^ String streamContents: [ :str | str nextPutAll: functionName; nextPutAll: ': argsArray'; cr; nextPut: $". arguments do: [ :arg | str nextPutAll: arg first ] separatedBy: [ str nextPutAll: ', ' ]. str nextPut: $" ]! ! !NBFnSpec methodsFor: 'accessing' stamp: 'IgorStasenko 8/19/2011 17:44'! returnType: anObject returnType := anObject! ! !NBFnSpec methodsFor: 'converting' stamp: 'IgorStasenko 8/21/2011 11:35'! asArraySpec ^ String streamContents: [:str | str nextPutAll: '#( '. self printType: returnType on: str. str space. functionName ifNotNil: [ str nextPutAll: functionName; space ]. str nextPutAll: '( '. arguments do: [:arg | str nextPutAll: arg second. "type name" arg third timesRepeat: [ str nextPut: $* ]. str space; nextPutAll: arg first; space ] separatedBy: [ str nextPutAll: ', ' ]. str nextPutAll: '))'. ]! ! !NBFnSpec methodsFor: 'accessing' stamp: 'IgorStasenko 8/19/2011 17:44'! arguments ^ arguments! ! !NBFnSpec methodsFor: 'accessing' stamp: 'IgorStasenko 8/19/2011 17:44'! functionName: anObject functionName := anObject! ! !NBFnSpec methodsFor: 'accessing' stamp: 'IgorStasenko 8/19/2011 17:44'! returnType ^ returnType! ! !NBFnSpec class methodsFor: 'instance creation' stamp: 'IgorStasenko 8/21/2011 11:07'! namedFunctionFrom: anArrayWithDefinition "Create an instance of receiver by parsing an array in a form like C function definition: #( void foo (int * x, float y ) ) " ^ NBFnSpecParser new parseNamedFunction: anArrayWithDefinition ! ! !NBFnSpecParser methodsFor: 'parsing' stamp: 'IgorStasenko 12/18/2011 19:28'! parseArguments " Parse a arguments spec in a form of: #( type1 name1 , type2 name2 , nil, true, false , 100 ) " [ stream atEnd ] whileFalse: [ self parseArgument ifNotNil: [:arg | fnSpec addArgument: arg]. self skipSpace. stream atEnd ifFalse: [ stream peek = $, ifFalse: [ self error: 'comma expected' ]. stream next. self skipSpace. ] ].! ! !NBFnSpecParser methodsFor: 'public interface' stamp: 'IgorStasenko 2/9/2012 12:47'! parseNamedFunction: aFunctionDefinition " Parse a function definition in a form of: #( returnType functionName (arguments) ) or 'returnType functionName (arguments)' Answer an instance of NBFnSpec class " | argsSpec typeAndName fnName | fnSpec := NBFnSpec new. aFunctionDefinition isString ifTrue: [ typeAndName := (aFunctionDefinition copyUpTo: $( ) trimBoth. argsSpec := ((aFunctionDefinition copyAfter: $( ) copyUpTo: $)) trimBoth. ] ifFalse: [ argsSpec := aFunctionDefinition last gather: [:ea | ea asString, ' ' ]. typeAndName := aFunctionDefinition allButLast gather: [:ea | ea asString, ' ' ]. ]. stream := typeAndName readStream. fnSpec returnType: (requestor returnType: self parseType). fnName := self parseWord. fnName ifNil: [ self error: 'function name expected' ]. fnSpec functionName: fnName. stream := argsSpec readStream. self parseArguments. ^ fnSpec! ! !NBFnSpecParser methodsFor: 'parsing' stamp: 'IgorStasenko 8/19/2011 17:59'! parseType " parse type name and optional number of asterisks, following it" | typeName ptrArity | typeName := self parseWord. typeName isNil ifTrue: [ ^ self error: 'type name expected' ]. "skip 'const' , which is often used but has no any use for us " typeName = 'const' ifTrue: [ self skipSpace. typeName := self parseWord. typeName isNil ifTrue: [ ^ self error: 'type name expected' ]. ]. ptrArity := 0. [ self skipSpace. stream peek = $* ] whileTrue: [ ptrArity := ptrArity + 1. stream next ]. ^ Array with: typeName with: ptrArity ! ! !NBFnSpecParser methodsFor: 'parsing' stamp: 'cipt 10/26/2012 19:21'! parseArgument | argName indirectIndex typeAndPtrArity char | " An argument can be: - nil , true , false - a class/pool variable name - integer literal - self , with optional ** - type name *** arg name " char := stream peek. (char isDigit or: [ char = $- ]) ifTrue: [ ^ requestor integerConstantArgument: self parseInt ]. typeAndPtrArity := self parseType. self skipSpace. argName := self parseWord. self skipSpace. char := stream peek. char = $@ ifTrue: [ stream next. self skipSpace. argName := argName. indirectIndex := self parseInt ]. "for sole 'void' fake argument " (typeAndPtrArity = #('void' 0) and: [ argName isNil ]) ifTrue: [ ^ nil ]. ^ requestor argName: argName indirectIndex: indirectIndex type: typeAndPtrArity first ptrArity: typeAndPtrArity second ! ! !NBFnSpecParser methodsFor: 'parsing' stamp: 'Igor.Stasenko 4/30/2010 06:03'! parseInt | negate num | negate := false. stream peek = $- ifTrue: [ negate := true. stream next. self skipSpace ]. num := String new writeStream. [ stream atEnd not and: [stream peek isDigit ] ] whileTrue: [ num nextPut: stream next ]. num := num contents asInteger. negate ifTrue: [ num := num negated ]. ^ num! ! !NBFnSpecParser methodsFor: 'public interface' stamp: 'IgorStasenko 2/9/2012 12:42'! parseAnonFunction: aFunctionDefinition " Parse a function definition in a form of: #( returnType (arguments) ) or 'returnType (arguments)' Answer an instance of NBFnSpec class " | argsSpec retType | fnSpec := NBFnSpec new. aFunctionDefinition isString ifTrue: [ retType := (aFunctionDefinition copyUpTo: $( ) trimBoth. argsSpec := ((aFunctionDefinition copyAfter: $( ) copyUpTo: $)) trimBoth. ] ifFalse: [ argsSpec := aFunctionDefinition last gather: [:ea | ea asString, ' ' ]. retType := aFunctionDefinition allButLast gather: [:ea | ea asString, ' ' ]. ]. stream := retType readStream. fnSpec returnType: (requestor returnType: self parseType). stream atEnd ifFalse: [ self error: 'Nothing more expected after function type']. stream := argsSpec readStream. self parseArguments. ^ fnSpec! ! !NBFnSpecParser methodsFor: 'initialization' stamp: 'IgorStasenko 8/21/2011 02:50'! initialize requestor := self. ! ! !NBFnSpecParser methodsFor: 'requestor callbacks' stamp: 'cipt 10/24/2012 20:19'! argName: aName indirectIndex: anIndex type: aTypeName ptrArity: arity ^ { aName. anIndex. aTypeName. arity }! ! !NBFnSpecParser methodsFor: 'requestor callbacks' stamp: 'IgorStasenko 8/21/2011 10:55'! returnType: aType ^ aType! ! !NBFnSpecParser methodsFor: 'requestor callbacks' stamp: 'IgorStasenko 8/21/2011 10:57'! integerConstantArgument: aValue ^ aValue! ! !NBFnSpecParser methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 05:31'! requestor: aRequestor requestor := aRequestor.! ! !NBFnSpecParser methodsFor: 'parsing' stamp: 'IgorStasenko 6/1/2012 18:37'! parseWord ^ String streamContents: [:st | | ch | "first char must be letter or underscore" ch := stream peek. (ch notNil and: [ ch isLetter or: [ '_$' includes: ch ]]) ifFalse: [ ^ nil ]. [ ch := stream peek. ch notNil and: [ch isLetter or: [ ('_$' includes: ch) or: [ch isDigit] ] ] ] whileTrue: [ st nextPut: stream next]. ] ! ! !NBFnSpecParser methodsFor: 'parsing' stamp: 'cipt 10/21/2012 01:27'! skipSpace | ch | [ ch := stream peek. ch ifNil: [ ^ self ]. ch isSeparator ] whileTrue: [ stream next ]! ! !NBFnSpecParserTest methodsFor: 'accessing' stamp: 'cipt 10/26/2012 19:19'! argName: argName indirectIndex: anIndex type: typeName ptrArity: ptrArity ^ #argument! ! !NBFnSpecParserTest methodsFor: 'tests' stamp: 'cipt 10/26/2012 19:30'! testParseAnonFn | parser args | #( #(int * * ( 0, nil, -10, FOO_BAR , int a, int* _b, char** c, void* * * d_)) 'int * * ( 0, nil, -10, FOO_BAR , int a, int* _b, char** c, void* * * d_)' ) do: [:spec | parser := self newParser parseAnonFunction: spec. self assert: parser returnType = #('int' 2). args := parser arguments. self assert: args size = 8. self assert: (args at: 1) = 0. self assert: (args at: 2) = #(nil nil 'nil' 0). self assert: (args at: 3) = -10. self assert: (args at: 4) = #(nil nil 'FOO_BAR' 0). self assert: (args at: 5) = #('a' nil 'int' 0). self assert: (args at: 6) = #('_b' nil 'int' 1). self assert: (args at: 7) = #('c' nil 'char' 2). self assert: (args at: 8) = #('d_' nil 'void' 3 ). ]! ! !NBFnSpecParserTest methodsFor: 'tests' stamp: 'cipt 10/26/2012 19:30'! testParseNamedFn | parser args | #( (int * * #'function_n$a$m$e' ( 0, nil, -10, FOO_BAR , int a, int* _b, char** c, void* * * d_)) ' int * * function_n$a$m$e (0, nil, -10, FOO_BAR , int a, int* _b, char** c, void* * * d_ ' ) do: [:spec | parser := self newParser parseNamedFunction: spec. self assert: parser functionName = 'function_n$a$m$e'. self assert: parser returnType = #('int' 2). args := parser arguments. self assert: args size = 8. self assert: (args at: 1) = 0. self assert: (args at: 2) = #(nil nil 'nil' 0). self assert: (args at: 3) = -10. self assert: (args at: 4) = #(nil nil 'FOO_BAR' 0). self assert: (args at: 5) = #('a' nil 'int' 0). self assert: (args at: 6) = #('_b' nil 'int' 1). self assert: (args at: 7) = #('c' nil 'char' 2). self assert: (args at: 8) = #('d_' nil 'void' 3 ). ]. ! ! !NBFnSpecParserTest methodsFor: 'parser' stamp: 'IgorStasenko 2/13/2012 13:01'! newParser ^ NBFnSpecParser new! ! !NBFnSpecParserTest methodsFor: 'callbacks' stamp: 'IgorStasenko 2/13/2012 13:04'! returnType: aType ^ #returnType! ! !NBFnSpecParserTest methodsFor: 'tests' stamp: 'IgorStasenko 2/13/2012 13:16'! testParserCallbacks | parser spec parsedSpec args | parser := self newParser requestor: self. spec := #(int * * function_name ( 0, nil, -10, FOO_BAR , int a, int* _b, char** c, void* * * d_)). parsedSpec := parser parseNamedFunction: spec. self assert: parsedSpec returnType equals: #returnType. args := parsedSpec arguments. self assert: args first = #integerConstant. self assert: args third = #integerConstant. args := args reject: [:each | each = #integerConstant ]. self assert: args size = 6. self assert: args asSet size = 1. self assert: args first = #argument! ! !NBFnSpecParserTest methodsFor: 'callbacks' stamp: 'IgorStasenko 2/13/2012 13:03'! integerConstantArgument: int ^ #integerConstant! ! !NBFnSpecParserTest methodsFor: 'tests' stamp: 'IgorStasenko 2/9/2012 12:44'! testParseNoArgsFn | parser args | #( #(int * * function_name ( void ) ) ' int * * function_name ( void ) ' ) do: [:spec | parser := self newParser parseNamedFunction: spec. self assert: parser functionName = 'function_name'. self assert: parser returnType = #('int' 2). args := parser arguments. self assert: args size = 0. ]! ! !NBInt16 commentStamp: ''! I responsible for marshalling signed 16-bit integer type values.! !NBInt16 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:14'! coerceReturnValue: gen | asm | "convert signed short to ST integer" asm := gen asm. asm movsx: asm EAX with: asm AX. gen proxy integerObjectOf: asm EAX. ! ! !NBInt16 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:14'! pushAsValue: gen gen asm push: (gen proxy integerValueOf: (loader emitLoad: gen))! ! !NBInt32 commentStamp: ''! I responsible for marshalling signed 32-bit integer type values.! !NBInt32 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:17'! coerceOopToOperand: gen ifFailedJumpTo: aLabel " input: EAX - oop output: EAX - result of coercion " self assert: (pointerArity = 0). gen proxy signed32BitValueOf: gen asm EAX! ! !NBInt32 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:17'! coerceReturnValue: gen "convert int32 to ST integer" gen proxy signed32BitIntegerFor: (gen returnValueRegister). ! ! !NBInt32 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:17'! pushAsValue: gen gen asm push: (gen proxy signed32BitValueOf: (loader emitLoad: gen) )! ! !NBInt64 commentStamp: ''! I responsible for marshalling signed 64-bit integer type values.! !NBInt64 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/3/2012 00:55'! coerceReturnValue: gen "convert 64-bit unsigned value in EAX:EDX to ST integer" gen proxy signed64BitIntegerFor ! ! !NBInt64 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/3/2012 00:24'! pushAsValue: gen | asm | asm := gen asm. gen proxy signed64BitValueOf: (loader emitLoad: gen). asm push: asm EDX; push: asm EAX. gen optCheckFailOnEveryArgument ifTrue: [ gen proxy ifFailedEmit: [ gen failWithMessage: 'Argument coercion failed: signed 64-bit integer value expected' ]. ].! ! !NBInt8 commentStamp: ''! I responsible for marshalling signed 8-bit integer type values.! !NBInt8 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:12'! coerceReturnValue: gen | asm | "convert signed byte to ST integer" asm := gen asm. asm movsx: asm EAX with: asm AL. gen proxy integerObjectOf: asm EAX. ! ! !NBInt8 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:12'! pushAsValue: gen "should we truncate it to 8bit value here?" gen asm push: (gen proxy integerValueOf: (loader emitLoad: gen) ) ! ! !NBIntegerExternalType commentStamp: 'Igor.Stasenko 4/28/2010 11:53'! Abstract class for all integer external types! !NBInterpreterProxy commentStamp: ''! I am an important part of a native code generation toolchain, which provides an access to all interpreterProxy functions. A native code, inevitably, needs to convert a method's arguments to their native representations, and access a different fields of oops. For this, we need to use interpreter proxy methods. Code generator options, used by proxy: #optNonMovable - The code is a standalone routine, which a) will be placed into a non-movable memory region. b) can be called by any other function, not by primitiveNativeCall, therefore #optDirectProxyFnAddress - call proxy functions directly, instead of loading their address indirectly via interpreterProxy struct #optUseStackPointer - use a direct ST stack pointer, initially retrieved using #getStackPointer ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! disownVM: flags self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'call' stamp: 'CamilloBruni 7/19/2012 12:04'! callFn: aFunctionOrName | fn | fn := aFunctionOrName. aFunctionOrName isString ifTrue: [ fn := self functions at: aFunctionOrName ]. fn checkVersion. gen optProxyLabels ifTrue: [ asm label: (asm uniqueLabelName: fn name). ]. self canUseDirectProxyFnAddress ifTrue: [ asm mov: (fn address asUImm32 annotation: fn name ) to: EAX; call: EAX ] ifFalse: [ asm mov: (self class interpreterProxyAddress asUImm32 annotation: 'interpreterProxy address') to: EAX; mov: ((EAX ptr + (fn index * self pointerSize)) annotation: fn name) to: EAX; call: EAX ] ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:52'! slotSizeOf: oop "Returns the number of slots in the receiver. If the receiver is a byte object, return the number of bytes. Otherwise return the number of words." ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:04'! pushFloat: f "not recommended for use in native code" self shouldNotUse ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:40'! classExternalFunction ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:03'! checkedIntegerValueOf: oop "convert smallinteger into integer value. fails if oop is not a smallinteger" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:40'! sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr "Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf: to Alien class with the supplied args. The arguments are raw C addresses and are converted to integer objects on the way." "useless without Alien... " ^ self gatedCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:03'! copyBitsFrom: x0 to: x1 at: y "This entry point needs to be implemented for the interpreter proxy. Since BitBlt is now a plugin we need to look up BitBltPlugin:=copyBitsFrom:to:at: and call it. This entire mechanism should eventually go away and be replaced with a dynamic lookup from BitBltPlugin itself but for backward compatibility this stub is provided" self shouldNotUse ! ! !NBInterpreterProxy methodsFor: 'initialization' stamp: 'CamilloBruni 8/3/2012 18:24'! initialize "actually, this should be determined by querying NativeBoost platformId" objectFormat := NBObjectFormat32 new. "set it to nil, if there is recursion" stackPtrAddress := [self class stackPointerAddress] on: NBCodeGenRecursion do: [ nil ]. framePtrAddress := [self class framePointerAddress] on: NBCodeGenRecursion do: [ nil ]. cStackPtrAddress := [self class cStackPointerAddress] on: NBCodeGenRecursion do: [ nil ]. cFramePtrAddress := [self class cFramePointerAddress] on: NBCodeGenRecursion do: [ nil ].! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 9/3/2012 00:23'! positive64BitValueOf: oop ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! setInterruptCheckChain: aFunctionAddr self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 14:57'! failed ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy objects' stamp: 'CamilloBruni 7/23/2012 18:03'! specialSelectorAt: index "generate the code to load the symbol at the given index from specialObjectsArray at: 23" "since we cannot directly access the specialObjectsArray we store it as an extra Root" NativeBoost extraRootsRegistry at: #specialSelectorsArray ifAbsentPut: [ Smalltalk specialSelectors ]; "specialSelectorsArray -> EAX" emitOopAt: #specialSelectorsArray generator: gen. "EAX at: index" self stObject: asm EAX at: index.! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'IgorStasenko 5/28/2012 06:32'! stackPointer (self canUseStackPointer not or: [stackPtrAddress isNil]) ifTrue: [ self error: 'cannot use stack pointer directly' ]. "answer a memory operand " ^ stackPtrAddress asUImm32 ptr32! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:49'! getThisSessionID ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 09:33'! isBytes: oop ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/30/2010 20:29'! classUnsafeAlien ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy objects' stamp: 'Igor.Stasenko 4/11/2010 16:15'! characterTable "return a character table special object (array of 256 characters)" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'CamilloBruni 8/3/2012 17:19'! framePointer (self canUseStackPointer not or: [framePtrAddress isNil]) ifTrue: [ self error: 'cannot use frame pointer directly' ]. "answer a memory operand " ^ framePtrAddress asUImm32 ptr32! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 15:58'! is: oop KindOf: stringPtr "char *" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'testing' stamp: 'IgorStasenko 8/3/2011 05:56'! usedGate ^ usedGate == true! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:15'! classArray ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/20/2010 06:02'! isBytesOrWords: oop ifNotJumpTo: label ^ objectFormat isBytesOrWords: oop ifNotJumpTo: label! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:03'! pop: nItems "not recommended for use in native code. use #stackValue: " self shouldNotUse ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:36'! superclassOf: classPointer ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:37'! firstFixedField: oop "Answer an address of first fixed field for given oop" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:04'! signed64BitIntegerFor: op "use #signed64BitIntegerFor instead" self shouldNotUse.! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'IgorStasenko 8/7/2011 04:24'! ifFailedEmit: aBlock | lbl | lbl := asm uniqueLabelName: 'notFailed'. self failed. asm or: EAX with: EAX. asm jz: lbl. aBlock value. asm label: lbl! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:53'! stObject: obj at: index put: value "Do what ST would return for at: index put: value." ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classPoint ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 15:59'! isIntegerObject: oop " return true (1) only if oop is smallInteger (not big integer or any other object !!!!) " ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 9/29/2010 11:04'! pushFloatOopAsFloat64: oop " input - oop , and operand, pointing to a Oop output: 32-bit floating-point value pushed on stack clobbers: EAX, ECX" Smalltalk compactClassesArray indexOf: Float ifAbsent: [ "if Float is not compact class, do the hard way " self floatValueOf: oop. asm sub: (asm ESP) with: 8. asm fstp: asm ESP ptr64. ^ self. ]. self verifyCompactClassOf: oop is: Float. objectFormat floatsMatchingPlatform ifFalse: [ asm push: EAX ptr + (self baseHeaderSize); push: EAX ptr + (self baseHeaderSize+4) ] ifTrue: [ asm push: EAX ptr + (self baseHeaderSize+4); push: EAX ptr + (self baseHeaderSize) ] ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/3/2010 14:28'! createInstanceOf: aClass size: indexableSize ^ self instantiateClass: [ gen emitFetchClass: aClass ] indexableSize: indexableSize! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! primitiveFailFor: errorCode ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'VM-extras' stamp: 'Igor.Stasenko 5/14/2010 03:48'! swapActiveContext: newContext "call the 'swapActiveContext' VM function " | fn | fn := NativeBoost loadFunction: 'swapActiveContext' from: ''. self assert: (fn ~= 0). asm push: newContext. asm mov: fn asUImm to: EAX. asm call: EAX; add: ESP with: 4. ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:54'! stSizeOf: obj "Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for size)." "Note: Assume oop is not a SmallInteger!!" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:20'! pushRemappableOop: oop "Record the given object in a the remap buffer. Objects in this buffer are remapped when a compaction occurs. This facility is used by the interpreter to ensure that objects in temporary variables are properly remapped." ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy-stack access' stamp: 'Igor.Stasenko 4/30/2010 20:16'! stackFloatValue: offset "answer a float value of oop on stack at given offset value. Note, return value is loaded in FP register, not GP register" self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! integerArg: index self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:34'! showDisplayBits: aForm Left: l Top: t Right: r Bottom: b "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object." "any reason to use it here?" self shouldBeImplemented! ! !NBInterpreterProxy methodsFor: 'proxy objects' stamp: 'Igor.Stasenko 4/11/2010 16:15'! nilObject ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:35'! reestablishContextPriorToCallback: callbackContext "callbackContext is an activation of invokeCallback:stack:registers:jmpbuf:. Its sender is the interpreter's state prior to the callback. Reestablish that state." "WARNING!!!! do not use any proxy functions, which may access the ST stack after calling this function, because its changing the active context and method, stack etc. Use at your own risk" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:31'! fetchClassOf: oop "Fetch the class of given oop" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:29'! removeGCRoot: addr ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:39'! literal: index ofMethod: methodOop "Answer a method's literal at given zero-based index" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:28'! internalIsImmutable: oop ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 9/3/2012 00:56'! positive64BitIntegerFor "Assume integer value is in EAX:EDX register pair. Make a call as if we push 2 arguments " | fn | fn := self functions at: #positive64BitIntegerFor: . ^ self call: fn arguments: { asm EAX. asm EDX }! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:40'! classExternalData ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:40'! primitiveMethod ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 9/3/2012 00:54'! signed64BitIntegerFor "Assume integer value is in EAX:EDX register pair. Make a call as if we push 2 arguments " | fn | fn := self functions at: #signed64BitIntegerFor: . ^ self call: fn arguments: { asm EAX. asm EDX }! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:53'! stObject: obj at: index "Return what ST would return for at: index." ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'IgorStasenko 5/26/2012 15:16'! varBytesFirstFieldOf: oop "Answer the address of first byte in oop in EAX. oop must be of a variable byte format" asm mov: oop to: asm EAX; add: asm EAX with: objectFormat varBytesFirstField ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:32'! primitiveFail "Fail a primitive." ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'HenrikSperreJohansen 8/25/2011 13:22'! receiverInto: aReg "Input: aReg. Output: aReg - register holding method's receiver" ^self stackValue: self methodArgumentCount storeIn: aReg. ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:40'! classExternalLibrary ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:17'! clone: oop "Return a shallow copy of the given object. May cause GC" "Assume: Oop is a real object, not a small integer." ^ self gatedCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:15'! classBitmap ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'testing' stamp: 'IgorStasenko 5/28/2012 05:25'! canUseStackPointer gen optUseStackPointer ifFalse: [ ^ false ]. ^ stackPtrAddress notNil ! ! !NBInterpreterProxy methodsFor: 'call' stamp: 'CamilloBruni 7/23/2012 13:29'! callGated: aFunction arguments: args "Call an interpreter proxy function through special gate function, ensuring that if it triggers GC and native code could be relocated, then gate will return to correct native code address after relocation" | align | asm decorateWith: 'InterpreterProxy >> ' , aFunction name during: [ align := gen stackAlignment. aFunction requiresAlignment ifFalse: [ align := 1 ]. asm cdeclCall: [ :call | args reverseDo: [:arg | call push: arg value ]. self gatedCallFn: aFunction. ] alignment: align ]. ^ EAX! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 9/29/2010 11:03'! pushFloatOopAsFloat32: oop " input - oop , and operand, pointing to a Oop output: 32-bit floating-point value pushed on stack clobbers: EAX, ECX" Smalltalk compactClassesArray indexOf: Float ifAbsent: [ "if Float is not compact class, do the hard way " self floatValueOf: oop. asm sub: (asm ESP) with: 4. asm fstp: asm ESP ptr32. ^ self. ]. "since Float is a compact, to check that object is instance of float, we just need to make sure that its header matching the Float's header format" "Floating point value is stored in PowerPC word order" self verifyCompactClassOf: oop is: Float. objectFormat floatsMatchingPlatform ifFalse: [ asm sub: ESP with: 8; mov: EAX ptr + self baseHeaderSize to: ECX; mov: ECX to: ESP ptr+4; mov: EAX ptr + (4+self baseHeaderSize) to: ECX; mov: ECX to: ESP ptr; fld: ESP ptr64; add: ESP with: 4 ] ifTrue: [ asm fld: EAX ptr64 + self baseHeaderSize; sub: ESP with: 4 ]. asm fstp: asm ESP ptr32 ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:03'! ioLoadModule: m OfLength: l "implemented , see NBUtils class>>ioLoadModule: " self shouldNotUse ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/30/2010 20:29'! classAlien ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy objects' stamp: 'CamilloBruni 7/23/2012 18:03'! specialObjectsArray " load the special objects array into EAX" "since we cannot directly access the specialObjectsArray we store it as an extra Root" NativeBoost extraRootsRegistry at: #specialObjectsArray ifAbsentPut: [ Smalltalk specialObjectsArray ]; "specialObjectsArray -> EAX" emitOopAt: #specialObjectsArray generator: gen.! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:30'! fetchArray: index ofObject: oop "Fetch the instance variable at the given index of the given object. Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object." ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'CamilloBruni 7/16/2012 09:50'! booleanValueOf: oop "convert true and false (Smalltalk) to true or false(C). Fails if oop is not a boolean object" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:44'! ioMicroMSecs ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:55'! storeInteger: index ofObject: obj withValue: integerValue "Note: Integer value must fit in SmallInt , otherwise function will fail primitive" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 16:01'! isWords: oop "Answer true if the argument contains only indexable words (no oops). See comment in formatOf:" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:19'! majorVersion ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:51'! ioFilename: aCharBuffer fromString: aFilenameString ofLength: filenameLength resolveAliases: bool "the vm has to convert aFilenameString via any canonicalization and char-mapping and put the result in aCharBuffer. Note the resolveAliases flag - this is an awful artefact of OSX and Apples demented alias handling. When opening a file, the flag must be true, when closing or renaming it must be false. Sigh." ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'call' stamp: 'CamilloBruni 7/23/2012 13:29'! call: aFunction arguments: args | align | asm decorateWith: 'InterpreterProxy >> ' , aFunction name during: [ align := gen stackAlignment. aFunction requiresAlignment ifFalse: [ align := 1 ]. asm cdeclCall: [ :call | args reverseDo: [:arg | call push: arg value ]. self callFn: aFunction. ] alignment: align ]. ^ EAX! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 16:42'! isInMemory: oop "Return true if the given address is in ST object memory" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy objects' stamp: 'Igor.Stasenko 4/11/2010 16:15'! falseObject ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'VM-extras' stamp: 'IgorStasenko 3/24/2011 21:28'! callInterpreter "call the 'callInterpreter' VM function " | fn | fn := NativeBoost loadFunction: #callInterpret from: ''. self assert: (fn ~= 0). asm mov: fn asUImm to: EAX. asm call: EAX.! ! !NBInterpreterProxy methodsFor: 'call' stamp: 'Igor.Stasenko 9/29/2010 09:27'! gatedCall | sender fn args | sender := thisContext sender. fn := self functions at: (sender method selector). args := Array new: sender method numArgs. 1 to: args size do: [:i | args at: i put: (sender tempAt: i ) ]. ^ self callGated: fn arguments: args! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:04'! push: anObject "not recommended for use in native code" self shouldNotUse ! ! !NBInterpreterProxy methodsFor: 'proxy-stack access' stamp: 'Igor.Stasenko 4/30/2010 20:16'! stackObjectValue: offset "Ensures that the given object is a real object, not a SmallInteger." ^self simpleCall ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'CamilloBruni 8/3/2012 18:23'! cStackPointer (self canUseStackPointer not or: [stackPtrAddress isNil]) ifTrue: [ self error: 'cannot use c stack pointer directly' ]. "answer a memory operand " ^ cStackPtrAddress asUImm32 ptr32! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:15'! signalSemaphoreWithIndex: index "Record the given semaphore index in the double buffer semaphores array to be signaled at the next convenient moment. Force a real interrupt check as soon as possible." ^self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 09:38'! signed32BitIntegerFor: value ^ self gatedCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:36'! compilerHookVector ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classFloat ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:32'! incrementalGC "Do a mark/sweep garbage collection of just the young object area of object memory (i.e., objects above youngStart), using the root table to identify objects containing pointers to young objects from the old object area." ^ self gatedCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:36'! setCompilerInitialized: initFlag ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! topRemappableOop self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'VM-extras' stamp: 'IgorStasenko 5/7/2012 07:30'! swapActiveContext: newContext restoreMethod: aMethodOop "call the 'swapActiveContextrestoreMethod' VM function " | fn | fn := NativeBoost loadFunction: 'swapActiveContextrestoreMethod' from: ''. self assert: (fn ~= 0). asm cdeclCall: [ :call | call push: aMethodOop value. call push: newContext value. asm mov: fn asUImm to: EAX; call: EAX ] alignment: gen stackAlignment ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:22'! byteSwapped: w "Answer the given integer with its bytes in the reverse order." ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:40'! classExternalStructure ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'HenrikSperreJohansen 8/25/2011 00:58'! methodArgumentCount "Answer a total number of arguments of primitive method" ^ gen method numArgs! ! !NBInterpreterProxy methodsFor: 'proxy objects' stamp: 'CamilloBruni 7/23/2012 17:10'! specialObjectsArrayAt: index "generate the code to load the value at the given index into EAX" self specialObjectsArray. self stObject: asm EAX at: index.! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:15'! classCharacter ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'IgorStasenko 5/28/2012 03:17'! prepareForCallout "reserve a stack pointer temp above any others - not used anymore, since Cog supports stackPointerAddress() function " ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/3/2010 14:29'! createInstanceOf: aClass ^ self createInstanceOf: aClass size: 0! ! !NBInterpreterProxy methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/29/2010 09:27'! functions ^ self class functions! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:12'! floatValueOf: oop "Return a double value of given floating point object. fails if oop is not a Float class instance" "note, result is floating point value" self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 5/4/2012 16:41'! fetchPointer: index ofObject: oop "Answer an instance variable value at given index for given oop. No range checking performed. Output: EAX" | reg mem | (index isBlock or: [ oop isBlock]) ifTrue: [ ^ self simpleCall ]. "shortcut if arguments are not blocks" reg := oop. reg isMem ifTrue: [ asm mov: oop to: EAX. reg := EAX ]. mem := reg ptr32. index isInteger ifTrue: [ mem displacement: (self baseHeaderSize+ (index*self oopSize)) asImm ] ifFalse: [ | idx | idx := index. index isMem ifTrue: [ "index stored at pointer" asm mov: index to: ECX. idx := ECX. ]. mem index: idx; scale: self oopSize; displacement: self baseHeaderSize asImm ]. asm mov: mem to: EAX. ^ EAX ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:02'! copyBits "This entry point needs to be implemented for the interpreter proxy. Since BitBlt is now a plugin we need to look up BitBltPlugin:=copyBits and call it. This entire mechanism should eventually go away and be replaced with a dynamic lookup from BitBltPlugin itself but for backward compatibility this stub is provided" self shouldNotUse ! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 15:58'! is: oop MemberOf: stringPtr "char *" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 09:39'! success: flag ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:04'! positive64BitIntegerFor: op "use positive64BitIntegerFor instead" self shouldNotUse.! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! methodReturnValue: oop self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! utcMicroseconds self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:38'! callbackEnter: callbackIDPtr " sqInt * callbackIDPtr should point to a memory where jumpbuf will be stored " ^ self gatedCall! ! !NBInterpreterProxy methodsFor: 'testing' stamp: 'Igor.Stasenko 9/29/2010 10:48'! canUseDirectProxyFnAddress "Answer true if code generation routines can use interpreterProxy function addresses directly (available after bootstrap) " ^ NativeBoost forCurrentPlatform isBootstrapping not and: [ gen optDirectProxyFnAddress ]! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:19'! makePointwithxValue: xval yValue: yval "make a Point xValue@yValue. We know both will be integers so no value nor root checking is needed" ^ self gatedCall ! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 16:00'! isIntegerValue: value " return true (1) only if given integer value fits in ST smallinteger immediate oop" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:51'! vmEndianness ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:12'! getStackPointer "return a ST stack pointer" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:11'! internalIsMutable: oop "return a ST stack pointer" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'IgorStasenko 8/30/2012 18:45'! verifyCompactClassOf: oop is: aClass " fail prim, if oop class not matching the aClas output: oop in EAX " | index cont fail | index := Smalltalk compactClassesArray indexOf: aClass. oop = EAX ifFalse: [ asm mov: oop to: EAX ]. cont := asm uniqueLabelName: 'cont'. fail := asm uniqueLabelName: 'fail'. asm "smallinteger test" test: EAX with: 1; jnz: fail; mov: EAX ptr to: ECX; and: ECX with: objectFormat compactClassMask; cmp: ECX with: (index bitShift: objectFormat compactClassIndexShift); je: cont. asm label: fail. gen failWithMessage: 'An instance of ', aClass name , ' expected'. asm label: cont. ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:04'! floatObjectOf: floatValue "istantiate a floating point object and put a floating point value to it. answer that object " "we can't pass the floating point value in general purpose register, see the NBFloat64>>coerceReturnValue: how to do that." self shouldNotUse. ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:27'! arrayValueOf: oop "Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object." ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:40'! classExternalAddress ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! addHighPriorityTickee: thickeeFnAddr period: periodms self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'call' stamp: 'Igor.Stasenko 4/9/2010 07:57'! call: aFunction ^ self call: aFunction arguments: #() ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/5/2010 20:11'! indexOf: ivarName in: aClass ^ aClass instVarIndexFor: ivarName ifAbsent: [nil]! ! !NBInterpreterProxy methodsFor: 'errors' stamp: 'IgorStasenko 8/5/2013 12:02'! shouldNotUse self error: 'This is not recommended for use and therefore banned.'! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'CamilloBruni 7/23/2012 13:29'! verifyClassOf: oop is: aClass asm decorateWith: 'verifyClassOf:is:', aClass name during: [ "do a shortcut for compact classes" Smalltalk compactClassesArray indexOf: aClass ifAbsent: [ | class | class := gen reserveTemp. gen proxy fetchClassOf: oop. asm mov: asm EAX to: class. gen emitFetchClass: aClass. asm cmp: asm EAX with: class; jne: gen failedLabel. gen releaseTemps: 1. ^ self ]. ^ self verifyCompactClassOf: oop is: aClass ]! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 16:01'! isPointers: value "Answer true if the argument has only fields that can hold oops. See comment in formatOf:" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! primitiveFailureCode self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:12'! positive32BitIntegerFor: integerValue "Convert a (possibly positive) integer value into corresponding smallint object or positive big int instance " ^ self gatedCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:44'! ioLoadFunction: fnName From: moduleName "Load and return the requested function from a module" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:15'! classByteArray ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! isYoung: anOop self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classSemaphore ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:49'! forceInterruptCheck ^ self gatedCall! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 15:58'! isIndexable: oop ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/20/2010 07:25'! oop: anOop ifSmallInt: aBlock ifNotSmallInt: notSmallIntBlock " emit code to check if argument, oop is smallInteger squeak smallints having a least significant bit set" | lbl1 lbl2 | lbl1 := asm uniqueLabelName: 'notSmallInt'. asm mov: anOop to: EAX; test: AL with: 1; je: lbl1. aBlock value. notSmallIntBlock ifNil: [ asm label: lbl1. ^ self ]. lbl2 := asm uniqueLabelName: 'smallIntTestEnd'. asm jmp: lbl2. asm label: lbl1. notSmallIntBlock value. asm label: lbl2. ! ! !NBInterpreterProxy methodsFor: 'proxy-stack access' stamp: 'Igor.Stasenko 4/30/2010 20:16'! stackIntegerValue: offset "answer a integer value of oop on stack at given offset value" ^self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy objects' stamp: 'Igor.Stasenko 4/11/2010 16:15'! trueObject ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:49'! fetchLong32: index ofObject: oop ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'accessing oop fields' stamp: 'Igor.Stasenko 5/19/2010 12:22'! storePointer: op intoVarbytes: destOop at: offset " input: op - register, holding a pointer value destOop - register operand with variable bytes oop offset - integer value" ^ self storeValue: op ofSize: self pointerSize intoVarbytes: destOop at: offset ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:04'! pushInteger: int "not recommended for use in native code" self shouldNotUse ! ! !NBInterpreterProxy methodsFor: 'call' stamp: 'IgorStasenko 8/3/2011 05:57'! gatedCallFn: aFunctionOrName | fn gate | gen optNonMovable ifTrue: [ "a non-movable code don't needs to use gate" ^ self callFn: aFunctionOrName ]. fn := aFunctionOrName. aFunctionOrName isString ifTrue: [ fn := self functions at: aFunctionOrName ]. gate := NativeBoost callgateFunctionAddress. fn checkVersion. gen optProxyLabels ifTrue: [ asm label: (asm uniqueLabelName: 'gated_', fn name). ]. "push an address of function to call" self canUseDirectProxyFnAddress ifTrue: [ asm push: (fn address asUImm32 annotation: fn name). ] ifFalse: [ asm mov: (self class interpreterProxyAddress asUImm32 annotation: 'interpreterProxy address') to: EAX; mov: ((EAX ptr + (fn index * self pointerSize)) annotation: fn name) to: EAX; push: EAX ]. asm mov: (gate asUImm32 annotation: 'Call gate') to: EAX; call: EAX. usedGate := true.! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 5/5/2010 18:00'! integerObjectOf: value "Convert C integer value to smallinteger object. no range checking performed. " "lets not do call, but just do a shortcut (value << 1) + 1 " | tmp | tmp := value. value isBlock ifTrue: [ tmp := value value ]. tmp = EAX ifFalse: [ asm mov: tmp to: EAX ]. asm shl: EAX with: 1; inc: EAX . ^ EAX " ^ self simpleCall " ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:39'! includesBehavior: aClass ThatOf: aSuperclass "Return the equivalent of aClass includesBehavior: aSuperclass. Note: written for efficiency and better inlining (only 1 temp)" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'IgorStasenko 5/28/2012 01:31'! receiver "Input: none. Output: EAX - a method's receiver" self canUseStackPointer ifFalse: [ ^self stackValue: self methodArgumentCount ]. "EAX - count " ^self receiverInto: EAX. "EAX - receiver" ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:15'! displayObject ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:38'! classLargeNegativeInteger ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:13'! positive32BitValueOf: oop "Convert the given object into an integer value. The object may be either a positive ST integer or a four-byte LargePositiveInteger." ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'CamilloBruni 7/23/2012 13:29'! stackValue: index storeIn: aReg (index isInteger and: [self canUseStackPointer]) ifTrue: [ asm decorateWith: 'InterpreterProxy>>stackValue:' , index asString during: [ asm mov: self stackPointer to: aReg. objectFormat stackGrowsDown ifTrue: [ asm mov: aReg ptr + (self oopSize*index) to: aReg] ifFalse: [ asm mov: aReg ptr - (self oopSize*index) to: aReg]. ^ aReg ]]. self error: 'Not available. (And should not reach here)'! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classString ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:11'! callbackLeave: callbackId "Leave from a previous callback" ^ self gatedCall! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'IgorStasenko 8/10/2011 17:52'! shiftForPointer "answer the shift bits for pointer size" ^ self pointerSize highBit - 1 ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:21'! become: array1 with: array2 ^ self gatedCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! floatArg: index self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:04'! pushBool: trueOrFalse "not recommended for use in native code" self shouldNotUse ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:56'! storePointer: index ofObject: obj withValue: oop ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:41'! methodPrimitiveIndex "Answer a primitive index of currently activated method" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 16:01'! isWeak: oop "Answer true if the argument has only weak fields that can hold oops. See comment in formatOf:" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:03'! obsoleteDontUseThisFetchWord: index ofObject: zap self shouldNotUse! ! !NBInterpreterProxy methodsFor: 'call' stamp: 'Igor.Stasenko 9/29/2010 09:27'! simpleCall | sender fn args | sender := thisContext sender. fn := self functions at: (sender method selector). args := Array new: sender method numArgs. 1 to: args size do: [:i | args at: i put: (sender tempAt: i ) ]. ^ self call: fn arguments: args! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 4/11/2010 23:04'! ifFailedJumpTo: label self failed. asm or: EAX with: EAX. asm jnz: label. ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 9/3/2012 00:23'! signed64BitValueOf: oop ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:19'! minorVersion ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! primitiveErrorTable self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:51'! primitiveIndexOf: methodOop "return a primitive index for given method oop" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! isKindOf: oop Class: aClass self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:03'! loadBitBltFrom: bbOop "This entry point needs to be implemented for the interpreter proxy. Since BitBlt is now a plugin we need to look up BitBltPlugin:=loadBitBltFrom and call it. This entire mechanism should eventually go away and be replaced with a dynamic lookup from BitBltPlugin itself but for backward compatibility this stub is provided" self shouldNotUse ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 09:34'! signed32BitValueOf: object ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/19/2010 11:56'! baseHeaderSize ^ objectFormat baseHeaderSize! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'CamilloBruni 7/23/2012 13:29'! stackValue: index (index isInteger and: [self canUseStackPointer]) ifTrue: [ asm decorateWith: 'InterpreterProxy>>stackValue:' , index asString during: [ asm mov: self stackPointer to: EAX. objectFormat stackGrowsDown ifTrue: [ asm mov: EAX ptr + (self pointerSize*index) to: EAX] ifFalse: [ asm mov: EAX ptr - (self pointerSize*index) to: EAX]. ^ EAX ]]. ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:23'! fullGC "Do a mark/sweep garbage collection of the entire object memory. Free inaccessible objects but do not move them." ^ self gatedCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:20'! popRemappableOop "Pop and return the possibly remapped object from the remap buffer." ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! instanceSizeOf: aClass self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! addSynchronousTickee: tickerFnAddr period: periodms round: roundms self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 16:02'! isWordsOrBytes: oop "Answer true if the contains only indexable words or bytes (no oops). See comment in formatOf:" "Note: Excludes CompiledMethods." ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:28'! byteSizeOf: oop "Return the size of the receiver in bytes" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:09'! integerValueOf: oop "Convert smallinteger oop to C integer value. No type checking performed. " ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:10'! fetchFloat: fieldIndex ofObject: objectPointer "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float." "Note: May be called by translated primitive code." ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:39'! literalCountOf: methodOop "Answer a total number of literals for given method" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:03'! pop: nItems thenPush: anObject "not recommended for use in native code. use #stackValue: , and return a result oop from native function instead" self shouldNotUse ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:26'! argumentCountOf: methodOop "return a number of arguments for given method oop" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:52'! sizeOfSTArrayFromCPrimitive: ptr "Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that." ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'accessing oop fields' stamp: 'Igor.Stasenko 5/19/2010 13:22'! storeValue: op ofSize: numBytes intoVarbytes: destOop at: offset " input: op - a register operand numBytes - integer destOop - register operand with variable bytes oop offset - integer value" | mem | mem := destOop ptr + (objectFormat varBytesFirstField + offset). self assert: (op isGeneralPurpose & destOop isGeneralPurpose). asm mov: (asm reg: op index size: numBytes) to: (mem size: numBytes). ! ! !NBInterpreterProxy methodsFor: 'accessing' stamp: 'IgorStasenko 12/21/2011 14:20'! generator: aGenerator gen := aGenerator. asm := aGenerator asm. objectFormat := NBObjectFormat current asm: asm. gen parseOptions: self class defaultOptions! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! methodArg: index self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 8/5/2013 12:03'! ioLoadSymbol: sym OfLength: len FromModule: handle "implemented , see NBUtils class>>ioLoadSymbol:fromModule: " self shouldNotUse ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/28/2010 13:32'! fetchInteger: index ofObject: oop "Fetch the instance variable at the given index of the given object. Return the C integer value of that instance variable, or fail if it is not an integer." ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'accessing' stamp: 'IgorStasenko 8/3/2011 19:50'! objectFormat ^ objectFormat ! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 15:58'! isFloatObject: oop ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:19'! instantiateClass: classOop indexableSize: sz ^ self gatedCall ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'CamilloBruni 8/3/2012 18:23'! cFramePointer (self canUseStackPointer not or: [stackPtrAddress isNil]) ifTrue: [ self error: 'cannot use c stack pointer directly' ]. "answer a memory operand " ^ cFramePtrAddress asUImm32 ptr32! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classLargePositiveInteger ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 16:48'! isArray: oop ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:37'! firstIndexableField: oop "Answer an address of first indexable field for given oop" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:23'! fullDisplayUpdate "Repaint the entire smalltalk screen, ignoring the affected rectangle. Used in some platform's code when the Smalltalk window is brought to the front or uncovered." ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/19/2010 11:54'! oopSize ^ objectFormat oopSize! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/19/2010 11:54'! pointerSize ^ self oopSize! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! tenuringIncrementalGC self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classSmallInteger ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! ownVM: threadIdAndFlags self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/19/2010 11:54'! ivar: ivarName in: aClass "answer an offset of ivar relative to oop" | index | index := aClass instVarIndexFor: ivarName ifAbsent: [nil]. ^ objectFormat instVarOffsetAt: index.! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! objectArg: index self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/20/2010 06:02'! isBytes: oop ifNotJumpTo: label ^ objectFormat isBytes: oop ifNotJumpTo: label! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/29/2010 06:20'! addGCRoot: sqIntPtr ^ self simpleCall ! ! !NBInterpreterProxy class methodsFor: 'accessing functions' stamp: 'CamilloBruni 8/3/2012 18:26'! cStackPointerAddress "to prevent recursion, we prohibit using stack pointer address when bootstrapping" NativeBoost forCurrentPlatform isBootstrapping ifTrue: [ ^ nil ]. ^ NativeBoost loadSymbol: #CStackPointer! ! !NBInterpreterProxy class methodsFor: 'class initialization' stamp: 'CamilloBruni 7/19/2012 11:54'! proxyFunctionsData "taken from sqVirtualMachine.h" ^ #( #minorVersion (void) #majorVersion (void) " InterpreterProxy methodsFor: 'stack access' " #pop: (sqInt) #pop:thenPush: (sqInt sqInt) #push: (sqInt) #pushBool: (sqInt) #pushFloat: (double) #pushInteger: (sqInt) #stackFloatValue: (sqInt ) #stackIntegerValue: (sqInt) #stackObjectValue: (sqInt) #stackValue: (sqInt) " InterpreterProxy methodsFor: 'object access' " #argumentCountOf: (sqInt) #arrayValueOf: (sqInt) #byteSizeOf: (sqInt) #fetchArray:ofObject: (sqInt sqInt) #fetchClassOf: (sqInt) #fetchFloat:ofObject: (sqInt sqInt) #fetchInteger:ofObject: (sqInt sqInt) #fetchPointer:ofObject: (sqInt sqInt) #obsoleteDontUseThisFetchWord:ofObject: (sqInt sqInt) #firstFixedField: (sqInt) #firstIndexableField: (sqInt) #literal:ofMethod: (sqInt sqInt) #literalCountOf: (sqInt ) #methodArgumentCount (void) #methodPrimitiveIndex (void) #primitiveIndexOf: (sqInt ) #sizeOfSTArrayFromCPrimitive: (voidPtr) #slotSizeOf: (sqInt ) #stObject:at: (sqInt sqInt ) #stObject:at:put: (sqInt sqInt sqInt) #stSizeOf: (sqInt) #storeInteger:ofObject:withValue: (sqInt sqInt sqInt ) #storePointer:ofObject:withValue: (sqInt sqInt sqInt ) " InterpreterProxy methodsFor: 'testing' " #is:KindOf: (sqInt charPtr) #is:MemberOf: (sqInt charPtr) #isBytes: (sqInt ) #isFloatObject: (sqInt ) #isIndexable: (sqInt ) #isIntegerObject: (sqInt ) #isIntegerValue: (sqInt ) #isPointers: (sqInt ) #isWeak: (sqInt ) #isWords: (sqInt ) #isWordsOrBytes: (sqInt ) " InterpreterProxy methodsFor: 'converting' " #booleanValueOf: (sqInt ) #checkedIntegerValueOf: (sqInt ) #floatObjectOf: (double ) #floatValueOf: (sqInt ) #integerObjectOf: (sqInt ) #integerValueOf: (sqInt ) #positive32BitIntegerFor: (sqInt ) #positive32BitValueOf: (sqInt ) " InterpreterProxy methodsFor: 'special objects' " #characterTable (void) #displayObject (void) #falseObject (void) #nilObject (void) #trueObject (void) " InterpreterProxy methodsFor: 'special classes' " #classArray (void) #classBitmap (void) #classByteArray (void) #classCharacter (void) #classFloat (void) #classLargePositiveInteger (void) #classPoint (void) #classSemaphore (void) #classSmallInteger (void) #classString (void) " InterpreterProxy methodsFor: 'instance creation' " #clone: (sqInt ) #instantiateClass:indexableSize: (sqInt sqInt ) #makePointwithxValue:yValue: (sqInt sqInt ) #popRemappableOop (void) #pushRemappableOop: (sqInt ) " InterpreterProxy methodsFor: 'other' " #become:with: (sqInt sqInt ) #byteSwapped: (sqInt) #failed (void) #fullDisplayUpdate (void) #fullGC (void) #incrementalGC (void) #primitiveFail (void) #showDisplayBits:Left:Top:Right:Bottom: (sqInt sqInt sqInt sqInt sqInt) #signalSemaphoreWithIndex: (sqInt) #success: (sqInt ) #superclassOf: (sqInt ) " InterpreterProxy methodsFor: 'compiler' " #compilerHookVector (void) #setCompilerInitialized: (sqInt ) " VM_PROXY_MINOR > 1 " 2 " InterpreterProxy methodsFor: 'BitBlt support' " #loadBitBltFrom: (sqInt ) #copyBits (void) #copyBitsFrom:to:at: (sqInt sqInt sqInt ) " VM_PROXY_MINOR > 2 " 3 #classLargeNegativeInteger (void) #signed32BitIntegerFor: (sqInt ) #signed32BitValueOf: (sqInt ) #includesBehavior:ThatOf: (sqInt sqInt ) #primitiveMethod (void) " InterpreterProxy methodsFor: 'FFI support' " #classExternalAddress (void) #classExternalData (void) #classExternalFunction (void) #classExternalLibrary (void) #classExternalStructure (void) #ioLoadModule:OfLength: (sqInt sqInt) #ioLoadSymbol:OfLength:FromModule: (sqInt sqInt sqInt ) #isInMemory: (sqInt ) " VM_PROXY_MINOR > 3 " 4 #ioLoadFunction:From: (charPtr charPtr) #ioMicroMSecs (void) " VM_PROXY_MINOR > 4 " 5 #positive64BitIntegerFor: (sqLong) #positive64BitValueOf: (sqInt) #signed64BitIntegerFor: (sqLong) #signed64BitValueOf: (sqInt) " VM_PROXY_MINOR > 5 " 6 #isArray: (sqInt ) #forceInterruptCheck (void) " VM_PROXY_MINOR > 6 " 7 #fetchLong32:ofObject: (sqInt sqInt) #getThisSessionID (void) #ioFilename:fromString:ofLength:resolveAliases: (charPtr charPtr sqInt sqInt) #vmEndianness (void) 8 #internalIsImmutable: (sqInt) #internalIsMutable: (sqInt) #primitiveFailFor: (sqInt) #classAlien (void) #getStackPointer (void) #sendInvokeCallback:Stack:Registers:Jmpbuf: (sqInt sqInt sqInt sqInt) #reestablishContextPriorToCallback: (sqInt) #classUnsafeAlien (void) " New methods for proxy version 1.8 " " callbackEnter: Re-enter the interpreter loop for a callback. Arguments: callbackID: Pointer to a location receiving the callback ID used in callbackLeave Returns: True if successful, false otherwise " callbackEnter: (sqIntPtr) " callbackLeave: Leave the interpreter from a previous callback Arguments: callbackID: The ID of the callback received from callbackEnter() Returns: True if succcessful, false otherwise. " callbackLeave: (sqInt) " addGCRoot: Add a variable location to the garbage collector. The contents of the variable location will be updated accordingly. Arguments: varLoc: Pointer to the variable location Returns: True if successful, false otherwise. " addGCRoot: (sqIntPtr) " removeGCRoot: Remove a variable location from the garbage collector. Arguments: varLoc: Pointer to the variable location Returns: True if successful, false otherwise. " removeGCRoot: (sqIntPtr) ) ! ! !NBInterpreterProxy class methodsFor: 'class initialization' stamp: 'CamilloBruni 7/18/2012 14:41'! CogProxyFunctionsData "taken from sqVirtualMachine.h" ^ #( #minorVersion (void) #majorVersion (void) " InterpreterProxy methodsFor: 'stack access' " #pop: (sqInt) #pop:thenPush: (sqInt sqInt) #push: (sqInt) #pushBool: (sqInt) #pushFloat: (double) #pushInteger: (sqInt) #stackFloatValue: (sqInt ) #stackIntegerValue: (sqInt) #stackObjectValue: (sqInt) #stackValue: (sqInt) " InterpreterProxy methodsFor: 'object access' " #argumentCountOf: (sqInt) #arrayValueOf: (sqInt) #byteSizeOf: (sqInt) #fetchArray:ofObject: (sqInt sqInt) #fetchClassOf: (sqInt) #fetchFloat:ofObject: (sqInt sqInt) #fetchInteger:ofObject: (sqInt sqInt) #fetchPointer:ofObject: (sqInt sqInt) #obsoleteDontUseThisFetchWord:ofObject: (sqInt sqInt) #firstFixedField: (sqInt) #firstIndexableField: (sqInt) #literal:ofMethod: (sqInt sqInt) #literalCountOf: (sqInt ) #methodArgumentCount (void) #methodPrimitiveIndex (void) #primitiveIndexOf: (sqInt ) #sizeOfSTArrayFromCPrimitive: (voidPtr) #slotSizeOf: (sqInt ) #stObject:at: (sqInt sqInt ) #stObject:at:put: (sqInt sqInt sqInt) #stSizeOf: (sqInt) #storeInteger:ofObject:withValue: (sqInt sqInt sqInt ) #storePointer:ofObject:withValue: (sqInt sqInt sqInt ) " InterpreterProxy methodsFor: 'testing' " #is:KindOf: (sqInt charPtr) #is:MemberOf: (sqInt charPtr) #isBytes: (sqInt ) #isFloatObject: (sqInt ) #isIndexable: (sqInt ) #isIntegerObject: (sqInt ) #isIntegerValue: (sqInt ) #isPointers: (sqInt ) #isWeak: (sqInt ) #isWords: (sqInt ) #isWordsOrBytes: (sqInt ) " InterpreterProxy methodsFor: 'converting' " #booleanValueOf: (sqInt ) #checkedIntegerValueOf: (sqInt ) #floatObjectOf: (double ) #floatValueOf: (sqInt ) #integerObjectOf: (sqInt ) #integerValueOf: (sqInt ) #positive32BitIntegerFor: (sqInt ) #positive32BitValueOf: (sqInt ) " InterpreterProxy methodsFor: 'special objects' " #characterTable (void) #displayObject (void) #falseObject (void) #nilObject (void) #trueObject (void) " InterpreterProxy methodsFor: 'special classes' " #classArray (void) #classBitmap (void) #classByteArray (void) #classCharacter (void) #classFloat (void) #classLargePositiveInteger (void) #classPoint (void) #classSemaphore (void) #classSmallInteger (void) #classString (void) " InterpreterProxy methodsFor: 'instance creation' " #clone: (sqInt ) #instantiateClass:indexableSize: (sqInt sqInt ) #makePointwithxValue:yValue: (sqInt sqInt ) #popRemappableOop (void) #pushRemappableOop: (sqInt ) " InterpreterProxy methodsFor: 'other' " #become:with: (sqInt sqInt ) #byteSwapped: (sqInt) #failed (void) #fullDisplayUpdate (void) #fullGC (void) #incrementalGC (void) #primitiveFail (void) #showDisplayBits:Left:Top:Right:Bottom: (sqInt sqInt sqInt sqInt sqInt) #signalSemaphoreWithIndex: (sqInt) #success: (sqInt ) #superclassOf: (sqInt ) " InterpreterProxy methodsFor: 'compiler' " #compilerHookVector (void) #setCompilerInitialized: (sqInt ) " VM_PROXY_MINOR > 1 " 2 " InterpreterProxy methodsFor: 'BitBlt support' " #loadBitBltFrom: (sqInt ) #copyBits (void) #copyBitsFrom:to:at: (sqInt sqInt sqInt ) " VM_PROXY_MINOR > 2 " 3 #classLargeNegativeInteger (void) #signed32BitIntegerFor: (sqInt ) #signed32BitValueOf: (sqInt ) #includesBehavior:ThatOf: (sqInt sqInt ) #primitiveMethod (void) " InterpreterProxy methodsFor: 'FFI support' " #classExternalAddress (void) #classExternalData (void) #classExternalFunction (void) #classExternalLibrary (void) #classExternalStructure (void) #ioLoadModule:OfLength: (sqInt sqInt) #ioLoadSymbol:OfLength:FromModule: (sqInt sqInt sqInt ) #isInMemory: (sqInt ) " VM_PROXY_MINOR > 3 " 4 #ioLoadFunction:From: (charPtr charPtr) #ioMicroMSecs (void) " VM_PROXY_MINOR > 4 " 5 #positive64BitIntegerFor: (sqLong) #positive64BitValueOf: (sqInt) #signed64BitIntegerFor: (sqLong) #signed64BitValueOf: (sqInt) " VM_PROXY_MINOR > 5 " 6 #isArray: (sqInt ) #forceInterruptCheck (void) " VM_PROXY_MINOR > 6 " 7 #fetchLong32:ofObject: (sqInt sqInt) #getThisSessionID (void) #ioFilename:fromString:ofLength:resolveAliases: (charPtr charPtr sqInt sqInt) #vmEndianness (void) 8 " New methods for proxy version 1.8 " callbackEnter: (sqIntPtr) callbackLeave: (sqInt) addGCRoot: (sqIntPtr) removeGCRoot: (sqIntPtr) 9 primitiveFailFor: (sqInt code) setInterruptCheckChain: (void * aFunction ) classAlien (void) classUnsafeAlien (void) sendInvokeCallback:Stack:Registers:Jmpbuf: (sqInt thunkPtrAsInt, sqInt stackPtrAsInt, sqInt regsPtrAsInt, sqInt jmpBufPtrAsInt) reestablishContextPriorToCallback: (sqInt callbackContext) getStackPointer (void) internalIsImmutable: (sqInt oop) internalIsMutable: (sqInt oop) 10 methodArg: (sqInt index) objectArg: (sqInt index) integerArg: (sqInt index) floatArg: (sqInt index) methodReturnValue: (sqInt oop) topRemappableOop (void) 11 disownVM: (sqInt flags) ownVM: (sqInt threadIdAndFlags) addHighPriorityTickee:period: (void ticker (void), unsigned periodms) addSynchronousTickee:period:round: (void ticker (void), unsigned periodms, unsigned roundms) utcMicroseconds (void) tenuringIncrementalGC (void) isYoung: (sqInt anOop) isKindOf:Class: (sqInt oop, sqInt aClass) primitiveErrorTable (void) primitiveFailureCode (void) instanceSizeOf: (sqInt aClass) ) ! ! !NBInterpreterProxy class methodsFor: 'options' stamp: 'Igor.Stasenko 5/19/2010 13:02'! defaultOptions "Default options for proxy. Proxy options is applied before default options of generator, so generator can override them" ^ #( "call proxy functions directly, instead of loading their address indirectly via interpreterProxy struct" #optDirectProxyFnAddress "use a direct ST stack pointer, initially retrieved using #getStackPointer" #optUseStackPointer ) ! ! !NBInterpreterProxy class methodsFor: 'accessing functions' stamp: 'IgorStasenko 11/24/2012 17:19'! minorVersion "retrieve an interpreter proxy structure minor version value" ^ self nbCallout options: #( "do not use interpreterProxy address directly" - optDirectProxyFnAddress "do not align stack for FFI call" + optNoAlignment ); function: #(short ()) emit: [:gen | gen proxy minorVersion ] ! ! !NBInterpreterProxy class methodsFor: 'accessing functions' stamp: 'CamilloBruni 8/3/2012 17:21'! framePointerAddress "to prevent recursion, we prohibit using stack pointer address when bootstrapping" NativeBoost forCurrentPlatform isBootstrapping ifTrue: [ ^ nil ]. ^ self primFramePointerAddress ! ! !NBInterpreterProxy class methodsFor: 'accessing functions' stamp: 'CamilloBruni 8/3/2012 18:26'! cFramePointerAddress "to prevent recursion, we prohibit using stack pointer address when bootstrapping" NativeBoost forCurrentPlatform isBootstrapping ifTrue: [ ^ nil ]. ^ NativeBoost loadSymbol: #CFramePointer ! ! !NBInterpreterProxy class methodsFor: 'accessing functions' stamp: 'Igor.Stasenko 5/3/2010 10:36'! fnAddressAt: index "retrieve an interpreter proxy function address at given zero-based index. (self functions at: #minorVersion) address " index isString ifTrue: [ ^ self fnAddressAt: (self functions at: index) index ]. ^ NativeBoost ulongAt: self interpreterProxyAddress + (4 * index) ! ! !NBInterpreterProxy class methodsFor: 'debugging' stamp: 'Igor.Stasenko 4/16/2010 03:31'! fnSelectorAt: offset " NBInterpreterProxy fnSelectorAt: 16r130 " ^ (self functionAtOffset: offset) selector! ! !NBInterpreterProxy class methodsFor: 'class initialization' stamp: 'Igor.Stasenko 9/29/2010 09:22'! generateFunctions " self generateFunctions " Functions := self generateFunctionsFrom: self proxyFunctionsData. "checked using compiler on 32bits" self assert: (Functions at: #vmEndianness) index * 4 = 456. CogFunctions := self generateFunctionsFrom: self CogProxyFunctionsData.! ! !NBInterpreterProxy class methodsFor: 'accessing functions' stamp: 'Igor.Stasenko 5/2/2010 08:34'! interpreterProxyAddress ^ self primitiveFailed! ! !NBInterpreterProxy class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/1/2010 11:46'! forGenerator: aNativeCodeGenerator ^ self basicNew initialize generator: aNativeCodeGenerator! ! !NBInterpreterProxy class methodsFor: 'accessing functions' stamp: 'IgorStasenko 11/24/2012 17:20'! primFramePointerAddress "retrieve a stack pointer address" ^ self nbCallout function: #(uint ()) emit: [:gen :proxy :asm | | fn | fn := [ (NativeBoost forCurrentPlatform loadSymbol: 'framePointerAddress' fromModule: '') ] ifError: [ nil ]. fn ifNil: [ ^ nil ]. "just for safety" asm mov: fn asUImm32 to: asm EAX; call: EAX. ].! ! !NBInterpreterProxy class methodsFor: 'class initialization' stamp: 'IgorStasenko 8/3/2011 09:08'! initialize "self initialize" self generateFunctions! ! !NBInterpreterProxy class methodsFor: 'accessing functions' stamp: 'IgorStasenko 5/28/2012 05:18'! stackPointerAddress "to prevent recursion, we prohibit using stack pointer address when bootstrapping" NativeBoost forCurrentPlatform isBootstrapping ifTrue: [ ^ nil ]. ^ self primStackPointerAddress ! ! !NBInterpreterProxy class methodsFor: 'class initialization' stamp: 'IgorStasenko 8/3/2011 07:36'! generateFunctionsFrom: data | i stream minorV functions | functions := IdentityDictionary new. i := 0. stream := data readStream. minorV := 0. [ stream atEnd ] whileFalse: [ | val | val := stream next. val isInteger ifTrue: [ minorV := val ] ifFalse: [ (functions includesKey: val) ifTrue: [ self error: 'duplicated function!!!!' ]. functions at: val put: ( NBProxyFunction new selector: val; parseArguments: stream next; index: i; majorVersion: 1; minorVersion: minorV; requiresAlignment: (self safeNoAlignFunctions includes: val) not; yourself ). i := i + 1. ] ]. ^ functions! ! !NBInterpreterProxy class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/1/2010 11:46'! new self error: 'Use #forGenerator: '! ! !NBInterpreterProxy class methodsFor: 'accessing functions' stamp: 'IgorStasenko 2/8/2013 12:59'! primStackPointerAddress "retrieve a stack pointer address" ^ self nbCallout function: #(uint ()) emit: [:gen :proxy :asm | | fn | fn := [ (NativeBoost loadSymbol: 'stackPointerAddress' fromModule: NativeBoost VMModule) ] ifError: [ nil ]. fn ifNil: [ ^ nil ]. "just for safety" asm mov: fn asUImm32 to: asm EAX; call: EAX. ].! ! !NBInterpreterProxy class methodsFor: 'class initialization' stamp: 'CamilloBruni 7/18/2012 14:41'! safeNoAlignFunctions "list of functions which is safe to call without stack alignment" ^ #( minorVersion majorVersion failed primitiveMethod getStackPointer stackValue: primitiveFail nilObject trueObject falseObject methodArgumentCount )! ! !NBInterpreterProxy class methodsFor: 'debugging' stamp: 'Igor.Stasenko 9/29/2010 09:26'! functionAtOffset: offset | index | index := offset / 4. ^ self functions detect: [:fn | fn index = index ] ! ! !NBInterpreterProxy class methodsFor: 'accessing' stamp: 'IgorStasenko 11/23/2011 10:44'! functions " choose a set of interprterProxy functions, depending on VM we're currently running on" ^ (Smalltalk vm version beginsWith: 'Squeak') ifTrue: [ Functions ] ifFalse: [ CogFunctions ]! ! !NBInterpreterProxy class methodsFor: 'accessing functions' stamp: 'IgorStasenko 11/24/2012 17:19'! majorVersion "retrieve an interpreter proxy structure major version value" ^ self nbCallout options: #( "do not use interpreterProxy address directly" - optDirectProxyFnAddress "do not align stack for FFI call" + optNoAlignment ); function: #(short ()) emit: [:gen | gen proxy majorVersion ] ! ! !NBInterpreterProxyTest methodsFor: 'tests' stamp: 'IgorStasenko 5/28/2012 04:42'! testStackPointer self assert: self primCheckStackPointer=0 ! ! !NBInterpreterProxyTest methodsFor: 'tests' stamp: 'IgorStasenko 5/28/2012 05:22'! testStackPointer2 self assert: self primCheckStackPointer2=0 ! ! !NBInterpreterProxyTest methodsFor: 'primitives' stamp: 'IgorStasenko 11/24/2012 17:21'! primCheckStackPointer2 "should answer 0" ^ self nbCallout function: #(uint () ) emit: [:gen :proxy :asm | | get | proxy getStackPointer. asm mov: NBInterpreterProxy stackPointerAddress asUImm32 ptr32 to: asm ECX; sub: asm EAX with: asm ECX ] ! ! !NBInterpreterProxyTest methodsFor: 'primitives' stamp: 'IgorStasenko 11/24/2012 17:20'! primCheckStackPointer "should answer 0" ^ self nbCallout function: #(uint () ) emit: [:gen :proxy :asm | | get | proxy getStackPointer. asm mov: NBInterpreterProxy stackPointerAddress asUImm32 to: asm ECX; mov: asm ECX ptr to: asm ECX; sub: asm EAX with: asm ECX ] ! ! !NBMacConstants class methodsFor: 'initialization' stamp: 'IgorStasenko 11/18/2012 17:08'! initialize RTLD_LAZY := 16r1. RTLD_NOW := 16r2. RTLD_LOCAL := 16r4. RTLD_GLOBAL := 16r8. RTLD_NOLOAD := 16r10. RTLD_NODELETE := 16r80. RTLD_FIRST := 16r100. " Mac OS X 10.5 and later " RTLD_NEXT := -1 . " ((void *) -1) Search subsequent objects. " RTLD_DEFAULT := -2. " ((void *) -2) Use default search algorithm. " RTLD_SELF := -3. " ((void *) -3) Search this and subsequent objects (Mac OS X 10.5 and later) " RTLD_MAIN_ONLY := -5. " ((void *) -5) Search main executable only (Mac OS X 10.5 and later)" self initMmapflags. ! ! !NBMacConstants class methodsFor: 'initialization' stamp: 'Igor.Stasenko 12/5/2010 19:18'! initMmapflags PROT_READ := 16r1. " Page can be read. " PROT_WRITE := 16r2. " Page can be written. " PROT_EXEC := 16r4. " Page can be executed. " PROT_NONE := 16r0. " Page can not be accessed. " MAP_FILE := 0. " map from file (default) " MAP_ANON := 16r1000. " allocated from memory, swap space " " Flags contain sharing type and options. Sharing types; choose one." MAP_SHARED := 16r0001. " [MF|SHM] share changes" MAP_PRIVATE := 16r0002. " [MF|SHM] changes are private" MAP_COPY := MAP_PRIVATE. MAP_FIXED := 16r0010. " [MF|SHM] interpret addr exactly " MAP_RENAME := 16r0020. " Sun: rename private pages to file " MAP_NORESERVE := 16r0040. " Sun: don't reserve needed swap area " MAP_RESERVED0080 := 16r0080. " previously unimplemented MAP_INHERIT " MAP_NOEXTEND := 16r0100. " for MAP_FILE, don't change file size " MAP_HASSEMAPHORE := 16r0200. " region may contain semaphores " MAP_NOCACHE := 16r0400. " don't cache pages for this mapping " MAP_FAILED := -1 asImm asDWord.! ! !NBMacExternalHeapManager methodsFor: 'memory management' stamp: 'Igor.Stasenko 12/5/2010 19:19'! primAllocatePage: bytesToAllocate | ptr buf | buf := ByteArray new: 4. self mmapLength: bytesToAllocate prot: self protFlags flags: self mapFlags into: buf. ptr := buf unsignedLongAt: 1 bigEndian: false. ptr = MAP_FAILED ifTrue: [ self error: 'Unable to map virtual memory' ]. ^ ptr ! ! !NBMacExternalHeapManager methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 17:22'! mmapLength: bytesToAllocate prot: protFlags flags: mapFlags into: returnValueBuffer "Note: mmap using 32-bit offset, while mmap64 - 64bit one" ^ self nbCallout options: #( - optDirectProxyFnAddress ); function: #( NBBootstrapUlong ( 0, uint bytesToAllocate, int protFlags, int mapFlags, -1, 0 "offset" )) emit: [:gen | | mmap | mmap := NativeBoost forCurrentPlatform getGlobalSymbolPointer: 'mmap'. gen asm mov: mmap asUImm32 to: gen asm EAX. gen asm call: gen asm EAX ] ! ! !NBMacExternalHeapManager methodsFor: 'flags' stamp: 'Igor.Stasenko 12/5/2010 19:13'! mapFlags ^ MAP_ANON bitOr: MAP_PRIVATE! ! !NBMacExternalHeapManager methodsFor: 'flags' stamp: 'Igor.Stasenko 12/5/2010 18:36'! protFlags "since NativeBoost using heap for placing executable code there, it is important that all allocated memory should be executable" ^ (PROT_READ bitOr: PROT_WRITE) bitOr: PROT_EXEC! ! !NBMacExternalHeapManager methodsFor: 'memory management' stamp: 'Igor.Stasenko 12/5/2010 19:19'! primFreePage: aMemoryPage "call munmap()" | res | res := self unmap: aMemoryPage address length: aMemoryPage length. res = 0 ifFalse: [ self error: 'error during unmapping virtual memory page' ]! ! !NBMacExternalHeapManager methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 17:22'! unmap: addr length: len "unmap memory page" ^ self nbCallout function: #( int munmap (uint addr, ulong len) ) module: RTLD_DEFAULT ! ! !NBMacShell commentStamp: 'SeanDeNigris 3/28/2014 12:48'! I represent the Mac shell. As a beginning, I can execute simple system calls.! !NBMacShell class methodsFor: 'system' stamp: 'SeanDeNigris 3/28/2014 11:41'! run: commandString "self run: 'open http://www.google.com'." ^ self nbCall: #( int system (String commandString) ) module: NativeBoost CLibrary ! ! !NBMacShell class methodsFor: 'mac commands' stamp: 'SeanDeNigris 3/28/2014 12:16'! open: aString "self open: 'http://www.google.com'" | openCommand | openCommand := 'open "{1}"' format: { aString }. self run: openCommand.! ! !NBMacSpecificTest methodsFor: 'tests' stamp: 'SeanDeNigris 3/28/2014 11:54'! testSystemCall self flag: 'The result goes to stdout. Can we capture it?'. self assert: (NBMacShell run: 'expr 1 + 1') equals: 0.! ! !NBMacSpecificTest class methodsFor: 'testing' stamp: 'TorstenBergmann 8/7/2013 12:11'! isAbstract "only run test subclasses on Mac" ^(self name = #NBMacSpecificTest) or: [ OSPlatform isMacOS not ]! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/24/2010 04:29'! length: aValue length := aValue! ! !NBMemoryBlock methodsFor: 'memory operations' stamp: 'Igor.Stasenko 9/24/2010 23:20'! reserve: numBytes for: heapManager "reserve a given number of bytes of memory if numBytes < length, then create a smaller block with free memory" | leftover | self assert: free. numBytes > length ifTrue: [ self error: 'can''t reserve more than length of block' ]. heapManager removeFreeBlock: self. numBytes = length ifTrue: [ free := false. ^ self ]. leftover := NBMemoryBlock new address: address + numBytes; length: length - numBytes; left: self; right: right. right := leftover. length := numBytes. free := false. heapManager addFreeBlock: leftover. ! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 04:17'! isFree ^ free! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 04:43'! right: anObject right := anObject! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 04:43'! left ^left! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 04:43'! address ^address! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 04:43'! address: anObject address := anObject! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 04:43'! right ^right! ! !NBMemoryBlock methodsFor: 'initialization' stamp: 'Igor.Stasenko 9/22/2010 04:38'! initialize free := true! ! !NBMemoryBlock methodsFor: 'printing' stamp: 'Igor.Stasenko 9/26/2010 03:59'! printOn: aStream super printOn: aStream. aStream nextPutAll: '( @ 16r'; nextPutAll: (address printStringBase: 16); nextPutAll: ', '; print: length. free ifTrue: [ aStream nextPutAll: ', free' ]. aStream nextPut: $)! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 04:43'! left: anObject left := anObject! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 04:43'! length ^length! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 00:46'! makeFreeFor: heapManager "mark receiver as free and merge with adjusted blocks, if they also free" free := true. (right notNil and: [right isFree]) ifTrue: [ length := length + right length. heapManager removeFreeBlock: right. right := right right. ]. (left notNil and: [ left isFree ]) ifTrue: [ left length: (left length + length). left right: right. heapManager checkForFreePage: left ] ifFalse: [ heapManager addFreeBlock: self ].! ! !NBMemoryPage methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 9/25/2010 00:21'! length ^ length! ! !NBMemoryPage methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 9/24/2010 23:41'! address: addr length: len address := addr. length := len. initialBlock := NBMemoryBlock new address: addr; length: len! ! !NBMemoryPage methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 9/25/2010 00:32'! address ^ address! ! !NBMemoryPage methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 9/24/2010 23:19'! totalAllocatedMemory | blk total | blk := initialBlock. total := 0. [ blk notNil ] whileTrue: [ blk isFree ifFalse: [ total := total + blk length ]. blk := blk right. ]. ^ total! ! !NBMemoryPage methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 9/25/2010 00:08'! firstBlock ^ initialBlock! ! !NBMemoryPage class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 9/24/2010 23:42'! address: addr length: len ^ self basicNew address: addr length: len! ! !NBMockExternalHeapManager methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 00:20'! primAllocatePage: numBytes ^ 0! ! !NBMockExternalHeapManager methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 00:21'! primFreePage: aMemoryPage ^ 0! ! !NBMockExternalObject methodsFor: 'accessing' stamp: 'IgorStasenko 8/24/2012 17:05'! data: anObject data := anObject! ! !NBMockExternalObject methodsFor: 'accessing' stamp: 'IgorStasenko 8/24/2012 17:05'! resourceData ^ data! ! !NBMockExternalObject class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/24/2012 17:18'! finalizeResourceData: object object value! ! !NBNativeCodeError methodsFor: 'accessing' stamp: 'IgorStasenko 8/6/2011 18:17'! errorCode ^ errorCode! ! !NBNativeCodeError methodsFor: 'accessing' stamp: 'IgorStasenko 2/20/2012 13:04'! signalError: error "set error/code and signal it" (errorCode := error) isSymbol ifTrue: [ " some errors produced by VM translated to symbols. we unifying it here to draw better description from our pool (see NativeBoostConstants class>> #initErrorDescriptions )" errorCode := ((Smalltalk specialObjectsArray at: 52) indexOf: error ifAbsent: [ ^self signal: self description ]) -1 ]. ^ self signal: self description! ! !NBNativeCodeError methodsFor: 'accessing' stamp: 'IgorStasenko 2/20/2012 13:46'! description ^ NBErrorDescriptions at: errorCode ifAbsent: [ 'Error during execution of native code: ' , errorCode asString]. ! ! !NBNativeCodeError class methodsFor: 'signalling' stamp: 'IgorStasenko 8/6/2011 17:48'! signalError: error ^ self new signalError: error! ! !NBNativeCodeGen commentStamp: 'IgorStasenko 2/15/2012 19:49'! I providing a basic interface for use a dynamically generated native code with NativeBoost plugin using #primitiveNativeCall. On my class side, you can find the interface to help managing native code, as well as basic functionality for dealing with it at run time. My instance serves as a helper to access common facilities used for code generation: - assembler - interpreter proxy i do not provide anything beyond that, so you still basically on you own, and must use assembler and interpreter proxy for implementing a low-level funcitonality in your code (like new primitive, new function etc) Instance Variables: asm : An object that is used to generate native code proxy : An object providing an access to public VM interface: like fetching a var from smalltalk stack, accessing object's internals, etc. options : A set of options which generated code may use method : a compiled method instance where native code will be installed to, (of course in case if my instance used for generating code to be installed there, and if not, it can be ignored) Usage: My most simple use is in a form: myMethod ^ NBNativeCodeGen methodAssembly: [:gen | "here you put an instructions or provide own machine code. a block should answer a bytearray, which should contain ready for use machine code" ] In case, if you want to use different top-level interface, like in order to write something like following: myMethod ^ self myCode: [ "here you put an instructions or provide own machine code" ] You can use #handleFailureIn:nativeCode: method , which takes care of handling primitive failure, dealing with errors and finally installing native code, which you providing, into corresponding method. ! !NBNativeCodeGen methodsFor: 'retrieving the code' stamp: 'Igor.Stasenko 4/25/2010 01:05'! dumpBytes ^ String streamContents: [:str | self bytes do: [:b | str nextPutAll: (b printStringBase: 16); space ] ] ! ! !NBNativeCodeGen methodsFor: 'options' stamp: 'Igor.Stasenko 5/1/2010 10:18'! defaultOptions ^ self class defaultOptions! ! !NBNativeCodeGen methodsFor: 'initialize-release' stamp: 'HenrikSperreJohansen 8/23/2011 22:09'! setMethod: aMethod method := aMethod ! ! !NBNativeCodeGen methodsFor: 'accessing' stamp: 'IgorStasenko 8/10/2011 15:08'! stackAlignment ^ self utils stackAlignment ! ! !NBNativeCodeGen methodsFor: 'options' stamp: 'Igor.Stasenko 5/1/2010 10:56'! optionAt: optionName ^ options includes: optionName! ! !NBNativeCodeGen methodsFor: 'code generation' stamp: 'Igor.Stasenko 5/2/2010 13:03'! emitFetchClass: aClass "emit code, which fetching the class oop into EAX" ^ NativeBoost extraRootsRegistry emitFetchClass: aClass generator: self ! ! !NBNativeCodeGen methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 8/23/2011 22:08'! method ^method! ! !NBNativeCodeGen methodsFor: 'accessing' stamp: 'IgorStasenko 8/10/2011 15:08'! utils ^ NativeBoost forCurrentPlatform! ! !NBNativeCodeGen methodsFor: 'code generation' stamp: 'Igor.Stasenko 4/28/2010 13:48'! reserveStackBytes: numBytesOrBlock andStoreAddrTo: aTemp "emit code to reserve a given number of bytes, answer the temp, which will hold an allocated block address " | numBytes | numBytes := numBytesOrBlock. numBytesOrBlock isBlock ifTrue: [ numBytes := numBytesOrBlock value: self ]. numBytes = EAX ifFalse: [ asm mov: numBytes to: EAX ]. "align stack to 4-bytes (will waste 4 bytes if its already aligned)" asm or: EAX with: 3; inc: EAX ; sub: ESP with: EAX; mov: ESP to: aTemp. "store the allocated space start into a temp" ^ aTemp ! ! !NBNativeCodeGen methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/1/2010 10:27'! proxy ^ proxy! ! !NBNativeCodeGen methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/11/2010 09:04'! asm ^ asm! ! !NBNativeCodeGen methodsFor: 'options' stamp: 'Igor.Stasenko 5/1/2010 13:45'! doesNotUnderstand: message (message selector isUnary and: [ message selector beginsWith: 'opt'] ) ifTrue: [ ^ options includes: message selector ]. ^ super doesNotUnderstand: message! ! !NBNativeCodeGen methodsFor: 'initialization' stamp: 'IgorStasenko 5/9/2011 13:12'! initialize asm := self newAssembler. options := Set new. proxy := NBInterpreterProxy forGenerator: self. self parseOptions: self defaultOptions. ! ! !NBNativeCodeGen methodsFor: 'code generation' stamp: 'IgorStasenko 8/5/2011 07:38'! reserveStackBytes: numBytesOrBlock "emit code to reserve a given number of bytes, answer the temp, which will hold an allocated block address " | address | address := self reserveTemp. ^ self reserveStackBytes: numBytesOrBlock andStoreAddrTo: address! ! !NBNativeCodeGen methodsFor: 'accessing' stamp: 'IgorStasenko 5/7/2011 21:27'! newAssembler ^ NativeBoost newAssembler ! ! !NBNativeCodeGen methodsFor: 'options' stamp: 'Igor.Stasenko 5/1/2010 10:55'! parseOptions: optionsArray "parse an array, which is a sequence of options in a form of: #( + option1 option2 - option3 ... ) each time the #+ is seen, the options which follow it will be subject for inclusion and, correspondingly, if #- seen, then they will be excluded . By default, (if none of #+ or #- specified initially), all options are subject for inclusion. " | include | include := true. optionsArray do: [:option | option == #+ ifTrue: [ include := true ] ifFalse: [ option == #- ifTrue: [ include := false ] ifFalse: [ include ifTrue: [ options add: option ] ifFalse: [ options remove: option ifAbsent:[] ]]] ].! ! !NBNativeCodeGen methodsFor: 'retrieving the code' stamp: 'IgorStasenko 8/3/2011 20:08'! bytes ^ self generatedCode bytes! ! !NBNativeCodeGen methodsFor: 'temporaries' stamp: 'IgorStasenko 5/9/2011 12:55'! releaseTemps: count asm releaseTemps: count! ! !NBNativeCodeGen methodsFor: 'temporaries' stamp: 'IgorStasenko 5/9/2011 12:55'! reserveTemp ^ asm reserveTemp! ! !NBNativeCodeGen methodsFor: 'retrieving the code' stamp: 'IgorStasenko 8/3/2011 20:15'! generatedCode proxy usedGate ifTrue: [ asm reserveExtraBytesOnStack: asm wordSize*2. ]. self optDebug ifTrue: [ self halt. ]. ^ asm generatedCode. ! ! !NBNativeCodeGen methodsFor: 'code generation' stamp: 'CamilloBruni 7/23/2012 16:40'! epilogue asm emitEpilogue: 0. ! ! !NBNativeCodeGen class methodsFor: 'instance creation' stamp: 'HenrikSperreJohansen 8/23/2011 22:10'! newForMethod: aMethod ^self new setMethod: aMethod! ! !NBNativeCodeGen class methodsFor: 'error handling' stamp: 'IgorStasenko 7/12/2013 16:38'! getErrorFrom: aContext lastError: errorCode | lastError method | lastError := errorCode. method := aContext method. "Check that method has a #primitiveNativeCall, since it required by generator, and sometimes you can forget putting primitive pragma" (method primitive = 220 or: [ method hasNativeCallPrimitive]) ifFalse: [ ^ ErrNoNBPrimitive ]. "Check if method using an extended primitive pragma (introduced in Cog), otherwise we just take an errorCode" (method pragmas anySatisfy: [:p | p keyword == #primitive:module:error: ]) ifTrue: [ "A primitive error is always the last temp (ensured by compiler) " lastError := aContext tempAt: method numTemps. ]. lastError = ErrNotEnabled ifTrue: [ "If we cannot enable it, report an error..." NativeBoost enableNativeCode ifFalse: [ ^ NBNativeCodeError signal: 'Cannot enable native code execution' ]. " Fake absence of native code, so then code generator will generate code and retry the call. Note that if you want to keep native code forever (generated once and kept forever as long as method exists), you might want to override this" lastError := ErrNoNativeCodeInMethod ]. ^ lastError ! ! !NBNativeCodeGen class methodsFor: 'debugging' stamp: 'Igor.Stasenko 4/28/2010 18:13'! debugOff DebugOn := false! ! !NBNativeCodeGen class methodsFor: 'options' stamp: ''! defaultOptions ^ #() ! ! !NBNativeCodeGen class methodsFor: 'public API' stamp: 'CamilloBruni 10/4/2012 10:37'! jitMethodAssembly: aBlock "This method will directly inline the nativecode in the jited method thus eliminating the overhead of running through the whole primitive activation each time the method is invoked. Unlike in the cdecl style NativeBoost code generation the return value is passed in EDX and not in EAX." ^ self handleFailureInJit: thisContext sender nativeCode: [:gen | aBlock cull: gen cull: gen proxy cull: gen asm. gen bytes ] ! ! !NBNativeCodeGen class methodsFor: 'error handling' stamp: 'IgorStasenko 2/20/2012 13:48'! handleFailureIn: aContext nativeCode: aBlock | method lastError | "Note: make sure that #lastError are sent first, no guarantee that we won't be preempted before but this is best we can do if method is not using extended primitive pragma with error code" lastError := self getErrorFrom: aContext lastError: NativeBoost lastError. method := aContext method. "install native code and retry the send" lastError = ErrNoNativeCodeInMethod ifTrue: [ ^ self generateCode: aBlock andRetry: aContext ]. "ok, we're out of options, signal an error here" ^ self signalError: lastError ! ! !NBNativeCodeGen class methodsFor: 'error handling' stamp: 'IgorStasenko 11/9/2012 04:12'! handleFailureInJit: aContext nativeCode: aBlock | method lastError | "Note: make sure that #lastError are sent first, no guarantee that we won't be preempted before but this is best we can do if method is not using extended primitive pragma with error code" lastError := self getErrorFromJit: aContext. method := aContext method. lastError = ErrRunningViaInterpreter ifTrue: [ "a method contains native code, but executed by interpreter " method forceJIT ifFalse: [ self error: 'Failed to JIT the compiled method. Try reducing it''s size ' ]. ^ self retrySend: aContext ]. "install native code and retry the send" (lastError = ErrNoNativeCodeInMethod or: [ lastError isNil ] ) ifTrue: [ ^ self generateCode: aBlock andRetry: aContext ]. "ok, we're out of options, signal an error here" ^ self signalError: lastError ! ! !NBNativeCodeGen class methodsFor: 'public API' stamp: 'HenrikSperreJohansen 8/23/2011 02:34'! methodAssembly: aBlock "We're get here from a method, which contains a native code. There are following error cases: - method does not contains a NativeBoost primitive - method's native code platform id doesn't match the current platform id - method having no native code generated yet - a native code runs but caused primitive failure " ^ self handleFailureIn: thisContext sender nativeCode: [:gen | aBlock cull: gen cull: gen proxy cull: gen asm. gen bytes ] ! ! !NBNativeCodeGen class methodsFor: 'error handling' stamp: 'IgorStasenko 2/20/2012 13:48'! signalError: errorCode ^ NBNativeCodeError signalError: errorCode ! ! !NBNativeCodeGen class methodsFor: 'debugging' stamp: 'Igor.Stasenko 5/2/2010 18:05'! debugOn DebugOn := true! ! !NBNativeCodeGen class methodsFor: 'error handling' stamp: 'IgorStasenko 9/21/2012 15:48'! getErrorFromJit: aContext | lastError method | method := aContext method. "Check that method has a primitive 220" (method primitive = self jitPrimitiveNumber) ifFalse: [ ^ ErrNoNBPrimitive ]. (method pragmas anySatisfy: [:p | p keyword == #primitive:error: ]) ifTrue: [ "A primitive error is always the last temp (ensured by compiler) " lastError := aContext tempAt: method numTemps. ] ifFalse: [ lastError := ErrInvalidPrimitiveVoltageUse ]. ^ lastError ! ! !NBNativeCodeGen class methodsFor: 'error handling' stamp: 'IgorStasenko 2/13/2012 14:50'! assertIsNBMethod: aMethod "Check that method having a native-boost primitive" ((aMethod primitive = 117) and: [ | lit | lit := aMethod literalAt: 1. lit first = #NativeBoostPlugin and: [ lit second == #primitiveNativeCall]]) ifFalse: [ ^NBNativeCodeError signalError: ErrNoNBPrimitive ].! ! !NBNativeCodeGen class methodsFor: 'managing methods' stamp: 'IgorStasenko 2/13/2012 14:21'! installNativeCode: bytes into: method "install a native code into a compiled method" "Installing/removing native code directly: In some cases user(s) may need it, like in case if you want to update/flush/recompile generated code for a number of methods due to some change in environment. For example, my class(es) might have a 'DeveloperMode' flag, which depending on its value may affect a generated code in order to do some additional checks at runtime (when turned on), and suppress them (when turned off). And so, in order to switch between those modes, we need a way to flush native code in affected methods. Also, since a plugin having no way to determine who provided a native code, users may implement own code generators (or just load code from file/cache) instead of using facilities provided by NativeBoost. " | trailer newMethod | trailer := CompiledMethodTrailer new. trailer nativeCode: bytes platformId: NativeBoost platformId sourcePointer: method trailer sourcePointer. newMethod := method copyWithTrailerBytes: trailer. method methodClass methodDict at: method selector put: newMethod. ^ newMethod ! ! !NBNativeCodeGen class methodsFor: 'instance creation' stamp: 'IgorStasenko 9/23/2012 04:31'! generateCode: aBlock andRetry: retryCtx | method bytes newMethod args | method := retryCtx method. NBRecursionDetect in: method during: [ bytes := aBlock value: (self newForMethod: method). ]. DebugOn == true ifTrue: [ (FileStream newFileNamed: 'asm.bin') nextPutAll: bytes; close. self halt ]. newMethod := self installNativeCode: bytes into: method. newMethod primitive = self jitPrimitiveNumber ifTrue: [ newMethod forceJIT ]. ^ self retrySend: retryCtx ! ! !NBNativeCodeGen class methodsFor: 'error handling' stamp: 'IgorStasenko 9/20/2012 14:48'! jitPrimitiveNumber ^ 220! ! !NBNativeCodeGen class methodsFor: 'managing methods' stamp: 'IgorStasenko 2/13/2012 14:21'! removeNativeCodeFrom: method "Installing/removing native code directly: In some cases user(s) may need it, like in case if you want to update/flush/recompile generated code for a number of methods due to some change in environment. For example, my class(es) might have a 'DeveloperMode' flag, which depending on its value may affect a generated code in order to do some additional checks at runtime (when turned on), and suppress them (when turned off). And so, in order to switch between those modes, we need a way to flush native code in affected methods. Also, since a plugin having no way to determine who provided a native code, users may implement own code generators (or just load code from file/cache) instead of using facilities provided by NativeBoost. " |trailer| trailer := method trailer. trailer kind == #NativeCodeTrailer ifTrue: [ "it _should_ be true.. but lets check to be sure" | newTrailer | newTrailer := CompiledMethodTrailer new sourcePointer: trailer sourcePointer. method isInstalled ifTrue: [ method methodClass methodDict at: method selector put: ( method copyWithTrailerBytes: newTrailer) ] ]! ! !NBNativeCodeGen class methodsFor: 'error handling' stamp: 'IgorStasenko 9/23/2012 03:38'! retrySend: retryCtx | method args | method := retryCtx method. "just resending the same message" args := Array new: method numArgs. 1 to: args size do: [ :i | args at: i put: (retryCtx tempAt: i) ]. thisContext terminateTo: retryCtx sender. ^ retryCtx receiver perform: method selector withArguments: args. ! ! !NBNativeCodeGen class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/2/2010 13:34'! nativeMethods " self nativeMethods " ^ CompiledMethod allInstances select: [:m | m trailer kind = #NativeCodeTrailer and: [ m isInstalled ] ]! ! !NBNativeFunction methodsFor: 'code generation' stamp: 'CamilloBruni 8/3/2012 16:17'! valueWithArguments: anArray "call this native function with the given arguments" self shouldBeImplemented.! ! !NBNativeFunction methodsFor: 'code generation' stamp: 'CamilloBruni 10/4/2012 19:32'! emitCall: asm " emit the asm code for calling myself " asm mov: (handle asUImm32 annotation: self annotation) to: asm EAX. asm call: asm EAX.! ! !NBNativeFunction methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2012 15:22'! resourceData ^ handle! ! !NBNativeFunction methodsFor: 'accessing' stamp: 'IgorStasenko 8/23/2012 18:16'! address ^ handle! ! !NBNativeFunction methodsFor: 'initialize-release' stamp: 'CamilloBruni 8/3/2012 15:53'! initializeWithCode: code fnSpec: aFnSpec | bytes | super initialize. fnSpec := aFnSpec. bytes := code bytes. handle := NativeBoost allocate: bytes size. NativeBoost memCopy: bytes to: handle size: bytes size.! ! !NBNativeFunction methodsFor: 'accessing' stamp: 'IgorStasenko 8/23/2012 18:30'! uninstall handle ifNotNil: [ NativeBoost free: handle. handle := nil. ]! ! !NBNativeFunction methodsFor: 'accessing' stamp: 'CamilloBruni 10/3/2012 14:41'! annotation ^ annotation! ! !NBNativeFunction methodsFor: 'accessing' stamp: 'CamilloBruni 10/3/2012 14:41'! annotation: anObject annotation := anObject! ! !NBNativeFunction class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/3/2012 16:18'! stdCall: fnSpec emit: aFunctionBodyBlock ^ (NBNativeFunctionGen stdCall: fnSpec emit: aFunctionBodyBlock) install.! ! !NBNativeFunction class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/3/2012 16:18'! cdecl: fnSpec emit: aFunctionBodyBlock ^ (NBNativeFunctionGen cdecl: fnSpec emit: aFunctionBodyBlock) install.! ! !NBNativeFunction class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/3/2012 15:53'! code: code fnSpec: fnSpec ^ self basicNew initializeWithCode: code fnSpec: fnSpec! ! !NBNativeFunction class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/3/2012 16:18'! cdecl: fnSpec emit: aFunctionBodyBlock options: anOptionArray ^ (NBNativeFunctionGen cdecl: fnSpec emit: aFunctionBodyBlock options: anOptionArray) install.! ! !NBNativeFunction class methodsFor: 'finalization' stamp: 'CamilloBruni 8/3/2012 15:24'! finalizeResourceData: anExternalAddress anExternalAddress free! ! !NBNativeFunction class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/3/2012 16:18'! stdCall: fnSpec emit: aFunctionBodyBlock options: anOptionArray ^ (NBNativeFunctionGen stdCall: fnSpec emit: aFunctionBodyBlock options: anOptionArray) install.! ! !NBNativeFunctionArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 19:13'! type ^type! ! !NBNativeFunctionArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 18:58'! name: aName name := aName! ! !NBNativeFunctionArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 18:58'! name ^ name! ! !NBNativeFunctionArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 19:13'! type: anObject type := anObject! ! !NBNativeFunctionArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 19:13'! offset ^offset! ! !NBNativeFunctionArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 19:13'! offset: anObject offset := anObject! ! !NBNativeFunctionGen commentStamp: ''! I'm a generator of native code. I can create C style functions, providing convenient syntactic sugar for accessing the function arguments in function body (but you still have to write the body of the function with the assembler). I can be used for implementing small helper routines, low-level callbacks or functions which will run in separate (to VM) thread. A function spec is used to help with fetching arguments from call stack by using #arg: method for that: NBNativeFunctionGen cdecl: #( int (byte* a, byte * b) ) emit: [:gen | | asm | asm := gen asm. "this will load argument from stack to register" asm mov: (gen arg: #b) to: EAX; ]. By invoking the expression above, I will generate a native code and keep it in my instance. Now to put this code in use, it must be installed (see #install) into external memory. Then an address to the function can be passed to any other external function, or even called by FFI callout: myFunction := NBNativeFunctionGen cdecl: #(..) emit: [...]. myFunction install. address := myFunction address. After function is no longer needed, it must be uninstalled (to conserve the external memory): myFunction uninstall. Note, that this must be done explicitly, since like everything which works with external resources, there's no any automatic resource management for external memory. ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/13/2010 23:34'! code ^ code! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2012 15:36'! address ^ nativeFunction address! ! !NBNativeFunctionGen methodsFor: 'code generation' stamp: 'CamilloBruni 7/23/2012 16:36'! generateInstructions: aFunctionBodyBlock | instructions | options add: #optNonMovable. "native functions are non-movable code" self prepareArguments. aFunctionBodyBlock cull: self cull: proxy cull: asm. self epilogue. instructions := asm prepareInstructions. self optDebug ifTrue: [ self halt ]. ^ instructions ! ! !NBNativeFunctionGen methodsFor: 'code generation' stamp: 'IgorStasenko 8/23/2012 18:14'! generate: aFunctionBodyBlock code := AJGeneratedCode fromInstructions: (self generateInstructions: aFunctionBodyBlock). ! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/7/2010 22:31'! stackSize ^ stackSize! ! !NBNativeFunctionGen methodsFor: 'spec parsing' stamp: 'cipt 10/26/2012 19:19'! argName: argName indirectIndex: anIndex type: typeName ptrArity: ptrArity | arg | arg := NBNativeFunctionArgument new. arg type: (self typeName: typeName ptrArity: ptrArity). arg name: argName. ^ arg ! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'CamilloBruni 7/23/2012 16:39'! returnLabel ^ returnLabel ifNil: [ returnLabel := asm uniqueLabelName: 'Return' ]! ! !NBNativeFunctionGen methodsFor: 'installing' stamp: 'IgorStasenko 8/23/2012 18:06'! install "install the code into a memory heap" self assert: code notNil. nativeFunction := NBNativeFunction code: code fnSpec: fnSpec. ^ nativeFunction ! ! !NBNativeFunctionGen methodsFor: 'convenience' stamp: 'IgorStasenko 5/28/2012 07:23'! arg: aName | arg | arg := fnSpec arguments detect: [:argx | argx name = aName ] ifNone: [ self error: 'invalid argument name' ]. self assert: (arg type typeSize <= 8). ^ (asm EBP ptr + arg offset) size: arg type typeSize! ! !NBNativeFunctionGen methodsFor: 'code generation' stamp: 'IgorStasenko 5/28/2012 07:20'! prepareArguments | args offset | (self optCdecl or: [ self optStdcall ]) ifTrue: [ args := fnSpec arguments. ]. offset := 8. "+ return address + EBP" stackSize := 0. args withIndexDo: [:arg :i | | sz | "arg size is 4 or 8" sz := arg type stackSize. stackSize := stackSize + sz. arg offset: offset. offset := offset + sz. ]. ! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 22:12'! nb ^ NativeBoost forCurrentPlatform ! ! !NBNativeFunctionGen methodsFor: 'convenience' stamp: 'CamilloBruni 7/23/2012 16:55'! return "Generate a jump to the return label. Use this function instead of directly calling #ret, #leave on the assembler if you want to rely on the default cleanup instructions generated by me" asm jmp: self returnLabel.! ! !NBNativeFunctionGen methodsFor: 'installing' stamp: 'IgorStasenko 8/23/2012 18:04'! uninstall "uninstall the code from a memory heap" nativeFunction ifNotNil: [ nativeFunction uninstall ].! ! !NBNativeFunctionGen methodsFor: 'code generation' stamp: 'CamilloBruni 7/23/2012 16:40'! epilogue asm label: self returnLabel; emitEpilogue: (self optStdcall ifTrue: [ stackSize] ifFalse: [0]).! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2012 15:36'! nativeFunction ^ nativeFunction! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'IgorStasenko 8/21/2011 11:01'! fnSpec: anonymousSpec fnSpec := NBFnSpecParser new requestor: self ; parseAnonFunction: anonymousSpec! ! !NBNativeFunctionGen class methodsFor: 'generator entry points' stamp: 'IgorStasenko 8/23/2012 18:06'! cdecl: fnSpec emit: aFunctionBodyBlock ^ self new cdecl; fnSpec: fnSpec; generate: aFunctionBodyBlock; yourself! ! !NBNativeFunctionGen class methodsFor: 'generator entry points' stamp: 'IgorStasenko 8/23/2012 18:06'! stdCall: fnSpec emit: aFunctionBodyBlock options: anOptions ^ self new parseOptions: anOptions; stdcall; fnSpec: fnSpec; generate: aFunctionBodyBlock; yourself! ! !NBNativeFunctionGen class methodsFor: 'generator entry points' stamp: 'IgorStasenko 8/23/2012 18:06'! stdCall: fnSpec emit: aFunctionBodyBlock ^ self new stdcall; fnSpec: fnSpec; generate: aFunctionBodyBlock; yourself! ! !NBNativeFunctionGen class methodsFor: 'generator entry points' stamp: 'IgorStasenko 8/23/2012 18:06'! cdecl: fnSpec emit: aFunctionBodyBlock options: anOptions ^ self new cdecl; parseOptions: anOptions; fnSpec: fnSpec; generate: aFunctionBodyBlock; yourself! ! !NBObjectFormat commentStamp: 'Igor.Stasenko 5/19/2010 11:12'! i am exposing an object format to ease accessing various object fields directly, without calling interpreter proxy functions, where it is appropriate! !NBObjectFormat methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 11:53'! instVarOffsetAt: ivarIndex "answer an offset of instance variable with given 1-based index, relative to some oop" self subclassResponsibility ! ! !NBObjectFormat methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 11:27'! oopSize self subclassResponsibility ! ! !NBObjectFormat methodsFor: 'object formats' stamp: 'Igor.Stasenko 5/20/2010 05:52'! indexableWordsFormat self subclassResponsibility ! ! !NBObjectFormat methodsFor: 'testing' stamp: 'IgorStasenko 11/23/2011 10:44'! isCogVM ^ (Smalltalk vm version beginsWith: 'Squeak') not! ! !NBObjectFormat methodsFor: 'sizes' stamp: 'HenrikSperreJohansen 8/23/2011 21:47'! varBytesFirstField " answer an offset of first byte of variable-bytes oop, relative to object pointer" "In object formats where additional header fields are stored before the base header, this is just the size of the header" ^ self baseHeaderSize ! ! !NBObjectFormat methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/20/2010 05:54'! asm: anAsm asm := anAsm! ! !NBObjectFormat methodsFor: 'sizes' stamp: 'HenrikSperreJohansen 8/23/2011 21:51'! stackArgumentSize "a default number of bytes on stack used by a single argument, for calling proxy functions" "In most cases, this will the same as oopSize, but not necessarily" ^self subclassResponsibility! ! !NBObjectFormat methodsFor: 'sizes' stamp: 'HenrikSperreJohansen 8/23/2011 21:44'! baseHeaderSize ^ self oopSize! ! !NBObjectFormat class methodsFor: 'accessing' stamp: 'IgorStasenko 12/21/2011 14:20'! current "answer an new instance of object format representing an object format of currently running system" ^ NBObjectFormat32 new! ! !NBObjectFormat32 commentStamp: 'Igor.Stasenko 5/19/2010 11:13'! - an object format for 32-bit images! !NBObjectFormat32 methodsFor: 'emitting tests' stamp: 'CamilloBruni 7/23/2012 13:29'! isBytesOrWords: oop ifNotJumpTo: label | gotIt | gotIt := asm uniqueLabelName: 'gotit'. asm decorateWith: '#isBytesOrWords:ifNotJumpTo:' during: [ asm mov: oop to: EAX; test: AL with: 1; jne: label; mov: EAX ptr to: ECX; and: ECX with: self objectFormatMask; cmp: ECX with: (self indexableWordsFormat bitShift: self objectFormatShift); je: gotIt; cmp: ECX with: (self indexableBytesFormat bitShift: self objectFormatShift); jl: label; label: gotIt ]! ! !NBObjectFormat32 methodsFor: 'header shifts' stamp: 'Igor.Stasenko 5/20/2010 03:35'! compactClassIndexShift "answer a compact class index shift" ^ 12 ! ! !NBObjectFormat32 methodsFor: 'object formats' stamp: 'HenrikSperreJohansen 8/22/2011 22:11'! fixedFieldsFormat " fixed fields only (all containing pointers) " ^ 2r0001! ! !NBObjectFormat32 methodsFor: 'header fields' stamp: 'HenrikSperreJohansen 8/22/2011 23:16'! identityHashMask "answer a bit mask for a compact class index in base header " " ggghhhhhhhhhhhhcccccffffsssssstt " ^ 2r00011111111111100000000000000000 ! ! !NBObjectFormat32 methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 11:53'! instVarOffsetAt: index "answer an offset of instance variable with given 1-based index, relative to some oop" ^ self baseHeaderSize + (self oopSize*(index-1)).! ! !NBObjectFormat32 methodsFor: 'header shifts' stamp: 'HenrikSperreJohansen 8/23/2011 00:55'! sizeShift ^ 2! ! !NBObjectFormat32 methodsFor: 'emitting tests' stamp: 'CamilloBruni 7/23/2012 13:29'! ifImmediate: aLocation jumpTo: aLabel "Jump to aLabel, if the OOP in aLocation is that of an immediate smallinteger" asm decorateWith: '#jumpTo:ifImmediate::' during: [ asm test: aLocation with: 1; jnz: aLabel ]! ! !NBObjectFormat32 methodsFor: 'emitting tests' stamp: 'HenrikSperreJohansen 8/22/2011 22:26'! isBytes2: oop ifNotJumpTo: label asm mov: oop to: EAX; test: AL with: 1; jne: label; "mov: EAX ptr to: ECX;" "and: ECX with: self objectFormatMask;" test: EAX with: (self indexableBytesFormat bitShift: self objectFormatShift); jz: label! ! !NBObjectFormat32 methodsFor: 'sizes' stamp: 'HenrikSperreJohansen 8/23/2011 21:50'! stackArgumentSize "a default number of bytes on stack used by a single argument, for calling proxy functions" ^self oopSize! ! !NBObjectFormat32 methodsFor: 'object formats' stamp: 'HenrikSperreJohansen 8/22/2011 22:11'! indexableBytesFormat " 8-11 indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size) " ^ 2r1000! ! !NBObjectFormat32 methodsFor: 'emitting tests' stamp: 'CamilloBruni 7/23/2012 13:29'! jumpTo: aLabel ifNotWordsOOP: aLocation asm decorateWith: '#jumpTo:ifNotWordsOOP:' during: [ self ifImmediate: aLocation jumpTo: aLabel . asm push: asm EAX; mov: aLocation ptr to: asm EAX; test: asm EAX with: (self indexableWordsFormat bitShift: self objectFormatShift); pop: asm EAX; jz: aLabel ]! ! !NBObjectFormat32 methodsFor: 'header shifts' stamp: 'HenrikSperreJohansen 8/23/2011 00:05'! objectFormatShift ^ 8! ! !NBObjectFormat32 methodsFor: 'header shifts' stamp: 'HenrikSperreJohansen 8/22/2011 23:01'! immediateShift ^ 24! ! !NBObjectFormat32 methodsFor: 'emitting tests' stamp: 'CamilloBruni 7/23/2012 13:29'! ifWordsOOP: aLocation storeHeaderIn: destinationLocation ifNotJumpTo: aLabel asm decorateWith: '#jumpTo:ifNotWordsOOP:' during: [ asm mov: aLocation ptr to: destinationLocation; test: destinationLocation with: (self indexableWordsFormat bitShift: self objectFormatShift); jz: aLabel ]! ! !NBObjectFormat32 methodsFor: 'header fields' stamp: 'HenrikSperreJohansen 8/23/2011 21:41'! objectSizeMask "answer a bit mask for a compact class index in base header " " ggghhhhhhhhhhhhcccccffffsssssstt " ^ 2r00000000000000000000000011111100 ! ! !NBObjectFormat32 methodsFor: 'header fields' stamp: 'HenrikSperreJohansen 8/22/2011 23:19'! compactClassMask "answer a bit mask for a compact class index in base header " " ggghhhhhhhhhhhhcccccffffsssssstt " ^ 2r00000000000000011111000000000000 ! ! !NBObjectFormat32 methodsFor: 'emitting tests' stamp: 'HenrikSperreJohansen 8/23/2011 01:51'! sizeOf: headerRegister is: anImmediate ifNotJumpTo: aLabel asm and: headerRegister with: self objectSizeMask; xor: headerRegister with: (anImmediate bitShift: self sizeShift); jnz: aLabel! ! !NBObjectFormat32 methodsFor: 'testing' stamp: 'Igor.Stasenko 9/29/2010 10:58'! floatsMatchingPlatform "Answer true if floats are store in platform native endianesness. This is false for Squeak on x86 , since they are always stored in bigendian format. Cog promising to always use native format for floats. " ^ self isCogVM! ! !NBObjectFormat32 methodsFor: 'emitting tests' stamp: 'CamilloBruni 7/23/2012 13:29'! jumpTo: aLabel ifImmediate: aLocation asm decorateWith: '#jumpTo:ifImmediate::' during: [ asm test: aLocation with: 1; jnz: aLabel ]! ! !NBObjectFormat32 methodsFor: 'object formats' stamp: 'Igor.Stasenko 5/20/2010 06:06'! noFieldsFormat ^ 0! ! !NBObjectFormat32 methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 11:29'! oopSize ^ 4! ! !NBObjectFormat32 methodsFor: 'object formats' stamp: 'HenrikSperreJohansen 8/22/2011 22:11'! indexableWordsFormat " indexable word fields only (no pointers) " ^ 2r0110! ! !NBObjectFormat32 methodsFor: 'testing' stamp: 'IgorStasenko 8/5/2011 18:14'! stackGrowsDown "Squeak interpreter stack grows up, while StackInterpreter down" ^ self isCogVM! ! !NBObjectFormat32 methodsFor: 'header fields' stamp: 'HenrikSperreJohansen 8/22/2011 23:16'! headerTypeMask "answer a bit mask for a compact class index in base header " " ggghhhhhhhhhhhhcccccffffsssssstt " ^ 2r00000000000000000000000000000011 ! ! !NBObjectFormat32 methodsFor: 'header fields' stamp: 'HenrikSperreJohansen 8/23/2011 21:41'! objectFormatMask "answer a bit mask for a compact class index in base header " " ggghhhhhhhhhhhhcccccffffsssssstt " ^ 2r00000000000000000000111100000000 ! ! !NBObjectFormat32 methodsFor: 'emitting tests' stamp: 'Igor.Stasenko 5/20/2010 07:25'! isBytes: oop ifNotJumpTo: label asm mov: oop to: EAX; test: AL with: 1; jne: label; mov: EAX ptr to: ECX; and: ECX with: self objectFormatMask; cmp: ECX with: (self indexableBytesFormat bitShift: self objectFormatShift); jl: label! ! !NBObjectFormat32 class methodsFor: 'helper' stamp: 'IgorStasenko 11/24/2012 17:22'! headerOf: anObject ^ self nbCallout function: #( ulong (oop anObject) ) emit: [:gen | gen asm pop: gen asm EAX. gen asm mov: gen asm EAX ptr to: gen asm EAX ]! ! !NBObjectFormat32Tests methodsFor: 'primitives' stamp: 'IgorStasenko 11/24/2012 17:23'! pushDouble: aFloat ^ self nbCallout function: #( double (double aFloat)) emit: [:gen | | asm | asm := gen asm. asm fld: asm ESP ptr64 ]! ! !NBObjectFormat32Tests methodsFor: 'tests' stamp: 'IgorStasenko 11/23/2011 10:46'! testCompactFloats | idx format | format := NBObjectFormat32 new. idx := Smalltalk compactClassesArray indexOf: Float ifAbsent: [ ^ nil ]. idx := idx bitShift: format compactClassIndexShift. NativeBoost enableNativeCode. Float allInstances do: [:each | | oopIdx | oopIdx := (NBObjectFormat32 headerOf: each) bitAnd: format compactClassMask. self assert: (oopIdx = idx) ]! ! !NBObjectFormat32Tests methodsFor: 'primitives' stamp: 'IgorStasenko 11/24/2012 17:23'! getFloatPtrOffset: aFloat "return the difference between float oop and pointer to its stored floating-point value , must be base header size" ^ self nbCallout function: #( ulong (oop aFloat, NBFloatPtr aFloat)) emit: [:gen | | asm | asm := gen asm. asm pop: asm ECX. "oop" asm pop: asm EAX. "float ptr" asm sub: asm EAX with: asm ECX ]! ! !NBObjectFormat32Tests methodsFor: 'tests' stamp: 'Igor.Stasenko 5/20/2010 09:19'! testPushingFloats self assert: (self pushFloat: 100.0) = 100.0. self assert: (self pushDouble: 100.0) = 100.0.! ! !NBObjectFormat32Tests methodsFor: 'primitives' stamp: 'IgorStasenko 11/24/2012 17:24'! pushFloat: aFloat ^ self nbCallout function: #( double (float aFloat)) emit: [:gen | | asm | asm := gen asm. asm fld: asm ESP ptr32 ]! ! !NBObjectFormat32Tests methodsFor: 'tests' stamp: 'IgorStasenko 12/21/2011 14:21'! testPushingFloatPointers self assert: (self getFloatPtrOffset: 10.0) = NBObjectFormat current baseHeaderSize. ! ! !NBOop commentStamp: ''! i am special "type", doing no conversion of any sort, just passing an object oop as it is.! !NBOop methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/1/2010 12:04'! coerceReturnValue: generator "oop is already in EAX, we don't need to do anything"! ! !NBOop methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/29/2010 07:56'! pushAsPointer: gen self error: 'oop is already a pointer. go away'.! ! !NBOop methodsFor: 'accessing' stamp: 'IgorStasenko 5/28/2012 01:38'! valueSize "Answer a number of bytes, which takes a value of given type (not a pointer to it) " ^ self pointerSize ! ! !NBOop methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/30/2010 13:55'! pushAsValue: gen gen asm push: (loader emitLoad: gen) ! ! !NBPointerArgumentsTests methodsFor: 'generation options' stamp: 'CiprianTeodorov 3/16/2013 22:53'! case1 ^#( +optAllowByteArraysPtr +optAllowExternalAddressPtr )! ! !NBPointerArgumentsTests methodsFor: 'generation options' stamp: 'CiprianTeodorov 3/16/2013 22:53'! case3 ^#( -optAllowByteArraysPtr -optAllowExternalAddressPtr )! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'IgorStasenko 7/12/2013 14:53'! testStructCase1ExternalAddress | value | value := 12345678. self should: [ self readStructPtrCase1: (self structExternalAddress: value) ] raise: NBFFICalloutError ! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'CiprianTeodorov 3/16/2013 23:43'! testStructCase2ByteArray self should: [self readStructPtrCase2: (self structByteArray: 12345678)] raise: NBFFICalloutError ! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'CiprianTeodorov 3/16/2013 23:55'! testStructCase1Struct |value| value := 12345678. self assert: (self readStructPtrCase1: (self structValue: value)) = value.! ! !NBPointerArgumentsTests methodsFor: 'enum primitives' stamp: 'CiprianTeodorov 3/17/2013 00:34'! readEnumPtrCase3: arg "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveEnum: arg case: self case3.! ! !NBPointerArgumentsTests methodsFor: 'struct primitives' stamp: 'CiprianTeodorov 3/17/2013 22:29'! arity2StructPtrCase3: arg "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveArity2Struct: arg case: self case3.! ! !NBPointerArgumentsTests methodsFor: 'integer pointers tests' stamp: 'CiprianTeodorov 3/17/2013 00:36'! intByteArray: aValue ^(self class intArrayType with: aValue) address.! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'CiprianTeodorov 3/16/2013 23:56'! testStructCase3Struct |value| value := 12345678. self assert: (self readStructPtrCase3: (self structValue: value)) = value.! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'CiprianTeodorov 3/16/2013 23:52'! testStructCase3ExternalAddress self should: [self readStructPtrCase3: (self structExternalAddress: 12345)] raise: NBFFICalloutError.! ! !NBPointerArgumentsTests methodsFor: 'integer pointers tests' stamp: 'CiprianTeodorov 3/17/2013 00:10'! testIntDirectly self should: [self readIntPtrCase1: 12345] raise: NBFFICalloutError ! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'CiprianTeodorov 3/17/2013 00:38'! structByteArray: aValue ^(self class structArrayType with: (self structValue: aValue)) address. ! ! !NBPointerArgumentsTests methodsFor: 'struct primitives' stamp: 'CiprianTeodorov 3/17/2013 22:29'! arity2StructPtrCase4: arg "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveArity2Struct: arg case: self case4.! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests arity 2' stamp: 'IgorStasenko 7/8/2013 17:38'! testArity2StructCase2Struct self should: [self arity2StructPtrCase2: (self structValue: 12345678)] raise: NBFFICalloutError. ! ! !NBPointerArgumentsTests methodsFor: 'enum pointers tests' stamp: 'IgorStasenko 7/12/2013 14:30'! testEnumDirectly self should: [self readEnumPtrCase1: self class enumClass BBB] raise: NBCodeGenerationError ! ! !NBPointerArgumentsTests methodsFor: 'integer primitives' stamp: 'CiprianTeodorov 3/16/2013 23:21'! primitiveInt: anInt case: aCase ^ (self nbCalloutIn: thisContext sender) options: aCase; function: #(int (int * anInt) ) emit: [:gen :proxy :asm | asm pop: asm ECX; mov: asm ECX ptr to: asm EAX. ] ! ! !NBPointerArgumentsTests methodsFor: 'integer primitives' stamp: 'CiprianTeodorov 3/16/2013 23:18'! readIntPtrCase3: anInt ^self primitiveInt: anInt case: self case3 ! ! !NBPointerArgumentsTests methodsFor: 'enum pointers tests' stamp: 'IgorStasenko 7/12/2013 14:33'! testEnumCase1ByteArray |item| item := self class enumClass BBB. self should: [ self readEnumPtrCase1: (self enumByteArray: item) ] raise: NBCodeGenerationError.! ! !NBPointerArgumentsTests methodsFor: 'integer primitives' stamp: 'CiprianTeodorov 3/16/2013 23:19'! readIntPtrCase1: anInt "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveInt: anInt case: self case1.! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'CiprianTeodorov 3/16/2013 23:55'! testStructCase2Struct |value| value := 12345678. self assert: (self readStructPtrCase2: (self structValue: value)) = value.! ! !NBPointerArgumentsTests methodsFor: 'struct primitives' stamp: 'CiprianTeodorov 3/16/2013 23:41'! readStructPtrCase2: aStruct "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveStruct: aStruct case: self case2.! ! !NBPointerArgumentsTests methodsFor: 'integer pointers tests' stamp: 'CiprianTeodorov 3/17/2013 00:08'! testIntCase3ByteArray self should: [ self readIntPtrCase3: (self intByteArray: 12345)] raise: NBFFICalloutError . ! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'CiprianTeodorov 3/16/2013 23:44'! testStructCase3ByteArray self should: [self readStructPtrCase3: (self structByteArray: 12345678)] raise: NBFFICalloutError ! ! !NBPointerArgumentsTests methodsFor: 'enum pointers tests' stamp: 'IgorStasenko 7/12/2013 14:30'! testEnumCase4ExternalAddress self should: [self readEnumPtrCase4: (self enumExternalAddress: self class enumClass BBB)] raise: NBCodeGenerationError. ! ! !NBPointerArgumentsTests methodsFor: 'enum pointers tests' stamp: 'IgorStasenko 7/12/2013 14:33'! testEnumCase1ExternalAddress | item | item := self class enumClass DDD. self should: [self readEnumPtrCase1: (self enumExternalAddress: item)] raise: NBCodeGenerationError.! ! !NBPointerArgumentsTests methodsFor: 'integer pointers tests' stamp: 'CiprianTeodorov 3/17/2013 00:08'! testIntCase2ExternalAddress | value | value := 12345. self assert: (self readIntPtrCase2: (self intExternalAddress: value)) = value.! ! !NBPointerArgumentsTests methodsFor: 'integer primitives' stamp: 'CiprianTeodorov 3/16/2013 23:18'! readIntPtrCase2: anInt ^self primitiveInt: anInt case: self case2 ! ! !NBPointerArgumentsTests methodsFor: 'enum pointers tests' stamp: 'IgorStasenko 7/12/2013 14:33'! testEnumCase2ExternalAddress | item | item := self class enumClass DDD. self should: [self readEnumPtrCase2: (self enumExternalAddress: item)] raise: NBCodeGenerationError! ! !NBPointerArgumentsTests methodsFor: 'struct primitives' stamp: 'CiprianTeodorov 3/16/2013 23:41'! readStructPtrCase1: aStruct "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveStruct: aStruct case: self case1.! ! !NBPointerArgumentsTests methodsFor: 'enum pointers tests' stamp: 'IgorStasenko 7/12/2013 14:32'! testEnumCase4ByteArray |item| item := self class enumClass BBB. self should: [ self readEnumPtrCase4: (self enumByteArray: item) ] raise: NBCodeGenerationError! ! !NBPointerArgumentsTests methodsFor: 'generation options' stamp: 'CiprianTeodorov 3/16/2013 22:53'! case2 ^#( -optAllowByteArraysPtr +optAllowExternalAddressPtr )! ! !NBPointerArgumentsTests methodsFor: 'enum pointers tests' stamp: 'CiprianTeodorov 3/17/2013 09:28'! enumExternalAddress: aValue ^(toBeFreed := self class enumArrayType externalNew: 1) at: 1 put: aValue; address. ! ! !NBPointerArgumentsTests methodsFor: 'enum primitives' stamp: 'CiprianTeodorov 3/17/2013 00:33'! primitiveEnum: arg case: aCase ^ (self nbCalloutIn: thisContext sender) options: aCase; function: {#NBInt32. {self class enumType. #*. #arg} } emit: [:gen :proxy :asm | asm pop: asm ECX; "pointer to the enum" mov: asm ECX ptr to: asm EAX. "read the enum value" ]! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'IgorStasenko 7/12/2013 14:53'! testStructCase1ByteArray |value| value := 12345678. self should: [ self readStructPtrCase1: (self structByteArray: value)] raise: NBFFICalloutError. ! ! !NBPointerArgumentsTests methodsFor: 'enum pointers tests' stamp: 'IgorStasenko 7/12/2013 14:32'! testEnumCase3ByteArray self should: [self readEnumPtrCase3: (self enumByteArray: self class enumClass BBB)] raise: NBCodeGenerationError. ! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'CiprianTeodorov 3/16/2013 23:56'! testStructCase4Struct |value| value := 12345678. self assert: (self readStructPtrCase4: (self structValue: value)) = value.! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests arity 2' stamp: 'IgorStasenko 7/8/2013 17:38'! testArity2StructCase1Struct "normally this test should fail, but it crashes the VM, because NBExternalStructure is variable byte class that gets captured by +optAllowByteArraysPtr" self should: [(self arity2StructPtrCase1: (self structValue: 12345678)).] raise: NBFFICalloutError. ! ! !NBPointerArgumentsTests methodsFor: 'integer pointers tests' stamp: 'CiprianTeodorov 3/17/2013 00:07'! testIntCase1ByteArray |value| value := 12345. self assert: (self readIntPtrCase1: (self intByteArray: value)) = value. ! ! !NBPointerArgumentsTests methodsFor: 'integer pointers tests' stamp: 'CiprianTeodorov 3/17/2013 00:07'! testIntCase1ExternalAddress | value | value := 12345. self assert: (self readIntPtrCase1: (self intExternalAddress: value)) = value. ! ! !NBPointerArgumentsTests methodsFor: 'enum pointers tests' stamp: 'CiprianTeodorov 3/17/2013 00:37'! enumByteArray: aValue ^(self class enumArrayType with: aValue) address! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests arity 2' stamp: 'IgorStasenko 7/8/2013 17:38'! testArity2StructCase4Struct "normally this test should fail, but it crashes the VM, because NBExternalStructure is variable byte class that gets captured by +optAllowByteArraysPtr" self should: [(self arity2StructPtrCase4: (self structValue: 12345678))] raise: NBFFICalloutError. ! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'CiprianTeodorov 3/17/2013 09:30'! structExternalAddress: aValue ^(toBeFreed := self class structArrayType externalNew: 1) at: 1 put: (self structValue: aValue); address. ! ! !NBPointerArgumentsTests methodsFor: 'enum primitives' stamp: 'CiprianTeodorov 3/17/2013 00:34'! readEnumPtrCase4: arg "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveEnum: arg case: self case4.! ! !NBPointerArgumentsTests methodsFor: 'enum pointers tests' stamp: 'IgorStasenko 7/12/2013 14:32'! testEnumCase3ExternalAddress self should: [self readEnumPtrCase3: (self enumExternalAddress: self class enumClass BBB)] raise: NBCodeGenerationError. ! ! !NBPointerArgumentsTests methodsFor: 'enum primitives' stamp: 'CiprianTeodorov 3/17/2013 00:33'! readEnumPtrCase1: arg "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveEnum: arg case: self case1.! ! !NBPointerArgumentsTests methodsFor: 'struct primitives' stamp: 'CiprianTeodorov 3/17/2013 14:59'! primitiveArity2Struct: arg case: aCase ^ (self nbCalloutIn: thisContext sender) options: aCase; function: {#long. {self class structType. #*. #*. #arg} } emit: [:gen :proxy :asm | asm pop: asm ECX; "pointer to the structure *" mov: asm ECX ptr32 to: asm ECX; mov: asm ECX ptr + 4 to: asm EAX. "read the long value from NBTestStructure" ]! ! !NBPointerArgumentsTests methodsFor: 'integer primitives' stamp: 'CiprianTeodorov 3/16/2013 23:18'! readIntPtrCase4: anInt ^self primitiveInt: anInt case: self case4. ! ! !NBPointerArgumentsTests methodsFor: 'struct primitives' stamp: 'CiprianTeodorov 3/17/2013 14:55'! arity2StructPtrCase2: arg "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveArity2Struct: arg case: self case2.! ! !NBPointerArgumentsTests methodsFor: 'enum pointers tests' stamp: 'IgorStasenko 7/12/2013 14:33'! testEnumCase2ByteArray self should: [self readEnumPtrCase2: (self enumByteArray: self class enumClass BBB)] raise: NBCodeGenerationError. ! ! !NBPointerArgumentsTests methodsFor: 'integer pointers tests' stamp: 'CiprianTeodorov 3/17/2013 00:08'! testIntCase3ExternalAddress self should: [self readIntPtrCase3: (self intExternalAddress: 12345)] raise: NBFFICalloutError.! ! !NBPointerArgumentsTests methodsFor: 'struct primitives' stamp: 'CiprianTeodorov 3/16/2013 23:42'! readStructPtrCase3: aStruct "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveStruct: aStruct case: self case3.! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'IgorStasenko 7/12/2013 14:54'! testStructCase2ExternalAddress | value | value := 12345678. self should: [ self readStructPtrCase2: (self structExternalAddress: value) ] raise: NBFFICalloutError . ! ! !NBPointerArgumentsTests methodsFor: 'integer pointers tests' stamp: 'CiprianTeodorov 3/17/2013 00:07'! testIntCase2ByteArray self should: [self readIntPtrCase2: (self intByteArray: 12345)] raise: NBFFICalloutError ! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'IgorStasenko 7/12/2013 14:54'! testStructCase4ByteArray |value| value := 12345678. self should: [self readStructPtrCase4: (self structByteArray: value) ] raise: NBFFICalloutError . ! ! !NBPointerArgumentsTests methodsFor: 'running' stamp: 'CiprianTeodorov 3/17/2013 09:43'! tearDown toBeFreed ifNotNil: [ toBeFreed free. toBeFreed := nil ]! ! !NBPointerArgumentsTests methodsFor: 'integer pointers tests' stamp: 'CiprianTeodorov 3/17/2013 09:29'! intExternalAddress: aValue ^(toBeFreed := self class intArrayType externalNew: 1) at: 1 put: aValue; address. ! ! !NBPointerArgumentsTests methodsFor: 'integer pointers tests' stamp: 'IgorStasenko 7/5/2013 16:17'! testIntCase4ExternalAddress " see case4 for details " | address | address := NBExternalAddress value: 12345. self assert: (self readIntPtrCase4: address ) equals: address value ! ! !NBPointerArgumentsTests methodsFor: 'struct primitives' stamp: 'CiprianTeodorov 3/17/2013 14:15'! arity2StructPtrCase1: arg "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveArity2Struct: arg case: self case1.! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'CiprianTeodorov 3/16/2013 23:52'! testStructCase4ExternalAddress self should: [self readStructPtrCase4: (self structExternalAddress: 12345)] raise: NBFFICalloutError.! ! !NBPointerArgumentsTests methodsFor: 'struct primitives' stamp: 'CiprianTeodorov 3/16/2013 23:42'! readStructPtrCase4: aStruct "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveStruct: aStruct case: self case4.! ! !NBPointerArgumentsTests methodsFor: 'enum primitives' stamp: 'CiprianTeodorov 3/17/2013 00:34'! readEnumPtrCase2: arg "this is the default case where both optAllowByteArraysPtr optAllowExternalAddressPtr are enabled" ^self primitiveEnum: arg case: self case2.! ! !NBPointerArgumentsTests methodsFor: 'integer pointers tests' stamp: 'CiprianTeodorov 3/17/2013 00:08'! testIntCase4ByteArray |value| value := 12345. self assert: (self readIntPtrCase4: (self intByteArray: value)) = value.! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests arity 2' stamp: 'IgorStasenko 7/8/2013 17:38'! testArity2StructCase3Struct self should: [self arity2StructPtrCase3: (self structValue: 12345678)] raise: NBFFICalloutError. ! ! !NBPointerArgumentsTests methodsFor: 'struct primitives' stamp: 'CiprianTeodorov 3/17/2013 00:30'! primitiveStruct: aStruct case: aCase ^ (self nbCalloutIn: thisContext sender) options: aCase; function: {#long. {self class structType. #*. #aStruct} } emit: [:gen :proxy :asm | asm pop: asm ECX; "pointer to the structure" mov: asm ECX ptr + 4 to: asm EAX. "read the long value from NBTestStructure" ]! ! !NBPointerArgumentsTests methodsFor: 'generation options' stamp: 'IgorStasenko 7/5/2013 16:12'! case4 "allow only var-byte objects as pointer arguments. by turning off optAllowExternalAddressPtr this means that external address will be treated as any other var-byte object and therefore an address of memory where address value is held will be passed to function instead of address value " ^#( +optAllowByteArraysPtr -optAllowExternalAddressPtr )! ! !NBPointerArgumentsTests methodsFor: 'struct ptr tests' stamp: 'CiprianTeodorov 5/19/2013 03:45'! structValue: aValue ^(self class structClass new) long: aValue; yourself ! ! !NBPointerArgumentsTests class methodsFor: 'initialize - event' stamp: 'CiprianTeodorov 4/9/2013 21:54'! initialize self reset.! ! !NBPointerArgumentsTests class methodsFor: 'accessing' stamp: 'CiprianTeodorov 5/19/2013 03:45'! resources ^{NBTestResources}! ! !NBPointerArgumentsTests class methodsFor: 'array types' stamp: 'CiprianTeodorov 3/17/2013 00:25'! structArrayType ^StructArrayType isNil ifTrue: [StructArrayType := NBExternalArray ofType: self structType] ifFalse:[StructArrayType]! ! !NBPointerArgumentsTests class methodsFor: 'type classes' stamp: 'CiprianTeodorov 3/17/2013 00:18'! structClass ^NBTestStructure ! ! !NBPointerArgumentsTests class methodsFor: 'array types' stamp: 'CiprianTeodorov 3/17/2013 00:19'! intArrayType ^IntArrayType isNil ifTrue: [IntArrayType := NBExternalArray ofType: #NBInt32] ifFalse:[IntArrayType]! ! !NBPointerArgumentsTests class methodsFor: 'type classes' stamp: 'CiprianTeodorov 3/17/2013 00:18'! structType ^self structClass name ! ! !NBPointerArgumentsTests class methodsFor: 'array types' stamp: 'CiprianTeodorov 3/17/2013 00:29'! enumArrayType ^EnumArrayType isNil ifTrue: [EnumArrayType := NBExternalArray ofType: self enumType] ifFalse:[EnumArrayType]! ! !NBPointerArgumentsTests class methodsFor: 'accessing' stamp: 'CiprianTeodorov 4/9/2013 21:54'! reset EnumArrayType := nil. IntArrayType := nil. PtrArrayType := nil. StructArrayType := nil.! ! !NBPointerArgumentsTests class methodsFor: 'type classes' stamp: 'CiprianTeodorov 3/17/2013 00:29'! enumType ^self enumClass name ! ! !NBPointerArgumentsTests class methodsFor: 'array types' stamp: 'CiprianTeodorov 3/17/2013 15:01'! ptrArrayType ^PtrArrayType isNil ifTrue: [PtrArrayType := NBExternalArray ofType: 'void *'] ifFalse:[PtrArrayType]! ! !NBPointerArgumentsTests class methodsFor: 'type classes' stamp: 'CiprianTeodorov 3/17/2013 00:30'! enumClass ^NBTestEnumeration ! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! majorVersion ^majorVersion! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/9/2010 07:14'! selector ^ selector! ! !NBProxyFunction methodsFor: 'comparing' stamp: 'Igor.Stasenko 4/9/2010 07:13'! hash ^ selector hash! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! minorVersion ^minorVersion! ! !NBProxyFunction methodsFor: 'adding' stamp: 'Igor.Stasenko 4/29/2010 03:34'! address self assert: (index < NBInterpreterProxy functions size). self checkVersion. ^ NBInterpreterProxy fnAddressAt: index! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! majorVersion: anObject majorVersion := anObject! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! arguments: anObject arguments := anObject! ! !NBProxyFunction methodsFor: 'parsing' stamp: 'Igor.Stasenko 9/29/2010 09:24'! parseArguments: args " not userful, lets ignore it" " (args size = 1 and: [ args first == #void ]) ifTrue: [ arguments := #(). ^ self ]. arguments := args collect: [:type | ( #(sqInt sqIntPtr sqLong double charPtr voidPtr) includes: type ) ifFalse: [ self error: 'invalid argument type' ]. type ]"! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/9/2010 07:22'! selector: aSelector selector := aSelector! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! retType: anObject retType := anObject! ! !NBProxyFunction methodsFor: 'comparing' stamp: 'Igor.Stasenko 4/9/2010 07:14'! = object ^ self class == object class and: [ selector == object selector ]! ! !NBProxyFunction methodsFor: 'asserting' stamp: 'Igor.Stasenko 4/29/2010 07:36'! checkVersion "exclude basic functions, otherwise we enter an endless chicken and egg loop" minorVersion = 0 ifTrue: [ ^ self ]. self assert: (NBInterpreterProxy majorVersion = majorVersion and: [ NBInterpreterProxy minorVersion >= minorVersion]). ! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/9/2010 07:34'! index: anIndex index := anIndex! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! minorVersion: anObject minorVersion := anObject! ! !NBProxyFunction methodsFor: 'printing' stamp: 'IgorStasenko 5/11/2011 16:47'! printOn: aStream aStream print: selector. arguments ifNotNil: [ aStream space; print: arguments ]! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'IgorStasenko 8/3/2011 07:32'! requiresAlignment ^ requiresAlignment ~~ false! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! arguments ^arguments! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'IgorStasenko 8/3/2011 07:36'! requiresAlignment: aBool requiresAlignment := aBool! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'IgorStasenko 5/11/2011 16:50'! name ^ selector ! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! retType ^retType! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/9/2010 07:35'! index ^ index! ! !NBQSortCallback methodsFor: 'accessing' stamp: 'IgorStasenko 11/24/2012 15:30'! trunk ^ trunk! ! !NBQSortCallback methodsFor: 'accessing' stamp: 'IgorStasenko 11/24/2012 15:30'! index ^ index! ! !NBQSortCallback class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/13/2010 22:54'! fnSpec ^ #(int ( NBExternalAddress a, NBExternalAddress b))! ! !NBQSortCallback class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/8/2010 19:17'! callType ^ #cdecl! ! !NBRecursionDetect commentStamp: ''! i am used to detect recursion during code generation.. use me like following: NBRecursionDetect in: someMethod during: [ ... some block .. ]. if recursion is detected, while evaluating the block, then NBCodeGenRecursion error will be signaled. A recursion usually happens when generating code for some method requires generating code for very same method, and so it enters infinite loop! !NBRecursionDetect methodsFor: 'accessing' stamp: 'IgorStasenko 5/28/2012 05:40'! method ^ method! ! !NBRecursionDetect methodsFor: 'signalling' stamp: 'IgorStasenko 5/28/2012 05:35'! signalForMethod: aMethod method := aMethod. ^ self signal! ! !NBRecursionDetect methodsFor: 'exceptiondescription' stamp: 'IgorStasenko 5/28/2012 06:01'! defaultAction ^ false "false indicate no recursion"! ! !NBRecursionDetect methodsFor: 'public' stamp: 'IgorStasenko 5/28/2012 06:46'! check: aMethod method == aMethod ifTrue: [ self resume: true "recursion detected" ] ifFalse: [ self pass ]! ! !NBRecursionDetect class methodsFor: 'helper' stamp: 'IgorStasenko 5/28/2012 07:02'! in: aMethod during: aBlock (self signalForMethod: aMethod) ifTrue: [ ^ NBCodeGenRecursion signal: aMethod printString ]. ^ aBlock on: self do: [:ex | ex check: aMethod ].! ! !NBRecursionDetect class methodsFor: 'signalling' stamp: 'IgorStasenko 5/28/2012 05:41'! signalForMethod: aMethod ^ self new signalForMethod: aMethod ! ! !NBSTIndirectArgument methodsFor: 'accessing' stamp: 'CiprianTeodorov 5/18/2013 00:05'! emitLoad: gen | asm | asm := gen asm. argumentLoader emitLoad: gen to: asm EAX. gen optCheckIndirectArgBounds ifTrue: [ | typeOk boundsFailed endLabel oop | typeOk := asm uniqueLabelName: 'typeOk'. boundsFailed := asm uniqueLabelName: 'boundsFailed'. endLabel := asm uniqueLabelName: 'end'. oop := gen reserveTemp. asm mov: asm EAX to: oop. "type checking" gen proxy isPointers: oop. asm cmp: asm EAX with: 0 asImm. asm jne: typeOk. gen failWithMessage: 'Type checking failed on indirect argument loading'. asm label: typeOk. "bounds checking" "bigger than 0" elementIndex <= 0 ifTrue:[ ^self error: 'Bound checking failed on indirect argument loading. index should be bigger that 0.']. "smaller than slot size" gen proxy slotSizeOf: oop. asm cmp: asm EAX with: elementIndex asImm. asm jl: boundsFailed. asm mov: oop to: asm EAX. asm jmp: endLabel . asm label: boundsFailed. gen failWithMessage: 'Bound checking failed on indirect argument loading'. asm label: endLabel . ]. gen proxy fetchPointer: elementIndex - 1 ofObject: asm EAX. ^ asm EAX! ! !NBSTIndirectArgument methodsFor: 'accessing' stamp: 'cipt 10/24/2012 20:34'! elementIndex ^ elementIndex! ! !NBSTIndirectArgument methodsFor: 'accessing' stamp: 'cipt 10/24/2012 20:34'! argumentLoader: anObject argumentLoader := anObject! ! !NBSTIndirectArgument methodsFor: 'accessing' stamp: 'cipt 10/24/2012 20:34'! elementIndex: anObject elementIndex := anObject! ! !NBSTIndirectArgument methodsFor: 'accessing' stamp: 'cipt 10/24/2012 20:34'! emitLoad: gen to: operand self emitLoad: gen. operand = gen asm EAX ifFalse:[gen asm mov: gen asm EAX to: operand]! ! !NBSTIndirectArgument methodsFor: 'accessing' stamp: 'cipt 10/24/2012 20:34'! argumentLoader ^ argumentLoader! ! !NBSTIndirectArgument methodsFor: 'accessing' stamp: 'cipt 10/24/2012 20:39'! usesSTStack ^ argumentLoader usesSTStack! ! !NBSTIvarArgument commentStamp: 'Igor.Stasenko 4/30/2010 12:24'! This guy knows how to load a receiver's ivar. ! !NBSTIvarArgument methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/30/2010 14:33'! emitLoad: gen "emit instructions to load a function argument into default register (EAX for integral types, FP(0) for floating point)" | index | index := receiverClass allInstVarNames indexOf: ivarName. gen receiverArgumentLoader emitLoad: gen to: gen asm EAX. "receiver in EAX" gen proxy fetchPointer: index-1 ofObject: gen asm EAX. ^ gen asm EAX! ! !NBSTIvarArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 12:24'! receiverClass: anObject receiverClass := anObject! ! !NBSTIvarArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 12:24'! receiverClass ^receiverClass! ! !NBSTIvarArgument methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/30/2010 12:29'! emitLoad: gen to: operand "emit instructions to load a function argument into given operand" self emitLoad: gen. operand = gen asm EAX ifFalse: [ gen asm mov: gen asm EAX to: operand ] ! ! !NBSTIvarArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 12:24'! ivarName ^ivarName! ! !NBSTIvarArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 12:24'! ivarName: anObject ivarName := anObject! ! !NBSTIvarArgument methodsFor: 'testing' stamp: 'Igor.Stasenko 5/18/2010 02:22'! usesSTStack ^ true " to fetch receiver we accessing the stack"! ! !NBSTMethodArgument commentStamp: 'Igor.Stasenko 4/30/2010 10:47'! i know what to emit for loading a method's argument from VM stack into register ! !NBSTMethodArgument methodsFor: 'emitting the code' stamp: 'Igor.Stasenko 4/30/2010 07:25'! emitLoad: gen gen proxy stackValue: stackIndex. ^ gen asm EAX! ! !NBSTMethodArgument methodsFor: 'initialization' stamp: 'IgorStasenko 8/5/2011 18:00'! initialize isReceiver := false! ! !NBSTMethodArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 07:23'! stackIndex: anObject stackIndex := anObject! ! !NBSTMethodArgument methodsFor: 'accessing' stamp: 'IgorStasenko 8/5/2011 18:00'! isReceiver: aBool isReceiver := aBool ! ! !NBSTMethodArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 07:23'! stackIndex ^stackIndex! ! !NBSTMethodArgument methodsFor: 'emitting the code' stamp: 'Igor.Stasenko 4/30/2010 12:22'! emitLoad: gen to: operand "emit instructions to load a function argument into given operand" gen proxy stackValue: stackIndex. operand = gen asm EAX ifFalse: [ gen asm mov: gen asm EAX to: operand ] ! ! !NBSTMethodArgument methodsFor: 'accessing' stamp: 'IgorStasenko 8/5/2011 18:00'! isReceiver ^ isReceiver ! ! !NBSTMethodArgument methodsFor: 'testing' stamp: 'Igor.Stasenko 5/18/2010 02:22'! usesSTStack ^ true " to fetch receiver we accessing the stack"! ! !NBSTMethodArgument class methodsFor: 'errors' stamp: 'IgorStasenko 8/6/2011 18:20'! lastError ^ self error: 'NativeBoost plugin is missing?'! ! !NBSizeT commentStamp: ''! i implement marshalling for the size_t type. size_t value size depends on a platform's word size. on 32-bit it will be 32 bit. on 64-bit it will be 64 bit ! !NBSizeT class methodsFor: 'converting' stamp: 'IgorStasenko 9/3/2012 00:10'! asNBExternalType: gen self pointerSize = 4 ifTrue: [ ^ (gen resolveType: #uint32 ) ]. self pointerSize = 8 ifTrue: [ ^ (gen resolveType: #uint64 ) ]. self error: 'no clue'! ! !NBTCHAR commentStamp: 'Igor.Stasenko 4/29/2010 13:44'! - depending on context, acts either as char or wchar! !NBTCHAR class methodsFor: 'converting' stamp: 'Igor.Stasenko 5/1/2010 10:56'! asNBExternalType: gen ^ (gen optionAt: #WinUnicode) ifTrue: [ 'wchar_t' asNBExternalType: gen ] ifFalse: [ #uchar asNBExternalType: gen ] ! ! !NBTString commentStamp: 'Igor.Stasenko 4/29/2010 14:26'! - depending on context, acts either as char* or wchar* string! !NBTString class methodsFor: 'converting' stamp: 'Igor.Stasenko 5/1/2010 10:56'! asNBExternalType: gen ^ (gen optionAt: #WinUnicode) ifTrue: [ NBWideString asNBExternalType: gen ] ifFalse: [ NBExternalString asNBExternalType: gen ] ! ! !NBTestCallbackReturnEnum class methodsFor: 'as yet unclassified' stamp: 'CiprianTeodorov 12/11/2012 19:53'! fnSpec ^#(#NBTestEnumeration (NBInt32))! ! !NBTestCallbackReturnEnum1 class methodsFor: 'as yet unclassified' stamp: 'CiprianTeodorov 12/13/2012 20:14'! fnSpec ^#(#NBTestEnumerationFromPairs (NBInt32))! ! !NBTestEnumeration class methodsFor: 'as yet unclassified' stamp: 'CiprianTeodorov 12/11/2012 19:10'! enumDecl ^ {(#AAA -> 1). (#BBB -> 2). (#CCC -> 3). (#DDD -> 2400)} asDictionary ! ! !NBTestEnumerationFromPairs class methodsFor: 'as yet unclassified' stamp: 'CiprianTeodorov 12/13/2012 08:22'! enumDecl ^ #(AAA 1 BBB 2 CCC 3 DDD 2400) ! ! !NBTestExternalValue methodsFor: '*generated-code-non-existing-package' stamp: 'CiprianTeodorov 4/9/2013 19:46'! value "Note, this method used as a template for my anonymous subclasses. " ^ self emitRead! ! !NBTestExternalValue methodsFor: '*generated-code-non-existing-package' stamp: 'CiprianTeodorov 4/9/2013 19:46'! value: value "Note, this method used as a template for my anonymous subclasses. " ^ self emitWrite ! ! !NBTestExternalValue class methodsFor: 'class initialization' stamp: 'CiprianTeodorov 4/9/2013 21:07'! initialize self initValueType: 'int'.! ! !NBTestNestedStructure class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/26/2012 19:45'! fieldsDesc " self createAccessors " ^ #( NBTestStructure1byte oneByte; int otherField )! ! !NBTestResources methodsFor: 'running' stamp: 'CiprianTeodorov 5/19/2013 03:36'! setUp {NBTestNestedStructure. NBTestStructure. NBTestStructure1byte. NBTestStructure2. NBTestStructure9bytes. NBTestStructureWithCallback. NBTestUnion1Byte. NBTestUnion2Pointers. NBTestUnionIntSize. NBTestUnionWithCallback. NBTestUnionWithStructure. NBTestUnionWithUnion} do: [ :each | each perform: #rebuildFieldAccessors ]! ! !NBTestStructure class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/3/2012 01:44'! fieldsDesc " self rebuildFieldAccessors " ^ #( byte byte; short short; long long; float float; double double; int64 int64; )! ! !NBTestStructure1byte class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/3/2012 02:36'! fieldsDesc " self rebuildFieldAccessors " ^ #( byte field )! ! !NBTestStructure2 class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/3/2012 02:36'! fieldsDesc " self rebuildFieldAccessors " ^ #( NBExternalAddress addr )! ! !NBTestStructure9bytes class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/3/2012 02:36'! fieldsDesc " self rebuildFieldAccessors" ^ #( int x; int y; char field )! ! !NBTestStructureWithCallback class methodsFor: 'as yet unclassified' stamp: 'cipt 11/28/2012 19:10'! fieldsDesc " self rebuildFieldAccessors " ^ #( int x; NBQSortCallback callback; int y; )! ! !NBTestUnion1Byte class methodsFor: 'as yet unclassified' stamp: 'CiprianTeodorov 1/19/2013 17:28'! fieldsDesc " self rebuildFieldAccessors " ^#( byte field1 byte field2 )! ! !NBTestUnion2Pointers class methodsFor: 'as yet unclassified' stamp: 'CiprianTeodorov 1/19/2013 17:31'! fieldsDesc " self rebuildFieldAccessors " ^ #( NBExternalAddress addr1 NBExternalAddress addr2 )! ! !NBTestUnionIntSize class methodsFor: 'as yet unclassified' stamp: 'CiprianTeodorov 1/19/2013 17:33'! fieldsDesc " self rebuildFieldAccessors " ^ #( int x; int y; char field )! ! !NBTestUnionWithCallback class methodsFor: 'as yet unclassified' stamp: 'CiprianTeodorov 1/19/2013 17:36'! fieldsDesc " self rebuildFieldAccessors " ^ #( char x; NBQSortCallback callback; )! ! !NBTestUnionWithStructure class methodsFor: 'as yet unclassified' stamp: 'CiprianTeodorov 1/19/2013 17:38'! fieldsDesc " self rebuildFieldAccessors " ^ #( char x; NBTestStructure9bytes struct; int z; )! ! !NBTestUnionWithUnion class methodsFor: 'as yet unclassified' stamp: 'CiprianTeodorov 1/19/2013 17:43'! fieldsDesc " self rebuildFieldAccessors " ^ #( char x; NBTestUnionIntSize union; double z; )! ! !NBUInt16 commentStamp: ''! I responsible for marshalling unsigned 16-bit integer type values.! !NBUInt16 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:14'! coerceReturnValue: gen | asm | "convert signed short to ST integer" asm := gen asm. asm movzx: asm EAX with: asm AX. gen proxy integerObjectOf: asm EAX. ! ! !NBUInt16 methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 23:14'! valueSize ^ 2! ! !NBUInt16 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:14'! pushAsValue: gen gen asm push: (gen proxy positive32BitValueOf: (loader emitLoad: gen))! ! !NBUInt32 commentStamp: ''! I responsible for marshalling unsigned 32-bit integer type values.! !NBUInt32 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:17'! pushAsValue: gen | asm | asm := gen asm. asm push: (gen proxy positive32BitValueOf: (loader emitLoad: gen)). gen optCheckFailOnEveryArgument ifTrue: [ gen proxy ifFailedEmit: [ gen failWithMessage: 'Argument coercion failed: positive 32-bit integer value expected' ]. ].! ! !NBUInt32 methodsFor: 'emitting code' stamp: 'CiprianTeodorov 12/11/2012 19:22'! coerceOopToOperand: gen ifFailedJumpTo: aLabel " input: EAX - oop output: EAX - result of coercion " self assert: (pointerArity = 0). gen proxy positive32BitValueOf: gen asm EAX! ! !NBUInt32 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:17'! coerceReturnValue: gen | asm | "convert signed byte to ST integer" asm := gen asm. gen proxy positive32BitIntegerFor: asm EAX.! ! !NBUInt32 methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 23:17'! valueSize ^ 4! ! !NBUInt64 commentStamp: ''! I responsible for marshalling unsigned 64-bit integer type values.! !NBUInt64 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/3/2012 01:11'! readOop: memoryOperand generator: gen "emit code to read a value from given memory operand and convert it to a corresponding ST object" | asm | pointerArity > 0 ifTrue: [ asm mov: memoryOperand to: asm EAX. ^ self coerceReturn: gen ]. asm := gen asm. asm lea: asm EAX with: memoryOperand; mov: asm EAX ptr + 4 to: asm EDX; mov: asm EAX ptr to: asm EAX. self coerceReturn: gen ! ! !NBUInt64 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/3/2012 00:57'! coerceReturnValue: gen "convert 64-bit unsigned value in EAX:EDX to ST integer" gen proxy positive64BitIntegerFor ! ! !NBUInt64 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/3/2012 01:10'! loadMem: memoryOperand generator: gen self shouldNotImplement! ! !NBUInt64 methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 23:22'! valueSize ^ 8! ! !NBUInt64 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/3/2012 00:25'! pushAsValue: gen | asm | asm := gen asm. gen proxy positive64BitValueOf: (loader emitLoad: gen). asm push: asm EDX; push: asm EAX. gen optCheckFailOnEveryArgument ifTrue: [ gen proxy ifFailedEmit: [ gen failWithMessage: 'Argument coercion failed: unsigned 64-bit integer value expected' ]. ].! ! !NBUInt8 commentStamp: ''! I responsible for marshalling unsigned 8-bit integer type values.! !NBUInt8 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:12'! coerceReturnValue: gen | asm | "convert unsigned byte to ST integer" asm := gen asm. asm movzx: asm EAX with: asm AL. gen proxy integerObjectOf: asm EAX. ! ! !NBUInt8 methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 23:12'! valueSize ^ 1! ! !NBUInt8 methodsFor: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:12'! pushAsValue: gen gen asm push: ( gen proxy positive32BitValueOf: (loader emitLoad: gen)). ! ! !NBUTF8StringExample commentStamp: 'IgorStasenko 8/8/2011 17:29'! This is an example of defining custom type. This type accepts a string(s) and converts them into utf-8 representation on stack on the fly and then pushes the pointer to converted string to callee. UTF8TextConverter new convertFromSystemString: ( NBBasicExamples new encodeToUTF8: 'owehjfopeh fr´' asWideString)! !NBUTF8StringExample methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 7/23/2012 13:29'! prepareArgumentUsing: gen "prepare the ByteString argument. Allocate a space for string on stack, then copy string contents there and add terminating null character " | asm stringOop len loop done donePreparing notNil moreThanOne moreThanTwo moreThanThree typeCheck | asm := gen asm. typeCheck := asm uniqueLabelName: 'ok'. loop := asm uniqueLabelName: 'loop'. done := asm uniqueLabelName: 'done'. notNil := asm uniqueLabelName: 'notNil'. donePreparing := asm uniqueLabelName: 'donePreparing'. moreThanOne := asm uniqueLabelName: 'moreThanOne'. moreThanTwo := asm uniqueLabelName: 'moreThanTwo'. moreThanThree := asm uniqueLabelName: 'moreThanThree'. loader emitLoad: gen. "reserve after emitting load, otherwise, if proxy using stackpointer temp, it will be clobbered" address := gen reserveTemp. stringOop := gen reserveTemp. len := gen reserveTemp. asm mov: EAX to: stringOop. gen optStringOrNull ifTrue: [ "allow passing nil as string, effectively will push null pointer as argument" gen proxy nilObject. asm cmp: EAX with: stringOop; jne: notNil; mov: 0 to: address; "null pointer" jmp: donePreparing. ]. asm label: notNil. gen proxy isWords: stringOop. asm or: EAX with: EAX. asm jne: typeCheck. gen failWithMessage: 'WideString instance expected'. asm label: typeCheck. gen proxy slotSizeOf: stringOop. asm mov: EAX to: len. "len*4 +1 - the total number of bytes to reserve on stack" asm shl: EAX with: 2; inc: EAX. gen reserveStackBytes: EAX andStoreAddrTo: address. gen proxy firstIndexableField: stringOop. asm decorateWith: ' copy string contents to the stack ' during: [ asm push: ESI; push: EDI; mov: EAX to: ESI; mov: address to: EDI; mov: len to: ECX; label: loop; dec: ECX; jl: done; "load the unicode value" mov: ESI ptr to: EAX; cmp: EAX with: 16r7F; jg: moreThanOne; "one byte" mov: AL to: EDI ptr; inc: EDI; add: ESI with: 4; jmp: loop; label: moreThanOne; cmp: EAX with: 16r7FF; jg: moreThanTwo; "two bytes" mov: EAX to: EDX; shr: EDX with: 6; or: DL with: 16rC0 asUImm; mov: DL to: EDI ptr; inc: EDI; and: AL with: 2r111111; or: AL with: 16r80 asUImm; mov: AL to: EDI ptr; inc: EDI; add: ESI with: 4; jmp: loop; label: moreThanTwo; cmp: EAX with: 16rFFFF; jg: moreThanThree; "three bytes" mov: EAX to: EDX; shr: EDX with: 12; or: DL with: 2r11100000 asUImm; mov: DL to: EDI ptr; inc: EDI; mov: EAX to: EDX; shr: EDX with: 6; and: DL with: 2r111111; or: DL with: 16r80 asUImm; mov: DL to: EDI ptr; inc: EDI; and: AL with: 2r111111; or: AL with: 16r80 asUImm; mov: AL to: EDI ptr; inc: EDI; add: ESI with: 4; jmp: loop; label: moreThanThree; cmp: EAX with: 16r1FFFFF; jg: gen failedLabel; "no more than 4 bytes!!" "4 bytes" mov: EAX to: EDX; shr: EDX with: 18; or: DL with: 2r11110000 asUImm; mov: DL to: EDI ptr; inc: EDI; mov: EAX to: EDX; shr: EDX with: 12; and: DL with: 2r111111; or: DL with: 16r80 asUImm; mov: DL to: EDI ptr; inc: EDI; mov: EAX to: EDX; shr: EDX with: 6; and: DL with: 2r111111; or: DL with: 16r80 asUImm; mov: DL to: EDI ptr; inc: EDI; and: AL with: 2r111111; or: AL with: 16r80 asUImm; mov: AL to: EDI ptr; inc: EDI; add: ESI with: 4; jmp: loop; label: done; mov: 0 to: EDI ptr8; "store null-terminating character" pop: EDI; pop: ESI. ]. gen releaseTemps: 2. "keep the address reserved, otherwise it will be clobbered" asm label: donePreparing! ! !NBUTF8StringExample methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/6/2011 16:04'! pushAsValue: gen gen asm push: address. ! ! !NBUnixConstants class methodsFor: 'initialization' stamp: 'Igor.Stasenko 9/25/2010 06:57'! initialize " self initialize " "from " self initDlopenFlags; initMmapFlags! ! !NBUnixConstants class methodsFor: 'initialization' stamp: 'Igor.Stasenko 9/25/2010 08:37'! initDlopenFlags "From " " The MODE argument to `dlopen' contains one of the following: " RTLD_LAZY := 16r00001. "Lazy function call binding." RTLD_NOW := 16r00002. " Immediate function call binding. " RTLD_BINDING_MASK := 16r3. " Mask of binding time value. " RTLD_NOLOAD := 16r00004. " Do not load the object." RTLD_DEEPBIND := 16r00008. " Use deep binding. " " If the following bit is set in the MODE argument to `dlopen', the symbols of the loaded object and its dependencies are made visible as if the object were linked directly into the program. " RTLD_GLOBAL := 16r00100. " Unix98 demands the following flag which is the inverse to RTLD_GLOBAL. The implementation does this by default and so we can define the value to zero. " RTLD_LOCAL := 0. " Do not delete object when closed. " RTLD_NODELETE := 16r01000. " From " " If the first argument of `dlsym' or `dlvsym' is set to RTLD_NEXT the run-time address of the symbol called NAME in the next shared object is returned. The 'next' relation is defined by the order the shared objects were loaded. " RTLD_NEXT := 16rFFFFFFFF. " ((void *) -1l) " " If the first argument to `dlsym' or `dlvsym' is set to RTLD_DEFAULT the run-time address of the symbol called NAME in the global scope is returned. " RTLD_DEFAULT := 0. ! ! !NBUnixConstants class methodsFor: 'initialization' stamp: 'Igor.Stasenko 9/25/2010 09:12'! initMmapFlags "From " " Memory protection flags, can be bitored " PROT_READ := 16r1. " Page can be read. " PROT_WRITE := 16r2. " Page can be written. " PROT_EXEC := 16r4. " Page can be executed. " PROT_NONE := 16r0. " Page can not be accessed. " PROT_GROWSDOWN := 16r01000000. " Extend change to start of growsdown vma (mprotect only). " PROT_GROWSUP := 16r02000000. "Extend change to start of growsup vma (mprotect only). " " Sharing types (must choose one and only one of these). " MAP_SHARED := 16r01. "Share changes." MAP_PRIVATE := 16r02. "Changes are private." MAP_TYPE := 16r0f. "Mask for type of mapping. " " Other flags. " MAP_FIXED := 16r10. "Interpret addr exactly. " MAP_FILE := 0. MAP_ANONYMOUS := 16r20. "Don't use a file." MAP_ANON := MAP_ANONYMOUS. MAP_32BIT := 16r40. "Only give out 32-bit addresses." "These are Linux-specific." MAP_GROWSDOWN := 16r00100. "Stack-like segment." MAP_DENYWRITE := 16r00800. " ETXTBSY " MAP_EXECUTABLE := 16r01000. " Mark it as an executable." MAP_LOCKED := 16r02000. " Lock the mapping. " MAP_NORESERVE := 16r04000. " Don't check for reservations. " MAP_POPULATE := 16r08000. " Populate (prefault) pagetables. " MAP_NONBLOCK := 16r10000. " Do not block on IO." MAP_STACK := 16r20000. " Allocation is for a stack. " MAP_FAILED := 16rFFFFFFFF. "-1"! ! !NBUnixExternalHeapManager commentStamp: 'Igor.Stasenko 9/26/2010 04:05'! Unix heap implementation, based on mmap()/munmap() functions to manage external heap.! !NBUnixExternalHeapManager methodsFor: 'memory pages' stamp: 'Igor.Stasenko 9/26/2010 03:37'! primAllocatePage: bytesToAllocate | ptr buf | buf := ByteArray new: 4. self mmapLength: bytesToAllocate prot: self protFlags flags: self mapFlags into: buf. ptr := buf unsignedLongAt: 1 bigEndian: false. ptr = MAP_FAILED ifTrue: [ self error: 'Unable to map virtual memory' ]. ^ ptr ! ! !NBUnixExternalHeapManager methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 17:24'! mmapLength: bytesToAllocate prot: protFlags flags: mapFlags into: returnValueBuffer "Note: mmap using 32-bit offset, while mmap64 - 64bit one" ^ self nbCallout options: #( - optDirectProxyFnAddress ); function: #( NBBootstrapUlong ( 0, uint bytesToAllocate, int protFlags, int mapFlags, -1, 0 "offset" ) ) emit: [:gen | | mmap | mmap := NativeBoost forCurrentPlatform getGlobalSymbolPointer: 'mmap'. gen asm mov: mmap asUImm32 to: gen asm EAX. gen asm call: gen asm EAX ] ! ! !NBUnixExternalHeapManager methodsFor: 'flags' stamp: 'Igor.Stasenko 9/25/2010 08:49'! mapFlags ^ MAP_ANON bitOr: MAP_PRIVATE! ! !NBUnixExternalHeapManager methodsFor: 'flags' stamp: 'Igor.Stasenko 9/26/2010 03:51'! protFlags "since NativeBoost using heap for placing executable code there, it is important that all allocated memory should be executable" ^ (PROT_READ bitOr: PROT_WRITE) bitOr: PROT_EXEC! ! !NBUnixExternalHeapManager methodsFor: 'memory pages' stamp: 'Igor.Stasenko 9/26/2010 03:45'! primFreePage: aMemoryPage "call munmap()" | res | res := self unmap: aMemoryPage address length: aMemoryPage length. res = 0 ifFalse: [ self error: 'error during unmapping virtual memory page' ]! ! !NBUnixExternalHeapManager methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 17:25'! unmap: addr length: len "unmap memory page" ^ self nbCallout function: #( int munmap (uint addr, ulong len) ) module: RTLD_DEFAULT ! ! !NBUnixSpecificTest class methodsFor: 'testing' stamp: 'TorstenBergmann 8/7/2013 12:12'! isAbstract "only run test subclasses on Unix" ^(self name = #NBUnixSpecificTest) or: [ OSPlatform isUnix not ]! ! !NBVoid methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/15/2012 21:13'! valueSize pointerArity < 1 ifTrue: [^self error: 'void has unknown size']. ^self pointerSize ! ! !NBVoid methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/11/2010 02:30'! coerceOopToOperand: gen ifFailedJumpTo: aLabel "coerce a object - oop , provided by loader and then put a result into an appropriate operand (memory/register), answer that operand" pointerArity = 0 ifTrue: [ ^ self . "returning void, do nothing " ]. self shouldBeImplemented ! ! !NBVoid methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/3/2010 14:00'! coerceReturnValue: gen "just return nil" gen proxy nilObject ! ! !NBVoid methodsFor: 'emitting code' stamp: 'IgorStasenko 9/3/2012 00:14'! pushAsValue: gen self error: 'pushing void ... puff... done!!'! ! !NBWeakFinalizerItem methodsFor: 'public API' stamp: 'IgorStasenko 6/2/2012 15:23'! doNotFinalize "send this message to avoid triggering finalization, once weakly-referenced object is dead" executor := nil.! ! !NBWeakFinalizerItem methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 03:56'! list: aList index: i freeIndex: nextFreeIndex list := aList. index := i. next := nextFreeIndex ! ! !NBWeakFinalizerItem methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 03:49'! markAsFree: oldFreeIndex next := oldFreeIndex. executor := nil. "to make sure" self basicAt: 1 put: nil.! ! !NBWeakFinalizerItem methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 03:15'! index: aNumber index := aNumber! ! !NBWeakFinalizerItem methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 04:00'! object: anObject executor: ex executor := ex. self basicAt: 1 put: anObject! ! !NBWeakFinalizerItem methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 03:48'! nextFreeIndex ^ next! ! !NBWeakFinalizerItem methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 03:15'! index ^ index! ! !NBWin32Caret class methodsFor: 'accessing' stamp: 'tbn 8/6/2013 22:20'! getBlinkTime "Returns the elapsed time, in milliseconds, required to invert the caret's pixels. The user can set this value using the Control Panel." ^ NBFFICallout stdcall: #( uint GetCaretBlinkTime()) module: #user32 ! ! !NBWin32Handle commentStamp: ''! Instances of this class represent a reference value to a Win32 resource (file, window, ...)! !NBWin32Handle methodsFor: 'conversion' stamp: 'Igor.Stasenko 5/18/2010 22:56'! asUnsignedLong ^ handle asUnsignedLong! ! !NBWin32Handle methodsFor: 'call convention' stamp: 'IgorStasenko 11/25/2012 14:16'! nbCallingConvention ^ #stdcall! ! !NBWin32Handle methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/17/2010 05:02'! value: uint handle value: uint! ! !NBWin32Hdc methodsFor: 'operations' stamp: 'IgorStasenko 11/25/2012 14:17'! rectangleLeft: nLeftRect top: nTopRect right: nRightRect bottom: nBottomRect ^self nbCall: #(BOOL Rectangle( HDC self , int nLeftRect, int nTopRect, int nRightRect, int nBottomRect)) module: #gdi32 ! ! !NBWin32Hdc methodsFor: 'operations' stamp: 'IgorStasenko 11/25/2012 14:17'! lineToX: nXEnd y: nYEnd ^self nbCall: #(BOOL LineTo(HDC self, int nXEnd, int nYEnd)) module: #gdi32 ! ! !NBWin32Hdc methodsFor: 'operations' stamp: 'IgorStasenko 11/25/2012 14:17'! moveToX: x y: y ^self nbCall: #(BOOL MoveToEx(HDC self, int x, int y, 0)) module: #gdi32 ! ! !NBWin32Heap methodsFor: 'win heap api' stamp: 'IgorStasenko 11/24/2012 17:30'! alloc: numberOfBytes ^ self nbCall: #( LPVOID HeapAlloc (self , 0 , SIZE_T numberOfBytes) )! ! !NBWin32Heap methodsFor: 'win heap api' stamp: 'IgorStasenko 11/24/2012 17:31'! free: lpMem "The HeapFree function frees a memory block allocated from a heap by the HeapAlloc or HeapReAlloc function. " ^ self nbCall: #( BOOL HeapFree (self, 0, LPVOID lpMem) )! ! !NBWin32Heap methodsFor: 'win heap api' stamp: 'IgorStasenko 11/24/2012 17:32'! sizeOf: lpMem "The HeapSize function retrieves the size of a memory block allocated from a heap by the HeapAlloc or HeapReAlloc function." ^ self nbCall: #( SIZE_T HeapSize (self, 0 , LPCVOID lpMem) ) ! ! !NBWin32Heap methodsFor: 'win heap api' stamp: 'IgorStasenko 11/24/2012 17:31'! destroy ^ self nbCall: #( BOOL HeapDestroy (self) )! ! !NBWin32Heap methodsFor: 'win heap api' stamp: 'Igor.Stasenko 5/3/2010 02:05'! privSetHandle: aHandle "do not use, if you not sure what you doing" handle := aHandle! ! !NBWin32Heap methodsFor: 'win heap api' stamp: 'IgorStasenko 11/24/2012 17:32'! validate ^ self nbCall: #( BOOL HeapValidate (self) )! ! !NBWin32Heap methodsFor: 'win heap api' stamp: 'IgorStasenko 11/24/2012 17:32'! unlock ^ self nbCall: #( BOOL HeapUnlock (self) ) ! ! !NBWin32Heap methodsFor: 'win heap api' stamp: 'IgorStasenko 11/24/2012 17:33'! zalloc: numberOfBytes "same as #alloc: but additionally zero-fill the allocated memory" ^ self nbCall: #( LPVOID HeapAlloc (self , HEAP_ZERO_MEMORY , SIZE_T numberOfBytes) ) ! ! !NBWin32Heap methodsFor: 'win heap api' stamp: 'IgorStasenko 11/24/2012 17:32'! lock ^ self nbCall: #( BOOL HeapLock (self) )! ! !NBWin32Heap methodsFor: 'win heap api' stamp: 'IgorStasenko 11/24/2012 17:31'! compact "The HeapCompact function attempts to compact a specified heap. It compacts the heap by coalescing adjacent free blocks of memory and decommitting large free blocks of memory." ^ self nbCall: #( SIZE_T HeapCompact (self , 0) )! ! !NBWin32Heap methodsFor: 'call convention' stamp: 'IgorStasenko 11/24/2012 17:29'! nbCallingConvention ^ #stdcall! ! !NBWin32Heap methodsFor: 'call convention' stamp: 'IgorStasenko 11/24/2012 17:30'! nbLibraryNameOrHandle ^ #Kernel32! ! !NBWin32Heap methodsFor: 'win heap api' stamp: 'IgorStasenko 11/24/2012 17:32'! realloc: flags mem: lpMem size: dwBytes ^ self nbCall: #( LPVOID HeapReAlloc (self, DWORD flags, LPVOID lpMem, SIZE_T dwBytes) ) ! ! !NBWin32Heap class methodsFor: 'instance creation' stamp: 'IgorStasenko 11/24/2012 17:35'! create: options initialiSize: dwInitialSize maximumSize: dwMaximumSize ^ self nbCallout stdcall function: #( NBWin32Heap HeapCreate ( DWORD options, SIZE_T dwInitialSize, SIZE_T dwMaximumSize) ) module: #Kernel32 ! ! !NBWin32MessageBox class methodsFor: 'instance creation' stamp: 'tbn 11/11/2012 20:00'! test self messageBox: NBWin32Window getFocus text: 'Hello from Pharo' title: 'Pharo' flags: MB_YESNO! ! !NBWin32MessageBox class methodsFor: 'instance creation' stamp: 'IgorStasenko 11/25/2012 14:49'! messageBox: hWnd text: lpText title: lpCaption flags: uType ^ self nbCallout stdcall function: #(int MessageBoxA( HWND hWnd, LPCTSTR lpText, LPCTSTR lpCaption, UINT uType )) module: #user32! ! !NBWin32Point class methodsFor: 'accessing' stamp: 'TorstenBergmann 8/7/2013 12:42'! fieldsDesc " self rebuildFieldAccessors " ^ #( long x; long y; )! ! !NBWin32Point class methodsFor: 'instance creation' stamp: 'TorstenBergmann 8/7/2013 13:08'! x: x y: y ^(self new) x: x; y: y; yourself! ! !NBWin32PointTest methodsFor: 'tests' stamp: 'TorstenBergmann 8/7/2013 13:16'! testInstanceCreation |p| p := (NBWin32Point x: 1 y: 5). self assert: p x = 1. self assert: p y = 5! ! !NBWin32Process methodsFor: 'testing' stamp: 'TorstenBergmann 8/13/2013 22:41'! isNormalPriorityClass "Indicates a normal process with no special scheduling needs" ^self getPriorityClass == NORMAL_PRIORITY_CLASS ! ! !NBWin32Process methodsFor: 'accessing' stamp: 'TorstenBergmann 8/13/2013 22:27'! getPriorityClass "Return the priority class for the specified process" ^NBFFICallout stdcall: #( DWORD GetPriorityClass(HANDLE self)) module: #kernel32 ! ! !NBWin32Process methodsFor: 'testing' stamp: 'TorstenBergmann 8/13/2013 22:41'! isRealtimePriorityClass "Indicates a process that has the highest possible priority. The threads of a real-time priority class process preempt the threads of all other processes, including operating system processes performing important tasks." ^self getPriorityClass == REALTIME_PRIORITY_CLASS ! ! !NBWin32Process methodsFor: 'testing' stamp: 'TorstenBergmann 8/13/2013 22:39'! isHighPriorityClass "Indicates a process that performs time-critical tasks that must be executed immediately for it to run correctly." ^self getPriorityClass == HIGH_PRIORITY_CLASS ! ! !NBWin32Process methodsFor: 'testing' stamp: 'TorstenBergmann 8/13/2013 22:40'! isIdlePriorityClass "Indicates a process whose threads run only when the system is idle and are preempted by the threads of any process running in a higher priority class. An example is a screen saver. The idle priority class is inherited by child processes." ^self getPriorityClass == IDLE_PRIORITY_CLASS ! ! !NBWin32Process class methodsFor: 'accessing' stamp: 'TorstenBergmann 8/13/2013 22:19'! getCurrentProcess "Return an instance with a pseudohandle for the current process." ^ NBFFICallout stdcall: #( NBWin32Process GetCurrentProcess()) module: #kernel32 ! ! !NBWin32Process class methodsFor: 'accessing' stamp: 'TorstenBergmann 8/13/2013 22:22'! getCurrentProcessId "Returns the process identifier (PID) of the calling process." ^ NBFFICallout stdcall: #( DWORD GetCurrentProcessId()) module: #kernel32 ! ! !NBWin32Rectangle class methodsFor: 'accessing' stamp: 'TorstenBergmann 8/13/2013 20:32'! fieldsDesc "self rebuildFieldAccessors " ^ #( long left; long top; long right; long bottom; )! ! !NBWin32Shell class methodsFor: 'accessing-64bit' stamp: 'tbn 11/9/2012 22:31'! getCommonProgramFilesX86 "Return the common program files x86. typically this is C:\Program Files (x86)\Common Files self getCommonProgramFilesX86 " ^self getEnvironmentVariable: 'COMMONPROGRAMFILES(x86)'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:34'! showInternetSettingsGeneral " self showInternetSettingsGeneral " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Inetcpl.cpl,,0'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:35'! showJoystickSettings " self showJoystickSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL joy.cpl'! ! !NBWin32Shell class methodsFor: 'file system' stamp: 'tbn 11/9/2012 22:30'! getTmpDirectory "Return the name of the temp directory. self getTmpDirectory " ^self getEnvironmentVariable: 'TMP'! ! !NBWin32Shell class methodsFor: 'debugging' stamp: 'tbn 11/9/2012 22:07'! outputDebugString: lpOutputString "Sends a string to the debugger for display. Use tools like DebugView to display" ^self nbCall: #(void OutputDebugStringA(LPCTSTR lpOutputString)) module: #Kernel32 ! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showProgramPropertiesInstallUninstall " self showProgramPropertiesInstallUninstall " ^self shellRunDLL: 'shell32.dll,Control_RunDLL appwiz.cpl,,1'! ! !NBWin32Shell class methodsFor: 'display' stamp: 'TorstenBergmann 8/8/2013 15:31'! getScreenHeight "Returns the the vertical screen size" ^self getSystemMetrics: SM_CYSCREEN ! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:33'! showDisplaySettingsScreenSaver " self showDisplaySettingsScreenSaver " ^self shellRunDLL: 'shell32.dll,Control_RunDLL desk.cpl,,1'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:34'! showInternationalSettingsNumber "Show the internation settings dialog for number. self showInternationalSettingsNumber " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Intl.cpl,,1'! ! !NBWin32Shell class methodsFor: 'accessing' stamp: 'tbn 11/9/2012 22:28'! getApplicationDataFolder "Return the folder for application data self getApplicationDataFolder " ^self getEnvironmentVariable: 'APPDATA'! ! !NBWin32Shell class methodsFor: 'api calls' stamp: 'tbn 11/9/2012 22:09'! shellExecute: hwnd operation: lpOperation file: lpFile parameters: lpParameters directory: lpDirectory show: nShowCmd ^ self nbCall: #( HINSTANCE ShellExecuteA( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFile, LPCTSTR lpParameters, LPCTSTR lpDirectory, INT nShowCmd)) module: 'Shell32.dll' ! ! !NBWin32Shell class methodsFor: 'file system' stamp: 'tbn 11/9/2012 22:29'! getPathEntries "Return the PATH entries" ^(self getEnvironmentVariable: 'PATH') findTokens: $;! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:33'! showFontsProperties " self showFontsProperties " ^self shellRunDLL: 'shell32.dll,Control_RunDLL main.cpl @3'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:37'! showTelephonySettings " self showTelephonySettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL telephon.cpl' ! ! !NBWin32Shell class methodsFor: 'display' stamp: 'TorstenBergmann 8/8/2013 15:31'! getScreenSize "returns the current screen size Return Value: A point representing the current screen size " |x y| x := self getScreenWidth. y := self getScreenHeight. ^x@y! ! !NBWin32Shell class methodsFor: 'display' stamp: 'TorstenBergmann 8/8/2013 15:31'! getScreenWidth "Returns the the horizontal screen size" ^self getSystemMetrics: SM_CXSCREEN ! ! !NBWin32Shell class methodsFor: 'operations' stamp: 'tbn 11/9/2012 22:12'! shellOpen: file " self shellOpen: 'c:\pharo.pdf' " ^self shellExecute: 'open' file: file parameters: '' directory: '' show: SW_SHOW! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showPrinterManagementFolder " self showPrinterManagementFolder " ^self shellRunDLL: 'Shell32.dll,SHHelpShortcuts_RunDLL PrintersFolder'! ! !NBWin32Shell class methodsFor: 'computer' stamp: 'tbn 11/9/2012 22:29'! getComputerName "Return the name of the computer. self getComputerName " ^self getEnvironmentVariable: 'COMPUTERNAME'! ! !NBWin32Shell class methodsFor: 'accessing' stamp: 'TorstenBergmann 12/20/2012 10:14'! getEnvironmentVariable: variableName "Return the value of the given environment variable" ^ self nbCall: #( String getenv (String variableName) ) module: NativeBoost CLibrary! ! !NBWin32Shell class methodsFor: 'api calls' stamp: 'TorstenBergmann 8/8/2013 20:33'! getInetIsOffline: dwFlags "Retrieves the specified system metric or system configuration setting." ^NBFFICallout stdcall: #(BOOL InetIsOffline(DWORD dwFlags)) module: 'url.dll' ! ! !NBWin32Shell class methodsFor: 'file system' stamp: 'tbn 11/9/2012 22:29'! getHomeDrive "Return the drive letter of the home drive. self getHomeDrive " ^self getEnvironmentVariable: 'HOMEDRIVE'! ! !NBWin32Shell class methodsFor: 'cpu' stamp: 'tbn 11/9/2012 22:29'! getProcessorLevel "Return the model number of the computer's processor. self getProcessorLevel " ^self getEnvironmentVariable: 'PROCESSOR_LEVEL'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:33'! showDisplaySettingsBackground " self showDisplaySettingsBackground " ^self shellRunDLL: 'shell32.dll,Control_RunDLL desk.cpl,,0'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showAccessibilityCommonSettings "Show the common settings for accessibility self showAccessibilityCommonSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL access.cpl,,5'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:34'! showInternetExplorerFavoriteManager " self showInternetExplorerFavoriteManager " ^self shellRunDLL: 'shdocvw.dll,DoOrganizeFavDlg'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:33'! showInternationalSettingsInputLocales "Show the internation settings for input locales. self showInternationalSettingsInputLocales " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Intl.cpl,,5'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:33'! showHotPlugRemoveDialog " self showHotPlugRemoveDialog " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL HotPlug.dll'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showControlPanel " self showControlPanel " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL'! ! !NBWin32Shell class methodsFor: 'file system' stamp: 'tbn 11/9/2012 22:29'! getHomePath "Return the home path. Typically this is \Documents and Settings\{username} self getHomePath " ^self getEnvironmentVariable: 'HOMEPATH'! ! !NBWin32Shell class methodsFor: 'api calls' stamp: 'tbn 8/6/2013 22:31'! getCommandLine "Returns command-line string for the current process" ^self nbCall: #(NBTString GetCommandLineA()) module: #kernel32 ! ! !NBWin32Shell class methodsFor: 'user' stamp: 'tbn 11/9/2012 22:30'! getUserDomain "Return the name of the domain that contains the user’s account. self getUserDomain " ^self getEnvironmentVariable: 'USERDOMAIN'! ! !NBWin32Shell class methodsFor: 'accessing' stamp: 'tbn 11/9/2012 22:28'! getAllUsersProfileFolder "Return the profile path for all users. typically this is C:\Documents and Settings\All Users self getAllUsersProfileFolder " ^self getEnvironmentVariable: 'ALLUSERSPROFILE'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showAddPrinterWizard " self showAddPrinterWizard " ^self shellRunDLL: 'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter' ! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:34'! showInternationalSettingsTime "Show the internation settings for input locales. self showInternationalSettingsTime " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Intl.cpl,,3'! ! !NBWin32Shell class methodsFor: 'file system' stamp: 'tbn 11/9/2012 22:29'! getPathExtensions "Returns a list of the file extensions that the OS considers to be executable. self getPathExtensions " ^self getEnvironmentVariable: 'PATHEXT'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:34'! showInternationalSettingsRegionalSettings "Show the regional and language settings. self showInternationalSettingsRegionalSettings " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Intl.cpl,,0'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:33'! showInternationalSettingsCurrency " self showInternationalSettingsCurrency " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Intl.cpl,,2'! ! !NBWin32Shell class methodsFor: 'api calls' stamp: 'tbn 11/12/2012 09:50'! primGetDriveType: lpRootPathName " self getDriveType: 'c:\' " ^ self nbCall: #(UINT GetDriveTypeA(LPCTSTR lpRootPathName)) module: #kernel32! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:35'! showMapNetworkDriveWizard " self showMapNetworkDriveWizard " ^self shellRunDLL: 'Shell32.dll,SHHelpShortcuts_RunDLL Connect'! ! !NBWin32Shell class methodsFor: 'user' stamp: 'tbn 11/9/2012 22:30'! getUserName "Return the name of the logged in user self getUserName " ^self getEnvironmentVariable: 'USERNAME'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showAccessibilityKeyboardSettings "Show the keyboard settings for Windows accessibility self showAccessibilityKeyboardSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL access.cpl,,1'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:37'! showSystemSettings "Show the system settings. Note that the argument zero opens the first tab. self showSystemSettings " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Sysdm.cpl,,0'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:35'! showMultimediaSettingsCDMusic " self showMultimediaSettingsCDMusic " ^self shellRunDLL: 'shell32.dll,Control_RunDLL mmsys.cpl,,3'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showDateTimePropertiesTimezone " self showDateTimePropertiesTimezone " ^self shellRunDLL: 'shell32.dll,Control_RunDLL timedate.cpl,,/f'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showProgramPropertiesWindowsSetup " self showProgramPropertiesWindowsSetup " ^self shellRunDLL: 'shell32.dll,Control_RunDLL appwiz.cpl,,2'! ! !NBWin32Shell class methodsFor: 'network' stamp: 'TorstenBergmann 8/8/2013 20:44'! isInternetOffline ^self getInetIsOffline: 0! ! !NBWin32Shell class methodsFor: 'keyboard' stamp: 'TorstenBergmann 8/8/2013 13:57'! getKeyboardType |types res| types := #( 'IBM PC/XT or compatible (83-key) keyboard' 'Olivetti "ICO" (102-key) keyboard' 'IBM PC/AT (84-key) or similar keyboard' 'IBM enhanced (101- or 102-key) keyboard' 'Nokia 1050 and similar keyboards' 'Nokia 9140 and similar keyboards' 'Japanese keyboard'). res := (self getKeyboardType: 0). ^res <= types size ifTrue: [ types at: res ] ifFalse: [ '' ]! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:35'! showMultimediaSettingsDevices " self showMultimediaSettingsDevices " ^self shellRunDLL: 'shell32.dll,Control_RunDLL mmsys.cpl,,4'! ! !NBWin32Shell class methodsFor: 'computer' stamp: 'TorstenBergmann 8/8/2013 15:28'! getBootType "Returns the boot type as a string. self getBootType " ^#('Normal' 'Fail-safe' 'Fail-safe with network') at: (self getSystemMetrics: SM_CLEANBOOT) + 1 ! ! !NBWin32Shell class methodsFor: 'file system' stamp: 'tbn 11/9/2012 22:30'! getTempDirectory "Return the name of the temp directory. self getTempDirectory " ^self getEnvironmentVariable: 'TEMP'! ! !NBWin32Shell class methodsFor: 'network' stamp: 'TorstenBergmann 8/8/2013 13:58'! getLogonServer "Returns the users logon server self getLogonServer " ^self getEnvironmentVariable: 'LOGONSERVER'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showPowerOptions " self showPowerOptions " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Ups.cpl'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:35'! showModemSettings " self showModemSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL modem.cpl' ! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:34'! showInternetSettingsConnections " self showInternetSettingsConnections " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Inetcpl.cpl,,4'! ! !NBWin32Shell class methodsFor: 'api calls' stamp: 'tbn 11/9/2012 22:10'! shellExecute: lpOperation file: lpFile parameters: lpParameters directory: lpDirectory show: nShowCmd ^ self nbCall: #( HINSTANCE ShellExecuteA( 0, LPCTSTR lpOperation, LPCTSTR lpFile, LPCTSTR lpParameters, LPCTSTR lpDirectory, INT nShowCmd)) module: 'Shell32.dll' ! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:35'! showInternetSettingsSecurity " self showInternetSettingsSecurity " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Inetcpl.cpl,,1'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:33'! showFindFastSetting " self showFindFastSetting " ^self shellRunDLL: 'shell32.dll,Control_RunDLL findfast.cpl'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:35'! showMultimediaSettingsAudio " self showMultimediaSettingsAudio " ^self shellRunDLL: 'shell32.dll,Control_RunDLL mmsys.cpl,,0'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showMultimediaSettingsMIDI " self showMultimediaSettingsMIDI " ^self shellRunDLL: 'shell32.dll,Control_RunDLL mmsys.cpl,,2'! ! !NBWin32Shell class methodsFor: 'accessing' stamp: 'tbn 11/9/2012 22:28'! getCommonProgramFiles "Return the common program files typically this is C:\Program Files\Common Files self getCommonProgramFiles " ^self getEnvironmentVariable: 'COMMONPROGRAMFILES'! ! !NBWin32Shell class methodsFor: 'mouse' stamp: 'TorstenBergmann 8/8/2013 15:26'! getNumberOfMouseButtons "Returns the number of mouse buttons, or zero if no mouse is installed" ^self getSystemMetrics: SM_CMOUSEBUTTONS ! ! !NBWin32Shell class methodsFor: 'file system' stamp: 'tbn 11/9/2012 22:30'! getSystemRootDirectory "Return the systems root directory. Typically this is 'C:\WINDOWS' self getSystemRootDirectory " ^self getEnvironmentVariable: 'SystemRoot'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:34'! showInternetExplorerSettings "Show the internet explorer settings self showInternetExplorerSettings " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Inetcpl.cpl,,6'! ! !NBWin32Shell class methodsFor: 'api calls' stamp: 'tbn 11/9/2012 22:09'! shellAbout: hWnd application: szApp other: szOtherStuff icon: hIcon " self shellAbout: NBWin32Window getFocus application: 'Pharo' other: 'More' icon: (NBWin32Handle new value: 0) " ^ self nbCall: #(int ShellAboutA( HWND hWnd, LPCTSTR szApp, LPCTSTR szOtherStuff, HICON hIcon )) module: #shell32! ! !NBWin32Shell class methodsFor: 'accessing' stamp: 'tbn 11/9/2012 22:28'! getCommandLineProcessor "Return command line processor executable self getCommandLineProcessor " ^self getEnvironmentVariable: 'ComSpec'! ! !NBWin32Shell class methodsFor: 'special' stamp: 'tbn 11/9/2012 22:22'! lockWorkstation "Locks the workstation." ^ self nbCall: #(BOOL LockWorkStation(void)) module: #user32 ! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showSoundSettings "Show the sound properties dialog box. self showSoundSettings " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Mmsys.cpl,,0'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showBluetoothSettings " self showBluetoothSettings " ^self shellRunDLL: 'irprops.cpl,,BluetoothAuthenticationAgent'! ! !NBWin32Shell class methodsFor: 'network' stamp: 'TorstenBergmann 8/8/2013 20:44'! isInternetOnline ^self isInternetOffline not! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:34'! showInternetSettingsAdvanced " self showInternetSettingsAdvanced " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Inetcpl.cpl,,6'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showPrinterProperties " self showPrinterProperties " ^self shellRunDLL: 'shell32.dll,Control_RunDLL main.cpl @2'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:33'! showDisplaySettingsCommon " self showDisplaySettingsCommon " ^self shellRunDLL: 'shell32.dll,Control_RunDLL desk.cpl,,3'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showDateTimeProperties " self showDateTimeProperties " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Timedate.cpl'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showODBCSettings " self showODBCSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL odbccp32.cpl' ! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:35'! showMicrosoftWorkgroupPostofficeSettings " self showMicrosoftWorkgroupPostofficeSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL wgpocpl.cpl'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showCOMPortsSettings " self showCOMPortsSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL ports.cpl' ! ! !NBWin32Shell class methodsFor: 'debugging' stamp: 'tbn 11/19/2012 07:05'! isDebuggerPresent "Indicates whether the calling process is running under the context of a debugger.." ^ NBFFICallout stdcall: #( BOOL IsDebuggerPresent()) module: #kernel32 ! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showServerProperties " self showServerProperties " ^self shellRunDLL: 'shell32.dll,Control_RunDLL srvmgr.cpl' ! ! !NBWin32Shell class methodsFor: 'mouse' stamp: 'TorstenBergmann 8/8/2013 15:40'! isTablet "Returns true if the current operating system is a tablet one" ^(self getSystemMetrics: SM_TABLETPC) ~= 0 ! ! !NBWin32Shell class methodsFor: 'operations' stamp: 'tbn 11/9/2012 22:11'! shellExplore: folder " self shellExplore: 'c:\' " ^self shellExecute: 'explore' file: folder parameters: '' directory: '' show: SW_SHOW! ! !NBWin32Shell class methodsFor: 'file system' stamp: 'tbn 11/9/2012 22:30'! getProgramFilesDirectory "Return the program files directory self getProgramFilesDirectory " ^self getEnvironmentVariable: 'PROGRAMFILES'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showAccessibilityDisplaySettings "Show the keyboard settings self showAccessibilityDisplaySettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL access.cpl,,3'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showAccessibilityMouseSettings "Show the mouse settings for accessibility self showAccessibilityMouseSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL access.cpl,,4'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:33'! showFontsInstallationFolder " self showFontsInstallationFolder " ^self shellRunDLL: 'Shell32.dll,SHHelpShortcuts_RunDLL FontsFolder'! ! !NBWin32Shell class methodsFor: 'cpu' stamp: 'tbn 11/9/2012 22:29'! getProcessorIdentifier "Return a description of the processor. self getProcessorIdentifier " ^self getEnvironmentVariable: 'PROCESSOR_IDENTIFIER'! ! !NBWin32Shell class methodsFor: 'keyboard' stamp: 'TorstenBergmann 8/8/2013 13:51'! getKeyboardType: nTypeFlag "Retrieves information about the current keyboard. " ^NBFFICallout stdcall: #(int GetKeyboardType(int nTypeFlag)) module: #user32 ! ! !NBWin32Shell class methodsFor: 'mouse' stamp: 'TorstenBergmann 8/8/2013 15:39'! isMouseWheelPresent "Returns true if a mouse with a wheel is installed, false otherwise Windows NT4.0 and later, Windows 98" ^(self getSystemMetrics: SM_MOUSEWHEELPRESENT) ~= 0 ! ! !NBWin32Shell class methodsFor: 'operations' stamp: 'tbn 11/9/2012 22:11'! shellBrowse: url " self shellBrowse: 'http://www.pharo-project.org' " ^self shellExecute: 'open' file: url parameters: '' directory: '' show: SW_SHOW! ! !NBWin32Shell class methodsFor: 'keyboard' stamp: 'TorstenBergmann 8/8/2013 14:03'! getNumberOfFunctionKeys "Returns the number of function keys (typically 12, sometimes 18) Return Value: An Integer " ^self getKeyboardType: 2 ! ! !NBWin32Shell class methodsFor: 'api calls' stamp: 'tbn 11/12/2012 10:04'! getDriveType: lpRootPathName " self getDriveType: 'D:\' " | types | types := #(DRIVE_UNKNOWN DRIVE_NO_ROOT_DIR DRIVE_REMOVABLE DRIVE_FIXED DRIVE_REMOTE DRIVE_CDROM DRIVE_RAMDISK). ^types at: (self primGetDriveType: lpRootPathName) + 1! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:34'! showInternetSettingsContent " self showInternetSettingsContent " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Inetcpl.cpl,,3'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showProgramPropertiesStartupDisk " self showProgramPropertiesStartupDisk " ^self shellRunDLL: 'shell32.dll,Control_RunDLL appwiz.cpl,,3'! ! !NBWin32Shell class methodsFor: 'file system' stamp: 'tbn 11/9/2012 22:30'! getSystemDrive "Return the drive containing the Windows root directory, usually C: self getSystemDrive " ^self getEnvironmentVariable: 'SYSTEMDRIVE'! ! !NBWin32Shell class methodsFor: 'operations' stamp: 'tbn 11/9/2012 22:25'! shellRunDLL: cmd " self shellRunDLL: 'shell32.dll,Control_RunDLL odbccp32.cpl' " ^self shellExecute: 'open' file: 'rundll32.exe' parameters: cmd directory: '' show: SW_SHOW! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showMultimediaSettingsVideo " self showMultimediaSettingsVideo " ^self shellRunDLL: 'shell32.dll,Control_RunDLL mmsys.cpl,,1'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showAccessibilitySoundSettings "Show the sound settings for accessibility self showAccessibilitySoundSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL access.cpl,,2'! ! !NBWin32Shell class methodsFor: 'cpu' stamp: 'tbn 11/9/2012 22:29'! getProcessorRevision "Return the revision number of the processor. self getProcessorRevision " ^self getEnvironmentVariable: 'PROCESSOR_REVISION'! ! !NBWin32Shell class methodsFor: 'user' stamp: 'tbn 11/9/2012 22:30'! getUserProfile "Return the users profile location. Typically this is C:\Documents and Settings\{username} self getUserProfile " ^self getEnvironmentVariable: 'USERPROFILE'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:34'! showInternetSettingsPrograms " self showInternetSettingsPrograms " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Inetcpl.cpl,,5'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:37'! showThemesSettings " self showThemesSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL themes.cpl' ! ! !NBWin32Shell class methodsFor: 'computer' stamp: 'tbn 11/9/2012 22:29'! getOS "Return the name of the OS" ^self getEnvironmentVariable: 'OS'! ! !NBWin32Shell class methodsFor: 'operations' stamp: 'tbn 11/9/2012 22:13'! shellPrint: file " self shellPrint: 'c:\index.html' " ^self shellExecute: 'print' file: file parameters: '' directory: '' show: SW_SHOW! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:35'! showMouseProperties " self showMouseProperties " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL main.cpl @0,0'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:35'! showMailAndFaxSettings " self showMailAndFaxSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL mlcfg32.cpl'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:35'! showKeyboardProperties " self showKeyboardProperties " ^self shellRunDLL: 'shell32.dll,Control_RunDLL main.cpl @1'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:33'! showInternationalSettingsDate "Show the internation settings for input locales. self showInternationalSettingsDate " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Intl.cpl,,4'! ! !NBWin32Shell class methodsFor: 'mouse' stamp: 'TorstenBergmann 8/8/2013 15:34'! isMouseAvailable "returns true if a mouse is available, otherwise false" ^self getNumberOfMouseButtons ~= 0! ! !NBWin32Shell class methodsFor: 'cpu' stamp: 'tbn 11/9/2012 22:29'! getProcessorArchitecture "Return processor chip architecture. Values: x86, IA64. self getProcessorArchitecture " ^self getEnvironmentVariable: 'PROCESSOR_ARCHITECTURE'! ! !NBWin32Shell class methodsFor: 'cpu' stamp: 'tbn 11/9/2012 22:29'! getNumberOfProcessors "Return the number of processors/cores. self getNumberOfProcessors " ^self getEnvironmentVariable: 'NUMBER_OF_PROCESSORS'! ! !NBWin32Shell class methodsFor: 'api calls' stamp: 'TorstenBergmann 8/8/2013 15:24'! getSystemMetrics: nIndex "Retrieves the specified system metric or system configuration setting." ^NBFFICallout stdcall: #(int GetSystemMetrics(int nIndex)) module: #user32 ! ! !NBWin32Shell class methodsFor: 'network' stamp: 'TorstenBergmann 8/8/2013 15:23'! isNetworkPresent ^(self getSystemMetrics: SM_NETWORK) & 1 = 1! ! !NBWin32Shell class methodsFor: 'display' stamp: 'TorstenBergmann 8/8/2013 15:23'! getNumberOfDisplayMonitors "Returns the number of display monitors attached to the desktop" ^self getSystemMetrics: SM_CMONITORS ! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:33'! showFormatDrive " self showFormatDrive " ^self shellRunDLL: 'shell32.dll,SHFormatDrive'! ! !NBWin32Shell class methodsFor: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showDisplaySettingsAppearance " self showDisplaySettingsAppearance " ^self shellRunDLL: 'shell32.dll,Control_RunDLL desk.cpl,,2'! ! !NBWin32Shell class methodsFor: 'file system' stamp: 'tbn 11/9/2012 22:30'! getWindowsDirectory "Return the path to the windows directory" ^self getEnvironmentVariable: 'windir'! ! !NBWin32ShellTest methodsFor: 'tests' stamp: 'TorstenBergmann 8/7/2013 12:28'! testNoDebuggerPresentByDefault self deny: NBWin32Shell isDebuggerPresent ! ! !NBWin32ShellTest methodsFor: 'tests' stamp: 'TorstenBergmann 8/7/2013 12:31'! testNumberOfProcessors self assert: NBWin32Shell getNumberOfProcessors asInteger > 0! ! !NBWin32ShellTest methodsFor: 'tests' stamp: 'TorstenBergmann 8/7/2013 12:27'! testGetComputerName self assert: NBWin32Shell getComputerName notEmpty ! ! !NBWin32ShellTest methodsFor: 'tests' stamp: 'TorstenBergmann 8/7/2013 12:30'! testGetDriveType self assert: (NBWin32Shell getDriveType: 'C:\') = #DRIVE_FIXED! ! !NBWin32ShellTest methodsFor: 'tests' stamp: 'TorstenBergmann 8/7/2013 12:27'! testGetCommandLine self assert: NBWin32Shell getCommandLine notEmpty ! ! !NBWin32SpecificTest class methodsFor: 'testing' stamp: 'CamilloBruni 9/10/2013 14:19'! isAbstract "only run test subclasses on Windows" ^(self name = #NBWin32SpecificTest) or: [ Smalltalk os isWin32 not ]! ! !NBWin32Thread methodsFor: 'testing' stamp: 'TorstenBergmann 8/13/2013 22:16'! isThreadAllAccess "For systems that do not support security descriptors, the (pseudo) handle is THREAD_ALL_ACCESS. " ^self handle value = THREAD_ALL_ACCESS! ! !NBWin32Thread class methodsFor: 'accessing' stamp: 'TorstenBergmann 8/13/2013 22:24'! getCurrentThreadId "Returns the thread identifier of the calling thread. Until the thread terminates, the thread identifier uniquely identifies the thread throughout the system." ^ NBFFICallout stdcall: #(DWORD GetCurrentThreadId()) module: #kernel32 ! ! !NBWin32Thread class methodsFor: 'accessing' stamp: 'TorstenBergmann 8/13/2013 21:43'! getCurrentThread "Return an instance with a pseudohandle for the current thread." ^ NBFFICallout stdcall: #( NBWin32Thread GetCurrentThread()) module: #kernel32 ! ! !NBWin32Window commentStamp: 'Igor.Stasenko 4/29/2010 10:54'! Through WinTypes pool, i seen as HWND type , so whenever you type HWND, you are working with instances of me ! !NBWin32Window methodsFor: 'api' stamp: 'TorstenBergmann 8/13/2013 20:22'! getWindow: wCmd "Retrieves the handle of a window that has the specified relationship (Z order or owner) to the specified window." ^self nbCall: #(HWND GetWindow(HWND self, UINT wCmd)) module: #user32 ! ! !NBWin32Window methodsFor: 'operations' stamp: 'IgorStasenko 11/24/2012 17:35'! destroyWindow "destroy the window" ^ self nbCallout stdcall; options: #( + optMayGC ); " calls windowproc" function: #( BOOL DestroyWindow ( HWND self )) module: #user32 ! ! !NBWin32Window methodsFor: 'accessing' stamp: 'IgorStasenko 11/25/2012 14:18'! getDC ^ self nbCall: #( HDC GetDC ( HWND self ) ) module: #user32! ! !NBWin32Window methodsFor: 'opening' stamp: 'TorstenBergmann 8/13/2013 21:30'! close "Minimizes (but does not destroy) the specified window" ^ self nbCallout stdcall function: #( BOOL CloseWindow( HWND self)) module: #user32 ! ! !NBWin32Window methodsFor: 'api' stamp: 'TorstenBergmann 8/13/2013 21:18'! getWindowRectangle |rect| rect := NBWin32Rectangle new. ^(self getWindowRect: rect) ifTrue: [ rect ] ifFalse: [ self error: 'failed' ] ! ! !NBWin32Window methodsFor: 'testing' stamp: 'tbn 8/6/2013 22:06'! isEnabled "Determines whether the specified window is enabled for mouse and keyboard input. " ^self nbCall: #(BOOL IsWindowEnabled(HWND self)) module: #user32 ! ! !NBWin32Window methodsFor: 'testing' stamp: 'IgorStasenko 11/25/2012 14:18'! isIconic "Determines whether the specified window is minimized (iconic). " ^self nbCall: #(BOOL IsIconic(HWND self)) module: #user32 ! ! !NBWin32Window methodsFor: 'accessing' stamp: 'IgorStasenko 11/25/2012 14:19'! setWindowText: lpString ^self nbCall: #(BOOL SetWindowTextA(HWND self, LPCTSTR lpString)) module: #user32 ! ! !NBWin32Window methodsFor: 'iterating' stamp: 'TorstenBergmann 8/13/2013 20:20'! getNextWindow "Returns the handle of the window below the given window." ^self getWindow: GW_HWNDNEXT! ! !NBWin32Window methodsFor: 'testing' stamp: 'tbn 8/6/2013 22:04'! isWindow "Determines whether the specified window handle identifies an existing window " ^self nbCall: #(BOOL IsWindow(HWND self)) module: #user32 ! ! !NBWin32Window methodsFor: 'accessing' stamp: 'tbn 11/12/2012 07:11'! getWindowExStyle "Retrieves the extended window styles" ^self getWindowLongAtIndex: GWL_EXSTYLE! ! !NBWin32Window methodsFor: 'api' stamp: 'IgorStasenko 11/25/2012 14:18'! getWindowLongAtIndex: nIndex ^self nbCall: #(LONG GetWindowLongA(HWND self, int nIndex)) module: #user32 ! ! !NBWin32Window methodsFor: 'operations' stamp: 'tbn 11/12/2012 09:20'! setNonResizable | newStyle | newStyle := self getWindowStyle bitClear: (WS_SIZEBOX|WS_MINIMIZE|WS_MAXIMIZE). self setWindowLong: self index: GWL_STYLE newVale: newStyle. ! ! !NBWin32Window methodsFor: 'opening' stamp: 'TorstenBergmann 8/13/2013 21:26'! show "show the window" ^ self nbCallout stdcall options: #( + optMayGC ); " calls windowproc" function: #( BOOL ShowWindow ( HWND self, SW_SHOW )) module: #user32 ! ! !NBWin32Window methodsFor: 'operations' stamp: 'IgorStasenko 11/24/2012 17:37'! moveWindowX: x y: y width: nWidth height: nHeight "move window example" ^ self nbCallout stdcall; options: #( + optMayGC ); " calls windowproc" function: #( BOOL MoveWindow ( HWND self, int x, int y, int nWidth, int nHeight, false )) module: #user32 ! ! !NBWin32Window methodsFor: 'iterating' stamp: 'TorstenBergmann 8/13/2013 20:44'! getTopWindow "Examines the Z order of the child windows associated with the specified parent window and retrieves the handle of the child window at the top of the Z order." ^self nbCall: #(HWND GetTopWindow(HWND self)) module: #user32 ! ! !NBWin32Window methodsFor: 'opening' stamp: 'TorstenBergmann 8/13/2013 21:32'! minimize ^self close! ! !NBWin32Window methodsFor: 'opening' stamp: 'TorstenBergmann 8/13/2013 21:34'! destroy "Destroys the specified window. The function sends WM_DESTROY and WM_NCDESTROY messages to the window to deactivate it and remove the keyboard focus from it. The function also destroys the window's menu, flushes the thread message queue, destroys timers, removes clipboard ownership, and breaks the clipboard viewer chain (if the window is at the top of the viewer chain). If the specified window is a parent or owner window, DestroyWindow automatically destroys the associated child or owned windows when it destroys the parent or owner window. The function first destroys child or owned windows, and then it destroys the parent or owner window. NOTE: A thread cannot use DestroyWindow to destroy a window created by a different thread." ^ self nbCallout stdcall function: #( BOOL DestroyWindow( HWND self)) module: #user32 ! ! !NBWin32Window methodsFor: 'testing' stamp: 'IgorStasenko 11/25/2012 14:19'! isZoomed "Determines whether a window is maximized. " ^self nbCall: #(BOOL IsZoomed(HWND self)) module: #user32 ! ! !NBWin32Window methodsFor: 'drawing' stamp: 'IgorStasenko 11/24/2012 17:36'! hide "destroy the window" ^ self nbCallout stdcall; options: #( + optMayGC ); " calls windowproc" function: #( BOOL ShowWindow ( HWND self, SW_HIDE )) module: #user32 ! ! !NBWin32Window methodsFor: 'accessing' stamp: 'IgorStasenko 11/25/2012 14:19'! setWindowLong: hWnd index: nIndex newVale: dwNewLong ^self nbCall: #(LONG SetWindowLongA(HWND hWnd, int nIndex, LONG dwNewLong)) module: #user32 ! ! !NBWin32Window methodsFor: 'api' stamp: 'TorstenBergmann 8/7/2013 12:50'! getWindowFromPoint: point ^self nbCall: #(HWND WindowFromPoint(NBWin32Point point)) module: #user32 ! ! !NBWin32Window methodsFor: 'accessing' stamp: 'IgorStasenko 11/25/2012 14:19'! releaseDC: hdc ^ self nbCall: #( int ReleaseDC ( HWND self , " handle to window" HDC hdc " handle to DC " )) module: #user32! ! !NBWin32Window methodsFor: 'iterating' stamp: 'TorstenBergmann 8/13/2013 20:21'! getPreviousWindow "Returns the handle of the window above the given window." ^self getWindow: GW_HWNDPREV ! ! !NBWin32Window methodsFor: 'comparing' stamp: 'TorstenBergmann 8/13/2013 20:02'! = anotherNBWin32Window "Compare using the external give handle" ^self species = anotherNBWin32Window species and: [ handle = anotherNBWin32Window handle ]! ! !NBWin32Window methodsFor: 'api' stamp: 'IgorStasenko 11/25/2012 14:18'! getWindowLong: hWnd index: nIndex ^self nbCall: #(LONG GetWindowLongA(HWND hWnd, int nIndex)) module: #user32 ! ! !NBWin32Window methodsFor: 'iterating' stamp: 'TorstenBergmann 8/13/2013 20:20'! getActiveWindow "Retrieves the window handle to the active window associated with the thread that calls the function. " ^self class getActiveWindow! ! !NBWin32Window methodsFor: 'testing' stamp: 'tbn 8/6/2013 22:08'! isUnicode "Determines whether the specified window is a native Unicode window. " ^self nbCall: #(BOOL IsWindowUnicode(HWND self)) module: #user32 ! ! !NBWin32Window methodsFor: 'api' stamp: 'tbn 11/11/2012 01:03'! getWindowText " self getFocus getWindowText " | len str | str := ByteString new: 1000. len := self getWindowText: self buffer: str bufferSize: 1000. ^ str first: len. ! ! !NBWin32Window methodsFor: 'testing' stamp: 'IgorStasenko 11/25/2012 14:18'! isVisible "Retrieves the visibility state of the specified window. . " ^self nbCall: #(BOOL IsWindowVisible(HWND self)) module: #user32 ! ! !NBWin32Window methodsFor: 'api' stamp: 'TorstenBergmann 8/13/2013 21:18'! getWindowRect: rect ^self nbCall: #(BOOL GetWindowRect(HWND self, RECT* rect)) module: #user32 ! ! !NBWin32Window methodsFor: 'accessing' stamp: 'tbn 11/12/2012 07:11'! getWindowStyle "Retrieves the window styles" ^self getWindowLongAtIndex: GWL_STYLE! ! !NBWin32Window methodsFor: 'api' stamp: 'IgorStasenko 11/25/2012 14:18'! getWindowText: hWnd buffer: lpString bufferSize: nMaxCount ^self nbCall: #(int GetWindowTextA(HWND hWnd, char* lpString, int nMaxCount)) module: #user32 ! ! !NBWin32Window methodsFor: 'iterating' stamp: 'TorstenBergmann 8/13/2013 20:48'! getParent "Retrieves the handle of the specified child window's parent window. If the window has no parent window, the return value is nil." ^self nbCall: #(HWND GetParent(HWND self)) module: #user32 ! ! !NBWin32Window class methodsFor: 'accessing' stamp: 'tbn 11/19/2012 06:57'! getForegroundWindow "Returns the handle of the foreground window (the window with which the user is currently working)." ^ NBFFICallout stdcall: #( HWND GetForegroundWindow()) module: #user32 ! ! !NBWin32Window class methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 5/17/2010 19:20'! DefWindowProcW ^ NBExternalAddress value: (NativeBoost loadSymbol: #DefWindowProcW fromModule: #user32)! ! !NBWin32Window class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 4/6/2012 13:58'! DefWindowProcA ^ NativeBoost loadSymbol: #DefWindowProcA fromModule: #user32! ! !NBWin32Window class methodsFor: 'accessing' stamp: 'tbn 8/6/2013 22:25'! getClipboardViewer "Retrieves the handle of the first window in the clipboard viewer chain." ^ NBFFICallout stdcall: #( HWND GetClipboardOwner()) module: #user32 ! ! !NBWin32Window class methodsFor: 'callout options' stamp: 'IgorStasenko 9/16/2012 18:10'! ffiCalloutOptions ^ #( + optMayGC )! ! !NBWin32Window class methodsFor: 'accessing' stamp: 'TorstenBergmann 8/7/2013 13:01'! getWindowFromPoint: point ^self nbCall: #(HWND WindowFromPoint(POINT point)) module: #user32 ! ! !NBWin32Window class methodsFor: 'accessing' stamp: 'tbn 8/6/2013 22:18'! getCapture "Return retrieves the window (if any) that has captured the mouse. Only one window at a time can capture the mouse; this window receives mouse input whether or not the cursor is within its borders." ^ self nbCallout stdcall function: #( HWND GetCapture ()) module: #user32 ! ! !NBWin32Window class methodsFor: 'accessing' stamp: 'tbn 11/19/2012 06:51'! getDesktopWindow "Return the handle of the windows desktop window" ^ NBFFICallout stdcall: #( HWND GetDesktopWindow()) module: #user32 ! ! !NBWin32Window class methodsFor: 'accessing' stamp: 'tbn 8/6/2013 22:11'! getActiveWindow "Retrieves the window handle to the active window associated with the thread that calls the function. " ^ NBFFICallout stdcall: #( HWND GetActiveWindow()) module: #user32 ! ! !NBWin32Window class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/24/2012 17:39'! createWindowExA: dwExStyle lpClassName: lpClassName lpWindowName: lpWindowName dwStyle: dwStyle x: x y: y width: nWidth height: nHeight hWndParent: hWndParent hMenu: hMenu hInstance: hInstance lParam: lpParam ^ self nbCallout stdcall; options: #( - WinUnicode ); function: #( HWND 'CreateWindowExA' ( DWORD dwExStyle, LPCTSTR lpClassName, LPCTSTR lpWindowName, DWORD dwStyle, ulong x, ulong y, ulong nWidth, ulong nHeight, HWND hWndParent, HMENU hMenu, HINSTANCE hInstance, LPVOID lpParam) ) module: #user32 ! ! !NBWin32Window class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/24/2012 17:40'! createWindowExW: dwExStyle lpClassName: lpClassName lpWindowName: lpWindowName dwStyle: dwStyle x: x y: y width: nWidth height: nHeight hWndParent: hWndParent hMenu: hMenu hInstance: hInstance lParam: lpParam ^ self nbCallout stdcall; options: #( + WinUnicode ); function: #( HWND 'CreateWindowExW' ( DWORD dwExStyle, LPCTSTR lpClassName, LPCTSTR lpWindowName, DWORD dwStyle, ulong x, ulong y, ulong nWidth, ulong nHeight, HWND hWndParent, HMENU hMenu, HINSTANCE hInstance, LPVOID lpParam) ) module: #user32 ! ! !NBWin32Window class methodsFor: 'accessing' stamp: 'IgorStasenko 11/24/2012 17:40'! getFocus "Return the HWND currently having the input focus" ^ self nbCallout stdcall function: #( HWND GetFocus ()) module: #user32 ! ! !NBWin32Window class methodsFor: 'accessing' stamp: 'tbn 8/6/2013 22:24'! getClipboardOwnerWindow "Retrieves the window handle of the current owner of the clipboard." ^ NBFFICallout stdcall: #( HWND GetClipboardOwner()) module: #user32 ! ! !NBWin32WindowTest methodsFor: 'tests' stamp: 'TorstenBergmann 8/7/2013 11:59'! testGetDesktopWindow self assert: NBWin32Window getDesktopWindow handle > 0! ! !NBWin32WindowTest methodsFor: 'tests' stamp: 'MarcusDenker 1/14/2014 17:21'! testWindowFromPoint self skip. "fails on CI server" self assert: (NBWin32Window getWindowFromPoint: (NBWin32Point x: 100 y: 100)) isWindow! ! !NBWin32WindowTest methodsFor: 'tests' stamp: 'TorstenBergmann 8/7/2013 12:26'! testIsEnabled self assert: NBWin32Window getDesktopWindow isEnabled! ! !NBWin32WindowTest methodsFor: 'tests' stamp: 'MarcusDenker 1/14/2014 17:21'! testIsVisible self skip. "fails on CI server" self assert: NBWin32Window getDesktopWindow isVisible! ! !NBWinConstants class methodsFor: 'constants' stamp: 'TorstenBergmann 8/13/2013 22:37'! baseConstants DEBUG_PROCESS := 16r00000001. DEBUG_ONLY_THIS_PROCESS := 16r00000002. CREATE_SUSPENDED := 16r00000004. DETACHED_PROCESS := 16r00000008. CREATE_NEW_CONSOLE := 16r00000010. NORMAL_PRIORITY_CLASS := 16r00000020. IDLE_PRIORITY_CLASS := 16r00000040. HIGH_PRIORITY_CLASS := 16r00000080. REALTIME_PRIORITY_CLASS := 16r00000100. CREATE_NEW_PROCESS_GROUP := 16r00000200. CREATE_UNICODE_ENVIRONMENT := 16r00000400. CREATE_SEPARATE_WOW_VDM := 16r00000800. CREATE_SHARED_WOW_VDM := 16r00001000. CREATE_FORCEDOS := 16r00002000. BELOW_NORMAL_PRIORITY_CLASS := 16r00004000. ABOVE_NORMAL_PRIORITY_CLASS := 16r00008000. "..." ACE_OBJECT_TYPE_PRESENT := 16r00000001. ACE_INHERITED_OBJECT_TYPE_PRESENT := 16r00000002. APPLICATION_ERROR_MASK := 16r20000000. ERROR_SEVERITY_SUCCESS := 16r00000000. ERROR_SEVERITY_INFORMATIONAL := 16r40000000. ERROR_SEVERITY_WARNING := 16r80000000. ERROR_SEVERITY_ERROR := 16rC0000000. SYNCHRONIZE := 16r100000. STANDARD_RIGHTS_REQUIRED := 16rF0000. STANDARD_RIGHTS_READ := 16r20000. STANDARD_RIGHTS_WRITE := 16r20000. STANDARD_RIGHTS_EXECUTE := 16r20000. STANDARD_RIGHTS_ALL := 16r1F0000. SPECIFIC_RIGHTS_ALL := 16rFFFF. ACCESS_SYSTEM_SECURITY := 16r1000000.! ! !NBWinConstants class methodsFor: 'constants' stamp: 'tbn 11/12/2012 10:09'! windowMessages WM_ACTIVATEAPP := 16r001C. WM_CANCELMODE := 16r001F. WM_CHILDACTIVATE := 16r0022. WM_CLOSE := 16r0010. WM_COMPACTING := 16r0041. WM_CREATE := 16r0001. WM_DESTROY := 16r0002. "http://msdn.microsoft.com/en-us/library/windows/desktop/ms632620(v=vs.85).aspx" WM_ENABLE := 16r000A. WM_ENTERSIZEMOVE := 16r0231. WM_EXITSIZEMOVE := 16r0232. WM_GETMINMAXINFO := 16r0024. WM_GETICON := 16r007F. WM_INPUTLANGCHANGE := 16r0051. WM_INPUTLANGCHANGEREQUEST := 16r0050. WM_MOVE := 16r0003. WM_MOVING := 16r0216. WM_NCACTIVATE := 16r0086. WM_NCCALCSIZE := 16r0083. WM_NCCREATE := 16r0081. WM_NCDESTROY := 16r0082. WM_NULL := 16r0000. WM_QUERYDRAGICON := 16r0037. WM_QUERYOPEN := 16r0013. WM_QUIT := 16r0012. WM_SHOWWINDOW := 16r0018. WM_SIZE := 16r0005. WM_SIZING := 16r0214. WM_STYLECHANGED := 16r007D. WM_STYLECHANGING := 16r007C. WM_THEMECHANGED := 16r031A. WM_USERCHANGED := 16r0054. WM_WINDOWPOSCHANGED := 16r0047. WM_WINDOWPOSCHANGING := 16r0046 ! ! !NBWinConstants class methodsFor: 'constants' stamp: 'TorstenBergmann 8/8/2013 15:19'! systemMetricConstants "http://msdn.microsoft.com/en-us/library/windows/desktop/ms724385(v=vs.85).aspx" SM_ARRANGE := 56. SM_CLEANBOOT := 67. SM_CMONITORS := 80. SM_CMOUSEBUTTONS := 43. SM_CXBORDER := 5. SM_CXCURSOR := 13. SM_CXDLGFRAME := 7. SM_CXDOUBLECLK := 36. SM_CXDRAG := 68. SM_CXEDGE := 45. SM_CXFIXEDFRAME := 7. SM_CXFOCUSBORDER := 83. SM_CXFRAME := 32. SM_CXFULLSCREEN := 16. SM_CXHSCROLL := 21. SM_CXHTHUMB := 10. SM_CXICON := 11. SM_CXICONSPACING := 38. SM_CXMAXIMIZED := 61. SM_CXMAXTRACK := 59. SM_CXMENUCHECK := 71. SM_CXMENUSIZE := 54. SM_CXMIN := 28. SM_CXMINIMIZED := 57. SM_CXMINSPACING := 47. SM_CXMINTRACK := 34. SM_CXPADDEDBORDER := 92. SM_CXSCREEN := 0. SM_CXSIZE := 30. SM_CXSIZEFRAME := 32. SM_CXSMICON := 49. SM_CXSMSIZE := 52. SM_CXVIRTUALSCREEN := 78. SM_CXVSCROLL := 2. SM_CYBORDER := 6. SM_CYCAPTION := 4. SM_CYCURSOR := 14. SM_CYDLGFRAME := 8. SM_CYDOUBLECLK := 37. SM_CYDRAG := 69. SM_CYEDGE := 46. SM_CYFIXEDFRAME := 8. SM_CYFOCUSBORDER := 84. SM_CYFRAME := 33. SM_CYFULLSCREEN := 17. SM_CYHSCROLL := 3. SM_CYICON := 12. SM_CYICONSPACING := 39. SM_CYKANJIWINDOW := 18. SM_CYMAXIMIZED := 62. SM_CYMAXTRACK := 60. SM_CYMENU := 15. SM_CYMENUCHECK := 72. SM_CYMENUSIZE := 55. SM_CYMIN := 29. SM_CYMINIMIZED := 58. SM_CYMINSPACING := 48. SM_CYMINTRACK := 35. SM_CYSCREEN := 1. SM_CYSIZE := 31. SM_CYSIZEFRAME := 33. SM_CYSMCAPTION := 51. SM_CYSMICON := 50. SM_CYSMSIZE := 53. SM_CYVIRTUALSCREEN := 79. SM_CYVSCROLL := 20. SM_CYVTHUMB := 9. SM_DBCSENABLED := 42. SM_DEBUG := 22. SM_DIGITIZER := 94. SM_IMMENABLED := 82. SM_MAXIMUMTOUCHES := 95. SM_MEDIACENTER := 87. SM_MENUDROPALIGNMENT := 40. SM_MIDEASTENABLED := 74. SM_MOUSEPRESENT := 19. SM_MOUSEHORIZONTALWHEELPRESENT := 91. SM_MOUSEWHEELPRESENT := 75. SM_NETWORK := 63. SM_PENWINDOWS := 41. SM_REMOTECONTROL := 16r2001. SM_REMOTESESSION := 16r1000. SM_SAMEDISPLAYFORMAT := 81. SM_SECURE := 44. SM_SHOWSOUNDS := 70. SM_SHUTTINGDOWN := 16r2000. SM_SLOWMACHINE := 73. SM_STARTER := 88. SM_SWAPBUTTON := 23. SM_TABLETPC := 86. SM_XVIRTUALSCREEN := 76. SM_YVIRTUALSCREEN := 77! ! !NBWinConstants class methodsFor: 'constants' stamp: 'Igor.Stasenko 5/2/2010 15:10'! windowStyles " Window Styles " WS_OVERLAPPED := 16r00000000. WS_POPUP := 16r80000000. WS_CHILD := 16r40000000. WS_MINIMIZE := 16r20000000. WS_VISIBLE := 16r10000000. WS_DISABLED := 16r08000000. WS_CLIPSIBLINGS := 16r04000000. WS_CLIPCHILDREN := 16r02000000. WS_MAXIMIZE := 16r01000000. WS_CAPTION := 16r00C00000. " WS_BORDER | WS_DLGFRAME " WS_BORDER := 16r00800000. WS_DLGFRAME := 16r00400000. WS_VSCROLL := 16r00200000. WS_HSCROLL := 16r00100000. WS_SYSMENU := 16r00080000. WS_THICKFRAME := 16r00040000. WS_GROUP := 16r00020000. WS_TABSTOP := 16r00010000. WS_MINIMIZEBOX := 16r00020000. WS_MAXIMIZEBOX := 16r00010000. " Common Window Styles " WS_OVERLAPPEDWINDOW := ((((WS_OVERLAPPED bitOr: WS_CAPTION ) bitOr: WS_SYSMENU ) bitOr: WS_THICKFRAME ) bitOr: WS_MINIMIZEBOX ) bitOr: WS_MAXIMIZEBOX. WS_POPUPWINDOW := (WS_POPUP bitOr: WS_BORDER) bitOr: WS_SYSMENU. WS_CHILDWINDOW := WS_CHILD. WS_TILED := WS_OVERLAPPED. WS_ICONIC := WS_MINIMIZE. WS_SIZEBOX := WS_THICKFRAME. WS_TILEDWINDOW := WS_OVERLAPPEDWINDOW. ! ! !NBWinConstants class methodsFor: 'constants' stamp: 'tbn 11/11/2012 20:14'! messageBoxConstants MB_ABORTRETRYIGNORE := 16r00000002. MB_CANCELTRYCONTINUE := 16r00000006. MB_HELP := 16r00004000. MB_OK := 16r00000000. MB_OKCANCEL := 16r00000001. MB_RETRYCANCEL := 16r00000005. MB_YESNO := 16r00000004. MB_YESNOCANCEL := 16r00000003. "To display an icon in the message box, specify one of the following values." MB_ICONEXCLAMATION := 16r00000030. MB_ICONWARNING := 16r00000030. MB_ICONINFORMATION := 16r00000040. MB_ICONASTERISK := 16r00000040. MB_ICONQUESTION := 16r00000020. MB_ICONSTOP := 16r00000010. MB_ICONERROR := 16r00000010. MB_ICONHAND := 16r00000010. "To indicate the default button, specify one of the following values." MB_DEFBUTTON1 := 16r00000000. MB_DEFBUTTON2 := 16r00000100. MB_DEFBUTTON3 := 16r00000200. MB_DEFBUTTON4 := 16r00000300. "To indicate the modality of the dialog box, specify one of the following values." MB_APPLMODAL := 16r00000000. MB_SYSTEMMODAL := 16r00001000. MB_TASKMODAL := 16r00002000. "To specify other options, use one or more of the following values." MB_DEFAULT_DESKTOP_ONLY := 16r00020000. MB_RIGHT := 16r00080000. "text is right justified" MB_RTLREADING := 16r00100000. MB_SETFOREGROUND := 16r00010000. MB_TOPMOST := 16r00040000. MB_SERVICE_NOTIFICATION := 16r00200000. IDABORT := 3. IDCANCEL := 2. IDCONTINUE := 11. IDIGNORE := 5. IDNO := 7. IDOK := 1. IDRETRY := 4. IDTRYAGAIN := 10. IDYES := 6. ! ! !NBWinConstants class methodsFor: 'constants' stamp: 'tbn 11/12/2012 09:52'! driveTypes DRIVE_UNKNOWN := 0. DRIVE_NO_ROOT_DIR := 1. DRIVE_REMOVABLE := 2. DRIVE_FIXED := 3. DRIVE_REMOTE := 4. DRIVE_CDROM := 5. DRIVE_RAMDISK := 6! ! !NBWinConstants class methodsFor: 'constants' stamp: 'TorstenBergmann 8/13/2013 19:21'! showWindowConstants SW_HIDE := 0. SW_SHOWNORMAL := 1. SW_NORMAL := 1. SW_SHOWMINIMIZED := 2. SW_SHOWMAXIMIZED := 3. SW_MAXIMIZE := 3. SW_SHOWNOACTIVATE := 4. SW_SHOW := 5. SW_MINIMIZE := 6. SW_SHOWMINNOACTIVE := 7. SW_SHOWNA := 8. SW_RESTORE := 9. SW_SHOWDEFAULT := 10. SW_FORCEMINIMIZE := 11. SW_MAX := 11! ! !NBWinConstants class methodsFor: 'constants' stamp: 'Igor.Stasenko 5/18/2010 04:16'! classStyles " Window class styles " CS_VREDRAW := 16r0001. CS_HREDRAW := 16r0002. CS_DBLCLKS := 16r0008. CS_OWNDC := 16r0020. CS_CLASSDC := 16r0040. CS_PARENTDC := 16r0080. CS_NOCLOSE := 16r0200. CS_SAVEBITS := 16r0800. CS_BYTEALIGNCLIENT := 16r1000. CS_BYTEALIGNWINDOW := 16r2000. CS_GLOBALCLASS := 16r4000. CS_IME := 16r00010000. CS_DROPSHADOW := 16r00020000. ! ! !NBWinConstants class methodsFor: 'class initialization' stamp: 'TorstenBergmann 8/13/2013 22:10'! initialize " self initialize" self baseConstants; classStyles; heapConstants; threadConstants; windowStyles; windowExStyles; windowCreationConstants; gdiConstants; showWindowConstants; getWindowConstants; messageBoxConstants; systemMetricConstants; getWindowLongConstants; windowMessages; driveTypes! ! !NBWinConstants class methodsFor: 'constants' stamp: 'tbn 11/12/2012 07:07'! getWindowLongConstants GWL_EXSTYLE := -20. GWL_HINSTANCE := -6. GWL_HWNDPARENT := -8. GWL_ID := -12. GWL_STYLE := -16. GWL_USERDATA := -21. GWL_WNDPROC := -4! ! !NBWinConstants class methodsFor: 'constants' stamp: 'TorstenBergmann 8/13/2013 22:12'! threadConstants THREAD_TERMINATE := 1. THREAD_SUSPEND_RESUME := 2. THREAD_GET_CONTEXT := 8. THREAD_SET_CONTEXT := 16. THREAD_SET_INFORMATION := 32. THREAD_QUERY_INFORMATION := 64. THREAD_SET_THREAD_TOKEN := 128. THREAD_IMPERSONATE := 256. THREAD_DIRECT_IMPERSONATION := 16r200. THREAD_ALL_ACCESS := STANDARD_RIGHTS_REQUIRED|SYNCHRONIZE|16r3FF! ! !NBWinConstants class methodsFor: 'constants' stamp: 'Igor.Stasenko 5/2/2010 15:10'! windowExStyles " Extended Window Styles " WS_EX_DLGMODALFRAME := 16r00000001. WS_EX_NOPARENTNOTIFY := 16r00000004. WS_EX_TOPMOST := 16r00000008. WS_EX_ACCEPTFILES := 16r00000010. WS_EX_TRANSPARENT := 16r00000020. WS_EX_MDICHILD := 16r00000040. WS_EX_TOOLWINDOW := 16r00000080. WS_EX_WINDOWEDGE := 16r00000100. WS_EX_CLIENTEDGE := 16r00000200. WS_EX_CONTEXTHELP := 16r00000400. WS_EX_RIGHT := 16r00001000. WS_EX_LEFT := 16r00000000. WS_EX_RTLREADING := 16r00002000. WS_EX_LTRREADING := 16r00000000. WS_EX_LEFTSCROLLBAR := 16r00004000. WS_EX_RIGHTSCROLLBAR := 16r00000000. WS_EX_CONTROLPARENT := 16r00010000. WS_EX_STATICEDGE := 16r00020000. WS_EX_APPWINDOW := 16r00040000. WS_EX_OVERLAPPEDWINDOW := (WS_EX_WINDOWEDGE bitOr: WS_EX_CLIENTEDGE). WS_EX_PALETTEWINDOW := (WS_EX_WINDOWEDGE bitOr: WS_EX_TOOLWINDOW) bitOr: WS_EX_TOPMOST. WS_EX_LAYERED := 16r00080000. WS_EX_NOINHERITLAYOUT := 16r00100000. " Disable inheritence of mirroring by children " WS_EX_LAYOUTRTL := 16r00400000. " Right to left mirroring " WS_EX_COMPOSITED := 16r02000000. WS_EX_NOACTIVATE := 16r08000000. ! ! !NBWinConstants class methodsFor: 'constants' stamp: 'Igor.Stasenko 5/2/2010 16:26'! heapConstants HEAP_CREATE_ENABLE_EXECUTE := 16r00040000. HEAP_GENERATE_EXCEPTIONS := 16r00000004. HEAP_NO_SERIALIZE := 16r00000001. HEAP_REALLOC_IN_PLACE_ONLY := 16r00000010. HEAP_ZERO_MEMORY := 16r00000008.! ! !NBWinConstants class methodsFor: 'constants' stamp: 'TorstenBergmann 8/13/2013 19:23'! getWindowConstants GW_HWNDFIRST := 0. GW_HWNDLAST := 1. GW_HWNDNEXT := 2. GW_HWNDPREV := 3. GW_OWNER := 4. GW_CHILD := 5. GW_ENABLEDPOPUP := 6. ! ! !NBWinConstants class methodsFor: 'constants' stamp: 'Igor.Stasenko 5/17/2010 14:27'! windowCreationConstants CW_USEDEFAULT := 16r80000000. ! ! !NBWinConstants class methodsFor: 'constants' stamp: 'Igor.Stasenko 5/18/2010 04:07'! gdiConstants " pixel types " PFD_TYPE_RGBA := 0. PFD_TYPE_COLORINDEX := 1. " layer types " PFD_MAIN_PLANE := 0. PFD_OVERLAY_PLANE := 1. PFD_UNDERLAY_PLANE := -1. " PIXELFORMATDESCRIPTOR flags " PFD_DOUBLEBUFFER := 16r00000001. PFD_STEREO := 16r00000002. PFD_DRAW_TO_WINDOW := 16r00000004. PFD_DRAW_TO_BITMAP := 16r00000008. PFD_SUPPORT_GDI := 16r00000010. PFD_SUPPORT_OPENGL := 16r00000020. PFD_GENERIC_FORMAT := 16r00000040. PFD_NEED_PALETTE := 16r00000080. PFD_NEED_SYSTEM_PALETTE := 16r00000100. PFD_SWAP_EXCHANGE := 16r00000200. PFD_SWAP_COPY := 16r00000400. PFD_SWAP_LAYER_BUFFERS := 16r00000800. PFD_GENERIC_ACCELERATED := 16r00001000. PFD_SUPPORT_DIRECTDRAW := 16r00002000. " PIXELFORMATDESCRIPTOR flags for use in ChoosePixelFormat only " PFD_DEPTH_DONTCARE := 16r20000000. PFD_DOUBLEBUFFER_DONTCARE := 16r40000000. PFD_STEREO_DONTCARE := 16r80000000. ! ! !NBWinTest class methodsFor: 'interface building' stamp: 'Igor.Stasenko 4/29/2010 15:35'! createWindow " NBWin32Window createWindowExA: lpClassName: lpWindowName: dwStyle: x: y: width: height: hWndParent: hMenu: hInstance: lParam: "! ! !NBWinTypes class methodsFor: 'object types' stamp: 'Igor.Stasenko 5/17/2010 15:19'! objTypes WNDCLASSEX := #NBWndClassEx! ! !NBWinTypes class methodsFor: 'initialization' stamp: 'TorstenBergmann 8/13/2013 20:54'! initialize " self initialize " BOOL := #bool. DWORD := #ulong. HWND := #NBWin32Window. POINT := #NBWin32Point. RECT := #NBWin32Rectangle. HDC := #NBWin32Hdc. HMENU := #HANDLE. UINT := #ulong. ATOM := #WORD. BOOLEAN := #BYTE. BYTE := #unsignedByte. CALLBACK := #'void*'. CHAR := #char. COLORREF := #DWORD. DWORDLONG := #ULONGLONG. DWORD32 := #ulong. DWORD64 := #ulonglong. FLOAT := #float. HRESULT := #LONG. INT := #long. INT32 := #long. INT64 := #longlong. LANGID := #WORD. LCID := #DWORD. LCTYPE := #DWORD. LGRPID := #DWORD. LONG := #long. LONGLONG := #longlong. LONG32 := #long. LONG64 := #longlong. LPARAM := #'LONG_PTR'. LPBOOL := #'BOOL*'. LPBYTE := #'BYTE*'. LPCOLORREF := #'DWORD*'. LPCVOID := #'void*'. LPDWORD := #'DWORD*'. WNDPROC := #'void*'. HANDLE := #NBWin32Handle. HINSTANCE := HMODULE := HCURSOR := HBRUSH := HACCEL := HCOLORSPACE := HCONV := HICON := HCONVLIST := HDDEDATA := HDESK := HDROP := HDWP := HENHMETAFILE := HFILE := HFONT := HGDIOBJ := HGLOBAL := HHOOK := HKEY := HKL := HLOCAL := HMETAFILE := HMODULE := HMONITOR := HPALETTE := HPEN := HRGN := HRSRC := HSZ := HWINSTA := #HANDLE. self initialize2. self initialize3. self stringTypes. self objTypes. ! ! !NBWinTypes class methodsFor: 'initialization' stamp: 'Igor.Stasenko 4/29/2010 14:23'! initialize3 " self initialize " LPHANDLE := 'HANDLE*'. LPINT := 'INT*'. LPLONG := 'LONG*'. LPVOID := 'void*'. LPWORD := 'WORD*'. LRESULT := 'LONG_PTR'. PBOOL := 'BOOL*'. PBOOLEAN := 'BOOLEAN*'. PBYTE := 'BYTE*'. PCHAR := 'CHAR*'. PDWORD := 'DWORD*'. PDWORDLONG := 'DWORDLONG*'. PDWORD32 := 'DWORD32*'. PDWORD64 := 'PDWORD64*'. PFLOAT := 'FLOAT*'. PHANDLE :='HANDLE*'. PHKEY := 'HKEY*'. PINT := 'INT*'. PINT32 := 'INT32*'. PINT64 := 'INT64*'. PLCID := 'PDWORD'. PLONG := 'LONG*'. PLONGLONG := 'LONGLONG*'. PLONG32 := 'LONG32*'. PLONG64 := 'LONG64*'. PSHORT := 'SHORT*'. PTBYTE := 'TBYTE*'. PTCHAR := 'TCHAR*'. PUCHAR := 'UCHAR*'. PUINT := 'UINT*'. PUINT32 := 'UINT32*'. PUINT64 := 'UINT64*'. PULONG := 'ULONG*'. PULONGLONG := 'ULONGLONG*'. PULONG32 := 'ULONG32*'. PULONG64 := 'ULONG64*'. PUSHORT := 'USHORT*'. PVOID := 'void*'. PWCHAR := 'WCHAR*'. PWORD := 'WORD*'. SHORT := 'short'. TBYTE := 'TCHAR'. UCHAR := #uchar. UINT := #uint. UINT32 := #uint. UINT64 := #uint64. ULONG := #ulong. ULONGLONG := #ulonglong. ULONG32 := #uint. ULONG64 := #uint64. USHORT := #ushort. USN := #LONGLONG. VOID := #void. WCHAR := #ushort. WORD := #ushort. WPARAM := #'UINT_PTR'. ! ! !NBWinTypes class methodsFor: 'initialization' stamp: 'Igor.Stasenko 5/17/2010 05:24'! stringTypes TCHAR := #NBTCHAR. LPTCH := 'TCHAR*'. WCHAR := 'wchar_t'. LPWCH := 'WCHAR*'. LPTSTR := #NBTString. LPWSTR := #NBWideString. LPSTR := #NBExternalString. LPCSTR := #LPSTR. LPCTSTR := #LPTSTR. LPCWSTR := #LPWSTR. PCSTR := #LPCSTR. PCTSTR := #LPCTSTR. PCWSTR := #LPCWSTR. PSTR := #LPSTR. PTSTR := #LPTSTR. PWSTR := #LPWSTR. ! ! !NBWinTypes class methodsFor: 'initialization' stamp: 'Igor.Stasenko 4/29/2010 13:37'! initialize2 " self initialize " DWORD_PTR := #ULONG_PTR. HALF_PTR := #short. "Half the size of a pointer" INT_PTR := #long. LONG_PTR := #long. PDWORD_PTR := 'DWORD_PTR*'. PHALF_PTR := 'HALF_PTR*'. PINT_PTR := 'INT_PTR*'. PLONG_PTR := 'LONG_PTR*'. POINTER_32 := '__ptr32'. POINTER_64 := '__ptr64'. PSIZE_T := 'SIZE_T*'. PSSIZE_T := 'SSIZE_T*'. PUHALF_PTR := 'UHALF_PTR*'. PUINT_PTR := 'UINT_PTR*'. PULONG_PTR := 'ULONG_PTR*'. SC_HANDLE := #HANDLE. SC_LOCK := #LPVOID. SERVICE_STATUS_HANDLE := #HANDLE. SIZE_T := 'ULONG_PTR'. SSIZE_T := 'LONG_PTR'. UHALF_PTR := #ushort. "different in 32/64" UINT_PTR := #uint. ULONG_PTR := #ulong. "different in 32/64" ! ! !NBWndClassEx methodsFor: 'registering' stamp: 'IgorStasenko 11/24/2012 16:24'! register ^ self nbCallout stdcall function: #( ATOM RegisterClassExA (WNDCLASSEX * self) ) module: #user32! ! !NBWndClassEx methodsFor: 'initialization' stamp: 'jb 11/14/2013 12:40'! initialize self cbSize: (self class instanceSize).! ! !NBWndClassEx class methodsFor: 'fields description' stamp: 'Igor.Stasenko 5/19/2010 09:24'! fieldsDesc ^ #( UINT cbSize; UINT style; WNDPROC lpfnWndProc; int cbClsExtra; int cbWndExtra; HINSTANCE hInstance; HICON hIcon; HCURSOR hCursor; HBRUSH hbrBackground; NBExternalAddress lpszMenuName; NBExternalAddress lpszClassName; HICON hIconSm; )! ! !NBWndClassEx class methodsFor: 'unregistering' stamp: 'Igor.Stasenko 5/17/2010 18:54'! unregister: aWndClassName ^ self unregister: aWndClassName instance: NativeBoostWin32 getVMModuleHandle. ! ! !NBWndClassEx class methodsFor: 'unregistering' stamp: 'IgorStasenko 11/24/2012 17:40'! unregister: aWndClassName instance: hInstance ^ self nbCallout stdcall function: #( BOOL UnregisterClassA ( LPCTSTR aWndClassName, HINSTANCE hInstance )) module: #user32 ! ! !NECClassVarEntry commentStamp: ''! I represent a class Variable! !NECClassVarEntry methodsFor: 'accessing' stamp: ''! label ^ 'class variable'! ! !NECClassVarEntry methodsFor: 'accessing' stamp: 'IgorStasenko 9/16/2013 17:19'! type ^ #classVar! ! !NECClassVarEntry methodsFor: 'operations' stamp: ''! guessTypeWith: anECContext ^ anECContext guessClassVarClass: contents! ! !NECClassVarTypeGuesser commentStamp: ''! I'm a simple InstructionClient that tries to guess the type of a given class variable name of a class. ! !NECClassVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! send: selector super: supered numArgs: numberArguments ! ! !NECClassVarTypeGuesser methodsFor: 'instruction decoding' stamp: ''! popIntoReceiverVariable: offset self reset! ! !NECClassVarTypeGuesser methodsFor: 'public' stamp: ''! methodRefs | theClass classVarAssoc | theClass := receiverClass classThatDefinesClassVariable: variableName. classVarAssoc := theClass classPool associationAt: variableName asSymbol. classVarAssoc value ifNil: [ ^ SystemNavigation new allCallsOn: classVarAssoc ] ifNotNil: [ ^ classVarAssoc value class ]! ! !NECClassVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! popIntoLiteralVariable: anAssociation anAssociation key == variableName asSymbol ifTrue: [ found := true ] ifFalse: [ self reset ]! ! !NECClassVarTypeGuesserTest methodsFor: 'utils' stamp: ''! guessVariable: aString in: aClass expected: theClassExpected | typeGuesser result | typeGuesser := NECClassVarTypeGuesser variableName: aString class: aClass. result := typeGuesser perform. self assert: result == theClassExpected! ! !NECClassVarTypeGuesserTest methodsFor: 'tests' stamp: ''! testClassVar self guessVariable: 'ClassVar' in: NECTestClass expected: ByteString! ! !NECClassVarTypeGuesserTest methodsFor: 'tests' stamp: ''! testSuperClassVar self guessVariable: 'SuperClassVar' in: NECTestClass expected: Dictionary ! ! !NECClassVarTypeGuesserTest methodsFor: 'tests' stamp: ''! testDependentsFieldsClassVar self guessVariable: 'DependentsFields' in: NECTestClass expected: WeakIdentityKeyDictionary! ! !NECContext commentStamp: ''! A completion is started by the ECController. The controller creates me to compute the context of the completion. The most important information about the context are the receiverClass and the completionToken. I create a ECModel or subclass when requested by the 'model' method. I use SHParser and SHRange to parse the text input.! !NECContext methodsFor: 'private-compute-index' stamp: 'EstebanLorenzano 4/18/2012 12:52'! createEmptyRangeForGapAt: index | current previous | current := ranges at: index. previous := ranges at: (index - 1 max: 1). self insertEmptyRangeAt: index start: previous end + 1 end: current start - 1. ^ index! ! !NECContext methodsFor: 'private' stamp: ''! computeReceiverClass | previous found | recurseCount := 0. completionIndex = 1 ifTrue: [^nil]. found := self checkImpossibleReceiver. found ifTrue: [^nil]. previous := ranges at: completionIndex - 1. previous type = #cascadeSeparator ifTrue: [^self guessCascadeReceiver: completionIndex - 1]. (previous type = #unary and: [(self sourceOf: previous) = 'new' and: [completionIndex > 2]]) ifTrue: [previous := ranges at: completionIndex - 2. previous type = #globalVar ifTrue: [^self guessTypeOf: completionIndex - 2] ifFalse: [self configureSelectorsOnly. ^nil]]. ^self guessTypeOf: completionIndex - 1! ! !NECContext methodsFor: 'private' stamp: ''! compute completionIndex := self computeIndexOfPosition. receiverClass := self computeReceiverClass! ! !NECContext methodsFor: 'private-receiver-guessing' stamp: ''! isSelectorsOnly | previous | previous := ranges at: completionIndex - 1. ^previous isOpening! ! !NECContext methodsFor: 'private' stamp: ''! guessTempVarClass: aSHRange ^self guessTempVarClass: (self sourceOf: aSHRange) type: aSHRange type. ! ! !NECContext methodsFor: 'private' stamp: ''! guessCascadeReceiver: aNumber | type | aNumber to: 1 by: -1 do: [ :index | type := (ranges at: index) type. ((#(#statementSeparator #assignment #ansiAssignment ) includes: type) or: [ (type beginsWith: 'pattern') or: [ type beginsWith: 'methodTemp' ] ]) ifTrue: [ ^ self guessTypeOf: index + 1 ] ]. ^ nil! ! !NECContext methodsFor: 'private-receiver-guessing' stamp: ''! checkImpossibleReceiver ^ self isSelectorsAndVariables ifTrue: [self configureSelectorsAndVariables] ifFalse: [self isVariablesOnly ifTrue: [self configureVariablesOnly] ifFalse: [self isSelectorsOnly and: [self configureSelectorsOnly]]]. ! ! !NECContext methodsFor: 'private-roel-typer' stamp: ''! guessWithRoelTyper: aString class: aClass | typeCollector typeClass typeInfo types type | typeCollector := Smalltalk classNamed: #TypeCollector. typeCollector ifNil: [ ^ nil ]. typeClass := aClass whichClassDefinesInstVar: aString. typeClass ifNil: [ ^ nil ]. typeInfo := (typeCollector typeInstvarsOfClass: typeClass) at: aString asSymbol ifAbsent: [ ^ nil ]. types := typeInfo types size <= 2 ifTrue: [ typeInfo types ] ifFalse: [ typeInfo types intersection: typeInfo assignments ]. type := types isEmpty ifFalse: [ self findCommonSuperclass: types ]. ^ type == Object ifFalse: [ type ]! ! !NECContext methodsFor: 'private-type-guessing' stamp: 'NicolaiHess 2/18/2014 14:16'! guessTypeOf: aNumber | range | self configureSelectorsOnly. recurseCount > 10 ifTrue: [ ^ nil ]. recurseCount := recurseCount + 1. range := ranges at: aNumber. range isSelf ifTrue: [ ^theClass ]. range isSuper ifTrue: [ ^theClass superclass ]. range isConstant ifTrue: [ ^self nonAbstractTypeOf: range ]. range isArgument ifTrue: [ ^self guessArgument: range ]. range isTemporaryVariable ifTrue: [ ^self guessTempVarClass: range ]. range isInstanceVariable ifTrue: [ ^self guessInstVarClass: range ]. range isClassVariable ifTrue: [ ^self guessClassVarClass: range ]. range isGlobal ifTrue: [ ^self guessGlobal: aNumber ]. ^nil! ! !NECContext methodsFor: 'private' stamp: ''! sourceOf: aSHRange stopAt: aNumber ^ aSHRange type = #empty ifTrue: [String new] ifFalse: [source copyFrom: aSHRange start to: aNumber]! ! !NECContext methodsFor: 'initialization' stamp: ''! initialize super initialize. source := String new. position := 0. recurseCount := 0. variables := true. selectors := true. ranges := OrderedCollection new. completionIndex := 0. completionToken := nil! ! !NECContext methodsFor: 'private-type-guessing' stamp: 'NicolaiHess 2/18/2014 14:13'! nonAbstractTypeOf: aRange | cls | cls := aRange asType. cls hasAbstractMethods ifFalse: [ ^ cls ]. ^ (cls readFromString: (aRange textIn: source)) class! ! !NECContext methodsFor: 'private-temporaries' stamp: ''! convertBlocksToVariables: anOrderedCollection | result blockStack | blockStack := anOrderedCollection. result := OrderedCollection new. blockStack do: [ :each | result addAll: each ]. ^ result! ! !NECContext methodsFor: 'private' stamp: 'CamilloBruni 8/5/2012 23:52'! guessClassVarClass: aSHRange | aClass name | name := self sourceOf: aSHRange. aClass := controller guessTypeFor: name. aClass ifNotNil: [^ aClass]. ^ (NECClassVarTypeGuesser variableName: name class: theClass theMetaClass) perform! ! !NECContext methodsFor: 'private-configure' stamp: ''! configureSelectorsAndVariables variables := true. selectors := true. ^true! ! !NECContext methodsFor: 'private' stamp: 'SeanDeNigris 6/22/2012 18:24'! createRanges | parser | parser := SHParserST80 new on: controller model. ranges := parser rangesIn: source classOrMetaClass: theClass workspace: controller workspace environment: nil. ranges := ranges select: [:each | each type ~= #comment]! ! !NECContext methodsFor: 'private' stamp: ''! receiverClass ^ receiverClass! ! !NECContext methodsFor: 'private-compute-index' stamp: ''! createEmptyRangeAtTail | previous | previous := ranges last. ranges add: (SHRange start: previous end + 1 end: source size type: #empty). ^ ranges size! ! !NECContext methodsFor: 'private-temporaries' stamp: ''! handleBlockStack: aCollection with: aSHRange | range blockStack | range := aSHRange. blockStack := aCollection. range isBlockStart ifTrue: [ blockStack add: OrderedCollection new ] ifFalse: [ range isBlockEnd ifTrue: [ blockStack removeLast ] ]! ! !NECContext methodsFor: 'private' stamp: ''! sourceOf: aSHRange ^aSHRange isString ifTrue: [aSHRange] ifFalse: [self sourceOf: aSHRange stopAt: aSHRange end]! ! !NECContext methodsFor: 'accessing' stamp: ''! theClass ^theClass! ! !NECContext methodsFor: 'private-compute-index' stamp: ''! insertEmptyRangeAt: index start: start end: end ranges add: (SHRange start: start end: end type: #empty) beforeIndex: index! ! !NECContext methodsFor: 'private-configure' stamp: ''! configureVariablesOnly variables := true. selectors := false. ^true! ! !NECContext methodsFor: 'accessing' stamp: 'MarcusDenker 12/2/2013 14:07'! createModel | modelClass | self receiverClass ifNotNil: [^ NECTypedModel class: receiverClass]. (controller workspace isNil and: [theClass notNil]) ifTrue: [completionIndex = 1 ifTrue: [^ NECOverrideModel class: theClass]]. modelClass := NECUntypedModel. (controller model respondsTo: #modelClass) ifTrue: [ controller model modelClass ifNotNil: [:class | modelClass := class]]. ^ modelClass class: theClass temporaries: self temporaries additionals: controller additionals variables: variables selectors: selectors! ! !NECContext methodsFor: 'private' stamp: ''! findSourceRangeFor: aNumber aNumber to: ranges size by: 2 do: [:index | index + 3 > ranges size ifTrue: [^ nil]. (ranges at: index + 1) isAssignment ifTrue: [(ranges at: index + 3) type = #statementSeparator ifTrue: [^ index + 2] ifFalse: [(ranges at: index + 2) type = #globalVar ifTrue: [^ index + 2] ifFalse: [(ranges at: index + 1) isAssignment ifFalse: [^ nil]]]]]! ! !NECContext methodsFor: 'private-type-guessing' stamp: 'StephanEggermont 3/11/2014 11:18'! guessArgument: aSHRange | name | name := self sourceOf: aSHRange. (name = 'html') ifTrue: [ Smalltalk at: #WAHtmlCanvas ifPresent: [ :canvasClass | ^canvasClass]. Smalltalk at: #WARenderCanvas ifPresent: [ :canvasClass | ^canvasClass]]. ^ NECInstVarTypeGuesser getClassFromTypeSuggestingName: name! ! !NECContext methodsFor: 'private-configure' stamp: ''! configureSelectorsOnly variables := false. selectors := true. ^true! ! !NECContext methodsFor: 'private-temporaries' stamp: ''! blockTemporaries | blocks range vars | blocks := OrderedCollection new. 1 to: completionIndex - 1 do: [ :index | range := ranges at: index. self handleBlockStack: blocks with: range. range isBlockTemporary ifTrue: [ vars := blocks last. vars add: range ] ]. ^ self convertBlocksToVariables: blocks! ! !NECContext methodsFor: 'accessing' stamp: ''! completionToken completionToken ifNil: [ | range | range := ranges at: completionIndex. completionToken := self sourceOf: range stopAt: position. completionToken := completionToken wordBefore: completionToken size ]. ^ completionToken! ! !NECContext methodsFor: 'private-compute-index' stamp: ''! computeIndexOfPosition | current | self checkForZeroPosition ifTrue: [ ^ 1 ]. 1 to: ranges size do: [ :index | current := ranges at: index. (current includesPosition: position) ifTrue: [ ^ index ] ifFalse: [ current end > position ifTrue: [ ^ self createEmptyRangeForGapAt: index ] ] ]. ^ self createEmptyRangeAtTail! ! !NECContext methodsFor: 'private' stamp: ''! guessInstVarClass: aSHRange | aClass name | name := self sourceOf: aSHRange. aClass := controller guessTypeFor: name. aClass ifNotNil: [ ^ aClass ]. aClass := self guessWithRoelTyper: name class: theClass. aClass ifNotNil: [ ^ aClass ]. ^ (NECInstVarTypeGuesser variableName: name class: theClass) perform! ! !NECContext methodsFor: 'accessing' stamp: ''! model model isNil ifTrue: [ model := self createModel ]. ^ model! ! !NECContext methodsFor: 'action' stamp: ''! narrowWith: aString completionToken := aString. model ifNotNil: [ model narrowWith: aString ]! ! !NECContext methodsFor: 'private-receiver-guessing' stamp: ''! isSelectorsAndVariables | current | current := ranges at: completionIndex. ^current isUnfinished! ! !NECContext methodsFor: 'initialize-release' stamp: ''! setController: aECController class: aClass source: aString position: anInteger controller := aECController. theClass := aClass. source := aString. position := anInteger. self createRanges. self compute! ! !NECContext methodsFor: 'action' stamp: ''! switchToUntyped receiverClass := nil. self configureSelectorsAndVariables. model := self createModel! ! !NECContext methodsFor: 'private-compute-index' stamp: ''! checkForZeroPosition ^ (position = 0 or: [ranges isEmpty]) and: [self insertEmptyRangeAt: 1 start: 0 end: 1. true]! ! !NECContext methodsFor: 'private-roel-typer' stamp: ''! findCommonSuperclass: aCollection | current | aCollection isEmpty ifTrue: [ ^ nil ]. current := aCollection first. aCollection do: [ :class | [ class includesBehavior: current ] whileFalse: [ current := current superclass ] ]. ^ current! ! !NECContext methodsFor: 'private' stamp: ''! guessTempVarClass: aString type: aSymbol | current type varName varType sourceIndex aClass | aClass := controller guessTypeFor: aString. aClass ifNotNil: [ ^ aClass ]. varName := aString. varType := aSymbol. 1 to: completionIndex do: [ :index | current := ranges at: index. (current type = varType and: [ (self sourceOf: current) = varName and: [ index + 3 <= ranges size ] ]) ifTrue: [ (sourceIndex := self findSourceRangeFor: index) notNil ifTrue: [ type := self guessTypeOf: sourceIndex. type ifNotNil: [ ^ type ] ] ] ]. ^ nil! ! !NECContext methodsFor: 'accessing' stamp: ''! temporaries | tempRanges | tempRanges := ranges select: [ :each | #(#patternTempVar #patternArg ) includes: each type ]. tempRanges addAll: self blockTemporaries. ^ tempRanges collect: [ :each | NECLocalEntry contents: (self sourceOf: each) type: each type ]! ! !NECContext methodsFor: 'private-receiver-guessing' stamp: ''! isVariablesOnly | current previous | current := ranges at: completionIndex. ^ current isVariablesOnly or: [ current isOpening or: [ previous := ranges at: completionIndex - 1. previous isOpening or: [ previous isSeparator or: [ previous isKeyword or: [ previous isAssignment or: [ previous isBinary ] ] ] ] ] ]! ! !NECContext methodsFor: 'private-type-guessing' stamp: ''! guessGlobal: aNumber | aClass | aClass := Smalltalk at: (self sourceOf: (ranges at: aNumber)) asSymbol ifAbsent: [ ^ nil ]. aClass isBehavior ifFalse: [ ^ nil ]. aNumber = (completionIndex - 1) ifTrue: [ ^ aClass class ]. (ranges size >= (aNumber + 1) and: [ (ranges at: aNumber + 1) type = #statementSeparator ]) ifTrue: [ ^ aClass class ]. ^ aClass! ! !NECContext class methodsFor: 'instance creation' stamp: ''! controller: aECController class: aClass source: aString position: anInteger ^ self basicNew initialize setController: aECController class: aClass source: aString position: anInteger! ! !NECContextTest methodsFor: 'tests' stamp: ''! testReceiverArgument | text context | text := 'testIt: aRectangle aRectangle printS'. context := self createContextFor: text at: text size. self assert: context receiverClass == Rectangle. text := 'testIt: rect rect is'. context := self createContextFor: text at: text size. self assert: context receiverClass isNil! ! !NECContextTest methodsFor: 'tests' stamp: ''! testCompletionToken | text context | text := 'testIt: aRectangle | abc | test. abc daf'. context := self createContextFor: text at: text size. self assert: context completionToken = 'daf'! ! !NECContextTest methodsFor: 'tests' stamp: 'NicolaiHess 2/19/2014 15:38'! testReceiverTempVar | text context | text := 'testIt | aha | aha _ ''test''. aha p'. context := self createContextFor: text at: text size. self assert: context receiverClass == ByteString. text := 'testIt | aha | ah _ ''test''. ah p'. context := self createContextFor: text at: text size. self assert: context receiverClass isNil. text := 'testIt | aha | aha _ constantString. aha p'. context := self createContextFor: text at: text size. self assert: context receiverClass == ByteString. text := 'testIt | aha | aha _ constant asDate. aha p'. context := self createContextFor: text at: text size. self assert: context receiverClass isNil. text := 'testIt | aha bili | aha _ constantString. bili _ aha. bili p'. context := self createContextFor: text at: text size. self assert: context receiverClass == ByteString. text := 'testIt | aha bili | aha _ constantString. bili _ aha _ 15. bili p'. context := self createContextFor: text at: text size. self assert: context receiverClass = SmallInteger. text := 'testIt | aha bili | aha _ constantString. bili _ 15. bili _ aha. bili p'. context := self createContextFor: text at: text size. self assert: context receiverClass == SmallInteger. text := 'testIt [ :each | |a| a _ 16. a print'. context := self createContextFor: text at: text size. self assert: context receiverClass == SmallInteger. text := 'testIt [ :each | |a| a _ Dictionary new. a print'. context := self createContextFor: text at: text size. self assert: context receiverClass == Dictionary. text := 'testIt [ :each | |a| a _ Dictionary. a print'. context := self createContextFor: text at: text size. self assert: context receiverClass == Dictionary class. text := 'testIt | aha | aha _ constantLargeInteger. aha p'. context := self createContextFor: text at: text size. self assert: context receiverClass = LargePositiveInteger.! ! !NECContextTest methodsFor: 'tests' stamp: ''! testCreateModel | text context | text := 'testIt: aRectangle aRectangle printS'. context := self createContextFor: text at: text size. self assert: context createModel class == NECTypedModel. text := 'testIt:'. context := self createContextFor: text at: text size. self assert: context createModel class = NECOverrideModel. text := 'testIt: rect rect is'. context := self createContextFor: text at: text size. self assert: context createModel class = NECUntypedModel! ! !NECContextTest methodsFor: 'private' stamp: 'CamilloBruni 8/21/2012 16:30'! checkUntypedVariablesOnly: aString | context model | context := self createContextFor: aString at: aString size. self assert: context isVariablesOnly. model := context model. model loadEntries. self assert: model hasMessage not. self assert: (model entriesOfType: #instVar) notEmpty. context narrowWith: 'a'. self assert: (model entriesOfType: #selector) isEmpty! ! !NECContextTest methodsFor: 'tests' stamp: ''! testBlockTemporariesBoxed | text temps context | text := 'testIt | a b c | a := [ :each | |d | d = a ifTrue:[ |x| ] ifFalse:[ |y|. ^self'. context := self createContextFor: text at: 73. temps := context temporaries collect: [ :each | each contents ]. self assert: temps size = 5. self assert: temps first = 'a'. self assert: temps second = 'b'. self assert: temps third = 'c'. self assert: temps fourth = 'each'. self assert: temps fifth = 'd'. ! ! !NECContextTest methodsFor: 'tests' stamp: ''! testReceiverClassVar | text context | text := 'testIt ClassVar '. context := self createContextFor: text at: text size. self assert: context receiverClass == ByteString! ! !NECContextTest methodsFor: 'tests' stamp: 'NicolaiHess 2/19/2014 15:31'! testReceiverConstant | text context | text := 'testIt 15r16 printS'. context := self createContextFor: text at: text size. self assert: context receiverClass == SmallInteger. text := 'testIt ''test'' printS'. context := self createContextFor: text at: text size. self assert: context receiverClass == ByteString. text := 'testIt true ifTrue:'. context := self createContextFor: text at: text size. self assert: context receiverClass == True. text := 'testIt false "this is it" printStr'. context := self createContextFor: text at: text size. self assert: context receiverClass == False. text := 'testIt a _ [ :test | test * test ] v'. context := self createContextFor: text at: text size. self assert: context receiverClass == BlockClosure. text := 'testIt $c as'. context := self createContextFor: text at: text size. self assert: context receiverClass == Character. text := 'testIt #gaga as'. context := self createContextFor: text at: text size. self assert: context receiverClass == Symbol. text := 'testIt #( 1 2 3) as'. context := self createContextFor: text at: text size. self assert: context receiverClass == Array. text:='testIt 2r1.1e2 as'. context := self createContextFor: text at: text size. self assert: context receiverClass == Float. text:='testIt 23s32 as'. context := self createContextFor: text at: text size. self assert: context receiverClass == ScaledDecimal. ! ! !NECContextTest methodsFor: 'tests' stamp: ''! testReceiverGlobal | text context | text := 'testIt Dictionary n'. context := self createContextFor: text at: text size. self assert: context receiverClass == Dictionary class. ! ! !NECContextTest methodsFor: 'tests' stamp: ''! testInTheMiddelOfAWord | text context | text := 'hagada'. context := self createContextFor: text at: 4. self assert: context completionToken = 'haga'! ! !NECContextTest methodsFor: 'tests' stamp: ''! testReceiverCascade | text context | text := 'testIt | b | b _ Stream new. b nextPutAll: ''test''; nextPut: $c; s'. context := self createContextFor: text at: text size. self assert: context receiverClass == Stream. text := 'testIt | b | b _ Stream new nextPutAll: ''test''; nextPut: $c with: true; s'. context := self createContextFor: text at: text size. self assert: context receiverClass == Stream. text := 'testIt: aStream | test | aStream nextPutAll: ''test''; nextPut: $c with: true; s'. context := self createContextFor: text at: text size. self assert: context receiverClass == Stream. text := 'testIt: aStream aStream nextPutAll: ''test''; nextPut: $c with: true; s'. context := self createContextFor: text at: text size. self assert: context receiverClass == Stream! ! !NECContextTest methodsFor: 'tests' stamp: ''! testEmpty self createContextFor: '' at: 0! ! !NECContextTest methodsFor: 'tests' stamp: ''! testReceiverTempVar2 | text context | text := 'openMenuFor: aParagraphEditor | theMenu | context := NECContext controller: self class: model receiverClass source: aParagraphEditor text string position: aParagraphEditor caret - 1. editor := aParagraphEditor. theMenu := NECMenuMorph controller: self position: (aParagraphEditor selectionPosition: context completionToken). theMenu isClosed ifFalse: [menuMorph := theMenu]. theMenu o'. context := self createContextFor: text at: text size. self assert: context receiverClass == NECMenuMorph! ! !NECContextTest methodsFor: 'private' stamp: ''! createContextFor: aString at: anInteger ^ NECContext controller: NECController new class: NECTestClass source: aString position: anInteger! ! !NECContextTest methodsFor: 'tests' stamp: ''! testUntypedVarsOnly self checkUntypedVariablesOnly: 'testIt '. self checkUntypedVariablesOnly: '+ aTest '. self checkUntypedVariablesOnly: 'gaga: aTest '. self checkUntypedVariablesOnly: 'gaga ^ '. self checkUntypedVariablesOnly: 'testIt a ifTrue:[ '. self checkUntypedVariablesOnly: 'testIt a ifTrue:[ :each'. self checkUntypedVariablesOnly: 'testIt a ifTrue:[ :each |'. self checkUntypedVariablesOnly: 'testIt a ifTrue:[ :each | '. self checkUntypedVariablesOnly: 'testIt '. self checkUntypedVariablesOnly: 'testIt ab _'. self checkUntypedVariablesOnly: 'testIt ab _ '. self checkUntypedVariablesOnly: 'self compare: '. self checkUntypedVariablesOnly: 'self compare: x caseSensitive: '. self checkUntypedVariablesOnly: 'self gaga: x gugu: ('. self checkUntypedVariablesOnly: 'testIt a _ 15 + '. self checkUntypedVariablesOnly: 'testIt self hugatada: '! ! !NECContextTest methodsFor: 'tests' stamp: ''! testUnfinishedString | text context | text := 'testIt: aRectangle | a b c | self test: ''test it and so'. context := self createContextFor: text at: text size. self assert: context completionToken = 'so'! ! !NECContextTest methodsFor: 'tests' stamp: ''! testBlockTemporaries | text temps context | text := 'testIt | a b c | a _ [ :each | |d | ^d]. ^self'. context := self createContextFor: text at: 39. temps := context temporaries collect: [ :each | each contents ]. self assert: temps size = 5. self assert: temps first = 'a'. self assert: temps second = 'b'. self assert: temps third = 'c'. self assert: temps fourth = 'each'. self assert: temps fifth = 'd'! ! !NECContextTest methodsFor: 'tests' stamp: ''! testReceiverGlobalVarNew | text context | text := 'testIt Dictionary new a'. context := self createContextFor: text at: text size. self assert: context receiverClass == Dictionary. ! ! !NECContextTest methodsFor: 'tests' stamp: ''! testTemporaries | text temps context | text := 'testIt: aRectangle | a b c | a _ [ :each | |d | ^d]. ^self'. context := self createContextFor: text at: text size. temps := context temporaries collect: [ :each | each contents ]. self assert: temps size = 4. self assert: temps first = 'aRectangle'. self assert: temps second = 'a'. self assert: temps third = 'b'. self assert: temps fourth = 'c'! ! !NECContextTest methodsFor: 'tests' stamp: ''! testCompletionTokenEmpty | text context | text := 'testIt: aRectangle | abc | test. abc daf '. context := self createContextFor: text at: text size. self assert: context completionToken = ''! ! !NECContextTest methodsFor: 'tests' stamp: ''! testUntypedSelectorsOnly | text context model | text := 'testIt: aRectangle | ab bc bd | ab '. context := self createContextFor: text at: text size. model := context model. self assert: model hasMessage. self assert: model message = 'press key for selectors'. context narrowWith: 'a'. self assert: (model entriesOfType: #selector) notEmpty. self assert: (model entriesOfType: #local) isEmpty. self assert: (model entriesOfType: #instance) isEmpty! ! !NECController commentStamp: ''! I live as an instance variable in a Browser, Debugger, Workspace or other window. I'm the glue between all participants of the completion system. I create the NECContext and pass myself to the NECMenuMorph. I process the keyboard events and pass them to the NECMenuMorph or close the morph if needed.! !NECController methodsFor: 'keyboard' stamp: 'EstebanLorenzano 2/25/2013 15:39'! smartBackspace | opposite currentText currentEditor smartCharacter | currentEditor := editor. currentEditor hasSelection ifTrue: [ ^ false ]. currentText := currentEditor text. smartCharacter := currentText at: currentEditor startIndex - 1 ifAbsent: [ ^ false ]. "take the opposite" opposite := self smartCharactersMapping at: smartCharacter ifAbsent: [ ^ false ]. "test if the next char is opposite" opposite = (currentText at: currentEditor stopIndex ifAbsent: [ ^ false ]) ifFalse: [ ^ false ]. "test if there is an extra opposite to remove" (self smartNeedExtraRemoveIn: currentText for: smartCharacter opposite: opposite at: currentEditor startIndex) ifFalse: [ ^ false ]. currentEditor closeTypeIn. currentEditor selectInvisiblyFrom: currentEditor startIndex - 1 to: currentEditor stopIndex. currentEditor replaceSelectionWith: currentEditor nullText. self invalidateEditorMorph. ^ true! ! !NECController methodsFor: 'keyboard' stamp: 'CamilleTeruel 2/12/2013 13:04'! smartCharacterWithEvent: anEvent "char is extracted from anEvent, anEvent is passed because we may need it. We may remove char if this is not costly." | opposite previous next char insertion insertionCenter | char := anEvent keyCharacter. editor hasSelection ifTrue: [ "we selected a piece of text and we type the same character that previously, so we unwrap it" "we selected a piece of text if the character is not a special one we do nothing." opposite := self smartCharactersMapping at: char ifAbsent: [ ^ nil ]. "else we wrap the selection" "editor replaceSelectionWith: (String with: char) , (editor selection) , (String with: opposite)." "ugly logic it should be encapsulated in the editor " anEvent shiftPressed ifTrue: [ editor shiftEnclose: anEvent ] ifFalse: [ editor enclose: anEvent ]. self invalidateEditorMorph. ^ true ]. "we are not in a selection" opposite := self smartCharactersMapping at: char ifAbsent: [ "if the character is not a special character" self smartInverseMapping at: char ifAbsent: [ ^ nil ]. "if the character is not a closing special character do nothing" "The character is special" editor blinkPrevParen: char. (editor nextCharacterIfAbsent: [ ^ nil ]) = char ifFalse: [ ^ nil ]. "do not get this test but if we comment it out we cannot type closing ) anymore" editor selectFrom: editor startIndex + 1 to: editor startIndex. self invalidateEditorMorph. ^ true ]. previous := editor previousCharacterIfAbsent: [ Character space ]. next := editor nextCharacterIfAbsent: [ Character space ]. insertion := next isSeparator ifFalse: [ char asString ] ifTrue: [ previous isSeparator ifFalse: [ char asString ] ifTrue: [ self newSmartCharacterInsertionStringForLeft: char right: opposite ]]. editor replaceSelectionWith: insertion. insertionCenter := insertion size // 2 max: 1. editor selectFrom: editor startIndex + insertionCenter to: editor startIndex + (insertionCenter - 1). self invalidateEditorMorph. ^ true! ! !NECController methodsFor: 'settings' stamp: ''! smartInverseMapping ^ inverseMapping ifNil: [ inverseMapping := Dictionary new. self smartCharactersMapping keysAndValuesDo: [ :key :value | inverseMapping at: value put: key ]. inverseMapping ]! ! !NECController methodsFor: 'keyboard' stamp: 'CamilloBruni 4/12/2013 16:29'! handleKeystrokeAfter: aKeyboardEvent editor: aParagraphEditor (aParagraphEditor isNil or: [ self isMenuOpen not ]) ifTrue: [ ^ self ]. aParagraphEditor atCompletionPosition ifFalse: [ ^ self closeMenu ]. self setModel: aParagraphEditor model. context narrowWith: aParagraphEditor wordAtCaret. menuMorph narrowCompletion. (context isNil or: [ context model isEmpty]) ifTrue: [ ^self closeMenu ]! ! !NECController methodsFor: 'keyboard' stamp: 'CamilloBruni 1/15/2013 15:51'! newSmartCharacterInsertionStringForLeft: left right: right ((NECPreferences smartCharactersWithDoubleSpace includes: left) or: [ (NECPreferences smartCharactersWithDoubleSpace includes: right)]) ifTrue: [ ^ String with: left with: Character space with: Character space with: right ]. ((NECPreferences smartCharactersWithSingleSpace includes: left) or: [ (NECPreferences smartCharactersWithSingleSpace includes: right)]) ifTrue: [ ^ String with: left with: Character space with: right ]. ^ String with: left with: right! ! !NECController methodsFor: 'accessing' stamp: ''! editor ^ editor! ! !NECController methodsFor: 'menu morph' stamp: 'CamilloBruni 10/21/2012 14:54'! closeMenu self stopCompletionDelay. menuMorph ifNotNil: [ menuMorph delete ]. menuMorph := nil.! ! !NECController methodsFor: 'accessing' stamp: ''! workspace ^nil! ! !NECController methodsFor: 'keyboard' stamp: ''! invalidateEditorMorph editor morph invalidRect: editor morph bounds. ! ! !NECController methodsFor: 'menu morph' stamp: 'IgorStasenko 9/16/2013 17:16'! openMenuFor: aParagraphEditor | theMenu | self stopCompletionDelay. context := self contextClass controller: self class: model selectedClassOrMetaClass source: aParagraphEditor text string position: aParagraphEditor caret - 1. editor := aParagraphEditor. theMenu := self menuMorphClass controller: self position: (aParagraphEditor selectionPosition: context completionToken). theMenu isClosed ifFalse: [ menuMorph := theMenu ]. (context isNil or: [ context model isEmpty ]) ifTrue: [ ^self closeMenu ].! ! !NECController methodsFor: 'private' stamp: 'AlainPlantec 7/9/2013 12:38'! resetCompletionDelay "Open the popup after 100ms and only after certain characters" self stopCompletionDelay. self isMenuOpen ifTrue: [ ^ self ]. editor atCompletionPosition ifFalse: [ ^ self ]. completionDelay := [ (Delay forMilliseconds: NECPreferences popupAutomaticDelay) wait. UIManager default defer: [ editor atCompletionPosition ifTrue: [ self openMenu ]] ] fork. ! ! !NECController methodsFor: 'private' stamp: 'EstebanLorenzano 4/11/2012 16:40'! contextClass ^NECContext! ! !NECController methodsFor: 'initialize-release' stamp: ''! setModel: aStringHolder model := aStringHolder! ! !NECController methodsFor: 'private' stamp: 'IgorStasenko 8/28/2013 15:21'! setEditor: anObject editor ifNotNil: [ "make sure we unsubscribe from old editor" editor morph announcer unsubscribe: self. ]. editor := anObject. editor morph onAnnouncement: MorphLostFocus send: #closeMenu to: self.! ! !NECController methodsFor: 'menu morph' stamp: 'EstebanLorenzano 2/1/2013 15:51'! openMenu ^ self openMenuFor: editor.! ! !NECController methodsFor: 'settings' stamp: ''! smartCharacters ^ NECPreferences smartCharacters ! ! !NECController methodsFor: 'private' stamp: 'EstebanLorenzano 2/25/2013 15:35'! smartNeedExtraRemoveIn: currentText for: opposite "Test if smart remove need to remove an extra character when the smart character is equal to its opposite" (currentText select: [ :char | char = opposite ]) size odd ifTrue: [ ^ false ]. ^true! ! !NECController methodsFor: 'keyboard' stamp: 'MarcusDenker 10/5/2013 19:28'! handleKeystrokeWithoutMenu: aKeyboardEvent self editor atCompletionPosition ifFalse: [ ^ (self smartInputWithEvent: aKeyboardEvent ) notNil ]. self stopCompletionDelay. (NECPreferences popupShowWithShortcut matches: {aKeyboardEvent}) ifTrue: [ self openMenu. ^true ]. (self smartInputWithEvent: aKeyboardEvent ) ifNotNil: [ ^true ]. NECPreferences popupShowAutomatic ifTrue: [ (aKeyboardEvent anyModifierKeyPressed not and: [ aKeyboardEvent keyCharacter isCompletionCharacter ]) ifTrue: [ self resetCompletionDelay ] ]. ^ false! ! !NECController methodsFor: 'keyboard' stamp: 'CamilloBruni 8/26/2012 17:51'! leftArrow (menuMorph hideDetail) ifFalse: [ self closeMenu. ^ false ]. ^ true! ! !NECController methodsFor: 'type guessing' stamp: 'CamilloBruni 8/5/2012 23:39'! guessTypeFor: aString ^ model isNil ifFalse: [ model guessTypeForName: aString ]! ! !NECController methodsFor: 'private' stamp: 'EstebanLorenzano 2/25/2013 15:40'! smartNeedExtraRemoveIn: currentText for: smartCharacter opposite: opposite at: position "Test if we need to remove an extra character when removing a smart character (any kind of smart character)" smartCharacter = opposite ifTrue: [ (self smartNeedExtraRemoveIn: currentText for: opposite) ifFalse: [ ^ false ] ] ifFalse: [ (self smartNeedExtraRemovePairedIn: currentText for: smartCharacter opposite: opposite at: position) ifFalse: [ ^false ] ]. ^ true! ! !NECController methodsFor: 'private' stamp: 'EstebanLorenzano 2/25/2013 15:43'! smartNeedExtraRemovePairedIn: currentText for: smartCharacter opposite: opposite at: position "Test if we need to remove an extra character when removed a paired smart character. A paired smart character is any smart character who has an opposite who is diferent to itself: [], ()" | startIndex countSmart countOpposite | countSmart := 0. countOpposite := 0. startIndex := self smartStartIndexIn: currentText for: smartCharacter opposite: opposite at: position. (currentText allButFirst: startIndex) do: [ :char | char = smartCharacter ifTrue: [ countSmart := countSmart + 1 ]. char = opposite ifTrue: [ countOpposite := countOpposite + 1 ] ]. (countSmart > countOpposite and: [ (countOpposite - countSmart) odd ]) ifTrue: [ ^ false ]. ^true! ! !NECController methodsFor: '*tools-spotlight-extensions' stamp: 'EstebanLorenzano 5/22/2012 17:47'! selectedAndClose "Answers selected index (if exists) and delete morph" | index | ^menuMorph ifNotNil: [ index := menuMorph selected. [ (index notNil and: [ context model notEmpty ]) ifTrue: [ context model completionAt: index ] ifFalse: [ nil ] ] ensure: [ menuMorph delete ] ]! ! !NECController methodsFor: 'menu morph' stamp: 'EstebanLorenzano 4/18/2012 11:05'! isMenuEmpty ^menuMorph isNil or: [ self context model notNil and: [ self context model isEmpty ] ]! ! !NECController methodsFor: 'menu morph' stamp: ''! isMenuOpen ^menuMorph notNil! ! !NECController methodsFor: 'accessing' stamp: ''! model ^model! ! !NECController methodsFor: 'keyboard' stamp: 'MarcusDenker 10/5/2013 19:27'! handleKeystrokeBefore: aKeyboardEvent editor: anEditor "I return a boolean. true when I have handled the event and no futher processing is needed by the caller." | keyCharacter controlKeyPressed | self flag: #fixme. "this method should be split up" self setEditor: anEditor. self setModel: editor model. keyCharacter := aKeyboardEvent keyCharacter. controlKeyPressed := aKeyboardEvent controlKeyPressed. self isMenuOpen ifFalse: [ ^ self handleKeystrokeWithoutMenu: aKeyboardEvent ]. (keyCharacter = Character home and: [ self captureNavigationKeys ]) ifTrue: [ menuMorph home. ^ true ]. (keyCharacter = Character end and: [ controlKeyPressed not and: [ self captureNavigationKeys ] ]) ifTrue: [ menuMorph end. ^ true ]. (keyCharacter = Character arrowRight and: [ self captureNavigationKeys ]) ifTrue: [ menuMorph showDetail. ^ true ]. (keyCharacter = Character arrowLeft and: [ self captureNavigationKeys ]) ifTrue: [ ^ self leftArrow ]. keyCharacter = Character arrowUp ifTrue: [ menuMorph moveUp. ^ true ]. keyCharacter = Character arrowDown ifTrue: [ menuMorph moveDown. ^ true ]. keyCharacter = Character pageUp ifTrue: [ menuMorph pageUp. ^ true ]. keyCharacter = Character pageDown ifTrue: [ menuMorph pageDown. ^ true ]. (keyCharacter = Character cr and: [ NECPreferences useEnterToAccept ]) ifTrue: [ menuMorph insertSelected ifTrue: [ ^ true ] ]. keyCharacter = Character tab ifTrue: [ NECPreferences expandPrefixes ifFalse: [ menuMorph insertSelected ifTrue: [ ^ true ] ] ifTrue: [ menuMorph insertCommonPrefixOrSelected ifTrue: [ ^ true ] ] ]. self flag: #todo. "Removing for now... most of the shortcuts are broken and no time or need now to fix them" "(keyCharacter = $h and: [ controlKeyPressed ]) ifTrue: [ menuMorph help. ^ true ]. (keyCharacter = $t and: [ controlKeyPressed ]) ifTrue: [ menuMorph expand. ^ true ]. (keyCharacter = $u and: [ controlKeyPressed ]) ifTrue: [ menuMorph switchToUntyped. ^ true ]. " "All keys but the alphanumeric chars (without command and control ) and the backspace key do close the menu" keyCharacter = Character backspace ifTrue: [ editor isCaretBehindChar ifFalse: [ self closeMenu ]. ^ false ]. (controlKeyPressed not & aKeyboardEvent commandKeyPressed not and: [ aKeyboardEvent keyCharacter isCompletionCharacter ]) ifFalse: [ self closeMenu. ^ keyCharacter = Character escape ]. ^ false! ! !NECController methodsFor: 'private' stamp: 'CamilloBruni 8/6/2012 00:26'! stopCompletionDelay completionDelay ifNotNil: [ completionDelay terminate ].! ! !NECController methodsFor: 'private' stamp: 'EstebanLorenzano 4/11/2012 16:49'! menuMorphClass ^ NECMenuMorph! ! !NECController methodsFor: 'testing' stamp: 'CamilloBruni 8/26/2012 23:11'! captureNavigationKeys ^ NECPreferences captureNavigationKeys! ! !NECController methodsFor: 'settings' stamp: ''! smartCharactersMapping ^ NECPreferences smartCharactersMapping ! ! !NECController methodsFor: 'accessing' stamp: ''! additionals ^ nil! ! !NECController methodsFor: 'private' stamp: 'EstebanLorenzano 2/25/2013 15:33'! smartStartIndexIn: currentText for: smartCharacter opposite: opposite at: position (position - 1) to: 1 by: -1 do: [ :index | | char | char := currentText at: index. (char = smartCharacter or: [ char = opposite]) ifFalse: [ ^index ] ]. ^0! ! !NECController methodsFor: 'menu morph' stamp: 'EstebanLorenzano 2/1/2013 18:42'! menuClosed NECSymbols resetCachedSymbols. menuMorph := nil. context := nil.! ! !NECController methodsFor: 'accessing' stamp: ''! context ^context! ! !NECController methodsFor: 'keyboard' stamp: 'Sd 11/27/2012 20:57'! smartInputWithEvent: anEvent "aCharacter is extracted from anEvent, anEvent is passed because we may need it. We may remove aCharacter if this is not costly." anEvent keyCharacter = Character backspace ifTrue: [ self smartBackspace ifTrue: [ ^ true ]]. self smartCharacters ifFalse: [ ^ nil ]. ^ self smartCharacterWithEvent: anEvent! ! !NECController class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 4/12/2012 13:43'! initialize self register! ! !NECController class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/12/2012 13:24'! allowModel: aModel ^NECPreferences enabled and: [ aModel isCodeCompletionAllowed ]! ! !NECController class methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/23/2012 13:48'! codeCompletionAround: aBlock textMorph: aTextMorph keyStroke: evt "Inserts code completion if allowed in this morph" | editor stringHolder completionAllowed controller | editor := aTextMorph editor. stringHolder := editor ifNotNil:[ editor model ]. completionAllowed := self allowModel: stringHolder. completionAllowed ifTrue: [ controller := self uniqueInstance. controller setModel: stringHolder. (controller handleKeystrokeBefore: evt editor: editor) ifTrue: [^ self ] ]. aBlock value. completionAllowed ifTrue: [ controller handleKeystrokeAfter: evt editor: editor ]! ! !NECController class methodsFor: 'tools registry' stamp: 'EstebanLorenzano 4/12/2012 13:44'! register self registerToolsOn: Smalltalk tools.! ! !NECController class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 4/11/2012 15:08'! reset uniqueInstance := nil ! ! !NECController class methodsFor: 'tools registry' stamp: 'EstebanLorenzano 4/11/2012 10:47'! registerToolsOn: registry "self registerToolsOn: Smalltalk tools" registry register: self as: #codeCompletion ! ! !NECController class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 4/11/2012 11:26'! uniqueInstance ^uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! ! !NECController class methodsFor: 'cleanup' stamp: 'MarcusDenker 4/24/2013 13:43'! cleanUp self reset! ! !NECControllerTest commentStamp: ''! A NECControllerTest is a test class for testing the behavior of NECController! !NECControllerTest methodsFor: 'tests-keyboard' stamp: 'EstebanLorenzano 2/25/2013 15:49'! testSmartNeedExtraRemoveInForOppositeAt self assert: (controller smartNeedExtraRemoveIn: '()' for: $( opposite:$) at:1). self deny: (controller smartNeedExtraRemoveIn: '(()' for: $( opposite:$) at:2). self assert: (controller smartNeedExtraRemoveIn: '(1()' for: $( opposite:$) at:3). self assert: (controller smartNeedExtraRemoveIn: '(1(1())' for: $( opposite:$) at:5). self assert: (controller smartNeedExtraRemoveIn: '((1)1())))' for: $( opposite:$) at:6). self deny: (controller smartNeedExtraRemoveIn: '()(()' for: $( opposite:$) at:3). self assert: (controller smartNeedExtraRemoveIn: '(foobar()' for: $( opposite:$) at:8).! ! !NECControllerTest methodsFor: 'initialize' stamp: 'EstebanLorenzano 2/25/2013 14:30'! tearDown "Tearing down code for NECControllerTest" controller := nil.! ! !NECControllerTest methodsFor: 'initialize' stamp: 'EstebanLorenzano 2/25/2013 14:30'! setUp "Setting up code for NECControllerTest" controller := NECController new.! ! !NECDetailMorph commentStamp: ''! I display some detail information for a selected ECEntry in the ECMenuMorph. The content I show, is provided by an ECDetailContentProvider subclass. ! !NECDetailMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/6/2012 00:34'! entryDescription: anECEntryDescription | categoryContents entryDescription | entryDescription := anECEntryDescription. title contents: (entryDescription title ifNil: [ description bounds: self titleBounds. String new] ifNotNil: [ description bounds: self descriptionBounds. entryDescription title]). description contentsWrapped: entryDescription description. categoryContents := entryDescription label. label contents: categoryContents! ! !NECDetailMorph methodsFor: 'drawing' stamp: ''! defaultColor ^ NECMenuMorph backgroundColor. ! ! !NECDetailMorph methodsFor: 'drawing' stamp: ''! bounds ^ super bounds topLeft extent: self class width @ self class height! ! !NECDetailMorph methodsFor: 'drawing' stamp: 'CamilloBruni 8/4/2012 01:49'! drawOn: aCanvas super drawOn: aCanvas. arrowPosition ifNotNil: [ self drawArrowOn: aCanvas. self drawMessageOn: aCanvas]! ! !NECDetailMorph methodsFor: 'accessing' stamp: ''! titleBounds ^ self contentBounds top: self contentBounds top + 10! ! !NECDetailMorph methodsFor: 'drawing' stamp: ''! messageFont ^ NECMenuMorph messageFont! ! !NECDetailMorph methodsFor: 'drawing' stamp: ''! drawArrowOn: aCanvas | point factor poligon | factor := self itemHeight. point := arrowPosition. poligon := OrderedCollection new. poligon add: point. poligon add: (point := point translateBy: (factor / 2) @ 0). poligon add: (point := point translateBy: 0 @ (factor * -0.5)). poligon add: (point := point translateBy: factor @ factor). poligon add: (point := point translateBy: (factor * -1) @ factor). poligon add: (point := point translateBy: 0 @ (factor * -0.5)). poligon add: (point := point translateBy: (factor * -0.5) @ 0). aCanvas drawPolygon: poligon fillStyle: self scrollColor! ! !NECDetailMorph methodsFor: 'drawing' stamp: ''! contentBounds | factor rectangle | factor := self itemHeight. rectangle := self bounds top: self bounds top + 3. rectangle := rectangle left: rectangle left + (factor * 2.0). rectangle := rectangle bottom: rectangle bottom - factor. ^ rectangle! ! !NECDetailMorph methodsFor: 'initialization' stamp: 'CamilloBruni 8/7/2012 11:41'! initialize | childBounds | super initialize. self borderStyle: (BorderStyle color: Color gray width: 1). childBounds := self contentBounds. label := StringMorph contents: '' font: self messageFont. label bounds: childBounds. self addMorph: label. title := StringMorph contents: '' font: NECMenuMorph titleFont. title bounds: self titleBounds. self addMorph: title. description := TextMorph new. description autoFit: false. description bounds: self descriptionBounds. description borderWidth: 0. self addMorph: description! ! !NECDetailMorph methodsFor: 'drawing' stamp: 'CamilloBruni 8/7/2012 11:40'! drawMessageOn: aCanvas | factor rectangle width browseMessage | factor := self itemHeight. rectangle := self bounds top: self bounds bottom - factor. rectangle := rectangle left: self contentBounds left. aCanvas line: rectangle topLeft to: rectangle topRight color: Color darkGray. rectangle := rectangle top: rectangle top + 1. aCanvas drawString: '<- close detail' in: rectangle font: self messageFont color: Color darkGray. browseMessage := 'browse ->'. width := self messageFont widthOfString: browseMessage. aCanvas drawString: browseMessage in: (rectangle left: rectangle right - width) font: self messageFont color: Color darkGray! ! !NECDetailMorph methodsFor: 'drawing' stamp: ''! itemHeight ^ NECMenuMorph itemHeight! ! !NECDetailMorph methodsFor: 'drawing' stamp: ''! scrollColor ^ NECMenuMorph scrollColor! ! !NECDetailMorph methodsFor: 'private' stamp: ''! positionOnLeft: anInteger ^ arrowPosition x - self class width - anInteger ! ! !NECDetailMorph methodsFor: 'drawing' stamp: 'CamilloBruni 8/7/2012 11:41'! position: aPoint menuWidth: anInteger | y x | arrowPosition := aPoint. y := aPoint y + self class height. y := y > Display height ifTrue: [Display height - self class height] ifFalse: [aPoint y - self itemHeight]. x := aPoint x. x := x + self class width > Display width ifTrue: [ arrowPosition := (self positionOnLeft: anInteger) @ aPoint y. arrowPosition x] ifFalse: [x]. self position: x @ y! ! !NECDetailMorph methodsFor: 'accessing' stamp: ''! descriptionBounds ^ self contentBounds top: self contentBounds top + 30! ! !NECDetailMorph class methodsFor: 'private' stamp: ''! width ^ NECMenuMorph itemWidth * 2.0! ! !NECDetailMorph class methodsFor: 'private' stamp: ''! height ^ NECMenuMorph itemHeight * 15.5! ! !NECEntry commentStamp: 'bar 10/5/2005 23:31'! I represent a completion entry that is management by a ECModel and shown in the ECMenuMorph as a menu entry.! !NECEntry methodsFor: 'accessing' stamp: ''! contentsAsSymbol ^ contents asSymbol ! ! !NECEntry methodsFor: 'detail information' stamp: ''! createDescriptionWith: anECContext | clazz | clazz := self guessTypeWith: anECContext. ^ clazz ifNil: [ NECEntryDescription label: self label ] ifNotNil: [ NECEntryDescription label: self label title: clazz printString description: clazz comment ]! ! !NECEntry methodsFor: 'testing' stamp: ''! isLocal ^ false! ! !NECEntry methodsFor: 'accessing' stamp: 'IgorStasenko 9/16/2013 17:18'! setContents: aString contents := aString.! ! !NECEntry methodsFor: 'testing' stamp: ''! isInstance ^ false! ! !NECEntry methodsFor: 'accessing' stamp: ''! setContents: aString type: aSymbol contents := aString. type := aSymbol! ! !NECEntry methodsFor: 'accessing' stamp: ''! completion ^ self contents asSymbol! ! !NECEntry methodsFor: 'accessing' stamp: ''! label ^ 'unknown'! ! !NECEntry methodsFor: 'printing' stamp: 'IgorStasenko 9/16/2013 17:21'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(; nextPutAll: contents asString; nextPut: $,; nextPutAll: self type; nextPut: $)! ! !NECEntry methodsFor: 'operations' stamp: ''! descriptionWith: anECContext description ifNotNil: [ ^ description ]. ^ description := self createDescriptionWith: anECContext! ! !NECEntry methodsFor: 'operations' stamp: ''! guessTypeWith: anECContext ^ nil! ! !NECEntry methodsFor: 'accessing' stamp: ''! type ^type! ! !NECEntry methodsFor: 'conversion' stamp: 'CamilloBruni 8/4/2012 02:07'! asNECEntry ^ self! ! !NECEntry methodsFor: 'operations' stamp: 'IgorStasenko 9/16/2013 17:27'! browseWith: anECContext | guessType | guessType := self guessTypeWith: anECContext. guessType ifNil: [^ false]. SystemNavigation new browseClass: guessType. ^ true! ! !NECEntry methodsFor: 'accessing' stamp: ''! contents ^contents! ! !NECEntry methodsFor: 'operations' stamp: ''! <= aECEntry ^ contents <= aECEntry contents! ! !NECEntry methodsFor: 'testing' stamp: ''! isSelector ^ false! ! !NECEntry class methodsFor: 'instance creation' stamp: ''! contents: aString type: aSymbol ^ self new setContents: aString type: aSymbol! ! !NECEntry class methodsFor: 'instance creation' stamp: 'IgorStasenko 9/16/2013 17:18'! contents: aString ^ self new setContents: aString! ! !NECEntryDescription commentStamp: ''! A NECEntryDescription is a holder for some information to be displayed.! !NECEntryDescription methodsFor: 'initialize-release' stamp: ''! setLabel: firstString title: secondString description: thirdString label := firstString. title := secondString. description := thirdString! ! !NECEntryDescription methodsFor: 'accessing' stamp: ''! description ( description isNil or:[description isEmpty]) ifTrue:[^'-']. ^ description! ! !NECEntryDescription methodsFor: 'accessing' stamp: ''! label ^ label! ! !NECEntryDescription methodsFor: 'accessing' stamp: ''! title ^ title! ! !NECEntryDescription class methodsFor: 'instance creation' stamp: ''! label: firstString ^ self new setLabel: firstString title: '(unknown)' description: nil! ! !NECEntryDescription class methodsFor: 'instance creation' stamp: ''! label: firstString title: secondString description: thirdString ^ self new setLabel: firstString title: secondString description: thirdString! ! !NECEntryTest methodsFor: 'tests' stamp: ''! testLocal | entry | entry := NECLocalEntry contents: 'abc' type: #patternArg:. self assert: entry contents = 'abc'. self assert: entry type = #patternArg:. self assert: entry isLocal! ! !NECEntryTest methodsFor: 'tests' stamp: ''! testPrintOn | entry | entry := NECSelectorEntry contents: 'compute' type: #unary:. self assert: 'NECSelectorEntry(compute,unary:)' = entry printString! ! !NECEntryTest methodsFor: 'tests' stamp: 'IgorStasenko 9/16/2013 17:30'! testInstance | entry | entry := NECInstVarEntry contents: 'abc'. self assert: entry isInstance! ! !NECEntryTest methodsFor: 'tests' stamp: ''! testCompletion | entry | entry := NECSelectorEntry contents: 'makeItHappen' type: #unary:. self assert: entry completion = #makeItHappen! ! !NECGlobalEntry commentStamp: ''! I represent a global variable.! !NECGlobalEntry methodsFor: 'accessing' stamp: ''! label ^ 'global'! ! !NECGlobalEntry methodsFor: 'accessing' stamp: 'IgorStasenko 9/16/2013 16:13'! type ^ #globalVar! ! !NECGlobalEntry methodsFor: 'operations' stamp: ''! guessTypeWith: anECContext | globalEntry | globalEntry := Smalltalk at: contents ifAbsent: [^ nil]. globalEntry isBehavior ifTrue: [^ globalEntry]. globalEntry ifNotNil: [^ globalEntry class]. ^ nil! ! !NECInstVarEntry commentStamp: ''! I represent an instance variable.! !NECInstVarEntry methodsFor: 'accessing' stamp: 'IgorStasenko 9/16/2013 17:29'! type ^ #instVar! ! !NECInstVarEntry methodsFor: 'testing' stamp: 'IgorStasenko 9/16/2013 16:15'! isInstance ^true! ! !NECInstVarEntry methodsFor: 'accessing' stamp: ''! label ^ 'instance variable'! ! !NECInstVarEntry methodsFor: 'operations' stamp: ''! guessTypeWith: anECContext ^ anECContext guessInstVarClass: contents! ! !NECInstVarTypeGuesser commentStamp: ''! I'm a simple InstructionClient that tries to guess the type of a given instance variable name of a class. ! !NECInstVarTypeGuesser methodsFor: 'public' stamp: ''! methodRefs | theClass selectors | theClass := receiverClass classThatDefinesInstanceVariable: variableName. theClass ifNil: [ ^ nil ]. selectors := theClass whichSelectorsStoreInto: variableName. ^ selectors collect: [ :each | RGMethodDefinition realClass: theClass selector: each]! ! !NECInstVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! prepare: aCompiledMethod | theClass | super prepare: aCompiledMethod. theClass := aCompiledMethod realClass. varIndex := (theClass allInstVarNames indexOf: variableName) - 1! ! !NECInstVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! popIntoReceiverVariable: offset varIndex = offset ifTrue: [ found := true ] ifFalse: [ self reset ]! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testConstantBoolean self guessVariable: 'constantBoolean' in: NECTestClass expected: True! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testMessageSend self guessVariable: 'messageSend' in: NECTestClass expected: Dictionary! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testConstantSymbol self guessVariable: 'constantSymbol' in: NECTestClass expected: ByteSymbol! ! !NECInstVarTypeGuesserTest methodsFor: 'private' stamp: ''! guessVariable: aString in: aClass expected: theClassExpected | typeGuesser result | typeGuesser := NECInstVarTypeGuesser variableName: aString class: aClass. result := typeGuesser perform. self assert: result == theClassExpected! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testConstantArray self guessVariable: 'constantArray' in: NECTestClass expected: Array! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testConstantIntegerNil self guessVariable: 'constantNil' in: NECTestClass expected: nil! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testMessageSend2 self guessVariable: 'messageSend2' in: NECTestClass expected: nil! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testSuperWithAnotherInit self guessVariable: 'superInstVar' in: NECTestClass expected: Dictionary! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testComplexInit2 self guessVariable: 'complexInit2' in: NECTestClass expected: Dictionary! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testConstantInteger self guessVariable: 'constantInteger' in: NECTestClass expected: SmallInteger! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testGlobalVarKeyword self guessVariable: 'globalVarKeyword' in: NECTestClass expected: SortedCollection! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testGlobalVarKeyword2 self guessVariable: 'globalVarKeyword2' in: NECTestClass expected: SortedCollection! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testTypeSuggestingParameter self guessVariable: 'typeSuggestingParameter2' in: NECTestClass expected: Rectangle! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testConstantString self guessVariable: 'constantString' in: NECTestClass expected: ByteString! ! !NECInstVarTypeGuesserTest methodsFor: 'testing' stamp: ''! testComplexInit self guessVariable: 'complexInit' in: NECTestClass expected: nil! ! !NECLocalEntry commentStamp: ''! I represent a local variable! !NECLocalEntry methodsFor: 'accessing' stamp: ''! label ^ 'local variable'! ! !NECLocalEntry methodsFor: 'testing' stamp: ''! isLocal ^true! ! !NECLocalEntry methodsFor: 'operations' stamp: 'IgorStasenko 9/16/2013 17:26'! guessTypeWith: anECContext ^ (anECContext guessTempVarClass: contents type: self type) ifNil: [anECContext guessArgument: contents]! ! !NECMenuMorph commentStamp: ''! I show the possible completions in a menu like appearance. The user may choose an entry from my list and complete the word he was typing in the editor. I'm showed with the Tab key and will be deleted when with ESC key or when a successful completion occurs. The following keystrokes are supported: Ctrl-Space or Tab: Open a new morph. Tab requires at least one character in front of the cursor. When already open complete the selected entry. Esc: Close me Ctrl+u: Change to untyped mode, so I show all selectors of all classes in the system and the variables that are accessible to the current context. Arrow Up: Move one entry up. Arrow Down: Move one entry down Enter: (like Ctrl-Space and Tab): Complete with the selected item and close the morph any letter or digit: Narrow the completion further Ctrl+t: Toggle the expand flag. When expand is disabled, you don't see selectors belonging to Object and ProtoObject. ! !NECMenuMorph methodsFor: 'drawing' stamp: 'CamilloBruni 8/4/2012 02:11'! drawLine: index on: aCanvas rectangle: rectangle | symbol font type string preString model highlightRectangle | model := context model. symbol := model entries at: index. string := symbol contents. preString := string asLowercase findString: context completionToken asLowercase. preString <= 0 ifFalse: [ preString := string first: preString - 1 ] ifTrue: [ preString := String empty ]. type := symbol type. font := self selectFont: type. index = self selected ifTrue: [ | rect | rect := rectangle withBottom: rectangle top + self class itemHeight. aCanvas fillRectangle: rect color: self class scrollColor. self detailPosition: rect topRight ]. highlightRectangle := rectangle translateBy: (font widthOfString: preString) @ 0. highlightRectangle := highlightRectangle withWidth: (font widthOfString: context completionToken). aCanvas fillRectangle: highlightRectangle color: (Color gray alpha: 0.3). aCanvas drawString: string in: (rectangle insetBy: 1) font: font color: (self selectColor: type).! ! !NECMenuMorph methodsFor: 'drawing' stamp: ''! prepareRectForNextRow: aRectangle ^aRectangle translateBy: 0 @ self class itemHeight! ! !NECMenuMorph methodsFor: 'actions' stamp: ''! showDetail detailMorph ifNotNil: [ ^ self browse ]. self itemsCount isZero ifTrue: [ ^ self ]. detailMorph := NECDetailMorph new. self addMorph: detailMorph. self updateDetail! ! !NECMenuMorph methodsFor: 'event handling' stamp: 'CamilloBruni 8/30/2012 16:55'! handlesMouseDown: anEvent ^ true! ! !NECMenuMorph methodsFor: 'accessing' stamp: ''! height | count | count := self class maxLength. self visible ifTrue: [ | height | height := World height - self bounds topLeft y. World submorphs do: [ :each | each class = TaskbarMorph ifTrue: [ height := height - each height ] ]. count := height // self class itemHeight - 1 min: count ]. ^ count asInteger isZero ifTrue: [ 1 ] ifFalse: [ count ]! ! !NECMenuMorph methodsFor: 'actions' stamp: 'IgorStasenko 9/16/2013 17:26'! browse (self selectedEntry browseWith: context) ifTrue: [ controller closeMenu ]! ! !NECMenuMorph methodsFor: 'actions' stamp: ''! moveUp (self selected = 0 and: [self firstVisible = 1]) ifTrue: [^ self]. self selected: self selected - 1. self selected < self firstVisible ifTrue: [firstVisible := firstVisible - 1]. self changed. ! ! !NECMenuMorph methodsFor: 'private' stamp: ''! visibleItemsCount. ^ self lastVisible - self firstVisible + 1! ! !NECMenuMorph methodsFor: 'initialization' stamp: 'CamilloBruni 8/26/2012 15:47'! initialize super initialize. self color: self class backgroundColor. self borderStyle: (BorderStyle color: Color gray width: 1). self when: #positionChanged send: #updateDetail to: self! ! !NECMenuMorph methodsFor: 'actions' stamp: 'SeanDeNigris 2/5/2013 13:03'! insertCommonPrefix "Return value: true if the user input has been handled, regardless of whether a prefix was inserted" | prefix | context model isEmpty ifTrue: [^ false]. context model entries size = 1 ifTrue: [ ^ self insertSelected ]. prefix := context model commonPrefix. self flag: 'Pending issue 7308, "controller editor wordAtCaret" below should be changed to "context completionToken"'. prefix size > controller editor wordAtCaret size ifTrue: [ self insertCompletion: prefix. context narrowWith: controller editor wordAtCaret ]. ^ true! ! !NECMenuMorph methodsFor: 'actions' stamp: ''! home self gotoPage: 1. self changed! ! !NECMenuMorph methodsFor: 'paging' stamp: ''! gotoPage: anInteger | item | item := (anInteger - 1) * self pageHeight + 1. item >= self itemsCount ifTrue: [ ^ self ]. item := item max: 1. firstVisible := item. self selected: firstVisible! ! !NECMenuMorph methodsFor: 'actions' stamp: ''! pageDown self gotoPage: self currentPage + 1. self changed. ! ! !NECMenuMorph methodsFor: 'initialization' stamp: 'CamilloBruni 8/30/2012 14:55'! createTitle | titleString transformationMorph | titleString := context model title ifNil: [ ^ self ]. titleStringMorph := StringMorph new. titleStringMorph contents: titleString; font: self class messageFont. transformationMorph := TransformationMorph new. transformationMorph rotationDegrees: -90.0; offset: self position negated - (0 @ (titleStringMorph width + 12)); addMorph: titleStringMorph. self addMorph: transformationMorph. self resize.! ! !NECMenuMorph methodsFor: 'drawing' stamp: 'CamilloBruni 8/30/2012 14:52'! resize | extent height | firstVisible := 1. height := self visibleItemsCount * self class itemHeight. pageHeight := self height asInteger. self hasMessage ifTrue: [ height := height + self class itemHeight ]. titleStringMorph ifNotNil: [ "titleStringMorph width: (titleStringMorph width min: 100)." height := height max: titleStringMorph width + 30 ]. extent := self class itemWidth @ height. self extent: extent.! ! !NECMenuMorph methodsFor: 'actions' stamp: 'CamilloBruni 8/26/2012 23:37'! insertSelected context model isEmpty ifTrue: [^ false]. self insertCompletion: (context model completionAt: self selected). self delete. ^ true! ! !NECMenuMorph methodsFor: 'drawing' stamp: ''! hasMessage ^ true ! ! !NECMenuMorph methodsFor: 'accessing' stamp: ''! selected: aNumber "Set the value of selected" context model notEmpty ifTrue: [ ((1 to: self itemsCount) includes: aNumber) ifTrue: [ aNumber ~= selected ifTrue: [ selected := aNumber ] ] ]! ! !NECMenuMorph methodsFor: 'drawing' stamp: 'CamilloBruni 8/7/2012 11:32'! drawOn: aCanvas | rectangle model | "draw background" super drawOn: aCanvas. rectangle := self bounds insetBy: 1. rectangle := rectangle bottom: rectangle top + self class itemHeight. rectangle := rectangle left: rectangle left + 20. model := context model. self extent: self extent. self firstVisible > 1 ifTrue: [ self drawTopScrollArrowOn: aCanvas ]. self lastVisible ~= self itemsCount ifTrue: [ self drawBottomScrollArrowOn: aCanvas ]. model notEmpty ifTrue: [ self firstVisible to: self lastVisible do: [ :index | self drawLine: index on: aCanvas rectangle: rectangle. rectangle := self prepareRectForNextRow: rectangle ]]. self drawMessageOn: aCanvas in: rectangle! ! !NECMenuMorph methodsFor: 'drawing' stamp: ''! selectColor: type ^ self class selectColorFor: type! ! !NECMenuMorph methodsFor: 'accessing' stamp: ''! detailPosition: aPoint detailPosition := aPoint. self triggerEvent: #positionChanged! ! !NECMenuMorph methodsFor: 'testing' stamp: 'CamilloBruni 8/26/2012 15:29'! takesKeyboardFocus ^ true! ! !NECMenuMorph methodsFor: 'actions' stamp: ''! end self gotoPage: self pageCount. self changed.! ! !NECMenuMorph methodsFor: 'actions' stamp: 'CamilloBruni 8/26/2012 18:25'! narrowCompletion | model | self selected: 0. firstVisible := 1. model := context model. model narrowWith: context completionToken. (model entries size = 1 and: [ model entries first contents = context completionToken ]) ifTrue: [ self delete. ^ false ]. model notEmpty ifTrue: [ self selected: 1 ]. self show. ^ true! ! !NECMenuMorph methodsFor: 'actions' stamp: ''! pageUp self gotoPage: self currentPage - 1. self changed. ! ! !NECMenuMorph methodsFor: 'drawing' stamp: ''! selectFont: aSymbol ^ self class selectFontFor: aSymbol! ! !NECMenuMorph methodsFor: 'private' stamp: ''! itemsCount ^context model entryCount! ! !NECMenuMorph methodsFor: 'private' stamp: ''! delete super delete. controller menuClosed! ! !NECMenuMorph methodsFor: 'paging' stamp: ''! pageHeight ^pageHeight.! ! !NECMenuMorph methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 2/9/2013 17:54'! insertCompletion: aString | caret old pos editor offset| editor := controller editor. caret := editor caret. editor selectInvisiblyFrom: caret - context completionToken size to: caret - 1. old := editor selection. editor zapSelectionWith: aString. offset := NECPreferences spaceAfterCompletion ifTrue: [ 1 ] ifFalse: [ 0 ]. pos := caret + (aString copyUpTo: $ ) size + offset - old size. editor selectAt: pos. editor morph invalidRect: editor morph bounds! ! !NECMenuMorph methodsFor: 'actions' stamp: 'EstebanLorenzano 2/1/2013 17:16'! help self class helpText asMorph openInWindowLabeled: self class helpTitle! ! !NECMenuMorph methodsFor: 'private' stamp: ''! isClosed ^ owner isNil! ! !NECMenuMorph methodsFor: 'actions' stamp: 'JohanBrichau 4/5/2013 22:30'! insertCommonPrefixOrSelected "Return value: true if the user input has been handled, regardless of whether a prefix was inserted" | prefix | context model isEmpty ifTrue: [^ false]. context model entries size = 1 ifTrue: [ ^ self insertSelected ]. prefix := context model commonPrefix. prefix = context model narrowString ifTrue:[^ self insertSelected]. self flag: 'Pending issue 7308, "controller editor wordAtCaret" below should be changed to "context completionToken"'. prefix size > controller editor wordAtCaret size ifTrue: [ self insertCompletion: prefix. context narrowWith: controller editor wordAtCaret ]. ^ true! ! !NECMenuMorph methodsFor: 'drawing' stamp: 'CamilloBruni 8/3/2012 20:33'! drawTopScrollArrowOn: aCanvas | aPolygon point arrowHeight | arrowHeight := self class scrollArrowSize. point := self bounds topLeft translateBy: 6 @ 11. aPolygon := Array with: point with: (point translateBy: arrowHeight @ 0) with: (point translateBy: arrowHeight / 2 @ arrowHeight negated). aCanvas drawPolygon: aPolygon fillStyle: Color black. ! ! !NECMenuMorph methodsFor: 'actions' stamp: 'CamilloBruni 8/26/2012 15:33'! close self delete.! ! !NECMenuMorph methodsFor: 'paging' stamp: ''! currentPage ^(self selected - 1 // self pageHeight ) + 1.! ! !NECMenuMorph methodsFor: 'private' stamp: ''! firstVisible ^firstVisible min: context model entryCount! ! !NECMenuMorph methodsFor: 'drawing' stamp: 'CamilloBruni 8/7/2012 11:35'! drawMessageOn: aCanvas in: rectangle self hasMessage ifFalse: [ ^ self ]. context model isEmpty ifFalse: [ aCanvas line: rectangle topLeft to: rectangle topRight color: Color gray ]. self drawModelMessageOn: aCanvas in: rectangle.! ! !NECMenuMorph methodsFor: 'actions' stamp: 'CamilloBruni 8/6/2012 00:29'! hideDetail detailMorph ifNil: [ ^ false ]. self removeMorph: detailMorph. detailMorph delete. detailMorph := nil. self changed. ^ true! ! !NECMenuMorph methodsFor: 'actions' stamp: 'CamilloBruni 8/30/2012 14:46'! show self resize. self activeHand newMouseFocus: self. self changed.! ! !NECMenuMorph methodsFor: 'actions' stamp: ''! moveDown self selected: self selected + 1. (self selected > self lastVisible and: [self selected <= self itemsCount]) ifTrue: [firstVisible := firstVisible + 1]. self changed! ! !NECMenuMorph methodsFor: 'drawing' stamp: 'EstebanLorenzano 2/1/2013 17:20'! drawModelMessageOn: aCanvas in: rectangle | message | self flag: #todo. "Removing for now... most of the shortcuts are broken and no time or need now to fix them" message := context model hasMessage ifTrue: [ context model message ", ' | ctrl-h=help'" ] ifFalse: [ self detailMessage ]. aCanvas drawString: message in: rectangle font: self class messageFont color: Color gray! ! !NECMenuMorph methodsFor: 'paging' stamp: ''! pageCount | count | self itemsCount == self pageHeight ifTrue: [^ 1]. count := self itemsCount // self pageHeight. (self itemsCount \\ self pageHeight) > 0 ifTrue:[count := count + 1]. ^count! ! !NECMenuMorph methodsFor: 'title' stamp: ''! removeTitle titleStringMorph ifNil: [^ self]. self removeMorph: titleStringMorph owner. titleStringMorph := nil! ! !NECMenuMorph methodsFor: 'initialization' stamp: 'MarcusDenker 10/5/2013 19:29'! setController: aECController position: aPoint controller := aECController. context := controller context. self position: aPoint - (20 @ 0). self narrowCompletion ifFalse: [ ^ self ]. self createTitle. self openInWorld! ! !NECMenuMorph methodsFor: 'private' stamp: ''! lastVisible ^ (self firstVisible + self height-1) min: (self itemsCount).! ! !NECMenuMorph methodsFor: 'drawing' stamp: 'EstebanLorenzano 2/1/2013 17:19'! detailMessage ^ String streamContents: [:stream | self flag: #todo. "Removing for now... most of the shortcuts are broken and no time or need now to fix them" "stream << 'ctrl-h=help'." NECPreferences captureNavigationKeys ifTrue: [ stream << (detailMorph ifNil: ['-> open detail'] ifNotNil: ['<- close detail'] ) ] ]! ! !NECMenuMorph methodsFor: 'private' stamp: 'CamilloBruni 8/7/2012 11:37'! updateDetail detailMorph ifNil: [^ self]. detailMorph entryDescription: (self selectedEntry descriptionWith: context); position: detailPosition menuWidth: self width; show! ! !NECMenuMorph methodsFor: 'paging' stamp: ''! pageCountString ^ self itemsCount = 501 ifTrue: [ 'more' ] ifFalse: [ self pageCount asString ]! ! !NECMenuMorph methodsFor: 'event handling' stamp: 'CamilloBruni 8/30/2012 14:36'! selectIndexAtPoint: aPoint | yPos | yPos := aPoint y - self bounds top. selected := firstVisible + (yPos / self class itemHeight) floor. selected := selected min: context model entries size max: 1.! ! !NECMenuMorph methodsFor: 'accessing' stamp: ''! selected "Answer the value of selected" selected ifNil: [ selected := self firstVisible ]. ^ selected! ! !NECMenuMorph methodsFor: 'accessing' stamp: ''! selectedEntry ^ context model entries at: self selected! ! !NECMenuMorph methodsFor: 'actions' stamp: 'CamilloBruni 8/7/2012 12:17'! switchToUntyped context switchToUntyped. self removeTitle; narrowCompletion! ! !NECMenuMorph methodsFor: 'event handling' stamp: 'EstebanLorenzano 2/1/2013 16:53'! mouseDown: evt (self bounds containsPoint: evt cursorPoint) ifTrue: [ evt wasHandled: true. ^ self selectIndexAtPoint: evt cursorPoint; insertSelected ]. super mouseDown: evt. evt wasHandled: false. self flag: #fixme "ugly hack". controller editor morph owner owner takeKeyboardFocus; handleMouseDown: evt. self close.! ! !NECMenuMorph methodsFor: 'actions' stamp: ''! expand context model toggleExpand. self narrowCompletion! ! !NECMenuMorph methodsFor: 'drawing' stamp: 'CamilloBruni 8/3/2012 20:32'! drawBottomScrollArrowOn: aCanvas | aPoligon point arrowHeight | point := self bounds bottomLeft translateBy: 6 @ -12. arrowHeight := self class scrollArrowSize. aPoligon := Array with: point with: (point translateBy: arrowHeight @ 0) with: (point translateBy: (arrowHeight / 2) @ arrowHeight). aCanvas drawPolygon: aPoligon fillStyle: Color black! ! !NECMenuMorph class methodsFor: 'help text' stamp: 'EstebanLorenzano 2/1/2013 17:15'! shortcut: aString text: secondString on: aTextStream aTextStream withAttributes: self shortcutAttributes do: [aTextStream nextPutAll: aString; cr]. aTextStream withAttributes: self explanationAttributes do: [aTextStream nextPutAll: secondString; cr]. ! ! !NECMenuMorph class methodsFor: 'preferences' stamp: ''! selectColorFor: aSymbol | attribute | attribute := self convertToSHSymbol: aSymbol. ^ (SHTextStylerST80 new attributesFor: attribute) first color! ! !NECMenuMorph class methodsFor: 'preferences-fonts' stamp: 'CamilloBruni 8/6/2012 00:33'! messageFont ^ StandardFonts menuFont! ! !NECMenuMorph class methodsFor: 'preferences' stamp: ''! maxLength ^ 20! ! !NECMenuMorph class methodsFor: 'instance creation' stamp: ''! controller: aECController position: aPoint | newObject | newObject := self new. newObject setController: aECController position: aPoint. ^ newObject! ! !NECMenuMorph class methodsFor: 'preferences' stamp: ''! convertToSHSymbol: aSymbol ^ (SHTextStylerST80 new attributesFor: aSymbol) notNil ifTrue: [ aSymbol ] ifFalse: [ #default ]! ! !NECMenuMorph class methodsFor: 'preferences' stamp: 'CamilloBruni 8/5/2012 23:13'! itemWidth ^ 250! ! !NECMenuMorph class methodsFor: 'preferences-fonts' stamp: 'CamilloBruni 8/6/2012 00:32'! selectFontFor: aSymbol | emphasized attributes | attributes := SHTextStylerST80 new attributesFor: (self convertToSHSymbol: aSymbol). emphasized := attributes size > 1 ifTrue: [ attributes second emphasisCode ] ifFalse: [ 0 ]. ^ StandardFonts codeFont emphasized: emphasized! ! !NECMenuMorph class methodsFor: 'preferences' stamp: ''! scrollArrowSize ^ 8! ! !NECMenuMorph class methodsFor: 'preferences' stamp: ''! itemHeight ^ (self selectFontFor: #default) height + 2! ! !NECMenuMorph class methodsFor: 'preferences-fonts' stamp: ''! titleFont ^ StandardFonts windowTitleFont! ! !NECMenuMorph class methodsFor: 'preferences-colors' stamp: 'CamilloBruni 8/3/2012 21:20'! backgroundColor ^NECPreferences backgroundColor! ! !NECMenuMorph class methodsFor: 'preferences-colors' stamp: 'EstebanLorenzano 5/14/2013 09:43'! scrollColor ^ Smalltalk ui theme settings selectionColor! ! !NECMenuMorph class methodsFor: 'help text' stamp: 'EstebanLorenzano 2/1/2013 17:15'! helpText | stream | stream := TextStream on: Text new. self section: 'character completion' on: stream. self shortcut: 'works on' text: ' [] {} () <> '''' ""' on: stream. self shortcut: 'usage 1' text: 'enter open character - closing character is entered as well' on: stream. self shortcut: 'usage 2' text: 'select some text, enter a smart character and the selected text get surrounded by the opening and closing character.' on: stream. self section: 'open/close menu' on: stream. self shortcut: 'ctrl-space or tab' text: 'open the completion menu' on: stream. self shortcut: 'ESC' text: 'close menu' on: stream. self shortcut: 'ctrl-h' text: 'open this help' on: stream. self section: 'menu navigation' on: stream. self shortcut: 'Arrows up/down' text: 'move the selection up and down' on: stream. self shortcut: 'Page up/down' text: 'page up and down' on: stream. self shortcut: 'Home/End' text: 'move to first or last page of the menu' on: stream. self section: 'show details and browse' on: stream. self shortcut: 'right arrow (detail closed)' text: 'show details about the selected item. This may be the type of the variable, the source of a method or the implementors of the selector.' on: stream. self shortcut: 'right arrow (detail open)' text: 'open a new browser for the selected item.' on: stream. self shortcut: 'left arrow' text: 'close the details' on: stream. self section: 'changing menu contents' on: stream. self shortcut: 'ctrl-u' text: 'switch to untyped mode in a typed menu' on: stream. self shortcut: 'ctrl-t' text: 'filter out methods of class Object in a typed menu. press again to make the reappear.' on: stream. self shortcut: 'alphanumeric character' text: 'filter the menu to the given input' on: stream. self shortcut: 'backspace' text: 'delete an input character, adjust menu to the new input.' on: stream. self section: 'inserting completion' on: stream. self shortcut: 'ctrl-space or tab' text: 'close the menu and insert selected completion. if there only one item left in the menu this done automaticly.' on: stream. ^ stream contents! ! !NECMenuMorph class methodsFor: 'help text' stamp: 'EstebanLorenzano 2/1/2013 17:15'! section: aString on: aTextStream aTextStream withAttributes: self sectionAttributes do: [aTextStream nextPutAll: aString]. aTextStream cr! ! !NECMenuMorph class methodsFor: 'help text' stamp: 'EstebanLorenzano 2/1/2013 17:15'! shortcutAttributes ^ {TextIndent spaceUsed; tabs: 1. TextEmphasis italic }! ! !NECMenuMorph class methodsFor: 'help text' stamp: 'EstebanLorenzano 2/1/2013 17:15'! explanationAttributes ^{TextIndent spaceUsed; tabs: 2}! ! !NECMenuMorph class methodsFor: 'help text' stamp: 'EstebanLorenzano 2/1/2013 17:15'! sectionAttributes ^ {TextEmphasis bold}! ! !NECMenuMorph class methodsFor: 'help text' stamp: 'EstebanLorenzano 2/1/2013 17:16'! helpTitle ^ 'Completion Keyboard Help'! ! !NECModel commentStamp: ''! I'm an abstract class that stores the entries to be completed.! !NECModel methodsFor: 'private' stamp: 'CamilloBruni 8/4/2012 00:47'! addToEntries: aCollection | temp caseSensitive | caseSensitive := NECPreferences caseSensitive. temp := aCollection select: [ :each | each contents occursInWithEmpty: narrowString caseSensitive: caseSensitive ]. entries addAll: temp! ! !NECModel methodsFor: 'accessing' stamp: ''! entries ^entries! ! !NECModel methodsFor: 'accessing' stamp: ''! hasMessage ^ self message notNil! ! !NECModel methodsFor: 'initialize-release' stamp: ''! toggleExpand ! ! !NECModel methodsFor: 'testing' stamp: ''! isEmpty ^ entries isEmpty! ! !NECModel methodsFor: 'private' stamp: ''! resetSelectors selectors := (SortedCollection new: 500) sortBlock: [ :a :b | | scoreA scoreB | scoreA := scoreB := 0. (a contents beginsWithEmpty: narrowString caseSensitive: NECPreferences caseSensitive) ifFalse: [ scoreA := 2 ]. (b contents beginsWithEmpty: narrowString caseSensitive: NECPreferences caseSensitive) ifFalse: [ scoreB := 2 ]. a contents < b contents ifTrue: [ scoreB := scoreB + 1 ] ifFalse: [ scoreA := scoreA + 1 ]. scoreA < scoreB ]! ! !NECModel methodsFor: 'accessing' stamp: ''! initializeSelectors self subclassResponsibility ! ! !NECModel methodsFor: 'accessing' stamp: ''! entryCount ^entries size! ! !NECModel methodsFor: 'private' stamp: ''! reset self resetSelectors. self resetEntries. narrowString := String new! ! !NECModel methodsFor: 'accessing' stamp: 'JohanBrichau 4/5/2013 22:08'! narrowString ^ narrowString! ! !NECModel methodsFor: 'action' stamp: ''! narrowWith: aString self subclassResponsibility ! ! !NECModel methodsFor: 'private' stamp: ''! resetEntries entries := OrderedCollection new! ! !NECModel methodsFor: 'testing' stamp: ''! notEmpty ^self isEmpty not! ! !NECModel methodsFor: 'initialize-release' stamp: ''! setClass: aClass clazz := aClass. self initializeSelectors. self narrowWith: String new! ! !NECModel methodsFor: 'initialization' stamp: ''! initialize self reset! ! !NECModel methodsFor: 'accessing' stamp: ''! at: aNumber ^ entries at: aNumber ! ! !NECModel methodsFor: 'action' stamp: ''! title ^nil! ! !NECModel methodsFor: 'accessing' stamp: 'SeanDeNigris 1/23/2013 15:06'! commonPrefix "Longest match among the typed text and all menu entries" | seed matchLengths prefixLength | seed := self entries first contents asString. matchLengths := entries allButFirst collect: [ :entry | seed charactersExactlyMatching: entry contents asString ] thenSelect: [ :e | e >= narrowString size ]. prefixLength := matchLengths isEmpty ifTrue: [ 0 ] ifFalse: [ matchLengths min ]. ^ seed first: prefixLength.! ! !NECModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 18:22'! message ^self isEmpty ifTrue: ['no completions found'] ifFalse: [nil]! ! !NECModel methodsFor: 'private' stamp: ''! narrowString: aString narrowString := aString! ! !NECModel methodsFor: 'action' stamp: 'EstebanLorenzano 2/1/2013 16:02'! completionAt: aNumber | entry | entry := (self at: aNumber) completion separateKeywords. ^ NECPreferences spaceAfterCompletion ifTrue: [ entry, ' ' ] ifFalse: [ entry ]. ! ! !NECModel methodsFor: 'accessing' stamp: ''! entriesOfType: aSymbol | collection | collection := entries select: [ :each | each type == aSymbol ]. ^ collection collect: [ :each | each contents ]! ! !NECModel methodsFor: 'action' stamp: ''! theClass ^nil! ! !NECModel class methodsFor: 'instance creation' stamp: ''! class: aClass | newInstance | newInstance := self basicNew initialize. newInstance setClass: aClass. ^ newInstance! ! !NECOverrideModel commentStamp: ''! I'm used when completing a method override. I contain all selectors of the superclass minus the already implemented selectors of the current class. When a completion occurs I complete a method template with a send to super.! !NECOverrideModel methodsFor: 'initialize-release' stamp: 'GabrielOmarCotelli 12/4/2013 08:32'! initializeSelectors clazz superclass ifNotNil: [ self initializeSelectorsFor: clazz superclass ]. clazz selectorsDo: [ :each | selectors detect: [ :ea | ea contentsAsSymbol == each ] ifFound: [ :entry | selectors remove: entry ifAbsent: [ ] ] ]! ! !NECOverrideModel methodsFor: 'action' stamp: ''! title ^ '(override) ' , clazz superclass name! ! !NECOverrideModel methodsFor: 'action' stamp: 'EstebanLorenzano 8/17/2012 16:40'! completionAt: aNumber | output source declaration | source := (self methodAt: aNumber) sourceCode. declaration := (source lineCorrespondingToIndex: 1) trimRight. output := WriteStream on: String new. output nextPutAll: declaration; cr; tab. (source includesSubstring: 'subclassResponsibility') ifFalse: [ (source includes: $^) ifTrue: [ output nextPutAll: '^ ' ]. output nextPutAll: 'super '; nextPutAll: declaration ]. ^ output contents! ! !NECOverrideModel methodsFor: 'private' stamp: ''! methodAt: aNumber ^ clazz lookupSelector: (self at: aNumber) contentsAsSymbol! ! !NECOverrideModelTest methodsFor: 'testing' stamp: ''! testCompletionAtWithReturn | completion | completion := model completionAt: 3. self assert: completion = 'toBeOverridenWithReturn ^ super toBeOverridenWithReturn'! ! !NECOverrideModelTest methodsFor: 'testing' stamp: ''! testTitle self assert: '(override) NECTestSuperClass' = model title! ! !NECOverrideModelTest methodsFor: 'testing' stamp: ''! testCompletionAt | completion | completion := model completionAt: 2. self assert: completion = 'toBeOverriden: anArgument super toBeOverriden: anArgument'! ! !NECOverrideModelTest methodsFor: 'testing' stamp: ''! testExpand | size | size := model entries size. self assert: size == model entries size! ! !NECOverrideModelTest methodsFor: 'testing' stamp: ''! setUp model := NECOverrideModel class: NECTestClass. model toggleExpand! ! !NECOverrideModelTest methodsFor: 'testing' stamp: ''! testOverride | selectors | self assert: model notEmpty. self assert: model entries size = 3. selectors := model entriesOfType: #selector. self assert: (selectors includes: #toBeOverriden:). self assert: (selectors includes: #initialize). self assert: (selectors includes: #toBeOverridenWithReturn)! ! !NECPreferences commentStamp: ''! I control the preferences for completion framework. It is the same for NECompletion and NOCompletion (and other potential completion algorithms should be configured here too) ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 8/26/2012 23:10'! captureNavigationKeys: aBoolean captureNavigationKeys := aBoolean! ! !NECPreferences class methodsFor: 'accessing' stamp: ''! enabled ^ enabled ! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 16:40'! popupAutomaticDelay ^popupAutomaticDelay ifNil: [ popupAutomaticDelay := self defaultPopupDelay ] ! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 1/15/2013 15:45'! smartCharactersWithSingleSpace ^ smartCharactersWithSingleSpace! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2012 23:56'! expandPrefixes: aBoolean expandPrefixes := aBoolean! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 1/15/2013 15:46'! smartCharactersWithSingleSpace: aString smartCharactersWithSingleSpace := aString! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 1/15/2013 15:46'! smartCharactersWithDoubleSpace: aString smartCharactersWithDoubleSpace := aString! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/14/2013 09:43'! backgroundColor ^backgroundColor ifNil: [ backgroundColor := (Smalltalk ui theme settings menuColor ifNil: [ Color white ]) ]! ! !NECPreferences class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/1/2013 16:37'! defaultSpaceAfterCompletion ^true! ! !NECPreferences class methodsFor: 'private' stamp: 'EstebanLorenzano 4/12/2012 13:10'! currentController ^ (Smalltalk tools hasToolNamed: #codeCompletion) ifTrue: [ Smalltalk tools codeCompletion ] ifFalse: [ nil ]! ! !NECPreferences class methodsFor: 'defaults' stamp: 'CamilloBruni 1/15/2013 15:45'! initialize enabled := caseSensitive := smartCharacters := false. expandPrefixes := false. captureNavigationKeys := false. useEnterToAccept := false. smartCharactersMapping := Dictionary new. smartCharactersMapping at: $( put: $); at: $[ put: $]; at: ${ put: $}; at: $" put: $"; at: $' put: $'. smartCharactersWithSingleSpace := ''. smartCharactersWithDoubleSpace := '[]'.! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 16:40'! popupShowAutomatic ^ popupShowAutomatic ifNil: [ popupShowAutomatic := self defaultPopupShowAutomatic ]! ! !NECPreferences class methodsFor: 'defaults' stamp: 'BenjaminVanRyseghem 2/9/2013 17:52'! defaultUseEnterToAccept ^ false! ! !NECPreferences class methodsFor: 'settings' stamp: 'EstebanLorenzano 5/14/2013 09:44'! settingsOn: aBuilder (aBuilder setting: #'Code Completion') target: self; parentName: #codeBrowsing; selector: #enabled; icon: Smalltalk ui icons smallConfigurationIcon; description: 'Enable or disable code completion in browsers, debuggers and workspaces.'; with: [ | availableControllers | availableControllers := self availableControllers. availableControllers size > 1 ifTrue: [ (aBuilder pickOne: #completionController) order: -1; label: 'Controller' translated; getSelector: #currentController; setSelector: #useController:; domainValues: availableControllers ]. (aBuilder setting: #backgroundColor) label: 'Background Color' translated. (aBuilder setting: #expandPrefixes) label: 'Complete common prefixes using TAB in the suggested completions' translated. (aBuilder setting: #useEnterToAccept) label: 'Use ENTER to accept a suggested completion' translated; default: self defaultUseEnterToAccept. (aBuilder setting: #captureNavigationKeys) label: 'Use navigation keys for extended completion functionality' translated. (aBuilder setting: #caseSensitive) label: 'Case Sensitive'; description: 'Decide if you want eCompletion to be case sensitive or not.'. (aBuilder setting: #smartCharacters) label: 'Smart Characters'; description: 'Decide if you want eCompletion to use smart characters, e.g, to automatically close brackets.'. (aBuilder setting: #smartCharactersWithSingleSpace) label: 'Smart Characters with Single Space'; description: 'Enumerate the characters which are automatically inserted with a single space in between.'. (aBuilder setting: #smartCharactersWithDoubleSpace) label: 'Smart Characters with Double Space'; description: 'Enumerate the characters which are automatically inserted with a two spaces in between.'. (aBuilder setting: #popupShowAutomatic) default: self defaultPopupShowAutomatic; label: 'Popup is automatic'. (aBuilder setting: #popupAutomaticDelay) default: self defaultPopupDelay; label: 'Popup appearance delay'. (aBuilder pickOne: #popupShowWithShortcut) default: self defaultPopupShortcut; label: 'Popup appears with this shortcut' translated; domainValues: self availablePopupShortcuts. (aBuilder setting: #spaceAfterCompletion) default: self defaultSpaceAfterCompletion; label: 'Put a space after completion' ].! ! !NECPreferences class methodsFor: 'private' stamp: 'EstebanLorenzano 4/12/2012 11:24'! useController: aClass aClass registerToolsOn: Smalltalk tools! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 13:36'! backgroundColor: aColor backgroundColor := aColor! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 13:11'! enabled: aBoolean enabled := aBoolean.! ! !NECPreferences class methodsFor: 'accessing' stamp: ''! caseSensitive: aBoolean caseSensitive := aBoolean! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 15:39'! popupShowWithShortcut: anObject popupShowWithShortcut := anObject! ! !NECPreferences class methodsFor: 'private' stamp: 'EstebanLorenzano 4/12/2012 13:04'! availableControllers ^NECController withAllSubclasses copyWithout: NECWorkspaceController! ! !NECPreferences class methodsFor: 'accessing' stamp: ''! smartCharacters ^ smartCharacters! ! !NECPreferences class methodsFor: 'accessing' stamp: 'GuillermoPolito 3/19/2013 19:12'! availablePopupShortcuts ^ { Character space shift. Character tab asKeyCombination}! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 15:39'! popupAutomaticDelay: anObject popupAutomaticDelay := anObject! ! !NECPreferences class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/1/2013 16:36'! defaultPopupShowAutomatic ^true! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 16:40'! popupShowWithShortcut ^ popupShowWithShortcut ifNil: [ popupShowWithShortcut := self defaultPopupShortcut ]! ! !NECPreferences class methodsFor: 'accessing' stamp: ''! smartCharactersMapping: aDictionary smartCharactersMapping := aDictionary! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2012 23:56'! expandPrefixes ^ expandPrefixes! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 15:54'! spaceAfterCompletion ^ spaceAfterCompletion ifNil: [ spaceAfterCompletion := true ]! ! !NECPreferences class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/1/2013 16:39'! defaultPopupDelay ^ 500! ! !NECPreferences class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/1/2013 17:22'! defaultPopupShortcut ^Character space shift! ! !NECPreferences class methodsFor: 'accessing' stamp: ''! smartCharacters: aBoolean smartCharacters := aBoolean! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 8/26/2012 23:28'! useEnterToAccept: aBoolean useEnterToAccept := aBoolean! ! !NECPreferences class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/9/2013 17:51'! useEnterToAccept ^ useEnterToAccept ifNil: [ useEnterToAccept := self defaultUseEnterToAccept ]! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 15:37'! popupShowAutomatic: aBoolean popupShowAutomatic := aBoolean! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 8/26/2012 23:10'! captureNavigationKeys ^ captureNavigationKeys! ! !NECPreferences class methodsFor: 'accessing' stamp: ''! caseSensitive ^ caseSensitive ! ! !NECPreferences class methodsFor: 'accessing' stamp: ''! smartCharactersMapping ^ smartCharactersMapping! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 1/15/2013 15:46'! smartCharactersWithDoubleSpace ^ smartCharactersWithDoubleSpace! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 15:39'! spaceAfterCompletion: anObject spaceAfterCompletion := anObject! ! !NECReadMe commentStamp: ''! NEC is based on the eCompletion package developed by Ruben Baker. We thank Ruben for having release this code in MIT. It was maintained by lukas renggli, damien Cassou and a couple of other cool developers. The current version (NEC) relies on some methods that re available in Pharo1.4. In addition the extensions made to shout has been moved to the Shout package. The goal of thise new version is to make sure that OCompletion can be just expressed as an extension of ECompletion and not a full copy of the ecompletion. This package relies on Shout.! !NECSelectorEntry commentStamp: ''! I represent a selector! !NECSelectorEntry methodsFor: 'private' stamp: ''! lookupSelector: aSymbol class: aClass "Look up the given selector in my methodDictionary. Return the corresponding method if found. Otherwise chase the superclass chain and try again. Return nil if no method is found." | lookupClass | lookupClass := aClass. [lookupClass isNil] whileFalse: [(lookupClass includesSelector: aSymbol) ifTrue: [^ Array with: lookupClass with: (lookupClass compiledMethodAt: aSymbol)]. lookupClass := lookupClass superclass]. ^ nil! ! !NECSelectorEntry methodsFor: 'accessing' stamp: 'CamilloBruni 8/6/2012 00:08'! label ^ (self guessTypeWith: nil) ifNil:[ 'method' ] ifNotNil: [ 'class' ].! ! !NECSelectorEntry methodsFor: 'detail information' stamp: 'CamilloBruni 8/6/2012 00:36'! createDescriptionWith: anECContext (self guessTypeWith: anECContext) ifNotNil: [ :clazz| ^ NECEntryDescription label: self label title: clazz printString description: clazz comment ]. ^ self findMethodWith: anECContext do: [:clazz :method | self methodSourceDescription: clazz method: method ] ifAbsent: [:selector | self implementorsDescription: selector]! ! !NECSelectorEntry methodsFor: 'private' stamp: 'CamilloBruni 8/27/2013 01:40'! findMethodWith: anECContext do: foundBlock ifAbsent: notfoundBlock | theClass result implementors | theClass := anECContext model theClass. result := theClass ifNil: [implementors := self systemNavigation allImplementorsOf: contents. implementors size == 1 ifTrue: [| ref | ref := implementors first. self lookupSelector: ref selector class: ref realClass] ifFalse: [^ notfoundBlock value: contents]] ifNotNil: [self lookupSelector: contents class: theClass]. ^ foundBlock value: result first value: result second! ! !NECSelectorEntry methodsFor: 'operations' stamp: 'CamilloBruni 8/6/2012 00:06'! guessTypeWith: anECContext | globalEntry | globalEntry := Smalltalk at: contents ifAbsent: [^ nil]. globalEntry isBehavior ifTrue: [^ globalEntry]. globalEntry ifNotNil: [^ globalEntry class]. ^ nil! ! !NECSelectorEntry methodsFor: 'private' stamp: 'CamilloBruni 8/6/2012 00:41'! methodSourceDescription: aClass method: aCompiledMethod | styler styledText | styler := SHTextStylerST80 new. styler classOrMetaClass: aClass. styledText := styler styledTextFor: (aCompiledMethod sourceCode) asText. ^ NECEntryDescription label: self label title: aClass printString description: styledText! ! !NECSelectorEntry methodsFor: 'private' stamp: 'CamilloBruni 8/6/2012 00:25'! browseWith: anECContext (self guessTypeWith: anECContext) ifNotNil: [ :clazz| SystemNavigation new browseClass: clazz. ^ true ]. ^ self findMethodWith: anECContext do: [ :class :method | Smalltalk tools browser fullOnClass: class selector: method selector. true ] ifAbsent: [ :selector | SystemNavigation new browseAllImplementorsOf: selector. true ]! ! !NECSelectorEntry methodsFor: 'private' stamp: 'CamilloBruni 8/6/2012 00:35'! implementorsDescription: aSymbol | implementors output | output := WriteStream on: String new. implementors := self systemNavigation allImplementorsOf: aSymbol. implementors isEmpty ifTrue: [ ^ NECEntryDescription label: 'symbol' title: '(no implementors)' description: 'This is just symbol.' ]. implementors do: [ :each | output nextPutAll: each classSymbol printString; cr ]. ^ NECEntryDescription label: self label title: '(Implementors)' description: output contents! ! !NECSelfEntry commentStamp: ''! I represent self! !NECSelfEntry methodsFor: 'accessing' stamp: ''! label ^ 'self'! ! !NECSelfEntry methodsFor: 'operations' stamp: ''! guessTypeWith: anECContext ^ anECContext theClass! ! !NECStringSortingTest methodsFor: 'tests' stamp: ''! testCompareWithCase self assert: ('at:' compare: 'atOne' caseSensitive: true) == 3! ! !NECStringSortingTest methodsFor: 'tests' stamp: ''! testCompare self assert: ('at:' compare: 'atOne' caseSensitive: false) == 1! ! !NECStringSortingTest methodsFor: 'tests' stamp: ''! testCaseSensitiveMap | map colon o | map := String classPool at: #CaseSensitiveOrder. colon := map at: $: asciiValue + 1. o := map at: $O asciiValue + 1. self assert: colon > o! ! !NECSuperEntry commentStamp: ''! I represent super.! !NECSuperEntry methodsFor: 'accessing' stamp: ''! label ^ 'super'! ! !NECSuperEntry methodsFor: 'operations' stamp: ''! guessTypeWith: anECContext ^ anECContext theClass ifNotNil: [anECContext theClass superclass]! ! !NECSymbols commentStamp: ''! I retrieve the symbols for the ecompletion algorithm. TODO remove stupid symbols (like packages and timestamps) I also do not know why I live here (in Pharo package)... I should have my place in Model :)! !NECSymbols class methodsFor: 'query' stamp: 'EstebanLorenzano 2/1/2013 18:44'! contains: aString caseSensitive: aBoolean do: aBlock | blockToPerform | blockToPerform := [ :each | ((each includes: $ ) not and: [ each includesSubstring: aString caseSensitive: aBoolean ]) ifTrue: [ aBlock value: each ] ]. cachedSymbols ifNotNil:[ self cachedInterestingSymbolsDo: blockToPerform ] ifNil: [ self cacheInterestingSymbolsAndDo: blockToPerform ] ! ! !NECSymbols class methodsFor: 'private' stamp: 'CamilloBruni 2/3/2013 18:27'! cacheInterestingSymbolsAndDo: aBlock "For time issue, we collect and perform the block in only one iteration" | cache | cache := OrderedCollection new: 5000. self interestingSymbolsDo: [:symbol | cache add: symbol. aBlock value: symbol ]. " only assign the cache in the end, aBlock might do a non-local return!!" cachedSymbols := cache.! ! !NECSymbols class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 18:31'! cachedSymbols ^cachedSymbols! ! !NECSymbols class methodsFor: 'private' stamp: 'EstebanLorenzano 2/1/2013 18:37'! cachedInterestingSymbolsDo: aBlock self cachedSymbols do: aBlock! ! !NECSymbols class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 18:31'! resetCachedSymbols cachedSymbols := nil! ! !NECSymbols class methodsFor: 'private' stamp: 'EstebanLorenzano 2/1/2013 18:16'! interestingSymbolsDo: aBlock Symbol allSymbolTablesDo:[:symbol | symbol isEmpty ifFalse: [ (symbol first isUppercase and:[ Smalltalk globals includesKey: symbol ]) ifTrue:[ aBlock value: symbol ] ifFalse: [ symbol first isLetter ifTrue: [ aBlock value: symbol ]]]].! ! !NECSymbols class methodsFor: 'query' stamp: ''! startsWith: aChar caseSensitive: aBoolean do: aBlock | char caseInSensitive firstChar | caseInSensitive := aBoolean not. firstChar := caseInSensitive ifTrue: [ aChar asLowercase ] ifFalse: [ aChar ]. Symbol allSymbolTablesDo: [ :each | | size | size := each size. char := size > 0 ifTrue: [ each first ]. (char notNil and: [ (char == firstChar or: [ caseInSensitive and: [ char asLowercase == firstChar ] ]) and: [ (each findAnySubStr: '- ' startingAt: 2) > size ] ]) ifTrue: [ aBlock value: each ] ]! ! !NECTestClass commentStamp: ''! I'm only for SUnit TestCases.! !NECTestClass methodsFor: 'utils' stamp: ''! lowPriorityOverrides: aRectangle messageSend := aRectangle. typeSuggestingParameter2 := aRectangle. ! ! !NECTestClass methodsFor: 'tests' stamp: ''! testIt: anArgument | loc1 x2 t | x2 := [:bar :var | var < bar]. loc1 := constantArray. x2 value: loc1. t := 15. ^ x2! ! !NECTestClass methodsFor: 'initialization' stamp: 'NicolaiHess 2/19/2014 15:37'! initialize: aRectangle constantInteger := 15. constantLargeInteger := 1073741824. constantString := 'Ruben'. constantSymbol := #Symbol. constantArray := #(15 16 17 28 ). constantBoolean := true. typeSuggestingParameter := aRectangle. messageSend := Dictionary new. messageSend2 := aRectangle origin. globalVarKeyword := SortedCollection sortBlock: [:a :b | a <= b]. globalVarKeyword2 := SortedCollection new: 15. constantNil := nil. typeSuggestingParameter2 := nil. complexInit := 15 > 16 ifTrue: [#Symbol] ifFalse: ['String']. complexInit2 := Dictionary new: aRectangle origin x. ! ! !NECTestClass class methodsFor: 'as yet unclassified' stamp: ''! initialize super initialize. ClassVar := 'Any string'! ! !NECTestSuperClass commentStamp: ''! I'm only for SUnit TestCases.! !NECTestSuperClass methodsFor: 'utils' stamp: ''! toBeOverriden: anArgument 15 > 16 ifTrue: [self sample * anArgument ]! ! !NECTestSuperClass methodsFor: 'initialization' stamp: ''! initialize superInstVar := Dictionary new! ! !NECTestSuperClass methodsFor: 'utils' stamp: ''! toBeOverridenWithReturn ^ 'saga'! ! !NECTestSuperClass methodsFor: 'tests' stamp: ''! testIt: aString self subclassResponsibility ! ! !NECTestSuperClass class methodsFor: 'as yet unclassified' stamp: ''! initialize SuperClassVar := Dictionary new! ! !NECTypeInfo commentStamp: ''! I'm used in ECInstVarTypeGuesser to store found type informations.! !NECTypeInfo methodsFor: 'accessing' stamp: ''! temporaryOffset: anInteger temporaryOffset := anInteger! ! !NECTypeInfo methodsFor: 'testing' stamp: ''! isDefinedByMessageSend ^kind == 2! ! !NECTypeInfo methodsFor: 'testing' stamp: ''! isDefinedByTemporary ^ kind == 3! ! !NECTypeInfo methodsFor: 'accessing' stamp: ''! setType: aClass kind: anInteger type := aClass. kind := anInteger! ! !NECTypeInfo methodsFor: 'accessing' stamp: ''! priority ^kind! ! !NECTypeInfo methodsFor: 'accessing' stamp: ''! type ^type! ! !NECTypeInfo methodsFor: 'accessing' stamp: ''! type: aClass type := aClass! ! !NECTypeInfo methodsFor: 'accessing' stamp: ''! temporaryOffset ^temporaryOffset! ! !NECTypeInfo class methodsFor: 'instance creation' stamp: ''! definedByTemporaryVar: anInteger | newInstance | newInstance := self new. newInstance setType: nil kind: 3. newInstance temporaryOffset: anInteger. ^ newInstance! ! !NECTypeInfo class methodsFor: 'instance creation' stamp: ''! definedByMessageSend: aClass | newInstance | newInstance := self new. newInstance setType: aClass kind: 2. ^ newInstance! ! !NECTypeInfo class methodsFor: 'instance creation' stamp: ''! definedByLiteral: aClass | newInstance | newInstance := self new. newInstance setType: aClass kind: 1. ^ newInstance! ! !NECTypedModel commentStamp: ''! I'm the model for a typed completion, that means when a receiver class is known. I only have selectors. I have an expand toggle: When false I filter out Object and ProtoObject selectors. The default value is true.! !NECTypedModel methodsFor: 'initialization' stamp: ''! initialize super initialize. expanded := true! ! !NECTypedModel methodsFor: 'action' stamp: ''! toggleExpand expanded := expanded not. self initializeSelectors. self narrowWith: narrowString! ! !NECTypedModel methodsFor: 'action' stamp: ''! title ^clazz name! ! !NECTypedModel methodsFor: 'private' stamp: ''! initializeSelectorsFor: aClass |excludedClasses| selectors reset. excludedClasses := (expanded ifTrue: [#()] ifFalse: [Object withAllSuperclasses]). selectors addAll: ((aClass allSelectorsWithout: excludedClasses) collect: [:each | NECSelectorEntry contents: each type: #selector])! ! !NECTypedModel methodsFor: 'private' stamp: ''! initializeSelectors self initializeSelectorsFor: clazz! ! !NECTypedModel methodsFor: 'action' stamp: ''! narrowWith: aString self narrowString: aString ; initializeSelectors. entries reset. self addToEntries: selectors! ! !NECTypedModel methodsFor: 'action' stamp: ''! theClass ^clazz! ! !NECTypedModelTest methodsFor: 'tests' stamp: ''! testTitle | model | model := NECTypedModel class: NECTestClass. self assert: #NECTestClass = model title! ! !NECTypedModelTest methodsFor: 'tests' stamp: ''! testExpand | model selectors | model := NECTypedModel class: NECTestClass. self assert: (model entriesOfType: #locals) isEmpty. self assert: (model entriesOfType: #instance) isEmpty. model toggleExpand. selectors := model entriesOfType: #selector. self assert: selectors size == 6. self assert: (selectors includes: #initialize). self assert: (selectors includes: #lowPriorityOverrides:). self assert: (selectors includes: #testIt:). model toggleExpand. selectors := model entriesOfType: #selector. self assert: selectors size > 100. self assert: (selectors includes: #instVarAt:). self assert: (selectors includes: #initialize). self assert: (selectors includes: #lowPriorityOverrides:). self assert: (selectors includes: #testIt:). self assert: (selectors includes: #instVarAt:). model toggleExpand. selectors := model entriesOfType: #selector. self assert: selectors size == 6! ! !NECTypedModelTest methodsFor: 'tests' stamp: ''! testTyped | model selectors | model := NECTypedModel class: NECTestClass. self assert: (model entriesOfType: #locals) size == 0. self assert: (model entriesOfType: #instance) size == 0. selectors := model entriesOfType: #selector. self assert: selectors size > 0. self assert: (selectors includes: #initialize). self assert: (selectors includes: #lowPriorityOverrides:). self assert: (selectors includes: #testIt:). model narrowWith: 'low'. selectors := model entriesOfType: #selector. self deny: (selectors includes: #initialize). self assert: (selectors includes: #lowPriorityOverrides:). self deny: (selectors includes: #testIt:)! ! !NECTypedModelTest methodsFor: 'tests' stamp: ''! testMessage | model | model := NECTypedModel class: NECTestClass. self shouldnt: model hasMessage. model narrowWith: 'hagadagadu'. self assert: model hasMessage. self assert: model message = 'no completions found'! ! !NECUnseparatedModel commentStamp: ''! kind of variant but no idea why - sd! !NECUnseparatedModel methodsFor: 'action' stamp: ''! completionAt: aNumber ^ (self at: aNumber) completion! ! !NECUntypedModel commentStamp: ''! When no receiver class is known, I'm the right model. I store all temporary variables, instance variables of the selected class and all selectors in system. For performance reasons I only collect selectors when at least one character is known.! !NECUntypedModel methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2013 21:39'! listLimit: aNumber listLimit := aNumber! ! !NECUntypedModel methodsFor: 'initialize-release' stamp: 'CamilloBruni 8/7/2012 12:35'! setClass: aClass temporaries: aCollection additionals: additionalCollection variables: variablesBoolean selectors: selectorsBoolean includeVariables := variablesBoolean. includeSelectors := selectorsBoolean. clazz := aClass. self initializeInstVars. self initializeClassVars. includeVariables ifTrue: [ localVars := aCollection. self addAdditionals: additionalCollection ] ifFalse: [ localVars := OrderedCollection new ]. self resetEntries.! ! !NECUntypedModel methodsFor: 'private' stamp: 'IgorStasenko 9/16/2013 17:28'! initializeSelectors self resetSelectors. includeSelectors ifFalse: [ Smalltalk keysAndValuesDo: [ :each :class | selectors add: (NECGlobalEntry contents: each) ]. ^ self ]. narrowString ifEmpty: [ ^ self ]. NECSymbols contains: narrowString caseSensitive: NECPreferences caseSensitive do: [ :each | (includeVariables or: [ each first isLowercase ]) ifTrue: [ selectors add: (NECSelectorEntry contents: each type: #selector). selectors size > self listLimit ifTrue: [ ^ self ]]]! ! !NECUntypedModel methodsFor: 'private' stamp: ''! addSelectors self initializeSelectors. self addToEntries: selectors! ! !NECUntypedModel methodsFor: 'action' stamp: ''! narrowWith: aString self narrowString: aString. self resetEntries. self addVariables. self addSelectors! ! !NECUntypedModel methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2013 21:39'! listLimit ^ listLimit! ! !NECUntypedModel methodsFor: 'initialization' stamp: 'CamilloBruni 2/3/2013 21:39'! initialize super initialize. localVars := SortedCollection new. instVars := SortedCollection new. classVars := SortedCollection new. includeSelectors := true. includeVariables := true. listLimit := 100.! ! !NECUntypedModel methodsFor: 'initialize-release' stamp: 'IgorStasenko 9/16/2013 17:28'! initializeClassVars (clazz isNil or: [ includeVariables not ]) ifTrue: [ ^ self ]. classVars := clazz theNonMetaClass allClassVarNames asSortedCollection. classVars := classVars collect: [ :each | NECClassVarEntry contents: each ]! ! !NECUntypedModel methodsFor: 'private' stamp: ''! addVariables includeVariables ifFalse: [^ self]. self addToEntries: localVars. self addToEntries: instVars. self addToEntries: classVars! ! !NECUntypedModel methodsFor: 'private' stamp: ''! addAdditionals: aCollection aCollection ifNotNil: [aCollection do: [:each | each isLocal ifTrue: [localVars add: each value] ifFalse: [each isInstance ifTrue: [instVars add: each value] ifFalse: [each isSelector ifTrue: [selectors add: each value]]]]]! ! !NECUntypedModel methodsFor: 'accessing' stamp: ''! message ^ (includeSelectors and: [ narrowString isEmpty ]) ifTrue: [ selectors size = 500 ifTrue: [ 'more...' ] ifFalse: [ 'press key for selectors' ] ] ifFalse: [ super message ]! ! !NECUntypedModel methodsFor: 'initialize-release' stamp: ''! narrowString: aString (narrowString isEmpty or: [aString isEmpty or: [aString first ~= narrowString first]]) ifTrue: [self reset]. super narrowString: aString! ! !NECUntypedModel methodsFor: 'initialize-release' stamp: 'IgorStasenko 9/16/2013 17:29'! initializeInstVars (clazz isNil or: [ includeVariables not ]) ifTrue: [ ^ self ]. instVars := clazz allInstVarNames asSortedCollection. instVars := instVars collect: [ :each | NECInstVarEntry contents: each ]. instVars add: (NECSelfEntry contents: 'self' type: #self). instVars add: (NECSuperEntry contents: 'super' type: #super)! ! !NECUntypedModel methodsFor: 'private' stamp: 'CamilloBruni 8/21/2012 16:29'! loadEntries self addVariables; addSelectors! ! !NECUntypedModel class methodsFor: 'instance creation' stamp: ''! class: aClass temporaries: aCollection ^self class: aClass temporaries: aCollection additionals: #() variables: true selectors: true! ! !NECUntypedModel class methodsFor: 'instance creation' stamp: ''! class: aClass temporaries: aCollection additionals: additionalCollection variables: variablesBoolean selectors: selectorsBoolean | newInstance | newInstance := self basicNew initialize. newInstance setClass: aClass temporaries: aCollection additionals: additionalCollection variables: variablesBoolean selectors: selectorsBoolean. ^ newInstance! ! !NECUntypedModelTest methodsFor: 'tests' stamp: 'CamilloBruni 8/21/2012 16:29'! testAdditionalLocals | model locals | model := NECUntypedModel class: NECTestClass temporaries: (OrderedCollection with: (NECLocalEntry contents: 'a' type: #local) with: (NECLocalEntry contents: 'b' type: #local)) additionals: (Array with: (NECLocalEntry contents: 'veryImp' type: #local)) variables: true selectors: true. model loadEntries. locals := model entriesOfType: #local. self assert: (locals includes: 'veryImp')! ! !NECUntypedModelTest methodsFor: 'tests' stamp: 'CamilloBruni 8/21/2012 16:29'! testForClassLocals | model locals temps | temps := #('loc1' 'x2' 'bar' 'var' ) collect: [ :each | NECLocalEntry contents: each type: #local ]. model := NECUntypedModel class: NECTestClass temporaries: temps. model loadEntries. locals := model entriesOfType: #local. self assert: locals size == 4. self assert: (locals includes: 'loc1'). self assert: (locals includes: 'x2'). self assert: (locals includes: 'bar'). self assert: (locals includes: 'var'). model narrowWith: 'l'. locals := model entriesOfType: #local. self assert: locals size == 1. self assert: (locals includes: 'loc1')! ! !NECUntypedModelTest methodsFor: 'tests' stamp: ''! tearDown NECPreferences caseSensitive: prefValueCase! ! !NECUntypedModelTest methodsFor: 'tests' stamp: 'CamilloBruni 2/3/2013 21:40'! testCaseSensitivity | model instances | self assert: NECPreferences caseSensitive. model := NECUntypedModel class: NECTestClass temporaries: OrderedCollection new. model listLimit: Float infinity. model narrowWith: 'typesugg'. self assert: model isEmpty. NECPreferences caseSensitive: false. model narrowWith: 'typesugg'. instances := model entriesOfType: #instVar. self assert: instances size == 2. self assert: (instances includes: 'typeSuggestingParameter'). model narrowWith: 'dict'. self assert: model notEmpty. self assert: ((model entriesOfType: #selector) includes: 'Dictionary')! ! !NECUntypedModelTest methodsFor: 'tests' stamp: ''! testNoEntriesWithSpace | model separatorEntry | model := NECUntypedModel new. self assert: model isEmpty. model narrowWith: 'b'. separatorEntry := model entries detect: [:each | (each value asString detect: [:char | char isSeparator] ifNone: []) notNil] ifNone: []. self assert: separatorEntry isNil! ! !NECUntypedModelTest methodsFor: 'tests' stamp: 'NicolaiHess 2/19/2014 15:38'! testCaseSensitive | model locals | self assert: NECPreferences caseSensitive. model := NECUntypedModel class: NECTestClass temporaries: OrderedCollection new. model loadEntries. locals := model entriesOfType: #instVar. self assert: locals size == 18. self assert: (locals includes: 'third'). self assert: (locals includes: 'constantInteger'). self assert: (locals includes: 'complexInit2'). self assert: (locals includes: 'typeSuggestingParameter'). model narrowWith: 'fo'! ! !NECUntypedModelTest methodsFor: 'tests' stamp: ''! setUp prefValueCase := NECPreferences caseSensitive. NECPreferences caseSensitive: true! ! !NECUntypedModelTest methodsFor: 'tests' stamp: ''! testEmpty | model | model := NECUntypedModel new. self assert: model isEmpty. self assert: model entries isEmpty. self assert: model entryCount == 0! ! !NECUntypedModelTest methodsFor: 'tests' stamp: ''! testTitle | model | model := NECUntypedModel class: NECTestClass temporaries: #(). self assert: model title isNil! ! !NECUntypedModelTest methodsFor: 'tests' stamp: 'CamilloBruni 8/21/2012 16:29'! testMessage | model | model := NECUntypedModel class: NECTestClass temporaries: #('a' 'b' ). model loadEntries. self assert: model notEmpty. self assert: model hasMessage. self assert: model message = 'press key for selectors'. model narrowWith: 'b'. self shouldnt: model hasMessage. model narrowWith: ''. self assert: model hasMessage. self assert: model message = 'press key for selectors'. model narrowWith: 'hagadagadu'. self assert: model hasMessage. self assert: model message = 'no completions found'. model := NECUntypedModel new. self assert: model hasMessage. self assert: model message = 'press key for selectors'! ! !NECUntypedModelTest methodsFor: 'tests' stamp: 'CamilloBruni 2/3/2013 21:39'! testNarrowWith | count model | model := NECUntypedModel new. model listLimit: Float infinity. self assert: model isEmpty. model narrowWith: 'b'. count := model entryCount. self assert: count == model entries size. self assert: model isEmpty not. model narrowWith: 'bar'. self assert: count > model entryCount. model narrowWith: 'barXXXX'. self assert: model isEmpty. model narrowWith: 'b'. self assert: count == model entryCount. model narrowWith: 'save'. self assert: model isEmpty not. model narrowWith: ''. self assert: model isEmpty! ! !NECUntypedModelTest methodsFor: 'tests' stamp: 'NicolaiHess 2/19/2014 15:38'! testForClassInstVars | model locals | model := NECUntypedModel class: NECTestClass temporaries: OrderedCollection new. model loadEntries. locals := model entriesOfType: #instVar. self assert: locals size == 18. self assert: (locals includes: 'third'). self assert: (locals includes: 'constantInteger'). self assert: (locals includes: 'complexInit2'). self assert: (locals includes: 'typeSuggestingParameter'). locals := model entriesOfType: #self. self assert: (locals includes: 'self'). locals := model entriesOfType: #super. self assert: (locals includes: 'super'). model narrowWith: 'fo'. locals := model entriesOfType: #instVar. self assert: locals size == 1. self assert: (locals includes: 'fourth')! ! !NECUntypedModelTest methodsFor: 'tests' stamp: 'CamilloBruni 8/21/2012 16:30'! testForClassVars | model classVars | model := NECUntypedModel class: NECTestClass temporaries: OrderedCollection new. model loadEntries. classVars := model entriesOfType: #classVar. self assert: classVars size >= 2. self assert: (classVars includes: 'SuperClassVar'). self assert: (classVars includes: 'ClassVar')! ! !NECVarTypeGuesser commentStamp: ''! I'm an InstructionClient that tries to guess the type of a given instance variable name of a class. ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! pushTemporaryVariable: offset "Push Contents Of Temporary Variable Whose Index Is the argument, offset, On Top Of Stack bytecode." | info | contextCount > 0 ifTrue:[^self]. info := NECTypeInfo definedByTemporaryVar: offset. types add: info! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! pushConstant: value "Push Constant, value, on Top Of Stack bytecode." | info | contextCount > 0 ifTrue: [ ^ self ]. value ifNotNil: [ info := NECTypeInfo definedByLiteral: value class. types add: info ]! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! blockReturnTop contextCount := contextCount - 1! ! !NECVarTypeGuesser methodsFor: 'public' stamp: ''! methodRefs ^ #()! ! !NECVarTypeGuesser methodsFor: 'public' stamp: ''! perform | infos infosOfMethod methodRefs | variableName isEmpty ifTrue: [^ nil]. methodRefs := self methodRefs. methodRefs ifNil: [^ nil]. methodRefs isBehavior ifTrue: [^ methodRefs]. contextCount := 0. infos := SortedCollection sortBlock: [:a :b | a priority <= b priority]. methodRefs do: [:each | self prepare: each. infosOfMethod := self typeOfVarIn: each compiledMethod. infos addAll: infosOfMethod]. infos notEmpty ifTrue: [^ infos first type]. ^ nil! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: 'MarcusDenker 10/5/2013 19:25'! computeVarType | info tempNames name | types ifEmpty: [ ^ nil ]. info := types first. (hasSend and: [ info isDefinedByMessageSend not ]) ifTrue: [ info type: nil. ^ info ]. info isDefinedByTemporary ifFalse: [ ^ info ]. tempNames := (receiverClass compiler parse: currentMethod sourceCode) tempNames. name := tempNames at: info temporaryOffset + 1. info type: (self class getClassFromTypeSuggestingName: name). ^ info! ! !NECVarTypeGuesser methodsFor: 'private' stamp: ''! reset contextCount > 0 ifTrue:[^self]. types reset. hasSend := false.! ! !NECVarTypeGuesser methodsFor: 'instance creation' stamp: ''! setVariableName: aString source: aSourceString class: aClass variableName := aString. receiverClass := aClass! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! popIntoLiteralVariable: anAssociation "Remove Top Of Stack And Store Into Literal Variable bytecode." self reset! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! pushActiveContext "Push Active Context On Top Of Its Own Stack bytecode." contextCount := contextCount + 1! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! interpretNextInstructionUsing: aScanner found := false. aScanner interpretNextInstructionFor: self. ^found ! ! !NECVarTypeGuesser methodsFor: 'initialization' stamp: ''! initialize super initialize. types := OrderedCollection new. hasSend := false. contextCount := 0! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! send: selector super: supered numArgs: numberArguments "Send Message With Selector, selector, bytecode. The argument, supered, indicates whether the receiver of the message is specified with 'super' in the source method. The arguments of the message are found in the top numArguments locations on the stack and the receiver just below them." contextCount > 0 ifTrue:[^self]. hasSend := true! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! typeOfVarIn: aMethod "Answer whether the receiver references an instance variable." | scanner end type infos | scanner := InstructionStream on: aMethod. end := scanner method endPC. currentMethod := aMethod. infos := OrderedCollection new. [ scanner pc <= end ] whileTrue: [ (self interpretNextInstructionUsing: scanner) ifTrue: [ type := self computeVarType. type ifNotNil: [ infos add: type ] ] ]. ^ infos! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! pushLiteralVariable: anAssociation "Push Contents Of anAssociation On Top Of Stack bytecode." | info | contextCount > 0 ifTrue:[^self]. info := NECTypeInfo definedByMessageSend: anAssociation value. types add: info! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! prepare: aCompiledMethod ! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: ''! popIntoTemporaryVariable: offset "Remove Top Of Stack And Store Into Temporary Variable bytecode." self reset ! ! !NECVarTypeGuesser class methodsFor: 'instance creation' stamp: ''! variableName: aString class: aClass ^self variableName: aString source: nil class: aClass ! ! !NECVarTypeGuesser class methodsFor: 'instance creation' stamp: ''! variableName: aString source: sourceString class: aClass | newInstance | newInstance := self basicNew initialize. newInstance setVariableName: aString source: sourceString class: aClass. ^ newInstance! ! !NECVarTypeGuesser class methodsFor: 'private' stamp: ''! getClassFromTypeSuggestingName: aString | firstUppercaseLetter className aStream aClass | aStream := WriteStream on: String new. aStream nextPut: aString first asUppercase. aStream nextPutAll: (aString copyFrom: 2 to: aString size). className := aStream contents. aClass := Smalltalk at: className asSymbol ifAbsent: []. (aClass isKindOf: Class) ifTrue: [^ aClass]. firstUppercaseLetter := aString indexOfFirstUppercaseCharacter. className := firstUppercaseLetter > 1 ifTrue: [aString copyFrom: firstUppercaseLetter to: aString size] ifFalse: [^ nil]. aClass := Smalltalk at: className asSymbol ifAbsent: []. (aClass isKindOf: Class) ifTrue: [^ aClass]. ^ nil! ! !NECWorkspaceController commentStamp: ''! I'm a specialized controller, that works with Workspaces.! !NECWorkspaceController methodsFor: 'accessing' stamp: ''! workspace ^model! ! !NECWorkspaceController methodsFor: 'accessing' stamp: ''! additionals ^ self workspace completionAdditionals! ! !NNavDirection commentStamp: ''! I'm the one who knows generalization to navigate an ast tree I have two concret classes: NavigateInto and NavigateOver! !NNavDirection class methodsFor: 'stand out' stamp: 'GiselaDecuzzi 5/14/2013 16:31'! findSelectionFor: navigationContext self subclassResponsibility .! ! !NNavDirection class methodsFor: 'private' stamp: 'GiselaDecuzzi 5/13/2013 16:50'! calculateBestSeletionFor: node beforeSelection: selectionInText step: blockForStep | selectionInNode | node ifNil:[ ^selectionInText ]. selectionInNode := node start to: node stop. ^ (selectionInText = selectionInNode ) ifTrue: [blockForStep value: selectionInText value: node ] ifFalse: [selectionInNode ].! ! !NNavDirectionChild commentStamp: ''! I'm the one who knowshow to navigate inside the child nodes! !NNavDirectionChild class methodsFor: 'private' stamp: 'GiselaDecuzzi 5/7/2013 17:23'! childNodeFor: node "We find the child for a node, if it has not childs nil, if has more than one let the user select the one he wants." node ifNil:[^nil]. ^ node children isEmpty ifTrue: [ nil ] ifFalse: [ node children size = 1 ifTrue: [node children at: 1] ifFalse: [ self askForNodeSelectionFrom: node children] ]! ! !NNavDirectionChild class methodsFor: 'step into' stamp: 'GiselaDecuzzi 5/14/2013 14:18'! selectionChildrenScope: selected for: node | children | node ifNil: [ ^selected ]. children := self childNodeFor: node. ^children ifNil: [ selected ] ifNotNil: [children start to: children stop]! ! !NNavDirectionChild class methodsFor: 'builder' stamp: 'GiselaDecuzzi 5/14/2013 14:42'! buildShortcut: aBuilder (aBuilder shortcut: #selectChild) category: #SmalltalkEditor default: $o command mac | $o ctrl unix | $o ctrl do: [ :morph | morph standOutIntoScope ] description: 'Select the node choosing the child'! ! !NNavDirectionChild class methodsFor: 'private' stamp: 'GiselaDecuzzi 5/13/2013 15:20'! askForNodeSelectionFrom: nodes ^ UIManager default enterOrRequestFrom: (nodes collect: [:node | (node respondsTo: #selector )ifTrue:[node selector] ifFalse:[node name]]) values: nodes lines: #() title: 'Which code do you want to select?' translated! ! !NNavDirectionChild class methodsFor: 'stand out' stamp: 'GiselaDecuzzi 5/14/2013 16:26'! findSelectionFor: navigationContext ^ self calculateBestSeletionFor: (self childNodeFor: navigationContext bestNodeForSelection) beforeSelection: navigationContext textSelection step: [ :selection :target | self selectionChildrenScope: selection for: target ]! ! !NNavDirectionFirstChild commentStamp: ''! I navigate throw the childs picking allways the firs one! !NNavDirectionFirstChild class methodsFor: 'builder' stamp: 'GiselaDecuzzi 6/18/2013 11:29'! buildShortcut: aBuilder (aBuilder shortcut: #firstChild) category: #SmalltalkEditor default: self defaultKeyCombination do: [ :morph | morph standOutIntoFirstScope] description: 'Select the node scope reducing to the first child' ! ! !NNavDirectionFirstChild class methodsFor: 'builder' stamp: 'GiselaDecuzzi 6/19/2013 12:42'! defaultKeyCombination ^NNavNavigation useArrowsShortcuts ifTrue: [ Character arrowRight command shift mac | Character arrowRight ctrl shift ] ifFalse: [ $o command shift mac| $o ctrl shift unix | $o ctrl shift ] ! ! !NNavDirectionFirstChild class methodsFor: 'private' stamp: 'GiselaDecuzzi 5/14/2013 16:33'! childNodeFor: node "We find the child for a node, if it has not childs nil, if has more than one return the first one." node ifNil:[^nil]. ^ node children isEmpty ifTrue: [ nil ] ifFalse: [ node children at: 1] ! ! !NNavDirectionParent commentStamp: ''! I'm the one who knows how to navigate going to the parent node.! !NNavDirectionParent class methodsFor: 'builder' stamp: 'GiselaDecuzzi 6/19/2013 12:43'! defaultKeyCombination ^NNavNavigation useArrowsShortcuts ifTrue: [ Character arrowLeft command shift mac | Character arrowLeft ctrl shift ] ifFalse: [ $p command shift mac| $p ctrl shift unix | $p ctrl shift ] ! ! !NNavDirectionParent class methodsFor: 'step over' stamp: 'GiselaDecuzzi 5/7/2013 14:43'! selectionParentScope: selected for: node | nodeSelection | node ifNil: [ ^selected ]. nodeSelection := node start to: node stop. selected = nodeSelection ifTrue: [ ^self selectionParentScope: selected for: node parent ] ifFalse: [ ^nodeSelection ].! ! !NNavDirectionParent class methodsFor: 'builder' stamp: 'GiselaDecuzzi 6/18/2013 11:38'! buildShortcut: aBuilder (aBuilder shortcut: #parent) category: #SmalltalkEditor default: self defaultKeyCombination do: [ :morph | morph standOutOverScope ] description: 'Select the node scope going to the paren node' ! ! !NNavDirectionParent class methodsFor: 'stand out' stamp: 'GiselaDecuzzi 5/14/2013 16:28'! findSelectionFor: navigationContext ^ self calculateBestSeletionFor: navigationContext bestNodeForSelection beforeSelection: navigationContext textSelection step: [ :selection :target | self selectionParentScope: selection for: target parent ]! ! !NNavDirectionPreviousBrother commentStamp: ''! Go back to the brother before! !NNavDirectionPreviousBrother class methodsFor: 'builder' stamp: 'GiselaDecuzzi 6/18/2013 11:41'! buildShortcut: aBuilder (aBuilder shortcut: #previousSibling) category: #SmalltalkEditor default: self defaultKeyCombination do: [ :morph | morph standOutPreviousChild] description: 'Select the node scope reducing to the previous sibling' ! ! !NNavDirectionPreviousBrother class methodsFor: 'builder' stamp: 'GiselaDecuzzi 6/19/2013 12:44'! defaultKeyCombination ^NNavNavigation useArrowsShortcuts ifTrue: [Character arrowLeft command mac | Character arrowLeft ctrl ] ifFalse: [ $u command mac| $u ctrl unix | $u ctrl ] ! ! !NNavDirectionPreviousBrother class methodsFor: 'step over' stamp: 'GiselaDecuzzi 5/13/2013 18:07'! brotherPositionFor: nodePosition brothers: brothers ^ nodePosition = 1 ifTrue: [ brothers size ] ifFalse: [ nodePosition - 1 ].! ! !NNavDirectionPreviousSelection commentStamp: ''! I know how to go to the previous selection in the text! !NNavDirectionPreviousSelection class methodsFor: 'builder' stamp: 'GiselaDecuzzi 5/22/2013 09:42'! buildShortcut: aBuilder (aBuilder shortcut: #previousSelection) category: #SmalltalkEditor default: $b command shift mac| $b ctrl shift unix | $b ctrl shift do: [ :morph | morph standOutPreviousSelection ] description: 'Select the previous selected scope'! ! !NNavDirectionPreviousSelection class methodsFor: 'stand out' stamp: 'GiselaDecuzzi 5/14/2013 15:35'! findSelectionFor: navigationContext ^ navigationContext lastSelection ! ! !NNavDirectionSibling commentStamp: ''! I'm the one who knows how to navigate in an horizontal way visiting node in the same level statin from left to right ! !NNavDirectionSibling class methodsFor: 'step over' stamp: 'GiselaDecuzzi 5/13/2013 18:07'! brotherNodeFor: node "Finds the next brother for the node" | brothers nodePosition nextBrotherPosition | node ifNil: [ ^nil ]. node parent ifNil: [ ^nil ]. "no parent you are orphan" brothers := node parent children. nodePosition := (brothers indexOf: node) . nextBrotherPosition := self brotherPositionFor: nodePosition brothers: brothers . ^ brothers at: nextBrotherPosition. ! ! !NNavDirectionSibling class methodsFor: 'builder' stamp: 'GiselaDecuzzi 6/19/2013 12:44'! defaultKeyCombination ^NNavNavigation useArrowsShortcuts ifTrue: [ Character arrowRight command mac | Character arrowRight ctrl ] ifFalse: [ $u command shift mac| $u ctrl shift unix | $u ctrl shift ]! ! !NNavDirectionSibling class methodsFor: 'step over' stamp: 'GiselaDecuzzi 5/13/2013 17:28'! brotherPositionFor: nodePosition brothers: brothers ^ nodePosition = brothers size ifTrue: [ 1 ] ifFalse: [ nodePosition + 1 ]. ! ! !NNavDirectionSibling class methodsFor: 'builder' stamp: 'GiselaDecuzzi 6/18/2013 11:40'! buildShortcut: aBuilder (aBuilder shortcut: #sibling) category: #SmalltalkEditor default: self defaultKeyCombination do: [ :morph | morph standOutHorizontalScope] description: 'Select the node going to the siblings' ! ! !NNavDirectionSibling class methodsFor: 'step over' stamp: 'GiselaDecuzzi 5/13/2013 17:03'! selectionBrotherScope: selected for: node | brother | node ifNil: [ ^selected ]. brother := self brotherNodeFor: node. ^brother ifNil:[nil] ifNotNil: [ brother start to: brother stop].! ! !NNavDirectionSibling class methodsFor: 'stand out' stamp: 'GiselaDecuzzi 5/14/2013 16:27'! findSelectionFor: navigationContext ^ self calculateBestSeletionFor: (self brotherNodeFor: navigationContext bestNodeForSelection ) beforeSelection: navigationContext textSelection step: [ :selection :target | self selectionBrotherScope: selection for: target ]! ! !NNavNavigateTest commentStamp: ''! I tests the navigations directions! !NNavNavigateTest methodsFor: 'children' stamp: 'GiselaDecuzzi 5/13/2013 17:45'! testNextChildWhenItHasNotChildsItIsNil | child parent | parent := RBSequenceNode new. child := NNavDirectionFirstChild childNodeFor: parent . self assert: child isNil .! ! !NNavNavigateTest methodsFor: 'sibling-prev' stamp: 'GiselaDecuzzi 5/14/2013 16:10'! testNotPreviousBrotherWhenOrphan | orphanNode brother | orphanNode := RBVariableNode named: 'roque'. brother := NNavDirectionPreviousBrother brotherNodeFor: orphanNode. self assert: brother isNil.! ! !NNavNavigateTest methodsFor: 'sibling-prev' stamp: 'GiselaDecuzzi 5/14/2013 16:07'! testNextBrotherItsThePreviousOfTheChilds | bigBrother middleBrother littleBrother brother parent | parent := RBSequenceNode new. bigBrother := RBVariableNode named: 'big'. parent addNode: bigBrother. middleBrother := RBVariableNode named: 'middle'. parent addNode: middleBrother. littleBrother := RBVariableNode named: 'little'. parent addNode: littleBrother. brother := NNavDirectionPreviousBrother brotherNodeFor: middleBrother . self assert: brother equals: bigBrother . ! ! !NNavNavigateTest methodsFor: 'sibling' stamp: 'GiselaDecuzzi 5/14/2013 16:09'! testNotBrotherWhenOrphan | orphanNode brother | orphanNode := RBVariableNode named: 'roque'. brother := NNavDirectionPreviousBrother brotherNodeFor: orphanNode. self assert: brother isNil.! ! !NNavNavigateTest methodsFor: 'children' stamp: 'GiselaDecuzzi 5/13/2013 17:45'! testNextChildWhenHasChildsIsTheBiggerOne | bigBrother littleBrother child parentRenamed | parentRenamed := RBSequenceNode new. bigBrother := RBVariableNode named: 'pp'. parentRenamed addNode: bigBrother. littleBrother := RBVariableNode named: 'roque'. parentRenamed addNode: littleBrother. child := NNavDirectionFirstChild childNodeFor: parentRenamed . self assert: child equals: bigBrother .! ! !NNavNavigateTest methodsFor: 'sibling' stamp: 'GiselaDecuzzi 5/13/2013 17:45'! testSameNodeIsTheBrotherWhenOnlyChild | uniqueChildNode brother parent | parent := RBSequenceNode new. uniqueChildNode := RBVariableNode named: 'roque'. parent addNode: uniqueChildNode. self assert: uniqueChildNode parent equals: parent. self assert: parent children size equals: 1. brother := NNavDirectionSibling brotherNodeFor: uniqueChildNode. self assert: brother equals: uniqueChildNode .! ! !NNavNavigateTest methodsFor: 'sibling' stamp: 'GiselaDecuzzi 5/13/2013 17:45'! testNextBrotherItsTheNextOfTheChilds | bigBrother littleBrother brother parent | parent := RBSequenceNode new. bigBrother := RBVariableNode named: 'pp'. parent addNode: bigBrother. littleBrother := RBVariableNode named: 'roque'. parent addNode: littleBrother. brother := NNavDirectionSibling brotherNodeFor: bigBrother . self assert: brother equals: littleBrother . ! ! !NNavNavigateTest methodsFor: 'sibling' stamp: 'GiselaDecuzzi 5/13/2013 17:45'! testNextBrotherWhenItsTheLasItsTheFirst | bigBrother littleBrother brother parent | parent := RBSequenceNode new. bigBrother := RBVariableNode named: 'pp'. parent addNode: bigBrother. littleBrother := RBVariableNode named: 'roque'. parent addNode: littleBrother. brother := NNavDirectionSibling brotherNodeFor: littleBrother. self assert: brother equals: bigBrother .! ! !NNavNavigateTest methodsFor: 'sibling-prev' stamp: 'GiselaDecuzzi 5/14/2013 16:09'! testNextBrotherWhenItsTheFirstItsTheLast | bigBrother middleBrother littleBrother brother parent | parent := RBSequenceNode new. bigBrother := RBVariableNode named: 'big'. parent addNode: bigBrother. middleBrother := RBVariableNode named: 'middle'. parent addNode: middleBrother. littleBrother := RBVariableNode named: 'little'. parent addNode: littleBrother. brother := NNavDirectionPreviousBrother brotherNodeFor: bigBrother. self assert: brother equals: littleBrother .! ! !NNavNavigation commentStamp: ''! I'm the one who manage the navigation and I have memory from what I've been navigating! !NNavNavigation methodsFor: 'current-context' stamp: 'GiselaDecuzzi 5/14/2013 15:11'! textSelection ^ self textArea selectionInterval! ! !NNavNavigation methodsFor: 'private' stamp: 'GiselaDecuzzi 5/14/2013 16:02'! updateState: newSelection newSelection = currentSelection ifFalse: [ lastSelection := currentSelection]. currentSelection := newSelection. currentEditor := nil. ! ! !NNavNavigation methodsFor: 'current-context' stamp: 'GiselaDecuzzi 5/14/2013 15:14'! bestNodeForSelection | root | currentEditor isWorkspace ifTrue: [root := RBParser parseFaultyExpression: self currentText] ifFalse: [root := RBParser parseFaultyMethod: self currentText]. ^ root bestNodeFor: self textSelection . ! ! !NNavNavigation methodsFor: 'current-context' stamp: 'GiselaDecuzzi 5/30/2013 13:55'! textArea ^ currentEditor sourceTextArea ! ! !NNavNavigation methodsFor: 'accessing' stamp: 'GiselaDecuzzi 5/14/2013 15:35'! lastSelection ^ lastSelection! ! !NNavNavigation methodsFor: 'current-context' stamp: 'GiselaDecuzzi 5/14/2013 15:10'! currentText ^ self textArea text! ! !NNavNavigation methodsFor: 'navigation' stamp: 'GiselaDecuzzi 5/14/2013 16:00'! navigate: editor direction: direction | newSelection | currentEditor := editor. newSelection := direction findSelectionFor: self. self textArea selectFrom: newSelection first to: newSelection last. self updateState: newSelection . ! ! !NNavNavigation class methodsFor: 'configuration' stamp: 'GiselaDecuzzi 6/18/2013 11:28'! useArrowsShortcuts: enable UseArrowsShortcuts := enable. KMRepository reset. ! ! !NNavNavigation class methodsFor: 'instance creation' stamp: 'GiselaDecuzzi 5/13/2013 16:10'! new "yes I'm a singleton" Instance ifNil: [Instance := super new]. ^Instance. ! ! !NNavNavigation class methodsFor: 'configuration' stamp: 'GiselaDecuzzi 6/18/2013 11:26'! enableAstHighlightSetting: aBuilder (aBuilder setting: #useArrowsShortcuts) label: 'AST navigation' translated; parent: #codeBrowsing; target: NNavNavigation ; description: 'When selected the shortcuts for node navigation use arrows' translated ! ! !NNavNavigation class methodsFor: 'configuration' stamp: 'GiselaDecuzzi 6/18/2013 11:32'! useArrowsShortcuts ^UseArrowsShortcuts ifNil: [ false ] ! ! !NOCCompletionTable commentStamp: ''! I keep track of symbols to be retrieved in ocompletion algorithm. Unlike ecompletion, I learn something and try to retrieve users last occurences of typing sequences first, then the system symbols which match. TODO remove stupid symbols (like packages and method extensions and timestamp)! !NOCCompletionTable methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 11:20'! listsForPrefix: aString | prefixes | aString isEmpty ifTrue: [^ Array with: (NOCEntryList ofSize: numberofEntries)]. prefixes := OrderedCollection with: aString first asLowercase asString. aString size > 1 ifTrue: [prefixes add: ((aString first: 2) collect: [:e | e asLowercase])]. ^ prefixes collect: [:prefix | table at: prefix ifAbsentPut: [ NOCEntryList ofSize: numberofEntries ]]! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/10/2009 12:11'! fillRate ^ self totalNumberOfEntries / self maxNumberOfEntries ! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/9/2009 17:42'! entriesPerPrefix: n numberofEntries := n! ! !NOCCompletionTable methodsFor: 'protocol' stamp: 'rr 4/15/2009 10:52'! addEntry: aString date: d | lists | lists := self listsForPrefix: aString. lists do: [:e | e addEntry: aString date: d] ! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/10/2009 11:21'! reset table := Dictionary new.! ! !NOCCompletionTable methodsFor: 'protocol' stamp: 'MarcusDenker 7/15/2012 13:47'! quickFillWithCategoryOf: cls (Smalltalk organization classesInCategory: cls theNonMetaClass category) do: [:e | self quickFillWithClass: e]! ! !NOCCompletionTable methodsFor: 'protocol' stamp: 'ul 11/6/2010 06:35'! compiled: selector in: class date: date | method | self addEntry: selector date: date. self class classes addEntry: class theNonMetaClass name date: date. (class canUnderstand: selector) ifFalse: [ ^self ]. method := class compiledMethodAt: selector ifAbsent: [ ^self ]. method messages do: [ :m | self addEntry: m date: date ]. method literals do: [ :each | (each isVariableBinding and: [ each key notNil and: [ each key first isUppercase ] ]) ifTrue: [ self class classes addEntry: each key date: date ] ]! ! !NOCCompletionTable methodsFor: 'protocol' stamp: 'rr 4/9/2009 17:55'! addEntry: aString | d | d := DateAndTime now. self addEntry: aString date: d! ! !NOCCompletionTable methodsFor: 'protocol' stamp: 'rr 4/16/2009 12:01'! justCompiled: selector in: class | date | date := DateAndTime now. self compiled: selector in: class date: date! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/10/2009 12:10'! maxNumberOfEntries ^ 26 * 26 * numberofEntries ! ! !NOCCompletionTable methodsFor: 'initialization' stamp: 'rr 4/9/2009 17:45'! initialize table := Dictionary new.! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 11:20'! listForPrefix: aString | prefix | aString isEmpty ifTrue: [^ NOCEntryList ofSize: numberofEntries]. prefix := aString size = 1 ifTrue: [ aString first asLowercase asString] ifFalse: [(aString first: 2) collect: [:e | e asLowercase]]. ^ table at: prefix ifAbsentPut: [ NOCEntryList ofSize: numberofEntries ]! ! !NOCCompletionTable methodsFor: 'protocol' stamp: 'rr 5/28/2009 14:10'! quickFillWithClass: cls cls methodsDo: [:e | self justCompiled: e selector in: cls] ! ! !NOCCompletionTable methodsFor: 'protocol' stamp: 'MarcusDenker 7/15/2012 13:48'! quickFillWithCategoriesMatching: pattern (Smalltalk organization categoriesMatching: pattern) do: [:category | (Smalltalk organization classesInCategory: category) do: [:e | self quickFillWithClass: e]]! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/9/2009 17:49'! totalNumberOfEntries ^ table inject: 0 into: [:total :list | total + list numEntries]! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/9/2009 17:46'! numberOfEntries ^ numberofEntries! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/17/2009 14:14'! entriesMatching: prefix | list | list := self listForPrefix: prefix. ^ list entriesMatching: prefix! ! !NOCCompletionTable class methodsFor: 'class initialization' stamp: 'MarcusDenker 11/14/2012 13:38'! initialize SystemAnnouncer uniqueInstance unsubscribe: self; on: MethodAdded, MethodModified send: #methodChanged: to: self. Smalltalk addToShutDownList: self.! ! !NOCCompletionTable class methodsFor: 'instance creation' stamp: 'rr 4/14/2009 17:13'! default ^ table ifNil: [table := self new entriesPerPrefix: 40]! ! !NOCCompletionTable class methodsFor: 'system startup' stamp: 'MarcusDenker 11/14/2012 13:39'! shutDown self reset! ! !NOCCompletionTable class methodsFor: 'events' stamp: 'GuillermoPolito 8/3/2012 14:44'! methodChanged: event self default totalNumberOfEntries < 200 ifTrue: [self default quickFillWithCategoryOf: event methodClass]. self default totalNumberOfEntries < 500 ifTrue: [self default quickFillWithClass: event methodClass]. self default justCompiled: event selector in: event methodClass.! ! !NOCCompletionTable class methodsFor: 'instance creation' stamp: 'MarcusDenker 11/14/2012 13:33'! reset classTable := nil. table := nil.! ! !NOCCompletionTable class methodsFor: 'accessing' stamp: 'CamilloBruni 8/4/2012 01:05'! classes ^ classTable ifNil: [classTable := self new entriesPerPrefix: 40]! ! !NOCCompletionTable class methodsFor: 'cleanup' stamp: 'MarcusDenker 11/14/2012 13:37'! cleanUp self reset.! ! !NOCContext commentStamp: ''! I keep the context of the ocompletion. I do the same as my parent but for this specific algorithm! !NOCContext methodsFor: 'model creation' stamp: 'CamilloBruni 8/5/2012 23:55'! createModel | aModel | aModel := NOCModel class: theClass temporaries: self temporaries additionals: controller additionals variables: variables selectors: selectors. aModel context: self. ^ aModel ! ! !NOCContext methodsFor: 'model creation' stamp: 'EstebanLorenzano 2/1/2013 17:50'! nextModel "Provide a next lookup model. It is defining a chain of responsibility, translating the model to eCompletion, to ensure having results" ^ super createModel! ! !NOCController commentStamp: ''! I am the entrance door to the ocompletion algorithm. I can resolve the queried sequences and retrieve a list of answers according to ocompletion algorithm based on the last accepted sequences from the user. ! !NOCController methodsFor: 'private' stamp: 'CamilloBruni 8/5/2012 23:16'! menuMorphClass ^ NOCMenuMorph! ! !NOCController methodsFor: 'private' stamp: 'EstebanLorenzano 4/12/2012 11:17'! contextClass ^NOCContext! ! !NOCDatedEntry commentStamp: ''! I keep a symbol entry, along with the last time it was used in the system. I am used to sort the possible answers.! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:08'! unlink next previous: previous. previous next: next! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'rr 4/9/2009 15:32'! now date := DateAndTime now! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'rr 2/21/2009 11:49'! date ^ date! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:07'! next ^next! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:07'! previous ^previous! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:38'! matches: pref ^contents beginsWithEmpty: pref caseSensitive: false! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:08'! next: anODatedEntry next := anODatedEntry! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'rr 4/9/2009 15:38'! date: d date := d! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:12'! link: anODatedEntry "Link the given entry after me." anODatedEntry next: next; previous: self. next previous: anODatedEntry. next := anODatedEntry! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:08'! previous: anODatedEntry previous := anODatedEntry! ! !NOCDatedEntry methodsFor: 'operations' stamp: 'rr 2/21/2009 11:49'! <= anEntry ^ date = anEntry date ifTrue: [contents <= anEntry contents] ifFalse: [date > anEntry date]! ! !NOCEmptyModel commentStamp: ''! I implement a null object pattern related to NOCModel in order to mark the end of possible completions in the answer list. ! !NOCEmptyModel methodsFor: 'accessing' stamp: 'rr 4/17/2009 14:26'! narrowString: string! ! !NOCEmptyModel methodsFor: 'accessing' stamp: 'rr 4/17/2009 14:27'! entryCount ^ 0! ! !NOCEmptyModel methodsFor: 'accessing' stamp: 'rr 4/14/2009 16:47'! entries ^ Array new! ! !NOCEmptyModel methodsFor: 'accessing' stamp: 'rr 4/17/2009 14:26'! narrowWith: string ! ! !NOCEntryList commentStamp: ''! I am the list of entries (possible symbols) returned by nocompletion algorithm. I am sorted according to last acceptance from the user.! !NOCEntryList methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:31'! firstEntry ^ entryHead previous! ! !NOCEntryList methodsFor: 'accessing' stamp: 'rr 4/9/2009 16:14'! last ^self lastEntry contents! ! !NOCEntryList methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 11:21'! setSize: n size := n. entries := Dictionary new: n. entryHead := NOCDatedEntry contents: #'' size type: #selector. entryHead next: entryHead; previous: entryHead. ! ! !NOCEntryList methodsFor: 'accessing' stamp: 'rr 4/9/2009 16:14'! first ^self firstEntry contents! ! !NOCEntryList methodsFor: 'adding' stamp: 'EstebanLorenzano 4/12/2012 11:21'! addEntry: aSymbol date: aDate | entry currentEntry | entry := entries at: aSymbol ifAbsent: nil. entry ifNotNil: [ entry unlink ] ifNil: [ entry := NOCDatedEntry contents: aSymbol type: #selector. entries at: aSymbol put: entry ]. entry date: aDate. currentEntry := entryHead previous. [ currentEntry == entryHead or: [ currentEntry date <= aDate ] ] whileFalse: [ currentEntry := currentEntry previous ]. currentEntry link: entry. entries size > size ifTrue: [ entry := entryHead next unlink. entries removeKey: entry contents ]! ! !NOCEntryList methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:31'! lastEntry ^ entryHead next! ! !NOCEntryList methodsFor: 'accessing' stamp: 'rr 2/21/2009 11:46'! numEntries ^ entries size! ! !NOCEntryList methodsFor: 'adding' stamp: 'rr 4/9/2009 16:06'! addEntry: aSymbol self addEntry: aSymbol date: DateAndTime now! ! !NOCEntryList methodsFor: 'accessing' stamp: 'ul 9/29/2010 18:56'! entriesMatching: prefix ^Array new: entries size // 4 + 1 streamContents: [ :stream | | entry | entry := self firstEntry. [ entry == entryHead ] whileFalse: [ (entry matches: prefix) ifTrue: [ stream nextPut: entry ]. entry := entry previous ] ]! ! !NOCEntryList class methodsFor: 'instance creation' stamp: 'rr 2/21/2009 11:44'! ofSize: n ^ self new setSize: n; yourself! ! !NOCMenuMorph commentStamp: ''! I am a morphic item used to show ocompletion entries. ! !NOCMenuMorph methodsFor: 'accessing' stamp: 'rr 4/15/2009 15:32'! height ^ 7! ! !NOCMenuMorph methodsFor: 'actions' stamp: 'rr 6/26/2009 11:33'! narrowCompletion | model | self selected: 0. firstVisible := 1. model := context model. model narrowWith: context completionToken. model notEmpty ifTrue: [self selected: 1]. model entries size < self selected ifTrue: [self selected: model entries size]. self show. ^ true! ! !NOCModel commentStamp: ''! I keep the state of the ocompletion algorithm. See comments of my parents for details. ! !NOCModel methodsFor: 'accessing' stamp: 'MarcusDenker 10/5/2013 19:28'! entries entries ifEmpty: [ self loadEntries ]. ^ entries! ! !NOCModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 11:20'! noNextModel nextModel := NOCEmptyModel new.! ! !NOCModel methodsFor: 'accessing' stamp: 'CamilloBruni 8/5/2012 23:55'! context: aNOCContext context := aNOCContext.! ! !NOCModel methodsFor: 'accessing' stamp: 'CamilloBruni 8/5/2012 23:33'! contract expand := true. nextModel := nil.! ! !NOCModel methodsFor: 'private' stamp: 'CamilloBruni 8/7/2012 11:50'! loadFavoredEntries (narrowString notEmpty and: [narrowString first isUppercase]) ifTrue: [ ^ classTable entriesMatching: narrowString ]. includeSelectors ifTrue: [ ^ table entriesMatching: narrowString ] ifFalse: [ ^ #() ].! ! !NOCModel methodsFor: 'initialize-release' stamp: 'rr 4/14/2009 13:56'! initializeSelectors! ! !NOCModel methodsFor: 'accessing' stamp: 'RomainRobbes 8/2/2010 17:56'! entryCount ^ self entries size! ! !NOCModel methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2012 21:26'! tableForEntry: ent ^ (ent notEmpty and: [ent first isUppercase]) ifTrue: [classTable] ifFalse: [table]! ! !NOCModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 11:17'! useUniqueTable table := NOCCompletionTable new entriesPerPrefix: 20. ! ! !NOCModel methodsFor: 'accessing' stamp: 'rr 5/28/2009 11:29'! addEntry: ent (self tableForEntry: ent) addEntry: ent ! ! !NOCModel methodsFor: 'accessing' stamp: 'rr 4/14/2009 13:56'! addSelectors ! ! !NOCModel methodsFor: 'accessing' stamp: 'MarcusDenker 12/2/2013 14:07'! narrowWith: aString self narrowString: aString. self loadEntries. self nextModel ifNotNil: [:nm | nm narrowWith: aString].! ! !NOCModel methodsFor: 'accessing' stamp: 'CamilloBruni 8/6/2012 12:58'! nextModel ^ nextModel ifNil: [ nextModel := context nextModel. nextModel narrowWith: narrowString. nextModel ].! ! !NOCModel methodsFor: 'initialization' stamp: 'CamilloBruni 8/3/2012 21:26'! initialize super initialize. self contract. table := NOCCompletionTable default. classTable := NOCCompletionTable classes.! ! !NOCModel methodsFor: 'private' stamp: 'CamilloBruni 8/7/2012 12:32'! sortByLastRecentlyUsed: lastRecentlyUsedEntries "Sort my entrys by the most recently used date" | lastRecentlyUsed | lastRecentlyUsed := Dictionary new. lastRecentlyUsedEntries do: [ :entry| lastRecentlyUsed at: entry contents put: entry date asSeconds ]. entries sort: [ :a :b|| dateA dateB| dateA := lastRecentlyUsed at: a contents asString ifAbsent: [ 0 ]. dateB := lastRecentlyUsed at: b contents asString ifAbsent: [ 0 ]. dateA >= dateB].! ! !NOCModel methodsFor: 'accessing' stamp: 'damiencassou 7/27/2009 14:22'! at: aNumber ^ self entries at: (aNumber max: 1) ! ! !NOCModel methodsFor: 'accessing' stamp: 'CamilloBruni 8/6/2012 00:01'! title ^ self nextModel title! ! !NOCModel methodsFor: 'private' stamp: 'CamilloBruni 8/7/2012 11:51'! loadNextModelEntries entries := self nextModel entries ! ! !NOCModel methodsFor: 'accessing' stamp: 'rr 4/15/2009 13:28'! expand expand := true.! ! !NOCModel methodsFor: 'accessing' stamp: 'rr 4/14/2009 13:46'! table ^ table! ! !NOCModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 16:01'! completionAt: aNumber "when an entry is selected, update its date (for inlined messages which do not appear in the method's body" | entry | entry := (self at: aNumber) completion. self addEntry: entry. ^ NECPreferences spaceAfterCompletion ifTrue: [ entry separateKeywords, ' ' ] ifFalse: [ entry separateKeywords ].! ! !NOCModel methodsFor: 'private' stamp: 'CamilloBruni 8/7/2012 12:25'! loadEntries | priorityEntries | "entries used from the last recently used" priorityEntries := 6. self loadNextModelEntries. entries size <= priorityEntries ifTrue: [ ^ self ]. "most recently used entries first!!" self sortByLastRecentlyUsed: self loadFavoredEntries. "sort the rest alphabetically" entries mergeSortFrom: priorityEntries to: entries size by: [ :a :b| (a contents asString compare: b contents asString caseSensitive: false) <= 2 ]! ! !NaNException commentStamp: 'SvenVanCaekenberghe 4/15/2011 16:41'! I am NaNException, an ArithmeticException signaled when Float nan was encountered where it was not allowed. ! !NameLookupFailure commentStamp: 'mir 5/12/2003 18:16'! Signals that a name lookup operation failed. hostName hostName for which the name loopup failed ! !NameLookupFailure methodsFor: 'accessing' stamp: 'len 12/14/2002 11:57'! hostName: aString hostName := aString! ! !NameLookupFailure methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/14/2013 19:59'! standardMessageText "Generate a standard textual description" ^ String streamContents: [ :stream | stream << 'cannot resolve '. stream print: self hostName ]! ! !NameLookupFailure methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/14/2013 19:59'! messageText "Overwritten to initialiaze the message text to a standard text if it has not yet been set" ^ messageText ifNil: [ messageText := self standardMessageText ]! ! !NameLookupFailure methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/14/2013 20:04'! defaultAction "Backward compatibility" | response | response := UIManager default chooseFrom: #('Retry' 'Give Up') title: self printString. ^ response = 2 ifTrue: [ super defaultAction ] ifFalse: [ self retry ]! ! !NameLookupFailure methodsFor: 'accessing' stamp: 'len 12/14/2002 11:57'! hostName ^ hostName! ! !NameLookupFailure class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:57'! hostName: aString ^ self new hostName: aString! ! !NameLookupFailure class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 1/14/2013 19:58'! signalFor: hostName "Create and signal a NameLookupFailure for hostName" ^ (self hostName: hostName) signal! ! !NameStringInHalo methodsFor: 'drawing' stamp: 'BenComan 4/17/2014 21:31'! drawOn: aCanvas aCanvas fillRectangle: self bounds color: Color white. super drawOn: aCanvas.! ! !NativeBoost commentStamp: ''! i am a core class, which provides a common functionality, required by many NativeBoost facilities to function, including: - basic memory operations - external roots registry - call gate function - session management Every new session, i using an unique instance, which is platform specific (see my subclasses). To access a current session instance, you can issue: NativeBoost forCurrentPlatform ! !NativeBoost methodsFor: 'memory access' stamp: 'Igor.Stasenko 5/3/2010 10:31'! ulongAt: ulongAddr | buf | buf := ByteArray new: 8. self ulongAt: ulongAddr into: buf. ^ buf unsignedLongAt: 1 bigEndian: false! ! !NativeBoost methodsFor: 'retrieving symbols' stamp: 'IgorStasenko 11/24/2012 15:58'! loadModule: aModuleName " call an interpreter proxy function void* ioLoadModuleOfLength(char*, int) to retrieve an external module handle if module can't be loaded, or not found , answer 0 " ^ self nbCallout options: #(- optAllowExternalAddressPtr); function: #( ulong (char* aModuleName, NBByteArraySize aModuleName )) emit: [:gen | gen proxy callFn: #ioLoadModule:OfLength: . ] ! ! !NativeBoost methodsFor: 'memory operations' stamp: 'Igor.Stasenko 9/25/2010 10:03'! allocate: aSize "Allocate a memory block with given size in bytes, answer an NBExternalAddress instance - address to the beginning of memory block" " DO NOT OVERRIDE. Override #basicAllocate: instead" | addr | addr := self basicAllocate: aSize. addr ifNil: [ self allocationFailed ]. ^ addr! ! !NativeBoost methodsFor: 'memory operations' stamp: 'Igor.Stasenko 9/26/2010 04:12'! free: address "Free the external memory, allocated using #allocate: message. Note: never pass pointers, which you allocated by other means" self subclassResponsibility ! ! !NativeBoost methodsFor: 'retrieving symbols' stamp: 'IgorStasenko 7/1/2013 11:04'! ioLoadModule: aModuleName " call an interpreter proxy function void* ioLoadModuleOfLength(char*, int) to retrieve an external module handle if module can't be loaded, or not found , answer nil " ^ NBNativeCodeGen methodAssembly: [:gen | | fail retHandle proxy asm moduleNameOop end | moduleNameOop := gen reserveTemp. asm := gen asm. proxy := gen proxy. fail := asm uniqueLabelName: 'failed'. retHandle := asm uniqueLabelName: 'retHandle'. end := asm uniqueLabelName: 'end'. proxy stackValue: 0. asm mov: EAX to: moduleNameOop. proxy isBytes: EAX. asm or: EAX with: EAX. asm jz: fail. proxy byteSizeOf: moduleNameOop. asm push: EAX. " push length " proxy varBytesFirstFieldOf: moduleNameOop. asm push: EAX. "push first indexable field address" proxy callFn: #ioLoadModule:OfLength: . asm or: EAX with: EAX; jnz: retHandle. proxy nilObject. asm jmp: end. asm label: retHandle. proxy signed32BitIntegerFor: EAX. asm jmp: end. asm label: fail. proxy primitiveFail. asm label: end. gen epilogue ] ! ! !NativeBoost methodsFor: 'bootstrapping' stamp: 'Igor.Stasenko 5/2/2010 14:01'! initializeExternalHeap "create and initialize a new instance of external memory heap" self subclassResponsibility! ! !NativeBoost methodsFor: 'callback support' stamp: 'cipt 11/3/2012 18:28'! insideCallback bootstrapping ifTrue: [ ^ false ]. ^ (callbackCounterAddr nbInt32AtOffset: 0) ~= 0! ! !NativeBoost methodsFor: 'retrieving symbols' stamp: 'JavierPimas 9/27/2011 14:47'! VMModule "answer a C library path, or module handle, use in FFI callouts as module: argument to call C run-time library function(s)" self subclassResponsibility ! ! !NativeBoost methodsFor: 'memory operations' stamp: 'Igor.Stasenko 5/3/2010 11:03'! allocationFailed self error: 'Memory allocation failed'! ! !NativeBoost methodsFor: 'memory operations' stamp: 'IgorStasenko 12/6/2012 14:43'! memCopy: src to: dst size: numBytes "Copy the numBytes from src to dst memory buffer. src & dst can be either a variable-byte oop or NBExternalAddress instance. Warning!!!! Warning!!!! Warning!!!! This is a direct memory accees!!!!!! No range checking!!!!!! " ^ self nbCallout options: #( + optAllowByteArraysPtr optAllowExternalAddressPtr); function: #( void (byte * src, byte * dst, ulong numBytes)) emit: [:gen | | asm temp1 temp2 | asm := gen asm. temp1 := gen reserveTemp. temp2 := gen reserveTemp. asm cld; mov: ESI to: temp1; mov: EDI to: temp2; pop: ESI; " src" pop: EDI; "dst" pop: ECX; "numBytes" rep; movsb; mov: temp1 to: ESI; mov: temp2 to: EDI ]! ! !NativeBoost methodsFor: 'memory access' stamp: 'IgorStasenko 11/24/2012 16:01'! ulongAt: addr into: returnValueBuffer "read uint from given address" ^ self nbCallout " do not use optimizations, since it may lead to infinite resursion" options: #( - optDirectProxyFnAddress optUseStackPointer + optNoAlignment); function: #( NBBootstrapUlong (ulong addr)) emit: [:gen | |asm| asm := gen asm. asm pop: asm EAX. asm mov: asm EAX ptr to: asm EAX ] ! ! !NativeBoost methodsFor: 'memory operations' stamp: 'Igor.Stasenko 5/3/2010 10:58'! basicAllocate: aSize "Allocate a memory block with given size in bytes, answer an NBExternalAddress instance - address to the beginning of memory block, or nil if allocation fails." self subclassResponsibility ! ! !NativeBoost methodsFor: 'initialization' stamp: 'IgorStasenko 3/31/2014 11:42'! initialize "once we have call gate function, we can turn bootstrapping mode off" bootstrapping := true. "first, wipe out all native code from image" self class clearNativeCode. "now, we can enable the native code" self primEnableNativeCode. Current := self. "set the class var" "Init basic stuff" self initializeExternalHeap. "callback counter" callbackCounterAddr := self allocate: 4. callbackCounterAddr nbInt32AtOffset: 0 put: 0. " finally, generate callgate function to finish bootstrap procedure" self callgateFunctionAddress. self initializeForNewSession. ! ! !NativeBoost methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 5/2/2010 13:36'! primEnableNativeCode "Primitive. Enables the execution of native code, which initially disabled during fresh image boot " ! ! !NativeBoost methodsFor: 'testing' stamp: 'Igor.Stasenko 9/25/2010 07:32'! isBootstrapping ^ bootstrapping! ! !NativeBoost methodsFor: 'bootstrapping' stamp: 'IgorStasenko 11/24/2012 15:56'! bootstrapLoadSymbol: symbolName ofLength: symbolLen fromModule: moduleHandle into: returnValueBuffer " call an interpreter proxy function void *ioLoadSymbolOfLengthFromModule(sqInt functionNameIndex, sqInt functionNameLength, void *moduleHandle) to retrieve an external module handle Returning a long 32 bit value may trigger GC which can move native code. In order to avoid that, we don't use any proxy function, which may lead to memory allocation. Thus, we store result into a byte array. " ^ self nbCallout options: #( - optDirectProxyFnAddress optAllowExternalAddressPtr); function: #( NBBootstrapUlong (byte * symbolName , long symbolLen, ulong moduleHandle) ) emit: [:gen | gen proxy callFn: #ioLoadSymbol:OfLength:FromModule: ] ! ! !NativeBoost methodsFor: 'accessing' stamp: 'IgorStasenko 5/28/2012 07:00'! callgateFunctionAddress ^ gateFunction ifNil: [ | bytes addr | NBRecursionDetect in: #callgateFunctionAddress during: [ bytes := self generateCallgateCode. self assert: (bytes class isBytes). addr := self allocate: bytes size. "copy generated bytes to external memory" self memCopy: bytes to: addr size: bytes size. ]. "finally set the function address" gateFunction := addr. bootstrapping := false. gateFunction ] ! ! !NativeBoost methodsFor: 'bootstrapping' stamp: 'IgorStasenko 8/3/2011 09:22'! generateCallgateCode "Answer a byte array of generated native code for gate function. We assume that caller reserves two temporaries on his stack frame [EBP-4], [EBP-8] for saving return address and pritimiveMethod oop" | asm primitiveMethod savedMethodOop returnAddr | asm := self newAssembler noStackFrame. savedMethodOop := EBP ptr - 4. returnAddr := EBP ptr - 8. primitiveMethod := NBInterpreterProxy fnAddressAt: #primitiveMethod. asm mov: primitiveMethod to: EAX; call: EAX; " retrieve a primitive method oop " mov: EAX to: savedMethodOop; pop: returnAddr; "store return address" pop: EAX; "function to call" call: EAX; " call the function " push: returnAddr; "push return addr back on stack" push: EAX; " save return value " push: EDX; mov: primitiveMethod to: EAX; call: EAX; " retrieve a primitive method oop " sub: EAX with: savedMethodOop; add: ESP ptr+8 with: EAX; " current - old + returnAddress " pop: EDX; pop: EAX; ret. ^ asm bytes ! ! !NativeBoost methodsFor: 'bootstrapping' stamp: 'IgorStasenko 3/31/2014 16:25'! initializeForNewSession "let NBExternalStructure recalculate its fields" NBExternalStructure initializeForNewSession. NBExternalArray initializeForNewSession. NBExternalTypeValue initializeForNewSession. "notify any observers about session change" self class announcer announce: NBSessionChangeAnnouncement ! ! !NativeBoost methodsFor: 'retrieving symbols' stamp: 'CiprianTeodorov 3/18/2013 22:34'! loadSymbol: aSymbolName fromModule: moduleName "module could be a string (name) or handle " | bytes module handle | bytes := ByteArray new: 8. moduleName isString ifTrue: [ self bootstrapLoadModule: moduleName asByteArray ofLength: moduleName size into: bytes. module := bytes unsignedLongAt: 1 bigEndian: false. module = 0 ifTrue: [ ^ nil ]. ] ifFalse: [ "if value is negative, use 32-bit complement" module := moduleName bitAnd: 16rFFFFFFFF. ]. self bootstrapLoadSymbol: aSymbolName asByteArray ofLength: aSymbolName size fromModule: module into: bytes. handle := bytes unsignedLongAt: 1 bigEndian: false. handle = 0 ifTrue: [ ^ nil ]. ^ NBExternalAddress value: handle ! ! !NativeBoost methodsFor: 'retrieving symbols' stamp: 'Igor.Stasenko 9/26/2010 04:59'! CLibrary "answer a C library path, or module handle, use in FFI callouts as module: argument to call C run-time library function(s)" self subclassResponsibility ! ! !NativeBoost methodsFor: 'retrieving symbols' stamp: 'IgorStasenko 11/24/2012 15:57'! loadFunction: fnName from: aModuleName " call an interpreter proxy function void* ioLoadFunctionFrom(char*, char*) to retrieve a function pointer of a registered module " ^ self nbCallout function: #( void* (String fnName, String aModuleName) ) emit: [:gen | gen proxy callFn: #ioLoadFunction:From: ]. ! ! !NativeBoost methodsFor: 'bootstrapping' stamp: 'IgorStasenko 11/24/2012 15:55'! bootstrapLoadModule: aModuleName ofLength: len into: returnValueBuffer " call an interpreter proxy function void* ioLoadModuleOfLength(char*, int) to retrieve an external module handle Returning a long 32 bit value may trigger GC. So, we need a gate function for it, which we can't have without loading external stuff, so we store result into a byte array " ^ self nbCallout options: #( - optDirectProxyFnAddress optAllowExternalAddressPtr); function: #( NBBootstrapUlong (byte * aModuleName , long len) ) emit: [:gen | gen proxy callFn: #ioLoadModule:OfLength: . ] ! ! !NativeBoost methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 10:12'! extraRootsRegistry ^ extraRootsRegistry ifNil: [ rootsCell := self allocate: (self pointerSize). extraRootsRegistry := NBExtraRootsRegistry newWithCell: rootsCell ]! ! !NativeBoost methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/2/2010 13:52'! pointerSize self subclassResponsibility ! ! !NativeBoost methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/5/2010 16:47'! newAssembler self subclassResponsibility ! ! !NativeBoost methodsFor: 'callback support' stamp: 'Igor.Stasenko 9/26/2010 04:37'! callbackCounterAddress ^ callbackCounterAddr! ! !NativeBoost methodsFor: 'retrieving symbols' stamp: 'IgorStasenko 11/24/2012 15:56'! ioLoadFunction: fnName from: aModuleName " call an interpreter proxy function void* ioLoadFunctionFrom(char*, char*) to retrieve a function pointer of a registered module " ^ self nbCallout function: #( ulong (String fnName, String aModuleName) ) emit: [:gen | gen proxy callFn: #ioLoadFunction:From: ]. ! ! !NativeBoost methodsFor: 'bootstrapping' stamp: 'IgorStasenko 11/24/2012 15:52'! bootstrapLoadFunction: fnName from: aModuleName into: returnValueBuffer " call an interpreter proxy function void* ioLoadFunctionFrom(char*, char*) to retrieve a function pointer of a registered module " ^ self nbCallout function: #( NBBootstrapUlong (String fnName, String aModuleName) ) emit: [:gen | gen proxy callFn: #ioLoadFunction:From: ]. ! ! !NativeBoost class methodsFor: 'memory access' stamp: 'Igor.Stasenko 5/3/2010 10:27'! ulongAt: ulongAddr ^ self forCurrentPlatform ulongAt: ulongAddr! ! !NativeBoost class methodsFor: 'memory access' stamp: 'Igor.Stasenko 5/5/2010 14:55'! allocate: size ^ self forCurrentPlatform allocate: size! ! !NativeBoost class methodsFor: 'memory access' stamp: 'Igor.Stasenko 5/5/2010 14:55'! free: address ^ self forCurrentPlatform free: address! ! !NativeBoost class methodsFor: 'testing' stamp: 'Igor.Stasenko 5/2/2010 11:00'! isEnabled "Answer flag indicating whether running a native code enabled by plugin" ^ self primitiveFailed! ! !NativeBoost class methodsFor: 'errors' stamp: 'IgorStasenko 8/6/2011 17:42'! lastError ^ self error: 'NativeBoost plugin is not installed?'! ! !NativeBoost class methodsFor: 'testing' stamp: 'Igor.Stasenko 9/26/2010 06:28'! insideCallback ^ self forCurrentPlatform insideCallback! ! !NativeBoost class methodsFor: 'retrieving symbols' stamp: 'JavierPimas 9/27/2011 14:48'! VMModule "answer a C library path, or module handle, use in FFI callouts as module: argument to call C run-time library function(s)" ^ self forCurrentPlatform VMModule! ! !NativeBoost class methodsFor: 'memory access' stamp: 'Igor.Stasenko 5/13/2010 23:06'! memCopy: src to: dst size: numBytes ^ self forCurrentPlatform memCopy: src to: dst size: numBytes! ! !NativeBoost class methodsFor: 'debugger support' stamp: 'IgorStasenko 3/19/2012 13:17'! simulatePrimitiveFor: aMethod receiver: recvr arguments: args context: ctx ^ self tryRunNativeCode: aMethod for: recvr withArgs: args! ! !NativeBoost class methodsFor: 'platform id' stamp: 'Igor.Stasenko 5/2/2010 11:07'! platformId " do not fail, answer nil instead" ^ nil! ! !NativeBoost class methodsFor: 'class initialization' stamp: 'IgorStasenko 3/19/2012 12:43'! initialize "self initialize" self registerPrimitiveSimulators! ! !NativeBoost class methodsFor: 'production mode support' stamp: 'IgorStasenko 7/12/2013 16:40'! prepareForProduction "make sure all methods in image, which using NB call primitive, having captured method's argument names (so later, image can run NB code without requiring access to source code)" CompiledMethod allInstances do: [ :method | method hasNativeCallPrimitive ifTrue: [ "that will make sure that names are cached" method nbArgumentNames ] ]! ! !NativeBoost class methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 1/17/2014 23:36'! isAvailable "Return true when NativeBoost support is available in the VM, false otherwise" ^ self isEnabledOrNil notNil! ! !NativeBoost class methodsFor: 'retrieving symbols' stamp: 'CamilloBruni 7/19/2012 11:51'! loadSymbol: aSymbolName ^ self loadSymbol: aSymbolName fromModule: ''! ! !NativeBoost class methodsFor: 'testing' stamp: 'IgorStasenko 5/28/2012 03:49'! isEnabledOrNil "Answer flag indicating whether running a native code enabled by plugin" ^ nil! ! !NativeBoost class methodsFor: 'subscribing for session change' stamp: 'IgorStasenko 3/28/2012 17:48'! notifyAboutSessionChange: anObject "register an object to be notified about session change" self announcer weak on: NBSessionChangeAnnouncement send: #nbSessionChanged to: anObject ! ! !NativeBoost class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/2/2010 19:10'! callgateFunctionAddress ^ self forCurrentPlatform callgateFunctionAddress! ! !NativeBoost class methodsFor: 'accessing' stamp: 'IgorStasenko 5/28/2012 08:13'! uniqueSessionObject "Answer an unique session object, which changes between image restarts. A call gate function is a good candidate for this, since its generated each time when image first boots. " ^ self forCurrentPlatform callgateFunctionAddress ! ! !NativeBoost class methodsFor: 'testing' stamp: 'Igor.Stasenko 9/25/2010 05:16'! primitiveLoadMainModule "Answer flag indicating whether running a native code enabled by plugin" ^ self primitiveFailed! ! !NativeBoost class methodsFor: 'accessing' stamp: 'IgorStasenko 3/28/2012 17:44'! announcer ^ NBAnnouncer ifNil: [ NBAnnouncer := Announcer new ].! ! !NativeBoost class methodsFor: 'platform id' stamp: 'Igor.Stasenko 4/29/2010 04:27'! targetPlatformId "Should be implemented by subclasses to indicate a target platform. Answer zero - a non-existing platform id " ^ 0! ! !NativeBoost class methodsFor: 'accessing' stamp: 'IgorStasenko 8/13/2013 14:59'! automaticallyGeneratedCodeCategory "answer the name of non-existing package extension category which will be used for auto-generated code to categorize under" ^ '*generated-code-non-existing-package'! ! !NativeBoost class methodsFor: 'debugger support' stamp: 'Igor.Stasenko 5/17/2010 22:01'! isNativeMethod: aCompiledMethod | lit | lit := aCompiledMethod literalAt: 1. ^ aCompiledMethod trailer kind == #NativeCodeTrailer and: [ lit first == #NativeBoostPlugin and: [ lit second == #primitiveNativeCall]]! ! !NativeBoost class methodsFor: 'retrieving symbols' stamp: 'CamilloBruni 7/19/2012 11:50'! loadSymbol: aSymbolName fromModule: moduleName ^ self forCurrentPlatform loadSymbol: aSymbolName fromModule: moduleName! ! !NativeBoost class methodsFor: 'retrieving symbols' stamp: 'Igor.Stasenko 9/26/2010 04:58'! CLibrary "answer a C library path, or module handle, use in FFI callouts as module: argument to call C run-time library function(s)" ^ self forCurrentPlatform CLibrary! ! !NativeBoost class methodsFor: 'retrieving symbols' stamp: 'CamilloBruni 7/19/2012 11:50'! loadFunction: fnName from: aModuleName ^ self forCurrentPlatform loadFunction: fnName from: aModuleName! ! !NativeBoost class methodsFor: 'accessing' stamp: 'IgorStasenko 5/10/2011 15:27'! clearNativeCode "Unconditionally clear all method's native code trailers using a single bulk-become" | old new | self isEnabled ifFalse: [ Current := nil ]. Current ifNotNil: [ Current insideCallback ifTrue: [ self error: 'Clearing a native code while inside a callback' ]]. old := OrderedCollection new. new := OrderedCollection new. CompiledMethod allInstancesDo: [:method | | trailer | trailer := method trailer. trailer kind == #NativeCodeTrailer ifTrue: [ old add: method. new add: (method copyWithTrailerBytes: (CompiledMethodTrailer new sourcePointer: trailer sourcePointer)) ] ]. old asArray elementsForwardIdentityTo: new asArray ! ! !NativeBoost class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/2/2010 13:04'! extraRootsRegistry ^ self forCurrentPlatform extraRootsRegistry! ! !NativeBoost class methodsFor: 'system startup' stamp: 'IgorStasenko 5/11/2011 00:50'! enableNativeCode "Enable the native code, answer true if operation was successfull or false if not" self isEnabled ifFalse: [ "If native code is disable in plugin, this means that a system is just started. Create a fresh instance of receiver " Current := nil. ]. self forCurrentPlatform. ^ Current notNil! ! !NativeBoost class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/18/2010 23:14'! forCurrentPlatform "answer my subclass instance, suitable for use on current platform" self isEnabled ifFalse: [ Current := nil ]. ^ Current ifNil: [ self discoverPlatformId ]! ! !NativeBoost class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/5/2010 16:46'! newAssembler ^ self forCurrentPlatform newAssembler! ! !NativeBoost class methodsFor: 'debugger support' stamp: 'IgorStasenko 3/19/2012 12:42'! registerPrimitiveSimulators ContextPart simulatePrimitive: #primitiveNativeCall module: #NativeBoostPlugin with: self! ! !NativeBoost class methodsFor: 'testing' stamp: 'IgorStasenko 5/28/2012 03:58'! sessionChanged: anOldSession "Answer true if session has changed. Do a quick test if NB plugin is not enabled yet to prevent fails in resource finalization during image startup. anOldSession is object which retrieved before, using #uniqueSessionObject message. " self isEnabledOrNil == true ifTrue: [ Current ifNil: [ ^ true ]. ^ (Current callgateFunctionAddress == anOldSession) not ]. "plugin is not enabled, or prim failed, assume session changed" ^ true ! ! !NativeBoost class methodsFor: 'debugger support' stamp: 'MarcusDenker 5/21/2013 07:44'! tryRunNativeCode: aCompiledMethod for: aReceiver withArgs: arguments "run only a native code of given method, and if it fails evaluate aFailBlock instead" | src node m | "self assert: (self isNativeMethod: aCompiledMethod)." src := String streamContents: [:str | str nextPutAll: 'NBDebug_stub'. 1 to: aCompiledMethod numArgs do: [:i | i = 1 ifTrue: [ str nextPutAll: ': ' ] ifFalse: [ str nextPutAll: ' with: ' ]. str nextPutAll: 'arg'. i printOn: str. ]. str cr; nextPutAll: ' '; cr; nextPutAll: ' ^ ContextPart primitiveFailTokenFor: errorCode'. ]. node := Smalltalk compiler compile: src in: aCompiledMethod methodClass classified: nil notifying: nil ifFail: [ ^ ContextPart primitiveFailTokenFor: nil ]. m := node generate: aCompiledMethod trailer. m flushCache. m selector flushCache. ^ m valueWithReceiver: aReceiver arguments: arguments. ! ! !NativeBoost class methodsFor: 'errors' stamp: 'IgorStasenko 5/11/2011 00:55'! unsupportedPlatform self error: 'You running on platform which not supported by NativeBoost'! ! !NativeBoost class methodsFor: 'retrieving symbols' stamp: 'CamilloBruni 7/19/2012 11:50'! loadFunction: fnName ^ self loadFunction: fnName from: ''! ! !NativeBoost class methodsFor: 'private' stamp: 'IgorStasenko 5/11/2011 00:48'! resetInstance "!!!!!!!! Never use it !!!!!!!! It is here only for development purposes" Current := nil.! ! !NativeBoost class methodsFor: 'system startup' stamp: 'ClementBera 7/26/2013 16:27'! discoverPlatformId | platId | "should not use it, if Current already set" self assert: (Current isNil). platId := self platformId. self allSubclassesDo: [:class | class targetPlatformId = platId ifTrue: [ class new " should set Current during initialization" ]]. Current ifNil: [ self unsupportedPlatform ]. ^ Current ! ! !NativeBoostConstants class methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/9/2010 11:00'! currentPlatformId self primitiveFailed! ! !NativeBoostConstants class methodsFor: 'initialization' stamp: 'IgorStasenko 8/6/2011 18:10'! initialize "self initialize" " Here the platform codes, defined to identify a platform on which VM runs. A compiled method which contain native code using this id to indicate for what platform the native code is generated. A primitive, which responsible for running native code, checks that platform id in method matching the platform id, specified by plugin, and if not, then primitive fails without attempt to run native code" "x86 platform codes" Linux32PlatformId := 1. Mac32PlatformId := 2. Win32PlatformId := 3. self initErrorCodes; initVMErrorCodes; initErrorDescriptions. ! ! !NativeBoostConstants class methodsFor: 'error codes' stamp: 'IgorStasenko 9/21/2012 15:37'! initErrorDescriptions NBErrorDescriptions := Dictionary newFromPairs: { NBPrimNoErr. 'No error'. NBPrimErrGenericFailure. 'Generic failure'. NBPrimErrBadReceiver. 'Bad receiver'. NBPrimErrBadArgument. 'Bad argument'. NBPrimErrBadIndex. 'Bad index'. NBPrimErrBadNumArgs. 'Invalid number of arguments'. NBPrimErrInappropriate. 'Inappropriate operation'. NBPrimErrUnsupported. 'unsupported operation'. NBPrimErrNoModification. 'No modification allowed to immutable object'. NBPrimErrNoMemory. 'Insufficient object memory'. NBPrimErrNoCMemory. 'Insufficient C memory'. NBPrimErrNotFound. 'Not found'. NBPrimErrBadMethod. 'Bad method'. NBPrimErrNamedInternal. 'Internal error in named primitive machinery'. NBPrimErrObjectMayMove. 'Object may move'. NBPrimErrLimitExceeded. 'Resource limit exceeded'. ErrNotEnabled. 'Execution of native code is not enabled by plugin'. ErrNoNativeCodeInMethod. 'No native code installed in primitive method'. ErrInvalidPlatformId. 'Native code in primitive method are for different platform'. ErrNoNBPrimitive. 'A method where native code will be installed, missing a pragma'. ErrRunningViaInterpreter. 'A method with primitive 220 (primitiveVoltage), contains JIT code, but VM decided to execute this method via interpreter '. ErrInvalidPrimitiveVoltageUse. 'A method uses primitive 220 (primitiveVoltage), but does not use an error code: ' }! ! !NativeBoostConstants class methodsFor: 'error codes' stamp: 'IgorStasenko 8/6/2011 18:04'! initVMErrorCodes "took from OSCog's sqVirtualMachine.h" NBPrimNoErr := 0. NBPrimErrGenericFailure := 1. NBPrimErrBadReceiver := 2. NBPrimErrBadArgument := 3. NBPrimErrBadIndex := 4. NBPrimErrBadNumArgs := 5. NBPrimErrInappropriate := 6. NBPrimErrUnsupported := 7. NBPrimErrNoModification := 8. NBPrimErrNoMemory := 9. NBPrimErrNoCMemory := 10. NBPrimErrNotFound := 11. NBPrimErrBadMethod := 12. NBPrimErrNamedInternal := 13. NBPrimErrObjectMayMove := 14. NBPrimErrLimitExceeded := 15.! ! !NativeBoostConstants class methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/9/2010 11:03'! win32PlatformId ^ Win32PlatformId! ! !NativeBoostConstants class methodsFor: 'accessing' stamp: 'IgorStasenko 9/10/2012 12:07'! mac32PlatformId ^ Mac32PlatformId! ! !NativeBoostConstants class methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/14/2010 15:03'! linux32PlatformId ^ Linux32PlatformId! ! !NativeBoostConstants class methodsFor: 'error codes' stamp: 'IgorStasenko 9/21/2012 15:46'! initErrorCodes "An error codes used by Cog NB plugin. Note, at the moment of writing this, a primitive error codes supported only in Cog VMs" NBErrorBase := 500. "execution of native code is not enabled by plugin" ErrNotEnabled := NBErrorBase + 1. "failed to find a native code for primitive method" ErrNoNativeCodeInMethod := NBErrorBase + 2. "native code generated for different platform" ErrInvalidPlatformId := NBErrorBase + 3. "the method which containing foreign call missing a #primitiveNativeCall primitive pragma" ErrNoNBPrimitive := NBErrorBase + 4. "the method has a 220 primitive (primitiveVoltage), but VM decided to execute this method via interpreter " ErrRunningViaInterpreter := NBErrorBase + 5. "A method uses primitive 220 (primitiveVoltage), but does not use an error code: " ErrInvalidPrimitiveVoltageUse := NBErrorBase + 6.! ! !NativeBoostLinux32 methodsFor: 'retrieving symbols' stamp: 'IgorStasenko 1/24/2012 12:38'! getGlobalSymbolPointer: symbolName | bytes addr | bytes := ByteArray new: 8. self bootstrapGetGlobalSymbolPointer: symbolName into: bytes. addr := bytes unsignedLongAt: 1 bigEndian: false. addr = 0 ifTrue: [ self error: 'failed to get a symbol address: ', symbolName ]. ^ NBExternalAddress value: addr ! ! !NativeBoostLinux32 methodsFor: 'memory operations' stamp: 'Igor.Stasenko 9/26/2010 04:13'! free: address "Free the external memory, allocated using #allocate: message. Note: never pass pointers, which you allocated by other means" heap free: address value! ! !NativeBoostLinux32 methodsFor: 'accessing' stamp: 'IgorStasenko 1/16/2014 12:40'! stackAlignment ^ 16! ! !NativeBoostLinux32 methodsFor: 'bootstrapping' stamp: 'Igor.Stasenko 9/26/2010 03:50'! initializeExternalHeap "initialize external memory heap" heap := NBUnixExternalHeapManager new. ! ! !NativeBoostLinux32 methodsFor: 'primitives' stamp: 'Igor.Stasenko 9/25/2010 06:30'! primitiveDlsym "retrieve a pointer to dlsym(...) function" ^ self primitiveFailed! ! !NativeBoostLinux32 methodsFor: 'retrieving symbols' stamp: 'JavierPimas 9/27/2011 14:46'! VMModule "taken from CLibrary. Should work for fetching VM functions too. use in FFI callouts as module: argument to call C run-time library function(s)" "use global symbol space" ^ RTLD_DEFAULT! ! !NativeBoostLinux32 methodsFor: 'retrieving symbols' stamp: 'IgorStasenko 1/18/2012 13:45'! loadSymbol: aSymbolName fromModule: moduleName (moduleName = '' or: [moduleName = 0 ]) ifTrue: [ "if module name is empty, try to retrieve symbol from globals " ^ self getGlobalSymbolPointer: aSymbolName ]. ^ super loadSymbol: aSymbolName fromModule: moduleName! ! !NativeBoostLinux32 methodsFor: 'retrieving symbols' stamp: 'Igor.Stasenko 9/26/2010 05:00'! CLibrary "answer a C library path, or module handle, use in FFI callouts as module: argument to call C run-time library function(s)" "use global symbol space" ^ RTLD_DEFAULT! ! !NativeBoostLinux32 methodsFor: 'memory operations' stamp: 'Igor.Stasenko 9/25/2010 09:37'! basicAllocate: numBytes "Allocate a memory block with given size in bytes, answer an NBExternalAddress instance - address to the beginning of memory block" | addr | addr := heap allocate: numBytes. addr = 0 ifTrue: [ ^ nil ]. ^ NBExternalAddress value: addr! ! !NativeBoostLinux32 methodsFor: 'bootstrapping' stamp: 'IgorStasenko 11/24/2012 16:02'! bootstrapGetGlobalSymbolPointer: symbolName into: returnValueBuffer " call dlsym(RTLD_DEFAULT, symbolName) " ^ self nbCallout options: #( - optUseStackPointer ); function: #( NBBootstrapUlong (RTLD_DEFAULT , String symbolName) ) emit: [:gen | | asm | self assert: (self primitiveDlsym ~= 0). asm := gen asm. asm mov: (self primitiveDlsym asUImm) to: asm EAX. asm call: asm EAX. ] ! ! !NativeBoostLinux32 methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 03:25'! pointerSize ^ 4! ! !NativeBoostLinux32 methodsFor: 'primitives' stamp: 'Igor.Stasenko 9/25/2010 06:31'! primitiveDlopen "retrieve a pointer to dlopen(...) function" ^ self primitiveFailed! ! !NativeBoostLinux32 methodsFor: 'accessing' stamp: 'IgorStasenko 8/5/2011 08:48'! newAssembler ^ AJx86Assembler new.! ! !NativeBoostLinux32 class methodsFor: 'platform id' stamp: 'Igor.Stasenko 9/22/2010 03:12'! targetPlatformId ^ Linux32PlatformId ! ! !NativeBoostMac32 methodsFor: 'bootstrapping' stamp: 'Igor.Stasenko 12/5/2010 18:32'! initializeExternalHeap "initialize external memory heap" heap := NBMacExternalHeapManager new. ! ! !NativeBoostMac32 methodsFor: 'bootstrapping' stamp: 'IgorStasenko 11/24/2012 16:03'! bootstrapGetGlobalSymbolPointer: symbolName into: returnValueBuffer " call dlsym(RTLD_DEFAULT, symbolName) " " override, since mac using different RTLD_DEFAULT constant value " ^ self nbCallout options: #( - optUseStackPointer); function: #( NBBootstrapUlong (RTLD_DEFAULT , String symbolName) ) emit: [:gen | | asm | asm := gen asm. asm mov: (self primitiveDlsym asUImm) to: asm EAX. asm call: asm EAX. ]! ! !NativeBoostMac32 methodsFor: 'bootstrapping' stamp: 'IgorStasenko 11/24/2012 16:03'! getEntryPointStackOffset " call dlsym(RTLD_DEFAULT, symbolName) " " override, since mac using different RTLD_DEFAULT constant value " ^ self nbCallout function: #( ulong () ) emit: [:gen | | asm | asm := gen asm. asm mov: asm ESP to: asm EAX; and: asm EAX with: 16r0F. ]. ! ! !NativeBoostMac32 methodsFor: 'platform-specific' stamp: 'IgorStasenko 8/2/2011 06:33'! stackAlignment ^ 16! ! !NativeBoostMac32 methodsFor: 'platform-specific' stamp: 'IgorStasenko 2/2/2012 16:00'! VMModule "answer a C library path, or module handle, use in FFI callouts as module: argument to call C run-time library function(s)" ^ self CLibrary! ! !NativeBoostMac32 methodsFor: 'assembler' stamp: 'IgorStasenko 8/5/2011 08:48'! newAssembler ^ AJx86Assembler new! ! !NativeBoostMac32 class methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/4/2010 22:21'! targetPlatformId ^ Mac32PlatformId ! ! !NativeBoostWin32 methodsFor: 'retrieving symbols' stamp: 'Igor.Stasenko 9/26/2010 05:00'! CLibrary "answer a C library path, or module handle, use in FFI callouts as module: argument to call C run-time library function(s)" "GNU/mingw compiler" ^ 'crtdll.dll'! ! !NativeBoostWin32 methodsFor: 'memory operations' stamp: 'Igor.Stasenko 5/3/2010 10:59'! basicAllocate: numBytes "answer an instance of NBExternalAddress, or nil if failed" | address | address := NBExternalAddress new. self bootstrapAllocate: numBytes into: address. (address asUnsignedLong) = 0 ifTrue: [ ^ nil ]. ^ address! ! !NativeBoostWin32 methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 10:44'! pointerSize ^ 4! ! !NativeBoostWin32 methodsFor: 'memory operations' stamp: 'IgorStasenko 11/24/2012 16:08'! free: lpMem "The HeapFree function frees a memory block allocated from a heap by the HeapAlloc or HeapReAlloc function. " ^ self nbCallout stdcall; "allow only external address" options: #( - optAllowByteArraysPtr + optAllowExternalAddressPtr ); function: #( BOOL HeapFree (ulong heapHandle, 0, LPVOID lpMem) ) module: #Kernel32 ! ! !NativeBoostWin32 methodsFor: 'private' stamp: 'IgorStasenko 11/24/2012 16:09'! privCreateHeap: returnValueBuffer ^ self nbCallout options: #( - optDirectProxyFnAddress ); stdcall; function: #( NBBootstrapUlong HeapCreate ( HEAP_CREATE_ENABLE_EXECUTE , 0 , 0 ) ) module: #Kernel32 ! ! !NativeBoostWin32 methodsFor: 'accessing' stamp: 'IgorStasenko 8/3/2011 08:08'! stackAlignment ^ 1! ! !NativeBoostWin32 methodsFor: 'accessing' stamp: 'IgorStasenko 8/5/2011 08:48'! newAssembler ^ AJx86Assembler new.! ! !NativeBoostWin32 methodsFor: 'bootstrapping' stamp: 'Igor.Stasenko 5/3/2010 10:50'! initializeExternalHeap "initialize external memory heap" | bytes | bytes := ByteArray new: 4. self privCreateHeap: bytes. heapHandle := bytes unsignedLongAt: 1 bigEndian: false. heapHandle = 0 ifTrue: [ self error: 'Unable to create external heap' ]. ! ! !NativeBoostWin32 methodsFor: 'bootstrapping' stamp: 'IgorStasenko 11/24/2012 16:08'! bootstrapAllocate: size into: returnValueBuffer ^ self nbCallout stdcall; options: #( - optDirectProxyFnAddress optAllowExternalAddressPtr); function: #( NBBootstrapUlong HeapAlloc (ulong heapHandle , 0 , SIZE_T size) ) module: #Kernel32 ! ! !NativeBoostWin32 methodsFor: 'retrieving symbols' stamp: 'IgorStasenko 2/8/2013 12:56'! VMModule ^ self class getVMModuleHandle handle! ! !NativeBoostWin32 class methodsFor: 'C heap access' stamp: 'IgorStasenko 11/24/2012 16:19'! realloc: address newSize: aSize ^ self nbCallout function: #(ulong realloc (ulong address, ulong aSize)) module: 'crtdll.dll'! ! !NativeBoostWin32 class methodsFor: 'accessing' stamp: 'IgorStasenko 11/24/2012 16:17'! getVMModuleHandle "The GetModuleHandle function retrieves a module handle for the specified module if the file has been mapped into the address space of the calling process." ^ self nbCallout stdcall; function: #( HMODULE GetModuleHandleA (0) ) module: #Kernel32 ! ! !NativeBoostWin32 class methodsFor: 'accessing' stamp: 'tbn 11/11/2012 01:01'! getVMModuleName | len str | str := ByteString new: 1000. len := self primGetModuleFileName: str with: 1000. ^ str first: len.! ! !NativeBoostWin32 class methodsFor: 'platform id' stamp: 'Igor.Stasenko 4/29/2010 04:31'! targetPlatformId ^ Win32PlatformId! ! !NativeBoostWin32 class methodsFor: 'library loading' stamp: 'IgorStasenko 11/24/2012 16:18'! loadLibrary: libName ^ self nbCallout stdcall function: #( long LoadLibraryA ( String libName )) module: #Kernel32 ! ! !NativeBoostWin32 class methodsFor: 'library loading' stamp: 'IgorStasenko 11/24/2012 16:09'! getModuleHandle: lpModuleName "The GetModuleHandle function retrieves a module handle for the specified module if the file has been mapped into the address space of the calling process." ^ self nbCallout options: #( - WinUnicode ); stdcall; function: #( HMODULE GetModuleHandleA (LPCTSTR lpModuleName ) ) module: #Kernel32 ! ! !NativeBoostWin32 class methodsFor: 'library loading' stamp: 'tbn 11/10/2012 23:48'! primGetModuleFileName: lpFileName with: nSize "The GetModuleFileName function retrieves the fully-qualified path for the file that contains the specified module that the current process owns." ^ NBFFICallout stdcall: #( DWORD GetModuleFileNameA ( 0, char * lpFileName, DWORD nSize)) module: #Kernel32 options: #( - optCoerceNilToNull WinUnicode ) ! ! !NativeBoostWin32 class methodsFor: 'C heap access' stamp: 'IgorStasenko 11/24/2012 16:18'! malloc: aSize ^ self nbCallout function: #( void* malloc (ulong aSize) ) module: 'crtdll.dll'! ! !NativeBoostWin32 class methodsFor: 'library loading' stamp: 'IgorStasenko 11/24/2012 16:17'! getProcAddress: hModule procName: lpProcName ^ self nbCallout stdcall; function: #( FARPROC GetProcAddress ( HMODULE hModule, LPCSTR lpProcName ) ) module: #Kernel32 ! ! !NativeBoostWin32 class methodsFor: 'accessing' stamp: 'tbn 11/11/2012 00:47'! squeakWindowHandle "This is slow, but efficient" ^(self loadFunction: 'stWindow' from: '') nbUInt32AtOffset: 0 ! ! !NativeCodeTests methodsFor: 'tests' stamp: 'Igor.Stasenko 4/30/2010 20:03'! testProxyFunctions | functions | functions := NBInterpreterProxy functions. functions valuesDo: [:fn | self assert: (NBInterpreterProxy canUnderstand: fn selector ). ]! ! !NativeCodeTests methodsFor: 'tests' stamp: 'IgorStasenko 8/5/2011 08:24'! testMovableStuff "test that if native code calls a VM function which triggers a full gc and relocates a native code, it will survive the move, a native code should return a difference between old and new primitive method, in case if its moved, the difference will be nonzero" | code | code := self createMoveTestCode. " we should not crash here ;) " ^ (1 to: 10) collect: [:each| Array new: (Random new nextInt: 100). self install: code into: (self class methodDict at: #movableStub). self movableStub ] ! ! !NativeCodeTests methodsFor: 'private' stamp: 'Igor.Stasenko 4/11/2010 18:21'! movableStub ^ 999! ! !NativeCodeTests methodsFor: 'private' stamp: 'IgorStasenko 8/5/2011 08:22'! createMoveTestCode ^ NBFFICallout new anonSpec: #( int ()); cdecl; generate: [:gen :proxy :asm | | methodOop | methodOop := gen reserveTemp. proxy primitiveMethod. asm mov: asm EAX to: methodOop. "call fullGC to trigger memory compaction" proxy fullGC. "return the difference between old primitiveMethod oop value and new one" proxy primitiveMethod. asm sub: asm EAX with: methodOop. ].! ! !NativeCodeTests methodsFor: 'tests' stamp: 'IgorStasenko 3/27/2012 18:20'! testArgumentOffsets "cdecl arguments placed in reverse order, push c; push b; push a.. so, c is most closer to stack frame and having smallest offset. " NBNativeFunctionGen cdecl: #( int (byte a, void * b, double c) ) emit: [:gen | | arg | arg := gen arg: #a. self assert: (arg isMem). self assert: (arg displacement value = 8). arg := gen arg: #b. self assert: (arg isMem). self assert: (arg displacement value = 12). arg := gen arg: #c. self assert: (arg isMem). self assert: (arg displacement value = 16). ]! ! !NativeCodeTests methodsFor: 'private' stamp: 'Igor.Stasenko 5/2/2010 10:56'! install: nativeCode into: method | trailer newMethod | trailer := CompiledMethodTrailer new. trailer nativeCode: nativeCode platformId: NativeBoost platformId sourcePointer: method trailer sourcePointer. newMethod := method copyWithTrailerBytes: trailer. method methodClass methodDict at: method selector put: newMethod. ! ! !NativeCodeTests class methodsFor: 'accessing' stamp: 'CiprianTeodorov 5/19/2013 03:46'! resources ^{NBTestResources}! ! !NaturalLanguageTranslator commentStamp: 'HilaireFernandes 5/13/2010 11:48'! A NaturalLanguageTranslator is a dummy translator. The localization framework is found in the gettext package. ! !NaturalLanguageTranslator class methodsFor: 'cleanup' stamp: 'MarcusDenker 4/22/2011 10:34'! cleanUp AllKnownPhrases := nil! ! !NaturalLanguageTranslator class methodsFor: 'translate' stamp: 'HilaireFernandes 5/13/2010 11:43'! translate: aString toLocale: localeID ^ aString! ! !NaturalLanguageTranslator class methodsFor: 'translate' stamp: 'HilaireFernandes 5/13/2010 11:43'! translate: aString ^ aString! ! !Nautilus commentStamp: ''! I'm a new browser based on RPackage and Announcements with fancy goodies: - groups ( you can create groups with your favorite classes) - multi-selections - environments - iconic buttons - hierarchy - pragma based menus! !Nautilus methodsFor: 'browser compatibility' stamp: 'BenjaminVanRyseghem 4/6/2012 17:44'! spawnHierarchyForClass: aClass selector: aSelector self setClass: aClass selector: aSelector. self spawnHierarchy! ! !Nautilus methodsFor: 'accessing' stamp: ''! plugins ^ plugins ifNil: [ plugins := OrderedCollection new ]! ! !Nautilus methodsFor: 'accessing' stamp: 'SebastianTleye 4/23/2013 13:12'! packagesWithoutExtensions ^ self browsedEnvironment packagesWithoutExtensions asArray! ! !Nautilus methodsFor: 'accessing' stamp: ''! selectedMethod ^ selectedMethod! ! !Nautilus methodsFor: 'accessing' stamp: ''! showCategories: aBoolean showCategories := aBoolean. self announcer announce: ( NautilusShowCategoriesChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'accessing' stamp: ''! uiClass: aClass uiClass := aClass! ! !Nautilus methodsFor: 'browser compatibility' stamp: 'MarcusDenker 10/24/2013 11:19'! labelString ^ self ui ifNil: [ 'Nautilus' ] ifNotNil: [:theui | theui title ]! ! !Nautilus methodsFor: 'announcement' stamp: ''! announce: anAnnouncement self announcer announce: anAnnouncement ! ! !Nautilus methodsFor: 'initialization' stamp: ''! initialize super initialize. plugins := OrderedCollection new. self class pluginClasses do: [:each || class position | class := each first. position := each second. plugins add: ((class model: self) position: position; yourself)]! ! !Nautilus methodsFor: 'private' stamp: ''! classesInTheSelectedPackage ^ self selectedPackage ifNil: [{}] ifNotNil: [:package | (package definedClasses asArray sort: [:a :b | a name <= b name]), (package extendedClasses asArray sort: [:a :b | a name <= b name])]! ! !Nautilus methodsFor: 'accessing' stamp: ''! showCategories ^ showCategories ifNil: [ showCategories := true ]! ! !Nautilus methodsFor: 'private' stamp: ''! packagesUsedByTheSelectedClass | result class | result := OrderedCollection new. class := self selectedClass. class ifNil: [^{}]. result add: class package. result addAll: (self foundExtentionsIn: class). result := result intersection: self packages. ^ result select:[:each | each notNil]! ! !Nautilus methodsFor: 'accessing' stamp: ''! showHierarchy ^ showHierarchy ifNil: [ showHierarchy := self class showHierarchy ]! ! !Nautilus methodsFor: 'browser compatibility' stamp: 'MarcusDenker 3/26/2013 08:19'! spawnHierarchy self showHierarchy: true; open. self ui showPackages: false! ! !Nautilus methodsFor: 'history' stamp: 'BenjaminVanRyseghem 10/18/2013 17:15'! removeFromHistory: aNautilusHistoryEntry self browsingHistory removeEntry: aNautilusHistoryEntry. self triggerEvent: #historyChanged! ! !Nautilus methodsFor: 'accessing' stamp: ''! switchClassesAndPackages ^ self class switchClassesAndPackages! ! !Nautilus methodsFor: 'accessing' stamp: ''! ui ^ ui! ! !Nautilus methodsFor: 'browser compatibility' stamp: ''! codeTextMorph ^ self ui codeTextMorph! ! !Nautilus methodsFor: 'accessing' stamp: ''! selectedGroup ^ selectedGroup! ! !Nautilus methodsFor: 'accessing' stamp: ''! showPackages: aBoolean showPackages := aBoolean. self announcer announce: ( NautilusShowPackagesChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'accessing' stamp: ''! showGroups: aBoolean showGroups := aBoolean. self announcer announce: ( NautilusShowGroupsChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'accessing' stamp: ''! commentPosition ^ self class commentPosition! ! !Nautilus methodsFor: 'history' stamp: ''! historyEntries ^ self browsingHistory entries! ! !Nautilus methodsFor: 'history' stamp: 'BenjaminVanRyseghem 10/18/2013 17:13'! adopt: anAssociation self browsingHistory pauseDuring: [ anAssociation key applyTo: self ]! ! !Nautilus methodsFor: 'accessing' stamp: ''! showPackages ^ showPackages ifNil: [ showPackages := true ]! ! !Nautilus methodsFor: 'accessing' stamp: ''! uiClass ^ uiClass ifNil: [ self defaultUIClass ]! ! !Nautilus methodsFor: 'accessing' stamp: ''! browsingHistory ^ browsingHistory ifNil: [ browsingHistory := NavigationHistory new ]! ! !Nautilus methodsFor: 'history' stamp: ''! hasPrevious ^self browsingHistory hasPrevious! ! !Nautilus methodsFor: 'accessing' stamp: ''! selectedPackage: anObject selectedPackage := anObject. self announcer announce: ( NautilusPackageSelected package: anObject )! ! !Nautilus methodsFor: 'displaying' stamp: 'BenjaminVanRyseghem 9/14/2012 14:38'! open ui := (self uiClass on: self) open. self announce: (WindowOpened new window: ui window)! ! !Nautilus methodsFor: 'history' stamp: 'CamilloBruni 10/4/2012 11:30'! previous self browsingHistory pauseDuring: [ self adopt: self browsingHistory previous. self triggerEvent: #historyChanged ]! ! !Nautilus methodsFor: 'history' stamp: 'BenjaminVanRyseghem 10/18/2013 17:28'! removeLastHistoryEntry self browsingHistory removeLastEntry. self triggerEvent: #historyChanged! ! !Nautilus methodsFor: 'history' stamp: 'NicolaiHess 1/11/2014 00:21'! registerHistoryNewEntry | lastEntry wrapper | self browsingHistory isPaused ifTrue: [ ^ self ]. wrapper := NautilusHistoryEntry with: self. self browsingHistory entries ifNotEmpty: [ :entries | lastEntry := entries last key. ( lastEntry selectedClass isNil or: [ ( wrapper selectedClass notNil and: [ wrapper selectedMethod = lastEntry selectedMethod and: [ wrapper selectedClass theNonMetaClass = lastEntry selectedClass theNonMetaClass ] ] ) ] ) ifTrue: [ ^ self ] ]. self browsingHistory add: wrapper. self triggerEvent: #historyChanged.! ! !Nautilus methodsFor: 'accessing' stamp: ''! showGroups ^ showGroups ifNil: [ showGroups := self shouldOpenOnGroups ]! ! !Nautilus methodsFor: 'displaying' stamp: ''! defaultUIClass ^ NautilusUI! ! !Nautilus methodsFor: 'displaying' stamp: 'CamilloBruni 9/21/2012 13:46'! close ui close! ! !Nautilus methodsFor: 'accessing' stamp: ''! selectedCategory ^ selectedCategory! ! !Nautilus methodsFor: 'history' stamp: 'CamilloBruni 10/4/2012 11:31'! next self browsingHistory pauseDuring: [ self adopt: self browsingHistory next. self triggerEvent: #historyChanged ].! ! !Nautilus methodsFor: 'accessing' stamp: ''! showComment ^ showComment ifNil: [ showComment := false ]! ! !Nautilus methodsFor: 'accessing' stamp: ''! showComment: aBoolean showComment := aBoolean. self announcer announce: ( NautilusShowCommentChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'accessing' stamp: 'NicolaiHess 4/7/2014 22:27'! groupsManager ^ self class groupsManager! ! !Nautilus methodsFor: 'accessing' stamp: ''! packages ^ self browsedEnvironment packages asArray! ! !Nautilus methodsFor: 'accessing' stamp: ''! selectedMethod: anObject selectedMethod := anObject. self announcer announce: ( NautilusMethodSelected method: anObject )! ! !Nautilus methodsFor: 'private' stamp: ''! warningLimit ^ self class warningLimit! ! !Nautilus methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 15:49'! parentOfClass: aClass ^ self class parentOfClass: aClass! ! !Nautilus methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/14/2012 15:33'! selectedClass: aClass selectedClass := aClass. self selectedCategory: nil. aClass ifNotNil: [ self recentClasses add: aClass theNonMetaClass name ]. self announcer announce: ( NautilusClassSelected class: aClass )! ! !Nautilus methodsFor: 'browser compatibility' stamp: ''! openEditString: aString " Dunno what to do"! ! !Nautilus methodsFor: 'accessing' stamp: ''! recentClasses ^ self class recentClasses! ! !Nautilus methodsFor: 'accessing' stamp: ''! selectedPackage ^ selectedPackage! ! !Nautilus methodsFor: 'accessing' stamp: ''! browsedEnvironment: anEnvironment browsedEnvironment := anEnvironment! ! !Nautilus methodsFor: 'announcement' stamp: ''! announcer ^ announcer ifNil: [ announcer := NautilusAnnouncer new ]! ! !Nautilus methodsFor: 'accessing' stamp: ''! browsedEnvironment ^ browsedEnvironment ifNil: [ browsedEnvironment := RBBrowserEnvironment new ]! ! !Nautilus methodsFor: 'private' stamp: ''! foundExtentionsIn: aClass ^ aClass extendingPackages. ! ! !Nautilus methodsFor: 'history' stamp: ''! hasNext ^self browsingHistory hasNext! ! !Nautilus methodsFor: 'accessing' stamp: ''! selectedCategory: anObject selectedCategory := anObject. self selectedMethod: nil. self announcer announce: ( NautilusProtocolSelected category: anObject )! ! !Nautilus methodsFor: 'accessing' stamp: ''! selectedClass ^ selectedClass! ! !Nautilus methodsFor: 'accessing' stamp: ''! showHierarchy: aBoolean showHierarchy := aBoolean. self announcer announce: ( NautilusShowHierarchyChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'accessing' stamp: ''! showInstance: aBoolean showInstance := aBoolean. self announcer announce: ( NautilusShowInstanceChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'history' stamp: 'NicolaiHess 1/11/2014 00:21'! package: aPackage class: aClass category: aCategory method: aMethod self selectedPackage: aPackage; selectedClass: aClass; selectedCategory: aCategory; selectedMethod: aMethod. self selectedClass notNil ifTrue:[self registerHistoryNewEntry ]! ! !Nautilus methodsFor: 'accessing' stamp: ''! classes ^ self browsedEnvironment classes! ! !Nautilus methodsFor: 'accessing' stamp: ''! showInstance ^ showInstance ifNil: [ showInstance := true ]! ! !Nautilus methodsFor: 'comparing' stamp: ''! = aNautilus self class = aNautilus class ifFalse: [ ^ false ]. 1 to: self class instVarNames size do: [:index | (self instVarAt: index) = (aNautilus instVarAt: index) ifFalse: [ ^ false ]]. ^ true! ! !Nautilus methodsFor: 'browser compatibility' stamp: 'EstebanLorenzano 10/9/2013 16:20'! setClass: aClass selector: aSelector | method protocol | method := aClass methodDict at: aSelector ifAbsent: [ nil ]. protocol := method ifNil: [ nil ] ifNotNil: [ method protocol ]. self showGroups: false; selectedPackage: (self parentOfClass: aClass); selectedClass: aClass; showInstance: aClass isMeta not; selectedCategory: protocol; selectedMethod: method ! ! !Nautilus methodsFor: 'private' stamp: 'NicolaiHess 4/7/2014 22:27'! shouldOpenOnGroups ^ self class openOnGroups and: [ (self class groupsManager) isEmpty not ]! ! !Nautilus methodsFor: 'browser compatibility' stamp: ''! contents: aText self ui sourceCode: aText! ! !Nautilus methodsFor: 'accessing' stamp: ''! selectedGroup: anObject selectedGroup := anObject. self announcer announce: ( NautilusGroupSelected group: anObject ).! ! !Nautilus class methodsFor: 'browser compatibility' stamp: 'BernardoContreras 7/17/2012 21:20'! newOnClass: aClass selector: aSelector ^ self fullOnClass: aClass selector: aSelector ! ! !Nautilus class methodsFor: 'opening' stamp: ''! openOnMethod: aMethod ^ self openOnMethod: aMethod inEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'accessing' stamp: ''! pluginClasses ^ PluginClasses ifNil: [ PluginClasses := OrderedCollection new ].! ! !Nautilus class methodsFor: 'accessing' stamp: ''! maxSize: anInteger maxSize := anInteger. self recentClasses maxSize: anInteger.! ! !Nautilus class methodsFor: 'opening' stamp: 'BenjaminVanRyseghem 5/13/2012 17:36'! openOnCategory: aCategory ofClass: aClass inEnvironment: anEnvironment | instance | instance := self new. instance browsedEnvironment: anEnvironment. instance showInstance: aClass isMeta not. instance showGroups: false. instance package: aClass package class: aClass category: aCategory method: nil. instance open. ^ instance! ! !Nautilus class methodsFor: 'opening' stamp: 'BenjaminVanRyseghem 6/26/2012 23:57'! openOnClass: aClass onProtocol: aProtocol ^ self openOnClass: aClass onProtocol: aProtocol inEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'accessing' stamp: ''! showHierarchy ^ ShowHierarchy ifNil: [ ShowHierarchy := true ]! ! !Nautilus class methodsFor: 'private' stamp: ''! defaultBrowsedEnvironment ^ RBBrowserEnvironment new! ! !Nautilus class methodsFor: 'opening' stamp: ''! openOnPackage: selectedPackage class: selectedClass category: selectedCategory method: selectedMethod group: selectedGroup showGroups: showGroups showHierarchy: showHierarchy showPackages: showPackages showComment: showComment showInstance: showInstance showCategories: showCategories inEnvironment: anEnvironment | instance | instance := self new. instance browsedEnvironment: anEnvironment. instance package: selectedPackage class: selectedClass category: selectedCategory method: selectedMethod. instance selectedGroup: selectedGroup. instance showGroups: showGroups; showHierarchy: showHierarchy; showComment: showComment; showInstance: showInstance; showCategories: showCategories. instance open. instance ui showPackages: showPackages. instance ui forceSelection: selectedCategory. instance ui forceSelection: selectedMethod. ^ instance! ! !Nautilus class methodsFor: 'opening' stamp: 'CamilloBruni 9/14/2012 01:06'! openOnPackage: aPackage inEnvironment: anEnvironment | instance | instance := self new. instance browsedEnvironment: anEnvironment. instance showGroups: false. instance selectedPackage: aPackage. instance open. instance ui showPackages: true. ^ instance! ! !Nautilus class methodsFor: 'settings' stamp: ''! switchClassesAndPackages ^ SwitchClassesAndPackages ifNil: [ SwitchClassesAndPackages := false ]! ! !Nautilus class methodsFor: 'opening' stamp: ''! openOnPackage: aPackage ^ self openOnPackage: aPackage inEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'accessing' stamp: ''! openOnGroups ^ OpenOnGroups ifNil: [ OpenOnGroups := false ]! ! !Nautilus class methodsFor: 'accessing' stamp: ''! historyMaxSize ^ HistoryMaxSize ifNil: [ HistoryMaxSize := self defaultMaxSize ]! ! !Nautilus class methodsFor: 'browser compatibility' stamp: 'BenjaminVanRyseghem 2/15/2013 01:47'! fullOnClass: class selector: selector highlight: autoSelectString | nautilus | nautilus := self fullOnClass: class selector: selector. autoSelectString ifNotNil: [ nautilus ui highlight: autoSelectString ]! ! !Nautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/4/2013 17:47'! emptyCommentWarning ^emptyCommentWarning ifNil: [ emptyCommentWarning := true ]! ! !Nautilus class methodsFor: 'accessing' stamp: ''! showAnnotationPane: aBoolean ShowAnnotationPane := aBoolean! ! !Nautilus class methodsFor: 'browser compatibility' stamp: 'BenjaminVanRyseghem 4/19/2012 13:08'! openBrowser self open.! ! !Nautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/6/2013 14:27'! useOldStyleKeys: aBoolean useOldStyleKeys := aBoolean! ! !Nautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/4/2013 17:53'! emptyCommentWarning:aBoolean emptyCommentWarning := aBoolean. AbstractNautilusUI resetClassesIconsCache! ! !Nautilus class methodsFor: 'settings' stamp: ''! commentPosition ^ CommentPosition ifNil: [ self defaultCommentPosition ]! ! !Nautilus class methodsFor: 'accessing' stamp: 'StephaneDucasse 11/30/2013 13:56'! resetGroups groups := nil.! ! !Nautilus class methodsFor: 'events' stamp: 'CamilleTeruel 7/29/2012 18:46'! stopNotifications " self stopNotifications " SystemAnnouncer uniqueInstance unsubscribe: self! ! !Nautilus class methodsFor: 'cleanup' stamp: 'md 4/15/2014 16:47'! cleanUp AbstractNautilusUI resetIconCaches. RecentClasses := nil. ! ! !Nautilus class methodsFor: 'private' stamp: ''! defaultCommentPosition ^ #right! ! !Nautilus class methodsFor: 'opening' stamp: ''! openOnPackage: selectedPackage class: selectedClass category: selectedCategory method: selectedMethod group: selectedGroup showGroups: showGroups showHierarchy: showHierarchy showPackages: showPackages showComment: showComment showInstance: showInstance showCategories: showCategories ^ self openOnPackage: selectedPackage class: selectedClass category: selectedCategory method: selectedMethod group: selectedGroup showGroups: showGroups showHierarchy: showHierarchy showPackages: showPackages showComment: showComment showInstance: showInstance showCategories: showCategories inEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'opening' stamp: ''! open ^ self openInEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'opening' stamp: ''! openOnCategory: aCategory ofClass: aClass ^ self openOnCategory: aCategory ofClass: aClass inEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'icon' stamp: ''! icon ^ AbstractNautilusUI icon! ! !Nautilus class methodsFor: 'opening' stamp: 'CamilloBruni 10/4/2012 10:50'! openOnClass: aClass onProtocol: aProtocol inEnvironment: anEnvironment | instance | instance := self new. instance browsedEnvironment: anEnvironment; showInstance: aClass isMeta not; selectedCategory: aProtocol; package: aClass package class: aClass category: nil method: nil; open. instance ui showPackages: (self switchClassesAndPackages not). instance ui selectedCategory: aProtocol; categorySelectionChanged; changed: #currentHistoryIndex. ^ instance! ! !Nautilus class methodsFor: 'opening' stamp: 'EstebanLorenzano 10/14/2013 17:32'! openOnMethod: aMethod inEnvironment: anEnvironment | instance class | class := aMethod methodClass. instance := self new. instance browsedEnvironment: anEnvironment; showInstance: class isMeta not; showGroups: false; package: (self parentOfClass: class) class: class category: aMethod protocol asString method: aMethod; open. instance ui showPackages: (self switchClassesAndPackages not); giveFocusToMethod. ^ instance! ! !Nautilus class methodsFor: 'browser compatibility' stamp: ''! fullOnClass: aClass ^ self openOnClass: aClass! ! !Nautilus class methodsFor: 'opening' stamp: 'CamilloBruni 9/14/2012 02:10'! openInEnvironment: anEnvironment | instance | instance := self new. instance browsedEnvironment: anEnvironment; open. instance ui showPackages: (self switchClassesAndPackages not). ^ instance! ! !Nautilus class methodsFor: 'system startup' stamp: 'MarcusDenker 10/16/2013 14:32'! shutDown self cleanUp! ! !Nautilus class methodsFor: 'private' stamp: ''! defaultMaxSize ^ NavigationHistory defaultMaxSize! ! !Nautilus class methodsFor: 'accessing' stamp: ''! historyMaxSize: anInteger (anInteger isKindOf: Integer) ifFalse: [ ^ self ]. anInteger > 0 ifFalse: [ ^ self ]. HistoryMaxSize := anInteger! ! !Nautilus class methodsFor: 'settings' stamp: 'BenjaminVanRyseghem 2/5/2013 14:35'! populateMethodList ^ populateMethodList ifNil: [ populateMethodList := self defaultPopulateMethodList ]! ! !Nautilus class methodsFor: 'accessing' stamp: 'NicolaiHess 4/7/2014 22:29'! groupsManager ^ groups ifNil: [ groups := self buildGroupManager ]! ! !Nautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/6/2013 14:31'! nautilusSettingsOn: aBuilder (aBuilder group: #Nautilus) target: self; label: 'Nautilus' translated; description: 'Settings related to the browser' translated; with: [ (aBuilder setting: #openOnGroups) label: 'Open the browser on groups ?' translated; description: 'If true, Nautilus will show groups when opened' translated. (aBuilder pickOne: #commentPosition) label: 'Position of the comment pane:' translated; target: self; default: self defaultCommentPosition; order: 1; domainValues: self commentPositions. (aBuilder setting: #showHierarchy) label: 'Show hierarchy by default ?' translated; description: 'If false, Nautilus will show a flat list of classes' translated. (aBuilder setting: #historyMaxSize) label: 'Set the max size of the navigation history' translated; description: ('By default, the value is ', self defaultMaxSize printString) translated. (aBuilder setting: #switchClassesAndPackages) label: 'Switch lists when opening on a class ?' translated; description: 'Default value: false' translated. (aBuilder setting: #warningLimit) label: 'Set the warning limit of source code pane' translated; description: 'By default, the value is 350 Put a negative value to disable' translated. (aBuilder setting: #emptyCommentWarning) label: 'Enable/disable warning for empty comments' translated; description: 'Enable/disable the warning for empty comments. CAUTION!! To have comments in your classes is highly recomended' translated. (aBuilder setting: #populateMethodList) label: 'Populate the method list at opening ?' translated; default: self defaultPopulateMethodList; description: 'If true, the browser may be a bit slower to open on big classes. If false, you will need an extra click to access a method' translated. (aBuilder setting: #useOldStyleKeys) label: 'Use old style keys ?' translated; description: 'If true, the browser will use the old style keys (This is highly non-recommended, you will lose a lot of cool access keys)' translated. ]! ! !Nautilus class methodsFor: 'private' stamp: 'NicolaiHess 4/7/2014 22:26'! buildGroupManager | holder | holder := GroupHolder new. (holder addADynamicClassGroupSilentlyNamed: 'Most Viewed Classes' block: [ self recentClassesElements ]) removable: false. (holder addADynamicClassGroupSilentlyNamed: 'Last Modified Classes' block: [ self lastModifiedClasses ]) removable: false. (holder addADynamicGroupSilentlyNamed: 'Work' block: [ {} ]) removable: true; isFillable: true. ^ holder ! ! !Nautilus class methodsFor: 'groups' stamp: 'md 4/15/2014 16:47'! lastModifiedClasses ^ RecentMessageList uniqueInstance lastClasses: 10! ! !Nautilus class methodsFor: 'accessing' stamp: ''! warningLimit ^ WarningLimit ifNil: [ WarningLimit := 350 ]! ! !Nautilus class methodsFor: 'opening' stamp: ''! openOnClass: aClass onGroup: aGroup inEnvironment: anEnvironment | instance | instance := self new. instance browsedEnvironment: anEnvironment. instance showInstance: aClass isMeta not. instance showGroups: true. instance selectedGroup: aGroup. instance package: aClass package class: aClass category: nil method: nil. instance open. ^ instance! ! !Nautilus class methodsFor: 'browser compatibility' stamp: ''! newOnClass: aClass ^ self fullOnClass: aClass! ! !Nautilus class methodsFor: 'accessing' stamp: ''! maxSize ^ maxSize ifNil: [ maxSize := 10]! ! !Nautilus class methodsFor: 'class initialization' stamp: 'MarcusDenker 5/5/2013 09:27'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #browser ! ! !Nautilus class methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 15:48'! parentOfClass: aClass ^ aClass package! ! !Nautilus class methodsFor: 'browser compatibility' stamp: ''! openBrowserView: aNautilus label: aString aNautilus open. aNautilus ui selectedMethod: aNautilus selectedMethod. aNautilus ui update. aNautilus ui title: aString! ! !Nautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/6/2013 14:03'! useOldStyleKeys ^useOldStyleKeys ifNil: [ useOldStyleKeys := false ]! ! !Nautilus class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/5/2013 14:35'! defaultPopulateMethodList ^ false! ! !Nautilus class methodsFor: 'accessing' stamp: ''! recentClasses ^ RecentClasses ifNil: [ RecentClasses := HistoryCollection maxSize: self maxSize ]! ! !Nautilus class methodsFor: 'opening' stamp: ''! openOnClass: aClass onGroup: aGroup ^ self openOnClass: aClass onGroup: aGroup inEnvironment: self defaultBrowsedEnvironment.! ! !Nautilus class methodsFor: 'opening' stamp: ''! openOnClass: aClass ^ self openOnClass: aClass inEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'instance creation' stamp: ''! browsedEnvironment: anEnvironment ^ self new browsedEnvironment: anEnvironment! ! !Nautilus class methodsFor: 'settings' stamp: 'BenjaminVanRyseghem 2/5/2013 14:34'! populateMethodList: aBoolean populateMethodList := aBoolean! ! !Nautilus class methodsFor: 'opening' stamp: 'EstebanLorenzano 10/14/2013 15:49'! openOnClass: aClass inEnvironment: anEnvironment | instance | instance := self new. instance browsedEnvironment: anEnvironment; showInstance: aClass isMeta not; showGroups: false; package: (self parentOfClass: aClass) class: aClass category: nil method: nil; open. instance ui showPackages: (self switchClassesAndPackages not); giveFocusToProtocol. ^ instance! ! !Nautilus class methodsFor: 'browser compatibility' stamp: 'NicolaiHess 12/11/2013 11:24'! fullOnClass: aClass selector: aSelector ^ aSelector ifNil: [ self openOnClass: aClass ] ifNotNil: [| method | method := aClass methodDict at: aSelector ifAbsent: [ ^ self openOnClass:aClass ]. method ifNotNil: [ self openOnMethod: method ]]! ! !Nautilus class methodsFor: 'accessing' stamp: ''! pluginClasses: aCollection PluginClasses := aCollection! ! !Nautilus class methodsFor: 'icon' stamp: ''! taskbarIcon ^ AbstractNautilusUI icon! ! !Nautilus class methodsFor: 'accessing' stamp: ''! showHierarchy: aBoolean ShowHierarchy := aBoolean! ! !Nautilus class methodsFor: 'opening' stamp: ''! openOnGroup: aGroup inEnvironment: anEnvironment | instance | instance := self new. instance browsedEnvironment: anEnvironment. instance showGroups: true. instance selectedGroup: aGroup. instance open. ^ instance! ! !Nautilus class methodsFor: 'accessing' stamp: ''! openOnGroups:aBoolean OpenOnGroups := aBoolean! ! !Nautilus class methodsFor: 'private' stamp: ''! defaultAnnotationInfo "see annotationRequests comment" ^ #(timeStamp messageCategory sendersCount implementorsCount allChangeSets)! ! !Nautilus class methodsFor: 'settings' stamp: ''! switchClassesAndPackages: aBoolean SwitchClassesAndPackages := aBoolean! ! !Nautilus class methodsFor: 'settings' stamp: ''! commentPositions ^ { #right. #bottom. #left. #top }! ! !Nautilus class methodsFor: 'opening' stamp: ''! openOnGroup: aGroup ^ self openOnGroup: aGroup inEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'settings' stamp: ''! commentPosition: aSymbol (self commentPositions includes: aSymbol) ifFalse: [ ^ self ]. CommentPosition := aSymbol! ! !Nautilus class methodsFor: 'browser compatibility' stamp: ''! fullOnEnvironment: anEnvironment self openInEnvironment: anEnvironment! ! !Nautilus class methodsFor: 'private' stamp: 'NicolaiHess 4/7/2014 22:26'! recentClassesElements ^ self recentClasses mostViewedElements collect: [ :nm | Smalltalk at: nm ifAbsent: [nil] ] thenSelect: [ :e | e notNil ]! ! !Nautilus class methodsFor: 'accessing' stamp: ''! warningLimit: anInteger WarningLimit := anInteger! ! !NautilusAnnouncer commentStamp: ''! an Announcer dedicated to Nautilus relative announcements! !NautilusBooleanAnnouncement commentStamp: ''! Announcement raised when a boolean value changed! !NautilusBooleanAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/12/2011 11:21'! boolean: anObject boolean := anObject! ! !NautilusBooleanAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/12/2011 11:21'! boolean ^ boolean! ! !NautilusBooleanAnnouncement class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/12/2011 11:21'! boolean: aBoolean ^ self new boolean: aBoolean! ! !NautilusBreadcrumbsPlugin commentStamp: ''! A NautilusBreadcrumbsPlugin is a plugin which add breadcrumbs (for Igor ;) ) ! !NautilusBreadcrumbsPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 3/9/2012 21:22'! registerTo: aModel aModel announcer on: NautilusPackageSelected send: #packageSelected: to: self; on: NautilusGroupSelected send: #groupSelected: to: self; on: NautilusClassSelected send: #classSelected: to: self; on: NautilusProtocolSelected send: #protocolSelected: to: self; on: NautilusMethodSelected send: #methodSelected: to: self; on: NautilusShowGroupsChanged send: #showGroupsChanged: to: self.! ! !NautilusBreadcrumbsPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/13/2012 17:16'! packageSelected: anAnnouncement | package | package := anAnnouncement package. packageButton ifNotNil: [ container removeMorph: packageButton ]. container removeMorph: self hFill. packageButton := PluggableButtonMorph new model: self; getMenuSelector: #packageMenu:; actionBlock: [:evt | evt shiftPressed ifTrue: [ Nautilus openOnPackage: package ] ifFalse: [ model ui selectedClass: nil; selectedPackage: package ]]. packageButton label: package name; height: 25. (package isNil or: [ model showGroups ]) ifFalse: [ container addMorph: packageButton ]. container addMorph: self hFill.! ! !NautilusBreadcrumbsPlugin methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 5/13/2012 17:09'! classMenu: aMenu ^ self model ui menu2: aMenu shifted: false. ! ! !NautilusBreadcrumbsPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/13/2012 17:09'! classSelected: anAnnouncement | class | class := anAnnouncement itemClass. classButton ifNotNil: [ container removeMorph: classButton ]. container removeMorph: self hFill. classButton := PluggableButtonMorph new model: self; getMenuSelector: #classMenu:; actionBlock: [:evt | evt shiftPressed ifTrue: [ class browse ] ifFalse: [ model ui selectedClass: class ]]. classButton label: class name; height: 25. class ifNotNil: [ container addMorph: classButton ]. container addMorph: self hFill.! ! !NautilusBreadcrumbsPlugin methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 5/13/2012 17:31'! methodMenu: aMenu ^ self model ui methodWidget elementsMenu: aMenu shifted: false.! ! !NautilusBreadcrumbsPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/9/2012 21:34'! display ^ container! ! !NautilusBreadcrumbsPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/13/2012 17:15'! groupSelected: anAnnouncement | group | group := anAnnouncement group. groupButton ifNotNil: [ container removeMorph: groupButton ]. container removeMorph: self hFill. groupButton := PluggableButtonMorph new model: self; getMenuSelector: #groupMenu:; actionBlock: [:evt | evt shiftPressed ifTrue: [ Nautilus openOnGroup: group ] ifFalse: [ model ui selectedGroup: group ]]. groupButton label: group name; height: 25. group ifNotNil: [ container addMorph: groupButton ]. container addMorph: self hFill! ! !NautilusBreadcrumbsPlugin methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:05'! initialize super initialize. classButton := nil. container := PanelMorph new changeTableLayout; listDirection: #rightToLeft; hResizing: #spaceFill; vResizing: #rigid; addMorph: self hFill; height: 25. methodButton := nil. packageButton := nil. protocolButton := nil.! ! !NautilusBreadcrumbsPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 3/9/2012 22:11'! showGroupsChanged: anAnnouncement container removeMorph: self hFill. model showGroups ifTrue: [ groupButton ifNotNil: [ container addMorph: groupButton behind: packageButton ]. packageButton ifNotNil: [ container removeMorph: packageButton ]] ifFalse: [ packageButton ifNotNil: [ container addMorph: packageButton behind: groupButton ]. groupButton ifNotNil: [ container removeMorph: groupButton ]]. container addMorph: self hFill.! ! !NautilusBreadcrumbsPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/13/2012 17:35'! protocolSelected: anAnnouncement | protocol | protocol := anAnnouncement category. protocolButton ifNotNil: [ container removeMorph: protocolButton ]. container removeMorph: self hFill. protocolButton := PluggableButtonMorph new model: self; getMenuSelector: #protocolMenu:; actionBlock: [:evt | evt shiftPressed ifTrue: [ Nautilus openOnCategory: protocol ofClass: self model selectedClass ] ifFalse: [ model ui selectedCategory: protocol. model ui update ]]. protocolButton label: protocol asString; height: 25. protocol ifNotNil: [ container addMorph: protocolButton ]. container addMorph: self hFill.! ! !NautilusBreadcrumbsPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/13/2012 17:30'! methodSelected: anAnnouncement | method | method := anAnnouncement method. methodButton ifNotNil: [ container removeMorph: methodButton ]. container removeMorph: self hFill. methodButton := PluggableButtonMorph new model: self; getMenuSelector: #methodMenu:; actionBlock: [ model ui selectedMethod: method ]. method ifNotNil: [ methodButton label: method selector asString; height: 25. container addMorph: methodButton ]. container addMorph: self hFill.! ! !NautilusBreadcrumbsPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/9/2012 21:48'! resetContainer container removeAllMorphs! ! !NautilusBreadcrumbsPlugin methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 5/13/2012 17:15'! groupMenu: aMenu ^ self model ui menu: aMenu shifted: false. ! ! !NautilusBreadcrumbsPlugin methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 5/13/2012 17:16'! packageMenu: aMenu ^ self model ui menu: aMenu shifted: false. ! ! !NautilusBreadcrumbsPlugin methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 5/13/2012 17:32'! protocolMenu: aMenu ^ self model ui categoryWidget categoriesMenu: aMenu shifted: false.! ! !NautilusBreadcrumbsPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/9/2012 21:46'! hFill ^ hFill ifNil: [ hFill := Morph new height: 0; width: 2; hResizing: #spaceFill; vResizing: #rigid; yourself ].! ! !NautilusBreadcrumbsPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 5/3/2012 09:36'! description ^ 'DO NOT WORK IN PHARO 1.4 Breadcrumbs for Nautilus. I hope Igor will like it ;)'! ! !NautilusBreadcrumbsPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 5/2/2012 13:16'! pluginName ^ 'BreadCrumbs'! ! !NautilusBreadcrumbsPlugin class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 3/9/2012 21:40'! defaultPosition ^ #middle! ! !NautilusChanged commentStamp: ''! A NautilusChanged is raised when a NautilusUI send th message #changed:! !NautilusChanged methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/13/2012 21:34'! symbol ^ symbol! ! !NautilusChanged methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/13/2012 21:34'! symbol: anObject symbol := anObject! ! !NautilusChanged class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/13/2012 21:34'! symbol: symbol ^ self new symbol: symbol; yourself! ! !NautilusClassSelected commentStamp: ''! A NautilusClassSelected is raised when a class is selected! !NautilusClassSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 14:45'! class: anObject class := anObject! ! !NautilusClassSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 14:47'! itemClass ^ class! ! !NautilusClassSelected class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/10/2011 14:48'! class: aClass ^ self new class: aClass! ! !NautilusGroupSelected commentStamp: ''! A NautilusGroupSelected is raised when a group is selected! !NautilusGroupSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 14:46'! group: anObject group := anObject! ! !NautilusGroupSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 14:46'! group ^ group! ! !NautilusGroupSelected class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/10/2011 14:48'! group: aGroup ^ self new group: aGroup! ! !NautilusHelp commentStamp: ''! I am a page of the Help book related to Nautilus! !NautilusHelp class methodsFor: 'accessing' stamp: 'SeanDeNigris 2/6/2013 14:42'! bookName ^ 'Nautilus'.! ! !NautilusHelp class methodsFor: 'accessing' stamp: 'SeanDeNigris 2/6/2013 14:46'! pages ^ #(contextMenus). ! ! !NautilusHelp class methodsFor: 'menus' stamp: 'SeanDeNigris 2/6/2013 14:51'! contextMenus ^ HelpTopic title: 'Adding to context menus' contents: 'On the class-side of your object, create a method that: 1. takes one argument (a PragmaMenuAndShortcutRegistration). 2. Begins with the pragma for whichever menu you want to extend (see AbstractNautilusUI "menu pragmas" protocol) For example, to extend the menu for the method list pane: methodMenu: aBuilder To see existing examples in your image, browse senders of that pragma'! ! !NautilusHistoryEntry commentStamp: ''! I am a history entry which hold a single step of the Nautilus browsing history! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! selectedCategory ^ selectedCategory! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showComment: anObject showComment := anObject! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! selectedMethod ^ selectedMethod! ! !NautilusHistoryEntry methodsFor: 'protocol' stamp: 'NicolaiHess 12/26/2013 12:22'! applyTo: aNautilus aNautilus ui ifNotNil: [ :interface | interface resetSelections]. aNautilus selectedPackage: self selectedPackage; selectedClass: self selectedClass; selectedCategory: self selectedCategory. self selectedMethod ifNil: [ aNautilus selectedMethod: nil ] ifNotNil: [:sel | aNautilus selectedMethod: (self selectedClass methodDict at: sel ifAbsent: [ nil ])]. aNautilus browsingHistory pauseDuring: [ aNautilus selectedGroup: self selectedGroup; showPackages: self showPackages; showGroups: self showGroups; showHierarchy: self showHierarchy; showComment: self showComment; showInstance: self showInstance; showCategories: self showCategories. ]. aNautilus ui ifNotNil: [:interface || cl | cl := self selectedClass. interface showPackages: aNautilus showPackages. cl ifNil: [ interface showInstance: false ] ifNotNil: [ interface showInstance: cl isMeta not]. interface selectedPackageWithoutChangingSelectionInternally: self selectedPackage; selectedClassWithoutChangingSelectionInternally: cl; selectedCategoryInternally: self selectedCategory. interface updateBothView. self selectedMethod ifNil: [ interface selectedMethod: nil ] ifNotNil: [:sel | interface selectedMethod: (cl compiledMethodAt: sel ifAbsent: [ nil ])]. interface update ].! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showCategories: anObject showCategories := anObject! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showComment ^ showComment! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! selectedMethod: anObject selectedMethod := anObject! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showCategories ^ showCategories! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! selectedClass: anObject selectedClass := anObject! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showHierarchy ^ showHierarchy! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! selectedPackage ^ selectedPackage! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! selectedClass ^ selectedClass! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! selectedCategory: anObject selectedCategory := anObject! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! selectedGroup ^ selectedGroup! ! !NautilusHistoryEntry methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! asHistoryString | label separator | separator := ' >>#'. self showGroups ifTrue: [ label := Text streamContents: [:s | self selectedGroup ifNotNil: [:g | s << ('G: ' asText addAttribute: TextEmphasis italic from: 1 to: 3) << (g name asText addAttribute: TextEmphasis italic from: 1 to: g name size). self selectedClass ifNotNil: [:c | s << separator << c name. self selectedMethod ifNotNil: [:m | s << separator << m asString ]]]]] ifFalse: [ label := String streamContents: [:s | self selectedPackage ifNotNil: [:p | self selectedClass ifNotNil: [:c | s << c name. self selectedMethod ifNotNil: [:m | s << separator << m asString ]]]]]. ^ label! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showHierarchy: anObject showHierarchy := anObject! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showGroups: anObject showGroups := anObject! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showInstance: anObject showInstance := anObject! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showPackages: anObject showPackages := anObject! ! !NautilusHistoryEntry methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! with: aNautilus self selectedPackage: aNautilus selectedPackage; selectedCategory: aNautilus selectedCategory. aNautilus selectedMethod ifNil: [ self selectedMethod: nil ] ifNotNil: [:met | self selectedMethod: met selector]. self selectedClass: aNautilus selectedClass; selectedGroup: aNautilus selectedGroup; showPackages: aNautilus showPackages; showGroups: aNautilus showGroups; showHierarchy: aNautilus showHierarchy; showComment: aNautilus showComment; showInstance: aNautilus showInstance; showCategories: aNautilus showCategories.! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showPackages ^ showPackages! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showInstance ^ showInstance! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! selectedPackage: anObject selectedPackage := anObject! ! !NautilusHistoryEntry methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! = anotherWrapper self species = anotherWrapper species ifFalse: [ ^ false ]. ^ self selectedPackage = anotherWrapper selectedPackage and: [ self selectedGroup = anotherWrapper selectedGroup and: [ self selectedClass = anotherWrapper selectedClass and: [ self selectedCategory = anotherWrapper selectedCategory and: [ self selectedMethod = anotherWrapper selectedMethod and: [ self showPackages = anotherWrapper showPackages and: [ self showInstance = anotherWrapper showInstance and: [ self showGroups = anotherWrapper showGroups and: [ self showHierarchy = anotherWrapper showHierarchy and: [ self showComment = anotherWrapper showComment and:[ self showCategories = anotherWrapper showCategories ]]]]]]]]]]! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! selectedGroup: anObject selectedGroup := anObject! ! !NautilusHistoryEntry methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! showGroups ^ showGroups! ! !NautilusHistoryEntry class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 10/18/2013 17:32'! with: aNautilus ^ self new with: aNautilus; yourself! ! !NautilusHistoryEntryWithSourceCode commentStamp: ''! I am a special wrapper used to store in the history unsaved source code! !NautilusHistoryEntryWithSourceCode methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/18/2013 17:33'! applyTo: aNautilus super applyTo: aNautilus. aNautilus ui ifNotNil: [ :interface | interface pendingText: self sourceCode ]. aNautilus removeFromHistory: self! ! !NautilusHistoryEntryWithSourceCode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:33'! sourceCode ^ sourceCode ifNil: [ '' ]! ! !NautilusHistoryEntryWithSourceCode methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/18/2013 17:33'! asHistoryString ^ '*', super asHistoryString! ! !NautilusHistoryEntryWithSourceCode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:33'! sourceCode: anObject sourceCode := anObject! ! !NautilusHistoryEntryWithSourceCode class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 10/18/2013 17:33'! with: aNautilus sourceCode: sourceCode ^ self new with: aNautilus; sourceCode: sourceCode; yourself! ! !NautilusKeyPressed commentStamp: ''! A NautilusKeyPressed is raised each time a key is pressed on a Nautilus ui! !NautilusKeyPressed methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:16'! key ^ key! ! !NautilusKeyPressed methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:16'! key: anObject key := anObject! ! !NautilusKeyPressed class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 5/10/2011 12:26'! key: aKey ^ self new key: aKey! ! !NautilusMethodSelected commentStamp: ''! A NautilusMethodSelected is raised each time a mehod is selected! !NautilusMethodSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 14:45'! method ^ method! ! !NautilusMethodSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 14:45'! method: anObject method := anObject! ! !NautilusMethodSelected class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/10/2011 14:49'! method: aMethod ^ self new method: aMethod! ! !NautilusMonticello commentStamp: ''! A NautilusMonticello is a class used to handle monticello integration into Nautilus by creating the menu entries! !NautilusMonticello methodsFor: 'monticello menus behavior' stamp: ''! addRepositoryTo: aGroup | repo | (repo := self newRepository) ifNil: [ ^ self ]. aGroup addRepository: repo.! ! !NautilusMonticello methodsFor: 'display' stamp: ''! viewChanges: patch from: fromDescription to: toDescription in: workingCopy "Open a browser on the given patch." PSMCPatchMorph usedByDefault ifTrue: [((PSMCPatchMorph forPatch: patch) fromDescription: fromDescription; toDescription: toDescription; newWindow) title: ('Changes to {1}' translated format: {fromDescription}); open] ifFalse: [(MCPatchBrowser forPatch: patch) label: 'Patch Browser: ', workingCopy description; show]! ! !NautilusMonticello methodsFor: 'monticello menus behavior' stamp: 'SeanDeNigris 6/21/2012 09:10'! viewChangesFor: mcpackage in: repo | workingCopy patch | workingCopy := mcpackage workingCopy. 'Finding changes' displayProgressFrom: 0 to: 10 during:[:bar| bar current: 1. patch := workingCopy changesRelativeToRepository: repo. bar current: 3. patch isEmpty ifTrue: [ workingCopy modified: false. bar current: 10. self inform: 'No changes' ] ifFalse: [ workingCopy modified: true. bar current: 5. self viewChanges: patch from: workingCopy packageName, ' (', workingCopy ancestry ancestorString, ')' to: ('Modified {1}' translated format: {workingCopy description}) in: workingCopy ]]! ! !NautilusMonticello methodsFor: 'monticello menus behavior' stamp: ''! newRepository | types index | types := MCRepository allConcreteSubclasses asArray. index := UIManager default chooseFrom: (types collect: [:ea | ea description]) title: 'Repository type:'. ^ index = 0 ifFalse: [(types at: index) morphicConfigure]! ! !NautilusMonticello methodsFor: 'monticello menus behavior' stamp: 'EstebanLorenzano 9/8/2013 11:02'! commit: workingCopy in: aRepository | newVersion | newVersion := workingCopy newVersionIn: aRepository. newVersion ifNil: [ ^ self ]. Cursor wait showWhile: [ [ aRepository storeVersion: newVersion. aRepository storeDependencies: newVersion ] ensure: [ (MCVersionInspector new version: newVersion) show ]]! ! !NautilusMonticello methodsFor: 'monticello menus behavior' stamp: ''! open: mcpackage in: repo | workingCopy | repo ifNil: [ ^ self ]. workingCopy := mcpackage workingCopy. repo morphicOpen: workingCopy! ! !NautilusMonticello methodsFor: 'monticello menus behavior' stamp: ''! createMCPackageFor: aPackage | name | name := aPackage name. name isEmptyOrNil ifFalse: [ MCWorkingCopy forPackage: (MCPackage new name: name) ]! ! !NautilusMonticello class methodsFor: 'monticello menus' stamp: 'EstebanLorenzano 4/14/2014 18:06'! packagesOpenMenu: aBuilder | package mcpackage target last group | target := aBuilder model. (package := target selectedPackage) ifNil: [ ^ target ]. mcpackage := package correspondingMcPackage. mcpackage ifNil: [ ^ self ]. (aBuilder item: #('Open ',package name)) label: 'Open...'; order: 1297; help: 'Open'; icon: (Smalltalk ui icons iconNamed: #monticelloPackageIcon); enabledBlock: [ target selectedPackages size < 2 ]. (group := mcpackage workingCopy repositoryGroup) repositories doWithIndex: [:repo : index | last := (aBuilder item: ('Repo',index printString)) label: repo description; parent: #('Open ',package name); order: index; action: [ self default open: mcpackage in: repo ]]. last withSeparatorAfter. (aBuilder item: 'Add a repository') parent: #('Open ',package name); order: 99; action: [ self default addRepositoryTo: group ]! ! !NautilusMonticello class methodsFor: 'singleton' stamp: ''! default ^ Default ifNil: [ Default := self basicNew initialize ]! ! !NautilusMonticello class methodsFor: 'instance creation' stamp: 'ChristopheDemarey 7/12/2013 17:34'! new ^ self default! ! !NautilusMonticello class methodsFor: 'monticello menus' stamp: 'EstebanLorenzano 4/14/2014 18:06'! packagesChangesMenu: aBuilder | package mcpackage target | target := aBuilder model. (package := target selectedPackage) ifNil: [ ^ target ]. mcpackage := package correspondingMcPackage. mcpackage ifNil: [ ^ self ]. mcpackage isDirty ifTrue: [ (aBuilder item: #('Changes with ',package name)) label: 'Changes with...'; order: 1295; help: 'Changes'; icon: (Smalltalk ui icons iconNamed: #monticelloPackageIcon); enabledBlock: [ target selectedPackages size < 2 ]. mcpackage workingCopy repositoryGroup repositories doWithIndex: [:repo : index | (aBuilder item: ('Repo',index printString)) label: repo description; parent: #('Changes with ',package name); order: index; action: [ self default viewChangesFor: mcpackage in: repo ]]]! ! !NautilusMonticello class methodsFor: 'monticello menus' stamp: 'EstebanLorenzano 4/14/2014 17:38'! packagesCreateMenu: aBuilder | package mcpackage target | target := aBuilder model. (package := target selectedPackage) ifNil: [ ^ target ]. mcpackage := package correspondingMcPackage. mcpackage ifNotNil: [ ^ self ]. (aBuilder item: #'Create a MC package') order: 1297; help: 'Create a MC package corresponding to my name'; icon: (Smalltalk ui icons iconNamed: #monticelloPackageIcon); action: [ self default createMCPackageFor: target selectedPackage ]; enabledBlock: [ target selectedPackages size < 2 ].! ! !NautilusMonticello class methodsFor: 'monticello menus' stamp: 'EstebanLorenzano 4/14/2014 18:06'! packagesCommitsMenu: aBuilder | package mcpackage target | target := aBuilder model. (package := target selectedPackage) ifNil: [ ^ target ]. mcpackage := package correspondingMcPackage. mcpackage ifNil: [ ^self ]. mcpackage isDirty ifTrue: [ | last group | (aBuilder item: #('Commit in ',package name)) label: 'Commit in...'; order: 1296; help: 'Commit'; icon: (Smalltalk ui icons iconNamed: #monticelloPackageIcon); enabledBlock: [ target selectedPackages size < 2 ]. (group := mcpackage workingCopy repositoryGroup) repositories doWithIndex: [:repo : index | last := ((aBuilder item: ('Repo',index printString)) label: repo description; parent: #('Commit in ',package name); order: index; action: [ self default commit: mcpackage workingCopy in: repo ])]. last withSeparatorAfter. (aBuilder item: 'Add a repository') parent: #('Commit in ',package name); order: 99; action: [ self default addRepositoryTo: group ]]! ! !NautilusPackageSelected commentStamp: ''! A NautilusPackageSelected is raised when a package is selected! !NautilusPackageSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:15'! package: anObject package := anObject! ! !NautilusPackageSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:15'! package ^ package! ! !NautilusPackageSelected class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/10/2011 12:28'! package: aPackage ^ self new package: aPackage! ! !NautilusPluginManager commentStamp: ''! NautilusPluginManager is a manger of plugins used to set up plugin for Nautilus UI! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 13:25'! resetPluginClassesListSelection pluginClassesSelected removeAll! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 8/25/2011 14:19'! buildPluginClassesList | list | list := PluggableListMorph on: self list: #getPluginClassesList primarySelection: #pluginClassesSelectedIndex changePrimarySelection: #pluginClassesSelectedIndex: listSelection: #pluginClassesSelectedAt: changeListSelection: #pluginClassesSelectedAt:put: menu: nil keystroke: nil. list wrapSelector: #pluginName. list resetListSelector: #resetPluginClassesListSelection. list autoDeselect: true. list vResizing: #spaceFill; hResizing: #spaceFill. ^ list! ! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginClassesSelected ^ pluginClassesSelected! ! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginsList ^ pluginsList! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 2/17/2012 16:32'! pluginClassesSelectedIndex: anInteger pluginClassesSelectedIndex := anInteger. self changed: #pluginClassesSelectedIndex. self changed: #getText.! ! !NautilusPluginManager methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 8/25/2011 13:50'! pluginsSelectedIndex: anIndex! ! !NautilusPluginManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/11/2011 15:57'! centering self left: ((World width / 2) - (self width /2)). self top: ((World height / 2) - (self height /2))! ! !NautilusPluginManager methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/11/2011 15:49'! buildPluginClassesBox ^ GroupboxMorph new addContentMorph: self buildPluginClassesList; addContentMorph: self buildAddButton; label: 'Available plugin classes:'; hResizing: #spaceFill; vResizing: #spaceFill.! ! !NautilusPluginManager methodsFor: 'display' stamp: 'BenjaminVanRyseghem 2/17/2012 16:34'! newContentMorph | row column | row := PanelMorph new layoutPolicy: TableLayout new; listDirection: #leftToRight; vResizing: #spaceFill; hResizing: #spaceFill; spaceFillWeight: 3; addMorph: self buildButtonsColumn; addMorph: self buildPluginsBox; addMorph: self buildPluginClassesBox. column := PanelMorph new layoutPolicy: TableLayout new; listDirection: #topToBottom; vResizing: #spaceFill; hResizing: #spaceFill; addMorph: self buildDescriptionTextArea; addMorph: row. ^ column! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'EstebanLorenzano 5/15/2013 11:15'! buildUpButton ^ IconicButton new target: self; actionSelector: #up; labelGraphic: (Smalltalk ui icons iconNamed: #upIcon); color: Color transparent; extent: 24 @ 24; borderWidth: 0! ! !NautilusPluginManager methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/11/2011 15:49'! buildPluginsBox ^ GroupboxMorph new addContentMorph: self buildPluginsList; addContentMorph: self buildRemoveButton; label: 'Selected plugins:'; hResizing: #spaceFill; vResizing: #spaceFill.! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 5/2/2012 13:18'! getPluginClassesList ^ AbstractNautilusPlugin allSubclasses sort: [:a :b | a pluginName <= b pluginName ]! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'ChristopheDemarey 8/29/2013 17:26'! buildFullDownButton ^ IconicButton new target: self; actionSelector: #fullDown; labelGraphic: (Smalltalk ui icons iconNamed: #bottomIcon); color: Color transparent; extent: 24 @ 24; borderWidth: 0! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 11:24'! pluginClassesSelectedAt: anIndex | object | object := self getPluginClassesList at: anIndex ifAbsent: [ ^ false ]. ^ pluginClassesSelected at: object ifAbsent: [ false ]! ! !NautilusPluginManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/25/2011 13:51'! fullDown | list selection | list := pluginsList copy. selection := self selectedPlugins. selection doWithIndex: [:idx :count || each | each := list at: idx. pluginsList removeAt: idx-count+1. pluginsList addLast: each]. self changed: #getPluginsList. self changed: #allSelections.! ! !NautilusPluginManager methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 5/11/2011 13:39'! initialize super initialize. pluginClassesSelected := Dictionary new. pluginsSelected := Dictionary new.! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'EstebanLorenzano 5/15/2013 11:15'! buildDownButton ^ IconicButton new target: self; actionSelector: #down; labelGraphic: (Smalltalk ui icons iconNamed: #downIcon); color: Color transparent; extent: 24 @ 24; borderWidth: 0! ! !NautilusPluginManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/25/2011 11:11'! treeClass ^ NautilusPluginManagerTree! ! !NautilusPluginManager methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/11/2011 11:28'! title ^ 'Nautilus Plugins Manager'! ! !NautilusPluginManager methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/25/2011 12:54'! addButtonAction self selectedPluginClasses do: [:each | self pluginsList addLast: { each. each defaultPosition } ]. tree update: #rootNodes! ! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginsSelected: anObject pluginsSelected := anObject! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'ChristopheDemarey 8/29/2013 17:26'! buildFullUpButton ^ IconicButton new target: self; actionSelector: #fullUp; labelGraphic: (Smalltalk ui icons iconNamed: #topIcon); color: Color transparent; extent: 24 @ 24; borderWidth: 0! ! !NautilusPluginManager methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 15:47'! addButtonLabel ^ 'Add'! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 11:25'! pluginClassesSelectedAt: anIndex put: aBoolean | object | object := self getPluginClassesList at: anIndex ifAbsent: [ ^ self ]. ^ pluginClassesSelected at: object put: aBoolean! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 8/25/2011 12:48'! getPluginsList ^ pluginsList ifNil: [ pluginsList := Nautilus pluginClasses copy ].! ! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginsSelected ^ pluginsSelected! ! !NautilusPluginManager methodsFor: 'text area behavior' stamp: 'BenjaminVanRyseghem 2/17/2012 16:31'! getText | item | item := self getPluginClassesList at: self pluginClassesSelectedIndex ifAbsent: [ ^ nil ]. ^ item ifNil: [ '' ] ifNotNil: [ item description ]! ! !NautilusPluginManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/25/2011 13:52'! up | list selection firstIndex | list := pluginsList copy. firstIndex := pluginsList size. selection := self selectedPlugins. selection do: [:index || each newIndex | each := list at: index. firstIndex := index-1 min: firstIndex. newIndex := index-1 max: 1. pluginsList removeAt: index. pluginsList add: each beforeIndex: newIndex . ]. self pluginsSelectedIndex: firstIndex. self changed: #getPluginsList. self changed: #allSelections.! ! !NautilusPluginManager methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/11/2011 15:57'! openInWorld super openInWorld. self width: 500. self height: 400. self centering! ! !NautilusPluginManager methodsFor: 'buttons behavior' stamp: 'MarcusDenker 9/27/2013 18:06'! removeButtonAction self selectedPlugins reverse do: [:item | self pluginsList remove: item ]. self resetPluginsListSelection. tree deselectAll. tree model setSelection: nil. tree update: #rootNodes! ! !NautilusPluginManager methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 15:50'! addButtonState ^ self selectedPluginClasses isEmpty not! ! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginClassesSelected: anObject pluginClassesSelected := anObject! ! !NautilusPluginManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/25/2011 13:51'! down | list selection firstIndex maxSize | list := pluginsList copy. maxSize := pluginsList size. firstIndex := maxSize. selection := self selectedPlugins. selection reverse do: [:index || each newIndex | each := list at: index. firstIndex := index+1 min: firstIndex. newIndex := index+1 min: maxSize. pluginsList removeAt: index. pluginsList add: each beforeIndex: newIndex . "set selection" ]. self pluginsSelectedIndex: firstIndex. self changed: #getPluginsList. self changed: #allSelections.! ! !NautilusPluginManager methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 15:47'! removeButtonLabel ^ 'Remove'! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 13:33'! resetPluginsListSelection pluginsSelected removeAll! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 5/11/2011 15:42'! buildAddButton ^ (PluggableButtonMorph on: self getState: #addButtonState action: #addButtonAction label: #addButtonLabel) hResizing: #spaceFill; vResizing: #shrinkWrap! ! !NautilusPluginManager methodsFor: 'private' stamp: 'MarcusDenker 9/27/2013 18:04'! fullUp | list selection | list := pluginsList copy. selection := self selectedPlugins. selection reverse doWithIndex: [:idx :count || each | each := list at: idx. pluginsList removeAt: (idx+count-1). pluginsList addFirst: each]. self changed: #getPluginsList. self changed: #allSelections.! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'MarcusDenker 9/27/2013 18:02'! buildButtonsColumn | column | column := PanelMorph new. column changeTableLayout; listDirection: #topToBottom. { self buildFullUpButton. self buildUpButton. self buildDownButton. self buildFullDownButton} reverse do: [:each | column addMorph: each ]. column vResizing: #spaceFill; width: 24; hResizing: #rigid. ^ column! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 8/25/2011 12:51'! buildPluginsList tree := (self treeClass model: self) buildPluginsTree. tree vResizing: #spaceFill; hResizing: #spaceFill. ^ tree buildContents! ! !NautilusPluginManager methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 15:49'! removeButtonState ^ self selectedPlugins isEmpty not! ! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginsList: anObject pluginsList := anObject! ! !NautilusPluginManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/11/2011 13:45'! isResizeable ^true! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 11:23'! pluginClassesSelectedIndex ^ pluginClassesSelectedIndex ifNil: [ pluginClassesSelectedIndex := 0 ]! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 8/25/2011 13:55'! selectedPlugins ^ tree selectedMorphList collect:[:each | each complexContents item ]! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 5/11/2011 15:42'! buildRemoveButton ^ (PluggableButtonMorph on: self getState: #removeButtonState action: #removeButtonAction label: #removeButtonLabel) hResizing: #spaceFill; vResizing: #shrinkWrap! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 15:56'! selectedPluginClasses | associations list | list := self getPluginClassesList. pluginClassesSelected ifNil: [ ^ {} ]. associations := pluginClassesSelected associations select: [:assoc | assoc value ]. associations := associations collect: [:assoc | assoc key ]. associations := associations sort: [:a : b | (list indexOf: a ifAbsent: [ 0 ]) <= (list indexOf: b ifAbsent: [ 0 ])]. ^ associations select: [:each | each notNil ]! ! !NautilusPluginManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/11/2011 15:56'! applyChanges Nautilus pluginClasses: self pluginsList! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 2/17/2012 16:32'! buildDescriptionTextArea ^ (PluggableTextMorph on: self text: #getText accept: nil) enabled: false; vResizing: #spaceFill; hResizing: #spaceFill; yourself! ! !NautilusPluginManagerTree commentStamp: ''! A NautilusPluginManagerTree is a tree which is used to render the plugins selection! !NautilusPluginManagerTree methodsFor: 't - accessing' stamp: 'AlainPlantec 10/17/2013 12:15'! update self updateList! ! !NautilusPluginManagerTree methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/25/2011 11:09'! model ^ model! ! !NautilusPluginManagerTree methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 8/25/2011 10:44'! rootNodeClassFromItem: anItem ^ PluginTreeNode! ! !NautilusPluginManagerTree methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/25/2011 11:09'! model: anObject model := anObject! ! !NautilusPluginManagerTree methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 8/25/2011 12:49'! rootItems ^ self model getPluginsList! ! !NautilusPluginManagerTree methodsFor: 'building' stamp: 'BenjaminVanRyseghem 2/8/2012 17:30'! buildPluginsTree | tree | tree := IdentityMorphTreeMorph on: self. tree listManager: (IdentityMorphTreeListManager new client: tree); columns: { MorphTreeColumn new startWidth: 100; rowMorphGetSelector: #firstMorph; headerButtonLabel: 'Plugin name' font: nil. MorphTreeColumn new startWidth: 75; rowMorphGetSelector: #secondMorph; headerButtonLabel: 'Position' font: nil}; withHLines: true; beMultiple; autoDeselection: false; rowInset: 4; columnInset: 4; getMenuSelector: #menu:shifted:; rowColorForEven: Color lightGray muchLighter odd: Color white. ^ tree! ! !NautilusPluginManagerTree class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 8/25/2011 11:10'! model: aModel ^ self new model: aModel! ! !NautilusProtocolSelected commentStamp: ''! A NautilusCategorySelected is raised when a category is selected! !NautilusProtocolSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 17:16'! category ^ category! ! !NautilusProtocolSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 17:16'! category: anObject category := anObject! ! !NautilusProtocolSelected class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/10/2011 17:17'! category: anObject ^ self new category: anObject! ! !NautilusRefactoring commentStamp: ''! NautilusRefactoring is a facade for refactorings: - class - method - inst var - class var - source code! !NautilusRefactoring methodsFor: 'undo-redo' stamp: ''! undoLabel | stream | stream := WriteStream with: 'Undo'. self changeManager hasUndoableOperations ifFalse: [ ^ stream contents ]. stream nextPut: $ ; nextPutAll: self changeManager undoChange name. stream position > 40 ifTrue: [ stream position: 40; nextPutAll: '...' ]. ^ stream contents! ! !NautilusRefactoring methodsFor: 'method' stamp: ''! renameMethodFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateRenameMethodFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'source' stamp: ''! extractToTemporaryBetween: anInterval from: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateExtractToTemporaryBetween: anInterval from: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'private-source' stamp: ''! privateCreateCascadeBetween: aSelection from: aMethod ^ RBCreateCascadeRefactoring model: environment combine: aSelection from: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'undo-redo' stamp: ''! redoOperation self changeManager redoOperation! ! !NautilusRefactoring methodsFor: 'display' stamp: ''! request: aString initialAnswer: aTemplateString ^ UIManager default request: aString initialAnswer: aTemplateString ! ! !NautilusRefactoring methodsFor: 'method' stamp: ''! pullUpMethodsFor: aCollection | refactoring | aCollection ifEmpty: [ ^ self ]. refactoring := self privatePullUpMethodsFor: aCollection. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'performing' stamp: 'CamilloBruni 10/8/2012 18:27'! performRefactorings: aCollectionRefactoring [[[ self internalPerformRefactorings: aCollectionRefactoring ] on: RBRefactoringFailure do: [ :exception | self handleFailure: exception ]] on: RBRefactoringWarning do: [ :exception | self handleWarning: exception ]] on: RBRefactoringError do: [ :exception | self handleError: exception ]! ! !NautilusRefactoring methodsFor: 'class' stamp: ''! buildRenameRefactoringEngineFor: aClass | newName | newName := (UIManager default request: 'Enter the new class name:' initialAnswer: aClass name). newName isEmptyOrNil ifTrue: [ ^ nil ]. ^ RBRenameClassRefactoring model: RBNamespace new rename: aClass to: newName! ! !NautilusRefactoring methodsFor: 'private-class var' stamp: ''! privateAddClassVarFrom: aClass | name | name := (self request: 'Enter the new variable name:' initialAnswer: 'Var'). ^ RBAddClassVariableRefactoring model: environment variable: name class: aClass theNonMetaClass! ! !NautilusRefactoring methodsFor: 'source' stamp: 'BenjaminVanRyseghem 6/26/2012 21:21'! renameTemporaryNamed: oldname Between: anInterval from: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateRenameTemporaryNamed: oldname Between: anInterval from: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'inst var' stamp: ''! pullUpInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privatePullUpInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method' stamp: ''! pushDownMethodsFor: aCollection | refactoring | aCollection ifEmpty: [ ^ self ]. refactoring := self privatePushDownMethodsFor: aCollection. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! protocolRegexText ^ 'RBProtocolRegexRefactoring new replace: ''^\*system(.*)$'' with: ''*kernel$1'' ignoreCase: true; yourself'! ! !NautilusRefactoring methodsFor: 'display' stamp: 'BenjaminVanRyseghem 1/24/2013 13:58'! chooseMultipleFrom: anArray title: aString | window | window := TickDialogWindow itemsList: anArray itemsHeaderName: '' wrapBlockOrSelector: [:e | e ] title: aString defaultValue: true. ^ anArray isEmpty ifTrue: [ anArray copyEmpty ] ifFalse: [ window chooseFromOwner: self model window ]! ! !NautilusRefactoring methodsFor: 'private-method' stamp: 'SebastianTleye 8/2/2013 10:41'! privateRemoveParameterMethodFor: aMethod | arguments parameter | arguments := aMethod argumentNames ifEmpty: [ ^ nil ]. parameter := (UIManager default chooseFrom: arguments) ifNil: [ ^ nil ]. ^ RBRemoveParameterRefactoring model: environment removeParameter: (arguments at: parameter ifAbsent: [ ^ nil ]) in: aMethod origin selector: aMethod selector! ! !NautilusRefactoring methodsFor: 'inst var' stamp: ''! removeInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateRemoveInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'private-source' stamp: ''! privateExtractToComponentBetween: anInterval from: aMethod ^ RBExtractMethodToComponentRefactoring model: environment extract: anInterval from: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'option' stamp: ''! requestSelfArgumentName ^ self request: 'Enter name for argument to refer to "self" in extracted method'! ! !NautilusRefactoring methodsFor: 'private-source' stamp: ''! privateInlineTemporaryBetween: anInterval from: aMethod ^ RBInlineTemporaryRefactoring model: environment inline: anInterval from: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! searchCodeText ^ 'RBParseTreeSearcher new matches: ''`@object'' do: [ :node :answer | node ]; matchesMethod: ''`@method: `@args | `@temps | `@.statements'' do: [ :node :answer | node ]; yourself'! ! !NautilusRefactoring methodsFor: 'private-method' stamp: 'MarcusDenker 4/21/2013 18:43'! privateRenameMethodFor: aMethod | class selector oldMethodName newMethodName oldArguments argumentPermutation | class := aMethod methodClass. selector := aMethod selector. oldArguments := aMethod argumentNames. oldMethodName := RBMethodName selector: selector arguments: oldArguments. (newMethodName := self requestMethodNameFor: oldMethodName) ifNil: [ ^ nil ]. argumentPermutation := newMethodName arguments collect: [ :each | oldArguments indexOf: each ]. ^ RBRenameMethodRefactoring model: environment renameMethod: selector in: class to: newMethodName selector permutation: argumentPermutation! ! !NautilusRefactoring methodsFor: 'private-inst var' stamp: ''! privateAccessorsInstVarFrom: aClass ^ self class: aClass andInstVariable: [ :class :variable | RBCreateAccessorsForVariableRefactoring model: environment variable: variable class: class classVariable: false ]! ! !NautilusRefactoring methodsFor: 'private-source' stamp: ''! privateInlineMethodBetween: anInterval from: aMethod ^ RBInlineMethodRefactoring model: environment inline: anInterval inMethod: aMethod selector forClass: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'method' stamp: ''! moveMethodFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateMoveMethodFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'private-method' stamp: ''! privatePullUpMethodsFor: aCollection | selectors class | selectors := aCollection collect: #selector. class := aCollection first methodClass. (aCollection allSatisfy: [:e | e methodClass == class ]) ifFalse: [ ^ nil ]. ^ RBPullUpMethodRefactoring model: environment pullUp: selectors from: class! ! !NautilusRefactoring methodsFor: 'class' stamp: 'BenjaminVanRyseghem 7/13/2012 16:09'! generateSuperClass "Execute the refactoring of the receiver." | refactoring | refactoring := self privateGenerateSuperClassFor: self model selectedClass theNonMetaClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring.! ! !NautilusRefactoring methodsFor: 'method' stamp: ''! removeParameterFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateRemoveParameterMethodFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'private-inst var' stamp: 'BenjaminVanRyseghem 4/18/2012 16:57'! privateRenameInstVarFrom: aClass ^ self class: aClass andInstVariable: [ :class :variable || name | name := self request: 'Enter the new variable name:' initialAnswer: variable. name ifNil: [ ^ nil ]. RBRenameInstanceVariableRefactoring model: environment rename: variable to: name asSymbol in: class ]! ! !NautilusRefactoring methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/19/2013 13:14'! accessorsInstVarNamed: aVariableName from: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAccessorsInstVarNamed: aVariableName from: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring.! ! !NautilusRefactoring methodsFor: 'option' stamp: 'GuillermoPolito 8/5/2013 16:15'! shouldInlineExpression: aString ^ self confirm: ('Do you want to inline the expression ''<1s>'' in the current method?' expandMacrosWith: aString)! ! !NautilusRefactoring methodsFor: 'private-class var' stamp: ''! privatePullUpClassVarFrom: aClass ^ self class: aClass andClassVariable: [ :class :variable | RBPullUpClassVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! typeClassTextFor: aCollectionOfClass ^ String streamContents: [:s | aCollectionOfClass do: [:class | s << (RBRefactoryTyper new runOn: class) printString. s cr; cr ]]! ! !NautilusRefactoring methodsFor: 'class var' stamp: ''! addClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAddClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'class var' stamp: ''! renameClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateRenameClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! classRegex self model sourceCode: self classRegexText! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! searchCode self model sourceCode: self searchCodeText! ! !NautilusRefactoring methodsFor: 'private-inst var' stamp: 'BenjaminVanRyseghem 4/18/2012 16:57'! privateRenameInstVarNamed: variable from: aClass | name | name := self request: 'Enter the new variable name:' initialAnswer: variable. name ifNil: [ ^ nil ]. ^ RBRenameInstanceVariableRefactoring model: environment rename: variable to: name asSymbol in: aClass! ! !NautilusRefactoring methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/18/2012 17:11'! changeSuperclassOf: aClass "should be implemented if it really makes sense" self model sourceTextArea flash! ! !NautilusRefactoring methodsFor: 'source' stamp: ''! extractBetween: anInterval from: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateExtractBetween: anInterval from: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'performing' stamp: 'CamilloBruni 10/8/2012 21:59'! internalPerformRefactorings: aCollectionRefactoring "Try to properly label aRefactoring and perform it or open the changes browser, depending on the preferences of the user." self promptOnRefactoring ifFalse: [ aCollectionRefactoring do: [:e | self refactoringOptions: e. e execute ]] ifTrue: [ aCollectionRefactoring do: [:e | self refactoringOptions: e. e primitiveExecute ]. aCollectionRefactoring ifEmpty: [ ^ self ]. (ChangesBrowser changes: aCollectionRefactoring) openWithSpec ].! ! !NautilusRefactoring methodsFor: 'class var' stamp: ''! removeClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateRemoveClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'undo-redo' stamp: ''! redoLabel | stream | stream := WriteStream with: 'Redo'. self changeManager hasRedoableOperations ifFalse: [ ^ stream contents ]. stream nextPut: $ ; nextPutAll: self changeManager redoChange name. stream position > 40 ifTrue: [ stream position: 40; nextPutAll: '...' ]. ^ stream contents! ! !NautilusRefactoring methodsFor: 'display' stamp: ''! handleMethodNameRequest: aMethodName ^ (MethodNameEditor openOn: aMethodName) methodName! ! !NautilusRefactoring methodsFor: 'class' stamp: ''! generateAccessors | refactorings | refactorings := self privateGenerateAccessorsFor: self model selectedClass. refactorings ifNil: [ ^ self ]. refactorings do: [:each | each model environment: self model browsedEnvironment ]. self performRefactorings: refactorings! ! !NautilusRefactoring methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/19/2013 13:12'! privateAccessorsInstVarNamed: aVariableName from: aClass. ^RBCreateAccessorsForVariableRefactoring model: environment variable: aVariableName class: aClass classVariable: false! ! !NautilusRefactoring methodsFor: 'private-class' stamp: ''! privateGenerateSubclassFor: class | subclassName | subclassName := self request: 'Enter new subclass name:'. ^ RBAddClassRefactoring model: environment addClass: subclassName superclass: class subclasses: (self chooseMultipleFrom: class subclasses title: 'Select subclasses of ' , subclassName , ':') category: class category! ! !NautilusRefactoring methodsFor: 'display' stamp: ''! class: aClass andClassVariable: aBlock | variables index variable class | variables := aClass theNonMetaClass allClassVarNames asArray sort. index := UIManager default chooseFrom: variables. variable := variables at: index ifAbsent: [ ^ nil ]. class := aClass theNonMetaClass whichClassDefinesClassVar: variable. ^ aBlock value: class value: variable! ! !NautilusRefactoring methodsFor: 'private-class var' stamp: 'BenjaminVanRyseghem 4/18/2012 16:58'! privateRenameClassVarFrom: aClass ^ self class: aClass andClassVariable: [ :class :variable || name | name := self request: 'Enter the new variable name:' initialAnswer: variable. name ifNil: [ ^ nil ]. RBRenameClassVariableRefactoring model: environment rename: variable to: name asSymbol in: class ]! ! !NautilusRefactoring methodsFor: 'class' stamp: 'BenjaminVanRyseghem 7/13/2012 16:13'! realizeClass | refactoring | refactoring := self privateRealizeClassFor: self model selectedClass theNonMetaClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring ! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! sourceRegexText ^ 'RBSourceRegexRefactoring new "Example 1: Replace symbols with strings" replace: ''#(\w+)'' with: ''''''$1'''''' ignoreCase: false; "Example 2: Replace 4 spaces with tabs" replace: '' '' with: '' '' ignoreCase: false; yourself'! ! !NautilusRefactoring methodsFor: 'source' stamp: ''! moveVariableDefinitionBetween: anInterval from: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateMoveVariableDefinitionBetween: anInterval from: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'private-source' stamp: ''! privateExtractBetween: anInterval from: aMethod ^ RBExtractMethodRefactoring model: environment extract: anInterval from: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'class var' stamp: 'BenjaminVanRyseghem 4/18/2012 16:57'! renameClassVarNamed: aName from: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateRenameClassVarNamed: aName from: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method' stamp: ''! removeMethodsFor: aCollection | refactoring | aCollection ifEmpty: [ ^ self ]. refactoring := self privateRemoveMethodsFor: aCollection. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'display' stamp: ''! request: aString ^ UIManager default request: aString initialAnswer: ''! ! !NautilusRefactoring methodsFor: 'method' stamp: ''! inlineParameterFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateInlineParameterFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'source' stamp: ''! inlineTemporaryBetween: anInterval from: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateInlineTemporaryBetween: anInterval from: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'private-inst var' stamp: 'TorstenBergmann 2/25/2014 10:40'! privateAddInstVarFrom: aClass | name | name := (self request: 'Enter the new variable name:' initialAnswer: 'inst'). name ifNil: [ ^nil ]. ^ RBAddInstanceVariableRefactoring model: environment variable: name class: aClass theNonMetaClass! ! !NautilusRefactoring methodsFor: 'display' stamp: ''! requestMethodNameFor: aMethodName ^ self handleMethodNameRequest: aMethodName! ! !NautilusRefactoring methodsFor: 'inst var' stamp: ''! accessorsInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAccessorsInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: 'DanielUber 10/26/2012 23:39'! typeClass self model sourceCode: (self typeClassTextFor: self model selectedClasses)! ! !NautilusRefactoring methodsFor: 'option' stamp: 'BenjaminVanRyseghem 8/5/2012 21:51'! shouldExtractAssignmentTo: aString ^ self confirm: ('Do you want to extract the assignment of <1s> at the end of selection?' expandMacrosWith: aString)! ! !NautilusRefactoring methodsFor: 'source' stamp: ''! temporaryToInstanceVariableNamed: name Between: anInterval from: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateTemporaryToInstanceVariableNamed: name Between: anInterval from: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'inst var' stamp: ''! abstractInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAbstractInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'accessing' stamp: ''! model ^ model! ! !NautilusRefactoring methodsFor: 'private-method' stamp: ''! privatePushDownMethodsFor: aCollection | selectors class | selectors := aCollection collect: #selector. class := aCollection first methodClass. (aCollection allSatisfy: [:e | e methodClass == class ]) ifFalse: [ ^ nil ]. ^ RBPushDownMethodRefactoring model: environment pushDown: selectors from: class! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: 'BenjaminVanRyseghem 4/16/2013 17:24'! rewriteCode self model rewriteCode: self rewriteCodeText! ! !NautilusRefactoring methodsFor: 'option' stamp: ''! selectVariableToMoveMethodTo: aSelector class: aClass | parseTree nameList | parseTree := aClass parseTreeFor: aSelector. parseTree isNil ifTrue: [ parseTree := RBMethodNode selector: #value body: (RBSequenceNode statements: #()) ]. nameList := OrderedCollection new. nameList addAll: parseTree argumentNames asSortedCollection; addAll: aClass allInstanceVariableNames asSortedCollection. ^ self chooseFrom: nameList title: 'Select variable to move method into:' lines: (Array with: parseTree argumentNames size)! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! protocolRegex self model sourceCode: self protocolRegexText! ! !NautilusRefactoring methodsFor: 'method' stamp: ''! addAParameterFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateAddAParameterFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/22/2013 15:36'! privateAccessorsClassVarNamed: aVariableName from: aClass. ^RBCreateAccessorsForVariableRefactoring model: environment variable: aVariableName class: aClass classVariable: true! ! !NautilusRefactoring methodsFor: 'private-inst var' stamp: 'StephaneDucasse 6/28/2013 10:34'! privatePullUpInstVarFrom: aClass ^ self class: aClass andInstVariable: [ :class :variable | RBPullUpInstanceVariableRefactoring model: environment variable: variable class: class superclass ]! ! !NautilusRefactoring methodsFor: 'private-method' stamp: 'MarcusDenker 4/21/2013 18:39'! privateInlineParameterFor: aMethod | arguments parameter | arguments := aMethod argumentNames ifEmpty: [ ^ nil ]. parameter := (UIManager default chooseFrom: arguments) ifNil: [ ^ nil ]. ^ RBInlineParameterRefactoring model: environment inlineParameter: (arguments at: parameter ifAbsent: [ ^ nil ]) in: aMethod methodClass selector: aMethod selector! ! !NautilusRefactoring methodsFor: 'private-class' stamp: ''! privateSplitClassFor: aClass | class | class := aClass theNonMetaClass. ^ RBSplitClassRefactoring model: environment class: class instanceVariables: (self chooseMultipleFrom: class instVarNames title: 'Select variables to extract:') newClassName: (self request: 'Enter new class name:') referenceVariableName: (self request: 'Enter new variable name where requests will be forwarded:')! ! !NautilusRefactoring methodsFor: 'display' stamp: ''! chooseFrom: anArray title: aString lines: aCollection anArray isEmpty ifTrue: [ ^ nil ]. anArray size = 1 ifTrue: [ ^ anArray first ]. ^ UIManager default chooseOrRequestFrom: anArray lines: aCollection title: aString.! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! sourceRegex self model sourceCode: self sourceRegexText! ! !NautilusRefactoring methodsFor: 'private-class' stamp: ''! privateRealizeClassFor: aClass ^ RBRealizeClassRefactoring model: environment className: aClass theNonMetaClass name! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! classRegexText ^ 'RBClassRegexRefactoring new "Example 1: Change class prefixes" renameClasses; replace: ''^AB(.*)$'' with: ''CD$1'' ignoreCase: false; "Example 2: Generate empty test classes" createClasses; rootClass: TestCase; replace: ''^.*$'' with: ''$0Test'' ignoreCase: false; "Example 3: Copy classes" copyClasses; replace: ''^.*$'' with: ''$0Plus'' ignoreCase: false; yourself'! ! !NautilusRefactoring methodsFor: 'undo-redo' stamp: ''! changeManager ^ RBRefactoryChangeManager instance! ! !NautilusRefactoring methodsFor: 'option' stamp: ''! openEnvironment: anEnvironment for: aRefactoring anEnvironment isEmpty ifTrue: [ ^ self inform: 'Empty scope' ]. Smalltalk tools browser fullOnEnvironment: anEnvironment! ! !NautilusRefactoring methodsFor: 'option' stamp: ''! shouldOverride: aSelector in: aClass ^ self confirm: ('<1s> is already defined in the <2p> hierarchy. Extracting it to an existing selector may change behavior. Do you wish to use <1s> anyway?' expandMacrosWith: aSelector with: aClass)! ! !NautilusRefactoring methodsFor: 'option' stamp: 'EstebanLorenzano 5/14/2013 09:43'! selectVariableTypesFrom: aCollectionOfTypes selected: aSelectedCollection for: aRefactoring | stream result | stream := WriteStream on: String new. aCollectionOfTypes do: [ :each | stream nextPutAll: each name ] separatedBy: [ stream cr ]. result := Smalltalk ui theme textEditorIn: self model window text: 'Select classes to move to: (one class per line)' title: 'Select classes to move to:' entryText: stream contents entryHeight: 300. result ifNil: [ ^ nil ]. ^ (result asString findTokens: String crlf) collect: [ :each | aRefactoring model classFor: (Smalltalk classNamed: each trimBoth) ] ! ! !NautilusRefactoring methodsFor: 'source' stamp: 'BenjaminVanRyseghem 4/18/2012 16:47'! renameTextSelection self model selectedMethod ifNotNil: [ ^ self renameTextSelectionForMethod ]. (self model selectedCategory isNil and: [ self model selectedClass notNil ]) ifTrue: [ " we are editing a class definition " ^ self renameTextSelectionForClass ].! ! !NautilusRefactoring methodsFor: 'private-source' stamp: ''! privateTemporaryToInstanceVariableNamed: name Between: anInterval from: aMethod ^ RBTemporaryToInstanceVariableRefactoring model: environment class: aMethod methodClass selector: aMethod selector variable: name! ! !NautilusRefactoring methodsFor: 'display' stamp: 'CamilloBruni 10/7/2012 23:24'! handleWarning: anException self inform: anException messageText. anException resume.! ! !NautilusRefactoring methodsFor: 'private-method' stamp: 'SebastianTleye 7/31/2013 12:58'! privateAddAParameterFor: aMethod | initializer newSelector initialAnswer oldSelector | oldSelector := aMethod selector. initialAnswer := oldSelector numArgs = 0 ifTrue: [ oldSelector , ':' ] ifFalse: [ oldSelector ]. newSelector := self request: 'Enter new selector:' initialAnswer: initialAnswer. newSelector isEmptyOrNil ifTrue: [ ^ nil ]. initializer := self request: 'Enter default value for parameter:' initialAnswer: 'nil'. initializer isEmpty ifTrue: [ ^ nil ]. ^ RBAddParameterRefactoring model: environment addParameterToMethod: aMethod selector in: aMethod origin newSelector: newSelector asSymbol initializer: initializer ! ! !NautilusRefactoring methodsFor: 'class' stamp: 'BenjaminVanRyseghem 7/13/2012 16:09'! generateSubclass | refactoring | refactoring := self privateGenerateSubclassFor: self model selectedClass theNonMetaClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring ! ! !NautilusRefactoring methodsFor: 'method' stamp: ''! inlineAllSendersFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateInlineAllSendersFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'private-inst var' stamp: ''! privatePushDownInstVarFrom: aClass ^ self class: aClass andInstVariable: [ :class :variable | RBPushDownInstanceVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'inst var' stamp: ''! renameInstVarFrom: aClass | class refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateRenameInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'source' stamp: 'BenjaminVanRyseghem 4/18/2012 17:06'! renameTextSelectionForClass | selectedInterval selection class | class := self model selectedClass. selection := self model sourceTextArea selectedContents asString. selectedInterval := self model sourceTextArea selectionInterval. selectedInterval isEmpty ifTrue: [ ^ self model sourceTextArea flash ]. (selection includes: Character space) ifTrue: [ ^ self model sourceTextArea flash ]. "Try to rename the superclass" selectedInterval first = 1 ifTrue: [ self changeSuperclassOf: class ]. "Rename the selected class" selection = class name ifTrue: [ self renameClass: class ]. "Rename a variable" self renameVariable: selection.! ! !NautilusRefactoring methodsFor: 'source' stamp: ''! extractToComponentBetween: anInterval from: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateExtractToComponentBetween: anInterval from: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'class var' stamp: ''! accessorsClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAccessorsClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'private-class var' stamp: 'BenjaminVanRyseghem 4/18/2012 16:58'! privateRenameClassVarNamed: variable from: aClass | name | name := self request: 'Enter the new variable name:' initialAnswer: variable. name ifNil: [ ^ nil ]. ^ RBRenameClassVariableRefactoring model: environment rename: variable to: name asSymbol in: aClass! ! !NautilusRefactoring methodsFor: 'source' stamp: ''! inlineMethodFromComponentBetween: anInterval from: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateInlineMethodFromComponentBetween: anInterval from: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'source' stamp: ''! inlineMethodBetween: anInterval from: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateInlineMethodBetween: anInterval from: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'private-inst var' stamp: ''! privateAbstractInstVarFrom: aClass ^ self class: aClass andInstVariable: [ :class :variable | RBAbstractInstanceVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'private-class var' stamp: ''! privateAccessorsClassVarFrom: aClass ^ self class: aClass andClassVariable: [ :class :variable | RBCreateAccessorsForVariableRefactoring model: environment variable: variable class: class classVariable: true ]! ! !NautilusRefactoring methodsFor: 'private-method' stamp: ''! privateInlineAllSendersFor: aMethod ^ RBInlineAllSendersRefactoring model: environment sendersOf: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'private-class var' stamp: ''! privatePushDownClassVarFrom: aClass ^ self class: aClass andClassVariable: [ :class :variable | RBPushDownClassVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'source' stamp: 'BenjaminVanRyseghem 4/18/2012 16:57'! renameVariable: aString | class | class := self model selectedClass. (class instVarNames includes: aString) ifTrue: [ ^ self renameInstVarNamed: aString from: class]. (class classVarNames includes: aString) ifTrue: [ ^ self renameClassVarNamed: aString from: class]. self model sourceTextArea flash! ! !NautilusRefactoring methodsFor: 'option' stamp: ''! refactoringOptions: aRefactoring aRefactoring setOption: #implementorToInline toUse: [ :ref :imps | self requestImplementorToInline: imps ]; setOption: #methodName toUse: [ :ref :name | self requestMethodNameFor: name ]; setOption: #selfArgumentName toUse: [ :ref | self requestSelfArgumentName ]; setOption: #selectVariableToMoveTo toUse: [ :ref :class :selector | self selectVariableToMoveMethodTo: selector class: class ]; setOption: #variableTypes toUse: [ :ref :types :selected | self selectVariableTypesFrom: types selected: selected for: ref ]; setOption: #extractAssignment toUse: [ :ref :string | self shouldExtractAssignmentTo: string ]; setOption: #inlineExpression toUse: [ :ref :string | self shouldInlineExpression: string ]; setOption: #alreadyDefined toUse: [ :ref :class :selector | self shouldOverride: selector in: class ]; setOption: #useExistingMethod toUse: [ :ref :selector | self shouldUseExistingMethod: selector ]; setOption: #openBrowser toUse: [ :ref :env | self openEnvironment: env for: ref]! ! !NautilusRefactoring methodsFor: 'display' stamp: 'CamilloBruni 10/8/2012 11:38'! handleError: anException anException actionBlock isNil ifTrue: [ self inform: anException messageText ] ifFalse: [ (self confirm: anException messageText) ifTrue: [ anException actionBlock value ] ]. anException resume! ! !NautilusRefactoring methodsFor: 'accessing' stamp: ''! model: aNautilusUI model := aNautilusUI. environment := (RBNamespace onEnvironment: aNautilusUI browsedEnvironment) name: self printString; yourself.! ! !NautilusRefactoring methodsFor: 'source' stamp: ''! splitCascadeBetween: anInterval from: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateSplitCascadeBetween: anInterval from: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'source' stamp: 'GuillermoPolito 11/7/2013 14:13'! formatSourceCode | textArea | self model ifNil: [ ^ self ]. textArea := self model sourceTextArea. textArea formatSourceCode.! ! !NautilusRefactoring methodsFor: 'inst var' stamp: ''! addInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAddInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'private-method' stamp: ''! privateMoveMethodFor: aMethod | instVars instVar | instVars := aMethod methodClass instVarNames. instVars ifNil: [ ^ nil ]. instVar := UIManager default chooseFrom: instVars. instVar ifNil: [ ^ nil ]. ^ RBMoveMethodRefactoring model: environment selector: aMethod selector class: aMethod methodClass variable: (instVars at: instVar ifAbsent: [ ^ nil ])! ! !NautilusRefactoring methodsFor: 'inst var' stamp: ''! pushDownInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privatePushDownInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method' stamp: ''! swapMethodFor: aCollection | refactorings | aCollection ifEmpty: [ ^ self ]. refactorings := self privateSwapMethodFor: aCollection. refactorings isEmptyOrNil ifTrue: [ ^ self ]. refactorings do: [:e | e model environment: self model browsedEnvironment ]. self performRefactorings: refactorings! ! !NautilusRefactoring methodsFor: 'undo-redo' stamp: ''! undoEnabled ^ self changeManager hasUndoableOperations! ! !NautilusRefactoring methodsFor: 'private-inst var' stamp: ''! privateRemoveInstVarFrom: aClass ^ self class: aClass andInstVariable: [ :class :variable | RBRemoveInstanceVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'private-source' stamp: ''! privateRenameTemporaryNamed: oldname Between: anInterval from: aMethod | name | name := (self request: 'Enter the new variable name:' initialAnswer: oldname). name ifNil: [ ^ nil ]. ^ RBRenameTemporaryRefactoring model: environment renameTemporaryFrom: anInterval to: name in: aMethod methodClass selector: aMethod selector ! ! !NautilusRefactoring methodsFor: 'undo-redo' stamp: ''! redoEnabled ^ self changeManager hasRedoableOperations! ! !NautilusRefactoring methodsFor: 'source' stamp: 'BenjaminVanRyseghem 4/18/2012 17:45'! extractToMethodTextSelection | aMethod selectedInterval textArea | textArea := self model sourceTextArea. aMethod := self model selectedMethod. aMethod ifNil: [ ^ textArea flash ]. textArea selectedContents asString ifEmpty: [ ^ textArea flash ]. selectedInterval := textArea selectionInterval. self extractBetween: selectedInterval from: aMethod! ! !NautilusRefactoring methodsFor: 'private-class' stamp: ''! privateGenerateSuperClassFor: class | superclassName subclasses | superclassName := self request: 'Enter new superclass name:'. superclassName isEmptyOrNil ifTrue: [ ^ self ]. subclasses := self chooseMultipleFrom: class subclasses title: 'Select subclasses of ' , superclassName , ':'. subclasses ifNil: [ ^ self ]. ^ RBChildrenToSiblingsRefactoring model: environment name: superclassName class: class subclasses: subclasses! ! !NautilusRefactoring methodsFor: 'private-source' stamp: ''! privateSplitCascadeBetween: anInterval from: aMethod ^ RBSplitCascadeRefactoring model: environment split: anInterval from: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'class var' stamp: ''! pushDownClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privatePushDownClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'class' stamp: ''! removeClasses: aCollection "Execute the refactoring of the receiver." | refactoring | refactoring := self privateRemoveClassesFor: aCollection. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring. ^ true! ! !NautilusRefactoring methodsFor: 'class' stamp: ''! splitClass: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateSplitClassFor: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'display' stamp: 'StephaneDucasse 5/18/2012 14:54'! shouldUseExistingMethod: aMethodName "for now we always want to use the existing method." ^ true! ! !NautilusRefactoring methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/22/2013 15:37'! accessorsClassVarNamed: aVariableName from: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAccessorsClassVarNamed: aVariableName from: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring.! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! rewriteCodeText ^ 'RBParseTreeRewriter new replace: ''`@object'' with: ''`@object''; replace: ''`@object'' with: ''`@object'' when: [ :node | true ]; replace: ''`@object'' withValueFrom: [ :node | node ]; replace: ''`@object'' withValueFrom: [ :node | node ] when: [ :node | true ]; replaceMethod: ''`@method: `@args | `@temps | `@.statements'' with: ''`@method: `@args | `@temps | `@.statements''; replaceMethod: ''`@method: `@args | `@temps | `@.statements'' with: ''`@method: `@args | `@temps | `@.statements'' when: [ :node | true ]; replaceMethod: ''`@method: `@args | `@temps | `@.statements'' withValueFrom: [ :node | node ]; replaceMethod: ''`@method: `@args | `@temps | `@.statements'' withValueFrom: [ :node | node ] when: [ :node | true ]; yourself'! ! !NautilusRefactoring methodsFor: 'private-method' stamp: 'SebastianTleye 7/31/2013 13:34'! privateRemoveMethodsFor: aCollection | selectors class | selectors := aCollection collect: #selector. class := aCollection first origin. (aCollection allSatisfy: [:e | e origin == class ]) ifFalse: [ ^ nil ]. ^ RBRemoveMethodRefactoring model: environment removeMethods: selectors from: class! ! !NautilusRefactoring methodsFor: 'private-class var' stamp: ''! privateAbstractClassVarFrom: aClass ^ self class: aClass andClassVariable: [ :class :variable | RBAbstractClassVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! categoryRegexText ^ 'RBCategoryRegexRefactoring new replace: ''^Kernel-(.*)$'' with: ''System-$1'' ignoreCase: false; yourself'! ! !NautilusRefactoring methodsFor: 'private-class var' stamp: ''! privateRemoveClassVarFrom: aClass ^ self class: aClass andClassVariable: [ :class :variable | RBRemoveClassVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'option' stamp: ''! promptOnRefactoring ^ self class promptOnRefactoring! ! !NautilusRefactoring methodsFor: 'source' stamp: ''! createCascadeBetween: anInterval from: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateCreateCascadeBetween: anInterval from: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'display' stamp: ''! class: aClass andInstVariable: aBlock | variables index variable class | variables := aClass theNonMetaClass allInstVarNames asArray sort. index := UIManager default chooseFrom: variables. variable := variables at: index ifAbsent: [ ^ nil ]. class := aClass theNonMetaClass whichClassDefinesInstVar: variable. class := class isMeta not ifTrue: [ RBClass existingNamed: class name ] ifFalse: [ RBMetaclass existingNamed: class theNonMetaClass name ]. class model: environment. ^ aBlock value: class value: variable! ! !NautilusRefactoring methodsFor: 'class var' stamp: ''! abstractClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAbstractClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'performing' stamp: ''! performRefactoring: aRefactoring "Try to properly label aRefactoring and perform it or open the changes browser, depending on the preferences of the user." self performRefactorings: {aRefactoring}! ! !NautilusRefactoring methodsFor: 'source' stamp: 'BenjaminVanRyseghem 4/18/2012 17:44'! extractToTempTextSelection | aMethod selectedInterval textArea | textArea := self model sourceTextArea. aMethod := self model selectedMethod. aMethod ifNil: [ ^ textArea flash ]. textArea selectedContents asString ifEmpty: [ ^ textArea flash ]. selectedInterval := textArea selectionInterval. self extractToTemporaryBetween: selectedInterval from: aMethod! ! !NautilusRefactoring methodsFor: 'private-source' stamp: ''! privateMoveVariableDefinitionBetween: anInterval from: aMethod ^ RBMoveVariableDefinitionRefactoring model: environment bindTight: anInterval in: aMethod methodClass selector: aMethod selector! ! !NautilusRefactoring methodsFor: 'undo-redo' stamp: ''! undoOperation self changeManager undoOperation! ! !NautilusRefactoring methodsFor: 'display' stamp: 'CamilloBruni 10/8/2012 11:37'! handleFailure: anException anException actionBlock isNil ifTrue: [ self inform: anException messageText ] ifFalse: [ (self confirm: anException messageText) ifTrue: [ anException actionBlock value ] ]. anException return! ! !NautilusRefactoring methodsFor: 'private-class' stamp: ''! privateRemoveClassesFor: aCollection ^ RBRemoveClassRefactoring model: environment classNames: (aCollection collect: [:e | e theNonMetaClass name ])! ! !NautilusRefactoring methodsFor: 'inst var' stamp: 'BenjaminVanRyseghem 4/18/2012 16:55'! renameInstVarNamed: aName from: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateRenameInstVarNamed: aName from: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'class' stamp: ''! renameClass: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self buildRenameRefactoringEngineFor: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring ! ! !NautilusRefactoring methodsFor: 'class var' stamp: ''! pullUpClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privatePullUpClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'private-source' stamp: ''! privateExtractToTemporaryBetween: anInterval from: aMethod | name | name := (self request: 'Enter the new variable name:'). name ifNil: [ ^ nil ]. ^ RBExtractToTemporaryRefactoring model: environment extract: anInterval to: name from: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'private-class' stamp: ''! privateGenerateAccessorsFor: class ^ class instVarNames collect: [:aVarName | RBCreateAccessorsForVariableRefactoring model: environment variable: aVarName class: class classVariable: false ]! ! !NautilusRefactoring methodsFor: 'display' stamp: ''! chooseMultipleFrom: anArray ^ self chooseMultipleFrom: anArray title: ''! ! !NautilusRefactoring methodsFor: 'private-method' stamp: ''! privateSwapMethodFor: aCollection ^ aCollection collect: [:aMethod | RBSwapMethodRefactoring model: environment swapMethod: aMethod selector in: aMethod methodClass ]! ! !NautilusRefactoring methodsFor: 'source' stamp: 'BenjaminVanRyseghem 4/18/2012 17:25'! renameTextSelectionForMethod | selectedInterval selection method | method := self model selectedMethod. selection := self model sourceTextArea selectedContents asString. selectedInterval := self model sourceTextArea selectionInterval. selectedInterval first = 1 ifTrue: [ ^ self renameMethodFor: method ]. self renameTemporaryNamed: selection Between: selectedInterval from: method! ! !NautilusRefactoring methodsFor: 'rewrite code' stamp: ''! categoryRegex self model sourceCode: self categoryRegexText! ! !NautilusRefactoring methodsFor: 'private-source' stamp: ''! privateInlineMethodFromComponentBetween: anInterval from: aMethod ^ RBInlineMethodFromComponentRefactoring model: environment inline: anInterval inMethod: aMethod selector forClass: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'private-class' stamp: ''! classObjectFor: anObject (anObject isBehavior or: [anObject isTrait]) ifTrue: [ ^ environment classFor: anObject ]. anObject isSymbol ifTrue: [ ^ environment classNamed: anObject ]. ^ anObject! ! !NautilusRefactoring class methodsFor: 'accessing' stamp: ''! promptOnRefactoring ^ PromptOnRefactoring ifNil: [ PromptOnRefactoring := true ]! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'SebastianTleye 8/8/2013 18:00'! refactoringMethodMenu: aBuilder | target | target := aBuilder model. target selectedMethod ifNil:[ ^ target ]. target selectedMethod origin instanceSide refactoringMethod: aBuilder.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'SebastianTleye 8/8/2013 17:54'! instVarRefactoringSubmenu: aBuilder | target selectedClass | target := aBuilder model. selectedClass := target selectedClass. selectedClass ifNil: [^target]. selectedClass instVarRefactoring: aBuilder.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'SebastianTleye 7/30/2013 16:10'! classVarRefactoringSubmenu: aBuilder | target selectedClass | target := aBuilder model. selectedClass := target selectedClass. selectedClass ifNil: [ ^ target ]. selectedClass varRefactoringSubMenu: aBuilder. ! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'SebastianTleye 7/30/2013 13:35'! refactoringClassMenu: aBuilder | target | target := aBuilder model. target selectedClass ifNil: [^target]. target selectedClass refactoringMenu: aBuilder.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'EstebanLorenzano 10/3/2013 16:16'! groupRefactoringMenu: aBuilder | target | target := aBuilder model. target selectedClass ifNotNil: [ target selectedClass groupRefactoring: aBuilder ].! ! !NautilusRefactoring class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/24/2012 22:29'! buildRefactoringMethodShortcutsOn: aBuilder (aBuilder shortcut: #rename) category: #NautilusGlobalShortcuts default: $r command, $m command do: [:target || scroll | scroll := target methodWidget vScrollValue. target refactor renameMethodFor: target selectedMethod. target methodWidget vScrollValue: scroll] description: 'Rename the seleted method' ! ! !NautilusRefactoring class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 1/25/2013 17:49'! buildSourceCodeShortcutsOn: aBuilder (aBuilder shortcut: #rename) category: #NautilusSourceCodeShortcuts default: $r command do: [:target | (target sourceTextArea hasUnacceptedEdits not) ifTrue: [ target refactor renameTextSelection ]] description: 'Rename the current selection'. (aBuilder shortcut: #extractToTemp) category: #NautilusSourceCodeShortcuts default: $x command shift do: [:target | (target sourceTextArea hasUnacceptedEdits not) ifTrue: [ target refactor extractToTempTextSelection ]] description: 'Extract to temp the current selection'. (aBuilder shortcut: #extractToMethod) category: #NautilusSourceCodeShortcuts default: $m command shift do: [:target | (target sourceTextArea hasUnacceptedEdits not) ifTrue: [ target refactor extractToMethodTextSelection ]] description: 'Extract to method the current selection'. (aBuilder shortcut: #format) category: #NautilusSourceCodeShortcuts default: $u command shift do: [ :target | target refactor formatSourceCode ].! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'SebastianTleye 8/8/2013 17:55'! methodRefactoringSubMenu: aBuilder | target selectedMethod | target := aBuilder model. selectedMethod := target selectedMethod. selectedMethod ifNil:[ ^ target ]. selectedMethod origin instanceSide methodRefactoring: aBuilder.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'MarcusDenker 12/2/2013 14:11'! sourceCodeRefactoringMenuHolder: aBuilder | target | target := aBuilder model. target selectedClass ifNotNil: [:selectedClass | selectedClass sourceCodeRefactoringMenu: aBuilder ].! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'SebastianTleye 7/30/2013 15:22'! classRefactoringSubmenu: aBuilder | target | target := aBuilder model. target selectedClass ifNil: [^target]. target selectedClass refactoringSubmenu: aBuilder.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'MarcusDenker 12/2/2013 14:07'! sourceCodeRefactoringMenu: aBuilder | target | target := aBuilder model. target selectedClass ifNotNil: [:selectedClass | selectedClass sourceCodeRefactoring: aBuilder ]! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'EstebanLorenzano 10/10/2013 13:24'! packageRefactoringMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Rewrite Code') order: 100; withSeparatorAfter. (aBuilder item: #'Rewrite Code') action: [ target refactor rewriteCode ]; parent: #'Rewrite Code'; order: 0. (aBuilder item: #'Search Code') action: [ target refactor searchCode ]; parent: #'Rewrite Code'; order: 100. ! ! !NautilusRefactoring class methodsFor: 'instance creation' stamp: ''! model: model ^ self new model: model; yourself! ! !NautilusRefactoring class methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/27/2012 13:27'! buildRefactoringShortcutsOn: aBuilder (aBuilder shortcut: #generateAccessors) category: #NautilusGlobalShortcuts default: $h command, $a command do: [:target | target refactor generateAccessors ] description: 'Generate the accessors for the selected class'. (aBuilder shortcut: #generateSubclass) category: #NautilusGlobalShortcuts default: $h command, $n command, $s command do: [:target | target refactor generateSubclass ] description: 'Generate a subclass for the selected class'.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'SebastianTleye 8/8/2013 17:52'! codeRewritingClassSubmenu: aBuilder | target | target := aBuilder model. target selectedClass ifNil: [^target]. target selectedClass codeRewritingClass: aBuilder.! ! !NautilusShowCategoriesChanged commentStamp: ''! A NautilusShowCategoriesChanged is raised the value showCategories changed! !NautilusShowCommentChanged commentStamp: ''! A NautilusShowCommentChanged is raised when showComment is switched! !NautilusShowGroupsChanged commentStamp: ''! A NautilusShowGroupsChanged is raised when the value showGroups is switched! !NautilusShowHierarchyChanged commentStamp: ''! A NautilusShowHierarchyChanged is raised when the value of howHierarchy is switched! !NautilusShowInstanceChanged commentStamp: ''! A NautilusShowInstanceChanged is raised when the value of showInstances is changed! !NautilusShowPackagesChanged commentStamp: ''! A NautilusShowPackagesChanged is raised when the value of showPackages changed! !NautilusTest commentStamp: ''! A NautilusTest is a test class for testing the behavior of Nautilus! !NautilusTest methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 2/16/2013 15:24'! testSelectedCategory self assert: nautilus selectedMethod isNil. nautilus selectedMethod: (Object>>#at:). nautilus selectedCategory: 'test'. self assert: (nautilus selectedCategory = 'test'). self assert: (nautilus selectedMethod isNil).! ! !NautilusTest methodsFor: 'running' stamp: ''! tearDown nautilus := nil.! ! !NautilusTest methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 2/16/2013 15:06'! testCorrespondingMethods self assert: ((Dictionary>>#associations) == (DictionaryTest>>#testAssociations) correspondingMethods first). self assert: ((Dictionary>>#add:) == (DictionaryTest>>#testAdd) correspondingMethods first). self assert: ((Dictionary>>#at:put:) == (DictionaryTest>>#testAtPut) correspondingMethods first).! ! !NautilusTest methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 2/16/2013 15:22'! testCorrespondingTestClass self assert: (Behavior correspondingForTest == BehaviorTest). self assert: (BehaviorTest correspondingForTest == Behavior).! ! !NautilusTest methodsFor: 'tests' stamp: ''! testCorrespondingTestMethod self assert: ((Dictionary>>#associations) correspondingTestMethod == (DictionaryTest>>#testAssociations)). self assert: ((Dictionary>>#add:) correspondingTestMethod == (DictionaryTest>>#testAdd)). self assert: ((Dictionary>>#at:put:) correspondingTestMethod == (DictionaryTest>>#testAtPut)).! ! !NautilusTest methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 4/20/2012 00:17'! testSelectedClass self assert: nautilus selectedMethod isNil. nautilus selectedMethod: (Object>>#at:). nautilus selectedCategory: 'test'. self assert: (nautilus selectedCategory = 'test'). self assert: (nautilus selectedMethod isNil). nautilus selectedClass: Morph. self assert: (nautilus selectedClass = Morph). self assert: (nautilus selectedCategory isNil). self assert: (nautilus selectedMethod isNil).! ! !NautilusTest methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 4/19/2012 23:47'! testSelectedMethod self assert: nautilus selectedMethod isNil. nautilus selectedMethod: (Object>>#at:). self assert: (nautilus selectedMethod = (Object>>#at:))! ! !NautilusTest methodsFor: 'running' stamp: ''! setUp nautilus := Nautilus new.! ! !NautilusTextDisplayerChanged commentStamp: ''! A NautilusTextDisplayerChanged is raised when the way to display the method changed.! !NautilusTextDisplayerChanged methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/13/2012 21:15'! displayerSymbol ^ displayerSymbol! ! !NautilusTextDisplayerChanged methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/13/2012 21:15'! displayerSymbol: anObject displayerSymbol := anObject! ! !NautilusTextDisplayerChanged class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/13/2012 21:19'! displayerSymbol: anObject ^ self new displayerSymbol: anObject; yourself! ! !NautilusUI commentStamp: ''! A UI for an instance of Nautilus! !NautilusUI methodsFor: 'widget - category' stamp: 'BenjaminVanRyseghem 4/17/2012 15:05'! resetMethodsListSelection methodWidget resetMethodsListSelection! ! !NautilusUI methodsFor: 'tests' stamp: ''! categoriesLabel ^ categoryWidget categoriesLabel! ! !NautilusUI methodsFor: 'widget - method' stamp: ''! buildTestSelectorFor: aMethod ^ String streamContents: [:s || capitalize | capitalize := true. s << 'test'. aMethod selector do: [:c | c = $: ifTrue: [ capitalize := true ] ifFalse: [ capitalize ifTrue: [ capitalize := false. s << c asUppercase. ] ifFalse:[ s << c ]]]] ! ! !NautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 4/14/2012 12:10'! addMethodsInGroup: aCollection (DialogGroupAdder new groups: self groupsManager; elementsToAdd: (aCollection sort: [:a :b | a name < b name])) open! ! !NautilusUI methodsFor: 'source code area' stamp: 'SebastianTleye 8/1/2013 15:19'! methodRemoved: anAnnouncement | method | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. method := anAnnouncement methodRemoved. ((method methodClass = self selectedClass) or: [ method methodClass users includes: self selectedClass ]) ifTrue: [ self selectedMethod = anAnnouncement methodRemoved ifTrue: [ self selectedMethod: nil ]. self resetMethodsListSelection. self removeAllFromMethodsIconsCache: method. method isTestMethod ifTrue: [ "Should update class icon" ClassesIconsCache removeKey: method methodClass ifAbsent: []. self updateClassView ]. self update. (method methodClass isMeta and: [ method methodClass hasMethods not ]) ifTrue: [ self changed: #instanceButtonLabel ] ]! ! !NautilusUI methodsFor: 'debugging actions' stamp: 'FernandoOlivero 11/25/2012 22:13'! debugTest: aMethod | context process | context := [ :value | [ value run ] ensure: [ UIManager default uiProcess == Processor activeProcess ifFalse: [ Processor activeProcess terminate ] ] ] asContext. context pop; push: (self buildTestSuiteFor: aMethod). [ context isNil or: [ context selector = aMethod selector ] ] whileFalse: [ context := context selector = #setUp ifTrue: [ context quickStep ] ifFalse: [ context step ] ]. context isNil ifTrue: [ ^ UIManager default inform: 'Unable to open debugger on #' , aMethod selector ]. process := Process forContext: context priority: Processor userInterruptPriority. Smalltalk tools debugger openOn: process context: context label: 'Debug ' , aMethod methodClass name , '>>#' , aMethod selector contents: nil fullView: true! ! !NautilusUI methodsFor: 'debugging actions' stamp: 'BenjaminVanRyseghem 5/2/2012 10:33'! buildTestSuiteFor: aMethod ^ TestSuite new addTest: (aMethod methodClass selector: aMethod selector); yourself! ! !NautilusUI methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 22:53'! initialize super initialize. categoryWidget := CategoryWidget model: self. methodWidget := MethodWidget model: self.! ! !NautilusUI methodsFor: 'group' stamp: ''! addProtocolsInGroup: aCollection | class mthds | (class := self selectedClass) ifNil: [ ^ self ]. mthds := self showGroups ifTrue: [ self methodsForCategoriesInGroup: aCollection ] ifFalse:[ self methodsForCategories: aCollection ]. (DialogGroupAdder new groups: self groupsManager; elementsToAdd: (mthds sort: [:a :b | a name < b name])) open! ! !NautilusUI methodsFor: 'widget - method' stamp: ''! methodsInSystemEnvironmentForCategory: aCategory in: class aCategory = self allLabel ifTrue: [ ^ class methods asOrderedCollection ]. ^ (class methodsInProtocol: aCategory) asOrderedCollection! ! !NautilusUI methodsFor: 'tests' stamp: ''! selectedCategories ^ categoryWidget selectedCategories! ! !NautilusUI methodsFor: 'widget - category' stamp: ''! getMethods ^ methodWidget getMethods! ! !NautilusUI methodsFor: 'source code area' stamp: 'MarcusDenker 11/21/2013 13:38'! methodAdded: anAnnouncement | method | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. method := anAnnouncement method. ((method methodClass = self selectedClass) or: [ method methodClass users includes: self selectedClass ]) ifTrue: [ self resetMethodsListSelection. self removeAllFromMethodsIconsCache: method. self update. (method methodClass isMeta and: [ method methodClass methods size = 1 ]) ifTrue: [ self changed: #instanceButtonLabel ] ]! ! !NautilusUI methodsFor: 'widget - method' stamp: 'BenjaminVanRyseghem 5/14/2012 12:18'! update categoryWidget resetCategoryCache. methodWidget resetMethodCache; updateList. self changed: #getCategoryItem:.! ! !NautilusUI methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 17:58'! giveFocusToClass self giveFocusTo: list2! ! !NautilusUI methodsFor: 'widget - category' stamp: 'EstebanLorenzano 2/6/2013 17:12'! buildMethodWidget | methodsList | methodsList := methodWidget buildMethodsList. self setShortcuts: #NautilusMethodShortcuts to: methodsList. ^methodsList ! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 01:24'! findAllMethod "Search for a method in the lookup of the selected class" | foundMethod class | self okToChange ifFalse: [^ self flashPackage ]. class := self selectedClass. class ifNil: [ ^ self ]. foundMethod := (SearchFacade allMessageSearchFor: class) chooseFromOwner: self window. foundMethod ifNil: [^ self ]. self showGroupsSilently: false. self categoryWidget resetSelection. self methodWidget resetSelection. self categoryWidget selectProtocol: foundMethod category. self model package: class package class: class category: foundMethod protocol method: foundMethod. self updateBothView. self update. self changed: #sourceCodeFrom:! ! !NautilusUI methodsFor: 'widget - category' stamp: ''! removeAllFromMethodsIconsCache: aMethod methodWidget removeAllFromMethodsIconsCache: aMethod! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'AlainPlantec 7/9/2013 12:38'! runTestForAMethodWithAnHalt: aMethod | testMethod color vScroll testClass testResult | testMethod := aMethod correspondingTestMethod. testMethod ifNil: [ ^ self ]. vScroll := methodWidget vScrollValue. testClass := testMethod methodClass. testResult := testClass run: testMethod selector. testResult updateResultsInHistory. (testResult failures isEmpty not or: [ testResult errors isEmpty not ]) ifTrue: [ testClass debug: testMethod selector ]. ClassesIconsCache removeKey: aMethod methodClass ifAbsent: []. UIManager default defer: [ methodWidget vScrollValue: vScroll ]. aMethod hasPassedTest ifTrue: [ color := Color green ]. aMethod hasFailedTest ifTrue: [ color := Color yellow ]. aMethod hasErrorTest ifTrue: [ color := Color red ]. self notifyTitle: 'Test Finished' contents: 'Method: ',testMethod methodClass asString, '>>#',testMethod selector asString color: color! ! !NautilusUI methodsFor: 'menus behavior' stamp: ''! fileOutMethods self fileOutMethods: self selectedMethods! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 02:09'! findProtocol "Search for a method in the lookup of the selected class" | foundProtocol class | class := self selectedClass. class ifNil: [ ^ self ]. self okToChange ifFalse: [^ self flashPackage ]. foundProtocol := (SearchFacade protocolSearchFor: class) chooseFromOwner: self window. foundProtocol ifNil: [^ self ]. self showGroupsSilently: false. self categoryWidget resetSelection. self categoryWidget selectProtocol: foundProtocol. self model package: class package class: class category: foundProtocol method: nil. self updateBothView. self update. self changed: #sourceCodeFrom:! ! !NautilusUI methodsFor: 'widget - category' stamp: ''! methodsSelection ^ methodWidget methodsSelection! ! !NautilusUI methodsFor: 'history behavior' stamp: 'BenjaminVanRyseghem 10/18/2013 16:36'! wrapHistory: anEntry ^ GoBackStringMorph contents: anEntry key asHistoryString! ! !NautilusUI methodsFor: 'widget - category' stamp: 'BenjaminVanRyseghem 4/17/2012 13:40'! methodsIconsCache ^ self methodWidget methodsIconsCache! ! !NautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 4/14/2012 12:17'! addMethodsInGroup self selectedMethods ifNotNil: [:mthds | self addMethodsInGroup: mthds ]! ! !NautilusUI methodsFor: 'widget - method' stamp: 'IgorStasenko 8/30/2012 15:59'! methodsInARestrictedEnvironment: env forCategory: aCategory in: class | mthds selectors | aCategory = self allLabel ifTrue: [ ^ class methods asOrderedCollection select: [:e | env includesSelector: e selector in: class ]]. selectors := env selectorsFor: aCategory in: class. mthds := OrderedCollection new. selectors do: [:s | mthds add: (class compiledMethodAt: s) ]. ^ mthds! ! !NautilusUI methodsFor: 'source code area' stamp: 'NicolaiHess 1/13/2014 13:38'! methodModified: anAnnouncement | collection nonMetaMethodClass | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. collection := self getList2. nonMetaMethodClass:=anAnnouncement methodClass. self showInstance ifFalse:[nonMetaMethodClass:=nonMetaMethodClass theNonMetaClass]. ((collection includes: nonMetaMethodClass) or: [ anAnnouncement methodClass users includes: self selectedClass ]) ifTrue: [ | method selectedMethod oldMethod | method := anAnnouncement newMethod. selectedMethod := self selectedMethod. self removeFromMethodsIconsCache: method. method isTestMethod ifTrue: [ "Should update class icon" ClassesIconsCache removeKey: method methodClass ifAbsent: []]. self updateClassView. oldMethod := anAnnouncement oldMethod. (selectedMethod = oldMethod or: [ oldMethod hasBreakpoint and: [ selectedMethod methodClass = oldMethod methodClass and: [ selectedMethod selector = oldMethod selector ]]]) ifTrue: [ sourceTextArea hasUnacceptedEdits ifTrue: [ | sourceCode | sourceCode := sourceTextArea text. self forceSelectedMethod: method. self update. self highlightCategory: method. sourceTextArea setText: sourceCode. sourceTextArea hasEditingConflicts: true. sourceTextArea update: #codeChangedElsewhere ] ifFalse: [ self selectedMethod: method. self update ]]]! ! !NautilusUI methodsFor: 'widget - method' stamp: ''! methodsForCategoryInGroup: aCategory | class group env mthds | (class := self selectedClass) ifNil: [ ^ {} ]. (group := self selectedGroup) ifNil: [ ^ {} ]. env := self browsedEnvironment. mthds := env isSystem ifTrue: [ aCategory = self allLabel ifTrue: [ (group methodsFor: class) asOrderedCollection ] ifFalse: [ (group methodsFor: class categorised: aCategory) asOrderedCollection ]] ifFalse: [ aCategory = self allLabel ifTrue: [ (group methodsFor: class) asOrderedCollection select: [:e | env includesSelector: e selector in: class ]] ifFalse: [(group methodsFor: class categorised: aCategory) asOrderedCollection select: [:e | env includesSelector: e selector in: class ]]]. ^ mthds sort: [:a :b | a selector < b selector ]! ! !NautilusUI methodsFor: 'widget - method' stamp: ''! hasFocus ^ window hasKeyboardFocus or: [ list hasKeyboardFocus or: [ list2 hasKeyboardFocus or: [ categoryWidget hasFocus or: [ methodWidget hasFocus or: [ sourceTextArea hasKeyboardFocus ]]]]]! ! !NautilusUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 6/24/2012 17:55'! keyPressedOnList: anEvent shifted: aBoolean | aCharacter | aCharacter := anEvent keyCharacter. (aCharacter == self class nextFocusKey) ifTrue: [ ^ self giveFocusTo: list2 ]. (aCharacter == self class previousFocusKey) ifTrue: [ ^ self giveFocusTo: sourceTextArea ].! ! !NautilusUI methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 5/2/2013 09:52'! sugsContext ^ SugsNautilusContext model: self.! ! !NautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:55'! selectedCategoryInternally: anObject self resetMethodsListSelection. anObject ifNotNil: [ self giveFocusTo: categoryWidget ]. self changed: #sourceCodeFrom:! ! !NautilusUI methodsFor: 'displaying' stamp: 'BenjaminVanRyseghem 4/16/2013 17:29'! open | focus | super open. window takeKeyboardFocus. focus := list. self selectedClass ifNotNil: [ acceptor := ClassOrMethodDefinitionAcceptor model: self. focus := list2 ]. self selectedCategory ifNotNil: [:cat | categoryWidget selectProtocol: cat. methodWidget resetMethodCache. methodWidget update: #getMethodItem:. acceptor := MethodDefinitionAcceptor model: self. focus := categoryWidget ]. self selectedMethod ifNotNil: [:meth | methodWidget selectMethod: meth. acceptor := MethodDefinitionAcceptor model: self. focus := methodWidget ]. self giveFocusTo: focus. ! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'CD 10/18/2013 17:28'! removeMethod: aMethod inClass: aClass "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. " | result | self okToChange ifFalse: [^ false]. result := super removeMethod: aMethod inClass: aClass. result ifTrue: [ self update ]. ^result! ! !NautilusUI methodsFor: 'tests' stamp: ''! enableCategorySingleSelection ^ self selectedCategories size <= 1! ! !NautilusUI methodsFor: '*NodeNavigation' stamp: 'GiselaDecuzzi 5/13/2013 13:33'! isWorkspace ^ false! ! !NautilusUI methodsFor: 'private' stamp: ''! nextButtonState ^ true! ! !NautilusUI methodsFor: 'widget - method' stamp: ''! methodsForCategoriesInGroup: aCollection | mthds | mthds := aCollection gather: [:e | self methodsForCategoryInGroup: e ]. ^ mthds sort: [:a :b | a selector < b selector ]! ! !NautilusUI methodsFor: 'plugins display' stamp: 'EstebanLorenzano 1/30/2013 14:50'! buildMiddlePlugins | middle container | middle := self model plugins select: [:each | each position = #middle ]. middle ifEmpty: [ ^ nil ]. middle size = 1 ifTrue: [ ^ middle first display ]. container := Morph new. self setShortcuts: #NautilusSourceCodeShortcuts to: container. container color: Color transparent; changeTableLayout; cellInset: 8; listDirection: #topToBottom; cellPositioning: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap. middle reverse do: [:each | each display ifNotNil: [:morph | container addMorph: morph ]]. ^ container! ! !NautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/20/2012 12:26'! toggleShowInstance self showInstance: self showInstance not. self changed: #instanceButtonState. categoryWidget label: self categoriesLabel. methodWidget label: self methodsLabel.! ! !NautilusUI methodsFor: 'drag and drop' stamp: ''! dropMethod: aCollectionOfMethods inARow: aRow | newProtocol | newProtocol := self getCategories at: aRow. aCollectionOfMethods do: [:aMethod | self move: aMethod from: aMethod category to: newProtocol isCopy: false ]. self selectedMethod: nil! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'AlainPlantec 7/9/2013 12:37'! runTestForAMethod: aMethod notifying: aBoolean priority: aPriority | testMethod testSemaphoreForMethod blockToEvaluate shouldAnnounce | testMethod := aMethod correspondingTestMethod. testSemaphoreForMethod := Semaphore new. shouldAnnounce := aBoolean. testMethod ifNil: [ ^ self ]. blockToEvaluate := [ | vScroll testClass testResult | vScroll := methodWidget vScrollValue. testClass := testMethod methodClass. testResult := [ testClass run: testMethod selector ] on: Halt do: [ :e | aBoolean ifTrue: [ [ self runTestForAMethodWithAnHalt: aMethod ] fork. shouldAnnounce := false. TestAsserter classForTestResult new ] ifFalse: [ TestAsserter classForTestResult new addFailure: (testClass selector: testMethod selector); yourself ]]. testResult updateResultsInHistory. testSemaphoreForMethod signal. (aBoolean and: [testResult failures isEmpty not or: [ testResult errors isEmpty not ]]) ifTrue: [ testClass debug: testMethod selector ]. ClassesIconsCache removeKey: aMethod methodClass ifAbsent: []. UIManager default defer: [ methodWidget vScrollValue: vScroll ]]. aBoolean ifTrue: [ blockToEvaluate forkAt: aPriority. ] ifFalse: [ blockToEvaluate value ]. testSemaphoreForMethod wait. shouldAnnounce ifTrue: [| color | testMethod hasPassedTest ifTrue: [ color := Color green ]. testMethod hasFailedTest ifTrue: [ color := Color yellow ]. testMethod hasErrorTest ifTrue: [ color := Color red ]. self notifyTitle: 'Test Finished' contents: 'Method: ',testMethod methodClass asString, '>>#',testMethod selector asString color: color ]. aBoolean ifFalse: [ testSemaphore signal ]! ! !NautilusUI methodsFor: 'tests' stamp: ''! getCategories ^ categoryWidget getCategories! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'NicolaiHess 1/6/2014 16:10'! findMethod "Search for a method in the lookup of the selected class" | foundMethod class | self okToChange ifFalse: [^ self flashPackage ]. class := self selectedClass. class ifNil: [ ^ self ]. foundMethod := (SearchFacade messageSearchFor: class) chooseFromOwner: self window. foundMethod ifNil: [^ self ]. self showGroupsSilently: false. self categoryWidget resetSelection. self methodWidget resetSelection. self categoryWidget selectProtocol: foundMethod category. self model package: self selectedPackage class: self selectedClass category: foundMethod protocol method: foundMethod. self update. self changed: #sourceCodeFrom:! ! !NautilusUI methodsFor: 'menus behavior' stamp: ''! moveMethodToPackage "Search for a package from a pattern or from the recent list" | packagesList | self okToChange ifFalse: [^ self flashPackage ]. packagesList := self model packages collect: [:each | each name ]. self moveMethodsToPackage: self selectedMethods in: packagesList from: self selectedPackage. self update. ! ! !NautilusUI methodsFor: 'widget - method' stamp: ''! resetSelections self resetListSelection. self resetListSelection2. self resetCategoriesListSelection. self resetMethodsListSelection.! ! !NautilusUI methodsFor: 'private' stamp: 'NicolaiHess 1/14/2014 10:41'! unselectClass commentTextArea ifNotNil: [ commentTextArea disable ]. acceptor := ClassDefinitionAcceptor model: self. classesSelection removeAll. self model package: self selectedPackage class: nil category: nil method: nil. self updateOnClassSelection! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'JurajKubelka 12/27/2013 11:51'! fullBrowse ^ self model class openOnPackage: self selectedPackage class: self selectedClass category: self selectedCategory method: self selectedMethod group: self selectedGroup showGroups: self showGroups showHierarchy: self showHierarchy showPackages: self showPackages showComment: self showComment showInstance: self showInstance showCategories: true ! ! !NautilusUI methodsFor: 'widget - category' stamp: ''! selectedMethods ^ methodWidget selectedMethods! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'BenComan 2/18/2014 00:47'! toggleBreakPoint | savedSelectedMethodIndex savedVscroll | self selectedMethod ifNotNil: [ :meth | savedSelectedMethodIndex := methodWidget selectedMethodIndex. savedVscroll := methodWidget vScrollValue. self toggleBreakOnEntryIn: meth. self update. methodWidget selectedMethodIndex: savedSelectedMethodIndex. savedVscroll := methodWidget vScrollValue: savedVscroll. ]. ! ! !NautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/14/2013 15:48'! parentOfClass: aClass ^ self model parentOfClass: aClass! ! !NautilusUI methodsFor: '*NautilusRefactoring' stamp: ''! refactor ^ NautilusRefactoring model: self! ! !NautilusUI methodsFor: 'displaying' stamp: 'BenjaminVanRyseghem 11/28/2013 16:46'! buildColumns: aWindow height: height | delta | delta := StandardFonts defaultFont height + 15. aWindow addMorph: (self buildFirstColumn: aWindow) fullFrame: ((0 @ 0 corner: 0.25 @ 0.5) asLayoutFrame topOffset: height ). aWindow addMorph: (self buildSecondColumn: aWindow) fullFrame: ((0.25 @ 0 corner: 0.5 @ 0.5) asLayoutFrame topOffset: height ). aWindow addMorph: (self buildThirdColumn: aWindow) fullFrame: ( (0.5 @ 0 corner: 0.75 @ 0.5) asLayoutFrame topOffset: height ; bottomOffset: delta negated). aWindow addMorph: (self buildFourthColumn: aWindow) fullFrame: ( (0.75 @ 0 corner: 1 @ 0.5) asLayoutFrame topOffset: height; bottomOffset: delta negated). aWindow addMorph: self buildNavigationList fullFrame: ((0.5 @ 0.5 corner: 1 @ 0.5) asLayoutFrame topOffset: delta negated).! ! !NautilusUI methodsFor: 'history behavior' stamp: 'BenjaminVanRyseghem 10/18/2013 17:45'! currentHistoryIndex | index item | index := 1 min: self getHistoryList size. index = 0 ifTrue: [ ^ 0 ]. item := (self getHistoryList at: index) key. self selectedClass = item selectedClass ifFalse: [ ^ 0 ]. self selectedMethod ifNil: [ ^ 0 ]. self selectedMethod selector = item selectedMethod ifTrue: [ ^ index ] ifFalse: [ ^ 0 ]! ! !NautilusUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 4/25/2012 11:11'! keyPressedOnList2: anEvent shifted: aBoolean | aCharacter | aCharacter := anEvent keyCharacter. (aCharacter == self class nextFocusKey) ifTrue: [ ^ self giveFocusTo: categoryWidget ]. (aCharacter == self class previousFocusKey) ifTrue: [ ^ self giveFocusTo: list ].! ! !NautilusUI methodsFor: 'private' stamp: 'NicolaiHess 1/14/2014 10:42'! updateOnClassSelection self changed: #toggleButtonEnabled. self setWindowTitle. self resetCategoriesListSelection. self resetMethodsListSelection. self update. self changed: #isAClassSelected. self changed: #getComments. self changed: #instanceButtonLabel. self changed: #sourceCodeFrom:! ! !NautilusUI methodsFor: 'menu-packages' stamp: 'EstebanLorenzano 2/21/2014 12:42'! demoteSelectedPackageAsPackageWithTag | package | package := self selectedPackage item. (package name includes: $-) ifFalse: [ ^ self inform: 'Package {1} does not have levels to downgrade.' ]. package demoteToRPackageNamed: (package name copyUpToLast: $-)! ! !NautilusUI methodsFor: 'widget - category' stamp: ''! keyPressedOnElement: anEvent ^ self methodWidget keyPressedOnElement: anEvent! ! !NautilusUI methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 18:00'! giveFocusToMethod self giveFocusTo: methodWidget! ! !NautilusUI methodsFor: 'menus behavior' stamp: ''! fileOutCategories self fileOutCategories: self selectedCategories from: self selectedClass! ! !NautilusUI methodsFor: 'private' stamp: ''! previousButtonState ^ true! ! !NautilusUI methodsFor: 'shortcuts from text morph' stamp: 'CamilloBruni 9/22/2012 20:12'! compileAMethodFromCategory: aCategory withSource: aString notifying: aController | category selector class scroll method| category := aCategory. class := self selectedClass ifNil: [ ^ Error signal: 'Should not happen!!' ]. scroll := sourceTextArea scrollValue y. (category = self noMethodsString or: [ category = self allLabel ]) ifTrue: [ category := self asYetUnclassifiedString ]. "sourceTextArea update: #clearUserEdits." selector := self compileANewMethodInClass: class categorized: category from: aString notifyng: aController. selector ifNil: [ ^ sourceTextArea hasUnacceptedEdits: true ]. method := (class methodNamed: selector). sourceTextArea update: #clearUserEdits. sourceTextArea vScrollValue: scroll. "self selectedCategory: cat." "methodsTree setSelectedNodeItem: method." ( self selectedMethod notNil and: [(self selectedClass = class) and: [ self selectedMethod selector = selector]]) ifFalse: [ self selectedMethod: method. self update. sourceTextArea vScrollValue: scroll.]! ! !NautilusUI methodsFor: '*NautilusRefactoring' stamp: 'BenjaminVanRyseghem 4/16/2013 17:35'! rewriteCode: aText acceptor := CodeRewritingAcceptor model: self. self sourceCode: aText! ! !NautilusUI methodsFor: 'widget - category' stamp: ''! enableMethodSingleSelection ^ self selectedMethods size <= 1! ! !NautilusUI methodsFor: 'plugins display' stamp: 'EstebanLorenzano 1/30/2013 14:48'! buildBottomPlugins | bottom container | bottom := self model plugins select: [:each | each position = #bottom ]. bottom ifEmpty: [ ^ nil ]. bottom size = 1 ifTrue: [ ^ bottom first display ]. container := Morph new. self setShortcuts: #NautilusSourceCodeShortcuts to: container. container color: Color transparent; changeTableLayout; cellInset: 8; listDirection: #topToBottom; cellPositioning: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap. bottom reverse do: [:each | each display ifNotNil: [:morph | container addMorph: morph ]]. ^ container! ! !NautilusUI methodsFor: '*NautilusRefactoring' stamp: ''! renameClassWithRefactoringEngine: aClass self refactor renameClass: aClass ! ! !NautilusUI methodsFor: 'drag and drop' stamp: 'CD 10/18/2013 17:22'! move: item from: oldCategory to: newCategory isCopy: isCopy | category | category := newCategory. category = self allLabel ifTrue: [ category := self asYetUnclassifiedString ]. isCopy ifFalse: [ item methodClass organization classify: item selector under: category suppressIfDefault: true. self selectedMethod: item ] ! ! !NautilusUI methodsFor: 'menus behavior' stamp: ''! categorizeMethod "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | aCollection aClass | self okToChange ifFalse: [^ self]. (aCollection := self selectedMethods) ifEmpty: [^ self]. (aClass := self selectedClass) ifNil: [^self]. self categorizeMethods: aCollection of: aClass from: aCollection first category. self update.! ! !NautilusUI methodsFor: 'displaying' stamp: 'EstebanLorenzano 5/14/2013 12:37'! addAll: aWindow | topHeight middleHeight bottomMorph bottomHeight delta | delta := 0. bottomHeight := 0. middleHeight := 0. topHeight := 0. " reverse order in column ..." "column vResizing: #rigid." self buildTopPlugins ifNotNil: [:top | topHeight := top height. aWindow addMorph: top fullFrame: ((0 @ 0 corner: 1 @ 0) asLayoutFrame bottomOffset: topHeight). delta := 4. topHeight := topHeight + delta. top color: Color transparent]. "navigationRow := self buildNavigationRow: aWindow height: topHeight." self buildColumns: aWindow height: topHeight"+navigationRow". self setShortcuts: #NautilusSourceCodeShortcuts to: aWindow. self buildMiddlePlugins ifNotNil: [:middle | middleHeight := middle height+4. aWindow addMorph: middle fullFrame: ((0 @ 0.5 corner: 1 @ 0.5) asLayoutFrame bottomOffset: middleHeight). middle color: Color transparent]. sourceCodePanel := PanelMorph new. self setShortcuts: #NautilusSourceCodeShortcuts to: sourceCodePanel. sourceCodePanel changeProportionalLayout. sourceCodePanel addMorph: self buildCodePane fullFrame: LayoutFrame identity. "self buildCommentPane." sourceCodePanel hResizing: #spaceFill; vResizing: #spaceFill. sourceCodeContainer := PanelMorph new. self setShortcuts: #NautilusSourceCodeShortcuts to: sourceCodeContainer. sourceCodeContainer changeTableLayout; listDirection: #leftToRight. { sourceCodePanel. self buildTextAreaButtonsColumn: aWindow} reverse do: [:each | sourceCodeContainer addMorph: each]. bottomMorph := self buildBottomPlugins. bottomMorph ifNotNil: [:bottom | bottomHeight := bottom height + 8]. aWindow addMorph: sourceCodeContainer fullFrame: ( (0@0.5 corner: 1 @ 1) asLayoutFrame topOffset: middleHeight; bottomOffset: bottomHeight negated). bottomMorph ifNotNil: [:bottom | aWindow addMorph: bottom fullFrame: ((0 @ 1 corner: 1 @ 1) asLayoutFrame topOffset: bottomHeight negated). bottom color: Color transparent]! ! !NautilusUI methodsFor: 'widget - category' stamp: ''! selectedMethod ^ self model selectedMethod ! ! !NautilusUI methodsFor: 'plugins display' stamp: ''! buildTopPlugins | top container | top := self model plugins select: [:each | each position = #top ]. top ifEmpty: [ ^ nil ]. top size = 1 ifTrue: [ ^ top first display ]. container := Morph new. container color: Color transparent; changeTableLayout; cellInset: 8; listDirection: #topToBottom; cellPositioning: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap. top reverse do: [:each | each display ifNotNil: [:morph | container addMorph: morph ]]. ^ container! ! !NautilusUI methodsFor: 'group' stamp: ''! addProtocolsInGroup self selectedCategories ifNotNil: [:ctgrs | self addProtocolsInGroup: ctgrs ].! ! !NautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/17/2012 15:05'! methodWidget ^ methodWidget! ! !NautilusUI methodsFor: 'tests' stamp: ''! categoriesSelection ^ categoryWidget categoriesSelection! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'MarcusDenker 9/27/2013 18:05'! removeMethods self selectedClass ifNotNil: [:class | self selectedMethods ifNotEmpty: [:items || scroll needToUpdate | scroll := methodWidget vScrollValue. needToUpdate := self removeMethods: items inClass: class. needToUpdate ifTrue: [ self resetMethodsListSelection. methodWidget updateList ]. (class methods includes: self selectedMethod) ifFalse: [ self selectedMethod: nil ]. self resetMethodsListSelection. methodWidget updateList; vScrollValue: scroll. ]]! ! !NautilusUI methodsFor: 'items creation' stamp: 'EstebanLorenzano 1/30/2013 14:50'! buildNavigationList | navigation | navigation := (DropListMorph on: self list: #getHistoryList selected: #currentHistoryIndex changeSelected: #setHistory:) hResizing: #spaceFill; vResizing: #spaceFill; wrapSelector: #wrapHistory:; ghostText: 'History Navigator'; yourself. self setShortcuts: #NautilusSourceCodeShortcuts to: navigation. ^ navigation! ! !NautilusUI methodsFor: 'widget - method' stamp: 'BenjaminVanRyseghem 4/18/2012 19:04'! signatureFor: aSelector ^ (aSelector includes: $:) ifTrue: [ | col | col := aSelector subStrings: ':'. String streamContents: [:s | col doWithIndex: [:e :i | i == 1 ifTrue: [ s << e << $: << ' anObject ' ] ifFalse: [ s << e << $: << ' anObject'<< (i-1) printString << ' ' ]]]] ifFalse: [ aSelector ]! ! !NautilusUI methodsFor: 'widget - method' stamp: ''! methodsForCategory: aCategory | methds class env | class := self selectedClass. class ifNil: [ ^ #() ]. env := self browsedEnvironment. methds := env isSystem ifTrue: [ self methodsInSystemEnvironmentForCategory: aCategory in: class ] ifFalse: [ self methodsInARestrictedEnvironment: env forCategory: aCategory in: class ]. ^ methds sort: [:a :b | a selector < b selector ].! ! !NautilusUI methodsFor: 'private' stamp: 'NicolaiHess 1/14/2014 10:41'! selectedClass: aClass withSelection: aPackage self model package: aPackage class: aClass category: nil method: nil. packagesSelection removeAll. packagesSelection at: aPackage put: true. self updateBothView! ! !NautilusUI methodsFor: 'widget - method' stamp: 'IgorStasenko 10/13/2013 19:07'! notifyTitle: title contents: contents GrowlMorph openWithLabel: title contents: contents! ! !NautilusUI methodsFor: 'widget - method' stamp: ''! methodsForCategories: aCollection ^ aCollection gather: [:e | self methodsForCategory: e ]! ! !NautilusUI methodsFor: 'shortcuts from text morph' stamp: 'MarcusDenker 9/27/2013 18:05'! compileSource: aText notifying: aController acceptor accept: aText asString notifying: aController.! ! !NautilusUI methodsFor: 'remove me' stamp: ''! incrementMethodsListIndex | index | methodWidget resetMethodsListSelection. index := (methodWidget selectedMethodIndex + 1). index > methodWidget getMethods size ifTrue: [ index := 1 ]. methodWidget selectedMethodIndex: index. sourceTextArea takeKeyboardFocus ! ! !NautilusUI methodsFor: 'widget - method' stamp: ''! forceSelection: aNode ! ! !NautilusUI methodsFor: 'tests' stamp: ''! categoriesMenu: aMenu shifted: b ^ aMenu becomeForward: (self categoryMenuBuilder menu)! ! !NautilusUI methodsFor: 'tests' stamp: 'NicolaiHess 1/15/2014 11:40'! selectedPackageIncludes: aClass ^ (self selectedPackage notNil) and:[ (self selectedPackage classes includes: aClass ) or:[ self selectedPackage classes includes: aClass class ]. ]! ! !NautilusUI methodsFor: 'tests' stamp: 'EstebanLorenzano 2/6/2013 17:01'! buildCategoryWidget | categoriesList | categoriesList := categoryWidget buildCategoriesList. self setShortcuts: #NautilusProtocolShortcuts to: categoriesList. ^categoriesList! ! !NautilusUI methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 5/14/2012 12:17'! categorySelectionChanged methodWidget resetMethodCache; updateList.! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 4/18/2012 18:43'! implementSelector | selection | selection := sourceTextArea selectedContents asString. selection ifEmpty: [ ^ sourceTextArea flash ]. self implementSelector: selection findSelector! ! !NautilusUI methodsFor: 'accessing' stamp: ''! categoryWidget ^ categoryWidget! ! !NautilusUI methodsFor: '*NautilusRefactoring' stamp: 'CamilloBruni 10/7/2012 23:27'! basicRenameClass: aClass " Override to set the class rename with RB by default " self renameClassWithRefactoringEngine: aClass! ! !NautilusUI methodsFor: 'history behavior' stamp: ''! getHistoryList ^ self model historyEntries reversed! ! !NautilusUI methodsFor: 'history behavior' stamp: 'NicolaiHess 12/30/2013 23:19'! setHistory: anIndex | entry | anIndex == self currentHistoryIndex ifTrue: [ ^ self ]. entry := self getHistoryList at: anIndex ifAbsent: [ nil ]. entry ifNil: [ ^ self ]. self okToChange ifTrue:[self model adopt: entry.]. self changed: #currentHistoryIndex.! ! !NautilusUI methodsFor: 'widget - category' stamp: ''! methodsLabel ^ methodWidget methodsLabel! ! !NautilusUI methodsFor: 'history behavior' stamp: 'CamilloBruni 10/4/2012 11:33'! previous self model hasPrevious ifFalse: [ ^ self ]. "show the previous item in the history" self model previous! ! !NautilusUI methodsFor: 'debugging actions' stamp: 'BenjaminVanRyseghem 5/2/2012 10:48'! debugTest | method | method := self selectedMethod. method correspondingTestMethod ifNotNil: [:test | self debugTest: test ]! ! !NautilusUI methodsFor: 'widget - method' stamp: 'IgorStasenko 10/13/2013 18:36'! notifyTitle: title contents: contents color: aColor GrowlMorph openWithLabel: title contents: contents backgroundColor: aColor labelColor: Color black ! ! !NautilusUI methodsFor: 'widget - method' stamp: 'EstebanLorenzano 10/17/2013 16:08'! highlightCategory: aMethod methodWidget resetMethodCache. aMethod ifNotNil: [ | category index | category := aMethod protocol. category = self selectedCategory ifFalse:[ index := self getCategories indexOf: ( category ). index > 0 ifTrue: [ categoryWidget searchedElement: index] ] ]! ! !NautilusUI methodsFor: 'displaying' stamp: ''! buildFourthColumn: aWindow ^ self buildMethodWidget! ! !NautilusUI methodsFor: 'history behavior' stamp: 'CamilloBruni 10/4/2012 11:19'! next self model hasNext ifFalse: [ ^ self ]. "show the next item in history" self model next! ! !NautilusUI methodsFor: 'remove me' stamp: 'BenjaminVanRyseghem 5/14/2012 12:07'! decrementMethodsListIndex | index | methodWidget resetMethodsListSelection. index :=(methodWidget selectedMethodIndex - 1). index < 1 ifTrue: [ index := methodWidget methodListSize ]. methodWidget selectedMethodIndex: index. sourceTextArea takeKeyboardFocus! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 8/3/2012 15:16'! removeNonLocalSelector: aSymbol | traits isAlias | traits := self selectedClassOrMetaClass traitsProvidingSelector: aSymbol. isAlias := self selectedClassOrMetaClass isLocalAliasSelector: aSymbol. isAlias ifTrue: [ [traits size = 1] assert. self selectedClassOrMetaClass removeAlias: aSymbol of: traits first] ifFalse: [ traits do: [:each | self selectedClassOrMetaClass addExclusionOf: aSymbol to: each ]] ! ! !NautilusUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 5/5/2012 14:38'! keyStroke: anEvent fromSourceCodeMorph: aMorph "Here I received each key stroke in the source code text morph" | string | (self selectedMethod isNil and: [ self selectedCategory isNil ]) ifTrue: [ (sourceTextArea text isEmpty or: [ sourceTextArea text first isLowercase]) ifTrue: [ self setStylerClass: self selectedClass ] ifFalse: [ self setStylerClass: nil ]]. string := anEvent keyString. string = '' ifTrue: [ ^ self giveFocusTo: list ]. string = '' ifTrue: [ ^ self giveFocusTo: methodWidget ]. string = '' ifTrue: [ ^ self decrementMethodsListIndex ]. string = '' ifTrue: [ ^ self incrementMethodsListIndex ]. self aKeyHasBeenPressed: anEvent keyCharacter. ! ! !NautilusUI methodsFor: 'widget - method' stamp: 'BenjaminVanRyseghem 4/3/2012 17:49'! generateTestMethodFor: aMethod "generate a test method for aMethod and return the generated method" | class | class := self model classes detect: [:e | e name = (aMethod methodClass name,'Test')] ifNone: [ self createTestForClass: aMethod methodClass ]. class ifNotNil:[ class compile: (self generateSourceCodeForTestFrom: aMethod) classified: 'tests-',aMethod category. ^ class >> (self buildTestSelectorFor: aMethod) asSymbol ]. ^ nil! ! !NautilusUI methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 4/17/2012 14:59'! selectedCategory ^ (self model ifNil: [ ^ nil ]) selectedCategory! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 5/5/2012 23:53'! runTestForAMethod: aMethod notifying: aBoolean self runTestForAMethod: aMethod notifying: aBoolean priority: Processor userBackgroundPriority! ! !NautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/16/2013 13:15'! isSelectedPackage: package ^ package = self selectedPackage.! ! !NautilusUI methodsFor: 'category-method methods' stamp: 'BenjaminVanRyseghem 4/16/2013 17:11'! selectedMethod: aMethod self okToChange ifTrue: [ self forceSelectedMethod: aMethod. self setWindowTitle. self highlightCategory: aMethod. aMethod ifNil: [ acceptor := self selectedCategory ifNil: [ ClassOrMethodDefinitionAcceptor model: self ] ifNotNil:[ MethodDefinitionAcceptor model: self ]] ifNotNil: [ acceptor := MethodDefinitionAcceptor model: self. self giveFocusTo: methodWidget ]. self changed: #sourceCodeFrom:. multipleMethodsEditor giveFocusToDefault. ^ true]. ^false ! ! !NautilusUI methodsFor: 'menu-packages' stamp: 'EstebanLorenzano 2/19/2014 16:33'! promoteSelectedPackageTagAsPackage self selectedPackage item promoteAsRPackage! ! !NautilusUI methodsFor: 'tests' stamp: ''! resetCategoriesListSelection categoryWidget resetCategoriesListSelection! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 10/9/2013 16:19'! generateTestMethodsAndFocus: aBoolean "generate testing methods for the selected methods in the test class" "I assume the test class is named #{MyClassName}Test" | focus | self selectedMethods ifEmpty: [^ self]. self selectedMethods reverse do: [:method | focus := self generateTestMethodFor: method ]. focus ifNil: [ ^ self ]. (aBoolean and: [ self okToChange ]) ifTrue: [ self showGroups: false. self selectedPackage: (self parentOfClass: focus methodClass). self selectedClass: focus methodClass. self selectedCategory: 'tests'. methodWidget selectMethod: focus. self selectedMethod: focus. self updateBothView ]! ! !NautilusUI methodsFor: 'widget - method' stamp: ''! generateSourceCodeForTestFrom: aMethod ^ self buildTestSelectorFor: aMethod.! ! !NautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/8/2013 16:32'! contentsSelectionFrom: aTextMorph ^ (contentSelection notNil and: [ aTextMorph == sourceTextArea ]) ifTrue: [ | result | result := contentSelection. contentSelection := nil. result ] ifFalse: [ self contentSelectionFor: aTextMorph ]! ! !NautilusUI methodsFor: 'source code area' stamp: 'SebastianTleye 8/2/2013 10:06'! methodRecategorized: anAnnouncement window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. ((anAnnouncement methodClass = self selectedClass) or: [ anAnnouncement methodClass users includes: self selectedClass ]) ifTrue: [self update ]! ! !NautilusUI methodsFor: 'category-method methods' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! selectedMethodWithoutAsking: aMethod self okToChange ifTrue: [ self forceSelectedMethod: aMethod. self setWindowTitle. self highlightCategory: aMethod. aMethod ifNotNil: [ self giveFocusTo: methodWidget ]. self changed: #sourceCodeFrom:. ^ true]. ^false ! ! !NautilusUI methodsFor: 'widget - category' stamp: ''! elementsMenu: aMenu shifted: b ^ aMenu becomeForward: (self methodMenuBuilder menu)! ! !NautilusUI methodsFor: 'category-method methods' stamp: 'BenjaminVanRyseghem 4/16/2013 17:08'! selectedCategory: protocol self okToChange ifTrue: [ methodWidget resetMethodCache. self model package: self selectedPackage class: self selectedClass category: protocol method: nil. self resetMethodsListSelection. protocol ifNil: [ acceptor := ClassOrMethodDefinitionAcceptor model: self ] ifNotNil: [ acceptor := MethodDefinitionAcceptor model: self. self giveFocusTo: categoryWidget ]. categoryWidget changed: #selectedCategoryIndex. self changed: #sourceCodeFrom:. ^ true]. ^ false! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 5/28/2013 14:13'! implementSelector: aSelector | behavior method category head source | category := Protocol unclassified. behavior := SearchFacade classSearch chooseFromOwner: self window. aSelector ifNil: [ ^ sourceTextArea flash ]. behavior ifNil: [ ^ sourceTextArea flash ]. (behavior includesSelector: aSelector) ifFalse: [ head := (self signatureFor: aSelector). source := head,' ^ self shouldBeImplemented'. method := behavior compile: source classified: category notifying: sourceTextArea ]. method := (behavior methodNamed: aSelector). self showInstance: true. self showGroups: false. self model package: behavior package class: behavior category: category method: method. self update. self updateBothView. self changed: #sourceCodeFrom:. self giveFocusTo: sourceTextArea. head ifNotNil: [ sourceTextArea selectFrom: head size + 4 to: source size ].! ! !NautilusUI methodsFor: 'displaying' stamp: ''! buildThirdColumn: aWindow ^ self buildCategoryWidget! ! !NautilusUI methodsFor: '*NautilusRefactoring' stamp: ''! removeClassWithRefactoringEngine: aCollection ^ self refactor removeClasses: aCollection ! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/17/2012 21:17'! addCategory "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | newName | self okToChange ifFalse: [^ self]. self selectedClass ifNil: [^ self]. newName := self addCategoryIn: self selectedClass before: self selectedCategory. self resetCategoriesListSelection. categoryWidget selectProtocol: newName. self selectedCategory: newName. newName ifNil: [ ^ self ]. self update; giveFocusToSourceCode.! ! !NautilusUI methodsFor: 'accessing' stamp: 'BenComan 4/9/2014 23:41'! "protocol: accessing" selectedClassWithoutChangingSelection: aClass categoryWidget resetCategoryCache. self okToChangeBoth ifFalse: [ ^ self ]. aClass ifNil: [ self unselectClass ] ifNotNil: [ acceptor := ClassOrMethodDefinitionAcceptor model: self. classesSelection at: aClass theNonMetaClass put: true. commentTextArea ifNotNil: [ commentTextArea enable ]. ((self selectedPackageIncludes: aClass theNonMetaClass) or: [ model showPackages not ]) ifTrue: [ self model package: self selectedPackage class: aClass category: nil method: nil ] ifFalse: [ self selectedClass: aClass withSelection: (self parentOfClass: aClass) ]. self updateOnClassSelection ]! ! !NautilusUI methodsFor: 'widget - method' stamp: 'EstebanLorenzano 5/28/2013 14:40'! allLabel ^ AllProtocol defaultName! ! !NautilusUI methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 17:59'! giveFocusToProtocol self giveFocusTo: categoryWidget! ! !NautilusUI methodsFor: 'widget - method' stamp: 'BenjaminVanRyseghem 6/22/2012 17:00'! addMethod self okToChange ifFalse: [ sourceTextArea flash. ^ self ]. sourceTextArea setText: ''. self giveFocusTo: sourceTextArea.! ! !NautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/18/2013 17:56'! selectedClassWithoutChangingSelectionInternally: aClass | package packageChanged | package := self selectedPackage. (self showPackages not or: [ self showGroups ]) ifTrue: [ aClass ifNotNil: [ package := aClass package ] ]. aClass ifNil: [ classesSelection removeAll ]. aClass ifNotNil: [ self giveFocusTo: list2 ]. packageChanged := (package ~= self selectedPackage). classesSelection at: aClass put: true. self model selectedClass: aClass. self setWindowTitle. packageChanged ifTrue: [ packagesSelection removeAll. packagesSelection at: package put: true. self showGroups ifTrue: [ self updateClassView ] ifFalse: [ self updateBothView ] ]. self resetCategoriesListSelection. self resetMethodsListSelection. self update. self changed: #isAClassSelected. self changed: #getComments. self changed: #sourceCodeFrom:! ! !NautilusUI methodsFor: 'history behavior' stamp: 'CamilloBruni 10/4/2012 10:49'! historyChanged self setWindowTitle. self changed: #getHistoryList. self changed: #currentHistoryIndex! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 1/16/2014 11:23'! renameCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | category newName vScroll | self okToChange ifFalse: [^ self]. category := self selectedCategory. vScroll := categoryWidget vScrollValue. newName := self renameCategory: category from: self selectedClass. newName ifNil: [ ^ self ]. categoryWidget deselectProtocol: category. self selectedCategory: newName. categoryWidget selectProtocol: newName. self update. categoryWidget vScrollValue: vScroll! ! !NautilusUI methodsFor: 'category-method methods' stamp: ''! forceSelectedMethod: aMethod self model package: self selectedPackage class: self selectedClass category: self selectedCategory method: aMethod.! ! !NautilusUI methodsFor: 'menus behavior' stamp: ''! removeCategories self selectedClass ifNotNil: [:class | self selectedCategories ifNotEmpty: [:items || removeACategory scroll | scroll := categoryWidget vScrollValue. removeACategory := false. items do: [:item || needToUpdate | needToUpdate := self removeCategory: item inClass: class. (needToUpdate and: [ removeACategory not ]) ifTrue: [ removeACategory := true]. needToUpdate ifTrue: [ self update ]]. removeACategory ifTrue: [ self selectedCategory: nil ]. self update. categoryWidget vScrollValue: scroll. ]]! ! !NautilusUI class methodsFor: 'keymapping' stamp: 'CamilloBruni 10/4/2012 11:13'! buildHistoryShortcutsOn: aBuilder (aBuilder shortcut: #previous) category: #NautilusGlobalShortcuts default: $[ command do: [:target| target previous ] description: 'Go back in the navigation history.'. (aBuilder shortcut: #next) category: #NautilusGlobalShortcuts default: $] command do: [:target| target next ] description: 'Go forward in the navigation history'. ! ! !NautilusUI class methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 4/8/2012 13:11'! initializeCache "self initializeCache" | collection instance | collection := Smalltalk allClassesAndTraits. instance := self new model: Nautilus new. collection do: [:cls | instance classIconFor: cls. cls methodDict do: [:m | instance methodWidget methodIconFor: m ] displayingProgress: [:m | 'Filing up cache for ', m dragAndDropPrint ]] displayingProgress: [:cls | 'Filing up cache for ', cls name ]! ! !NautilusUITest commentStamp: ''! A NautilusUITest is a test class for testing the behavior of NautilusUI! !NautilusUITest methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 2/16/2013 14:54'! testBuildTestSelectorFor | method selector | method := MorphicEventHandler >> #keyStroke:fromMorph:. selector := nautilusUI buildTestSelectorFor: method. self assert: selector equals: 'testKeyStrokeFromMorph'! ! !NautilusUITest methodsFor: 'initialization' stamp: ''! setUp "Setting up code for NautilusUITest" nautilusUI := NautilusUI on: Nautilus new.! ! !NautilusUITest methodsFor: 'initialization' stamp: ''! tearDown "Tearing down code for NautilusUITest" nautilusUI := nil.! ! !NautilusWindow commentStamp: ''! I am a subclass of StandardWindow with my own icon Maybe I'm useless, but right now I'm not on the top of the to do list! !NautilusWindow methodsFor: 'about' stamp: 'BenjaminVanRyseghem 8/27/2012 11:05'! aboutText ^'Nautilus is a new browser for Pharo Smalltalk based on RPackage and Announcements with fancy goodies: - groups - multi-selections - environments - iconic buttons - hierarchy - pragma based menus - KeyMapping shortcuts - Ring compliant - refactorings support - stateless shortcuts - multiple source code panel - direct feedback (method too long, class uncommented ...) Made by Benjamin Van Ryseghem and friends'! ! !NautilusWindow methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 1/22/2012 00:08'! hasFocus ^ ActiveHand keyboardFocus == self! ! !NautilusWindow methodsFor: 'open/close' stamp: 'BenjaminVanRyseghem 9/14/2012 14:39'! delete | mod | mod := self model. super delete. mod ifNotNil: [ mod announce: (WindowClosed new window: self) ]! ! !NautilusWindow methodsFor: 'about' stamp: 'BenjaminVanRyseghem 2/20/2012 16:59'! aboutTitle ^'About Nautilus'! ! !NautilusWindow methodsFor: 'open/close' stamp: 'BenjaminVanRyseghem 12/20/2012 12:47'! initialExtent ^ 850@600! ! !NavigationHistory commentStamp: ''! I act as a web browser history! !NavigationHistory methodsFor: 'protocol' stamp: 'CamilloBruni 10/4/2012 11:32'! pauseDuring: aBlock | previousPausedValue | "Don't accept any new entries while executing aBlock" previousPausedValue := paused. paused := true. aBlock ensure: [ paused := previousPausedValue ]! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/13/2012 04:03'! entries ^ storage! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/11/2011 15:09'! last ^ storage last! ! !NavigationHistory methodsFor: 'testing' stamp: 'CamilloBruni 10/4/2012 11:17'! hasNext ^ index < storage size! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/18/2013 17:36'! removeEntry: anEntry | toRemove | "we know that toRemove will always contains one element" toRemove := (storage select: [:e | e key == anEntry ]). toRemove ifEmpty: [ ^ self ]. toRemove := toRemove first. storage remove: toRemove. storage addLast: toRemove! ! !NavigationHistory methodsFor: 'protocol' stamp: 'SvenVanCaekenberghe 1/9/2014 20:34'! basicAdd: anEntry ( storage isEmpty not and: [ storage last = anEntry ] ) ifTrue: [ ^ self ]. anEntry = self current key ifTrue: [ ^ self ]. self checkSize. index := index +1. index > storage size ifTrue: [ storage addLast: (anEntry -> DateAndTime now)] ifFalse: [ storage := storage copyFrom: 1 to: index. storage at: index put: (anEntry -> DateAndTime now)]! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/11/2011 15:09'! back index := ((index - 1) max: 0)! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/12/2011 12:25'! next index := ((index + 1) min: storage size). ^ storage at: index! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/18/2013 18:00'! removeLastEntry self isPaused ifTrue: [ ^ self ]. storage ifEmpty: [ ^ self ]. storage remove: storage last. index := index -1! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/18/2013 17:48'! addEntry: anEntry self isPaused ifTrue: [ ^ self ]. self basicAdd: anEntry! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/14/2011 22:53'! maxSize: anInteger maxSize := anInteger! ! !NavigationHistory methodsFor: 'initialization' stamp: 'CamilloBruni 10/4/2012 11:29'! initialize storage := OrderedCollection new. index := 0. paused := false.! ! !NavigationHistory methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 5/12/2011 13:01'! hasPrevious ^ index > 1! ! !NavigationHistory methodsFor: 'collection compatibility' stamp: 'BenjaminVanRyseghem 3/13/2012 16:13'! add: anEntry self addEntry: anEntry! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/19/2011 11:05'! maxSize ^ maxSize ifNil: [ maxSize := self class defaultMaxSize ].! ! !NavigationHistory methodsFor: 'testing' stamp: 'CamilloBruni 10/4/2012 11:30'! isPaused ^ paused! ! !NavigationHistory methodsFor: 'protocol' stamp: 'CamilloBruni 9/20/2013 22:12'! previous index := index-1 max: 1. ^ storage at: index! ! !NavigationHistory methodsFor: 'protocol' stamp: 'SvenVanCaekenberghe 1/9/2014 20:35'! replaceCurrentWith: anEntry "Change the current history item to the given object" storage at: index put: (anEntry -> DateAndTime now)! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/11/2011 16:11'! current ^ storage at: index ifAbsent: [ nil -> nil ]! ! !NavigationHistory methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/24/2011 13:42'! checkSize [ storage size >= self maxSize ] whileTrue: [ storage removeFirst. index := index -1].! ! !NavigationHistory class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/13/2012 16:37'! defaultMaxSize ^ 15! ! !NetNameResolver commentStamp: ''! This class implements TCP/IP style network name lookup and translation facilities. Attempt to keep track of whether there is a network available. HaveNetwork true if last attempt to contact the network was successful. LastContact Time of that contact (totalSeconds). haveNetwork returns true, false, or #expired. True means there was contact in the last 30 minutes. False means contact failed or was false last time we asked. Get out of false state by making contact with a server in some way (FileList or updates).! !NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/17/97 16:26'! promptUserForHostAddress "Ask the user for a host name and return its address." "NetNameResolver promptUserForHostAddress" ^ NetNameResolver promptUserForHostAddressDefault: '' ! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:32'! primGetAddressInfoNext self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:33'! primGetNameInfoServiceSize self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primNameLookupResult "Return the host address found by the last host name lookup. Returns nil if the last lookup was unsuccessful." self primitiveFailed ! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primStartLookupOfName: hostName "Look up the given host name in the Domain Name Server to find its address. This call is asynchronous. To get the results, wait for it to complete or time out and then use primNameLookupResult." self primitiveFailed ! ! !NetNameResolver class methodsFor: 'private' stamp: 'HenrikSperreJohansen 2/16/2012 15:54'! resolverMutex "This must have been initialized by class initialization. If a failure occurs due to mutex not being properly initialized, do NOT solve it by lazy initialization, or you WILLl introduce a race condition" ^ResolverMutex! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'mir 2/22/2002 15:50'! localHostAddress "Return the local address of this host." "NetNameResolver localHostAddress" self initializeNetwork. ^ self primLocalAddress ! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:32'! primGetAddressInfoResult: socketAddress self primitiveFailed! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'ls 9/5/1998 01:14'! addressForName: aString ^self addressForName: aString timeout: 60! ! !NetNameResolver class methodsFor: 'initialization' stamp: 'CamilloBruni 1/14/2013 22:15'! initialize "NetNameResolver initialize" "Note: On the Mac, the name resolver is asynchronous (i.e., Squeak can do other things while it is working), but can only handle one request at a time. On other platforms, such as Unix, the resolver is synchronous; a call to, say, the name lookup primitive will block all Squeak processes until it returns." "Resolver Status Values" ResolverUninitialized := 0. "network is not initialized" ResolverReady := 1. "resolver idle, last request succeeded" ResolverBusy := 2. "lookup in progress" ResolverError := 3. "resolver idle, last request failed" DefaultHostName := ''. HaveNetwork := nil. ResolverMutex := Mutex new ! ! !NetNameResolver class methodsFor: 'network initialization' stamp: 'HenrikSperreJohansen 2/16/2012 15:47'! initializeNetwork "Initialize the network drivers and record the semaphore to be used by the resolver. Do nothing if the network is already initialized.." "NetNameResolver initializeNetwork" | successful sema| "network is already initialized" (self resolverStatus = ResolverUninitialized) ifFalse: [^true]. "No real message sends allowed in the atomic check, so pre-create a semaphore" sema := Semaphore forMutualExclusion. "Atomically check if another process is in the progress of initializing network. If so, block untill it is done and retry, otherwise start setting it up. Not doing so could lead to - External semaphore leakage (if we both try to set up simultaneously) - Returning an incorrect result (if we return a value independent of whether the other process was successful)" HaveNetwork == nil ifTrue: [HaveNetwork := sema]. "Then, enter critical section where other process has initialized, or we need to do it." HaveNetwork critical: [ |semaIndex| "If other process initialized while we were blocked, retry to see if it were successful" HaveNetwork ifNil: [^self initializeNetwork]. "If the network has previously been initialized, but now unavailable, we need to unregister semaphore" ResolverSemaphore ifNotNil: [Smalltalk unregisterExternalObject: ResolverSemaphore]. ResolverSemaphore := Semaphore new. semaIndex := Smalltalk registerExternalObject: ResolverSemaphore. successful := (self primInitializeNetwork: semaIndex) notNil. HaveNetwork := nil.]. ^successful or: [NoNetworkError signal: 'failed network initialization'] ! ! !NetNameResolver class methodsFor: 'address string utils' stamp: 'lr 3/13/2010 15:07'! stringFromAddress: addr "Return a string representing the given host address as four decimal bytes delimited with decimal points." "NetNameResolver stringFromAddress: NetNameResolver localHostAddress" | s | s := String new writeStream. 1 to: 3 do: [ :i | (addr at: i) printOn: s. s nextPut: $.]. (addr at: 4) printOn: s. ^ s contents ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'NouryBouraqadi 10/1/2010 16:08'! loopBackName ^'localhost'! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:32'! primGetAddressInfoSize self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:32'! primGetAddressInfoType self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:32'! primGetAddressInfoHost: hostName service: servName flags: flags family: family type: type protocol: protocol self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:33'! primHostNameResult: aString self primitiveFailed! ! !NetNameResolver class methodsFor: 'private' stamp: 'SvenVanCaekenberghe 11/2/2012 13:24'! waitForResolverNonBusyUntil: deadline "Wait up to the given number of seconds for the resolver to be non busy. Return the resolver state." | status passed | status := self resolverStatus. [ status = ResolverBusy and: [ (passed := Time millisecondsSince: deadline key) < deadline value] ] whileTrue: [ "wait for resolver to be available" ResolverSemaphore waitTimeoutMSecs: (deadline value - passed). status := self resolverStatus ]. ^ status! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:33'! primGetNameInfoHostSize self primitiveFailed! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'NouryBouraqadi 10/1/2010 16:08'! loopBackAddress ^self addressForName: self loopBackName! ! !NetNameResolver class methodsFor: 'address string utils' stamp: 'ClementBera 7/26/2013 16:27'! addressFromString: addressString "Return the internet address represented by the given string. The string should contain four positive decimal integers delimited by periods, commas, or spaces, where each integer represents one address byte. Return nil if the string is not a host address in an acceptable format." "NetNameResolver addressFromString: '1.2.3.4'" "NetNameResolver addressFromString: '1,2,3,4'" "NetNameResolver addressFromString: '1 2 3 4'" | newAddr s byte delimiter | newAddr := ByteArray new: 4. s := addressString readStream. s skipSeparators. 1 to: 4 do: [ :i | byte := self readDecimalByteFrom: s. byte ifNil: [ ^ nil ]. newAddr at: i put: byte. i < 4 ifTrue: [ delimiter := s next. (delimiter = $. or: [ delimiter = $, or: [ delimiter = $ ] ]) ifFalse: [ ^ nil ] ] ]. ^ newAddr! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primAddressLookupResult "Return the host name found by the last host address lookup. Returns nil if the last lookup was unsuccessful." self primitiveFailed ! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primNameResolverStatus "Return an integer reflecting the status of the network name resolver. For a list of possible values, see the comment in the 'initialize' method of this class." self primitiveFailed ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/15/97 16:52'! localAddressString "Return a string representing the local host address as four decimal bytes delimited with decimal points." "NetNameResolver localAddressString" ^ NetNameResolver stringFromAddress: NetNameResolver localHostAddress ! ! !NetNameResolver class methodsFor: 'private' stamp: 'lr 3/13/2010 15:07'! readDecimalByteFrom: aStream "Read a positive, decimal integer from the given stream. Stop when a non-digit or end-of-stream is encountered. Return nil if stream is not positioned at a decimal digit or if the integer value read exceeds 255. JMM - 000503 fixed didn't work correctly" | digitSeen value digit | digitSeen := false. value := 0. [aStream atEnd] whileFalse: [digit := aStream next digitValue. (digit < 0 or: [digit > 9]) ifTrue: [ aStream skip: -1. (digitSeen not or: [value > 255]) ifTrue: [^ nil]. ^ value]. digitSeen := true. value := (value * 10) + digit]. (digitSeen not or: [value > 255]) ifTrue: [^ nil]. ^ value ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'SvenVanCaekenberghe 11/2/2012 13:13'! nameForAddress: hostAddress timeout: secs "Look up the given host address and return its name. Return nil if the lookup fails or is not completed in the given number of seconds. Depends on the given host address being known to the gateway, which may not be the case for dynamically allocated addresses." "NetNameResolver nameForAddress: (NetNameResolver addressFromString: '128.111.92.2') timeout: 30" | deadline result | self initializeNetwork. deadline := Time millisecondClockValue -> (secs * 1000). "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." self resolverMutex critical: [ result := (self waitForResolverReadyUntil: deadline) ifTrue: [ self primStartLookupOfAddress: hostAddress. (self waitForCompletionUntil: deadline) ifTrue: [self primAddressLookupResult] ifFalse: [nil]] ifFalse: [nil]]. ^result ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'JMM 5/3/2000 11:25'! resolverError ^self primNameResolverError ! ! !NetNameResolver class methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 1/14/2013 20:01'! isConnected "Dirty, but avoids fixing the plugin bug" [ NetNameResolver addressForName: 'www.esug.org' ] on: NameLookupFailure do: [ :exception | ^ false ]. ^ true! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:32'! primGetAddressInfoProtocol self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:34'! primHostNameSize self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:33'! primGetNameInfoServiceResult: aString self primitiveFailed! ! !NetNameResolver class methodsFor: 'private' stamp: 'SvenVanCaekenberghe 11/2/2012 13:24'! waitForCompletionUntil: deadline "Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is ready, false if the network is not initialized or the resolver does not become free within the given time period." | status | status := self waitForResolverNonBusyUntil: deadline. status = ResolverReady ifTrue: [^ true] ifFalse: [ status = ResolverBusy ifTrue: [self primAbortLookup]. ^ false]. ! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primStartLookupOfAddress: hostAddr "Look up the given host address in the Domain Name Server to find its name. This call is asynchronous. To get the results, wait for it to complete or time out and then use primAddressLookupResult." self primitiveFailed ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'lr 3/13/2010 15:07'! localHostName "Return the local name of this host." "NetNameResolver localHostName" | hostName | hostName := NetNameResolver nameForAddress: self localHostAddress timeout: 5. ^hostName ifNil: [self localAddressString] ifNotNil: [hostName]! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:33'! primGetNameInfoHostResult: aString self primitiveFailed! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'ClementBera 7/26/2013 16:27'! addressForName: hostName timeout: secs "Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds." "NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30" "NetNameResolver addressForName: '100000jobs.de' timeout: 30" "NetNameResolver addressForName: '1.7.6.4' timeout: 30" "NetNameResolver addressForName: '' timeout: 30" | deadline result | self initializeNetwork. "check if this is a valid numeric host address (e.g. 1.2.3.4)" result := self addressFromString: hostName. result ifNotNil: [ ^ result asSocketAddress ]. "Look up a host name, including ones that start with a digit (e.g. 100000jobs.de or www.pharo-project.org)" deadline := Time millisecondClockValue -> (secs * 1000). "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." self resolverMutex critical: [ (self waitForResolverReadyUntil: deadline) ifTrue: [ self primStartLookupOfName: hostName. (self waitForCompletionUntil: deadline) ifTrue: [ result := self primNameLookupResult ] ifFalse: [ ^ NameLookupFailure signalFor: hostName ] ] ifFalse: [ ^ NameLookupFailure signalFor: hostName ] ]. ^ result asSocketAddress! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primLocalAddress "Return the local address of this host." self primitiveFailed ! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primNameResolverError "Return an integer reflecting the error status of the last network name resolver request. Zero means no error." self primitiveFailed ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'MarcusDenker 10/9/2013 16:32'! promptUserForHostAddressDefault: defaultName "Ask the user for a host name and return its address. If the default name is the empty string, use the last host name as the default." "NetNameResolver promptUserForHostAddressDefault: ''" | default hostName serverAddr | default := defaultName isEmpty ifTrue: [ DefaultHostName ] ifFalse: [ defaultName ]. hostName := UIManager default request: 'Host name or address?' initialAnswer: default. hostName isEmptyOrNil ifTrue: [ ^ 0 ]. serverAddr := NetNameResolver addressForName: hostName timeout: 15. hostName size > 0 ifTrue: [ DefaultHostName := hostName ]. ^ serverAddr! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:32'! primGetAddressInfoFamily self primitiveFailed! ! !NetNameResolver class methodsFor: 'network initialization' stamp: 'ar 2/2/2001 15:09'! primInitializeNetwork: resolverSemaIndex "Initialize the network drivers on platforms that need it, such as the Macintosh, and return nil if network initialization failed or the reciever if it succeeds. Since mobile computers may not always be connected to a network, this method should NOT be called automatically at startup time; rather, it should be called when first starting a networking application. It is a noop if the network driver has already been initialized. If non-zero, resolverSemaIndex is the index of a VM semaphore to be associated with the network name resolver. This semaphore will be signalled when the resolver status changes, such as when a name lookup query is completed." "Note: some platforms (e.g., Mac) only allow only one name lookup query at a time, so a manager process should be used to serialize resolver lookup requests." ^ nil "return nil if primitive fails" ! ! !NetNameResolver class methodsFor: 'private' stamp: 'SvenVanCaekenberghe 11/2/2012 13:24'! waitForResolverReadyUntil: deadline "Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is not busy, false if the network is not initialized or the resolver does not become free within the given time period." | status | status := self resolverStatus. status = ResolverUninitialized ifTrue: [^ false]. status := self waitForResolverNonBusyUntil: deadline. ^ status ~= ResolverBusy ! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'! primAbortLookup "Abort the current lookup operation, freeing the name resolver for the next query." self primitiveFailed ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'JMM 5/3/2000 11:25'! resolverStatus ^self primNameResolverStatus ! ! !NetNameResolverTest commentStamp: 'TorstenBergmann 2/5/2014 10:12'! SUnit tests for NetNameResolver ! !NetNameResolverTest methodsFor: 'accessing' stamp: 'NouryBouraqadi 10/1/2010 16:29'! localHostNameIsLoopBackName ^NetNameResolver localHostName = NetNameResolver loopBackName! ! !NetNameResolverTest methodsFor: 'testing' stamp: 'NouryBouraqadi 10/1/2010 16:41'! testLocalHostAddress NetNameResolver isConnected ifTrue: [self deny: self localHostAddressIsLoopBackAddress] ifFalse: [self assert: self localHostAddressIsLoopBackAddress]! ! !NetNameResolverTest methodsFor: 'testing' stamp: 'NouryBouraqadi 10/1/2010 16:45'! testLocalHostName self deny: NetNameResolver localHostName isNil. NetNameResolver isConnected ifTrue: [self deny: self localHostNameIsLoopBackName] ifFalse: [self assert: self localHostNameIsLoopBackName]! ! !NetNameResolverTest methodsFor: 'accessing' stamp: 'NouryBouraqadi 10/1/2010 16:27'! localHostAddressIsLoopBackAddress ^NetNameResolver localHostAddress = NetNameResolver loopBackAddress! ! !NetworkError commentStamp: 'mir 5/12/2003 18:12'! Abstract super class for all network related exceptions.! !NetworkSystemSettings commentStamp: ''! I am NetworkSystemSettings, a class side API to manage various system network settings, mostly related to HTTP proxying.! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 17:04'! proxyPassword: aPassword "Set the HTTP proxy password. Can be empty or nil to reset" ProxyPassword := aPassword ifNotNil: [ aPassword base64Encoded ] ! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 17:03'! httpProxyPort: aPortNumber "Set the HTTP Proxy port to use to aPortNumber, use nil to reset" aPortNumber = HTTPProxyPort ifTrue: [ ^ self ]. LastHTTPProxyPort := HTTPProxyPort. HTTPProxyPort := aPortNumber ! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 17:08'! useHTTPProxy: aBoolean "Set whether an HTTP proxy should be used. This is a global switch." UseHTTPProxy = aBoolean ifTrue: [ ^ self ]. UseHTTPProxy := aBoolean. self useHTTPProxy ifTrue: [ self httpProxyPort: self lastHTTPProxyPort. self httpProxyServer: self lastHTTPProxyServer ] ifFalse: [ self httpProxyPort: nil. self httpProxyServer: nil ]! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 17:14'! httpProxyServer: aServerName "Set the hostname of the HTTP proxy server to use to aServerName. Can be nil or empty, when no HTTP proxy should be used." aServerName = HTTPProxyServer ifTrue: [ ^ self ]. LastHTTPProxyServer := HTTPProxyServer. HTTPProxyServer := aServerName ifNotNil: [ aServerName trimBoth ] ! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 17:08'! useNetworkAuthentification: aBoolean "Set whether authentication should be used when accessing the HTTP proxy. This is a switch over username/password." UseNetworkAuthentification := aBoolean! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SantiagoBragagnolo 9/16/2012 23:51'! manageHttpProxyExceptions ^ LastHTTPProxyExceptions ifNil:[ LastHTTPProxyExceptions := '']. ! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 14:20'! httpProxyPort "Return the HTTP proxy port to use, an Integer" ^ HTTPProxyPort ifNil: [ HTTPProxyPort := 80 ]! ! !NetworkSystemSettings class methodsFor: 'private' stamp: 'SvenVanCaekenberghe 9/6/2012 14:23'! lastHTTPProxyPort ^ LastHTTPProxyPort ifNil: [ LastHTTPProxyPort := HTTPProxyPort ] ! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 17:04'! proxyPassword "Return the HTTP proxy password to use, if any. Can be empty." ^ ProxyPassword ifNil: [ '' ] ifNotNil: [ ProxyPassword base64Decoded ]! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SantiagoBragagnolo 9/16/2012 23:49'! manageHttpProxyExceptions: aStringWithExceptions self removeAllHttpProxyExceptions. aStringWithExceptions ifNotNil:[ LastHTTPProxyExceptions := aStringWithExceptions. ( ';' split: aStringWithExceptions) do: [ :domain | self addHttpProxyException: domain ]. ].! ! !NetworkSystemSettings class methodsFor: 'private' stamp: 'SvenVanCaekenberghe 9/6/2012 14:23'! lastHTTPProxyServer ^ LastHTTPProxyServer ifNil: [ LastHTTPProxyServer := HTTPProxyServer ] ! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 15:25'! removeHttpProxyException: domainName "Remove a (partial, wildcard) domain name from the list of proxy exceptions" self httpProxyExceptions remove: domainName ifAbsent: []! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 17:00'! httpProxyExceptions "Return a list of partial, wildcard domain name strings that define which servers should not be proxied" ^ HTTPProxyExceptions ifNil: [ HTTPProxyExceptions := OrderedCollection new ]! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 17:07'! useNetworkAuthentification "Should authentication be used when accessing the HTTP proxy ? This is a switch over username/password." ^ UseNetworkAuthentification ifNil: [ UseNetworkAuthentification := false ]! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 16:52'! httpProxyServer "Return the hostname of the HTTP proxy server to use, a String. Can be empty, when no HTTP proxy should be used." ^ HTTPProxyServer ifNil: [ '' ]! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 17:06'! useHTTPProxy "Should an HTTP proxy be used ? This is a global switch." ^ UseHTTPProxy ifNil: [ UseHTTPProxy := false ]! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 13:45'! blabEmail: aBlabEmailString BlabEmail := aBlabEmailString! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 13:45'! blabEmail ^ BlabEmail ifNil: [ BlabEmail := '' ]! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SantiagoBragagnolo 11/2/2012 15:35'! isAnExceptionFor: anUrl ^ HTTPProxyExceptions contains: [ :domain | anUrl host = domain.].! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 15:10'! addHttpProxyException: domainName "Add a (partial, wildcard) domain name to the list of proxy exceptions" "HTTPSocket addProxyException: '*.online.disney.com'." self httpProxyExceptions add: domainName! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SantiagoBragagnolo 9/16/2012 23:47'! networkSettingsOn: aBuilder (aBuilder group: #network) label: 'Network' translated; description: 'All network related settings' translated; noOrdering; with: [ (aBuilder setting: #useHTTPProxy) label: 'Use HTTP proxy' translated; noOrdering; description: 'If checked then the you will be able to set a port number and a server name. If unchecked, then no http proxy is used.' translated; with: [ (aBuilder setting: #httpProxyPort) label: 'Port' translated; description: 'The HTTP proxy port'. (aBuilder setting: #httpProxyServer) label: 'Server' translated; description: 'The HTTP proxy server (i.e. proxy.univ-brest.fr)'. (aBuilder setting: #manageHttpProxyExceptions) label: 'Exceptions' translated; target: NetworkSystemSettings; description: 'Domains to avoid to proxy (separated by ;)' ]. (aBuilder setting: #useNetworkAuthentification) label: 'Proxy authentication' translated; noOrdering; description: 'If checked then you will be able to enter a user name and a password for network authentification. Store HTTP 1.0 basic authentication credentials. Note: this is an ugly hack that stores your password in your image. It''s just enought to get you going if you use a firewall that requires authentication' translated; with: [ (aBuilder setting: #proxyUser) label: 'User name' translated; description: 'The proxy user name' translated. (aBuilder setting: #proxyPassword) type: #Password; label: 'Password' translated; description: 'The user password' translated]. (aBuilder setting: #blabEmail) label: 'Blab email' translated; ghostHelp: 'somebody@some.where'; description: 'Enter blab email of the form ''somebody@some.where''. It can be empty' translated]! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 17:05'! proxyUser "Return the HTTP proxy user to use, if any. Can be empty." ^ ProxyUser ifNil: [ '' ] ifNotNil: [ ProxyUser base64Decoded ]! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 17:05'! proxyUser: aUser "Set the HTTP proxy user. Can be empty or nil to reset" ProxyUser := aUser ifNotNil: [ aUser base64Encoded ] ! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'GabrielOmarCotelli 11/28/2013 19:23'! isHttpProxyException: serverName "Return true when serverName matches any of our HTTP proxy exceptions, else return false" ^ self httpProxyExceptions anySatisfy: [ :domainName | domainName match: serverName ]! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SantiagoBragagnolo 9/16/2012 23:51'! removeAllHttpProxyExceptions HTTPProxyExceptions removeAll.! ! !NewArrayNode commentStamp: ''! I represent a node for the genPushNewArray: opcode.! !NewArrayNode methodsFor: 'code generation (closures)' stamp: 'eem 6/16/2008 09:31'! analyseTempsWithin: scopeBlock "" rootNode: rootNode "" assignmentPools: assignmentPools "" "This is a no-op except in TempVariableNode" ^self! ! !NewArrayNode methodsFor: 'code generation' stamp: 'eem 5/25/2008 14:58'! sizeCodeForValue: encoder ^encoder sizePushNewArray: numElements! ! !NewArrayNode methodsFor: 'code generation' stamp: 'eem 5/25/2008 14:58'! emitCodeForValue: stack encoder: encoder encoder genPushNewArray: numElements. stack push: 1! ! !NewArrayNode methodsFor: 'accessing' stamp: 'eem 5/25/2008 14:58'! numElements ^numElements! ! !NewArrayNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:35'! accept: aVisitor ^aVisitor visitNewArrayNode: self! ! !NewArrayNode methodsFor: 'accessing' stamp: 'eem 5/25/2008 14:59'! numElements: n numElements := n! ! !NewHandleMorph methodsFor: 'all' stamp: 'ar 8/16/2001 15:48'! followHand: aHand forEachPointDo: block1 lastPointDo: block2 withCursor: aCursor hand := aHand. hand showTemporaryCursor: aCursor "hotSpotOffset: aCursor offset negated". borderWidth := 0. color := Color transparent. pointBlock := block1. lastPointBlock := block2. self position: hand lastEvent cursorPoint - (self extent // 2)! ! !NewHandleMorph methodsFor: 'stepping and presenter' stamp: 'IgorStasenko 1/2/2012 18:06'! step | eventSource | eventSource := hand lastEvent. eventSource anyButtonPressed ifTrue: [waitingForClickInside := false. self position: eventSource cursorPoint - (self extent // 2). pointBlock value: self center] ifFalse: [waitingForClickInside ifTrue: [(self containsPoint: eventSource cursorPoint) ifFalse: ["mouse wandered out before clicked" ^ self delete]] ifFalse: [lastPointBlock value: self center. ^ self delete]]! ! !NewHandleMorph methodsFor: 'initialization' stamp: 'marcus.denker 11/19/2008 13:47'! initialize "initialize the state of the receiver" super initialize. waitingForClickInside := true. ! ! !NewHandleMorph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/16/2001 15:38'! delete hand ifNotNil:[ hand showTemporaryCursor: nil. ]. super delete.! ! !NewHandleMorph methodsFor: 'all' stamp: 'di 5/18/1998 15:27'! followHand: aHand forEachPointDo: block1 lastPointDo: block2 hand := aHand. pointBlock := block1. lastPointBlock := block2. self position: hand lastEvent cursorPoint - (self extent // 2)! ! !NewHandleMorph methodsFor: 'dropping/grabbing' stamp: 'di 4/30/1999 14:06'! justDroppedInto: aMorph event: anEvent "No dropping behavior because stepping will delete me. Moreover it needs to be done that way to evaluate lastPointBlock" ! ! !NewHandleMorph methodsFor: 'wiw support' stamp: 'RAA 1/10/2001 10:15'! morphicLayerNumber ^1 "handles are very front-like - e.g. the spawn reframe logic actually asks if the first submorph of the world is one of us before deciding to create one"! ! !NewList commentStamp: ''! NewList is a new morph as replacement for PluggableListMorph. The API used is hardcoded, but NewListAdapter has been introduced to hold this "pluggable" behavior! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! drawColor: anObject drawColor value: anObject! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/27/2012 01:13'! rawItemAtIndex: index ^ self model getRawItemAt: index! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! selectionWithKeys: anObject selectionWithKeys value: anObject! ! !NewList methodsFor: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/24/2012 01:12'! whenItemsChangedDo: aBlock listCache whenChangedDo: aBlock! ! !NewList methodsFor: 'looks & colors' stamp: 'BenjaminVanRyseghem 5/1/2013 08:22'! color: aColor self drawColor: aColor! ! !NewList methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize renderer := nil asValueHolder. super initialize. lastKeystrokeTime := 0. lastKeystrokes := ''. drawColor := Color white asValueHolder. model := nil asValueHolder. isInitialized := false asValueHolder. isMultipleSelection := false asValueHolder. listCache := OrderedCollection new asValueHolder. selectedIndex := 0 asValueHolder. selectedIndexes := Dictionary new asValueHolder. listSize := nil asValueHolder. headerHeight := 0 asValueHolder. headerTitle := '' asValueHolder. clickOnHeader := nil asValueHolder. secondSelection := nil asValueHolder. displayListCache := OrderedCollection new asValueHolder. runningProcesses := Array new asValueHolder. deSelectOnReclick := false asValueHolder. selectionWithKeys := true asValueHolder. selectedItem := nil asValueHolder. selectedItems := OrderedCollection new asValueHolder. unselectOnChange := false asValueHolder. iconCache := Dictionary new asValueHolder. iconMaxSize := nil asValueHolder. enabled := true asValueHolder. allowToSelect := true asValueHolder.! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! headerTitle: anObject headerTitle value: anObject! ! !NewList methodsFor: 'updating - private' stamp: 'BenjaminVanRyseghem 11/29/2012 19:51'! retrieveSelectedItems ^ self selectedIndexes collect: [:e | self rawItemAtIndex: e ]! ! !NewList methodsFor: 'events - keyboard' stamp: 'BenjaminVanRyseghem 11/25/2012 00:31'! handlesKeyStroke: anEvet ^ true! ! !NewList methodsFor: 'updating - private' stamp: 'BenjaminVanRyseghem 11/29/2012 19:51'! retrieveSelectedItem ^ self rawItemAtIndex: self selectedIndex! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/29/2012 17:50'! toggleAtIndexes: anIndex | bool | bool := selectedIndexes at: anIndex ifAbsent: [ false ]. selectedIndexes at: anIndex put: bool not! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:29'! isMultipleSelection ^ isMultipleSelection value! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:28'! selectedIndex ^ selectedIndex value! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:29'! headerHeight ^ headerHeight value! ! !NewList methodsFor: 'menu' stamp: 'BenjaminVanRyseghem 11/27/2012 01:02'! getMenu: shiftKeyState ^ self model getMenu: shiftKeyState.! ! !NewList methodsFor: 'updating - private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! updateDisplayListCache "self runningProcesses do: [:e | e ifNotNil: [:process | process terminate ]]." displayListCache value: (Array new: self listSize). self runningProcesses: (Array new: self listSize).! ! !NewList methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 12/13/2012 11:36'! drawOn: aCanvas aCanvas fillRectangle: self fullBounds color: self drawColor.! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 02:32'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/26/2012 21:10'! handlesDoubleClick ^ self model handlesDoubleClick! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 5/1/2013 07:59'! acceptDroppingMorph: aMorph atIndex: index event: evt inMorph: source ^ self model acceptDroppingMorph: aMorph atIndex: index event: evt inMorph: source! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 00:11'! itemHalfOffSet ^ 1! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 1/28/2013 13:27'! itemAtIndex: index ^ (displayListCache at: index) ifNil: [ | item rawItem icon | (runningProcesses at: index) ifNotNil: [:process | process terminate. runningProcesses remove: process ]. rawItem := self rawItemAtIndex: index. icon := self iconForItem: rawItem at: index. rawItem := self model getDisplayForItem: rawItem at: index. item := rawItem. displayListCache at: index put: item. item ]! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/26/2012 21:02'! retrieveHeaderTitle ^ self model getHeaderTitle! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:28'! setIndex: index | oldIndex newIndex | oldIndex := selectedIndex value. newIndex := index. self secondSelection: 0. self setViewToIndex: index. selectedIndex value: newIndex. (self deSelectOnReclick and: [ oldIndex == newIndex ]) ifTrue: [ self toggleAtIndexes: newIndex ] ifFalse: [ self addAtIndexes: newIndex ]! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:29'! isInitialized ^ isInitialized value! ! !NewList methodsFor: 'events - keyboard' stamp: 'BenjaminVanRyseghem 11/29/2012 17:52'! navigationKey: anEvent self isMultipleSelection ifTrue: [ | keyString | keyString := anEvent keyString. keyString = '' ifTrue: [ self selectAll. ^ true ]. keyString = '' ifTrue: [ self inverseSelection. ^ true ]. keyString = '' ifTrue: [ self deselectAll. ^ true ] ]. ^ super navigationKey: anEvent! ! !NewList methodsFor: 'updating - private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! updateHeaderHeight self isInitialized ifFalse: [ ^ self ]. headerHeight value: self model getHeaderHeight.! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/17/2012 14:44'! updateScrollbars self setScrollDeltas. self scrollBar changed. hScrollBar changed.! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 5/1/2013 10:02'! retrieveAllowToSelect ^ self model allowToSelect! ! !NewList methodsFor: 'events - mouse' stamp: 'BenjaminVanRyseghem 12/16/2012 17:07'! mouseUp: event | newEvent | newEvent := event translatedBy: self topLeft negated . self renderer mouseUp: newEvent.! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 10/17/2013 16:28'! retrieveItems ^ self model getItems ifNil: [ selectedItems value ]! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 10/17/2013 16:31'! updateListSize self isInitialized ifFalse: [ ^ self ]. listSize value: self retrieveListSize! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! isInitialized: anObject isInitialized value: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/27/2012 01:03'! runningProcesses ^ runningProcesses! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/25/2012 01:31'! setViewToIndex: index index isZero ifTrue: [ ^ self ]. self scrollToShow: (self renderer drawBoundsForIndex: index)! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/13/2012 13:37'! private_selectedIndexes ^ selectedIndexes! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/13/2012 11:09'! invalidateIconCacheFor: anItem iconCache removeKey: anItem! ! !NewList methodsFor: 'protocol' stamp: 'StephaneDucasse 1/4/2014 22:27'! cacheAt: index ^ listCache value at: index ifAbsent: [ nil ]! ! !NewList methodsFor: 'communication with model' stamp: 'ClementBera 5/3/2013 15:08'! keyStrokeAction: anEvent ^ self model keyStrokeAction: anEvent! ! !NewList methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 11/5/2013 11:21'! transferFor: draggedItem from: aMorph ^ self model transferFor: draggedItem from: aMorph! ! !NewList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/25/2012 01:47'! isSecondSelectedIndex: anIndex ^ self secondSelection == anIndex! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 01:14'! scrollToShow: aRectangle "scroll to include as much of aRectangle as possible, where aRectangle is in the scroller's local space" | range | ((aRectangle top - scroller offset y - self headerHeight) >= 0 and: [ (aRectangle bottom - scroller offset y) <= (self innerBounds height) ]) ifTrue: [ "already visible" ^self ]. range := self vLeftoverScrollRange. scrollBar value: (range > 0 ifTrue: [((aRectangle top-self headerHeight) / self vLeftoverScrollRange) truncateTo: scrollBar scrollDelta] ifFalse: [0]). scroller offset: -3 @ (range * scrollBar value).! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/16/2012 17:52'! selectSecondSelection ActiveEvent commandKeyPressed ifFalse: [ selectedIndexes removeAll ]. self setIndex: self secondSelection! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! inverseSelection self isMultipleSelection ifFalse: [ ^ self ]. 1 to: self listSize do: [: i | self toggleAtIndexes: i ]. self secondSelection: 0. selectedIndex value: self selectedIndexes first. self changed.! ! !NewList methodsFor: 'events - mouse' stamp: 'BenjaminVanRyseghem 11/25/2012 02:10'! mouseDownOnItemAt: index event: anEvent | item | item := self itemAtIndex: index. (item respondsTo: #mouseDown:) ifTrue: [ item mouseDown: anEvent ]! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:29'! adoptIndexes: aDictionary selectedIndexes value: aDictionary! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/17/2012 14:57'! invalidateIconCache iconCache removeAll! ! !NewList methodsFor: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/29/2012 19:46'! whenSelectedItemChangedDo: aBlock selectedItem whenChangedDo: aBlock! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:28'! model ^ model value! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 10/17/2013 16:28'! listSize ^ listSize value ifNil: [ self retrieveListSize ]! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/29/2012 19:17'! hasMultipledSelected | int | int := 0. selectedIndexes do: [:ass | ass value ifTrue: [ int := int + 1 ]. int = 2 ifTrue: [ ^ true ]]. ^ false! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/1/2013 09:21'! hasHeader: aBoolean self renderer hasHeader: aBoolean! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 00:46'! numberOfDisplayedItems ^ (self innerBounds height // self itemHeight) min: self listSize! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:28'! secondSelection ^ secondSelection value! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:29'! deSelectOnReclick ^ deSelectOnReclick value! ! !NewList methodsFor: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/29/2012 19:34'! whenSelectedIndexesChangedDo: aBlock selectedIndexes whenChangedDo: aBlock! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! deSelectOnReclick: anObject deSelectOnReclick value: anObject! ! !NewList methodsFor: 'events - mouse' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! mouseDownOnHeader: anEvent "Just to rise an announcement" clickOnHeader value: anEvent! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:29'! headerTitle ^ headerTitle value! ! !NewList methodsFor: 'events - keyboard' stamp: 'BenjaminVanRyseghem 11/29/2012 19:10'! keyStroke: event "Process keys specialKeys are things like up, down, etc. ALWAYS HANDLED modifierKeys are regular characters either 1) accompanied with ctrl, cmd or 2) any character if the list doesn't want to handle basic keys (handlesBasicKeys returns false) basicKeys are any characters" | aChar | (self scrollByKeyboard: event) ifTrue: [ ^ self ]. (self navigationKey: event) ifTrue: [ ^ self ]. (self keyStrokeAction: event) ifTrue: [ ^ self ]. aChar := event keyCharacter. aChar asciiValue < 32 ifTrue: [^ self specialKeyPressed: event ]. ^ self basicKeyPressed: aChar! ! !NewList methodsFor: 'events - keyboard' stamp: 'BenjaminVanRyseghem 11/29/2012 19:14'! specialKeyPressed: anEvent "A special key with the given ascii-value was pressed; dispatch it" | keyString max nextSelection oldSelection howManyItemsShowing | keyString := anEvent keyString. keyString = '' ifTrue: [" escape key" ^ ActiveEvent shiftPressed ifTrue: [ ActiveWorld invokeWorldMenuFromEscapeKey ] ifFalse: [ (self yellowButtonActivity: false) ifTrue: [ ^ self ]]]. keyString = '' ifTrue: [ "enter pressed" self selectSecondSelection ]. max := self listSize. max > 0 ifFalse: [ ^ self ]. nextSelection := oldSelection := self selectedIndex. (keyString = '' or: [ keyString = '' ]) ifTrue: [" down arrow" "self resetListSelectionSilently." nextSelection := oldSelection + 1. nextSelection := nextSelection min: max ]. (keyString = '' or: [ keyString = '' ]) ifTrue: [ " up arrow" "self resetListSelectionSilently." oldSelection = 0 ifTrue: [ nextSelection := self listSize ] ifFalse: [ nextSelection := oldSelection - 1. nextSelection := 1 max: nextSelection ]]. keyString = '' ifTrue: [" home" "self resetListSelectionSilently." nextSelection := 1]. keyString = '' ifTrue: [" end" "self resetListSelectionSilently." nextSelection := max]. howManyItemsShowing := self numberOfDisplayedItems. keyString = '' ifTrue: [" page up" "self resetListSelectionSilently." nextSelection := 1 max: oldSelection - howManyItemsShowing]. keyString = '' ifTrue: [" page down" "self resetListSelectionSilently." nextSelection := oldSelection + howManyItemsShowing min: max]. (self enabled and: [model okToChange]) ifFalse: [ ^ self ]. "No change if model is locked" oldSelection = nextSelection ifTrue: [ ^ self ]. ((anEvent shiftPressed not and: [ anEvent commandKeyPressed not ]) and: [ self selectionWithKeys ]) ifTrue: [ self resetSelectionIndexes ]. self setIndex: nextSelection. anEvent shiftPressed ifTrue: [ self addAtIndexes: nextSelection ]! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/17/2012 14:57'! updateIconCache self invalidateIconCache! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 12/13/2012 09:44'! retrieveIconMaxSize ^ self model iconMaxSize ifNil: [ 0@0 ]! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 6/21/2013 00:07'! separatorAfter: item at: index ^ self model separatorAfter: item at: index! ! !NewList methodsFor: 'accessing' stamp: 'CamilloBruni 11/8/2013 16:36'! allowToSelect ^ allowToSelect value! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! renderer: anObject renderer value: anObject! ! !NewList methodsFor: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/29/2012 19:46'! whenSelectedItemsChangedDo: aBlock selectedItems whenChangedDo: aBlock! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! headerHeight: anObject headerHeight value: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! unselectOnChange: anObject unselectOnChange value: anObject! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/29/2012 17:50'! addAtIndexes: anIndex selectedIndexes at: anIndex put: true! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:28'! selectionWithKeys ^ selectionWithKeys value! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/16/2012 17:49'! resetListSelectionSilently selectedIndexes removeAll! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/26/2012 18:54'! adapter ^ self model! ! !NewList methodsFor: 'looks & colors' stamp: 'BenjaminVanRyseghem 11/23/2012 15:03'! defaultItemColor ^ Color black! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 10/17/2013 16:31'! updateHeaderTitle self isInitialized ifFalse: [ ^ self ]. headerTitle value: self retrieveHeaderTitle.! ! !NewList methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 1/28/2013 13:20'! on: eventName send: selector to: recipient renderer on: eventName send: selector to: recipient! ! !NewList methodsFor: 'events - keyboard' stamp: 'MarcusDenker 10/16/2013 18:01'! basicKeyPressed: aChar | nextSelection milliSeconds slowKeyStroke oldSelection | nextSelection := oldSelection := self selectedIndex. milliSeconds := Time millisecondClockValue. slowKeyStroke := milliSeconds - lastKeystrokeTime > 500. lastKeystrokeTime := milliSeconds. aChar = Character space ifTrue: [ self clickOnSelectedItem. ^ self secondSelection: 0 ]. self ensureFullDisplayListCache. slowKeyStroke ifTrue: ["forget previous keystrokes and search in following elements" lastKeystrokes := aChar asLowercase asString.] ifFalse: ["append quick keystrokes but don't move selection if it still matches" lastKeystrokes :=String streamContents: [:s | s << lastKeystrokes << aChar asLowercase asString ]]. "Get rid of blanks and style used in some lists" nextSelection := displayListCache findFirst: [:a | a ifNil: [ false "in case it's not loaded yet" ] ifNotNil: [:e | e beginsWith: lastKeystrokes fromList: self ]]. nextSelection isZero ifTrue: [ ^ self secondSelection: 0 ]. "No change if model is locked" model okToChange ifFalse: [ ^ self ]. "No change if model is locked" "The following line is a workaround around the behaviour of OBColumn>>selection:, which deselects when called twice with the same argument." oldSelection = nextSelection ifTrue: [ ^ self ]. self secondSelection: nextSelection. ! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:29'! drawColor ^ drawColor value! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/29/2012 16:29'! resetSelectionIndexes selectedIndexes removeAll! ! !NewList methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! endOfInitialization isInitialized value: true. self updateItems. self updateDisplayListCache. self updateListSize. self updateHeaderTitle. self updateHeaderHeight. self updateAllowToSelect. self updateRenderer. selectedItem value: self retrieveSelectedItem. selectedItems value: self retrieveSelectedItems. listCache whenChangedDo: [:e | listSize value: e size. self updateDisplayListCache. self unselectOnChange ifTrue: [ self deselectAll ]. self updateScrollbars ]. listSize whenChangedDo: [:e | self updateRenderer ]. headerTitle whenChangedDo:[:e | self updateHeaderHeight ]. secondSelection whenChangedDo: [:idx | self setViewToIndex: idx. self renderer updateRectFor: idx ]. selectedIndex whenChangedDo: [:newIndex :oldIndex | selectedItem value: self retrieveSelectedItem. self renderer updateRectFor: oldIndex. ]. selectedIndexes whenChangedDo: [:newIndex :oldIndex | selectedItems value: self retrieveSelectedItems ]. headerTitle whenChangedDo: [:t | self renderer invalidHeader ].! ! !NewList methodsFor: 'looks & colors' stamp: 'BenjaminVanRyseghem 11/23/2012 16:05'! font ^ self theme listFont! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:43'! selectAll self isMultipleSelection ifFalse: [ ^ self ]. 1 to: self listSize do: [: i | selectedIndexes value at: i put: true ]. selectedIndexes valueChanged. self secondSelection: 0. selectedIndex value: self listSize. self changed.! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:28'! model: anObject model value ifNotNil: [:m | m removeDependent: self ]. anObject ifNotNil: [anObject addDependent: self ]. model value: anObject! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 10/17/2013 16:31'! updateIconMaxSize iconMaxSize value: self retrieveIconMaxSize! ! !NewList methodsFor: 'layout' stamp: 'BenjaminVanRyseghem 12/17/2012 14:10'! privateFullBounds ^ self bounds! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:28'! renderer ^ renderer value! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/25/2012 02:21'! clickOnSelectedItem | item | item := self itemAtIndex: self selectedIndex. (item respondsTo: #click:) ifTrue: [ item click: MouseEvent new ]! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 5/1/2013 08:53'! wantsDroppedMorph: aMorph event: anEvent inMorph: source self dropEnabled ifFalse: [ ^ false ]. ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: source! ! !NewList methodsFor: 'updating - private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:31'! updateRenderer | morph | self flag: 'Can we keep the same instead of removing it ?'. self scroller removeAllMorphs. morph := NewListRenderer on: self. morph color: self color; width: self scroller width" +10"; hasHeader: self hasHeader; height: (self listSize*self itemHeight+self headerHeight). self scroller addMorph: morph. renderer value: morph.! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! listSize: anObject listSize value: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! isMultipleSelection: anObject isMultipleSelection value: anObject! ! !NewList methodsFor: 'looks & colors' stamp: 'BenjaminVanRyseghem 11/23/2012 18:07'! selectedBackgroundColor ^ self theme settings selectionColor! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/13/2012 09:46'! itemHeight ^ (self font height max: self iconMaxSize y) + (2*self itemHalfOffSet)! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:28'! unselectOnChange ^ unselectOnChange value! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 12/16/2012 17:19'! retrieveListSize ^ self model getListSize ifNil: [ listCache size ]! ! !NewList methodsFor: 'events - mouse' stamp: 'BenjaminVanRyseghem 12/13/2012 14:40'! mouseUpOnItemAt: index event: anEvent | item | index isZero ifTrue: [ ^ self ]. index > self listSize ifTrue: [ ^ self ]. item := self itemAtIndex: index. (item respondsTo: #mouseDown:) ifTrue: [ item mouseDown: anEvent ]! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:29'! enabled: aBoolean "Set the value of enabled" enabled value = aBoolean ifTrue: [^self]. enabled value: aBoolean. self changed: #enabled. self adoptPaneColor: self paneColor; changed! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2012 19:55'! selectedIndexes ^ (selectedIndexes select: [:ass | ass value ]) keys sort! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! secondSelection: anObject secondSelection value: anObject! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! updateAllowToSelect allowToSelect value: self retrieveAllowToSelect! ! !NewList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2012 16:30'! isSelectedIndex: index ^ self isMultipleSelection ifTrue: [ selectedIndexes at: index ifAbsent: [ ^false ]] ifFalse: [ self selectedIndex = index ]! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! deselectAll selectedIndex value: 0. self isMultipleSelection ifTrue: [ selectedIndexes removeAll. self secondSelection: 0 ]. self changed.! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 10/17/2013 16:31'! updateItems self isInitialized ifFalse: [ ^ self ]. listCache value: self retrieveItems! ! !NewList methodsFor: 'geometry' stamp: 'BenjaminVanRyseghem 11/24/2012 01:32'! extent: newExtent super extent: newExtent. "Change listMorph's bounds to the new width. It is either the size of the widest list item, or the size of self, whatever is bigger" self renderer ifNil: [ ^ self ]. self renderer width: ((self width-40) max: (self renderer maxWidth))! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 7/18/2013 14:25'! update: aParameter aParameter == #getItems ifTrue: [ ^ self updateItems ]. aParameter == #getListSize ifTrue: [ ^ self updateListSize ]. aParameter == #getHeaderTitle ifTrue: [ ^ self updateHeaderTitle ]. aParameter == #iconMaxSize ifTrue: [ ^ self updateIconMaxSize ]. aParameter == #iconForItem:at: ifTrue: [ ^ self updateIconCache ]. aParameter == #resetSelectedIndexes ifTrue: [ ^ self deselectAll ]. aParameter == #allowToSelect ifTrue: [ ^ self updateAllowToSelect ]. aParameter == #invalidateIcons ifTrue: [ ^ self invalidateIconCache ]. aParameter isArray ifFalse: [ ^ self ]. aParameter size == 2 ifFalse: [ ^ self ]. aParameter first = #deSelectOnReclick: ifTrue: [ self deSelectOnReclick: aParameter second ]. aParameter first = #isMultipleSelection: ifTrue: [ self isMultipleSelection: aParameter second ]. aParameter first = #unselectOnChange: ifTrue: [ self unselectOnChange: aParameter second ]. aParameter first = #hasHeader: ifTrue: [ self hasHeader: aParameter second ]. aParameter first = #setIndex: ifTrue: [ self setIndex: aParameter second ].! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:30'! runningProcesses: aCollection runningProcesses value: aCollection! ! !NewList methodsFor: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/24/2012 19:07'! whenHeaderIsClickedDo: aBlock clickOnHeader whenChangedDo: aBlock! ! !NewList methodsFor: 'looks & colors' stamp: 'BenjaminVanRyseghem 11/24/2012 14:48'! colorForItem: item at: index ^ (self isSelectedIndex: index) ifTrue: [ self theme currentSettings selectionTextColor ] ifFalse: [ self defaultItemColor ]! ! !NewList methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 10/17/2013 16:29'! iconMaxSize ^ iconMaxSize value ifNil: [ iconMaxSize value: self retrieveIconMaxSize ]! ! !NewList methodsFor: 'looks & colors' stamp: 'BenjaminVanRyseghem 11/23/2012 14:48'! secondSelectionColor ^ self theme settings secondarySelectionColor! ! !NewList methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/26/2013 01:53'! iconForItem: anItem at: anIndex ^ iconCache at: anItem ifAbsentPut: [ (self model iconForItem: anItem at: anIndex) asMorph ]! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:29'! hasHeader ^ headerHeight value ~~ 0! ! !NewList methodsFor: 'updating - private' stamp: 'BenjaminVanRyseghem 11/27/2012 01:33'! ensureFullDisplayListCache [ listCache doWithIndex: [:e :i || process | process := [ | item | item := self model getDisplayForItem: e at: i. (displayListCache at: i) ifNil: [ displayListCache at: i put: item ]] fork. runningProcesses at: i put: process ]] fork. ! ! !NewList methodsFor: 'events - mouse' stamp: 'BenjaminVanRyseghem 5/1/2013 08:42'! doubleClick: event self model doubleClick: event! ! !NewList methodsFor: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/26/2012 18:47'! whenSelectedIndexChangedDo: aBlock selectedIndex whenChangedDo: aBlock! ! !NewList class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/26/2012 18:38'! adapterOn: aModel ^ NewListAdapter on: aModel! ! !NewList class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/26/2012 18:35'! on: aListModel ^ self new model: aListModel; yourself! ! !NewList class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/26/2012 18:51'! on: aModel getItemsSelector: getItems setIndexSelector: setIndex getDisplaySelector: getDisplay | listModel instance | listModel := self adapterOn: aModel. listModel on: aModel getItemsSelector: getItems setIndexSelector: setIndex getDisplaySelector: getDisplay. instance := self on: listModel. listModel list: instance. ^ instance! ! !NewList class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 12/13/2012 12:25'! on: aModel getItemsSelector: getItems getDisplaySelector: getDisplay | listModel instance | listModel := self adapterOn: aModel. listModel on: aModel getItemsSelector: getItems getDisplaySelector: getDisplay. instance := self on: listModel. listModel list: instance. ^ instance! ! !NewListAdapter commentStamp: ''! NewListAdapter is used to link the model and the list. It holds the "pluggable" part of the widget, aka the definition of the API! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 20:28'! deSelectOnReclick: aBoolean self list deSelectOnReclick: aBoolean! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! getItemsSelector: anObject getItemsSelector value: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! getListSizeSelector ^ getListSizeSelector value! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 20:27'! dragEnabled: aBoolean self list dragEnabled: aBoolean! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 20:28'! dropEnabled: aBoolean self list dropEnabled: aBoolean! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'StephaneDucasse 1/4/2014 22:46'! separatorAfter: item at: index "returns whether there should be a separator after an item displayed at a given index." ^ separatorSelector value ifNotNil: [ self model perform: separatorSelector with: item with: index ] ifNil: [ false ]! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 08:45'! color: aColor self list color: aColor! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 20:55'! getDisplayForItem: item at: index ^ self getDisplaySelector ifNil: [ item printString ] ifNotNil: [ :s | self model perform: s withEnoughArguments: {item. index} ]! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! getDisplaySelector ^ getDisplaySelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! getIndexSelector: anObject getIndexSelector value: anObject! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 21:26'! getRawItemAt: index ^ self getItemAtIndexSelector ifNil: [ self list cacheAt: index ] ifNotNil: [:selector | self model perform: selector with: index ]! ! !NewListAdapter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize "Initialization code for NewListAdapter" super initialize. doubleClickSelector := nil asValueHolder. dragItemSelector := nil asValueHolder. dropItemSelector := nil asValueHolder. getDisplaySelector := nil asValueHolder. getHeaderTitleSelector := nil asValueHolder. getMenuSelector := nil asValueHolder. getIndexSelector := nil asValueHolder. getItemAtIndexSelector := nil asValueHolder. getItemsSelector := nil asValueHolder. getListSizeSelector := nil asValueHolder. keyStrokeSelector := nil asValueHolder. lastKeystrokeTime := nil asValueHolder. lastKeystrokes := nil asValueHolder. model := nil asValueHolder. list := nil asValueHolder. setIndexSelector := nil asValueHolder. wantsDropSelector := nil asValueHolder. getMenuTitleSelector := nil asValueHolder. getIconSelector := nil asValueHolder. getIconMaxSizeSelector := nil asValueHolder. getIndexesSelector := nil asValueHolder. separatorSelector := nil asValueHolder! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 09:52'! allowToSelect ^ self allowToSelectSelector ifNil: [ true ] ifNotNil: [ :s | self model perform: s ]! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! dragItemSelector ^ dragItemSelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! keyStrokeSelector: anObject keyStrokeSelector value: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! list ^ list value! ! !NewListAdapter methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/16/2012 20:09'! setIndexFromModel | index | index := self getIndexSelector ifNil: [ ^ self ] ifNotNil: [:s | self model perform: s ]. self list setIndex: index.! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/29/2012 20:06'! unselectOnChange: aBoolean self list unselectOnChange: aBoolean! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'MarcusDenker 10/16/2013 18:02'! getMenu: shiftKeyState "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | menu aMenu aTitle | self getMenuSelector isNil ifTrue: [ ^ nil ]. menu := UIManager default newMenuIn: self for: self model. aTitle := self getMenuTitleSelector ifNotNil: [ self model perform: self getMenuTitleSelector ]. self getMenuSelector numArgs = 1 ifTrue: [ aMenu := self model perform: self getMenuSelector with: menu. aTitle ifNotNil: [ aMenu addTitle: aTitle ]. ^ aMenu ]. self getMenuSelector numArgs = 2 ifTrue: [ aMenu := self model perform: self getMenuSelector with: menu with: shiftKeyState. aTitle ifNotNil: [ aMenu addTitle: aTitle ]. ^ aMenu ]. ^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! getMenuTitleSelector: anObject getMenuTitleSelector value: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! getMenuSelector: aSelector getMenuSelector value: aSelector! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! getIconMaxSizeSelector: anObject getIconMaxSizeSelector value: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! getHeaderTitleSelector: anObject getHeaderTitleSelector value: anObject! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 21:10'! handlesDoubleClick ^ self doubleClickSelector notNil! ! !NewListAdapter methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/26/2012 18:54'! on: aModel getItemsSelector: getItems setIndexSelector: setIndex getDisplaySelector: getDisplay ^ self model: aModel; getItemsSelector: getItems; setIndexSelector: setIndex; getDisplaySelector: getDisplay; yourself! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 08:00'! acceptDroppingMorph: aMorph atIndex: index event: evt inMorph: source self dropItemSelector ifNotNil: [| item | item := aMorph passenger first. self model perform: self dropItemSelector with: item with: index ] ifNil: [ self model acceptDroppingMorph: aMorph event: evt inMorph: source ]! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! doubleClickSelector: anObject doubleClickSelector value: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! getItemsSelector ^ getItemsSelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! getIndexSelector ^ getIndexSelector value! ! !NewListAdapter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! endOfInitialization getItemsSelector whenChangedDo: [:e | self list updateItems ]. setIndexSelector value ifNotNil: [:s | self list whenSelectedIndexChangedDo: [:a :b :c :d | self model perform: s withEnoughArguments: {a. b. c. d } ]]. getHeaderTitleSelector whenChangedDo: [:s | self list hasHeader: (s notNil) ]. self list endOfInitialization! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! getItemAtIndexSelector: aSelector getItemAtIndexSelector value: aSelector! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 21:05'! getHeaderHeight self flag: '25 should not be hardcoded'. ^ self getHeaderTitleSelector ifNil: [ 0 ] ifNotNil: [:s | 25 ]! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! model: anObject model value ifNotNil: [:m | m removeDependent: self ]. anObject ifNotNil: [anObject addDependent: self ]. model value: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! dropItemSelector ^ dropItemSelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! wantsDropSelector ^ wantsDropSelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! getItemAtIndexSelector ^ getItemAtIndexSelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! getMenuTitleSelector ^ getMenuTitleSelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'StephaneDucasse 1/4/2014 22:51'! separatorSelector "return selector to be executed to get the separator between two list items." ^ separatorSelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! getIconMaxSizeSelector ^ getIconMaxSizeSelector value! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 08:53'! wantsDroppedMorph: aMorph event: anEvent inMorph: source ^ aMorph dragTransferType == #dragTransfer ifTrue: [ self dropItemSelector ifNil: [ ^ false ]. self wantsDropSelector ifNil: [ ^ true ]. (self model perform: self wantsDropSelector with: aMorph passenger) ] ifFalse: [ self model wantsDroppedMorph: aMorph event: anEvent inMorph: source ]! ! !NewListAdapter methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 11/5/2013 11:21'! transferFor: draggedItem from: aMorph ^ self model transferFor: draggedItem from: aMorph! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! separatorSelector: anObject separatorSelector value: anObject! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 21:03'! getHeaderTitle ^ self getHeaderTitleSelector ifNil: [ '' ] ifNotNil: [:s | self model perform: s ]! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/29/2012 16:42'! isMultipleSelection: aBoolean self list isMultipleSelection: aBoolean! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 1/28/2013 13:33'! keyStrokeAction: anEvent ^ self keyStrokeSelector ifNil: [ false ] ifNotNil: [:s | (self model perform: s withEnoughArguments: { anEvent. ActiveHand shiftPressed}) = true ]! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! getHeaderTitleSelector ^ getHeaderTitleSelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! setIndexSelector: anObject setIndexSelector value: anObject! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 12/16/2012 17:17'! getListSize ^ self getListSizeSelector ifNil: [ nil ] ifNotNil: [:s | self model perform: s ]! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! getIndexesSelector: aSelector getIndexesSelector value: aSelector! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! wantsDropSelector: anObject wantsDropSelector value: anObject! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 21:27'! draggedItemAtIndex: anIndex ^ self dragItemSelector ifNil: [ self getRawItemAt: anIndex ] ifNotNil: [:s | self model perform: s with: anIndex ]! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! dropItemSelector: anObject dropItemSelector value: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! getIconSelector: anObject getIconSelector value: anObject! ! !NewListAdapter methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/17/2012 14:56'! update: aSymbol aSymbol == self getItemsSelector ifTrue: [ ^ self changed: #getItems ]. aSymbol == self getListSizeSelector ifTrue: [ ^ self changed: #getListSize ]. aSymbol == self getHeaderTitleSelector ifTrue: [ ^ self changed: #getHeaderTitle ]. aSymbol == self getIconSelector ifTrue: [ ^ self changed: #iconForItem:at: ]. aSymbol == self getIndexSelector ifTrue: [ ^ self setIndexFromModel ]. aSymbol == self getIndexesSelector ifTrue: [ ^ self setIndexesFromModel ]. aSymbol == #resetSelectedIndexes ifTrue: [ ^ self changed: #resetSelectedIndexes ]. aSymbol == #invalidateIcons ifTrue: [ ^ self changed: #invalidateIcons ]! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! getMenuSelector ^ getMenuSelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! dragItemSelector: anObject dragItemSelector value: anObject! ! !NewListAdapter methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/16/2012 20:38'! setIndexesFromModel | indexes | indexes := self getIndexesSelector ifNil: [ ^ self ] ifNotNil: [:s | self model perform: s ]. self list adoptIndexes: indexes.! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/1/2013 09:52'! allowToSelectSelector ^ allowToSelectSelector! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! keyStrokeSelector ^ keyStrokeSelector value! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 12/16/2012 18:39'! dragPassengersFor: antem inMorph: aMorph ^ self model dragPassengersFor: antem inMorph: aMorph! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/1/2013 09:52'! allowToSelectSelector: aSelector allowToSelectSelector := aSelector! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! doubleClickSelector ^ doubleClickSelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! getIndexesSelector ^ getIndexesSelector value! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 12/13/2012 11:26'! iconForItem: anItem at: anIndex ^ self getIconSelector ifNil: [ nil ] ifNotNil: [:s | self model perform: s withEnoughArguments: {anItem . anIndex} ]! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! list: anObject list value: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! model ^ model value! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 12/13/2012 09:18'! iconMaxSize ^ self getIconMaxSizeSelector ifNil: [ nil ] ifNotNil: [:s | self model perform: s ]! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 12/16/2012 17:17'! getItems ^ self getItemsSelector ifNil: [ nil ] ifNotNil: [:s | self model perform: s ]! ! !NewListAdapter methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 12/13/2012 12:26'! on: aModel getItemsSelector: getItems getDisplaySelector: getDisplay ^ self model: aModel; getItemsSelector: getItems; getDisplaySelector: getDisplay; yourself! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:35'! getListSizeSelector: aSelector getListSizeSelector value: aSelector! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! getDisplaySelector: anObject getDisplaySelector value: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:34'! setIndexSelector ^ setIndexSelector value! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! getIconSelector ^ getIconSelector value! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 08:43'! doubleClick: event self model perform: self doubleClickSelector withEnoughArguments: { event }! ! !NewListAdapter class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/26/2012 18:50'! on: aModel ^ self new model: aModel; yourself! ! !NewListExample commentStamp: ''! I am an example of how to use the NewList. I also provide so comparision with the old List implementation. NewListExample new withNewList; openInWindow. NewListExample new withOldList; openInWindow.! !NewListExample methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/25/2012 03:04'! menu: aMenu shifted: aBoolean aMenu add: 'Foo' target: self selector: #halt. ^ aMenu! ! !NewListExample methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 5/1/2013 09:27'! headerTitle ^ 'My Title'! ! !NewListExample methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/29/2012 19:36'! buildTextMorph ^ PluggableTextMorph new! ! !NewListExample methodsFor: 'initialize' stamp: 'MarcusDenker 10/16/2013 18:00'! openInWorld | panel | panel := PanelMorph new. panel changeProportionalLayout; addMorph: listMorph fullFrame: ((0@0 corner: 1@0.5) asLayoutFrame); addMorph: textMorph fullFrame: ((0@0.5 corner: 1@1) asLayoutFrame). panel openInWorld! ! !NewListExample methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2012 19:36'! toggleTitle toggleTitle := toggleTitle not. self changed: #title. self changed: #getItems.! ! !NewListExample methodsFor: 'morphic' stamp: 'EstebanLorenzano 5/15/2013 11:16'! iconFor: item at: anIndex | icon | icon := Smalltalk ui icons iconNamed: #testGreenIcon. "^ icon" ^ IconicButton new target: self; actionSelector: #halt; labelGraphic: icon ; color: Color transparent; extent: 12 @ 12; helpText: 'Run the tests'; borderWidth: 0.! ! !NewListExample methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/23/2012 17:47'! getIndex ^ index! ! !NewListExample methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 5/21/2013 18:03'! displayItem: anItem ^ anItem asStringMorph color: Color red; yourself" ^ TextInputFieldModel new ghostText: anItem asString."! ! !NewListExample methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 12/13/2012 09:19'! iconMaxSize ^ 16@16! ! !NewListExample methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 5/1/2013 09:53'! allowToSelect ^ false.! ! !NewListExample methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:06'! initialize super initialize. pluggable := false. index := 0. toggleTitle := true. rawList := (1 to: 10) asOrderedCollection. textMorph := self buildTextMorph! ! !NewListExample methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/1/2013 09:53'! buildMorph | list | list := NewList on: self getItemsSelector: #getItems setIndexSelector: #setIndex: getDisplaySelector: #displayItem:. list adapter getHeaderTitleSelector: #title; getMenuSelector: #menu:shifted:; dragEnabled: true; dropEnabled: true; allowToSelectSelector: #allowToSelect; isMultipleSelection: true; deSelectOnReclick: true; getHeaderTitleSelector: #headerTitle; doubleClickSelector: #halt; dropItemSelector: #drop:at:; getIconSelector: #iconFor:at:; getIconMaxSizeSelector: #iconMaxSize; endOfInitialization. list whenHeaderIsClickedDo: [ self toggleTitle ]. list whenSelectedItemsChangedDo: [:items | textMorph ifNotNil: [ textMorph setText: (String streamContents: [:s | items do: [:e | s << e printString ; cr ]] )]] . ^ list! ! !NewListExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/23/2012 15:47'! listMorph ^ listMorph! ! !NewListExample methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/25/2012 22:22'! drop: anItem at: anIndex rawList remove: anItem. rawList add: anItem beforeIndex: anIndex. self changed: #getItems! ! !NewListExample methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/25/2012 22:21'! getItems ^ toggleTitle ifTrue: [ rawList ] ifFalse: [ rawList reversed ]! ! !NewListExample methodsFor: 'initialize' stamp: 'MarcusDenker 10/16/2013 18:00'! openInWindow | panel | panel := PanelMorph new. panel changeProportionalLayout; addMorph: listMorph fullFrame: ((0@0 corner: 1@0.5) asLayoutFrame); addMorph: textMorph fullFrame: ((0@0.5 corner: 1@1) asLayoutFrame). panel openInWindow! ! !NewListExample methodsFor: 'morphic' stamp: 'MarcusDenker 10/16/2013 18:02'! setIndex: idx pluggable ifFalse: [ ^ self ]. index := idx = index ifTrue: [ 0 ] ifFalse: [ idx ]. self changed: #getIndex! ! !NewListExample methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/25/2012 22:21'! title ^ toggleTitle ifTrue: [ 'Title' ] ifFalse: [ 'Title (reversed)' ]! ! !NewListExample methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/26/2012 17:14'! withNewList listMorph := self buildMorph.! ! !NewListExample methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/26/2012 17:15'! withOldList listMorph := self buildMorphWithOld.! ! !NewListExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/23/2012 15:47'! listMorph: anObject listMorph := anObject! ! !NewListExample methodsFor: 'initialize' stamp: 'MarcusDenker 10/16/2013 18:02'! buildMorphWithOld pluggable := true. ^ PluggableListMorph on: self list: #getItems selected: #getIndex changeSelected: #setIndex: menu: #menu:shifted:! ! !NewListModel commentStamp: ''! | m | m := NewListModel new. m items: (10 to: 50) asOrderedCollection. m headerTitle: 'Fubu'. m setSelectedIndex: 5. m openWithSpec.! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 10:34'! resetSelection "Unselect every items" self changed: #resetSelectedIndexes! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! deSelectOnReclick: aBoolean deSelectOnReclick value: aBoolean! ! !NewListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 5/1/2013 09:02'! whenAllowToSelectChanged: aBlock "Set a block to value when the value of allowToSelect has changed" allowToSelect whenChangedDo: aBlock! ! !NewListModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/12/2013 10:44'! registerEvents items whenChangedDo: [ self changed: #getItems ]. headerTitle whenChangedDo: [ :title | self changed: #getHeaderTitle. self changed: { #hasHeader: . title notNil } ]. deSelectOnReclick whenChangedDo: [ :bool | self changed: { #deSelectOnReclick: . bool } ]. isMultipleSelection whenChangedDo: [ :bool | self changed: { #isMultipleSelection: . bool } ]. unselectOnChange whenChangedDo: [ :bool | self changed: { #unselectOnChange: . bool } ]. handlesDoubleClick whenChangedDo: [ :bool | self changed: { #handlesDoubleClick . bool } ]. menuHolder whenChangedDo: [ :aMenuModel :oldMenu | (oldMenu isNil or: [ oldMenu isBlock ]) ifFalse: [ oldMenu neglect: self ]. (aMenuModel isNil or: [ aMenuModel isBlock ]) ifFalse: [ aMenuModel applyTo: self ] ]! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! setSelectedIndex: anIndex "Set the index of the item you want to be selected" self widget ifNil: [ selectedIndex value: anIndex ] ifNotNil: [ self changed: { #setIndex: .anIndex } ]! ! !NewListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 5/1/2013 10:31'! whenSelectionChanged: aBlock "Set a block to value when the selection of the list has changed" self whenSelectionIndexChanged: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/21/2013 00:10'! separatorAfter: item at: index ^ self separatorBlock cull: item cull: index! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! separatorBlock: aBlock separatorBlock value: aBlock! ! !NewListModel methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! selectedItem: anIndex selectedItem value: anIndex! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! getDisplayForItem: item at: index ^ displayBlock value cull: item cull: index! ! !NewListModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize "Initialization code for NewListModel" super initialize. items := #() asReactiveVariable. deSelectOnReclick := false asReactiveVariable. draggedItemAtIndex := [ :index | self getRawItemAt: index ] asReactiveVariable. displayBlock := [ :object | object asStringOrText ] asReactiveVariable. headerHeight := 0 asReactiveVariable. headerTitle := nil asReactiveVariable. menuTitle := nil asReactiveVariable. menuHolder := nil asReactiveVariable. handlesDoubleClick := false asReactiveVariable. doubleClick := [ ] asReactiveVariable. iconHolder := [ nil ] asReactiveVariable. iconMaxSize := nil asReactiveVariable. keyStrokeAction := [ false ] asReactiveVariable. isMultipleSelection := false asReactiveVariable. unselectOnChange := false asReactiveVariable. sortingBlock := self defaultSortingBlock asReactiveVariable. filteringBlock := self defaultFilteringBlock asReactiveVariable. allowToSelect := true asReactiveVariable. listAnnouncer := Announcer new. headerClicked := [] asReactiveVariable. selectedIndex := 0 asReactiveVariable. selectedItem := nil asReactiveVariable. selectedIndexes := #() asReactiveVariable. selectedItems := #() asReactiveVariable. separatorBlock := [ false ] asReactiveVariable. self registerEvents! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! getRawItemAt: index ^ items value at: index ifAbsent: [ nil ]! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! allowToSelect ^ allowToSelect value! ! !NewListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 5/1/2013 10:30'! whenMultiSelectionChanged: aBlock "Set a block to value when the multiSelection value has changed" isMultipleSelection whenChangedDo: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! headerTitle: aTitle headerTitle value: aTitle! ! !NewListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 10/17/2013 17:01'! whenListChanged: aBlock "Specify a block to value after the contents of the list has changed" "Basically when you set a new list of items" | block | block := [ :announcement :ann | aBlock cull: announcement newValue cull: announcement oldValue cull: announcement cull: ann ]. listAnnouncer when: ValueChanged do: block! ! !NewListModel methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! selectedIndex: anIndex selectedIndex value: anIndex! ! !NewListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 5/1/2013 10:34'! whenSelectedItemChanged: aBlock "Set a block to value when the select item is changed" selectedItem whenChangedDo: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! allowToSelect: aBoolean "Set if the list items can be selected or not" allowToSelect value: aBoolean. aBoolean ifFalse: [ self resetSelection ].! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! isMultipleSelection ^ isMultipleSelection value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! unselectOnChange: aBoolean unselectOnChange value: aBoolean.! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! selectedIndex "Return the index of the selected item In the case of a multiple selection list, it returns the last selected item" ^ selectedIndex value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! filteringBlock "Return the filtering of the items" ^ filteringBlock value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/1/2013 15:46'! getMenu: shiftKeyState | menu | menuHolder value ifNil: [ ^ nil ]. menuHolder value isBlock ifFalse: [ ^ menuHolder value ]. menu := MenuModel new. menuHolder value cull: menu cull: shiftKeyState. menuTitle value ifNotNil: [ :title | menu title: title ]. ^ menu ! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! filteringBlock: aBlock "To set the filtering of the items" filteringBlock value: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! handlesDoubleClick ^ handlesDoubleClick value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! selectedItems "Return all the selected items in the case of a multiple selection list" ^ selectedItems value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! sortingBlock "Return the ordering of the items" ^ sortingBlock value! ! !NewListModel methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! selectedItems: anIndex selectedItems value: anIndex! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! icons: aBlock iconHolder value: aBlock! ! !NewListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 5/1/2013 10:31'! whenSortingBlockChanged: aBlock "Set a block to value when the sorting block has changed" sortingBlock whenChangedDo: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! sortingBlock: aBlock "To set the ordering of the items" sortingBlock value: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 10:26'! setSelectedItem: anItem "Set the item you want to be selected" | index | index := self listItems identityIndexOf: anItem ifAbsent: [ ^ self ]. self setSelectedIndex: index! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! resetSortingBlock "Reset the sortering block with the default value which consists in not sorting" sortingBlock value: self defaultSortingBlock! ! !NewListModel methodsFor: 'protocol-events' stamp: 'CamilloBruni 5/2/2013 22:03'! whenHandlesDoubleClickChanged: aBlock "Set a block to value when the handlesDoubleClick value has changed" handlesDoubleClick whenChangedDo: aBlock! ! !NewListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 5/1/2013 10:30'! whenDisplayBlockChanged: aBlock "Set a block to value when the filtering block block has changed" displayBlock whenChangedDo: aBlock! ! !NewListModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! headerClicked: aBlock headerClicked value: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 17:02'! items: aList "Set the items of the list. aList is a collection of your domain specific items. Use a two stages notification (issue 7420)." | oldContents | oldContents := items value. items value: (aList sorted: sortingBlock value). listAnnouncer announce: (ValueChanged oldValue: oldContents newValue: items value)! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! getHeaderHeight ^ headerHeight value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 09:02'! beSingleSelection "Make list selection single" self isMultipleSelection: false! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! multiSelection: aBoolean "Make the list seelction become multiple if aBoolean is true. Otherwise set the selection as single" isMultipleSelection value: aBoolean. ! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 10:30'! updateList "Refresh the list" self changed: #getItems.! ! !NewListModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/1/2013 09:12'! defaultSortingBlock ^ [:a :b | true]! ! !NewListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 5/1/2013 10:30'! whenFilteringBlockChanged: aBlock "Set a block to value when the filtering block block has changed" filteringBlock whenChangedDo: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! separatorBlock ^ separatorBlock value! ! !NewListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 5/1/2013 09:02'! whenMenuChanged: aBlock "Set a block to value when the menu block has changed" menuHolder whenChangedDo: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! isMultipleSelection: aBoolean isMultipleSelection value: aBoolean! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! unselectOnChange ^ unselectOnChange value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! doubleClickAction "Return the block evaluated on double click" ^ doubleClick value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! handlesDoubleClick: aBoolean "Enable or disable double click on the list." handlesDoubleClick value: aBoolean! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! menu: aBlock "Set the block used to defined the menu" menuHolder value: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! doubleClickAction: aBlock "Set the block evaluated on double click." doubleClick value: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! resetFilteringBlock "Reset the filtering block with the default value which consists in showing everything" filteringBlock value: self defaultFilteringBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! keyStrokeAction: anEvent ^ keyStrokeAction value cull: anEvent! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 08:29'! getListSize ^ self getItems size! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! selectedItem "Return the selected item. In the case of a multiple selection list, it returns the last selected item" ^ selectedItem value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! getHeaderTitle ^ headerTitle value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 09:02'! beMultipleSelection "Make list selection multiple" self isMultipleSelection: true! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! selectedIndexes "Return the indexes of selected items on the case of a multiple selection list" ^ selectedIndexes value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! draggedItemAtIndex: anIndex ^ draggedItemAtIndex value cull: anIndex.! ! !NewListModel methodsFor: 'protocol-events' stamp: 'CamilloBruni 5/2/2013 21:56'! whenDoubleClickActionChanged: aBlock "Set a block to value when the doubleClick value has changed" doubleClick whenChangedDo: aBlock! ! !NewListModel methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! selectedIndexes: anIndex selectedIndexes value: anIndex! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! menu "Return the block used to defined the menu" ^ menuHolder value! ! !NewListModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/1/2013 09:12'! defaultFilteringBlock ^ [:col | col]! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! listItems "Return the items of the list. They are your domain specific items" ^ listItemsCache ifNil: [ listItemsCache := filteringBlock value value: items value ] ! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! displayBlock: aBlock "Set the one argument block used to wrap your domain specific items. The block should return something that can be displayed in a list - like a String or a Text" displayBlock value: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! iconMaxSize ^ iconMaxSize value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! iconForItem: anItem at: anIndex ^ iconHolder value cull: anItem cull: anIndex! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! hasHeader ^ headerTitle value notNil! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/1/2013 09:02'! listSize "Return the size of the list" ^ self listItems size! ! !NewListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 5/1/2013 10:31'! whenSelectedIndexChanged: aBlock "Set a block to value when the selection index has changed" selectedIndex whenChangedDo: aBlock! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! getItems ^ items value! ! !NewListModel methodsFor: 'list protocol-events' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! headerClicked headerClicked value value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! iconMaxSize: aPoint iconMaxSize value: aPoint! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! displayBlock "Return the one argument block used to wrap your domain specific items. The block should return something that can be displayed in a list - like a String or a Text" ^ displayBlock value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! multiSelection "Return true if the list has a multiple selection. False if the list has a single selection" ^ isMultipleSelection value! ! !NewListModel methodsFor: '*Deprecated30' stamp: 'BenjaminVanRyseghem 5/1/2013 10:33'! whenSelectionIndexChanged: aBlock self deprecated: 'Use #whenSelectedIndexChanged: instead' on: '1 May 2013' in: '30078'! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! deSelectOnReclick ^ deSelectOnReclick value! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! doubleClick: event doubleClick value cull: event! ! !NewListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/1/2013 13:39'! defaultSpec ^ #(NewListAdapter adapt: #(model))! ! !NewListModel class methodsFor: 'examples' stamp: 'SvenVanCaekenberghe 11/18/2013 16:23'! exampleWithMenu "self exampleWithMenu" | menu group1 item11 item12 group2 item21 item22 model| menu := MenuModel new. group1 := MenuGroupModel new. item11 := MenuItemModel new name: [ DateAndTime now asString ]; enabled: [ DateAndTime now seconds even ]; yourself. item12 := MenuItemModel new name: 'item2'; shortcut: $b shift command mac | $b alt shift win | $b alt shift unix; action: [ self halt ]; enabled: true; yourself. group1 addMenuItem: item11. group1 addMenuItem: item12. group1 autoRefresh: true. group2 := MenuGroupModel new. item21 := MenuItemModel new name: 'item3'; state: [ DateAndTime now seconds odd ]; description: [ DateAndTime now asString ]; yourself. item22 := MenuItemModel new name: 'item4'; subMenu: (MenuModel new autoRefresh: true; addGroup: [ :g | g addItem: [ :i| i name: [ 'sub' , ((Character value: (DateAndTime now seconds + 60))) asString ]; action: [ self halt ]; shortcut: $d shift command mac | $d alt shift win | $d alt shift unix ]]; yourself); yourself. group2 addMenuItem: item21. group2 addMenuItem: item22. menu addMenuGroup: group1. menu addMenuGroup: group2. menu title: 'Test'. model := NewListModel new. model menu: menu. model openWithSpec! ! !NewListModel class methodsFor: 'examples' stamp: 'BenjaminVanRyseghem 11/12/2013 10:43'! exampleWithMenu2 "self exampleWithMenu2" | oddMenu evenMenu model | oddMenu := MenuModel new addGroup: [ :group | group addItem: [ :item | item name: 'Odd'; shortcut: $o command; action: [ self logCr: 'o' ] ] ]. evenMenu := MenuModel new addGroup: [ :group | group addItem: [ :item | item name: 'Even'; shortcut: $e command; action: [ self logCr: 'e' ] ] ]. model := NewListModel new. model openWithSpec. model items: (1 to: 10) asOrderedCollection. model whenSelectedItemChanged: [ :number | number odd ifTrue: [ model menu: oddMenu ] ifFalse: [ model menu: evenMenu ] ]! ! !NewListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/13/2014 15:23'! adapterName ^ #NewListAdapter! ! !NewListRenderer commentStamp: ''! NewListRenderer is the morph contained by a NewList used to render all the items and manage mouse events.! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 22:17'! rawItemAtIndex: index ^ self listSource rawItemAtIndex: index! ! !NewListRenderer methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 5/1/2013 07:47'! drawHeaderOn: aCanvas | drawBounds top item itemColor backgroundColor height width deltaY deltaX | drawBounds := self owner bounds. top := self topDifference. drawBounds := -3 @ top corner: drawBounds right @ top + self headerHeight. aCanvas fillRectangle: drawBounds fillStyle: ((GradientFillStyle ramp: {(0 -> (Color r: 0.854 g: 0.836 b: 0.806)). (1 -> Color gray muchLighter lighter)}) origin: drawBounds left @ drawBounds bottom; direction: 0 @ self headerHeight negated asFloat; normal: 0 @ 1; radial: false; yourself). item := self headerTitle. itemColor := Color black. backgroundColor := self backgroundColorForIndex: 0. height := item heightToDisplayInList: self. width := item widthToDisplayInList: self. deltaY := ((drawBounds height - height) / 2) asInteger. deltaX := ((self owner width - width) / 2) asInteger. drawBounds := drawBounds translateBy: deltaX @ deltaY. item listRenderOn: aCanvas atRow: 0 bounds: drawBounds color: itemColor backgroundColor: backgroundColor from: self! ! !NewListRenderer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 15:58'! releaseKeyboardFocus ActiveHand releaseKeyboardFocus. self listSource changed! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:32'! potentialDropIndex: anInteger potentialDropIndex value: anInteger! ! !NewListRenderer methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize super initialize. wantsSteps := false. listSource := nil asValueHolder. itemHeight := nil asValueHolder. maxWidth := 0 asValueHolder. hasHeader := false asValueHolder. potentialDropIndex := 0 asValueHolder. steppingTime := 100. mouseDownIndex := 0 asValueHolder. listSource whenChangedDo: [:e | itemHeight value: e itemHeight. e whenItemsChangedDo: [ maxWidth value: 0 ]]. potentialDropIndex whenChangedDo: [:new :old | self updateRectFor: new and: old ]. mouseDownIndex whenChangedDo: [:new :old | (old ~~ 0 and: [ new ~~ 0 ]) ifTrue: [ self updateRectFor: old and: new ] ifFalse: [ old isZero ifFalse: [self updateRectFor: old ]. new isZero ifFalse: [self updateRectFor: new ]]].! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! mouseDownIndex ^ mouseDownIndex value! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:32'! maxWidth: anInteger maxWidth value: anInteger! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 19:41'! dropEnabled ^ self listSource dropEnabled! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 12/13/2012 09:06'! gapBetweenIconAndItem ^ self listSource iconMaxSize ifNil: [ 0 ] ifNotNil: [ 4 ]! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/25/2012 19:41'! isPotentialDrop: anIndex ^ anIndex == self potentialDropIndex! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 16:02'! dragItemSelector ^ self listSource dragItemSelector! ! !NewListRenderer methodsFor: 'stepping and presenter' stamp: 'BenjaminVanRyseghem 11/25/2012 21:04'! stepTime ^ steppingTime! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 12/16/2012 17:44'! takeKeyboardFocus self listSource takeKeyboardFocus! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 02:34'! isMultipleSelection ^ self listSource isMultipleSelection! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 00:53'! selectedIndex ^ self listSource selectedIndex! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/29/2012 19:23'! drawBackgroundForItem: item at: index on: aCanvas color: aColor | frame | frame := self selectionFrameForItem: item at: index. aCanvas fillRectangle: frame color: aColor! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 13:33'! headerHeight ^ self listSource headerHeight! ! !NewListRenderer methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 6/21/2013 00:06'! drawOn: aCanvas | first last | aCanvas fillRectangle: self fullBounds color: self drawColor. first := self topVisibleIndexForCanvas: aCanvas. last := self bottomVisibleIndexForCanvas: aCanvas. self listSize isZero ifTrue: [ last := 0 ]. first to: last do: [ :index || item | item := self itemAtIndex: index. self drawBackgroundForItem: item at: index on: aCanvas. self drawItem: item at: index on: aCanvas. (self separatorAfter: item at: index) ifTrue: [ self drawSeparatorForItem: item at: index on: aCanvas ]]. self hasHeader ifTrue: [ self drawHeaderOn: aCanvas ].! ! !NewListRenderer methodsFor: 'menu' stamp: 'BenjaminVanRyseghem 11/25/2012 02:59'! getMenu: shiftKeyState "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | aMenu | aMenu := self listSource getMenu: shiftKeyState. aMenu ifNotNil: [ aMenu commandKeyHandler: self ]. ^ aMenu! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 5/1/2013 08:42'! handlesDoubleClick ^ self listSource handlesDoubleClick! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 00:12'! itemHalfOffSet ^ self listSource itemHalfOffSet! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:34'! itemAtIndex: index ^ self listSource itemAtIndex: index! ! !NewListRenderer methodsFor: 'stepping and presenter' stamp: 'BenjaminVanRyseghem 1/28/2013 17:32'! step | stepBounds mousePosition delta | ActiveHand hasSubmorphs ifFalse: [ ^ wantsSteps := false ]. mousePosition := ActiveHand position. stepBounds := self listSource fullBoundsInWorld. (stepBounds containsPoint: mousePosition) ifFalse: [ ^ wantsSteps := false ]. delta := stepBounds top + self headerHeight + 10 - mousePosition y. (mousePosition y > (stepBounds top + self headerHeight-10) and: [ 0 < delta]) ifTrue: [ ^ self listSource scrollBar scrollUp: delta//2 ]. delta := stepBounds top - self headerHeight + self listSource height - 5 - mousePosition y. ( 0 > delta ) ifTrue: [ ^ self listSource scrollBar scrollDown: delta negated // 3]. self stopStepping.! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 6/21/2013 00:17'! separatorColor ^ Color black! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:32'! itemHeight: anInteger itemHeight value: anInteger! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 19:21'! dropItemSelector ^ self listSource dropItemSelector! ! !NewListRenderer methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 12/13/2012 10:07'! drawSubmorphsOn: aCanvas "Do nothing please"! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 5/1/2013 09:55'! mouseUp: event | previousIndex index | self listSource wantsKeyboardFocus ifTrue: [ self listSource takeKeyboardFocus ]. (event position y < (self topDifference + self headerHeight)) ifTrue: [ ^ self mouseDownOnHeader: event ]. self allowToSelect ifFalse: [ ^ self ]. index := self indexAtLocation: event position. previousIndex := self selectedIndex. ((event shiftPressed not and: [ event commandKeyPressed not ]) and: [ self selectionWithKeys ]) ifTrue: [ self resetSelectionIndexes ]. self mouseDownIndex: 0. ( self deSelectOnReclick and: [ previousIndex == index ]) ifTrue: [ self listSource private_selectedIndexes at: index put: false. index := 0 ]. self listSource setIndex: index. self listSource mouseUpOnItemAt: index event: event. event commandKeyPressed ifTrue: [ previousIndex = index ifTrue: [ previousIndex := 0 ]]. event shiftPressed ifTrue: [ | start end | start := previousIndex min: index. end := previousIndex max: index. start to: end do: [:e | self listSource addAtIndexes: e ]]! ! !NewListRenderer methodsFor: 'drawing - background' stamp: 'BenjaminVanRyseghem 11/29/2012 19:27'! drawBackgroundForItem: item at: index on: aCanvas (self isSelectedIndex: index) ifTrue: [ self drawSelectedBackgroundForItem: item at: index on: aCanvas ] ifFalse: [ (self isSecondSelectedIndex: index) ifTrue: [ self drawSecondSelectedItem: item at: index on: aCanvas ] ifFalse: [ self drawDefaultBackgroundForItem: item at: index on: aCanvas ] ]. (self isPotentialDrop: index) ifTrue: [ self drawPotentialDropBackroundForItem: item at: index on: aCanvas ]. self drawMouseDownBackgroundFor: item at: index on: aCanvas! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 12/13/2012 09:14'! iconColor ^ Color transparent! ! !NewListRenderer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 19:31'! resetPotentialDropIndex self potentialDropIndex: 0! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:36'! isSecondSelectedIndex: index ^ self listSource isSecondSelectedIndex: index! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/25/2012 19:44'! potentialDropColor ^ Color blue! ! !NewListRenderer methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/1/2013 08:00'! acceptDroppingMorph: aMorph event: evt "This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. The default implementation just adds the given morph to the receiver." "Here we let the model do its work." [ self listSource acceptDroppingMorph: aMorph atIndex: self potentialDropIndex event: evt inMorph: self ] ensure: [ self resetPotentialDropIndex. evt hand releaseMouseFocus: self. Cursor normal show ]! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 11/25/2012 19:54'! mouseLeaveDragging: evt self resetPotentialDropIndex. super mouseLeaveDragging: evt! ! !NewListRenderer methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 11/5/2013 11:20'! startDrag: evt | transferMorph draggedIndex draggedItem passenger | evt hand hasSubmorphs ifTrue: [^ self]. self dragEnabled ifFalse: [ ^ self ]. ActiveHand anyButtonPressed ifFalse: [ ^ self ]. draggedIndex := self indexAtLocation: evt position. draggedItem := self listSource model draggedItemAtIndex: draggedIndex. draggedItem ifNil: [ ^ self ]. passenger := self listSource transferFor: draggedItem from: self listSource. passenger ifNil: [ ^ self ]. self releaseKeyboardFocus. transferMorph := self listSource withPassenger: passenger from: self. transferMorph dropNotifyRecipient: self. transferMorph align: transferMorph draggedMorph bottomLeft with: ((evt position) translateBy: (self listSource bounds left)@(self listSource bounds top - self topDifference + self headerHeight - (3*self itemHeight/2))). "self mouseDownRow: nil." transferMorph dragTransferType: ((self model dragTransferTypeForMorph: self) ifNil: [ #dragTransfer ]). [evt hand grabMorph: transferMorph ] ensure: [ Cursor normal show. evt hand releaseMouseFocus: self] ! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 10/17/2013 16:32'! listSource: anObject listSource value: anObject. ! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:33'! listSize "could be cached" ^ self listSource listSize! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/29/2012 19:17'! hasMultipledSelected ^ self listSource hasMultipledSelected! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:32'! hasHeader: aBoolean hasHeader value: aBoolean! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 5/1/2013 08:41'! mouseDown: event | selectors | (self enabled and: [ event yellowButtonPressed ]) "First check for option (menu) click" ifTrue: [ self isMultipleSelection ifTrue: [ event commandKeyPressed ifFalse: [ "right click" (self yellowButtonActivity: event shiftPressed) ifTrue: [ ^ self ]]] ifFalse: [ (self yellowButtonActivity: event shiftPressed) ifTrue: [ ^ self ]]]. self mouseDownIndex: (self indexAtLocation: event position). selectors := Array with: #click: with: (self handlesDoubleClick ifTrue: [ #doubleClick: ]) with: nil with: (self dragEnabled ifTrue: [ #startDrag: ] ifFalse:[ nil ]). event hand waitForClicksOrDrag: self event: event selectors: selectors threshold: 10.! ! !NewListRenderer methodsFor: 'drawing - item' stamp: 'BenjaminVanRyseghem 5/21/2013 18:01'! drawItem: item at: index on: aCanvas "Display the given item at the given row on the given canvas." | itemColor drawBounds itemBounds backgroundColor | drawBounds := self drawBoundsForItem: item at: index. itemBounds := drawBounds translateBy: (self iconMaxSize x + self gapBetweenIconAndItem) @ (2 * self itemHalfOffSet). itemColor := self colorForItem: item at: index. backgroundColor := self backgroundColorForIndex: index. item listRenderOn: aCanvas atRow: index bounds: itemBounds color: itemColor backgroundColor: backgroundColor from: self. self drawIconOn: aCanvas forAt: index from: drawBounds. self flag: 'should be item drawAsListItemOn: aCanvas row: index bounds: drawBounds list: self '! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! potentialDropIndex ^ potentialDropIndex value! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/29/2012 18:35'! deSelectOnReclick ^ self listSource deSelectOnReclick! ! !NewListRenderer methodsFor: 'drawing - background' stamp: 'BenjaminVanRyseghem 11/25/2012 19:44'! drawPotentialDropBackroundForItem: item at: index on: aCanvas | drawBounds | drawBounds := self drawBoundsForItem: item at: index. drawBounds := self ensureFrame: drawBounds. aCanvas frameRectangle: drawBounds color: self potentialDropColor! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:33'! maxWidth ^ maxWidth value! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 11/24/2012 19:08'! mouseDownOnHeader: anEvent self listSource mouseDownOnHeader: anEvent! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 13:48'! headerTitle ^ self listSource headerTitle! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 6/21/2013 00:07'! separatorAfter: item at: index ^ self listSource separatorAfter: item at: index! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 5/1/2013 09:56'! allowToSelect ^ self listSource allowToSelect! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 6/21/2013 00:17'! separatorSize ^ 1! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/25/2012 01:30'! drawBoundsForIndex: index "calculate the bounds that row should be drawn at. This might be outside our bounds!!" | topLeft drawBounds | topLeft := self topLeft x @ (self topLeft y + self headerHeight + ((index - 1) * self itemHeight)). drawBounds := topLeft extent: self width @ self itemHeight. ^ drawBounds! ! !NewListRenderer methodsFor: 'drawing - background' stamp: 'BenjaminVanRyseghem 12/5/2012 14:45'! drawDefaultBackgroundForItem: item at: index on: aCanvas "Nothing to do"! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/29/2012 16:59'! selectionWithKeys ^ self listSource selectionWithKeys! ! !NewListRenderer methodsFor: 'drawing - item' stamp: 'BenjaminVanRyseghem 2/21/2013 23:23'! drawIconOn: aCanvas forAt: index from: itemBounds | item icon maxSize drawBounds xOffset yOffset backgroundColor | item := self rawItemAtIndex: index. icon := self listSource iconForItem: item at: index. icon ifNil: [ ^ self ]. maxSize := self iconMaxSize. drawBounds := itemBounds topLeft extent: maxSize. xOffset := (maxSize x - icon width) / 2. yOffset := (maxSize y - icon height) / 2 + self itemHalfOffSet. drawBounds := drawBounds translateBy: xOffset @ yOffset. backgroundColor := self backgroundColorForIndex: index. icon listRenderOn: aCanvas atRow: index bounds: drawBounds color: self iconColor backgroundColor: backgroundColor from: self! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 12/13/2012 13:53'! drawBoundsForItem: item at: index "calculate the bounds that row should be drawn at. This might be outside our bounds!!" | topLeft drawBounds width | width := (item widthToDisplayInList: self) + self iconMaxSize x + self gapBetweenIconAndItem. (width > self maxWidth) ifTrue: [ self maxWidth: width. self width: width ]. topLeft := self topLeft x @ (self topLeft y + self headerHeight + ((index - 1) * self itemHeight)). drawBounds := topLeft extent: width @ self itemHeight. ^ drawBounds! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'EstebanLorenzano 1/28/2013 16:10'! basicRemoveAllMorphs submorphs := EmptyArray ! ! !NewListRenderer methodsFor: 'drawing - item' stamp: 'BenjaminVanRyseghem 6/21/2013 00:18'! drawSeparatorForItem: item at: index on: aCanvas | frame rectangle height separatorColor | height := self separatorSize. separatorColor := self separatorColor. frame := self selectionFrameForItem: item at: index. rectangle := (frame left@(frame bottom - height)) corner: (frame right@frame bottom). aCanvas fillRectangle: rectangle color: separatorColor! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/25/2012 19:30'! updateRectFor: index and: anotherIndex self flag: 'Could be optimized'. self listSource changed. "| item | index isZero ifFalse: [ item := self itemAtIndex: index. self invalidRect: (self selectionFrameForItem: item at: index) ]"! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 12/16/2012 17:09'! drawColor ^ self listSource drawColor! ! !NewListRenderer methodsFor: 'drawing - background' stamp: 'BenjaminVanRyseghem 11/29/2012 19:28'! drawMouseDownBackgroundFor: item at: index on: aCanvas index == self mouseDownIndex ifTrue: [ aCanvas frameRectangle: (self selectionFrameForItem: item at: index) width: 1 colors: {Color gray. Color transparent} dashes: #(1 1)]! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 11/25/2012 19:58'! handleMouseMove: anEvent "System level event handling." anEvent wasHandled ifTrue: [ ^ self ]. "not interested" anEvent wasHandled: true. self mouseMove: anEvent. (self handlesMouseStillDown: anEvent) ifTrue:[ "Step at the new location" self startStepping: #handleMouseStillDown: at: Time millisecondClockValue arguments: {anEvent copy resetHandlerFields} stepTime: self mouseStillDownStepRate ]. ^ self eventHandler ifNotNil: [:handler | handler mouseMove: anEvent fromMorph: self ] ! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/29/2012 16:29'! resetSelectionIndexes self listSource resetSelectionIndexes! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:36'! font ^ self listSource font! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/24/2012 19:22'! invalidHeader | rect | rect := self bounds. rect := rect topLeft extent: rect width@self headerHeight. self invalidRect: rect! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 19:13'! wantsDropSelector ^ self listSource wantsDropSelector! ! !NewListRenderer methodsFor: 'layout' stamp: 'BenjaminVanRyseghem 12/17/2012 14:09'! privateFullBounds ^ self bounds! ! !NewListRenderer methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 11/29/2012 19:33'! dropAcceptedMorph: transferMorph from: sourceMorph self mouseDownIndex: 0.! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/24/2012 13:28'! indexAtLocation: aPoint "return the number of the row at aPoint" "Here we assume that all the item have the same height" | y | y := aPoint y. (y < (self top + self headerHeight)) ifTrue: [ ^ 1 ]. ^((y - self top - self headerHeight // self itemHeight) + 1) min: self listSize max: 1! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 10/17/2013 16:32'! listSource ^ listSource value! ! !NewListRenderer methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/1/2013 08:53'! wantsDroppedMorph: aMorph event: anEvent inMorph: source ^ self listSource wantsDroppedMorph: aMorph event: anEvent inMorph: source! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/24/2012 15:11'! bottomVisibleIndexForCanvas: aCanvas "return the top visible index in aCanvas's clip rectangle" | rect | rect := aCanvas clipRect. ^self indexAtLocation: (rect left @ rect bottom + self headerHeight).! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:51'! selectedBackgroundColor ^ self listSource selectedBackgroundColor! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:32'! itemHeight ^ itemHeight value! ! !NewListRenderer methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 11/29/2012 19:33'! dropRejectedMorph: aTransferMorp self resetPotentialDropIndex. self mouseDownIndex: 0.! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 11/25/2012 19:55'! handlesMouseOverDragging: evt "Yes, for mouse down highlight." ^true! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 5/1/2013 08:53'! mouseMove: evt | index | "Check if the mouse is currently dragging an object" evt isDraggingEvent ifFalse: [ ^ super mouseMove: evt ]. "Check if we are interested in this object" self dropEnabled ifFalse: [ ^ super mouseMove: evt ]. (self wantsDroppedMorph: (evt hand submorphs at: 1 ifAbsent: [ ^ super mouseMove: evt ]) event: evt inMorph: self) ifFalse: [ ^ super mouseMove: evt ]. self isScrolling ifTrue: [ ^ self ]. index := self indexAtLocation: evt position. self potentialDropIndex: index. (evt position y > (self topDifference + self headerHeight - 10) and: [ evt position y < (self topDifference + self headerHeight + 10) ]) ifTrue: [ wantsSteps := true ]. evt position y > (self topDifference - self headerHeight + self listSource height - 5) ifTrue: [ wantsSteps := true ]! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/25/2012 00:06'! topVisibleIndexForCanvas: aCanvas "return the top visible index in aCanvas's clip rectangle" | rect | rect := aCanvas clipRect. ^ self indexAtLocation: (rect left @ self topDifference + self headerHeight)! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 12/16/2012 17:25'! selectedIndexes ^ self listSource selectedIndexes! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:35'! isSelectedIndex: index ^ self listSource isSelectedIndex: index! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 5/1/2013 08:08'! backgroundColorForIndex: anIndex ^ (self isSelectedIndex: anIndex) ifTrue: [ self selectedBackgroundColor ] ifFalse: [ Color transparent ]! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:32'! mouseDownIndex: anInteger self allowToSelect ifFalse: [ ^ self ]. mouseDownIndex value: anInteger! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 02:43'! getMenuSelector ^ self listSource getMenuSelector! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/24/2012 23:42'! topDifference | ownerTop top | ownerTop := self listSource top. top := (self bounds: self fullBounds in: self listSource) top. ^ ownerTop - top +1! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 14:47'! colorForItem: item at: index ^ self listSource colorForItem: item at: index ! ! !NewListRenderer methodsFor: 'drawing - background' stamp: 'BenjaminVanRyseghem 11/24/2012 00:29'! drawSelectedBackgroundForItem: item at: index on: aCanvas self drawBackgroundForItem: item at: index on: aCanvas color: self selectedBackgroundColor! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 12/13/2012 09:44'! iconMaxSize ^ self listSource iconMaxSize! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/24/2012 19:18'! selectionFrameForItem: item at: index "Answer the selection frame rectangle." | frame | frame := self drawBoundsForItem: item at: index. ^ self ensureFrame: frame.! ! !NewListRenderer methodsFor: 'drawing - background' stamp: 'BenjaminVanRyseghem 11/24/2012 00:29'! drawSecondSelectedItem: item at: index on: aCanvas self drawBackgroundForItem: item at: index on: aCanvas color: self secondSelectionColor.! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 01:48'! secondSelectionColor ^ self listSource secondSelectionColor! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:32'! hasHeader ^ hasHeader value! ! !NewListRenderer methodsFor: 'stepping and presenter' stamp: 'BenjaminVanRyseghem 1/28/2013 17:31'! wantsSteps ^ wantsSteps! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/25/2012 02:20'! updateRectFor: index self flag: 'Could be optimized'. self listSource changed. "| item | index isZero ifFalse: [ item := self itemAtIndex: index. self invalidRect: (self selectionFrameForItem: item at: index) ]"! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 15:51'! dragEnabled ^ self listSource dragEnabled! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'IgorStasenko 12/22/2012 03:02'! ensureFrame: aFrame | frame | frame := aFrame. "??? forgot to use result ??? frame intersect: (self bounds bottom: (self bounds bottom +self headerHeight)). " frame := self bounds: frame in: self listSource. frame := self bounds: ((frame left: self listSource innerBounds left) right: self listSource innerBounds right) from: self listSource. ^ frame! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 5/1/2013 08:42'! doubleClick: event self listSource doubleClick: event! ! !NewListRenderer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 21:16'! isScrolling ^ self isStepping! ! !NewListRenderer class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/24/2012 00:30'! on: aNewList ^ self new listSource: aNewList; yourself! ! !NewValueHolder commentStamp: 'BenjaminVanRyseghem 1/24/2014 19:04'! I am a class holding any object inside its unique instance variable. Each time the instance variable value changes, an announcement is emitted. The instance variable is accessed through `value` and `value:` while the registration is done by `whenChangedDo: aBlock`. In addition, infinite loops of propagation are prevented. Use case: you have two lists A, and B, and you want to keep their selection synchronised. So when A selection changes, you set B selection. But since B selection changes, you set A selection, and so on… This case is prevented by the use of a `lock` variable. / !! \ IMPORTANT / !! \ NewValueHolder will soon be replaced by ReactiveVariable ============================================= Within Spec itself, NewValueHolder has been renamed to ReactiveVariable (during the beta phase of Pharo 3). Since Pharo 3 was already in beta, NewValueHolder has been kept untouched. For new code (and all code in future versions of Pharo), use the following two hook methods: asReactiveVariable - use wherever you would have used asValueHolder, which will soon be deprecated. For now, it returns a NewValueHolder. In the future it will return a (polymorphic) ReactiveVariable selectionReactiveVariable - as above, returns a SelectionValueHolder for now. This extension method allows the two different packages to coexist without having direct references from the Spec model.! !NewValueHolder methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 8/20/2012 11:38'! initialize super initialize. announcer := Announcer new. lock := false.! ! !NewValueHolder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:48'! value ^ value! ! !NewValueHolder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/23/2014 12:34'! value: anObject self handleCircularReferencesWhile: [ | oldValue | oldValue := value. value := anObject. self valueChanged: oldValue ]. ^ value! ! !NewValueHolder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 17:00'! valueChanged announcer announce: (ValueChanged newValue: value)! ! !NewValueHolder methodsFor: 'announcements' stamp: 'EstebanLorenzano 9/8/2013 16:05'! whenChangedSend: aSelector to: aReceiver announcer on: ValueChanged send: aSelector to: aReceiver! ! !NewValueHolder methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 10/17/2013 17:10'! printOn: aStream super printOn: aStream. aStream nextPutAll: '[ '; print: self value; nextPutAll: ' ]'! ! !NewValueHolder methodsFor: 'announcements' stamp: 'MarcusDenker 9/14/2013 10:28'! addDependent: aDependent self error: 'Former API, should be changed'.! ! !NewValueHolder methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/23/2014 12:35'! handleCircularReferencesWhile: aBlock "Used to handle circular references as explained in the class comment" lock ifTrue: [ ^ self ]. lock := true. aBlock ensure: [ lock := false ].! ! !NewValueHolder methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 10/17/2013 17:01'! whenChangedDo: aBlock | block | block := [:announcement :ann | aBlock cull: announcement newValue cull: announcement oldValue cull: announcement cull: ann ]. announcer when: ValueChanged do: block! ! !NewValueHolder methodsFor: '*Spec-Extensions' stamp: 'BenjaminVanRyseghem 1/29/2014 17:20'! rawValue: aValue value := aValue! ! !NewValueHolder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 17:02'! valueChanged: oldValue announcer announce: (ValueChanged oldValue: oldValue newValue: value)! ! !NewValueHolder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 17:02'! valueChanged: oldValue to: newValue announcer announce: (ValueChanged oldValue: oldValue newValue: newValue)! ! !NewValueHolder class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 10/17/2013 16:23'! value: contents ^ self new value: contents; yourself! ! !NewVersionBrowser commentStamp: ''! A NewVersionBrowser is a tool made for browsing the several versions of the provided method.! !NewVersionBrowser methodsFor: 'instance creation' stamp: 'NicolaiHess 1/21/2014 11:05'! browserForList: aList browser := MessageBrowser new. browser topologicSort: false; refreshingBlock: [:m | false]; sortingBlock: [:a :b | (a annotationNamed:#versionIndex ifAbsent:[0]) < (b annotationNamed:#versionIndex ifAbsent:[0]) ]; displayBlock: [:changeRecord | self displayStringsFor: changeRecord]. browser toolbarModel emptyDropList; addItemLabeled: 'Side By Side' do: [ self showDiffMorphWithConverter: (DiffMorphChangeRecordConverter methodReference: browser textConverter method referencesList: aList) ]; addItemLabeled: 'Source' do: [ self showSourceWithConverter: (SourceMethodConverter method: browser textConverter method) ]; addItemLabeled: 'Diff' do: [ self showSourceWithConverter: (DiffChangeRecordConverter methodReference: browser textConverter method referencesList: aList) ]. browser toolbarModel versionModel label: 'Revert'; action: [ self revert: browser selectedItem ]. browser listModel menu:[:menu | menu addAllFromPragma:'newVersionBrowserListMenu' target:self]. ^ browser.! ! !NewVersionBrowser methodsFor: 'instance creation' stamp: 'NicolaiHess 1/21/2014 10:29'! buildBrowser | changeList b | changeList := self buildChangeList. self browserForList: changeList. b := browser messages: changeList; title: 'Recent versions of ' , class name , '>>' , selector; openWithSpec. self showDiffMorphWithConverter: (DiffMorphChangeRecordConverter methodReference: browser textConverter method referencesList: changeList). ^ b ! ! !NewVersionBrowser methodsFor: 'menu' stamp: 'NicolaiHess 1/20/2014 01:35'! browseImplementors SystemNavigation new browseImplementorsOf: selector name: 'Implementors of ' , selector autoSelect: nil! ! !NewVersionBrowser methodsFor: 'instance creation' stamp: 'NicolaiHess 1/19/2014 19:48'! revert: aChangeRecord aChangeRecord ifNil: [self inform: 'nothing selected, so nothing done'] ifNotNil: [ class ifNotNil: [ class compile: aChangeRecord sourceCode classified: aChangeRecord category withStamp: aChangeRecord stamp notifying:nil]]. browser messages: self buildChangeList; setSelectedIndex: 1.! ! !NewVersionBrowser methodsFor: 'menu' stamp: 'NicolaiHess 1/21/2014 09:51'! compareToCurrentVersion self compareTo: class >> selector withLabel:'current version'! ! !NewVersionBrowser methodsFor: 'instance creation' stamp: 'NicolaiHess 1/19/2014 17:15'! showDiffMorphWithConverter: aConverter | behavior | behavior := browser textModel behavior. browser instantiateModels: #(textModel DiffModel). browser needRebuild: false. browser openWithSpec. browser textConverter: aConverter. browser textModel behavior: behavior! ! !NewVersionBrowser methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/14/2012 11:50'! buildChangeList | method | (class isNil or: [ selector isNil ]) ifTrue: [ ^ #() ]. method := (class>>selector). ^ self scanVersionsOf: method class: class theNonMetaClass meta: class isMeta category: method category selector: selector.! ! !NewVersionBrowser methodsFor: 'menu' stamp: 'NicolaiHess 1/20/2014 01:35'! browseSenders SystemNavigation new browseSendersOf: selector name: 'Senders of ' , selector autoSelect: selector! ! !NewVersionBrowser methodsFor: 'copy and paste' stamp: 'NicolaiHess 1/20/2014 01:55'! scanVersionsOf: method class: aClass meta: meta category: cat selector: aSelector ^( ChangeSet scanVersionsOf: method class: aClass meta: meta category: cat selector: aSelector) collectWithIndex:[:c :i | |rg| rg:= c asRingDefinition. rg annotationNamed:#versionIndex put:i ] ! ! !NewVersionBrowser methodsFor: 'accessing' stamp: 'NicolaiHess 1/20/2014 00:03'! browser ^ browser! ! !NewVersionBrowser methodsFor: 'menu' stamp: 'NicolaiHess 1/21/2014 09:51'! compareTo:anOtherVersion withLabel:aLabel | diff versions selected| selected := browser selectedMessage. versions := Array with:anOtherVersion with: (selected). diff := DiffModel new. diff title: ('Comparison from {1} to {2}' format:{selected stamp . aLabel}). diff text:(DiffMorphChangeRecordConverter methodReference: anOtherVersion referencesList: versions) getText. diff openWithSpec. ! ! !NewVersionBrowser methodsFor: 'accessing' stamp: 'NicolaiHess 1/21/2014 11:02'! displayStringsFor: aMethodVersion | author version | author := aMethodVersion stamp trim ifEmpty: [ '' ] ifNotEmpty: [ :s | s firstWord ]. version := aMethodVersion stamp trim substrings ifEmpty: [ '' ] ifNotEmpty: [ :s | s allButFirst joinUsing: ' ' ]. ^ {author. version. (aMethodVersion realClass name). (aMethodVersion selector). ('{' , aMethodVersion category , '}')}! ! !NewVersionBrowser methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/14/2012 11:50'! browseVersionsOf: method class: aClass meta: meta category: msgCategory selector: aSelector class := meta ifTrue: [ aClass theMetaClass ] ifFalse: [ aClass theNonMetaClass ]. selector := aSelector. ^ self buildBrowser! ! !NewVersionBrowser methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 10/18/2013 14:51'! showSourceWithConverter: aConverter | behavior | behavior := browser textModel behavior. browser instantiateModels: #(textModel TextModel). browser needRebuild: false. browser openWithSpec. browser textConverter: aConverter. browser textModel behavior: behavior! ! !NewVersionBrowser methodsFor: 'menu' stamp: 'NicolaiHess 1/21/2014 09:52'! compareToOtherVersion | labels versions index | versions := self buildChangeList. labels := versions collect: [ :version | version stamp ]. index := UIManager default chooseFrom: labels. index > 0 ifTrue: [ |selected| selected := versions at:index. self compareTo: selected withLabel: selected stamp]! ! !NewVersionBrowser class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/14/2012 09:56'! browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector ^ self new browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector! ! !NewVersionBrowser class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/18/2013 13:33'! browseVersionsForClass: aClass selector: aSelector ^ self browseVersionsOf: (aClass compiledMethodAt: aSelector) class: aClass meta: aClass isMeta category: (aClass organization categoryOfElement: aSelector) selector: aSelector! ! !NewVersionBrowser class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/18/2013 13:29'! browseVersionsOf: method ^ self new browseVersionsOf: method class: method methodClass meta: method methodClass isMeta category: method protocol selector: method selector! ! !NewVersionBrowser class methodsFor: 'menu' stamp: 'NicolaiHess 1/20/2014 01:31'! versionsBrowserListMenu: aBuilder | tool browser model | model := aBuilder model. browser := aBuilder model browser. tool := browser model. browser selectedMessage notNil ifTrue: [ | message | message := browser selectedMessage compiledMethod. (aBuilder item: #'Compare to current') help: 'Compare selected version to the current version'; target: model; selector: #compareToCurrentVersion. (aBuilder item: #'Compare to version...') help: 'Compare selected version to another selected version'; target: model; selector: #compareToOtherVersion. (aBuilder item: #'Revert to selected version') help: 'Resubmit the selected version, so that it becomes the current version'; action: [ model revert: message ]]. (aBuilder item: #Senders) keyText: 'n'; help: 'Browse all senders of this selector'; action: [ model browseSenders ]. (aBuilder item: #Implementors) keyText: 'm'; help: 'Browse all implementors of this selector'; action: [ model browseImplementors ]; withSeparatorAfter ! ! !NoNetworkError commentStamp: 'mir 5/12/2003 18:17'! Signals that no network was found. This could happen, e.g., on dial-up connection when no connection was established when Squeak tried to access it. ! !NonBooleanReceiver commentStamp: ''! Some constructs are optimized in the compiler : #whileTrue: #whileFalse: #ifTrue: #ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue: So you cannot by default use them on non boolean objects. If you really need to use optimized constructs, you can enable Opal compiler and do one of the following : - recompile your method with the pragma : - recompile your class with the method : MyClass class>>compiler ^ super compiler options: #(+ optIlineNone) - call from this method by Object>>#mustBeBooleanInMagic:"! !NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'! object: anObject object := anObject! ! !NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'! object ^object! ! !NonBooleanReceiver methodsFor: 'signaledexception' stamp: 'hmm 7/29/2001 21:37'! isResumable ^true! ! !NonInteractiveTranscript commentStamp: ''! I am NonInteractiveTranscript, a replacement for Transcript, writing everything to a file or stdout. This is useful when running headless. NonInteractiveTranscript file install. To connect to the output stream of the virtual machine process choose stdout. NonInteractiveTranscript stdout install. or NonInteractiveTranscript stderr install ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 19:30'! ensureCr! ! !NonInteractiveTranscript methodsFor: 'initialize-release' stamp: 'CamilloBruni 10/12/2013 16:40'! close self critical: [ stream ifNotNil: [ (self isStdout or: [ self isStderr ]) ifTrue: [ stream flush ] ifFalse: [ stream close ]. stream := nil ] ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 21:23'! print: anObject self nextPutAll: anObject asString! ! !NonInteractiveTranscript methodsFor: 'testing' stamp: 'CamilloBruni 9/13/2013 23:56'! isStderr ^ fileName = #stderr! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 19:30'! << anObject self show: anObject! ! !NonInteractiveTranscript methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 9/28/2011 21:22'! initialize super initialize. accessSemaphore := Mutex new! ! !NonInteractiveTranscript methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 12/4/2011 17:49'! fileName "The file name that I will write to. Lazy initialized to a default. When I connect to the standard output stream of the virtual machine process I return #stdout." ^ fileName ifNil: [ fileName := self class defaultLogFileName ]! ! !NonInteractiveTranscript methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/4/2011 17:46'! isStdout "Answer true when I am setup to be connected to the special standard output stream of the virtual machine process." ^ fileName = #stdout! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/30/2011 10:19'! nextPutAll: aCollection ^ self critical: [ self stream nextPutAll: aCollection ]! ! !NonInteractiveTranscript methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 9/28/2011 19:26'! printOn: aStream self == Transcript ifFalse: [ ^ super printOn: aStream ]. aStream nextPutAll: 'Transcript'! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 20:02'! show: anObject self critical: [ self print: anObject; endEntry ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/30/2011 10:18'! cr self critical: [ self stream cr ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/30/2011 10:19'! tab ^ self critical: [ self stream tab ]! ! !NonInteractiveTranscript methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/30/2011 10:32'! stream "The file stream I am writing to. Lazy initialized so as not to create the file when it is not used." ^ stream ifNil: [ self initializeStream ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 19:29'! clear! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 19:48'! endEntry self flush! ! !NonInteractiveTranscript methodsFor: 'private' stamp: 'SvenVanCaekenberghe 9/28/2011 19:55'! critical: block ^ accessSemaphore critical: block ! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/30/2011 10:18'! nextPut: aCharacter ^ self critical: [ self stream nextPut: aCharacter ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 19:29'! reset! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/30/2011 10:19'! space ^ self critical: [ self stream space ]! ! !NonInteractiveTranscript methodsFor: 'installation' stamp: 'SvenVanCaekenberghe 12/4/2011 17:31'! install "Install me as a replacement for Transcript" Smalltalk globals at: #Transcript put: self! ! !NonInteractiveTranscript methodsFor: 'initialize-release' stamp: 'SvenVanCaekenberghe 7/6/2012 10:42'! fileName: anObject "Initialize me to write to a file stream described by anObject. anObject is either a String naming a file or the special #stdout value for using the standard output stream of the virtual machine process." self close. fileName := anObject! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 20:02'! crShow: anObject self critical: [ self cr; show: anObject ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/30/2011 10:18'! flush self critical: [ self stream flush ]! ! !NonInteractiveTranscript methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 9/28/2011 19:26'! isSelfEvaluating self == Transcript ifTrue: [ ^ true ]. ^ super isSelfEvaluating! ! !NonInteractiveTranscript methodsFor: 'private' stamp: 'CamilloBruni 9/13/2013 23:57'! initializeStream "Open the file stream that I write to or connect to #stdout. I use the proper line end convention. I will append to regular files." stream := self isStdout ifTrue: [ FileStream stdout ] ifFalse: [ self isStderr ifTrue: [ FileStream stderr ] ifFalse: [ FileStream fileNamed: self fileName ]]. stream wantsLineEndConversion: true. (self isStdout or: [ self isStderr ]) ifTrue: [ stream converter "Force lazy initialization of converter" ] ifFalse: [ stream setToEnd ]. ^ stream ! ! !NonInteractiveTranscript class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 12/4/2011 17:34'! file "Create a new NonInteractiveTranscript that will output to the default file named by #defaultLogFileName." ^ self onFileNamed: self defaultLogFileName ! ! !NonInteractiveTranscript class methodsFor: 'class initialization' stamp: 'SvenVanCaekenberghe 7/6/2012 10:46'! initialize "Make sure to cleanup on shutdown" Smalltalk addToShutDownList: self ! ! !NonInteractiveTranscript class methodsFor: 'system startup' stamp: 'SvenVanCaekenberghe 7/6/2012 10:54'! shutDown "Send close to all our instances. Their streams will be reopened on first use later on." self allInstances do: [ :each | each close ]! ! !NonInteractiveTranscript class methodsFor: 'constants' stamp: 'SvenVanCaekenberghe 9/30/2011 10:29'! defaultLogFileName "The default file name that will be used to write to. This should probably become a system setting." ^ 'PharoTranscript.log'! ! !NonInteractiveTranscript class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 12/4/2011 17:33'! onFileNamed: fileName "Create a NonInteractiveTranscript that will write to fileName." ^ self new fileName: fileName; yourself! ! !NonInteractiveTranscript class methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 7/6/2012 10:43'! isInstalled ^ Transcript class = self! ! !NonInteractiveTranscript class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/13/2013 23:57'! stderr "Create a new NonInteractiveTranscript that will output to the special standard error output stream of the virtual machine process." ^ self onFileNamed: #stderr! ! !NonInteractiveTranscript class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 12/4/2011 17:33'! stdout "Create a new NonInteractiveTranscript that will output to the special standard output stream of the virtual machine process." ^ self onFileNamed: #stdout! ! !NonInteractiveUIManager commentStamp: 'IgorStasenko 1/24/2011 15:36'! This is a non-interactive UI manager, i.e. a UI manager which doesn't provides any kind of interactivity with users. For most of requests, it throws an ErrorNonInteractive exception, which can be handled by various tools to do things differently when UI is not avaliable. For example: response := [ UIManager default request: 'what is your name?' ] on: ErrorNonInteractive do: [:ex | ex resume: 'Mr. John Smith' ]. You can replace the default UI Manager with my instance in cases, when you need to guarantee that your task(s) will run in fully automated mode. This is useful for things like: - when image runs as a persistent application on a server - image runs headless from command-line with some batch scripts/commands ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:31'! chooseOrRequestFrom: labelList values: valueList lines: linesArray title: aString ^ self nonInteractiveWarning: (String streamContents: [ :s| s nextPutAll: 'Choice Request: '; nextPutAll: aString; cr. labelList with: valueList do: [ :label :value| s tab; nextPutAll: label asString; nextPutAll: ':'; tab; print: value; cr ]])! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:12'! confirm: queryString trueChoice: trueChoice falseChoice: falseChoice ^ self nonInteractiveRequest: queryString! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:18'! chooseFrom: labelList values: valueList lines: linesArray title: aString "Choose an item from the given list. Answer the selected item." ^ self chooseOrRequestFrom: labelList values: valueList lines: linesArray title: aString! ! !NonInteractiveUIManager methodsFor: 'errors' stamp: 'IgorStasenko 1/24/2011 10:34'! nonInteractive: anException ^ ErrorNonInteractive signalForException: anException! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:02'! request: queryString initialAnswer: defaultAnswer ^ self request: queryString initialAnswer: defaultAnswer title: nil entryCompletion: nil. ! ! !NonInteractiveUIManager methodsFor: 'events' stamp: 'CamilloBruni 7/24/2012 16:05'! onDebug: process context: context title: title full: bool ^ self nonInteractiveWarning: 'Opening Debugger'! ! !NonInteractiveUIManager methodsFor: 'default actions' stamp: 'IgorStasenko 1/24/2011 14:37'! fileExistsDefaultAction: anException ^ self nonInteractive: anException ! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:10'! multiLineRequest: queryString initialAnswer: defaultAnswer answerHeight: answerHeight ^ self nonInteractiveRequest: queryString! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:02'! request: aStringOrText initialAnswer: defaultAnswer title: aTitle ^ self request: aStringOrText initialAnswer: defaultAnswer title: aTitle entryCompletion: nil. ! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 2/21/2012 02:05'! syntaxErrorNotificationDefaultAction: aSyntaxErrorNotification "display and log the syntax error" super syntaxErrorNotificationDefaultAction: aSyntaxErrorNotification. "in noninteractive mode simply quit" ^ self exitFailure! ! !NonInteractiveUIManager methodsFor: 'events' stamp: 'FernandoOlivero 3/16/2012 16:24'! onSnapshot: resuming "The resuming argument is true when image boots from disk, and false, if user just did an image snapshot." resuming ifTrue: [ Smalltalk isHeadless ifFalse: [ "restore old, or nil, so it will be set in #default " uiManager beDefault. UIManager default onSnapshot: resuming. ^ self ]. Smalltalk isInteractive ifTrue: [ "use a headless but interactive manager" ^ self headlessManager onSnapshot: resuming ]]. " this flag set to true only if we are saving a snapshot before quitting " doNotQuitOnRestart ifTrue: [ Smalltalk snapshot: false andQuit: true].! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:12'! confirm: aString orCancel: cancelBlock ^ self nonInteractiveRequest: aString! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:06'! fontFromUser: priorFont ^self nonInteractiveWarning: 'Font Choose Request'! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:10'! request: aStringOrText initialAnswer: defaultAnswer title: aTitle entryCompletion: anEntryCompletion (ProvideAnswerNotification signal: aStringOrText) ifNotNil: [:answer | ^ answer = #default ifTrue: [ defaultAnswer ] ifFalse: [ answer ]]. ^ self nonInteractiveRequest: aStringOrText title: aTitle! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:12'! confirm: queryString trueChoice: trueChoice falseChoice: falseChoice cancelChoice: cancelChoice default: aSymbol ^ self nonInteractiveRequest: queryString! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:12'! confirm: queryString label: titleString ^ self nonInteractiveRequest: queryString title: titleString! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:12'! confirm: queryString (ProvideAnswerNotification signal: queryString) ifNotNil: [:answer | ^ answer]. ^ self nonInteractiveWarning: 'Confirming: ', queryString! ! !NonInteractiveUIManager methodsFor: 'errors' stamp: 'IgorStasenko 1/21/2011 16:25'! nonInteractive ^ ErrorNonInteractive signal! ! !NonInteractiveUIManager methodsFor: 'errors' stamp: 'CamilloBruni 7/24/2012 15:57'! nonInteractiveWarning: aWarnMessage ^ ErrorNonInteractive signal: aWarnMessage! ! !NonInteractiveUIManager methodsFor: 'errors' stamp: 'CamilloBruni 7/24/2012 16:11'! nonInteractiveRequest: aStringOrText ^ self nonInteractiveRequest: aStringOrText title: nil! ! !NonInteractiveUIManager methodsFor: '*Morphic-Base' stamp: 'IgorStasenko 1/25/2011 17:57'! currentWorld " err.. we should probably prohibit this message.. but lets play nice" uiManager ifNotNil: [ ^ uiManager currentWorld ]. ActiveWorld ifNotNil: [^ActiveWorld]. ^World! ! !NonInteractiveUIManager methodsFor: 'default actions' stamp: 'MarcusDenker 9/10/2013 12:12'! lowSpaceWatcherDefaultAction: preemptedProcess | ctx | "yeah.. space is low.. quit!!!! :)" ctx := preemptedProcess ifNotNil: [ preemptedProcess suspendedContext ]. ctx ifNil: [ ctx := thisContext sender ]. self quitFrom: ctx withMessage: 'Low space signal received.'. self error. "what else we can do? "! ! !NonInteractiveUIManager methodsFor: 'errors' stamp: 'CamilloBruni 7/24/2012 16:09'! nonInteractiveRequest: aStringOrText title: aTitle ^ self nonInteractiveWarning: (String streamContents: [ :s| s nextPutAll: 'Interactive Request: '. aTitle ifNotNil: [ s nextPutAll: '[ '; nextPutAll: aTitle asString; nextPutAll: ' ] ' ]. s nextPutAll: aStringOrText asString. ])! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:08'! edit: aText label: labelString accept: anAction "Open an editor on the given string/text" ^self nonInteractiveWarning: (String streamContents: [ :s | s nextPutAll: 'Editing Text: '. labelString ifNotNil: [ s nextPutAll: '[ '; nextPutAll: labelString; nextPutAll: ' ] ']. s cr; nextPutAll: aText])! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:18'! chooseFrom: aList lines: linesArray title: aString "Choose an item from the given list. Answer the index of the selected item." ^ self chooseOrRequestFrom: aList values: aList lines: linesArray title: aString! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 15:56'! requestPassword: queryString ^self nonInteractiveWarning: 'Requesting Password'.! ! !NonInteractiveUIManager methodsFor: 'default actions' stamp: 'IgorStasenko 1/24/2011 10:33'! fileDoesNotExistsDefaultAction: anException ^ self nonInteractive: anException ! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:19'! chooseFullFileNameMatching: patterns label: labelString "Let the user choose a file matching the given patterns" ^ self nonInteractiveWarning: (String streamContents: [ :s| s nextPutAll: 'Interactive File Choice Request: '; nextPutAll: '[ '; nextPutAll: labelString asString; nextPutAll: ' ] '; print: patterns. ])! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:20'! chooseFileMatching: patterns label: labelString "Let the user choose a file matching the given patterns" ^ self chooseFullFileNameMatching: patterns label: labelString! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:02'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint "Create an instance of me whose question is queryString with the given initial answer. Answer the string the user accepts. Answer the empty string if the user cancels." ^ self request: queryString initialAnswer: defaultAnswer title: nil entryCompletion: nil. ! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:02'! request: queryString initialAnswer: defaultAnswer entryCompletion: anEntryCompletion ^ self request: queryString initialAnswer: defaultAnswer title: nil entryCompletion: anEntryCompletion. ! ! !NonInteractiveUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 7/24/2012 16:21'! chooseDirectory: label from: dir "Let the user choose a directory" ^ self nonInteractiveWarning: (String streamContents: [ :s| s nextPutAll: 'Interactive Directory Choice Request: '; nextPutAll: '[ '; nextPutAll: label asString; nextPutAll: ' ] from '; print: dir ])! ! !NonInteractiveUIManager methodsFor: 'non-interactive' stamp: 'CamilloBruni 2/13/2012 19:02'! nonInteractiveManager " Answer an instance of non-interactive manager, which will be used when image runs headless. We put it here, so subclasses can override it. We already non-interactive. Just answer self " ^ self! ! !NonReentrantWeakMessageSend commentStamp: 'LaurentLaffont 4/15/2011 20:18'! NonReentrantWeakMessageSend does what it says, while the message is being executed, additional evaluations will be discarded. It's used by when:sendOnce:to: protocol from Polymorph events, but unused in the base image. when:send:to:exclusive: is used one place though. It's useful when objects are mutually registered to each other's events, but the actions may lead to the others action being triggered. Examples are - two lists whose contents update based on the selection in the other - The DiffMorph (Uses ExclusiveWeakMessageSend) ExclusiveWeakMessageSend are used when the decision whether to process an event is shared between multiple objects. IE 2 objects respond to different events, but if received simultaneously, only the first of them should have it's action executed. With Announcement, the corresponding functionality to non-reentrancy would be achieved using: VW - AnnouncementCollection>>suspendWhile: anActionBlock Pharo - Announcer >> suspend: aSubscriber while: anActionBlock (As we neither have a specific AnnouncementCollection class, nor access to Registry itself. Not implemented yet though :P) The shared state required to achieve Exclusivity would probably have to recide outside of the framework.! !NonReentrantWeakMessageSend methodsFor: 'initialization' stamp: 'gvc 10/25/2006 18:04'! initialize "Initialize the receiver." super initialize. self executing: false! ! !NonReentrantWeakMessageSend methodsFor: 'evaluating' stamp: 'gvc 10/24/2006 11:42'! value "Answer the superclass value or nil if already executing." ^self execute: [super value]! ! !NonReentrantWeakMessageSend methodsFor: 'evaluating' stamp: 'gvc 10/24/2006 11:56'! valueWithArguments: anArray "Answer the superclass value or nil if already executing." ^self execute: [super valueWithArguments: anArray]! ! !NonReentrantWeakMessageSend methodsFor: 'evaluating' stamp: 'gvc 10/24/2006 11:56'! valueWithEnoughArguments: anArray "Answer the superclass value or nil if already executing." ^self execute: [super valueWithEnoughArguments: anArray]! ! !NonReentrantWeakMessageSend methodsFor: 'accessing' stamp: 'gvc 10/25/2006 18:03'! executing "Answer the value of executing" ^ executing! ! !NonReentrantWeakMessageSend methodsFor: 'testing' stamp: 'gvc 10/25/2006 18:15'! isValid "Answer the superclass vlaue of isValid or false if executing is true." ^self executing ifTrue: [false] ifFalse: [super isValid]! ! !NonReentrantWeakMessageSend methodsFor: 'evaluating' stamp: 'gvc 10/25/2006 18:03'! execute: aBlock "Answer the value of the block or nil if already executing." self executing ifTrue: [^nil]. self executing: true. ^aBlock ensure: [self executing: false]! ! !NonReentrantWeakMessageSend methodsFor: 'accessing' stamp: 'gvc 10/25/2006 18:03'! executing: anObject "Set the value of executing" executing := anObject! ! !NotFound commentStamp: 'SvenVanCaekenberghe 4/18/2011 14:32'! I am NotFound, an exception to indicate that something is not found in a collection. I am an Error and thus Exception. Typically, the thing not found is in my object instance variable. The collection where this thing was not found is in my inherited signaler instance variable. [ NotFound signalFor: 10 in: #(1 2 3) ] on: NotFound do: [ :exception | exception ]! !NotFound methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 14:30'! object: anObject "Set the object that was not found" object := anObject! ! !NotFound methodsFor: 'private' stamp: 'nice 12/2/2011 23:35'! standardMessageText "Generate a standard textual description" ^ String streamContents: [ :stream | stream print: self object. stream << ' not found in '. stream print: self collection class ]! ! !NotFound methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 14:29'! object "Return the object that was not found" ^ object! ! !NotFound methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 14:27'! collection: aCollection "Set the collection where something is not found in" self signaler: aCollection! ! !NotFound methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 14:27'! collection "Return the collection where something is not found in" ^ self signaler! ! !NotFound methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 14:35'! messageText "Overwritten to initialiaze the message text to a standard text if it has not yet been set" ^ messageText ifNil: [ messageText := self standardMessageText ]! ! !NotFound class methodsFor: 'instance creation' stamp: 'MartinDias 10/23/2013 14:47'! signalFor: anObject "Create and signal a NotFound exception for anObject in the default receiver." ^ self new object: anObject; signal! ! !NotFound class methodsFor: 'instance creation' stamp: 'MartinDias 10/23/2013 14:47'! signalFor: anObject in: aCollection "Create and signal a NotFound exception for anObject in aCollection." ^ self new object: anObject; collection: aCollection; signal! ! !NotYetImplemented commentStamp: ''! I am NotYetImplement, an exception signaled when a method is a stub for code that will be implemented in the future. This is used in incremental development, for example when doing Test First development. It is similar to ShouldBeImplemented, with a slightly different meaning.! !NotYetImplemented methodsFor: 'printing' stamp: 'MarcusDenker 5/24/2012 10:08'! standardMessageText "Generate a standard textual description" ^ String streamContents: [ :stream | stream print: self selector. stream << ' is not yet implemented in '. stream print: self signaler class]! ! !Notification commentStamp: ''! A Notification is an indication that something interesting has occurred. If it is not handled, it will pass by without effect.! !Notification methodsFor: 'exceptiondescription' stamp: 'pnm 8/16/2000 15:04'! defaultAction "No action is taken. The value nil is returned as the value of the message that signaled the exception." ^nil! ! !NullCanvas commentStamp: ''! A canvas which ignores all drawing commands.! !NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:12'! form ^Form extent: self extent! ! !NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:11'! extent ^100@100! ! !NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:13'! origin ^0@0! ! !NullCanvas methodsFor: 'drawing-support' stamp: 'ls 3/27/2000 21:39'! transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize "do this in order that timing runs work better" aBlock value: self! ! !NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:11'! clipRect ^1@1 extent: 99@99! ! !NullCanvas methodsFor: 'drawing-support' stamp: 'ls 3/27/2000 21:40'! translateBy: delta during: aBlock "do this in order that timing runs work better" aBlock value: self! ! !NullCanvas methodsFor: 'copying' stamp: 'ls 3/20/2000 21:26'! copyClipRect: clipRect "who cares what the clipping rectangle is?" ^self! ! !NullCanvas methodsFor: 'drawing-support' stamp: 'ls 3/27/2000 21:41'! clipBy: region during: aBlock "do this in order that timing runs work better" aBlock value: self! ! !NullSound commentStamp: 'TorstenBergmann 2/5/2014 10:29'! The NullSound means silence ! !NullSound class methodsFor: 'playing' stamp: 'gvc 7/30/2009 17:55'! play "Do nothing for the null sound."! ! !NullSoundTheme commentStamp: 'TorstenBergmann 2/5/2014 10:30'! A silent sound theme! !NullSoundTheme methodsFor: 'initialize-release' stamp: 'gvc 7/30/2009 17:56'! defaultDefaultSound "Answer the default default sound!!" ^NullSound! ! !NullSoundTheme class methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 17:57'! themeName "Answer the friendly name of the theme." ^'No Sounds'! ! !NullStream commentStamp: ''! I am a stream that does nothing i.e. generates and consumes an infinite number of elements (NullObject pattern). I can be used as an equivalent of /dev/null (for example a logging in off mode) or for performance benchmarks.! !NullStream methodsFor: 'positioning' stamp: 'StephaneDucasse 3/13/2010 11:08'! skip: anInteger "Set the receiver's position to be the current position+anInteger. A subclass might choose to be more helpful and select the minimum of the receiver's size and position+anInteger, or the maximum of 1 and position+anInteger for the repositioning." self position: position + anInteger! ! !NullStream methodsFor: 'accessing' stamp: 'StephaneDucasse 3/13/2010 11:05'! element "The element returned by the stream" ^binary ifTrue: [0] ifFalse: [Character value: 0]! ! !NullStream methodsFor: 'accessing' stamp: 'StephaneDucasse 3/13/2010 11:05'! binary "Switches the stream to binary mode" binary := true! ! !NullStream methodsFor: 'reading' stamp: 'StephaneDucasse 3/13/2010 11:07'! nextInto: aCollection "Read the next elements of the receiver into aCollection. Return aCollection or a partial copy if less than aCollection size elements have been read." ^self next: aCollection size into: aCollection startingAt: 1.! ! !NullStream methodsFor: 'accessing' stamp: 'StephaneDucasse 3/13/2010 11:05'! collectionSpecies "The type of collection returned by the stream" ^binary ifTrue: [ByteArray] ifFalse: [ByteString]! ! !NullStream methodsFor: 'reading' stamp: 'StephaneDucasse 3/13/2010 11:06'! next "Answer the next object accessible by the receiver." position := position + 1. ^self element! ! !NullStream methodsFor: 'reading' stamp: 'StephaneDucasse 3/13/2010 11:06'! next: n into: aCollection "Read n objects into the given collection. Return aCollection or a partial copy if less than n elements have been read." ^self next: n into: aCollection startingAt: 1! ! !NullStream methodsFor: 'testing' stamp: 'ClementBera 7/29/2013 14:37'! isBinary "Return true if the receiver is a binary byte stream" ^binary ! ! !NullStream methodsFor: 'reading' stamp: 'StephaneDucasse 3/13/2010 11:07'! nextInto: aCollection startingAt: startIndex "Read the next elements of the receiver into aCollection. Return aCollection or a partial copy if less than aCollection size elements have been read." ^self next: (aCollection size - startIndex +1) into: aCollection startingAt: startIndex.! ! !NullStream methodsFor: 'positioning' stamp: 'StephaneDucasse 3/13/2010 11:08'! position: anInteger "Set the current position for accessing the objects to be anInteger, as long as anInteger is within the bounds of the receiver's contents. If it is not, create an error notification." (anInteger >= 0) ifTrue: [position := anInteger] ifFalse: [self positionError]! ! !NullStream methodsFor: 'initialization' stamp: 'StephaneDucasse 3/13/2010 11:06'! initialize "Initialize the receiver" binary := false. position := 0.! ! !NullStream methodsFor: 'reading' stamp: 'DamienCassou 3/27/2014 16:51'! peekLast ^ lastElement! ! !NullStream methodsFor: 'printing' stamp: 'MilanMimica 11/4/2011 21:22'! printOn: aStream aStream nextPutAll: 'a '; nextPutAll: self class name.! ! !NullStream methodsFor: 'writing' stamp: 'DamienCassou 3/27/2014 17:20'! nextPutAll: aCollection "Append the elements of aCollection to the sequence of objects accessible by the receiver. Answer aCollection." position := position + aCollection size. aCollection isEmpty ifFalse: [ lastElement := aCollection last ]. ^ aCollection! ! !NullStream methodsFor: 'accessing' stamp: 'StephaneDucasse 3/13/2010 11:04'! ascii "Switches the stream to ascii mode" binary := false.! ! !NullStream methodsFor: 'writing' stamp: 'DamienCassou 3/27/2014 16:53'! cr ^ self nextPut: Character cr! ! !NullStream methodsFor: 'writing' stamp: 'StephaneDucasse 3/13/2010 11:08'! peek "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil." ^self element! ! !NullStream methodsFor: 'writing' stamp: 'DamienCassou 3/27/2014 17:15'! tab ^ self nextPut: Character tab! ! !NullStream methodsFor: 'writing' stamp: 'DamienCassou 3/27/2014 16:53'! lf ^ self nextPut: Character lf! ! !NullStream methodsFor: 'testing' stamp: 'StephaneDucasse 3/13/2010 11:05'! isEmpty "Answer whether the receiver's contents has no elements." ^false ! ! !NullStream methodsFor: 'writing' stamp: 'DamienCassou 3/27/2014 16:54'! nextPut: anObject "Insert the argument, anObject, as the next object accessible by the receiver. Answer anObject." position := position + 1. lastElement := anObject. ^anObject! ! !NullStream methodsFor: 'writing' stamp: 'StephaneDucasse 3/13/2010 11:07'! next: anInteger putAll: aCollection "Store the next anInteger elements from the given collection." ^self next: anInteger putAll: aCollection startingAt: 1! ! !NullStream methodsFor: 'testing' stamp: 'StephaneDucasse 3/13/2010 11:05'! atEnd "Answer whether the receiver can access any more objects." ^false! ! !NullStream methodsFor: 'positioning' stamp: 'StephaneDucasse 3/13/2010 11:08'! reset "Set the receiver's position to the beginning of the sequence of objects." position := 0! ! !NullStream methodsFor: 'reading' stamp: 'StephaneDucasse 3/13/2010 11:06'! next: anInteger "Answer the next anInteger elements of my collection. Must override because default uses self contents species, which might involve a large collection." position := position + anInteger. ^self collectionSpecies new: anInteger! ! !NullStream methodsFor: 'writing' stamp: 'DamienCassou 3/27/2014 17:15'! space ^ self nextPut: Character space! ! !NullStream methodsFor: 'positioning' stamp: 'StephaneDucasse 3/13/2010 11:08'! position "Answer the current position of accessing the sequence of objects." ^position! ! !NullStream methodsFor: 'writing' stamp: 'DamienCassou 3/27/2014 17:02'! next: anInteger putAll: aCollection startingAt: startIndex "Store the next anInteger elements from the given collection." position := position + anInteger. lastElement := aCollection at: anInteger + startIndex - 1. ^aCollection! ! !NullStream methodsFor: 'reading' stamp: 'StephaneDucasse 3/13/2010 11:07'! next: n into: aCollection startingAt: startIndex "Read n objects into the given collection. Return aCollection or a partial copy if less than n elements have been read." position := position + n. ^aCollection! ! !NullStream methodsFor: 'accessing' stamp: 'StephaneDucasse 3/13/2010 11:05'! contents "Answer all of the contents of the receiver." self shouldNotImplement! ! !NullStream methodsFor: 'reading' stamp: 'SvenVanCaekenberghe 4/26/2011 09:19'! readInto: collection startingAt: startIndex count: n "Read n objects into the given collection. Return number of elements that have been read." position := position + n. ^ n! ! !NullStream class methodsFor: 'instance creation' stamp: 'StephaneDucasse 3/13/2010 11:09'! new "Creates a new instance" ^self basicNew initialize! ! !NullStreamTest methodsFor: 'tests' stamp: 'DamienCassou 3/27/2014 17:21'! testNextPutAllEmpty self assert: stream position equals: 0. self assert: stream peekLast equals: nil. stream nextPutAll: ''. self assert: stream position equals: 0. self assert: stream peekLast equals: nil.! ! !NullStreamTest methodsFor: 'tests' stamp: 'DamienCassou 3/27/2014 17:14'! testPeekLast self assert: stream peekLast equals: nil. stream nextPut: $a. self assert: stream peekLast equals: $a. stream nextPutAll: 'bcd'. self assert: stream peekLast equals: $d. stream cr. self assert: stream peekLast equals: Character cr. stream lf. self assert: stream peekLast equals: Character lf. stream space. self assert: stream peekLast equals: Character space. stream tab. self assert: stream peekLast equals: Character tab. stream next: 4 putAll: 'abcdefgh' startingAt: 3. self assert: stream peekLast equals: $f.! ! !NullStreamTest methodsFor: 'tests' stamp: 'DamienCassou 3/27/2014 17:18'! testCounting | expectedPosition | expectedPosition := 0. self assert: stream position equals: expectedPosition. stream nextPut: $a. expectedPosition := expectedPosition + 1. self assert: stream position equals: expectedPosition. stream nextPutAll: 'bcd'. expectedPosition := expectedPosition + 3. self assert: stream position equals: expectedPosition. stream cr. expectedPosition := expectedPosition + 1. self assert: stream position equals: expectedPosition. stream lf. expectedPosition := expectedPosition + 1. self assert: stream position equals: expectedPosition. stream space. expectedPosition := expectedPosition + 1. self assert: stream position equals: expectedPosition. stream tab. expectedPosition := expectedPosition + 1. self assert: stream position equals: expectedPosition. stream next: 4 putAll: 'abcdefgh' startingAt: 3. expectedPosition := expectedPosition + 4. self assert: stream position equals: expectedPosition.! ! !NullStreamTest methodsFor: 'running' stamp: 'DamienCassou 3/27/2014 16:46'! setUp super setUp. stream := NullStream new.! ! !NullTaskList commentStamp: 'SeanDeNigris 1/23/2014 11:53'! I stand in when the task list is not open in the world.! !NullTaskList methodsFor: 'private' stamp: 'SeanDeNigris 1/22/2014 19:56'! world: aWorldMorph world := aWorldMorph.! ! !NullTaskList methodsFor: 'event handling' stamp: 'SeanDeNigris 1/23/2014 12:00'! handleEvent: aKeyboardEvent aKeyboardEvent isWindowNavigation ifFalse: [ ^ false ]. world theme openTaskListIn: world from: aKeyboardEvent. ^ true.! ! !NullTaskList class methodsFor: 'instance creation' stamp: 'SeanDeNigris 1/22/2014 19:56'! in: world ^ self new world: world; yourself.! ! !NullTextStyler commentStamp: 'BenjaminVanRyseghem 8/1/2010 22:53'! This class is a styler NullObject! !NullTextStyler methodsFor: 'formatting' stamp: 'BenjaminVanRyseghem 8/1/2010 14:26'! format: aText ^aText! ! !NullTextStyler methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/2/2010 16:17'! font: aFont! ! !NullTextStyler methodsFor: 'private' stamp: 'AlainPlantec 9/19/2011 19:32'! stylingEnabled ^ false! ! !NullTextStyler methodsFor: 'accessing' stamp: 'AlainPlantec 8/27/2011 14:15'! environment: anObject ! ! !NullTextStyler methodsFor: 'accessing' stamp: 'AlainPlantec 5/11/2011 11:02'! view: aViewOrMorph ! ! !NullTextStyler methodsFor: 'styling' stamp: 'BenjaminVanRyseghem 8/1/2010 14:27'! style: aText! ! !NullTextStyler methodsFor: 'styling' stamp: 'StephaneDucasse 8/10/2010 12:35'! unstyledTextFrom: aText ^aText! ! !NullTextStyler methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/2/2010 16:17'! classOrMetaClass: aBehavior! ! !NullTextStyler methodsFor: 'styling' stamp: 'AlainPlantec 5/11/2011 10:36'! styleInBackgroundProcess: aText ! ! !NullTextStyler methodsFor: 'private' stamp: 'AlainPlantec 9/19/2011 19:32'! stylingEnabled: aBoolean ! ! !NullTextStyler methodsFor: 'accessing' stamp: 'AlainPlantec 5/11/2011 11:03'! workspace: aWorkspace ! ! !Number commentStamp: ''! Class Number holds the most general methods for dealing with numbers. Subclasses Float, Fraction, and Integer, and their subclasses, provide concrete representations of a numeric quantity. All of Number's subclasses participate in a simple type coercion mechanism that supports mixed-mode arithmetic and comparisons. It works as follows: If self op: arg fails because of incompatible types, then it is retried in the following guise: (arg adaptTypeA: self) op: arg adaptToTypeA. This gives the arg of typeB an opportunity to resolve the incompatibility, knowing exactly what two types are involved. If self is more general, then arg will be converted, and viceVersa. This mechanism is extensible to any new number classes that one might wish to add to Pharo. The only requirement is that every subclass of Number must support a pair of conversion methods specific to each of the other subclasses of Number. Implementation notes ---------------------------------- The implementation of #degreeCos and #degreeSin is such that results are exact for any multiple of 90. Care is also taken to evaluate the sine between -90° and 90°, this will avoid #degreesToRadians and i386 FPU sine function to accumulate round off errors due to approximate representation of pi. We can thus evaluate 240 degreeCos with at most 1 ulp error. It's not perfect, but better than previous implementation. For cosine, we know that: cosd(x)=cosd(abs(x)) cosd(x)=sind(90-x) thus the trick is to evaluate: cosd(x)=sind(90-abs(x)) after appropriate modulo in [-180,180[ This way, we are sure to evaluate the sine between -90° and 90° The #degreesToRadians and #sin are used rather than #degreeSin to avoid cycles. For sine, it would be necessary to evaluate either sind(x) if abs(x) <=90 or sind(180-x) if abs(x) >= 90 A possible implementation would be: | x | x := 90 + self \\ 360 - 90. x >= 180 ifTrue: [x := 180 - x]. ^x degreesToRadians sin We prefer evaluating cosd(90-x) thus providing a branch free implementation.! !Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:02'! strictlyPositive "Answer whether the receiver is mathematically positive." ^ self > 0! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/24/2012 15:32'! hour ^ self hours! ! !Number methodsFor: 'mathematical functions' stamp: 'CamilloBruni 7/10/2012 22:24'! ** exponent " A shortcut methog for raisedTo: " ^ self raisedTo: exponent! ! !Number methodsFor: 'intervals' stamp: 'tao 1/30/1999 08:58'! to: stop by: step do: aBlock "Normally compiled in-line, and therefore not overridable. Evaluate aBlock for each element of the interval (self to: stop by: step)." | nextValue | nextValue := self. step = 0 ifTrue: [self error: 'step must be non-zero']. step < 0 ifTrue: [[stop <= nextValue] whileTrue: [aBlock value: nextValue. nextValue := nextValue + step]] ifFalse: [[stop >= nextValue] whileTrue: [aBlock value: nextValue. nextValue := nextValue + step]]! ! !Number methodsFor: 'mathematical functions' stamp: 'jmv 10/13/2011 08:36'! nthRoot: aPositiveInteger "Answer the nth root of the receiver." self subclassResponsibility! ! !Number methodsFor: 'mathematical functions' stamp: 'nice 10/31/2010 22:03'! degreeCos "Answer the cosine of the receiver taken as an angle in degrees." ^ (90 - (180 + self \\ 360 - 180) abs) degreesToRadians sin! ! !Number methodsFor: 'intervals' stamp: ''! to: stop by: step "Answer an Interval from the receiver up to the argument, stop, incrementing by step." ^Interval from: self to: stop by: step! ! !Number methodsFor: 'arithmetic' stamp: ''! \\ aNumber "modulo. Remainder defined in terms of //. Answer a Number with the same sign as aNumber. e.g. 9\\4 = 1, -9\\4 = 3, 9\\-4 = -3, 0.9\\0.4 = 0.1." ^self - (self // aNumber * aNumber)! ! !Number methodsFor: 'testing' stamp: 'tao 10/10/97 16:36'! isNaN ^ false! ! !Number methodsFor: 'converting' stamp: 'ar 5/20/2001 01:40'! asB3DVector3 ^self@self@self! ! !Number methodsFor: 'printing' stamp: 'nice 3/29/2011 21:48'! printOn: aStream showingDecimalPlaces: placesDesired "Print a representation of the receiver on aStream in decimal notation with prescribed number of places after decimal separator." | rounder rounded roundedFractionPart | placesDesired <= 0 ifTrue: [^ self rounded printOn: aStream]. rounder := 10 raisedToInteger: placesDesired. rounded := self roundTo: rounder reciprocal. rounded negative ifTrue: [aStream nextPut: $-]. rounded := rounded abs. rounded integerPart truncated printOn: aStream. aStream nextPut: $.. roundedFractionPart := (rounded fractionPart * rounder) truncated. roundedFractionPart printOn: aStream base: 10 length: placesDesired padded: true! ! !Number methodsFor: 'arithmetic' stamp: ''! // aNumber "Integer quotient defined by division with truncation toward negative infinity. 9//4 = 2, -9//4 = -3. -0.9//0.4 = -3. \\ answers the remainder from this division." ^(self / aNumber) floor! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 15:12'! second ^ self seconds ! ! !Number methodsFor: 'mathematical functions' stamp: 'jsp 2/24/1999 15:20'! arcTan: denominator "The receiver is the tangent of an angle. Answer the angle measured in radians." ^(self asFloat) arcTan: denominator.! ! !Number methodsFor: 'intervals' stamp: ''! to: stop "Answer an Interval from the receiver up to the argument, stop, incrementing by 1." ^Interval from: self to: stop by: 1! ! !Number methodsFor: 'arithmetic' stamp: ''! negated "Answer a Number that is the negation of the receiver." ^0 - self! ! !Number methodsFor: 'mathematical functions' stamp: ''! exp "Answer the exponential of the receiver as a floating point number." ^self asFloat exp! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 16:00'! milliSecond ^ self milliSeconds ! ! !Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:45'! adaptToString: rcvr andSend: selector "If I am involved in arithmetic with a String, convert it to a Number." ^ rcvr asNumber perform: selector with: self! ! !Number methodsFor: 'converting' stamp: 'nice 5/16/2009 22:46'! asScaledDecimal: scale "Answer the receiver converted to a ScaledDecimal." ^ ScaledDecimal newFromNumber: self scale: scale! ! !Number methodsFor: 'truncation and round off' stamp: 'StephaneDucasse 5/8/2010 17:14'! fractionPart "Added for ANSI compatibility" ^self - self integerPart! ! !Number methodsFor: 'mathematical functions' stamp: ''! sign "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0." self > 0 ifTrue: [^1]. self < 0 ifTrue: [^-1]. ^0! ! !Number methodsFor: 'arithmetic' stamp: ''! + aNumber "Answer the sum of the receiver and aNumber." self subclassResponsibility! ! !Number methodsFor: 'mathematical functions' stamp: ''! tan "The receiver represents an angle measured in radians. Answer its tangent." ^self asFloat tan! ! !Number methodsFor: 'converting' stamp: ''! asInteger "Answer an Integer nearest the receiver toward zero." ^self truncated! ! !Number methodsFor: 'converting' stamp: ''! degreesToRadians "The receiver is assumed to represent degrees. Answer the conversion to radians." ^self asFloat degreesToRadians! ! !Number methodsFor: 'mathematical functions' stamp: ''! log: aNumber "Answer the log base aNumber of the receiver." ^self ln / aNumber ln! ! !Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:53'! printOn: aStream self printOn: aStream base: 10! ! !Number methodsFor: 'mathematical functions' stamp: 'Janniklaval 10/23/2010 13:47'! sign: aNumber "Return a Number with the same sign as aNumber" ^ aNumber copySignTo: self.! ! !Number methodsFor: 'printing' stamp: 'laza 3/30/2004 10:50'! printString ^self printStringBase: 10! ! !Number methodsFor: 'converting' stamp: 'dtl 9/25/2004 11:47'! asScaledDecimal "Answer a scaled decimal number approximating the receiver." #Numeric. ^ self asScaledDecimal: 8 ! ! !Number methodsFor: 'converting' stamp: 'nice 1/4/2009 20:31'! adaptToFloat: rcvr andCompare: selector "If I am involved in comparison with a Float, convert rcvr to a Fraction. This way, no bit is lost and comparison is exact." rcvr isFinite ifFalse: [ selector == #= ifTrue: [^false]. selector == #~= ifTrue: [^true]. rcvr isNaN ifTrue: [^ false]. (selector = #< or: [selector = #'<=']) ifTrue: [^ rcvr positive not]. (selector = #> or: [selector = #'>=']) ifTrue: [^ rcvr positive]. ^self error: 'unknow comparison selector']. ^ rcvr asTrueFraction perform: selector with: self! ! !Number methodsFor: 'truncation and round off' stamp: 'GabrielOmarCotelli 5/26/2009 21:57'! integerPart "Added for ANSI compatibility" ^self truncated! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 16:07'! minute ^ self minutes ! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 5/16/2003 07:56'! days ^ Duration days: self! ! !Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'! adaptToPoint: rcvr andSend: selector "If I am involved in arithmetic with a Point, convert me to a Point." ^ rcvr perform: selector with: self@self! ! !Number methodsFor: 'truncation and round off' stamp: 'di 10/4/1999 08:08'! roundTo: quantum "Answer the nearest number that is a multiple of quantum." ^(self / quantum) rounded * quantum! ! !Number methodsFor: '*monticellofiletree-core' stamp: 'dkh 4/6/2012 15:56:14'! writeCypressJsonOn: aStream forHtml: forHtml indent: startIndent "by default ignore ... is used for Dictionary and Array, i.e., container objects and String which actually encodes itself differently for HTML" aStream nextPutAll: self printString! ! !Number methodsFor: 'mathematical functions' stamp: 'nice 10/31/2010 22:01'! degreeSin "Answer the sine of the receiver taken as an angle in degrees." ^(90 - self) degreeCos! ! !Number methodsFor: 'mathematical functions' stamp: 'jmv 10/11/2011 08:34'! sqrt "Answer the square root of the receiver." self subclassResponsibility! ! !Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:50'! storeOn: aStream self printOn: aStream! ! !Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'! negative "Answer whether the receiver is mathematically negative." ^ self < 0! ! !Number methodsFor: 'printing' stamp: 'sw 7/1/1998 12:33'! stringForReadout ^ self rounded printString! ! !Number methodsFor: 'mathematical functions' stamp: 'jmv 10/13/2011 08:50'! raisedTo: aNumber "Answer the receiver raised to aNumber." aNumber isInteger ifTrue: [ "Do the special case of integer power" ^ self raisedToInteger: aNumber]. aNumber isFraction ifTrue: [ "Special case for fraction power" ^ (self nthRoot: aNumber denominator) raisedToInteger: aNumber numerator ]. self < 0 ifTrue: [ ^ ArithmeticError signal: 'Negative numbers can''t be raised to float powers.' ]. 0 = aNumber ifTrue: [^ self class one]. "Special case of exponent=0" 1 = aNumber ifTrue: [^ self]. "Special case of exponent=1" 0 = self ifTrue: [ "Special case of self = 0" aNumber < 0 ifTrue: [^ (ZeroDivide dividend: self) signal] ifFalse: [^ self]]. ^ (aNumber * self ln) exp "Otherwise use logarithms"! ! !Number methodsFor: 'printing' stamp: 'nice 9/25/2007 02:35'! storeOn: aStream base: base "This method should print a representation of the number for the given base, including the base prefix (with letter r for radix)" ^self subclassResponsibility! ! !Number methodsFor: 'printing' stamp: 'nice 3/29/2011 21:39'! printShowingDecimalPlaces: placesDesired "Print the receiver showing precisely the given number of places desired. If placesDesired is positive, a decimal point and that many digits after the decimal point will always be shown. If placesDesired is zero, a whole number will be shown, without a decimal point." ^String new: placesDesired + 10 streamContents: [:aStream | self printOn: aStream showingDecimalPlaces: placesDesired] " 23 printShowingDecimalPlaces: 2 23.5698 printShowingDecimalPlaces: 2 -234.567 printShowingDecimalPlaces: 5 23.4567 printShowingDecimalPlaces: 0 23.5567 printShowingDecimalPlaces: 0 -23.4567 printShowingDecimalPlaces: 0 -23.5567 printShowingDecimalPlaces: 0 100000000 printShowingDecimalPlaces: 1 0.98 printShowingDecimalPlaces: 5 -0.98 printShowingDecimalPlaces: 2 2.567 printShowingDecimalPlaces: 2 -2.567 printShowingDecimalPlaces: 2 0 printShowingDecimalPlaces: 2 "! ! !Number methodsFor: 'mathematical functions' stamp: 'ar 8/31/2000 20:05'! interpolateTo: aNumber at: param ^self + (aNumber - self * param)! ! !Number methodsFor: 'converting' stamp: 'SvenVanCaekenberghe 3/8/2012 08:20'! asFloat "Answer a floating-point number approximating the receiver." self subclassResponsibility! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 5/16/2003 08:52'! nanoSeconds ^ Duration nanoSeconds: self.! ! !Number methodsFor: 'truncation and round off' stamp: 'di 2/19/98 21:58'! detentBy: detent atMultiplesOf: grid snap: snap "Map all values that are within detent/2 of any multiple of grid to that multiple. Otherwise, if snap is true, return self, meaning that the values in the dead zone will never be returned. If snap is false, then expand the range between dead zones so that it covers the range between multiples of the grid, and scale the value by that factor." | r1 r2 | r1 := self roundTo: grid. "Nearest multiple of grid" (self roundTo: detent) = r1 ifTrue: [^ r1]. "Snap to that multiple..." snap ifTrue: [^ self]. "...or return self" r2 := self < r1 "Nearest end of dead zone" ifTrue: [r1 - (detent asFloat/2)] ifFalse: [r1 + (detent asFloat/2)]. "Scale values between dead zones to fill range between multiples" ^ r1 + ((self - r2) * grid asFloat / (grid - detent)) " (170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: true] (170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: false] (3.9 to: 4.1 by: 0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: true] (-3.9 to: -4.1 by: -0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: false] "! ! !Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'! adaptToInteger: rcvr andSend: selector "If I am involved in arithmetic with a Integer, convert us and evaluate exprBlock." ^ self subclassResponsibility! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 16:23'! year ^self years! ! !Number methodsFor: 'arithmetic' stamp: ''! * aNumber "Answer the result of multiplying the receiver by aNumber." self subclassResponsibility! ! !Number methodsFor: 'testing' stamp: ''! isNumber ^ true! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'CamilloBruni 6/22/2012 21:48'! asSeconds ^ Duration milliSeconds: self * 1000! ! !Number methodsFor: 'arithmetic' stamp: ''! rem: aNumber "Remainder defined in terms of quo:. Answer a Number with the same sign as self. e.g. 9 rem: 4 = 1, -9 rem: 4 = -1. 0.9 rem: 0.4 = 0.1." ^self - ((self quo: aNumber) * aNumber)! ! !Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:43'! adaptToCollection: rcvr andSend: selector "If I am involved in arithmetic with a Collection, return a Collection of the results of each element combined with me in that expression." ^ rcvr collect: [:element | element perform: selector with: self]! ! !Number methodsFor: 'mathematical functions' stamp: 'GabrielOmarCotelli 5/26/2009 19:49'! raisedToInteger: anInteger "The 0 raisedToInteger: 0 is an special case. In some contexts must be 1 and in others must be handled as an indeterminate form. I take the first context because that's the way that was previously handled. Maybe further discussion is required on this topic." |bitProbe result| anInteger negative ifTrue: [^(self raisedToInteger: anInteger negated) reciprocal]. bitProbe := 1 bitShift: anInteger highBit - 1. result := self class one. [ (anInteger bitAnd: bitProbe) = 0 ifFalse: [result := result * self]. bitProbe := bitProbe bitShift: -1. bitProbe > 0 ] whileTrue: [result := result * result]. ^result! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 16:23'! nanoSecond ^ self nanoSeconds ! ! !Number methodsFor: 'truncation and round off' stamp: 'AlexandreBergel 8/21/2011 17:45'! ceiling "Answer the integer nearest the receiver toward infinity." | truncation | truncation := self truncated. self <= 0 ifTrue: [ ^ truncation ]. ^ self = truncation ifTrue: [ truncation ] ifFalse: [ truncation + 1 ]! ! !Number methodsFor: 'converting' stamp: ''! radiansToDegrees "The receiver is assumed to represent radians. Answer the conversion to degrees." ^self asFloat radiansToDegrees! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'md 8/28/2013 15:37'! asDuration ^ Duration seconds: self asInteger ! ! !Number methodsFor: 'converting' stamp: ''! asPoint "Answer a Point with the receiver as both coordinates; often used to supply the same value in two dimensions, as with symmetrical gridding or scaling." ^self @ self! ! !Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'! adaptToFraction: rcvr andSend: selector "If I am involved in arithmetic with a Fraction, convert us and evaluate exprBlock." ^ self subclassResponsibility! ! !Number methodsFor: 'converting' stamp: 'nice 10/5/2009 21:28'! asSmallPositiveDegrees "Return the receiver normalized to lie within the range (0, 360)" ^self \\ 360! ! !Number methodsFor: 'mathematical functions' stamp: 'CamilloBruni 7/13/2012 17:37'! % aNumber "modulo. Remainder defined in terms of //. Answer a Number with the same sign as aNumber. e.g. 9\\4 = 1, -9\\4 = 3, 9\\-4 = -3, 0.9\\0.4 = 0.1." ^ self \\ aNumber! ! !Number methodsFor: 'converting' stamp: ''! @ y "Primitive. Answer a Point whose x value is the receiver and whose y value is the argument. Optional. No Lookup. See Object documentation whatIsAPrimitive." ^Point x: self y: y! ! !Number methodsFor: 'truncation and round off' stamp: 'CamilloBrui 7/8/2011 12:17'! roundDownTo: aNumber "Answer the next multiple of aNumber toward negative infinity that is nearest the receiver. Examples: 3.1479 roundDownTo: 0.01 -> 3.14 3.1479 roundDownTo: 0.1 -> 3.1 1923 roundDownTo: 10 -> 1920 3.1479 roundDownTo: 0.005 -> 3.145 -3.1479 roundDownTo: 0.01 -> -3.15" ^(self / aNumber) floor * aNumber! ! !Number methodsFor: 'arithmetic' stamp: ''! abs "Answer a Number that is the absolute value (positive magnitude) of the receiver." self < 0 ifTrue: [^self negated] ifFalse: [^self]! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 5/16/2003 07:56'! hours ^ Duration hours: self! ! !Number methodsFor: 'mathematical functions' stamp: ''! arcTan "The receiver is the tangent of an angle. Answer the angle measured in radians." ^self asFloat arcTan! ! !Number methodsFor: 'mathematical functions' stamp: ''! sin "The receiver represents an angle measured in radians. Answer its sine." ^self asFloat sin! ! !Number methodsFor: 'mathematical functions' stamp: ''! squared "Answer the receiver multipled by itself." ^self * self! ! !Number methodsFor: 'mathematical functions' stamp: 'nice 12/11/2012 19:18'! floorLog: radix "Answer the floor of the log base radix of the receiver." ^(self log: radix) floor! ! !Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:21'! adaptToFloat: rcvr andSend: selector "If I am involved in arithmetic with a Float, convert me to a Float." ^ rcvr perform: selector with: self asFloat! ! !Number methodsFor: 'mathematical functions' stamp: 'di 9/8/1998 17:10'! log "Answer the base-10 log of the receiver." ^self asFloat log! ! !Number methodsFor: 'arithmetic' stamp: 'GabrielOmarCotelli 5/23/2009 20:20'! reciprocal "Returns the reciprocal of self. In case self is 0 the / signals ZeroDivide" ^1 / self! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 9/25/2003 13:16'! milliSeconds ^ Duration milliSeconds: self ! ! !Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:17'! positive "Answer whether the receiver is positive or equal to 0. (ST-80 protocol). See also strictlyPositive" ^ self >= 0! ! !Number methodsFor: 'printing' stamp: ''! printStringBase: base ^ String streamContents: [:strm | self printOn: strm base: base]! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 15:51'! day ^ self days! ! !Number methodsFor: 'printing' stamp: ''! storeStringBase: base ^ String streamContents: [:strm | self storeOn: strm base: base]! ! !Number methodsFor: 'testing' stamp: ''! odd "Answer whether the receiver is an odd number." ^self even == false! ! !Number methodsFor: 'truncation and round off' stamp: ''! rounded "Answer the integer nearest the receiver." ^(self + (self sign / 2)) truncated! ! !Number methodsFor: 'arithmetic' stamp: ''! / aNumber "Answer the result of dividing the receiver by aNumber." self subclassResponsibility! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 5/16/2003 07:56'! minutes ^ Duration minutes: self! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 5/16/2003 07:57'! seconds ^ Duration seconds: self! ! !Number methodsFor: 'arithmetic' stamp: 'CamilloBruni 7/13/2012 19:09'! quo: aNumber "Integer quotient defined by division with truncation toward zero. -9 quo: 4 = -2. -0.9 quo: 0.4 = -2. rem: answers the remainder from this division." ^(self / aNumber) truncated! ! !Number methodsFor: 'comparing' stamp: 'nice 12/26/2009 18:46'! closeTo: num "are these two numbers close?" num isFloat ifTrue: [^ num closeTo: self asFloat]. ^[self = num] ifError: [false]! ! !Number methodsFor: 'mathematical functions' stamp: ''! arcCos "The receiver is the cosine of an angle. Answer the angle measured in radians." ^self asFloat arcCos! ! !Number methodsFor: 'truncation and round off' stamp: ''! floor "Answer the integer nearest the receiver toward negative infinity." | truncation | truncation := self truncated. self >= 0 ifTrue: [^truncation]. self = truncation ifTrue: [^truncation] ifFalse: [^truncation - 1]! ! !Number methodsFor: 'arithmetic' stamp: ''! - aNumber "Answer the difference between the receiver and aNumber." self subclassResponsibility! ! !Number methodsFor: 'converting' stamp: 'nice 4/23/2011 02:25'! withNegativeSign "Answer a number with same magnitude than receiver and negative sign." ^self abs negated! ! !Number methodsFor: 'mathematical functions' stamp: ''! cos "The receiver represents an angle measured in radians. Answer its cosine." ^self asFloat cos! ! !Number methodsFor: 'intervals' stamp: ''! to: stop do: aBlock "Normally compiled in-line, and therefore not overridable. Evaluate aBlock for each element of the interval (self to: stop by: 1)." | nextValue | nextValue := self. [nextValue <= stop] whileTrue: [aBlock value: nextValue. nextValue := nextValue + 1]! ! !Number methodsFor: 'truncation and round off' stamp: ''! truncated "Answer an integer nearest the receiver toward zero." ^self quo: 1! ! !Number methodsFor: 'truncation and round off' stamp: ''! reduce "If self is close to an integer, return that integer" ^ self! ! !Number methodsFor: 'printing' stamp: 'nice 9/25/2007 02:36'! printOn: aStream base: base "This method should print a representation of the number for the given base, excluding the base prefix (and the letter r for radix)" ^self subclassResponsibility! ! !Number methodsFor: 'truncation and round off' stamp: 'CamilloBrui 7/8/2011 12:17'! truncateTo: aNumber "Answer the next multiple of aNumber toward zero that is nearest the receiver. Examples: 3.1479 truncateTo: 0.01 -> 3.14 3.1479 truncateTo: 0.1 -> 3.1 1923 truncateTo: 10 -> 1920 3.1479 truncateTo: 0.005 -> 3.145 -3.1479 truncateTo: 0.01 -> -3.14" ^(self quo: aNumber) * aNumber! ! !Number methodsFor: 'converting' stamp: 'sw 2/16/1999 18:15'! asNumber ^ self! ! !Number methodsFor: 'mathematical functions' stamp: ''! ln "Answer the natural log of the receiver." ^self asFloat ln! ! !Number methodsFor: 'testing' stamp: 'sw 12/30/1998 13:21'! isDivisibleBy: aNumber aNumber = 0 ifTrue: [^ false]. aNumber isInteger ifFalse: [^ false]. ^ (self \\ aNumber) = 0! ! !Number methodsFor: 'truncation and round off' stamp: 'CamilloBrui 7/8/2011 12:17'! roundUpTo: aNumber "Answer the next multiple of aNumber toward infinity that is nearest the receiver. Examples: 3.1479 roundUpTo: 0.01 -> 3.15 3.1479 roundUpTo: 0.1 -> 3.2 1923 roundUpTo: 10 -> 1930 3.1479 roundUpTo: 0.005 -> 3.15 -3.1479 roundUpTo: 0.01 -> -3.14" ^(self / aNumber) ceiling * aNumber! ! !Number methodsFor: 'converting' stamp: 'sw 9/8/97 16:30'! asSmallAngleDegrees "Return the receiver normalized to lie within the range (-180, 180)" | pos | pos := self \\ 360. pos > 180 ifTrue: [pos := pos - 360]. ^ pos "#(-500 -300 -150 -5 0 5 150 300 500 1200) collect: [:n | n asSmallAngleDegrees]"! ! !Number methodsFor: 'mathematical functions' stamp: ''! arcSin "The receiver is the sine of an angle. Answer the angle measured in radians." ^self asFloat arcSin! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 5/16/2003 07:57'! weeks ^ Duration weeks: self! ! !Number methodsFor: 'mathematical functions' stamp: 'nice 4/23/2011 02:26'! copySignTo: aNumber "Return a number with same magnitude as aNumber and same sign as self." ^ self positive ifTrue: [aNumber abs] ifFalse: [aNumber withNegativeSign].! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'CamilloBruni 9/22/2012 10:48'! years ^ Duration years: self! ! !Number methodsFor: 'testing' stamp: 'tao 4/19/98 23:33'! isInfinite ^ false! ! !Number methodsFor: 'testing' stamp: ''! even "Answer whether the receiver is an even number." ^self \\ 2 = 0! ! !Number methodsFor: '*Morphic-Base' stamp: 'cb 6/25/2013 13:24'! defaultLabel "Answer the default label to be used for an Inspector window on the receiver." ^ super defaultLabel, ': ', self printString! ! !Number methodsFor: 'truncation and round off' stamp: 'GuillermoPolito 6/22/2012 14:49'! round: numberOfWishedDecimal self subclassResponsibility! ! !Number methodsFor: 'converting' stamp: 'StephaneDucasse 9/7/2013 13:10'! asMargin ^ Margin fromNumber: self.! ! !Number methodsFor: 'testing' stamp: ''! isZero ^self = 0! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 15:15'! week ^ self weeks ! ! !Number class methodsFor: 'instance creation' stamp: 'YuriyTymchuk 10/29/2013 11:10'! squeezeNumberOutOfString: stringOrStream "Try and find a number in this string. First, look if the string starts with a number. Then, see if it ends with a number. Then, remove a character from the front and see if the remaining string makes a number. Repeat the process until no characters are left or the number has been found. As soon as a number is found, it is returned. Otherwise, the method fails." ^ NumberParser squeezeNumberOutOfString: stringOrStream! ! !Number class methodsFor: 'instance creation' stamp: 'YuriyTymchuk 10/29/2013 11:14'! readFrom: stringOrStream "Answer a number as described on aStream. The number may be any accepted Smalltalk literal Number format. It can include a leading radix specification, as in 16rFADE. It can as well be NaN, Infinity or -Infinity for conveniency. If stringOrStream does not start with a valid number description, fail." ^(NumberParser on: stringOrStream) nextNumber! ! !Number class methodsFor: 'instance creation' stamp: 'YuriyTymchuk 10/29/2013 11:10'! squeezeNumberOutOfString: stringOrStream ifFail: aBlock "Try and find a number in this string. First, look if the string starts with a number. Then, see if it ends with a number. Then, remove a character from the front and see if the remaining string makes a number. Repeat the process until no characters are left or the number has been found. As soon as a number is found, it is returned. Otherwise, the method fails." ^ NumberParser squeezeNumberOutOfString: stringOrStream onError: aBlock! ! !Number class methodsFor: 'instance creation' stamp: 'MarcusDenker 11/15/2013 10:54'! readFrom: stringOrStream ifFail: aBlock "Answer a number as described on aStream. The number may be any accepted Smalltalk literal Number format. It can include a leading radix specification, as in 16rFADE. It can as well be NaN, Infinity or -Infinity for conveniency. If input does not represent a valid number, then execute fail block and leave the stream positioned before offending character" ^(NumberParser on: stringOrStream) failBlock: aBlock; nextNumber! ! !Number class methodsFor: 'deprecated' stamp: 'dtl 7/3/2006 17:41'! readExponent: baseValue base: base from: aStream "Complete creation of a number, reading exponent from aStream. Answer the number, or nil if parsing fails. (e|d|q)>" | sign exp value | ('edq' includes: aStream next) ifFalse: [^ nil]. sign := ((aStream peek) == $-) ifTrue: [aStream next. -1] ifFalse: [1]. (aStream atEnd or: [(aStream peek digitValue between: 0 and: 9) not]) ifTrue: [^ nil]. "Avoid throwing an error" exp := (Integer readFrom: aStream base: 10) * sign. value := baseValue * (base raisedTo: exp). ^ value ! ! !Number class methodsFor: 'deprecated' stamp: 'CamilloBruni 8/1/2012 16:14'! readRemainderOf: integerPart from: aStream base: base withSign: sign "Read optional fractional part and exponent or decimal scale, and return the final result" "Number readFrom: '3r-22.2'" | value fractionDigits fracpos fractionPart fraction pos v foundDecimal | value := integerPart. fractionDigits := 0. foundDecimal := false. (aStream peekFor: $.) ifTrue: ["." foundDecimal := true. (aStream atEnd not and: [aStream peek digitValue between: 0 and: base - 1]) ifTrue: [fracpos := aStream position. fractionPart := Integer readFrom: aStream base: base. fraction := fractionPart asFloat / (base raisedTo: aStream position - fracpos). fractionDigits := aStream position - fracpos. value := value asFloat + fraction]]. pos := aStream position. (v := self readScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream) ifNil: [aStream position: pos] ifNotNil: [^ v "s>"]. pos := aStream position. (v := self readExponent: value base: base from: aStream) ifNil: [aStream position: pos. (foundDecimal and: [fractionDigits = 0]) ifTrue: ["oops - just ." aStream skip: -1. "un-gobble the period" ^ value * sign]] ifNotNil: [value := v "(e|d|q)>"]. (value isFloat and: [value = 0.0 and: [sign = -1]]) ifTrue: [^ Float negativeZero] ifFalse: [^ value * sign]! ! !Number class methodsFor: '*Tools-Debugger' stamp: 'SeanDeNigris 5/28/2013 17:48'! canonicalArgumentName ^ 'aNumber'.! ! !Number class methodsFor: 'constants' stamp: 'GabrielOmarCotelli 5/23/2009 20:46'! one ^1! ! !Number class methodsFor: 'instance creation' stamp: 'YuriyTymchuk 10/29/2013 11:10'! readFrom: stringOrStream base: base "Answer a number as described on aStream in the given number base. If stringOrStream does not start with a valid number description, answer 0 for backward compatibility. This is not clever and should better be changed." ^(NumberParser on: stringOrStream) nextNumberBase: base! ! !Number class methodsFor: '*System-Settings-Browser' stamp: 'alain.plantec 3/18/2009 15:09'! settingInputWidgetForNode: aSettingNode ^ aSettingNode inputWidgetForNumber! ! !Number class methodsFor: 'deprecated' stamp: 'ClementBera 7/26/2013 16:28'! readScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream "Complete creation of a ScaledDecimal, reading scale from aStream. Answer a ScaledDecimal, or nil if parsing fails. s[]" | scale decimalMultiplier decimalFraction | aStream atEnd ifTrue: [^ nil]. (aStream next == $s) ifFalse: [^ nil]. "s" (aStream atEnd not and: [aStream peek digitValue between: 0 and: 9]) ifTrue: [scale := Integer readFrom: aStream] ifFalse: [^ nil]. scale ifNil: ["s" fractionDigits = 0 ifTrue: ["s" scale := 0] ifFalse: [".s" scale := fractionDigits]]. fractionPart ifNil: [^integerPart * sign asScaledDecimal: scale] ifNotNil: [decimalMultiplier := base raisedTo: fractionDigits. decimalFraction := integerPart * decimalMultiplier + fractionPart * sign / decimalMultiplier. ^decimalFraction asScaledDecimal: scale]! ! !NumberParser commentStamp: 'nice 2/13/2010 00:31'! NumberParser is an abstract class for parsing and building numbers from string/stream. It offers a framework with utility methods and exception handling. Number syntax is not defined and should be subclassResponsibility. Instance variables: sourceStream the stream of characters from which the number is read base the radix in which to interpret digits neg true in case of minus sign integerPart the integer part of the number fractionPart the fraction part of the number if any exponent the exponent used in scientific notation if any scale the scale used in case of ScaledDecimal number if any nDigits number of digits read to form an Integer lasNonZero position of last non zero digit, starting at 1 from left, 0 if all digits are zero requestor could eventually be used to insert an error message in a text editor failBlock Block to execute whenever an error occurs! !NumberParser methodsFor: 'accessing' stamp: 'YuriyTymchuk 10/29/2013 11:08'! exponentLetters "answer the list of possible exponents for Numbers. Note: this parser will not honour precision attached to the exponent. different exponent do not lead to different precisions. only IEEE 754 floating point numbers will be created" ^'edq'! ! !NumberParser methodsFor: 'parsing-private' stamp: 'nice 10/7/2009 01:40'! makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart "at this point integerPart fractionPart and scale have been read out (in inst var). Form a ScaledDecimal. Care of eliminating trailing zeroes from the fractionPart" | decimalMultiplier decimalFraction | decimalMultiplier := base raisedToInteger: numberOfNonZeroFractionDigits. decimalFraction := integerPart * decimalMultiplier + (fractionPart // (base raisedTo: numberOfTrailingZeroInFractionPart)) / decimalMultiplier. neg ifTrue: [decimalFraction := decimalFraction negated]. ^decimalFraction asScaledDecimal: scale! ! !NumberParser methodsFor: 'error' stamp: 'nice 2/25/2010 02:39'! expected: aString | errorString | errorString := aString , ' expected'. requestor isNil ifFalse: [requestor notify: errorString at: sourceStream position + 1 in: sourceStream]. failBlock ifNotNil: [^failBlock cull: errorString cull: sourceStream position + 1]. self error: 'Reading a number failed: ' , errorString! ! !NumberParser methodsFor: 'parsing-large int' stamp: 'nice 3/15/2010 00:14'! nextElementaryLargeIntegerBase: aRadix "Form an unsigned integer with incoming digits from sourceStream. Return this integer, or zero if no digits found. Stop reading if end of digits or if a LargeInteger is formed. Count the number of digits and the position of lastNonZero digit and store them in instVar." | value digit char | value := 0. nDigits := 0. lastNonZero := 0. [value isLarge or: [(char := sourceStream next) == nil or: [digit := char digitValue. (0 > digit or: [digit >= aRadix]) and: [sourceStream skip: -1. true]]]] whileFalse: [ nDigits := nDigits + 1. 0 = digit ifFalse: [lastNonZero := nDigits]. value := value * aRadix + digit]. ^value! ! !NumberParser methodsFor: 'parsing-private' stamp: 'nice 7/26/2009 00:22'! makeFloatFromMantissa: m exponent: k base: aRadix "Convert infinite precision arithmetic into Floating point. This alogrithm rely on correct IEEE rounding mode being implemented in Integer>>asFloat and Fraction>>asFloat" ^(k positive ifTrue: [m * (aRadix raisedToInteger: k)] ifFalse: [Fraction numerator: m denominator: (aRadix raisedToInteger: k negated)]) asFloat! ! !NumberParser methodsFor: 'parsing-public' stamp: 'YuriyTymchuk 10/29/2013 11:08'! nextNumberBase: b "Method for reading a number without radix prefix. This one can read Float Integer and ScaledDecimal" | numberOfTrailingZeroInIntegerPart | base := b. neg := sourceStream peekFor: $-. integerPart := self nextUnsignedIntegerOrNilBase: base. integerPart ifNil: [ "This is not a regular number beginning with a digit It is time to check for exceptional condition NaN and Infinity" ^self readNamedFloatOrFail]. numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. ^ (sourceStream peekFor: $.) ifTrue: [self readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart] ifFalse: [self makeIntegerOrScaledInteger]! ! !NumberParser methodsFor: 'parsing-public' stamp: 'nice 3/15/2014 15:46'! nextScaledDecimal "Main method for reading a (scaled) decimal number. Good Gracious, do not accept a decimal in another base than 10!! In other words, do not accept radix notation like 2r1.1, even not 10r5.3 Do not accept exponent notation neither, like 1.0e-3" | numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart | base := 10. neg := sourceStream peekFor: $-. integerPart := self nextUnsignedIntegerBase: base. (sourceStream peekFor: $.) ifTrue: [fractionPart := self nextUnsignedIntegerOrNilBase: base. fractionPart ifNil: ["Oops, the decimal point seems not part of this number" sourceStream skip: -1. ^ neg ifTrue: [integerPart negated asScaledDecimal: 0] ifFalse: [integerPart asScaledDecimal: 0]]. numberOfNonZeroFractionDigits := lastNonZero. numberOfTrailingZeroInFractionPart := nDigits - lastNonZero. (self readScaleWithDefaultNumberOfDigits: nDigits) ifFalse: ["No scale were provided. use number of digits after decimal point as scale" scale := nDigits]. ^self makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart]. self readScaleWithDefaultNumberOfDigits: 0. neg ifTrue: [integerPart := integerPart negated]. ^integerPart asScaledDecimal: scale! ! !NumberParser methodsFor: 'parsing-public' stamp: 'YuriyTymchuk 10/29/2013 11:08'! nextNumber "main method for reading a number. This one can read Float Integer and ScaledDecimal" | numberOfTrailingZeroInIntegerPart | base := 10. neg := self peekSignIsMinus. integerPart := self nextUnsignedIntegerOrNilBase: base. integerPart ifNil: [ "This is not a regular number beginning with a digit It is time to check for exceptional condition NaN and Infinity" ^self readNamedFloatOrFail]. numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. (sourceStream peekFor: $r) ifTrue: ["r" (base := integerPart) < 2 ifTrue: [ sourceStream skip: -1. ^ self expected: 'an integer greater than 1 as valid radix']. self peekSignIsMinus ifTrue: [neg := neg not]. integerPart := self nextUnsignedIntegerBase: base. numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero]. ^ (sourceStream peekFor: $.) ifTrue: [self readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart] ifFalse: [self makeIntegerOrScaledInteger]! ! !NumberParser methodsFor: 'parsing-private' stamp: 'nice 3/15/2014 15:43'! makeIntegerOrScaledInteger "at this point, there is no digit, nor fractionPart. maybe it can be a scaled decimal with fraction omitted..." neg ifTrue: [integerPart := integerPart negated]. self readExponent ifTrue: [^integerPart * (base raisedToInteger: exponent)]. (self readScaleWithDefaultNumberOfDigits: 0) ifTrue: [^integerPart asScaledDecimal: scale]. ^ integerPart! ! !NumberParser methodsFor: 'parsing-public' stamp: 'nice 10/30/2011 16:11'! nextFraction | numerator denominator | numerator := self nextInteger. (sourceStream peekFor: $/) ifFalse: [^numerator]. denominator := self nextInteger. ^numerator / denominator! ! !NumberParser methodsFor: 'parsing-public' stamp: 'nice 4/2/2010 20:25'! nextIntegerBase: aRadix "Form an integer with following digits. Fail if no digit found" | isNeg value | isNeg := self peekSignIsMinus. value := self nextUnsignedIntegerBase: aRadix. ^isNeg ifTrue: [value negated] ifFalse: [value]! ! !NumberParser methodsFor: 'accessing' stamp: 'nice 5/1/2006 01:58'! failBlock: aBlockOrNil failBlock := aBlockOrNil! ! !NumberParser methodsFor: 'initialize-release' stamp: 'damiencassou 5/30/2008 10:56'! on: aStringOrStream sourceStream := aStringOrStream isString ifTrue: [ aStringOrStream readStream ] ifFalse: [ aStringOrStream ]. base := 10. neg := false. integerPart := fractionPart := exponent := scale := 0. requestor := failBlock := nil! ! !NumberParser methodsFor: 'accessing' stamp: 'nice 5/1/2006 01:59'! requestor: anObjectOrNil requestor := anObjectOrNil! ! !NumberParser methodsFor: 'parsing-public' stamp: 'YuriyTymchuk 10/29/2013 11:09'! nextInteger "Main method for reading an Integer. This won't try to read a Float nor a ScaledDecimal." | numberOfTrailingZeroInIntegerPart | base := 10. neg := self peekSignIsMinus. integerPart := self nextUnsignedIntegerOrNilBase: base. integerPart ifNil: [self fail]. numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero. (sourceStream peekFor: $r) ifTrue: ["r" | oldNeg pos | pos := sourceStream position. (base := integerPart) < 2 ifTrue: ["A radix currently need to be greater than 1, ungobble the r and return the integer part" sourceStream skip: -1. ^neg ifTrue: [base negated] ifFalse: [base]]. oldNeg := neg. self peekSignIsMinus ifTrue: [neg := neg not]. integerPart := self nextUnsignedIntegerOrNilBase: base. integerPart ifNil: [self fail]. numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero]. neg ifTrue: [integerPart := integerPart negated]. self readExponent ifTrue: [^integerPart * (base raisedToInteger: exponent)]. ^ integerPart! ! !NumberParser methodsFor: 'parsing-public' stamp: 'nice 7/26/2009 00:21'! nextUnsignedIntegerOrNilBase: aRadix "Form an unsigned integer with incoming digits from sourceStream. Answer this integer, or nil if no digit found. Count the number of digits and the position of lastNonZero digit and store them in instVar" | nPackets high nDigitsHigh lastNonZeroHigh low | "read no more digits than one elementary LargeInteger" high := self nextElementaryLargeIntegerBase: aRadix. nDigits = 0 ifTrue: [^nil]. "Not enough digits to form a LargeInteger, stop iteration" high isLarge ifFalse: [^high]. "We now have to engage arithmetic with LargeInteger Decompose the integer in a high and low packets of growing size:" nPackets := 1. nDigitsHigh := nDigits. lastNonZeroHigh := lastNonZero. [ low := self nextLargeIntegerBase: aRadix nPackets: nPackets . high := high * (aRadix raisedToInteger: nDigits) + low. lastNonZero = 0 ifFalse: [lastNonZeroHigh := lastNonZero + nDigitsHigh]. nDigitsHigh := nDigitsHigh + nDigits. low isLarge] whileTrue: [nPackets := nPackets * 2]. nDigits := nDigitsHigh. lastNonZero := lastNonZeroHigh. ^high! ! !NumberParser methodsFor: 'parsing-private' stamp: 'nice 3/15/2014 15:43'! readScaleWithDefaultNumberOfDigits: anInteger "Read the scale if any and store it into scale instance Variable. Answer true if found, answer false if none. The scale is specified by letter s, optionnally followed by a positive integer in base 10. If no integer is specified, that means using as many digits as provided after the fraction separator, as provided by parameter anInteger. A letter s followed by another letter is not considered as a scale specification, because it could be part of a message." scale := 0. sourceStream atEnd ifTrue: [ ^ false ]. (sourceStream peekFor: $s) ifFalse: [ ^ false ]. scale := self nextUnsignedIntegerOrNilBase: 10. scale ifNil: [ scale := anInteger. (sourceStream peek ifNil: [ false ] ifNotNil: [ :nextChar | nextChar isLetter ]) ifTrue: [ sourceStream skip: -1. "ungobble the s" ^ false ] ifFalse: [ ^ true ] ]. ^ true! ! !NumberParser methodsFor: 'parsing-private' stamp: 'nice 2/13/2010 16:03'! readExponent "read the exponent if any (stored in instVar). Answer true if found, answer false if none. If exponent letter is not followed by a digit, this is not considered as an error. Exponent are always read in base 10." | eneg epos | exponent := 0. sourceStream atEnd ifTrue: [^ false]. (self exponentLetters includes: sourceStream peek) ifFalse: [^ false]. sourceStream next. eneg := sourceStream peekFor: $-. epos := eneg not and: [self allowPlusSignInExponent and: [sourceStream peekFor: $+]]. exponent := self nextUnsignedIntegerOrNilBase: 10. exponent ifNil: ["Oops, there was no digit after the exponent letter.Ungobble the letter" exponent := 0. sourceStream skip: ((eneg or: [epos]) ifTrue: [-2] ifFalse: [-1]). ^ false]. eneg ifTrue: [exponent := exponent negated]. ^ true! ! !NumberParser methodsFor: 'accessing' stamp: 'nice 2/12/2010 23:56'! allowPlusSignInExponent "return a boolean indicating if plus sign is allowed or not in exponent" ^self allowPlusSign! ! !NumberParser methodsFor: 'accessing' stamp: 'YuriyTymchuk 10/29/2013 11:08'! allowPlusSign "return a boolean indicating if plus sign is allowed or not" ^false! ! !NumberParser methodsFor: 'parsing-private' stamp: 'YuriyTymchuk 10/29/2013 11:08'! readNamedFloatOrFail "This method is used when there is no digit encountered: It try and read a named Float NaN or Infinity. Negative sign for -Infinity has been read before sending this method, and is indicated in the neg inst.var. Fail if no named Float is found" neg ifFalse: [(sourceStream nextMatchAll: 'NaN') ifTrue: [^ Float nan]]. (sourceStream nextMatchAll: 'Infinity') ifTrue: [^ neg ifTrue: [Float infinity negated] ifFalse: [Float infinity]]. ^self expected: 'a digit between 0 and ' , (String with: (Character digitValue: base - 1))! ! !NumberParser methodsFor: 'parsing-public' stamp: 'nice 10/16/2008 01:05'! nextUnsignedIntegerBase: aRadix "Form an unsigned integer with incoming digits from sourceStream. Fail if no digit found. Count the number of digits and the lastNonZero digit and store int in instVar " | value | value := self nextUnsignedIntegerOrNilBase: aRadix. value ifNil: [^self expected: ('a digit between 0 and ' copyWith: (Character digitValue: aRadix - 1))]. ^value! ! !NumberParser methodsFor: 'parsing-large int' stamp: 'nice 1/14/2014 03:27'! nextLargeIntegerBase: aRadix nPackets: nPackets "Form a Large integer with incoming digits from sourceStream. Return this integer, or zero if no digits found. Stop reading when no more digits or when nPackets elementary LargeInteger have been encountered. Count the number of digits and the lastNonZero digit and store them in instVar" | high nDigitsHigh lastNonZeroHigh low nDigitsLow halfPackets | halfPackets := nPackets bitShift: -1. halfPackets = 0 ifTrue: [^self nextElementaryLargeIntegerBase: aRadix]. high := self nextLargeIntegerBase: aRadix nPackets: halfPackets. high isLarge ifFalse: [^high]. nDigitsHigh := nDigits. lastNonZeroHigh := lastNonZero. low := self nextLargeIntegerBase: aRadix nPackets: halfPackets. nDigitsLow := nDigits. nDigits := nDigitsHigh + nDigitsLow. lastNonZero := lastNonZero = 0 ifTrue: [lastNonZeroHigh] ifFalse: [lastNonZero + nDigitsHigh]. ^high * (aRadix raisedToInteger: nDigitsLow) + low! ! !NumberParser methodsFor: 'parsing-public' stamp: 'nice 8/27/2010 20:51'! nextIntegerBase: aRadix ifFail: aBlock "Form an integer with optional sign and following digits from sourceStream." | isNeg value | isNeg := self peekSignIsMinus. value := self nextUnsignedIntegerOrNilBase: aRadix. value ifNil: [^aBlock value]. ^isNeg ifTrue: [value negated] ifFalse: [value]! ! !NumberParser methodsFor: 'parsing-public' stamp: 'nice 10/16/2008 01:05'! nextUnsignedIntegerBase: aRadix ifFail: errorBlock "Form an unsigned integer with incoming digits from sourceStream. Answer this integer, or execute errorBlock if no digit found. Count the number of digits and the position of lastNonZero digit and store them in instVar" | value | value := self nextUnsignedIntegerOrNilBase: aRadix. value ifNil: [^errorBlock value]. ^value! ! !NumberParser methodsFor: 'parsing-private' stamp: 'nice 3/15/2014 15:45'! readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart "at this stage, sign integerPart and a decimal point have been read. try and form a number with a fractionPart" | numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart mantissa value | fractionPart := self nextUnsignedIntegerOrNilBase: base. fractionPart ifNil: ["No fractionPart found,ungobble the decimal point and return the integerPart" sourceStream skip: -1. ^ neg ifTrue: [integerPart negated] ifFalse: [integerPart]]. numberOfNonZeroFractionDigits := lastNonZero. numberOfTrailingZeroInFractionPart := nDigits - lastNonZero. self readExponent ifFalse: [(self readScaleWithDefaultNumberOfDigits: nDigits) ifTrue: [^self makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart]]. fractionPart isZero ifTrue: [mantissa := integerPart // (base raisedToInteger: numberOfTrailingZeroInIntegerPart). exponent := exponent + numberOfTrailingZeroInIntegerPart] ifFalse: [mantissa := integerPart * (base raisedToInteger: numberOfNonZeroFractionDigits) + (fractionPart // (base raisedToInteger: numberOfTrailingZeroInFractionPart)). exponent := exponent - numberOfNonZeroFractionDigits]. value := self makeFloatFromMantissa: mantissa exponent: exponent base: base. ^ neg ifTrue: [value isZero ifTrue: [Float negativeZero] ifFalse: [value negated]] ifFalse: [value]! ! !NumberParser methodsFor: 'error' stamp: 'NikoSchwarz 10/17/2009 10:45'! fail failBlock ifNotNil: [^failBlock value]. self error: 'Reading a number failed'! ! !NumberParser methodsFor: 'parsing-private' stamp: 'nice 2/12/2010 23:57'! peekSignIsMinus "Peek an optional sign from sourceStream. Answer true if it is minus sign" | isMinus | isMinus := sourceStream peekFor: $-. isMinus ifFalse: [self allowPlusSign ifTrue: [sourceStream peekFor: $+]]. ^isMinus! ! !NumberParser class methodsFor: 'instance creation' stamp: 'nice 5/1/2006 02:02'! parse: aStringOrStream onError: failBlock ^(self new) on: aStringOrStream; failBlock: failBlock; nextNumber! ! !NumberParser class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/28/2013 10:44'! parse: aStringOrStream ^self new on: aStringOrStream; nextNumber! ! !NumberParser class methodsFor: 'instance creation' stamp: 'nice 5/1/2006 00:45'! on: aStringOrStream ^self new on: aStringOrStream! ! !NumberParser class methodsFor: 'instance creation' stamp: 'NikoSchwarz 10/23/2009 13:21'! squeezeNumberOutOfString: stringOrStream "Try and find a number in this string. First, look if the string starts with a number. Then, see if it ends with a number. Then, remove a character from the front and see if the remaining string makes a number. Repeat the process until no characters are left or the number has been found. As soon as a number is found, it is returned. Otherwise, the method fails." ^ self squeezeNumberOutOfString: stringOrStream onError: [self error: 'Reading a number failed']! ! !NumberParser class methodsFor: 'instance creation' stamp: 'MarcusDenker 12/2/2013 14:07'! squeezeNumberOutOfString: stringOrStream onError: errorBlock "Try and find a number in this string. First, look if the string starts with a number. Then, see if it ends with a number. Then, remove a character from the front and see if the remaining string makes a number. Repeat the process until no characters are left or the number has been found. As soon as a number is found, it is returned. Otherwise, the method fails." | string | string := stringOrStream. stringOrStream size timesRepeat: [ (self parse: string onError: [ nil ]) ifNotNil: [ :result| ^ result ]. string := string allButFirst ]. ^ errorBlock value! ! !NumberParserTest commentStamp: 'nice 5/7/2006 17:54'! Provide tests for new clas aimed at parsing numbers. It duplicates NumberParsingTest, with few more tests.! !NumberParserTest methodsFor: 'tests - Float' stamp: 'nice 1/15/2014 00:00'! testFloatmin "Note that these are originally tests cases for former bugs of libc dtoa from netlib. ref http://www.exploringbinary.com/gays-strtod-returns-zero-for-inputs-just-above-2-1075/ ref http://gcc.gnu.org/viewcvs/gcc/trunk/gcc/testsuite/gcc.dg/float-exact-1.c?view=markup&pathrev=205119 They are also non regression for a bug of NumberParser related to incorrect position of last non zero digit. ref https://pharo.fogbugz.com/f/cases/12642/bug-in-NumberParser-when-reading-a-number-with-fraction-part" | halfMin moreThanHalfmin | halfMin := NumberParser parse: (Float fmin asTrueFraction / 2 printShowingDecimalPlaces: 1 - Float fmin exponent). self assert: halfMin = 0.0 description: 'nearest even of 0.5*Float fmin is zero'. moreThanHalfmin := NumberParser parse: (Float fmin asTrueFraction / 2 + (10 raisedTo: Float fmin exponent - 4) printShowingDecimalPlaces: 4 - Float fmin exponent). self assert: moreThanHalfmin = Float fmin description: 'nearest Float of a Fraction > 0.5*Float fmin is Float fmin'.! ! !NumberParserTest methodsFor: 'tests - Float' stamp: 'YuriyTymchuk 10/29/2013 11:10'! testFloatGradualUnderflow "Gradual underflow are tricky. This is a non regression test for http://bugs.squeak.org/view.php?id=6976" | float trueFraction str | "as a preamble, use a base 16 representation to avoid round off error and check that number parsing is correct" trueFraction := 16r2D2593D58B4FC4 / (16 raisedTo: 256+13). "Parse the number in base 16 if possible - it is impossible if lowercase letter are allowed digits due to exponent letter ambiguity." float := self areLowercaseDigitsAllowed ifFalse: [NumberParser parse: '16r2.D2593D58B4FC4e-256'] ifTrue: [trueFraction asFloat].. self assert: float asTrueFraction = trueFraction. self assert: float = trueFraction asFloat. "now print in base 10" str := (String new: 32) writeStream. float absPrintExactlyOn: str base: 10. "verify if SqNumberParser can read it back" self assert: (NumberParser parse: str contents) = float. ! ! !NumberParserTest methodsFor: 'tests - squeezing' stamp: 'BenjaminVanRyseghem 7/1/2012 02:03'! testSqueezingOutNumbers "test that SqNumberParser squeezeNumberOutOfString finds numbers." self assert: '123blabla' squeezeOutNumber equals: 123. self assert: 'blabla123' squeezeOutNumber equals: 123. self assert: 'blabla12blabla' squeezeOutNumber equals: 12. self assert: ('12.3bla' squeezeOutNumber -12.3 ) abs < 0.0001. self assert: '.1' squeezeOutNumber > 0. self assert: 'blabla1230' squeezeOutNumber equals: 1230.! ! !NumberParserTest methodsFor: 'tests - Float' stamp: 'YuriyTymchuk 10/29/2013 11:10'! testFloatReadWithRadix "This covers parsing in Number>>readFrom: Note: In most Smalltalk dialects, the radix notation is not used for numbers with exponents. In Squeak, a string with radix and exponent can be parsed, and the exponent is always treated as base 10 (not the base indicated in the radix prefix). I am not sure if this is a feature, a bug, or both, but the Squeak behavior is documented in this test. -dtl" | rs | self assert: (NumberParser parse: '2r1.0101e9') = (1.3125 * (2 raisedTo: 9)). rs := '2r1.0101e9e9' readStream. self assert: (NumberParser parse: rs) = 672.0. self assert: rs upToEnd = 'e9'! ! !NumberParserTest methodsFor: 'tests - fail' stamp: 'YuriyTymchuk 10/29/2013 11:10'! testFail "Verify that the value of a failblock is returned." self assert: (NumberParser parse: 'blablabla' onError: [42]) equals: 42! ! !NumberParserTest methodsFor: 'tests - Float' stamp: 'YuriyTymchuk 10/29/2013 11:10'! testFloatPrintString "self debug: #testFloatPrintString" | f r bases | f := Float basicNew: 2. r := Random new seed: 1234567. "printing a Float in base other than 10 is broken if lowercase digits are allowed" bases := self areLowercaseDigitsAllowed ifTrue: [#(10)] ifFalse: [#(2 8 10 16)]. 100 timesRepeat: [f basicAt: 1 put: (r nextInt: 16r100000000)- 1. f basicAt: 2 put: (r nextInt: 16r100000000) - 1. bases do: [:base | | str | str := (String new: 64) writeStream. f negative ifTrue: [str nextPut: $-]. str print: base; nextPut: $r. f absPrintExactlyOn: str base: base. self assert: (NumberParser parse: str contents) = f]]. "test big num near infinity" 10 timesRepeat: [f basicAt: 1 put: 16r7FE00000 + ((r nextInt: 16r100000) - 1). f basicAt: 2 put: (r nextInt: 16r100000000) - 1. bases do: [:base | | str | str := (String new: 64) writeStream. f negative ifTrue: [str nextPut: $-]. str print: base; nextPut: $r. f absPrintExactlyOn: str base: base. self assert: (NumberParser parse: str contents) = f]]. "test infinitesimal (gradual underflow)" 10 timesRepeat: [f basicAt: 1 put: 0 + ((r nextInt: 16r100000) - 1). f basicAt: 2 put: (r nextInt: 16r100000000) - 1. bases do: [:base | | str | str := (String new: 64) writeStream. f negative ifTrue: [str nextPut: $-]. str print: base; nextPut: $r. f absPrintExactlyOn: str base: base. self assert: (NumberParser parse: str contents) = f]].! ! !NumberParserTest methodsFor: 'utility' stamp: 'YuriyTymchuk 10/29/2013 11:10'! areLowercaseDigitsAllowed "Answer true if lowercase letter are allowed digits." ^(NumberParser parse: '16re' onError: [-1]) = 16rE! ! !NumberParserTest methodsFor: 'tests - Float' stamp: 'YuriyTymchuk 10/29/2013 11:10'! testFloatReadError "This covers parsing in Number>>readFrom:" | rs num | rs := '1e' readStream. num := NumberParser parse: rs. self assert: 1 = num. self assert: rs upToEnd = 'e'. rs := '1s' readStream. num := NumberParser parse: rs. self assert: 1 = num. self assert: rs upToEnd = ''. rs := '1.' readStream. num := NumberParser parse: rs. self assert: 1 = num. self assert: num isInteger. self assert: rs upToEnd = '.'. rs := '' readStream. self should: [NumberParser parse: rs] raise: Error. rs := 'foo' readStream. self should: [NumberParser parse: rs] raise: Error. rs := 'radix' readStream. self should: [NumberParser parse: rs] raise: Error. rs := '.e0' readStream. self should: [NumberParser parse: rs] raise: Error. rs := '-.e0' readStream. self should: [NumberParser parse: rs] raise: Error. rs := '--1' readStream. self should: [NumberParser parse: rs] raise: Error.! ! !NumberParserTest methodsFor: 'tests - Integer' stamp: 'YuriyTymchuk 10/29/2013 11:10'! testIntegerReadFrom "Ensure remaining characters in a stream are not lost when parsing an integer." | rs i s | rs := '123s could be confused with a ScaledDecimal' readStream. i := NumberParser parse: rs. self assert: i = 123. s := rs upToEnd. self assert: ' could be confused with a ScaledDecimal' = s. rs := '123.s could be confused with a ScaledDecimal' readStream. i := NumberParser parse: rs. self assert: i = 123. s := rs upToEnd. self assert: '.s could be confused with a ScaledDecimal' = s! ! !NumberParserTest methodsFor: 'tests - Integer' stamp: 'YuriyTymchuk 10/29/2013 11:10'! testcheckForCoverage "self debug: #testcheckForCoverage" "Tests for old semantics of Number>>readFrom:" self should: [(NumberParser parse: '.') = 0 ] raise: Error. self should: [(NumberParser parse: '.1') asNumber = 0.1] raise: Error. self assert: (NumberParser parse: '0.0') asNumber = 0. self assert: (NumberParser parse: '0.1') asNumber = 0.1. self assert: (NumberParser parse: '1.1') asNumber = 1.1. self assert: (NumberParser parse: '-1') asNumber = -1.! ! !NumberParserTest methodsFor: 'tests - Float' stamp: 'YuriyTymchuk 10/29/2013 11:10'! testFloatFromStreamAsNumber "This covers parsing in Number>>readFrom:" | rs aFloat | rs := '10r-12.3456' readStream. aFloat := NumberParser parse: rs. self assert: -12.3456 = aFloat. self assert: rs atEnd. rs := '10r-12.3456e2' readStream. aFloat := NumberParser parse: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs := '10r-12.3456e2e2' readStream. aFloat := NumberParser parse: rs. self assert: -1234.56 = aFloat. self assert: rs upToEnd = 'e2'. rs := '10r-12.3456d2' readStream. aFloat := NumberParser parse: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs := '10r-12.3456q2' readStream. aFloat := NumberParser parse: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs := '-12.3456q2' readStream. aFloat := NumberParser parse: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs := '12.3456q2' readStream. aFloat := NumberParser parse: rs. self assert: 1234.56 = aFloat. self assert: rs atEnd. rs := '12.3456z2' readStream. aFloat := NumberParser parse: rs. self assert: 12.3456 = aFloat. self assert: rs upToEnd = 'z2'. ! ! !NumberParserTest methodsFor: 'tests - ScaledDecimal' stamp: 'nice 3/15/2014 15:50'! testScaledDecimalWithoutScaleSpecification self assert: (NumberParser parse: '0.050s') = (1/20). self assert: (NumberParser parse: '0.050s') scale= 3.! ! !NumberParserTest methodsFor: 'tests - Float' stamp: 'YuriyTymchuk 10/29/2013 11:10'! testFloatFromStreamWithExponent "This covers parsing in Number>>readFrom:" | rs aFloat | rs := '1.0e-14' readStream. aFloat := NumberParser parse: rs. self assert: 1.0e-14 = aFloat. self assert: rs atEnd. rs := '1.0e-14 1' readStream. aFloat := NumberParser parse: rs. self assert: 1.0e-14 = aFloat. self assert: rs upToEnd = ' 1'. rs := '1.0e-14eee' readStream. aFloat := NumberParser parse: rs. self assert: 1.0e-14 = aFloat. self assert: rs upToEnd = 'eee'. rs := '1.0e14e10' readStream. aFloat := NumberParser parse: rs. self assert: 1.0e14 = aFloat. self assert: rs upToEnd = 'e10'. rs := '1.0e+14e' readStream. "Plus sign is not parseable" aFloat := NumberParser parse: rs. self assert: 1.0 = aFloat. self assert: rs upToEnd = 'e+14e'. rs := '1.0e' readStream. aFloat := NumberParser parse: rs. self assert: 1.0 = aFloat. self assert: rs upToEnd = 'e'.! ! !NumberParserTest methodsFor: 'tests - Integer' stamp: 'YuriyTymchuk 10/29/2013 11:10'! testIntegerReadWithRadix "This covers parsing in Number>>readFrom: Note: In most Smalltalk dialects, the radix notation is not used for numbers with exponents. In Squeak, a string with radix and exponent can be parsed, and the exponent is always treated as base 10 (not the base indicated in the radix prefix). I am not sure if this is a feature, a bug, or both, but the Squeak behavior is documented in this test. -dtl" | rs | self assert: (NumberParser parse: '2r1e26') = (2 raisedTo: 26). rs := '2r1e26eee' readStream. self assert: (NumberParser parse: rs) = 67108864. self assert: rs upToEnd = 'eee' ! ! !NumberParserTest methodsFor: 'tests - ScaledDecimal' stamp: 'YuriyTymchuk 10/29/2013 11:10'! testScaledDecimalWithTrailingZeroes "This is a non regression tests for http://bugs.squeak.org/view.php?id=7169" self assert: (NumberParser parse: '0.50s2') = (1/2). self assert: (NumberParser parse: '0.500s3') = (1/2). self assert: (NumberParser parse: '0.050s3') = (1/20).! ! !NumberParsingTest commentStamp: 'dtl 11/24/2004 15:35'! Tests to verify parsing of numbers from streams and strings. Note: ScaledDecimalTest contains related tests for parsing ScaledDecimal.! !NumberParsingTest methodsFor: 'tests - Integer' stamp: 'StephaneDucasse 5/28/2011 13:41'! testIntegerFromString "This covers parsing in Number>>readFrom: Trailing decimal points should be ignored." self assert: ('123' asNumber = 123). self assert: ('-123' asNumber = -123). self assert: ('123.' asNumber = 123). self assert: ('-123.' asNumber = -123). self assert: ('123This is not to be read' asNumber = 123). self assert: ('123s could be confused with a ScaledDecimal' asNumber = 123). self assert: ('123e could be confused with a Float' asNumber = 123). ! ! !NumberParsingTest methodsFor: 'tests - Float' stamp: 'damiencassou 5/30/2008 11:09'! testFloatReadWithRadix "This covers parsing in Number>>readFrom: Note: In most Smalltalk dialects, the radix notation is not used for numbers with exponents. In Squeak, a string with radix and exponent can be parsed, and the exponent is always treated as base 10 (not the base indicated in the radix prefix). I am not sure if this is a feature, a bug, or both, but the Squeak behavior is documented in this test. -dtl" | aNumber rs | aNumber := '2r1.0101e9' asNumber. self assert: 672.0 = aNumber. self assert: (Number readFrom: '2r1.0101e9') = (1.3125 * (2 raisedTo: 9)). rs := '2r1.0101e9e9' readStream. self assert: (Number readFrom: rs) = 672.0. self assert: rs upToEnd = 'e9'! ! !NumberParsingTest methodsFor: 'tests - Float' stamp: 'YuriyTymchuk 10/29/2013 11:14'! testNumberReadOnlyDigit "This covers parsing in Number>>readFrom:" | rs num | rs := '1e' readStream. num := Number readFrom: rs. self assert: 1 = num. self assert: rs upToEnd = 'e'. rs := '1s' readStream. num := Number readFrom: rs. self assert: 1 = num. self assert: rs upToEnd = ''. rs := '1.' readStream. num := Number readFrom: rs. self assert: 1 = num. self assert: num isInteger. self assert: rs upToEnd = '.'.! ! !NumberParsingTest methodsFor: 'tests - Float' stamp: 'AdrianLienhard 6/5/2010 16:32'! testNumberReadExactlyError "This covers parsing in Number>>readExactlyFrom:" | rs | rs := '' readStream. self should: [Number readFrom: rs] raise: Error. rs := 'foo' readStream. self should: [Number readFrom: rs] raise: Error. rs := 'radix' readStream. self should: [Number readFrom: rs] raise: Error. rs := '.e0' readStream. self should: [Number readFrom: rs] raise: Error. rs := '-.e0' readStream. self should: [Number readFrom: rs] raise: Error. rs := '--1' readStream. self should: [Number readFrom: rs] raise: Error.! ! !NumberParsingTest methodsFor: 'tests - Float' stamp: 'dtl 11/24/2004 14:07'! testFloatFromStringAsNumber "This covers parsing in Number>>readFrom:" | aFloat | aFloat := '10r-12.3456' asNumber. self assert: -12.3456 = aFloat. aFloat := '10r-12.3456e2' asNumber. self assert: -1234.56 = aFloat. aFloat := '10r-12.3456d2' asNumber. self assert: -1234.56 = aFloat. aFloat := '10r-12.3456q2' asNumber. self assert: -1234.56 = aFloat. aFloat := '-12.3456q2' asNumber. self assert: -1234.56 = aFloat. aFloat := '12.3456q2' asNumber. self assert: 1234.56 = aFloat. ! ! !NumberParsingTest methodsFor: 'tests - ScaledDecimal' stamp: 'nice 3/15/2014 15:51'! testScaledDecimalWithoutScaleSpecification self assert: (Number readFrom: '0.050s') = (1/20). self assert: (Number readFrom: '0.050s') scale= 3. self assert: (ScaledDecimal readFrom: '0.050') = (1/20). self assert: (ScaledDecimal readFrom: '0.050') scale= 3.! ! !NumberParsingTest methodsFor: 'tests - Integer' stamp: 'YuriyTymchuk 11/3/2013 11:55'! testIntegerReadFrom "Ensure remaining characters in a stream are not lost when parsing an integer." | rs i s | rs := '123s could be confused with a ScaledDecimal' readStream. i := Integer readFrom: rs. self assert: i = 123. s := rs upToEnd. self assert: 's could be confused with a ScaledDecimal' = s. rs := '123.s could be confused with a ScaledDecimal' readStream. i := Integer readFrom: rs. self assert: i = 123. s := rs upToEnd. self assert: '.s could be confused with a ScaledDecimal' = s. rs := '123sA has unary message sA' readStream. i := Number readFrom: rs. self assert: i = 123. s := rs upToEnd. self assert: 'sA has unary message sA' = s. rs := '123sB has unary message sB' readStream. i := Number readFrom: rs. self assert: i = 123. s := rs upToEnd. self assert: 'sB has unary message sB' = s! ! !NumberParsingTest methodsFor: 'tests - Float' stamp: 'YuriyTymchuk 10/29/2013 11:20'! testFloatFromStringWithExponent "This covers parsing in Number>>readFrom:" | aFloat | aFloat := '1.0e-14' asNumber. self assert: 1.0e-14 = aFloat. aFloat := '1.0e-14 1' asNumber. self assert: 1.0e-14 = aFloat. aFloat := '1.0e-14e' asNumber. self assert: 1.0e-14 = aFloat. aFloat := '1.0e14e' asNumber. self assert: 1.0e14 = aFloat.! ! !NumberParsingTest methodsFor: 'tests - Float' stamp: 'dtl 11/24/2004 14:29'! testFloatFromStreamAsNumber "This covers parsing in Number>>readFrom:" | rs aFloat | rs := '10r-12.3456' readStream. aFloat := Number readFrom: rs. self assert: -12.3456 = aFloat. self assert: rs atEnd. rs := '10r-12.3456e2' readStream. aFloat := Number readFrom: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs := '10r-12.3456e2e2' readStream. aFloat := Number readFrom: rs. self assert: -1234.56 = aFloat. self assert: rs upToEnd = 'e2'. rs := '10r-12.3456d2' readStream. aFloat := Number readFrom: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs := '10r-12.3456q2' readStream. aFloat := Number readFrom: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs := '-12.3456q2' readStream. aFloat := Number readFrom: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs := '12.3456q2' readStream. aFloat := Number readFrom: rs. self assert: 1234.56 = aFloat. self assert: rs atEnd. rs := '12.3456z2' readStream. aFloat := Number readFrom: rs. self assert: 12.3456 = aFloat. self assert: rs upToEnd = 'z2'. ! ! !NumberParsingTest methodsFor: 'tests - Integer' stamp: 'Janniklaval 10/23/2010 13:40'! testNegativeZero "This test ensure that -0.0 will produce a negativeZero" | negativeZero | negativeZero := Number readFrom: '-0.0' readStream. "If it is a negative zero, it must behave like a negative zero... IEEE 754 tells how it should behave" self deny: (negativeZero at: 1) = 0 description: 'In IEEE 754, a negative zero has its sign bit set to 1'.. self assert: negativeZero = 0 description: 'In IEEE 754, a negative zero cannot be distinguished from zero'.! ! !NumberParsingTest methodsFor: 'tests - ScaledDecimal' stamp: 'nice 8/29/2008 22:04'! testScaledDecimalWithTrailingZeroes "This is a non regression tests for http://bugs.squeak.org/view.php?id=7169" self assert: (Number readFrom: '0.50s2') = (1/2). self assert: (Number readFrom: '0.500s3') = (1/2). self assert: (Number readFrom: '0.050s3') = (1/20).! ! !NumberParsingTest methodsFor: 'tests - Integer' stamp: 'VeronicaUquillas 6/11/2010 14:42'! testIntegerReadWithRadix "This covers parsing in Number>>readFrom: Note: In most Smalltalk dialects, the radix notation is not used for numbers with exponents. In Squeak, a string with radix and exponent can be parsed, and the exponent is always treated as base 10 (not the base indicated in the radix prefix). I am not sure if this is a feature, a bug, or both, but the Squeak behavior is documented in this test. -dtl" | aNumber rs | aNumber := '2r1e26' asNumber. self assert: 67108864 = aNumber. self assert: (Number readFrom: '2r1e26') = (2 raisedTo: 26). rs := '2r1e26eee' readStream. self assert: (Number readFrom: rs) = 67108864. self assert: rs upToEnd = 'eee' ! ! !NumberParsingTest methodsFor: 'tests - Float' stamp: 'YuriyTymchuk 10/29/2013 11:15'! testFloatFromStreamWithExponent "This covers parsing in Number>>readFrom:" | rs aFloat | rs := '1.0e-14' readStream. aFloat := Number readFrom: rs. self assert: 1.0e-14 = aFloat. self assert: rs atEnd. rs := '1.0e-14 1' readStream. aFloat := Number readFrom: rs. self assert: 1.0e-14 = aFloat. self assert: rs upToEnd = ' 1'. rs := '1.0e-14eee' readStream. aFloat := Number readFrom: rs. self assert: 1.0e-14 = aFloat. self assert: rs upToEnd = 'eee'. rs := '1.0e14e10' readStream. aFloat := Number readFrom: rs. self assert: 1.0e14 = aFloat. self assert: rs upToEnd = 'e10'. rs := '1.0e+14e' readStream. aFloat := Number readFrom: rs. self assert: 1.0 = aFloat. self assert: rs upToEnd = 'e+14e'. rs := '1.0e' readStream. aFloat := Number readFrom: rs. self assert: 1.0 = aFloat. self assert: rs upToEnd = 'e'.! ! !NumberTest commentStamp: 'TorstenBergmann 2/5/2014 08:41'! SUnit tests for numbers! !NumberTest methodsFor: 'tests' stamp: 'JohanBrichau 8/26/2010 14:18'! testReadFrom self assert: 1.0e-14 = (Number readFrom: '1.0e-14'). self assert: 2r1e26 = (Number readFrom: '2r1e26'). self should: [Number readFrom: 'foo'] raise: Error! ! !NumberTest methodsFor: 'tests' stamp: 'nice 12/6/2007 21:24'! testRaisedTo "this is a test related to http://bugs.squeak.org/view.php?id=6781" self should: [0 raisedTo: -1] raise: ZeroDivide. self should: [0 raisedTo: -1.0] raise: ZeroDivide.! ! !NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/23/2009 20:49'! testOne self assert: Integer one = 1; assert: Float one = 1.0; assert: Fraction one = 1! ! !NumberTest methodsFor: 'tests' stamp: 'adrian_lienhard 1/7/2009 17:55'! testPrintShowingDecimalPlaces self assert: (111.2 printShowingDecimalPlaces: 2) = '111.20'. self assert: (111.2 printShowingDecimalPlaces: 0) = '111'. self assert: (111 printShowingDecimalPlaces: 0) = '111'. self assert: (111111111111111 printShowingDecimalPlaces: 2) = '111111111111111.00'. self assert: (10 printShowingDecimalPlaces: 20) ='10.00000000000000000000'. self assert: (0.98 printShowingDecimalPlaces: 2) = '0.98'. self assert: (-0.98 printShowingDecimalPlaces: 2) = '-0.98'. self assert: (2.567 printShowingDecimalPlaces: 2) = '2.57'. self assert: (-2.567 printShowingDecimalPlaces: 2) = '-2.57'. self assert: (0.01 printShowingDecimalPlaces: 2) = '0.01'. self assert: (-0.001 printShowingDecimalPlaces: 2) = '0.00'.! ! !NumberTest methodsFor: 'tests' stamp: 'nice 4/24/2008 00:58'! testPrintShowingDecimalPlaces3 "This problem were reported at http://bugs.squeak.org/view.php?id=7028 unfortunate inversion of left / right padding" self assert: (1.009 printShowingDecimalPlaces: 3) = '1.009'. self assert: (35.900 printShowingDecimalPlaces: 3) = '35.900'. self assert: (-0.097 printShowingDecimalPlaces: 3) = '-0.097'.! ! !NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/26/2009 21:57'! testFractionPart self assert: 2 fractionPart = 0; assert: (1/2) fractionPart = (1/2); assert: (4/3) fractionPart = (1/3); assert: 2.0 fractionPart = 0.0; assert: 0.5 fractionPart = 0.5; assert: 2.5 fractionPart = 0.5 ! ! !NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/23/2009 19:26'! testReciprocal self assert: 1 reciprocal = 1; assert: 2 reciprocal = (1/2); assert: -1 reciprocal = -1; assert: -3 reciprocal = (-1/3). self should: [ 0 reciprocal ] raise: ZeroDivide! ! !NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2009 16:46'! testRaisedToIntegerWithFloats self assert: (2.0 raisedToInteger: 0) = 1.0; assert: (2.0 raisedToInteger: 1) = 2.0; assert: (2.0 raisedToInteger: 4) = 16.0; assert: (0.0 raisedToInteger: 0) = 1.0; assert: (0.0 raisedToInteger: 2) = 0.0; assert: (2.0 raisedToInteger: -1) = 0.5; assert: (2.0 raisedToInteger: -4) = 0.0625. self assert: (-3.0 raisedTo: 0) = 1.0; assert: (-3.0 raisedTo: 1) = -3.0; assert: (-3.0 raisedTo: 2) = 9.0; assert: (-3.0 raisedTo: 3) = -27.0; assert: (-2.0 raisedTo: -2) = 0.25; assert: (-2.0 raisedTo: -3) = -0.125. self should: [ 0.0 raisedTo: -1 ] raise: ZeroDivide! ! !NumberTest methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testPrintShowingDecimalPlaces2 "This tests problems related to Float>>rounded and Float>>roundTo:: - Float>>#rounded is inexact - Float>>#roundTo: might overflow" "5000000000000001.0 asTrueFraction = 5000000000000001. 5000000000000001 highBit = 53. This number is represented exactly asFloat, it should print exactly" self assert: (5000000000000001.0 printShowingDecimalPlaces: 0) = '5000000000000001'. "50000000000001.25 asTrueFraction = (200000000000005/4). 200000000000005 highBit = 48, 4 isPowerOfTwo, So this number is also represented exactly as Float, it should print exactly. Beware: (50000000000001.25 / 0.01) rounded exhibit the same problem as above." self assert: (50000000000001.25 printShowingDecimalPlaces: 2) = '50000000000001.25'. "This number is close to maximum float value" 1.0e306 printShowingDecimalPlaces: 3! ! !NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/26/2009 21:55'! testIntegerPart self assert: 2 integerPart = 2; assert: (1/2) integerPart = 0; assert: (4/3) integerPart = 1; assert: 2.0 integerPart = 2.0; assert: 0.5 integerPart = 0.0; assert: 2.5 integerPart = 2.0 ! ! !NumberTest methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2009 16:41'! testRaisedToInteger self assert: (2 raisedToInteger: 0) = 1; assert: (2 raisedToInteger: 1) = 2; assert: (2 raisedToInteger: 4) = 16; assert: (0 raisedToInteger: 0) = 1; assert: (0 raisedToInteger: 2) = 0; assert: (2 raisedToInteger: -1) = (1/2); assert: (2 raisedToInteger: -4) = (1/16). self assert: (-3 raisedTo: 0) = 1; assert: (-3 raisedTo: 1) = -3; assert: (-3 raisedTo: 2) = 9; assert: (-3 raisedTo: 3) = -27; assert: (-3 raisedTo: -2) = (1/9); assert: (-3 raisedTo: -3) = (-1/27). self should: [ 0 raisedTo: -1 ] raise: ZeroDivide! ! !OCASTCheckerTest methodsFor: 'testing - simple' stamp: 'CamilloBruni 8/31/2013 20:23'! testSemanticAnalysisOnNonMethodNode | ast | {[ 1 + 2 ]. thisContext. (OCOpalExamples >> #exampleReturn1)} do: [ :object | ast := object sourceNode. ast doSemanticAnalysis ]. #('1' 'true' 'nil' '1 + 2' '^1' '1 + 2. 2 + 3' '#(1 true)' '{ #foo . 1 }' '1+2;+3') do: [ :source | ast := RBExplicitVariableParser parseExpression: source. ast doSemanticAnalysis ]. ast := RBExplicitVariableParser parseMethod: 'foo 1 + 2'. ast doSemanticAnalysis! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 7/2/2012 10:45'! testSingleRemoteDifferentBlocksSameArgumentName | ast assignment vars | ast := (OCOpalExamples>>#singleRemoteDifferentBlocksSameArgumentName) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 3. self deny: (ast scope lookupVar: 'b') isEscaping. self deny: (ast scope lookupVar: 'c') isEscaping. self assert: (ast scope lookupVar: 'z') isEscaping. ! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 6/29/2012 16:03'! testInstanceVar | ast assignment vars | ast := (OCOpalExamples>>#exampleiVar) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars isEmpty. self assert: ast scope outerScope isInstanceScope. self assert: (ast scope outerScope lookupVar: 'iVar') isInstance. assignment := RBParseTreeSearcher treeMatching: '`var := ``@anything' in: ast. self assert: assignment variable isInstance.! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 7/2/2012 10:45'! testNoRemoteBlockArgument | ast assignment vars | ast := (OCOpalExamples>>#noRemoteBlockArgument) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 3. self deny: (ast scope lookupVar: 'block') isEscaping . self deny: (ast scope lookupVar: 'block1') isEscaping. self deny: (ast scope lookupVar: 'block2') isEscaping. ! ! !OCASTCheckerTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/7/2013 13:06'! testExampleToDoArgument | ast | ast := (OCOpalExamples>>#exampleToDoArgument) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0.! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 7/2/2012 10:45'! testNoRemoteMethodTemp | ast assignment vars | ast := (OCOpalExamples>>#noRemoteMethodTemp) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 2. self deny: (ast scope lookupVar: 'block1') isEscaping. self deny: (ast scope lookupVar: 'block2') isEscaping. ! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 5/25/2013 16:44'! testOptimizedBlockWrittenAfterClosedOverCase1 | ast scopes | ast := (OCOpalExamples>>#optimizedBlockWrittenAfterClosedOverCase1) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self deny: (ast scope lookupVar: 'index') isEscaping. self assert: (ast scope lookupVar: 'index') definingScope = ast scope. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: (scopes third lookupVar: 'temp') isWrite. self assert: (scopes third lookupVar: 'temp') isEscaping. ! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 7/2/2012 10:43'! testDoubleRemoteAnidatedBlocks | ast assignment vars scopes | ast := (OCOpalExamples>>#doubleRemoteAnidatedBlocks) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 2. self assert: (ast scope lookupVar: 'last') isEscaping. self assert: (ast scope lookupVar: 'val') isEscaping. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: scopes size = 4. self assert: (scopes second lookupVar: 'i') isEscaping. "This is due to the inlined block." self assert: scopes third tempVars size = 1. self deny: (scopes third lookupVar: 'continue') isEscaping. "It is not escaping since is being accessed in an optimized block." ! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 7/2/2012 10:45'! testNoRemoteBlockTemp | ast assignment vars | ast := (OCOpalExamples>>#noRemoteBlockTemp) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 3. self deny: (ast scope lookupVar: 'block') isEscaping. self deny: (ast scope lookupVar: 'block1') isEscaping. self deny: (ast scope lookupVar: 'block2') isEscaping. ! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 5/25/2013 16:46'! testsingleRemoteTempVarWhileWithTempNotInlined | ast | ast := (OCOpalExamples>>#exampleWhileWithTempNotInlined) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 2. self assert: (ast scope lookupVar: 'index') isEscaping. self assert: (ast scope lookupVar: 'index') definingScope = ast scope. self deny: (ast scope lookupVar: 'block') isEscaping. self assert: (ast scope lookupVar: 'block') isTemp. ! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 5/22/2013 16:50'! testExampleSuper | ast assignment vars | ast := (OCOpalExamples>>#exampleSuper) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: (ast scope lookupVar: 'super') isSuper. assignment := RBParseTreeSearcher treeMatching: '`var := ``@anything' in: ast. self assert: assignment value binding isSuper.! ! !OCASTCheckerTest methodsFor: 'testing - simple' stamp: 'MarcusDenker 7/2/2012 10:44'! testReturn1 | ast | ast := (OCOpalExamples>>#exampleReturn1) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars isEmpty.! ! !OCASTCheckerTest methodsFor: 'testing - primitives' stamp: 'MarcusDenler 12/10/2012 16:17'! testExamplePrimitiveErrorCode | method ast ir newMethod | ast := (OCOpalExamples>>#examplePrimitiveErrorCode) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: (ast scope lookupVar: 'code') isTemp. ! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 5/22/2013 16:50'! testExampleThisContext | ast assignment vars | ast := (OCOpalExamples>>#exampleThisContext) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: (ast scope lookupVar: 'thisContext') isContext. assignment := RBParseTreeSearcher treeMatching: '`var := ``@anything' in: ast. self assert: assignment value binding isContext.! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 10/1/2013 15:08'! testsingleRemoteTempVarWrittenAfterClosedOver | ast | ast := (OCOpalExamples>>#singleRemoteTempVarWrittenAfterClosedOver) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 2. self assert: (ast scope lookupVar: 'index') isWrite. self assert: (ast scope lookupVar: 'index') definingScope = ast scope. self deny: (ast scope lookupVar: 'block') isEscaping. self assert: (ast scope lookupVar: 'block') isTemp. ! ! !OCASTCheckerTest methodsFor: 'tools' stamp: 'MarcusDenker 5/18/2013 10:13'! nameAnalysisNoClosureIn: class for: ast "Look up vars in classOrScope. My tree will be annotated with bindings to Scopes and Variables." OCASTSemanticAnalyzer new compilationContext: class compiler compilationContext; visitNode: ast.! ! !OCASTCheckerTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 7/2/2012 10:44'! testExampleInlineBlockCollectionLR3 | ast | ast := (OCOpalExamples>>#exampleInlineBlockCollectionLR3) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. "index is a temp of the outer method due to optimized block"! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 5/22/2013 16:50'! testExampleSelf | ast assignment vars | ast := (OCOpalExamples>>#exampleSelf) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: (ast scope lookupVar: 'self') isSelf. assignment := RBParseTreeSearcher treeMatching: '`var := ``@anything' in: ast. self assert: assignment value binding isSelf.! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 7/2/2012 10:45'! testSingleRemoteMethodArgument | ast assignment vars | ast := (OCOpalExamples>>#singleRemoteMethodArgument) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 2. self deny: (ast scope lookupVar: 'block') isEscaping. self assert: (ast scope lookupVar: 'temp') isEscaping. self assert: (ast scope lookupVar: 'temp') isWrite. ! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 7/2/2012 10:45'! testNoRemoteBlockReturn | ast assignment vars | ast := (OCOpalExamples>>#noRemoteBlockReturn) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0. ! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 7/2/2012 10:45'! testOptimizedBlocksAndSameNameTemps | ast assignment vars scopes | ast := (OCOpalExamples>>#optimizedBlocksAndSameNameTemps) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 2. self deny: (ast scope lookupVar: 's') isRemote. self deny: (ast scope lookupVar: 'c') isRemote. scopes := (OCScopesCollector new visitNode: ast) scopes. self deny: (scopes second lookupVar: 'a') isRemote. self deny: (scopes fourth lookupVar: 'i') isRemote. ! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 5/25/2013 16:45'! testOptimizedBlockWrittenAfterClosedOverCase2 | ast scopes | ast := (OCOpalExamples>>#optimizedBlockWrittenAfterClosedOverCase2) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self deny: (ast scope lookupVar: 'index') isEscaping. self assert: (ast scope lookupVar: 'index') definingScope= ast scope. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: ( scopes third lookupVar: 'temp') isEscapingWrite. self assert: ( scopes third lookupVar: 'temp') isEscaping. ! ! !OCASTCheckerTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 10/1/2013 15:07'! testSingleRemoteTempVar | ast | ast := (OCOpalExamples>>#singleRemoteTempVar) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 3. self assert: (ast scope lookupVar: 'index') isEscaping. self assert: (ast scope lookupVar: 'index') definingScope = ast scope. self deny: (ast scope lookupVar: 'block') isEscaping. self assert: (ast scope lookupVar: 'theCollection') isEscaping. self assert: (ast scope lookupVar: 'block') isTemp. self assert: (ast scope lookupVar: 'theCollection') isTemp. self deny: (ast scope lookupVar: 'theCollection') isInstance. self deny: (ast scope lookupVar: 'index') isInstance. self deny: (ast scope lookupVar: 'block') isInstance. ! ! !OCASTCheckerTest methodsFor: 'testing - simple' stamp: 'MarcusDenker 7/2/2012 10:44'! testExampleIfNotNilReturnNil | ast | ast := (OCOpalExamples>>#exampleIfNotNilReturnNil) parseTree. self nameAnalysisNoClosureIn: OCOpalExamples for: ast. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0.! ! !OCASTClosureAnalyzer methodsFor: 'visiting' stamp: 'MarcusDenker 5/22/2013 16:51'! visitVariableNode: aVariableNode "re-lookup the temorary variables..." | var | aVariableNode isTemp ifFalse: [^self]. var := scope lookupVar: aVariableNode name. aVariableNode binding: var. var isTempVectorTemp ifTrue: [scope addCopyingTempToAllScopesUpToDefVector: var vectorName]. var isCopying ifTrue: [scope addCopyingTempToAllScopesUpToDefTemp: var].! ! !OCASTClosureAnalyzer methodsFor: 'visiting' stamp: 'MarcusDenker 4/11/2013 15:11'! visitBlockNode: aBlockNode "here look at the temps and make copying vars / tempVector out of them" scope := aBlockNode scope. self doRemotes; doCopying. self visitNode: aBlockNode body. scope := scope popScope.! ! !OCASTClosureAnalyzer methodsFor: 'variables' stamp: 'JorgeRessia 9/23/2010 15:59'! doCopying | copying | copying := scope tempVars select: [ :each | each isEscapingRead]. copying do: [ :each | scope addCopyingTemp: each]! ! !OCASTClosureAnalyzer methodsFor: 'variables' stamp: 'JorgeRessia 9/22/2010 16:16'! doRemotes | remotes | remotes := scope tempVars select: [ :each | each isEscapingWrite]. remotes do: [ :each | scope moveToVectorTemp: each]. ! ! !OCASTClosureAnalyzer methodsFor: 'visiting' stamp: 'MarcusDenker 4/11/2013 15:11'! visitMethodNode: aMethodNode "here look at the temps and make copying vars / tempVector out of them" scope := aMethodNode scope. self doRemotes; doCopying. self visitNode: aMethodNode body. scope := scope popScope.! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:46'! testSingleRemoteDifferentBlocksSameArgumentName | ast assignment vars | ast := (OCOpalExamples>>#singleRemoteDifferentBlocksSameArgumentName) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 2. self assert: ast scope tempVector size = 1. self deny: (ast scope lookupVar: 'b') isRemote. self deny: (ast scope lookupVar: 'c') isRemote. self assert: (ast scope lookupVar: 'z') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 4/29/2013 17:39'! testDoubleRemoteAnidatedBlocks | ast assignment vars scopes | ast := (OCOpalExamples>>#doubleRemoteAnidatedBlocks) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0. self assert: ast scope tempVector size = 2. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: (ast scope lookupVar: 'last') isRemote. self assert: (ast scope lookupVar: 'val') isRemote. self assert: (ast scope lookupVar: 'val') vectorName = '0vector0'. self deny: (scopes second lookupVar: 'i') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - optimized blocks' stamp: 'MarcusDenker 5/22/2013 16:50'! testExampleSimpleBlockLocalIf | ast assignment var | ast := (OCOpalExamples>>#exampleSimpleBlockLocalIf) parseTree. ast doSemanticAnalysis. assignment := RBParseTreeSearcher treeMatching: '`var := ``@anything' in: ast. var := assignment variable binding. self assert: var isWrite. self deny: var isEscaping.! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:46'! testSingleRemoteReadNestedBlocks | ast assignment vars | ast := (OCOpalExamples>>#singleRemoteReadNestedBlocks) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0. self assert: ast scope tempVector size = 1. self assert: (ast scope lookupVar: 'a') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 10/1/2013 15:08'! testsingleRemoteTempVarWrittenAfterClosedOver | ast | ast := (OCOpalExamples>>#singleRemoteTempVarWrittenAfterClosedOver) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: ast scope tempVector size = 1. self assert: (ast scope lookupVar: 'index') isRemote. self assert: (ast scope lookupVar: 'index') definingScope = ast scope. self deny: (ast scope lookupVar: 'block') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:46'! testOptimizedBlockWriteInNestedBlockCase2 | ast assignment vars scopes | ast := (OCOpalExamples>>#optimizedBlockWriteInNestedBlockCase2) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: ast scope tempVector size = 0. self deny: (ast scope lookupVar: 't1') isRemote. self assert: ast scope copiedVars size = 0. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:45'! testNestedBlocksRemoteInBlockCase3 | ast assignment vars scopes | ast := (OCOpalExamples>>#nestedBlocksRemoteInBlockCase3) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0. self assert: ast scope tempVector size = 1. self assert: (ast scope lookupVar: 'block') isRemote. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: scopes second tempVars size = 0. self assert: scopes second tempVector size = 0. self assert: scopes third tempVars size = 0. self assert: scopes third tempVector size = 1. self assert: (scopes third tempVector at: 'a') isRemote. self assert: scopes fourth tempVars size = 0. self assert: scopes fourth tempVector size = 0. self assert: scopes fifth tempVars size = 0. self assert: scopes fifth tempVector size = 1. self assert: (scopes fifth tempVector at: 'b') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:45'! testOptimizedBlockReadInBlock | ast assignment vars scopes | ast := (OCOpalExamples>>#optimizedBlockReadInBlock) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: ast scope tempVector size = 0. self deny: (ast scope lookupVar: 't1') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:45'! testNoRemoteBlockArgument | ast assignment vars | ast := (OCOpalExamples>>#noRemoteBlockArgument) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 3. self deny: (ast scope lookupVar: 'block') isRemote . self deny: (ast scope lookupVar: 'block1') isRemote. self deny: (ast scope lookupVar: 'block2') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:45'! testExampleSimpleBlockNested | ast assignment vars scopes | ast := (OCOpalExamples>>#exampleSimpleBlockNested) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 2. self assert: ast scope tempVector size = 1. self deny: (ast scope lookupVar: 'a') isRemote. self deny: (ast scope lookupVar: 'dict') isRemote. self assert: (ast scope lookupVar: 'match') isRemote. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: scopes second tempVars size = 2. self assert: scopes second tempVector size = 0. self deny: (scopes second lookupVar: 'each') isRemote. self deny: (scopes second lookupVar: 'index') isRemote. self assert: scopes second copiedVars size = 3 ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:45'! testNestedBlocksRemoteInBlockCase2 | ast assignment vars scopes | ast := (OCOpalExamples>>#nestedBlocksRemoteInBlockCase2) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: ast scope tempVector size = 0. self deny: (ast scope lookupVar: 'block') isRemote. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: scopes second tempVars size = 0. self assert: scopes second tempVector size = 0. self assert: scopes third tempVars size = 0. self assert: scopes third tempVector size = 1. self assert: (scopes third tempVector at: 'a') isRemote. self assert: scopes fourth tempVars size = 0. self assert: scopes fourth tempVector size = 0. self assert: scopes fifth tempVars size = 0. self assert: scopes fifth tempVector size = 1. self assert: (scopes fifth tempVector at: 'b') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:45'! testNoRemoteReadInBlock | ast assignment vars scopes | ast := (OCOpalExamples>>#noRemoteReadInBlock) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: ast scope tempVector size = 0. self deny: (ast scope lookupVar: 'a') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:46'! testOptimizedBlockWrittenAfterClosedOverCase1 | ast assignment vars scopes | ast := (OCOpalExamples>>#optimizedBlockWrittenAfterClosedOverCase1) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: ast scope tempVector size = 0. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: scopes third tempVars size = 0. self assert: scopes third tempVector size = 1. self deny: (scopes third lookupVar: 'index') isRemote. "problem: as block is optimized, this var does not need to be remote" self assert: (scopes third tempVector at: 'temp') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - blocks' stamp: 'MarcusDenker 11/20/2012 15:45'! testExampleWhileModificationBefore | ast assignment vars blockScope blockScope2 | ast := (OCOpalExamples>>#exampleWhileModificationBefore) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0. self assert: ast scope tempVector size = 1. self assert: ast scope copiedVars size = 1. self assert: (ast scope lookupVar: 'index') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:45'! testNoRemoteReadNestedBlocks | ast assignment vars scopes | ast := (OCOpalExamples>>#noRemoteReadNestedBlocks) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0. self assert: ast scope tempVector size = 0. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: scopes second tempVars size = 1. self assert: scopes second tempVector size = 0. self deny: (scopes second lookupVar: 'a') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:46'! testWrittenAfterClosedOver | ast assignment vars scopes | ast := (OCOpalExamples>>#writtenAfterClosedOver) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0. self assert: ast scope tempVector size = 1. self assert: (ast scope lookupVar: 'a') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 5/25/2013 16:48'! testsingleRemoteTempVarWhileWithTempNotInlined | ast | ast := (OCOpalExamples>>#exampleWhileWithTempNotInlined) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: ast scope tempVector size = 1. self assert: (ast scope lookupVar: 'index') isRemote. self assert: (ast scope lookupVar: 'index') definingScope = ast scope. self deny: (ast scope lookupVar: 'block') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:45'! testExampleSimpleBlockLocalWhile | ast assignment vars scopes | ast := (OCOpalExamples>>#exampleSimpleBlockLocalWhile) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0. self assert: ast scope tempVector size = 1. self assert: (ast scope lookupVar: 'a') isRemote. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: scopes second tempVars size = 1. self assert: scopes second tempVector size = 0. self deny: (scopes second lookupVar: 'b') isRemote. self assert: (scopes second lookupVar: 'b') isArg. self deny: (scopes fourth lookupVar: 'hallo') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:46'! testOptimizedBlockWriteInNestedBlockCase4 | ast assignment vars scopes | ast := (OCOpalExamples>>#optimizedBlockWriteInNestedBlockCase4) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0. self assert: ast scope tempVector size = 1. self assert: (ast scope lookupVar: 't1') isRemote. self assert: ast scope copiedVars size = 1. "Is this correct, I think that the copied vars should be empty." scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: scopes second tempVars size = 0. self assert: scopes second tempVector size = 0. self assert: scopes second copiedVars size = 1. scopes second copiedVars at: '0vector0' ifAbsent: [self fail] ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:46'! testSingleRemoteMethodArgument | ast assignment vars | ast := (OCOpalExamples>>#singleRemoteMethodArgument) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: ast scope tempVector size = 1. self deny: (ast scope lookupVar: 'block') isRemote. self assert: (ast scope lookupVar: 'temp') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:46'! testOptimizedBlockWriteInNestedBlockCase3 | ast assignment vars scopes | ast := (OCOpalExamples>>#optimizedBlockWriteInNestedBlockCase3) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0. self assert: ast scope tempVector size = 1. self assert: (ast scope lookupVar: 't1') isRemote. self assert: ast scope copiedVars size = 1. "Is this correct, I think that the copied vars should be empty." scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: scopes second tempVars size = 0. self assert: scopes second tempVector size = 0. self assert: scopes second copiedVars size = 1. scopes second copiedVars at: '0vector0' ifAbsent: [self fail]. self assert: ((scopes second copiedVars at: '0vector0') isStoringTempVector). ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 5/3/2013 13:11'! testNestedBlocksRemoteInBlockCase1 | ast scopes | ast := (OCOpalExamples>>#nestedBlocksRemoteInBlockCase1) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: ast scope tempVector size = 0. self deny: (ast scope lookupVar: 'block') isRemote. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: scopes second tempVars size = 0. self assert: scopes second tempVector size = 2. self assert: (scopes second tempVector at: 'a') isRemote. self assert: (scopes second tempVector at: 'b') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:47'! testOptimizedBlockWriteInNestedBlock | ast assignment vars scopes | ast := (OCOpalExamples>>#optimizedBlockWriteInNestedBlock) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 0. self assert: ast scope tempVector size = 1. self assert: (ast scope lookupVar: 't1') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:46'! testOptimizedBlockWrittenAfterClosedOverCase2 | ast assignment vars scopes | ast := (OCOpalExamples>>#optimizedBlockWrittenAfterClosedOverCase2) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: ast scope tempVector size =0. self deny: (ast scope lookupVar: 'index') isRemote. scopes := (OCScopesCollector new visitNode: ast) scopes. self assert: (scopes third tempVector at: 'temp') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 5/25/2013 16:47'! testSingleRemoteTempVar | ast | ast := (OCOpalExamples>>#singleRemoteTempVar) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 2. self assert: ast scope tempVector size = 1. self assert: (ast scope lookupVar: 'index') isRemote. self assert: (ast scope lookupVar: 'index') definingScope = ast scope. self deny: (ast scope lookupVar: 'block') isRemote. self deny: (ast scope lookupVar: 'collection') isRemote. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - blocks' stamp: 'MarcusDenker 11/20/2012 15:44'! testExampleBlockArgument | ast assignment vars blockScope blockScope2 | ast := (OCOpalExamples>>#exampleBlockArgument) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 3. self assert: ast scope tempVector size = 0. self assert: ast scope copiedVars size = 0. self deny: (ast scope lookupVar: 'block') isRemote. self deny: (ast scope lookupVar: 'block1') isRemote. self deny: (ast scope lookupVar: 'block2') isRemote. blockScope := (OCScopesCollector new visitNode: ast) scopes second. self assert: blockScope tempVars size = 2. self assert: blockScope tempVector size = 0. self assert: blockScope copiedVars size = 1. self deny: (blockScope lookupVar: 'temp') isRemote. self assert: (blockScope lookupVar: 'temp') isEscapingRead. self assert: (blockScope lookupVar: 'temp') isWrite. self deny: (blockScope lookupVar: 'temp') isEscapingWrite. self deny: (blockScope lookupVar: 'arg') isRemote. blockScope2 := (OCScopesCollector new visitNode: ast) scopes third. self assert: blockScope2 tempVars size = 0. self assert: blockScope2 tempVector size = 0. self assert: blockScope2 copiedVars size = 1. ! ! !OCASTClosureAnalyzerTest methodsFor: 'tests - special cases' stamp: 'MarcusDenker 11/20/2012 15:45'! testOptimizedBlockWriteInBlock | ast assignment vars scopes | ast := (OCOpalExamples>>#optimizedBlockWriteInBlock) parseTree. ast doSemanticAnalysis. self assert: ast scope isMethodScope. self assert: ast scope tempVars size = 1. self assert: ast scope tempVector size = 0. self deny: (ast scope lookupVar: 't1') isRemote. ! ! !OCASTSemanticAnalyzer commentStamp: ''! I visit each node in the abstract syntax tree while growing and shrinking a scope chain. Each method and block node is linked with its corresponding scope object, and each variable def and ref is linked with its corresponding OCVariable. Exceptions are raised for undefined variable references and so on (see subclasses of OCSemanticWarning). ! !OCASTSemanticAnalyzer methodsFor: 'variables' stamp: 'md 11/14/2013 17:11'! declareVariableNode: aVariableNode | name var | name := aVariableNode name. var := scope lookupVarForDeclaration: name. var ifNotNil: [ self variable: aVariableNode shadows: var. (var scope ~= scope) ifTrue: [ "Create new var that shadows outer one" var := scope addTemp: name ] ] ifNil: [ "new var" var := scope addTemp: name ]. aVariableNode binding: var. ^ var! ! !OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: 'MarcusDenker 5/23/2013 10:17'! storeIntoSpecialVariable: variableNode ^ OCSemanticError new node: variableNode; compilationContext: compilationContext; messageText: 'Cannot store into'; signal! ! !OCASTSemanticAnalyzer methodsFor: 'variables' stamp: 'MarcusDenker 4/16/2013 15:58'! lookupVariableForWrite: aVariableNode | var | var := scope lookupVar: aVariableNode name. var ifNil: [^var]. var isSpecialVariable ifTrue: [ self storeIntoSpecialVariable: aVariableNode ]. var isTemp ifTrue: [ (var scope outerNotOptimizedScope ~= scope outerNotOptimizedScope) "only escaping when they will end up in different closures" ifTrue: [ var markEscapingWrite]]. ^var! ! !OCASTSemanticAnalyzer methodsFor: 'visitor' stamp: 'MarcusDenker 5/25/2013 16:21'! visitMessageNode: aMessageNode | selectorString | "this should be moved to the parser" selectorString := (String streamContents: [ :str | aMessageNode selectorParts do: [ :each | str nextPutAll: each value ]]). (Symbol findInterned: selectorString) ifNil: [self unknownSelector: aMessageNode]. (aMessageNode isCascaded not or: [aMessageNode isFirstCascaded]) ifTrue: [self visitNode: aMessageNode receiver]. aMessageNode arguments do: [:each | self visitNode: each]. ! ! !OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: 'MarcusDenker 5/22/2013 16:50'! uninitializedVariable: variableNode variableNode binding markRead. ^ OCUninitializedVariableWarning new node: variableNode; compilationContext: compilationContext; signal! ! !OCASTSemanticAnalyzer methodsFor: 'visitor' stamp: 'MarcusDenker 5/18/2013 10:44'! visitMethodNode: aMethodNode scope := compilationContext scope newMethodScope. aMethodNode scope: scope. scope node: aMethodNode. aMethodNode arguments do: [:node | (self declareVariableNode: node) markArg]. aMethodNode pragmas do: [:each | self visitNode: each]. self visitNode: aMethodNode body. scope := scope outerScope. ! ! !OCASTSemanticAnalyzer methodsFor: 'visitor' stamp: 'CamilloBruni 2/26/2014 16:45'! visitSequenceNode: aSequenceNode aSequenceNode temporaries do: [ :node | self declareVariableNode: node ]. aSequenceNode parent isMethod ifTrue: [ aSequenceNode parent pragmas detect: [ :pragma | pragma isPrimitiveError ] ifFound: [ :pragma | self declareVariableNode: (RBVariableNode named: (pragma argumentAt: #error:) value asString) ] ]. aSequenceNode statements do: [ :each | self visitNode: each ]. aSequenceNode temporaries reverseDo: [ :node | node binding isUnused ifTrue: [ self unusedVariable: node ] ]! ! !OCASTSemanticAnalyzer methodsFor: 'visitor' stamp: 'MarcusDenker 5/18/2013 10:23'! visitBlockNode: aBlockNode blockcounter := self blockcounter + 1. aBlockNode isInlined ifTrue: [^ self visitInlinedBlockNode: aBlockNode ]. scope := scope newBlockScope: blockcounter. aBlockNode scope: scope. scope node: aBlockNode. aBlockNode arguments do: [:node | (self declareVariableNode: node) markArg]. self visitNode: aBlockNode body. scope := scope popScope.! ! !OCASTSemanticAnalyzer methodsFor: 'visitor' stamp: 'MarcusDenker 5/22/2013 16:51'! visitVariableNode: aVariableNode | var | var := (self lookupVariableForRead: aVariableNode) ifNil: [(self undeclaredVariable: aVariableNode)]. "written variables in loops need special care... needs to be checked" (var isTemp and: [var isEscaping and: [scope outerScope isInsideOptimizedLoop]]) ifTrue: [ var isWrite ifTrue: [var markEscapingWrite]. var isRead ifTrue: [var markEscapingRead]]. aVariableNode binding: var. var isUninitialized ifTrue: [self uninitializedVariable: aVariableNode].! ! !OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: 'MarcusDenker 5/17/2013 16:26'! unusedVariable: variableNode ^ OCUnusedVariableWarning new node: variableNode; compilationContext: compilationContext; signal! ! !OCASTSemanticAnalyzer methodsFor: 'accessing' stamp: 'ClementBera 5/16/2013 13:59'! compilationContext ^ compilationContext! ! !OCASTSemanticAnalyzer methodsFor: 'variables' stamp: 'MarcusDenker 5/18/2013 10:32'! lookupVariableForRead: aVariableNode | var | var := scope lookupVar: aVariableNode name. var ifNil: [^var]. (var isTemp and: [var scope outerNotOptimizedScope ~= scope outerNotOptimizedScope] ) "only escaping when they will end up in different closures" ifTrue: [var markEscapingRead]. ^var! ! !OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: 'MarcusDenker 5/17/2013 16:26'! variable: variableNode shadows: semVar ^ OCShadowVariableWarning new node: variableNode; shadowedVar: semVar; compilationContext: compilationContext; signal! ! !OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: 'MarcusDenker 5/17/2013 16:26'! undeclaredVariable: variableNode ^ OCUndeclaredVariableWarning new node: variableNode; compilationContext: compilationContext; signal! ! !OCASTSemanticAnalyzer methodsFor: 'visitor' stamp: 'MarcusDenker 5/22/2013 16:51'! visitAssignmentNode: anAssignmentNode | var | self visitNode: anAssignmentNode value. var := (self lookupVariableForWrite: anAssignmentNode variable) ifNil: [self undeclaredVariable: anAssignmentNode variable]. var markWrite. anAssignmentNode variable binding: var. ! ! !OCASTSemanticAnalyzer methodsFor: 'accessing' stamp: 'MarcusDenker 5/18/2013 10:23'! blockcounter ^blockcounter ifNil: [0]! ! !OCASTSemanticAnalyzer methodsFor: 'initialize-release' stamp: 'MarcusDenker 9/4/2010 09:53'! scope: aSemScope scope := aSemScope! ! !OCASTSemanticAnalyzer methodsFor: 'error handling' stamp: 'MarcusDenker 5/17/2013 16:34'! unknownSelector: messageNode ^ OCUnknownSelectorWarning new node: messageNode; compilationContext: compilationContext; signal! ! !OCASTSemanticAnalyzer methodsFor: 'accessing' stamp: 'MarcusDenker 5/7/2013 08:56'! compilationContext: aCompilationContext compilationContext := aCompilationContext! ! !OCASTSemanticAnalyzer methodsFor: 'api' stamp: 'MarcusDenker 7/10/2013 15:55'! analyze: aNode self visitNode: aNode. OCASTClosureAnalyzer new visitNode: aNode! ! !OCASTSemanticAnalyzer methodsFor: 'visitor' stamp: 'MarcusDenker 5/14/2013 16:32'! visitPragmaNode: aPragmaNode super visitPragmaNode: aPragmaNode. aPragmaNode isCompilerOption ifTrue: [ aPragmaNode asPragma sendTo: aPragmaNode methodNode compilationContext ].! ! !OCASTSemanticAnalyzer methodsFor: 'visitor' stamp: 'MarcusDenker 5/18/2013 10:23'! visitInlinedBlockNode: aBlockNode scope := scope newOptimizedBlockScope: blockcounter. aBlockNode isInlinedLoop ifTrue: [scope markInlinedLoop]. aBlockNode scope: scope. scope node: aBlockNode. aBlockNode arguments do: [:node | (self declareVariableNode: node ) markArg.]. self visitNode: aBlockNode body. scope := scope popScope.! ! !OCASTTranslator commentStamp: 'ajh 3/24/2003 22:19'! I visit an abstract syntax tree and generate IR (intermediate representation) instructions for each node by sending the appropriate message to my methodBuilder (an IRBuilder). I hold onto my two subclasses one for generating instructions for value, the other for generating instructions for effect.! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 14:13'! emitIfFalse: aMessageNode self shouldBeSentToValueOrEffectTranslator! ! !OCASTTranslator methodsFor: 'visitor' stamp: 'MarcusDenker 5/18/2013 17:41'! emitMessageNode: aMessageNode aMessageNode isCascaded ifFalse: [ valueTranslator visitNode: aMessageNode receiver]. aMessageNode arguments do: [:each | valueTranslator visitNode: each]. aMessageNode isSuperSend ifTrue: [methodBuilder send: aMessageNode selector toSuperOf: self compilationContext getClass] ifFalse: [methodBuilder send: aMessageNode selector]. ! ! !OCASTTranslator methodsFor: 'errors' stamp: 'nice 5/1/2013 18:03'! shouldBeSentToValueOrEffectTranslator self error: 'should be sent only to valueTranslator or effectTranslator'! ! !OCASTTranslator methodsFor: 'accessing' stamp: 'ajh 3/10/2003 17:59'! ir ^ methodBuilder ir! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'MarcusDenker 6/11/2013 15:52'! emitIfNotNilIfNil: aMessageNode | args | valueTranslator visitNode: aMessageNode receiver. args := aMessageNode arguments. args first arguments ifNotEmpty: [ args first arguments first binding emitStore: methodBuilder ]. methodBuilder pushLiteral: nil. methodBuilder send: #==. methodBuilder jumpAheadTo: #else if: true. self visitInlinedBlockNode: args first. methodBuilder jumpAheadTo: #end. methodBuilder jumpAheadTarget: #else. self visitInlinedBlockNode: args last. methodBuilder jumpAheadTarget: #end! ! !OCASTTranslator methodsFor: 'visitor-double dispatching' stamp: 'nice 5/1/2013 16:13'! visitCascadeNode: aCascadeNode valueTranslator visitNode: aCascadeNode receiver. aCascadeNode messages allButLastDo: [:node | methodBuilder pushDup. effectTranslator visitNode: node. ]. self visitNode: aCascadeNode messages last. ! ! !OCASTTranslator methodsFor: 'visitor-double dispatching' stamp: 'ClementBera 11/20/2013 19:36'! visitMessageNode: aMessageNode aMessageNode isInlined ifTrue: [ methodBuilder addLiteral: aMessageNode selector. "so searching for senders will work" ^self perform: (OptimizedMessages at: aMessageNode selector) with: aMessageNode]. ^ self emitMessageNode: aMessageNode! ! !OCASTTranslator methodsFor: 'visitor' stamp: 'cb 6/27/2013 16:53'! visitMethodNode: aMethodNode aMethodNode arguments size > 15 ifTrue: [self backendError: 'Too many arguments' forNode: aMethodNode ]. methodBuilder compilationContext: aMethodNode compilationContext. methodBuilder addTemps: aMethodNode scope tempVarNames. methodBuilder properties: aMethodNode properties. methodBuilder irPrimitive: aMethodNode primitiveFromPragma. aMethodNode pragmas do: [:each | self visitPragmaNode: each]. methodBuilder numArgs: aMethodNode arguments size. aMethodNode scope tempVector ifNotEmpty: [ methodBuilder createTempVectorNamed: aMethodNode scope tempVectorName withVars: (aMethodNode scope tempVector collect: [:each| each name]) asArray. ]. effectTranslator visitNode: aMethodNode body. aMethodNode body lastIsReturn ifFalse: [methodBuilder pushReceiver; returnTop]! ! !OCASTTranslator methodsFor: 'visitor-double dispatching' stamp: 'MarcusDenker 7/10/2013 16:20'! visitArrayNode: anArrayNode | elementNodes | anArrayNode statements size > 32 ifTrue: [^ self visitLargeArrayNode: anArrayNode ]. elementNodes := anArrayNode children. elementNodes do: [:node | valueTranslator visitNode: node]. methodBuilder pushConsArray: elementNodes size.! ! !OCASTTranslator methodsFor: 'visitor' stamp: 'MarcusDenker 5/22/2013 16:50'! visitVariableNode: aVariableNode aVariableNode binding emitValue: methodBuilder ! ! !OCASTTranslator methodsFor: 'visitor-double dispatching' stamp: 'cb 9/26/2013 14:27'! visitBlockNode: aBlockNode | tempNames argumentNames copiedNames | aBlockNode arguments size >15 ifTrue: [self backendError: 'Too many arguments' forNode: aBlockNode ]. aBlockNode isInlined ifTrue: [^ self visitInlinedBlockNode: aBlockNode ]. "uncomment to enable clean blocks aBlockNode isClean ifTrue: [^ self visitCleanBlockNode: aBlockNode ]." argumentNames := aBlockNode argumentNames asArray. tempNames := (aBlockNode scope tempVars asArray collect: [ :each | each name]) copyWithoutAll: argumentNames. copiedNames := (aBlockNode scope inComingCopiedVars asArray collect: [:each | each name]). methodBuilder pushClosureCopyCopiedValues: copiedNames args: argumentNames jumpTo: #block. aBlockNode scope tempVector ifNotEmpty: [ methodBuilder createTempVectorNamed: aBlockNode scope tempVectorName withVars: (aBlockNode scope tempVector collect: [:each| each name]) asArray. ]. methodBuilder addTemps: tempNames. valueTranslator visitNode: aBlockNode body. methodBuilder addBlockReturnTopIfRequired. self flag: 'why dont we just add a blockReturnTop here... it could be removed or ignored in IRTranslator'. methodBuilder jumpAheadTarget: #block. ! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 14:32'! emitIf: aMessageNode boolean: aBoolean valueTranslator visitNode: aMessageNode receiver. methodBuilder jumpAheadTo: #else if: aBoolean. self visitInlinedBlockNode: aMessageNode arguments first. methodBuilder jumpAheadTo: #end. methodBuilder jumpAheadTarget: #else. self visitInlinedBlockNode: aMessageNode arguments last. methodBuilder jumpAheadTarget: #end.! ! !OCASTTranslator methodsFor: 'visitor-double dispatching' stamp: 'ClementBera 7/19/2013 14:24'! visitLargeArrayNode: aRBArrayNode "Long form: generates (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray" methodBuilder pushLiteralVariable: Array binding. methodBuilder pushLiteral: aRBArrayNode statements size. methodBuilder send: #braceStream:. aRBArrayNode statements do: [ :each | methodBuilder pushDup. valueTranslator visitNode: each. methodBuilder send: #nextPut:. methodBuilder popTop. ]. methodBuilder send: #braceArray. ! ! !OCASTTranslator methodsFor: 'initialization' stamp: 'ClementBera 12/11/2012 11:35'! initialize methodBuilder := IRBuilder new. effectTranslator := self as: OCASTTranslatorForEffect. valueTranslator := self as: OCASTTranslatorForValue. effectTranslator instVarNamed: #effectTranslator put: effectTranslator. effectTranslator instVarNamed: #valueTranslator put: valueTranslator. valueTranslator instVarNamed: #valueTranslator put: valueTranslator. ! ! !OCASTTranslator methodsFor: 'visitor-double dispatching' stamp: 'MarcusDenker 4/11/2013 15:12'! visitLiteralArrayNode: aRBLiteralArrayNode methodBuilder pushLiteral: aRBLiteralArrayNode value. ! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 14:11'! emitWhileTrue: aMessageNode self emitWhile: aMessageNode boolean: false! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 14:10'! emitWhile: aMessageNode boolean: aBoolean methodBuilder jumpBackTarget: #begin. valueTranslator visitInlinedBlockNode: aMessageNode receiver. methodBuilder jumpAheadTo: #end if: aBoolean. aMessageNode arguments ifNotEmpty: [ effectTranslator visitInlinedBlockNode: aMessageNode arguments first]. methodBuilder jumpBackTo: #begin. methodBuilder jumpAheadTarget: #end.! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 15:04'! emitAllButLastCases: cases | assocMessageNode | 1 to: cases size - 1 do: [:i | methodBuilder pushDup. assocMessageNode := cases at: i. valueTranslator visitInlinedBlockNode: assocMessageNode receiver. methodBuilder send: #=. methodBuilder jumpAheadTo: #next if: false. methodBuilder popTop. self visitInlinedBlockNode: assocMessageNode arguments first. methodBuilder jumpAheadTo: #end. methodBuilder jumpAheadTarget: #next. ]! ! !OCASTTranslator methodsFor: 'testing' stamp: 'pmm 7/19/2006 11:52'! isValueTranslator ^self == valueTranslator! ! !OCASTTranslator methodsFor: 'visitor' stamp: 'CamilloBruni 2/26/2014 16:45'! visitPragmaNode: aPragmaNode methodBuilder addPragma: aPragmaNode asPragma. aPragmaNode isPrimitiveError ifTrue: [ methodBuilder storeTemp: (aPragmaNode argumentAt: #error:) value ]. ! ! !OCASTTranslator methodsFor: 'testing' stamp: 'pmm 7/19/2006 11:54'! isEffectTranslator ^self == effectTranslator! ! !OCASTTranslator methodsFor: 'visitor-double dispatching' stamp: 'MarcusDenker 4/11/2013 15:12'! visitInlinedBlockNode: anOptimizedBlockNode "We are visiting a scope that is not a block, but inlined in the outer context. This means: - we do not create a Block - we call IRBuilder to add temps " | argumentNames tempNames copiedNames | argumentNames := anOptimizedBlockNode argumentNames asArray. tempNames := (anOptimizedBlockNode scope tempVars collect: [ :each | each name asSymbol]) copyWithoutAll: argumentNames. copiedNames := (anOptimizedBlockNode scope inComingCopiedVars collect: [:each | each name]) asArray. anOptimizedBlockNode scope tempVector ifNotEmpty: [ methodBuilder createTempVectorNamed: anOptimizedBlockNode scope tempVectorName withVars: (anOptimizedBlockNode scope tempVector collect: [:each| each name]) asArray. ]. methodBuilder addTemps: tempNames. methodBuilder addTemps: copiedNames. methodBuilder addTemps: argumentNames. anOptimizedBlockNode isInlinedLoop ifTrue: [ tempNames do: [ :tempName | methodBuilder pushLiteral: nil. methodBuilder storeTemp: tempName. methodBuilder popTop. ]]. self visitNode: anOptimizedBlockNode body.! ! !OCASTTranslator methodsFor: 'visitor-double dispatching' stamp: 'ClementBera 8/5/2013 11:09'! visitCleanBlockNode: aBlockNode ! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 14:11'! emitWhileFalse: aMessageNode self emitWhile: aMessageNode boolean: true! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 15:04'! emitCaseOf: aMessageNode | cases assocMessageNode | cases := aMessageNode arguments first statements. cases ifEmpty: [ self backendError: 'At least one case required' forNode: aMessageNode ]. valueTranslator visitNode: aMessageNode receiver. self emitAllButLastCases: cases. "last case without otherwise" methodBuilder pushDup. assocMessageNode := cases last. valueTranslator visitInlinedBlockNode: assocMessageNode receiver. methodBuilder send: #=. methodBuilder jumpAheadTo: #next if: false. methodBuilder popTop. self visitInlinedBlockNode: assocMessageNode arguments first. methodBuilder jumpAheadTo: #end. methodBuilder jumpAheadTarget: #next. methodBuilder send: #caseError. aMessageNode lastIsReturn ifTrue: [ (aMessageNode owningScope) isBlockScope ifTrue: [methodBuilder blockReturnTop] ifFalse: [methodBuilder returnTop]] ifFalse: [self isEffectTranslator ifTrue: [methodBuilder popTop]]. cases size timesRepeat: [methodBuilder jumpAheadTarget: #end].! ! !OCASTTranslator methodsFor: 'errors' stamp: 'MarcusDenker 5/15/2013 14:49'! backendError: aMessage forNode: aNode SyntaxErrorNotification inClass: Object category: nil withCode: aNode methodNode source doitFlag: false errorMessage: aMessage location: aNode startWithoutParentheses! ! !OCASTTranslator methodsFor: 'visitor-double dispatching' stamp: 'nice 5/2/2013 00:22'! visitSequenceNode: aSequenceNode self shouldBeSentToValueOrEffectTranslator! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'nice 5/1/2013 18:03'! emitOr: aMessageNode self shouldBeSentToValueOrEffectTranslator ! ! !OCASTTranslator methodsFor: 'visitor' stamp: 'JorgeRessia 5/6/2010 10:00'! visitNode: aNode methodBuilder mapToNode: aNode. super visitNode: aNode. methodBuilder popMap. ! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'MarcusDenker 9/20/2013 15:04'! emitToDo: aMessageNode step: step | limit block iterator limitEmit | limit := aMessageNode arguments first. block := aMessageNode arguments last. iterator := block arguments first binding. limitEmit := [valueTranslator visitNode: limit]. limit isLiteralNode | limit isSelf | limit isSuper ifFalse: [ valueTranslator visitNode: limit. methodBuilder addTemp: (iterator name, #limit). methodBuilder storeTemp: (iterator name, #limit). methodBuilder popTop. limitEmit := [methodBuilder pushTemp: (iterator name, #limit)]]. "push start. allocate and initialize iterator" valueTranslator visitNode: aMessageNode receiver. iterator emitStore: methodBuilder. self isEffectTranslator ifTrue: [methodBuilder popTop]. methodBuilder jumpBackTarget: #start. iterator emitValue: methodBuilder. limitEmit value. methodBuilder send: (step > 0 ifTrue: [#<=] ifFalse: [#>=]). methodBuilder jumpAheadTo: #done if: false. effectTranslator visitInlinedBlockNode: block. iterator emitValue: methodBuilder. methodBuilder pushLiteral: step. methodBuilder send: #+. iterator emitStore: methodBuilder. methodBuilder popTop. methodBuilder jumpBackTo: #start. methodBuilder jumpAheadTarget: #done.! ! !OCASTTranslator methodsFor: 'accessing' stamp: 'MarcusDenker 5/18/2013 17:38'! compilationContext ^methodBuilder compilationContext ! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 14:13'! emitIfTrue: aMessageNode self shouldBeSentToValueOrEffectTranslator! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 15:04'! emitCaseOfOtherwise: aMessageNode | cases assocMessageNode | cases := aMessageNode arguments first statements. cases ifEmpty: [ self backendError: 'At least one case required' forNode: aMessageNode ]. valueTranslator visitNode: aMessageNode receiver. self emitAllButLastCases: cases. "last case with otherwise" assocMessageNode := cases last. valueTranslator visitInlinedBlockNode: assocMessageNode receiver. methodBuilder send: #=. methodBuilder jumpAheadTo: #next if: false. self visitInlinedBlockNode: assocMessageNode arguments first. methodBuilder jumpAheadTo: #end. methodBuilder jumpAheadTarget: #next. self visitInlinedBlockNode: aMessageNode arguments last. cases size timesRepeat: [methodBuilder jumpAheadTarget: #end].! ! !OCASTTranslator methodsFor: 'visitor-double dispatching' stamp: 'MarcusDenker 6/11/2013 15:52'! visitAssignmentNode: anAssignmentNode valueTranslator visitNode: anAssignmentNode value. anAssignmentNode variable binding emitStore: methodBuilder ! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'nice 5/1/2013 18:03'! emitAnd: aMessageNode self shouldBeSentToValueOrEffectTranslator ! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 14:08'! emitToDo: aMessageNode self emitToDo: aMessageNode step: 1! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'MarcusDenker 4/11/2013 15:12'! emitIfNil: aMessageNode valueTranslator visitNode: aMessageNode receiver. self isValueTranslator ifTrue: [ methodBuilder pushDup ]. methodBuilder pushLiteral: nil. methodBuilder send: #==. methodBuilder jumpAheadTo: #else if: false. self isValueTranslator ifTrue: [ methodBuilder popTop ]. self visitInlinedBlockNode: aMessageNode arguments first. methodBuilder jumpAheadTarget: #else. ! ! !OCASTTranslator methodsFor: 'visitor-double dispatching' stamp: 'MarcusDenker 4/11/2013 15:12'! visitLiteralNode: aLiteralNode methodBuilder pushLiteral: aLiteralNode value. ! ! !OCASTTranslator methodsFor: 'visitor' stamp: 'MarcusDenker 4/11/2013 15:12'! visitReturnNode: aReturnNode valueTranslator visitNode: aReturnNode value. methodBuilder returnTop. ! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/26/2013 14:05'! emitTimesRepeat: aMessageNode | limit block limitEmit | limit := aMessageNode receiver. block := aMessageNode arguments last. limitEmit := [valueTranslator visitNode: limit]. limit isLiteral | limit isSelf | limit isSuper ifFalse: [ valueTranslator visitNode: limit. methodBuilder addTemp: #limit. methodBuilder storeTemp: #limit. methodBuilder popTop. limitEmit := [methodBuilder pushTemp: #limit]]. "push start. allocate and initialize iterator" self isValueTranslator ifTrue: [ limitEmit value ]. methodBuilder pushLiteral: 1. methodBuilder addTemp: #iterator. methodBuilder storeTemp: #iterator. methodBuilder popTop. methodBuilder jumpBackTarget: #start. methodBuilder pushTemp: #iterator. limitEmit value. methodBuilder send: #<=. methodBuilder jumpAheadTo: #done if: false. effectTranslator visitInlinedBlockNode: block. methodBuilder pushTemp: #iterator. methodBuilder pushLiteral: 1. methodBuilder send: #+. methodBuilder storeTemp: #iterator. methodBuilder popTop. methodBuilder jumpBackTo: #start. methodBuilder jumpAheadTarget: #done.! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 14:33'! emitIfFalseIfTrue: aMessageNode self emitIf: aMessageNode boolean: true! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'MarcusDenker 6/11/2013 15:52'! emitIfNilIfNotNil: aMessageNode | args | valueTranslator visitNode: aMessageNode receiver. args := aMessageNode arguments. args last arguments ifNotEmpty: [ args last arguments first binding emitStore: methodBuilder ]. methodBuilder pushLiteral: nil. methodBuilder send: #==. methodBuilder jumpAheadTo: #notNilCase if: false. self visitInlinedBlockNode: args first. methodBuilder jumpAheadTo: #end. methodBuilder jumpAheadTarget: #notNilCase. self visitInlinedBlockNode: args last. methodBuilder jumpAheadTarget: #end.! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'nice 5/1/2013 21:01'! emitIfNotNil: aMessageNode self shouldBeSentToValueOrEffectTranslator! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'ClementBera 7/10/2013 14:33'! emitIfTrueIfFalse: aMessageNode self emitIf: aMessageNode boolean: false! ! !OCASTTranslator methodsFor: 'inline messages' stamp: 'MarcusDenker 9/20/2013 15:04'! emitToByDo: aMessageNode | step | step := aMessageNode arguments second. step isLiteralNode ifFalse: [self error: 'should not have been inlined']. step := step value. self emitToDo: aMessageNode step: step! ! !OCASTTranslator class methodsFor: 'initialize' stamp: 'ClementBera 11/26/2013 13:17'! initialize "OCASTTranslator initialize" super initialize. OptimizedMessages := { #caseOf: -> #emitCaseOf: . #caseOf:otherwise: -> #emitCaseOfOtherwise: . #ifFalse: -> #emitIfFalse: . #ifFalse:ifTrue: -> #emitIfFalseIfTrue: . #ifNil: -> #emitIfNil: . #ifNil:ifNotNil: -> #emitIfNilIfNotNil: . #ifNotNil: -> #emitIfNotNil: . #ifNotNil:ifNil: -> #emitIfNotNilIfNil: . #ifTrue: -> #emitIfTrue: . #ifTrue:ifFalse: -> #emitIfTrueIfFalse: . #or: -> #emitOr: . #and: -> #emitAnd: . #timesRepeat: -> #emitTimesRepeat: . #to:by:do: -> #emitToByDo: . #to:do: -> #emitToDo: . #whileFalse: -> #emitWhileFalse: . #whileTrue: -> #emitWhileTrue: . #whileFalse -> #emitWhileFalse: . #whileTrue -> #emitWhileTrue: } asDictionary! ! !OCASTTranslatorForEffect commentStamp: 'ajh 3/24/2003 22:20'! I override some methods in my super to generate instructions for effect only.! !OCASTTranslatorForEffect methodsFor: 'inline messages' stamp: 'MarcusDenker 4/11/2013 15:12'! emitIfFalse: aMessageNode valueTranslator visitNode: aMessageNode receiver. methodBuilder jumpAheadTo: #else if: true. self visitInlinedBlockNode: aMessageNode arguments first. methodBuilder jumpAheadTarget: #else. ! ! !OCASTTranslatorForEffect methodsFor: 'visitor-double dispatching' stamp: 'MarcusDenker 10/14/2010 15:50'! emitMessageNode: aMessageNode super emitMessageNode: aMessageNode. methodBuilder popTop. ! ! !OCASTTranslatorForEffect methodsFor: 'visitor-double dispatching' stamp: 'nice 5/2/2013 00:21'! visitSequenceNode: aSequenceNode aSequenceNode statements do: [:each | self visitNode: each].! ! !OCASTTranslatorForEffect methodsFor: 'visitor-double dispatching' stamp: 'ClementBera 10/22/2013 13:09'! visitArrayNode: anArrayNode "An arrayNode may have side effect, for example: '{self foo}'. So we cannot just generate nothing for this node." super visitArrayNode: anArrayNode. methodBuilder popTop. ! ! !OCASTTranslatorForEffect methodsFor: 'inline messages' stamp: 'nice 5/1/2013 15:58'! emitOr: aMessageNode self emitIfFalse: aMessageNode! ! !OCASTTranslatorForEffect methodsFor: 'visitor-double dispatching' stamp: 'ClementBera 10/22/2013 13:04'! visitBlockNode: aBlockNode "A block has no side effect, so a block translated for effect just doesn't generate anything" ! ! !OCASTTranslatorForEffect methodsFor: 'visitor-double dispatching' stamp: 'MarcusDenker 4/17/2013 14:56'! visitVariableNode: aVariableNode "when visiting a variable for effect, we could push it and then pop it, but we do nothing"! ! !OCASTTranslatorForEffect methodsFor: 'inline messages' stamp: 'MarcusDenker 4/11/2013 15:12'! emitIfTrue: aMessageNode valueTranslator visitNode: aMessageNode receiver. methodBuilder jumpAheadTo: #else if: false. self visitInlinedBlockNode: aMessageNode arguments first. methodBuilder jumpAheadTarget: #else.! ! !OCASTTranslatorForEffect methodsFor: 'visitor-double dispatching' stamp: 'CamilleTeruel 3/7/2014 11:17'! visitLiteralArrayNode: aLiteralNode "when visiting a literal array for effect, we could push it and then pop it, but we do nothing"! ! !OCASTTranslatorForEffect methodsFor: 'visitor-double dispatching' stamp: 'MarcusDenker 4/11/2013 15:12'! visitAssignmentNode: anAssignmentNode super visitAssignmentNode: anAssignmentNode . methodBuilder popTop. ! ! !OCASTTranslatorForEffect methodsFor: 'inline messages' stamp: 'nice 5/1/2013 15:58'! emitAnd: aMessageNode self emitIfTrue: aMessageNode! ! !OCASTTranslatorForEffect methodsFor: 'visitor-double dispatching' stamp: 'MarcusDenker 4/17/2013 14:59'! visitLiteralNode: aLiteralNode "when visiting a literal for effect, we could push it and then pop it, but we do nothing"! ! !OCASTTranslatorForEffect methodsFor: 'inline messages' stamp: 'MarcusDenker 5/22/2013 16:50'! emitIfNotNil: aMessageNode | args | valueTranslator visitNode: aMessageNode receiver. args := aMessageNode arguments. args first arguments ifNotEmpty: [ args first arguments first binding emitStore: methodBuilder ]. methodBuilder pushLiteral: nil. methodBuilder send: #==. methodBuilder jumpAheadTo: #end if: true. self visitInlinedBlockNode: args first. methodBuilder jumpAheadTarget: #end. ! ! !OCASTTranslatorForValue commentStamp: 'ajh 3/24/2003 22:20'! I override some methods in my super to generate instructions for effect and value only.! !OCASTTranslatorForValue methodsFor: 'inline messages' stamp: 'nice 5/1/2013 23:02'! emitIfFalse: aMessageNode self visitNode: aMessageNode receiver. methodBuilder jumpAheadTo: #false if: false. methodBuilder pushLiteral: nil. methodBuilder jumpAheadTo: #end. methodBuilder jumpAheadTarget: #false. self visitInlinedBlockNode: aMessageNode arguments first. methodBuilder jumpAheadTarget: #end.! ! !OCASTTranslatorForValue methodsFor: 'inline messages' stamp: 'MarcusDenker 6/23/2012 12:09'! emitWhileTrue: aMessageNode super emitWhileTrue: aMessageNode. methodBuilder pushLiteral: nil. ! ! !OCASTTranslatorForValue methodsFor: 'inline messages' stamp: 'MarcusDenker 6/23/2012 12:09'! emitWhileFalse: aMessageNode super emitWhileFalse: aMessageNode. methodBuilder pushLiteral: nil. ! ! !OCASTTranslatorForValue methodsFor: 'inline messages' stamp: 'nice 5/1/2013 23:03'! emitAnd: aMessageNode self visitNode: aMessageNode receiver. methodBuilder pushDup; jumpAheadTo: #end if: false; popTop. self visitInlinedBlockNode: aMessageNode arguments first. methodBuilder jumpAheadTarget: #end.! ! !OCASTTranslatorForValue methodsFor: 'visitor-double dispatching' stamp: 'nice 5/2/2013 00:21'! visitSequenceNode: aSequenceNode | statements | statements := aSequenceNode statements. statements ifEmpty: [ methodBuilder pushLiteral: nil. ^self]. statements allButLastDo: [:each | effectTranslator visitNode: each]. self visitNode: statements last.! ! !OCASTTranslatorForValue methodsFor: 'inline messages' stamp: 'nice 5/1/2013 23:03'! emitOr: aMessageNode self visitNode: aMessageNode receiver. methodBuilder pushDup; jumpAheadTo: #end if: true; popTop. self visitInlinedBlockNode: aMessageNode arguments first. methodBuilder jumpAheadTarget: #end.! ! !OCASTTranslatorForValue methodsFor: 'inline messages' stamp: 'MarcusDenker 6/11/2013 15:52'! emitIfNotNil: aMessageNode | args | self visitNode: aMessageNode receiver. args := aMessageNode arguments. args first arguments ifNotEmpty: [ args first arguments first binding emitStore: methodBuilder ]. methodBuilder pushDup. methodBuilder pushLiteral: nil. methodBuilder send: #==. methodBuilder jumpAheadTo: #end if: true. methodBuilder popTop. self visitInlinedBlockNode: args first. methodBuilder jumpAheadTarget: #end.! ! !OCASTTranslatorForValue methodsFor: 'inline messages' stamp: 'nice 5/1/2013 23:03'! emitIfTrue: aMessageNode self visitNode: aMessageNode receiver. methodBuilder jumpAheadTo: #else if: false. self visitInlinedBlockNode: aMessageNode arguments first. methodBuilder jumpAheadTo: #end. methodBuilder jumpAheadTarget: #else. methodBuilder pushLiteral: nil. methodBuilder jumpAheadTarget: #end.! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleToDoInsideTemp | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleToDoInsideTemp) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoInsideTemp. ! ! !OCASTTranslatorTest methodsFor: 'testing - misc' stamp: 'ClementBera 6/28/2013 13:38'! testPushBigArray | ast ir aCompiledMethod instance | ast := (OCOpalExamples>>#examplePushBigArray) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new . aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance examplePushBigArray.! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'ClementBera 5/21/2013 14:54'! testExampleBlockExternal | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleBlockExternal) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockExternal. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleIfTrueAssign | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleIfTrueAssign) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = 1. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockEmpty | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockEmpty) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockEmpty . ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleToDoOutsideTemp | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleToDoOutsideTemp) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoOutsideTemp. ! ! !OCASTTranslatorTest methodsFor: 'testing - simple' stamp: 'MarcusDenker 6/29/2012 16:16'! testNewArray | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleNewArray) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleNewArray. ! ! !OCASTTranslatorTest methodsFor: 'testing - primitives' stamp: 'MarcusDenler 12/10/2012 16:20'! testExamplePrimitiveErrorCode | method ast ir newMethod | method := (OCOpalExamples>>#examplePrimitiveErrorCode). ast := method parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. newMethod := ir compiledMethod. self assert: method primitive = newMethod primitive. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockReturn | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockReturn) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockReturn. ! ! !OCASTTranslatorTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleThisContext | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleThisContext) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: OCOpalExamples new exampleThisContext isContext. self assert: ((OCOpalExamples>>#exampleThisContext) valueWithReceiver: instance arguments: #()) isContext. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) isContext. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleBlockExternal2 | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleBlockExternal2) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockExternal2. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleBlockInternal | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleBlockInternal) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockInternal. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlock | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlock) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) value = instance exampleSimpleBlock value. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockLocal | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockLocal) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockLocal . ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockLocalIfNested | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockLocalIfNested) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockLocalIfNested. ! ! !OCASTTranslatorTest methodsFor: 'testing - misc' stamp: 'MarcusDenker 11/20/2012 16:29'! testTodoValue | ast ir aCompiledMethod instance | ast := (OCOpalExamples>>#exampleToDoValue) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new . aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoValue.! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleBlockMethodArgument | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleBlockMethodArgument:) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #(2)) = 4. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleIfNotNilArg | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleIfNotNilArg) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleIfNotNilArg. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleIfTrue | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleIfTrue) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = 'result'. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleMethodTempInNestedBlock | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleMethodTempInNestedBlock) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: ((aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleMethodTempInNestedBlock) ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockArgument4 | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockArgument4) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockArgument4 . ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockNested | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockNested) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockNested. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleToDoArgument | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleToDoArgument) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoArgument. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleToDoInsideTempNotInlined | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleToDoInsideTempNotInlined) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoInsideTempNotInlined. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleWhileModificationBeforeNotInlined | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleWhileModificationBeforeNotInlined) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleWhileModificationBeforeNotInlined. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleBlockNested | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleBlockNested) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockNested. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleWhileModificationBefore | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleWhileModificationBefore) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: OCOpalExamples new arguments: #()) = instance exampleWhileModificationBefore. ! ! !OCASTTranslatorTest methodsFor: 'testing - misc' stamp: 'MarcusDenker 6/29/2012 16:16'! testPushArray | ast ir aCompiledMethod instance | ast := (OCOpalExamples>>#examplePushArray) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new . aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance examplePushArray.! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockArgument5 | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockArgument5) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockArgument5 . ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleWhileModificationAfterNotInlined | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleWhileModificationAfterNotInlined) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleWhileModificationAfterNotInlined. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'ClementBera 7/26/2013 14:25'! testExampleTimesRepeatEffect | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleTimesRepeatEffect) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleTimesRepeatEffect. ! ! !OCASTTranslatorTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSuper | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSuper) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSuper. ! ! !OCASTTranslatorTest methodsFor: 'testing - simple' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleIfFalseIfTrue | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleIfFalseIfTrue) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleIfFalseIfTrue. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'ClementBera 7/26/2013 14:26'! testExampleTimesRepeatValue | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleTimesRepeatValue) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleTimesRepeatValue. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 12/7/2012 15:32'! testExampleToDoArgumentLimitIsExpression | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleToDoArgumentLimitIsExpression) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoArgumentLimitIsExpression. ! ! !OCASTTranslatorTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 6/29/2012 16:16'! testiVar | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleiVar) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleiVar. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleBlockExternalNested | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleBlockExternalNested) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockExternalNested. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleBlockExternalArg | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleBlockExternalArg) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockExternalArg. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleWhileWithTemp | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleWhileWithTemp) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleWhileWithTemp. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleWhileWithTempNotInlined | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleWhileWithTempNotInlined) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleWhileWithTempNotInlined. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleToDoArgumentNotInlined | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleToDoArgumentNotInlined) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoArgumentNotInlined. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 11/20/2012 15:47'! testExampleBlockArgument | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleBlockArgument) parseTree. ir := ast doSemanticAnalysis ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockArgument. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockArgument3 | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockArgument3) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockArgument3. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleIfNotNilReturnNil | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleIfNotNilReturnNil) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleIfNotNilReturnNil. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockiVar | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockiVar) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: ((aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockiVar) ! ! !OCASTTranslatorTest methodsFor: 'testing - simple' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleIfFalse | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleIfFalse) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleIfFalse. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleMethodWithOptimizedBlocksA | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleMethodWithOptimizedBlocksA) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new . aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleMethodWithOptimizedBlocksA. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockArgument1 | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockArgument1) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockArgument1. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockArgument2 | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockArgument2) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockArgument2. ! ! !OCASTTranslatorTest methodsFor: 'testing - misc' stamp: 'MarcusDenker 12/7/2012 15:51'! testTodoValueLimitExpression | ast ir aCompiledMethod instance | ast := (OCOpalExamples>>#exampleToDoValueLimitExpression) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new . aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoValueLimitExpression.! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockLocalIf | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockLocalIf) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockLocalIf. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleToDoOutsideTempNotInlined | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleToDoOutsideTempNotInlined) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoOutsideTempNotInlined. ! ! !OCASTTranslatorTest methodsFor: 'testing - simple' stamp: 'MarcusDenker 6/29/2012 16:16'! testReturn1 | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleReturn1) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleReturn1. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleInlineBlockCollectionLR3 | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleInlineBlockCollectionLR3) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = (2 to: 12) asArray. ! ! !OCASTTranslatorTest methodsFor: 'testing - variables' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSelf | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSelf) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSelf. ! ! !OCASTTranslatorTest methodsFor: 'testing - primitives' stamp: 'MarcusDenler 12/10/2012 15:27'! testExamplePrimitiveErrorCodeModule | method ast ir newMethod | method := (OCOpalExamples>>#examplePrimitiveErrorCodeModule). ast := method parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. newMethod := ir compiledMethod. self assert: method primitive = newMethod primitive. self assert: method pragmas printString = newMethod pragmas printString ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleIfTrueIfFalse | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleIfTrueIfFalse) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = 'result'. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleNestedBlockScoping | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleNestedBlockScoping) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleNestedBlockScoping. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenker 6/29/2012 16:16'! testExampleSimpleBlockLocalWhile | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#exampleSimpleBlockLocalWhile) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockLocalWhile. ! ! !OCASTTranslatorTest methodsFor: 'testing - simple' stamp: 'MarcusDenker 6/29/2012 16:16'! testOnePlusTwo | ast ir aCompiledMethod instance | ast := (OCOpalExamples>>#exampleReturn1plus2) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new. aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleReturn1plus2. ! ! !OCASTTranslatorTest methodsFor: 'testing - blocks - optimized' stamp: 'MarcusDenler 12/11/2012 15:03'! testExampleOptimizedBlockWrittenAfterClosedOverCase1 | ir ast aCompiledMethod instance | ast := (OCOpalExamples>>#optimizedBlockWrittenAfterClosedOverCase1) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new . aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance optimizedBlockWrittenAfterClosedOverCase1. ! ! !OCASTTranslatorTest methodsFor: 'testing - simple' stamp: 'MarcusDenker 6/29/2012 16:16'! testEmptyMethod | ast ir aCompiledMethod instance | ast := (OCOpalExamples>>#exampleEmptyMethod) parseTree. ir := (ast doSemanticAnalysisIn: OCOpalExamples) ir. instance := OCOpalExamples new . aCompiledMethod := ir compiledMethod. self assert: (aCompiledMethod valueWithReceiver: instance arguments: #()) = instance exampleEmptyMethod. ! ! !OCAbstractLocalVariable commentStamp: ''! I am an argument or temporary variable of a method or block. index is not the index in the bytecode but just used for sorting (see tempVars). to be fixed...! !OCAbstractLocalVariable methodsFor: 'read/write usage' stamp: 'MarcusDenker 10/16/2013 15:28'! isUninitialized usage ifNil: [ ^true ]. self isArg ifTrue: [ ^false ]. "arguments are never unitialized" ^self isRead! ! !OCAbstractLocalVariable methodsFor: 'initializing' stamp: 'jorgeRessia 11/14/2009 10:56'! name: string name := string! ! !OCAbstractLocalVariable methodsFor: 'testing' stamp: 'ms 7/31/2007 00:42'! isLocal ^true! ! !OCAbstractLocalVariable methodsFor: 'initializing' stamp: 'MarcusDenker 11/16/2012 11:30'! index: n index := n! ! !OCAbstractLocalVariable methodsFor: 'read/write usage' stamp: 'MarcusDenker 9/5/2010 20:13'! isArg ^usage = #arg! ! !OCAbstractLocalVariable methodsFor: 'read/write usage' stamp: 'MarcusDenker 9/5/2010 20:13'! markArg usage := #arg! ! !OCAbstractLocalVariable methodsFor: 'accessing' stamp: 'ajh 6/23/2004 22:51'! name ^ name! ! !OCAbstractLocalVariable methodsFor: 'accessing' stamp: 'MarcusDenker 11/16/2012 11:30'! index ^ index! ! !OCAbstractMethodScope commentStamp: ''! I am an abstract superclass for Block and Method scopes! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'MarcusDenker 12/17/2012 15:18'! allTempNames ^self allTemps collect: #name.! ! !OCAbstractMethodScope methodsFor: 'initializing' stamp: 'MarcusDenker 9/9/2010 17:25'! id: int id := int! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'MarcusDenker 9/22/2010 10:51'! addCopyingTempToAllScopesUpToDefVector: aName (self hasCopyingTempNamed: aName) ifFalse: [self addCopyingTempNamed: aName]. self tempVectorName = aName ifTrue: [^ self]. ^ self outerScope addCopyingTempToAllScopesUpToDefVector: aName.! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'MarcusDenker 7/2/2012 10:16'! addTemp: name ^ tempVars add: (OCTempVariable new name: name; index: tempVars size; scope: self; yourself)! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'JorgeRessia 9/7/2010 20:24'! copiedVars ^ copiedVars! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'JorgeRessia 9/7/2010 20:25'! tempVector ^ tempVector ! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'MarcusDenker 12/18/2012 16:43'! addVectorTemp: aTemp ^ tempVector add: (OCVectorTempVariable new name: aTemp name; vectorName: self tempVectorName; index: tempVector size; scope: self; usage: aTemp usage; escaping: aTemp escaping; yourself)! ! !OCAbstractMethodScope methodsFor: 'scope' stamp: 'ClementBera 8/5/2013 10:49'! outerOffsetTo: aScope "return how many scopes up from me aScope is. We ignore optimized scopes so the resulting offset maps to contexts" | offset scope | offset := 0. scope := self. [scope == aScope] whileFalse: [ scope isOptimizedBlockScope ifTrue: [scope := scope outerNotOptimizedScope] ifFalse: [ offset := offset + 1. scope isInstanceScope ifTrue: [^0]. scope := scope outerScope ] ]. ^offset. ! ! !OCAbstractMethodScope methodsFor: 'scope' stamp: 'MarcusDenker 10/7/2010 10:05'! newOptimizedBlockScope: int ^ OCOptimizedBlockScope new outerScope: self; id: int; yourself.! ! !OCAbstractMethodScope methodsFor: 'scope' stamp: 'ajh 7/8/2004 14:19'! popScope "Propogate free var usages to their outer vars, then return outer scope" ^ self outerScope! ! !OCAbstractMethodScope methodsFor: 'initialization' stamp: 'MarcusDenker 7/2/2012 10:16'! initialize tempVars := OCKeyedSet keyBlock: [:var | var name]. copiedVars := OCKeyedSet keyBlock: [:var | var name]. tempVector := OCKeyedSet keyBlock: [:var | var name]. id := 0. thisContextVar := OCSpecialVariable new name: 'thisContext'; scope: self; yourself. ! ! !OCAbstractMethodScope methodsFor: 'printing' stamp: 'ajh 3/20/2003 11:29'! printOn: stream super printOn: stream. stream space. self scopeLevel printOn: stream. ! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'ClementBera 7/9/2013 18:05'! allTemps "return all temps defined, even the ones in the outer scope that are not used in the current. This includes the arguments We do not need to care about shadowed temps as temp shadowing is not allowed." | temps | temps := OrderedCollection new. self outerScope allTemps do: [ :var | (self localTempNames includes: var name) ifFalse: [ temps add: var.] ]. temps addAll: self localTemps. ^temps asArray. ! ! !OCAbstractMethodScope methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 6/5/2013 13:53'! lookupVarForDeclaration: name tempVars at: name ifPresent: [:v | ^ v]. name = 'thisContext' ifTrue: [^ thisContextVar]. ^self outerScope lookupVarForDeclaration: name ! ! !OCAbstractMethodScope methodsFor: 'testing' stamp: ''! isMethodScope ^false! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'MarcusDenker 10/14/2010 13:46'! tempVarNames ^ self tempVars collect: [:each| each name]! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'MarcusDenker 12/17/2012 15:14'! localTempNames ^self localTemps collect: [:each | each name]! ! !OCAbstractMethodScope methodsFor: 'lookup' stamp: 'MarcusDenker 9/22/2010 10:39'! lookupVar: name copiedVars at: name ifPresent: [:v | ^ v]. tempVector at: name ifPresent: [:v | ^ v]. tempVars at: name ifPresent: [:v | ^ v]. name = 'thisContext' ifTrue: [^ thisContextVar]. ^self outerScope lookupVar: name ! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'MarcusDenker 11/15/2012 16:08'! tempVectorName "the name of the tempVector is not a valid name of a temp variable This way we avoid name clashes " ^'0vector', id asString! ! !OCAbstractMethodScope methodsFor: 'testing' stamp: 'MarcusDenker 10/7/2010 10:07'! isBlockScope ^false! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'MarcusDenker 9/10/2010 08:46'! hasCopyingTempNamed: name ^self copiedVars anySatisfy: [:each | each name = name]! ! !OCAbstractMethodScope methodsFor: 'scope' stamp: 'MarcusDenker 10/7/2010 10:06'! newBlockScope: int ^ OCBlockScope new outerScope: self; id: int; yourself.! ! !OCAbstractMethodScope methodsFor: 'scope' stamp: 'MarcusDenker 5/18/2013 16:40'! outerNotOptimizedScope ^self! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'ClementBera 5/21/2013 14:52'! addCopyingTemp: aTempVar ^ copiedVars add: (OCCopyingTempVariable new originalVar: aTempVar originalVar; name: aTempVar name; index: tempVars size; escaping: aTempVar escaping; usage: aTempVar usage; scope: self; yourself)! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'ajh 6/25/2004 22:23'! tempVars ^ tempVars asSortedCollection: [:x :y | x index <= y index]! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'MarcusDenker 9/22/2010 11:10'! addCopyingTempToAllScopesUpToDefTemp: aVar (self hasCopyingTempNamed: aVar name) ifFalse: [self addCopyingTemp: aVar]. tempVars at: aVar name ifPresent: [:v | ^ self]. ^ self outerScope addCopyingTempToAllScopesUpToDefTemp: aVar. ! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'ClementBera 7/9/2013 18:10'! localTemps "all temps accessed in the context... for tempVectors, it takes all the vars even those not used here" | localVars | localVars := OrderedCollection new. self copiedVars do: [:var | var isStoringTempVector ifTrue: [var tempVectorForTempStoringIt do: [:tempVectorVars | localVars add: tempVectorVars]] ]. self tempVars do: [:var | localVars add: var]. ^localVars asArray! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'MarcusDenker 9/22/2010 11:07'! moveToVectorTemp: aTempVar self addVectorTemp: aTempVar. self removeTemp: aTempVar. ! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'ClementBera 5/21/2013 14:48'! addCopyingTempNamed: name ^ copiedVars add: (OCCopyingTempVariable new name: name; index: tempVars size; scope: self; yourself)! ! !OCAbstractMethodScope methodsFor: 'temp vars' stamp: 'ajh 6/25/2004 22:05'! removeTemp: tempVar tempVars remove: tempVar. tempVars do: [:var | var index > tempVar index ifTrue: [ var index: var index - 1]]. ! ! !OCAbstractScope commentStamp: 'ajh 3/24/2003 21:53'! I am a symbol table where variable names are associated with SemVars. Each context (method/closure) get a fresh scope that inherits from its outer scope.! !OCAbstractScope methodsFor: 'testing' stamp: 'JorgeRessia 9/23/2010 19:15'! isInstanceScope ^ false! ! !OCAbstractScope methodsFor: 'testing' stamp: 'JorgeRessia 9/23/2010 19:15'! isInsideOptimizedLoop ^ false! ! !OCAbstractScope methodsFor: 'lookup' stamp: 'ajh 3/11/2003 20:19'! lookupVar: name "subclass responsibility" ^ self outerScope lookupVar: name! ! !OCAbstractScope methodsFor: 'accessing' stamp: 'MarcusDenker 12/18/2012 13:39'! node ^node! ! !OCAbstractScope methodsFor: 'accessing' stamp: 'MarcusDenker 12/18/2012 13:32'! node: aNode node := aNode! ! !OCAbstractScope methodsFor: 'decompiling' stamp: 'ms 7/11/2007 11:16'! instanceScope ^self outerScope instanceScope! ! !OCAbstractScope methodsFor: 'levels' stamp: 'ajh 3/20/2003 11:27'! scopeLevel outerScope ifNil: [^ 0]. ^ outerScope scopeLevel + 1! ! !OCAbstractScope methodsFor: 'lookup' stamp: 'ajh 2/25/2003 22:41'! lookupSelector: name Symbol hasInterned: name ifTrue: [ :sym | ^ sym]. ^ nil! ! !OCAbstractScope methodsFor: 'levels' stamp: 'ajh 2/26/2003 13:44'! outerScope ^ outerScope! ! !OCAbstractScope methodsFor: 'initializing' stamp: 'ajh 2/26/2003 13:43'! outerScope: aSemScope outerScope := aSemScope! ! !OCAbstractScope methodsFor: 'lookup' stamp: 'MarcusDenker 6/5/2013 13:53'! lookupVarForDeclaration: name "subclass responsibility" ^ self outerScope lookupVarForDeclaration: name! ! !OCAbstractScope methodsFor: 'testing' stamp: 'MarcusDenker 12/20/2012 14:38'! isOptimizedBlockScope ^false! ! !OCAbstractScope methodsFor: 'lookup' stamp: 'ajh 2/25/2003 22:40'! possibleSelectorsFor: string ^ Symbol possibleSelectorsFor: string! ! !OCAbstractVariable commentStamp: ''! I am an entry in a Scope that gets associated with variable nodes of the same name. ! !OCAbstractVariable methodsFor: 'read/write usage' stamp: 'MarcusDenker 4/9/2013 10:39'! isUninitialized ^ false! ! !OCAbstractVariable methodsFor: 'emitting' stamp: 'JorgeRessia 4/19/2010 09:35'! emitStore: methodBuilder self subclassResponsibility! ! !OCAbstractVariable methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 5/22/2013 15:40'! specialCommands ^{}.! ! !OCAbstractVariable methodsFor: 'testing' stamp: 'ms 7/31/2007 00:42'! isLocal ^false! ! !OCAbstractVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/1/2010 14:44'! isSelf ^false! ! !OCAbstractVariable methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:55'! isSpecialVariable ^false! ! !OCAbstractVariable methodsFor: 'testing' stamp: 'MarcusDenker 8/27/2010 11:16'! isInstance ^false ! ! !OCAbstractVariable methodsFor: 'testing' stamp: 'ajh 7/8/2004 16:25'! isGlobal ^ false! ! !OCAbstractVariable methodsFor: 'read/write usage' stamp: 'MarcusDenker 10/16/2013 15:25'! isRead ^usage = #read or: [ usage = #arg ] "we treat arguments as read by default" ! ! !OCAbstractVariable methodsFor: 'accessing' stamp: 'ClementBera 5/21/2013 14:52'! originalVar ^ self! ! !OCAbstractVariable methodsFor: 'testing' stamp: 'MarcusDenker 6/14/2013 15:42'! isUndeclared ^ false! ! !OCAbstractVariable methodsFor: 'emitting' stamp: 'JorgeRessia 4/19/2010 09:35'! emitValue: methodBuilder self subclassResponsibility! ! !OCAbstractVariable methodsFor: 'printing' stamp: 'ajh 2/27/2003 00:38'! printOn: stream stream nextPutAll: self name! ! !OCAbstractVariable methodsFor: 'testing' stamp: 'ajh 3/18/2003 11:13'! isTemp ^ false! ! !OCAbstractVariable methodsFor: 'accessing' stamp: 'ajh 6/23/2004 22:52'! scope ^ scope! ! !OCAbstractVariable methodsFor: 'read/write usage' stamp: 'MarcusDenker 5/18/2011 15:54'! isWrite ^usage = #write ! ! !OCAbstractVariable methodsFor: 'accessing' stamp: 'ajh 3/16/2003 20:08'! asString ^ self name! ! !OCAbstractVariable methodsFor: 'accessing' stamp: 'MarcusDenker 9/22/2010 11:05'! usage: anObject usage := anObject! ! !OCAbstractVariable methodsFor: 'accessing' stamp: 'ClementBera 5/21/2013 14:53'! definingScope ^ scope! ! !OCAbstractVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/20/2013 13:28'! isLiteralVariable ^false! ! !OCAbstractVariable methodsFor: 'accessing' stamp: 'MarcusDenker 6/13/2013 14:59'! isArg ^false! ! !OCAbstractVariable methodsFor: 'read/write usage' stamp: 'MarcusDenker 10/16/2013 15:25'! markRead "reading does not change a #write, nor an #arg" usage ifNil: [usage := #read]! ! !OCAbstractVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/1/2010 15:30'! isSuper ^false! ! !OCAbstractVariable methodsFor: 'read/write usage' stamp: 'MarcusDenker 10/16/2013 15:27'! isUnused "when the var is never read or written, it is not used. Note: we have a special #arg use which means arguments are never unused" ^ usage isNil! ! !OCAbstractVariable methodsFor: 'initializing' stamp: 'ajh 7/8/2004 16:17'! scope: aLexicalScope scope := aLexicalScope! ! !OCAbstractVariable methodsFor: 'accessing' stamp: 'MarcusDenker 9/5/2010 20:13'! usage ^ usage! ! !OCAbstractVariable methodsFor: 'read/write usage' stamp: 'MarcusDenker 10/16/2013 15:26'! markWrite "write is the strongest use: a read is turned into a write" usage := #write.! ! !OCAbstractVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/21/2010 16:02'! isRemote ^false! ! !OCAbstractVariable methodsFor: 'accessing' stamp: 'ajh 6/23/2004 22:47'! name ^ self subclassResponsibility! ! !OCArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:35'! testByteArrayEmpty self class compile: 'array ^ #[]'. self assert: (self array isKindOf: ByteArray). self assert: (self array isEmpty)! ! !OCArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:32'! testByteArrayRange self class compile: 'array ^ #[ 0 255 ]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 2). self assert: (self array first = 0). self assert: (self array last = 255)! ! !OCArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:45'! testByteArrayLong self class compile: 'array ^ #[ ' , ((0 to: 255) inject: ' ' into: [ :r :e | r , ' ' , e asString ]) , ' ]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 256). 0 to: 255 do: [ :index | self assert: (self array at: index + 1) = index ]! ! !OCArrayLiteralTest methodsFor: 'initialization' stamp: 'avi 2/16/2004 21:09'! tearDown self class removeSelector: #array! ! !OCArrayLiteralTest methodsFor: 'tests' stamp: 'Henrik Sperre Johansen 3/23/2009 13:55'! testByteArrayWithinArray self class compile: 'array ^ #( #[1] #[2] )'. self assert: (self array isKindOf: Array). self assert: (self array size = 2). self assert: (self array first isKindOf: ByteArray). self assert: (self array first first = 1). self assert: (self array last isKindOf: ByteArray). self assert: (self array last first = 2) ! ! !OCArrayLiteralTest methodsFor: 'running' stamp: 'MarcusDenker 5/13/2013 13:21'! runCase SystemAnnouncer uniqueInstance suspendAllWhile: [ super runCase ] ! ! !OCArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:36'! testByteArrayLiteral self class compile: 'array ^ #[ 1 2 3 4 ]'. self assert: (self array = self array). self assert: (self array == self array)! ! !OCArrayLiteralTest methodsFor: 'tests' stamp: 'lr 1/29/2009 20:34'! testByteArrayBase self class compile: 'array ^ #[2r1010 8r333 16rFF]'. self assert: (self array isKindOf: ByteArray). self assert: (self array size = 3). self assert: (self array first = 10). self assert: (self array second = 219). self assert: (self array last = 255) ! ! !OCArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:09'! testSymbols self class compile: 'array ^ #(#nil #true #false #''nil'' #''true'' #''false'')'. self assert: self array = {#nil. #true. #false. #nil. #true. #false}.! ! !OCArrayLiteralTest methodsFor: 'tests' stamp: 'avi 2/16/2004 21:08'! testReservedIdentifiers self class compile: 'array ^ #(nil true false)'. self assert: self array = {nil. true. false}.! ! !OCBC2IR2BCSymbolic methodsFor: 'tests' stamp: 'MarcusDenker 5/15/2013 16:52'! testExampleInlineBlockCollectionLR3 | aMethod newMethod | aMethod := OCOpalExamples>>#exampleInlineBlockCollectionLR3. newMethod := (aMethod ir) compiledMethodWith: aMethod trailer. self assert: aMethod abstractSymbolic = newMethod abstractSymbolic.! ! !OCBC2IR2BCSymbolic methodsFor: 'tests' stamp: 'MarcusDenker 6/6/2012 17:46'! testExamplePrimitiveErrorCode | aMethod newMethod | aMethod := OCOpalExamples>>#examplePrimitiveErrorCode. newMethod := (aMethod ir) compiledMethodWith: aMethod trailer. self assert: aMethod abstractSymbolic = newMethod abstractSymbolic.! ! !OCBlockScope commentStamp: ''! I modelt the scope of a block! !OCBlockScope methodsFor: 'accessing' stamp: 'MarcusDenker 10/14/2010 10:13'! inComingCopiedVars ^ copiedVars select: [:each | outerScope copiedVars includes: each].! ! !OCBlockScope methodsFor: 'testing' stamp: 'JorgeRessia 9/7/2010 18:39'! isBlockScope ^ true! ! !OCBlockScope methodsFor: 'testing' stamp: 'ClementBera 8/5/2013 11:04'! hasEscapingVars ^ (copiedVars isEmpty & tempVector isEmpty) not! ! !OCBlockScope methodsFor: 'testing' stamp: 'MarcusDenker 12/14/2012 11:51'! isInsideOptimizedLoop ^ self outerScope isInsideOptimizedLoop! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-misc' stamp: 'MarcusDenker 11/20/2012 16:47'! testExamplePushArray | ir method newMethod instance | method := (OCOpalExamples>>#examplePushArray) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance examplePushArray! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:50'! testExampleToDoInsideTemp | ir method newMethod instance | method := (OCOpalExamples>>#exampleToDoInsideTemp) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoInsideTemp! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:42'! testExampleBlockExternal | ir method newMethod instance | method := (OCOpalExamples>>#exampleBlockExternal) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockExternal. ! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:45'! testExampleIfIfNotNilReturnNil | ir method newMethod instance | method := (OCOpalExamples>>#exampleIfNotNilReturnNil) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleIfNotNilReturnNil! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:49'! testExampleSimpleBlockEmpty | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockEmpty) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockEmpty! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-simple' stamp: 'MarcusDenker 11/20/2012 16:47'! testExampleReturn1 | ir method newMethod instance | method := (OCOpalExamples>>#exampleReturn1) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleReturn1! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:50'! testExampleToDoOutsideTemp | ir method newMethod instance | method := (OCOpalExamples>>#exampleToDoOutsideTemp) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoOutsideTemp! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-variables' stamp: 'MarcusDenker 11/20/2012 16:50'! testExampleThisContext | ir method newMethod instance | method := (OCOpalExamples>>#exampleThisContext) parseTree generate. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) isContext! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:49'! testExampleSimpleBlockReturn | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockReturn) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockReturn! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:43'! testExampleBlockExternal2 | ir method newMethod instance | method := (OCOpalExamples>>#exampleBlockExternal2) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockExternal2. ! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:43'! testExampleBlockInternal | ir method newMethod instance | method := (OCOpalExamples>>#exampleBlockInternal) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockInternal.! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:48'! testExampleSimpleBlock | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlock) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) value = instance exampleSimpleBlock value! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:49'! testExampleSimpleBlockLocal | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockLocal) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockLocal! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:45'! testExampleIfNotNilArg | ir method newMethod instance | method := (OCOpalExamples>>#exampleIfNotNilArg) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleIfNotNilArg.! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-simple' stamp: 'MarcusDenker 11/20/2012 16:45'! testExampleEmptyMethod | ir method newMethod instance | method := (OCOpalExamples>>#exampleEmptyMethod) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleEmptyMethod.! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:46'! testExampleIfTrue | ir method newMethod instance | method := (OCOpalExamples>>#exampleIfTrue) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleIfTrue! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:47'! testExampleMethodTempInNestedBlock | ir method newMethod instance | method := (OCOpalExamples>>#exampleMethodTempInNestedBlock) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleMethodTempInNestedBlock! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:48'! testExampleSimpleBlockArgument4 | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockArgument4) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockArgument4! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:49'! testExampleSimpleBlockNested | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockNested) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockNested! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:50'! testExampleToDoArgument | ir method newMethod instance | method := (OCOpalExamples>>#exampleToDoArgument) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoArgument! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:50'! testExampleToDoInsideTempNotInlined | ir method newMethod instance | method := (OCOpalExamples>>#exampleToDoInsideTempNotInlined) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoInsideTempNotInlined! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:44'! testExampleWhileModificationBeforeNotInlined | ir method newMethod instance | method := (OCOpalExamples>>#exampleWhileModificationBeforeNotInlined) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleWhileModificationBeforeNotInlined! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:43'! testExampleBlockNested | ir method newMethod instance | method := (OCOpalExamples>>#exampleBlockNested) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockNested.! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:44'! testExampleWhileModificationBefore | ir method newMethod instance | method := (OCOpalExamples>>#exampleWhileModificationBefore) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleWhileModificationBefore! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:48'! testExampleSimpleBlockArgument5 | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockArgument5) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockArgument5! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:51'! testExampleWhileModificationAfterNotInlined | ir method newMethod instance | method := (OCOpalExamples>>#exampleWhileModificationAfterNotInlined) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleWhileModificationAfterNotInlined! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-variables' stamp: 'MarcusDenker 11/20/2012 16:50'! testExampleSuper | ir method newMethod instance | method := (OCOpalExamples>>#exampleSuper) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSuper! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:45'! testExampleIfFalseIfTrue | ir method newMethod instance | method := (OCOpalExamples>>#exampleIfFalseIfTrue) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleIfFalseIfTrue.! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-misc' stamp: 'MarcusDenker 11/20/2012 16:42'! testExampleToDoValue | ir method newMethod instance | method := (OCOpalExamples>>#exampleToDoValue) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoValue! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:43'! testExampleBlockExternalNested | ir method newMethod instance | method := (OCOpalExamples>>#exampleBlockExternalNested) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockExternalNested. ! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:43'! testExampleBlockExternalArg | ir method newMethod instance | method := (OCOpalExamples>>#exampleBlockExternalArg) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockExternalArg. ! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-variables' stamp: 'MarcusDenker 11/20/2012 16:44'! testExampleiVar | ir method newMethod instance | method := (OCOpalExamples>>#exampleiVar) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleiVar! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:44'! testExampleWhileWithTemp | ir method newMethod instance | method := (OCOpalExamples>>#exampleWhileWithTemp) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleWhileWithTemp! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:44'! testExampleWhileWithTempNotInlined | ir method newMethod instance | method := (OCOpalExamples>>#exampleWhileWithTempNotInlined) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleWhileWithTempNotInlined! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:50'! testExampleToDoArgumentNotInlined | ir method newMethod instance | method := (OCOpalExamples>>#exampleToDoArgumentNotInlined) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoArgumentNotInlined! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:42'! testExampleBlockArgument | ir method newMethod instance | method := (OCOpalExamples>>#exampleBlockArgument) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleBlockArgument. ! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:45'! testExampleIfFalse | ir method newMethod instance | method := (OCOpalExamples>>#exampleIfFalse) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleIfFalse.! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:48'! testExampleSimpleBlockArgument3 | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockArgument3) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockArgument3! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:49'! testExampleSimpleBlockiVar | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockiVar) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockiVar! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:49'! testExampleSimpleBlockLocalNested | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockNested) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockNested! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:47'! testExampleMethodWithOptimizedBlocksA | ir method newMethod instance | method := (OCOpalExamples>>#exampleMethodWithOptimizedBlocksA) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleMethodWithOptimizedBlocksA! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-simple' stamp: 'MarcusDenker 11/20/2012 16:48'! testExampleReturn1plus2 | ir method newMethod instance | method := (OCOpalExamples>>#exampleReturn1plus2) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleReturn1plus2! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:48'! testExampleSimpleBlockArgument1 | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockArgument1) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockArgument1! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:48'! testExampleSimpleBlockArgument2 | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockArgument2) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockArgument2! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:49'! testExampleSimpleBlockLocalIf | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockLocalIf) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockLocalIf! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:51'! testExampleToDoOutsideTempNotInlined | ir method newMethod instance | method := (OCOpalExamples>>#exampleToDoOutsideTempNotInlined) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleToDoOutsideTempNotInlined! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-variables' stamp: 'MarcusDenker 11/20/2012 16:48'! testExampleSelf | ir method newMethod instance | method := (OCOpalExamples>>#exampleSelf) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSelf! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:46'! testExampleIfTrueIfFalse | ir method newMethod instance | method := (OCOpalExamples>>#exampleIfTrueIfFalse) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleIfTrueIfFalse! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks' stamp: 'MarcusDenker 11/20/2012 16:47'! testExampleNestedBlockScoping | ir method newMethod instance | method := (OCOpalExamples>>#exampleNestedBlockScoping) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleNestedBlockScoping! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-simple' stamp: 'MarcusDenker 11/20/2012 16:47'! testExampleNewArray | ir method newMethod instance | method := (OCOpalExamples>>#exampleNewArray) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleNewArray! ! !OCBytecodeDecompilerExamplesTest methodsFor: 'tests-blocks-optimized' stamp: 'MarcusDenker 11/20/2012 16:49'! testExampleSimpleBlockLocalWhile | ir method newMethod instance | method := (OCOpalExamples>>#exampleSimpleBlockLocalWhile) parseTree generate. instance := OCOpalExamples new. ir := IRBytecodeDecompiler new decompile: method. newMethod := ir compiledMethod. self assert: (newMethod valueWithReceiver: instance arguments: #()) = instance exampleSimpleBlockLocalWhile! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'ToonVerwaest 3/31/2011 14:30'! testBugOffset | iRMethod aCompiledMethod ir method | iRMethod := IRBuilder new addTemps: #(#a #b); pushTemp: #b; pushTemp: #a; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. ir := aCompiledMethod ir. method := ir compiledMethod. self assert: (aCompiledMethod symbolic = method symbolic). ! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralBoolean | ir1 ir2 method | ir1 := IRBuilderTest new testLiteralBoolean. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'examples' stamp: 'MarcusDenker 8/27/2010 13:23'! pushClosureCopyNoCopiedArg ^IRBuilder new pushReceiver; pushClosureCopyCopiedValues: #() args: #(d) jumpTo: #block; pushLiteral: 1; pushTemp: #d; send: #+; blockReturnTop; jumpAheadTarget: #block; pushLiteral: 1; send: #value:; returnTop; ir. ! ! !OCBytecodeDecompilerTest methodsFor: 'examples' stamp: 'MarcusDenker 8/27/2010 13:23'! pushClosureCopyNoCopied | iRMethod aCompiledMethod | ^ IRBuilder new pushReceiver; pushClosureCopyCopiedValues: #() args: #() jumpTo: #block; pushLiteral: 1; pushLiteral: 2; send: #+; blockReturnTop; jumpAheadTarget: #block; send: #value; returnTop; ir. ! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralVariableClass | ir1 ir2 method | ir1 := IRBuilderTest new testLiteralVariableClass. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'examples' stamp: 'MarcusDenker 8/27/2010 13:22'! remoteTemp | iRMethod aCompiledMethod | iRMethod := IRBuilder new createTempVectorNamed:#methodVector withVars: #(b); "b we know will be written to, so make a tempvector entry" addTemps: #(a); "we have one real temp" pushLiteral: 1; storeTemp: #a; popTop; pushClosureCopyCopiedValues: #(#a #methodVector) args: #() jumpTo: #block; pushTemp: #a; "a is just read, so we copy it to the block" pushLiteral: 1; send: #+; storeRemoteTemp: #b inVector: #methodVector; "b comes from tempvetor, as we do write to it" popTop; blockReturnTop; jumpAheadTarget: #block; send: #value; pushRemoteTemp: #b inVector: #methodVector; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #() ) = 2). ^iRMethod ! ! !OCBytecodeDecompilerTest methodsFor: 'tests - blocks' stamp: 'MarcusDenker 9/20/2013 15:05'! testBlockWithTemp | method ir | method := ClassTestCase>>#targetClass. ir := method ir. "the block sequence of the block with the temp should not have a pushNil, as this is inserted later again" self assert: (ir allSequences at: 5) first isPushLiteral not.! ! !OCBytecodeDecompilerTest methodsFor: 'tests - blocks' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushClosureCopyOneCopiedArg | ir1 ir2 method | ir1 := self pushClosureCopyOneCopiedArg. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushSelf | ir1 ir2 method | ir1 := IRBuilderTest new testPushSelf. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'examples' stamp: 'MarcusDenker 8/27/2010 13:24'! pushClosureCopyOneCopiedArg ^IRBuilder new addTemps: #(a); pushReceiver; pushLiteral: 1; storeTemp: #a; popTop; pushClosureCopyCopiedValues: #(a) args: #(d) jumpTo: #block; pushTemp: #a; pushTemp: #d; send: #+; blockReturnTop; jumpAheadTarget: #block; pushLiteral: 1; send: #value:; returnTop; ir. ! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralVariableClassVariable | ir1 ir2 method | ir1 := IRBuilderTest new testLiteralVariableClassVariable. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testStoreIntoVariable | ir1 ir2 method | ir1 := IRBuilderTest new testStoreIntoVariable. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralVariableGlobale | ir1 ir2 method | ir1 := IRBuilderTest new testLiteralVariableGlobale. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testReturnTop | ir1 ir2 method | ir1 := IRBuilderTest new testReturnTop. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testSendSuper | ir1 ir2 method | ir1 := IRBuilderTest new testSendSuper. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testPopTop | ir1 ir2 method | ir1 := IRBuilderTest new testPopTop. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testInstVar | ir1 ir2 method method2 | ir1 := IRBuilderTest new testInstVar. method := ir1 compiledMethod. ir2 := method ir. method2 := ir2 compiledMethod. self deny: method2 == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: method2 = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralArray | ir1 ir2 method | ir1 := IRBuilderTest new testLiteralArray. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests - blocks' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushClosureCopyNoCopied | ir1 ir2 method | ir1 := self pushClosureCopyNoCopied. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralNil | ir1 ir2 method | ir1 := IRBuilderTest new testLiteralNil. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralString | ir1 ir2 method | ir1 := IRBuilderTest new testLiteralString. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests - examples' stamp: 'CamilloBruni 8/31/2013 20:23'! testDecompileBytecodeDecompilerTestClass | decompiledIR aCompiledMethod | self class methodDict do: [ :each | decompiledIR := IRBytecodeDecompiler new decompile: each. aCompiledMethod := decompiledIR compiledMethod ]! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testJumpAheadTo | ir1 ir2 method | ir1 := IRBuilderTest new testJumpAheadTo. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testJumpBackTo | ir1 ir2 method | ir1 := IRBuilderTest new testJumpBackTo. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testDup | ir1 ir2 method | ir1 := IRBuilderTest new testDup. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushConsArray | ir1 ir2 method | ir1 := IRBuilderTest new testPushConsArray. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushConsArray2 | ir1 ir2 method | ir1 := IRBuilderTest new testPushConsArray2. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests - examples' stamp: 'CamilloBruni 8/31/2013 20:23'! testWhileTrue | cm decompiledIR aCompiledMethod | cm := self class >> #testWhileTrue. decompiledIR := IRBytecodeDecompiler new decompile: cm. aCompiledMethod := decompiledIR compiledMethod! ! !OCBytecodeDecompilerTest methodsFor: 'tests - examples' stamp: 'CamilloBruni 8/31/2013 20:23'! testDecompilerOrderedCollectionDo | cm decompiledIR | cm := OrderedCollection >> #do:. decompiledIR := IRBytecodeDecompiler new decompile: cm. decompiledIR compiledMethod! ! !OCBytecodeDecompilerTest methodsFor: 'examples' stamp: 'MarcusDenker 8/27/2010 13:23'! pushClosureCopyOneCopiedTemp ^IRBuilder new addTemps: #(a); pushReceiver; pushLiteral: 1; storeTemp: #a; popTop; pushClosureCopyCopiedValues: #(a) args: #() jumpTo: #block; addTemps: #(d); "the temp" pushTemp: #a; pushLiteral: 1; send: #+; storeTemp: #d; popTop; pushTemp: #d; blockReturnTop; jumpAheadTarget: #block; send: #value; returnTop; ir. ! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralCharacter | ir1 ir2 method | ir1 := IRBuilderTest new testLiteralCharacter. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests - blocks' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushClosureCopyOneCopiedTemp | ir1 ir2 method | ir1 := self pushClosureCopyOneCopiedTemp. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'setUp - tearDown' stamp: 'MarcusDenker 5/13/2013 14:51'! tearDown SmalltalkImage compilerClass: currentCompiler.! ! !OCBytecodeDecompilerTest methodsFor: 'tests - blocks' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushClosureCopyNoCopiedArg | ir1 ir2 method | ir1 := self pushClosureCopyNoCopiedArg. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: ir2 compiledMethod symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests - examples' stamp: 'CamilloBruni 8/31/2013 20:23'! testDecompileIRBuilderTestClass | decompiledIR aCompiledMethod | IRBuilderTest methodDict do: [ :each | decompiledIR := IRBytecodeDecompiler new decompile: each. aCompiledMethod := decompiledIR compiledMethod ]! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralInteger | ir1 ir2 method | ir1 := IRBuilderTest new testLiteralInteger. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'setUp - tearDown' stamp: 'MarcusDenker 5/13/2013 14:51'! setUp currentCompiler := SmalltalkImage compilerClass. SmalltalkImage compilerClass: OpalCompiler.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralSymbol | ir1 ir2 method | ir1 := IRBuilderTest new testLiteralSymbol. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:05'! testRemoteTempNested | ir1 ir2 method | ir1 := self remoteTempNested. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests - examples' stamp: 'CamilloBruni 8/31/2013 20:23'! testDecompileBytecodeGeneratorTest | decompiledIR aCompiledMethod | OCBytecodeGeneratorTest methodDict do: [ :each | decompiledIR := IRBytecodeDecompiler new decompile: each. aCompiledMethod := decompiledIR compiledMethod ]! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testLiteralFloat | ir1 ir2 method | ir1 := IRBuilderTest new testLiteralFloat. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method .! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushTempTemp | ir1 ir2 method | ir1 := IRBuilderTest new testPushTempTemp. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushThisContext | ir1 ir2 method | ir1 := IRBuilderTest new testPushThisContext. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic. self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testJumpAheadToIf | ir1 ir2 method | ir1 := IRBuilderTest new testJumpAheadToIf. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testPushTempArgument | ir1 ir2 method | ir1 := IRBuilderTest new testPushTempArgument. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:05'! testRemoteTemp | ir1 ir2 method | ir1 := self remoteTemp. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 7/16/2012 16:07'! testStoreTemp | ir1 ir2 method | ir1 := IRBuilderTest new testStoreTemp. method := ir1 compiledMethod. ir2 := IRBytecodeDecompiler new decompile: method. self deny: ir2 compiledMethod == method. self assert: (ir2 compiledMethod) symbolic = method symbolic . self assert: ir2 compiledMethod = method.! ! !OCBytecodeDecompilerTest methodsFor: 'examples' stamp: 'MarcusDenker 8/27/2010 13:23'! remoteTempNested | iRMethod aCompiledMethod | iRMethod := IRBuilder new createTempVectorNamed:#methodVector withVars: #(b); "b we know will be written to, so make a tempvector entry" addTemps: #(a); "we have one real temp" pushLiteral: 1; storeTemp: #a; popTop; pushClosureCopyCopiedValues: #(methodVector a) args: #() jumpTo: #block; createTempVectorNamed:#blockVector withVars: #(f); pushTemp: #a; "a is just read, so we copy it to the block" pushClosureCopyCopiedValues: #(methodVector) args: #() jumpTo: #block2; pushLiteral: 1; storeRemoteTemp: #b inVector: #methodVector; "f comes from tempvetor, as we do write to it" blockReturnTop; jumpAheadTarget: #block2; send: #value; send: #+; storeRemoteTemp: #b inVector: #methodVector; "b comes from tempvetor, as we do write to it" blockReturnTop; jumpAheadTarget: #block; send: #value; pushRemoteTemp: #b inVector: #methodVector; returnTop; ir. aCompiledMethod := iRMethod compiledMethod. self assert: (aCompiledMethod isKindOf: CompiledMethod). self assert: ((aCompiledMethod valueWithReceiver: nil arguments: #()) = 2). ^iRMethod ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testStoreInstVar | gen cm symbolic | gen := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; storeInstVar: 1; returnTop. cm := gen compiledMethod. symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: gen stackFrameSize = 1. self assert: cm isCompiledMethod. self assert: symbolic = '13 <76> pushConstant: 1 14 <81 00> storeIntoRcvr: 0 16 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testBlockReturnTop | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; blockReturnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <7D> blockReturn '. ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - execution' stamp: 'MarcusDenker 7/16/2012 16:05'! testExample | cm | cm := IRBytecodeGenerator new numArgs: 1; numTemps: 1; pushTemp: 1; pushInstVar: 2; send: #>; if: false goto: #else; pushLiteral: 'yes'; returnTop ; label: #else; pushLiteral: 'no'; returnTop; compiledMethod. cm methodClass: self class. cm selector: #test. self assert: (cm isKindOf: CompiledMethod). self assert: (cm valueWithReceiver: 2@2 arguments: #(1)) = 'no' . self assert: (cm valueWithReceiver: 2@2 arguments: #(3)) = 'yes' . ^cm ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushLiteralVariable | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteralVariable: (LookupKey key: '1'); returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '17 <40> pushLit: 1 18 <7C> returnTop ' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - errors' stamp: 'MarcusDenker 7/16/2012 16:05'! testStoreRemoteTempInVectorAtOutOfRange self should: [ IRBytecodeGenerator new numArgs: 0; storeRemoteTemp: 1 inVectorAt: 257 ] raise: Error withExceptionDo: [:exception | self assert: (exception messageText = 'tempVectorIndex out of range 0 to 255')] ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - errors' stamp: 'MarcusDenker 7/16/2012 16:05'! testStoreRemoteTempOutOfRangeInVectorAt self should: [ IRBytecodeGenerator new numArgs: 0; storeRemoteTemp: 257 inVectorAt: 1 ] raise: Error withExceptionDo: [:exception | self assert: (exception messageText = 'remoteTempIndex out of range 0 to 255')] ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushNewArray | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushNewArray: 1; returnTop; compiledMethod. self assert: (cm isKindOf: CompiledMethod). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <8A 01> push: (Array new: 1) 15 <7C> returnTop ' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testSend | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; send: #a; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '17 <76> pushConstant: 1 18 send: a 19 <7C> returnTop ' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - errors' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushRemoteTempOutOfRangeInVectorAt self should: [ IRBytecodeGenerator new numArgs: 0; pushRemoteTemp: 257 inVectorAt: 1 ] raise: Error withExceptionDo: [:exception | self assert: (exception messageText = 'remoteTempIndex is out of range 0 to 255')] ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testStoreLiteralVariable | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; storeIntoLiteralVariable: OCBytecodeGeneratorTest binding; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '17 <76> pushConstant: 1 18 <81 C0> storeIntoLit: OCBytecodeGeneratorTest 20 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testReturnTop | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <76> pushConstant: 1 14 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testReturnReceiver | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; returnReceiver; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = 'Quick return self' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPopTop | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; pushLiteral: 1; popTop; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <76> pushConstant: 1 14 <76> pushConstant: 1 15 <87> pop 16 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testStorePopInstVar | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; pushLiteral: 1; storePopInstVar: 1; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <76> pushConstant: 1 14 <76> pushConstant: 1 15 <60> popIntoRcvr: 0 16 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testIfGoToOtherWise | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 1; pushTemp: 1; pushLiteral: 1; if: true goto: #return otherwise: #other; label: #other; returnTop; label: #return; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <10> pushTemp: 0 14 <76> pushConstant: 1 15 jumpTrue: 18 17 <7C> returnTop 18 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testStorePopRemoteTempInVectorAt | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; pushLiteral: 1; storePopRemoteTemp: 1 inVectorAt: 1; returnTop; compiledMethod. self assert: (cm isKindOf: CompiledMethod). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <76> pushConstant: 1 14 <76> pushConstant: 1 15 <8E 00 00> popIntoTemp: 0 inVectorAt: 0 18 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushConsArray | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; pushConsArray: 1; returnTop; compiledMethod. self assert: (cm isKindOf: CompiledMethod). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <76> pushConstant: 1 14 <8A 81> pop 1 into (Array new: 1) 16 <7C> returnTop ' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - execution' stamp: 'MarcusDenker 7/16/2012 16:05'! testClosureExample | cm | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushClosureCopyNumCopiedValues: 0 numArgs: 0 to: #end; pushReceiver; blockReturnTop; label: #end; returnTop; compiledMethod. cm methodClass: self class. cm selector: #test. self assert: (cm isKindOf: CompiledMethod). self assert: ((cm valueWithReceiver: 2@2 arguments: #()) isKindOf: BlockClosure). self assert: ((cm valueWithReceiver: 2@2 arguments: #()) value = (2@2)). ^cm ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testStorePopIntoLiteralVariable | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; pushLiteral: 1; storePopIntoLiteralVariable: (#test->1); returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '17 <76> pushConstant: 1 18 <76> pushConstant: 1 19 <82 C0> popIntoLit: test 21 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testReturnConstant | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; returnConstant: 1; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = 'Quick return 1' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testStorePopTemp | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; pushLiteral: 1; storePopTemp: 1; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <76> pushConstant: 1 14 <76> pushConstant: 1 15 <68> popIntoTemp: 0 16 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushClosureCopyNumCopiedValuesNumArgsTo | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushClosureCopyNumCopiedValues: 0 numArgs: 0 to: #end; pushReceiver; blockReturnTop; label: #end; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <8F 00 00 02> closureNumCopied: 0 numArgs: 0 bytes 17 to 18 17 <70> self 18 <7D> blockReturn 19 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushRemoteTempInVectorAt | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushRemoteTemp: 1 inVectorAt: 1; returnTop; compiledMethod. self assert: (cm isKindOf: CompiledMethod). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <8C 00 00> pushTemp: 0 inVectorAt: 0 16 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testSendToSuperOf | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; send: #a toSuperOf: Object; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '17 <76> pushConstant: 1 18 <85 00> superSend: a 20 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushLiteral | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <76> pushConstant: 1 14 <7C> returnTop ' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushInstVar | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushInstVar: 1; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <00> pushRcvr: 0 14 <7C> returnTop ' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testIfGoTo | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 1; pushTemp: 1; pushLiteral: 1; if: true goto: #return; returnTop; label: #return; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <10> pushTemp: 0 14 <76> pushConstant: 1 15 jumpTrue: 18 17 <7C> returnTop 18 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - errors' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushRemoteTempInVectorAtOutOfRange self should: [ IRBytecodeGenerator new numArgs: 0; pushRemoteTemp: 1 inVectorAt: 257 ] raise: Error withExceptionDo: [:exception | self assert: (exception messageText = 'tempVectorIndex is out of range 0 to 255')] ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testGoTo | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; label: #back; pushLiteral: 1; returnTop; goto: #back; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <76> pushConstant: 1 14 <76> pushConstant: 1 15 <7C> returnTop 16 jumpTo: 14 '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushReceiver | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushReceiver; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <70> self 14 <7C> returnTop ' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushTemp | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 1; pushTemp: 1; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <10> pushTemp: 0 14 <7C> returnTop ' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testLabel | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; label: #back; pushLiteral: 1; returnTop; goto: #back; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <76> pushConstant: 1 14 <76> pushConstant: 1 15 <7C> returnTop 16 jumpTo: 14 '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushThisContext | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushThisContext ; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <89> pushThisContext: 14 <7C> returnTop ' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testPushDup | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushDup; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <88> dup 14 <7C> returnTop ' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - execution' stamp: 'MarcusDenker 7/16/2012 16:05'! testExample2 | cm | cm := IRBytecodeGenerator new numArgs: 1; numTemps: 1; pushInstVar: 2; pushTemp: 1; send: #<; if: false goto: #else; pushLiteral: 'yes'; returnTop ; label: #else; pushLiteral: 'no'; returnTop; compiledMethod. self assert: (cm isKindOf: CompiledMethod). self assert: (cm valueWithReceiver: 2@2 arguments: #(1)) = 'no' . self assert: (cm valueWithReceiver: 2@2 arguments: #(3)) = 'yes' . ^cm ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testStoreTemp | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 1; pushLiteral: 1; storeTemp: 1; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <76> pushConstant: 1 14 <81 40> storeIntoTemp: 0 16 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testReturnInstVar | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; returnInstVar: 1; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = 'Quick return field 0 (0-based)' ! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testStoreIntoLiteralVariable | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; storeIntoLiteralVariable: (LookupKey key: '1'); returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '17 <76> pushConstant: 1 18 <81 C0> storeIntoLit: 1 20 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testGoToIf | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 1; pushTemp: 1; pushLiteral: 1; if: true goto: #return; returnTop; label: #return; returnTop; compiledMethod. self assert: (cm isCompiledMethod ). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <10> pushTemp: 0 14 <76> pushConstant: 1 15 jumpTrue: 18 17 <7C> returnTop 18 <7C> returnTop '! ! !OCBytecodeGeneratorTest methodsFor: 'tests - instructions' stamp: 'MarcusDenker 7/16/2012 16:05'! testStoreRemoteTempInVectorAt | cm symbolic | cm := IRBytecodeGenerator new numArgs: 0; numTemps: 0; pushLiteral: 1; storeRemoteTemp: 1 inVectorAt: 1; returnTop; compiledMethod. self assert: (cm isKindOf: CompiledMethod). symbolic := String streamContents: [:str | cm longPrintOn: str ]. self assert: symbolic = '13 <76> pushConstant: 1 14 <8D 00 00> storeIntoTemp: 0 inVectorAt: 0 17 <7C> returnTop '! ! !OCBytecodeGeneratorTest class methodsFor: 'accessing' stamp: 'lr 8/21/2010 10:06'! packageNamesUnderTest ^ #('OpalCompiler')! ! !OCCaseOfTest methodsFor: 'tests' stamp: 'ClementBera 7/10/2013 15:02'! testCaseOfEffect | temp | #case1 caseOf: { [#case1]->[ temp := 1 ]. [#case2]->[ temp := 2 ] }. self assert: temp equals: 1. #case2 caseOf: { [#case1]->[ temp := 1 ]. [#case2]->[ temp := 2 ] }. self assert: temp equals: 2. self should: [ #case3 caseOf: { [#case1]->[ 1 ]. [#case2]->[ 2 ] } ] raise: Error! ! !OCCaseOfTest methodsFor: 'tests' stamp: 'ClementBera 7/10/2013 15:02'! testCaseOfValue | temp | temp := #case1 caseOf: { [#case1]->[ 1 ]. [#case2]->[ 2 ] }. self assert: temp equals: 1. temp := #case2 caseOf: { [#case1]->[ 1 ]. [#case2]->[ 2 ] }. self assert: temp equals: 2. self should: [ temp := #case3 caseOf: { [#case1]->[ 1 ]. [#case2]->[ 2 ] } ] raise: Error ! ! !OCCaseOfTest methodsFor: 'tests' stamp: 'ClementBera 7/10/2013 15:01'! testCaseOfOtherwiseEffect | temp | #case1 caseOf: { [#case1]->[ temp := 1 ]. [#case2]->[ temp := 2 ] } otherwise: [ temp := 3 ]. self assert: temp equals: 1. #case2 caseOf: { [#case1]->[ temp := 1 ]. [#case2]->[ temp := 2 ] } otherwise: [ temp := 3 ]. self assert: temp equals: 2. #case3 caseOf: { [#case1]->[ temp := 1 ]. [#case2]->[ temp := 2 ] } otherwise: [ temp := 3 ]. self assert: temp equals: 3 ! ! !OCCaseOfTest methodsFor: 'tests' stamp: 'ClementBera 7/10/2013 15:09'! testCompilationError self should: [ self compile: 'methodPattern 1 caseOf: { }' ] raise: SyntaxErrorNotification. self should: [ self compile: 'methodPattern 1 caseOf: { } otherwise: [ 42 ]' ] raise: SyntaxErrorNotification.! ! !OCCaseOfTest methodsFor: 'helper' stamp: 'ClementBera 7/10/2013 15:08'! compile: source ^OpalCompiler new class: self class; source: source; compile! ! !OCCaseOfTest methodsFor: 'tests' stamp: 'ClementBera 7/10/2013 15:00'! testCaseOfOtherwiseValue | temp | temp := #case1 caseOf: { [#case1]->[ 1 ]. [#case2]->[ 2 ] } otherwise: [ 3 ]. self assert: temp equals: 1. temp := #case2 caseOf: { [#case1]->[ 1 ]. [#case2]->[ 2 ] } otherwise: [ 3 ]. self assert: temp equals: 2. temp := #case3 caseOf: { [#case1]->[ 1 ]. [#case2]->[ 2 ] } otherwise: [ 3 ]. self assert: temp equals: 3 ! ! !OCClassScope commentStamp: 'ajh 3/24/2003 21:44'! I include all variable enries for class, pool and global vars.! !OCClassScope methodsFor: 'lookup' stamp: 'MarcusDenker 6/14/2013 15:22'! lookupVar: name "Return a SemVar for my pool var with this name. Return nil if none found" ^(class bindingOf: name asSymbol) ifNotNil: [:assoc | OCLiteralVariable new assoc: assoc; scope: self; yourself] ! ! !OCClassScope methodsFor: 'initializing' stamp: 'ajh 2/25/2003 20:10'! class: aBehavior class := aBehavior! ! !OCClassScope methodsFor: 'levels' stamp: 'MarcusDenker 8/27/2010 12:35'! newMethodScope ^ self instanceScope newMethodScope! ! !OCClassScope methodsFor: 'levels' stamp: 'MarcusDenker 8/22/2010 10:52'! instanceScope ^ OCInstanceScope new vars: class allInstVarNames; outerScope: self; yourself! ! !OCClassScope methodsFor: 'printing' stamp: 'MarcusDenker 6/18/2013 10:00'! printOn: stream class printOn: stream.! ! !OCClassScope methodsFor: 'lookup' stamp: 'MarcusDenker 6/5/2013 13:52'! lookupVarForDeclaration: name ^self lookupVar: name! ! !OCClassScope class methodsFor: 'instance creation' stamp: 'MarcusDenker 8/21/2010 18:39'! for: aClass ^self new class: aClass; yourself! ! !OCCleanBockTest methodsFor: 'tests' stamp: 'ClementBera 8/5/2013 11:06'! testBlockIsClean self assert: [ ] sourceNode isClean. self assert: [ 1 + 2 ] sourceNode isClean. self assert: [ :a | a + 2 ] sourceNode isClean. self assert: [ :a :b | a + b + 3 ] sourceNode isClean. self assert: [ | a | a := 1. a + 3 ] sourceNode isClean. ! ! !OCCleanBockTest methodsFor: 'tests' stamp: 'ClementBera 8/5/2013 11:11'! testBlockIsNotClean | escpWrite escpRead | escpRead := escpWrite := 1. self deny: [ self foo ] sourceNode isClean. self deny: [ ^ 1 ] sourceNode isClean. self deny: [ instVar foo ] sourceNode isClean. self deny: [ escpRead foo ] sourceNode isClean. self deny: [ escpWrite := 2 ] sourceNode isClean. self deny: [[ self foo ]] sourceNode isClean. self deny: [[ ^ 1 ]] sourceNode isClean. self deny: [[ instVar foo ]] sourceNode isClean. self deny: [[ escpRead foo ]] sourceNode isClean. self deny: [[ escpWrite := 2 ]] sourceNode isClean.! ! !OCClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/23/2013 13:53'! testDebuggerTempAccess self doTestDebuggerTempAccessWith: 1 with: 2! ! !OCClosureCompilerTest methodsFor: 'running' stamp: 'MarcusDenker 9/5/2013 12:59'! evaluate: aString in: aContext to: anObject self class compiler source: aString; context: aContext; receiver: anObject; evaluate! ! !OCClosureCompilerTest methodsFor: 'running' stamp: 'MarcusDenker 5/23/2013 13:45'! tearDown SmalltalkImage compilerClass: currentCompiler.! ! !OCClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/23/2013 13:45'! testInlineBlockCollectionLR3 | col | col := OrderedCollection new. 1 to: 11 do: [ :each | | i | i := each. col add: [ i ]. i := i + 1 ]. self assert: (col collect: [ :each | each value ]) asArray = (2 to: 12) asArray! ! !OCClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/23/2013 13:45'! testInlineBlockCollectionSD1 | a1 b1 a2 b2 | b1 := OrderedCollection new. 1 to: 3 do: [:i | a1 := i. b1 add: [a1]]. b1 := b1 asArray collect: [:b | b value]. b2 := OrderedCollection new. 1 to: 3 do: [:i | a2 := i. b2 add: [a2]] yourself. "defeat optimization" b2 := b2 asArray collect: [:b | b value]. self assert: b1 = b2! ! !OCClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/23/2013 13:45'! testInlineBlockCollectionLR1 "Test case from Lukas Renggli" | col | col := OrderedCollection new. 1 to: 11 do: [ :each | col add: [ each ] ]. self assert: (col collect: [ :each | each value ]) asArray = (1 to: 11) asArray! ! !OCClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/23/2013 13:45'! testInlineBlockCollectionLR2 "Test case from Lukas Renggli" | col | col := OrderedCollection new. 1 to: 11 do: [ :each | #(1) do: [:ignored| col add: [ each ]] ]. self assert: (col collect: [ :each | each value ]) asArray = (1 to: 11) asArray! ! !OCClosureCompilerTest methodsFor: 'running' stamp: 'MarcusDenker 5/23/2013 13:46'! setUp currentCompiler := SmalltalkImage compilerClass. SmalltalkImage compilerClass: OpalCompiler.! ! !OCClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 13:00'! doTestDebuggerTempAccessWith: one with: two "Test debugger access for temps" | outerContext local1 remote1 | outerContext := thisContext. local1 := 3. remote1 := 1/2. self assert: (self evaluate: 'one' in: thisContext to: self) == one. self assert: (self evaluate: 'two' in: thisContext to: self) == two. self assert: (self evaluate: 'local1' in: thisContext to: self) == local1. self assert: (self evaluate: 'remote1' in: thisContext to: self) == remote1. self evaluate: 'local1 := -3.0' in: thisContext to: self. self assert: local1 = -3.0. (1 to: 2) do: [:i| | local2 r1 r2 r3 r4 | local2 := i * 3. remote1 := local2 / 7. self assert: thisContext ~~ outerContext. self assert: (r1 := self evaluate: 'one' in: thisContext to: self) == one. self assert: (r2 := self evaluate: 'two' in: thisContext to: self) == two. self assert: (r3 := self evaluate: 'i' in: thisContext to: self) == i. self assert: (r4 := self evaluate: 'local2' in: thisContext to: self) == local2. self assert: (r4 := self evaluate: 'remote1' in: thisContext to: self) == remote1. self assert: (r4 := self evaluate: 'remote1' in: outerContext to: self) == remote1. self evaluate: 'local2 := 15' in: thisContext to: self. self assert: local2 = 15. self evaluate: 'local1 := 25' in: thisContext to: self. self assert: local1 = 25. { r1. r2. r3. r4 } "placate the compiler"]. self assert: local1 = 25. self assert: remote1 = (6/7)! ! !OCClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/23/2013 13:45'! testOptimizedBlockLocalNilling2 "Whether a block is optimized or not a block-local temp should be nil at the start of each evaluation of the block." 1 to: 6 do: [:i| | j k | self assert: j isNil. self assert: k isNil. i even ifTrue: [j := i + 2] ifFalse: [k := i + 1]. self assert: (j isNil or: [k isNil]). self assert: (j isNil not or: [k isNil not])]! ! !OCClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/23/2013 13:45'! testInlineBlockCollectionEM1 | a1 b1 i1 a2 b2 i2 we wb | b1 := OrderedCollection new. i1 := 1. [a1 := i1. i1 <= 3] whileTrue: [b1 add: [a1]. i1 := i1 + 1]. b1 := b1 asArray collect: [:b | b value]. b2 := OrderedCollection new. i2 := 1. we := [a2 := i2. i2 <= 3]. wb := [b2 add: [a2]. i2 := i2 + 1]. we whileTrue: wb. "defeat optimization" b2 := b2 asArray collect: [:b | b value]. self assert: b1 = b2! ! !OCClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 5/23/2013 13:45'! testOptimizedBlockLocalNilling1 "Whether a block is optimized or not a block-local temp should be nil at the start of each evaluation of the block." 1 to: 3 do: [:i| | j | self assert: j isNil. j := i + 1. self assert: j isNil not]! ! !OCClosureCompilerTest methodsFor: 'source' stamp: 'MarcusDenker 5/23/2013 13:45'! closureCases ^#( '| n | n := 1. ^n + n' '[:c :s| | mn | mn := Compiler new compile: (c sourceCodeAt: s) in: c notifying: nil ifFail: [self halt]. mn generate: #(0 0 0 0). {mn blockExtentsToTempsMap. mn encoder schematicTempNames}] value: AbstractInstructionTests value: #runBinaryConditionalJumps:' 'inject: thisValue into: binaryBlock | nextValue | nextValue := thisValue. self do: [:each | nextValue := binaryBlock value: nextValue value: each]. ^nextValue' 'mapFromBlockStartsIn: aMethod toTempVarsFrom: schematicTempNamesString constructor: aDecompilerConstructor | map | map := aMethod mapFromBlockKeys: aMethod startpcsToBlockExtents keys asSortedCollection toSchematicTemps: schematicTempNamesString. map keysAndValuesDo: [:startpc :tempNameTupleVector| | subMap tempVector numTemps | subMap := Dictionary new. tempNameTupleVector do: [:tuple| tuple last isArray ifTrue: [subMap at: tuple last first put: tuple last last. numTemps := tuple last first] ifFalse: [numTemps := tuple last]]. tempVector := Array new: numTemps. subMap keysAndValuesDo: [:index :size| tempVector at: index put: (Array new: size)]. tempNameTupleVector do: [:tuple| | itv | tuple last isArray ifTrue: [itv := tempVector at: tuple last first. itv at: tuple last last put: (aDecompilerConstructor codeTemp: tuple last last - 1 named: tuple first)] ifFalse: [tempVector at: tuple last put: (aDecompilerConstructor codeTemp: tuple last - 1 named: tuple first)]]. subMap keysAndValuesDo: [:index :size| tempVector at: index put: (aDecompilerConstructor codeRemoteTemp: index remoteTemps: (tempVector at: index))]. map at: startpc put: tempVector]. ^map' 'gnuifyFrom: inFileStream to: outFileStream | inData beforeInterpret inInterpret inInterpretVars beforePrimitiveResponse inPrimitiveResponse | inData := inFileStream upToEnd withSqueakLineEndings. inFileStream close. outFileStream nextPutAll: ''/* This file has been post-processed for GNU C */''; cr; cr; cr. beforeInterpret := true. "whether we are before the beginning of interpret()" inInterpret := false. "whether we are in the middle of interpret" inInterpretVars := false. "whether we are in the variables of interpret" beforePrimitiveResponse := true. "whether we are before the beginning of primitiveResponse()" inPrimitiveResponse := false. "whether we are inside of primitiveResponse" ''Gnuifying'' displayProgressAt: Sensor cursorPoint from: 1 to: (inData occurrencesOf: Character cr) during: [:bar | | lineNumber | lineNumber := 0. inData linesDo: [ :inLine | | outLine extraOutLine caseLabel | bar value: (lineNumber := lineNumber + 1). outLine := inLine. "print out one line for each input line; by default, print out the line that was input, but some rules modify it" extraOutLine := nil. "occasionally print a second output line..." beforeInterpret ifTrue: [ inLine = ''#include "sq.h"'' ifTrue: [ outLine := ''#include "sqGnu.h"'' ]. inLine = ''interpret(void) {'' ifTrue: [ "reached the beginning of interpret" beforeInterpret := false. inInterpret := true. inInterpretVars := true ] ] ifFalse: [ inInterpretVars ifTrue: [ (inLine findString: ''register struct foo * foo = &fum;'') > 0 ifTrue: [ outLine := ''register struct foo * foo FOO_REG = &fum;'' ]. (inLine findString: '' localIP;'') > 0 ifTrue: [ outLine := '' char* localIP IP_REG;'' ]. (inLine findString: '' localFP;'') > 0 ifTrue: [ outLine := '' char* localFP FP_REG;'' ]. (inLine findString: '' localSP;'') > 0 ifTrue: [ outLine := '' char* localSP SP_REG;'' ]. (inLine findString: '' currentBytecode;'') > 0 ifTrue: [ outLine := '' sqInt currentBytecode CB_REG;'' ]. inLine isEmpty ifTrue: [ "reached end of variables" inInterpretVars := false. outLine := '' JUMP_TABLE;''. extraOutLine := inLine ] ] ifFalse: [ inInterpret ifTrue: [ "working inside interpret(); translate the switch statement" (inLine beginsWith: '' case '') ifTrue: [ caseLabel := (inLine findTokens: '' :'') second. outLine := '' CASE('', caseLabel, '')'' ]. inLine = '' break;'' ifTrue: [ outLine := '' BREAK;'' ]. inLine = ''}'' ifTrue: [ "all finished with interpret()" inInterpret := false ] ] ifFalse: [ beforePrimitiveResponse ifTrue: [ (inLine beginsWith: ''primitiveResponse('') ifTrue: [ "into primitiveResponse we go" beforePrimitiveResponse := false. inPrimitiveResponse := true. extraOutLine := '' PRIM_TABLE;'' ] ] ifFalse: [ inPrimitiveResponse ifTrue: [ inLine = '' switch (primitiveIndex) {'' ifTrue: [ extraOutLine := outLine. outLine := '' PRIM_DISPATCH;'' ]. inLine = '' switch (GIV(primitiveIndex)) {'' ifTrue: [ extraOutLine := outLine. outLine := '' PRIM_DISPATCH;'' ]. (inLine beginsWith: '' case '') ifTrue: [ caseLabel := (inLine findTokens: '' :'') second. outLine := '' CASE('', caseLabel, '')'' ]. inLine = ''}'' ifTrue: [ inPrimitiveResponse := false ] ] ] ] ] ]. outFileStream nextPutAll: outLine; cr. extraOutLine ifNotNil: [ outFileStream nextPutAll: extraOutLine; cr ]]]. outFileStream close' )! ! !OCClosureCompilerTest class methodsFor: 'code examples' stamp: 'MarcusDenker 5/23/2013 13:45'! methodWithCopiedTemps | a b c r | a := 1. b := 2. c := 4. r := [a + b + c] value. b := nil. r "Parser new parse: (self class sourceCodeAt: #methodWithCopiedTemps) class: self class" "(Parser new encoderClass: EncoderForV3; parse: (self class sourceCodeAt: #methodWithCopiedTemps) class: self class) generateUsingClosures: #(0 0 0 0)"! ! !OCClosureCompilerTest class methodsFor: 'code examples' stamp: 'MarcusDenker 5/23/2013 13:45'! methodWithCopiedAndAssignedTemps | blk "0w" a "0w" b "0w" c "0w" t "0w" r1 "0w" r2 "0w" | a := 1. "1w" b := 2. "1w" c := 4. "1w" t := 0. "1w" blk "5w" := ["2" t "3w" := t "3r" + a "3r" + b "3r" + c "3r" ] "4". r1 "5w" := blk "5r" value. b "5w" := -100. r2 "5w" := blk "5r" value. ^r1 "5r" -> r2 "5r" -> t "5r" "a: main(read(),write(0,1)), block(read(3),write()) => copy; no writes follow read b: main(read(),write(0,1,5)), block(read(3),write()) => remote; write follows contained read blk: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5 c: main(read(),write(0,1)), block(read(3),write()) => copy; no writes follow read r1: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5 r2: main(read(5),write(0,5)), block(read(),write()) => no copy in blocks < 5 t: main(read(5),write(0,1)), block(read(3),write(3)) => remote; read follows contained write" "(Parser new encoderClass: EncoderForV3; parse: (self class sourceCodeAt: #methodWithCopiedAndAssignedTemps) class: self class) generateUsingClosures: #(0 0 0 0)"! ! !OCClosureCompilerTest class methodsFor: 'code examples' stamp: 'MarcusDenker 5/23/2013 13:45'! methodWithOptimizedBlocks | s c | s := self isNil ifTrue: [| a | a := 'isNil'. a] ifFalse: [| b | b := 'notNil'. b]. c := String new: s size. 1 to: s size do: [:i| c at: i put: (s at: i)]. ^c "Parser new parse: (self class sourceCodeAt: #methodWithOptimizedBlocks) class: self class"! ! !OCClosureCompilerTest class methodsFor: 'code examples' stamp: 'MarcusDenker 5/23/2013 13:45'! methodWithVariousTemps | classes total totalLength | classes := self withAllSuperclasses. total := totalLength := 0. classes do: [:class| | className | className := class name. total := total + 1. totalLength := totalLength + className size]. ^total -> totalLength "Parser new parse: (self class sourceCodeAt: #methodWithVariousTemps) class: self class"! ! !OCClosureCompilerTest class methodsFor: 'code examples' stamp: 'MarcusDenker 5/23/2013 13:45'! methodWithOptimizedBlocksA | s c | s := self isNil ifTrue: [| a | a := 'isNil'. a] ifFalse: [| a | a := 'notNil'. a]. c := String new: s size. 1 to: s size do: [:i| c at: i put: (s at: i)]. ^c "Parser new parse: (self class sourceCodeAt: #methodWithOptimizedBlocksA) class: self class"! ! !OCClosureCompilerTest class methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 5/23/2013 13:50'! compilerClass ^OpalCompiler! ! !OCClosureCompilerTest class methodsFor: 'code examples' stamp: 'MarcusDenker 5/23/2013 13:45'! methodWithCopiedAndPostClosedOverAssignedTemps | blk a b c r1 r2 | a := 1. b := 2. c := 4. blk := [a + b + c]. r1 := blk value. b := nil. r2 := blk value. r1 -> r2 "(Parser new encoderClass: EncoderForV3; parse: (self class sourceCodeAt: #methodWithCopiedAndPostClosedOverAssignedTemps) class: self class) generateUsingClosures: #(0 0 0 0)"! ! !OCClosureTests methodsFor: 'testing-empty' stamp: 'MarcusDenker 5/2/2013 11:25'! testEmptyBlockTwoArguments self assert: (self class compiler evaluate: '[ :a :b ] value: 1 value: 2') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class compiler evaluate: '[ :a :b | ] value: 1 value: 2') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class compiler evaluate: '[ :a :b | | t | ] value: 1 value: 2') isNil description: 'Empty blocks in ST-80 should return nil'! ! !OCClosureTests methodsFor: 'testing-while' stamp: 'StephaneDucasse 7/3/2010 22:21'! testWhileWithTempIsNil "self debug: #testWhileWithTempIsNil" | index | index := 0. [ index < 5 ] whileTrue: [ | temp | collection add: temp. temp := index := index + 1. collection add: temp]. self assertValues: #(nil 1 nil 2 nil 3 nil 4 nil 5)! ! !OCClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:36'! testMethodTemp | block1 block2 | block1 := self methodArgument: 1. block2 := self methodArgument: 2. self assert: block1 value = 1. self assert: block2 value = 2! ! !OCClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:33'! testBlockTemp | block block1 block2 | block := [ :arg | [ arg ] ]. block1 := block value: 1. block2 := block value: 2. self assert: block1 value = 1. self assert: block2 value = 2! ! !OCClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! testWhileModificationAfter | index | index := 0. [ index < 5 ] whileTrue: [ collection add: [ index ]. index := index + 1 ]. self assertValues: #(5 5 5 5 5)! ! !OCClosureTests methodsFor: 'testing' stamp: 'sd 6/8/2012 23:31'! testIsClean | local | local := #testIsClean. self assert: [] isClean. "closes over nothing at all" self assert: [:a :b| a < b] isClean. "accesses only arguments" self assert: [:a :b| | s | s := a + b. s even] isClean. "accesses only local variables" self deny: [^nil] isClean. "closes over home (^-return)" self deny: [self] isClean. "closes over the receiver" self deny: [collection] isClean. "closes over the receiver (to access the inst var collection)" self deny: [local] isClean. "closes over local variable of outer context"! ! !OCClosureTests methodsFor: 'utilities' stamp: 'StefanMarr 3/16/2012 01:36'! assertValues: anArray | values | values := collection collect: [ :each | each value ]. self assert: anArray asArray = values asArray description: ['Expected: ' , anArray asArray printString , ', but got ' , values asArray printString]! ! !OCClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:35'! methodArgument: anObject ^ [ anObject ] ! ! !OCClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoOutsideTemp | temp | 1 to: 5 do: [ :index | temp := index. collection add: [ temp ] ]. self assertValues: #(5 5 5 5 5)! ! !OCClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoOutsideTempNotInlined | block temp | block := [ :index | temp := index. collection add: [ temp ] ]. 1 to: 5 do: block. self assertValues: #(5 5 5 5 5)! ! !OCClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! testWhileModificationAfterNotInlined | index block | index := 0. block := [ collection add: [ index ]. index := index + 1 ]. [ index < 5 ] whileTrue: block. self assertValues: #(5 5 5 5 5)! ! !OCClosureTests methodsFor: 'running' stamp: 'lr 3/9/2009 16:48'! setUp super setUp. collection := OrderedCollection new! ! !OCClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoInsideTempNotInlined | block | block := [ :index | | temp | temp := index. collection add: [ temp ] ]. 1 to: 5 do: block. self assertValues: #(1 2 3 4 5)! ! !OCClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! testWhileModificationBefore | index | index := 0. [ index < 5 ] whileTrue: [ index := index + 1. collection add: [ index ] ]. self assertValues: #(5 5 5 5 5)! ! !OCClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:29'! testWhileModificationBeforeNotInlined | index block | index := 0. block := [ index := index + 1. collection add: [ index ] ]. [ index < 5 ] whileTrue: block. self assertValues: #(5 5 5 5 5)! ! !OCClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:52'! testWhileWithTemp | index | index := 0. [ index < 5 ] whileTrue: [ | temp | temp := index := index + 1. collection add: [ temp ] ]. self assertValues: #(1 2 3 4 5)! ! !OCClosureTests methodsFor: 'testing-while' stamp: 'lr 3/10/2009 14:53'! testWhileWithTempNotInlined | index block | index := 0. block := [ | temp | temp := index := index + 1. collection add: [ temp ] ]. [ index < 5 ] whileTrue: block. self assertValues: #(1 2 3 4 5)! ! !OCClosureTests methodsFor: 'testing-empty' stamp: 'MarcusDenker 5/2/2013 11:25'! testEmptyBlockOneArgument self assert: (self class compiler evaluate: '[ :a ] value: 1') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class compiler evaluate: '[ :a | ] value: 1') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class compiler evaluate: '[ :a | | t | ] value: 1') isNil description: 'Empty blocks in ST-80 should return nil'! ! !OCClosureTests methodsFor: 'testing-empty' stamp: 'MarcusDenker 5/2/2013 11:25'! testEmptyBlockZeroArguments self assert: (self class compiler evaluate: '[ ] value') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class compiler evaluate: '[ | t | ] value') isNil description: 'Empty blocks in ST-80 should return nil'! ! !OCClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoArgument 1 to: 5 do: [ :index | collection add: [ index ] ]. self assertValues: #(1 2 3 4 5)! ! !OCClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:33'! testBlockArgument | block block1 block2 | block := [ :arg | | temp | temp := arg. [ temp ] ]. block1 := block value: 1. block2 := block value: 2. self assert: block1 value = 1. self assert: block2 value = 2! ! !OCClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoArgumentNotInlined | block | block := [ :index | collection add: [ index ] ]. 1 to: 5 do: block. self assertValues: #(1 2 3 4 5)! ! !OCClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:36'! testMethodArgument | temp block | temp := 0. block := [ [ temp ] ]. temp := 1. block := block value. temp := 2. self assert: block value = 2! ! !OCClosureTests methodsFor: 'testing-todo' stamp: 'lr 3/10/2009 14:51'! testToDoInsideTemp 1 to: 5 do: [ :index | | temp | temp := index. collection add: [ temp ] ]. self assertValues: #(1 2 3 4 5)! ! !OCCompiledMethodIntegrityTests methodsFor: 'test' stamp: 'MarcusDenker 9/5/2013 14:43'! testBlockTemps | newCompiledMethod originalCompiledMethod | (Smalltalk hasClassNamed: #Compiler) ifFalse: [^self skip]. newCompiledMethod := OpalCompiler new source: 'ascentOf: aCharacter ^ [ | temp1 temp2 temp3 | 1= temp1. 2 = temp2. 3 = temp3].'; class: OCMockCompilationClass; compile. originalCompiledMethod := (Smalltalk classNamed: #Compiler) new source: 'ascentOf: aCharacter ^ [ | temp1 temp2 temp3 | 1= temp1. 2 = temp2. 3 = temp3].'; class: OCMockCompilationClass; compile. self assert: newCompiledMethod numArgs = originalCompiledMethod numArgs. self assert: newCompiledMethod numLiterals = originalCompiledMethod numLiterals. self assert: newCompiledMethod numTemps = originalCompiledMethod numTemps. self assert: newCompiledMethod primitive = originalCompiledMethod primitive. self assert: newCompiledMethod header = originalCompiledMethod header! ! !OCCompiledMethodIntegrityTests methodsFor: 'test' stamp: 'MarcusDenker 9/5/2013 14:45'! testPrimitive | newCompiledMethod originalCompiledMethod | (Smalltalk hasClassNamed: #Compiler) ifFalse: [^self skip]. newCompiledMethod := OpalCompiler new source: 'size ^ self basicSize.'; class: OCMockCompilationClass; compile. originalCompiledMethod := (Smalltalk classNamed: #Compiler) new source: 'size ^ self basicSize.'; class: OCMockCompilationClass; compile. self assert: newCompiledMethod numArgs = originalCompiledMethod numArgs. self assert: newCompiledMethod numLiterals = originalCompiledMethod numLiterals. self assert: newCompiledMethod numTemps = originalCompiledMethod numTemps. self assert: newCompiledMethod primitive = originalCompiledMethod primitive. self assert: newCompiledMethod header = originalCompiledMethod header! ! !OCCompiledMethodIntegrityTests methodsFor: 'test' stamp: 'MarcusDenker 9/5/2013 14:44'! testNotUsedArgument | newCompiledMethod originalCompiledMethod | (Smalltalk hasClassNamed: #Compiler) ifFalse: [^self skip]. newCompiledMethod := OpalCompiler new source: 'ascentOf: aCharacter ^ self ascent.'; class: OCMockCompilationClass; compile. originalCompiledMethod := (Smalltalk classNamed: #Compiler) new source: 'ascentOf: aCharacter ^ self ascent.'; class: OCMockCompilationClass; compile. self assert: newCompiledMethod numArgs = originalCompiledMethod numArgs. self assert: newCompiledMethod numLiterals = originalCompiledMethod numLiterals. self assert: newCompiledMethod numTemps = originalCompiledMethod numTemps. self assert: newCompiledMethod primitive = originalCompiledMethod primitive. self assert: newCompiledMethod header = originalCompiledMethod header! ! !OCCompiledMethodIntegrityTests methodsFor: 'test' stamp: 'MarcusDenker 9/5/2013 14:45'! testPragmas | newCompiledMethod originalCompiledMethod | (Smalltalk hasClassNamed: #Compiler) ifFalse: [^self skip]. newCompiledMethod := OpalCompiler new source: 'methodDoublePragma '; class: OCMockCompilationClass; compile. originalCompiledMethod := (Smalltalk classNamed: #Compiler) new source: 'methodDoublePragma '; class: OCMockCompilationClass; compile. self assert: newCompiledMethod numArgs = originalCompiledMethod numArgs. self assert: newCompiledMethod numLiterals = originalCompiledMethod numLiterals. "AdditionalState assertions" self assert: newCompiledMethod literals first selector = originalCompiledMethod literals first selector. self assert: (newCompiledMethod literals first analogousCodeTo: originalCompiledMethod literals first). self assert: (newCompiledMethod literals first instVarNamed: 'method') = newCompiledMethod. self assert: newCompiledMethod literals second = originalCompiledMethod literals second. self assert: newCompiledMethod numTemps = originalCompiledMethod numTemps. self assert: newCompiledMethod primitive = originalCompiledMethod primitive. self assert: newCompiledMethod header = originalCompiledMethod header! ! !OCCompiledMethodIntegrityTests methodsFor: 'test' stamp: 'MarcusDenker 9/5/2013 14:46'! testRemoteTempInVector | newCompiledMethod originalCompiledMethod | (Smalltalk hasClassNamed: #Compiler) ifFalse: [^self skip]. "Here the problem was that the Scope kept both the remote temp answer and the new remote this caused that the number of temps were more than the correnct" newCompiledMethod := OpalCompiler new source: 'value | answer | self do: [:each | answer := each value]. ^answer'; class: Object; compile. originalCompiledMethod := (Smalltalk classNamed: #Compiler) new source: 'value | answer | self do: [:each | answer := each value]. ^answer'; class: Object; compile. self assert: newCompiledMethod numArgs = originalCompiledMethod numArgs. self assert: newCompiledMethod numLiterals = originalCompiledMethod numLiterals. self assert: newCompiledMethod numTemps = originalCompiledMethod numTemps. self assert: newCompiledMethod primitive = originalCompiledMethod primitive. self assert: newCompiledMethod header = originalCompiledMethod header! ! !OCCompilerExceptionsTest methodsFor: 'tests' stamp: 'MarcusDenker 5/25/2013 16:18'! testUnknownSelector self compiling: 'griffle self reallyHopeThisIsntImplementedAnywere2' shouldRaise: OCUnknownSelectorWarning ; compiling: 'griffle [ self reallyHopeThisIsntImplementedAywhere2 ] value' shouldRaise: OCUnknownSelectorWarning! ! !OCCompilerExceptionsTest methodsFor: 'setUp' stamp: 'MarcusDenker 5/25/2013 16:16'! tearDown self removeGeneratedMethods. SmalltalkImage compilerClass: currentCompiler.! ! !OCCompilerExceptionsTest methodsFor: 'tests' stamp: 'MarcusDenker 5/25/2013 11:21'! testUndefinedVariable self compiling: 'griffle | goo | ^ goo' shouldRaise: OCUninitializedVariableWarning ; compiling: 'griffle [ | goo | ^ goo ] value' shouldRaise: OCUninitializedVariableWarning! ! !OCCompilerExceptionsTest methodsFor: 'emulating' stamp: 'MarcusDenker 5/25/2013 11:17'! selectionInterval ^ 1 to: 0! ! !OCCompilerExceptionsTest methodsFor: 'setUp' stamp: 'MarcusDenker 5/25/2013 16:16'! setUp currentCompiler := SmalltalkImage compilerClass. SmalltalkImage compilerClass: OpalCompiler. ! ! !OCCompilerExceptionsTest methodsFor: 'compiling' stamp: 'MarcusDenker 5/25/2013 11:17'! compiling: sourceCode shouldRaise: exceptionClass self should: [ self compile: sourceCode ] raise: exceptionClass! ! !OCCompilerExceptionsTest methodsFor: 'compiling' stamp: 'StephaneDucasse 8/29/2013 21:06'! removeGeneratedMethods self class removeProtocol: 'generated'! ! !OCCompilerExceptionsTest methodsFor: 'compiling' stamp: 'MarcusDenker 5/25/2013 11:17'! interactive ^ true! ! !OCCompilerExceptionsTest methodsFor: 'emulating' stamp: 'MarcusDenker 5/25/2013 11:17'! selectFrom: start to: end ! ! !OCCompilerExceptionsTest methodsFor: 'tests' stamp: 'MarcusDenker 5/25/2013 11:22'! testUndeclaredVariable self compiling: 'griffle ^ goo' shouldRaise: OCUndeclaredVariableWarning ; compiling: 'griffle ^ [ goo ] value' shouldRaise: OCUndeclaredVariableWarning! ! !OCCompilerExceptionsTest methodsFor: 'emulating' stamp: 'MarcusDenker 5/25/2013 11:17'! text ^ text! ! !OCCompilerExceptionsTest methodsFor: 'compiling' stamp: 'MarcusDenker 5/25/2013 11:17'! compile: sourceString text := sourceString. self class compileSilently: text classified: 'generated' notifying: self! ! !OCCompilerExceptionsTest methodsFor: 'tests' stamp: 'MarcusDenker 5/25/2013 11:21'! testUnusedVariable self compiling: 'griffle | goo | ^nil' shouldRaise: OCUnusedVariableWarning.! ! !OCCompilerExceptionsTest methodsFor: 'emulating' stamp: 'MarcusDenker 5/25/2013 11:17'! select ! ! !OCCompilerNotifyingTest commentStamp: ''! A CompilerNotifyingTest is a TestCase for checking that Compiler/Parser notifications are inserted at the right place in a TextEditor. Instance Variables expectedErrorPositions: expectedErrors: failure: morph: text: errorPositions - the position where error text should be inserted for each chunk of text evaluated errors - the error text that should be inserted on evaluation of each chunk of text evaluated failure - an object returned in case of evaluation error and whose identity can be uniquely recognized as a failure morph - the Morph holding the text text - the string containing all the chunks to be evaluated (separated by %) and the expected error messages (`enclosed in back quotes`) this text will be stripped of the error messages before being evaluated. ! !OCCompilerNotifyingTest methodsFor: 'testing-byteCode limits' stamp: 'md 5/23/2013 10:27'! testTooManyArguments self setUpForErrorsIn: '^ ` Too many arguments ->`[:x1 :x2 :x3 :x4 :x5 :x6 :x7 :x8 :x9 :x10 :x11 :x12 :x13 :x14 :x15 :x16 :x17 | ]'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 3/27/2014 11:08'! testExtraneousStatementAfterAReturnInABlock self setUpForErrorsIn: '[ ^1 ` End of statement list encountered ->`2]'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'private' stamp: 'ClementBera 4/16/2013 10:38'! numberOfSelections ^(text occurrencesOf: $%) + 1! ! !OCCompilerNotifyingTest methodsFor: 'testing-byteCode limits' stamp: 'ClementBera 5/14/2013 14:42'! testTooManyTemporaries self setUpForErrorsIn: '| a1 a2 a3 a4 a5 a6 a7 a8 a9 b1 b2 b3 b4 b5 b6 b7 b8 b9 c1 c2 c3 c4 c5 c6 c7 c8 c9 d1 d2 d3 d4 d5 d6 d7 d8 d9 e1 e2 e3 e4 e5 e6 e7 e8 e9 f1 f2 f3 f4 f5 f6 f7 f8 f9 g1 g2 g3 g4 g5 g6 g7 g8 g9 | a1 := a2 := a3 := a4 := a5 := a6 := a7 := a8 := a9 := b1 := b2 := b3 := b4 := b5 := b6 := b7 := b8 := b9 := c1 := c2 := c3 := c4 := c5 := c6 := c7 := c8 := c9 := d1 := d2 := d3 := d4 := d5 := d6 := d7 := d8 := d9 := e1 := e2 := e3 := e4 := e5 := e6 := e7 := e8 := e9 := f1 := f2 := f3 := f4 := f5 := f6 := f7 := f8 := f9 := g1 := g2 := g3 := g4 := g5 := g6 := g7 := g8 := g9 := 1'. self flag: 'fail on jenkins but works on my computer with both compiler I dont know why'. "self should: [ self enumerateAllSelections ] raise: Error. [ self enumerateAllSelections ] on: Error do: [ :ex | self assert: ex messageText equals: 'Cannot compile -- stack including temps is too deep' ]"! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:23'! testMissingExpressionAfterAReturn self setUpForErrorsIn: '^ ` Variable or expression expected ->`. 1 + 2'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'private' stamp: 'ClementBera 5/14/2013 13:22'! evaluateSelection ^ OpalCompiler new source: morph editor selectionAsStream; requestor: morph editor; failBlock: [^failure]; evaluate ! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:17'! testMissingBlockArgumentName self setUpForErrorsIn: '[ :x : ` Variable name expected ->`1]'. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:29'! testUnmatchedExpressionParenthesis self setUpForErrorsIn: '1+(2 ` '')'' expected ->`. '. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'initialize-release' stamp: 'ClementBera 4/16/2013 10:38'! initializeTextWithoutError "Remove the errors from the text to be compiled and answer the text without errors. Meanwhile, collect the expected error messages and their expected position." | input output errorStream positionStream | input := text readStream. output := (String new: text size) writeStream. errorStream := (Array new: self numberOfSelections) writeStream. positionStream := (Array new: self numberOfSelections) writeStream. [output nextPutAll: (input upTo: $`). input atEnd] whileFalse: [positionStream nextPut: output position + 1. errorStream nextPut: (input upTo: $`)]. expectedErrors := errorStream contents. expectedErrorPositions := positionStream contents. ^output contents! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 3/27/2014 11:08'! testExpectedExpressionInBraceArray self setUpForErrorsIn: '{ 1. 2 ` End of statement list encountered ->`3 }'. self enumerateAllSelections. self setUpForErrorsIn: '{ 1. 2. ` Variable or expression expected ->`| x | x}'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:25'! testMissingSeparatorBetweenBlockArgumentAndStatements self setUpForErrorsIn: '[ :x ` ''|'' expected ->`x + 1 ]'. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:28'! testUnmatchedByteArrayBracket self setUpForErrorsIn: '#[ 1 2 ` '']'' expected ->`'. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:29'! testUnmatchedLocalTempDeclarationInABlock self setUpForErrorsIn: '[:z | | x y ` ''|'' expected ->`]'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:28'! testUnmatchedBlockBracket self setUpForErrorsIn: 'nil yourself. [` '']'' expected ->`'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/25/2013 16:45'! testInvalidRadix self setUpForErrorsIn: '1` Reading a number failed: an integer greater than 1 as valid radix expected ->`r0'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'md 5/23/2013 10:25'! testInvalidLiteralCharacter self setUpForErrorsIn: '^ #yourself , #)` Expecting a literal type ->` , #end'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:24'! testMissingMessageAfterACascade self setUpForErrorsIn: 'nil yourself; ` Message expected ->`^ 2'. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'private' stamp: 'ClementBera 4/16/2013 13:21'! evaluateSelectionNumber: n | i start stop | i := start := 1. [stop := morph text indexOf: $% startingAt: start + 1 ifAbsent: morph text size + 1. i = n] whileFalse: [i := i + 1. start := stop + 1]. morph editor selectFrom: start to: stop - 1. ^self evaluateSelection ! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 3/27/2014 11:08'! testMissingPeriodSeparatorBetweenStatements self setUpForErrorsIn: '1 + 2 ` End of statement list encountered ->`^nil'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:29'! testUnmatchedLiteralParenthesis self setUpForErrorsIn: '#( 1 2` '')'' expected ->`'. self enumerateAllSelections. self setUpForErrorsIn: '#( 1 2 ` '')'' expected ->`'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/25/2013 16:33'! testDigitTooLargeForARadix self setUpForErrorsIn: '2r` Reading a number failed: a digit between 0 and 1 expected ->`3'. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:21'! testMissingArgumentAfterABinaryMessage self setUpForErrorsIn: '1 +` Variable or expression expected ->`'. self enumerateAllSelections. self setUpForErrorsIn: '1 + ` Variable or expression expected ->`* 2 + 3'. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/25/2013 17:04'! testUnmatchedStringQuote self setUpForErrorsIn: '^nil printString , ''unfinished string` Unmatched '' in string literal. ->`'. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:28'! testUnmatchedBraceArray self setUpForErrorsIn: '{ 1. 2` expected } ->`'. self enumerateAllSelections. self setUpForErrorsIn: '{ 1. 2 ` expected } ->`'. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'initialize-release' stamp: 'ClementBera 4/16/2013 10:38'! setUpForErrorsIn: aTextWithErrorsEnclosedInBackQuote "Extract the expectedErrors, the expectedErrorPositions and set up a TextMorph containing the text without errors. each section separated by % in aTextWithErrorsEnclosedInBackQuote will be evaluated separately. The expected error message should lie in aTextWithErrorsEnclosedInBackQuote at the expected position, and enclosed in back quotes." text := aTextWithErrorsEnclosedInBackQuote. morph := MockSourceEditor new contents: self initializeTextWithoutError asText.! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:22'! testMissingExpression self setUpForErrorsIn: '| x | x := ` Variable or expression expected ->'. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'ClementBera 4/16/2013 14:26'! testInvalidPrimitive "Not implemented yet. ##primitive:error: #primitive:module:error: skipped, cannot be evaluated"! ! !OCCompilerNotifyingTest methodsFor: 'initialize-release' stamp: 'ClementBera 4/16/2013 10:37'! setUp failure := Object new.! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'ClementBera 4/16/2013 14:26'! testInvalidPragma "Not implemented yet. #pragmaLiteral: #pragmaSequence #pragmaStatement #pragmaPrimitives skipped, cannot be evaluated"! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 16:07'! testAssignmentOfSelf self setUpForErrorsIn: '` Cannot store into ->`self := 1. ^self'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'ClementBera 4/16/2013 14:26'! testInvalidExternalFunctionDeclaration "Not implemented yet. #externalFunctionDeclaration skipped, cannot be evaluated"! ! !OCCompilerNotifyingTest methodsFor: 'private' stamp: 'MarcusDenker 5/23/2013 10:39'! enumerateAllSelections 1 to: self numberOfSelections do: [:n | self assert: (self evaluateSelectionNumber: n) == failure. self assert: morph editor selection asString equals: (expectedErrors at: n). self assert: (expectedErrorPositions at: n) equals: morph editor startIndex. morph editor cut].! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'ClementBera 4/16/2013 13:41'! testEmptyCaseStatement self flag: 'Opal has the correct behavior but the error is not caught' "self setUpForErrorsIn: '^ nil caseOf: { ` At least one case required ->`} '. self enumerateAllSelections."! ! !OCCompilerNotifyingTest methodsFor: 'testing-byteCode limits' stamp: 'ClementBera 5/23/2013 15:28'! testTooManyLiterals self setUpForErrorsIn: '{#(1). #(2). #(3). #(4). #(5). #(6). #(7). #(8). #(9). #(10). #(11). #(12). #(13). #(14). #(15). #(16). #(17). #(18). #(19). #(20). #(21). #(22). #(23). #(24). #(25). #(26). #(27). #(28). #(29). #(30). #(31). #(32). #(33). #(34). #(35). #(36). #(37). #(38). #(39). #(40). #(41). #(42). #(43). #(44). #(45). #(46). #(47). #(48). #(49). #(50). #(51). #(52). #(53). #(54). #(55). #(56). #(57). #(58). #(59). #(60). #(61). #(62). #(63). #(64). #(65). #(66). #(67). #(68). #(69). #(70). #(71). #(72). #(73). #(74). #(75). #(76). #(77). #(78). #(79). #(80). #(81). #(82). #(83). #(84). #(85). #(86). #(87). #(88). #(89). #(90). #(91). #(92). #(93). #(94). #(95). #(96). #(97). #(98). #(99). #(100). #(101). #(102). #(103). #(104). #(105). #(106). #(107). #(108). #(109). #(110). #(111). #(112). #(113). #(114). #(115). #(116). #(117). #(118). #(119). #(120). #(121). #(122). #(123). #(124). #(125). #(126). #(127). #(128). #(129). #(130). #(131). #(132). #(133). #(134). #(135). #(136). #(137). #(138). #(139). #(140). #(141). #(142). #(143). #(144). #(145). #(146). #(147). #(148). #(149). #(150). #(151). #(152). #(153). #(154). #(155). #(156). #(157). #(158). #(159). #(160). #(161). #(162). #(163). #(164). #(165). #(166). #(167). #(168). #(169). #(170). #(171). #(172). #(173). #(174). #(175). #(176). #(177). #(178). #(179). #(180). #(181). #(182). #(183). #(184). #(185). #(186). #(187). #(188). #(189). #(190). #(191). #(192). #(193). #(194). #(195). #(196). #(197). #(198). #(199). #(200). #(201). #(202). #(203). #(204). #(205). #(206). #(207). #(208). #(209). #(210). #(211). #(212). #(213). #(214). #(215). #(216). #(217). #(218). #(219). #(220). #(221). #(222). #(223). #(224). #(225). #(226). #(227). #(228). #(229). #(230). #(231). #(232). #(233). #(234). #(235). #(236). #(237). #(238). #(239). #(240). #(241). #(242). #(243). #(244). #(245). #(246). #(247). #(248). #(249). #(250). #(251). #(252). #(253). #(254). #(255). #(256). `More than 256 literals referenced. You must split or otherwise simplify this method. The 257th literal is: ->`#(257)}'. self should: [ self enumerateAllSelections ] raise: Error. [ self enumerateAllSelections ] on: Error do: [ :exc | exc class = Error. exc messageText = 'too many literals (>256)' ]! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/25/2013 17:03'! testUnmatchedCommentQuote self setUpForErrorsIn: '1+2 "unfinished comment` Unmatched " in comment. ->`'. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:22'! testMissingArgumentAfterAMessageKey self setUpForErrorsIn: '1 to: ` Variable or expression expected ->`:='. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'ClementBera 4/16/2013 14:26'! testInvalidPattern "Not implemented yet. #pattern:inContext: skipped, cannot be evaluated"! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:27'! testTooLargeAnIntegerInALiteralByteArray self setUpForErrorsIn: '#[ 1 2 ` Expecting 8-bit integer ->`256 4 5]'. self enumerateAllSelections! ! !OCCompilerNotifyingTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:29'! testUnmatchedLocalTempDeclaration self setUpForErrorsIn: '| x y ` ''|'' expected ->`'. self enumerateAllSelections.! ! !OCCompilerNotifyingTest methodsFor: 'testing-block arguments' stamp: 'MarcusDenker 5/23/2013 10:46'! testifTrueBlockWithArgument self setUpForErrorsIn: '` ifTrue:ifFalse: takes zero-arg blocks ->`true ifTrue: [:x | 1 + 1 ]'. self enumerateAllSelections. self setUpForErrorsIn: '` ifTrue:ifFalse: takes zero-arg blocks ->`true ifTrue: [:x :y | 1 + 1 ]'. self enumerateAllSelections.! ! !OCCompilerSyntaxErrorNotifyingTest commentStamp: 'nice 2/23/2012 22:09'! A CompilerSyntaxErrorNotifyingTest is a specialization for testing correct handling of non interactive compiler notification. Non interactive is a very relative notion in Smalltalk... Here it means that user interaction will not happen directly in the TextEditor holding source code, but rather thru a SyntaxError window that will pop-up. This test intercept the Notification before the pop-up is raised. ! !OCCompilerSyntaxErrorNotifyingTest methodsFor: 'private' stamp: 'MarcusDenker 5/23/2013 09:49'! enumerateAllSelections "This method intercepts the SyntaxErrorNotification and prevent the SyntaxError morph to open. The notification errorCode hold the source of evaluated sub-selection with inserted error message. This can be compared to expected error notification." 1 to: self numberOfSelections do: [:n | | result | result := [self evaluateSelectionNumber: n] on: SyntaxErrorNotification do: [:exc | | expectedNotification expectedNotificationLocation | expectedNotification := (expectedErrors at: n) allButFirst allButLast: 3. expectedNotificationLocation := (expectedErrorPositions at: n) - (morph editor startIndex - 1). self assert: expectedNotificationLocation equals: exc location. self assert: expectedNotification equals: exc errorMessage asString. exc return: nil]].! ! !OCCompilerSyntaxErrorNotifyingTest methodsFor: 'private' stamp: 'ClementBera 5/14/2013 13:31'! evaluateSelection ^ OpalCompiler new source: morph editor selection readStream; "Note subtle difference versus (morph editor selectionAsStream). The later does not answer the same contents and would raise a SyntaxErrorNotification with wrong sub-selection" failBlock: [^failure]; evaluate! ! !OCCompilerSyntaxErrorNotifyingTest class methodsFor: 'testing' stamp: 'nice 2/22/2012 22:54'! shouldInheritSelectors "This class can recycle all of super tests, it just has to refine internal Compiler evaluation machinery" ^true! ! !OCCompilerTest commentStamp: 'nice 12/3/2007 22:15'! CompilerTest is a holder for SUnit test of Compiler! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 5/25/2013 15:04'! testInBlockTempShadowing interactive := true. self initializeErrorMessage. text := 'temp |var2| [:temp| |var2|]'. self compileWithFailBlock: [ self assert: (errorMessage = 'Name already defined ->'). self assert: (errorLocation = 22). self assert: (errorSource contents = 'temp |var2| [:temp| |var2|]'). ^nil]. self fail. ! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:46'! testNotInteractiveInBlockArgumentInstanceVariableShadowing interactive := false. self initializeErrorMessage. OpalCompiler new source: 'temp [:var1 | ]'; class: MockForCompilation; translate. self assert: ( newTranscript contents = ' MockForCompilation>>temp(var1 is shadowed)'). ! ! !OCCompilerTest methodsFor: 'running' stamp: 'EstebanLorenzano 8/3/2012 15:28'! runCase SystemAnnouncer uniqueInstance suspendAllWhile: [ super runCase ] ! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:54'! testNotInteractiveSiblingBlocksTempShadowing interactive := false. self initializeErrorMessage. OpalCompiler new source: 'temp [:temp | ]. [:temp | ]'; class: MockForCompilation; requestor: self; failBlock: [self fail. ^nil]; translate. self assert: ( newTranscript contents = ''). ! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:56'! testSiblingBlocksInstanceVariableShadowing interactive := true. self initializeErrorMessage. OpalCompiler new source: 'temp [:temp | ].[:temp | |var1|]'; class: MockForCompilation; requestor: self; failBlock: [ self assert: (errorMessage = 'Name already defined ->'). self assert: (errorLocation = 27). ^nil]; translate. self fail. ! ! !OCCompilerTest methodsFor: 'mocking' stamp: 'ClementBera 5/14/2013 13:50'! text ^ text! ! !OCCompilerTest methodsFor: 'running' stamp: 'ClementBera 5/14/2013 13:54'! compile ^ self compileWithFailBlock: [^ nil]! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:48'! testNotInteractiveInBlockTempInstanceVariableShadowing interactive := false. self initializeErrorMessage. OpalCompiler new source: 'temp [:temp | |var1|]'; class: MockForCompilation; requestor: self; failBlock: [self fail. ^nil]; translate. self assert: ( newTranscript contents = ' MockForCompilation>>temp(var1 is shadowed)'). ! ! !OCCompilerTest methodsFor: 'mocking' stamp: 'JorgeRessia 3/4/2010 12:48'! initializeErrorMessage errorMessage := nil. errorLocation := nil. errorSource := nil! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:57'! testSiblingBlocksTempShadowing interactive := true. self initializeErrorMessage. OpalCompiler new source: 'temp [:temp | ]. [:temp | ]'; class: MockForCompilation; failBlock: [self fail. ^nil]; translate. ! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 5/25/2013 15:40'! testEmptyCharacterFail! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:49'! testNotInteractiveInBlockTempShadowing interactive := false. self initializeErrorMessage. OpalCompiler new source: 'temp |var2| [:temp| |var2|]'; class: MockForCompilation; requestor: self; failBlock: [self fail]; translate. self assert: newTranscript contents equals: ' MockForCompilation>>temp(var2 is shadowed)' ! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 5/25/2013 15:13'! testNoShadowing interactive := true. self initializeErrorMessage. text := 'temp |var2| var2:=1'. self compileWithFailBlock: [ self fail. ^nil ]. ! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 5/25/2013 15:01'! testInBlockArgumentInstanceVariableShadowing interactive := true. self initializeErrorMessage. text := 'temp [:var1 | ]'. self compile. self flag: 'display menu instead of going into failblock'. self assert: (errorMessage = 'Name already defined ->'). self assert: (errorLocation = 8). self assert: (errorSource contents = 'temp [:var1 | ]'). ! ! !OCCompilerTest methodsFor: 'mocking' stamp: 'JorgeRessia 3/4/2010 12:49'! notify: aString at: aSmallInteger in: aReadStream errorMessage := aString. errorLocation := aSmallInteger. errorSource := aReadStream. ! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:50'! testNotInteractiveNoShadowing interactive := false. self initializeErrorMessage. OpalCompiler new source: 'temp |var2|'; class: MockForCompilation; requestor: self; failBlock: [self fail. ^nil]; translate. self assert: ( newTranscript contents = ''). ! ! !OCCompilerTest methodsFor: 'literals' stamp: 'MarcusDenker 12/7/2013 23:51'! testScaledDecimalLiterals "Equal ScaledDecimal with different scales should use different slots This is related to http://bugs.squeak.org/view.php?id=6797" "This correctly works when evaluated separately" self deny: (Smalltalk evaluate: '0.5s1') scale = (Smalltalk evaluate: '0.5s2') scale. "But not when evaluated together if literal reduction is too agressive" self deny: (Smalltalk evaluate: '0.5s1 scale = 0.5s2 scale').! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:55'! testReservedNameAsBlockArgumentShadowing interactive := true. #( 'self' 'super' 'thisContext' 'true' 'false' 'nil' ) do: [ :each | self initializeErrorMessage. [ :exit | OpalCompiler new source: 'temp ^ [ :' , each , ' | ^ ' , each , ' ]'; class: MockForCompilation; requestor: self; failBlock: [ exit value ]; translate. self fail ] valueWithExit. self assert: ((errorMessage = 'Variable name expected ->' )or: [ errorMessage = 'Name already defined ->' ]). self assert: errorLocation = 11 ]! ! !OCCompilerTest methodsFor: 'running' stamp: 'simon.denier 6/11/2010 14:24'! tearDown Smalltalk globals at: #Transcript put: originalTranscript. ! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:55'! testReservedNameAsMethodArgumentShadowing interactive := true. #( 'self' 'super' 'thisContext' 'true' 'false' 'nil' ) do: [ :each | self initializeErrorMessage. [ :exit | OpalCompiler new source: 'temp: ' , each , ' ^ ' , each; class: MockForCompilation; requestor: self; failBlock: [ exit value ]; translate. self fail ] valueWithExit. self assert: ((errorMessage = 'Variable name expected ->' )or: [ errorMessage = 'Name already defined ->' ]). self assert: errorLocation = 7 ]! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:58'! testTraitTempShadowing self initializeErrorMessage. OpalCompiler new source: 'testReplaceFromToWithStartingAt | result repStart collection replacementCollection firstIndex secondIndex | replacementCollection := 1.'; class: ArrayTest; failBlock: [self fail.]; translate. self assert: ( newTranscript contents = ' ArrayTest>>testReplaceFromToWithStartingAt(replacementCollection is shadowed) ArrayTest>>testReplaceFromToWithStartingAt(firstIndex is shadowed) ArrayTest>>testReplaceFromToWithStartingAt(secondIndex is shadowed)').! ! !OCCompilerTest methodsFor: 'running' stamp: 'simon.denier 6/11/2010 14:24'! setUp originalTranscript := Transcript. newTranscript := MockTranscript new. Smalltalk globals at: #Transcript put: newTranscript. ! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 5/25/2013 15:03'! testInBlockTempInstanceVariableShadowing interactive := true. self initializeErrorMessage. text := 'temp [:temp | |var1|]'. self compileWithFailBlock: [ self assert: (errorMessage = 'Name already defined ->'). self assert: (errorLocation = 16). self assert: (errorSource contents = 'temp [:temp | |var1|]'). ^nil]. self fail.! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:51'! testNotInteractiveShadowingOfTemp interactive := false. self initializeErrorMessage. OpalCompiler new source: 'temp |temp1 temp1| '; class: MockForCompilation; requestor: self; translate. self assert: ( newTranscript contents = ' MockForCompilation>>temp(temp1 is shadowed)'). ! ! !OCCompilerTest methodsFor: 'mocking' stamp: 'JorgeRessia 3/4/2010 12:49'! interactive ^interactive! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 5/25/2013 15:03'! testInBlockTempArgumentShadowing interactive := true. self initializeErrorMessage. text := 'temp [:temp | |temp|]'. self compileWithFailBlock: [ self assert: (errorMessage = 'Name already defined ->'). self assert: (errorLocation = 16). self assert: (errorSource contents = 'temp [:temp | |temp|]'). ^nil]. self fail. ! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:47'! testNotInteractiveInBlockTempArgumentShadowing interactive := false. self initializeErrorMessage. OpalCompiler new source: 'temp [:temp | |temp|]'; class: MockForCompilation; requestor: self; translate. self assert: newTranscript contents equals: ' MockForCompilation>>temp(temp is shadowed)' ! ! !OCCompilerTest methodsFor: 'literals' stamp: 'ClementBera 5/14/2013 14:03'! testNegativeZero self assert: (OpalCompiler evaluate: '-0.0') hex = Float negativeZero hex.! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 5/25/2013 15:05'! testInstanceVariableShadowing interactive := true. self initializeErrorMessage. text := 'var1 |var1|'. self compileWithFailBlock: [ self assert: (errorMessage = 'Name already defined ->'). self assert: (errorLocation = 7). self assert: (errorSource contents = 'var1 |var1|'). ^nil]. self fail. ! ! !OCCompilerTest methodsFor: 'test shadowing' stamp: 'MarcusDenker 9/5/2013 14:51'! testNotInteractiveSiblingBlocksInstanceVariableShadowing interactive := false. self initializeErrorMessage. OpalCompiler new source: 'temp [:temp | ].[:temp | |var1|]'; class: MockForCompilation; requestor: self; failBlock: [self fail. ^nil]; translate. self assert: ( newTranscript contents = ' MockForCompilation>>temp(var1 is shadowed)'). ! ! !OCCompilerTest methodsFor: 'running' stamp: 'MarcusDenker 5/25/2013 14:53'! compileWithFailBlock: aBlock ^ OpalCompiler new source: text; class: MockForCompilation; requestor: self; failBlock: aBlock; translate. ! ! !OCCopyingTempVariable methodsFor: 'accessing' stamp: 'ClementBera 5/21/2013 14:47'! originalVar: anObject originalVar := anObject! ! !OCCopyingTempVariable methodsFor: 'accessing' stamp: 'ClementBera 5/21/2013 14:47'! originalVar ^ originalVar! ! !OCCopyingTempVariable methodsFor: 'debugging' stamp: 'ClementBera 5/21/2013 14:52'! definingScope ^ originalVar scope ! ! !OCCopyingTempVariable methodsFor: 'temp vector' stamp: 'MarcusDenker 11/15/2012 17:09'! tempVectorForTempStoringIt "If I am stroring a temp Vector, this method returns this victor. useful for analysis e.g. which variables are active in a context" | searchScope | self isStoringTempVector ifFalse: [^nil]. searchScope := scope. [searchScope isInstanceScope or: [searchScope tempVectorName = name]] whileFalse: [searchScope := searchScope outerScope]. searchScope isInstanceScope ifTrue: [ ^nil] "not found" ifFalse: [^ searchScope tempVector] ! ! !OCCopyingTempVariable methodsFor: 'debugging' stamp: 'MarcusDenker 12/18/2012 15:09'! indexInTempVectorFromIR: aName ^(scope node irInstruction tempVectorNamed: name) indexForVarNamed: aName.! ! !OCCopyingTempVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/9/2010 16:06'! isCopying ^true! ! !OCCopyingTempVariable methodsFor: 'debugging' stamp: 'MarcusDenker 12/18/2012 15:08'! writeFromContext: aContext scope: contextScope value: aValue | myContext myScope | "take care to set the copy correctly up to the definition" myContext := aContext. myScope := contextScope. [myScope hasCopyingTempNamed: name] whileTrue: [ super writeFromContext: myContext scope: myScope value: aValue. myContext := myContext outerContext. myScope := myScope outerScope. myScope isInstanceScope ifTrue: [^aValue] ]. ^aValue. ! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testIfNotNil1Arg self assert: (5 ifNotNil: [ :a | a printString ]) = '5'. self assert: (nil ifNotNil: [ :a | a printString ]) isNil! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'MarcusDenker 5/13/2013 13:12'! testIfNilIfNotNil0Arg self assert: (5 ifNil: [#foo] ifNotNil: [#bar]) = #bar. self assert: (nil ifNil: [#foo] ifNotNil: [#bar]) = #foo! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testIfNotNil1ArgAsVar | block | block := [ :a | a printString ]. self assert: (5 ifNotNil: block) = '5'. self assert: (nil ifNotNil: block) isNil! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testIfNotNil0Arg self assert: (5 ifNotNil: [ #foo ]) = #foo. self assert: (nil ifNotNil: [ #foo ]) isNil! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:36'! testIfNotNilIfNil1ArgAsVar | block1 block2 | block1 := [#foo]. block2 := [:a | a printString]. self assert: (5 ifNotNil: block2 ifNil: block1) = '5'. self assert: (nil ifNotNil: block2 ifNil: block1) = #foo! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! testIfNotNil0ArgAsVar | block | block := [ #foo ]. self assert: (5 ifNotNil: block) = #foo. self assert: (nil ifNotNil: block) isNil! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:33'! testIfNilIfNotNil1ArgAsVar | block1 block2 | block1 := [#foo]. block2 := [:a | a printString]. self assert: (5 ifNil: block1 ifNotNil: block2) = '5'. self assert: (nil ifNil: block1 ifNotNil: block2) = #foo! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'vb 4/15/2007 12:25'! testIfNilIfNotNil1Arg self assert: (5 ifNil: [#foo] ifNotNil: [:a | a printString]) = '5'. self assert: (nil ifNil: [#foo] ifNotNil: [:a | a printString]) = #foo! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:43'! testIfNilIfNotNil0ArgAsVar | block1 block2 | block1 := [#foo]. block2 := [#bar]. self assert: (5 ifNil: block1 ifNotNil: block2) = #bar. self assert: (nil ifNil: block1 ifNotNil: block2) = #foo! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:35'! testIfNotNilIfNil0Arg self assert: (5 ifNotNil: [#foo] ifNil: [#bar]) = #foo. self assert: (nil ifNotNil: [#foo] ifNil: [#bar]) = #bar! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:36'! testIfNotNilIfNil0ArgAsVar | block1 block2 | block1 := [#foo]. block2 := [#bar]. self assert: (5 ifNotNil: block2 ifNil: block1) = #bar. self assert: (nil ifNotNil: block2 ifNil: block1) = #foo! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'vb 4/16/2007 11:35'! testIfNotNilIfNil1Arg self assert: (5 ifNotNil: [:a | a printString] ifNil: [#foo]) = '5'. self assert: (nil ifNotNil: [:a | a printString] ifNil: [#foo]) = #foo! ! !OCIfNotNilTests methodsFor: 'tests' stamp: 'MarcusDenker 4/17/2013 15:02'! testIfNotNil1ArgWithStatement self assert: (5 ifNotNil: [ :a | 3. a ]) = 5. self assert: (5 ifNotNil: [ :a | a. 3 ]) = 3.! ! !OCInstanceScope methodsFor: 'testing' stamp: 'ajh 7/8/2004 20:26'! isInstanceScope ^ true! ! !OCInstanceScope methodsFor: 'initialization' stamp: 'MarcusDenker 5/18/2013 10:44'! initialize vars := OCKeyedSet keyBlock: [:var | var name]. selfVar := OCSpecialVariable new name: 'self'; scope: self; yourself. superVar := OCSpecialVariable new name: 'super'; scope: self; yourself.! ! !OCInstanceScope methodsFor: 'acessing' stamp: 'MarcusDenker 12/17/2012 15:18'! allTemps ^#()! ! !OCInstanceScope methodsFor: 'lookup' stamp: 'MarcusDenker 9/1/2010 15:32'! lookupVar: name "Return a ScopeVar for my inst var with this name. Return nil if none found" name = 'self' ifTrue: [^ selfVar]. name = 'super' ifTrue: [^ superVar]. ^ vars at: name ifAbsent: [self outerScope lookupVar: name]! ! !OCInstanceScope methodsFor: 'lookup' stamp: 'MarcusDenker 6/14/2013 13:34'! lookupVarForDeclaration: name "Return a ScopeVar for my inst var with this name. Return nil if none found" name = 'self' ifTrue: [^ selfVar]. name = 'super' ifTrue: [^ superVar]. ^ vars at: name ifAbsent: [self outerScope lookupVarForDeclaration: name]! ! !OCInstanceScope methodsFor: 'scope' stamp: 'MarcusDenker 9/9/2010 17:22'! newMethodScope ^ OCMethodScope new outerScope: self! ! !OCInstanceScope methodsFor: 'acessing' stamp: 'ms 7/10/2007 17:58'! instanceScope ^self! ! !OCInstanceScope methodsFor: 'initializing' stamp: 'MarcusDenker 6/29/2012 15:38'! vars: names vars := Dictionary new. names withIndexDo: [:name :index | vars at: name put: (OCInstanceVariable new name: name; index: index; scope: self; yourself)]. ! ! !OCInstanceVariable methodsFor: 'accessing' stamp: 'MarcusDenker 8/27/2010 11:09'! index ^ index! ! !OCInstanceVariable methodsFor: 'emitting' stamp: 'MarcusDenker 8/27/2010 11:17'! emitStore: methodBuilder methodBuilder storeInstVar: index! ! !OCInstanceVariable methodsFor: 'accessing' stamp: 'MarcusDenker 8/27/2010 11:05'! name: anObject name := anObject! ! !OCInstanceVariable methodsFor: 'emitting' stamp: 'MarcusDenker 8/27/2010 11:17'! emitValue: methodBuilder methodBuilder pushInstVar: index. ! ! !OCInstanceVariable methodsFor: 'accessing' stamp: 'MarcusDenker 8/27/2010 11:09'! index: anObject index := anObject! ! !OCInstanceVariable methodsFor: '*AST-Interpreter-Core' stamp: 'GuillermoPolito 5/14/2013 11:10'! readWith: anInterpreter inNode: aVariableNode ^ anInterpreter readInstVarAt: index named: name! ! !OCInstanceVariable methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 5/22/2013 15:44'! specialCommands ^ SugsSuggestionFactory commandsForInstanceVariable.! ! !OCInstanceVariable methodsFor: 'testing' stamp: 'MarcusDenker 8/27/2010 11:16'! isInstance ^true ! ! !OCInstanceVariable methodsFor: 'accessing' stamp: 'MarcusDenker 8/27/2010 11:05'! name ^ name! ! !OCInstanceVariable methodsFor: '*AST-Interpreter-Core' stamp: 'GuillermoPolito 5/14/2013 11:09'! accept: anInterpreter assign: aValue inNode: aVariableNode ^ anInterpreter write: aValue at: index named: name! ! !OCKeyedSet commentStamp: ''! Like Set except a key of every element is used for hashing and searching instead of the element itself. keyBlock gets the key of an element.! !OCKeyedSet methodsFor: 'adding' stamp: 'MarcusDenker 5/12/2011 13:43'! like: anObject "Answer an object in the receiver that is equal to anObject, nil if no such object is found. Relies heavily on hash properties" | index | ^(index := self scanFor: (keyBlock value: anObject)) = 0 ifFalse: [array at: index] ifTrue: [nil]! ! !OCKeyedSet methodsFor: 'testing' stamp: 'CamilloBruni 7/3/2013 13:20'! isHealthy "Opal developers plan to remove this class so for the moment we just return true/" ^ true! ! !OCKeyedSet methodsFor: 'adding' stamp: 'ajh 12/4/2001 05:27'! addAll: aCollection "Include all the elements of aCollection as the receiver's elements" (aCollection respondsTo: #associationsDo:) ifTrue: [aCollection associationsDo: [:ass | self add: ass]] ifFalse: [aCollection do: [:each | self add: each]]. ^ aCollection! ! !OCKeyedSet methodsFor: 'initialization' stamp: 'MarcusDenker 8/20/2010 11:22'! initialize: n super initialize: n. keyBlock := [:element | element key]. ! ! !OCKeyedSet methodsFor: 'private' stamp: 'MarcusDenker 8/12/2010 15:55'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | element start finish | finish := array size. start := (anObject hash \\ finish) + 1. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element := array at: index) isNil or: [(keyBlock value: element) = anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element := array at: index) isNil or: [(keyBlock value: element) = anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !OCKeyedSet methodsFor: 'removing' stamp: 'MarcusDenker 8/12/2010 15:55'! removeKey: key ifAbsent: aBlock | index obj | index := self findElementOrNil: key. (obj := array at: index) ifNil: [ ^ aBlock value ]. array at: index put: nil. tally := tally - 1. self fixCollisionsFrom: index. ^ obj! ! !OCKeyedSet methodsFor: 'accessing' stamp: 'ajh 9/5/2000 03:58'! at: key ifPresent: aBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." | v | v := self at: key ifAbsent: [^ nil]. ^ aBlock value: v ! ! !OCKeyedSet methodsFor: 'accessing' stamp: 'ajh 9/5/2000 03:57'! at: key "Answer the value associated with the key." ^ self at: key ifAbsent: [self errorKeyNotFound]! ! !OCKeyedSet methodsFor: 'adding' stamp: 'md 3/14/2006 12:37'! add: newObject "Include newObject as one of the receiver's elements, but only if not already present. Answer newObject." | index | newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. index := self findElementOrNil: (keyBlock value: newObject). (array at: index) ifNil: [self atNewIndex: index put: newObject]. ^ newObject! ! !OCKeyedSet methodsFor: 'accessing' stamp: 'MarcusDenker 8/18/2010 19:13'! at: key ifAbsent: aBlock "Answer the value associated with the key or, if key isn't found, answer the result of evaluating aBlock." ^(array at: (self findElementOrNil: key)) ifNil: [aBlock value] ifNotNil: [:o | o]. ! ! !OCKeyedSet methodsFor: 'private' stamp: 'ajh 3/29/2001 19:04'! errorKeyNotFound self error: 'key not found'! ! !OCKeyedSet methodsFor: 'testing' stamp: 'MarcusDenker 8/13/2010 11:38'! includesKey: key ^ (array at: (self findElementOrNil: key)) notNil! ! !OCKeyedSet methodsFor: 'initialize' stamp: 'ajh 9/5/2000 03:36'! keyBlock: oneArgBlock "When evaluated return the key of the argument which will be an element of the set" keyBlock := oneArgBlock! ! !OCKeyedSet methodsFor: 'private' stamp: 'MarcusDenker 8/12/2010 15:55'! fixCollisionsFrom: start "The element at start has been removed and replaced by nil. This method moves forward from there, relocating any entries that had been placed below due to collisions with this one" | element index | index := start. [ (element := array at: (index := index \\ array size + 1)) isNil ] whileFalse: [ | newIndex | (newIndex := self findElementOrNil: (keyBlock value: element)) = index ifFalse: [ array swap: index with: newIndex ] ]! ! !OCKeyedSet methodsFor: 'accessing' stamp: 'ajh 12/10/2000 15:42'! at: key ifAbsentPut: aBlock "Answer the value associated with the key or, if key isn't found, add the result of evaluating aBlock to self" ^ self at: key ifAbsent: [self add: aBlock value]! ! !OCKeyedSet methodsFor: 'private' stamp: 'ajh 12/13/2001 00:17'! rehash | newSelf | newSelf := self species new: self size. newSelf keyBlock: keyBlock. self do: [:each | newSelf noCheckAdd: each]. array := newSelf array! ! !OCKeyedSet methodsFor: 'accessing' stamp: 'ajh 7/3/2004 17:55'! keys | keys | keys := Set new. self keysDo: [:key | keys add: key]. ^ keys! ! !OCKeyedSet methodsFor: 'copying' stamp: 'nice 6/16/2009 20:56'! copyEmpty ^super copyEmpty keyBlock: keyBlock copy! ! !OCKeyedSet methodsFor: 'adding' stamp: 'ajh 6/3/2002 10:11'! member: newObject "Include newObject as one of the receiver's elements, if already exists just return it" | index | newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. index := self findElementOrNil: (keyBlock value: newObject). (array at: index) ifNotNil: [^ array at: index]. self atNewIndex: index put: newObject. ^ newObject! ! !OCKeyedSet methodsFor: 'removing' stamp: 'MarcusDenker 8/12/2010 15:55'! remove: oldObject ifAbsent: aBlock | index | index := self findElementOrNil: (keyBlock value: oldObject). (array at: index) ifNil: [ ^ aBlock value ]. array at: index put: nil. tally := tally - 1. self fixCollisionsFrom: index. ^ oldObject! ! !OCKeyedSet methodsFor: 'removing' stamp: 'ajh 3/29/2001 19:03'! removeKey: key ^ self removeKey: key ifAbsent: [self errorKeyNotFound]! ! !OCKeyedSet methodsFor: 'testing' stamp: 'MarcusDenker 8/13/2010 11:38'! includes: anObject ^ (array at: (self findElementOrNil: (keyBlock value: anObject))) notNil! ! !OCKeyedSet methodsFor: 'accessing' stamp: 'ajh 7/3/2004 17:54'! keysDo: block self do: [:item | block value: (keyBlock value: item)]! ! !OCKeyedSet methodsFor: 'private' stamp: 'ajh 9/5/2000 03:46'! noCheckAdd: anObject array at: (self findElementOrNil: (keyBlock value: anObject)) put: anObject. tally := tally + 1! ! !OCKeyedSet methodsFor: 'removing' stamp: 'nice 12/30/2008 19:01'! removeAll "See super." | tmp | tmp := keyBlock. super removeAll. keyBlock := tmp! ! !OCKeyedSet class methodsFor: 'instance creation' stamp: 'ajh 10/23/2000 23:16'! keyBlock: oneArgBlock "Create a new KeySet whose way to access an element's key is by executing oneArgBlock on the element" ^ self new keyBlock: oneArgBlock! ! !OCLiteralList commentStamp: 'ajh 3/25/2003 00:31'! Holds a unique ordered collection of literals! !OCLiteralList methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:21'! indexOf: anElement startingAt: start ifAbsent: exceptionBlock start to: self size do: [:index | ((self at: index) literalEqual: anElement) ifTrue: [^ index]]. ^ exceptionBlock value! ! !OCLiteralList methodsFor: 'adding' stamp: 'ajh 3/6/2003 18:00'! addLast: object "Only add if not already in list" (equalitySet includes: object) ifTrue: [^ object]. equalitySet add: object. super addLast: object. ^ object ! ! !OCLiteralList methodsFor: 'private' stamp: 'MarcusDenker 8/21/2010 13:05'! setCollection: anArray super setCollection: anArray. equalitySet := OCLiteralSet new: anArray size. ! ! !OCLiteralSet commentStamp: 'ajh 3/25/2003 00:33'! Holds a unique set of literals. Literal objects are equal if they are #= plus they are the same class. This set uses this rule for finding elements. Example: Set new add: 'anthony'; add: #anthony; size "= 1" LiteralSet new add: 'anthony'; add: #anthony; size "= 2" ! !OCLiteralSet methodsFor: 'adding' stamp: 'ajh 12/9/2001 16:03'! add: newObject "Include newObject as one of the receiver's elements. If equivalent is already present don't add and return equivalent object" | index | newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. index := self findElementOrNil: newObject. ^ (array at: index) ifNil: [self atNewIndex: index put: newObject. newObject] ifNotNil: [array at: index]! ! !OCLiteralSet methodsFor: 'private' stamp: 'MarcusDenker 8/12/2010 15:54'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | element start finish | start := (anObject hash \\ array size) + 1. finish := array size. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element := array at: index) isNil or: [element literalEqual: anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element := array at: index) isNil or: [element literalEqual: anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !OCLiteralVariable commentStamp: 'ajh 3/24/2003 21:53'! I am a global, pool, or class variable.! !OCLiteralVariable methodsFor: 'accessing' stamp: 'ms 8/5/2006 14:35'! value ^assoc value! ! !OCLiteralVariable methodsFor: 'emitting' stamp: 'JorgeRessia 4/19/2010 09:37'! emitStore: methodBuilder methodBuilder storeIntoLiteralVariable: assoc. ! ! !OCLiteralVariable methodsFor: 'initializing' stamp: 'ajh 2/26/2003 17:31'! assoc: anAssociation assoc := anAssociation! ! !OCLiteralVariable methodsFor: 'emitting' stamp: 'JorgeRessia 4/19/2010 09:37'! emitValue: methodBuilder methodBuilder pushLiteralVariable: assoc.! ! !OCLiteralVariable methodsFor: '*AST-Interpreter-Core' stamp: 'GuillermoPolito 5/14/2013 11:10'! readWith: anInterpreter inNode: aVariableNode ^ self value! ! !OCLiteralVariable methodsFor: 'accessing' stamp: 'GiselaDecuzzi 5/22/2013 15:06'! assoc ^ assoc! ! !OCLiteralVariable methodsFor: '*SmartSuggestions' stamp: 'MarcusDenker 9/20/2013 15:05'! specialCommands (self isLiteralVariable and: [Smalltalk globals includesAssociation: self assoc ]) ifTrue:[ ^SugsSuggestionFactory commandsForClass]. (self isLiteralVariable and: [(Smalltalk globals includesAssociation: self assoc ) not]) ifTrue:[^SugsSuggestionFactory commandsForClassVariable]. ! ! !OCLiteralVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/20/2013 13:28'! isLiteralVariable ^true.! ! !OCLiteralVariable methodsFor: 'testing' stamp: 'ajh 7/8/2004 16:25'! isGlobal ^ true! ! !OCLiteralVariable methodsFor: 'accessing' stamp: 'ajh 7/2/2004 14:15'! name ^ assoc name! ! !OCLiteralVariable methodsFor: '*AST-Interpreter-Core' stamp: 'MarcusDenker 7/24/2013 15:55'! accept: aVisitor assign: aValue inNode: aVariableNode ^self assoc value: aValue! ! !OCMethodScope commentStamp: ''! I am the scope for a Method! !OCMethodScope methodsFor: 'testing' stamp: 'MarcusDenker 8/27/2010 11:31'! isMethodScope ^true! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:36'! testReturnBlockInMethod | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'methodArgument: anObject ^ [ anObject ]'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '13 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '14 <8F 10 00 02> closureNumCopied: 1 numArgs: 0 bytes 18 to 19'. self assert: (bytecode at: (index := index + 1)) = '18 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '19 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '20 <7C> returnTop'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'other-tests' stamp: 'MarcusDenker 9/5/2013 14:32'! testDifferentBlocksWithSameArgumentName | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'exampleNestedBlock | b c z | b := [:a | z := 2. z + a]. c := [:a | z + a]. ^ (b value: 2) + (c value: 1)'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '13 <8A 01> push: (Array new: 1)'. self assert: (bytecode at: (index := index + 1)) = '15 <6A> popIntoTemp: 2'. self assert: (bytecode at: (index := index + 1)) = '16 <12> pushTemp: 2'. self assert: (bytecode at: (index := index + 1)) = '17 <8F 11 00 0A> closureNumCopied: 1 numArgs: 1 bytes 21 to 30'. self assert: (bytecode at: (index := index + 1)) = '21 <77> pushConstant: 2'. self assert: (bytecode at: (index := index + 1)) = '22 <8E 00 01> popIntoTemp: 0 inVectorAt: 1'. self assert: (bytecode at: (index := index + 1)) = '25 <8C 00 01> pushTemp: 0 inVectorAt: 1'. self assert: (bytecode at: (index := index + 1)) = '28 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '29 send: +'. self assert: (bytecode at: (index := index + 1)) = '30 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '31 <68> popIntoTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '32 <12> pushTemp: 2'. self assert: (bytecode at: (index := index + 1)) = '33 <8F 11 00 06> closureNumCopied: 1 numArgs: 1 bytes 37 to 42'. self assert: (bytecode at: (index := index + 1)) = '37 <8C 00 01> pushTemp: 0 inVectorAt: 1'. self assert: (bytecode at: (index := index + 1)) = '40 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '41 send: +'. self assert: (bytecode at: (index := index + 1)) = '42 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '43 <69> popIntoTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '44 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '45 <77> pushConstant: 2'. self assert: (bytecode at: (index := index + 1)) = '46 send: value:'. self assert: (bytecode at: (index := index + 1)) = '47 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '48 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '49 send: value:'. self assert: (bytecode at: (index := index + 1)) = '50 send: +'. self assert: (bytecode at: (index := index + 1)) = '51 <7C> returnTop'.! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'test - block returning' stamp: 'MarcusDenker 9/5/2013 14:28'! testBlockReturning | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'open (self announcements at: self index ifAbsent: [ ^ self ]) open'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '29 <70> self'. self assert: (bytecode at: (index := index + 1)) = '30 send: announcements'. self assert: (bytecode at: (index := index + 1)) = '31 <70> self'. self assert: (bytecode at: (index := index + 1)) = '32 send: index'. self assert: (bytecode at: (index := index + 1)) = '33 <8F 00 00 01> closureNumCopied: 0 numArgs: 0 bytes 37 to 37'. self assert: (bytecode at: (index := index + 1)) = '37 <78> returnSelf'. self assert: (bytecode at: (index := index + 1)) = '38 send: at:ifAbsent:'. self assert: (bytecode at: (index := index + 1)) = '39 send: open'. self assert: (bytecode at: (index := index + 1)) = '40 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '41 <78> returnSelf'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:33'! testMethodTemp | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'testMethodTemp | block1 block2 | block1 := self methodArgument: 1. block2 := self methodArgument: 2. self assert: block1 value = 1. self assert: block2 value = 2'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '21 <70> self'. self assert: (bytecode at: (index := index + 1)) = '22 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '23 send: methodArgument:'. self assert: (bytecode at: (index := index + 1)) = '24 <68> popIntoTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '25 <70> self'. self assert: (bytecode at: (index := index + 1)) = '26 <77> pushConstant: 2'. self assert: (bytecode at: (index := index + 1)) = '27 send: methodArgument:'. self assert: (bytecode at: (index := index + 1)) = '28 <69> popIntoTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '29 <70> self'. self assert: (bytecode at: (index := index + 1)) = '30 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '31 send: value'. self assert: (bytecode at: (index := index + 1)) = '32 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '33 send: ='. self assert: (bytecode at: (index := index + 1)) = '34 send: assert:'. self assert: (bytecode at: (index := index + 1)) = '35 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '36 <70> self'. self assert: (bytecode at: (index := index + 1)) = '37 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '38 send: value'. self assert: (bytecode at: (index := index + 1)) = '39 <77> pushConstant: 2'. self assert: (bytecode at: (index := index + 1)) = '40 send: ='. self assert: (bytecode at: (index := index + 1)) = '41 send: assert:'. self assert: (bytecode at: (index := index + 1)) = '42 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '43 <78> returnSelf'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:29'! testBlockTemp | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'testBlockTemp | block block1 block2 | block := [ :arg | [ arg ] ]. block1 := block value: 1. block2 := block value: 2. self assert: block1 value = 1. self assert: block2 value = 2'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '17 <8F 01 00 08> closureNumCopied: 0 numArgs: 1 bytes 21 to 28'. self assert: (bytecode at: (index := index + 1)) = '21 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '22 <8F 10 00 02> closureNumCopied: 1 numArgs: 0 bytes 26 to 27'. self assert: (bytecode at: (index := index + 1)) = '26 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '27 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '28 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '29 <68> popIntoTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '30 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '31 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '32 send: value:'. self assert: (bytecode at: (index := index + 1)) = '33 <69> popIntoTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '34 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '35 <77> pushConstant: 2'. self assert: (bytecode at: (index := index + 1)) = '36 send: value:'. self assert: (bytecode at: (index := index + 1)) = '37 <6A> popIntoTemp: 2'. self assert: (bytecode at: (index := index + 1)) = '38 <70> self'. self assert: (bytecode at: (index := index + 1)) = '39 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '40 send: value'. self assert: (bytecode at: (index := index + 1)) = '41 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '42 send: ='. self assert: (bytecode at: (index := index + 1)) = '43 send: assert:'. self assert: (bytecode at: (index := index + 1)) = '44 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '45 <70> self'. self assert: (bytecode at: (index := index + 1)) = '46 <12> pushTemp: 2'. self assert: (bytecode at: (index := index + 1)) = '47 send: value'. self assert: (bytecode at: (index := index + 1)) = '48 <77> pushConstant: 2'. self assert: (bytecode at: (index := index + 1)) = '49 send: ='. self assert: (bytecode at: (index := index + 1)) = '50 send: assert:'. self assert: (bytecode at: (index := index + 1)) = '51 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '52 <78> returnSelf'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'other-tests' stamp: 'MarcusDenker 9/5/2013 14:34'! testModulePrimitive | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'copyBitsAgain "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed'; class: BitBlt; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = ''. self assert: (bytecode at: (index := index + 1)) = '21 <70> self'. self assert: (bytecode at: (index := index + 1)) = '22 send: primitiveFailed'. self assert: (bytecode at: (index := index + 1)) = '23 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '24 <78> returnSelf'.! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:38'! testToDoOutsideTempNotInlined "there seems to be a better indexzation of the temps we have one more" | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'testToDoOutsideTempNotInlined | block temp | block := [ :index | temp := index. collection add: [ temp ] ]. 1 to: 5 do: block. self assertValues: #(5 5 5 5 5)'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '33 <8A 01> push: (Array new: 1)'. self assert: (bytecode at: (index := index + 1)) = '35 <69> popIntoTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '36 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '37 <8F 11 00 10> closureNumCopied: 1 numArgs: 1 bytes 41 to 56'. self assert: (bytecode at: (index := index + 1)) = '41 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '42 <8E 00 01> popIntoTemp: 0 inVectorAt: 1'. self assert: (bytecode at: (index := index + 1)) = '45 <00> pushRcvr: 0'. self assert: (bytecode at: (index := index + 1)) = '46 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '47 <8F 10 00 04> closureNumCopied: 1 numArgs: 0 bytes 51 to 54'. self assert: (bytecode at: (index := index + 1)) = '51 <8C 00 00> pushTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '54 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '55 send: add:'. self assert: (bytecode at: (index := index + 1)) = '56 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '57 <68> popIntoTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '58 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '59 <21> pushConstant: 5'. self assert: (bytecode at: (index := index + 1)) = '60 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '61 send: to:do:'. self assert: (bytecode at: (index := index + 1)) = '62 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '63 <70> self'. self assert: (bytecode at: (index := index + 1)) = '64 <23> pushConstant: #(5 5 5 5 5)'. self assert: (bytecode at: (index := index + 1)) = '65 send: assertValues:'. self assert: (bytecode at: (index := index + 1)) = '66 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '67 <78> returnSelf'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:38'! testWhileModificationAfterNotInlined "The bytecodes integers are different in some cases." | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'testWhileModificationAfterNotInlined | index block | index := 0. block := [ collection add: [ index ]. index := index + 1 ]. [ index < 5 ] whileTrue: block. self assertValues: #(5 5 5 5 5)'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '33 <8A 01> push: (Array new: 1)'. self assert: (bytecode at: (index := index + 1)) = '35 <69> popIntoTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '36 <75> pushConstant: 0'. self assert: (bytecode at: (index := index + 1)) = '37 <8E 00 01> popIntoTemp: 0 inVectorAt: 1'. self assert: (bytecode at: (index := index + 1)) = '40 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '41 <8F 10 00 15> closureNumCopied: 1 numArgs: 0 bytes 45 to 65'. self assert: (bytecode at: (index := index + 1)) = '45 <00> pushRcvr: 0'. self assert: (bytecode at: (index := index + 1)) = '46 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '47 <8F 10 00 04> closureNumCopied: 1 numArgs: 0 bytes 51 to 54'. self assert: (bytecode at: (index := index + 1)) = '51 <8C 00 00> pushTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '54 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '55 send: add:'. self assert: (bytecode at: (index := index + 1)) = '56 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '57 <8C 00 00> pushTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '60 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '61 send: +'. self assert: (bytecode at: (index := index + 1)) = '62 <8D 00 00> storeIntoTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '65 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '66 <68> popIntoTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '67 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '68 <8F 10 00 06> closureNumCopied: 1 numArgs: 0 bytes 72 to 77'. self assert: (bytecode at: (index := index + 1)) = '72 <8C 00 00> pushTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '75 <21> pushConstant: 5'. self assert: (bytecode at: (index := index + 1)) = '76 send: <'. self assert: (bytecode at: (index := index + 1)) = '77 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '78 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '79 send: whileTrue:'. self assert: (bytecode at: (index := index + 1)) = '80 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '81 <70> self'. self assert: (bytecode at: (index := index + 1)) = '82 <23> pushConstant: #(5 5 5 5 5)'. self assert: (bytecode at: (index := index + 1)) = '83 send: assertValues:'. self assert: (bytecode at: (index := index + 1)) = '84 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '85 <78> returnSelf'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:40'! testWhileModificationBeforeNotInlined "The bytecodes integers are different in some cases." | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'testWhileModificationBeforeNotInlined | index block | index := 0. block := [ index := index + 1. collection add: [ index ] ]. [ index < 5 ] whileTrue: block. self assertValues: #(5 5 5 5 5)'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '33 <8A 01> push: (Array new: 1)'. self assert: (bytecode at: (index := index + 1)) = '35 <69> popIntoTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '36 <75> pushConstant: 0'. self assert: (bytecode at: (index := index + 1)) = '37 <8E 00 01> popIntoTemp: 0 inVectorAt: 1'. self assert: (bytecode at: (index := index + 1)) = '40 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '41 <8F 10 00 14> closureNumCopied: 1 numArgs: 0 bytes 45 to 64'. self assert: (bytecode at: (index := index + 1)) = '45 <8C 00 00> pushTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '48 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '49 send: +'. self assert: (bytecode at: (index := index + 1)) = '50 <8E 00 00> popIntoTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '53 <00> pushRcvr: 0'. self assert: (bytecode at: (index := index + 1)) = '54 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '55 <8F 10 00 04> closureNumCopied: 1 numArgs: 0 bytes 59 to 62'. self assert: (bytecode at: (index := index + 1)) = '59 <8C 00 00> pushTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '62 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '63 send: add:'. self assert: (bytecode at: (index := index + 1)) = '64 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '65 <68> popIntoTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '66 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '67 <8F 10 00 06> closureNumCopied: 1 numArgs: 0 bytes 71 to 76'. self assert: (bytecode at: (index := index + 1)) = '71 <8C 00 00> pushTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '74 <21> pushConstant: 5'. self assert: (bytecode at: (index := index + 1)) = '75 send: <'. self assert: (bytecode at: (index := index + 1)) = '76 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '77 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '78 send: whileTrue:'. self assert: (bytecode at: (index := index + 1)) = '79 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '80 <70> self'. self assert: (bytecode at: (index := index + 1)) = '81 <23> pushConstant: #(5 5 5 5 5)'. self assert: (bytecode at: (index := index + 1)) = '82 send: assertValues:'. self assert: (bytecode at: (index := index + 1)) = '83 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '84 <78> returnSelf'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:30'! testWhileWithTempNotInlined "The bytecodes integers are different in some cases." | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'testWhileWithTempNotInlined | index block | index := 0. block := [ | temp | temp := index := index + 1. collection add: [ temp ] ]. [ index < 5 ] whileTrue: block. self assertValues: #(1 2 3 4 5)'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '33 <8A 01> push: (Array new: 1)'. self assert: (bytecode at: (index := index + 1)) = '35 <69> popIntoTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '36 <75> pushConstant: 0'. self assert: (bytecode at: (index := index + 1)) = '37 <8E 00 01> popIntoTemp: 0 inVectorAt: 1'. self assert: (bytecode at: (index := index + 1)) = '40 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '41 <8F 10 00 14> closureNumCopied: 1 numArgs: 0 bytes 45 to 64'. self assert: (bytecode at: (index := index + 1)) = '45 <73> pushConstant: nil'. self assert: (bytecode at: (index := index + 1)) = '46 <8C 00 00> pushTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '49 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '50 send: +'. self assert: (bytecode at: (index := index + 1)) = '51 <8D 00 00> storeIntoTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '54 <69> popIntoTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '55 <00> pushRcvr: 0'. self assert: (bytecode at: (index := index + 1)) = '56 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '57 <8F 10 00 02> closureNumCopied: 1 numArgs: 0 bytes 61 to 62'. self assert: (bytecode at: (index := index + 1)) = '61 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '62 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '63 send: add:'. self assert: (bytecode at: (index := index + 1)) = '64 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '65 <68> popIntoTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '66 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '67 <8F 10 00 06> closureNumCopied: 1 numArgs: 0 bytes 71 to 76'. self assert: (bytecode at: (index := index + 1)) = '71 <8C 00 00> pushTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '74 <21> pushConstant: 5'. self assert: (bytecode at: (index := index + 1)) = '75 send: <'. self assert: (bytecode at: (index := index + 1)) = '76 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '77 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '78 send: whileTrue:'. self assert: (bytecode at: (index := index + 1)) = '79 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '80 <70> self'. self assert: (bytecode at: (index := index + 1)) = '81 <23> pushConstant: #(1 2 3 4 5)'. self assert: (bytecode at: (index := index + 1)) = '82 send: assertValues:'. self assert: (bytecode at: (index := index + 1)) = '83 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '84 <78> returnSelf'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:37'! testToDoInsideTempNotInlined "Some instructions are the same but we have a different number at he begining, and the storeTemp and popIntoTemp issue" | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'testToDoInsideTempNotInlined | block | block := [ :index | | temp | temp := index. collection add: [ temp ] ]. 1 to: 5 do: block. self assertValues: #(1 2 3 4 5)'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '33 <8F 01 00 0D> closureNumCopied: 0 numArgs: 1 bytes 37 to 49'. self assert: (bytecode at: (index := index + 1)) = '37 <73> pushConstant: nil'. self assert: (bytecode at: (index := index + 1)) = '38 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '39 <69> popIntoTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '40 <00> pushRcvr: 0'. self assert: (bytecode at: (index := index + 1)) = '41 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '42 <8F 10 00 02> closureNumCopied: 1 numArgs: 0 bytes 46 to 47'. self assert: (bytecode at: (index := index + 1)) = '46 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '47 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '48 send: add:'. self assert: (bytecode at: (index := index + 1)) = '49 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '50 <68> popIntoTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '51 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '52 <21> pushConstant: 5'. self assert: (bytecode at: (index := index + 1)) = '53 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '54 send: to:do:'. self assert: (bytecode at: (index := index + 1)) = '55 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '56 <70> self'. self assert: (bytecode at: (index := index + 1)) = '57 <23> pushConstant: #(1 2 3 4 5)'. self assert: (bytecode at: (index := index + 1)) = '58 send: assertValues:'. self assert: (bytecode at: (index := index + 1)) = '59 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '60 <78> returnSelf'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:36'! testSetUp | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'setUp super setUp. collection := OrderedCollection new'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '21 <70> self'. self assert: (bytecode at: (index := index + 1)) = '22 <85 00> superSend: setUp'. self assert: (bytecode at: (index := index + 1)) = '24 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '25 <41> pushLit: OrderedCollection'. self assert: (bytecode at: (index := index + 1)) = '26 send: new'. self assert: (bytecode at: (index := index + 1)) = '27 <60> popIntoRcvr: 0'. self assert: (bytecode at: (index := index + 1)) = '28 <78> returnSelf'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:37'! testToDoArgumentNotInlined | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'testToDoArgumentNotInlined | block | block := [ :index | collection add: [ index ] ]. 1 to: 5 do: block. self assertValues: #(1 2 3 4 5)'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '33 <8F 01 00 0A> closureNumCopied: 0 numArgs: 1 bytes 37 to 46'. self assert: (bytecode at: (index := index + 1)) = '37 <00> pushRcvr: 0'. self assert: (bytecode at: (index := index + 1)) = '38 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '39 <8F 10 00 02> closureNumCopied: 1 numArgs: 0 bytes 43 to 44'. self assert: (bytecode at: (index := index + 1)) = '43 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '44 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '45 send: add:'. self assert: (bytecode at: (index := index + 1)) = '46 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '47 <68> popIntoTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '48 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '49 <21> pushConstant: 5'. self assert: (bytecode at: (index := index + 1)) = '50 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '51 send: to:do:'. self assert: (bytecode at: (index := index + 1)) = '52 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '53 <70> self'. self assert: (bytecode at: (index := index + 1)) = '54 <23> pushConstant: #(1 2 3 4 5)'. self assert: (bytecode at: (index := index + 1)) = '55 send: assertValues:'. self assert: (bytecode at: (index := index + 1)) = '56 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '57 <78> returnSelf'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:33'! testMethodArgument | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'testMethodArgument | temp block | temp := 0. block := [ [ temp ] ]. temp := 1. block := block value. temp := 2. self assert: block value = 2'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '17 <8A 01> push: (Array new: 1)'. self assert: (bytecode at: (index := index + 1)) = '19 <69> popIntoTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '20 <75> pushConstant: 0'. self assert: (bytecode at: (index := index + 1)) = '21 <8E 00 01> popIntoTemp: 0 inVectorAt: 1'. self assert: (bytecode at: (index := index + 1)) = '24 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '25 <8F 10 00 0A> closureNumCopied: 1 numArgs: 0 bytes 29 to 38'. self assert: (bytecode at: (index := index + 1)) = '29 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '30 <8F 10 00 04> closureNumCopied: 1 numArgs: 0 bytes 34 to 37'. self assert: (bytecode at: (index := index + 1)) = '34 <8C 00 00> pushTemp: 0 inVectorAt: 0'. self assert: (bytecode at: (index := index + 1)) = '37 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '38 <7D> blockReturn'. self assert: (bytecode at: (index := index + 1)) = '39 <68> popIntoTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '40 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '41 <8E 00 01> popIntoTemp: 0 inVectorAt: 1'. self assert: (bytecode at: (index := index + 1)) = '44 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '45 send: value'. self assert: (bytecode at: (index := index + 1)) = '46 <68> popIntoTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '47 <77> pushConstant: 2'. self assert: (bytecode at: (index := index + 1)) = '48 <8E 00 01> popIntoTemp: 0 inVectorAt: 1'. self assert: (bytecode at: (index := index + 1)) = '51 <70> self'. self assert: (bytecode at: (index := index + 1)) = '52 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '53 send: value'. self assert: (bytecode at: (index := index + 1)) = '54 <77> pushConstant: 2'. self assert: (bytecode at: (index := index + 1)) = '55 send: ='. self assert: (bytecode at: (index := index + 1)) = '56 send: assert:'. self assert: (bytecode at: (index := index + 1)) = '57 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '58 <78> returnSelf'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'test - array compilation' stamp: 'MarcusDenker 9/5/2013 14:34'! testMultiElementArray | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'method ^{1. 2. 3. 4. 5. 6 }'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '29 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '30 <77> pushConstant: 2'. self assert: (bytecode at: (index := index + 1)) = '31 <20> pushConstant: 3'. self assert: (bytecode at: (index := index + 1)) = '32 <21> pushConstant: 4'. self assert: (bytecode at: (index := index + 1)) = '33 <22> pushConstant: 5'. self assert: (bytecode at: (index := index + 1)) = '34 <23> pushConstant: 6'. self assert: (bytecode at: (index := index + 1)) = '35 <8A 86> pop 6 into (Array new: 6)'. self assert: (bytecode at: (index := index + 1)) = '37 <7C> returnTop'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:35'! testOneFloat | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'one ^1.0'; class: Float class; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '17 <20> pushConstant: 1.0'. self assert: (bytecode at: (index := index + 1)) = '18 <7C> returnTop'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:35'! testPragma | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'methodDoublePragma '; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = 'Quick return self'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'test - array compilation' stamp: 'MarcusDenker 9/5/2013 14:36'! testSimpleArray | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'method ^{1}'; class: OCMockCompilationClass; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '13 <76> pushConstant: 1'. self assert: (bytecode at: (index := index + 1)) = '14 <8A 81> pop 1 into (Array new: 1)'. self assert: (bytecode at: (index := index + 1)) = '16 <7C> returnTop'. ! ! !OCNewCompilerWithChangesFunctionalTests methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:37'! testSteamContentsLimitedToSequenceableCollectionClass | aCompiledMethod bytecode index | aCompiledMethod := OpalCompiler new source: 'streamContents: blockWithArg limitedTo: sizeLimit | stream | stream := LimitedWriteStream on: (self new: (100 min: sizeLimit)). stream setLimit: sizeLimit limitBlock: [^ stream contents]. blockWithArg value: stream. ^ stream contents'; class: SequenceableCollection class; compile. bytecode := aCompiledMethod symbolic asString subStrings: ' '. index := 0. self assert: (bytecode at: (index := index + 1)) = '37 <40> pushLit: LimitedWriteStream'. self assert: (bytecode at: (index := index + 1)) = '38 <70> self'. self assert: (bytecode at: (index := index + 1)) = '39 <21> pushConstant: 100'. self assert: (bytecode at: (index := index + 1)) = '40 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '41 send: min:'. self assert: (bytecode at: (index := index + 1)) = '42 send: new:'. self assert: (bytecode at: (index := index + 1)) = '43 send: on:'. self assert: (bytecode at: (index := index + 1)) = '44 <6A> popIntoTemp: 2'. self assert: (bytecode at: (index := index + 1)) = '45 <12> pushTemp: 2'. self assert: (bytecode at: (index := index + 1)) = '46 <11> pushTemp: 1'. self assert: (bytecode at: (index := index + 1)) = '47 <12> pushTemp: 2'. self assert: (bytecode at: (index := index + 1)) = '48 <8F 10 00 03> closureNumCopied: 1 numArgs: 0 bytes 52 to 54'. self assert: (bytecode at: (index := index + 1)) = '52 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '53 send: contents'. self assert: (bytecode at: (index := index + 1)) = '54 <7C> returnTop'. self assert: (bytecode at: (index := index + 1)) = '55 send: setLimit:limitBlock:'. self assert: (bytecode at: (index := index + 1)) = '56 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '57 <10> pushTemp: 0'. self assert: (bytecode at: (index := index + 1)) = '58 <12> pushTemp: 2'. self assert: (bytecode at: (index := index + 1)) = '59 send: value:'. self assert: (bytecode at: (index := index + 1)) = '60 <87> pop'. self assert: (bytecode at: (index := index + 1)) = '61 <12> pushTemp: 2'. self assert: (bytecode at: (index := index + 1)) = '62 send: contents'. self assert: (bytecode at: (index := index + 1)) = '63 <7C> returnTop'. ! ! !OCOpalExamples commentStamp: ''! I am the central place for example code used in tests! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/21/2010 15:57'! exampleSimpleBlockEmpty ^[] value.! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! noRemoteReadNestedBlocks [ |a| a := 1. [ a ]] ! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! optimizedBlocksAndSameNameTemps | s c | s := self isNil ifTrue: [| a | a := 1. a] ifFalse: [| a | a := 2. a]. c := String new: s size. 1 to: s size do: [:i| c at: i put: (s at: i)]. ^c! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 16:29'! exampleIfFalse true ifFalse: [^1]. ^2! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlockLocalIfNested ^true ifTrue: [| hallo | [ hallo := 1 . hallo] value] .! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! optimizedBlockWriteInNestedBlockCase4 | t1 | [(true) whileTrue: [ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ] ] ! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'ClementBera 7/26/2013 14:08'! exampleTimesRepeatEffect | foo | foo := 1. 5 timesRepeat: [ foo := foo + 3 ] . ^ foo! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! singleRemoteReadNestedBlocks |a| [ a := 1. [ a ]] ! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 6/5/2012 17:15'! exampleIfTrueIfFalse 1 <2 ifTrue: [^'result'] ifFalse: [2]. ! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 2/3/2011 15:04'! exampleInlineBlockCollectionLR3 | col | col := OrderedCollection new. 1 to: 11 do: [ :each | | i | i := each. col add: [ i ]. i := i + 1 ]. ^ (col collect: [ :each | each value ]) asArray "= (2 to: 12) asArray" ! ! !OCOpalExamples methodsFor: 'examples-misc' stamp: 'MarcusDenker 10/12/2010 12:27'! examplePushArray | t | {1 .t:=1}. ^t! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:10'! exampleBlockInternal ^[ | t | t := 1. t] value! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/25/2010 13:31'! exampleMethodTempInNestedBlock | temp block | temp := 0. block := [ [ temp ] ]. temp := 1. block := block value. temp := 2. "self assert: block value = 2." ^block value.! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlockArgument2 ^[:a :b | a + b ] value: 1 value: 1.! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/25/2010 13:32'! exampleBlockArgument | block block1 block2 | block := [ :arg | | temp | temp := arg. [ temp ] ]. block1 := block value: 1. block2 := block value: 2. self assert: block1 value = 1. self assert: block2 value = 2. ^block1 value + block2 value.! ! !OCOpalExamples methodsFor: 'examples-variables' stamp: 'MarcusDenker 9/1/2010 15:25'! exampleSuper | t | t := super. ^super.! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 13:51'! exampleWhileModificationAfterNotInlined | index block | index := 0. block := [ collection add: [ index ]. index := index + 1 ]. [ index < 5 ] whileTrue: block. ^collection "#(5 5 5 5 5)"! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlockLocalIf ^true ifTrue: [ | hallo | hallo := 1 . hallo].! ! !OCOpalExamples methodsFor: 'initialization' stamp: 'MarcusDenker 8/25/2010 15:49'! initialize collection := OrderedCollection new! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:10'! exampleBlockExternal2 | t1 t2 | t1 := t2 := 1. ^[t1 + t2] value.! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:42'! noRemoteBlockTemp | block block1 block2 | block := [ :arg | [ arg ] ]. block1 := block value: 1. block2 := block value: 2. ! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! optimizedBlockWriteReadInBlock | t1 | [ t1 < 5 ] whileTrue: [ t1 := 1. [ t1 ] ]. ! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenler 12/11/2012 15:02'! optimizedBlockWrittenAfterClosedOverCase1 | index | index := 0. [ index < 5 ] whileTrue: [ | temp | [ temp ]. temp := index := index + 1]. ^index ! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlockArgument1 ^[:a | a ] value: 1.! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlockArgument5 ^[:a :b :c :d :e| a + b + c + d + e] valueWithArguments: #(1 1 1 1 1). ! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 13:49'! exampleWhileWithTemp | index | index := 0. [ index < 5 ] whileTrue: [ | temp | temp := index := index + 1. collection add: [ temp ] ]. ^collection "#(1 2 3 4 5)"! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:42'! noRemoteReadInBlock | a | a := 1. [ a ] ! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 15:47'! nestedBlocksRemoteInBlockCase3 | block | block := [ [ |a| block := [ a := 1] ]. [ |b| block := [ b := 2] ] ].! ! !OCOpalExamples methodsFor: 'examples-variables' stamp: 'MarcusDenker 8/20/2010 15:22'! exampleiVar iVar := 1. ^iVar.! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 16:20'! exampleMethodWithOptimizedBlocksA | s c | s := self isNil ifTrue: [| a | a := 'isNil'. a] ifFalse: [| a | a := 'notNil'. a]. c := String new: s size. 1 to: s size do: [:i| c at: i put: (s at: i)]. ^c. "notNil"! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlockLocal ^[ :each | | t | t:= each. t ] value: 5.! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 13:54'! exampleToDoInsideTempNotInlined | block | block := [ :index | | temp | temp := index. collection add: [ temp ] ]. 1 to: 5 do: block. ^collection "#(1 2 3 4 5)"! ! !OCOpalExamples methodsFor: 'examples-simple' stamp: 'MarcusDenker 8/20/2010 21:00'! exampleNewArray | temp | temp := Array new: 3. ^temp! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 9/22/2010 11:14'! exampleWhileModificationBefore | index | collection := OrderedCollection new. index := 0. [ index < 5 ] whileTrue: [ index := index + 1. collection add: [ index ] ]. ^collection collect: #value. "#(5 5 5 5 5)"! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:42'! nestedBlocksRemoteInBlockCase1 | block | block := [ | a b | [ a := b ]. [ b := a ] ]! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 5/17/2013 15:57'! exampleBlockExternal | t | t := 1. ^[t] value.! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! optimizedBlockWriteInBlock | t1 | [ t1 < 5 ] whileTrue: [ t1 := 1 ]. ! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlockNested | a match dict | a := #(a b c d). dict := Dictionary new. a doWithIndex: [:each :index | (match := a indexOf: each) > 0 ifTrue: [dict at: index put: (a at: match)]]. ^ dict.! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:42'! doubleRemoteAnidatedBlocks | val last | val := 0. 1 to: 10 do: [ :i | [ :continue | i = 4 ifTrue: [continue value]. val := val + 1. last := i ] valueWithExit. ]. self assert: val = 9. self assert: last = 10. ! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! optimizedBlockWriteInNestedBlockCase2 | t1 | (true) ifTrue: [ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ] ! ! !OCOpalExamples methodsFor: 'examples-pragmas' stamp: 'MarcusDenker 5/13/2011 14:41'! exampleDoublePrimitive ! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlockiVar ^[iVar] value.! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlockArgument3 ^[:a :b :c | a + b + c ] value: 1 value: 1 value: 1.! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 13:53'! exampleToDoOutsideTemp | temp | 1 to: 5 do: [ :index | temp := index. collection add: [ temp ] ]. ^collection "#(5 5 5 5 5)"! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! optimizedBlockWriteInNestedBlockCase3 | t1 | [(true) ifTrue: [ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ] ] ! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/21/2010 15:05'! exampleSimpleBlockReturn [^1] value.! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 12/7/2012 15:11'! exampleToDoArgumentLimitIsExpression | count sum | count := 10. sum := 0. 1 to: count - 1 do: [ :each | sum := sum + each]. ^sum! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 13:55'! exampleToDoInsideTemp 1 to: 5 do: [ :index | | temp | temp := index. collection add: [ temp ] ]. ^collection "#(1 2 3 4 5)"! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 10/1/2013 15:07'! singleRemoteTempVarWrittenAfterClosedOver | index block | index := 0. block := [ index ]. index := index + 1. ! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/25/2010 13:42'! exampleNestedBlockScoping | b c z | b := [:a | z := 2. z + a]. c := [:a | z + a]. ^ (b value: 2) + (c value: 1)! ! !OCOpalExamples methodsFor: 'examples-simple' stamp: 'MarcusDenker 8/20/2010 15:07'! exampleReturn1 ^1! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 6/5/2012 17:11'! exampleIfTrue 1 < 2 ifTrue: [^'result']. ! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 10/1/2013 15:05'! singleRemoteTempVar | index block theCollection | index := 0. block := [ theCollection add: [ index ]. index := index + 1 ]. [ index < 5 ] whileTrue: block. self assertValues: #(5 5 5 5 5)! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:42'! noRemoteMethodTemp | block1 block2 | block1 := self methodArgument: 1. block2 := self methodArgument: 2. ! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! singleRemoteDifferentBlocksSameArgumentName | b c z | b := [:a | z := 2. z + a]. c := [:a | z + a]. ^ (b value: 2) + (c value: 1) ! ! !OCOpalExamples methodsFor: 'examples-misc' stamp: 'ClementBera 6/28/2013 13:39'! examplePushBigArray "This array should have a size more than 127 elements" { 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 . 255 }. ^ 1! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/21/2010 13:29'! exampleIfNotNilReturnNil ^nil ifNotNil: [ :arg | arg not ]! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 13:52'! exampleToDoArgumentNotInlined | block | block := [ :index | collection add: [ index ] ]. 1 to: 5 do: block. ^collection "#(1 2 3 4 5)"! ! !OCOpalExamples methodsFor: 'examples-simple' stamp: 'MarcusDenker 8/21/2010 15:59'! exampleEmptyMethod! ! !OCOpalExamples methodsFor: 'examples-pragmas' stamp: 'MarcusDenler 12/10/2012 15:53'! examplePrimitiveErrorCode ^ code ! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! optimizedBlockWriteInNestedBlock | t1 | ^[ [ t1 < 5 ] whileTrue: [ t1 := 1 ] ] ! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 2/3/2011 12:19'! exampleIfTrueAssign | a | a := 1 <2 ifTrue: [1] ifFalse: [2]. ^a ! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:42'! nestedBlocksRemoteInBlockCase2 | block | block := [ [ |a| [ a := 1] ]. [ |b| [ b := 2] ] ]! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! optimizedBlockWrittenAfterClosedOverCase2 | index | index := 0. [ index < 5 ] whileTrue: [ | temp | temp := index := index + 1. [ temp ] ]. ! ! !OCOpalExamples methodsFor: 'examples-pragmas' stamp: 'MarcusDenler 12/10/2012 15:27'! examplePrimitiveErrorCodeModule "Primitive. Attempt to load a module of the given name. Fail if module cannot be found, or cannot be loaded, or failed to initialize" ^ self primitiveFailed! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:10'! exampleBlockExternalArg | t | t := 1. ^[:a | t + a] value: 1.! ! !OCOpalExamples methodsFor: 'examples-variables' stamp: 'MarcusDenker 9/1/2010 14:42'! exampleSelf | t | t := self. ^self.! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 9/22/2010 11:14'! exampleToDoArgument collection := OrderedCollection new. 1 to: 5 do: [ :index | collection add: [index] ]. ^collection collect: #value. "#(1 2 3 4 5)"! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'ClementBera 7/26/2013 14:08'! exampleTimesRepeatValue ^ 5 timesRepeat: [ 1 + 2 ] ! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 16:29'! exampleIfFalseIfTrue true ifFalse: [^1] ifTrue: [^2].! ! !OCOpalExamples methodsFor: 'examples-simple' stamp: 'MarcusDenker 8/20/2010 20:25'! exampleReturn1plus2 ^1+2! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 13:53'! exampleToDoOutsideTempNotInlined | block temp | block := [ :index | temp := index. collection add: [ temp ] ]. 1 to: 5 do: block. ^collection "#(5 5 5 5 5)"! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 13:47'! exampleWhileWithTempNotInlined | index block | index := 0. block := [ | temp | temp := index := index + 1. collection add: [ temp ] ]. [ index < 5 ] whileTrue: block. ^collection "#(1 2 3 4 5)"! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlockArgument4 ^[:a :b :c :d | a + b + c + d] value: 1 value: 1 value: 1 value: 1. ! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:10'! exampleBlockExternalNested | t s | t := s := 1. ^[[s] value + t ] value.! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlockLocalWhile |a| a := true. ^[: b | [a] whileTrue: [ | hallo | a := false. hallo := 1 . hallo]]value: 1.! ! !OCOpalExamples methodsFor: 'examples-misc' stamp: 'MarcusDenker 12/5/2012 16:16'! exampleToDoValueLimitExpression ^ 2 to: 3+4 do: [:each | each] ! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/20/2010 16:09'! exampleSimpleBlock ^[1].! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:42'! noRemoteBlockArgument | block block1 block2 | block := [ :arg | | temp | temp := arg. [ temp ] ]. block1 := block value: 1. block2 := block value: 2. ! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:42'! noRemoteBlockReturn (self announcements at: self index ifAbsent: [ ^ self ]) open. ! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 8/21/2010 16:26'! exampleBlockNested ^[ [1] value] value! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/21/2010 13:30'! exampleIfNotNilArg ^1 even ifNotNil: [ :arg | arg not ]! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! optimizedBlockReadInBlock | t1 | [ t1 < 5 ] whileTrue: [ [ t1 ] ]. ! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! singleRemoteMethodArgument | temp block | temp := 0. block := [ [ temp ] ]. temp := 1. block := block value. temp := 2. ! ! !OCOpalExamples methodsFor: 'examples-variables' stamp: 'MarcusDenker 9/1/2010 15:25'! exampleThisContext | t | t := thisContext. ^thisContext.! ! !OCOpalExamples methodsFor: 'examples-blocks' stamp: 'MarcusDenker 2/3/2011 10:26'! exampleBlockMethodArgument: arg | block | block := [ :blockarg | blockarg + arg]. self assert: ((block value: 2) = (arg + 2)). ^block value: 2! ! !OCOpalExamples methodsFor: 'examples-blocks-optimized' stamp: 'MarcusDenker 8/25/2010 13:49'! exampleWhileModificationBeforeNotInlined | index block | index := 0. block := [ index := index + 1. collection add: [ index ] ]. [ index < 5 ] whileTrue: block. ^collection. "#(5 5 5 5 5)"! ! !OCOpalExamples methodsFor: 'examples' stamp: 'MarcusDenker 7/2/2012 10:43'! writtenAfterClosedOver | a | [ a ]. a := 1! ! !OCOpalExamples methodsFor: 'examples-misc' stamp: 'MarcusDenker 12/5/2012 15:52'! exampleToDoValue ^ 1 to: 2 do: [:each | each] ! ! !OCOpalExamples class methodsFor: 'compiler' stamp: 'MarcusDenker 5/26/2013 14:37'! compilerClass ^OpalCompiler! ! !OCOptimizedBlockScope commentStamp: ''! In Smalltalk, methods like ifTrue: are inlined an there is no Block for the arguments of these message sends. To be consistent, these blocks need nevertheless a scope. ! !OCOptimizedBlockScope methodsFor: 'testing' stamp: 'JorgeRessia 9/11/2010 08:08'! isOptimizedBlockScope ^ true! ! !OCOptimizedBlockScope methodsFor: 'initialization' stamp: 'JorgeRessia 9/23/2010 13:16'! initialize super initialize. isInlinedLoop := false! ! !OCOptimizedBlockScope methodsFor: 'private' stamp: 'MarcusDenker 12/14/2012 11:25'! markInlinedLoop isInlinedLoop := true! ! !OCOptimizedBlockScope methodsFor: 'testing' stamp: 'JorgeRessia 9/23/2010 13:21'! isInsideOptimizedLoop ^ isInlinedLoop ifTrue: [true] ifFalse: [self outerScope isInsideOptimizedLoop]! ! !OCOptimizedBlockScope methodsFor: 'accessing' stamp: 'JorgeRessia 9/23/2010 14:00'! outerNotOptimizedScope ^self outerScope outerNotOptimizedScope! ! !OCPerformTest commentStamp: 'HenrikSperreJohansen 5/19/2010 02:33'! I test a primitive failure with perform:withArguments: which was raised when selectors with many arguments was called from methods with small stack sizes.! !OCPerformTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPerformWithArgsLargeFrame self doPerformOldLargeFrame! ! !OCPerformTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPerformWithArgsSmallFrame self doPerformOldSmallFrame! ! !OCPerformTest methodsFor: 'helper methods' stamp: 'HenrikSperreJohansen 5/19/2010 02:28'! doPerformOldSmallFrame "The perform primitive reuses the current stack frame. When this was small, it would cause the perform primitive to fail, when the amount of arguments were too high" ^self perform: #a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: withArguments: (Array new: 15). ! ! !OCPerformTest methodsFor: 'helper methods' stamp: 'Igor.Stasenko 5/19/2010 00:21'! a1: a1 a2: a2 a3: a3 a4: a4 a5: a5 a6: a6 a7: a7 a8:a8 a9: a9 a10: a10 a11: a11 a12: a12 a13: a13 a14: a14 a15: a15 ^ true! ! !OCPerformTest methodsFor: 'helper methods' stamp: 'MarcusDenker 6/17/2012 15:06'! doPerformOldLargeFrame | t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 | "The perform primitive reuses the current stack frame. When this was big,the following perform would succeed, since the stack frame was large enough to fit all the arguments" t1 := t2 := t3 := t4 := t5 := t6 := t7 := t8 := t9 := t10 := t11 := t12 := t13 := 1. self perform: #a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: withArguments: (Array new: 15). ^ t1! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:13'! testIsPrimitve | aRBMethode | aRBMethode := OpalCompiler new parse: self methodPrimitive. self assert: aRBMethode isPrimitive! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:14'! testPrimitiveNumber | aRBMethode | aRBMethode := OpalCompiler new parse: self methodPrimitive. self assert: (aRBMethode compiledMethod primitive = 4)! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:13'! testDoublePragma | aRBMethode | "self debug: #testDoublePragma" aRBMethode := OpalCompiler new parse: self methodDoublePragma. self assert: (aRBMethode compiledMethod pragmas first keyword = #hello:). self assert: (aRBMethode compiledMethod pragmas second keyword = #hello:)! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/16/2006 21:05'! methodPrimitivePragma ^'methodPrimitivePragma '! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/22/2006 13:33'! methodPrimitiveStringModule ^'methodPrimitiveStringModule '! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:14'! testPrimitiveStringModule | aRBMethode | aRBMethode := OpalCompiler new parse: self methodPrimitiveStringModule. self assert: (aRBMethode compiledMethod primitive = 117)! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/26/2006 22:53'! methodNoPragma ^'methodNoPragma: aNum ^aNum'! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:13'! testCdecl | aRBMethode | Smalltalk globals at: #ExternalFunction ifAbsent:[^self]. aRBMethode := OpalCompiler new parse: self methodCdecl. self assert: ((aRBMethode compiledMethod literalAt: 1) isKindOf: (Smalltalk globals at: #ExternalFunction )). self assert: (aRBMethode compiledMethod primitive = 120)! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/19/2006 00:12'! methodApicall ^'methodApicall: aHWND ^self externalCallFailed'! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:14'! testPragmaTwoParam "self debug: #testPragmaAfterBeforTemp" | aRBMethode | aRBMethode := OpalCompiler new parse: self methodPragmaTwoParam. self assert: (aRBMethode compiledMethod pragmas first keyword = #hello:by:) ! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:14'! testPragmaUnarayMessage | aRBMethode | aRBMethode := OpalCompiler new parse: self methodPragmaUnarayMessage. self assert: (aRBMethode compiledMethod pragmas first keyword = #hello)! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/16/2006 21:04'! methodPragmaAfterBeforTemps ^'methodPragmaAfterBeforTemps | aTemp | '! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:14'! testPrimitivePragmaNumber | aRBMethode | aRBMethode := OpalCompiler new parse: self methodPrimitivePragma. self assert: (aRBMethode compiledMethod primitive = 4)! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/20/2006 20:49'! methodPragmaTwoParam ^'methodDoublePragma '! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:14'! testPragmaAfterBeforTemp "self debug: #testPragmaAfterBeforTemp" | aRBMethode | aRBMethode := OpalCompiler new parse: self methodPragmaAfterBeforTemps. self assert: (aRBMethode compiledMethod pragmas first keyword = #hello:). self assert: (aRBMethode compiledMethod pragmas second keyword = #world:) ! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/25/2006 08:36'! methodCdeclNoModule ^'ffiTestShort: c1 with: c2 with: c3 with: c4 "FFITester ffiTestShort: $A with: 65 with: 65.0 with: $A" ^self externalCallFailed'! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/16/2006 21:05'! methodPrimitive ^'methodPrimitive '! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/25/2006 07:56'! methodPragmaUnarayMessage ^'methodPragmaUnarayMessage '! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:14'! testSinglePragma | aRBMethode | aRBMethode := OpalCompiler new parse: self methodSinglePragma. self assert: (aRBMethode compiledMethod pragmas first keyword = #hello:) ! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/16/2006 21:03'! methodDoublePragma ^'methodDoublePragma '! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/16/2006 21:06'! methodSinglePragma ^'methodSinglePragma '! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:14'! testPrimitiveString | aRBMethode | aRBMethode := OpalCompiler new parse: self methodPrimitiveString. self assert: (aRBMethode compiledMethod primitive = 117)! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/19/2006 00:15'! methodCdecl ^'XCloseDisplay: aDisplay ^self externalCallFailed'! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:13'! testCdeclNoModule | aRBMethode | Smalltalk globals at: #ExternalFunction ifAbsent:[^self]. aRBMethode := OpalCompiler new parse: self methodCdeclNoModule. self assert: ((aRBMethode compiledMethod literalAt: 1) isKindOf: (Smalltalk globals at: #ExternalFunction)). self assert: (aRBMethode compiledMethod primitive = 120)! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:12'! testApicall | aRBMethode | Smalltalk globals at: #ExternalFunction ifAbsent:[^self]. aRBMethode := OpalCompiler new parse: self methodApicall. self assert: ((aRBMethode compiledMethod literalAt: 1) isKindOf: (Smalltalk globals at: #ExternalFunction)). self assert: (aRBMethode compiledMethod primitive = 120)! ! !OCPragmaTest methodsFor: 'method-tested' stamp: 'ms 7/22/2006 13:31'! methodPrimitiveString ^'methodPrimitiveString '! ! !OCPragmaTest methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2013 13:14'! testNoPragma "self debug: #testDoublePrimitive" OpalCompiler new parse: self methodNoPragma! ! !OCRequestorScope methodsFor: 'lookup' stamp: 'MarcusDenker 12/2/2013 14:08'! lookupVar: name name = 'self' ifTrue: [ ^outerScope lookupVar: name]. name = 'super' ifTrue: [ ^outerScope lookupVar: name]. name first isUppercase ifTrue: [ ^outerScope lookupVar: name ]. (requestor bindingOf: name asSymbol) ifNotNil: [:assoc | ^ OCLiteralVariable new assoc: assoc; scope: self; yourself]. ^ super lookupVar: name. ! ! !OCRequestorScope methodsFor: 'accessing' stamp: 'MarcusDenker 4/11/2013 14:37'! requestor: anObject requestor := anObject! ! !OCRequestorScope methodsFor: 'lookup' stamp: 'MarcusDenker 5/18/2013 13:52'! newMethodScope ^ OCMethodScope new outerScope: (self outerScope: outerScope instanceScope) ! ! !OCRequestorScope methodsFor: 'accessing' stamp: 'MarcusDenker 4/11/2013 14:37'! requestor ^ requestor! ! !OCScannerTest methodsFor: 'testing' stamp: 'MarcusDenker 5/19/2013 16:45'! testLiteralSymbols ((((32 to: 126) collect: [:ascii | Character value: ascii])) copyWithout: $`) , "backtick is not suppored by OBParser" #(':x:yourself' '::' 'x:yourself' '123' 'x0:1:2:' 'x.y.z' '1abc' 'a1b0c2' ' x' 'x ' '+x-y' '||' '--' '++' '+-' '+/-' '-/+' '<|>' '#x' '()' '[]' '{}' '') do: [:str | self assert: (self class compiler evaluate: str asSymbol printString) = str asSymbol description: 'in all case, a Symbol must be printed in an interpretable fashion']! ! !OCScannerTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testAmbiguousSelector "Non regression test. See http://code.google.com/p/pharo/issues/detail?id=2271 and http://bugs.squeak.org/view.php?id=7491" '1@-1' parseLiterals. self assert: ('1@-1' parseLiterals at: 2) asString = '@-'! ! !OCScopesCollector commentStamp: ''! I am a helper class to simplify tests related to scopes. I collect all scopes of the AST. This way one can easily check for scopes and variables even when the scopes are deeply nested. Simple example (with just a method scope): |ast scopes ivar| ast := (OCOpalExamples>>#exampleiVar) parseTree doSemanticAnalysisIn: OCOpalExamples. scopes := (OCScopesCollector new visitNode: ast) scopes. ivar := scopes first lookupVar: #iVar! !OCScopesCollector methodsFor: 'accessing' stamp: 'JorgeRessia 9/7/2010 16:21'! scopes ^scopes! ! !OCScopesCollector methodsFor: 'initialization' stamp: 'JorgeRessia 9/7/2010 16:20'! initialize scopes := OrderedCollection new. super initialize! ! !OCScopesCollector methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 4/11/2013 15:12'! visitBlockNode: aBlockNode scopes add: aBlockNode owningScope. super visitBlockNode: aBlockNode! ! !OCScopesCollector methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 4/11/2013 15:12'! visitMethodNode: aMethodNode scopes add: aMethodNode owningScope. super visitMethodNode: aMethodNode! ! !OCSemanticError commentStamp: ''! Raises a semantic error during semantic analysis! !OCSemanticError methodsFor: 'exceptiondescription' stamp: 'MarcusDenker 5/17/2013 16:33'! defaultAction ^self notify: messageText at: node start.! ! !OCSemanticError methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 16:33'! methodNode ^node methodNode! ! !OCSemanticError methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 16:33'! node ^ node! ! !OCSemanticError methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 11:41'! compilationContext: anObject compilationContext := anObject! ! !OCSemanticError methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 16:33'! node: aNode node := aNode! ! !OCSemanticError methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 11:44'! methodClass ^self methodNode methodClass! ! !OCSemanticError methodsFor: 'error handling' stamp: 'MarcusDenker 5/23/2013 10:35'! notify: aString at: location "Refer to the comment in Object|notify:." ^compilationContext requestor ifNil: [SyntaxErrorNotification inClass: self methodClass category: self methodClass category withCode: self methodNode source doitFlag: false errorMessage: aString location: location] ifNotNil: [compilationContext requestor notify: aString , ' ->' at: location in: compilationContext requestor text]! ! !OCSemanticError methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 11:41'! compilationContext ^ compilationContext! ! !OCSemanticWarning commentStamp: 'ajh 7/7/2004 17:36'! If a variable is not found or some other problem occurs during checking (ASTChecker) than a particular subclass instance of me is signal, usually causing a notification to the user. If not handled, the default handling is done, and compiling continues.! !OCSemanticWarning methodsFor: 'accessing - compatibility' stamp: 'CamilloBruni 7/17/2013 15:37'! errorCode self requestor ifNil: [ ^ self node methodNode asString ]. ^ self requestor contents! ! !OCSemanticWarning methodsFor: 'accessing - compatibility' stamp: 'CamilloBruni 7/10/2013 16:19'! errorMessage ^ self messageText! ! !OCSemanticWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/18/2013 16:26'! openMenuIn: aBlock self subclassResponsibility! ! !OCSemanticWarning methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 16:31'! node ^node ! ! !OCSemanticWarning methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 16:26'! node: anObject node := anObject! ! !OCSemanticWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/17/2013 16:25'! methodClass ^node methodNode methodClass! ! !OCSemanticWarning methodsFor: 'accessing - compatibility' stamp: 'CamilloBruni 7/10/2013 16:18'! location ^ self node sourceInterval first! ! !OCSemanticWarning methodsFor: 'accessing' stamp: 'MarcusDenker 6/7/2013 13:05'! compilationContext ^ compilationContext! ! !OCSemanticWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/23/2013 10:35'! notify: aString at: location "Refer to the comment in Object|notify:." ^self requestor ifNil: [SyntaxErrorNotification inClass: self methodClass category: self methodClass category withCode: self methodNode source doitFlag: false errorMessage: aString location: location] ifNotNil: [self requestor notify: aString , ' ->' at: location in: self requestor text]! ! !OCSemanticWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/17/2013 14:46'! interactive ^ UIManager default interactiveParserFor: self requestor! ! !OCSemanticWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/17/2013 15:02'! defaultAction self errorNotification ifFalse: [ ^nil ]. ^self openMenuIn: [:labels :lines :caption | UIManager default chooseFrom: labels lines: lines title: caption]! ! !OCSemanticWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/17/2013 16:25'! methodNode ^node methodNode! ! !OCSemanticWarning methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 14:45'! requestor ^ compilationContext requestor! ! !OCSemanticWarning methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 12:41'! compilationContext: anObject compilationContext := anObject! ! !OCSemanticWarning methodsFor: 'accessing' stamp: 'ClementBera 11/26/2013 13:31'! errorNotification ^ compilationContext interactive and: [ compilationContext warningAllowed ]! ! !OCShadowVariableWarning commentStamp: 'ajh 3/24/2003 22:21'! I get signalled when a variable in a block or method scope shadows a variable of the same name in an outer scope. The default action is to allow it.! !OCShadowVariableWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/25/2013 15:25'! variable: varNode shadows: semVar self interactive ifTrue: [ OCSemanticError new node: node; compilationContext: compilationContext; messageText: self stringMessage; signal ] ifFalse: [ Transcript cr; show: self methodClass name,'>>', varNode methodNode selector; show: '('; show: varNode name; show: ' is shadowed)'; yourself].! ! !OCShadowVariableWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/17/2013 16:29'! defaultAction ^ self resume: (self variable: self node shadows: self shadowedVar) ! ! !OCShadowVariableWarning methodsFor: 'accessing' stamp: 'MarcusDenker 5/23/2013 10:41'! stringMessage ^ 'Name already defined'! ! !OCShadowVariableWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/18/2013 16:43'! openMenuIn: aBlock self error: 'should not be called'! ! !OCShadowVariableWarning methodsFor: 'accessing' stamp: 'MarcusDenker 10/11/2010 16:08'! shadowedVar: aVar shadowedVar := aVar! ! !OCShadowVariableWarning methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 16:27'! node: aVariableNode super node: aVariableNode. messageText := 'Temp shadows: ', aVariableNode name. ! ! !OCShadowVariableWarning methodsFor: 'accessing' stamp: 'ajh 3/19/2003 13:32'! shadowedVar ^ shadowedVar! ! !OCSourceCode2BytecodeTest commentStamp: 'kwl 10/14/2006 10:43'! I provide at least one test which corresponds to a message sent by InstructionStream>>#interpretNextInstructionFor: to its client.! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimNewWith | selector method scanner did | selector := (method := self compile2method: 'bytecodeNewWith self new: 3') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#new:. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimDoWith | selector method scanner did | selector := (method := self compile2method: 'bytecodeDoWith self do: #something') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#do:. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimQuo | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimQuo 3 // 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#//. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimAdd | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimAdd 3 + 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#+. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testStoreAndPopLiteralVariableBytecode | selector method scanner did | selector := (method := self compile2method: 'storeAndPopLiteralVariableBytecode ClassVar := nil') selector. scanner := InstructionStream on: method. self assert: ((did := scanner nextInstruction; peekInstruction) selector == #popIntoLiteralVariable: and: [did arguments first = (#ClassVar -> nil)]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimLessThan | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimLessThan 3 < 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#<. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimNotEqual | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimNotEqual 3 ~= 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#~=. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimGreaterOrEqual | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimGreaterOrEqual 3 >= 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#'>='. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimBitShift | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimBitShift 3 bitShift: 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#bitShift:. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testDoDup | selector method scanner | method := self compile2method: 'duplicateTopBytecode 3 + 4; yourself'. selector := method selector. scanner := InstructionStream on: method. 1 timesRepeat: [scanner nextInstruction]. self assert: scanner peekInstruction selector == #doDup description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testStoreAndPopTemporaryVariableBytecode | selector method scanner did | selector := (method:= self compile2method: 'storeAndPopTemporaryVariableBytecode | t0 t1 | t1 := t0') selector. scanner := InstructionStream on: method. self assert: ((did := scanner nextInstruction; peekInstruction) selector == #popIntoTemporaryVariable: and: [did arguments first == 1]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimValueWith | selector method scanner did | selector := (method := self compile2method: 'bytecodeValueWith self value: 3') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#value:. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimAtPut | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimAtPut self at: 3 put: 4') selector. scanner := InstructionStream on: method. 3 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#at:put:. false. 2}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushConstantOneBytecode | selector method scanner did | selector := (method := self compile2method: 'pushConstantOneBytecode 1 yourself') selector. scanner := InstructionStream on: method. self assert: ((did := scanner peekInstruction) selector == #pushConstant: and: [did arguments first == 1]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushConstantTrueBytecode | selector method scanner did | selector := (method := self compile2method: 'pushConstantTrueBytecode true yourself') selector. scanner := InstructionStream on: method. self assert: ((did := scanner peekInstruction) selector == #pushConstant: and: [did arguments first]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testReturnTrueBytecode | selector method scanner did | selector := (method := self compile2method: 'returnTrueBytecode 3 + 4. ^ true') selector. scanner := InstructionStream on: method. 4 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #methodReturnConstant: and: [did arguments first]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushLiteralConstantBytecode | selector method scanner did | selector := (method := self compile2method: 'pushLiteralConstantBytecode #() yourself') selector. scanner := InstructionStream on: method. self assert: ((did := scanner peekInstruction) selector == #pushConstant: and: [did arguments first = #()]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimPointX | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimPointX self x') selector. scanner := InstructionStream on: method. 1 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#x. false. 0}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimSubtract | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimSubtract 3 - 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#-. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimValue | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimValue self value') selector. scanner := InstructionStream on: method. 1 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#value. false. 0}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushActiveContextBytecode | selector method scanner | selector := (method := self compile2method: 'pushActiveContextBytecode thisContext yourself') selector. scanner := InstructionStream on: method. self assert: scanner peekInstruction selector == #pushActiveContext description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimAtEnd | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimSize self atEnd') selector. scanner := InstructionStream on: method. 1 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#atEnd. false. 0}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimMultiply | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimMultiply 3 * 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#'*'. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimDivide | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimDivide 3 / 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#/. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimBitOr | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimBitOr 3 bitOr: 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#bitOr:. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimNext | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimSize self next') selector. scanner := InstructionStream on: method. 1 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#next. false. 0}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimNew | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimNew super new') selector. scanner := InstructionStream on: method. 1 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#new. true. 0}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimAt | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimAt self at: 3') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#at:. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimIdentity | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimIdentity 3 == 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#==. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushConstantMinusOneBytecode | selector method scanner did | selector := (method := self compile2method: 'pushConstantMinusOneBytecode -1 yourself') selector. scanner := InstructionStream on: method. self assert: ((did := scanner peekInstruction) selector == #pushConstant: and: [did arguments first == -1]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushConstantTwoBytecode | selector method scanner did | selector := (method := self compile2method: 'pushConstantTwoBytecode 2 yourself') selector. scanner := InstructionStream on: method. self assert: ((did := scanner peekInstruction) selector == #pushConstant: and: [did arguments first == 2]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushConstantZeroBytecode | selector method scanner did | selector := (method := self compile2method: 'pushConstantZeroBytecode 0 yourself') selector. scanner := InstructionStream on: method. self assert: ((did := scanner peekInstruction) selector == #pushConstant: and: [did arguments first == 0]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimEqual | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimEqual 3 = 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#'='. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimNextPut | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimNextPut self nextPut: 3') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#nextPut:. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushLiteralVariableBytecode | selector method scanner did | selector := (method := self compile2method: 'pushLiteralVariableBytecode ClassVar yourself') selector. scanner := InstructionStream on: method. self assert: ((did := scanner peekInstruction) selector == #pushLiteralVariable: and: [did arguments first = (#ClassVar -> nil)]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushConstantNilBytecode | selector method scanner did | selector := (method := self compile2method: 'pushConstantNilBytecode nil yourself') selector. scanner := InstructionStream on: method. self assert: ((did := scanner peekInstruction) selector == #pushConstant: and: [did arguments first isNil]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testReturnFalseBytecode | selector method scanner did | selector := (method := self compile2method: 'returnFalseBytecode 3 + 4. ^ false') selector. scanner := InstructionStream on: method. 4 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #methodReturnConstant: and: [did arguments first not]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testReturnReceiver | selector method scanner | selector := (method := self compile2method: 'returnReceiver 3 + 4. ^ self') selector. scanner := InstructionStream on: method. 4 timesRepeat: [scanner nextInstruction]. self assert: scanner peekInstruction selector == #methodReturnReceiver description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushConstantFalseBytecode | selector method scanner did | selector := (method := self compile2method: 'pushConstantFalseBytecode false yourself') selector. scanner := InstructionStream on: method. self assert: ((did := scanner peekInstruction) selector == #pushConstant: and: [did arguments first not]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testReturnTopFromBlock | selector method scanner | selector := (method := self compile2method: 'returnTopFromBlock |ia| ^[ia]') selector. scanner := InstructionStream on: method. 3 timesRepeat: [scanner nextInstruction]. self assert: scanner peekInstruction selector == #blockReturnTop description: ('Failed ' , selector)! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimMakePoint | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimMakePoint 3 @ 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#'@'. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testDoPop | selector method scanner | selector := (method := self compile2method: 'popStackBytecode 3 + 4') selector. scanner := InstructionStream on: method. 3 timesRepeat: [scanner nextInstruction]. self assert: scanner peekInstruction selector == #doPop description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testStoreAndPopReceiverVariableBytecode | selector method scanner did | selector := (method := self compile2method: 'storeAndPopReceiverVariableBytecode instVar := self') selector. scanner := InstructionStream on: method. self assert: ((did := scanner nextInstruction; peekInstruction) selector == #popIntoReceiverVariable: and: [did arguments first == 2]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimPointY | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimPointY self y') selector. scanner := InstructionStream on: method. 1 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#y. false. 0}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimSize | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimSize self size') selector. scanner := InstructionStream on: method. 1 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#size. false. 0}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testStoreIntoReceiverVariableBytecode | selector method scanner did | selector := (method := self compile2method: 'storeIntoReceiverVariableBytecode ^ (instVar := self)') selector. scanner := InstructionStream on: method. self assert: ((did := scanner nextInstruction; peekInstruction) selector == #storeIntoReceiverVariable: and: [did arguments first == 2]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushReceiverBytecode | selector method scanner | selector := (method := self compile2method: 'pushReceiverBytecode ^ self yourself') selector. scanner := InstructionStream on: method. self assert: scanner peekInstruction selector == #pushReceiver description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimLessOrEqual | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimLessOrEqual 3 <= 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#<=. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimMod | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimMod 3 \\ 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#\\. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimBitAnd | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimBitAnd 3 bitAnd: 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#bitAnd:. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testStoreIntoTemporaryVariableBytecode | selector method scanner did | selector := (method := self compile2method: 'storeIntoTemporaryVariableBytecode | t0 t1 | ^ (t1 := t0)') selector. scanner := InstructionStream on: method. self assert: ((did := scanner nextInstruction; peekInstruction) selector == #storeIntoTemporaryVariable: and: [did arguments first == 1]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testReturnTopFromMethod | selector method scanner | selector := (method := self compile2method: 'returnTopFromMethod ^ 3 + 4') selector. scanner := InstructionStream on: method. 3 timesRepeat: [scanner nextInstruction]. self assert: scanner peekInstruction selector == #methodReturnTop description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testSuperSendWith | selector method scanner did | selector := (method := self compile2method: 'bytecodeSuperSendWith super new: 0') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#new:. true. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushReceiverVariableBytecode | selector method scanner did | selector := (method := self compile2method: 'pushReceiverVariableBytecode instVar yourself') selector. scanner := InstructionStream on: method. self assert: ((did := scanner peekInstruction) selector == #pushReceiverVariable: and: [did arguments first == 2]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'compiling' stamp: 'MarcusDenker 9/5/2013 14:22'! compile2method: sourceStream "Compile code without logging the source in the changes file" ^OpalCompiler new source: sourceStream; class: self class; compile. ! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testSuperSend | selector method scanner did | selector := (method := self compile2method: 'bytecodeSuperSend super yourself') selector. scanner := InstructionStream on: method. 1 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#yourself. true. 0}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPushTemporaryVariableBytecode | selector method scanner did | selector := (method := self compile2method: 'pushTemporaryVariableBytecode: t0 t0 yourself') selector. scanner := InstructionStream on: method. self assert: ((did := scanner peekInstruction) selector == #pushTemporaryVariable: and: [did arguments first == 0]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testPrimGreaterThan | selector method scanner did | selector := (method := self compile2method: 'bytecodePrimGreaterThan 3 > 4') selector. scanner := InstructionStream on: method. 2 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #send:super:numArgs: and: [did arguments = {#>. false. 1}]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testStoreIntoLiteralVariableBytecode | selector method scanner did | selector := (method := self compile2method: 'storeIntoLiteralVariableBytecode ^ (ClassVar := nil)') selector. scanner := InstructionStream on: method. self assert: ((did := scanner nextInstruction; peekInstruction) selector == #storeIntoLiteralVariable: and: [did arguments first = (#ClassVar -> nil)]) description: 'Failed ' , selector! ! !OCSourceCode2BytecodeTest methodsFor: 'tests' stamp: 'MarcusDenker 9/5/2013 14:22'! testReturnNilBytecode | selector method scanner did | selector := (method := self compile2method: 'returnNilBytecode 3 + 4. ^ nil') selector. scanner := InstructionStream on: method. 4 timesRepeat: [scanner nextInstruction]. self assert: ((did := scanner peekInstruction) selector == #methodReturnConstant: and: [did arguments first isNil]) description: 'Failed ' , selector! ! !OCSourceCodeChanged commentStamp: 'BenComan 3/6/2014 02:40'! An OCSourceCodeChanged is used to pass corrected source code from OCUndeclaredVariableWarning back to OpalCompiler>>compile so that parsing can be restarted,. Introduced to resolve Case 12954.! !OCSourceCodeChanged methodsFor: 'accessing' stamp: 'BenComan 3/3/2014 09:06'! newSourceCode: aString newSourceCode := aString! ! !OCSourceCodeChanged methodsFor: 'accessing' stamp: 'BenComan 3/3/2014 09:06'! newSourceCode ^newSourceCode! ! !OCSpecialVariable commentStamp: ''! I model self, thisContext and super! !OCSpecialVariable methodsFor: 'testing' stamp: 'MarcusDenker 4/9/2013 10:39'! isUninitialized ^ false! ! !OCSpecialVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/3/2010 16:09'! isContext ^name = 'thisContext'! ! !OCSpecialVariable methodsFor: 'emitting' stamp: 'MarcusDenker 9/3/2010 15:46'! emitStore: methodBuilder self shouldNotImplement! ! !OCSpecialVariable methodsFor: 'emitting' stamp: 'MarcusDenker 9/3/2010 16:15'! emitValue: methodBuilder self isContext ifTrue: [methodBuilder pushThisContext] ifFalse:[methodBuilder pushReceiver] ! ! !OCSpecialVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/3/2010 16:09'! isSuper ^name = 'super'! ! !OCSpecialVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/3/2010 15:51'! isSelf ^name = 'self'! ! !OCSpecialVariable methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2013 15:55'! isSpecialVariable ^true! ! !OCTempVariable methodsFor: 'comparing' stamp: 'MarcusDenker 11/16/2012 11:26'! hash ^ name hash bitXor: (usage hash bitXor: scope hash).! ! !OCTempVariable methodsFor: 'emitting' stamp: ''! emitStore: methodBuilder methodBuilder storeTemp: name. ! ! !OCTempVariable methodsFor: 'escaping' stamp: 'MarcusDenker 9/21/2010 16:22'! isEscapingWrite ^escaping = #escapingWrite ! ! !OCTempVariable methodsFor: 'escaping' stamp: 'MarcusDenker 5/18/2011 15:57'! markEscapingWrite escaping := #escapingWrite. usage := #write.! ! !OCTempVariable methodsFor: '*AST-Interpreter-Core' stamp: 'MarcusDenker 5/22/2013 16:50'! readWith: anInterpreter inNode: aVariableNode self isArg ifTrue: [ | definingScope argIndex | definingScope := aVariableNode binding definingScope. argIndex := definingScope node argumentNames indexOf: name. ^ anInterpreter readArgumentAt: argIndex node: aVariableNode ]. "If it is not an arg, it is a normal temporary" ^ anInterpreter readTemporaryAt: -1 named: name! ! !OCTempVariable methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 5/22/2013 15:43'! specialCommands ^SugsSuggestionFactory commandsForTemporaryVariable.! ! !OCTempVariable methodsFor: 'debugging' stamp: 'ClementBera 7/9/2013 17:32'! readFromContext: aContext scope: contextScope "Usually the loop is useless, the first case with i = offset returns the correct result. However, the loop is required for specific case as Debugger restart feature." | offset contextForRead | offset := contextScope outerOffsetTo: scope. offset to: 0 by: -1 do: [ :i | contextForRead := aContext. i timesRepeat: [contextForRead := contextForRead outerContext ]. contextForRead ifNotNil: [ :ctx | ^ ctx tempAt: self indexFromIR ] ]. self error: 'temporary variable not found' ! ! !OCTempVariable methodsFor: 'escaping' stamp: 'MarcusDenker 9/21/2010 16:22'! isEscapingRead ^escaping = #escapingRead ! ! !OCTempVariable methodsFor: 'testing' stamp: ''! isTempVectorTemp ^false! ! !OCTempVariable methodsFor: 'escaping' stamp: 'MarcusDenker 9/21/2010 18:06'! markEscapingRead escaping = #escapingWrite ifFalse: [escaping := #escapingRead]! ! !OCTempVariable methodsFor: 'debugging' stamp: 'MarcusDenker 12/18/2012 14:41'! writeFromContext: aContext scope: contextScope value: aValue | offset contextForRead | offset := contextScope outerOffsetTo: scope. contextForRead := aContext. offset timesRepeat: [contextForRead := contextForRead outerContext]. ^contextForRead tempAt: self indexFromIR put: aValue! ! !OCTempVariable methodsFor: '*AST-Interpreter-Core' stamp: 'GuillermoPolito 5/14/2013 11:52'! accept: anInterpeter assign: value inNode: aVariableNode self isArg ifTrue: [ self error: 'Arguments cannot be assigned'. ]. "If it is not an arg, it is a normal temporary" ^ anInterpeter write: value temporaryAt: -1 named: name! ! !OCTempVariable methodsFor: 'escaping' stamp: 'MarcusDenker 9/22/2010 11:04'! escaping ^escaping! ! !OCTempVariable methodsFor: 'initialization' stamp: 'MarcusDenker 9/5/2010 20:18'! initialize super initialize. escaping := false.! ! !OCTempVariable methodsFor: 'comparing' stamp: 'MarcusDenker 11/16/2012 11:24'! = aTempVar ^aTempVar class = self class and: [aTempVar scope = self scope and: [aTempVar name = self name and: [aTempVar usage = self usage]]]. ! ! !OCTempVariable methodsFor: 'emitting' stamp: ''! emitValue: methodBuilder methodBuilder pushTemp: name.! ! !OCTempVariable methodsFor: 'escaping' stamp: 'MarcusDenker 9/22/2010 11:04'! escaping: anObject escaping := anObject! ! !OCTempVariable methodsFor: 'testing' stamp: 'ajh 6/23/2004 23:18'! isTemp ^ true! ! !OCTempVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/9/2010 16:07'! isCopying ^false! ! !OCTempVariable methodsFor: 'escaping' stamp: 'MarcusDenker 5/18/2011 16:00'! markWrite "if an escaping var is wrote to later, it needs to be remote" self isEscaping ifTrue: [self markEscapingWrite]. super markWrite.! ! !OCTempVariable methodsFor: 'escaping' stamp: 'MarcusDenker 9/21/2010 16:06'! isEscaping ^escaping = #escapingRead or: [escaping = #escapingWrite]! ! !OCTempVariable methodsFor: 'testing' stamp: 'MarcusDenker 11/15/2012 16:37'! isStoringTempVector "I am a temp that stores a temp vector. Those generated temps have a invalid name starting with 0" ^name first = $0.! ! !OCTempVariable methodsFor: 'debugging' stamp: 'MarcusDenker 4/18/2013 15:53'! indexFromIR ^scope outerNotOptimizedScope node irInstruction indexForVarNamed: name! ! !OCUndeclaredVariable methodsFor: 'testing' stamp: 'MarcusDenker 6/14/2013 15:42'! isUndeclared ^ true! ! !OCUndeclaredVariable methodsFor: 'emitting' stamp: 'MarcusDenker 6/14/2013 15:36'! emitStore: methodBuilder methodBuilder storeIntoLiteralVariable: self assoc ! ! !OCUndeclaredVariable methodsFor: 'accessing' stamp: 'MarcusDenker 6/14/2013 15:33'! name: anObject name := anObject! ! !OCUndeclaredVariable methodsFor: 'emitting' stamp: 'MarcusDenker 6/14/2013 15:36'! emitValue: methodBuilder methodBuilder pushLiteralVariable: self assoc. ! ! !OCUndeclaredVariable methodsFor: 'accessing' stamp: 'MarcusDenker 6/14/2013 15:36'! assoc ^Undeclared associationAt: name! ! !OCUndeclaredVariable methodsFor: 'accessing' stamp: 'MarcusDenker 6/14/2013 15:33'! name ^ name! ! !OCUndeclaredVariableWarning commentStamp: ''! I get signalled when a temporary variable is used that is not defined. My default action is to create an Undeclared binding and add it to the Undeclared dictionary.! !OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/17/2013 16:25'! declareClassVar self methodClass theNonMetaClass addClassVarNamed: node name asSymbol. ^ (node owningScope lookupVar: node name) ifNil: [self error: 'should be found']! ! !OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: 'MarcusDenker 6/4/2013 14:44'! declareInstVar: name "Declare an instance variable." self methodClass addInstVarNamed: name. "We are changing a class after the scope hierarchy was created, so we need to update the Instance Scope" self methodNode scope instanceScope vars: self methodClass allInstVarNames. ^ (node owningScope lookupVar: node name) ifNil: [self error: 'should not happen']! ! !OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: 'MarcusDenker 7/9/2013 13:27'! defaultAction | varName className selector | className := self methodClass name . selector := self methodNode selector. varName := node name. self methodNode selector ifNotNil: [self crTrace: className, '>>', selector, ' '] ifNil: [self traceCr:'']. self traceCr: '(' , varName , ' is Undeclared) '. ^super defaultAction ifNil: [ Undeclared at: varName asSymbol put: nil. OCUndeclaredVariable new name: varName asSymbol]! ! !OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/17/2013 16:25'! possibleVariablesFor: proposedVariable | results class | class := node methodNode methodClass . results := proposedVariable correctAgainst: node temporaryVariables continuedFrom: nil. proposedVariable first canBeGlobalVarInitial ifTrue: [ results := class possibleVariablesFor: proposedVariable continuedFrom: results ]. ^ proposedVariable correctAgainst: nil continuedFrom: results. ! ! !OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: 'BenComan 3/3/2014 09:17'! openMenuIn: aBlock | alternatives labels actions lines caption choice name interval | interval := node sourceInterval. name := node name. alternatives := self possibleVariablesFor: name. labels := OrderedCollection new. actions := OrderedCollection new. lines := OrderedCollection new. name first isLowercase ifTrue: [labels add: 'Declare new temporary variable'. actions add: [self declareTempAndPaste: name]. labels add: 'Declare new instance variable'. actions add: [self declareInstVar: name]] ifFalse: [labels add: 'Define new class'. actions add: [self defineClass: name]. labels add: 'Declare new global'. actions add: [self declareGlobal]. labels add: 'Declare new class variable'. actions add: [self declareClassVar]]. lines add: labels size. alternatives do: [:each | labels add: each. actions add: [ self substituteVariable: each atInterval: interval. (OCSourceCodeChanged new newSourceCode: self requestor text) signal. ]]. lines add: labels size. labels add: 'Cancel'. caption := 'Unknown variable: ' , name , ' please correct, or cancel:'. choice := aBlock value: labels value: lines value: caption. choice ifNotNil: [self resume: (actions at: choice ifAbsent: [compilationContext failBlock value]) value]! ! !OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: 'AlexandreBergel 11/11/2013 13:29'! declareTempAndPaste: name | insertion delta theTextString characterBeforeMark tempsMark newMethodNode | "Below we are getting the text that is actually seen in the morph. This is rather ugly. Maybe there is a better way to do this." theTextString := self requestor textMorph editor paragraph text. "We parse again the method displayed in the morph. The variable methodNode has the first version of the method, without temporary declarations. " newMethodNode := RBParser parseMethod: theTextString. "We check if there is a declaration of temporary variables" tempsMark := newMethodNode body rightBar ifNil: [ self methodNode body start ]. characterBeforeMark := theTextString at: tempsMark-1 ifAbsent: [$ ]. (theTextString at: tempsMark) = $| ifTrue: [ "Paste it before the second vertical bar" insertion := name, ' '. characterBeforeMark isSeparator ifFalse: [ insertion := ' ', insertion]. delta := 0. ] ifFalse: [ "No bars - insert some with CR, tab" insertion := '| ' , name , ' |',String cr. delta := 2. "the bar and CR" characterBeforeMark = Character tab ifTrue: [ insertion := insertion , String tab. delta := delta + 1. "the tab" ] ]. tempsMark := tempsMark + (self substituteWord: insertion wordInterval: (tempsMark to: tempsMark-1) offset: 0) - delta. self methodNode scope addTemp: name. ^ (node owningScope lookupVar: node name) ifNil: [self error: 'should not happen'] ! ! !OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/18/2013 16:27'! defineClass: className "Prompts the user to define a new class." | classSymbol systemCategory classDefinition | classSymbol := className asSymbol. systemCategory := self methodClass category ifNil: [ 'Unknown' ]. classDefinition := 'Object subclass: #' , classSymbol , ' instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''' , systemCategory , ''''. classDefinition := UIManager default multiLineRequest: 'Edit class definition:' initialAnswer: classDefinition answerHeight: 150. (classDefinition isNil or: [ classDefinition isEmpty ]) ifTrue: [ ^ self error ]. self class compiler evaluate: classDefinition. ^ (node owningScope lookupVar: className) ifNil: [self error: 'should be not happen']! ! !OCUndeclaredVariableWarning methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 16:27'! node: aVariableNode super node: aVariableNode. messageText := 'Undeclared temp: ', aVariableNode name. ! ! !OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/17/2013 16:25'! declareGlobal Smalltalk at: node name asSymbol put: nil. ^ (node owningScope lookupVar: node name) ifNil: [self error: 'should be not happen']! ! !OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: 'MarcusDenker 5/17/2013 14:45'! substituteWord: correctWord wordInterval: spot offset: o "Substitute the correctSelector into the (presuamed interactive) receiver." self requestor correctFrom: (spot first + o) to: (spot last + o) with: correctWord. ^ o + correctWord size - spot size! ! !OCUndeclaredVariableWarning methodsFor: 'correcting' stamp: 'BenComan 3/3/2014 14:28'! substituteVariable: varName atInterval: anInterval self substituteWord: varName wordInterval: anInterval offset: 0. self methodNode source: self requestor text. node replaceWith:((RBVariableNode named: varName) binding: (node owningScope lookupVar: varName)). ^ (node owningScope lookupVar: varName) ifNil: [self error: 'should be found'].! ! !OCUninitializedVariableWarning commentStamp: 'ajh 3/24/2003 22:34'! I get signalled when a temporary variable is used before it is assigned to. My default action is to allow it since all temps get initialized to nil.! !OCUninitializedVariableWarning methodsFor: 'correcting' stamp: 'NicolaiHess 2/5/2014 10:07'! openMenuIn: aBlock | caption index | caption := node name, ' appears to be uninitialized at this point. Proceed anyway?'. index := aBlock value: #('yes' 'no') value: #() value: caption. (index = 1) ifFalse:[^self compilationContext failBlock value]. ^ self resume: true.! ! !OCUninitializedVariableWarning methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 16:27'! node: aVariableNode super node: aVariableNode. messageText := 'Uninitialized temp: ', aVariableNode name. ! ! !OCUnknownSelectorWarning commentStamp: 'ajh 3/24/2003 22:23'! I get signalled when no selector is defined for a message send, indicating a possible mispelling. My default action is to create a new selector.! !OCUnknownSelectorWarning methodsFor: 'correcting' stamp: 'NicolaiHess 2/5/2014 01:06'! replaceSelectorTextTo: aNewSelector | offset | offset := 0. aNewSelector keywords doWithIndex: [ :k :i | | selectorPart | selectorPart := self node selectorParts at: i. self requestor correctFrom: offset + selectorPart start to: offset + selectorPart stop with: k. offset := offset + k size - selectorPart value size ]! ! !OCUnknownSelectorWarning methodsFor: 'correcting' stamp: 'NicolaiHess 2/5/2014 01:07'! openMenuIn: aBlock | alternatives labels lines caption choice name newSelector | name := node selector. alternatives := Symbol possibleSelectorsFor: name. labels := Array streamContents: [:s | s nextPut: name; nextPutAll: alternatives; nextPut: 'cancel']. lines := {1. alternatives size + 1}. caption := 'Unknown selector, please\confirm, correct, or cancel' withCRs. choice := aBlock value: labels value: lines value: caption. (choice isZero or: [ choice = labels size ]) ifTrue: [ ^ self compilationContext failBlock value ]. choice = 1 ifFalse: [ newSelector := alternatives at: choice - 1. self replaceSelectorTextTo: newSelector. self node selector: newSelector]. self resume: true.! ! !OCUnknownSelectorWarning methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 16:34'! node: aMessageNode super node: aMessageNode. messageText := 'Unknown selector: ', aMessageNode selector. ! ! !OCUnusedVariableWarning commentStamp: 'ajh 3/24/2003 22:35'! I get signalled when a temporary variable is declared but never used. My default action is to allow it since it is benign.! !OCUnusedVariableWarning methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 16:27'! node: aVariableNode super node: aVariableNode. messageText := 'Unused temp: ', aVariableNode name. ! ! !OCUnusedVariableWarning methodsFor: 'correcting' stamp: 'NicolaiHess 2/3/2014 21:44'! defaultAction | answer | self errorNotification ifFalse: [ ^nil ]. answer := UIManager default chooseFrom: #('yes' 'no') lines: #() title: node name asWideString, ' appears to be unused in this method. OK to remove it?' withCRs. (answer = 2 ) ifTrue: [ ^self]. (answer = 0 ) ifTrue: [ self compilationContext failBlock value]. self node parent scope removeTemp: (self node parent scope lookupVar:(node name)). self node parent removeTemporaryNamed: node name. self requestor correctFrom: node start to: node stop with: ''. ! ! !OCVectorTempVariable methodsFor: 'emitting' stamp: 'MarcusDenker 12/18/2012 16:42'! emitStore: methodBuilder methodBuilder storeRemoteTemp: name inVector: vectorName.! ! !OCVectorTempVariable methodsFor: 'emitting' stamp: 'MarcusDenker 12/18/2012 16:42'! emitValue: methodBuilder methodBuilder pushRemoteTemp: name inVector: vectorName.! ! !OCVectorTempVariable methodsFor: 'accessing' stamp: 'MarcusDenker 12/18/2012 16:43'! vectorName: anObject vectorName := anObject! ! !OCVectorTempVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/5/2010 17:13'! isRemote ^true! ! !OCVectorTempVariable methodsFor: 'accessing' stamp: 'MarcusDenker 12/18/2012 16:44'! vectorName ^ vectorName! ! !OCVectorTempVariable methodsFor: 'debugging' stamp: 'MarcusDenker 12/20/2012 14:39'! readFromContext: aContext scope: contextScope | tempVectorVar theVector offset | tempVectorVar := scope lookupVar: vectorName. theVector := tempVectorVar readFromContext: aContext scope: contextScope. offset := tempVectorVar indexInTempVectorFromIR: name. ^theVector at: offset.! ! !OCVectorTempVariable methodsFor: 'testing' stamp: 'MarcusDenker 9/9/2010 16:11'! isTempVectorTemp ^true! ! !OCVectorTempVariable methodsFor: 'debugging' stamp: 'MarcusDenker 12/18/2012 16:42'! writeFromContext: aContext scope: contextScope value: aValue | tempVectorVar theVector offset | tempVectorVar := scope lookupVar: vectorName. theVector := tempVectorVar readFromContext: aContext scope: tempVectorVar scope. offset := tempVectorVar indexInTempVectorFromIR: name. ^theVector at: offset put: aValue.! ! !OSEnvironment commentStamp: ''! I represent the user environment variables. See `man environ` for more details.! !OSEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 4/29/2013 16:16'! at: key ifAbsentPut: aBlock "Return the value at the given key. If key is not included in the receiver store the result of evaluating aBlock as new value." ^ self at: key ifAbsent: [ self at: key put: aBlock value ]! ! !OSEnvironment methodsFor: 'enumeration' stamp: 'CamilloBruni 4/29/2013 17:42'! keysAndValuesDo: aBlock withAssociationString: associationString | equalsIndex | equalsIndex := associationString indexOf: $=. aBlock value: (associationString first: equalsIndex-1) value: (associationString allButFirst: equalsIndex). ! ! !OSEnvironment methodsFor: 'private' stamp: 'CamilloBruni 4/29/2013 15:43'! getEnv: string "This method calls the Standard C Library getenv() function" ^ self nbCall: #( String getenv (String string) ) module: NativeBoost CLibrary! ! !OSEnvironment methodsFor: 'private' stamp: 'CamilloBruni 4/29/2013 15:52'! unsetEnv: string "This method calls the Standard C Library getenv() function" ^ self nbCall: #( int unsetenv (String string) ) module: NativeBoost CLibrary! ! !OSEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 4/29/2013 16:16'! at: key ifPresent: oneArgBlock ifAbsent: absentBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating the oneArgBlock with the value associated with the key, otherwise answer the value of absentBlock." self at: key ifPresent: [ :v | ^oneArgBlock value: v ]. ^absentBlock value! ! !OSEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 4/29/2013 16:18'! keys "Answer an Array containing the receiver's keys." ^Array streamContents: [ :s | self keysDo: [ :key | s nextPut: key]]! ! !OSEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 5/4/2013 15:25'! removeKey: key ^ self unsetEnv: key! ! !OSEnvironment methodsFor: 'enumeration' stamp: 'CamilloBruni 4/29/2013 16:21'! associationsDo: aBlock ^ self keysAndValuesDo: [ :key :value | aBlock value: key -> value ]! ! !OSEnvironment methodsFor: 'testing' stamp: 'CamilloBruni 5/4/2013 15:27'! includes: anObject self do: [:each | anObject = each ifTrue: [^true]]. ^false! ! !OSEnvironment methodsFor: 'enumeration' stamp: 'CamilloBruni 4/29/2013 16:21'! keysDo: aBlock ^ self keysAndValuesDo: [ :key :value | aBlock value: key ]! ! !OSEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 4/29/2013 16:50'! platform ^ platform! ! !OSEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 5/4/2013 15:29'! at: aKey ifPresent: aBlock ^ aBlock value: (self at: aKey ifAbsent: [ ^ nil ])! ! !OSEnvironment methodsFor: 'accessing' stamp: 'CamilloBrunui 5/6/2013 16:37'! at: aKey put: aValue ^ self setEnv: aKey value: aValue! ! !OSEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 4/29/2013 16:14'! at: aKey ^ self at: aKey ifAbsent: [ KeyNotFound signalFor: aKey ]! ! !OSEnvironment methodsFor: 'enumeration' stamp: 'CamilloBruni 5/4/2013 15:31'! do: aBlock ^self valuesDo: aBlock! ! !OSEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 4/29/2013 16:14'! at: aKey ifAbsent: aBlock ^ (self getEnv: aKey) ifNil: aBlock! ! !OSEnvironment methodsFor: 'enumeration' stamp: 'CamilloBruni 4/29/2013 16:22'! valuesDo: aBlock ^ self keysAndValuesDo: [ :key :value | aBlock value: value ]! ! !OSEnvironment methodsFor: 'converting' stamp: 'CamilloBruni 4/29/2013 16:24'! asDictionary | dictionary | dictionary := Dictionary new. self keysAndValuesDo: [ :key :value | dictionary at: key put: value ]. ^ dictionary! ! !OSEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 4/29/2013 16:17'! associations "Answer a Collection containing the receiver's associations." ^Array streamContents: [ :stream | self associationsDo: [ :each | stream nextPut: each ]]! ! !OSEnvironment methodsFor: 'enumeration' stamp: 'CamilloBruni 4/29/2013 17:43'! keysAndValuesDo: aBlock self subclassResponsibility! ! !OSEnvironment methodsFor: 'testing' stamp: 'CamilloBruni 5/4/2013 15:30'! includesKey: aKey ^ self at: aKey ifPresent: [ :value | true ] ifAbsent: [ false ].! ! !OSEnvironment methodsFor: 'initialize-release' stamp: 'CamilloBruni 4/29/2013 16:50'! initializeWith: anOSPlatform super initialize. platform := anOSPlatform! ! !OSEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 4/29/2013 16:19'! values "Answer a Collection containing the receiver's values." ^ Array streamContents: [ :stream| self valuesDo: [ :value | stream nextPut: value ]]! ! !OSEnvironment class methodsFor: 'testing' stamp: 'EstebanLorenzano 1/24/2014 16:38'! isDefaultFor: aPlatform ^ false! ! !OSEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/29/2013 15:47'! default ^ self new! ! !OSEnvironment class methodsFor: 'testing' stamp: 'EstebanLorenzano 1/24/2014 16:38'! isAvailable ^ NativeBoost isAvailable! ! !OSEnvironment class methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/24/2014 16:37'! environmentFor: aPlatform | environmentClass | environmentClass := self allSubclasses detect: [ :each | each isDefaultFor: aPlatform ] ifNone: [ nil ]. ^ (environmentClass notNil and: [ environmentClass isAvailable ]) ifTrue: [ environmentClass platform: aPlatform ] ifFalse: [ PlatformIndependentEnvironment platform: aPlatform ]! ! !OSEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/29/2013 16:50'! platform: anOSPlatform ^ self basicNew initializeWith: anOSPlatform ! ! !OSEnvironmentTest commentStamp: ''! This tests the OSEnvironment. The tests assume that there is at least 1 environment variable given.! !OSEnvironmentTest methodsFor: 'tests' stamp: 'CamilloBruni 5/4/2013 15:25'! testAtPut | key value env | env := self instance. value := 1000 atRandom asString. key := 'OSEnvironmentTest >> #testAtPut >> ', value. env at: key put: value. self assert: (env at: key) equals: value. env removeKey: key. self deny: (env includesKey: key)! ! !OSEnvironmentTest methodsFor: 'tests' stamp: 'CamilloBruni 5/4/2013 15:24'! testAssociations | associations | associations := self instance associations. self deny: associations isEmpty. self assert: associations anyOne key isString. self assert: associations anyOne value isString.! ! !OSEnvironmentTest methodsFor: 'helper' stamp: 'cami 7/22/2013 18:17'! instance ^ Smalltalk os environment! ! !OSEnvironmentTest methodsFor: 'tests' stamp: 'CamilloBruni 5/4/2013 15:28'! testKeys | env keys | env := self instance. keys := env keys. self deny: keys isEmpty. self assert: keys anyOne isString. self assert: (env includesKey: keys anyOne)! ! !OSEnvironmentTest methodsFor: 'tests' stamp: 'EstebanLorenzano 1/25/2014 13:15'! testEnvironmentFor { MacOSPlatform -> UnixEnvironment. MacOSXPlatform -> UnixEnvironment. UnixPlatform -> UnixEnvironment. Win32Platform -> Win32Environment } asDictionary keysAndValuesDo: [ :platformClass :envClass | self assert: (OSEnvironment environmentFor: platformClass new) class equals: envClass ] ! ! !OSEnvironmentTest methodsFor: 'tests' stamp: 'CamilloBruni 5/4/2013 15:30'! testValues | env values | env := self instance. values := env values. self deny: values isEmpty. self assert: values anyOne isString. self assert: (env includes: values anyOne)! ! !OSEnvironmentTest methodsFor: 'tests' stamp: 'CamilloBruni 5/4/2013 15:19'! testAsDictionary self assert: self instance asDictionary isDictionary! ! !OSPlatform commentStamp: 'michael.rueger 2/25/2009 18:29'! An OSPlatform is an abstract representation of a 'OS platform'. Platforms can be hierarchical, e.g., a "general" platform as superclass and more specific platforms as subclasses as long as the subclasses provide sufficient means to identify themselves. The original implementation was for Tweak. Current holds the current OSPlatform subclass Architectural considerations: most platform specific methods that need to be added to the platform class should be in the form of extensions rather then adding them directly to this package. Otherwise the platform class will degenerate very quickly into a dependence hub for all kinds of sub systems.! !OSPlatform methodsFor: '*System-Clipboard' stamp: 'AlainPlantec 3/2/2010 14:41'! clipboardClass ^Clipboard! ! !OSPlatform methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/12/2013 14:16'! lineEnding ^ self subclassResponsibility! ! !OSPlatform methodsFor: 'compatbility' stamp: 'cami 7/22/2013 18:33'! platformFamily ^ self family! ! !OSPlatform methodsFor: 'accessing' stamp: 'CamilloBruni 5/9/2013 22:40'! version "Return the version number string of the platform we're running on" ^ self class currentVersion! ! !OSPlatform methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2013 22:25'! isMacOSX ^ false! ! !OSPlatform methodsFor: 'testing' stamp: 'cami 7/22/2013 18:27'! isWindows ^ false! ! !OSPlatform methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/24/2014 16:39'! environment ^ environment ifNil: [ environment := self createEnvironment ]! ! !OSPlatform methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2013 22:25'! isMacOS ^ false! ! !OSPlatform methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2013 22:30'! isX11 ^ self windowSystemName = 'X11'! ! !OSPlatform methodsFor: 'private' stamp: 'EstebanLorenzano 1/24/2014 16:38'! createEnvironment ^ OSEnvironment environmentFor: self! ! !OSPlatform methodsFor: 'accessing' stamp: 'cami 7/22/2013 18:33'! family "Returns a symbol specific to the platform family (MacOSX, Windows, Unix, RiscOS). This may need to be extended if there are new platforms added or significant differences within a platform family arise (as was the case between MacOS 9 and X)." self subclassResponsibility! ! !OSPlatform methodsFor: 'initialize' stamp: 'VeronicaUquillas 6/11/2010 14:40'! shutDown: quitting "Pharo is shutting down. If this platform requires specific shutdown code, this is a great place to put it." ! ! !OSPlatform methodsFor: 'accessing' stamp: 'CamilloBruni 5/9/2013 22:32'! virtualKey: virtualKeyCode "Subclass responsibility to override if necessary" ^nil! ! !OSPlatform methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2013 22:25'! isUnix ^ false! ! !OSPlatform methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2013 22:25'! isWin32 ^ false! ! !OSPlatform methodsFor: 'compatbility' stamp: 'cami 7/22/2013 18:37'! platformName ^ self name! ! !OSPlatform methodsFor: 'accessing' stamp: 'CamilloBruni 5/9/2013 22:22'! subtype "Return the subType of the platform we're running on" ^ (Smalltalk vm getSystemAttribute: 1003)! ! !OSPlatform methodsFor: 'accessing' stamp: 'CamilloBruni 5/9/2013 22:30'! windowSystemName "Return the name of the window system currently being used for display." ^ Smalltalk vm getSystemAttribute: 1005! ! !OSPlatform methodsFor: '*Files' stamp: 'DamienCassou 11/7/2013 16:18'! potentialLocationsOfSourcesFile "Return a collection of directories where the PharoVXX.sources should be searched." ^ self subclassResponsibility! ! !OSPlatform methodsFor: 'accessing' stamp: 'CamilloBruni 5/9/2013 22:37'! name "Return the name of the platform we're running on" ^ self class currentPlatformName! ! !OSPlatform methodsFor: 'initialize' stamp: 'VeronicaUquillas 6/11/2010 14:40'! startUp: resuming "Pharo is starting up. If this platform requires specific intialization, this is a great place to put it." ! ! !OSPlatform methodsFor: 'accessing' stamp: 'cami 7/22/2013 18:17'! current ^ self! ! !OSPlatform methodsFor: '*Keymapping-KeyCombinations' stamp: 'BenjaminVanRyseghem 11/29/2013 16:01'! defaultModifier ^ self subclassResponsibility! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:43'! platformSubtype self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os subtype` instead' on: '2013-07-22' in: #Pharo30. ^ self current subtype! ! !OSPlatform class methodsFor: 'system attributes' stamp: 'CamilloBruni 5/9/2013 22:38'! currentVersion "Return the version number string of the platform we're running on" ^ (Smalltalk vm getSystemAttribute: 1002) asString! ! !OSPlatform class methodsFor: 'private' stamp: 'EstebanLorenzano 1/24/2014 16:39'! determineActivePlatform "Look for the matching platform class" ^ self allSubclasses detect: [ :any | any isActivePlatform ]. ! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:41'! vmVersion self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk vm version` instead' on: '2013-07-22' in: #Pharo30. ^Smalltalk vm version! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:43'! version self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os version` instead' on: '2013-07-22' in: #Pharo30. ^ self current version! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:43'! osVersion self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os version` instead' on: '2013-07-22' in: #Pharo30. ^ self current version! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:42'! isMacOSX self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os isMacOSX` instead' on: '2013-07-22' in: #Pharo30. ^ self current isMacOSX! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:43'! isX11 self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os isX11` instead' on: '2013-07-22' in: #Pharo30. ^ self current isX11! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:42'! isMacOS self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os isMacOS` instead' on: '2013-07-22' in: #Pharo30. ^ self current isMacOS! ! !OSPlatform class methodsFor: 'class initialization' stamp: 'CamilloBruni 5/9/2013 22:40'! initialize "Initialize the receiver" "OSPlatform initialize" Smalltalk removeFromStartUpList: self; addToStartUpList: self after: Delay; removeFromShutDownList: self; addToShutDownList: self after: DisplayScreen. self startUp: true.! ! !OSPlatform class methodsFor: 'private' stamp: 'ar 12/11/2004 22:22'! isActivePlatform "Answer whether the receiver is the active platform" ^false! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:43'! isWin32 self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os isWin32` instead' on: '2013-07-22' in: #Pharo30. ^ self current isWin32! ! !OSPlatform class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 1/24/2014 16:39'! shutDown: quitting "The system is going down" Current ifNotNil: [ Current shutDown: quitting ]. ! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:44'! virtualKey: virtualKeyCode self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os` instead' on: '2013-07-22' in: #Pharo30. "Subclass responsibility to override if necessary" ^self current virtualKey: virtualKeyCode! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:43'! isUnix self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os isUnix` instead' on: '2013-07-22' in: #Pharo30. ^ self current isUnix! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:43'! platformName self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os name` instead' on: '2013-07-22' in: #Pharo30. ^ self current name! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:43'! subtype self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os subtype` instead' on: '2013-07-22' in: #Pharo30. ^ self current subtype! ! !OSPlatform class methodsFor: 'system attributes' stamp: 'CamilloBruni 5/9/2013 22:37'! currentPlatformName "Return the name of the platform we're running on" ^ Smalltalk vm getSystemAttribute: 1001! ! !OSPlatform class methodsFor: '*Deprecated30' stamp: 'cami 7/22/2013 18:44'! windowSystemName self deprecated: 'Do not refer to OSPlatform directly, use `Smalltalk os windowSystemName` instead' on: '2013-07-22' in: #Pharo30. ^ self current windowSystemName! ! !OSPlatform class methodsFor: 'accessing' stamp: 'ar 12/11/2004 23:04'! current "Answer the current platform" ^Current! ! !OSPlatform class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 1/24/2014 16:39'! startUp: resuming "Determine the current platform." resuming ifFalse: [ ^ self ]. Current := self determineActivePlatform new. Current startUp: resuming! ! !OSPlatformTest methodsFor: 'testing' stamp: 'LaurentLaffont 5/25/2010 21:53'! testStartUpList "This test documents issue http://code.google.com/p/pharo/issues/detail?id=838" self should: [ ((SmalltalkImage classPool at: 'StartUpList') indexOf: #OSPlatform) < ((SmalltalkImage classPool at: 'StartUpList') indexOf: #InputEventSensor) ]! ! !OSPlatformTest methodsFor: 'testing' stamp: 'cami 7/22/2013 18:35'! testAPI "A test to make sure the full API will work" Smalltalk os isMacOS; isMacOSX; isWin32; isWindows; isX11; name; subtype; family.! ! !Object commentStamp: ''! Object is the root class for almost all of the other classes in the class hierarchy. The exceptions are ProtoObject (the superclass of Object) and its subclasses. Class Object provides default behavior common to all normal objects, such as access, copying, comparison, error handling, message sending, and reflection. Also utility messages that all objects should respond to are defined here. Object has no instance variables, nor should any be added. This is due to several classes of objects that inherit from Object that have special implementations (SmallInteger and UndefinedObject for example) or the VM knows about and depends on the structure and layout of certain standard classes. Class Variables: DependentsFields an IdentityDictionary Provides a virtual 'dependents' field so that any object may have one or more dependent views, synchronized by the changed:/update: protocol. Note that class Model has a real slot for its dependents, and overrides the associated protocol with more efficient implementations. Because Object is the root of the inheritance tree, methods are often defined in Object to give all objects special behaviors needed by certain subsystems or applications, or to respond to certain general test messages such as isMorph. Miscellanous Discussions. About at: index accepting float and not only integers This behavior is also free in the sense that the failure code is only invoked when the primitive fails and so adds nothing to the cost of successful accesses, which are the high dynamic frequency operation. It will also show up under profiling if one is concerned about efficiency, and so isn't a hidden cost. It is also in keeping with Smalltalk's mixed mode/arbitrary precision implicit coercion number system that one *can* use fractions or floats as indices. Stripping out coercions like this will make the system more brittle. So please do *not* remove this "hack". I think it's a feature and a useful one. Can you give me an example that demonstrates the usefulness of this feature? | a r | a := Array new: 10 withAll: 0. r := Random new. 100 timesRepeat: [| v | v := r next * 10 + 1. a at: v put: (a at: v) + 1]. a i.e. I didn't have to provide an explicit rounding step. That's useful. But in general anywhere where an index is derived by some calculation not having to provide the rounding step could be useful/helpful/more concise. e.g. (n roundTo: 0.1) * 10 vs ((n roundTo: 0.1) * 10) asInteger. Some thought went into the original choice. It is not a hack but there by intent. The integers are simply a subset of the reals and forcing the programmer to use them is favouring the machine above the programmer. But I think you should justify getting rid of it rather than my having to justify keeping it. Getting rid of it risks breaking code. If it is there but does not harm then why get rid of it? best Eliot Miranda ! !Object methodsFor: 'memory usage' stamp: 'GuillermoPolito 6/28/2013 11:06'! sizeInMemory "Answer the number of bytes consumed by this instance including object header." | contentBytes | contentBytes := Smalltalk wordSize. "base header" contentBytes := contentBytes + (self class instSize * Smalltalk wordSize). "instance vars" self class isVariable ifTrue:[ | bytesPerElement | "indexed elements" bytesPerElement := self class isBytes ifTrue: [1] ifFalse: [4]. contentBytes := (contentBytes + (self basicSize * bytesPerElement)). "If we are not filling an ammount of bytes multiple of the wordSize, we do it" (contentBytes \\ Smalltalk wordSize) = 0 ifFalse: [ | extraBytesToFillAWord | extraBytesToFillAWord := Smalltalk wordSize - (contentBytes \\ Smalltalk wordSize). contentBytes := contentBytes + extraBytesToFillAWord. ] ]. contentBytes > 255 ifTrue: [ contentBytes := contentBytes + (2 * Smalltalk wordSize) ] ifFalse: [ self class isCompact ifFalse: [ contentBytes := contentBytes + Smalltalk wordSize] ]. ^contentBytes! ! !Object methodsFor: 'drag and drop' stamp: ''! acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph ^false.! ! !Object methodsFor: '*Collections-Abstract-splitjoin' stamp: 'onierstrasz 4/12/2009 19:58'! appendTo: aCollection "double dispatch for join:" ^ aCollection addLast: self! ! !Object methodsFor: 'message performing' stamp: 'ClementBera 4/21/2013 14:49'! perform: selector withArguments: argArray "Send the selector, aSymbol, to the receiver with arguments in argArray. Fail if the number of arguments expected by the selector does not match the size of argArray. Primitive. Optional. See Object documentation whatIsAPrimitive." ^ self perform: selector withArguments: argArray inSuperclass: self class! ! !Object methodsFor: 'introspection' stamp: 'eem 5/14/2008 13:20'! instVarNamed: aString "Return the value of the instance variable in me with that name. Slow and unclean, but very useful. " ^ self instVarAt: (self class instVarIndexFor: aString asString ifAbsent: [self error: 'no such inst var']) ! ! !Object methodsFor: 'flagging' stamp: 'sw 8/4/97 16:49'! isThisEverCalled ^ self isThisEverCalled: thisContext sender printString! ! !Object methodsFor: 'converting' stamp: 'nice 3/28/2006 23:29'! adaptToInteger: rcvr andCompare: selector "If I am involved in comparison with an Integer. Default behaviour is to process comparison as any other selectors." ^ self adaptToInteger: rcvr andSend: selector! ! !Object methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/24/2012 16:07'! nbCall: fnSpec options: callOptions " you can override this method if you need to" ^ (self nbCalloutIn: thisContext sender) convention: self nbCallingConvention; options: callOptions; function: fnSpec module: self nbLibraryNameOrHandle ! ! !Object methodsFor: 'user interface' stamp: 'sw 10/5/1998 14:39'! addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph "The receiver serves as the model for aMorph; a menu is being constructed for the morph, and here the receiver is able to add its own items" ! ! !Object methodsFor: '*Tools-Base' stamp: 'EstebanLorenzano 5/14/2013 09:43'! defaultBackgroundColor "Answer the color to be used as the base window color for a window whose model is an object of the receiver's class" "I don't want to do a self theme because otherwise I will need to implement it on Object" ^ Smalltalk ui theme windowColorFor: self! ! !Object methodsFor: 'reflective operations' stamp: 'MartinDias 7/1/2013 14:55'! becomeForward: otherObject copyHash: copyHash "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. If copyHash is true, the argument's identity hash bits will be set to those of the receiver. Fails if either argument is a SmallInteger." (Array with: self) elementsForwardIdentityTo: (Array with: otherObject) copyHash: copyHash! ! !Object methodsFor: '*Kernel-Exceptions-debugging' stamp: 'SeanDeNigris 8/29/2011 10:51'! haltIf: condition Halt if: condition.! ! !Object methodsFor: 'printing' stamp: 'di 6/20/97 09:12'! storeString "Answer a String representation of the receiver from which the receiver can be reconstructed." ^ String streamContents: [:s | self storeOn: s]! ! !Object methodsFor: '*Monticello-Storing' stamp: 'tk 4/8/1999 12:05'! readDataFrom: aDataStream size: varsOnDisk "Fill in the fields of self based on the contents of aDataStream. Return self. Read in the instance-variables written by Object>>storeDataOn:. NOTE: This method must send beginReference: before reading any objects from aDataStream that might reference it. Allow aDataStream to have fewer inst vars. See SmartRefStream." | cntInstVars cntIndexedVars | cntInstVars := self class instSize. self class isVariable ifTrue: [cntIndexedVars := varsOnDisk - cntInstVars. cntIndexedVars < 0 ifTrue: [ self error: 'Class has changed too much. Define a convertxxx method']] ifFalse: [cntIndexedVars := 0. cntInstVars := varsOnDisk]. "OK if fewer than now" aDataStream beginReference: self. 1 to: cntInstVars do: [:i | self instVarAt: i put: aDataStream next]. 1 to: cntIndexedVars do: [:i | self basicAt: i put: aDataStream next]. "Total number read MUST be equal to varsOnDisk!!" ^ self "If we ever return something other than self, fix calls on (super readDataFrom: aDataStream size: anInteger)"! ! !Object methodsFor: 'nil testing' stamp: 'MarcusDenker 12/2/2013 14:15'! ifNotNilDo: aBlock ifNil: nilBlock "please use #ifNotNil:ifNil: " ^ aBlock value: self ! ! !Object methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! metacelloIntegerLessThanSelf: anInteger ^self error: 'Invalid Metacello verson component - should be String or Integer.'! ! !Object methodsFor: '*System-Settings-Browser' stamp: 'alain.plantec 3/24/2009 23:21'! settingFixedDomainValueNodeFrom: aSettingNode ^ aSettingNode fixedDomainValueNodeForObject: self! ! !Object methodsFor: 'finalization' stamp: 'ar 3/21/98 16:27'! finalize "Finalize the resource associated with the receiver. This message should only be sent during the finalization process. There is NO garantuee that the resource associated with the receiver hasn't been free'd before so take care that you don't run into trouble - this all may happen with interrupt priority."! ! !Object methodsFor: '*Monticello-Storing' stamp: 'CamilloBruni 8/1/2012 16:02'! comeFullyUpOnReload: smartRefStream "Normally this read-in object is exactly what we want to store." ^ self! ! !Object methodsFor: '*Kernel-Exceptions-debugging' stamp: 'MarcusDenker 2/29/2012 08:24'! halt: aString Halt now: aString! ! !Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:11'! dragTransferType ^nil! ! !Object methodsFor: 'testing' stamp: 'ar 9/13/2000 15:37'! isMorphicEvent ^false! ! !Object methodsFor: 'message performing' stamp: 'ClementBera 4/21/2013 14:53'! perform: aSymbol "Send the unary selector, aSymbol, to the receiver. Fail if the number of arguments expected by the selector is not zero. Primitive. Optional. See Object documentation whatIsAPrimitive." ^ self perform: aSymbol withArguments: (Array new: 0)! ! !Object methodsFor: 'events-accessing' stamp: 'reThink 2/25/2001 08:50'! updateableActionMap ^EventManager updateableActionMapFor: self! ! !Object methodsFor: 'testing' stamp: 'sw 1/12/98 18:09'! haltIfNil! ! !Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/24/2006 11:50'! when: anEventSelector sendOnce: aMessageSelector to: anObject self when: anEventSelector evaluate: (NonReentrantWeakMessageSend receiver: anObject selector: aMessageSelector)! ! !Object methodsFor: '*Kernel-Exceptions-debugging' stamp: 'CamilloBruni 7/17/2013 20:08'! halt "This is the typical message to use for inserting breakpoints during debugging." Halt now! ! !Object methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 15:23'! valueWithArguments: aSequenceOfArguments ^self! ! !Object methodsFor: 'events-registering' stamp: 'reThink 2/18/2001 15:04'! when: anEventSelector evaluate: anAction | actions | actions := self actionSequenceForEvent: anEventSelector. (actions includes: anAction) ifTrue: [^ self]. self setActionSequence: (actions copyWith: anAction) forEvent: anEventSelector! ! !Object methodsFor: 'pointing to' stamp: 'G.C 10/22/2008 09:59'! refersToLiteral: literal "Answer true if literal is identical to any literal in this array, even if imbedded in further structures. This is the end of the imbedded structure path so return false." ^ false! ! !Object methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/24/2012 16:07'! nbCall: fnSpec module: aModuleNameOrHandle " you can override this method if you need to" ^ (self nbCalloutIn: thisContext sender) convention: self nbCallingConvention; function: fnSpec module: aModuleNameOrHandle ! ! !Object methodsFor: '*Collections-Abstract-splitjoin' stamp: 'onierstrasz 4/12/2009 19:58'! joinTo: stream "double dispatch for join:" ^ stream nextPut: self! ! !Object methodsFor: 'private' stamp: 'yo 6/29/2004 11:37'! errorNotIndexable "Create an error notification that the receiver is not indexable." self error: ('Instances of {1} are not indexable' translated format: {self class name})! ! !Object methodsFor: '*Morphic-Base' stamp: 'MarcusDenker 7/20/2012 14:57'! asStringMorph "Open a StringMorph, as best one can, on the receiver" ^ self asString asStringMorph ! ! !Object methodsFor: 'events-accessing' stamp: 'gk 8/14/2007 23:53'! hasActionsWithReceiver: anObject ^self actionMap keys anySatisfy: [:eachEventSelector | (self actionSequenceForEvent: eachEventSelector) anySatisfy: [:anAction | anAction receiver == anObject]]! ! !Object methodsFor: 'set implementation' stamp: 'Igor.Stasenko 11/13/2009 07:19'! enclosedSetElement "The receiver is included into a set as an element. Since some objects require wrappers (see SetElement) to be able to be included into a Set, a set sends this message to its element to make sure it getting real object, instead of its wrapper. Only SetElement instance or its subclasses allowed to answer something different than receiver itself" ! ! !Object methodsFor: 'testing' stamp: 'ar 8/17/1999 19:43'! isCollection "Return true if the receiver is some sort of Collection and responds to basic collection messages such as #size and #do:" ^false! ! !Object methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 6/18/2012 05:26'! isSpecLayout ^ false! ! !Object methodsFor: 'error handling' stamp: 'al 9/16/2005 14:12'! requirement self error: 'Implicitly required method'! ! !Object methodsFor: 'user interface' stamp: ''! modelWakeUp "A window with me as model is being entered or expanded. Default response is no-op" ! ! !Object methodsFor: 'block support' stamp: 'ajh 7/6/2003 20:37'! mustBeBoolean "Catches attempts to test truth of non-Booleans. This message is sent from the VM. The sending context is rewound to just before the jump causing this exception." ^ self mustBeBooleanIn: thisContext sender! ! !Object methodsFor: 'message performing' stamp: 'ClementBera 4/21/2013 14:53'! perform: aSymbol with: anObject "Send the selector, aSymbol, to the receiver with anObject as its argument. Fail if the number of arguments expected by the selector is not one. Primitive. Optional. See Object documentation whatIsAPrimitive." ^ self perform: aSymbol withArguments: (Array with: anObject)! ! !Object methodsFor: '*Morphic-Base' stamp: 'AlainPlantec 12/19/2009 23:13'! hasModelYellowButtonMenuItems ^Morph cmdGesturesEnabled! ! !Object methodsFor: '*Morphic-Base' stamp: 'dgd 9/25/2004 23:17'! iconOrThumbnailOfSize: aNumberOrPoint "Answer an appropiate form to represent the receiver" ^ nil! ! !Object methodsFor: '*Collections-Abstract-splitjoin' stamp: 'CamilloBruni 1/19/2013 12:38'! split: aSequenceableCollection do: aBlock "optimized version for single delimiters: Example: $/ split: '/foo/bar' indicesDo: [ :item | ]" self split: aSequenceableCollection indicesDo: [ :start :end | aBlock value: (aSequenceableCollection copyFrom: start to: end) ]! ! !Object methodsFor: '*Morphic-Base' stamp: 'BenjaminVanRyseghem 10/11/2013 15:28'! tail ^ nil! ! !Object methodsFor: 'testing' stamp: 'MarcusDenker 10/17/2013 12:05'! isClass ^ false! ! !Object methodsFor: 'copying' stamp: 'StephaneDucasse 2/20/2010 21:43'! veryDeepFixupWith: deepCopier "I have no fields and no superclass. Catch the super call." "avoid to use me we will deprecate it in the future"! ! !Object methodsFor: 'reflective operations' stamp: ''! someObject "Primitive. Answer the first object in the enumeration of all objects." self primitiveFailed.! ! !Object methodsFor: 'block support' stamp: 'ClementBera 6/28/2013 10:20'! mustBeBooleanIn: context "context is the where the non-boolean error occurred. Rewind context to before jump then raise error." "Some constructs are optimized in the compiler : #whileTrue: #whileFalse: #ifTrue: #ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue: So you cannot by default use them on non boolean objects." "If you really need to use optimized constructs, you can enable Opal compiler and do one of the following : - recompile your method with the pragma : - recompile your class with the method : MyClass class>>compiler ^ super compiler options: #(+ optIlineNone) - call from this method by Object>>#mustBeBooleanInMagic:" | proceedValue | context skipBackBeforeJump. proceedValue := NonBooleanReceiver new object: self; signal: 'proceed for truth.'. ^ proceedValue ~~ false! ! !Object methodsFor: 'finalization' stamp: 'BenjaminVanRyseghem 7/31/2013 15:40'! actAsExecutor "Do nothing"! ! !Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:22'! printString "Answer a String whose characters are a description of the receiver. If you want to print without a character limit, use fullPrintString." ^ self printStringLimitedTo: 50000! ! !Object methodsFor: 'tracing' stamp: 'StephaneDucasse 11/6/2011 23:56'! crTrace self crTrace: self printString! ! !Object methodsFor: '*necompletion-extensions' stamp: 'EstebanLorenzano 4/11/2012 15:47'! isCodeCompletionAllowed ^false! ! !Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/25/2006 18:18'! when: anEventSelector send: aMessageSelector to: anObject exclusive: aValueHolder self when: anEventSelector evaluate: ((ExclusiveWeakMessageSend receiver: anObject selector: aMessageSelector) basicExecuting: aValueHolder)! ! !Object methodsFor: '*Morphic-Base' stamp: 'BenjaminVanRyseghem 5/16/2013 12:27'! isTransferable ^ false! ! !Object methodsFor: 'drag and drop' stamp: ''! dragPassengerFor: item inMorph: dragSource ^item! ! !Object methodsFor: 'logging-Deprecated' stamp: 'StephaneDucasse 11/7/2011 22:43'! crLog self crTrace: self printString! ! !Object methodsFor: 'finalization' stamp: 'StephaneDucasse 3/21/2010 15:13'! toFinalizeSend: aSelector to: aFinalizer with: aResourceHandle "When I am finalized (e.g., garbage collected) close the associated resource handle by sending aSelector to the appropriate finalizer (the guy who knows how to get rid of the resource). WARNING: Neither the finalizer nor the resource handle are allowed to reference me. If they do, then I will NEVER be garbage collected. Since this cannot be validated here, it is up to the client to make sure this invariant is not broken." self == aFinalizer ifTrue:[self error: 'I cannot finalize myself']. self == aResourceHandle ifTrue:[self error: 'I cannot finalize myself']. ^self finalizationRegistry add: self executor: (ObjectFinalizer new receiver: aFinalizer selector: aSelector argument: aResourceHandle)! ! !Object methodsFor: 'accessing' stamp: ''! basicAt: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive." index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self basicAt: index asInteger] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: '*Polymorph-TaskbarIcons' stamp: ''! taskbarIcon "Answer the icon for the receiver in a task bar or nil for the default." ^self class taskbarIcon! ! !Object methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 11/26/2013 17:18'! isSpecAdapter ^ false! ! !Object methodsFor: 'accessing' stamp: 'di 3/29/1999 13:10'! size "Primitive. Answer the number of indexable variables in the receiver. This value is the same as the largest legal subscript. Essential. See Object documentation whatIsAPrimitive." self class isVariable ifFalse: [self errorNotIndexable]. ^ 0! ! !Object methodsFor: '*Deprecated30' stamp: 'StephaneDucasse 5/24/2013 08:23'! triggerEvent: anEventSelector with: anObject ifNotHandled: anExceptionBlock self deprecated: 'do not used it anymore!!' on: '21 May 2013' in: #Pharo30. ^self triggerEvent: anEventSelector withArguments: (Array with: anObject) ifNotHandled: anExceptionBlock! ! !Object methodsFor: '*Morphic-Base' stamp: 'BenjaminVanRyseghem 11/27/2013 14:52'! wantsVisualFeedback ^ true! ! !Object methodsFor: 'printing' stamp: ''! isLiteral "Answer whether the receiver has a literal text form recognized by the compiler." ^false! ! !Object methodsFor: 'macpal' stamp: 'sw 1/28/1999 17:31'! contentsChanged self changed: #contents! ! !Object methodsFor: 'accessing' stamp: 'md 5/16/2006 12:34'! yourself "Answer self." ^self! ! !Object methodsFor: '*Spec-Inspector' stamp: 'MarcusDenker 9/28/2013 15:53'! inspectorClass "Answer the class of the inspector to be used on the receiver. Called by inspect; use basicInspect to get a normal (less useful) type of inspector." ^ Smalltalk tools inspectorClass! ! !Object methodsFor: 'testing' stamp: ''! notNil "Coerces nil to false and everything else to true." ^true! ! !Object methodsFor: 'class membership' stamp: ''! isKindOf: aClass "Answer whether the class, aClass, is a superclass or class of the receiver." self class == aClass ifTrue: [^true] ifFalse: [^self class inheritsFrom: aClass]! ! !Object methodsFor: 'testing' stamp: 'rhi 8/12/2003 09:52'! isInterval ^ false! ! !Object methodsFor: '*Collections-Abstract-splitjoin' stamp: 'CamilloBruni 1/19/2013 12:38'! split: aSequenceableCollection "optimized version for single delimiters: Example: $/ split: '/foo/bar'" | result position oldPosition | result := OrderedCollection new: (aSequenceableCollection size / 2) asInteger. self split: aSequenceableCollection do: [ :item | result add: item ]. ^ result ! ! !Object methodsFor: 'error handling' stamp: 'MarcusDenker 10/10/2013 16:35'! explicitRequirement "If one of the superclasses can perform the selector, we execute the method of that class, otherwise, the explicit requirement error is thrown" | originalMethod originalSelector originalClass originalArguments errorBlock originalReceiver | originalClass := thisContext sender receiver class. originalReceiver := thisContext sender receiver. originalMethod := thisContext sender method. originalSelector := originalMethod selector. originalArguments := thisContext sender arguments. errorBlock := [ ^ self error: 'Explicitly required method' ]. originalMethod isFromTrait ifFalse: errorBlock. originalClass superclass withAllSuperclassesDo: [ :superCl | superCl compiledMethodAt: originalSelector ifPresent: [ :method | (method isProvided or: [ method isFromTrait not ]) ifTrue: [ ^ method valueWithReceiver: originalReceiver arguments: originalArguments ] ] ifAbsent: [ ] ]. ^ errorBlock value! ! !Object methodsFor: 'converting' stamp: 'Igor.Stasenko 11/13/2009 06:03'! asSetElement "Answer an object, which can be put into a Set as element , wrapped by one of SetElement instance, if necessary. Default implementation is to answer self" ! ! !Object methodsFor: 'printing' stamp: 'tk 10/19/2001 11:18'! longPrintOn: aStream limitedTo: sizeLimit indent: indent "Append to the argument, aStream, the names and values of all of the receiver's instance variables. Limit is the length limit for each inst var." self class allInstVarNames doWithIndex: [:title :index | indent timesRepeat: [aStream tab]. aStream nextPutAll: title; nextPut: $:; space; tab; nextPutAll: ((self instVarAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)); cr]! ! !Object methodsFor: 'updating' stamp: ''! okToChange "Allows a controller to ask this of any model" ^ true! ! !Object methodsFor: 'testing' stamp: 'gm 2/22/2003 12:56'! isMorphicModel "Return true if the receiver is a morphic model" ^false ! ! !Object methodsFor: 'events-accessing' stamp: 'SqR 6/28/2001 13:19'! actionsDo: aBlock self actionMap do: aBlock! ! !Object methodsFor: '*metacello-core' stamp: 'dkh 6/21/2012 20:08'! metacelloSemanticIntegerLessThanSelf: anInteger ^ self error: 'Invalid Metacello verson component - should be String or Integer.'! ! !Object methodsFor: '*Spec-Tools' stamp: 'BenjaminVanRyseghem 10/3/2012 13:57'! subObjectsToInspect ^ (1 to: self class allInstVarNames size) collect: [:i | self instVarAt: i ]! ! !Object methodsFor: '*Morphic-Base' stamp: 'AlainPlantec 12/19/2009 23:13'! addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph "The receiver serves as the model for aMorph; a menu is being constructed for the morph, and here the receiver is able to add its own items" Morph cmdGesturesEnabled ifTrue: [ "build mode" aCustomMenu add: 'inspect model' translated target: self action: #inspect. ]. ^aCustomMenu ! ! !Object methodsFor: 'reflective operations' stamp: 'ar 3/2/2001 01:34'! primitiveChangeClassTo: anObject "Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have. Note: The primitive will fail in most cases that you think might work. This is mostly because of a) the difference between compact and non-compact classes, and b) because of differences in the format. As an example, '(Array new: 3) primitiveChangeClassTo: Morph basicNew' would fail for three of the reasons mentioned above. Array is compact, Morph is not (failure #1). Array is variable and Morph is fixed (different format - failure #2). Morph is a fixed-field-only object and the array is too short (failure #3). The facility is really provided for certain, very specific applications (mostly related to classes changing shape) and not for casual use." self primitiveFailed! ! !Object methodsFor: 'dependencies' stamp: 'sma 2/29/2000 20:23'! removeDependent: anObject "Remove the given object as one of the receiver's dependents." | dependents | dependents := self dependents reject: [:each | each == anObject]. self myDependents: (dependents isEmpty ifFalse: [dependents]). ^ anObject! ! !Object methodsFor: 'error handling' stamp: 'SvenVanCaekenberghe 4/20/2011 13:25'! shouldNotImplement "Announce that, although the receiver inherits this message, it should not implement it." ShouldNotImplement signalFor: thisContext sender selector! ! !Object methodsFor: 'events-accessing' stamp: 'ClementBera 9/27/2013 17:54'! setActionSequence: actionSequence forEvent: anEventSelector | action | action := actionSequence asMinimalRepresentation. action ifNil: [self removeActionsForEvent: anEventSelector] ifNotNil: [self updateableActionMap at: anEventSelector asSymbol put: action]! ! !Object methodsFor: '*System-Support' stamp: 'MarcusDenker 7/12/2012 17:58'! systemNavigation ^ SystemNavigation new! ! !Object methodsFor: 'stepping' stamp: 'sw 10/19/1999 08:22'! stepTimeIn: aSystemWindow ^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! ! !Object methodsFor: 'primitive failure' stamp: 'StephaneDucasse 12/5/2009 21:06'! primitiveFail "primitiveFail may be invoked by certain methods whose code is translated in C. In such a case primitiveFail and not primitiveFailed should be invoked. The reason is that this code is translated to C by VMMaker. #primitiveFail is implemented in Interpreter of VMMaker." ^ self primitiveFailed! ! !Object methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/22/2012 18:32'! nbAddress "Return the native address" ^ self nbCallout function: #( int ( void ) ) emit: [:gen :proxy :asm | proxy receiver ]! ! !Object methodsFor: '*Tools-Browser' stamp: 'bkv 7/1/2003 12:33'! break "This is a simple message to use for inserting breakpoints during debugging. The debugger is opened by sending a signal. This gives a chance to restore invariants related to multiple processes." BreakPoint signal. "nil break."! ! !Object methodsFor: 'streaming' stamp: 'MPW 1/1/1901 00:49'! putOn:aStream ^aStream nextPut:self. ! ! !Object methodsFor: 'events-accessing' stamp: 'SqR 2/19/2001 14:04'! hasActionForEvent: anEventSelector "Answer true if there is an action associated with anEventSelector" ^(self actionForEvent: anEventSelector) notNil! ! !Object methodsFor: 'private' stamp: ''! errorImproperStore "Create an error notification that an improper store was attempted." self error: 'Improper store into indexable object'! ! !Object methodsFor: '*NativeBoost-core' stamp: 'JavierPimas 11/17/2011 11:12'! nbCallingConvention ^#cdecl ! ! !Object methodsFor: 'asserting' stamp: 'CamilloBruni 5/27/2013 16:20'! assert: aBlock description: aStringOrBlock "Throw an assertion error if aBlock does not evaluates to true." aBlock value ifFalse: [ AssertionFailure signal: aStringOrBlock value ]! ! !Object methodsFor: 'user interface' stamp: 'sw 10/4/1999 08:13'! addModelItemsToWindowMenu: aMenu "aMenu is being constructed to be presented to the user in response to the user's pressing on the menu widget in the title bar of a morphic window. Here, the model is given the opportunity to add any model-specific items to the menu, whose default target is the SystemWindow itself."! ! !Object methodsFor: '*Morphic-Base' stamp: 'AlainPlantec 10/20/2009 10:14'! asMorph "Open a morph, as best one can, on the receiver" ^ self asStringMorph " 234 asMorph. (MenuIcons tinyMenuIcon) asMorph. 'fred' asMorph. " ! ! !Object methodsFor: 'updating' stamp: 'nk 2/17/2004 11:13'! update: anAspect with: anObject "Receive a change notice from an object of whom the receiver is a dependent. The default behavior is to call update:, which by default does nothing; a subclass might want to change itself in some way." ^ self update: anAspect! ! !Object methodsFor: 'testing' stamp: 'ar 12/23/1999 15:43'! isStream "Return true if the receiver responds to the stream protocol" ^false ! ! !Object methodsFor: 'message performing' stamp: 'ClementBera 4/21/2013 14:53'! perform: aSymbol with: firstObject with: secondObject with: thirdObject "Send the selector, aSymbol, to the receiver with the given arguments. Fail if the number of arguments expected by the selector is not three. Primitive. Optional. See Object documentation whatIsAPrimitive." ^ self perform: aSymbol withArguments: (Array with: firstObject with: secondObject with: thirdObject)! ! !Object methodsFor: 'testing' stamp: ''! isMorph ^ false! ! !Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:28'! longPrintOn: aStream "Append to the argument, aStream, the names and values of all of the receiver's instance variables." self class allInstVarNames doWithIndex: [:title :index | aStream nextPutAll: title; nextPut: $:; space; tab; print: (self instVarAt: index); cr]! ! !Object methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/21/2011 13:00'! errorSubscriptBounds: index "Create an error notification that an improper integer was used as an index." SubscriptOutOfBounds signalFor: index! ! !Object methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/31/2009 15:52'! taskbarLabel "Answer the label string for the receiver in a task bar or nil for the default." ^self class taskbarLabel! ! !Object methodsFor: 'updating' stamp: 'MarcusDenker 6/11/2010 11:36'! changed: anAspect with: anObject "Receiver changed. The change is denoted by the argument anAspect. Usually the argument is a Symbol that is part of the dependent's change protocol. Inform all of the dependents. Also pass anObject for additional information." self dependents do: [:aDependent | aDependent update: anAspect with: anObject]! ! !Object methodsFor: 'testing' stamp: 'di 11/6/1998 08:04'! isPoint "Overridden to return true in Point." ^ false! ! !Object methodsFor: 'private' stamp: ''! errorNonIntegerIndex "Create an error notification that an improper object was used as an index." self error: 'only integers should be used as indices'! ! !Object methodsFor: '*Tools-Explorer' stamp: 'yo 8/27/2008 23:16'! customizeExplorerContents ^ false. ! ! !Object methodsFor: '*System-Settings-Browser' stamp: 'alain.plantec 3/19/2009 09:50'! settingStoreOn: aStream ^ self storeOn: aStream! ! !Object methodsFor: '*NativeBoost-Examples' stamp: 'IgorStasenko 11/23/2012 14:02'! nbOopHeader " This method provided only for educational purposes. Do not rely on it, if you wanna keep your code portable among various object memory formats " " simply return an object header word in a form which it is " ^ self nbCallout function: #( uint (oop self) ) emit: [:gen :proxy :asm | asm pop: asm EAX; push: asm EAX. proxy isIntegerObject: asm EAX. asm or: asm EAX with: asm EAX; jne: #notOop; pop: asm EAX; mov: asm EAX ptr to: asm EAX; "load the header" jmp: #exitt; label: #notOop; mov: 0 to: asm EAX; label: #exitt ].! ! !Object methodsFor: 'events-accessing' stamp: 'nk 12/20/2002 17:48'! actionForEvent: anEventSelector "Answer the action to be evaluated when has been triggered." | actions | actions := self actionMap at: anEventSelector asSymbol ifAbsent: [nil]. actions ifNil: [^nil]. ^ actions asMinimalRepresentation! ! !Object methodsFor: 'copying' stamp: 'eem 6/11/2008 17:52'! copySameFrom: otherObject "Copy to myself all instance variables named the same in otherObject. This ignores otherObject's control over its own inst vars." | myInstVars otherInstVars | myInstVars := self class allInstVarNames. otherInstVars := otherObject class allInstVarNames. myInstVars doWithIndex: [:each :index | | match | (match := otherInstVars indexOf: each) > 0 ifTrue: [self instVarAt: index put: (otherObject instVarAt: match)]]. 1 to: (self basicSize min: otherObject basicSize) do: [:i | self basicAt: i put: (otherObject basicAt: i)]. ! ! !Object methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 10/1/2013 13:46'! asWidget ^ self! ! !Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:15'! adaptToFloat: rcvr andSend: selector "If no method has been provided for adapting an object to a Float, then it may be adequate to simply adapt it to a number." ^ self adaptToNumber: rcvr andSend: selector! ! !Object methodsFor: 'error handling' stamp: 'stephane.ducasse 6/1/2009 13:51'! notify: aString "Create and schedule a Notifier with the argument as the message in order to request confirmation before a process can proceed." Warning signal: aString! ! !Object methodsFor: 'testing' stamp: 'adrian-lienhard 6/21/2009 23:52'! isTrait ^false! ! !Object methodsFor: 'flagging' stamp: 'sw 3/7/2001 13:14'! nominallyUnsent: aSelectorSymbol "From within the body of a method which is not formally sent within the system, but which you intend to have remain in the system (for potential manual invocation, or for documentation, or perhaps because it's sent by commented-out-code that you anticipate uncommenting out someday, send this message, with the selector itself as the argument. This will serve two purposes: (1) The method will not be returned by searches for unsent selectors (because it, in a manner of speaking, sends itself). (2) You can locate all such methods by browsing senders of #nominallyUnsent:" false ifTrue: [self flag: #nominallyUnsent:] "So that this method itself will appear to be sent" ! ! !Object methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/24/2012 15:28'! at: index put: value "Primitive. Assumes receiver is indexable. Store the argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. See Object documentation whatIsAPrimitive." index isInteger ifTrue: [self class isVariable ifTrue: [(index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]] ifFalse: [self errorNotIndexable]]. index isNumber ifTrue: [^self at: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: 'copying' stamp: 'MarianoMartinezPeck 8/24/2012 15:58'! postCopy "I'm a hook method in the sense of Design Patterns TemplateHook/Methods. I'm called by copy. self is a shallow copy, subclasses should copy fields as necessary to complete the full copy" ^ self ! ! !Object methodsFor: '*NewValueHolder' stamp: 'BenjaminVanRyseghem 1/24/2014 18:46'! asReactiveVariable "See NewValueHolder class comment" ^ self asValueHolder! ! !Object methodsFor: 'message performing' stamp: 'ClementBera 4/21/2013 14:41'! perform: selector withArguments: argArray inSuperclass: lookupClass "NOTE: This is just like perform:withArguments:, except that the message lookup process begins, not with the receivers's class, but with the supplied superclass instead. It will fail if lookupClass cannot be found among the receiver's superclasses. Primitive. Essential. See Object documentation whatIsAPrimitive." (selector isSymbol) ifFalse: [^ self error: 'selector argument must be a Symbol']. (selector numArgs = argArray size) ifFalse: [^ self error: 'incorrect number of arguments']. (self class == lookupClass or: [self class inheritsFrom: lookupClass]) ifFalse: [^ self error: 'lookupClass is not in my inheritance chain']. self primitiveFailed! ! !Object methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! metacelloStringLessThanSelf: anInteger ^self error: 'Invalid Metacello verson component - should be String or Integer.'! ! !Object methodsFor: 'pointing to' stamp: 'IgorStasenko 9/2/2012 02:24'! pointsOnlyWeaklyTo: anObject "Assume, we already know that receiver points to an object, answer true if receiver points only weakly to it " self class isWeak ifFalse: [ ^ false ]. 1 to: self class instSize do: [:i | (self instVarAt: i) == anObject ifTrue: [^ false]]. ^ true! ! !Object methodsFor: 'printing' stamp: 'tk 5/7/1999 16:20'! printStringLimitedTo: limit "Answer a String whose characters are a description of the receiver. If you want to print without a character limit, use fullPrintString." | limitedString | limitedString := String streamContents: [:s | self printOn: s] limitedTo: limit. limitedString size < limit ifTrue: [^ limitedString]. ^ limitedString , '...etc...'! ! !Object methodsFor: 'testing' stamp: 'sw 11/13/2001 07:26'! wantsDiffFeedback "Answer whether the receiver, serving as the model of a text-bearing entity, would like for 'diffs' green pane-border feedback to be shown" ^ false! ! !Object methodsFor: 'testing' stamp: 'md 11/21/2003 12:14'! isCompiledMethod ^ false! ! !Object methodsFor: '*UIManager' stamp: 'pavel.krivanek 11/21/2008 16:50'! primitiveError: aString "This method is called when the error handling results in a recursion in calling on error: or halt or halt:." UIManager default onPrimitiveError: aString.! ! !Object methodsFor: 'converting' stamp: 'nice 3/28/2006 23:29'! adaptToFraction: rcvr andCompare: selector "If I am involved in comparison with a Fraction. Default behaviour is to process comparison as any other selectors." ^ self adaptToFraction: rcvr andSend: selector! ! !Object methodsFor: 'dependencies' stamp: 'sma 2/29/2000 19:58'! dependents "Answer a collection of objects that are 'dependent' on the receiver; that is, all objects that should be notified if the receiver changes." ^ self myDependents ifNil: [#()]! ! !Object methodsFor: 'casing-To be deprecated' stamp: 'StephaneDucasse 8/12/2013 21:27'! caseOf: aBlockAssociationCollection "DO NOT USE THIS METHOD!! It will be removed from Pharo." "The elements of aBlockAssociationCollection are associations between blocks. Answer the evaluated value of the first association in aBlockAssociationCollection whose evaluated key equals the receiver. If no match is found, report an error." ^ self caseOf: aBlockAssociationCollection otherwise: [self caseError] "| z | z := {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z" "| z | z := {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z" "The following are compiled in-line:" "#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}" "#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}"! ! !Object methodsFor: 'dependencies' stamp: 'sma 2/29/2000 19:53'! breakDependents "Remove all of the receiver's dependents." self myDependents: nil! ! !Object methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper "Be careful because the order is important. For example, weak are also variable, but we need that weak objects send #visitWeakObject: and not #visitVariableObject: " self class isFixed ifTrue: [ ^ aGeneralMapper visitFixedObject: self ]. self class isWeak ifTrue: [ ^ aGeneralMapper visitWeakObject: self ]. self class isPointers ifTrue: [ ^ aGeneralMapper visitVariableObject: self ]. self class isBytes ifTrue: [ ^ aGeneralMapper visitBytesObject: self ]. self class isWords ifTrue: [ ^ aGeneralMapper visitWordsObject: self ]. self error: 'Something is wrong!!'! ! !Object methodsFor: 'user interface' stamp: 'rbb 3/1/2005 09:27'! 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." ^ UIManager default confirm: aString orCancel: cancelBlock! ! !Object methodsFor: 'message performing' stamp: 'st 11/5/2004 16:19'! perform: selector orSendTo: otherTarget "If I wish to intercept and handle selector myself, do it; else send it to otherTarget" ^ (self respondsTo: selector) ifTrue: [self perform: selector] ifFalse: [otherTarget perform: selector]! ! !Object methodsFor: 'private' stamp: ''! storeAt: offset inTempFrame: aContext "This message had to get sent to an expression already on the stack as a Block argument being accessed by the debugger. Just re-route it to the temp frame." ^ aContext tempAt: offset put: self! ! !Object methodsFor: 'printing' stamp: 'tk 10/16/2001 19:41'! longPrintString "Answer a String whose characters are a description of the receiver." | str | str := String streamContents: [:aStream | self longPrintOn: aStream]. "Objects without inst vars should return something" ^ str isEmpty ifTrue: [self printString, String cr] ifFalse: [str]! ! !Object methodsFor: '*Tools-Base' stamp: 'sw 10/19/1999 14:39'! updateListsAndCodeIn: aWindow self canDiscardEdits ifFalse: [^ self]. aWindow updatablePanes do: [:aPane | aPane verifyContents]! ! !Object methodsFor: '*Spec-Inspector' stamp: 'MarcusDenker 9/28/2013 16:26'! inspectWithLabel: aLabel "Create and schedule an Inspector in which the user can examine the receiver's variables." ^Smalltalk tools inspector inspect: self label: aLabel! ! !Object methodsFor: 'testing' stamp: 'yo 8/28/2002 13:41'! isCharacter ^ false. ! ! !Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:23'! logEntry Transcript show: 'Entered ', thisContext sender printString; cr. ! ! !Object methodsFor: 'copying' stamp: 'CamilloBruni 10/2/2013 19:39'! veryDeepCopyWith: deepCopier "Copy me and the entire tree of objects I point to. An object in the tree twice is copied once, and both references point to him. deepCopier holds a dictionary of objects we have seen. Some classes refuse to be copied. Some classes are picky about which fields get deep copied." | class selfNumberOfInstanceVariables fieldOfSelf copyOfSelf currentClass hasVeryDeepInnerMethod currentNumberOfInstanceVariables | deepCopier references at: self ifPresent: [ :newer | "already copied" ^ newer]. class := self class. class isMeta ifTrue: [ "a metaclass" ^ self ]. copyOfSelf := self shallowCopy. deepCopier references at: self put: copyOfSelf. "remember" (class isVariable and: [class isPointers]) ifTrue: [ self basicSize to: 1 by: -1 do: [ :i | fieldOfSelf := self basicAt: i. copyOfSelf basicAt: i put: (deepCopier references at: fieldOfSelf ifAbsent: [ fieldOfSelf veryDeepCopyWith: deepCopier ])]]. "Ask each superclass if it wants to share (weak copy) any inst vars" copyOfSelf veryDeepInner: deepCopier. "other superclasses want all instance variables deep copied" currentClass := class. selfNumberOfInstanceVariables := class instSize. [ selfNumberOfInstanceVariables == 0 ] whileFalse: [ hasVeryDeepInnerMethod := currentClass includesSelector: #veryDeepInner:. currentNumberOfInstanceVariables := currentClass instSize - currentClass superclass instSize. hasVeryDeepInnerMethod ifTrue: ["skip inst vars" selfNumberOfInstanceVariables := selfNumberOfInstanceVariables - currentNumberOfInstanceVariables] ifFalse: [ currentNumberOfInstanceVariables timesRepeat: [ fieldOfSelf := self instVarAt: selfNumberOfInstanceVariables. copyOfSelf instVarAt: selfNumberOfInstanceVariables put: (deepCopier references at: fieldOfSelf ifAbsent: [ fieldOfSelf veryDeepCopyWith: deepCopier ]). selfNumberOfInstanceVariables := selfNumberOfInstanceVariables - 1 ]]. currentClass := currentClass superclass ]. ^ copyOfSelf ! ! !Object methodsFor: 'logging-Deprecated' stamp: 'StephaneDucasse 5/27/2011 19:07'! logCrTab: aString "Log the argument. Use self logCr: 'something' instead of Transcript show: 'something' ; cr ; tab" Transcript show: aString ; cr ; tab! ! !Object methodsFor: 'testing' stamp: 'nk 4/25/2002 08:04'! isMessageSend ^false ! ! !Object methodsFor: '*Morphic-Base' stamp: 'nk 2/26/2004 13:35'! asTextMorph "Open a TextMorph, as best one can, on the receiver" ^ TextMorph new contentsAsIs: self asStringOrText ! ! !Object methodsFor: 'copying' stamp: 'stephane.ducasse 6/1/2009 13:49'! veryDeepCopy "Do a complete tree copy using a dictionary. An object in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy." | copier new | copier := DeepCopier new initialize: 4096 "self initialDeepCopierSize". new := self veryDeepCopyWith: copier. copier references associationsDo: [:assoc | assoc value veryDeepFixupWith: copier]. copier fixDependents. ^ new! ! !Object methodsFor: 'asserting' stamp: 'jannik.laval 5/2/2010 16:34'! assert: aBlock "Throw an assertion error if aBlock does not evaluates to true." aBlock value ifFalse: [AssertionFailure signal: 'Assertion failed']! ! !Object methodsFor: '*Deprecated30' stamp: 'StephaneDucasse 5/24/2013 08:23'! triggerEvent: anEventSelector withArguments: anArgumentList ifNotHandled: anExceptionBlock self deprecated: 'do not used it anymore!!' on: '21 May 2013' in: #Pharo30. ^(self actionForEvent: anEventSelector ifAbsent: [^anExceptionBlock value]) valueWithArguments: anArgumentList! ! !Object methodsFor: '*Morphic-Base' stamp: 'CamilloBruni 10/21/2012 23:38'! asDraggableMorph ^ self asStringMorph ! ! !Object methodsFor: '*Tools-Browser' stamp: 'BenjaminVanRyseghem 1/7/2012 18:04'! browseHierarchy self systemNavigation browseHierarchy: self class! ! !Object methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:02'! literalEqual: other ^ self class == other class and: [self = other]! ! !Object methodsFor: 'copying' stamp: 'StephaneDucasse 2/20/2010 21:40'! deepCopy "Answer a copy of the receiver with its own copy of each instance variable. deepCopy does a deep copy. It should never be overridden and only be used if you want to get these very specific semantics. It doesn't handle cycles, #veryDeepCopy does. In the future we will make it handle cycles and deprecate veryDeepCopy" | newObject class index | class := self class. (class == Object) ifTrue: [^self]. class isVariable ifTrue: [index := self basicSize. newObject := class basicNew: index. [index > 0] whileTrue: [newObject basicAt: index put: (self basicAt: index) deepCopy. index := index - 1]] ifFalse: [newObject := class basicNew]. index := class instSize. [index > 0] whileTrue: [newObject instVarAt: index put: (self instVarAt: index) deepCopy. index := index - 1]. ^newObject! ! !Object methodsFor: 'copying' stamp: 'StephaneDucasse 2/20/2010 21:42'! shallowCopy "Answer a copy of the receiver which shares the receiver's instance variables. It should never be overridden. I'm invoked from the copy template method. Subclasses that need to specialize the copy should specialize the postCopy hook method." | class newObject index | class := self class. class isVariable ifTrue: [index := self basicSize. newObject := class basicNew: index. [index > 0] whileTrue: [newObject basicAt: index put: (self basicAt: index). index := index - 1]] ifFalse: [newObject := class basicNew]. index := class instSize. [index > 0] whileTrue: [newObject instVarAt: index put: (self instVarAt: index). index := index - 1]. ^ newObject! ! !Object methodsFor: 'events-accessing' stamp: 'rw 2/10/2002 13:05'! createActionMap ^IdentityDictionary new! ! !Object methodsFor: '*Spec-Inspector' stamp: 'MarcusDenker 9/28/2013 16:11'! inspector ^ Smalltalk tools inspector inspector: self! ! !Object methodsFor: 'tracing' stamp: 'StephaneDucasse 11/6/2011 23:56'! traceCr: aString "Log the argument. Use self traceCr: 'something' instead of Transcript show: 'something' ; cr " Transcript show: aString ; cr! ! !Object methodsFor: '*System-Caching' stamp: 'SvenVanCaekenberghe 12/16/2013 20:12'! asDoubleLink ^ DoubleLink value: self! ! !Object methodsFor: 'events-accessing' stamp: 'nk 12/20/2002 17:48'! actionForEvent: anEventSelector ifAbsent: anExceptionBlock "Answer the action to be evaluated when has been triggered." | actions | actions := self actionMap at: anEventSelector asSymbol ifAbsent: [nil]. actions ifNil: [^anExceptionBlock value]. ^ actions asMinimalRepresentation! ! !Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:36'! removeActionsWithReceiver: anObject forEvent: anEventSelector self removeActionsSatisfying: [:anAction | anAction receiver == anObject] forEvent: anEventSelector! ! !Object methodsFor: '*Tools-Finder' stamp: 'pmm 3/13/2010 11:33'! copyTwoLevel "one more level than a shallowCopy" "do not use this method we will deprecated soon" | newObject class index | class := self class. newObject := self shallowCopy. newObject == self ifTrue: [^ self]. class isVariable ifTrue: [index := self basicSize. [index > 0] whileTrue: [newObject basicAt: index put: (self basicAt: index) shallowCopy. index := index - 1]]. index := class instSize. [index > 0] whileTrue: [newObject instVarAt: index put: (self instVarAt: index) shallowCopy. index := index - 1]. ^newObject! ! !Object methodsFor: 'error handling' stamp: 'al 12/16/2003 16:16'! traitConflict self error: 'A class or trait does not properly resolve a conflict between multiple traits it uses.'! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 14:59'! triggerEvent: anEventSelector with: anObject ^self triggerEvent: anEventSelector withArguments: (Array with: anObject)! ! !Object methodsFor: '*Monticello-Storing' stamp: 'MarianoMartinezPeck 5/21/2012 22:52'! storeDataOn: aDataStream "Store myself on a DataStream. Answer self. This is a low-level DataStream/ReferenceStream method. See also objectToStoreOnDataStream. NOTE: This method must send 'aDataStream beginInstance:size:' and then (nextPut:/nextPutWeak:) its subobjects. readDataFrom:size: reads back what we write here." | cntInstVars cntIndexedVars | cntInstVars := self class instSize. cntIndexedVars := self basicSize. aDataStream beginInstance: self class size: cntInstVars + cntIndexedVars. 1 to: cntInstVars do: [:i | aDataStream nextPut: (self instVarAt: i)]. "Write fields of a variable length object. " (self class isBits) ifFalse: [ 1 to: cntIndexedVars do: [:i | aDataStream nextPut: (self basicAt: i)]]. ! ! !Object methodsFor: 'stepping' stamp: 'sw 10/19/1999 08:26'! wantsStepsIn: aSystemWindow ^ self wantsSteps! ! !Object methodsFor: '*Collections-Abstract-splitjoin' stamp: 'CamilloBruni 1/19/2013 12:38'! split: aSequenceableCollection indicesDo: aBlock "optimized version for single delimiters: Example: $/ split: '/foo/bar' indicesDo: [ :start :end | ]" | position oldPosition | position := 1. oldPosition := position. position := aSequenceableCollection indexOf: self startingAt: position. [ position > 0 ] whileTrue: [ aBlock value: oldPosition value: position - 1. position := position + 1. oldPosition := position. position := aSequenceableCollection indexOf: self startingAt: position. ]. aBlock value: oldPosition value: aSequenceableCollection size. ! ! !Object methodsFor: 'testing' stamp: ''! isText ^ false! ! !Object methodsFor: 'events-accessing' stamp: 'reThink 2/18/2001 14:43'! actionMap ^EventManager actionMapFor: self! ! !Object methodsFor: 'finalization' stamp: 'Igor.Stasenko 5/25/2010 04:59'! hasMultipleExecutors "All objects, except ObjectFinalizerCollection instances should answer false to this message" ^ false! ! !Object methodsFor: 'updating' stamp: 'sw 10/31/1999 00:15'! noteSelectionIndex: anInteger for: aSymbol "backstop"! ! !Object methodsFor: '*Morphic-Base' stamp: 'cb 6/25/2013 13:23'! defaultLabel "Answer the default label to be used in morphs." ^ self class name! ! !Object methodsFor: 'tracing' stamp: 'StephaneDucasse 11/6/2011 23:55'! trace: aString "Log the argument. Use self trace: instead of Transcript show: " Transcript show: aString.! ! !Object methodsFor: 'reflective operations' stamp: 'di 1/9/1999 15:19'! becomeForward: otherObject "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. Fails if either argument is a SmallInteger." (Array with: self) elementsForwardIdentityTo: (Array with: otherObject)! ! !Object methodsFor: 'printing' stamp: 'BG 11/7/2004 13:39'! longPrintStringLimitedTo: aLimitValue "Answer a String whose characters are a description of the receiver." | str | str := String streamContents: [:aStream | self longPrintOn: aStream limitedTo: aLimitValue indent: 0]. "Objects without inst vars should return something" ^ str isEmpty ifTrue: [self printString, String cr] ifFalse: [str]! ! !Object methodsFor: 'primitive failure' stamp: 'StephaneDucasse 3/27/2010 23:07'! primitiveFailed "Announce that a primitive has failed and there is no appropriate Smalltalk code to run." self primitiveFailed: thisContext sender selector! ! !Object methodsFor: '*MenuRegistration-Core' stamp: 'SeanDeNigris 6/16/2013 13:38'! fallbackMenuOn: aMenuMorph "When pragma menu building goes wrong, a fallback menu is created. To add custom items to that menu, override me in subclasses. See WorldState>>#fallbackMenuOn: for an example"! ! !Object methodsFor: '*monticellofiletree-core' stamp: 'dkh 4/6/2012 15:56:14'! writeCypressJsonForHtmlOn: aStream indent: startIndent self writeCypressJsonOn: aStream forHtml: true indent: startIndent! ! !Object methodsFor: 'testing' stamp: 'ajh 1/21/2003 13:15'! isBlock ^ false! ! !Object methodsFor: 'testing' stamp: 'md 10/2/2005 21:52'! isRectangle ^false! ! !Object methodsFor: 'converting' stamp: 'sma 5/12/2000 17:39'! asOrderedCollection "Answer an OrderedCollection with the receiver as its only element." ^ OrderedCollection with: self! ! !Object methodsFor: 'converting' stamp: 'HenrikSperreJohansen 10/18/2009 15:58'! asLink "Answer a string that represents the receiver." ^ ValueLink value: self! ! !Object methodsFor: '*Graphics-Display Objects' stamp: 'sw 3/26/2001 12:12'! printDirectlyToDisplay "For debugging: write the receiver's printString directly to the display at (0, 100); senders of this are detected by the check-for-slips mechanism." self asString displayAt: 0@100 "StringMorph someInstance printDirectlyToDisplay"! ! !Object methodsFor: '*Morphic-Base' stamp: 'HenrikSperreJohansen 6/28/2010 12:24'! externalName "Answer an external name by which the receiver is known. Generic implementation here is a transitional backstop. probably" ^ [(self asString copyWithout: Character cr) truncateTo: 27] ifError: [ ^ self class name printString] ! ! !Object methodsFor: 'testing' stamp: 'eem 11/26/2008 20:22'! isContext ^false! ! !Object methodsFor: '*Polymorph-Widgets-Themes' stamp: 'YuriyTymchuk 12/20/2013 11:14'! systemIcon ^ Smalltalk ui icons iconNamed: #classIcon! ! !Object methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/22/2012 14:25'! nbCallout ^ NBFFICalloutAPI inContext: thisContext sender! ! !Object methodsFor: 'accessing' stamp: ''! basicAt: index put: value "Primitive. Assumes receiver is indexable. Store the second argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive." index isInteger ifTrue: [(index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]]. index isNumber ifTrue: [^self basicAt: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: 'stepping' stamp: 'sw 10/19/1999 08:21'! stepTime ^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! ! !Object methodsFor: 'dependencies' stamp: 'sma 2/29/2000 19:55'! myDependents "Private. Answer a list of all the receiver's dependents." ^ DependentsFields at: self ifAbsent: []! ! !Object methodsFor: 'associating' stamp: 'md 7/22/2005 16:03'! -> anObject "Answer an Association between self and anObject" ^Association basicNew key: self value: anObject! ! !Object methodsFor: 'dependencies' stamp: ''! release "Remove references to objects that may refer to the receiver. This message should be overridden by subclasses with any cycles, in which case the subclass should also include the expression super release." self releaseActionMap! ! !Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'! when: anEventSelector send: aMessageSelector to: anObject self when: anEventSelector evaluate: (WeakMessageSend receiver: anObject selector: aMessageSelector)! ! !Object methodsFor: 'converting' stamp: 'rw 4/27/2002 07:48'! asActionSequence ^WeakActionSequence with: self! ! !Object methodsFor: 'deprecation' stamp: 'MarcusDenker 3/26/2013 13:17'! deprecated: anExplanationString "this is not itself deprecated, but a compatibility method for old-style deprecation" (Deprecation method: thisContext sender method explanation: anExplanationString on: 'unknown' in: 'unknown') signal! ! !Object methodsFor: 'stepping' stamp: 'sw 10/19/1999 08:16'! stepIn: aWindow ^ self step! ! !Object methodsFor: 'deprecation' stamp: 'AndrewBlack 9/6/2009 08:58'! deprecated: anExplanationString on: date in: version "Warn that the sending method has been deprecated" (Deprecation method: thisContext sender method explanation: anExplanationString on: date in: version) signal! ! !Object methodsFor: 'tracing' stamp: 'StephaneDucasse 11/6/2011 23:57'! crTrace: aString "Log the argument. Use self crTrace: instead of Transcript cr; show: " Transcript cr; show: aString.! ! !Object methodsFor: '*Morphic-Base' stamp: 'BenjaminVanRyseghem 10/11/2013 15:27'! head ^ self! ! !Object methodsFor: 'literal testing' stamp: 'ul 11/23/2010 13:28'! shouldBePrintedAsLiteral ^self isLiteral! ! !Object methodsFor: '*metacello-core' stamp: 'dkh 6/5/2012 19:01:24'! metacelloVersionComponentLessThan: aMetacelloVersonComponent ^self error: 'Invalid Metacello verson component - should be String or Integer.'! ! !Object methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/24/2012 16:07'! nbCall: fnSpec module: aModuleNameOrHandle options: callOptions " you can override this method if you need to" ^ (self nbCalloutIn: thisContext sender) convention: self nbCallingConvention; options: callOptions; function: fnSpec module: aModuleNameOrHandle ! ! !Object methodsFor: '*NewValueHolder' stamp: 'BenjaminVanRyseghem 1/24/2014 18:46'! asValueHolder "See NewValueHolder class comment" ^ NewValueHolder value: self! ! !Object methodsFor: 'copying' stamp: 'tpr 2/14/2004 21:53'! copyFrom: anotherObject "Copy to myself all instance variables I have in common with anotherObject. This is dangerous because it ignores an object's control over its own inst vars. " | mine his | mine := self class allInstVarNames. his := anotherObject class allInstVarNames. 1 to: (mine size min: his size) do: [:ind | (mine at: ind) = (his at: ind) ifTrue: [ self instVarAt: ind put: (anotherObject instVarAt: ind)]]. self class isVariable & anotherObject class isVariable ifTrue: [ 1 to: (self basicSize min: anotherObject basicSize) do: [:ind | self basicAt: ind put: (anotherObject basicAt: ind)]].! ! !Object methodsFor: 'finalization' stamp: 'ar 5/19/2003 20:10'! finalizationRegistry "Answer the finalization registry associated with the receiver." ^WeakRegistry default! ! !Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/24/2006 11:49'! when: anEventSelector sendOnce: aMessageSelector to: anObject with: anArg self when: anEventSelector evaluate: (NonReentrantWeakMessageSend receiver: anObject selector: aMessageSelector arguments: (Array with: anArg))! ! !Object methodsFor: 'casing-To be deprecated' stamp: 'StephaneDucasse 8/12/2013 21:27'! caseOf: aBlockAssociationCollection otherwise: aBlock "DO NOT USE THIS METHOD!! It will be removed from Pharo." "The elements of aBlockAssociationCollection are associations between blocks. Answer the evaluated value of the first association in aBlockAssociationCollection whose evaluated key equals the receiver. If no match is found, answer the result of evaluating aBlock." aBlockAssociationCollection associationsDo: [:assoc | (assoc key value = self) ifTrue: [^assoc value value]]. ^ aBlock value "| z | z := {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]" "| z | z := {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]" "The following are compiled in-line:" "#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]" "#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]"! ! !Object methodsFor: '*Tools-Explorer' stamp: 'md 8/13/2008 21:39'! hasContentsInExplorer ^self basicSize > 0 or: [self class allInstVarNames notEmpty] ! ! !Object methodsFor: 'printing' stamp: 'di 6/20/97 08:57'! fullPrintString "Answer a String whose characters are a description of the receiver." ^ String streamContents: [:s | self printOn: s]! ! !Object methodsFor: 'updating' stamp: ''! changed: aParameter "Receiver changed. The change is denoted by the argument aParameter. Usually the argument is a Symbol that is part of the dependent's change protocol. Inform all of the dependents." self dependents do: [:aDependent | aDependent update: aParameter]! ! !Object methodsFor: 'events-accessing' stamp: 'rw 4/27/2002 08:35'! actionSequenceForEvent: anEventSelector ^(self actionMap at: anEventSelector asSymbol ifAbsent: [^WeakActionSequence new]) asActionSequence! ! !Object methodsFor: 'dependencies' stamp: 'sma 2/29/2000 19:26'! canDiscardEdits "Answer true if none of the views on this model has unaccepted edits that matter." self dependents do: [:each | each canDiscardEdits ifFalse: [^ false]] without: self. ^ true! ! !Object methodsFor: 'testing' stamp: 'ar 7/9/1999 18:18'! isBehavior "Return true if the receiver is a behavior. Note: Do not override in any class except behavior." ^false! ! !Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:33'! releaseActionMap EventManager releaseActionMapFor: self! ! !Object methodsFor: 'events-removing' stamp: 'MarcusDenker 10/2/2013 20:15'! removeActionsSatisfying: aBlock self actionMap keysDo: [:eachEventSelector | self removeActionsSatisfying: aBlock forEvent: eachEventSelector ]! ! !Object methodsFor: 'nil testing' stamp: 'MarcusDenker 12/2/2013 14:15'! ifNil: nilBlock ifNotNilDo: aBlock "please use #ifNil:ifNotNil: " ^ aBlock value: self ! ! !Object methodsFor: 'class membership' stamp: ''! respondsTo: aSymbol "Answer whether the method dictionary of the receiver's class contains aSymbol as a message selector." ^self class canUnderstand: aSymbol! ! !Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:33'! removeActionsForEvent: anEventSelector | map | map := self actionMap. map removeKey: anEventSelector asSymbol ifAbsent: []. map isEmpty ifTrue: [self releaseActionMap]! ! !Object methodsFor: 'accessing' stamp: ''! basicSize "Primitive. Answer the number of indexable variables in the receiver. This value is the same as the largest legal subscript. Essential. Do not override in any subclass. See Object documentation whatIsAPrimitive." "The number of indexable fields of fixed-length objects is 0" ^0 ! ! !Object methodsFor: 'private' stamp: 'eem 5/9/2008 09:04'! species "Answer the preferred class for reconstructing the receiver. For example, collections create new collections whenever enumeration messages such as collect: or select: are invoked. The new kind of collection is determined by the species of the original collection. Species and class are not always the same. For example, the species of Interval is Array." ^self class! ! !Object methodsFor: 'testing' stamp: 'eem 5/8/2008 11:13'! isArray ^false! ! !Object methodsFor: 'testing' stamp: 'ar 8/14/2001 23:19'! isVariableBinding "Return true if I represent a literal variable binding" ^false ! ! !Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/25/2006 18:17'! when: anEventSelector send: aMessageSelector to: anObject with: anArg exclusive: aValueHolder self when: anEventSelector evaluate: ((ExclusiveWeakMessageSend receiver: anObject selector: aMessageSelector arguments: (Array with: anArg)) basicExecuting: aValueHolder)! ! !Object methodsFor: '*Tools-Base' stamp: 'sw 1/18/2001 13:43'! showDiffs "Answer whether the receiver, serving as the model of a text-bearing entity, is 'showing differences' -- if it is, the editor may wish to show special feedback" ^ false! ! !Object methodsFor: 'message performing' stamp: 'ClementBera 4/21/2013 14:53'! perform: aSymbol with: firstObject with: secondObject "Send the selector, aSymbol, to the receiver with the given arguments. Fail if the number of arguments expected by the selector is not two. Primitive. Optional. See Object documentation whatIsAPrimitive." ^ self perform: aSymbol withArguments: (Array with: firstObject with: secondObject)! ! !Object methodsFor: '*metacello-core' stamp: 'dkh 6/21/2012 20:08'! metacelloSemanticVersionComponentLessThan: aMetacelloVersonComponent ^ self error: 'Invalid Metacello verson component - should be String or Integer.'! ! !Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:31'! removeActionsSatisfying: aOneArgBlock forEvent: anEventSelector self setActionSequence: ((self actionSequenceForEvent: anEventSelector) reject: [:anAction | aOneArgBlock value: anAction]) forEvent: anEventSelector! ! !Object methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 1/17/2012 16:04'! nbGetSymbolAddress: aName module: aModuleNameOrHandle "Lookup for given symbol in external module and answer its address (an instance of NBExternalAddress), or nil if not found. A default implementation, first we try to use OS-specific symbol lookup mechanism, and if not found, we try to lookup a symbol from VM registered plugin(s)" | addr | addr := NativeBoost loadSymbol: aName fromModule: aModuleNameOrHandle. ^ addr ifNil: [ "loadfunction takes only names, not handles" aModuleNameOrHandle isString ifFalse: [ nil ] ifTrue: [ NativeBoost loadFunction: aName from: aModuleNameOrHandle ]]! ! !Object methodsFor: 'updating' stamp: ''! changed "Receiver changed in a general way; inform all the dependents by sending each dependent an update: message." self changed: self! ! !Object methodsFor: 'reading' stamp: 'damiencassou 5/30/2008 10:56'! readFromString: aString "Create an object based on the contents of aString." ^ self readFrom: aString readStream! ! !Object methodsFor: 'reflective operations' stamp: 'CamilloBruni 8/1/2012 16:26'! doesNotUnderstand: aMessage "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)." "Testing: (3 activeProcess)" | exception resumeValue | (exception := MessageNotUnderstood new) message: aMessage; receiver: self. resumeValue := exception signal. ^exception reachedDefaultHandler ifTrue: [aMessage sentTo: self] ifFalse: [resumeValue]! ! !Object methodsFor: '*Morphic-Base' stamp: 'BenjaminVanRyseghem 5/16/2013 12:21'! transferFor: passenger from: aMorph ^ TransferMorph withPassenger: passenger from: aMorph! ! !Object methodsFor: '*Spec-Core' stamp: 'ChristopheDemarey 11/20/2013 14:38'! isTreeNodeModel ^ false! ! !Object methodsFor: 'testing' stamp: 'nk 4/17/2004 19:43'! isColorForm ^false! ! !Object methodsFor: '*UIManager' stamp: 'rbb 3/1/2005 09:26'! 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." "nil confirm: 'Are you hungry?'" ^ UIManager default confirm: queryString! ! !Object methodsFor: 'printing' stamp: 'MarianoMartinezPeck 8/24/2012 15:28'! printOn: aStream "Append to the argument, aStream, a sequence of characters that identifies the receiver." | title | title := self class name. aStream nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); nextPutAll: title! ! !Object methodsFor: '*Tools-Explorer' stamp: 'sma 11/12/2000 11:43'! asExplorerString ^ self printString! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:21'! triggerEvent: anEventSelector withArguments: anArgumentList ^(self actionForEvent: anEventSelector) valueWithArguments: anArgumentList! ! !Object methodsFor: 'converting' stamp: 'nice 3/28/2006 23:29'! adaptToFloat: rcvr andCompare: selector "If I am involved in comparison with a Float. Default behaviour is to process comparison as any other selectors." ^ self adaptToFloat: rcvr andSend: selector! ! !Object methodsFor: 'logging-Deprecated' stamp: 'StephaneDucasse 5/23/2011 22:09'! log: aString "Log the argument. Use self log: instead of Transcript show: " Transcript show: aString.! ! !Object methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/24/2012 16:07'! nbCall: fnSpec " you can override this method if you need to" ^ (self nbCalloutIn: thisContext sender) convention: self nbCallingConvention; function: fnSpec module: self nbLibraryNameOrHandle ! ! !Object methodsFor: '*monticellofiletree-core' stamp: 'ChristopheDemarey 9/8/2013 18:34'! writeCypressJsonOn: aStream forHtml: forHtml indent: startIndent "by default ignore ... is used for Dictionary and Array, i.e., container objects and String which actually encodes itself differently for HTML" ^ SubclassResponsibility signalFor: thisContext sender selector! ! !Object methodsFor: 'error handling' stamp: 'tfei 4/12/1999 12:55'! error: aString "Throw a generic Error exception." ^Error new signal: aString! ! !Object methodsFor: 'primitive failure' stamp: 'SvenVanCaekenberghe 4/20/2011 13:26'! primitiveFailed: selector "Announce that a primitive has failed and there is no appropriate Smalltalk code to run." PrimitiveFailed signalFor: selector! ! !Object methodsFor: '*Spec-Inspector' stamp: 'CamilloBruni 9/20/2013 19:27'! additionalInspectorClasses "Answer addtional inspector classes that are used to show alternative views of instances of myself" ^ { }! ! !Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/25/2006 18:17'! when: anEventSelector send: aMessageSelector to: anObject withArguments: anArgArray exclusive: aValueHolder self when: anEventSelector evaluate: ((ExclusiveWeakMessageSend receiver: anObject selector: aMessageSelector arguments: anArgArray) basicExecuting: aValueHolder)! ! !Object methodsFor: 'printing' stamp: ''! storeOn: aStream "Append to the argument aStream a sequence of characters that is an expression whose evaluation creates an object similar to the receiver." aStream nextPut: $(. self class isVariable ifTrue: [aStream nextPutAll: '(', self class name, ' basicNew: '; store: self basicSize; nextPutAll: ') '] ifFalse: [aStream nextPutAll: self class name, ' basicNew']. 1 to: self class instSize do: [:i | aStream nextPutAll: ' instVarAt: '; store: i; nextPutAll: ' put: '; store: (self instVarAt: i); nextPut: $;]. 1 to: self basicSize do: [:i | aStream nextPutAll: ' basicAt: '; store: i; nextPutAll: ' put: '; store: (self basicAt: i); nextPut: $;]. aStream nextPutAll: ' yourself)' ! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:22'! triggerEvent: anEventSelector "Evaluate all actions registered for . Return the value of the last registered action." ^(self actionForEvent: anEventSelector) value! ! !Object methodsFor: 'casing-To be deprecated' stamp: 'StephaneDucasse 8/12/2013 21:27'! caseError "DO NOT USE THIS METHOD!! It will be removed from Pharo." "Report an error from an in-line or explicit case statement." self error: 'Case not found (', self printString, '), and no otherwise clause'! ! !Object methodsFor: 'error handling' stamp: 'SvenVanCaekenberghe 4/20/2011 13:26'! shouldBeImplemented "Announce that this message should be implemented" ShouldBeImplemented signalFor: thisContext sender selector! ! !Object methodsFor: 'dependencies' stamp: 'ar 2/11/2001 01:55'! addDependent: anObject "Make the given object one of the receiver's dependents." | dependents | dependents := self dependents. (dependents includes: anObject) ifFalse: [self myDependents: (dependents copyWithDependent: anObject)]. ^ anObject! ! !Object methodsFor: '*UIManager' stamp: 'CamilloBruni 8/1/2012 16:09'! inform: aString "Display a message for the user to read and then dismiss." aString isEmptyOrNil ifFalse: [UIManager default inform: aString]! ! !Object methodsFor: 'introspection' stamp: 'sw 10/16/2000 10:59'! className "Answer a string characterizing the receiver's class, for use in list views for example" ^ self class name asString! ! !Object methodsFor: 'logging-Deprecated' stamp: 'StephaneDucasse 5/27/2011 19:09'! crLog: aString "Log the argument. Use self log: instead of Transcript cr; show: " Transcript cr; show: aString.! ! !Object methodsFor: 'tracing' stamp: 'StephaneDucasse 11/6/2011 23:56'! traceCr self traceCr: self printString! ! !Object methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 7/22/2013 16:07'! mustBeBooleanInMagic: context "Permits to redefine methods inlined by compiler. Take the ast node corresponding to the mustBeBoolean error, compile it on the fly with Opal and executes it as a DoIt. Then resume the execution of the context." | proceedValue sendNode selector expression arguments methodNode method offset position | context skipBackBeforeJump. sendNode := context sourceNode sourceNodeForPC: context pc. position := sendNode irInstruction bytecodeOffset. offset := sendNode irInstruction nextBytecodeOffsetAfterJump - position. expression := sendNode copy asSequenceNode transformLastToReturn. selector := #ExecuteUnOptimzedIn:. arguments := {(RBVariableNode named:'ThisContext')}. methodNode := RBMethodNode selector: selector arguments: arguments body: expression. context tempNames do: [:tempName | methodNode :=methodNode rewriteTempNamedWrite: tempName forContext: context. methodNode :=methodNode rewriteTempNamedRead: tempName forContext: context. ]. methodNode compilationContext: sendNode methodNode compilationContext. methodNode compilationContext class: UndefinedObject; compilerOptions: #(+ optionIlineNone). method := methodNode generateWithSource. context jump: offset. proceedValue := self withArgs: {context} executeMethod: method. ^proceedValue! ! !Object methodsFor: '*Fuel' stamp: 'MaxLeske 5/3/2013 15:18'! fuelReplacement ^ self! ! !Object methodsFor: 'stepping' stamp: 'sw 10/20/1999 14:52'! stepAt: millisecondClockValue in: aWindow ^ self stepIn: aWindow! ! !Object methodsFor: '*Kernel-Exceptions-debugging' stamp: 'SeanDeNigris 8/29/2011 15:16'! haltOnCount: anInteger Halt onCount: anInteger.! ! !Object methodsFor: 'comparing' stamp: 'MarianoMartinezPeck 8/24/2012 15:58'! = anObject "Answer whether the receiver and the argument represent the same object. If = is redefined in any subclass, consider also redefining the message hash." ^self == anObject ! ! !Object methodsFor: '*Kernel-Exceptions-debugging' stamp: 'SeanDeNigris 8/29/2011 12:16'! haltIfShiftPressed Halt ifShiftPressed.! ! !Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:15'! adaptToInteger: rcvr andSend: selector "If no method has been provided for adapting an object to a Integer, then it may be adequate to simply adapt it to a number." ^ self adaptToNumber: rcvr andSend: selector! ! !Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:31'! removeAction: anAction forEvent: anEventSelector self removeActionsSatisfying: [:action | action = anAction] forEvent: anEventSelector! ! !Object methodsFor: 'testing' stamp: 'md 4/30/2003 15:30'! isSymbol ^ false ! ! !Object methodsFor: 'testing' stamp: 'md 8/11/2005 16:45'! isDictionary ^false! ! !Object methodsFor: 'testing' stamp: 'rhi 8/14/2003 08:51'! isHeap ^ false! ! !Object methodsFor: 'error handling' stamp: 'md 1/20/2006 16:24'! handles: exception "This method exists in case a non exception class is the first arg in an on:do: (for instance using a exception class that is not loaded). We prefer this to raising an error during error handling itself. Also, semantically it makes sense that the exception handler is not active if its exception class is not loaded" ^ false! ! !Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'! when: anEventSelector send: aMessageSelector to: anObject with: anArg self when: anEventSelector evaluate: (WeakMessageSend receiver: anObject selector: aMessageSelector arguments: (Array with: anArg))! ! !Object methodsFor: 'error handling' stamp: 'md 8/2/2005 22:17'! error "Throw a generic Error exception." ^self error: 'Error!!'.! ! !Object methodsFor: 'comparing' stamp: ''! ~= anObject "Answer whether the receiver and the argument do not represent the same object." ^self = anObject == false! ! !Object methodsFor: 'introspection' stamp: ''! instVarAt: index "Primitive. Answer a fixed variable in an object. The numbering of the variables corresponds to the named instance variables. Fail if the index is not an Integer or is not the index of a fixed variable. Essential. See Object documentation whatIsAPrimitive." "Access beyond fixed variables." ^self basicAt: index - self class instSize ! ! !Object methodsFor: 'testing' stamp: ''! isNumber "Overridden to return true in Number, natch" ^ false! ! !Object methodsFor: 'testing' stamp: 'jam 3/9/2003 15:10'! isSystemWindow "answer whatever the receiver is a SystemWindow" ^ false! ! !Object methodsFor: 'events-removing' stamp: 'rw 7/29/2003 17:18'! removeActionsWithReceiver: anObject self actionMap copy keysDo: [:eachEventSelector | self removeActionsSatisfying: [:anAction | anAction receiver == anObject] forEvent: eachEventSelector ]! ! !Object methodsFor: '*Fuel' stamp: 'MartinDias 8/27/2011 19:03'! fuelAfterMaterialization "Materialization process will send this message after materializing instances of my class"! ! !Object methodsFor: 'updating' stamp: 'MarianoMartinezPeck 8/24/2012 15:28'! windowIsClosing "This message is used to inform a models that its window is closing. Most models do nothing, but some, such as the Debugger, must do some cleanup. Note that this mechanism must be used with care by models that support multiple views, since one view may be closed while others left open." ! ! !Object methodsFor: 'flagging' stamp: 'MarcusDenker 9/14/2013 10:28'! isThisEverCalled: msg "Send this message, with some useful printable argument, from methods or branches of methods which you believe are never reached." self error: 'This is indeed called: ', msg printString! ! !Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'! when: anEventSelector send: aMessageSelector to: anObject withArguments: anArgArray self when: anEventSelector evaluate: (WeakMessageSend receiver: anObject selector: aMessageSelector arguments: anArgArray)! ! !Object methodsFor: 'user interface' stamp: 'sw 10/16/1999 22:45'! modelWakeUpIn: aWindow "A window with me as model is being entered or expanded. Default response is no-op" self modelWakeUp! ! !Object methodsFor: 'user interface' stamp: 'RAA 3/31/1999 12:13'! withoutListWrapper ^self! ! !Object methodsFor: 'error handling' stamp: ''! notify: aString at: location "Create and schedule a Notifier with the argument as the message in order to request confirmation before a process can proceed. Subclasses can override this and insert an error message at location within aString." self notify: aString "nil notify: 'confirmation message' at: 12"! ! !Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:14'! adaptToFraction: rcvr andSend: selector "If no method has been provided for adapting an object to a Fraction, then it may be adequate to simply adapt it to a number." ^ self adaptToNumber: rcvr andSend: selector! ! !Object methodsFor: '*Tools-Browser' stamp: 'BenjaminVanRyseghem 2/8/2012 17:10'! browse ^ self systemNavigation browseClass: self class! ! !Object methodsFor: '*monticellofiletree-core' stamp: 'dkh 4/6/2012 15:56:14'! writeCypressJsonOn: aStream indent: startIndent self writeCypressJsonOn: aStream forHtml: false indent: startIndent! ! !Object methodsFor: 'finalization' stamp: 'ar 3/21/98 18:38'! retryWithGC: execBlock until: testBlock "Retry execBlock as long as testBlock returns false. Do an incremental GC after the first try, a full GC after the second try." | blockValue | blockValue := execBlock value. (testBlock value: blockValue) ifTrue:[^blockValue]. Smalltalk garbageCollectMost. blockValue := execBlock value. (testBlock value: blockValue) ifTrue:[^blockValue]. Smalltalk garbageCollect. ^execBlock value.! ! !Object methodsFor: 'testing' stamp: 'sma 6/15/2000 15:48'! isString "Overridden to return true in String, natch" ^ false! ! !Object methodsFor: 'evaluating' stamp: 'MarianoMartinezPeck 8/24/2012 15:58'! value ^self! ! !Object methodsFor: '*Tools-Explorer' stamp: 'MarcusDenker 9/28/2013 15:39'! explore ^Smalltalk tools inspector explore: self! ! !Object methodsFor: 'drag and drop' stamp: ''! dragTransferTypeForMorph: dragSource ^nil! ! !Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:22'! logExit Transcript show: 'Exited ', thisContext sender printString; cr. ! ! !Object methodsFor: 'tracing' stamp: 'StephaneDucasse 11/6/2011 23:58'! trace self trace: self printString! ! !Object methodsFor: 'testing' stamp: 'MarcusDenker 4/9/2013 14:25'! isNotNil "Coerces nil to false and everything else to true." ^true! ! !Object methodsFor: 'copying' stamp: 'StephaneDucasse 2/20/2010 21:43'! veryDeepInner: deepCopier "No special treatment for inst vars of my superclasses. Override when some need to be weakly copied. Object>>veryDeepCopyWith: will veryDeepCopy any inst var whose class does not actually define veryDeepInner:" "avoid to use me we will deprecate it in the future"! ! !Object methodsFor: 'nil testing' stamp: 'MarcusDenker 12/2/2013 14:14'! ifNotNilDo: aBlock "Please use #ifNotNil: instead" ^ aBlock value: self ! ! !Object methodsFor: 'binding' stamp: ''! bindingOf: aString ^nil! ! !Object methodsFor: 'logging-Deprecated' stamp: 'StephaneDucasse 11/5/2011 10:49'! logCr self logCr: self printString! ! !Object methodsFor: 'converting' stamp: 'MarianoMartinezPeck 8/24/2012 15:58'! asString "Answer a string that represents the receiver." ^ self printString ! ! !Object methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/22/2012 14:25'! nbCalloutIn: aContext ^ NBFFICalloutAPI inContext: aContext! ! !Object methodsFor: 'logging-Deprecated' stamp: 'StephaneDucasse 5/23/2011 22:09'! logCr: aString "Log the argument. Use self logCr: 'something' instead of Transcript show: 'something' ; cr " Transcript show: aString ; cr! ! !Object methodsFor: '*Spec-Inspector' stamp: 'SeanDeNigris 1/23/2013 22:22'! inspectOnce "Inspect unless we have already done it once." Halt isHaltOnceEnabled ifTrue: [ Halt disableHaltOnce. ^ self inspect ].! ! !Object methodsFor: '*Morphic-Base' stamp: 'nk 9/1/2004 10:41'! currentHand "Return a usable HandMorph -- the one associated with the object's current environment. This method will always return a hand, even if it has to conjure one up as a last resort. If a particular hand is actually handling events at the moment (such as a remote hand or a ghost hand), it will be returned." ^ActiveHand ifNil: [ self currentWorld primaryHand ]! ! !Object methodsFor: '*Ring-Core-Kernel' stamp: 'StephaneDucasse 7/16/2011 22:53'! isRingObject ^false! ! !Object methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'! isMethodProperties ^false! ! !Object methodsFor: 'asserting' stamp: 'jannik.laval 5/2/2010 16:59'! assert: aBlock descriptionBlock: descriptionBlock "Throw an assertion error if aBlock does not evaluate to true." aBlock value ifFalse: [AssertionFailure signal: descriptionBlock value asString ]! ! !Object methodsFor: 'testing' stamp: ''! isInteger "Overridden to return true in Integer." ^ false! ! !Object methodsFor: 'testing' stamp: 'len 1/13/98 21:18'! isFraction "Answer true if the receiver is a Fraction." ^ false! ! !Object methodsFor: 'testing' stamp: ''! isColor "Answer true if receiver is a Color. False by default." ^ false ! ! !Object methodsFor: 'testing' stamp: 'eem 5/23/2008 13:47'! isClosure ^false! ! !Object methodsFor: '*Morphic-Base' stamp: 'ar 3/18/2001 00:03'! currentEvent "Answer the current Morphic event. This method never returns nil." ^ActiveEvent ifNil:[self currentHand lastEvent]! ! !Object methodsFor: '*Fuel' stamp: 'CamilloBruni 6/14/2013 09:59'! serializeToFileNamed: aFilename ^ FLSerializer serialize: self toFileNamed: aFilename! ! !Object methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/24/2012 15:58'! name "Answer a name for the receiver. This is used generically in the title of certain inspectors, such as the referred-to inspector, and specificially by various subsystems. By default, we let the object just print itself out.. " ^ self printString ! ! !Object methodsFor: '*metacello-core' stamp: 'dkh 6/21/2012 20:09'! metacelloSemanticStringLessThanSelf: anInteger ^ self error: 'Invalid Metacello verson component - should be String or Integer.'! ! !Object methodsFor: '*Tools-Finder' stamp: 'MarcusDenker 9/20/2011 10:19'! closeTo: anObject "Do not use this Method!! It is a workaround for MethodFinder" ^[self = anObject] ifError: [false]! ! !Object methodsFor: '*Shout-Parsing' stamp: 'SeanDeNigris 6/22/2012 18:24'! shoutParser: anSHParserST80 "Tools can define this method to customize the parser"! ! !Object methodsFor: 'introspection' stamp: ''! instVarAt: anInteger put: anObject "Primitive. Store a value into a fixed variable in the receiver. The numbering of the variables corresponds to the named instance variables. Fail if the index is not an Integer or is not the index of a fixed variable. Answer the value stored as the result. Using this message violates the principle that each object has sovereign control over the storing of values into its instance variables. Essential. See Object documentation whatIsAPrimitive." "Access beyond fixed fields" ^self basicAt: anInteger - self class instSize put: anObject! ! !Object methodsFor: 'drag and drop' stamp: ''! wantsDroppedMorph: aMorph event: anEvent inMorph: destinationLM ^false ! ! !Object methodsFor: 'testing' stamp: 'di 11/9/1998 09:38'! isFloat "Overridden to return true in Float, natch" ^ false! ! !Object methodsFor: 'introspection' stamp: 'eem 5/14/2008 13:20'! instVarNamed: aString put: aValue "Store into the value of the instance variable in me of that name. Slow and unclean, but very useful. " ^self instVarAt: (self class instVarIndexFor: aString asString ifAbsent: [self error: 'no such inst var']) put: aValue ! ! !Object methodsFor: 'testing' stamp: 'MarcusDenker 10/17/2013 12:05'! isClassOrTrait ^ false! ! !Object methodsFor: 'dependencies' stamp: 'sma 2/29/2000 19:52'! myDependents: aCollectionOrNil "Private. Set (or remove) the receiver's dependents list." aCollectionOrNil ifNil: [DependentsFields removeKey: self ifAbsent: []] ifNotNil: [DependentsFields at: self put: aCollectionOrNil]! ! !Object methodsFor: 'class membership' stamp: ''! isMemberOf: aClass "Answer whether the receiver is an instance of the class, aClass." ^self class == aClass! ! !Object methodsFor: 'converting' stamp: 'MarcusDenker 7/20/2012 14:59'! asStringOrText "Answer a string that represents the receiver." ^ self asString ! ! !Object methodsFor: 'error handling' stamp: 'SvenVanCaekenberghe 4/20/2011 13:25'! subclassResponsibility "This message sets up a framework for the behavior of the class' subclasses. Announce that the subclass should have implemented this message." SubclassResponsibility signalFor: thisContext sender selector! ! !Object methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/24/2012 15:29'! at: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive. Read the class comment for a discussion about that the fact that the index can be a float." index isInteger ifTrue: [self class isVariable ifTrue: [self errorSubscriptBounds: index] ifFalse: [self errorNotIndexable]]. index isNumber ifTrue: [^self at: index asInteger] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: '*NativeBoost-core' stamp: 'CamilloBruni 1/13/2013 18:20'! nbLibraryNameOrHandle self flag: 'HACK: avoid direct subclassResponsibility to not break RB test cases..'. ^ SubclassResponsibility signalFor: thisContext selector ! ! !Object methodsFor: 'converting' stamp: ''! as: aSimilarClass "Create an object of class aSimilarClass that has similar contents to the receiver." ^ aSimilarClass newFrom: self! ! !Object methodsFor: 'error handling' stamp: 'MarcusDenker 5/24/2012 10:37'! notYetImplemented "Announce that this message is not yet implemented" NotYetImplemented signalFor: thisContext sender selector! ! !Object methodsFor: '*Morphic-Core' stamp: 'JuanVuletich 11/1/2010 15:18'! currentWorld "Answer a morphic world that is the current UI focus." ^UIManager default currentWorld! ! !Object methodsFor: '*Deprecated30' stamp: 'StephaneDucasse 5/24/2013 08:23'! triggerEvent: anEventSelector ifNotHandled: anExceptionBlock "Evaluate all actions registered for . Return the value of the last registered action." self deprecated: 'do not used it anymore!!' on: '21 May 2013' in: #Pharo30. ^(self actionForEvent: anEventSelector ifAbsent: [^anExceptionBlock value]) value ! ! !Object methodsFor: '*Polymorph-EventEnhancements' stamp: 'gvc 10/24/2006 11:49'! when: anEventSelector sendOnce: aMessageSelector to: anObject withArguments: anArgArray self when: anEventSelector evaluate: (NonReentrantWeakMessageSend receiver: anObject selector: aMessageSelector arguments: anArgArray)! ! !Object methodsFor: '*Spec-Tools' stamp: 'BenjaminVanRyseghem 10/3/2012 13:57'! displaySubObjectAt: index ^ self class allInstVarNames at: index! ! !Object methodsFor: 'comparing' stamp: 'MarianoMartinezPeck 8/24/2012 15:58'! hash "Answer a SmallInteger whose value is related to the receiver's identity. May be overridden, and should be overridden in any classes that define = " ^ self identityHash ! ! !Object methodsFor: 'updating' stamp: ''! update: aParameter "Receive a change notice from an object of whom the receiver is a dependent. The default behavior is to do nothing; a subclass might want to change itself in some way." ^ self! ! !Object methodsFor: 'message performing' stamp: 'nk 4/11/2002 14:13'! perform: selector withEnoughArguments: anArray "Send the selector, aSymbol, to the receiver with arguments in argArray. Only use enough arguments for the arity of the selector; supply nils for missing ones." | numArgs args | numArgs := selector numArgs. anArray size == numArgs ifTrue: [ ^self perform: selector withArguments: anArray asArray ]. args := Array new: numArgs. args replaceFrom: 1 to: (anArray size min: args size) with: anArray startingAt: 1. ^ self perform: selector withArguments: args! ! !Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:23'! logExecution Transcript show: 'Executing ', thisContext sender printString; cr. ! ! !Object methodsFor: 'copying' stamp: 'MarcusDenker 9/27/2010 15:28'! copy "Answer another instance just like the receiver. Subclasses typically override postCopy; they typically do not override shallowCopy. Copy is a template method in the sense of Design Patterns. So do not override it. Override postCopy instead. Pay attention that normally you should call postCopy of your superclass too." ^self shallowCopy postCopy! ! !Object methodsFor: '*Morphic-Base' stamp: 'BenjaminVanRyseghem 10/7/2011 21:36'! dragPassengersFor: item inMorph: dragSource ^ { item }! ! !Object methodsFor: '*Kernel-Exceptions-debugging' stamp: 'SeanDeNigris 8/29/2011 15:02'! haltOnce Halt once.! ! !Object methodsFor: '*Spec-Inspector' stamp: 'MarcusDenker 9/28/2013 15:49'! inspect "Create and schedule an Inspector in which the user can examine the receiver's variables." ^ Smalltalk tools inspector inspect: self! ! !Object methodsFor: 'user interface' stamp: 'RAA 8/2/1999 12:41'! complexContents ^self! ! !Object methodsFor: 'evaluating' stamp: 'ajh 1/21/2003 12:59'! in: aBlock "Evaluate the given block with the receiver as its argument." ^ aBlock value: self ! ! !Object methodsFor: 'testing' stamp: 'ar 10/30/2000 23:22'! isForm ^false! ! !Object methodsFor: 'stepping' stamp: 'di 1/8/1999 15:04'! wantsSteps "Overridden by morphic classes whose instances want to be stepped, or by model classes who want their morphic views to be stepped." ^ false! ! !Object methodsFor: '*Morphic-Base' stamp: 'BenjaminVanRyseghem 2/7/2014 15:19'! asAlphaImageMorph ^ self asMorph! ! !Object methodsFor: 'finalization' stamp: 'ar 3/20/98 22:19'! executor "Return an object which can act as executor for finalization of the receiver" ^self shallowCopy actAsExecutor! ! !Object methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:47'! isSelfEvaluating ^ self isLiteral! ! !Object methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/10/2007 11:41'! okToClose "Sent to models when a window closing. Allows this check to be independent of okToChange." ^true! ! !Object methodsFor: '*Collections-Abstract-splitjoin' stamp: 'onierstrasz 4/10/2009 22:50'! join: aSequenceableCollection ^ (Array with: self) join: aSequenceableCollection! ! !Object methodsFor: 'literal testing' stamp: 'md 1/20/2006 17:09'! hasLiteralSuchThat: testBlock "This is the end of the imbedded structure path so return false." ^ false! ! !Object class methodsFor: '*System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:21'! fileReaderServicesForFile: fullName suffix: suffix "Backstop" ^#()! ! !Object class methodsFor: '*Polymorph-TaskbarIcons' stamp: ''! taskbarIcon "Answer the icon for an instance of the receiver in a task bar or nil for the default." ^nil ! ! !Object class methodsFor: 'class initialization' stamp: 'rw 2/10/2002 13:09'! flushEvents "Object flushEvents" EventManager flushEvents. ! ! !Object class methodsFor: 'instance creation' stamp: 'MarcusDenker 5/2/2013 11:24'! readFrom: textStringOrStream "Create an object based on the contents of textStringOrStream." | object | object := self class compiler evaluate: textStringOrStream. (object isKindOf: self) ifFalse: [self error: self name, ' expected']. ^object! ! !Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 01:41'! initializeDependentsFields "Object initialize" DependentsFields := WeakIdentityKeyDictionary new. ! ! !Object class methodsFor: '*Tools-Debugger' stamp: 'SeanDeNigris 5/28/2013 17:57'! canonicalArgumentName | prefix | prefix := self name first isVowel ifTrue: [ 'an' ] ifFalse: [ 'a' ]. ^ prefix, self name.! ! !Object class methodsFor: 'documentation' stamp: ''! howToModifyPrimitives "You are allowed to write methods which specify primitives, but please use caution. If you make a subclass of a class which contains a primitive method, the subclass inherits the primitive. The message which is implemented primitively may be overridden in the subclass (E.g., see at:put: in String's subclass Symbol). The primitive behavior can be invoked using super (see Symbol string:). A class which attempts to mimic the behavior of another class without being its subclass may or may not be able to use the primitives of the original class. In general, if the instance variables read or written by a primitive have the same meanings and are in the same fields in both classes, the primitive will work. For certain frequently used 'special selectors', the compiler emits a send-special-selector bytecode instead of a send-message bytecode. Special selectors were created because they offer two advantages. Code which sends special selectors compiles into fewer bytes than normal. For some pairs of receiver classes and special selectors, the interpreter jumps directly to a primitive routine without looking up the method in the class. This is much faster than a normal message lookup. A selector which is a special selector solely in order to save space has a normal behavior. Methods whose selectors are special in order to gain speed contain the comment, 'No Lookup'. When the interpreter encounters a send-special-selector bytecode, it checks the class of the receiver and the selector. If the class-selector pair is a no-lookup pair, then the interpreter swiftly jumps to the routine which implements the corresponding primitive. (A special selector whose receiver is not of the right class to make a no-lookup pair, is looked up normally). The pairs are listed below. No-lookup methods contain a primitive number specification, , which is redundant. Since the method is not normally looked up, deleting the primitive number specification cannot prevent this primitive from running. If a no-lookup primitive fails, the method is looked up normally, and the expressions in it are executed. No Lookup pairs of (class, selector) SmallInteger with any of + - * / \\ bitOr: bitShift: bitAnd: // SmallInteger with any of = ~= > < >= <= Any class with == Any class with @ Point with either of x y ContextPart with blockCopy: BlockContext with either of value value: " self error: 'comment only'! ! !Object class methodsFor: 'documentation' stamp: ''! whatIsAPrimitive "Some messages in the system are responded to primitively. A primitive response is performed directly by the interpreter rather than by evaluating expressions in a method. The methods for these messages indicate the presence of a primitive response by including before the first expression in the method. Primitives exist for several reasons. Certain basic or 'primitive' operations cannot be performed in any other way. Smalltalk without primitives can move values from one variable to another, but cannot add two SmallIntegers together. Many methods for arithmetic and comparison between numbers are primitives. Some primitives allow Smalltalk to communicate with I/O devices such as the disk, the display, and the keyboard. Some primitives exist only to make the system run faster; each does the same thing as a certain Smalltalk method, and its implementation as a primitive is optional. When the Smalltalk interpreter begins to execute a method which specifies a primitive response, it tries to perform the primitive action and to return a result. If the routine in the interpreter for this primitive is successful, it will return a value and the expressions in the method will not be evaluated. If the primitive routine is not successful, the primitive 'fails', and the Smalltalk expressions in the method are executed instead. These expressions are evaluated as though the primitive routine had not been called. The Smalltalk code that is evaluated when a primitive fails usually anticipates why that primitive might fail. If the primitive is optional, the expressions in the method do exactly what the primitive would have done (See Number @). If the primitive only works on certain classes of arguments, the Smalltalk code tries to coerce the argument or appeals to a superclass to find a more general way of doing the operation (see SmallInteger +). If the primitive is never supposed to fail, the expressions signal an error (see SmallInteger asFloat). Each method that specifies a primitive has a comment in it. If the primitive is optional, the comment will say 'Optional'. An optional primitive that is not implemented always fails, and the Smalltalk expressions do the work instead. If a primitive is not optional, the comment will say, 'Essential'. Some methods will have the comment, 'No Lookup'. See Object howToModifyPrimitives for an explanation of special selectors which are not looked up. For the primitives for +, -, *, and bitShift: in SmallInteger, and truncated in Float, the primitive constructs and returns a 16-bit LargePositiveInteger when the result warrants it. Returning 16-bit LargePositiveIntegers from these primitives instead of failing is optional in the same sense that the LargePositiveInteger arithmetic primitives are optional. The comments in the SmallInteger primitives say, 'Fails if result is not a SmallInteger', even though the implementor has the option to construct a LargePositiveInteger. For further information on primitives, see the 'Primitive Methods' part of the chapter on the formal specification of the interpreter in the Smalltalk book." self error: 'comment only'! ! !Object class methodsFor: '*Tools-FileList' stamp: 'md 2/15/2006 17:20'! services "Backstop" ^#()! ! !Object class methodsFor: 'class initialization' stamp: 'MarianoMartinezPeck 8/24/2012 15:31'! initialize "Object initialize" DependentsFields ifNil:[self initializeDependentsFields].! ! !Object class methodsFor: 'instance creation' stamp: 'StephaneDucasse 2/20/2010 21:38'! newFrom: aSimilarObject "Create an object that has similar contents to aSimilarObject. If the classes have any instance varaibles with the same names, copy them across. If this is bad for a class, override this method." ^ (self isVariable ifTrue: [self basicNew: aSimilarObject basicSize] ifFalse: [self basicNew]) copySameFrom: aSimilarObject! ! !Object class methodsFor: '*System-Support' stamp: 'MarianoMartinezPeck 8/24/2012 15:58'! registerToolsOn: aToolRegistry " Override to register any tools for Smalltalk tools registry. " ! ! !Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 01:45'! reInitializeDependentsFields "Object reInitializeDependentsFields" | oldFields | oldFields := DependentsFields. DependentsFields := WeakIdentityKeyDictionary new. oldFields keysAndValuesDo:[:obj :deps| deps do:[:d| obj addDependent: d]]. ! ! !Object class methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! lastMetacelloVersionLoad "Answer the last version loaded and the list of packages loaded for that version. See MetacelloConfigTemplate." ^nil -> 'default'! ! !Object class methodsFor: '*metacello-mc' stamp: 'dkh 6/8/2012 14:04:22'! metacelloVersion: versionString loads: anArrayOrString "Stash the last version loaded and the list of packages loaded for that version. The list of packages will be used by the tools when doing 'Load Package Version'. See MetacelloConfigTemplate for example" "noop by default"! ! !Object class methodsFor: '*System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:27'! fileReaderServicesForDirectory: aFileDirectory "Backstop" ^#()! ! !Object class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/31/2009 15:53'! taskbarLabel "Answer the label string for the receiver in a task bar or nil for the default." ^nil! ! !Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 02:00'! flushDependents DependentsFields keysAndValuesDo:[:key :dep| key ifNotNil:[key removeDependent: nil]. ]. DependentsFields finalizeValues.! ! !Object class methodsFor: '*NewValueHolder' stamp: 'BenjaminVanRyseghem 1/24/2014 18:46'! selectionReactiveVariable "See NewValueHolder class comment" ^ SelectionValueHolder new! ! !ObjectExplorer commentStamp: ''! ObjectExplorer provides a hierarchical alternative to #inspect. Simply evaluate an expression like: World explore and enjoy.! !ObjectExplorer methodsFor: 'accessing' stamp: 'RAA 9/23/1999 13:15'! doItContext "Answer the context in which a text selection can be evaluated." ^nil! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! object ^currentSelection ifNotNil: [ :cs | cs withoutListWrapper ]! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! selector ^currentSelection ifNotNil: [ :cs | cs selector ]! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'sd 11/20/2005 21:27'! monitorList ^monitorList ifNil: [ monitorList := WeakIdentityKeyDictionary new ].! ! !ObjectExplorer methodsFor: '*Shout-Parsing' stamp: 'SeanDeNigris 6/22/2012 18:35'! shoutParser: anSHParserST80 anSHParserST80 isMethod: false.! ! !ObjectExplorer methodsFor: 'acessing - morphs' stamp: 'CamilloBruni 9/20/2013 21:18'! window | window listMorph | window := (SystemWindow labelled: self label) model: self. listMorph := self treeListMorph. window addMorph: listMorph frame: (0 @ 0 corner: 1 @ 0.8). window addMorph: self textMorph frame: (0 @ 0.8 corner: 1 @ 1). listMorph autoDeselect: false. ^ window! ! !ObjectExplorer methodsFor: 'user interface' stamp: 'stephaneducasse 9/17/2005 21:51'! openExplorerFor: anObject withLabel: label "ObjectExplorer new openExplorerFor: Smalltalk withLabel: 'Smalltalk'" (self explorerFor: anObject withLabel: label) openInWorld! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'MarcusDenker 3/26/2011 21:57'! getCurrentSelection ^currentSelection! ! !ObjectExplorer methodsFor: 'updating' stamp: 'MarcusDenker 3/26/2011 21:57'! noteNewSelection: x currentSelection := x. self changed: #getCurrentSelection. currentSelection ifNil: [^self]. currentSelection sendSettingMessageTo: self. ! ! !ObjectExplorer methodsFor: 'menus' stamp: 'NicolaiHess 2/23/2014 10:53'! addTo: aMenu fromMenuModelOf: element "adapt elements menuModel items as menu morph items " | menuModel | menuModel := MenuModel new. element inspectionMenu: menuModel. menuModel menuGroups do: [ :group | | items | items := group buildWithSpec. items do: [ :item | aMenu addMenuItem: item ] ] separatedBy: [ aMenu addLine ]! ! !ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:26'! inspectSelection "Open an Inspector on the current selection" self object inspect! ! !ObjectExplorer methodsFor: 'menus' stamp: 'IgorStasenko 1/22/2012 14:42'! explorePointers "Open a PointerExplorer on the current selection" Smalltalk tools pointerExplorer openOn: self object! ! !ObjectExplorer methodsFor: '*necompletion' stamp: 'SeanDeNigris 6/22/2012 16:25'! isCodeCompletionAllowed ^ true.! ! !ObjectExplorer methodsFor: '*necompletion-extensions' stamp: 'SeanDeNigris 6/22/2012 16:26'! selectedClassOrMetaClass ^ self selectedClass! ! !ObjectExplorer methodsFor: '*necompletion' stamp: 'SeanDeNigris 7/7/2012 22:48'! guessTypeForName: aString self flag: 'we may be able to do something more sophisticated here, but needed something to prevent a DNU. Returning nil was taken from AbstractTool. See Debugger or Workspace for actual guessing logic'. ^ nil.! ! !ObjectExplorer methodsFor: 'menus' stamp: 'sd 11/20/2005 21:27'! defsOfSelection "Open a browser on all defining references to the selected instance variable, if that's what's currently selected." | aClass sel | (aClass := self parentObject class) isVariable ifTrue: [^ self changed: #flash]. sel := self selector. self systemNavigation browseAllStoresInto: sel from: aClass! ! !ObjectExplorer methodsFor: '*Shout-Styling' stamp: 'SeanDeNigris 6/22/2012 19:07'! shoutAboutToStyle: aPluggableShoutMorphOrView aPluggableShoutMorphOrView classOrMetaClass: self object class. ^ true! ! !ObjectExplorer methodsFor: 'menus' stamp: 'IgorStasenko 9/2/2012 17:05'! exploreStrongPointers "Open a StrongPointerExplorer on the current selection" Smalltalk tools strongPointerExplorer openOn: self object! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:16'! getList ^Array with: (ObjectExplorerWrapper with: rootObject name: 'root' model: self parent: nil) ! ! !ObjectExplorer methodsFor: 'user interface' stamp: 'RAA 6/2/2000 16:23'! initialExtent ^300@500! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:01'! release self world ifNotNil: [ self world stopStepping: self selector: #step ]. super release.! ! !ObjectExplorer methodsFor: 'menus' stamp: 'RAA 9/23/1999 13:19'! selectedClass "Answer the class of the receiver's current selection" ^self doItReceiver class ! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'RAA 9/23/1999 13:11'! contentsSelection "Return the interval of text in the code pane to select when I set the pane's contents" ^ 1 to: 0 "null selection"! ! !ObjectExplorer methodsFor: 'menus' stamp: 'RAA 9/23/1999 13:22'! codePaneMenu: aMenu shifted: shifted "Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items" ^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted ! ! !ObjectExplorer methodsFor: 'menus' stamp: 'IgorStasenko 8/28/2013 11:28'! genericMenu: aMenu currentSelection isNil ifTrue: [ self buildMenuForNoSelection: aMenu ] ifFalse: [ self buildMenuForSelection: aMenu ]. ^ aMenu! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 10:02'! parentObject currentSelection ifNil: [ ^nil ]. currentSelection parent ifNil: [ ^rootObject ]. ^currentSelection parent withoutListWrapper! ! !ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:26'! exploreSelection "Open an ObjectExplorer on the current selection" self object explore! ! !ObjectExplorer methodsFor: 'user interface' stamp: 'CamilloBruni 9/20/2013 21:43'! openExplorerFor: anObject " ObjectExplorer new openExplorerFor: Smalltalk " | win | self rootObject: anObject. win := (self explorerFor: anObject) openInWorld. self expandTreeInMorph: win. ^self ! ! !ObjectExplorer methodsFor: 'menus' stamp: 'sd 11/20/2005 21:27'! referencesToSelection "Open a browser on all references to the selected instance variable, if that's what's currently selected." | aClass sel | (aClass := self parentObject class) isVariable ifTrue: [^ self changed: #flash]. sel := self selector. self systemNavigation browseAllAccessesTo: sel from: aClass! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/12/2003 17:55'! shouldGetStepsFrom: aWorld ^self monitorList notEmpty! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'sd 11/20/2005 21:27'! stopMonitoring monitorList := nil. self world stopStepping: self selector: #step! ! !ObjectExplorer methodsFor: 'menus' stamp: 'IgorStasenko 8/28/2013 11:43'! explorerKey: aChar from: view currentSelection ifNotNil: [ aChar == $i ifTrue: [^ self inspectSelection]. aChar == $I ifTrue: [^ self exploreSelection]. aChar == $b ifTrue: [^ self object browse]. aChar == $h ifTrue: [^ self systemNavigation browseHierarchy: self object class]. ]. ^ self arrowKey: aChar from: view! ! !ObjectExplorer methodsFor: 'user interface' stamp: 'CamilloBruni 9/20/2013 20:21'! explorerFor: anObject withLabel: label ^UIManager default explorer: self withLabel: label! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:02'! monitor: anObjectExplorerWrapper "Start stepping and watching the given wrapper for changes." anObjectExplorerWrapper ifNil: [ ^self ]. self world ifNil: [ ^self ]. self monitorList at: anObjectExplorerWrapper put: anObjectExplorerWrapper asString. self world startStepping: self at: Time millisecondClockValue selector: #step arguments: #() stepTime: 200.! ! !ObjectExplorer methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon ^ Smalltalk ui icons smallInspectItIcon ! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nice 1/5/2010 15:59'! step "If there's anything in my monitor list, see if the strings have changed." | changes | changes := false. self monitorList keysAndValuesDo: [ :k :v | | string | k ifNotNil: [ k refresh. (string := k asString) ~= v ifTrue: [ self monitorList at: k put: string. changes := true ]. ] ]. changes ifTrue: [ | sel | sel := currentSelection. self changed: #getList. self noteNewSelection: sel. ]. self monitorList isEmpty ifTrue: [ ActiveWorld stopStepping: self selector: #step ].! ! !ObjectExplorer methodsFor: 'updating' stamp: 'MarcusDenker 3/26/2011 21:58'! update: aSymbol aSymbol == #hierarchicalList ifTrue: [ ^self changed: #getList ]. super update: aSymbol! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 20:21'! explorerFor: anObject ^UIManager default explorer: self withLabel: (anObject printStringLimitedTo: 32)! ! !ObjectExplorer methodsFor: 'menus' stamp: 'IgorStasenko 8/28/2013 11:23'! buildMenuForNoSelection: aMenu ^ aMenu add: '*nothing selected*' target: self selector: #yourself ! ! !ObjectExplorer methodsFor: 'menus' stamp: 'NicolaiHess 2/23/2014 10:53'! buildMenuForSelection: aMenu "Borrow a menu from my inspector" | element | aMenu defaultTarget: self. element := SelfEyeElement host: self object. element mainInspectSubMenu: aMenu. self addTo:aMenu fromMenuModelOf:element. aMenu addLine; add: 'monitor changes' target: self selector: #monitor: argument: currentSelection. monitorList isEmptyOrNil ifFalse: [aMenu addLine; add: 'stop monitoring all' target: self selector: #stopMonitoring]. ! ! !ObjectExplorer methodsFor: 'user interface' stamp: 'CamilloBruni 9/20/2013 21:45'! expandTreeInMorph: morph Cursor wait showWhile: [ (morph respondsTo: #expandRoots) ifTrue: [ morph expandRoots ]. morph submorphs do: [ :subMorph| (subMorph respondsTo: #expandRoots) ifTrue: [ subMorph expandRoots ]]].! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:01'! world ^ActiveWorld! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 20:21'! label ^ self rootObject printStringLimitedTo: 32! ! !ObjectExplorer methodsFor: 'acessing - morphs' stamp: 'CamilloBruni 9/20/2013 21:18'! textMorph | text | text := PluggableTextMorph on: self text: #trash accept: #trash: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. text askBeforeDiscardingEdits: false. ^ text! ! !ObjectExplorer methodsFor: 'acessing - morphs' stamp: 'CamilloBruni 9/20/2013 20:19'! treeListMorph ^ SimpleHierarchicalListMorph on: self list: #getList selected: #getCurrentSelection changeSelected: #noteNewSelection: menu: #genericMenu: keystroke: #explorerKey:from:! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'RAA 9/23/1999 13:19'! doItReceiver "Answer the object that should be informed of the result of evaluating a text selection." currentSelection ifNil: [^rootObject]. ^currentSelection withoutListWrapper ! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'JuanVuletich 10/26/2010 14:27'! rootObject: anObject rootObject := anObject! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2013 20:21'! rootObject ^ rootObject! ! !ObjectExplorer class methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:55'! about StringHolder new textContents: self comment; openLabel: 'about ',self asString! ! !ObjectExplorer class methodsFor: 'setting' stamp: 'AlainPlantec 12/6/2009 22:13'! showIcons: aBoolean ShowIcons := aBoolean! ! !ObjectExplorer class methodsFor: 'tools registry' stamp: 'IgorStasenko 2/20/2011 15:07'! openOn: anObject " -- common protocol for inspector/explorer " ^ self new openExplorerFor: anObject! ! !ObjectExplorer class methodsFor: 'setting' stamp: 'AlainPlantec 12/6/2009 22:12'! showIcons ^ ShowIcons ifNil: [ShowIcons := true]! ! !ObjectExplorerWrapper commentStamp: ''! Contributed by Bob Arning as part of the ObjectExplorer package. ! !ObjectExplorerWrapper methodsFor: 'monitoring' stamp: 'nk 7/12/2003 18:28'! refresh "hack to refresh item given an object and a string that is either an index or an instance variable name." [ | index | (model class allInstVarNames includes: itemName) ifTrue: [ item := model instVarNamed: itemName ] ifFalse: [ index := itemName asNumber. (index between: 1 and: model basicSize) ifTrue: [ item := model basicAt: index]] ] on: Error do: [ :ex | item := nil ]! ! !ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:49'! selector parent ifNil: [ ^nil ]. ^(parent withoutListWrapper class allInstVarNames includes: itemName) ifTrue: [ itemName asSymbol ]! ! !ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:14'! parent: anObject parent := anObject! ! !ObjectExplorerWrapper methodsFor: 'converting' stamp: 'sge 4/12/2001 08:24'! asString | explorerString string | explorerString := [item asExplorerString] on: Error do: ['']. string := itemName , ': ' , explorerString. (string includes: Character cr) ifTrue: [^ string withSeparatorsCompacted]. ^ string! ! !ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:14'! setItem: anObject name: aString model: aModel parent: itemParent parent := itemParent. self setItem: anObject name: aString model: aModel! ! !ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:14'! parent ^parent! ! !ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'RAA 6/21/1999 11:27'! hasContents ^item hasContentsInExplorer ! ! !ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'yo 8/27/2008 23:39'! contents (item customizeExplorerContents) ifTrue: [^item explorerContents]. "For all others, show named vars first, then indexed vars" ^(item class allInstVarNames asOrderedCollection withIndexCollect: [:each :index | self class with: (item instVarAt: index) name: each model: item parent: self]) , ((1 to: item basicSize) collect: [:index | self class with: (item basicAt: index) name: index printString model: item parent: self])! ! !ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'RAA 6/21/1999 10:49'! setItem: anObject name: aString model: aModel item := anObject. model := aModel. itemName := aString.! ! !ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'MarcusDenker 11/2/2013 14:44'! icon "Answer a form to be used as icon" ^ item iconOrThumbnailOfSize: 16! ! !ObjectExplorerWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 10:50'! with: anObject name: aString model: aModel ^self new setItem: anObject name: aString model: aModel! ! !ObjectExplorerWrapper class methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:16'! with: anObject name: aString model: aModel parent: aParent ^self new setItem: anObject name: aString model: aModel parent: aParent ! ! !ObjectFinalizer commentStamp: 'jcg 4/27/2010 01:01'! Represents an action that is to be taken when a target object (not referenced by the ObjectFinalizer) is garbage-collected.! !ObjectFinalizer methodsFor: 'finalization' stamp: 'IgorStasenko 8/17/2011 15:43'! finalize "Finalize the resource associated with the receiver. This message should only be sent during the finalization process. There is NO garantuee that the resource associated with the receiver hasn't been free'd before so take care that you don't run into trouble - this all may happen with interrupt priority." self value! ! !ObjectFinalizer methodsFor: 'initialize' stamp: 'jcg 1/15/2010 01:36'! receiver: anObject selector: aSymbol argument: aParameter "Not really necessary now that we're a subclass of MessageSend, but we keep it around because existing code might expect it." self receiver: anObject; selector: aSymbol; arguments: (Array with: aParameter).! ! !ObjectFinalizerCollection commentStamp: 'ul 2/26/2010 14:23'! An ObjectFinalizerCollection is simple collection which is intended to hold ObjectFinalizers and be used by WeakRegistry.! !ObjectFinalizerCollection methodsFor: 'finalization' stamp: 'ul 2/25/2010 16:53'! finalize "Finalize all elements in this collection. The elements are expected to be ObjectFinalizers, but can be any object which understands #finalize." self do: #finalize! ! !ObjectFinalizerCollection methodsFor: 'testing' stamp: 'Igor.Stasenko 5/25/2010 04:58'! hasMultipleExecutors ^ true! ! !ObjectFinalizerTests methodsFor: 'tests' stamp: 'HenrikSperreJohansen 3/30/2010 15:48'! testFinalizationOfMultipleResources "Test that finalizers for multiple resources registered will be ran when object is finalized" | objToFinalize resource1 resource2 resourceCleanBlock | objToFinalize := Object new. resource1 := Array with: false. resource2 := Array with: false. resourceCleanBlock := [:array | array at: 1 put: true]. objToFinalize toFinalizeSend: #value: to: resourceCleanBlock with: resource1. objToFinalize toFinalizeSend: #value: to: resourceCleanBlock with: resource2. self deny: resource1 first. self deny: resource2 first. "Trigger finalization" objToFinalize := nil. Smalltalk garbageCollect. self assert: resource1 first. self assert: resource2 first! ! !ObjectLayout commentStamp: ''! I am the superclass of standard layouts for Objects.! !ObjectLayout methodsFor: 'comparing' stamp: 'MartinDias 4/12/2013 13:27'! hash ^ super hash bitXor: self compactClassIndex! ! !ObjectLayout methodsFor: 'extending' stamp: 'MartinDias 7/24/2013 13:21'! extendByte self hasFields ifTrue: [ IncompatibleLayoutConflict new layout: self; subType: #byte; signal ]. ^ ByteLayout new! ! !ObjectLayout methodsFor: 'initialize-release' stamp: 'ToonVerwaest 4/1/2011 01:53'! initializeInstance: anInstance self subclassResponsibility! ! !ObjectLayout methodsFor: 'accessing' stamp: 'MartinDias 3/28/2013 12:00'! compactClassIndex ^ compactClassIndex! ! !ObjectLayout methodsFor: 'reshaping' stamp: 'MartinDias 8/28/2013 15:48'! reshapeFrom: oldScope to: newParentLayout "Answer the reshaped version of me for a new parent layout." | newScope | newScope := self slotScope rebase: oldScope to: newParentLayout slotScope. ^ newParentLayout extendAgain: self with: newScope.! ! !ObjectLayout methodsFor: 'extending' stamp: 'MartinDias 7/24/2013 13:21'! extendCompiledMethod self hasFields ifTrue: [ IncompatibleLayoutConflict new layout: self; subType: #compiledMethod; signal ]. ^ CompiledMethodLayout new! ! !ObjectLayout methodsFor: 'extending' stamp: 'MartinDias 7/24/2013 13:21'! extendVariable: aScope IncompatibleLayoutConflict new layout: self; subType: #variable; signal! ! !ObjectLayout methodsFor: 'initialization' stamp: 'ToonVerwaest 4/1/2011 01:34'! initialize compactClassIndex := 0! ! !ObjectLayout methodsFor: 'comparing' stamp: 'MartinDias 4/12/2013 13:27'! = other ^ super = other ifFalse: [ false ] ifTrue: [ self compactClassIndex = other compactClassIndex ]! ! !ObjectLayout methodsFor: 'extending' stamp: 'MartinDias 7/24/2013 13:21'! extend: aScope IncompatibleLayoutConflict new layout: self; subType: #slot; signal! ! !ObjectLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 01:35'! compactClassIndex: anIndex compactClassIndex := anIndex. host setFormat: self format! ! !ObjectLayout methodsFor: 'extending' stamp: 'MartinDias 9/5/2013 15:49'! extend "Answer a default extension of me." ^ self subclassResponsibility! ! !ObjectLayout methodsFor: 'extending' stamp: 'MartinDias 7/24/2013 13:21'! extendWord self hasFields ifTrue: [ IncompatibleLayoutConflict new layout: self; subType: #word; signal ]. ^ WordLayout new! ! !ObjectLayout methodsFor: 'format' stamp: 'MartinDias 7/3/2013 18:00'! format "Answer an Integer that encodes this layout in the way that VM expects it." | fieldSize sizeHiBits format | fieldSize := self fieldSize + 1. sizeHiBits := fieldSize // 64. format := sizeHiBits. format := (format bitShift: 5) + compactClassIndex. format := (format bitShift: 4) + self instanceSpecification. format := (format bitShift: 6) + (fieldSize \\ 64). format := (format bitShift: 1). ^ format! ! !ObjectLayout methodsFor: 'reshaping' stamp: 'CamilloBruni 7/17/2013 13:42'! reshapeTo: aModification ^ self class extending: aModification layout scope: LayoutEmptyScope instance host: self host! ! !ObjectLayout methodsFor: 'diff' stamp: 'ToonVerwaest 4/1/2011 02:22'! computeChangesFrom: other in: modification other hasSlots ifTrue: [ modification removals: other allSlots asArray ]! ! !ObjectLayout class methodsFor: 'instance creation' stamp: 'MartinDias 7/11/2013 16:01'! extending: superLayout scope: aScope host: aClass self subclassResponsibility! ! !ObjectStringConverter commentStamp: 'GaryChambers 3/9/2011 13:37'! Generic object<->string converter for use with PluggableTextFieldMorph. Optional regex matching for validation. Optional transform blocks for each conversion direction.! !ObjectStringConverter methodsFor: 'conversion' stamp: 'GaryChambers 3/9/2011 13:41'! configureForIntegers "Configure the receiver to match/convert positive or negative integers only." self objectClass: Integer; regexString: '[-]?[0-9]+'; stringTransformBlock: [:s | (s beginsWith: '-') ifTrue: ['-', (s select: [:c | c isDigit])] ifFalse: [s select: [:c | c isDigit]]]! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'gvc 7/30/2009 14:09'! objectClass: aClass "Set the class of object we are dealing with." objectClass := aClass! ! !ObjectStringConverter methodsFor: 'conversion' stamp: 'GaryChambers 4/18/2012 18:05'! objectAsString: anObject "Answer the given object in string form." ^(self objectTransformBlock value: anObject) ifNotNil: [:o | o asString]! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'GaryChambers 3/8/2011 11:41'! regex ^ regex! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'GaryChambers 3/8/2011 11:41'! regex: anObject regex := anObject! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'GaryChambers 3/9/2011 13:31'! objectTransformBlock: anObject objectTransformBlock := anObject! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'gvc 9/18/2006 12:10'! objectClass "Answer the class of object we are dealing with." ^objectClass! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'GaryChambers 3/8/2011 11:49'! regexString: aString "Setup the regex based on the given string." self regex: aString asRegex! ! !ObjectStringConverter methodsFor: 'conversion' stamp: 'GaryChambers 4/18/2012 18:09'! stringAsObject: aString "Answer the given string in object form." |transformed| transformed := self stringTransformBlock value: aString. ^(transformed notNil and: [self needsConversion]) ifTrue: [self objectClass readFromString: transformed] ifFalse: [transformed]! ! !ObjectStringConverter methodsFor: 'initialization' stamp: 'GaryChambers 3/9/2011 13:33'! initialize "Initialize the receiver." super initialize. self objectTransformBlock: [:obj | obj]; stringTransformBlock: [:string | string]! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'GaryChambers 3/9/2011 13:31'! objectTransformBlock ^ objectTransformBlock! ! !ObjectStringConverter methodsFor: 'conversion' stamp: 'GaryChambers 3/9/2011 13:42'! configureForPositiveIntegers "Configure the receiver to match/convert positive integers only." self objectClass: Integer; regexString: '[0-9]+'; stringTransformBlock: [:s | s select: [:c | c isDigit]]! ! !ObjectStringConverter methodsFor: 'conversion' stamp: 'GaryChambers 3/8/2011 12:42'! needsConversion "Answer whether conversion is required for the receiver's object class." ^self objectClass notNil and: [(self objectClass includesBehavior: String) not]! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'GaryChambers 3/9/2011 13:31'! stringTransformBlock: anObject stringTransformBlock := anObject! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'GaryChambers 3/9/2011 13:31'! stringTransformBlock ^ stringTransformBlock! ! !ObjectStringConverter methodsFor: 'conversion' stamp: 'GaryChambers 3/8/2011 12:34'! isStringValid: aString "Answer whether the given string is valid for conversion." ^(self regex isNil or: [self regex matches: aString]) and: [ [self stringAsObject: aString. true] on: Error do: [false]]! ! !ObjectStringConverter class methodsFor: 'as yet unclassified' stamp: 'gvc 9/18/2006 12:11'! forClass: aClass "Answer a new instance of the receiver that converts to and from the given class of object and a string." ^self new objectClass: aClass! ! !ObjectTest commentStamp: 'TorstenBergmann 2/5/2014 08:41'! SUnit tests for objects! !ObjectTest methodsFor: 'tests' stamp: 'md 11/26/2004 16:36'! testBecomeForward "self debug: #testBecomeForward" "this test should that all the variables pointing to an object are pointing now to another one. Not that this inverse is not true. This kind of become is called oneWayBecome in VW" | pt1 pt2 pt3 | pt1 := 0@0. pt2 := pt1. pt3 := 100@100. pt1 becomeForward: pt3. self assert: pt2 = (100@100). self assert: pt3 == pt2. self assert: pt1 = (100@100)! ! !ObjectTest methodsFor: 'tests - debugging' stamp: 'SeanDeNigris 8/29/2011 18:04'! testHaltIf self shouldHaltWhen: [self haltIf: true]. self shouldntHaltWhen: [self haltIf: false]. self shouldHaltWhen: [self haltIf: [true]]. self shouldntHaltWhen: [self haltIf: [false]]. self shouldHaltWhen: [self haltIf: #testHaltIf]. self shouldntHaltWhen: [self haltIf: #teadfasdfltIf]. self shouldHaltWhen: [self a]. self shouldntHaltWhen: [self a1]. self shouldHaltWhen: [self haltIf: [:receiver | receiver class = self class]]. self shouldntHaltWhen: [self haltIf: [:receiver | receiver class ~= self class]].! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:46'! a1 self b1.! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:46'! b1 self haltIf: #testasdasdfHaltIf.! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:45'! b self haltIf: #testHaltIf.! ! !ObjectTest methodsFor: 'tests' stamp: 'md 11/26/2004 16:37'! testBecome "self debug: #testBecome" "this test should that all the variables pointing to an object are pointing now to another one, and all object pointing to the other are pointing to the object" | pt1 pt2 pt3 | pt1 := 0@0. pt2 := pt1. pt3 := 100@100. pt1 become: pt3. self assert: pt2 = (100@100). self assert: pt3 = (0@0). self assert: pt1 = (100@100).! ! !ObjectTest methodsFor: 'tests - debugging' stamp: 'CamilloBruni 8/31/2013 20:23'! testHaltOnce | anObject | anObject := Object new. Halt enableHaltOnce. self should: [ anObject haltOnce ] raise: Halt. Halt disableHaltOnce. anObject haltOnce! ! !ObjectTest methodsFor: 'assertions-halt' stamp: 'SeanDeNigris 8/28/2011 17:18'! shouldntHaltWhen: aBlock self shouldnt: aBlock raise: Halt.! ! !ObjectTest methodsFor: 'assertions-halt' stamp: 'SeanDeNigris 8/28/2011 17:22'! shouldHaltAfter: aNumber times: aBlock self shouldHaltWhen: [ aNumber timesRepeat: aBlock ].! ! !ObjectTest methodsFor: 'assertions-halt' stamp: 'SeanDeNigris 8/28/2011 17:18'! shouldHaltWhen: aBlock self should: aBlock raise: Halt.! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:45'! a self b.! ! !ObjectTest methodsFor: 'assertions-halt' stamp: 'SeanDeNigris 8/28/2011 17:23'! shouldntHaltAfter: aNumber times: aBlock self shouldntHaltWhen: [ aNumber timesRepeat: aBlock ].! ! !ObjectTest methodsFor: 'tests - debugging' stamp: 'SeanDeNigris 8/29/2011 18:05'! testHaltOnCount | anObject | anObject := Object new. "Halts regardless of whether HaltOnce is false for the image" Halt disableHaltOnce. self shouldHaltWhen: [ anObject haltOnCount: 1 ]. "Should halt if executed enough times" self shouldHaltAfter: 2 times: [ anObject haltOnCount: 2 ]. "Should not halt if not executed enough times" self shouldntHaltAfter: 2 times: [ anObject haltOnCount: 3 ]. Halt stopCounting. "Should ignore new count given while previous count is in progress" anObject haltOnCount: 2. self shouldHaltWhen: [ anObject haltOnCount: 5 ].! ! !ObjectsAsMethodsExample methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2003 20:16'! answer42 ^42! ! !ObjectsAsMethodsExample methodsFor: 'as yet unclassified' stamp: 'md 3/1/2006 19:37'! run: oldSelector with: arguments in: aReceiver ^self perform: oldSelector withArguments: arguments! ! !ObjectsAsMethodsExample methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2003 20:16'! add: a with: b ^a + b! ! !ObsoleteTest commentStamp: 'SteveFreeman 7/17/2010 11:31'! Example class for ClassTest! !ObsoleteTest methodsFor: 'testing' stamp: 'simon.denier 6/11/2010 14:46'! testClassObsolete | aClass obj | Smalltalk globals at: #ClassForObsoleteTest ifPresent: [ :cls | cls removeFromSystem ]. aClass := Object subclass: #ClassForObsoleteTest. obj := aClass new. self deny: aClass isObsolete. self deny: aClass class isObsolete. aClass removeFromSystem. self assert: aClass isObsolete. self assert: aClass class isObsolete! ! !ObsoleteTest methodsFor: 'testing' stamp: 'simon.denier 6/11/2010 14:46'! testTraitObsolete | aClass obj aTrait | Smalltalk globals at: #ClassForObsoleteTest ifPresent: [ :cls | cls removeFromSystem ]. Smalltalk globals at: #TraitForObsoleteTest ifPresent: [ :tr | tr removeFromSystem ]. aTrait := Trait named: #TraitForObsoleteTest. aClass := Object subclass: #ClassForObsoleteTest uses: {aTrait}. obj := aClass new. self deny: aTrait isObsolete. aTrait removeFromSystem. self assert: aTrait isObsolete. self deny: aClass isObsolete. Smalltalk globals at: #ClassForObsoleteTest ifPresent: [ :cls | cls removeFromSystem ]. Smalltalk globals at: #TraitForObsoleteTest ifPresent: [ :tr | tr removeFromSystem ]. ! ! !OkCancelToolbar commentStamp: ''! An OkCancelToolbar is a model for a basic Ok-Cancel toolbar! !OkCancelToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! cancelAction ^ cancelAction value! ! !OkCancelToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! cancelled ^ cancelled value! ! !OkCancelToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize cancelled := false asReactiveVariable. cancelAction := [ true ] asReactiveVariable. super initialize.! ! !OkCancelToolbar methodsFor: 'accessing' stamp: ''! cancelButton ^ cancelButton! ! !OkCancelToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! cancelAction: aBlock ^ cancelAction value: aBlock! ! !OkCancelToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/27/2013 15:11'! initializePresenter super initializePresenter. cancelButton action: [ self performCancelAction ]! ! !OkCancelToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 15:11'! performCancelAction ^ cancelAction value value == false ifFalse: [ cancelled value: true. owner ifNil: [ self delete ] ifNotNil: [ owner delete ] ]! ! !OkCancelToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/27/2013 15:11'! triggerCancelAction self performCancelAction! ! !OkCancelToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:03'! registerCancelButtonEvents cancelButton label: 'Cancel'; enabled: true; state: false! ! !OkCancelToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:07'! initializeWidgets super initializeWidgets. self instantiateModels: #( cancelButton ButtonModel ). self registerCancelButtonEvents. self focusOrder add: cancelButton! ! !OkCancelToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! cancelled: aBoolean cancelled value: aBoolean! ! !OkCancelToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/6/2013 18:35'! cancel self cancelled: true! ! !OkCancelToolbar class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/17/2013 11:58'! defaultSpec ^ SpecLayout composed add: #okButton origin: 1@0 corner: 1@1 offsetOrigin: (2*(self buttonWidth negated))@0 offsetCorner: (self buttonWidth negated)@0; add: #cancelButton origin: 1@0 corner: 1@1 offsetOrigin: (self buttonWidth negated)@0 offsetCorner: 0@0; send: #vShrinkWrap; yourself! ! !OkCancelToolbar class methodsFor: 'specs' stamp: ''! title ^ 'Ok Cancel'! ! !OkState commentStamp: ''! I am the state showing everything is ok! !OkState methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/26/2013 23:23'! image ^ Smalltalk ui icons smallOkIcon asMorph! ! !OkToolbar commentStamp: ''! An OkCancelToolbar is a model for a basic Ok toolbar! !OkToolbar methodsFor: 'private' stamp: 'IgorStasenko 12/20/2012 14:03'! addAll: aWindow withSpec: aSpec aWindow addMorph: (self buildWithSpec: aSpec) fullFrame: ((0@0 corner: 1@0) asLayoutFrame bottomOffset: 30).! ! !OkToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/26/2013 14:09'! triggerOkAction self okActionBlock value! ! !OkToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:01'! registerOkButtonEvents okButton label: 'Ok'; enabled: true; state: false! ! !OkToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/6/2013 18:48'! triggerCancelAction self cancel! ! !OkToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/6/2013 18:48'! cancel owner ifNil: [ self delete ] ifNotNil: [ owner delete ]! ! !OkToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:02'! initializeWidgets self instantiateModels: #( okButton ButtonModel ). self registerOkButtonEvents. self focusOrder add: okButton! ! !OkToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize super initialize. okAction := [ true ] asReactiveVariable.! ! !OkToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! okAction ^ okAction value! ! !OkToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 4/26/2013 14:09'! initializePresenter okButton action: self okActionBlock! ! !OkToolbar methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! okActionBlock ^ [ okAction value value == false ifFalse: [ owner ifNil: [ self delete ] ifNotNil: [ owner delete ] ] ]! ! !OkToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! okAction: aBlock ^ okAction value: aBlock! ! !OkToolbar methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/10/2012 13:05'! hFill ^ Morph new color: Color transparent; height: 0; vResizing: #rigid; hResizing: #spaceFill! ! !OkToolbar methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:05'! okButton ^ okButton! ! !OkToolbar class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 10/17/2013 11:58'! defaultSpec ^ SpecLayout composed add: #okButton origin: 1@0 corner: 1@1 offsetOrigin: (self buttonWidth negated)@0 offsetCorner: 0@0; send: #vShrinkWrap; yourself! ! !OkToolbar class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 5/10/2012 13:07'! title ^ 'Ok Toolbar'! ! !OldClassBuilderAdapter commentStamp: ''! I am an adapter of a Slot class builder to the traditional class building protocol.! !OldClassBuilderAdapter methodsFor: 'adapted api' stamp: 'MartinDias 8/7/2013 14:10'! name: name inEnvironment: environment subclassOf: superClass type: type instanceVariableNames: instanceVariablesString classVariableNames: classVariablesString poolDictionaries: sharedPoolsString category: category "Define a new class in the given environment" ^ self slotClassInstaller make: [ :builder | builder superclass: superClass; name: name; layoutClass: (self layoutForType: type); slots: instanceVariablesString asSlotCollection; sharedVariables: classVariablesString; sharedPools: sharedPoolsString; category: category; environment: environment; copyTraitCompositionFromExistingClass; copyClassSlotsFromExistingClass ]. ! ! !OldClassBuilderAdapter methodsFor: 'adapted api' stamp: 'CamilloBruni 6/28/2013 14:47'! class: oldClass instanceVariableNames: instVarString "This is the basic initialization message to change the definition of an existing Metaclass" | theClass | theClass := oldClass theNonMetaClass. theClass := self slotClassInstaller make: [ :builder | builder superclass: theClass superclass; name: theClass name; layoutClass: theClass layout class; slots: (theClass instVarNames collect: [:n | n asSlot ]); sharedVariables: theClass classVariablesString; sharedPools: theClass sharedPoolsString; traitComposition: theClass traitComposition; category: theClass category asString; classSlots: instVarString asSlotCollection ]. ^ theClass theMetaClass! ! !OldClassBuilderAdapter methodsFor: 'adapted api' stamp: 'MartinDias 6/14/2013 18:11'! superclass: newSuper subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class." ^self name: t inEnvironment: newSuper environment subclassOf: newSuper type: newSuper typeOfClass instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !OldClassBuilderAdapter methodsFor: 'adapted api' stamp: 'MartinDias 6/14/2013 18:00'! superclass: aClass variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class in which the subclass is to have indexable pointer variables." aClass isBits ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. ^self name: t inEnvironment: aClass environment subclassOf: aClass type: #variable instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !OldClassBuilderAdapter methodsFor: 'adapted api' stamp: 'MartinDias 6/14/2013 17:58'! superclass: aClass weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class (the receiver) in which the subclass is to have weak indexable pointer variables." aClass isBits ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. ^self name: t inEnvironment: aClass environment subclassOf: aClass type: #weak instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !OldClassBuilderAdapter methodsFor: 'accessing' stamp: 'MartinDias 12/9/2013 11:38'! layoutForType: typeSymbol typeSymbol = #compiledMethod ifTrue: [ ^ CompiledMethodLayout ]. typeSymbol = #bytes ifTrue: [ ^ ByteLayout ]. typeSymbol = #words ifTrue: [ ^ WordLayout ]. typeSymbol = #weak ifTrue: [ ^ WeakLayout ]. typeSymbol = #variable ifTrue: [ ^ VariableLayout ]. typeSymbol = #normal ifTrue: [ ^ FixedLayout ]. Error signal: 'Invalid layout type: ', typeSymbol asString.! ! !OldClassBuilderAdapter methodsFor: 'accessing' stamp: 'MartinDias 7/1/2013 18:36'! anonymousClassInstaller ^ AnonymousClassInstaller! ! !OldClassBuilderAdapter methodsFor: 'adapted api' stamp: 'MarcusDenker 9/14/2013 10:28'! becomeCompact: aClass "Make the class compact. This means: - to find a free slot in 'Smalltalk compactClassArray' - add the class in that array - update the format of the class with the index - update the instances of the class " | compactClassesArray index | aClass isWeak ifTrue: [^ self error: 'You must not make a weak class compact']. compactClassesArray := Smalltalk compactClassesArray. (aClass isCompact or: [compactClassesArray includes: aClass]) ifTrue: [^ self error: aClass name , 'is already compact']. index := compactClassesArray indexOf: nil ifAbsent: [^ self error: 'compact class table is full']. "Install this class in the compact class table" compactClassesArray at: index put: aClass. "Update instspec so instances will be compact. The layout has the responsibility for setting the format." aClass layout compactClassIndex: index. "Make up new instances and become old ones into them" aClass updateInstancesFrom: aClass. "Purge any old instances" Smalltalk garbageCollect.! ! !OldClassBuilderAdapter methodsFor: 'adapted api' stamp: 'MartinDias 6/14/2013 18:01'! superclass: aClass variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class in which the subclass is to have indexable byte-sized nonpointer variables." | oldClassOrNil actualType | (aClass instSize > 0) ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields']. (aClass isVariable and: [aClass isWords]) ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields']. (aClass isVariable and: [aClass isPointers]) ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields']. oldClassOrNil := aClass environment at: t ifAbsent:[nil]. actualType := (oldClassOrNil notNil and: [oldClassOrNil typeOfClass == #compiledMethod]) ifTrue: [#compiledMethod] ifFalse: [#bytes]. ^self name: t inEnvironment: aClass environment subclassOf: aClass type: actualType instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !OldClassBuilderAdapter methodsFor: 'accessing' stamp: 'MartinDias 6/14/2013 17:42'! slotClassInstaller ^ PharoClassInstaller! ! !OldClassBuilderAdapter methodsFor: 'adapted api' stamp: 'MarcusDenker 9/14/2013 10:28'! becomeCompact: aClass simplyAt: index "The same as #becomeCompact: but without updating the instances." | compactClassesArray | aClass isWeak ifTrue: [^ self error: 'You must not make a weak class compact']. compactClassesArray := Smalltalk compactClassesArray. (aClass isCompact or: [compactClassesArray includes: aClass]) ifTrue: [^ self error: aClass name, 'is already compact']. (compactClassesArray at: index) ifNotNil: [^ self error: 'compact table slot already in use']. "Install this class in the compact class table" compactClassesArray at: index put: aClass. "Update instspec so instances will be compact. The layout has the responsibility for setting the format." aClass layout compactClassIndex: index.! ! !OldClassBuilderAdapter methodsFor: 'adapted api' stamp: 'MartinDias 7/1/2013 18:36'! anonymousSubclassOf: superClass "Answer an anonymous subclass of the given superclass." ^ self anonymousClassInstaller make: [ :builder | builder superclass: superClass; layoutClass: superClass layout class ]. ! ! !OldClassBuilderAdapter methodsFor: 'adapted api' stamp: 'MarcusDenker 9/12/2013 16:38'! becomeUncompact: aClass "The inverse of #becomeCompact. However, some classes can not be uncompact: see #checkCanBeUncompact." | compactClassesArray index | compactClassesArray := Smalltalk compactClassesArray. (index := aClass indexIfCompact) = 0 ifTrue: [^ self]. self assert:[compactClassesArray includes: aClass]. aClass checkCanBeUncompact. "Update instspec so instances will be compact. The layout has the responsibility for setting the format." aClass layout compactClassIndex: 0. "Make up new instances and become old ones into them" aClass updateInstancesFrom: aClass. "Make sure there are no compact ones left around" Smalltalk garbageCollect. "Remove this class from the compact class table" compactClassesArray at: index put: nil. ! ! !OldClassBuilderAdapter methodsFor: 'adapted api' stamp: 'MartinDias 6/14/2013 17:59'! superclass: aClass variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat "This is the standard initialization message for creating a new class as a subclass of an existing class in which the subclass is to have indexable word-sized nonpointer variables." (aClass instSize > 0) ifTrue: [^self error: 'cannot make a word subclass of a class with named fields']. (aClass isVariable and: [aClass isBytes]) ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields']. (aClass isVariable and: [aClass isPointers]) ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields']. ^self name: t inEnvironment: aClass environment subclassOf: aClass type: #words instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !OpalCompiler commentStamp: ''! I provide the API of the whole Compiler Package. -> parsing: just parse -> translate: parse and generate code so we get all error messages -> compile: translate but return the CompiledMethod ! !OpalCompiler methodsFor: 'private' stamp: 'GiselaDecuzzi 6/11/2013 14:41'! parseExpression | parseClass | parseClass := self compilationContext parserClass. ^self useFaultyForParsing ifTrue: [parseClass parseFaultyExpression: source contents] ifFalse: [parseClass parseExpression: source contents]! ! !OpalCompiler methodsFor: 'public access' stamp: 'IgorStasenko 8/28/2013 10:36'! translate [ self compile ] on: ReparseAfterSourceEditing do: [ :ex | self source: ex newSource readStream. self compile ] . ^ ast! ! !OpalCompiler methodsFor: 'accessing' stamp: 'ClementBera 6/7/2013 09:58'! compiledMethodTrailer: bytes self compilationContext compiledMethodTrailer: bytes! ! !OpalCompiler methodsFor: '*Deprecated30' stamp: 'MarcusDenker 10/11/2013 10:31'! decompileMethod: aCompiledMethod self deprecated: 'decompiling bc->text is not supported'. ^self parse: aCompiledMethod codeForNoSource. ! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:55'! logged: aBoolean self compilationContext logged: aBoolean.! ! !OpalCompiler methodsFor: 'accessing' stamp: 'GiselaDecuzzi 6/11/2013 13:55'! useFaultyForParsing: anObject useFaultyForParsing := anObject! ! !OpalCompiler methodsFor: 'public access' stamp: 'BenComan 3/3/2014 14:56'! compile | cm | [ [ ast := self parse. self doSemanticAnalysis. ] on: OCSourceCodeChanged do: [ :notification | self source: notification newSourceCode. notification retry. ]. cm := ast generate: self compilationContext compiledMethodTrailer ] on: SyntaxErrorNotification do: [ :exception | self compilationContext requestor ifNotNil: [ self compilationContext requestor notify: exception errorMessage , ' ->' at: exception location in: exception errorCode. ^ self compilationContext failBlock value ] ifNil: [ exception pass ]]. ^cm! ! !OpalCompiler methodsFor: 'public access' stamp: 'MarcusDenker 5/26/2013 09:55'! options: anOptionsArray self compilationContext parseOptions: anOptionsArray! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:50'! environment: anSmallTalkImage self compilationContext environment: anSmallTalkImage ! ! !OpalCompiler methodsFor: 'public access' stamp: 'MarcusDenker 9/5/2013 15:35'! compile: textOrString ^self source: textOrString; compile.! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:51'! requestor: aRequestor self compilationContext requestor: aRequestor. self compilationContext interactive: (UIManager default interactiveParserFor: self compilationContext requestor).! ! !OpalCompiler methodsFor: 'accessing' stamp: 'ClementBera 6/7/2013 09:49'! failBlock: aBlock self compilationContext failBlock: aBlock.! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:53'! compilationContextClass: aClass compilationContextClass := aClass.! ! !OpalCompiler methodsFor: 'private' stamp: 'ClementBera 6/7/2013 09:49'! doSemanticAnalysis ^[ast doSemanticAnalysisInContext: self compilationContext] on: OCSemanticError do: [ :ex | ex defaultAction. ^ self compilationContext failBlock value ]! ! !OpalCompiler methodsFor: 'public access' stamp: 'GiselaDecuzzi 6/11/2013 14:39'! parse | expression selector arguments method | self compilationContext noPattern ifFalse: [^self parseMethod]. expression := (self parseExpression) asSequenceNode transformLastToReturn. context ifNil: [selector := #DoIt. arguments := #()] ifNotNil: [selector := #DoItIn:. arguments := {(RBVariableNode named:'ThisContext')}]. method := RBMethodNode selector: selector arguments: arguments body: expression. context ifNotNil: [context tempNames do: [:tempName | method :=method rewriteTempNamedWrite: tempName forContext: context. method :=method rewriteTempNamedRead: tempName forContext: context. ]]. ^method ! ! !OpalCompiler methodsFor: 'accessing' stamp: 'ClementBera 6/7/2013 09:59'! context: aContext context := aContext! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:55'! noPattern: aBoolean self compilationContext noPattern: aBoolean. ! ! !OpalCompiler methodsFor: 'public access' stamp: 'MarcusDenker 6/14/2013 15:48'! parseLiterals: aString ^RBExplicitVariableParser parseLiterals: aString! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 5/12/2013 11:20'! receiver: anObject receiver := anObject.! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 6/17/2013 12:51'! compilationContext ^ compilationContext ifNil: [ compilationContext := self compilationContextClass default ]! ! !OpalCompiler methodsFor: 'private' stamp: 'GiselaDecuzzi 6/11/2013 14:36'! parseMethod | parseClass | parseClass := self compilationContext parserClass. ^self useFaultyForParsing ifTrue: [parseClass parseFaultyMethod: source contents] ifFalse: [parseClass parseMethod: source contents]! ! !OpalCompiler methodsFor: 'public access' stamp: 'MarcusDenker 8/28/2013 10:31'! format: textOrString ^self source: textOrString; format! ! !OpalCompiler methodsFor: 'public access' stamp: 'MarcusDenker 8/28/2013 15:31'! parse: textOrString ^self source: textOrString; parse! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 7/5/2013 15:41'! class: aClass self compilationContext class: aClass.! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:36'! compilationContextClass ^compilationContextClass ifNil: [ CompilationContext ]! ! !OpalCompiler methodsFor: 'public access' stamp: 'MarcusDenker 1/5/2014 10:55'! evaluate "Compiles the sourceStream into a parse tree, then generates code into a method. If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is invoked from here via withArgs:executeMethod:, hence the system no longer creates Doit method litter on errors." | value selectedSource itsSelection itsSelectionString | self class: (context ifNil: [ receiver class ] ifNotNil: [ context method methodClass ]). self noPattern: true. selectedSource := ((self compilationContext requestor respondsTo: #selection) and: [ (itsSelection := self compilationContext requestor selection) notNil and: [ (itsSelectionString := itsSelection asString) isEmptyOrNil not ] ]) ifTrue: [ itsSelectionString ] ifFalse: [ source ]. self source: selectedSource. value := receiver withArgs: (context ifNil: [ #() ] ifNotNil: [ {context} ]) executeMethod: self translate generateWithSource. self compilationContext logged ifTrue: [ SystemAnnouncer uniqueInstance evaluated: selectedSource contents context: context ]. ^ value! ! !OpalCompiler methodsFor: 'public access' stamp: 'MarcusDenker 4/27/2013 19:40'! format ^self parse formattedCode.! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 5/13/2013 14:36'! compilationContext: anObject compilationContext := anObject! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 4/27/2013 12:45'! source: aString source := aString readStream.! ! !OpalCompiler methodsFor: 'accessing' stamp: 'GiselaDecuzzi 6/11/2013 13:56'! useFaultyForParsing ^ useFaultyForParsing ifNil: [ useFaultyForParsing := false ]! ! !OpalCompiler methodsFor: 'public access' stamp: 'MarcusDenker 6/14/2013 15:48'! parseSelector: aString "Answer the message selector for the argument, aString, which should parse successfully up to the temporary declaration or the end of the method header." ^[RBExplicitVariableParser parseMethodPattern: aString] on: Error do: [nil].! ! !OpalCompiler methodsFor: 'accessing' stamp: 'MarcusDenker 5/26/2013 09:49'! category: aCategory self compilationContext category: aCategory.! ! !OpalCompiler class methodsFor: 'options' stamp: 'ClementBera 11/26/2013 13:20'! defaultOptions ^ #( "by default we inline all optimized constructs" + optionInlineIf + optionInlineIfNil + optionInlineAndOr + optionInlineWhile + optionInlineToDo + optionInlineCase - optionInlineTimesRepeat - optionIlineNone "to turn off all. Overrides the others" - optionLongIvarAccessBytecodes "special for Contexts" + optionOptimizeIR )! ! !OpalCompiler class methodsFor: '*Deprecated30' stamp: 'MarcusDenker 10/11/2013 10:23'! decompileMethod: aCompiledMethod self deprecated: 'decompiling not supported' on: '09 May 2013' in: 'Pharo 3.0'. ^self new decompileMethod: aCompiledMethod! ! !OpalCompiler class methodsFor: 'old - public' stamp: 'MarcusDenker 4/27/2013 21:27'! format: textOrStream in: aClass notifying: aRequestor ^self new source: textOrStream; class: aClass; requestor: aRequestor; format ! ! !OpalCompiler class methodsFor: 'old - public' stamp: 'MarcusDenker 4/27/2013 22:23'! evaluate: textOrString logged: logFlag "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor. Compilation is carried out with respect to nil, i.e., no object." ^ self new source: textOrString; logged: logFlag; evaluate ! ! !OpalCompiler class methodsFor: 'public' stamp: 'MarcusDenker 11/16/2012 15:35'! debuggerMethodMapForMethod: aMethod ^ DebuggerMethodMapOpal forMethod: aMethod! ! !OpalCompiler class methodsFor: 'old - public' stamp: 'MarcusDenker 4/27/2013 22:23'! evaluate: textOrString for: anObject notifying: aController logged: logFlag "Compile and execute the argument, textOrString with respect to the class of anObject. If a compilation error occurs, notify aController. If both compilation and execution are successful then, if logFlag is true, log (write) the text onto a system changes file so that it can be replayed if necessary." ^ self new source: textOrString; logged: logFlag; receiver: anObject; requestor: aController; evaluate ! ! !OpalCompiler class methodsFor: 'old - public' stamp: 'MarcusDenker 4/27/2013 22:23'! evaluate: textOrString notifying: aController logged: logFlag "See Compiler|evaluate:for:notifying:logged:. Compilation is carried out with respect to nil, i.e., no object." ^ self new source: textOrString; logged: logFlag; requestor: aController; evaluate ! ! !OpalCompiler class methodsFor: '*Deprecated30' stamp: 'MarcusDenker 5/18/2013 16:42'! decompilerClass self deprecated: 'use #compilerClass' on: '02 May 2013' in: 'Pharo 3.0'. ^self! ! !OpalCompiler class methodsFor: 'public' stamp: 'MarcusDenker 10/1/2013 14:22'! recompileAll "Recompile all classes and traits in the system." Smalltalk image recompile ! ! !OpalCompiler class methodsFor: 'old - public' stamp: 'MarcusDenker 4/30/2013 10:28'! evaluate: textOrString ^self new source: textOrString; evaluate! ! !OpalCompiler class methodsFor: '*Deprecated30' stamp: 'MarcusDenker 10/11/2013 10:23'! decompile: aSelector in: aClass self deprecated: 'decompiling not supported' on: '09 May 2013' in: 'Pharo 3.0'. ^self new decompile: aSelector in: aClass ! ! !OpalCompiler class methodsFor: '*Deprecated30' stamp: 'MarcusDenker 10/11/2013 10:23'! decompile: aSelector in: aClass method: aMethod self deprecated: 'decompiling not supported' on: '09 May 2013' in: 'Pharo 3.0'. ^self new decompile: aSelector in: aClass method: aMethod! ! !OpalCompiler class methodsFor: 'public' stamp: 'MarcusDenker 5/23/2013 07:47'! isActive ^Smalltalk compilerClass == self! ! !OpalCompiler class methodsFor: 'old - public' stamp: 'MarcusDenker 4/27/2013 21:29'! evaluate: textOrString for: anObject logged: logFlag "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor." ^self new source: textOrString; logged: logFlag; receiver: anObject; evaluate! ! !OpenSansRegular commentStamp: ''! http://www.google.com/fonts/specimen/Open+Sans Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.! !OpenSansRegular class methodsFor: 'accessing' stamp: 'IgorStasenko 4/8/2014 16:47'! fontContents ^#[0 1 0 0 0 19 1 0 0 4 0 48 68 83 73 71 158 18 68 29 0 3 59 156 0 0 21 116 71 68 69 70 0 38 3 175 0 3 55 124 0 0 0 30 71 80 79 83 11 55 15 55 0 3 55 156 0 0 0 56 71 83 85 66 14 43 61 183 0 3 55 212 0 0 3 198 79 83 47 50 161 62 158 201 0 0 1 184 0 0 0 96 99 109 97 112 41 171 47 104 0 0 16 180 0 0 4 26 99 118 116 32 15 77 24 164 0 0 29 144 0 0 0 162 102 112 103 109 126 97 182 17 0 0 20 208 0 0 7 180 103 97 115 112 0 21 0 35 0 3 55 108 0 0 0 16 103 108 121 102 116 56 153 75 0 0 37 140 0 1 47 180 104 101 97 100 247 118 226 166 0 0 1 60 0 0 0 54 104 104 101 97 13 204 9 115 0 0 1 116 0 0 0 36 104 109 116 120 232 53 60 221 0 0 2 24 0 0 14 154 107 101 114 110 84 43 9 126 0 1 85 64 0 1 182 54 108 111 99 97 41 20 220 241 0 0 30 52 0 0 7 86 109 97 120 112 5 67 2 10 0 0 1 152 0 0 0 32 110 97 109 101 115 176 136 133 0 3 11 120 0 0 5 199 112 111 115 116 2 67 239 108 0 3 17 64 0 0 38 43 112 114 101 112 67 183 150 164 0 0 28 132 0 0 1 9 0 1 0 0 0 1 25 154 33 199 245 95 95 15 60 245 0 9 8 0 0 0 0 0 201 53 49 139 0 0 0 0 201 232 76 76 251 154 253 213 9 162 8 98 0 0 0 9 0 2 0 0 0 0 0 0 0 1 0 0 8 141 253 168 0 0 9 172 251 154 254 123 9 162 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 163 0 1 0 0 3 170 0 138 0 22 0 86 0 5 0 2 0 16 0 47 0 92 0 0 1 14 0 248 0 3 0 1 0 3 4 182 1 144 0 5 0 8 5 154 5 51 0 0 1 31 5 154 5 51 0 0 3 209 0 102 1 241 8 2 2 11 6 6 3 5 4 2 2 4 224 0 2 239 64 0 32 91 0 0 0 40 0 0 0 0 49 65 83 67 0 64 0 32 255 253 6 31 254 20 0 132 8 141 2 88 32 0 1 159 0 0 0 0 4 72 5 182 0 0 0 32 0 3 4 205 0 193 0 0 0 0 4 20 0 0 2 20 0 0 2 35 0 152 3 53 0 133 5 43 0 51 4 147 0 131 6 150 0 104 5 215 0 113 1 197 0 133 2 94 0 82 2 94 0 61 4 106 0 86 4 147 0 104 1 246 0 63 2 147 0 84 2 33 0 152 2 240 0 20 4 147 0 102 4 147 0 188 4 147 0 100 4 147 0 94 4 147 0 43 4 147 0 133 4 147 0 117 4 147 0 94 4 147 0 104 4 147 0 106 2 33 0 152 2 33 0 63 4 147 0 104 4 147 0 119 4 147 0 104 3 111 0 27 7 49 0 121 5 16 0 0 5 47 0 201 5 12 0 125 5 213 0 201 4 115 0 201 4 33 0 201 5 211 0 125 5 231 0 201 2 170 0 84 2 35 255 96 4 233 0 201 4 39 0 201 7 57 0 201 6 8 0 201 6 59 0 125 4 209 0 201 6 59 0 125 4 242 0 201 4 100 0 106 4 109 0 18 5 211 0 186 4 195 0 0 7 104 0 27 4 158 0 8 4 123 0 0 4 145 0 82 2 162 0 166 2 240 0 23 2 162 0 51 4 86 0 49 3 150 255 252 4 158 1 137 4 115 0 94 4 231 0 176 3 207 0 115 4 231 0 115 4 125 0 115 2 182 0 29 4 98 0 39 4 233 0 176 2 6 0 162 2 6 255 145 4 51 0 176 2 6 0 176 7 113 0 176 4 233 0 176 4 213 0 115 4 231 0 176 4 231 0 115 3 68 0 176 3 209 0 106 2 211 0 31 4 233 0 164 4 2 0 0 6 57 0 23 4 49 0 39 4 8 0 2 3 190 0 82 3 8 0 61 4 104 1 238 3 8 0 72 4 147 0 104 2 20 0 0 2 35 0 152 4 147 0 190 4 147 0 63 4 147 0 123 4 147 0 31 4 104 1 238 4 33 0 123 4 158 1 53 6 168 0 100 2 213 0 70 3 250 0 82 4 147 0 104 2 147 0 84 6 168 0 100 4 0 255 250 3 109 0 127 4 147 0 104 2 199 0 49 2 199 0 33 4 158 1 137 4 244 0 176 5 61 0 113 2 33 0 152 1 209 0 37 2 199 0 76 3 0 0 66 3 250 0 80 6 61 0 75 6 61 0 46 6 61 0 26 3 111 0 51 5 16 0 0 5 16 0 0 5 16 0 0 5 16 0 0 5 16 0 0 5 16 0 0 6 252 255 254 5 12 0 125 4 115 0 201 4 115 0 201 4 115 0 201 4 115 0 201 2 170 0 60 2 170 0 84 2 170 255 255 2 170 0 60 5 199 0 47 6 8 0 201 6 59 0 125 6 59 0 125 6 59 0 125 6 59 0 125 6 59 0 125 4 147 0 133 6 59 0 125 5 211 0 186 5 211 0 186 5 211 0 186 5 211 0 186 4 123 0 0 4 227 0 201 4 250 0 176 4 115 0 94 4 115 0 94 4 115 0 94 4 115 0 94 4 115 0 94 4 115 0 94 6 221 0 94 3 207 0 115 4 125 0 115 4 125 0 115 4 125 0 115 4 125 0 115 2 6 255 218 2 6 0 169 2 6 255 179 2 6 255 236 4 197 0 113 4 233 0 176 4 213 0 115 4 213 0 115 4 213 0 115 4 213 0 115 4 213 0 115 4 147 0 104 4 213 0 115 4 233 0 164 4 233 0 164 4 233 0 164 4 233 0 164 4 8 0 2 4 231 0 176 4 8 0 2 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 5 12 0 125 3 207 0 115 5 12 0 125 3 207 0 115 5 12 0 125 3 207 0 115 5 12 0 125 3 207 0 115 5 213 0 201 4 231 0 115 5 199 0 47 4 231 0 115 4 115 0 201 4 125 0 115 4 115 0 201 4 125 0 115 4 115 0 201 4 125 0 115 4 115 0 201 4 125 0 115 4 115 0 201 4 125 0 115 5 211 0 125 4 98 0 39 5 211 0 125 4 98 0 39 5 211 0 125 4 98 0 39 5 211 0 125 4 98 0 39 5 231 0 201 4 233 0 176 5 231 0 0 4 233 0 20 2 170 255 226 2 6 255 144 2 170 0 42 2 6 255 218 2 170 0 30 2 6 255 204 2 170 0 84 2 6 0 53 2 170 0 84 2 6 0 176 4 205 0 84 4 12 0 162 2 35 255 96 2 6 255 145 4 233 0 201 4 51 0 176 4 37 0 176 4 39 0 201 2 6 0 163 4 39 0 201 2 6 0 89 4 39 0 201 2 6 0 176 4 39 0 201 2 131 0 176 4 47 0 29 2 23 255 252 6 8 0 201 4 233 0 176 6 8 0 201 4 233 0 176 6 8 0 201 4 233 0 176 5 115 0 1 6 8 0 201 4 233 0 176 6 59 0 125 4 213 0 115 6 59 0 125 4 213 0 115 6 59 0 125 4 213 0 115 7 98 0 125 7 137 0 113 4 242 0 201 3 68 0 176 4 242 0 201 3 68 0 96 4 242 0 201 3 68 0 130 4 100 0 106 3 209 0 106 4 100 0 106 3 209 0 106 4 100 0 106 3 209 0 106 4 100 0 106 3 209 0 106 4 109 0 18 2 211 0 31 4 109 0 18 2 211 0 31 4 109 0 18 2 211 0 31 5 211 0 186 4 233 0 164 5 211 0 186 4 233 0 164 5 211 0 186 4 233 0 164 5 211 0 186 4 233 0 164 5 211 0 186 4 233 0 164 5 211 0 186 4 233 0 164 7 104 0 27 6 57 0 23 4 123 0 0 4 8 0 2 4 123 0 0 4 145 0 82 3 190 0 82 4 145 0 82 3 190 0 82 4 145 0 82 3 190 0 82 2 143 0 176 4 158 0 195 5 20 0 0 4 115 0 94 6 252 255 254 6 221 0 94 6 59 0 125 4 213 0 115 4 100 0 106 3 209 0 106 4 188 1 12 4 188 1 12 4 178 1 45 4 188 1 37 2 6 0 162 4 158 1 111 1 147 0 37 4 188 1 8 4 158 0 231 4 158 1 252 4 158 1 27 5 16 0 0 2 33 0 152 4 242 255 212 6 125 255 212 3 152 255 228 6 129 255 228 5 133 255 212 6 129 255 228 2 182 255 233 5 16 0 0 5 47 0 201 4 41 0 201 4 147 0 39 4 115 0 201 4 145 0 82 5 231 0 201 6 59 0 125 2 170 0 84 4 233 0 201 4 211 0 0 7 57 0 201 6 8 0 201 4 109 0 72 6 59 0 125 5 213 0 201 4 209 0 201 4 137 0 74 4 109 0 18 4 123 0 0 6 98 0 106 4 158 0 8 6 94 0 109 6 66 0 80 2 170 0 60 4 123 0 0 4 227 0 115 3 205 0 90 4 233 0 176 2 182 0 168 4 223 0 164 4 227 0 115 5 6 0 176 4 25 0 10 4 164 0 113 3 205 0 90 3 221 0 115 4 233 0 176 4 188 0 115 2 182 0 168 4 37 0 176 4 70 255 242 4 244 0 176 4 86 0 0 3 205 0 113 4 213 0 115 5 51 0 25 4 213 0 166 3 219 0 115 4 231 0 115 3 201 0 18 4 223 0 164 5 190 0 115 4 94 255 236 6 6 0 164 6 47 0 115 2 182 0 9 4 223 0 164 4 213 0 115 4 223 0 164 6 47 0 115 4 115 0 201 5 223 0 18 4 41 0 201 5 29 0 125 4 100 0 106 2 170 0 84 2 170 0 60 2 35 255 96 7 111 0 0 7 160 0 201 5 223 0 18 4 229 0 201 4 248 0 27 5 213 0 201 5 16 0 0 4 231 0 201 5 47 0 201 4 41 0 201 5 119 0 14 4 115 0 201 6 193 0 2 4 166 0 74 6 25 0 203 6 25 0 203 4 229 0 201 5 162 0 0 7 57 0 201 5 231 0 201 6 59 0 125 5 213 0 201 4 209 0 201 5 12 0 125 4 109 0 18 4 248 0 27 6 98 0 106 4 158 0 8 5 229 0 201 5 143 0 170 8 66 0 201 8 68 0 201 5 129 0 18 6 211 0 201 5 37 0 201 5 10 0 61 8 102 0 201 5 23 0 51 4 115 0 94 4 197 0 119 4 141 0 176 3 109 0 176 4 147 0 41 4 125 0 115 5 227 0 4 3 221 0 68 5 18 0 176 5 18 0 176 4 39 0 176 4 145 0 16 5 225 0 176 5 18 0 176 4 213 0 115 4 248 0 176 4 231 0 176 3 207 0 115 3 188 0 41 4 8 0 2 5 184 0 113 4 49 0 39 5 2 0 176 4 221 0 156 7 31 0 176 7 45 0 176 5 143 0 41 6 41 0 176 4 188 0 176 3 240 0 57 6 166 0 176 4 113 0 37 4 125 0 115 4 233 0 20 3 109 0 176 3 240 0 115 3 209 0 106 2 6 0 162 2 6 255 236 2 6 255 145 6 178 0 16 7 23 0 176 4 233 0 20 4 39 0 176 4 8 0 2 4 248 0 176 4 55 0 201 3 109 0 176 7 104 0 27 6 57 0 23 7 104 0 27 6 57 0 23 7 104 0 27 6 57 0 23 4 123 0 0 4 8 0 2 4 0 0 82 8 0 0 82 8 0 0 82 3 74 255 252 1 92 0 25 1 92 0 25 1 246 0 63 1 92 0 25 2 205 0 25 2 205 0 25 3 61 0 25 4 4 0 123 4 20 0 123 3 2 0 164 6 70 0 152 9 158 0 100 1 197 0 133 3 37 0 133 2 111 0 82 2 111 0 80 3 227 0 152 1 10 254 121 3 39 0 109 4 147 0 98 4 147 0 68 6 27 0 154 4 184 0 63 6 152 0 141 4 41 0 119 8 39 0 201 6 53 0 37 6 66 0 80 4 244 0 102 6 61 0 71 6 61 0 32 6 61 0 71 6 61 0 106 4 166 0 102 4 147 0 39 5 233 0 201 5 12 0 76 4 147 0 104 4 100 0 37 5 164 0 119 3 18 0 12 4 147 0 98 4 147 0 104 4 147 0 104 4 147 0 104 4 170 0 111 4 188 0 29 4 188 0 29 4 158 0 219 2 6 255 145 4 0 1 137 4 0 1 113 4 0 1 129 2 199 0 39 2 199 0 20 2 199 0 59 2 199 0 41 2 199 0 57 2 199 0 51 2 199 0 35 4 0 0 0 8 0 0 0 4 0 0 0 8 0 0 0 2 170 0 0 2 0 0 0 1 86 0 0 4 121 0 0 2 33 0 0 1 154 0 0 0 205 0 0 0 0 0 0 0 0 0 0 8 0 0 84 8 0 0 84 2 6 255 145 1 92 0 25 4 250 0 10 4 133 0 0 6 184 0 18 7 57 0 201 7 113 0 176 5 16 0 0 4 115 0 94 6 82 254 223 2 170 0 117 3 51 0 152 7 117 0 29 7 117 0 29 6 61 0 125 4 223 0 115 6 37 0 186 5 82 0 164 0 0 252 83 0 0 253 13 0 0 252 25 0 0 253 8 0 0 253 59 4 115 0 201 6 25 0 203 4 125 0 115 5 18 0 176 8 23 0 133 6 141 0 0 5 102 0 23 5 14 0 23 7 90 0 201 5 227 0 176 5 109 0 0 4 131 0 10 7 94 0 201 6 33 0 176 5 197 0 20 5 35 0 12 7 203 0 201 6 197 0 176 4 168 0 63 3 221 0 25 6 94 0 109 6 6 0 164 6 61 0 125 4 213 0 115 5 2 0 0 4 12 0 0 5 2 0 0 4 12 0 0 9 172 0 125 8 125 0 115 6 141 0 125 5 66 0 115 7 254 0 125 6 119 0 115 7 223 0 94 6 141 0 0 5 29 0 125 3 231 0 115 4 223 0 106 4 117 0 203 4 158 0 248 4 158 1 223 4 158 1 225 7 233 0 41 7 166 0 41 6 41 0 201 5 37 0 176 4 231 0 47 4 188 0 20 4 227 0 201 4 231 0 176 4 55 0 47 3 109 0 18 5 35 0 201 4 51 0 176 7 31 0 2 6 61 0 4 4 166 0 74 3 221 0 68 5 74 0 201 4 92 0 176 4 233 0 201 4 68 0 176 4 233 0 47 4 35 0 20 5 131 0 16 4 236 0 41 5 248 0 201 5 47 0 176 6 129 0 201 5 227 0 176 8 137 0 201 6 236 0 176 6 59 0 125 5 31 0 115 5 12 0 125 3 207 0 115 4 109 0 16 3 188 0 41 4 123 0 0 4 2 0 0 4 123 0 0 4 2 0 0 4 244 0 8 4 86 0 39 6 215 0 16 5 188 0 41 5 137 0 170 4 223 0 156 5 143 0 170 4 205 0 156 5 143 0 201 4 174 0 176 6 180 0 61 5 70 0 51 6 180 0 61 5 70 0 51 2 170 0 84 6 193 0 2 5 227 0 4 5 131 0 201 4 100 0 176 5 166 0 0 4 147 0 16 5 209 0 201 4 238 0 176 5 246 0 201 5 57 0 176 5 143 0 170 4 221 0 156 7 59 0 201 5 227 0 176 2 170 0 84 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 6 252 255 254 6 221 0 94 4 115 0 201 4 125 0 115 5 215 0 117 4 121 0 102 5 215 0 117 4 121 0 102 6 193 0 2 5 227 0 4 4 166 0 74 3 221 0 68 4 170 0 74 3 233 0 27 6 25 0 203 5 18 0 176 6 25 0 203 5 18 0 176 6 59 0 125 4 213 0 115 6 61 0 125 4 213 0 115 6 61 0 125 4 213 0 115 5 10 0 61 3 240 0 57 4 248 0 27 4 8 0 2 4 248 0 27 4 8 0 2 4 248 0 27 4 8 0 2 5 143 0 170 4 221 0 156 4 55 0 201 3 109 0 176 6 211 0 201 6 41 0 176 4 55 0 47 3 109 0 18 4 248 0 8 4 82 0 39 4 158 0 6 4 49 0 39 4 231 0 131 4 231 0 115 7 49 0 131 7 43 0 115 7 59 0 78 6 106 0 80 5 0 0 78 4 47 0 80 7 217 0 0 6 207 0 16 8 25 0 201 7 78 0 176 6 12 0 125 5 31 0 115 5 174 0 16 5 45 0 41 4 170 0 111 3 205 0 90 5 154 0 0 4 145 0 16 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 45 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 5 16 0 0 4 115 0 94 4 115 0 201 4 125 0 115 4 115 0 201 4 125 0 115 4 115 0 201 4 125 0 115 4 115 0 201 4 125 0 115 4 115 0 93 4 125 0 74 4 115 0 201 4 125 0 115 4 115 0 201 4 125 0 115 4 115 0 201 4 125 0 115 2 170 0 84 2 6 0 123 2 170 0 84 2 6 0 157 6 59 0 125 4 213 0 115 6 59 0 125 4 213 0 115 6 59 0 125 4 213 0 115 6 59 0 125 4 213 0 97 6 59 0 125 4 213 0 115 6 59 0 125 4 213 0 115 6 59 0 125 4 213 0 115 6 61 0 125 4 223 0 115 6 61 0 125 4 223 0 115 6 61 0 125 4 223 0 115 6 61 0 125 4 223 0 115 6 61 0 125 4 223 0 115 5 211 0 186 4 233 0 164 5 211 0 186 4 233 0 164 6 37 0 186 5 82 0 164 6 37 0 186 5 82 0 164 6 37 0 186 5 82 0 164 6 37 0 186 5 82 0 164 6 37 0 186 5 82 0 164 4 123 0 0 4 8 0 2 4 123 0 0 4 8 0 2 4 123 0 0 4 8 0 2 4 231 0 115 0 0 251 229 0 0 252 113 0 0 251 154 0 0 252 113 0 0 252 104 0 0 252 121 0 0 252 121 0 0 252 121 0 0 252 104 1 164 0 49 1 164 0 25 1 164 0 25 3 45 0 52 4 137 0 115 2 244 0 45 4 20 0 41 4 147 0 94 4 143 0 23 4 147 0 133 4 147 0 117 4 147 0 94 4 147 0 104 4 147 0 106 5 109 0 29 6 90 0 92 4 109 0 18 2 211 0 31 4 231 0 113 4 231 0 113 4 231 0 113 4 231 0 113 4 231 0 113 2 59 0 201 2 59 0 5 2 59 0 179 2 59 255 199 2 59 0 5 2 59 255 171 2 59 255 243 2 59 255 231 2 59 0 86 2 59 0 187 4 94 0 201 2 229 255 228 2 59 0 201 0 5 0 201 0 5 0 201 0 201 0 153 0 184 0 0 0 0 0 1 0 3 0 1 0 0 0 12 0 4 4 14 0 0 0 176 0 128 0 6 0 48 0 72 0 73 0 126 0 203 0 207 1 39 1 50 1 97 1 127 1 146 1 161 1 176 1 240 1 255 2 27 2 55 2 188 2 199 2 201 2 221 2 243 3 1 3 3 3 9 3 15 3 35 3 138 3 140 3 161 3 170 3 206 3 210 3 214 4 13 4 79 4 95 4 134 4 145 4 191 4 207 5 19 30 1 30 63 30 133 30 199 30 202 30 241 30 249 31 77 32 11 32 21 32 30 32 34 32 38 32 48 32 51 32 58 32 60 32 68 32 112 32 121 32 127 32 164 32 167 32 172 33 5 33 19 33 22 33 32 33 34 33 38 33 46 33 94 34 2 34 6 34 15 34 18 34 26 34 30 34 43 34 72 34 96 34 101 37 202 251 4 254 255 255 253 255 255 0 0 0 32 0 73 0 74 0 160 0 204 0 208 1 40 1 51 1 98 1 146 1 160 1 175 1 240 1 250 2 24 2 55 2 188 2 198 2 201 2 216 2 243 3 0 3 3 3 9 3 15 3 35 3 132 3 140 3 142 3 163 3 171 3 209 3 214 4 0 4 14 4 80 4 96 4 136 4 146 4 192 4 208 30 0 30 62 30 128 30 160 30 200 30 203 30 242 31 77 32 0 32 19 32 23 32 32 32 38 32 48 32 50 32 57 32 60 32 68 32 112 32 116 32 127 32 163 32 167 32 171 33 5 33 19 33 22 33 32 33 34 33 38 33 46 33 91 34 2 34 6 34 15 34 17 34 26 34 30 34 43 34 72 34 96 34 100 37 202 251 0 254 255 255 252 255 255 255 227 0 0 255 227 255 194 0 0 255 194 0 0 255 194 0 0 255 176 0 191 0 178 0 97 255 73 0 0 0 0 255 150 254 133 254 132 254 118 255 104 255 99 255 98 255 93 0 103 255 68 0 0 253 207 0 0 0 0 253 205 254 130 254 127 0 0 253 154 0 0 254 12 0 0 254 9 0 0 254 9 228 88 228 24 227 122 228 125 0 0 228 125 0 0 227 13 226 66 225 239 225 238 225 237 225 234 225 225 225 224 225 219 225 218 225 211 225 203 225 200 225 153 225 118 225 116 0 0 225 24 225 11 225 9 226 110 224 254 224 251 224 244 224 200 224 37 224 34 224 26 224 25 224 18 224 15 224 3 223 231 223 208 223 205 220 105 0 0 3 79 2 83 0 1 0 0 0 174 0 0 0 0 0 170 0 0 0 174 0 0 0 192 0 0 0 0 0 0 0 0 0 0 0 240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 224 0 0 0 234 1 16 0 0 0 0 0 0 1 24 0 0 1 48 0 0 1 76 0 0 1 92 0 0 0 0 0 0 0 0 0 0 1 112 0 0 1 114 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 96 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 60 0 0 0 0 0 0 3 150 3 151 3 152 3 153 3 154 3 155 0 235 3 156 0 237 3 157 0 239 3 158 0 241 3 159 0 243 3 160 3 143 3 144 1 38 1 39 1 40 1 41 1 42 1 43 1 44 1 45 1 46 1 47 1 48 1 49 1 50 1 51 1 52 1 53 1 54 1 55 1 56 1 57 1 58 1 59 1 60 1 61 1 62 1 63 1 64 1 65 1 73 1 74 1 36 1 37 1 84 1 85 1 86 1 87 1 88 1 89 3 161 1 92 1 93 1 94 1 95 1 96 1 97 1 98 1 99 1 100 1 101 1 102 3 162 1 104 1 105 1 106 1 107 1 108 1 109 1 110 1 111 1 112 1 113 1 114 1 115 1 116 1 117 1 118 3 163 2 104 1 156 1 157 1 158 1 159 1 160 3 164 3 165 1 163 1 164 1 165 1 166 1 167 2 105 2 106 1 234 1 235 1 236 1 237 1 238 1 239 1 240 1 241 1 242 1 243 1 244 1 245 2 107 1 246 1 247 2 147 2 148 2 149 2 150 2 151 2 152 2 153 2 154 1 248 1 249 3 166 2 202 2 203 2 204 2 205 2 206 2 207 2 208 2 209 2 210 2 211 2 212 2 213 2 214 2 215 3 167 3 168 3 70 3 169 2 0 2 1 3 111 3 112 3 113 3 114 3 115 3 116 3 117 2 28 3 141 2 52 2 53 2 93 2 94 0 0 64 71 91 90 89 88 85 84 83 82 81 80 79 78 77 76 75 74 73 72 71 70 69 68 67 66 65 64 63 62 61 60 59 58 57 56 55 54 53 49 48 47 46 45 44 40 39 38 37 36 35 34 33 31 24 20 17 16 15 14 13 11 10 9 8 7 6 5 4 3 2 1 0 44 32 176 1 96 69 176 3 37 32 17 70 97 35 69 35 97 72 45 44 32 69 24 104 68 45 44 69 35 70 96 176 32 97 32 176 70 96 176 4 38 35 72 72 45 44 69 35 70 35 97 176 32 96 32 176 38 97 176 32 97 176 4 38 35 72 72 45 44 69 35 70 96 176 64 97 32 176 102 96 176 4 38 35 72 72 45 44 69 35 70 35 97 176 64 96 32 176 38 97 176 64 97 176 4 38 35 72 72 45 44 1 16 32 60 0 60 45 44 32 69 35 32 176 205 68 35 32 184 1 90 81 88 35 32 176 141 68 35 89 32 176 237 81 88 35 32 176 77 68 35 89 32 176 4 38 81 88 35 32 176 13 68 35 89 33 33 45 44 32 32 69 24 104 68 32 176 1 96 32 69 176 70 118 104 138 69 96 68 45 44 1 177 11 10 67 35 67 101 10 45 44 0 177 10 11 67 35 67 11 45 44 0 176 40 35 112 177 1 40 62 1 176 40 35 112 177 2 40 69 58 177 2 0 8 13 45 44 32 69 176 3 37 69 97 100 176 80 81 88 69 68 27 33 33 89 45 44 73 176 14 35 68 45 44 32 69 176 0 67 96 68 45 44 1 176 6 67 176 7 67 101 10 45 44 32 105 176 64 97 176 0 139 32 177 44 192 138 140 184 16 0 98 96 43 12 100 35 100 97 92 88 176 3 97 89 45 44 138 3 69 138 138 135 176 17 43 176 41 35 68 176 41 122 228 24 45 44 69 101 176 44 35 68 69 176 43 35 68 45 44 75 82 88 69 68 27 33 33 89 45 44 75 81 88 69 68 27 33 33 89 45 44 1 176 5 37 16 35 32 138 245 0 176 1 96 35 237 236 45 44 1 176 5 37 16 35 32 138 245 0 176 1 97 35 237 236 45 44 1 176 6 37 16 245 0 237 236 45 44 176 2 67 176 1 82 88 33 33 33 33 33 27 70 35 70 96 138 138 70 35 32 70 138 96 138 97 184 255 128 98 35 32 16 35 138 177 12 12 138 112 69 96 32 176 0 80 88 176 1 97 184 255 186 139 27 176 70 140 89 176 16 96 104 1 58 89 45 44 32 69 176 3 37 70 82 75 176 19 81 91 88 176 2 37 70 32 104 97 176 3 37 176 3 37 63 35 33 56 27 33 17 89 45 44 32 69 176 3 37 70 80 88 176 2 37 70 32 104 97 176 3 37 176 3 37 63 35 33 56 27 33 17 89 45 44 0 176 7 67 176 6 67 11 45 44 33 33 12 100 35 100 139 184 64 0 98 45 44 33 176 128 81 88 12 100 35 100 139 184 32 0 98 27 178 0 64 47 43 89 176 2 96 45 44 33 176 192 81 88 12 100 35 100 139 184 21 85 98 27 178 0 128 47 43 89 176 2 96 45 44 12 100 35 100 139 184 64 0 98 96 35 33 45 44 75 83 88 138 176 4 37 73 100 35 69 105 176 64 139 97 176 128 98 176 32 97 106 176 14 35 68 35 16 176 14 246 27 33 35 138 18 17 32 57 47 89 45 44 75 83 88 32 176 3 37 73 100 105 32 176 5 38 176 6 37 73 100 35 97 176 128 98 176 32 97 106 176 14 35 68 176 4 38 16 176 14 246 138 16 176 14 35 68 176 14 246 176 14 35 68 176 14 237 27 138 176 4 38 17 18 32 57 35 32 57 47 47 89 45 44 69 35 69 96 35 69 96 35 69 96 35 118 104 24 176 128 98 32 45 44 176 72 43 45 44 32 69 176 0 84 88 176 64 68 32 69 176 64 97 68 27 33 33 89 45 44 69 177 48 47 69 35 69 97 96 176 1 96 105 68 45 44 75 81 88 176 47 35 112 176 20 35 66 27 33 33 89 45 44 75 81 88 32 176 3 37 69 105 83 88 68 27 33 33 89 27 33 33 89 45 44 69 176 20 67 176 0 96 99 176 1 96 105 68 45 44 176 47 69 68 45 44 69 35 32 69 138 96 68 45 44 69 35 69 96 68 45 44 75 35 81 88 185 0 51 255 224 177 52 32 27 179 51 0 52 0 89 68 68 45 44 176 22 67 88 176 3 38 69 138 88 100 102 176 31 96 27 100 176 32 96 102 32 88 27 33 176 64 89 176 1 97 89 35 88 101 89 176 41 35 68 35 16 176 41 224 27 33 33 33 33 33 89 45 44 176 2 67 84 88 75 83 35 75 81 90 88 56 27 33 33 89 27 33 33 33 33 89 45 44 176 22 67 88 176 4 37 69 100 176 32 96 102 32 88 27 33 176 64 89 176 1 97 35 88 27 101 89 176 41 35 68 176 5 37 176 8 37 8 32 88 2 27 3 89 176 4 37 16 176 5 37 32 70 176 4 37 35 66 60 176 4 37 176 7 37 8 176 7 37 16 176 6 37 32 70 176 4 37 176 1 96 35 66 60 32 88 1 27 0 89 176 4 37 16 176 5 37 176 41 224 176 41 32 69 101 68 176 7 37 16 176 6 37 176 41 224 176 5 37 176 8 37 8 32 88 2 27 3 89 176 5 37 176 3 37 67 72 176 4 37 176 7 37 8 176 6 37 176 3 37 176 1 96 67 72 27 33 89 33 33 33 33 33 33 33 45 44 2 176 4 37 32 32 70 176 4 37 35 66 176 5 37 8 176 3 37 69 72 33 33 33 33 45 44 2 176 3 37 32 176 4 37 8 176 2 37 67 72 33 33 33 45 44 69 35 32 69 24 32 176 0 80 32 88 35 101 35 89 35 104 32 176 64 80 88 33 176 64 89 35 88 101 89 138 96 68 45 44 75 83 35 75 81 90 88 32 69 138 96 68 27 33 33 89 45 44 75 84 88 32 69 138 96 68 27 33 33 89 45 44 75 83 35 75 81 90 88 56 27 33 33 89 45 44 176 0 33 75 84 88 56 27 33 33 89 45 44 176 2 67 84 88 176 70 43 27 33 33 33 33 89 45 44 176 2 67 84 88 176 71 43 27 33 33 33 89 45 44 176 2 67 84 88 176 72 43 27 33 33 33 33 89 45 44 176 2 67 84 88 176 73 43 27 33 33 33 89 45 44 32 138 8 35 75 83 138 75 81 90 88 35 56 27 33 33 89 45 44 0 176 2 37 73 176 0 83 88 32 176 64 56 17 27 33 89 45 44 1 70 35 70 96 35 70 97 35 32 16 32 70 138 97 184 255 128 98 138 177 64 64 138 112 69 96 104 58 45 44 32 138 35 73 100 138 35 83 88 60 27 33 89 45 44 75 82 88 125 27 122 89 45 44 176 18 0 75 1 75 84 66 45 44 177 2 0 66 177 35 1 136 81 177 64 1 136 83 90 88 185 16 0 0 32 136 84 88 178 2 1 2 67 96 66 89 177 36 1 136 81 88 185 32 0 0 64 136 84 88 178 2 2 2 67 96 66 177 36 1 136 84 88 178 2 32 2 67 96 66 0 75 1 75 82 88 178 2 8 2 67 96 66 89 27 185 64 0 0 128 136 84 88 178 2 4 2 67 96 66 89 185 64 0 0 128 99 184 1 0 136 84 88 178 2 8 2 67 96 66 89 185 64 0 1 0 99 184 2 0 136 84 88 178 2 16 2 67 96 66 89 177 38 1 136 81 88 185 64 0 2 0 99 184 4 0 136 84 88 178 2 64 2 67 96 66 89 185 64 0 4 0 99 184 8 0 136 84 88 178 2 128 2 67 96 66 89 89 89 89 89 89 177 0 2 67 84 88 64 10 5 64 8 64 9 64 12 2 13 2 27 177 1 2 67 84 88 178 5 64 8 186 1 0 0 9 1 0 179 12 1 13 1 27 177 128 2 67 82 88 178 5 64 8 184 1 128 177 9 64 27 178 5 64 8 186 1 128 0 9 1 64 89 185 64 0 0 128 136 85 185 64 0 2 0 99 184 4 0 136 85 90 88 179 12 0 13 1 27 179 12 0 13 1 89 89 89 66 66 66 66 66 45 44 69 24 104 35 75 81 88 35 32 69 32 100 176 64 80 88 124 89 104 138 96 89 68 45 44 176 0 22 176 2 37 176 2 37 1 176 1 35 62 0 176 2 35 62 177 1 2 6 12 176 10 35 101 66 176 11 35 66 1 176 1 35 63 0 176 2 35 63 177 1 2 6 12 176 6 35 101 66 176 7 35 66 176 1 22 1 45 44 176 128 176 2 67 80 176 1 176 2 67 84 91 88 33 35 16 176 32 26 201 27 138 16 237 89 45 44 176 89 43 45 44 138 16 229 45 64 153 9 33 72 32 85 32 1 30 85 31 72 3 85 31 30 1 15 30 63 30 175 30 3 77 75 38 31 76 75 51 31 75 70 37 31 38 52 16 85 37 51 36 85 25 19 255 31 7 4 255 31 6 3 255 31 74 73 51 31 73 70 37 31 19 51 18 85 5 1 3 85 4 51 3 85 31 3 1 15 3 63 3 175 3 3 71 70 25 31 235 70 1 35 51 34 85 28 51 27 85 22 51 21 85 17 1 15 85 16 51 15 85 15 15 79 15 2 31 15 207 15 2 15 15 255 15 2 6 2 1 0 85 1 51 0 85 111 0 127 0 175 0 239 0 4 16 0 1 128 22 1 5 1 184 1 144 177 84 83 43 43 75 184 7 255 82 75 176 9 80 91 176 1 136 176 37 83 176 1 136 176 64 81 90 176 6 136 176 0 85 90 91 88 177 1 1 142 89 133 141 141 0 66 29 75 176 50 83 88 176 32 29 89 75 176 100 83 88 176 16 29 177 22 0 66 89 115 115 43 43 94 115 116 117 43 43 43 43 43 116 43 115 116 43 43 43 43 43 43 43 43 43 43 43 43 43 115 116 43 43 43 24 94 0 0 0 6 20 0 23 0 78 5 182 0 23 0 117 5 182 5 205 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4 72 0 20 0 145 0 0 255 236 0 0 0 0 255 236 0 0 0 0 255 236 0 0 254 20 255 236 0 0 5 182 0 19 252 148 255 237 254 133 255 234 254 169 255 236 0 24 254 188 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 8 0 0 0 0 0 0 139 0 129 0 221 0 152 0 143 0 142 0 153 0 136 0 129 1 15 0 138 0 0 0 0 0 31 0 31 0 31 0 31 0 81 0 119 0 255 1 123 1 236 2 106 2 131 2 174 2 217 3 21 3 65 3 95 3 116 3 150 3 175 3 241 4 26 4 91 4 185 4 251 5 70 5 163 5 197 6 52 6 145 6 199 6 251 7 27 7 68 7 100 7 187 8 65 8 128 8 219 9 25 9 85 9 138 9 184 10 8 10 57 10 108 10 148 10 195 10 225 11 31 11 86 11 156 11 217 12 44 12 121 12 204 12 240 13 36 13 75 13 143 13 191 13 230 14 18 14 54 14 79 14 114 14 147 14 169 14 200 15 36 15 121 15 180 16 7 16 84 16 148 17 40 17 102 17 148 17 210 18 16 18 39 18 127 18 185 18 250 19 79 19 163 19 214 20 40 20 104 20 165 20 204 21 23 21 71 21 128 21 172 21 238 22 6 22 75 22 133 22 133 22 182 23 1 23 83 23 161 23 245 24 26 24 149 24 203 25 71 25 148 25 207 25 237 25 245 26 127 26 149 26 205 26 217 27 19 27 99 27 130 27 193 27 241 28 19 28 69 28 108 28 165 28 221 28 243 29 8 29 30 29 123 29 140 29 157 29 174 29 191 29 209 29 221 30 43 30 55 30 72 30 89 30 106 30 124 30 141 30 158 30 175 30 193 31 25 31 42 31 59 31 76 31 93 31 110 31 128 31 174 32 25 32 42 32 59 32 76 32 94 32 111 32 177 33 24 33 40 33 56 33 72 33 88 33 105 33 122 34 5 34 17 34 33 34 49 34 65 34 82 34 99 34 116 34 133 34 151 34 255 35 15 35 31 35 47 35 63 35 79 35 96 35 166 36 12 36 28 36 44 36 60 36 77 36 93 36 180 36 197 36 214 36 230 36 247 37 7 37 19 37 31 37 48 37 64 37 81 37 97 37 114 37 131 37 148 37 164 37 181 37 198 37 206 38 58 38 75 38 91 38 108 38 124 38 141 38 158 38 170 38 182 38 199 38 215 38 232 38 248 39 9 39 25 39 42 39 59 39 71 39 87 39 104 39 121 39 201 40 34 40 51 40 68 40 85 40 102 40 119 40 136 40 147 40 158 40 175 40 198 40 210 40 222 40 239 41 0 41 12 41 23 41 76 41 93 41 110 41 121 41 133 41 150 41 166 41 178 41 190 41 248 42 45 42 62 42 78 42 90 42 101 42 118 42 134 42 151 42 222 43 39 43 56 43 72 43 89 43 105 43 123 43 140 43 239 44 105 44 122 44 138 44 149 44 161 44 178 44 195 44 212 44 228 44 245 45 5 45 17 45 29 45 46 45 62 45 73 45 84 45 101 45 117 45 178 46 4 46 21 46 37 46 54 46 70 46 87 46 103 46 121 46 138 46 156 46 173 46 185 46 197 46 214 46 231 46 248 47 8 47 26 47 43 47 59 47 76 47 93 47 110 47 126 47 165 47 248 48 119 49 22 49 39 49 56 49 73 49 89 49 100 49 111 49 152 49 193 49 215 49 255 50 31 50 84 50 123 50 180 50 230 51 5 51 78 51 95 51 103 51 120 51 138 51 156 51 173 51 191 51 208 51 227 51 235 51 243 52 18 52 26 52 34 52 42 52 50 52 139 52 147 52 155 52 193 52 201 52 209 53 6 53 14 53 50 53 58 53 113 53 121 53 129 53 232 53 240 54 60 54 144 54 162 54 180 54 196 54 212 54 228 54 245 55 7 55 107 55 208 56 6 56 103 56 197 57 18 57 76 57 166 57 210 57 218 58 44 58 52 58 95 58 202 58 210 59 16 59 92 59 168 59 237 60 37 60 93 60 186 61 16 61 95 61 185 61 203 61 220 61 236 61 252 62 13 62 31 62 111 62 128 62 202 62 210 62 218 62 236 62 244 63 83 63 166 63 229 63 246 64 7 64 55 64 63 64 134 64 142 64 150 64 223 64 231 65 44 65 137 65 193 65 210 66 1 66 60 66 68 66 76 66 84 66 92 66 100 66 108 66 116 66 179 66 187 66 195 66 244 67 43 67 91 67 149 67 219 68 35 68 97 68 175 69 15 69 86 69 94 69 186 70 21 70 52 70 124 70 132 70 202 71 35 71 91 71 107 71 155 71 209 72 20 72 73 72 81 72 117 72 125 72 133 72 170 72 178 73 19 73 27 73 76 73 131 73 180 73 239 74 52 74 125 74 184 75 8 75 101 75 169 75 186 76 37 76 53 76 131 76 139 76 147 76 165 76 173 77 6 77 88 77 96 77 112 77 128 77 177 77 214 77 253 78 14 78 30 78 47 78 64 78 82 78 100 78 117 78 134 78 155 78 176 78 184 78 218 78 247 79 21 79 29 79 58 79 105 79 154 79 180 79 242 80 90 80 122 80 138 81 36 81 44 81 52 81 87 81 123 81 135 81 160 81 211 82 24 82 134 82 248 83 110 83 212 84 44 84 160 84 244 84 252 85 75 85 98 85 121 85 144 85 167 86 10 86 62 86 99 86 151 86 174 86 210 87 50 87 98 87 227 88 44 88 62 88 80 88 125 88 137 88 149 88 188 88 227 89 2 89 33 89 64 89 117 89 183 89 252 90 77 90 110 90 211 91 39 91 39 91 39 91 39 91 39 91 39 91 39 91 39 91 39 91 39 91 39 91 39 91 39 91 39 92 113 92 204 92 221 92 229 93 108 93 167 94 11 94 28 94 45 94 57 94 69 94 87 94 140 94 195 94 211 94 227 95 64 95 151 95 224 96 49 96 58 96 67 96 76 96 122 96 153 96 170 96 187 96 203 96 219 97 78 97 153 97 237 98 59 98 155 98 254 99 63 99 128 99 214 100 44 100 143 100 244 101 105 101 224 102 140 103 48 103 56 103 64 103 157 103 246 104 47 104 103 104 121 104 139 105 1 105 13 105 128 105 243 106 157 107 59 107 209 108 58 108 125 108 191 109 3 109 51 109 96 109 134 109 172 110 144 111 27 111 129 111 223 112 49 112 130 112 215 113 67 113 123 113 180 114 6 114 85 114 168 114 251 115 7 115 19 115 80 115 140 115 205 116 16 116 88 116 172 116 230 117 30 117 93 117 162 117 221 118 29 118 115 118 198 119 66 119 185 119 197 119 209 120 2 120 52 120 60 120 111 120 173 120 241 121 48 121 113 121 174 121 236 122 48 122 115 122 191 123 11 123 67 123 122 123 232 124 75 124 193 125 45 125 53 125 70 125 87 125 172 125 252 126 68 126 135 126 204 127 21 127 85 127 150 127 218 128 30 128 111 128 189 128 197 128 214 128 230 128 248 129 9 129 17 129 25 129 42 129 58 129 139 129 218 129 236 129 253 130 15 130 33 130 51 130 68 130 144 130 218 130 235 130 251 131 13 131 30 131 48 131 65 131 73 131 81 131 99 131 116 131 134 131 151 131 168 131 184 131 202 131 219 131 237 131 254 132 16 132 33 132 76 132 119 132 137 132 155 132 167 132 178 132 190 132 202 133 16 133 86 133 148 133 156 133 246 134 100 134 201 135 39 135 129 135 212 136 43 136 121 136 196 137 19 137 102 137 176 137 239 138 45 138 138 138 146 138 158 138 170 138 182 138 194 138 211 138 228 138 246 139 8 139 26 139 44 139 62 139 80 139 98 139 116 139 137 139 157 139 175 139 193 139 211 139 229 139 247 140 9 140 27 140 45 140 66 140 86 140 98 140 110 140 127 140 144 140 161 140 177 140 195 140 213 140 231 140 249 141 11 141 29 141 47 141 65 141 86 141 106 141 123 141 140 141 152 141 164 141 176 141 188 141 205 141 222 141 240 142 2 142 20 142 38 142 56 142 74 142 92 142 110 142 131 142 151 142 168 142 184 142 201 142 217 142 234 142 251 143 12 143 28 143 40 143 52 143 64 143 76 143 93 143 110 143 127 143 143 143 160 143 176 143 193 143 210 143 227 143 243 143 255 144 11 144 23 144 35 144 52 144 69 144 86 144 102 144 114 144 166 144 225 145 29 145 106 145 194 145 250 146 50 146 123 146 205 146 245 147 24 147 59 147 68 147 131 147 173 147 238 148 78 148 147 148 222 148 230 149 9 149 17 149 110 149 122 149 246 150 2 150 14 150 113 150 129 150 145 150 162 150 178 150 199 150 216 150 233 150 250 151 12 151 29 151 46 151 63 151 74 151 91 151 103 151 121 151 129 151 147 151 155 151 173 151 181 151 189 151 206 151 218 0 0 0 2 0 193 0 0 4 10 5 182 0 3 0 7 0 21 183 4 3 5 2 4 3 7 0 0 47 50 47 51 1 47 51 47 51 49 48 19 33 17 33 55 33 17 33 193 3 73 252 183 104 2 121 253 135 5 182 250 74 104 4 230 0 2 0 152 255 227 1 137 5 182 0 3 0 14 0 43 64 20 3 9 9 2 4 4 15 16 1 1 12 2 12 6 79 89 12 22 2 3 0 63 63 43 17 18 0 57 24 47 17 18 1 57 17 51 51 17 51 49 48 1 35 3 51 3 52 51 50 22 21 20 6 35 34 38 1 70 105 51 207 225 120 58 63 64 57 52 68 1 147 4 35 250 180 136 70 66 64 71 63 0 0 2 0 133 3 166 2 176 5 182 0 3 0 7 0 31 64 13 0 3 7 4 3 4 8 9 6 2 7 3 3 0 63 51 205 50 17 18 1 57 57 17 51 17 51 49 48 1 3 35 3 33 3 35 3 1 63 40 105 41 2 43 41 104 41 5 182 253 240 2 16 253 240 2 16 0 0 2 0 51 0 0 4 246 5 182 0 27 0 31 0 153 64 85 8 31 28 21 4 20 9 17 12 12 9 18 15 14 11 4 10 19 19 20 22 29 30 7 4 6 23 4 1 0 25 4 24 5 5 6 20 6 10 33 3 26 23 3 24 10 24 32 33 8 4 12 13 12 78 89 28 1 13 31 0 16 17 16 78 89 25 21 17 79 13 1 79 17 1 13 17 13 17 5 23 19 3 10 5 0 47 51 63 51 18 57 57 47 47 93 93 17 51 51 43 17 0 51 51 17 51 51 43 17 0 51 51 17 18 1 57 57 17 23 51 17 18 57 57 17 51 17 18 23 57 17 18 23 57 17 51 17 18 23 57 50 50 17 51 17 18 23 57 49 48 1 3 33 21 33 3 35 19 33 3 35 19 33 53 33 19 33 53 33 19 51 3 33 19 51 3 33 21 1 33 19 33 3 213 66 1 27 254 205 84 137 84 254 209 82 136 80 254 250 1 31 68 254 235 1 43 82 139 82 1 49 84 134 84 1 8 252 229 1 47 66 254 209 3 131 254 172 129 254 82 1 174 254 82 1 174 129 1 84 127 1 180 254 76 1 180 254 76 127 254 172 1 84 0 3 0 131 255 137 4 12 6 18 0 32 0 38 0 45 0 102 64 53 39 17 37 29 23 4 4 42 20 13 5 33 0 0 25 5 17 9 5 46 47 37 13 6 13 77 89 3 6 36 14 42 14 76 89 29 42 43 28 20 28 77 89 23 42 20 6 20 6 20 5 22 5 0 47 47 18 57 57 47 47 18 57 50 43 17 0 51 17 51 43 17 0 51 17 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 51 51 17 51 51 51 17 51 49 48 1 20 6 7 21 35 53 34 38 39 53 22 22 51 17 38 38 53 52 54 55 53 51 21 22 23 7 38 39 17 30 2 7 52 38 39 17 54 1 20 22 23 17 6 6 4 12 204 183 129 112 210 67 83 217 89 205 165 203 167 129 184 171 52 149 154 157 156 74 170 89 128 217 253 221 90 111 99 102 1 193 136 177 23 232 223 35 31 156 37 47 1 184 65 172 136 131 168 18 182 180 5 69 131 59 11 254 78 50 95 123 101 72 89 44 254 123 30 3 7 76 92 41 1 131 16 93 0 0 5 0 104 255 236 6 45 5 203 0 9 0 21 0 33 0 45 0 49 0 69 64 36 0 16 5 10 22 40 28 34 34 46 40 10 48 16 6 50 51 3 13 31 43 13 43 13 43 48 49 6 48 24 25 37 25 7 19 7 0 63 51 63 51 63 63 18 57 57 47 47 17 51 17 51 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 19 20 22 51 50 17 16 35 34 6 5 20 6 35 34 38 53 52 54 51 50 22 1 20 22 51 50 54 53 52 38 35 34 6 5 20 6 35 34 38 53 52 54 51 50 22 1 1 35 1 242 74 83 164 164 83 74 1 202 153 148 140 155 149 146 145 156 1 166 74 84 84 80 80 84 84 74 1 203 153 148 142 153 149 146 142 159 254 254 252 213 147 3 43 4 2 170 170 1 84 1 82 168 170 228 233 238 223 227 230 238 252 219 171 169 167 173 171 165 165 171 227 233 238 222 227 230 235 3 32 250 74 5 182 0 0 3 0 113 255 236 5 211 5 205 0 11 0 21 0 53 0 81 64 48 19 22 0 29 6 35 42 43 46 43 45 35 14 38 25 29 22 9 54 55 51 12 73 89 51 19 15 39 45 14 48 5 47 3 25 38 3 42 42 32 47 18 32 9 74 89 32 4 0 63 43 0 24 63 18 57 47 23 57 18 23 57 63 43 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 20 22 23 54 54 53 52 38 35 34 6 19 50 55 1 14 2 21 20 22 37 52 54 55 46 2 53 52 54 51 50 22 21 20 6 7 1 54 54 55 51 2 7 1 35 39 6 6 35 34 38 1 158 72 87 129 101 103 86 89 111 155 241 159 254 75 111 92 44 155 254 185 139 180 85 61 36 196 175 162 186 136 157 1 151 56 67 23 168 68 137 1 43 229 185 118 244 150 215 237 4 147 69 125 88 75 127 83 77 97 96 251 157 154 1 168 68 89 102 65 117 137 250 130 200 102 95 98 106 57 150 168 167 149 107 181 93 254 121 62 167 99 254 226 148 254 221 178 106 92 212 0 0 1 0 133 3 166 1 63 5 182 0 3 0 20 183 0 3 3 4 5 2 3 3 0 63 205 17 18 1 57 17 51 49 48 1 3 35 3 1 63 40 105 41 5 182 253 240 2 16 0 0 1 0 82 254 188 2 33 5 182 0 13 0 28 64 12 7 0 10 4 0 4 14 15 11 39 3 3 0 63 63 17 18 1 57 57 17 51 17 51 49 48 19 16 18 55 51 6 2 21 20 18 23 35 38 2 82 155 146 162 144 145 148 139 160 147 154 2 49 1 9 1 206 174 193 254 50 244 240 254 54 189 170 1 198 0 0 1 0 61 254 188 2 12 5 182 0 13 0 28 64 12 4 10 7 0 10 0 14 15 10 3 4 39 0 63 63 17 18 1 57 57 17 51 17 51 49 48 1 16 2 7 35 54 18 53 52 2 39 51 22 18 2 12 155 146 160 139 148 145 144 162 147 154 2 49 254 249 254 58 168 188 1 203 240 244 1 206 193 175 254 49 0 1 0 86 2 127 4 14 6 20 0 14 0 48 64 27 3 5 4 1 7 13 10 9 11 9 15 16 4 10 1 13 2 12 12 13 10 7 4 6 8 14 0 0 63 196 50 23 57 17 51 17 51 17 51 17 18 1 23 57 49 48 1 3 37 23 5 19 7 3 3 39 19 37 55 5 3 2 145 43 1 142 26 254 131 248 172 176 160 176 242 254 135 29 1 135 43 6 20 254 117 111 182 31 254 186 94 1 106 254 150 94 1 70 31 182 111 1 139 0 0 1 0 104 0 227 4 41 4 195 0 11 0 40 64 19 0 4 4 9 5 5 12 13 3 7 8 7 80 89 0 15 8 1 8 0 47 93 51 43 17 0 51 17 18 1 57 17 51 51 17 51 49 48 1 33 21 33 17 35 17 33 53 33 17 51 2 141 1 156 254 100 139 254 102 1 154 139 3 23 138 254 86 1 170 138 1 172 0 1 0 63 254 248 1 109 0 238 0 8 0 17 181 5 0 9 10 5 0 0 47 205 17 18 1 57 57 49 48 37 23 6 2 7 35 54 18 55 1 94 15 26 98 53 125 27 65 13 238 23 100 254 247 114 104 1 50 92 0 1 0 84 1 217 2 63 2 113 0 3 0 17 181 2 0 5 4 0 1 0 47 51 17 18 1 57 57 49 48 19 53 33 21 84 1 235 1 217 152 152 0 1 0 152 255 227 1 137 0 242 0 11 0 24 64 11 6 0 0 12 13 9 3 79 89 9 22 0 63 43 17 18 1 57 17 51 49 48 55 52 54 51 50 22 21 20 6 35 34 38 152 61 57 58 65 66 57 51 67 106 67 69 69 67 65 70 63 0 0 1 0 20 0 0 2 219 5 182 0 3 0 19 183 2 0 4 5 3 3 2 18 0 63 63 17 18 1 57 57 49 48 1 1 35 1 2 219 253 223 166 2 33 5 182 250 74 5 182 0 2 0 102 255 236 4 45 5 205 0 11 0 23 0 40 64 20 18 0 12 6 0 6 25 24 9 21 75 89 9 7 3 15 75 89 3 25 0 63 43 0 24 63 43 17 18 1 57 57 17 51 17 51 49 48 1 16 2 35 34 2 17 16 18 51 50 18 1 16 18 51 50 18 17 16 2 35 34 2 4 45 239 246 236 246 238 244 238 247 252 225 150 164 166 149 149 166 164 150 2 221 254 133 254 138 1 127 1 114 1 126 1 114 254 126 254 146 254 193 254 221 1 39 1 59 1 59 1 37 254 223 0 1 0 188 0 0 2 203 5 182 0 10 0 36 64 16 9 0 1 8 1 11 12 4 9 7 7 1 9 6 1 24 0 63 63 18 57 47 18 57 17 18 1 57 57 17 51 51 49 48 33 35 17 52 55 6 6 7 39 1 51 2 203 162 8 21 52 212 88 1 131 140 4 18 130 116 21 46 172 114 1 43 0 1 0 100 0 0 4 37 5 203 0 25 0 43 64 23 24 1 7 19 0 19 14 1 4 26 27 16 10 75 89 16 7 1 24 76 89 1 24 0 63 43 0 24 63 43 17 18 1 23 57 17 51 17 51 49 48 33 33 53 1 62 2 53 52 38 35 34 6 7 39 54 51 50 22 21 20 2 7 1 21 33 4 37 252 63 1 129 176 112 56 142 126 91 163 100 88 202 238 206 234 156 214 254 192 2 240 143 1 131 178 152 144 83 117 137 60 79 113 168 211 178 139 254 240 208 254 199 8 0 0 1 0 94 255 236 4 27 5 203 0 39 0 67 64 36 27 0 19 7 7 0 3 22 34 13 6 40 41 3 23 22 23 22 75 89 23 23 10 37 37 30 75 89 37 7 10 17 75 89 10 25 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 49 48 1 20 6 7 21 22 22 21 20 4 33 34 38 39 53 22 22 51 32 17 16 33 35 53 51 50 54 53 52 38 35 34 6 7 39 54 54 51 50 22 3 238 157 144 176 170 254 222 254 245 116 193 91 95 215 96 1 123 254 94 144 146 171 200 147 126 96 170 109 84 90 235 130 213 236 4 94 140 178 30 8 22 180 146 209 225 35 44 158 47 49 1 41 1 10 143 151 134 107 122 52 70 112 71 81 195 0 0 2 0 43 0 0 4 106 5 190 0 10 0 18 0 60 64 30 18 5 9 2 2 11 7 3 0 3 5 3 19 20 1 5 18 5 76 89 9 15 7 18 18 3 7 6 3 24 0 63 63 18 57 47 18 57 51 43 17 0 51 17 18 1 23 57 17 51 51 51 17 51 17 51 49 48 1 35 17 35 17 33 53 1 51 17 51 33 17 52 55 35 6 7 1 4 106 217 159 253 57 2 182 176 217 254 136 10 8 48 42 254 55 1 80 254 176 1 80 145 3 221 252 41 1 230 143 180 96 63 253 118 0 1 0 133 255 236 4 29 5 182 0 26 0 58 64 31 15 3 25 20 8 20 23 3 4 28 27 0 17 75 89 0 0 6 21 21 24 76 89 21 6 6 12 75 89 6 25 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 49 48 1 50 4 21 20 0 35 34 39 53 22 22 51 50 54 53 16 33 34 7 39 19 33 21 33 3 54 2 45 231 1 9 254 223 254 247 130 70 208 101 176 195 254 137 95 159 86 55 2 215 253 183 37 115 3 125 229 199 227 254 254 79 160 45 51 166 157 1 50 29 55 2 172 153 254 73 23 0 0 2 0 117 255 236 4 47 5 203 0 22 0 36 0 68 64 35 26 17 11 33 33 0 0 6 17 3 38 37 12 11 14 29 77 89 11 14 14 20 3 20 23 75 89 20 25 3 8 77 89 3 7 0 63 43 0 24 63 43 17 18 0 57 24 47 57 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 49 48 19 16 0 33 50 23 21 38 35 34 2 3 51 54 51 50 22 21 20 2 35 34 0 5 50 54 53 52 38 35 34 6 6 21 20 22 22 117 1 79 1 72 113 65 77 99 235 248 12 12 110 238 197 227 249 212 227 254 246 1 235 142 157 146 145 90 150 89 80 147 2 113 1 175 1 171 19 143 25 254 219 254 198 172 238 204 228 254 251 1 85 200 179 169 145 166 74 130 70 103 178 104 0 1 0 94 0 0 4 43 5 182 0 6 0 31 64 16 1 5 5 0 2 3 7 8 3 2 76 89 3 6 0 24 0 63 63 43 17 18 1 23 57 17 51 49 48 33 1 33 53 33 21 1 1 29 2 94 252 227 3 205 253 170 5 29 153 133 250 207 0 3 0 104 255 236 4 41 5 203 0 22 0 34 0 46 0 77 64 41 23 15 38 20 44 3 29 9 9 3 6 17 20 15 6 47 48 6 17 41 32 41 32 75 89 41 41 12 0 12 26 77 89 12 25 0 35 77 89 0 7 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 0 57 57 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 50 22 21 20 6 7 22 22 21 20 6 35 34 38 53 52 37 38 38 53 52 54 3 20 22 51 50 54 53 52 38 39 6 6 1 34 6 21 20 22 23 54 54 53 52 38 2 72 200 234 134 147 178 150 254 221 234 252 1 50 138 120 235 119 167 151 149 166 156 194 149 134 1 58 125 142 118 159 143 119 145 5 203 186 164 108 178 73 85 187 123 182 217 205 188 251 140 78 181 112 159 189 251 166 120 134 140 122 97 151 71 64 155 3 103 120 100 92 132 66 60 138 92 101 119 0 0 2 0 106 255 236 4 37 5 203 0 23 0 37 0 65 64 34 27 17 34 10 10 0 0 4 17 3 38 39 14 30 77 89 11 20 14 14 2 20 20 24 75 89 20 7 2 7 77 89 2 25 0 63 43 0 24 63 43 17 18 0 57 24 47 18 57 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 16 33 34 39 53 22 51 50 18 19 35 6 6 35 34 38 53 52 18 51 50 22 18 1 34 6 21 20 22 51 50 54 54 53 52 38 38 4 37 253 104 116 68 80 102 240 245 11 12 55 182 114 194 228 255 208 149 223 120 254 20 143 156 144 147 91 153 88 82 147 3 70 252 166 20 143 26 1 41 1 51 83 87 232 208 228 1 8 153 254 219 1 48 184 164 144 165 74 128 70 105 178 102 0 0 2 0 152 255 227 1 137 4 100 0 11 0 21 0 40 64 20 16 6 6 12 0 0 22 23 14 19 79 89 14 16 9 3 79 89 9 22 0 63 43 0 24 63 43 17 18 1 57 17 51 51 17 51 49 48 55 52 54 51 50 22 21 20 6 35 34 38 17 52 51 50 21 20 6 35 34 38 152 61 57 58 65 66 57 51 67 118 123 66 57 51 67 106 67 69 69 67 65 70 63 3 187 135 135 65 70 63 0 2 0 63 254 248 1 133 4 100 0 8 0 18 0 34 64 16 1 13 13 5 9 9 20 19 11 16 79 89 11 16 5 0 0 47 205 63 43 17 18 1 57 17 51 51 17 51 49 48 37 23 6 2 7 35 54 18 55 3 52 51 50 21 20 6 35 34 38 1 94 15 26 98 53 125 27 65 13 21 119 123 66 57 58 61 238 23 100 254 247 114 104 1 50 92 2 239 135 135 65 70 70 0 0 1 0 104 0 242 4 41 4 217 0 6 0 21 64 9 4 0 5 1 4 7 8 3 0 0 47 47 17 18 1 23 57 49 48 37 1 53 1 21 1 1 4 41 252 63 3 193 252 242 3 14 242 1 166 98 1 223 149 254 141 254 184 0 0 2 0 119 1 193 4 25 3 227 0 3 0 7 0 42 64 21 7 2 4 0 2 0 9 8 4 5 80 89 4 1 0 80 89 15 1 1 1 0 47 93 43 0 24 47 43 17 18 1 57 57 17 51 17 51 49 48 19 53 33 21 1 53 33 21 119 3 162 252 94 3 162 3 90 137 137 254 103 137 137 0 0 1 0 104 0 242 4 41 4 217 0 6 0 21 64 9 5 1 2 0 4 7 8 6 3 0 47 47 17 18 1 23 57 49 48 19 1 1 53 1 21 1 104 3 15 252 241 3 193 252 63 1 137 1 70 1 117 149 254 33 98 254 90 0 0 2 0 27 255 227 3 57 5 203 0 27 0 38 0 57 64 29 33 28 27 0 7 19 19 0 28 14 4 39 40 0 0 36 16 36 30 79 89 36 22 16 10 73 89 16 4 0 63 43 0 24 63 43 17 18 0 57 24 47 17 18 1 23 57 17 51 17 51 17 51 49 48 1 53 52 54 55 54 54 53 52 38 35 34 6 7 39 54 51 50 22 21 20 6 6 7 6 6 21 21 3 52 51 50 22 21 20 6 35 34 38 1 33 72 98 136 71 131 123 79 150 97 59 189 206 191 212 39 76 126 101 65 178 120 58 63 64 57 52 68 1 147 54 117 151 84 115 116 82 102 111 37 49 135 99 188 171 73 111 99 110 86 114 95 33 254 215 136 70 66 64 71 63 0 2 0 121 255 70 6 184 5 180 0 53 0 63 0 69 64 34 35 46 54 14 59 7 20 27 0 0 41 20 14 46 5 64 65 24 56 56 4 61 8 17 11 17 11 17 43 31 50 3 38 43 0 47 51 63 51 18 57 57 47 47 18 57 50 51 51 17 51 17 18 1 23 57 17 51 17 51 51 17 51 17 51 49 48 1 20 6 6 35 34 38 39 35 6 6 35 34 38 53 52 54 51 50 22 23 3 21 20 51 50 54 53 52 2 36 35 34 4 2 21 16 0 33 50 55 21 6 35 32 0 17 16 18 36 33 50 4 18 1 20 51 50 19 19 38 35 34 6 6 184 88 160 104 86 118 11 8 40 149 102 150 169 236 192 68 172 69 25 133 91 114 148 254 239 177 223 254 182 174 1 66 1 47 210 226 192 244 254 149 254 111 214 1 140 1 0 215 1 79 183 251 246 195 207 18 14 72 85 130 147 2 217 142 236 130 104 81 87 98 205 176 204 255 25 22 254 42 22 178 215 172 181 1 16 147 185 254 169 225 254 207 254 184 86 133 84 1 143 1 102 1 4 1 150 223 181 254 179 254 164 254 1 57 1 5 20 180 0 2 0 0 0 0 5 16 5 188 0 7 0 14 0 57 64 30 2 14 11 8 1 5 0 3 0 7 3 4 7 4 16 15 14 2 73 89 11 5 14 14 4 5 3 0 4 18 0 63 51 63 18 57 47 18 57 43 17 18 1 57 57 17 51 17 51 17 18 23 57 49 48 33 3 33 3 35 1 51 1 1 3 38 39 6 7 3 4 96 182 253 182 180 172 2 66 143 2 63 254 101 170 33 35 22 41 172 1 209 254 47 5 188 250 68 2 106 1 197 86 125 96 115 254 59 0 3 0 201 0 0 4 190 5 182 0 14 0 23 0 32 0 73 64 38 19 4 29 10 15 25 25 14 10 4 7 14 4 33 34 8 15 24 15 24 74 89 15 15 14 0 14 25 74 89 14 18 0 23 74 89 0 3 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 19 33 32 4 21 20 6 7 21 4 17 20 4 35 33 19 33 50 54 53 52 38 35 35 17 17 33 50 54 53 52 38 35 201 1 157 1 35 1 4 145 139 1 77 254 247 238 254 2 170 1 24 180 158 176 192 250 1 49 177 179 183 187 5 182 174 188 130 169 25 10 57 254 219 196 220 3 68 113 134 123 109 253 145 253 221 137 146 136 128 0 0 1 0 125 255 236 4 207 5 203 0 22 0 38 64 20 3 14 20 9 14 3 23 24 18 0 73 89 18 4 11 6 73 89 11 19 0 63 43 0 24 63 43 17 18 1 23 57 17 51 49 48 1 34 0 17 16 0 51 50 55 21 6 35 32 0 17 52 18 36 51 50 23 7 38 3 59 241 254 233 1 13 249 153 196 152 223 254 189 254 161 169 1 63 216 230 172 72 166 5 51 254 191 254 233 254 225 254 199 55 149 57 1 136 1 105 226 1 84 184 84 146 78 0 0 2 0 201 0 0 5 88 5 182 0 8 0 17 0 40 64 20 14 4 9 0 4 0 18 19 5 13 74 89 5 3 4 14 74 89 4 18 0 63 43 0 24 63 43 17 18 1 57 57 17 51 17 51 49 48 1 16 0 33 33 17 33 32 0 3 16 0 33 35 17 51 32 0 5 88 254 119 254 143 254 107 1 192 1 85 1 122 180 254 225 254 229 247 207 1 48 1 50 2 233 254 150 254 129 5 182 254 134 254 167 1 30 1 34 251 112 1 43 0 0 1 0 201 0 0 3 248 5 182 0 11 0 58 64 31 6 10 10 1 4 0 8 1 4 12 13 6 9 73 89 6 6 1 2 2 5 73 89 2 3 1 10 73 89 1 18 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 49 48 33 33 17 33 21 33 17 33 21 33 17 33 3 248 252 209 3 47 253 123 2 94 253 162 2 133 5 182 151 254 41 150 253 230 0 1 0 201 0 0 3 248 5 182 0 9 0 50 64 26 6 0 0 1 3 8 1 3 10 11 6 9 73 89 6 6 1 2 2 5 73 89 2 3 1 18 0 63 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 49 48 33 35 17 33 21 33 17 33 21 33 1 115 170 3 47 253 123 2 94 253 162 5 182 151 253 233 151 0 0 1 0 125 255 236 5 61 5 203 0 27 0 58 64 31 20 8 25 2 2 14 27 8 4 28 29 0 27 73 89 0 0 5 12 12 17 73 89 12 4 5 23 73 89 5 19 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 49 48 1 33 17 6 6 35 32 0 17 52 18 36 51 50 23 7 38 35 32 0 17 16 0 33 50 55 17 33 3 76 1 241 116 240 158 254 180 254 142 183 1 88 231 234 202 66 198 183 254 245 254 212 1 33 1 24 152 145 254 185 2 254 253 57 37 38 1 139 1 100 228 1 87 181 86 150 84 254 194 254 230 254 216 254 206 35 1 194 0 1 0 201 0 0 5 31 5 182 0 11 0 51 64 25 9 1 1 0 8 4 4 5 0 5 13 12 8 3 73 89 8 8 5 10 6 3 1 5 18 0 63 51 63 51 18 57 47 43 17 18 1 57 57 17 51 17 51 17 51 17 51 49 48 33 35 17 33 17 35 17 51 17 33 17 51 5 31 170 252 254 170 170 3 2 170 2 176 253 80 5 182 253 146 2 110 0 0 1 0 84 0 0 2 86 5 182 0 11 0 55 64 28 5 1 10 3 8 0 0 3 1 3 12 13 9 4 6 4 74 89 6 3 10 3 1 3 74 89 1 18 0 63 43 17 0 51 24 63 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 49 48 33 33 53 55 17 39 53 33 21 7 17 23 2 86 253 254 172 172 2 2 172 172 98 35 4 170 37 98 98 37 251 86 35 0 1 255 96 254 127 1 104 5 182 0 13 0 29 64 13 11 8 8 14 15 9 3 0 5 73 89 0 34 0 63 43 0 24 63 17 18 1 57 17 51 49 48 3 34 39 53 22 51 50 54 53 17 51 17 20 6 12 94 54 71 77 99 103 170 192 254 127 27 145 20 120 113 5 182 250 88 190 209 0 0 1 0 201 0 0 4 233 5 182 0 11 0 42 64 21 8 4 4 5 5 2 11 10 0 5 13 12 2 8 5 9 6 3 1 5 18 0 63 51 63 51 18 57 57 17 18 1 23 57 17 51 17 51 49 48 33 35 1 7 17 35 17 51 17 1 51 1 4 233 200 253 235 153 170 170 2 151 201 253 180 2 197 136 253 195 5 182 253 43 2 213 253 133 0 1 0 201 0 0 3 248 5 182 0 5 0 31 64 14 3 0 0 4 6 7 1 3 0 3 73 89 0 18 0 63 43 0 24 63 17 18 1 57 57 17 51 49 48 51 17 51 17 33 21 201 170 2 133 5 182 250 228 154 0 1 0 201 0 0 6 113 5 182 0 19 0 50 64 24 8 5 5 6 11 14 14 13 6 13 20 21 1 10 17 3 6 11 7 3 14 0 6 18 0 63 51 51 63 51 18 23 57 17 18 1 57 57 17 51 17 51 17 51 17 51 49 48 33 1 35 22 21 17 35 17 33 1 51 1 51 17 35 17 52 55 35 1 3 80 254 16 8 14 157 1 0 1 207 8 1 211 254 170 14 8 254 12 5 16 154 212 252 94 5 182 251 74 4 182 250 74 3 174 162 190 250 242 0 1 0 201 0 0 5 63 5 182 0 16 0 46 64 21 9 6 6 7 1 15 15 0 7 0 17 18 11 3 7 15 8 3 1 7 18 0 63 51 63 51 18 57 57 17 18 1 57 57 17 51 17 51 17 51 17 51 49 48 33 35 1 35 22 21 17 35 17 51 1 51 38 2 55 17 51 5 63 194 252 225 8 16 157 192 3 29 8 2 14 2 159 4 203 216 180 252 193 5 182 251 58 27 1 37 63 3 71 0 0 2 0 125 255 236 5 190 5 205 0 11 0 23 0 40 64 20 18 0 12 6 0 6 25 24 9 21 73 89 9 4 3 15 73 89 3 19 0 63 43 0 24 63 43 17 18 1 57 57 17 51 17 51 49 48 1 16 0 33 32 0 17 16 0 33 32 0 1 16 18 51 50 18 17 16 2 35 34 2 5 190 254 157 254 196 254 189 254 161 1 96 1 68 1 59 1 98 251 115 253 241 243 248 247 242 243 253 2 221 254 161 254 110 1 139 1 104 1 101 1 137 254 112 254 160 254 215 254 205 1 50 1 42 1 39 1 49 254 205 0 2 0 201 0 0 4 104 5 182 0 9 0 18 0 52 64 26 10 5 5 6 14 0 6 0 19 20 10 4 74 89 10 10 6 7 7 18 74 89 7 3 6 18 0 63 63 43 17 18 0 57 24 47 43 17 18 1 57 57 17 51 17 51 17 51 49 48 1 20 4 33 35 17 35 17 33 32 1 51 50 54 53 52 38 35 35 4 104 254 209 254 230 172 170 1 123 2 36 253 11 153 226 202 190 201 190 4 12 222 239 253 193 5 182 253 27 146 161 145 142 0 0 2 0 125 254 164 5 190 5 205 0 15 0 27 0 52 64 27 16 10 22 0 0 4 3 10 4 28 29 3 13 7 13 25 73 89 13 4 7 19 73 89 5 7 19 0 63 198 43 0 24 63 43 17 18 0 57 17 18 1 23 57 17 51 17 51 49 48 1 16 2 7 1 35 1 7 32 0 17 16 0 33 32 0 1 16 18 51 50 18 17 16 2 35 34 2 5 190 226 206 1 92 247 254 227 55 254 189 254 161 1 96 1 68 1 59 1 98 251 115 253 241 243 248 247 242 243 253 2 221 254 231 254 140 66 254 150 1 74 2 1 139 1 104 1 101 1 137 254 112 254 160 254 215 254 205 1 50 1 42 1 39 1 49 254 205 0 2 0 201 0 0 4 207 5 182 0 12 0 21 0 72 64 37 13 1 1 2 12 9 17 7 11 10 10 7 9 2 4 22 23 9 13 0 13 0 74 89 13 13 2 3 3 21 73 89 3 3 11 2 18 0 63 51 63 43 17 18 0 57 24 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 49 48 1 17 35 17 33 32 4 21 16 5 1 35 1 37 51 50 54 53 52 38 35 35 1 115 170 1 145 1 13 1 1 254 218 1 141 201 254 158 254 207 233 180 168 171 189 221 2 96 253 160 5 182 206 207 254 222 102 253 111 2 96 146 143 143 145 128 0 1 0 106 255 236 4 2 5 203 0 36 0 52 64 27 30 19 12 0 0 24 19 5 4 37 38 12 30 3 22 22 27 73 89 22 4 3 9 73 89 3 19 0 63 43 0 24 63 43 17 18 0 57 57 17 18 1 23 57 17 51 17 51 49 48 1 20 4 35 32 39 53 22 22 51 50 54 53 52 38 38 39 38 38 53 52 54 51 50 23 7 38 35 34 6 21 20 22 22 23 22 22 4 2 254 232 240 254 252 140 90 212 104 170 172 61 143 146 204 175 254 209 218 183 53 181 171 135 152 56 133 137 230 173 1 133 193 216 67 164 38 44 129 115 76 97 82 52 73 200 161 169 200 80 148 76 116 103 76 97 81 49 82 188 0 0 1 0 18 0 0 4 90 5 182 0 7 0 36 64 18 0 1 5 1 3 3 8 9 7 3 4 3 73 89 4 3 1 18 0 63 63 43 17 0 51 17 18 1 23 57 17 51 49 48 33 35 17 33 53 33 21 33 2 139 170 254 49 4 72 254 49 5 31 151 151 0 0 1 0 186 255 236 5 25 5 182 0 17 0 37 64 17 16 1 10 7 1 7 19 18 17 8 3 4 13 73 89 4 19 0 63 43 0 24 63 51 17 18 1 57 57 17 51 17 51 49 48 1 17 20 0 33 32 0 53 17 51 17 20 22 51 50 54 53 17 5 25 254 210 254 248 254 248 254 223 170 200 194 185 200 5 182 252 78 250 254 226 1 32 252 3 174 252 70 183 196 197 184 3 184 0 1 0 0 0 0 4 195 5 182 0 10 0 26 64 11 1 4 12 11 8 3 0 4 3 3 18 0 63 63 51 18 57 17 18 1 57 57 49 48 1 51 1 35 1 51 1 22 23 54 55 4 12 183 253 241 168 253 244 180 1 80 58 34 36 58 5 182 250 74 5 182 252 78 163 154 162 161 0 1 0 27 0 0 7 76 5 182 0 25 0 36 64 16 25 10 27 26 21 14 14 5 9 24 17 10 3 1 9 18 0 63 51 63 51 51 18 57 57 17 51 17 18 1 57 57 49 48 33 35 1 38 38 39 6 7 1 35 1 51 19 22 23 54 55 1 51 1 22 23 54 55 19 51 5 197 168 254 217 21 52 1 22 48 254 226 168 254 123 180 231 48 22 27 53 1 6 180 1 19 48 33 19 53 230 180 3 211 65 198 20 132 157 252 51 5 182 252 121 190 154 183 175 3 121 252 127 155 195 142 204 3 133 0 0 1 0 8 0 0 4 150 5 182 0 11 0 35 64 18 4 6 5 11 10 0 6 13 12 2 8 4 9 6 3 1 4 18 0 63 51 63 51 18 57 57 17 18 1 23 57 49 48 33 35 1 1 35 1 1 51 1 1 51 1 4 150 193 254 119 254 112 180 1 230 254 59 188 1 107 1 110 181 254 59 2 131 253 125 2 252 2 186 253 189 2 67 253 76 0 0 1 0 0 0 0 4 123 5 182 0 8 0 32 64 15 4 5 2 5 7 3 9 10 0 5 1 7 3 5 18 0 63 63 51 18 57 17 18 1 23 57 17 51 49 48 1 1 51 1 17 35 17 1 51 2 61 1 134 184 254 24 172 254 25 186 2 219 2 219 252 129 253 201 2 47 3 135 0 1 0 82 0 0 4 63 5 182 0 9 0 43 64 23 8 1 3 7 0 7 4 1 4 10 11 5 4 73 89 5 3 1 8 73 89 1 18 0 63 43 0 24 63 43 17 18 1 23 57 17 51 17 51 49 48 33 33 53 1 33 53 33 21 1 33 4 63 252 19 3 8 253 16 3 191 252 248 3 30 133 4 152 153 133 251 105 0 1 0 166 254 188 2 111 5 182 0 7 0 32 64 14 6 1 4 0 1 0 8 9 5 2 3 6 1 39 0 63 51 63 51 17 18 1 57 57 17 51 17 51 49 48 1 33 17 33 21 33 17 33 2 111 254 55 1 201 254 223 1 33 254 188 6 250 141 250 33 0 0 1 0 23 0 0 2 221 5 182 0 3 0 19 183 3 1 4 5 3 3 2 18 0 63 63 17 18 1 57 57 49 48 19 1 35 1 186 2 35 166 253 224 5 182 250 74 5 182 0 0 1 0 51 254 188 1 252 5 182 0 7 0 32 64 14 3 0 1 6 0 6 8 9 0 7 39 3 4 3 0 63 51 63 51 17 18 1 57 57 17 51 17 51 49 48 23 33 17 33 53 33 17 33 51 1 33 254 223 1 201 254 55 182 5 223 141 249 6 0 0 1 0 49 2 39 4 35 5 193 0 6 0 24 64 9 0 3 7 8 5 2 0 4 2 0 47 47 51 18 57 17 18 1 57 57 49 48 19 1 51 1 35 1 1 49 1 178 99 1 221 152 254 140 254 178 2 39 3 154 252 102 2 233 253 23 0 1 255 252 254 197 3 154 255 72 0 3 0 17 181 0 5 1 4 1 2 0 47 51 17 1 51 17 51 49 48 1 33 53 33 3 154 252 98 3 158 254 197 131 0 1 1 137 4 217 3 18 6 33 0 9 0 19 182 0 4 11 10 6 128 1 0 47 26 205 17 18 1 57 57 49 48 1 35 38 38 39 53 51 22 22 23 3 18 110 65 178 40 203 32 114 44 4 217 52 192 63 21 69 181 53 0 2 0 94 255 236 3 205 4 90 0 25 0 36 0 71 64 37 34 8 11 30 30 25 25 18 8 3 37 38 1 2 11 30 71 89 2 11 11 0 21 21 15 70 89 21 16 5 26 70 89 5 22 0 21 0 63 63 43 0 24 63 43 17 18 0 57 24 47 57 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 49 48 33 39 35 6 6 35 34 38 53 16 37 55 53 52 38 35 34 7 39 54 54 51 50 22 21 17 37 50 54 53 53 7 6 6 21 20 22 3 82 33 8 82 163 122 163 185 2 19 186 111 122 137 173 51 81 193 97 196 189 254 14 155 177 166 198 175 109 156 103 73 168 155 1 76 16 6 68 129 123 84 127 44 50 174 192 253 20 117 170 153 99 7 7 109 115 90 94 0 2 0 176 255 236 4 117 6 20 0 19 0 31 0 68 64 34 10 23 23 15 15 12 29 3 12 3 32 33 13 0 12 21 18 17 10 17 6 0 6 26 70 89 6 22 0 20 70 89 0 16 0 63 43 0 24 63 43 17 18 0 57 57 17 51 24 63 63 17 18 1 57 57 17 51 17 51 17 51 17 51 49 48 1 50 18 17 16 2 35 34 38 39 35 7 35 17 51 17 20 7 51 54 23 34 6 21 20 22 51 50 54 53 52 38 2 174 216 239 241 214 107 177 60 12 35 119 166 8 8 116 204 170 150 154 170 153 150 150 4 90 254 217 254 242 254 242 254 213 79 82 141 6 20 254 134 127 101 164 139 195 231 231 199 223 209 214 210 0 0 1 0 115 255 236 3 139 4 92 0 22 0 38 64 20 15 3 3 21 9 3 24 23 6 13 70 89 6 16 0 18 70 89 0 22 0 63 43 0 24 63 43 17 18 1 23 57 17 51 49 48 5 34 0 17 16 0 51 50 22 23 7 38 38 35 32 17 20 22 51 50 55 21 6 2 102 238 254 251 1 9 245 79 158 45 51 55 130 50 254 178 163 160 137 144 110 20 1 37 1 12 1 19 1 44 34 23 141 22 29 254 86 202 216 59 147 57 0 2 0 115 255 236 4 55 6 20 0 18 0 31 0 66 64 33 29 6 23 0 14 14 17 6 17 32 33 18 21 15 0 0 1 1 12 3 9 9 26 70 89 9 16 3 19 70 89 3 22 0 63 43 0 24 63 43 17 18 0 57 57 17 51 24 63 63 17 18 1 57 57 17 51 17 51 51 17 51 49 48 37 35 6 35 34 2 17 16 18 51 50 23 51 39 39 17 51 17 35 37 50 54 53 53 52 38 35 34 6 21 20 22 3 154 9 115 229 215 239 240 214 223 119 13 7 4 166 135 254 158 170 153 155 170 146 155 154 147 167 1 38 1 15 1 15 1 44 162 79 77 1 190 249 236 119 185 206 35 233 199 227 207 210 214 0 2 0 115 255 236 4 18 4 92 0 19 0 26 0 59 64 31 24 10 23 11 3 3 17 10 3 28 27 23 11 70 89 23 23 0 6 6 20 70 89 6 16 0 14 70 89 0 22 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 51 17 51 49 48 5 34 0 17 16 0 51 50 18 21 21 33 22 22 51 50 55 21 6 6 3 34 6 7 33 52 38 2 127 243 254 231 1 5 220 206 240 253 13 5 185 168 177 173 88 157 156 132 157 14 2 61 140 20 1 40 1 7 1 9 1 56 254 241 222 105 193 200 74 148 38 33 3 229 172 152 157 167 0 0 1 0 29 0 0 3 14 6 31 0 20 0 57 64 29 20 12 12 19 2 2 7 3 5 3 21 22 10 15 70 89 10 0 1 5 7 5 70 89 19 7 15 3 21 0 63 63 51 43 17 0 51 24 63 43 17 18 1 57 57 17 51 51 17 51 51 18 57 49 48 1 33 17 35 17 35 53 55 53 16 33 50 23 7 38 35 34 6 21 21 33 2 158 254 233 166 196 196 1 97 87 117 43 96 68 94 90 1 23 3 199 252 57 3 199 75 60 61 1 148 35 133 31 125 138 71 0 0 3 0 39 254 20 4 49 4 92 0 42 0 55 0 65 0 110 64 62 43 25 56 37 12 31 61 5 49 19 1 19 5 2 42 34 28 31 37 25 10 66 67 28 15 53 15 53 70 89 8 59 71 89 10 34 8 42 15 8 15 8 22 42 42 2 71 89 42 15 40 63 71 89 40 16 22 46 71 89 22 27 0 63 43 0 24 63 43 0 24 63 43 17 18 0 57 57 24 47 47 17 18 57 57 43 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 49 48 1 21 7 22 22 21 20 6 35 34 39 6 21 20 22 51 51 50 22 21 20 4 33 34 38 53 52 54 55 38 38 53 52 54 55 38 38 53 52 54 51 50 23 1 20 22 51 50 54 53 52 38 35 35 34 6 19 20 22 51 50 53 52 35 34 6 4 49 203 28 44 220 192 49 43 106 74 90 194 178 191 254 220 254 232 215 233 128 116 42 57 64 69 85 107 216 198 86 69 254 17 150 140 209 201 110 152 199 113 126 90 130 116 243 246 117 126 4 72 105 24 35 113 71 161 192 8 56 85 45 43 150 143 182 191 160 146 100 146 26 19 80 53 60 90 42 35 168 108 180 195 20 251 0 89 92 125 107 89 69 108 3 60 115 118 236 247 126 0 1 0 176 0 0 4 68 6 20 0 22 0 51 64 25 14 12 8 8 9 0 22 9 22 23 24 14 9 18 18 4 70 89 18 16 10 0 0 9 21 0 63 51 63 63 43 17 18 0 57 17 18 1 57 57 17 51 17 51 17 51 51 49 48 33 17 52 38 35 34 6 21 17 35 17 51 17 20 7 51 54 54 51 50 22 21 17 3 158 122 130 173 159 166 166 8 10 49 181 116 201 201 2 197 134 132 188 214 253 195 6 20 254 41 85 56 79 91 191 208 253 53 0 0 2 0 162 0 0 1 102 5 223 0 3 0 15 0 35 64 17 10 0 0 4 1 1 16 17 13 7 72 89 13 2 15 1 21 0 63 63 206 43 17 18 1 57 17 51 51 17 51 49 48 33 35 17 51 3 52 54 51 50 22 21 20 6 35 34 38 1 86 166 166 180 56 42 40 58 58 40 42 56 4 72 1 41 57 53 54 56 56 55 55 0 0 2 255 145 254 20 1 102 5 223 0 12 0 24 0 44 64 22 19 11 11 13 8 8 25 26 22 16 72 89 22 64 9 15 0 5 70 89 0 27 0 63 43 0 24 63 26 206 43 17 18 1 57 17 51 51 17 51 49 48 19 34 39 53 22 51 50 54 53 17 51 17 16 3 52 54 51 50 22 21 20 6 35 34 38 43 95 59 69 67 78 73 166 180 56 42 40 58 58 40 42 56 254 20 25 135 20 85 87 4 252 251 16 254 188 7 93 57 53 54 56 56 55 55 0 1 0 176 0 0 4 29 6 20 0 16 0 54 64 27 16 14 10 10 11 11 8 6 4 5 8 4 17 18 12 0 0 16 16 8 8 3 7 11 21 3 15 0 63 63 51 18 57 47 57 17 51 63 17 18 1 23 57 17 57 17 51 17 51 51 49 48 1 54 55 1 51 1 1 35 1 7 17 35 17 51 17 20 7 1 84 43 88 1 98 197 254 68 1 219 201 254 125 125 164 164 8 2 49 61 99 1 119 254 45 253 139 2 6 108 254 102 6 20 252 199 55 115 0 1 0 176 0 0 1 86 6 20 0 3 0 22 64 9 0 1 1 4 5 2 0 1 21 0 63 63 17 18 1 57 17 51 49 48 33 35 17 51 1 86 166 166 6 20 0 1 0 176 0 0 6 203 4 92 0 35 0 70 64 35 21 17 17 18 8 9 0 35 9 18 35 3 36 37 28 22 21 21 18 25 4 13 25 13 70 89 31 25 16 19 15 9 0 18 21 0 63 51 51 63 63 51 43 17 0 51 17 18 57 24 47 51 51 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 33 17 52 38 35 34 6 21 17 35 17 52 38 35 34 6 21 17 35 17 51 23 51 54 54 51 32 23 51 54 54 51 50 22 21 17 6 37 112 118 155 148 166 112 119 156 145 166 135 27 8 47 171 106 1 1 79 8 49 186 119 186 185 2 201 131 131 178 185 253 156 2 201 131 131 187 213 253 193 4 72 150 80 90 186 86 100 191 210 253 53 0 0 1 0 176 0 0 4 68 4 92 0 20 0 49 64 24 0 20 12 8 8 9 20 9 22 21 12 9 16 16 4 70 89 16 16 10 15 0 9 21 0 63 51 63 63 43 17 18 0 57 17 18 1 57 57 17 51 17 51 17 51 49 48 33 17 52 38 35 34 6 21 17 35 17 51 23 51 54 54 51 50 22 21 17 3 158 122 130 172 160 166 135 27 8 51 184 113 198 200 2 197 134 132 186 214 253 193 4 72 150 81 89 191 210 253 53 0 2 0 115 255 236 4 98 4 92 0 12 0 24 0 40 64 20 19 0 13 7 0 7 26 25 10 22 70 89 10 16 3 16 70 89 3 22 0 63 43 0 24 63 43 17 18 1 57 57 17 51 17 51 49 48 1 16 0 35 34 38 2 53 16 0 51 50 0 1 20 22 51 50 54 53 52 38 35 34 6 4 98 254 242 238 147 228 124 1 12 238 230 1 15 252 189 168 163 163 169 169 165 163 166 2 37 254 244 254 211 138 1 2 173 1 12 1 43 254 206 254 251 210 220 219 211 209 217 214 0 2 0 176 254 20 4 117 4 92 0 20 0 33 0 63 64 32 25 11 4 7 7 8 31 18 8 18 34 35 4 11 0 15 15 21 70 89 15 16 9 15 8 27 0 28 70 89 0 22 0 63 43 0 24 63 63 63 43 17 18 0 57 57 17 18 1 57 57 17 51 17 51 17 51 51 51 49 48 5 34 38 39 35 22 21 17 35 17 51 23 51 54 54 51 50 18 17 16 2 3 34 6 7 21 20 22 51 50 54 53 52 38 2 174 107 177 60 12 12 166 135 23 8 64 170 110 218 237 241 238 168 150 2 154 170 142 161 161 20 79 82 96 86 254 61 6 52 150 90 80 254 214 254 243 254 242 254 213 3 227 186 203 37 231 199 230 202 205 219 0 2 0 115 254 20 4 55 4 92 0 12 0 31 0 68 64 34 10 16 29 22 3 26 26 25 16 25 32 33 26 27 23 15 29 30 30 22 13 19 19 7 70 89 19 16 13 0 70 89 13 22 0 63 43 0 24 63 43 17 18 0 57 57 17 51 24 63 63 17 18 1 57 57 17 51 17 51 51 51 17 51 49 48 37 50 54 55 53 52 38 35 34 6 21 20 22 23 34 2 17 16 18 51 50 23 51 55 51 17 35 17 52 55 35 6 2 78 166 152 5 156 169 146 155 153 125 212 238 240 214 225 121 9 24 131 166 11 13 115 119 178 211 37 230 202 227 207 207 217 139 1 42 1 11 1 13 1 46 170 150 249 204 1 213 100 70 167 0 1 0 176 0 0 3 39 4 92 0 16 0 42 64 20 13 9 9 10 10 2 17 18 11 15 13 0 10 21 0 5 70 89 0 16 0 63 43 0 24 63 18 57 63 17 18 1 57 57 17 51 17 51 49 48 1 50 23 7 38 35 34 6 21 17 35 17 51 23 51 54 54 2 164 73 58 23 68 52 133 189 166 137 19 8 61 172 4 92 12 154 15 216 161 253 180 4 72 203 107 116 0 1 0 106 255 236 3 115 4 92 0 36 0 54 64 28 30 19 12 0 0 24 5 19 4 37 38 12 30 3 22 22 27 70 89 22 16 6 3 9 70 89 3 22 0 63 43 0 24 47 63 43 17 18 0 57 57 17 18 1 23 57 17 51 17 51 49 48 1 20 6 35 34 39 53 22 22 51 50 54 53 52 38 39 46 2 53 52 54 51 50 23 7 38 35 34 6 21 20 22 22 23 22 22 3 115 228 206 218 122 79 181 84 130 140 111 161 153 129 63 218 190 177 169 59 165 134 118 120 45 100 142 195 137 1 43 153 166 69 154 40 46 83 85 64 91 62 57 85 108 75 134 155 72 135 68 74 65 44 62 56 53 71 144 0 1 0 31 255 236 2 168 5 70 0 22 0 52 64 27 16 20 20 9 11 9 18 3 4 24 23 10 19 16 19 71 89 14 64 16 15 7 0 70 89 7 22 0 63 43 0 24 63 26 205 43 17 0 51 17 18 1 23 57 17 51 17 51 49 48 37 50 54 55 21 6 6 35 32 17 17 35 53 55 55 51 21 33 21 33 17 20 22 2 18 44 82 24 27 105 42 254 194 157 157 70 96 1 62 254 194 94 117 13 7 127 13 17 1 79 2 140 80 69 234 254 129 253 123 99 106 0 0 1 0 164 255 236 4 57 4 72 0 20 0 52 64 25 1 19 7 12 12 10 19 10 21 22 12 13 13 16 8 20 15 16 4 70 89 16 22 11 21 0 63 63 43 0 24 63 51 18 57 17 51 17 18 1 57 57 17 51 17 51 17 51 49 48 1 17 20 22 51 50 54 53 17 51 17 35 39 35 6 6 35 34 38 53 17 1 76 122 130 172 159 166 137 24 9 51 181 116 200 199 4 72 253 57 134 132 188 213 2 64 251 184 147 81 86 190 209 2 205 0 0 1 0 0 0 0 4 2 4 72 0 11 0 24 64 10 1 10 12 13 5 9 1 15 0 21 0 63 63 51 57 17 18 1 57 57 49 48 33 1 51 19 22 23 51 54 18 19 51 1 1 160 254 96 178 236 80 14 8 11 117 204 178 254 96 4 72 253 118 228 68 53 1 77 2 48 251 184 0 1 0 23 0 0 6 35 4 72 0 28 0 44 64 20 9 27 29 30 23 22 14 13 3 4 13 4 8 26 18 9 15 0 8 21 0 63 51 63 51 51 18 57 57 17 51 17 51 51 51 17 18 1 57 57 49 48 33 3 38 39 35 6 7 3 35 1 51 18 18 23 51 54 54 55 19 51 19 22 23 51 54 54 19 51 1 4 47 201 19 52 8 40 30 207 192 254 213 174 106 111 8 8 11 49 18 201 180 196 56 20 8 4 35 191 172 254 209 2 131 59 209 175 95 253 127 4 72 254 99 254 80 75 57 181 53 2 117 253 139 172 117 36 150 2 220 251 184 0 0 1 0 39 0 0 4 8 4 72 0 11 0 34 64 17 7 5 6 0 1 5 12 13 9 3 1 8 11 21 4 1 15 0 63 51 63 51 18 57 57 17 18 1 23 57 49 48 1 1 51 1 1 51 1 1 35 1 1 35 1 184 254 131 189 1 33 1 32 187 254 131 1 145 188 254 205 254 202 188 2 49 2 23 254 92 1 164 253 233 253 207 1 188 254 68 0 1 0 2 254 20 4 6 4 72 0 21 0 36 64 18 9 15 0 3 22 23 4 13 0 13 18 70 89 13 27 8 0 15 0 63 50 63 43 17 18 0 57 17 18 1 23 57 49 48 19 51 19 22 23 51 54 54 19 51 1 6 6 35 34 39 53 22 51 50 55 55 2 178 240 79 19 8 13 83 230 178 254 41 70 187 136 76 74 55 68 171 73 61 4 72 253 143 214 95 51 247 2 124 251 32 185 155 17 133 12 192 156 0 0 1 0 82 0 0 3 109 4 72 0 9 0 43 64 23 8 1 3 7 0 7 4 1 4 10 11 5 4 71 89 5 15 1 8 71 89 1 21 0 63 43 0 24 63 43 17 18 1 23 57 17 51 17 51 49 48 33 33 53 1 33 53 33 21 1 33 3 109 252 229 2 86 253 207 2 231 253 178 2 93 113 3 86 129 129 252 186 0 1 0 61 254 188 2 193 5 182 0 28 0 44 64 21 25 26 26 11 23 0 0 15 7 20 3 3 7 11 3 29 30 19 3 4 39 0 63 63 17 18 1 23 57 17 51 17 51 51 17 51 17 51 17 51 49 48 37 20 22 23 21 38 38 53 17 52 38 35 53 54 54 53 17 52 54 51 21 6 21 17 20 7 21 22 21 1 219 117 113 190 208 126 120 130 116 216 182 230 223 223 12 102 92 2 140 2 170 154 1 47 104 89 141 2 92 96 1 50 155 172 139 6 193 254 217 215 39 12 39 215 0 1 1 238 254 16 2 123 6 20 0 3 0 22 64 9 2 3 3 4 5 3 27 0 0 0 63 63 17 18 1 57 17 51 49 48 1 51 17 35 1 238 141 141 6 20 247 252 0 1 0 72 254 188 2 203 5 182 0 29 0 44 64 21 21 5 10 18 18 2 25 0 29 29 14 14 25 5 3 30 31 21 39 6 3 0 63 63 17 18 1 23 57 17 51 17 51 17 51 51 17 51 17 51 49 48 1 38 53 17 52 39 53 50 22 21 17 20 22 23 21 34 6 21 17 20 6 7 53 54 54 53 17 52 54 55 2 10 223 227 184 211 118 130 122 126 205 190 111 116 110 113 2 63 39 215 1 39 193 6 139 174 153 254 206 97 91 2 141 89 104 254 209 153 171 2 140 2 92 102 1 41 114 120 20 0 0 1 0 104 2 80 4 41 3 84 0 23 0 36 64 17 3 15 24 25 18 12 80 89 3 18 15 6 6 0 80 89 6 0 47 43 0 16 24 196 47 196 43 17 18 1 57 57 49 48 1 34 6 7 53 54 51 50 22 23 22 22 51 50 54 55 21 6 35 34 38 39 38 38 1 82 53 127 54 100 144 68 113 89 66 98 47 54 128 54 102 142 72 126 72 75 90 2 201 67 54 151 109 28 38 28 27 64 57 150 110 33 32 32 24 0 0 2 0 152 254 139 1 137 4 94 0 3 0 14 0 43 64 20 2 4 4 3 9 9 15 16 0 0 3 12 12 6 79 89 12 16 3 34 0 63 63 43 17 18 0 57 24 47 17 18 1 57 17 51 51 17 51 49 48 19 51 19 35 19 20 35 34 38 53 52 54 51 50 22 219 105 51 207 225 121 60 60 63 57 51 70 2 172 251 223 5 76 135 71 64 63 72 64 0 1 0 190 255 236 3 219 5 203 0 27 0 62 64 30 22 8 13 3 3 10 4 0 16 16 4 8 3 28 29 25 5 2 19 10 13 2 13 2 13 4 11 7 4 25 0 63 63 18 57 57 47 47 17 51 51 17 51 51 17 18 1 23 57 17 51 17 51 51 17 51 17 51 49 48 37 6 7 21 35 53 38 2 53 16 37 53 51 21 22 22 23 7 38 35 34 6 21 20 22 51 50 55 3 203 105 147 133 203 193 1 140 135 75 142 49 49 133 109 172 162 159 167 141 142 240 54 6 200 206 32 1 17 250 1 252 62 172 164 3 33 23 140 51 211 217 212 203 59 0 1 0 63 0 0 4 68 5 201 0 29 0 72 64 38 24 19 9 13 13 26 22 17 2 11 22 19 5 30 31 12 24 25 24 78 89 9 25 25 19 0 19 16 76 89 19 24 0 5 75 89 0 7 0 63 43 0 24 63 43 17 18 0 57 24 47 51 43 17 0 51 17 18 1 23 57 17 51 51 17 51 17 51 49 48 1 50 23 7 38 35 34 6 21 17 33 21 33 21 20 6 7 33 21 33 53 54 53 53 35 53 51 17 52 54 2 170 190 170 61 154 143 123 125 1 166 254 90 65 74 3 27 251 251 205 198 198 224 5 201 84 133 77 124 140 254 217 127 221 100 136 44 154 141 47 244 223 127 1 60 178 205 0 0 2 0 123 1 6 4 23 4 160 0 27 0 39 0 32 64 13 28 0 34 14 0 14 40 41 31 21 21 37 7 0 47 51 51 47 51 17 18 1 57 57 17 51 17 51 49 48 19 52 55 39 55 23 54 51 50 23 55 23 7 22 21 20 7 23 7 39 6 35 34 39 7 39 55 38 55 20 22 51 50 54 53 52 38 35 34 6 184 74 135 94 135 104 130 127 102 137 95 134 74 74 131 92 137 102 127 134 100 135 92 133 74 129 157 116 116 158 160 114 116 157 2 211 122 107 140 92 133 73 73 133 92 138 113 118 131 103 135 92 133 71 73 133 92 136 107 124 112 160 159 113 114 162 164 0 0 1 0 31 0 0 4 113 5 182 0 22 0 86 64 46 18 14 7 11 11 16 12 5 9 2 9 3 12 20 14 21 7 23 24 10 14 14 7 15 6 18 18 3 0 19 21 15 19 31 19 2 15 19 15 19 12 1 21 6 12 24 0 63 63 51 18 57 57 47 47 93 17 18 57 50 50 17 51 17 51 51 17 51 17 18 1 23 57 17 51 17 51 51 17 51 17 51 49 48 1 1 51 1 33 21 33 21 33 21 33 17 35 17 33 53 33 53 33 53 33 1 51 2 72 1 123 174 254 96 1 6 254 195 1 61 254 195 164 254 196 1 60 254 196 1 0 254 101 178 2 223 2 215 252 254 127 170 127 254 244 1 12 127 170 127 3 2 0 2 1 238 254 16 2 123 6 20 0 3 0 7 0 36 64 16 2 6 6 3 7 7 8 9 4 3 4 3 7 27 0 0 0 63 63 57 57 47 47 17 18 1 57 17 51 51 17 51 49 48 1 51 17 35 17 51 17 35 1 238 141 141 141 141 6 20 252 248 254 13 252 247 0 2 0 123 255 248 3 150 6 29 0 49 0 61 0 67 64 38 50 0 19 6 42 30 56 25 25 30 12 6 0 35 6 62 63 21 3 59 54 28 45 6 33 9 33 39 71 89 33 21 9 16 71 89 9 0 0 63 43 0 24 63 43 17 18 0 23 57 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 19 52 54 55 38 38 53 52 54 51 50 22 23 7 38 38 35 34 6 21 20 22 23 22 22 21 20 6 7 22 21 20 6 35 34 39 53 22 22 51 50 54 53 52 38 38 39 46 2 55 20 22 23 23 54 53 52 38 39 6 6 139 86 78 74 84 207 197 94 159 97 53 98 135 76 116 116 123 154 186 150 82 74 153 234 212 218 128 78 194 82 134 141 48 108 115 142 134 66 146 132 167 49 137 147 185 68 85 3 41 86 137 37 40 111 85 121 139 29 39 131 39 27 59 64 60 84 55 68 151 107 90 141 41 81 146 140 153 65 148 37 45 76 71 46 58 58 43 52 90 114 98 77 105 61 19 80 111 83 112 57 19 100 0 2 1 53 5 14 3 104 5 211 0 11 0 23 0 30 64 12 6 0 12 18 0 18 24 25 15 3 21 9 0 47 51 205 50 17 18 1 57 57 17 51 17 51 49 48 1 52 54 51 50 22 21 20 6 35 34 38 37 52 54 51 50 22 21 20 6 35 34 38 1 53 53 37 38 55 55 38 37 53 1 125 53 37 37 55 55 37 37 53 5 113 52 46 46 52 50 49 49 50 52 46 46 52 50 49 49 0 0 3 0 100 255 236 6 68 5 203 0 22 0 38 0 54 0 70 64 39 39 23 3 15 47 31 31 20 9 15 23 5 55 56 6 12 0 18 15 12 31 12 2 0 18 16 18 2 12 18 12 18 27 43 35 19 51 27 4 0 63 51 63 51 18 57 57 47 47 93 93 17 51 17 51 17 18 1 23 57 17 51 17 51 17 51 49 48 1 34 6 21 20 22 51 50 55 21 6 6 35 34 38 53 52 54 51 50 23 7 38 1 52 18 36 51 50 4 18 21 20 2 4 35 34 36 2 55 20 18 4 51 50 36 18 53 52 2 36 35 34 4 2 3 125 125 135 127 131 86 125 48 101 70 194 208 221 191 128 118 58 108 252 151 200 1 94 202 200 1 94 202 194 254 162 208 207 254 162 195 105 174 1 45 172 174 1 42 175 174 254 215 176 174 254 214 175 4 35 174 154 168 162 45 124 20 28 241 216 209 246 60 118 51 254 184 200 1 94 202 200 254 162 202 197 254 166 208 207 1 90 198 173 254 211 173 174 1 41 176 174 1 42 175 174 254 215 0 0 2 0 70 3 20 2 113 5 199 0 22 0 31 0 55 64 28 23 6 27 10 1 1 22 22 16 6 3 32 33 28 10 10 18 25 22 0 3 16 3 2 3 13 18 31 0 63 51 212 93 196 51 18 57 47 51 17 18 1 23 57 17 51 17 51 51 17 51 49 48 1 39 6 35 34 38 53 52 54 55 55 53 52 35 34 7 39 54 51 50 22 21 17 37 20 51 50 53 53 7 6 6 2 20 24 92 140 95 111 154 165 117 148 100 104 43 114 133 130 137 254 80 112 201 98 112 103 3 33 84 97 99 102 102 105 6 4 39 133 51 96 56 105 121 254 60 188 100 180 49 4 4 57 0 2 0 82 0 117 3 170 3 190 0 6 0 13 0 41 64 19 3 6 10 13 2 4 11 9 9 4 13 6 4 14 15 12 5 8 1 0 47 51 47 51 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 19 1 23 1 1 7 1 37 1 23 1 1 7 1 82 1 86 119 254 223 1 33 119 254 170 1 139 1 88 117 254 225 1 31 117 254 168 2 39 1 151 69 254 162 254 161 71 1 151 27 1 151 69 254 162 254 161 71 1 151 0 0 1 0 104 1 8 4 41 3 23 0 5 0 27 64 12 2 1 4 1 6 7 5 4 80 89 5 2 0 47 47 43 17 18 1 57 57 17 51 49 48 1 17 35 17 33 53 4 41 137 252 200 3 23 253 241 1 133 138 0 255 255 0 84 1 217 2 63 2 113 2 6 0 16 0 0 0 4 0 100 255 236 6 68 5 203 0 8 0 22 0 38 0 54 0 93 64 51 39 23 0 17 17 18 4 9 47 31 31 13 9 12 18 23 6 55 56 12 16 16 0 0 14 19 14 18 8 19 15 18 31 18 2 0 19 16 19 2 18 19 18 19 27 43 35 19 51 27 4 0 63 51 63 51 18 57 57 47 47 93 93 17 51 17 51 17 18 57 47 51 17 51 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 49 48 1 51 50 54 53 52 38 35 35 5 20 6 7 19 35 3 35 17 35 17 33 50 22 1 52 18 36 51 50 4 18 21 20 2 4 35 34 36 2 55 20 18 4 51 50 36 18 53 52 2 36 35 34 4 2 2 211 108 80 97 86 93 106 1 178 85 77 238 168 207 135 148 1 5 166 155 251 223 200 1 94 202 200 1 94 202 194 254 162 208 207 254 162 195 105 174 1 45 172 174 1 42 175 174 254 215 176 174 254 214 175 2 250 83 64 75 65 136 80 123 30 254 117 1 98 254 158 3 123 130 254 197 200 1 94 202 200 254 162 202 197 254 166 208 207 1 90 198 173 254 211 173 174 1 41 176 174 1 42 175 174 254 215 0 1 255 250 6 20 4 6 6 147 0 3 0 17 181 0 5 1 4 1 2 0 47 51 17 1 51 17 51 49 48 1 33 53 33 4 6 251 244 4 12 6 20 127 0 2 0 127 3 92 2 238 5 203 0 12 0 24 0 33 64 14 13 0 19 6 0 6 25 26 16 10 192 22 3 4 0 63 51 26 204 50 17 18 1 57 57 17 51 17 51 49 48 19 52 54 51 50 22 21 20 6 6 35 34 38 55 20 22 51 50 54 53 52 38 35 34 6 127 181 130 130 182 82 146 84 130 181 115 117 81 80 115 113 82 83 115 4 147 130 182 181 131 84 143 84 180 131 82 114 113 83 84 113 114 0 255 255 0 104 0 1 4 41 4 195 2 38 0 14 0 0 0 7 2 43 0 0 253 116 0 1 0 49 2 74 2 141 5 201 0 24 0 35 64 17 7 19 23 1 1 14 19 0 4 26 25 10 16 31 23 1 32 0 63 51 63 51 17 18 1 23 57 17 51 17 51 49 48 1 33 53 55 62 2 53 52 38 35 34 6 7 39 54 51 50 22 21 20 6 7 7 33 2 141 253 164 236 89 82 33 80 63 52 98 69 66 131 152 132 147 89 147 174 1 184 2 74 104 230 86 97 76 54 68 69 38 50 88 111 130 112 80 151 138 165 0 1 0 33 2 57 2 141 5 201 0 35 0 57 64 34 15 5 5 0 3 18 30 10 6 36 37 18 93 19 109 19 2 76 19 1 11 19 27 19 2 19 19 8 26 33 31 13 8 33 0 63 51 63 51 18 57 47 93 93 93 51 17 18 1 23 57 17 51 49 48 1 20 6 7 22 21 20 6 35 34 39 53 22 51 50 53 52 35 35 53 51 50 54 53 52 38 35 34 6 7 39 54 54 51 50 22 2 115 82 68 176 184 168 152 116 147 123 211 231 117 119 103 99 80 67 66 112 56 69 63 140 94 136 157 4 231 80 103 23 47 162 128 143 56 123 68 162 145 107 79 68 61 68 43 35 90 45 54 119 0 1 1 137 4 217 3 18 6 33 0 9 0 19 182 9 4 10 11 4 128 9 0 47 26 205 17 18 1 57 57 49 48 1 54 54 55 51 21 6 6 7 35 1 137 48 111 32 202 44 174 64 111 4 242 62 176 65 21 65 190 52 0 1 0 176 254 20 4 68 4 72 0 22 0 53 64 26 5 10 10 8 16 0 19 19 20 8 20 24 23 6 21 15 20 27 13 2 70 89 13 22 9 21 0 63 63 43 0 24 63 63 51 17 18 1 57 57 17 51 17 51 51 17 51 17 51 49 48 1 16 51 50 54 53 17 51 17 35 39 35 6 35 34 39 35 22 21 17 35 17 51 1 86 254 171 159 166 136 26 10 111 229 150 88 10 10 166 166 1 125 254 250 189 212 2 64 251 184 147 167 92 84 160 254 192 6 52 0 1 0 113 254 252 4 96 6 20 0 15 0 39 64 18 4 5 1 0 0 5 11 3 16 17 8 8 5 3 15 5 1 5 0 47 51 63 51 18 57 47 17 18 1 23 57 17 51 17 51 49 48 1 35 17 35 17 35 17 6 35 34 38 53 16 54 51 33 4 96 114 213 115 62 84 216 203 218 232 2 45 254 252 6 176 249 80 3 51 18 250 251 1 4 254 0 1 0 152 2 76 1 137 3 90 0 11 0 23 64 10 6 0 0 13 12 3 9 79 89 3 0 47 43 17 18 1 57 17 51 49 48 19 52 54 51 50 22 21 20 6 35 34 38 152 62 56 58 65 66 57 51 67 2 211 66 69 69 66 65 70 63 0 0 1 0 37 254 20 1 180 0 0 0 18 0 36 64 16 17 14 11 0 0 14 5 3 19 20 14 17 17 8 3 16 0 47 204 50 57 47 51 17 18 1 23 57 17 51 17 51 49 48 1 20 6 35 34 39 53 22 51 50 54 53 52 38 39 55 51 7 22 1 180 153 150 51 45 45 59 79 81 79 109 88 110 55 180 254 223 97 106 9 106 8 40 54 43 53 17 178 115 39 0 1 0 76 2 74 1 225 5 182 0 10 0 32 64 14 2 0 3 3 10 12 11 9 9 3 32 6 0 30 0 63 50 63 57 47 17 18 1 57 57 17 51 51 49 48 1 51 17 35 17 52 55 6 6 7 39 1 82 143 133 6 22 54 135 67 5 182 252 148 2 67 91 90 22 45 95 96 0 2 0 66 3 20 2 190 5 199 0 11 0 23 0 37 64 18 12 6 18 0 6 0 24 25 15 0 3 16 3 2 3 21 9 31 0 63 51 196 93 50 17 18 1 57 57 17 51 17 51 49 48 1 20 6 35 34 38 53 52 54 51 50 22 5 20 22 51 50 54 53 52 38 35 34 6 2 190 171 150 146 169 168 151 152 165 253 254 91 104 105 92 92 105 103 92 4 111 164 183 186 161 163 181 182 162 122 122 122 122 123 118 118 0 2 0 80 0 117 3 168 3 190 0 6 0 13 0 35 64 17 11 9 4 2 0 3 7 2 10 9 6 14 15 12 5 8 1 0 47 51 47 51 17 18 1 23 57 17 51 17 51 49 48 1 1 39 1 1 55 1 5 1 39 1 1 55 1 3 168 254 168 117 1 31 254 225 117 1 88 254 117 254 168 117 1 31 254 225 117 1 88 2 12 254 105 71 1 95 1 94 69 254 105 27 254 105 71 1 95 1 94 69 254 105 255 255 0 75 0 0 5 209 5 182 0 39 2 23 2 131 0 0 0 38 0 123 255 0 1 7 2 60 3 29 253 183 0 9 179 3 2 18 24 0 63 53 53 0 255 255 0 46 0 0 5 219 5 182 0 39 2 23 2 63 0 0 0 38 0 123 226 0 1 7 0 116 3 78 253 183 0 7 178 2 16 24 0 63 53 0 255 255 0 26 0 0 6 33 5 201 0 38 0 117 249 0 0 39 2 23 2 223 0 0 1 7 2 60 3 109 253 183 0 9 179 3 2 43 24 0 63 53 53 0 0 2 0 51 254 119 3 84 4 94 0 29 0 40 0 65 64 34 8 20 30 35 1 28 15 28 35 20 4 41 42 0 29 1 12 3 29 29 17 38 38 32 79 89 38 16 17 11 73 89 17 35 0 63 43 0 24 63 43 17 18 0 57 24 47 95 94 93 17 18 1 23 57 17 51 17 51 17 51 49 48 1 21 20 6 7 14 2 21 20 22 51 50 54 55 23 6 35 34 38 53 52 62 2 55 54 54 53 53 19 20 35 34 38 53 52 54 51 50 22 2 78 75 97 121 61 25 132 122 80 150 98 59 197 198 190 216 35 64 89 54 101 65 180 121 59 62 66 55 51 70 2 172 51 122 148 84 106 75 77 56 100 113 38 48 135 96 186 170 70 105 89 82 47 88 116 93 31 1 43 135 69 66 64 71 64 255 255 0 0 0 0 5 16 7 115 2 38 0 36 0 0 1 7 0 67 255 194 1 82 0 8 179 2 16 5 38 0 43 53 255 255 0 0 0 0 5 16 7 115 2 38 0 36 0 0 1 7 0 118 0 133 1 82 0 8 179 2 24 5 38 0 43 53 255 255 0 0 0 0 5 16 7 115 2 38 0 36 0 0 1 7 1 75 0 35 1 82 0 8 179 2 29 5 38 0 43 53 255 255 0 0 0 0 5 16 7 47 2 38 0 36 0 0 1 7 1 82 0 4 1 82 0 8 179 2 24 5 38 0 43 53 255 255 0 0 0 0 5 16 7 37 2 38 0 36 0 0 1 7 0 106 0 55 1 82 0 10 180 3 2 36 5 38 0 43 53 53 255 255 0 0 0 0 5 16 7 6 2 38 0 36 0 0 0 7 1 80 0 57 0 129 0 2 255 254 0 0 6 129 5 182 0 15 0 19 0 78 64 44 10 14 14 17 1 0 8 12 1 16 5 5 21 5 20 9 19 6 19 73 89 16 3 73 89 10 13 73 89 16 10 16 10 1 6 3 5 18 1 14 73 89 1 18 0 63 43 0 24 63 63 18 57 57 47 47 43 43 43 17 0 51 17 1 51 17 18 23 57 17 51 51 17 51 49 48 33 33 17 33 3 35 1 33 21 33 17 33 21 33 17 33 1 33 17 35 6 129 253 18 253 254 227 176 2 186 3 201 253 188 2 29 253 227 2 68 251 84 1 190 118 1 209 254 47 5 182 151 254 41 150 253 230 1 210 2 181 0 255 255 0 125 254 20 4 207 5 203 2 38 0 38 0 0 0 7 0 122 2 2 0 0 255 255 0 201 0 0 3 248 7 115 2 38 0 40 0 0 1 7 0 67 255 183 1 82 0 8 179 1 13 5 38 0 43 53 255 255 0 201 0 0 3 248 7 115 2 38 0 40 0 0 1 7 0 118 0 63 1 82 0 8 179 1 21 5 38 0 43 53 255 255 0 201 0 0 3 248 7 115 2 38 0 40 0 0 1 7 1 75 255 251 1 82 0 8 179 1 26 5 38 0 43 53 255 255 0 201 0 0 3 248 7 37 2 38 0 40 0 0 1 7 0 106 0 18 1 82 0 10 180 2 1 33 5 38 0 43 53 53 255 255 0 60 0 0 2 86 7 115 2 38 0 44 0 0 1 7 0 67 254 179 1 82 0 8 179 1 13 5 38 0 43 53 255 255 0 84 0 0 2 115 7 115 2 38 0 44 0 0 1 7 0 118 255 97 1 82 0 8 179 1 21 5 38 0 43 53 255 255 255 255 0 0 2 161 7 115 2 38 0 44 0 0 1 7 1 75 254 243 1 82 0 8 179 1 26 5 38 0 43 53 255 255 0 60 0 0 2 111 7 37 2 38 0 44 0 0 1 7 0 106 255 7 1 82 0 10 180 2 1 33 5 38 0 43 53 53 0 2 0 47 0 0 5 72 5 182 0 12 0 23 0 87 64 50 17 21 21 8 4 13 0 0 19 4 6 4 24 25 20 6 7 6 73 89 17 15 7 63 7 175 7 207 7 223 7 5 11 3 7 7 4 9 9 16 74 89 9 3 4 21 74 89 4 18 0 63 43 0 24 63 43 17 18 0 57 24 47 95 94 93 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 49 48 1 16 0 33 33 17 35 53 51 17 33 32 0 3 16 33 35 17 33 21 33 17 51 32 5 72 254 119 254 143 254 123 154 154 1 178 1 81 1 124 181 253 199 231 1 123 254 133 190 2 98 2 233 254 150 254 129 2 137 150 2 151 254 137 254 164 2 64 253 252 150 254 10 255 255 0 201 0 0 5 63 7 47 2 38 0 49 0 0 1 7 1 82 0 147 1 82 0 8 179 1 26 5 38 0 43 53 255 255 0 125 255 236 5 190 7 115 2 38 0 50 0 0 1 7 0 67 0 121 1 82 0 8 179 2 25 5 38 0 43 53 255 255 0 125 255 236 5 190 7 115 2 38 0 50 0 0 1 7 0 118 1 10 1 82 0 8 179 2 33 5 38 0 43 53 255 255 0 125 255 236 5 190 7 115 2 38 0 50 0 0 1 7 1 75 0 180 1 82 0 8 179 2 38 5 38 0 43 53 255 255 0 125 255 236 5 190 7 47 2 38 0 50 0 0 1 7 1 82 0 154 1 82 0 8 179 2 33 5 38 0 43 53 255 255 0 125 255 236 5 190 7 37 2 38 0 50 0 0 1 7 0 106 0 213 1 82 0 10 180 3 2 45 5 38 0 43 53 53 0 1 0 133 1 16 4 12 4 152 0 11 0 25 64 9 7 9 3 1 9 1 12 13 8 0 25 47 17 18 1 57 57 17 51 17 51 49 48 1 23 1 1 7 1 1 39 1 1 55 1 3 172 96 254 160 1 94 96 254 158 254 164 101 1 94 254 160 100 1 97 4 152 99 254 158 254 160 99 1 95 254 161 99 1 96 1 96 101 254 157 0 0 3 0 125 255 195 5 190 5 246 0 19 0 27 0 35 0 78 64 44 22 31 23 30 4 28 20 28 10 20 0 0 18 15 5 8 10 6 36 37 22 30 33 25 13 33 73 89 15 18 8 5 4 3 16 13 4 3 25 73 89 6 3 19 0 63 198 43 0 24 63 198 18 23 57 43 17 18 0 57 57 17 18 1 23 57 17 51 17 51 17 18 23 57 49 48 1 16 0 33 34 39 7 39 55 38 17 16 0 33 50 23 55 23 7 22 3 16 39 1 22 51 50 18 1 16 23 1 38 35 34 2 5 190 254 157 254 196 235 148 101 120 108 178 1 96 1 68 209 157 97 120 106 192 180 110 253 96 115 176 243 248 252 39 101 2 157 106 168 243 253 2 221 254 161 254 110 100 141 79 154 198 1 109 1 101 1 137 94 135 80 148 202 254 149 1 16 154 252 76 82 1 50 1 42 254 250 154 3 175 73 254 205 0 255 255 0 186 255 236 5 25 7 115 2 38 0 56 0 0 1 7 0 67 0 70 1 82 0 8 179 1 19 5 38 0 43 53 255 255 0 186 255 236 5 25 7 115 2 38 0 56 0 0 1 7 0 118 0 207 1 82 0 8 179 1 27 5 38 0 43 53 255 255 0 186 255 236 5 25 7 115 2 38 0 56 0 0 1 7 1 75 0 125 1 82 0 8 179 1 32 5 38 0 43 53 255 255 0 186 255 236 5 25 7 37 2 38 0 56 0 0 1 7 0 106 0 152 1 82 0 10 180 2 1 39 5 38 0 43 53 53 255 255 0 0 0 0 4 123 7 115 2 38 0 60 0 0 1 7 0 118 0 49 1 82 0 8 179 1 18 5 38 0 43 53 0 2 0 201 0 0 4 121 5 182 0 12 0 21 0 54 64 28 13 9 5 5 6 17 0 6 0 22 23 13 4 74 89 9 21 74 89 13 9 13 9 6 7 3 6 18 0 63 63 18 57 57 47 47 43 43 17 18 1 57 57 17 51 17 51 17 51 51 49 48 1 20 4 33 35 17 35 17 51 17 51 32 4 1 51 50 54 53 52 38 35 35 4 121 254 209 254 225 184 170 170 215 1 25 1 22 252 250 168 226 202 190 202 204 3 16 227 238 254 193 5 182 255 0 207 253 234 143 164 149 138 0 0 1 0 176 255 236 4 156 6 31 0 48 0 65 64 34 41 42 5 29 35 0 23 12 12 0 29 17 42 5 49 50 18 18 42 46 46 38 70 89 46 0 42 21 15 21 70 89 15 22 0 63 43 0 24 63 63 43 17 18 0 57 24 47 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 20 7 6 6 21 20 22 22 23 22 22 21 20 6 35 34 39 53 22 22 51 50 53 52 38 39 38 38 53 52 54 55 54 54 53 52 38 35 32 21 17 35 17 52 54 51 50 22 4 25 143 88 56 27 71 78 140 102 194 179 188 107 63 156 72 215 83 110 127 96 69 71 75 64 136 127 254 236 166 220 222 206 225 4 242 135 115 70 67 33 32 42 57 51 95 157 101 160 171 69 154 39 47 182 75 107 70 82 123 84 63 106 53 57 90 53 80 85 223 251 76 4 178 178 187 157 255 255 0 94 255 236 3 205 6 33 2 38 0 68 0 0 1 6 0 67 142 0 0 8 179 2 38 17 38 0 43 53 255 255 0 94 255 236 3 205 6 33 2 38 0 68 0 0 1 6 0 118 43 0 0 8 179 2 46 17 38 0 43 53 255 255 0 94 255 236 3 205 6 33 2 38 0 68 0 0 1 6 1 75 216 0 0 8 179 2 51 17 38 0 43 53 255 255 0 94 255 236 3 205 5 221 2 38 0 68 0 0 1 6 1 82 189 0 0 8 179 2 46 17 38 0 43 53 255 255 0 94 255 236 3 205 5 211 2 38 0 68 0 0 1 6 0 106 226 0 0 10 180 3 2 58 17 38 0 43 53 53 255 255 0 94 255 236 3 205 6 133 2 38 0 68 0 0 1 6 1 80 247 0 0 10 180 3 2 40 17 38 0 43 53 53 0 3 0 94 255 236 6 115 4 92 0 41 0 52 0 59 0 97 64 51 42 0 36 17 48 56 25 25 4 48 57 24 24 31 48 11 0 5 60 61 27 45 39 45 70 89 25 49 4 49 71 89 56 36 39 17 4 4 14 34 39 22 53 8 14 8 70 89 20 14 16 0 63 51 43 17 0 51 24 63 51 18 57 47 57 18 57 51 43 17 0 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 18 57 57 17 51 49 48 19 52 54 55 55 53 52 38 35 34 7 39 54 54 51 50 22 23 54 54 51 50 18 21 21 33 18 33 50 54 55 21 6 6 35 32 39 6 6 35 34 38 55 20 22 51 50 54 53 53 7 6 6 1 34 6 7 33 52 38 94 248 254 184 116 119 144 163 52 74 199 98 130 165 41 53 171 110 192 232 253 67 8 1 58 91 157 84 86 149 101 254 223 125 81 197 134 163 185 174 107 88 145 168 158 186 164 3 189 121 139 11 2 7 128 1 47 161 179 8 6 68 129 123 84 127 41 53 87 95 88 96 254 245 222 107 254 117 35 39 148 38 33 233 127 106 170 151 95 89 169 154 99 7 8 109 2 50 166 158 156 168 0 255 255 0 115 254 20 3 139 4 92 2 38 0 70 0 0 0 7 0 122 1 70 0 0 255 255 0 115 255 236 4 18 6 33 2 38 0 72 0 0 1 6 0 67 181 0 0 8 179 2 28 17 38 0 43 53 255 255 0 115 255 236 4 18 6 33 2 38 0 72 0 0 1 6 0 118 78 0 0 8 179 2 36 17 38 0 43 53 255 255 0 115 255 236 4 18 6 33 2 38 0 72 0 0 1 6 1 75 247 0 0 8 179 2 41 17 38 0 43 53 255 255 0 115 255 236 4 18 5 211 2 38 0 72 0 0 1 6 0 106 10 0 0 10 180 3 2 48 17 38 0 43 53 53 255 255 255 218 0 0 1 99 6 33 2 38 0 243 0 0 1 7 0 67 254 81 0 0 0 8 179 1 5 17 38 0 43 53 255 255 0 169 0 0 2 50 6 33 2 38 0 243 0 0 1 7 0 118 255 32 0 0 0 8 179 1 13 17 38 0 43 53 255 255 255 179 0 0 2 85 6 33 2 38 0 243 0 0 1 7 1 75 254 167 0 0 0 8 179 1 18 17 38 0 43 53 255 255 255 236 0 0 2 31 5 211 2 38 0 243 0 0 1 7 0 106 254 183 0 0 0 10 180 2 1 25 17 38 0 43 53 53 0 2 0 113 255 236 4 98 6 33 0 27 0 38 0 74 64 43 33 6 12 28 28 0 0 24 25 22 14 17 19 16 6 9 39 40 9 31 70 89 11 3 22 17 25 14 15 5 20 9 9 3 23 20 1 3 36 70 89 3 22 0 63 43 0 24 63 51 18 57 47 18 23 57 18 57 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 16 0 35 34 0 53 52 0 51 50 23 55 38 39 5 39 55 38 39 55 22 23 55 23 7 22 18 3 52 38 35 32 17 20 22 51 50 54 4 98 254 251 247 222 254 233 1 7 220 226 100 8 57 205 254 241 73 233 92 94 69 156 102 238 76 207 152 165 168 180 156 254 175 175 162 175 161 2 51 254 231 254 210 1 13 226 230 1 6 121 4 214 191 155 108 133 62 49 117 73 75 138 107 119 143 254 114 254 232 147 170 254 152 167 183 201 0 255 255 0 176 0 0 4 68 5 221 2 38 0 81 0 0 1 6 1 82 14 0 0 8 179 1 30 17 38 0 43 53 255 255 0 115 255 236 4 98 6 33 2 38 0 82 0 0 1 6 0 67 212 0 0 8 179 2 26 17 38 0 43 53 255 255 0 115 255 236 4 98 6 33 2 38 0 82 0 0 1 6 0 118 86 0 0 8 179 2 34 17 38 0 43 53 255 255 0 115 255 236 4 98 6 33 2 38 0 82 0 0 1 6 1 75 14 0 0 8 179 2 39 17 38 0 43 53 255 255 0 115 255 236 4 98 5 221 2 38 0 82 0 0 1 6 1 82 241 0 0 8 179 2 34 17 38 0 43 53 255 255 0 115 255 236 4 98 5 211 2 38 0 82 0 0 1 6 0 106 27 0 0 10 180 3 2 46 17 38 0 43 53 53 0 3 0 104 0 252 4 41 4 168 0 3 0 15 0 27 0 51 64 24 22 10 10 16 4 2 4 1 3 28 29 25 19 19 1 7 13 13 1 1 0 80 89 1 0 47 43 17 0 51 24 47 51 17 51 47 51 17 18 1 23 57 17 51 51 17 51 49 48 19 53 33 21 1 52 54 51 50 22 21 20 6 35 34 38 17 52 54 51 50 22 21 20 6 35 34 38 104 3 193 253 174 59 54 52 58 59 51 52 61 59 54 52 58 59 51 52 61 2 141 138 138 254 232 60 61 63 58 57 64 63 2 244 60 61 63 58 57 64 63 0 3 0 115 255 188 4 98 4 135 0 19 0 27 0 35 0 75 64 41 23 31 28 20 20 10 28 0 0 18 15 5 8 10 6 36 37 22 30 33 25 13 25 70 89 15 18 8 5 4 3 16 13 16 3 33 70 89 6 3 22 0 63 198 43 0 24 63 198 18 23 57 43 17 18 0 57 57 17 18 1 23 57 17 51 17 51 17 18 57 57 49 48 1 16 0 35 34 39 7 39 55 38 17 16 0 51 50 23 55 23 7 22 5 20 23 1 38 35 34 6 5 52 39 1 22 51 50 54 4 98 254 242 238 154 112 84 114 94 129 1 12 238 154 116 84 117 97 127 252 189 53 1 209 75 114 163 166 2 151 51 254 47 71 113 163 169 2 37 254 244 254 211 69 117 78 131 152 1 0 1 12 1 43 76 119 76 133 152 249 171 102 2 134 53 214 212 164 100 253 125 51 219 0 255 255 0 164 255 236 4 57 6 33 2 38 0 88 0 0 1 6 0 67 196 0 0 8 179 1 22 17 38 0 43 53 255 255 0 164 255 236 4 57 6 33 2 38 0 88 0 0 1 6 0 118 113 0 0 8 179 1 30 17 38 0 43 53 255 255 0 164 255 236 4 57 6 33 2 38 0 88 0 0 1 6 1 75 18 0 0 8 179 1 35 17 38 0 43 53 255 255 0 164 255 236 4 57 5 211 2 38 0 88 0 0 1 6 0 106 33 0 0 10 180 2 1 42 17 38 0 43 53 53 255 255 0 2 254 20 4 6 6 33 2 38 0 92 0 0 1 6 0 118 18 0 0 8 179 1 31 17 38 0 43 53 0 2 0 176 254 20 4 117 6 20 0 22 0 34 0 62 64 31 32 6 27 20 16 16 17 6 17 36 35 18 0 17 27 12 22 9 3 9 30 70 89 9 22 3 23 70 89 3 16 0 63 43 0 24 63 43 17 18 0 57 57 24 63 63 17 18 1 57 57 17 51 17 51 51 17 51 49 48 1 54 54 51 50 18 17 16 2 35 34 39 35 23 22 21 17 35 17 51 17 20 7 37 34 6 7 21 20 22 51 32 17 52 38 1 88 66 170 106 215 240 241 214 222 122 12 4 8 166 166 6 1 72 168 152 2 154 170 1 47 148 3 180 89 79 254 212 254 245 254 244 254 211 161 34 77 63 254 53 8 0 254 46 52 90 27 184 201 41 231 199 1 176 215 209 255 255 0 2 254 20 4 6 5 211 2 38 0 92 0 0 1 6 0 106 181 0 0 10 180 2 1 43 17 38 0 43 53 53 255 255 0 0 0 0 5 16 6 180 2 38 0 36 0 0 1 7 1 77 0 63 1 82 0 8 179 2 18 5 38 0 43 53 255 255 0 94 255 236 3 205 5 98 2 38 0 68 0 0 1 6 1 77 245 0 0 8 179 2 40 17 38 0 43 53 255 255 0 0 0 0 5 16 7 55 2 38 0 36 0 0 1 7 1 78 0 43 1 82 0 8 179 2 15 5 38 0 43 53 255 255 0 94 255 236 3 205 5 229 2 38 0 68 0 0 1 6 1 78 228 0 0 8 179 2 37 17 38 0 43 53 255 255 0 0 254 66 5 17 5 188 2 38 0 36 0 0 0 7 1 81 3 160 0 0 255 255 0 94 254 66 4 0 4 90 2 38 0 68 0 0 0 7 1 81 2 143 0 0 255 255 0 125 255 236 4 207 7 115 2 38 0 38 0 0 1 7 0 118 1 8 1 82 0 8 179 1 32 5 38 0 43 53 255 255 0 115 255 236 3 139 6 33 2 38 0 70 0 0 1 6 0 118 68 0 0 8 179 1 32 17 38 0 43 53 255 255 0 125 255 236 4 207 7 115 2 38 0 38 0 0 1 7 1 75 0 172 1 82 0 8 179 1 37 5 38 0 43 53 255 255 0 115 255 236 3 139 6 33 2 38 0 70 0 0 1 6 1 75 212 0 0 8 179 1 37 17 38 0 43 53 255 255 0 125 255 236 4 207 7 49 2 38 0 38 0 0 1 7 1 79 2 27 1 82 0 8 179 1 32 5 38 0 43 53 255 255 0 115 255 236 3 139 5 223 2 38 0 70 0 0 1 7 1 79 1 80 0 0 0 8 179 1 32 17 38 0 43 53 255 255 0 125 255 236 4 207 7 115 2 38 0 38 0 0 1 7 1 76 0 193 1 82 0 8 179 1 34 5 38 0 43 53 255 255 0 115 255 236 3 161 6 33 2 38 0 70 0 0 1 6 1 76 243 0 0 8 179 1 34 17 38 0 43 53 255 255 0 201 0 0 5 88 7 115 2 38 0 39 0 0 1 7 1 76 0 88 1 82 0 8 179 2 29 5 38 0 43 53 255 255 0 115 255 236 5 129 6 20 2 38 0 71 0 0 1 7 2 56 3 12 0 0 0 7 178 2 35 0 0 63 53 0 255 255 0 47 0 0 5 72 5 182 2 6 0 146 0 0 0 2 0 115 255 236 4 211 6 20 0 26 0 39 0 100 64 55 37 6 18 14 0 30 30 21 25 22 25 16 6 4 40 41 26 21 24 16 17 16 71 89 21 15 17 31 17 47 17 3 9 3 17 17 9 19 0 1 12 3 9 9 34 70 89 9 16 3 27 70 89 3 22 0 63 43 0 24 63 43 17 18 0 57 57 24 63 18 57 47 95 94 93 51 43 17 0 51 24 63 17 18 1 23 57 17 51 51 17 51 51 51 17 51 49 48 37 35 6 35 34 2 17 16 18 51 50 23 51 38 53 53 33 53 33 53 51 21 51 21 35 17 35 37 50 54 53 53 52 38 35 34 6 21 20 22 3 154 9 115 229 215 239 240 214 223 119 13 11 254 64 1 192 166 156 156 135 254 158 170 153 155 170 146 155 154 147 167 1 38 1 15 1 15 1 44 162 83 73 133 129 184 184 129 251 37 119 185 206 35 233 199 227 207 210 214 255 255 0 201 0 0 3 248 6 180 2 38 0 40 0 0 1 7 1 77 0 18 1 82 0 8 179 1 15 5 38 0 43 53 255 255 0 115 255 236 4 18 5 98 2 38 0 72 0 0 1 6 1 77 10 0 0 8 179 2 30 17 38 0 43 53 255 255 0 201 0 0 3 248 7 55 2 38 0 40 0 0 1 7 1 78 0 16 1 82 0 8 179 1 12 5 38 0 43 53 255 255 0 115 255 236 4 18 5 229 2 38 0 72 0 0 1 6 1 78 251 0 0 8 179 2 27 17 38 0 43 53 255 255 0 201 0 0 3 248 7 20 2 38 0 40 0 0 1 7 1 79 1 111 1 53 0 8 179 1 21 5 38 0 43 53 255 255 0 115 255 236 4 18 5 223 2 38 0 72 0 0 1 7 1 79 1 84 0 0 0 8 179 2 36 17 38 0 43 53 255 255 0 201 254 66 3 248 5 182 2 38 0 40 0 0 0 7 1 81 2 115 0 0 255 255 0 115 254 97 4 18 4 92 2 38 0 72 0 0 0 7 1 81 2 102 0 31 255 255 0 201 0 0 3 248 7 115 2 38 0 40 0 0 1 7 1 76 0 16 1 82 0 8 179 1 23 5 38 0 43 53 255 255 0 115 255 236 4 18 6 33 2 38 0 72 0 0 1 6 1 76 251 0 0 8 179 2 38 17 38 0 43 53 255 255 0 125 255 236 5 61 7 115 2 38 0 42 0 0 1 7 1 75 0 233 1 82 0 8 179 1 42 5 38 0 43 53 255 255 0 39 254 20 4 49 6 33 2 38 0 74 0 0 1 6 1 75 202 0 0 8 179 3 80 17 38 0 43 53 255 255 0 125 255 236 5 61 7 55 2 38 0 42 0 0 1 7 1 78 1 0 1 82 0 8 179 1 28 5 38 0 43 53 255 255 0 39 254 20 4 49 5 229 2 38 0 74 0 0 1 6 1 78 206 0 0 8 179 3 66 17 38 0 43 53 255 255 0 125 255 236 5 61 7 49 2 38 0 42 0 0 1 7 1 79 2 100 1 82 0 8 179 1 37 5 38 0 43 53 255 255 0 39 254 20 4 49 5 223 2 38 0 74 0 0 1 7 1 79 1 31 0 0 0 8 179 3 75 17 38 0 43 53 255 255 0 125 254 59 5 61 5 203 2 38 0 42 0 0 0 7 2 57 1 39 0 0 255 255 0 39 254 20 4 49 6 33 2 38 0 74 0 0 1 6 2 58 68 0 0 8 179 3 70 17 38 0 43 53 255 255 0 201 0 0 5 31 7 115 2 38 0 43 0 0 1 7 1 75 0 150 1 82 0 8 179 1 26 5 38 0 43 53 255 255 0 176 0 0 4 68 7 170 2 38 0 75 0 0 1 7 1 75 0 31 1 137 0 8 179 1 37 2 38 0 43 53 0 2 0 0 0 0 5 231 5 182 0 19 0 23 0 84 64 44 23 3 15 15 0 16 20 4 12 12 7 11 8 11 16 18 4 24 25 23 14 73 89 22 10 18 19 18 74 89 7 3 19 23 19 23 19 1 12 16 18 5 1 3 0 63 51 63 51 18 57 57 47 47 17 51 51 43 17 0 51 51 43 17 18 1 23 57 17 51 51 17 51 51 17 51 51 17 51 51 49 48 19 53 51 21 33 53 51 21 51 21 35 17 35 17 33 17 35 17 35 53 1 53 33 21 201 170 3 2 170 200 200 170 252 254 170 201 4 117 252 254 4 190 248 248 248 248 141 251 207 2 176 253 80 4 49 141 254 138 233 233 0 1 0 20 0 0 4 68 6 20 0 30 0 89 64 50 22 20 16 8 8 13 9 0 30 30 18 9 11 4 31 32 23 22 26 4 70 89 19 11 12 11 71 89 16 12 15 12 31 12 47 12 3 22 26 12 12 26 22 3 9 14 0 0 9 21 0 63 51 63 18 23 57 47 47 47 93 17 51 43 17 0 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 51 51 49 48 33 17 52 38 35 34 6 21 17 35 17 35 53 51 53 51 21 33 21 33 21 20 7 51 54 54 51 50 22 21 17 3 158 122 130 174 158 166 156 156 166 1 193 254 63 8 10 49 181 116 201 201 2 158 134 132 186 213 253 231 4 219 127 186 186 127 196 84 56 79 91 191 210 253 92 255 255 255 226 0 0 2 202 7 47 2 38 0 44 0 0 1 7 1 82 254 218 1 82 0 8 179 1 21 5 38 0 43 53 255 255 255 144 0 0 2 120 5 221 2 38 0 243 0 0 1 7 1 82 254 136 0 0 0 8 179 1 13 17 38 0 43 53 255 255 0 42 0 0 2 130 6 180 2 38 0 44 0 0 1 7 1 77 254 253 1 82 0 8 179 1 15 5 38 0 43 53 255 255 255 218 0 0 2 50 5 98 2 38 0 243 0 0 1 7 1 77 254 173 0 0 0 8 179 1 7 17 38 0 43 53 255 255 0 30 0 0 2 138 7 55 2 38 0 44 0 0 1 7 1 78 254 249 1 82 0 8 179 1 12 5 38 0 43 53 255 255 255 204 0 0 2 56 5 229 2 38 0 243 0 0 1 7 1 78 254 167 0 0 0 8 179 1 4 17 38 0 43 53 255 255 0 84 254 66 2 86 5 182 2 38 0 44 0 0 0 6 1 81 104 0 255 255 0 53 254 66 1 129 5 223 2 38 0 76 0 0 0 6 1 81 16 0 255 255 0 84 0 0 2 86 7 49 2 38 0 44 0 0 1 7 1 79 0 80 1 82 0 8 179 1 21 5 38 0 43 53 0 1 0 176 0 0 1 86 4 72 0 3 0 22 64 9 0 1 1 5 4 2 15 1 21 0 63 63 17 18 1 57 17 51 49 48 33 35 17 51 1 86 166 166 4 72 255 255 0 84 254 127 4 16 5 182 0 38 0 44 0 0 0 7 0 45 2 168 0 0 255 255 0 162 254 20 3 108 5 223 0 38 0 76 0 0 0 7 0 77 2 6 0 0 255 255 255 96 254 127 2 101 7 115 2 38 0 45 0 0 1 7 1 75 254 183 1 82 0 8 179 1 28 5 38 0 43 53 255 255 255 145 254 20 2 79 6 33 2 38 2 55 0 0 1 7 1 75 254 161 0 0 0 8 179 1 27 17 38 0 43 53 255 255 0 201 254 59 4 233 5 182 2 38 0 46 0 0 0 7 2 57 0 137 0 0 255 255 0 176 254 59 4 29 6 20 2 38 0 78 0 0 0 6 2 57 43 0 0 1 0 176 0 0 4 27 4 70 0 13 0 47 64 25 13 11 7 7 8 3 1 2 5 8 5 14 15 2 13 5 6 4 8 0 9 15 4 8 21 0 63 51 63 51 18 23 57 17 18 1 23 57 17 51 17 51 51 49 48 1 51 1 1 35 1 7 17 35 17 51 17 20 7 3 47 207 254 98 1 187 201 254 151 135 178 178 12 4 70 254 30 253 156 1 248 113 254 121 4 70 254 229 166 113 255 255 0 201 0 0 3 248 7 115 2 38 0 47 0 0 1 7 0 118 255 99 1 82 0 8 179 1 15 5 38 0 43 53 255 255 0 163 0 0 2 44 7 172 2 38 0 79 0 0 1 7 0 118 255 26 1 139 0 8 179 1 13 2 38 0 43 53 255 255 0 201 254 59 3 248 5 182 2 38 0 47 0 0 0 6 2 57 49 0 255 255 0 89 254 59 1 87 6 20 2 38 0 79 0 0 0 7 2 57 254 232 0 0 255 255 0 201 0 0 3 248 5 183 2 38 0 47 0 0 1 7 2 56 1 29 255 163 0 7 178 1 9 3 0 63 53 0 255 255 0 176 0 0 2 160 6 20 2 38 0 79 0 0 1 6 2 56 43 0 0 7 178 1 7 0 0 63 53 0 255 255 0 201 0 0 3 248 5 182 2 38 0 47 0 0 0 7 1 79 2 4 253 103 255 255 0 176 0 0 2 168 6 20 0 38 0 79 0 0 0 7 1 79 1 66 253 56 0 1 0 29 0 0 3 248 5 182 0 13 0 61 64 33 7 11 11 4 0 12 9 0 3 4 15 14 9 7 4 10 3 1 6 8 2 8 2 8 0 5 3 0 11 73 89 0 18 0 63 43 0 24 63 18 57 57 47 47 18 23 57 17 18 1 23 57 17 51 51 17 51 49 48 51 17 7 39 55 17 51 17 37 23 5 17 33 21 201 105 67 172 170 1 41 67 254 148 2 133 1 252 59 114 101 3 30 253 70 174 121 211 254 60 154 0 1 255 252 0 0 2 39 6 20 0 11 0 55 64 28 0 4 4 9 5 5 12 2 13 8 12 0 2 9 3 8 6 6 1 7 1 7 1 5 10 0 5 21 0 63 63 18 57 57 47 47 18 23 57 17 1 51 17 51 18 57 17 51 51 17 51 49 48 1 55 23 7 17 35 17 7 39 55 17 51 1 86 137 72 209 166 110 70 180 166 3 96 94 112 141 253 63 2 84 72 113 119 3 32 0 255 255 0 201 0 0 5 63 7 115 2 38 0 49 0 0 1 7 0 118 1 2 1 82 0 8 179 1 26 5 38 0 43 53 255 255 0 176 0 0 4 68 6 33 2 38 0 81 0 0 1 6 0 118 121 0 0 8 179 1 30 17 38 0 43 53 255 255 0 201 254 59 5 63 5 182 2 38 0 49 0 0 0 7 2 57 0 205 0 0 255 255 0 176 254 59 4 68 4 92 2 38 0 81 0 0 0 6 2 57 86 0 255 255 0 201 0 0 5 63 7 115 2 38 0 49 0 0 1 7 1 76 0 166 1 82 0 8 179 1 28 5 38 0 43 53 255 255 0 176 0 0 4 68 6 33 2 38 0 81 0 0 1 6 1 76 31 0 0 8 179 1 32 17 38 0 43 53 255 255 0 1 0 0 4 203 5 182 0 39 0 81 0 135 0 0 1 6 2 7 232 0 0 7 178 1 28 3 0 63 53 0 0 1 0 201 254 127 5 63 5 182 0 25 0 56 64 28 16 13 13 14 8 20 20 23 23 2 14 3 26 27 18 10 14 21 15 3 14 18 0 5 73 89 0 34 0 63 43 0 24 63 63 51 18 57 57 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 34 39 53 22 51 50 54 53 1 35 18 21 17 35 17 51 1 51 38 53 17 51 17 20 6 3 201 98 54 71 83 105 106 252 192 8 16 157 192 3 29 8 14 159 193 254 127 27 145 20 122 111 4 203 254 248 158 252 219 5 182 251 78 149 224 3 61 250 88 195 204 0 1 0 176 254 20 4 68 4 92 0 29 0 56 64 30 19 15 15 16 7 27 27 2 16 3 30 31 23 11 70 89 23 16 19 16 17 15 16 21 0 5 70 89 0 27 0 63 43 0 24 63 63 18 57 63 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 34 39 53 22 51 50 53 17 52 38 35 34 6 21 17 35 17 51 23 51 54 54 51 50 22 21 17 20 6 3 37 86 55 60 62 140 122 130 172 160 166 135 27 10 52 180 110 203 199 140 254 20 25 135 20 172 3 121 134 132 186 214 253 193 4 72 150 82 88 191 210 252 141 154 170 255 255 0 125 255 236 5 190 6 180 2 38 0 50 0 0 1 7 1 77 0 199 1 82 0 8 179 2 27 5 38 0 43 53 255 255 0 115 255 236 4 98 5 98 2 38 0 82 0 0 1 6 1 77 18 0 0 8 179 2 28 17 38 0 43 53 255 255 0 125 255 236 5 190 7 55 2 38 0 50 0 0 1 7 1 78 0 193 1 82 0 8 179 2 24 5 38 0 43 53 255 255 0 115 255 236 4 98 5 229 2 38 0 82 0 0 1 6 1 78 14 0 0 8 179 2 25 17 38 0 43 53 255 255 0 125 255 236 5 190 7 115 2 38 0 50 0 0 1 7 1 83 1 20 1 82 0 10 180 3 2 43 5 38 0 43 53 53 255 255 0 115 255 236 4 98 6 33 2 38 0 82 0 0 1 6 1 83 90 0 0 10 180 3 2 44 17 38 0 43 53 53 0 2 0 125 255 236 6 231 5 205 0 20 0 31 0 83 64 46 24 6 15 19 19 29 0 13 17 29 6 5 32 33 15 18 73 89 15 15 0 11 11 14 73 89 11 3 9 21 73 89 9 4 3 27 73 89 3 18 0 19 73 89 0 18 0 63 43 0 24 63 43 0 24 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 17 51 49 48 33 33 6 35 32 0 17 16 0 33 50 23 33 21 33 17 33 21 33 17 33 1 34 0 17 16 0 51 50 55 17 38 6 231 253 0 102 92 254 185 254 159 1 92 1 64 102 90 3 14 253 179 2 39 253 217 2 77 252 68 249 254 255 1 1 247 112 87 87 20 1 137 1 106 1 104 1 134 23 151 254 41 150 253 230 4 157 254 207 254 217 254 215 254 205 33 4 117 30 0 3 0 113 255 236 7 31 4 90 0 30 0 42 0 49 0 85 64 45 31 8 14 2 22 22 37 47 21 21 28 37 8 4 50 51 43 40 11 40 70 89 46 22 70 89 2 5 14 11 46 46 5 17 11 16 24 34 5 34 70 89 0 5 22 0 63 51 43 17 0 51 24 63 51 18 57 47 18 57 18 57 43 43 17 0 51 17 18 1 23 57 17 51 17 51 18 57 57 17 51 49 48 5 32 39 6 6 35 34 0 17 16 0 51 50 22 23 54 54 51 50 18 21 21 33 18 33 50 54 55 21 6 6 1 20 22 51 50 54 53 52 38 35 34 6 37 34 6 7 33 52 38 5 150 254 219 125 62 209 137 223 254 244 1 6 235 131 205 62 58 192 126 201 238 253 39 8 1 74 94 161 87 88 152 251 33 152 167 163 153 155 165 166 149 4 71 127 145 12 2 32 132 20 235 116 119 1 49 1 8 1 9 1 44 119 114 112 121 254 247 226 105 254 119 35 39 148 39 32 2 57 211 219 213 209 221 213 216 216 164 158 158 164 255 255 0 201 0 0 4 207 7 115 2 38 0 53 0 0 1 7 0 118 0 121 1 82 0 8 179 2 31 5 38 0 43 53 255 255 0 176 0 0 3 39 6 33 2 38 0 85 0 0 1 6 0 118 220 0 0 8 179 1 26 17 38 0 43 53 255 255 0 201 254 59 4 207 5 182 2 38 0 53 0 0 0 6 2 57 125 0 255 255 0 96 254 59 3 39 4 92 2 38 0 85 0 0 0 7 2 57 254 239 0 0 255 255 0 201 0 0 4 207 7 115 2 38 0 53 0 0 1 7 1 76 0 27 1 82 0 8 179 2 33 5 38 0 43 53 255 255 0 130 0 0 3 39 6 33 2 38 0 85 0 0 1 7 1 76 255 118 0 0 0 8 179 1 28 17 38 0 43 53 255 255 0 106 255 236 4 2 7 115 2 38 0 54 0 0 1 7 0 118 0 80 1 82 0 8 179 1 46 5 38 0 43 53 255 255 0 106 255 236 3 115 6 33 2 38 0 86 0 0 1 6 0 118 234 0 0 8 179 1 46 17 38 0 43 53 255 255 0 106 255 236 4 2 7 115 2 38 0 54 0 0 1 7 1 75 255 234 1 82 0 8 179 1 51 5 38 0 43 53 255 255 0 106 255 236 3 115 6 33 2 38 0 86 0 0 1 6 1 75 151 0 0 8 179 1 51 17 38 0 43 53 255 255 0 106 254 20 4 2 5 203 2 38 0 54 0 0 0 7 0 122 1 39 0 0 255 255 0 106 254 20 3 115 4 92 2 38 0 86 0 0 0 7 0 122 0 213 0 0 255 255 0 106 255 236 4 2 7 115 2 38 0 54 0 0 1 7 1 76 255 228 1 82 0 8 179 1 48 5 38 0 43 53 255 255 0 106 255 236 3 115 6 33 2 38 0 86 0 0 1 6 1 76 153 0 0 8 179 1 48 17 38 0 43 53 255 255 0 18 254 59 4 90 5 182 2 38 0 55 0 0 0 6 2 57 25 0 255 255 0 31 254 59 2 168 5 70 2 38 0 87 0 0 0 6 2 57 130 0 255 255 0 18 0 0 4 90 7 115 2 38 0 55 0 0 1 7 1 76 255 220 1 82 0 8 179 1 19 5 38 0 43 53 255 255 0 31 255 236 2 215 6 20 2 38 0 87 0 0 1 6 2 56 98 0 0 7 178 1 26 0 0 63 53 0 0 1 0 18 0 0 4 90 5 182 0 15 0 63 64 33 7 11 11 0 12 4 9 12 14 2 5 16 17 10 14 15 14 74 89 7 15 15 3 12 18 6 2 3 2 73 89 3 3 0 63 43 17 0 51 24 63 18 57 47 51 43 17 0 51 17 18 1 23 57 17 51 51 17 51 49 48 1 17 33 53 33 21 33 17 33 21 33 17 35 17 33 53 1 225 254 49 4 72 254 49 1 54 254 202 170 254 199 3 47 1 240 151 151 254 16 141 253 94 2 162 141 0 1 0 31 255 236 2 168 5 70 0 28 0 76 64 41 23 19 27 27 12 8 2 21 25 8 10 14 6 29 30 14 22 19 22 71 89 26 10 11 10 71 89 23 11 11 6 17 64 19 15 6 0 70 89 6 22 0 63 43 0 24 63 26 205 18 57 47 51 43 17 0 51 43 17 0 51 17 18 1 23 57 17 51 51 17 51 51 49 48 37 50 55 21 6 6 35 32 17 53 35 53 51 17 35 53 55 55 51 21 33 21 33 17 33 21 33 21 20 2 23 85 60 32 106 42 254 200 141 141 157 157 70 96 1 62 254 194 1 45 254 211 117 20 127 14 16 1 92 254 129 1 0 80 69 234 254 129 255 0 129 244 221 0 255 255 0 186 255 236 5 25 7 47 2 38 0 56 0 0 1 7 1 82 0 111 1 82 0 8 179 1 27 5 38 0 43 53 255 255 0 164 255 236 4 57 5 221 2 38 0 88 0 0 1 6 1 82 247 0 0 8 179 1 30 17 38 0 43 53 255 255 0 186 255 236 5 25 6 180 2 38 0 56 0 0 1 7 1 77 0 145 1 82 0 8 179 1 21 5 38 0 43 53 255 255 0 164 255 236 4 57 5 98 2 38 0 88 0 0 1 6 1 77 25 0 0 8 179 1 24 17 38 0 43 53 255 255 0 186 255 236 5 25 7 55 2 38 0 56 0 0 1 7 1 78 0 139 1 82 0 8 179 1 18 5 38 0 43 53 255 255 0 164 255 236 4 57 5 229 2 38 0 88 0 0 1 6 1 78 18 0 0 8 179 1 21 17 38 0 43 53 255 255 0 186 255 236 5 25 7 215 2 38 0 56 0 0 1 7 1 80 0 156 1 82 0 10 180 2 1 21 5 38 0 43 53 53 255 255 0 164 255 236 4 57 6 133 2 38 0 88 0 0 1 6 1 80 35 0 0 10 180 2 1 24 17 38 0 43 53 53 255 255 0 186 255 236 5 25 7 115 2 38 0 56 0 0 1 7 1 83 0 225 1 82 0 10 180 2 1 37 5 38 0 43 53 53 255 255 0 164 255 236 4 57 6 33 2 38 0 88 0 0 1 6 1 83 104 0 0 10 180 2 1 40 17 38 0 43 53 53 255 255 0 186 254 66 5 25 5 182 2 38 0 56 0 0 0 7 1 81 2 33 0 0 255 255 0 164 254 66 4 101 4 72 2 38 0 88 0 0 0 7 1 81 2 244 0 0 255 255 0 27 0 0 7 76 7 115 2 38 0 58 0 0 1 7 1 75 1 84 1 82 0 8 179 1 40 5 38 0 43 53 255 255 0 23 0 0 6 35 6 33 2 38 0 90 0 0 1 7 1 75 0 193 0 0 0 8 179 1 43 17 38 0 43 53 255 255 0 0 0 0 4 123 7 115 2 38 0 60 0 0 1 7 1 75 255 224 1 82 0 8 179 1 23 5 38 0 43 53 255 255 0 2 254 20 4 6 6 33 2 38 0 92 0 0 1 6 1 75 173 0 0 8 179 1 36 17 38 0 43 53 255 255 0 0 0 0 4 123 7 37 2 38 0 60 0 0 1 7 0 106 255 241 1 82 0 10 180 2 1 30 5 38 0 43 53 53 255 255 0 82 0 0 4 63 7 115 2 38 0 61 0 0 1 7 0 118 0 66 1 82 0 8 179 1 19 5 38 0 43 53 255 255 0 82 0 0 3 109 6 33 2 38 0 93 0 0 1 6 0 118 232 0 0 8 179 1 19 17 38 0 43 53 255 255 0 82 0 0 4 63 7 49 2 38 0 61 0 0 1 7 1 79 1 68 1 82 0 8 179 1 19 5 38 0 43 53 255 255 0 82 0 0 3 109 5 223 2 38 0 93 0 0 1 7 1 79 0 223 0 0 0 8 179 1 19 17 38 0 43 53 255 255 0 82 0 0 4 63 7 115 2 38 0 61 0 0 1 7 1 76 255 237 1 82 0 8 179 1 21 5 38 0 43 53 255 255 0 82 0 0 3 109 6 33 2 38 0 93 0 0 1 6 1 76 134 0 0 8 179 1 21 17 38 0 43 53 0 1 0 176 0 0 2 219 6 31 0 12 0 29 64 14 0 1 1 13 6 14 4 9 70 89 4 0 1 21 0 63 63 43 17 1 51 18 57 17 51 49 48 33 35 17 16 33 50 23 7 38 35 34 6 21 1 86 166 1 103 96 100 43 87 73 97 89 4 156 1 131 37 133 30 123 122 0 0 1 0 195 254 20 4 23 5 203 0 32 0 68 64 36 26 30 30 12 8 18 28 8 10 2 5 33 34 29 10 12 10 70 89 26 12 12 16 0 16 22 70 89 16 4 0 5 70 89 0 27 0 63 43 0 24 63 43 17 18 0 57 24 47 51 43 17 0 51 17 18 1 23 57 17 51 51 17 51 49 48 1 34 39 53 22 51 50 54 53 17 35 53 55 53 52 54 51 50 23 7 7 38 35 34 6 21 21 33 21 33 17 20 6 1 72 69 64 70 61 95 77 222 222 162 182 85 120 22 21 102 60 98 80 1 26 254 234 158 254 20 19 139 18 102 113 3 205 75 60 139 195 178 43 64 65 32 105 124 149 129 252 55 184 175 0 4 0 0 0 0 5 20 7 170 0 16 0 24 0 34 0 46 0 97 64 52 17 5 4 24 6 20 7 4 3 7 8 35 0 41 11 8 11 9 34 20 2 0 29 3 9 48 47 38 14 44 2 9 24 6 73 89 9 20 14 24 34 14 24 24 14 34 3 8 28 4 8 18 0 63 51 47 18 23 57 47 47 47 17 18 57 57 43 17 0 51 51 17 51 17 18 1 23 57 17 51 17 51 17 51 17 51 17 18 57 57 17 57 57 49 48 1 20 7 1 35 3 33 3 35 1 38 53 52 54 51 50 22 19 3 38 39 6 6 7 3 19 54 54 55 51 21 6 6 7 35 19 52 38 35 34 6 21 20 22 51 50 54 3 104 104 2 20 174 176 253 158 166 174 2 20 106 122 99 100 125 27 178 25 47 14 48 9 177 152 49 102 23 203 32 168 66 111 211 66 51 51 66 60 57 53 64 5 150 133 56 251 39 1 145 254 111 4 215 52 136 101 114 117 252 54 1 176 58 145 48 135 24 254 84 4 133 59 149 42 16 46 161 45 254 245 57 60 60 57 55 61 61 0 5 0 94 255 236 3 205 7 170 0 9 0 36 0 47 0 59 0 71 0 103 64 55 45 18 66 54 60 48 41 21 21 11 36 36 6 48 0 54 29 18 7 72 73 9 9 4 63 57 69 51 17 11 12 21 41 71 89 12 21 21 15 32 32 25 70 89 32 16 15 37 70 89 15 22 10 21 4 0 47 63 63 43 0 24 63 43 17 18 0 57 24 47 57 43 17 0 51 24 63 51 196 50 17 57 47 17 18 1 23 57 17 51 51 17 51 17 51 17 51 17 51 49 48 1 53 54 54 55 33 21 6 6 7 1 39 35 6 6 35 34 38 53 16 37 55 53 52 38 35 34 6 7 39 54 54 51 50 22 21 17 37 50 54 53 53 7 6 6 21 20 22 1 20 6 35 34 38 53 52 54 51 50 22 7 52 38 35 34 6 21 20 22 51 50 54 1 215 46 106 22 1 4 21 164 128 1 2 33 8 82 163 122 163 185 2 25 180 119 133 96 167 71 55 84 208 101 209 201 254 14 155 177 166 198 175 109 1 170 123 102 101 121 121 101 101 124 109 65 51 51 66 60 57 52 64 6 217 16 42 120 31 12 24 105 68 249 39 156 103 73 168 155 1 76 16 6 68 130 122 52 32 127 43 51 174 192 253 20 117 170 153 99 7 7 109 115 90 94 5 61 98 119 116 99 98 115 119 94 56 61 61 56 56 61 61 0 255 255 255 254 0 0 6 129 7 115 2 38 0 136 0 0 1 7 0 118 2 76 1 82 0 8 179 2 29 5 38 0 43 53 255 255 0 94 255 236 6 115 6 33 2 38 0 168 0 0 1 7 0 118 1 133 0 0 0 8 179 3 69 17 38 0 43 53 255 255 0 125 255 195 5 190 7 115 2 38 0 154 0 0 1 7 0 118 1 25 1 82 0 8 179 3 45 5 38 0 43 53 255 255 0 115 255 188 4 98 6 33 2 38 0 186 0 0 1 6 0 118 86 0 0 8 179 3 45 17 38 0 43 53 255 255 0 106 254 59 4 2 5 203 2 38 0 54 0 0 0 6 2 57 6 0 255 255 0 106 254 59 3 115 4 92 2 38 0 86 0 0 0 6 2 57 185 0 0 1 1 12 4 217 3 174 6 33 0 14 0 24 64 9 7 0 16 15 11 4 128 14 9 0 47 51 26 205 50 17 18 1 57 57 49 48 1 54 54 55 51 22 22 23 21 35 38 39 6 7 35 1 12 127 102 23 166 22 109 125 119 88 133 136 83 115 4 240 136 128 41 42 133 130 23 55 131 134 52 0 0 1 1 12 4 217 3 174 6 33 0 14 0 24 64 9 6 0 16 15 5 1 128 3 11 0 47 51 26 205 50 17 18 1 57 57 49 48 1 51 22 23 54 55 51 21 7 6 7 35 38 38 39 1 12 115 114 105 130 91 119 66 144 46 166 23 102 127 6 33 74 115 130 59 25 68 148 87 41 126 136 0 0 1 1 45 4 217 3 133 5 98 0 3 0 17 181 0 1 4 5 0 3 0 47 51 17 18 1 57 57 49 48 1 33 21 33 1 45 2 88 253 168 5 98 137 0 1 1 37 4 217 3 145 5 229 0 14 0 24 64 9 12 3 16 15 11 4 128 8 0 0 47 50 26 204 50 17 18 1 57 57 49 48 1 34 38 39 51 30 2 51 50 54 55 51 6 6 2 86 140 156 9 104 6 41 73 85 101 96 10 104 10 167 4 217 137 131 49 56 26 64 67 126 142 0 0 1 0 162 5 2 1 102 5 223 0 11 0 19 182 6 0 0 12 13 3 9 0 47 205 17 18 1 57 17 51 49 48 19 52 54 51 50 22 21 20 6 35 34 38 162 56 42 40 58 58 40 42 56 5 113 57 53 54 56 56 55 55 0 0 2 1 111 4 217 3 45 6 133 0 11 0 23 0 30 64 12 18 6 12 0 6 0 24 25 15 9 21 3 0 47 51 204 50 17 18 1 57 57 17 51 17 51 49 48 1 20 6 35 34 38 53 52 54 51 50 22 7 52 38 35 34 6 21 20 22 51 50 54 3 45 123 102 101 120 121 100 101 124 108 66 51 51 66 60 57 52 65 5 178 98 119 117 98 98 115 119 94 56 61 61 56 56 61 61 0 1 0 37 254 66 1 113 0 0 0 15 0 24 64 10 0 9 4 13 9 3 16 17 2 7 0 47 51 17 18 1 23 57 17 51 49 48 23 20 51 50 55 21 6 35 34 53 52 54 55 51 6 6 178 94 42 55 65 60 207 86 72 120 68 69 238 94 13 109 18 188 70 135 53 66 109 0 0 1 1 8 4 217 3 240 5 221 0 23 0 36 64 15 9 21 24 25 17 0 5 12 0 12 0 12 21 128 9 0 47 26 204 57 57 47 47 17 51 17 51 17 18 1 57 57 49 48 1 34 46 2 35 34 6 7 35 54 54 51 50 30 2 51 50 54 55 51 6 6 3 20 43 82 79 73 34 50 51 14 98 13 115 91 46 86 78 72 32 49 48 15 99 13 113 4 219 37 45 37 60 61 121 137 37 45 37 59 62 121 137 0 0 2 0 231 4 217 3 182 6 33 0 9 0 19 0 27 64 12 14 5 19 9 4 20 21 13 4 128 19 9 0 47 51 26 205 50 17 18 1 23 57 49 48 19 54 54 55 51 21 6 6 7 35 37 54 54 55 51 21 6 6 7 35 231 36 110 31 186 37 171 58 97 1 101 49 101 26 186 37 171 58 96 4 242 48 186 69 21 63 196 48 25 68 177 58 21 63 196 48 0 0 1 1 252 4 217 3 16 6 115 0 9 0 19 182 4 0 11 10 4 128 9 0 47 26 205 17 18 1 57 57 49 48 1 54 54 55 51 21 6 6 7 35 1 252 27 53 12 184 18 109 49 100 4 246 72 227 82 23 74 237 76 0 3 1 27 5 14 3 131 6 180 0 8 0 20 0 32 0 43 64 20 15 9 21 27 27 3 8 9 4 33 34 24 12 8 12 8 12 3 30 18 0 47 51 204 57 57 47 47 17 51 17 18 1 23 57 17 51 17 51 49 48 1 54 55 51 21 6 6 7 35 39 52 54 51 50 22 21 20 6 35 34 38 37 52 54 51 50 22 21 20 6 35 34 38 2 0 65 31 189 33 121 51 80 229 52 38 41 49 55 35 38 52 1 180 52 38 41 49 55 35 38 52 5 133 169 134 20 67 179 61 4 52 46 52 46 50 49 49 50 52 46 52 46 50 49 49 255 255 0 0 0 0 5 16 6 10 2 38 0 36 0 0 1 7 1 84 254 32 255 151 0 7 178 2 18 0 0 63 53 0 255 255 0 152 2 76 1 137 3 90 2 6 0 121 0 0 255 255 255 212 0 0 4 117 6 10 0 38 0 40 125 0 1 7 1 84 253 216 255 151 0 7 178 1 16 0 0 63 53 0 255 255 255 212 0 0 5 181 6 10 0 39 0 43 0 150 0 0 1 7 1 84 253 216 255 151 0 7 178 1 16 0 0 63 53 0 255 255 255 228 0 0 3 68 6 10 0 39 0 44 0 238 0 0 1 7 1 84 253 232 255 151 0 7 178 1 16 0 0 63 53 0 255 255 255 228 255 236 6 2 6 10 0 38 0 50 68 0 1 7 1 84 253 232 255 151 0 7 178 2 28 0 0 63 53 0 255 255 255 212 0 0 5 133 6 10 0 39 0 60 1 10 0 0 1 7 1 84 253 216 255 151 0 7 178 1 13 0 0 63 53 0 255 255 255 228 0 0 6 51 6 10 0 38 1 118 63 0 1 7 1 84 253 232 255 151 0 7 178 1 35 0 0 63 53 0 255 255 255 233 255 236 2 147 6 180 2 38 1 134 0 0 1 7 1 85 254 206 0 0 0 12 181 3 2 1 46 17 38 0 43 53 53 53 255 255 0 0 0 0 5 16 5 188 2 6 0 36 0 0 255 255 0 201 0 0 4 190 5 182 2 6 0 37 0 0 0 1 0 201 0 0 3 248 5 182 0 5 0 29 64 14 3 4 4 0 6 7 5 2 73 89 5 3 4 18 0 63 63 43 17 18 1 57 57 17 51 49 48 1 21 33 17 35 17 3 248 253 123 170 5 182 153 250 227 5 182 0 255 255 0 39 0 0 4 109 5 182 2 6 2 40 0 0 255 255 0 201 0 0 3 248 5 182 2 6 0 40 0 0 255 255 0 82 0 0 4 63 5 182 2 6 0 61 0 0 255 255 0 201 0 0 5 31 5 182 2 6 0 43 0 0 0 3 0 125 255 236 5 190 5 205 0 3 0 15 0 27 0 63 64 32 2 3 16 22 16 10 22 4 10 4 28 29 0 3 73 89 0 0 7 13 13 25 73 89 13 4 7 19 73 89 7 19 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 57 57 17 51 17 51 17 18 57 57 49 48 1 33 21 33 37 16 0 33 32 0 17 16 0 33 32 0 1 16 18 51 50 18 17 16 2 35 34 2 1 227 2 117 253 139 3 219 254 157 254 196 254 189 254 161 1 96 1 68 1 59 1 98 251 115 250 244 243 248 247 242 245 251 3 51 149 63 254 161 254 110 1 139 1 104 1 101 1 137 254 112 254 160 254 216 254 204 1 48 1 44 1 42 1 46 254 206 0 255 255 0 84 0 0 2 86 5 182 2 6 0 44 0 0 255 255 0 201 0 0 4 233 5 182 2 6 0 46 0 0 0 1 0 0 0 0 4 211 5 182 0 10 0 26 64 11 8 0 12 11 4 8 9 3 1 8 18 0 63 51 63 18 57 17 18 1 57 57 49 48 33 35 1 38 39 6 7 1 35 1 51 4 211 182 254 182 87 22 33 71 254 184 182 2 16 177 3 160 252 90 139 201 252 94 5 182 255 255 0 201 0 0 6 113 5 182 2 6 0 48 0 0 255 255 0 201 0 0 5 63 5 182 2 6 0 49 0 0 0 3 0 72 0 0 4 37 5 182 0 3 0 7 0 11 0 52 64 29 10 7 3 2 6 8 6 13 12 0 3 73 89 0 0 10 4 10 11 73 89 10 18 4 7 73 89 4 3 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 49 48 19 33 21 33 3 33 21 33 1 21 33 53 195 2 231 253 25 82 3 139 252 117 3 180 252 35 3 72 150 3 4 151 251 121 152 152 255 255 0 125 255 236 5 190 5 205 2 6 0 50 0 0 0 1 0 201 0 0 5 12 5 182 0 7 0 35 64 17 1 0 4 5 0 5 9 8 6 3 73 89 6 3 1 5 18 0 63 51 63 43 17 18 1 57 57 17 51 17 51 49 48 33 35 17 33 17 35 17 33 5 12 170 253 17 170 4 67 5 31 250 225 5 182 0 255 255 0 201 0 0 4 104 5 182 2 6 0 51 0 0 0 1 0 74 0 0 4 92 5 182 0 12 0 53 64 28 8 10 10 0 9 2 11 6 3 2 0 5 13 14 7 8 4 8 73 89 4 3 0 10 73 89 0 18 0 63 43 0 24 63 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 49 48 51 53 1 1 53 33 21 33 39 1 1 33 21 74 1 225 254 43 3 203 253 92 96 1 204 254 31 3 84 141 2 111 2 43 143 153 2 253 223 253 154 152 0 255 255 0 18 0 0 4 90 5 182 2 6 0 55 0 0 255 255 0 0 0 0 4 123 5 182 2 6 0 60 0 0 0 3 0 106 255 236 5 248 5 203 0 25 0 34 0 43 0 80 64 41 39 20 26 2 13 13 43 25 14 30 7 7 14 20 3 44 45 12 16 26 42 16 42 74 89 34 36 24 36 74 89 2 24 16 24 16 24 14 19 0 4 0 63 63 57 57 47 47 17 51 43 17 0 51 43 17 0 51 17 51 17 18 1 23 57 17 51 17 51 51 51 17 51 51 17 51 49 48 1 51 21 51 50 22 22 21 20 2 4 35 35 21 35 53 35 34 36 2 53 52 54 54 51 51 19 51 50 54 53 52 38 43 3 34 6 21 20 22 51 51 2 219 172 70 171 251 133 149 254 253 176 41 172 45 176 254 254 146 135 252 171 67 172 25 201 223 206 185 58 172 57 182 209 222 202 24 5 203 180 136 248 159 166 254 253 130 225 225 132 1 4 161 158 248 139 252 69 219 195 185 210 212 183 197 217 0 255 255 0 8 0 0 4 150 5 182 2 6 0 59 0 0 0 1 0 109 0 0 5 242 5 182 0 29 0 62 64 31 10 7 17 0 0 14 1 21 24 24 1 7 3 30 31 29 3 13 3 73 89 17 13 13 1 22 15 8 3 1 18 0 63 63 51 51 18 57 47 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 17 51 49 48 33 35 17 35 34 38 38 53 17 51 17 20 22 51 51 17 51 17 51 50 54 53 17 51 17 20 6 4 35 35 3 131 170 45 176 255 144 174 207 212 27 170 29 211 207 176 144 254 253 175 45 1 190 122 247 164 1 227 254 33 188 201 3 100 252 156 198 187 1 227 254 31 165 247 123 0 0 1 0 80 0 0 5 244 5 205 0 31 0 57 64 32 3 13 29 19 24 19 22 25 7 10 13 8 8 32 33 16 0 73 89 16 4 26 22 6 9 8 9 73 89 25 8 18 0 63 51 43 17 0 51 51 51 24 63 43 17 18 1 23 57 17 51 17 51 49 48 1 34 2 21 20 18 23 21 33 53 33 38 2 53 16 0 33 32 0 17 20 2 7 33 21 33 53 54 18 53 52 2 3 33 238 250 173 180 253 182 1 108 151 160 1 98 1 58 1 59 1 98 158 151 1 107 253 182 183 169 249 5 53 254 255 253 225 254 179 132 133 152 118 1 94 203 1 54 1 96 254 165 254 199 207 254 166 120 152 133 134 1 78 222 252 1 2 255 255 0 60 0 0 2 111 7 37 2 38 0 44 0 0 1 7 0 106 255 7 1 82 0 10 180 2 1 33 5 38 0 43 53 53 255 255 0 0 0 0 4 123 7 37 2 38 0 60 0 0 1 7 0 106 255 239 1 82 0 10 180 2 1 30 5 38 0 43 53 53 255 255 0 115 255 236 4 199 6 115 2 38 1 126 0 0 1 6 1 84 29 0 0 8 179 2 52 17 38 0 43 53 255 255 0 90 255 236 3 135 6 115 2 38 1 130 0 0 1 6 1 84 200 0 0 8 179 1 47 17 38 0 43 53 255 255 0 176 254 20 4 68 6 115 2 38 1 132 0 0 1 6 1 84 59 0 0 8 179 1 30 17 38 0 43 53 255 255 0 168 255 236 2 147 6 115 2 38 1 134 0 0 1 7 1 84 254 196 0 0 0 8 179 1 25 17 38 0 43 53 255 255 0 164 255 236 4 113 6 180 2 38 1 146 0 0 1 6 1 85 59 0 0 12 181 3 2 1 52 17 38 0 43 53 53 53 0 2 0 115 255 236 4 199 4 92 0 11 0 42 0 71 64 36 9 15 39 21 4 4 29 34 29 15 3 43 44 24 15 39 40 40 22 12 18 18 7 70 89 18 16 31 0 12 0 70 89 36 12 22 0 63 51 43 17 0 51 24 63 43 17 18 0 57 57 17 51 24 63 17 18 1 23 57 17 51 17 51 51 17 51 49 48 37 50 54 53 53 52 38 35 32 17 20 22 23 34 2 17 16 18 51 50 22 23 51 54 55 51 6 6 21 17 20 51 50 55 21 6 35 34 38 39 35 6 6 2 80 169 150 152 169 254 209 147 133 214 238 244 225 121 161 54 12 24 41 129 21 28 84 29 33 46 65 81 89 18 13 59 167 119 195 218 15 229 199 254 80 212 212 139 1 41 1 12 1 18 1 41 84 84 92 56 66 246 116 254 73 114 10 119 26 81 86 86 81 0 2 0 176 254 20 4 168 6 31 0 19 0 41 0 76 64 40 24 15 15 16 39 3 30 8 8 3 5 34 16 5 42 43 16 27 35 34 70 89 14 35 14 35 11 0 11 27 70 89 11 22 0 20 70 89 0 0 0 63 43 0 24 63 43 17 18 0 57 57 24 47 47 43 0 24 63 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 50 22 21 16 5 21 4 17 20 4 35 34 38 39 17 35 17 52 54 23 34 6 21 17 22 22 51 50 54 53 52 38 35 35 53 51 50 54 53 52 38 2 147 220 249 254 199 1 121 254 248 238 109 160 79 166 253 228 158 157 93 161 86 171 173 190 177 112 92 155 162 156 6 31 208 183 254 218 51 8 42 254 145 209 225 31 38 253 227 6 52 225 246 140 172 165 252 137 49 37 150 157 157 164 142 147 137 123 133 0 1 0 10 254 20 4 14 4 72 0 18 0 33 64 16 15 4 1 5 4 19 20 10 9 9 1 14 5 15 1 27 0 63 63 51 18 57 47 51 17 18 1 23 57 49 48 1 35 52 18 55 1 51 19 22 23 51 62 2 19 51 1 6 2 2 20 180 64 43 254 63 172 240 94 19 8 5 41 43 234 172 254 107 48 53 254 20 96 1 38 114 4 60 253 184 235 103 30 142 129 2 109 251 211 124 254 220 0 2 0 113 255 236 4 96 6 18 0 30 0 42 0 59 64 32 37 28 16 3 31 22 22 9 0 3 28 5 43 44 16 0 34 3 25 6 25 40 70 89 25 22 6 13 70 89 6 0 0 63 43 0 24 63 43 17 18 0 23 57 17 18 1 23 57 17 51 17 51 17 51 49 48 1 38 38 53 52 54 51 50 22 23 7 38 38 35 34 6 21 20 22 23 22 22 21 20 0 35 34 36 53 52 18 1 52 38 39 6 6 21 20 22 51 50 54 2 33 140 116 194 164 103 189 126 72 112 159 81 85 97 107 167 210 177 254 240 236 227 254 240 226 2 97 123 141 206 191 178 147 162 174 3 168 78 159 99 130 152 45 63 135 62 44 79 66 71 111 91 115 241 164 235 254 248 248 210 177 1 5 254 115 128 183 74 53 217 160 144 171 186 0 0 1 0 90 255 236 3 135 4 92 0 37 0 77 64 43 4 16 35 23 29 11 1 19 23 16 6 38 39 20 37 2 37 2 70 89 15 37 31 37 2 11 3 37 37 13 26 26 33 70 89 26 16 13 7 70 89 13 22 0 63 43 0 24 63 43 17 18 0 57 24 47 95 94 93 43 17 18 0 57 17 18 1 23 57 17 51 17 51 49 48 1 21 35 32 21 20 22 51 50 54 55 21 6 35 34 38 53 52 54 55 53 38 38 53 52 54 51 50 22 23 7 38 38 35 34 21 20 33 2 203 148 254 201 147 146 84 166 100 137 221 210 241 110 130 98 107 224 192 97 165 100 63 94 130 79 250 1 61 2 129 141 195 90 98 39 47 148 75 169 148 98 131 41 11 28 127 92 133 158 33 45 133 42 28 162 172 0 0 1 0 115 254 111 3 160 6 20 0 32 0 48 64 24 7 25 30 19 19 14 14 3 0 25 4 33 34 17 35 30 3 0 1 0 70 89 1 0 0 63 43 17 0 51 51 24 63 17 18 1 23 57 17 51 17 51 17 51 49 48 19 53 33 21 6 0 2 21 20 22 22 23 22 22 21 20 7 35 54 53 52 38 39 38 38 53 52 62 2 55 6 33 176 2 240 215 254 224 138 59 125 172 149 136 127 166 125 111 143 203 188 59 112 201 242 40 254 241 5 135 141 129 180 254 189 254 223 166 98 118 73 37 31 109 91 149 164 161 107 56 61 26 36 219 194 114 208 195 229 218 8 0 0 1 0 176 254 20 4 68 4 92 0 20 0 47 64 24 0 20 12 8 8 9 20 9 22 21 16 4 70 89 16 16 12 9 10 15 9 21 0 27 0 63 63 63 18 57 63 43 17 18 1 57 57 17 51 17 51 17 51 49 48 1 17 52 38 35 34 6 21 17 35 17 51 23 51 54 54 51 50 22 21 17 3 158 122 130 172 160 166 135 27 8 51 184 113 198 200 254 20 4 177 134 132 186 214 253 193 4 72 150 81 89 191 210 251 73 0 3 0 115 255 236 4 74 6 43 0 11 0 18 0 25 0 73 64 39 22 16 16 6 23 15 15 0 6 0 26 27 22 16 70 89 15 22 191 22 2 11 3 22 22 3 9 9 19 70 89 9 1 3 12 70 89 3 22 0 63 43 0 24 63 43 17 18 0 57 24 47 95 94 93 43 17 18 1 57 57 17 51 17 51 17 51 17 51 49 48 1 16 2 35 34 2 17 16 18 51 50 18 1 50 18 19 33 18 18 19 34 2 3 33 2 2 4 74 244 250 240 249 245 244 244 250 254 18 164 156 6 253 121 4 150 167 161 150 10 2 133 11 152 3 12 254 106 254 118 1 147 1 141 1 151 1 136 254 107 251 225 1 49 1 51 254 208 254 204 5 41 254 225 254 231 1 25 1 31 0 1 0 168 255 236 2 147 4 72 0 15 0 31 64 14 1 14 7 14 17 16 15 15 11 4 70 89 11 22 0 63 43 0 24 63 17 18 1 57 57 17 51 49 48 1 17 20 22 51 50 54 55 21 6 6 35 34 38 53 17 1 78 73 87 37 101 27 31 105 50 160 145 4 72 252 250 104 101 13 7 127 13 17 168 169 3 11 255 255 0 176 0 0 4 27 4 70 2 6 0 250 0 0 0 1 255 242 255 236 4 70 6 33 0 34 0 51 64 27 8 1 21 3 36 0 0 35 24 19 70 89 24 22 30 31 31 0 11 11 6 70 89 11 1 0 21 0 63 63 43 17 18 0 57 17 51 24 63 43 17 1 51 17 18 23 57 49 48 35 1 39 46 2 35 34 7 53 54 51 50 22 22 23 1 22 22 51 50 55 21 6 35 34 38 39 3 38 39 35 6 7 3 14 1 217 58 30 50 67 49 58 57 68 63 91 121 88 54 1 107 19 42 35 27 33 48 61 74 83 29 156 84 22 9 28 88 254 4 55 162 85 70 36 13 133 17 60 130 152 252 12 49 51 10 121 24 76 83 1 180 240 96 116 209 253 182 0 255 255 0 176 254 20 4 68 4 72 2 6 0 119 0 0 0 1 0 0 0 0 4 2 4 72 0 14 0 28 64 12 9 10 10 0 16 15 5 14 21 9 0 15 0 63 50 63 57 17 18 1 57 57 17 51 49 48 17 51 19 22 22 23 51 54 18 17 51 16 2 7 35 172 219 26 83 16 8 177 159 166 207 225 186 4 72 253 178 67 238 62 175 1 189 1 81 254 149 254 4 225 0 1 0 113 254 111 3 160 6 20 0 49 0 73 64 39 4 25 45 31 29 28 19 12 12 40 0 28 31 37 25 7 50 51 28 48 1 48 1 71 89 48 48 16 38 41 37 38 37 70 89 38 0 16 35 0 63 63 43 17 0 51 17 18 57 24 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 35 34 6 21 20 30 2 23 22 22 21 20 6 7 35 54 54 53 52 38 39 38 38 53 52 54 55 53 38 53 52 54 55 6 35 35 53 33 21 35 34 6 6 21 20 22 51 51 3 86 178 176 213 50 95 135 84 142 135 54 67 156 53 66 115 143 200 199 158 128 217 139 166 128 115 68 2 186 51 130 224 127 167 175 170 2 242 178 142 80 98 61 36 18 29 110 90 65 149 99 71 147 52 55 61 25 34 200 176 140 210 39 12 64 217 117 158 50 12 141 131 80 144 95 115 108 255 255 0 115 255 236 4 98 4 92 2 6 0 82 0 0 0 1 0 25 255 236 4 244 4 72 0 21 0 54 64 29 10 11 7 19 16 3 19 11 13 5 22 23 18 9 13 15 13 70 89 15 15 11 21 5 0 70 89 5 22 0 63 43 0 24 63 63 43 17 0 51 51 17 18 1 23 57 17 51 17 51 49 48 37 50 55 21 6 35 34 53 17 33 17 35 17 35 53 55 33 21 35 17 20 22 4 125 38 48 43 84 219 254 35 166 221 143 4 76 213 51 117 18 131 24 253 2 209 252 70 3 186 74 68 142 253 60 74 55 0 2 0 166 254 20 4 98 4 92 0 16 0 28 0 54 64 27 21 9 9 10 26 0 10 0 29 30 6 3 14 14 17 70 89 14 16 10 27 3 23 70 89 3 22 0 63 43 0 24 63 63 43 17 18 0 57 17 18 1 57 57 17 51 17 51 17 51 49 48 1 16 0 35 34 39 35 22 21 17 35 17 16 18 51 50 18 37 34 6 21 17 22 51 50 54 53 52 38 4 98 255 0 233 179 120 8 8 168 251 234 219 252 254 33 158 151 122 183 159 152 144 2 37 254 241 254 214 94 61 212 254 219 4 31 1 10 1 31 254 209 162 207 209 254 174 102 208 222 214 212 0 0 1 0 115 254 111 3 162 4 92 0 32 0 46 64 23 14 7 0 21 21 7 27 3 34 33 4 18 18 24 11 24 30 70 89 24 16 11 35 0 63 63 43 17 18 0 57 17 51 17 18 1 23 57 17 51 17 51 49 48 1 20 22 22 23 22 22 21 20 6 7 35 54 54 53 52 38 38 39 38 38 53 16 0 51 50 22 23 7 38 35 34 6 1 31 59 143 160 148 131 54 67 156 54 67 51 110 97 204 195 1 20 248 79 158 54 53 130 114 176 170 2 10 135 132 80 34 32 107 90 66 152 95 70 148 50 40 47 38 18 37 254 219 1 30 1 54 33 24 141 51 218 0 2 0 115 255 236 4 182 4 72 0 13 0 25 0 48 64 25 20 0 14 7 7 12 0 11 4 27 26 12 23 9 23 70 89 9 15 4 17 70 89 4 22 0 63 43 0 24 63 43 17 0 51 17 18 1 23 57 17 51 17 51 49 48 1 20 6 6 35 34 0 53 16 33 33 21 33 22 1 20 22 51 50 54 53 16 39 35 34 6 4 96 123 229 154 235 254 248 2 80 1 243 254 248 178 252 191 170 161 159 171 174 65 222 200 1 252 157 241 130 1 32 254 2 62 142 167 254 247 194 209 197 182 1 14 186 208 0 0 1 0 18 255 231 3 147 4 72 0 19 0 44 64 23 3 15 0 9 15 17 4 20 21 2 17 19 17 70 89 19 15 12 5 70 89 12 22 0 63 43 0 24 63 43 17 0 51 17 18 1 23 57 17 51 49 48 1 21 33 17 20 51 50 54 55 21 6 6 35 34 38 53 17 33 53 55 3 147 254 80 205 47 98 27 35 111 48 181 170 254 215 148 4 72 142 253 150 223 13 7 125 15 18 170 170 2 127 74 68 0 0 1 0 164 255 236 4 113 4 72 0 21 0 37 64 17 12 19 6 3 19 3 23 22 15 4 15 0 9 70 89 0 22 0 63 43 0 24 63 51 17 18 1 57 57 17 51 17 51 49 48 5 34 38 17 17 51 17 20 22 51 50 54 53 52 38 39 51 22 22 21 16 0 2 115 231 232 166 158 153 167 161 28 34 166 36 28 254 254 20 250 1 10 2 88 253 176 192 195 238 251 130 224 136 144 214 140 254 194 254 212 0 0 2 0 115 254 20 5 76 4 92 0 24 0 34 0 65 64 35 10 4 32 24 24 12 0 25 19 19 0 7 4 4 35 36 16 28 70 89 16 16 6 15 32 12 1 12 70 89 23 1 22 0 27 0 63 63 51 43 17 0 51 24 63 63 43 17 18 1 23 57 17 51 17 51 51 17 51 17 51 49 48 1 17 36 0 17 16 55 23 6 6 21 16 5 17 52 54 51 50 18 21 20 2 6 7 17 1 52 38 35 34 6 21 17 54 54 2 131 254 252 254 244 207 131 89 81 1 104 166 149 180 218 136 248 165 1 121 124 102 73 78 179 198 254 20 1 218 11 1 35 1 15 1 40 253 90 117 224 124 254 117 35 2 108 187 190 254 219 250 178 254 251 144 8 254 38 4 39 185 219 120 114 253 146 16 236 0 1 255 236 254 20 4 80 4 78 0 32 0 57 64 33 14 7 8 5 21 24 30 7 34 23 33 5 24 8 21 4 6 23 27 17 12 70 89 17 27 6 15 0 28 70 89 0 15 0 63 43 0 24 63 63 43 0 24 63 18 23 57 17 1 51 18 23 57 49 48 19 50 22 22 23 19 1 51 1 19 22 22 51 50 55 21 6 35 34 38 39 3 1 35 1 3 38 38 35 34 7 53 54 178 54 78 62 44 145 1 62 180 254 84 190 48 82 63 45 45 60 59 115 141 59 150 254 150 178 1 208 172 38 70 43 37 27 49 4 78 43 91 112 254 143 2 97 252 252 254 28 122 74 8 129 15 118 159 1 131 253 104 3 68 1 188 99 80 11 129 17 0 1 0 164 254 20 5 135 6 18 0 26 0 61 64 31 22 19 1 14 14 25 15 4 10 10 15 19 3 27 28 26 0 7 20 15 1 25 16 25 70 89 13 16 22 15 27 0 63 63 51 43 17 0 51 24 63 51 63 17 18 1 23 57 17 51 17 51 51 17 51 17 51 49 48 1 17 54 54 53 52 38 39 51 18 21 16 0 5 17 35 17 36 0 17 17 51 17 20 22 23 17 3 90 188 203 26 37 166 63 254 227 254 240 164 254 248 254 246 166 180 184 6 18 250 105 15 231 204 120 235 168 254 240 244 254 236 254 206 16 254 38 1 218 9 1 34 1 16 2 31 253 219 195 218 13 5 153 0 1 0 115 255 236 5 188 4 72 0 39 0 61 64 30 10 3 38 19 19 16 25 32 32 16 3 3 40 41 38 17 17 0 28 6 15 22 13 0 13 70 89 35 0 22 0 63 50 43 17 0 51 24 63 51 18 57 47 57 17 18 1 23 57 17 51 17 51 18 57 17 51 49 48 5 34 2 53 52 18 55 51 6 6 21 20 22 51 50 54 53 17 51 17 20 22 51 50 54 53 52 2 39 51 22 18 21 20 2 35 34 39 35 6 1 244 182 203 55 68 172 68 57 120 107 94 105 161 106 93 107 120 55 69 172 65 57 203 182 220 68 9 65 20 1 40 254 156 1 1 153 156 255 157 193 216 143 125 1 55 254 201 128 140 216 193 151 1 4 157 146 254 249 157 252 254 214 182 182 255 255 0 9 255 236 2 147 5 211 2 38 1 134 0 0 1 7 0 106 254 212 0 0 0 10 180 2 1 37 17 38 0 43 53 53 255 255 0 164 255 236 4 113 5 211 2 38 1 146 0 0 1 6 0 106 57 0 0 10 180 2 1 43 17 38 0 43 53 53 255 255 0 115 255 236 4 98 6 115 2 38 0 82 0 0 1 6 1 84 33 0 0 8 179 2 34 17 38 0 43 53 255 255 0 164 255 236 4 113 6 115 2 38 1 146 0 0 1 6 1 84 39 0 0 8 179 1 31 17 38 0 43 53 255 255 0 115 255 236 5 188 6 115 2 38 1 150 0 0 1 7 1 84 0 201 0 0 0 8 179 1 49 17 38 0 43 53 255 255 0 201 0 0 3 248 7 37 2 38 0 40 0 0 1 7 0 106 0 39 1 82 0 10 180 2 1 33 5 38 0 43 53 53 0 1 0 18 255 236 5 66 5 182 0 29 0 70 64 38 22 14 14 15 8 27 27 20 2 15 17 5 30 31 22 13 73 89 22 22 15 18 21 17 18 17 73 89 18 3 15 18 0 5 73 89 0 19 0 63 43 0 24 63 63 43 17 0 51 17 18 57 24 47 43 17 18 1 23 57 17 51 17 51 17 51 49 48 5 34 39 53 22 51 50 54 53 53 52 38 35 33 17 35 17 33 53 33 21 33 17 33 50 22 21 21 20 6 3 207 96 54 55 91 101 104 131 140 254 131 170 254 176 3 183 254 67 1 140 205 221 196 20 22 150 19 124 112 131 128 113 253 27 5 31 151 151 254 94 191 178 143 190 211 255 255 0 201 0 0 3 248 7 115 2 38 1 97 0 0 1 7 0 118 0 90 1 82 0 8 179 1 15 5 38 0 43 53 0 1 0 125 255 236 4 227 5 205 0 24 0 56 64 30 6 3 17 22 12 5 17 4 25 26 3 6 73 89 3 3 14 20 20 0 73 89 20 4 14 9 73 89 14 19 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 51 49 48 1 34 4 7 33 21 33 18 0 51 50 55 21 6 35 32 0 17 16 0 33 50 23 7 38 3 66 226 254 243 30 2 211 253 41 10 1 11 249 162 201 161 226 254 180 254 162 1 121 1 78 237 178 71 169 5 51 250 241 150 254 238 254 227 55 149 57 1 132 1 109 1 95 1 145 88 148 82 255 255 0 106 255 236 4 2 5 203 2 6 0 54 0 0 255 255 0 84 0 0 2 86 5 182 2 6 0 44 0 0 255 255 0 60 0 0 2 111 7 37 2 38 0 44 0 0 1 7 0 106 255 7 1 82 0 10 180 2 1 33 5 38 0 43 53 53 255 255 255 96 254 127 1 104 5 182 2 6 0 45 0 0 0 2 0 0 255 233 7 35 5 182 0 26 0 35 0 71 64 38 24 27 27 4 31 0 0 4 13 3 36 37 24 35 73 89 24 24 11 22 22 6 73 89 22 3 11 16 74 89 11 18 4 27 74 89 4 18 0 63 43 0 24 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 20 4 33 33 17 33 2 2 6 6 35 34 39 53 22 51 50 62 2 18 19 33 17 51 32 1 51 50 54 53 52 38 35 35 7 35 254 237 254 252 254 185 254 147 57 84 80 139 107 69 64 50 63 48 65 43 55 68 65 2 166 122 2 58 253 76 133 198 183 192 220 102 1 170 206 220 5 31 254 72 253 246 251 121 25 143 26 62 103 250 1 190 1 226 253 144 253 77 139 140 138 124 0 2 0 201 0 0 7 84 5 182 0 17 0 26 0 74 64 38 11 7 7 8 15 18 18 12 4 22 0 0 4 8 3 27 28 26 6 11 6 73 89 15 11 11 4 13 9 3 8 18 4 18 74 89 4 18 0 63 43 0 24 63 63 51 18 57 47 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 17 51 17 51 49 48 1 20 4 33 33 17 33 17 35 17 51 17 33 17 51 17 51 32 1 51 50 54 53 52 38 35 35 7 84 254 240 254 251 254 183 253 125 170 170 2 131 172 121 2 57 253 78 133 196 185 193 219 102 1 170 206 220 2 176 253 80 5 182 253 146 2 110 253 144 253 77 139 140 137 125 0 0 1 0 18 0 0 5 66 5 182 0 19 0 58 64 31 0 12 12 13 6 5 5 18 13 15 4 20 21 19 15 16 15 73 89 0 11 73 89 0 0 13 16 3 6 13 18 0 63 51 63 18 57 47 43 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 49 48 1 33 50 22 21 17 35 17 52 38 35 33 17 35 17 33 53 33 21 33 2 12 1 144 205 217 170 125 140 254 125 170 254 176 3 246 254 4 3 125 188 181 253 244 1 246 126 113 253 27 5 31 151 151 255 255 0 201 0 0 4 229 7 115 2 38 1 180 0 0 1 7 0 118 0 162 1 82 0 8 179 1 20 5 38 0 43 53 255 255 0 27 255 236 4 248 7 94 2 38 1 189 0 0 1 7 2 54 0 68 1 82 0 8 179 1 23 5 38 0 43 53 0 1 0 201 254 131 5 12 5 182 0 11 0 48 64 24 8 5 2 3 9 0 0 3 5 3 12 13 10 6 3 5 8 73 89 1 5 18 3 34 0 63 63 51 43 0 24 63 51 17 18 1 23 57 17 51 17 51 17 51 49 48 33 33 17 35 17 33 17 51 17 33 17 51 5 12 254 47 176 254 62 170 2 239 170 254 131 1 125 5 182 250 228 5 28 0 255 255 0 0 0 0 5 16 5 188 2 6 0 36 0 0 0 2 0 201 0 0 4 125 5 182 0 13 0 22 0 61 64 32 18 0 9 14 14 4 4 7 0 3 24 23 9 22 73 89 9 9 4 5 5 8 73 89 5 3 4 14 74 89 4 18 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 20 4 33 33 17 33 21 33 17 51 50 22 22 1 51 50 54 53 52 38 35 35 4 125 254 253 254 251 254 84 3 94 253 76 227 193 242 116 252 246 239 190 173 176 219 207 1 170 218 208 5 182 151 254 39 89 174 254 84 130 149 142 120 0 255 255 0 201 0 0 4 190 5 182 2 6 0 37 0 0 255 255 0 201 0 0 3 248 5 182 2 6 1 97 0 0 0 2 0 14 254 131 5 74 5 182 0 13 0 19 0 67 64 36 4 5 19 7 16 10 14 12 1 0 0 12 10 7 5 5 20 21 10 16 73 89 10 3 1 5 34 19 12 6 3 6 73 89 3 18 0 63 43 17 0 51 51 24 63 51 63 43 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 49 48 1 35 17 33 17 35 17 51 18 18 19 33 17 51 33 17 33 6 2 7 5 74 162 252 8 162 113 154 219 12 2 145 185 254 157 254 179 18 206 137 254 131 1 125 254 131 2 23 1 3 2 230 1 51 250 228 4 131 242 253 89 234 0 255 255 0 201 0 0 3 248 5 182 2 6 0 40 0 0 0 1 0 2 0 0 6 188 5 182 0 17 0 60 64 31 6 13 13 3 14 10 9 8 1 14 0 17 7 18 19 15 12 9 6 3 0 0 1 14 11 17 18 7 4 1 3 0 63 51 51 63 51 51 18 57 17 51 51 51 51 51 17 18 1 23 57 17 51 51 17 51 49 48 1 1 51 1 17 51 17 1 51 1 1 35 1 17 35 17 1 35 2 86 253 193 190 2 57 164 2 58 190 253 192 2 82 196 253 186 164 253 187 199 2 240 2 198 253 60 2 196 253 60 2 196 253 60 253 14 2 229 253 27 2 229 253 27 0 1 0 74 255 236 4 53 5 203 0 40 0 67 64 36 28 0 19 7 7 0 3 23 35 12 6 41 42 3 24 23 24 23 74 89 24 24 10 38 38 31 74 89 38 4 10 16 74 89 10 19 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 49 48 1 20 6 7 21 22 22 21 20 4 33 34 39 53 22 22 51 50 54 53 52 38 35 35 53 51 50 54 53 52 38 35 34 6 7 39 54 54 51 50 22 4 25 183 161 183 189 254 206 254 233 255 163 96 223 103 198 203 225 223 218 209 205 225 162 137 110 178 117 84 101 251 135 225 255 4 96 144 180 24 8 25 180 145 205 229 79 158 46 50 150 141 134 138 143 147 132 107 128 50 74 114 75 77 197 0 1 0 203 0 0 5 82 5 182 0 15 0 52 64 24 14 2 2 15 6 9 9 8 15 8 16 17 5 4 12 13 4 13 9 15 18 6 0 3 0 63 50 63 51 57 57 17 51 17 51 17 18 1 57 57 17 51 17 51 17 51 17 51 49 48 19 51 17 20 7 51 1 51 17 35 17 52 55 35 1 35 203 159 14 8 3 52 186 160 17 9 252 203 186 5 182 252 211 225 182 4 196 250 74 3 37 201 221 251 53 0 255 255 0 203 0 0 5 82 7 94 2 38 1 178 0 0 1 7 2 54 0 225 1 82 0 8 179 1 16 5 38 0 43 53 0 1 0 201 0 0 4 229 5 182 0 10 0 45 64 22 7 3 3 4 0 9 10 4 4 11 12 10 7 2 7 4 8 5 3 1 4 18 0 63 51 63 51 18 57 57 17 51 17 18 1 23 57 17 51 17 51 49 48 33 35 1 17 35 17 51 17 1 51 1 4 229 206 253 92 170 170 2 147 195 253 121 2 229 253 27 5 182 253 60 2 196 253 58 0 1 0 0 255 231 4 217 5 182 0 19 0 45 64 24 3 18 1 0 0 18 10 3 20 21 18 3 73 89 18 3 8 13 74 89 8 19 1 18 0 63 63 43 0 24 63 43 17 18 1 23 57 17 51 17 51 49 48 33 35 17 33 7 2 2 6 39 34 39 53 22 51 50 54 54 18 19 33 4 217 170 254 37 31 61 93 152 126 74 59 54 59 53 79 61 93 56 3 18 5 31 240 254 33 254 69 174 2 25 143 26 87 215 2 89 1 184 255 255 0 201 0 0 6 113 5 182 2 6 0 48 0 0 255 255 0 201 0 0 5 31 5 182 2 6 0 43 0 0 255 255 0 125 255 236 5 190 5 205 2 6 0 50 0 0 255 255 0 201 0 0 5 12 5 182 2 6 1 110 0 0 255 255 0 201 0 0 4 104 5 182 2 6 0 51 0 0 255 255 0 125 255 236 4 207 5 203 2 6 0 38 0 0 255 255 0 18 0 0 4 90 5 182 2 6 0 55 0 0 0 1 0 27 255 236 4 248 5 182 0 22 0 42 64 21 18 8 2 9 4 23 24 14 13 8 13 0 17 9 3 0 5 73 89 0 19 0 63 43 0 24 63 51 18 57 57 17 51 17 18 1 23 57 49 48 5 34 39 53 22 51 50 54 55 1 51 1 22 23 51 54 55 1 51 1 14 2 1 37 111 84 93 96 110 133 66 253 199 188 1 176 25 14 8 28 11 1 103 180 254 45 84 135 169 20 30 166 43 101 139 4 65 252 193 49 47 84 22 3 53 251 234 187 170 79 255 255 0 106 255 236 5 248 5 203 2 6 1 115 0 0 255 255 0 8 0 0 4 150 5 182 2 6 0 59 0 0 0 1 0 201 254 131 5 184 5 182 0 11 0 50 64 25 8 5 9 0 3 2 2 0 5 3 12 13 10 6 3 0 8 5 8 73 89 5 18 3 34 0 63 63 43 17 0 51 24 63 51 17 18 1 23 57 17 51 17 51 17 51 49 48 37 51 17 35 17 33 17 51 17 33 17 51 5 12 172 161 251 178 170 2 239 170 154 253 233 1 125 5 182 250 228 5 28 0 0 1 0 170 0 0 4 199 5 182 0 19 0 45 64 22 11 8 17 1 1 0 8 0 20 21 5 14 73 89 5 5 1 18 9 3 1 18 0 63 63 51 18 57 47 43 17 18 1 57 57 17 51 17 51 17 51 49 48 33 35 17 6 6 35 34 38 53 17 51 17 20 22 51 50 54 55 17 51 4 199 170 149 198 106 207 223 170 127 143 97 177 169 170 2 92 53 39 190 179 2 69 253 207 121 116 29 55 2 202 0 1 0 201 0 0 7 121 5 182 0 11 0 49 64 24 4 1 8 5 9 0 0 5 1 3 12 13 10 6 2 3 8 4 1 4 73 89 1 18 0 63 43 17 0 51 24 63 51 51 17 18 1 23 57 17 51 17 51 17 51 49 48 33 33 17 51 17 33 17 51 17 33 17 51 7 121 249 80 170 2 88 170 2 88 172 5 182 250 228 5 28 250 228 5 28 0 1 0 201 254 131 8 4 5 182 0 15 0 59 64 30 3 0 7 4 8 11 14 13 13 11 4 0 4 16 17 14 34 9 5 1 3 11 7 3 0 3 73 89 0 18 0 63 43 17 0 51 51 24 63 51 51 63 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 51 17 51 17 33 17 51 17 33 17 51 17 51 17 35 17 201 170 2 71 172 2 72 170 172 162 5 182 250 228 5 28 250 228 5 28 250 228 253 233 1 125 0 0 2 0 18 0 0 5 23 5 182 0 12 0 21 0 61 64 32 9 13 13 4 17 0 0 4 6 3 22 23 9 21 73 89 9 9 4 7 7 6 73 89 7 3 4 13 74 89 4 18 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 20 4 35 33 17 33 53 33 17 51 32 4 1 51 50 54 53 52 38 35 35 5 23 254 253 249 254 71 254 176 1 250 244 1 5 1 18 252 245 252 181 169 175 203 224 1 170 206 220 5 31 151 253 144 205 254 26 139 140 136 126 0 0 3 0 201 0 0 6 10 5 182 0 10 0 19 0 23 0 63 64 32 3 11 11 0 15 7 21 20 20 7 0 3 24 25 21 18 3 19 73 89 3 3 0 22 1 3 0 11 74 89 0 18 0 63 43 0 24 63 51 18 57 47 43 0 24 63 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 51 17 51 17 51 32 4 21 20 4 35 37 51 50 54 53 52 38 35 35 1 35 17 51 201 170 239 1 5 1 18 254 253 249 254 246 247 181 170 179 200 219 4 151 170 170 5 182 253 144 205 207 206 220 145 141 140 137 123 253 82 5 182 0 2 0 201 0 0 4 186 5 182 0 10 0 18 0 50 64 25 7 11 11 4 14 0 4 0 19 20 7 18 73 89 7 7 4 5 3 4 11 74 89 4 18 0 63 43 0 24 63 18 57 47 43 17 18 1 57 57 17 51 17 51 17 51 49 48 1 20 4 35 33 17 51 17 33 32 4 1 33 32 17 52 38 35 33 4 186 254 241 251 254 25 170 1 35 1 11 1 25 252 185 1 43 1 108 187 206 254 242 1 170 203 223 5 182 253 144 211 254 32 1 23 135 127 0 1 0 61 255 236 4 137 5 203 0 26 0 58 64 31 24 21 21 9 9 22 15 3 4 27 28 23 22 73 89 23 23 12 5 12 18 73 89 12 19 5 0 73 89 5 4 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 49 48 1 34 7 39 54 51 50 4 18 21 16 0 33 34 39 53 22 22 51 32 0 19 33 53 33 38 0 1 211 172 162 72 172 236 217 1 57 162 254 148 254 170 227 156 83 172 99 1 15 1 20 8 253 49 2 205 22 254 241 5 51 76 144 84 176 254 186 221 254 136 254 108 57 149 21 34 1 33 1 16 152 229 1 2 0 2 0 201 255 236 7 231 5 205 0 18 0 30 0 71 64 38 12 8 8 9 19 13 6 25 0 0 6 9 3 31 32 16 28 73 89 16 4 12 7 73 89 12 12 9 10 3 9 18 3 22 73 89 3 19 0 63 43 0 24 63 63 18 57 47 43 0 24 63 43 17 18 1 23 57 17 51 17 51 51 17 51 17 51 49 48 1 16 0 33 32 0 3 33 17 35 17 51 17 33 18 0 33 32 0 1 16 18 51 50 18 17 16 2 35 34 2 7 231 254 171 254 208 254 211 254 171 11 254 158 170 170 1 100 23 1 81 1 31 1 51 1 86 251 160 238 231 234 237 235 232 233 240 2 221 254 158 254 113 1 111 1 85 253 80 5 182 253 146 1 55 1 78 254 111 254 161 254 216 254 204 1 50 1 42 1 42 1 46 254 207 0 2 0 51 0 0 4 78 5 182 0 13 0 21 0 61 64 32 21 12 12 11 18 6 2 6 3 11 4 23 22 0 20 74 89 3 9 0 0 2 9 9 15 74 89 9 3 12 2 18 0 63 51 63 43 17 18 0 57 24 47 18 57 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 1 35 1 38 38 53 52 36 33 33 17 35 17 17 35 34 6 21 16 33 51 2 123 254 129 201 1 154 161 146 1 15 1 19 1 146 170 227 183 190 1 123 221 2 98 253 158 2 127 51 207 158 196 211 250 74 2 98 2 193 126 142 254 221 255 255 0 94 255 236 3 205 4 90 2 6 0 68 0 0 0 2 0 119 255 236 4 84 6 33 0 23 0 34 0 59 64 30 26 18 32 11 0 0 6 18 3 36 35 12 11 15 28 70 89 11 15 15 21 5 21 24 70 89 21 22 5 1 0 63 63 43 17 18 0 57 24 47 57 43 17 0 51 17 18 1 23 57 17 51 51 17 51 49 48 19 16 18 55 36 55 23 4 7 6 6 7 51 54 54 51 50 18 21 16 0 35 34 0 5 32 17 16 33 34 6 6 7 16 18 119 212 230 1 30 218 31 254 165 149 145 145 7 12 62 196 107 202 226 254 250 234 231 254 250 1 252 1 49 254 235 76 141 117 32 166 2 145 1 104 1 147 50 61 38 146 58 34 33 246 212 84 96 254 250 232 254 255 254 223 1 98 215 1 133 1 115 63 104 55 254 249 254 237 0 3 0 176 0 0 4 76 4 72 0 14 0 22 0 31 0 73 64 38 28 20 20 11 23 0 15 7 7 0 3 11 4 32 33 4 28 19 28 19 70 89 28 28 11 12 12 27 70 89 12 15 11 20 70 89 11 21 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 20 6 7 21 22 22 21 20 6 35 33 17 33 32 3 52 38 35 33 17 33 32 3 52 38 35 33 17 33 50 54 4 41 123 111 140 129 225 216 254 29 1 225 1 152 131 135 156 254 211 1 49 1 31 31 123 125 254 199 1 25 154 126 3 53 107 111 19 9 19 126 111 153 166 4 72 253 2 89 81 254 151 2 154 80 67 254 203 76 0 0 1 0 176 0 0 3 68 4 72 0 5 0 29 64 14 2 3 0 3 7 6 4 1 70 89 4 15 3 21 0 63 63 43 17 18 1 57 57 17 51 49 48 1 33 17 35 17 33 3 68 254 18 166 2 148 3 186 252 70 4 72 0 2 0 41 254 133 4 104 4 72 0 13 0 19 0 67 64 36 4 5 19 7 16 10 14 12 1 0 0 12 10 7 5 5 20 21 10 16 71 89 10 15 1 5 34 19 12 6 3 6 70 89 3 21 0 63 43 17 0 51 51 24 63 51 63 43 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 49 48 1 35 17 33 17 35 17 51 54 18 19 33 17 51 33 17 35 6 2 7 4 104 161 253 2 160 86 134 152 3 2 43 157 254 195 246 13 145 108 254 133 1 123 254 133 2 10 182 1 234 1 25 252 71 3 54 222 254 57 145 0 255 255 0 115 255 236 4 18 4 92 2 6 0 72 0 0 0 1 0 4 0 0 5 223 4 70 0 17 0 60 64 31 2 9 9 17 10 6 4 5 10 14 15 13 7 19 18 17 11 8 5 2 14 14 13 3 0 15 15 10 7 13 21 0 63 51 51 63 51 51 18 57 17 51 51 51 51 51 17 18 1 23 57 17 51 51 17 51 49 48 1 51 17 1 51 1 1 35 1 17 35 17 1 35 1 1 51 1 2 164 153 1 197 182 254 54 1 241 192 254 30 153 254 31 191 1 240 254 55 182 1 195 4 70 253 237 2 19 253 237 253 205 2 43 253 213 2 43 253 213 2 51 2 19 253 237 0 1 0 68 255 236 3 127 4 92 0 34 0 77 64 43 2 13 30 19 19 13 15 33 8 24 6 35 36 16 34 33 34 33 70 89 15 34 31 34 2 11 3 34 34 22 10 22 27 70 89 22 22 10 4 70 89 10 16 0 63 43 0 24 63 43 17 18 0 57 24 47 95 94 93 43 17 18 0 57 17 18 1 23 57 17 51 17 51 49 48 1 32 53 52 35 34 6 7 39 54 51 50 22 21 20 7 21 22 22 21 20 6 35 34 39 53 22 51 50 54 53 52 33 35 53 1 129 1 55 252 77 126 102 59 170 201 189 218 205 126 116 245 216 237 129 183 187 144 147 254 201 152 2 129 172 162 28 42 135 76 155 134 184 57 8 37 137 103 152 169 71 152 86 99 93 191 141 0 1 0 176 0 0 4 98 4 72 0 13 0 52 64 25 8 4 7 7 6 11 3 3 12 6 12 15 14 3 10 12 4 13 15 12 21 7 21 4 15 0 63 63 63 63 17 18 57 57 17 18 1 57 57 17 51 17 51 17 51 17 51 51 49 48 1 17 7 7 1 51 17 35 17 55 55 1 35 17 1 76 7 3 2 81 207 155 3 5 253 176 207 4 72 253 73 182 57 3 166 251 184 2 158 132 130 252 92 4 72 0 255 255 0 176 0 0 4 98 6 12 2 38 1 210 0 0 1 6 2 54 61 0 0 8 179 1 14 17 38 0 43 53 0 1 0 176 0 0 4 12 4 72 0 10 0 45 64 22 10 6 6 7 3 1 2 7 4 12 11 2 10 5 10 7 0 8 15 4 7 21 0 63 51 63 51 18 57 57 17 51 17 18 1 23 57 17 51 17 51 49 48 1 51 1 1 35 1 17 35 17 51 17 3 47 182 254 39 2 0 194 254 12 166 166 4 72 253 239 253 201 2 43 253 213 4 72 253 235 0 1 0 16 255 242 3 225 4 72 0 16 0 45 64 24 1 0 3 15 10 15 0 3 18 17 15 3 70 89 15 15 7 12 71 89 7 22 1 21 0 63 63 43 0 24 63 43 17 18 1 23 57 17 51 17 51 49 48 33 35 17 33 2 2 6 35 34 39 53 22 51 50 18 19 33 3 225 168 254 183 27 96 153 118 54 32 22 28 115 136 35 2 129 3 186 254 156 254 94 194 12 123 6 1 230 1 239 0 1 0 176 0 0 5 47 4 70 0 20 0 53 64 25 3 6 6 5 18 15 15 16 5 16 22 21 7 14 0 14 11 3 17 15 6 16 21 11 21 0 63 63 51 63 51 18 57 57 17 51 17 18 1 57 57 17 51 17 51 17 51 17 51 49 48 37 55 55 1 51 17 35 17 7 7 1 35 1 38 39 17 35 17 51 1 22 2 233 31 43 1 41 211 147 20 58 254 229 139 254 229 53 20 148 203 1 31 43 160 93 118 2 211 251 186 3 137 58 153 253 74 2 184 134 75 252 119 4 70 253 73 110 0 1 0 176 0 0 4 98 4 72 0 11 0 57 64 30 2 6 6 5 1 9 9 10 5 10 13 12 1 8 70 89 47 1 63 1 2 1 1 10 3 11 15 6 10 21 0 63 51 63 51 18 57 47 93 43 17 18 1 57 57 17 51 17 51 17 51 17 51 49 48 1 17 33 17 51 17 35 17 33 17 35 17 1 86 2 102 166 166 253 154 166 4 72 254 53 1 203 251 184 1 238 254 18 4 72 255 255 0 115 255 236 4 98 4 92 2 6 0 82 0 0 0 1 0 176 0 0 4 72 4 72 0 7 0 35 64 17 0 1 5 4 1 4 8 9 2 7 70 89 2 15 5 1 21 0 63 51 63 43 17 18 1 57 57 17 51 17 51 49 48 33 35 17 33 17 35 17 33 1 86 166 3 152 168 253 182 4 72 251 184 3 184 0 255 255 0 176 254 20 4 117 4 92 2 6 0 83 0 0 255 255 0 115 255 236 3 139 4 92 2 6 0 70 0 0 0 1 0 41 0 0 3 147 4 72 0 7 0 36 64 18 2 3 0 3 5 3 8 9 1 5 6 5 70 89 6 15 3 21 0 63 63 43 17 0 51 17 18 1 23 57 17 51 49 48 1 33 17 35 17 33 53 33 3 147 254 156 166 254 160 3 106 3 186 252 70 3 186 142 255 255 0 2 254 20 4 6 4 72 2 6 0 92 0 0 0 3 0 113 254 20 5 70 6 20 0 17 0 24 0 30 0 76 64 39 18 9 28 15 4 4 21 12 5 25 0 0 5 9 3 31 32 13 0 27 22 12 22 70 89 15 12 16 28 21 6 21 70 89 3 6 22 5 27 0 63 63 51 43 17 0 51 24 63 51 43 17 0 51 24 63 17 18 1 23 57 17 51 17 51 51 51 17 51 51 17 51 49 48 1 20 0 7 17 35 17 38 0 53 52 0 55 17 51 17 22 0 5 20 22 23 17 6 6 5 16 37 17 54 54 5 70 254 229 254 164 248 254 224 1 31 255 158 251 1 30 251 217 176 192 185 183 3 123 254 147 190 175 2 37 249 254 217 21 254 36 1 220 19 1 46 244 249 1 38 20 1 188 254 68 23 254 212 240 192 218 18 3 84 17 207 200 1 127 39 252 174 19 218 255 255 0 39 0 0 4 8 4 72 2 6 0 91 0 0 0 1 0 176 254 133 4 221 4 72 0 11 0 50 64 25 6 3 7 10 1 0 0 10 3 3 12 13 8 4 15 10 6 3 6 70 89 3 21 1 34 0 63 63 43 17 0 51 24 63 51 17 18 1 23 57 17 51 17 51 17 51 49 48 1 35 17 33 17 51 17 33 17 51 17 51 4 221 166 252 121 166 2 70 166 155 254 133 1 123 4 72 252 71 3 185 252 71 0 1 0 156 0 0 4 45 4 72 0 18 0 45 64 22 6 10 10 9 1 17 9 17 20 19 3 14 70 89 3 3 10 7 18 15 10 21 0 63 63 51 18 57 47 43 17 18 1 57 57 17 51 17 51 17 51 49 48 1 17 20 51 50 54 55 17 51 17 35 17 6 6 35 34 38 53 17 1 66 219 91 166 105 166 166 105 179 113 164 186 4 72 254 112 192 56 67 1 213 251 184 1 240 72 59 172 147 1 156 0 1 0 176 0 0 6 111 4 72 0 11 0 49 64 24 8 5 0 9 1 4 4 9 5 3 12 13 10 2 6 15 0 8 5 8 70 89 5 21 0 63 43 17 0 51 24 63 51 51 17 18 1 23 57 17 51 17 51 17 51 49 48 37 33 17 51 17 33 17 51 17 33 17 51 3 225 1 230 168 250 65 166 1 229 166 143 3 185 251 184 4 72 252 71 3 185 0 0 1 0 176 254 135 7 10 4 70 0 15 0 59 64 30 12 9 0 13 1 4 7 6 6 4 13 9 4 16 17 14 2 10 15 4 0 12 9 12 70 89 9 21 7 34 0 63 63 43 17 0 51 51 24 63 51 51 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 37 33 17 51 17 51 17 35 17 33 17 51 17 33 17 51 3 225 1 230 166 157 168 250 78 166 1 229 166 143 3 183 252 73 253 248 1 121 4 70 252 73 3 183 0 0 2 0 41 0 0 5 29 4 72 0 12 0 20 0 61 64 32 0 18 18 8 13 4 4 8 10 3 21 22 0 17 70 89 0 0 8 11 11 10 70 89 11 15 8 18 70 89 8 21 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 33 50 22 21 20 6 35 33 17 33 53 33 1 52 38 35 33 17 33 32 2 45 1 57 224 215 223 220 254 37 254 162 2 4 2 76 124 157 254 205 1 57 1 19 2 131 154 155 166 168 3 186 142 252 252 93 83 254 151 0 0 3 0 176 0 0 5 121 4 72 0 10 0 14 0 22 0 63 64 32 0 16 16 8 4 19 12 11 11 19 8 3 23 24 12 21 0 15 70 89 0 0 8 13 9 15 8 16 70 89 8 21 0 63 43 0 24 63 51 18 57 47 43 0 24 63 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 33 50 22 21 20 6 35 33 17 51 1 35 17 51 1 17 33 32 53 52 38 35 1 86 1 43 209 201 213 207 254 57 166 4 35 166 166 251 221 1 25 1 8 122 147 2 131 155 154 165 169 4 72 251 184 4 72 253 172 254 151 185 92 84 0 2 0 176 0 0 4 76 4 72 0 9 0 18 0 50 64 25 15 3 0 11 11 7 3 7 20 19 0 10 70 89 0 0 7 8 15 7 11 70 89 7 21 0 63 43 0 24 63 18 57 47 43 17 18 1 57 57 17 51 17 51 17 51 49 48 1 33 32 17 20 6 35 33 17 51 17 17 33 50 54 53 52 38 35 1 86 1 82 1 164 219 211 254 18 166 1 64 132 140 129 148 2 131 254 203 162 172 4 72 253 172 254 151 92 93 91 85 0 1 0 57 255 236 3 125 4 92 0 26 0 68 64 38 12 9 9 24 24 10 18 2 4 27 28 11 10 70 89 15 11 31 11 2 11 3 11 11 0 21 21 15 70 89 21 16 0 6 70 89 0 22 0 63 43 0 24 63 43 17 18 0 57 24 47 95 94 93 43 17 18 1 23 57 17 51 17 51 49 48 5 34 39 53 22 22 51 50 54 55 33 53 33 38 38 35 34 7 39 54 54 51 32 0 17 16 0 1 86 167 118 60 140 91 174 189 10 253 213 2 41 16 169 161 103 151 47 55 164 80 1 0 1 10 254 223 20 57 147 23 36 186 185 141 172 160 54 140 26 35 254 219 254 236 254 243 254 214 0 2 0 176 255 236 6 51 4 92 0 18 0 30 0 81 64 45 12 8 8 9 19 13 6 25 0 0 6 9 3 31 32 16 28 70 89 16 16 12 7 70 89 15 12 31 12 2 11 3 12 12 9 10 15 9 21 3 22 70 89 3 22 0 63 43 0 24 63 63 18 57 47 95 94 93 43 0 24 63 43 17 18 1 23 57 17 51 17 51 51 17 51 17 51 49 48 1 16 0 35 34 2 39 33 17 35 17 51 17 33 54 54 51 50 0 1 20 22 51 50 54 53 52 38 35 34 6 6 51 254 255 224 213 250 14 254 225 166 166 1 33 20 252 207 220 1 1 252 238 146 161 158 149 146 161 161 146 2 37 254 243 254 212 1 11 247 254 18 4 72 254 53 228 251 254 207 254 250 211 219 213 217 210 216 216 0 2 0 37 0 0 3 193 4 72 0 13 0 20 0 61 64 32 17 11 11 10 14 5 1 5 2 10 4 22 21 13 16 70 89 2 8 13 13 1 8 8 19 70 89 8 15 11 1 21 0 63 51 63 43 17 18 0 57 24 47 18 57 43 17 18 1 23 57 17 51 17 51 17 51 49 48 51 35 1 38 38 53 52 54 51 33 17 35 17 33 1 20 33 33 17 33 34 231 194 1 59 127 135 202 181 1 232 166 254 235 254 246 1 20 1 11 254 211 242 1 207 28 161 122 150 172 251 184 1 182 1 78 190 1 114 255 255 0 115 255 236 4 18 5 211 2 38 0 72 0 0 1 6 0 106 8 0 0 10 180 3 2 48 17 38 0 43 53 53 0 1 0 20 254 20 4 68 6 20 0 39 0 102 64 58 29 27 23 15 15 20 16 7 37 37 25 2 16 18 5 40 41 30 29 33 11 70 89 26 18 19 18 71 89 23 19 15 19 31 19 47 19 3 9 3 29 33 19 19 33 29 3 16 21 0 16 21 0 5 70 89 0 27 0 63 43 0 24 63 63 18 23 57 47 47 47 95 94 93 17 51 43 17 0 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 51 51 49 48 1 34 39 53 22 51 50 53 17 52 38 35 34 6 21 17 35 17 35 53 51 53 51 21 33 21 33 21 20 7 51 54 54 51 50 22 21 17 20 6 3 47 79 52 58 55 129 122 130 173 157 168 156 156 166 1 145 254 111 8 10 49 181 116 201 201 137 254 20 25 137 20 170 3 82 134 132 188 211 253 231 4 219 127 186 186 127 196 84 56 79 91 191 210 252 182 156 170 255 255 0 176 0 0 3 68 6 33 2 38 1 205 0 0 1 6 0 118 241 0 0 8 179 1 15 17 38 0 43 53 0 1 0 115 255 236 3 170 4 92 0 25 0 68 64 38 15 18 18 3 9 24 17 3 4 26 27 15 18 70 89 15 15 31 15 2 11 3 15 15 0 6 6 12 70 89 6 16 0 21 70 89 0 22 0 63 43 0 24 63 43 17 18 0 57 24 47 95 94 93 43 17 18 1 23 57 17 51 17 51 49 48 5 34 0 17 16 0 51 50 22 23 7 38 35 34 6 7 33 21 33 22 22 51 50 55 21 6 2 121 248 254 242 1 19 251 82 158 57 49 143 109 164 170 16 2 41 253 213 9 170 167 140 151 116 20 1 35 1 16 1 19 1 42 32 25 141 51 163 169 141 190 181 59 147 57 255 255 0 106 255 236 3 115 4 92 2 6 0 86 0 0 255 255 0 162 0 0 1 102 5 223 2 6 0 76 0 0 255 255 255 236 0 0 2 31 5 211 2 38 0 243 0 0 1 7 0 106 254 183 0 0 0 10 180 2 1 25 17 38 0 43 53 53 255 255 255 145 254 20 1 102 5 223 2 6 0 77 0 0 0 2 0 16 255 242 6 66 4 72 0 21 0 29 0 76 64 41 9 20 0 27 27 7 22 4 4 7 20 14 4 30 31 0 26 70 89 0 0 12 20 20 9 70 89 20 15 12 17 71 89 12 21 7 27 70 89 7 21 0 63 43 0 24 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 51 50 22 21 16 33 33 17 33 2 2 35 34 39 53 22 51 50 18 19 33 1 52 38 35 35 17 51 32 3 176 244 211 203 254 75 254 101 254 254 40 181 171 56 32 22 28 115 136 35 2 80 1 236 125 158 231 237 1 21 2 131 155 154 254 178 3 186 253 250 254 62 12 123 6 1 230 1 239 252 252 91 85 254 151 0 2 0 176 0 0 6 164 4 70 0 17 0 25 0 74 64 38 15 11 11 12 1 19 19 16 8 22 5 5 8 12 3 26 27 18 10 15 10 70 89 1 15 15 8 17 13 15 12 21 8 19 70 89 8 21 0 63 43 0 24 63 63 51 18 57 47 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 17 51 17 51 49 48 1 17 33 50 22 21 16 33 33 17 33 17 35 17 51 17 33 17 19 17 51 32 53 52 38 35 4 0 1 0 217 203 254 78 254 96 254 10 172 172 1 250 166 240 1 20 128 153 4 70 254 59 153 154 254 178 1 238 254 18 4 70 254 55 1 201 253 174 254 151 185 92 84 0 255 255 0 20 0 0 4 68 6 20 2 6 0 233 0 0 255 255 0 176 0 0 4 12 6 33 2 38 1 212 0 0 1 6 0 118 51 0 0 8 179 1 20 17 38 0 43 53 255 255 0 2 254 20 4 6 6 12 2 38 0 92 0 0 1 6 2 54 183 0 0 8 179 1 22 17 38 0 43 53 0 1 0 176 254 135 4 70 4 70 0 11 0 50 64 25 4 1 10 11 5 8 8 11 1 3 12 13 11 34 6 2 15 9 1 1 4 70 89 1 21 0 63 43 17 0 51 24 63 51 63 17 18 1 23 57 17 51 17 51 17 51 49 48 33 33 17 51 17 33 17 51 17 33 17 35 2 47 254 129 166 2 74 166 254 143 166 4 70 252 73 3 183 251 186 254 135 0 0 1 0 201 0 0 4 8 6 227 0 7 0 35 64 17 0 3 5 6 3 6 9 8 7 4 73 89 1 7 3 6 18 0 63 63 198 43 17 18 1 57 57 17 51 17 51 49 48 1 17 51 17 33 17 35 17 3 102 162 253 107 170 5 182 1 45 254 58 250 227 5 182 0 0 1 0 176 0 0 3 68 5 137 0 7 0 39 64 18 5 0 2 3 0 3 9 8 6 4 4 1 71 89 4 15 3 21 0 63 63 43 0 24 16 198 17 18 1 57 57 17 51 17 51 49 48 1 33 17 35 17 33 17 51 3 68 254 18 166 1 238 166 3 199 252 57 4 72 1 65 0 255 255 0 27 0 0 7 76 7 115 2 38 0 58 0 0 1 7 0 67 1 23 1 82 0 8 179 1 27 5 38 0 43 53 255 255 0 23 0 0 6 35 6 33 2 38 0 90 0 0 1 6 0 67 115 0 0 8 179 1 30 17 38 0 43 53 255 255 0 27 0 0 7 76 7 115 2 38 0 58 0 0 1 7 0 118 1 176 1 82 0 8 179 1 35 5 38 0 43 53 255 255 0 23 0 0 6 35 6 33 2 38 0 90 0 0 1 7 0 118 1 27 0 0 0 8 179 1 38 17 38 0 43 53 255 255 0 27 0 0 7 76 7 37 2 38 0 58 0 0 1 7 0 106 1 100 1 82 0 10 180 2 1 47 5 38 0 43 53 53 255 255 0 23 0 0 6 35 5 211 2 38 0 90 0 0 1 7 0 106 0 207 0 0 0 10 180 2 1 50 17 38 0 43 53 53 255 255 0 0 0 0 4 123 7 115 2 38 0 60 0 0 1 7 0 67 255 148 1 82 0 8 179 1 10 5 38 0 43 53 255 255 0 2 254 20 4 6 6 33 2 38 0 92 0 0 1 7 0 67 255 97 0 0 0 8 179 1 23 17 38 0 43 53 0 1 0 82 1 217 3 174 2 113 0 3 0 17 181 0 2 4 5 0 1 0 47 51 17 18 1 57 57 49 48 19 53 33 21 82 3 92 1 217 152 152 0 1 0 82 1 217 7 174 2 113 0 3 0 17 181 0 2 4 5 0 1 0 47 51 17 18 1 57 57 49 48 19 53 33 21 82 7 92 1 217 152 152 255 255 0 82 1 217 7 174 2 113 2 6 2 3 0 0 0 2 255 252 254 49 3 78 255 211 0 3 0 7 0 28 64 11 4 0 9 5 1 1 8 5 6 2 1 0 47 51 47 51 17 1 51 17 51 17 51 50 49 48 1 33 53 33 53 33 53 33 3 78 252 174 3 82 252 174 3 82 254 49 139 140 139 0 0 1 0 25 3 193 1 68 5 182 0 7 0 18 182 1 5 8 9 0 4 3 0 63 205 17 18 1 57 57 49 48 19 39 54 18 55 51 6 7 37 12 22 98 56 123 66 37 3 193 22 90 1 12 121 254 247 0 0 1 0 25 3 193 1 68 5 182 0 7 0 18 182 5 1 8 9 5 7 3 0 63 198 17 18 1 57 57 49 48 1 23 6 2 7 35 18 55 1 53 15 26 98 53 122 70 32 5 182 22 100 254 247 114 1 29 216 0 255 255 0 63 254 248 1 109 0 238 2 6 0 15 0 0 0 1 0 25 3 193 1 70 5 182 0 7 0 18 182 2 6 9 8 3 7 3 0 63 205 17 18 1 57 57 49 48 19 22 23 35 38 2 39 55 223 37 66 123 45 109 24 14 5 182 251 250 94 1 28 101 22 0 0 2 0 25 3 193 2 180 5 182 0 7 0 15 0 26 64 12 4 1 13 9 4 16 17 0 8 3 12 3 0 63 51 205 50 17 18 1 23 57 49 48 1 39 54 19 51 6 2 7 33 39 54 18 55 51 6 7 1 150 15 56 122 123 30 59 13 253 215 12 22 98 56 123 66 37 3 193 22 215 1 8 115 254 223 97 22 90 1 12 121 254 247 0 0 2 0 25 3 193 2 180 5 182 0 7 0 16 0 26 64 12 9 13 1 5 4 17 18 13 5 16 7 3 0 63 51 198 50 17 18 1 23 57 49 48 1 23 6 2 7 35 18 55 33 23 6 2 7 35 54 18 55 1 53 15 26 98 53 122 70 32 2 39 14 24 96 56 125 26 66 13 5 182 22 100 254 247 114 1 29 216 22 91 254 246 122 100 1 52 93 0 255 255 0 25 254 249 2 180 0 238 1 7 2 11 0 0 251 56 0 32 183 1 0 7 64 13 13 72 7 184 255 192 179 12 12 72 7 184 255 192 179 9 9 72 7 0 17 43 43 43 53 53 0 1 0 123 0 0 3 137 6 20 0 11 0 67 64 33 9 2 2 8 3 10 1 1 7 4 0 4 3 5 4 12 13 0 5 5 11 6 6 7 8 0 1 4 4 10 7 3 18 0 63 46 51 51 17 51 63 18 57 47 51 51 17 51 17 18 1 23 57 17 51 51 17 51 17 51 51 17 51 49 48 1 37 19 35 19 5 53 5 3 51 3 37 3 137 254 160 49 196 49 254 180 1 76 49 196 49 1 96 3 231 31 251 250 4 6 31 170 30 1 161 254 95 30 0 1 0 123 0 0 3 154 6 20 0 21 0 117 64 58 12 7 21 16 4 4 15 10 5 20 17 0 3 3 14 11 9 6 19 1 1 6 5 7 4 22 23 1 8 8 2 7 3 6 6 0 9 20 11 11 17 14 19 12 12 18 9 14 13 7 13 7 13 5 15 0 5 18 0 63 63 18 57 57 47 47 18 57 57 50 50 17 51 17 51 51 17 51 17 51 51 17 51 17 51 51 17 51 17 18 1 23 57 17 51 17 51 51 51 51 17 51 51 51 17 51 51 51 17 51 51 17 51 49 48 1 37 21 37 19 35 19 5 53 5 3 19 5 53 5 3 51 3 37 21 37 19 2 57 1 97 254 159 49 198 49 254 166 1 90 43 43 254 166 1 90 49 198 49 1 97 254 159 43 1 231 31 168 29 254 133 1 123 29 168 31 1 43 1 27 31 168 30 1 124 254 132 30 168 31 254 229 0 1 0 164 1 244 2 94 3 227 0 11 0 19 182 6 0 0 12 13 9 3 0 47 205 17 18 1 57 17 51 49 48 19 52 54 51 50 22 21 20 6 35 34 38 164 113 108 105 116 115 106 107 114 2 236 121 126 124 123 119 129 131 0 255 255 0 152 255 227 5 174 0 242 0 38 0 17 0 0 0 39 0 17 2 18 0 0 0 7 0 17 4 37 0 0 0 7 0 100 255 236 9 59 5 203 0 9 0 20 0 24 0 36 0 47 0 59 0 70 0 91 64 48 0 16 5 10 48 66 54 60 25 43 31 37 37 43 60 21 66 10 23 16 8 71 72 28 51 51 40 63 25 3 13 34 57 57 45 68 13 68 13 68 23 24 6 23 24 7 18 7 0 63 51 63 63 18 57 57 47 47 17 51 51 17 51 17 51 63 51 51 17 51 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 17 51 49 48 19 20 22 51 50 17 16 35 34 6 5 20 6 35 34 38 53 16 33 50 22 37 1 35 1 1 20 22 51 50 54 53 52 38 35 34 6 5 20 6 35 34 38 53 16 33 50 22 5 20 22 51 50 54 53 52 38 35 34 6 5 20 6 35 34 38 53 16 33 50 22 236 83 93 180 180 93 83 1 237 161 156 149 163 1 56 152 165 2 105 252 213 148 3 43 2 160 83 93 91 89 89 91 93 83 1 237 162 155 148 163 1 55 150 167 251 56 81 93 91 89 89 91 93 81 1 235 162 155 149 163 1 56 150 167 4 2 170 170 1 84 1 82 168 170 230 231 238 223 1 201 240 219 250 74 5 182 252 2 171 169 167 173 171 165 165 171 230 230 239 221 1 201 236 221 171 169 167 173 171 165 165 171 230 230 238 222 1 201 236 0 255 255 0 133 3 166 1 63 5 182 2 6 0 10 0 0 255 255 0 133 3 166 2 176 5 182 0 6 0 5 0 0 0 1 0 82 0 117 2 31 3 190 0 6 0 26 64 10 4 2 3 6 2 6 8 7 5 1 0 47 47 17 18 1 57 57 17 51 17 51 49 48 19 1 23 1 1 7 1 82 1 86 119 254 223 1 33 119 254 170 2 39 1 151 69 254 162 254 161 71 1 151 0 1 0 80 0 117 2 29 3 190 0 6 0 26 64 10 3 0 4 2 0 2 8 7 5 1 0 47 47 17 18 1 57 57 17 51 17 51 49 48 1 1 39 1 1 55 1 2 29 254 168 117 1 31 254 225 117 1 88 2 12 254 105 71 1 95 1 94 69 254 105 0 255 255 0 152 255 227 3 74 5 182 0 38 0 4 0 0 0 7 0 4 1 193 0 0 0 1 254 121 0 0 2 143 5 182 0 3 0 19 183 0 5 2 4 3 3 2 18 0 63 63 17 1 51 17 51 49 48 1 1 35 1 2 143 252 121 143 3 135 5 182 250 74 5 182 0 1 0 109 3 33 2 195 5 199 0 18 0 38 64 17 0 18 12 8 8 9 18 9 20 19 4 15 31 0 9 10 31 0 63 205 50 63 51 17 18 1 57 57 17 51 17 51 17 51 49 48 1 17 52 38 35 34 6 21 17 35 17 51 23 51 54 51 32 21 17 2 76 78 80 114 91 116 96 14 10 75 145 1 2 3 33 1 164 84 71 105 122 254 164 2 153 88 101 250 254 84 0 1 0 98 0 0 4 35 5 182 0 17 0 75 64 40 14 0 4 4 9 5 11 16 2 5 7 5 18 19 3 7 8 7 78 89 0 8 14 17 76 89 8 14 8 14 5 10 10 13 76 89 10 6 5 24 0 63 63 43 17 18 0 57 57 24 47 47 43 17 0 51 43 17 0 51 17 18 1 23 57 17 51 51 17 51 51 49 48 1 33 21 33 17 35 17 35 53 51 17 33 21 33 17 33 21 33 1 184 1 52 254 204 166 176 176 3 17 253 149 2 68 253 188 1 139 129 254 246 1 10 129 4 43 151 253 233 151 0 1 0 68 0 0 4 72 5 201 0 37 0 112 64 64 13 9 17 17 34 30 26 11 15 21 2 15 26 28 32 23 7 38 39 16 28 29 28 78 89 13 29 12 32 33 32 78 89 9 33 15 33 31 33 63 33 79 33 4 9 3 29 33 29 33 23 0 23 20 76 89 23 24 0 5 75 89 0 7 0 63 43 0 24 63 43 17 18 0 57 57 24 47 47 95 94 93 17 51 43 17 0 51 17 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 51 17 51 51 49 48 1 50 23 7 38 35 34 6 21 21 33 21 33 21 33 21 33 21 20 6 7 33 21 33 53 54 53 53 35 53 51 53 35 53 51 53 52 54 2 176 201 158 60 152 147 122 126 1 164 254 92 1 164 254 92 65 74 3 27 251 252 206 200 200 200 200 224 5 201 80 131 71 135 129 186 129 166 129 33 100 136 44 154 141 48 243 35 129 166 129 207 178 205 0 0 3 0 154 255 236 5 209 5 182 0 22 0 33 0 42 0 96 64 55 34 28 28 29 38 23 16 20 20 13 9 2 18 9 23 11 29 6 43 44 27 34 75 89 16 19 78 89 3 27 11 16 14 14 16 11 27 3 5 29 30 30 42 75 89 30 6 29 24 6 0 77 89 6 25 0 63 43 0 24 63 63 43 17 18 0 23 57 24 47 47 47 47 47 43 43 17 18 1 23 57 17 51 51 17 51 17 51 17 51 17 51 49 48 37 50 54 55 21 6 35 34 38 53 17 35 53 55 55 51 21 51 21 35 17 20 22 1 20 4 33 35 17 35 17 33 32 22 1 51 50 54 53 52 38 35 35 5 78 34 86 11 60 110 109 129 157 157 62 98 221 221 52 254 145 254 235 254 246 64 165 1 6 1 0 254 253 161 52 200 185 172 183 82 117 14 4 125 30 136 138 1 207 80 69 191 211 129 254 71 77 82 3 151 227 234 253 193 5 182 211 253 238 145 162 145 142 0 0 1 0 63 255 236 4 137 5 203 0 38 0 113 64 63 29 23 31 22 22 26 11 2 7 7 26 36 17 4 10 26 23 6 39 40 11 23 24 23 78 89 8 24 5 29 30 29 78 89 2 30 15 30 31 30 47 30 3 9 3 24 30 24 30 19 34 34 0 76 89 34 7 19 14 76 89 19 25 0 63 43 0 24 63 43 17 18 0 57 57 24 47 47 95 94 93 17 51 43 17 0 51 17 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 17 51 17 51 49 48 1 32 3 33 21 33 7 21 23 33 21 33 22 22 51 50 55 21 6 35 34 0 3 35 53 51 39 53 55 35 53 51 18 0 51 50 23 7 38 3 27 254 193 79 1 254 253 244 2 2 1 207 254 65 37 203 170 156 153 146 171 237 254 223 46 166 152 2 2 152 164 39 1 36 237 201 165 71 166 5 53 254 109 129 57 64 45 129 180 197 66 150 65 1 13 1 1 129 42 44 80 129 1 5 1 36 97 139 86 0 4 0 141 255 248 6 10 5 193 0 3 0 15 0 23 0 43 0 69 64 36 37 27 32 42 16 10 20 4 4 0 10 42 2 27 6 44 45 35 30 6 18 7 24 22 13 39 24 13 24 13 24 2 3 6 2 24 0 63 63 18 57 57 47 47 17 51 17 51 63 51 63 51 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 1 35 1 1 20 6 35 34 38 53 52 54 51 50 22 5 20 51 50 53 52 35 34 37 34 38 53 52 54 51 50 23 7 38 35 34 21 20 51 50 55 21 6 5 31 252 213 148 3 43 1 127 169 148 139 170 167 148 141 170 254 21 178 176 176 178 253 202 166 182 188 171 104 88 33 81 80 224 220 98 90 78 5 182 250 74 5 182 251 152 159 183 185 157 158 184 186 156 238 238 235 219 177 161 168 179 35 103 31 238 235 33 101 37 0 2 0 119 255 236 3 156 5 203 0 28 0 36 0 61 64 31 35 26 26 15 9 29 22 3 22 9 12 4 37 38 35 15 13 25 10 5 12 19 2 12 2 12 6 31 19 0 6 0 47 51 47 51 18 57 57 47 47 17 18 23 57 17 18 1 23 57 17 51 17 51 51 17 51 49 48 37 50 55 51 6 6 35 34 38 53 53 6 7 53 54 55 17 52 54 51 50 22 21 20 2 7 17 20 22 19 52 35 34 6 21 17 36 2 125 174 18 95 8 153 142 150 160 96 96 78 114 150 135 117 135 206 175 82 174 127 67 62 1 0 111 213 166 178 181 169 243 35 22 113 21 38 1 242 138 159 161 138 185 254 208 74 254 229 104 123 4 43 194 86 108 254 75 137 0 0 4 0 201 0 0 7 195 5 182 0 15 0 27 0 39 0 43 0 95 64 49 9 6 6 7 1 13 13 0 28 22 34 16 16 43 40 22 0 7 6 44 45 31 19 37 25 11 40 19 3 25 8 19 25 19 25 40 8 40 41 74 89 40 18 14 8 3 1 7 18 0 63 51 63 51 63 43 17 18 0 57 57 24 47 47 17 18 57 17 18 57 17 51 17 51 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 17 51 49 48 33 35 1 35 18 21 17 35 17 51 1 51 38 53 17 51 1 20 6 35 34 38 53 52 54 51 50 22 5 20 22 51 50 54 53 52 38 35 34 6 3 53 33 21 4 199 187 253 76 8 16 151 194 2 170 8 14 152 2 252 161 147 139 162 161 147 139 162 254 34 81 93 91 79 79 91 92 82 86 2 0 4 203 254 224 108 252 193 5 182 251 58 245 138 3 71 252 183 163 184 187 160 163 181 187 157 114 118 117 115 115 112 112 253 32 135 135 0 2 0 37 2 229 5 133 5 182 0 7 0 24 0 79 64 39 0 1 15 12 12 13 17 20 20 19 19 13 6 1 3 5 25 26 23 22 9 10 10 17 14 14 4 7 3 3 4 16 8 8 20 13 1 4 3 0 63 196 50 50 57 47 51 17 51 17 51 17 51 17 51 51 17 51 51 51 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 49 48 1 35 17 35 53 33 21 35 1 3 35 23 17 35 17 51 19 19 51 17 35 17 55 35 3 1 113 123 209 2 31 211 2 88 201 8 6 119 187 196 203 180 127 6 8 211 2 229 2 103 106 106 253 153 2 47 129 254 82 2 209 253 209 2 47 253 47 1 164 137 253 211 0 255 255 0 80 0 0 5 244 5 205 2 6 1 118 0 0 0 2 0 102 255 221 4 139 4 72 0 23 0 31 0 52 64 26 31 14 14 4 24 12 12 21 4 3 32 33 13 20 47 31 63 31 2 31 31 17 28 8 17 0 0 47 50 47 51 18 57 47 93 57 51 17 18 1 23 57 17 51 17 51 17 51 49 48 5 34 38 2 53 52 54 54 51 50 22 18 21 33 17 22 22 51 50 54 55 23 6 6 19 17 38 38 35 34 7 17 2 121 157 241 133 138 244 149 152 243 135 252 197 49 166 82 131 183 81 72 98 217 147 50 163 88 173 122 35 147 1 5 157 171 255 140 142 254 253 165 254 156 53 70 105 129 41 155 124 2 139 1 21 53 66 117 254 233 255 255 0 71 255 236 5 243 5 182 0 39 2 23 2 92 0 0 0 38 0 123 251 0 1 7 2 64 3 96 253 179 0 11 180 4 3 2 25 25 0 63 53 53 53 0 255 255 0 32 255 236 6 8 5 201 0 39 2 23 2 162 0 0 0 39 2 64 3 117 253 179 1 6 0 117 255 0 0 11 180 1 3 2 14 25 0 63 53 53 53 0 255 255 0 71 255 236 6 4 5 182 0 39 2 23 2 156 0 0 0 38 2 61 12 0 1 7 2 64 3 113 253 179 0 11 180 4 3 2 44 25 0 63 53 53 53 0 255 255 0 106 255 236 6 0 5 182 0 39 2 23 2 70 0 0 0 39 2 64 3 109 253 179 1 6 2 63 49 0 0 11 180 1 3 2 14 25 0 63 53 53 53 0 0 2 0 102 255 236 4 53 5 199 0 26 0 40 0 65 64 34 38 7 31 15 15 0 0 20 7 3 41 42 11 34 71 89 14 4 11 11 24 4 24 17 70 89 24 3 4 27 70 89 4 22 0 63 43 0 24 63 43 17 18 0 57 24 47 18 57 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 16 2 4 35 34 38 53 52 18 54 51 50 22 23 55 16 33 34 6 7 53 54 54 51 50 18 1 50 54 18 55 38 38 35 34 6 6 21 20 22 4 53 167 254 236 173 172 187 136 232 151 97 146 43 4 254 230 62 144 48 47 155 74 210 216 253 162 95 166 120 22 25 128 80 101 165 101 101 3 166 254 250 254 53 233 201 192 169 1 51 161 93 75 90 1 149 44 33 159 23 37 254 236 251 198 144 1 3 150 97 108 132 250 128 118 130 0 2 0 39 0 0 4 109 5 182 0 5 0 12 0 40 64 19 9 5 10 4 5 4 14 13 6 5 1 5 9 73 89 5 18 1 3 0 63 63 43 17 18 0 57 17 18 1 57 57 17 51 17 51 49 48 55 1 51 1 21 33 1 6 7 1 33 1 38 39 1 207 166 1 209 251 186 2 33 61 40 254 252 2 209 254 254 68 104 5 78 250 176 102 4 244 225 121 252 254 2 249 202 0 0 1 0 201 254 16 5 33 5 182 0 7 0 35 64 17 0 7 3 4 7 4 9 8 5 2 73 89 5 3 0 4 27 0 63 51 63 43 17 18 1 57 57 17 51 17 51 49 48 1 17 33 17 35 17 33 17 4 119 252 252 170 4 88 254 16 7 13 248 243 7 166 248 90 0 1 0 76 254 16 4 221 5 182 0 11 0 49 64 26 7 9 9 3 0 8 2 10 6 2 0 4 12 13 4 7 73 89 4 3 0 9 73 89 0 27 0 63 43 0 24 63 43 17 18 1 23 57 17 51 17 51 51 17 51 49 48 19 53 1 1 53 33 21 33 1 1 33 21 76 2 119 253 153 4 64 252 176 2 67 253 164 3 170 254 16 107 3 156 3 51 108 151 252 252 252 141 152 0 1 0 104 2 141 4 41 3 23 0 3 0 21 64 9 2 0 5 4 1 0 80 89 1 0 47 43 17 18 1 57 57 49 48 19 53 33 21 104 3 193 2 141 138 138 0 1 0 37 255 242 4 188 6 152 0 8 0 28 64 11 8 10 3 9 3 6 4 4 1 8 1 0 47 47 18 57 47 57 51 17 1 51 17 51 49 48 5 35 1 35 53 33 19 1 51 2 111 127 254 233 180 1 33 235 2 2 137 14 3 14 135 253 84 5 189 0 0 3 0 119 1 147 5 45 4 12 0 21 0 33 0 45 0 51 64 24 31 12 43 0 0 37 25 12 4 46 47 34 28 28 17 6 9 19 15 40 22 22 3 9 0 47 51 51 17 51 47 51 18 57 57 51 17 51 17 18 1 23 57 17 51 17 51 49 48 1 20 6 35 34 38 39 6 6 35 34 38 53 52 54 51 50 23 54 51 50 22 1 50 54 55 38 38 35 34 6 21 20 22 1 34 6 7 22 22 51 50 54 53 52 38 5 45 167 128 93 153 65 60 153 88 131 168 168 131 181 122 124 185 133 162 252 125 66 109 54 50 109 72 76 100 97 2 161 66 109 55 51 110 71 76 100 101 2 207 131 185 106 116 104 113 173 142 134 179 219 215 175 254 187 91 100 97 93 105 87 83 106 1 121 92 98 97 94 107 84 85 105 0 1 0 12 254 20 2 248 6 20 0 20 0 28 64 12 8 18 2 18 13 3 21 22 16 11 5 0 0 47 50 47 51 17 18 1 23 57 17 51 49 48 1 50 23 21 38 35 34 21 17 20 6 35 34 39 53 22 51 50 53 17 16 2 125 79 44 49 62 176 165 163 74 59 61 58 182 6 20 16 137 22 243 250 225 176 187 19 135 22 243 5 31 1 106 0 0 2 0 98 1 135 4 45 4 31 0 23 0 47 0 112 64 64 40 15 27 3 15 3 49 48 39 30 30 24 80 89 15 30 31 30 47 30 3 9 3 30 42 64 42 36 80 89 27 42 64 15 6 6 0 80 89 15 6 31 6 47 6 3 9 3 6 18 64 18 12 80 89 3 0 18 16 18 32 18 3 18 0 47 93 196 43 0 26 24 16 205 95 94 93 43 0 16 24 196 26 222 196 43 0 26 24 16 205 95 94 93 43 0 16 24 196 17 18 1 57 57 17 51 17 51 49 48 1 34 6 7 53 54 51 50 22 23 22 22 51 50 54 55 21 6 35 34 38 39 38 38 3 34 6 7 53 54 51 50 22 23 22 22 51 50 54 55 21 6 35 34 38 39 38 38 1 80 54 127 57 108 148 67 112 88 77 91 45 53 128 54 101 153 67 111 88 73 91 49 57 128 53 106 150 69 116 82 69 95 49 55 129 51 100 154 69 118 79 84 85 2 0 64 57 150 110 28 37 33 25 66 57 151 109 29 37 30 25 1 150 68 53 149 109 32 34 29 26 66 55 150 110 32 33 34 24 0 0 1 0 104 0 166 4 41 5 2 0 19 0 70 64 38 5 1 16 11 11 9 10 14 4 0 19 1 8 20 21 13 5 6 5 80 89 10 8 15 6 1 9 3 6 14 2 1 2 80 89 18 17 1 0 47 51 196 43 17 0 51 24 47 95 94 93 198 51 43 17 0 51 17 18 1 23 57 17 51 17 51 49 48 1 33 53 33 19 33 53 33 19 23 7 33 21 33 3 33 21 33 3 39 1 125 254 235 1 84 127 254 45 2 19 135 125 109 1 23 254 170 129 1 215 253 233 131 125 1 193 137 1 16 137 1 31 57 230 137 254 240 137 254 229 55 255 255 0 104 0 1 4 41 4 217 2 38 0 31 0 0 1 7 2 43 0 0 253 116 0 9 179 1 0 7 18 0 63 53 53 0 255 255 0 104 0 1 4 41 4 217 2 38 0 33 0 0 1 7 2 43 0 0 253 116 0 9 179 1 0 7 18 0 63 53 53 0 0 2 0 111 0 0 4 61 5 195 0 5 0 9 0 32 64 13 8 0 6 3 0 3 10 11 9 7 2 5 2 0 47 47 18 57 57 17 18 1 57 57 17 51 17 51 49 48 19 1 51 1 1 35 9 3 111 1 194 72 1 196 254 60 72 1 98 254 195 254 195 1 61 2 223 2 228 253 28 253 33 2 225 2 19 253 237 253 236 0 255 255 0 29 0 0 4 28 6 31 0 38 0 73 0 0 0 7 0 76 2 182 0 0 255 255 0 29 0 0 4 12 6 31 0 38 0 73 0 0 0 7 0 79 2 182 0 0 0 1 0 219 4 217 3 190 6 12 0 13 0 24 64 9 11 3 15 14 10 4 128 7 0 0 47 50 26 204 50 17 18 1 57 57 49 48 1 34 38 39 51 22 22 51 50 54 55 51 6 6 2 72 185 170 10 156 9 91 113 103 99 11 157 12 178 4 217 143 164 104 82 88 98 158 149 0 0 1 255 145 254 20 1 86 4 72 0 12 0 29 64 13 11 8 8 14 13 9 15 0 5 70 89 0 27 0 63 43 0 24 63 17 18 1 57 17 51 49 48 19 34 39 53 22 51 50 54 53 17 51 17 16 43 95 59 69 67 78 73 166 254 20 25 135 20 85 87 4 252 251 16 254 188 0 0 1 1 137 4 205 2 117 6 20 0 9 0 19 182 9 4 10 11 4 128 9 0 47 26 205 17 18 1 57 57 49 48 1 54 54 55 51 21 6 6 7 35 1 137 19 39 10 168 11 88 47 90 4 229 55 167 81 18 51 188 70 0 1 1 113 254 59 2 111 255 131 0 9 0 19 182 9 4 10 11 9 128 4 0 47 26 205 17 18 1 57 57 49 48 1 54 54 55 51 21 6 6 7 35 1 113 28 51 7 168 11 98 55 90 254 84 64 186 53 18 51 193 66 0 1 1 129 4 217 2 127 6 33 0 9 0 19 182 9 4 10 11 9 128 4 0 47 26 205 17 18 1 57 57 49 48 1 6 6 7 35 53 54 54 55 51 2 127 29 53 6 166 14 99 49 92 6 8 61 193 49 19 61 191 57 0 2 0 39 2 57 2 158 5 199 0 11 0 21 0 32 64 14 6 12 0 17 12 17 23 22 9 19 31 3 14 33 0 63 51 63 51 17 18 1 57 57 17 51 17 51 49 48 19 20 22 51 50 54 53 52 38 35 34 6 5 16 33 34 38 53 16 33 50 22 176 82 94 94 86 86 94 94 82 1 238 254 196 158 157 1 59 158 158 4 0 168 166 165 171 170 164 165 169 254 55 236 221 1 197 232 0 2 0 20 2 74 2 180 5 188 0 10 0 20 0 60 64 31 20 5 11 7 3 3 9 2 0 2 5 3 21 22 1 5 5 9 15 20 31 20 2 20 20 3 14 7 31 3 32 0 63 63 51 18 57 47 93 51 51 17 51 17 18 1 23 57 17 51 51 17 51 51 17 51 49 48 1 35 21 35 53 33 53 1 51 17 51 33 53 52 55 14 3 7 7 2 180 125 145 254 110 1 152 139 125 254 242 6 5 24 30 30 11 168 3 20 202 202 101 2 67 253 205 195 134 75 12 39 45 45 17 246 0 1 0 59 2 55 2 137 5 170 0 29 0 43 64 21 16 3 28 23 9 23 26 3 4 31 30 19 0 0 6 27 24 30 13 6 33 0 63 51 63 51 18 57 47 51 17 18 1 23 57 17 51 17 51 49 48 1 50 22 21 20 6 35 34 38 39 53 22 22 51 50 54 53 52 38 35 34 6 7 39 19 33 21 33 7 54 1 72 145 176 170 166 74 139 41 56 140 54 95 110 109 102 57 76 31 59 33 1 239 254 131 20 62 4 104 143 123 140 155 31 23 131 34 38 83 89 78 88 17 8 41 1 160 104 230 12 0 0 2 0 41 2 57 2 162 5 199 0 23 0 35 0 54 64 28 27 18 33 11 0 0 6 18 3 37 36 30 11 21 0 15 16 15 2 15 15 3 24 21 33 8 3 31 0 63 51 63 51 18 57 47 93 18 57 51 17 18 1 23 57 17 51 51 17 51 49 48 19 16 54 51 50 23 21 38 35 34 6 7 51 54 54 51 50 22 21 20 6 35 34 38 5 50 54 53 52 38 35 34 6 21 20 22 41 219 219 74 49 52 83 141 150 10 8 29 113 85 125 148 166 141 153 173 1 68 81 99 88 86 85 112 106 3 195 1 5 255 15 114 18 153 166 43 59 148 126 144 164 210 99 93 99 79 91 90 59 89 124 0 0 1 0 57 2 74 2 143 5 182 0 6 0 28 64 13 1 5 5 0 2 3 7 8 2 3 30 0 32 0 63 63 51 17 18 1 23 57 17 51 49 48 19 1 33 53 33 21 1 162 1 94 254 57 2 86 254 160 2 74 2 248 116 94 252 242 0 3 0 51 2 57 2 147 5 199 0 21 0 34 0 45 0 63 64 34 22 13 38 19 43 3 28 7 7 3 5 16 19 13 6 46 47 5 16 32 32 11 41 27 41 2 41 41 25 10 33 35 0 31 0 63 50 63 51 57 47 93 51 18 57 57 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 50 22 21 20 7 22 21 20 6 35 34 38 53 52 54 55 38 38 53 52 54 3 20 22 51 50 54 53 52 38 39 39 6 6 19 34 6 21 20 22 23 54 53 52 38 1 100 124 151 148 176 165 138 146 159 73 85 74 57 157 53 84 86 90 84 93 81 28 72 70 172 68 75 68 81 140 78 5 199 118 104 130 76 74 158 113 137 128 116 69 116 46 46 93 68 102 126 253 102 60 73 73 60 63 79 28 10 34 84 1 239 60 57 47 71 33 54 97 57 60 0 2 0 35 2 57 2 156 5 201 0 22 0 34 0 60 64 31 26 17 32 10 0 0 5 17 3 35 36 29 14 10 11 11 20 15 14 31 14 2 14 14 3 23 20 31 8 3 33 0 63 51 63 51 18 57 47 93 18 57 17 51 17 51 17 18 1 23 57 17 51 51 17 51 49 48 1 16 6 35 34 39 53 22 51 32 19 35 6 6 35 34 38 53 52 54 51 50 22 37 34 6 21 20 22 51 50 54 53 52 38 2 156 218 212 83 49 49 93 1 20 21 10 35 116 65 131 153 169 136 152 176 254 184 81 95 85 87 84 115 103 4 70 254 242 255 15 116 20 1 70 51 52 146 131 136 165 202 91 95 87 81 95 85 62 97 114 0 0 22 0 84 254 129 7 193 5 238 0 5 0 11 0 17 0 23 0 27 0 31 0 35 0 39 0 43 0 47 0 51 0 55 0 59 0 63 0 67 0 71 0 83 0 91 0 107 0 116 0 124 0 137 0 248 64 135 65 64 61 60 49 48 15 5 0 12 84 78 88 72 118 107 112 96 122 103 133 134 69 68 41 40 37 36 20 10 9 23 23 134 6 18 59 27 127 103 96 56 24 55 47 107 52 44 72 35 31 32 28 3 17 78 12 25 138 139 10 0 42 66 90 81 134 92 116 92 41 65 70 62 100 117 117 108 69 61 130 125 86 75 107 118 107 38 50 37 49 21 13 0 66 1 65 62 92 61 108 13 49 50 3 107 12 92 108 107 107 108 92 3 1 45 44 29 28 25 24 19 18 15 12 57 56 53 52 33 32 7 6 4 1 0 47 51 51 51 51 51 51 51 51 51 47 51 51 51 51 51 51 51 51 51 18 23 57 47 47 47 17 18 23 57 17 57 18 57 57 17 57 57 17 51 17 51 17 51 17 51 16 196 50 196 50 17 51 17 51 18 57 17 51 17 51 17 51 16 196 196 50 17 51 17 51 17 18 1 23 57 17 51 51 51 51 51 51 51 51 51 17 51 17 51 17 51 17 51 17 51 17 51 17 51 51 51 51 51 51 51 51 51 49 48 19 17 33 21 35 21 37 53 33 17 35 53 1 17 51 21 51 21 33 53 51 53 51 17 33 53 33 21 33 53 33 21 1 53 33 21 1 35 17 51 17 35 17 51 1 53 33 21 1 35 17 51 1 53 33 21 51 53 33 21 1 35 17 51 53 35 17 51 1 35 17 51 5 20 6 35 34 38 53 52 54 51 50 22 5 20 51 50 53 52 35 34 37 51 50 22 21 20 6 7 21 22 22 21 20 6 35 35 19 51 50 54 53 52 38 35 35 21 21 51 50 54 53 52 35 1 34 39 53 22 51 50 53 17 51 17 20 6 84 1 47 192 5 206 1 48 109 249 0 111 192 5 14 195 109 253 73 1 17 251 225 1 14 254 242 1 14 4 183 109 109 109 109 251 194 1 16 252 48 111 111 2 192 1 16 119 1 17 250 168 111 111 111 111 6 254 109 109 251 159 135 127 127 135 135 127 126 136 254 115 135 135 135 135 1 225 172 109 112 46 44 61 46 109 94 207 123 66 46 36 42 47 59 74 49 37 90 1 94 52 28 43 25 86 125 105 4 190 1 48 111 193 193 111 254 208 193 249 2 1 47 194 109 109 194 254 209 109 109 109 109 6 254 111 111 250 168 1 14 2 2 1 15 250 59 109 109 1 166 1 14 4 74 111 111 111 111 252 47 1 16 121 1 15 253 104 1 16 73 145 156 156 145 146 155 154 147 197 197 196 97 67 83 49 66 8 8 14 68 53 81 89 1 98 34 32 34 29 227 154 43 37 74 254 250 10 102 8 86 1 146 254 114 95 99 0 0 3 0 84 254 193 7 170 6 20 0 3 0 30 0 42 0 46 64 25 1 11 23 37 4 30 31 17 3 9 43 44 40 30 20 14 34 30 14 14 30 34 3 2 0 0 47 47 23 57 47 47 47 17 51 17 51 17 18 1 23 57 49 48 9 3 5 53 52 54 55 54 54 53 52 38 35 34 6 7 23 54 51 50 22 21 20 6 7 6 6 21 21 3 20 22 51 50 54 53 52 38 35 34 6 3 254 3 172 252 84 252 86 3 235 44 65 103 73 187 165 79 186 71 82 160 90 63 62 49 72 84 59 27 71 70 66 73 72 67 72 69 6 20 252 86 252 87 3 169 251 47 50 65 49 82 126 88 135 154 56 42 178 80 58 47 53 75 54 68 112 74 59 254 237 63 72 73 62 64 73 72 255 255 255 145 254 20 2 87 6 33 2 38 2 55 0 0 1 7 1 76 254 169 0 0 0 8 179 1 24 17 38 0 43 53 255 255 0 25 3 193 1 68 5 182 2 6 2 7 0 0 0 2 0 10 255 236 4 223 6 43 0 45 0 54 0 102 64 57 27 7 23 11 52 37 46 31 31 43 2 45 2 37 11 7 18 6 55 56 20 14 71 89 0 33 46 33 71 89 43 46 15 46 31 46 2 9 3 20 46 20 46 5 40 40 49 70 89 40 1 5 29 70 89 5 22 0 63 43 0 24 63 43 17 18 0 57 57 24 47 47 95 94 93 17 51 43 17 0 51 43 17 18 1 23 57 17 51 51 17 51 17 51 17 51 17 51 49 48 1 22 21 16 0 33 32 17 52 55 54 53 52 38 35 34 6 7 39 54 51 50 22 21 20 7 6 21 20 51 32 17 52 39 38 36 38 53 52 54 51 50 0 19 51 21 37 38 2 35 34 6 21 20 4 4 86 4 254 224 254 253 254 119 16 15 36 32 25 54 15 33 83 95 88 93 15 16 233 1 119 4 223 254 201 160 182 168 208 1 0 42 143 254 199 28 183 123 93 97 1 19 3 78 46 65 254 159 254 110 1 88 57 123 122 23 47 35 15 9 118 39 93 93 35 131 132 58 207 2 112 63 44 2 105 188 131 144 163 254 205 254 215 129 129 211 1 0 95 75 141 154 0 1 0 0 0 0 4 123 5 195 0 21 0 40 64 20 17 18 7 18 20 3 22 23 0 18 20 3 18 18 5 10 74 89 5 4 0 63 43 0 24 63 63 18 57 17 18 1 23 57 17 51 49 48 1 18 18 54 54 51 50 23 21 38 35 34 14 3 7 17 35 17 1 51 2 57 122 141 77 92 58 48 40 26 31 40 59 86 124 101 31 172 254 35 186 2 205 1 35 1 55 108 48 15 135 6 56 161 252 236 85 253 227 2 47 3 135 0 0 2 0 18 255 236 6 119 4 72 0 20 0 41 0 76 64 39 24 3 18 33 33 30 39 13 10 13 30 3 6 5 42 43 19 31 31 0 8 21 11 6 8 6 70 89 8 15 36 27 0 27 70 89 16 0 22 0 63 50 43 17 0 51 24 63 43 17 0 51 51 17 18 57 24 47 57 17 18 1 23 57 17 51 17 51 18 57 17 51 49 48 5 34 38 53 52 19 33 53 55 33 21 35 22 21 20 6 35 34 39 35 6 1 6 2 21 20 22 51 50 54 53 53 51 21 20 22 51 50 54 53 52 39 2 41 186 199 135 254 227 142 5 215 250 117 200 185 221 68 8 68 254 207 63 66 108 117 93 108 162 107 93 117 109 111 20 231 240 240 1 7 74 68 142 252 251 240 231 182 182 3 206 132 254 254 103 174 168 143 125 188 188 122 146 169 173 254 239 0 255 255 0 201 0 0 6 113 7 117 2 38 0 48 0 0 1 7 0 118 1 156 1 84 0 8 179 1 29 5 38 0 43 53 255 255 0 176 0 0 6 203 6 33 2 38 0 80 0 0 1 7 0 118 1 205 0 0 0 8 179 1 45 17 38 0 43 53 255 255 0 0 253 213 5 16 5 188 2 38 0 36 0 0 0 7 2 91 1 53 0 0 255 255 0 94 253 213 3 205 4 90 2 38 0 68 0 0 0 7 2 91 0 199 0 0 255 255 254 223 255 236 5 210 5 205 0 38 0 50 20 0 1 7 2 92 254 71 0 0 0 9 179 3 2 26 3 0 63 53 53 0 0 2 0 117 253 213 2 53 255 131 0 11 0 23 0 30 64 12 18 6 12 0 6 0 24 25 21 3 15 9 0 47 51 204 50 17 18 1 57 57 17 51 17 51 49 48 1 20 6 35 34 38 53 52 54 51 50 22 7 52 38 35 34 6 21 20 22 51 50 54 2 53 125 102 101 120 120 101 101 126 110 66 51 51 66 60 57 53 64 254 174 97 120 117 98 98 117 118 97 57 60 60 57 56 61 61 0 2 0 152 4 104 2 207 5 197 0 8 0 23 0 30 64 14 14 9 3 8 12 19 9 5 24 25 2 11 8 21 0 47 196 220 198 17 18 1 23 57 17 51 49 48 1 54 55 51 21 6 6 7 35 37 52 55 21 6 21 20 30 2 21 20 35 34 38 1 176 70 28 189 41 119 49 78 254 232 237 121 31 37 31 93 55 67 4 135 181 122 20 78 172 57 118 163 61 72 41 53 20 19 16 26 28 74 68 0 255 255 0 29 0 0 6 211 6 31 0 39 0 73 2 176 0 0 0 38 0 73 0 0 0 7 0 76 5 109 0 0 255 255 0 29 0 0 6 195 6 31 0 39 0 73 2 176 0 0 0 38 0 73 0 0 0 7 0 79 5 109 0 0 0 2 0 125 255 236 6 100 6 20 0 21 0 33 0 60 64 31 22 6 15 17 17 28 0 0 20 11 6 4 34 35 20 11 3 9 9 31 73 89 15 9 4 3 25 73 89 3 19 0 63 43 0 24 63 198 43 17 18 0 57 57 17 18 1 23 57 17 51 51 17 51 17 51 49 48 1 16 0 33 32 0 17 16 0 33 32 23 62 2 53 51 23 6 6 7 22 1 16 18 51 50 18 17 16 2 35 34 2 5 188 254 157 254 198 254 189 254 161 1 97 1 67 1 69 179 50 58 27 182 14 29 131 104 96 251 117 250 244 243 246 245 242 243 253 2 221 254 158 254 113 1 137 1 106 1 104 1 134 215 12 67 102 105 22 155 173 39 176 254 254 254 214 254 206 1 49 1 43 1 39 1 49 254 209 0 0 2 0 115 255 236 5 25 4 240 0 22 0 34 0 60 64 31 23 7 16 18 18 29 0 0 21 12 7 4 35 36 21 12 3 10 10 32 70 89 16 10 16 3 26 70 89 3 22 0 63 43 0 24 63 198 43 17 18 0 57 57 17 18 1 23 57 17 51 51 17 51 17 51 49 48 1 16 0 35 34 38 2 53 16 0 51 50 23 62 2 53 51 23 6 6 7 22 5 20 22 51 50 54 53 52 38 35 34 6 4 98 254 242 238 147 228 124 1 12 238 217 137 51 58 26 180 15 31 121 102 71 252 189 158 173 175 157 159 175 173 156 2 37 254 244 254 211 138 1 2 173 1 12 1 43 141 15 65 99 110 23 156 175 38 138 185 211 219 219 211 210 216 216 0 1 0 186 255 236 6 123 6 20 0 27 0 51 64 24 5 7 7 1 11 20 17 11 17 29 28 10 1 14 27 5 18 3 14 23 73 89 14 19 0 63 43 0 24 63 198 51 18 57 57 17 18 1 57 57 17 51 17 51 51 17 51 49 48 1 21 62 2 53 51 23 6 6 7 17 16 0 33 32 0 53 17 51 17 20 22 51 50 54 53 17 5 25 58 70 31 181 14 33 172 149 254 225 254 248 254 244 254 212 170 204 198 184 193 5 182 198 8 62 112 110 22 182 184 25 253 141 254 254 254 234 1 31 253 3 174 252 70 183 196 193 188 3 184 0 0 1 0 164 255 236 5 150 4 242 0 29 0 68 64 34 1 28 13 15 15 19 20 7 7 10 19 28 19 30 31 21 22 10 18 22 3 20 13 8 29 15 25 4 70 89 25 22 20 21 0 63 63 43 0 24 63 51 198 18 23 57 17 51 17 18 1 57 57 17 51 51 17 51 17 51 17 51 17 51 49 48 1 17 20 22 51 50 54 53 17 51 21 54 54 53 51 23 6 6 7 17 35 39 35 6 6 35 34 38 53 17 1 76 122 130 172 159 166 82 74 178 15 32 176 141 137 24 9 52 181 111 203 200 4 70 253 59 134 132 188 213 2 62 121 11 128 154 23 186 191 14 252 172 147 82 85 190 209 2 203 0 255 255 252 83 4 217 253 220 6 33 0 7 0 67 250 202 0 0 255 255 253 13 4 217 254 150 6 33 0 7 0 118 251 132 0 0 255 255 252 25 4 217 255 1 5 221 0 7 1 82 251 17 0 0 0 1 253 8 4 184 254 115 6 143 0 17 0 30 64 12 2 5 5 13 13 8 0 0 19 11 16 4 0 47 204 50 17 1 51 17 51 51 18 57 17 51 49 48 1 20 7 7 35 39 54 54 53 52 38 35 34 7 53 54 51 32 254 115 166 10 105 12 86 78 67 73 62 32 38 69 1 0 5 215 140 34 113 176 14 50 43 43 41 6 100 10 0 1 253 59 254 160 254 2 255 125 0 11 0 17 181 6 0 0 13 9 3 0 47 205 17 1 51 17 51 49 48 5 52 54 51 50 22 21 20 6 35 34 38 253 59 59 42 40 58 58 40 42 59 242 57 54 54 57 55 55 55 0 255 255 0 201 0 0 3 248 7 115 2 38 0 40 0 0 1 7 0 67 255 216 1 82 0 8 179 1 13 5 38 0 43 53 255 255 0 203 0 0 5 82 7 115 2 38 1 178 0 0 1 7 0 67 0 104 1 82 0 8 179 1 17 5 38 0 43 53 255 255 0 115 255 236 4 18 6 33 2 38 0 72 0 0 1 6 0 67 183 0 0 8 179 2 28 17 38 0 43 53 255 255 0 176 0 0 4 98 6 33 2 38 1 210 0 0 1 6 0 67 220 0 0 8 179 1 15 17 38 0 43 53 0 1 0 133 255 236 7 145 5 201 0 49 0 69 64 36 34 22 42 39 47 9 9 4 39 27 22 5 50 51 0 31 25 31 73 89 16 40 40 19 6 25 4 44 37 19 37 73 89 12 19 19 0 63 51 43 17 0 51 24 63 51 18 57 47 57 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 49 48 1 34 6 7 39 54 51 50 0 17 16 0 35 34 38 39 35 6 6 35 32 0 17 16 18 51 50 23 7 38 38 35 34 2 17 16 18 51 50 55 17 51 17 22 51 50 18 17 16 2 5 164 60 94 45 69 126 150 228 1 1 254 229 255 108 172 83 8 80 169 107 255 0 254 229 255 228 153 124 70 45 93 60 147 165 207 187 139 102 170 102 142 187 206 165 5 47 41 31 146 80 254 136 254 173 254 141 254 97 45 51 50 46 1 155 1 119 1 83 1 120 80 146 31 41 254 215 254 246 254 211 254 178 76 1 201 254 55 76 1 75 1 48 1 11 1 40 0 1 0 0 0 0 6 29 4 72 0 29 0 40 64 22 23 0 13 14 5 5 30 31 27 21 13 0 18 10 4 4 22 14 5 15 4 21 0 63 63 51 51 18 23 57 63 17 18 1 23 57 49 48 1 6 6 3 35 1 51 19 22 23 51 54 54 19 3 51 0 22 23 51 54 18 17 51 16 2 7 35 3 38 3 39 10 20 179 213 254 127 172 246 32 46 8 19 74 142 172 178 1 9 45 10 8 173 153 166 195 219 182 125 33 1 201 26 51 254 132 4 72 253 73 93 189 53 163 1 36 1 213 252 255 144 44 184 1 179 1 82 254 150 254 7 229 1 90 92 0 2 0 23 0 0 4 252 6 20 0 17 0 26 0 76 64 40 8 4 18 18 1 15 22 11 11 6 15 0 4 27 28 7 17 0 17 73 89 4 0 8 26 73 89 0 8 0 8 15 2 0 15 18 74 89 15 18 0 63 43 0 24 63 18 57 57 47 47 43 17 0 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 51 49 48 19 33 17 51 17 33 21 33 17 51 32 17 20 4 33 33 17 33 1 51 50 54 53 52 38 35 35 23 1 63 172 1 162 254 94 201 2 49 254 247 254 251 254 104 254 193 1 235 213 192 181 186 218 182 4 250 1 26 254 230 148 254 224 254 100 208 218 4 102 252 43 137 144 138 122 0 0 2 0 23 0 0 4 156 5 39 0 17 0 25 0 71 64 38 4 0 19 19 15 11 22 7 7 2 11 13 4 26 27 3 13 14 13 70 89 4 18 70 89 4 4 11 16 0 14 15 11 19 70 89 11 21 0 63 43 0 24 63 51 198 18 57 47 43 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 51 49 48 1 33 21 33 17 33 32 17 20 6 35 33 17 35 53 51 53 51 17 17 33 32 53 52 38 35 1 168 1 88 254 168 1 63 1 181 223 220 254 33 235 235 166 1 49 1 31 135 156 4 72 140 254 197 254 205 166 168 3 188 140 223 252 205 254 151 185 92 84 0 1 0 201 255 236 7 33 5 203 0 32 0 74 64 41 23 19 19 20 6 24 29 12 5 24 17 20 6 33 34 27 0 73 89 27 4 6 18 23 18 73 89 3 23 23 20 21 3 20 18 14 9 73 89 14 19 0 63 43 0 24 63 63 18 57 47 51 43 17 0 51 24 63 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 34 4 7 33 21 33 18 0 51 50 55 21 6 35 32 0 3 33 17 35 17 51 17 33 18 0 37 50 23 7 38 38 5 143 227 254 252 31 2 191 253 61 8 1 9 247 154 194 152 222 254 193 254 165 8 254 162 170 170 1 100 30 1 113 1 48 213 182 72 100 157 5 51 250 241 150 254 239 254 226 55 149 57 1 112 1 84 253 80 5 182 253 146 1 51 1 78 2 92 146 48 38 0 0 1 0 176 255 236 5 156 4 92 0 33 0 89 64 50 22 25 25 10 3 9 5 5 6 16 32 24 3 6 5 34 35 13 19 70 89 13 16 25 4 9 4 70 89 22 15 9 31 9 2 11 3 9 9 6 7 15 6 21 0 28 70 89 0 22 0 63 43 0 24 63 63 18 57 47 95 94 93 51 43 17 0 51 24 63 43 17 18 1 23 57 17 51 17 51 17 51 51 17 51 49 48 5 34 0 39 33 17 35 17 51 17 33 54 36 51 50 22 23 7 38 35 34 6 7 33 21 33 22 22 51 50 54 55 21 6 4 119 235 254 244 11 254 225 166 166 1 33 24 1 13 223 81 154 54 50 138 101 163 167 16 2 24 253 230 9 169 164 61 119 98 110 20 1 10 248 254 18 4 72 254 51 235 246 32 25 141 51 164 170 141 188 181 22 37 147 57 0 2 0 0 0 0 5 109 5 182 0 11 0 18 0 52 64 27 2 3 7 12 3 13 10 5 20 19 1 5 12 5 73 89 16 8 12 12 7 8 3 11 3 7 18 0 63 51 51 63 18 57 47 18 57 43 17 0 51 17 18 1 23 57 17 51 49 48 1 35 17 35 17 35 1 35 1 51 1 35 1 33 39 38 39 6 7 3 152 148 156 149 254 223 178 2 104 158 2 103 183 253 92 1 76 82 56 30 24 64 2 170 253 86 2 170 253 86 5 182 250 74 3 63 207 144 100 98 164 0 0 2 0 10 0 0 4 121 4 72 0 11 0 18 0 53 64 28 5 6 10 12 6 13 3 1 6 20 19 4 8 12 8 70 89 17 11 12 12 10 11 15 6 2 10 21 0 63 51 51 63 18 57 47 18 57 43 17 0 51 17 18 1 23 57 17 51 49 48 1 1 35 3 35 17 35 17 35 3 35 1 3 33 38 38 39 35 6 2 168 1 209 172 207 113 151 115 205 172 1 209 33 1 15 43 56 34 9 28 4 72 251 184 1 233 254 23 1 233 254 23 4 72 254 45 108 138 106 92 0 0 2 0 201 0 0 7 94 5 182 0 19 0 26 0 70 64 37 14 10 10 11 2 3 18 21 3 20 8 7 11 7 27 28 5 1 9 14 9 73 89 20 24 12 14 14 11 16 12 3 19 7 3 11 18 0 63 51 51 51 63 51 18 57 47 18 57 51 43 17 0 51 51 17 18 1 23 57 17 51 17 51 17 51 49 48 1 35 17 35 17 35 1 35 1 33 17 35 17 51 17 33 1 51 1 35 1 33 2 38 39 6 6 5 133 143 154 147 254 227 186 1 34 254 95 170 170 1 225 1 6 158 2 102 188 253 102 1 62 118 28 12 19 35 2 176 253 80 2 176 253 80 2 176 253 80 5 182 253 146 2 110 250 74 3 72 1 53 86 47 67 104 0 2 0 176 0 0 6 20 4 72 0 19 0 25 0 77 64 43 17 13 13 14 5 6 1 25 6 24 11 10 14 7 26 27 8 4 12 17 12 70 89 24 21 19 47 17 63 17 2 17 17 14 19 15 15 15 10 6 2 14 21 0 63 51 51 51 63 63 18 57 47 93 18 57 51 43 17 0 51 51 17 18 1 23 57 17 51 17 51 17 51 49 48 1 1 35 3 35 17 35 17 35 3 35 19 33 17 35 17 51 17 33 19 23 35 6 6 7 33 4 70 1 206 170 208 113 152 110 209 172 209 254 223 166 166 1 94 197 104 8 10 32 89 1 12 4 72 251 184 1 238 254 18 1 238 254 18 1 238 254 18 4 72 254 51 1 205 115 34 95 217 0 0 2 0 20 0 0 5 174 5 182 0 31 0 34 0 75 64 40 32 1 15 16 33 30 30 29 16 2 1 7 6 36 35 30 1 33 31 31 33 73 89 14 18 29 18 74 89 34 2 29 29 24 31 3 16 8 24 18 0 63 51 51 63 18 57 47 51 51 43 17 0 51 43 17 18 0 57 57 17 18 1 23 57 17 51 17 51 17 51 49 48 1 21 1 30 2 23 19 35 3 46 2 35 35 17 35 17 35 34 6 6 7 3 35 19 62 2 55 1 53 5 33 1 5 41 254 90 118 154 100 50 133 174 137 35 68 101 89 27 170 26 91 99 65 32 135 185 136 47 99 149 118 254 101 3 190 253 10 1 123 5 182 133 254 17 6 72 139 164 254 59 1 201 111 96 38 253 66 2 190 39 95 111 254 55 1 197 159 142 73 7 1 239 133 153 254 57 0 0 2 0 12 0 0 5 20 4 72 0 32 0 35 0 78 64 42 33 1 15 16 34 31 24 31 30 16 2 1 7 7 37 36 31 1 34 32 32 34 70 89 17 14 18 30 18 71 89 35 2 30 30 24 32 15 16 8 24 21 0 63 51 51 63 18 57 47 51 51 43 17 0 51 51 43 17 18 0 57 57 17 18 1 23 57 17 51 17 51 17 51 49 48 1 21 1 30 3 19 35 3 46 2 35 35 17 35 17 35 34 6 6 7 3 35 19 62 3 55 1 53 5 33 1 4 139 254 174 87 111 73 49 155 172 133 34 58 84 76 10 153 11 75 82 56 39 135 170 131 24 48 73 110 87 254 177 3 32 253 180 1 37 4 72 105 254 160 7 48 80 105 254 113 1 80 87 71 28 253 246 2 10 26 64 94 254 174 1 80 61 105 79 50 8 1 96 105 140 254 193 0 0 2 0 201 0 0 7 197 5 182 0 36 0 39 0 97 64 53 33 29 29 30 38 35 15 16 2 39 37 1 7 1 39 16 34 27 35 24 30 9 41 40 35 1 36 38 36 38 73 89 18 14 28 33 28 73 89 39 2 33 33 30 36 3 31 3 24 16 8 30 18 0 63 51 51 51 63 63 18 57 47 51 51 43 17 0 51 51 43 17 18 0 57 57 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 17 51 49 48 1 21 1 30 2 23 19 35 3 46 2 35 35 17 35 17 35 34 6 6 7 3 35 19 54 55 33 17 35 17 51 17 33 1 53 5 33 1 7 61 254 93 120 153 101 45 136 168 138 31 70 105 95 24 172 25 94 100 66 33 135 178 135 55 56 254 82 170 170 2 215 254 104 3 193 253 10 1 123 5 182 133 254 14 6 72 144 156 254 59 1 201 104 99 40 253 68 2 188 40 95 108 254 55 1 190 184 58 253 80 5 182 253 146 1 233 133 153 254 55 0 0 2 0 176 0 0 6 186 4 72 0 36 0 39 0 103 64 58 33 29 29 30 38 35 15 16 2 39 37 1 7 1 39 16 34 27 35 24 30 9 41 40 35 1 36 38 36 38 70 89 18 14 28 33 28 70 89 39 2 47 33 63 33 2 33 33 30 36 15 31 15 24 16 8 30 21 0 63 51 51 51 63 63 18 57 47 93 51 51 43 17 0 51 51 43 17 18 0 57 57 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 17 51 49 48 1 21 1 30 3 19 35 3 46 2 35 35 17 35 17 35 34 6 6 7 3 35 19 54 55 33 17 35 17 51 17 33 1 53 5 33 1 6 49 254 174 88 111 73 48 155 172 133 34 58 86 74 10 154 10 75 84 55 38 135 170 131 47 37 254 205 166 166 2 53 254 176 3 33 253 180 1 37 4 72 105 254 158 7 49 78 105 254 114 1 80 86 70 28 253 248 2 8 27 63 92 254 174 1 80 120 40 254 16 4 72 254 53 1 98 105 140 254 199 0 1 0 63 254 78 4 53 6 209 0 75 0 132 64 77 0 19 33 63 25 70 70 10 63 55 67 60 42 28 45 40 19 11 76 77 73 22 74 89 73 19 57 52 49 15 46 31 46 47 46 3 9 3 46 42 64 67 29 28 29 28 74 89 29 29 16 60 42 42 36 74 89 42 4 10 9 73 89 10 16 16 3 73 89 16 35 12 7 73 89 12 34 0 63 43 0 24 63 43 0 24 16 198 43 0 24 63 43 17 0 51 18 57 24 47 43 17 18 0 57 26 24 16 221 95 94 93 57 196 50 63 43 17 18 1 23 57 17 51 17 51 17 51 49 48 23 20 22 51 50 55 54 51 50 23 21 38 35 34 7 6 35 34 38 53 52 54 55 54 54 53 16 33 35 53 51 50 54 53 52 38 35 34 6 7 39 54 55 38 39 39 53 51 22 23 54 54 51 50 23 21 38 35 34 6 7 22 22 21 20 6 7 21 22 22 21 20 4 5 6 6 240 87 89 97 120 120 70 155 71 80 160 68 105 105 105 179 184 217 232 204 181 254 64 218 209 205 225 162 137 106 187 110 86 168 190 57 117 49 123 92 131 92 131 64 50 48 24 43 44 111 48 178 193 191 170 186 203 254 229 254 230 138 134 137 55 50 7 6 39 166 51 5 5 125 133 126 129 9 8 138 141 1 12 143 147 132 107 128 55 69 114 114 28 66 121 52 27 59 136 115 86 14 113 10 82 71 23 189 143 140 184 26 8 24 178 144 208 213 9 5 55 0 0 1 0 25 254 123 3 127 5 78 0 70 0 131 64 78 23 41 54 11 46 16 16 32 11 3 14 8 62 50 64 60 41 11 71 72 68 62 65 0 5 71 89 0 15 65 31 65 47 65 3 9 3 65 62 38 26 70 89 35 29 70 89 14 51 50 51 50 70 89 38 35 51 51 35 38 3 32 62 62 56 70 89 8 62 16 32 34 19 44 71 89 19 22 0 63 43 0 24 63 63 51 43 17 18 0 23 57 24 47 47 47 43 17 18 0 57 43 43 0 24 16 212 95 94 93 196 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 49 48 1 50 23 21 38 35 34 6 7 22 22 21 20 7 21 22 21 20 6 7 14 2 21 20 22 51 50 55 55 50 23 21 38 38 35 7 6 35 34 38 53 52 54 55 36 53 52 38 35 35 53 51 32 53 52 35 34 6 7 39 54 55 38 39 53 51 22 23 54 54 2 248 51 45 24 41 47 103 45 122 140 211 248 242 225 93 109 48 75 89 86 122 175 125 39 21 84 55 179 130 92 144 159 190 180 1 78 156 159 148 119 1 55 252 74 143 88 59 124 126 92 103 123 75 140 88 134 5 78 15 112 10 79 62 28 138 107 184 57 8 71 202 148 168 3 2 23 42 44 49 43 5 5 39 143 19 24 5 5 119 112 116 125 3 4 190 97 90 141 172 162 34 36 135 55 15 117 98 27 52 137 110 85 255 255 0 109 0 0 5 242 5 182 2 6 1 117 0 0 255 255 0 164 254 20 5 135 6 18 2 6 1 149 0 0 0 3 0 125 255 236 5 190 5 205 0 11 0 18 0 25 0 71 64 37 22 16 16 6 23 15 15 0 6 0 26 27 22 16 73 89 15 22 1 11 3 22 22 3 9 9 19 73 89 9 4 3 12 73 89 3 19 0 63 43 0 24 63 43 17 18 0 57 24 47 95 94 93 43 17 18 1 57 57 17 51 17 51 17 51 17 51 49 48 1 16 0 33 32 0 17 16 0 33 32 0 1 50 18 19 33 18 18 19 34 2 3 33 38 2 5 190 254 157 254 196 254 189 254 161 1 96 1 68 1 59 1 98 253 97 229 247 13 252 43 13 249 232 224 251 19 3 211 17 244 2 221 254 161 254 110 1 139 1 104 1 101 1 137 254 112 252 68 1 17 1 12 254 245 254 238 4 180 254 254 255 0 254 1 4 0 0 3 0 115 255 236 4 98 4 92 0 12 0 19 0 26 0 73 64 39 23 17 17 7 24 16 16 0 7 0 27 28 23 17 70 89 15 23 31 23 2 11 3 23 23 3 10 10 20 70 89 10 16 3 13 70 89 3 22 0 63 43 0 24 63 43 17 18 0 57 24 47 95 94 93 43 17 18 1 57 57 17 51 17 51 17 51 17 51 49 48 1 16 0 35 34 38 2 53 16 0 51 50 0 1 50 54 55 33 22 22 19 34 6 7 33 38 38 4 98 254 242 238 147 228 124 1 12 238 230 1 15 254 8 158 164 10 253 105 9 160 160 156 158 13 2 147 15 161 2 37 254 244 254 211 138 1 2 173 1 12 1 43 254 206 253 77 184 191 186 189 3 88 173 167 168 172 0 0 1 0 0 0 0 5 72 5 195 0 21 0 32 64 16 6 22 19 23 17 0 74 89 17 4 10 5 6 3 5 18 0 63 63 18 57 63 43 17 1 51 18 57 49 48 1 34 6 7 1 35 1 51 1 22 23 54 55 19 62 2 51 50 23 21 38 4 225 59 78 57 254 184 197 253 238 180 1 82 72 35 32 70 162 59 84 110 89 42 79 56 5 55 103 181 251 229 5 182 252 86 199 143 144 223 2 6 191 152 65 19 141 20 0 1 0 0 0 0 4 61 4 82 0 22 0 30 64 15 1 23 15 24 13 18 71 89 13 16 5 1 15 0 21 0 63 63 57 63 43 17 1 51 18 57 49 48 33 1 51 19 18 23 51 54 19 19 62 2 51 50 23 21 38 35 34 6 7 3 1 150 254 106 174 225 100 19 8 23 82 96 37 71 91 84 45 30 29 38 47 58 28 248 4 72 253 155 254 244 100 118 1 11 1 53 122 123 52 10 127 8 84 92 252 223 255 255 0 0 0 0 5 72 7 115 2 38 2 128 0 0 1 7 3 118 4 215 1 82 0 10 180 2 1 33 5 38 0 43 53 53 255 255 0 0 0 0 4 61 6 33 2 38 2 129 0 0 1 7 3 118 4 100 0 0 0 10 180 2 1 34 17 38 0 43 53 53 0 3 0 125 254 20 9 162 5 205 0 11 0 23 0 46 0 68 64 38 12 6 18 0 33 46 39 24 0 6 6 47 48 37 42 74 89 37 27 29 28 28 3 32 24 15 9 21 73 89 9 4 3 15 73 89 3 19 0 63 43 0 24 63 43 0 24 63 51 18 57 17 51 63 43 17 18 1 23 57 17 51 17 51 49 48 1 16 0 33 32 0 17 16 0 33 32 0 1 16 18 51 50 18 17 16 2 35 34 2 37 51 19 22 23 51 54 54 19 51 1 6 6 35 34 39 53 22 51 50 54 55 55 5 84 254 185 254 220 254 215 254 189 1 67 1 44 1 35 1 69 251 221 223 217 218 221 220 216 218 225 4 111 176 246 78 20 8 11 83 228 176 254 43 69 188 136 76 74 55 66 94 117 35 61 2 221 254 160 254 111 1 139 1 104 1 102 1 136 254 112 254 160 254 215 254 205 1 49 1 43 1 41 1 47 254 210 65 253 139 207 102 44 251 2 131 251 32 182 158 17 133 12 103 89 156 255 255 0 115 254 20 8 123 4 92 0 38 0 82 0 0 0 7 0 92 4 117 0 0 0 2 0 125 255 135 6 16 6 45 0 19 0 40 0 81 64 42 20 10 38 13 7 17 34 34 3 28 31 0 0 28 7 23 10 5 41 42 36 34 38 13 38 73 89 17 15 13 3 28 26 23 7 23 73 89 5 3 7 18 0 63 51 51 43 17 0 51 51 24 63 51 51 43 17 0 51 51 17 18 1 23 57 17 51 17 51 51 17 51 17 51 51 17 51 49 48 1 16 0 5 6 35 34 39 36 0 17 16 0 37 54 51 50 23 4 0 1 20 18 23 54 54 51 50 23 54 18 53 52 2 39 6 35 34 39 6 2 6 16 254 209 254 248 26 119 124 20 254 244 254 209 1 43 1 16 20 124 121 22 1 12 1 45 251 33 202 189 17 73 54 110 31 189 202 202 189 31 110 113 31 189 202 2 221 254 210 254 115 44 111 111 41 1 138 1 54 1 49 1 133 44 108 108 44 254 115 254 213 244 254 207 41 48 38 86 41 1 49 244 244 1 47 39 88 86 39 254 211 0 0 2 0 115 255 147 4 207 4 180 0 23 0 45 0 80 64 42 24 12 15 9 43 27 37 21 3 35 0 0 3 32 27 9 12 6 46 47 40 37 43 15 43 70 89 21 18 15 16 32 30 27 9 27 70 89 6 3 9 21 0 63 51 51 43 17 0 51 51 24 63 51 51 43 17 0 51 51 17 18 1 23 57 17 51 17 51 51 17 51 17 51 17 51 49 48 1 20 2 7 6 6 35 34 38 39 38 2 53 52 18 55 54 54 51 50 22 23 22 18 5 20 22 23 54 54 51 50 23 54 54 53 16 37 6 6 35 34 38 39 6 6 4 207 224 204 9 64 56 57 61 9 203 229 224 208 8 62 57 56 64 9 202 226 252 80 125 137 12 60 53 103 24 134 124 254 252 13 61 51 53 60 12 137 125 2 37 233 254 223 37 54 45 43 56 36 1 38 229 233 1 32 36 56 42 43 57 38 254 220 225 177 210 31 42 34 74 31 210 175 1 96 62 42 32 32 44 31 209 0 0 3 0 125 255 236 7 127 8 59 0 21 0 69 0 84 0 85 64 46 67 55 31 43 43 1 38 70 75 80 72 60 12 55 10 85 86 21 2 2 7 7 16 12 82 64 72 58 34 64 58 64 73 89 40 58 4 28 22 52 22 73 89 46 52 19 0 63 51 43 17 0 51 24 63 51 43 17 0 51 24 16 214 26 220 212 205 50 18 57 47 51 17 18 1 23 57 17 51 17 51 49 48 1 21 35 34 46 2 35 34 6 21 21 35 53 52 54 51 50 30 2 51 1 50 54 55 22 22 51 50 18 17 16 2 35 34 6 7 39 54 51 50 0 17 16 0 33 34 38 39 6 6 35 32 0 17 16 0 51 50 23 7 38 38 35 34 2 17 16 18 1 20 7 53 54 53 52 46 2 53 52 51 50 22 5 162 17 84 142 120 102 43 47 60 125 116 112 58 112 119 133 78 253 40 88 171 61 55 171 93 188 210 165 147 60 95 43 70 121 154 228 1 1 254 224 254 253 104 170 76 75 167 110 254 252 254 227 1 1 228 154 121 70 43 94 60 148 165 210 2 128 237 120 31 36 31 92 56 67 7 199 121 36 43 36 52 51 16 28 103 110 36 44 36 248 186 66 63 57 72 1 78 1 45 1 11 1 40 43 31 146 82 254 136 254 173 254 140 254 98 40 48 45 43 1 157 1 117 1 85 1 118 82 146 31 43 254 217 254 244 254 209 254 180 6 104 162 61 72 41 53 20 18 17 26 28 73 68 0 0 3 0 115 255 236 6 4 7 6 0 42 0 63 0 78 0 92 64 51 19 7 28 40 40 44 34 64 69 13 74 66 54 7 10 79 80 50 58 63 45 45 54 76 66 10 64 31 16 10 16 70 89 2 23 70 89 2 4 37 10 16 26 21 4 21 70 89 0 4 22 0 63 51 43 17 0 51 24 63 51 18 57 43 43 17 0 51 26 24 16 222 220 212 50 17 51 205 50 17 18 1 23 57 17 51 17 51 49 48 5 34 39 6 35 34 2 17 16 18 51 50 22 23 7 38 35 34 6 21 16 33 50 55 22 22 51 32 17 52 38 35 34 7 39 54 54 51 50 18 17 16 2 3 21 35 34 46 2 35 34 21 21 35 53 52 54 51 50 30 2 51 5 20 7 53 54 53 52 46 2 53 52 51 50 22 4 43 148 94 92 143 225 250 207 186 62 119 40 57 89 71 116 109 1 49 123 112 62 111 67 1 45 110 115 71 89 57 40 119 62 187 206 247 81 16 84 143 120 101 43 107 125 115 112 58 113 118 131 78 254 240 238 119 30 36 30 92 56 67 20 65 65 1 35 1 14 1 23 1 40 32 25 139 51 214 214 254 94 80 42 38 1 162 214 214 51 139 25 32 254 215 254 234 254 245 254 218 6 165 120 36 42 36 102 17 31 100 111 37 43 37 221 161 62 72 40 56 20 17 17 25 27 74 68 0 0 2 0 94 255 236 7 127 7 4 0 13 0 64 0 95 64 52 48 36 57 54 62 23 23 1 18 54 41 12 36 7 65 66 14 45 39 45 73 89 30 55 55 33 39 5 9 9 13 64 9 15 72 13 7 3 11 64 20 39 4 59 51 33 51 73 89 26 33 19 0 63 51 43 17 0 51 24 63 51 26 222 50 50 205 43 50 17 51 17 18 57 47 57 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 49 48 1 21 7 35 39 35 7 35 39 35 7 35 39 53 1 34 6 7 39 54 51 50 18 17 16 0 33 34 38 39 35 6 6 35 32 0 17 16 0 51 50 23 7 38 38 35 34 2 17 16 18 51 50 54 55 17 51 17 22 51 50 18 17 16 2 5 139 80 32 50 186 49 33 49 188 47 33 80 3 67 60 93 45 70 124 153 228 255 254 226 254 253 116 172 76 9 78 172 112 254 252 254 227 1 1 229 150 126 70 45 93 60 147 165 210 190 65 130 51 170 102 145 188 212 165 7 4 27 172 103 103 103 103 172 27 254 43 41 31 146 80 254 136 254 173 254 139 254 99 48 48 49 47 1 160 1 114 1 85 1 118 80 146 31 41 254 215 254 246 254 209 254 180 38 38 1 201 254 55 76 1 74 1 49 1 11 1 40 0 0 2 0 0 0 0 6 29 5 164 0 13 0 42 0 63 64 36 36 1 14 26 27 12 18 7 43 44 40 21 14 31 22 3 17 18 5 9 9 13 64 9 15 72 13 7 3 11 35 27 18 15 17 21 0 63 63 51 51 222 50 50 205 43 50 17 51 17 18 23 57 63 17 18 1 23 57 49 48 1 21 7 35 39 35 7 35 39 35 7 35 39 53 1 7 3 35 1 51 19 22 23 51 54 54 19 3 51 0 22 23 51 54 18 17 51 16 2 7 35 3 38 4 182 82 30 50 188 49 31 49 188 50 30 80 1 172 39 170 213 254 127 172 246 39 41 8 12 35 186 172 178 1 9 45 10 8 173 153 166 195 219 182 125 33 5 164 27 172 103 103 103 103 172 27 252 37 95 254 150 4 72 253 73 111 171 35 81 1 136 1 213 252 255 144 44 184 1 179 1 82 254 150 254 7 229 1 90 92 0 0 1 0 125 254 20 4 227 5 203 0 23 0 45 64 24 3 15 9 10 21 10 15 3 24 25 19 0 73 89 19 4 12 6 73 89 12 19 10 27 0 63 63 43 0 24 63 43 17 18 1 23 57 17 51 17 51 49 48 1 34 0 17 16 0 33 50 55 17 35 17 35 32 0 17 52 18 36 51 50 23 7 38 3 72 245 254 224 1 10 1 2 111 57 170 20 254 181 254 159 175 1 72 216 237 170 71 171 5 51 254 192 254 232 254 218 254 212 23 253 116 1 216 1 132 1 109 224 1 86 184 84 146 78 0 1 0 115 254 20 3 162 4 92 0 24 0 47 64 24 15 3 23 22 9 22 3 3 25 26 23 27 6 12 70 89 6 16 0 18 70 89 0 22 0 63 43 0 24 63 43 0 24 63 17 18 1 23 57 17 51 17 51 49 48 5 34 0 17 16 0 51 50 22 23 7 38 35 34 6 21 20 22 51 50 54 55 17 35 17 2 117 254 254 252 1 17 251 79 164 48 49 142 104 177 171 171 171 53 80 57 166 20 1 31 1 18 1 20 1 43 34 23 141 51 205 221 220 200 17 26 253 110 1 216 0 0 1 0 106 255 252 4 117 5 6 0 19 0 47 64 33 4 2 8 3 6 0 17 7 10 16 13 18 12 14 14 21 20 19 0 3 17 6 15 5 16 7 13 10 9 12 11 1 18 0 63 205 23 57 17 18 1 23 57 49 48 1 3 39 19 37 55 5 19 37 55 5 19 23 3 5 7 37 3 5 7 2 2 182 121 182 254 225 66 1 33 205 254 223 67 1 33 185 118 184 1 33 68 254 225 204 1 30 65 1 57 254 195 67 1 66 166 115 168 1 100 166 117 168 1 61 67 254 192 166 115 166 254 158 168 115 0 1 0 203 4 145 3 172 5 180 0 19 0 30 64 12 0 6 10 16 6 16 20 21 3 0 13 9 0 47 51 51 50 17 18 1 57 57 17 51 17 51 49 48 1 6 6 35 34 38 53 52 54 51 33 54 54 51 50 22 21 20 6 35 1 135 6 42 48 51 41 42 54 1 193 6 43 47 51 45 44 54 4 240 45 50 50 53 53 41 46 48 49 51 56 40 0 1 0 248 4 229 3 219 5 215 0 19 0 28 64 11 7 18 21 20 0 18 18 12 4 128 9 0 47 26 204 50 51 17 51 17 18 1 57 57 49 48 1 50 55 54 51 50 22 21 21 35 53 52 35 34 14 2 35 35 53 1 4 120 150 149 81 111 116 125 106 43 102 121 142 84 16 5 98 59 58 111 100 31 17 102 36 43 36 121 0 1 1 223 4 215 2 205 6 53 0 14 0 24 64 10 10 0 12 5 0 3 15 16 3 13 0 47 204 17 18 1 23 57 17 51 49 48 1 52 54 51 50 21 20 14 2 21 20 23 21 38 1 223 67 56 92 30 36 30 119 238 5 184 56 69 76 27 25 16 18 20 54 40 74 64 0 1 1 225 4 215 2 207 6 53 0 14 0 24 64 10 5 0 0 10 2 3 15 16 12 2 0 47 204 17 18 1 23 57 17 51 49 48 1 20 7 53 54 53 52 46 2 53 52 51 50 22 2 207 238 119 30 36 30 92 56 67 5 184 161 64 74 40 54 20 18 16 25 27 76 69 0 8 0 41 254 193 7 193 5 145 0 12 0 26 0 40 0 54 0 68 0 82 0 95 0 109 0 128 64 73 95 40 68 90 34 62 12 26 7 20 82 54 109 76 48 103 16 110 111 0 7 58 72 72 65 79 69 68 62 76 86 99 99 92 106 102 95 90 109 30 44 44 37 51 47 34 40 3 54 16 23 7 79 76 106 109 51 54 23 23 54 51 109 106 76 79 7 8 9 13 20 3 9 0 47 51 47 51 18 23 57 47 47 47 47 47 47 47 47 17 51 17 23 51 17 51 51 17 51 17 51 51 51 17 51 51 17 51 17 51 51 51 17 51 51 17 51 17 51 17 18 1 23 57 49 48 1 38 38 35 34 6 7 35 54 51 50 22 23 3 38 38 35 34 6 7 35 54 54 51 50 22 23 1 38 38 35 34 6 7 35 54 54 51 50 22 23 33 38 38 35 34 6 7 35 54 54 51 50 22 23 1 38 38 35 34 6 7 35 54 54 51 50 22 23 33 38 38 35 34 6 7 35 54 54 51 50 22 23 1 38 38 35 34 6 7 35 54 51 50 22 23 33 38 38 35 34 6 7 35 54 54 51 50 22 23 4 111 5 60 69 78 50 5 75 11 197 93 113 7 79 5 60 69 78 50 5 75 5 100 103 92 115 6 1 244 5 60 68 78 50 5 76 5 101 103 92 115 6 251 47 5 60 68 78 50 5 76 5 101 103 92 115 6 4 49 5 60 68 78 50 5 76 5 101 103 92 115 6 251 47 5 60 68 78 50 5 76 5 101 103 92 115 6 4 240 5 60 68 78 51 5 75 11 198 92 115 6 249 190 5 60 68 78 50 5 76 5 101 103 92 115 6 4 207 44 44 41 47 194 101 93 249 242 44 44 41 47 89 105 102 92 1 22 45 43 39 49 90 105 102 93 45 43 39 49 90 105 102 93 3 219 45 43 39 49 90 105 102 93 45 43 39 49 90 105 102 93 254 25 44 44 40 48 194 104 90 45 43 39 49 90 104 102 92 0 0 8 0 41 254 127 7 125 5 211 0 7 0 15 0 23 0 31 0 39 0 46 0 53 0 62 0 52 64 37 21 23 37 32 62 58 5 1 41 44 31 28 50 53 9 13 16 63 64 59 43 7 46 54 25 21 29 17 47 39 15 36 51 14 5 12 5 0 47 47 18 23 57 17 18 1 23 57 49 48 5 23 6 6 7 35 54 55 3 39 54 54 55 51 6 7 1 55 22 22 23 21 38 39 5 7 38 38 39 53 22 23 1 55 54 54 55 23 6 7 1 7 6 7 39 54 55 3 39 38 39 55 22 23 1 23 22 22 23 7 38 38 39 4 55 11 17 70 36 97 53 17 59 11 19 73 31 97 52 18 2 35 14 71 200 65 221 129 251 104 14 66 191 79 221 129 3 166 2 67 190 67 69 177 120 252 234 2 155 169 69 177 120 43 17 82 69 67 123 76 3 106 17 39 90 22 67 31 130 38 35 14 66 191 79 221 129 4 152 14 71 200 65 220 130 254 22 11 19 73 31 97 53 17 59 11 17 70 36 97 53 17 1 170 16 39 88 25 68 110 88 252 149 16 89 63 68 110 88 2 222 2 140 183 70 198 99 252 233 2 69 194 60 70 50 195 52 0 0 2 0 201 254 131 6 8 7 94 0 20 0 34 0 89 64 47 13 10 12 7 14 14 9 19 2 2 20 20 24 32 9 10 5 36 35 20 18 6 5 17 18 5 18 14 0 14 9 73 89 14 18 12 34 31 15 24 1 24 28 21 7 0 3 0 63 50 222 50 205 93 50 63 63 43 17 18 0 57 57 17 51 17 51 24 63 17 18 1 23 57 17 51 17 51 17 51 17 51 51 17 51 49 48 19 51 17 20 7 7 51 1 51 17 51 3 35 19 35 17 52 55 35 1 35 1 34 38 39 51 22 22 51 50 54 55 51 6 6 201 161 10 4 8 3 52 184 184 143 197 156 160 19 9 252 201 186 2 67 186 168 10 155 10 93 110 105 99 9 158 12 181 5 182 252 209 118 206 83 4 198 250 226 253 235 1 125 3 37 175 247 251 53 6 43 143 164 108 78 93 93 159 148 0 2 0 176 254 135 5 18 6 12 0 17 0 31 0 79 64 42 10 7 9 4 11 11 6 15 1 1 16 16 21 29 6 7 5 33 32 3 14 16 17 15 11 6 70 89 11 16 21 9 34 28 15 21 1 21 25 18 4 15 0 63 222 50 205 93 50 63 63 51 43 0 24 63 18 57 57 17 18 1 23 57 17 51 17 51 17 51 17 51 51 17 51 49 48 1 17 20 7 1 51 17 51 3 35 19 35 17 52 55 1 35 17 37 34 38 39 51 22 22 51 50 54 55 51 6 6 1 76 10 2 81 207 176 129 172 125 155 8 253 174 205 1 236 185 170 10 156 7 90 116 103 100 10 157 12 178 4 72 253 106 136 136 3 166 252 71 253 248 1 121 2 160 158 104 252 90 4 72 145 143 164 102 84 90 96 158 149 0 2 0 47 0 0 4 125 5 182 0 17 0 25 0 77 64 41 8 4 18 18 1 15 21 11 11 6 15 17 4 26 27 8 25 73 89 7 17 0 17 73 89 4 0 8 0 8 0 15 2 15 18 74 89 15 18 2 3 0 63 63 43 17 18 0 57 57 24 47 47 17 51 43 17 0 51 43 17 18 1 23 57 17 51 17 51 51 17 51 51 49 48 19 51 53 51 21 33 21 33 17 51 32 17 20 4 33 33 17 35 1 51 32 17 52 38 35 35 47 154 170 1 86 254 170 192 2 74 254 236 254 241 254 111 154 1 68 221 1 123 184 201 215 4 252 186 186 150 254 224 254 100 210 216 4 102 252 43 1 25 132 128 0 0 2 0 20 0 0 4 76 6 20 0 18 0 26 0 75 64 40 4 0 20 20 16 12 23 8 8 2 12 14 4 27 28 4 19 70 89 3 14 15 14 71 89 0 15 4 15 4 15 12 17 0 12 20 70 89 12 21 0 63 43 0 24 63 18 57 57 47 47 17 51 43 17 0 51 43 17 18 1 23 57 17 51 17 51 51 17 51 51 49 48 1 33 21 33 17 33 50 22 21 20 6 35 33 17 35 53 51 53 51 17 17 33 32 53 52 38 35 1 86 1 39 254 217 1 64 223 215 224 221 254 33 156 156 166 1 49 1 31 132 159 5 31 129 253 229 154 155 164 170 4 158 129 245 251 224 254 151 185 92 84 0 0 2 0 201 0 0 4 121 5 182 0 15 0 28 0 72 64 41 16 10 10 11 24 0 0 4 5 3 22 6 21 19 20 11 10 29 30 22 19 28 16 12 28 74 89 9 16 74 89 6 3 12 9 9 11 12 3 11 18 0 63 63 18 57 47 18 57 57 43 43 17 18 0 57 57 17 18 1 23 57 17 51 17 51 17 51 49 48 1 20 6 7 23 7 39 6 35 35 17 35 17 33 32 4 1 51 50 55 39 55 23 54 53 52 38 35 35 4 121 115 108 120 100 149 102 136 184 170 1 137 1 18 1 21 252 250 166 87 76 108 108 140 127 194 202 200 4 12 127 201 57 157 84 192 27 253 193 5 182 215 253 242 10 141 82 176 72 178 145 142 0 2 0 176 254 20 4 117 4 92 0 24 0 41 0 85 64 49 29 11 4 7 7 8 39 18 18 21 22 20 37 23 34 36 35 8 10 42 43 37 34 25 32 15 25 70 89 12 11 11 4 20 23 4 0 15 16 9 15 8 27 0 32 70 89 0 22 0 63 43 0 24 63 63 63 18 23 57 17 51 43 17 18 0 57 57 17 18 1 23 57 17 51 17 51 17 51 51 51 49 48 5 34 38 39 35 22 21 17 35 17 51 23 51 54 54 51 50 18 17 16 7 23 7 39 6 3 34 6 7 21 20 22 51 50 55 39 55 23 54 53 52 38 2 174 107 177 60 12 12 166 135 25 8 64 169 109 218 237 183 115 100 131 71 109 168 150 2 154 170 47 41 121 106 129 101 150 20 79 82 148 34 254 61 6 52 150 90 80 254 214 254 243 254 174 145 156 80 174 24 3 227 186 203 37 231 199 12 158 80 170 103 249 215 209 0 0 1 0 47 0 0 4 8 5 182 0 13 0 60 64 31 3 7 7 12 8 0 5 8 10 4 14 15 6 10 11 10 73 89 3 11 11 8 13 13 2 73 89 13 3 8 18 0 63 63 43 17 18 0 57 24 47 51 43 17 0 51 17 18 1 23 57 17 51 51 17 51 49 48 1 21 33 17 33 21 33 17 35 17 35 53 51 17 4 8 253 107 1 168 254 88 170 154 154 5 182 153 254 2 150 253 119 2 137 150 2 151 0 1 0 18 0 0 3 66 4 72 0 13 0 60 64 31 2 6 6 11 7 0 4 7 9 4 14 15 5 9 10 9 71 89 2 10 10 7 12 12 1 70 89 12 15 7 21 0 63 63 43 17 18 0 57 24 47 51 43 17 0 51 17 18 1 23 57 17 51 51 17 51 49 48 1 33 17 33 21 33 17 35 17 35 53 51 17 33 3 66 254 20 1 90 254 166 166 158 158 2 146 3 188 254 168 127 254 27 1 229 127 1 228 0 0 1 0 201 254 0 4 219 5 182 0 27 0 65 64 35 9 3 3 4 25 14 14 7 20 4 4 28 29 17 23 73 89 17 28 11 0 73 89 11 11 4 5 5 8 73 89 5 3 4 18 0 63 63 43 17 18 0 57 24 47 43 0 24 63 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 34 7 17 35 17 33 21 33 17 54 51 32 0 17 16 0 33 34 38 39 53 22 51 32 17 52 0 2 49 100 90 170 3 73 253 97 90 121 1 64 1 85 254 226 254 253 83 125 70 123 137 1 127 255 0 2 143 12 253 125 5 182 153 253 252 10 254 173 254 198 254 197 254 165 21 28 152 49 1 254 245 1 4 0 0 1 0 176 254 10 3 250 4 72 0 27 0 65 64 35 8 25 20 14 14 15 15 2 18 25 4 29 28 22 11 70 89 22 22 15 16 16 19 70 89 16 15 15 21 0 5 70 89 0 27 0 63 43 0 24 63 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 34 39 53 22 51 50 54 53 52 38 35 34 7 17 35 17 33 21 33 17 54 51 32 0 17 16 2 2 70 145 101 116 123 133 136 178 181 69 74 166 2 154 254 12 82 59 1 16 1 7 228 254 10 60 149 63 202 215 223 208 17 254 37 4 72 142 254 183 12 254 229 254 217 254 245 254 218 0 0 1 0 2 254 131 6 248 5 182 0 21 0 77 64 41 6 17 17 3 18 13 12 12 8 9 18 0 1 21 7 22 23 18 21 18 19 16 9 6 3 0 0 15 1 15 10 73 89 15 18 13 34 7 4 1 3 0 63 51 51 63 63 43 17 18 0 57 17 51 51 51 51 51 24 63 51 17 18 1 23 57 17 51 17 51 51 17 51 49 48 1 1 51 1 17 51 17 1 51 1 1 51 17 35 17 35 1 17 35 17 1 35 2 86 253 193 190 2 57 164 2 58 190 253 192 1 218 180 162 94 253 186 164 253 187 199 2 240 2 198 253 60 2 196 253 60 2 196 253 60 253 168 253 233 1 125 2 229 253 27 2 229 253 27 0 0 1 0 4 254 135 6 31 4 72 0 21 0 75 64 40 2 13 13 21 14 9 8 8 4 5 14 18 19 17 7 22 23 21 15 12 5 2 18 18 11 3 0 19 15 14 17 21 11 6 70 89 11 21 9 34 0 63 63 43 0 24 63 51 63 51 51 18 57 17 51 51 51 51 51 17 18 1 23 57 17 51 17 51 51 17 51 49 48 1 51 17 1 51 1 1 51 17 35 17 35 1 17 35 17 1 35 1 1 51 1 2 164 153 1 197 182 254 54 1 112 193 162 94 254 30 153 254 31 191 1 240 254 55 182 1 195 4 72 253 237 2 19 253 237 254 90 253 248 1 121 2 45 253 211 2 45 253 211 2 53 2 19 253 237 0 255 255 0 74 254 66 4 53 5 203 2 38 1 177 0 0 0 7 3 127 1 88 0 0 255 255 0 68 254 66 3 127 4 92 2 38 1 209 0 0 0 7 3 127 1 8 0 0 0 1 0 201 254 131 5 43 5 182 0 15 0 59 64 32 12 8 8 9 3 2 2 14 15 6 9 5 16 17 15 12 6 3 5 13 10 3 9 18 5 0 73 89 5 18 3 34 0 63 63 43 0 24 63 63 51 18 23 57 17 18 1 23 57 17 51 17 51 17 51 49 48 37 51 17 35 17 35 1 7 17 35 17 51 17 1 51 1 4 127 172 162 102 253 233 153 170 170 2 151 201 253 180 154 253 233 1 125 2 197 136 253 195 5 182 253 43 2 213 253 133 0 1 0 176 254 133 4 61 4 72 0 14 0 58 64 31 14 10 10 11 6 5 5 1 2 11 4 15 16 2 14 9 3 8 0 12 15 11 21 8 3 70 89 8 21 6 34 0 63 63 43 0 24 63 63 51 18 23 57 17 18 1 23 57 17 51 17 51 17 51 49 48 1 51 1 1 51 17 35 17 35 1 17 35 17 51 17 3 47 182 254 39 1 127 178 159 84 254 12 166 166 4 72 253 239 254 88 253 246 1 123 2 43 253 213 4 72 253 235 0 0 1 0 201 0 0 4 233 5 182 0 18 0 56 64 30 6 2 2 3 10 17 17 7 18 14 12 18 3 4 19 20 8 10 6 0 16 18 6 3 11 4 3 15 3 18 0 63 51 63 51 18 23 57 17 18 1 23 57 17 51 51 17 51 17 51 17 51 49 48 1 7 17 35 17 51 17 55 17 51 21 1 51 1 1 35 1 17 35 1 240 125 170 170 125 125 1 155 203 253 180 2 98 200 254 76 125 2 168 107 253 195 5 182 253 37 139 1 93 211 1 198 253 133 252 197 2 92 254 207 0 1 0 176 0 0 4 59 4 72 0 19 0 58 64 31 6 2 2 3 14 10 18 18 7 19 15 12 19 3 4 20 21 8 10 6 1 17 19 6 3 11 4 15 16 3 21 0 63 51 63 51 18 23 57 17 18 1 23 57 17 51 51 17 51 51 17 51 17 51 49 48 1 39 17 35 17 51 17 55 17 51 21 1 51 1 21 1 35 1 21 35 1 205 119 166 166 119 131 1 14 182 254 60 1 235 194 254 213 129 1 178 121 253 213 4 72 253 235 121 1 74 205 1 31 254 37 107 253 254 1 59 221 0 0 1 0 47 0 0 4 233 5 182 0 19 0 71 64 38 8 4 16 16 1 17 11 14 12 10 6 14 17 19 6 20 21 7 19 0 19 73 89 4 11 8 14 3 17 0 0 2 13 17 18 9 2 3 0 63 51 63 51 18 57 47 18 23 57 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 51 49 48 19 51 53 51 21 51 21 35 17 1 51 1 1 35 1 7 17 35 17 35 47 154 170 221 221 2 149 203 253 180 2 98 206 253 241 153 170 154 5 4 178 178 151 254 110 2 219 253 133 252 197 2 197 134 253 193 4 109 0 0 1 0 20 0 0 4 27 6 20 0 25 0 77 64 43 10 8 4 22 22 1 23 18 16 6 17 23 25 6 26 27 20 10 15 19 23 21 7 25 0 25 71 89 4 15 0 31 0 47 0 3 0 0 2 15 15 2 0 0 63 63 18 57 47 93 51 43 17 0 51 24 63 51 18 57 57 17 18 1 23 57 17 51 51 17 51 51 51 49 48 19 51 53 51 21 33 21 33 17 7 7 51 55 54 54 1 51 1 1 35 1 7 17 35 17 35 20 156 164 1 125 254 131 3 3 8 18 55 40 1 112 199 254 68 1 217 199 254 125 125 164 156 5 90 186 186 127 253 232 91 55 24 74 48 1 133 254 45 253 139 2 4 106 254 102 4 219 0 1 0 16 0 0 5 131 5 182 0 13 0 53 64 27 2 10 10 11 5 8 6 4 8 11 4 14 15 8 2 0 7 11 18 3 3 0 13 73 89 0 3 0 63 43 0 24 63 63 51 18 57 57 17 18 1 23 57 17 51 17 51 17 51 49 48 19 33 17 1 51 1 1 35 1 7 17 35 17 33 16 1 252 2 150 203 253 180 2 98 201 253 236 154 170 254 174 5 182 253 37 2 219 253 133 252 197 2 197 136 253 195 5 29 0 0 1 0 41 0 0 4 227 4 72 0 12 0 53 64 27 5 1 1 9 9 10 12 10 4 6 4 14 13 8 2 0 7 10 21 3 15 0 12 70 89 0 15 0 63 43 0 24 63 63 51 18 57 57 17 18 1 23 57 17 51 17 51 17 51 49 48 19 33 17 1 51 1 1 35 1 17 35 17 33 41 2 2 1 219 182 254 39 2 0 194 254 10 164 254 162 4 72 253 235 2 21 253 237 253 203 2 43 253 213 3 188 0 1 0 201 254 131 5 193 5 182 0 15 0 68 64 36 12 8 8 9 13 5 5 0 3 2 2 0 9 3 16 17 12 7 73 89 12 12 5 14 10 3 9 18 5 0 73 89 5 18 3 34 0 63 63 43 0 24 63 63 51 18 57 47 43 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 49 48 37 51 17 35 17 35 17 33 17 35 17 51 17 33 17 51 5 31 162 162 170 252 254 170 170 3 2 170 154 253 233 1 125 2 176 253 80 5 182 253 146 2 110 0 0 1 0 176 254 135 4 248 4 72 0 15 0 78 64 43 1 13 13 14 2 10 10 5 8 7 7 5 14 3 16 17 1 12 70 89 15 1 31 1 2 11 3 1 1 10 3 15 15 14 21 10 5 70 89 10 21 8 34 0 63 63 43 0 24 63 63 51 18 57 47 95 94 93 43 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 49 48 1 17 33 17 51 17 51 17 35 17 35 17 33 17 35 17 1 86 2 102 166 150 166 150 253 154 166 4 72 254 53 1 203 252 71 253 248 1 121 1 238 254 18 4 72 0 0 1 0 201 0 0 6 111 5 182 0 13 0 63 64 33 10 6 6 7 11 3 3 2 0 2 7 3 14 15 10 5 73 89 10 10 7 12 12 1 73 89 12 3 8 3 3 7 18 0 63 51 63 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 33 17 35 17 33 17 35 17 51 17 33 17 33 6 111 254 176 172 253 0 170 170 3 0 1 252 5 29 250 227 2 176 253 80 5 182 253 146 2 110 0 1 0 176 0 0 5 193 4 72 0 13 0 73 64 39 1 11 11 12 2 8 8 7 4 7 12 3 14 15 13 15 1 10 70 89 15 1 31 1 2 11 3 1 1 3 8 12 21 3 6 70 89 3 15 0 63 43 0 24 63 51 18 57 47 95 94 93 43 0 24 63 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 17 33 17 33 21 33 17 35 17 33 17 35 17 1 86 2 102 2 5 254 161 166 253 154 166 4 72 254 53 1 203 140 252 68 1 238 254 18 4 72 0 1 0 201 254 0 8 29 5 182 0 29 0 71 64 38 4 5 8 0 0 1 23 13 13 18 1 5 4 30 31 16 21 73 89 16 28 10 26 73 89 10 10 5 6 6 3 73 89 6 3 1 5 18 0 63 51 63 43 17 18 0 57 24 47 43 0 24 63 43 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 33 35 17 33 17 35 17 33 17 54 51 32 0 17 16 0 33 34 39 53 22 51 32 17 52 2 35 34 6 7 4 217 170 253 68 170 4 16 68 125 1 50 1 81 254 229 254 254 156 123 134 127 1 122 230 232 42 127 24 5 29 250 227 5 182 253 97 12 254 168 254 200 254 199 254 166 49 152 49 1 254 242 1 5 7 5 0 0 1 0 176 254 10 6 168 4 72 0 28 0 71 64 38 17 18 21 13 13 14 7 26 26 2 14 18 4 29 30 23 10 70 89 23 23 18 19 19 16 70 89 19 15 14 18 21 0 5 70 89 0 27 0 63 43 0 24 63 51 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 34 39 53 22 51 50 17 52 38 35 34 7 17 35 17 33 17 35 17 33 17 54 51 50 0 17 16 2 5 23 131 97 109 108 240 166 172 67 72 168 253 223 166 3 111 75 66 246 1 6 209 254 10 60 149 63 1 161 223 208 21 254 41 3 184 252 72 4 72 254 39 14 254 215 254 231 254 244 254 219 0 2 0 125 255 172 5 225 5 205 0 40 0 52 0 80 64 44 27 17 47 35 41 0 8 0 3 22 32 35 17 7 53 54 38 44 74 89 12 50 38 38 14 20 20 25 73 89 20 4 10 5 73 89 10 14 14 30 73 89 14 19 0 63 43 0 24 16 196 43 0 24 63 43 17 18 0 57 24 47 57 57 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 20 2 7 22 51 50 55 21 6 35 34 39 6 35 32 0 17 16 0 33 50 23 7 38 35 32 17 16 18 51 50 55 38 2 53 52 18 51 50 18 3 52 38 35 34 6 21 20 22 23 54 54 5 184 138 116 66 90 78 61 56 91 178 148 102 144 254 202 254 161 1 73 1 58 127 92 47 84 90 254 51 255 235 54 46 86 92 198 175 181 193 176 103 93 94 103 93 83 102 115 2 166 181 254 203 86 30 22 153 25 100 36 1 137 1 86 1 120 1 138 35 145 28 253 158 254 224 254 206 10 103 1 28 160 244 1 10 254 246 254 254 177 204 201 176 140 254 85 67 255 0 0 2 0 115 255 199 4 211 4 92 0 10 0 53 0 80 64 44 30 19 0 38 6 44 52 44 47 24 36 38 19 7 54 55 41 8 71 89 13 3 41 41 15 22 22 27 70 89 22 16 11 49 70 89 11 15 15 33 70 89 15 22 0 63 43 0 24 16 196 43 0 24 63 43 17 18 0 57 24 47 57 57 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 20 22 23 54 54 53 52 35 34 6 1 34 39 6 35 34 38 38 53 16 18 51 50 23 7 38 35 34 6 21 20 22 51 50 54 55 38 53 52 54 51 50 22 21 20 6 7 22 51 50 55 21 6 2 238 68 63 68 83 135 72 75 1 102 147 130 96 123 149 226 122 248 227 91 77 37 54 79 156 145 170 164 37 53 6 139 168 151 148 157 107 94 52 67 66 49 39 1 242 94 161 53 44 158 110 235 125 253 99 77 40 139 254 164 1 19 1 48 22 138 19 209 231 206 210 9 3 148 225 173 193 189 177 125 209 64 26 14 137 14 0 255 255 0 125 254 66 4 207 5 203 2 38 0 38 0 0 0 7 3 127 2 37 0 0 255 255 0 115 254 66 3 139 4 92 2 38 0 70 0 0 0 7 3 127 1 131 0 0 0 1 0 16 254 131 4 90 5 182 0 11 0 50 64 27 6 11 8 9 3 9 11 1 4 12 13 11 6 73 89 11 18 9 34 5 1 2 1 73 89 2 3 0 63 43 17 0 51 24 63 63 43 17 18 1 23 57 17 51 17 51 49 48 1 33 53 33 21 33 17 51 17 35 17 35 1 223 254 49 4 74 254 49 162 162 172 5 29 153 153 251 125 253 233 1 125 0 0 1 0 41 254 135 3 145 4 72 0 11 0 52 64 27 6 11 8 9 3 9 11 1 4 12 13 9 34 5 1 2 1 70 89 2 15 11 6 70 89 11 21 0 63 43 0 24 63 43 17 0 51 24 63 17 18 1 23 57 17 51 17 51 49 48 1 33 53 33 21 33 17 51 17 35 17 35 1 137 254 160 3 104 254 158 150 166 150 3 188 140 140 252 211 253 248 1 121 0 255 255 0 0 0 0 4 123 5 182 2 6 0 60 0 0 0 1 0 0 254 20 4 2 4 72 0 13 0 41 64 20 0 1 12 1 3 3 14 15 8 7 13 7 2 11 3 15 2 21 1 27 0 63 63 63 51 18 57 57 17 51 17 18 1 23 57 17 51 49 48 1 35 17 1 51 19 22 23 51 54 55 19 51 1 2 84 166 254 82 172 236 83 19 8 33 70 233 172 254 82 254 20 1 232 4 76 253 155 222 97 138 181 2 101 251 180 0 0 1 0 0 0 0 4 123 5 182 0 16 0 58 64 30 4 8 8 13 9 2 6 9 11 15 5 17 18 7 11 12 11 73 89 4 0 15 12 12 9 1 15 3 9 18 0 63 63 51 18 57 47 18 57 51 43 17 0 51 17 18 1 23 57 17 51 51 17 51 49 48 1 1 51 1 21 33 21 33 17 35 17 33 53 33 53 1 51 2 61 1 134 184 254 24 1 43 254 213 172 254 211 1 45 254 25 186 2 219 2 219 252 129 59 152 254 156 1 100 152 51 3 135 0 1 0 0 254 20 4 2 4 72 0 19 0 60 64 31 17 1 1 6 2 16 19 2 4 7 5 20 21 12 11 11 5 15 7 15 0 4 5 4 71 89 17 5 21 2 27 0 63 63 51 43 17 0 51 24 63 51 18 57 17 51 17 18 1 23 57 17 51 51 17 51 49 48 5 17 35 17 33 53 33 1 51 19 22 23 51 54 55 19 51 1 33 21 2 84 166 254 234 1 20 254 84 172 236 83 19 8 33 70 233 172 254 84 1 18 129 254 149 1 107 129 4 72 253 155 222 97 138 181 2 101 251 184 129 0 0 1 0 8 254 131 4 213 5 182 0 15 0 55 64 32 3 2 2 14 15 12 6 9 10 8 8 16 17 12 15 9 6 4 5 13 10 3 8 18 5 0 73 89 5 18 3 34 0 63 63 43 0 24 63 63 51 18 23 57 17 18 1 23 57 17 51 49 48 37 51 17 35 17 35 1 1 35 1 1 51 1 1 51 1 4 51 162 162 94 254 119 254 112 180 1 230 254 59 188 1 107 1 110 181 254 59 154 253 233 1 125 2 131 253 125 2 252 2 186 253 189 2 67 253 76 0 1 0 39 254 133 4 55 4 72 0 15 0 57 64 33 10 9 9 5 6 3 13 0 1 15 8 16 17 15 21 3 6 0 13 4 12 1 12 7 70 89 12 21 10 34 4 1 15 0 63 51 63 63 43 17 18 0 23 57 24 63 17 18 1 23 57 17 51 49 48 1 1 51 1 1 51 1 1 51 17 35 17 35 1 1 35 1 184 254 131 189 1 33 1 32 187 254 131 1 43 149 166 69 254 205 254 202 188 2 49 2 23 254 92 1 164 253 233 254 94 253 246 1 123 1 188 254 68 0 0 1 0 16 254 131 6 168 5 182 0 15 0 64 64 34 12 5 0 13 3 2 2 13 10 5 7 5 16 17 14 3 11 7 8 7 73 89 8 3 0 12 5 12 73 89 5 18 3 34 0 63 63 43 17 0 51 24 63 43 17 0 51 24 63 17 18 1 23 57 17 51 17 51 17 51 49 48 37 51 17 35 17 33 17 33 53 33 21 33 17 33 17 51 5 254 170 162 251 180 254 86 4 47 254 37 2 240 170 154 253 233 1 125 5 29 153 153 251 125 5 28 0 1 0 41 254 135 5 152 4 70 0 15 0 63 64 34 2 11 6 3 9 8 8 3 0 11 13 5 16 17 1 13 14 13 70 89 14 15 6 2 11 2 70 89 11 21 9 34 4 15 0 63 63 63 43 17 0 51 24 63 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 49 48 1 33 17 33 17 51 17 51 17 35 17 33 17 33 53 33 3 121 254 151 2 70 166 156 166 252 120 254 191 3 80 3 186 252 213 3 183 252 73 253 248 1 121 3 186 140 0 0 1 0 170 254 131 5 104 5 182 0 23 0 59 64 31 21 0 5 3 2 15 12 2 5 12 3 24 25 18 9 73 89 18 18 5 22 13 3 5 0 73 89 5 18 3 34 0 63 63 43 0 24 63 51 18 57 47 43 17 18 1 23 57 17 51 17 51 17 51 51 49 48 37 51 17 35 17 35 17 6 6 35 34 38 53 17 51 17 20 22 51 50 54 55 17 51 4 199 161 161 170 149 198 106 207 223 170 127 143 97 177 169 170 154 253 233 1 125 2 92 53 39 190 179 2 69 253 207 121 116 29 55 2 202 0 0 1 0 156 254 133 4 195 4 72 0 22 0 59 64 31 1 21 9 6 14 12 11 11 14 21 3 23 24 3 18 70 89 3 3 14 7 22 15 14 9 70 89 14 21 12 34 0 63 63 43 0 24 63 51 18 57 47 43 17 18 1 23 57 17 51 17 51 51 17 51 49 48 1 17 20 51 50 54 55 17 51 17 51 17 35 17 35 17 6 6 35 34 38 53 17 1 66 219 91 166 105 166 150 166 150 105 179 113 164 186 4 72 254 112 192 56 67 1 213 252 71 253 246 1 123 1 240 72 59 172 147 1 156 0 1 0 170 0 0 4 199 5 182 0 22 0 74 64 38 5 2 11 21 21 8 22 13 17 17 16 16 22 2 3 23 24 20 0 8 0 73 89 11 8 22 8 9 9 8 22 3 3 17 18 14 3 3 0 63 51 63 18 23 57 47 47 47 17 51 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 51 17 51 17 51 49 48 1 32 17 17 51 17 20 22 51 17 51 17 54 55 17 51 17 35 17 6 7 17 35 2 117 254 53 170 135 154 125 134 163 172 172 168 129 125 2 0 1 113 2 69 253 207 119 118 1 92 254 170 13 60 2 207 250 74 2 88 65 17 254 207 0 1 0 156 0 0 4 29 4 72 0 23 0 74 64 38 1 22 6 16 16 3 17 8 12 12 11 11 17 22 3 24 25 15 19 3 19 70 89 6 3 17 3 4 4 3 17 3 12 9 23 15 12 21 0 63 63 51 18 23 57 47 47 47 17 51 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 51 17 51 17 51 49 48 1 17 20 23 17 51 17 54 55 17 51 17 35 17 6 7 21 35 53 35 34 38 53 17 1 66 200 119 113 133 166 166 128 118 119 22 160 184 4 72 254 112 186 6 1 45 254 221 24 89 1 213 251 184 1 240 91 26 248 234 170 149 1 156 0 1 0 201 0 0 4 229 5 182 0 18 0 47 64 23 2 17 17 18 9 8 8 18 20 19 4 13 73 89 2 18 4 4 9 18 18 0 3 0 63 63 51 57 47 18 57 43 17 18 1 57 57 17 51 17 51 17 51 49 48 19 51 17 36 51 50 22 21 17 35 17 52 38 35 34 6 7 17 35 201 170 1 0 196 207 223 170 127 143 107 186 149 170 5 182 253 164 92 191 177 253 186 2 49 120 118 34 50 253 53 0 0 1 0 176 0 0 4 66 4 72 0 18 0 47 64 23 0 18 11 7 7 8 18 8 20 19 14 3 70 89 11 14 14 8 9 15 0 8 21 0 63 51 63 18 57 47 57 43 17 18 1 57 57 17 51 17 51 17 51 49 48 33 17 52 35 34 6 7 17 35 17 51 17 54 54 51 50 22 21 17 3 154 217 88 156 119 166 166 95 186 114 163 190 1 141 193 49 74 254 45 4 72 254 14 69 62 168 151 254 102 0 2 0 61 255 236 6 63 5 205 0 32 0 39 0 81 64 42 5 3 0 36 17 17 8 30 37 16 16 24 30 0 4 40 41 17 30 7 30 73 89 36 7 2 7 2 27 12 27 20 73 89 27 19 12 33 73 89 12 4 0 63 43 0 24 63 43 17 18 0 57 57 24 47 47 51 43 17 0 51 17 18 1 23 57 17 51 17 51 51 17 51 17 51 51 49 48 19 52 55 51 6 21 20 51 51 55 18 0 33 32 0 17 21 33 18 0 51 50 54 55 21 6 6 35 32 0 3 34 38 1 34 2 7 33 16 38 61 27 145 20 113 34 5 29 1 77 1 23 1 41 1 40 251 220 14 1 5 247 101 202 141 114 221 130 254 198 254 163 19 142 155 3 175 209 240 16 3 110 203 3 135 73 54 50 60 103 43 1 42 1 71 254 133 254 143 69 254 248 254 239 31 43 156 39 30 1 100 1 76 118 2 35 254 245 249 1 9 251 0 0 2 0 51 255 236 4 221 4 90 0 31 0 38 0 76 64 40 10 8 5 22 13 36 21 21 29 13 3 5 5 39 40 22 3 12 3 70 89 35 12 7 12 7 0 17 17 32 70 89 17 16 0 25 70 89 0 22 0 63 43 0 24 63 43 17 18 0 57 57 24 47 47 51 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 51 49 48 5 34 0 39 36 53 52 55 51 6 21 20 51 51 55 54 54 51 50 18 21 21 33 22 22 51 50 54 55 21 6 6 3 34 6 7 33 52 38 3 74 243 254 236 6 254 246 25 141 20 106 21 6 34 250 183 207 241 253 12 6 172 173 101 159 98 88 157 160 134 151 14 2 61 140 20 1 30 252 4 221 69 50 47 59 103 35 202 224 254 247 226 105 198 195 32 42 148 38 33 3 227 164 158 157 165 0 2 0 61 254 131 6 63 5 205 0 34 0 41 0 93 64 49 11 9 6 38 23 23 14 3 33 34 39 22 22 30 34 3 6 5 42 43 34 34 32 19 23 3 13 3 73 89 38 13 8 13 8 0 18 18 35 73 89 18 4 0 26 74 89 0 19 0 63 43 0 24 63 43 17 18 0 57 57 24 47 47 51 43 17 0 51 24 63 63 17 18 1 23 57 17 51 17 51 17 51 51 17 51 17 51 51 49 48 5 36 0 3 34 38 53 52 55 51 6 21 20 51 51 55 18 0 33 32 0 17 21 33 18 0 51 50 54 55 21 6 7 17 35 19 34 2 7 33 16 38 3 160 254 254 254 219 19 142 155 27 145 20 113 34 5 29 1 77 1 23 1 41 1 40 251 220 14 1 5 247 101 202 141 176 235 166 76 209 240 16 3 110 203 12 29 1 90 1 49 118 117 73 54 50 60 103 43 1 42 1 71 254 133 254 143 69 254 248 254 239 31 43 156 62 5 254 149 6 178 254 245 249 1 9 251 0 2 0 51 254 135 4 221 4 90 0 33 0 40 0 88 64 47 10 8 5 22 13 32 33 38 21 21 29 33 13 3 5 6 41 42 33 34 31 22 22 3 12 3 70 89 37 12 7 12 7 0 17 17 34 70 89 17 16 0 25 70 89 0 21 0 63 43 0 24 63 43 17 18 0 57 57 24 47 47 51 43 17 0 51 24 63 63 17 18 1 23 57 17 51 17 51 17 51 17 51 51 49 48 5 38 2 39 36 53 52 55 51 6 21 20 51 51 55 54 54 51 50 18 21 21 33 22 22 51 50 54 55 21 6 7 17 35 19 34 6 7 33 52 38 2 213 191 211 6 254 246 25 141 20 106 21 6 34 250 183 207 241 253 12 6 172 173 101 159 98 142 165 166 68 134 151 14 2 61 140 10 31 1 17 224 4 221 69 50 47 59 103 35 202 224 254 247 226 105 198 195 32 42 148 65 4 254 153 5 72 164 158 157 165 0 255 255 0 84 0 0 2 86 5 182 2 6 0 44 0 0 255 255 0 2 0 0 6 188 7 96 2 38 1 176 0 0 1 7 2 54 1 16 1 84 0 8 179 1 18 5 38 0 43 53 255 255 0 4 0 0 5 223 6 12 2 38 1 208 0 0 1 7 2 54 0 164 0 0 0 8 179 1 18 17 38 0 43 53 0 1 0 201 254 0 5 25 5 182 0 28 0 66 64 37 7 3 3 4 26 14 14 9 10 20 4 5 29 30 17 23 73 89 17 28 7 2 73 89 11 0 74 89 7 11 11 4 8 5 3 4 18 0 63 63 51 18 57 47 57 43 43 0 24 63 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 34 7 17 35 17 51 17 1 51 1 55 32 0 17 16 0 33 34 38 39 53 22 51 50 18 53 52 36 2 94 140 95 170 170 2 137 205 253 133 26 1 79 1 98 254 217 254 245 82 124 70 122 152 187 200 254 235 2 123 31 253 164 5 182 253 60 2 196 253 84 2 254 187 254 207 254 198 254 164 20 29 152 49 1 13 241 232 253 0 0 1 0 176 254 10 4 33 4 72 0 28 0 66 64 37 4 0 0 1 23 10 16 10 6 7 1 5 29 30 14 20 70 89 14 27 4 28 71 89 7 26 70 89 4 7 7 1 5 2 15 1 21 0 63 63 51 18 57 47 57 43 43 0 24 63 43 17 18 1 23 57 17 51 17 51 17 51 49 48 33 35 17 51 17 1 51 1 4 18 17 20 6 6 35 34 39 53 22 22 51 50 54 53 52 38 35 34 7 1 84 164 164 1 227 183 254 55 1 0 252 110 204 133 136 95 46 108 71 135 152 187 190 82 92 4 72 253 250 2 6 254 30 4 254 228 254 245 177 252 132 60 145 25 38 217 200 211 207 24 0 1 0 0 254 131 5 145 5 182 0 23 0 57 64 31 3 0 5 4 1 1 5 14 3 24 25 22 7 73 89 22 3 12 17 74 89 12 18 5 0 73 89 5 18 3 34 0 63 63 43 0 24 63 43 0 24 63 43 17 18 1 23 57 17 51 17 51 51 49 48 37 51 3 35 19 35 17 33 7 2 2 6 39 34 39 53 22 51 50 54 54 18 19 33 4 217 184 143 197 156 170 254 37 31 61 93 152 126 74 59 54 59 53 79 61 93 56 3 18 154 253 233 1 125 5 31 240 254 33 254 69 174 2 25 143 26 87 215 2 89 1 184 0 0 1 0 16 254 135 4 143 4 70 0 20 0 57 64 31 3 0 5 4 1 1 5 13 3 21 22 19 7 70 89 19 15 11 16 71 89 11 21 5 0 70 89 5 21 3 34 0 63 63 43 0 24 63 43 0 24 63 43 17 18 1 23 57 17 51 17 51 51 49 48 37 51 3 35 19 35 17 33 2 2 6 35 34 39 53 22 51 50 18 19 33 3 223 176 129 172 125 166 254 181 28 94 152 118 58 28 22 28 113 137 34 2 129 143 253 248 1 121 3 184 254 152 254 100 192 10 127 6 1 217 1 246 0 0 1 0 201 254 0 5 31 5 182 0 21 0 61 64 32 18 14 14 15 19 11 11 0 0 6 15 3 22 23 18 13 73 89 18 18 15 20 16 3 15 18 3 9 73 89 3 28 0 63 43 0 24 63 63 51 18 57 47 43 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 37 16 0 33 34 38 39 53 22 51 32 17 17 33 17 35 17 51 17 33 17 51 5 31 254 230 254 251 82 122 77 123 135 1 140 252 254 170 170 3 2 170 150 254 194 254 168 19 30 150 49 1 247 2 35 253 80 5 182 253 146 2 110 0 1 0 176 254 10 4 98 4 72 0 21 0 71 64 39 15 11 11 12 16 8 8 19 19 2 12 3 22 23 15 10 70 89 15 15 31 15 2 11 3 15 15 12 17 13 15 12 21 0 5 70 89 0 27 0 63 43 0 24 63 63 51 18 57 47 95 94 93 43 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 34 39 53 22 51 50 54 53 17 33 17 35 17 51 17 33 17 51 17 16 2 2 211 132 93 111 102 125 118 253 156 166 166 2 100 168 207 254 10 58 149 61 198 207 1 189 254 18 4 72 254 53 1 203 251 235 254 244 254 227 0 1 0 201 254 131 5 215 5 182 0 15 0 68 64 36 12 8 8 9 13 3 0 5 4 1 1 5 9 3 16 17 12 7 73 89 12 12 5 14 10 3 9 18 5 0 73 89 5 18 3 34 0 63 63 43 0 24 63 63 51 18 57 47 43 17 18 1 23 57 17 51 17 51 51 51 17 51 17 51 49 48 37 51 3 35 19 35 17 33 17 35 17 51 17 33 17 51 5 31 184 145 197 158 170 252 254 170 170 3 2 170 154 253 233 1 125 2 176 253 80 5 182 253 146 2 110 0 0 1 0 176 254 135 5 18 4 70 0 15 0 68 64 36 1 13 13 14 8 5 2 10 9 6 6 10 14 3 16 17 1 12 70 89 1 1 10 3 15 15 14 21 10 5 70 89 10 21 8 34 0 63 63 43 0 24 63 63 51 18 57 47 43 17 18 1 23 57 17 51 17 51 51 51 17 51 17 51 49 48 1 17 33 17 51 17 51 3 35 19 35 17 33 17 35 17 1 86 2 102 166 176 129 172 125 166 253 154 166 4 70 254 55 1 201 252 73 253 248 1 121 1 238 254 18 4 70 0 0 1 0 170 254 131 4 199 5 182 0 23 0 61 64 32 15 12 2 3 21 5 5 0 0 3 12 3 24 25 18 9 73 89 18 18 1 22 13 3 3 34 1 4 73 89 1 18 0 63 43 0 24 63 63 51 18 57 47 43 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 33 35 17 35 17 51 17 6 6 35 34 38 53 17 51 17 20 22 51 50 54 55 17 51 4 199 170 162 162 149 198 106 207 223 170 127 143 97 177 169 170 254 131 2 23 1 194 53 39 190 179 2 69 253 207 121 116 29 55 2 202 0 1 0 156 254 133 4 45 4 72 0 22 0 61 64 32 1 21 11 12 6 14 14 9 9 12 21 3 23 24 3 18 70 89 3 3 10 7 22 15 12 34 10 13 70 89 10 21 0 63 43 0 24 63 63 51 18 57 47 43 17 18 1 23 57 17 51 17 51 17 51 17 51 49 48 1 17 20 51 50 54 55 17 51 17 35 17 35 17 51 17 6 6 35 34 38 53 17 1 66 219 91 166 105 166 149 166 149 105 179 113 164 186 4 72 254 112 192 56 67 1 213 251 184 254 133 2 10 1 97 72 59 172 147 1 156 0 1 0 201 254 131 7 41 5 182 0 24 0 72 64 37 9 6 6 7 17 14 12 19 18 15 15 19 7 3 25 26 23 22 2 11 2 19 8 19 14 73 89 19 18 17 34 12 8 3 0 7 18 0 63 51 63 51 63 63 43 17 18 0 57 57 17 51 51 17 18 1 23 57 17 51 17 51 51 51 17 51 17 51 49 48 33 1 35 23 22 21 17 35 17 33 1 51 1 51 17 51 3 35 19 35 17 52 55 35 1 3 80 254 16 8 7 7 157 1 0 1 209 8 1 209 254 184 143 199 158 170 14 8 254 12 5 16 127 192 47 252 94 5 182 251 74 4 182 250 228 253 233 1 125 3 174 132 220 250 242 0 0 1 0 176 254 135 5 223 4 70 0 24 0 63 64 32 19 20 8 5 10 9 6 6 10 20 3 25 26 11 18 0 18 15 3 21 15 20 21 10 5 70 89 10 15 21 8 34 0 63 63 51 43 0 24 63 63 51 18 57 57 17 51 17 18 1 23 57 17 51 17 51 51 17 51 49 48 37 55 55 1 51 17 51 3 35 19 35 17 7 7 1 35 1 38 39 17 35 17 51 1 22 2 233 31 43 1 41 211 176 129 172 125 147 20 58 254 229 139 254 229 53 20 148 203 1 41 45 160 93 118 2 211 252 73 253 248 1 121 3 137 58 153 253 74 2 184 134 75 252 119 4 70 253 45 110 255 255 0 84 0 0 2 86 5 182 2 6 0 44 0 0 255 255 0 0 0 0 5 16 7 94 2 38 0 36 0 0 1 7 2 54 0 57 1 82 0 8 179 2 15 5 38 0 43 53 255 255 0 94 255 236 3 205 6 12 2 38 0 68 0 0 1 6 2 54 232 0 0 8 179 2 37 17 38 0 43 53 255 255 0 0 0 0 5 16 7 37 2 38 0 36 0 0 1 7 0 106 0 61 1 82 0 10 180 3 2 36 5 38 0 43 53 53 255 255 0 94 255 236 3 205 5 211 2 38 0 68 0 0 1 6 0 106 243 0 0 10 180 3 2 58 17 38 0 43 53 53 255 255 255 254 0 0 6 129 5 182 2 6 0 136 0 0 255 255 0 94 255 236 6 115 4 92 2 6 0 168 0 0 255 255 0 201 0 0 3 248 7 94 2 38 0 40 0 0 1 7 2 54 0 16 1 82 0 8 179 1 12 5 38 0 43 53 255 255 0 115 255 236 4 18 6 12 2 38 0 72 0 0 1 6 2 54 12 0 0 8 179 2 27 17 38 0 43 53 0 2 0 117 255 236 5 88 5 205 0 18 0 25 0 61 64 32 23 14 16 22 22 9 9 2 14 3 26 27 15 23 73 89 15 15 12 6 12 19 73 89 12 19 6 0 73 89 6 4 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 34 7 53 54 54 51 32 0 17 16 0 33 32 17 53 33 2 0 3 50 18 55 33 16 22 2 152 227 226 115 210 134 1 75 1 111 254 166 254 203 253 172 4 47 17 254 249 195 210 249 16 252 135 204 5 53 76 158 38 32 254 113 254 155 254 162 254 113 2 235 70 1 10 1 14 251 78 1 13 247 254 248 252 0 0 2 0 102 255 236 4 6 4 92 0 20 0 27 0 59 64 31 25 9 24 11 3 3 17 9 3 28 29 10 25 70 89 10 10 6 0 6 21 70 89 6 22 0 14 70 89 0 16 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 51 17 51 49 48 1 50 0 17 16 0 35 34 2 53 53 33 38 38 35 34 6 7 53 54 54 19 50 54 55 33 20 22 1 250 245 1 23 254 253 218 208 243 2 244 5 179 166 98 165 95 89 162 154 133 154 12 253 195 141 4 92 254 212 254 251 254 248 254 201 1 12 225 105 204 187 33 41 147 40 34 252 27 165 156 157 164 0 255 255 0 117 255 236 5 88 7 37 2 38 2 225 0 0 1 7 0 106 0 147 1 82 0 10 180 3 2 47 5 38 0 43 53 53 255 255 0 102 255 236 4 6 5 211 2 38 2 226 0 0 1 6 0 106 234 0 0 10 180 3 2 49 17 38 0 43 53 53 255 255 0 2 0 0 6 188 7 37 2 38 1 176 0 0 1 7 0 106 1 16 1 82 0 10 180 2 1 39 5 38 0 43 53 53 255 255 0 4 0 0 5 223 5 211 2 38 1 208 0 0 1 7 0 106 0 162 0 0 0 10 180 2 1 39 17 38 0 43 53 53 255 255 0 74 255 236 4 53 7 37 2 38 1 177 0 0 1 7 0 106 255 243 1 82 0 10 180 2 1 62 5 38 0 43 53 53 255 255 0 68 255 236 3 127 5 211 2 38 1 209 0 0 1 6 0 106 148 0 0 10 180 2 1 56 17 38 0 43 53 53 0 1 0 74 255 236 4 55 5 182 0 25 0 64 64 35 0 19 21 25 15 3 3 25 19 22 8 5 26 27 25 22 23 22 73 89 0 18 74 89 0 0 6 23 3 6 12 74 89 6 19 0 63 43 0 24 63 18 57 47 43 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 49 48 1 4 4 21 20 4 33 32 39 53 22 22 51 50 54 53 52 38 35 35 53 1 33 53 33 21 1 252 1 23 1 36 254 205 254 234 254 255 163 96 222 106 199 202 225 223 140 1 238 253 78 3 135 3 63 9 211 193 206 232 79 158 46 50 153 144 134 138 141 1 222 153 139 0 0 1 0 27 254 20 3 166 4 72 0 25 0 64 64 35 0 19 21 25 15 4 4 25 19 22 9 5 26 27 25 22 23 22 70 89 0 18 71 89 0 0 7 23 15 7 12 70 89 7 27 0 63 43 0 24 63 18 57 47 43 43 17 0 51 17 18 1 23 57 17 51 17 51 17 51 49 48 1 30 2 21 20 0 35 34 39 53 22 51 50 54 53 52 38 35 35 53 1 33 53 33 21 1 172 149 230 127 254 216 239 234 138 183 200 161 197 214 202 121 1 197 253 137 3 56 1 207 7 114 202 136 222 254 238 70 154 86 190 160 164 170 114 1 254 142 123 0 255 255 0 203 0 0 5 82 6 180 2 38 1 178 0 0 1 7 1 77 0 180 1 82 0 8 179 1 19 5 38 0 43 53 255 255 0 176 0 0 4 98 5 98 2 38 1 210 0 0 1 6 1 77 49 0 0 8 179 1 17 17 38 0 43 53 255 255 0 203 0 0 5 82 7 37 2 38 1 178 0 0 1 7 0 106 0 190 1 82 0 10 180 2 1 37 5 38 0 43 53 53 255 255 0 176 0 0 4 98 5 211 2 38 1 210 0 0 1 6 0 106 61 0 0 10 180 2 1 35 17 38 0 43 53 53 255 255 0 125 255 236 5 190 7 37 2 38 0 50 0 0 1 7 0 106 0 209 1 82 0 10 180 3 2 45 5 38 0 43 53 53 255 255 0 115 255 236 4 98 5 211 2 38 0 82 0 0 1 6 0 106 29 0 0 10 180 3 2 46 17 38 0 43 53 53 255 255 0 125 255 236 5 190 5 205 2 6 2 126 0 0 255 255 0 115 255 236 4 98 4 92 2 6 2 127 0 0 255 255 0 125 255 236 5 190 7 37 2 38 2 126 0 0 1 7 0 106 0 209 1 82 0 10 180 4 3 47 5 38 0 43 53 53 255 255 0 115 255 236 4 98 5 211 2 38 2 127 0 0 1 6 0 106 27 0 0 10 180 4 3 48 17 38 0 43 53 53 255 255 0 61 255 236 4 137 7 37 2 38 1 199 0 0 1 7 0 106 255 237 1 82 0 10 180 2 1 48 5 38 0 43 53 53 255 255 0 57 255 236 3 125 5 211 2 38 1 231 0 0 1 6 0 106 142 0 0 10 180 2 1 48 17 38 0 43 53 53 255 255 0 27 255 236 4 248 6 180 2 38 1 189 0 0 1 7 1 77 0 47 1 82 0 8 179 1 26 5 38 0 43 53 255 255 0 2 254 20 4 6 5 98 2 38 0 92 0 0 1 6 1 77 173 0 0 8 179 1 25 17 38 0 43 53 255 255 0 27 255 236 4 248 7 37 2 38 1 189 0 0 1 7 0 106 0 59 1 82 0 10 180 2 1 44 5 38 0 43 53 53 255 255 0 2 254 20 4 6 5 211 2 38 0 92 0 0 1 6 0 106 183 0 0 10 180 2 1 43 17 38 0 43 53 53 255 255 0 27 255 236 4 248 7 115 2 38 1 189 0 0 1 7 1 83 0 141 1 82 0 10 180 2 1 42 5 38 0 43 53 53 255 255 0 2 254 20 4 6 6 33 2 38 0 92 0 0 1 6 1 83 4 0 0 10 180 2 1 41 17 38 0 43 53 53 255 255 0 170 0 0 4 199 7 37 2 38 1 193 0 0 1 7 0 106 0 106 1 82 0 10 180 2 1 41 5 38 0 43 53 53 255 255 0 156 0 0 4 45 5 211 2 38 1 225 0 0 1 6 0 106 23 0 0 10 180 2 1 40 17 38 0 43 53 53 0 1 0 201 254 131 4 8 5 182 0 9 0 45 64 24 4 9 6 7 1 7 9 3 10 11 9 4 73 89 9 18 7 34 0 3 73 89 0 3 0 63 43 0 24 63 63 43 17 18 1 23 57 17 51 17 51 49 48 19 33 21 33 17 51 17 35 17 35 201 3 63 253 107 161 161 170 5 182 153 251 125 253 233 1 125 0 1 0 176 254 135 3 66 4 70 0 9 0 45 64 24 4 9 6 7 1 7 9 3 10 11 9 4 70 89 9 21 7 34 0 3 70 89 0 15 0 63 43 0 24 63 63 43 17 18 1 23 57 17 51 17 51 49 48 19 33 21 33 17 51 17 35 17 35 176 2 146 254 20 150 166 150 4 70 140 252 213 253 248 1 121 255 255 0 201 0 0 6 10 7 37 2 38 1 197 0 0 1 7 0 106 1 27 1 82 0 10 180 4 3 45 5 38 0 43 53 53 255 255 0 176 0 0 5 121 5 211 2 38 1 229 0 0 1 7 0 106 0 197 0 0 0 10 180 4 3 44 17 38 0 43 53 53 255 255 0 47 254 117 4 8 5 182 2 38 2 155 0 0 0 7 3 128 0 147 0 0 255 255 0 18 254 117 3 66 4 72 2 38 2 156 0 0 0 6 3 129 117 0 255 255 0 8 254 117 4 201 5 182 0 38 0 59 0 0 0 7 3 128 3 88 0 0 255 255 0 39 254 117 4 52 4 72 0 38 0 91 0 0 0 7 3 129 2 195 0 0 0 1 0 6 0 0 4 150 5 182 0 17 0 59 64 34 15 2 17 1 16 13 4 10 7 9 6 11 12 19 18 10 17 0 17 73 89 7 13 15 4 0 0 2 12 15 18 5 2 3 0 63 51 63 51 18 57 47 57 18 57 51 43 17 0 51 17 18 1 23 57 49 48 19 33 1 51 1 1 51 1 33 21 33 1 35 1 1 35 1 33 127 1 51 254 119 188 1 107 1 108 183 254 112 1 60 254 186 1 189 193 254 119 254 112 182 1 191 254 186 3 84 2 98 253 187 2 69 253 158 152 253 68 2 131 253 125 2 188 0 0 1 0 39 0 0 4 8 4 72 0 17 0 59 64 34 15 2 17 1 16 13 4 10 7 9 6 11 12 19 18 10 17 0 17 71 89 7 13 15 4 0 0 2 12 15 21 5 2 15 0 63 51 63 51 18 57 47 57 18 57 51 43 17 0 51 17 18 1 23 57 49 48 19 33 1 51 1 1 51 1 33 21 33 1 35 1 1 35 1 33 117 1 18 254 180 189 1 33 1 32 187 254 178 1 24 254 226 1 104 188 254 205 254 202 188 1 102 254 232 2 119 1 209 254 92 1 164 254 47 129 254 10 1 188 254 68 1 246 0 0 2 0 131 0 0 4 55 5 182 0 10 0 19 0 52 64 26 4 19 19 7 15 0 7 0 21 20 3 12 73 89 3 3 8 5 8 18 74 89 8 18 5 3 0 63 63 43 17 18 0 57 24 47 43 17 18 1 57 57 17 51 17 51 17 51 49 48 19 52 36 33 51 17 51 17 33 32 36 1 35 34 6 21 20 22 51 51 131 1 36 1 32 198 170 254 99 254 245 254 244 3 10 186 222 194 182 203 217 1 164 212 206 2 112 250 74 213 1 219 124 142 143 132 255 255 0 115 255 236 4 55 6 20 2 6 0 71 0 0 0 2 0 131 255 236 6 119 5 182 0 25 0 35 0 70 64 36 30 3 24 10 10 7 35 15 18 18 35 3 3 36 37 6 27 73 89 24 6 16 6 16 0 8 3 12 32 0 32 74 89 21 0 19 0 63 50 43 17 0 51 24 63 18 57 57 47 47 57 43 17 18 1 23 57 17 51 17 51 51 18 57 17 51 49 48 5 34 38 53 52 36 33 51 17 51 17 20 51 50 54 53 17 51 17 20 6 35 34 38 39 6 19 35 34 6 21 16 33 50 54 53 2 78 226 233 1 42 1 34 145 170 230 100 121 170 207 184 118 159 51 113 41 151 212 194 1 33 127 141 18 209 208 217 222 2 112 251 183 236 123 110 1 230 254 24 174 206 82 90 170 2 192 139 150 254 244 119 112 0 0 2 0 115 255 236 6 135 6 20 0 34 0 46 0 81 64 41 44 19 12 32 32 29 26 38 3 6 6 38 19 3 47 48 30 0 13 16 26 22 4 4 16 22 22 42 70 89 22 16 0 35 16 35 70 89 9 16 22 0 63 51 43 17 0 51 24 63 43 17 18 0 57 24 47 18 57 18 57 63 17 18 1 23 57 17 51 17 51 51 51 18 57 17 51 49 48 37 50 54 53 17 51 17 20 6 35 34 38 39 35 6 6 35 34 2 17 16 18 51 50 22 23 51 38 38 53 17 51 17 20 22 33 50 54 53 53 52 38 35 32 17 20 22 4 254 118 107 168 200 189 129 158 43 8 75 185 129 208 232 231 207 106 159 63 12 2 8 166 109 253 185 162 146 148 162 254 226 139 119 132 136 1 57 254 189 200 197 91 113 113 91 1 41 1 12 1 12 1 47 77 85 17 112 27 1 190 251 140 160 137 185 206 35 231 201 254 78 214 210 0 1 0 78 255 236 6 129 5 203 0 42 0 75 64 40 6 19 40 25 31 34 34 22 25 19 1 13 6 43 44 23 2 1 2 1 74 89 2 32 2 32 37 16 37 28 73 89 37 19 16 9 74 89 16 4 0 63 43 0 24 63 43 17 18 0 57 57 24 47 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 49 48 1 35 53 51 50 54 53 52 38 35 34 6 7 39 54 54 51 50 22 21 20 6 7 21 4 19 22 22 51 50 54 53 17 51 17 20 6 35 34 38 39 38 38 1 174 201 193 192 213 154 128 103 177 103 84 93 246 130 214 245 178 156 1 98 6 2 108 124 119 112 168 210 189 202 208 2 2 205 2 172 143 147 132 108 127 55 69 114 72 80 196 167 141 183 26 8 51 254 209 150 127 121 135 1 205 254 41 198 199 209 200 150 145 0 1 0 80 255 236 5 197 4 92 0 37 0 75 64 40 18 30 10 36 2 5 5 36 30 32 14 24 6 38 39 33 15 14 15 14 70 89 15 3 15 3 8 27 27 20 70 89 27 16 8 0 70 89 8 22 0 63 43 0 24 63 43 17 18 0 57 57 24 47 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 49 48 37 50 17 17 51 17 20 6 35 32 3 38 38 35 35 53 51 32 53 52 35 34 6 7 39 54 54 51 50 22 21 20 7 21 22 22 23 22 4 66 221 166 187 196 254 134 16 5 141 148 140 111 1 33 242 75 135 77 57 85 163 104 184 211 192 99 123 5 9 119 1 12 1 57 254 189 202 195 1 77 99 88 141 172 162 36 34 135 40 36 155 134 184 57 8 20 122 106 211 0 1 0 78 254 131 4 209 5 203 0 35 0 74 64 40 25 26 30 35 33 32 32 22 26 35 4 16 6 36 37 26 5 4 5 4 74 89 5 5 35 19 35 30 73 89 35 18 33 34 19 12 74 89 19 4 0 63 43 0 24 63 63 43 17 18 0 57 24 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 49 48 1 52 38 35 35 53 51 50 54 53 52 38 35 34 6 7 39 54 54 51 50 22 21 20 6 7 21 22 22 21 17 51 17 35 17 35 3 131 229 226 217 209 205 225 164 135 105 195 105 84 97 254 132 220 253 189 163 184 195 172 162 172 1 156 133 139 143 147 132 107 128 58 66 114 74 78 196 167 140 183 25 8 25 179 148 254 254 253 233 1 125 0 0 1 0 80 254 135 4 16 4 90 0 30 0 74 64 40 7 18 25 30 28 27 27 21 30 18 3 13 6 32 31 21 4 3 4 3 70 89 4 4 30 15 30 25 70 89 30 21 28 34 15 10 70 89 15 16 0 63 43 0 24 63 63 43 17 18 0 57 24 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 49 48 1 52 33 35 53 51 32 53 52 38 35 34 7 39 54 51 50 22 21 20 7 21 22 22 21 21 51 17 35 17 35 2 213 254 203 150 117 1 57 133 119 153 150 61 161 203 191 213 203 126 112 157 166 149 1 45 199 141 172 82 80 70 135 74 154 135 182 57 11 37 137 102 156 253 248 1 121 0 0 1 0 0 255 233 7 33 5 182 0 35 0 58 64 29 20 35 26 29 29 35 9 3 36 37 27 27 7 18 18 1 73 89 18 3 23 12 7 12 74 89 32 7 19 0 63 51 43 17 0 51 24 63 43 17 18 0 57 24 47 17 18 1 23 57 17 51 17 51 49 48 1 33 7 2 2 6 6 35 34 39 53 22 51 50 54 54 18 18 19 33 17 20 22 51 50 54 53 17 51 17 20 6 35 34 38 53 4 12 254 72 31 43 76 83 130 100 69 64 50 63 49 64 44 56 74 55 2 239 111 115 112 113 168 205 188 196 200 5 31 240 254 174 254 68 210 102 25 143 26 62 104 1 2 1 233 1 174 251 207 137 121 121 135 1 205 254 41 193 204 204 197 0 0 1 0 16 255 236 6 41 4 70 0 29 0 58 64 29 0 14 5 8 8 14 22 3 31 30 6 6 20 28 28 16 70 89 28 15 3 25 20 25 71 89 11 20 22 0 63 51 43 17 0 51 24 63 43 17 18 0 57 24 47 17 18 1 23 57 17 51 17 51 49 48 1 20 22 51 50 17 17 51 17 20 6 35 34 38 53 17 33 2 2 6 35 34 39 53 22 51 50 18 19 33 3 207 104 119 213 166 187 190 188 203 254 197 28 94 152 118 58 28 22 28 113 137 34 2 113 1 131 137 131 1 10 1 59 254 189 202 195 196 203 2 61 254 152 254 100 192 10 127 6 1 217 1 246 0 0 1 0 201 255 236 7 94 5 182 0 25 0 67 64 35 23 0 15 6 9 22 18 18 19 9 15 19 3 26 27 22 17 73 89 22 7 22 7 19 24 20 3 19 18 12 3 73 89 12 19 0 63 43 0 24 63 63 51 18 57 57 47 47 43 17 18 1 23 57 17 51 17 51 17 51 17 51 51 49 48 1 20 22 51 50 54 53 17 51 17 20 6 35 34 38 53 17 33 17 35 17 51 17 33 17 51 4 246 110 115 112 113 166 200 191 195 200 253 39 170 170 2 217 170 1 133 137 121 121 135 1 205 254 41 191 206 203 198 1 51 253 80 5 182 253 146 2 110 0 0 1 0 176 255 236 6 168 4 72 0 24 0 77 64 42 5 2 19 10 13 1 22 22 23 13 19 23 3 25 26 1 21 70 89 15 1 31 1 2 11 3 1 11 1 11 23 3 24 15 23 21 16 8 70 89 16 22 0 63 43 0 24 63 63 51 18 57 57 47 47 95 94 93 43 17 18 1 23 57 17 51 17 51 17 51 17 51 51 49 48 1 17 33 17 51 17 20 22 51 50 17 17 51 17 20 6 35 34 38 53 53 33 17 35 17 1 86 2 80 166 106 119 213 166 187 192 186 205 253 176 166 4 72 254 53 1 203 253 61 137 133 1 12 1 57 254 189 202 195 198 201 115 254 18 4 72 0 0 1 0 125 255 236 5 154 5 203 0 28 0 58 64 31 22 8 27 2 2 15 28 8 4 29 30 0 28 73 89 0 0 5 12 12 19 73 89 12 4 5 25 73 89 5 19 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 49 48 1 33 21 16 0 33 32 0 17 52 18 36 51 50 22 23 7 38 38 35 32 0 17 16 0 51 32 17 33 3 102 2 52 254 204 254 201 254 187 254 147 179 1 85 234 120 237 83 66 90 214 87 254 245 254 222 1 11 247 1 180 254 127 2 240 86 254 161 254 177 1 145 1 96 229 1 84 181 49 39 148 38 46 254 197 254 227 254 227 254 195 1 215 0 0 1 0 115 255 236 4 176 4 92 0 25 0 58 64 31 18 7 24 2 2 12 25 7 4 26 27 0 25 70 89 0 0 4 10 10 15 70 89 10 16 4 21 70 89 4 22 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 49 48 1 33 21 16 33 32 0 17 16 0 33 50 23 7 38 35 34 6 21 20 22 51 50 54 53 33 2 178 1 254 253 254 254 238 254 215 1 67 1 33 212 175 59 168 166 205 229 204 197 169 175 254 170 2 63 67 253 240 1 39 1 16 1 14 1 43 80 131 74 222 210 207 223 160 157 0 0 1 0 16 255 236 4 244 5 182 0 20 0 57 64 29 5 19 10 13 13 3 19 0 4 21 22 11 11 16 1 16 8 73 89 16 19 4 0 1 0 73 89 1 3 0 63 43 17 0 51 24 63 43 17 18 0 57 24 47 17 18 1 23 57 17 51 17 51 49 48 19 53 33 21 33 17 20 22 51 50 17 17 51 17 20 6 35 34 38 53 17 16 4 60 254 47 119 114 232 168 211 189 198 205 5 29 153 153 252 104 137 123 1 0 1 207 254 41 192 205 206 195 3 160 0 0 1 0 41 255 236 4 135 4 70 0 20 0 54 64 28 2 16 7 10 10 0 16 18 4 21 22 1 18 19 18 70 89 8 8 13 19 15 13 5 70 89 13 22 0 63 43 0 24 63 18 57 47 43 17 0 51 17 18 1 23 57 17 51 17 51 49 48 1 33 17 20 22 51 50 17 17 51 17 20 6 35 34 38 53 17 33 53 33 3 129 254 166 109 118 215 166 189 192 192 201 254 168 3 88 3 186 253 201 137 131 1 4 1 65 254 189 202 195 203 196 2 63 140 0 1 0 111 255 236 4 88 5 203 0 38 0 71 64 38 21 32 12 0 36 35 5 27 17 35 0 32 6 39 40 35 15 18 15 18 74 89 15 15 29 3 29 24 74 89 29 19 3 9 74 89 3 4 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 49 48 19 52 36 51 32 23 7 38 38 35 34 6 21 20 22 51 51 21 35 34 6 21 20 22 51 50 55 21 6 33 32 36 53 52 54 55 53 38 38 156 1 8 225 1 2 209 94 105 181 101 140 159 209 200 217 213 222 232 202 183 233 199 175 254 251 254 244 254 219 207 188 170 180 4 92 169 198 144 120 68 52 123 114 128 147 141 142 138 142 141 92 158 77 220 197 151 192 22 8 25 178 255 255 0 90 255 236 3 135 4 92 2 6 1 130 0 0 255 255 0 0 254 117 5 107 5 182 0 38 1 181 0 0 0 7 3 128 3 250 0 0 255 255 0 16 254 117 4 115 4 72 2 38 1 213 0 0 0 7 3 129 3 2 0 0 255 255 0 0 254 160 5 16 5 188 2 38 0 36 0 0 0 7 2 103 4 233 0 0 255 255 0 94 254 160 3 205 4 90 2 38 0 68 0 0 0 7 2 103 4 121 0 0 255 255 0 0 0 0 5 16 7 225 2 38 0 36 0 0 1 7 2 102 4 252 1 82 0 8 179 2 19 5 38 0 43 53 255 255 0 94 255 236 3 205 6 143 2 38 0 68 0 0 1 7 2 102 4 166 0 0 0 8 179 2 41 17 38 0 43 53 255 255 0 0 0 0 5 16 7 209 2 38 0 36 0 0 1 7 3 119 4 229 1 82 0 10 180 3 2 21 5 38 0 43 53 53 255 255 0 94 255 236 4 65 6 127 2 38 0 68 0 0 1 7 3 119 4 147 0 0 0 10 180 3 2 43 17 38 0 43 53 53 255 255 0 0 0 0 5 16 7 209 2 38 0 36 0 0 1 7 3 120 4 221 1 82 0 10 180 3 2 21 5 38 0 43 53 53 255 255 0 45 255 236 3 205 6 127 2 38 0 68 0 0 1 7 3 120 4 147 0 0 0 10 180 3 2 43 17 38 0 43 53 53 255 255 0 0 0 0 5 16 8 74 2 38 0 36 0 0 1 7 3 121 4 217 1 82 0 10 180 3 2 21 5 38 0 43 53 53 255 255 0 94 255 236 4 23 6 248 2 38 0 68 0 0 1 7 3 121 4 156 0 0 0 10 180 3 2 43 17 38 0 43 53 53 255 255 0 0 0 0 5 16 8 98 2 38 0 36 0 0 1 7 3 122 4 229 1 82 0 10 180 3 2 45 5 38 0 43 53 53 255 255 0 94 255 236 3 205 7 16 2 38 0 68 0 0 1 7 3 122 4 145 0 0 0 10 180 3 2 67 17 38 0 43 53 53 255 255 0 0 254 160 5 16 7 115 2 38 0 36 0 0 0 39 2 103 4 233 0 0 1 7 1 75 0 43 1 82 0 8 179 3 41 5 38 0 43 53 255 255 0 94 254 160 3 205 6 33 2 38 0 68 0 0 0 39 2 103 4 121 0 0 1 6 1 75 212 0 0 8 179 3 62 17 38 0 43 53 255 255 0 0 0 0 5 16 8 19 2 38 0 36 0 0 1 7 3 123 4 236 1 82 0 10 180 3 2 23 5 38 0 43 53 53 255 255 0 94 255 236 3 205 6 193 2 38 0 68 0 0 1 7 3 123 4 154 0 0 0 10 180 3 2 45 17 38 0 43 53 53 255 255 0 0 0 0 5 16 8 19 2 38 0 36 0 0 1 7 3 124 4 233 1 82 0 10 180 3 2 23 5 38 0 43 53 53 255 255 0 94 255 236 3 205 6 193 2 38 0 68 0 0 1 7 3 124 4 152 0 0 0 10 180 3 2 45 17 38 0 43 53 53 255 255 0 0 0 0 5 16 8 88 2 38 0 36 0 0 1 7 3 125 4 233 1 82 0 10 180 3 2 33 5 38 0 43 53 53 255 255 0 94 255 236 3 205 7 6 2 38 0 68 0 0 1 7 3 125 4 160 0 0 0 10 180 3 2 55 17 38 0 43 53 53 255 255 0 0 0 0 5 16 8 94 2 38 0 36 0 0 1 7 3 126 4 227 1 82 0 10 180 3 2 39 5 38 0 43 53 53 255 255 0 94 255 236 3 205 7 12 2 38 0 68 0 0 1 7 3 126 4 152 0 0 0 10 180 3 2 61 17 38 0 43 53 53 255 255 0 0 254 160 5 16 7 73 2 38 0 36 0 0 0 39 1 78 0 45 1 100 1 7 2 103 4 233 0 0 0 8 179 2 15 5 38 0 43 53 255 255 0 94 254 160 3 205 5 229 2 38 0 68 0 0 0 38 1 78 216 0 1 7 2 103 4 121 0 0 0 8 179 2 37 17 38 0 43 53 255 255 0 201 254 160 3 248 5 182 2 38 0 40 0 0 0 7 2 103 4 193 0 0 255 255 0 115 254 160 4 18 4 92 2 38 0 72 0 0 0 7 2 103 4 184 0 0 255 255 0 201 0 0 3 248 7 225 2 38 0 40 0 0 1 7 2 102 4 209 1 82 0 8 179 1 16 5 38 0 43 53 255 255 0 115 255 236 4 18 6 143 2 38 0 72 0 0 1 7 2 102 4 201 0 0 0 8 179 2 31 17 38 0 43 53 255 255 0 201 0 0 3 248 7 47 2 38 0 40 0 0 1 7 1 82 255 228 1 82 0 8 179 1 21 5 38 0 43 53 255 255 0 115 255 236 4 18 5 221 2 38 0 72 0 0 1 6 1 82 208 0 0 8 179 2 36 17 38 0 43 53 255 255 0 201 0 0 4 111 7 209 2 38 0 40 0 0 1 7 3 119 4 193 1 82 0 10 180 2 1 18 5 38 0 43 53 53 255 255 0 115 255 236 4 92 6 127 2 38 0 72 0 0 1 7 3 119 4 174 0 0 0 10 180 3 2 33 17 38 0 43 53 53 255 255 0 93 0 0 3 248 7 209 2 38 0 40 0 0 1 7 3 120 4 195 1 82 0 10 180 2 1 18 5 38 0 43 53 53 255 255 0 74 255 236 4 18 6 127 2 38 0 72 0 0 1 7 3 120 4 176 0 0 0 10 180 3 2 33 17 38 0 43 53 53 255 255 0 201 0 0 4 57 8 74 2 38 0 40 0 0 1 7 3 121 4 190 1 82 0 10 180 2 1 18 5 38 0 43 53 53 255 255 0 115 255 236 4 29 6 248 2 38 0 72 0 0 1 7 3 121 4 162 0 0 0 10 180 3 2 33 17 38 0 43 53 53 255 255 0 201 0 0 3 248 8 98 2 38 0 40 0 0 1 7 3 122 4 184 1 82 0 10 180 2 1 42 5 38 0 43 53 53 255 255 0 115 255 236 4 18 7 16 2 38 0 72 0 0 1 7 3 122 4 162 0 0 0 10 180 3 2 57 17 38 0 43 53 53 255 255 0 201 254 160 3 248 7 115 2 38 0 40 0 0 0 39 2 103 4 190 0 0 1 7 1 75 0 2 1 82 0 8 179 2 37 5 38 0 43 53 255 255 0 115 254 160 4 18 6 33 2 38 0 72 0 0 0 39 2 103 4 176 0 0 1 6 1 75 241 0 0 8 179 3 52 17 38 0 43 53 255 255 0 84 0 0 2 86 7 225 2 38 0 44 0 0 1 7 2 102 3 201 1 82 0 8 179 1 16 5 38 0 43 53 255 255 0 123 0 0 1 230 6 143 2 38 0 243 0 0 1 7 2 102 3 115 0 0 0 8 179 1 8 17 38 0 43 53 255 255 0 84 254 160 2 86 5 182 2 38 0 44 0 0 0 7 2 103 3 180 0 0 255 255 0 157 254 160 1 102 5 223 2 38 0 76 0 0 0 7 2 103 3 98 0 0 255 255 0 125 254 160 5 190 5 205 2 38 0 50 0 0 0 7 2 103 5 127 0 0 255 255 0 115 254 160 4 98 4 92 2 38 0 82 0 0 0 7 2 103 4 201 0 0 255 255 0 125 255 236 5 190 7 225 2 38 0 50 0 0 1 7 2 102 5 143 1 82 0 8 179 2 28 5 38 0 43 53 255 255 0 115 255 236 4 98 6 143 2 38 0 82 0 0 1 7 2 102 4 217 0 0 0 8 179 2 29 17 38 0 43 53 255 255 0 125 255 236 5 190 7 209 2 38 0 50 0 0 1 7 3 119 5 125 1 82 0 10 180 3 2 30 5 38 0 43 53 53 255 255 0 115 255 236 4 117 6 127 2 38 0 82 0 0 1 7 3 119 4 199 0 0 0 10 180 3 2 31 17 38 0 43 53 53 255 255 0 125 255 236 5 190 7 209 2 38 0 50 0 0 1 7 3 120 5 125 1 82 0 10 180 3 2 30 5 38 0 43 53 53 255 255 0 97 255 236 4 98 6 127 2 38 0 82 0 0 1 7 3 120 4 199 0 0 0 10 180 3 2 31 17 38 0 43 53 53 255 255 0 125 255 236 5 190 8 74 2 38 0 50 0 0 1 7 3 121 5 123 1 82 0 10 180 3 2 30 5 38 0 43 53 53 255 255 0 115 255 236 4 98 6 248 2 38 0 82 0 0 1 7 3 121 4 199 0 0 0 10 180 3 2 31 17 38 0 43 53 53 255 255 0 125 255 236 5 190 8 98 2 38 0 50 0 0 1 7 3 122 5 121 1 82 0 10 180 3 2 54 5 38 0 43 53 53 255 255 0 115 255 236 4 98 7 16 2 38 0 82 0 0 1 7 3 122 4 197 0 0 0 10 180 3 2 55 17 38 0 43 53 53 255 255 0 125 254 160 5 190 7 115 2 38 0 50 0 0 0 39 2 103 5 127 0 0 1 7 1 75 0 193 1 82 0 8 179 3 49 5 38 0 43 53 255 255 0 115 254 160 4 98 6 33 2 38 0 82 0 0 0 39 2 103 4 205 0 0 1 6 1 75 14 0 0 8 179 3 50 17 38 0 43 53 255 255 0 125 255 236 6 100 7 115 2 38 2 95 0 0 1 7 0 118 1 43 1 82 0 8 179 2 43 5 38 0 43 53 255 255 0 115 255 236 5 25 6 33 2 38 2 96 0 0 1 6 0 118 109 0 0 8 179 2 43 17 38 0 43 53 255 255 0 125 255 236 6 100 7 115 2 38 2 95 0 0 1 7 0 67 0 135 1 82 0 8 179 2 35 5 38 0 43 53 255 255 0 115 255 236 5 25 6 33 2 38 2 96 0 0 1 6 0 67 212 0 0 8 179 2 36 17 38 0 43 53 255 255 0 125 255 236 6 100 7 225 2 38 2 95 0 0 1 7 2 102 5 143 1 82 0 8 179 2 38 5 38 0 43 53 255 255 0 115 255 236 5 25 6 143 2 38 2 96 0 0 1 7 2 102 4 217 0 0 0 8 179 2 39 17 38 0 43 53 255 255 0 125 255 236 6 100 7 47 2 38 2 95 0 0 1 7 1 82 0 160 1 82 0 8 179 2 43 5 38 0 43 53 255 255 0 115 255 236 5 25 5 221 2 38 2 96 0 0 1 6 1 82 245 0 0 8 179 2 35 17 38 0 43 53 255 255 0 125 254 160 6 100 6 20 2 38 2 95 0 0 0 7 2 103 5 123 0 0 255 255 0 115 254 160 5 25 4 240 2 38 2 96 0 0 0 7 2 103 4 201 0 0 255 255 0 186 254 160 5 25 5 182 2 38 0 56 0 0 0 7 2 103 5 74 0 0 255 255 0 164 254 160 4 57 4 72 2 38 0 88 0 0 0 7 2 103 4 184 0 0 255 255 0 186 255 236 5 25 7 225 2 38 0 56 0 0 1 7 2 102 5 84 1 82 0 8 179 1 22 5 38 0 43 53 255 255 0 164 255 236 4 57 6 143 2 38 0 88 0 0 1 7 2 102 4 213 0 0 0 8 179 1 25 17 38 0 43 53 255 255 0 186 255 236 6 123 7 115 2 38 2 97 0 0 1 7 0 118 0 238 1 82 0 8 179 1 37 5 38 0 43 53 255 255 0 164 255 236 5 150 6 33 2 38 2 98 0 0 1 6 0 118 121 0 0 8 179 1 38 17 38 0 43 53 255 255 0 186 255 236 6 123 7 115 2 38 2 97 0 0 1 7 0 67 0 90 1 82 0 8 179 1 29 5 38 0 43 53 255 255 0 164 255 236 5 150 6 33 2 38 2 98 0 0 1 6 0 67 187 0 0 8 179 1 31 17 38 0 43 53 255 255 0 186 255 236 6 123 7 225 2 38 2 97 0 0 1 7 2 102 5 96 1 82 0 8 179 1 32 5 38 0 43 53 255 255 0 164 255 236 5 150 6 143 2 38 2 98 0 0 1 7 2 102 4 219 0 0 0 8 179 1 34 17 38 0 43 53 255 255 0 186 255 236 6 123 7 47 2 38 2 97 0 0 1 7 1 82 0 127 1 82 0 8 179 1 37 5 38 0 43 53 255 255 0 164 255 236 5 150 5 221 2 38 2 98 0 0 1 6 1 82 255 0 0 8 179 1 30 17 38 0 43 53 255 255 0 186 254 160 6 123 6 20 2 38 2 97 0 0 0 7 2 103 5 76 0 0 255 255 0 164 254 160 5 150 4 242 2 38 2 98 0 0 0 7 2 103 4 178 0 0 255 255 0 0 254 160 4 123 5 182 2 38 0 60 0 0 0 7 2 103 4 156 0 0 255 255 0 2 254 20 4 6 4 72 2 38 0 92 0 0 0 7 2 103 5 158 255 253 255 255 0 0 0 0 4 123 7 225 2 38 0 60 0 0 1 7 2 102 4 170 1 82 0 8 179 1 13 5 38 0 43 53 255 255 0 2 254 20 4 6 6 143 2 38 0 92 0 0 1 7 2 102 4 106 0 0 0 8 179 1 26 17 38 0 43 53 255 255 0 0 0 0 4 123 7 47 2 38 0 60 0 0 1 7 1 82 255 194 1 82 0 8 179 1 18 5 38 0 43 53 255 255 0 2 254 20 4 6 5 221 2 38 0 92 0 0 1 6 1 82 138 0 0 8 179 1 31 17 38 0 43 53 255 255 0 115 254 197 4 211 6 20 2 38 0 211 0 0 0 7 0 66 0 180 0 0 0 2 251 229 4 217 254 180 6 33 0 9 0 19 0 30 64 12 4 10 14 14 0 0 21 15 6 128 11 1 0 47 51 26 205 50 17 1 51 17 51 18 57 57 49 48 1 35 38 38 39 53 51 22 22 23 5 35 38 38 39 53 51 22 22 23 254 180 96 52 177 37 186 28 99 49 254 156 96 56 174 37 187 28 99 49 4 217 42 202 63 21 61 174 68 25 44 200 63 21 61 174 68 0 0 2 252 113 4 217 255 174 6 127 0 13 0 21 0 40 64 17 21 0 6 17 17 23 3 6 10 21 10 21 10 17 192 6 1 0 47 51 26 204 57 57 47 47 17 18 57 17 1 51 17 51 57 57 49 48 1 35 38 39 6 7 35 53 55 54 55 51 22 23 39 54 55 51 21 6 7 35 254 211 94 112 99 114 97 94 53 112 52 176 66 151 80 73 54 172 83 120 96 4 217 75 91 101 65 25 60 123 77 94 166 194 91 112 21 110 96 0 0 2 251 154 4 217 254 215 6 127 0 13 0 21 0 42 64 18 6 14 17 17 0 0 23 3 6 10 15 10 15 10 19 192 6 1 0 47 51 26 204 57 57 47 47 17 18 57 17 1 51 17 51 18 57 57 49 48 1 35 38 39 6 7 35 53 55 54 55 51 22 23 37 35 38 39 53 51 22 23 254 215 94 97 114 106 105 94 53 112 52 176 66 151 253 238 95 120 84 172 52 75 4 217 65 101 96 70 23 60 123 77 94 166 172 94 112 21 108 97 0 2 252 113 4 217 255 123 6 248 0 13 0 31 0 52 64 24 16 19 0 19 27 3 6 6 22 14 14 33 3 10 6 18 10 18 10 25 30 192 6 1 0 47 51 26 204 50 57 57 47 47 17 18 57 17 1 51 17 51 51 18 23 57 17 51 49 48 1 35 38 39 6 7 35 53 55 54 55 51 22 23 19 20 7 7 35 39 54 54 53 52 38 35 34 7 53 54 51 50 254 211 94 112 99 114 97 94 53 112 52 176 66 151 168 127 6 80 10 57 63 57 43 46 26 25 55 195 4 217 75 91 101 65 25 60 123 77 94 166 1 123 103 29 81 131 9 32 38 37 25 6 80 6 0 2 252 104 4 217 254 231 7 16 0 23 0 37 0 58 64 27 24 30 9 9 21 21 39 27 30 34 30 25 17 9 0 5 12 34 0 12 12 0 34 3 21 192 25 0 47 26 204 23 57 47 47 47 17 51 16 196 51 17 51 17 18 57 17 1 51 17 51 18 57 57 49 48 1 34 46 2 35 34 6 7 35 54 54 51 50 30 2 51 50 54 55 51 6 6 19 35 38 39 6 7 35 53 55 54 55 51 22 23 254 45 37 71 67 63 28 40 42 14 91 13 101 75 37 73 67 62 27 40 42 12 90 11 99 94 94 97 114 106 105 94 53 112 52 176 66 151 6 53 30 37 30 49 50 106 113 30 36 30 49 49 104 115 254 164 65 101 96 70 23 60 123 77 94 166 0 2 252 121 4 217 254 199 6 193 0 7 0 20 0 36 64 15 7 4 10 10 18 18 22 3 64 7 17 10 128 14 8 0 47 51 26 221 50 212 26 205 17 1 51 17 51 18 57 57 49 48 1 54 55 51 21 6 7 35 19 32 3 51 22 22 51 50 54 55 51 6 6 253 94 80 49 172 86 119 96 62 254 236 15 102 9 76 106 98 86 8 105 11 149 5 244 104 101 21 114 93 254 252 1 4 72 57 65 64 120 140 0 2 252 121 4 217 254 199 6 193 0 7 0 20 0 36 64 15 7 4 10 10 18 18 22 4 64 1 17 10 128 14 8 0 47 51 26 221 50 212 26 205 17 1 51 17 51 18 57 57 49 48 1 35 38 39 53 51 22 23 3 32 3 51 22 22 51 50 54 55 51 6 6 253 209 94 119 86 172 52 75 53 254 236 15 102 9 76 106 98 86 8 105 11 149 5 221 93 114 21 108 97 254 229 1 4 72 57 65 64 120 140 0 2 252 121 4 217 254 199 7 6 0 17 0 30 0 46 64 21 8 0 0 5 13 3 20 20 28 28 32 11 16 4 4 24 24 27 20 128 18 0 47 26 205 50 51 17 57 47 196 50 17 1 51 17 51 18 23 57 17 51 49 48 1 20 7 7 35 39 54 54 53 52 38 35 34 7 53 54 51 50 3 32 3 51 22 22 51 50 54 55 51 6 6 254 49 127 6 82 10 57 66 57 44 37 36 22 62 192 149 254 236 15 102 9 76 106 98 86 8 105 11 149 6 121 100 29 41 90 9 32 37 37 26 6 78 8 253 211 1 4 72 57 65 64 120 140 0 2 252 104 4 217 254 231 7 12 0 23 0 36 0 48 64 21 26 34 9 9 21 38 5 12 12 30 30 24 21 64 17 9 0 33 26 128 24 0 47 26 221 50 214 196 51 26 205 17 51 17 57 47 51 17 1 51 50 17 57 57 49 48 1 34 46 2 35 34 6 7 35 54 54 51 50 30 2 51 50 54 55 51 6 6 3 32 3 51 22 22 51 50 54 55 51 6 6 254 45 37 71 67 63 28 40 42 14 91 13 100 76 37 73 67 62 27 40 42 12 90 11 99 221 254 236 15 102 9 76 106 98 86 8 105 11 149 6 51 30 36 30 48 50 104 113 30 36 30 49 49 103 114 254 166 1 4 72 57 65 64 120 140 0 1 0 49 254 66 1 109 0 0 0 15 0 26 64 11 0 5 5 2 10 3 16 17 13 8 3 0 47 204 50 17 18 1 23 57 17 51 49 48 23 52 39 51 22 21 20 6 35 34 39 53 22 51 50 54 223 139 123 158 102 99 65 50 32 54 37 51 238 103 135 120 132 91 103 16 108 10 48 0 0 1 0 25 254 117 1 113 0 154 0 11 0 24 64 9 10 0 6 0 12 13 8 3 0 0 47 204 50 17 18 1 57 57 17 51 49 48 37 17 16 35 34 39 53 22 51 50 53 17 1 113 228 56 60 41 61 94 154 254 223 254 252 24 140 19 100 1 48 0 0 1 0 25 254 117 1 113 0 143 0 11 0 24 64 9 10 0 6 0 12 13 8 3 0 0 47 204 50 17 18 1 57 57 17 51 49 48 37 17 16 35 34 39 53 22 51 50 53 17 1 113 228 56 60 41 61 94 143 254 234 254 252 24 140 19 100 1 37 0 255 255 0 52 0 0 2 67 5 182 0 7 0 20 255 120 0 0 0 2 0 115 255 236 4 23 4 115 0 11 0 23 0 40 64 20 12 6 18 0 6 0 24 25 9 21 75 89 9 38 3 15 77 89 3 25 0 63 43 0 24 63 43 17 18 1 57 57 17 51 17 51 49 48 1 16 2 35 34 2 17 16 18 51 50 18 1 20 22 51 50 54 53 52 38 35 34 6 4 23 247 222 217 246 249 218 216 249 253 4 155 142 141 158 158 143 141 154 2 47 254 245 254 200 1 53 1 14 1 15 1 53 254 203 254 241 208 232 234 206 204 236 233 0 0 1 0 45 0 0 2 55 4 94 0 10 0 38 64 17 9 1 1 0 8 0 11 12 7 4 7 4 1 9 16 1 24 0 63 63 18 57 57 47 47 17 18 1 57 57 17 51 17 51 49 48 33 35 17 52 55 6 7 7 39 1 51 2 55 161 8 67 62 150 90 1 127 139 2 49 239 140 67 48 112 114 1 35 0 1 0 41 0 0 3 215 4 115 0 25 0 44 64 24 7 19 0 19 23 14 1 5 26 27 16 10 75 89 16 38 24 23 1 23 76 89 1 24 0 63 43 17 0 51 24 63 43 17 18 1 23 57 17 51 49 48 33 33 53 1 62 2 53 52 38 35 34 6 7 39 54 51 50 22 21 20 6 7 5 23 33 3 215 252 82 1 145 157 113 44 139 119 88 156 92 90 192 242 198 218 130 186 254 185 2 2 190 133 1 47 119 104 83 65 87 103 61 74 109 168 168 150 115 187 128 231 6 0 0 1 0 94 254 149 4 27 4 116 0 39 0 71 64 38 3 4 27 0 19 7 7 0 4 22 34 13 6 40 41 4 23 22 23 22 75 89 23 23 10 37 37 30 75 89 37 38 10 17 75 89 10 37 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 0 57 17 18 1 23 57 17 51 17 51 17 51 49 48 1 20 6 7 21 22 22 21 20 4 33 34 38 39 53 22 22 51 32 17 16 33 35 53 51 50 54 53 52 38 35 34 6 7 39 54 54 51 50 22 3 238 157 144 176 170 254 222 254 245 116 193 91 95 215 96 1 123 254 94 144 146 171 200 147 126 96 170 109 84 90 235 130 213 236 3 7 140 178 30 8 22 180 146 209 225 35 44 158 47 49 1 41 1 10 143 151 134 107 122 52 70 112 71 81 195 0 0 2 0 23 254 168 4 102 4 94 0 10 0 18 0 66 64 33 18 5 9 2 2 11 7 3 0 3 5 3 19 20 1 5 18 5 77 89 9 18 14 15 15 7 18 18 3 7 16 3 36 0 63 63 18 57 47 18 57 17 51 17 51 43 17 0 51 17 18 1 23 57 17 51 51 51 17 51 17 51 49 48 37 35 17 35 17 33 53 1 51 17 51 33 17 52 55 35 6 7 1 4 102 217 168 253 50 2 190 184 217 254 134 12 10 41 68 254 57 27 254 141 1 115 125 3 198 252 68 1 92 218 222 86 92 253 158 0 0 1 0 133 254 149 4 29 4 95 0 26 0 58 64 31 15 3 25 20 8 20 23 3 4 28 27 0 17 75 89 0 0 6 21 21 24 76 89 21 16 6 12 75 89 6 37 0 63 43 0 24 63 43 17 18 0 57 24 47 43 17 18 1 23 57 17 51 17 51 49 48 1 50 4 21 20 0 35 34 39 53 22 22 51 50 54 53 16 33 34 7 39 19 33 21 33 3 54 2 45 231 1 9 254 223 254 247 130 70 208 101 176 195 254 137 94 160 86 55 2 215 253 183 37 115 2 38 229 199 227 254 254 79 160 45 51 166 157 1 50 29 55 2 172 153 254 73 23 0 255 255 0 117 255 236 4 47 5 203 2 6 0 25 0 0 0 1 0 94 254 169 4 43 4 95 0 6 0 31 64 16 1 5 5 0 2 3 7 8 3 2 76 89 3 16 0 36 0 63 63 43 17 18 1 23 57 17 51 49 48 1 1 33 53 33 21 1 1 29 2 94 252 227 3 205 253 170 254 169 5 29 153 133 250 207 255 255 0 104 255 236 4 41 5 203 2 6 0 27 0 0 0 2 0 106 254 149 4 37 4 116 0 23 0 37 0 65 64 34 27 17 34 10 10 0 0 4 17 3 38 39 14 30 77 89 10 20 14 14 2 20 20 24 75 89 20 38 2 7 77 89 2 37 0 63 43 0 24 63 43 17 18 0 57 24 47 18 57 43 17 18 1 23 57 17 51 17 51 17 51 49 48 1 16 33 34 39 53 22 51 50 18 19 35 6 6 35 34 38 53 52 18 51 50 22 18 1 34 6 21 20 22 51 50 54 54 53 52 38 38 4 37 253 104 116 68 80 102 240 245 11 12 55 182 114 194 228 255 208 149 223 120 254 20 143 156 144 147 91 153 88 82 147 1 239 252 166 20 143 26 1 41 1 51 83 87 232 208 228 1 8 153 254 219 1 48 184 164 144 165 74 128 70 105 178 102 0 255 255 0 29 0 0 5 196 6 31 0 39 0 73 2 182 0 0 0 6 0 73 0 0 0 2 0 92 2 221 5 170 5 193 0 34 0 51 0 90 64 46 44 48 48 46 42 38 38 40 10 0 28 17 5 17 22 0 40 46 6 53 52 43 49 36 3 45 47 45 41 47 35 35 40 28 10 20 8 3 3 40 41 25 20 20 41 3 0 63 51 47 51 16 205 50 47 51 18 57 57 17 51 17 51 17 51 17 18 23 57 17 18 1 23 57 17 51 17 51 17 51 17 51 17 51 17 51 49 48 1 20 6 35 34 39 53 22 51 50 53 52 38 38 39 38 38 53 52 54 51 50 23 7 38 35 34 6 21 20 22 22 23 22 22 1 3 35 23 17 35 17 51 19 19 51 17 35 17 55 35 3 2 72 149 124 145 74 106 119 148 23 54 85 120 81 142 110 125 92 34 100 83 60 75 18 43 95 129 80 1 166 201 8 6 119 188 195 203 180 127 6 8 211 3 172 98 109 33 108 40 100 33 40 33 31 44 91 76 86 105 39 99 37 46 40 29 36 28 36 50 90 254 236 2 47 129 254 82 2 209 253 209 2 47 253 47 1 164 137 253 211 255 255 0 18 254 20 4 90 5 182 2 38 0 55 0 0 0 7 0 122 1 63 0 0 255 255 0 31 254 20 2 168 5 70 2 38 0 87 0 0 0 7 0 122 0 197 0 0 0 2 0 113 254 20 4 55 4 92 0 12 0 42 0 71 64 38 10 21 26 3 42 42 30 30 36 21 3 43 44 33 39 70 89 36 33 27 28 15 26 15 24 18 24 7 70 89 24 16 18 0 70 89 18 22 0 63 43 0 24 63 43 17 18 0 57 57 24 63 63 51 43 17 18 1 23 57 17 51 17 51 51 17 51 49 48 37 50 54 55 53 52 38 35 34 6 21 20 22 5 52 55 35 6 35 34 2 17 16 18 51 50 23 51 55 51 17 20 6 35 34 39 53 22 22 51 50 54 53 2 76 170 151 4 158 171 144 153 151 1 219 9 11 112 230 217 239 243 211 223 123 11 24 131 236 249 242 149 75 210 118 142 165 119 183 202 43 226 204 224 208 209 217 107 36 99 167 1 45 1 10 1 8 1 49 166 146 251 164 236 236 70 158 42 46 169 146 255 255 0 113 254 20 4 55 6 33 2 38 3 145 0 0 1 6 1 75 6 0 0 8 179 2 57 17 38 0 43 53 255 255 0 113 254 20 4 55 5 229 2 38 3 145 0 0 1 6 1 78 12 0 0 8 179 2 43 17 38 0 43 53 255 255 0 113 254 20 4 55 5 223 2 38 3 145 0 0 1 7 1 79 1 86 0 0 0 8 179 2 52 17 38 0 43 53 255 255 0 113 254 20 4 55 6 33 2 38 3 145 0 0 1 6 2 58 119 0 0 8 179 2 47 17 38 0 43 53 0 1 0 201 0 0 1 115 5 182 0 3 0 17 182 0 4 5 1 3 0 18 0 63 63 17 18 1 57 49 48 51 17 51 17 201 170 5 182 250 74 0 255 255 0 5 0 0 1 142 7 115 2 38 3 150 0 0 1 7 0 67 254 124 1 82 0 8 179 1 5 5 38 0 43 53 255 255 0 179 0 0 2 60 7 115 2 38 3 150 0 0 1 7 0 118 255 42 1 82 0 8 179 1 13 5 38 0 43 53 255 255 255 199 0 0 2 105 7 115 2 38 3 150 0 0 1 7 1 75 254 187 1 82 0 8 179 1 18 5 38 0 43 53 255 255 0 5 0 0 2 56 7 37 2 38 3 150 0 0 1 7 0 106 254 208 1 82 0 10 180 2 1 25 5 38 0 43 53 53 255 255 255 171 0 0 2 147 7 47 2 38 3 150 0 0 1 7 1 82 254 163 1 82 0 8 179 1 13 5 38 0 43 53 255 255 255 243 0 0 2 75 6 180 2 38 3 150 0 0 1 7 1 77 254 198 1 82 0 8 179 1 7 5 38 0 43 53 255 255 255 231 0 0 2 83 7 55 2 38 3 150 0 0 1 7 1 78 254 194 1 82 0 8 179 1 4 5 38 0 43 53 255 255 0 86 254 66 1 162 5 182 2 38 3 150 0 0 0 6 1 81 49 0 255 255 0 187 0 0 1 127 7 49 2 38 3 150 0 0 1 7 1 79 0 25 1 82 0 8 179 1 13 5 38 0 43 53 255 255 0 201 254 127 3 163 5 182 0 38 3 150 0 0 0 7 0 45 2 59 0 0 255 255 255 228 0 0 2 29 6 10 0 39 3 150 0 170 0 0 1 7 1 84 253 232 255 151 0 7 178 1 8 0 0 63 53 0 255 255 0 201 0 0 1 115 5 182 2 6 3 150 0 0 255 255 0 5 0 0 2 56 7 37 2 38 3 150 0 0 1 7 0 106 254 208 1 82 0 10 180 2 1 25 5 38 0 43 53 53 255 255 0 201 0 0 1 115 5 182 2 6 3 150 0 0 255 255 0 5 0 0 2 56 7 37 2 38 3 150 0 0 1 7 0 106 254 208 1 82 0 10 180 2 1 25 5 38 0 43 53 53 255 255 0 201 0 0 1 115 5 182 2 6 3 150 0 0 255 255 0 201 0 0 1 115 5 182 2 6 3 150 0 0 255 255 0 153 0 0 2 4 7 225 2 38 3 150 0 0 1 7 2 102 3 145 1 82 0 8 179 1 8 5 38 0 43 53 255 255 0 184 254 160 1 127 5 182 2 38 3 150 0 0 0 7 2 103 3 125 0 0 0 0 0 1 0 0 182 50 0 1 73 6 128 0 0 14 54 36 0 5 0 36 255 113 0 5 0 55 0 41 0 5 0 57 0 41 0 5 0 58 0 41 0 5 0 60 0 20 0 5 0 68 255 174 0 5 0 70 255 133 0 5 0 71 255 133 0 5 0 72 255 133 0 5 0 74 255 195 0 5 0 80 255 195 0 5 0 81 255 195 0 5 0 82 255 133 0 5 0 83 255 195 0 5 0 84 255 133 0 5 0 85 255 195 0 5 0 86 255 195 0 5 0 88 255 195 0 5 0 130 255 113 0 5 0 131 255 113 0 5 0 132 255 113 0 5 0 133 255 113 0 5 0 134 255 113 0 5 0 135 255 113 0 5 0 159 0 20 0 5 0 162 255 133 0 5 0 163 255 174 0 5 0 164 255 174 0 5 0 165 255 174 0 5 0 166 255 174 0 5 0 167 255 174 0 5 0 168 255 174 0 5 0 169 255 133 0 5 0 170 255 133 0 5 0 171 255 133 0 5 0 172 255 133 0 5 0 173 255 133 0 5 0 180 255 133 0 5 0 181 255 133 0 5 0 182 255 133 0 5 0 183 255 133 0 5 0 184 255 133 0 5 0 186 255 133 0 5 0 187 255 195 0 5 0 188 255 195 0 5 0 189 255 195 0 5 0 190 255 195 0 5 0 194 255 113 0 5 0 195 255 174 0 5 0 196 255 113 0 5 0 197 255 174 0 5 0 198 255 113 0 5 0 199 255 174 0 5 0 201 255 133 0 5 0 203 255 133 0 5 0 205 255 133 0 5 0 207 255 133 0 5 0 209 255 133 0 5 0 211 255 133 0 5 0 213 255 133 0 5 0 215 255 133 0 5 0 217 255 133 0 5 0 219 255 133 0 5 0 221 255 133 0 5 0 223 255 195 0 5 0 225 255 195 0 5 0 227 255 195 0 5 0 229 255 195 0 5 0 250 255 195 0 5 1 6 255 195 0 5 1 8 255 195 0 5 1 13 255 195 0 5 1 15 255 133 0 5 1 17 255 133 0 5 1 19 255 133 0 5 1 21 255 133 0 5 1 23 255 195 0 5 1 25 255 195 0 5 1 29 255 195 0 5 1 33 255 195 0 5 1 36 0 41 0 5 1 38 0 41 0 5 1 43 255 195 0 5 1 45 255 195 0 5 1 47 255 195 0 5 1 49 255 195 0 5 1 51 255 195 0 5 1 53 255 195 0 5 1 54 0 41 0 5 1 56 0 20 0 5 1 58 0 20 0 5 1 67 255 113 0 5 1 68 255 174 0 5 1 70 255 174 0 5 1 72 255 133 0 5 1 74 255 195 0 5 1 86 255 113 0 5 1 95 255 113 0 5 1 98 255 113 0 5 1 105 255 113 0 5 1 121 255 174 0 5 1 122 255 215 0 5 1 123 255 215 0 5 1 126 255 174 0 5 1 129 255 195 0 5 1 130 255 215 0 5 1 131 255 215 0 5 1 132 255 215 0 5 1 135 255 215 0 5 1 137 255 215 0 5 1 140 255 174 0 5 1 142 255 195 0 5 1 143 255 174 0 5 1 144 255 174 0 5 1 147 255 174 0 5 1 153 255 174 0 5 1 164 255 133 0 5 1 170 255 113 0 5 1 174 255 133 0 5 1 181 255 133 0 5 1 202 255 215 0 5 1 206 255 113 0 5 1 207 255 133 0 5 1 213 255 113 0 5 1 216 255 133 0 5 1 219 255 133 0 5 1 222 255 133 0 5 1 234 255 133 0 5 1 237 255 133 0 5 1 238 255 195 0 5 1 242 255 113 0 5 1 250 0 41 0 5 1 252 0 41 0 5 1 254 0 41 0 5 2 0 0 20 0 5 2 87 255 195 0 5 2 88 255 113 0 5 2 89 255 174 0 5 2 96 255 133 0 5 2 98 255 195 0 5 2 106 255 133 0 5 2 114 255 113 0 5 2 115 255 113 0 5 2 125 255 236 0 5 2 127 255 133 0 5 2 133 255 133 0 5 2 135 255 133 0 5 2 137 255 133 0 5 2 141 255 133 0 5 2 178 255 133 0 5 2 180 255 133 0 5 2 206 255 133 0 5 2 207 255 113 0 5 2 217 255 113 0 5 2 218 255 215 0 5 2 219 255 113 0 5 2 220 255 215 0 5 2 221 255 113 0 5 2 222 255 215 0 5 2 224 255 133 0 5 2 226 255 215 0 5 2 228 255 215 0 5 2 240 255 133 0 5 2 242 255 133 0 5 2 244 255 133 0 5 3 9 255 113 0 5 3 10 255 133 0 5 3 11 255 113 0 5 3 12 255 133 0 5 3 17 255 133 0 5 3 18 255 113 0 5 3 22 255 133 0 5 3 26 255 133 0 5 3 27 255 133 0 5 3 28 255 113 0 5 3 29 255 113 0 5 3 30 255 174 0 5 3 31 255 113 0 5 3 32 255 174 0 5 3 33 255 113 0 5 3 34 255 174 0 5 3 35 255 113 0 5 3 37 255 113 0 5 3 38 255 174 0 5 3 39 255 113 0 5 3 40 255 174 0 5 3 41 255 113 0 5 3 42 255 174 0 5 3 43 255 113 0 5 3 44 255 174 0 5 3 45 255 113 0 5 3 46 255 174 0 5 3 47 255 113 0 5 3 48 255 174 0 5 3 49 255 113 0 5 3 50 255 174 0 5 3 51 255 113 0 5 3 52 255 174 0 5 3 54 255 133 0 5 3 56 255 133 0 5 3 58 255 133 0 5 3 60 255 133 0 5 3 64 255 133 0 5 3 66 255 133 0 5 3 68 255 133 0 5 3 74 255 133 0 5 3 76 255 133 0 5 3 78 255 133 0 5 3 82 255 133 0 5 3 84 255 133 0 5 3 86 255 133 0 5 3 88 255 133 0 5 3 90 255 133 0 5 3 92 255 133 0 5 3 94 255 133 0 5 3 96 255 133 0 5 3 98 255 195 0 5 3 100 255 195 0 5 3 102 255 195 0 5 3 104 255 195 0 5 3 106 255 195 0 5 3 108 255 195 0 5 3 110 255 195 0 5 3 111 0 20 0 5 3 113 0 20 0 5 3 115 0 20 0 5 3 143 0 41 0 10 0 36 255 113 0 10 0 55 0 41 0 10 0 57 0 41 0 10 0 58 0 41 0 10 0 60 0 20 0 10 0 68 255 174 0 10 0 70 255 133 0 10 0 71 255 133 0 10 0 72 255 133 0 10 0 74 255 195 0 10 0 80 255 195 0 10 0 81 255 195 0 10 0 82 255 133 0 10 0 83 255 195 0 10 0 84 255 133 0 10 0 85 255 195 0 10 0 86 255 195 0 10 0 88 255 195 0 10 0 130 255 113 0 10 0 131 255 113 0 10 0 132 255 113 0 10 0 133 255 113 0 10 0 134 255 113 0 10 0 135 255 113 0 10 0 159 0 20 0 10 0 162 255 133 0 10 0 163 255 174 0 10 0 164 255 174 0 10 0 165 255 174 0 10 0 166 255 174 0 10 0 167 255 174 0 10 0 168 255 174 0 10 0 169 255 133 0 10 0 170 255 133 0 10 0 171 255 133 0 10 0 172 255 133 0 10 0 173 255 133 0 10 0 180 255 133 0 10 0 181 255 133 0 10 0 182 255 133 0 10 0 183 255 133 0 10 0 184 255 133 0 10 0 186 255 133 0 10 0 187 255 195 0 10 0 188 255 195 0 10 0 189 255 195 0 10 0 190 255 195 0 10 0 194 255 113 0 10 0 195 255 174 0 10 0 196 255 113 0 10 0 197 255 174 0 10 0 198 255 113 0 10 0 199 255 174 0 10 0 201 255 133 0 10 0 203 255 133 0 10 0 205 255 133 0 10 0 207 255 133 0 10 0 209 255 133 0 10 0 211 255 133 0 10 0 213 255 133 0 10 0 215 255 133 0 10 0 217 255 133 0 10 0 219 255 133 0 10 0 221 255 133 0 10 0 223 255 195 0 10 0 225 255 195 0 10 0 227 255 195 0 10 0 229 255 195 0 10 0 250 255 195 0 10 1 6 255 195 0 10 1 8 255 195 0 10 1 13 255 195 0 10 1 15 255 133 0 10 1 17 255 133 0 10 1 19 255 133 0 10 1 21 255 133 0 10 1 23 255 195 0 10 1 25 255 195 0 10 1 29 255 195 0 10 1 33 255 195 0 10 1 36 0 41 0 10 1 38 0 41 0 10 1 43 255 195 0 10 1 45 255 195 0 10 1 47 255 195 0 10 1 49 255 195 0 10 1 51 255 195 0 10 1 53 255 195 0 10 1 54 0 41 0 10 1 56 0 20 0 10 1 58 0 20 0 10 1 67 255 113 0 10 1 68 255 174 0 10 1 70 255 174 0 10 1 72 255 133 0 10 1 74 255 195 0 10 1 86 255 113 0 10 1 95 255 113 0 10 1 98 255 113 0 10 1 105 255 113 0 10 1 121 255 174 0 10 1 122 255 215 0 10 1 123 255 215 0 10 1 126 255 174 0 10 1 129 255 195 0 10 1 130 255 215 0 10 1 131 255 215 0 10 1 132 255 215 0 10 1 135 255 215 0 10 1 137 255 215 0 10 1 140 255 174 0 10 1 142 255 195 0 10 1 143 255 174 0 10 1 144 255 174 0 10 1 147 255 174 0 10 1 153 255 174 0 10 1 164 255 133 0 10 1 170 255 113 0 10 1 174 255 133 0 10 1 181 255 133 0 10 1 202 255 215 0 10 1 206 255 113 0 10 1 207 255 133 0 10 1 213 255 113 0 10 1 216 255 133 0 10 1 219 255 133 0 10 1 222 255 133 0 10 1 234 255 133 0 10 1 237 255 133 0 10 1 238 255 195 0 10 1 242 255 113 0 10 1 250 0 41 0 10 1 252 0 41 0 10 1 254 0 41 0 10 2 0 0 20 0 10 2 87 255 195 0 10 2 88 255 113 0 10 2 89 255 174 0 10 2 96 255 133 0 10 2 98 255 195 0 10 2 106 255 133 0 10 2 114 255 113 0 10 2 115 255 113 0 10 2 125 255 236 0 10 2 127 255 133 0 10 2 133 255 133 0 10 2 135 255 133 0 10 2 137 255 133 0 10 2 141 255 133 0 10 2 178 255 133 0 10 2 180 255 133 0 10 2 206 255 133 0 10 2 207 255 113 0 10 2 217 255 113 0 10 2 218 255 215 0 10 2 219 255 113 0 10 2 220 255 215 0 10 2 221 255 113 0 10 2 222 255 215 0 10 2 224 255 133 0 10 2 226 255 215 0 10 2 228 255 215 0 10 2 240 255 133 0 10 2 242 255 133 0 10 2 244 255 133 0 10 3 9 255 113 0 10 3 10 255 133 0 10 3 11 255 113 0 10 3 12 255 133 0 10 3 17 255 133 0 10 3 18 255 113 0 10 3 22 255 133 0 10 3 26 255 133 0 10 3 27 255 133 0 10 3 28 255 113 0 10 3 29 255 113 0 10 3 30 255 174 0 10 3 31 255 113 0 10 3 32 255 174 0 10 3 33 255 113 0 10 3 34 255 174 0 10 3 35 255 113 0 10 3 37 255 113 0 10 3 38 255 174 0 10 3 39 255 113 0 10 3 40 255 174 0 10 3 41 255 113 0 10 3 42 255 174 0 10 3 43 255 113 0 10 3 44 255 174 0 10 3 45 255 113 0 10 3 46 255 174 0 10 3 47 255 113 0 10 3 48 255 174 0 10 3 49 255 113 0 10 3 50 255 174 0 10 3 51 255 113 0 10 3 52 255 174 0 10 3 54 255 133 0 10 3 56 255 133 0 10 3 58 255 133 0 10 3 60 255 133 0 10 3 64 255 133 0 10 3 66 255 133 0 10 3 68 255 133 0 10 3 74 255 133 0 10 3 76 255 133 0 10 3 78 255 133 0 10 3 82 255 133 0 10 3 84 255 133 0 10 3 86 255 133 0 10 3 88 255 133 0 10 3 90 255 133 0 10 3 92 255 133 0 10 3 94 255 133 0 10 3 96 255 133 0 10 3 98 255 195 0 10 3 100 255 195 0 10 3 102 255 195 0 10 3 104 255 195 0 10 3 106 255 195 0 10 3 108 255 195 0 10 3 110 255 195 0 10 3 111 0 20 0 10 3 113 0 20 0 10 3 115 0 20 0 10 3 143 0 41 0 11 0 45 0 184 0 15 0 38 255 154 0 15 0 42 255 154 0 15 0 50 255 154 0 15 0 52 255 154 0 15 0 55 255 113 0 15 0 56 255 215 0 15 0 57 255 133 0 15 0 58 255 133 0 15 0 60 255 133 0 15 0 137 255 154 0 15 0 148 255 154 0 15 0 149 255 154 0 15 0 150 255 154 0 15 0 151 255 154 0 15 0 152 255 154 0 15 0 154 255 154 0 15 0 155 255 215 0 15 0 156 255 215 0 15 0 157 255 215 0 15 0 158 255 215 0 15 0 159 255 133 0 15 0 200 255 154 0 15 0 202 255 154 0 15 0 204 255 154 0 15 0 206 255 154 0 15 0 222 255 154 0 15 0 224 255 154 0 15 0 226 255 154 0 15 0 228 255 154 0 15 1 14 255 154 0 15 1 16 255 154 0 15 1 18 255 154 0 15 1 20 255 154 0 15 1 36 255 113 0 15 1 38 255 113 0 15 1 42 255 215 0 15 1 44 255 215 0 15 1 46 255 215 0 15 1 48 255 215 0 15 1 50 255 215 0 15 1 52 255 215 0 15 1 54 255 133 0 15 1 56 255 133 0 15 1 58 255 133 0 15 1 71 255 154 0 15 1 102 255 174 0 15 1 109 255 174 0 15 1 113 255 113 0 15 1 114 255 133 0 15 1 115 255 154 0 15 1 117 255 133 0 15 1 120 255 133 0 15 1 133 255 215 0 15 1 157 255 113 0 15 1 159 255 154 0 15 1 166 255 113 0 15 1 184 255 154 0 15 1 187 255 154 0 15 1 188 255 113 0 15 1 190 255 174 0 15 1 193 255 92 0 15 1 196 255 113 0 15 1 220 255 154 0 15 1 225 255 133 0 15 1 228 255 154 0 15 1 250 255 133 0 15 1 252 255 133 0 15 1 254 255 133 0 15 2 0 255 133 0 15 2 84 255 133 0 15 2 95 255 154 0 15 2 97 255 215 0 15 2 108 255 154 0 15 2 124 255 92 0 15 2 126 255 154 0 15 2 128 255 133 0 15 2 130 255 133 0 15 2 132 255 154 0 15 2 134 255 154 0 15 2 136 255 154 0 15 2 138 255 154 0 15 2 140 255 154 0 15 2 169 255 113 0 15 2 170 255 154 0 15 2 177 255 154 0 15 2 179 255 154 0 15 2 181 255 113 0 15 2 182 255 154 0 15 2 183 255 133 0 15 2 185 255 133 0 15 2 189 255 113 0 15 2 190 255 154 0 15 2 191 255 92 0 15 2 192 255 133 0 15 2 193 255 92 0 15 2 194 255 133 0 15 2 197 255 133 0 15 2 199 255 133 0 15 2 212 255 92 0 15 2 213 255 133 0 15 2 239 255 154 0 15 2 241 255 154 0 15 2 243 255 154 0 15 2 253 255 92 0 15 2 254 255 133 0 15 3 13 255 133 0 15 3 14 255 154 0 15 3 15 255 133 0 15 3 16 255 154 0 15 3 21 255 154 0 15 3 23 255 113 0 15 3 24 255 154 0 15 3 73 255 154 0 15 3 75 255 154 0 15 3 77 255 154 0 15 3 79 255 154 0 15 3 81 255 154 0 15 3 83 255 154 0 15 3 85 255 154 0 15 3 87 255 154 0 15 3 89 255 154 0 15 3 91 255 154 0 15 3 93 255 154 0 15 3 95 255 154 0 15 3 97 255 215 0 15 3 99 255 215 0 15 3 101 255 215 0 15 3 103 255 215 0 15 3 105 255 215 0 15 3 107 255 215 0 15 3 109 255 215 0 15 3 111 255 133 0 15 3 113 255 133 0 15 3 115 255 133 0 15 3 143 255 113 0 16 0 55 255 174 0 16 1 36 255 174 0 16 1 38 255 174 0 16 1 113 255 174 0 16 1 157 255 174 0 16 1 166 255 174 0 16 1 188 255 174 0 16 1 196 255 174 0 16 1 220 255 215 0 16 1 228 255 215 0 16 2 169 255 174 0 16 2 170 255 215 0 16 2 181 255 174 0 16 2 182 255 215 0 16 2 189 255 174 0 16 2 190 255 215 0 16 3 23 255 174 0 16 3 24 255 215 0 16 3 143 255 174 0 17 0 38 255 154 0 17 0 42 255 154 0 17 0 50 255 154 0 17 0 52 255 154 0 17 0 55 255 113 0 17 0 56 255 215 0 17 0 57 255 133 0 17 0 58 255 133 0 17 0 60 255 133 0 17 0 137 255 154 0 17 0 148 255 154 0 17 0 149 255 154 0 17 0 150 255 154 0 17 0 151 255 154 0 17 0 152 255 154 0 17 0 154 255 154 0 17 0 155 255 215 0 17 0 156 255 215 0 17 0 157 255 215 0 17 0 158 255 215 0 17 0 159 255 133 0 17 0 200 255 154 0 17 0 202 255 154 0 17 0 204 255 154 0 17 0 206 255 154 0 17 0 222 255 154 0 17 0 224 255 154 0 17 0 226 255 154 0 17 0 228 255 154 0 17 1 14 255 154 0 17 1 16 255 154 0 17 1 18 255 154 0 17 1 20 255 154 0 17 1 36 255 113 0 17 1 38 255 113 0 17 1 42 255 215 0 17 1 44 255 215 0 17 1 46 255 215 0 17 1 48 255 215 0 17 1 50 255 215 0 17 1 52 255 215 0 17 1 54 255 133 0 17 1 56 255 133 0 17 1 58 255 133 0 17 1 71 255 154 0 17 1 102 255 174 0 17 1 109 255 174 0 17 1 113 255 113 0 17 1 114 255 133 0 17 1 115 255 154 0 17 1 117 255 133 0 17 1 120 255 133 0 17 1 133 255 215 0 17 1 157 255 113 0 17 1 159 255 154 0 17 1 166 255 113 0 17 1 184 255 154 0 17 1 187 255 154 0 17 1 188 255 113 0 17 1 190 255 174 0 17 1 193 255 92 0 17 1 196 255 113 0 17 1 220 255 154 0 17 1 225 255 133 0 17 1 228 255 154 0 17 1 250 255 133 0 17 1 252 255 133 0 17 1 254 255 133 0 17 2 0 255 133 0 17 2 84 255 133 0 17 2 95 255 154 0 17 2 97 255 215 0 17 2 108 255 154 0 17 2 124 255 92 0 17 2 126 255 154 0 17 2 128 255 133 0 17 2 130 255 133 0 17 2 132 255 154 0 17 2 134 255 154 0 17 2 136 255 154 0 17 2 138 255 154 0 17 2 140 255 154 0 17 2 169 255 113 0 17 2 170 255 154 0 17 2 177 255 154 0 17 2 179 255 154 0 17 2 181 255 113 0 17 2 182 255 154 0 17 2 183 255 133 0 17 2 185 255 133 0 17 2 189 255 113 0 17 2 190 255 154 0 17 2 191 255 92 0 17 2 192 255 133 0 17 2 193 255 92 0 17 2 194 255 133 0 17 2 197 255 133 0 17 2 199 255 133 0 17 2 212 255 92 0 17 2 213 255 133 0 17 2 239 255 154 0 17 2 241 255 154 0 17 2 243 255 154 0 17 2 253 255 92 0 17 2 254 255 133 0 17 3 13 255 133 0 17 3 14 255 154 0 17 3 15 255 133 0 17 3 16 255 154 0 17 3 21 255 154 0 17 3 23 255 113 0 17 3 24 255 154 0 17 3 73 255 154 0 17 3 75 255 154 0 17 3 77 255 154 0 17 3 79 255 154 0 17 3 81 255 154 0 17 3 83 255 154 0 17 3 85 255 154 0 17 3 87 255 154 0 17 3 89 255 154 0 17 3 91 255 154 0 17 3 93 255 154 0 17 3 95 255 154 0 17 3 97 255 215 0 17 3 99 255 215 0 17 3 101 255 215 0 17 3 103 255 215 0 17 3 105 255 215 0 17 3 107 255 215 0 17 3 109 255 215 0 17 3 111 255 133 0 17 3 113 255 133 0 17 3 115 255 133 0 17 3 143 255 113 0 36 0 5 255 113 0 36 0 10 255 113 0 36 0 38 255 215 0 36 0 42 255 215 0 36 0 45 1 10 0 36 0 50 255 215 0 36 0 52 255 215 0 36 0 55 255 113 0 36 0 57 255 174 0 36 0 58 255 174 0 36 0 60 255 133 0 36 0 137 255 215 0 36 0 148 255 215 0 36 0 149 255 215 0 36 0 150 255 215 0 36 0 151 255 215 0 36 0 152 255 215 0 36 0 154 255 215 0 36 0 159 255 133 0 36 0 200 255 215 0 36 0 202 255 215 0 36 0 204 255 215 0 36 0 206 255 215 0 36 0 222 255 215 0 36 0 224 255 215 0 36 0 226 255 215 0 36 0 228 255 215 0 36 1 14 255 215 0 36 1 16 255 215 0 36 1 18 255 215 0 36 1 20 255 215 0 36 1 36 255 113 0 36 1 38 255 113 0 36 1 54 255 174 0 36 1 56 255 133 0 36 1 58 255 133 0 36 1 71 255 215 0 36 1 250 255 174 0 36 1 252 255 174 0 36 1 254 255 174 0 36 2 0 255 133 0 36 2 7 255 113 0 36 2 11 255 113 0 36 2 95 255 215 0 36 3 73 255 215 0 36 3 75 255 215 0 36 3 77 255 215 0 36 3 79 255 215 0 36 3 81 255 215 0 36 3 83 255 215 0 36 3 85 255 215 0 36 3 87 255 215 0 36 3 89 255 215 0 36 3 91 255 215 0 36 3 93 255 215 0 36 3 95 255 215 0 36 3 111 255 133 0 36 3 113 255 133 0 36 3 115 255 133 0 36 3 143 255 113 0 37 0 15 255 174 0 37 0 17 255 174 0 37 0 36 255 215 0 37 0 55 255 195 0 37 0 57 255 236 0 37 0 58 255 236 0 37 0 59 255 215 0 37 0 60 255 236 0 37 0 61 255 236 0 37 0 130 255 215 0 37 0 131 255 215 0 37 0 132 255 215 0 37 0 133 255 215 0 37 0 134 255 215 0 37 0 135 255 215 0 37 0 159 255 236 0 37 0 194 255 215 0 37 0 196 255 215 0 37 0 198 255 215 0 37 1 36 255 195 0 37 1 38 255 195 0 37 1 54 255 236 0 37 1 56 255 236 0 37 1 58 255 236 0 37 1 59 255 236 0 37 1 61 255 236 0 37 1 63 255 236 0 37 1 67 255 215 0 37 1 160 255 236 0 37 1 250 255 236 0 37 1 252 255 236 0 37 1 254 255 236 0 37 2 0 255 236 0 37 2 8 255 174 0 37 2 12 255 174 0 37 2 88 255 215 0 37 3 29 255 215 0 37 3 31 255 215 0 37 3 33 255 215 0 37 3 35 255 215 0 37 3 37 255 215 0 37 3 39 255 215 0 37 3 41 255 215 0 37 3 43 255 215 0 37 3 45 255 215 0 37 3 47 255 215 0 37 3 49 255 215 0 37 3 51 255 215 0 37 3 111 255 236 0 37 3 113 255 236 0 37 3 115 255 236 0 37 3 143 255 195 0 38 0 38 255 215 0 38 0 42 255 215 0 38 0 50 255 215 0 38 0 52 255 215 0 38 0 137 255 215 0 38 0 148 255 215 0 38 0 149 255 215 0 38 0 150 255 215 0 38 0 151 255 215 0 38 0 152 255 215 0 38 0 154 255 215 0 38 0 200 255 215 0 38 0 202 255 215 0 38 0 204 255 215 0 38 0 206 255 215 0 38 0 222 255 215 0 38 0 224 255 215 0 38 0 226 255 215 0 38 0 228 255 215 0 38 1 14 255 215 0 38 1 16 255 215 0 38 1 18 255 215 0 38 1 20 255 215 0 38 1 71 255 215 0 38 2 95 255 215 0 38 3 73 255 215 0 38 3 75 255 215 0 38 3 77 255 215 0 38 3 79 255 215 0 38 3 81 255 215 0 38 3 83 255 215 0 38 3 85 255 215 0 38 3 87 255 215 0 38 3 89 255 215 0 38 3 91 255 215 0 38 3 93 255 215 0 38 3 95 255 215 0 39 0 15 255 174 0 39 0 17 255 174 0 39 0 36 255 215 0 39 0 55 255 195 0 39 0 57 255 236 0 39 0 58 255 236 0 39 0 59 255 215 0 39 0 60 255 236 0 39 0 61 255 236 0 39 0 130 255 215 0 39 0 131 255 215 0 39 0 132 255 215 0 39 0 133 255 215 0 39 0 134 255 215 0 39 0 135 255 215 0 39 0 159 255 236 0 39 0 194 255 215 0 39 0 196 255 215 0 39 0 198 255 215 0 39 1 36 255 195 0 39 1 38 255 195 0 39 1 54 255 236 0 39 1 56 255 236 0 39 1 58 255 236 0 39 1 59 255 236 0 39 1 61 255 236 0 39 1 63 255 236 0 39 1 67 255 215 0 39 1 160 255 236 0 39 1 250 255 236 0 39 1 252 255 236 0 39 1 254 255 236 0 39 2 0 255 236 0 39 2 8 255 174 0 39 2 12 255 174 0 39 2 88 255 215 0 39 3 29 255 215 0 39 3 31 255 215 0 39 3 33 255 215 0 39 3 35 255 215 0 39 3 37 255 215 0 39 3 39 255 215 0 39 3 41 255 215 0 39 3 43 255 215 0 39 3 45 255 215 0 39 3 47 255 215 0 39 3 49 255 215 0 39 3 51 255 215 0 39 3 111 255 236 0 39 3 113 255 236 0 39 3 115 255 236 0 39 3 143 255 195 0 40 0 45 0 123 0 41 0 15 255 133 0 41 0 17 255 133 0 41 0 34 0 41 0 41 0 36 255 215 0 41 0 130 255 215 0 41 0 131 255 215 0 41 0 132 255 215 0 41 0 133 255 215 0 41 0 134 255 215 0 41 0 135 255 215 0 41 0 194 255 215 0 41 0 196 255 215 0 41 0 198 255 215 0 41 1 67 255 215 0 41 2 8 255 133 0 41 2 12 255 133 0 41 2 88 255 215 0 41 3 29 255 215 0 41 3 31 255 215 0 41 3 33 255 215 0 41 3 35 255 215 0 41 3 37 255 215 0 41 3 39 255 215 0 41 3 41 255 215 0 41 3 43 255 215 0 41 3 45 255 215 0 41 3 47 255 215 0 41 3 49 255 215 0 41 3 51 255 215 0 46 0 38 255 215 0 46 0 42 255 215 0 46 0 50 255 215 0 46 0 52 255 215 0 46 0 137 255 215 0 46 0 148 255 215 0 46 0 149 255 215 0 46 0 150 255 215 0 46 0 151 255 215 0 46 0 152 255 215 0 46 0 154 255 215 0 46 0 200 255 215 0 46 0 202 255 215 0 46 0 204 255 215 0 46 0 206 255 215 0 46 0 222 255 215 0 46 0 224 255 215 0 46 0 226 255 215 0 46 0 228 255 215 0 46 1 14 255 215 0 46 1 16 255 215 0 46 1 18 255 215 0 46 1 20 255 215 0 46 1 71 255 215 0 46 2 95 255 215 0 46 3 73 255 215 0 46 3 75 255 215 0 46 3 77 255 215 0 46 3 79 255 215 0 46 3 81 255 215 0 46 3 83 255 215 0 46 3 85 255 215 0 46 3 87 255 215 0 46 3 89 255 215 0 46 3 91 255 215 0 46 3 93 255 215 0 46 3 95 255 215 0 47 0 5 255 92 0 47 0 10 255 92 0 47 0 38 255 215 0 47 0 42 255 215 0 47 0 50 255 215 0 47 0 52 255 215 0 47 0 55 255 215 0 47 0 56 255 236 0 47 0 57 255 215 0 47 0 58 255 215 0 47 0 60 255 195 0 47 0 137 255 215 0 47 0 148 255 215 0 47 0 149 255 215 0 47 0 150 255 215 0 47 0 151 255 215 0 47 0 152 255 215 0 47 0 154 255 215 0 47 0 155 255 236 0 47 0 156 255 236 0 47 0 157 255 236 0 47 0 158 255 236 0 47 0 159 255 195 0 47 0 200 255 215 0 47 0 202 255 215 0 47 0 204 255 215 0 47 0 206 255 215 0 47 0 222 255 215 0 47 0 224 255 215 0 47 0 226 255 215 0 47 0 228 255 215 0 47 1 14 255 215 0 47 1 16 255 215 0 47 1 18 255 215 0 47 1 20 255 215 0 47 1 36 255 215 0 47 1 38 255 215 0 47 1 42 255 236 0 47 1 44 255 236 0 47 1 46 255 236 0 47 1 48 255 236 0 47 1 50 255 236 0 47 1 52 255 236 0 47 1 54 255 215 0 47 1 56 255 195 0 47 1 58 255 195 0 47 1 71 255 215 0 47 1 250 255 215 0 47 1 252 255 215 0 47 1 254 255 215 0 47 2 0 255 195 0 47 2 7 255 92 0 47 2 11 255 92 0 47 2 95 255 215 0 47 2 97 255 236 0 47 3 73 255 215 0 47 3 75 255 215 0 47 3 77 255 215 0 47 3 79 255 215 0 47 3 81 255 215 0 47 3 83 255 215 0 47 3 85 255 215 0 47 3 87 255 215 0 47 3 89 255 215 0 47 3 91 255 215 0 47 3 93 255 215 0 47 3 95 255 215 0 47 3 97 255 236 0 47 3 99 255 236 0 47 3 101 255 236 0 47 3 103 255 236 0 47 3 105 255 236 0 47 3 107 255 236 0 47 3 109 255 236 0 47 3 111 255 195 0 47 3 113 255 195 0 47 3 115 255 195 0 47 3 143 255 215 0 50 0 15 255 174 0 50 0 17 255 174 0 50 0 36 255 215 0 50 0 55 255 195 0 50 0 57 255 236 0 50 0 58 255 236 0 50 0 59 255 215 0 50 0 60 255 236 0 50 0 61 255 236 0 50 0 130 255 215 0 50 0 131 255 215 0 50 0 132 255 215 0 50 0 133 255 215 0 50 0 134 255 215 0 50 0 135 255 215 0 50 0 159 255 236 0 50 0 194 255 215 0 50 0 196 255 215 0 50 0 198 255 215 0 50 1 36 255 195 0 50 1 38 255 195 0 50 1 54 255 236 0 50 1 56 255 236 0 50 1 58 255 236 0 50 1 59 255 236 0 50 1 61 255 236 0 50 1 63 255 236 0 50 1 67 255 215 0 50 1 160 255 236 0 50 1 250 255 236 0 50 1 252 255 236 0 50 1 254 255 236 0 50 2 0 255 236 0 50 2 8 255 174 0 50 2 12 255 174 0 50 2 88 255 215 0 50 3 29 255 215 0 50 3 31 255 215 0 50 3 33 255 215 0 50 3 35 255 215 0 50 3 37 255 215 0 50 3 39 255 215 0 50 3 41 255 215 0 50 3 43 255 215 0 50 3 45 255 215 0 50 3 47 255 215 0 50 3 49 255 215 0 50 3 51 255 215 0 50 3 111 255 236 0 50 3 113 255 236 0 50 3 115 255 236 0 50 3 143 255 195 0 51 0 15 254 246 0 51 0 17 254 246 0 51 0 36 255 154 0 51 0 59 255 215 0 51 0 61 255 236 0 51 0 130 255 154 0 51 0 131 255 154 0 51 0 132 255 154 0 51 0 133 255 154 0 51 0 134 255 154 0 51 0 135 255 154 0 51 0 194 255 154 0 51 0 196 255 154 0 51 0 198 255 154 0 51 1 59 255 236 0 51 1 61 255 236 0 51 1 63 255 236 0 51 1 67 255 154 0 51 2 8 254 246 0 51 2 12 254 246 0 51 2 88 255 154 0 51 3 29 255 154 0 51 3 31 255 154 0 51 3 33 255 154 0 51 3 35 255 154 0 51 3 37 255 154 0 51 3 39 255 154 0 51 3 41 255 154 0 51 3 43 255 154 0 51 3 45 255 154 0 51 3 47 255 154 0 51 3 49 255 154 0 51 3 51 255 154 0 52 0 15 255 174 0 52 0 17 255 174 0 52 0 36 255 215 0 52 0 55 255 195 0 52 0 57 255 236 0 52 0 58 255 236 0 52 0 59 255 215 0 52 0 60 255 236 0 52 0 61 255 236 0 52 0 130 255 215 0 52 0 131 255 215 0 52 0 132 255 215 0 52 0 133 255 215 0 52 0 134 255 215 0 52 0 135 255 215 0 52 0 159 255 236 0 52 0 194 255 215 0 52 0 196 255 215 0 52 0 198 255 215 0 52 1 36 255 195 0 52 1 38 255 195 0 52 1 54 255 236 0 52 1 56 255 236 0 52 1 58 255 236 0 52 1 59 255 236 0 52 1 61 255 236 0 52 1 63 255 236 0 52 1 67 255 215 0 52 1 160 255 236 0 52 1 250 255 236 0 52 1 252 255 236 0 52 1 254 255 236 0 52 2 0 255 236 0 52 2 8 255 174 0 52 2 12 255 174 0 52 2 88 255 215 0 52 3 29 255 215 0 52 3 31 255 215 0 52 3 33 255 215 0 52 3 35 255 215 0 52 3 37 255 215 0 52 3 39 255 215 0 52 3 41 255 215 0 52 3 43 255 215 0 52 3 45 255 215 0 52 3 47 255 215 0 52 3 49 255 215 0 52 3 51 255 215 0 52 3 111 255 236 0 52 3 113 255 236 0 52 3 115 255 236 0 52 3 143 255 195 0 55 0 15 255 133 0 55 0 16 255 174 0 55 0 17 255 133 0 55 0 34 0 41 0 55 0 36 255 113 0 55 0 38 255 215 0 55 0 42 255 215 0 55 0 50 255 215 0 55 0 52 255 215 0 55 0 55 0 41 0 55 0 68 255 92 0 55 0 70 255 113 0 55 0 71 255 113 0 55 0 72 255 113 0 55 0 74 255 113 0 55 0 80 255 154 0 55 0 81 255 154 0 55 0 82 255 113 0 55 0 83 255 154 0 55 0 84 255 113 0 55 0 85 255 154 0 55 0 86 255 133 0 55 0 88 255 154 0 55 0 89 255 215 0 55 0 90 255 215 0 55 0 91 255 215 0 55 0 92 255 215 0 55 0 93 255 174 0 55 0 130 255 113 0 55 0 131 255 113 0 55 0 132 255 113 0 55 0 133 255 113 0 55 0 134 255 113 0 55 0 135 255 113 0 55 0 137 255 215 0 55 0 148 255 215 0 55 0 149 255 215 0 55 0 150 255 215 0 55 0 151 255 215 0 55 0 152 255 215 0 55 0 154 255 215 0 55 0 162 255 113 0 55 0 163 255 92 0 55 0 164 255 92 0 55 0 165 255 92 0 55 0 166 255 92 0 55 0 167 255 92 0 55 0 168 255 92 0 55 0 169 255 113 0 55 0 170 255 113 0 55 0 171 255 113 0 55 0 172 255 113 0 55 0 173 255 113 0 55 0 180 255 113 0 55 0 181 255 113 0 55 0 182 255 113 0 55 0 183 255 113 0 55 0 184 255 113 0 55 0 186 255 113 0 55 0 187 255 154 0 55 0 188 255 154 0 55 0 189 255 154 0 55 0 190 255 154 0 55 0 191 255 215 0 55 0 194 255 113 0 55 0 195 255 92 0 55 0 196 255 113 0 55 0 197 255 92 0 55 0 198 255 113 0 55 0 199 255 92 0 55 0 200 255 215 0 55 0 201 255 113 0 55 0 202 255 215 0 55 0 203 255 113 0 55 0 204 255 215 0 55 0 205 255 113 0 55 0 206 255 215 0 55 0 207 255 113 0 55 0 209 255 113 0 55 0 211 255 113 0 55 0 213 255 113 0 55 0 215 255 113 0 55 0 217 255 113 0 55 0 219 255 113 0 55 0 221 255 113 0 55 0 222 255 215 0 55 0 223 255 113 0 55 0 224 255 215 0 55 0 225 255 113 0 55 0 226 255 215 0 55 0 227 255 113 0 55 0 228 255 215 0 55 0 229 255 113 0 55 0 250 255 154 0 55 1 6 255 154 0 55 1 8 255 154 0 55 1 13 255 154 0 55 1 14 255 215 0 55 1 15 255 113 0 55 1 16 255 215 0 55 1 17 255 113 0 55 1 18 255 215 0 55 1 19 255 113 0 55 1 20 255 215 0 55 1 21 255 113 0 55 1 23 255 154 0 55 1 25 255 154 0 55 1 29 255 133 0 55 1 33 255 133 0 55 1 36 0 41 0 55 1 38 0 41 0 55 1 43 255 154 0 55 1 45 255 154 0 55 1 47 255 154 0 55 1 49 255 154 0 55 1 51 255 154 0 55 1 53 255 154 0 55 1 55 255 215 0 55 1 60 255 174 0 55 1 62 255 174 0 55 1 64 255 174 0 55 1 67 255 113 0 55 1 68 255 92 0 55 1 70 255 92 0 55 1 71 255 215 0 55 1 72 255 113 0 55 1 74 255 133 0 55 1 251 255 215 0 55 1 253 255 215 0 55 2 2 255 174 0 55 2 3 255 174 0 55 2 4 255 174 0 55 2 8 255 133 0 55 2 12 255 133 0 55 2 87 255 154 0 55 2 88 255 113 0 55 2 89 255 92 0 55 2 95 255 215 0 55 2 96 255 113 0 55 2 98 255 154 0 55 3 29 255 113 0 55 3 30 255 92 0 55 3 31 255 113 0 55 3 32 255 92 0 55 3 33 255 113 0 55 3 34 255 92 0 55 3 35 255 113 0 55 3 37 255 113 0 55 3 38 255 92 0 55 3 39 255 113 0 55 3 40 255 92 0 55 3 41 255 113 0 55 3 42 255 92 0 55 3 43 255 113 0 55 3 44 255 92 0 55 3 45 255 113 0 55 3 46 255 92 0 55 3 47 255 113 0 55 3 48 255 92 0 55 3 49 255 113 0 55 3 50 255 92 0 55 3 51 255 113 0 55 3 52 255 92 0 55 3 54 255 113 0 55 3 56 255 113 0 55 3 58 255 113 0 55 3 60 255 113 0 55 3 64 255 113 0 55 3 66 255 113 0 55 3 68 255 113 0 55 3 73 255 215 0 55 3 74 255 113 0 55 3 75 255 215 0 55 3 76 255 113 0 55 3 77 255 215 0 55 3 78 255 113 0 55 3 79 255 215 0 55 3 81 255 215 0 55 3 82 255 113 0 55 3 83 255 215 0 55 3 84 255 113 0 55 3 85 255 215 0 55 3 86 255 113 0 55 3 87 255 215 0 55 3 88 255 113 0 55 3 89 255 215 0 55 3 90 255 113 0 55 3 91 255 215 0 55 3 92 255 113 0 55 3 93 255 215 0 55 3 94 255 113 0 55 3 95 255 215 0 55 3 96 255 113 0 55 3 98 255 154 0 55 3 100 255 154 0 55 3 102 255 154 0 55 3 104 255 154 0 55 3 106 255 154 0 55 3 108 255 154 0 55 3 110 255 154 0 55 3 112 255 215 0 55 3 143 0 41 0 56 0 15 255 215 0 56 0 17 255 215 0 56 0 36 255 236 0 56 0 130 255 236 0 56 0 131 255 236 0 56 0 132 255 236 0 56 0 133 255 236 0 56 0 134 255 236 0 56 0 135 255 236 0 56 0 194 255 236 0 56 0 196 255 236 0 56 0 198 255 236 0 56 1 67 255 236 0 56 2 8 255 215 0 56 2 12 255 215 0 56 2 88 255 236 0 56 3 29 255 236 0 56 3 31 255 236 0 56 3 33 255 236 0 56 3 35 255 236 0 56 3 37 255 236 0 56 3 39 255 236 0 56 3 41 255 236 0 56 3 43 255 236 0 56 3 45 255 236 0 56 3 47 255 236 0 56 3 49 255 236 0 56 3 51 255 236 0 57 0 15 255 154 0 57 0 17 255 154 0 57 0 34 0 41 0 57 0 36 255 174 0 57 0 38 255 236 0 57 0 42 255 236 0 57 0 50 255 236 0 57 0 52 255 236 0 57 0 68 255 215 0 57 0 70 255 215 0 57 0 71 255 215 0 57 0 72 255 215 0 57 0 74 255 236 0 57 0 80 255 236 0 57 0 81 255 236 0 57 0 82 255 215 0 57 0 83 255 236 0 57 0 84 255 215 0 57 0 85 255 236 0 57 0 86 255 236 0 57 0 88 255 236 0 57 0 130 255 174 0 57 0 131 255 174 0 57 0 132 255 174 0 57 0 133 255 174 0 57 0 134 255 174 0 57 0 135 255 174 0 57 0 137 255 236 0 57 0 148 255 236 0 57 0 149 255 236 0 57 0 150 255 236 0 57 0 151 255 236 0 57 0 152 255 236 0 57 0 154 255 236 0 57 0 162 255 215 0 57 0 163 255 215 0 57 0 164 255 215 0 57 0 165 255 215 0 57 0 166 255 215 0 57 0 167 255 215 0 57 0 168 255 215 0 57 0 169 255 215 0 57 0 170 255 215 0 57 0 171 255 215 0 57 0 172 255 215 0 57 0 173 255 215 0 57 0 180 255 215 0 57 0 181 255 215 0 57 0 182 255 215 0 57 0 183 255 215 0 57 0 184 255 215 0 57 0 186 255 215 0 57 0 187 255 236 0 57 0 188 255 236 0 57 0 189 255 236 0 57 0 190 255 236 0 57 0 194 255 174 0 57 0 195 255 215 0 57 0 196 255 174 0 57 0 197 255 215 0 57 0 198 255 174 0 57 0 199 255 215 0 57 0 200 255 236 0 57 0 201 255 215 0 57 0 202 255 236 0 57 0 203 255 215 0 57 0 204 255 236 0 57 0 205 255 215 0 57 0 206 255 236 0 57 0 207 255 215 0 57 0 209 255 215 0 57 0 211 255 215 0 57 0 213 255 215 0 57 0 215 255 215 0 57 0 217 255 215 0 57 0 219 255 215 0 57 0 221 255 215 0 57 0 222 255 236 0 57 0 223 255 236 0 57 0 224 255 236 0 57 0 225 255 236 0 57 0 226 255 236 0 57 0 227 255 236 0 57 0 228 255 236 0 57 0 229 255 236 0 57 0 250 255 236 0 57 1 6 255 236 0 57 1 8 255 236 0 57 1 13 255 236 0 57 1 14 255 236 0 57 1 15 255 215 0 57 1 16 255 236 0 57 1 17 255 215 0 57 1 18 255 236 0 57 1 19 255 215 0 57 1 20 255 236 0 57 1 21 255 215 0 57 1 23 255 236 0 57 1 25 255 236 0 57 1 29 255 236 0 57 1 33 255 236 0 57 1 43 255 236 0 57 1 45 255 236 0 57 1 47 255 236 0 57 1 49 255 236 0 57 1 51 255 236 0 57 1 53 255 236 0 57 1 67 255 174 0 57 1 68 255 215 0 57 1 70 255 215 0 57 1 71 255 236 0 57 1 72 255 215 0 57 1 74 255 236 0 57 2 8 255 154 0 57 2 12 255 154 0 57 2 87 255 236 0 57 2 88 255 174 0 57 2 89 255 215 0 57 2 95 255 236 0 57 2 96 255 215 0 57 2 98 255 236 0 57 3 29 255 174 0 57 3 30 255 215 0 57 3 31 255 174 0 57 3 32 255 215 0 57 3 33 255 174 0 57 3 34 255 215 0 57 3 35 255 174 0 57 3 37 255 174 0 57 3 38 255 215 0 57 3 39 255 174 0 57 3 40 255 215 0 57 3 41 255 174 0 57 3 42 255 215 0 57 3 43 255 174 0 57 3 44 255 215 0 57 3 45 255 174 0 57 3 46 255 215 0 57 3 47 255 174 0 57 3 48 255 215 0 57 3 49 255 174 0 57 3 50 255 215 0 57 3 51 255 174 0 57 3 52 255 215 0 57 3 54 255 215 0 57 3 56 255 215 0 57 3 58 255 215 0 57 3 60 255 215 0 57 3 64 255 215 0 57 3 66 255 215 0 57 3 68 255 215 0 57 3 73 255 236 0 57 3 74 255 215 0 57 3 75 255 236 0 57 3 76 255 215 0 57 3 77 255 236 0 57 3 78 255 215 0 57 3 79 255 236 0 57 3 81 255 236 0 57 3 82 255 215 0 57 3 83 255 236 0 57 3 84 255 215 0 57 3 85 255 236 0 57 3 86 255 215 0 57 3 87 255 236 0 57 3 88 255 215 0 57 3 89 255 236 0 57 3 90 255 215 0 57 3 91 255 236 0 57 3 92 255 215 0 57 3 93 255 236 0 57 3 94 255 215 0 57 3 95 255 236 0 57 3 96 255 215 0 57 3 98 255 236 0 57 3 100 255 236 0 57 3 102 255 236 0 57 3 104 255 236 0 57 3 106 255 236 0 57 3 108 255 236 0 57 3 110 255 236 0 58 0 15 255 154 0 58 0 17 255 154 0 58 0 34 0 41 0 58 0 36 255 174 0 58 0 38 255 236 0 58 0 42 255 236 0 58 0 50 255 236 0 58 0 52 255 236 0 58 0 68 255 215 0 58 0 70 255 215 0 58 0 71 255 215 0 58 0 72 255 215 0 58 0 74 255 236 0 58 0 80 255 236 0 58 0 81 255 236 0 58 0 82 255 215 0 58 0 83 255 236 0 58 0 84 255 215 0 58 0 85 255 236 0 58 0 86 255 236 0 58 0 88 255 236 0 58 0 130 255 174 0 58 0 131 255 174 0 58 0 132 255 174 0 58 0 133 255 174 0 58 0 134 255 174 0 58 0 135 255 174 0 58 0 137 255 236 0 58 0 148 255 236 0 58 0 149 255 236 0 58 0 150 255 236 0 58 0 151 255 236 0 58 0 152 255 236 0 58 0 154 255 236 0 58 0 162 255 215 0 58 0 163 255 215 0 58 0 164 255 215 0 58 0 165 255 215 0 58 0 166 255 215 0 58 0 167 255 215 0 58 0 168 255 215 0 58 0 169 255 215 0 58 0 170 255 215 0 58 0 171 255 215 0 58 0 172 255 215 0 58 0 173 255 215 0 58 0 180 255 215 0 58 0 181 255 215 0 58 0 182 255 215 0 58 0 183 255 215 0 58 0 184 255 215 0 58 0 186 255 215 0 58 0 187 255 236 0 58 0 188 255 236 0 58 0 189 255 236 0 58 0 190 255 236 0 58 0 194 255 174 0 58 0 195 255 215 0 58 0 196 255 174 0 58 0 197 255 215 0 58 0 198 255 174 0 58 0 199 255 215 0 58 0 200 255 236 0 58 0 201 255 215 0 58 0 202 255 236 0 58 0 203 255 215 0 58 0 204 255 236 0 58 0 205 255 215 0 58 0 206 255 236 0 58 0 207 255 215 0 58 0 209 255 215 0 58 0 211 255 215 0 58 0 213 255 215 0 58 0 215 255 215 0 58 0 217 255 215 0 58 0 219 255 215 0 58 0 221 255 215 0 58 0 222 255 236 0 58 0 223 255 236 0 58 0 224 255 236 0 58 0 225 255 236 0 58 0 226 255 236 0 58 0 227 255 236 0 58 0 228 255 236 0 58 0 229 255 236 0 58 0 250 255 236 0 58 1 6 255 236 0 58 1 8 255 236 0 58 1 13 255 236 0 58 1 14 255 236 0 58 1 15 255 215 0 58 1 16 255 236 0 58 1 17 255 215 0 58 1 18 255 236 0 58 1 19 255 215 0 58 1 20 255 236 0 58 1 21 255 215 0 58 1 23 255 236 0 58 1 25 255 236 0 58 1 29 255 236 0 58 1 33 255 236 0 58 1 43 255 236 0 58 1 45 255 236 0 58 1 47 255 236 0 58 1 49 255 236 0 58 1 51 255 236 0 58 1 53 255 236 0 58 1 67 255 174 0 58 1 68 255 215 0 58 1 70 255 215 0 58 1 71 255 236 0 58 1 72 255 215 0 58 1 74 255 236 0 58 2 8 255 154 0 58 2 12 255 154 0 58 2 87 255 236 0 58 2 88 255 174 0 58 2 89 255 215 0 58 2 95 255 236 0 58 2 96 255 215 0 58 2 98 255 236 0 58 3 29 255 174 0 58 3 30 255 215 0 58 3 31 255 174 0 58 3 32 255 215 0 58 3 33 255 174 0 58 3 34 255 215 0 58 3 35 255 174 0 58 3 37 255 174 0 58 3 38 255 215 0 58 3 39 255 174 0 58 3 40 255 215 0 58 3 41 255 174 0 58 3 42 255 215 0 58 3 43 255 174 0 58 3 44 255 215 0 58 3 45 255 174 0 58 3 46 255 215 0 58 3 47 255 174 0 58 3 48 255 215 0 58 3 49 255 174 0 58 3 50 255 215 0 58 3 51 255 174 0 58 3 52 255 215 0 58 3 54 255 215 0 58 3 56 255 215 0 58 3 58 255 215 0 58 3 60 255 215 0 58 3 64 255 215 0 58 3 66 255 215 0 58 3 68 255 215 0 58 3 73 255 236 0 58 3 74 255 215 0 58 3 75 255 236 0 58 3 76 255 215 0 58 3 77 255 236 0 58 3 78 255 215 0 58 3 79 255 236 0 58 3 81 255 236 0 58 3 82 255 215 0 58 3 83 255 236 0 58 3 84 255 215 0 58 3 85 255 236 0 58 3 86 255 215 0 58 3 87 255 236 0 58 3 88 255 215 0 58 3 89 255 236 0 58 3 90 255 215 0 58 3 91 255 236 0 58 3 92 255 215 0 58 3 93 255 236 0 58 3 94 255 215 0 58 3 95 255 236 0 58 3 96 255 215 0 58 3 98 255 236 0 58 3 100 255 236 0 58 3 102 255 236 0 58 3 104 255 236 0 58 3 106 255 236 0 58 3 108 255 236 0 58 3 110 255 236 0 59 0 38 255 215 0 59 0 42 255 215 0 59 0 50 255 215 0 59 0 52 255 215 0 59 0 137 255 215 0 59 0 148 255 215 0 59 0 149 255 215 0 59 0 150 255 215 0 59 0 151 255 215 0 59 0 152 255 215 0 59 0 154 255 215 0 59 0 200 255 215 0 59 0 202 255 215 0 59 0 204 255 215 0 59 0 206 255 215 0 59 0 222 255 215 0 59 0 224 255 215 0 59 0 226 255 215 0 59 0 228 255 215 0 59 1 14 255 215 0 59 1 16 255 215 0 59 1 18 255 215 0 59 1 20 255 215 0 59 1 71 255 215 0 59 2 95 255 215 0 59 3 73 255 215 0 59 3 75 255 215 0 59 3 77 255 215 0 59 3 79 255 215 0 59 3 81 255 215 0 59 3 83 255 215 0 59 3 85 255 215 0 59 3 87 255 215 0 59 3 89 255 215 0 59 3 91 255 215 0 59 3 93 255 215 0 59 3 95 255 215 0 60 0 15 255 133 0 60 0 17 255 133 0 60 0 34 0 41 0 60 0 36 255 133 0 60 0 38 255 215 0 60 0 42 255 215 0 60 0 50 255 215 0 60 0 52 255 215 0 60 0 68 255 154 0 60 0 70 255 154 0 60 0 71 255 154 0 60 0 72 255 154 0 60 0 74 255 215 0 60 0 80 255 195 0 60 0 81 255 195 0 60 0 82 255 154 0 60 0 83 255 195 0 60 0 84 255 154 0 60 0 85 255 195 0 60 0 86 255 174 0 60 0 88 255 195 0 60 0 93 255 215 0 60 0 130 255 133 0 60 0 131 255 133 0 60 0 132 255 133 0 60 0 133 255 133 0 60 0 134 255 133 0 60 0 135 255 133 0 60 0 137 255 215 0 60 0 148 255 215 0 60 0 149 255 215 0 60 0 150 255 215 0 60 0 151 255 215 0 60 0 152 255 215 0 60 0 154 255 215 0 60 0 162 255 154 0 60 0 163 255 154 0 60 0 164 255 154 0 60 0 165 255 154 0 60 0 166 255 154 0 60 0 167 255 154 0 60 0 168 255 154 0 60 0 169 255 154 0 60 0 170 255 154 0 60 0 171 255 154 0 60 0 172 255 154 0 60 0 173 255 154 0 60 0 180 255 154 0 60 0 181 255 154 0 60 0 182 255 154 0 60 0 183 255 154 0 60 0 184 255 154 0 60 0 186 255 154 0 60 0 187 255 195 0 60 0 188 255 195 0 60 0 189 255 195 0 60 0 190 255 195 0 60 0 194 255 133 0 60 0 195 255 154 0 60 0 196 255 133 0 60 0 197 255 154 0 60 0 198 255 133 0 60 0 199 255 154 0 60 0 200 255 215 0 60 0 201 255 154 0 60 0 202 255 215 0 60 0 203 255 154 0 60 0 204 255 215 0 60 0 205 255 154 0 60 0 206 255 215 0 60 0 207 255 154 0 60 0 209 255 154 0 60 0 211 255 154 0 60 0 213 255 154 0 60 0 215 255 154 0 60 0 217 255 154 0 60 0 219 255 154 0 60 0 221 255 154 0 60 0 222 255 215 0 60 0 223 255 215 0 60 0 224 255 215 0 60 0 225 255 215 0 60 0 226 255 215 0 60 0 227 255 215 0 60 0 228 255 215 0 60 0 229 255 215 0 60 0 250 255 195 0 60 1 6 255 195 0 60 1 8 255 195 0 60 1 13 255 195 0 60 1 14 255 215 0 60 1 15 255 154 0 60 1 16 255 215 0 60 1 17 255 154 0 60 1 18 255 215 0 60 1 19 255 154 0 60 1 20 255 215 0 60 1 21 255 154 0 60 1 23 255 195 0 60 1 25 255 195 0 60 1 29 255 174 0 60 1 33 255 174 0 60 1 43 255 195 0 60 1 45 255 195 0 60 1 47 255 195 0 60 1 49 255 195 0 60 1 51 255 195 0 60 1 53 255 195 0 60 1 60 255 215 0 60 1 62 255 215 0 60 1 64 255 215 0 60 1 67 255 133 0 60 1 68 255 154 0 60 1 70 255 154 0 60 1 71 255 215 0 60 1 72 255 154 0 60 1 74 255 174 0 60 2 8 255 133 0 60 2 12 255 133 0 60 2 87 255 195 0 60 2 88 255 133 0 60 2 89 255 154 0 60 2 95 255 215 0 60 2 96 255 154 0 60 2 98 255 195 0 60 3 29 255 133 0 60 3 30 255 154 0 60 3 31 255 133 0 60 3 32 255 154 0 60 3 33 255 133 0 60 3 34 255 154 0 60 3 35 255 133 0 60 3 37 255 133 0 60 3 38 255 154 0 60 3 39 255 133 0 60 3 40 255 154 0 60 3 41 255 133 0 60 3 42 255 154 0 60 3 43 255 133 0 60 3 44 255 154 0 60 3 45 255 133 0 60 3 46 255 154 0 60 3 47 255 133 0 60 3 48 255 154 0 60 3 49 255 133 0 60 3 50 255 154 0 60 3 51 255 133 0 60 3 52 255 154 0 60 3 54 255 154 0 60 3 56 255 154 0 60 3 58 255 154 0 60 3 60 255 154 0 60 3 64 255 154 0 60 3 66 255 154 0 60 3 68 255 154 0 60 3 73 255 215 0 60 3 74 255 154 0 60 3 75 255 215 0 60 3 76 255 154 0 60 3 77 255 215 0 60 3 78 255 154 0 60 3 79 255 215 0 60 3 81 255 215 0 60 3 82 255 154 0 60 3 83 255 215 0 60 3 84 255 154 0 60 3 85 255 215 0 60 3 86 255 154 0 60 3 87 255 215 0 60 3 88 255 154 0 60 3 89 255 215 0 60 3 90 255 154 0 60 3 91 255 215 0 60 3 92 255 154 0 60 3 93 255 215 0 60 3 94 255 154 0 60 3 95 255 215 0 60 3 96 255 154 0 60 3 98 255 195 0 60 3 100 255 195 0 60 3 102 255 195 0 60 3 104 255 195 0 60 3 106 255 195 0 60 3 108 255 195 0 60 3 110 255 195 0 61 0 38 255 236 0 61 0 42 255 236 0 61 0 50 255 236 0 61 0 52 255 236 0 61 0 137 255 236 0 61 0 148 255 236 0 61 0 149 255 236 0 61 0 150 255 236 0 61 0 151 255 236 0 61 0 152 255 236 0 61 0 154 255 236 0 61 0 200 255 236 0 61 0 202 255 236 0 61 0 204 255 236 0 61 0 206 255 236 0 61 0 222 255 236 0 61 0 224 255 236 0 61 0 226 255 236 0 61 0 228 255 236 0 61 1 14 255 236 0 61 1 16 255 236 0 61 1 18 255 236 0 61 1 20 255 236 0 61 1 71 255 236 0 61 2 95 255 236 0 61 3 73 255 236 0 61 3 75 255 236 0 61 3 77 255 236 0 61 3 79 255 236 0 61 3 81 255 236 0 61 3 83 255 236 0 61 3 85 255 236 0 61 3 87 255 236 0 61 3 89 255 236 0 61 3 91 255 236 0 61 3 93 255 236 0 61 3 95 255 236 0 62 0 45 0 184 0 68 0 5 255 236 0 68 0 10 255 236 0 68 2 7 255 236 0 68 2 11 255 236 0 69 0 5 255 236 0 69 0 10 255 236 0 69 0 89 255 215 0 69 0 90 255 215 0 69 0 91 255 215 0 69 0 92 255 215 0 69 0 93 255 236 0 69 0 191 255 215 0 69 1 55 255 215 0 69 1 60 255 236 0 69 1 62 255 236 0 69 1 64 255 236 0 69 1 251 255 215 0 69 1 253 255 215 0 69 2 7 255 236 0 69 2 11 255 236 0 69 3 112 255 215 0 70 0 5 0 41 0 70 0 10 0 41 0 70 2 7 0 41 0 70 2 11 0 41 0 72 0 5 255 236 0 72 0 10 255 236 0 72 0 89 255 215 0 72 0 90 255 215 0 72 0 91 255 215 0 72 0 92 255 215 0 72 0 93 255 236 0 72 0 191 255 215 0 72 1 55 255 215 0 72 1 60 255 236 0 72 1 62 255 236 0 72 1 64 255 236 0 72 1 251 255 215 0 72 1 253 255 215 0 72 2 7 255 236 0 72 2 11 255 236 0 72 3 112 255 215 0 73 0 5 0 123 0 73 0 10 0 123 0 73 2 7 0 123 0 73 2 11 0 123 0 75 0 5 255 236 0 75 0 10 255 236 0 75 2 7 255 236 0 75 2 11 255 236 0 78 0 70 255 215 0 78 0 71 255 215 0 78 0 72 255 215 0 78 0 82 255 215 0 78 0 84 255 215 0 78 0 162 255 215 0 78 0 169 255 215 0 78 0 170 255 215 0 78 0 171 255 215 0 78 0 172 255 215 0 78 0 173 255 215 0 78 0 180 255 215 0 78 0 181 255 215 0 78 0 182 255 215 0 78 0 183 255 215 0 78 0 184 255 215 0 78 0 186 255 215 0 78 0 201 255 215 0 78 0 203 255 215 0 78 0 205 255 215 0 78 0 207 255 215 0 78 0 209 255 215 0 78 0 211 255 215 0 78 0 213 255 215 0 78 0 215 255 215 0 78 0 217 255 215 0 78 0 219 255 215 0 78 0 221 255 215 0 78 1 15 255 215 0 78 1 17 255 215 0 78 1 19 255 215 0 78 1 21 255 215 0 78 1 72 255 215 0 78 2 96 255 215 0 78 3 54 255 215 0 78 3 56 255 215 0 78 3 58 255 215 0 78 3 60 255 215 0 78 3 64 255 215 0 78 3 66 255 215 0 78 3 68 255 215 0 78 3 74 255 215 0 78 3 76 255 215 0 78 3 78 255 215 0 78 3 82 255 215 0 78 3 84 255 215 0 78 3 86 255 215 0 78 3 88 255 215 0 78 3 90 255 215 0 78 3 92 255 215 0 78 3 94 255 215 0 78 3 96 255 215 0 80 0 5 255 236 0 80 0 10 255 236 0 80 2 7 255 236 0 80 2 11 255 236 0 81 0 5 255 236 0 81 0 10 255 236 0 81 2 7 255 236 0 81 2 11 255 236 0 82 0 5 255 236 0 82 0 10 255 236 0 82 0 89 255 215 0 82 0 90 255 215 0 82 0 91 255 215 0 82 0 92 255 215 0 82 0 93 255 236 0 82 0 191 255 215 0 82 1 55 255 215 0 82 1 60 255 236 0 82 1 62 255 236 0 82 1 64 255 236 0 82 1 251 255 215 0 82 1 253 255 215 0 82 2 7 255 236 0 82 2 11 255 236 0 82 3 112 255 215 0 83 0 5 255 236 0 83 0 10 255 236 0 83 0 89 255 215 0 83 0 90 255 215 0 83 0 91 255 215 0 83 0 92 255 215 0 83 0 93 255 236 0 83 0 191 255 215 0 83 1 55 255 215 0 83 1 60 255 236 0 83 1 62 255 236 0 83 1 64 255 236 0 83 1 251 255 215 0 83 1 253 255 215 0 83 2 7 255 236 0 83 2 11 255 236 0 83 3 112 255 215 0 85 0 5 0 82 0 85 0 10 0 82 0 85 0 68 255 215 0 85 0 70 255 215 0 85 0 71 255 215 0 85 0 72 255 215 0 85 0 74 255 236 0 85 0 82 255 215 0 85 0 84 255 215 0 85 0 162 255 215 0 85 0 163 255 215 0 85 0 164 255 215 0 85 0 165 255 215 0 85 0 166 255 215 0 85 0 167 255 215 0 85 0 168 255 215 0 85 0 169 255 215 0 85 0 170 255 215 0 85 0 171 255 215 0 85 0 172 255 215 0 85 0 173 255 215 0 85 0 180 255 215 0 85 0 181 255 215 0 85 0 182 255 215 0 85 0 183 255 215 0 85 0 184 255 215 0 85 0 186 255 215 0 85 0 195 255 215 0 85 0 197 255 215 0 85 0 199 255 215 0 85 0 201 255 215 0 85 0 203 255 215 0 85 0 205 255 215 0 85 0 207 255 215 0 85 0 209 255 215 0 85 0 211 255 215 0 85 0 213 255 215 0 85 0 215 255 215 0 85 0 217 255 215 0 85 0 219 255 215 0 85 0 221 255 215 0 85 0 223 255 236 0 85 0 225 255 236 0 85 0 227 255 236 0 85 0 229 255 236 0 85 1 15 255 215 0 85 1 17 255 215 0 85 1 19 255 215 0 85 1 21 255 215 0 85 1 68 255 215 0 85 1 70 255 215 0 85 1 72 255 215 0 85 2 7 0 82 0 85 2 11 0 82 0 85 2 89 255 215 0 85 2 96 255 215 0 85 3 30 255 215 0 85 3 32 255 215 0 85 3 34 255 215 0 85 3 38 255 215 0 85 3 40 255 215 0 85 3 42 255 215 0 85 3 44 255 215 0 85 3 46 255 215 0 85 3 48 255 215 0 85 3 50 255 215 0 85 3 52 255 215 0 85 3 54 255 215 0 85 3 56 255 215 0 85 3 58 255 215 0 85 3 60 255 215 0 85 3 64 255 215 0 85 3 66 255 215 0 85 3 68 255 215 0 85 3 74 255 215 0 85 3 76 255 215 0 85 3 78 255 215 0 85 3 82 255 215 0 85 3 84 255 215 0 85 3 86 255 215 0 85 3 88 255 215 0 85 3 90 255 215 0 85 3 92 255 215 0 85 3 94 255 215 0 85 3 96 255 215 0 87 0 5 0 41 0 87 0 10 0 41 0 87 2 7 0 41 0 87 2 11 0 41 0 89 0 5 0 82 0 89 0 10 0 82 0 89 0 15 255 174 0 89 0 17 255 174 0 89 0 34 0 41 0 89 2 7 0 82 0 89 2 8 255 174 0 89 2 11 0 82 0 89 2 12 255 174 0 90 0 5 0 82 0 90 0 10 0 82 0 90 0 15 255 174 0 90 0 17 255 174 0 90 0 34 0 41 0 90 2 7 0 82 0 90 2 8 255 174 0 90 2 11 0 82 0 90 2 12 255 174 0 91 0 70 255 215 0 91 0 71 255 215 0 91 0 72 255 215 0 91 0 82 255 215 0 91 0 84 255 215 0 91 0 162 255 215 0 91 0 169 255 215 0 91 0 170 255 215 0 91 0 171 255 215 0 91 0 172 255 215 0 91 0 173 255 215 0 91 0 180 255 215 0 91 0 181 255 215 0 91 0 182 255 215 0 91 0 183 255 215 0 91 0 184 255 215 0 91 0 186 255 215 0 91 0 201 255 215 0 91 0 203 255 215 0 91 0 205 255 215 0 91 0 207 255 215 0 91 0 209 255 215 0 91 0 211 255 215 0 91 0 213 255 215 0 91 0 215 255 215 0 91 0 217 255 215 0 91 0 219 255 215 0 91 0 221 255 215 0 91 1 15 255 215 0 91 1 17 255 215 0 91 1 19 255 215 0 91 1 21 255 215 0 91 1 72 255 215 0 91 2 96 255 215 0 91 3 54 255 215 0 91 3 56 255 215 0 91 3 58 255 215 0 91 3 60 255 215 0 91 3 64 255 215 0 91 3 66 255 215 0 91 3 68 255 215 0 91 3 74 255 215 0 91 3 76 255 215 0 91 3 78 255 215 0 91 3 82 255 215 0 91 3 84 255 215 0 91 3 86 255 215 0 91 3 88 255 215 0 91 3 90 255 215 0 91 3 92 255 215 0 91 3 94 255 215 0 91 3 96 255 215 0 92 0 5 0 82 0 92 0 10 0 82 0 92 0 15 255 174 0 92 0 17 255 174 0 92 0 34 0 41 0 92 2 7 0 82 0 92 2 8 255 174 0 92 2 11 0 82 0 92 2 12 255 174 0 94 0 45 0 184 0 130 0 5 255 113 0 130 0 10 255 113 0 130 0 38 255 215 0 130 0 42 255 215 0 130 0 45 1 10 0 130 0 50 255 215 0 130 0 52 255 215 0 130 0 55 255 113 0 130 0 57 255 174 0 130 0 58 255 174 0 130 0 60 255 133 0 130 0 137 255 215 0 130 0 148 255 215 0 130 0 149 255 215 0 130 0 150 255 215 0 130 0 151 255 215 0 130 0 152 255 215 0 130 0 154 255 215 0 130 0 159 255 133 0 130 0 200 255 215 0 130 0 202 255 215 0 130 0 204 255 215 0 130 0 206 255 215 0 130 0 222 255 215 0 130 0 224 255 215 0 130 0 226 255 215 0 130 0 228 255 215 0 130 1 14 255 215 0 130 1 16 255 215 0 130 1 18 255 215 0 130 1 20 255 215 0 130 1 36 255 113 0 130 1 38 255 113 0 130 1 54 255 174 0 130 1 56 255 133 0 130 1 58 255 133 0 130 1 71 255 215 0 130 1 250 255 174 0 130 1 252 255 174 0 130 1 254 255 174 0 130 2 0 255 133 0 130 2 7 255 113 0 130 2 11 255 113 0 130 2 95 255 215 0 130 3 73 255 215 0 130 3 75 255 215 0 130 3 77 255 215 0 130 3 79 255 215 0 130 3 81 255 215 0 130 3 83 255 215 0 130 3 85 255 215 0 130 3 87 255 215 0 130 3 89 255 215 0 130 3 91 255 215 0 130 3 93 255 215 0 130 3 95 255 215 0 130 3 111 255 133 0 130 3 113 255 133 0 130 3 115 255 133 0 130 3 143 255 113 0 131 0 5 255 113 0 131 0 10 255 113 0 131 0 38 255 215 0 131 0 42 255 215 0 131 0 45 1 10 0 131 0 50 255 215 0 131 0 52 255 215 0 131 0 55 255 113 0 131 0 57 255 174 0 131 0 58 255 174 0 131 0 60 255 133 0 131 0 137 255 215 0 131 0 148 255 215 0 131 0 149 255 215 0 131 0 150 255 215 0 131 0 151 255 215 0 131 0 152 255 215 0 131 0 154 255 215 0 131 0 159 255 133 0 131 0 200 255 215 0 131 0 202 255 215 0 131 0 204 255 215 0 131 0 206 255 215 0 131 0 222 255 215 0 131 0 224 255 215 0 131 0 226 255 215 0 131 0 228 255 215 0 131 1 14 255 215 0 131 1 16 255 215 0 131 1 18 255 215 0 131 1 20 255 215 0 131 1 36 255 113 0 131 1 38 255 113 0 131 1 54 255 174 0 131 1 56 255 133 0 131 1 58 255 133 0 131 1 71 255 215 0 131 1 250 255 174 0 131 1 252 255 174 0 131 1 254 255 174 0 131 2 0 255 133 0 131 2 7 255 113 0 131 2 11 255 113 0 131 2 95 255 215 0 131 3 73 255 215 0 131 3 75 255 215 0 131 3 77 255 215 0 131 3 79 255 215 0 131 3 81 255 215 0 131 3 83 255 215 0 131 3 85 255 215 0 131 3 87 255 215 0 131 3 89 255 215 0 131 3 91 255 215 0 131 3 93 255 215 0 131 3 95 255 215 0 131 3 111 255 133 0 131 3 113 255 133 0 131 3 115 255 133 0 131 3 143 255 113 0 132 0 5 255 113 0 132 0 10 255 113 0 132 0 38 255 215 0 132 0 42 255 215 0 132 0 45 1 10 0 132 0 50 255 215 0 132 0 52 255 215 0 132 0 55 255 113 0 132 0 57 255 174 0 132 0 58 255 174 0 132 0 60 255 133 0 132 0 137 255 215 0 132 0 148 255 215 0 132 0 149 255 215 0 132 0 150 255 215 0 132 0 151 255 215 0 132 0 152 255 215 0 132 0 154 255 215 0 132 0 159 255 133 0 132 0 200 255 215 0 132 0 202 255 215 0 132 0 204 255 215 0 132 0 206 255 215 0 132 0 222 255 215 0 132 0 224 255 215 0 132 0 226 255 215 0 132 0 228 255 215 0 132 1 14 255 215 0 132 1 16 255 215 0 132 1 18 255 215 0 132 1 20 255 215 0 132 1 36 255 113 0 132 1 38 255 113 0 132 1 54 255 174 0 132 1 56 255 133 0 132 1 58 255 133 0 132 1 71 255 215 0 132 1 250 255 174 0 132 1 252 255 174 0 132 1 254 255 174 0 132 2 0 255 133 0 132 2 7 255 113 0 132 2 11 255 113 0 132 2 95 255 215 0 132 3 73 255 215 0 132 3 75 255 215 0 132 3 77 255 215 0 132 3 79 255 215 0 132 3 81 255 215 0 132 3 83 255 215 0 132 3 85 255 215 0 132 3 87 255 215 0 132 3 89 255 215 0 132 3 91 255 215 0 132 3 93 255 215 0 132 3 95 255 215 0 132 3 111 255 133 0 132 3 113 255 133 0 132 3 115 255 133 0 132 3 143 255 113 0 133 0 5 255 113 0 133 0 10 255 113 0 133 0 38 255 215 0 133 0 42 255 215 0 133 0 45 1 10 0 133 0 50 255 215 0 133 0 52 255 215 0 133 0 55 255 113 0 133 0 57 255 174 0 133 0 58 255 174 0 133 0 60 255 133 0 133 0 137 255 215 0 133 0 148 255 215 0 133 0 149 255 215 0 133 0 150 255 215 0 133 0 151 255 215 0 133 0 152 255 215 0 133 0 154 255 215 0 133 0 159 255 133 0 133 0 200 255 215 0 133 0 202 255 215 0 133 0 204 255 215 0 133 0 206 255 215 0 133 0 222 255 215 0 133 0 224 255 215 0 133 0 226 255 215 0 133 0 228 255 215 0 133 1 14 255 215 0 133 1 16 255 215 0 133 1 18 255 215 0 133 1 20 255 215 0 133 1 36 255 113 0 133 1 38 255 113 0 133 1 54 255 174 0 133 1 56 255 133 0 133 1 58 255 133 0 133 1 71 255 215 0 133 1 250 255 174 0 133 1 252 255 174 0 133 1 254 255 174 0 133 2 0 255 133 0 133 2 7 255 113 0 133 2 11 255 113 0 133 2 95 255 215 0 133 3 73 255 215 0 133 3 75 255 215 0 133 3 77 255 215 0 133 3 79 255 215 0 133 3 81 255 215 0 133 3 83 255 215 0 133 3 85 255 215 0 133 3 87 255 215 0 133 3 89 255 215 0 133 3 91 255 215 0 133 3 93 255 215 0 133 3 95 255 215 0 133 3 111 255 133 0 133 3 113 255 133 0 133 3 115 255 133 0 133 3 143 255 113 0 134 0 5 255 113 0 134 0 10 255 113 0 134 0 38 255 215 0 134 0 42 255 215 0 134 0 45 1 10 0 134 0 50 255 215 0 134 0 52 255 215 0 134 0 55 255 113 0 134 0 57 255 174 0 134 0 58 255 174 0 134 0 60 255 133 0 134 0 137 255 215 0 134 0 148 255 215 0 134 0 149 255 215 0 134 0 150 255 215 0 134 0 151 255 215 0 134 0 152 255 215 0 134 0 154 255 215 0 134 0 159 255 133 0 134 0 200 255 215 0 134 0 202 255 215 0 134 0 204 255 215 0 134 0 206 255 215 0 134 0 222 255 215 0 134 0 224 255 215 0 134 0 226 255 215 0 134 0 228 255 215 0 134 1 14 255 215 0 134 1 16 255 215 0 134 1 18 255 215 0 134 1 20 255 215 0 134 1 36 255 113 0 134 1 38 255 113 0 134 1 54 255 174 0 134 1 56 255 133 0 134 1 58 255 133 0 134 1 71 255 215 0 134 1 250 255 174 0 134 1 252 255 174 0 134 1 254 255 174 0 134 2 0 255 133 0 134 2 7 255 113 0 134 2 11 255 113 0 134 2 95 255 215 0 134 3 73 255 215 0 134 3 75 255 215 0 134 3 77 255 215 0 134 3 79 255 215 0 134 3 81 255 215 0 134 3 83 255 215 0 134 3 85 255 215 0 134 3 87 255 215 0 134 3 89 255 215 0 134 3 91 255 215 0 134 3 93 255 215 0 134 3 95 255 215 0 134 3 111 255 133 0 134 3 113 255 133 0 134 3 115 255 133 0 134 3 143 255 113 0 135 0 5 255 113 0 135 0 10 255 113 0 135 0 38 255 215 0 135 0 42 255 215 0 135 0 45 1 10 0 135 0 50 255 215 0 135 0 52 255 215 0 135 0 55 255 113 0 135 0 57 255 174 0 135 0 58 255 174 0 135 0 60 255 133 0 135 0 137 255 215 0 135 0 148 255 215 0 135 0 149 255 215 0 135 0 150 255 215 0 135 0 151 255 215 0 135 0 152 255 215 0 135 0 154 255 215 0 135 0 159 255 133 0 135 0 200 255 215 0 135 0 202 255 215 0 135 0 204 255 215 0 135 0 206 255 215 0 135 0 222 255 215 0 135 0 224 255 215 0 135 0 226 255 215 0 135 0 228 255 215 0 135 1 14 255 215 0 135 1 16 255 215 0 135 1 18 255 215 0 135 1 20 255 215 0 135 1 36 255 113 0 135 1 38 255 113 0 135 1 54 255 174 0 135 1 56 255 133 0 135 1 58 255 133 0 135 1 71 255 215 0 135 1 250 255 174 0 135 1 252 255 174 0 135 1 254 255 174 0 135 2 0 255 133 0 135 2 7 255 113 0 135 2 11 255 113 0 135 2 95 255 215 0 135 3 73 255 215 0 135 3 75 255 215 0 135 3 77 255 215 0 135 3 79 255 215 0 135 3 81 255 215 0 135 3 83 255 215 0 135 3 85 255 215 0 135 3 87 255 215 0 135 3 89 255 215 0 135 3 91 255 215 0 135 3 93 255 215 0 135 3 95 255 215 0 135 3 111 255 133 0 135 3 113 255 133 0 135 3 115 255 133 0 135 3 143 255 113 0 136 0 45 0 123 0 137 0 38 255 215 0 137 0 42 255 215 0 137 0 50 255 215 0 137 0 52 255 215 0 137 0 137 255 215 0 137 0 148 255 215 0 137 0 149 255 215 0 137 0 150 255 215 0 137 0 151 255 215 0 137 0 152 255 215 0 137 0 154 255 215 0 137 0 200 255 215 0 137 0 202 255 215 0 137 0 204 255 215 0 137 0 206 255 215 0 137 0 222 255 215 0 137 0 224 255 215 0 137 0 226 255 215 0 137 0 228 255 215 0 137 1 14 255 215 0 137 1 16 255 215 0 137 1 18 255 215 0 137 1 20 255 215 0 137 1 71 255 215 0 137 2 95 255 215 0 137 3 73 255 215 0 137 3 75 255 215 0 137 3 77 255 215 0 137 3 79 255 215 0 137 3 81 255 215 0 137 3 83 255 215 0 137 3 85 255 215 0 137 3 87 255 215 0 137 3 89 255 215 0 137 3 91 255 215 0 137 3 93 255 215 0 137 3 95 255 215 0 138 0 45 0 123 0 139 0 45 0 123 0 140 0 45 0 123 0 141 0 45 0 123 0 146 0 15 255 174 0 146 0 17 255 174 0 146 0 36 255 215 0 146 0 55 255 195 0 146 0 57 255 236 0 146 0 58 255 236 0 146 0 59 255 215 0 146 0 60 255 236 0 146 0 61 255 236 0 146 0 130 255 215 0 146 0 131 255 215 0 146 0 132 255 215 0 146 0 133 255 215 0 146 0 134 255 215 0 146 0 135 255 215 0 146 0 159 255 236 0 146 0 194 255 215 0 146 0 196 255 215 0 146 0 198 255 215 0 146 1 36 255 195 0 146 1 38 255 195 0 146 1 54 255 236 0 146 1 56 255 236 0 146 1 58 255 236 0 146 1 59 255 236 0 146 1 61 255 236 0 146 1 63 255 236 0 146 1 67 255 215 0 146 1 160 255 236 0 146 1 250 255 236 0 146 1 252 255 236 0 146 1 254 255 236 0 146 2 0 255 236 0 146 2 8 255 174 0 146 2 12 255 174 0 146 2 88 255 215 0 146 3 29 255 215 0 146 3 31 255 215 0 146 3 33 255 215 0 146 3 35 255 215 0 146 3 37 255 215 0 146 3 39 255 215 0 146 3 41 255 215 0 146 3 43 255 215 0 146 3 45 255 215 0 146 3 47 255 215 0 146 3 49 255 215 0 146 3 51 255 215 0 146 3 111 255 236 0 146 3 113 255 236 0 146 3 115 255 236 0 146 3 143 255 195 0 148 0 15 255 174 0 148 0 17 255 174 0 148 0 36 255 215 0 148 0 55 255 195 0 148 0 57 255 236 0 148 0 58 255 236 0 148 0 59 255 215 0 148 0 60 255 236 0 148 0 61 255 236 0 148 0 130 255 215 0 148 0 131 255 215 0 148 0 132 255 215 0 148 0 133 255 215 0 148 0 134 255 215 0 148 0 135 255 215 0 148 0 159 255 236 0 148 0 194 255 215 0 148 0 196 255 215 0 148 0 198 255 215 0 148 1 36 255 195 0 148 1 38 255 195 0 148 1 54 255 236 0 148 1 56 255 236 0 148 1 58 255 236 0 148 1 59 255 236 0 148 1 61 255 236 0 148 1 63 255 236 0 148 1 67 255 215 0 148 1 160 255 236 0 148 1 250 255 236 0 148 1 252 255 236 0 148 1 254 255 236 0 148 2 0 255 236 0 148 2 8 255 174 0 148 2 12 255 174 0 148 2 88 255 215 0 148 3 29 255 215 0 148 3 31 255 215 0 148 3 33 255 215 0 148 3 35 255 215 0 148 3 37 255 215 0 148 3 39 255 215 0 148 3 41 255 215 0 148 3 43 255 215 0 148 3 45 255 215 0 148 3 47 255 215 0 148 3 49 255 215 0 148 3 51 255 215 0 148 3 111 255 236 0 148 3 113 255 236 0 148 3 115 255 236 0 148 3 143 255 195 0 149 0 15 255 174 0 149 0 17 255 174 0 149 0 36 255 215 0 149 0 55 255 195 0 149 0 57 255 236 0 149 0 58 255 236 0 149 0 59 255 215 0 149 0 60 255 236 0 149 0 61 255 236 0 149 0 130 255 215 0 149 0 131 255 215 0 149 0 132 255 215 0 149 0 133 255 215 0 149 0 134 255 215 0 149 0 135 255 215 0 149 0 159 255 236 0 149 0 194 255 215 0 149 0 196 255 215 0 149 0 198 255 215 0 149 1 36 255 195 0 149 1 38 255 195 0 149 1 54 255 236 0 149 1 56 255 236 0 149 1 58 255 236 0 149 1 59 255 236 0 149 1 61 255 236 0 149 1 63 255 236 0 149 1 67 255 215 0 149 1 160 255 236 0 149 1 250 255 236 0 149 1 252 255 236 0 149 1 254 255 236 0 149 2 0 255 236 0 149 2 8 255 174 0 149 2 12 255 174 0 149 2 88 255 215 0 149 3 29 255 215 0 149 3 31 255 215 0 149 3 33 255 215 0 149 3 35 255 215 0 149 3 37 255 215 0 149 3 39 255 215 0 149 3 41 255 215 0 149 3 43 255 215 0 149 3 45 255 215 0 149 3 47 255 215 0 149 3 49 255 215 0 149 3 51 255 215 0 149 3 111 255 236 0 149 3 113 255 236 0 149 3 115 255 236 0 149 3 143 255 195 0 150 0 15 255 174 0 150 0 17 255 174 0 150 0 36 255 215 0 150 0 55 255 195 0 150 0 57 255 236 0 150 0 58 255 236 0 150 0 59 255 215 0 150 0 60 255 236 0 150 0 61 255 236 0 150 0 130 255 215 0 150 0 131 255 215 0 150 0 132 255 215 0 150 0 133 255 215 0 150 0 134 255 215 0 150 0 135 255 215 0 150 0 159 255 236 0 150 0 194 255 215 0 150 0 196 255 215 0 150 0 198 255 215 0 150 1 36 255 195 0 150 1 38 255 195 0 150 1 54 255 236 0 150 1 56 255 236 0 150 1 58 255 236 0 150 1 59 255 236 0 150 1 61 255 236 0 150 1 63 255 236 0 150 1 67 255 215 0 150 1 160 255 236 0 150 1 250 255 236 0 150 1 252 255 236 0 150 1 254 255 236 0 150 2 0 255 236 0 150 2 8 255 174 0 150 2 12 255 174 0 150 2 88 255 215 0 150 3 29 255 215 0 150 3 31 255 215 0 150 3 33 255 215 0 150 3 35 255 215 0 150 3 37 255 215 0 150 3 39 255 215 0 150 3 41 255 215 0 150 3 43 255 215 0 150 3 45 255 215 0 150 3 47 255 215 0 150 3 49 255 215 0 150 3 51 255 215 0 150 3 111 255 236 0 150 3 113 255 236 0 150 3 115 255 236 0 150 3 143 255 195 0 151 0 15 255 174 0 151 0 17 255 174 0 151 0 36 255 215 0 151 0 55 255 195 0 151 0 57 255 236 0 151 0 58 255 236 0 151 0 59 255 215 0 151 0 60 255 236 0 151 0 61 255 236 0 151 0 130 255 215 0 151 0 131 255 215 0 151 0 132 255 215 0 151 0 133 255 215 0 151 0 134 255 215 0 151 0 135 255 215 0 151 0 159 255 236 0 151 0 194 255 215 0 151 0 196 255 215 0 151 0 198 255 215 0 151 1 36 255 195 0 151 1 38 255 195 0 151 1 54 255 236 0 151 1 56 255 236 0 151 1 58 255 236 0 151 1 59 255 236 0 151 1 61 255 236 0 151 1 63 255 236 0 151 1 67 255 215 0 151 1 160 255 236 0 151 1 250 255 236 0 151 1 252 255 236 0 151 1 254 255 236 0 151 2 0 255 236 0 151 2 8 255 174 0 151 2 12 255 174 0 151 2 88 255 215 0 151 3 29 255 215 0 151 3 31 255 215 0 151 3 33 255 215 0 151 3 35 255 215 0 151 3 37 255 215 0 151 3 39 255 215 0 151 3 41 255 215 0 151 3 43 255 215 0 151 3 45 255 215 0 151 3 47 255 215 0 151 3 49 255 215 0 151 3 51 255 215 0 151 3 111 255 236 0 151 3 113 255 236 0 151 3 115 255 236 0 151 3 143 255 195 0 152 0 15 255 174 0 152 0 17 255 174 0 152 0 36 255 215 0 152 0 55 255 195 0 152 0 57 255 236 0 152 0 58 255 236 0 152 0 59 255 215 0 152 0 60 255 236 0 152 0 61 255 236 0 152 0 130 255 215 0 152 0 131 255 215 0 152 0 132 255 215 0 152 0 133 255 215 0 152 0 134 255 215 0 152 0 135 255 215 0 152 0 159 255 236 0 152 0 194 255 215 0 152 0 196 255 215 0 152 0 198 255 215 0 152 1 36 255 195 0 152 1 38 255 195 0 152 1 54 255 236 0 152 1 56 255 236 0 152 1 58 255 236 0 152 1 59 255 236 0 152 1 61 255 236 0 152 1 63 255 236 0 152 1 67 255 215 0 152 1 160 255 236 0 152 1 250 255 236 0 152 1 252 255 236 0 152 1 254 255 236 0 152 2 0 255 236 0 152 2 8 255 174 0 152 2 12 255 174 0 152 2 88 255 215 0 152 3 29 255 215 0 152 3 31 255 215 0 152 3 33 255 215 0 152 3 35 255 215 0 152 3 37 255 215 0 152 3 39 255 215 0 152 3 41 255 215 0 152 3 43 255 215 0 152 3 45 255 215 0 152 3 47 255 215 0 152 3 49 255 215 0 152 3 51 255 215 0 152 3 111 255 236 0 152 3 113 255 236 0 152 3 115 255 236 0 152 3 143 255 195 0 154 0 15 255 174 0 154 0 17 255 174 0 154 0 36 255 215 0 154 0 55 255 195 0 154 0 57 255 236 0 154 0 58 255 236 0 154 0 59 255 215 0 154 0 60 255 236 0 154 0 61 255 236 0 154 0 130 255 215 0 154 0 131 255 215 0 154 0 132 255 215 0 154 0 133 255 215 0 154 0 134 255 215 0 154 0 135 255 215 0 154 0 159 255 236 0 154 0 194 255 215 0 154 0 196 255 215 0 154 0 198 255 215 0 154 1 36 255 195 0 154 1 38 255 195 0 154 1 54 255 236 0 154 1 56 255 236 0 154 1 58 255 236 0 154 1 59 255 236 0 154 1 61 255 236 0 154 1 63 255 236 0 154 1 67 255 215 0 154 1 160 255 236 0 154 1 250 255 236 0 154 1 252 255 236 0 154 1 254 255 236 0 154 2 0 255 236 0 154 2 8 255 174 0 154 2 12 255 174 0 154 2 88 255 215 0 154 3 29 255 215 0 154 3 31 255 215 0 154 3 33 255 215 0 154 3 35 255 215 0 154 3 37 255 215 0 154 3 39 255 215 0 154 3 41 255 215 0 154 3 43 255 215 0 154 3 45 255 215 0 154 3 47 255 215 0 154 3 49 255 215 0 154 3 51 255 215 0 154 3 111 255 236 0 154 3 113 255 236 0 154 3 115 255 236 0 154 3 143 255 195 0 155 0 15 255 215 0 155 0 17 255 215 0 155 0 36 255 236 0 155 0 130 255 236 0 155 0 131 255 236 0 155 0 132 255 236 0 155 0 133 255 236 0 155 0 134 255 236 0 155 0 135 255 236 0 155 0 194 255 236 0 155 0 196 255 236 0 155 0 198 255 236 0 155 1 67 255 236 0 155 2 8 255 215 0 155 2 12 255 215 0 155 2 88 255 236 0 155 3 29 255 236 0 155 3 31 255 236 0 155 3 33 255 236 0 155 3 35 255 236 0 155 3 37 255 236 0 155 3 39 255 236 0 155 3 41 255 236 0 155 3 43 255 236 0 155 3 45 255 236 0 155 3 47 255 236 0 155 3 49 255 236 0 155 3 51 255 236 0 156 0 15 255 215 0 156 0 17 255 215 0 156 0 36 255 236 0 156 0 130 255 236 0 156 0 131 255 236 0 156 0 132 255 236 0 156 0 133 255 236 0 156 0 134 255 236 0 156 0 135 255 236 0 156 0 194 255 236 0 156 0 196 255 236 0 156 0 198 255 236 0 156 1 67 255 236 0 156 2 8 255 215 0 156 2 12 255 215 0 156 2 88 255 236 0 156 3 29 255 236 0 156 3 31 255 236 0 156 3 33 255 236 0 156 3 35 255 236 0 156 3 37 255 236 0 156 3 39 255 236 0 156 3 41 255 236 0 156 3 43 255 236 0 156 3 45 255 236 0 156 3 47 255 236 0 156 3 49 255 236 0 156 3 51 255 236 0 157 0 15 255 215 0 157 0 17 255 215 0 157 0 36 255 236 0 157 0 130 255 236 0 157 0 131 255 236 0 157 0 132 255 236 0 157 0 133 255 236 0 157 0 134 255 236 0 157 0 135 255 236 0 157 0 194 255 236 0 157 0 196 255 236 0 157 0 198 255 236 0 157 1 67 255 236 0 157 2 8 255 215 0 157 2 12 255 215 0 157 2 88 255 236 0 157 3 29 255 236 0 157 3 31 255 236 0 157 3 33 255 236 0 157 3 35 255 236 0 157 3 37 255 236 0 157 3 39 255 236 0 157 3 41 255 236 0 157 3 43 255 236 0 157 3 45 255 236 0 157 3 47 255 236 0 157 3 49 255 236 0 157 3 51 255 236 0 158 0 15 255 215 0 158 0 17 255 215 0 158 0 36 255 236 0 158 0 130 255 236 0 158 0 131 255 236 0 158 0 132 255 236 0 158 0 133 255 236 0 158 0 134 255 236 0 158 0 135 255 236 0 158 0 194 255 236 0 158 0 196 255 236 0 158 0 198 255 236 0 158 1 67 255 236 0 158 2 8 255 215 0 158 2 12 255 215 0 158 2 88 255 236 0 158 3 29 255 236 0 158 3 31 255 236 0 158 3 33 255 236 0 158 3 35 255 236 0 158 3 37 255 236 0 158 3 39 255 236 0 158 3 41 255 236 0 158 3 43 255 236 0 158 3 45 255 236 0 158 3 47 255 236 0 158 3 49 255 236 0 158 3 51 255 236 0 159 0 15 255 133 0 159 0 17 255 133 0 159 0 34 0 41 0 159 0 36 255 133 0 159 0 38 255 215 0 159 0 42 255 215 0 159 0 50 255 215 0 159 0 52 255 215 0 159 0 68 255 154 0 159 0 70 255 154 0 159 0 71 255 154 0 159 0 72 255 154 0 159 0 74 255 215 0 159 0 80 255 195 0 159 0 81 255 195 0 159 0 82 255 154 0 159 0 83 255 195 0 159 0 84 255 154 0 159 0 85 255 195 0 159 0 86 255 174 0 159 0 88 255 195 0 159 0 93 255 215 0 159 0 130 255 133 0 159 0 131 255 133 0 159 0 132 255 133 0 159 0 133 255 133 0 159 0 134 255 133 0 159 0 135 255 133 0 159 0 137 255 215 0 159 0 148 255 215 0 159 0 149 255 215 0 159 0 150 255 215 0 159 0 151 255 215 0 159 0 152 255 215 0 159 0 154 255 215 0 159 0 162 255 154 0 159 0 163 255 154 0 159 0 164 255 154 0 159 0 165 255 154 0 159 0 166 255 154 0 159 0 167 255 154 0 159 0 168 255 154 0 159 0 169 255 154 0 159 0 170 255 154 0 159 0 171 255 154 0 159 0 172 255 154 0 159 0 173 255 154 0 159 0 180 255 154 0 159 0 181 255 154 0 159 0 182 255 154 0 159 0 183 255 154 0 159 0 184 255 154 0 159 0 186 255 154 0 159 0 187 255 195 0 159 0 188 255 195 0 159 0 189 255 195 0 159 0 190 255 195 0 159 0 194 255 133 0 159 0 195 255 154 0 159 0 196 255 133 0 159 0 197 255 154 0 159 0 198 255 133 0 159 0 199 255 154 0 159 0 200 255 215 0 159 0 201 255 154 0 159 0 202 255 215 0 159 0 203 255 154 0 159 0 204 255 215 0 159 0 205 255 154 0 159 0 206 255 215 0 159 0 207 255 154 0 159 0 209 255 154 0 159 0 211 255 154 0 159 0 213 255 154 0 159 0 215 255 154 0 159 0 217 255 154 0 159 0 219 255 154 0 159 0 221 255 154 0 159 0 222 255 215 0 159 0 223 255 215 0 159 0 224 255 215 0 159 0 225 255 215 0 159 0 226 255 215 0 159 0 227 255 215 0 159 0 228 255 215 0 159 0 229 255 215 0 159 0 250 255 195 0 159 1 6 255 195 0 159 1 8 255 195 0 159 1 13 255 195 0 159 1 14 255 215 0 159 1 15 255 154 0 159 1 16 255 215 0 159 1 17 255 154 0 159 1 18 255 215 0 159 1 19 255 154 0 159 1 20 255 215 0 159 1 21 255 154 0 159 1 23 255 195 0 159 1 25 255 195 0 159 1 29 255 174 0 159 1 33 255 174 0 159 1 43 255 195 0 159 1 45 255 195 0 159 1 47 255 195 0 159 1 49 255 195 0 159 1 51 255 195 0 159 1 53 255 195 0 159 1 60 255 215 0 159 1 62 255 215 0 159 1 64 255 215 0 159 1 67 255 133 0 159 1 68 255 154 0 159 1 70 255 154 0 159 1 71 255 215 0 159 1 72 255 154 0 159 1 74 255 174 0 159 2 8 255 133 0 159 2 12 255 133 0 159 2 87 255 195 0 159 2 88 255 133 0 159 2 89 255 154 0 159 2 95 255 215 0 159 2 96 255 154 0 159 2 98 255 195 0 159 3 29 255 133 0 159 3 30 255 154 0 159 3 31 255 133 0 159 3 32 255 154 0 159 3 33 255 133 0 159 3 34 255 154 0 159 3 35 255 133 0 159 3 37 255 133 0 159 3 38 255 154 0 159 3 39 255 133 0 159 3 40 255 154 0 159 3 41 255 133 0 159 3 42 255 154 0 159 3 43 255 133 0 159 3 44 255 154 0 159 3 45 255 133 0 159 3 46 255 154 0 159 3 47 255 133 0 159 3 48 255 154 0 159 3 49 255 133 0 159 3 50 255 154 0 159 3 51 255 133 0 159 3 52 255 154 0 159 3 54 255 154 0 159 3 56 255 154 0 159 3 58 255 154 0 159 3 60 255 154 0 159 3 64 255 154 0 159 3 66 255 154 0 159 3 68 255 154 0 159 3 73 255 215 0 159 3 74 255 154 0 159 3 75 255 215 0 159 3 76 255 154 0 159 3 77 255 215 0 159 3 78 255 154 0 159 3 79 255 215 0 159 3 81 255 215 0 159 3 82 255 154 0 159 3 83 255 215 0 159 3 84 255 154 0 159 3 85 255 215 0 159 3 86 255 154 0 159 3 87 255 215 0 159 3 88 255 154 0 159 3 89 255 215 0 159 3 90 255 154 0 159 3 91 255 215 0 159 3 92 255 154 0 159 3 93 255 215 0 159 3 94 255 154 0 159 3 95 255 215 0 159 3 96 255 154 0 159 3 98 255 195 0 159 3 100 255 195 0 159 3 102 255 195 0 159 3 104 255 195 0 159 3 106 255 195 0 159 3 108 255 195 0 159 3 110 255 195 0 160 0 15 254 246 0 160 0 17 254 246 0 160 0 36 255 154 0 160 0 59 255 215 0 160 0 61 255 236 0 160 0 130 255 154 0 160 0 131 255 154 0 160 0 132 255 154 0 160 0 133 255 154 0 160 0 134 255 154 0 160 0 135 255 154 0 160 0 194 255 154 0 160 0 196 255 154 0 160 0 198 255 154 0 160 1 59 255 236 0 160 1 61 255 236 0 160 1 63 255 236 0 160 1 67 255 154 0 160 2 8 254 246 0 160 2 12 254 246 0 160 2 88 255 154 0 160 3 29 255 154 0 160 3 31 255 154 0 160 3 33 255 154 0 160 3 35 255 154 0 160 3 37 255 154 0 160 3 39 255 154 0 160 3 41 255 154 0 160 3 43 255 154 0 160 3 45 255 154 0 160 3 47 255 154 0 160 3 49 255 154 0 160 3 51 255 154 0 162 0 5 255 236 0 162 0 10 255 236 0 162 2 7 255 236 0 162 2 11 255 236 0 163 0 5 255 236 0 163 0 10 255 236 0 163 2 7 255 236 0 163 2 11 255 236 0 164 0 5 255 236 0 164 0 10 255 236 0 164 2 7 255 236 0 164 2 11 255 236 0 165 0 5 255 236 0 165 0 10 255 236 0 165 2 7 255 236 0 165 2 11 255 236 0 166 0 5 255 236 0 166 0 10 255 236 0 166 2 7 255 236 0 166 2 11 255 236 0 167 0 5 255 236 0 167 0 10 255 236 0 167 2 7 255 236 0 167 2 11 255 236 0 170 0 5 255 236 0 170 0 10 255 236 0 170 0 89 255 215 0 170 0 90 255 215 0 170 0 91 255 215 0 170 0 92 255 215 0 170 0 93 255 236 0 170 0 191 255 215 0 170 1 55 255 215 0 170 1 60 255 236 0 170 1 62 255 236 0 170 1 64 255 236 0 170 1 251 255 215 0 170 1 253 255 215 0 170 2 7 255 236 0 170 2 11 255 236 0 170 3 112 255 215 0 171 0 5 255 236 0 171 0 10 255 236 0 171 0 89 255 215 0 171 0 90 255 215 0 171 0 91 255 215 0 171 0 92 255 215 0 171 0 93 255 236 0 171 0 191 255 215 0 171 1 55 255 215 0 171 1 60 255 236 0 171 1 62 255 236 0 171 1 64 255 236 0 171 1 251 255 215 0 171 1 253 255 215 0 171 2 7 255 236 0 171 2 11 255 236 0 171 3 112 255 215 0 172 0 5 255 236 0 172 0 10 255 236 0 172 0 89 255 215 0 172 0 90 255 215 0 172 0 91 255 215 0 172 0 92 255 215 0 172 0 93 255 236 0 172 0 191 255 215 0 172 1 55 255 215 0 172 1 60 255 236 0 172 1 62 255 236 0 172 1 64 255 236 0 172 1 251 255 215 0 172 1 253 255 215 0 172 2 7 255 236 0 172 2 11 255 236 0 172 3 112 255 215 0 173 0 5 255 236 0 173 0 10 255 236 0 173 0 89 255 215 0 173 0 90 255 215 0 173 0 91 255 215 0 173 0 92 255 215 0 173 0 93 255 236 0 173 0 191 255 215 0 173 1 55 255 215 0 173 1 60 255 236 0 173 1 62 255 236 0 173 1 64 255 236 0 173 1 251 255 215 0 173 1 253 255 215 0 173 2 7 255 236 0 173 2 11 255 236 0 173 3 112 255 215 0 178 0 5 255 236 0 178 0 10 255 236 0 178 0 89 255 215 0 178 0 90 255 215 0 178 0 91 255 215 0 178 0 92 255 215 0 178 0 93 255 236 0 178 0 191 255 215 0 178 1 55 255 215 0 178 1 60 255 236 0 178 1 62 255 236 0 178 1 64 255 236 0 178 1 251 255 215 0 178 1 253 255 215 0 178 2 7 255 236 0 178 2 11 255 236 0 178 3 112 255 215 0 180 0 5 255 236 0 180 0 10 255 236 0 180 0 89 255 215 0 180 0 90 255 215 0 180 0 91 255 215 0 180 0 92 255 215 0 180 0 93 255 236 0 180 0 191 255 215 0 180 1 55 255 215 0 180 1 60 255 236 0 180 1 62 255 236 0 180 1 64 255 236 0 180 1 251 255 215 0 180 1 253 255 215 0 180 2 7 255 236 0 180 2 11 255 236 0 180 3 112 255 215 0 181 0 5 255 236 0 181 0 10 255 236 0 181 0 89 255 215 0 181 0 90 255 215 0 181 0 91 255 215 0 181 0 92 255 215 0 181 0 93 255 236 0 181 0 191 255 215 0 181 1 55 255 215 0 181 1 60 255 236 0 181 1 62 255 236 0 181 1 64 255 236 0 181 1 251 255 215 0 181 1 253 255 215 0 181 2 7 255 236 0 181 2 11 255 236 0 181 3 112 255 215 0 182 0 5 255 236 0 182 0 10 255 236 0 182 0 89 255 215 0 182 0 90 255 215 0 182 0 91 255 215 0 182 0 92 255 215 0 182 0 93 255 236 0 182 0 191 255 215 0 182 1 55 255 215 0 182 1 60 255 236 0 182 1 62 255 236 0 182 1 64 255 236 0 182 1 251 255 215 0 182 1 253 255 215 0 182 2 7 255 236 0 182 2 11 255 236 0 182 3 112 255 215 0 184 0 5 255 215 0 184 0 10 255 215 0 184 2 7 255 215 0 184 2 11 255 215 0 186 0 5 255 236 0 186 0 10 255 236 0 186 0 89 255 215 0 186 0 90 255 215 0 186 0 91 255 215 0 186 0 92 255 215 0 186 0 93 255 236 0 186 0 191 255 215 0 186 1 55 255 215 0 186 1 60 255 236 0 186 1 62 255 236 0 186 1 64 255 236 0 186 1 251 255 215 0 186 1 253 255 215 0 186 2 7 255 236 0 186 2 11 255 236 0 186 3 112 255 215 0 191 0 5 0 82 0 191 0 10 0 82 0 191 0 15 255 174 0 191 0 17 255 174 0 191 0 34 0 41 0 191 2 7 0 82 0 191 2 8 255 174 0 191 2 11 0 82 0 191 2 12 255 174 0 192 0 5 255 236 0 192 0 10 255 236 0 192 0 89 255 215 0 192 0 90 255 215 0 192 0 91 255 215 0 192 0 92 255 215 0 192 0 93 255 236 0 192 0 191 255 215 0 192 1 55 255 215 0 192 1 60 255 236 0 192 1 62 255 236 0 192 1 64 255 236 0 192 1 251 255 215 0 192 1 253 255 215 0 192 2 7 255 236 0 192 2 11 255 236 0 192 3 112 255 215 0 193 0 5 0 82 0 193 0 10 0 82 0 193 0 15 255 174 0 193 0 17 255 174 0 193 0 34 0 41 0 193 2 7 0 82 0 193 2 8 255 174 0 193 2 11 0 82 0 193 2 12 255 174 0 194 0 5 255 113 0 194 0 10 255 113 0 194 0 38 255 215 0 194 0 42 255 215 0 194 0 45 1 10 0 194 0 50 255 215 0 194 0 52 255 215 0 194 0 55 255 113 0 194 0 57 255 174 0 194 0 58 255 174 0 194 0 60 255 133 0 194 0 137 255 215 0 194 0 148 255 215 0 194 0 149 255 215 0 194 0 150 255 215 0 194 0 151 255 215 0 194 0 152 255 215 0 194 0 154 255 215 0 194 0 159 255 133 0 194 0 200 255 215 0 194 0 202 255 215 0 194 0 204 255 215 0 194 0 206 255 215 0 194 0 222 255 215 0 194 0 224 255 215 0 194 0 226 255 215 0 194 0 228 255 215 0 194 1 14 255 215 0 194 1 16 255 215 0 194 1 18 255 215 0 194 1 20 255 215 0 194 1 36 255 113 0 194 1 38 255 113 0 194 1 54 255 174 0 194 1 56 255 133 0 194 1 58 255 133 0 194 1 71 255 215 0 194 1 250 255 174 0 194 1 252 255 174 0 194 1 254 255 174 0 194 2 0 255 133 0 194 2 7 255 113 0 194 2 11 255 113 0 194 2 95 255 215 0 194 3 73 255 215 0 194 3 75 255 215 0 194 3 77 255 215 0 194 3 79 255 215 0 194 3 81 255 215 0 194 3 83 255 215 0 194 3 85 255 215 0 194 3 87 255 215 0 194 3 89 255 215 0 194 3 91 255 215 0 194 3 93 255 215 0 194 3 95 255 215 0 194 3 111 255 133 0 194 3 113 255 133 0 194 3 115 255 133 0 194 3 143 255 113 0 195 0 5 255 236 0 195 0 10 255 236 0 195 2 7 255 236 0 195 2 11 255 236 0 196 0 5 255 113 0 196 0 10 255 113 0 196 0 38 255 215 0 196 0 42 255 215 0 196 0 45 1 10 0 196 0 50 255 215 0 196 0 52 255 215 0 196 0 55 255 113 0 196 0 57 255 174 0 196 0 58 255 174 0 196 0 60 255 133 0 196 0 137 255 215 0 196 0 148 255 215 0 196 0 149 255 215 0 196 0 150 255 215 0 196 0 151 255 215 0 196 0 152 255 215 0 196 0 154 255 215 0 196 0 159 255 133 0 196 0 200 255 215 0 196 0 202 255 215 0 196 0 204 255 215 0 196 0 206 255 215 0 196 0 222 255 215 0 196 0 224 255 215 0 196 0 226 255 215 0 196 0 228 255 215 0 196 1 14 255 215 0 196 1 16 255 215 0 196 1 18 255 215 0 196 1 20 255 215 0 196 1 36 255 113 0 196 1 38 255 113 0 196 1 54 255 174 0 196 1 56 255 133 0 196 1 58 255 133 0 196 1 71 255 215 0 196 1 250 255 174 0 196 1 252 255 174 0 196 1 254 255 174 0 196 2 0 255 133 0 196 2 7 255 113 0 196 2 11 255 113 0 196 2 95 255 215 0 196 3 73 255 215 0 196 3 75 255 215 0 196 3 77 255 215 0 196 3 79 255 215 0 196 3 81 255 215 0 196 3 83 255 215 0 196 3 85 255 215 0 196 3 87 255 215 0 196 3 89 255 215 0 196 3 91 255 215 0 196 3 93 255 215 0 196 3 95 255 215 0 196 3 111 255 133 0 196 3 113 255 133 0 196 3 115 255 133 0 196 3 143 255 113 0 197 0 5 255 236 0 197 0 10 255 236 0 197 2 7 255 236 0 197 2 11 255 236 0 198 0 5 255 113 0 198 0 10 255 113 0 198 0 38 255 215 0 198 0 42 255 215 0 198 0 45 1 10 0 198 0 50 255 215 0 198 0 52 255 215 0 198 0 55 255 113 0 198 0 57 255 174 0 198 0 58 255 174 0 198 0 60 255 133 0 198 0 137 255 215 0 198 0 148 255 215 0 198 0 149 255 215 0 198 0 150 255 215 0 198 0 151 255 215 0 198 0 152 255 215 0 198 0 154 255 215 0 198 0 159 255 133 0 198 0 200 255 215 0 198 0 202 255 215 0 198 0 204 255 215 0 198 0 206 255 215 0 198 0 222 255 215 0 198 0 224 255 215 0 198 0 226 255 215 0 198 0 228 255 215 0 198 1 14 255 215 0 198 1 16 255 215 0 198 1 18 255 215 0 198 1 20 255 215 0 198 1 36 255 113 0 198 1 38 255 113 0 198 1 54 255 174 0 198 1 56 255 133 0 198 1 58 255 133 0 198 1 71 255 215 0 198 1 250 255 174 0 198 1 252 255 174 0 198 1 254 255 174 0 198 2 0 255 133 0 198 2 7 255 113 0 198 2 11 255 113 0 198 2 95 255 215 0 198 3 73 255 215 0 198 3 75 255 215 0 198 3 77 255 215 0 198 3 79 255 215 0 198 3 81 255 215 0 198 3 83 255 215 0 198 3 85 255 215 0 198 3 87 255 215 0 198 3 89 255 215 0 198 3 91 255 215 0 198 3 93 255 215 0 198 3 95 255 215 0 198 3 111 255 133 0 198 3 113 255 133 0 198 3 115 255 133 0 198 3 143 255 113 0 199 0 5 255 236 0 199 0 10 255 236 0 199 2 7 255 236 0 199 2 11 255 236 0 200 0 38 255 215 0 200 0 42 255 215 0 200 0 50 255 215 0 200 0 52 255 215 0 200 0 137 255 215 0 200 0 148 255 215 0 200 0 149 255 215 0 200 0 150 255 215 0 200 0 151 255 215 0 200 0 152 255 215 0 200 0 154 255 215 0 200 0 200 255 215 0 200 0 202 255 215 0 200 0 204 255 215 0 200 0 206 255 215 0 200 0 222 255 215 0 200 0 224 255 215 0 200 0 226 255 215 0 200 0 228 255 215 0 200 1 14 255 215 0 200 1 16 255 215 0 200 1 18 255 215 0 200 1 20 255 215 0 200 1 71 255 215 0 200 2 95 255 215 0 200 3 73 255 215 0 200 3 75 255 215 0 200 3 77 255 215 0 200 3 79 255 215 0 200 3 81 255 215 0 200 3 83 255 215 0 200 3 85 255 215 0 200 3 87 255 215 0 200 3 89 255 215 0 200 3 91 255 215 0 200 3 93 255 215 0 200 3 95 255 215 0 202 0 38 255 215 0 202 0 42 255 215 0 202 0 50 255 215 0 202 0 52 255 215 0 202 0 137 255 215 0 202 0 148 255 215 0 202 0 149 255 215 0 202 0 150 255 215 0 202 0 151 255 215 0 202 0 152 255 215 0 202 0 154 255 215 0 202 0 200 255 215 0 202 0 202 255 215 0 202 0 204 255 215 0 202 0 206 255 215 0 202 0 222 255 215 0 202 0 224 255 215 0 202 0 226 255 215 0 202 0 228 255 215 0 202 1 14 255 215 0 202 1 16 255 215 0 202 1 18 255 215 0 202 1 20 255 215 0 202 1 71 255 215 0 202 2 95 255 215 0 202 3 73 255 215 0 202 3 75 255 215 0 202 3 77 255 215 0 202 3 79 255 215 0 202 3 81 255 215 0 202 3 83 255 215 0 202 3 85 255 215 0 202 3 87 255 215 0 202 3 89 255 215 0 202 3 91 255 215 0 202 3 93 255 215 0 202 3 95 255 215 0 204 0 38 255 215 0 204 0 42 255 215 0 204 0 50 255 215 0 204 0 52 255 215 0 204 0 137 255 215 0 204 0 148 255 215 0 204 0 149 255 215 0 204 0 150 255 215 0 204 0 151 255 215 0 204 0 152 255 215 0 204 0 154 255 215 0 204 0 200 255 215 0 204 0 202 255 215 0 204 0 204 255 215 0 204 0 206 255 215 0 204 0 222 255 215 0 204 0 224 255 215 0 204 0 226 255 215 0 204 0 228 255 215 0 204 1 14 255 215 0 204 1 16 255 215 0 204 1 18 255 215 0 204 1 20 255 215 0 204 1 71 255 215 0 204 2 95 255 215 0 204 3 73 255 215 0 204 3 75 255 215 0 204 3 77 255 215 0 204 3 79 255 215 0 204 3 81 255 215 0 204 3 83 255 215 0 204 3 85 255 215 0 204 3 87 255 215 0 204 3 89 255 215 0 204 3 91 255 215 0 204 3 93 255 215 0 204 3 95 255 215 0 206 0 38 255 215 0 206 0 42 255 215 0 206 0 50 255 215 0 206 0 52 255 215 0 206 0 137 255 215 0 206 0 148 255 215 0 206 0 149 255 215 0 206 0 150 255 215 0 206 0 151 255 215 0 206 0 152 255 215 0 206 0 154 255 215 0 206 0 200 255 215 0 206 0 202 255 215 0 206 0 204 255 215 0 206 0 206 255 215 0 206 0 222 255 215 0 206 0 224 255 215 0 206 0 226 255 215 0 206 0 228 255 215 0 206 1 14 255 215 0 206 1 16 255 215 0 206 1 18 255 215 0 206 1 20 255 215 0 206 1 71 255 215 0 206 2 95 255 215 0 206 3 73 255 215 0 206 3 75 255 215 0 206 3 77 255 215 0 206 3 79 255 215 0 206 3 81 255 215 0 206 3 83 255 215 0 206 3 85 255 215 0 206 3 87 255 215 0 206 3 89 255 215 0 206 3 91 255 215 0 206 3 93 255 215 0 206 3 95 255 215 0 208 0 15 255 174 0 208 0 17 255 174 0 208 0 36 255 215 0 208 0 55 255 195 0 208 0 57 255 236 0 208 0 58 255 236 0 208 0 59 255 215 0 208 0 60 255 236 0 208 0 61 255 236 0 208 0 130 255 215 0 208 0 131 255 215 0 208 0 132 255 215 0 208 0 133 255 215 0 208 0 134 255 215 0 208 0 135 255 215 0 208 0 159 255 236 0 208 0 194 255 215 0 208 0 196 255 215 0 208 0 198 255 215 0 208 1 36 255 195 0 208 1 38 255 195 0 208 1 54 255 236 0 208 1 56 255 236 0 208 1 58 255 236 0 208 1 59 255 236 0 208 1 61 255 236 0 208 1 63 255 236 0 208 1 67 255 215 0 208 1 160 255 236 0 208 1 250 255 236 0 208 1 252 255 236 0 208 1 254 255 236 0 208 2 0 255 236 0 208 2 8 255 174 0 208 2 12 255 174 0 208 2 88 255 215 0 208 3 29 255 215 0 208 3 31 255 215 0 208 3 33 255 215 0 208 3 35 255 215 0 208 3 37 255 215 0 208 3 39 255 215 0 208 3 41 255 215 0 208 3 43 255 215 0 208 3 45 255 215 0 208 3 47 255 215 0 208 3 49 255 215 0 208 3 51 255 215 0 208 3 111 255 236 0 208 3 113 255 236 0 208 3 115 255 236 0 208 3 143 255 195 0 209 0 5 0 82 0 209 0 10 0 82 0 209 0 12 0 143 0 209 0 34 0 164 0 209 0 64 0 143 0 209 0 69 0 61 0 209 0 75 0 61 0 209 0 78 0 61 0 209 0 79 0 61 0 209 0 96 0 143 0 209 0 231 0 61 0 209 0 233 0 123 0 209 2 7 0 82 0 209 2 11 0 82 0 210 0 15 255 174 0 210 0 17 255 174 0 210 0 36 255 215 0 210 0 55 255 195 0 210 0 57 255 236 0 210 0 58 255 236 0 210 0 59 255 215 0 210 0 60 255 236 0 210 0 61 255 236 0 210 0 130 255 215 0 210 0 131 255 215 0 210 0 132 255 215 0 210 0 133 255 215 0 210 0 134 255 215 0 210 0 135 255 215 0 210 0 159 255 236 0 210 0 194 255 215 0 210 0 196 255 215 0 210 0 198 255 215 0 210 1 36 255 195 0 210 1 38 255 195 0 210 1 54 255 236 0 210 1 56 255 236 0 210 1 58 255 236 0 210 1 59 255 236 0 210 1 61 255 236 0 210 1 63 255 236 0 210 1 67 255 215 0 210 1 160 255 236 0 210 1 250 255 236 0 210 1 252 255 236 0 210 1 254 255 236 0 210 2 0 255 236 0 210 2 8 255 174 0 210 2 12 255 174 0 210 2 88 255 215 0 210 3 29 255 215 0 210 3 31 255 215 0 210 3 33 255 215 0 210 3 35 255 215 0 210 3 37 255 215 0 210 3 39 255 215 0 210 3 41 255 215 0 210 3 43 255 215 0 210 3 45 255 215 0 210 3 47 255 215 0 210 3 49 255 215 0 210 3 51 255 215 0 210 3 111 255 236 0 210 3 113 255 236 0 210 3 115 255 236 0 210 3 143 255 195 0 212 0 45 0 123 0 213 0 5 255 236 0 213 0 10 255 236 0 213 0 89 255 215 0 213 0 90 255 215 0 213 0 91 255 215 0 213 0 92 255 215 0 213 0 93 255 236 0 213 0 191 255 215 0 213 1 55 255 215 0 213 1 60 255 236 0 213 1 62 255 236 0 213 1 64 255 236 0 213 1 251 255 215 0 213 1 253 255 215 0 213 2 7 255 236 0 213 2 11 255 236 0 213 3 112 255 215 0 214 0 45 0 123 0 215 0 5 255 236 0 215 0 10 255 236 0 215 0 89 255 215 0 215 0 90 255 215 0 215 0 91 255 215 0 215 0 92 255 215 0 215 0 93 255 236 0 215 0 191 255 215 0 215 1 55 255 215 0 215 1 60 255 236 0 215 1 62 255 236 0 215 1 64 255 236 0 215 1 251 255 215 0 215 1 253 255 215 0 215 2 7 255 236 0 215 2 11 255 236 0 215 3 112 255 215 0 216 0 45 0 123 0 217 0 5 255 236 0 217 0 10 255 236 0 217 0 89 255 215 0 217 0 90 255 215 0 217 0 91 255 215 0 217 0 92 255 215 0 217 0 93 255 236 0 217 0 191 255 215 0 217 1 55 255 215 0 217 1 60 255 236 0 217 1 62 255 236 0 217 1 64 255 236 0 217 1 251 255 215 0 217 1 253 255 215 0 217 2 7 255 236 0 217 2 11 255 236 0 217 3 112 255 215 0 218 0 45 0 123 0 219 0 5 255 236 0 219 0 10 255 236 0 219 0 89 255 215 0 219 0 90 255 215 0 219 0 91 255 215 0 219 0 92 255 215 0 219 0 93 255 236 0 219 0 191 255 215 0 219 1 55 255 215 0 219 1 60 255 236 0 219 1 62 255 236 0 219 1 64 255 236 0 219 1 251 255 215 0 219 1 253 255 215 0 219 2 7 255 236 0 219 2 11 255 236 0 219 3 112 255 215 0 220 0 45 0 123 0 221 0 5 255 236 0 221 0 10 255 236 0 221 0 89 255 215 0 221 0 90 255 215 0 221 0 91 255 215 0 221 0 92 255 215 0 221 0 93 255 236 0 221 0 191 255 215 0 221 1 55 255 215 0 221 1 60 255 236 0 221 1 62 255 236 0 221 1 64 255 236 0 221 1 251 255 215 0 221 1 253 255 215 0 221 2 7 255 236 0 221 2 11 255 236 0 221 3 112 255 215 0 231 0 5 255 236 0 231 0 10 255 236 0 231 2 7 255 236 0 231 2 11 255 236 0 248 0 38 255 215 0 248 0 42 255 215 0 248 0 50 255 215 0 248 0 52 255 215 0 248 0 137 255 215 0 248 0 148 255 215 0 248 0 149 255 215 0 248 0 150 255 215 0 248 0 151 255 215 0 248 0 152 255 215 0 248 0 154 255 215 0 248 0 200 255 215 0 248 0 202 255 215 0 248 0 204 255 215 0 248 0 206 255 215 0 248 0 222 255 215 0 248 0 224 255 215 0 248 0 226 255 215 0 248 0 228 255 215 0 248 1 14 255 215 0 248 1 16 255 215 0 248 1 18 255 215 0 248 1 20 255 215 0 248 1 71 255 215 0 248 2 95 255 215 0 248 3 73 255 215 0 248 3 75 255 215 0 248 3 77 255 215 0 248 3 79 255 215 0 248 3 81 255 215 0 248 3 83 255 215 0 248 3 85 255 215 0 248 3 87 255 215 0 248 3 89 255 215 0 248 3 91 255 215 0 248 3 93 255 215 0 248 3 95 255 215 0 249 0 70 255 215 0 249 0 71 255 215 0 249 0 72 255 215 0 249 0 82 255 215 0 249 0 84 255 215 0 249 0 162 255 215 0 249 0 169 255 215 0 249 0 170 255 215 0 249 0 171 255 215 0 249 0 172 255 215 0 249 0 173 255 215 0 249 0 180 255 215 0 249 0 181 255 215 0 249 0 182 255 215 0 249 0 183 255 215 0 249 0 184 255 215 0 249 0 186 255 215 0 249 0 201 255 215 0 249 0 203 255 215 0 249 0 205 255 215 0 249 0 207 255 215 0 249 0 209 255 215 0 249 0 211 255 215 0 249 0 213 255 215 0 249 0 215 255 215 0 249 0 217 255 215 0 249 0 219 255 215 0 249 0 221 255 215 0 249 1 15 255 215 0 249 1 17 255 215 0 249 1 19 255 215 0 249 1 21 255 215 0 249 1 72 255 215 0 249 2 96 255 215 0 249 3 54 255 215 0 249 3 56 255 215 0 249 3 58 255 215 0 249 3 60 255 215 0 249 3 64 255 215 0 249 3 66 255 215 0 249 3 68 255 215 0 249 3 74 255 215 0 249 3 76 255 215 0 249 3 78 255 215 0 249 3 82 255 215 0 249 3 84 255 215 0 249 3 86 255 215 0 249 3 88 255 215 0 249 3 90 255 215 0 249 3 92 255 215 0 249 3 94 255 215 0 249 3 96 255 215 0 250 0 70 255 215 0 250 0 71 255 215 0 250 0 72 255 215 0 250 0 82 255 215 0 250 0 84 255 215 0 250 0 162 255 215 0 250 0 169 255 215 0 250 0 170 255 215 0 250 0 171 255 215 0 250 0 172 255 215 0 250 0 173 255 215 0 250 0 180 255 215 0 250 0 181 255 215 0 250 0 182 255 215 0 250 0 183 255 215 0 250 0 184 255 215 0 250 0 186 255 215 0 250 0 201 255 215 0 250 0 203 255 215 0 250 0 205 255 215 0 250 0 207 255 215 0 250 0 209 255 215 0 250 0 211 255 215 0 250 0 213 255 215 0 250 0 215 255 215 0 250 0 217 255 215 0 250 0 219 255 215 0 250 0 221 255 215 0 250 1 15 255 215 0 250 1 17 255 215 0 250 1 19 255 215 0 250 1 21 255 215 0 250 1 72 255 215 0 250 2 96 255 215 0 250 3 54 255 215 0 250 3 56 255 215 0 250 3 58 255 215 0 250 3 60 255 215 0 250 3 64 255 215 0 250 3 66 255 215 0 250 3 68 255 215 0 250 3 74 255 215 0 250 3 76 255 215 0 250 3 78 255 215 0 250 3 82 255 215 0 250 3 84 255 215 0 250 3 86 255 215 0 250 3 88 255 215 0 250 3 90 255 215 0 250 3 92 255 215 0 250 3 94 255 215 0 250 3 96 255 215 0 251 0 5 255 92 0 251 0 10 255 92 0 251 0 38 255 215 0 251 0 42 255 215 0 251 0 50 255 215 0 251 0 52 255 215 0 251 0 55 255 215 0 251 0 56 255 236 0 251 0 57 255 215 0 251 0 58 255 215 0 251 0 60 255 195 0 251 0 137 255 215 0 251 0 148 255 215 0 251 0 149 255 215 0 251 0 150 255 215 0 251 0 151 255 215 0 251 0 152 255 215 0 251 0 154 255 215 0 251 0 155 255 236 0 251 0 156 255 236 0 251 0 157 255 236 0 251 0 158 255 236 0 251 0 159 255 195 0 251 0 200 255 215 0 251 0 202 255 215 0 251 0 204 255 215 0 251 0 206 255 215 0 251 0 222 255 215 0 251 0 224 255 215 0 251 0 226 255 215 0 251 0 228 255 215 0 251 1 14 255 215 0 251 1 16 255 215 0 251 1 18 255 215 0 251 1 20 255 215 0 251 1 36 255 215 0 251 1 38 255 215 0 251 1 42 255 236 0 251 1 44 255 236 0 251 1 46 255 236 0 251 1 48 255 236 0 251 1 50 255 236 0 251 1 52 255 236 0 251 1 54 255 215 0 251 1 56 255 195 0 251 1 58 255 195 0 251 1 71 255 215 0 251 1 250 255 215 0 251 1 252 255 215 0 251 1 254 255 215 0 251 2 0 255 195 0 251 2 7 255 92 0 251 2 11 255 92 0 251 2 95 255 215 0 251 2 97 255 236 0 251 3 73 255 215 0 251 3 75 255 215 0 251 3 77 255 215 0 251 3 79 255 215 0 251 3 81 255 215 0 251 3 83 255 215 0 251 3 85 255 215 0 251 3 87 255 215 0 251 3 89 255 215 0 251 3 91 255 215 0 251 3 93 255 215 0 251 3 95 255 215 0 251 3 97 255 236 0 251 3 99 255 236 0 251 3 101 255 236 0 251 3 103 255 236 0 251 3 105 255 236 0 251 3 107 255 236 0 251 3 109 255 236 0 251 3 111 255 195 0 251 3 113 255 195 0 251 3 115 255 195 0 251 3 143 255 215 0 253 0 5 255 92 0 253 0 10 255 92 0 253 0 38 255 215 0 253 0 42 255 215 0 253 0 50 255 215 0 253 0 52 255 215 0 253 0 55 255 215 0 253 0 56 255 236 0 253 0 57 255 215 0 253 0 58 255 215 0 253 0 60 255 195 0 253 0 137 255 215 0 253 0 148 255 215 0 253 0 149 255 215 0 253 0 150 255 215 0 253 0 151 255 215 0 253 0 152 255 215 0 253 0 154 255 215 0 253 0 155 255 236 0 253 0 156 255 236 0 253 0 157 255 236 0 253 0 158 255 236 0 253 0 159 255 195 0 253 0 200 255 215 0 253 0 202 255 215 0 253 0 204 255 215 0 253 0 206 255 215 0 253 0 222 255 215 0 253 0 224 255 215 0 253 0 226 255 215 0 253 0 228 255 215 0 253 1 14 255 215 0 253 1 16 255 215 0 253 1 18 255 215 0 253 1 20 255 215 0 253 1 36 255 215 0 253 1 38 255 215 0 253 1 42 255 236 0 253 1 44 255 236 0 253 1 46 255 236 0 253 1 48 255 236 0 253 1 50 255 236 0 253 1 52 255 236 0 253 1 54 255 215 0 253 1 56 255 195 0 253 1 58 255 195 0 253 1 71 255 215 0 253 1 250 255 215 0 253 1 252 255 215 0 253 1 254 255 215 0 253 2 0 255 195 0 253 2 7 255 92 0 253 2 11 255 92 0 253 2 95 255 215 0 253 2 97 255 236 0 253 3 73 255 215 0 253 3 75 255 215 0 253 3 77 255 215 0 253 3 79 255 215 0 253 3 81 255 215 0 253 3 83 255 215 0 253 3 85 255 215 0 253 3 87 255 215 0 253 3 89 255 215 0 253 3 91 255 215 0 253 3 93 255 215 0 253 3 95 255 215 0 253 3 97 255 236 0 253 3 99 255 236 0 253 3 101 255 236 0 253 3 103 255 236 0 253 3 105 255 236 0 253 3 107 255 236 0 253 3 109 255 236 0 253 3 111 255 195 0 253 3 113 255 195 0 253 3 115 255 195 0 253 3 143 255 215 0 255 0 5 255 92 0 255 0 10 255 92 0 255 0 38 255 215 0 255 0 42 255 215 0 255 0 50 255 215 0 255 0 52 255 215 0 255 0 55 255 215 0 255 0 56 255 236 0 255 0 57 255 215 0 255 0 58 255 215 0 255 0 60 255 195 0 255 0 137 255 215 0 255 0 148 255 215 0 255 0 149 255 215 0 255 0 150 255 215 0 255 0 151 255 215 0 255 0 152 255 215 0 255 0 154 255 215 0 255 0 155 255 236 0 255 0 156 255 236 0 255 0 157 255 236 0 255 0 158 255 236 0 255 0 159 255 195 0 255 0 200 255 215 0 255 0 202 255 215 0 255 0 204 255 215 0 255 0 206 255 215 0 255 0 222 255 215 0 255 0 224 255 215 0 255 0 226 255 215 0 255 0 228 255 215 0 255 1 14 255 215 0 255 1 16 255 215 0 255 1 18 255 215 0 255 1 20 255 215 0 255 1 36 255 215 0 255 1 38 255 215 0 255 1 42 255 236 0 255 1 44 255 236 0 255 1 46 255 236 0 255 1 48 255 236 0 255 1 50 255 236 0 255 1 52 255 236 0 255 1 54 255 215 0 255 1 56 255 195 0 255 1 58 255 195 0 255 1 71 255 215 0 255 1 250 255 215 0 255 1 252 255 215 0 255 1 254 255 215 0 255 2 0 255 195 0 255 2 7 255 92 0 255 2 11 255 92 0 255 2 95 255 215 0 255 2 97 255 236 0 255 3 73 255 215 0 255 3 75 255 215 0 255 3 77 255 215 0 255 3 79 255 215 0 255 3 81 255 215 0 255 3 83 255 215 0 255 3 85 255 215 0 255 3 87 255 215 0 255 3 89 255 215 0 255 3 91 255 215 0 255 3 93 255 215 0 255 3 95 255 215 0 255 3 97 255 236 0 255 3 99 255 236 0 255 3 101 255 236 0 255 3 103 255 236 0 255 3 105 255 236 0 255 3 107 255 236 0 255 3 109 255 236 0 255 3 111 255 195 0 255 3 113 255 195 0 255 3 115 255 195 0 255 3 143 255 215 1 0 0 5 0 82 1 0 0 10 0 82 1 0 0 12 0 143 1 0 0 34 0 143 1 0 0 64 0 143 1 0 0 69 0 61 1 0 0 75 0 61 1 0 0 78 0 61 1 0 0 79 0 61 1 0 0 96 0 143 1 0 0 231 0 61 1 0 0 233 0 143 1 0 2 7 0 82 1 0 2 11 0 82 1 1 0 5 255 92 1 1 0 10 255 92 1 1 0 38 255 215 1 1 0 42 255 215 1 1 0 50 255 215 1 1 0 52 255 215 1 1 0 55 255 215 1 1 0 56 255 236 1 1 0 57 255 215 1 1 0 58 255 215 1 1 0 60 255 195 1 1 0 137 255 215 1 1 0 148 255 215 1 1 0 149 255 215 1 1 0 150 255 215 1 1 0 151 255 215 1 1 0 152 255 215 1 1 0 154 255 215 1 1 0 155 255 236 1 1 0 156 255 236 1 1 0 157 255 236 1 1 0 158 255 236 1 1 0 159 255 195 1 1 0 200 255 215 1 1 0 202 255 215 1 1 0 204 255 215 1 1 0 206 255 215 1 1 0 222 255 215 1 1 0 224 255 215 1 1 0 226 255 215 1 1 0 228 255 215 1 1 1 14 255 215 1 1 1 16 255 215 1 1 1 18 255 215 1 1 1 20 255 215 1 1 1 36 255 215 1 1 1 38 255 215 1 1 1 42 255 236 1 1 1 44 255 236 1 1 1 46 255 236 1 1 1 48 255 236 1 1 1 50 255 236 1 1 1 52 255 236 1 1 1 54 255 215 1 1 1 56 255 195 1 1 1 58 255 195 1 1 1 71 255 215 1 1 1 250 255 215 1 1 1 252 255 215 1 1 1 254 255 215 1 1 2 0 255 195 1 1 2 7 255 92 1 1 2 11 255 92 1 1 2 95 255 215 1 1 2 97 255 236 1 1 3 73 255 215 1 1 3 75 255 215 1 1 3 77 255 215 1 1 3 79 255 215 1 1 3 81 255 215 1 1 3 83 255 215 1 1 3 85 255 215 1 1 3 87 255 215 1 1 3 89 255 215 1 1 3 91 255 215 1 1 3 93 255 215 1 1 3 95 255 215 1 1 3 97 255 236 1 1 3 99 255 236 1 1 3 101 255 236 1 1 3 103 255 236 1 1 3 105 255 236 1 1 3 107 255 236 1 1 3 109 255 236 1 1 3 111 255 195 1 1 3 113 255 195 1 1 3 115 255 195 1 1 3 143 255 215 1 3 0 5 255 92 1 3 0 10 255 92 1 3 0 38 255 215 1 3 0 42 255 215 1 3 0 50 255 215 1 3 0 52 255 215 1 3 0 55 255 215 1 3 0 56 255 236 1 3 0 57 255 215 1 3 0 58 255 215 1 3 0 60 255 195 1 3 0 137 255 215 1 3 0 148 255 215 1 3 0 149 255 215 1 3 0 150 255 215 1 3 0 151 255 215 1 3 0 152 255 215 1 3 0 154 255 215 1 3 0 155 255 236 1 3 0 156 255 236 1 3 0 157 255 236 1 3 0 158 255 236 1 3 0 159 255 195 1 3 0 200 255 215 1 3 0 202 255 215 1 3 0 204 255 215 1 3 0 206 255 215 1 3 0 222 255 215 1 3 0 224 255 215 1 3 0 226 255 215 1 3 0 228 255 215 1 3 1 14 255 215 1 3 1 16 255 215 1 3 1 18 255 215 1 3 1 20 255 215 1 3 1 36 255 215 1 3 1 38 255 215 1 3 1 42 255 236 1 3 1 44 255 236 1 3 1 46 255 236 1 3 1 48 255 236 1 3 1 50 255 236 1 3 1 52 255 236 1 3 1 54 255 215 1 3 1 56 255 195 1 3 1 58 255 195 1 3 1 71 255 215 1 3 1 250 255 215 1 3 1 252 255 215 1 3 1 254 255 215 1 3 2 0 255 195 1 3 2 7 255 92 1 3 2 11 255 92 1 3 2 95 255 215 1 3 2 97 255 236 1 3 3 73 255 215 1 3 3 75 255 215 1 3 3 77 255 215 1 3 3 79 255 215 1 3 3 81 255 215 1 3 3 83 255 215 1 3 3 85 255 215 1 3 3 87 255 215 1 3 3 89 255 215 1 3 3 91 255 215 1 3 3 93 255 215 1 3 3 95 255 215 1 3 3 97 255 236 1 3 3 99 255 236 1 3 3 101 255 236 1 3 3 103 255 236 1 3 3 105 255 236 1 3 3 107 255 236 1 3 3 109 255 236 1 3 3 111 255 195 1 3 3 113 255 195 1 3 3 115 255 195 1 3 3 143 255 215 1 8 0 5 255 236 1 8 0 10 255 236 1 8 2 7 255 236 1 8 2 11 255 236 1 14 0 15 255 174 1 14 0 17 255 174 1 14 0 36 255 215 1 14 0 55 255 195 1 14 0 57 255 236 1 14 0 58 255 236 1 14 0 59 255 215 1 14 0 60 255 236 1 14 0 61 255 236 1 14 0 130 255 215 1 14 0 131 255 215 1 14 0 132 255 215 1 14 0 133 255 215 1 14 0 134 255 215 1 14 0 135 255 215 1 14 0 159 255 236 1 14 0 194 255 215 1 14 0 196 255 215 1 14 0 198 255 215 1 14 1 36 255 195 1 14 1 38 255 195 1 14 1 54 255 236 1 14 1 56 255 236 1 14 1 58 255 236 1 14 1 59 255 236 1 14 1 61 255 236 1 14 1 63 255 236 1 14 1 67 255 215 1 14 1 160 255 236 1 14 1 250 255 236 1 14 1 252 255 236 1 14 1 254 255 236 1 14 2 0 255 236 1 14 2 8 255 174 1 14 2 12 255 174 1 14 2 88 255 215 1 14 3 29 255 215 1 14 3 31 255 215 1 14 3 33 255 215 1 14 3 35 255 215 1 14 3 37 255 215 1 14 3 39 255 215 1 14 3 41 255 215 1 14 3 43 255 215 1 14 3 45 255 215 1 14 3 47 255 215 1 14 3 49 255 215 1 14 3 51 255 215 1 14 3 111 255 236 1 14 3 113 255 236 1 14 3 115 255 236 1 14 3 143 255 195 1 16 0 15 255 174 1 16 0 17 255 174 1 16 0 36 255 215 1 16 0 55 255 195 1 16 0 57 255 236 1 16 0 58 255 236 1 16 0 59 255 215 1 16 0 60 255 236 1 16 0 61 255 236 1 16 0 130 255 215 1 16 0 131 255 215 1 16 0 132 255 215 1 16 0 133 255 215 1 16 0 134 255 215 1 16 0 135 255 215 1 16 0 159 255 236 1 16 0 194 255 215 1 16 0 196 255 215 1 16 0 198 255 215 1 16 1 36 255 195 1 16 1 38 255 195 1 16 1 54 255 236 1 16 1 56 255 236 1 16 1 58 255 236 1 16 1 59 255 236 1 16 1 61 255 236 1 16 1 63 255 236 1 16 1 67 255 215 1 16 1 160 255 236 1 16 1 250 255 236 1 16 1 252 255 236 1 16 1 254 255 236 1 16 2 0 255 236 1 16 2 8 255 174 1 16 2 12 255 174 1 16 2 88 255 215 1 16 3 29 255 215 1 16 3 31 255 215 1 16 3 33 255 215 1 16 3 35 255 215 1 16 3 37 255 215 1 16 3 39 255 215 1 16 3 41 255 215 1 16 3 43 255 215 1 16 3 45 255 215 1 16 3 47 255 215 1 16 3 49 255 215 1 16 3 51 255 215 1 16 3 111 255 236 1 16 3 113 255 236 1 16 3 115 255 236 1 16 3 143 255 195 1 18 0 15 255 174 1 18 0 17 255 174 1 18 0 36 255 215 1 18 0 55 255 195 1 18 0 57 255 236 1 18 0 58 255 236 1 18 0 59 255 215 1 18 0 60 255 236 1 18 0 61 255 236 1 18 0 130 255 215 1 18 0 131 255 215 1 18 0 132 255 215 1 18 0 133 255 215 1 18 0 134 255 215 1 18 0 135 255 215 1 18 0 159 255 236 1 18 0 194 255 215 1 18 0 196 255 215 1 18 0 198 255 215 1 18 1 36 255 195 1 18 1 38 255 195 1 18 1 54 255 236 1 18 1 56 255 236 1 18 1 58 255 236 1 18 1 59 255 236 1 18 1 61 255 236 1 18 1 63 255 236 1 18 1 67 255 215 1 18 1 160 255 236 1 18 1 250 255 236 1 18 1 252 255 236 1 18 1 254 255 236 1 18 2 0 255 236 1 18 2 8 255 174 1 18 2 12 255 174 1 18 2 88 255 215 1 18 3 29 255 215 1 18 3 31 255 215 1 18 3 33 255 215 1 18 3 35 255 215 1 18 3 37 255 215 1 18 3 39 255 215 1 18 3 41 255 215 1 18 3 43 255 215 1 18 3 45 255 215 1 18 3 47 255 215 1 18 3 49 255 215 1 18 3 51 255 215 1 18 3 111 255 236 1 18 3 113 255 236 1 18 3 115 255 236 1 18 3 143 255 195 1 20 0 45 0 123 1 23 0 5 0 82 1 23 0 10 0 82 1 23 0 68 255 215 1 23 0 70 255 215 1 23 0 71 255 215 1 23 0 72 255 215 1 23 0 74 255 236 1 23 0 82 255 215 1 23 0 84 255 215 1 23 0 162 255 215 1 23 0 163 255 215 1 23 0 164 255 215 1 23 0 165 255 215 1 23 0 166 255 215 1 23 0 167 255 215 1 23 0 168 255 215 1 23 0 169 255 215 1 23 0 170 255 215 1 23 0 171 255 215 1 23 0 172 255 215 1 23 0 173 255 215 1 23 0 180 255 215 1 23 0 181 255 215 1 23 0 182 255 215 1 23 0 183 255 215 1 23 0 184 255 215 1 23 0 186 255 215 1 23 0 195 255 215 1 23 0 197 255 215 1 23 0 199 255 215 1 23 0 201 255 215 1 23 0 203 255 215 1 23 0 205 255 215 1 23 0 207 255 215 1 23 0 209 255 215 1 23 0 211 255 215 1 23 0 213 255 215 1 23 0 215 255 215 1 23 0 217 255 215 1 23 0 219 255 215 1 23 0 221 255 215 1 23 0 223 255 236 1 23 0 225 255 236 1 23 0 227 255 236 1 23 0 229 255 236 1 23 1 15 255 215 1 23 1 17 255 215 1 23 1 19 255 215 1 23 1 21 255 215 1 23 1 68 255 215 1 23 1 70 255 215 1 23 1 72 255 215 1 23 2 7 0 82 1 23 2 11 0 82 1 23 2 89 255 215 1 23 2 96 255 215 1 23 3 30 255 215 1 23 3 32 255 215 1 23 3 34 255 215 1 23 3 38 255 215 1 23 3 40 255 215 1 23 3 42 255 215 1 23 3 44 255 215 1 23 3 46 255 215 1 23 3 48 255 215 1 23 3 50 255 215 1 23 3 52 255 215 1 23 3 54 255 215 1 23 3 56 255 215 1 23 3 58 255 215 1 23 3 60 255 215 1 23 3 64 255 215 1 23 3 66 255 215 1 23 3 68 255 215 1 23 3 74 255 215 1 23 3 76 255 215 1 23 3 78 255 215 1 23 3 82 255 215 1 23 3 84 255 215 1 23 3 86 255 215 1 23 3 88 255 215 1 23 3 90 255 215 1 23 3 92 255 215 1 23 3 94 255 215 1 23 3 96 255 215 1 25 0 5 0 82 1 25 0 10 0 82 1 25 0 68 255 215 1 25 0 70 255 215 1 25 0 71 255 215 1 25 0 72 255 215 1 25 0 74 255 236 1 25 0 82 255 215 1 25 0 84 255 215 1 25 0 162 255 215 1 25 0 163 255 215 1 25 0 164 255 215 1 25 0 165 255 215 1 25 0 166 255 215 1 25 0 167 255 215 1 25 0 168 255 215 1 25 0 169 255 215 1 25 0 170 255 215 1 25 0 171 255 215 1 25 0 172 255 215 1 25 0 173 255 215 1 25 0 180 255 215 1 25 0 181 255 215 1 25 0 182 255 215 1 25 0 183 255 215 1 25 0 184 255 215 1 25 0 186 255 215 1 25 0 195 255 215 1 25 0 197 255 215 1 25 0 199 255 215 1 25 0 201 255 215 1 25 0 203 255 215 1 25 0 205 255 215 1 25 0 207 255 215 1 25 0 209 255 215 1 25 0 211 255 215 1 25 0 213 255 215 1 25 0 215 255 215 1 25 0 217 255 215 1 25 0 219 255 215 1 25 0 221 255 215 1 25 0 223 255 236 1 25 0 225 255 236 1 25 0 227 255 236 1 25 0 229 255 236 1 25 1 15 255 215 1 25 1 17 255 215 1 25 1 19 255 215 1 25 1 21 255 215 1 25 1 68 255 215 1 25 1 70 255 215 1 25 1 72 255 215 1 25 2 7 0 82 1 25 2 11 0 82 1 25 2 89 255 215 1 25 2 96 255 215 1 25 3 30 255 215 1 25 3 32 255 215 1 25 3 34 255 215 1 25 3 38 255 215 1 25 3 40 255 215 1 25 3 42 255 215 1 25 3 44 255 215 1 25 3 46 255 215 1 25 3 48 255 215 1 25 3 50 255 215 1 25 3 52 255 215 1 25 3 54 255 215 1 25 3 56 255 215 1 25 3 58 255 215 1 25 3 60 255 215 1 25 3 64 255 215 1 25 3 66 255 215 1 25 3 68 255 215 1 25 3 74 255 215 1 25 3 76 255 215 1 25 3 78 255 215 1 25 3 82 255 215 1 25 3 84 255 215 1 25 3 86 255 215 1 25 3 88 255 215 1 25 3 90 255 215 1 25 3 92 255 215 1 25 3 94 255 215 1 25 3 96 255 215 1 27 0 5 0 82 1 27 0 10 0 82 1 27 0 68 255 215 1 27 0 70 255 215 1 27 0 71 255 215 1 27 0 72 255 215 1 27 0 74 255 236 1 27 0 82 255 215 1 27 0 84 255 215 1 27 0 162 255 215 1 27 0 163 255 215 1 27 0 164 255 215 1 27 0 165 255 215 1 27 0 166 255 215 1 27 0 167 255 215 1 27 0 168 255 215 1 27 0 169 255 215 1 27 0 170 255 215 1 27 0 171 255 215 1 27 0 172 255 215 1 27 0 173 255 215 1 27 0 180 255 215 1 27 0 181 255 215 1 27 0 182 255 215 1 27 0 183 255 215 1 27 0 184 255 215 1 27 0 186 255 215 1 27 0 195 255 215 1 27 0 197 255 215 1 27 0 199 255 215 1 27 0 201 255 215 1 27 0 203 255 215 1 27 0 205 255 215 1 27 0 207 255 215 1 27 0 209 255 215 1 27 0 211 255 215 1 27 0 213 255 215 1 27 0 215 255 215 1 27 0 217 255 215 1 27 0 219 255 215 1 27 0 221 255 215 1 27 0 223 255 236 1 27 0 225 255 236 1 27 0 227 255 236 1 27 0 229 255 236 1 27 1 15 255 215 1 27 1 17 255 215 1 27 1 19 255 215 1 27 1 21 255 215 1 27 1 68 255 215 1 27 1 70 255 215 1 27 1 72 255 215 1 27 2 7 0 82 1 27 2 11 0 82 1 27 2 89 255 215 1 27 2 96 255 215 1 27 3 30 255 215 1 27 3 32 255 215 1 27 3 34 255 215 1 27 3 38 255 215 1 27 3 40 255 215 1 27 3 42 255 215 1 27 3 44 255 215 1 27 3 46 255 215 1 27 3 48 255 215 1 27 3 50 255 215 1 27 3 52 255 215 1 27 3 54 255 215 1 27 3 56 255 215 1 27 3 58 255 215 1 27 3 60 255 215 1 27 3 64 255 215 1 27 3 66 255 215 1 27 3 68 255 215 1 27 3 74 255 215 1 27 3 76 255 215 1 27 3 78 255 215 1 27 3 82 255 215 1 27 3 84 255 215 1 27 3 86 255 215 1 27 3 88 255 215 1 27 3 90 255 215 1 27 3 92 255 215 1 27 3 94 255 215 1 27 3 96 255 215 1 36 0 15 255 133 1 36 0 16 255 174 1 36 0 17 255 133 1 36 0 34 0 41 1 36 0 36 255 113 1 36 0 38 255 215 1 36 0 42 255 215 1 36 0 50 255 215 1 36 0 52 255 215 1 36 0 55 0 41 1 36 0 68 255 92 1 36 0 70 255 113 1 36 0 71 255 113 1 36 0 72 255 113 1 36 0 74 255 113 1 36 0 80 255 154 1 36 0 81 255 154 1 36 0 82 255 113 1 36 0 83 255 154 1 36 0 84 255 113 1 36 0 85 255 154 1 36 0 86 255 133 1 36 0 88 255 154 1 36 0 89 255 215 1 36 0 90 255 215 1 36 0 91 255 215 1 36 0 92 255 215 1 36 0 93 255 174 1 36 0 130 255 113 1 36 0 131 255 113 1 36 0 132 255 113 1 36 0 133 255 113 1 36 0 134 255 113 1 36 0 135 255 113 1 36 0 137 255 215 1 36 0 148 255 215 1 36 0 149 255 215 1 36 0 150 255 215 1 36 0 151 255 215 1 36 0 152 255 215 1 36 0 154 255 215 1 36 0 162 255 113 1 36 0 163 255 92 1 36 0 164 255 92 1 36 0 165 255 92 1 36 0 166 255 92 1 36 0 167 255 92 1 36 0 168 255 92 1 36 0 169 255 113 1 36 0 170 255 113 1 36 0 171 255 113 1 36 0 172 255 113 1 36 0 173 255 113 1 36 0 180 255 113 1 36 0 181 255 113 1 36 0 182 255 113 1 36 0 183 255 113 1 36 0 184 255 113 1 36 0 186 255 113 1 36 0 187 255 154 1 36 0 188 255 154 1 36 0 189 255 154 1 36 0 190 255 154 1 36 0 191 255 215 1 36 0 194 255 113 1 36 0 195 255 92 1 36 0 196 255 113 1 36 0 197 255 92 1 36 0 198 255 113 1 36 0 199 255 92 1 36 0 200 255 215 1 36 0 201 255 113 1 36 0 202 255 215 1 36 0 203 255 113 1 36 0 204 255 215 1 36 0 205 255 113 1 36 0 206 255 215 1 36 0 207 255 113 1 36 0 209 255 113 1 36 0 211 255 113 1 36 0 213 255 113 1 36 0 215 255 113 1 36 0 217 255 113 1 36 0 219 255 113 1 36 0 221 255 113 1 36 0 222 255 215 1 36 0 223 255 113 1 36 0 224 255 215 1 36 0 225 255 113 1 36 0 226 255 215 1 36 0 227 255 113 1 36 0 228 255 215 1 36 0 229 255 113 1 36 0 250 255 154 1 36 1 6 255 154 1 36 1 8 255 154 1 36 1 13 255 154 1 36 1 14 255 215 1 36 1 15 255 113 1 36 1 16 255 215 1 36 1 17 255 113 1 36 1 18 255 215 1 36 1 19 255 113 1 36 1 20 255 215 1 36 1 21 255 113 1 36 1 23 255 154 1 36 1 25 255 154 1 36 1 29 255 133 1 36 1 33 255 133 1 36 1 36 0 41 1 36 1 38 0 41 1 36 1 43 255 154 1 36 1 45 255 154 1 36 1 47 255 154 1 36 1 49 255 154 1 36 1 51 255 154 1 36 1 53 255 154 1 36 1 55 255 215 1 36 1 60 255 174 1 36 1 62 255 174 1 36 1 64 255 174 1 36 1 67 255 113 1 36 1 68 255 92 1 36 1 70 255 92 1 36 1 71 255 215 1 36 1 72 255 113 1 36 1 74 255 133 1 36 1 251 255 215 1 36 1 253 255 215 1 36 2 2 255 174 1 36 2 3 255 174 1 36 2 4 255 174 1 36 2 8 255 133 1 36 2 12 255 133 1 36 2 87 255 154 1 36 2 88 255 113 1 36 2 89 255 92 1 36 2 95 255 215 1 36 2 96 255 113 1 36 2 98 255 154 1 36 3 29 255 113 1 36 3 30 255 92 1 36 3 31 255 113 1 36 3 32 255 92 1 36 3 33 255 113 1 36 3 34 255 92 1 36 3 35 255 113 1 36 3 37 255 113 1 36 3 38 255 92 1 36 3 39 255 113 1 36 3 40 255 92 1 36 3 41 255 113 1 36 3 42 255 92 1 36 3 43 255 113 1 36 3 44 255 92 1 36 3 45 255 113 1 36 3 46 255 92 1 36 3 47 255 113 1 36 3 48 255 92 1 36 3 49 255 113 1 36 3 50 255 92 1 36 3 51 255 113 1 36 3 52 255 92 1 36 3 54 255 113 1 36 3 56 255 113 1 36 3 58 255 113 1 36 3 60 255 113 1 36 3 64 255 113 1 36 3 66 255 113 1 36 3 68 255 113 1 36 3 73 255 215 1 36 3 74 255 113 1 36 3 75 255 215 1 36 3 76 255 113 1 36 3 77 255 215 1 36 3 78 255 113 1 36 3 79 255 215 1 36 3 81 255 215 1 36 3 82 255 113 1 36 3 83 255 215 1 36 3 84 255 113 1 36 3 85 255 215 1 36 3 86 255 113 1 36 3 87 255 215 1 36 3 88 255 113 1 36 3 89 255 215 1 36 3 90 255 113 1 36 3 91 255 215 1 36 3 92 255 113 1 36 3 93 255 215 1 36 3 94 255 113 1 36 3 95 255 215 1 36 3 96 255 113 1 36 3 98 255 154 1 36 3 100 255 154 1 36 3 102 255 154 1 36 3 104 255 154 1 36 3 106 255 154 1 36 3 108 255 154 1 36 3 110 255 154 1 36 3 112 255 215 1 36 3 143 0 41 1 37 0 5 0 41 1 37 0 10 0 41 1 37 2 7 0 41 1 37 2 11 0 41 1 38 0 15 255 133 1 38 0 16 255 174 1 38 0 17 255 133 1 38 0 34 0 41 1 38 0 36 255 113 1 38 0 38 255 215 1 38 0 42 255 215 1 38 0 50 255 215 1 38 0 52 255 215 1 38 0 55 0 41 1 38 0 68 255 92 1 38 0 70 255 113 1 38 0 71 255 113 1 38 0 72 255 113 1 38 0 74 255 113 1 38 0 80 255 154 1 38 0 81 255 154 1 38 0 82 255 113 1 38 0 83 255 154 1 38 0 84 255 113 1 38 0 85 255 154 1 38 0 86 255 133 1 38 0 88 255 154 1 38 0 89 255 215 1 38 0 90 255 215 1 38 0 91 255 215 1 38 0 92 255 215 1 38 0 93 255 174 1 38 0 130 255 113 1 38 0 131 255 113 1 38 0 132 255 113 1 38 0 133 255 113 1 38 0 134 255 113 1 38 0 135 255 113 1 38 0 137 255 215 1 38 0 148 255 215 1 38 0 149 255 215 1 38 0 150 255 215 1 38 0 151 255 215 1 38 0 152 255 215 1 38 0 154 255 215 1 38 0 162 255 113 1 38 0 163 255 92 1 38 0 164 255 92 1 38 0 165 255 92 1 38 0 166 255 92 1 38 0 167 255 92 1 38 0 168 255 92 1 38 0 169 255 113 1 38 0 170 255 113 1 38 0 171 255 113 1 38 0 172 255 113 1 38 0 173 255 113 1 38 0 180 255 113 1 38 0 181 255 113 1 38 0 182 255 113 1 38 0 183 255 113 1 38 0 184 255 113 1 38 0 186 255 113 1 38 0 187 255 154 1 38 0 188 255 154 1 38 0 189 255 154 1 38 0 190 255 154 1 38 0 191 255 215 1 38 0 194 255 113 1 38 0 195 255 92 1 38 0 196 255 113 1 38 0 197 255 92 1 38 0 198 255 113 1 38 0 199 255 92 1 38 0 200 255 215 1 38 0 201 255 113 1 38 0 202 255 215 1 38 0 203 255 113 1 38 0 204 255 215 1 38 0 205 255 113 1 38 0 206 255 215 1 38 0 207 255 113 1 38 0 209 255 113 1 38 0 211 255 113 1 38 0 213 255 113 1 38 0 215 255 113 1 38 0 217 255 113 1 38 0 219 255 113 1 38 0 221 255 113 1 38 0 222 255 215 1 38 0 223 255 113 1 38 0 224 255 215 1 38 0 225 255 113 1 38 0 226 255 215 1 38 0 227 255 113 1 38 0 228 255 215 1 38 0 229 255 113 1 38 0 250 255 154 1 38 1 6 255 154 1 38 1 8 255 154 1 38 1 13 255 154 1 38 1 14 255 215 1 38 1 15 255 113 1 38 1 16 255 215 1 38 1 17 255 113 1 38 1 18 255 215 1 38 1 19 255 113 1 38 1 20 255 215 1 38 1 21 255 113 1 38 1 23 255 154 1 38 1 25 255 154 1 38 1 29 255 133 1 38 1 33 255 133 1 38 1 36 0 41 1 38 1 38 0 41 1 38 1 43 255 154 1 38 1 45 255 154 1 38 1 47 255 154 1 38 1 49 255 154 1 38 1 51 255 154 1 38 1 53 255 154 1 38 1 55 255 215 1 38 1 60 255 174 1 38 1 62 255 174 1 38 1 64 255 174 1 38 1 67 255 113 1 38 1 68 255 92 1 38 1 70 255 92 1 38 1 71 255 215 1 38 1 72 255 113 1 38 1 74 255 133 1 38 1 251 255 215 1 38 1 253 255 215 1 38 2 2 255 174 1 38 2 3 255 174 1 38 2 4 255 174 1 38 2 8 255 133 1 38 2 12 255 133 1 38 2 87 255 154 1 38 2 88 255 113 1 38 2 89 255 92 1 38 2 95 255 215 1 38 2 96 255 113 1 38 2 98 255 154 1 38 3 29 255 113 1 38 3 30 255 92 1 38 3 31 255 113 1 38 3 32 255 92 1 38 3 33 255 113 1 38 3 34 255 92 1 38 3 35 255 113 1 38 3 37 255 113 1 38 3 38 255 92 1 38 3 39 255 113 1 38 3 40 255 92 1 38 3 41 255 113 1 38 3 42 255 92 1 38 3 43 255 113 1 38 3 44 255 92 1 38 3 45 255 113 1 38 3 46 255 92 1 38 3 47 255 113 1 38 3 48 255 92 1 38 3 49 255 113 1 38 3 50 255 92 1 38 3 51 255 113 1 38 3 52 255 92 1 38 3 54 255 113 1 38 3 56 255 113 1 38 3 58 255 113 1 38 3 60 255 113 1 38 3 64 255 113 1 38 3 66 255 113 1 38 3 68 255 113 1 38 3 73 255 215 1 38 3 74 255 113 1 38 3 75 255 215 1 38 3 76 255 113 1 38 3 77 255 215 1 38 3 78 255 113 1 38 3 79 255 215 1 38 3 81 255 215 1 38 3 82 255 113 1 38 3 83 255 215 1 38 3 84 255 113 1 38 3 85 255 215 1 38 3 86 255 113 1 38 3 87 255 215 1 38 3 88 255 113 1 38 3 89 255 215 1 38 3 90 255 113 1 38 3 91 255 215 1 38 3 92 255 113 1 38 3 93 255 215 1 38 3 94 255 113 1 38 3 95 255 215 1 38 3 96 255 113 1 38 3 98 255 154 1 38 3 100 255 154 1 38 3 102 255 154 1 38 3 104 255 154 1 38 3 106 255 154 1 38 3 108 255 154 1 38 3 110 255 154 1 38 3 112 255 215 1 38 3 143 0 41 1 39 0 5 0 41 1 39 0 10 0 41 1 39 2 7 0 41 1 39 2 11 0 41 1 40 0 15 255 133 1 40 0 16 255 174 1 40 0 17 255 133 1 40 0 34 0 41 1 40 0 36 255 113 1 40 0 38 255 215 1 40 0 42 255 215 1 40 0 50 255 215 1 40 0 52 255 215 1 40 0 55 0 41 1 40 0 68 255 92 1 40 0 70 255 113 1 40 0 71 255 113 1 40 0 72 255 113 1 40 0 74 255 113 1 40 0 80 255 154 1 40 0 81 255 154 1 40 0 82 255 113 1 40 0 83 255 154 1 40 0 84 255 113 1 40 0 85 255 154 1 40 0 86 255 133 1 40 0 88 255 154 1 40 0 89 255 215 1 40 0 90 255 215 1 40 0 91 255 215 1 40 0 92 255 215 1 40 0 93 255 174 1 40 0 130 255 113 1 40 0 131 255 113 1 40 0 132 255 113 1 40 0 133 255 113 1 40 0 134 255 113 1 40 0 135 255 113 1 40 0 137 255 215 1 40 0 148 255 215 1 40 0 149 255 215 1 40 0 150 255 215 1 40 0 151 255 215 1 40 0 152 255 215 1 40 0 154 255 215 1 40 0 162 255 113 1 40 0 163 255 92 1 40 0 164 255 92 1 40 0 165 255 92 1 40 0 166 255 92 1 40 0 167 255 92 1 40 0 168 255 92 1 40 0 169 255 113 1 40 0 170 255 113 1 40 0 171 255 113 1 40 0 172 255 113 1 40 0 173 255 113 1 40 0 180 255 113 1 40 0 181 255 113 1 40 0 182 255 113 1 40 0 183 255 113 1 40 0 184 255 113 1 40 0 186 255 113 1 40 0 187 255 154 1 40 0 188 255 154 1 40 0 189 255 154 1 40 0 190 255 154 1 40 0 191 255 215 1 40 0 194 255 113 1 40 0 195 255 92 1 40 0 196 255 113 1 40 0 197 255 92 1 40 0 198 255 113 1 40 0 199 255 92 1 40 0 200 255 215 1 40 0 201 255 113 1 40 0 202 255 215 1 40 0 203 255 113 1 40 0 204 255 215 1 40 0 205 255 113 1 40 0 206 255 215 1 40 0 207 255 113 1 40 0 209 255 113 1 40 0 211 255 113 1 40 0 213 255 113 1 40 0 215 255 113 1 40 0 217 255 113 1 40 0 219 255 113 1 40 0 221 255 113 1 40 0 222 255 215 1 40 0 223 255 113 1 40 0 224 255 215 1 40 0 225 255 113 1 40 0 226 255 215 1 40 0 227 255 113 1 40 0 228 255 215 1 40 0 229 255 113 1 40 0 250 255 154 1 40 1 6 255 154 1 40 1 8 255 154 1 40 1 13 255 154 1 40 1 14 255 215 1 40 1 15 255 113 1 40 1 16 255 215 1 40 1 17 255 113 1 40 1 18 255 215 1 40 1 19 255 113 1 40 1 20 255 215 1 40 1 21 255 113 1 40 1 23 255 154 1 40 1 25 255 154 1 40 1 29 255 133 1 40 1 33 255 133 1 40 1 36 0 41 1 40 1 38 0 41 1 40 1 43 255 154 1 40 1 45 255 154 1 40 1 47 255 154 1 40 1 49 255 154 1 40 1 51 255 154 1 40 1 53 255 154 1 40 1 55 255 215 1 40 1 60 255 174 1 40 1 62 255 174 1 40 1 64 255 174 1 40 1 67 255 113 1 40 1 68 255 92 1 40 1 70 255 92 1 40 1 71 255 215 1 40 1 72 255 113 1 40 1 74 255 133 1 40 1 251 255 215 1 40 1 253 255 215 1 40 2 2 255 174 1 40 2 3 255 174 1 40 2 4 255 174 1 40 2 8 255 133 1 40 2 12 255 133 1 40 2 87 255 154 1 40 2 88 255 113 1 40 2 89 255 92 1 40 2 95 255 215 1 40 2 96 255 113 1 40 2 98 255 154 1 40 3 29 255 113 1 40 3 30 255 92 1 40 3 31 255 113 1 40 3 32 255 92 1 40 3 33 255 113 1 40 3 34 255 92 1 40 3 35 255 113 1 40 3 37 255 113 1 40 3 38 255 92 1 40 3 39 255 113 1 40 3 40 255 92 1 40 3 41 255 113 1 40 3 42 255 92 1 40 3 43 255 113 1 40 3 44 255 92 1 40 3 45 255 113 1 40 3 46 255 92 1 40 3 47 255 113 1 40 3 48 255 92 1 40 3 49 255 113 1 40 3 50 255 92 1 40 3 51 255 113 1 40 3 52 255 92 1 40 3 54 255 113 1 40 3 56 255 113 1 40 3 58 255 113 1 40 3 60 255 113 1 40 3 64 255 113 1 40 3 66 255 113 1 40 3 68 255 113 1 40 3 73 255 215 1 40 3 74 255 113 1 40 3 75 255 215 1 40 3 76 255 113 1 40 3 77 255 215 1 40 3 78 255 113 1 40 3 79 255 215 1 40 3 81 255 215 1 40 3 82 255 113 1 40 3 83 255 215 1 40 3 84 255 113 1 40 3 85 255 215 1 40 3 86 255 113 1 40 3 87 255 215 1 40 3 88 255 113 1 40 3 89 255 215 1 40 3 90 255 113 1 40 3 91 255 215 1 40 3 92 255 113 1 40 3 93 255 215 1 40 3 94 255 113 1 40 3 95 255 215 1 40 3 96 255 113 1 40 3 98 255 154 1 40 3 100 255 154 1 40 3 102 255 154 1 40 3 104 255 154 1 40 3 106 255 154 1 40 3 108 255 154 1 40 3 110 255 154 1 40 3 112 255 215 1 40 3 143 0 41 1 42 0 15 255 215 1 42 0 17 255 215 1 42 0 36 255 236 1 42 0 130 255 236 1 42 0 131 255 236 1 42 0 132 255 236 1 42 0 133 255 236 1 42 0 134 255 236 1 42 0 135 255 236 1 42 0 194 255 236 1 42 0 196 255 236 1 42 0 198 255 236 1 42 1 67 255 236 1 42 2 8 255 215 1 42 2 12 255 215 1 42 2 88 255 236 1 42 3 29 255 236 1 42 3 31 255 236 1 42 3 33 255 236 1 42 3 35 255 236 1 42 3 37 255 236 1 42 3 39 255 236 1 42 3 41 255 236 1 42 3 43 255 236 1 42 3 45 255 236 1 42 3 47 255 236 1 42 3 49 255 236 1 42 3 51 255 236 1 44 0 15 255 215 1 44 0 17 255 215 1 44 0 36 255 236 1 44 0 130 255 236 1 44 0 131 255 236 1 44 0 132 255 236 1 44 0 133 255 236 1 44 0 134 255 236 1 44 0 135 255 236 1 44 0 194 255 236 1 44 0 196 255 236 1 44 0 198 255 236 1 44 1 67 255 236 1 44 2 8 255 215 1 44 2 12 255 215 1 44 2 88 255 236 1 44 3 29 255 236 1 44 3 31 255 236 1 44 3 33 255 236 1 44 3 35 255 236 1 44 3 37 255 236 1 44 3 39 255 236 1 44 3 41 255 236 1 44 3 43 255 236 1 44 3 45 255 236 1 44 3 47 255 236 1 44 3 49 255 236 1 44 3 51 255 236 1 46 0 15 255 215 1 46 0 17 255 215 1 46 0 36 255 236 1 46 0 130 255 236 1 46 0 131 255 236 1 46 0 132 255 236 1 46 0 133 255 236 1 46 0 134 255 236 1 46 0 135 255 236 1 46 0 194 255 236 1 46 0 196 255 236 1 46 0 198 255 236 1 46 1 67 255 236 1 46 2 8 255 215 1 46 2 12 255 215 1 46 2 88 255 236 1 46 3 29 255 236 1 46 3 31 255 236 1 46 3 33 255 236 1 46 3 35 255 236 1 46 3 37 255 236 1 46 3 39 255 236 1 46 3 41 255 236 1 46 3 43 255 236 1 46 3 45 255 236 1 46 3 47 255 236 1 46 3 49 255 236 1 46 3 51 255 236 1 48 0 15 255 215 1 48 0 17 255 215 1 48 0 36 255 236 1 48 0 130 255 236 1 48 0 131 255 236 1 48 0 132 255 236 1 48 0 133 255 236 1 48 0 134 255 236 1 48 0 135 255 236 1 48 0 194 255 236 1 48 0 196 255 236 1 48 0 198 255 236 1 48 1 67 255 236 1 48 2 8 255 215 1 48 2 12 255 215 1 48 2 88 255 236 1 48 3 29 255 236 1 48 3 31 255 236 1 48 3 33 255 236 1 48 3 35 255 236 1 48 3 37 255 236 1 48 3 39 255 236 1 48 3 41 255 236 1 48 3 43 255 236 1 48 3 45 255 236 1 48 3 47 255 236 1 48 3 49 255 236 1 48 3 51 255 236 1 50 0 15 255 215 1 50 0 17 255 215 1 50 0 36 255 236 1 50 0 130 255 236 1 50 0 131 255 236 1 50 0 132 255 236 1 50 0 133 255 236 1 50 0 134 255 236 1 50 0 135 255 236 1 50 0 194 255 236 1 50 0 196 255 236 1 50 0 198 255 236 1 50 1 67 255 236 1 50 2 8 255 215 1 50 2 12 255 215 1 50 2 88 255 236 1 50 3 29 255 236 1 50 3 31 255 236 1 50 3 33 255 236 1 50 3 35 255 236 1 50 3 37 255 236 1 50 3 39 255 236 1 50 3 41 255 236 1 50 3 43 255 236 1 50 3 45 255 236 1 50 3 47 255 236 1 50 3 49 255 236 1 50 3 51 255 236 1 52 0 15 255 215 1 52 0 17 255 215 1 52 0 36 255 236 1 52 0 130 255 236 1 52 0 131 255 236 1 52 0 132 255 236 1 52 0 133 255 236 1 52 0 134 255 236 1 52 0 135 255 236 1 52 0 194 255 236 1 52 0 196 255 236 1 52 0 198 255 236 1 52 1 67 255 236 1 52 2 8 255 215 1 52 2 12 255 215 1 52 2 88 255 236 1 52 3 29 255 236 1 52 3 31 255 236 1 52 3 33 255 236 1 52 3 35 255 236 1 52 3 37 255 236 1 52 3 39 255 236 1 52 3 41 255 236 1 52 3 43 255 236 1 52 3 45 255 236 1 52 3 47 255 236 1 52 3 49 255 236 1 52 3 51 255 236 1 54 0 15 255 154 1 54 0 17 255 154 1 54 0 34 0 41 1 54 0 36 255 174 1 54 0 38 255 236 1 54 0 42 255 236 1 54 0 50 255 236 1 54 0 52 255 236 1 54 0 68 255 215 1 54 0 70 255 215 1 54 0 71 255 215 1 54 0 72 255 215 1 54 0 74 255 236 1 54 0 80 255 236 1 54 0 81 255 236 1 54 0 82 255 215 1 54 0 83 255 236 1 54 0 84 255 215 1 54 0 85 255 236 1 54 0 86 255 236 1 54 0 88 255 236 1 54 0 130 255 174 1 54 0 131 255 174 1 54 0 132 255 174 1 54 0 133 255 174 1 54 0 134 255 174 1 54 0 135 255 174 1 54 0 137 255 236 1 54 0 148 255 236 1 54 0 149 255 236 1 54 0 150 255 236 1 54 0 151 255 236 1 54 0 152 255 236 1 54 0 154 255 236 1 54 0 162 255 215 1 54 0 163 255 215 1 54 0 164 255 215 1 54 0 165 255 215 1 54 0 166 255 215 1 54 0 167 255 215 1 54 0 168 255 215 1 54 0 169 255 215 1 54 0 170 255 215 1 54 0 171 255 215 1 54 0 172 255 215 1 54 0 173 255 215 1 54 0 180 255 215 1 54 0 181 255 215 1 54 0 182 255 215 1 54 0 183 255 215 1 54 0 184 255 215 1 54 0 186 255 215 1 54 0 187 255 236 1 54 0 188 255 236 1 54 0 189 255 236 1 54 0 190 255 236 1 54 0 194 255 174 1 54 0 195 255 215 1 54 0 196 255 174 1 54 0 197 255 215 1 54 0 198 255 174 1 54 0 199 255 215 1 54 0 200 255 236 1 54 0 201 255 215 1 54 0 202 255 236 1 54 0 203 255 215 1 54 0 204 255 236 1 54 0 205 255 215 1 54 0 206 255 236 1 54 0 207 255 215 1 54 0 209 255 215 1 54 0 211 255 215 1 54 0 213 255 215 1 54 0 215 255 215 1 54 0 217 255 215 1 54 0 219 255 215 1 54 0 221 255 215 1 54 0 222 255 236 1 54 0 223 255 236 1 54 0 224 255 236 1 54 0 225 255 236 1 54 0 226 255 236 1 54 0 227 255 236 1 54 0 228 255 236 1 54 0 229 255 236 1 54 0 250 255 236 1 54 1 6 255 236 1 54 1 8 255 236 1 54 1 13 255 236 1 54 1 14 255 236 1 54 1 15 255 215 1 54 1 16 255 236 1 54 1 17 255 215 1 54 1 18 255 236 1 54 1 19 255 215 1 54 1 20 255 236 1 54 1 21 255 215 1 54 1 23 255 236 1 54 1 25 255 236 1 54 1 29 255 236 1 54 1 33 255 236 1 54 1 43 255 236 1 54 1 45 255 236 1 54 1 47 255 236 1 54 1 49 255 236 1 54 1 51 255 236 1 54 1 53 255 236 1 54 1 67 255 174 1 54 1 68 255 215 1 54 1 70 255 215 1 54 1 71 255 236 1 54 1 72 255 215 1 54 1 74 255 236 1 54 2 8 255 154 1 54 2 12 255 154 1 54 2 87 255 236 1 54 2 88 255 174 1 54 2 89 255 215 1 54 2 95 255 236 1 54 2 96 255 215 1 54 2 98 255 236 1 54 3 29 255 174 1 54 3 30 255 215 1 54 3 31 255 174 1 54 3 32 255 215 1 54 3 33 255 174 1 54 3 34 255 215 1 54 3 35 255 174 1 54 3 37 255 174 1 54 3 38 255 215 1 54 3 39 255 174 1 54 3 40 255 215 1 54 3 41 255 174 1 54 3 42 255 215 1 54 3 43 255 174 1 54 3 44 255 215 1 54 3 45 255 174 1 54 3 46 255 215 1 54 3 47 255 174 1 54 3 48 255 215 1 54 3 49 255 174 1 54 3 50 255 215 1 54 3 51 255 174 1 54 3 52 255 215 1 54 3 54 255 215 1 54 3 56 255 215 1 54 3 58 255 215 1 54 3 60 255 215 1 54 3 64 255 215 1 54 3 66 255 215 1 54 3 68 255 215 1 54 3 73 255 236 1 54 3 74 255 215 1 54 3 75 255 236 1 54 3 76 255 215 1 54 3 77 255 236 1 54 3 78 255 215 1 54 3 79 255 236 1 54 3 81 255 236 1 54 3 82 255 215 1 54 3 83 255 236 1 54 3 84 255 215 1 54 3 85 255 236 1 54 3 86 255 215 1 54 3 87 255 236 1 54 3 88 255 215 1 54 3 89 255 236 1 54 3 90 255 215 1 54 3 91 255 236 1 54 3 92 255 215 1 54 3 93 255 236 1 54 3 94 255 215 1 54 3 95 255 236 1 54 3 96 255 215 1 54 3 98 255 236 1 54 3 100 255 236 1 54 3 102 255 236 1 54 3 104 255 236 1 54 3 106 255 236 1 54 3 108 255 236 1 54 3 110 255 236 1 55 0 5 0 82 1 55 0 10 0 82 1 55 0 15 255 174 1 55 0 17 255 174 1 55 0 34 0 41 1 55 2 7 0 82 1 55 2 8 255 174 1 55 2 11 0 82 1 55 2 12 255 174 1 56 0 15 255 133 1 56 0 17 255 133 1 56 0 34 0 41 1 56 0 36 255 133 1 56 0 38 255 215 1 56 0 42 255 215 1 56 0 50 255 215 1 56 0 52 255 215 1 56 0 68 255 154 1 56 0 70 255 154 1 56 0 71 255 154 1 56 0 72 255 154 1 56 0 74 255 215 1 56 0 80 255 195 1 56 0 81 255 195 1 56 0 82 255 154 1 56 0 83 255 195 1 56 0 84 255 154 1 56 0 85 255 195 1 56 0 86 255 174 1 56 0 88 255 195 1 56 0 93 255 215 1 56 0 130 255 133 1 56 0 131 255 133 1 56 0 132 255 133 1 56 0 133 255 133 1 56 0 134 255 133 1 56 0 135 255 133 1 56 0 137 255 215 1 56 0 148 255 215 1 56 0 149 255 215 1 56 0 150 255 215 1 56 0 151 255 215 1 56 0 152 255 215 1 56 0 154 255 215 1 56 0 162 255 154 1 56 0 163 255 154 1 56 0 164 255 154 1 56 0 165 255 154 1 56 0 166 255 154 1 56 0 167 255 154 1 56 0 168 255 154 1 56 0 169 255 154 1 56 0 170 255 154 1 56 0 171 255 154 1 56 0 172 255 154 1 56 0 173 255 154 1 56 0 180 255 154 1 56 0 181 255 154 1 56 0 182 255 154 1 56 0 183 255 154 1 56 0 184 255 154 1 56 0 186 255 154 1 56 0 187 255 195 1 56 0 188 255 195 1 56 0 189 255 195 1 56 0 190 255 195 1 56 0 194 255 133 1 56 0 195 255 154 1 56 0 196 255 133 1 56 0 197 255 154 1 56 0 198 255 133 1 56 0 199 255 154 1 56 0 200 255 215 1 56 0 201 255 154 1 56 0 202 255 215 1 56 0 203 255 154 1 56 0 204 255 215 1 56 0 205 255 154 1 56 0 206 255 215 1 56 0 207 255 154 1 56 0 209 255 154 1 56 0 211 255 154 1 56 0 213 255 154 1 56 0 215 255 154 1 56 0 217 255 154 1 56 0 219 255 154 1 56 0 221 255 154 1 56 0 222 255 215 1 56 0 223 255 215 1 56 0 224 255 215 1 56 0 225 255 215 1 56 0 226 255 215 1 56 0 227 255 215 1 56 0 228 255 215 1 56 0 229 255 215 1 56 0 250 255 195 1 56 1 6 255 195 1 56 1 8 255 195 1 56 1 13 255 195 1 56 1 14 255 215 1 56 1 15 255 154 1 56 1 16 255 215 1 56 1 17 255 154 1 56 1 18 255 215 1 56 1 19 255 154 1 56 1 20 255 215 1 56 1 21 255 154 1 56 1 23 255 195 1 56 1 25 255 195 1 56 1 29 255 174 1 56 1 33 255 174 1 56 1 43 255 195 1 56 1 45 255 195 1 56 1 47 255 195 1 56 1 49 255 195 1 56 1 51 255 195 1 56 1 53 255 195 1 56 1 60 255 215 1 56 1 62 255 215 1 56 1 64 255 215 1 56 1 67 255 133 1 56 1 68 255 154 1 56 1 70 255 154 1 56 1 71 255 215 1 56 1 72 255 154 1 56 1 74 255 174 1 56 2 8 255 133 1 56 2 12 255 133 1 56 2 87 255 195 1 56 2 88 255 133 1 56 2 89 255 154 1 56 2 95 255 215 1 56 2 96 255 154 1 56 2 98 255 195 1 56 3 29 255 133 1 56 3 30 255 154 1 56 3 31 255 133 1 56 3 32 255 154 1 56 3 33 255 133 1 56 3 34 255 154 1 56 3 35 255 133 1 56 3 37 255 133 1 56 3 38 255 154 1 56 3 39 255 133 1 56 3 40 255 154 1 56 3 41 255 133 1 56 3 42 255 154 1 56 3 43 255 133 1 56 3 44 255 154 1 56 3 45 255 133 1 56 3 46 255 154 1 56 3 47 255 133 1 56 3 48 255 154 1 56 3 49 255 133 1 56 3 50 255 154 1 56 3 51 255 133 1 56 3 52 255 154 1 56 3 54 255 154 1 56 3 56 255 154 1 56 3 58 255 154 1 56 3 60 255 154 1 56 3 64 255 154 1 56 3 66 255 154 1 56 3 68 255 154 1 56 3 73 255 215 1 56 3 74 255 154 1 56 3 75 255 215 1 56 3 76 255 154 1 56 3 77 255 215 1 56 3 78 255 154 1 56 3 79 255 215 1 56 3 81 255 215 1 56 3 82 255 154 1 56 3 83 255 215 1 56 3 84 255 154 1 56 3 85 255 215 1 56 3 86 255 154 1 56 3 87 255 215 1 56 3 88 255 154 1 56 3 89 255 215 1 56 3 90 255 154 1 56 3 91 255 215 1 56 3 92 255 154 1 56 3 93 255 215 1 56 3 94 255 154 1 56 3 95 255 215 1 56 3 96 255 154 1 56 3 98 255 195 1 56 3 100 255 195 1 56 3 102 255 195 1 56 3 104 255 195 1 56 3 106 255 195 1 56 3 108 255 195 1 56 3 110 255 195 1 57 0 5 0 82 1 57 0 10 0 82 1 57 0 15 255 174 1 57 0 17 255 174 1 57 0 34 0 41 1 57 2 7 0 82 1 57 2 8 255 174 1 57 2 11 0 82 1 57 2 12 255 174 1 58 0 15 255 133 1 58 0 17 255 133 1 58 0 34 0 41 1 58 0 36 255 133 1 58 0 38 255 215 1 58 0 42 255 215 1 58 0 50 255 215 1 58 0 52 255 215 1 58 0 68 255 154 1 58 0 70 255 154 1 58 0 71 255 154 1 58 0 72 255 154 1 58 0 74 255 215 1 58 0 80 255 195 1 58 0 81 255 195 1 58 0 82 255 154 1 58 0 83 255 195 1 58 0 84 255 154 1 58 0 85 255 195 1 58 0 86 255 174 1 58 0 88 255 195 1 58 0 93 255 215 1 58 0 130 255 133 1 58 0 131 255 133 1 58 0 132 255 133 1 58 0 133 255 133 1 58 0 134 255 133 1 58 0 135 255 133 1 58 0 137 255 215 1 58 0 148 255 215 1 58 0 149 255 215 1 58 0 150 255 215 1 58 0 151 255 215 1 58 0 152 255 215 1 58 0 154 255 215 1 58 0 162 255 154 1 58 0 163 255 154 1 58 0 164 255 154 1 58 0 165 255 154 1 58 0 166 255 154 1 58 0 167 255 154 1 58 0 168 255 154 1 58 0 169 255 154 1 58 0 170 255 154 1 58 0 171 255 154 1 58 0 172 255 154 1 58 0 173 255 154 1 58 0 180 255 154 1 58 0 181 255 154 1 58 0 182 255 154 1 58 0 183 255 154 1 58 0 184 255 154 1 58 0 186 255 154 1 58 0 187 255 195 1 58 0 188 255 195 1 58 0 189 255 195 1 58 0 190 255 195 1 58 0 194 255 133 1 58 0 195 255 154 1 58 0 196 255 133 1 58 0 197 255 154 1 58 0 198 255 133 1 58 0 199 255 154 1 58 0 200 255 215 1 58 0 201 255 154 1 58 0 202 255 215 1 58 0 203 255 154 1 58 0 204 255 215 1 58 0 205 255 154 1 58 0 206 255 215 1 58 0 207 255 154 1 58 0 209 255 154 1 58 0 211 255 154 1 58 0 213 255 154 1 58 0 215 255 154 1 58 0 217 255 154 1 58 0 219 255 154 1 58 0 221 255 154 1 58 0 222 255 215 1 58 0 223 255 215 1 58 0 224 255 215 1 58 0 225 255 215 1 58 0 226 255 215 1 58 0 227 255 215 1 58 0 228 255 215 1 58 0 229 255 215 1 58 0 250 255 195 1 58 1 6 255 195 1 58 1 8 255 195 1 58 1 13 255 195 1 58 1 14 255 215 1 58 1 15 255 154 1 58 1 16 255 215 1 58 1 17 255 154 1 58 1 18 255 215 1 58 1 19 255 154 1 58 1 20 255 215 1 58 1 21 255 154 1 58 1 23 255 195 1 58 1 25 255 195 1 58 1 29 255 174 1 58 1 33 255 174 1 58 1 43 255 195 1 58 1 45 255 195 1 58 1 47 255 195 1 58 1 49 255 195 1 58 1 51 255 195 1 58 1 53 255 195 1 58 1 60 255 215 1 58 1 62 255 215 1 58 1 64 255 215 1 58 1 67 255 133 1 58 1 68 255 154 1 58 1 70 255 154 1 58 1 71 255 215 1 58 1 72 255 154 1 58 1 74 255 174 1 58 2 8 255 133 1 58 2 12 255 133 1 58 2 87 255 195 1 58 2 88 255 133 1 58 2 89 255 154 1 58 2 95 255 215 1 58 2 96 255 154 1 58 2 98 255 195 1 58 3 29 255 133 1 58 3 30 255 154 1 58 3 31 255 133 1 58 3 32 255 154 1 58 3 33 255 133 1 58 3 34 255 154 1 58 3 35 255 133 1 58 3 37 255 133 1 58 3 38 255 154 1 58 3 39 255 133 1 58 3 40 255 154 1 58 3 41 255 133 1 58 3 42 255 154 1 58 3 43 255 133 1 58 3 44 255 154 1 58 3 45 255 133 1 58 3 46 255 154 1 58 3 47 255 133 1 58 3 48 255 154 1 58 3 49 255 133 1 58 3 50 255 154 1 58 3 51 255 133 1 58 3 52 255 154 1 58 3 54 255 154 1 58 3 56 255 154 1 58 3 58 255 154 1 58 3 60 255 154 1 58 3 64 255 154 1 58 3 66 255 154 1 58 3 68 255 154 1 58 3 73 255 215 1 58 3 74 255 154 1 58 3 75 255 215 1 58 3 76 255 154 1 58 3 77 255 215 1 58 3 78 255 154 1 58 3 79 255 215 1 58 3 81 255 215 1 58 3 82 255 154 1 58 3 83 255 215 1 58 3 84 255 154 1 58 3 85 255 215 1 58 3 86 255 154 1 58 3 87 255 215 1 58 3 88 255 154 1 58 3 89 255 215 1 58 3 90 255 154 1 58 3 91 255 215 1 58 3 92 255 154 1 58 3 93 255 215 1 58 3 94 255 154 1 58 3 95 255 215 1 58 3 96 255 154 1 58 3 98 255 195 1 58 3 100 255 195 1 58 3 102 255 195 1 58 3 104 255 195 1 58 3 106 255 195 1 58 3 108 255 195 1 58 3 110 255 195 1 59 0 38 255 236 1 59 0 42 255 236 1 59 0 50 255 236 1 59 0 52 255 236 1 59 0 137 255 236 1 59 0 148 255 236 1 59 0 149 255 236 1 59 0 150 255 236 1 59 0 151 255 236 1 59 0 152 255 236 1 59 0 154 255 236 1 59 0 200 255 236 1 59 0 202 255 236 1 59 0 204 255 236 1 59 0 206 255 236 1 59 0 222 255 236 1 59 0 224 255 236 1 59 0 226 255 236 1 59 0 228 255 236 1 59 1 14 255 236 1 59 1 16 255 236 1 59 1 18 255 236 1 59 1 20 255 236 1 59 1 71 255 236 1 59 2 95 255 236 1 59 3 73 255 236 1 59 3 75 255 236 1 59 3 77 255 236 1 59 3 79 255 236 1 59 3 81 255 236 1 59 3 83 255 236 1 59 3 85 255 236 1 59 3 87 255 236 1 59 3 89 255 236 1 59 3 91 255 236 1 59 3 93 255 236 1 59 3 95 255 236 1 61 0 38 255 236 1 61 0 42 255 236 1 61 0 50 255 236 1 61 0 52 255 236 1 61 0 137 255 236 1 61 0 148 255 236 1 61 0 149 255 236 1 61 0 150 255 236 1 61 0 151 255 236 1 61 0 152 255 236 1 61 0 154 255 236 1 61 0 200 255 236 1 61 0 202 255 236 1 61 0 204 255 236 1 61 0 206 255 236 1 61 0 222 255 236 1 61 0 224 255 236 1 61 0 226 255 236 1 61 0 228 255 236 1 61 1 14 255 236 1 61 1 16 255 236 1 61 1 18 255 236 1 61 1 20 255 236 1 61 1 71 255 236 1 61 2 95 255 236 1 61 3 73 255 236 1 61 3 75 255 236 1 61 3 77 255 236 1 61 3 79 255 236 1 61 3 81 255 236 1 61 3 83 255 236 1 61 3 85 255 236 1 61 3 87 255 236 1 61 3 89 255 236 1 61 3 91 255 236 1 61 3 93 255 236 1 61 3 95 255 236 1 63 0 38 255 236 1 63 0 42 255 236 1 63 0 50 255 236 1 63 0 52 255 236 1 63 0 137 255 236 1 63 0 148 255 236 1 63 0 149 255 236 1 63 0 150 255 236 1 63 0 151 255 236 1 63 0 152 255 236 1 63 0 154 255 236 1 63 0 200 255 236 1 63 0 202 255 236 1 63 0 204 255 236 1 63 0 206 255 236 1 63 0 222 255 236 1 63 0 224 255 236 1 63 0 226 255 236 1 63 0 228 255 236 1 63 1 14 255 236 1 63 1 16 255 236 1 63 1 18 255 236 1 63 1 20 255 236 1 63 1 71 255 236 1 63 2 95 255 236 1 63 3 73 255 236 1 63 3 75 255 236 1 63 3 77 255 236 1 63 3 79 255 236 1 63 3 81 255 236 1 63 3 83 255 236 1 63 3 85 255 236 1 63 3 87 255 236 1 63 3 89 255 236 1 63 3 91 255 236 1 63 3 93 255 236 1 63 3 95 255 236 1 67 0 5 255 113 1 67 0 10 255 113 1 67 0 38 255 215 1 67 0 42 255 215 1 67 0 45 1 10 1 67 0 50 255 215 1 67 0 52 255 215 1 67 0 55 255 113 1 67 0 57 255 174 1 67 0 58 255 174 1 67 0 60 255 133 1 67 0 137 255 215 1 67 0 148 255 215 1 67 0 149 255 215 1 67 0 150 255 215 1 67 0 151 255 215 1 67 0 152 255 215 1 67 0 154 255 215 1 67 0 159 255 133 1 67 0 200 255 215 1 67 0 202 255 215 1 67 0 204 255 215 1 67 0 206 255 215 1 67 0 222 255 215 1 67 0 224 255 215 1 67 0 226 255 215 1 67 0 228 255 215 1 67 1 14 255 215 1 67 1 16 255 215 1 67 1 18 255 215 1 67 1 20 255 215 1 67 1 36 255 113 1 67 1 38 255 113 1 67 1 54 255 174 1 67 1 56 255 133 1 67 1 58 255 133 1 67 1 71 255 215 1 67 1 250 255 174 1 67 1 252 255 174 1 67 1 254 255 174 1 67 2 0 255 133 1 67 2 7 255 113 1 67 2 11 255 113 1 67 2 95 255 215 1 67 3 73 255 215 1 67 3 75 255 215 1 67 3 77 255 215 1 67 3 79 255 215 1 67 3 81 255 215 1 67 3 83 255 215 1 67 3 85 255 215 1 67 3 87 255 215 1 67 3 89 255 215 1 67 3 91 255 215 1 67 3 93 255 215 1 67 3 95 255 215 1 67 3 111 255 133 1 67 3 113 255 133 1 67 3 115 255 133 1 67 3 143 255 113 1 68 0 5 255 236 1 68 0 10 255 236 1 68 2 7 255 236 1 68 2 11 255 236 1 69 0 45 0 123 1 71 0 15 255 174 1 71 0 17 255 174 1 71 0 36 255 215 1 71 0 55 255 195 1 71 0 57 255 236 1 71 0 58 255 236 1 71 0 59 255 215 1 71 0 60 255 236 1 71 0 61 255 236 1 71 0 130 255 215 1 71 0 131 255 215 1 71 0 132 255 215 1 71 0 133 255 215 1 71 0 134 255 215 1 71 0 135 255 215 1 71 0 159 255 236 1 71 0 194 255 215 1 71 0 196 255 215 1 71 0 198 255 215 1 71 1 36 255 195 1 71 1 38 255 195 1 71 1 54 255 236 1 71 1 56 255 236 1 71 1 58 255 236 1 71 1 59 255 236 1 71 1 61 255 236 1 71 1 63 255 236 1 71 1 67 255 215 1 71 1 160 255 236 1 71 1 250 255 236 1 71 1 252 255 236 1 71 1 254 255 236 1 71 2 0 255 236 1 71 2 8 255 174 1 71 2 12 255 174 1 71 2 88 255 215 1 71 3 29 255 215 1 71 3 31 255 215 1 71 3 33 255 215 1 71 3 35 255 215 1 71 3 37 255 215 1 71 3 39 255 215 1 71 3 41 255 215 1 71 3 43 255 215 1 71 3 45 255 215 1 71 3 47 255 215 1 71 3 49 255 215 1 71 3 51 255 215 1 71 3 111 255 236 1 71 3 113 255 236 1 71 3 115 255 236 1 71 3 143 255 195 1 86 0 5 255 113 1 86 0 10 255 113 1 86 1 102 255 215 1 86 1 109 255 215 1 86 1 113 255 113 1 86 1 114 255 133 1 86 1 115 255 215 1 86 1 117 255 174 1 86 1 120 255 133 1 86 2 7 255 113 1 86 2 11 255 113 1 86 2 84 255 133 1 91 0 15 255 174 1 91 0 17 255 174 1 91 1 86 255 215 1 91 1 95 255 215 1 91 1 98 255 215 1 91 1 100 255 236 1 91 1 105 255 215 1 91 1 112 255 236 1 91 1 113 255 195 1 91 1 114 255 236 1 91 1 116 255 215 1 91 1 117 255 236 1 91 1 120 255 236 1 91 1 136 255 236 1 91 2 8 255 174 1 91 2 12 255 174 1 91 2 84 255 236 1 92 0 15 255 133 1 92 0 17 255 133 1 92 1 86 255 133 1 92 1 95 255 133 1 92 1 98 255 133 1 92 1 102 255 215 1 92 1 105 255 133 1 92 1 109 255 215 1 92 1 115 255 195 1 92 1 118 255 236 1 92 1 121 255 154 1 92 1 122 255 174 1 92 1 123 255 195 1 92 1 124 255 195 1 92 1 125 255 195 1 92 1 126 255 154 1 92 1 129 255 195 1 92 1 130 255 174 1 92 1 132 255 195 1 92 1 134 255 195 1 92 1 135 255 195 1 92 1 137 255 195 1 92 1 140 255 154 1 92 1 142 255 154 1 92 1 143 255 154 1 92 1 144 255 154 1 92 1 146 255 195 1 92 1 147 255 154 1 92 1 149 255 195 1 92 1 150 255 195 1 92 1 152 255 195 1 92 1 153 255 154 1 92 1 154 255 195 1 92 1 155 255 195 1 92 2 8 255 133 1 92 2 12 255 133 1 92 2 33 255 236 1 93 1 113 255 215 1 93 1 114 255 236 1 93 1 120 255 236 1 93 2 84 255 236 1 94 0 5 255 215 1 94 0 10 255 215 1 94 2 7 255 215 1 94 2 11 255 215 1 95 0 5 255 113 1 95 0 10 255 113 1 95 1 102 255 215 1 95 1 109 255 215 1 95 1 113 255 113 1 95 1 114 255 133 1 95 1 115 255 215 1 95 1 117 255 174 1 95 1 120 255 133 1 95 2 7 255 113 1 95 2 11 255 113 1 95 2 84 255 133 1 96 0 15 255 174 1 96 0 17 255 174 1 96 1 86 255 215 1 96 1 95 255 215 1 96 1 98 255 215 1 96 1 105 255 215 1 96 1 116 255 215 1 96 2 8 255 174 1 96 2 12 255 174 1 97 0 15 255 133 1 97 0 16 255 174 1 97 0 17 255 133 1 97 1 86 255 92 1 97 1 95 255 92 1 97 1 98 255 92 1 97 1 102 255 195 1 97 1 105 255 92 1 97 1 109 255 195 1 97 1 115 255 154 1 97 1 118 255 195 1 97 1 121 255 113 1 97 1 122 255 154 1 97 1 123 255 154 1 97 1 124 255 174 1 97 1 125 255 154 1 97 1 126 255 113 1 97 1 128 255 215 1 97 1 129 255 195 1 97 1 130 255 154 1 97 1 132 255 154 1 97 1 134 255 174 1 97 1 135 255 154 1 97 1 137 255 154 1 97 1 138 255 215 1 97 1 140 255 113 1 97 1 142 255 154 1 97 1 143 255 113 1 97 1 144 255 113 1 97 1 146 255 154 1 97 1 147 255 113 1 97 1 148 255 215 1 97 1 149 255 154 1 97 1 150 255 154 1 97 1 152 255 154 1 97 1 153 255 113 1 97 1 154 255 154 1 97 1 155 255 154 1 97 2 2 255 174 1 97 2 3 255 174 1 97 2 4 255 174 1 97 2 8 255 133 1 97 2 12 255 133 1 97 2 33 255 195 1 97 2 83 255 215 1 98 0 5 255 113 1 98 0 10 255 113 1 98 1 102 255 215 1 98 1 109 255 215 1 98 1 113 255 113 1 98 1 114 255 133 1 98 1 115 255 215 1 98 1 117 255 174 1 98 1 120 255 133 1 98 2 7 255 113 1 98 2 11 255 113 1 98 2 84 255 133 1 100 1 102 255 236 1 100 1 109 255 236 1 100 1 115 255 195 1 102 0 15 255 174 1 102 0 17 255 174 1 102 1 86 255 215 1 102 1 95 255 215 1 102 1 98 255 215 1 102 1 100 255 236 1 102 1 105 255 215 1 102 1 112 255 236 1 102 1 113 255 195 1 102 1 114 255 236 1 102 1 116 255 215 1 102 1 117 255 236 1 102 1 120 255 236 1 102 1 136 255 236 1 102 2 8 255 174 1 102 2 12 255 174 1 102 2 84 255 236 1 104 1 102 255 215 1 104 1 109 255 215 1 104 1 115 255 195 1 104 1 141 255 236 1 104 1 145 255 236 1 105 0 5 255 113 1 105 0 10 255 113 1 105 1 102 255 215 1 105 1 109 255 215 1 105 1 113 255 113 1 105 1 114 255 133 1 105 1 115 255 215 1 105 1 117 255 174 1 105 1 120 255 133 1 105 2 7 255 113 1 105 2 11 255 113 1 105 2 84 255 133 1 109 0 15 255 174 1 109 0 17 255 174 1 109 1 86 255 215 1 109 1 95 255 215 1 109 1 98 255 215 1 109 1 100 255 236 1 109 1 105 255 215 1 109 1 112 255 236 1 109 1 113 255 195 1 109 1 114 255 236 1 109 1 116 255 215 1 109 1 117 255 236 1 109 1 120 255 236 1 109 1 136 255 236 1 109 2 8 255 174 1 109 2 12 255 174 1 109 2 84 255 236 1 111 0 15 254 246 1 111 0 17 254 246 1 111 1 86 255 154 1 111 1 95 255 154 1 111 1 98 255 154 1 111 1 100 255 236 1 111 1 105 255 154 1 111 1 116 255 215 1 111 1 136 255 215 1 111 2 8 254 246 1 111 2 12 254 246 1 113 0 15 255 133 1 113 0 16 255 174 1 113 0 17 255 133 1 113 1 86 255 92 1 113 1 95 255 92 1 113 1 98 255 92 1 113 1 102 255 195 1 113 1 105 255 92 1 113 1 109 255 195 1 113 1 115 255 154 1 113 1 118 255 195 1 113 1 121 255 113 1 113 1 122 255 154 1 113 1 123 255 154 1 113 1 124 255 174 1 113 1 125 255 154 1 113 1 126 255 113 1 113 1 128 255 215 1 113 1 129 255 195 1 113 1 130 255 154 1 113 1 132 255 154 1 113 1 134 255 174 1 113 1 135 255 154 1 113 1 137 255 154 1 113 1 138 255 215 1 113 1 140 255 113 1 113 1 142 255 154 1 113 1 143 255 113 1 113 1 144 255 113 1 113 1 146 255 154 1 113 1 147 255 113 1 113 1 148 255 215 1 113 1 149 255 154 1 113 1 150 255 154 1 113 1 152 255 154 1 113 1 153 255 113 1 113 1 154 255 154 1 113 1 155 255 154 1 113 2 2 255 174 1 113 2 3 255 174 1 113 2 4 255 174 1 113 2 8 255 133 1 113 2 12 255 133 1 113 2 33 255 195 1 113 2 83 255 215 1 114 0 15 255 133 1 114 0 17 255 133 1 114 1 86 255 133 1 114 1 95 255 133 1 114 1 98 255 133 1 114 1 102 255 215 1 114 1 105 255 133 1 114 1 109 255 215 1 114 1 115 255 195 1 114 1 118 255 236 1 114 1 121 255 154 1 114 1 122 255 174 1 114 1 123 255 195 1 114 1 124 255 195 1 114 1 125 255 195 1 114 1 126 255 154 1 114 1 129 255 195 1 114 1 130 255 174 1 114 1 132 255 195 1 114 1 134 255 195 1 114 1 135 255 195 1 114 1 137 255 195 1 114 1 140 255 154 1 114 1 142 255 154 1 114 1 143 255 154 1 114 1 144 255 154 1 114 1 146 255 195 1 114 1 147 255 154 1 114 1 149 255 195 1 114 1 150 255 195 1 114 1 152 255 195 1 114 1 153 255 154 1 114 1 154 255 195 1 114 1 155 255 195 1 114 2 8 255 133 1 114 2 12 255 133 1 114 2 33 255 236 1 115 0 15 255 154 1 115 0 17 255 154 1 115 1 86 255 215 1 115 1 95 255 215 1 115 1 98 255 215 1 115 1 100 255 195 1 115 1 105 255 215 1 115 1 112 255 236 1 115 1 113 255 174 1 115 1 114 255 195 1 115 1 116 255 236 1 115 1 120 255 195 1 115 1 136 255 236 1 115 2 8 255 154 1 115 2 12 255 154 1 115 2 84 255 195 1 116 1 102 255 215 1 116 1 109 255 215 1 116 1 115 255 195 1 116 1 141 255 236 1 116 1 145 255 236 1 117 0 15 255 133 1 117 0 17 255 133 1 117 1 86 255 174 1 117 1 95 255 174 1 117 1 98 255 174 1 117 1 102 255 236 1 117 1 105 255 174 1 117 1 109 255 236 1 117 2 8 255 133 1 117 2 12 255 133 1 118 1 113 255 215 1 118 1 114 255 236 1 118 1 120 255 236 1 118 2 84 255 236 1 120 0 15 255 133 1 120 0 17 255 133 1 120 1 86 255 133 1 120 1 95 255 133 1 120 1 98 255 133 1 120 1 102 255 215 1 120 1 105 255 133 1 120 1 109 255 215 1 120 1 115 255 195 1 120 1 118 255 236 1 120 1 121 255 154 1 120 1 122 255 174 1 120 1 123 255 195 1 120 1 124 255 195 1 120 1 125 255 195 1 120 1 126 255 154 1 120 1 129 255 195 1 120 1 130 255 174 1 120 1 132 255 195 1 120 1 134 255 195 1 120 1 135 255 195 1 120 1 137 255 195 1 120 1 140 255 154 1 120 1 142 255 154 1 120 1 143 255 154 1 120 1 144 255 154 1 120 1 146 255 195 1 120 1 147 255 154 1 120 1 149 255 195 1 120 1 150 255 195 1 120 1 152 255 195 1 120 1 153 255 154 1 120 1 154 255 195 1 120 1 155 255 195 1 120 2 8 255 133 1 120 2 12 255 133 1 120 2 33 255 236 1 121 1 136 0 41 1 123 0 5 255 236 1 123 0 10 255 236 1 123 2 7 255 236 1 123 2 11 255 236 1 124 0 5 255 174 1 124 0 10 255 174 1 124 1 141 255 236 1 124 1 145 255 236 1 124 2 7 255 174 1 124 2 11 255 174 1 126 1 136 0 41 1 128 0 15 255 174 1 128 0 17 255 174 1 128 1 136 255 236 1 128 2 8 255 174 1 128 2 12 255 174 1 131 0 16 255 154 1 131 1 121 255 215 1 131 1 126 255 215 1 131 1 129 255 215 1 131 1 140 255 215 1 131 1 141 255 215 1 131 1 143 255 215 1 131 1 144 255 215 1 131 1 145 255 215 1 131 1 147 255 215 1 131 1 153 255 215 1 131 2 2 255 154 1 131 2 3 255 154 1 131 2 4 255 154 1 132 0 5 255 236 1 132 0 10 255 236 1 132 2 7 255 236 1 132 2 11 255 236 1 133 0 15 255 215 1 133 0 17 255 215 1 133 2 8 255 215 1 133 2 12 255 215 1 134 0 5 255 174 1 134 0 10 255 174 1 134 1 141 255 236 1 134 1 145 255 236 1 134 2 7 255 174 1 134 2 11 255 174 1 135 1 121 255 215 1 135 1 126 255 215 1 135 1 140 255 215 1 135 1 143 255 215 1 135 1 144 255 215 1 135 1 147 255 215 1 135 1 153 255 215 1 136 0 5 255 133 1 136 0 10 255 133 1 136 1 121 255 236 1 136 1 126 255 236 1 136 1 128 255 215 1 136 1 138 255 215 1 136 1 140 255 236 1 136 1 141 255 215 1 136 1 143 255 236 1 136 1 144 255 236 1 136 1 145 255 215 1 136 1 147 255 236 1 136 1 153 255 236 1 136 2 7 255 133 1 136 2 11 255 133 1 138 0 15 255 174 1 138 0 17 255 174 1 138 1 136 255 236 1 138 2 8 255 174 1 138 2 12 255 174 1 140 0 5 255 236 1 140 0 10 255 236 1 140 1 128 255 215 1 140 1 138 255 215 1 140 2 7 255 236 1 140 2 11 255 236 1 142 0 5 255 236 1 142 0 10 255 236 1 142 1 128 255 215 1 142 1 138 255 215 1 142 2 7 255 236 1 142 2 11 255 236 1 144 0 15 255 236 1 144 0 17 255 236 1 144 2 8 255 236 1 144 2 12 255 236 1 147 0 5 255 236 1 147 0 10 255 236 1 147 1 128 255 215 1 147 1 138 255 215 1 147 2 7 255 236 1 147 2 11 255 236 1 148 0 15 255 195 1 148 0 16 255 215 1 148 0 17 255 195 1 148 1 121 255 215 1 148 1 126 255 215 1 148 1 129 255 215 1 148 1 140 255 215 1 148 1 143 255 215 1 148 1 144 255 215 1 148 1 147 255 215 1 148 1 153 255 215 1 148 2 2 255 215 1 148 2 3 255 215 1 148 2 4 255 215 1 148 2 8 255 195 1 148 2 12 255 195 1 151 0 5 255 215 1 151 0 10 255 215 1 151 2 7 255 215 1 151 2 11 255 215 1 153 0 5 255 236 1 153 0 10 255 236 1 153 1 128 255 215 1 153 1 138 255 215 1 153 2 7 255 236 1 153 2 11 255 236 1 157 0 5 255 174 1 157 0 10 255 174 1 157 1 157 255 133 1 157 1 166 255 133 1 157 1 168 255 215 1 157 1 188 255 154 1 157 1 189 255 215 1 157 1 193 255 154 1 157 1 196 255 133 1 157 1 220 255 215 1 157 1 221 255 215 1 157 1 225 255 215 1 157 1 228 255 215 1 157 1 246 255 215 1 157 2 7 255 174 1 157 2 11 255 174 1 157 2 110 255 174 1 157 2 124 255 154 1 157 2 128 255 174 1 157 2 130 255 174 1 157 2 151 255 174 1 157 2 155 255 174 1 157 2 167 255 174 1 157 2 169 255 133 1 157 2 170 255 215 1 157 2 181 255 154 1 157 2 182 255 215 1 157 2 183 255 154 1 157 2 184 255 215 1 157 2 185 255 154 1 157 2 186 255 215 1 157 2 189 255 133 1 157 2 190 255 215 1 157 2 191 255 154 1 157 2 192 255 215 1 157 2 193 255 154 1 157 2 194 255 215 1 157 2 212 255 154 1 157 2 213 255 215 1 157 2 247 255 215 1 157 2 248 255 215 1 157 2 249 255 215 1 157 2 250 255 215 1 157 2 251 255 215 1 157 2 252 255 215 1 157 2 253 255 154 1 157 2 254 255 215 1 157 3 3 255 174 1 157 3 13 255 154 1 157 3 14 255 195 1 157 3 15 255 154 1 157 3 16 255 195 1 157 3 23 255 133 1 157 3 24 255 215 1 158 0 15 255 133 1 158 0 16 255 174 1 158 0 17 255 133 1 158 1 159 255 215 1 158 1 164 255 154 1 158 1 170 255 113 1 158 1 174 255 154 1 158 1 181 255 154 1 158 1 184 255 215 1 158 1 187 255 215 1 158 1 188 0 41 1 158 1 190 255 174 1 158 1 204 255 154 1 158 1 205 255 154 1 158 1 206 255 133 1 158 1 207 255 113 1 158 1 208 255 215 1 158 1 209 255 215 1 158 1 210 255 154 1 158 1 211 255 154 1 158 1 212 255 154 1 158 1 213 255 133 1 158 1 214 255 154 1 158 1 215 255 154 1 158 1 216 255 113 1 158 1 217 255 154 1 158 1 218 255 154 1 158 1 219 255 113 1 158 1 220 255 174 1 158 1 221 255 174 1 158 1 222 255 113 1 158 1 223 255 215 1 158 1 224 255 154 1 158 1 225 255 154 1 158 1 226 255 154 1 158 1 227 255 154 1 158 1 228 255 174 1 158 1 229 255 154 1 158 1 230 255 154 1 158 1 231 255 215 1 158 1 232 255 154 1 158 1 233 255 195 1 158 1 234 255 113 1 158 1 236 255 154 1 158 1 237 255 113 1 158 1 238 255 133 1 158 1 242 255 133 1 158 1 243 255 154 1 158 1 245 255 154 1 158 1 246 255 174 1 158 1 247 255 154 1 158 1 249 255 154 1 158 2 2 255 174 1 158 2 3 255 174 1 158 2 4 255 174 1 158 2 8 255 133 1 158 2 12 255 133 1 158 2 106 255 113 1 158 2 107 255 154 1 158 2 108 255 215 1 158 2 109 255 215 1 158 2 113 255 154 1 158 2 114 255 113 1 158 2 115 255 133 1 158 2 117 255 154 1 158 2 119 255 154 1 158 2 121 255 154 1 158 2 125 255 154 1 158 2 126 255 215 1 158 2 127 255 113 1 158 2 129 255 215 1 158 2 131 255 215 1 158 2 132 255 215 1 158 2 133 255 113 1 158 2 134 255 215 1 158 2 135 255 113 1 158 2 136 255 215 1 158 2 137 255 113 1 158 2 138 255 215 1 158 2 139 255 215 1 158 2 140 255 215 1 158 2 141 255 113 1 158 2 150 255 154 1 158 2 154 255 154 1 158 2 158 255 154 1 158 2 160 255 215 1 158 2 162 255 215 1 158 2 164 255 154 1 158 2 166 255 154 1 158 2 170 255 174 1 158 2 172 255 154 1 158 2 174 255 154 1 158 2 176 255 154 1 158 2 177 255 215 1 158 2 178 255 113 1 158 2 179 255 215 1 158 2 180 255 113 1 158 2 181 0 41 1 158 2 182 255 174 1 158 2 184 255 174 1 158 2 186 255 174 1 158 2 188 255 215 1 158 2 190 255 174 1 158 2 192 255 154 1 158 2 194 255 154 1 158 2 196 255 154 1 158 2 197 255 154 1 158 2 198 255 113 1 158 2 199 255 154 1 158 2 200 255 113 1 158 2 203 255 215 1 158 2 205 255 154 1 158 2 206 255 154 1 158 2 207 255 133 1 158 2 209 255 154 1 158 2 211 255 154 1 158 2 213 255 154 1 158 2 215 255 154 1 158 2 217 255 113 1 158 2 219 255 113 1 158 2 221 255 113 1 158 2 224 255 113 1 158 2 230 255 215 1 158 2 232 255 215 1 158 2 234 255 195 1 158 2 236 255 154 1 158 2 238 255 154 1 158 2 239 255 215 1 158 2 240 255 113 1 158 2 241 255 215 1 158 2 242 255 113 1 158 2 243 255 215 1 158 2 244 255 113 1 158 2 246 255 215 1 158 2 248 255 174 1 158 2 250 255 174 1 158 2 252 255 174 1 158 2 254 255 154 1 158 3 0 255 154 1 158 3 2 255 154 1 158 3 6 255 215 1 158 3 8 255 215 1 158 3 9 255 113 1 158 3 10 255 113 1 158 3 11 255 113 1 158 3 12 255 113 1 158 3 14 255 154 1 158 3 16 255 154 1 158 3 17 255 154 1 158 3 18 255 133 1 158 3 20 255 154 1 158 3 21 255 215 1 158 3 22 255 113 1 158 3 24 255 174 1 158 3 26 255 113 1 158 3 27 255 154 1 158 3 28 255 133 1 159 1 159 255 215 1 159 1 184 255 215 1 159 1 187 255 215 1 159 1 190 255 215 1 159 1 225 255 215 1 159 2 108 255 215 1 159 2 126 255 215 1 159 2 132 255 215 1 159 2 134 255 215 1 159 2 136 255 215 1 159 2 138 255 215 1 159 2 140 255 215 1 159 2 177 255 215 1 159 2 179 255 215 1 159 2 192 255 215 1 159 2 194 255 215 1 159 2 197 255 215 1 159 2 199 255 215 1 159 2 213 255 215 1 159 2 239 255 215 1 159 2 241 255 215 1 159 2 243 255 215 1 159 2 254 255 215 1 159 3 9 255 215 1 159 3 11 255 215 1 159 3 14 255 215 1 159 3 16 255 215 1 159 3 21 255 215 1 160 3 14 255 215 1 160 3 16 255 215 1 164 0 5 255 174 1 164 0 10 255 174 1 164 1 157 255 133 1 164 1 166 255 133 1 164 1 168 255 215 1 164 1 188 255 154 1 164 1 189 255 215 1 164 1 193 255 154 1 164 1 196 255 133 1 164 1 220 255 215 1 164 1 221 255 215 1 164 1 225 255 215 1 164 1 228 255 215 1 164 1 246 255 215 1 164 2 7 255 174 1 164 2 11 255 174 1 164 2 110 255 174 1 164 2 124 255 154 1 164 2 128 255 174 1 164 2 130 255 174 1 164 2 151 255 174 1 164 2 155 255 174 1 164 2 167 255 174 1 164 2 169 255 133 1 164 2 170 255 215 1 164 2 181 255 154 1 164 2 182 255 215 1 164 2 183 255 154 1 164 2 184 255 215 1 164 2 185 255 154 1 164 2 186 255 215 1 164 2 189 255 133 1 164 2 190 255 215 1 164 2 191 255 154 1 164 2 192 255 215 1 164 2 193 255 154 1 164 2 194 255 215 1 164 2 212 255 154 1 164 2 213 255 215 1 164 2 247 255 215 1 164 2 248 255 215 1 164 2 249 255 215 1 164 2 250 255 215 1 164 2 251 255 215 1 164 2 252 255 215 1 164 2 253 255 154 1 164 2 254 255 215 1 164 3 3 255 174 1 164 3 13 255 154 1 164 3 14 255 195 1 164 3 15 255 154 1 164 3 16 255 195 1 164 3 23 255 133 1 164 3 24 255 215 1 165 0 5 255 174 1 165 0 10 255 174 1 165 1 157 255 133 1 165 1 166 255 133 1 165 1 168 255 215 1 165 1 188 255 154 1 165 1 189 255 215 1 165 1 193 255 154 1 165 1 196 255 133 1 165 1 220 255 215 1 165 1 221 255 215 1 165 1 225 255 215 1 165 1 228 255 215 1 165 1 246 255 215 1 165 2 7 255 174 1 165 2 11 255 174 1 165 2 110 255 174 1 165 2 124 255 154 1 165 2 128 255 174 1 165 2 130 255 174 1 165 2 151 255 174 1 165 2 155 255 174 1 165 2 167 255 174 1 165 2 169 255 133 1 165 2 170 255 215 1 165 2 181 255 154 1 165 2 182 255 215 1 165 2 183 255 154 1 165 2 184 255 215 1 165 2 185 255 154 1 165 2 186 255 215 1 165 2 189 255 133 1 165 2 190 255 215 1 165 2 191 255 154 1 165 2 192 255 215 1 165 2 193 255 154 1 165 2 194 255 215 1 165 2 212 255 154 1 165 2 213 255 215 1 165 2 247 255 215 1 165 2 248 255 215 1 165 2 249 255 215 1 165 2 250 255 215 1 165 2 251 255 215 1 165 2 252 255 215 1 165 2 253 255 154 1 165 2 254 255 215 1 165 3 3 255 174 1 165 3 13 255 154 1 165 3 14 255 195 1 165 3 15 255 154 1 165 3 16 255 195 1 165 3 23 255 133 1 165 3 24 255 215 1 166 0 5 255 174 1 166 0 10 255 174 1 166 1 157 255 133 1 166 1 166 255 133 1 166 1 168 255 215 1 166 1 188 255 154 1 166 1 189 255 215 1 166 1 193 255 154 1 166 1 196 255 133 1 166 1 220 255 215 1 166 1 221 255 215 1 166 1 225 255 215 1 166 1 228 255 215 1 166 1 246 255 215 1 166 2 7 255 174 1 166 2 11 255 174 1 166 2 110 255 174 1 166 2 124 255 154 1 166 2 128 255 174 1 166 2 130 255 174 1 166 2 151 255 174 1 166 2 155 255 174 1 166 2 167 255 174 1 166 2 169 255 133 1 166 2 170 255 215 1 166 2 181 255 154 1 166 2 182 255 215 1 166 2 183 255 154 1 166 2 184 255 215 1 166 2 185 255 154 1 166 2 186 255 215 1 166 2 189 255 133 1 166 2 190 255 215 1 166 2 191 255 154 1 166 2 192 255 215 1 166 2 193 255 154 1 166 2 194 255 215 1 166 2 212 255 154 1 166 2 213 255 215 1 166 2 247 255 215 1 166 2 248 255 215 1 166 2 249 255 215 1 166 2 250 255 215 1 166 2 251 255 215 1 166 2 252 255 215 1 166 2 253 255 154 1 166 2 254 255 215 1 166 3 3 255 174 1 166 3 13 255 154 1 166 3 14 255 195 1 166 3 15 255 154 1 166 3 16 255 195 1 166 3 23 255 133 1 166 3 24 255 215 1 167 1 159 255 215 1 167 1 184 255 215 1 167 1 187 255 215 1 167 1 190 255 215 1 167 1 193 255 215 1 167 1 225 255 215 1 167 2 108 255 215 1 167 2 124 255 215 1 167 2 126 255 215 1 167 2 132 255 215 1 167 2 134 255 215 1 167 2 136 255 215 1 167 2 138 255 215 1 167 2 140 255 215 1 167 2 177 255 215 1 167 2 179 255 215 1 167 2 191 255 215 1 167 2 192 255 215 1 167 2 193 255 215 1 167 2 194 255 215 1 167 2 197 255 154 1 167 2 199 255 154 1 167 2 212 255 215 1 167 2 213 255 215 1 167 2 239 255 215 1 167 2 241 255 215 1 167 2 243 255 215 1 167 2 253 255 215 1 167 2 254 255 215 1 167 3 9 255 215 1 167 3 11 255 215 1 167 3 14 255 215 1 167 3 16 255 215 1 167 3 21 255 215 1 167 3 25 255 236 1 168 0 15 255 133 1 168 0 17 255 133 1 168 1 159 255 236 1 168 1 164 255 154 1 168 1 170 255 113 1 168 1 174 255 154 1 168 1 181 255 154 1 168 1 184 255 236 1 168 1 187 255 236 1 168 1 190 255 195 1 168 1 201 255 236 1 168 1 206 255 174 1 168 1 207 255 215 1 168 1 213 255 174 1 168 1 216 255 215 1 168 1 219 255 215 1 168 1 222 255 215 1 168 1 225 255 215 1 168 1 234 255 215 1 168 1 235 0 102 1 168 1 237 255 215 1 168 1 238 255 236 1 168 1 242 255 174 1 168 1 244 0 102 1 168 2 8 255 133 1 168 2 12 255 133 1 168 2 106 255 215 1 168 2 108 255 236 1 168 2 114 255 113 1 168 2 115 255 174 1 168 2 126 255 236 1 168 2 127 255 215 1 168 2 132 255 236 1 168 2 133 255 215 1 168 2 134 255 236 1 168 2 135 255 215 1 168 2 136 255 236 1 168 2 137 255 215 1 168 2 138 255 236 1 168 2 140 255 236 1 168 2 141 255 215 1 168 2 152 0 102 1 168 2 168 0 102 1 168 2 177 255 236 1 168 2 178 255 215 1 168 2 179 255 236 1 168 2 180 255 215 1 168 2 192 255 215 1 168 2 194 255 215 1 168 2 197 255 215 1 168 2 198 255 195 1 168 2 199 255 215 1 168 2 200 255 195 1 168 2 206 255 154 1 168 2 207 255 174 1 168 2 213 255 215 1 168 2 217 255 113 1 168 2 219 255 113 1 168 2 221 255 113 1 168 2 224 255 215 1 168 2 239 255 236 1 168 2 240 255 215 1 168 2 241 255 236 1 168 2 242 255 215 1 168 2 243 255 236 1 168 2 244 255 215 1 168 2 254 255 215 1 168 3 9 255 113 1 168 3 10 255 215 1 168 3 11 255 113 1 168 3 12 255 215 1 168 3 17 255 154 1 168 3 18 255 174 1 168 3 21 255 236 1 168 3 22 255 215 1 168 3 26 255 215 1 168 3 27 255 154 1 168 3 28 255 174 1 170 0 5 255 113 1 170 0 10 255 113 1 170 1 157 255 154 1 170 1 166 255 154 1 170 1 188 255 113 1 170 1 190 255 215 1 170 1 193 255 154 1 170 1 196 255 154 1 170 1 220 255 215 1 170 1 225 255 215 1 170 1 228 255 215 1 170 2 7 255 113 1 170 2 11 255 113 1 170 2 110 255 215 1 170 2 124 255 154 1 170 2 128 255 174 1 170 2 130 255 174 1 170 2 151 255 215 1 170 2 155 255 215 1 170 2 167 255 215 1 170 2 169 255 154 1 170 2 170 255 215 1 170 2 181 255 113 1 170 2 182 255 215 1 170 2 183 255 133 1 170 2 185 255 133 1 170 2 189 255 154 1 170 2 190 255 215 1 170 2 191 255 154 1 170 2 192 255 215 1 170 2 193 255 154 1 170 2 194 255 215 1 170 2 197 255 154 1 170 2 199 255 154 1 170 2 212 255 154 1 170 2 213 255 215 1 170 2 225 255 215 1 170 2 227 255 215 1 170 2 253 255 154 1 170 2 254 255 215 1 170 3 3 255 215 1 170 3 13 255 113 1 170 3 14 255 215 1 170 3 15 255 113 1 170 3 16 255 215 1 170 3 23 255 154 1 170 3 24 255 215 1 171 0 5 255 215 1 171 0 10 255 215 1 171 1 170 255 236 1 171 1 193 255 215 1 171 2 7 255 215 1 171 2 11 255 215 1 171 2 114 255 236 1 171 2 124 255 215 1 171 2 191 255 215 1 171 2 193 255 215 1 171 2 197 255 215 1 171 2 199 255 215 1 171 2 212 255 215 1 171 2 217 255 236 1 171 2 219 255 236 1 171 2 221 255 236 1 171 2 253 255 215 1 172 0 15 255 174 1 172 0 17 255 174 1 172 2 8 255 174 1 172 2 12 255 174 1 172 2 128 255 236 1 172 2 130 255 236 1 172 2 183 255 236 1 172 2 185 255 236 1 172 3 13 255 215 1 172 3 15 255 215 1 173 0 15 255 133 1 173 0 16 255 174 1 173 0 17 255 133 1 173 1 159 255 215 1 173 1 164 255 154 1 173 1 170 255 113 1 173 1 174 255 154 1 173 1 181 255 154 1 173 1 184 255 215 1 173 1 187 255 215 1 173 1 188 0 41 1 173 1 190 255 174 1 173 1 204 255 154 1 173 1 205 255 154 1 173 1 206 255 133 1 173 1 207 255 113 1 173 1 208 255 215 1 173 1 209 255 215 1 173 1 210 255 154 1 173 1 211 255 154 1 173 1 212 255 154 1 173 1 213 255 133 1 173 1 214 255 154 1 173 1 215 255 154 1 173 1 216 255 113 1 173 1 217 255 154 1 173 1 218 255 154 1 173 1 219 255 113 1 173 1 220 255 174 1 173 1 221 255 174 1 173 1 222 255 113 1 173 1 223 255 215 1 173 1 224 255 154 1 173 1 225 255 154 1 173 1 226 255 154 1 173 1 227 255 154 1 173 1 228 255 174 1 173 1 229 255 154 1 173 1 230 255 154 1 173 1 231 255 215 1 173 1 232 255 154 1 173 1 233 255 195 1 173 1 234 255 113 1 173 1 236 255 154 1 173 1 237 255 113 1 173 1 238 255 133 1 173 1 242 255 133 1 173 1 243 255 154 1 173 1 245 255 154 1 173 1 246 255 174 1 173 1 247 255 154 1 173 1 249 255 154 1 173 2 2 255 174 1 173 2 3 255 174 1 173 2 4 255 174 1 173 2 8 255 133 1 173 2 12 255 133 1 173 2 106 255 113 1 173 2 107 255 154 1 173 2 108 255 215 1 173 2 109 255 215 1 173 2 113 255 154 1 173 2 114 255 113 1 173 2 115 255 133 1 173 2 117 255 154 1 173 2 119 255 154 1 173 2 121 255 154 1 173 2 125 255 154 1 173 2 126 255 215 1 173 2 127 255 113 1 173 2 129 255 215 1 173 2 131 255 215 1 173 2 132 255 215 1 173 2 133 255 113 1 173 2 134 255 215 1 173 2 135 255 113 1 173 2 136 255 215 1 173 2 137 255 113 1 173 2 138 255 215 1 173 2 139 255 215 1 173 2 140 255 215 1 173 2 141 255 113 1 173 2 150 255 154 1 173 2 154 255 154 1 173 2 158 255 154 1 173 2 160 255 215 1 173 2 162 255 215 1 173 2 164 255 154 1 173 2 166 255 154 1 173 2 170 255 174 1 173 2 172 255 154 1 173 2 174 255 154 1 173 2 176 255 154 1 173 2 177 255 215 1 173 2 178 255 113 1 173 2 179 255 215 1 173 2 180 255 113 1 173 2 181 0 41 1 173 2 182 255 174 1 173 2 184 255 174 1 173 2 186 255 174 1 173 2 188 255 215 1 173 2 190 255 174 1 173 2 192 255 154 1 173 2 194 255 154 1 173 2 196 255 154 1 173 2 197 255 154 1 173 2 198 255 113 1 173 2 199 255 154 1 173 2 200 255 113 1 173 2 203 255 215 1 173 2 205 255 154 1 173 2 206 255 154 1 173 2 207 255 133 1 173 2 209 255 154 1 173 2 211 255 154 1 173 2 213 255 154 1 173 2 215 255 154 1 173 2 217 255 113 1 173 2 219 255 113 1 173 2 221 255 113 1 173 2 224 255 113 1 173 2 230 255 215 1 173 2 232 255 215 1 173 2 234 255 195 1 173 2 236 255 154 1 173 2 238 255 154 1 173 2 239 255 215 1 173 2 240 255 113 1 173 2 241 255 215 1 173 2 242 255 113 1 173 2 243 255 215 1 173 2 244 255 113 1 173 2 246 255 215 1 173 2 248 255 174 1 173 2 250 255 174 1 173 2 252 255 174 1 173 2 254 255 154 1 173 3 0 255 154 1 173 3 2 255 154 1 173 3 6 255 215 1 173 3 8 255 215 1 173 3 9 255 113 1 173 3 10 255 113 1 173 3 11 255 113 1 173 3 12 255 113 1 173 3 14 255 154 1 173 3 16 255 154 1 173 3 17 255 154 1 173 3 18 255 133 1 173 3 20 255 154 1 173 3 21 255 215 1 173 3 22 255 113 1 173 3 24 255 174 1 173 3 26 255 113 1 173 3 27 255 154 1 173 3 28 255 133 1 174 1 163 0 225 1 174 2 234 0 41 1 174 3 14 255 215 1 174 3 16 255 215 1 176 1 159 255 215 1 176 1 184 255 215 1 176 1 187 255 215 1 176 1 190 255 215 1 176 1 193 255 215 1 176 1 225 255 215 1 176 2 108 255 215 1 176 2 124 255 215 1 176 2 126 255 215 1 176 2 132 255 215 1 176 2 134 255 215 1 176 2 136 255 215 1 176 2 138 255 215 1 176 2 140 255 215 1 176 2 177 255 215 1 176 2 179 255 215 1 176 2 191 255 215 1 176 2 192 255 215 1 176 2 193 255 215 1 176 2 194 255 215 1 176 2 197 255 154 1 176 2 199 255 154 1 176 2 212 255 215 1 176 2 213 255 215 1 176 2 239 255 215 1 176 2 241 255 215 1 176 2 243 255 215 1 176 2 253 255 215 1 176 2 254 255 215 1 176 3 9 255 215 1 176 3 11 255 215 1 176 3 14 255 215 1 176 3 16 255 215 1 176 3 21 255 215 1 176 3 25 255 236 1 177 0 15 255 174 1 177 0 17 255 174 1 177 2 8 255 174 1 177 2 12 255 174 1 177 2 128 255 236 1 177 2 130 255 236 1 177 2 183 255 236 1 177 2 185 255 236 1 177 3 13 255 215 1 177 3 15 255 215 1 180 1 159 255 215 1 180 1 184 255 215 1 180 1 187 255 215 1 180 1 190 255 215 1 180 1 193 255 215 1 180 1 225 255 215 1 180 2 108 255 215 1 180 2 124 255 215 1 180 2 126 255 215 1 180 2 132 255 215 1 180 2 134 255 215 1 180 2 136 255 215 1 180 2 138 255 215 1 180 2 140 255 215 1 180 2 177 255 215 1 180 2 179 255 215 1 180 2 191 255 215 1 180 2 192 255 215 1 180 2 193 255 215 1 180 2 194 255 215 1 180 2 197 255 154 1 180 2 199 255 154 1 180 2 212 255 215 1 180 2 213 255 215 1 180 2 239 255 215 1 180 2 241 255 215 1 180 2 243 255 215 1 180 2 253 255 215 1 180 2 254 255 215 1 180 3 9 255 215 1 180 3 11 255 215 1 180 3 14 255 215 1 180 3 16 255 215 1 180 3 21 255 215 1 180 3 25 255 236 1 184 0 15 255 174 1 184 0 17 255 174 1 184 1 157 255 236 1 184 1 164 255 215 1 184 1 166 255 236 1 184 1 168 255 215 1 184 1 170 255 215 1 184 1 174 255 215 1 184 1 176 255 215 1 184 1 177 255 236 1 184 1 181 255 215 1 184 1 188 255 195 1 184 1 189 255 215 1 184 1 191 255 215 1 184 1 193 255 215 1 184 1 196 255 236 1 184 1 199 255 236 1 184 1 206 255 236 1 184 1 213 255 236 1 184 1 242 255 236 1 184 2 8 255 174 1 184 2 12 255 174 1 184 2 114 255 215 1 184 2 115 255 236 1 184 2 122 255 236 1 184 2 124 255 215 1 184 2 128 255 236 1 184 2 130 255 236 1 184 2 159 255 215 1 184 2 161 255 236 1 184 2 169 255 236 1 184 2 181 255 195 1 184 2 183 255 236 1 184 2 185 255 236 1 184 2 187 255 215 1 184 2 189 255 236 1 184 2 191 255 215 1 184 2 193 255 215 1 184 2 202 255 215 1 184 2 206 255 215 1 184 2 207 255 236 1 184 2 212 255 215 1 184 2 217 255 215 1 184 2 219 255 215 1 184 2 221 255 215 1 184 2 229 255 215 1 184 2 231 255 236 1 184 2 245 255 236 1 184 2 247 255 215 1 184 2 249 255 215 1 184 2 251 255 215 1 184 2 253 255 215 1 184 3 5 255 215 1 184 3 7 255 215 1 184 3 13 255 215 1 184 3 15 255 215 1 184 3 17 255 215 1 184 3 18 255 236 1 184 3 23 255 236 1 184 3 27 255 215 1 184 3 28 255 236 1 186 0 15 254 246 1 186 0 17 254 246 1 186 1 164 255 133 1 186 1 170 255 154 1 186 1 174 255 133 1 186 1 176 255 215 1 186 1 181 255 133 1 186 1 191 255 215 1 186 1 206 255 154 1 186 1 213 255 154 1 186 1 242 255 154 1 186 2 8 254 246 1 186 2 12 254 246 1 186 2 114 255 154 1 186 2 115 255 154 1 186 2 118 255 236 1 186 2 159 255 215 1 186 2 187 255 215 1 186 2 202 255 215 1 186 2 206 255 133 1 186 2 207 255 154 1 186 2 217 255 154 1 186 2 219 255 154 1 186 2 221 255 154 1 186 2 229 255 215 1 186 3 5 255 215 1 186 3 7 255 215 1 186 3 9 255 174 1 186 3 11 255 174 1 186 3 17 255 133 1 186 3 18 255 154 1 186 3 27 255 133 1 186 3 28 255 154 1 187 1 159 255 215 1 187 1 184 255 215 1 187 1 187 255 215 1 187 1 190 255 215 1 187 1 225 255 215 1 187 2 108 255 215 1 187 2 126 255 215 1 187 2 132 255 215 1 187 2 134 255 215 1 187 2 136 255 215 1 187 2 138 255 215 1 187 2 140 255 215 1 187 2 177 255 215 1 187 2 179 255 215 1 187 2 192 255 215 1 187 2 194 255 215 1 187 2 197 255 215 1 187 2 199 255 215 1 187 2 213 255 215 1 187 2 239 255 215 1 187 2 241 255 215 1 187 2 243 255 215 1 187 2 254 255 215 1 187 3 9 255 215 1 187 3 11 255 215 1 187 3 14 255 215 1 187 3 16 255 215 1 187 3 21 255 215 1 188 0 15 255 133 1 188 0 16 255 174 1 188 0 17 255 133 1 188 1 159 255 215 1 188 1 164 255 154 1 188 1 170 255 113 1 188 1 174 255 154 1 188 1 181 255 154 1 188 1 184 255 215 1 188 1 187 255 215 1 188 1 188 0 41 1 188 1 190 255 174 1 188 1 204 255 154 1 188 1 205 255 154 1 188 1 206 255 133 1 188 1 207 255 113 1 188 1 208 255 215 1 188 1 209 255 215 1 188 1 210 255 154 1 188 1 211 255 154 1 188 1 212 255 154 1 188 1 213 255 133 1 188 1 214 255 154 1 188 1 215 255 154 1 188 1 216 255 113 1 188 1 217 255 154 1 188 1 218 255 154 1 188 1 219 255 113 1 188 1 220 255 174 1 188 1 221 255 174 1 188 1 222 255 113 1 188 1 223 255 215 1 188 1 224 255 154 1 188 1 225 255 154 1 188 1 226 255 154 1 188 1 227 255 154 1 188 1 228 255 174 1 188 1 229 255 154 1 188 1 230 255 154 1 188 1 231 255 215 1 188 1 232 255 154 1 188 1 233 255 195 1 188 1 234 255 113 1 188 1 236 255 154 1 188 1 237 255 113 1 188 1 238 255 133 1 188 1 242 255 133 1 188 1 243 255 154 1 188 1 245 255 154 1 188 1 246 255 174 1 188 1 247 255 154 1 188 1 249 255 154 1 188 2 2 255 174 1 188 2 3 255 174 1 188 2 4 255 174 1 188 2 8 255 133 1 188 2 12 255 133 1 188 2 106 255 113 1 188 2 107 255 154 1 188 2 108 255 215 1 188 2 109 255 215 1 188 2 113 255 154 1 188 2 114 255 113 1 188 2 115 255 133 1 188 2 117 255 154 1 188 2 119 255 154 1 188 2 121 255 154 1 188 2 125 255 154 1 188 2 126 255 215 1 188 2 127 255 113 1 188 2 129 255 215 1 188 2 131 255 215 1 188 2 132 255 215 1 188 2 133 255 113 1 188 2 134 255 215 1 188 2 135 255 113 1 188 2 136 255 215 1 188 2 137 255 113 1 188 2 138 255 215 1 188 2 139 255 215 1 188 2 140 255 215 1 188 2 141 255 113 1 188 2 150 255 154 1 188 2 154 255 154 1 188 2 158 255 154 1 188 2 160 255 215 1 188 2 162 255 215 1 188 2 164 255 154 1 188 2 166 255 154 1 188 2 170 255 174 1 188 2 172 255 154 1 188 2 174 255 154 1 188 2 176 255 154 1 188 2 177 255 215 1 188 2 178 255 113 1 188 2 179 255 215 1 188 2 180 255 113 1 188 2 181 0 41 1 188 2 182 255 174 1 188 2 184 255 174 1 188 2 186 255 174 1 188 2 188 255 215 1 188 2 190 255 174 1 188 2 192 255 154 1 188 2 194 255 154 1 188 2 196 255 154 1 188 2 197 255 154 1 188 2 198 255 113 1 188 2 199 255 154 1 188 2 200 255 113 1 188 2 203 255 215 1 188 2 205 255 154 1 188 2 206 255 154 1 188 2 207 255 133 1 188 2 209 255 154 1 188 2 211 255 154 1 188 2 213 255 154 1 188 2 215 255 154 1 188 2 217 255 113 1 188 2 219 255 113 1 188 2 221 255 113 1 188 2 224 255 113 1 188 2 230 255 215 1 188 2 232 255 215 1 188 2 234 255 195 1 188 2 236 255 154 1 188 2 238 255 154 1 188 2 239 255 215 1 188 2 240 255 113 1 188 2 241 255 215 1 188 2 242 255 113 1 188 2 243 255 215 1 188 2 244 255 113 1 188 2 246 255 215 1 188 2 248 255 174 1 188 2 250 255 174 1 188 2 252 255 174 1 188 2 254 255 154 1 188 3 0 255 154 1 188 3 2 255 154 1 188 3 6 255 215 1 188 3 8 255 215 1 188 3 9 255 113 1 188 3 10 255 113 1 188 3 11 255 113 1 188 3 12 255 113 1 188 3 14 255 154 1 188 3 16 255 154 1 188 3 17 255 154 1 188 3 18 255 133 1 188 3 20 255 154 1 188 3 21 255 215 1 188 3 22 255 113 1 188 3 24 255 174 1 188 3 26 255 113 1 188 3 27 255 154 1 188 3 28 255 133 1 189 0 15 255 133 1 189 0 17 255 133 1 189 1 159 255 236 1 189 1 164 255 154 1 189 1 170 255 113 1 189 1 174 255 154 1 189 1 181 255 154 1 189 1 184 255 236 1 189 1 187 255 236 1 189 1 190 255 195 1 189 1 201 255 236 1 189 1 206 255 174 1 189 1 207 255 215 1 189 1 213 255 174 1 189 1 216 255 215 1 189 1 219 255 215 1 189 1 222 255 215 1 189 1 225 255 215 1 189 1 234 255 215 1 189 1 235 0 102 1 189 1 237 255 215 1 189 1 238 255 236 1 189 1 242 255 174 1 189 1 244 0 102 1 189 2 8 255 133 1 189 2 12 255 133 1 189 2 106 255 215 1 189 2 108 255 236 1 189 2 114 255 113 1 189 2 115 255 174 1 189 2 126 255 236 1 189 2 127 255 215 1 189 2 132 255 236 1 189 2 133 255 215 1 189 2 134 255 236 1 189 2 135 255 215 1 189 2 136 255 236 1 189 2 137 255 215 1 189 2 138 255 236 1 189 2 140 255 236 1 189 2 141 255 215 1 189 2 152 0 102 1 189 2 168 0 102 1 189 2 177 255 236 1 189 2 178 255 215 1 189 2 179 255 236 1 189 2 180 255 215 1 189 2 192 255 215 1 189 2 194 255 215 1 189 2 197 255 215 1 189 2 198 255 195 1 189 2 199 255 215 1 189 2 200 255 195 1 189 2 206 255 154 1 189 2 207 255 174 1 189 2 213 255 215 1 189 2 217 255 113 1 189 2 219 255 113 1 189 2 221 255 113 1 189 2 224 255 215 1 189 2 239 255 236 1 189 2 240 255 215 1 189 2 241 255 236 1 189 2 242 255 215 1 189 2 243 255 236 1 189 2 244 255 215 1 189 2 254 255 215 1 189 3 9 255 113 1 189 3 10 255 215 1 189 3 11 255 113 1 189 3 12 255 215 1 189 3 17 255 154 1 189 3 18 255 174 1 189 3 21 255 236 1 189 3 22 255 215 1 189 3 26 255 215 1 189 3 27 255 154 1 189 3 28 255 174 1 190 0 15 255 174 1 190 0 17 255 174 1 190 1 157 255 215 1 190 1 164 255 215 1 190 1 166 255 215 1 190 1 168 255 195 1 190 1 170 255 215 1 190 1 174 255 215 1 190 1 176 255 215 1 190 1 177 255 215 1 190 1 181 255 215 1 190 1 188 255 195 1 190 1 189 255 195 1 190 1 191 255 215 1 190 1 196 255 215 1 190 1 199 255 215 1 190 1 206 255 236 1 190 1 213 255 236 1 190 1 242 255 236 1 190 2 8 255 174 1 190 2 12 255 174 1 190 2 114 255 215 1 190 2 115 255 236 1 190 2 122 255 215 1 190 2 128 255 236 1 190 2 130 255 236 1 190 2 159 255 215 1 190 2 161 255 215 1 190 2 169 255 215 1 190 2 181 255 195 1 190 2 183 255 195 1 190 2 185 255 195 1 190 2 187 255 215 1 190 2 189 255 215 1 190 2 202 255 215 1 190 2 206 255 215 1 190 2 207 255 236 1 190 2 217 255 215 1 190 2 219 255 215 1 190 2 221 255 215 1 190 2 229 255 215 1 190 2 231 255 215 1 190 2 245 255 215 1 190 2 247 255 195 1 190 2 249 255 195 1 190 2 251 255 195 1 190 3 5 255 215 1 190 3 7 255 215 1 190 3 13 255 215 1 190 3 15 255 215 1 190 3 17 255 215 1 190 3 18 255 236 1 190 3 23 255 215 1 190 3 27 255 215 1 190 3 28 255 236 1 191 1 159 255 215 1 191 1 184 255 215 1 191 1 187 255 215 1 191 1 190 255 215 1 191 1 193 255 215 1 191 1 225 255 215 1 191 2 108 255 215 1 191 2 124 255 215 1 191 2 126 255 215 1 191 2 132 255 215 1 191 2 134 255 215 1 191 2 136 255 215 1 191 2 138 255 215 1 191 2 140 255 215 1 191 2 177 255 215 1 191 2 179 255 215 1 191 2 191 255 215 1 191 2 192 255 215 1 191 2 193 255 215 1 191 2 194 255 215 1 191 2 197 255 154 1 191 2 199 255 154 1 191 2 212 255 215 1 191 2 213 255 215 1 191 2 239 255 215 1 191 2 241 255 215 1 191 2 243 255 215 1 191 2 253 255 215 1 191 2 254 255 215 1 191 3 9 255 215 1 191 3 11 255 215 1 191 3 14 255 215 1 191 3 16 255 215 1 191 3 21 255 215 1 191 3 25 255 236 1 192 1 163 0 225 1 192 2 234 0 41 1 192 3 14 255 215 1 192 3 16 255 215 1 195 1 163 0 225 1 195 2 234 0 41 1 195 3 14 255 215 1 195 3 16 255 215 1 196 0 5 255 174 1 196 0 10 255 174 1 196 1 157 255 133 1 196 1 166 255 133 1 196 1 168 255 215 1 196 1 188 255 154 1 196 1 189 255 215 1 196 1 193 255 154 1 196 1 196 255 133 1 196 1 220 255 215 1 196 1 221 255 215 1 196 1 225 255 215 1 196 1 228 255 215 1 196 1 246 255 215 1 196 2 7 255 174 1 196 2 11 255 174 1 196 2 110 255 174 1 196 2 124 255 154 1 196 2 128 255 174 1 196 2 130 255 174 1 196 2 151 255 174 1 196 2 155 255 174 1 196 2 167 255 174 1 196 2 169 255 133 1 196 2 170 255 215 1 196 2 181 255 154 1 196 2 182 255 215 1 196 2 183 255 154 1 196 2 184 255 215 1 196 2 185 255 154 1 196 2 186 255 215 1 196 2 189 255 133 1 196 2 190 255 215 1 196 2 191 255 154 1 196 2 192 255 215 1 196 2 193 255 154 1 196 2 194 255 215 1 196 2 212 255 154 1 196 2 213 255 215 1 196 2 247 255 215 1 196 2 248 255 215 1 196 2 249 255 215 1 196 2 250 255 215 1 196 2 251 255 215 1 196 2 252 255 215 1 196 2 253 255 154 1 196 2 254 255 215 1 196 3 3 255 174 1 196 3 13 255 154 1 196 3 14 255 195 1 196 3 15 255 154 1 196 3 16 255 195 1 196 3 23 255 133 1 196 3 24 255 215 1 198 0 5 255 174 1 198 0 10 255 174 1 198 1 157 255 133 1 198 1 166 255 133 1 198 1 168 255 215 1 198 1 188 255 154 1 198 1 189 255 215 1 198 1 193 255 154 1 198 1 196 255 133 1 198 1 220 255 215 1 198 1 221 255 215 1 198 1 225 255 215 1 198 1 228 255 215 1 198 1 246 255 215 1 198 2 7 255 174 1 198 2 11 255 174 1 198 2 110 255 174 1 198 2 124 255 154 1 198 2 128 255 174 1 198 2 130 255 174 1 198 2 151 255 174 1 198 2 155 255 174 1 198 2 167 255 174 1 198 2 169 255 133 1 198 2 170 255 215 1 198 2 181 255 154 1 198 2 182 255 215 1 198 2 183 255 154 1 198 2 184 255 215 1 198 2 185 255 154 1 198 2 186 255 215 1 198 2 189 255 133 1 198 2 190 255 215 1 198 2 191 255 154 1 198 2 192 255 215 1 198 2 193 255 154 1 198 2 194 255 215 1 198 2 212 255 154 1 198 2 213 255 215 1 198 2 247 255 215 1 198 2 248 255 215 1 198 2 249 255 215 1 198 2 250 255 215 1 198 2 251 255 215 1 198 2 252 255 215 1 198 2 253 255 154 1 198 2 254 255 215 1 198 3 3 255 174 1 198 3 13 255 154 1 198 3 14 255 195 1 198 3 15 255 154 1 198 3 16 255 195 1 198 3 23 255 133 1 198 3 24 255 215 1 199 0 15 255 174 1 199 0 17 255 174 1 199 1 157 255 236 1 199 1 164 255 215 1 199 1 166 255 236 1 199 1 168 255 215 1 199 1 170 255 215 1 199 1 174 255 215 1 199 1 176 255 215 1 199 1 177 255 236 1 199 1 181 255 215 1 199 1 188 255 195 1 199 1 189 255 215 1 199 1 191 255 215 1 199 1 193 255 215 1 199 1 196 255 236 1 199 1 199 255 236 1 199 1 206 255 236 1 199 1 213 255 236 1 199 1 242 255 236 1 199 2 8 255 174 1 199 2 12 255 174 1 199 2 114 255 215 1 199 2 115 255 236 1 199 2 122 255 236 1 199 2 124 255 215 1 199 2 128 255 236 1 199 2 130 255 236 1 199 2 159 255 215 1 199 2 161 255 236 1 199 2 169 255 236 1 199 2 181 255 195 1 199 2 183 255 236 1 199 2 185 255 236 1 199 2 187 255 215 1 199 2 189 255 236 1 199 2 191 255 215 1 199 2 193 255 215 1 199 2 202 255 215 1 199 2 206 255 215 1 199 2 207 255 236 1 199 2 212 255 215 1 199 2 217 255 215 1 199 2 219 255 215 1 199 2 221 255 215 1 199 2 229 255 215 1 199 2 231 255 236 1 199 2 245 255 236 1 199 2 247 255 215 1 199 2 249 255 215 1 199 2 251 255 215 1 199 2 253 255 215 1 199 3 5 255 215 1 199 3 7 255 215 1 199 3 13 255 215 1 199 3 15 255 215 1 199 3 17 255 215 1 199 3 18 255 236 1 199 3 23 255 236 1 199 3 27 255 215 1 199 3 28 255 236 1 200 0 15 255 174 1 200 0 17 255 174 1 200 1 157 255 236 1 200 1 164 255 215 1 200 1 166 255 236 1 200 1 168 255 215 1 200 1 170 255 215 1 200 1 174 255 215 1 200 1 176 255 215 1 200 1 177 255 236 1 200 1 181 255 215 1 200 1 188 255 195 1 200 1 189 255 215 1 200 1 191 255 215 1 200 1 193 255 215 1 200 1 196 255 236 1 200 1 199 255 236 1 200 1 206 255 236 1 200 1 213 255 236 1 200 1 242 255 236 1 200 2 8 255 174 1 200 2 12 255 174 1 200 2 114 255 215 1 200 2 115 255 236 1 200 2 122 255 236 1 200 2 124 255 215 1 200 2 128 255 236 1 200 2 130 255 236 1 200 2 159 255 215 1 200 2 161 255 236 1 200 2 169 255 236 1 200 2 181 255 195 1 200 2 183 255 236 1 200 2 185 255 236 1 200 2 187 255 215 1 200 2 189 255 236 1 200 2 191 255 215 1 200 2 193 255 215 1 200 2 202 255 215 1 200 2 206 255 215 1 200 2 207 255 236 1 200 2 212 255 215 1 200 2 217 255 215 1 200 2 219 255 215 1 200 2 221 255 215 1 200 2 229 255 215 1 200 2 231 255 236 1 200 2 245 255 236 1 200 2 247 255 215 1 200 2 249 255 215 1 200 2 251 255 215 1 200 2 253 255 215 1 200 3 5 255 215 1 200 3 7 255 215 1 200 3 13 255 215 1 200 3 15 255 215 1 200 3 17 255 215 1 200 3 18 255 236 1 200 3 23 255 236 1 200 3 27 255 215 1 200 3 28 255 236 1 202 0 5 255 236 1 202 0 10 255 236 1 202 2 7 255 236 1 202 2 11 255 236 1 204 1 233 0 41 1 205 0 15 255 154 1 205 0 16 255 215 1 205 0 17 255 154 1 205 1 206 255 195 1 205 1 207 255 236 1 205 1 213 255 195 1 205 1 216 255 236 1 205 1 219 255 236 1 205 1 222 255 236 1 205 1 234 255 236 1 205 1 237 255 236 1 205 1 242 255 195 1 205 2 2 255 215 1 205 2 3 255 215 1 205 2 4 255 215 1 205 2 8 255 154 1 205 2 12 255 154 1 205 2 106 255 236 1 205 2 115 255 195 1 205 2 127 255 236 1 205 2 133 255 236 1 205 2 135 255 236 1 205 2 137 255 236 1 205 2 141 255 236 1 205 2 178 255 236 1 205 2 180 255 236 1 205 2 207 255 195 1 205 2 224 255 236 1 205 2 240 255 236 1 205 2 242 255 236 1 205 2 244 255 236 1 205 3 10 255 236 1 205 3 12 255 236 1 205 3 18 255 195 1 205 3 22 255 236 1 205 3 26 255 236 1 205 3 28 255 195 1 206 0 5 255 236 1 206 0 10 255 236 1 206 2 7 255 236 1 206 2 11 255 236 1 207 0 5 255 236 1 207 0 10 255 236 1 207 2 7 255 236 1 207 2 11 255 236 1 208 1 207 255 215 1 208 1 216 255 215 1 208 1 219 255 215 1 208 1 222 255 215 1 208 1 225 255 215 1 208 1 234 255 215 1 208 1 237 255 215 1 208 2 106 255 215 1 208 2 127 255 215 1 208 2 133 255 215 1 208 2 135 255 215 1 208 2 137 255 215 1 208 2 141 255 215 1 208 2 178 255 215 1 208 2 180 255 215 1 208 2 192 255 215 1 208 2 194 255 215 1 208 2 198 255 215 1 208 2 200 255 215 1 208 2 213 255 215 1 208 2 224 255 215 1 208 2 240 255 215 1 208 2 242 255 215 1 208 2 244 255 215 1 208 2 254 255 215 1 208 3 10 255 215 1 208 3 12 255 215 1 208 3 22 255 215 1 208 3 26 255 215 1 209 1 233 0 41 1 212 1 207 255 215 1 212 1 216 255 215 1 212 1 219 255 215 1 212 1 222 255 215 1 212 1 225 255 215 1 212 1 234 255 215 1 212 1 237 255 215 1 212 2 106 255 215 1 212 2 127 255 215 1 212 2 133 255 215 1 212 2 135 255 215 1 212 2 137 255 215 1 212 2 141 255 215 1 212 2 178 255 215 1 212 2 180 255 215 1 212 2 192 255 215 1 212 2 194 255 215 1 212 2 198 255 215 1 212 2 200 255 215 1 212 2 213 255 215 1 212 2 224 255 215 1 212 2 240 255 215 1 212 2 242 255 215 1 212 2 244 255 215 1 212 2 254 255 215 1 212 3 10 255 215 1 212 3 12 255 215 1 212 3 22 255 215 1 212 3 26 255 215 1 216 0 5 255 236 1 216 0 10 255 236 1 216 1 208 255 215 1 216 1 220 255 236 1 216 1 221 255 236 1 216 1 223 255 215 1 216 1 225 255 236 1 216 1 228 255 236 1 216 1 246 255 236 1 216 2 7 255 236 1 216 2 11 255 236 1 216 2 160 255 215 1 216 2 170 255 236 1 216 2 182 255 236 1 216 2 188 255 215 1 216 2 190 255 236 1 216 2 192 255 236 1 216 2 194 255 236 1 216 2 203 255 215 1 216 2 213 255 236 1 216 2 230 255 215 1 216 2 248 255 236 1 216 2 250 255 236 1 216 2 252 255 236 1 216 2 254 255 236 1 216 3 6 255 215 1 216 3 8 255 215 1 216 3 14 255 236 1 216 3 16 255 236 1 216 3 24 255 236 1 218 0 5 255 236 1 218 0 10 255 236 1 218 1 208 255 215 1 218 1 220 255 236 1 218 1 221 255 236 1 218 1 223 255 215 1 218 1 225 255 236 1 218 1 228 255 236 1 218 1 246 255 236 1 218 2 7 255 236 1 218 2 11 255 236 1 218 2 160 255 215 1 218 2 170 255 236 1 218 2 182 255 236 1 218 2 188 255 215 1 218 2 190 255 236 1 218 2 192 255 236 1 218 2 194 255 236 1 218 2 203 255 215 1 218 2 213 255 236 1 218 2 230 255 215 1 218 2 248 255 236 1 218 2 250 255 236 1 218 2 252 255 236 1 218 2 254 255 236 1 218 3 6 255 215 1 218 3 8 255 215 1 218 3 14 255 236 1 218 3 16 255 236 1 218 3 24 255 236 1 220 0 15 255 154 1 220 0 16 255 215 1 220 0 17 255 154 1 220 1 206 255 195 1 220 1 207 255 236 1 220 1 213 255 195 1 220 1 216 255 236 1 220 1 219 255 236 1 220 1 222 255 236 1 220 1 234 255 236 1 220 1 237 255 236 1 220 1 242 255 195 1 220 2 2 255 215 1 220 2 3 255 215 1 220 2 4 255 215 1 220 2 8 255 154 1 220 2 12 255 154 1 220 2 106 255 236 1 220 2 115 255 195 1 220 2 127 255 236 1 220 2 133 255 236 1 220 2 135 255 236 1 220 2 137 255 236 1 220 2 141 255 236 1 220 2 178 255 236 1 220 2 180 255 236 1 220 2 207 255 195 1 220 2 224 255 236 1 220 2 240 255 236 1 220 2 242 255 236 1 220 2 244 255 236 1 220 3 10 255 236 1 220 3 12 255 236 1 220 3 18 255 195 1 220 3 22 255 236 1 220 3 26 255 236 1 220 3 28 255 195 1 221 0 15 255 174 1 221 0 17 255 174 1 221 1 206 255 215 1 221 1 213 255 215 1 221 1 242 255 215 1 221 2 8 255 174 1 221 2 12 255 174 1 221 2 115 255 215 1 221 2 207 255 215 1 221 3 18 255 215 1 221 3 28 255 215 1 222 0 5 255 236 1 222 0 10 255 236 1 222 1 208 255 215 1 222 1 220 255 236 1 222 1 221 255 236 1 222 1 223 255 215 1 222 1 225 255 236 1 222 1 228 255 236 1 222 1 246 255 236 1 222 2 7 255 236 1 222 2 11 255 236 1 222 2 160 255 215 1 222 2 170 255 236 1 222 2 182 255 236 1 222 2 188 255 215 1 222 2 190 255 236 1 222 2 192 255 236 1 222 2 194 255 236 1 222 2 203 255 215 1 222 2 213 255 236 1 222 2 230 255 215 1 222 2 248 255 236 1 222 2 250 255 236 1 222 2 252 255 236 1 222 2 254 255 236 1 222 3 6 255 215 1 222 3 8 255 215 1 222 3 14 255 236 1 222 3 16 255 236 1 222 3 24 255 236 1 223 1 207 255 215 1 223 1 216 255 215 1 223 1 219 255 215 1 223 1 222 255 215 1 223 1 225 255 215 1 223 1 234 255 215 1 223 1 237 255 215 1 223 2 106 255 215 1 223 2 127 255 215 1 223 2 133 255 215 1 223 2 135 255 215 1 223 2 137 255 215 1 223 2 141 255 215 1 223 2 178 255 215 1 223 2 180 255 215 1 223 2 192 255 215 1 223 2 194 255 215 1 223 2 198 255 215 1 223 2 200 255 215 1 223 2 213 255 215 1 223 2 224 255 215 1 223 2 240 255 215 1 223 2 242 255 215 1 223 2 244 255 215 1 223 2 254 255 215 1 223 3 10 255 215 1 223 3 12 255 215 1 223 3 22 255 215 1 223 3 26 255 215 1 224 0 5 255 236 1 224 0 10 255 236 1 224 2 7 255 236 1 224 2 11 255 236 1 227 0 5 255 236 1 227 0 10 255 236 1 227 2 7 255 236 1 227 2 11 255 236 1 228 0 5 255 133 1 228 0 10 255 133 1 228 1 208 255 215 1 228 1 220 255 154 1 228 1 221 255 195 1 228 1 223 255 215 1 228 1 225 255 174 1 228 1 228 255 154 1 228 1 246 255 195 1 228 2 7 255 133 1 228 2 11 255 133 1 228 2 109 255 215 1 228 2 129 255 215 1 228 2 131 255 215 1 228 2 139 255 215 1 228 2 160 255 215 1 228 2 170 255 154 1 228 2 182 255 154 1 228 2 184 255 195 1 228 2 186 255 195 1 228 2 188 255 215 1 228 2 190 255 154 1 228 2 192 255 174 1 228 2 194 255 174 1 228 2 198 255 215 1 228 2 200 255 215 1 228 2 203 255 215 1 228 2 213 255 174 1 228 2 230 255 215 1 228 2 234 255 215 1 228 2 248 255 195 1 228 2 250 255 195 1 228 2 252 255 195 1 228 2 254 255 174 1 228 3 6 255 215 1 228 3 8 255 215 1 228 3 14 255 154 1 228 3 16 255 154 1 228 3 24 255 154 1 230 0 5 255 133 1 230 0 10 255 133 1 230 1 208 255 215 1 230 1 220 255 154 1 230 1 221 255 195 1 230 1 223 255 215 1 230 1 225 255 174 1 230 1 228 255 154 1 230 1 246 255 195 1 230 2 7 255 133 1 230 2 11 255 133 1 230 2 109 255 215 1 230 2 129 255 215 1 230 2 131 255 215 1 230 2 139 255 215 1 230 2 160 255 215 1 230 2 170 255 154 1 230 2 182 255 154 1 230 2 184 255 195 1 230 2 186 255 195 1 230 2 188 255 215 1 230 2 190 255 154 1 230 2 192 255 174 1 230 2 194 255 174 1 230 2 198 255 215 1 230 2 200 255 215 1 230 2 203 255 215 1 230 2 213 255 174 1 230 2 230 255 215 1 230 2 234 255 215 1 230 2 248 255 195 1 230 2 250 255 195 1 230 2 252 255 195 1 230 2 254 255 174 1 230 3 6 255 215 1 230 3 8 255 215 1 230 3 14 255 154 1 230 3 16 255 154 1 230 3 24 255 154 1 231 0 5 255 236 1 231 0 10 255 236 1 231 1 208 255 215 1 231 1 220 255 236 1 231 1 221 255 236 1 231 1 223 255 215 1 231 1 225 255 236 1 231 1 228 255 236 1 231 1 246 255 236 1 231 2 7 255 236 1 231 2 11 255 236 1 231 2 160 255 215 1 231 2 170 255 236 1 231 2 182 255 236 1 231 2 188 255 215 1 231 2 190 255 236 1 231 2 192 255 236 1 231 2 194 255 236 1 231 2 203 255 215 1 231 2 213 255 236 1 231 2 230 255 215 1 231 2 248 255 236 1 231 2 250 255 236 1 231 2 252 255 236 1 231 2 254 255 236 1 231 3 6 255 215 1 231 3 8 255 215 1 231 3 14 255 236 1 231 3 16 255 236 1 231 3 24 255 236 1 232 0 5 255 236 1 232 0 10 255 236 1 232 1 208 255 215 1 232 1 220 255 236 1 232 1 221 255 236 1 232 1 223 255 215 1 232 1 225 255 236 1 232 1 228 255 236 1 232 1 246 255 236 1 232 2 7 255 236 1 232 2 11 255 236 1 232 2 160 255 215 1 232 2 170 255 236 1 232 2 182 255 236 1 232 2 188 255 215 1 232 2 190 255 236 1 232 2 192 255 236 1 232 2 194 255 236 1 232 2 203 255 215 1 232 2 213 255 236 1 232 2 230 255 215 1 232 2 248 255 236 1 232 2 250 255 236 1 232 2 252 255 236 1 232 2 254 255 236 1 232 3 6 255 215 1 232 3 8 255 215 1 232 3 14 255 236 1 232 3 16 255 236 1 232 3 24 255 236 1 234 0 5 255 236 1 234 0 10 255 236 1 234 2 7 255 236 1 234 2 11 255 236 1 235 0 5 255 236 1 235 0 10 255 236 1 235 2 7 255 236 1 235 2 11 255 236 1 235 3 14 255 215 1 235 3 16 255 215 1 236 0 15 255 154 1 236 0 16 255 215 1 236 0 17 255 154 1 236 1 206 255 195 1 236 1 207 255 236 1 236 1 213 255 195 1 236 1 216 255 236 1 236 1 219 255 236 1 236 1 222 255 236 1 236 1 234 255 236 1 236 1 237 255 236 1 236 1 242 255 195 1 236 2 2 255 215 1 236 2 3 255 215 1 236 2 4 255 215 1 236 2 8 255 154 1 236 2 12 255 154 1 236 2 106 255 236 1 236 2 115 255 195 1 236 2 127 255 236 1 236 2 133 255 236 1 236 2 135 255 236 1 236 2 137 255 236 1 236 2 141 255 236 1 236 2 178 255 236 1 236 2 180 255 236 1 236 2 207 255 195 1 236 2 224 255 236 1 236 2 240 255 236 1 236 2 242 255 236 1 236 2 244 255 236 1 236 3 10 255 236 1 236 3 12 255 236 1 236 3 18 255 195 1 236 3 22 255 236 1 236 3 26 255 236 1 236 3 28 255 195 1 242 0 5 255 133 1 242 0 10 255 133 1 242 1 208 255 215 1 242 1 220 255 154 1 242 1 221 255 195 1 242 1 223 255 215 1 242 1 225 255 174 1 242 1 228 255 154 1 242 1 246 255 195 1 242 2 7 255 133 1 242 2 11 255 133 1 242 2 109 255 215 1 242 2 129 255 215 1 242 2 131 255 215 1 242 2 139 255 215 1 242 2 160 255 215 1 242 2 170 255 154 1 242 2 182 255 154 1 242 2 184 255 195 1 242 2 186 255 195 1 242 2 188 255 215 1 242 2 190 255 154 1 242 2 192 255 174 1 242 2 194 255 174 1 242 2 198 255 215 1 242 2 200 255 215 1 242 2 203 255 215 1 242 2 213 255 174 1 242 2 230 255 215 1 242 2 234 255 215 1 242 2 248 255 195 1 242 2 250 255 195 1 242 2 252 255 195 1 242 2 254 255 174 1 242 3 6 255 215 1 242 3 8 255 215 1 242 3 14 255 154 1 242 3 16 255 154 1 242 3 24 255 154 1 243 0 5 255 133 1 243 0 10 255 133 1 243 1 208 255 215 1 243 1 220 255 154 1 243 1 221 255 195 1 243 1 223 255 215 1 243 1 225 255 174 1 243 1 228 255 154 1 243 1 246 255 195 1 243 2 7 255 133 1 243 2 11 255 133 1 243 2 109 255 215 1 243 2 129 255 215 1 243 2 131 255 215 1 243 2 139 255 215 1 243 2 160 255 215 1 243 2 170 255 154 1 243 2 182 255 154 1 243 2 184 255 195 1 243 2 186 255 195 1 243 2 188 255 215 1 243 2 190 255 154 1 243 2 192 255 174 1 243 2 194 255 174 1 243 2 198 255 215 1 243 2 200 255 215 1 243 2 203 255 215 1 243 2 213 255 174 1 243 2 230 255 215 1 243 2 234 255 215 1 243 2 248 255 195 1 243 2 250 255 195 1 243 2 252 255 195 1 243 2 254 255 174 1 243 3 6 255 215 1 243 3 8 255 215 1 243 3 14 255 154 1 243 3 16 255 154 1 243 3 24 255 154 1 244 0 5 255 236 1 244 0 10 255 236 1 244 2 7 255 236 1 244 2 11 255 236 1 244 3 14 255 215 1 244 3 16 255 215 1 245 1 207 255 215 1 245 1 216 255 215 1 245 1 219 255 215 1 245 1 222 255 215 1 245 1 225 255 215 1 245 1 234 255 215 1 245 1 237 255 215 1 245 2 106 255 215 1 245 2 127 255 215 1 245 2 133 255 215 1 245 2 135 255 215 1 245 2 137 255 215 1 245 2 141 255 215 1 245 2 178 255 215 1 245 2 180 255 215 1 245 2 192 255 215 1 245 2 194 255 215 1 245 2 198 255 215 1 245 2 200 255 215 1 245 2 213 255 215 1 245 2 224 255 215 1 245 2 240 255 215 1 245 2 242 255 215 1 245 2 244 255 215 1 245 2 254 255 215 1 245 3 10 255 215 1 245 3 12 255 215 1 245 3 22 255 215 1 245 3 26 255 215 1 246 0 15 255 174 1 246 0 17 255 174 1 246 1 206 255 215 1 246 1 213 255 215 1 246 1 242 255 215 1 246 2 8 255 174 1 246 2 12 255 174 1 246 2 115 255 215 1 246 2 207 255 215 1 246 3 18 255 215 1 246 3 28 255 215 1 248 0 15 255 133 1 248 0 16 255 174 1 248 0 17 255 133 1 248 1 159 255 215 1 248 1 164 255 154 1 248 1 170 255 113 1 248 1 174 255 154 1 248 1 181 255 154 1 248 1 184 255 215 1 248 1 187 255 215 1 248 1 188 0 41 1 248 1 190 255 174 1 248 1 204 255 154 1 248 1 205 255 154 1 248 1 206 255 133 1 248 1 207 255 113 1 248 1 208 255 215 1 248 1 209 255 215 1 248 1 210 255 154 1 248 1 211 255 154 1 248 1 212 255 154 1 248 1 213 255 133 1 248 1 214 255 154 1 248 1 215 255 154 1 248 1 216 255 113 1 248 1 217 255 154 1 248 1 218 255 154 1 248 1 219 255 113 1 248 1 220 255 174 1 248 1 221 255 174 1 248 1 222 255 113 1 248 1 223 255 215 1 248 1 224 255 154 1 248 1 225 255 154 1 248 1 226 255 154 1 248 1 227 255 154 1 248 1 228 255 174 1 248 1 229 255 154 1 248 1 230 255 154 1 248 1 231 255 215 1 248 1 232 255 154 1 248 1 233 255 195 1 248 1 234 255 113 1 248 1 236 255 154 1 248 1 237 255 113 1 248 1 238 255 133 1 248 1 242 255 133 1 248 1 243 255 154 1 248 1 245 255 154 1 248 1 246 255 174 1 248 1 247 255 154 1 248 1 249 255 154 1 248 2 2 255 174 1 248 2 3 255 174 1 248 2 4 255 174 1 248 2 8 255 133 1 248 2 12 255 133 1 248 2 106 255 113 1 248 2 107 255 154 1 248 2 108 255 215 1 248 2 109 255 215 1 248 2 113 255 154 1 248 2 114 255 113 1 248 2 115 255 133 1 248 2 117 255 154 1 248 2 119 255 154 1 248 2 121 255 154 1 248 2 125 255 154 1 248 2 126 255 215 1 248 2 127 255 113 1 248 2 129 255 215 1 248 2 131 255 215 1 248 2 132 255 215 1 248 2 133 255 113 1 248 2 134 255 215 1 248 2 135 255 113 1 248 2 136 255 215 1 248 2 137 255 113 1 248 2 138 255 215 1 248 2 139 255 215 1 248 2 140 255 215 1 248 2 141 255 113 1 248 2 150 255 154 1 248 2 154 255 154 1 248 2 158 255 154 1 248 2 160 255 215 1 248 2 162 255 215 1 248 2 164 255 154 1 248 2 166 255 154 1 248 2 170 255 174 1 248 2 172 255 154 1 248 2 174 255 154 1 248 2 176 255 154 1 248 2 177 255 215 1 248 2 178 255 113 1 248 2 179 255 215 1 248 2 180 255 113 1 248 2 181 0 41 1 248 2 182 255 174 1 248 2 184 255 174 1 248 2 186 255 174 1 248 2 188 255 215 1 248 2 190 255 174 1 248 2 192 255 154 1 248 2 194 255 154 1 248 2 196 255 154 1 248 2 197 255 154 1 248 2 198 255 113 1 248 2 199 255 154 1 248 2 200 255 113 1 248 2 203 255 215 1 248 2 205 255 154 1 248 2 206 255 154 1 248 2 207 255 133 1 248 2 209 255 154 1 248 2 211 255 154 1 248 2 213 255 154 1 248 2 215 255 154 1 248 2 217 255 113 1 248 2 219 255 113 1 248 2 221 255 113 1 248 2 224 255 113 1 248 2 230 255 215 1 248 2 232 255 215 1 248 2 234 255 195 1 248 2 236 255 154 1 248 2 238 255 154 1 248 2 239 255 215 1 248 2 240 255 113 1 248 2 241 255 215 1 248 2 242 255 113 1 248 2 243 255 215 1 248 2 244 255 113 1 248 2 246 255 215 1 248 2 248 255 174 1 248 2 250 255 174 1 248 2 252 255 174 1 248 2 254 255 154 1 248 3 0 255 154 1 248 3 2 255 154 1 248 3 6 255 215 1 248 3 8 255 215 1 248 3 9 255 113 1 248 3 10 255 113 1 248 3 11 255 113 1 248 3 12 255 113 1 248 3 14 255 154 1 248 3 16 255 154 1 248 3 17 255 154 1 248 3 18 255 133 1 248 3 20 255 154 1 248 3 21 255 215 1 248 3 22 255 113 1 248 3 24 255 174 1 248 3 26 255 113 1 248 3 27 255 154 1 248 3 28 255 133 1 249 0 15 255 154 1 249 0 16 255 215 1 249 0 17 255 154 1 249 1 206 255 195 1 249 1 207 255 236 1 249 1 213 255 195 1 249 1 216 255 236 1 249 1 219 255 236 1 249 1 222 255 236 1 249 1 234 255 236 1 249 1 237 255 236 1 249 1 242 255 195 1 249 2 2 255 215 1 249 2 3 255 215 1 249 2 4 255 215 1 249 2 8 255 154 1 249 2 12 255 154 1 249 2 106 255 236 1 249 2 115 255 195 1 249 2 127 255 236 1 249 2 133 255 236 1 249 2 135 255 236 1 249 2 137 255 236 1 249 2 141 255 236 1 249 2 178 255 236 1 249 2 180 255 236 1 249 2 207 255 195 1 249 2 224 255 236 1 249 2 240 255 236 1 249 2 242 255 236 1 249 2 244 255 236 1 249 3 10 255 236 1 249 3 12 255 236 1 249 3 18 255 195 1 249 3 22 255 236 1 249 3 26 255 236 1 249 3 28 255 195 1 250 0 15 255 154 1 250 0 17 255 154 1 250 0 34 0 41 1 250 0 36 255 174 1 250 0 38 255 236 1 250 0 42 255 236 1 250 0 50 255 236 1 250 0 52 255 236 1 250 0 68 255 215 1 250 0 70 255 215 1 250 0 71 255 215 1 250 0 72 255 215 1 250 0 74 255 236 1 250 0 80 255 236 1 250 0 81 255 236 1 250 0 82 255 215 1 250 0 83 255 236 1 250 0 84 255 215 1 250 0 85 255 236 1 250 0 86 255 236 1 250 0 88 255 236 1 250 0 130 255 174 1 250 0 131 255 174 1 250 0 132 255 174 1 250 0 133 255 174 1 250 0 134 255 174 1 250 0 135 255 174 1 250 0 137 255 236 1 250 0 148 255 236 1 250 0 149 255 236 1 250 0 150 255 236 1 250 0 151 255 236 1 250 0 152 255 236 1 250 0 154 255 236 1 250 0 162 255 215 1 250 0 163 255 215 1 250 0 164 255 215 1 250 0 165 255 215 1 250 0 166 255 215 1 250 0 167 255 215 1 250 0 168 255 215 1 250 0 169 255 215 1 250 0 170 255 215 1 250 0 171 255 215 1 250 0 172 255 215 1 250 0 173 255 215 1 250 0 180 255 215 1 250 0 181 255 215 1 250 0 182 255 215 1 250 0 183 255 215 1 250 0 184 255 215 1 250 0 186 255 215 1 250 0 187 255 236 1 250 0 188 255 236 1 250 0 189 255 236 1 250 0 190 255 236 1 250 0 194 255 174 1 250 0 195 255 215 1 250 0 196 255 174 1 250 0 197 255 215 1 250 0 198 255 174 1 250 0 199 255 215 1 250 0 200 255 236 1 250 0 201 255 215 1 250 0 202 255 236 1 250 0 203 255 215 1 250 0 204 255 236 1 250 0 205 255 215 1 250 0 206 255 236 1 250 0 207 255 215 1 250 0 209 255 215 1 250 0 211 255 215 1 250 0 213 255 215 1 250 0 215 255 215 1 250 0 217 255 215 1 250 0 219 255 215 1 250 0 221 255 215 1 250 0 222 255 236 1 250 0 223 255 236 1 250 0 224 255 236 1 250 0 225 255 236 1 250 0 226 255 236 1 250 0 227 255 236 1 250 0 228 255 236 1 250 0 229 255 236 1 250 0 250 255 236 1 250 1 6 255 236 1 250 1 8 255 236 1 250 1 13 255 236 1 250 1 14 255 236 1 250 1 15 255 215 1 250 1 16 255 236 1 250 1 17 255 215 1 250 1 18 255 236 1 250 1 19 255 215 1 250 1 20 255 236 1 250 1 21 255 215 1 250 1 23 255 236 1 250 1 25 255 236 1 250 1 29 255 236 1 250 1 33 255 236 1 250 1 43 255 236 1 250 1 45 255 236 1 250 1 47 255 236 1 250 1 49 255 236 1 250 1 51 255 236 1 250 1 53 255 236 1 250 1 67 255 174 1 250 1 68 255 215 1 250 1 70 255 215 1 250 1 71 255 236 1 250 1 72 255 215 1 250 1 74 255 236 1 250 2 8 255 154 1 250 2 12 255 154 1 250 2 87 255 236 1 250 2 88 255 174 1 250 2 89 255 215 1 250 2 95 255 236 1 250 2 96 255 215 1 250 2 98 255 236 1 250 3 29 255 174 1 250 3 30 255 215 1 250 3 31 255 174 1 250 3 32 255 215 1 250 3 33 255 174 1 250 3 34 255 215 1 250 3 35 255 174 1 250 3 37 255 174 1 250 3 38 255 215 1 250 3 39 255 174 1 250 3 40 255 215 1 250 3 41 255 174 1 250 3 42 255 215 1 250 3 43 255 174 1 250 3 44 255 215 1 250 3 45 255 174 1 250 3 46 255 215 1 250 3 47 255 174 1 250 3 48 255 215 1 250 3 49 255 174 1 250 3 50 255 215 1 250 3 51 255 174 1 250 3 52 255 215 1 250 3 54 255 215 1 250 3 56 255 215 1 250 3 58 255 215 1 250 3 60 255 215 1 250 3 64 255 215 1 250 3 66 255 215 1 250 3 68 255 215 1 250 3 73 255 236 1 250 3 74 255 215 1 250 3 75 255 236 1 250 3 76 255 215 1 250 3 77 255 236 1 250 3 78 255 215 1 250 3 79 255 236 1 250 3 81 255 236 1 250 3 82 255 215 1 250 3 83 255 236 1 250 3 84 255 215 1 250 3 85 255 236 1 250 3 86 255 215 1 250 3 87 255 236 1 250 3 88 255 215 1 250 3 89 255 236 1 250 3 90 255 215 1 250 3 91 255 236 1 250 3 92 255 215 1 250 3 93 255 236 1 250 3 94 255 215 1 250 3 95 255 236 1 250 3 96 255 215 1 250 3 98 255 236 1 250 3 100 255 236 1 250 3 102 255 236 1 250 3 104 255 236 1 250 3 106 255 236 1 250 3 108 255 236 1 250 3 110 255 236 1 251 0 5 0 82 1 251 0 10 0 82 1 251 0 15 255 174 1 251 0 17 255 174 1 251 0 34 0 41 1 251 2 7 0 82 1 251 2 8 255 174 1 251 2 11 0 82 1 251 2 12 255 174 1 252 0 15 255 154 1 252 0 17 255 154 1 252 0 34 0 41 1 252 0 36 255 174 1 252 0 38 255 236 1 252 0 42 255 236 1 252 0 50 255 236 1 252 0 52 255 236 1 252 0 68 255 215 1 252 0 70 255 215 1 252 0 71 255 215 1 252 0 72 255 215 1 252 0 74 255 236 1 252 0 80 255 236 1 252 0 81 255 236 1 252 0 82 255 215 1 252 0 83 255 236 1 252 0 84 255 215 1 252 0 85 255 236 1 252 0 86 255 236 1 252 0 88 255 236 1 252 0 130 255 174 1 252 0 131 255 174 1 252 0 132 255 174 1 252 0 133 255 174 1 252 0 134 255 174 1 252 0 135 255 174 1 252 0 137 255 236 1 252 0 148 255 236 1 252 0 149 255 236 1 252 0 150 255 236 1 252 0 151 255 236 1 252 0 152 255 236 1 252 0 154 255 236 1 252 0 162 255 215 1 252 0 163 255 215 1 252 0 164 255 215 1 252 0 165 255 215 1 252 0 166 255 215 1 252 0 167 255 215 1 252 0 168 255 215 1 252 0 169 255 215 1 252 0 170 255 215 1 252 0 171 255 215 1 252 0 172 255 215 1 252 0 173 255 215 1 252 0 180 255 215 1 252 0 181 255 215 1 252 0 182 255 215 1 252 0 183 255 215 1 252 0 184 255 215 1 252 0 186 255 215 1 252 0 187 255 236 1 252 0 188 255 236 1 252 0 189 255 236 1 252 0 190 255 236 1 252 0 194 255 174 1 252 0 195 255 215 1 252 0 196 255 174 1 252 0 197 255 215 1 252 0 198 255 174 1 252 0 199 255 215 1 252 0 200 255 236 1 252 0 201 255 215 1 252 0 202 255 236 1 252 0 203 255 215 1 252 0 204 255 236 1 252 0 205 255 215 1 252 0 206 255 236 1 252 0 207 255 215 1 252 0 209 255 215 1 252 0 211 255 215 1 252 0 213 255 215 1 252 0 215 255 215 1 252 0 217 255 215 1 252 0 219 255 215 1 252 0 221 255 215 1 252 0 222 255 236 1 252 0 223 255 236 1 252 0 224 255 236 1 252 0 225 255 236 1 252 0 226 255 236 1 252 0 227 255 236 1 252 0 228 255 236 1 252 0 229 255 236 1 252 0 250 255 236 1 252 1 6 255 236 1 252 1 8 255 236 1 252 1 13 255 236 1 252 1 14 255 236 1 252 1 15 255 215 1 252 1 16 255 236 1 252 1 17 255 215 1 252 1 18 255 236 1 252 1 19 255 215 1 252 1 20 255 236 1 252 1 21 255 215 1 252 1 23 255 236 1 252 1 25 255 236 1 252 1 29 255 236 1 252 1 33 255 236 1 252 1 43 255 236 1 252 1 45 255 236 1 252 1 47 255 236 1 252 1 49 255 236 1 252 1 51 255 236 1 252 1 53 255 236 1 252 1 67 255 174 1 252 1 68 255 215 1 252 1 70 255 215 1 252 1 71 255 236 1 252 1 72 255 215 1 252 1 74 255 236 1 252 2 8 255 154 1 252 2 12 255 154 1 252 2 87 255 236 1 252 2 88 255 174 1 252 2 89 255 215 1 252 2 95 255 236 1 252 2 96 255 215 1 252 2 98 255 236 1 252 3 29 255 174 1 252 3 30 255 215 1 252 3 31 255 174 1 252 3 32 255 215 1 252 3 33 255 174 1 252 3 34 255 215 1 252 3 35 255 174 1 252 3 37 255 174 1 252 3 38 255 215 1 252 3 39 255 174 1 252 3 40 255 215 1 252 3 41 255 174 1 252 3 42 255 215 1 252 3 43 255 174 1 252 3 44 255 215 1 252 3 45 255 174 1 252 3 46 255 215 1 252 3 47 255 174 1 252 3 48 255 215 1 252 3 49 255 174 1 252 3 50 255 215 1 252 3 51 255 174 1 252 3 52 255 215 1 252 3 54 255 215 1 252 3 56 255 215 1 252 3 58 255 215 1 252 3 60 255 215 1 252 3 64 255 215 1 252 3 66 255 215 1 252 3 68 255 215 1 252 3 73 255 236 1 252 3 74 255 215 1 252 3 75 255 236 1 252 3 76 255 215 1 252 3 77 255 236 1 252 3 78 255 215 1 252 3 79 255 236 1 252 3 81 255 236 1 252 3 82 255 215 1 252 3 83 255 236 1 252 3 84 255 215 1 252 3 85 255 236 1 252 3 86 255 215 1 252 3 87 255 236 1 252 3 88 255 215 1 252 3 89 255 236 1 252 3 90 255 215 1 252 3 91 255 236 1 252 3 92 255 215 1 252 3 93 255 236 1 252 3 94 255 215 1 252 3 95 255 236 1 252 3 96 255 215 1 252 3 98 255 236 1 252 3 100 255 236 1 252 3 102 255 236 1 252 3 104 255 236 1 252 3 106 255 236 1 252 3 108 255 236 1 252 3 110 255 236 1 253 0 5 0 82 1 253 0 10 0 82 1 253 0 15 255 174 1 253 0 17 255 174 1 253 0 34 0 41 1 253 2 7 0 82 1 253 2 8 255 174 1 253 2 11 0 82 1 253 2 12 255 174 1 254 0 15 255 154 1 254 0 17 255 154 1 254 0 34 0 41 1 254 0 36 255 174 1 254 0 38 255 236 1 254 0 42 255 236 1 254 0 50 255 236 1 254 0 52 255 236 1 254 0 68 255 215 1 254 0 70 255 215 1 254 0 71 255 215 1 254 0 72 255 215 1 254 0 74 255 236 1 254 0 80 255 236 1 254 0 81 255 236 1 254 0 82 255 215 1 254 0 83 255 236 1 254 0 84 255 215 1 254 0 85 255 236 1 254 0 86 255 236 1 254 0 88 255 236 1 254 0 130 255 174 1 254 0 131 255 174 1 254 0 132 255 174 1 254 0 133 255 174 1 254 0 134 255 174 1 254 0 135 255 174 1 254 0 137 255 236 1 254 0 148 255 236 1 254 0 149 255 236 1 254 0 150 255 236 1 254 0 151 255 236 1 254 0 152 255 236 1 254 0 154 255 236 1 254 0 162 255 215 1 254 0 163 255 215 1 254 0 164 255 215 1 254 0 165 255 215 1 254 0 166 255 215 1 254 0 167 255 215 1 254 0 168 255 215 1 254 0 169 255 215 1 254 0 170 255 215 1 254 0 171 255 215 1 254 0 172 255 215 1 254 0 173 255 215 1 254 0 180 255 215 1 254 0 181 255 215 1 254 0 182 255 215 1 254 0 183 255 215 1 254 0 184 255 215 1 254 0 186 255 215 1 254 0 187 255 236 1 254 0 188 255 236 1 254 0 189 255 236 1 254 0 190 255 236 1 254 0 194 255 174 1 254 0 195 255 215 1 254 0 196 255 174 1 254 0 197 255 215 1 254 0 198 255 174 1 254 0 199 255 215 1 254 0 200 255 236 1 254 0 201 255 215 1 254 0 202 255 236 1 254 0 203 255 215 1 254 0 204 255 236 1 254 0 205 255 215 1 254 0 206 255 236 1 254 0 207 255 215 1 254 0 209 255 215 1 254 0 211 255 215 1 254 0 213 255 215 1 254 0 215 255 215 1 254 0 217 255 215 1 254 0 219 255 215 1 254 0 221 255 215 1 254 0 222 255 236 1 254 0 223 255 236 1 254 0 224 255 236 1 254 0 225 255 236 1 254 0 226 255 236 1 254 0 227 255 236 1 254 0 228 255 236 1 254 0 229 255 236 1 254 0 250 255 236 1 254 1 6 255 236 1 254 1 8 255 236 1 254 1 13 255 236 1 254 1 14 255 236 1 254 1 15 255 215 1 254 1 16 255 236 1 254 1 17 255 215 1 254 1 18 255 236 1 254 1 19 255 215 1 254 1 20 255 236 1 254 1 21 255 215 1 254 1 23 255 236 1 254 1 25 255 236 1 254 1 29 255 236 1 254 1 33 255 236 1 254 1 43 255 236 1 254 1 45 255 236 1 254 1 47 255 236 1 254 1 49 255 236 1 254 1 51 255 236 1 254 1 53 255 236 1 254 1 67 255 174 1 254 1 68 255 215 1 254 1 70 255 215 1 254 1 71 255 236 1 254 1 72 255 215 1 254 1 74 255 236 1 254 2 8 255 154 1 254 2 12 255 154 1 254 2 87 255 236 1 254 2 88 255 174 1 254 2 89 255 215 1 254 2 95 255 236 1 254 2 96 255 215 1 254 2 98 255 236 1 254 3 29 255 174 1 254 3 30 255 215 1 254 3 31 255 174 1 254 3 32 255 215 1 254 3 33 255 174 1 254 3 34 255 215 1 254 3 35 255 174 1 254 3 37 255 174 1 254 3 38 255 215 1 254 3 39 255 174 1 254 3 40 255 215 1 254 3 41 255 174 1 254 3 42 255 215 1 254 3 43 255 174 1 254 3 44 255 215 1 254 3 45 255 174 1 254 3 46 255 215 1 254 3 47 255 174 1 254 3 48 255 215 1 254 3 49 255 174 1 254 3 50 255 215 1 254 3 51 255 174 1 254 3 52 255 215 1 254 3 54 255 215 1 254 3 56 255 215 1 254 3 58 255 215 1 254 3 60 255 215 1 254 3 64 255 215 1 254 3 66 255 215 1 254 3 68 255 215 1 254 3 73 255 236 1 254 3 74 255 215 1 254 3 75 255 236 1 254 3 76 255 215 1 254 3 77 255 236 1 254 3 78 255 215 1 254 3 79 255 236 1 254 3 81 255 236 1 254 3 82 255 215 1 254 3 83 255 236 1 254 3 84 255 215 1 254 3 85 255 236 1 254 3 86 255 215 1 254 3 87 255 236 1 254 3 88 255 215 1 254 3 89 255 236 1 254 3 90 255 215 1 254 3 91 255 236 1 254 3 92 255 215 1 254 3 93 255 236 1 254 3 94 255 215 1 254 3 95 255 236 1 254 3 96 255 215 1 254 3 98 255 236 1 254 3 100 255 236 1 254 3 102 255 236 1 254 3 104 255 236 1 254 3 106 255 236 1 254 3 108 255 236 1 254 3 110 255 236 1 255 0 5 0 82 1 255 0 10 0 82 1 255 0 15 255 174 1 255 0 17 255 174 1 255 0 34 0 41 1 255 2 7 0 82 1 255 2 8 255 174 1 255 2 11 0 82 1 255 2 12 255 174 2 0 0 15 255 133 2 0 0 17 255 133 2 0 0 34 0 41 2 0 0 36 255 133 2 0 0 38 255 215 2 0 0 42 255 215 2 0 0 50 255 215 2 0 0 52 255 215 2 0 0 68 255 154 2 0 0 70 255 154 2 0 0 71 255 154 2 0 0 72 255 154 2 0 0 74 255 215 2 0 0 80 255 195 2 0 0 81 255 195 2 0 0 82 255 154 2 0 0 83 255 195 2 0 0 84 255 154 2 0 0 85 255 195 2 0 0 86 255 174 2 0 0 88 255 195 2 0 0 93 255 215 2 0 0 130 255 133 2 0 0 131 255 133 2 0 0 132 255 133 2 0 0 133 255 133 2 0 0 134 255 133 2 0 0 135 255 133 2 0 0 137 255 215 2 0 0 148 255 215 2 0 0 149 255 215 2 0 0 150 255 215 2 0 0 151 255 215 2 0 0 152 255 215 2 0 0 154 255 215 2 0 0 162 255 154 2 0 0 163 255 154 2 0 0 164 255 154 2 0 0 165 255 154 2 0 0 166 255 154 2 0 0 167 255 154 2 0 0 168 255 154 2 0 0 169 255 154 2 0 0 170 255 154 2 0 0 171 255 154 2 0 0 172 255 154 2 0 0 173 255 154 2 0 0 180 255 154 2 0 0 181 255 154 2 0 0 182 255 154 2 0 0 183 255 154 2 0 0 184 255 154 2 0 0 186 255 154 2 0 0 187 255 195 2 0 0 188 255 195 2 0 0 189 255 195 2 0 0 190 255 195 2 0 0 194 255 133 2 0 0 195 255 154 2 0 0 196 255 133 2 0 0 197 255 154 2 0 0 198 255 133 2 0 0 199 255 154 2 0 0 200 255 215 2 0 0 201 255 154 2 0 0 202 255 215 2 0 0 203 255 154 2 0 0 204 255 215 2 0 0 205 255 154 2 0 0 206 255 215 2 0 0 207 255 154 2 0 0 209 255 154 2 0 0 211 255 154 2 0 0 213 255 154 2 0 0 215 255 154 2 0 0 217 255 154 2 0 0 219 255 154 2 0 0 221 255 154 2 0 0 222 255 215 2 0 0 223 255 215 2 0 0 224 255 215 2 0 0 225 255 215 2 0 0 226 255 215 2 0 0 227 255 215 2 0 0 228 255 215 2 0 0 229 255 215 2 0 0 250 255 195 2 0 1 6 255 195 2 0 1 8 255 195 2 0 1 13 255 195 2 0 1 14 255 215 2 0 1 15 255 154 2 0 1 16 255 215 2 0 1 17 255 154 2 0 1 18 255 215 2 0 1 19 255 154 2 0 1 20 255 215 2 0 1 21 255 154 2 0 1 23 255 195 2 0 1 25 255 195 2 0 1 29 255 174 2 0 1 33 255 174 2 0 1 43 255 195 2 0 1 45 255 195 2 0 1 47 255 195 2 0 1 49 255 195 2 0 1 51 255 195 2 0 1 53 255 195 2 0 1 60 255 215 2 0 1 62 255 215 2 0 1 64 255 215 2 0 1 67 255 133 2 0 1 68 255 154 2 0 1 70 255 154 2 0 1 71 255 215 2 0 1 72 255 154 2 0 1 74 255 174 2 0 2 8 255 133 2 0 2 12 255 133 2 0 2 87 255 195 2 0 2 88 255 133 2 0 2 89 255 154 2 0 2 95 255 215 2 0 2 96 255 154 2 0 2 98 255 195 2 0 3 29 255 133 2 0 3 30 255 154 2 0 3 31 255 133 2 0 3 32 255 154 2 0 3 33 255 133 2 0 3 34 255 154 2 0 3 35 255 133 2 0 3 37 255 133 2 0 3 38 255 154 2 0 3 39 255 133 2 0 3 40 255 154 2 0 3 41 255 133 2 0 3 42 255 154 2 0 3 43 255 133 2 0 3 44 255 154 2 0 3 45 255 133 2 0 3 46 255 154 2 0 3 47 255 133 2 0 3 48 255 154 2 0 3 49 255 133 2 0 3 50 255 154 2 0 3 51 255 133 2 0 3 52 255 154 2 0 3 54 255 154 2 0 3 56 255 154 2 0 3 58 255 154 2 0 3 60 255 154 2 0 3 64 255 154 2 0 3 66 255 154 2 0 3 68 255 154 2 0 3 73 255 215 2 0 3 74 255 154 2 0 3 75 255 215 2 0 3 76 255 154 2 0 3 77 255 215 2 0 3 78 255 154 2 0 3 79 255 215 2 0 3 81 255 215 2 0 3 82 255 154 2 0 3 83 255 215 2 0 3 84 255 154 2 0 3 85 255 215 2 0 3 86 255 154 2 0 3 87 255 215 2 0 3 88 255 154 2 0 3 89 255 215 2 0 3 90 255 154 2 0 3 91 255 215 2 0 3 92 255 154 2 0 3 93 255 215 2 0 3 94 255 154 2 0 3 95 255 215 2 0 3 96 255 154 2 0 3 98 255 195 2 0 3 100 255 195 2 0 3 102 255 195 2 0 3 104 255 195 2 0 3 106 255 195 2 0 3 108 255 195 2 0 3 110 255 195 2 1 0 5 0 82 2 1 0 10 0 82 2 1 0 15 255 174 2 1 0 17 255 174 2 1 0 34 0 41 2 1 2 7 0 82 2 1 2 8 255 174 2 1 2 11 0 82 2 1 2 12 255 174 2 2 0 55 255 174 2 2 1 36 255 174 2 2 1 38 255 174 2 2 1 113 255 174 2 2 1 157 255 174 2 2 1 166 255 174 2 2 1 188 255 174 2 2 1 196 255 174 2 2 1 220 255 215 2 2 1 228 255 215 2 2 2 169 255 174 2 2 2 170 255 215 2 2 2 181 255 174 2 2 2 182 255 215 2 2 2 189 255 174 2 2 2 190 255 215 2 2 3 23 255 174 2 2 3 24 255 215 2 2 3 143 255 174 2 3 0 55 255 174 2 3 1 36 255 174 2 3 1 38 255 174 2 3 1 113 255 174 2 3 1 157 255 174 2 3 1 166 255 174 2 3 1 188 255 174 2 3 1 196 255 174 2 3 1 220 255 215 2 3 1 228 255 215 2 3 2 169 255 174 2 3 2 170 255 215 2 3 2 181 255 174 2 3 2 182 255 215 2 3 2 189 255 174 2 3 2 190 255 215 2 3 3 23 255 174 2 3 3 24 255 215 2 3 3 143 255 174 2 4 0 55 255 174 2 4 1 36 255 174 2 4 1 38 255 174 2 4 1 113 255 174 2 4 1 157 255 174 2 4 1 166 255 174 2 4 1 188 255 174 2 4 1 196 255 174 2 4 1 220 255 215 2 4 1 228 255 215 2 4 2 169 255 174 2 4 2 170 255 215 2 4 2 181 255 174 2 4 2 182 255 215 2 4 2 189 255 174 2 4 2 190 255 215 2 4 3 23 255 174 2 4 3 24 255 215 2 4 3 143 255 174 2 6 0 36 255 113 2 6 0 55 0 41 2 6 0 57 0 41 2 6 0 58 0 41 2 6 0 60 0 20 2 6 0 68 255 174 2 6 0 70 255 133 2 6 0 71 255 133 2 6 0 72 255 133 2 6 0 74 255 195 2 6 0 80 255 195 2 6 0 81 255 195 2 6 0 82 255 133 2 6 0 83 255 195 2 6 0 84 255 133 2 6 0 85 255 195 2 6 0 86 255 195 2 6 0 88 255 195 2 6 0 130 255 113 2 6 0 131 255 113 2 6 0 132 255 113 2 6 0 133 255 113 2 6 0 134 255 113 2 6 0 135 255 113 2 6 0 159 0 20 2 6 0 162 255 133 2 6 0 163 255 174 2 6 0 164 255 174 2 6 0 165 255 174 2 6 0 166 255 174 2 6 0 167 255 174 2 6 0 168 255 174 2 6 0 169 255 133 2 6 0 170 255 133 2 6 0 171 255 133 2 6 0 172 255 133 2 6 0 173 255 133 2 6 0 180 255 133 2 6 0 181 255 133 2 6 0 182 255 133 2 6 0 183 255 133 2 6 0 184 255 133 2 6 0 186 255 133 2 6 0 187 255 195 2 6 0 188 255 195 2 6 0 189 255 195 2 6 0 190 255 195 2 6 0 194 255 113 2 6 0 195 255 174 2 6 0 196 255 113 2 6 0 197 255 174 2 6 0 198 255 113 2 6 0 199 255 174 2 6 0 201 255 133 2 6 0 203 255 133 2 6 0 205 255 133 2 6 0 207 255 133 2 6 0 209 255 133 2 6 0 211 255 133 2 6 0 213 255 133 2 6 0 215 255 133 2 6 0 217 255 133 2 6 0 219 255 133 2 6 0 221 255 133 2 6 0 223 255 195 2 6 0 225 255 195 2 6 0 227 255 195 2 6 0 229 255 195 2 6 0 250 255 195 2 6 1 6 255 195 2 6 1 8 255 195 2 6 1 13 255 195 2 6 1 15 255 133 2 6 1 17 255 133 2 6 1 19 255 133 2 6 1 21 255 133 2 6 1 23 255 195 2 6 1 25 255 195 2 6 1 29 255 195 2 6 1 33 255 195 2 6 1 36 0 41 2 6 1 38 0 41 2 6 1 43 255 195 2 6 1 45 255 195 2 6 1 47 255 195 2 6 1 49 255 195 2 6 1 51 255 195 2 6 1 53 255 195 2 6 1 54 0 41 2 6 1 56 0 20 2 6 1 58 0 20 2 6 1 67 255 113 2 6 1 68 255 174 2 6 1 70 255 174 2 6 1 72 255 133 2 6 1 74 255 195 2 6 1 86 255 113 2 6 1 95 255 113 2 6 1 98 255 113 2 6 1 105 255 113 2 6 1 121 255 174 2 6 1 122 255 215 2 6 1 123 255 215 2 6 1 126 255 174 2 6 1 129 255 195 2 6 1 130 255 215 2 6 1 131 255 215 2 6 1 132 255 215 2 6 1 135 255 215 2 6 1 137 255 215 2 6 1 140 255 174 2 6 1 142 255 195 2 6 1 143 255 174 2 6 1 144 255 174 2 6 1 147 255 174 2 6 1 153 255 174 2 6 1 164 255 133 2 6 1 170 255 113 2 6 1 174 255 133 2 6 1 181 255 133 2 6 1 202 255 215 2 6 1 206 255 113 2 6 1 207 255 133 2 6 1 213 255 113 2 6 1 216 255 133 2 6 1 219 255 133 2 6 1 222 255 133 2 6 1 234 255 133 2 6 1 237 255 133 2 6 1 238 255 195 2 6 1 242 255 113 2 6 1 250 0 41 2 6 1 252 0 41 2 6 1 254 0 41 2 6 2 0 0 20 2 6 2 87 255 195 2 6 2 88 255 113 2 6 2 89 255 174 2 6 2 96 255 133 2 6 2 98 255 195 2 6 2 106 255 133 2 6 2 114 255 113 2 6 2 115 255 113 2 6 2 125 255 236 2 6 2 127 255 133 2 6 2 133 255 133 2 6 2 135 255 133 2 6 2 137 255 133 2 6 2 141 255 133 2 6 2 178 255 133 2 6 2 180 255 133 2 6 2 206 255 133 2 6 2 207 255 113 2 6 2 217 255 113 2 6 2 218 255 215 2 6 2 219 255 113 2 6 2 220 255 215 2 6 2 221 255 113 2 6 2 222 255 215 2 6 2 224 255 133 2 6 2 226 255 215 2 6 2 228 255 215 2 6 2 240 255 133 2 6 2 242 255 133 2 6 2 244 255 133 2 6 3 9 255 113 2 6 3 10 255 133 2 6 3 11 255 113 2 6 3 12 255 133 2 6 3 17 255 133 2 6 3 18 255 113 2 6 3 22 255 133 2 6 3 26 255 133 2 6 3 27 255 133 2 6 3 28 255 113 2 6 3 29 255 113 2 6 3 30 255 174 2 6 3 31 255 113 2 6 3 32 255 174 2 6 3 33 255 113 2 6 3 34 255 174 2 6 3 35 255 113 2 6 3 37 255 113 2 6 3 38 255 174 2 6 3 39 255 113 2 6 3 40 255 174 2 6 3 41 255 113 2 6 3 42 255 174 2 6 3 43 255 113 2 6 3 44 255 174 2 6 3 45 255 113 2 6 3 46 255 174 2 6 3 47 255 113 2 6 3 48 255 174 2 6 3 49 255 113 2 6 3 50 255 174 2 6 3 51 255 113 2 6 3 52 255 174 2 6 3 54 255 133 2 6 3 56 255 133 2 6 3 58 255 133 2 6 3 60 255 133 2 6 3 64 255 133 2 6 3 66 255 133 2 6 3 68 255 133 2 6 3 74 255 133 2 6 3 76 255 133 2 6 3 78 255 133 2 6 3 82 255 133 2 6 3 84 255 133 2 6 3 86 255 133 2 6 3 88 255 133 2 6 3 90 255 133 2 6 3 92 255 133 2 6 3 94 255 133 2 6 3 96 255 133 2 6 3 98 255 195 2 6 3 100 255 195 2 6 3 102 255 195 2 6 3 104 255 195 2 6 3 106 255 195 2 6 3 108 255 195 2 6 3 110 255 195 2 6 3 111 0 20 2 6 3 113 0 20 2 6 3 115 0 20 2 6 3 143 0 41 2 7 0 36 255 113 2 7 0 55 0 41 2 7 0 57 0 41 2 7 0 58 0 41 2 7 0 60 0 20 2 7 0 68 255 174 2 7 0 70 255 133 2 7 0 71 255 133 2 7 0 72 255 133 2 7 0 74 255 195 2 7 0 80 255 195 2 7 0 81 255 195 2 7 0 82 255 133 2 7 0 83 255 195 2 7 0 84 255 133 2 7 0 85 255 195 2 7 0 86 255 195 2 7 0 88 255 195 2 7 0 130 255 113 2 7 0 131 255 113 2 7 0 132 255 113 2 7 0 133 255 113 2 7 0 134 255 113 2 7 0 135 255 113 2 7 0 159 0 20 2 7 0 162 255 133 2 7 0 163 255 174 2 7 0 164 255 174 2 7 0 165 255 174 2 7 0 166 255 174 2 7 0 167 255 174 2 7 0 168 255 174 2 7 0 169 255 133 2 7 0 170 255 133 2 7 0 171 255 133 2 7 0 172 255 133 2 7 0 173 255 133 2 7 0 180 255 133 2 7 0 181 255 133 2 7 0 182 255 133 2 7 0 183 255 133 2 7 0 184 255 133 2 7 0 186 255 133 2 7 0 187 255 195 2 7 0 188 255 195 2 7 0 189 255 195 2 7 0 190 255 195 2 7 0 194 255 113 2 7 0 195 255 174 2 7 0 196 255 113 2 7 0 197 255 174 2 7 0 198 255 113 2 7 0 199 255 174 2 7 0 201 255 133 2 7 0 203 255 133 2 7 0 205 255 133 2 7 0 207 255 133 2 7 0 209 255 133 2 7 0 211 255 133 2 7 0 213 255 133 2 7 0 215 255 133 2 7 0 217 255 133 2 7 0 219 255 133 2 7 0 221 255 133 2 7 0 223 255 195 2 7 0 225 255 195 2 7 0 227 255 195 2 7 0 229 255 195 2 7 0 250 255 195 2 7 1 6 255 195 2 7 1 8 255 195 2 7 1 13 255 195 2 7 1 15 255 133 2 7 1 17 255 133 2 7 1 19 255 133 2 7 1 21 255 133 2 7 1 23 255 195 2 7 1 25 255 195 2 7 1 29 255 195 2 7 1 33 255 195 2 7 1 36 0 41 2 7 1 38 0 41 2 7 1 43 255 195 2 7 1 45 255 195 2 7 1 47 255 195 2 7 1 49 255 195 2 7 1 51 255 195 2 7 1 53 255 195 2 7 1 54 0 41 2 7 1 56 0 20 2 7 1 58 0 20 2 7 1 67 255 113 2 7 1 68 255 174 2 7 1 70 255 174 2 7 1 72 255 133 2 7 1 74 255 195 2 7 1 86 255 113 2 7 1 95 255 113 2 7 1 98 255 113 2 7 1 105 255 113 2 7 1 121 255 174 2 7 1 122 255 215 2 7 1 123 255 215 2 7 1 126 255 174 2 7 1 129 255 195 2 7 1 130 255 215 2 7 1 131 255 215 2 7 1 132 255 215 2 7 1 135 255 215 2 7 1 137 255 215 2 7 1 140 255 174 2 7 1 142 255 195 2 7 1 143 255 174 2 7 1 144 255 174 2 7 1 147 255 174 2 7 1 153 255 174 2 7 1 164 255 133 2 7 1 170 255 113 2 7 1 174 255 133 2 7 1 181 255 133 2 7 1 202 255 215 2 7 1 206 255 113 2 7 1 207 255 133 2 7 1 213 255 113 2 7 1 216 255 133 2 7 1 219 255 133 2 7 1 222 255 133 2 7 1 234 255 133 2 7 1 237 255 133 2 7 1 238 255 195 2 7 1 242 255 113 2 7 1 250 0 41 2 7 1 252 0 41 2 7 1 254 0 41 2 7 2 0 0 20 2 7 2 87 255 195 2 7 2 88 255 113 2 7 2 89 255 174 2 7 2 96 255 133 2 7 2 98 255 195 2 7 2 106 255 133 2 7 2 114 255 113 2 7 2 115 255 113 2 7 2 125 255 236 2 7 2 127 255 133 2 7 2 133 255 133 2 7 2 135 255 133 2 7 2 137 255 133 2 7 2 141 255 133 2 7 2 178 255 133 2 7 2 180 255 133 2 7 2 206 255 133 2 7 2 207 255 113 2 7 2 217 255 113 2 7 2 218 255 215 2 7 2 219 255 113 2 7 2 220 255 215 2 7 2 221 255 113 2 7 2 222 255 215 2 7 2 224 255 133 2 7 2 226 255 215 2 7 2 228 255 215 2 7 2 240 255 133 2 7 2 242 255 133 2 7 2 244 255 133 2 7 3 9 255 113 2 7 3 10 255 133 2 7 3 11 255 113 2 7 3 12 255 133 2 7 3 17 255 133 2 7 3 18 255 113 2 7 3 22 255 133 2 7 3 26 255 133 2 7 3 27 255 133 2 7 3 28 255 113 2 7 3 29 255 113 2 7 3 30 255 174 2 7 3 31 255 113 2 7 3 32 255 174 2 7 3 33 255 113 2 7 3 34 255 174 2 7 3 35 255 113 2 7 3 37 255 113 2 7 3 38 255 174 2 7 3 39 255 113 2 7 3 40 255 174 2 7 3 41 255 113 2 7 3 42 255 174 2 7 3 43 255 113 2 7 3 44 255 174 2 7 3 45 255 113 2 7 3 46 255 174 2 7 3 47 255 113 2 7 3 48 255 174 2 7 3 49 255 113 2 7 3 50 255 174 2 7 3 51 255 113 2 7 3 52 255 174 2 7 3 54 255 133 2 7 3 56 255 133 2 7 3 58 255 133 2 7 3 60 255 133 2 7 3 64 255 133 2 7 3 66 255 133 2 7 3 68 255 133 2 7 3 74 255 133 2 7 3 76 255 133 2 7 3 78 255 133 2 7 3 82 255 133 2 7 3 84 255 133 2 7 3 86 255 133 2 7 3 88 255 133 2 7 3 90 255 133 2 7 3 92 255 133 2 7 3 94 255 133 2 7 3 96 255 133 2 7 3 98 255 195 2 7 3 100 255 195 2 7 3 102 255 195 2 7 3 104 255 195 2 7 3 106 255 195 2 7 3 108 255 195 2 7 3 110 255 195 2 7 3 111 0 20 2 7 3 113 0 20 2 7 3 115 0 20 2 7 3 143 0 41 2 8 0 38 255 154 2 8 0 42 255 154 2 8 0 50 255 154 2 8 0 52 255 154 2 8 0 55 255 113 2 8 0 56 255 215 2 8 0 57 255 133 2 8 0 58 255 133 2 8 0 60 255 133 2 8 0 137 255 154 2 8 0 148 255 154 2 8 0 149 255 154 2 8 0 150 255 154 2 8 0 151 255 154 2 8 0 152 255 154 2 8 0 154 255 154 2 8 0 155 255 215 2 8 0 156 255 215 2 8 0 157 255 215 2 8 0 158 255 215 2 8 0 159 255 133 2 8 0 200 255 154 2 8 0 202 255 154 2 8 0 204 255 154 2 8 0 206 255 154 2 8 0 222 255 154 2 8 0 224 255 154 2 8 0 226 255 154 2 8 0 228 255 154 2 8 1 14 255 154 2 8 1 16 255 154 2 8 1 18 255 154 2 8 1 20 255 154 2 8 1 36 255 113 2 8 1 38 255 113 2 8 1 42 255 215 2 8 1 44 255 215 2 8 1 46 255 215 2 8 1 48 255 215 2 8 1 50 255 215 2 8 1 52 255 215 2 8 1 54 255 133 2 8 1 56 255 133 2 8 1 58 255 133 2 8 1 71 255 154 2 8 1 102 255 174 2 8 1 109 255 174 2 8 1 113 255 113 2 8 1 114 255 133 2 8 1 115 255 154 2 8 1 117 255 133 2 8 1 120 255 133 2 8 1 133 255 215 2 8 1 157 255 113 2 8 1 159 255 154 2 8 1 166 255 113 2 8 1 184 255 154 2 8 1 187 255 154 2 8 1 188 255 113 2 8 1 190 255 174 2 8 1 193 255 92 2 8 1 196 255 113 2 8 1 220 255 154 2 8 1 225 255 133 2 8 1 228 255 154 2 8 1 250 255 133 2 8 1 252 255 133 2 8 1 254 255 133 2 8 2 0 255 133 2 8 2 84 255 133 2 8 2 95 255 154 2 8 2 97 255 215 2 8 2 108 255 154 2 8 2 124 255 92 2 8 2 126 255 154 2 8 2 128 255 133 2 8 2 130 255 133 2 8 2 132 255 154 2 8 2 134 255 154 2 8 2 136 255 154 2 8 2 138 255 154 2 8 2 140 255 154 2 8 2 169 255 113 2 8 2 170 255 154 2 8 2 177 255 154 2 8 2 179 255 154 2 8 2 181 255 113 2 8 2 182 255 154 2 8 2 183 255 133 2 8 2 185 255 133 2 8 2 189 255 113 2 8 2 190 255 154 2 8 2 191 255 92 2 8 2 192 255 133 2 8 2 193 255 92 2 8 2 194 255 133 2 8 2 197 255 133 2 8 2 199 255 133 2 8 2 212 255 92 2 8 2 213 255 133 2 8 2 239 255 154 2 8 2 241 255 154 2 8 2 243 255 154 2 8 2 253 255 92 2 8 2 254 255 133 2 8 3 13 255 133 2 8 3 14 255 154 2 8 3 15 255 133 2 8 3 16 255 154 2 8 3 21 255 154 2 8 3 23 255 113 2 8 3 24 255 154 2 8 3 73 255 154 2 8 3 75 255 154 2 8 3 77 255 154 2 8 3 79 255 154 2 8 3 81 255 154 2 8 3 83 255 154 2 8 3 85 255 154 2 8 3 87 255 154 2 8 3 89 255 154 2 8 3 91 255 154 2 8 3 93 255 154 2 8 3 95 255 154 2 8 3 97 255 215 2 8 3 99 255 215 2 8 3 101 255 215 2 8 3 103 255 215 2 8 3 105 255 215 2 8 3 107 255 215 2 8 3 109 255 215 2 8 3 111 255 133 2 8 3 113 255 133 2 8 3 115 255 133 2 8 3 143 255 113 2 10 0 36 255 113 2 10 0 55 0 41 2 10 0 57 0 41 2 10 0 58 0 41 2 10 0 60 0 20 2 10 0 68 255 174 2 10 0 70 255 133 2 10 0 71 255 133 2 10 0 72 255 133 2 10 0 74 255 195 2 10 0 80 255 195 2 10 0 81 255 195 2 10 0 82 255 133 2 10 0 83 255 195 2 10 0 84 255 133 2 10 0 85 255 195 2 10 0 86 255 195 2 10 0 88 255 195 2 10 0 130 255 113 2 10 0 131 255 113 2 10 0 132 255 113 2 10 0 133 255 113 2 10 0 134 255 113 2 10 0 135 255 113 2 10 0 159 0 20 2 10 0 162 255 133 2 10 0 163 255 174 2 10 0 164 255 174 2 10 0 165 255 174 2 10 0 166 255 174 2 10 0 167 255 174 2 10 0 168 255 174 2 10 0 169 255 133 2 10 0 170 255 133 2 10 0 171 255 133 2 10 0 172 255 133 2 10 0 173 255 133 2 10 0 180 255 133 2 10 0 181 255 133 2 10 0 182 255 133 2 10 0 183 255 133 2 10 0 184 255 133 2 10 0 186 255 133 2 10 0 187 255 195 2 10 0 188 255 195 2 10 0 189 255 195 2 10 0 190 255 195 2 10 0 194 255 113 2 10 0 195 255 174 2 10 0 196 255 113 2 10 0 197 255 174 2 10 0 198 255 113 2 10 0 199 255 174 2 10 0 201 255 133 2 10 0 203 255 133 2 10 0 205 255 133 2 10 0 207 255 133 2 10 0 209 255 133 2 10 0 211 255 133 2 10 0 213 255 133 2 10 0 215 255 133 2 10 0 217 255 133 2 10 0 219 255 133 2 10 0 221 255 133 2 10 0 223 255 195 2 10 0 225 255 195 2 10 0 227 255 195 2 10 0 229 255 195 2 10 0 250 255 195 2 10 1 6 255 195 2 10 1 8 255 195 2 10 1 13 255 195 2 10 1 15 255 133 2 10 1 17 255 133 2 10 1 19 255 133 2 10 1 21 255 133 2 10 1 23 255 195 2 10 1 25 255 195 2 10 1 29 255 195 2 10 1 33 255 195 2 10 1 36 0 41 2 10 1 38 0 41 2 10 1 43 255 195 2 10 1 45 255 195 2 10 1 47 255 195 2 10 1 49 255 195 2 10 1 51 255 195 2 10 1 53 255 195 2 10 1 54 0 41 2 10 1 56 0 20 2 10 1 58 0 20 2 10 1 67 255 113 2 10 1 68 255 174 2 10 1 70 255 174 2 10 1 72 255 133 2 10 1 74 255 195 2 10 1 86 255 113 2 10 1 95 255 113 2 10 1 98 255 113 2 10 1 105 255 113 2 10 1 121 255 174 2 10 1 122 255 215 2 10 1 123 255 215 2 10 1 126 255 174 2 10 1 129 255 195 2 10 1 130 255 215 2 10 1 131 255 215 2 10 1 132 255 215 2 10 1 135 255 215 2 10 1 137 255 215 2 10 1 140 255 174 2 10 1 142 255 195 2 10 1 143 255 174 2 10 1 144 255 174 2 10 1 147 255 174 2 10 1 153 255 174 2 10 1 164 255 133 2 10 1 170 255 113 2 10 1 174 255 133 2 10 1 181 255 133 2 10 1 202 255 215 2 10 1 206 255 113 2 10 1 207 255 133 2 10 1 213 255 113 2 10 1 216 255 133 2 10 1 219 255 133 2 10 1 222 255 133 2 10 1 234 255 133 2 10 1 237 255 133 2 10 1 238 255 195 2 10 1 242 255 113 2 10 1 250 0 41 2 10 1 252 0 41 2 10 1 254 0 41 2 10 2 0 0 20 2 10 2 87 255 195 2 10 2 88 255 113 2 10 2 89 255 174 2 10 2 96 255 133 2 10 2 98 255 195 2 10 2 106 255 133 2 10 2 114 255 113 2 10 2 115 255 113 2 10 2 125 255 236 2 10 2 127 255 133 2 10 2 133 255 133 2 10 2 135 255 133 2 10 2 137 255 133 2 10 2 141 255 133 2 10 2 178 255 133 2 10 2 180 255 133 2 10 2 206 255 133 2 10 2 207 255 113 2 10 2 217 255 113 2 10 2 218 255 215 2 10 2 219 255 113 2 10 2 220 255 215 2 10 2 221 255 113 2 10 2 222 255 215 2 10 2 224 255 133 2 10 2 226 255 215 2 10 2 228 255 215 2 10 2 240 255 133 2 10 2 242 255 133 2 10 2 244 255 133 2 10 3 9 255 113 2 10 3 10 255 133 2 10 3 11 255 113 2 10 3 12 255 133 2 10 3 17 255 133 2 10 3 18 255 113 2 10 3 22 255 133 2 10 3 26 255 133 2 10 3 27 255 133 2 10 3 28 255 113 2 10 3 29 255 113 2 10 3 30 255 174 2 10 3 31 255 113 2 10 3 32 255 174 2 10 3 33 255 113 2 10 3 34 255 174 2 10 3 35 255 113 2 10 3 37 255 113 2 10 3 38 255 174 2 10 3 39 255 113 2 10 3 40 255 174 2 10 3 41 255 113 2 10 3 42 255 174 2 10 3 43 255 113 2 10 3 44 255 174 2 10 3 45 255 113 2 10 3 46 255 174 2 10 3 47 255 113 2 10 3 48 255 174 2 10 3 49 255 113 2 10 3 50 255 174 2 10 3 51 255 113 2 10 3 52 255 174 2 10 3 54 255 133 2 10 3 56 255 133 2 10 3 58 255 133 2 10 3 60 255 133 2 10 3 64 255 133 2 10 3 66 255 133 2 10 3 68 255 133 2 10 3 74 255 133 2 10 3 76 255 133 2 10 3 78 255 133 2 10 3 82 255 133 2 10 3 84 255 133 2 10 3 86 255 133 2 10 3 88 255 133 2 10 3 90 255 133 2 10 3 92 255 133 2 10 3 94 255 133 2 10 3 96 255 133 2 10 3 98 255 195 2 10 3 100 255 195 2 10 3 102 255 195 2 10 3 104 255 195 2 10 3 106 255 195 2 10 3 108 255 195 2 10 3 110 255 195 2 10 3 111 0 20 2 10 3 113 0 20 2 10 3 115 0 20 2 10 3 143 0 41 2 12 0 38 255 154 2 12 0 42 255 154 2 12 0 50 255 154 2 12 0 52 255 154 2 12 0 55 255 113 2 12 0 56 255 215 2 12 0 57 255 133 2 12 0 58 255 133 2 12 0 60 255 133 2 12 0 137 255 154 2 12 0 148 255 154 2 12 0 149 255 154 2 12 0 150 255 154 2 12 0 151 255 154 2 12 0 152 255 154 2 12 0 154 255 154 2 12 0 155 255 215 2 12 0 156 255 215 2 12 0 157 255 215 2 12 0 158 255 215 2 12 0 159 255 133 2 12 0 200 255 154 2 12 0 202 255 154 2 12 0 204 255 154 2 12 0 206 255 154 2 12 0 222 255 154 2 12 0 224 255 154 2 12 0 226 255 154 2 12 0 228 255 154 2 12 1 14 255 154 2 12 1 16 255 154 2 12 1 18 255 154 2 12 1 20 255 154 2 12 1 36 255 113 2 12 1 38 255 113 2 12 1 42 255 215 2 12 1 44 255 215 2 12 1 46 255 215 2 12 1 48 255 215 2 12 1 50 255 215 2 12 1 52 255 215 2 12 1 54 255 133 2 12 1 56 255 133 2 12 1 58 255 133 2 12 1 71 255 154 2 12 1 102 255 174 2 12 1 109 255 174 2 12 1 113 255 113 2 12 1 114 255 133 2 12 1 115 255 154 2 12 1 117 255 133 2 12 1 120 255 133 2 12 1 133 255 215 2 12 1 157 255 113 2 12 1 159 255 154 2 12 1 166 255 113 2 12 1 184 255 154 2 12 1 187 255 154 2 12 1 188 255 113 2 12 1 190 255 174 2 12 1 193 255 92 2 12 1 196 255 113 2 12 1 220 255 154 2 12 1 225 255 133 2 12 1 228 255 154 2 12 1 250 255 133 2 12 1 252 255 133 2 12 1 254 255 133 2 12 2 0 255 133 2 12 2 84 255 133 2 12 2 95 255 154 2 12 2 97 255 215 2 12 2 108 255 154 2 12 2 124 255 92 2 12 2 126 255 154 2 12 2 128 255 133 2 12 2 130 255 133 2 12 2 132 255 154 2 12 2 134 255 154 2 12 2 136 255 154 2 12 2 138 255 154 2 12 2 140 255 154 2 12 2 169 255 113 2 12 2 170 255 154 2 12 2 177 255 154 2 12 2 179 255 154 2 12 2 181 255 113 2 12 2 182 255 154 2 12 2 183 255 133 2 12 2 185 255 133 2 12 2 189 255 113 2 12 2 190 255 154 2 12 2 191 255 92 2 12 2 192 255 133 2 12 2 193 255 92 2 12 2 194 255 133 2 12 2 197 255 133 2 12 2 199 255 133 2 12 2 212 255 92 2 12 2 213 255 133 2 12 2 239 255 154 2 12 2 241 255 154 2 12 2 243 255 154 2 12 2 253 255 92 2 12 2 254 255 133 2 12 3 13 255 133 2 12 3 14 255 154 2 12 3 15 255 133 2 12 3 16 255 154 2 12 3 21 255 154 2 12 3 23 255 113 2 12 3 24 255 154 2 12 3 73 255 154 2 12 3 75 255 154 2 12 3 77 255 154 2 12 3 79 255 154 2 12 3 81 255 154 2 12 3 83 255 154 2 12 3 85 255 154 2 12 3 87 255 154 2 12 3 89 255 154 2 12 3 91 255 154 2 12 3 93 255 154 2 12 3 95 255 154 2 12 3 97 255 215 2 12 3 99 255 215 2 12 3 101 255 215 2 12 3 103 255 215 2 12 3 105 255 215 2 12 3 107 255 215 2 12 3 109 255 215 2 12 3 111 255 133 2 12 3 113 255 133 2 12 3 115 255 133 2 12 3 143 255 113 2 33 1 113 255 215 2 33 1 114 255 236 2 33 1 120 255 236 2 33 2 84 255 236 2 83 0 15 255 195 2 83 0 17 255 195 2 83 2 8 255 195 2 83 2 12 255 195 2 84 0 15 255 133 2 84 0 17 255 133 2 84 1 86 255 133 2 84 1 95 255 133 2 84 1 98 255 133 2 84 1 102 255 215 2 84 1 105 255 133 2 84 1 109 255 215 2 84 1 115 255 195 2 84 1 118 255 236 2 84 1 121 255 154 2 84 1 122 255 174 2 84 1 123 255 195 2 84 1 124 255 195 2 84 1 125 255 195 2 84 1 126 255 154 2 84 1 129 255 195 2 84 1 130 255 174 2 84 1 132 255 195 2 84 1 134 255 195 2 84 1 135 255 195 2 84 1 137 255 195 2 84 1 140 255 154 2 84 1 142 255 154 2 84 1 143 255 154 2 84 1 144 255 154 2 84 1 146 255 195 2 84 1 147 255 154 2 84 1 149 255 195 2 84 1 150 255 195 2 84 1 152 255 195 2 84 1 153 255 154 2 84 1 154 255 195 2 84 1 155 255 195 2 84 2 8 255 133 2 84 2 12 255 133 2 84 2 33 255 236 2 88 0 5 255 113 2 88 0 10 255 113 2 88 0 38 255 215 2 88 0 42 255 215 2 88 0 45 1 10 2 88 0 50 255 215 2 88 0 52 255 215 2 88 0 55 255 113 2 88 0 57 255 174 2 88 0 58 255 174 2 88 0 60 255 133 2 88 0 137 255 215 2 88 0 148 255 215 2 88 0 149 255 215 2 88 0 150 255 215 2 88 0 151 255 215 2 88 0 152 255 215 2 88 0 154 255 215 2 88 0 159 255 133 2 88 0 200 255 215 2 88 0 202 255 215 2 88 0 204 255 215 2 88 0 206 255 215 2 88 0 222 255 215 2 88 0 224 255 215 2 88 0 226 255 215 2 88 0 228 255 215 2 88 1 14 255 215 2 88 1 16 255 215 2 88 1 18 255 215 2 88 1 20 255 215 2 88 1 36 255 113 2 88 1 38 255 113 2 88 1 54 255 174 2 88 1 56 255 133 2 88 1 58 255 133 2 88 1 71 255 215 2 88 1 250 255 174 2 88 1 252 255 174 2 88 1 254 255 174 2 88 2 0 255 133 2 88 2 7 255 113 2 88 2 11 255 113 2 88 2 95 255 215 2 88 3 73 255 215 2 88 3 75 255 215 2 88 3 77 255 215 2 88 3 79 255 215 2 88 3 81 255 215 2 88 3 83 255 215 2 88 3 85 255 215 2 88 3 87 255 215 2 88 3 89 255 215 2 88 3 91 255 215 2 88 3 93 255 215 2 88 3 95 255 215 2 88 3 111 255 133 2 88 3 113 255 133 2 88 3 115 255 133 2 88 3 143 255 113 2 89 0 5 255 236 2 89 0 10 255 236 2 89 2 7 255 236 2 89 2 11 255 236 2 90 0 15 255 174 2 90 0 17 255 174 2 90 1 86 255 215 2 90 1 95 255 215 2 90 1 98 255 215 2 90 1 100 255 236 2 90 1 105 255 215 2 90 1 112 255 236 2 90 1 113 255 195 2 90 1 114 255 236 2 90 1 116 255 215 2 90 1 117 255 236 2 90 1 120 255 236 2 90 1 136 255 236 2 90 2 8 255 174 2 90 2 12 255 174 2 90 2 84 255 236 2 96 0 73 0 82 2 96 0 87 0 82 2 96 0 89 0 102 2 96 0 90 0 102 2 96 0 91 0 102 2 96 0 92 0 102 2 96 0 191 0 102 2 96 1 37 0 82 2 96 1 39 0 82 2 96 1 55 0 102 2 96 1 251 0 102 2 96 1 253 0 102 2 96 2 52 0 82 2 96 2 53 0 82 2 96 2 93 0 82 2 96 2 94 0 82 2 96 3 112 0 102 2 96 3 141 0 82 2 96 3 144 0 82 2 98 0 73 0 102 2 98 0 87 0 102 2 98 0 89 0 102 2 98 0 90 0 102 2 98 0 91 0 102 2 98 0 92 0 102 2 98 0 191 0 102 2 98 1 37 0 102 2 98 1 39 0 102 2 98 1 55 0 102 2 98 1 251 0 102 2 98 1 253 0 102 2 98 2 52 0 102 2 98 2 53 0 102 2 98 2 93 0 102 2 98 2 94 0 102 2 98 3 112 0 102 2 98 3 141 0 102 2 98 3 144 0 102 2 106 0 5 255 236 2 106 0 10 255 236 2 106 2 7 255 236 2 106 2 11 255 236 2 108 0 15 255 174 2 108 0 17 255 174 2 108 1 157 255 236 2 108 1 164 255 215 2 108 1 166 255 236 2 108 1 168 255 215 2 108 1 170 255 215 2 108 1 174 255 215 2 108 1 176 255 215 2 108 1 177 255 236 2 108 1 181 255 215 2 108 1 188 255 195 2 108 1 189 255 215 2 108 1 191 255 215 2 108 1 193 255 215 2 108 1 196 255 236 2 108 1 199 255 236 2 108 1 206 255 236 2 108 1 213 255 236 2 108 1 242 255 236 2 108 2 8 255 174 2 108 2 12 255 174 2 108 2 114 255 215 2 108 2 115 255 236 2 108 2 122 255 236 2 108 2 124 255 215 2 108 2 128 255 236 2 108 2 130 255 236 2 108 2 159 255 215 2 108 2 161 255 236 2 108 2 169 255 236 2 108 2 181 255 195 2 108 2 183 255 236 2 108 2 185 255 236 2 108 2 187 255 215 2 108 2 189 255 236 2 108 2 191 255 215 2 108 2 193 255 215 2 108 2 202 255 215 2 108 2 206 255 215 2 108 2 207 255 236 2 108 2 212 255 215 2 108 2 217 255 215 2 108 2 219 255 215 2 108 2 221 255 215 2 108 2 229 255 215 2 108 2 231 255 236 2 108 2 245 255 236 2 108 2 247 255 215 2 108 2 249 255 215 2 108 2 251 255 215 2 108 2 253 255 215 2 108 3 5 255 215 2 108 3 7 255 215 2 108 3 13 255 215 2 108 3 15 255 215 2 108 3 17 255 215 2 108 3 18 255 236 2 108 3 23 255 236 2 108 3 27 255 215 2 108 3 28 255 236 2 109 0 15 255 174 2 109 0 17 255 174 2 109 1 206 255 215 2 109 1 213 255 215 2 109 1 242 255 215 2 109 2 8 255 174 2 109 2 12 255 174 2 109 2 115 255 215 2 109 2 207 255 215 2 109 3 18 255 215 2 109 3 28 255 215 2 110 0 5 255 174 2 110 0 10 255 174 2 110 1 157 255 215 2 110 1 166 255 215 2 110 1 188 255 174 2 110 1 193 255 174 2 110 1 196 255 215 2 110 1 220 255 215 2 110 1 228 255 215 2 110 2 7 255 174 2 110 2 11 255 174 2 110 2 124 255 174 2 110 2 128 255 195 2 110 2 130 255 195 2 110 2 169 255 215 2 110 2 170 255 215 2 110 2 181 255 174 2 110 2 182 255 215 2 110 2 183 255 195 2 110 2 185 255 195 2 110 2 189 255 215 2 110 2 190 255 215 2 110 2 191 255 174 2 110 2 193 255 174 2 110 2 212 255 174 2 110 2 253 255 174 2 110 3 13 255 154 2 110 3 15 255 154 2 110 3 23 255 215 2 110 3 24 255 215 2 111 0 5 255 133 2 111 0 10 255 133 2 111 1 208 255 215 2 111 1 220 255 154 2 111 1 221 255 195 2 111 1 223 255 215 2 111 1 225 255 174 2 111 1 228 255 154 2 111 1 246 255 195 2 111 2 7 255 133 2 111 2 11 255 133 2 111 2 109 255 215 2 111 2 129 255 215 2 111 2 131 255 215 2 111 2 139 255 215 2 111 2 160 255 215 2 111 2 170 255 154 2 111 2 182 255 154 2 111 2 184 255 195 2 111 2 186 255 195 2 111 2 188 255 215 2 111 2 190 255 154 2 111 2 192 255 174 2 111 2 194 255 174 2 111 2 198 255 215 2 111 2 200 255 215 2 111 2 203 255 215 2 111 2 213 255 174 2 111 2 230 255 215 2 111 2 234 255 215 2 111 2 248 255 195 2 111 2 250 255 195 2 111 2 252 255 195 2 111 2 254 255 174 2 111 3 6 255 215 2 111 3 8 255 215 2 111 3 14 255 154 2 111 3 16 255 154 2 111 3 24 255 154 2 112 1 159 255 215 2 112 1 184 255 215 2 112 1 187 255 215 2 112 1 190 255 215 2 112 1 225 255 215 2 112 2 108 255 215 2 112 2 126 255 215 2 112 2 132 255 215 2 112 2 134 255 215 2 112 2 136 255 215 2 112 2 138 255 215 2 112 2 140 255 215 2 112 2 177 255 215 2 112 2 179 255 215 2 112 2 192 255 215 2 112 2 194 255 215 2 112 2 197 255 215 2 112 2 199 255 215 2 112 2 213 255 215 2 112 2 239 255 215 2 112 2 241 255 215 2 112 2 243 255 215 2 112 2 254 255 215 2 112 3 9 255 215 2 112 3 11 255 215 2 112 3 14 255 215 2 112 3 16 255 215 2 112 3 21 255 215 2 114 0 5 255 113 2 114 0 10 255 113 2 114 1 157 255 154 2 114 1 166 255 154 2 114 1 188 255 113 2 114 1 190 255 215 2 114 1 193 255 154 2 114 1 196 255 154 2 114 1 220 255 215 2 114 1 225 255 215 2 114 1 228 255 215 2 114 2 7 255 113 2 114 2 11 255 113 2 114 2 110 255 215 2 114 2 124 255 154 2 114 2 128 255 174 2 114 2 130 255 174 2 114 2 151 255 215 2 114 2 155 255 215 2 114 2 167 255 215 2 114 2 169 255 154 2 114 2 170 255 215 2 114 2 181 255 113 2 114 2 182 255 215 2 114 2 183 255 133 2 114 2 185 255 133 2 114 2 189 255 154 2 114 2 190 255 215 2 114 2 191 255 154 2 114 2 192 255 215 2 114 2 193 255 154 2 114 2 194 255 215 2 114 2 197 255 154 2 114 2 199 255 154 2 114 2 212 255 154 2 114 2 213 255 215 2 114 2 225 255 215 2 114 2 227 255 215 2 114 2 253 255 154 2 114 2 254 255 215 2 114 3 3 255 215 2 114 3 13 255 113 2 114 3 14 255 215 2 114 3 15 255 113 2 114 3 16 255 215 2 114 3 23 255 154 2 114 3 24 255 215 2 115 0 5 255 113 2 115 0 10 255 113 2 115 1 207 255 215 2 115 1 216 255 215 2 115 1 219 255 215 2 115 1 220 255 154 2 115 1 221 255 195 2 115 1 222 255 215 2 115 1 225 255 195 2 115 1 228 255 154 2 115 1 234 255 215 2 115 1 237 255 215 2 115 1 246 255 195 2 115 2 7 255 113 2 115 2 11 255 113 2 115 2 106 255 215 2 115 2 109 255 215 2 115 2 125 255 236 2 115 2 127 255 215 2 115 2 129 255 215 2 115 2 131 255 215 2 115 2 133 255 215 2 115 2 135 255 215 2 115 2 137 255 215 2 115 2 139 255 215 2 115 2 141 255 215 2 115 2 170 255 154 2 115 2 178 255 215 2 115 2 180 255 215 2 115 2 182 255 154 2 115 2 184 255 215 2 115 2 186 255 215 2 115 2 190 255 154 2 115 2 192 255 195 2 115 2 194 255 195 2 115 2 198 255 215 2 115 2 200 255 215 2 115 2 213 255 195 2 115 2 224 255 215 2 115 2 240 255 215 2 115 2 242 255 215 2 115 2 244 255 215 2 115 2 248 255 195 2 115 2 250 255 195 2 115 2 252 255 195 2 115 2 254 255 195 2 115 3 10 255 215 2 115 3 12 255 215 2 115 3 14 255 133 2 115 3 16 255 133 2 115 3 22 255 215 2 115 3 24 255 154 2 115 3 26 255 215 2 116 0 5 255 113 2 116 0 10 255 113 2 116 1 157 255 154 2 116 1 166 255 154 2 116 1 188 255 113 2 116 1 190 255 215 2 116 1 193 255 154 2 116 1 196 255 154 2 116 1 220 255 215 2 116 1 225 255 215 2 116 1 228 255 215 2 116 2 7 255 113 2 116 2 11 255 113 2 116 2 110 255 215 2 116 2 124 255 154 2 116 2 128 255 174 2 116 2 130 255 174 2 116 2 151 255 215 2 116 2 155 255 215 2 116 2 167 255 215 2 116 2 169 255 154 2 116 2 170 255 215 2 116 2 181 255 113 2 116 2 182 255 215 2 116 2 183 255 133 2 116 2 185 255 133 2 116 2 189 255 154 2 116 2 190 255 215 2 116 2 191 255 154 2 116 2 192 255 215 2 116 2 193 255 154 2 116 2 194 255 215 2 116 2 197 255 154 2 116 2 199 255 154 2 116 2 212 255 154 2 116 2 213 255 215 2 116 2 225 255 215 2 116 2 227 255 215 2 116 2 253 255 154 2 116 2 254 255 215 2 116 3 3 255 215 2 116 3 13 255 113 2 116 3 14 255 215 2 116 3 15 255 113 2 116 3 16 255 215 2 116 3 23 255 154 2 116 3 24 255 215 2 117 0 5 255 113 2 117 0 10 255 113 2 117 1 207 255 215 2 117 1 216 255 215 2 117 1 219 255 215 2 117 1 220 255 154 2 117 1 221 255 195 2 117 1 222 255 215 2 117 1 225 255 195 2 117 1 228 255 154 2 117 1 234 255 215 2 117 1 237 255 215 2 117 1 246 255 195 2 117 2 7 255 113 2 117 2 11 255 113 2 117 2 106 255 215 2 117 2 109 255 215 2 117 2 125 255 236 2 117 2 127 255 215 2 117 2 129 255 215 2 117 2 131 255 215 2 117 2 133 255 215 2 117 2 135 255 215 2 117 2 137 255 215 2 117 2 139 255 215 2 117 2 141 255 215 2 117 2 170 255 154 2 117 2 178 255 215 2 117 2 180 255 215 2 117 2 182 255 154 2 117 2 184 255 215 2 117 2 186 255 215 2 117 2 190 255 154 2 117 2 192 255 195 2 117 2 194 255 195 2 117 2 198 255 215 2 117 2 200 255 215 2 117 2 213 255 195 2 117 2 224 255 215 2 117 2 240 255 215 2 117 2 242 255 215 2 117 2 244 255 215 2 117 2 248 255 195 2 117 2 250 255 195 2 117 2 252 255 195 2 117 2 254 255 195 2 117 3 10 255 215 2 117 3 12 255 215 2 117 3 14 255 133 2 117 3 16 255 133 2 117 3 22 255 215 2 117 3 24 255 154 2 117 3 26 255 215 2 118 3 13 255 236 2 118 3 15 255 236 2 120 3 13 255 236 2 120 3 15 255 236 2 122 0 15 255 174 2 122 0 17 255 174 2 122 2 8 255 174 2 122 2 12 255 174 2 122 2 128 255 236 2 122 2 130 255 236 2 122 2 183 255 236 2 122 2 185 255 236 2 122 3 13 255 215 2 122 3 15 255 215 2 124 0 15 255 113 2 124 0 17 255 113 2 124 1 164 255 195 2 124 1 170 255 174 2 124 1 174 255 195 2 124 1 181 255 195 2 124 1 206 255 215 2 124 1 213 255 215 2 124 1 242 255 215 2 124 2 8 255 113 2 124 2 12 255 113 2 124 2 114 255 174 2 124 2 115 255 215 2 124 2 206 255 195 2 124 2 207 255 215 2 124 2 217 255 174 2 124 2 219 255 174 2 124 2 221 255 174 2 124 3 9 255 174 2 124 3 11 255 174 2 124 3 17 255 195 2 124 3 18 255 215 2 124 3 27 255 195 2 124 3 28 255 215 2 125 0 5 255 236 2 125 0 10 255 236 2 125 1 208 255 215 2 125 1 220 255 236 2 125 1 221 255 236 2 125 1 223 255 215 2 125 1 225 255 236 2 125 1 228 255 236 2 125 1 246 255 236 2 125 2 7 255 236 2 125 2 11 255 236 2 125 2 160 255 215 2 125 2 170 255 236 2 125 2 182 255 236 2 125 2 188 255 215 2 125 2 190 255 236 2 125 2 192 255 236 2 125 2 194 255 236 2 125 2 203 255 215 2 125 2 213 255 236 2 125 2 230 255 215 2 125 2 248 255 236 2 125 2 250 255 236 2 125 2 252 255 236 2 125 2 254 255 236 2 125 3 6 255 215 2 125 3 8 255 215 2 125 3 14 255 236 2 125 3 16 255 236 2 125 3 24 255 236 2 126 0 15 255 174 2 126 0 17 255 174 2 126 1 157 255 236 2 126 1 164 255 215 2 126 1 166 255 236 2 126 1 168 255 215 2 126 1 170 255 215 2 126 1 174 255 215 2 126 1 176 255 215 2 126 1 177 255 236 2 126 1 181 255 215 2 126 1 188 255 195 2 126 1 189 255 215 2 126 1 191 255 215 2 126 1 193 255 215 2 126 1 196 255 236 2 126 1 199 255 236 2 126 1 206 255 236 2 126 1 213 255 236 2 126 1 242 255 236 2 126 2 8 255 174 2 126 2 12 255 174 2 126 2 114 255 215 2 126 2 115 255 236 2 126 2 122 255 236 2 126 2 124 255 215 2 126 2 128 255 236 2 126 2 130 255 236 2 126 2 159 255 215 2 126 2 161 255 236 2 126 2 169 255 236 2 126 2 181 255 195 2 126 2 183 255 236 2 126 2 185 255 236 2 126 2 187 255 215 2 126 2 189 255 236 2 126 2 191 255 215 2 126 2 193 255 215 2 126 2 202 255 215 2 126 2 206 255 215 2 126 2 207 255 236 2 126 2 212 255 215 2 126 2 217 255 215 2 126 2 219 255 215 2 126 2 221 255 215 2 126 2 229 255 215 2 126 2 231 255 236 2 126 2 245 255 236 2 126 2 247 255 215 2 126 2 249 255 215 2 126 2 251 255 215 2 126 2 253 255 215 2 126 3 5 255 215 2 126 3 7 255 215 2 126 3 13 255 215 2 126 3 15 255 215 2 126 3 17 255 215 2 126 3 18 255 236 2 126 3 23 255 236 2 126 3 27 255 215 2 126 3 28 255 236 2 127 0 5 255 236 2 127 0 10 255 236 2 127 1 208 255 215 2 127 1 220 255 236 2 127 1 221 255 236 2 127 1 223 255 215 2 127 1 225 255 236 2 127 1 228 255 236 2 127 1 246 255 236 2 127 2 7 255 236 2 127 2 11 255 236 2 127 2 160 255 215 2 127 2 170 255 236 2 127 2 182 255 236 2 127 2 188 255 215 2 127 2 190 255 236 2 127 2 192 255 236 2 127 2 194 255 236 2 127 2 203 255 215 2 127 2 213 255 236 2 127 2 230 255 215 2 127 2 248 255 236 2 127 2 250 255 236 2 127 2 252 255 236 2 127 2 254 255 236 2 127 3 6 255 215 2 127 3 8 255 215 2 127 3 14 255 236 2 127 3 16 255 236 2 127 3 24 255 236 2 128 0 15 255 133 2 128 0 17 255 133 2 128 1 159 255 236 2 128 1 164 255 154 2 128 1 170 255 113 2 128 1 174 255 154 2 128 1 181 255 154 2 128 1 184 255 236 2 128 1 187 255 236 2 128 1 190 255 195 2 128 1 201 255 236 2 128 1 206 255 174 2 128 1 207 255 215 2 128 1 213 255 174 2 128 1 216 255 215 2 128 1 219 255 215 2 128 1 222 255 215 2 128 1 225 255 215 2 128 1 234 255 215 2 128 1 235 0 102 2 128 1 237 255 215 2 128 1 238 255 236 2 128 1 242 255 174 2 128 1 244 0 102 2 128 2 8 255 133 2 128 2 12 255 133 2 128 2 106 255 215 2 128 2 108 255 236 2 128 2 114 255 113 2 128 2 115 255 174 2 128 2 126 255 236 2 128 2 127 255 215 2 128 2 132 255 236 2 128 2 133 255 215 2 128 2 134 255 236 2 128 2 135 255 215 2 128 2 136 255 236 2 128 2 137 255 215 2 128 2 138 255 236 2 128 2 140 255 236 2 128 2 141 255 215 2 128 2 152 0 102 2 128 2 168 0 102 2 128 2 177 255 236 2 128 2 178 255 215 2 128 2 179 255 236 2 128 2 180 255 215 2 128 2 192 255 215 2 128 2 194 255 215 2 128 2 197 255 215 2 128 2 198 255 195 2 128 2 199 255 215 2 128 2 200 255 195 2 128 2 206 255 154 2 128 2 207 255 174 2 128 2 213 255 215 2 128 2 217 255 113 2 128 2 219 255 113 2 128 2 221 255 113 2 128 2 224 255 215 2 128 2 239 255 236 2 128 2 240 255 215 2 128 2 241 255 236 2 128 2 242 255 215 2 128 2 243 255 236 2 128 2 244 255 215 2 128 2 254 255 215 2 128 3 9 255 113 2 128 3 10 255 215 2 128 3 11 255 113 2 128 3 12 255 215 2 128 3 17 255 154 2 128 3 18 255 174 2 128 3 21 255 236 2 128 3 22 255 215 2 128 3 26 255 215 2 128 3 27 255 154 2 128 3 28 255 174 2 129 0 15 255 174 2 129 0 17 255 174 2 129 1 206 255 215 2 129 1 213 255 215 2 129 1 242 255 215 2 129 2 8 255 174 2 129 2 12 255 174 2 129 2 115 255 215 2 129 2 207 255 215 2 129 3 18 255 215 2 129 3 28 255 215 2 130 0 15 255 133 2 130 0 17 255 133 2 130 1 159 255 236 2 130 1 164 255 154 2 130 1 170 255 113 2 130 1 174 255 154 2 130 1 181 255 154 2 130 1 184 255 236 2 130 1 187 255 236 2 130 1 190 255 195 2 130 1 201 255 236 2 130 1 206 255 174 2 130 1 207 255 215 2 130 1 213 255 174 2 130 1 216 255 215 2 130 1 219 255 215 2 130 1 222 255 215 2 130 1 225 255 215 2 130 1 234 255 215 2 130 1 235 0 102 2 130 1 237 255 215 2 130 1 238 255 236 2 130 1 242 255 174 2 130 1 244 0 102 2 130 2 8 255 133 2 130 2 12 255 133 2 130 2 106 255 215 2 130 2 108 255 236 2 130 2 114 255 113 2 130 2 115 255 174 2 130 2 126 255 236 2 130 2 127 255 215 2 130 2 132 255 236 2 130 2 133 255 215 2 130 2 134 255 236 2 130 2 135 255 215 2 130 2 136 255 236 2 130 2 137 255 215 2 130 2 138 255 236 2 130 2 140 255 236 2 130 2 141 255 215 2 130 2 152 0 102 2 130 2 168 0 102 2 130 2 177 255 236 2 130 2 178 255 215 2 130 2 179 255 236 2 130 2 180 255 215 2 130 2 192 255 215 2 130 2 194 255 215 2 130 2 197 255 215 2 130 2 198 255 195 2 130 2 199 255 215 2 130 2 200 255 195 2 130 2 206 255 154 2 130 2 207 255 174 2 130 2 213 255 215 2 130 2 217 255 113 2 130 2 219 255 113 2 130 2 221 255 113 2 130 2 224 255 215 2 130 2 239 255 236 2 130 2 240 255 215 2 130 2 241 255 236 2 130 2 242 255 215 2 130 2 243 255 236 2 130 2 244 255 215 2 130 2 254 255 215 2 130 3 9 255 113 2 130 3 10 255 215 2 130 3 11 255 113 2 130 3 12 255 215 2 130 3 17 255 154 2 130 3 18 255 174 2 130 3 21 255 236 2 130 3 22 255 215 2 130 3 26 255 215 2 130 3 27 255 154 2 130 3 28 255 174 2 131 0 15 255 174 2 131 0 17 255 174 2 131 1 206 255 215 2 131 1 213 255 215 2 131 1 242 255 215 2 131 2 8 255 174 2 131 2 12 255 174 2 131 2 115 255 215 2 131 2 207 255 215 2 131 3 18 255 215 2 131 3 28 255 215 2 132 0 15 255 174 2 132 0 17 255 174 2 132 1 206 255 215 2 132 1 213 255 215 2 132 1 242 255 215 2 132 2 8 255 174 2 132 2 12 255 174 2 132 2 115 255 215 2 132 2 207 255 215 2 132 3 18 255 215 2 132 3 28 255 215 2 133 0 15 255 174 2 133 0 17 255 174 2 133 1 206 255 215 2 133 1 213 255 215 2 133 1 242 255 215 2 133 2 8 255 174 2 133 2 12 255 174 2 133 2 115 255 215 2 133 2 207 255 215 2 133 3 18 255 215 2 133 3 28 255 215 2 134 0 15 255 174 2 134 0 17 255 174 2 134 1 157 255 236 2 134 1 164 255 215 2 134 1 166 255 236 2 134 1 168 255 215 2 134 1 170 255 215 2 134 1 174 255 215 2 134 1 176 255 215 2 134 1 177 255 236 2 134 1 181 255 215 2 134 1 188 255 195 2 134 1 189 255 215 2 134 1 191 255 215 2 134 1 193 255 215 2 134 1 196 255 236 2 134 1 199 255 236 2 134 1 206 255 236 2 134 1 213 255 236 2 134 1 242 255 236 2 134 2 8 255 174 2 134 2 12 255 174 2 134 2 114 255 215 2 134 2 115 255 236 2 134 2 122 255 236 2 134 2 124 255 215 2 134 2 128 255 236 2 134 2 130 255 236 2 134 2 159 255 215 2 134 2 161 255 236 2 134 2 169 255 236 2 134 2 181 255 195 2 134 2 183 255 236 2 134 2 185 255 236 2 134 2 187 255 215 2 134 2 189 255 236 2 134 2 191 255 215 2 134 2 193 255 215 2 134 2 202 255 215 2 134 2 206 255 215 2 134 2 207 255 236 2 134 2 212 255 215 2 134 2 217 255 215 2 134 2 219 255 215 2 134 2 221 255 215 2 134 2 229 255 215 2 134 2 231 255 236 2 134 2 245 255 236 2 134 2 247 255 215 2 134 2 249 255 215 2 134 2 251 255 215 2 134 2 253 255 215 2 134 3 5 255 215 2 134 3 7 255 215 2 134 3 13 255 215 2 134 3 15 255 215 2 134 3 17 255 215 2 134 3 18 255 236 2 134 3 23 255 236 2 134 3 27 255 215 2 134 3 28 255 236 2 135 0 5 255 236 2 135 0 10 255 236 2 135 1 208 255 215 2 135 1 220 255 236 2 135 1 221 255 236 2 135 1 223 255 215 2 135 1 225 255 236 2 135 1 228 255 236 2 135 1 246 255 236 2 135 2 7 255 236 2 135 2 11 255 236 2 135 2 160 255 215 2 135 2 170 255 236 2 135 2 182 255 236 2 135 2 188 255 215 2 135 2 190 255 236 2 135 2 192 255 236 2 135 2 194 255 236 2 135 2 203 255 215 2 135 2 213 255 236 2 135 2 230 255 215 2 135 2 248 255 236 2 135 2 250 255 236 2 135 2 252 255 236 2 135 2 254 255 236 2 135 3 6 255 215 2 135 3 8 255 215 2 135 3 14 255 236 2 135 3 16 255 236 2 135 3 24 255 236 2 136 0 15 255 174 2 136 0 17 255 174 2 136 1 157 255 236 2 136 1 164 255 215 2 136 1 166 255 236 2 136 1 168 255 215 2 136 1 170 255 215 2 136 1 174 255 215 2 136 1 176 255 215 2 136 1 177 255 236 2 136 1 181 255 215 2 136 1 188 255 195 2 136 1 189 255 215 2 136 1 191 255 215 2 136 1 193 255 215 2 136 1 196 255 236 2 136 1 199 255 236 2 136 1 206 255 236 2 136 1 213 255 236 2 136 1 242 255 236 2 136 2 8 255 174 2 136 2 12 255 174 2 136 2 114 255 215 2 136 2 115 255 236 2 136 2 122 255 236 2 136 2 124 255 215 2 136 2 128 255 236 2 136 2 130 255 236 2 136 2 159 255 215 2 136 2 161 255 236 2 136 2 169 255 236 2 136 2 181 255 195 2 136 2 183 255 236 2 136 2 185 255 236 2 136 2 187 255 215 2 136 2 189 255 236 2 136 2 191 255 215 2 136 2 193 255 215 2 136 2 202 255 215 2 136 2 206 255 215 2 136 2 207 255 236 2 136 2 212 255 215 2 136 2 217 255 215 2 136 2 219 255 215 2 136 2 221 255 215 2 136 2 229 255 215 2 136 2 231 255 236 2 136 2 245 255 236 2 136 2 247 255 215 2 136 2 249 255 215 2 136 2 251 255 215 2 136 2 253 255 215 2 136 3 5 255 215 2 136 3 7 255 215 2 136 3 13 255 215 2 136 3 15 255 215 2 136 3 17 255 215 2 136 3 18 255 236 2 136 3 23 255 236 2 136 3 27 255 215 2 136 3 28 255 236 2 137 0 5 255 236 2 137 0 10 255 236 2 137 1 208 255 215 2 137 1 220 255 236 2 137 1 221 255 236 2 137 1 223 255 215 2 137 1 225 255 236 2 137 1 228 255 236 2 137 1 246 255 236 2 137 2 7 255 236 2 137 2 11 255 236 2 137 2 160 255 215 2 137 2 170 255 236 2 137 2 182 255 236 2 137 2 188 255 215 2 137 2 190 255 236 2 137 2 192 255 236 2 137 2 194 255 236 2 137 2 203 255 215 2 137 2 213 255 236 2 137 2 230 255 215 2 137 2 248 255 236 2 137 2 250 255 236 2 137 2 252 255 236 2 137 2 254 255 236 2 137 3 6 255 215 2 137 3 8 255 215 2 137 3 14 255 236 2 137 3 16 255 236 2 137 3 24 255 236 2 138 0 15 255 174 2 138 0 17 255 174 2 138 1 157 255 236 2 138 1 164 255 215 2 138 1 166 255 236 2 138 1 168 255 215 2 138 1 170 255 215 2 138 1 174 255 215 2 138 1 176 255 215 2 138 1 177 255 236 2 138 1 181 255 215 2 138 1 188 255 195 2 138 1 189 255 215 2 138 1 191 255 215 2 138 1 193 255 215 2 138 1 196 255 236 2 138 1 199 255 236 2 138 1 206 255 236 2 138 1 213 255 236 2 138 1 242 255 236 2 138 2 8 255 174 2 138 2 12 255 174 2 138 2 114 255 215 2 138 2 115 255 236 2 138 2 122 255 236 2 138 2 124 255 215 2 138 2 128 255 236 2 138 2 130 255 236 2 138 2 159 255 215 2 138 2 161 255 236 2 138 2 169 255 236 2 138 2 181 255 195 2 138 2 183 255 236 2 138 2 185 255 236 2 138 2 187 255 215 2 138 2 189 255 236 2 138 2 191 255 215 2 138 2 193 255 215 2 138 2 202 255 215 2 138 2 206 255 215 2 138 2 207 255 236 2 138 2 212 255 215 2 138 2 217 255 215 2 138 2 219 255 215 2 138 2 221 255 215 2 138 2 229 255 215 2 138 2 231 255 236 2 138 2 245 255 236 2 138 2 247 255 215 2 138 2 249 255 215 2 138 2 251 255 215 2 138 2 253 255 215 2 138 3 5 255 215 2 138 3 7 255 215 2 138 3 13 255 215 2 138 3 15 255 215 2 138 3 17 255 215 2 138 3 18 255 236 2 138 3 23 255 236 2 138 3 27 255 215 2 138 3 28 255 236 2 139 0 15 255 174 2 139 0 17 255 174 2 139 1 206 255 215 2 139 1 213 255 215 2 139 1 242 255 215 2 139 2 8 255 174 2 139 2 12 255 174 2 139 2 115 255 215 2 139 2 207 255 215 2 139 3 18 255 215 2 139 3 28 255 215 2 140 1 159 255 215 2 140 1 184 255 215 2 140 1 187 255 215 2 140 1 190 255 215 2 140 1 225 255 215 2 140 2 108 255 215 2 140 2 126 255 215 2 140 2 132 255 215 2 140 2 134 255 215 2 140 2 136 255 215 2 140 2 138 255 215 2 140 2 140 255 215 2 140 2 177 255 215 2 140 2 179 255 215 2 140 2 192 255 215 2 140 2 194 255 215 2 140 2 197 255 215 2 140 2 199 255 215 2 140 2 213 255 215 2 140 2 239 255 215 2 140 2 241 255 215 2 140 2 243 255 215 2 140 2 254 255 215 2 140 3 9 255 215 2 140 3 11 255 215 2 140 3 14 255 215 2 140 3 16 255 215 2 140 3 21 255 215 2 149 1 163 0 225 2 149 2 234 0 41 2 149 3 14 255 215 2 149 3 16 255 215 2 150 0 5 255 236 2 150 0 10 255 236 2 150 2 7 255 236 2 150 2 11 255 236 2 151 0 5 255 174 2 151 0 10 255 174 2 151 1 157 255 215 2 151 1 166 255 215 2 151 1 188 255 174 2 151 1 193 255 174 2 151 1 196 255 215 2 151 1 220 255 215 2 151 1 228 255 215 2 151 2 7 255 174 2 151 2 11 255 174 2 151 2 124 255 174 2 151 2 128 255 195 2 151 2 130 255 195 2 151 2 169 255 215 2 151 2 170 255 215 2 151 2 181 255 174 2 151 2 182 255 215 2 151 2 183 255 195 2 151 2 185 255 195 2 151 2 189 255 215 2 151 2 190 255 215 2 151 2 191 255 174 2 151 2 193 255 174 2 151 2 212 255 174 2 151 2 253 255 174 2 151 3 13 255 154 2 151 3 15 255 154 2 151 3 23 255 215 2 151 3 24 255 215 2 152 0 5 255 133 2 152 0 10 255 133 2 152 1 208 255 215 2 152 1 220 255 154 2 152 1 221 255 195 2 152 1 223 255 215 2 152 1 225 255 174 2 152 1 228 255 154 2 152 1 246 255 195 2 152 2 7 255 133 2 152 2 11 255 133 2 152 2 109 255 215 2 152 2 129 255 215 2 152 2 131 255 215 2 152 2 139 255 215 2 152 2 160 255 215 2 152 2 170 255 154 2 152 2 182 255 154 2 152 2 184 255 195 2 152 2 186 255 195 2 152 2 188 255 215 2 152 2 190 255 154 2 152 2 192 255 174 2 152 2 194 255 174 2 152 2 198 255 215 2 152 2 200 255 215 2 152 2 203 255 215 2 152 2 213 255 174 2 152 2 230 255 215 2 152 2 234 255 215 2 152 2 248 255 195 2 152 2 250 255 195 2 152 2 252 255 195 2 152 2 254 255 174 2 152 3 6 255 215 2 152 3 8 255 215 2 152 3 14 255 154 2 152 3 16 255 154 2 152 3 24 255 154 2 153 0 15 254 246 2 153 0 17 254 246 2 153 1 164 255 133 2 153 1 170 255 154 2 153 1 174 255 133 2 153 1 176 255 215 2 153 1 181 255 133 2 153 1 191 255 215 2 153 1 206 255 154 2 153 1 213 255 154 2 153 1 242 255 154 2 153 2 8 254 246 2 153 2 12 254 246 2 153 2 114 255 154 2 153 2 115 255 154 2 153 2 118 255 236 2 153 2 159 255 215 2 153 2 187 255 215 2 153 2 202 255 215 2 153 2 206 255 133 2 153 2 207 255 154 2 153 2 217 255 154 2 153 2 219 255 154 2 153 2 221 255 154 2 153 2 229 255 215 2 153 3 5 255 215 2 153 3 7 255 215 2 153 3 9 255 174 2 153 3 11 255 174 2 153 3 17 255 133 2 153 3 18 255 154 2 153 3 27 255 133 2 153 3 28 255 154 2 154 0 5 255 236 2 154 0 10 255 236 2 154 1 208 255 215 2 154 1 220 255 236 2 154 1 221 255 236 2 154 1 223 255 215 2 154 1 225 255 236 2 154 1 228 255 236 2 154 1 246 255 236 2 154 2 7 255 236 2 154 2 11 255 236 2 154 2 160 255 215 2 154 2 170 255 236 2 154 2 182 255 236 2 154 2 188 255 215 2 154 2 190 255 236 2 154 2 192 255 236 2 154 2 194 255 236 2 154 2 203 255 215 2 154 2 213 255 236 2 154 2 230 255 215 2 154 2 248 255 236 2 154 2 250 255 236 2 154 2 252 255 236 2 154 2 254 255 236 2 154 3 6 255 215 2 154 3 8 255 215 2 154 3 14 255 236 2 154 3 16 255 236 2 154 3 24 255 236 2 155 0 15 255 154 2 155 0 16 255 215 2 155 0 17 255 154 2 155 1 157 0 41 2 155 1 159 255 215 2 155 1 164 255 174 2 155 1 166 0 41 2 155 1 170 255 133 2 155 1 174 255 174 2 155 1 181 255 174 2 155 1 184 255 215 2 155 1 187 255 215 2 155 1 188 0 41 2 155 1 190 255 195 2 155 1 196 0 41 2 155 1 204 255 195 2 155 1 205 255 195 2 155 1 206 255 154 2 155 1 207 255 174 2 155 1 208 255 215 2 155 1 209 255 215 2 155 1 210 255 195 2 155 1 211 255 195 2 155 1 212 255 195 2 155 1 213 255 154 2 155 1 214 255 195 2 155 1 215 255 195 2 155 1 216 255 174 2 155 1 217 255 195 2 155 1 218 255 195 2 155 1 219 255 174 2 155 1 222 255 174 2 155 1 223 255 215 2 155 1 224 255 195 2 155 1 225 255 154 2 155 1 226 255 195 2 155 1 227 255 195 2 155 1 229 255 195 2 155 1 230 255 195 2 155 1 231 255 215 2 155 1 232 255 195 2 155 1 234 255 174 2 155 1 235 0 41 2 155 1 236 255 195 2 155 1 237 255 174 2 155 1 238 255 195 2 155 1 242 255 154 2 155 1 243 255 195 2 155 1 244 0 41 2 155 1 245 255 195 2 155 1 247 255 195 2 155 1 249 255 195 2 155 2 2 255 215 2 155 2 3 255 215 2 155 2 4 255 215 2 155 2 8 255 154 2 155 2 12 255 154 2 155 2 106 255 174 2 155 2 107 255 195 2 155 2 108 255 215 2 155 2 113 255 195 2 155 2 114 255 133 2 155 2 115 255 154 2 155 2 117 255 195 2 155 2 119 255 215 2 155 2 121 255 195 2 155 2 125 255 195 2 155 2 126 255 215 2 155 2 127 255 174 2 155 2 132 255 215 2 155 2 133 255 174 2 155 2 134 255 215 2 155 2 135 255 174 2 155 2 136 255 215 2 155 2 137 255 174 2 155 2 138 255 215 2 155 2 140 255 215 2 155 2 141 255 174 2 155 2 150 255 195 2 155 2 152 0 41 2 155 2 154 255 195 2 155 2 158 255 195 2 155 2 160 255 215 2 155 2 162 255 215 2 155 2 164 255 195 2 155 2 166 255 195 2 155 2 168 0 41 2 155 2 169 0 41 2 155 2 172 255 195 2 155 2 174 255 195 2 155 2 176 255 195 2 155 2 177 255 215 2 155 2 178 255 174 2 155 2 179 255 215 2 155 2 180 255 174 2 155 2 181 0 41 2 155 2 188 255 215 2 155 2 189 0 41 2 155 2 192 255 154 2 155 2 194 255 154 2 155 2 196 255 195 2 155 2 197 255 215 2 155 2 198 255 195 2 155 2 199 255 215 2 155 2 200 255 195 2 155 2 203 255 215 2 155 2 205 255 195 2 155 2 206 255 174 2 155 2 207 255 154 2 155 2 209 255 195 2 155 2 211 255 195 2 155 2 213 255 154 2 155 2 215 255 195 2 155 2 217 255 133 2 155 2 219 255 133 2 155 2 221 255 133 2 155 2 224 255 174 2 155 2 230 255 215 2 155 2 232 255 215 2 155 2 236 255 195 2 155 2 238 255 195 2 155 2 239 255 215 2 155 2 240 255 174 2 155 2 241 255 215 2 155 2 242 255 174 2 155 2 243 255 215 2 155 2 244 255 174 2 155 2 246 255 215 2 155 2 254 255 154 2 155 3 0 255 195 2 155 3 2 255 195 2 155 3 6 255 215 2 155 3 8 255 215 2 155 3 9 255 154 2 155 3 10 255 174 2 155 3 11 255 154 2 155 3 12 255 174 2 155 3 14 255 215 2 155 3 16 255 215 2 155 3 17 255 174 2 155 3 18 255 154 2 155 3 20 255 195 2 155 3 21 255 215 2 155 3 22 255 174 2 155 3 23 0 41 2 155 3 26 255 174 2 155 3 27 255 174 2 155 3 28 255 154 2 156 0 15 255 195 2 156 0 17 255 195 2 156 1 206 255 195 2 156 1 207 255 215 2 156 1 213 255 195 2 156 1 216 255 215 2 156 1 219 255 215 2 156 1 222 255 215 2 156 1 234 255 215 2 156 1 237 255 215 2 156 1 242 255 195 2 156 2 8 255 195 2 156 2 12 255 195 2 156 2 106 255 215 2 156 2 115 255 195 2 156 2 127 255 215 2 156 2 133 255 215 2 156 2 135 255 215 2 156 2 137 255 215 2 156 2 141 255 215 2 156 2 178 255 215 2 156 2 180 255 215 2 156 2 207 255 195 2 156 2 224 255 215 2 156 2 240 255 215 2 156 2 242 255 215 2 156 2 244 255 215 2 156 3 10 255 215 2 156 3 12 255 215 2 156 3 18 255 195 2 156 3 22 255 215 2 156 3 26 255 215 2 156 3 28 255 195 2 157 0 5 255 195 2 157 0 10 255 195 2 157 1 157 255 195 2 157 1 163 0 102 2 157 1 166 255 195 2 157 1 188 255 195 2 157 1 193 255 174 2 157 1 196 255 195 2 157 1 220 255 215 2 157 1 225 255 215 2 157 1 228 255 215 2 157 2 7 255 195 2 157 2 11 255 195 2 157 2 124 255 174 2 157 2 128 255 195 2 157 2 130 255 195 2 157 2 169 255 195 2 157 2 170 255 215 2 157 2 181 255 195 2 157 2 182 255 215 2 157 2 183 255 215 2 157 2 185 255 215 2 157 2 189 255 195 2 157 2 190 255 215 2 157 2 191 255 174 2 157 2 192 255 215 2 157 2 193 255 174 2 157 2 194 255 215 2 157 2 212 255 174 2 157 2 213 255 215 2 157 2 253 255 174 2 157 2 254 255 215 2 157 3 13 255 215 2 157 3 14 255 195 2 157 3 15 255 215 2 157 3 16 255 195 2 157 3 23 255 195 2 157 3 24 255 215 2 158 0 5 255 195 2 158 0 10 255 195 2 158 2 7 255 195 2 158 2 11 255 195 2 158 3 14 255 215 2 158 3 16 255 215 2 159 1 159 255 215 2 159 1 163 0 225 2 159 1 184 255 215 2 159 1 187 255 215 2 159 1 190 255 195 2 159 1 220 255 215 2 159 1 225 255 174 2 159 1 228 255 215 2 159 2 108 255 215 2 159 2 123 0 61 2 159 2 125 255 236 2 159 2 126 255 215 2 159 2 132 255 215 2 159 2 134 255 215 2 159 2 136 255 215 2 159 2 138 255 215 2 159 2 140 255 215 2 159 2 170 255 215 2 159 2 177 255 215 2 159 2 179 255 215 2 159 2 182 255 215 2 159 2 190 255 215 2 159 2 192 255 174 2 159 2 194 255 174 2 159 2 197 255 195 2 159 2 198 255 215 2 159 2 199 255 195 2 159 2 200 255 215 2 159 2 213 255 174 2 159 2 239 255 215 2 159 2 241 255 215 2 159 2 243 255 215 2 159 2 254 255 174 2 159 3 14 255 215 2 159 3 16 255 215 2 159 3 21 255 215 2 159 3 24 255 215 2 160 1 207 255 236 2 160 1 216 255 236 2 160 1 219 255 236 2 160 1 222 255 236 2 160 1 225 255 236 2 160 1 234 255 236 2 160 1 237 255 236 2 160 2 106 255 236 2 160 2 127 255 236 2 160 2 133 255 236 2 160 2 135 255 236 2 160 2 137 255 236 2 160 2 141 255 236 2 160 2 178 255 236 2 160 2 180 255 236 2 160 2 192 255 236 2 160 2 194 255 236 2 160 2 213 255 236 2 160 2 224 255 236 2 160 2 240 255 236 2 160 2 242 255 236 2 160 2 244 255 236 2 160 2 254 255 236 2 160 3 10 255 236 2 160 3 12 255 236 2 160 3 14 255 215 2 160 3 16 255 215 2 160 3 22 255 236 2 160 3 26 255 236 2 161 0 15 255 174 2 161 0 17 255 174 2 161 2 8 255 174 2 161 2 12 255 174 2 161 2 128 255 236 2 161 2 130 255 236 2 161 2 183 255 236 2 161 2 185 255 236 2 161 3 13 255 215 2 161 3 15 255 215 2 162 1 233 0 41 2 163 1 159 255 215 2 163 1 163 0 225 2 163 1 184 255 215 2 163 1 187 255 215 2 163 1 190 255 195 2 163 1 220 255 215 2 163 1 225 255 174 2 163 1 228 255 215 2 163 2 108 255 215 2 163 2 123 0 61 2 163 2 125 255 236 2 163 2 126 255 215 2 163 2 132 255 215 2 163 2 134 255 215 2 163 2 136 255 215 2 163 2 138 255 215 2 163 2 140 255 215 2 163 2 170 255 215 2 163 2 177 255 215 2 163 2 179 255 215 2 163 2 182 255 215 2 163 2 190 255 215 2 163 2 192 255 174 2 163 2 194 255 174 2 163 2 197 255 195 2 163 2 198 255 215 2 163 2 199 255 195 2 163 2 200 255 215 2 163 2 213 255 174 2 163 2 239 255 215 2 163 2 241 255 215 2 163 2 243 255 215 2 163 2 254 255 174 2 163 3 14 255 215 2 163 3 16 255 215 2 163 3 21 255 215 2 163 3 24 255 215 2 164 1 207 255 236 2 164 1 216 255 236 2 164 1 219 255 236 2 164 1 222 255 236 2 164 1 225 255 236 2 164 1 234 255 236 2 164 1 237 255 236 2 164 2 106 255 236 2 164 2 127 255 236 2 164 2 133 255 236 2 164 2 135 255 236 2 164 2 137 255 236 2 164 2 141 255 236 2 164 2 178 255 236 2 164 2 180 255 236 2 164 2 192 255 236 2 164 2 194 255 236 2 164 2 213 255 236 2 164 2 224 255 236 2 164 2 240 255 236 2 164 2 242 255 236 2 164 2 244 255 236 2 164 2 254 255 236 2 164 3 10 255 236 2 164 3 12 255 236 2 164 3 14 255 215 2 164 3 16 255 215 2 164 3 22 255 236 2 164 3 26 255 236 2 165 1 159 255 215 2 165 1 184 255 215 2 165 1 187 255 215 2 165 1 190 255 215 2 165 1 193 255 215 2 165 1 225 255 215 2 165 2 108 255 215 2 165 2 124 255 215 2 165 2 126 255 215 2 165 2 132 255 215 2 165 2 134 255 215 2 165 2 136 255 215 2 165 2 138 255 215 2 165 2 140 255 215 2 165 2 177 255 215 2 165 2 179 255 215 2 165 2 191 255 215 2 165 2 192 255 215 2 165 2 193 255 215 2 165 2 194 255 215 2 165 2 197 255 154 2 165 2 199 255 154 2 165 2 212 255 215 2 165 2 213 255 215 2 165 2 239 255 215 2 165 2 241 255 215 2 165 2 243 255 215 2 165 2 253 255 215 2 165 2 254 255 215 2 165 3 9 255 215 2 165 3 11 255 215 2 165 3 14 255 215 2 165 3 16 255 215 2 165 3 21 255 215 2 165 3 25 255 236 2 166 1 207 255 215 2 166 1 216 255 215 2 166 1 219 255 215 2 166 1 222 255 215 2 166 1 225 255 215 2 166 1 234 255 215 2 166 1 237 255 215 2 166 2 106 255 215 2 166 2 127 255 215 2 166 2 133 255 215 2 166 2 135 255 215 2 166 2 137 255 215 2 166 2 141 255 215 2 166 2 178 255 215 2 166 2 180 255 215 2 166 2 192 255 215 2 166 2 194 255 215 2 166 2 198 255 215 2 166 2 200 255 215 2 166 2 213 255 215 2 166 2 224 255 215 2 166 2 240 255 215 2 166 2 242 255 215 2 166 2 244 255 215 2 166 2 254 255 215 2 166 3 10 255 215 2 166 3 12 255 215 2 166 3 22 255 215 2 166 3 26 255 215 2 167 1 159 255 215 2 167 1 184 255 215 2 167 1 187 255 215 2 167 1 190 255 215 2 167 1 193 255 215 2 167 1 225 255 215 2 167 2 108 255 215 2 167 2 124 255 215 2 167 2 126 255 215 2 167 2 132 255 215 2 167 2 134 255 215 2 167 2 136 255 215 2 167 2 138 255 215 2 167 2 140 255 215 2 167 2 177 255 215 2 167 2 179 255 215 2 167 2 191 255 215 2 167 2 192 255 215 2 167 2 193 255 215 2 167 2 194 255 215 2 167 2 197 255 154 2 167 2 199 255 154 2 167 2 212 255 215 2 167 2 213 255 215 2 167 2 239 255 215 2 167 2 241 255 215 2 167 2 243 255 215 2 167 2 253 255 215 2 167 2 254 255 215 2 167 3 9 255 215 2 167 3 11 255 215 2 167 3 14 255 215 2 167 3 16 255 215 2 167 3 21 255 215 2 167 3 25 255 236 2 168 1 207 255 215 2 168 1 216 255 215 2 168 1 219 255 215 2 168 1 222 255 215 2 168 1 225 255 215 2 168 1 234 255 215 2 168 1 237 255 215 2 168 2 106 255 215 2 168 2 127 255 215 2 168 2 133 255 215 2 168 2 135 255 215 2 168 2 137 255 215 2 168 2 141 255 215 2 168 2 178 255 215 2 168 2 180 255 215 2 168 2 192 255 215 2 168 2 194 255 215 2 168 2 198 255 215 2 168 2 200 255 215 2 168 2 213 255 215 2 168 2 224 255 215 2 168 2 240 255 215 2 168 2 242 255 215 2 168 2 244 255 215 2 168 2 254 255 215 2 168 3 10 255 215 2 168 3 12 255 215 2 168 3 22 255 215 2 168 3 26 255 215 2 169 1 159 255 215 2 169 1 184 255 215 2 169 1 187 255 215 2 169 1 190 255 215 2 169 1 193 255 215 2 169 1 225 255 215 2 169 2 108 255 215 2 169 2 124 255 215 2 169 2 126 255 215 2 169 2 132 255 215 2 169 2 134 255 215 2 169 2 136 255 215 2 169 2 138 255 215 2 169 2 140 255 215 2 169 2 177 255 215 2 169 2 179 255 215 2 169 2 191 255 215 2 169 2 192 255 215 2 169 2 193 255 215 2 169 2 194 255 215 2 169 2 197 255 154 2 169 2 199 255 154 2 169 2 212 255 215 2 169 2 213 255 215 2 169 2 239 255 215 2 169 2 241 255 215 2 169 2 243 255 215 2 169 2 253 255 215 2 169 2 254 255 215 2 169 3 9 255 215 2 169 3 11 255 215 2 169 3 14 255 215 2 169 3 16 255 215 2 169 3 21 255 215 2 169 3 25 255 236 2 170 1 207 255 215 2 170 1 216 255 215 2 170 1 219 255 215 2 170 1 222 255 215 2 170 1 225 255 215 2 170 1 234 255 215 2 170 1 237 255 215 2 170 2 106 255 215 2 170 2 127 255 215 2 170 2 133 255 215 2 170 2 135 255 215 2 170 2 137 255 215 2 170 2 141 255 215 2 170 2 178 255 215 2 170 2 180 255 215 2 170 2 192 255 215 2 170 2 194 255 215 2 170 2 198 255 215 2 170 2 200 255 215 2 170 2 213 255 215 2 170 2 224 255 215 2 170 2 240 255 215 2 170 2 242 255 215 2 170 2 244 255 215 2 170 2 254 255 215 2 170 3 10 255 215 2 170 3 12 255 215 2 170 3 22 255 215 2 170 3 26 255 215 2 171 1 163 0 225 2 171 2 234 0 41 2 171 3 14 255 215 2 171 3 16 255 215 2 172 0 5 255 236 2 172 0 10 255 236 2 172 2 7 255 236 2 172 2 11 255 236 2 173 0 15 255 154 2 173 0 16 255 215 2 173 0 17 255 154 2 173 1 157 0 41 2 173 1 159 255 215 2 173 1 164 255 174 2 173 1 166 0 41 2 173 1 170 255 133 2 173 1 174 255 174 2 173 1 181 255 174 2 173 1 184 255 215 2 173 1 187 255 215 2 173 1 188 0 41 2 173 1 190 255 195 2 173 1 196 0 41 2 173 1 204 255 195 2 173 1 205 255 195 2 173 1 206 255 154 2 173 1 207 255 174 2 173 1 208 255 215 2 173 1 209 255 215 2 173 1 210 255 195 2 173 1 211 255 195 2 173 1 212 255 195 2 173 1 213 255 154 2 173 1 214 255 195 2 173 1 215 255 195 2 173 1 216 255 174 2 173 1 217 255 195 2 173 1 218 255 195 2 173 1 219 255 174 2 173 1 222 255 174 2 173 1 223 255 215 2 173 1 224 255 195 2 173 1 225 255 154 2 173 1 226 255 195 2 173 1 227 255 195 2 173 1 229 255 195 2 173 1 230 255 195 2 173 1 231 255 215 2 173 1 232 255 195 2 173 1 234 255 174 2 173 1 235 0 41 2 173 1 236 255 195 2 173 1 237 255 174 2 173 1 238 255 195 2 173 1 242 255 154 2 173 1 243 255 195 2 173 1 244 0 41 2 173 1 245 255 195 2 173 1 247 255 195 2 173 1 249 255 195 2 173 2 2 255 215 2 173 2 3 255 215 2 173 2 4 255 215 2 173 2 8 255 154 2 173 2 12 255 154 2 173 2 106 255 174 2 173 2 107 255 195 2 173 2 108 255 215 2 173 2 113 255 195 2 173 2 114 255 133 2 173 2 115 255 154 2 173 2 117 255 195 2 173 2 119 255 215 2 173 2 121 255 195 2 173 2 125 255 195 2 173 2 126 255 215 2 173 2 127 255 174 2 173 2 132 255 215 2 173 2 133 255 174 2 173 2 134 255 215 2 173 2 135 255 174 2 173 2 136 255 215 2 173 2 137 255 174 2 173 2 138 255 215 2 173 2 140 255 215 2 173 2 141 255 174 2 173 2 150 255 195 2 173 2 152 0 41 2 173 2 154 255 195 2 173 2 158 255 195 2 173 2 160 255 215 2 173 2 162 255 215 2 173 2 164 255 195 2 173 2 166 255 195 2 173 2 168 0 41 2 173 2 169 0 41 2 173 2 172 255 195 2 173 2 174 255 195 2 173 2 176 255 195 2 173 2 177 255 215 2 173 2 178 255 174 2 173 2 179 255 215 2 173 2 180 255 174 2 173 2 181 0 41 2 173 2 188 255 215 2 173 2 189 0 41 2 173 2 192 255 154 2 173 2 194 255 154 2 173 2 196 255 195 2 173 2 197 255 215 2 173 2 198 255 195 2 173 2 199 255 215 2 173 2 200 255 195 2 173 2 203 255 215 2 173 2 205 255 195 2 173 2 206 255 174 2 173 2 207 255 154 2 173 2 209 255 195 2 173 2 211 255 195 2 173 2 213 255 154 2 173 2 215 255 195 2 173 2 217 255 133 2 173 2 219 255 133 2 173 2 221 255 133 2 173 2 224 255 174 2 173 2 230 255 215 2 173 2 232 255 215 2 173 2 236 255 195 2 173 2 238 255 195 2 173 2 239 255 215 2 173 2 240 255 174 2 173 2 241 255 215 2 173 2 242 255 174 2 173 2 243 255 215 2 173 2 244 255 174 2 173 2 246 255 215 2 173 2 254 255 154 2 173 3 0 255 195 2 173 3 2 255 195 2 173 3 6 255 215 2 173 3 8 255 215 2 173 3 9 255 154 2 173 3 10 255 174 2 173 3 11 255 154 2 173 3 12 255 174 2 173 3 14 255 215 2 173 3 16 255 215 2 173 3 17 255 174 2 173 3 18 255 154 2 173 3 20 255 195 2 173 3 21 255 215 2 173 3 22 255 174 2 173 3 23 0 41 2 173 3 26 255 174 2 173 3 27 255 174 2 173 3 28 255 154 2 174 0 15 255 154 2 174 0 16 255 215 2 174 0 17 255 154 2 174 1 206 255 195 2 174 1 207 255 236 2 174 1 213 255 195 2 174 1 216 255 236 2 174 1 219 255 236 2 174 1 222 255 236 2 174 1 234 255 236 2 174 1 237 255 236 2 174 1 242 255 195 2 174 2 2 255 215 2 174 2 3 255 215 2 174 2 4 255 215 2 174 2 8 255 154 2 174 2 12 255 154 2 174 2 106 255 236 2 174 2 115 255 195 2 174 2 127 255 236 2 174 2 133 255 236 2 174 2 135 255 236 2 174 2 137 255 236 2 174 2 141 255 236 2 174 2 178 255 236 2 174 2 180 255 236 2 174 2 207 255 195 2 174 2 224 255 236 2 174 2 240 255 236 2 174 2 242 255 236 2 174 2 244 255 236 2 174 3 10 255 236 2 174 3 12 255 236 2 174 3 18 255 195 2 174 3 22 255 236 2 174 3 26 255 236 2 174 3 28 255 195 2 175 0 5 255 92 2 175 0 10 255 92 2 175 1 157 255 154 2 175 1 163 0 102 2 175 1 166 255 154 2 175 1 188 255 72 2 175 1 193 255 133 2 175 1 196 255 154 2 175 1 220 255 174 2 175 1 225 255 215 2 175 1 228 255 174 2 175 2 7 255 92 2 175 2 11 255 92 2 175 2 124 255 133 2 175 2 128 255 113 2 175 2 130 255 113 2 175 2 169 255 154 2 175 2 170 255 174 2 175 2 181 255 72 2 175 2 182 255 174 2 175 2 183 255 154 2 175 2 185 255 154 2 175 2 189 255 154 2 175 2 190 255 174 2 175 2 191 255 133 2 175 2 192 255 215 2 175 2 193 255 133 2 175 2 194 255 215 2 175 2 197 255 195 2 175 2 198 255 215 2 175 2 199 255 195 2 175 2 200 255 215 2 175 2 212 255 133 2 175 2 213 255 215 2 175 2 253 255 133 2 175 2 254 255 215 2 175 3 13 255 72 2 175 3 14 255 174 2 175 3 15 255 72 2 175 3 16 255 174 2 175 3 23 255 154 2 175 3 24 255 174 2 176 0 5 255 113 2 176 0 10 255 113 2 176 1 220 255 154 2 176 1 225 255 215 2 176 1 228 255 154 2 176 2 7 255 113 2 176 2 11 255 113 2 176 2 109 255 215 2 176 2 129 255 215 2 176 2 131 255 215 2 176 2 139 255 215 2 176 2 170 255 154 2 176 2 182 255 154 2 176 2 184 255 215 2 176 2 186 255 215 2 176 2 190 255 154 2 176 2 192 255 215 2 176 2 194 255 215 2 176 2 198 255 215 2 176 2 200 255 215 2 176 2 213 255 215 2 176 2 254 255 215 2 176 3 14 255 113 2 176 3 16 255 113 2 176 3 24 255 154 2 177 1 157 255 215 2 177 1 166 255 215 2 177 1 188 255 195 2 177 1 196 255 215 2 177 2 128 255 236 2 177 2 130 255 236 2 177 2 169 255 215 2 177 2 181 255 195 2 177 2 183 255 236 2 177 2 185 255 236 2 177 2 189 255 215 2 177 3 13 255 215 2 177 3 15 255 215 2 177 3 23 255 215 2 178 0 5 255 236 2 178 0 10 255 236 2 178 1 208 255 215 2 178 1 220 255 236 2 178 1 221 255 236 2 178 1 223 255 215 2 178 1 225 255 236 2 178 1 228 255 236 2 178 1 246 255 236 2 178 2 7 255 236 2 178 2 11 255 236 2 178 2 160 255 215 2 178 2 170 255 236 2 178 2 182 255 236 2 178 2 188 255 215 2 178 2 190 255 236 2 178 2 192 255 236 2 178 2 194 255 236 2 178 2 203 255 215 2 178 2 213 255 236 2 178 2 230 255 215 2 178 2 248 255 236 2 178 2 250 255 236 2 178 2 252 255 236 2 178 2 254 255 236 2 178 3 6 255 215 2 178 3 8 255 215 2 178 3 14 255 236 2 178 3 16 255 236 2 178 3 24 255 236 2 179 1 159 255 215 2 179 1 184 255 215 2 179 1 187 255 215 2 179 1 190 255 215 2 179 1 225 255 215 2 179 2 108 255 215 2 179 2 126 255 215 2 179 2 132 255 215 2 179 2 134 255 215 2 179 2 136 255 215 2 179 2 138 255 215 2 179 2 140 255 215 2 179 2 177 255 215 2 179 2 179 255 215 2 179 2 192 255 215 2 179 2 194 255 215 2 179 2 197 255 215 2 179 2 199 255 215 2 179 2 213 255 215 2 179 2 239 255 215 2 179 2 241 255 215 2 179 2 243 255 215 2 179 2 254 255 215 2 179 3 9 255 215 2 179 3 11 255 215 2 179 3 14 255 215 2 179 3 16 255 215 2 179 3 21 255 215 2 181 0 15 255 133 2 181 0 16 255 174 2 181 0 17 255 133 2 181 1 159 255 215 2 181 1 164 255 154 2 181 1 170 255 113 2 181 1 174 255 154 2 181 1 181 255 154 2 181 1 184 255 215 2 181 1 187 255 215 2 181 1 188 0 41 2 181 1 190 255 174 2 181 1 204 255 154 2 181 1 205 255 154 2 181 1 206 255 133 2 181 1 207 255 113 2 181 1 208 255 215 2 181 1 209 255 215 2 181 1 210 255 154 2 181 1 211 255 154 2 181 1 212 255 154 2 181 1 213 255 133 2 181 1 214 255 154 2 181 1 215 255 154 2 181 1 216 255 113 2 181 1 217 255 154 2 181 1 218 255 154 2 181 1 219 255 113 2 181 1 220 255 174 2 181 1 221 255 174 2 181 1 222 255 113 2 181 1 223 255 215 2 181 1 224 255 154 2 181 1 225 255 154 2 181 1 226 255 154 2 181 1 227 255 154 2 181 1 228 255 174 2 181 1 229 255 154 2 181 1 230 255 154 2 181 1 231 255 215 2 181 1 232 255 154 2 181 1 233 255 195 2 181 1 234 255 113 2 181 1 236 255 154 2 181 1 237 255 113 2 181 1 238 255 133 2 181 1 242 255 133 2 181 1 243 255 154 2 181 1 245 255 154 2 181 1 246 255 174 2 181 1 247 255 154 2 181 1 249 255 154 2 181 2 2 255 174 2 181 2 3 255 174 2 181 2 4 255 174 2 181 2 8 255 133 2 181 2 12 255 133 2 181 2 106 255 113 2 181 2 107 255 154 2 181 2 108 255 215 2 181 2 109 255 215 2 181 2 113 255 154 2 181 2 114 255 113 2 181 2 115 255 133 2 181 2 117 255 154 2 181 2 119 255 154 2 181 2 121 255 154 2 181 2 125 255 154 2 181 2 126 255 215 2 181 2 127 255 113 2 181 2 129 255 215 2 181 2 131 255 215 2 181 2 132 255 215 2 181 2 133 255 113 2 181 2 134 255 215 2 181 2 135 255 113 2 181 2 136 255 215 2 181 2 137 255 113 2 181 2 138 255 215 2 181 2 139 255 215 2 181 2 140 255 215 2 181 2 141 255 113 2 181 2 150 255 154 2 181 2 154 255 154 2 181 2 158 255 154 2 181 2 160 255 215 2 181 2 162 255 215 2 181 2 164 255 154 2 181 2 166 255 154 2 181 2 170 255 174 2 181 2 172 255 154 2 181 2 174 255 154 2 181 2 176 255 154 2 181 2 177 255 215 2 181 2 178 255 113 2 181 2 179 255 215 2 181 2 180 255 113 2 181 2 181 0 41 2 181 2 182 255 174 2 181 2 184 255 174 2 181 2 186 255 174 2 181 2 188 255 215 2 181 2 190 255 174 2 181 2 192 255 154 2 181 2 194 255 154 2 181 2 196 255 154 2 181 2 197 255 154 2 181 2 198 255 113 2 181 2 199 255 154 2 181 2 200 255 113 2 181 2 203 255 215 2 181 2 205 255 154 2 181 2 206 255 154 2 181 2 207 255 133 2 181 2 209 255 154 2 181 2 211 255 154 2 181 2 213 255 154 2 181 2 215 255 154 2 181 2 217 255 113 2 181 2 219 255 113 2 181 2 221 255 113 2 181 2 224 255 113 2 181 2 230 255 215 2 181 2 232 255 215 2 181 2 234 255 195 2 181 2 236 255 154 2 181 2 238 255 154 2 181 2 239 255 215 2 181 2 240 255 113 2 181 2 241 255 215 2 181 2 242 255 113 2 181 2 243 255 215 2 181 2 244 255 113 2 181 2 246 255 215 2 181 2 248 255 174 2 181 2 250 255 174 2 181 2 252 255 174 2 181 2 254 255 154 2 181 3 0 255 154 2 181 3 2 255 154 2 181 3 6 255 215 2 181 3 8 255 215 2 181 3 9 255 113 2 181 3 10 255 113 2 181 3 11 255 113 2 181 3 12 255 113 2 181 3 14 255 154 2 181 3 16 255 154 2 181 3 17 255 154 2 181 3 18 255 133 2 181 3 20 255 154 2 181 3 21 255 215 2 181 3 22 255 113 2 181 3 24 255 174 2 181 3 26 255 113 2 181 3 27 255 154 2 181 3 28 255 133 2 182 0 15 255 154 2 182 0 16 255 215 2 182 0 17 255 154 2 182 1 206 255 195 2 182 1 207 255 236 2 182 1 213 255 195 2 182 1 216 255 236 2 182 1 219 255 236 2 182 1 222 255 236 2 182 1 234 255 236 2 182 1 237 255 236 2 182 1 242 255 195 2 182 2 2 255 215 2 182 2 3 255 215 2 182 2 4 255 215 2 182 2 8 255 154 2 182 2 12 255 154 2 182 2 106 255 236 2 182 2 115 255 195 2 182 2 127 255 236 2 182 2 133 255 236 2 182 2 135 255 236 2 182 2 137 255 236 2 182 2 141 255 236 2 182 2 178 255 236 2 182 2 180 255 236 2 182 2 207 255 195 2 182 2 224 255 236 2 182 2 240 255 236 2 182 2 242 255 236 2 182 2 244 255 236 2 182 3 10 255 236 2 182 3 12 255 236 2 182 3 18 255 195 2 182 3 22 255 236 2 182 3 26 255 236 2 182 3 28 255 195 2 183 0 15 255 133 2 183 0 17 255 133 2 183 1 159 255 215 2 183 1 164 255 174 2 183 1 170 255 133 2 183 1 174 255 174 2 183 1 181 255 174 2 183 1 184 255 215 2 183 1 187 255 215 2 183 1 190 255 195 2 183 1 202 255 174 2 183 1 204 255 195 2 183 1 205 255 195 2 183 1 206 255 154 2 183 1 207 255 154 2 183 1 210 255 195 2 183 1 211 255 195 2 183 1 212 255 195 2 183 1 213 255 154 2 183 1 214 255 195 2 183 1 215 255 195 2 183 1 216 255 154 2 183 1 217 255 195 2 183 1 218 255 195 2 183 1 219 255 154 2 183 1 222 255 154 2 183 1 224 255 195 2 183 1 225 255 174 2 183 1 226 255 195 2 183 1 227 255 195 2 183 1 229 255 195 2 183 1 230 255 195 2 183 1 232 255 195 2 183 1 233 255 215 2 183 1 234 255 154 2 183 1 235 0 41 2 183 1 236 255 195 2 183 1 237 255 154 2 183 1 238 255 174 2 183 1 242 255 154 2 183 1 243 255 195 2 183 1 244 0 41 2 183 1 245 255 195 2 183 1 247 255 195 2 183 1 249 255 195 2 183 2 8 255 133 2 183 2 12 255 133 2 183 2 106 255 154 2 183 2 107 255 195 2 183 2 108 255 215 2 183 2 113 255 195 2 183 2 114 255 133 2 183 2 115 255 154 2 183 2 117 255 195 2 183 2 119 255 215 2 183 2 121 255 195 2 183 2 125 255 215 2 183 2 126 255 215 2 183 2 127 255 154 2 183 2 132 255 215 2 183 2 133 255 154 2 183 2 134 255 215 2 183 2 135 255 154 2 183 2 136 255 215 2 183 2 137 255 154 2 183 2 138 255 215 2 183 2 140 255 215 2 183 2 141 255 154 2 183 2 150 255 195 2 183 2 152 0 41 2 183 2 154 255 195 2 183 2 158 255 195 2 183 2 164 255 195 2 183 2 166 255 195 2 183 2 168 0 41 2 183 2 172 255 195 2 183 2 174 255 195 2 183 2 176 255 195 2 183 2 177 255 215 2 183 2 178 255 154 2 183 2 179 255 215 2 183 2 180 255 154 2 183 2 192 255 174 2 183 2 194 255 174 2 183 2 196 255 195 2 183 2 198 255 174 2 183 2 200 255 174 2 183 2 205 255 195 2 183 2 206 255 174 2 183 2 207 255 154 2 183 2 209 255 195 2 183 2 211 255 195 2 183 2 213 255 174 2 183 2 215 255 195 2 183 2 217 255 133 2 183 2 218 255 174 2 183 2 219 255 133 2 183 2 220 255 174 2 183 2 221 255 133 2 183 2 222 255 174 2 183 2 224 255 154 2 183 2 225 255 236 2 183 2 226 255 174 2 183 2 227 255 236 2 183 2 228 255 174 2 183 2 236 255 195 2 183 2 238 255 195 2 183 2 239 255 215 2 183 2 240 255 154 2 183 2 241 255 215 2 183 2 242 255 154 2 183 2 243 255 215 2 183 2 244 255 154 2 183 2 254 255 174 2 183 3 0 255 195 2 183 3 2 255 195 2 183 3 9 255 174 2 183 3 10 255 154 2 183 3 11 255 174 2 183 3 12 255 154 2 183 3 14 255 215 2 183 3 16 255 215 2 183 3 17 255 174 2 183 3 18 255 154 2 183 3 20 255 195 2 183 3 21 255 215 2 183 3 22 255 154 2 183 3 25 255 236 2 183 3 26 255 154 2 183 3 27 255 174 2 183 3 28 255 154 2 184 0 15 255 174 2 184 0 17 255 174 2 184 1 206 255 236 2 184 1 213 255 236 2 184 1 242 255 236 2 184 2 8 255 174 2 184 2 12 255 174 2 184 2 115 255 236 2 184 2 207 255 236 2 184 3 18 255 236 2 184 3 28 255 236 2 185 0 15 255 133 2 185 0 17 255 133 2 185 1 159 255 215 2 185 1 164 255 174 2 185 1 170 255 133 2 185 1 174 255 174 2 185 1 181 255 174 2 185 1 184 255 215 2 185 1 187 255 215 2 185 1 190 255 195 2 185 1 202 255 174 2 185 1 204 255 195 2 185 1 205 255 195 2 185 1 206 255 154 2 185 1 207 255 154 2 185 1 210 255 195 2 185 1 211 255 195 2 185 1 212 255 195 2 185 1 213 255 154 2 185 1 214 255 195 2 185 1 215 255 195 2 185 1 216 255 154 2 185 1 217 255 195 2 185 1 218 255 195 2 185 1 219 255 154 2 185 1 222 255 154 2 185 1 224 255 195 2 185 1 225 255 174 2 185 1 226 255 195 2 185 1 227 255 195 2 185 1 229 255 195 2 185 1 230 255 195 2 185 1 232 255 195 2 185 1 233 255 215 2 185 1 234 255 154 2 185 1 235 0 41 2 185 1 236 255 195 2 185 1 237 255 154 2 185 1 238 255 174 2 185 1 242 255 154 2 185 1 243 255 195 2 185 1 244 0 41 2 185 1 245 255 195 2 185 1 247 255 195 2 185 1 249 255 195 2 185 2 8 255 133 2 185 2 12 255 133 2 185 2 106 255 154 2 185 2 107 255 195 2 185 2 108 255 215 2 185 2 113 255 195 2 185 2 114 255 133 2 185 2 115 255 154 2 185 2 117 255 195 2 185 2 119 255 215 2 185 2 121 255 195 2 185 2 125 255 215 2 185 2 126 255 215 2 185 2 127 255 154 2 185 2 132 255 215 2 185 2 133 255 154 2 185 2 134 255 215 2 185 2 135 255 154 2 185 2 136 255 215 2 185 2 137 255 154 2 185 2 138 255 215 2 185 2 140 255 215 2 185 2 141 255 154 2 185 2 150 255 195 2 185 2 152 0 41 2 185 2 154 255 195 2 185 2 158 255 195 2 185 2 164 255 195 2 185 2 166 255 195 2 185 2 168 0 41 2 185 2 172 255 195 2 185 2 174 255 195 2 185 2 176 255 195 2 185 2 177 255 215 2 185 2 178 255 154 2 185 2 179 255 215 2 185 2 180 255 154 2 185 2 192 255 174 2 185 2 194 255 174 2 185 2 196 255 195 2 185 2 198 255 174 2 185 2 200 255 174 2 185 2 205 255 195 2 185 2 206 255 174 2 185 2 207 255 154 2 185 2 209 255 195 2 185 2 211 255 195 2 185 2 213 255 174 2 185 2 215 255 195 2 185 2 217 255 133 2 185 2 218 255 174 2 185 2 219 255 133 2 185 2 220 255 174 2 185 2 221 255 133 2 185 2 222 255 174 2 185 2 224 255 154 2 185 2 225 255 236 2 185 2 226 255 174 2 185 2 227 255 236 2 185 2 228 255 174 2 185 2 236 255 195 2 185 2 238 255 195 2 185 2 239 255 215 2 185 2 240 255 154 2 185 2 241 255 215 2 185 2 242 255 154 2 185 2 243 255 215 2 185 2 244 255 154 2 185 2 254 255 174 2 185 3 0 255 195 2 185 3 2 255 195 2 185 3 9 255 174 2 185 3 10 255 154 2 185 3 11 255 174 2 185 3 12 255 154 2 185 3 14 255 215 2 185 3 16 255 215 2 185 3 17 255 174 2 185 3 18 255 154 2 185 3 20 255 195 2 185 3 21 255 215 2 185 3 22 255 154 2 185 3 25 255 236 2 185 3 26 255 154 2 185 3 27 255 174 2 185 3 28 255 154 2 186 0 15 255 174 2 186 0 17 255 174 2 186 1 206 255 236 2 186 1 213 255 236 2 186 1 242 255 236 2 186 2 8 255 174 2 186 2 12 255 174 2 186 2 115 255 236 2 186 2 207 255 236 2 186 3 18 255 236 2 186 3 28 255 236 2 187 1 159 255 215 2 187 1 163 0 225 2 187 1 184 255 215 2 187 1 187 255 215 2 187 1 190 255 195 2 187 1 220 255 215 2 187 1 225 255 174 2 187 1 228 255 215 2 187 2 108 255 215 2 187 2 123 0 61 2 187 2 125 255 236 2 187 2 126 255 215 2 187 2 132 255 215 2 187 2 134 255 215 2 187 2 136 255 215 2 187 2 138 255 215 2 187 2 140 255 215 2 187 2 170 255 215 2 187 2 177 255 215 2 187 2 179 255 215 2 187 2 182 255 215 2 187 2 190 255 215 2 187 2 192 255 174 2 187 2 194 255 174 2 187 2 197 255 195 2 187 2 198 255 215 2 187 2 199 255 195 2 187 2 200 255 215 2 187 2 213 255 174 2 187 2 239 255 215 2 187 2 241 255 215 2 187 2 243 255 215 2 187 2 254 255 174 2 187 3 14 255 215 2 187 3 16 255 215 2 187 3 21 255 215 2 187 3 24 255 215 2 188 1 207 255 236 2 188 1 216 255 236 2 188 1 219 255 236 2 188 1 222 255 236 2 188 1 225 255 236 2 188 1 234 255 236 2 188 1 237 255 236 2 188 2 106 255 236 2 188 2 127 255 236 2 188 2 133 255 236 2 188 2 135 255 236 2 188 2 137 255 236 2 188 2 141 255 236 2 188 2 178 255 236 2 188 2 180 255 236 2 188 2 192 255 236 2 188 2 194 255 236 2 188 2 213 255 236 2 188 2 224 255 236 2 188 2 240 255 236 2 188 2 242 255 236 2 188 2 244 255 236 2 188 2 254 255 236 2 188 3 10 255 236 2 188 3 12 255 236 2 188 3 14 255 215 2 188 3 16 255 215 2 188 3 22 255 236 2 188 3 26 255 236 2 189 1 163 0 225 2 189 2 234 0 41 2 189 3 14 255 215 2 189 3 16 255 215 2 190 0 5 255 236 2 190 0 10 255 236 2 190 2 7 255 236 2 190 2 11 255 236 2 191 1 163 0 225 2 191 2 234 0 41 2 191 3 14 255 215 2 191 3 16 255 215 2 192 0 5 255 236 2 192 0 10 255 236 2 192 2 7 255 236 2 192 2 11 255 236 2 195 0 5 255 195 2 195 0 10 255 195 2 195 1 157 255 215 2 195 1 166 255 215 2 195 1 188 255 133 2 195 1 193 255 174 2 195 1 196 255 215 2 195 1 220 255 215 2 195 1 221 255 236 2 195 1 225 255 236 2 195 1 228 255 215 2 195 1 246 255 236 2 195 2 7 255 195 2 195 2 11 255 195 2 195 2 124 255 174 2 195 2 128 255 195 2 195 2 130 255 195 2 195 2 169 255 215 2 195 2 170 255 215 2 195 2 181 255 133 2 195 2 182 255 215 2 195 2 183 255 154 2 195 2 185 255 154 2 195 2 189 255 215 2 195 2 190 255 215 2 195 2 191 255 174 2 195 2 192 255 236 2 195 2 193 255 174 2 195 2 194 255 236 2 195 2 212 255 174 2 195 2 213 255 236 2 195 2 248 255 236 2 195 2 250 255 236 2 195 2 252 255 236 2 195 2 253 255 174 2 195 2 254 255 236 2 195 3 13 255 174 2 195 3 14 255 215 2 195 3 15 255 174 2 195 3 16 255 215 2 195 3 23 255 215 2 195 3 24 255 215 2 196 0 5 255 154 2 196 0 10 255 154 2 196 1 220 255 215 2 196 1 221 255 215 2 196 1 228 255 215 2 196 1 246 255 215 2 196 2 7 255 154 2 196 2 11 255 154 2 196 2 170 255 215 2 196 2 182 255 215 2 196 2 184 255 215 2 196 2 186 255 215 2 196 2 190 255 215 2 196 2 248 255 215 2 196 2 250 255 215 2 196 2 252 255 215 2 196 3 14 255 174 2 196 3 16 255 174 2 196 3 24 255 215 2 197 1 188 255 215 2 197 2 128 255 236 2 197 2 130 255 236 2 197 2 181 255 215 2 197 2 183 255 236 2 197 2 185 255 236 2 197 3 13 255 236 2 197 3 15 255 236 2 198 0 5 255 236 2 198 0 10 255 236 2 198 2 7 255 236 2 198 2 11 255 236 2 199 1 188 255 215 2 199 2 128 255 236 2 199 2 130 255 236 2 199 2 181 255 215 2 199 2 183 255 236 2 199 2 185 255 236 2 199 3 13 255 236 2 199 3 15 255 236 2 200 0 5 255 236 2 200 0 10 255 236 2 200 2 7 255 236 2 200 2 11 255 236 2 202 1 159 255 215 2 202 1 184 255 215 2 202 1 187 255 215 2 202 1 190 255 215 2 202 1 193 255 215 2 202 1 225 255 215 2 202 2 108 255 215 2 202 2 124 255 215 2 202 2 126 255 215 2 202 2 132 255 215 2 202 2 134 255 215 2 202 2 136 255 215 2 202 2 138 255 215 2 202 2 140 255 215 2 202 2 177 255 215 2 202 2 179 255 215 2 202 2 191 255 215 2 202 2 192 255 215 2 202 2 193 255 215 2 202 2 194 255 215 2 202 2 197 255 154 2 202 2 199 255 154 2 202 2 212 255 215 2 202 2 213 255 215 2 202 2 239 255 215 2 202 2 241 255 215 2 202 2 243 255 215 2 202 2 253 255 215 2 202 2 254 255 215 2 202 3 9 255 215 2 202 3 11 255 215 2 202 3 14 255 215 2 202 3 16 255 215 2 202 3 21 255 215 2 202 3 25 255 236 2 203 1 207 255 215 2 203 1 216 255 215 2 203 1 219 255 215 2 203 1 222 255 215 2 203 1 225 255 215 2 203 1 234 255 215 2 203 1 237 255 215 2 203 2 106 255 215 2 203 2 127 255 215 2 203 2 133 255 215 2 203 2 135 255 215 2 203 2 137 255 215 2 203 2 141 255 215 2 203 2 178 255 215 2 203 2 180 255 215 2 203 2 192 255 215 2 203 2 194 255 215 2 203 2 198 255 215 2 203 2 200 255 215 2 203 2 213 255 215 2 203 2 224 255 215 2 203 2 240 255 215 2 203 2 242 255 215 2 203 2 244 255 215 2 203 2 254 255 215 2 203 3 10 255 215 2 203 3 12 255 215 2 203 3 22 255 215 2 203 3 26 255 215 2 204 0 5 255 195 2 204 0 10 255 195 2 204 1 163 0 102 2 204 1 188 255 215 2 204 1 190 255 215 2 204 1 193 255 174 2 204 1 220 255 195 2 204 1 225 255 215 2 204 1 228 255 195 2 204 2 7 255 195 2 204 2 11 255 195 2 204 2 109 255 236 2 204 2 124 255 174 2 204 2 128 255 215 2 204 2 129 255 236 2 204 2 130 255 215 2 204 2 131 255 236 2 204 2 139 255 236 2 204 2 170 255 195 2 204 2 181 255 215 2 204 2 182 255 195 2 204 2 183 255 215 2 204 2 184 255 236 2 204 2 185 255 215 2 204 2 186 255 236 2 204 2 190 255 195 2 204 2 191 255 174 2 204 2 192 255 215 2 204 2 193 255 174 2 204 2 194 255 215 2 204 2 197 255 195 2 204 2 198 255 215 2 204 2 199 255 195 2 204 2 200 255 215 2 204 2 212 255 174 2 204 2 213 255 215 2 204 2 253 255 174 2 204 2 254 255 215 2 204 3 13 255 215 2 204 3 14 255 195 2 204 3 15 255 215 2 204 3 16 255 195 2 204 3 24 255 195 2 205 1 225 255 215 2 205 2 192 255 215 2 205 2 194 255 215 2 205 2 213 255 215 2 205 2 254 255 215 2 206 1 163 0 225 2 206 2 234 0 41 2 206 3 14 255 215 2 206 3 16 255 215 2 207 0 5 255 236 2 207 0 10 255 236 2 207 2 7 255 236 2 207 2 11 255 236 2 210 1 163 0 225 2 210 2 234 0 41 2 210 3 14 255 215 2 210 3 16 255 215 2 211 0 5 255 236 2 211 0 10 255 236 2 211 2 7 255 236 2 211 2 11 255 236 2 214 1 163 0 225 2 214 2 234 0 41 2 214 3 14 255 215 2 214 3 16 255 215 2 215 0 5 255 236 2 215 0 10 255 236 2 215 2 7 255 236 2 215 2 11 255 236 2 217 0 5 255 113 2 217 0 10 255 113 2 217 1 157 255 154 2 217 1 166 255 154 2 217 1 188 255 113 2 217 1 190 255 215 2 217 1 193 255 154 2 217 1 196 255 154 2 217 1 220 255 215 2 217 1 225 255 215 2 217 1 228 255 215 2 217 2 7 255 113 2 217 2 11 255 113 2 217 2 110 255 215 2 217 2 124 255 154 2 217 2 128 255 174 2 217 2 130 255 174 2 217 2 151 255 215 2 217 2 155 255 215 2 217 2 167 255 215 2 217 2 169 255 154 2 217 2 170 255 215 2 217 2 181 255 113 2 217 2 182 255 215 2 217 2 183 255 133 2 217 2 185 255 133 2 217 2 189 255 154 2 217 2 190 255 215 2 217 2 191 255 154 2 217 2 192 255 215 2 217 2 193 255 154 2 217 2 194 255 215 2 217 2 197 255 154 2 217 2 199 255 154 2 217 2 212 255 154 2 217 2 213 255 215 2 217 2 225 255 215 2 217 2 227 255 215 2 217 2 253 255 154 2 217 2 254 255 215 2 217 3 3 255 215 2 217 3 13 255 113 2 217 3 14 255 215 2 217 3 15 255 113 2 217 3 16 255 215 2 217 3 23 255 154 2 217 3 24 255 215 2 218 0 5 255 236 2 218 0 10 255 236 2 218 2 7 255 236 2 218 2 11 255 236 2 219 0 5 255 113 2 219 0 10 255 113 2 219 1 157 255 154 2 219 1 166 255 154 2 219 1 188 255 113 2 219 1 190 255 215 2 219 1 193 255 154 2 219 1 196 255 154 2 219 1 220 255 215 2 219 1 225 255 215 2 219 1 228 255 215 2 219 2 7 255 113 2 219 2 11 255 113 2 219 2 110 255 215 2 219 2 124 255 154 2 219 2 128 255 174 2 219 2 130 255 174 2 219 2 151 255 215 2 219 2 155 255 215 2 219 2 167 255 215 2 219 2 169 255 154 2 219 2 170 255 215 2 219 2 181 255 113 2 219 2 182 255 215 2 219 2 183 255 133 2 219 2 185 255 133 2 219 2 189 255 154 2 219 2 190 255 215 2 219 2 191 255 154 2 219 2 192 255 215 2 219 2 193 255 154 2 219 2 194 255 215 2 219 2 197 255 154 2 219 2 199 255 154 2 219 2 212 255 154 2 219 2 213 255 215 2 219 2 225 255 215 2 219 2 227 255 215 2 219 2 253 255 154 2 219 2 254 255 215 2 219 3 3 255 215 2 219 3 13 255 113 2 219 3 14 255 215 2 219 3 15 255 113 2 219 3 16 255 215 2 219 3 23 255 154 2 219 3 24 255 215 2 220 0 5 255 236 2 220 0 10 255 236 2 220 2 7 255 236 2 220 2 11 255 236 2 222 0 5 255 236 2 222 0 10 255 236 2 222 2 7 255 236 2 222 2 11 255 236 2 224 0 5 255 236 2 224 0 10 255 236 2 224 2 7 255 236 2 224 2 11 255 236 2 225 0 15 255 174 2 225 0 17 255 174 2 225 1 157 255 236 2 225 1 164 255 215 2 225 1 166 255 236 2 225 1 168 255 215 2 225 1 170 255 215 2 225 1 174 255 215 2 225 1 176 255 215 2 225 1 177 255 236 2 225 1 181 255 215 2 225 1 188 255 195 2 225 1 189 255 215 2 225 1 191 255 215 2 225 1 193 255 215 2 225 1 196 255 236 2 225 1 199 255 236 2 225 1 206 255 236 2 225 1 213 255 236 2 225 1 242 255 236 2 225 2 8 255 174 2 225 2 12 255 174 2 225 2 114 255 215 2 225 2 115 255 236 2 225 2 122 255 236 2 225 2 124 255 215 2 225 2 128 255 236 2 225 2 130 255 236 2 225 2 159 255 215 2 225 2 161 255 236 2 225 2 169 255 236 2 225 2 181 255 195 2 225 2 183 255 236 2 225 2 185 255 236 2 225 2 187 255 215 2 225 2 189 255 236 2 225 2 191 255 215 2 225 2 193 255 215 2 225 2 202 255 215 2 225 2 206 255 215 2 225 2 207 255 236 2 225 2 212 255 215 2 225 2 217 255 215 2 225 2 219 255 215 2 225 2 221 255 215 2 225 2 229 255 215 2 225 2 231 255 236 2 225 2 245 255 236 2 225 2 247 255 215 2 225 2 249 255 215 2 225 2 251 255 215 2 225 2 253 255 215 2 225 3 5 255 215 2 225 3 7 255 215 2 225 3 13 255 215 2 225 3 15 255 215 2 225 3 17 255 215 2 225 3 18 255 236 2 225 3 23 255 236 2 225 3 27 255 215 2 225 3 28 255 236 2 226 0 5 255 236 2 226 0 10 255 236 2 226 1 208 255 215 2 226 1 220 255 236 2 226 1 221 255 236 2 226 1 223 255 215 2 226 1 225 255 236 2 226 1 228 255 236 2 226 1 246 255 236 2 226 2 7 255 236 2 226 2 11 255 236 2 226 2 160 255 215 2 226 2 170 255 236 2 226 2 182 255 236 2 226 2 188 255 215 2 226 2 190 255 236 2 226 2 192 255 236 2 226 2 194 255 236 2 226 2 203 255 215 2 226 2 213 255 236 2 226 2 230 255 215 2 226 2 248 255 236 2 226 2 250 255 236 2 226 2 252 255 236 2 226 2 254 255 236 2 226 3 6 255 215 2 226 3 8 255 215 2 226 3 14 255 236 2 226 3 16 255 236 2 226 3 24 255 236 2 227 0 15 255 174 2 227 0 17 255 174 2 227 1 157 255 236 2 227 1 164 255 215 2 227 1 166 255 236 2 227 1 168 255 215 2 227 1 170 255 215 2 227 1 174 255 215 2 227 1 176 255 215 2 227 1 177 255 236 2 227 1 181 255 215 2 227 1 188 255 195 2 227 1 189 255 215 2 227 1 191 255 215 2 227 1 193 255 215 2 227 1 196 255 236 2 227 1 199 255 236 2 227 1 206 255 236 2 227 1 213 255 236 2 227 1 242 255 236 2 227 2 8 255 174 2 227 2 12 255 174 2 227 2 114 255 215 2 227 2 115 255 236 2 227 2 122 255 236 2 227 2 124 255 215 2 227 2 128 255 236 2 227 2 130 255 236 2 227 2 159 255 215 2 227 2 161 255 236 2 227 2 169 255 236 2 227 2 181 255 195 2 227 2 183 255 236 2 227 2 185 255 236 2 227 2 187 255 215 2 227 2 189 255 236 2 227 2 191 255 215 2 227 2 193 255 215 2 227 2 202 255 215 2 227 2 206 255 215 2 227 2 207 255 236 2 227 2 212 255 215 2 227 2 217 255 215 2 227 2 219 255 215 2 227 2 221 255 215 2 227 2 229 255 215 2 227 2 231 255 236 2 227 2 245 255 236 2 227 2 247 255 215 2 227 2 249 255 215 2 227 2 251 255 215 2 227 2 253 255 215 2 227 3 5 255 215 2 227 3 7 255 215 2 227 3 13 255 215 2 227 3 15 255 215 2 227 3 17 255 215 2 227 3 18 255 236 2 227 3 23 255 236 2 227 3 27 255 215 2 227 3 28 255 236 2 228 0 5 255 236 2 228 0 10 255 236 2 228 1 208 255 215 2 228 1 220 255 236 2 228 1 221 255 236 2 228 1 223 255 215 2 228 1 225 255 236 2 228 1 228 255 236 2 228 1 246 255 236 2 228 2 7 255 236 2 228 2 11 255 236 2 228 2 160 255 215 2 228 2 170 255 236 2 228 2 182 255 236 2 228 2 188 255 215 2 228 2 190 255 236 2 228 2 192 255 236 2 228 2 194 255 236 2 228 2 203 255 215 2 228 2 213 255 236 2 228 2 230 255 215 2 228 2 248 255 236 2 228 2 250 255 236 2 228 2 252 255 236 2 228 2 254 255 236 2 228 3 6 255 215 2 228 3 8 255 215 2 228 3 14 255 236 2 228 3 16 255 236 2 228 3 24 255 236 2 229 1 159 255 215 2 229 1 184 255 215 2 229 1 187 255 215 2 229 1 190 255 215 2 229 1 193 255 215 2 229 1 225 255 215 2 229 2 108 255 215 2 229 2 124 255 215 2 229 2 126 255 215 2 229 2 132 255 215 2 229 2 134 255 215 2 229 2 136 255 215 2 229 2 138 255 215 2 229 2 140 255 215 2 229 2 177 255 215 2 229 2 179 255 215 2 229 2 191 255 215 2 229 2 192 255 215 2 229 2 193 255 215 2 229 2 194 255 215 2 229 2 197 255 154 2 229 2 199 255 154 2 229 2 212 255 215 2 229 2 213 255 215 2 229 2 239 255 215 2 229 2 241 255 215 2 229 2 243 255 215 2 229 2 253 255 215 2 229 2 254 255 215 2 229 3 9 255 215 2 229 3 11 255 215 2 229 3 14 255 215 2 229 3 16 255 215 2 229 3 21 255 215 2 229 3 25 255 236 2 230 1 207 255 215 2 230 1 216 255 215 2 230 1 219 255 215 2 230 1 222 255 215 2 230 1 225 255 215 2 230 1 234 255 215 2 230 1 237 255 215 2 230 2 106 255 215 2 230 2 127 255 215 2 230 2 133 255 215 2 230 2 135 255 215 2 230 2 137 255 215 2 230 2 141 255 215 2 230 2 178 255 215 2 230 2 180 255 215 2 230 2 192 255 215 2 230 2 194 255 215 2 230 2 198 255 215 2 230 2 200 255 215 2 230 2 213 255 215 2 230 2 224 255 215 2 230 2 240 255 215 2 230 2 242 255 215 2 230 2 244 255 215 2 230 2 254 255 215 2 230 3 10 255 215 2 230 3 12 255 215 2 230 3 22 255 215 2 230 3 26 255 215 2 231 0 15 255 174 2 231 0 17 255 174 2 231 2 8 255 174 2 231 2 12 255 174 2 231 2 128 255 236 2 231 2 130 255 236 2 231 2 183 255 236 2 231 2 185 255 236 2 231 3 13 255 215 2 231 3 15 255 215 2 232 1 233 0 41 2 233 0 5 255 236 2 233 0 10 255 236 2 233 2 7 255 236 2 233 2 11 255 236 2 233 3 14 255 215 2 233 3 16 255 215 2 239 0 15 255 174 2 239 0 17 255 174 2 239 1 157 255 236 2 239 1 164 255 215 2 239 1 166 255 236 2 239 1 168 255 215 2 239 1 170 255 215 2 239 1 174 255 215 2 239 1 176 255 215 2 239 1 177 255 236 2 239 1 181 255 215 2 239 1 188 255 195 2 239 1 189 255 215 2 239 1 191 255 215 2 239 1 193 255 215 2 239 1 196 255 236 2 239 1 199 255 236 2 239 1 206 255 236 2 239 1 213 255 236 2 239 1 242 255 236 2 239 2 8 255 174 2 239 2 12 255 174 2 239 2 114 255 215 2 239 2 115 255 236 2 239 2 122 255 236 2 239 2 124 255 215 2 239 2 128 255 236 2 239 2 130 255 236 2 239 2 159 255 215 2 239 2 161 255 236 2 239 2 169 255 236 2 239 2 181 255 195 2 239 2 183 255 236 2 239 2 185 255 236 2 239 2 187 255 215 2 239 2 189 255 236 2 239 2 191 255 215 2 239 2 193 255 215 2 239 2 202 255 215 2 239 2 206 255 215 2 239 2 207 255 236 2 239 2 212 255 215 2 239 2 217 255 215 2 239 2 219 255 215 2 239 2 221 255 215 2 239 2 229 255 215 2 239 2 231 255 236 2 239 2 245 255 236 2 239 2 247 255 215 2 239 2 249 255 215 2 239 2 251 255 215 2 239 2 253 255 215 2 239 3 5 255 215 2 239 3 7 255 215 2 239 3 13 255 215 2 239 3 15 255 215 2 239 3 17 255 215 2 239 3 18 255 236 2 239 3 23 255 236 2 239 3 27 255 215 2 239 3 28 255 236 2 240 0 5 255 236 2 240 0 10 255 236 2 240 1 208 255 215 2 240 1 220 255 236 2 240 1 221 255 236 2 240 1 223 255 215 2 240 1 225 255 236 2 240 1 228 255 236 2 240 1 246 255 236 2 240 2 7 255 236 2 240 2 11 255 236 2 240 2 160 255 215 2 240 2 170 255 236 2 240 2 182 255 236 2 240 2 188 255 215 2 240 2 190 255 236 2 240 2 192 255 236 2 240 2 194 255 236 2 240 2 203 255 215 2 240 2 213 255 236 2 240 2 230 255 215 2 240 2 248 255 236 2 240 2 250 255 236 2 240 2 252 255 236 2 240 2 254 255 236 2 240 3 6 255 215 2 240 3 8 255 215 2 240 3 14 255 236 2 240 3 16 255 236 2 240 3 24 255 236 2 241 0 15 255 174 2 241 0 17 255 174 2 241 1 157 255 236 2 241 1 164 255 215 2 241 1 166 255 236 2 241 1 168 255 215 2 241 1 170 255 215 2 241 1 174 255 215 2 241 1 176 255 215 2 241 1 177 255 236 2 241 1 181 255 215 2 241 1 188 255 195 2 241 1 189 255 215 2 241 1 191 255 215 2 241 1 193 255 215 2 241 1 196 255 236 2 241 1 199 255 236 2 241 1 206 255 236 2 241 1 213 255 236 2 241 1 242 255 236 2 241 2 8 255 174 2 241 2 12 255 174 2 241 2 114 255 215 2 241 2 115 255 236 2 241 2 122 255 236 2 241 2 124 255 215 2 241 2 128 255 236 2 241 2 130 255 236 2 241 2 159 255 215 2 241 2 161 255 236 2 241 2 169 255 236 2 241 2 181 255 195 2 241 2 183 255 236 2 241 2 185 255 236 2 241 2 187 255 215 2 241 2 189 255 236 2 241 2 191 255 215 2 241 2 193 255 215 2 241 2 202 255 215 2 241 2 206 255 215 2 241 2 207 255 236 2 241 2 212 255 215 2 241 2 217 255 215 2 241 2 219 255 215 2 241 2 221 255 215 2 241 2 229 255 215 2 241 2 231 255 236 2 241 2 245 255 236 2 241 2 247 255 215 2 241 2 249 255 215 2 241 2 251 255 215 2 241 2 253 255 215 2 241 3 5 255 215 2 241 3 7 255 215 2 241 3 13 255 215 2 241 3 15 255 215 2 241 3 17 255 215 2 241 3 18 255 236 2 241 3 23 255 236 2 241 3 27 255 215 2 241 3 28 255 236 2 242 0 5 255 236 2 242 0 10 255 236 2 242 1 208 255 215 2 242 1 220 255 236 2 242 1 221 255 236 2 242 1 223 255 215 2 242 1 225 255 236 2 242 1 228 255 236 2 242 1 246 255 236 2 242 2 7 255 236 2 242 2 11 255 236 2 242 2 160 255 215 2 242 2 170 255 236 2 242 2 182 255 236 2 242 2 188 255 215 2 242 2 190 255 236 2 242 2 192 255 236 2 242 2 194 255 236 2 242 2 203 255 215 2 242 2 213 255 236 2 242 2 230 255 215 2 242 2 248 255 236 2 242 2 250 255 236 2 242 2 252 255 236 2 242 2 254 255 236 2 242 3 6 255 215 2 242 3 8 255 215 2 242 3 14 255 236 2 242 3 16 255 236 2 242 3 24 255 236 2 243 0 15 255 174 2 243 0 17 255 174 2 243 1 157 255 236 2 243 1 164 255 215 2 243 1 166 255 236 2 243 1 168 255 215 2 243 1 170 255 215 2 243 1 174 255 215 2 243 1 176 255 215 2 243 1 177 255 236 2 243 1 181 255 215 2 243 1 188 255 195 2 243 1 189 255 215 2 243 1 191 255 215 2 243 1 193 255 215 2 243 1 196 255 236 2 243 1 199 255 236 2 243 1 206 255 236 2 243 1 213 255 236 2 243 1 242 255 236 2 243 2 8 255 174 2 243 2 12 255 174 2 243 2 114 255 215 2 243 2 115 255 236 2 243 2 122 255 236 2 243 2 124 255 215 2 243 2 128 255 236 2 243 2 130 255 236 2 243 2 159 255 215 2 243 2 161 255 236 2 243 2 169 255 236 2 243 2 181 255 195 2 243 2 183 255 236 2 243 2 185 255 236 2 243 2 187 255 215 2 243 2 189 255 236 2 243 2 191 255 215 2 243 2 193 255 215 2 243 2 202 255 215 2 243 2 206 255 215 2 243 2 207 255 236 2 243 2 212 255 215 2 243 2 217 255 215 2 243 2 219 255 215 2 243 2 221 255 215 2 243 2 229 255 215 2 243 2 231 255 236 2 243 2 245 255 236 2 243 2 247 255 215 2 243 2 249 255 215 2 243 2 251 255 215 2 243 2 253 255 215 2 243 3 5 255 215 2 243 3 7 255 215 2 243 3 13 255 215 2 243 3 15 255 215 2 243 3 17 255 215 2 243 3 18 255 236 2 243 3 23 255 236 2 243 3 27 255 215 2 243 3 28 255 236 2 244 0 5 255 236 2 244 0 10 255 236 2 244 1 208 255 215 2 244 1 220 255 236 2 244 1 221 255 236 2 244 1 223 255 215 2 244 1 225 255 236 2 244 1 228 255 236 2 244 1 246 255 236 2 244 2 7 255 236 2 244 2 11 255 236 2 244 2 160 255 215 2 244 2 170 255 236 2 244 2 182 255 236 2 244 2 188 255 215 2 244 2 190 255 236 2 244 2 192 255 236 2 244 2 194 255 236 2 244 2 203 255 215 2 244 2 213 255 236 2 244 2 230 255 215 2 244 2 248 255 236 2 244 2 250 255 236 2 244 2 252 255 236 2 244 2 254 255 236 2 244 3 6 255 215 2 244 3 8 255 215 2 244 3 14 255 236 2 244 3 16 255 236 2 244 3 24 255 236 2 245 0 15 255 174 2 245 0 17 255 174 2 245 1 157 255 236 2 245 1 164 255 215 2 245 1 166 255 236 2 245 1 168 255 215 2 245 1 170 255 215 2 245 1 174 255 215 2 245 1 176 255 215 2 245 1 177 255 236 2 245 1 181 255 215 2 245 1 188 255 195 2 245 1 189 255 215 2 245 1 191 255 215 2 245 1 193 255 215 2 245 1 196 255 236 2 245 1 199 255 236 2 245 1 206 255 236 2 245 1 213 255 236 2 245 1 242 255 236 2 245 2 8 255 174 2 245 2 12 255 174 2 245 2 114 255 215 2 245 2 115 255 236 2 245 2 122 255 236 2 245 2 124 255 215 2 245 2 128 255 236 2 245 2 130 255 236 2 245 2 159 255 215 2 245 2 161 255 236 2 245 2 169 255 236 2 245 2 181 255 195 2 245 2 183 255 236 2 245 2 185 255 236 2 245 2 187 255 215 2 245 2 189 255 236 2 245 2 191 255 215 2 245 2 193 255 215 2 245 2 202 255 215 2 245 2 206 255 215 2 245 2 207 255 236 2 245 2 212 255 215 2 245 2 217 255 215 2 245 2 219 255 215 2 245 2 221 255 215 2 245 2 229 255 215 2 245 2 231 255 236 2 245 2 245 255 236 2 245 2 247 255 215 2 245 2 249 255 215 2 245 2 251 255 215 2 245 2 253 255 215 2 245 3 5 255 215 2 245 3 7 255 215 2 245 3 13 255 215 2 245 3 15 255 215 2 245 3 17 255 215 2 245 3 18 255 236 2 245 3 23 255 236 2 245 3 27 255 215 2 245 3 28 255 236 2 246 0 5 255 236 2 246 0 10 255 236 2 246 1 208 255 215 2 246 1 220 255 236 2 246 1 221 255 236 2 246 1 223 255 215 2 246 1 225 255 236 2 246 1 228 255 236 2 246 1 246 255 236 2 246 2 7 255 236 2 246 2 11 255 236 2 246 2 160 255 215 2 246 2 170 255 236 2 246 2 182 255 236 2 246 2 188 255 215 2 246 2 190 255 236 2 246 2 192 255 236 2 246 2 194 255 236 2 246 2 203 255 215 2 246 2 213 255 236 2 246 2 230 255 215 2 246 2 248 255 236 2 246 2 250 255 236 2 246 2 252 255 236 2 246 2 254 255 236 2 246 3 6 255 215 2 246 3 8 255 215 2 246 3 14 255 236 2 246 3 16 255 236 2 246 3 24 255 236 2 247 0 15 255 133 2 247 0 17 255 133 2 247 1 159 255 236 2 247 1 164 255 154 2 247 1 170 255 113 2 247 1 174 255 154 2 247 1 181 255 154 2 247 1 184 255 236 2 247 1 187 255 236 2 247 1 190 255 195 2 247 1 201 255 236 2 247 1 206 255 174 2 247 1 207 255 215 2 247 1 213 255 174 2 247 1 216 255 215 2 247 1 219 255 215 2 247 1 222 255 215 2 247 1 225 255 215 2 247 1 234 255 215 2 247 1 235 0 102 2 247 1 237 255 215 2 247 1 238 255 236 2 247 1 242 255 174 2 247 1 244 0 102 2 247 2 8 255 133 2 247 2 12 255 133 2 247 2 106 255 215 2 247 2 108 255 236 2 247 2 114 255 113 2 247 2 115 255 174 2 247 2 126 255 236 2 247 2 127 255 215 2 247 2 132 255 236 2 247 2 133 255 215 2 247 2 134 255 236 2 247 2 135 255 215 2 247 2 136 255 236 2 247 2 137 255 215 2 247 2 138 255 236 2 247 2 140 255 236 2 247 2 141 255 215 2 247 2 152 0 102 2 247 2 168 0 102 2 247 2 177 255 236 2 247 2 178 255 215 2 247 2 179 255 236 2 247 2 180 255 215 2 247 2 192 255 215 2 247 2 194 255 215 2 247 2 197 255 215 2 247 2 198 255 195 2 247 2 199 255 215 2 247 2 200 255 195 2 247 2 206 255 154 2 247 2 207 255 174 2 247 2 213 255 215 2 247 2 217 255 113 2 247 2 219 255 113 2 247 2 221 255 113 2 247 2 224 255 215 2 247 2 239 255 236 2 247 2 240 255 215 2 247 2 241 255 236 2 247 2 242 255 215 2 247 2 243 255 236 2 247 2 244 255 215 2 247 2 254 255 215 2 247 3 9 255 113 2 247 3 10 255 215 2 247 3 11 255 113 2 247 3 12 255 215 2 247 3 17 255 154 2 247 3 18 255 174 2 247 3 21 255 236 2 247 3 22 255 215 2 247 3 26 255 215 2 247 3 27 255 154 2 247 3 28 255 174 2 248 0 15 255 174 2 248 0 17 255 174 2 248 1 206 255 215 2 248 1 213 255 215 2 248 1 242 255 215 2 248 2 8 255 174 2 248 2 12 255 174 2 248 2 115 255 215 2 248 2 207 255 215 2 248 3 18 255 215 2 248 3 28 255 215 2 249 0 15 255 133 2 249 0 17 255 133 2 249 1 159 255 236 2 249 1 164 255 154 2 249 1 170 255 113 2 249 1 174 255 154 2 249 1 181 255 154 2 249 1 184 255 236 2 249 1 187 255 236 2 249 1 190 255 195 2 249 1 201 255 236 2 249 1 206 255 174 2 249 1 207 255 215 2 249 1 213 255 174 2 249 1 216 255 215 2 249 1 219 255 215 2 249 1 222 255 215 2 249 1 225 255 215 2 249 1 234 255 215 2 249 1 235 0 102 2 249 1 237 255 215 2 249 1 238 255 236 2 249 1 242 255 174 2 249 1 244 0 102 2 249 2 8 255 133 2 249 2 12 255 133 2 249 2 106 255 215 2 249 2 108 255 236 2 249 2 114 255 113 2 249 2 115 255 174 2 249 2 126 255 236 2 249 2 127 255 215 2 249 2 132 255 236 2 249 2 133 255 215 2 249 2 134 255 236 2 249 2 135 255 215 2 249 2 136 255 236 2 249 2 137 255 215 2 249 2 138 255 236 2 249 2 140 255 236 2 249 2 141 255 215 2 249 2 152 0 102 2 249 2 168 0 102 2 249 2 177 255 236 2 249 2 178 255 215 2 249 2 179 255 236 2 249 2 180 255 215 2 249 2 192 255 215 2 249 2 194 255 215 2 249 2 197 255 215 2 249 2 198 255 195 2 249 2 199 255 215 2 249 2 200 255 195 2 249 2 206 255 154 2 249 2 207 255 174 2 249 2 213 255 215 2 249 2 217 255 113 2 249 2 219 255 113 2 249 2 221 255 113 2 249 2 224 255 215 2 249 2 239 255 236 2 249 2 240 255 215 2 249 2 241 255 236 2 249 2 242 255 215 2 249 2 243 255 236 2 249 2 244 255 215 2 249 2 254 255 215 2 249 3 9 255 113 2 249 3 10 255 215 2 249 3 11 255 113 2 249 3 12 255 215 2 249 3 17 255 154 2 249 3 18 255 174 2 249 3 21 255 236 2 249 3 22 255 215 2 249 3 26 255 215 2 249 3 27 255 154 2 249 3 28 255 174 2 250 0 15 255 174 2 250 0 17 255 174 2 250 1 206 255 215 2 250 1 213 255 215 2 250 1 242 255 215 2 250 2 8 255 174 2 250 2 12 255 174 2 250 2 115 255 215 2 250 2 207 255 215 2 250 3 18 255 215 2 250 3 28 255 215 2 251 0 15 255 133 2 251 0 17 255 133 2 251 1 159 255 236 2 251 1 164 255 154 2 251 1 170 255 113 2 251 1 174 255 154 2 251 1 181 255 154 2 251 1 184 255 236 2 251 1 187 255 236 2 251 1 190 255 195 2 251 1 201 255 236 2 251 1 206 255 174 2 251 1 207 255 215 2 251 1 213 255 174 2 251 1 216 255 215 2 251 1 219 255 215 2 251 1 222 255 215 2 251 1 225 255 215 2 251 1 234 255 215 2 251 1 235 0 102 2 251 1 237 255 215 2 251 1 238 255 236 2 251 1 242 255 174 2 251 1 244 0 102 2 251 2 8 255 133 2 251 2 12 255 133 2 251 2 106 255 215 2 251 2 108 255 236 2 251 2 114 255 113 2 251 2 115 255 174 2 251 2 126 255 236 2 251 2 127 255 215 2 251 2 132 255 236 2 251 2 133 255 215 2 251 2 134 255 236 2 251 2 135 255 215 2 251 2 136 255 236 2 251 2 137 255 215 2 251 2 138 255 236 2 251 2 140 255 236 2 251 2 141 255 215 2 251 2 152 0 102 2 251 2 168 0 102 2 251 2 177 255 236 2 251 2 178 255 215 2 251 2 179 255 236 2 251 2 180 255 215 2 251 2 192 255 215 2 251 2 194 255 215 2 251 2 197 255 215 2 251 2 198 255 195 2 251 2 199 255 215 2 251 2 200 255 195 2 251 2 206 255 154 2 251 2 207 255 174 2 251 2 213 255 215 2 251 2 217 255 113 2 251 2 219 255 113 2 251 2 221 255 113 2 251 2 224 255 215 2 251 2 239 255 236 2 251 2 240 255 215 2 251 2 241 255 236 2 251 2 242 255 215 2 251 2 243 255 236 2 251 2 244 255 215 2 251 2 254 255 215 2 251 3 9 255 113 2 251 3 10 255 215 2 251 3 11 255 113 2 251 3 12 255 215 2 251 3 17 255 154 2 251 3 18 255 174 2 251 3 21 255 236 2 251 3 22 255 215 2 251 3 26 255 215 2 251 3 27 255 154 2 251 3 28 255 174 2 252 0 15 255 174 2 252 0 17 255 174 2 252 1 206 255 215 2 252 1 213 255 215 2 252 1 242 255 215 2 252 2 8 255 174 2 252 2 12 255 174 2 252 2 115 255 215 2 252 2 207 255 215 2 252 3 18 255 215 2 252 3 28 255 215 2 255 0 15 255 133 2 255 0 16 255 174 2 255 0 17 255 133 2 255 1 159 255 215 2 255 1 164 255 154 2 255 1 170 255 113 2 255 1 174 255 154 2 255 1 181 255 154 2 255 1 184 255 215 2 255 1 187 255 215 2 255 1 188 0 41 2 255 1 190 255 174 2 255 1 204 255 154 2 255 1 205 255 154 2 255 1 206 255 133 2 255 1 207 255 113 2 255 1 208 255 215 2 255 1 209 255 215 2 255 1 210 255 154 2 255 1 211 255 154 2 255 1 212 255 154 2 255 1 213 255 133 2 255 1 214 255 154 2 255 1 215 255 154 2 255 1 216 255 113 2 255 1 217 255 154 2 255 1 218 255 154 2 255 1 219 255 113 2 255 1 220 255 174 2 255 1 221 255 174 2 255 1 222 255 113 2 255 1 223 255 215 2 255 1 224 255 154 2 255 1 225 255 154 2 255 1 226 255 154 2 255 1 227 255 154 2 255 1 228 255 174 2 255 1 229 255 154 2 255 1 230 255 154 2 255 1 231 255 215 2 255 1 232 255 154 2 255 1 233 255 195 2 255 1 234 255 113 2 255 1 236 255 154 2 255 1 237 255 113 2 255 1 238 255 133 2 255 1 242 255 133 2 255 1 243 255 154 2 255 1 245 255 154 2 255 1 246 255 174 2 255 1 247 255 154 2 255 1 249 255 154 2 255 2 2 255 174 2 255 2 3 255 174 2 255 2 4 255 174 2 255 2 8 255 133 2 255 2 12 255 133 2 255 2 106 255 113 2 255 2 107 255 154 2 255 2 108 255 215 2 255 2 109 255 215 2 255 2 113 255 154 2 255 2 114 255 113 2 255 2 115 255 133 2 255 2 117 255 154 2 255 2 119 255 154 2 255 2 121 255 154 2 255 2 125 255 154 2 255 2 126 255 215 2 255 2 127 255 113 2 255 2 129 255 215 2 255 2 131 255 215 2 255 2 132 255 215 2 255 2 133 255 113 2 255 2 134 255 215 2 255 2 135 255 113 2 255 2 136 255 215 2 255 2 137 255 113 2 255 2 138 255 215 2 255 2 139 255 215 2 255 2 140 255 215 2 255 2 141 255 113 2 255 2 150 255 154 2 255 2 154 255 154 2 255 2 158 255 154 2 255 2 160 255 215 2 255 2 162 255 215 2 255 2 164 255 154 2 255 2 166 255 154 2 255 2 170 255 174 2 255 2 172 255 154 2 255 2 174 255 154 2 255 2 176 255 154 2 255 2 177 255 215 2 255 2 178 255 113 2 255 2 179 255 215 2 255 2 180 255 113 2 255 2 181 0 41 2 255 2 182 255 174 2 255 2 184 255 174 2 255 2 186 255 174 2 255 2 188 255 215 2 255 2 190 255 174 2 255 2 192 255 154 2 255 2 194 255 154 2 255 2 196 255 154 2 255 2 197 255 154 2 255 2 198 255 113 2 255 2 199 255 154 2 255 2 200 255 113 2 255 2 203 255 215 2 255 2 205 255 154 2 255 2 206 255 154 2 255 2 207 255 133 2 255 2 209 255 154 2 255 2 211 255 154 2 255 2 213 255 154 2 255 2 215 255 154 2 255 2 217 255 113 2 255 2 219 255 113 2 255 2 221 255 113 2 255 2 224 255 113 2 255 2 230 255 215 2 255 2 232 255 215 2 255 2 234 255 195 2 255 2 236 255 154 2 255 2 238 255 154 2 255 2 239 255 215 2 255 2 240 255 113 2 255 2 241 255 215 2 255 2 242 255 113 2 255 2 243 255 215 2 255 2 244 255 113 2 255 2 246 255 215 2 255 2 248 255 174 2 255 2 250 255 174 2 255 2 252 255 174 2 255 2 254 255 154 2 255 3 0 255 154 2 255 3 2 255 154 2 255 3 6 255 215 2 255 3 8 255 215 2 255 3 9 255 113 2 255 3 10 255 113 2 255 3 11 255 113 2 255 3 12 255 113 2 255 3 14 255 154 2 255 3 16 255 154 2 255 3 17 255 154 2 255 3 18 255 133 2 255 3 20 255 154 2 255 3 21 255 215 2 255 3 22 255 113 2 255 3 24 255 174 2 255 3 26 255 113 2 255 3 27 255 154 2 255 3 28 255 133 3 0 0 15 255 154 3 0 0 16 255 215 3 0 0 17 255 154 3 0 1 206 255 195 3 0 1 207 255 236 3 0 1 213 255 195 3 0 1 216 255 236 3 0 1 219 255 236 3 0 1 222 255 236 3 0 1 234 255 236 3 0 1 237 255 236 3 0 1 242 255 195 3 0 2 2 255 215 3 0 2 3 255 215 3 0 2 4 255 215 3 0 2 8 255 154 3 0 2 12 255 154 3 0 2 106 255 236 3 0 2 115 255 195 3 0 2 127 255 236 3 0 2 133 255 236 3 0 2 135 255 236 3 0 2 137 255 236 3 0 2 141 255 236 3 0 2 178 255 236 3 0 2 180 255 236 3 0 2 207 255 195 3 0 2 224 255 236 3 0 2 240 255 236 3 0 2 242 255 236 3 0 2 244 255 236 3 0 3 10 255 236 3 0 3 12 255 236 3 0 3 18 255 195 3 0 3 22 255 236 3 0 3 26 255 236 3 0 3 28 255 195 3 3 0 15 255 154 3 3 0 16 255 215 3 3 0 17 255 154 3 3 1 157 0 41 3 3 1 159 255 215 3 3 1 164 255 174 3 3 1 166 0 41 3 3 1 170 255 133 3 3 1 174 255 174 3 3 1 181 255 174 3 3 1 184 255 215 3 3 1 187 255 215 3 3 1 188 0 41 3 3 1 190 255 195 3 3 1 196 0 41 3 3 1 204 255 195 3 3 1 205 255 195 3 3 1 206 255 154 3 3 1 207 255 174 3 3 1 208 255 215 3 3 1 209 255 215 3 3 1 210 255 195 3 3 1 211 255 195 3 3 1 212 255 195 3 3 1 213 255 154 3 3 1 214 255 195 3 3 1 215 255 195 3 3 1 216 255 174 3 3 1 217 255 195 3 3 1 218 255 195 3 3 1 219 255 174 3 3 1 222 255 174 3 3 1 223 255 215 3 3 1 224 255 195 3 3 1 225 255 154 3 3 1 226 255 195 3 3 1 227 255 195 3 3 1 229 255 195 3 3 1 230 255 195 3 3 1 231 255 215 3 3 1 232 255 195 3 3 1 234 255 174 3 3 1 235 0 41 3 3 1 236 255 195 3 3 1 237 255 174 3 3 1 238 255 195 3 3 1 242 255 154 3 3 1 243 255 195 3 3 1 244 0 41 3 3 1 245 255 195 3 3 1 247 255 195 3 3 1 249 255 195 3 3 2 2 255 215 3 3 2 3 255 215 3 3 2 4 255 215 3 3 2 8 255 154 3 3 2 12 255 154 3 3 2 106 255 174 3 3 2 107 255 195 3 3 2 108 255 215 3 3 2 113 255 195 3 3 2 114 255 133 3 3 2 115 255 154 3 3 2 117 255 195 3 3 2 119 255 215 3 3 2 121 255 195 3 3 2 125 255 195 3 3 2 126 255 215 3 3 2 127 255 174 3 3 2 132 255 215 3 3 2 133 255 174 3 3 2 134 255 215 3 3 2 135 255 174 3 3 2 136 255 215 3 3 2 137 255 174 3 3 2 138 255 215 3 3 2 140 255 215 3 3 2 141 255 174 3 3 2 150 255 195 3 3 2 152 0 41 3 3 2 154 255 195 3 3 2 158 255 195 3 3 2 160 255 215 3 3 2 162 255 215 3 3 2 164 255 195 3 3 2 166 255 195 3 3 2 168 0 41 3 3 2 169 0 41 3 3 2 172 255 195 3 3 2 174 255 195 3 3 2 176 255 195 3 3 2 177 255 215 3 3 2 178 255 174 3 3 2 179 255 215 3 3 2 180 255 174 3 3 2 181 0 41 3 3 2 188 255 215 3 3 2 189 0 41 3 3 2 192 255 154 3 3 2 194 255 154 3 3 2 196 255 195 3 3 2 197 255 215 3 3 2 198 255 195 3 3 2 199 255 215 3 3 2 200 255 195 3 3 2 203 255 215 3 3 2 205 255 195 3 3 2 206 255 174 3 3 2 207 255 154 3 3 2 209 255 195 3 3 2 211 255 195 3 3 2 213 255 154 3 3 2 215 255 195 3 3 2 217 255 133 3 3 2 219 255 133 3 3 2 221 255 133 3 3 2 224 255 174 3 3 2 230 255 215 3 3 2 232 255 215 3 3 2 236 255 195 3 3 2 238 255 195 3 3 2 239 255 215 3 3 2 240 255 174 3 3 2 241 255 215 3 3 2 242 255 174 3 3 2 243 255 215 3 3 2 244 255 174 3 3 2 246 255 215 3 3 2 254 255 154 3 3 3 0 255 195 3 3 3 2 255 195 3 3 3 6 255 215 3 3 3 8 255 215 3 3 3 9 255 154 3 3 3 10 255 174 3 3 3 11 255 154 3 3 3 12 255 174 3 3 3 14 255 215 3 3 3 16 255 215 3 3 3 17 255 174 3 3 3 18 255 154 3 3 3 20 255 195 3 3 3 21 255 215 3 3 3 22 255 174 3 3 3 23 0 41 3 3 3 26 255 174 3 3 3 27 255 174 3 3 3 28 255 154 3 4 0 15 255 195 3 4 0 17 255 195 3 4 1 206 255 195 3 4 1 207 255 215 3 4 1 213 255 195 3 4 1 216 255 215 3 4 1 219 255 215 3 4 1 222 255 215 3 4 1 234 255 215 3 4 1 237 255 215 3 4 1 242 255 195 3 4 2 8 255 195 3 4 2 12 255 195 3 4 2 106 255 215 3 4 2 115 255 195 3 4 2 127 255 215 3 4 2 133 255 215 3 4 2 135 255 215 3 4 2 137 255 215 3 4 2 141 255 215 3 4 2 178 255 215 3 4 2 180 255 215 3 4 2 207 255 195 3 4 2 224 255 215 3 4 2 240 255 215 3 4 2 242 255 215 3 4 2 244 255 215 3 4 3 10 255 215 3 4 3 12 255 215 3 4 3 18 255 195 3 4 3 22 255 215 3 4 3 26 255 215 3 4 3 28 255 195 3 5 1 159 255 215 3 5 1 163 0 225 3 5 1 184 255 215 3 5 1 187 255 215 3 5 1 190 255 195 3 5 1 220 255 215 3 5 1 225 255 174 3 5 1 228 255 215 3 5 2 108 255 215 3 5 2 123 0 61 3 5 2 125 255 236 3 5 2 126 255 215 3 5 2 132 255 215 3 5 2 134 255 215 3 5 2 136 255 215 3 5 2 138 255 215 3 5 2 140 255 215 3 5 2 170 255 215 3 5 2 177 255 215 3 5 2 179 255 215 3 5 2 182 255 215 3 5 2 190 255 215 3 5 2 192 255 174 3 5 2 194 255 174 3 5 2 197 255 195 3 5 2 198 255 215 3 5 2 199 255 195 3 5 2 200 255 215 3 5 2 213 255 174 3 5 2 239 255 215 3 5 2 241 255 215 3 5 2 243 255 215 3 5 2 254 255 174 3 5 3 14 255 215 3 5 3 16 255 215 3 5 3 21 255 215 3 5 3 24 255 215 3 6 1 207 255 236 3 6 1 216 255 236 3 6 1 219 255 236 3 6 1 222 255 236 3 6 1 225 255 236 3 6 1 234 255 236 3 6 1 237 255 236 3 6 2 106 255 236 3 6 2 127 255 236 3 6 2 133 255 236 3 6 2 135 255 236 3 6 2 137 255 236 3 6 2 141 255 236 3 6 2 178 255 236 3 6 2 180 255 236 3 6 2 192 255 236 3 6 2 194 255 236 3 6 2 213 255 236 3 6 2 224 255 236 3 6 2 240 255 236 3 6 2 242 255 236 3 6 2 244 255 236 3 6 2 254 255 236 3 6 3 10 255 236 3 6 3 12 255 236 3 6 3 14 255 215 3 6 3 16 255 215 3 6 3 22 255 236 3 6 3 26 255 236 3 7 1 159 255 215 3 7 1 184 255 215 3 7 1 187 255 215 3 7 1 190 255 215 3 7 1 193 255 215 3 7 1 225 255 215 3 7 2 108 255 215 3 7 2 124 255 215 3 7 2 126 255 215 3 7 2 132 255 215 3 7 2 134 255 215 3 7 2 136 255 215 3 7 2 138 255 215 3 7 2 140 255 215 3 7 2 177 255 215 3 7 2 179 255 215 3 7 2 191 255 215 3 7 2 192 255 215 3 7 2 193 255 215 3 7 2 194 255 215 3 7 2 197 255 154 3 7 2 199 255 154 3 7 2 212 255 215 3 7 2 213 255 215 3 7 2 239 255 215 3 7 2 241 255 215 3 7 2 243 255 215 3 7 2 253 255 215 3 7 2 254 255 215 3 7 3 9 255 215 3 7 3 11 255 215 3 7 3 14 255 215 3 7 3 16 255 215 3 7 3 21 255 215 3 7 3 25 255 236 3 8 1 207 255 236 3 8 1 216 255 236 3 8 1 219 255 236 3 8 1 222 255 236 3 8 1 225 255 236 3 8 1 234 255 236 3 8 1 237 255 236 3 8 2 106 255 236 3 8 2 127 255 236 3 8 2 133 255 236 3 8 2 135 255 236 3 8 2 137 255 236 3 8 2 141 255 236 3 8 2 178 255 236 3 8 2 180 255 236 3 8 2 192 255 236 3 8 2 194 255 236 3 8 2 213 255 236 3 8 2 224 255 236 3 8 2 240 255 236 3 8 2 242 255 236 3 8 2 244 255 236 3 8 2 254 255 236 3 8 3 10 255 236 3 8 3 12 255 236 3 8 3 14 255 215 3 8 3 16 255 215 3 8 3 22 255 236 3 8 3 26 255 236 3 11 0 5 255 154 3 11 0 10 255 154 3 11 1 157 255 174 3 11 1 166 255 174 3 11 1 168 255 195 3 11 1 170 255 195 3 11 1 176 255 195 3 11 1 188 255 113 3 11 1 189 255 195 3 11 1 191 255 195 3 11 1 193 255 195 3 11 1 196 255 174 3 11 1 208 255 215 3 11 1 220 255 195 3 11 1 223 255 215 3 11 1 225 255 215 3 11 1 228 255 195 3 11 2 7 255 154 3 11 2 11 255 154 3 11 2 114 255 195 3 11 2 118 255 215 3 11 2 124 255 195 3 11 2 128 255 195 3 11 2 130 255 195 3 11 2 159 255 195 3 11 2 160 255 215 3 11 2 169 255 174 3 11 2 170 255 195 3 11 2 181 255 113 3 11 2 182 255 195 3 11 2 183 255 195 3 11 2 185 255 195 3 11 2 187 255 195 3 11 2 188 255 215 3 11 2 189 255 174 3 11 2 190 255 195 3 11 2 191 255 195 3 11 2 192 255 215 3 11 2 193 255 195 3 11 2 194 255 215 3 11 2 202 255 195 3 11 2 203 255 215 3 11 2 212 255 195 3 11 2 213 255 215 3 11 2 217 255 195 3 11 2 219 255 195 3 11 2 221 255 195 3 11 2 229 255 195 3 11 2 230 255 215 3 11 2 247 255 195 3 11 2 249 255 195 3 11 2 251 255 195 3 11 2 253 255 195 3 11 2 254 255 215 3 11 3 5 255 195 3 11 3 6 255 215 3 11 3 7 255 195 3 11 3 8 255 215 3 11 3 13 255 215 3 11 3 14 255 215 3 11 3 15 255 215 3 11 3 16 255 215 3 11 3 23 255 174 3 11 3 24 255 195 3 12 0 5 255 154 3 12 0 10 255 154 3 12 1 208 255 215 3 12 1 220 255 195 3 12 1 221 255 215 3 12 1 223 255 215 3 12 1 225 255 215 3 12 1 228 255 195 3 12 1 246 255 215 3 12 2 7 255 154 3 12 2 11 255 154 3 12 2 160 255 215 3 12 2 170 255 195 3 12 2 182 255 195 3 12 2 188 255 215 3 12 2 190 255 195 3 12 2 192 255 215 3 12 2 194 255 215 3 12 2 203 255 215 3 12 2 213 255 215 3 12 2 230 255 215 3 12 2 248 255 215 3 12 2 250 255 215 3 12 2 252 255 215 3 12 2 254 255 215 3 12 3 6 255 215 3 12 3 8 255 215 3 12 3 14 255 154 3 12 3 16 255 154 3 12 3 24 255 195 3 13 0 5 255 154 3 13 0 10 255 154 3 13 1 157 255 174 3 13 1 166 255 174 3 13 1 168 255 195 3 13 1 170 255 195 3 13 1 176 255 195 3 13 1 188 255 113 3 13 1 189 255 195 3 13 1 191 255 195 3 13 1 193 255 195 3 13 1 196 255 174 3 13 1 208 255 215 3 13 1 220 255 195 3 13 1 223 255 215 3 13 1 225 255 215 3 13 1 228 255 195 3 13 2 7 255 154 3 13 2 11 255 154 3 13 2 114 255 195 3 13 2 118 255 215 3 13 2 124 255 195 3 13 2 128 255 195 3 13 2 130 255 195 3 13 2 159 255 195 3 13 2 160 255 215 3 13 2 169 255 174 3 13 2 170 255 195 3 13 2 181 255 113 3 13 2 182 255 195 3 13 2 183 255 195 3 13 2 185 255 195 3 13 2 187 255 195 3 13 2 188 255 215 3 13 2 189 255 174 3 13 2 190 255 195 3 13 2 191 255 195 3 13 2 192 255 215 3 13 2 193 255 195 3 13 2 194 255 215 3 13 2 202 255 195 3 13 2 203 255 215 3 13 2 212 255 195 3 13 2 213 255 215 3 13 2 217 255 195 3 13 2 219 255 195 3 13 2 221 255 195 3 13 2 229 255 195 3 13 2 230 255 215 3 13 2 247 255 195 3 13 2 249 255 195 3 13 2 251 255 195 3 13 2 253 255 195 3 13 2 254 255 215 3 13 3 5 255 195 3 13 3 6 255 215 3 13 3 7 255 195 3 13 3 8 255 215 3 13 3 13 255 215 3 13 3 14 255 215 3 13 3 15 255 215 3 13 3 16 255 215 3 13 3 23 255 174 3 13 3 24 255 195 3 14 0 5 255 154 3 14 0 10 255 154 3 14 1 208 255 215 3 14 1 220 255 195 3 14 1 221 255 215 3 14 1 223 255 215 3 14 1 225 255 215 3 14 1 228 255 195 3 14 1 246 255 215 3 14 2 7 255 154 3 14 2 11 255 154 3 14 2 160 255 215 3 14 2 170 255 195 3 14 2 182 255 195 3 14 2 188 255 215 3 14 2 190 255 195 3 14 2 192 255 215 3 14 2 194 255 215 3 14 2 203 255 215 3 14 2 213 255 215 3 14 2 230 255 215 3 14 2 248 255 215 3 14 2 250 255 215 3 14 2 252 255 215 3 14 2 254 255 215 3 14 3 6 255 215 3 14 3 8 255 215 3 14 3 14 255 154 3 14 3 16 255 154 3 14 3 24 255 195 3 15 1 163 0 225 3 15 2 234 0 41 3 15 3 14 255 215 3 15 3 16 255 215 3 16 0 5 255 236 3 16 0 10 255 236 3 16 2 7 255 236 3 16 2 11 255 236 3 17 0 5 255 154 3 17 0 10 255 154 3 17 1 157 255 174 3 17 1 166 255 174 3 17 1 168 255 195 3 17 1 170 255 195 3 17 1 176 255 195 3 17 1 188 255 113 3 17 1 189 255 195 3 17 1 191 255 195 3 17 1 193 255 195 3 17 1 196 255 174 3 17 1 208 255 215 3 17 1 220 255 195 3 17 1 223 255 215 3 17 1 225 255 215 3 17 1 228 255 195 3 17 2 7 255 154 3 17 2 11 255 154 3 17 2 114 255 195 3 17 2 118 255 215 3 17 2 124 255 195 3 17 2 128 255 195 3 17 2 130 255 195 3 17 2 159 255 195 3 17 2 160 255 215 3 17 2 169 255 174 3 17 2 170 255 195 3 17 2 181 255 113 3 17 2 182 255 195 3 17 2 183 255 195 3 17 2 185 255 195 3 17 2 187 255 195 3 17 2 188 255 215 3 17 2 189 255 174 3 17 2 190 255 195 3 17 2 191 255 195 3 17 2 192 255 215 3 17 2 193 255 195 3 17 2 194 255 215 3 17 2 202 255 195 3 17 2 203 255 215 3 17 2 212 255 195 3 17 2 213 255 215 3 17 2 217 255 195 3 17 2 219 255 195 3 17 2 221 255 195 3 17 2 229 255 195 3 17 2 230 255 215 3 17 2 247 255 195 3 17 2 249 255 195 3 17 2 251 255 195 3 17 2 253 255 195 3 17 2 254 255 215 3 17 3 5 255 195 3 17 3 6 255 215 3 17 3 7 255 195 3 17 3 8 255 215 3 17 3 13 255 215 3 17 3 14 255 215 3 17 3 15 255 215 3 17 3 16 255 215 3 17 3 23 255 174 3 17 3 24 255 195 3 18 0 5 255 154 3 18 0 10 255 154 3 18 1 208 255 215 3 18 1 220 255 195 3 18 1 221 255 215 3 18 1 223 255 215 3 18 1 225 255 215 3 18 1 228 255 195 3 18 1 246 255 215 3 18 2 7 255 154 3 18 2 11 255 154 3 18 2 160 255 215 3 18 2 170 255 195 3 18 2 182 255 195 3 18 2 188 255 215 3 18 2 190 255 195 3 18 2 192 255 215 3 18 2 194 255 215 3 18 2 203 255 215 3 18 2 213 255 215 3 18 2 230 255 215 3 18 2 248 255 215 3 18 2 250 255 215 3 18 2 252 255 215 3 18 2 254 255 215 3 18 3 6 255 215 3 18 3 8 255 215 3 18 3 14 255 154 3 18 3 16 255 154 3 18 3 24 255 195 3 19 0 5 255 154 3 19 0 10 255 154 3 19 1 157 255 174 3 19 1 166 255 174 3 19 1 168 255 195 3 19 1 170 255 195 3 19 1 176 255 195 3 19 1 188 255 113 3 19 1 189 255 195 3 19 1 191 255 195 3 19 1 193 255 195 3 19 1 196 255 174 3 19 1 208 255 215 3 19 1 220 255 195 3 19 1 223 255 215 3 19 1 225 255 215 3 19 1 228 255 195 3 19 2 7 255 154 3 19 2 11 255 154 3 19 2 114 255 195 3 19 2 118 255 215 3 19 2 124 255 195 3 19 2 128 255 195 3 19 2 130 255 195 3 19 2 159 255 195 3 19 2 160 255 215 3 19 2 169 255 174 3 19 2 170 255 195 3 19 2 181 255 113 3 19 2 182 255 195 3 19 2 183 255 195 3 19 2 185 255 195 3 19 2 187 255 195 3 19 2 188 255 215 3 19 2 189 255 174 3 19 2 190 255 195 3 19 2 191 255 195 3 19 2 192 255 215 3 19 2 193 255 195 3 19 2 194 255 215 3 19 2 202 255 195 3 19 2 203 255 215 3 19 2 212 255 195 3 19 2 213 255 215 3 19 2 217 255 195 3 19 2 219 255 195 3 19 2 221 255 195 3 19 2 229 255 195 3 19 2 230 255 215 3 19 2 247 255 195 3 19 2 249 255 195 3 19 2 251 255 195 3 19 2 253 255 195 3 19 2 254 255 215 3 19 3 5 255 195 3 19 3 6 255 215 3 19 3 7 255 195 3 19 3 8 255 215 3 19 3 13 255 215 3 19 3 14 255 215 3 19 3 15 255 215 3 19 3 16 255 215 3 19 3 23 255 174 3 19 3 24 255 195 3 20 0 5 255 154 3 20 0 10 255 154 3 20 1 208 255 215 3 20 1 220 255 195 3 20 1 221 255 215 3 20 1 223 255 215 3 20 1 225 255 215 3 20 1 228 255 195 3 20 1 246 255 215 3 20 2 7 255 154 3 20 2 11 255 154 3 20 2 160 255 215 3 20 2 170 255 195 3 20 2 182 255 195 3 20 2 188 255 215 3 20 2 190 255 195 3 20 2 192 255 215 3 20 2 194 255 215 3 20 2 203 255 215 3 20 2 213 255 215 3 20 2 230 255 215 3 20 2 248 255 215 3 20 2 250 255 215 3 20 2 252 255 215 3 20 2 254 255 215 3 20 3 6 255 215 3 20 3 8 255 215 3 20 3 14 255 154 3 20 3 16 255 154 3 20 3 24 255 195 3 21 0 15 255 174 3 21 0 17 255 174 3 21 1 170 255 236 3 21 1 176 255 215 3 21 1 188 255 215 3 21 1 191 255 215 3 21 2 8 255 174 3 21 2 12 255 174 3 21 2 114 255 236 3 21 2 128 255 236 3 21 2 130 255 236 3 21 2 159 255 215 3 21 2 181 255 215 3 21 2 183 255 236 3 21 2 185 255 236 3 21 2 187 255 215 3 21 2 202 255 215 3 21 2 217 255 236 3 21 2 219 255 236 3 21 2 221 255 236 3 21 2 229 255 215 3 21 3 5 255 215 3 21 3 7 255 215 3 22 0 5 255 215 3 22 0 10 255 215 3 22 1 208 255 236 3 22 1 221 255 236 3 22 1 223 255 236 3 22 1 246 255 236 3 22 2 7 255 215 3 22 2 11 255 215 3 22 2 160 255 236 3 22 2 188 255 236 3 22 2 203 255 236 3 22 2 230 255 236 3 22 2 248 255 236 3 22 2 250 255 236 3 22 2 252 255 236 3 22 3 6 255 236 3 22 3 8 255 236 3 22 3 14 255 215 3 22 3 16 255 215 3 23 0 5 255 174 3 23 0 10 255 174 3 23 1 157 255 195 3 23 1 166 255 195 3 23 1 170 255 215 3 23 1 176 255 215 3 23 1 188 255 195 3 23 1 191 255 215 3 23 1 193 255 215 3 23 1 196 255 195 3 23 1 220 255 215 3 23 1 228 255 215 3 23 2 7 255 174 3 23 2 11 255 174 3 23 2 114 255 215 3 23 2 124 255 215 3 23 2 128 255 215 3 23 2 130 255 215 3 23 2 159 255 215 3 23 2 169 255 195 3 23 2 170 255 215 3 23 2 181 255 195 3 23 2 182 255 215 3 23 2 183 255 215 3 23 2 185 255 215 3 23 2 187 255 215 3 23 2 189 255 195 3 23 2 190 255 215 3 23 2 191 255 215 3 23 2 193 255 215 3 23 2 202 255 215 3 23 2 212 255 215 3 23 2 217 255 215 3 23 2 219 255 215 3 23 2 221 255 215 3 23 2 229 255 215 3 23 2 253 255 215 3 23 3 5 255 215 3 23 3 7 255 215 3 23 3 13 255 215 3 23 3 15 255 215 3 23 3 23 255 195 3 23 3 24 255 215 3 24 0 5 255 154 3 24 0 10 255 154 3 24 1 208 255 215 3 24 1 220 255 195 3 24 1 221 255 215 3 24 1 223 255 215 3 24 1 225 255 215 3 24 1 228 255 195 3 24 1 246 255 215 3 24 2 7 255 154 3 24 2 11 255 154 3 24 2 160 255 215 3 24 2 170 255 195 3 24 2 182 255 195 3 24 2 188 255 215 3 24 2 190 255 195 3 24 2 192 255 215 3 24 2 194 255 215 3 24 2 203 255 215 3 24 2 213 255 215 3 24 2 230 255 215 3 24 2 248 255 215 3 24 2 250 255 215 3 24 2 252 255 215 3 24 2 254 255 215 3 24 3 6 255 215 3 24 3 8 255 215 3 24 3 14 255 154 3 24 3 16 255 154 3 24 3 24 255 195 3 25 1 225 255 215 3 25 2 192 255 215 3 25 2 194 255 215 3 25 2 213 255 215 3 25 2 254 255 215 3 27 1 163 0 225 3 27 2 234 0 41 3 27 3 14 255 215 3 27 3 16 255 215 3 28 0 5 255 236 3 28 0 10 255 236 3 28 2 7 255 236 3 28 2 11 255 236 3 29 0 5 255 113 3 29 0 10 255 113 3 29 0 38 255 215 3 29 0 42 255 215 3 29 0 45 1 10 3 29 0 50 255 215 3 29 0 52 255 215 3 29 0 55 255 113 3 29 0 57 255 174 3 29 0 58 255 174 3 29 0 60 255 133 3 29 0 137 255 215 3 29 0 148 255 215 3 29 0 149 255 215 3 29 0 150 255 215 3 29 0 151 255 215 3 29 0 152 255 215 3 29 0 154 255 215 3 29 0 159 255 133 3 29 0 200 255 215 3 29 0 202 255 215 3 29 0 204 255 215 3 29 0 206 255 215 3 29 0 222 255 215 3 29 0 224 255 215 3 29 0 226 255 215 3 29 0 228 255 215 3 29 1 14 255 215 3 29 1 16 255 215 3 29 1 18 255 215 3 29 1 20 255 215 3 29 1 36 255 113 3 29 1 38 255 113 3 29 1 54 255 174 3 29 1 56 255 133 3 29 1 58 255 133 3 29 1 71 255 215 3 29 1 250 255 174 3 29 1 252 255 174 3 29 1 254 255 174 3 29 2 0 255 133 3 29 2 7 255 113 3 29 2 11 255 113 3 29 2 95 255 215 3 29 3 73 255 215 3 29 3 75 255 215 3 29 3 77 255 215 3 29 3 79 255 215 3 29 3 81 255 215 3 29 3 83 255 215 3 29 3 85 255 215 3 29 3 87 255 215 3 29 3 89 255 215 3 29 3 91 255 215 3 29 3 93 255 215 3 29 3 95 255 215 3 29 3 111 255 133 3 29 3 113 255 133 3 29 3 115 255 133 3 29 3 143 255 113 3 30 0 5 255 236 3 30 0 10 255 236 3 30 2 7 255 236 3 30 2 11 255 236 3 31 0 5 255 113 3 31 0 10 255 113 3 31 0 38 255 215 3 31 0 42 255 215 3 31 0 45 1 10 3 31 0 50 255 215 3 31 0 52 255 215 3 31 0 55 255 113 3 31 0 57 255 174 3 31 0 58 255 174 3 31 0 60 255 133 3 31 0 137 255 215 3 31 0 148 255 215 3 31 0 149 255 215 3 31 0 150 255 215 3 31 0 151 255 215 3 31 0 152 255 215 3 31 0 154 255 215 3 31 0 159 255 133 3 31 0 200 255 215 3 31 0 202 255 215 3 31 0 204 255 215 3 31 0 206 255 215 3 31 0 222 255 215 3 31 0 224 255 215 3 31 0 226 255 215 3 31 0 228 255 215 3 31 1 14 255 215 3 31 1 16 255 215 3 31 1 18 255 215 3 31 1 20 255 215 3 31 1 36 255 113 3 31 1 38 255 113 3 31 1 54 255 174 3 31 1 56 255 133 3 31 1 58 255 133 3 31 1 71 255 215 3 31 1 250 255 174 3 31 1 252 255 174 3 31 1 254 255 174 3 31 2 0 255 133 3 31 2 7 255 113 3 31 2 11 255 113 3 31 2 95 255 215 3 31 3 73 255 215 3 31 3 75 255 215 3 31 3 77 255 215 3 31 3 79 255 215 3 31 3 81 255 215 3 31 3 83 255 215 3 31 3 85 255 215 3 31 3 87 255 215 3 31 3 89 255 215 3 31 3 91 255 215 3 31 3 93 255 215 3 31 3 95 255 215 3 31 3 111 255 133 3 31 3 113 255 133 3 31 3 115 255 133 3 31 3 143 255 113 3 32 0 5 255 236 3 32 0 10 255 236 3 32 2 7 255 236 3 32 2 11 255 236 3 33 0 5 255 113 3 33 0 10 255 113 3 33 0 38 255 215 3 33 0 42 255 215 3 33 0 45 1 10 3 33 0 50 255 215 3 33 0 52 255 215 3 33 0 55 255 113 3 33 0 57 255 174 3 33 0 58 255 174 3 33 0 60 255 133 3 33 0 137 255 215 3 33 0 148 255 215 3 33 0 149 255 215 3 33 0 150 255 215 3 33 0 151 255 215 3 33 0 152 255 215 3 33 0 154 255 215 3 33 0 159 255 133 3 33 0 200 255 215 3 33 0 202 255 215 3 33 0 204 255 215 3 33 0 206 255 215 3 33 0 222 255 215 3 33 0 224 255 215 3 33 0 226 255 215 3 33 0 228 255 215 3 33 1 14 255 215 3 33 1 16 255 215 3 33 1 18 255 215 3 33 1 20 255 215 3 33 1 36 255 113 3 33 1 38 255 113 3 33 1 54 255 174 3 33 1 56 255 133 3 33 1 58 255 133 3 33 1 71 255 215 3 33 1 250 255 174 3 33 1 252 255 174 3 33 1 254 255 174 3 33 2 0 255 133 3 33 2 7 255 113 3 33 2 11 255 113 3 33 2 95 255 215 3 33 3 73 255 215 3 33 3 75 255 215 3 33 3 77 255 215 3 33 3 79 255 215 3 33 3 81 255 215 3 33 3 83 255 215 3 33 3 85 255 215 3 33 3 87 255 215 3 33 3 89 255 215 3 33 3 91 255 215 3 33 3 93 255 215 3 33 3 95 255 215 3 33 3 111 255 133 3 33 3 113 255 133 3 33 3 115 255 133 3 33 3 143 255 113 3 34 0 5 255 236 3 34 0 10 255 236 3 34 2 7 255 236 3 34 2 11 255 236 3 35 0 5 255 113 3 35 0 10 255 113 3 35 0 38 255 215 3 35 0 42 255 215 3 35 0 45 1 10 3 35 0 50 255 215 3 35 0 52 255 215 3 35 0 55 255 113 3 35 0 57 255 174 3 35 0 58 255 174 3 35 0 60 255 133 3 35 0 137 255 215 3 35 0 148 255 215 3 35 0 149 255 215 3 35 0 150 255 215 3 35 0 151 255 215 3 35 0 152 255 215 3 35 0 154 255 215 3 35 0 159 255 133 3 35 0 200 255 215 3 35 0 202 255 215 3 35 0 204 255 215 3 35 0 206 255 215 3 35 0 222 255 215 3 35 0 224 255 215 3 35 0 226 255 215 3 35 0 228 255 215 3 35 1 14 255 215 3 35 1 16 255 215 3 35 1 18 255 215 3 35 1 20 255 215 3 35 1 36 255 113 3 35 1 38 255 113 3 35 1 54 255 174 3 35 1 56 255 133 3 35 1 58 255 133 3 35 1 71 255 215 3 35 1 250 255 174 3 35 1 252 255 174 3 35 1 254 255 174 3 35 2 0 255 133 3 35 2 7 255 113 3 35 2 11 255 113 3 35 2 95 255 215 3 35 3 73 255 215 3 35 3 75 255 215 3 35 3 77 255 215 3 35 3 79 255 215 3 35 3 81 255 215 3 35 3 83 255 215 3 35 3 85 255 215 3 35 3 87 255 215 3 35 3 89 255 215 3 35 3 91 255 215 3 35 3 93 255 215 3 35 3 95 255 215 3 35 3 111 255 133 3 35 3 113 255 133 3 35 3 115 255 133 3 35 3 143 255 113 3 36 0 5 255 236 3 36 0 10 255 236 3 36 2 7 255 236 3 36 2 11 255 236 3 37 0 5 255 113 3 37 0 10 255 113 3 37 0 38 255 215 3 37 0 42 255 215 3 37 0 45 1 10 3 37 0 50 255 215 3 37 0 52 255 215 3 37 0 55 255 113 3 37 0 57 255 174 3 37 0 58 255 174 3 37 0 60 255 133 3 37 0 137 255 215 3 37 0 148 255 215 3 37 0 149 255 215 3 37 0 150 255 215 3 37 0 151 255 215 3 37 0 152 255 215 3 37 0 154 255 215 3 37 0 159 255 133 3 37 0 200 255 215 3 37 0 202 255 215 3 37 0 204 255 215 3 37 0 206 255 215 3 37 0 222 255 215 3 37 0 224 255 215 3 37 0 226 255 215 3 37 0 228 255 215 3 37 1 14 255 215 3 37 1 16 255 215 3 37 1 18 255 215 3 37 1 20 255 215 3 37 1 36 255 113 3 37 1 38 255 113 3 37 1 54 255 174 3 37 1 56 255 133 3 37 1 58 255 133 3 37 1 71 255 215 3 37 1 250 255 174 3 37 1 252 255 174 3 37 1 254 255 174 3 37 2 0 255 133 3 37 2 7 255 113 3 37 2 11 255 113 3 37 2 95 255 215 3 37 3 73 255 215 3 37 3 75 255 215 3 37 3 77 255 215 3 37 3 79 255 215 3 37 3 81 255 215 3 37 3 83 255 215 3 37 3 85 255 215 3 37 3 87 255 215 3 37 3 89 255 215 3 37 3 91 255 215 3 37 3 93 255 215 3 37 3 95 255 215 3 37 3 111 255 133 3 37 3 113 255 133 3 37 3 115 255 133 3 37 3 143 255 113 3 38 0 5 255 236 3 38 0 10 255 236 3 38 2 7 255 236 3 38 2 11 255 236 3 39 0 5 255 113 3 39 0 10 255 113 3 39 0 38 255 215 3 39 0 42 255 215 3 39 0 45 1 10 3 39 0 50 255 215 3 39 0 52 255 215 3 39 0 55 255 113 3 39 0 57 255 174 3 39 0 58 255 174 3 39 0 60 255 133 3 39 0 137 255 215 3 39 0 148 255 215 3 39 0 149 255 215 3 39 0 150 255 215 3 39 0 151 255 215 3 39 0 152 255 215 3 39 0 154 255 215 3 39 0 159 255 133 3 39 0 200 255 215 3 39 0 202 255 215 3 39 0 204 255 215 3 39 0 206 255 215 3 39 0 222 255 215 3 39 0 224 255 215 3 39 0 226 255 215 3 39 0 228 255 215 3 39 1 14 255 215 3 39 1 16 255 215 3 39 1 18 255 215 3 39 1 20 255 215 3 39 1 36 255 113 3 39 1 38 255 113 3 39 1 54 255 174 3 39 1 56 255 133 3 39 1 58 255 133 3 39 1 71 255 215 3 39 1 250 255 174 3 39 1 252 255 174 3 39 1 254 255 174 3 39 2 0 255 133 3 39 2 7 255 113 3 39 2 11 255 113 3 39 2 95 255 215 3 39 3 73 255 215 3 39 3 75 255 215 3 39 3 77 255 215 3 39 3 79 255 215 3 39 3 81 255 215 3 39 3 83 255 215 3 39 3 85 255 215 3 39 3 87 255 215 3 39 3 89 255 215 3 39 3 91 255 215 3 39 3 93 255 215 3 39 3 95 255 215 3 39 3 111 255 133 3 39 3 113 255 133 3 39 3 115 255 133 3 39 3 143 255 113 3 40 0 5 255 236 3 40 0 10 255 236 3 40 2 7 255 236 3 40 2 11 255 236 3 41 0 5 255 113 3 41 0 10 255 113 3 41 0 38 255 215 3 41 0 42 255 215 3 41 0 45 1 10 3 41 0 50 255 215 3 41 0 52 255 215 3 41 0 55 255 113 3 41 0 57 255 174 3 41 0 58 255 174 3 41 0 60 255 133 3 41 0 137 255 215 3 41 0 148 255 215 3 41 0 149 255 215 3 41 0 150 255 215 3 41 0 151 255 215 3 41 0 152 255 215 3 41 0 154 255 215 3 41 0 159 255 133 3 41 0 200 255 215 3 41 0 202 255 215 3 41 0 204 255 215 3 41 0 206 255 215 3 41 0 222 255 215 3 41 0 224 255 215 3 41 0 226 255 215 3 41 0 228 255 215 3 41 1 14 255 215 3 41 1 16 255 215 3 41 1 18 255 215 3 41 1 20 255 215 3 41 1 36 255 113 3 41 1 38 255 113 3 41 1 54 255 174 3 41 1 56 255 133 3 41 1 58 255 133 3 41 1 71 255 215 3 41 1 250 255 174 3 41 1 252 255 174 3 41 1 254 255 174 3 41 2 0 255 133 3 41 2 7 255 113 3 41 2 11 255 113 3 41 2 95 255 215 3 41 3 73 255 215 3 41 3 75 255 215 3 41 3 77 255 215 3 41 3 79 255 215 3 41 3 81 255 215 3 41 3 83 255 215 3 41 3 85 255 215 3 41 3 87 255 215 3 41 3 89 255 215 3 41 3 91 255 215 3 41 3 93 255 215 3 41 3 95 255 215 3 41 3 111 255 133 3 41 3 113 255 133 3 41 3 115 255 133 3 41 3 143 255 113 3 42 0 5 255 236 3 42 0 10 255 236 3 42 2 7 255 236 3 42 2 11 255 236 3 43 0 5 255 113 3 43 0 10 255 113 3 43 0 38 255 215 3 43 0 42 255 215 3 43 0 45 1 10 3 43 0 50 255 215 3 43 0 52 255 215 3 43 0 55 255 113 3 43 0 57 255 174 3 43 0 58 255 174 3 43 0 60 255 133 3 43 0 137 255 215 3 43 0 148 255 215 3 43 0 149 255 215 3 43 0 150 255 215 3 43 0 151 255 215 3 43 0 152 255 215 3 43 0 154 255 215 3 43 0 159 255 133 3 43 0 200 255 215 3 43 0 202 255 215 3 43 0 204 255 215 3 43 0 206 255 215 3 43 0 222 255 215 3 43 0 224 255 215 3 43 0 226 255 215 3 43 0 228 255 215 3 43 1 14 255 215 3 43 1 16 255 215 3 43 1 18 255 215 3 43 1 20 255 215 3 43 1 36 255 113 3 43 1 38 255 113 3 43 1 54 255 174 3 43 1 56 255 133 3 43 1 58 255 133 3 43 1 71 255 215 3 43 1 250 255 174 3 43 1 252 255 174 3 43 1 254 255 174 3 43 2 0 255 133 3 43 2 7 255 113 3 43 2 11 255 113 3 43 2 95 255 215 3 43 3 73 255 215 3 43 3 75 255 215 3 43 3 77 255 215 3 43 3 79 255 215 3 43 3 81 255 215 3 43 3 83 255 215 3 43 3 85 255 215 3 43 3 87 255 215 3 43 3 89 255 215 3 43 3 91 255 215 3 43 3 93 255 215 3 43 3 95 255 215 3 43 3 111 255 133 3 43 3 113 255 133 3 43 3 115 255 133 3 43 3 143 255 113 3 44 0 5 255 236 3 44 0 10 255 236 3 44 2 7 255 236 3 44 2 11 255 236 3 45 0 5 255 113 3 45 0 10 255 113 3 45 0 38 255 215 3 45 0 42 255 215 3 45 0 45 1 10 3 45 0 50 255 215 3 45 0 52 255 215 3 45 0 55 255 113 3 45 0 57 255 174 3 45 0 58 255 174 3 45 0 60 255 133 3 45 0 137 255 215 3 45 0 148 255 215 3 45 0 149 255 215 3 45 0 150 255 215 3 45 0 151 255 215 3 45 0 152 255 215 3 45 0 154 255 215 3 45 0 159 255 133 3 45 0 200 255 215 3 45 0 202 255 215 3 45 0 204 255 215 3 45 0 206 255 215 3 45 0 222 255 215 3 45 0 224 255 215 3 45 0 226 255 215 3 45 0 228 255 215 3 45 1 14 255 215 3 45 1 16 255 215 3 45 1 18 255 215 3 45 1 20 255 215 3 45 1 36 255 113 3 45 1 38 255 113 3 45 1 54 255 174 3 45 1 56 255 133 3 45 1 58 255 133 3 45 1 71 255 215 3 45 1 250 255 174 3 45 1 252 255 174 3 45 1 254 255 174 3 45 2 0 255 133 3 45 2 7 255 113 3 45 2 11 255 113 3 45 2 95 255 215 3 45 3 73 255 215 3 45 3 75 255 215 3 45 3 77 255 215 3 45 3 79 255 215 3 45 3 81 255 215 3 45 3 83 255 215 3 45 3 85 255 215 3 45 3 87 255 215 3 45 3 89 255 215 3 45 3 91 255 215 3 45 3 93 255 215 3 45 3 95 255 215 3 45 3 111 255 133 3 45 3 113 255 133 3 45 3 115 255 133 3 45 3 143 255 113 3 46 0 5 255 236 3 46 0 10 255 236 3 46 2 7 255 236 3 46 2 11 255 236 3 47 0 5 255 113 3 47 0 10 255 113 3 47 0 38 255 215 3 47 0 42 255 215 3 47 0 45 1 10 3 47 0 50 255 215 3 47 0 52 255 215 3 47 0 55 255 113 3 47 0 57 255 174 3 47 0 58 255 174 3 47 0 60 255 133 3 47 0 137 255 215 3 47 0 148 255 215 3 47 0 149 255 215 3 47 0 150 255 215 3 47 0 151 255 215 3 47 0 152 255 215 3 47 0 154 255 215 3 47 0 159 255 133 3 47 0 200 255 215 3 47 0 202 255 215 3 47 0 204 255 215 3 47 0 206 255 215 3 47 0 222 255 215 3 47 0 224 255 215 3 47 0 226 255 215 3 47 0 228 255 215 3 47 1 14 255 215 3 47 1 16 255 215 3 47 1 18 255 215 3 47 1 20 255 215 3 47 1 36 255 113 3 47 1 38 255 113 3 47 1 54 255 174 3 47 1 56 255 133 3 47 1 58 255 133 3 47 1 71 255 215 3 47 1 250 255 174 3 47 1 252 255 174 3 47 1 254 255 174 3 47 2 0 255 133 3 47 2 7 255 113 3 47 2 11 255 113 3 47 2 95 255 215 3 47 3 73 255 215 3 47 3 75 255 215 3 47 3 77 255 215 3 47 3 79 255 215 3 47 3 81 255 215 3 47 3 83 255 215 3 47 3 85 255 215 3 47 3 87 255 215 3 47 3 89 255 215 3 47 3 91 255 215 3 47 3 93 255 215 3 47 3 95 255 215 3 47 3 111 255 133 3 47 3 113 255 133 3 47 3 115 255 133 3 47 3 143 255 113 3 48 0 5 255 236 3 48 0 10 255 236 3 48 2 7 255 236 3 48 2 11 255 236 3 49 0 5 255 113 3 49 0 10 255 113 3 49 0 38 255 215 3 49 0 42 255 215 3 49 0 45 1 10 3 49 0 50 255 215 3 49 0 52 255 215 3 49 0 55 255 113 3 49 0 57 255 174 3 49 0 58 255 174 3 49 0 60 255 133 3 49 0 137 255 215 3 49 0 148 255 215 3 49 0 149 255 215 3 49 0 150 255 215 3 49 0 151 255 215 3 49 0 152 255 215 3 49 0 154 255 215 3 49 0 159 255 133 3 49 0 200 255 215 3 49 0 202 255 215 3 49 0 204 255 215 3 49 0 206 255 215 3 49 0 222 255 215 3 49 0 224 255 215 3 49 0 226 255 215 3 49 0 228 255 215 3 49 1 14 255 215 3 49 1 16 255 215 3 49 1 18 255 215 3 49 1 20 255 215 3 49 1 36 255 113 3 49 1 38 255 113 3 49 1 54 255 174 3 49 1 56 255 133 3 49 1 58 255 133 3 49 1 71 255 215 3 49 1 250 255 174 3 49 1 252 255 174 3 49 1 254 255 174 3 49 2 0 255 133 3 49 2 7 255 113 3 49 2 11 255 113 3 49 2 95 255 215 3 49 3 73 255 215 3 49 3 75 255 215 3 49 3 77 255 215 3 49 3 79 255 215 3 49 3 81 255 215 3 49 3 83 255 215 3 49 3 85 255 215 3 49 3 87 255 215 3 49 3 89 255 215 3 49 3 91 255 215 3 49 3 93 255 215 3 49 3 95 255 215 3 49 3 111 255 133 3 49 3 113 255 133 3 49 3 115 255 133 3 49 3 143 255 113 3 50 0 5 255 236 3 50 0 10 255 236 3 50 2 7 255 236 3 50 2 11 255 236 3 51 0 5 255 113 3 51 0 10 255 113 3 51 0 38 255 215 3 51 0 42 255 215 3 51 0 45 1 10 3 51 0 50 255 215 3 51 0 52 255 215 3 51 0 55 255 113 3 51 0 57 255 174 3 51 0 58 255 174 3 51 0 60 255 133 3 51 0 137 255 215 3 51 0 148 255 215 3 51 0 149 255 215 3 51 0 150 255 215 3 51 0 151 255 215 3 51 0 152 255 215 3 51 0 154 255 215 3 51 0 159 255 133 3 51 0 200 255 215 3 51 0 202 255 215 3 51 0 204 255 215 3 51 0 206 255 215 3 51 0 222 255 215 3 51 0 224 255 215 3 51 0 226 255 215 3 51 0 228 255 215 3 51 1 14 255 215 3 51 1 16 255 215 3 51 1 18 255 215 3 51 1 20 255 215 3 51 1 36 255 113 3 51 1 38 255 113 3 51 1 54 255 174 3 51 1 56 255 133 3 51 1 58 255 133 3 51 1 71 255 215 3 51 1 250 255 174 3 51 1 252 255 174 3 51 1 254 255 174 3 51 2 0 255 133 3 51 2 7 255 113 3 51 2 11 255 113 3 51 2 95 255 215 3 51 3 73 255 215 3 51 3 75 255 215 3 51 3 77 255 215 3 51 3 79 255 215 3 51 3 81 255 215 3 51 3 83 255 215 3 51 3 85 255 215 3 51 3 87 255 215 3 51 3 89 255 215 3 51 3 91 255 215 3 51 3 93 255 215 3 51 3 95 255 215 3 51 3 111 255 133 3 51 3 113 255 133 3 51 3 115 255 133 3 51 3 143 255 113 3 52 0 5 255 236 3 52 0 10 255 236 3 52 2 7 255 236 3 52 2 11 255 236 3 53 0 45 0 123 3 54 0 5 255 236 3 54 0 10 255 236 3 54 0 89 255 215 3 54 0 90 255 215 3 54 0 91 255 215 3 54 0 92 255 215 3 54 0 93 255 236 3 54 0 191 255 215 3 54 1 55 255 215 3 54 1 60 255 236 3 54 1 62 255 236 3 54 1 64 255 236 3 54 1 251 255 215 3 54 1 253 255 215 3 54 2 7 255 236 3 54 2 11 255 236 3 54 3 112 255 215 3 55 0 45 0 123 3 56 0 5 255 236 3 56 0 10 255 236 3 56 0 89 255 215 3 56 0 90 255 215 3 56 0 91 255 215 3 56 0 92 255 215 3 56 0 93 255 236 3 56 0 191 255 215 3 56 1 55 255 215 3 56 1 60 255 236 3 56 1 62 255 236 3 56 1 64 255 236 3 56 1 251 255 215 3 56 1 253 255 215 3 56 2 7 255 236 3 56 2 11 255 236 3 56 3 112 255 215 3 57 0 45 0 123 3 58 0 5 255 236 3 58 0 10 255 236 3 58 0 89 255 215 3 58 0 90 255 215 3 58 0 91 255 215 3 58 0 92 255 215 3 58 0 93 255 236 3 58 0 191 255 215 3 58 1 55 255 215 3 58 1 60 255 236 3 58 1 62 255 236 3 58 1 64 255 236 3 58 1 251 255 215 3 58 1 253 255 215 3 58 2 7 255 236 3 58 2 11 255 236 3 58 3 112 255 215 3 59 0 45 0 123 3 60 0 5 255 236 3 60 0 10 255 236 3 60 0 89 255 215 3 60 0 90 255 215 3 60 0 91 255 215 3 60 0 92 255 215 3 60 0 93 255 236 3 60 0 191 255 215 3 60 1 55 255 215 3 60 1 60 255 236 3 60 1 62 255 236 3 60 1 64 255 236 3 60 1 251 255 215 3 60 1 253 255 215 3 60 2 7 255 236 3 60 2 11 255 236 3 60 3 112 255 215 3 61 0 45 0 123 3 62 0 5 255 236 3 62 0 10 255 236 3 62 0 89 255 215 3 62 0 90 255 215 3 62 0 91 255 215 3 62 0 92 255 215 3 62 0 93 255 236 3 62 0 191 255 215 3 62 1 55 255 215 3 62 1 60 255 236 3 62 1 62 255 236 3 62 1 64 255 236 3 62 1 251 255 215 3 62 1 253 255 215 3 62 2 7 255 236 3 62 2 11 255 236 3 62 3 112 255 215 3 63 0 45 0 123 3 64 0 5 255 236 3 64 0 10 255 236 3 64 0 89 255 215 3 64 0 90 255 215 3 64 0 91 255 215 3 64 0 92 255 215 3 64 0 93 255 236 3 64 0 191 255 215 3 64 1 55 255 215 3 64 1 60 255 236 3 64 1 62 255 236 3 64 1 64 255 236 3 64 1 251 255 215 3 64 1 253 255 215 3 64 2 7 255 236 3 64 2 11 255 236 3 64 3 112 255 215 3 65 0 45 0 123 3 66 0 5 255 236 3 66 0 10 255 236 3 66 0 89 255 215 3 66 0 90 255 215 3 66 0 91 255 215 3 66 0 92 255 215 3 66 0 93 255 236 3 66 0 191 255 215 3 66 1 55 255 215 3 66 1 60 255 236 3 66 1 62 255 236 3 66 1 64 255 236 3 66 1 251 255 215 3 66 1 253 255 215 3 66 2 7 255 236 3 66 2 11 255 236 3 66 3 112 255 215 3 67 0 45 0 123 3 68 0 5 255 236 3 68 0 10 255 236 3 68 0 89 255 215 3 68 0 90 255 215 3 68 0 91 255 215 3 68 0 92 255 215 3 68 0 93 255 236 3 68 0 191 255 215 3 68 1 55 255 215 3 68 1 60 255 236 3 68 1 62 255 236 3 68 1 64 255 236 3 68 1 251 255 215 3 68 1 253 255 215 3 68 2 7 255 236 3 68 2 11 255 236 3 68 3 112 255 215 3 73 0 15 255 174 3 73 0 17 255 174 3 73 0 36 255 215 3 73 0 55 255 195 3 73 0 57 255 236 3 73 0 58 255 236 3 73 0 59 255 215 3 73 0 60 255 236 3 73 0 61 255 236 3 73 0 130 255 215 3 73 0 131 255 215 3 73 0 132 255 215 3 73 0 133 255 215 3 73 0 134 255 215 3 73 0 135 255 215 3 73 0 159 255 236 3 73 0 194 255 215 3 73 0 196 255 215 3 73 0 198 255 215 3 73 1 36 255 195 3 73 1 38 255 195 3 73 1 54 255 236 3 73 1 56 255 236 3 73 1 58 255 236 3 73 1 59 255 236 3 73 1 61 255 236 3 73 1 63 255 236 3 73 1 67 255 215 3 73 1 160 255 236 3 73 1 250 255 236 3 73 1 252 255 236 3 73 1 254 255 236 3 73 2 0 255 236 3 73 2 8 255 174 3 73 2 12 255 174 3 73 2 88 255 215 3 73 3 29 255 215 3 73 3 31 255 215 3 73 3 33 255 215 3 73 3 35 255 215 3 73 3 37 255 215 3 73 3 39 255 215 3 73 3 41 255 215 3 73 3 43 255 215 3 73 3 45 255 215 3 73 3 47 255 215 3 73 3 49 255 215 3 73 3 51 255 215 3 73 3 111 255 236 3 73 3 113 255 236 3 73 3 115 255 236 3 73 3 143 255 195 3 74 0 5 255 236 3 74 0 10 255 236 3 74 0 89 255 215 3 74 0 90 255 215 3 74 0 91 255 215 3 74 0 92 255 215 3 74 0 93 255 236 3 74 0 191 255 215 3 74 1 55 255 215 3 74 1 60 255 236 3 74 1 62 255 236 3 74 1 64 255 236 3 74 1 251 255 215 3 74 1 253 255 215 3 74 2 7 255 236 3 74 2 11 255 236 3 74 3 112 255 215 3 75 0 15 255 174 3 75 0 17 255 174 3 75 0 36 255 215 3 75 0 55 255 195 3 75 0 57 255 236 3 75 0 58 255 236 3 75 0 59 255 215 3 75 0 60 255 236 3 75 0 61 255 236 3 75 0 130 255 215 3 75 0 131 255 215 3 75 0 132 255 215 3 75 0 133 255 215 3 75 0 134 255 215 3 75 0 135 255 215 3 75 0 159 255 236 3 75 0 194 255 215 3 75 0 196 255 215 3 75 0 198 255 215 3 75 1 36 255 195 3 75 1 38 255 195 3 75 1 54 255 236 3 75 1 56 255 236 3 75 1 58 255 236 3 75 1 59 255 236 3 75 1 61 255 236 3 75 1 63 255 236 3 75 1 67 255 215 3 75 1 160 255 236 3 75 1 250 255 236 3 75 1 252 255 236 3 75 1 254 255 236 3 75 2 0 255 236 3 75 2 8 255 174 3 75 2 12 255 174 3 75 2 88 255 215 3 75 3 29 255 215 3 75 3 31 255 215 3 75 3 33 255 215 3 75 3 35 255 215 3 75 3 37 255 215 3 75 3 39 255 215 3 75 3 41 255 215 3 75 3 43 255 215 3 75 3 45 255 215 3 75 3 47 255 215 3 75 3 49 255 215 3 75 3 51 255 215 3 75 3 111 255 236 3 75 3 113 255 236 3 75 3 115 255 236 3 75 3 143 255 195 3 76 0 5 255 236 3 76 0 10 255 236 3 76 0 89 255 215 3 76 0 90 255 215 3 76 0 91 255 215 3 76 0 92 255 215 3 76 0 93 255 236 3 76 0 191 255 215 3 76 1 55 255 215 3 76 1 60 255 236 3 76 1 62 255 236 3 76 1 64 255 236 3 76 1 251 255 215 3 76 1 253 255 215 3 76 2 7 255 236 3 76 2 11 255 236 3 76 3 112 255 215 3 77 0 15 255 174 3 77 0 17 255 174 3 77 0 36 255 215 3 77 0 55 255 195 3 77 0 57 255 236 3 77 0 58 255 236 3 77 0 59 255 215 3 77 0 60 255 236 3 77 0 61 255 236 3 77 0 130 255 215 3 77 0 131 255 215 3 77 0 132 255 215 3 77 0 133 255 215 3 77 0 134 255 215 3 77 0 135 255 215 3 77 0 159 255 236 3 77 0 194 255 215 3 77 0 196 255 215 3 77 0 198 255 215 3 77 1 36 255 195 3 77 1 38 255 195 3 77 1 54 255 236 3 77 1 56 255 236 3 77 1 58 255 236 3 77 1 59 255 236 3 77 1 61 255 236 3 77 1 63 255 236 3 77 1 67 255 215 3 77 1 160 255 236 3 77 1 250 255 236 3 77 1 252 255 236 3 77 1 254 255 236 3 77 2 0 255 236 3 77 2 8 255 174 3 77 2 12 255 174 3 77 2 88 255 215 3 77 3 29 255 215 3 77 3 31 255 215 3 77 3 33 255 215 3 77 3 35 255 215 3 77 3 37 255 215 3 77 3 39 255 215 3 77 3 41 255 215 3 77 3 43 255 215 3 77 3 45 255 215 3 77 3 47 255 215 3 77 3 49 255 215 3 77 3 51 255 215 3 77 3 111 255 236 3 77 3 113 255 236 3 77 3 115 255 236 3 77 3 143 255 195 3 79 0 15 255 174 3 79 0 17 255 174 3 79 0 36 255 215 3 79 0 55 255 195 3 79 0 57 255 236 3 79 0 58 255 236 3 79 0 59 255 215 3 79 0 60 255 236 3 79 0 61 255 236 3 79 0 130 255 215 3 79 0 131 255 215 3 79 0 132 255 215 3 79 0 133 255 215 3 79 0 134 255 215 3 79 0 135 255 215 3 79 0 159 255 236 3 79 0 194 255 215 3 79 0 196 255 215 3 79 0 198 255 215 3 79 1 36 255 195 3 79 1 38 255 195 3 79 1 54 255 236 3 79 1 56 255 236 3 79 1 58 255 236 3 79 1 59 255 236 3 79 1 61 255 236 3 79 1 63 255 236 3 79 1 67 255 215 3 79 1 160 255 236 3 79 1 250 255 236 3 79 1 252 255 236 3 79 1 254 255 236 3 79 2 0 255 236 3 79 2 8 255 174 3 79 2 12 255 174 3 79 2 88 255 215 3 79 3 29 255 215 3 79 3 31 255 215 3 79 3 33 255 215 3 79 3 35 255 215 3 79 3 37 255 215 3 79 3 39 255 215 3 79 3 41 255 215 3 79 3 43 255 215 3 79 3 45 255 215 3 79 3 47 255 215 3 79 3 49 255 215 3 79 3 51 255 215 3 79 3 111 255 236 3 79 3 113 255 236 3 79 3 115 255 236 3 79 3 143 255 195 3 81 0 15 255 174 3 81 0 17 255 174 3 81 0 36 255 215 3 81 0 55 255 195 3 81 0 57 255 236 3 81 0 58 255 236 3 81 0 59 255 215 3 81 0 60 255 236 3 81 0 61 255 236 3 81 0 130 255 215 3 81 0 131 255 215 3 81 0 132 255 215 3 81 0 133 255 215 3 81 0 134 255 215 3 81 0 135 255 215 3 81 0 159 255 236 3 81 0 194 255 215 3 81 0 196 255 215 3 81 0 198 255 215 3 81 1 36 255 195 3 81 1 38 255 195 3 81 1 54 255 236 3 81 1 56 255 236 3 81 1 58 255 236 3 81 1 59 255 236 3 81 1 61 255 236 3 81 1 63 255 236 3 81 1 67 255 215 3 81 1 160 255 236 3 81 1 250 255 236 3 81 1 252 255 236 3 81 1 254 255 236 3 81 2 0 255 236 3 81 2 8 255 174 3 81 2 12 255 174 3 81 2 88 255 215 3 81 3 29 255 215 3 81 3 31 255 215 3 81 3 33 255 215 3 81 3 35 255 215 3 81 3 37 255 215 3 81 3 39 255 215 3 81 3 41 255 215 3 81 3 43 255 215 3 81 3 45 255 215 3 81 3 47 255 215 3 81 3 49 255 215 3 81 3 51 255 215 3 81 3 111 255 236 3 81 3 113 255 236 3 81 3 115 255 236 3 81 3 143 255 195 3 83 0 15 255 174 3 83 0 17 255 174 3 83 0 36 255 215 3 83 0 55 255 195 3 83 0 57 255 236 3 83 0 58 255 236 3 83 0 59 255 215 3 83 0 60 255 236 3 83 0 61 255 236 3 83 0 130 255 215 3 83 0 131 255 215 3 83 0 132 255 215 3 83 0 133 255 215 3 83 0 134 255 215 3 83 0 135 255 215 3 83 0 159 255 236 3 83 0 194 255 215 3 83 0 196 255 215 3 83 0 198 255 215 3 83 1 36 255 195 3 83 1 38 255 195 3 83 1 54 255 236 3 83 1 56 255 236 3 83 1 58 255 236 3 83 1 59 255 236 3 83 1 61 255 236 3 83 1 63 255 236 3 83 1 67 255 215 3 83 1 160 255 236 3 83 1 250 255 236 3 83 1 252 255 236 3 83 1 254 255 236 3 83 2 0 255 236 3 83 2 8 255 174 3 83 2 12 255 174 3 83 2 88 255 215 3 83 3 29 255 215 3 83 3 31 255 215 3 83 3 33 255 215 3 83 3 35 255 215 3 83 3 37 255 215 3 83 3 39 255 215 3 83 3 41 255 215 3 83 3 43 255 215 3 83 3 45 255 215 3 83 3 47 255 215 3 83 3 49 255 215 3 83 3 51 255 215 3 83 3 111 255 236 3 83 3 113 255 236 3 83 3 115 255 236 3 83 3 143 255 195 3 85 0 15 255 174 3 85 0 17 255 174 3 85 0 36 255 215 3 85 0 55 255 195 3 85 0 57 255 236 3 85 0 58 255 236 3 85 0 59 255 215 3 85 0 60 255 236 3 85 0 61 255 236 3 85 0 130 255 215 3 85 0 131 255 215 3 85 0 132 255 215 3 85 0 133 255 215 3 85 0 134 255 215 3 85 0 135 255 215 3 85 0 159 255 236 3 85 0 194 255 215 3 85 0 196 255 215 3 85 0 198 255 215 3 85 1 36 255 195 3 85 1 38 255 195 3 85 1 54 255 236 3 85 1 56 255 236 3 85 1 58 255 236 3 85 1 59 255 236 3 85 1 61 255 236 3 85 1 63 255 236 3 85 1 67 255 215 3 85 1 160 255 236 3 85 1 250 255 236 3 85 1 252 255 236 3 85 1 254 255 236 3 85 2 0 255 236 3 85 2 8 255 174 3 85 2 12 255 174 3 85 2 88 255 215 3 85 3 29 255 215 3 85 3 31 255 215 3 85 3 33 255 215 3 85 3 35 255 215 3 85 3 37 255 215 3 85 3 39 255 215 3 85 3 41 255 215 3 85 3 43 255 215 3 85 3 45 255 215 3 85 3 47 255 215 3 85 3 49 255 215 3 85 3 51 255 215 3 85 3 111 255 236 3 85 3 113 255 236 3 85 3 115 255 236 3 85 3 143 255 195 3 88 0 73 0 82 3 88 0 87 0 82 3 88 0 89 0 102 3 88 0 90 0 102 3 88 0 91 0 102 3 88 0 92 0 102 3 88 0 191 0 102 3 88 1 37 0 82 3 88 1 39 0 82 3 88 1 55 0 102 3 88 1 251 0 102 3 88 1 253 0 102 3 88 2 52 0 82 3 88 2 53 0 82 3 88 2 93 0 82 3 88 2 94 0 82 3 88 3 112 0 102 3 88 3 141 0 82 3 88 3 144 0 82 3 90 0 73 0 82 3 90 0 87 0 82 3 90 0 89 0 102 3 90 0 90 0 102 3 90 0 91 0 102 3 90 0 92 0 102 3 90 0 191 0 102 3 90 1 37 0 82 3 90 1 39 0 82 3 90 1 55 0 102 3 90 1 251 0 102 3 90 1 253 0 102 3 90 2 52 0 82 3 90 2 53 0 82 3 90 2 93 0 82 3 90 2 94 0 82 3 90 3 112 0 102 3 90 3 141 0 82 3 90 3 144 0 82 3 92 0 73 0 82 3 92 0 87 0 82 3 92 0 89 0 102 3 92 0 90 0 102 3 92 0 91 0 102 3 92 0 92 0 102 3 92 0 191 0 102 3 92 1 37 0 82 3 92 1 39 0 82 3 92 1 55 0 102 3 92 1 251 0 102 3 92 1 253 0 102 3 92 2 52 0 82 3 92 2 53 0 82 3 92 2 93 0 82 3 92 2 94 0 82 3 92 3 112 0 102 3 92 3 141 0 82 3 92 3 144 0 82 3 94 0 73 0 82 3 94 0 87 0 82 3 94 0 89 0 102 3 94 0 90 0 102 3 94 0 91 0 102 3 94 0 92 0 102 3 94 0 191 0 102 3 94 1 37 0 82 3 94 1 39 0 82 3 94 1 55 0 102 3 94 1 251 0 102 3 94 1 253 0 102 3 94 2 52 0 82 3 94 2 53 0 82 3 94 2 93 0 82 3 94 2 94 0 82 3 94 3 112 0 102 3 94 3 141 0 82 3 94 3 144 0 82 3 96 0 73 0 82 3 96 0 87 0 82 3 96 0 89 0 102 3 96 0 90 0 102 3 96 0 91 0 102 3 96 0 92 0 102 3 96 0 191 0 102 3 96 1 37 0 82 3 96 1 39 0 82 3 96 1 55 0 102 3 96 1 251 0 102 3 96 1 253 0 102 3 96 2 52 0 82 3 96 2 53 0 82 3 96 2 93 0 82 3 96 2 94 0 82 3 96 3 112 0 102 3 96 3 141 0 82 3 96 3 144 0 82 3 97 0 15 255 215 3 97 0 17 255 215 3 97 0 36 255 236 3 97 0 130 255 236 3 97 0 131 255 236 3 97 0 132 255 236 3 97 0 133 255 236 3 97 0 134 255 236 3 97 0 135 255 236 3 97 0 194 255 236 3 97 0 196 255 236 3 97 0 198 255 236 3 97 1 67 255 236 3 97 2 8 255 215 3 97 2 12 255 215 3 97 2 88 255 236 3 97 3 29 255 236 3 97 3 31 255 236 3 97 3 33 255 236 3 97 3 35 255 236 3 97 3 37 255 236 3 97 3 39 255 236 3 97 3 41 255 236 3 97 3 43 255 236 3 97 3 45 255 236 3 97 3 47 255 236 3 97 3 49 255 236 3 97 3 51 255 236 3 102 0 73 0 102 3 102 0 87 0 102 3 102 0 89 0 102 3 102 0 90 0 102 3 102 0 91 0 102 3 102 0 92 0 102 3 102 0 191 0 102 3 102 1 37 0 102 3 102 1 39 0 102 3 102 1 55 0 102 3 102 1 251 0 102 3 102 1 253 0 102 3 102 2 52 0 102 3 102 2 53 0 102 3 102 2 93 0 102 3 102 2 94 0 102 3 102 3 112 0 102 3 102 3 141 0 102 3 102 3 144 0 102 3 104 0 73 0 102 3 104 0 87 0 102 3 104 0 89 0 102 3 104 0 90 0 102 3 104 0 91 0 102 3 104 0 92 0 102 3 104 0 191 0 102 3 104 1 37 0 102 3 104 1 39 0 102 3 104 1 55 0 102 3 104 1 251 0 102 3 104 1 253 0 102 3 104 2 52 0 102 3 104 2 53 0 102 3 104 2 93 0 102 3 104 2 94 0 102 3 104 3 112 0 102 3 104 3 141 0 102 3 104 3 144 0 102 3 106 0 73 0 102 3 106 0 87 0 102 3 106 0 89 0 102 3 106 0 90 0 102 3 106 0 91 0 102 3 106 0 92 0 102 3 106 0 191 0 102 3 106 1 37 0 102 3 106 1 39 0 102 3 106 1 55 0 102 3 106 1 251 0 102 3 106 1 253 0 102 3 106 2 52 0 102 3 106 2 53 0 102 3 106 2 93 0 102 3 106 2 94 0 102 3 106 3 112 0 102 3 106 3 141 0 102 3 106 3 144 0 102 3 108 0 73 0 102 3 108 0 87 0 102 3 108 0 89 0 102 3 108 0 90 0 102 3 108 0 91 0 102 3 108 0 92 0 102 3 108 0 191 0 102 3 108 1 37 0 102 3 108 1 39 0 102 3 108 1 55 0 102 3 108 1 251 0 102 3 108 1 253 0 102 3 108 2 52 0 102 3 108 2 53 0 102 3 108 2 93 0 102 3 108 2 94 0 102 3 108 3 112 0 102 3 108 3 141 0 102 3 108 3 144 0 102 3 110 0 73 0 102 3 110 0 87 0 102 3 110 0 89 0 102 3 110 0 90 0 102 3 110 0 91 0 102 3 110 0 92 0 102 3 110 0 191 0 102 3 110 1 37 0 102 3 110 1 39 0 102 3 110 1 55 0 102 3 110 1 251 0 102 3 110 1 253 0 102 3 110 2 52 0 102 3 110 2 53 0 102 3 110 2 93 0 102 3 110 2 94 0 102 3 110 3 112 0 102 3 110 3 141 0 102 3 110 3 144 0 102 3 111 0 15 255 133 3 111 0 17 255 133 3 111 0 34 0 41 3 111 0 36 255 133 3 111 0 38 255 215 3 111 0 42 255 215 3 111 0 50 255 215 3 111 0 52 255 215 3 111 0 68 255 154 3 111 0 70 255 154 3 111 0 71 255 154 3 111 0 72 255 154 3 111 0 74 255 215 3 111 0 80 255 195 3 111 0 81 255 195 3 111 0 82 255 154 3 111 0 83 255 195 3 111 0 84 255 154 3 111 0 85 255 195 3 111 0 86 255 174 3 111 0 88 255 195 3 111 0 93 255 215 3 111 0 130 255 133 3 111 0 131 255 133 3 111 0 132 255 133 3 111 0 133 255 133 3 111 0 134 255 133 3 111 0 135 255 133 3 111 0 137 255 215 3 111 0 148 255 215 3 111 0 149 255 215 3 111 0 150 255 215 3 111 0 151 255 215 3 111 0 152 255 215 3 111 0 154 255 215 3 111 0 162 255 154 3 111 0 163 255 154 3 111 0 164 255 154 3 111 0 165 255 154 3 111 0 166 255 154 3 111 0 167 255 154 3 111 0 168 255 154 3 111 0 169 255 154 3 111 0 170 255 154 3 111 0 171 255 154 3 111 0 172 255 154 3 111 0 173 255 154 3 111 0 180 255 154 3 111 0 181 255 154 3 111 0 182 255 154 3 111 0 183 255 154 3 111 0 184 255 154 3 111 0 186 255 154 3 111 0 187 255 195 3 111 0 188 255 195 3 111 0 189 255 195 3 111 0 190 255 195 3 111 0 194 255 133 3 111 0 195 255 154 3 111 0 196 255 133 3 111 0 197 255 154 3 111 0 198 255 133 3 111 0 199 255 154 3 111 0 200 255 215 3 111 0 201 255 154 3 111 0 202 255 215 3 111 0 203 255 154 3 111 0 204 255 215 3 111 0 205 255 154 3 111 0 206 255 215 3 111 0 207 255 154 3 111 0 209 255 154 3 111 0 211 255 154 3 111 0 213 255 154 3 111 0 215 255 154 3 111 0 217 255 154 3 111 0 219 255 154 3 111 0 221 255 154 3 111 0 222 255 215 3 111 0 223 255 215 3 111 0 224 255 215 3 111 0 225 255 215 3 111 0 226 255 215 3 111 0 227 255 215 3 111 0 228 255 215 3 111 0 229 255 215 3 111 0 250 255 195 3 111 1 6 255 195 3 111 1 8 255 195 3 111 1 13 255 195 3 111 1 14 255 215 3 111 1 15 255 154 3 111 1 16 255 215 3 111 1 17 255 154 3 111 1 18 255 215 3 111 1 19 255 154 3 111 1 20 255 215 3 111 1 21 255 154 3 111 1 23 255 195 3 111 1 25 255 195 3 111 1 29 255 174 3 111 1 33 255 174 3 111 1 43 255 195 3 111 1 45 255 195 3 111 1 47 255 195 3 111 1 49 255 195 3 111 1 51 255 195 3 111 1 53 255 195 3 111 1 60 255 215 3 111 1 62 255 215 3 111 1 64 255 215 3 111 1 67 255 133 3 111 1 68 255 154 3 111 1 70 255 154 3 111 1 71 255 215 3 111 1 72 255 154 3 111 1 74 255 174 3 111 2 8 255 133 3 111 2 12 255 133 3 111 2 87 255 195 3 111 2 88 255 133 3 111 2 89 255 154 3 111 2 95 255 215 3 111 2 96 255 154 3 111 2 98 255 195 3 111 3 29 255 133 3 111 3 30 255 154 3 111 3 31 255 133 3 111 3 32 255 154 3 111 3 33 255 133 3 111 3 34 255 154 3 111 3 35 255 133 3 111 3 37 255 133 3 111 3 38 255 154 3 111 3 39 255 133 3 111 3 40 255 154 3 111 3 41 255 133 3 111 3 42 255 154 3 111 3 43 255 133 3 111 3 44 255 154 3 111 3 45 255 133 3 111 3 46 255 154 3 111 3 47 255 133 3 111 3 48 255 154 3 111 3 49 255 133 3 111 3 50 255 154 3 111 3 51 255 133 3 111 3 52 255 154 3 111 3 54 255 154 3 111 3 56 255 154 3 111 3 58 255 154 3 111 3 60 255 154 3 111 3 64 255 154 3 111 3 66 255 154 3 111 3 68 255 154 3 111 3 73 255 215 3 111 3 74 255 154 3 111 3 75 255 215 3 111 3 76 255 154 3 111 3 77 255 215 3 111 3 78 255 154 3 111 3 79 255 215 3 111 3 81 255 215 3 111 3 82 255 154 3 111 3 83 255 215 3 111 3 84 255 154 3 111 3 85 255 215 3 111 3 86 255 154 3 111 3 87 255 215 3 111 3 88 255 154 3 111 3 89 255 215 3 111 3 90 255 154 3 111 3 91 255 215 3 111 3 92 255 154 3 111 3 93 255 215 3 111 3 94 255 154 3 111 3 95 255 215 3 111 3 96 255 154 3 111 3 98 255 195 3 111 3 100 255 195 3 111 3 102 255 195 3 111 3 104 255 195 3 111 3 106 255 195 3 111 3 108 255 195 3 111 3 110 255 195 3 112 0 5 0 82 3 112 0 10 0 82 3 112 0 15 255 174 3 112 0 17 255 174 3 112 0 34 0 41 3 112 2 7 0 82 3 112 2 8 255 174 3 112 2 11 0 82 3 112 2 12 255 174 3 113 0 15 255 133 3 113 0 17 255 133 3 113 0 34 0 41 3 113 0 36 255 133 3 113 0 38 255 215 3 113 0 42 255 215 3 113 0 50 255 215 3 113 0 52 255 215 3 113 0 68 255 154 3 113 0 70 255 154 3 113 0 71 255 154 3 113 0 72 255 154 3 113 0 74 255 215 3 113 0 80 255 195 3 113 0 81 255 195 3 113 0 82 255 154 3 113 0 83 255 195 3 113 0 84 255 154 3 113 0 85 255 195 3 113 0 86 255 174 3 113 0 88 255 195 3 113 0 93 255 215 3 113 0 130 255 133 3 113 0 131 255 133 3 113 0 132 255 133 3 113 0 133 255 133 3 113 0 134 255 133 3 113 0 135 255 133 3 113 0 137 255 215 3 113 0 148 255 215 3 113 0 149 255 215 3 113 0 150 255 215 3 113 0 151 255 215 3 113 0 152 255 215 3 113 0 154 255 215 3 113 0 162 255 154 3 113 0 163 255 154 3 113 0 164 255 154 3 113 0 165 255 154 3 113 0 166 255 154 3 113 0 167 255 154 3 113 0 168 255 154 3 113 0 169 255 154 3 113 0 170 255 154 3 113 0 171 255 154 3 113 0 172 255 154 3 113 0 173 255 154 3 113 0 180 255 154 3 113 0 181 255 154 3 113 0 182 255 154 3 113 0 183 255 154 3 113 0 184 255 154 3 113 0 186 255 154 3 113 0 187 255 195 3 113 0 188 255 195 3 113 0 189 255 195 3 113 0 190 255 195 3 113 0 194 255 133 3 113 0 195 255 154 3 113 0 196 255 133 3 113 0 197 255 154 3 113 0 198 255 133 3 113 0 199 255 154 3 113 0 200 255 215 3 113 0 201 255 154 3 113 0 202 255 215 3 113 0 203 255 154 3 113 0 204 255 215 3 113 0 205 255 154 3 113 0 206 255 215 3 113 0 207 255 154 3 113 0 209 255 154 3 113 0 211 255 154 3 113 0 213 255 154 3 113 0 215 255 154 3 113 0 217 255 154 3 113 0 219 255 154 3 113 0 221 255 154 3 113 0 222 255 215 3 113 0 223 255 215 3 113 0 224 255 215 3 113 0 225 255 215 3 113 0 226 255 215 3 113 0 227 255 215 3 113 0 228 255 215 3 113 0 229 255 215 3 113 0 250 255 195 3 113 1 6 255 195 3 113 1 8 255 195 3 113 1 13 255 195 3 113 1 14 255 215 3 113 1 15 255 154 3 113 1 16 255 215 3 113 1 17 255 154 3 113 1 18 255 215 3 113 1 19 255 154 3 113 1 20 255 215 3 113 1 21 255 154 3 113 1 23 255 195 3 113 1 25 255 195 3 113 1 29 255 174 3 113 1 33 255 174 3 113 1 43 255 195 3 113 1 45 255 195 3 113 1 47 255 195 3 113 1 49 255 195 3 113 1 51 255 195 3 113 1 53 255 195 3 113 1 60 255 215 3 113 1 62 255 215 3 113 1 64 255 215 3 113 1 67 255 133 3 113 1 68 255 154 3 113 1 70 255 154 3 113 1 71 255 215 3 113 1 72 255 154 3 113 1 74 255 174 3 113 2 8 255 133 3 113 2 12 255 133 3 113 2 87 255 195 3 113 2 88 255 133 3 113 2 89 255 154 3 113 2 95 255 215 3 113 2 96 255 154 3 113 2 98 255 195 3 113 3 29 255 133 3 113 3 30 255 154 3 113 3 31 255 133 3 113 3 32 255 154 3 113 3 33 255 133 3 113 3 34 255 154 3 113 3 35 255 133 3 113 3 37 255 133 3 113 3 38 255 154 3 113 3 39 255 133 3 113 3 40 255 154 3 113 3 41 255 133 3 113 3 42 255 154 3 113 3 43 255 133 3 113 3 44 255 154 3 113 3 45 255 133 3 113 3 46 255 154 3 113 3 47 255 133 3 113 3 48 255 154 3 113 3 49 255 133 3 113 3 50 255 154 3 113 3 51 255 133 3 113 3 52 255 154 3 113 3 54 255 154 3 113 3 56 255 154 3 113 3 58 255 154 3 113 3 60 255 154 3 113 3 64 255 154 3 113 3 66 255 154 3 113 3 68 255 154 3 113 3 73 255 215 3 113 3 74 255 154 3 113 3 75 255 215 3 113 3 76 255 154 3 113 3 77 255 215 3 113 3 78 255 154 3 113 3 79 255 215 3 113 3 81 255 215 3 113 3 82 255 154 3 113 3 83 255 215 3 113 3 84 255 154 3 113 3 85 255 215 3 113 3 86 255 154 3 113 3 87 255 215 3 113 3 88 255 154 3 113 3 89 255 215 3 113 3 90 255 154 3 113 3 91 255 215 3 113 3 92 255 154 3 113 3 93 255 215 3 113 3 94 255 154 3 113 3 95 255 215 3 113 3 96 255 154 3 113 3 98 255 195 3 113 3 100 255 195 3 113 3 102 255 195 3 113 3 104 255 195 3 113 3 106 255 195 3 113 3 108 255 195 3 113 3 110 255 195 3 114 0 5 0 82 3 114 0 10 0 82 3 114 0 15 255 174 3 114 0 17 255 174 3 114 0 34 0 41 3 114 2 7 0 82 3 114 2 8 255 174 3 114 2 11 0 82 3 114 2 12 255 174 3 115 0 15 255 133 3 115 0 17 255 133 3 115 0 34 0 41 3 115 0 36 255 133 3 115 0 38 255 215 3 115 0 42 255 215 3 115 0 50 255 215 3 115 0 52 255 215 3 115 0 68 255 154 3 115 0 70 255 154 3 115 0 71 255 154 3 115 0 72 255 154 3 115 0 74 255 215 3 115 0 80 255 195 3 115 0 81 255 195 3 115 0 82 255 154 3 115 0 83 255 195 3 115 0 84 255 154 3 115 0 85 255 195 3 115 0 86 255 174 3 115 0 88 255 195 3 115 0 93 255 215 3 115 0 130 255 133 3 115 0 131 255 133 3 115 0 132 255 133 3 115 0 133 255 133 3 115 0 134 255 133 3 115 0 135 255 133 3 115 0 137 255 215 3 115 0 148 255 215 3 115 0 149 255 215 3 115 0 150 255 215 3 115 0 151 255 215 3 115 0 152 255 215 3 115 0 154 255 215 3 115 0 162 255 154 3 115 0 163 255 154 3 115 0 164 255 154 3 115 0 165 255 154 3 115 0 166 255 154 3 115 0 167 255 154 3 115 0 168 255 154 3 115 0 169 255 154 3 115 0 170 255 154 3 115 0 171 255 154 3 115 0 172 255 154 3 115 0 173 255 154 3 115 0 180 255 154 3 115 0 181 255 154 3 115 0 182 255 154 3 115 0 183 255 154 3 115 0 184 255 154 3 115 0 186 255 154 3 115 0 187 255 195 3 115 0 188 255 195 3 115 0 189 255 195 3 115 0 190 255 195 3 115 0 194 255 133 3 115 0 195 255 154 3 115 0 196 255 133 3 115 0 197 255 154 3 115 0 198 255 133 3 115 0 199 255 154 3 115 0 200 255 215 3 115 0 201 255 154 3 115 0 202 255 215 3 115 0 203 255 154 3 115 0 204 255 215 3 115 0 205 255 154 3 115 0 206 255 215 3 115 0 207 255 154 3 115 0 209 255 154 3 115 0 211 255 154 3 115 0 213 255 154 3 115 0 215 255 154 3 115 0 217 255 154 3 115 0 219 255 154 3 115 0 221 255 154 3 115 0 222 255 215 3 115 0 223 255 215 3 115 0 224 255 215 3 115 0 225 255 215 3 115 0 226 255 215 3 115 0 227 255 215 3 115 0 228 255 215 3 115 0 229 255 215 3 115 0 250 255 195 3 115 1 6 255 195 3 115 1 8 255 195 3 115 1 13 255 195 3 115 1 14 255 215 3 115 1 15 255 154 3 115 1 16 255 215 3 115 1 17 255 154 3 115 1 18 255 215 3 115 1 19 255 154 3 115 1 20 255 215 3 115 1 21 255 154 3 115 1 23 255 195 3 115 1 25 255 195 3 115 1 29 255 174 3 115 1 33 255 174 3 115 1 43 255 195 3 115 1 45 255 195 3 115 1 47 255 195 3 115 1 49 255 195 3 115 1 51 255 195 3 115 1 53 255 195 3 115 1 60 255 215 3 115 1 62 255 215 3 115 1 64 255 215 3 115 1 67 255 133 3 115 1 68 255 154 3 115 1 70 255 154 3 115 1 71 255 215 3 115 1 72 255 154 3 115 1 74 255 174 3 115 2 8 255 133 3 115 2 12 255 133 3 115 2 87 255 195 3 115 2 88 255 133 3 115 2 89 255 154 3 115 2 95 255 215 3 115 2 96 255 154 3 115 2 98 255 195 3 115 3 29 255 133 3 115 3 30 255 154 3 115 3 31 255 133 3 115 3 32 255 154 3 115 3 33 255 133 3 115 3 34 255 154 3 115 3 35 255 133 3 115 3 37 255 133 3 115 3 38 255 154 3 115 3 39 255 133 3 115 3 40 255 154 3 115 3 41 255 133 3 115 3 42 255 154 3 115 3 43 255 133 3 115 3 44 255 154 3 115 3 45 255 133 3 115 3 46 255 154 3 115 3 47 255 133 3 115 3 48 255 154 3 115 3 49 255 133 3 115 3 50 255 154 3 115 3 51 255 133 3 115 3 52 255 154 3 115 3 54 255 154 3 115 3 56 255 154 3 115 3 58 255 154 3 115 3 60 255 154 3 115 3 64 255 154 3 115 3 66 255 154 3 115 3 68 255 154 3 115 3 73 255 215 3 115 3 74 255 154 3 115 3 75 255 215 3 115 3 76 255 154 3 115 3 77 255 215 3 115 3 78 255 154 3 115 3 79 255 215 3 115 3 81 255 215 3 115 3 82 255 154 3 115 3 83 255 215 3 115 3 84 255 154 3 115 3 85 255 215 3 115 3 86 255 154 3 115 3 87 255 215 3 115 3 88 255 154 3 115 3 89 255 215 3 115 3 90 255 154 3 115 3 91 255 215 3 115 3 92 255 154 3 115 3 93 255 215 3 115 3 94 255 154 3 115 3 95 255 215 3 115 3 96 255 154 3 115 3 98 255 195 3 115 3 100 255 195 3 115 3 102 255 195 3 115 3 104 255 195 3 115 3 106 255 195 3 115 3 108 255 195 3 115 3 110 255 195 3 116 0 5 0 82 3 116 0 10 0 82 3 116 0 15 255 174 3 116 0 17 255 174 3 116 0 34 0 41 3 116 2 7 0 82 3 116 2 8 255 174 3 116 2 11 0 82 3 116 2 12 255 174 3 141 0 5 0 123 3 141 0 10 0 123 3 141 2 7 0 123 3 141 2 11 0 123 3 143 0 15 255 133 3 143 0 16 255 174 3 143 0 17 255 133 3 143 0 34 0 41 3 143 0 36 255 113 3 143 0 38 255 215 3 143 0 42 255 215 3 143 0 50 255 215 3 143 0 52 255 215 3 143 0 55 0 41 3 143 0 68 255 92 3 143 0 70 255 113 3 143 0 71 255 113 3 143 0 72 255 113 3 143 0 74 255 113 3 143 0 80 255 154 3 143 0 81 255 154 3 143 0 82 255 113 3 143 0 83 255 154 3 143 0 84 255 113 3 143 0 85 255 154 3 143 0 86 255 133 3 143 0 88 255 154 3 143 0 89 255 215 3 143 0 90 255 215 3 143 0 91 255 215 3 143 0 92 255 215 3 143 0 93 255 174 3 143 0 130 255 113 3 143 0 131 255 113 3 143 0 132 255 113 3 143 0 133 255 113 3 143 0 134 255 113 3 143 0 135 255 113 3 143 0 137 255 215 3 143 0 148 255 215 3 143 0 149 255 215 3 143 0 150 255 215 3 143 0 151 255 215 3 143 0 152 255 215 3 143 0 154 255 215 3 143 0 162 255 113 3 143 0 163 255 92 3 143 0 164 255 92 3 143 0 165 255 92 3 143 0 166 255 92 3 143 0 167 255 92 3 143 0 168 255 92 3 143 0 169 255 113 3 143 0 170 255 113 3 143 0 171 255 113 3 143 0 172 255 113 3 143 0 173 255 113 3 143 0 180 255 113 3 143 0 181 255 113 3 143 0 182 255 113 3 143 0 183 255 113 3 143 0 184 255 113 3 143 0 186 255 113 3 143 0 187 255 154 3 143 0 188 255 154 3 143 0 189 255 154 3 143 0 190 255 154 3 143 0 191 255 215 3 143 0 194 255 113 3 143 0 195 255 92 3 143 0 196 255 113 3 143 0 197 255 92 3 143 0 198 255 113 3 143 0 199 255 92 3 143 0 200 255 215 3 143 0 201 255 113 3 143 0 202 255 215 3 143 0 203 255 113 3 143 0 204 255 215 3 143 0 205 255 113 3 143 0 206 255 215 3 143 0 207 255 113 3 143 0 209 255 113 3 143 0 211 255 113 3 143 0 213 255 113 3 143 0 215 255 113 3 143 0 217 255 113 3 143 0 219 255 113 3 143 0 221 255 113 3 143 0 222 255 215 3 143 0 223 255 113 3 143 0 224 255 215 3 143 0 225 255 113 3 143 0 226 255 215 3 143 0 227 255 113 3 143 0 228 255 215 3 143 0 229 255 113 3 143 0 250 255 154 3 143 1 6 255 154 3 143 1 8 255 154 3 143 1 13 255 154 3 143 1 14 255 215 3 143 1 15 255 113 3 143 1 16 255 215 3 143 1 17 255 113 3 143 1 18 255 215 3 143 1 19 255 113 3 143 1 20 255 215 3 143 1 21 255 113 3 143 1 23 255 154 3 143 1 25 255 154 3 143 1 29 255 133 3 143 1 33 255 133 3 143 1 36 0 41 3 143 1 38 0 41 3 143 1 43 255 154 3 143 1 45 255 154 3 143 1 47 255 154 3 143 1 49 255 154 3 143 1 51 255 154 3 143 1 53 255 154 3 143 1 55 255 215 3 143 1 60 255 174 3 143 1 62 255 174 3 143 1 64 255 174 3 143 1 67 255 113 3 143 1 68 255 92 3 143 1 70 255 92 3 143 1 71 255 215 3 143 1 72 255 113 3 143 1 74 255 133 3 143 1 251 255 215 3 143 1 253 255 215 3 143 2 2 255 174 3 143 2 3 255 174 3 143 2 4 255 174 3 143 2 8 255 133 3 143 2 12 255 133 3 143 2 87 255 154 3 143 2 88 255 113 3 143 2 89 255 92 3 143 2 95 255 215 3 143 2 96 255 113 3 143 2 98 255 154 3 143 3 29 255 113 3 143 3 30 255 92 3 143 3 31 255 113 3 143 3 32 255 92 3 143 3 33 255 113 3 143 3 34 255 92 3 143 3 35 255 113 3 143 3 37 255 113 3 143 3 38 255 92 3 143 3 39 255 113 3 143 3 40 255 92 3 143 3 41 255 113 3 143 3 42 255 92 3 143 3 43 255 113 3 143 3 44 255 92 3 143 3 45 255 113 3 143 3 46 255 92 3 143 3 47 255 113 3 143 3 48 255 92 3 143 3 49 255 113 3 143 3 50 255 92 3 143 3 51 255 113 3 143 3 52 255 92 3 143 3 54 255 113 3 143 3 56 255 113 3 143 3 58 255 113 3 143 3 60 255 113 3 143 3 64 255 113 3 143 3 66 255 113 3 143 3 68 255 113 3 143 3 73 255 215 3 143 3 74 255 113 3 143 3 75 255 215 3 143 3 76 255 113 3 143 3 77 255 215 3 143 3 78 255 113 3 143 3 79 255 215 3 143 3 81 255 215 3 143 3 82 255 113 3 143 3 83 255 215 3 143 3 84 255 113 3 143 3 85 255 215 3 143 3 86 255 113 3 143 3 87 255 215 3 143 3 88 255 113 3 143 3 89 255 215 3 143 3 90 255 113 3 143 3 91 255 215 3 143 3 92 255 113 3 143 3 93 255 215 3 143 3 94 255 113 3 143 3 95 255 215 3 143 3 96 255 113 3 143 3 98 255 154 3 143 3 100 255 154 3 143 3 102 255 154 3 143 3 104 255 154 3 143 3 106 255 154 3 143 3 108 255 154 3 143 3 110 255 154 3 143 3 112 255 215 3 143 3 143 0 41 3 144 0 5 0 41 3 144 0 10 0 41 3 144 2 7 0 41 3 144 2 11 0 41 0 0 0 0 0 26 1 62 0 1 0 0 0 0 0 0 0 57 0 0 0 1 0 0 0 0 0 1 0 9 0 57 0 1 0 0 0 0 0 2 0 7 0 66 0 1 0 0 0 0 0 3 0 30 0 73 0 1 0 0 0 0 0 4 0 9 0 57 0 1 0 0 0 0 0 5 0 12 0 103 0 1 0 0 0 0 0 6 0 8 0 115 0 1 0 0 0 0 0 7 0 82 0 123 0 1 0 0 0 0 0 8 0 20 0 205 0 1 0 0 0 0 0 11 0 28 0 225 0 1 0 0 0 0 0 12 0 46 0 253 0 1 0 0 0 0 0 13 0 46 1 43 0 1 0 0 0 0 0 14 0 42 1 89 0 3 0 1 4 9 0 0 0 114 1 131 0 3 0 1 4 9 0 1 0 18 1 245 0 3 0 1 4 9 0 2 0 14 2 7 0 3 0 1 4 9 0 3 0 60 2 21 0 3 0 1 4 9 0 4 0 18 1 245 0 3 0 1 4 9 0 5 0 24 2 81 0 3 0 1 4 9 0 6 0 16 2 105 0 3 0 1 4 9 0 7 0 164 2 121 0 3 0 1 4 9 0 8 0 40 3 29 0 3 0 1 4 9 0 11 0 56 3 69 0 3 0 1 4 9 0 12 0 92 3 125 0 3 0 1 4 9 0 13 0 92 3 217 0 3 0 1 4 9 0 14 0 84 4 53 68 105 103 105 116 105 122 101 100 32 100 97 116 97 32 99 111 112 121 114 105 103 104 116 32 169 32 50 48 49 48 45 50 48 49 49 44 32 71 111 111 103 108 101 32 67 111 114 112 111 114 97 116 105 111 110 46 79 112 101 110 32 83 97 110 115 82 101 103 117 108 97 114 65 115 99 101 110 100 101 114 32 45 32 79 112 101 110 32 83 97 110 115 32 66 117 105 108 100 32 49 48 48 86 101 114 115 105 111 110 32 49 46 49 48 79 112 101 110 83 97 110 115 79 112 101 110 32 83 97 110 115 32 105 115 32 97 32 116 114 97 100 101 109 97 114 107 32 111 102 32 71 111 111 103 108 101 32 97 110 100 32 109 97 121 32 98 101 32 114 101 103 105 115 116 101 114 101 100 32 105 110 32 99 101 114 116 97 105 110 32 106 117 114 105 115 100 105 99 116 105 111 110 115 46 65 115 99 101 110 100 101 114 32 67 111 114 112 111 114 97 116 105 111 110 104 116 116 112 58 47 47 119 119 119 46 97 115 99 101 110 100 101 114 99 111 114 112 46 99 111 109 47 104 116 116 112 58 47 47 119 119 119 46 97 115 99 101 110 100 101 114 99 111 114 112 46 99 111 109 47 116 121 112 101 100 101 115 105 103 110 101 114 115 46 104 116 109 108 76 105 99 101 110 115 101 100 32 117 110 100 101 114 32 116 104 101 32 65 112 97 99 104 101 32 76 105 99 101 110 115 101 44 32 86 101 114 115 105 111 110 32 50 46 48 104 116 116 112 58 47 47 119 119 119 46 97 112 97 99 104 101 46 111 114 103 47 108 105 99 101 110 115 101 115 47 76 73 67 69 78 83 69 45 50 46 48 0 68 0 105 0 103 0 105 0 116 0 105 0 122 0 101 0 100 0 32 0 100 0 97 0 116 0 97 0 32 0 99 0 111 0 112 0 121 0 114 0 105 0 103 0 104 0 116 0 32 0 169 0 32 0 50 0 48 0 49 0 48 0 45 0 50 0 48 0 49 0 49 0 44 0 32 0 71 0 111 0 111 0 103 0 108 0 101 0 32 0 67 0 111 0 114 0 112 0 111 0 114 0 97 0 116 0 105 0 111 0 110 0 46 0 79 0 112 0 101 0 110 0 32 0 83 0 97 0 110 0 115 0 82 0 101 0 103 0 117 0 108 0 97 0 114 0 65 0 115 0 99 0 101 0 110 0 100 0 101 0 114 0 32 0 45 0 32 0 79 0 112 0 101 0 110 0 32 0 83 0 97 0 110 0 115 0 32 0 66 0 117 0 105 0 108 0 100 0 32 0 49 0 48 0 48 0 86 0 101 0 114 0 115 0 105 0 111 0 110 0 32 0 49 0 46 0 49 0 48 0 79 0 112 0 101 0 110 0 83 0 97 0 110 0 115 0 79 0 112 0 101 0 110 0 32 0 83 0 97 0 110 0 115 0 32 0 105 0 115 0 32 0 97 0 32 0 116 0 114 0 97 0 100 0 101 0 109 0 97 0 114 0 107 0 32 0 111 0 102 0 32 0 71 0 111 0 111 0 103 0 108 0 101 0 32 0 97 0 110 0 100 0 32 0 109 0 97 0 121 0 32 0 98 0 101 0 32 0 114 0 101 0 103 0 105 0 115 0 116 0 101 0 114 0 101 0 100 0 32 0 105 0 110 0 32 0 99 0 101 0 114 0 116 0 97 0 105 0 110 0 32 0 106 0 117 0 114 0 105 0 115 0 100 0 105 0 99 0 116 0 105 0 111 0 110 0 115 0 46 0 65 0 115 0 99 0 101 0 110 0 100 0 101 0 114 0 32 0 67 0 111 0 114 0 112 0 111 0 114 0 97 0 116 0 105 0 111 0 110 0 104 0 116 0 116 0 112 0 58 0 47 0 47 0 119 0 119 0 119 0 46 0 97 0 115 0 99 0 101 0 110 0 100 0 101 0 114 0 99 0 111 0 114 0 112 0 46 0 99 0 111 0 109 0 47 0 104 0 116 0 116 0 112 0 58 0 47 0 47 0 119 0 119 0 119 0 46 0 97 0 115 0 99 0 101 0 110 0 100 0 101 0 114 0 99 0 111 0 114 0 112 0 46 0 99 0 111 0 109 0 47 0 116 0 121 0 112 0 101 0 100 0 101 0 115 0 105 0 103 0 110 0 101 0 114 0 115 0 46 0 104 0 116 0 109 0 108 0 76 0 105 0 99 0 101 0 110 0 115 0 101 0 100 0 32 0 117 0 110 0 100 0 101 0 114 0 32 0 116 0 104 0 101 0 32 0 65 0 112 0 97 0 99 0 104 0 101 0 32 0 76 0 105 0 99 0 101 0 110 0 115 0 101 0 44 0 32 0 86 0 101 0 114 0 115 0 105 0 111 0 110 0 32 0 50 0 46 0 48 0 104 0 116 0 116 0 112 0 58 0 47 0 47 0 119 0 119 0 119 0 46 0 97 0 112 0 97 0 99 0 104 0 101 0 46 0 111 0 114 0 103 0 47 0 108 0 105 0 99 0 101 0 110 0 115 0 101 0 115 0 47 0 76 0 73 0 67 0 69 0 78 0 83 0 69 0 45 0 50 0 46 0 48 0 0 2 0 0 0 0 0 0 255 102 0 102 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 170 1 2 1 3 1 4 1 5 1 6 1 7 1 8 1 9 1 10 1 11 1 12 1 13 1 14 1 15 1 16 1 17 1 18 1 19 1 20 1 21 1 22 1 23 1 24 1 25 1 26 1 27 1 28 1 29 1 30 1 31 1 32 1 33 1 34 1 35 1 36 1 37 1 38 1 39 1 40 1 41 1 42 1 43 1 44 1 45 1 46 1 47 1 48 1 49 1 50 1 51 1 52 1 53 1 54 1 55 1 56 1 57 1 58 1 59 1 60 1 61 1 62 1 63 1 64 1 65 1 66 1 67 1 68 1 69 1 70 1 71 1 72 1 73 1 74 1 75 1 76 1 77 1 78 1 79 1 80 1 81 1 82 1 83 1 84 1 85 1 86 1 87 1 88 1 89 1 90 1 91 1 92 1 93 1 94 1 95 1 96 1 97 1 98 1 99 1 100 1 101 1 102 1 103 1 104 1 105 1 106 1 107 1 108 1 109 1 110 1 111 1 112 1 113 1 114 1 115 1 116 1 117 1 118 1 119 1 120 1 121 1 122 1 123 1 124 1 125 1 126 1 127 1 128 1 129 1 130 1 131 1 132 1 133 1 134 1 135 1 136 1 137 1 138 1 139 1 140 1 141 1 142 1 143 1 144 1 145 1 146 1 147 1 148 1 149 1 150 1 151 1 152 1 153 1 154 1 155 1 156 1 157 1 158 1 159 1 160 1 161 1 162 1 163 1 164 1 165 1 166 1 167 1 168 1 169 1 170 1 171 1 172 1 173 1 174 1 175 1 176 1 177 1 178 1 179 1 180 1 181 1 182 1 183 1 184 1 185 1 186 1 187 1 188 1 189 1 190 1 191 1 192 1 193 1 194 1 195 1 196 1 197 1 198 1 199 1 200 1 201 1 202 1 203 1 204 1 205 1 206 1 207 1 208 1 209 1 210 1 211 1 212 1 213 1 214 1 215 1 216 1 217 1 218 1 219 1 220 1 221 1 222 1 223 1 224 1 225 1 226 1 227 1 228 1 229 1 230 1 231 1 232 1 233 1 234 1 235 1 236 1 237 1 238 1 239 1 240 1 241 1 242 1 243 1 244 1 245 1 246 1 247 1 248 1 249 1 250 1 251 1 252 1 253 1 254 1 255 2 0 2 1 2 2 2 3 2 4 2 5 2 6 2 7 2 8 2 9 2 10 2 11 2 12 2 13 2 14 2 15 2 16 2 17 2 18 2 19 2 20 2 21 2 22 2 23 2 24 2 25 2 26 2 27 2 28 2 29 2 30 2 31 2 32 2 33 2 34 2 35 2 36 2 37 2 38 2 39 2 40 2 41 2 42 2 43 2 44 2 45 2 46 2 47 2 48 2 49 2 50 2 51 2 52 2 53 2 54 2 55 2 56 2 57 2 58 2 59 2 60 2 61 2 62 2 63 2 64 2 65 2 66 2 67 2 68 2 69 2 70 2 71 2 72 2 73 2 74 2 75 2 76 2 77 2 78 2 79 2 80 2 81 2 82 2 83 2 84 2 85 2 86 2 87 2 88 2 89 2 90 2 91 2 92 2 93 2 94 2 95 2 96 2 97 2 98 2 99 2 100 2 101 2 102 2 103 2 104 2 105 2 106 2 107 2 108 2 109 2 110 2 111 2 112 2 113 2 114 2 115 2 116 2 117 2 118 2 119 2 120 2 121 2 122 2 123 2 124 2 125 2 126 2 127 2 128 2 129 2 130 2 131 2 132 2 133 2 134 2 135 2 136 2 137 2 138 2 139 2 140 2 141 2 142 2 143 2 144 2 145 2 146 2 147 2 148 2 149 2 150 2 151 2 152 2 153 2 154 2 155 2 156 2 157 2 158 2 159 2 160 2 161 2 162 2 163 2 164 2 165 2 166 2 167 2 168 2 169 2 170 2 171 2 172 2 173 2 174 2 175 2 176 2 177 2 178 2 179 2 180 2 181 2 182 2 183 2 184 2 185 2 186 2 187 2 188 2 189 2 190 2 191 2 192 2 193 2 194 2 195 2 196 2 197 2 198 2 199 2 200 2 201 2 202 2 203 2 204 2 205 2 206 2 207 2 208 2 209 2 210 2 211 2 212 2 213 2 214 2 215 2 216 2 217 2 218 2 219 2 220 2 221 2 222 2 223 2 224 2 225 2 226 2 227 2 228 2 229 2 230 2 231 2 232 2 233 2 234 2 235 2 236 2 237 2 238 2 239 2 240 2 241 2 242 2 243 2 244 2 245 2 246 2 247 2 248 2 249 2 250 2 251 2 252 2 253 2 254 2 255 3 0 3 1 3 2 3 3 3 4 3 5 3 6 3 7 3 8 3 9 3 10 3 11 3 12 3 13 3 14 3 15 3 16 3 17 3 18 3 19 3 20 3 21 3 22 3 23 3 24 3 25 3 26 3 27 3 28 3 29 3 30 3 31 3 32 3 33 3 34 3 35 3 36 3 37 3 38 3 39 3 40 3 41 3 42 3 43 3 44 3 45 3 46 3 47 3 48 3 49 3 50 3 51 3 52 3 53 3 54 3 55 3 56 3 57 3 58 3 59 3 60 3 61 3 62 3 63 3 64 3 65 3 66 3 67 3 68 3 69 3 70 3 71 3 72 3 73 3 74 3 75 3 76 3 77 3 78 3 79 3 80 3 81 3 82 3 83 3 84 3 85 3 86 3 87 3 88 3 89 3 90 3 91 3 92 3 93 3 94 3 95 3 96 3 97 3 98 3 99 3 100 3 101 3 102 3 103 3 104 3 105 3 106 3 107 3 108 3 109 3 110 3 111 3 112 3 113 3 114 3 115 3 116 3 117 3 118 3 119 3 120 3 121 3 122 3 123 3 124 3 125 3 126 3 127 3 128 3 129 3 130 3 131 3 132 3 133 3 134 3 135 3 136 3 137 3 138 3 139 3 140 3 141 3 142 3 143 3 144 3 145 3 146 3 147 3 148 3 149 3 150 3 151 3 152 3 153 3 154 3 155 3 156 3 157 3 158 3 159 3 160 3 161 3 162 3 163 3 164 3 165 3 166 3 167 3 168 3 169 3 170 3 171 3 172 3 173 3 174 3 175 3 176 3 177 3 178 3 179 3 180 3 181 3 182 3 183 3 184 3 185 3 186 3 187 3 188 3 189 3 190 3 191 3 192 3 193 3 194 3 195 3 196 3 197 3 198 3 199 3 200 3 201 3 202 3 203 3 204 3 205 3 206 3 207 3 208 3 209 3 210 3 211 3 212 3 213 3 214 3 215 3 216 3 217 3 218 3 219 3 220 3 221 3 222 3 223 3 224 3 225 3 226 3 227 3 228 3 229 3 230 3 231 3 232 3 233 3 234 3 235 3 236 3 237 3 238 3 239 3 240 3 241 3 242 3 243 3 244 3 245 3 246 3 247 3 248 3 249 3 250 3 251 3 252 3 253 3 254 3 255 4 0 4 1 4 2 4 3 4 4 4 5 4 6 4 7 4 8 4 9 4 10 4 11 4 12 4 13 4 14 4 15 4 16 4 17 4 18 4 19 4 20 4 21 4 22 4 23 4 24 4 25 4 26 4 27 4 28 4 29 4 30 4 31 4 32 4 33 4 34 4 35 4 36 4 37 4 38 4 39 4 40 4 41 4 42 4 43 4 44 4 45 4 46 4 47 4 48 4 49 4 50 4 51 4 52 4 53 4 54 4 55 4 56 4 57 4 58 4 59 4 60 4 61 4 62 4 63 4 64 4 65 4 66 4 67 4 68 4 69 4 70 4 71 4 72 4 73 4 74 4 75 4 76 4 77 4 78 4 79 4 80 4 81 4 82 4 83 4 84 4 85 4 86 4 87 4 88 4 89 4 90 4 91 4 92 4 93 4 94 4 95 4 96 4 97 4 98 4 99 4 100 4 101 4 102 4 103 4 104 4 105 4 106 4 107 4 108 4 109 4 110 4 111 4 112 4 113 4 114 4 115 4 116 4 117 4 118 4 119 4 120 4 121 4 122 4 123 4 124 4 125 4 126 4 127 4 128 4 129 4 130 4 131 4 132 4 133 4 134 4 135 4 136 4 137 4 138 4 139 4 140 4 141 4 142 4 143 4 144 4 145 4 146 4 147 4 148 4 149 4 150 4 151 4 152 4 153 4 154 4 155 4 156 4 157 4 158 4 159 4 160 4 161 4 162 4 163 4 164 4 165 4 166 4 167 4 168 4 169 4 170 4 171 7 46 110 111 116 100 101 102 4 110 117 108 108 16 110 111 110 109 97 114 107 105 110 103 114 101 116 117 114 110 5 115 112 97 99 101 6 101 120 99 108 97 109 8 113 117 111 116 101 100 98 108 10 110 117 109 98 101 114 115 105 103 110 6 100 111 108 108 97 114 7 112 101 114 99 101 110 116 9 97 109 112 101 114 115 97 110 100 11 113 117 111 116 101 115 105 110 103 108 101 9 112 97 114 101 110 108 101 102 116 10 112 97 114 101 110 114 105 103 104 116 8 97 115 116 101 114 105 115 107 4 112 108 117 115 5 99 111 109 109 97 6 104 121 112 104 101 110 6 112 101 114 105 111 100 5 115 108 97 115 104 4 122 101 114 111 3 111 110 101 3 116 119 111 5 116 104 114 101 101 4 102 111 117 114 4 102 105 118 101 3 115 105 120 5 115 101 118 101 110 5 101 105 103 104 116 4 110 105 110 101 5 99 111 108 111 110 9 115 101 109 105 99 111 108 111 110 4 108 101 115 115 5 101 113 117 97 108 7 103 114 101 97 116 101 114 8 113 117 101 115 116 105 111 110 2 97 116 1 65 1 66 1 67 1 68 1 69 1 70 1 71 1 72 5 73 46 97 108 116 1 74 1 75 1 76 1 77 1 78 1 79 1 80 1 81 1 82 1 83 1 84 1 85 1 86 1 87 1 88 1 89 1 90 11 98 114 97 99 107 101 116 108 101 102 116 9 98 97 99 107 115 108 97 115 104 12 98 114 97 99 107 101 116 114 105 103 104 116 11 97 115 99 105 105 99 105 114 99 117 109 10 117 110 100 101 114 115 99 111 114 101 5 103 114 97 118 101 1 97 1 98 1 99 1 100 1 101 1 102 1 103 1 104 1 105 1 106 1 107 1 108 1 109 1 110 1 111 1 112 1 113 1 114 1 115 1 116 1 117 1 118 1 119 1 120 1 121 1 122 9 98 114 97 99 101 108 101 102 116 3 98 97 114 10 98 114 97 99 101 114 105 103 104 116 10 97 115 99 105 105 116 105 108 100 101 16 110 111 110 98 114 101 97 107 105 110 103 115 112 97 99 101 10 101 120 99 108 97 109 100 111 119 110 4 99 101 110 116 8 115 116 101 114 108 105 110 103 8 99 117 114 114 101 110 99 121 3 121 101 110 9 98 114 111 107 101 110 98 97 114 7 115 101 99 116 105 111 110 8 100 105 101 114 101 115 105 115 9 99 111 112 121 114 105 103 104 116 11 111 114 100 102 101 109 105 110 105 110 101 13 103 117 105 108 108 101 109 111 116 108 101 102 116 10 108 111 103 105 99 97 108 110 111 116 7 117 110 105 48 48 65 68 10 114 101 103 105 115 116 101 114 101 100 9 111 118 101 114 115 99 111 114 101 6 100 101 103 114 101 101 9 112 108 117 115 109 105 110 117 115 11 116 119 111 115 117 112 101 114 105 111 114 13 116 104 114 101 101 115 117 112 101 114 105 111 114 5 97 99 117 116 101 2 109 117 9 112 97 114 97 103 114 97 112 104 14 112 101 114 105 111 100 99 101 110 116 101 114 101 100 7 99 101 100 105 108 108 97 11 111 110 101 115 117 112 101 114 105 111 114 12 111 114 100 109 97 115 99 117 108 105 110 101 14 103 117 105 108 108 101 109 111 116 114 105 103 104 116 10 111 110 101 113 117 97 114 116 101 114 7 111 110 101 104 97 108 102 13 116 104 114 101 101 113 117 97 114 116 101 114 115 12 113 117 101 115 116 105 111 110 100 111 119 110 6 65 103 114 97 118 101 6 65 97 99 117 116 101 11 65 99 105 114 99 117 109 102 108 101 120 6 65 116 105 108 100 101 9 65 100 105 101 114 101 115 105 115 5 65 114 105 110 103 2 65 69 8 67 99 101 100 105 108 108 97 6 69 103 114 97 118 101 6 69 97 99 117 116 101 11 69 99 105 114 99 117 109 102 108 101 120 9 69 100 105 101 114 101 115 105 115 10 73 103 114 97 118 101 46 97 108 116 10 73 97 99 117 116 101 46 97 108 116 15 73 99 105 114 99 117 109 102 108 101 120 46 97 108 116 13 73 100 105 101 114 101 115 105 115 46 97 108 116 3 69 116 104 6 78 116 105 108 100 101 6 79 103 114 97 118 101 6 79 97 99 117 116 101 11 79 99 105 114 99 117 109 102 108 101 120 6 79 116 105 108 100 101 9 79 100 105 101 114 101 115 105 115 8 109 117 108 116 105 112 108 121 6 79 115 108 97 115 104 6 85 103 114 97 118 101 6 85 97 99 117 116 101 11 85 99 105 114 99 117 109 102 108 101 120 9 85 100 105 101 114 101 115 105 115 6 89 97 99 117 116 101 5 84 104 111 114 110 10 103 101 114 109 97 110 100 98 108 115 6 97 103 114 97 118 101 6 97 97 99 117 116 101 11 97 99 105 114 99 117 109 102 108 101 120 6 97 116 105 108 100 101 9 97 100 105 101 114 101 115 105 115 5 97 114 105 110 103 2 97 101 8 99 99 101 100 105 108 108 97 6 101 103 114 97 118 101 6 101 97 99 117 116 101 11 101 99 105 114 99 117 109 102 108 101 120 9 101 100 105 101 114 101 115 105 115 6 105 103 114 97 118 101 6 105 97 99 117 116 101 11 105 99 105 114 99 117 109 102 108 101 120 9 105 100 105 101 114 101 115 105 115 3 101 116 104 6 110 116 105 108 100 101 6 111 103 114 97 118 101 6 111 97 99 117 116 101 11 111 99 105 114 99 117 109 102 108 101 120 6 111 116 105 108 100 101 9 111 100 105 101 114 101 115 105 115 6 100 105 118 105 100 101 6 111 115 108 97 115 104 6 117 103 114 97 118 101 6 117 97 99 117 116 101 11 117 99 105 114 99 117 109 102 108 101 120 9 117 100 105 101 114 101 115 105 115 6 121 97 99 117 116 101 5 116 104 111 114 110 9 121 100 105 101 114 101 115 105 115 7 65 109 97 99 114 111 110 7 97 109 97 99 114 111 110 6 65 98 114 101 118 101 6 97 98 114 101 118 101 7 65 111 103 111 110 101 107 7 97 111 103 111 110 101 107 6 67 97 99 117 116 101 6 99 97 99 117 116 101 11 67 99 105 114 99 117 109 102 108 101 120 11 99 99 105 114 99 117 109 102 108 101 120 4 67 100 111 116 4 99 100 111 116 6 67 99 97 114 111 110 6 99 99 97 114 111 110 6 68 99 97 114 111 110 6 100 99 97 114 111 110 6 68 99 114 111 97 116 6 100 99 114 111 97 116 7 69 109 97 99 114 111 110 7 101 109 97 99 114 111 110 6 69 98 114 101 118 101 6 101 98 114 101 118 101 10 69 100 111 116 97 99 99 101 110 116 10 101 100 111 116 97 99 99 101 110 116 7 69 111 103 111 110 101 107 7 101 111 103 111 110 101 107 6 69 99 97 114 111 110 6 101 99 97 114 111 110 11 71 99 105 114 99 117 109 102 108 101 120 11 103 99 105 114 99 117 109 102 108 101 120 6 71 98 114 101 118 101 6 103 98 114 101 118 101 4 71 100 111 116 4 103 100 111 116 12 71 99 111 109 109 97 97 99 99 101 110 116 12 103 99 111 109 109 97 97 99 99 101 110 116 11 72 99 105 114 99 117 109 102 108 101 120 11 104 99 105 114 99 117 109 102 108 101 120 4 72 98 97 114 4 104 98 97 114 10 73 116 105 108 100 101 46 97 108 116 6 105 116 105 108 100 101 11 73 109 97 99 114 111 110 46 97 108 116 7 105 109 97 99 114 111 110 10 73 98 114 101 118 101 46 97 108 116 6 105 98 114 101 118 101 11 73 111 103 111 110 101 107 46 97 108 116 7 105 111 103 111 110 101 107 14 73 100 111 116 97 99 99 101 110 116 46 97 108 116 8 100 111 116 108 101 115 115 105 6 73 74 46 97 108 116 2 105 106 11 74 99 105 114 99 117 109 102 108 101 120 11 106 99 105 114 99 117 109 102 108 101 120 12 75 99 111 109 109 97 97 99 99 101 110 116 12 107 99 111 109 109 97 97 99 99 101 110 116 12 107 103 114 101 101 110 108 97 110 100 105 99 6 76 97 99 117 116 101 6 108 97 99 117 116 101 12 76 99 111 109 109 97 97 99 99 101 110 116 12 108 99 111 109 109 97 97 99 99 101 110 116 6 76 99 97 114 111 110 6 108 99 97 114 111 110 4 76 100 111 116 4 108 100 111 116 6 76 115 108 97 115 104 6 108 115 108 97 115 104 6 78 97 99 117 116 101 6 110 97 99 117 116 101 12 78 99 111 109 109 97 97 99 99 101 110 116 12 110 99 111 109 109 97 97 99 99 101 110 116 6 78 99 97 114 111 110 6 110 99 97 114 111 110 11 110 97 112 111 115 116 114 111 112 104 101 3 69 110 103 3 101 110 103 7 79 109 97 99 114 111 110 7 111 109 97 99 114 111 110 6 79 98 114 101 118 101 6 111 98 114 101 118 101 13 79 104 117 110 103 97 114 117 109 108 97 117 116 13 111 104 117 110 103 97 114 117 109 108 97 117 116 2 79 69 2 111 101 6 82 97 99 117 116 101 6 114 97 99 117 116 101 12 82 99 111 109 109 97 97 99 99 101 110 116 12 114 99 111 109 109 97 97 99 99 101 110 116 6 82 99 97 114 111 110 6 114 99 97 114 111 110 6 83 97 99 117 116 101 6 115 97 99 117 116 101 11 83 99 105 114 99 117 109 102 108 101 120 11 115 99 105 114 99 117 109 102 108 101 120 8 83 99 101 100 105 108 108 97 8 115 99 101 100 105 108 108 97 6 83 99 97 114 111 110 6 115 99 97 114 111 110 12 84 99 111 109 109 97 97 99 99 101 110 116 12 116 99 111 109 109 97 97 99 99 101 110 116 6 84 99 97 114 111 110 6 116 99 97 114 111 110 4 84 98 97 114 4 116 98 97 114 6 85 116 105 108 100 101 6 117 116 105 108 100 101 7 85 109 97 99 114 111 110 7 117 109 97 99 114 111 110 6 85 98 114 101 118 101 6 117 98 114 101 118 101 5 85 114 105 110 103 5 117 114 105 110 103 13 85 104 117 110 103 97 114 117 109 108 97 117 116 13 117 104 117 110 103 97 114 117 109 108 97 117 116 7 85 111 103 111 110 101 107 7 117 111 103 111 110 101 107 11 87 99 105 114 99 117 109 102 108 101 120 11 119 99 105 114 99 117 109 102 108 101 120 11 89 99 105 114 99 117 109 102 108 101 120 11 121 99 105 114 99 117 109 102 108 101 120 9 89 100 105 101 114 101 115 105 115 6 90 97 99 117 116 101 6 122 97 99 117 116 101 10 90 100 111 116 97 99 99 101 110 116 10 122 100 111 116 97 99 99 101 110 116 6 90 99 97 114 111 110 6 122 99 97 114 111 110 5 108 111 110 103 115 6 102 108 111 114 105 110 10 65 114 105 110 103 97 99 117 116 101 10 97 114 105 110 103 97 99 117 116 101 7 65 69 97 99 117 116 101 7 97 101 97 99 117 116 101 11 79 115 108 97 115 104 97 99 117 116 101 11 111 115 108 97 115 104 97 99 117 116 101 12 83 99 111 109 109 97 97 99 99 101 110 116 12 115 99 111 109 109 97 97 99 99 101 110 116 10 99 105 114 99 117 109 102 108 101 120 5 99 97 114 111 110 6 109 97 99 114 111 110 5 98 114 101 118 101 9 100 111 116 97 99 99 101 110 116 4 114 105 110 103 6 111 103 111 110 101 107 5 116 105 108 100 101 12 104 117 110 103 97 114 117 109 108 97 117 116 5 116 111 110 111 115 13 100 105 101 114 101 115 105 115 116 111 110 111 115 10 65 108 112 104 97 116 111 110 111 115 9 97 110 111 116 101 108 101 105 97 12 69 112 115 105 108 111 110 116 111 110 111 115 8 69 116 97 116 111 110 111 115 13 73 111 116 97 116 111 110 111 115 46 97 108 116 12 79 109 105 99 114 111 110 116 111 110 111 115 12 85 112 115 105 108 111 110 116 111 110 111 115 10 79 109 101 103 97 116 111 110 111 115 17 105 111 116 97 100 105 101 114 101 115 105 115 116 111 110 111 115 5 65 108 112 104 97 4 66 101 116 97 5 71 97 109 109 97 7 117 110 105 48 51 57 52 7 69 112 115 105 108 111 110 4 90 101 116 97 3 69 116 97 5 84 104 101 116 97 8 73 111 116 97 46 97 108 116 5 75 97 112 112 97 6 76 97 109 98 100 97 2 77 117 2 78 117 2 88 105 7 79 109 105 99 114 111 110 2 80 105 3 82 104 111 5 83 105 103 109 97 3 84 97 117 7 85 112 115 105 108 111 110 3 80 104 105 3 67 104 105 3 80 115 105 7 117 110 105 48 51 65 57 16 73 111 116 97 100 105 101 114 101 115 105 115 46 97 108 116 15 85 112 115 105 108 111 110 100 105 101 114 101 115 105 115 10 97 108 112 104 97 116 111 110 111 115 12 101 112 115 105 108 111 110 116 111 110 111 115 8 101 116 97 116 111 110 111 115 9 105 111 116 97 116 111 110 111 115 20 117 112 115 105 108 111 110 100 105 101 114 101 115 105 115 116 111 110 111 115 5 97 108 112 104 97 4 98 101 116 97 5 103 97 109 109 97 5 100 101 108 116 97 7 101 112 115 105 108 111 110 4 122 101 116 97 3 101 116 97 5 116 104 101 116 97 4 105 111 116 97 5 107 97 112 112 97 6 108 97 109 98 100 97 7 117 110 105 48 51 66 67 2 110 117 2 120 105 7 111 109 105 99 114 111 110 2 112 105 3 114 104 111 6 115 105 103 109 97 49 5 115 105 103 109 97 3 116 97 117 7 117 112 115 105 108 111 110 3 112 104 105 3 99 104 105 3 112 115 105 5 111 109 101 103 97 12 105 111 116 97 100 105 101 114 101 115 105 115 15 117 112 115 105 108 111 110 100 105 101 114 101 115 105 115 12 111 109 105 99 114 111 110 116 111 110 111 115 12 117 112 115 105 108 111 110 116 111 110 111 115 10 111 109 101 103 97 116 111 110 111 115 9 97 102 105 105 49 48 48 50 51 9 97 102 105 105 49 48 48 53 49 9 97 102 105 105 49 48 48 53 50 9 97 102 105 105 49 48 48 53 51 9 97 102 105 105 49 48 48 53 52 13 97 102 105 105 49 48 48 53 53 46 97 108 116 13 97 102 105 105 49 48 48 53 54 46 97 108 116 9 97 102 105 105 49 48 48 53 55 9 97 102 105 105 49 48 48 53 56 9 97 102 105 105 49 48 48 53 57 9 97 102 105 105 49 48 48 54 48 9 97 102 105 105 49 48 48 54 49 9 97 102 105 105 49 48 48 54 50 9 97 102 105 105 49 48 49 52 53 9 97 102 105 105 49 48 48 49 55 9 97 102 105 105 49 48 48 49 56 9 97 102 105 105 49 48 48 49 57 9 97 102 105 105 49 48 48 50 48 9 97 102 105 105 49 48 48 50 49 9 97 102 105 105 49 48 48 50 50 9 97 102 105 105 49 48 48 50 52 9 97 102 105 105 49 48 48 50 53 9 97 102 105 105 49 48 48 50 54 9 97 102 105 105 49 48 48 50 55 9 97 102 105 105 49 48 48 50 56 9 97 102 105 105 49 48 48 50 57 9 97 102 105 105 49 48 48 51 48 9 97 102 105 105 49 48 48 51 49 9 97 102 105 105 49 48 48 51 50 9 97 102 105 105 49 48 48 51 51 9 97 102 105 105 49 48 48 51 52 9 97 102 105 105 49 48 48 51 53 9 97 102 105 105 49 48 48 51 54 9 97 102 105 105 49 48 48 51 55 9 97 102 105 105 49 48 48 51 56 9 97 102 105 105 49 48 48 51 57 9 97 102 105 105 49 48 48 52 48 9 97 102 105 105 49 48 48 52 49 9 97 102 105 105 49 48 48 52 50 9 97 102 105 105 49 48 48 52 51 9 97 102 105 105 49 48 48 52 52 9 97 102 105 105 49 48 48 52 53 9 97 102 105 105 49 48 48 52 54 9 97 102 105 105 49 48 48 52 55 9 97 102 105 105 49 48 48 52 56 9 97 102 105 105 49 48 48 52 57 9 97 102 105 105 49 48 48 54 53 9 97 102 105 105 49 48 48 54 54 9 97 102 105 105 49 48 48 54 55 9 97 102 105 105 49 48 48 54 56 9 97 102 105 105 49 48 48 54 57 9 97 102 105 105 49 48 48 55 48 9 97 102 105 105 49 48 48 55 50 9 97 102 105 105 49 48 48 55 51 9 97 102 105 105 49 48 48 55 52 9 97 102 105 105 49 48 48 55 53 9 97 102 105 105 49 48 48 55 54 9 97 102 105 105 49 48 48 55 55 9 97 102 105 105 49 48 48 55 56 9 97 102 105 105 49 48 48 55 57 9 97 102 105 105 49 48 48 56 48 9 97 102 105 105 49 48 48 56 49 9 97 102 105 105 49 48 48 56 50 9 97 102 105 105 49 48 48 56 51 9 97 102 105 105 49 48 48 56 52 9 97 102 105 105 49 48 48 56 53 9 97 102 105 105 49 48 48 56 54 9 97 102 105 105 49 48 48 56 55 9 97 102 105 105 49 48 48 56 56 9 97 102 105 105 49 48 48 56 57 9 97 102 105 105 49 48 48 57 48 9 97 102 105 105 49 48 48 57 49 9 97 102 105 105 49 48 48 57 50 9 97 102 105 105 49 48 48 57 51 9 97 102 105 105 49 48 48 57 52 9 97 102 105 105 49 48 48 57 53 9 97 102 105 105 49 48 48 57 54 9 97 102 105 105 49 48 48 57 55 9 97 102 105 105 49 48 48 55 49 9 97 102 105 105 49 48 48 57 57 9 97 102 105 105 49 48 49 48 48 9 97 102 105 105 49 48 49 48 49 9 97 102 105 105 49 48 49 48 50 9 97 102 105 105 49 48 49 48 51 9 97 102 105 105 49 48 49 48 52 9 97 102 105 105 49 48 49 48 53 9 97 102 105 105 49 48 49 48 54 9 97 102 105 105 49 48 49 48 55 9 97 102 105 105 49 48 49 48 56 9 97 102 105 105 49 48 49 48 57 9 97 102 105 105 49 48 49 49 48 9 97 102 105 105 49 48 49 57 51 9 97 102 105 105 49 48 48 53 48 9 97 102 105 105 49 48 48 57 56 6 87 103 114 97 118 101 6 119 103 114 97 118 101 6 87 97 99 117 116 101 6 119 97 99 117 116 101 9 87 100 105 101 114 101 115 105 115 9 119 100 105 101 114 101 115 105 115 6 89 103 114 97 118 101 6 121 103 114 97 118 101 6 101 110 100 97 115 104 6 101 109 100 97 115 104 9 97 102 105 105 48 48 50 48 56 13 117 110 100 101 114 115 99 111 114 101 100 98 108 9 113 117 111 116 101 108 101 102 116 10 113 117 111 116 101 114 105 103 104 116 14 113 117 111 116 101 115 105 110 103 108 98 97 115 101 13 113 117 111 116 101 114 101 118 101 114 115 101 100 12 113 117 111 116 101 100 98 108 108 101 102 116 13 113 117 111 116 101 100 98 108 114 105 103 104 116 12 113 117 111 116 101 100 98 108 98 97 115 101 6 100 97 103 103 101 114 9 100 97 103 103 101 114 100 98 108 6 98 117 108 108 101 116 8 101 108 108 105 112 115 105 115 11 112 101 114 116 104 111 117 115 97 110 100 6 109 105 110 117 116 101 6 115 101 99 111 110 100 13 103 117 105 108 115 105 110 103 108 108 101 102 116 14 103 117 105 108 115 105 110 103 108 114 105 103 104 116 9 101 120 99 108 97 109 100 98 108 8 102 114 97 99 116 105 111 110 9 110 115 117 112 101 114 105 111 114 5 102 114 97 110 99 9 97 102 105 105 48 56 57 52 49 6 112 101 115 101 116 97 4 69 117 114 111 9 97 102 105 105 54 49 50 52 56 9 97 102 105 105 54 49 50 56 57 9 97 102 105 105 54 49 51 53 50 9 116 114 97 100 101 109 97 114 107 5 79 109 101 103 97 9 101 115 116 105 109 97 116 101 100 9 111 110 101 101 105 103 104 116 104 12 116 104 114 101 101 101 105 103 104 116 104 115 11 102 105 118 101 101 105 103 104 116 104 115 12 115 101 118 101 110 101 105 103 104 116 104 115 11 112 97 114 116 105 97 108 100 105 102 102 5 68 101 108 116 97 7 112 114 111 100 117 99 116 9 115 117 109 109 97 116 105 111 110 5 109 105 110 117 115 7 114 97 100 105 99 97 108 8 105 110 102 105 110 105 116 121 8 105 110 116 101 103 114 97 108 11 97 112 112 114 111 120 101 113 117 97 108 8 110 111 116 101 113 117 97 108 9 108 101 115 115 101 113 117 97 108 12 103 114 101 97 116 101 114 101 113 117 97 108 7 108 111 122 101 110 103 101 7 117 110 105 70 66 48 49 7 117 110 105 70 66 48 50 13 99 121 114 105 108 108 105 99 98 114 101 118 101 8 100 111 116 108 101 115 115 106 16 99 97 114 111 110 99 111 109 109 97 97 99 99 101 110 116 11 99 111 109 109 97 97 99 99 101 110 116 17 99 111 109 109 97 97 99 99 101 110 116 114 111 116 97 116 101 12 122 101 114 111 115 117 112 101 114 105 111 114 12 102 111 117 114 115 117 112 101 114 105 111 114 12 102 105 118 101 115 117 112 101 114 105 111 114 11 115 105 120 115 117 112 101 114 105 111 114 13 115 101 118 101 110 115 117 112 101 114 105 111 114 13 101 105 103 104 116 115 117 112 101 114 105 111 114 12 110 105 110 101 115 117 112 101 114 105 111 114 7 117 110 105 50 48 48 48 7 117 110 105 50 48 48 49 7 117 110 105 50 48 48 50 7 117 110 105 50 48 48 51 7 117 110 105 50 48 48 52 7 117 110 105 50 48 48 53 7 117 110 105 50 48 48 54 7 117 110 105 50 48 48 55 7 117 110 105 50 48 48 56 7 117 110 105 50 48 48 57 7 117 110 105 50 48 48 65 7 117 110 105 50 48 48 66 7 117 110 105 70 69 70 70 7 117 110 105 70 70 70 67 7 117 110 105 70 70 70 68 7 117 110 105 48 49 70 48 7 117 110 105 48 50 66 67 7 117 110 105 48 51 68 49 7 117 110 105 48 51 68 50 7 117 110 105 48 51 68 54 7 117 110 105 49 69 51 69 7 117 110 105 49 69 51 70 7 117 110 105 49 69 48 48 7 117 110 105 49 69 48 49 7 117 110 105 49 70 52 68 7 117 110 105 48 50 70 51 9 100 97 115 105 97 111 120 105 97 7 117 110 105 70 66 48 51 7 117 110 105 70 66 48 52 5 79 104 111 114 110 5 111 104 111 114 110 5 85 104 111 114 110 5 117 104 111 114 110 7 117 110 105 48 51 48 48 7 117 110 105 48 51 48 49 7 117 110 105 48 51 48 51 4 104 111 111 107 8 100 111 116 98 101 108 111 119 7 117 110 105 48 52 48 48 7 117 110 105 48 52 48 68 7 117 110 105 48 52 53 48 7 117 110 105 48 52 53 68 7 117 110 105 48 52 54 48 7 117 110 105 48 52 54 49 7 117 110 105 48 52 54 50 7 117 110 105 48 52 54 51 7 117 110 105 48 52 54 52 7 117 110 105 48 52 54 53 7 117 110 105 48 52 54 54 7 117 110 105 48 52 54 55 7 117 110 105 48 52 54 56 7 117 110 105 48 52 54 57 7 117 110 105 48 52 54 65 7 117 110 105 48 52 54 66 7 117 110 105 48 52 54 67 7 117 110 105 48 52 54 68 7 117 110 105 48 52 54 69 7 117 110 105 48 52 54 70 7 117 110 105 48 52 55 48 7 117 110 105 48 52 55 49 7 117 110 105 48 52 55 50 7 117 110 105 48 52 55 51 7 117 110 105 48 52 55 52 7 117 110 105 48 52 55 53 7 117 110 105 48 52 55 54 7 117 110 105 48 52 55 55 7 117 110 105 48 52 55 56 7 117 110 105 48 52 55 57 7 117 110 105 48 52 55 65 7 117 110 105 48 52 55 66 7 117 110 105 48 52 55 67 7 117 110 105 48 52 55 68 7 117 110 105 48 52 55 69 7 117 110 105 48 52 55 70 7 117 110 105 48 52 56 48 7 117 110 105 48 52 56 49 7 117 110 105 48 52 56 50 7 117 110 105 48 52 56 51 7 117 110 105 48 52 56 52 7 117 110 105 48 52 56 53 7 117 110 105 48 52 56 54 7 117 110 105 48 52 56 56 7 117 110 105 48 52 56 57 7 117 110 105 48 52 56 65 7 117 110 105 48 52 56 66 7 117 110 105 48 52 56 67 7 117 110 105 48 52 56 68 7 117 110 105 48 52 56 69 7 117 110 105 48 52 56 70 7 117 110 105 48 52 57 50 7 117 110 105 48 52 57 51 7 117 110 105 48 52 57 52 7 117 110 105 48 52 57 53 7 117 110 105 48 52 57 54 7 117 110 105 48 52 57 55 7 117 110 105 48 52 57 56 7 117 110 105 48 52 57 57 7 117 110 105 48 52 57 65 7 117 110 105 48 52 57 66 7 117 110 105 48 52 57 67 7 117 110 105 48 52 57 68 7 117 110 105 48 52 57 69 7 117 110 105 48 52 57 70 7 117 110 105 48 52 65 48 7 117 110 105 48 52 65 49 7 117 110 105 48 52 65 50 7 117 110 105 48 52 65 51 7 117 110 105 48 52 65 52 7 117 110 105 48 52 65 53 7 117 110 105 48 52 65 54 7 117 110 105 48 52 65 55 7 117 110 105 48 52 65 56 7 117 110 105 48 52 65 57 7 117 110 105 48 52 65 65 7 117 110 105 48 52 65 66 7 117 110 105 48 52 65 67 7 117 110 105 48 52 65 68 7 117 110 105 48 52 65 69 7 117 110 105 48 52 65 70 7 117 110 105 48 52 66 48 7 117 110 105 48 52 66 49 7 117 110 105 48 52 66 50 7 117 110 105 48 52 66 51 7 117 110 105 48 52 66 52 7 117 110 105 48 52 66 53 7 117 110 105 48 52 66 54 7 117 110 105 48 52 66 55 7 117 110 105 48 52 66 56 7 117 110 105 48 52 66 57 7 117 110 105 48 52 66 65 7 117 110 105 48 52 66 66 7 117 110 105 48 52 66 67 7 117 110 105 48 52 66 68 7 117 110 105 48 52 66 69 7 117 110 105 48 52 66 70 11 117 110 105 48 52 67 48 46 97 108 116 7 117 110 105 48 52 67 49 7 117 110 105 48 52 67 50 7 117 110 105 48 52 67 51 7 117 110 105 48 52 67 52 7 117 110 105 48 52 67 53 7 117 110 105 48 52 67 54 7 117 110 105 48 52 67 55 7 117 110 105 48 52 67 56 7 117 110 105 48 52 67 57 7 117 110 105 48 52 67 65 7 117 110 105 48 52 67 66 7 117 110 105 48 52 67 67 7 117 110 105 48 52 67 68 7 117 110 105 48 52 67 69 11 117 110 105 48 52 67 70 46 97 108 116 7 117 110 105 48 52 68 48 7 117 110 105 48 52 68 49 7 117 110 105 48 52 68 50 7 117 110 105 48 52 68 51 7 117 110 105 48 52 68 52 7 117 110 105 48 52 68 53 7 117 110 105 48 52 68 54 7 117 110 105 48 52 68 55 7 117 110 105 48 52 68 56 7 117 110 105 48 52 68 57 7 117 110 105 48 52 68 65 7 117 110 105 48 52 68 66 7 117 110 105 48 52 68 67 7 117 110 105 48 52 68 68 7 117 110 105 48 52 68 69 7 117 110 105 48 52 68 70 7 117 110 105 48 52 69 48 7 117 110 105 48 52 69 49 7 117 110 105 48 52 69 50 7 117 110 105 48 52 69 51 7 117 110 105 48 52 69 52 7 117 110 105 48 52 69 53 7 117 110 105 48 52 69 54 7 117 110 105 48 52 69 55 7 117 110 105 48 52 69 56 7 117 110 105 48 52 69 57 7 117 110 105 48 52 69 65 7 117 110 105 48 52 69 66 7 117 110 105 48 52 69 67 7 117 110 105 48 52 69 68 7 117 110 105 48 52 69 69 7 117 110 105 48 52 69 70 7 117 110 105 48 52 70 48 7 117 110 105 48 52 70 49 7 117 110 105 48 52 70 50 7 117 110 105 48 52 70 51 7 117 110 105 48 52 70 52 7 117 110 105 48 52 70 53 7 117 110 105 48 52 70 54 7 117 110 105 48 52 70 55 7 117 110 105 48 52 70 56 7 117 110 105 48 52 70 57 7 117 110 105 48 52 70 65 7 117 110 105 48 52 70 66 7 117 110 105 48 52 70 67 7 117 110 105 48 52 70 68 7 117 110 105 48 52 70 69 7 117 110 105 48 52 70 70 7 117 110 105 48 53 48 48 7 117 110 105 48 53 48 49 7 117 110 105 48 53 48 50 7 117 110 105 48 53 48 51 7 117 110 105 48 53 48 52 7 117 110 105 48 53 48 53 7 117 110 105 48 53 48 54 7 117 110 105 48 53 48 55 7 117 110 105 48 53 48 56 7 117 110 105 48 53 48 57 7 117 110 105 48 53 48 65 7 117 110 105 48 53 48 66 7 117 110 105 48 53 48 67 7 117 110 105 48 53 48 68 7 117 110 105 48 53 48 69 7 117 110 105 48 53 48 70 7 117 110 105 48 53 49 48 7 117 110 105 48 53 49 49 7 117 110 105 48 53 49 50 7 117 110 105 48 53 49 51 7 117 110 105 49 69 65 48 7 117 110 105 49 69 65 49 7 117 110 105 49 69 65 50 7 117 110 105 49 69 65 51 7 117 110 105 49 69 65 52 7 117 110 105 49 69 65 53 7 117 110 105 49 69 65 54 7 117 110 105 49 69 65 55 7 117 110 105 49 69 65 56 7 117 110 105 49 69 65 57 7 117 110 105 49 69 65 65 7 117 110 105 49 69 65 66 7 117 110 105 49 69 65 67 7 117 110 105 49 69 65 68 7 117 110 105 49 69 65 69 7 117 110 105 49 69 65 70 7 117 110 105 49 69 66 48 7 117 110 105 49 69 66 49 7 117 110 105 49 69 66 50 7 117 110 105 49 69 66 51 7 117 110 105 49 69 66 52 7 117 110 105 49 69 66 53 7 117 110 105 49 69 66 54 7 117 110 105 49 69 66 55 7 117 110 105 49 69 66 56 7 117 110 105 49 69 66 57 7 117 110 105 49 69 66 65 7 117 110 105 49 69 66 66 7 117 110 105 49 69 66 67 7 117 110 105 49 69 66 68 7 117 110 105 49 69 66 69 7 117 110 105 49 69 66 70 7 117 110 105 49 69 67 48 7 117 110 105 49 69 67 49 7 117 110 105 49 69 67 50 7 117 110 105 49 69 67 51 7 117 110 105 49 69 67 52 7 117 110 105 49 69 67 53 7 117 110 105 49 69 67 54 7 117 110 105 49 69 67 55 11 117 110 105 49 69 67 56 46 97 108 116 7 117 110 105 49 69 67 57 11 117 110 105 49 69 67 65 46 97 108 116 7 117 110 105 49 69 67 66 7 117 110 105 49 69 67 67 7 117 110 105 49 69 67 68 7 117 110 105 49 69 67 69 7 117 110 105 49 69 67 70 7 117 110 105 49 69 68 48 7 117 110 105 49 69 68 49 7 117 110 105 49 69 68 50 7 117 110 105 49 69 68 51 7 117 110 105 49 69 68 52 7 117 110 105 49 69 68 53 7 117 110 105 49 69 68 54 7 117 110 105 49 69 68 55 7 117 110 105 49 69 68 56 7 117 110 105 49 69 68 57 7 117 110 105 49 69 68 65 7 117 110 105 49 69 68 66 7 117 110 105 49 69 68 67 7 117 110 105 49 69 68 68 7 117 110 105 49 69 68 69 7 117 110 105 49 69 68 70 7 117 110 105 49 69 69 48 7 117 110 105 49 69 69 49 7 117 110 105 49 69 69 50 7 117 110 105 49 69 69 51 7 117 110 105 49 69 69 52 7 117 110 105 49 69 69 53 7 117 110 105 49 69 69 54 7 117 110 105 49 69 69 55 7 117 110 105 49 69 69 56 7 117 110 105 49 69 69 57 7 117 110 105 49 69 69 65 7 117 110 105 49 69 69 66 7 117 110 105 49 69 69 67 7 117 110 105 49 69 69 68 7 117 110 105 49 69 69 69 7 117 110 105 49 69 69 70 7 117 110 105 49 69 70 48 7 117 110 105 49 69 70 49 7 117 110 105 49 69 70 52 7 117 110 105 49 69 70 53 7 117 110 105 49 69 70 54 7 117 110 105 49 69 70 55 7 117 110 105 49 69 70 56 7 117 110 105 49 69 70 57 7 117 110 105 50 48 65 66 7 117 110 105 48 51 48 70 19 99 105 114 99 117 109 102 108 101 120 97 99 117 116 101 99 111 109 98 19 99 105 114 99 117 109 102 108 101 120 103 114 97 118 101 99 111 109 98 18 99 105 114 99 117 109 102 108 101 120 104 111 111 107 99 111 109 98 19 99 105 114 99 117 109 102 108 101 120 116 105 108 100 101 99 111 109 98 14 98 114 101 118 101 97 99 117 116 101 99 111 109 98 14 98 114 101 118 101 103 114 97 118 101 99 111 109 98 13 98 114 101 118 101 104 111 111 107 99 111 109 98 14 98 114 101 118 101 116 105 108 100 101 99 111 109 98 16 99 121 114 105 108 108 105 99 104 111 111 107 108 101 102 116 17 99 121 114 105 108 108 105 99 98 105 103 104 111 111 107 85 67 17 99 121 114 105 108 108 105 99 98 105 103 104 111 111 107 76 67 8 111 110 101 46 112 110 117 109 7 122 101 114 111 46 111 115 6 111 110 101 46 111 115 6 116 119 111 46 111 115 8 116 104 114 101 101 46 111 115 7 102 111 117 114 46 111 115 7 102 105 118 101 46 111 115 6 115 105 120 46 111 115 8 115 101 118 101 110 46 111 115 8 101 105 103 104 116 46 111 115 7 110 105 110 101 46 111 115 2 102 102 7 117 110 105 50 49 50 48 8 84 99 101 100 105 108 108 97 8 116 99 101 100 105 108 108 97 5 103 46 97 108 116 15 103 99 105 114 99 117 109 102 108 101 120 46 97 108 116 10 103 98 114 101 118 101 46 97 108 116 8 103 100 111 116 46 97 108 116 16 103 99 111 109 109 97 97 99 99 101 110 116 46 97 108 116 1 73 6 73 103 114 97 118 101 6 73 97 99 117 116 101 11 73 99 105 114 99 117 109 102 108 101 120 9 73 100 105 101 114 101 115 105 115 6 73 116 105 108 100 101 7 73 109 97 99 114 111 110 6 73 98 114 101 118 101 7 73 111 103 111 110 101 107 10 73 100 111 116 97 99 99 101 110 116 2 73 74 9 73 111 116 97 116 111 110 111 115 4 73 111 116 97 12 73 111 116 97 100 105 101 114 101 115 105 115 9 97 102 105 105 49 48 48 53 53 9 97 102 105 105 49 48 48 53 54 7 117 110 105 48 52 67 48 7 117 110 105 48 52 67 70 7 117 110 105 49 69 67 56 7 117 110 105 49 69 67 65 0 0 1 0 3 0 8 0 10 0 13 0 7 255 255 0 15 0 1 0 0 0 12 0 0 0 22 0 0 0 2 0 1 0 0 3 169 0 1 0 4 0 0 0 1 0 0 0 0 0 1 0 0 0 10 0 52 0 54 0 1 108 97 116 110 0 8 0 16 0 2 77 79 76 32 0 22 82 79 77 32 0 28 0 0 255 255 0 0 0 0 255 255 0 0 0 0 255 255 0 0 0 0 0 0 0 1 0 0 0 10 0 110 1 228 0 1 108 97 116 110 0 8 0 16 0 2 77 79 76 32 0 40 82 79 77 32 0 66 0 0 255 255 0 9 0 3 0 8 0 11 0 0 0 14 0 17 0 20 0 23 0 26 0 0 255 255 0 10 0 4 0 6 0 9 0 12 0 1 0 15 0 18 0 21 0 24 0 27 0 0 255 255 0 10 0 5 0 7 0 10 0 13 0 2 0 16 0 19 0 22 0 25 0 28 0 29 108 105 103 97 0 176 108 105 103 97 0 182 108 105 103 97 0 188 108 110 117 109 0 194 108 110 117 109 0 200 108 110 117 109 0 206 108 111 99 108 0 212 108 111 99 108 0 218 111 110 117 109 0 224 111 110 117 109 0 232 111 110 117 109 0 240 112 110 117 109 0 248 112 110 117 109 0 254 112 110 117 109 1 4 115 97 108 116 1 10 115 97 108 116 1 18 115 97 108 116 1 26 115 115 48 49 1 34 115 115 48 49 1 42 115 115 48 49 1 50 115 115 48 50 1 58 115 115 48 50 1 64 115 115 48 50 1 70 115 115 48 51 1 76 115 115 48 51 1 82 115 115 48 51 1 88 116 110 117 109 1 94 116 110 117 109 1 102 116 110 117 109 1 110 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 9 0 0 0 1 0 7 0 0 0 1 0 7 0 0 0 1 0 7 0 0 0 1 0 8 0 0 0 1 0 8 0 0 0 2 0 2 0 3 0 0 0 2 0 2 0 3 0 0 0 2 0 2 0 3 0 0 0 1 0 4 0 0 0 1 0 4 0 0 0 1 0 4 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 2 0 0 0 1 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 1 0 1 0 0 0 1 0 1 0 0 0 1 0 1 0 0 0 2 0 5 0 6 0 0 0 2 0 5 0 6 0 0 0 2 0 5 0 6 0 10 0 22 0 30 0 38 0 46 0 54 0 62 0 70 0 78 0 86 0 94 0 1 0 0 0 1 0 80 0 1 0 0 0 1 0 122 0 1 0 0 0 1 0 170 0 1 0 0 0 1 0 198 0 1 0 0 0 1 0 238 0 1 0 0 0 1 0 244 0 1 0 0 0 1 1 16 0 1 0 0 0 1 1 22 0 1 0 0 0 1 1 50 0 4 0 0 0 1 1 72 0 2 0 16 0 5 3 145 3 146 3 147 3 148 3 149 0 2 0 5 0 74 0 74 0 0 0 223 0 223 0 1 0 225 0 225 0 2 0 227 0 227 0 3 0 229 0 229 0 4 0 2 0 46 0 20 0 44 0 142 0 143 0 144 0 145 0 234 0 236 0 238 0 240 0 242 0 244 1 90 1 103 1 119 1 161 1 162 2 201 2 216 3 69 3 71 0 2 0 1 3 150 3 169 0 0 0 2 0 26 0 10 3 131 3 132 3 133 3 134 3 135 3 136 3 137 3 138 3 139 3 140 0 2 0 1 0 19 0 28 0 0 0 2 0 26 0 10 3 131 3 133 3 134 3 135 3 136 3 137 3 138 3 139 3 140 3 132 0 2 0 3 0 19 0 19 0 0 0 21 0 28 0 1 3 130 3 130 0 9 0 2 0 8 0 1 3 130 0 1 0 1 0 20 0 2 0 26 0 10 0 19 0 20 0 21 0 22 0 23 0 24 0 25 0 26 0 27 0 28 0 2 0 1 3 131 3 140 0 0 0 2 0 8 0 1 0 20 0 1 0 1 3 130 0 2 0 26 0 10 0 19 3 130 0 21 0 22 0 23 0 24 0 25 0 26 0 27 0 28 0 2 0 1 3 131 3 140 0 0 0 2 0 14 0 4 3 143 3 144 1 32 1 33 0 2 0 2 1 36 1 37 0 0 1 73 1 74 0 2 0 1 0 54 0 1 0 8 0 5 0 12 0 20 0 28 0 34 0 40 2 94 0 3 0 73 0 79 2 93 0 3 0 73 0 76 3 141 0 2 0 73 2 53 0 2 0 79 2 52 0 2 0 76 0 1 0 1 0 73 0 0 0 0 0 1 0 1 0 1 0 0 0 1 0 0 21 94 0 0 0 20 0 0 0 0 0 0 21 86 48 130 21 82 6 9 42 134 72 134 247 13 1 7 2 160 130 21 67 48 130 21 63 2 1 1 49 11 48 9 6 5 43 14 3 2 26 5 0 48 97 6 10 43 6 1 4 1 130 55 2 1 4 160 83 48 81 48 44 6 10 43 6 1 4 1 130 55 2 1 28 162 30 128 28 0 60 0 60 0 60 0 79 0 98 0 115 0 111 0 108 0 101 0 116 0 101 0 62 0 62 0 62 48 33 48 9 6 5 43 14 3 2 26 5 0 4 20 130 184 185 128 143 217 245 64 166 109 110 179 21 84 65 54 153 222 211 125 160 130 17 93 48 130 3 122 48 130 2 98 160 3 2 1 2 2 16 56 37 215 250 248 97 175 158 244 144 231 38 181 214 90 213 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 83 49 11 48 9 6 3 85 4 6 19 2 85 83 49 23 48 21 6 3 85 4 10 19 14 86 101 114 105 83 105 103 110 44 32 73 110 99 46 49 43 48 41 6 3 85 4 3 19 34 86 101 114 105 83 105 103 110 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 67 65 48 30 23 13 48 55 48 54 49 53 48 48 48 48 48 48 90 23 13 49 50 48 54 49 52 50 51 53 57 53 57 90 48 92 49 11 48 9 6 3 85 4 6 19 2 85 83 49 23 48 21 6 3 85 4 10 19 14 86 101 114 105 83 105 103 110 44 32 73 110 99 46 49 52 48 50 6 3 85 4 3 19 43 86 101 114 105 83 105 103 110 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 83 105 103 110 101 114 32 45 32 71 50 48 129 159 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 129 141 0 48 129 137 2 129 129 0 196 181 242 82 21 188 136 134 96 41 22 74 91 47 75 145 107 135 145 243 53 84 88 53 234 209 54 94 98 77 82 81 52 113 194 123 102 29 137 200 221 42 196 106 10 246 55 217 152 116 145 246 146 174 176 181 118 150 241 169 74 99 69 71 46 107 11 146 78 75 43 140 238 88 74 139 212 7 228 26 44 248 130 170 88 217 205 66 243 45 192 117 222 141 171 199 142 29 154 108 76 8 149 30 222 219 239 103 225 114 194 73 194 158 96 60 225 226 190 22 163 99 120 105 20 123 173 45 2 3 1 0 1 163 129 196 48 129 193 48 52 6 8 43 6 1 5 5 7 1 1 4 40 48 38 48 36 6 8 43 6 1 5 5 7 48 1 134 24 104 116 116 112 58 47 47 111 99 115 112 46 118 101 114 105 115 105 103 110 46 99 111 109 48 12 6 3 85 29 19 1 1 255 4 2 48 0 48 51 6 3 85 29 31 4 44 48 42 48 40 160 38 160 36 134 34 104 116 116 112 58 47 47 99 114 108 46 118 101 114 105 115 105 103 110 46 99 111 109 47 116 115 115 45 99 97 46 99 114 108 48 22 6 3 85 29 37 1 1 255 4 12 48 10 6 8 43 6 1 5 5 7 3 8 48 14 6 3 85 29 15 1 1 255 4 4 3 2 6 192 48 30 6 3 85 29 17 4 23 48 21 164 19 48 17 49 15 48 13 6 3 85 4 3 19 6 84 83 65 49 45 50 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 130 1 1 0 80 197 75 200 36 128 223 228 13 36 194 222 26 177 161 2 161 166 130 45 12 131 21 129 55 10 130 14 44 176 90 23 97 181 216 5 254 136 219 241 145 145 179 86 26 64 166 235 146 190 56 57 176 117 54 116 58 152 79 228 55 186 153 137 202 149 66 29 176 185 199 160 141 87 224 250 213 100 4 66 53 78 1 209 51 162 23 200 77 170 39 199 242 225 134 76 2 56 77 131 120 198 252 83 224 235 224 6 135 221 164 150 158 94 12 152 226 165 190 191 130 133 195 96 225 223 173 40 216 199 165 75 100 218 199 27 91 189 172 57 8 213 56 34 161 51 139 47 138 154 235 188 7 33 63 68 65 9 7 181 101 28 36 188 72 211 68 128 235 161 207 201 2 180 20 207 84 199 22 163 128 92 249 121 62 93 114 125 136 23 158 44 67 162 202 83 206 125 61 246 42 58 184 79 148 0 165 109 10 131 93 249 94 83 244 24 179 87 15 112 195 251 245 173 149 160 14 23 222 196 22 128 96 201 15 43 110 134 4 241 235 244 120 39 209 5 197 238 52 91 94 185 73 50 242 51 48 130 3 196 48 130 3 45 160 3 2 1 2 2 16 71 191 25 149 223 141 82 70 67 247 219 109 72 13 49 164 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 129 139 49 11 48 9 6 3 85 4 6 19 2 90 65 49 21 48 19 6 3 85 4 8 19 12 87 101 115 116 101 114 110 32 67 97 112 101 49 20 48 18 6 3 85 4 7 19 11 68 117 114 98 97 110 118 105 108 108 101 49 15 48 13 6 3 85 4 10 19 6 84 104 97 119 116 101 49 29 48 27 6 3 85 4 11 19 20 84 104 97 119 116 101 32 67 101 114 116 105 102 105 99 97 116 105 111 110 49 31 48 29 6 3 85 4 3 19 22 84 104 97 119 116 101 32 84 105 109 101 115 116 97 109 112 105 110 103 32 67 65 48 30 23 13 48 51 49 50 48 52 48 48 48 48 48 48 90 23 13 49 51 49 50 48 51 50 51 53 57 53 57 90 48 83 49 11 48 9 6 3 85 4 6 19 2 85 83 49 23 48 21 6 3 85 4 10 19 14 86 101 114 105 83 105 103 110 44 32 73 110 99 46 49 43 48 41 6 3 85 4 3 19 34 86 101 114 105 83 105 103 110 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 67 65 48 130 1 34 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 130 1 15 0 48 130 1 10 2 130 1 1 0 169 202 178 164 204 205 32 175 10 125 137 172 135 117 240 180 78 241 223 193 15 191 103 97 189 163 100 28 218 187 249 202 51 171 132 48 137 88 126 140 219 107 221 54 158 15 191 209 236 120 242 119 166 126 111 60 191 147 175 13 186 104 244 108 148 202 189 82 45 171 72 61 245 182 213 93 95 27 2 159 250 47 107 30 164 247 163 154 166 26 200 2 225 127 76 82 227 14 96 236 64 28 126 185 13 222 63 199 180 223 135 189 95 122 106 49 46 3 153 129 19 168 71 32 206 49 115 13 87 45 205 120 52 51 149 18 153 18 185 222 104 47 170 230 227 194 138 140 42 195 139 33 135 102 189 131 88 87 111 117 191 60 170 38 135 93 202 16 21 60 159 132 234 84 193 10 110 196 254 197 74 221 185 7 17 151 34 124 219 62 39 209 30 120 236 159 49 201 241 230 34 25 219 196 179 71 67 154 26 95 160 30 144 228 94 245 238 124 241 125 171 98 1 143 245 77 11 222 208 34 86 168 149 205 174 136 118 174 238 186 13 243 228 77 217 160 251 104 160 174 20 59 179 135 193 187 2 3 1 0 1 163 129 219 48 129 216 48 52 6 8 43 6 1 5 5 7 1 1 4 40 48 38 48 36 6 8 43 6 1 5 5 7 48 1 134 24 104 116 116 112 58 47 47 111 99 115 112 46 118 101 114 105 115 105 103 110 46 99 111 109 48 18 6 3 85 29 19 1 1 255 4 8 48 6 1 1 255 2 1 0 48 65 6 3 85 29 31 4 58 48 56 48 54 160 52 160 50 134 48 104 116 116 112 58 47 47 99 114 108 46 118 101 114 105 115 105 103 110 46 99 111 109 47 84 104 97 119 116 101 84 105 109 101 115 116 97 109 112 105 110 103 67 65 46 99 114 108 48 19 6 3 85 29 37 4 12 48 10 6 8 43 6 1 5 5 7 3 8 48 14 6 3 85 29 15 1 1 255 4 4 3 2 1 6 48 36 6 3 85 29 17 4 29 48 27 164 25 48 23 49 21 48 19 6 3 85 4 3 19 12 84 83 65 50 48 52 56 45 49 45 53 51 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 129 129 0 74 107 249 234 88 194 68 28 49 137 121 153 43 150 191 130 172 1 214 28 76 205 176 138 88 110 223 8 41 163 94 200 202 147 19 231 4 82 13 239 71 39 47 0 56 176 228 201 147 78 154 212 34 98 21 247 63 55 33 79 112 49 128 241 139 56 135 179 232 232 151 0 254 207 85 150 78 36 210 169 39 78 122 174 183 97 65 243 42 206 231 201 217 94 221 187 43 133 62 181 157 181 217 225 87 255 190 180 197 126 245 207 12 158 240 151 254 43 211 59 82 27 27 56 39 247 63 74 48 130 4 252 48 130 4 101 160 3 2 1 2 2 16 101 82 38 225 178 46 24 225 89 15 41 133 172 34 231 92 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 95 49 11 48 9 6 3 85 4 6 19 2 85 83 49 23 48 21 6 3 85 4 10 19 14 86 101 114 105 83 105 103 110 44 32 73 110 99 46 49 55 48 53 6 3 85 4 11 19 46 67 108 97 115 115 32 51 32 80 117 98 108 105 99 32 80 114 105 109 97 114 121 32 67 101 114 116 105 102 105 99 97 116 105 111 110 32 65 117 116 104 111 114 105 116 121 48 30 23 13 48 57 48 53 50 49 48 48 48 48 48 48 90 23 13 49 57 48 53 50 48 50 51 53 57 53 57 90 48 129 182 49 11 48 9 6 3 85 4 6 19 2 85 83 49 23 48 21 6 3 85 4 10 19 14 86 101 114 105 83 105 103 110 44 32 73 110 99 46 49 31 48 29 6 3 85 4 11 19 22 86 101 114 105 83 105 103 110 32 84 114 117 115 116 32 78 101 116 119 111 114 107 49 59 48 57 6 3 85 4 11 19 50 84 101 114 109 115 32 111 102 32 117 115 101 32 97 116 32 104 116 116 112 115 58 47 47 119 119 119 46 118 101 114 105 115 105 103 110 46 99 111 109 47 114 112 97 32 40 99 41 48 57 49 48 48 46 6 3 85 4 3 19 39 86 101 114 105 83 105 103 110 32 67 108 97 115 115 32 51 32 67 111 100 101 32 83 105 103 110 105 110 103 32 50 48 48 57 45 50 32 67 65 48 130 1 34 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 130 1 15 0 48 130 1 10 2 130 1 1 0 190 103 29 180 96 170 16 73 111 86 23 124 102 201 94 134 13 213 241 172 167 113 131 142 139 137 248 136 4 137 21 6 186 45 132 33 149 228 209 156 80 76 251 210 34 189 218 242 178 53 59 30 143 195 9 251 252 19 46 90 191 137 124 61 59 37 30 246 243 88 123 156 244 1 181 198 10 184 128 206 190 39 116 97 103 39 77 106 229 236 129 97 88 121 163 224 23 16 18 21 39 176 225 77 52 127 43 71 32 68 185 222 102 36 102 138 205 79 186 31 197 56 200 84 144 225 114 246 25 102 117 106 185 73 104 207 56 121 13 170 48 168 219 44 96 72 158 215 170 20 1 169 131 215 56 145 48 57 19 150 3 58 124 64 84 182 173 224 47 27 131 220 168 17 82 62 2 179 215 43 253 33 182 167 92 163 15 11 169 166 16 80 14 52 46 77 167 206 201 94 37 212 140 188 243 110 124 41 188 1 93 252 49 135 90 213 140 133 103 88 136 25 160 191 53 240 234 43 163 33 231 144 246 131 229 168 237 96 120 94 123 96 131 253 87 11 93 65 13 99 84 96 214 67 33 239 2 3 1 0 1 163 130 1 219 48 130 1 215 48 18 6 3 85 29 19 1 1 255 4 8 48 6 1 1 255 2 1 0 48 112 6 3 85 29 32 4 105 48 103 48 101 6 11 96 134 72 1 134 248 69 1 7 23 3 48 86 48 40 6 8 43 6 1 5 5 7 2 1 22 28 104 116 116 112 115 58 47 47 119 119 119 46 118 101 114 105 115 105 103 110 46 99 111 109 47 99 112 115 48 42 6 8 43 6 1 5 5 7 2 2 48 30 26 28 104 116 116 112 115 58 47 47 119 119 119 46 118 101 114 105 115 105 103 110 46 99 111 109 47 114 112 97 48 14 6 3 85 29 15 1 1 255 4 4 3 2 1 6 48 109 6 8 43 6 1 5 5 7 1 12 4 97 48 95 161 93 160 91 48 89 48 87 48 85 22 9 105 109 97 103 101 47 103 105 102 48 33 48 31 48 7 6 5 43 14 3 2 26 4 20 143 229 211 26 134 172 141 142 107 195 207 128 106 212 72 24 44 123 25 46 48 37 22 35 104 116 116 112 58 47 47 108 111 103 111 46 118 101 114 105 115 105 103 110 46 99 111 109 47 118 115 108 111 103 111 46 103 105 102 48 29 6 3 85 29 37 4 22 48 20 6 8 43 6 1 5 5 7 3 2 6 8 43 6 1 5 5 7 3 3 48 52 6 8 43 6 1 5 5 7 1 1 4 40 48 38 48 36 6 8 43 6 1 5 5 7 48 1 134 24 104 116 116 112 58 47 47 111 99 115 112 46 118 101 114 105 115 105 103 110 46 99 111 109 48 49 6 3 85 29 31 4 42 48 40 48 38 160 36 160 34 134 32 104 116 116 112 58 47 47 99 114 108 46 118 101 114 105 115 105 103 110 46 99 111 109 47 112 99 97 51 46 99 114 108 48 41 6 3 85 29 17 4 34 48 32 164 30 48 28 49 26 48 24 6 3 85 4 3 19 17 67 108 97 115 115 51 67 65 50 48 52 56 45 49 45 53 53 48 29 6 3 85 29 14 4 22 4 20 151 208 107 168 38 112 200 161 63 148 31 8 45 196 53 155 164 161 30 242 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 129 129 0 139 3 192 221 148 216 65 162 97 105 176 21 168 120 199 48 198 144 60 126 66 247 36 182 228 131 115 23 4 127 4 16 156 161 226 250 129 47 235 192 202 68 231 114 224 80 182 85 16 32 131 110 150 146 228 154 81 106 180 55 49 220 165 45 235 140 0 199 29 79 231 77 50 186 133 248 78 190 250 103 85 101 240 106 190 122 202 100 56 26 16 16 120 69 118 49 243 134 122 3 15 96 194 179 93 157 246 139 102 118 130 27 89 225 131 229 189 73 165 56 86 229 222 65 119 14 88 15 48 130 5 19 48 130 3 251 160 3 2 1 2 2 16 102 227 240 103 121 202 21 22 109 80 83 111 136 25 26 131 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 48 129 182 49 11 48 9 6 3 85 4 6 19 2 85 83 49 23 48 21 6 3 85 4 10 19 14 86 101 114 105 83 105 103 110 44 32 73 110 99 46 49 31 48 29 6 3 85 4 11 19 22 86 101 114 105 83 105 103 110 32 84 114 117 115 116 32 78 101 116 119 111 114 107 49 59 48 57 6 3 85 4 11 19 50 84 101 114 109 115 32 111 102 32 117 115 101 32 97 116 32 104 116 116 112 115 58 47 47 119 119 119 46 118 101 114 105 115 105 103 110 46 99 111 109 47 114 112 97 32 40 99 41 48 57 49 48 48 46 6 3 85 4 3 19 39 86 101 114 105 83 105 103 110 32 67 108 97 115 115 32 51 32 67 111 100 101 32 83 105 103 110 105 110 103 32 50 48 48 57 45 50 32 67 65 48 30 23 13 49 48 48 55 50 57 48 48 48 48 48 48 90 23 13 49 50 48 56 48 56 50 51 53 57 53 57 90 48 129 208 49 11 48 9 6 3 85 4 6 19 2 85 83 49 22 48 20 6 3 85 4 8 19 13 77 97 115 115 97 99 104 117 115 101 116 116 115 49 15 48 13 6 3 85 4 7 19 6 87 111 98 117 114 110 49 30 48 28 6 3 85 4 10 20 21 77 111 110 111 116 121 112 101 32 73 109 97 103 105 110 103 32 73 110 99 46 49 62 48 60 6 3 85 4 11 19 53 68 105 103 105 116 97 108 32 73 68 32 67 108 97 115 115 32 51 32 45 32 77 105 99 114 111 115 111 102 116 32 83 111 102 116 119 97 114 101 32 86 97 108 105 100 97 116 105 111 110 32 118 50 49 24 48 22 6 3 85 4 11 20 15 84 121 112 101 32 79 112 101 114 97 116 105 111 110 115 49 30 48 28 6 3 85 4 3 20 21 77 111 110 111 116 121 112 101 32 73 109 97 103 105 110 103 32 73 110 99 46 48 129 159 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 3 129 141 0 48 129 137 2 129 129 0 148 68 160 149 105 124 85 13 208 219 22 141 50 53 138 76 51 171 94 32 161 76 215 42 135 56 215 152 165 64 240 25 73 11 34 30 83 79 194 67 166 202 139 169 86 239 110 72 6 168 5 21 57 30 99 59 36 18 144 185 152 207 202 8 53 125 114 227 71 87 253 121 203 138 74 231 64 112 45 53 99 127 174 128 207 196 175 216 251 247 201 252 137 216 215 164 160 219 9 242 162 242 123 239 205 117 193 247 101 80 100 34 157 189 125 188 173 184 75 204 88 69 14 77 209 89 76 77 2 3 1 0 1 163 130 1 131 48 130 1 127 48 9 6 3 85 29 19 4 2 48 0 48 14 6 3 85 29 15 1 1 255 4 4 3 2 7 128 48 68 6 3 85 29 31 4 61 48 59 48 57 160 55 160 53 134 51 104 116 116 112 58 47 47 99 115 99 51 45 50 48 48 57 45 50 45 99 114 108 46 118 101 114 105 115 105 103 110 46 99 111 109 47 67 83 67 51 45 50 48 48 57 45 50 46 99 114 108 48 68 6 3 85 29 32 4 61 48 59 48 57 6 11 96 134 72 1 134 248 69 1 7 23 3 48 42 48 40 6 8 43 6 1 5 5 7 2 1 22 28 104 116 116 112 115 58 47 47 119 119 119 46 118 101 114 105 115 105 103 110 46 99 111 109 47 114 112 97 48 19 6 3 85 29 37 4 12 48 10 6 8 43 6 1 5 5 7 3 3 48 117 6 8 43 6 1 5 5 7 1 1 4 105 48 103 48 36 6 8 43 6 1 5 5 7 48 1 134 24 104 116 116 112 58 47 47 111 99 115 112 46 118 101 114 105 115 105 103 110 46 99 111 109 48 63 6 8 43 6 1 5 5 7 48 2 134 51 104 116 116 112 58 47 47 99 115 99 51 45 50 48 48 57 45 50 45 97 105 97 46 118 101 114 105 115 105 103 110 46 99 111 109 47 67 83 67 51 45 50 48 48 57 45 50 46 99 101 114 48 31 6 3 85 29 35 4 24 48 22 128 20 151 208 107 168 38 112 200 161 63 148 31 8 45 196 53 155 164 161 30 242 48 17 6 9 96 134 72 1 134 248 66 1 1 4 4 3 2 4 16 48 22 6 10 43 6 1 4 1 130 55 2 1 27 4 8 48 6 1 1 0 1 1 255 48 13 6 9 42 134 72 134 247 13 1 1 5 5 0 3 130 1 1 0 78 230 34 135 223 103 65 21 23 226 210 238 126 14 206 194 153 214 99 189 240 181 147 229 106 114 98 225 245 210 60 56 238 168 61 8 95 186 71 129 130 95 91 75 73 244 29 32 250 15 147 9 208 29 25 86 68 23 162 136 243 251 141 157 174 247 13 53 222 60 12 172 68 148 96 69 42 155 254 155 111 76 59 177 52 103 112 16 134 255 90 57 92 90 227 108 130 171 53 124 101 75 253 152 109 181 21 148 73 156 136 112 16 190 61 177 98 149 180 219 180 212 218 232 157 65 144 126 254 125 185 164 146 235 110 242 34 138 198 119 54 77 138 90 11 83 5 49 211 43 40 175 82 225 141 122 107 181 119 68 189 12 173 244 93 37 44 227 205 138 48 62 75 3 156 121 202 166 78 174 11 194 204 36 7 11 193 148 130 246 16 241 186 144 182 155 154 216 92 60 19 241 234 2 6 24 39 77 60 137 111 51 138 211 134 222 233 88 51 117 61 235 147 105 226 68 111 78 0 108 207 213 133 218 86 166 154 166 63 203 76 33 104 144 242 96 186 225 232 6 93 57 33 19 50 237 49 130 3 103 48 130 3 99 2 1 1 48 129 203 48 129 182 49 11 48 9 6 3 85 4 6 19 2 85 83 49 23 48 21 6 3 85 4 10 19 14 86 101 114 105 83 105 103 110 44 32 73 110 99 46 49 31 48 29 6 3 85 4 11 19 22 86 101 114 105 83 105 103 110 32 84 114 117 115 116 32 78 101 116 119 111 114 107 49 59 48 57 6 3 85 4 11 19 50 84 101 114 109 115 32 111 102 32 117 115 101 32 97 116 32 104 116 116 112 115 58 47 47 119 119 119 46 118 101 114 105 115 105 103 110 46 99 111 109 47 114 112 97 32 40 99 41 48 57 49 48 48 46 6 3 85 4 3 19 39 86 101 114 105 83 105 103 110 32 67 108 97 115 115 32 51 32 67 111 100 101 32 83 105 103 110 105 110 103 32 50 48 48 57 45 50 32 67 65 2 16 102 227 240 103 121 202 21 22 109 80 83 111 136 25 26 131 48 9 6 5 43 14 3 2 26 5 0 160 112 48 16 6 10 43 6 1 4 1 130 55 2 1 12 49 2 48 0 48 25 6 9 42 134 72 134 247 13 1 9 3 49 12 6 10 43 6 1 4 1 130 55 2 1 4 48 28 6 10 43 6 1 4 1 130 55 2 1 11 49 14 48 12 6 10 43 6 1 4 1 130 55 2 1 21 48 35 6 9 42 134 72 134 247 13 1 9 4 49 22 4 20 72 227 234 219 23 99 143 198 177 21 87 39 32 183 101 244 25 83 149 24 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 4 129 128 69 59 188 212 186 239 218 27 191 98 59 222 18 236 74 6 132 69 113 65 201 2 254 46 14 149 243 137 177 82 244 65 235 109 50 44 72 191 41 145 188 178 47 93 100 36 52 46 186 150 180 182 74 115 151 224 246 159 65 247 247 104 182 245 128 6 120 65 190 83 144 192 126 120 82 91 28 170 14 33 66 220 190 9 156 51 211 70 80 144 59 5 153 16 43 89 105 236 133 216 99 209 45 195 6 150 52 237 20 163 156 242 241 84 64 213 71 23 160 11 0 31 140 102 239 222 62 27 161 130 1 127 48 130 1 123 6 9 42 134 72 134 247 13 1 9 6 49 130 1 108 48 130 1 104 2 1 1 48 103 48 83 49 11 48 9 6 3 85 4 6 19 2 85 83 49 23 48 21 6 3 85 4 10 19 14 86 101 114 105 83 105 103 110 44 32 73 110 99 46 49 43 48 41 6 3 85 4 3 19 34 86 101 114 105 83 105 103 110 32 84 105 109 101 32 83 116 97 109 112 105 110 103 32 83 101 114 118 105 99 101 115 32 67 65 2 16 56 37 215 250 248 97 175 158 244 144 231 38 181 214 90 213 48 9 6 5 43 14 3 2 26 5 0 160 93 48 24 6 9 42 134 72 134 247 13 1 9 3 49 11 6 9 42 134 72 134 247 13 1 7 1 48 28 6 9 42 134 72 134 247 13 1 9 5 49 15 23 13 49 49 48 53 48 53 49 54 53 53 49 48 90 48 35 6 9 42 134 72 134 247 13 1 9 4 49 22 4 20 84 23 8 43 11 189 238 26 39 14 31 141 252 83 147 244 56 86 16 15 48 13 6 9 42 134 72 134 247 13 1 1 1 5 0 4 129 128 29 193 119 137 174 155 111 34 227 107 229 69 218 78 145 64 240 159 239 59 31 39 74 86 172 58 253 168 148 106 124 247 156 193 127 123 147 96 78 27 196 43 87 149 148 203 22 225 154 103 51 209 43 41 19 200 236 190 188 89 177 3 164 41 153 236 29 136 153 36 135 119 15 155 202 20 251 212 212 73 76 116 14 200 61 46 111 32 201 3 205 232 229 15 208 33 57 179 86 25 213 251 172 189 172 169 56 189 176 213 12 163 217 99 173 176 149 180 104 88 195 226 215 41 255 145 164 199 0 0]! ! !OpenSansRegular class methodsFor: 'class initialization' stamp: 'IgorStasenko 4/9/2014 15:12'! initialize FreeTypeFontProvider registerFont: self ! ! !OpenSansRegular class methodsFor: 'accessing' stamp: 'IgorStasenko 4/8/2014 16:47'! originalFileName ^ 'OpenSans-Regular.ttf'! ! !OpenToolTest commentStamp: 'TorstenBergmann 2/4/2014 20:46'! SUnit tests for opening of tools! !OpenToolTest methodsFor: 'test inspect' stamp: 'ClementBera 6/28/2013 11:16'! testInspectClass | inspector | inspector := Object inspector. inspector changed. inspector close.! ! !OpenToolTest methodsFor: 'test browse' stamp: 'MarcusDenker 2/3/2014 09:46'! testOpenBrowseOnInstalledTraitMethod | browser | browser := (Class>>#hasClassSide) browse. browser changed. browser close.! ! !OpenToolTest methodsFor: 'test inspect' stamp: 'ClementBera 6/28/2013 11:16'! testInspectDictionary | inspector | inspector := (Dictionary new) inspector. inspector changed. inspector close.! ! !OpenToolTest methodsFor: 'test inspect' stamp: 'ClementBera 6/28/2013 11:16'! testInspectArray | inspector | inspector := (1 to: 1000) asArray inspector. inspector changed. inspector close.! ! !OpenToolTest methodsFor: 'test browse' stamp: 'CamilloBruni 9/21/2012 14:10'! testOpenBrowseOnMethod | browser | browser := (Object>>#name) browse. browser changed. browser close.! ! !OpenToolTest methodsFor: 'test browse' stamp: 'CamilloBruni 9/21/2012 14:09'! testOpenBrowseOnClass | browser | browser := Object browse. browser changed. browser close.! ! !OpenToolTest methodsFor: 'test browse' stamp: 'SebastianTleye 7/22/2013 13:46'! testOpenBrowseOnTraitMethod | browser | browser := (TBehavior>>#name) browse. browser changed. browser close.! ! !OpenToolTest methodsFor: 'test inspect' stamp: 'ClementBera 6/28/2013 11:16'! testInspectInteger | inspector | inspector := 1 inspector. inspector changed. inspector close.! ! !OpenToolTest methodsFor: 'test senders' stamp: 'CamilloBruni 9/21/2012 14:22'! testSendersOfAt | senders | senders := SystemNavigation default browseAllSendersOf: #name. senders changed. senders close.! ! !OpenToolTest methodsFor: 'test inspect' stamp: 'SebastianTleye 7/9/2013 18:43'! testInspectTraitClass | inspector | inspector := TBehavior inspector. inspector changed. inspector close.! ! !OptimizedBlockLocalTempReadBeforeWrittenVisitor commentStamp: 'StephaneDucasse 11/29/2011 22:25'! Answer the set of temporary variables that are read before they are written in the visited parse tree. Used by the compiler to detect those block-local temporaries of blocks in optimized loops that require nilling to prevent a value from a previous iteration persisting into a subsequent one.! !OptimizedBlockLocalTempReadBeforeWrittenVisitor methodsFor: 'initialization' stamp: 'eem 9/5/2009 21:03'! initialize inOptimizedBlock := false! ! !OptimizedBlockLocalTempReadBeforeWrittenVisitor methodsFor: 'visiting' stamp: 'eem 9/5/2009 22:09'! visitBlockNode: aBlockNode | savedWritten | "If we're in the optimized block in one side of an optimized ifTrue:ifFalse: et al leave it to the enclosing visitMessageNode: activation to handle merging written." inOptimizedBlock ifTrue: [^super visitBlockNode: aBlockNode]. "If we're not then don't update written because without evaluating the guard(s) we can't tell if the block is evaluated or not, and we must avoid false positives." savedWritten := written copy. super visitBlockNode: aBlockNode. written := savedWritten! ! !OptimizedBlockLocalTempReadBeforeWrittenVisitor methodsFor: 'visiting' stamp: 'eem 9/8/2008 14:43'! visitTempVariableNode: aTempVariableNode (aTempVariableNode isArg or: [written notNil and: [written includes: aTempVariableNode]]) ifTrue: [^self]. readBeforeWritten ifNil: [readBeforeWritten := IdentitySet new]. readBeforeWritten add: aTempVariableNode! ! !OptimizedBlockLocalTempReadBeforeWrittenVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:28'! visitAssignmentNode: anAssignmentNode anAssignmentNode value accept: self. anAssignmentNode variable isTemp ifTrue: [written ifNil: [written := IdentitySet new]. written add: anAssignmentNode variable] ifFalse: [anAssignmentNode variable accept: self]! ! !OptimizedBlockLocalTempReadBeforeWrittenVisitor methodsFor: 'visiting' stamp: 'eem 9/5/2009 22:03'! visitMessageNode: aMessageNode | savedWritten writtenPostFirstArm | (aMessageNode isOptimized and: [#(ifTrue:ifFalse: ifFalse:ifTrue: ifNil:ifNotNil: ifNotNil:ifNil:) includes: aMessageNode selector key]) ifFalse: [^super visitMessageNode: aMessageNode]. aMessageNode receiver accept: self. aMessageNode selector accept: self. savedWritten := written copy. aMessageNode argumentsInEvaluationOrder do: [:argument| argument isBlockNode ifTrue: [| savedIOB | savedIOB := inOptimizedBlock. inOptimizedBlock := true. [argument accept: self] ensure: [inOptimizedBlock := savedIOB]] ifFalse: [argument accept: self]] separatedBy: [writtenPostFirstArm := written. written := savedWritten]. (written notNil and: [writtenPostFirstArm notNil]) ifTrue: [written := written intersection: writtenPostFirstArm]! ! !OptimizedBlockLocalTempReadBeforeWrittenVisitor methodsFor: 'accessing' stamp: 'eem 9/8/2008 14:30'! readBeforeWritten ^readBeforeWritten ifNil: [IdentitySet new]! ! !OrderedCollection commentStamp: ''! I represent a collection of objects ordered by the collector.! !OrderedCollection methodsFor: 'copying' stamp: 'nice 10/5/2009 10:18'! copyFrom: startIndex to: endIndex "Answer a copy of the receiver that contains elements from position startIndex to endIndex." ^self shallowCopy postCopyFrom: startIndex to: endIndex! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'di 8/31/1999 13:13'! with: otherCollection collect: twoArgBlock "Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection." | result | otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size']. result := self species new: self size. 1 to: self size do: [:index | result addLast: (twoArgBlock value: (self at: index) value: (otherCollection at: index))]. ^ result! ! !OrderedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 11:26'! addAll: aCollection "Add each element of aCollection at my end. Answer aCollection." ^ self addAllLast: aCollection! ! !OrderedCollection methodsFor: 'adding' stamp: 'sw 3/1/2001 11:03'! addAllFirstUnlessAlreadyPresent: anOrderedCollection "Add each element of anOrderedCollection at the beginning of the receiver, preserving the order, but do not add any items that are already in the receiver. Answer anOrderedCollection." anOrderedCollection reverseDo: [:each | (self includes: each) ifFalse: [self addFirst: each]]. ^ anOrderedCollection! ! !OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:26'! find: oldObject " This method answers an index in the range firstIndex .. lastIndex, which is meant for internal use only. Never use this method in your code, the methods for public use are: #indexOf: #indexOf:ifAbsent: " | index | index := firstIndex. [index <= lastIndex] whileTrue: [(array at: index) = oldObject ifTrue: [^ index]. index := index + 1]. self errorNotFound: oldObject! ! !OrderedCollection methodsFor: 'private' stamp: 'cmm 10/25/2010 22:27'! growAtFirst "Add new empty slots to the front of array, while keeping the empty slots at the end." | newArray newFirstIndex newLastIndex | newArray := self class arrayType new: (array size * 2 max: 1). newFirstIndex := newArray size - array size + firstIndex. newLastIndex := newFirstIndex + lastIndex - firstIndex. newArray replaceFrom: newFirstIndex to: newLastIndex with: array startingAt: firstIndex. array := newArray. firstIndex := newFirstIndex. lastIndex := newLastIndex! ! !OrderedCollection methodsFor: 'adding' stamp: 'ar 7/15/2008 23:05'! add: newObject beforeIndex: index "Add the argument, newObject, as an element of the receiver. Put it in the sequence just before index. Answer newObject." (index between: 1 and: self size+1) ifFalse:[^self errorSubscriptBounds: index]. self insert: newObject before: firstIndex + index - 1. ^ newObject! ! !OrderedCollection methodsFor: 'adding' stamp: ''! addLast: newObject "Add newObject to the end of the receiver. Answer newObject." lastIndex = array size ifTrue: [self makeRoomAtLast]. lastIndex := lastIndex + 1. array at: lastIndex put: newObject. ^ newObject! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'CamilloBruni 3/22/2013 23:52'! reject: rejectBlock "Optimized version of Collection>>#reject:" | newCollection element | newCollection := self copyEmpty. firstIndex to: lastIndex do: [ :index | (rejectBlock value: (element := array at: index)) ifFalse: [ newCollection addLast: element ]]. ^ newCollection! ! !OrderedCollection methodsFor: 'removing' stamp: 'ar 5/22/2000 12:19'! removeAt: index | removed | removed := self at: index. self removeIndex: index + firstIndex - 1. ^removed! ! !OrderedCollection methodsFor: 'adding' stamp: 'StephaneDucasse 12/25/2009 12:13'! addAllLast: aCollection "Add each element of aCollection at the end of the receiver. Answer aCollection." aCollection do: [:each | self addLast: each]. ^aCollection! ! !OrderedCollection methodsFor: 'adding' stamp: 'ajh 5/22/2003 12:03'! at: index ifAbsentPut: block "Return value at index, however, if value does not exist (nil or out of bounds) then add block's value at index (growing self if necessary)" | v | index <= self size ifTrue: [ ^ (v := self at: index) ifNotNil: [v] ifNil: [self at: index put: block value] ]. [self size < index] whileTrue: [self add: nil]. ^ self at: index put: block value! ! !OrderedCollection methodsFor: 'removing' stamp: ''! removeFirst "Remove the first element of the receiver and answer it. If the receiver is empty, create an error notification." | firstObject | self emptyCheck. firstObject := array at: firstIndex. array at: firstIndex put: nil. firstIndex := firstIndex + 1. ^ firstObject! ! !OrderedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:42'! capacity "Answer the current capacity of the receiver." ^ array size! ! !OrderedCollection methodsFor: 'converting' stamp: 'stephane.ducasse 8/8/2009 10:48'! asArray ^ (Array new: self size) replaceFrom: 1 to: self size with: array startingAt: firstIndex.! ! !OrderedCollection methodsFor: 'copying' stamp: ''! copyReplaceFrom: start to: stop with: replacementCollection "Answer a copy of the receiver with replacementCollection's elements in place of the receiver's start'th to stop'th elements. This does not expect a 1-1 map from replacementCollection to the start to stop elements, so it will do an insert or append." | newOrderedCollection delta startIndex stopIndex | "if start is less than 1, ignore stop and assume this is inserting at the front. if start greater than self size, ignore stop and assume this is appending. otherwise, it is replacing part of me and start and stop have to be within my bounds. " delta := 0. startIndex := start. stopIndex := stop. start < 1 ifTrue: [startIndex := stopIndex := 0] ifFalse: [startIndex > self size ifTrue: [startIndex := stopIndex := self size + 1] ifFalse: [(stopIndex < (startIndex - 1) or: [stopIndex > self size]) ifTrue: [self errorOutOfBounds]. delta := stopIndex - startIndex + 1]]. newOrderedCollection := self species new: self size + replacementCollection size - delta. 1 to: startIndex - 1 do: [:index | newOrderedCollection add: (self at: index)]. 1 to: replacementCollection size do: [:index | newOrderedCollection add: (replacementCollection at: index)]. stopIndex + 1 to: self size do: [:index | newOrderedCollection add: (self at: index)]. ^newOrderedCollection! ! !OrderedCollection methodsFor: 'private' stamp: 'apb 10/15/2000 18:10'! setContents: anArray array := anArray. firstIndex := 1. lastIndex := array size.! ! !OrderedCollection methodsFor: 'removing' stamp: 'ul 2/24/2011 14:33'! reset "Quickly remove all elements. The objects will be still referenced, but will not be accessible." self resetTo: 1! ! !OrderedCollection methodsFor: 'adding' stamp: ''! addFirst: newObject "Add newObject to the beginning of the receiver. Answer newObject." firstIndex = 1 ifTrue: [self makeRoomAtFirst]. firstIndex := firstIndex - 1. array at: firstIndex put: newObject. ^ newObject! ! !OrderedCollection methodsFor: '*GroupManager' stamp: 'BenjaminVanRyseghem 4/14/2012 12:08'! removeDuplicates | iterator | "Remove the copies of elements, but keep the same order" self ifEmpty: [ ^ self ]. iterator := 1. [ iterator <= self size ] whileTrue: [ | each newIndex | each := self at: iterator. [ newIndex := (self indexOf: each startingAt: iterator+1). newIndex > 0 ] whileTrue: [ self removeAt: newIndex ]. iterator := iterator + 1. ]! ! !OrderedCollection methodsFor: 'private' stamp: 'MarianoMartinezPeck 8/3/2011 14:37'! makeRoomAtLast "Make some empty slots at the end of the array. If we have more than 50% free space, then just move the elements, so that the last 50% of the slots are free, otherwise add new free slots to the end by growing. Precondition: lastIndex = array size" | tally newFirstIndex newLastIndex | tally := self size. tally * 2 >= lastIndex ifTrue: [ ^self growAtLast ]. tally = 0 ifTrue: [ ^self resetTo: 1 ]. newLastIndex := lastIndex // 2. newFirstIndex := newLastIndex - lastIndex + firstIndex. array replaceFrom: newFirstIndex to: newLastIndex with: array startingAt: firstIndex. array from: newLastIndex + 1 to: lastIndex put: nil. firstIndex := newFirstIndex. lastIndex := newLastIndex! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'CamilloBruni 3/22/2013 23:51'! reject: rejectBlock thenCollect: collectBlock " Optimized version of Collection>>#reject:thenCollect: " | newCollection | newCollection := self copyEmpty. firstIndex to: lastIndex do: [ :index | | element | element := array at: index. (rejectBlock value: element) ifFalse: [ newCollection addLast: (collectBlock value: element) ]]. ^ newCollection! ! !OrderedCollection methodsFor: 'private' stamp: ''! errorConditionNotSatisfied self error: 'no element satisfies condition'! ! !OrderedCollection methodsFor: 'private' stamp: 'di 11/14/97 12:54'! setCollection: anArray array := anArray. self reset! ! !OrderedCollection methodsFor: 'testing' stamp: 'md 8/13/2008 21:40'! hasContentsInExplorer ^self notEmpty! ! !OrderedCollection methodsFor: 'adding' stamp: 'CamilloBruni 4/12/2011 13:52'! add: newObject afterIndex: index "Add the argument, newObject, as an element of the receiver. Put it in the sequence just after index. Answer newObject." (index between: 0 and: self size) ifFalse:[^self errorSubscriptBounds: index]. self insert: newObject before: firstIndex + index. ^ newObject! ! !OrderedCollection methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2011 15:39'! at: anInteger put: anObject "Put anObject at element index anInteger. at:put: cannot be used to append, front or back, to an ordered collection; it is used by a knowledgeable client to replace an element." self ensureBoundsFrom: anInteger to: anInteger. ^array at: anInteger + firstIndex - 1 put: anObject! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:22'! collect: aBlock "Evaluate aBlock with each of my elements as the argument. Collect the resulting values into a collection that is like me. Answer the new collection. Override superclass in order to use addLast:, not at:put:." | newCollection | newCollection := self species new: self size. firstIndex to: lastIndex do: [:index | newCollection addLast: (aBlock value: (array at: index))]. ^ newCollection! ! !OrderedCollection methodsFor: 'copying' stamp: 'nice 10/5/2009 08:50'! postCopy array := array copy! ! !OrderedCollection methodsFor: 'enumerating' stamp: ''! reverseDo: aBlock "Override the superclass for performance reasons." | index | index := lastIndex. [index >= firstIndex] whileTrue: [aBlock value: (array at: index). index := index - 1]! ! !OrderedCollection methodsFor: 'private' stamp: 'cmm 10/25/2010 22:27'! growAtLast "Add new empty slots to the end of array, while keeping the empty slots at the front." | newArray | newArray := self class arrayType new: (array size * 2 max: 1). newArray replaceFrom: firstIndex to: lastIndex with: array startingAt: firstIndex. array := newArray! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'pmm 3/13/2010 11:33'! sort: aSortBlock "Sort this array using aSortBlock. The block should take two arguments and return true if the first element should preceed the second one." self size <= 1 ifTrue: [^ self]. "nothing to do" array mergeSortFrom: firstIndex to: lastIndex src: array shallowCopy dst: array by: aSortBlock! ! !OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:28'! removeIndex: removedIndex " removedIndex is an index in the range firstIndex .. lastIndex, such an index is not known from outside the collection. Never use this method in your code, it is meant for private use by OrderedCollection only. The method for public use is: #removeAt: " array replaceFrom: removedIndex to: lastIndex - 1 with: array startingAt: removedIndex+1. array at: lastIndex put: nil. lastIndex := lastIndex - 1.! ! !OrderedCollection methodsFor: 'removing' stamp: 'cmm 10/25/2010 22:26'! removeAll "remove all the elements from this collection. Keep same amount of storage" self setCollection: (self class arrayType new: array size)! ! !OrderedCollection methodsFor: 'private' stamp: 'ar 4/16/1999 07:59'! resetTo: index firstIndex := index. lastIndex := firstIndex - 1! ! !OrderedCollection methodsFor: '*Fuel' stamp: 'MarianoMartinezPeck 7/26/2012 17:42'! fuelAccept: aGeneralMapper "Since we have subclasses of OrderedCollection that behave differently, we cannot use the visitSimpleCollection: for all of them." ^ (self class == OrderedCollection ) ifTrue: [ aGeneralMapper visitSimpleCollection: self ] ifFalse: [ super fuelAccept: aGeneralMapper ] ! ! !OrderedCollection methodsFor: 'copying' stamp: 'sw 1/26/96'! reversed "Answer a copy of the receiver with element order reversed. " | newCol | newCol := self species new. self reverseDo: [:elem | newCol addLast: elem]. ^ newCol "#(2 3 4 'fred') reversed"! ! !OrderedCollection methodsFor: 'adding' stamp: ''! add: newObject after: oldObject "Add the argument, newObject, as an element of the receiver. Put it in the sequence just succeeding oldObject. Answer newObject." | index | index := self find: oldObject. self insert: newObject before: index + 1. ^newObject! ! !OrderedCollection methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2011 15:36'! at: anInteger "Answer my element at index anInteger. at: is used by a knowledgeable client to access an existing element" self ensureBoundsFrom: anInteger to: anInteger. ^ array at: anInteger + firstIndex - 1! ! !OrderedCollection methodsFor: 'adding' stamp: ''! add: newObject ^self addLast: newObject! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'bf 5/16/2000 16:30'! withIndexCollect: elementAndIndexBlock "Just like with:collect: except that the iteration index supplies the second argument to the block. Override superclass in order to use addLast:, not at:put:." | newCollection | newCollection := self species new: self size. firstIndex to: lastIndex do: [:index | newCollection addLast: (elementAndIndexBlock value: (array at: index) value: index - firstIndex + 1)]. ^ newCollection! ! !OrderedCollection methodsFor: 'adding' stamp: ''! add: newObject before: oldObject "Add the argument, newObject, as an element of the receiver. Put it in the sequence just preceding oldObject. Answer newObject." | index | index := self find: oldObject. self insert: newObject before: index. ^newObject! ! !OrderedCollection methodsFor: 'private' stamp: 'MarianoMartinezPeck 8/3/2011 14:37'! makeRoomAtFirst "Make some empty slots at the front of the array. If we have more than 50% free space, then just move the elements, so that the first 50% of the slots are free, otherwise add new free slots to the front by growing. Precondition: firstIndex = 1" | tally newFirstIndex newLastIndex | tally := self size. tally * 2 >= array size ifTrue: [ ^self growAtFirst ]. tally = 0 ifTrue: [ ^self resetTo: array size + 1 ]. newFirstIndex := array size // 2 + 1. newLastIndex := newFirstIndex - firstIndex + lastIndex. 0 to: tally - 1 do: [ :offset | array at: newLastIndex - offset put: (array at: lastIndex - offset) ]. array from: firstIndex to: newFirstIndex - 1 put: nil. firstIndex := newFirstIndex. lastIndex := newLastIndex! ! !OrderedCollection methodsFor: 'private' stamp: ''! collector "Private" ^ array! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'CamilloBruni 3/22/2013 23:52'! collect: collectBlock thenSelect: selectBlock "Optimized version Collection>>#collect:thenSelect:" | newCollection newElement | newCollection := self copyEmpty. firstIndex to: lastIndex do: [ :index | newElement := collectBlock value: (array at: index). (selectBlock value: newElement) ifTrue: [ newCollection addLast: newElement ]]. ^ newCollection! ! !OrderedCollection methodsFor: 'copying' stamp: ''! copyWith: newElement "Answer a copy of the receiver that is 1 bigger than the receiver and includes the argument, newElement, at the end." | newCollection | newCollection := self copy. newCollection add: newElement. ^newCollection! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'CamilloBruni 3/22/2013 23:52'! select: selectBlock thenCollect: collectBlock " Optimized version Collection>>#select:thenCollect: " | newCollection element | newCollection := self copyEmpty. firstIndex to: lastIndex do: [ :index | element := array at: index. (selectBlock value: element) ifTrue: [ newCollection addLast: (collectBlock value: element) ]]. ^ newCollection! ! !OrderedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:39'! size "Answer how many elements the receiver contains." ^ lastIndex - firstIndex + 1! ! !OrderedCollection methodsFor: 'copying' stamp: ''! copyEmpty "Answer a copy of the receiver that contains no elements." ^self species new! ! !OrderedCollection methodsFor: 'removing' stamp: ''! remove: oldObject ifAbsent: absentBlock | index | index := firstIndex. [index <= lastIndex] whileTrue: [oldObject = (array at: index) ifTrue: [self removeIndex: index. ^ oldObject] ifFalse: [index := index + 1]]. ^ absentBlock value! ! !OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:29'! insert: anObject before: spot " spot is an index in the range firstIndex .. lastIndex, such an index is not known from outside the collection. Never use this method in your code, it is meant for private use by OrderedCollection only. The methods for use are: #add:before: to insert an object before another object #add:beforeIndex: to insert an object before a given position. " | "index" delta spotIndex| spotIndex := spot. delta := spotIndex - firstIndex. firstIndex = 1 ifTrue: [self makeRoomAtFirst. spotIndex := firstIndex + delta]. firstIndex := firstIndex - 1. array replaceFrom: firstIndex to: spotIndex - 2 with: array startingAt: firstIndex + 1. array at: spotIndex - 1 put: anObject. " index := firstIndex := firstIndex - 1. [index < (spotIndex - 1)] whileTrue: [array at: index put: (array at: index + 1). index := index + 1]. array at: index put: anObject." ^ anObject! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'CamilloBruni 4/11/2011 15:34'! collect: aBlock from: fromIndex to: toIndex "Override superclass in order to use addLast:, not at:put:." | result | self ensureBoundsFrom: fromIndex to: toIndex. result := self species new: toIndex - fromIndex + 1. firstIndex + fromIndex - 1 to: firstIndex + toIndex - 1 do: [:index | result addLast: (aBlock value: (array at: index))]. ^ result ! ! !OrderedCollection methodsFor: 'removing' stamp: 'cmm 10/25/2010 22:26'! removeFirst: n "Remove first n object into an array" | list | list := self class arrayType new: n. 1 to: n do: [ : i | list at: i put: self removeFirst ]. ^ list! ! !OrderedCollection methodsFor: 'adding' stamp: ''! addAllFirst: anOrderedCollection "Add each element of anOrderedCollection at the beginning of the receiver. Answer anOrderedCollection." anOrderedCollection reverseDo: [:each | self addFirst: each]. ^anOrderedCollection! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'CamilloBruni 3/22/2013 23:51'! select: selectBlock "Optimized version of Collection>>#select: " | newCollection element | newCollection := self copyEmpty. firstIndex to: lastIndex do: [ :index | (selectBlock value: (element := array at: index)) ifTrue: [ newCollection addLast: element ]]. ^ newCollection! ! !OrderedCollection methodsFor: 'enumerating' stamp: ''! do: aBlock "Override the superclass for performance reasons." | index | index := firstIndex. [index <= lastIndex] whileTrue: [aBlock value: (array at: index). index := index + 1]! ! !OrderedCollection methodsFor: 'removing' stamp: ''! removeLast "Remove the last element of the receiver and answer it. If the receiver is empty, create an error notification." | lastObject | self emptyCheck. lastObject := array at: lastIndex. array at: lastIndex put: nil. lastIndex := lastIndex - 1. ^ lastObject! ! !OrderedCollection methodsFor: 'splitjoin' stamp: 'onierstrasz 4/12/2009 19:44'! join: aCollection | result | result := self class new. aCollection do: [:each | each appendTo: result] separatedBy: [self appendTo: result]. ^ result! ! !OrderedCollection methodsFor: 'copying' stamp: 'nice 5/28/2008 21:02'! postCopyFrom: startIndex to: endIndex "finish copying the array in a certain range." endIndex < startIndex ifFalse: [ "Because actual size of the array may be greater than used size, postCopyFrom:to: may fail to fail and answer an incorrect result if this sanity check were not applied" (startIndex between: 1 and: self size) ifFalse: [^self error: 'startIndex is out of bounds']. (endIndex between: 1 and: self size) ifFalse: [^self error: 'endIndex is out of bounds']]. "Add a protection that lacks in Array>>postcopy" array := array copyFrom: startIndex + firstIndex - 1 to: (endIndex max: startIndex - 1) + firstIndex - 1. firstIndex := 1. lastIndex := array size! ! !OrderedCollection methodsFor: 'removing' stamp: 'cmm 10/25/2010 22:26'! removeLast: n "Remove last n object into an array with last in last position" | list | list := self class arrayType new: n. n to: 1 by: -1 do: [ : i | list at: i put: self removeLast ]. ^ list! ! !OrderedCollection methodsFor: 'testing' stamp: 'CamilloBruni 4/11/2011 15:34'! ensureBoundsFrom: fromIndex to: toIndex (fromIndex < 1) ifTrue: [^self errorSubscriptBounds: fromIndex]. (toIndex + firstIndex - 1 > lastIndex) ifTrue: [^self errorSubscriptBounds: toIndex].! ! !OrderedCollection methodsFor: 'removing' stamp: 'StephaneDucasse 10/18/2010 14:51'! removeAllSuchThat: aBlock "Remove each element of the receiver for which aBlock evaluates to true. The method in Collection is O(N^2), this is O(N)." | n | n := firstIndex. firstIndex to: lastIndex do: [:index | (aBlock value: (array at: index)) ifFalse: [ array at: n put: (array at: index). n := n + 1]]. array from: n to: lastIndex put: nil. lastIndex := n - 1! ! !OrderedCollection class methodsFor: 'instance creation' stamp: 'cmm 10/25/2010 22:27'! new: anInteger ^ self basicNew setCollection: (self arrayType new: anInteger)! ! !OrderedCollection class methodsFor: 'stream creation' stamp: 'CamilloBruni 9/5/2011 15:48'! new: size streamContents: aBlock ^ self withAll: (super new: size streamContents: aBlock)! ! !OrderedCollection class methodsFor: 'accessing' stamp: 'CamilloBruni 9/5/2011 15:38'! streamSpecies ^ Array! ! !OrderedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:41'! new ^ self new: 10! ! !OrderedCollection class methodsFor: 'instance creation' stamp: ''! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." | newCollection | newCollection := self new: aCollection size. newCollection addAll: aCollection. ^newCollection " OrderedCollection newFrom: {1. 2. 3} {1. 2. 3} as: OrderedCollection {4. 2. 7} as: SortedCollection "! ! !OrderedCollection class methodsFor: 'instance creation' stamp: 'apb 10/15/2000 22:02'! ofSize: n "Create a new collection of size n with nil as its elements. This method exists because OrderedCollection new: n creates an empty collection, not one of size n." | collection | collection := self new: n. collection setContents: (collection collector). ^ collection ! ! !OrderedCollection class methodsFor: 'private' stamp: 'cmm 10/25/2010 22:26'! arrayType ^ Array! ! !OrderedCollection class methodsFor: 'instance creation' stamp: 'cmm 10/25/2010 22:28'! new: anInteger withAll: anObject ^ self basicNew setContents: (self arrayType new: anInteger withAll: anObject)! ! !OrderedCollectionTest commentStamp: 'BG 1/10/2004 22:07'! These test cases demonstrate addition of items into an OrderedCollection as well as item removal. Some of the assertions are quite complicated and use a lot of collection protocol. Such methods do not test one single method, but protocol in general.! !OrderedCollectionTest methodsFor: 'tests - remove' stamp: ''! testRemoveAllError "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self elementNotIn. aSubCollection := self nonEmptyWithoutEqualElements copyWith: el. self should: [ | res | res := self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! ! !OrderedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButLast "self debug: #testAllButLast" | abf col | col := self moreThan3Elements. abf := col allButLast. self deny: abf last = col last. self assert: abf size + 1 = col size! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'SebastianTleye 6/28/2013 14:37'! simpleCollection ^simpleCollection.! ! !OrderedCollectionTest methodsFor: 'tests - begins ends with' stamp: ''! testsEndsWith self assert: (self nonEmpty endsWith: self nonEmpty copyWithoutFirst). self assert: (self nonEmpty endsWith: self nonEmpty). self deny: (self nonEmpty endsWith: (self nonEmpty copyWith: self nonEmpty first)).! ! !OrderedCollectionTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceAllWith1Occurence | result firstIndexesOfOccurrence index endPartIndexResult endPartIndexCollection | result := self collectionWith1TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection . "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection . index:= firstIndexesOfOccurrence at: 1. "verify content of 'result' : " "first part of 'result'' : '" 1 to: (index -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " index to: (index + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - index + 1 )) ]. " end part :" endPartIndexResult := index + self replacementCollection size . endPartIndexCollection := index + self oldSubCollection size . 1 to: (result size - endPartIndexResult - 1 ) do: [ :i | self assert: (result at: ( endPartIndexResult + i - 1 ) ) = (self collectionWith1TimeSubcollection at: ( endPartIndexCollection + i - 1 ) ). ]. ! ! !OrderedCollectionTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElementsOfIdenticalCollectionObjects "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" self assert: (self empty hasEqualElements: self empty). self assert: (self nonEmpty hasEqualElements: self nonEmpty). ! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOf "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing) = 0! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyWithReplacementTest self replacementCollection. self oldSubCollection. self collectionWith1TimeSubcollection. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection) = 1! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:52'! moreThan4Elements " return a collection including at leat 4 elements" ^ indexCollection ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:42'! secondIndex " return an index between 'nonEmpty' bounds that is > to 'second index' " ^2! ! !OrderedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''! testFirstNElements "self debug: #testFirstNElements" | result | result := self moreThan3Elements first: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements first: self moreThan3Elements size + 1 ] raise: Error! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:27'! collectionWith2TimeSubcollection " return a collection including 'oldSubCollection' two or many time " ^ (((OrderedCollection new add: elementNotIn; yourself),self oldSubCollection ) add: elementNotIn;yourself),self oldSubCollection! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''! testTWrite | added collection elem | collection := self otherCollection . elem := self element . added := collection write: elem . self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: elem ) . self assert: (collection includes: elem ). ! ! !OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''! testFromToPut | collection index | index := self indexArray anyOne. collection := self nonEmpty copy. collection from: 1 to: index put: self aValue.. 1 to: index do: [:i | self assert: (collection at: i)= self aValue]. (index +1) to: collection size do: [:i | self assert: (collection at:i)= (self nonEmpty at:i)].! ! !OrderedCollectionTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithoutFirst | result | result := self nonEmpty copyWithoutFirst. self assert: result size = (self nonEmpty size - 1). 1 to: result size do: [:i | self assert: (result at: i)= (self nonEmpty at: (i + 1))].! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0TStructuralEqualityTest self empty. self nonEmpty. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionTwoSimilarElementsInIntersection "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self assert: (self collection occurrencesOf: self anotherElementOrAssociationIn) = self numberOfSimilarElementsInIntersection. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testBefore "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2)) = (self moreThan4Elements at: 1). self should: [ self moreThan4Elements before: (self moreThan4Elements at: 1) ] raise: Error. self should: [ self moreThan4Elements before: 66 ] raise: Error! ! !OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testLastIndexOfDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element) = collection size! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'StephaneDucasse 3/22/2010 21:17'! testAddBeforeIndex "self run: #testAddBeforeIndex" | l | l := #(1 2 3 4) asOrderedCollection. l add: 77 beforeIndex: 1. self assert: (l = #(77 1 2 3 4) asOrderedCollection). l add: 88 beforeIndex: 3. self assert: (l = #(77 1 88 2 3 4) asOrderedCollection). l add: 99 beforeIndex: l size+1. self assert: (l = #(77 1 88 2 3 4 99) asOrderedCollection). self should:[l add: 666 beforeIndex: 0] raise: Error. self should:[l add: 666 beforeIndex: l size+2] raise: Error. "Now make room by removing first two and last two elements, and see if the illegal bounds test still fails" (l first: 2) , (l last: 2) reversed do: [:e | l remove: e]. self should:[l add: 666 beforeIndex: 0] raise: Error. self should:[l add: 666 beforeIndex: l size+2] raise: Error. ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:56'! collectionOfFloat ^ collectionOfFloat ! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 19:00'! testAdd | l | l := #(1 2 3 4) asOrderedCollection. l add: 88. self assert: (l = #(1 2 3 4 88) asOrderedCollection). l add: 99. self assert: (l = #(1 2 3 4 88 99) asOrderedCollection). ! ! !OrderedCollectionTest methodsFor: 'tests - sequence isempty' stamp: ''! testSequenceIfNotEmptyifEmpty self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! ! !OrderedCollectionTest methodsFor: 'test - creation' stamp: ''! testWith "self debug: #testWith" | aCol anElement | anElement := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: anElement. self assert: (aCol includes: anElement).! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:12'! collectionWithoutEqualElements " return a collection not including equal elements " ^ withoutEqualElements ! ! !OrderedCollectionTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedArray | result collection | collection := self collectionWithSortableElements . result := collection asArray sort. self assert: (result class includesBehavior: Array). self assert: result isSorted. self assert: result size = collection size! ! !OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''! testTWriteTwice | added oldSize collection elem | collection := self collectionWithElement . elem := self element . oldSize := collection size. added := collection write: elem ; write: elem . self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: elem ). self assert: collection size = (oldSize + 2)! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyUpToWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpTo:' should copy until the first occurence :" result := collection copyUpTo: (element ). "verifying content: " self assert: result isEmpty. ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindFirst | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. self assert: result=1. ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithIndexCollect | result index collection | index := 0. collection := self nonEmptyMoreThan1Element . result := collection withIndexCollect: [:each :i | self assert: i = (index := index + 1). self assert: i = (collection indexOf: each) . each] . 1 to: result size do:[: i | self assert: (result at:i)= (collection at: i)]. self assert: result size = collection size.! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:41'! firstIndex " return an index between 'nonEmpty' bounds that is < to 'second index' " ^1! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! testOFixtureReplacementSequencedTest self nonEmpty. self deny: self nonEmpty isEmpty. self elementInForReplacement. self assert: (self nonEmpty includes: self elementInForReplacement ) . self newElement. self firstIndex. self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). self secondIndex. self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). self assert: self firstIndex <=self secondIndex . self replacementCollection. self replacementCollectionSameSize. self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size ! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''! testCopyNotSame "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self nonEmpty copy. self deny: copy == self nonEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''! testTAddAll | added collection toBeAdded | collection := self collectionWithElement . toBeAdded := self otherCollection . added := collection addAll: toBeAdded . self assert: added == toBeAdded . "test for identiy because #addAll: has not reason to copy its parameter." self assert: (collection includesAll: toBeAdded )! ! !OrderedCollectionTest methodsFor: 'tests - printing' stamp: ''! testPrintElementsOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printElementsOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'DamienCassou 8/23/2013 10:30'! unsortedCollection ^ OrderedCollection new add: 3; add: 1; add: 20; add: 4; add: 2; yourself! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''! testTAddWithOccurences | added oldSize collection anElement | collection := self collectionWithElement . anElement := self element . oldSize := collection size. added := collection add: anElement withOccurrences: 5. self assert: added == anElement. "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: anElement). self assert: collection size = (oldSize + 5)! ! !OrderedCollectionTest methodsFor: 'tests - begins ends with' stamp: ''! testsEndsWithEmpty self deny: (self nonEmpty endsWith: self empty). self deny: (self empty endsWith: self nonEmpty). ! ! !OrderedCollectionTest methodsFor: 'tests - removing' stamp: 'sd 3/21/2006 22:39'! testRemoveFirst "Allows one to remove n element of a collection at the first" "self run:#testRemoveFirst" | c1 | c1 := #(2 3 4 6) asOrderedCollection. c1 removeFirst: 1. self assert: (c1 = #(3 4 6) asOrderedCollection). c1 removeFirst: 2. self assert: (c1 = #(6) asOrderedCollection). self should: [c1 removeFirst: 10] raise: Error. ! ! !OrderedCollectionTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithSequenceable | result index element | index := self indexInNonEmpty . element := self nonEmpty at: index. result := self nonEmpty copyWith: (element ). self assert: result size = (self nonEmpty size + 1). self assert: result last = element . 1 to: (result size - 1) do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i ))].! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIterateSequencedReadableTest | res | self nonEmptyMoreThan1Element. self assert: self nonEmptyMoreThan1Element size > 1. self empty. self assert: self empty isEmpty . res := true. self nonEmptyMoreThan1Element detect: [ :each | (self nonEmptyMoreThan1Element occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false.! ! !OrderedCollectionTest methodsFor: 'tests - concatenation' stamp: ''! testConcatenationWithEmpty | result | result:= self empty,self secondCollection . 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:i). ]. "size : " self assert: result size = ( self secondCollection size).! ! !OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''! testSwapWith "self debug: #testSwapWith" | result index | index := self indexArray anyOne. result:= self nonEmpty copy . result swap: index with: 1. self assert: (result at: index) = (self nonEmpty at:1). self assert: (result at: 1) = (self nonEmpty at: index). ! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyUpToLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyUpToLast:' should copy until the last occurence :" result := collection copyUpToLast: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (result at: i ) = ( collection at: i ) ]. self assert: result size = (collection size - 1). ! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:57'! anotherElementNotIn ^ 42! ! !OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtAllIndexesPut self nonEmpty atAllPut: self aValue. self nonEmpty do:[ :each| self assert: each = self aValue]. ! ! !OrderedCollectionTest methodsFor: 'tests - removing' stamp: 'sd 3/21/2006 22:39'! testRemoveIfAbsent "Allows one to remove an element from a collection and to copy it in another collection." "If the element isn't in the first collection, the second collection copy the element after ifAbsent" "self run:#testRemoveIfAbsent" | c1 c2 | c1 := #(1 2 3 4) asOrderedCollection. c2 := OrderedCollection new. c2 add: (c1 remove: 2 ifAbsent: [6]). self assert: (c1 = #(1 3 4) asOrderedCollection). self assert: (c2 = #(2) asOrderedCollection). c2 add: (c1 remove: 18 ifAbsent: [6]). self assert: (c1 = #(1 3 4) asOrderedCollection). self assert: (c2 = #(2 6) asOrderedCollection).! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 18:59'! testAddLast | l | l := #(1 2 3 4) asOrderedCollection. l addLast: 88. self assert: (l = #(1 2 3 4 88) asOrderedCollection). l addLast: 99. self assert: (l = #(1 2 3 4 88 99) asOrderedCollection). ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:40'! collectionWith1TimeSubcollection " return a collection including 'oldSubCollection' only one time " ^ ((OrderedCollection new add: elementNotIn; yourself),self oldSubCollection) add: elementNotIn;yourself ! ! !OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtAllPut | | self nonEmpty atAll: self indexArray put: self aValue.. self indexArray do: [:i | self assert: (self nonEmpty at: i)=self aValue ]. ! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testAtOutOfBounds "self debug: #testAtOutOfBounds" self should: [ self moreThan4Elements at: self moreThan4Elements size + 1 ] raise: Error. self should: [ self moreThan4Elements at: -1 ] raise: Error! ! !OrderedCollectionTest methodsFor: 'test - creation' stamp: ''! testOfSize "self debug: #testOfSize" | aCol | aCol := self collectionClass ofSize: 3. self assert: (aCol size = 3). ! ! !OrderedCollectionTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !OrderedCollectionTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: 'cm 3/8/2006 10:02'! testWithCollect "Allows one to collect some element of two collections into another collection with element corresponding to the condition in the blocks" "self run: #testWithCollect" | c1 c2 res | c1 := #(-1 2 -3 4 -5 6 -7 8) asOrderedCollection. c2 := #(-9 10 -11 12 -13 14 -15 16) asOrderedCollection. res := c1 with: c2 collect: [:each1 :each2 | each1 < each2 ifTrue: [each1] ifFalse: [each2]]. self assert: (res = #(-9 2 -11 4 -13 6 -15 8) asOrderedCollection). ! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastOne | delim oneItemStream result | delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim last: 'and'. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSetAritmeticTest self collection. self deny: self collection isEmpty. self nonEmpty. self deny: self nonEmpty isEmpty. self anotherElementOrAssociationNotIn. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self collectionClass! ! !OrderedCollectionTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiter | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' . allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString). ].! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:03'! elementInCollectionOfFloat ^ collectionOfFloat anyOne.! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''! testTAddTwice | added oldSize collection anElement | collection := self collectionWithElement . anElement := self element . oldSize := collection size. added := collection add: anElement ; add: anElement . self assert: added == anElement . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: anElement ). self assert: collection size = (oldSize + 2)! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 11:17'! collectionWithoutNilElements " return a collection that doesn't includes a nil element and that doesn't includes equal elements'" ^ withoutEqualElements ! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePutTest self aValue. self anotherValue. self anIndex. self nonEmpty isDictionary ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. self empty. self assert: self empty isEmpty . self nonEmpty. self deny: self nonEmpty isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self collectionWithoutEqualElements. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !OrderedCollectionTest methodsFor: 'tests - replacing' stamp: ''! testReplaceFromToWithStartingAt | result repStart collection replacementCollec firstInd secondInd | collection := self nonEmpty . result := collection copy. replacementCollec := self replacementCollectionSameSize . firstInd := self firstIndex . secondInd := self secondIndex . repStart := replacementCollec size - ( secondInd - firstInd + 1 ) + 1. result replaceFrom: firstInd to: secondInd with: replacementCollec startingAt: repStart . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstInd - 1 ) do: [ :i | self assert: ( collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstInd ) to: ( replacementCollec size - repStart +1 ) do: [:i| self assert: (result at: i)=( replacementCollec at: ( repStart + ( i - firstInd ) ) ) ]. " end part :" ( firstInd + replacementCollec size ) to: ( result size ) do: [ :i | self assert: ( result at: i ) = ( collection at: ( secondInd + 1 - ( firstInd + replacementCollec size ) + i ) ) ].! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: ''! valueArray " return a collection (with the same size than 'indexArray' )of values to be put in 'nonEmpty' at indexes in 'indexArray' " | result | result := Array new: self indexArray size. 1 to: result size do: [:i | result at:i put: (self aValue ). ]. ^ result.! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeWithIdentityTest | anElement | self collectionWithCopyNonIdentical. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterMore | delim multiItemStream result index | "delim := ', '. multiItemStream := '' readWrite. self oneTwoThreeItemCol asStringOn: multiItemStream delimiter: ', '. self assert: multiItemStream contents = '1, 2, 3'." delim := ', '. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', '. index:=1. (result findBetweenSubStrs: ', ' )do: [:each | self assert: each= ((self nonEmpty at:index)asString). index:=index+1 ].! ! !OrderedCollectionTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementThatExists "self debug: #testRemoveElementThatExists" | el res | el := self nonEmptyWithoutEqualElements anyOne. res := self nonEmptyWithoutEqualElements remove: el. self assert: res == el! ! !OrderedCollectionTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! anIndex ^ 2! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 13:59'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^collection5Elements ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testDetectSequenced " testing that detect keep the first element returning true for sequenceable collections " | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element detect: [:each | each notNil ]. self assert: result = element. ! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''! testIdentityIncludesNonSpecificComportement " test the same comportement than 'includes: ' " | collection | collection := self nonEmpty . self deny: (collection identityIncludes: self elementNotIn ). self assert:(collection identityIncludes: collection anyOne) ! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureAsStringCommaAndDelimiterTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty. self nonEmpty1Element. self assert: self nonEmpty1Element size = 1! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:16'! collectionMoreThan1NoDuplicates " return a collection of size 5 without equal elements" ^ withoutEqualElements ! ! !OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: 'sd 3/21/2006 22:41'! testCollect "Allows one to collect some element of a collection into another collection" "self run: #testCollect" | c1 c2 res | c1 := #(-1 2 -3 4) asOrderedCollection. c2 := #(1 2 3 4) asOrderedCollection. res := c1 collect: [:each | each abs]. self assert: (c2 = res).! ! !OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''! testFlattened self assert: self simpleCollection flattened equals: #(1 8 3). self assert: self collectionOfCollectionsOfInts flattened equals: #( 1 2 3 4 5 6 ). self assert: self collectionWithCharacters flattened equals: #($a $x $d $c $m). self assert: self collectionOfCollectionsOfStrings flattened equals: #('foo' 'bar' 'zorg').! ! !OrderedCollectionTest methodsFor: 'as yet unclassified' stamp: ''! testSorted | result tmp unsorted | unsorted := self unsortedCollection. result := unsorted sorted. self deny: unsorted == result. tmp := result at: 1. result do: [ :each | self assert: each >= tmp. tmp := each ]! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''! testIncludesAnyAllThere "self debug: #testIncludesAnyOfAllThere'" self deny: (self nonEmpty includesAny: self empty). self assert: (self nonEmpty includesAny: { self nonEmpty anyOne }). self assert: (self nonEmpty includesAny: self nonEmpty).! ! !OrderedCollectionTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! elementToAdd ^ 55! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testPairsDo | index | index:=1. self nonEmptyMoreThan1Element pairsDo: [:each1 :each2 | self assert:(self nonEmptyMoreThan1Element at:index)=each1. self assert:(self nonEmptyMoreThan1Element at:(index+1))=each2. index:=index+2]. self nonEmptyMoreThan1Element size odd ifTrue:[self assert: index=self nonEmptyMoreThan1Element size] ifFalse:[self assert: index=(self nonEmptyMoreThan1Element size+1)].! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: ''! collectionWithCopy "return a collection of type 'self collectionWIithoutEqualsElements class' containing no elements equals ( with identity equality) but 2 elements only equals with classic equality" | result collection | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. collection add: collection first copy. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !OrderedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''! testLastNElements "self debug: #testLastNElements" | result | result := self moreThan3Elements last: self moreThan3Elements size - 1. 1 to: result size do: [ :i | self assert: (result at: i) = (self moreThan3Elements at: i + 1) ]. self assert: result size = (self moreThan3Elements size - 1). self should: [ self moreThan3Elements last: self moreThan3Elements size + 1 ] raise: Error! ! !OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: 'cm 3/8/2006 09:09'! testCollectFromTo "Allows one to collect some element of a collection into another collection between a first index and an end index for the collect" "self run: #testCollectFromTo" | c1 res | c1 := #(-1 2 -3 4 -5 6 -7 8) asOrderedCollection. res := c1 collect: [:each | each abs] from: 1 to: 3. self assert: (res = #(1 2 3) asOrderedCollection). self should: [c1 collect: [:each | each abs] from: 10 to: 13] raise: Error. self should: [c1 collect: [:each | each abs] from: 5 to: 2] raise: Error.! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/30/2008 19:03'! accessCollection ^ indexCollection! ! !OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''! testFlatCollect self assert: (self simpleCollection flatCollect: [ :x | { x } ]) equals: self simpleCollection. self assert: (self simpleCollection flatCollect: [ :x | { x } ]) species = self simpleCollection species. self assert: (self collectionOfCollectionsOfInts flatCollect: [ :x | { x } ]) equals: self collectionOfCollectionsOfInts. self assert: (self collectionWithCharacters flatCollect: [ :x | { x } ]) equals: self collectionWithCharacters. self assert: (self collectionOfCollectionsOfStrings flatCollect: [ :x | { x } ]) equals: self collectionOfCollectionsOfStrings! ! !OrderedCollectionTest methodsFor: 'tests - printing' stamp: ''! testPrintNameOn | aStream result | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printNameOn: aStream . Transcript show: result asString. self nonEmpty class name first isVowel ifTrue:[ self assert: aStream contents =('an ',self nonEmpty class name ) ] ifFalse:[self assert: aStream contents =('a ',self nonEmpty class name)].! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0SortingArrayedTest | tmp sorted | " an unsorted collection of number " self unsortedCollection. self unsortedCollection do: [ :each | each isNumber ]. sorted := true. self unsortedCollection pairsDo: [ :each1 :each2 | each2 < each1 ifTrue: [ sorted := false ] ]. self assert: sorted = false. " a collection of number sorted in an ascending order" self sortedInAscendingOrderCollection. self sortedInAscendingOrderCollection do: [ :each | each isNumber ]. tmp := self sortedInAscendingOrderCollection at: 1. self sortedInAscendingOrderCollection do: [ :each | self assert: each >= tmp. tmp := each ]! ! !OrderedCollectionTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceAllWithManyOccurence | result firstIndexesOfOccurrence resultBetweenPartIndex collectionBetweenPartIndex diff | " testing fixture here as this method may be not used for collection that can't contain equals element :" self collectionWith2TimeSubcollection. self assert: (self howMany: self oldSubCollection in: self collectionWith2TimeSubcollection) = 2. " test :" diff := self replacementCollection size - self oldSubCollection size. result := self collectionWith2TimeSubcollection copyReplaceAll: self oldSubCollection with: self replacementCollection. "detecting indexes of olSubCollection" firstIndexesOfOccurrence := self firstIndexesOf: self oldSubCollection in: self collectionWith2TimeSubcollection. " verifying that replacementCollection has been put in places of oldSubCollections " firstIndexesOfOccurrence do: [ :each | (firstIndexesOfOccurrence indexOf: each) = 1 ifTrue: [ each to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ifFalse: [ each + diff to: self replacementCollection size do: [ :i | self assert: (result at: i) = (self replacementCollection at: i - each + 1) ] ] ]. " verifying that the 'between' parts correspond to the initial collection : " 1 to: firstIndexesOfOccurrence size do: [ :i | i = 1 ifTrue: [ 1 to: (firstIndexesOfOccurrence at: i) - 1 do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ] ifFalse: [ resultBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self replacementCollection size. collectionBetweenPartIndex := (firstIndexesOfOccurrence at: i - 1) + self oldSubCollection size. 1 to: (firstIndexesOfOccurrence at: i) - collectionBetweenPartIndex - 1 do: [ :j | self assert: (result at: resultBetweenPartIndex + i - 1) = (self collectionWith2TimeSubcollection at: collectionBetweenPartIndex + i - 1) ] ] " specific comportement for the begining of the collection :" " between parts till the end : " ]. "final part :" 1 to: self collectionWith2TimeSubcollection size - (firstIndexesOfOccurrence last + self oldSubCollection size) do: [ :i | self assert: (result at: firstIndexesOfOccurrence last + self replacementCollection size - 1 + i) = (self collectionWith2TimeSubcollection at: firstIndexesOfOccurrence last + self oldSubCollection size - 1 + i) ]! ! !OrderedCollectionTest methodsFor: 'test - equality' stamp: ''! testEqualSignIsTrueForNonIdenticalButEqualCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). self assert: (self nonEmpty = self nonEmpty copy). self assert: (self nonEmpty copy = self nonEmpty). self assert: (self nonEmpty copy = self nonEmpty copy).! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'CamilloBruni 8/31/2013 20:23'! testAtIfAbsentPut "Allows one to add an element at an index if no element exist at this index" "self run:#testAtIfAbsentPut" | c | c := #(1 2 3 4) asOrderedCollection. c at: 2 ifAbsentPut: [ 5 ]. self assert: c = #(1 2 3 4) asOrderedCollection. c at: 5 ifAbsentPut: [ 5 ]. self assert: c = #(1 2 3 4 5) asOrderedCollection. c at: 7 ifAbsentPut: [ 7 ]. self assert: c = #(1 2 3 4 5 nil 7) asOrderedCollection! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:42'! elementInForElementAccessing " return an element inculded in 'accessCollection '" ^ self accessCollection anyOne! ! !OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent:startingAt: should return the position of the first occurrence :'" self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 55 ]) = 1. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 55 ]) = collection size! ! !OrderedCollectionTest methodsFor: 'tests - copying with replacement' stamp: ''! testCopyReplaceFromToWithInsertion | result indexOfSubcollection | indexOfSubcollection := (self firstIndexesOf: self oldSubCollection in: self collectionWith1TimeSubcollection) at: 1. result := self collectionWith1TimeSubcollection copyReplaceFrom: indexOfSubcollection to: ( indexOfSubcollection - 1 ) with: self replacementCollection . "verify content of 'result' : " "first part of 'result'' : '" 1 to: (indexOfSubcollection -1) do: [ :i | self assert: (self collectionWith1TimeSubcollection at:i)=(result at: i) ]. " middle part containing replacementCollection : " indexOfSubcollection to: (indexOfSubcollection + self replacementCollection size-1) do: [ :i | self assert: ( result at: i )=(self replacementCollection at: ( i - indexOfSubcollection +1 )) ]. " end part :" (indexOfSubcollection + self replacementCollection size) to: (result size) do: [:i| self assert: (result at: i)=(self collectionWith1TimeSubcollection at: (i-self replacementCollection size))]. " verify size: " self assert: result size=(self collectionWith1TimeSubcollection size + self replacementCollection size). ! ! !OrderedCollectionTest methodsFor: 'tests - replacing' stamp: ''! testReplaceFromToWith | result collection replacementCollec firstInd secondInd | collection := self nonEmpty . replacementCollec := self replacementCollectionSameSize . firstInd := self firstIndex . secondInd := self secondIndex . result := collection copy. result replaceFrom: firstInd to: secondInd with: replacementCollec . "verify content of 'result' : " "first part of 'result'' : '" 1 to: ( firstInd - 1 ) do: [ :i | self assert: (collection at:i ) = ( result at: i ) ]. " middle part containing replacementCollection : " ( firstInd ) to: ( firstInd + replacementCollec size - 1 ) do: [ :i | self assert: ( result at: i ) = ( replacementCollec at: ( i - firstInd +1 ) ) ]. " end part :" ( firstInd + replacementCollec size) to: (result size) do: [:i| self assert: ( result at: i ) = ( collection at: ( secondInd + 1 - ( firstInd + replacementCollec size ) + i ) ) ]. ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:42'! newElement "return an element that will be put in the collection in place of another" ^999! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringMore "self assert: self oneTwoThreeItemCol asCommaString = '1, 2, 3'. self assert: self oneTwoThreeItemCol asCommaStringAnd = '1, 2 and 3' " | result resultAnd index allElementsAsString | result:= self nonEmpty asCommaString . resultAnd:= self nonEmpty asCommaStringAnd . index := 1. (result findBetweenSubStrs: ',' )do: [:each | index = 1 ifTrue: [self assert: each= ((self nonEmpty at:index)asString)] ifFalse: [self assert: each= (' ',(self nonEmpty at:index) asString)]. index:=index+1 ]. "verifying esultAnd :" allElementsAsString:=(resultAnd findBetweenSubStrs: ',' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size ) ifTrue: [ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i) asString)] ifFalse:[self assert: (allElementsAsString at:i)=(' ',(self nonEmpty at:i) asString)] ]. i=(allElementsAsString size) ifTrue:[ i = 1 ifTrue:[self assert: (allElementsAsString at:i)=( (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ifFalse:[self assert: (allElementsAsString at:i)=( ' ' , (self nonEmpty at:i ) asString ,' and ', (self nonEmpty at: ( i + 1) ) asString )] ]. ].! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWith "self debug: #testCopyNonEmptyWith" | res anElement | anElement := self elementToAdd . res := self nonEmpty copyWith: anElement. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self assert: (res includes: (anElement value)). self nonEmpty do: [ :each | res includes: each ]! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'sd 3/21/2006 22:36'! testAddAllFirstUnlessAlreadyPresent "Allows one to add each element of an orderedCollection at the beginning of another orderedCollection preserving the order but no duplicate element" "self run:#testAddAllFirstUnlessAlreadyPresent" | c1 c2 c3 | c1 := #(1 2 3 4 ) asOrderedCollection. c2 := #(5 6 7 8 9 ) asOrderedCollection. c3 := #(0 1 ) asOrderedCollection. c2 addAllFirstUnlessAlreadyPresent: c1. self assert: c2 = #(1 2 3 4 5 6 7 8 9 ) asOrderedCollection. c1 addAllFirstUnlessAlreadyPresent: c3. self deny: c1 = #(0 1 1 2 3 4 ) asOrderedCollection. self assert: c1 = #(0 1 2 3 4 ) asOrderedCollection. ! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! testCopyNonEmptyWithoutAllNotIncluded ! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''! testIdentityIndexOfIAbsent | collection element | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = 1. self assert: (collection identityIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 55 ]) = 55! ! !OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtAllPutAll | aValueArray | aValueArray := self valueArray . self nonEmpty atAll: self indexArray putAll: aValueArray . 1 to: self indexArray size do: [:i | self assert: (self nonEmpty at:(self indexArray at: i))= (aValueArray at:i) ]! ! !OrderedCollectionTest methodsFor: 'testsRemoving' stamp: 'nice 9/14/2009 20:57'! testRemoveAll "Allows one to remove all elements of a collection" | c1 c2 s2 | c1 := #(2 3 4 6) asOrderedCollection. c1 addAll: (1 to: 200). c2 := c1 copy. s2 := c2 size. c1 removeAll. self assert: c1 size = 0. self assert: c2 size = s2 description: 'the copy has not been modified' ! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyEmptyMethod | result | result := self collectionWithoutEqualElements copyEmpty . self assert: result isEmpty . self assert: result class= self nonEmpty class.! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:10'! collectionWithEqualElements " return a collecition including atLeast two elements equal" ^collectionWithDuplicateElement ! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''! testIndexOfSubCollectionStartingAt "self debug: #testIndexOfIfAbsent" | subcollection index collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. index := collection indexOfSubCollection: subcollection startingAt: 1. self assert: index = 1. index := collection indexOfSubCollection: subcollection startingAt: 2. self assert: index = 0! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 18:58'! testAddFirst | l | l := #(1 2 3 4) asOrderedCollection. l addFirst: 88. self assert: (l = #(88 1 2 3 4) asOrderedCollection). l addFirst: 99. self assert: (l = #(99 88 1 2 3 4) asOrderedCollection). ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:24'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ collectionOfFloat ! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyAfterWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection last. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the first occurence :" result := collection copyAfter: (element ). "verifying content: " 1 to: result size do: [:i | self assert: (collection at:(i + 1 )) = (result at: (i)) ]. "verify size: " self assert: result size = (collection size - 1).! ! !OrderedCollectionTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollectionWithSortBlock | result tmp | result := self collectionWithSortableElements asSortedCollection: [:a :b | a > b]. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (self collectionWithSortableElements occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = self collectionWithSortableElements size. tmp:=result at: 1. result do: [:each| self assert: tmp>=each. tmp:=each]. ! ! !OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''! testFlatCollectAs self assert: (self simpleCollection flatCollect: [ :x | { x }, { x } ] as: IdentitySet) equals: self simpleCollection asIdentitySet! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 8/31/2013 20:23'! test0FixtureTConvertAsSetForMultiplinessTest "a collection ofFloat with equal elements:" | res | self withEqualElements. self withEqualElements do: [ :each | self assert: each class = Float ]. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true. "a collection of Float without equal elements:" self elementsCopyNonIdenticalWithoutEqualElements. self elementsCopyNonIdenticalWithoutEqualElements do: [ :each | self assert: each class = Float ]. res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !OrderedCollectionTest methodsFor: 'tests - sorting' stamp: ''! testSortedUsingBlock | result tmp | result := self unsortedCollection sorted: [:a :b | a>b].. tmp := result at: 1. result do: [:each | self assert: each<=tmp. tmp:= each. ].! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 19:07'! testAddItem2 | collection | collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. collection add: 'James' before: 'Jim'. collection add: 'Margaret' before: 'Andrew'. self assert: (collection indexOf: 'James') + 1 = (collection indexOf: 'Jim'). self assert: (collection indexOf: 'Margaret') + 1 = (collection indexOf: 'Andrew')! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''! testIdentityIndexOf "self debug: #testIdentityIndexOf" | collection element | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! !OrderedCollectionTest methodsFor: 'test - creation' stamp: ''! testWithAll "self debug: #testWithAll" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection . aCol := self collectionClass withAll: collection . collection do: [ :each | self assert: (aCol occurrencesOf: each ) = ( collection occurrencesOf: each ) ]. self assert: (aCol size = collection size ).! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIndexAccessTest | res collection element | self collectionMoreThan1NoDuplicates. self assert: self collectionMoreThan1NoDuplicates size > 1. res := true. self collectionMoreThan1NoDuplicates detect: [ :each | (self collectionMoreThan1NoDuplicates occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self elementInForIndexAccessing. self assert: ((collection := self collectionMoreThan1NoDuplicates) includes: (element := self elementInForIndexAccessing)). self elementNotInForIndexAccessing. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureOccurrencesTest | tmp | self empty. self assert: self empty isEmpty. self collectionWithoutEqualElements. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each ]. self elementNotInForOccurrences. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !OrderedCollectionTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 18:57'! testAddBefore | l | l := #(1 2 3 4) asOrderedCollection. l add: 88 before: 1. self assert: (l = #(88 1 2 3 4) asOrderedCollection). l add: 99 before: 2. self assert: (l = #(88 1 99 2 3 4) asOrderedCollection). ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := 0. firstCollection with: secondCollection do: [:a :b | ( index := index + 1). self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b.] ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 12/18/2009 13:11'! secondCollection " return a collection that will be the second part of the concatenation" ^ collectionWith4Elements ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'sd 6/5/2005 09:21'! testAddItem1 | collection size | collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. size := collection size. collection add: 'James' before: 'Jim'. collection add: 'Margaret' before: 'Andrew'. self assert: size + 2 = collection size. ! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testAtWrap "self debug: #testAt" " self assert: (self accessCollection at: 1) = 1. self assert: (self accessCollection at: 2) = 2. " | index | index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index + self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: index - self moreThan4Elements size) = self elementInForElementAccessing. self assert: (self moreThan4Elements atWrap: 1 + self moreThan4Elements size) = (self moreThan4Elements at: 1)! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithout "self debug: #testCopyNonEmptyWithout" | res anElementOfTheCollection | anElementOfTheCollection := self nonEmpty anyOne. res := (self nonEmpty copyWithout: anElementOfTheCollection). "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self deny: (res includes: anElementOfTheCollection). self nonEmpty do: [:each | (each = anElementOfTheCollection) ifFalse: [self assert: (res includes: each)]]. ! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutNotIncluded "self debug: #testCopyNonEmptyWithoutNotIncluded" | res | res := self nonEmpty copyWithout: self elementToAdd. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self nonEmpty do: [ :each | self assert: (res includes: each) ]! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testAllButFirstDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButFirstDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i +1))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !OrderedCollectionTest methodsFor: 'tests - concatenation' stamp: ''! testConcatenation | result index | result:= self firstCollection,self secondCollection . "first part : " index := 1. self firstCollection do: [:each | self assert: (self firstCollection at: index)=each. index := index+1.]. "second part : " 1 to: self secondCollection size do: [:i | self assert: (self secondCollection at:i)= (result at:index). index:=index+1]. "size : " self assert: result size = (self firstCollection size + self secondCollection size).! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'DamienCassou 8/23/2013 10:28'! sortedInAscendingOrderCollection " return a collection sorted in an acsending order" ^ OrderedCollection new add: 1; add: 2; add: 3; add: 4; add: 5; yourself! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionItself "self debug: #testIntersectionItself" | result | result := (self collectionWithoutEqualElements intersection: self collectionWithoutEqualElements). self assert: result size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (result includes: each) ]. ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testKeysAndValuesDo "| result | result:= OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| result add: (value+i)]. 1 to: result size do: [:i| self assert: (result at:i)=((self nonEmptyMoreThan1Element at:i)+i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element keysAndValuesDo: [:i :value| indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:10'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ duplicateElement ! ! !OrderedCollectionTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOf | collection | collection := self collectionWithoutEqualElements . collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! !OrderedCollectionTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 16:29'! emptyButAllocatedWith20 ^ emptyButAllocatedWith20! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0CopyTest self empty. self assert: self empty size = 0. self nonEmpty. self assert: (self nonEmpty size = 0) not. self collectionWithElementsToRemove. self assert: (self collectionWithElementsToRemove size = 0) not. self collectionWithElementsToRemove do: [ :each | self assert: (self nonEmpty includes: each) ]. self elementToAdd. self deny: (self nonEmpty includes: self elementToAdd). self collectionNotIncluded. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !OrderedCollectionTest methodsFor: 'tests - streaming' stamp: ''! testStreamContentsProtocol | result index | result:= self collectionClass << [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !OrderedCollectionTest methodsFor: 'tests - copying' stamp: 'stephane.ducasse 1/12/2009 15:02'! testCopyEmptyOld "Allows one to create a copy of the receiver that contains no elements" "self run:#testCopyEmpty" | c1 c2 | c1 := #(1 2 3 4 ) asOrderedCollection. c2 := c1 copyEmpty. self assert: (c2 size = 0).! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 14:16'! collectionWithNonIdentitySameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingEnd ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:44'! indexInNonEmpty " return an index between bounds of 'nonEmpty' " ^ 2! ! !OrderedCollectionTest methodsFor: 'test - remove' stamp: ''! testRemoveElementThatExistsTwice "self debug: #testRemoveElementThatDoesExistsTwice" | size | size := self nonEmpty size. self assert: (self nonEmpty includes: self elementTwiceIn). self nonEmpty remove: self elementTwiceIn. self assert: size - 1 = self nonEmpty size. self assert: (self nonEmpty includes: self elementTwiceIn). self nonEmpty remove: self elementTwiceIn. self assert: size - 2 = self nonEmpty size! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 12/18/2009 12:05'! result ^ collectResult ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 10:22'! collectionWithCopyNonIdentical " return a collection that include elements for which 'copy' return a different object (this is not the case of SmallInteger)" ^ collectionOfFloat! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithout "self debug: #testCopyEmptyWithout" | res | res := self empty copyWithout: self elementToAdd. self assert: res size = self empty size. self deny: (res includes: self elementToAdd)! ! !OrderedCollectionTest methodsFor: 'tests - as sorted collection' stamp: ''! testAsSortedCollection | aCollection result | aCollection := self collectionWithSortableElements . result := aCollection asSortedCollection. self assert: (result class includesBehavior: SortedCollection). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. self assert: result size = aCollection size.! ! !OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIdentityIndexOfDuplicate "self debug: #testIdentityIndexOf" | collection element | "testing fixture here as this method may not be used by some collections testClass" self collectionWithNonIdentitySameAtEndAndBegining. collection := self collectionWithNonIdentitySameAtEndAndBegining. self assert: collection first = collection last. self deny: collection first == collection last. 1 to: collection size do: [ :i | i > 1 & (i < collection size) ifTrue: [ self deny: (collection at: i) = collection first ] ]. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals but are not the same object" self assert: (collection identityIndexOf: element) = collection size! ! !OrderedCollectionTest methodsFor: 'test - creation' stamp: 'stephane.ducasse 12/9/2008 18:31'! collectionClass ^ OrderedCollection! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:57'! nonEmpty1Element " return a collection of size 1 including one element" ^ OrderedCollection new add:( self nonEmpty anyOne); yourself.! ! !OrderedCollectionTest methodsFor: 'tests - begins ends with' stamp: ''! testsBeginsWith self assert: (self nonEmpty beginsWith:(self nonEmpty copyUpTo: self nonEmpty last)). self assert: (self nonEmpty beginsWith:(self nonEmpty )). self deny: (self nonEmpty beginsWith:(self nonEmpty copyWith:self nonEmpty first)).! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''! testUnion "self debug: #testUnionOfEmpties" | union | union := self empty union: self nonEmpty. self containsAll: union of: self empty andOf: self nonEmpty. union := self nonEmpty union: self empty. self containsAll: union of: self empty andOf: self nonEmpty. union := self collection union: self nonEmpty. self containsAll: union of: self collection andOf: self nonEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - copying' stamp: 'sd 3/21/2006 22:41'! testCopyReplaceFromToWith "Allows one to create a copy from the receiver which elements between start and end of the receiver being replace by element of the collection after with:" "self run:#testCopyReplaceFromToWith" | c1 c2 c3 c4 | c1 := #(1 2 3 4) asOrderedCollection. c2 := #(5 6 7 8 9) asOrderedCollection. c3 := (c2 copyReplaceFrom: 1 to: 2 with: c1). self assert: c3 = #(1 2 3 4 7 8 9) asOrderedCollection. self should: [c2 copyReplaceFrom: 3 to: 1 with: c1] raise: Error. c4 := (c2 copyReplaceFrom: 10 to: 25 with: c1). self assert: c4 = #(5 6 7 8 9 1 2 3 4) asOrderedCollection. ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testDo! ! !OrderedCollectionTest methodsFor: 'tests - begins ends with' stamp: ''! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSequencedConcatenationTest self empty. self assert: self empty isEmpty. self firstCollection. self secondCollection! ! !OrderedCollectionTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElements "self debug: #testHasEqualElements" self deny: (self empty hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty asSet). self deny: (self nonEmpty reversed hasEqualElements: self nonEmpty). self deny: (self nonEmpty hasEqualElements: self nonEmpty reversed).! ! !OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'StephaneDucasse 3/22/2010 21:18'! testAddAfterIndex "self run: #testAddAfterIndex" | l | l := #(1 2 3 4) asOrderedCollection. l add: 77 afterIndex: 0. self assert: (l = #(77 1 2 3 4) asOrderedCollection). l add: 88 afterIndex: 2. self assert: (l = #(77 1 88 2 3 4) asOrderedCollection). l add: 99 afterIndex: l size. self assert: (l = #(77 1 88 2 3 4 99) asOrderedCollection). self should:[l add: 666 afterIndex: -1] raise: Error. self should:[l add: 666 afterIndex: l size+1] raise: Error. "Now make room by removing first two and last two elements, and see if the illegal bounds test still fails" (l first: 2) , (l last: 2) reversed do: [:e | l remove: e]. self should: [l add: 666 afterIndex: -1] raise: Error. self should: [l add: 666 afterIndex: l size+1] raise: Error.! ! !OrderedCollectionTest methodsFor: 'parameters' stamp: 'stephane.ducasse 10/5/2008 12:38'! selectorToAccessValuePutIn "return the selector of the method that should be invoked to access an element" ^ #first! ! !OrderedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''! testShuffled | result | result := self nonEmpty shuffled . "verify content of 'result: '" result do: [:each | self assert: (self nonEmpty occurrencesOf: each)=(result occurrencesOf: each)]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !OrderedCollectionTest methodsFor: 'tests - equality' stamp: ''! testHasEqualElementsIsTrueForNonIdenticalButEqualCollections "self debug: #testHasEqualElementsIsTrueForNonIdenticalButEqualCollections" self assert: (self empty hasEqualElements: self empty copy). self assert: (self empty copy hasEqualElements: self empty). self assert: (self empty copy hasEqualElements: self empty copy). self assert: (self nonEmpty hasEqualElements: self nonEmpty copy). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty). self assert: (self nonEmpty copy hasEqualElements: self nonEmpty copy).! ! !OrderedCollectionTest methodsFor: 'tests - as identity set' stamp: ''! testAsIdentitySetWithIdentityEqualsElements | result | result := self collectionWithIdentical asIdentitySet. " Only one element should have been removed as two elements are equals with Identity equality" self assert: result size = (self collectionWithIdentical size - 1). self collectionWithIdentical do: [ :each | (self collectionWithIdentical occurrencesOf: each) > 1 ifTrue: [ "the two elements equals only with classic equality shouldn't 'have been removed" self assert: (result asOrderedCollection occurrencesOf: each) = 1 " the other elements are still here" ] ifFalse: [ self assert: (result asOrderedCollection occurrencesOf: each) = 1 ] ]. self assert: result class = IdentitySet! ! !OrderedCollectionTest methodsFor: 'test - equality' stamp: ''! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0TSequencedStructuralEqualityTest self nonEmpty at: 1 "Ensures #nonEmpty is sequenceable"! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''! testCopySameClass "self debug: #testCopySameClass" "A copy of a collection should always be of the same class as the instance it copies" | copy | copy := self empty copy. self assert: copy class == self empty class.! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testAfter "self debug: #testAfter" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1)) = (self moreThan4Elements at: 2). self should: [ self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ] raise: Error. self should: [ self moreThan4Elements after: self elementNotInForElementAccessing ] raise: Error! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfter | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfter: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureAsSetForIdentityMultiplinessTest "a collection (of elements for which copy is not identical ) without equal elements:" | anElement res | self elementsCopyNonIdenticalWithoutEqualElements. anElement := self elementsCopyNonIdenticalWithoutEqualElements anyOne. self deny: anElement copy == anElement. res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:38'! oldSubCollection " return a subCollection included in collectionWith1TimeSubcollection . ex : subCollection := #( 2 3 4) and collectionWith1TimeSubcollection := #(1 2 3 4 5)" ^ nonEmpty ! ! !OrderedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButFirstNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i + 2) ]. self assert: abf size + 2 = col size! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePrintTest self nonEmpty! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'SebastianTleye 6/26/2013 11:23'! collectionOfCollectionsOfInts ^collectionOfCollectionsOfInts.! ! !OrderedCollectionTest methodsFor: 'tests - sorting' stamp: ''! testIsSortedBy self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | ab]). ! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 13:42'! testAddBeforeAndRemove | l initialCollection | l := #(1 2 3 4) asOrderedCollection. initialCollection := l shallowCopy. l add: 88 before: 1. self assert: (l = #(88 1 2 3 4) asOrderedCollection). l add: 99 before: 2. self assert: (l = #(88 1 99 2 3 4) asOrderedCollection). l remove: 99. l remove: 88. self assert: l = initialCollection. ! ! !OrderedCollectionTest methodsFor: 'tests - copying' stamp: 'sd 3/21/2006 22:41'! testCopyFromTo "Allows one to create a copy of the receiver that contains elements from position start to end" "self run: #testCopyFromTo" | c1 c2 c3 | c1 := #(1 2 3 4) asOrderedCollection. c2 := (c1 copyFrom: 1 to: 2). self assert: c2 = #(1 2) asOrderedCollection. self should: [c1 copyFrom: 10 to: 20] raise: Error. c3 := c1 copyFrom: 4 to: 2. self assert: c3 isEmpty. self should: [c1 copyFrom: 4 to: 5 ] raise: Error. ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseWithDo | firstCollection secondCollection index | firstCollection := self nonEmptyMoreThan1Element. secondCollection := firstCollection copy. index := firstCollection size. firstCollection reverseWith: secondCollection do: [:a :b | self assert: (firstCollection at: index) equals: a. self assert: (secondCollection at: index) equals: b. ( index := index - 1).] ! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''! testIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: ''! testFlatCollectAsSet self assert: (self simpleCollection flatCollectAsSet: [ :x | { x }, { x } ]) equals: self simpleCollection asSet! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:42'! elementNotInForElementAccessing " return an element not included in 'accessCollection' " ^ elementNotIn ! ! !OrderedCollectionTest methodsFor: 'tests - as set tests' stamp: ''! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !OrderedCollectionTest methodsFor: 'tests - printing' stamp: ''! testPrintOnDelimiterLast | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream delimiter: ', ' last: 'and'. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=('and')asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ].! ! !OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness' stamp: ''! testCopyAfterLastWithDuplicate | result element collection | collection := self collectionWithSameAtEndAndBegining . element := collection first. " collectionWithSameAtEndAndBegining first and last elements are equals. 'copyAfter:' should copy after the last occurence of element :" result := collection copyAfterLast: (element ). "verifying content: " self assert: result isEmpty. ! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWith "self debug: #testCopyWith" | res anElement | anElement := self elementToAdd. res := self empty copyWith: anElement. self assert: res size = (self empty size + 1). self assert: (res includes: (anElement value))! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:35'! indexInForCollectionWithoutDuplicates " return an index between 'collectionWithoutEqualsElements' bounds" ^ 2! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! howMany: aSubCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp := collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: aSubCollection) ifTrue: [ nTime := nTime + 1. 1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !OrderedCollectionTest methodsFor: 'tests - removing' stamp: 'sd 3/21/2006 22:39'! testRemoveAt "Allows one to remove an element from a collection at an index" "self run:#testRemoveAt" | c1 | c1 := #(2 3 4 6) asOrderedCollection. c1 removeAt: 2. self assert: (c1 = #(2 4 6) asOrderedCollection). self should: [c1 removeAt: 10] raise: Error. self should: [c1 removeAt: -1] raise: Error. ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 10:21'! collectionWith5Elements " return a collection of size 5 including 5 elements" ^ indexCollection ! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureConverAsSortedTest self collectionWithSortableElements. self deny: self collectionWithSortableElements isEmpty! ! !OrderedCollectionTest methodsFor: 'tests - printing' stamp: ''! testStoreOn " for the moment work only for collection that include simple elements such that Integer" "| string str result cuttedResult index elementsAsStringExpected elementsAsStringObtained tmp | string := ''. str := ReadWriteStream on: string. elementsAsStringExpected := OrderedCollection new. elementsAsStringObtained := OrderedCollection new. self nonEmpty do: [ :each | elementsAsStringExpected add: each asString]. self nonEmpty storeOn: str. result := str contents . cuttedResult := ( result findBetweenSubStrs: ';' ). index := 1. cuttedResult do: [ :each | index = 1 ifTrue: [ self assert: (each beginsWith: ( tmp := '((' , self nonEmpty class asString , ' new) add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1. ] ifFalse: [ index < cuttedResult size ifTrue:[self assert: (each beginsWith: ( tmp:= ' add: ' )). tmp := each copyFrom: ( tmp size + 1) to: ( each size ). elementsAsStringObtained add: tmp. index := index + 1.] ifFalse: [self assert: ( each = ' yourself)' ) ]. ] ]. elementsAsStringExpected do: [ :each | self assert: (elementsAsStringExpected occurrencesOf: each ) = ( elementsAsStringObtained occurrencesOf: each) ]" ! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''! testIndexOfStartingAtIfAbsent "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection indexOf: element startingAt: 2 ifAbsent: [ 99 ]) = 99. self assert: (collection indexOf: element startingAt: 1 ifAbsent: [ 99 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing startingAt: 1 ifAbsent: [ 99 ]) = 99! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'SebastianTleye 6/26/2013 12:43'! collectionOfCollectionsOfStrings ^collectionOfCollectionsOfStrings.! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:37'! integerCollection " return a collection only including SmallInteger elements" ^ indexCollection ! ! !OrderedCollectionTest methodsFor: 'tests - replacing' stamp: ''! testReplaceAllWith | result collection oldElement newElement oldOccurrences | collection := self nonEmpty . result := collection copy. oldElement := self elementInForReplacement . newElement := self newElement . oldOccurrences := (result occurrencesOf: oldElement) + (result occurrencesOf: newElement). result replaceAll: oldElement with: newElement . self assert: oldOccurrences = (result occurrencesOf: newElement)! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !OrderedCollectionTest methodsFor: 'tests - occurrencesOf for multipliness' stamp: ''! testOccurrencesOfForMultipliness | collection elem | collection := self collectionWithEqualElements . elem := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: elem ) = 2. ! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testAtAll "self debug: #testAtAll" " self flag: #theCollectionshouldbe102030intheFixture. self assert: (self accessCollection atAll: #(2 1)) first = self accessCollection second. self assert: (self accessCollection atAll: #(2)) first = self accessCollection second." | result | result := self moreThan4Elements atAll: #(2 1 2 ). self assert: (result at: 1) = (self moreThan4Elements at: 2). self assert: (result at: 2) = (self moreThan4Elements at: 1). self assert: (result at: 3) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements atAll: #()) = self moreThan4Elements species new! ! !OrderedCollectionTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementReallyRemovesElement "self debug: #testRemoveElementReallyRemovesElement" | size | size := self nonEmptyWithoutEqualElements size. self nonEmptyWithoutEqualElements remove: self nonEmptyWithoutEqualElements anyOne. self assert: size - 1 = self nonEmptyWithoutEqualElements size! ! !OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''! assertNonDuplicatedContents: aCollection whenConvertedTo: aClass | result | result := aCollection perform: ('as' , aClass name) asSymbol. self assert: (result class includesBehavior: aClass). result do: [ :each | self assert: (aCollection occurrencesOf: each) = (result occurrencesOf: each) ]. ^ result! ! !OrderedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''! testShallowCopy | result | result := self nonEmpty shallowCopy . "verify content of 'result: '" 1 to: self nonEmpty size do: [:i | self assert: ((result at:i)=(self nonEmpty at:i))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''! testIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | collection | collection := self collectionMoreThan1NoDuplicates. self assert: (collection indexOf: collection first ifAbsent: [ 33 ]) = 1. self assert: (collection indexOf: self elementNotInForIndexAccessing ifAbsent: [ 33 ]) = 33! ! !OrderedCollectionTest methodsFor: 'tests - streaming' stamp: ''! testStreamContentsSized | result | result:= self collectionClass new: 1 streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection. result:= self collectionClass new: 1000 streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyPartOfSequenceableTest self collectionWithoutEqualElements. self collectionWithoutEqualElements do: [ :each | self assert: (self collectionWithoutEqualElements occurrencesOf: each) = 1 ]. self indexInForCollectionWithoutDuplicates. self assert: (self indexInForCollectionWithoutDuplicates > 0 & self indexInForCollectionWithoutDuplicates) < self collectionWithoutEqualElements size. self empty. self assert: self empty isEmpty! ! !OrderedCollectionTest methodsFor: 'test - creation' stamp: ''! testWithWithWith "self debug: #testWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom:1 to: 3 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''! testAsByteArray | res | self integerCollectionWithoutEqualElements. self integerCollectionWithoutEqualElements do: [ :each | self assert: each class = SmallInteger ]. res := true. self integerCollectionWithoutEqualElements detect: [ :each | (self integerCollectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. self assertSameContents: self integerCollectionWithoutEqualElements whenConvertedTo: ByteArray! ! !OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyWithOrWithoutSpecificElementsTest self nonEmpty. self deny: self nonEmpty isEmpty. self indexInNonEmpty. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:32'! elementNotInForIndexAccessing ^ elementNotIn ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:12'! firstCollection " return a collection that will be the first part of the concatenation" ^ nonEmpty ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:00'! collectionInForIncluding ^ self nonEmpty copyWithoutFirst.! ! !OrderedCollectionTest methodsFor: 'parameters' stamp: ''! accessValuePutIn "return access the element put in the non-empty collection" ^ self perform: self selectorToAccessValuePutIn! ! !OrderedCollectionTest methodsFor: 'parameters' stamp: ''! valuePutIn "the value that we will put in the non empty collection" ^ #x! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: ''! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !OrderedCollectionTest methodsFor: 'tests - sorting' stamp: ''! testSortUsingSortBlock | result tmp | result := self unsortedCollection sort: [:a :b | a>b]. tmp := result at: 1. result do: [:each | self assert: each<=tmp. tmp:= each. ].! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithSeparateCollection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithSeparateCollection" | res separateCol | separateCol := self collectionClass with: self anotherElementOrAssociationNotIn. res := self collectionWithoutEqualElements difference: separateCol. self deny: (res includes: self anotherElementOrAssociationNotIn). self assert: res size equals: self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each| self assert: (res includes: each)]. res := separateCol difference: self collection. self deny: (res includes: self collection anyOne). self assert: res equals: separateCol! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureEmptySequenceableTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'sd 3/21/2006 22:36'! testAddAllFirst "Allows one to add each element of an orderedCollection at the beginning of another orderedCollection " "self run:#testAddAllFirst" | c1 c2 | c1 := #(1 2 3 4 ) asOrderedCollection. c2 := #(5 6 7 8 9 ) asOrderedCollection. c2 addAllFirst: c1. self assert: c2 = #(1 2 3 4 5 6 7 8 9) asOrderedCollection! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'sd 1/28/2009 16:29'! collectionWithElement "Returns a collection that already includes what is returned by #element." ^ collectionWithElement! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''! testIndexOfSubCollectionStartingAtIfAbsent "self debug: #testIndexOfIfAbsent" | index absent subcollection collection | collection := self collectionMoreThan1NoDuplicates. subcollection := self collectionMoreThan1NoDuplicates. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 1 ifAbsent: [ absent := true ]. self assert: absent = false. absent := false. index := collection indexOfSubCollection: subcollection startingAt: 2 ifAbsent: [ absent := true ]. self assert: absent = true! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:11'! withEqualElements " return a collection of float including equal elements (classic equality)" ^ collectionOfFloat , collectionOfFloat! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpToLast: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1).! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCloneTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''! testTAddIfNotPresentWithElementAlreadyIn | added oldSize collection anElement | collection := self collectionWithElement . oldSize := collection size. anElement := self element . self assert: (collection includes: anElement ). added := collection addIfNotPresent: anElement . self assert: added == anElement . "test for identiy because #add: has not reason to copy its parameter." self assert: collection size = oldSize! ! !OrderedCollectionTest methodsFor: 'tests - printing' stamp: ''! testPrintOn | aStream result allElementsAsString | result:=''. aStream:= ReadWriteStream on: result. self nonEmpty printOn: aStream . allElementsAsString:=(result findBetweenSubStrs: ' ' ). 1 to: allElementsAsString size do: [:i | i=1 ifTrue:[ self accessCollection class name first isVowel ifTrue:[self assert: (allElementsAsString at:i)='an' ] ifFalse:[self assert: (allElementsAsString at:i)='a'].]. i=2 ifTrue:[self assert: (allElementsAsString at:i)=self accessCollection class name]. i>2 ifTrue:[self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString).]. ].! ! !OrderedCollectionTest methodsFor: 'tests - at put' stamp: ''! testAtPutTwoValues "self debug: #testAtPutTwoValues" self nonEmpty at: self anIndex put: self aValue. self nonEmpty at: self anIndex put: self anotherValue. self assert: (self nonEmpty at: self anIndex) = self anotherValue.! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpTo | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyUpTo: (collection at:index). "verify content of 'result' :" 1 to: result size do: [:i| self assert: (collection at:i)=(result at:i)]. "verify size of 'result' :" self assert: result size = (index-1). ! ! !OrderedCollectionTest methodsFor: 'tests - remove' stamp: ''! testRemoveElementFromEmpty "self debug: #testRemoveElementFromEmpty" self should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] raise: Error! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:22'! collectionWithElementsToRemove ^ nonEmpty copyWithoutFirst.! ! !OrderedCollectionTest methodsFor: 'tests - copying' stamp: 'zz 12/7/2005 13:47'! testReversed | collection1 collection2 | collection1 := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. collection2 := collection1 reversed. self assert: collection2 first = 'Andrew'. self assert: collection2 last = 'Jim'! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterLastMore | delim multiItemStream result last allElementsAsString | delim := ', '. last := 'and'. result:=''. multiItemStream := ReadWriteStream on:result. self nonEmpty asStringOn: multiItemStream delimiter: ', ' last: last. allElementsAsString:=(result findBetweenSubStrs: ', ' ). 1 to: allElementsAsString size do: [:i | i<(allElementsAsString size-1 ) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:i)asString)]. i=(allElementsAsString size-1) ifTrue:[ self deny: (allElementsAsString at:i)=(last)asString]. i=(allElementsAsString size) ifTrue: [self assert: (allElementsAsString at:i)=((self nonEmpty at:(i-1))asString)]. ]. ! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testLast "self debug: #testLast" self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! !OrderedCollectionTest methodsFor: 'test - iterate' stamp: 'luc.fabresse 11/29/2008 23:09'! expectedSizeAfterReject ^1! ! !OrderedCollectionTest methodsFor: 'test - remove' stamp: 'damienpollet 1/30/2009 17:16'! elementTwiceIn ^ super elementTwiceIn! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''! testTAdd | added collection | collection :=self otherCollection . added := collection add: self element. self assert: added == self element. "test for identiy because #add: has not reason to copy its parameter." self assert: (collection includes: self element) . self assert: (self collectionWithElement includes: self element). ! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIncludeTest | anElementIn | self nonEmpty. self deny: self nonEmpty isEmpty. self elementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self anotherElementNotIn. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self empty. self assert: self empty isEmpty! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'CamilloBruni 8/31/2013 20:23'! testIdentityIncludes " test the comportement in presence of elements 'includes' but not 'identityIncludes' " " can not be used by collections that can't include elements for wich copy doesn't return another instance " | collection element | self collectionWithCopyNonIdentical. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureIndexAccessFotMultipliness self collectionWithSameAtEndAndBegining. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [ :i | i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! testIncludesElementIsNotThere "self debug: #testIncludesElementIsNotThere" self deny: (self nonEmpty includes: self elementNotInForOccurrences). self assert: (self nonEmpty includes: self nonEmpty anyOne). self deny: (self empty includes: self elementNotInForOccurrences)! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 12/18/2009 13:09'! replacementCollection " return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' " ^ collectionWith4Elements! ! !OrderedCollectionTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithoutIndex | result index | index := self indexInNonEmpty . result := self nonEmpty copyWithoutIndex: index . "verify content of 'result:'" 1 to: result size do: [:i | i<( index ) ifTrue: [self assert: ((result at:i )= (self nonEmpty at:i))]. i>=( index ) ifTrue: [self assert: (result at:i )= (self nonEmpty at:(i+1))]]. "verify size of result : " self assert: result size=(self nonEmpty size -1).! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 11:14'! collectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals . (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingEnd ! ! !OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testLastIndexOfStartingAtDuplicate "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf:ifAbsent:startingAt: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 55 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 55 ]) = 1! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:01'! integerCollectionWithoutEqualElements " return a collection of integer without equal elements" ^ withoutEqualElements ! ! !OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtWrapPut "self debug: #testAtWrapPut" | index | index := self indexArray anyOne. self nonEmpty atWrap: 0 put: self aValue. self assert: (self nonEmpty at:(self nonEmpty size))=self aValue. self nonEmpty atWrap: (self nonEmpty size+1) put: self aValue. self assert: (self nonEmpty at:(1))=self aValue. self nonEmpty atWrap: (index ) put: self aValue. self assert: (self nonEmpty at: index ) = self aValue. self nonEmpty atWrap: (self nonEmpty size+index ) put: self aValue . self assert: (self nonEmpty at:(index ))=self aValue .! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseDo | result | result:= OrderedCollection new. self nonEmpty reverseDo: [: each | result add: each]. 1 to: result size do: [:i| self assert: (result at: i)=(self nonEmpty at:(self nonEmpty size-i+1))].! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 13:43'! testAddDuplicateItem1 | collection | collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. collection add: 'John' before: 'John'. self assert: ((collection asBag occurrencesOf: 'John') = 2 and: [(collection at: (collection indexOf: 'John') + 1) = (collection at: (collection indexOf: 'John'))])! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''! testCopyEquals "self debug: #testCopySameClass" "A copy should be equivalent to the things it's a copy of" | copy | copy := self nonEmpty copy. self assert: copy = self nonEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIndexOfDuplicate "self debug: #testIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf: should return the position of the first occurrence :'" self assert: (collection indexOf: element) = 1! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''! testCopyEmptyWithoutAll "self debug: #testCopyEmptyWithoutAll" | res | res := self empty copyWithoutAll: self collectionWithElementsToRemove. self assert: res size = self empty size. self collectionWithElementsToRemove do: [ :each | self deny: (res includes: each) ]! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: ''! testTAddIfNotPresentWithNewElement | added oldSize collection elem | collection := self otherCollection . oldSize := collection size. elem := self element . self deny: (collection includes: elem ). added := collection addIfNotPresent: elem . self assert: added == elem . "test for identiy because #add: has not reason to copy its parameter." self assert: (collection size = (oldSize + 1)). ! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testAtPin "self debug: #testAtPin" self assert: (self moreThan4Elements atPin: 2) = self moreThan4Elements second. self assert: (self moreThan4Elements atPin: 99) = self moreThan4Elements last. self assert: (self moreThan4Elements atPin: -99) = self moreThan4Elements first! ! !OrderedCollectionTest methodsFor: 'tests - sequence isempty' stamp: ''! testSequenceIfNotEmpty self assert: (self nonEmpty ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: ''! testCopyNonEmptyWithoutAll "self debug: #testCopyNonEmptyWithoutAll" | res | res := self nonEmpty copyWithoutAll: self collectionWithElementsToRemove. "here we do not test the size since for a non empty set we would get a problem. Then in addition copy is not about duplicate management. The element should be in at the end." self collectionWithElementsToRemove do: [ :each | self deny: (res includes: (each)) ]. self nonEmpty do: [ :each | (self collectionWithElementsToRemove includes: each) ifFalse: [ self assert: (res includes: each) ] ]! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:46'! elementsCopyNonIdenticalWithoutEqualElements " return a collection that does niot incllude equal elements ( classic equality )" ^ collectionOfFloat! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyAfterLast | result index collection | collection := self collectionWithoutEqualElements . index:= self indexInForCollectionWithoutDuplicates . result := collection copyAfterLast: (collection at:index ). "verifying content: " (1) to: result size do: [:i | self assert: (collection at:(i + index ))=(result at: (i))]. "verify size: " self assert: result size = (collection size - index).! ! !OrderedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButLastNElements "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButLast: 2. 1 to: abf size do: [ :i | self assert: (abf at: i) = (col at: i) ]. self assert: abf size + 2 = col size! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testAtLastIfAbsent "self debug: #testAtLastIfAbsent" self assert: (self moreThan4Elements atLast: 1 ifAbsent: [ nil ]) = self moreThan4Elements last. self assert: (self moreThan4Elements atLast: self moreThan4Elements size + 1 ifAbsent: [ 222 ]) = 222! ! !OrderedCollectionTest methodsFor: 'tests - copying' stamp: 'sd 3/21/2006 22:41'! testCopyWith "Allows one to create a copy of the receiver that contains the new element at the end" "self run: #testCopyWith" | c1 | c1 := #(1 2 3 4) asOrderedCollection. c1 := c1 copyWith: 6. self assert: c1 = #(1 2 3 4 6) asOrderedCollection. ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testAfterIfAbsent "self debug: #testAfterIfAbsent" self assert: (self moreThan4Elements after: (self moreThan4Elements at: 1) ifAbsent: [ 33 ]) = (self moreThan4Elements at: 2). self assert: (self moreThan4Elements after: (self moreThan4Elements at: self moreThan4Elements size) ifAbsent: [ 33 ]) = 33. self assert: (self moreThan4Elements after: self elementNotInForElementAccessing ifAbsent: [ 33 ]) = 33! ! !OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''! assertNoDuplicates: aCollection whenConvertedTo: aClass | result | result := self collectionWithEqualElements asIdentitySet. self assert: (result class includesBehavior: IdentitySet). self collectionWithEqualElements do: [ :initial | self assert: (result occurrencesOf: initial) = 1 ]! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureOccurrencesForMultiplinessTest | cpt anElement collection | self collectionWithEqualElements. self collectionWithEqualElements. self elementTwiceInForOccurrences. anElement := self elementTwiceInForOccurrences. collection := self collectionWithEqualElements. cpt := 0. " testing with identity check ( == ) so that identy collections can use this trait : " self collectionWithEqualElements do: [ :each | each == self elementTwiceInForOccurrences ifTrue: [ cpt := cpt + 1 ] ]. self assert: cpt = 2! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !OrderedCollectionTest methodsFor: 'test - equality' stamp: ''! testEqualSignIsTrueForEmptyButNonIdenticalCollections "self debug: #testEqualSignIsTrueForNonIdenticalButEqualCollections" self assert: (self empty = self empty copy). self assert: (self empty copy = self empty). self assert: (self empty copy = self empty copy). ! ! !OrderedCollectionTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 12:10'! nonEmpty ^ nonEmpty! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindLast | element result | element := self nonEmptyMoreThan1Element at:self nonEmptyMoreThan1Element size. result:=self nonEmptyMoreThan1Element findLast: [:each | each =element]. self assert: result=self nonEmptyMoreThan1Element size. ! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCreationWithTest self collectionMoreThan5Elements. self assert: self collectionMoreThan5Elements size >= 5! ! !OrderedCollectionTest methodsFor: 'tests - accessing' stamp: 'sd 3/21/2006 22:38'! testAtPut "Allows one to replace an element but not at an off range index" "self run:#testAtPut" | c | c := #(1 2 3 4 ) asOrderedCollection. c at: 2 put: 5. self assert: c = #(1 5 3 4 ) asOrderedCollection. self should: [c at: 5 put: 8] raise: Error. self deny: c = #(1 5 3 4 8 ) asOrderedCollection! ! !OrderedCollectionTest methodsFor: 'tests - copy - clone' stamp: ''! testCopyNonEmpty "self debug: #testCopyNonEmpty" | copy | copy := self nonEmpty copy. self deny: copy isEmpty. self assert: copy size = self nonEmpty size. self nonEmpty do: [:each | copy includes: each]! ! !OrderedCollectionTest methodsFor: 'tests - remove' stamp: ''! testRemoveAllFoundIn "self debug: #testRemoveElementThatExists" | el aSubCollection res | el := self nonEmptyWithoutEqualElements anyOne. aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. res := self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureRequirementsOfTAddTest self collectionWithElement. self otherCollection. self element. self assert: (self collectionWithElement includes: self element). self deny: (self otherCollection includes: self element)! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !OrderedCollectionTest methodsFor: 'test - creation' stamp: ''! testWithWith "self debug: #testWithWith" | aCol collection element1 element2 | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 2 . element1 := collection at: 1. element2 := collection at:2. aCol := self collectionClass with: element1 with: element2 . self assert: (aCol occurrencesOf: element1 ) = ( collection occurrencesOf: element1). self assert: (aCol occurrencesOf: element2 ) = ( collection occurrencesOf: element2). ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: ''! collectionWithIdentical "return a collection of type : 'self collectionWIithoutEqualsElements class containing two elements equals ( with identity equality)" | result collection anElement | collection := OrderedCollection withAll: self elementsCopyNonIdenticalWithoutEqualElements. anElement := collection first. collection add: anElement. result := self elementsCopyNonIdenticalWithoutEqualElements class withAll: collection. ^ result! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testFirstSecondThird "self debug: #testFirstSecondThird" self assert: self moreThan4Elements first = (self moreThan4Elements at: 1). self assert: self moreThan4Elements second = (self moreThan4Elements at: 2). self assert: self moreThan4Elements third = (self moreThan4Elements at: 3). self assert: self moreThan4Elements fourth = (self moreThan4Elements at: 4)! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureTRemoveTest | duplicate | self empty. self nonEmptyWithoutEqualElements. self deny: self nonEmptyWithoutEqualElements isEmpty. duplicate := true. self nonEmptyWithoutEqualElements detect: [ :each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ duplicate := false ]. self assert: duplicate = false. self elementNotIn. self assert: self empty isEmpty. self deny: self nonEmptyWithoutEqualElements isEmpty. self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! !OrderedCollectionTest methodsFor: 'setup' stamp: 'cyrille.delaunay 12/18/2009 13:09'! sizeCollection ^ collectionWith4Elements! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'SebastianTleye 6/26/2013 12:45'! collectionWithCharacters ^withCharacters.! ! !OrderedCollectionTest methodsFor: 'tests - copying with or without' stamp: ''! testCopyWithFirst | index element result | index:= self indexInNonEmpty . element:= self nonEmpty at: index. result := self nonEmpty copyWithFirst: element. self assert: result size = (self nonEmpty size + 1). self assert: result first = element . 2 to: result size do: [ :i | self assert: (result at: i) = ( self nonEmpty at: ( i - 1 ))].! ! !OrderedCollectionTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! aValue ^ 33! ! !OrderedCollectionTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 12:10'! empty ^ empty! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testAtLast "self debug: #testAtLast" | index | self assert: (self moreThan4Elements atLast: 1) = self moreThan4Elements last. "tmp:=1. self do: [:each | each =self elementInForIndexAccessing ifTrue:[index:=tmp]. tmp:=tmp+1]." index := self moreThan4Elements indexOf: self elementInForElementAccessing. self assert: (self moreThan4Elements atLast: index) = (self moreThan4Elements at: self moreThan4Elements size - index + 1)! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:49'! indexArray ^ indexArray .! ! !OrderedCollectionTest methodsFor: 'setup' stamp: 'cyrille.delaunay 12/18/2009 13:03'! collection ^ collectionWith4Elements! ! !OrderedCollectionTest methodsFor: 'tests - puting with indexes' stamp: ''! testAtLastPut | result index | index := self indexArray anyOne. result := self nonEmpty atLast: index put: self aValue. self assert: (self nonEmpty at: (self nonEmpty size +1 - index)) = self aValue .! ! !OrderedCollectionTest methodsFor: 'tests' stamp: 'StephaneDucasse 12/23/2009 21:41'! testSort "self run: #testSort" | ord | ord := OrderedCollection new addAll: #(2 1 3 6 7 10 6); yourself. self assert: ord sort asArray = #(1 2 3 6 6 7 10). self assert: ord sort = (OrderedCollection new addAll:#(1 2 3 6 6 7 10); yourself). self assert: (ord sort: [:a :b | a > b]) asArray = #(10 7 6 6 3 2 1). ord := OrderedCollection new. self assert: ord sort asArray = #(). ! ! !OrderedCollectionTest methodsFor: 'tests - enumerating' stamp: 'sd 6/5/2005 09:21'! testIndexOfWithDuplicates | collection indices bagOfIndices | collection := #('Jim' 'Mary' 'John' 'Andrew' 'Mary' 'John' 'Jim' 'Micheal') asOrderedCollection. indices := collection collect: [:item | collection indexOf: item]. self assert: indices asSet size = collection asSet size. bagOfIndices := indices asBag. self assert: (indices asSet allSatisfy: [:index | (bagOfIndices occurrencesOf: index) = (collection occurrencesOf: (collection at: index))]). " indexOf: returns the index of the first occurrence of an item. For an item with n occurrences, the index of its first occurrence is found n times. "! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionEmpty "self debug: #testIntersectionEmpty" | inter | inter := self empty intersection: self empty. self assert: inter isEmpty. inter := self empty intersection: self collection . self assert: inter = self empty. ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:04'! anotherElementOrAssociationIn " return an element (or an association for Dictionary ) present in 'collection' " ^ self collection anyOne! ! !OrderedCollectionTest methodsFor: 'tests begin ' stamp: 'StephaneDucasse 3/28/2010 21:07'! testEndsWithAnyOf "We can't test SequenceableCollection directly. However, we can test a sampling of its descendants." "self debug: #testEndsWithAnyOf" | la oc | la := #(6 5 4 3 2 1). oc := OrderedCollection new. oc add: 3; add: 2; add: 1. self assert: (la endsWithAnyOf: #((17) (1) (42))). self assert: (la endsWithAnyOf: #((17) (2 1) (42))). self assert: (la endsWithAnyOf: #((17) (3 2 1) (42))). self deny: (la endsWithAnyOf: #()). self deny: (la endsWithAnyOf: #(())). self deny: (la endsWithAnyOf: #((42))).! ! !OrderedCollectionTest methodsFor: 'tests - sorting' stamp: ''! testIsSorted self assert: self sortedInAscendingOrderCollection isSorted. self deny: self unsortedCollection isSorted! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !OrderedCollectionTest methodsFor: 'tests - converting' stamp: ''! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIdentityIndexOfIAbsentDuplicate "self debug: #testIdentityIndexOfIfAbsent" | collection element elementCopy | collection := self collectionWithNonIdentitySameAtEndAndBegining . element := collection last. elementCopy := element copy. self deny: element == elementCopy . self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = collection size. self assert: (collection identityIndexOf: elementCopy ifAbsent: [ 55 ]) = 55! ! !OrderedCollectionTest methodsFor: 'tests - equality' stamp: ''! testEqualSignForSequenceableCollections "self debug: #testEqualSign" self deny: (self nonEmpty = self nonEmpty asSet). self deny: (self nonEmpty reversed = self nonEmpty). self deny: (self nonEmpty = self nonEmpty reversed).! ! !OrderedCollectionTest methodsFor: 'tests - streaming' stamp: ''! testStreamContents | result index | result:= self collectionClass streamContents: [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !OrderedCollectionTest methodsFor: 'tests - occurrencesOf' stamp: ''! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureBeginsEndsWithTest self nonEmpty. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size > 1. self empty. self assert: self empty isEmpty! ! !OrderedCollectionTest methodsFor: 'tests begin ' stamp: 'StephaneDucasse 3/28/2010 21:07'! testBeginsWithAnyOf "We can't test SequenceableCollection directly. However, we can test a sampling of its descendants." "self debug: #testBeginsWithAnyOf" | la oc | la := #(1 2 3 4 5 6). oc := OrderedCollection new. oc add: 1; add: 2; add: 3. self assert: (la beginsWithAnyOf: #((17) (1) (42))). self assert: (la beginsWithAnyOf: #((17) (1 2) (42))). self assert: (la beginsWithAnyOf: #((17) (1 2 3) (42))). self deny: (la beginsWithAnyOf: #()). self deny: (la beginsWithAnyOf: #(())). self deny: (la beginsWithAnyOf: #((42))).! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifferenceWithNonNullIntersection "Answer the set theoretic difference of two collections." "self debug: #testDifferenceWithNonNullIntersection" " #(1 2 3) difference: #(2 4) -> #(1 3)" | res overlapping | overlapping := self collectionClass with: self anotherElementOrAssociationNotIn with: self anotherElementOrAssociationIn. res := self collection difference: overlapping. self deny: (res includes: self anotherElementOrAssociationIn). overlapping do: [ :each | self deny: (res includes: each) ]! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testAtIfAbsent "self debug: #testAt" | absent | absent := false. self moreThan4Elements at: self moreThan4Elements size + 1 ifAbsent: [ absent := true ]. self assert: absent = true. absent := false. self moreThan4Elements at: self moreThan4Elements size ifAbsent: [ absent := true ]. self assert: absent = false! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:26'! collectionNotIncluded ^ OrderedCollection new add: elementNotIn ; add: elementNotIn ; yourself.! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ 666! ! !OrderedCollectionTest methodsFor: 'test - equality' stamp: ''! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''! testIndexOf "self debug: #testIndexOf" | tmp index collection | collection := self collectionMoreThan1NoDuplicates. tmp := collection size. collection reverseDo: [ :each | each = self elementInForIndexAccessing ifTrue: [ index := tmp ]. tmp := tmp - 1 ]. self assert: (collection indexOf: self elementInForIndexAccessing) = index! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSubcollectionAccessTest self moreThan3Elements. self assert: self moreThan3Elements size > 2! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 12:04'! anotherElementOrAssociationNotIn " return an element (or an association for Dictionary )not present in 'collection' " ^ elementNotIn ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:27'! elementInForIndexAccessing ^ self accessCollection anyOne.! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureSequencedElementAccessTest self moreThan4Elements. self assert: self moreThan4Elements size >= 4. self subCollectionNotIn. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self elementNotInForElementAccessing. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self elementInForElementAccessing. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testLastIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" "self debug: #testLastIndexOf" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection first. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'lastIndexOf: should return the position of the last occurrence :'" self assert: (collection lastIndexOf: element ifAbsent: [ 55 ]) = collection size! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''! testIntersectionBasic "self debug: #testIntersectionBasic" | inter | inter := self collection intersection: (self collectionClass with: self anotherElementOrAssociationIn). self deny: inter isEmpty. self assert: (inter includes: self anotherElementOrAssociationIn value)! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''! testDifference "Answer the set theoretic difference of two collections." "self debug: #testDifference" | difference | self assert: (self collectionWithoutEqualElements difference: self collectionWithoutEqualElements) isEmpty. self assert: (self empty difference: self collectionWithoutEqualElements) isEmpty. difference := (self collectionWithoutEqualElements difference: self empty). self assert: difference size = self collectionWithoutEqualElements size. self collectionWithoutEqualElements do: [ :each | self assert: (difference includes: each)]. ! ! !OrderedCollectionTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:19'! anotherValue ^ 66! ! !OrderedCollectionTest methodsFor: 'tests - subcollections access' stamp: ''! testAllButFirst "self debug: #testAllButFirst" | abf col | col := self moreThan3Elements. abf := col allButFirst. self deny: abf first = col first. self assert: abf size + 1 = col size! ! !OrderedCollectionTest methodsFor: 'tests - as set tests' stamp: ''! testAsIdentitySetWithEqualsElements | result collection | collection := self withEqualElements . result := collection asIdentitySet. collection do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = IdentitySet.! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'sd 3/21/2006 22:36'! testAddAll "Allows one to add each element of an orderedCollection at the end of another orderedCollection " "self run:#testAddAll" | c1 c2 | c1 := #(1 2 3 4 ) asOrderedCollection. c2 := #(5 6 7 8 9 ) asOrderedCollection. c1 addAll: c2. self assert: c1 = #(1 2 3 4 5 6 7 8 9) asOrderedCollection! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'DamienCassou 8/26/2013 15:59'! element "Returns an object that can be added to the collection returned by #collection." ^ 5! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/8/2008 16:04'! otherCollection ^ otherCollection! ! !OrderedCollectionTest methodsFor: 'tests - removing' stamp: 'zz 12/7/2005 19:05'! testRemoveAllSuchThat | collection | collection := (1 to: 10) asOrderedCollection. collection removeAllSuchThat: [:e | e even]. self assert: collection = (1 to: 10 by: 2) asOrderedCollection! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testAllButLastDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element allButLastDo: [:each | result add: each]. 1 to: (result size) do: [:i| self assert: (self nonEmptyMoreThan1Element at:(i ))=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'zz 12/7/2005 18:52'! testAddAfter | l | l := #(1 2 3 4) asOrderedCollection. l add: 88 after: 1. self assert: (l = #(1 88 2 3 4) asOrderedCollection). l add: 99 after: 2. self assert: (l = #(1 88 2 99 3 4) asOrderedCollection). ! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopyPartOfForMultipliness self collectionWithSameAtEndAndBegining. self assert: self collectionWithSameAtEndAndBegining first = self collectionWithSameAtEndAndBegining last. self assert: self collectionWithSameAtEndAndBegining size > 1. 1 to: self collectionWithSameAtEndAndBegining size do: [ :i | i > 1 & (i < self collectionWithSameAtEndAndBegining size) ifTrue: [ self deny: (self collectionWithSameAtEndAndBegining at: i) = self collectionWithSameAtEndAndBegining first ] ]! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:29'! nonEmptyWithoutEqualElements " return a collection without equal elements " ^ withoutEqualElements ! ! !OrderedCollectionTest methodsFor: 'tests - removing' stamp: 'sd 3/21/2006 22:39'! testRemoveLast "Allows one to remove n element of a collection at the end" "self run:#testRemoveLast" | c1 | c1 := #(2 3 4 6) asOrderedCollection. c1 removeLast: 1. self assert: (c1 = #(2 3 4) asOrderedCollection). c1 removeLast: 2. self assert: (c1 = #(2) asOrderedCollection). self should: [c1 removeLast: 10] raise: Error.! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testPairsCollect | index result | index:=0. result:=self nonEmptyMoreThan1Element pairsCollect: [:each1 :each2 | self assert: ( self nonEmptyMoreThan1Element indexOf: each2 ) = (index := index + 2). (self nonEmptyMoreThan1Element indexOf: each2) = ((self nonEmptyMoreThan1Element indexOf: each1) + 1). ]. result do: [:each | self assert: each = true]. ! ! !OrderedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !OrderedCollectionTest methodsFor: 'parameters' stamp: ''! accessValuePutInOn: s "return access the element put in the non-empty collection" ^ s perform: self selectorToAccessValuePutIn! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:02'! subCollectionNotIn ^ self collectionNotIncluded .! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithIndexDo "| result | result:=Array new: self nonEmptyMoreThan1Element size. self nonEmptyMoreThan1Element withIndexDo: [:each :i | result at:i put:(each+i)]. 1 to: result size do:[: i | self assert: (result at:i)= ((self nonEmptyMoreThan1Element at: i) + i)]" | indexes elements | indexes:= OrderedCollection new. elements := OrderedCollection new. self nonEmptyMoreThan1Element withIndexDo: [:value :i | indexes add: (i). elements add: value]. (1 to: self nonEmptyMoreThan1Element size )do: [ :i | self assert: (indexes at: i) = i. self assert: (elements at: i) = (self nonEmptyMoreThan1Element at: i). ]. self assert: indexes size = elements size. self assert: indexes size = self nonEmptyMoreThan1Element size . ! ! !OrderedCollectionTest methodsFor: 'tests - copying same contents' stamp: ''! testReverse | result | result := self nonEmpty reversed. "verify content of 'result: '" 1 to: result size do: [:i | self assert: ((result at: i) = (self nonEmpty at: (self nonEmpty size - i + 1)))]. "verify size of 'result' :" self assert: result size=self nonEmpty size.! ! !OrderedCollectionTest methodsFor: 'test - creation' stamp: ''! testWithWithWithWith "self debug: #testWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 4. aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: ( collection at: 4). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testBeforeIfAbsent "self debug: #testBefore" self assert: (self moreThan4Elements before: (self moreThan4Elements at: 1) ifAbsent: [ 99 ]) = 99. self assert: (self moreThan4Elements before: (self moreThan4Elements at: 2) ifAbsent: [ 99 ]) = (self moreThan4Elements at: 1)! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable' stamp: ''! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixturePutOneOrMoreElementsTest self aValue. self indexArray. self indexArray do: [ :each| self assert: each class = SmallInteger. self assert: (each>=1 & each<= self nonEmpty size). ]. self assert: self indexArray size = self valueArray size. self empty. self assert: self empty isEmpty . self nonEmpty. self deny: self nonEmpty isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - as identity set' stamp: ''! testAsIdentitySetWithoutIdentityEqualsElements | result collection | collection := self collectionWithCopy. result := collection asIdentitySet. " no elements should have been removed as no elements are equels with Identity equality" self assert: result size = collection size. collection do: [ :each | (collection occurrencesOf: each) = (result asOrderedCollection occurrencesOf: each) ]. self assert: result class = IdentitySet! ! !OrderedCollectionTest methodsFor: 'test - iterate' stamp: 'stephane.ducasse 10/6/2008 17:38'! speciesClass ^ OrderedCollection! ! !OrderedCollectionTest methodsFor: 'tests - accessing' stamp: 'stephane.ducasse 10/6/2008 16:32'! testCapacityFromAsOrderedCollection "Allows one to check the current capacity of an Ordered collection" "self run:#testCapacityFromAsOrderedCollection" | c1 c2 c3 | c1 := #(1 2 ) asOrderedCollection. self assert: (c1 capacity = 2). c2 := OrderedCollection new: 10. c2 add: 3. self assert: (c2 capacity = 10). c3 := OrderedCollection new. self deny: (c3 capacity = 0). ! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic' stamp: ''! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: ''! test0FixtureCopySameContentsTest self nonEmpty. self deny: self nonEmpty isEmpty. self empty. self assert: self empty isEmpty! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsCommaStringOne "self assert: self oneItemCol asCommaString = '1'. self assert: self oneItemCol asCommaStringAnd = '1'." self assert: self nonEmpty1Element asCommaString = (self nonEmpty1Element first asString). self assert: self nonEmpty1Element asCommaStringAnd = (self nonEmpty1Element first asString). ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/21/2009 13:48'! floatCollectionWithSameAtEndAndBegining " return a collection with elements at end and begining equals only with classic equality (they are not the same object). (others elements of the collection are not equal to those elements)" ^ floatCollectionWithSameBeginingEnd ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testFromToDo | result | result:= OrderedCollection new. self nonEmptyMoreThan1Element from: 1 to: (self nonEmptyMoreThan1Element size -1) do: [:each | result add: each]. 1 to: (self nonEmptyMoreThan1Element size -1) do: [:i| self assert: (self nonEmptyMoreThan1Element at:i )=(result at:i)]. self assert: result size=(self nonEmptyMoreThan1Element size-1).! ! !OrderedCollectionTest methodsFor: 'tests - adding' stamp: 'sd 3/21/2006 22:36'! testAddAllLast "Allows one to add each element of an orderedCollection at the beginning of another orderedCollection " "self run:#testAddAllLast" | c1 c2 | c1 := #(1 2 3 4 ) asOrderedCollection. c2 := #(5 6 7 8 9 ) asOrderedCollection. c1 addAllLast: c2. self assert: c1 = #(1 2 3 4 5 6 7 8 9) asOrderedCollection! ! !OrderedCollectionTest methodsFor: 'tests - accessing' stamp: 'zz 12/7/2005 18:50'! testAt | collection | collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. self assert: (collection at:1) = 'Jim'. self assert: (collection at:2) = 'Mary'! ! !OrderedCollectionTest methodsFor: 'setup' stamp: 'SebastianTleye 6/28/2013 14:38'! setUp nonEmpty := OrderedCollection new add: self valuePutIn; add: self elementTwiceIn; add: self elementTwiceIn; yourself. empty := OrderedCollection new. elementNotIn := 99. collectionWith4Elements := OrderedCollection new add: 1; add: -2; add: 3; add: 1; yourself. indexArray := { 3. 1.}. indexCollection := OrderedCollection new add: 1; add: 2;add: 3; add: 4; add:5; yourself. otherCollection := OrderedCollection new add: 1;add: 20; add: 30; yourself. withoutEqualElements := OrderedCollection new add: 1;add: 20; add: 30; yourself. collectResult := OrderedCollection new add: SmallInteger; add: SmallInteger; add: SmallInteger; yourself. collectionOfCollectionsOfStrings:= OrderedCollection new add: (OrderedCollection new add: (OrderedCollection new add: 'foo'; yourself); add: (OrderedCollection new add: 'bar'; yourself); yourself); add: 'zorg'; yourself. simpleCollection := OrderedCollection new add: 1; add: 8; add: 3; yourself. collectionOfCollectionsOfInts := OrderedCollection new add: 1; add: (OrderedCollection new add: 2; add: 3; yourself); add: (OrderedCollection new add: 4; add: (OrderedCollection new add: 5; add: 6; yourself); yourself); yourself. withCharacters := OrderedCollection new add: $a; add: $x; add: $d; add: $c; add: $m; yourself. emptyButAllocatedWith20 := OrderedCollection new: 20. collectionWithElement := OrderedCollection new add: self element; yourself. collectionOfFloat := OrderedCollection new add: 4.1; add: 7.2; add: 2.5; yourself. floatCollectionWithSameBeginingEnd := OrderedCollection new add: 4.1; add: 7.2; add: 4.1 copy ; yourself. duplicateElement := 2. collectionWithDuplicateElement := OrderedCollection new add: duplicateElement ; add: duplicateElement ; add:4 ; yourself. collection5Elements := OrderedCollection new add: 1; add: 2; add: 3; add: 4; add: 5; yourself.! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:02'! elementNotIn ^ elementNotIn ! ! !OrderedCollectionTest methodsFor: 'test - creation' stamp: ''! testWithWithWithWithWith "self debug: #testWithWithWithWithWith" | aCol collection | collection := self collectionMoreThan5Elements asOrderedCollection copyFrom: 1 to: 5 . aCol := self collectionClass with: (collection at:1) with: ( collection at:2 ) with: ( collection at: 3) with: (collection at: 4 ) with: ( collection at: 5 ). 1 to: 3 do: [ :i | self assert: ( aCol occurrencesOf: ( collection at: i ) ) = ( collection occurrencesOf: ( collection at: i ) ) ].! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:52'! moreThan3Elements " return a collection including atLeast 3 elements" ^ indexCollection ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:45'! replacementCollectionSameSize " return a collection of size (secondIndex - firstIndex + 1)" | res | res := OrderedCollection new. 1 to: (self secondIndex - self firstIndex + 1) do: [ :i | res add: 99. ]. ^res.! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 14:05'! nonEmptyMoreThan1Element " return a collection with more than one element" ^ withoutEqualElements .! ! !OrderedCollectionTest methodsFor: 'tests - element accessing' stamp: ''! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness' stamp: ''! testIndexOfIfAbsentDuplicate "self debug: #testIndexOfIfAbsent" | collection element | collection := self collectionWithSameAtEndAndBegining. element := collection last. " floatCollectionWithSameAtEndAndBegining first and last elements are equals 'indexOf:ifAbsent: should return the position of the first occurrence :'" self assert: (collection indexOf: element ifAbsent: [ 55 ]) = 1! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter' stamp: ''! testAsStringOnDelimiterOne | delim oneItemStream result | "delim := ', '. oneItemStream := '' readWrite. self oneItemCol asStringOn: oneItemStream delimiter: delim. self assert: oneItemStream contents = '1'." delim := ', '. result:=''. oneItemStream := ReadWriteStream on: result. self nonEmpty1Element asStringOn: oneItemStream delimiter: delim. oneItemStream do:[:each | self assert: each = (self nonEmpty1Element first asString)]. ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: ''! elementInForReplacement " return an element included in 'nonEmpty' " ^ self nonEmpty anyOne.! ! !OrderedCollectionTest methodsFor: 'tests - at put' stamp: ''! testAtPutOutOfBounds "self debug: #testAtPutOutOfBounds" self should: [self empty at: self anIndex put: self aValue] raise: Error ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:03'! elementInForIncludesTest " return an element included in nonEmpty " ^ self nonEmpty anyOne! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOfIfAbsent "self debug: #testIndexOfIfAbsent" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection lastIndexOf: element ifAbsent: [ 99 ]) = 1. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing ifAbsent: [ 99 ]) = 99! ! !OrderedCollectionTest methodsFor: 'tests - copying with replacement' stamp: ''! firstIndexesOf: aSubCollection in: collection " return an OrderedCollection with the first indexes of the occurrences of subCollection in collection " | tmp result currentIndex | tmp:= collection. result:= OrderedCollection new. currentIndex := 1. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: aSubCollection) ifTrue: [ result add: currentIndex. 1 to: aSubCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections' stamp: ''! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: ''! testLastIndexOfStartingAt "self debug: #testLastIndexOf" | element collection | collection := self collectionMoreThan1NoDuplicates. element := collection last. self assert: (collection lastIndexOf: element startingAt: collection size ifAbsent: [ 99 ]) = collection size. self assert: (collection lastIndexOf: element startingAt: collection size - 1 ifAbsent: [ 99 ]) = 99. self assert: (collection lastIndexOf: self elementNotInForIndexAccessing startingAt: collection size ifAbsent: [ 99 ]) = 99! ! !OrderedIdentityDictionary commentStamp: ''! An OrderedIdentityDictionary is a dictionary which keep the order of addition of the elements! !OrderedIdentityDictionary methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:06'! initialize "This method is not used since new is overriden to use initalize:" keys := OrderedCollection new. super initialize. ! ! !OrderedIdentityDictionary methodsFor: 'removing' stamp: 'BenjaminVanRyseghem 7/10/2012 21:18'! removeKey: key ifAbsent: aBlock "Here I do not do anything if absent not to perform the block twice" keys remove: key ifAbsent: []. ^ super removeKey: key ifAbsent: aBlock ! ! !OrderedIdentityDictionary methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:06'! initialize: aNumber keys := OrderedCollection new. super initialize: aNumber! ! !OrderedIdentityDictionary methodsFor: 'adding' stamp: 'BenjaminVanRyseghem 7/10/2012 21:32'! at: key put: anObject (self includesKey: key) ifFalse: [ keys add: key ]. ^ super at: key put: anObject ! ! !OrderedIdentityDictionary methodsFor: 'adding' stamp: 'BenjaminVanRyseghem 7/10/2012 21:12'! add: anAssociation (self includesKey: anAssociation key) ifFalse: [ keys add: anAssociation key ]. ^ super add: anAssociation ! ! !OrderedIdentityDictionary methodsFor: 'enumerating' stamp: 'BenjaminVanRyseghem 7/10/2012 21:14'! associationsDo: aBlock keys do: [:k | aBlock value: (self associationAt: k )]! ! !OrientedFillStyle commentStamp: ''! OrientedFill is an abstract superclass for fills which can be aligned appropriately. Instance variables: origin The point at which to align the fill. direction The direction in which the fill is defined normal Typically, just the direction rotated by 90 degrees.! !OrientedFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'dgd 10/17/2003 22:35'! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" aMenu add: 'change origin' translated target: self selector: #changeOriginIn:event: argument: aMorph. aMenu add: 'change orientation' translated target: self selector: #changeOrientationIn:event: argument: aMorph.! ! !OrientedFillStyle methodsFor: 'testing' stamp: 'ar 6/18/1999 07:57'! isOrientedFill "Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)" ^true! ! !OrientedFillStyle methodsFor: 'comparing' stamp: 'gvc 7/24/2007 12:20'! hash "Hash is implemented because #= is implemented." ^self species hash bitXor: (self origin hash bitXor: (self direction hash bitXor: (self normal hash)))! ! !OrientedFillStyle methodsFor: 'comparing' stamp: 'gvc 7/24/2007 12:19'! = anOrientedFillStyle "Answer whether equal." ^self species = anOrientedFillStyle species and: [self origin = anOrientedFillStyle origin and: [self direction = anOrientedFillStyle direction and: [self normal = anOrientedFillStyle normal]]]! ! !OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:38'! origin ^origin! ! !OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:03'! direction ^direction ifNil:[direction := normal y @ normal x negated]! ! !OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:37'! direction: aPoint direction := aPoint! ! !OrientedFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'ar 6/18/1999 07:41'! changeOrientationIn: aMorph event: evt "Interactively change the origin of the receiver" | handle | handle := HandleMorph new forEachPointDo:[:pt| self direction: pt - self origin. self normal: nil. aMorph changed]. evt hand attachMorph: handle. handle startStepping.! ! !OrientedFillStyle methodsFor: '*Morphic-Base-Balloon' stamp: 'ar 6/18/1999 07:28'! changeOriginIn: aMorph event: evt "Interactively change the origin of the receiver" | handle | handle := HandleMorph new forEachPointDo:[:pt| self origin: pt. aMorph changed]. evt hand attachMorph: handle. handle startStepping.! ! !OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/14/1998 23:31'! normal ^normal ifNil:[normal := direction y negated @ direction x]! ! !OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:38'! origin: aPoint origin := aPoint.! ! !OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:37'! normal: aPoint normal := aPoint! ! !OutOfMemory commentStamp: 'StephaneDucasse 12/18/2009 12:01'! OutOfMemory is signaled when an allocation fails due to not having enough memory. Its default action signals the low-space semaphore. Originally suggested by A. Raab.! !OutOfMemory methodsFor: 'handling' stamp: 'StephaneDucasse 12/18/2009 11:57'! defaultAction Smalltalk signalLowSpace.! ! !OutOfMemory methodsFor: 'testing' stamp: 'StephaneDucasse 12/18/2009 11:57'! isResumable ^true! ! !OverflowRowMorph commentStamp: 'gvc 1/12/2010 13:32'! Instances of this class accept, via #baseMorph:, a morph that is expected to be row-like containing submorphs. Based on the receiver's layout, the base morphs that are able to fit within the receiver (subject to minExtents) are layed out along with, if necessary, a button to pop-up a column of any remaining, unfittable, base morphs. Handy for button bars etc. Example: (OverflowRowMorph new baseMorph: (UITheme builder newRow: ((1 to: 6) collect: [:i | |label| label := 'Button ', i asString. (UITheme builder newButtonFor: Transcript getState: nil action: #show: arguments: {label} getEnabled: nil label: label help: nil) hResizing: #spaceFill]))) openInWindow ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 4/12/2011 10:11'! newPotentialMorph "Answer a morph for trialing potential layout." |potential| potential := self theme builder newRow: self baseMorphs. potential extent: potential minExtent. ^potential! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2010 12:47'! outOfWorld: aWorld "Get rid of the more column if visible." self hideMore. ^super outOfWorld: aWorld! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2010 18:54'! buttonWidth "Answer the width for the more button." ^self theme scrollbarThickness + 3! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/18/2010 16:41'! adoptPaneColor: paneColor "Pass on to the list morph and border too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self moreButton cornerStyle: self cornerStyle. self changed: #moreButtonLabel. self moreMorphs do: [:m | m adoptPaneColor: paneColor]! ! !OverflowRowMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2010 19:13'! baseMorphs "Answer the value of baseMorphs" ^ baseMorphs! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2010 18:35'! moreButtonLabel "Answer the label for the more button." ^AlphaImageMorph new image: ( ScrollBar arrowOfDirection: #right size: self buttonWidth color: self paneColor darker)! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/1/2010 15:02'! moreMorphs "Answer those base morphs that are not currently part of the receiver's submorphs." ^self baseMorphs ifEmpty: [#()] ifNotEmpty: [self baseMorphs copyFrom: self submorphs size to: self baseMorphs size]! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/1/2010 13:29'! fitBaseMorphs "Replace the receiver's submorphs with the base morphs that can fit in the receiver's bounds. Critically, morphs must be replaced in one go to avoid #extent: recursion." |proposed| self hideMore. proposed := self newPotentialMorph. [proposed width <= self width or: [proposed submorphCount = 0]] whileFalse: [ proposed removeMorph: proposed lastSubmorph; extent: proposed minExtent]. proposed submorphCount < self baseMorphs size ifTrue: [ self moreButton hResizing: #shrinkWrap. proposed addMorphBack: self moreButton; extent: proposed minExtent]. [proposed width > self width and: [proposed submorphCount > 1]] whileTrue: [ proposed removeMorph: (proposed submorphs at: proposed submorphs size - 1); extent: proposed minExtent]. (proposed submorphCount = 1 and: [self moreButton owner notNil]) ifTrue: [ self moreButton hResizing: #spaceFill]. self removeAllMorphs; addAllMorphs: proposed submorphs ! ! !OverflowRowMorph methodsFor: 'initialization' stamp: 'gvc 7/1/2010 15:01'! initialize "Initialize the receiver." super initialize. self baseMorphs: #(); moreButton: self newMoreButton; changeTableLayout; listDirection: #leftToRight; vResizing: #shrinkWrap! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2010 13:14'! newMoreButton "Answer a new button for popping up the base morphs that are currently unable to fit in the allotted space." ^(ControlButtonMorph on: self getState: nil action: #popMore label: #moreButtonLabel) hResizing: #rigid; vResizing: #spaceFill; cornerStyle: #square; extent: self buttonWidth asPoint! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2010 18:37'! showMore "Show the morphs that don't fit." self hideMore. self recreateMoreMorph. self world addMorphInLayer: self moreMorph! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 7/9/2013 12:39'! hideMore "Hide the morphs that don't fit." self moreVisible ifTrue: [ self moreMorph delete. self defer: [self world ifNotNil: [:w | w invalidRect: self moreMorph bounds]]]! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2010 12:48'! stepTime "Answer the desired time between steps in milliseconds." ^100! ! !OverflowRowMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2010 20:01'! moreMorph "Answer the value of moreMorph" ^ moreMorph! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/1/2010 12:26'! desiredMoreMorphPosition "Answer the position the more morph should be placed." ^self moreButton boundsInWorld bottom + self moreMorph height > self world height ifTrue: [self moreButton boundsInWorld topRight - (self moreMorph width@self moreMorph height)] ifFalse: [self moreButton boundsInWorld bottomRight - (self moreMorph width@0)]! ! !OverflowRowMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2010 20:01'! moreMorph: anObject "Set the value of moreMorph" moreMorph := anObject! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/18/2010 15:25'! popMore "Hide / show the unshown base morphs." (self moreMorph isNil or: [self moreMorph owner isNil]) ifTrue: [self showMore] ifFalse: [self hideMore]! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2010 18:55'! baseMorph: aRowMorph "Configure the receiver to match the specifications for the given morph and store the given morph's submorphs for later reallocation." self baseMorphs: aRowMorph submorphs. self cellInset: aRowMorph cellInset; layoutInset: aRowMorph layoutInset; height: aRowMorph minExtent y; minHeight: self height. self fitBaseMorphs! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 7/9/2013 12:38'! extent: aPoint "Refit the base morphs and potential 'more' button'" super extent: aPoint. self fitBaseMorphs. self defer: [self layoutChanged] "since possibly changing actual submorphs during layout processing"! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2010 12:48'! moreVisible "Answer whether the more column is visible." ^(self moreMorph ifNil: [^false]) owner notNil! ! !OverflowRowMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2010 19:13'! baseMorphs: anObject "Set the value of baseMorphs" baseMorphs := anObject! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 4/29/2011 00:37'! step "Move the more column if it is showing." self moreVisible ifTrue: [ self window ifNotNil: [:w | w isActive ifFalse: [self hideMore]]. self moreMorph position = self desiredMoreMorphPosition ifFalse: [self hideMore]]! ! !OverflowRowMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2010 19:14'! moreButton "Answer the value of moreButton" ^ moreButton! ! !OverflowRowMorph methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 4/12/2011 10:11'! recreateMoreMorph "Answer a new morph showing the undisplayed base morphs. Assign to moreMorph." self moreMorph: (self theme builder newColumn: self moreMorphs). self moreMorph setProperty: #morphicLayerNumber toValue: 6; layoutInset: 4; borderStyle: (self theme taskbarThumbnailNormalBorderStyleFor: self moreMorph); extent: self moreMorph minExtent; position: self desiredMoreMorphPosition; paneColor: self paneColor; color: self paneColor. ^self moreMorph! ! !OverflowRowMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2010 19:14'! moreButton: anObject "Set the value of moreButton" moreButton := anObject! ! !PNGReadWriter commentStamp: ''! I am a subclass of ImageReadWriter that decodes Portable Network Graphics (PNG) images. Submitted by Duane Maxwell! !PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:54'! filterVertical: count "Use the pixel above as a predictor" 1 to: count do: [ :i | thisScanline at: i put: (((thisScanline at: i) + (prevScanline at: i)) bitAnd: 255) ] ! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'lr 7/4/2009 10:42'! processIHDRChunk width := chunk longAt: 1 bigEndian: true. height := chunk longAt: 5 bigEndian: true. bitsPerChannel := chunk at: 9. colorType := chunk at: 10. "compression := chunk at: 11." "TODO - validate compression" "filterMethod := chunk at: 12." "TODO - validate filterMethod" interlaceMethod := chunk at: 13. "TODO - validate interlace method" (#(2 4 6 ) includes: colorType) ifTrue: [ depth := 32 ]. (#(0 3 ) includes: colorType) ifTrue: [ depth := bitsPerChannel min: 8. colorType = 0 ifTrue: [ "grayscale" palette := self grayColorsFor: depth ] ]. bitsPerPixel := (BPP at: colorType + 1) at: bitsPerChannel highBit. bytesPerScanline := (width * bitsPerPixel + 7) // 8. rowSize := width * depth + 31 >> 5! ! !PNGReadWriter methodsFor: 'accessing' stamp: 'DSM 3/24/2000 01:12'! understandsImageFormat #(137 80 78 71 13 10 26 10) do: [ :byte | stream next = byte ifFalse: [^ false]]. ^ true ! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'StephaneDucasse 10/25/2013 16:18'! copyPixelsGrayAlpha: y at: startX by: incX "Handle interlaced grayscale with alpha color mode (colorType = 4)" | i pixel gray b | b := BitBlt bitPokerToForm: form. bitsPerChannel = 8 ifTrue: [ startX to: width - 1 by: incX do: [ :x | i := (x // incX << 1) + 1. gray := thisScanline at: i. pixel := ((thisScanline at: i + 1) << 24) + (gray << 16) + (gray << 8) + gray. b pixelAt: x @ y put: pixel ] ] ifFalse: [ startX to: width - 1 by: incX do: [ :x | i := (x // incX << 2) + 1. gray := thisScanline at: i. pixel := ((thisScanline at: i + 2) << 24) + (gray << 16) + (gray << 8) + gray. b pixelAt: x @ y put: pixel ] ]! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'SvenVanCaekenberghe 10/26/2013 10:17'! processNonInterlaced | z filter temp copyMethod debug | debug := self debugging. copyMethod := #( #copyPixelsGray: nil #copyPixelsRGB: #copyPixelsIndexed: #copyPixelsGrayAlpha: nil #copyPixelsRGBA: ) at: colorType + 1. debug ifTrue: [ Transcript cr; nextPutAll: 'NI chunk size='; print: idatChunkStream position ]. z := ZLibReadStream on: idatChunkStream originalContents from: 1 to: idatChunkStream position. prevScanline := ByteArray new: bytesPerScanline. thisScanline := ByteArray new: bytesPerScanline. 0 to: height - 1 do: [ :y | filter := z next. debug ifTrue: [ filtersSeen add: filter ]. thisScanline := z next: bytesPerScanline into: thisScanline startingAt: 1. (debug and: [ thisScanline size < bytesPerScanline ]) ifTrue: [ Transcript nextPutAll: ('wanted {1} but only got {2}' format: { bytesPerScanline. (thisScanline size) }); cr ]. filter = 0 ifFalse: [ self filterScanline: filter count: bytesPerScanline ]. self perform: copyMethod with: y. temp := prevScanline. prevScanline := thisScanline. thisScanline := temp ]. z atEnd ifFalse: [ self error: 'Unexpected data' ]. debug ifTrue: [ Transcript nextPutAll: ' compressed size='; print: z position ]! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! copyPixelsRGB: y at: startX by: incX "Handle interlaced RGB color mode (colorType = 2)" | i pixel tempForm tempBits xx loopsToDo | tempForm := Form extent: width @ 1 depth: 32. tempBits := tempForm bits. pixel := LargePositiveInteger new: 4. pixel at: 4 put: 255. loopsToDo := (width - startX + incX - 1) // incX. bitsPerChannel = 8 ifTrue: [ i := startX // incX * 3 + 1. xx := startX + 1. 1 to: loopsToDo do: [ :j | pixel at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i + 1); at: 1 put: (thisScanline at: i + 2). tempBits at: xx put: pixel. i := i + 3. xx := xx + incX ] ] ifFalse: [ i := startX // incX * 6 + 1. xx := startX + 1. 1 to: loopsToDo do: [ :j | pixel at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i + 2); at: 1 put: (thisScanline at: i + 4). tempBits at: xx put: pixel. i := i + 6. xx := xx + incX ] ]. transparentPixelValue ifNotNil: [ startX to: width - 1 by: incX do: [ :x | (tempBits at: x + 1) = transparentPixelValue ifTrue: [ tempBits at: x + 1 put: 0 ] ] ]. tempForm displayOn: form at: 0 @ y rule: Form paint! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'SvenVanCaekenberghe 10/26/2013 10:05'! copyPixelsRGB: y "Handle non-interlaced RGB color mode (colorType = 2)" | i pixel tempForm tempBits | (transparentPixelValue isNil and: [ bitsPerChannel = 8 ]) ifTrue: [ "Do the same trick as in #copyPixelsRGBA:" | targetIndex | tempBits := ByteArray new: thisScanline size * 4 // 3 withAll: 16rFF. tempForm := Form extent: width@1 depth: 32 bits: tempBits. targetIndex := 1. 1 to: thisScanline size by: 3 do: [ :index | tempBits at: targetIndex put: (thisScanline at: index); at: targetIndex + 1 put: (thisScanline at: index + 1); at: targetIndex + 2 put: (thisScanline at: index + 2). targetIndex := targetIndex + 4 ]. cachedDecoderMap ifNil:[cachedDecoderMap := self rgbaDecoderMapForDepth: depth]. (BitBlt toForm: form) sourceForm: tempForm; destOrigin: 0@y; combinationRule: Form over; colorMap: cachedDecoderMap; copyBits. ^self ]. tempForm := Form extent: width @ 1 depth: 32. tempBits := tempForm bits. pixel := LargePositiveInteger new: 4. pixel at: 4 put: 255. i := 1. bitsPerChannel = 8 ifTrue: [ 1 to: width do: [ :x | pixel at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i + 1); at: 1 put: (thisScanline at: i + 2). tempBits at: x put: pixel. i := i + 3 ] ] ifFalse: [ 1 to: width do: [ :x | pixel at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i + 2); at: 1 put: (thisScanline at: i + 4). tempBits at: x put: pixel. i := i + 6 ] ]. transparentPixelValue ifNotNil: [ 1 to: width do: [ :x | (tempBits at: x) = transparentPixelValue ifTrue: [ tempBits at: x put: 0 ] ] ]. tempForm displayOn: form at: 0 @ y rule: Form paint! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 2/19/2004 00:10'! writeType6DataOn: zStream "Write RGBA data." | scanline hack hackBlt cm miscBlt | scanline := ByteArray new: bytesPerScanline. hack := Form extent: width@1 depth: 32 bits: scanline. form depth = 16 ifTrue:[ "Expand 16 -> 32" miscBlt := BitBlt toForm: hack. miscBlt sourceForm: form. miscBlt combinationRule: Form over. miscBlt destOrigin: 0@0. miscBlt width: width; height: 1. ]. hackBlt := BitBlt toForm: hack. hackBlt sourceForm: (miscBlt ifNil:[form] ifNotNil:[hack]). hackBlt combinationRule: Form over. hackBlt destOrigin: 0@0. hackBlt width: width; height: 1. bigEndian ifTrue:[ cm := ColorMap shifts: #(8 8 8 -24) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). ] ifFalse:[ cm := ColorMap shifts: #(-16 0 16 0) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). ]. hackBlt colorMap: cm. 0 to: height-1 do:[:i| miscBlt ifNil:[ hackBlt sourceOrigin: 0@i; copyBits. ] ifNotNil:[ miscBlt sourceOrigin: 0@i; copyBits. hack fixAlpha. hackBlt copyBits. ]. zStream nextPut: 0. "filterType" zStream nextPutAll: scanline. ]. zStream close.! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 18:29'! writeSBITChunkOn: aStream "Write the IDAT chunk" aStream nextPutAll: 'sBIT' asByteArray. form depth = 16 ifFalse:[self error: 'Unimplemented feature']. aStream nextPut: 5. aStream nextPut: 5. aStream nextPut: 5. aStream nextPut: 1.! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'lr 7/4/2009 10:42'! processPLTEChunk | colorCount i | colorCount := chunk size // 3. "TODO - validate colorCount against depth" palette := Array new: colorCount. 0 to: colorCount - 1 do: [ :index | i := index * 3 + 1. palette at: index + 1 put: (Color r: (chunk at: i) / 255.0 g: (chunk at: i + 1) / 255.0 b: (chunk at: i + 2) / 255.0) ]! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 2/19/2004 00:10'! rgbaDecoderMapForDepth: decoderDepth bigEndian ifTrue:[ depth = 16 ifTrue:[ "Big endian, 32 -> 16 color mapping." ^ColorMap shifts: #(-17 -14 -11 0) masks: #(16rF8000000 16rF80000 16rF800 16r00) ] ifFalse:[ "Big endian, 32 -> 32 color mapping" ^ColorMap shifts: #(-8 -8 -8 24) masks: #(16rFF000000 16rFF0000 16rFF00 16rFF). ]. ]. depth = 16 ifTrue:[ "Little endian, 32 -> 16 color mapping." ^ColorMap shifts: #(7 -6 -19 0) masks: #(16rF8 16rF800 16rF80000 0) ] ifFalse:[ "Little endian, 32 -> 32 color mapping" ^ColorMap shifts: #(-16 0 16 0) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). ].! ! !PNGReadWriter methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 10/26/2013 10:08'! nextImage bigEndian := Smalltalk isBigEndian. filtersSeen := Bag new. idatChunkStream := nil. transparentPixelValue := nil. unknownChunks := Set new. stream reset. stream binary. stream skip: 8. [stream atEnd] whileFalse: [self processNextChunk]. "Set up our form" palette ifNotNil: ["Dump the palette if it's the same as our standard palette" palette = (StandardColors copyFrom: 1 to: palette size) ifTrue: [palette := nil]]. (depth <= 8 and: [palette notNil]) ifTrue: [form := ColorForm extent: width @ height depth: depth. form colors: palette] ifFalse: [form := Form extent: width @ height depth: depth]. backColor ifNotNil: [form fillColor: backColor]. idatChunkStream ifNil: [ self error: 'image data is missing' ] ifNotNil: [ self processIDATChunk ]. unknownChunks isEmpty ifFalse: ["Transcript show: ' ',unknownChunks asSortedCollection asArray printString."]. self debugging ifTrue: [Transcript cr; show: 'form = ' , form printString. Transcript cr; show: 'colorType = ' , colorType printString. Transcript cr; show: 'interlaceMethod = ' , interlaceMethod printString. Transcript cr; show: 'filters = ' , filtersSeen sortedCounts asArray printString]. ^form! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:08'! writeIENDChunkOn: aStream "Write the IEND chunk" aStream nextPutAll: 'IEND' asByteArray.! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! copyPixels: y "Handle non-interlaced pixels of supported colorTypes" | s | s := #( #copyPixelsGray: nil #copyPixelsRGB: #copyPixelsIndexed: #copyPixelsGrayAlpha: nil #copyPixelsRGBA: ) at: colorType + 1. self perform: s asSymbol with: y! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 1/1/1970 20:58'! writeType3DataOn: zStream "Write color indexed data." | scanline hack hackBlt swizzleBlt swizzleHack hackDepth | scanline := ByteArray new: bytesPerScanline + 3 // 4 * 4. hackDepth := bigEndian ifTrue:[form depth] ifFalse:[form depth negated]. hack := Form extent: width@1 depth: hackDepth bits: scanline. hackBlt := BitBlt toForm: hack. hackBlt sourceForm: form. hackBlt combinationRule: Form over. hackBlt destOrigin: 0@0. hackBlt width: width; height: 1. (form depth < 8 and:[bigEndian not]) ifTrue:[ swizzleHack := Form new hackBits: scanline. swizzleBlt := BitBlt toForm: swizzleHack. swizzleBlt sourceForm: swizzleHack. swizzleBlt combinationRule: Form over. swizzleBlt colorMap: (StandardSwizzleMaps at: form depth). ]. 0 to: height-1 do:[:i| hackBlt sourceOrigin: 0@i; copyBits. swizzleBlt ifNotNil:[swizzleBlt copyBits]. zStream nextPut: 0. "filterType" zStream next: bytesPerScanline putAll: scanline startingAt: 1. ]. zStream close.! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'ar 12/12/2003 18:33'! processSBITChunk | rBits gBits bBits aBits | colorType = 6 ifFalse:[^self]. rBits := chunk at: 1. gBits := chunk at: 2. bBits := chunk at: 3. aBits := chunk at: 4. (rBits = 5 and:[gBits = 5 and:[bBits = 5 and:[aBits = 1]]]) ifTrue:[ depth := 16. ].! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/4/2000 17:00'! processIDATChunk interlaceMethod = 0 ifTrue: [ self processNonInterlaced ] ifFalse: [ self processInterlaced ] ! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/5/2000 11:24'! processPhysicalPixelChunk "Transcript show: ' PHYSICAL: ',chunk printString." ! ! !PNGReadWriter methodsFor: 'filtering' stamp: 'lr 7/4/2009 10:42'! paethPredictLeft: a above: b aboveLeft: c "Predicts the value of a pixel based on nearby pixels, based on Paeth (GG II, 1991)" | pa pb pc | pa := b > c ifTrue: [ b - c ] ifFalse: [ c - b ]. pb := a > c ifTrue: [ a - c ] ifFalse: [ c - a ]. pc := a + b - c - c. pc < 0 ifTrue: [ pc := pc * -1 ]. (pa <= pb and: [ pa <= pc ]) ifTrue: [ ^ a ]. pb <= pc ifTrue: [ ^ b ]. ^ c! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:21'! writeIHDRChunkOn: aStream "Write the IHDR chunk" aStream nextPutAll: 'IHDR' asByteArray. aStream nextInt32Put: width. aStream nextInt32Put: height. aStream nextNumber: 1 put: bitsPerChannel. aStream nextNumber: 1 put: colorType. aStream nextNumber: 1 put: 0. "compression" aStream nextNumber: 1 put: 0. "filter method" aStream nextNumber: 1 put: 0. "interlace method" ! ! !PNGReadWriter methodsFor: 'writing' stamp: 'nk 2/17/2004 16:51'! updateCrc: oldCrc from: start to: stop in: aCollection ^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'StephaneDucasse 10/25/2013 16:18'! copyPixelsIndexed: y at: startX by: incX "Handle interlaced indexed color mode (colorType = 3)" | offset bits pixPerByte shifts blitter pixel mask pixelNumber | offset := y * rowSize + 1. bits := form bits. bitsPerChannel = 8 ifTrue: [ startX to: width - 1 by: incX do: [ :x | | w b | w := offset + (x >> 2). b := (3 - (x \\ 4)) * 8. pixel := (thisScanline at: x // incX + 1) << b. mask := (255 << b) bitInvert32. bits at: w put: (((bits at: w) bitAnd: mask) bitOr: pixel) ]. ^ self ]. bitsPerChannel = 1 ifTrue: [ pixPerByte := 8. mask := 1. shifts := #(7 6 5 4 3 2 1 0 ) ]. bitsPerChannel = 2 ifTrue: [ pixPerByte := 4. mask := 3. shifts := #(6 4 2 0 ) ]. bitsPerChannel = 4 ifTrue: [ pixPerByte := 2. mask := 15. shifts := #(4 0 ) ]. blitter := BitBlt bitPokerToForm: form. pixelNumber := 0. startX to: width - 1 by: incX do: [ :x | | rawByte | rawByte := thisScanline at: pixelNumber // pixPerByte + 1. pixel := rawByte >> (shifts at: pixelNumber \\ pixPerByte + 1) bitAnd: mask. blitter pixelAt: x @ y put: pixel. pixelNumber := pixelNumber + 1 ]! ! !PNGReadWriter methodsFor: 'filtering' stamp: 'lr 7/4/2009 10:42'! filterHorizontal: count "Use the pixel to the left as a predictor" | delta | delta := bitsPerPixel // 8 max: 1. delta + 1 to: count do: [ :i | thisScanline at: i put: ((thisScanline at: i) + (thisScanline at: i - delta) bitAnd: 255) ]! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'StephaneDucasse 10/25/2013 16:17'! copyPixelsGray: y "Handle non-interlaced grayscale color mode (colorType = 0)" | base bits bytesLeft word | bitsPerChannel = 16 ifTrue: [ "Warning: This is extremely slow. Besides we are downsampling to 8 bits!!" | blitter | blitter := BitBlt bitPokerToForm: form. 0 to: width - 1 do: [ :x | blitter pixelAt: x @ y put: 255 - (thisScanline at: x * 2 + 1) ]. ^self ]. "Just copy the bits" "This Smalltalk version might be easier to understand than the others below." base := y * (form width * bitsPerChannel + 31 // 32) + 1. bits := form bits. 0 to: thisScanline size // 4 - 1 do: [ :i | | ii | ii := i * 4. "This somewhat weird mixture of (#* and #+) with (#bitShift: and #bitOr:) is to make use of faster arithmetic bytecodes, but not of slow largeintegers." word := (((thisScanline at: ii + 1) * 256 + (thisScanline at: ii + 2) * 256 + (thisScanline at: ii + 3)) bitShift: 8) bitOr: (thisScanline at: ii + 4). bits at: base + i put: word ]. (bytesLeft := thisScanline size bitAnd: 3) = 0 ifFalse: [ word := 0. thisScanline size - bytesLeft + 1 to: thisScanline size do: [ :ii | word := word * 256 + (thisScanline at: ii) ]. word := word bitShift: 8 * (4 - bytesLeft). bits at: base + (thisScanline size // 4) put: word ]. "This interesting technique (By Andreas Raab) is faster for very large images, but might be slower for small ones" "^self copyPixelsGrayWeirdBitBltHack: y ". "It uses the following method: PNGReadWriter >> copyPixelsGrayWeirdBitBltHack: y ""Handle non-interlaced black and white color mode (colorType = 0) By Andreas Raab"" | source dest cmap | source := Form extent: 1 @ (thisScanline size // 4) depth: 32 bits: thisScanline. dest := Form extent: 1 @ (form bits size) depth: 32 bits: form bits. cmap := Smalltalk isLittleEndian ifTrue:[ColorMap shifts: #(-24 -8 8 24) masks: #(16rFF000000 16r00FF0000 16r0000FF00 16r000000FF)]. (BitBlt toForm: dest) sourceForm: source; destX: 0 destY: (y * form width*bitsPerChannel//32) width: 1 height: (form width+31*bitsPerChannel//32); colorMap: cmap; combinationRule: 3; copyBits." "This interesting technique (By Yoshiki Ohshima) is faster for very large images, but might be slower for small ones" "form bits copyFromByteArray2: thisScanline to: y * (form width* bitsPerChannel // 32)". "It uses the following method: BitMap >> copyFromByteArray2: byteArray to: i ""This method should work with either byte orderings"" | myHack byteHack | myHack := Form new hackBits: self. byteHack := Form new hackBits: byteArray. Smalltalk isLittleEndian ifTrue: [byteHack swapEndianness]. byteHack displayOn: myHack at: 0@i"! ! !PNGReadWriter methodsFor: 'filtering' stamp: 'lr 7/4/2009 10:42'! filterAverage: count "Use the average of the pixel to the left and the pixel above as a predictor" | delta | delta := bitsPerPixel // 8 max: 1. 1 to: delta do: [ :i | thisScanline at: i put: ((thisScanline at: i) + ((prevScanline at: i) // 2) bitAnd: 255) ]. delta + 1 to: count do: [ :i | thisScanline at: i put: ((thisScanline at: i) + (((prevScanline at: i) + (thisScanline at: i - delta)) // 2) bitAnd: 255) ]! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'lr 7/4/2009 10:42'! processBackgroundChunk "Transcript show: ' BACKGROUND: ',chunk printString." | val red green blue max | colorType = 3 ifTrue: [ backColor := palette at: chunk first + 1. ^ self ]. max := (2 raisedTo: bitsPerChannel) - 1. (colorType = 0 or: [ colorType = 4 ]) ifTrue: [ val := chunk unsignedShortAt: 1 bigEndian: true. backColor := Color gray: val / max. ^ self ]. (colorType = 2 or: [ colorType = 6 ]) ifTrue: [ red := chunk unsignedShortAt: 1 bigEndian: true. green := chunk unsignedShortAt: 3 bigEndian: true. blue := chunk unsignedShortAt: 5 bigEndian: true. backColor := Color r: red / max g: green / max b: blue / max. ^ self ] "self halt." "==== The bKGD chunk specifies a default background color to present the image against. Note that viewers are not bound to honor this chunk; a viewer can choose to use a different background. For color type 3 (indexed color), the bKGD chunk contains: Palette index: 1 byte The value is the palette index of the color to be used as background. For color types 0 and 4 (grayscale, with or without alpha), bKGD contains: Gray: 2 bytes, range 0 .. (2^bitdepth)-1 (For consistency, 2 bytes are used regardless of the image bit depth.) The value is the gray level to be used as background. For color types 2 and 6 (truecolor, with or without alpha), bKGD contains: Red: 2 bytes, range 0 .. (2^bitdepth)-1 Green: 2 bytes, range 0 .. (2^bitdepth)-1 Blue: 2 bytes, range 0 .. (2^bitdepth)-1 (For consistency, 2 bytes per sample are used regardless of the image bit depth.) This is the RGB color to be used as background. When present, the bKGD chunk must precede the first IDAT chunk, and must follow the PLTE chunk, if any. ==="! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'SvenVanCaekenberghe 10/26/2013 10:11'! processNextChunk | length chunkType crc chunkCrc | length := self nextLong. chunkType := (self next: 4) asString. (chunk isNil or: [ chunk size ~= length ]) ifTrue: [ chunk := self next: length ] ifFalse: [ stream next: length into: chunk startingAt: 1 ]. chunkCrc := self nextLong bitXor: 4294967295. crc := self updateCrc: 4294967295 from: 1 to: 4 in: chunkType. crc := self updateCrc: crc from: 1 to: length in: chunk. crc = chunkCrc ifFalse: [ self error: 'PNGReadWriter crc error in chunk ' , chunkType ]. chunkType = 'IEND' ifTrue: [ ^ self "*should* be the last chunk" ]. chunkType = 'sBIT' ifTrue: [ ^ self processSBITChunk "could indicate unusual sample depth in original" ]. chunkType = 'gAMA' ifTrue: [ ^ self "indicates gamma correction value" ]. chunkType = 'bKGD' ifTrue: [ ^ self processBackgroundChunk ]. chunkType = 'pHYs' ifTrue: [ ^ self processPhysicalPixelChunk ]. chunkType = 'tRNS' ifTrue: [ ^ self processTransparencyChunk ]. chunkType = 'IHDR' ifTrue: [ ^ self processIHDRChunk ]. chunkType = 'PLTE' ifTrue: [ ^ self processPLTEChunk ]. chunkType = 'IDAT' ifTrue: [ "---since the compressed data can span multiple chunks, stitch them all together first. later, if memory is an issue, we need to figure out how to do this on the fly---" idatChunkStream ifNil: [ idatChunkStream := WriteStream with: chunk copy ] ifNotNil: [ idatChunkStream nextPutAll: chunk ]. ^ self ]. unknownChunks add: chunkType! ! !PNGReadWriter methodsFor: 'filtering' stamp: 'lr 7/4/2009 10:42'! filterPaeth: count "Select one of (the pixel to the left, the pixel above and the pixel to above left) to predict the value of this pixel" | delta | delta := bitsPerPixel // 8 max: 1. 1 to: delta do: [ :i | thisScanline at: i put: ((thisScanline at: i) + (prevScanline at: i) bitAnd: 255) ]. delta + 1 to: count do: [ :i | thisScanline at: i put: ((thisScanline at: i) + (self paethPredictLeft: (thisScanline at: i - delta) above: (prevScanline at: i) aboveLeft: (prevScanline at: i - delta)) bitAnd: 255) ]! ! !PNGReadWriter methodsFor: 'writing' stamp: 'lr 7/4/2009 10:42'! writeIDATChunkOn: aStream "Write the IDAT chunk" | z | aStream nextPutAll: 'IDAT' asByteArray. z := ZLibWriteStream on: aStream. form depth <= 8 ifTrue: [ self writeType3DataOn: z ] ifFalse: [ self writeType6DataOn: z ]. self debugging ifTrue: [ Transcript cr; nextPutAll: 'compressed size='; print: aStream position; nextPutAll: ' uncompressed size='; print: z position ]! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 16:37'! nextPutImage: aForm "Write out the given form. We're keeping it simple here, no interlacing, no filters." ^self nextPutImage: aForm interlace: 0 filter: 0. "no filtering"! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:34'! writeTRNSChunkOn: aStream "Write out tRNS chunk" aStream nextPutAll: 'tRNS' asByteArray. form colors do:[:aColor| aStream nextPut: (aColor alpha * 255) truncated. ].! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! copyPixelsRGBA: y "Handle non-interlaced RGBA color modes (colorType = 6)" | i pixel tempForm tempBits ff | bitsPerChannel = 8 ifTrue: [ ff := Form extent: width @ 1 depth: 32 bits: thisScanline. cachedDecoderMap ifNil: [ cachedDecoderMap := self rgbaDecoderMapForDepth: depth ]. (BitBlt toForm: form) sourceForm: ff; destOrigin: 0 @ y; combinationRule: Form over; colorMap: cachedDecoderMap; copyBits. ^ self ]. tempForm := Form extent: width @ 1 depth: 32. tempBits := tempForm bits. pixel := LargePositiveInteger new: 4. i := -7. 0 to: width - 1 do: [ :x | i := i + 8. pixel at: 4 put: (thisScanline at: i + 6); at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i + 2); at: 1 put: (thisScanline at: i + 4). tempBits at: x + 1 put: pixel ]. tempForm displayOn: form at: 0 @ y rule: Form over! ! !PNGReadWriter methodsFor: 'writing' stamp: 'lr 7/4/2009 10:42'! writeChunk: crcStream | bytes length crc debug | debug := self debugging. bytes := crcStream originalContents. length := crcStream position. crc := self updateCrc: 4294967295 from: 1 to: length in: bytes. crc := crc bitXor: 4294967295. debug ifTrue: [ Transcript cr; print: stream position; space; nextPutAll: (bytes copyFrom: 1 to: 4) asString; nextPutAll: ' len='; print: length; nextPutAll: ' crc=0x'; nextPutAll: crc printStringHex ]. stream nextNumber: 4 put: length - 4. "exclude chunk name" stream next: length putAll: bytes startingAt: 1. stream nextNumber: 4 put: crc. debug ifTrue: [ Transcript nextPutAll: ' afterPos='; print: stream position ]. crcStream resetToStart! ! !PNGReadWriter methodsFor: 'miscellaneous' stamp: 'DSM 4/27/2000 13:09'! doPass: pass "Certain interlace passes are skipped with certain small image dimensions" pass = 1 ifTrue: [ ^ true ]. ((width = 1) and: [height = 1]) ifTrue: [ ^ false ]. pass = 2 ifTrue: [ ^ width >= 5 ]. pass = 3 ifTrue: [ ^ height >= 5 ]. pass = 4 ifTrue: [ ^ (width >=3 ) or: [height >= 5] ]. pass = 5 ifTrue: [ ^ height >=3 ]. pass = 6 ifTrue: [ ^ width >=2 ]. pass = 7 ifTrue: [ ^ height >=2 ]. ! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'SvenVanCaekenberghe 10/26/2013 10:09'! processInterlaced | z filter bytesPerPass startingCol colIncrement rowIncrement startingRow cx sc temp | startingCol := #(0 4 0 2 0 1 0 ). colIncrement := #(8 8 4 4 2 2 1 ). rowIncrement := #(8 8 8 4 4 2 2 ). startingRow := #(0 0 4 0 2 0 1 ). z := ZLibReadStream on: idatChunkStream originalContents from: 1 to: idatChunkStream position. 1 to: 7 do: [ :pass | (self doPass: pass) ifTrue: [ cx := colIncrement at: pass. sc := startingCol at: pass. bytesPerPass := ((width - sc + cx - 1) // cx * bitsPerPixel + 7) // 8. prevScanline := ByteArray new: bytesPerPass. thisScanline := ByteArray new: bytesPerScanline. (startingRow at: pass) to: height - 1 by: (rowIncrement at: pass) do: [ :y | filter := z next. filtersSeen add: filter. (filter isNil or: [ (filter between: 0 and: 4) not ]) ifTrue: [ ^ self ]. thisScanline := z next: bytesPerPass into: thisScanline startingAt: 1. self filterScanline: filter count: bytesPerPass. self copyPixels: y at: sc by: cx. temp := prevScanline. prevScanline := thisScanline. thisScanline := temp ] ] ]. z atEnd ifFalse: [ self error: 'Unexpected data' ]! ! !PNGReadWriter methodsFor: 'writing' stamp: 'StephaneDucasse 2/2/2010 12:15'! writeFileSignature stream nextPutAll: #[16r89 16r50 16r4E 16r47 16r0D 16r0A 16r1A 16r0A]! ! !PNGReadWriter methodsFor: 'filtering' stamp: 'eat 9/11/2000 20:08'! filterScanline: filterType count: count self perform: ( #(filterNone: filterHorizontal: filterVertical: filterAverage: filterPaeth:) at: filterType+1) with: count. ! ! !PNGReadWriter methodsFor: 'writing' stamp: 'StephaneDucasse 3/17/2010 21:16'! nextPutImage: aForm interlace: aMethod filter: aFilterType "Note: For now we keep it simple - interlace and filtering are simply ignored" | crcStream | bigEndian := Smalltalk isBigEndian. form := aForm. width := aForm width. height := aForm height. aForm depth <= 8 ifTrue: [bitsPerChannel := aForm depth. colorType := 3. bytesPerScanline := (width * aForm depth + 7) // 8] ifFalse: [bitsPerChannel := 8. colorType := 6. bytesPerScanline := width * 4]. self writeFileSignature. crcStream := (ByteArray new: 1000) writeStream. crcStream resetToStart. self writeIHDRChunkOn: crcStream. self writeChunk: crcStream. form depth <= 8 ifTrue: [crcStream resetToStart. self writePLTEChunkOn: crcStream. self writeChunk: crcStream. form isColorForm ifTrue: [crcStream resetToStart. self writeTRNSChunkOn: crcStream. self writeChunk: crcStream]]. form depth = 16 ifTrue: [crcStream resetToStart. self writeSBITChunkOn: crcStream. self writeChunk: crcStream]. crcStream resetToStart. self writeIDATChunkOn: crcStream. self writeChunk: crcStream. crcStream resetToStart. self writeIENDChunkOn: crcStream. self writeChunk: crcStream! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! copyPixelsRGBA: y at: startX by: incX "Handle interlaced RGBA color modes (colorType = 6)" | i pixel tempForm tempBits | tempForm := Form extent: width @ 1 depth: 32. tempBits := tempForm bits. pixel := LargePositiveInteger new: 4. bitsPerChannel = 8 ifTrue: [ i := (startX // incX << 2) + 1. startX to: width - 1 by: incX do: [ :x | pixel at: 4 put: (thisScanline at: i + 3); at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i + 1); at: 1 put: (thisScanline at: i + 2). tempBits at: x + 1 put: pixel. i := i + 4 ] ] ifFalse: [ i := (startX // incX << 3) + 1. startX to: width - 1 by: incX do: [ :x | pixel at: 4 put: (thisScanline at: i + 6); at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i + 2); at: 1 put: (thisScanline at: i + 4). tempBits at: x + 1 put: pixel. i := i + 8 ] ]. tempForm displayOn: form at: 0 @ y rule: Form paintAlpha! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'StephaneDucasse 10/25/2013 16:18'! copyPixelsGrayAlpha: y "Handle non-interlaced grayscale with alpha color mode (colorType = 4)" | i pixel gray b | b := BitBlt bitPokerToForm: form. bitsPerChannel = 8 ifTrue: [ 0 to: width - 1 do: [ :x | i := (x << 1) + 1. gray := thisScanline at: i. pixel := ((thisScanline at: i + 1) << 24) + (gray << 16) + (gray << 8) + gray. b pixelAt: x @ y put: pixel ] ] ifFalse: [ 0 to: width - 1 do: [ :x | i := (x << 2) + 1. gray := thisScanline at: i. pixel := ((thisScanline at: i + 2) << 24) + (gray << 16) + (gray << 8) + gray. b pixelAt: x @ y put: pixel ] ]! ! !PNGReadWriter methodsFor: 'writing' stamp: 'nice 1/5/2010 15:59'! writePLTEChunkOn: aStream "Write the PLTE chunk" | colors | aStream nextPutAll: 'PLTE' asByteArray. (form isColorForm) ifTrue:[colors := form colors] ifFalse:[colors := Color indexedColors copyFrom: 1 to: (1 bitShift: form depth)]. colors do:[:aColor| | r g b | r := (aColor red * 255) truncated. g := (aColor green * 255) truncated. b := (aColor blue * 255) truncated. aStream nextPut: r; nextPut: g; nextPut: b. ].! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'jmv 4/15/2010 10:18'! processTransparencyChunk | red green blue | "Transcript show: ' TRANSPARENCY ',chunk printString." colorType = 0 ifTrue: [ transparentPixelValue := chunk unsignedShortAt: 1 bigEndian: true. palette at: transparentPixelValue put: Color transparent. ^self ]. colorType = 2 ifTrue: [ red := chunk at: 2. green := chunk at: 2. blue := chunk at: 2. transparentPixelValue := 16rFF00 + red << 8 + green << 8 + blue. ^self ]. colorType = 3 ifTrue: [ chunk withIndexDo: [ :alpha :index | palette at: index put: ((palette at: index) alpha: alpha/255) ]. ^self ]. ! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 1/1/1970 21:00'! copyPixelsIndexed: y "Handle non-interlaced indexed color mode (colorType = 3)" | hack hackBlt swizzleHack swizzleBlt scanline hackDepth | scanline := ByteArray new: bytesPerScanline + 3 // 4 * 4. scanline replaceFrom: 1 to: thisScanline size with: thisScanline startingAt: 1. hackDepth := bigEndian ifTrue:[form depth] ifFalse:[form depth negated]. hack := Form extent: width@1 depth: hackDepth bits: scanline. hackBlt := BitBlt toForm: form. hackBlt sourceForm: hack. hackBlt combinationRule: Form over. hackBlt destOrigin: 0@y. hackBlt width: width; height: 1. (form depth < 8 and:[bigEndian not]) ifTrue:[ swizzleHack := Form new hackBits: scanline. swizzleBlt := BitBlt toForm: swizzleHack. swizzleBlt sourceForm: swizzleHack. swizzleBlt combinationRule: Form over. swizzleBlt colorMap: (StandardSwizzleMaps at: form depth). swizzleBlt copyBits. ]. hackBlt copyBits.! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'StephaneDucasse 10/25/2013 16:18'! copyPixelsGray: y at: startX by: incX "Handle interlaced grayscale color mode (colorType = 0)" | offset bits blitter pixPerByte shifts b pixel mask pixelNumber | bitsPerChannel = 16 ifTrue: [ b := BitBlt bitPokerToForm: form. startX to: width - 1 by: incX do: [ :x | b pixelAt: x @ y put: 255 - (thisScanline at: (x // incX << 1) + 1) ]. ^ self ]. offset := y * rowSize + 1. bits := form bits. bitsPerChannel = 8 ifTrue: [ startX to: width - 1 by: incX do: [ :x | | w | w := offset + (x >> 2). b := (3 - (x \\ 4)) * 8. pixel := (thisScanline at: x // incX + 1) << b. mask := (255 << b) bitInvert32. bits at: w put: (((bits at: w) bitAnd: mask) bitOr: pixel) ]. ^ self ]. bitsPerChannel = 1 ifTrue: [ pixPerByte := 8. mask := 1. shifts := #(7 6 5 4 3 2 1 0 ) ]. bitsPerChannel = 2 ifTrue: [ pixPerByte := 4. mask := 3. shifts := #(6 4 2 0 ) ]. bitsPerChannel = 4 ifTrue: [ pixPerByte := 2. mask := 15. shifts := #(4 0 ) ]. blitter := BitBlt current bitPokerToForm: form. pixelNumber := 0. startX to: width - 1 by: incX do: [ :x | | rawByte | rawByte := thisScanline at: pixelNumber // pixPerByte + 1. pixel := rawByte >> (shifts at: pixelNumber \\ pixPerByte + 1) bitAnd: mask. blitter pixelAt: x @ y put: pixel. pixelNumber := pixelNumber + 1 ]! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! copyPixels: y at: startX by: incX "Handle interlaced pixels of supported colorTypes" | s | s := #( #copyPixelsGray:at:by: nil #copyPixelsRGB:at:by: #copyPixelsIndexed:at:by: #copyPixelsGrayAlpha:at:by: nil #copyPixelsRGBA:at:by: ) at: colorType + 1. self perform: s asSymbol with: y with: startX with: incX! ! !PNGReadWriter methodsFor: 'accessing' stamp: 'RAA 11/7/2000 09:20'! debugging ^Debugging == true! ! !PNGReadWriter methodsFor: 'miscellaneous' stamp: 'jmv 4/15/2010 10:19'! grayColorsFor: d "return a color table for a gray image" palette := Array new: 1< (Base64MimeConverter mimeEncode: (bytes contents readStream)) contents ]. " ^{Color red-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E CiHUAAAAGklEQVR4XmO4cwc/YLgz8hWMfAUjX8EIVQAAbnlwLukXXkcAAAAASUVORK5CYII='. Color green-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E CiHUAAAAGUlEQVR4XmPQ1cUPGHRHvoKRr2DkKxihCgBZ3bQBCq5u/AAAAABJRU5ErkJggg=='. Color blue-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E CiHUAAAAGUlEQVR4XmNwc8MPGNxGvoKRr2DkKxihCgCl7xgQRbPxcwAAAABJRU5ErkJggg=='. Color black-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E CiHUAAAAGUlEQVR4XmNgZMQPGBhHvoKRr2DkKxihCgBEmAQBphO0cAAAAABJRU5ErkJggg==' }! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'on 6/10/2008 16:36'! encodeAndDecodeAlpha: original fileName := 'testAlpha', original depth printString,'.png'. self encodeAndDecode: original. self deleteFile.! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! test16BitDisplay self encodeAndDecodeDisplay: 16! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! test2Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 2))! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'nice 1/5/2010 15:59'! decodeColors: colorsAndFiles depth: requiredDepth colorsAndFiles do:[:assoc| | bytes color form | color := assoc key. bytes := Base64MimeConverter mimeDecodeToBytes: assoc value readStream. form := PNGReadWriter formFromStream: bytes. self assert: form depth = requiredDepth. self assert: (form pixelValueAt: 1@1) = (color pixelValueForDepth: requiredDepth). ].! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'nice 1/5/2010 15:59'! encodeColors: colorsAndFiles depth: requiredDepth colorsAndFiles do:[:assoc| | original encoded color ff | color := assoc key. original := Base64MimeConverter mimeDecodeToBytes: assoc value readStream. ff := Form extent: 32@32 depth: requiredDepth. ff fillColor: color. encoded := ByteArray new writeStream. PNGReadWriter putForm: ff onStream: encoded. self assert: (encoded contents = original contents). ].! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nice 1/5/2010 15:59'! encodeAndDecode: original "Make sure that the given form is encoded and decoded correctly" | stream bytes decoded | "encode" stream := ByteArray new writeStream. (PNGReadWriter on: stream) nextPutImage: original; close. bytes := stream contents. self writeEncoded: bytes. "decode" stream := self readEncoded: bytes. decoded := (PNGReadWriter new on: stream) nextImage. decoded display. "compare" self assert: original width = decoded width. self assert: original height = decoded height. self assert: original depth = decoded depth. self assert: original bits = decoded bits. self assert: original class == decoded class. (original isColorForm) ifTrue:[ original colors with: decoded colors do:[:c1 :c2| | maxErr | "we must round here due to encoding errors" maxErr := 1. "max. error for 8bit rgb component" self assert: ((c1 red * 255) truncated - (c2 red * 255) truncated) abs <= maxErr. self assert: ((c1 green * 255) truncated - (c2 green * 255) truncated) abs <= maxErr. self assert: ((c1 blue * 255) truncated - (c2 blue * 255) truncated) abs <= maxErr. self assert: ((c1 alpha * 255) truncated - (c2 alpha * 255) truncated) abs <= maxErr. ]. ].! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'on 6/10/2008 16:36'! encodeAndDecodeColor: aColor depth: aDepth | aForm | fileName := 'testColor', aColor name, aDepth printString,'.png'. aForm := Form extent: 32@32 depth: aDepth. aForm fillColor: aColor. self encodeAndDecode: aForm. self deleteFile. ! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 11:10'! readEncoded: bytes "Answer a ReadStream on the file named by fileName, if possible; else a ReadStream on bytes" fileName ifNil:[^ bytes readStream ]. ^(FileStream oldFileOrNoneNamed: fileName) ifNil: [ Transcript nextPutAll: 'can''t open ', fileName; cr. bytes readStream ]. ! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! testBlue8 self encodeAndDecodeColor: Color blue depth: 8! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'stephane.ducasse 6/14/2008 15:26'! encodeAndDecodeDisplay: depth | form | fileName := 'testDisplay', depth printString,'.png'. form := Form extent: (Display extent min: 560@560) depth: depth. World fullDrawOn: form getCanvas. self encodeAndDecode: form. self deleteFile.! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'! testPngEncodingColors32 self encodeColors: self coloredFiles32 depth: 32.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'StephaneDucasse 6/17/2013 15:54'! deleteFile fileName asFileReference ensureDelete! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:49'! testAlphaCoding self encodeAndDecodeAlpha: (self drawTransparentStuffOn: (Form extent: 33@33 depth: 32))! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'on 6/10/2008 16:36'! encodeAndDecodeForm: original fileName := 'testForm', original depth printString,'.png'. self encodeAndDecode: original. self deleteFile.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 18:18'! encodeAndDecodeStream: file | aForm | file reset. (PNGReadWriter new on: file) understandsImageFormat ifFalse:[^self error: 'don''t understand format!!' ]. file reset. aForm := (PNGReadWriter new on: file) nextImage. aForm ifNil:[^self error: 'nil form' ]. aForm display. self encodeAndDecode: aForm. ! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:44'! test8BitColors self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 8))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! test8BitDisplay self encodeAndDecodeDisplay: 8! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! test32BitDisplay self encodeAndDecodeDisplay: 32! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:43'! test1BitColors self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 1))! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'! testPngEncodingColors16 self encodeColors: self coloredFiles16 depth: 16.! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:56'! test4BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 4))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! test8Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 8))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:43'! test2BitColors self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 2))! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'lr 3/7/2010 12:05'! drawTransparentStuffOn: aForm "Draw stuff on aForm. Avoid any symmetry." | canvas | canvas := FormCanvas on: aForm. canvas frameAndFillRectangle: (1 @ 1 corner: aForm extent - 15) fillColor: (Color red alpha: 0.25) borderWidth: 3 borderColor: (Color green alpha: 0.5). canvas fillOval: (aForm boundingBox topRight - (15 @ -5) extent: 20 @ 20) color: (Color white alpha: 0.75) borderWidth: 1 borderColor: Color blue. ^ aForm "(PNGReadWriterTest new drawStuffOn: (Form extent: 32@32 depth: 16)) display"! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! test32Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 32))! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! testBlue32 self encodeAndDecodeColor: Color blue depth: 32! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! testGreen32 self encodeAndDecodeColor: Color green depth: 32! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'lr 3/7/2010 12:05'! drawStuffOn: aForm "Draw stuff on aForm. Avoid any symmetry." | canvas | canvas := FormCanvas on: aForm. canvas frameAndFillRectangle: (1 @ 1 corner: aForm extent - 15) fillColor: Color red borderWidth: 3 borderColor: Color green. canvas fillOval: (aForm boundingBox topRight - (15 @ -5) extent: 20 @ 20) color: Color blue borderWidth: 1 borderColor: Color white. ^ aForm "(PNGReadWriterTest new drawStuffOn: (Form extent: 32@32 depth: 16)) display"! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! testBlack16 self encodeAndDecodeColor: Color blue depth: 16! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! test16Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 16))! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'StephaneDucasse 2/10/2010 18:54'! writeEncoded: bytes fileName ifNil:[^self]. FileStream forceNewFileNamed: fileName do: [:file | file nextPutAll: bytes]! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:57'! test8BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 8))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:57'! test32BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 32))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! test4Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 4))! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'! testPngEncodingColors8 self encodeColors: self coloredFiles8 depth: 8.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/29/2004 03:55'! encodeAndDecodeWithError: aStream self should:[self encodeAndDecodeStream: aStream] raise: Error! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'! testPngDecodingColors16 self decodeColors: self coloredFiles16 depth: 16.! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:57'! test16BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 16))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:44'! test4BitColors self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 4))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'StephaneDucasse 1/19/2010 22:57'! testPngSuite "Requires the suite from ftp://swrinde.nde.swri.edu/pub/png/images/suite/PngSuite.zip to be present as PngSuite.zip" | file | file := [ FileStream readOnlyFileNamed: 'PngSuite.zip'] on: Error do:[:ex| ex return]. file ifNil:[^self]. [ | zip entries |zip := ZipArchive new readFrom: file. entries := zip members select:[:mbr| mbr fileName asLowercase endsWith: '.png']. entries do:[:mbr| (mbr fileName asLowercase first = $x) ifTrue: [self encodeAndDecodeWithError: mbr contentStream ] ifFalse: [self encodeAndDecodeStream: mbr contentStream ] ]. ] ensure:[file close].! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'! testPngDecodingColors32 self decodeColors: self coloredFiles32 depth: 32.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 11:29'! tearDown World changed.! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! testBlue16 self encodeAndDecodeColor: Color blue depth: 16! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! testGreen16 self encodeAndDecodeColor: Color green depth: 16! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:56'! test2BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 2))! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'! testRed16 self encodeAndDecodeColor: Color red depth: 16! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:25'! coloredFiles16 "Created by {Color red. Color green. Color blue. Color black} collect:[:fillC| | ff bytes | ff := Form extent: 32@32 depth: 16. ff fillColor: fillC. bytes := WriteStream on: ByteArray new. PNGReadWriter putForm: ff onStream: bytes. fillC -> (Base64MimeConverter mimeEncode: (bytes contents readStream)) contents ]. " ^{Color red-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADZJ REFUeF7lziEBAAAMAjD6J8b9MRAT80uT65Af8AN+wA/4AT/gB/yAH/ADfsAP+AE/4AfmgQdc z9xqBS2pdAAAAABJRU5ErkJggg=='. Color green-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ REFUeF7lziEBAAAMAjD6J77jMRAT80sunfIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA68HyT 3Gqf2I6NAAAAAElFTkSuQmCC'. Color blue-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ REFUeF7lziEBAAAMAjD6J77jMRAT80ty3fIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA48JxX 3GpYhihrAAAAAElFTkSuQmCC'. Color black-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ REFUeF7lziEBAAAMAjDk+xfmMRAT80ty3fIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA48LbT HD3MKH3GAAAAAElFTkSuQmCC' }! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nice 1/5/2010 15:59'! encodeAndDecodeReverse: original "Make sure that the given form is encoded and decoded correctly" | stream bytes decoded reversed | fileName := 'testReverse', original depth printString,'.png'. self assert: original class == Form. "won't work with ColorForm" "Switch pixel order" reversed := Form extent: original extent depth: original depth negated. original displayOn: reversed. self assert: original width = reversed width. self assert: original height = reversed height. self assert: original depth = reversed depth. self deny: original nativeDepth = reversed nativeDepth. original depth = 32 ifTrue:[self assert: original bits = reversed bits] ifFalse:[self deny: original bits = reversed bits]. "encode" stream := ByteArray new writeStream. (PNGReadWriter on: stream) nextPutImage: reversed; close. bytes := stream contents. self writeEncoded: bytes. "decode" stream := bytes readStream. decoded := (PNGReadWriter new on: stream) nextImage. decoded display. "compare" self assert: original width = decoded width. self assert: original height = decoded height. self assert: original depth = decoded depth. self assert: original bits = decoded bits. self assert: original class == decoded class. (original isColorForm) ifTrue:[ original colors with: decoded colors do:[:c1 :c2| | maxErr | "we must round here due to encoding errors" maxErr := 1. "max. error for 8bit rgb component" self assert: ((c1 red * 255) truncated - (c2 red * 255) truncated) abs <= maxErr. self assert: ((c1 green * 255) truncated - (c2 green * 255) truncated) abs <= maxErr. self assert: ((c1 blue * 255) truncated - (c2 blue * 255) truncated) abs <= maxErr. self assert: ((c1 alpha * 255) truncated - (c2 alpha * 255) truncated) abs <= maxErr. ]. ]. self deleteFile.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:45'! setUp fileName := nil.! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! test2BitDisplay self encodeAndDecodeDisplay: 2! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'! testRed8 self encodeAndDecodeColor: Color red depth: 8! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'HenrikSperreJohansen 6/6/2010 22:33'! coloredFiles32 "Created by {Color red. Color green. Color blue. Color black} collect:[:fillC| | ff bytes | ff := Form extent: 32@32 depth: 32. ff fillColor: fillC. bytes := WriteStream on: ByteArray new. PNGReadWriter putForm: ff onStream: bytes. fillC -> (Base64MimeConverter mimeEncode: (bytes contents readStream)) contents ]. " ^{ Color red -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANUlEQVR4XuXOIQEAAAwEoe9f +hZjAoFnbfVo+QE/4Af8gB/wA37AD/gBP+AH/IAf8AN+4DlwVA34ajP6EEoAAAAASUVORK5C YII='. Color green -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAAM0lEQVR4XuXOMQ0AAAACIPuX 1hgejAIkPfMDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA7MFfR+Grvv2BdAAAAAElFTkSuQmCC'. Color blue-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANElEQVR4XuXOIQEAAAACIP+f 1hkGAp0k7Zcf8AN+wA/4AT/gB/yAH/ADfsAP+AE/4AfOgQFblfhqnnPWHAAAAABJRU5ErkJg gg=='. Color black -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANklEQVR4XuXOsQ0AAAzCMP5/ uvQLBkfK7nw33gf4AB/gA3yAD/ABPsAH+AAf4AN8gA/wAVtAAbe1/C5AK87lAAAAAElFTkSu QmCC' }! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'! testPngDecodingColors8 self decodeColors: self coloredFiles8 depth: 8.! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! test4BitDisplay self encodeAndDecodeDisplay: 4! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 01:56'! test1BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 1))! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! testBlack8 self encodeAndDecodeColor: Color blue depth: 8! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'! testGreen8 self encodeAndDecodeColor: Color green depth: 8! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:50'! test1Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 1))! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! testBlack32 self encodeAndDecodeColor: Color blue depth: 32! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:48'! testRed32 self encodeAndDecodeColor: Color red depth: 32! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'PeterHugossonMiller 9/3/2009 10:12'! encodeAndDecodeWithColors: aColorForm "Screw around with aColorForm colors" | colors nColors indexedColors max myRandom | fileName := 'testColors', aColorForm depth printString,'.png'. indexedColors := Color indexedColors. nColors := 1 bitShift: aColorForm depth. colors := Array new writeStream. "Make first half translucent" max := nColors // 2. 1 to: max do:[:i| colors nextPut: ((indexedColors at: i) alpha: i / max asFloat). ]. "Make random choices for second half" myRandom := Random seed: 42315. max to: nColors do:[:i| colors nextPut: (indexedColors atRandom: myRandom). ]. self deleteFile. ! ! !POP3Client commentStamp: 'mir 5/12/2003 17:57'! This class implements POP3 (Post Office Protocol 3) as specified in RFC 1939. (see http://www.ietf.org/rfc.html) You can use it to download email from the mail server to your personal mail program. To see an example of it's use, see POPSocket class>>example.! !POP3Client methodsFor: 'private testing' stamp: 'mir 11/11/2002 15:44'! responseIsWarning ^self lastResponse beginsWith: '-'! ! !POP3Client methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:43'! responseIsError ^self lastResponse beginsWith: '-'! ! !POP3Client methodsFor: 'private protocol' stamp: 'mir 4/7/2003 17:38'! clearTextLogin [self sendCommand: 'USER ', self user. self checkResponse. self logProgress: self lastResponse. self sendCommand: 'PASS ', self password. self checkResponse. self logProgress: self lastResponse] on: TelnetProtocolError do: [:ex | "Neither authentication worked. Indicate an error and close up" self close. ex resignalAs: ((LoginFailedException protocolInstance: self) signal: 'Login failed.')]! ! !POP3Client methodsFor: 'private' stamp: 'mir 3/8/2002 11:41'! loginMethod: aSymbol ^self connectionInfo at: #loginMethod put: aSymbol! ! !POP3Client methodsFor: 'private' stamp: 'mir 11/11/2002 16:20'! loginMethod ^self connectionInfo at: #loginMethod ifAbsent: [nil]! ! !POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:35'! deleteMessage: num "delete the numbered message" self ensureConnection. self sendCommand: 'DELE ', num printString. self checkResponse. self logProgress: self lastResponse! ! !POP3Client methodsFor: 'private protocol' stamp: 'mir 4/7/2003 17:39'! login self loginMethod ifNil: [^self]. self loginMethod == #clearText ifTrue: [^self clearTextLogin]. self loginMethod == #APOP ifTrue: [^self apopLogin]. (POP3LoginError protocolInstance: self) signal: 'Unsupported login procedure.'! ! !POP3Client methodsFor: 'public protocol' stamp: 'nice 1/5/2010 15:59'! messageCount "Query the server and answer the number of messages that are in the user's mailbox." | numMessages | self ensureConnection. self sendCommand: 'STAT'. self checkResponse. self logProgress: self lastResponse. [ | answerString |answerString := (self lastResponse findTokens: Character separators) second. numMessages := answerString asNumber asInteger] on: Error do: [:ex | (ProtocolClientError protocolInstance: self) signal: 'Invalid STAT response.']. ^numMessages! ! !POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:35'! retrieveMessage: number "retrieve the numbered message" self ensureConnection. self sendCommand: 'RETR ', number printString. self checkResponse. self logProgress: self lastResponse. ^self getMultilineResponse! ! !POP3Client methodsFor: 'public protocol' stamp: 'len 12/14/2002 17:50'! quit "QUIT " self sendCommand: 'QUIT'. self checkResponse.! ! !POP3Client methodsFor: 'public protocol' stamp: 'mir 3/8/2002 11:40'! loginUser: userName password: password loginMethod: aLoginMethod self user: userName. self password: password. self loginMethod: aLoginMethod. self login! ! !POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:57'! loginUser: userName password: password self loginUser: userName password: password loginMethod: #clearText! ! !POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:58'! apopLoginUser: userName password: password self loginUser: userName password: password loginMethod: #APOP! ! !POP3Client methodsFor: 'private protocol' stamp: 'CamilloBruni 5/25/2012 18:19'! apopLogin "Attempt to authenticate ourselves to the server without sending the password as cleartext." "For secure authentication, we look for a timestamp in the initial response string we get from the server, and then try the APOP command as specified in RFC 1939. If the initial response from the server is +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us> we extract the timestamp <1896.697170952@dbc.mtview.ca.us> then form a string of the form <1896.697170952@dbc.mtview.ca.us>USERPASSWORD and then send only the MD5 hash of that to the server. Thus the password never hits the wire" [ | hash timestamp | "Look for a timestamp in the response we received from the server" timestamp := self lastResponse findTokens: '<>' includes: '@'. timestamp ifNil: [ (POP3LoginError protocolInstance: self) signal: 'APOP not supported.' ]. (Smalltalk globals includesKey: #MD5) ifTrue: [ hash := ((Smalltalk globals at: #MD5) hashMessage: '<' , timestamp , '>' , self password) storeStringHex asLowercase. "trim starting 16r and zero pad it to 32 characters if needed" hash := hash padLeftTo: 32 with: $0 ] ifFalse: [ (POP3LoginError protocolInstance: self) signal: 'APOP (MD5) not supported.' ]. self sendCommand: 'APOP ' , self user , ' ' , hash. self checkResponse. self logProgress: self lastResponse ] on: ProtocolClientError do: [ :ex | self close. (LoginFailedException protocolInstance: self) signal: 'Login failed.' ]! ! !POP3Client methodsFor: 'private protocol' stamp: 'PeterHugossonMiller 9/3/2009 10:12'! getMultilineResponse "Get a multiple line response to the last command, filtering out LF characters. A multiple line response ends with a line containing only a single period (.) character." | response done chunk | response := String new writeStream. done := false. [done] whileFalse: [ chunk := self stream nextLine. (chunk beginsWith: '.') ifTrue: [response nextPutAll: (chunk copyFrom: 2 to: chunk size); cr ] ifFalse: [response nextPutAll: chunk; cr ]. done := (chunk = '.') ]. ^ response contents ! ! !POP3Client class methodsFor: 'accessing' stamp: 'mir 3/7/2002 12:51'! defaultPortNumber ^110! ! !POP3Client class methodsFor: 'example' stamp: 'rbb 3/1/2005 11:05'! example "POP3Client example" "download a user's messages into an OrderedCollection and inspect the OrderedCollection" | ps messages userName password | userName := (UIManager default request: 'POP username'). password := (UIManager default request: 'POP password'). ps := POP3Client openOnHostNamed: (UIManager default request: 'POP server'). [ ps loginUser: userName password: password. ps logProgressToTranscript. messages := OrderedCollection new. 1 to: ps messageCount do: [ :messageNr | messages add: (ps retrieveMessage: messageNr) ]] ensure: [ps close]. messages inspect.! ! !POP3Client class methodsFor: 'accessing' stamp: 'mir 3/7/2002 12:52'! logFlag ^#pop! ! !POP3LoginError commentStamp: 'mir 5/12/2003 17:58'! Exception for signaling POP3 login failures.! !PSMCChangeWrapper methodsFor: 'accessing' stamp: 'gvc 10/30/2006 11:22'! operation "Answer the underlying operation." self subclassResponsibility ! ! !PSMCChangeWrapper methodsFor: 'testing' stamp: 'gvc 7/6/2007 14:41'! isConflict "Answer whether the receiver is a conflict item." ^false! ! !PSMCChangeWrapper methodsFor: 'accessing' stamp: 'gvc 1/14/2009 12:42'! actualClass "Answer the class represented in the receiver." ^(self operation ifNil: [^nil]) targetClass! ! !PSMCChangeWrapper methodsFor: 'accessing' stamp: 'IgorStasenko 6/24/2011 17:29'! preferredColor | op | op := self operation. op ifNil: [ ^ nil ]. (op isConflict and: [ op isResolved not ] ) ifTrue: [ ^ Color red ]. op remoteChosen ifFalse: [ ^ Color gray ]. ^ nil "use default color "! ! !PSMCChangeWrapper methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:44'! model: anObject "Set the model." model := anObject! ! !PSMCChangeWrapper methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/19/2013 13:11'! icon "Answer a form with an icon to represent the receiver" |o| o := self operation. o isNil ifTrue: [^ Smalltalk ui icons changeEmptyIcon ]. o isAddition ifTrue: [^ Smalltalk ui icons changeAddIcon ]. o isRemoval ifTrue: [^ Smalltalk ui icons changeRemoveIcon ]. ^ Smalltalk ui icons changeUpdateIcon! ! !PSMCClassChangeWrapper methodsFor: 'accessing' stamp: 'GabrielOmarCotelli 11/30/2013 16:18'! operation "Answer the patch operation for the class itself or nil if none." ^ self model detect: [ :i | i targetClassName = self item and: [ i definition isClassDefinition ] ] ifNone: [ nil ]! ! !PSMCClassChangeWrapper methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 16:18'! isConflict "Answer whether the receiver is a conflict item." | op | op := self operation. ^ op notNil and: [op isConflict ]! ! !PSMCClassChangeWrapper methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 16:18'! localChosen "Answer whether the local version is chosen." ^self operation localChosen! ! !PSMCClassChangeWrapper methodsFor: 'choosing' stamp: 'StephaneDucasse 6/24/2011 16:22'! chooseLocal "Choose the local version." self operation chooseLocal! ! !PSMCClassChangeWrapper methodsFor: 'accessing' stamp: 'lr 3/14/2010 21:13'! actualClass "Answer the class represented in the receiver." ^ super actualClass ifNil: [ Smalltalk globals classNamed: self item ]! ! !PSMCClassChangeWrapper methodsFor: 'accessing' stamp: 'gvc 4/1/2009 13:30'! gatherContents "Answer the contents of the change from the model." ^((self model select: [:i | i targetClassName = self item and: [ i definition isClassDefinition not]]) collect: [:o | o patchWrapper model: self model]) asSortedCollection: [:a :b | a asString <= b asString]! ! !PSMCClassChangeWrapper methodsFor: 'choosing' stamp: 'StephaneDucasse 6/24/2011 16:22'! clearChoice "Choose neither version (be in conflict)." self operation clearChoice! ! !PSMCClassChangeWrapper methodsFor: 'testing' stamp: 'gvc 7/6/2007 15:42'! remoteChosen "Answer whether the remote version is chosen." ^self conflict remoteChosen! ! !PSMCClassChangeWrapper methodsFor: 'choosing' stamp: 'StephaneDucasse 6/24/2011 16:22'! chooseRemote "Choose the remote version." self operation chooseRemote! ! !PSMCClassChangeWrapper methodsFor: 'accessing' stamp: 'gvc 4/1/2009 13:30'! contents "Answer the contents of the change." ^contents ifNil: [contents := self gatherContents]! ! !PSMCClassChangeWrapper methodsFor: 'accessing' stamp: 'CamilloBruni 9/19/2013 19:43'! icon "Answer a form with an icon to represent the receiver" self isConflict ifTrue: [ self localChosen ifTrue: [ ^ Smalltalk ui icons changeBlockIcon ]]. ^ super icon! ! !PSMCMergeMorph commentStamp: ''! A PSMCMergeMorph is a graphical tool to navigate changes and select changes in case of conflicts.! !PSMCMergeMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/4/2010 16:49'! initialColorInSystemWindow: aSystemWindow "Answer the colour the receiver should be when added to a SystemWindow." ^Color transparent! ! !PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! codeMorph "Answer the value of codeMorph" ^ codeMorph! ! !PSMCMergeMorph methodsFor: 'actions' stamp: 'gvc 1/9/2009 15:43'! cancel "Delete the window to cancel." self window delete! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2009 17:12'! compositeText: aString "Save the new method text for the selected method. Yet to be implemented." UIManager default inform: 'Saving of replacement methods is not yet imlemented.'! ! !PSMCMergeMorph methodsFor: 'instance-creation' stamp: 'gvc 1/29/2009 12:43'! newButtonsMorph "Answer a new buttons morph." ^(self newRow: { self newConflictsButton. self newToolSpacer hResizing: #spaceFill. self newMergeButton. self newCancelButton}) removeProperty: #fillStyle; listCentering: #bottomRight; layoutInset: 4! ! !PSMCMergeMorph methodsFor: 'instance-creation' stamp: 'gvc 11/1/2006 11:53'! newCodeMorph "Answer a new code morph." ^(self newTextEditorFor: self getText: #compositeText setText: #compositeText: getEnabled: nil) wrapFlag: false; setText: ''! ! !PSMCMergeMorph methodsFor: 'initialization' stamp: 'IgorStasenko 12/19/2012 17:35'! initialize "Initialize the receiver." |buttons buttonsHeight| super initialize. buttons := self newButtonsMorph. buttonsHeight := buttons minExtent y. self merged: false; patchMorph: self newPatchMorph; codeMorph: self newCodeMorph; changeProportionalLayout; addMorph: self patchMorph fullFrame: (0@0 corner: 1@0.6) asLayoutFrame ; addMorph: self codeMorph fullFrame: ((0@0.6 corner: 1@1) asLayoutFrame bottomOffset: buttonsHeight negated); addMorph: self newButtonsMorph fullFrame: ((0@1 corner: 1@1) asLayoutFrame topOffset: buttonsHeight negated); addPaneSplitters! ! !PSMCMergeMorph methodsFor: 'instance-creation' stamp: 'gvc 1/29/2009 12:54'! newConflictsButton "Answer a new button for displaying the count of outstanding conflicts and navigating to each. It will be disabled if all conflicts are resolved." ^(self newButtonFor: self getState: nil action: #selectNextConflict arguments: #() getEnabled: #notAllConflictsResolved getLabel: #conflictCountString help: 'Select the next conflict in the tree' translated) vResizing: #spaceFill "workaround until table layout fixed"! ! !PSMCMergeMorph methodsFor: 'actions' stamp: 'gvc 1/9/2009 15:44'! merge "Do the merge and close if no conflicts." ^self model isMerged ifTrue: [self merged: true. self window delete] ifFalse: [self inform: 'You must resolve all conflicts first.' translated]! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:46'! notAllConflictsResolved "Answer whether any conflicts are unresolved." ^self allConflictsResolved not! ! !PSMCMergeMorph methodsFor: 'instance-creation' stamp: 'gvc 11/1/2006 14:26'! newPatchMorph "Answer a new patch morph." ^PSMCMergePatchMorph new borderWidth: 0; addDependent: self; yourself! ! !PSMCMergeMorph methodsFor: 'actions' stamp: 'gvc 11/1/2006 11:53'! compositeText "Answer the composite text from the patch morph." ^self patchMorph compositeText! ! !PSMCMergeMorph methodsFor: 'instance-creation' stamp: 'gvc 1/29/2009 12:42'! newMergeButton "Answer a new button for performing the merge. It will be disabled if any conflicts are unresolved." ^self newButtonFor: self action: #merge getEnabled: #allConflictsResolved label: 'Merge' translated help: 'Merge the version into the image' translated! ! !PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! patchMorph "Answer the value of patchMorph" ^ patchMorph! ! !PSMCMergeMorph methodsFor: 'updating' stamp: 'gvc 1/29/2009 13:22'! update: aspect "A join has probably changed its selection state." super update: aspect. aspect == #compositeText ifTrue: [self updateCode]. aspect == #changes ifTrue: [self changed: #conflictCountString; changed: #allConflictsResolved; changed: #notAllConflictsResolved]! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 11:54'! updateCode "Update the code morph to match selected differences." self changed: #compositeText! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 09:47'! defaultTitle "Answer the default title label for the receiver." ^'Merge' translated! ! !PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2009 17:42'! merged "Answer the value of merged. Indicates whether the merge button was pressed with no conflicts remaining." ^ merged! ! !PSMCMergeMorph methodsFor: 'actions' stamp: 'gvc 2/3/2010 16:05'! fromDescription: aString "Set the description for the left-hand side of the merge, typically 'currently in image'." self patchMorph fromDescription: aString! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:50'! conflictCountString "Answer a string describing the number of conflicts." |count| count := self conflictCount. ^count = 1 ifTrue: ['1 conflict' translated] ifFalse: ['{1} conflicts' translated format: {count}]! ! !PSMCMergeMorph methodsFor: 'actions' stamp: 'gvc 2/3/2010 16:05'! toDescription: aString "Set the description for the right-hand side of the merge, typically 'incoming'." self patchMorph toDescription: aString! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:52'! conflictCount "Answer the number of conflicts that are unresolved." ^(self model ifNil: [^0]) conflicts count: [:c | c isResolved not]! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/9/2009 15:18'! allConflictsResolved "Answer whether all conflicts were resolved." ^(self model ifNil: [^false]) isMerged! ! !PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! patchMorph: anObject "Set the value of patchMorph" patchMorph := anObject! ! !PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! codeMorph: anObject "Set the value of codeMorph" codeMorph := anObject! ! !PSMCMergeMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 6/24/2011 15:08'! model: aMerger "Set the model and update the window." |grouped sorted| super model: aMerger. grouped := aMerger operations groupBy: [:o | o targetClassName ifNil: [o shortSummary]] having: [:g | true]. sorted := OrderedCollection new. grouped keys asSortedCollection do: [:k | sorted addAll: ((grouped at: k) asSortedCollection: [:a :b | a shortSummary <= b shortSummary])]. self patchMorph model: sorted! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:57'! selectNextConflict "Select the next conflict in the tree." self patchMorph selectNextConflict! ! !PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2009 17:42'! merged: anObject "Set the value of merged" merged := anObject! ! !PSMCMergeMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 10:31'! forMerger: aMerger "Answer a new instance of the receiver with the given merger as the model." ^ self new model: aMerger! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2009 14:06'! updateSource "Update the source difference morph." |sel| sel := self selectedChangeWrapper. self diffMorph allowJoinClicks: (sel notNil and: [ sel isConflict and: [sel operation isModification]]). super updateSource. (sel isNil or: [sel isConflict not]) ifTrue: [^self]. sel localChosen ifTrue: [self diffMorph indicateSrc] ifFalse: [self diffMorph indicateDst]! ! !PSMCMergePatchMorph methodsFor: 'hooks' stamp: 'gvc 11/1/2006 14:25'! diffMorphClass "Answer a the class to use for a new diff morph." ^MergeDiffMorph! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/25/2010 10:18'! keepAllCurrentVersion "Mark all conflicts as local." self allConflicts do: [:c | c chooseLocal]. self changed: #changes. self updateSource! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! allConflictsMenu "Answer the all conflicts menu." |menu| menu := UIManager default newMenuIn: self for: self. menu addToggle: 'Keep current version of all' translated target: self selector: #keepAllCurrentVersion getStateSelector: nil enablementSelector: #hasAnyNonKeptConflicts. menu lastItem font: self theme menuFont; icon: Smalltalk ui icons smallBackIcon; keyText: 'Shift+Cmd+c'. menu addToggle: 'Use incoming version of all' translated target: self selector: #useAllIncomingVersion getStateSelector: nil enablementSelector: #hasAnyNonIncomingConflicts. menu lastItem font: self theme menuFont; icon: Smalltalk ui icons smallForwardIcon; keyText: 'Shift+Cmd+g'. menu addToggle: 'Mark all as conflict' translated target: self selector: #markAllAsConflict getStateSelector: nil enablementSelector: #hasAnyNonConflictConflicts. menu lastItem font: self theme menuFont; icon: Smalltalk ui icons smallCancelIcon; keyText: 'Shift+Cmd+x'. ^menu! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 6/24/2011 16:08'! changeTreeKey: aCharacter "Handle change tree key strokes." super changeTreeKey: aCharacter. (aCharacter == $a and: [ self selectionIsNotNil]) ifTrue: [ ^ self toggleApplySelectedChange. ]. (aCharacter == $c and: [self selectionIsNotNil]) ifTrue: [ ^self keepCurrentVersion]. (aCharacter == $g and: [self selectionIsNotNil]) ifTrue: [ ^self useIncomingVersion]. (aCharacter == $x and: [self selectionIsNotNil]) ifTrue: [ ^self markAsConflict]. (aCharacter == $f and: [self notAllConflictsResolved]) ifTrue: [ ^self selectNextConflict]. (aCharacter == $C and: [self hasAnyNonKeptConflicts]) ifTrue: [ ^self keepAllCurrentVersion]. (aCharacter == $G and: [self hasAnyNonIncomingConflicts]) ifTrue: [ ^self useAllIncomingVersion]. (aCharacter == $X and: [self hasAnyNonConflictConflicts]) ifTrue: [ ^self markAllAsConflict]! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/25/2010 10:17'! markAllAsConflict "Mark all conflicts as unresolved." self allConflicts do: [:c | c clearChoice]. self changed: #changes. self updateSource! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/25/2010 10:21'! allConflicts "Answer all conflicts in the model." ^self model select: [:op | op isConflict]! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/25/2010 13:51'! hasAnyNonConflictConflicts "Answer whether there are any conflicts not marked as a conflict." ^self allConflicts anySatisfy: [:conflict | conflict isResolved]! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/25/2010 13:38'! hasConflicts "Answer whether there are any conflicts." ^self allConflicts notEmpty! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 6/22/2011 17:51'! selectionIsNotNil ^ self selectedChange notNil! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 6/24/2011 17:28'! toggleApplySelectedChange self selectedChange remoteChosen ifTrue: [ self selectedChange chooseLocal ] ifFalse: [ self selectedChange chooseRemote ]. self changed: #changes. self updateSource! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 6/24/2011 17:30'! selectionIsRemoteChosen self selectedChange ifNil: [ ^ false]. ^ self selectedChange remoteChosen! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/9/2010 14:18'! nextConflict "Answer the next (unresolved) conflict or, nil if none." |coll current index| current := self selectedChangeWrapper. index := current isNil ifTrue: [0] ifFalse: [self model indexOf: current item]. coll := (self model copyFrom: index + 1 to: self model size), (self model copyFrom: 1 to: index). ^coll detect: [:item | item isConflict and: [item isResolved not]] ifNone: [nil]! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:46'! useIncomingVersion "Mark the conflict as remote." self selectedChangeWrapper chooseRemote. self changed: #changes. self updateSource! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/25/2010 10:18'! useAllIncomingVersion "Mark all conflicts as remote." self allConflicts do: [:c | c chooseRemote]. self changed: #changes. self updateSource! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 6/24/2011 16:07'! markAsConflict "Mark the operation as unresolved conflict." self selectedChangeWrapper operation beConflict. self changed: #changes. self updateSource.! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/25/2010 13:51'! hasAnyNonKeptConflicts "Answer whether there are any conflicts not marked as keep." ^self allConflicts anySatisfy: [:conflict | conflict isResolved not or: [conflict remoteChosen]]! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 7/6/2007 15:46'! keepCurrentVersion "Mark the conflict as local." self selectedChangeWrapper chooseLocal. self changed: #changes. self updateSource! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 4/2/2009 13:03'! selectNextConflict "Select the next conflict after the current selection, if any." |next op def path| next := self nextConflict ifNil: [^self]. op := next operation. def := next remoteDefinition ifNil: [next localDefinition]. path := {#changes. #openPath}. def isMethodDefinition ifTrue: [path := path, {def fullClassName}]. path := path, {op shortSummary}. self changed: path! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 14:26'! notAllConflictsResolved "Answer whether any conflicts are unresolved." ^self model anySatisfy: [:item | item isConflict and: [item isResolved not]]! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! changesMenu: m "Answer the changes menu." |menu| menu := super changesMenu: m. menu addLine. menu addToggle: 'Apply this change' translated target: self selector: #toggleApplySelectedChange getStateSelector: #selectionIsRemoteChosen enablementSelector: #selectionIsNotNil. menu addToggle: 'Keep current version' translated target: self selector: #keepCurrentVersion getStateSelector: nil enablementSelector: #selectionIsNotNil. menu lastItem font: self theme menuFont; icon: Smalltalk ui icons smallBackIcon; keyText: 'Cmd+c'. menu addToggle: 'Use incoming version' translated target: self selector: #useIncomingVersion getStateSelector: nil enablementSelector: #selectionIsNotNil. menu lastItem font: self theme menuFont; icon: Smalltalk ui icons smallForwardIcon; keyText: 'Cmd+g'. menu addToggle: 'Mark as conflict' translated target: self selector: #markAsConflict getStateSelector: nil enablementSelector: #selectionIsNotNil. menu lastItem font: self theme menuFont; icon: Smalltalk ui icons smallCancelIcon; keyText: 'Cmd+x'. menu addToggle: 'All conflicts' translated target: self selector: nil getStateSelector: nil enablementSelector: #hasConflicts. menu lastItem font: self theme menuFont; subMenu: self allConflictsMenu. menu addLine. menu addToggle: 'Select next conflict' translated target: self selector: #selectNextConflict getStateSelector: nil enablementSelector: #notAllConflictsResolved. menu lastItem font: self theme menuFont; icon: Smalltalk ui icons smallRightFlushIcon; keyText: 'Cmd+f'. ^menu! ! !PSMCMergePatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/25/2010 13:50'! hasAnyNonIncomingConflicts "Answer whether there are any conflicts not marked as incoming." ^self allConflicts anySatisfy: [:conflict | conflict isResolved not or: [conflict localChosen]]! ! !PSMCPatchMorph commentStamp: 'LaurentLaffont 2/23/2011 20:21'! I'm a Monticello tool based on polymorph used to browse diffs. Activate me with the setting named 'Use Polymorph difference tools'.! !PSMCPatchMorph methodsFor: 'initialization' stamp: 'gvc 10/30/2006 11:08'! model: aCollection "Set the model and update the window." super model: aCollection. self changed: #changes! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 9/14/2013 16:29'! changes "Answer the changes tree roots." |changes classes| self model ifNil: [^#()]. changes := OrderedCollection new. classes := Set new. self model do: [:o | o definition isOrganizationDefinition ifTrue: [changes add: (o patchWrapper model: self model)] ifFalse: [ o targetClassName notNil ifTrue:[ (classes includes: o targetClassName) ifFalse: [classes add: o targetClassName. changes add: (PSMCClassChangeWrapper with: o targetClassName model: self model)]]]]. ^(changes reject: [:e | e isKindOf: PSMCClassChangeWrapper]) , ((changes select: [:e | e isKindOf: PSMCClassChangeWrapper]) sorted: [:a :b | a item <= b item])! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 12:47'! browseImplementors "Browse the method implementors." self systemNavigation browseAllImplementorsOf: (self selectedMessageName ifNil: [^self])! ! !PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 11/1/2006 12:18'! selectedChangeWrapper: aWrapper "Set the selected change." selectedChangeWrapper := aWrapper. self changed: #selectedChangeWrapper; updateSource; changed: #compositeText! ! !PSMCPatchMorph methodsFor: 'updating' stamp: 'gvc 10/30/2006 15:30'! update: aspect "A join has probably changed its selection state." super update: aspect. aspect == #selectedDifferences ifTrue: [self changed: #compositeText]! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/22/2010 17:57'! changeTreeKey: aCharacter "Handle change tree key strokes." (aCharacter == $b and: [self selectionHasAcutalClass]) ifTrue: [ ^self browseClass]. (aCharacter == $v and: [self selectionIsMethodChange]) ifTrue: [ ^self browseVersions]. (aCharacter == $m and: [self selectionIsMethodChange]) ifTrue: [ ^self browseImplementors]. (aCharacter == $n and: [self selectionIsMethodChange]) ifTrue: [ ^self browseSenders]! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 1/21/2012 22:56'! browseVersions "Browse the method versions." | aClass aSelector | aClass := self selectedChangeWrapper actualClass. aSelector := self selectedMessageName ifNil: [^self]. Smalltalk tools versionBrowser browseVersionsForClass: aClass selector: aSelector ! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/22/2010 17:52'! newChangeTreeMorph "Answer a new morph for the tree of changes." ^(self newTreeFor: self list: #changes selected: #selectedChangeWrapper changeSelected: #selectedChangeWrapper:) getMenuSelector: #changesMenu:; keystrokeActionSelector: #changeTreeKey:! ! !PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:18'! defaultTitle "Answer the default title label for the receiver." ^'Changes' translated! ! !PSMCPatchMorph methodsFor: 'updating' stamp: 'CamilloBruni 9/14/2013 16:35'! expandChangeTree self flag: #TODO. "We should only expand the nodes wich have partial changes, if a class was added or removed there is no need to show the complete tree expanded" self changeTree expandAll.! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 1/11/2012 22:53'! selectionIsMethodChange "Answer whether the currently selected change is for a method." ^self selectedChange notNil and: [ self selectedChange definition isMethodDefinition and: [ self selectedChange definition isLoadable ] ]! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 2/8/2012 17:09'! browseClass "Browse the class of the selected item." ^ Smalltalk tools browser fullOnClass: self selectedChangeWrapper actualClass selector: self selectedMessageName! ! !PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 1/29/2009 13:17'! changeTree "Answer the value of changeTree" ^ changeTree! ! !PSMCPatchMorph methodsFor: 'initialization' stamp: 'CamilloBruni 9/14/2013 16:29'! initialize "Initialize the receiver." |descriptionHeight| super initialize. self diffMorph: self newDiffMorph; changeTree: self newChangeTreeMorph; descriptionMorph: self newDescriptionMorph. descriptionHeight := self descriptionMorph minExtent y. self changeProportionalLayout; addMorph: self descriptionMorph fullFrame: ((0.3@0 corner: 1@0) asLayoutFrame leftOffset: ProportionalSplitterMorph splitterWidth; bottomOffset: descriptionHeight); addMorph: self changeTree fullFrame: (0@0 corner: 0.3@1) asLayoutFrame; addMorph: self diffMorph fullFrame: ((0.3@0 corner: 1@1) asLayoutFrame topLeftOffset: ProportionalSplitterMorph splitterWidth @ descriptionHeight); addPaneSplitters. self updateDescriptionFillStyle: self paneColor. self splitters first delete. self onAnnouncement: MorphOpened do: [ self expandChangeTree ] ! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/26/2006 15:52'! selectedMessageName "Answer the method selector or nil if no method change is selected.." ^self selectionIsMethodChange ifTrue: [self selectedChange definition selector] ! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 10/13/2013 07:57'! browseSenders "Browse the method senders." self systemNavigation browseAllSendersOf: (self selectedMessageName ifNil: [^self])! ! !PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 11:58'! selectedChange "Answer the selected change." ^(self selectedChangeWrapper ifNil: [^nil]) operation! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 12/2/2013 14:14'! selectionHasAcutalClass "Answer whether the currently selected change has an actual class in the image." ^self selectedChangeWrapper ifNil: [false] ifNotNil: [:w | w actualClass notNil]! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 8/15/2010 11:38'! loadMethodSelection "Install the selected change" self selectedChange ifNil: [ ^self ]. self selectedChange definition load.! ! !PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 11:57'! selectedChangeWrapper "Answer the selected change." ^selectedChangeWrapper! ! !PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 1/29/2009 13:17'! changeTree: anObject "Set the value of changeTree" changeTree := anObject! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 13:28'! updateSource "Update the source difference morph." |sel| sel := self selectedChange. sel isNil ifTrue: [self diffMorph from: '' to: ''] ifFalse: [self diffMorph from: sel diffFromSource to: sel diffToSource contextClass: (sel isClassPatch ifTrue: [nil] ifFalse: [sel targetClass])]! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! changesMenu: m "Answer the changes menu." |menu| menu := self newMenu addTitle: 'Changes' icon: Smalltalk ui icons smallCopyIcon. menu addToggle: 'Browse class...' translated target: self selector: #browseClass getStateSelector: nil enablementSelector: #selectionHasAcutalClass. menu lastItem font: self theme menuFont; icon: Smalltalk tools browser taskbarIcon; keyText: 'Cmd+b'. menu addLine. menu addToggle: 'Versions...' translated target: self selector: #browseVersions getStateSelector: nil enablementSelector: #selectionIsMethodChange. menu lastItem font: self theme menuFont; icon: Smalltalk ui icons smallJustifiedIcon; keyText: 'Cmd+v'. menu addToggle: 'Senders...' translated target: self selector: #browseSenders getStateSelector: nil enablementSelector: #selectionIsMethodChange. menu lastItem font: self theme menuFont; icon: Smalltalk ui icons smallForwardIcon; keyText: 'Cmd+n'. menu addToggle: 'Implementors...' translated target: self selector: #browseImplementors getStateSelector: nil enablementSelector: #selectionIsMethodChange. menu lastItem font: self theme menuFont; icon: Smalltalk ui icons smallDoItIcon; keyText: 'Cmd+m'. menu addToggle: 'Install incoming version' translated target: self selector: #loadMethodSelection getStateSelector: nil enablementSelector: #selectionIsMethodChange. menu lastItem font: self theme menuFont; icon: Smalltalk ui icons smallUpdateIcon. menu add: 'Expand All' translated target: self model selector: #expandAll. menu add: 'Collapse All' translated target: self model selector: #collapseAll. ^menu! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 12:02'! compositeText "Answer the composite text based on the selection state of the joins." ^self diffMorph compositeText! ! !PSMCPatchMorph class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallForwardIcon! ! !PSMCPatchMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 2/9/2010 14:03'! usedByDefault: aBoolean "Specify whether the Polymorph diff tools should be used with Monticello." UsedByDefault := aBoolean! ! !PSMCPatchMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 2/9/2010 14:04'! usedByDefault "Answer whether the Polymorph diff tools should be used with Monticello." ^UsedByDefault ifNil: [UsedByDefault := true]! ! !PSMCPatchMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 10/30/2006 11:08'! forPatch: aPatch "Answer a new instance of the receiver with the given patch as the model." ^ self new model: aPatch operations! ! !PSMCPatchOperationWrapper methodsFor: 'accessing' stamp: 'gvc 10/26/2006 12:00'! operation "Answer the pacth operation for the receiver or nil if none." ^self item! ! !PSMCPatchOperationWrapper methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 15:47'! isConflict "Answer whether the receiver is a conflict item." ^ self operation isConflict! ! !PSMCPatchOperationWrapper methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 15:48'! localChosen "Answer whether the local version is chosen." ^self operation localChosen! ! !PSMCPatchOperationWrapper methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 15:52'! chooseLocal "Choose the local version." self operation chooseLocal! ! !PSMCPatchOperationWrapper methodsFor: 'accessing' stamp: 'CamilloBruni 9/19/2013 19:43'! icon "Answer a form with an icon to represent the receiver" self item localChosen ifTrue: [ ^ Smalltalk ui icons changeBlockIcon ]. ^ super icon! ! !PSMCPatchOperationWrapper methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 15:51'! clearChoice "Choose neither version (be in conflict)." self operation clearChoice! ! !PSMCPatchOperationWrapper methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 15:51'! remoteChosen "Answer whether the remote version is chosen." ^self operation remoteChosen! ! !PSMCPatchOperationWrapper methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 15:52'! chooseRemote "Choose the remote version." self operation chooseRemote! ! !PSMCPatchOperationWrapper methodsFor: 'converting' stamp: 'GaryChambers 10/26/2011 16:19'! asString "Answer the method name." ^self item definition summary! ! !PSMCSystemSettings commentStamp: 'TorstenBergmann 2/12/2014 23:29'! Settings for the polymorph system! !PSMCSystemSettings class methodsFor: 'settings' stamp: 'AlainPlantec 1/10/2010 22:04'! defaultMonticelloDiffToolsSettingOn: aBuilder (aBuilder setting: #polymorphDiffToolsUsedByDefault) label: 'Use Polymorph difference tools' translated; description: 'When enabled the Polymorph diff tools will be used with Monticello. When disabled, the original tools are used.' translated; parent: #monticello; target: PSMCPatchMorph; selector: #usedByDefault! ! !PackageAPIHelpBuilder commentStamp: 'TorstenBergmann 2/4/2014 21:17'! A builder for the API of the various packages! !PackageAPIHelpBuilder methodsFor: 'building' stamp: 'tbn 3/23/2010 21:28'! buildPackageTopic: pTopic | classTopic classes | classes := (PackageInfo named: pTopic title) classes asSortedCollection: [:cl1 :cl2 | cl1 name < cl2 name]. classes do: [:aClass| classTopic := ClassAPIHelpBuilder buildHierarchicalHelpTopicFrom: aClass withSubclasses: false withMethods: true. pTopic addSubtopic: classTopic ] ! ! !PackageAPIHelpBuilder methodsFor: 'building' stamp: 'StephanEggermont 12/9/2013 19:52'! build |pTopic| topicToBuild := (HelpTopic named: rootToBuildFrom bookName). rootToBuildFrom helpPackages do: [:package| pTopic := HelpTopic named: package. topicToBuild addSubtopic: pTopic. self buildPackageTopic: pTopic. ] ! ! !PackageAbstractNodeExample commentStamp: 'TorstenBergmann 2/3/2014 23:56'! Example for abstract package nodes! !PackageAbstractNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:52'! browseItem ! ! !PackageAbstractNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:52'! inspectItem self inspect! ! !PackageAbstractNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/25/2011 17:06'! keyStroke: anEvent from: aTreeMorph | c | c := anEvent keyCharacter. c = $b ifTrue: [self browseItem. ^ true]. c = $i ifTrue: [self inspectItem. ^ true]. c = $I ifTrue: [self exploreItem. ^ true]. ^ false ! ! !PackageAbstractNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:52'! exploreItem self explore! ! !PackageAbstractNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:52'! doubleClick self browseItem! ! !PackageAbstractNodeExample methodsFor: 'menu' stamp: 'AlainPlantec 1/15/2010 14:53'! contents ^ contents ifNil: [contents := super contents]! ! !PackageAbstractNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 10/3/2011 01:02'! menu: menu shifted: b menu add: 'Expand all' translated target: self selector: #expandAll. menu add: 'Browse (b)' translated target: self selector: #browseItem. menu add: 'Inspect (i)' translated target: self selector: #inspectItem. menu add: 'Explore (I)' translated target: self selector: #exploreItem. ! ! !PackageAndClassChooser commentStamp: ''! I am a widget to select classes and packages from a tree.! !PackageAndClassChooser methodsFor: 'updating' stamp: 'CamilloBruni 10/1/2013 12:50'! update updateProcess ifNotNil: [ updateProcess terminate ]. updateProcess := [ |roots| roots := self roots. UIManager default defer: [ self tree roots: roots ]. ] fork.! ! !PackageAndClassChooser methodsFor: 'accessing' stamp: 'CamilloBruni 11/18/2013 21:00'! searchField ^ searchField ifNil: [ searchField := SearchMorph new model: self; updateSelector: #searchUpdate:; on: (Character arrowDown asKeyCombination) do: [ :arg :arg2 :keystroke | self tree spec instance handleKeystroke: keystroke ]; yourself. searchField := searchField asSpecAdapter ]! ! !PackageAndClassChooser methodsFor: 'updating' stamp: 'CamilloBruni 10/1/2013 12:27'! searchUpdate: aString searchPattern := nil. aString isEmptyOrNil ifFalse: [ searchPattern := [aString asRegexIgnoringCase] on: RegexSyntaxError do: [ aString ]]. self update.! ! !PackageAndClassChooser methodsFor: 'actions' stamp: 'CamilloBruni 11/20/2013 17:02'! chooseModalTo: parentWindow "Open this this package class chooser as a dialog modal to the given window" | dialog result | dialog := self openDialogWithSpec. result := nil. dialog okAction: [ result := self selectedItems ]; cancelAction: [ result := nil ]. parentWindow openModal: dialog window. ^ result! ! !PackageAndClassChooser methodsFor: 'accessing - tree' stamp: 'CamilloBruni 9/26/2013 14:30'! childrenFor: aPackageOrClass | result name | name := aPackageOrClass name. aPackageOrClass isBehavior ifTrue: [ ^ #() ]. aPackageOrClass isTrait ifTrue: [ ^ #() ]. result := Set new. RPackageOrganizer default packagesDo: [ :each | | tempName | tempName := each name. (tempName size > name size and: [ (tempName at: name size + 1) = $- and: [ (tempName beginsWith: name) ]]) ifTrue: [ result add: each ]]. result := result asSortedCollection: [ :a :b | a name <= b name ]. result addAll: aPackageOrClass definedClasses. ^ result ! ! !PackageAndClassChooser methodsFor: 'testing' stamp: 'CamilloBruni 10/1/2013 12:32'! hasSearch ^ self searchPattern isNil not! ! !PackageAndClassChooser methodsFor: 'initialization' stamp: 'CamilloBruni 10/1/2013 12:24'! initializeWidgets self setFocus; update.! ! !PackageAndClassChooser methodsFor: 'accessing - tree' stamp: 'CamilloBruni 10/1/2013 12:28'! roots | rootNames organizer| self hasSearch ifTrue: [ ^ self filteredRoots ]. organizer := RPackageOrganizer default. rootNames := (organizer packageNames collect: [ :name | name copyUpTo: $- ]) asSet asSortedCollection. ^ rootNames collect: [ :name| organizer packageNamed: name ifAbsent: [ RPackage named: name ]]! ! !PackageAndClassChooser methodsFor: 'accessing' stamp: 'CamilloBruni 9/26/2013 01:54'! selectedItems ^ self tree selectedItems! ! !PackageAndClassChooser methodsFor: 'accessing' stamp: 'CamilloBruni 11/17/2013 15:46'! tree ^ tree ifNil: [ tree := self instantiate: TreeModel. tree isCheckList: true; multiSelection: true; autoMultiSelection: true; " rootNodeHolder: [ :item | TreeNodeModel with: item model: tree ];" displayBlock: [ :aPackageOrClass | self labelFor: aPackageOrClass ]; childrenBlock: [ :aPackageOrClass | self childrenFor: aPackageOrClass ]; iconBlock: [ :treeNode | self iconFor: treeNode content ]; whenSelectedItemChanged: [ :selection | self selectionChanged ]; doubleClick: [ Nautilus openOnPackage: tree selectedItem ]]! ! !PackageAndClassChooser methodsFor: 'accessing - tree' stamp: 'CamilloBruni 10/1/2013 12:42'! labelFor: aPackageOrClass self hasSearch ifTrue: [ ^ aPackageOrClass name ]. ^ (aPackageOrClass name copyAfterLast: $-) ifEmpty: [ aPackageOrClass name ]! ! !PackageAndClassChooser methodsFor: 'actions' stamp: 'CamilloBruni 9/26/2013 19:48'! choose ^ self chooseModalTo: World! ! !PackageAndClassChooser methodsFor: 'accessing - tree' stamp: 'CamilloBruni 11/18/2013 20:59'! iconFor: anRPackageOrClass anRPackageOrClass isBehavior ifTrue: [ ^ Smalltalk ui icons classIcon ]. RPackageOrganizer default packageNamed: anRPackageOrClass name ifAbsent: [ ^ Smalltalk ui icons emptyPackageIcon ]. ^ Smalltalk ui icons packageIcon! ! !PackageAndClassChooser methodsFor: 'accessing - tree' stamp: 'CamilloBruni 9/26/2013 02:07'! selectionChanged "Synchronize the selected items"! ! !PackageAndClassChooser methodsFor: 'accessing' stamp: 'CamilloBruni 9/26/2013 02:00'! selectedItem ^ self tree selectedItem! ! !PackageAndClassChooser methodsFor: 'initialization' stamp: 'CamilloBruni 10/1/2013 12:24'! setFocus self focusOrder add: self searchField; add: self tree. ! ! !PackageAndClassChooser methodsFor: 'accessing - tree' stamp: 'CamilloBruni 10/1/2013 12:40'! filteredRoots | roots | roots := RPackageOrganizer default packages select: [ :package | searchPattern search: package name ]. roots := roots asSortedCollection: [ :a :b | a name <= b name ]. Smalltalk allClassesAndTraitsDo: [ :class | (searchPattern search: class name) ifTrue: [ roots add: class ]]. ^ roots! ! !PackageAndClassChooser methodsFor: 'accessing' stamp: 'CamilloBruni 10/1/2013 12:32'! searchPattern ^ searchPattern! ! !PackageAndClassChooser class methodsFor: 'specs' stamp: 'CamilloBruni 10/1/2013 12:21'! defaultSpec ^ SpecLayout composed newColumn: [ :c | c add: #searchField height: 25; add: #tree ]; yourself! ! !PackageChecker commentStamp: 'TorstenBergmann 2/12/2014 22:57'! Utility class to check packages! !PackageChecker methodsFor: 'check' stamp: 'StephaneDucasse 7/30/2010 14:03'! check "self new check" "only work for top level package overlapping. Foo and Foo-Core, but not Foo-Core and Foo-Core-Test" | packageNames dict overlappingPackages | overlappingPackages := OrderedCollection new. packageNames := MCWorkingCopy allManagers collect: [:each | each packageName]. dict := packageNames groupedBy: [:each | each copyUpTo: $-]. dict copy keysAndValuesDo: [:k :v | v size = 1 ifTrue: [ dict removeKey: k]]. dict keysAndValuesDo: [:k :v | (v includes: k) ifTrue: [ overlappingPackages add: v. Warning signal: 'Overlapping packages: ', v printString]]. ^ overlappingPackages ! ! !PackageClassNodeExample commentStamp: 'TorstenBergmann 2/3/2014 23:55'! Example for a package class node! !PackageClassNodeExample methodsFor: 'menu' stamp: 'StephaneDucasse 8/29/2013 20:55'! methodsInCategory: aCat ^ self item selectorsInProtocol: aCat! ! !PackageClassNodeExample methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2011 20:57'! browseItem Smalltalk tools browser fullOnClass: self item selector: nil! ! !PackageClassNodeExample methodsFor: 'menu' stamp: 'AlainPlantec 1/29/2010 12:16'! childrenItems ^ self item organization categories ! ! !PackageClassNodeExample methodsFor: 'menu' stamp: 'AlainPlantec 2/8/2010 09:39'! childNodeClassFromItem: anItem ^PackageMethodCategoryNodeExample! ! !PackageInfo commentStamp: ''! Subclass this class to create new Packages.! !PackageInfo methodsFor: 'testing' stamp: 'sd 9/12/2010 19:07'! includesClassNamed: aClassName ^ self includesSystemCategory: ((self systemOrganization categoryOfElement: aClassName) ifNil: [^false])! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 8/9/2011 17:56'! coreMethodsForClass: aClass ^ (aClass selectors asSet difference: ((self foreignExtensionMethodsForClass: aClass) collect: [:r | r selector])) asArray collect: [:sel | self referenceForMethod: sel ofClass: aClass]! ! !PackageInfo methodsFor: 'testing' stamp: 'avi 4/6/2004 15:16'! extensionMethodsForClass: aClass ^ (self extensionCategoriesForClass: aClass) gather: [:cat | ((aClass organization listAtCategoryNamed: cat) ifNil: [#()]) collect: [:sel | self referenceForMethod: sel ofClass: aClass]]! ! !PackageInfo methodsFor: 'modifying' stamp: 'nice 1/5/2010 15:59'! externalTraits ^ Array streamContents: [:s | | behaviors | behaviors := self classesAndMetaClasses. Smalltalk allTraits do: [:trait | (behaviors includes: trait) ifFalse: [s nextPut: trait]. (behaviors includes: trait classSide) ifFalse: [s nextPut: trait classSide]]]. ! ! !PackageInfo methodsFor: 'accessing' stamp: 'sd 9/12/2010 19:07'! foreignSystemCategories ^ self systemOrganization categories reject: [:cat | self includesSystemCategory: cat] ! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'SeanDeNigris 2/5/2013 16:16'! asRPackageSet ^ RPackageSet named: self packageName.! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 2/6/2010 16:44'! methodsInCategory: aString ofClass: aClass ^Array streamContents: [:stream | self methodsInCategory: aString ofClass: aClass do: [:each | stream nextPut: each]] ! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 8/21/2011 17:46'! referenceForMethod: aSymbol ofClass: aClass ^ RGMethodDefinition realClass: aClass selector: aSymbol! ! !PackageInfo methodsFor: 'naming' stamp: 'ab 10/16/2002 21:22'! externalName ^ self packageName! ! !PackageInfo methodsFor: 'testing' stamp: 'dvf 10/18/2002 23:22'! extensionMethodsFromClasses: classes ^classes gather: [:class | self extensionMethodsForClass: class]! ! !PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'! methodCategoryPrefix ^ methodCategoryPrefix ifNil: [methodCategoryPrefix := '*', self packageName asLowercase]! ! !PackageInfo methodsFor: 'listing' stamp: 'al 3/1/2006 21:51'! extensionClasses ^ self externalBehaviors reject: [:classOrTrait | (self extensionCategoriesForClass: classOrTrait) isEmpty]! ! !PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'! packageName ^ packageName ifNil: [packageName := self categoryName]! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'cyrille.delaunay 10/29/2010 10:31'! coreMethodsNotDefinedInSubCategories ^ self classesAndMetaClassesNotDefinedInSubCategories gather: [:class | self coreMethodsForClass: class]! ! !PackageInfo methodsFor: 'modifying' stamp: 'al 3/1/2006 21:42'! externalBehaviors ^self externalClasses , self externalTraits! ! !PackageInfo methodsFor: 'listing' stamp: 'StephaneDucasse 3/3/2010 13:47'! allOverriddenMethods "search classes and meta classes" ^ Array streamContents: [:stream | self allOverriddenMethodsDo: [:each | stream nextPut: each]] ! ! !PackageInfo methodsFor: 'testing' stamp: 'sd 9/12/2010 19:08'! systemOrganization ^self environment organization! ! !PackageInfo methodsFor: 'modifying' stamp: 'avi 10/11/2003 15:14'! removeMethod: aMethodReference! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 2/6/2010 16:45'! overrideCategoriesForClass: aClass ^Array streamContents: [:stream | self overrideCategoriesForClass: aClass do: [:each | stream nextPut: each]] ! ! !PackageInfo methodsFor: 'enumerating' stamp: 'StephaneDucasse 3/3/2010 13:46'! allOverriddenMethodsDo: aBlock "Evaluates aBlock with all the overridden methods in the system" ^ ProtoObject withAllSubclassesDo: [:class | self overriddenMethodsInClass: class do: aBlock] ! ! !PackageInfo methodsFor: 'listing' stamp: 'ab 11/13/2002 01:23'! coreMethods ^ self classesAndMetaClasses gather: [:class | self coreMethodsForClass: class]! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! includesClass: aClass ^ self includesSystemCategory: aClass theNonMetaClass category! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'cyrille.delaunay 10/29/2010 10:35'! externalTraitsNotDefinedInSubCategories ^ Array streamContents: [:s | | behaviors | behaviors := self classesAndMetaClassesNotDefinedInSubCategories. Smalltalk allTraits do: [:trait | (behaviors includes: trait) ifFalse: [s nextPut: trait]. (behaviors includes: trait classSide) ifFalse: [s nextPut: trait classSide]]]. ! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! includesSystemCategory: categoryName ^ self category: categoryName matches: self systemCategoryPrefix! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'cyrille.delaunay 10/29/2010 10:37'! extensionMethodsNotDefinedInSubCategories ^ self externalBehaviorsNotDefinedInSubCategories gather: [:classOrTrait | self extensionMethodsForClass: classOrTrait]! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'EstebanLorenzano 1/24/2013 13:40'! isEmpty ^(self classesAndMetaClassesNotDefinedInSubCategories, self coreMethodsNotDefinedInSubCategories, self extensionMethodsNotDefinedInSubCategories) isEmpty ! ! !PackageInfo methodsFor: 'enumerating' stamp: 'StephaneDucasse 2/6/2010 16:51'! methodsInCategory: aString ofClass: aClass do: aBlock ((aClass organization listAtCategoryNamed: aString) ifNil: [^self]) do: [:sel | aBlock value: (self referenceForMethod: sel ofClass: aClass)]! ! !PackageInfo methodsFor: 'listing' stamp: 'StephaneDucasse 8/9/2011 18:00'! methods ^ (self extensionMethods, self coreMethods) select: [:method | method isValid and: [method isLocalSelector and: [method selector isDoIt not]]]! ! !PackageInfo methodsFor: 'testing' stamp: 'sd 9/12/2010 19:08'! systemCategories ^ self systemOrganization categories select: [:cat | self includesSystemCategory: cat]! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'BenjaminVanRyseghem 8/29/2012 10:04'! withClassesAndCategoriesDo: aBlock self systemCategories do: [:aSymbol | (SystemOrganization listAtCategoryNamed: aSymbol asString) collect: [:e | self class environment at: e ] thenDo: [ :class | aBlock value: class value: aSymbol. ]. ].! ! !PackageInfo methodsFor: 'enumerating' stamp: 'StephaneDucasse 2/6/2010 16:52'! overriddenMethodsInClass: aClass do: aBlock "Evaluates aBlock with the overridden methods in aClass" ^ self overrideCategoriesForClass: aClass do: [:cat | self methodsInCategory: cat ofClass: aClass do: aBlock]! ! !PackageInfo methodsFor: 'naming' stamp: 'ab 10/28/2002 10:38'! systemCategoryPrefix ^ self packageName! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 8/9/2011 18:00'! includesMethodReference: aMethodRef ^ self includesMethod: aMethodRef selector ofClass: aMethodRef actualClass! ! !PackageInfo methodsFor: 'accessing' stamp: 'CamilloBruni 10/4/2012 18:34'! foreignClasses | s | s := IdentitySet new. self foreignSystemCategories do: [ :c | (self systemOrganization listAtCategoryNamed: c) do: [ :cl | | cls | cls := self environment at: cl. s add: cls; add: cls theMetaClass ] ]. ^ s ! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 2/6/2010 16:41'! isOverrideOfYourMethod: aMethodReference "Answers true if the argument overrides a method in this package" ^ (self isYourClassExtension: aMethodReference category) not and: [(self changeRecordForOverriddenMethod: aMethodReference) notNil]! ! !PackageInfo methodsFor: 'dependencies' stamp: 'stephaneducasse 2/4/2006 20:40'! externalSubclasses | pkgClasses subClasses | pkgClasses := self classes. subClasses := Set new. pkgClasses do: [:c | subClasses addAll: (c allSubclasses)]. ^ subClasses difference: pkgClasses ! ! !PackageInfo methodsFor: 'Ring extensions' stamp: 'VeronicaUquillas 7/28/2011 16:33'! asRingDefinition "Creates a RGPackage containing all its classes and methods. Including extension methods" | rgPackage rgClasses rgMethods rgCls | self flag: 'Should be removed when RPackage is integrated'. rgPackage := RGFactory current createPackageNamed: self packageName. rgClasses := self classes collect:[ :cls| cls asRingDefinition ]. rgMethods := self methods collect: [ :mth| mth asRingDefinition ]. rgClasses do:[ :cls| rgPackage addClass: cls ]. rgClasses do:[ :cls| | scls | scls:= rgPackage classOrTraitNamed: cls superclassName. scls notNil ifTrue:[ cls superclass: scls. cls theMetaClass superclass: scls theMetaClass ] ]. rgMethods do:[ :mth | rgCls:= rgPackage classOrTraitNamed: mth parentName. rgCls notNil ifTrue: [ mth isExtension: false. rgCls addMethod: mth ] ifFalse:[ mth isExtension: true ]. rgPackage addMethod: mth ]. ^rgPackage! ! !PackageInfo methodsFor: 'modifying' stamp: 'StephaneDucasse 8/9/2011 17:56'! addCoreMethod: aMethodReference | category | category := self baseCategoryOfMethod: aMethodReference. aMethodReference actualClass organization classify: aMethodReference selector under: category suppressIfDefault: false! ! !PackageInfo methodsFor: 'listing' stamp: 'PavelKrivanek 4/17/2012 19:40'! extensionMethods ^ (Smalltalk allClassesAndTraits, (Smalltalk allClasses collect: [:c | c class])) gather: [:classOrTrait | self extensionMethodsForClass: classOrTrait]! ! !PackageInfo methodsFor: 'dependencies' stamp: 'StephaneDucasse 8/9/2011 17:57'! externalRefsSelect: selBlock thenCollect: colBlock | pkgMethods dependents extMethods otherClasses otherMethods classNames | classNames := self classes collect: [:c | c name]. extMethods := self extensionMethods collect: [:mr | mr selector]. otherClasses := self externalClasses difference: self externalSubclasses. otherMethods := otherClasses gather: [:c | c selectors]. pkgMethods := self methods asSet collect: [:mr | mr selector]. pkgMethods removeAllFoundIn: otherMethods. dependents := Set new. otherClasses do: [:c | c selectorsAndMethodsDo: [:sel :compiled | | refs | (extMethods includes: sel) ifFalse: [refs := compiled literals select: selBlock thenCollect: colBlock. refs do: [:ea | ((classNames includes: ea) or: [pkgMethods includes: ea]) ifTrue: [dependents add: (self referenceForMethod: sel ofClass: c) -> ea]]]]]. ^ dependents! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:20'! extensionCategoriesForClass: aClass ^ aClass organization categories select: [:cat | self isYourClassExtension: cat]! ! !PackageInfo methodsFor: 'dependencies' stamp: 'ab 11/18/2002 01:16'! externalCallers ^ self externalRefsSelect: [:literal | literal isKindOf: Symbol] thenCollect: [:l | l].! ! !PackageInfo methodsFor: 'enumerating' stamp: 'StephaneDucasse 3/3/2010 13:47'! overriddenMethodsDo: aBlock "Enumerates the methods the receiver contains which have been overridden by other packages" ^ self allOverriddenMethodsDo: [:ea | (self isOverrideOfYourMethod: ea) ifTrue: [aBlock value: ea]]! ! !PackageInfo methodsFor: 'listing' stamp: 'StephaneDucasse 2/6/2010 17:38'! overriddenMethodsInClass: aClass ^Array streamContents: [:stream | self overriddenMethodsInClass: aClass do: [:each | stream nextPut: each]] ! ! !PackageInfo methodsFor: 'enumerating' stamp: 'eem 8/30/2010 10:28'! actualMethodsDo: aBlock "Evaluate aBlock with the actual method objects in this package." | enum | self extensionMethods do: [:mr| aBlock value: mr compiledMethod]. enum := [:behavior| behavior organization categories do: [:cat| (self isForeignClassExtension: cat) ifFalse: [(behavior organization listAtCategoryNamed: cat) do: [:s| aBlock value: (behavior compiledMethodAt: s)]]]]. self classes do: [:c| enum value: c; value: c classSide] ! ! !PackageInfo methodsFor: 'dependencies' stamp: 'ab 11/18/2002 01:15'! externalUsers ^ self externalRefsSelect: [:literal | literal isVariableBinding] thenCollect: [:l | l key]! ! !PackageInfo methodsFor: 'registering' stamp: 'avi 11/12/2003 23:12'! register PackageOrganizer default registerPackage: self! ! !PackageInfo methodsFor: 'modifying' stamp: 'StephaneDucasse 8/18/2009 23:17'! addMethod: aMethodReference (self includesClass: aMethodReference actualClass) ifTrue: [self addCoreMethod: aMethodReference] ifFalse: [self addExtensionMethod: aMethodReference]! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'cyrille.delaunay 11/25/2010 16:40'! classesAndMetaClassesNotDefinedInSubCategories |subCategoriesClasses| subCategoriesClasses := OrderedCollection new. self systemCategories do: [:aSymbol | aSymbol = self packageName asSymbol ifFalse: [ subCategoriesClasses addAll: (PackageOrganizer default packageNamed: aSymbol ifAbsent: [PackageInfo new]) classesAndMetaClasses ] ]. ^ self classesAndMetaClasses difference: subCategoriesClasses! ! !PackageInfo methodsFor: 'testing' stamp: 'dvf 9/17/2002 00:18'! includesMethodCategory: categoryName ofClass: aClass ^ (self isYourClassExtension: categoryName) or: [(self includesClass: aClass) and: [(self isForeignClassExtension: categoryName) not]]! ! !PackageInfo methodsFor: 'testing' stamp: 'MartinDias 11/6/2013 16:04'! changeRecordForOverriddenMethod: aMethodDefinition ^ SourceFiles changeRecordsFor: aMethodDefinition detect: [ :protocol | self includesMethodCategory: protocol ofClass: aMethodDefinition actualClass ]! ! !PackageInfo methodsFor: 'accessing' stamp: 'sd 9/12/2010 19:05'! environment ^ Smalltalk globals ! ! !PackageInfo methodsFor: 'dependencies' stamp: 'ab 6/10/2003 17:18'! externalClasses | myClasses | myClasses := self classesAndMetaClasses. ^ Array streamContents: [:s | ProtoObject withAllSubclassesDo: [:class | (myClasses includes: class) ifFalse: [s nextPut: class]]]! ! !PackageInfo methodsFor: 'testing' stamp: 'dvf 10/18/2002 23:22'! outsideClasses ^ProtoObject withAllSubclasses difference: self classesAndMetaClasses! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! foreignExtensionMethodsForClass: aClass ^ (self foreignExtensionCategoriesForClass: aClass) gather: [:cat | (aClass organization listAtCategoryNamed: cat) collect: [:sel | self referenceForMethod: sel ofClass: aClass]]! ! !PackageInfo methodsFor: 'testing' stamp: 'dvf 7/23/2003 14:06'! includesMethodCategory: categoryName ofClassNamed: aClass ^ (self isYourClassExtension: categoryName) or: [(self includesClassNamed: aClass) and: [(self isForeignClassExtension: categoryName) not]]! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'GuillermoPolito 8/11/2012 21:12'! extensionMethodsFromAllSystem ^ Smalltalk allClassesAndTraits gather: [:classOrTrait | (self extensionMethodsForClass: classOrTrait classSide), (self extensionMethodsForClass: classOrTrait) ]! ! !PackageInfo methodsFor: 'printing' stamp: 'stephane.ducasse 8/26/2008 20:43'! printOn: aStream super printOn: aStream. aStream nextPutAll: '(',self packageName,')'.! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'cyrilledelaunay 2/9/2011 10:53'! classesNotDefinedInSubCategories "return all classes that are defined in a category matching exactly the name of this package. Rpackage has to re-order each class in its right package. See RPackageOrganizer>>importFromPackageInfo:" |subCategoriesClasses| subCategoriesClasses := OrderedCollection new. self systemCategories do: [:aSymbol | aSymbol = self packageName asSymbol ifFalse: [ subCategoriesClasses addAll: (PackageInfo named: aSymbol asString) classes ] ]. ^ self classes difference: subCategoriesClasses! ! !PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'! packageName: aString packageName := aString! ! !PackageInfo methodsFor: 'listing' stamp: 'ul 11/13/2009 16:29'! classesAndMetaClasses "Return a Set with all classes and metaclasses belonging to this package" | baseClasses result | baseClasses := self classes. result := (Set new: baseClasses size * 2) addAll: baseClasses; yourself. baseClasses do: [ :c | result add: c classSide]. ^result ! ! !PackageInfo methodsFor: 'listing' stamp: 'StephaneDucasse 2/6/2010 17:37'! overriddenMethods ^ Array streamContents: [:stream | self overriddenMethodsDo: [:each | stream nextPut: each]] ! ! !PackageInfo methodsFor: 'enumerating' stamp: 'StephaneDucasse 2/6/2010 16:52'! overrideCategoriesForClass: aClass do: aBlock "Evaluates aBlock with all the *foo-override categories in aClass" ^ aClass organization categories do: [:cat | (self isOverrideCategory: cat) ifTrue: [aBlock value: cat]]! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:18'! coreCategoriesForClass: aClass ^ aClass organization categories select: [:cat | (self isForeignClassExtension: cat) not]! ! !PackageInfo methodsFor: 'modifying' stamp: 'stephaneducasse 2/4/2006 20:40'! baseCategoryOfMethod: aMethodReference | oldCat oldPrefix tokens | oldCat := aMethodReference category. ({ 'as yet unclassified'. 'all' } includes: oldCat) ifTrue: [ oldCat := '' ]. tokens := oldCat findTokens: '*-' keep: '*'. "Strip off any old prefixes" ((tokens at: 1 ifAbsent: [ '' ]) = '*') ifTrue: [ [ ((tokens at: 1 ifAbsent: [ '' ]) = '*') ] whileTrue: [ tokens removeFirst ]. oldPrefix := tokens removeFirst asLowercase. [ (tokens at: 1 ifAbsent: [ '' ]) asLowercase = oldPrefix ] whileTrue: [ tokens removeFirst ]. ]. tokens isEmpty ifTrue: [^ 'as yet unclassified']. ^ String streamContents: [ :s | tokens do: [ :tok | s nextPutAll: tok ] separatedBy: [ s nextPut: $- ]]! ! !PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 14:20'! hash ^ packageName hash! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 12/5/2002 00:16'! includesMethod: aSymbol ofClass: aClass aClass ifNil: [^ false]. ^ self includesMethodCategory: ((aClass organization categoryOfElement: aSymbol) ifNil: [' ']) ofClass: aClass! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! isForeignClassExtension: categoryName ^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not]! ! !PackageInfo methodsFor: 'testing' stamp: 'avi 3/10/2004 12:37'! isYourClassExtension: categoryName ^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix]! ! !PackageInfo methodsFor: 'modifying' stamp: 'StephaneDucasse 8/9/2011 17:56'! addExtensionMethod: aMethodReference | category | category := self baseCategoryOfMethod: aMethodReference. aMethodReference actualClass organization classify: aMethodReference selector under: self methodCategoryPrefix, '-', category! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:22'! foreignExtensionCategoriesForClass: aClass ^ aClass organization categories select: [:cat | self isForeignClassExtension: cat]! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 2/6/2010 16:39'! includesChangeRecord: aChangeRecord ^ aChangeRecord methodClass notNil and: [self includesMethodCategory: aChangeRecord category ofClass: aChangeRecord methodClass]! ! !PackageInfo methodsFor: 'accessing' stamp: 'GuillermoPolito 8/18/2012 13:55'! definedClasses ^self classes! ! !PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'! categoryName |category| category := self class category. ^ (category endsWith: '-Info') ifTrue: [category copyUpToLast: $-] ifFalse: [category]! ! !PackageInfo methodsFor: 'accessing' stamp: 'MarcusDenker 10/25/2010 10:43'! classes ^ (self systemCategories gather: [ :cat | (self systemOrganization listAtCategoryNamed: cat) collect: [ :className | self environment at: className ] ]) sort: [ :a :b | a className <= b className ] ! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'cyrille.delaunay 10/29/2010 10:37'! externalBehaviorsNotDefinedInSubCategories ^self externalClassesNotDefinedInSubCategories , self externalTraitsNotDefinedInSubCategories! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 2/6/2010 16:41'! isOverrideCategory: aString ^ aString endsWith: '-override'! ! !PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 00:09'! = other ^ other species = self species and: [other packageName = self packageName]! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 2/6/2010 16:41'! isOverrideMethod: aMethodReference ^ self isOverrideCategory: aMethodReference category! ! !PackageInfo methodsFor: 'comparing' stamp: 'StephaneDucasse 3/3/2010 13:44'! linesOfCode "An approximate measure of lines of code. Includes comments, but excludes blank lines." ^self methods inject: 0 into: [:sum :each | sum + each compiledMethod linesOfCode]! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'cyrille.delaunay 10/29/2010 10:33'! externalClassesNotDefinedInSubCategories | myClasses | myClasses := self classesAndMetaClassesNotDefinedInSubCategories. ^ Array streamContents: [:s | ProtoObject withAllSubclassesDo: [:class | (myClasses includes: class) ifFalse: [s nextPut: class]]]! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 2/6/2010 17:40'! category: categoryName matches: prefix | prefixSize catSize | categoryName ifNil: [ ^false ]. catSize := categoryName size. prefixSize := prefix size. catSize < prefixSize ifTrue: [ ^false ]. (categoryName findString: prefix startingAt: 1 caseSensitive: false) = 1 ifFalse: [ ^false ]. ^(categoryName at: prefix size + 1 ifAbsent: [ ^true ]) = $-! ! !PackageInfo methodsFor: 'listing' stamp: 'StephaneDucasse 8/9/2011 18:01'! selectors ^ self methods collect: [:ea | ea selector]! ! !PackageInfo class methodsFor: 'packages access' stamp: 'avi 11/12/2003 23:00'! named: aString ^ PackageOrganizer default packageNamed: aString ifAbsent: [(self new packageName: aString) register]! ! !PackageInfo class methodsFor: 'initialization' stamp: 'avi 2/18/2004 00:46'! initialize self allSubclassesDo: [:ea | ea new register]! ! !PackageInfo class methodsFor: 'compatibility' stamp: 'avi 3/9/2004 16:28'! default ^ self allPackages detect: [:ea | ea class = self] ifNone: [self new register]! ! !PackageInfo class methodsFor: 'packages access' stamp: 'Alexandre.Bergel 4/4/2009 09:26'! allPackages ^PackageOrganizer default packages! ! !PackageInfo class methodsFor: 'packages access' stamp: 'avi 11/11/2003 17:19'! registerPackageName: aString ^ PackageOrganizer default registerPackageNamed: aString! ! !PackageInfo class methodsFor: 'testing' stamp: 'Alexandre.Bergel 4/4/2009 09:29'! existPackageNamed: aString " self existPackageNamed: 'PackageInfo' self existPackageNamed: 'Zork' " ^ (self allPackages anySatisfy: [:each | each packageName = aString]) ! ! !PackageInfoTest methodsFor: '*Tests-util' stamp: 'AlexandreBergel 5/26/2008 22:31'! packageClass ^ PackageInfo! ! !PackageInfoTest methodsFor: '*Tests-util' stamp: 'PavelKrivanek 10/17/2013 21:18'! testGatherExtensionsFromSamePackage | extensionMethod | extensionMethod := (PackageInfoTest>>#packageClass). self assert: (extensionMethod category beginsWith: '*'). self assert: (((PackageInfo named: 'Tests') extensionMethods collect: #method) includes: extensionMethod)! ! !PackageInfoTest methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 12/26/2011 17:37'! testKernelPackage | kernelPackage | "We make sure that the package Kernel exist" self assert: (self packageClass existPackageNamed: 'Kernel'). kernelPackage := self packageClass named: 'Kernel'. "Testing the name of the kernel" self assert: (kernelPackage packageName = 'Kernel'). self assert: (kernelPackage externalName = 'Kernel'). "The kernel package includes the class Object" self assert: (kernelPackage includesClass: Object). self assert: (kernelPackage includesClassNamed: #Object). "All methods defined in Object belongs to the package Kernel" "MethodReference should be remove" self assert: ((kernelPackage coreMethodsForClass: Object) allSatisfy: [:m | (m isKindOf: RGMethodDefinition)]). self assert: ((Object methods collect: [:cm | cm methodReference]) includesAllOf: (kernelPackage coreMethodsForClass: Object)). "However, all methods defined in the class do not belong to the package because of methods extensions" self deny: ((kernelPackage coreMethodsForClass: Object) includesAllOf: (Object methods collect: [:cm | cm methodReference])). "Check some methods defined in the package" self assert: (kernelPackage includesMethod: #at: ofClass: Object). self assert: (kernelPackage includesMethod: #at:put ofClass: Object). self assert: (kernelPackage includesMethod: #basicAt: ofClass: Object). "Methods that belong to other packages do not belong to kernel" "browser and browseHierarchy belong to the Tools package" self deny: (kernelPackage includesMethod: #browse ofClass: Object). self deny: (kernelPackage includesMethod: #browseHierarchy ofClass: Object). ! ! !PackageInfoTest methodsFor: 'running' stamp: 'AlexandreBergel 5/26/2008 22:29'! tearDown super tearDown. createdClasses ifNotNil: [createdClasses do: [:cls | cls removeFromSystem ]]! ! !PackageInfoTest methodsFor: 'running' stamp: 'AlexandreBergel 5/26/2008 22:23'! setUp super setUp. createdClasses := nil! ! !PackageMethodCategoryNodeExample commentStamp: 'TorstenBergmann 2/3/2014 23:55'! Example for a package method node! !PackageMethodCategoryNodeExample methodsFor: 'accessing' stamp: 'StephaneDucasse 8/29/2013 20:55'! childrenItems ^ self parentNode item selectorsInProtocol: self item! ! !PackageMethodCategoryNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/8/2010 09:39'! childNodeClassFromItem: anItem ^ PackageMethodNodeExample! ! !PackageMethodNodeExample commentStamp: 'TorstenBergmann 2/3/2014 23:55'! Example for a package method node! !PackageMethodNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/26/2010 13:49'! selector ^ self item! ! !PackageMethodNodeExample methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2011 20:57'! browseItem Smalltalk tools browser fullOnClass: self itemClass selector: self selector ! ! !PackageMethodNodeExample methodsFor: 'results' stamp: 'AlainPlantec 1/26/2010 14:03'! compiledMethod ^ self itemClass compiledMethodAt: self selector ifAbsent: [self itemClass class compiledMethodAt: self selector ifAbsent: []]! ! !PackageMethodNodeExample methodsFor: 'private' stamp: 'AlainPlantec 1/26/2010 13:49'! itemClass ^ self parentNode parentNode item. ! ! !PackageNodeExample commentStamp: 'TorstenBergmann 2/3/2014 23:55'! Example for a pakage node! !PackageNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/15/2010 15:15'! asString ^ self item packageName! ! !PackageNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/29/2010 12:17'! childrenItems ^ self item classes ! ! !PackageNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/8/2010 09:39'! childNodeClassFromItem: anItem ^ PackageClassNodeExample ! ! !PackageOrganizer commentStamp: 'TorstenBergmann 2/26/2014 08:28'! The package organizer. Access using PackageOrganizer default! !PackageOrganizer methodsFor: 'searching' stamp: 'MarcusDenker 3/11/2010 11:28'! packageOfClass: aClass ifNone: errorBlock | classCategory | classCategory := aClass theNonMetaClass category. packages at: classCategory ifPresent: [:v | ^ v]. (classCategory includes: $-) ifTrue: [ packages at: (classCategory copyUpTo: $-) ifPresent: [:v | ^ v] ]. ^ self packages detect: [:ea | ea includesClass: aClass] ifNone: errorBlock! ! !PackageOrganizer methodsFor: 'searching' stamp: 'stephane.ducasse 9/4/2008 12:52'! mostSpecificPackageOfMethod: aMethodReference ifNone: aBlock ^ self mostSpecificPackageIn: (self packages select: [ :each | each includesMethodReference: aMethodReference ]) ifNone: aBlock! ! !PackageOrganizer methodsFor: 'accessing' stamp: 'avi 11/12/2003 23:01'! packageNames ^ packages keys! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'! packageOfMethod: aMethodReference ^ self packageOfMethod: aMethodReference ifNone: [self noPackageFound]! ! !PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 21:10'! unregisterPackageNamed: aString self unregisterPackage: (self packageNamed: aString ifAbsent: [^ self])! ! !PackageOrganizer methodsFor: 'searching' stamp: 'stephane.ducasse 9/4/2008 12:50'! mostSpecificPackageOfClass: aClass ^ self mostSpecificPackageOfClass: aClass ifNone: [self noPackageFound]! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 11/12/2003 23:08'! packageNamed: aString ifAbsent: errorBlock ^ packages at: aString ifAbsent: errorBlock! ! !PackageOrganizer methodsFor: 'cleaning' stamp: 'BenjaminVanRyseghem 7/22/2013 14:54'! flushObsoletePackages: aBlock "Flush all packages considered obsolete by evaluating the argument block." packages keys do: [ :key | (aBlock value: (packages at: key)) ifTrue:[packages removeKey: key]. ]! ! !PackageOrganizer methodsFor: '*rpackage-core' stamp: 'cyrilledelaunay 1/31/2011 14:50'! packagesDictionary ^ packages! ! !PackageOrganizer methodsFor: 'searching' stamp: 'stephane.ducasse 9/4/2008 12:50'! mostSpecificPackageOfMethod: aMethodReference ^ self mostSpecificPackageOfMethod: aMethodReference ifNone: [self noPackageFound]! ! !PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 21:08'! registerPackageNamed: aString ^ self registerPackage: (PackageInfo named: aString)! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'! packageOfClass: aClass ^ self packageOfClass: aClass ifNone: [self noPackageFound]! ! !PackageOrganizer methodsFor: 'accessing' stamp: 'avi 11/12/2003 23:01'! packages ^ packages values! ! !PackageOrganizer methodsFor: 'private' stamp: 'stephane.ducasse 9/4/2008 12:51'! mostSpecificPackageIn: aCollection ifNone: aBlock aCollection isEmpty ifTrue: [ ^ aBlock value ]. ^ (aCollection asArray sort: [ :a :b | a packageName size > b packageName size ]) first! ! !PackageOrganizer methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:13'! initialize super initialize. packages := Dictionary new! ! !PackageOrganizer methodsFor: 'searching' stamp: 'stephane.ducasse 9/4/2008 12:51'! mostSpecificPackageOfClass: aClass ifNone: aBlock ^ self mostSpecificPackageIn: (self packages select: [ :each | each includesClass: aClass ]) ifNone: aBlock! ! !PackageOrganizer methodsFor: 'registering' stamp: 'BenjaminVanRyseghem 7/22/2013 14:54'! unregisterPackage: aPackageInfo packages removeKey: aPackageInfo packageName ifAbsent: []! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'! noPackageFound self error: 'No package found'! ! !PackageOrganizer methodsFor: 'registering' stamp: 'BenjaminVanRyseghem 7/22/2013 14:54'! registerPackage: aPackageInfo packages at: aPackageInfo packageName put: aPackageInfo! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:22'! packageOfMethod: aMethodReference ifNone: errorBlock ^ self packages detect: [:ea | ea includesMethodReference: aMethodReference] ifNone: errorBlock! ! !PackageOrganizer class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:40'! default ^ default ifNil: [default := self new]! ! !PackageRemotesManager commentStamp: 'ChristopheDemarey 1/8/2014 16:53'! I am an user interface used to link mcpackages and remotes PackageRemotesManager new openWithSpec! !PackageRemotesManager methodsFor: 'private' stamp: 'ChristopheDemarey 12/19/2013 17:32'! change: selected forRemote: remote | selectedPackage group | selectedPackage := packages selectedItem. selectedPackage ifNil: [ ^ self ]. group := selectedPackage content repositoryGroup. selected ifTrue: [ group addRepository: remote ] ifFalse: [ group removeRepository: remote ]! ! !PackageRemotesManager methodsFor: 'accessing' stamp: 'ChristopheDemarey 1/8/2014 16:55'! remotes ^ remotes! ! !PackageRemotesManager methodsFor: 'initialization' stamp: 'ChristopheDemarey 1/8/2014 16:57'! initializeWidgets packages := self instantiate: SearchableTree. remotes := self instantiate: RemotesManager. packages displayBlock: [ :each | each packageName ]. remotes selectedRemotes: self selectedPackageRepositories. self focusOrder add: packages; add: remotes! ! !PackageRemotesManager methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 12/4/2013 13:12'! initializeDialogWindow: aWindow aWindow toolbar: OkToolbar new! ! !PackageRemotesManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/30/2013 22:05'! doIfNotSilent: aBlock silent ifTrue: [ ^ self ]. aBlock value! ! !PackageRemotesManager methodsFor: 'accessing' stamp: 'ChristopheDemarey 1/8/2014 16:55'! packages ^ packages! ! !PackageRemotesManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/30/2013 20:02'! packages: mcPackages packages roots: mcPackages! ! !PackageRemotesManager methodsFor: 'initialization' stamp: 'ChristopheDemarey 12/17/2013 17:24'! initialize super initialize. silent := false.! ! !PackageRemotesManager methodsFor: 'accessing' stamp: 'ChristopheDemarey 1/8/2014 16:55'! remotesTree ^ remotes remotes! ! !PackageRemotesManager methodsFor: 'initialization' stamp: 'ChristopheDemarey 12/19/2013 16:36'! initializePresenter packages whenSelectedItemChanged: [ :item | self updateRemoteSelectionFrom: item ]. packages whenRootsChanged: [ :nodes | nodes ifNotEmpty: [ nodes first takeHighlight ] ]. remotes selectedChangedBlock: [:remote :selected | self doIfNotSilent: [ self change: selected forRemote: remote ]]. self whenBuiltDo: [ | nodes | nodes := packages roots. nodes ifNotEmpty: [ packages selectedItem: ( nodes first selected: true; takeHighlight; yourself ) ] ]! ! !PackageRemotesManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/1/2013 00:29'! title ^ 'Remotes manager'! ! !PackageRemotesManager methodsFor: 'private' stamp: 'ChristopheDemarey 1/8/2014 16:55'! selectedPackageRepositories ^ packages selectedItem ifNil: [ #() ] ifNotNil: [ :item | item content repositoryGroup repositories ].! ! !PackageRemotesManager methodsFor: 'private' stamp: 'ChristopheDemarey 12/19/2013 17:30'! updateRemoteSelectionFrom: aPackage | repositories | aPackage ifNil: [ repositories := #() ] ifNotNil: [ repositories := aPackage repositoryGroup repositories ]. self remotesTree roots do: [ :node | self silentWhile: [ node selected: (repositories includes: node content remote) ] ]! ! !PackageRemotesManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/30/2013 22:04'! silentWhile: aBlock | oldSilent | oldSilent := silent. silent := true. aBlock ensure: [ silent := oldSilent ]! ! !PackageRemotesManager methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/4/2013 10:18'! initialExtent ^ 700@460! ! !PackageRemotesManager class methodsFor: 'specs' stamp: 'ChristopheDemarey 12/17/2013 16:44'! defaultSpec ^ SpecLayout composed newRow: [ :row | row add: #packages; addSplitter; add: #remotes ]; yourself! ! !PackageTasksPlugin commentStamp: ''! This plugin shows the tasks in the current package. A task is a method which sends #flag: to mark it as #todo, or #fixme, or whatever task you want to fix. Clicking in the specific task makes you jump to the marked method.! !PackageTasksPlugin methodsFor: 'display' stamp: 'GuillermoPolito 5/2/2012 13:32'! selectedIndex ^index! ! !PackageTasksPlugin methodsFor: 'initialization' stamp: 'GuillermoPolito 5/2/2012 13:46'! initialize tasks := OrderedCollection new. index := 0. panel := PanelMorph new changeTableLayout; listDirection: #leftToRight; addMorph: self buildTaskList; addMorph: ((StringMorph contents: 'Tasks:') width: 50; height: 50; yourself); hResizing: #spaceFill; vResizing: #shrinkWrap; yourself. ! ! !PackageTasksPlugin methodsFor: 'announcement' stamp: 'MarcusDenker 9/27/2013 18:06'! packageSelected: anAnnouncement | package | package := anAnnouncement package. package ifNil: [ tasks removeAll ] ifNotNil: [ tasks := (self systemNavigation allCallsOn: 'flag:' asSymbol) select: [ :m | package includesMethod: m selector ofClass: m methodClass ] ]. self changed: #tasks.! ! !PackageTasksPlugin methodsFor: 'display' stamp: 'GuillermoPolito 5/2/2012 13:37'! display ^panel! ! !PackageTasksPlugin methodsFor: 'display' stamp: 'GuillermoPolito 5/2/2012 13:33'! selectedIndex: anIndex index := anIndex. self updateMethodSelection: (tasks at: index ifAbsent: [ ^self ]).! ! !PackageTasksPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/2/2012 14:13'! updateMethodSelection: aMethod model ui categoryWidget resetCategoryCache; resetCategoriesListSelection. model ui categoryWidget categoriesSelection at: aMethod category put: true. model ui methodWidget resetMethodCache; resetMethodsListSelection. model ui methodWidget methodsSelection at: aMethod category put: true. model ui listSelection2 removeAll. model ui listSelection2 at: aMethod methodClass put: true. model package: model selectedPackage class: aMethod methodClass category: aMethod category method: aMethod method. model ui update. model ui updateClassView.! ! !PackageTasksPlugin methodsFor: 'display' stamp: 'GuillermoPolito 5/2/2012 13:44'! buildTaskList ^(PluggableListMorph on: self list: #tasks selected: #selectedIndex changeSelected: #selectedIndex: menu: nil keystroke: nil) height: 50; hResizing: #spaceFill; yourself.! ! !PackageTasksPlugin methodsFor: 'display' stamp: 'GuillermoPolito 5/2/2012 12:38'! tasks ^tasks! ! !PackageTasksPlugin methodsFor: 'display' stamp: 'GuillermoPolito 5/2/2012 12:38'! index ^index! ! !PackageTasksPlugin class methodsFor: 'position' stamp: 'GuillermoPolito 5/2/2012 12:49'! defaultPosition ^ #top! ! !PackageTasksPlugin class methodsFor: 'position' stamp: 'GuillermoPolito 5/2/2012 13:53'! description ^self comment! ! !PackageTreeExample commentStamp: ''! PackageTreeExample new open! !PackageTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/7/2010 22:44'! rootNodeClassFromItem: anItem ^ PackageNodeExample! ! !PackageTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/11/2011 14:57'! defaultTreeMorph ^ super defaultTreeMorph doubleClickSelector: #doubleClick; nodeStringGetter: #asString; getMenuSelector: #menu:shifted:. ! ! !PackageTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/7/2011 11:39'! open ^ self openDialogWindowIn: World title: 'Packages'. ! ! !PackageTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/25/2011 17:06'! keyStroke: anEvent from: aTreeMorph self selectedNode ifNotNil: [:current | current keyStroke: anEvent from: aTreeMorph]! ! !PackageTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/15/2009 20:11'! doubleClick self selectedNode ifNotNil: [:n | n doubleClick]! ! !PackageTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/29/2010 12:14'! rootItems ^ PackageOrganizer default packages ! ! !PackageTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/15/2009 15:10'! menu: menu shifted: b "Set up the menu to apply to the receiver's, honoring the #shifted boolean" self selectedNode ifNotNil: [:current | current menu: menu shifted: b]. ^ menu! ! !PackageTreeGroupNodeModel commentStamp: ''! I'm a group node model.! !PackageTreeGroupNodeModel methodsFor: 'converting' stamp: 'EstebanLorenzano 10/14/2013 13:16'! asNautilusSelection ^ PackageTreeGroupSelection node: self! ! !PackageTreeGroupNodeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/3/2013 15:31'! rowMorphForColumn: aTreeColumn ^ self item name asMorph! ! !PackageTreeGroupNodeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/3/2013 15:32'! icon ^ self model groupIconFor: self item.! ! !PackageTreeGroupSelection commentStamp: ''! I'm a group selection.! !PackageTreeGroupSelection methodsFor: 'testing' stamp: 'EstebanLorenzano 10/3/2013 15:36'! includesClass: aClass ^ self definedClasses includes: aClass! ! !PackageTreeGroupSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/9/2013 12:56'! menu: aMenu shifted: aBoolean target: aTarget ^ aTarget groupsMenu: aMenu shifted: aBoolean! ! !PackageTreeGroupSelection methodsFor: 'testing' stamp: 'EstebanLorenzano 10/3/2013 16:09'! isGroup ^ true! ! !PackageTreeGroupSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/25/2013 14:48'! protocolsFor: class ^ self item protocolsFor: class! ! !PackageTreeGroupSelection methodsFor: 'testing' stamp: 'NicolasPetton 2/14/2014 15:22'! includesCategory: aSymbol ^ self item packages anySatisfy: [ :each | each name == aSymbol ]! ! !PackageTreeGroupSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 13:14'! definedClasses ^ self item classes! ! !PackageTreeGroupSelection methodsFor: 'testing' stamp: 'EstebanLorenzano 11/29/2013 14:47'! removable ^ self item removable ! ! !PackageTreeGroupSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 12/12/2013 18:13'! categoryName ^ ''! ! !PackageTreeGroupSelection methodsFor: 'accessing' stamp: 'NicolaiHess 1/16/2014 09:56'! classes ^ self definedClasses! ! !PackageTreeGroupSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/9/2013 17:35'! registerSelectionTarget: aTarget aTarget registerSelectionGroup: self.! ! !PackageTreeGroupSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 13:15'! package ^ self item packages ifNotEmpty: [ :packages | packages first ]! ! !PackageTreeGroupSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/25/2013 14:48'! methodsFor: class categorised: aCategory ^ self item methodsFor: class categorised: aCategory! ! !PackageTreeGroupSelection methodsFor: 'testing' stamp: 'EstebanLorenzano 11/29/2013 14:47'! isReadOnly ^ self item isReadOnly ! ! !PackageTreeGroupSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/25/2013 14:47'! methodsFor: class ^ self item methodsFor: class! ! !PackageTreeGroupSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/14/2014 18:08'! correspondingMcPackage ^ self package correspondingMcPackage! ! !PackageTreeGroupSelection class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 10/14/2013 16:11'! group: aGroup ^ self node: (PackageTreeGroupNodeModel with: aGroup)! ! !PackageTreeModel commentStamp: ''! I'm a tree model for managing grouos, packages and tags.! !PackageTreeModel methodsFor: 'drag and drop' stamp: 'EstebanLorenzano 11/29/2013 13:26'! acceptDroppingMorph: aMorph event: evt inMorph: aTreeMorph | target items | target := (aTreeMorph scrollerSubMorphFromPoint: evt position) complexContents item. items := aMorph passenger. target ifNotNil: [ model dropInAPackage: items into: target ]! ! !PackageTreeModel methodsFor: 'help-text' stamp: 'EstebanLorenzano 1/27/2014 12:32'! helpTextFor: aRPackage "We try to get a configuration class with the same name of the package" "If the package has subnames with dashes, we take only the first part" | configuration possibleConfigurationName | aRPackage name ifEmpty: [ ^ nil ]. possibleConfigurationName := 'ConfigurationOf', (aRPackage name subStrings: '-') first. configuration := possibleConfigurationName asSymbol asClassIfAbsent: [ ^nil ]. "If the configuration has a catalog description we show it, if not we don't" (configuration respondsTo: #catalogDescription) ifFalse: [ ^ nil ]. ^configuration catalogDescription.! ! !PackageTreeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 19:10'! packageIconFor: aPackage ^ self model packageIconFor: aPackage.! ! !PackageTreeModel methodsFor: 'drag and drop' stamp: 'NicolaiHess 2/13/2014 11:19'! wantsDroppedMorph: aMorph event: anEvent inMorph: destMorph "TODO: Filter out to avoid drag and drop of different objet types. Here, we don't know what the target may be so filtering is limited." aMorph dragTransferType ifNil: [ ^ false ]. ^ destMorph model == self! ! !PackageTreeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/25/2013 13:44'! rootNodes self model showGroups ifTrue: [ ^ self groupsAsNodes ]. ^ PackageTreeNautilus showGroupsOnTop ifTrue: [ self groupsAsNodes, (self packagesAsNodes) ] ifFalse: [ self packagesAsNodes ]. ! ! !PackageTreeModel methodsFor: 'keyboard managing' stamp: 'EstebanLorenzano 3/19/2014 13:44'! arrowEvent: event key: aChar target: aMorph "Transmit flow to next column" ^ self model keyPressedOnTree: event target: aMorph.! ! !PackageTreeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/3/2013 15:32'! groupIconFor: aPackage ^ self model groupIconFor: aPackage.! ! !PackageTreeModel methodsFor: 'package filter' stamp: 'JurajKubelka 11/15/2013 16:16'! packageMatchPattern: aRPackage ^ self model packageMatchPattern: aRPackage! ! !PackageTreeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 18:46'! model ^ model! ! !PackageTreeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 19:20'! tagIconFor: aTag ^ nil! ! !PackageTreeModel methodsFor: 'private' stamp: 'EstebanLorenzano 11/27/2013 13:19'! packagesAsNodes ^ ((self model packages select: [ :each | self packageMatchPattern: each ] thenCollect: [ :each | each asNautilusNodeWithModel: self ]) sorted: [ :a :b | a name < b name ]) ! ! !PackageTreeModel methodsFor: 'private' stamp: 'EstebanLorenzano 10/3/2013 15:24'! groupsAsNodes ^ (self model groups collect: [ :each | PackageTreeGroupNodeModel with: each model: self ]) sorted: [ :a :b | a name < b name ]! ! !PackageTreeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 18:46'! model: anObject model := anObject! ! !PackageTreeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/3/2013 13:18'! menu: menu shifted: b ^ self model menu: menu shifted: b! ! !PackageTreeNautilus commentStamp: ''! I'm a model for Nautilus with package tree.! !PackageTreeNautilus methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/25/2013 14:34'! defaultUIClass ^ PackageTreeNautilusUI! ! !PackageTreeNautilus methodsFor: 'package filter' stamp: 'JurajKubelka 12/26/2013 14:23'! packagePatternString: aString self ui packagePatternString: aString! ! !PackageTreeNautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 11/25/2013 13:39'! showGroupsOnTop ^ ShowGroupsOnTop ifNil: [ ShowGroupsOnTop := true ]! ! !PackageTreeNautilus class methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 15:51'! parentOfClass: aClass "I can answer an RPackage or an RPackageTag, depending on the presence of Tags in package. This is an UI optimization to not show a tree RPackage->RPackageTag when there is just one tag in package, named in the same way as his parent" | package tag | package := aClass package. tag := package classTagForClass: aClass. ^ (((tag name = package name) and: [ package classTags size <= 1 ]) ifTrue: [ package ] ifFalse: [ tag ]) asNautilusSelection! ! !PackageTreeNautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 11/25/2013 13:40'! nautilusSettingsOn: aBuilder (aBuilder setting: #showGroupsOnTop) parent: #Nautilus; target: self; label: 'Show groups on top ?' translated; description: 'If true, Nautilus will show groups on top of package pane' translated.! ! !PackageTreeNautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 11/25/2013 13:40'! showGroupsOnTop: aBoolean ShowGroupsOnTop := aBoolean! ! !PackageTreeNautilusUI commentStamp: ''! I'm the UI representation of Nautilus with Package tree. I redefine the category column to add a tree who can manage groups, packages and tags. I try to redefine just the basic, and for that reason there are some concepts that changed for bad (they are now less understandable). #selectedPackage now answers not a package but a "selection", and instance of a child of PackageTreeSelection who can be: - a package, like before - a package tag - a group ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/10/2013 16:13'! listClearSelection list model deselectAll.! ! !PackageTreeNautilusUI methodsFor: 'package' stamp: 'EstebanLorenzano 2/21/2014 13:07'! addPackageBasedOn: aPackage [ ^ super addPackageBasedOn: aPackage ] on: RPackageConflictError do: [ :e | UIManager default inform: e messageText, '. You need to use promote/demote options instead.' ]. ^ nil! ! !PackageTreeNautilusUI methodsFor: 'private dispatch' stamp: 'EstebanLorenzano 11/19/2013 19:32'! renamePackageCategory: package self basicRenamePackage: package! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 3/19/2014 11:20'! updateBothView | selectedPackage selectedClass | selectedPackage := self selectedPackage. selectedClass := self selectedClass. super updateBothView. "I need to restore selection (otherwise, nothing goes to the right position)" list model updateList. self selectedPackage: selectedPackage. self selectedClass: selectedClass.! ! !PackageTreeNautilusUI methodsFor: 'package' stamp: 'EstebanLorenzano 10/10/2013 13:19'! addPackagesAsGroup: aCollection | group | aCollection isEmptyOrNil ifTrue: [ ^ nil ]. group := super addPackagesAsGroup: aCollection. self updatePackageView. ^ group! ! !PackageTreeNautilusUI methodsFor: 'class' stamp: 'EstebanLorenzano 12/12/2013 21:37'! addTraitIn: aPackage super addTraitIn: aPackage asNautilusSelection item.! ! !PackageTreeNautilusUI methodsFor: 'package filter' stamp: 'JurajKubelka 11/15/2013 16:41'! ensureSafePackagePattern: aPattern ^ [ aPattern asRegexIgnoringCase ] on: RegexSyntaxError do: [ :ex | self fixPackagePattern: aPattern ex: ex ]! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/9/2013 15:55'! updatePackageView list model changed: #rootNodes.! ! !PackageTreeNautilusUI methodsFor: 'package filter' stamp: 'JurajKubelka 12/26/2013 14:54'! packagePatternString: aStringOrNil aStringOrNil ifNil: [ ^ self ]. searchWidget content: aStringOrNil! ! !PackageTreeNautilusUI methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/25/2013 13:54'! selectedPackageWithoutChangingSelection: aSelection | class | self okToChange ifFalse: [ ^ self ]. class := self selectedClass. (class notNil and: [ aSelection isNil or: [ (aSelection includesClass: class) not ] ]) ifTrue: [ self selectedClass: nil ]. aSelection ifNotNil: [ aSelection registerSelectionTarget: self ]. self updateClassView. self update. self changed: #getComments. self changed: #sourceCodeFrom:.! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/14/2013 15:41'! listSelectItem: anObject | selection | selection := anObject asNautilusSelection. list model expandAllFromNode: selection nodePath first; selectItems: { selection item }. list scrollSelectionIntoView.! ! !PackageTreeNautilusUI methodsFor: 'package' stamp: 'NicolaiHess 2/2/2014 20:39'! alertCategoryName: tagName exitstsAlreadyIn: package | errorMessage | errorMessage := String streamContents: [ :stream | stream << 'Category named ' << tagName << ' already exists in package ' << package name ]. UIManager default inform: errorMessage! ! !PackageTreeNautilusUI methodsFor: 'accessing' stamp: 'NicolaiHess 1/19/2014 12:09'! groupsAreVisible ^ self showGroups or:[ PackageTreeNautilus showGroupsOnTop]! ! !PackageTreeNautilusUI methodsFor: 'events handling' stamp: 'EstebanLorenzano 3/19/2014 13:44'! keyPressedOnTree: anEvent target: aMorph (anEvent keyCharacter == self class nextFocusKey and: [ (aMorph canExpand not or: [ aMorph isExpanded ]) ]) ifTrue: [ self giveFocusTo: list2. ^ true ]. ^ false ! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 11/25/2013 14:07'! loadList2 ^ self showPackages ifTrue: [ self showHierarchy ifTrue: [ self getClassHierarchy2 ] ifFalse: [ self getPackagesList2 ] ] ifFalse: [ cachedHierarchy ifNotNil: [:col | col sortedElements ] ifNil: [ self getClassHierarchy ] ]! ! !PackageTreeNautilusUI methodsFor: 'accessing' stamp: 'NicolaiHess 1/28/2014 15:27'! selected: aNode | selections | selections := aNode selectedNodes collect: [ :each |each asNautilusSelection]. "leave if selection contains no node that isn't already selected" (selections contains:[:each | (self isSelectedPackage:each) not]) ifFalse:[^ self]. self clearPackageSelections. self resetShowHierarchy. selections do:[: each | self selectedPackageWithoutChangingSelection: each]. self changed: #selected. self changed: #currentHistoryIndex. ! ! !PackageTreeNautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 11/27/2013 14:29'! restrictedBrowsePackages: selections ^ super restrictedBrowsePackages: (selections collect: [ :each | each asNautilusSelection item ])! ! !PackageTreeNautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 10/15/2013 18:24'! addClassCategory | package | package := self addClassCategoryBasedOn: self selectedPackage. package ifNotNil: [ self selectedPackage: package. self updatePackageView ]! ! !PackageTreeNautilusUI methodsFor: 'accessing' stamp: 'BenComan 4/13/2014 00:54'! showPackages: aBoolean self okToChange ifFalse: [ ^ nil ]. list enabled: aBoolean. aBoolean ifFalse: [ self basicShowHierarchy ]. listElements := nil. list2Elements := nil. "If showPackages false(Hierarchy)-->true(Flat) then selected package needs to synch to that of selected class" (aBoolean and: [ self model showPackages not ]) ifTrue: [ self model showPackages: aBoolean. self selectedPackage: self selectedClass package. ] ifFalse: [ self model showPackages: aBoolean. ]. self changed: #groupsButtonLabel. self updateClassView. self changed: #toggleButtonState. self changed: #toggleButtonLabel. self changedLabels.! ! !PackageTreeNautilusUI methodsFor: 'accessing' stamp: 'MarcusDenker 4/11/2014 15:06'! showGroups: aBoolean self okToChange ifFalse: [ ^ self ]. self showGroups = aBoolean ifTrue: [ ^ self ]. self model selectedPackage: nil. self clearPackageSelections. self listClearSelection. self model showGroups: aBoolean. self updatePackageView. self updateClassView. self changed: #groupsButtonLabel. ! ! !PackageTreeNautilusUI methodsFor: 'private dispatch' stamp: 'EstebanLorenzano 12/18/2013 17:08'! removeClassCategory: packageTag self basicRemoveClasses: packageTag classes. packageTag asNautilusSelection item removeFromPackage.! ! !PackageTreeNautilusUI methodsFor: 'displaying' stamp: 'BenjaminVanRyseghem 1/29/2014 18:03'! buildFirstColumn: aWindow | buttons | buttons := PanelMorph new. self setShortcuts: #NautilusPackageShortcuts to: buttons. buttons changeProportionalLayout; addMorph: self buildGroupsButton fullFrame: ((0@0 corner: 0.5@1) asLayoutFrame rightOffset: -2); addMorph: self buildToggleButton fullFrame: ((0.5@0 corner: 1@1) asLayoutFrame topLeftOffset: 2@0); hResizing: #spaceFill; vResizing: #spaceFill. ^ PanelMorph new changeProportionalLayout; addMorph: self buildList fullFrame: (LayoutFrame identity topOffset: 30; bottomOffset: -30); addMorph: self buildPackageSearch fullFrame: (LayoutFrame identity bottomFraction: 0; bottomOffset: 25; leftOffset: -1; rightOffset: 1); addMorph: buttons fullFrame: ((0@1 corner: 1@1) asLayoutFrame topOffset: -25; bottomOffset: -1); hResizing: #spaceFill; vResizing: #spaceFill; yourself.! ! !PackageTreeNautilusUI methodsFor: 'private dispatch' stamp: 'NicolaiHess 2/2/2014 20:36'! renameClassCategory: packageTag | newName oldName | oldName := packageTag name. newName := UIManager default request: ('New name of category {1}' format: { packageTag name }) initialAnswer: oldName title: 'Rename a category'. newName = oldName ifTrue: [ ^ self ]. (self isValidPackageName: newName) ifFalse: [ ^ self alertInvalidPackageName:newName ]. (self category:newName existsIn:packageTag package) ifTrue:[ ^ self alertCategoryName:newName exitstsAlreadyIn:packageTag package]. packageTag renameTo: newName. ! ! !PackageTreeNautilusUI methodsFor: 'source code area' stamp: 'johanfabry 1/20/2014 11:09'! defaultClassDescriptor | string | string := 'Object subclass: #NameOfSubclass instanceVariableNames: '''' classVariableNames: '''' category: '''. ^ self selectedPackage ifNotNil: [ :package | string, package categoryName, '''' ] ifNil: [ string, '''' ] ! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'NicolaiHess 1/4/2014 01:05'! clearPackageSelections listElements := nil. list2Elements := nil. packagesSelection removeAll. groupsSelection removeAll.! ! !PackageTreeNautilusUI methodsFor: 'class' stamp: 'EstebanLorenzano 10/14/2013 16:48'! classAdded: anAnnouncement | class | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement classAdded. ((self parentOfClass: class) nodePath anySatisfy: [ :node | node item = class package ]) ifTrue: [ self updateClassView. self removeFromPackagesIconsCache: class package ] ! ! !PackageTreeNautilusUI methodsFor: 'class' stamp: 'EstebanLorenzano 12/12/2013 21:37'! addClassIn: aPackage super addClassIn: aPackage asNautilusSelection item.! ! !PackageTreeNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 10/15/2013 18:37'! packageFixPragma ^ 'nautilusGlobalPackageTreeFixMenu'! ! !PackageTreeNautilusUI methodsFor: 'private dispatch' stamp: 'EstebanLorenzano 12/20/2013 11:34'! fullBrowseFromTag: aPackageTag self model class openOnPackage: aPackageTag asNautilusSelection class: self selectedClass category: self selectedCategory method: self selectedMethod group: self selectedGroup showGroups: self showGroups showHierarchy: self showHierarchy showPackages: self showPackages showComment: self showComment showInstance: self showInstance showCategories: true ! ! !PackageTreeNautilusUI methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/16/2013 14:21'! selectedPackage: aPackage " Force package selection, not used by the lists " self okToChange ifFalse: [ ^ self ]. acceptor := ClassDefinitionAcceptor model: self. groupsSelection removeAll. packagesSelection removeAll. packagesSelection at: aPackage put: true. aPackage ifNotNil: [ self basicSelectPackage: aPackage ] ifNil: [ self selectedPackageWithoutChangingSelection: nil. self listClearSelection ]. ! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 2/21/2014 13:07'! addClassCategoryBasedOn: aSelection | name package packageTag | packageTag := nil. package := aSelection package. name := UIManager default request: ('New category: {1}-' format: { package name }) initialAnswer: '' title: 'Create a new category'. [ (self isValidPackageName: name) ifTrue: [ packageTag := package addClassTag: name ] ifFalse: [ self alertInvalidPackageName: name ] ] on: RPackageConflictError do: [ :e | UIManager default inform: e messageText, '. You need to use promote/demote options instead.' ]. ^ packageTag! ! !PackageTreeNautilusUI methodsFor: 'events handling' stamp: 'EstebanLorenzano 3/19/2014 13:40'! keyPressedOnList: anEvent shifted: aBoolean (anEvent keyCharacter == self class nextFocusKey and: [ (list canExpand not or: [ list isExpanded ]) ]) ifTrue: [ self giveFocusTo: list2. ^ true ]. ^ false ! ! !PackageTreeNautilusUI methodsFor: 'package filter' stamp: 'CamilloBruni 2/19/2014 21:14'! packageSearchUpdate: aPattern packagePattern := (aPattern isNil or: [ aPattern trimBoth isEmpty ]) ifTrue: [ nil ] ifFalse: [ self ensureSafePackagePattern: aPattern ]. self updatePackages! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 11/25/2013 16:10'! resetShowHierarchy "If I'm showing hierarchy, going back to show simple class list" self model showHierarchy ifFalse: [ ^ self ]. self showPackages: true.! ! !PackageTreeNautilusUI methodsFor: 'private dispatch' stamp: 'EstebanLorenzano 12/20/2013 11:32'! fullBrowseFromPackage: aPackage self model class openOnPackage: aPackage class: self selectedClass category: self selectedCategory method: self selectedMethod group: self selectedGroup showGroups: self showGroups showHierarchy: self showHierarchy showPackages: self showPackages showComment: self showComment showInstance: self showInstance showCategories: true ! ! !PackageTreeNautilusUI methodsFor: 'package' stamp: 'EstebanLorenzano 12/11/2013 16:52'! fileOutPackages: aCollection self do: [ :package | package asNautilusSelection item fileOut ] on: aCollection displaying: 'Filing out packages...'.! ! !PackageTreeNautilusUI methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/3/2013 16:57'! groups ^ self model groupsManager groups.! ! !PackageTreeNautilusUI methodsFor: 'package filter' stamp: 'JurajKubelka 12/26/2013 14:20'! packagePatternString ^ searchWidget searchString! ! !PackageTreeNautilusUI methodsFor: 'package filter' stamp: 'BenjaminVanRyseghem 1/29/2014 18:01'! buildPackageSearch "It is an search dialog which filters package list" | textMorph | searchWidget := SearchMorph new model: self; updateSelector: #packageSearchUpdate:; ghostText: 'Type: Pkg1|^Pkg2|Pk.*Core$'; list: SharedValueHolder instance; useSelectionIndex: false; setIndexSelector: #packageSearchUpdate:; yourself. textMorph := searchWidget contentMorph textMorph. self setShortcuts: #NautilusGlobalShortcuts to: textMorph. textMorph bindKeyCombination: Character tab asKeyCombination toAction: [ textMorph navigateFocusForward ]. ^ searchWidget! ! !PackageTreeNautilusUI methodsFor: 'package filter' stamp: 'JurajKubelka 11/15/2013 16:51'! fixPackagePattern: aPattern ex: anException | fixedPattern | fixedPattern := aPattern copyReplaceAll: '*' with: '.*' . ^ [ fixedPattern asRegexIgnoringCase ] on: RegexSyntaxError do: [ :ex | '.*' asRegexIgnoringCase ]! ! !PackageTreeNautilusUI methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 19:09'! packages ^ self model packages! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 1/3/2014 09:55'! basicRenamePackage: aPackage | newName | newName := UIManager default request: 'New name of the package' initialAnswer: aPackage name title: 'Rename a package'. newName = aPackage name ifTrue: [ ^ self ]. (self isValidPackageName: newName) ifTrue: [ aPackage renameTo: newName ] ifFalse: [ self alertInvalidPackageName:newName ].! ! !PackageTreeNautilusUI methodsFor: 'test creation' stamp: 'EstebanLorenzano 12/12/2013 18:09'! buildTestPackageNameFrom:aClass ^ aClass package categoryName asString, '-Tests' ! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'NicolaiHess 1/2/2014 20:42'! isSelectedPackage: aSelection aSelection ifNil:[^ self selectedPackage isNil] ifNotNil:[^ aSelection asNautilusSelection = self selectedPackage ] ! ! !PackageTreeNautilusUI methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/29/2013 16:09'! selectedProtocol ^ self selectedCategory ifNotNil: [ :protocolName | self selectedClass organization protocolNamed: protocolName ]! ! !PackageTreeNautilusUI methodsFor: 'menus behavior' stamp: 'JurajKubelka 12/27/2013 11:52'! fullBrowse super fullBrowse packagePatternString: self packagePatternString! ! !PackageTreeNautilusUI methodsFor: 'private dispatch' stamp: 'EstebanLorenzano 10/14/2013 12:54'! registerSelectionPackage: aSelection self model package: aSelection class: self selectedClass category: nil method: nil. packagesSelection at: aSelection item put: true.! ! !PackageTreeNautilusUI methodsFor: 'private dispatch' stamp: 'EstebanLorenzano 2/21/2014 12:33'! removePackageCategory: package self basicRemoveClasses: package definedClasses. self browsedEnvironment packageOrganizer unregisterPackage: package asNautilusSelection item ! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/16/2013 15:02'! renamePackage: aSelection aSelection asNautilusSelection renameTarget: self. ! ! !PackageTreeNautilusUI methodsFor: 'menus behavior' stamp: 'TommasoDalSasso 12/20/2013 12:30'! removePackages | names packages | packages := self selectedPackages. packages ifEmpty: [ ^ self ]. names := (packages collect: [:package | package name ]) joinUsing: String cr. (UIManager default confirm: ('Are you sure you want to delete the selection(s) named ', String cr, names, ' and their classes ?')) ifTrue: [ packages do: [ :each | each asNautilusSelection removeTarget: self ]. self updatePackageView ]! ! !PackageTreeNautilusUI methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/10/2013 16:14'! basicSelectPackage: aPackage | selection | selection := aPackage asNautilusSelection. self giveFocusTo: list. self selectedPackageWithoutChangingSelection: selection. self listSelectItem: selection.! ! !PackageTreeNautilusUI methodsFor: 'menus' stamp: 'EstebanLorenzano 10/9/2013 12:57'! menu: aMenu shifted: aBoolean self selectedPackage ifNil: [ ^ aMenu ]. ^ self selectedPackage menu: aMenu shifted: aBoolean target: self! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/9/2013 17:40'! updateGroupView self updatePackageView! ! !PackageTreeNautilusUI methodsFor: 'package filter' stamp: 'JurajKubelka 12/10/2013 17:00'! updatePackages | package | package := self selectedPackage. list buildContents. self selectedPackage: package. self updatePackageViewAndMove! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 12/26/2013 10:29'! runPackagesTestsNotifying: aBoolean | packages classes label | (packages := self selectedPackages) ifNil: [ ^ self ]. packages size > 1 ifTrue: [ label := 'Packages: ' ] ifFalse: [ label := 'Package: ' ]. classes := packages gather: [ :package | package asNautilusSelection definedClasses ]. classes := classes select: [ :class | class inheritsFrom: TestCase ]. self runClassTests: classes notifying: false. aBoolean ifTrue: [ | color | (classes anySatisfy:[:e | e hasPassedTest ]) ifTrue: [ color := Color green ]. (classes anySatisfy:[:e | e hasFailedTest ]) ifTrue: [ color := Color yellow ]. (classes anySatisfy:[:e | e hasErrorTest ]) ifTrue: [ color := Color red ]. self notifyTitle: 'Test Finished' contents: label , ((packages collect: #name) joinUsing: ', ') color: color ].! ! !PackageTreeNautilusUI methodsFor: 'package' stamp: 'NicolaiHess 2/2/2014 20:36'! category: aClassTag existsIn: aPackage aPackage classTagNamed: aClassTag ifPresent:[^ true]. ^ false.! ! !PackageTreeNautilusUI methodsFor: 'items creation' stamp: 'EstebanLorenzano 10/9/2013 18:01'! buildList | treeModel | treeModel := PackageTreeModel new model: self; yourself. list := (MorphTreeMorph on: treeModel) multiSelection: true; dropEnabled: true; getMenuSelector: #menu:shifted:; hResizing: #spaceFill; vResizing: #spaceFill. treeModel announcer when: MorphTreeSelectionChanged do: [ :ann | self selected: ann selection ]. list buildContents. self selectedPackage ifNotNil: [ self listSelectItem: self selectedPackage ]. ^ list.! ! !PackageTreeNautilusUI methodsFor: 'package filter' stamp: 'CamilloBruni 2/19/2014 21:13'! packageMatchPattern: aRPackage ^ self packagePattern ifNil: [ true ] ifNotNil: [ :pattern | pattern search: aRPackage name ]! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/16/2013 17:01'! basicRemoveClasses: aCollection aCollection do: #removeFromSystem.! ! !PackageTreeNautilusUI methodsFor: 'private dispatch' stamp: 'EstebanLorenzano 10/14/2013 15:24'! registerSelectionGroup: aSelection self model selectedGroup: aSelection item. self flag: #todo. "I need to refactor to remove the need of groups" "I select also group-as-a-package, because I will be filtering with package selection, not with group selection (which actually does not has much sense now)" self model package: aSelection class: self selectedClass category: nil method: nil. groupsSelection at: aSelection item put: true. ! ! !PackageTreeNautilusUI methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/10/2013 16:15'! selectedGroup: aGroup " Force package selection, not used by the lists " self okToChange ifFalse: [ ^ self ]. acceptor := ClassDefinitionAcceptor model: self. packagesSelection removeAll. groupsSelection removeAll. groupsSelection at: aGroup put: true. aGroup ifNotNil: [ self basicSelectPackage: aGroup ] ifNil: [ self selectedPackageWithoutChangingSelection: nil. self listClearSelection ]. ! ! !PackageTreeNautilusUI methodsFor: 'package filter' stamp: 'CamilloBruni 2/19/2014 21:14'! packagePattern ^ packagePattern ifNil: [ nil ]! ! !PackageTreeNautilusUI methodsFor: 'private' stamp: 'EstebanLorenzano 10/16/2013 14:19'! basicShowHierarchy "Prepares the class panel to show hierarchies" | class | class := self selectedClass theNonMetaClass. classesSelection at: class put: true. self hierarchyClass: class. listElements := nil. list2Elements := nil ! ! !PackageTreeNautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 11/29/2013 16:11'! renameCategory | protocol | protocol := self selectedProtocol. protocol ifNil: [ ^ self ]. protocol canBeRenamed ifFalse: [ ^ self inform: ('You can not rename "{1}" protocol.' format: { protocol name }) ]. ^ super renameCategory.! ! !PackageTreeNautilusUI methodsFor: 'menus behavior' stamp: 'EstebanLorenzano 10/10/2013 13:34'! removeGroups self okToChange ifFalse: [ ^ self ]. super removeGroups. self updatePackageView.! ! !PackageTreeNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/19/2014 16:44'! packagesFixMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Find Class...') keyText: 'f, c' if: Nautilus useOldStyleKeys not; keyText: 'f' if: Nautilus useOldStyleKeys; action: [target findClass]; order: 0; help: 'Search for a class by name'. (aBuilder item: #'Find Package...') keyText: 'f, p' if: Nautilus useOldStyleKeys not; keyText: 'F' if: Nautilus useOldStyleKeys; action: [ target findPackage ]; order: 100; help: 'Search for a package by name'; withSeparatorAfter. (aBuilder item: #'Add package...') keyText: 'n, p' if: Nautilus useOldStyleKeys not; keyText: 'n' if: Nautilus useOldStyleKeys; action: [target addPackage]; order: 200; help: 'Add a package'. (aBuilder item: #'Add tag...') action: [ target addClassCategory ]; order: 210; help: 'Add a tag/category in package'; withSeparatorAfter. (aBuilder item: #'Browse full') keyText: 'b, f' if: Nautilus useOldStyleKeys not; keyText: 'b' if: Nautilus useOldStyleKeys; action: [target fullBrowse]; order: 999; help: 'Open the same browser'.! ! !PackageTreeNodeModel commentStamp: ''! I'm a generic model for package tree nodes. ! !PackageTreeNodeModel methodsFor: 'comparing' stamp: 'EstebanLorenzano 10/14/2013 15:02'! hash ^ self class hash bitXor: self item hash! ! !PackageTreeNodeModel methodsFor: 'comparing' stamp: 'EstebanLorenzano 10/14/2013 15:02'! = aNode self class = aNode class ifFalse: [ ^ false ]. ^ self item = aNode item.! ! !PackageTreeNodeModel methodsFor: 'converting' stamp: 'EstebanLorenzano 10/10/2013 16:46'! asNautilusSelection "Answers a pair RPackage->Tag to express the correct selection" ^ self subclassResponsibility! ! !PackageTreeNodeModel methodsFor: 'converting' stamp: 'EstebanLorenzano 11/26/2013 12:51'! asString ^ self item name! ! !PackageTreePackageNodeModel commentStamp: ''! I'm a package node model.! !PackageTreePackageNodeModel methodsFor: 'accessing' stamp: 'GuillermoPolito 11/7/2013 15:56'! helpText ^ self model helpTextFor: self item.! ! !PackageTreePackageNodeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 19:06'! rowMorphForColumn: aTreeColumn ^ self item name asMorph! ! !PackageTreePackageNodeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 19:29'! childNodeClassFromItem: anItem ^ PackageTreeTagNodeModel! ! !PackageTreePackageNodeModel methodsFor: 'converting' stamp: 'EstebanLorenzano 10/10/2013 16:46'! asNautilusSelection ^ PackageTreePackageSelection package: self item ! ! !PackageTreePackageNodeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 12/13/2013 15:40'! childrenItems | tags | tags := self item classTags. "If there is just one, do not show" ^ (tags size = 1 and: [ tags anyOne name = self item name ]) ifTrue: [ #() ] ifFalse: [ tags sorted: [ :a :b | a categoryName < b categoryName ] ]! ! !PackageTreePackageNodeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 19:22'! icon ^ self model packageIconFor: self item.! ! !PackageTreePackageSelection commentStamp: ''! I'm a package selection.! !PackageTreePackageSelection methodsFor: 'testing' stamp: 'EstebanLorenzano 10/14/2013 13:22'! includesClass: aClass ^ self item includesClass: aClass! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/27/2013 11:33'! classTags ^ self item classTags! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/9/2013 12:56'! menu: aMenu shifted: aBoolean target: aTarget ^ aTarget packagesMenu: aMenu shifted: aBoolean! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/16/2013 15:01'! renameTarget: target target renamePackageCategory: self item.! ! !PackageTreePackageSelection methodsFor: 'testing' stamp: 'NicolasPetton 2/14/2014 15:23'! includesCategory: aSymbol ^ self package name == aSymbol! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 13:18'! definedClasses ^ self item definedClasses! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 13:18'! extendedClasses ^ self item extendedClasses! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 12/12/2013 18:12'! categoryName ^ self item categoryName! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 13:18'! classes ^ self item classes! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/9/2013 17:36'! registerSelectionTarget: aTarget aTarget registerSelectionPackage: self.! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 13:18'! extensionClasses ^ self item extensionClasses! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 16:06'! package ^ self item! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/16/2013 16:48'! removeTarget: target target removePackageCategory: self.! ! !PackageTreePackageSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/14/2014 18:07'! correspondingMcPackage ^ self package correspondingMcPackage! ! !PackageTreePackageSelection class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 10/14/2013 13:21'! package: aPackage ^ self node: (PackageTreePackageNodeModel with: aPackage)! ! !PackageTreeSelection commentStamp: ''! I'm a base selection of an item from package tree. ! !PackageTreeSelection methodsFor: 'testing' stamp: 'EstebanLorenzano 10/3/2013 14:42'! includesClass: aClass ^ self subclassResponsibility! ! !PackageTreeSelection methodsFor: 'initialization' stamp: 'EstebanLorenzano 10/14/2013 13:13'! initializeNode: aNode self initialize. node := aNode. ! ! !PackageTreeSelection methodsFor: 'comparing' stamp: 'EstebanLorenzano 10/16/2013 13:19'! hash ^ self class hash bitXor: self item hash! ! !PackageTreeSelection methodsFor: 'converting' stamp: 'EstebanLorenzano 10/10/2013 16:00'! asNautilusSelection ^ self! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/9/2013 12:56'! menu: aMenu shifted: aBoolean target: aTarget ^ self subclassResponsibility! ! !PackageTreeSelection methodsFor: 'testing' stamp: 'EstebanLorenzano 10/3/2013 16:09'! isGroup ^ false! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/16/2013 15:01'! renameTarget: target ! ! !PackageTreeSelection methodsFor: 'testing' stamp: 'NicolasPetton 2/14/2014 15:21'! includesCategory: aSymbol ^ false! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 13:13'! node ^ node! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/3/2013 14:17'! definedClasses ^ self subclassResponsibility! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/3/2013 14:21'! extendedClasses ^ #()! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 12/12/2013 18:13'! categoryName ^ self subclassResponsibility! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/9/2013 12:52'! registerSelectionTarget: aTarget self subclassResponsibility! ! !PackageTreeSelection methodsFor: 'comparing' stamp: 'EstebanLorenzano 10/16/2013 13:19'! = other self class = other class ifFalse: [ ^ false ]. self item = other item ifFalse: [ ^ false ]. ^ true! ! !PackageTreeSelection methodsFor: 'converting' stamp: 'EstebanLorenzano 10/14/2013 14:43'! nodePath ^ self node path! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/3/2013 15:34'! extensionClasses ^ #()! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 13:14'! item ^ self node item.! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/16/2013 16:47'! removeTarget: target self subclassResponsibility.! ! !PackageTreeSelection methodsFor: 'testing' stamp: 'GuillermoPolito 2/14/2014 11:06'! isPackageTag ^ false! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 13:23'! name ^ self item name! ! !PackageTreeSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/14/2014 18:07'! correspondingMcPackage ^ self subclassResponsibility! ! !PackageTreeSelection class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 10/14/2013 13:13'! node: aNode ^ self basicNew initializeNode: aNode; yourself! ! !PackageTreeSelection class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 10/14/2013 13:19'! new self error: 'Use #node:'! ! !PackageTreeTagNodeModel commentStamp: ''! I'm a tag node model.! !PackageTreeTagNodeModel methodsFor: 'converting' stamp: 'EstebanLorenzano 10/14/2013 13:23'! asNautilusSelection ^ PackageTreeTagSelection node: self! ! !PackageTreeTagNodeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/10/2013 14:37'! rowMorphForColumn: aTreeColumn ^ self item name asMorph! ! !PackageTreeTagNodeModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 19:21'! icon ^ self model tagIconFor: self item! ! !PackageTreeTagNodeModel class methodsFor: 'accessing' stamp: 'EstebanLorenzano 12/12/2013 17:38'! rootText ^ '*'! ! !PackageTreeTagSelection commentStamp: ''! I'm a tag selection.! !PackageTreeTagSelection methodsFor: 'testing' stamp: 'EstebanLorenzano 10/14/2013 13:16'! includesClass: aClass ^ self item classNames includes: aClass instanceSide name.! ! !PackageTreeTagSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/27/2013 11:34'! classTags ^ #()! ! !PackageTreeTagSelection methodsFor: 'testing' stamp: 'GuillermoPolito 2/14/2014 11:05'! isPackageTag ^ true! ! !PackageTreeTagSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/16/2013 15:02'! renameTarget: target target renameClassCategory: self item.! ! !PackageTreeTagSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/3/2013 14:19'! extensionClasses ^ #()! ! !PackageTreeTagSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 16:07'! package ^ self item package! ! !PackageTreeTagSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/16/2013 16:48'! removeTarget: target target removeClassCategory: self.! ! !PackageTreeTagSelection methodsFor: 'testing' stamp: 'NicolasPetton 2/14/2014 15:31'! includesCategory: aSymbol ^ self categoryName asSymbol == aSymbol! ! !PackageTreeTagSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/14/2013 13:16'! definedClasses ^ self item classes! ! !PackageTreeTagSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/3/2013 14:21'! extendedClasses ^ #()! ! !PackageTreeTagSelection methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/3/2013 16:14'! classes ^ self definedClasses! ! !PackageTreeTagSelection class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 10/14/2013 14:56'! tag: aTag ^ self node: ((PackageTreeTagNodeModel with: aTag) parentNode: (PackageTreePackageNodeModel with: aTag package); yourself)! ! !PackageWidget commentStamp: ''! PackageWidget is the basic implementation of a wiget managing packages! !PaginatedMorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/17/2013 09:38'! pageSize: anIntegerOrNil self setPageSize: anIntegerOrNil. self announce: (MorphTreeChangeRequest pageSize: anIntegerOrNil) ! ! !PaginatedMorphTreeModel methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 11:22'! pageSize ^ pageSize ! ! !PaginatedMorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 11:25'! rootNodes | computedRootNodes | computedRootNodes := super rootNodes. self defaultChunkSize ifNotNil: [computedRootNodes size > self defaultChunkSize ifTrue: [self chunkSize: self defaultChunkSize]] ifNil: [ self defaultPageSize ifNotNil: [computedRootNodes size > self defaultPageSize ifTrue: [self pageSize: self defaultPageSize]]]. ^ computedRootNodes ! ! !PaginatedMorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/17/2013 09:38'! chunkSize: anIntegerOrNil self setPageSize: anIntegerOrNil. self announce: (MorphTreeChangeRequest chunkSize: anIntegerOrNil) ! ! !PaginatedMorphTreeModel methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 11:22'! setPageSize: anIntegerOrNil pageSize := anIntegerOrNil. ! ! !PaginatedMorphTreeModel methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 11:22'! chunkSize ^ pageSize ! ! !PaginatedMorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 11:29'! treeMorphClass ^ PaginatedMorphTreeMorph ! ! !PaginatedMorphTreeModel class methodsFor: 'examples' stamp: 'AlainPlantec 10/18/2013 11:02'! testExample "This test demonstrate a paginating morphTreeMorph in action." "self testExample." | treeMorph aWindow aModel | aModel := self itemsList: (1 to: 100) asArray. aWindow := aModel theme newWindowIn: World for: aModel title: 'test'. treeMorph := aModel defaultTreeMorph. treeMorph pageSize: 30. treeMorph buildContents. aWindow addMorph: treeMorph fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 1) offsets: (0 @ 0 corner: 0 @ 0)). aWindow open. aModel expandItemPath: {40}. self assert: treeMorph pager currentPage == 2! ! !PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 11:12'! pagerColor ^ self color darker alpha: 0.6! ! !PaginatedMorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/18/2013 11:02'! expandItemPath: anItemPath | rest | rest := anItemPath asOrderedCollection. [ rest notEmpty ] whileTrue: [ | res | res := (1 to: self nodeList size) select: [ :li | (self nodeList at: li) item = rest first ]. res isEmpty ifTrue: [ ^ self ]. self pager nextPage: res first. (self allNodeMorphs at: 1 ifAbsent: [ ^ self ]) openItemPath: {(rest first)}. rest := rest copyWithoutFirst ]. ^ self! ! !PaginatedMorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 10/10/2011 11:08'! extent: newExtent self extent = newExtent ifTrue: [^ self]. super extent: newExtent. self updatePager. ! ! !PaginatedMorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 10/10/2011 10:52'! adoptPaneColor: paneColor "Pass on to the selection, the border and on the eventual pager too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self pager ifNotNil: [:p | p color: self pagerColor]! ! !PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 10:57'! addNavigationPane: aNavigPane pager := aNavigPane. self addMorph: pager. pager buildPanel. self updatePager. self changed! ! !PaginatedMorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 10/10/2011 11:06'! innerBounds | inner | inner := super innerBounds. inner := inner withBottom: inner bottom - self pagerHeight. ^ inner! ! !PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 10:55'! pageSize: aPageSize self pager ifNil: [aPageSize ifNotNil: [self addNavigationPane: (MorphTreePager on: self pageSize: aPageSize)]] ifNotNil: [aPageSize ifNil: [self removePager] ifNotNil: [self pager changePageSize: aPageSize]]! ! !PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 10:58'! updatePager self pager ifNotNil: [self pager buildPanel]! ! !PaginatedMorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/10/2011 11:07'! buildContents super buildContents. self updatePager! ! !PaginatedMorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 10:54'! currentNodelist "The nodeList currently viewed (not the full node list if a pager is used)" ^ self pager ifNil: [super nodeList] ifNotNil: [self pager currentNodelist]! ! !PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 10:55'! pagerHeight ^ self pager ifNil: [0] ifNotNil: [pager computedHeight]! ! !PaginatedMorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/10/2011 11:08'! updateContentsWithPreviouslyExpanded: aNodeList super updateContentsWithPreviouslyExpanded: aNodeList. self updatePager! ! !PaginatedMorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 10/10/2011 11:06'! vScrollBarHeight ^ super vScrollBarHeight - self pagerHeight! ! !PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 10:57'! chunkSize: aPageSize self pager ifNil: [aPageSize ifNotNil: [self addNavigationPane: (MorphTreeChunkPager on: self pageSize: aPageSize)]] ifNotNil: [aPageSize ifNil: [self removePager] ifNotNil: [self pager changePageSize: aPageSize]]! ! !PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 10:55'! pager ^ pager ! ! !PaginatedMorphTreeMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 10/10/2011 10:56'! vScrollBarValue: scrollValue super vScrollBarValue: scrollValue. self pager ifNotNil: [:p | p vScrollBarValue: scrollValue]! ! !PaginatedMorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 10/10/2011 11:05'! hResizeScrollBar super hResizeScrollBar. hScrollBar bounds: ((hScrollBar bounds withTop: (hScrollBar top - self pagerHeight)) withBottom: (hScrollBar bottom - self pagerHeight))! ! !PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 10:56'! removePager self pager ifNotNil: [ self removeMorph: self pager. pager := nil. self updateList. self resizerChanged]. ! ! !PaginatedMorphTreeMorphTests methodsFor: 'tests' stamp: 'AlainPlantec 10/18/2013 11:05'! testPager "This test demonstrate a paginating morphTreeMorph in action." | treeMorph aWindow aModel | aModel := PaginatedMorphTreeModel itemsList: (1 to: 100) asArray. aWindow := aModel theme newWindowIn: World for: aModel title: 'test'. treeMorph := aModel defaultTreeMorph. treeMorph pageSize: 30. treeMorph buildContents. aWindow addMorph: treeMorph fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 1) offsets: (0 @ 0 corner: 0 @ 0)). aWindow open. aModel expandItemPath: { 40 }. self assert: treeMorph pager currentPage == 2. aWindow close! ! !PaneScrolling commentStamp: ''! I am an announcement raised when a scroll pane is scrolled. My two attributes are - step: a point representing the scrollbar movement - scrollPane: a pointer to the widget raising the announcement! !PaneScrolling methodsFor: 'accessing' stamp: 'MartinDias 7/16/2013 17:52'! step ^ step! ! !PaneScrolling methodsFor: 'accessing' stamp: 'MartinDias 7/16/2013 17:53'! scrollPane ^ scrollPane! ! !PaneScrolling methodsFor: 'accessing' stamp: 'MartinDias 7/16/2013 17:52'! step: anObject step := anObject! ! !PaneScrolling methodsFor: 'accessing' stamp: 'MartinDias 7/16/2013 17:53'! scrollPane: anObject scrollPane := anObject! ! !PanelMorph commentStamp: 'gvc 5/18/2007 12:38'! A container morph that tracks the owner's pane colour unless an explicit fillStyle is specified. Additionally allows hooking of mouseOver events (no button down).! !PanelMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/12/2007 10:49'! initialColorInSystemWindow: aSystemWindow "Answer the colour the receiver should be when added to a SystemWindow." ^Color transparent! ! !PanelMorph methodsFor: 'initialize' stamp: 'gvc 7/27/2006 10:36'! defaultColor "Answer the default color for the receiver." ^Color transparent! ! !PanelMorph methodsFor: 'protocol' stamp: 'gvc 3/4/2010 12:21'! interactionState: aSymbol "Pass on to submorphs." self submorphsDo: [:m | (m respondsTo: #interactionState:) ifTrue: [ m interactionState: aSymbol]]! ! !PanelMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 4/1/2014 13:05'! isResizeableMorph: submorph forSplitter: e | done | done := e splitsTopAndBottom ifTrue: [ submorph layoutFrame isVerticallyResizeable ] ifFalse: [ submorph layoutFrame isHorizontallyResizeable ]. ^ done! ! !PanelMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 4/1/2014 13:18'! checkSplitters (self submorphsSatisfying: [ :e | e isKindOf: ProportionalSplitterMorph ]) do: [ :splitter | self checkMorphsLeftOrTopFrom: splitter. self checkMorphsRightOrBottomFrom: splitter ]! ! !PanelMorph methodsFor: 'protocol' stamp: 'gvc 5/1/2007 17:26'! mouseOver: anEvent "Handle a mouseOver event, meaning the mouse just moved within the receiver with no button pressed. The default response is to let my eventHandler, if any, handle it." self eventHandler ifNotNil: [self eventHandler mouseOver: anEvent fromMorph: self]! ! !PanelMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 7/31/2012 15:47'! newHSplitter ^ ProportionalSplitterMorph new beSplitsTopAndBottom; setProperty: #model toValue: self.! ! !PanelMorph methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:54'! adoptPaneColor: paneColor "Change our color too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self assureExtension. extension fillStyle ifNil: [self color: paneColor]. self borderStyle baseColor: paneColor darker! ! !PanelMorph methodsFor: 'event handling' stamp: 'gvc 5/1/2007 17:25'! on: eventName send: selector to: recipient "Register a recipient for handling an event." self eventHandler ifNil: [self eventHandler: EventHandlerPlus new]. self eventHandler on: eventName send: selector to: recipient! ! !PanelMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'IgorStasenko 12/19/2012 18:00'! newHSplitterAt: anIndex | above frame splitter index size | size := submorphs size. index := size - anIndex + 2. above := self submorphs at: index. frame := above layoutFrame. splitter := self newHSplitter. splitter layoutFrame: ((frame leftFraction @ frame bottomFraction corner: frame rightFraction @ frame bottomFraction) asLayoutFrame bottomOffset: 4). self privateAddMorph: splitter atIndex: (size - anIndex + 2)! ! !PanelMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 4/1/2014 13:19'! checkMorphsLeftOrTopFrom: splitter | index size | size := submorphs size. index := submorphs identityIndexOf: splitter. index := index + 1. [ index <= size ] whileTrue: [ | submorph done | submorph := submorphs at: index. splitter addLeftOrTop: submorph. done := self isResizeableMorph: submorph forSplitter: splitter. done ifTrue: [ index := size + 1 ]. index := index + 1 ]! ! !PanelMorph methodsFor: 'initialization' stamp: 'gvc 1/16/2007 12:33'! initialize "Initialize the receiver." super initialize. self clipSubmorphs: true; beSticky "stop being grabbed"! ! !PanelMorph methodsFor: 'event handling' stamp: 'gvc 5/1/2007 17:26'! on: eventName send: selector to: recipient withValue: value "Register a recipient for handling an event." self eventHandler ifNil: [self eventHandler: EventHandlerPlus new]. self eventHandler on: eventName send: selector to: recipient withValue: value ! ! !PanelMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'IgorStasenko 12/19/2012 18:01'! newVSplitterAt: anIndex | left frame splitter index size | size := submorphs size. index := size - anIndex + 2. left := self submorphs at: index. frame := left layoutFrame. splitter := self newVSplitter. splitter layoutFrame: ((frame rightFraction @ frame topFraction corner: frame rightFraction @ frame bottomFraction) asLayoutFrame rightOffset: 4). self privateAddMorph: splitter atIndex: (size - anIndex + 2)! ! !PanelMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 4/1/2014 13:17'! checkMorphsLeftOrTopFrom: splitter size: size | index | index := submorphs identityIndexOf: splitter. index := index + 1. [ index <= size ] whileTrue: [ | submorph done | submorph := submorphs at: index. splitter addLeftOrTop: submorph. done := self isResizeableMorph: submorph forSplitter: splitter. done ifTrue: [ index := size + 1 ]. index := index + 1 ]! ! !PanelMorph methodsFor: 'protocol' stamp: 'StephaneDucasse 5/31/2013 17:50'! enabled: aBoolean "Pass on to submorphs." self submorphsDo: [:m | m enabled: aBoolean]! ! !PanelMorph methodsFor: 'events-processing' stamp: 'GaryChambers 7/29/2011 15:29'! handleMouseOver: anEvent "System level event handling." super handleMouseOver: anEvent. (self handlesMouseOver: anEvent) ifTrue:[ anEvent wasHandled: true. self mouseOver: anEvent]! ! !PanelMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 4/1/2014 13:16'! checkMorphsRightOrBottomFrom: splitter | index | index := submorphs identityIndexOf: splitter. index := index - 1. [ index > 0 ] whileTrue: [ | submorph done | submorph := submorphs at: index. splitter addRightOrBottom: submorph. done := self isResizeableMorph: submorph forSplitter: splitter. done ifTrue: [ index := 0 ]. index := index - 1 ]! ! !PanelMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 7/31/2012 15:47'! newVSplitter ^ ProportionalSplitterMorph new setProperty: #model toValue: self.! ! !PanelMorph methodsFor: 'initialization' stamp: 'gvc 7/26/2006 17:31'! defaultBorderWidth "Answer the default border width for the receiver." ^0! ! !PanelMorphWithSplitters commentStamp: ''! A PanelMorphWithSplitters is which add splitters the way SystemWindow do it! !PanelMorphWithSplitters methodsFor: 'private' stamp: 'IgorStasenko 12/19/2012 18:13'! addPaneHSplitterBetween: topMorphs and: bottomMorphs "Add a horizontal splitter for the given morphs that share a common bottom fraction. If there is a horizontal discontinuity apply the splitter to the first contiguous group. Answer the morphs to which the splitter was applied." |targetY fixed rightFraction leftFrame rightFrame sorted morph topGroup bottomGroup splitter offset| topMorphs ifEmpty: [^self]. targetY := topMorphs first layoutFrame bottomFraction. fixed := topMorphs select: [:m | m layoutFrame topFraction = m layoutFrame bottomFraction]. "fixed morphs appear in both top and bottom" sorted := ((topMorphs reject: [:m | m layoutFrame topFraction = m layoutFrame bottomFraction]) asSortedCollection: [:a :b | a layoutFrame rightFraction = b layoutFrame rightFraction ifTrue: [a layoutFrame leftFraction <= b layoutFrame leftFraction] ifFalse: [a layoutFrame rightFraction <= b layoutFrame rightFraction]]) readStream. sorted contents ifEmpty: [^fixed]. topGroup := OrderedCollection new. rightFraction := sorted contents first layoutFrame leftFraction. [sorted atEnd or: [morph := sorted next. (morph layoutFrame leftFraction ~= rightFraction and: [ morph layoutFrame rightFraction ~= rightFraction])]] whileFalse: [ topGroup add: morph. rightFraction := morph layoutFrame rightFraction]. leftFrame := topGroup first layoutFrame. rightFrame := topGroup last layoutFrame. bottomGroup := (bottomMorphs reject: [:m | m layoutFrame topFraction = m layoutFrame bottomFraction]) select: [:m | (m layoutFrame leftFraction between: leftFrame leftFraction and: rightFrame rightFraction) or: [ m layoutFrame rightFraction between: leftFrame leftFraction and: rightFrame rightFraction]]. offset := (topGroup collect: [:m | m layoutFrame bottomOffset]) max. splitter := ProportionalSplitterMorph new beSplitsTopAndBottom. splitter layoutFrame: ( (leftFrame leftFraction @ targetY corner: rightFrame rightFraction @ targetY) asLayoutFrame leftOffset: leftFrame leftOffset; rightOffset: rightFrame rightOffset; topOffset: offset; bottomOffset: 4+offset ). topGroup := topGroup, fixed. topGroup do: [:m | splitter addLeftOrTop: m]. bottomGroup do: [:m | splitter addRightOrBottom: m]. self addMorphBack: splitter. ^topGroup! ! !PanelMorphWithSplitters methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:06'! initialize super initialize. paneMorphs := OrderedCollection new.! ! !PanelMorphWithSplitters methodsFor: 'private' stamp: ''! addPaneHSplitters "Add the horizontal pane splitters." |remaining targetBottom sameBottom sameTop| remaining := paneMorphs reject: [:each | each layoutFrame bottomFraction = 1 or: [ each layoutFrame bottomFraction = 0]]. [remaining notEmpty] whileTrue: [ targetBottom := remaining first layoutFrame bottomFraction. sameBottom := remaining select: [:each | each layoutFrame bottomFraction = targetBottom]. sameTop := paneMorphs select: [:each | each layoutFrame topFraction = targetBottom]. remaining := remaining copyWithoutAll: (self addPaneHSplitterBetween: sameBottom and: sameTop)]! ! !PanelMorphWithSplitters methodsFor: 'private' stamp: 'IgorStasenko 12/19/2012 18:13'! addPaneVSplitterBetween: leftMorphs and: rightMorphs "Add a vertical splitter for the given morphs that share a common right fraction. If there is a vertical discontinuity apply the splitter to the first contiguous group. Answer the morphs to which the splitter was applied." |targetX fixed bottomFraction topFrame bottomFrame sorted morph leftGroup rightGroup splitter offset| leftMorphs ifEmpty: [^self]. targetX := leftMorphs first layoutFrame rightFraction. fixed := leftMorphs select: [:m | m layoutFrame leftFraction = m layoutFrame rightFraction]. "fixed morphs appear in both top and bottom" sorted := ((leftMorphs reject: [:m | m layoutFrame leftFraction = m layoutFrame rightFraction]) asSortedCollection: [:a :b | a layoutFrame bottomFraction = b layoutFrame bottomFraction ifTrue: [a layoutFrame topFraction <= b layoutFrame topFraction] ifFalse: [a layoutFrame bottomFraction <= b layoutFrame bottomFraction]]) readStream. sorted contents ifEmpty: [^fixed]. leftGroup := OrderedCollection new. bottomFraction := sorted contents first layoutFrame topFraction. [sorted atEnd or: [morph := sorted next. morph layoutFrame topFraction ~= bottomFraction and: [ morph layoutFrame bottomFraction ~= bottomFraction]]] whileFalse: [ leftGroup add: morph. bottomFraction := morph layoutFrame bottomFraction]. topFrame := leftGroup first layoutFrame. bottomFrame := leftGroup last layoutFrame. rightGroup := (rightMorphs reject: [:m | m layoutFrame leftFraction = m layoutFrame rightFraction]) select: [:m | m layoutFrame topFraction between: topFrame topFraction and: bottomFrame bottomFraction]. offset := (leftGroup collect: [:m | m layoutFrame rightOffset]) max. splitter := ProportionalSplitterMorph new. splitter layoutFrame: ((targetX @ topFrame topFraction corner: targetX @ bottomFrame bottomFraction) asLayoutFrame leftOffset: offset; topOffset: topFrame topOffset; rightOffset: 4+offset; bottomOffset: bottomFrame bottomOffset). leftGroup := leftGroup, fixed. leftGroup do: [:m | splitter addLeftOrTop: m]. rightGroup do: [:m | splitter addRightOrBottom: m]. self addMorphBack: splitter. ^leftGroup! ! !PanelMorphWithSplitters methodsFor: 'submorphs-add/remove' stamp: ''! addMorph: aMorph fullFrame: aLayout paneMorphs add: aMorph. super addMorph: aMorph fullFrame: aLayout! ! !PanelMorphWithSplitters methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/23/2012 17:01'! addPaneSplitters "Add the vertical and horizontal pane splitters." self removePaneSplitters. self addPaneVSplitters. self addPaneHSplitters. self linkSplittersToSplitters! ! !PanelMorphWithSplitters methodsFor: 'private' stamp: ''! addPaneVSplitters "Add the vertical pane splitters." |remaining targetRight sameRight sameLeft | remaining := paneMorphs reject: [:each | each layoutFrame rightFraction = 1 or: [ each layoutFrame rightFraction = 0]]. [remaining notEmpty] whileTrue: [ targetRight := remaining first layoutFrame rightFraction. sameRight := remaining select: [:each | each layoutFrame rightFraction = targetRight]. sameLeft := paneMorphs select: [:each | each layoutFrame leftFraction = targetRight and: [ each layoutFrame rightFraction ~= targetRight]]. remaining := remaining copyWithoutAll: (self addPaneVSplitterBetween: sameRight and: sameLeft)]! ! !PanelMorphWithSplitters methodsFor: 'private' stamp: ''! linkSplittersToSplitters "The pane morphs are already linked. Cross link the splitters as appropriate." self splitters do: [:each | each splitsTopAndBottom ifTrue: [self splitters do: [:eachMorph | eachMorph splitsTopAndBottom ~= each splitsTopAndBottom ifTrue: [ eachMorph layoutFrame bottomFraction = each layoutFrame topFraction ifTrue: [each addLeftOrTop: eachMorph]. eachMorph layoutFrame topFraction = each layoutFrame bottomFraction ifTrue: [each addRightOrBottom: eachMorph]]]] ifFalse: [self splitters do: [:eachMorph | eachMorph splitsTopAndBottom ~= each splitsTopAndBottom ifTrue: [ eachMorph layoutFrame rightFraction = each layoutFrame leftFraction ifTrue: [each addLeftOrTop: eachMorph]. eachMorph layoutFrame leftFraction = each layoutFrame rightFraction ifTrue: [each addRightOrBottom: eachMorph]]]]. each comeToFront.]! ! !PanelMorphWithSplitters methodsFor: 'submorphs-add/remove' stamp: 'BenjaminVanRyseghem 3/23/2012 17:00'! addMorph: aMorph paneMorphs add: aMorph. ^ super addMorph: aMorph! ! !PanelMorphWithSplitters methodsFor: 'layout-properties' stamp: ''! layoutFrame: aFrame self activate. super layoutFrame: aFrame! ! !Paragraph commentStamp: 'AlainPlantec 9/15/2011 16:13'! A Paragraph represents text that has been laid out, or composed, in some container. I also display the different kinds of text selection (secondary, find-replace and selection bar). Class collaborations SelectionBlock instances are built by myself and stored in the extraSelectionBlocks instance variable in order to display supplementary selections Class main API no particular main API. Instance Variables extraSelectionBlocks: findReplaceSelectionRegex: presentationLines: presentationText: refreshExtraSelection: secondarySelection: extraSelectionBlocks - a collection of SelectionBlock for the drowing of the differents kind of text selection findReplaceSelectionRegex - the find/replace matcher that is set from the editor of by the FindReplaceService presentationLines - created for debugging purpose, should be removed ? presentationText - created for debugging purpose, should be removed ? refreshExtraSelection - a boolean that is set to tru when there is a need to refresh selections secondarySelection - the string of the secondary selection that is set from the editor when a portion of text is selected text A Text with encoded per-character emphasis. textStyle A TextStyle with font set, line height and horizontal alignment. firstCharacterIndex The starting index in text for this paragraph, allowing composition of a long text into a number of containers. container A Rectangle or TextContainer that determines where text can go. lines An Array of TextLines comprising the final layout of the text after it has been composed within its container. positionWhenComposed As its name implies. Allows display at new locations without the need to recompose the text. Lines are ordered vertically. However, for a given y, there may be several lines in left to right order. Lines must never be empty, even if text is empty. Notes on yet another hack - 5 Feb 2001 We really need to clean up #composeLinesFrom:to:delta:into:priorLines:atY:!!!!!! I added one more habdful of code to correct: This is an annoying bug that's been around for a couple of years, but I finally figured out how to duplicate the problem, so I figured I'd just report it now. (It doesn't necessarily have to be fixed for 3.0 if it looks messy, but if it's a simple fix, it would be worth it.) In Morphic, if you have the following text in a workspace: This is line 1 This is line 2 **and** you have a return character after line 2, you will normally be able to click the mouse two times below line 2 in order to select all the text. If you edit line 2 (e.g. so that it reads "line number 2"), you can still select all the text by clicking below the second line. However, if you edit line 1, you will not be able to select all the text from the bottom in the same way. Things get messed up such that the last return character seems to be gone. In this state, if you position the cursor immediately after the 2, and press the right arrow, the cursor jumps to the beginning of line 2... oof. (report by Doug Way) While I don't have a very deep understanding of the above mentioned method, I was able to determine that text ending in a CR worked better in the editor when the last entry in had a start of text size + 1 and a stop of text size. I have accordingly added code near the end to ensure this. It seems to have fixed the problem, but we do need to clean this baby up some day. - Bob ! !Paragraph methodsFor: 'private' stamp: 'di 10/21/97 21:36'! positionWhenComposed: pos positionWhenComposed := pos! ! !Paragraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! rightFlush textStyle rightFlush! ! !Paragraph methodsFor: 'private' stamp: 'di 5/21/1998 21:47'! textStyle: ts lines: l text: t "Private -- just a service for deepCopy" textStyle := ts. lines := l. text := t.! ! !Paragraph methodsFor: 'editing' stamp: 'GabrielOmarCotelli 11/30/2013 17:08'! actionAttributesUnder: aClickPoint event: anEvent do: aBlock | startBlock | startBlock := self characterBlockAtPoint: aClickPoint. (text attributesAt: startBlock stringIndex forStyle: textStyle) select: [ :attribute | attribute mayActOnEvent: anEvent ] thenDo: [ :attribute | | range boxes | "find the boxes for the current attribute range" range := text rangeOf: attribute startingAt: startBlock stringIndex. boxes := self selectionRectsFrom: (self characterBlockForIndex: range first) to: (self characterBlockForIndex: range last + 1). boxes detect: [ :each | each containsPoint: aClickPoint ] ifFound: [ aBlock cull: attribute cull: boxes ] ]! ! !Paragraph methodsFor: 'editing' stamp: 'CamilloBruni 2/2/2012 00:19'! move: anEvent for: model controller: editor "Give sensitive text a chance to fire. Display flash: (100@100 extent: 100@100)." | action clickPoint | clickPoint := anEvent cursorPoint. action := false. self actionAttributesUnder: clickPoint event: anEvent do: [ :attribute| |target| "evaluate the attribute action" target := (model ifNil: [editor morph]). (attribute actOnMove: anEvent for: target in: self editor: editor) == true ifTrue: [ ^ true ]]. (action and: [ Cursor currentCursor == Cursor webLink]) ifTrue:[ Cursor normal show ]. ^ action! ! !Paragraph methodsFor: 'composition' stamp: 'AlainPlantec 9/20/2011 10:08'! recomposeFrom: start to: stop delta: delta "Recompose this paragraph. The altered portion is between start and stop. Recomposition may continue to the end of the text, due to a ripple effect. Delta is the amount by which the current text is longer than it was when its current lines were composed." "Have to recompose line above in case a word-break was affected." | startLine newLines | startLine := (self lineIndexForCharacter: start) - 1 max: 1. [startLine > 1 and: [(lines at: startLine - 1) top = (lines at: startLine) top]] whileTrue: [startLine := startLine - 1]. "Find leftmost of line pieces" newLines := OrderedCollection new: lines size + 1. 1 to: startLine - 1 do: [:i | newLines addLast: (lines at: i)]. text string isOctetString ifTrue: [ ^ self composeLinesFrom: (lines at: startLine) first to: stop delta: delta into: newLines priorLines: lines atY: (lines at: startLine) top. ]. self multiComposeLinesFrom: (lines at: startLine) first to: stop delta: delta into: newLines priorLines: lines atY: (lines at: startLine) top! ! !Paragraph methodsFor: 'access' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme ^ Smalltalk ui theme! ! !Paragraph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/8/2012 04:21'! drawOnAthensCanvas: aCanvas bounds: aRectangle "do nothing"! ! !Paragraph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:12'! initialize super initialize. self positionWhenComposed: 0 @ 0! ! !Paragraph methodsFor: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! secondarySelection: aSubString secondarySelection := aSubString. ! ! !Paragraph methodsFor: 'private' stamp: 'di 4/14/98 13:17'! fastFindFirstLineSuchThat: lineBlock "Perform a binary search of the lines array and return the index of the first element for which lineBlock evaluates as true. This assumes the condition is one that goes from false to true for increasing line numbers (as, eg, yval > somey or start char > somex). If lineBlock is not true for any element, return size+1." | index low high | low := 1. high := lines size. [index := high + low // 2. low > high] whileFalse: [(lineBlock value: (lines at: index)) ifTrue: [high := index - 1] ifFalse: [low := index + 1]]. ^ low! ! !Paragraph methodsFor: 'private' stamp: 'di 4/14/98 13:11'! lineIndexForCharacter: index "Answer the index of the line in which to select the character at index." ^ (self fastFindFirstLineSuchThat: [:line | line first > index]) - 1 max: 1! ! !Paragraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:04'! wantsColumnBreaks ^wantsColumnBreaks! ! !Paragraph methodsFor: 'composition' stamp: 'di 10/22/97 11:13'! compositionRectangle ^ container! ! !Paragraph methodsFor: 'access' stamp: 'jm 11/19/97 20:27'! textOwner: ignored "See TextOnCurve"! ! !Paragraph methodsFor: 'private' stamp: 'edc 6/18/2004 09:10'! moveBy: delta lines do: [:line | line moveBy: delta]. positionWhenComposed ifNotNil:[ positionWhenComposed := positionWhenComposed + delta]. container := container translateBy: delta! ! !Paragraph methodsFor: 'private' stamp: 'FernandoOlivero 6/15/2010 13:46'! adjustBottomY | heights bottomY verticalSize | heights := lines collect:[:each| each lineHeight ]. verticalSize := heights sum. bottomY := container top + verticalSize. container := container withBottom: bottomY.! ! !Paragraph methodsFor: 'selection' stamp: 'nice 10/29/2013 02:37'! characterBlockAtPoint: aPoint "Answer a CharacterBlock for the character in the text at aPoint." | line | line := lines at: (self lineIndexForPoint: aPoint). ^ (CharacterBlockScanner new text: text textStyle: textStyle) characterBlockAtPoint: aPoint index: nil in: line! ! !Paragraph methodsFor: 'display' stamp: 'tbn 8/5/2009 10:01'! displaySelectionInLine: line on: aCanvas | leftX rightX w caretColor | selectionStart ifNil: [^self]. "No selection" aCanvas isShadowDrawing ifTrue: [ ^self ]. "don't draw selection with shadow" selectionStart = selectionStop ifTrue: ["Only show caret on line where clicked" selectionStart textLine ~= line ifTrue: [^self]] ifFalse: ["Test entire selection before or after here" (selectionStop stringIndex < line first or: [selectionStart stringIndex > (line last + 1)]) ifTrue: [^self]. "No selection on this line" (selectionStop stringIndex = line first and: [selectionStop textLine ~= line]) ifTrue: [^self]. "Selection ends on line above" (selectionStart stringIndex = (line last + 1) and: [selectionStop textLine ~= line]) ifTrue: [^self]]. "Selection begins on line below" leftX := (selectionStart stringIndex < line first ifTrue: [line ] ifFalse: [selectionStart ])left. rightX := (selectionStop stringIndex > (line last + 1) or: [selectionStop stringIndex = (line last + 1) and: [selectionStop textLine ~= line]]) ifTrue: [line right] ifFalse: [selectionStop left]. selectionStart = selectionStop ifTrue: [rightX := rightX + 1. w := self caretWidth. caretRect := (leftX-w) @ line top corner: (rightX+w)@ line bottom. self showCaret ifFalse:[^self]. caretColor := self insertionPointColor. 1 to: w do: [:i | "Draw caret triangles at top and bottom" aCanvas fillRectangle: ((leftX - w + i - 1) @ (line top + i - 1) extent: ((w - i) * 2 + 3) @ 1) color: caretColor. aCanvas fillRectangle: ((leftX - w + i - 1) @ (line bottom - i) extent: ((w - i) * 2 + 3) @ 1) color: caretColor]. aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom) color: caretColor] ifFalse: [caretRect := nil. aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom) color: self selectionColor]! ! !Paragraph methodsFor: 'display' stamp: 'AlainPlantec 9/15/2011 15:57'! displayExtraSelectionOn: aCanvas "Send all visible lines to the displayScanner for display" | visibleRectangle line | visibleRectangle := aCanvas clipRect. refreshExtraSelection = true ifTrue: [self buildSelectionBlocksFrom: visibleRectangle topLeft to: visibleRectangle bottomRight. refreshExtraSelection := false]. extraSelectionBlocks ifNotNil: [ (self lineIndexForPoint: visibleRectangle topLeft) to: (self lineIndexForPoint: visibleRectangle bottomRight) do: [:i | line := lines at: i. extraSelectionBlocks do: [:selblock | self displaySelectionBlock: selblock inLine: line on: aCanvas]]]! ! !Paragraph methodsFor: 'selection' stamp: 'IgorStasenko 1/14/2011 13:44'! selectionColor: aColor "ignored"! ! !Paragraph methodsFor: 'access' stamp: 'AlainPlantec 10/24/2010 14:30'! caretWidth ^ Editor dumbbellCursor ifTrue: [ 2 ] ifFalse: [ 0 ]! ! !Paragraph methodsFor: 'access' stamp: 'sbw 10/13/1999 22:31'! numberOfLines ^lines size! ! !Paragraph methodsFor: 'access' stamp: 'di 10/23/97 21:01'! lastCharacterIndex ^ lines last last! ! !Paragraph methodsFor: 'selection' stamp: 'di 12/2/97 19:57'! selectionStart: startBlock selectionStop: stopBlock selectionStart := startBlock. selectionStop := stopBlock.! ! !Paragraph methodsFor: 'access' stamp: 'di 10/24/97 17:38'! extent ^ container width @ (lines last bottom - lines first top)! ! !Paragraph methodsFor: 'editing' stamp: 'CamilloBruni 2/2/2012 00:19'! click: anEvent for: model controller: editor "Give sensitive text a chance to fire. Display flash: (100@100 extent: 100@100)." | action clickPoint | clickPoint := anEvent cursorPoint. action := false. self actionAttributesUnder: clickPoint event: anEvent do: [ :attribute| |target| "evaluate the attribute action" target := (model ifNil: [editor morph]). (attribute actOnClick: anEvent for: target in: self editor: editor) == true ifTrue: [ ^ true ]]. (action and: [ Cursor currentCursor == Cursor webLink]) ifTrue:[ Cursor normal show ]. ^ action! ! !Paragraph methodsFor: 'private' stamp: 'di 11/8/97 15:47'! adjustLineIndicesBy: delta firstCharacterIndex := firstCharacterIndex + delta. lines do: [:line | line slide: delta]. ! ! !Paragraph methodsFor: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! selectionBarColor ^ self theme selectionBarColor! ! !Paragraph methodsFor: 'private' stamp: 'RAA 8/30/1998 15:04'! lineIndexOfCharacterIndex: characterIndex "Answer the line index for a given characterIndex." "apparently the selector changed with NewParagraph" ^self lineIndexForCharacter: characterIndex ! ! !Paragraph methodsFor: 'private' stamp: 'di 10/26/97 15:57'! adjustRightX | shrink | shrink := container right - maxRightX. lines do: [:line | line paddingWidth: (line paddingWidth - shrink)]. container := container withRight: maxRightX! ! !Paragraph methodsFor: 'selection' stamp: 'di 10/5/1998 12:59'! defaultCharacterBlock ^ (CharacterBlock new stringIndex: firstCharacterIndex text: text topLeft: lines first topLeft extent: 0 @ 0) textLine: lines first! ! !Paragraph methodsFor: 'access' stamp: 'di 11/8/97 15:41'! firstCharacterIndex ^ firstCharacterIndex! ! !Paragraph methodsFor: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! extraSelectionChanged refreshExtraSelection := true! ! !Paragraph methodsFor: 'private' stamp: 'di 4/14/98 13:13'! lineIndexForPoint: aPoint "Answer the index of the line in which to select the character nearest to aPoint." | i py | py := aPoint y truncated. "Find the first line at this y-value" i := (self fastFindFirstLineSuchThat: [:line | line bottom > py]) min: lines size. "Now find the first line at this x-value" [i < lines size and: [(lines at: i+1) top = (lines at: i) top and: [aPoint x >= (lines at: i+1) left]]] whileTrue: [i := i + 1]. ^ i! ! !Paragraph methodsFor: 'display' stamp: 'AlainPlantec 9/15/2011 15:57'! displaySelectionBlock: aSelBlock inLine: line on: aCanvas "Display a SelectionBlock if it does not overlap vith the regular selection" (selectionStart notNil and: [selectionStop notNil and: [selectionStart ~= selectionStop]]) ifTrue: [ | startIdx stopIdx selSartIdx selStopIdx selBlockRange selRange | startIdx := aSelBlock first stringIndex. stopIdx := aSelBlock last stringIndex. selSartIdx := selectionStart stringIndex. selStopIdx := selectionStop stringIndex. selBlockRange := (startIdx) to: (stopIdx). selRange := (selSartIdx) to: (selStopIdx). ((selBlockRange rangeIncludes: selSartIdx + 1) or: [(selBlockRange rangeIncludes: selStopIdx - 1) or: [(selRange rangeIncludes: startIdx + 1) or: [selRange rangeIncludes: stopIdx - 1]]]) ifTrue: [^ self]]. "regular selection and this selection block overlap" aSelBlock displayInLine: line on: aCanvas ! ! !Paragraph methodsFor: 'selection' stamp: 'CamilloBruni 2/6/2012 23:28'! selectionContainsPoint: aPoint "return whether the current selection contains the given point" ^ self selectionRects anySatisfy: [ :rect| rect containsPoint: aPoint ]! ! !Paragraph methodsFor: 'private' stamp: 'nice 11/17/2009 00:59'! indentationOfLineIndex: lineIndex ifBlank: aBlock "Answer the number of leading tabs in the line at lineIndex. If there are no visible characters, pass the number of tabs to aBlock and return its value. If the line is word-wrap overflow, back up a line and recur." | arrayIndex first last crlf | crlf := CharacterSet crlf. arrayIndex := lineIndex. [first := (lines at: arrayIndex) first. first > 1 and: [crlf includes: (text string at: first - 1)]] whileTrue: "word wrap" [arrayIndex := arrayIndex - 1]. last := (lines at: arrayIndex) last. ^(text string copyFrom: first to: last) indentationIfBlank: aBlock. ! ! !Paragraph methodsFor: 'access' stamp: 'AlainPlantec 9/15/2011 17:15'! composer ^ composer ifNil: [composer := TextComposer new]! ! !Paragraph methodsFor: 'editing' stamp: 'di 4/28/1999 10:14'! replaceFrom: start to: stop with: aText displaying: displayBoolean "Edit the text, and then recompose the lines." text replaceFrom: start to: stop with: aText. self recomposeFrom: start to: start + aText size - 1 delta: aText size - (stop-start+1)! ! !Paragraph methodsFor: 'private' stamp: 'di 10/24/97 17:40'! lines ^ lines! ! !Paragraph methodsFor: 'composition' stamp: 'AlainPlantec 9/15/2011 15:56'! multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" | newResult | newResult := self composer multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY textStyle: textStyle text: text container: container wantsColumnBreaks: wantsColumnBreaks == true. lines := newResult first asArray. "maxRightX printString displayAt: 0@0." ^ maxRightX := newResult second. ! ! !Paragraph methodsFor: 'access' stamp: 'sw 1/13/98 21:31'! string ^ text string! ! !Paragraph methodsFor: 'access' stamp: 'di 11/16/97 09:02'! adjustedFirstCharacterIndex "Return the index in the text where this paragraph WOULD begin if nothing had changed, except the size of the text -- ie if there have only been an insertion of deletion in the preceding morphs" offsetToEnd ifNil: [^ -1]. ^ text size - offsetToEnd! ! !Paragraph methodsFor: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! findReplaceSelectionColor ^ self theme currentSettings findReplaceSelectionColor ! ! !Paragraph methodsFor: 'access' stamp: 'di 10/21/97 14:39'! text ^ text! ! !Paragraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! leftFlush textStyle leftFlush! ! !Paragraph methodsFor: 'selection' stamp: 'FernandoOlivero 4/12/2011 10:11'! selectionColor ^ self focused ifTrue: [self theme selectionColor] ifFalse: [self theme unfocusedSelectionColor]. ! ! !Paragraph methodsFor: 'composition' stamp: 'di 11/8/97 15:31'! compose: t style: ts from: startingIndex in: textContainer text := t. textStyle := ts. firstCharacterIndex := startingIndex. offsetToEnd := text size - firstCharacterIndex. container := textContainer. self composeAll! ! !Paragraph methodsFor: 'composition' stamp: 'AlainPlantec 9/15/2011 13:40'! composeAll ^ self multiComposeLinesFrom: firstCharacterIndex to: text size delta: 0 into: OrderedCollection new priorLines: Array new atY: container top ! ! !Paragraph methodsFor: 'composition' stamp: 'AlainPlantec 9/15/2011 17:16'! composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" | newResult | newResult := self composer composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY textStyle: textStyle text: text container: container wantsColumnBreaks: wantsColumnBreaks == true. lines := newResult first asArray. ^ maxRightX := newResult second. ! ! !Paragraph methodsFor: 'selection' stamp: 'nice 10/29/2013 02:38'! characterBlockForIndex: index "Answer a CharacterBlock for the character in text at index." | line | line := lines at: (self lineIndexForCharacter: index). ^ (CharacterBlockScanner new text: text textStyle: textStyle) characterBlockAtPoint: nil index: ((index max: line first) min: text size+1) in: line! ! !Paragraph methodsFor: 'access' stamp: 'rr 3/22/2004 12:41'! focused: aBoolean focused := aBoolean! ! !Paragraph methodsFor: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! hasExtraSelection "Return true if I've some findReplace or secondary selection" ^ extraSelectionBlocks isEmptyOrNil not ! ! !Paragraph methodsFor: 'selection' stamp: 'StephaneDucasse 10/13/2013 17:23'! selectionRectsFrom: characterBlock1 to: characterBlock2 "Return an array of rectangles representing the area between the two character blocks given as arguments." | line1 line2 rects cb1 cb2 w | characterBlock1 <= characterBlock2 ifTrue: [cb1 := characterBlock1. cb2 := characterBlock2] ifFalse: [cb2 := characterBlock1. cb1 := characterBlock2]. cb1 = cb2 ifTrue: [w := self caretWidth. ^ Array with: (cb1 topLeft - (w@0) corner: cb1 bottomLeft + ((w+1)@0))]. line1 := self lineIndexForCharacter: cb1 stringIndex. line2 := self lineIndexForCharacter: cb2 stringIndex. line1 = line2 ifTrue: [^ Array with: (cb1 topLeft corner: cb2 bottomRight)]. rects := OrderedCollection new. rects addLast: (cb1 topLeft corner: (lines at: line1) bottomRight). line1+1 to: line2-1 do: [ :i | | line | line := lines at: i. (line left = rects last left and: [ line right = rects last right ]) ifTrue: [ "new line has same margins as old one -- merge them, so that the caller gets as few rectangles as possible" | lastRect | lastRect := rects removeLast. rects add: (lastRect bottom: line bottom) ] ifFalse: [ "differing margins; cannot merge" rects add: line rectangle ] ]. rects addLast: ((lines at: line2) topLeft rectangle: cb2 bottomLeft). ^ rects! ! !Paragraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:03'! wantsColumnBreaks: aBoolean wantsColumnBreaks := aBoolean! ! !Paragraph methodsFor: 'composition' stamp: 'di 11/15/97 09:21'! composeAllStartingAt: characterIndex firstCharacterIndex := characterIndex. offsetToEnd := text size - firstCharacterIndex. self composeAll! ! !Paragraph methodsFor: 'access' stamp: 'tbn 8/5/2009 09:50'! caretRect "The rectangle in which the caret was last drawn, or nil if the last drawing drew a range-selection rather than insertion point." ^ caretRect! ! !Paragraph methodsFor: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! secondarySelectionColor ^ self theme currentSettings secondarySelectionColor ! ! !Paragraph methodsFor: 'display' stamp: 'AlainPlantec 11/17/2010 19:48'! displayOn: aCanvas using: displayScanner at: somePosition "Send all visible lines to the displayScanner for display" | visibleRectangle offset leftInRun line | visibleRectangle := aCanvas clipRect. offset := (somePosition - positionWhenComposed) truncated. leftInRun := 0. (self lineIndexForPoint: visibleRectangle topLeft) to: (self lineIndexForPoint: visibleRectangle bottomRight) do: [:i | line := lines at: i. self displaySelectionInLine: line on: aCanvas. line first <= line last ifTrue: [leftInRun := displayScanner displayLine: line offset: offset leftInRun: leftInRun]]. ! ! !Paragraph methodsFor: 'selection' stamp: 'jm 11/19/97 22:56'! containsPoint: aPoint ^ (lines at: (self lineIndexForPoint: aPoint)) rectangle containsPoint: aPoint! ! !Paragraph methodsFor: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! findReplaceSelectionRegex: aRegex findReplaceSelectionRegex := aRegex. ! ! !Paragraph methodsFor: 'access' stamp: 'di 10/21/97 14:39'! textStyle ^ textStyle! ! !Paragraph methodsFor: 'editing' stamp: 'FernandoOlivero 3/14/2010 22:29'! replaceFrom: start to: stop with: aText "Edit the text, and then recompose the lines." text replaceFrom: start to: stop with: aText. self recomposeFrom: start to: start + aText size - 1 delta: aText size - (stop-start+1)! ! !Paragraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! centered textStyle centered! ! !Paragraph methodsFor: 'copying' stamp: 'di 5/21/1998 21:45'! deepCopy "Don't want to copy the container (etc) or fonts in the TextStyle." | new | new := self copy. new textStyle: textStyle copy lines: lines copy text: text deepCopy. ^ new! ! !Paragraph methodsFor: 'display' stamp: 'AlainPlantec 9/15/2011 15:57'! displaySelectionBarOn: aCanvas | visibleRectangle line | selectionStart ifNil: [^ self]. selectionStop ifNil: [^ self]. visibleRectangle := aCanvas clipRect. selectionStart textLine = selectionStop textLine ifFalse: [^self]. line := selectionStart textLine. aCanvas fillRectangle: (visibleRectangle left @ line top corner: visibleRectangle right @ line bottom) color: self selectionBarColor! ! !Paragraph methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:47'! insertionPointColor self focused ifFalse: [^ Color transparent]. ^ Display depth <= 2 ifTrue: [Color black] ifFalse: [self class insertionPointColor]! ! !Paragraph methodsFor: 'selection' stamp: 'ThierryGoubier 1/8/2013 16:42'! buildSelectionBlocksFrom: topLeft to: bottomRight | viewedString primary topLeftBlk bottomRightBlk findReplaceIntervals secondarySelectionIntervals startIdx stopIdx | Display depth = 1 ifTrue: [ ^ self ]. Display depth = 2 ifTrue: [ ^ self ]. primary := selectionStart notNil ifTrue: [ selectionStart stringIndex to: selectionStop stringIndex - 1 ] ifFalse: [ 0 to: -1 ]. topLeftBlk := self characterBlockAtPoint: topLeft. bottomRightBlk := self characterBlockAtPoint: bottomRight. startIdx := topLeftBlk stringIndex. stopIdx := bottomRightBlk stringIndex. viewedString := (self text copyFrom: startIdx to: stopIdx) asString. self theme currentSettings haveSecondarySelectionTextColor ifTrue: [ self text removeAttribute: TextSelectionColor secondarySelection ]. self theme currentSettings haveFindReplaceSelectionTextColor ifTrue: [ self text removeAttribute: TextSelectionColor findReplaceSelection ]. findReplaceIntervals := #(). extraSelectionBlocks := Array streamContents: [ :strm | findReplaceSelectionRegex ifNotNil: [ findReplaceIntervals := findReplaceSelectionRegex matchingRangesIn: viewedString. findReplaceIntervals := (findReplaceIntervals collect: [ :r | r + topLeftBlk stringIndex - 1 ]) reject: [ :r | primary size > 0 and: [ (r includes: primary first) or: [ primary includes: r first ] ] ]. findReplaceIntervals do: [ :r | self theme currentSettings haveFindReplaceSelectionTextColor ifTrue: [ self text addAttribute: TextSelectionColor findReplaceSelection from: r first to: r last ]. strm nextPut: (ParagraphSelectionBlock first: (self characterBlockForIndex: r first) last: (self characterBlockForIndex: r last + 1) color: self findReplaceSelectionColor) ] ]. secondarySelection ifNotNil: [ secondarySelectionIntervals := (secondarySelection reject: [ :i | (findReplaceIntervals includes: i) or: [ i = primary or: [ i first > self text size ] ] ]) collect: [ :i | i first to: (i last min: self text size) ]. secondarySelectionIntervals do: [ :r | self theme currentSettings haveSecondarySelectionTextColor ifTrue: [ self text addAttribute: TextSelectionColor secondarySelection from: r first to: r last ]. strm nextPut: (ParagraphSelectionBlock first: (self characterBlockForIndex: r first) last: (self characterBlockForIndex: r last + 1) color: self secondarySelectionColor) ] ] ]. findReplaceSelectionRegex := nil. secondarySelection := nil! ! !Paragraph methodsFor: 'access' stamp: 'AlainPlantec 11/17/2010 22:58'! focused ^ focused ifNil: [focused := false] ! ! !Paragraph methodsFor: 'selection' stamp: 'di 11/30/97 12:10'! selectionRects "Return an array of rectangles representing the selection region." selectionStart ifNil: [^ Array new]. ^ self selectionRectsFrom: selectionStart to: selectionStop! ! !Paragraph methodsFor: 'access' stamp: 'di 10/23/97 19:33'! textStyle: aTextStyle "Set the style by which the receiver should display its text." textStyle := aTextStyle! ! !Paragraph methodsFor: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! extraSelectionRects "Return an array of rectangles representing the findReplace and the secondary selection regions." ^ Array streamContents: [:strm | extraSelectionBlocks ifNotNil: [:blocks | blocks do: [:selBlock | strm nextPutAll: (self selectionRectsFrom: selBlock first to: selBlock last)]]] ! ! !Paragraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! justified textStyle justified! ! !Paragraph methodsFor: 'access' stamp: 'FernandoOlivero 6/18/2011 18:38'! maxRightX ^ maxRightX! ! !Paragraph methodsFor: 'access' stamp: 'tbn 8/5/2009 09:51'! showCaret: aBool showCaret := aBool ! ! !Paragraph methodsFor: 'access' stamp: 'ThierryGoubier 12/20/2012 22:10'! secondarySelection ^ secondarySelection! ! !Paragraph methodsFor: 'access' stamp: 'tbn 8/5/2009 09:51'! showCaret ^showCaret ifNil:[true] ! ! !Paragraph class methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:46'! insertionPointColor: aColor InsertionPointColor := aColor! ! !Paragraph class methodsFor: 'settings' stamp: 'FernandoOlivero 9/18/2013 11:15'! insertionPointColor ^ InsertionPointColor ifNil: [InsertionPointColor := (Color r: 0.0 g: 0.0 b: 0.8 alpha: 0.8)]! ! !ParagraphSelectionBlock methodsFor: 'accessing' stamp: 'AlainPlantec 11/13/2010 09:13'! last ^ last! ! !ParagraphSelectionBlock methodsFor: 'displaying' stamp: 'AlainPlantec 11/13/2010 08:59'! displayInLine: line on: aCanvas "Display myself in the passed line." | startIdx stopIdx leftX rightX | startIdx := first stringIndex. stopIdx := last stringIndex. (stopIdx < line first or: [startIdx > (line last + 1)]) ifTrue: [^self]. "No selection on this line" (stopIdx = line first and: [last textLine ~= line]) ifTrue: [^self]. "Selection ends on line above" (startIdx = (line last + 1) and: [last textLine ~= line]) ifTrue: [^self]. "Selection begins on line below" leftX := (startIdx < line first ifTrue: [line] ifFalse: [first]) left. rightX := (stopIdx > (line last + 1) or: [stopIdx = (line last + 1) and: [last textLine ~= line]]) ifTrue: [line right] ifFalse: [last left]. aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom) color: color! ! !ParagraphSelectionBlock methodsFor: 'accessing' stamp: 'AlainPlantec 11/13/2010 09:13'! first ^ first! ! !ParagraphSelectionBlock methodsFor: 'initialize-release' stamp: 'AlainPlantec 11/13/2010 08:42'! first: firstCharBlock last: lastCharBlock color: aColor first := firstCharBlock. last := lastCharBlock. color := aColor! ! !ParagraphSelectionBlock class methodsFor: 'instance creation' stamp: 'AlainPlantec 11/13/2010 08:43'! first: firstCharBlock last: lastCharBlock color: aColor ^ self new first: firstCharBlock last: lastCharBlock color: aColor! ! !ParseNode commentStamp: ''! This superclass of most compiler/decompiler classes declares common class variables, default messages, and the code emitters for jumps. Some of the class variables are initialized here; the rest are initialized in class VariableNode.! !ParseNode methodsFor: 'testing' stamp: ''! isVariableReference ^false! ! !ParseNode methodsFor: 'comment' stamp: ''! comment: newComment comment := newComment! ! !ParseNode methodsFor: 'testing' stamp: 'md 7/27/2006 19:14'! isMessage ^false! ! !ParseNode methodsFor: 'testing' stamp: 'ar 11/19/2002 14:58'! isVariableNode ^false! ! !ParseNode methodsFor: 'code generation' stamp: 'nk 7/10/2004 10:04'! pc "Used by encoder source mapping." ^pc ifNil: [ 0 ] ! ! !ParseNode methodsFor: 'testing' stamp: 'MarcusDenker 5/20/2013 15:21'! isReturn ^false! ! !ParseNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/28/2010 19:02'! printSingleComment: aString on: aStream indent: indent "Print the comment string, assuming it has been indented indent tabs. Break the string at word breaks, given the widths in the default font, at 450 points." | readStream word position lineBreak font wordWidth tabWidth spaceWidth lastChar | readStream := aString readStream. font := TextStyle default defaultFont. tabWidth := DefaultTab. spaceWidth := font widthOf: Character space. position := indent * tabWidth. lineBreak := 450. [readStream atEnd] whileFalse: [word := self nextWordFrom: readStream setCharacter: [:lc | lastChar := lc]. wordWidth := word inject: 0 into: [:width :char | width + (font widthOf: char)]. position := position + wordWidth. position > lineBreak ifTrue: [aStream skip: -1; crtab: indent. position := indent * tabWidth + wordWidth + spaceWidth. lastChar = Character cr ifTrue: [[readStream peekFor: Character tab] whileTrue]. word isEmpty ifFalse: [aStream nextPutAll: word; space]] ifFalse: [aStream nextPutAll: word. readStream atEnd ifFalse: [position := position + spaceWidth. aStream space]. lastChar = Character cr ifTrue: [aStream skip: -1; crtab: indent. position := indent * tabWidth. [readStream peekFor: Character tab] whileTrue]]]! ! !ParseNode methodsFor: 'testing' stamp: ''! isUnusedTemp ^ false! ! !ParseNode methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 10:15'! nodePrintOn: aStrm indent: nn | var aaStrm myLine | "Show just the sub nodes and the code." (aaStrm := aStrm) ifNil: [aaStrm := (String new: 500) writeStream]. nn timesRepeat: [aaStrm tab]. aaStrm nextPutAll: self class name; space. myLine := self printString copyWithout: Character cr. myLine := myLine copyFrom: 1 to: (myLine size min: 70). aaStrm nextPutAll: myLine; cr. 1 to: self class instSize do: [:ii | var := self instVarAt: ii. (var respondsTo: #asReturnNode) ifTrue: [var nodePrintOn: aaStrm indent: nn+1]]. 1 to: self class instSize do: [:ii | var := self instVarAt: ii. (var isKindOf: SequenceableCollection) ifTrue: [ var do: [:aNode | (aNode respondsTo: #asReturnNode) ifTrue: [ aNode nodePrintOn: aaStrm indent: nn+1]]]]. ^ aaStrm ! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:38'! emitCodeForEffect: stack encoder: encoder self emitCodeForValue: stack encoder: encoder. encoder genPop. stack pop: 1! ! !ParseNode methodsFor: 'comment' stamp: ''! comment ^comment! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:13'! sizeCode: encoder forBranchOn: condition dist: dist dist = 0 ifTrue: [^encoder sizePop]. ^condition ifTrue: [encoder sizeBranchPopTrue: dist] ifFalse: [encoder sizeBranchPopFalse: dist]! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:38'! emitCodeForReturn: stack encoder: encoder self emitCodeForValue: stack encoder: encoder. encoder genReturnTop! ! !ParseNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:33'! accept: aVisitor "Accept a visitor by double-dispatching to a type-specific method on the visitor, e.g. visitBlockNode:. All such implementations under ParseNode should answer the result of the dispatch, e.g. ^aVisitor visitBlockNode: self" ^self subclassResponsibility! ! !ParseNode methodsFor: 'printing' stamp: 'ms 8/1/2006 16:47'! shortPrintOn: aStream self printOn: aStream indent: 0! ! !ParseNode methodsFor: 'testing' stamp: 'eem 2/3/2011 09:12'! ensureCanCascade: encoder! ! !ParseNode methodsFor: 'testing' stamp: ''! assignmentCheck: encoder at: location "For messageNodes masquerading as variables for the debugger. For now we let this through - ie we allow stores ev into args. Should check against numArgs, though." ^ -1! ! !ParseNode methodsFor: 'testing' stamp: ''! isUndefTemp ^ false! ! !ParseNode methodsFor: 'testing' stamp: ''! isSpecialConstant ^ false! ! !ParseNode methodsFor: 'printing' stamp: 'eem 9/5/2009 11:27'! printCommentOn: aStream indent: indent | thisComment | self comment == nil ifTrue: [^ self]. 1 to: self comment size do: [:index | index > 1 ifTrue: [aStream crtab: indent]. aStream nextPut: $". thisComment := self comment at: index. self printSingleComment: thisComment on: aStream indent: indent. aStream nextPut: $"]! ! !ParseNode methodsFor: 'encoding' stamp: 'MarcusDenker 6/24/2013 11:13'! encodeSelector: aSelector ^nil! ! !ParseNode methodsFor: 'private' stamp: 'PeterHugossonMiller 9/3/2009 10:14'! nextWordFrom: aStream setCharacter: aBlock | outStream char | outStream := (String new: 16) writeStream. [(aStream peekFor: Character space) or: [aStream peekFor: Character tab]] whileTrue. [aStream atEnd or: [char := aStream next. char = Character cr or: [char = Character space]]] whileFalse: [outStream nextPut: char]. aBlock value: char. ^ outStream contents! ! !ParseNode methodsFor: 'testing' stamp: ''! isMessage: selSymbol receiver: rcvrPred arguments: argsPred "See comment in MessageNode." ^false! ! !ParseNode methodsFor: 'converting' stamp: ''! asReturnNode ^ReturnNode new expr: self! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52'! emitCodeForBlockValue: stack encoder: encoder "Generate code for evaluating the last statement in a block" ^self emitCodeForValue: stack encoder: encoder! ! !ParseNode methodsFor: 'testing' stamp: ''! isArg ^false! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 09:52'! sizeCode: encoder forJump: dist ^dist = 0 ifTrue: [0] ifFalse: [encoder sizeJump: dist]! ! !ParseNode methodsFor: 'testing' stamp: 'md 1/20/2006 16:22'! isDoIt "polymorphic with RBNodes; called by debugger" ^ false! ! !ParseNode methodsFor: 'testing' stamp: 'tk 8/2/1999 18:39'! isSelfPseudoVariable "Overridden in VariableNode." ^false! ! !ParseNode methodsFor: 'testing' stamp: 'eem 6/16/2008 09:37'! isAssignmentNode ^false! ! !ParseNode methodsFor: 'testing' stamp: ''! nowHasRef "Ignored in all but VariableNode"! ! !ParseNode methodsFor: 'testing' stamp: ''! canCascade ^false! ! !ParseNode methodsFor: 'private' stamp: 'ls 1/29/2004 21:17'! ifNilReceiver "assuming this object is the receiver of an ifNil:, what object is being asked about?" ^self! ! !ParseNode methodsFor: 'printing' stamp: 'NikoSchwarz 6/5/2010 17:48'! printAsIfCompiledOn: aStream "Refer to the comment in Object|printOn:." self printOn: aStream indent: 0. ! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:39'! emitCodeForJump: dist encoder: encoder dist = 0 ifFalse: [encoder genJump: dist]! ! !ParseNode methodsFor: 'testing' stamp: ''! isConstantNumber "Overridden in LiteralNode" ^false! ! !ParseNode methodsFor: 'testing' stamp: ''! toDoIncrement: ignored "Only meant for Messages or Assignments - else return nil" ^ nil! ! !ParseNode methodsFor: 'testing' stamp: 'John M McIntosh 3/2/2009 19:58'! isMessageNode ^false! ! !ParseNode methodsFor: 'visiting' stamp: 'eem 7/20/2009 19:44'! nodesDo: aBlock self accept: (ParseNodeEnumerator ofBlock: aBlock)! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 8/4/2008 13:57'! pc: anInteger "Used by encoder source mapping." pc := anInteger! ! !ParseNode methodsFor: 'testing' stamp: 'MarcusDenker 9/20/2013 13:27'! isLiteralNode ^false! ! !ParseNode methodsFor: 'testing' stamp: ''! isReturningIf ^false! ! !ParseNode methodsFor: 'printing' stamp: 'NikoSchwarz 6/5/2010 17:50'! printOn: aStream "Refer to the comment in Object|printOn:." aStream nextPut: ${. self printAsIfCompiledOn: aStream. aStream nextPut: $}.! ! !ParseNode methodsFor: 'testing' stamp: 'di 10/12/1999 15:28'! isTemp ^ false! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:37'! emitCodeForBranchOn: condition dist: dist pop: stack encoder: encoder stack pop: 1. dist = 0 ifTrue: [^encoder genPop]. condition ifTrue: [encoder genBranchPopTrue: dist] ifFalse: [encoder genBranchPopFalse: dist]! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:57'! sizeCodeForReturn: encoder ^(self sizeCodeForValue: encoder) + encoder sizeReturnTop! ! !ParseNode methodsFor: 'testing' stamp: ''! isComplex "Used for pretty printing to determine whether to start a new line" ^false! ! !ParseNode methodsFor: 'testing' stamp: 'eem 8/31/2010 11:34'! isOnlySubnodeOf: aSubtree "" in: aParseTree "" "Answer if the receiver only occurs within aSubtree of aParseTree, not in the rest of aParseTree. Assumes that aSubtree is in fact a subnode of aParseTree." | isSubnode | isSubnode := false. aSubtree accept: (ParseNodeEnumerator ofBlock: [:node| node == self ifTrue: [isSubnode := true]]). isSubnode ifFalse: [^false]. aParseTree accept: (ParseNodeEnumerator ofBlock: [:node| node == self ifTrue: [^false]] select: [:node| node ~= aSubtree]). ^true! ! !ParseNode methodsFor: 'printing' stamp: ''! printOn: aStream indent: anInteger "If control gets here, avoid recursion loop." super printOn: aStream! ! !ParseNode methodsFor: 'testing' stamp: ''! isReturnSelf ^false! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 14:52'! sizeCodeForBlockValue: encoder "Answer the size for evaluating the last statement in a block" ^self sizeCodeForValue: encoder! ! !ParseNode methodsFor: 'printing' stamp: ''! printOn: aStream indent: level precedence: p self printOn: aStream indent: level! ! !ParseNode methodsFor: 'testing' stamp: 'ls 1/29/2004 21:11'! isJust: node ^false! ! !ParseNode methodsFor: 'testing' stamp: ''! nowHasDef "Ignored in all but VariableNode"! ! !ParseNode methodsFor: 'testing' stamp: 'eem 9/25/2008 12:11'! isBlockNode ^false! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:53'! sizeCodeForEffect: encoder ^(self sizeCodeForValue: encoder) + encoder sizePop! ! !ParseNode class methodsFor: 'accessing' stamp: 'ajh 8/12/2002 11:10'! blockReturnCode ^ EndRemote! ! !ParseNode class methodsFor: 'class initialization' stamp: ''! initialize "ParseNode initialize. VariableNode initialize" LdInstType := 1. LdTempType := 2. LdLitType := 3. LdLitIndType := 4. SendType := 5. CodeBases := #(0 16 32 64 208 ). CodeLimits := #(16 16 32 32 16 ). LdSelf := 112. LdTrue := 113. LdFalse := 114. LdNil := 115. LdMinus1 := 116. LoadLong := 128. Store := 129. StorePop := 130. ShortStoP := 96. SendLong := 131. DblExtDoAll := 132. SendLong2 := 134. LdSuper := 133. Pop := 135. Dup := 136. LdThisContext := 137. EndMethod := 124. EndRemote := 125. Jmp := 144. Bfp := 152. JmpLimit := 8. JmpLong := 164. "code for jmp 0" BtpLong := 168. SendPlus := 176. Send := 208. SendLimit := 16! ! !ParseNode class methodsFor: 'accessing' stamp: 'eem 5/21/2008 13:18'! pushNilCode ^LdNil! ! !ParseNode class methodsFor: 'accessing' stamp: 'ajh 8/6/2002 12:04'! popCode ^ Pop! ! !ParseNode class methodsFor: 'accessing' stamp: 'eem 8/4/2009 12:34'! tempSortBlock "Answer a block that can sort a set of temporaries into a stable order so that different compilations produce the same results." ^[:t1 :t2| | be1 be2 bs1 bs2 | t1 index < t2 index "simple sort by index." or: [t1 index = t2 index "complex tie break" and: [t1 isRemote ~= t2 isRemote ifTrue: [t2 isRemote] "put direct temps before indirect temps" ifFalse: [((be1 := t1 definingScope blockExtent) isNil or: [(be2 := t2 definingScope blockExtent) isNil]) ifTrue: [t1 name < t2 name] "only have the name left to go on" ifFalse: "put temps from outer scopes before those from inner scopes" [(bs1 := be1 first) < (bs2 := be2 first) or: [bs1 = bs2 and: [t1 name < t2 name]]]]]]] "only have the name left to go on"! ! !ParseNodeEnumerator commentStamp: 'eem 8/31/2010 11:41'! ParseNodeEnumerator implements ParseNode>>nodesDo:. It can be used to enumerate an entire tree via aParseNode accept: (ParseNodeEnumerator ofBlock: aBlock) or selectively, excluding the node and subnodes for which selectBlock answers false, via aParseNode accept: (ParseNodeEnumerator ofBlock: aBlock select: selectBlock) Here's a doIt that generates and compiles the visiting methods: self superclass selectors do: [:s| self compile: (String streamContents: [:str| | arg | arg := 'a', (s allButFirst: 5) allButLast. str nextPutAll: s, ' ', arg; crtab; nextPutAll: '(theSelectBlock isNil or: [theSelectBlock value: '; nextPutAll: arg; nextPutAll: ']) ifFalse:'; crtab; tab: 2; nextPutAll: '[^nil].'; crtab; nextPutAll: 'theBlock value: '; nextPutAll: arg; nextPut: $.; crtab; nextPutAll: '^super '; nextPutAll: s, ' ', arg])]! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitCascadeNode: aCascadeNode (theSelectBlock isNil or: [theSelectBlock value: aCascadeNode]) ifFalse: [^nil]. theBlock value: aCascadeNode. ^super visitCascadeNode: aCascadeNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitFieldNode: aFieldNode (theSelectBlock isNil or: [theSelectBlock value: aFieldNode]) ifFalse: [^nil]. theBlock value: aFieldNode. ^super visitFieldNode: aFieldNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitLiteralVariableNode: aLiteralVariableNode (theSelectBlock isNil or: [theSelectBlock value: aLiteralVariableNode]) ifFalse: [^nil]. theBlock value: aLiteralVariableNode. ^super visitLiteralVariableNode: aLiteralVariableNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitMessageNode: aMessageNode (theSelectBlock isNil or: [theSelectBlock value: aMessageNode]) ifFalse: [^nil]. theBlock value: aMessageNode. ^super visitMessageNode: aMessageNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitMethodNode: aMethodNode (theSelectBlock isNil or: [theSelectBlock value: aMethodNode]) ifFalse: [^nil]. theBlock value: aMethodNode. ^super visitMethodNode: aMethodNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitBlockNode: aBlockNode (theSelectBlock isNil or: [theSelectBlock value: aBlockNode]) ifFalse: [^nil]. theBlock value: aBlockNode. ^super visitBlockNode: aBlockNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitNewArrayNode: aNewArrayNode (theSelectBlock isNil or: [theSelectBlock value: aNewArrayNode]) ifFalse: [^nil]. theBlock value: aNewArrayNode. ^super visitNewArrayNode: aNewArrayNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'IgorStasenko 1/11/2011 20:52'! visitInstanceVariableNode: anInstanceVariableNode (self shouldVisit: anInstanceVariableNode) ifFalse: [^nil]. theBlock value: anInstanceVariableNode. ^super visitInstanceVariableNode: anInstanceVariableNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitSelectorNode: aSelectorNode (theSelectBlock isNil or: [theSelectBlock value: aSelectorNode]) ifFalse: [^nil]. theBlock value: aSelectorNode. ^super visitSelectorNode: aSelectorNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitVariableNode: aVariableNode (theSelectBlock isNil or: [theSelectBlock value: aVariableNode]) ifFalse: [^nil]. theBlock value: aVariableNode. ^super visitVariableNode: aVariableNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitBraceNode: aBraceNode (theSelectBlock isNil or: [theSelectBlock value: aBraceNode]) ifFalse: [^nil]. theBlock value: aBraceNode. ^super visitBraceNode: aBraceNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitFutureNode: aFutureNode (theSelectBlock isNil or: [theSelectBlock value: aFutureNode]) ifFalse: [^nil]. theBlock value: aFutureNode. ^super visitFutureNode: aFutureNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitTempVariableNode: aTempVariableNode (theSelectBlock isNil or: [theSelectBlock value: aTempVariableNode]) ifFalse: [^nil]. theBlock value: aTempVariableNode. ^super visitTempVariableNode: aTempVariableNode! ! !ParseNodeEnumerator methodsFor: 'testing' stamp: 'HenrikSperreJohansen 8/31/2010 23:36'! shouldVisit: aNode ^theSelectBlock isNil or: [theSelectBlock value: aNode]! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitAssignmentNode: anAssignmentNode (theSelectBlock isNil or: [theSelectBlock value: anAssignmentNode]) ifFalse: [^nil]. theBlock value: anAssignmentNode. ^super visitAssignmentNode: anAssignmentNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitRemoteTempVectorNode: aRemoteTempVectorNode (theSelectBlock isNil or: [theSelectBlock value: aRemoteTempVectorNode]) ifFalse: [^nil]. theBlock value: aRemoteTempVectorNode. ^super visitRemoteTempVectorNode: aRemoteTempVectorNode! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitCommentNode: aCommentNode (theSelectBlock isNil or: [theSelectBlock value: aCommentNode]) ifFalse: [^nil]. theBlock value: aCommentNode. ^super visitCommentNode: aCommentNode! ! !ParseNodeEnumerator methodsFor: 'initialize-release' stamp: 'eem 8/31/2010 11:24'! ofBlock: aBlock select: aSelectBlock theBlock := aBlock. theSelectBlock := aSelectBlock! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitLiteralNode: aLiteralNode (theSelectBlock isNil or: [theSelectBlock value: aLiteralNode]) ifFalse: [^nil]. theBlock value: aLiteralNode. ^super visitLiteralNode: aLiteralNode! ! !ParseNodeEnumerator methodsFor: 'initialize-release' stamp: 'eem 7/20/2009 19:44'! ofBlock: aBlock theBlock := aBlock! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitMessageNodeInCascade: aMessageNodeInCascade (theSelectBlock isNil or: [theSelectBlock value: aMessageNodeInCascade]) ifFalse: [^nil]. theBlock value: aMessageNodeInCascade. ^super visitMessageNodeInCascade: aMessageNodeInCascade! ! !ParseNodeEnumerator methodsFor: 'visiting' stamp: 'eem 8/31/2010 11:13'! visitReturnNode: aReturnNode (theSelectBlock isNil or: [theSelectBlock value: aReturnNode]) ifFalse: [^nil]. theBlock value: aReturnNode. ^super visitReturnNode: aReturnNode! ! !ParseNodeEnumerator class methodsFor: 'instance creation' stamp: 'eem 7/20/2009 19:45'! ofBlock: aBlock ^self new ofBlock: aBlock! ! !ParseNodeEnumerator class methodsFor: 'instance creation' stamp: 'eem 8/31/2010 11:43'! ofBlock: aBlock select: selectBlock ^self new ofBlock: aBlock select: selectBlock! ! !ParseNodeVisitor commentStamp: ''! I am an abstract superclass for ParseNode visitors that functions as a null visitor. Here's the code that defines my interface: (SystemNavigation new allImplementorsOf: #accept: localTo: ParseNode) do: [:methodReference| methodReference compiledMethod messages do: [:sel| ((sel beginsWith: 'visit') and: [sel numArgs = 1]) ifTrue: [ParseNodeVisitor compile: (String streamContents: [:str| str nextPutAll: sel; space; nextPut: $a. methodReference classSymbol first isVowel ifTrue: [str nextPut: $n]. str nextPutAll: methodReference classSymbol]) classified: 'visiting']]]! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 16:13'! visitCascadeNode: aCascadeNode aCascadeNode receiver accept: self. aCascadeNode messages do: [:message| self visitMessageNodeInCascade: message]! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitFieldNode: aFieldNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitLiteralVariableNode: aLiteralVariableNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/5/2009 20:08'! visitMessageNode: aMessageNode aMessageNode receiver accept: self. "receiver notNil ifTrue: ''receiver is nil for cascades'' [receiver accept: self]." aMessageNode selector accept: self. aMessageNode argumentsInEvaluationOrder do: [:argument| argument accept: self]! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:53'! visitMethodNode: aMethodNode aMethodNode block accept: self! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:13'! visitBlockNode: aBlockNode aBlockNode statements do: [:statement| statement accept: self]! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitNewArrayNode: aNewArrayNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitInstanceVariableNode: anInstanceVariableNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitSelectorNode: aSelectorNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:32'! visitVariableNode: aVariableNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:14'! visitBraceNode: aBraceNode aBraceNode elements do: [:element| element accept: self]! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitTempVariableNode: aTempVariableNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:10'! visitAssignmentNode: anAssignmentNode "N.B. since assigment happens after the value is evaluated the value is visited first." anAssignmentNode value accept: self. anAssignmentNode variable accept: self! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitRemoteTempVectorNode: aRemoteTempVectorNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitCommentNode: aCommentNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitLiteralNode: aLiteralNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 2/9/2009 10:04'! visitMessageNodeInCascade: aMessageNode "receiver is nil for cascades" aMessageNode selector accept: self. aMessageNode argumentsInEvaluationOrder do: [:argument| argument accept: self]! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:53'! visitReturnNode: aReturnNode aReturnNode expr accept: self! ! !ParseStack commentStamp: ''! I keep track of the current and high position of the stack that will be needed by code being compiled.! !ParseStack methodsFor: 'accessing' stamp: ''! pop: n (position := position - n) < 0 ifTrue: [self error: 'Parse stack underflow']! ! !ParseStack methodsFor: 'accessing' stamp: ''! size ^length! ! !ParseStack methodsFor: 'printing' stamp: ''! printOn: aStream super printOn: aStream. aStream nextPutAll: ' at '; print: position; nextPutAll: ' of '; print: length! ! !ParseStack methodsFor: 'results' stamp: ''! position ^position! ! !ParseStack methodsFor: 'accessing' stamp: ''! push: n (position := position + n) > length ifTrue: [length := position]! ! !ParseStack methodsFor: 'initialization' stamp: ''! init length := position := 0! ! !ParseStack methodsFor: 'accessing' stamp: 'eem 9/12/2008 10:31'! position: n (position := n) > length ifTrue: [length := position]! ! !Parser commentStamp: ''! I parse Smalltalk syntax and create a MethodNode that is the root of the parse tree. I look one token ahead.! !Parser methodsFor: 'scanning' stamp: 'nice 2/9/2012 14:02'! advance | this | prevMark := hereMark. prevEnd := hereEnd. this := here. here := token. hereType := tokenType. hereMark := mark. hereEnd := source position - (aheadChar == DoItCharacter ifTrue: [hereChar == DoItCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]). self scanToken. "Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr." ^this! ! !Parser methodsFor: 'primitives' stamp: 'lr 9/29/2010 08:12'! primitive: anIntegerOrString "Create indexed primitive." ^self primitive: anIntegerOrString error: nil! ! !Parser methodsFor: 'expression types' stamp: 'StephaneDucasse 3/25/2011 17:54'! pattern: fromDoit inContext: ctxt " unarySelector | binarySelector arg | keyword arg {keyword arg} => {selector, arguments, precedence}." | args selector | doitFlag := fromDoit. fromDoit ifTrue: [^ctxt == nil ifTrue: [{#DoIt. {}. 1}] ifFalse: [{#DoItIn:. {encoder encodeVariable: encoder doItInContextName}. 3}]]. hereType == #word ifTrue: [^ {self advance asSymbol. {}. 1}]. (hereType == #binary or: [hereType == #verticalBar]) ifTrue: [selector := self advance asSymbol. args := Array with: (encoder bindArg: self argumentName). ^ {selector. args. 2}]. hereType == #keyword ifTrue: [selector := (String new: 32) writeStream. args := OrderedCollection new. [hereType == #keyword] whileTrue:[ selector nextPutAll: self advance. args addLast: (encoder bindArg: self argumentName). ]. ^ {selector contents asSymbol. args. 3}]. ^self expected: 'Message pattern'! ! !Parser methodsFor: 'expression types' stamp: ''! argumentName hereType == #word ifFalse: [^self expected: 'Argument name']. ^self advance! ! !Parser methodsFor: 'error handling' stamp: 'CamilloBruni 2/8/2012 23:20'! notify: string at: location requestor isNil ifTrue: [(encoder == self or: [encoder isNil]) ifTrue: [^ self fail "failure setting up syntax error"]. SyntaxErrorNotification inClass: encoder classEncoding category: category withCode: source contents doitFlag: doitFlag errorMessage: string location: location] ifFalse: [requestor notify: string , ' ->' at: location in: source]. ^self fail! ! !Parser methodsFor: 'scanning' stamp: ''! match: type "Answer with true if next tokens type matches." hereType == type ifTrue: [self advance. ^true]. ^false! ! !Parser methodsFor: 'temps' stamp: ''! bindArg: name ^ self bindTemp: name! ! !Parser methodsFor: 'error correction' stamp: 'cwp 10/15/2007 22:58'! possibleVariablesFor: proposedVariable ^encoder possibleVariablesFor: proposedVariable! ! !Parser methodsFor: 'primitives' stamp: 'ar 12/2/1999 16:49'! externalType: descriptorClass "Parse an return an external type" | xType | xType := descriptorClass atomicTypeNamed: here. xType == nil ifTrue:["Look up from class scope" Symbol hasInterned: here ifTrue:[:sym| xType := descriptorClass structTypeNamed: sym]]. xType == nil ifTrue:[ "Raise an error if user is there" self interactive ifTrue:[^nil]. "otherwise go over it silently" xType := descriptorClass forceTypeNamed: here]. self advance. (self matchToken:#*) ifTrue:[^xType asPointerType] ifFalse:[^xType]! ! !Parser methodsFor: 'expression types' stamp: 'eem 2/3/2011 09:50'! cascade " {; message} => CascadeNode." | rcvr msgs | parseNode canCascade ifFalse: [^self expected: 'Cascading not']. parseNode ensureCanCascade: encoder. rcvr := parseNode cascadeReceiver. msgs := OrderedCollection with: parseNode. [self match: #semicolon] whileTrue: [parseNode := rcvr. (self messagePart: 3 repeat: false) ifFalse: [^self expected: 'Cascade']. parseNode canCascade ifFalse: [^self expected: '<- No special messages']. parseNode ensureCanCascade: encoder. parseNode cascadeReceiver. msgs addLast: parseNode]. parseNode := CascadeNode new receiver: rcvr messages: msgs! ! !Parser methodsFor: 'error correction' stamp: 'nice 4/4/2010 21:45'! ambiguousSelector: aString inRange: anInterval | correctedSelector userSelection offset intervalWithOffset | self interactive ifFalse: [ "In non interactive mode, break backward compatibility: $- is part of selector" Transcript cr; nextPutAll: encoder classEncoding storeString; nextPutAll:#'>>'; nextPutAll: encoder selector storeString; show: ' will send ' , token , '-'. ^super ambiguousSelector: aString inRange: anInterval]. "handle the text selection" userSelection := requestor selectionInterval. intervalWithOffset := anInterval first + requestorOffset to: anInterval last + requestorOffset. requestor selectFrom: intervalWithOffset first to: intervalWithOffset last. requestor select. "Build the menu with alternatives" correctedSelector := AmbiguousSelector signalName: aString inRange: intervalWithOffset. correctedSelector ifNil: [^self fail]. "Execute the selected action" offset := self substituteWord: correctedSelector wordInterval: intervalWithOffset offset: 0. requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last + offset. token := (correctedSelector readStream upTo: Character space) asSymbol! ! !Parser methodsFor: 'expression types' stamp: 'eem 5/30/2008 11:51'! statements: argNodes innerBlock: inner ^self statements: argNodes innerBlock: inner blockNode: BlockNode new! ! !Parser methodsFor: 'primitives' stamp: 'lr 9/29/2010 08:13'! primitive: aNameString module: aModuleStringOrNil error: errorCodeVariableOrNil "Create named primitive with optional error code." (aNameString isString and: [ aModuleStringOrNil isNil or: [ aModuleStringOrNil isString ] ]) ifFalse: [ ^ self expected: 'Named primitive' ]. self allocateLiteral: (Array with: (aModuleStringOrNil isNil ifFalse: [ aModuleStringOrNil asSymbol ]) with: aNameString asSymbol with: 0 with: 0). errorCodeVariableOrNil ifNotNil: [encoder floatTemp: (encoder bindTemp: errorCodeVariableOrNil) nowHasDef]. ^117! ! !Parser methodsFor: 'error correction' stamp: 'StephaneDucasse 8/27/2010 11:33'! declareInstVar: name "Declare an instance variable. Since the variable will get added after any existing inst vars its index is the instSize." encoder classEncoding addInstVarNamed: name. ^InstanceVariableNode new name: name index: encoder classEncoding instSize ! ! !Parser methodsFor: 'expression types' stamp: 'nice 3/5/2010 23:17'! method: doit context: ctxt " pattern [ | temporaries ] block => MethodNode." | sap blk prim temps messageComment methodNode | properties := AdditionalMethodState new. sap := self pattern: doit inContext: ctxt. "sap={selector, arguments, precedence}" properties selector: (sap at: 1). encoder selector: (sap at: 1). (sap at: 2) do: [:argNode | argNode beMethodArg]. doit ifFalse: [self pragmaSequence]. temps := self temporaries. messageComment := currentComment. currentComment := nil. doit ifFalse: [self pragmaSequence]. prim := self pragmaPrimitives. self statements: #() innerBlock: doit. blk := parseNode. doit ifTrue: [blk returnLast] ifFalse: [blk returnSelfIfNoOther: encoder]. hereType == #doIt ifFalse: [^self expected: 'Nothing more']. self interactive ifTrue: [self removeUnusedTemps]. methodNode := self newMethodNode comment: messageComment. ^methodNode selector: (sap at: 1) arguments: (sap at: 2) precedence: (sap at: 3) temporaries: temps block: blk encoder: encoder primitive: prim properties: properties! ! !Parser methodsFor: 'private' stamp: 'nice 2/23/2010 17:48'! init: sourceStream notifying: req failBlock: aBlock requestor := req. failBlock := aBlock. requestorOffset := 0. super scan: sourceStream. prevMark := hereMark := mark. self advance! ! !Parser methodsFor: 'pragmas' stamp: 'StephaneDucasse 6/2/2010 09:58'! properties ^ properties ifNil: [ properties := AdditionalMethodState new ]! ! !Parser methodsFor: 'expression types' stamp: 'di 11/19/1999 07:43'! expression (hereType == #word and: [tokenType == #leftArrow]) ifTrue: [^ self assignment: self variable]. hereType == #leftBrace ifTrue: [self braceExpression] ifFalse: [self primaryExpression ifFalse: [^ false]]. (self messagePart: 3 repeat: true) ifTrue: [hereType == #semicolon ifTrue: [self cascade]]. ^ true! ! !Parser methodsFor: 'private' stamp: 'PeterHugossonMiller 9/2/2009 16:11'! initPattern: aString notifying: req return: aBlock | result | self init: aString asString readStream notifying: req failBlock: [^nil]. encoder := self. result := aBlock value: (self pattern: false inContext: nil). encoder := failBlock := nil. "break cycles" ^result! ! !Parser methodsFor: 'error handling' stamp: ''! notify: aString "Notify problem at token before 'here'." ^self notify: aString at: prevMark + requestorOffset! ! !Parser methodsFor: 'expression types' stamp: 'eem 7/20/2009 12:09'! blockExpression "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." | blockNode variableNodes temporaryBlockVariables start | blockNode := BlockNode new. variableNodes := OrderedCollection new. start := prevMark + requestorOffset. "Gather parameters." [self match: #colon] whileTrue: [variableNodes addLast: (encoder bindBlockArg: self argumentName within: blockNode)]. (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: [^self expected: 'Vertical bar']. temporaryBlockVariables := self temporaryBlockVariablesFor: blockNode. self statements: variableNodes innerBlock: true blockNode: blockNode. blockNode temporaries: temporaryBlockVariables. (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. blockNode noteSourceRangeStart: start end: self endOfLastToken encoder: encoder. "The scope of the parameters and temporary block variables is no longer active." temporaryBlockVariables do: [:variable | variable scope: -1]. variableNodes do: [:variable | variable scope: -1]! ! !Parser methodsFor: 'error correction' stamp: 'BenjaminVanRyseghem 12/20/2012 14:47'! correctVariable: proposedVariable interval: spot "Correct the proposedVariable to a known variable, or declare it as a new variable if such action is requested. We support declaring lowercase variables as temps or inst-vars, and uppercase variables as Globals or ClassVars, depending on whether the context is nil (class=UndefinedObject). Spot is the interval within the test stream of the variable. " "Check if this is an i-var, that has been corrected already (ugly)" "Display the pop-up menu" | tempIvar binding userSelection action | (encoder classEncoding instVarNames includes: proposedVariable) ifTrue: [^InstanceVariableNode new name: proposedVariable index: (encoder classEncoding allInstVarNames indexOf: proposedVariable)]. "If we can't ask the user for correction, make it undeclared" self interactive ifFalse: [^encoder undeclared: proposedVariable]. "First check to see if the requestor knows anything about the variable" tempIvar := proposedVariable first isLowercase. (tempIvar and: [(binding := requestor bindingOf: proposedVariable) notNil]) ifTrue: [^encoder global: binding name: proposedVariable]. userSelection := requestor selectionInterval. requestor selectFrom: spot first to: spot last. "requestor select." "Build the menu with alternatives" action := UndeclaredVariable signalFor: self name: proposedVariable inRange: spot. action ifNil: [^self fail]. "Execute the selected action" requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. ^action value! ! !Parser methodsFor: 'expression types' stamp: 'di 3/8/2000 09:36'! braceExpression " { elements } => BraceNode." | elements locations loc more | elements := OrderedCollection new. locations := OrderedCollection new. self advance. more := hereType ~~ #rightBrace. [more] whileTrue: [loc := hereMark + requestorOffset. self expression ifTrue: [elements addLast: parseNode. locations addLast: loc] ifFalse: [^self expected: 'Variable or expression']. (self match: #period) ifTrue: [more := hereType ~~ #rightBrace] ifFalse: [more := false]]. parseNode := BraceNode new elements: elements sourceLocations: locations. (self match: #rightBrace) ifFalse: [^self expected: 'Period or right brace']. ^true! ! !Parser methodsFor: 'public access' stamp: 'jmv 3/2/2010 17:11'! encoderClass: anEncoderClass encoder ifNotNil: [ self error: 'encoder already set']. encoder := anEncoderClass new! ! !Parser methodsFor: 'expression types' stamp: 'di 12/4/1999 21:04'! variable | varName varStart varEnd | varStart := self startOfNextToken + requestorOffset. varName := self advance. varEnd := self endOfLastToken + requestorOffset. ^ encoder encodeVariable: varName sourceRange: (varStart to: varEnd) ifUnknown: [self correctVariable: varName interval: (varStart to: varEnd)]! ! !Parser methodsFor: 'primitives' stamp: ''! allocateLiteral: lit encoder litIndex: lit! ! !Parser methodsFor: 'error correction' stamp: 'nice 1/5/2010 15:59'! removeUnusedTemps "Scan for unused temp names, and prompt the user about the prospect of removing each one found" | str madeChanges | "I disabled this option. I keep the old code just in case - Hernan Wilkinson" self warns ifFalse: [ ^ self ]. madeChanges := false. str := requestor text asString. ((tempsMark between: 1 and: str size) and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. encoder unusedTempNames do: [:temp | | start end | (UnusedVariable name: temp) ifTrue: [(encoder encodeVariable: temp) isUndefTemp ifTrue: [end := tempsMark. ["Beginning at right temp marker..." start := end - temp size + 1. end < temp size or: [temp = (str copyFrom: start to: end) and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]] whileFalse: ["Search left for the unused temp" end := requestor nextTokenFrom: end direction: -1]. end < temp size ifFalse: [(str at: start-1) = $ ifTrue: [start := start-1]. requestor correctFrom: start to: end with: ''. str := str copyReplaceFrom: start to: end with: ''. madeChanges := true. tempsMark := tempsMark - (end-start+1)]] ifFalse: [self inform: 'You''ll first have to remove the\statement where it''s stored into' withCRs]]]. madeChanges ifTrue: [ReparseAfterSourceEditing signal]! ! !Parser methodsFor: 'error handling' stamp: 'HenrikSperreJohansen 5/31/2010 14:49'! fail | exitBlock | (encoder isNil or: [encoder == self]) ifFalse: [encoder release. encoder := nil]. "break cycle" exitBlock := failBlock. failBlock := nil. ^exitBlock value! ! !Parser methodsFor: 'primitives' stamp: 'lr 9/29/2010 08:12'! primitive: aNameString error: errorCodeVariableOrNil module: aModuleStringOrNil "Create named primitive with optional error code." ^self primitive: aNameString module: aModuleStringOrNil error: errorCodeVariableOrNil! ! !Parser methodsFor: 'expression types' stamp: 'ar 1/4/2002 00:23'! temporaries " [ '|' (variable)* '|' ]" | vars theActualText | (self match: #verticalBar) ifFalse: ["no temps" doitFlag ifTrue: [self interactive ifFalse: [tempsMark := 1] ifTrue: [tempsMark := requestor selectionInterval first]. ^ #()]. tempsMark := (prevEnd ifNil: [0]) + 1. tempsMark := hereMark "formerly --> prevMark + prevToken". tempsMark > 0 ifTrue: [theActualText := source contents. [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] whileTrue: [tempsMark := tempsMark + 1]]. ^ #()]. vars := OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (encoder bindTemp: self advance)]. (self match: #verticalBar) ifTrue: [tempsMark := prevMark. ^ vars]. ^ self expected: 'Vertical bar' ! ! !Parser methodsFor: 'public access' stamp: 'nice 8/27/2010 20:54'! encoder ^encoder ifNil: [encoder := EncoderForV3PlusClosures new]! ! !Parser methodsFor: 'public access' stamp: 'eem 8/20/2008 20:55'! parseSelector: aString "Answer the message selector for the argument, aString, which should parse successfully up to the temporary declaration or the end of the method header." self initScannerForTokenization. ^self initPattern: aString notifying: nil return: [:pattern | pattern at: 1]! ! !Parser methodsFor: 'expression types' stamp: 'eem 6/2/2009 10:26'! assignment: varNode " var ':=' expression => AssignmentNode." | loc start | (loc := varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0 ifTrue: [^self notify: 'Cannot store into' at: loc]. start := self startOfNextToken. self advance. self expression ifFalse: [^self expected: 'Expression']. parseNode := AssignmentNode new variable: varNode value: parseNode from: encoder sourceRange: (start to: self endOfLastToken). varNode nowHasDef. ^true! ! !Parser methodsFor: 'expression types' stamp: 'eem 5/13/2008 14:32'! temporariesIn: methodSelector " [ '|' (variable)* '|' ]" | vars theActualText | (self match: #verticalBar) ifFalse: ["no temps" doitFlag ifTrue: [self interactive ifFalse: [tempsMark := 1] ifTrue: [tempsMark := requestor selectionInterval first]. ^ #()]. tempsMark := (prevEnd ifNil: [0]) + 1. tempsMark := hereMark "formerly --> prevMark + prevToken". tempsMark > 0 ifTrue: [theActualText := source contents. [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] whileTrue: [tempsMark := tempsMark + 1]]. ^ #()]. vars := OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (encoder bindTemp: self advance in: methodSelector)]. (self match: #verticalBar) ifTrue: [tempsMark := prevMark. ^ vars]. ^ self expected: 'Vertical bar'! ! !Parser methodsFor: 'expression types' stamp: 'lr 3/12/2010 21:15'! statements: argNodes innerBlock: inner blockNode: theBlockNode | stmts returns start | "give initial comment to block, since others trail statements" theBlockNode comment: currentComment. stmts := OrderedCollection new. returns := false. hereType ~~ #rightBracket ifTrue: [[theBlockNode startOfLastStatement: (start := self startOfNextToken). (returns := self matchReturn) ifTrue: [self expression ifFalse: [^self expected: 'Expression to return']. self addComment. stmts addLast: (parseNode isReturningIf ifTrue: [parseNode] ifFalse: [ReturnNode new expr: parseNode encoder: encoder sourceRange: (start to: self endOfLastToken)])] ifFalse: [self expression ifTrue: [self addComment. stmts addLast: parseNode] ifFalse: [self addComment. stmts size = 0 ifTrue: [stmts addLast: (encoder encodeVariable: (inner ifTrue: ['nil'] ifFalse: ['self']))]]]. returns ifTrue: [self match: #period. (hereType == #rightBracket or: [hereType == #doIt]) ifFalse: [^self expected: 'End of block']]. returns not and: [self match: #period]] whileTrue]. (inner and: [argNodes size > 0 and: [stmts isEmpty]]) ifTrue: [ "A ST-80 empty block should return nil" stmts addLast: (encoder encodeVariable: 'nil' sourceRange: nil ifUnknown: [self error: 'Compiler internal error'])]. theBlockNode arguments: argNodes statements: stmts returns: returns from: encoder. parseNode := theBlockNode. ^true! ! !Parser methodsFor: 'private' stamp: ''! addComment parseNode ~~ nil ifTrue: [parseNode comment: currentComment. currentComment := nil]! ! !Parser methodsFor: 'pragmas' stamp: 'mha 9/1/2009 16:32'! pragmaStatement "Read a single pragma statement. Parse all generic pragmas in the form of: and remember them, including primitives." | selector arguments words index keyword | (hereType = #keyword or: [ hereType = #word or: [ hereType = #binary ] ]) ifFalse: [ ^ self expected: 'pragma declaration' ]. " This is a ugly hack into the compiler of the FFI package. FFI should be changed to use propre pragmas that can be parsed with the code here. " (here = #apicall: or: [ here = #cdecl: ]) ifTrue: [ ^ self externalFunctionDeclaration ]. selector := String new. arguments := OrderedCollection new. words := OrderedCollection new. [ hereType = #keyword or: [ (hereType = #word or: [ hereType = #binary ]) and: [ selector isEmpty ] ] ] whileTrue: [ index := self startOfNextToken + requestorOffset. selector := selector , self advance. words add: (index to: self endOfLastToken + requestorOffset). (selector last = $: or: [ selector first isLetter not ]) ifTrue: [ arguments add: (self pragmaLiteral: selector) ] ]. selector numArgs ~= arguments size ifTrue: [ ^ self expected: 'pragma argument' ]. (Symbol hasInterned: selector ifTrue: [ :value | keyword := value]) ifFalse: [ keyword := self correctSelector: selector wordIntervals: words exprInterval: (words first first to: words last last) ifAbort: [ ^ self fail ] ]. self addPragma: (Pragma keyword: keyword arguments: arguments asArray). ^ true! ! !Parser methodsFor: 'expression types' stamp: 'nice 3/5/2010 22:16'! primaryExpression hereType == #word ifTrue: [parseNode := self variable. (parseNode isUndefTemp and: [self interactive]) ifTrue: [ self warns ifTrue: [self queryUndefined]]. parseNode nowHasRef. ^ true]. hereType == #leftBracket ifTrue: [self advance. self blockExpression. ^true]. hereType == #leftBrace ifTrue: [self braceExpression. ^true]. hereType == #leftParenthesis ifTrue: [self advance. self expression ifFalse: [^self expected: 'expression']. (self match: #rightParenthesis) ifFalse: [^self expected: 'right parenthesis']. ^true]. (hereType == #string or: [hereType == #number or: [hereType == #literal]]) ifTrue: [parseNode := encoder encodeLiteral: self advance. ^true]. (here == #- and: [tokenType == #number and: [1 + hereEnd = mark]]) ifTrue: [self advance. parseNode := encoder encodeLiteral: self advance negated. ^true]. ^false! ! !Parser methodsFor: 'expression types' stamp: 'eem 5/30/2008 14:16'! temporaryBlockVariablesFor: aBlockNode "Scan and answer temporary block variables." | variables | (self match: #verticalBar) ifFalse: "There are't any temporary variables." [^#()]. variables := OrderedCollection new. [hereType == #word] whileTrue: [variables addLast: (encoder bindBlockTemp: self advance within: aBlockNode)]. ^(self match: #verticalBar) ifTrue: [variables] ifFalse: [self expected: 'Vertical bar']! ! !Parser methodsFor: 'error handling' stamp: 'nice 2/22/2012 02:49'! expected: aString "Notify a problem at token 'here'." ^ self notify: aString , ' expected' at: hereMark + requestorOffset! ! !Parser methodsFor: 'error correction' stamp: ''! substituteSelector: selectorParts wordIntervals: spots "Substitute the correctSelector into the (presuamed interactive) receiver." | offset | offset := 0. selectorParts with: spots do: [ :word :interval | offset := self substituteWord: word wordInterval: interval offset: offset ] ! ! !Parser methodsFor: 'pragmas' stamp: 'lr 9/29/2010 08:25'! pragmaPrimitives | primitiveSelectors primitives | properties isEmpty ifTrue: [^0]. primitiveSelectors := self class primitivePragmaSelectors. primitives := properties pragmas select: [:pragma| primitiveSelectors includes: pragma keyword]. primitives isEmpty ifTrue: [^0]. primitives size > 1 ifTrue: [^self notify: 'Ambigous primitives']. ^self perform: primitives first keyword withArguments: primitives first arguments! ! !Parser methodsFor: 'private' stamp: 'MarcusDenker 4/27/2013 08:45'! warns "return whether the parser will ask the user for correction" ^ true! ! !Parser methodsFor: 'error correction' stamp: 'eem 9/5/2009 14:41'! substituteVariable: each atInterval: anInterval self substituteWord: each wordInterval: anInterval offset: 0. ^encoder encodeVariable: each! ! !Parser methodsFor: 'scanning' stamp: 'di 6/7/2000 08:44'! matchReturn ^ self match: #upArrow! ! !Parser methodsFor: 'error correction' stamp: 'StephaneDucasse 8/27/2010 10:54'! declareClassVar: name | sym class | sym := name asSymbol. class := encoder classEncoding. class := class theNonMetaClass. "not the metaclass" class addClassVarNamed: name. ^ encoder global: (class classPool associationAt: sym) name: sym! ! !Parser methodsFor: 'public access' stamp: 'pavel.krivanek 3/12/2009 09:40'! parse: sourceStreamOrString class: behavior ^ self parse: sourceStreamOrString readStream class: behavior noPattern: false context: nil notifying: nil ifFail: [ self fail ]! ! !Parser methodsFor: 'error correction' stamp: 'MarcusDenker 5/2/2013 11:34'! defineClass: className "Prompts the user to define a new class." | classSymbol systemCategory classDefinition | classSymbol := className asSymbol. systemCategory := self encoder classEncoding theNonMetaClass category ifNil: [ 'Unknown' ]. classDefinition := 'Object subclass: #' , classSymbol , ' instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''' , systemCategory , ''''. classDefinition := UIManager default multiLineRequest: 'Edit class definition:' initialAnswer: classDefinition answerHeight: 150. (classDefinition isNil or: [ classDefinition isEmpty ]) ifTrue: [ ^ self fail ]. self class compiler evaluate: classDefinition. ^ encoder global: (Smalltalk globals associationAt: classSymbol) name: classSymbol! ! !Parser methodsFor: 'scanning' stamp: ''! startOfNextToken "Return starting position in source of next token." hereType == #doIt ifTrue: [^source position + 1]. ^hereMark! ! !Parser methodsFor: 'pragmas' stamp: 'MarcusDenker 5/2/2013 11:35'! pragmaLiteral: selectorSoFar "Read a pragma literal. As a nicety we allow a variable name (rather than a literal string) as the second argument to primitive:error:" (hereType == #string or: [ hereType == #literal or: [ hereType == #number ] ]) ifTrue: [ ^ self advance ]. (here == $# and: [ tokenType == #word ]) ifTrue: [ ^ self advance ]. (here == #- and: [ tokenType == #number ]) ifTrue: [ ^ (self advance; advance) negated ]. (here = 'true' or: [ here = 'false' or: [ here = 'nil' ] ]) ifTrue: [ ^ self class compiler evaluate: self advance ]. "This nicety allows one to supply a primitive error temp as a variable name, rather than a string." ((selectorSoFar beginsWith: 'primitive:') and: [(selectorSoFar endsWith: 'error:') and: [hereType == #word]]) ifTrue: [^self advance]. ^self expected: 'Literal constant'! ! !Parser methodsFor: 'error handling' stamp: 'eem 5/14/2008 13:34'! addWarning: aString "ignored by the default compiler."! ! !Parser methodsFor: 'primitives' stamp: 'lr 9/29/2010 08:12'! primitive: anIntegerOrString error: errorCodeVariableOrNil "Create indexed primitive with optional error code." ^anIntegerOrString isInteger ifTrue: [errorCodeVariableOrNil ifNotNil: [encoder floatTemp: (encoder bindTemp: errorCodeVariableOrNil) nowHasDef]. anIntegerOrString] ifFalse: [anIntegerOrString isString ifTrue: [self primitive: anIntegerOrString module: nil error: errorCodeVariableOrNil] ifFalse: [self expected: 'Indexed primitive']]! ! !Parser methodsFor: 'error correction' stamp: 'cwp 10/17/2007 22:38/eem 9/5/2009 11:10 - => :='! queryUndefined | varStart varName | varName := parseNode key. varStart := self endOfLastToken + requestorOffset - varName size + 1. requestor selectFrom: varStart to: varStart + varName size - 1; select. (UndefinedVariable name: varName) ifFalse: [^ self fail]! ! !Parser methodsFor: 'scanning' stamp: 'hmm 7/16/2001 19:23'! endOfLastToken ^ prevEnd ifNil: [mark]! ! !Parser methodsFor: 'public access' stamp: 'ar 9/27/2005 19:19'! parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock ^self parse: sourceStream class: class category: nil noPattern: noPattern context: ctxt notifying: req ifFail: aBlock ! ! !Parser methodsFor: 'scanning' stamp: ''! matchToken: thing "Matches the token, not its type." here = thing ifTrue: [self advance. ^true]. ^false! ! !Parser methodsFor: 'error correction' stamp: 'MarcusDenker 3/5/2012 19:54'! correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." | correctSelector userSelection | "If we can't ask the user, assume that the keyword will be defined later" (self interactive and: [ self warns ]) ifFalse: [^proposedKeyword asSymbol]. userSelection := requestor selectionInterval. requestor selectFrom: spots first first to: spots last last. requestor select. correctSelector := UnknownSelector name: proposedKeyword. correctSelector ifNil: [^abortAction value]. requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. self substituteSelector: correctSelector keywords wordIntervals: spots. ^(proposedKeyword last ~~ $: and: [correctSelector last == $:]) ifTrue: [abortAction value] ifFalse: [correctSelector]! ! !Parser methodsFor: 'primitives' stamp: 'lr 9/29/2010 08:12'! primitive: aNameString module: aModuleStringOrNil "Create named primitive." ^self primitive: aNameString module: aModuleStringOrNil error: nil! ! !Parser methodsFor: 'error correction' stamp: 'RAA 6/5/2001 11:57'! declareTempAndPaste: name | insertion delta theTextString characterBeforeMark | theTextString := requestor text string. characterBeforeMark := theTextString at: tempsMark-1 ifAbsent: [$ ]. (theTextString at: tempsMark) = $| ifTrue: [ "Paste it before the second vertical bar" insertion := name, ' '. characterBeforeMark isSeparator ifFalse: [ insertion := ' ', insertion]. delta := 0. ] ifFalse: [ "No bars - insert some with CR, tab" insertion := '| ' , name , ' |',String cr. delta := 2. "the bar and CR" characterBeforeMark = Character tab ifTrue: [ insertion := insertion , String tab. delta := delta + 1. "the tab" ]. ]. tempsMark := tempsMark + (self substituteWord: insertion wordInterval: (tempsMark to: tempsMark-1) offset: 0) - delta. ^ encoder bindAndJuggle: name! ! !Parser methodsFor: 'expression types' stamp: 'PeterHugossonMiller 9/3/2009 10:15'! messagePart: level repeat: repeat | start receiver selector args precedence words keywordStart | [receiver := parseNode. (hereType == #keyword and: [level >= 3]) ifTrue: [start := self startOfNextToken. selector := (String new: 32) writeStream. args := OrderedCollection new. words := OrderedCollection new. [hereType == #keyword] whileTrue: [keywordStart := self startOfNextToken + requestorOffset. selector nextPutAll: self advance. words addLast: (keywordStart to: self endOfLastToken + requestorOffset). self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 2 repeat: true. args addLast: parseNode]. (Symbol hasInterned: selector contents ifTrue: [ :sym | selector := sym]) ifFalse: [ selector := self correctSelector: selector contents wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence := 3] ifFalse: [((hereType == #binary or: [hereType == #verticalBar]) and: [level >= 2]) ifTrue: [start := self startOfNextToken. selector := self advance asOctetString asSymbol. self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 1 repeat: true. args := Array with: parseNode. precedence := 2] ifFalse: [hereType == #word ifTrue: [start := self startOfNextToken. selector := self advance. args := #(). words := OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). (Symbol hasInterned: selector ifTrue: [ :sym | selector := sym]) ifFalse: [ selector := self correctSelector: selector wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence := 1] ifFalse: [^args notNil]]]. parseNode := MessageNode new receiver: receiver selector: selector arguments: args precedence: precedence from: encoder sourceRange: (start to: self endOfLastToken). repeat] whileTrue: []. ^true! ! !Parser methodsFor: 'error correction' stamp: 'eem 5/27/2009 09:27'! declareGlobal: name | sym | sym := name asSymbol. ^encoder global: (encoder environment at: sym put: nil; associationAt: sym) name: sym! ! !Parser methodsFor: 'primitives' stamp: 'nice 3/26/2011 23:15'! externalFunctionDeclaration "Parse the function declaration for a call to an external library." | descriptorClass callType retType externalName args argType module | descriptorClass := Smalltalk globals at: #ExternalFunction ifAbsent: [ nil ]. descriptorClass == nil ifTrue: [ ^ false ]. callType := descriptorClass callingConventionFor: here. callType == nil ifTrue: [ ^ false ]. "Parse return type" self advance. retType := self externalType: descriptorClass. retType == nil ifTrue: [ ^ self expected: 'return type' ]. "Parse function name or index" externalName := here. (self match: #string) ifTrue: [ externalName := externalName asSymbol ] ifFalse: [ (self match: #number) ifFalse: [ ^ self expected: 'function name or index' ] ]. (self matchToken: #'(') ifFalse: [ ^ self expected: 'argument list' ]. args := Array new writeStream. [ here == #')' ] whileFalse: [ argType := self externalType: descriptorClass. argType == nil ifTrue: [ ^ self expected: 'argument' ]. argType isVoid & argType isPointerType not ifFalse: [ args nextPut: argType ] ]. (args position = self properties selector numArgs) ifFalse: [ ^self expected: 'Matching number of arguments']. (self matchToken: #')') ifFalse: [ ^ self expected: ')' ]. (self matchToken: 'module:') ifTrue: [ module := here. (self match: #string) ifFalse: [ ^ self expected: 'String' ]. module := module asSymbol ]. Smalltalk globals at: #ExternalLibraryFunction ifPresent: [ :xfn | | fn | fn := xfn name: externalName module: module callType: callType returnType: retType argumentTypes: args contents. self allocateLiteral: fn ]. self addPragma: (Pragma keyword: #primitive: arguments: #(120)). ^ true! ! !Parser methodsFor: 'public access' stamp: 'BenjaminVanRyseghem 12/20/2012 14:48'! parse: sourceStream class: class category: aCategory noPattern: noPattern context: ctxt notifying: req ifFail: aBlock "Answer a MethodNode for the argument, sourceStream, that is the root of a parse tree. Parsing is done with respect to the argument, class, to find instance, class, and pool variables; and with respect to the argument, ctxt, to find temporary variables. Errors in parsing are reported to the argument, req, if not nil; otherwise aBlock is evaluated. The argument noPattern is a Boolean that is true if the the sourceStream does not contain a method header (i.e., for DoIts)." | methNode repeatNeeded myStream s p | category := aCategory. myStream := sourceStream. [repeatNeeded := false. p := myStream position. s := myStream upToEnd. myStream position: p. self encoder init: class context: ctxt notifying: self. self init: myStream notifying: req failBlock: [^ aBlock value]. doitFlag := noPattern. failBlock:= aBlock. [methNode := self method: noPattern context: ctxt] on: ReparseAfterSourceEditing do: [ :ex | repeatNeeded := true. myStream := requestor text string readStream]. repeatNeeded] whileTrue: [encoder := self encoder class new]. requestor ifNil: [ methNode sourceText: s ] ifNotNil: [ methNode sourceText: requestor text string ]. ^methNode ! ! !Parser methodsFor: 'error correction' stamp: ''! substituteWord: correctWord wordInterval: spot offset: o "Substitute the correctSelector into the (presuamed interactive) receiver." requestor correctFrom: (spot first + o) to: (spot last + o) with: correctWord. requestorOffset := requestorOffset + correctWord size - spot size. ^ o + correctWord size - spot size! ! !Parser methodsFor: 'expression types' stamp: 'eem 5/29/2008 09:36'! newMethodNode ^self encoder methodNodeClass new! ! !Parser methodsFor: 'pragmas' stamp: 'lr 10/5/2006 09:47'! pragmaSequence "Parse a sequence of method pragmas." [ true ] whileTrue: [ (self matchToken: #<) ifFalse: [ ^ self ]. self pragmaStatement. (self matchToken: #>) ifFalse: [ ^ self expected: '>' ] ]! ! !Parser methodsFor: 'error handling' stamp: 'pavel.krivanek 11/21/2008 16:57'! interactive ^ UIManager default interactiveParserFor: requestor! ! !Parser methodsFor: 'error handling' stamp: 'di 2/9/1999 15:43'! offEnd: aString "Notify a problem beyond 'here' (in lookAhead token). Don't be offEnded!!" requestorOffset == nil ifTrue: [^ self notify: aString at: mark] ifFalse: [^ self notify: aString at: mark + requestorOffset] ! ! !Parser methodsFor: 'error correction' stamp: 'cwp 10/15/2007 23:00'! canDeclareClassVariable ^encoder classEncoding ~~ UndefinedObject! ! !Parser methodsFor: 'temps' stamp: ''! bindTemp: name ^name! ! !Parser methodsFor: 'pragmas' stamp: 'eem 11/29/2008 16:44'! addPragma: aPragma properties := properties copyWith: aPragma! ! !Parser methodsFor: 'temps' stamp: 'eem 5/13/2008 12:17'! bindTemp: name in: methodSelector ^name! ! !Parser class methodsFor: 'accessing' stamp: 'lr 9/29/2010 08:24'! primitivePragmaSelectors "Answer the selectors of pragmas that specify VM primitives. Needed for compile and decomple." ^ (Pragma allNamed: #primitive from: self to: Parser) collect: [ :each | each selector ]! ! !ParserNotification commentStamp: 'TorstenBergmann 1/31/2014 11:18'! Common superclass for parser notifications! !ParserNotification methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2007 23:29/eem 9/5/2009 11:10 - => :='! setName: aString name := aString! ! !ParserNotification methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2007 21:36'! openMenuIn: aBlock self subclassResponsibility! ! !ParserNotification methodsFor: 'as yet unclassified' stamp: 'cwp 8/25/2009 20:04'! defaultAction self openMenuIn: [:labels :lines :caption | UIManager default chooseFrom: labels lines: lines title: caption]! ! !ParserNotification class methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2007 23:31'! name: aString ^ (self new setName: aString) signal! ! !Password commentStamp: ''! "Hold a password. There are three ways to get the password. If there is no password (sequence == nil), ask the user for it. If the use supplied one during this session, return that. It is cleared at shutDown. If sequence is a number, get the server passwords off the disk. File 'sqk.info' must be in the same folder 'Squeak.sources' file. Decode the file. Return the password indexed by sequence."! !Password methodsFor: 'accessing' stamp: 'tk 1/5/98 21:08'! decode: string "Xor with secret number -- just so file won't have raw password in it" | kk rand | rand := Random new seed: 234237. kk := (ByteArray new: string size) collect: [:bb | (rand next * 255) asInteger]. 1 to: kk size do: [:ii | kk at: ii put: ((kk at: ii) bitXor: (string at: ii) asciiValue)]. ^ kk asString! ! !Password methodsFor: 'accessing' stamp: 'StephaneDucasse 6/22/2012 18:58'! serverPasswords "Get the server passwords off the disk and decode them. The file 'sqk.info' must be in some folder that Squeak thinks is special (vm folder, or default directory). (Note: This code works even if you are running with no system sources file.)" | sfile | (sfile := FileSystem lookInUsualPlaces: 'pass.info') ifNil: [^ nil]. ^ (self decode: sfile contentsOfEntireFile) lines ! ! !Password methodsFor: 'accessing' stamp: 'SeanDeNigris 2/1/2013 21:56'! passwordFor: serverDir "Returned the password from one of many sources. OK if send in a nil arg." | sp msg | cache ifNotNil: [^ cache]. sequence ifNotNil: [ (sp := self serverPasswords) ifNotNil: [ sequence <= sp size ifTrue: [^ sp at: sequence]]]. msg := 'this directory'. (serverDir user = 'anonymous') & (serverDir typeWithDefault == #ftp) ifTrue: [ ^ cache := UIManager default request: 'Please let this anonymous ftp\server know your email address.\This is the polite thing to do.' withCRs initialAnswer: 'yourName@company.com']. ^ cache := UIManager default requestPassword: 'Password for ', serverDir user, ' at ', msg, ':'. "Diff between empty string and abort?"! ! !Password methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'! cache: anObject cache := anObject! ! !Password methodsFor: 'accessing' stamp: 'tk 1/5/98 21:14'! sequence: anNumber sequence := anNumber! ! !Password methodsFor: 'accessing' stamp: 'mir 6/29/2001 01:01'! sequence ^sequence! ! !Password class methodsFor: 'system startup' stamp: 'tk 6/24/1999 11:36'! shutDown "Forget all cached passwords, so they won't stay in the image" self allSubInstancesDo: [:each | each cache: nil].! ! !PasswordDialogWindow commentStamp: 'LaurentLaffont 4/15/2011 20:17'! I'm a Dialog whose TextEditors characters are replaced by *. Example: (UITheme builder openModal: (PasswordDialogWindow new title: 'Authentification'; textFont: StandardFonts defaultFont; text: 'Enter your password')) entryText explore! !PasswordDialogWindow methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/4/2012 22:51'! showPassword: aBoolean (showPassword := aBoolean) ifTrue: [ self beDecrypted ] ifFalse: [ self beEncrypted ]. self changed: #showPassword! ! !PasswordDialogWindow methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/4/2012 22:42'! beEncrypted textEditor font: (StrikeFont passwordFontSize: self theme textFont pointSize)! ! !PasswordDialogWindow methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/4/2012 22:52'! showPasswordButton ^ (CheckboxMorph on: self selected: #showPassword changeSelected: #showPassword:) label: 'Show password'; labelClickable: true; height: 25.! ! !PasswordDialogWindow methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 5/4/2012 22:47'! newContentMorph "Answer a new content morph." self iconMorph: self newIconMorph. self textMorph: self newTextMorph. self textMorph wrapFlag: false. self textEditorMorph: self newTextEditorMorph. ^self newGroupboxForAll: { self newRow: {self iconMorph. self textMorph}. self textEditorMorph. self showPasswordButton}! ! !PasswordDialogWindow methodsFor: 'creation' stamp: 'BenjaminVanRyseghem 5/4/2012 22:42'! newTextEditorMorph "Answer a new morph for the text entry using a password font." textEditor := super newTextEditorMorph. self beEncrypted. ^ textEditor! ! !PasswordDialogWindow methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/4/2012 22:48'! showPassword ^ showPassword ifNil: [ showPassword := false ]! ! !PasswordDialogWindow methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/4/2012 22:43'! beDecrypted textEditor font: self theme textFont! ! !PasswordInitializationDialogWindow commentStamp: ''! A PasswordInitializationDialogWindow is a dialog window asking twice for the same pssword to confirm it. Used to set a password and ensure the entered value! !PasswordInitializationDialogWindow methodsFor: 'creation' stamp: 'BenjaminVanRyseghem 5/11/2012 16:06'! ok | boolean | boolean := (textEditorMorph textMorph text = confirmationTextEditorMorph textMorph text). boolean ifFalse: [ self setInvalidLabel. textEditorMorph setText: ''. confirmationTextEditorMorph setText: ''. ^ self ]. self cancelled: false; applyChanges; delete! ! !PasswordInitializationDialogWindow methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/10/2012 23:45'! beEncrypted textEditorMorph font: (StrikeFont passwordFontSize: self theme textFont pointSize). confirmationTextEditorMorph font: (StrikeFont passwordFontSize: self theme textFont pointSize)! ! !PasswordInitializationDialogWindow methodsFor: 'creation' stamp: 'BenjaminVanRyseghem 5/10/2012 23:44'! showPasswordButton ^ (CheckboxMorph on: self selected: #showPassword changeSelected: #showPassword:) label: 'Show password'; labelClickable: true; height: 25.! ! !PasswordInitializationDialogWindow methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/7/2012 11:40'! newConfirmationTextMorph ^ 'Please confirm your password' asMorph.! ! !PasswordInitializationDialogWindow methodsFor: 'creation' stamp: 'BenjaminVanRyseghem 5/7/2012 11:28'! newTextEditorMorph "Answer a new morph for the text entry using a password font." |textEditor| textEditor := super newTextEditorMorph. textEditor font: (StrikeFont passwordFontSize: self theme textFont pointSize). ^textEditor! ! !PasswordInitializationDialogWindow methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 5/11/2012 15:57'! newContentMorph "Answer a new content morph." self iconMorph: self newIconMorph. self textMorph: self newTextMorph. self confirmationTextMorph: self newConfirmationTextMorph. self textMorph wrapFlag: false. self textEditorMorph: self newTextEditorMorph. self confirmationTextEditorMorph: self newTextEditorMorph. ^self newGroupboxForAll: { self newRow: {self iconMorph. self textMorph}. self textEditorMorph. self confirmationTextMorph. self confirmationTextEditorMorph. self newRow: {self showPasswordButton. self buildInvalidPasswordLabel}}! ! !PasswordInitializationDialogWindow methodsFor: 'creation' stamp: 'IgorStasenko 12/20/2012 14:56'! setInvalidLabel: aString container removeAllMorphs. container addMorph: aString asMorph fullFrame: LayoutFrame identity ! ! !PasswordInitializationDialogWindow methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/10/2012 13:32'! enteredValue ^ self cancelled ifTrue: [ nil ] ifFalse: [ textEditorMorph text asString ]! ! !PasswordInitializationDialogWindow methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/10/2012 23:44'! showPassword ^ showPassword ifNil: [ showPassword := false ]! ! !PasswordInitializationDialogWindow methodsFor: 'creation' stamp: 'BenjaminVanRyseghem 5/9/2012 23:07'! newTextMorph "Answer a text morph." ^self newText: 'Please enter your password'! ! !PasswordInitializationDialogWindow methodsFor: 'creation' stamp: 'BenjaminVanRyseghem 5/11/2012 15:58'! buildInvalidPasswordLabel container := PanelMorph new color: Color transparent; changeProportionalLayout; height: 25; vResizing: #rigid; hResizing: #spaceFill; yourself. ^ container! ! !PasswordInitializationDialogWindow methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/10/2012 23:44'! showPassword: aBoolean (showPassword := aBoolean) ifTrue: [ self beDecrypted ] ifFalse: [ self beEncrypted ]. self changed: #showPassword! ! !PasswordInitializationDialogWindow methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:06'! initialize super initialize. self textFont: Smalltalk ui theme textFont.! ! !PasswordInitializationDialogWindow methodsFor: 'creation' stamp: 'BenjaminVanRyseghem 5/11/2012 16:04'! setInvalidLabel self setInvalidLabel: ('passwords are not the same' asMorph color: Color red)! ! !PasswordInitializationDialogWindow methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/10/2012 23:45'! beDecrypted textEditorMorph font: self theme textFont. confirmationTextEditorMorph font: self theme textFont.! ! !PasswordInitializationDialogWindow methodsFor: 'creation' stamp: 'BenjaminVanRyseghem 5/11/2012 15:55'! invalidPasswordLabel ^ LabelMorph new text: ''! ! !PasswordInitializationDialogWindow methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 5/9/2012 23:09'! defaultLabel ^ 'Enter your password'! ! !PasswordInitializationDialogWindow methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/7/2012 11:29'! confirmationTextEditorMorph ^ confirmationTextEditorMorph! ! !PasswordInitializationDialogWindow methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 5/7/2012 11:32'! confirmationTextMorph ^ confirmationTextMorph! ! !PasswordInitializationDialogWindow methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 5/7/2012 11:32'! confirmationTextMorph: aMorph confirmationTextMorph := aMorph! ! !PasswordInitializationDialogWindow methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/9/2012 23:30'! autoAccept ^false! ! !PasswordInitializationDialogWindow methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/7/2012 11:29'! confirmationTextEditorMorph: anObject confirmationTextEditorMorph := anObject! ! !PasteUpMorph commentStamp: ''! A morph whose submorphs comprise a paste-up of rectangular subparts which "show through". Anything called a 'Playfield' is a PasteUpMorph. Facilities commonly needed on pages of graphical presentations and on simulation playfields, such as the painting of new objects, turtle trails, gradient fills, background paintings, parts-bin behavior, collision-detection, etc., are (or will be) provided. ! !PasteUpMorph methodsFor: 'world state' stamp: 'alain.plantec 5/30/2008 14:07'! handleFatalDrawingError: errMsg "Handle a fatal drawing error." Display deferUpdates: false. "Just in case" self primitiveError: errMsg. "Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'nice 1/5/2010 15:59'! findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" submorphs do: [:aMorph | | aWindow | (((aWindow := aMorph renderedMorph) isSystemWindow) and: [qualifyingBlock value: aWindow]) ifTrue: [aWindow isCollapsed ifTrue: [aWindow expand]. aWindow activateAndForceLabelToShow. ^self]]. "None found, so create one" makeBlock value openInWorld! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'di 10/18/2001 02:58'! grabLassoFromScreen: evt "Allow the user to specify a polygonal area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand." self extractScreenRegion: (PolygonMorph fromHandFreehand: evt hand) andPutSketchInHand: evt hand ! ! !PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: 'MarianoMartinezPeck 5/2/2012 23:49'! closeAllWindowsDiscardingChanges World systemWindows do: [:w | [w delete] valueSupplyingAnswer: false]! ! !PasteUpMorph methodsFor: 'submorphs-accessing' stamp: 'nk 7/4/2003 16:49'! morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock "Include hands if the receiver is the World" self handsDo:[:m| m == someMorph ifTrue:["Try getting out quickly" owner ifNil:[^self]. ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock]. "The hand only overlaps if it's not the hardware cursor" m needsToBeDrawn ifTrue:[ (m fullBoundsInWorld intersects: aRectangle) ifTrue:[aBlock value: m]]]. ^super morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock! ! !PasteUpMorph methodsFor: 'world state' stamp: 'dgd 9/5/2004 19:46'! restoreMainDockingBarDisplay "Restore the display of docking bars" self dockingBars do: [:each | each updateBounds]! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 7/18/2010 15:20'! initialize "initialize the state of the receiver" super initialize. self enableDragNDrop. self clipSubmorphs: true! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 2/4/2001 00:54'! dropEnabled "Get this morph's ability to add and remove morphs via drag-n-drop." ^ (self valueOfProperty: #dropEnabled) ~~ false ! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'tbn 11/4/2008 09:15'! keyboardNavigationHandler "Answer the receiver's existing keyboardNavigationHandler, or nil if none." | aHandler | aHandler := self valueOfProperty: #keyboardNavigationHandler ifAbsent: [^ nil]. (aHandler hasProperty: #moribund) ifTrue: "got clobbered in another project" [self removeProperty: #keyboardNavigationHandler. ^ nil]. ^ aHandler! ! !PasteUpMorph methodsFor: 'world state' stamp: 'AlainPlantec 7/9/2013 12:39'! restoreMorphicDisplay DisplayScreen startUp. ThumbnailMorph recursionReset. self extent: Display extent; viewBox: Display boundingBox; handsDo: [:h | h visible: true; showTemporaryCursor: nil]; resizeBackgroundMorph; restoreMainDockingBarDisplay; fullRepaintNeeded. self defer: [Cursor normal show]. self layoutChanged. ! ! !PasteUpMorph methodsFor: 'options' stamp: 'ar 11/9/2000 12:49'! resizeToFit ^self vResizing == #shrinkWrap! ! !PasteUpMorph methodsFor: 'options' stamp: 'dgd 12/13/2003 19:30'! resizeToFitString "Answer a string, to be used in a self-updating menu, to represent whether the receiver is currently using resize-to-fit or not" ^ (self resizeToFit ifTrue: [''] ifFalse: ['']) , 'resize to fit' translated! ! !PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 4/4/2006 13:58'! bringTopmostsToFront submorphs select:[:m| m wantsToBeTopmost] thenDo:[:m| self addMorphInLayer: m].! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'di 10/18/2001 01:13'! grabRubberBandFromScreen: evt "Allow the user to specify a polygonal area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand." self extractScreenRegion: (PolygonMorph fromHand: evt hand) andPutSketchInHand: evt hand! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 14:36'! systemWindows "Answer the system windows in the world." ^self submorphsSatisfying: [:m | m isSystemWindow]! ! !PasteUpMorph methodsFor: 'accessing' stamp: 'ar 4/25/2001 17:15'! useRoundedCorners "Somewhat special cased because we do have to fill Display for this" super useRoundedCorners. self == World ifTrue:[Display bits primFill: 0]. "done so that we *don't* get a flash"! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'IgorStasenko 1/2/2012 19:05'! grabDrawingFromScreen: evt "Allow the user to specify a rectangular area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand." | m | m := self drawingClass withForm: Form fromUser. evt hand position: self activeHand cursorPoint. "update hand pos after Sensor loop in fromUser" evt hand attachMorph: m.! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'AlainPlantec 2/17/2010 09:35'! invokeWorldMenu: evt "Put up the world menu, triggered by the passed-in event." | menu | self bringTopmostsToFront. "put up screen menu" (menu := self worldMenu) popUpEvent: evt in: self. ^ menu! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/3/2010 17:59'! resizeBackgroundMorph "Resize the background morph to fit the world." self backgroundMorph isNil ifFalse: [ self backgroundMorph extent: self extent]! ! !PasteUpMorph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 4/21/2011 14:33'! drawOnAthensCanvas: aCanvas "Draw in order: - background color - background sketch, if any - Update and draw the turtleTrails form. See the comment in updateTrailsForm. Later (in drawSubmorphsOn:) I will skip drawing the background sketch." "draw background fill" super drawOnAthensCanvas: aCanvas. backgroundMorph ifNotNil: [ aCanvas clipBy: self clippingBounds during: [ aCanvas fullDrawMorph: backgroundMorph ] ] ! ! !PasteUpMorph methodsFor: 'wiw support' stamp: 'RAA 8/14/2000 12:10'! shouldGetStepsFrom: aWorld (self isWorldMorph and: [owner notNil]) ifTrue: [ ^self outermostWorldMorph == aWorld ]. ^super shouldGetStepsFrom: aWorld! ! !PasteUpMorph methodsFor: 'drawing' stamp: 'StephaneDucasse 6/27/2013 22:54'! drawOn: aCanvas "Draw in order: - background color - grid, if any - background sketch, if any Later (in drawSubmorphsOn:) I will skip drawing the background sketch." super drawOn: aCanvas. self drawGridOn: aCanvas. self drawBackgroundSketchOn: aCanvas! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:48'! griddingOnOff griddingOn := self griddingOn not. self changed! ! !PasteUpMorph methodsFor: 'taskbar' stamp: 'MarcusDenker 3/23/2011 15:37'! removeTaskbar "Remove the receiver's taskbars." self taskbars do: [:each | each removeFromWorld]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/11/2004 20:45'! delayedInvokeWorldMenu: evt self addAlarm: #invokeWorldMenu: with: evt after: 200! ! !PasteUpMorph methodsFor: 'testing' stamp: 'StephaneDucasse 6/28/2013 13:17'! isEasySelecting "This is to isolate easySelection predicate. Selectors in holders make no sense so we are limiting easy selection to the worldMorph. It would also make sense in playfield so feel free to adjust this predicate. Selection can always be forced by using the shift before mouse down." ^ false! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'StephaneDucasse 3/3/2010 15:32'! drawingClass ^ ImageMorph! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'SeanDeNigris 1/23/2014 11:58'! navigationKey: aKeyboardEvent ^ self taskList handleEvent: aKeyboardEvent.! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! addMorph: aMorph centeredNear: aPoint "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." | trialRect delta | trialRect := Rectangle center: aPoint extent: aMorph fullBounds extent. delta := trialRect amountToTranslateWithin: bounds. aMorph position: trialRect origin + delta. self addMorph: aMorph. ! ! !PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: 'CamilleTeruel 12/6/2013 14:44'! findWindow: evt "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." | menu expanded collapsed nakedMorphs | menu := UIManager default newMenuIn: self for: self. expanded := self windowsSatisfying: [:w | w isCollapsed not]. collapsed := self windowsSatisfying: [:w | w isCollapsed]. nakedMorphs := self submorphsSatisfying:[:m | m isSystemWindow not]. (expanded isEmpty and: [collapsed isEmpty and: [nakedMorphs isEmpty]]) ifTrue: [^ self inform: 'No morph in world']. (expanded asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: [:w | menu add: w label target: w action: #activateAndForceLabelToShow. w model canDiscardEdits ifFalse: [menu lastItem color: Color red]]. (expanded isEmpty or: [ collapsed isEmpty and: [ nakedMorphs isEmpty ]]) ifFalse: [menu addLine]. (collapsed asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: [:w | menu add: w label target: w action: #collapseOrExpand. w model canDiscardEdits ifFalse: [menu lastItem color: Color red]]. nakedMorphs isEmpty ifFalse: [menu addLine]. (nakedMorphs asSortedCollection: [:w1 :w2 | w1 class name caseInsensitiveLessOrEqual: w2 class name]) do: [:w | menu add: w class name target: w action: #comeToFrontAndAddHalo]. menu addTitle: 'find window' translated. menu popUpEvent: evt in: self.! ! !PasteUpMorph methodsFor: 'accessing' stamp: 'tak 3/15/2005 17:31'! removeModalWindow self modalWindow: nil! ! !PasteUpMorph methodsFor: 'world state' stamp: 'StephaneDucasse 10/25/2013 16:17'! flashRects: rectangleList color: aColor "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." "Details: Uses two reverses so that the display is restored to its original state. This is necessary when in deferred update mode." | blt | blt := (BitBlt toForm: Display) sourceForm: nil; sourceOrigin: 0@0; clipRect: self viewBox; combinationRule: Form reverse. rectangleList do: [:r | | screenRect | screenRect := r translateBy: self viewBox origin. blt destRect: screenRect; copyBits. Display forceToScreen: screenRect; forceDisplayUpdate. (Delay forMilliseconds: 15) wait. blt destRect: screenRect; copyBits. Display forceToScreen: screenRect; forceDisplayUpdate]. ! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'dgd 12/13/2003 19:30'! griddingString "Answer a string to use in a menu offering the user the opportunity to start or stop using gridding" ^ (self griddingOn ifTrue: [''] ifFalse: ['']) , 'use gridding' translated! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/29/2008 10:59'! nextVisibleWindow "Answer the next (visible) window to navigate to." |sys| sys := self visibleSystemWindows. sys ifEmpty: [^nil]. ^sys after: self currentWindow ifAbsent: [sys first]! ! !PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: 'MarcusDenker 9/13/2013 16:28'! bringWindowsFullOnscreen "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." | r | bounds allAreasOutsideList: (self taskbars collect: [ :t | t bounds ]) do: [ :e | r isNil ifTrue: [ r := e ] ifFalse: [ r area > e area ifTrue: [ r ] ifFalse: [ e ] ] ]. (self windowsSatisfying: [ :w | true ]) do: [ :aWindow | aWindow right: (aWindow right min: r right). aWindow bottom: (aWindow bottom min: r bottom). aWindow left: (aWindow left max: r left). aWindow top: (aWindow top max: r top) ]! ! !PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'sw 1/10/2000 16:44'! defersHaloOnClickTo: aSubMorph "If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true" ^ true ! ! !PasteUpMorph methodsFor: 'user interface' stamp: 'dgd 2/22/2003 14:11'! modelWakeUp "I am the model of a SystemWindow, that has just been activated" | aWindow | owner isNil ifTrue: [^self]. "Not in Morphic world" (owner isKindOf: TransformMorph) ifTrue: [^self viewBox: self fullBounds]. (aWindow := self containingWindow) ifNotNil: [self viewBox = aWindow panelRect ifFalse: [self viewBox: aWindow panelRect]]! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'HenrikSperreJohansen 4/7/2010 09:58'! windowEvent: anEvent self windowEventHandler ifNotNil: [^self windowEventHandler windowEvent: anEvent]. anEvent type == #windowClose ifTrue: [WorldState quitSession]. ! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'SeanDeNigris 2/16/2014 20:33'! makeAScreenshot | filePrefix | filePrefix := 'PharoScreenshot'. (UIManager default chooseFrom: {'The entire world' translated. 'A selected area' translated} values: #(#world #area ) message: 'What do you want to shoot? (File will be saved in image directory)' translated title: 'Make a screenshot') ifNotNil: [:choice | |form | form := choice = #world ifTrue: [World imageForm] ifFalse: [Form fromUser]. PNGReadWriter putForm: form onFileNamed: (FileSystem workingDirectory / filePrefix , 'png') nextVersion] ! ! !PasteUpMorph methodsFor: 'drawing' stamp: 'StephaneDucasse 6/27/2013 19:19'! drawSubmorphsOn: aCanvas "Display submorphs back to front, but skip my background sketch." | drawBlock | submorphs isEmpty ifTrue: [ ^ self ]. drawBlock := [ :canvas | submorphs reverseDo: [ :m | m ~~ backgroundMorph ifTrue: [ canvas fullDrawMorph: m ] ] ]. self clipSubmorphs ifTrue: [ aCanvas clipBy: (aCanvas clipRect intersect: self clippingBounds ifNone: [ ^ self ]) during: drawBlock ] ifFalse: [ drawBlock value: aCanvas ]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'StephaneDucasse 6/28/2013 13:20'! discoveredWorldMenu ^ owner discoveredWorldMenu ! ! !PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: 'AlainPlantec 1/9/2010 06:22'! collapseAll "Collapse all windows" (self windowsSatisfying: [:w | w isCollapsed not]) reverseDo: [:w | w collapseOrExpand. self displayWorld]. self collapseNonWindows! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 16:14'! currentWindow "Answer the top window." ^SystemWindow topWindow! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 12:19'! dispatchCommandKeyInWorld: aChar event: evt "Dispatch the desktop command key if possible. Answer whether handled" | aMessageSend | aMessageSend := self commandKeySelectors at: aChar ifAbsent: [^ false]. aMessageSend selector numArgs = 0 ifTrue: [aMessageSend value] ifFalse: [aMessageSend valueWithArguments: (Array with: evt)]. ^ true ! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/29/2008 11:00'! visibleSystemWindows "Answer the visible system windows in the world." ^self submorphsSatisfying: [:m | m isSystemWindow and: [m visible]]! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:11'! gridVisible ^ self hasProperty: #gridVisible! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 9/19/2000 22:17'! dragThroughOnDesktop: evt "Draw out a selection rectangle" | selection | selection := SelectionMorph newBounds: (evt cursorPoint extent: 8@8). self addMorph: selection. ^ selection extendByHand: evt hand ! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'StephaneDucasse 6/27/2013 19:32'! wantsDroppedMorph: aMorph event: evt self visible ifFalse: [^ false]. "will be a call to #hidden again very soon" self dropEnabled ifFalse: [^ false]. ^ true! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:47'! gridVisibleOnOff self setProperty: #gridVisible toValue: self gridVisible not. self changed! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/18/2003 23:10'! keyboardNavigationHandler: aHandler "Set the receiver's keyboard navigation handler as indicated. A nil argument means to remove the handler" aHandler ifNil: [self removeProperty: #keyboardNavigationHandler] ifNotNil: [self setProperty: #keyboardNavigationHandler toValue: aHandler]! ! !PasteUpMorph methodsFor: 'taskbar' stamp: 'MarcusDenker 3/23/2011 15:37'! showWorldTaskbar: aBoolean "Change the receiver to show the taskbar." aBoolean ifTrue: [self createTaskbarIfNecessary] ifFalse: [self removeTaskbar]! ! !PasteUpMorph methodsFor: 'project state' stamp: 'StephaneDucasse 6/28/2013 13:14'! viewBox: newViewBox "I am now displayed within newViewBox; react." super position: newViewBox topLeft. fullBounds := bounds := newViewBox. ! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'StephaneDucasse 7/2/2013 17:26'! acceptDroppingMorph: dropped event: evt "The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied" | aMorph | aMorph := self morphToDropFrom: dropped. super acceptDroppingMorph: aMorph event: evt. aMorph submorphsDo: [ :m | (m isKindOf: HaloMorph) ifTrue: [ m delete ] ]. self bringTopmostsToFront! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'GuillermoPolito 9/4/2010 17:37'! keystrokeInWorld: evt "A keystroke was hit when no keyboard focus was set, so it is sent here to the world instead." | aChar ascii | aChar := evt keyCharacter. (ascii := aChar asciiValue) = 27 ifTrue: "escape key" [^ self invokeWorldMenuFromEscapeKey]. (self navigationKey: evt) ifTrue: [^self]. (evt controlKeyPressed not and: [(#(1 4 8 28 29 30 31 32) includes: ascii) "home, end, backspace, arrow keys, space" and: [self keyboardNavigationHandler notNil]]) ifTrue: [self keyboardNavigationHandler navigateFromKeystroke: aChar]. (evt commandKeyPressed and: [Editor cmdKeysInText]) ifTrue: [^ self dispatchCommandKeyInWorld: aChar event: evt]. "It was unhandled. Remember the keystroke." self lastKeystroke: evt keyString. self triggerEvent: #keyStroke! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'FernandoOlivero 4/12/2011 10:11'! backgroundImage: aForm layout: aSymbol "Set a background image, replacing the current background morph, if any, with the given layout (see AlphaImageMorph layoutSymbols). " self backgroundMorph: ( (self theme builder newAlphaImage: aForm help: nil) autoSize: false; layout: aSymbol; lock)! ! !PasteUpMorph methodsFor: 'drawing' stamp: 'AlainPlantec 5/8/2010 00:31'! gridFormOrigin: origin grid: smallGrid background: backColor line: lineColor | bigGrid gridForm gridOrigin | gridOrigin := origin \\ smallGrid. bigGrid := (smallGrid asPoint x) @ (smallGrid asPoint y). gridForm := Form extent: bigGrid depth: Display depth. backColor ifNotNil: [gridForm fillWithColor: backColor]. gridOrigin x to: gridForm width by: smallGrid x do: [:x | gridForm fill: (x@0 extent: 1@gridForm height) fillColor: lineColor]. gridOrigin y to: gridForm height by: smallGrid y do: [:y | gridForm fill: (0@y extent: gridForm width@1) fillColor: lineColor]. ^ InfiniteForm with: gridForm ! ! !PasteUpMorph methodsFor: '*Tools' stamp: 'MarcusDenker 4/2/2013 15:47'! defaultDesktopCommandKeyTriplets "Answer a list of triplets of the form [+ optional fourth element, a for use in desktop-command-key-help] that will provide the default desktop command key handlers. If the selector takes an argument, that argument will be the command-key event" ^ { { $r. ActiveWorld. #restoreMorphicDisplay. 'Redraw the screen'}. { $b. Smalltalk tools browser. #open. 'Open a new System Browser'}. { $k. Smalltalk tools workspace. #open. 'Open a new, blank Workspace'}. { $t. Smalltalk tools transcript. #open. 'Make a System Transcript visible'}. { $C. self. #findAChangeSorter:. 'Make a Change Sorter visible'}. { $R. Smalltalk tools recentMessageList.#open. 'Open a Recent Submissions browser'}. { $W. Smalltalk tools finder. #open. 'Open a new Finder'}. { $Z. Smalltalk tools changeList. #browseRecentLog. 'Browse recently-logged changes'}. { $\. SystemWindow. #sendTopWindowToBack. 'Send the top window to the back'}. }. ! ! !PasteUpMorph methodsFor: 'project state' stamp: 'MarcusDenker 9/13/2013 15:51'! steppingMorphsNotInWorld | all | all := self allMorphs. ^ self listOfSteppingMorphs reject: [ :m | all includes: m ] "self currentWorld steppingMorphsNotInWorld do: [:m | m delete]"! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'nk 1/6/2004 12:38'! extractScreenRegion: poly andPutSketchInHand: hand "The user has specified a polygonal area of the Display. Now capture the pixels from that region, and put in the hand as a Sketch." | screenForm outline topLeft innerForm exterior | outline := poly shadowForm. topLeft := outline offset. exterior := (outline offset: 0@0) anyShapeFill reverse. screenForm := Form fromDisplay: (topLeft extent: outline extent). screenForm eraseShape: exterior. innerForm := screenForm trimBordersOfColor: Color transparent. innerForm isAllWhite ifFalse: [hand attachMorph: (self drawingClass withForm: innerForm)]! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'StephaneDucasse 7/2/2013 17:29'! dispatchKeystroke: anEvent anEvent keyCharacter == Character tab ifTrue: [ self tabAmongFields ifTrue: [ ^ self tabHitWithEvent: anEvent ] ]! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/3/2010 17:59'! backgroundMorph "Answer the background morph if any." ^backgroundMorph! ! !PasteUpMorph methodsFor: 'stepping' stamp: 'StephaneDucasse 11/7/2011 22:43'! cleanseOtherworldlySteppers "If the current project is a morphic one, then remove from its steplist those morphs that are not really in the world" "Utilities cleanseOtherworldlySteppers" | old delta | old := self currentWorld stepListSize. self currentWorld steppingMorphsNotInWorld do: [:m | m delete]. self currentWorld cleanseStepList. (delta := old - self currentWorld stepListSize) > 0 ifTrue: [ self crTrace: delta asString , ' morphs removed from steplist' ]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'StephaneDucasse 6/28/2013 13:04'! worldMenu ^ owner worldMenu ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'StephaneDucasse 3/3/2010 15:49'! addWorldHaloMenuItemsTo: aMenu hand: aHandMorph "Add standard halo items to the menu, given that the receiver is a World" self addFillStyleMenuItems: aMenu hand: aHandMorph. self addLayoutMenuItems: aMenu hand: aHandMorph. aMenu addLine. self addWorldToggleItemsToHaloMenu: aMenu. aMenu addLine. self addExportMenuItems: aMenu hand: aHandMorph. self addMiscExtrasTo: aMenu. self addDebuggingItemsTo: aMenu hand: aHandMorph. aMenu addLine. aMenu defaultTarget: aHandMorph. ! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:15'! griddingOn ^ griddingOn ifNil: [false]! ! !PasteUpMorph methodsFor: 'drawing' stamp: 'StephaneDucasse 6/27/2013 22:54'! drawGridOn: aCanvas (self griddingOn and: [ self gridVisible ]) ifTrue: [ aCanvas fillRectangle: self bounds fillStyle: (self gridFormOrigin: self gridOrigin grid: self gridModulus background: nil line: Color lightGray) ]! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'StephaneDucasse 7/2/2013 17:40'! mouseDown: evt "Handle a mouse down event." | grabbedMorph handHadHalos | (self defaultYellowButtonMenuEnabled and: [evt yellowButtonPressed]) ifTrue: [ (self yellowButtonActivity: evt shiftPressed) ifTrue: [ ^ self ]]. grabbedMorph := self morphToGrab: evt. grabbedMorph ifNotNil: [ grabbedMorph isSticky ifTrue: [^self]. ^evt hand grabMorph: grabbedMorph]. (super handlesMouseDown: evt) ifTrue: [^super mouseDown: evt]. handHadHalos := evt hand halo notNil. evt hand removeHalo. "shake off halos" self isWorldMorph ifTrue: [ self currentWindow ifNotNil: [:topWindow | SystemWindow passivateTopWindow]]. "since pasteup will release keyboard focus now" evt hand releaseKeyboardFocus. "shake of keyboard foci" (evt shiftPressed not and: [ self isWorldMorph not and: [ self wantsEasySelection not ]]) ifTrue: [ "explicitly ignore the event if we're not the world and we'll not select, so that we could be picked up if need be" evt wasHandled: false. ^ self. ]. ( evt shiftPressed or: [ self wantsEasySelection ] ) ifTrue: [ "We'll select on drag, let's decide what to do on click" | clickSelector | clickSelector := nil. evt shiftPressed ifTrue: [ clickSelector := #findWindow:.] ifFalse: [self isWorldMorph ifTrue: [clickSelector := handHadHalos ifTrue: [ #delayedInvokeWorldMenu: ] ifFalse: [ #invokeWorldMenu: ]]]. evt hand waitForClicksOrDrag: self event: evt selectors: { clickSelector. nil. nil. #dragThroughOnDesktop: } threshold: 5. ] ifFalse: [ "We wont select, just bring world menu if I'm the world" self isWorldMorph ifTrue: [ handHadHalos ifTrue: [ self delayedInvokeWorldMenu: evt ] ifFalse: [ self invokeWorldMenu: evt ] ] ]. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ar 3/18/2001 00:35'! restoreDisplay World restoreMorphicDisplay. "I don't actually expect this to be called"! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 13:52'! commandKeySelectors "Answer my command-key table" | aDict | aDict := self valueOfProperty: #commandKeySelectors ifAbsentPut: [self initializeDesktopCommandKeySelectors]. ^ aDict! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'StephaneDucasse 6/28/2013 13:04'! worldMenuAt: aMenuItemName ^ owner worldMenuAt: aMenuItemName ! ! !PasteUpMorph methodsFor: 'wiw support' stamp: 'dgd 8/31/2004 16:25'! addMorphInLayer: aMorph super addMorphInLayer: aMorph. aMorph wantsToBeTopmost ifFalse:[self bringTopmostsToFront].! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 1.0 b: 0.6! ! !PasteUpMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 6/27/2013 19:34'! modalWindow: aMorph (self valueOfProperty: #modalWindow) ifNotNil: [ :morph | morph doCancel ]. self setProperty: #modalWindow toValue: aMorph. aMorph ifNotNil: [ self when: #aboutToLeaveWorld send: #removeModalWindow to: self ]! ! !PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: 'nice 1/5/2010 15:59'! windowsSatisfying: windowBlock | windows | windows := OrderedCollection new. self submorphs do: [:m | | s | ((m isSystemWindow) and: [windowBlock value: m]) ifTrue: [windows addLast: m] ifFalse: [((m isKindOf: TransformationMorph) and: [m submorphs size = 1]) ifTrue: [s := m firstSubmorph. ((s isSystemWindow) and: [windowBlock value: s]) ifTrue: [windows addLast: s]]]]. ^ windows! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'StephaneDucasse 7/2/2013 17:28'! keyStroke: anEvent "A keystroke has been made. Service event handlers and, if it's a keystroke presented to the world, dispatch it to #unfocusedKeystroke:" super keyStroke: anEvent. "Give event handlers a chance" self selectedObject ifNotNil: [ :selected | selected moveOrResizeFromKeystroke: anEvent ]. self dispatchKeystroke: anEvent! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'AlainPlantec 12/13/2009 08:11'! lastKeystroke "Answer the last keystroke fielded by the receiver" ^ self valueOfProperty: #lastKeystroke ifAbsent: ['']! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'MarcusDenker 4/29/2011 00:37'! themeChanged "The theme has changed. Update the desktop wallpaper if appropriate." (self theme desktopImageFor: self) ifNotNil: [:aForm | self color: Color white. self backgroundImage: aForm layout: self theme desktopImageLayout]. super themeChanged! ! !PasteUpMorph methodsFor: 'drawing' stamp: 'MarcusDenker 10/10/2013 23:47'! drawBackgroundSketchOn: aCanvas backgroundMorph ifNil: [ ^ self ]. self clipSubmorphs ifTrue: [ aCanvas clipBy: self clippingBounds during: [ :canvas | canvas fullDrawMorph: backgroundMorph ] ] ifFalse: [ aCanvas fullDrawMorph: backgroundMorph ]! ! !PasteUpMorph methodsFor: 'options' stamp: 'tk 10/30/2001 18:41'! toggleResizeToFit "Toggle whether the receiver is set to resize-to-fit" self vResizeToFit: self resizeToFit not! ! !PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'RAA 12/16/2000 18:37'! addMorphFront: aMorph ^self addMorphInFrontOfLayer: aMorph ! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:28'! gridSpecPut: newSpec "Gridding rectangle provides origin and modulus" ^ self setProperty: #gridSpec toValue: newSpec! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'AlainPlantec 2/17/2010 01:53'! invokeWorldMenuFromEscapeKey self invokeWorldMenu: ActiveEvent! ! !PasteUpMorph methodsFor: 'world state' stamp: 'StephaneDucasse 2/9/2011 17:59'! deleteAllHalos "self halt. self haloMorphs do: [:each | (each target isKindOf: SelectionMorph) ifTrue: [each target delete]]. self hands do: [:each | each removeHalo]"! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'AlainPlantec 10/17/2009 17:32'! nonWindows ^ (self submorphs select: [:m | (m isSystemWindow) not and: [m wantsToBeTopmost not]])! ! !PasteUpMorph methodsFor: 'private' stamp: 'nk 7/8/2003 09:18'! privateRemoveMorph: aMorph backgroundMorph == aMorph ifTrue: [ backgroundMorph := nil ]. ^super privateRemoveMorph: aMorph. ! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 16:18'! previousWindow "Answer the previous window to navigate to." |sys| sys := self systemWindows. sys ifEmpty: [^nil]. ^sys before: self currentWindow ifAbsent: [sys last]! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'ar 10/3/2000 22:46'! handlesMouseDown: evt ^true! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'AlainPlantec 1/9/2010 06:07'! collapseNonWindows self nonWindows reject: [:m | m isSticky] thenDo: [:m | m collapse]! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 7/6/1999 13:36'! toggleOriginAtCenter | hasIt | hasIt := self hasProperty: #originAtCenter. hasIt ifTrue: [self removeProperty: #originAtCenter] ifFalse: [self setProperty: #originAtCenter toValue: true]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'AlainPlantec 12/13/2009 08:12'! lastKeystroke: aString "Remember the last keystroke fielded by the receiver" ^ self setProperty: #lastKeystroke toValue: aString! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'ar 2/23/2001 16:44'! morphToGrab: event "Return the morph to grab from a mouse down event. If none, return nil." self submorphsDo:[:m| ((m rejectsEvent: event) not and:[m fullContainsPoint: event cursorPoint]) ifTrue:[^m]. ]. ^nil! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'StephaneDucasse 2/13/2010 11:38'! showImage: aForm "Show an image, possibly attached to the pointer for positioning" HandMorph attach: (World drawingClass withForm: aForm)! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 7/6/1999 13:26'! originAtCenter ^ self hasProperty: #originAtCenter! ! !PasteUpMorph methodsFor: 'taskbar' stamp: 'MarcusDenker 3/23/2011 15:29'! moveCollapsedWindowsToTaskbar "Move collapsed windows to the taskbar." (self systemWindows select: [:w | w isCollapsed]) do: [:w | w restore; minimize]! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'StephaneDucasse 7/2/2013 17:27'! handlesKeyboard: evt ^ evt keyCharacter == Character tab and: [ self tabAmongFields ]! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/12/2007 17:01'! modalUnlockFrom: aSystemWindow "Don't unlock the world!! Unlock the submorphs that were not originally locked." |lockStates| lockStates := self valueOfProperty: #submorphLockStates ifAbsent: [^self]. self removeProperty: #submorphLockStates. lockStates keysAndValuesDo: [:m :locked | locked ifFalse: [m unlock]]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'nice 1/5/2010 15:59'! initializeDesktopCommandKeySelectors "Provide the starting settings for desktop command key selectors. Answer the dictionary." "ActiveWorld initializeDesktopCommandKeySelectors" | dict | dict := IdentityDictionary new. self defaultDesktopCommandKeyTriplets do: [:trip | | messageSend | messageSend := MessageSend receiver: trip second selector: trip third. dict at: trip first put: messageSend]. self setProperty: #commandKeySelectors toValue: dict. ^ dict ! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 5/4/2013 12:55'! dropFiles: anEvent "Handle a number of dropped files from the OS. TODO: - use a more general mechanism for figuring out what to do with the file (perhaps even offering a choice from a menu) - remember the resource location or (when in browser) even the actual file handle" | numFiles stream handler | Smalltalk tools userManager canDropOSFile ifFalse: [ ^ self ]. numFiles := anEvent contents. 1 to: numFiles do: [:i | (stream := FileStream requestDropStream: i) ifNotNil: [ handler := ExternalDropHandler lookupExternalDropHandler: stream. [handler ifNotNil: [handler handle: stream in: self dropEvent: anEvent]] ensure: [stream close]]].! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'tbn 3/12/2010 01:47'! windowEventHandler "This is a class variable so it is global to all projects and does not get saved" ^WindowEventHandler! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:28'! gridOrigin ^ self gridSpec origin! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'GaryChambers 6/10/2011 12:02'! isWindowActive: aSystemWindow "Answer whether the given window is active. True if the current top window." ^self currentWindow == aSystemWindow! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'stephane.ducasse 5/21/2009 15:15'! positionNear: aPoint forExtent: anExtent adjustmentSuggestion: adjustmentPoint "Compute a plausible positioning for adding a subpart of size anExtent, somewhere near aPoint, using adjustmentPoint as the unit of adjustment" | adjustedPosition | adjustedPosition := aPoint. [((self morphsAt: (adjustedPosition + (anExtent // 2))) size > 1) and: "that 1 is self here" [bounds containsPoint: adjustedPosition]] whileTrue: [adjustedPosition := adjustedPosition + adjustmentPoint]. ^ adjustedPosition! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'StephaneDucasse 3/10/2011 15:32'! navigateVisibleWindowForward "Change the active window to the next visible and not collapsed window." self nextVisibleWindow ifNil: [SystemWindow passivateTopWindow] ifNotNil: [:m | m activate] ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'IgorStasenko 1/2/2012 19:04'! chooseClickTarget Cursor crossHair showWhile: [self activeHand waitButton]. Cursor down showWhile: [self activeHand anyButtonPressed]. ^ (self morphsAt: self activeHand cursorPoint) first! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:29'! gridOrigin: newOrigin ^ self gridSpecPut: (newOrigin extent: self gridModulus)! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'SeanDeNigris 1/23/2014 00:28'! openModal: aSystemWindow "Open the given window locking the receiver until it is dismissed. Set the pane color to match the current theme. Answer the system window." aSystemWindow setWindowColor: self theme windowColor. ^ super openModal: aSystemWindow! ! !PasteUpMorph methodsFor: 'taskbar' stamp: 'MarcusDenker 3/23/2011 15:30'! createTaskbarIfNecessary "Private - create a new taskbar if not present." self taskbars ifEmpty: [ TaskbarMorph new openInWorld: self. self moveCollapsedWindowsToTaskbar]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 13:56'! respondToCommand: aCharacter bySending: aSelector to: aReceiver "Respond to the command-key use of the given character by sending the given selector to the given receiver. If the selector is nil, retract any prior such setting" aSelector ifNil: [self commandKeySelectors removeKey: aCharacter] ifNotNil: [self commandKeySelectors at: aCharacter put: (MessageSend receiver: aReceiver selector: aSelector)]! ! !PasteUpMorph methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:39'! startStepping: aMorph "Add the given morph to the step list. Do nothing if it is already being stepped." ^self startStepping: aMorph at: Time millisecondClockValue selector: #stepAt: arguments: nil stepTime: nil! ! !PasteUpMorph methodsFor: 'thumbnail' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon ^ Smalltalk ui icons homeIcon! ! !PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: 'stephane.ducasse 9/25/2008 13:33'! expandAll "Expand all windows" (self windowsSatisfying: [:w | w isCollapsed]) reverseDo: [:w | w collapseOrExpand. self displayWorld]! ! !PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: 'janniklaval 3/8/2011 12:31'! fitAll "Fit all windows as visible" |allowedArea| allowedArea := RealEstateAgent maximumUsableAreaInWorld: World. (self windowsSatisfying: [:w | w isCollapsed not]) reverseDo:[:w | w extent: w initialExtent. w bounds:((w position extent: w initialExtent) translatedAndSquishedToBeWithin: allowedArea). ]. self displayWorld! ! !PasteUpMorph methodsFor: 'caching' stamp: 'StephaneDucasse 7/2/2013 17:33'! releaseCachedState super releaseCachedState. self removeModalWindow. ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 4/20/2002 01:38'! addWorldToggleItemsToHaloMenu: aMenu "Add toggle items for the world to the halo menu" #( (hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me') (roundedCornersString toggleCornerRounding 'whether the world should have rounded corners')) do: [:trip | aMenu addUpdating: trip first action: trip second. aMenu balloonTextForLastItem: trip third]! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:26'! gridSpec "Gridding rectangle provides origin and modulus" ^ self valueOfProperty: #gridSpec ifAbsent: [0@0 extent: 8@8]! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'CamilloBruni 2/16/2012 11:52'! modalLockTo: aSystemWindow "Don't lock the world nor the aSystemWindow!! Lock the submorphs." |lockStates| lockStates := IdentityDictionary new. "lock all submorphs" self submorphsDo: [:m | lockStates at: m put: m isLocked. m lock]. "don't lock the given window" aSystemWindow unlock. lockStates at: aSystemWindow put: aSystemWindow isLocked. self setProperty: #submorphLockStates toValue: lockStates! ! !PasteUpMorph methodsFor: 'Morphic-Base-Windows' stamp: 'alain.plantec 2/6/2009 17:17'! closeUnchangedWindows "Present a menu of window titles for all windows with changes, and activate the one that gets chosen." (self confirm: 'Do you really want to close all windows except those with unaccepted edits?' translated) ifFalse: [^ self]. (self windowsSatisfying: [:w | w model canDiscardEdits]) do: [:w | w delete]! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 16:18'! nextWindow "Answer the next window to navigate to." |sys| sys := self systemWindows. sys ifEmpty: [^nil]. ^sys after: self currentWindow ifAbsent: [sys first]! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'dgd 12/13/2003 19:30'! gridVisibleString "Answer a string to be used in a menu offering the opportunity to show or hide the grid" ^ (self gridVisible ifTrue: [''] ifFalse: ['']) , 'show grid when gridding' translated! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'ClementBera 10/3/2013 10:30'! becomeActiveDuring: aBlock "Make the receiver the ActiveWorld during the evaluation of aBlock. Note that this method does deliberately *not* use #ensure: to prevent re-installation of the world on project switches." | priorWorld priorHand priorEvent | priorWorld := ActiveWorld. priorHand := ActiveHand. priorEvent := ActiveEvent. ActiveWorld := self. ActiveHand := self hands first. "default" ActiveEvent := nil. "not in event cycle" aBlock on: Error do: [:ex | ActiveWorld := priorWorld. ActiveEvent := priorEvent. ActiveHand := priorHand. ex pass]! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'MarcusDenker 12/11/2009 07:42'! navigateWindowForward "Change the active window to the next window." self nextWindow ifNotNil: [:m | self currentWindow ifNotNil: [:w | w sendToBack]. m isCollapsed ifTrue: [m collapseOrExpand]. m activate]! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'AlainPlantec 12/10/2009 11:38'! wantsEasySelection "Answer if the receiver want easy selection mode" ^ self isEasySelecting ! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:29'! gridModulus ^ self gridSpec extent! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/12/2007 17:06'! handlerForMouseDown: anEvent "If we have a modal dialog then answer nil otherwise as usual.." ^(self hasProperty: #submorphLockStates) ifFalse: [super handlerForMouseDown: anEvent]! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'StephaneDucasse 7/2/2013 17:28'! wantsWindowEvent: anEvent ^ self windowEventHandler notNil! ! !PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'StephaneDucasse 2/19/2010 16:02'! wantsHaloFromClick (owner isSystemWindow) ifTrue: [^ false]. ^ true. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'MarcusDenker 9/13/2013 15:50'! addMorphs: aMorphOrList "Dump in submorphs, and stepList from aMorphOrList. Used to bring a world, paste-up, or other morph in from an object file." aMorphOrList isMorph ifTrue: [ aMorphOrList privateOwner: nil. aMorphOrList isWorldMorph ifFalse: [ self firstHand attachMorph: aMorphOrList. self startSteppingSubmorphsOf: aMorphOrList] ifTrue: [ self addMorph: aMorphOrList ]. aMorphOrList privateSubmorphs reverseDo: [:m | m privateOwner: nil. self addMorph: m. m changed]. (aMorphOrList instVarNamed: 'stepList') do: [:entry | entry first startSteppingIn: self]] ifFalse: ["list, add them all" aMorphOrList reverseDo: [:m | m privateOwner: nil. self addMorph: m. self startSteppingSubmorphsOf: m. "It may not want this!!" m changed]]! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color r: 0.861 g: 1.0 b: 0.722! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'MarcusDenker 9/29/2013 15:30'! findAChangeSorter: evt "Locate a change sorter, open it, and bring it to the front. Create one if necessary" | changeSorterClass | changeSorterClass := Smalltalk tools changeSorter. self findAWindowSatisfying: [:aWindow | aWindow model isKindOf: changeSorterClass] orMakeOneUsing: [changeSorterClass open]! ! !PasteUpMorph methodsFor: 'world state' stamp: 'alain.plantec 2/6/2009 11:39'! checkCurrentHandForObjectToPaste | response | self primaryHand pasteBuffer ifNil: [^self]. response := self confirm: ('Hand is holding a Morph in its paste buffer:' translated, '\') withCRs, self primaryHand pasteBuffer printString, ('\', 'Delete it ?' translated) withCRs. response = 1 ifTrue: [self primaryHand pasteBuffer: nil]. ! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:22'! repelsMorph: aMorph event: ev (aMorph wantsToBeDroppedInto: self) ifFalse: [^ false]. self dropEnabled ifFalse: [^ true]. (self wantsDroppedMorph: aMorph event: ev) ifFalse: [^ true]. ^ super repelsMorph: aMorph event: ev "consults #repelling flag"! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'MarcusDenker 12/11/2009 07:41'! navigateWindowBackward "Change the active window to the previous window." self previousWindow ifNotNil: [:m | m isCollapsed ifTrue: [m collapseOrExpand]. m activate]! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'StephaneDucasse 7/18/2010 16:37'! wantsKeyboardFocusFor: aSubmorph aSubmorph wouldAcceptKeyboardFocus ifTrue: [ ^ true]. ^ super wantsKeyboardFocusFor: aSubmorph! ! !PasteUpMorph methodsFor: 'Morphic-Base-Basic' stamp: 'adrian_lienhard 7/19/2009 20:50'! morphToDropFrom: aMorph "Given a morph being carried by the hand, which the hand is about to drop, answer the actual morph to be deposited. Normally this would be just the morph itself, but several unusual cases arise, which this method is designed to service." ^aMorph ! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:47'! gridModulus: newModulus self gridSpecPut: (self gridOrigin extent: newModulus). self changed! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'MarcusDenker 5/2/2013 11:35'! setGridSpec "Gridding rectangle provides origin and modulus" | response result | response := UIManager default request: 'New grid origin (usually 0@0):' translated initialAnswer: self gridOrigin printString. response isEmpty ifTrue: [^ self]. result := [self class compiler evaluate: response] ifError: [^ self]. (result isPoint and: [(result >= (0@0))]) ifTrue: [self gridOrigin: result] ifFalse: [self inform: ('Must be a Point with coordinates (for example 10@10)' translated )]. response := UIManager default request: 'New grid spacing:' translated initialAnswer: self gridModulus printString. response isEmptyOrNil ifTrue: [^ self]. result := [self class compiler evaluate: response] ifError: [^ self]. (result isPoint and: [(result > (0@0)) ]) ifTrue: [self gridModulus: result] ifFalse: [self inform: ('Must be a Point with coordinates (for example 10@10)' translated )]. ! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'tbn 3/12/2010 01:47'! windowEventHandler: anObject "This is a class variable so it is global to all projects and does not get saved" WindowEventHandler := anObject ! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 5/13/2011 09:16'! backgroundMorph: aMorph "Set the background morph. Probably best if locked prior to adding." self backgroundMorph isNil ifFalse: [ self backgroundMorph delete]. backgroundMorph := aMorph. aMorph isNil ifFalse: [ aMorph bounds: self bounds. self addMorphBack: aMorph]! ! !Path commentStamp: ''! I'm a private and abstract filesystem path, independent of the string representation used to describe paths on a specific filesystem. I provide methods for navigating the filesystem hierarchy and working with absolute and relative paths. I only refer to a concrete file or directory with regard to a specific filesystem. Normally users should not use me directly. Path independent representation of delimiter is defined by DiskFileSystem current delimiter. API instance creation: #* and #/ are mnemonic to . and / whose arguments should be string file- or directory names, not fragments of Unix path notation intended to be parsed. #/ and #* provide a mini-DSL for building up paths, while #readFrom:delimiter: parses path strings. Note that (Path with: 'parent/child/') isRelative returns true because it creates to a relative path to a file/directory called 'parent/child'. In bash you'd escape the slashes like this: parent\/child\/ similarly (Path with: '/parent/child/') isRelative returns true That's a relative path to '/parent/child'. In bash: /\parent\/child\/ (Path with: '') isRelative returns false Because this is an absolute path to the root of the file system. Absolute paths have an empty first element. If you consider $/ the separator, '/usr/local/bin' has an empty first element. ! !Path methodsFor: 'testing' stamp: 'cwp 2/26/2011 11:03'! isRoot self subclassResponsibility ! ! !Path methodsFor: 'navigating' stamp: 'cwp 3/29/2011 16:25'! resolve: anObject "Return a path in which the argument has been interpreted in the context of the receiver. Different argument types have different resolution semantics, so we use double dispatch to resolve them correctly." ^ anObject asResolvedBy: self! ! !Path methodsFor: 'comparing' stamp: 'CamilloBruni 9/5/2012 18:07'! isContainedBy: anObject "DoubleDispatch helper for #contains:" ^ anObject containsPath: self! ! !Path methodsFor: 'private' stamp: 'cwp 10/25/2009 19:53'! isAllParents 1 to: self size do: [:i | (self at: i) = '..' ifFalse: [^ false]]. ^ true! ! !Path methodsFor: 'comparing' stamp: 'cwp 10/25/2009 23:05'! containsReference: aReference ^ false! ! !Path methodsFor: 'testing' stamp: 'cwp 7/18/2009 00:42'! isWorkingDirectory ^ self size = 0! ! !Path methodsFor: 'navigating' stamp: 'cwp 3/29/2011 16:30'! resolveString: aString "Treat strings as relative paths with a single element." ^ self / aString! ! !Path methodsFor: 'navigating' stamp: 'cwp 10/25/2009 19:53'! parent | size parent | self isRoot ifTrue: [^ self]. self isAllParents ifTrue: [^ self / '..']. size := self size - 1. parent := self class new: size. 1 to: size do: [:i | parent at: i put: (self at: i)]. ^ parent! ! !Path methodsFor: 'printing' stamp: 'cwp 2/26/2011 17:58'! printOn: aStream delimiter: aCharacter (1 to: self size) do: [:index | aStream nextPutAll: (self at: index)] separatedBy: [aStream nextPut: aCharacter]! ! !Path methodsFor: 'accessing' stamp: 'SeanDeNigris 6/28/2012 00:09'! extension "Return the extension of path basename i.e., /foo/gloops.taz extension is 'taz'" ^ self basename copyAfterLast: self extensionDelimiter! ! !Path methodsFor: 'testing' stamp: 'DamienPollet 2/20/2011 04:00'! isEmpty ^ self size = 0! ! !Path methodsFor: 'accessing' stamp: 'sd 2/11/2011 21:02'! fullName "Return the fullName of the receiver." ^ self printString! ! !Path methodsFor: 'navigating' stamp: 'cwp 3/29/2011 16:23'! relativeToReference: aReference ^ self relativeToPath: aReference path! ! !Path methodsFor: 'navigating' stamp: 'cwp 11/15/2009 00:00'! relativeTo: anObject ^ anObject makeRelative: self! ! !Path methodsFor: '*Network-Url' stamp: 'SvenVanCaekenberghe 10/25/2013 17:03'! asUrl ^ self asZnUrl! ! !Path methodsFor: 'navigating' stamp: 'cwp 11/15/2009 00:00'! makeRelative: anObject ^ anObject relativeToPath: self! ! !Path methodsFor: 'navigating' stamp: 'cwp 11/17/2009 23:52'! , extension ^ self withName: self basename extension: extension! ! !Path methodsFor: 'private' stamp: 'cwp 12/13/2008 21:08'! copyFrom: aPath | size | size := aPath size min: self size. 1 to: size do: [:i | self at: i put: (aPath at: i)]. ! ! !Path methodsFor: 'testing' stamp: 'cwp 12/13/2008 21:00'! isRelative ^ self isAbsolute not! ! !Path methodsFor: 'navigating' stamp: 'CamilloBruni 1/19/2012 14:31'! resolvePath: aPath "Answers an absolute path created by resolving the argument against the receiver. If the argument is abolute answer the argument itself. Otherwise, concatenate the two paths, then process all parent references '..', and create a path with the remaining elements." | elements | aPath isAbsolute ifTrue: [^ aPath]. elements := Array new: self size + aPath size. 1 to: self size do: [:i | elements at: i put: (self at: i)]. 1 to: aPath size do: [:i | elements at: self size + i put: (aPath at: i)]. ^ self class withAll: (self class canonicalizeElements: elements)! ! !Path methodsFor: 'accessing' stamp: 'CamilloBruni 8/12/2011 20:16'! segments "return an array with all the path segements separated" | segments index | segments := Array new: self size. index := 1. self do: [ :part| segments at: index put: part. index := index + 1 ]. ^ segments! ! !Path methodsFor: 'accessing' stamp: 'StephaneDucasse 2/15/2010 18:06'! base "Returns the base of the basename, i.e. /foo/gloops.taz basename is 'gloops'" ^ self basename copyUpTo: self extensionDelimiter! ! !Path methodsFor: 'navigating' stamp: 'CamilloBruni 9/5/2012 11:26'! relativeToPath: aPath "Return the receiver as relative to the argument aPath" "(Path / 'griffle' / 'plonk' / 'nurp') relativeToPath: (Path / 'griffle') returns plonk/nurp" | prefix relative | aPath isRelative ifTrue: [^ aPath]. prefix := self lengthOfStemWith: aPath. relative := RelativePath parents: (aPath size - prefix). prefix + 1 to: self size do: [:i | relative := relative / (self at: i)]. ^ relative! ! !Path methodsFor: 'private' stamp: 'cwp 11/17/2009 23:58'! withName: name extension: extension | basename | basename :=String streamContents: [:out | out nextPutAll: name. out nextPut: self extensionDelimiter. out nextPutAll: extension]. ^ self copy at: self size put: basename; yourself! ! !Path methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 18:22'! basenameWithoutExtension "Returns the base of the basename but without its extension, i.e. /foo/gloops.taz basenameWithoutExtension is 'gloops' / basenameWithoutExtension is '/'" ^ self basename copyUpToLast: self extensionDelimiter! ! !Path methodsFor: 'accessing' stamp: 'CamilloBruni 8/9/2011 16:11'! basename "Returns the base of the basename, i.e. /foo/gloops.taz basename is 'gloops.taz' / basename is '/'" self size == 0 "the root node" ifTrue: [ ^ '/']. ^ self at: self size! ! !Path methodsFor: 'accessing' stamp: 'cwp 10/11/2009 11:05'! delimiter ^ $/! ! !Path methodsFor: 'navigating' stamp: 'CamilloBruni 8/15/2011 17:36'! / aString | path | aString isEmptyOrNil ifTrue: [ Error signal: 'Path element cannot be empty or nil']. path := self class new: self size + 1. path copyFrom: self. path at: path size put: aString. ^ path! ! !Path methodsFor: 'comparing' stamp: 'CamilloBruni 9/5/2012 18:05'! contains: anObject "Return true if anObject is in a subfolder of me" ^ anObject isContainedBy: self! ! !Path methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 17:41'! basename: newBasename "change the basename" self size == 0 "the root node" ifTrue: [ ^ Error signal: '0 length Path, cannot change basename']. self at: self size put: newBasename! ! !Path methodsFor: 'converting' stamp: 'cwp 10/10/2009 18:04'! asPathWith: anObject ^ self! ! !Path methodsFor: 'comparing' stamp: 'cwp 11/16/2009 09:06'! isChildOf: anObject ^ self parent = anObject! ! !Path methodsFor: 'printing' stamp: 'cwp 11/17/2009 10:22'! printOn: aStream self printOn: aStream delimiter: self delimiter. ! ! !Path methodsFor: 'comparing' stamp: 'cwp 10/25/2009 22:59'! containsPath: aPath self size < aPath size ifFalse: [^ false]. 1 to: self size do: [:i | (self at: i) = (aPath at: i) ifFalse: [^ false]]. ^ true! ! !Path methodsFor: 'printing' stamp: 'cwp 1/13/2009 21:27'! printWithDelimiter: aCharacter ^ String streamContents: [:out | self printOn: out delimiter: aCharacter]! ! !Path methodsFor: 'navigating' stamp: 'cwp 9/22/2009 09:06'! resolveReference: aReference ^ aReference! ! !Path methodsFor: 'comparing' stamp: 'cwp 12/14/2008 17:06'! hash | hash | hash := self class identityHash. 1 to: self size do: [:i | hash := String stringHash: (self at: i) initialHash: hash]. ^ hash! ! !Path methodsFor: 'navigating' stamp: 'cwp 11/17/2009 23:51'! withExtension: extension | basename name | basename := self basename. ^ (basename endsWith: extension) ifTrue: [ self ] ifFalse: [name := basename copyUpToLast: self extensionDelimiter. self withName: name extension: extension]! ! !Path methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 18:18'! extensions "Return the extensions of the receiver in order of appearance" "(Path from: '/foo/bar.tar.gz') extensions" ^ (self extensionDelimiter split: self basename) allButFirst! ! !Path methodsFor: 'enumerating' stamp: 'cwp 3/29/2011 16:42'! withParents | paths | paths := OrderedCollection new. 1 to: self size -1 do: [ :index | paths add: ((self class new: index) copyFrom: self) ]. paths add: self. ^ paths! ! !Path methodsFor: 'private' stamp: 'CamilloBruni 8/12/2011 16:42'! lengthOfStemWith: aPath | limit index | limit := self size min: aPath size. index := 1. [index <= limit and: [(self at: index) = (aPath at: index)]] whileTrue: [index := index + 1]. ^ index - 1! ! !Path methodsFor: 'testing' stamp: 'cwp 2/26/2011 10:58'! isAbsolute self subclassResponsibility ! ! !Path methodsFor: 'converting' stamp: 'EstebanLorenzano 4/12/2012 14:28'! asFileReference ^ FileSystem disk referenceTo: self! ! !Path methodsFor: 'navigating' stamp: 'cwp 9/22/2009 09:08'! asResolvedBy: anObject ^ anObject resolvePath: self! ! !Path methodsFor: 'comparing' stamp: 'cwp 12/14/2008 17:36'! = other ^ self species = other species and: [self size = other size and: [(1 to: self size) allSatisfy: [:i | (self at: i) = (other at: i)]]]! ! !Path methodsFor: 'enumerating' stamp: 'cwp 7/18/2009 01:13'! do: aBlock 1 to: self size do: [ :index || segment | segment := self at: index. segment isEmpty ifFalse: [ aBlock value: segment ] ]! ! !Path methodsFor: 'navigating' stamp: 'cwp 11/16/2009 10:19'! resolve ^ self! ! !Path methodsFor: 'accessing' stamp: 'cwp 12/23/2008 11:25'! extensionDelimiter ^ self class extensionDelimiter! ! !Path methodsFor: 'comparing' stamp: 'CamilloBruni 8/21/2013 17:51'! <= other ^ self fullName <= other fullName! ! !Path class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 4/2/2012 11:42'! root "Answer the root path - ie, / on unix" ^ AbsolutePath new! ! !Path class methodsFor: 'private' stamp: 'tbn 6/26/2012 21:02'! isAbsoluteUnixPath: aString ^aString first = $/ ! ! !Path class methodsFor: 'private' stamp: 'CamilloBruni 5/8/2012 17:47'! withAll: aCollection | inst | inst := self new: aCollection size. aCollection withIndexDo: [:segment :index | inst at: index put: segment]. ^ inst! ! !Path class methodsFor: 'private' stamp: 'BenComan 3/14/2014 23:29'! absoluteWindowsPathRegex "Return a copy of the regex since it is not thread-safe. Note: That the #copy only makes a shallow copy which is fast and but sufficient. Note: The slow part is parsing the regular expression, which only happens once here" "Case13065 Force re-initialization of variable during integration. Subsequently next line should be removed as step 2 of integration" absoluteWindowsPathRegex := '([a-zA-Z]\:)?\\.*' asRegex. ^ (absoluteWindowsPathRegex ifNil: [ absoluteWindowsPathRegex := '([a-zA-Z]\:)?\\.*' asRegex ]) copy! ! !Path class methodsFor: 'private' stamp: 'cwp 10/26/2009 13:41'! addEmptyElementTo: result result isEmpty ifTrue: [result add: ''] ! ! !Path class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/5/2012 11:25'! * aString "Answer a relative path with aString as its sole segment. For example, Path * 'griffle' will produce the same result as ./griffle in a unix shell. The selector #* was chosen for it's visual similarity to $." "Note: aString is not parsed, so supplying a string like '/griffle/plonk' will not create an absolute path." ^ RelativePath with: aString! ! !Path class methodsFor: 'encodings' stamp: 'StephaneDucasse 2/18/2011 22:31'! extensionDelimiter "Return the extension delimiter character." ^ $.! ! !Path class methodsFor: 'private' stamp: 'CamilloBruni 9/5/2012 11:28'! with: aString "Answer a relative path of the given string. N.B. that the argument is not parsed; it is the name of a single path element, and path separators in it do not have special meaning." "(Path with: '/parent/child/') isRelative answers true because this is a relative path to a file or directory named '/parent/child/'. In bash: \/parent\/child\/" | inst | inst := self new: 1. inst at: 1 put: aString. ^ inst! ! !Path class methodsFor: 'private' stamp: 'CamilloBruni 2/14/2014 14:46'! addParentElementTo: result (result isEmpty or: [ result last = '..' ]) ifTrue: [ result add: '..' ] ifFalse: [ result removeLast ] ! ! !Path class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/7/2012 02:19'! from: aString ^ self from: aString delimiter: $/! ! !Path class methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 10/11/2013 12:54'! cleanUp absoluteWindowsPathRegex := nil.! ! !Path class methodsFor: 'instance creation' stamp: 'CamilloBruni 2/14/2014 14:28'! from: aString delimiter: aDelimiterCharacter "Answer a path composed of several elements delimited by aCharacter" | pathClass | aString isEmpty ifTrue: [ ^ self root ]. pathClass := ((self isAbsoluteUnixPath: aString) or: [self isAbsoluteWindowsPath: aString]) ifTrue: [ AbsolutePath ] ifFalse:[ RelativePath ]. ^ pathClass withAll: (pathClass canonicalizeElements: (aDelimiterCharacter split: aString))! ! !Path class methodsFor: 'instance creation' stamp: 'cwp 11/15/2009 00:11'! parents: anInteger | path | path := self new: anInteger. 1 to: anInteger do: [:i | path at: i put: '..']. ^ path! ! !Path class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 4/2/2012 11:43'! workingDirectory "Answer a path that will always resolve to the current working directory." ^ RelativePath new! ! !Path class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 4/2/2012 11:43'! parent "Answer a path that resolves to the parent of the current working directory. This is similar to .. in unix, but doesn't rely on actual hardlinks being present in the filesystem." ^ RelativePath with: '..'! ! !Path class methodsFor: 'private' stamp: 'CamilloBruni 2/14/2014 14:44'! addElement: element to: result element = '..' ifTrue: [ ^ self addParentElementTo: result ]. element = '' ifTrue: [ ^ self addEmptyElementTo: result ]. element = '.' ifFalse: [ result add: element ]! ! !Path class methodsFor: 'private' stamp: 'CamilloBruni 2/14/2014 14:28'! canonicalizeElements: aCollection | result | result := OrderedCollection new. aCollection do: [ :element | self addElement: element to: result]. ^ result! ! !Path class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/5/2012 11:25'! / aString "Answer an absolute path with aString as it's sole segment. The selector was chosen to allow path construction with Smalltalk syntax, which neverthelesss resembles paths as they appear in a unix shell. Eg. Path / 'griffle' / 'plonk'." aString isEmptyOrNil ifTrue: [ Error signal: 'Path element cannot be empty or nil']. ^ AbsolutePath with: aString! ! !Path class methodsFor: 'private' stamp: 'CamilloBruni 5/30/2013 22:43'! isAbsoluteWindowsPath: aString ^ self absoluteWindowsPathRegex matches: aString! ! !PathShape commentStamp: 'LaurentLaffont 3/31/2011 21:05'! I represent a model of an open sequence of connected points that can be queried for enclosing bounds and whether a point lies along any segment. I am typically used for drawing with a Canvas. ps := PathShape new addVertex: 0@0; addVertex: 30@30; addVertex: 50@10. self assert: (ps containsPoint: 24@24). self assert: (ps containsPoint: 40@30) not. Transcript show: ps calculatedBounds asString; cr.! !PathShape methodsFor: 'accessing' stamp: 'gvc 10/31/2006 10:36'! basicBounds "Answer the bounds of the receiver without lazy calculation." ^bounds! ! !PathShape methodsFor: 'initialization' stamp: 'gvc 10/31/2006 10:35'! initialize "Initialize the receiver." super initialize. self vertices: OrderedCollection new! ! !PathShape methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 10:40'! addVertex: aPoint "Add a vertex to the path." self vertices add: aPoint. self basicBounds ifNotNil: [ self bounds: (self bounds quickMergePoint: aPoint)] ! ! !PathShape methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:40'! bounds "Answer the bounds of the receiver." ^bounds ifNil: [bounds := self calculatedBounds]! ! !PathShape methodsFor: 'accessing' stamp: 'gvc 10/31/2006 10:25'! bounds: anObject "Set the value of bounds" bounds := anObject! ! !PathShape methodsFor: 'accessing' stamp: 'gvc 10/31/2006 10:24'! vertices "Answer the value of vertices" ^ vertices! ! !PathShape methodsFor: 'accessing' stamp: 'gvc 10/31/2006 11:08'! vertices: aCollection "Set the value of vertices." vertices := aCollection asOrderedCollection. self bounds: nil! ! !PathShape methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 10:47'! segmentsDo: aBlock "Evaluate the two-argument block with each vertex and its successor." self vertices size < 2 ifTrue: [^self]. 1 to: self vertices size - 1 do: [:i | aBlock value: (self vertices at: i) value: (self vertices at: i + 1)]! ! !PathShape methodsFor: 'as yet unclassified' stamp: 'gvc 6/25/2007 13:52'! calculatedBounds "Answer the bounds of the receiver calculated from the receiver's vertices." |tl br| self vertices ifEmpty: [^nil]. tl := br := self vertices first. self vertices allButFirstDo: [:v | tl := tl min: v. br := br max: v]. ^tl corner: br + 1! ! !PathShape methodsFor: 'as yet unclassified' stamp: 'gvc 6/25/2007 14:03'! containsPoint: aPoint "Answer whether the receiver contains the given point." (self basicContainsPoint: aPoint) ifFalse: [^false]. self segmentsDo: [:p1 :p2 | (aPoint onLineFrom: p1 to: p2 within: 0) ifTrue: [^true]]. ^false! ! !PathShape class methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 11:08'! vertices: aCollection "Answer a new instance of the receiver with the given vertices." ^self new vertices: aCollection! ! !PathTest commentStamp: 'TorstenBergmann 1/31/2014 11:44'! SUnit tests for file system paths! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:33'! testParseTrailingSlash | path | path := Path from: 'griffle/' delimiter: $/. self assert: path size equals: 1. self assert: (path at: 1) equals: 'griffle'! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:39'! testRelativeFromString | path | path := Path from: 'plonk/griffle'. self assert: path isRelative. self assert: path size equals: 2. self assert: (path at: 1) equals: 'plonk'. self assert: (path at: 2) equals: 'griffle'.! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testIsRelative self assert: (Path * 'plonk') isRelative! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testIsNotAbsolute self deny: (Path * 'plonk') isAbsolute! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:33'! testRelativePrintString | path actual | path := Path * 'plonk' / 'griffle'. actual := path printString. self assert: actual equals: 'Path * ''plonk'' / ''griffle'''! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testSiblingOfPath | griffle nurb | griffle := Path / 'griffle'. nurb := Path / 'nurb'. self deny: (griffle isChildOf: nurb). self deny: (nurb isChildOf: griffle).! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:41'! testRelativeFromStringNormalization | path | path := Path from: 'plonk/../griffle'. self assert: path isRelative. self assert: path size equals: 1. self assert: (path at: 1) equals: 'griffle'.! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:32'! testParseBogus "self run: #testParseBogus" | path | path := Path from: 'parent?<>~ \child/grandChild' delimiter: $/. self assert: path size equals: 2. self assert: (path at: 1) equals: 'parent?<>~ \child'. self assert: (path at: 2) equals: 'grandChild'. ! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRootParent | root | root := Path root. self assert: root parent == root! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:32'! testExtensions self assertCollection: (Path from: 'foo') extensions asArray equals: #(). self assertCollection: (Path from: 'foo.tar') extensions asArray equals: #( 'tar' ). self assertCollection: (Path from: 'foo.tar.gz') extensions asArray equals: #( 'tar' 'gz'). self assertCollection: (Path from: 'foo.1.tar.gz') extensions asArray equals: #( '1' 'tar' 'gz').! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testContainsLocator | ancestor descendent | ancestor := FileLocator imageDirectory resolve path. descendent := FileLocator image / 'griffle'. self deny: (ancestor contains: descendent). self deny: (descendent contains: ancestor)! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:32'! testParentResolution | base relative absolute | base := Path / 'plonk' / 'pinto'. relative := Path parent / 'griffle' / 'zonk'. absolute := base resolve: relative. self assert: absolute isAbsolute. self assert: (absolute at: 1) equals: 'plonk'. self assert: (absolute at: 2) equals: 'griffle'. self assert: (absolute at: 3) equals: 'zonk'. ! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:33'! testRelativeWithParents | path allPaths | path := Path * 'plonk' / 'griffle' / 'nurb'. allPaths := path withParents. self assert: allPaths size equals: 3. self assert: allPaths first basename equals: 'plonk'. self assert: allPaths first size equals: 1. self assert: allPaths second basename equals: 'griffle'. self assert: allPaths second size equals: 2. self assert: (allPaths second isChildOf: allPaths first). self assert: allPaths third basename equals: 'nurb'. self assert: allPaths third size equals: 3. self assert: (allPaths third isChildOf: allPaths second). self assert: allPaths third == path! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:35'! testSimpleResolution | base relative absolute | base := Path / 'plonk'. relative := (Path * 'griffle') / 'zonk'. absolute := base resolve: relative. self assert: absolute isAbsolute. self assert: (absolute at: 1) equals: 'plonk'. self assert: (absolute at: 2) equals: 'griffle'. self assert: (absolute at: 3) equals: 'zonk'. ! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:30'! testCommaAddsExtension | path result | path := Path * 'plonk' . result := path, 'griffle'. self assert: result basename equals: 'plonk.griffle'! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:35'! testResolveString "self debug: #testResolveString" | path result | path := Path * 'plonk'. result := path resolve: 'griffle'. self assert: result class equals: path class. self assert: result size equals: 2. self assert: (result at: 1) equals: 'plonk'. self assert: (result at: 2) equals: 'griffle'.! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:33'! testParseWindowsPathWithUnixDelimiters "self run: #testParse" | path | path := WindowsStore new pathFromString: 'C:\a/b/c'. self assert: path segments size equals: 4. self assertCollection: path segments equals: #('C:' 'a' 'b' 'c') ! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:30'! testBasenameWithoutExtension "self debug: #testBasenameWithoutExtension" | path | path := Path * 'plonk' / 'griffle'. self assert: path basenameWithoutExtension equals: 'griffle'. path := Path * 'plonk' / 'griffle.taz'. self assert: path basenameWithoutExtension equals: 'griffle'. path := Path * 'plonk' / 'griffle.taz.zork'. self assert: path basenameWithoutExtension equals: 'griffle.taz'.! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testResolveAbsolute | path | path := Path / 'griffle'. self assert: path resolve == path. self assert: path isAbsolute! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:35'! testWorkingDirPrintString | path actual | path := Path workingDirectory. actual := path printString. self assert: actual equals: 'Path workingDirectory'! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:35'! testSlash | path actual | path := Path * 'plonk'. actual := path / 'griffle'. self assert: actual class equals: path class. self assert: (actual printWithDelimiter: $/) equals: 'plonk/griffle'! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:33'! testPrintRelativeWithParent | path | path := Path parent / 'foo'. self assert: (path printWithDelimiter: $/) equals: '../foo'! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:43'! testIsChildOfReference | parent child | parent := Path / 'griffle'. child := (FileSystem memory referenceTo: parent / 'nurb'). self deny: (child isChildOf: parent). self deny: (parent isChildOf: child)! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testUnequalContent | a b | a := Path * 'plonk'. b := Path * 'griffle'. self deny: a = b.! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:32'! testParentParent | path | path := (Path * '..') parent. self assert: path size equals: 2. self assert: (path at: 1) equals: '..'. self assert: (path at: 2) equals: '..'.! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:35'! testRootPrintString | path actual | path := Path root. actual := path printString. self assert: actual equals: 'Path root'! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testGrandchildOfPath | griffle nurb | griffle := Path / 'griffle'. nurb := griffle / 'plonk' / 'nurb'. self deny: (griffle isChildOf: nurb). self deny: (nurb isChildOf: griffle).! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testIsNotRoot self deny: (Path / 'plonk') isRoot! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:35'! testWithExtentionReplacesExtension | path result | path := Path * 'plonk.griffle'. result := path withExtension: 'griffle'. self assert: result basename equals: 'plonk.griffle'! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:32'! testParent | path parent | path := (Path * 'plonk') / 'griffle'. parent := path parent. self assert: parent isRelative. self assert: (parent at: 1) equals: 'plonk'! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:30'! testAbsolutePrintString | path actual | path := Path / 'plonk' / 'griffle'. actual := path printString. self assert: actual equals: 'Path / ''plonk'' / ''griffle'''! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:41'! testRelativeFromStringNormalizationParent | path | path := Path from: 'plonk/../../griffle'. self assert: path isRelative. self assert: path size equals: 2. self assert: (path at: 1) equals: '..'. self assert: (path at: 2) equals: 'griffle'.! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:32'! testParse "self run: #testParse" | path | path := Path from: 'parent/child/grandChild' delimiter: $/. self assert: path size equals: 3. self assert: (path at: 1) equals: 'parent'. self assert: (path at: 2) equals: 'child'. self assert: (path at: 3) equals: 'grandChild'. ! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:31'! testEqual | a b | a := Path * 'plonk'. b := Path * 'plonk'. self deny: a == b. self assert: a equals: b.! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testIsEmpty self assert: (Path workingDirectory) isEmpty! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:33'! testRelativeToBranch | parent child relative | parent := Path / 'griffle' / 'bibb'. child := Path / 'griffle' / 'plonk' / 'nurp'. relative := child relativeTo: parent. self assert: relative equals: (Path parent / 'plonk' / 'nurp')! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:35'! testWorkingDirectoryParent | path | path := Path workingDirectory parent. self assert: path size equals: 1. self assert: (path at: 1) equals: '..'! ! !PathTest methodsFor: 'tests' stamp: 'tbn 6/26/2012 21:07'! testUnixAbsolutePathName self assert: (Path from: '/test') isAbsolute. self assert: (Path from: '/etc/bin') isAbsolute.! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testIsNotRelative self deny: (Path / 'plonk') isRelative! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:30'! testAbsoluteWithParents | path allPaths | path := Path / 'plonk' / 'griffle' / 'nurb'. allPaths := path withParents. self assert: allPaths size equals: 4. self assert: allPaths first isRoot. self assert: allPaths second basename equals: 'plonk'. self assert: allPaths second size equals: 1. self assert: (allPaths second isChildOf: allPaths first). self assert: allPaths third basename equals: 'griffle'. self assert: allPaths third size equals: 2. self assert: (allPaths third isChildOf: allPaths second). self assert: allPaths fourth basename equals: 'nurb'. self assert: allPaths fourth size equals: 3. self assert: (allPaths fourth isChildOf: allPaths third). self assert: allPaths fourth equals: path. self assert: allPaths fourth == path! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:33'! testRelativeTo "self run: #testRelativeTo" "aPath relativeTo: aParent returns a new path relative to the parent" | parent child relative | parent := Path / 'griffle'. child := Path / 'griffle' / 'plonk' / 'nurp'. relative := child relativeTo: parent. self assert: relative equals: (Path * 'plonk' / 'nurp')! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testIsRoot self assert: Path root isRoot! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testIsChildOfPath | parent child | parent := Path / 'griffle'. child := parent / 'nurb'. self assert: (child isChildOf: parent). self deny: (parent isChildOf: child)! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testResolveRelative | path | path := Path * 'griffle'. self assert: path resolve == path. self assert: path isRelative! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testIsAbsolute self assert: (Path / 'plonk') isAbsolute! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:41'! testRelativeFromStringParent | path | path := Path from: '../..'. self assert: path isRelative. self assert: path size equals: 2. self assert: (path at: 1) equals: '..'. self assert: (path at: 2) equals: '..'.! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:32'! testMakeRelative "self run: #testMakeRelative" | parent child relative | parent := Path / 'griffle' / 'bibb'. child := Path / 'griffle' / 'plonk' / 'nurp'. relative := parent makeRelative: child. self assert: relative equals: (Path parent / 'plonk' / 'nurp')! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:30'! testCommaAddsExtensionAgain | path result | path := Path * 'plonk.griffle'. result := path, 'nurp'. self assert: result basename equals: 'plonk.griffle.nurp'! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testContains | ancestor descendent | ancestor := Path / 'plonk'. descendent := Path / 'plonk' / 'griffle' / 'bork'. self assert: (ancestor contains: descendent). self deny: (descendent contains: ancestor)! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:30'! testBasename | path | path := Path * 'plonk' / 'griffle'. self assert: path basename equals: 'griffle'! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:33'! testPrintWithDelimiter | path | path := (Path * 'plonk') / 'griffle'. self assert: (path printWithDelimiter: $%) equals: 'plonk%griffle'! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:35'! testWithExtentionAddsExtension | path result | path := Path * 'plonk'. result := path withExtension: 'griffle'. self assert: result basename equals: 'plonk.griffle'! ! !PathTest methodsFor: 'tests' stamp: 'tbn 6/26/2012 21:05'! testWindowsAbsolutePathName self assert: (Path from: 'A:\') isAbsolute. self assert: (Path from: 'c:\') isAbsolute. self assert: (Path from: 'c:\test') isAbsolute.! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:29'! testAbsolutePath | path | self assert: (AbsolutePath new isAbsolute). self assert: (Path root isAbsolute). path := AbsolutePath from: 'parent/child/grandChild' delimiter: $/. self assert: path size equals: 3. self assert: (path at: 1) equals: 'parent'. self assert: (path at: 2) equals: 'child'. self assert: (path at: 3) equals: 'grandChild'. path := AbsolutePath from: '/' delimiter: $/. self assert: path equals: Path root. ! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:30'! testAsReference | path reference | path := Path * 'plonk'. reference := path asFileReference. self assert: reference class equals: FileReference. self assert: reference path equals: path! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testUnequalSize | a b | a := Path * 'plonk'. b := (Path * 'plonk') / 'griffle'. self deny: a = b.! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 2/14/2014 14:35'! testResolvePath "self debug: #testResolvePath" | path | path := Path / 'grandfather' / 'father' / 'child'. self assert: (path resolvePath: Path / 'grandfather') equals: (Path / 'grandfather'). self assert: (path resolvePath: Path / 'child') equals: (Path / 'child'). self assert: (path resolvePath: Path * 'grandfather') equals: (Path / 'grandfather' / 'father' / 'child' / 'grandfather'). self assert: (path resolvePath: Path * 'child') equals: (Path / 'grandfather' / 'father' / 'child' / 'child'). self assert: (path resolvePath: Path * 'grandfather') equals: (Path / 'grandfather' / 'father' / 'child' / 'grandfather'). self assert: (path resolvePath: Path * 'child') equals: (Path / 'grandfather' / 'father' / 'child' / 'child'). self assert: (path resolvePath: (Path parent) / '..') equals: (Path / 'grandfather')! ! !PeelToFirstDebugAction commentStamp: ''! A PeelToFirstDebugAction peels the stack back to the second occurance of the currently selected message. ! !PeelToFirstDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/21/2013 22:00'! id ^ #peelToFirst! ! !PeelToFirstDebugAction methodsFor: 'actions' stamp: 'AndreiChis 9/21/2013 22:08'! executeAction self session peelToFirstLike: self currentContext ! ! !PeelToFirstDebugAction methodsFor: 'testing' stamp: 'AndreiChis 9/21/2013 22:06'! appliesToDebugger: aDebugger ^ aDebugger session isInterruptedContextPostMortem not! ! !PeelToFirstDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/21/2013 22:01'! defaultLabel ^ 'Peel to first like this'! ! !PeelToFirstDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/21/2013 22:01'! defaultOrder ^ 45! ! !PeelToFirstDebugAction class methodsFor: 'registration' stamp: 'AndreiChis 9/21/2013 22:13'! actionType ! ! !PerformTest commentStamp: 'HenrikSperreJohansen 5/19/2010 02:33'! I test a primitive failure with perform:withArguments: which was raised when selectors with many arguments was called from methods with small stack sizes.! !PerformTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPerformWithArgsLargeFrame self doPerformOldLargeFrame! ! !PerformTest methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testPerformWithArgsSmallFrame self doPerformOldSmallFrame! ! !PerformTest methodsFor: 'helper methods' stamp: 'HenrikSperreJohansen 5/19/2010 02:28'! doPerformOldSmallFrame "The perform primitive reuses the current stack frame. When this was small, it would cause the perform primitive to fail, when the amount of arguments were too high" ^self perform: #a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: withArguments: (Array new: 15). ! ! !PerformTest methodsFor: 'helper methods' stamp: 'Igor.Stasenko 5/19/2010 00:21'! a1: a1 a2: a2 a3: a3 a4: a4 a5: a5 a6: a6 a7: a7 a8:a8 a9: a9 a10: a10 a11: a11 a12: a12 a13: a13 a14: a14 a15: a15 ^ true! ! !PerformTest methodsFor: 'helper methods' stamp: 'MarcusDenker 6/17/2012 15:06'! doPerformOldLargeFrame | t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 | "The perform primitive reuses the current stack frame. When this was big,the following perform would succeed, since the stack frame was large enough to fit all the arguments" t1 := t2 := t3 := t4 := t5 := t6 := t7 := t8 := t9 := t10 := t11 := t12 := t13 := 1. self perform: #a1:a2:a3:a4:a5:a6:a7:a8:a9:a10:a11:a12:a13:a14:a15: withArguments: (Array new: 15). ^ t1! ! !PermissionsEditor commentStamp: ''! A PermissionsEditor is a GUI for editing a user permissions! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! isRoot ^ isRoot! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canRunStartupScript ^ canRunStartupScript! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:05'! setCanDropOSFile canDropOSFile state: false; enabled: false; whenChangedDo: [ self checkRoot ]; label: 'Can drop files into the image from the OS ?'! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 14:06'! setIsRoot isRoot state: false; enabled: false; label: 'Is this user root ?'! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canInspect ^ canInspect! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canEditUser ^ canEditUser! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:05'! setCanInspect canInspect state: false; enabled: false; whenChangedDo: [ self checkRoot ]; label: 'Can inspect object ?'! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:05'! setCanRunStartupScript canRunStartupScript state: false; enabled: false; whenChangedDo: [ self checkRoot ]; label: 'Can run script from the OS ?'! ! !PermissionsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! user ^ user value! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:04'! setCanBrowse canBrowse state: false; enabled: false; whenChangedDo: [ self checkRoot ]; label: 'Can browse code ?'.! ! !PermissionsEditor methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2014 16:07'! initialize lock := false. user := nil asValueHolder. super initialize.! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 14:06'! initializeCheckBoxes self setCanBrowse. self setCanDebug. self setCanDropOSFile. self setCanEditCode. self setCanEditUser. self setCanEvaluateCode. self setCanInspect. self setCanRunStartupScript. self setCanShowMorphHalo. self setIsRoot! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/2/2012 16:23'! initializePresenter self registerIsRootEvents. self registerUserEvent.! ! !PermissionsEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! title ^ user value ifNil: 'Permissions editor' ifNotNil: [:usr | 'Editing ', usr username, '''s permissions' ]! ! !PermissionsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! user: anUser ^ user value: anUser! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:05'! setCanEditUser canEditUser state: false; enabled: false; whenChangedDo: [ self checkRoot ]; label: 'Can user permissions ?'! ! !PermissionsEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/21/2012 15:56'! initialExtent ^ (360@300)! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canBrowse ^ canBrowse! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canEditCode ^ canEditCode! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canDropOSFile ^ canDropOSFile! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'EstebanLorenzano 12/6/2012 18:46'! registerUserEvent user whenChangedDo: [ :usr | self updateTitle. canBrowse enabled: usr notNil. canDebug enabled: usr notNil. canDropOSFile enabled: usr notNil. canEditCode enabled: usr notNil. canEditUser enabled: usr notNil. canEvaluateCode enabled: usr notNil. canInspect enabled: usr notNil. canRunStartupScript enabled: usr notNil. canShowMorphHalo enabled: usr notNil. usr ifNotNil: [ canBrowse state: usr canBrowse. canDebug state: usr canDebug. canDropOSFile state: usr canDropOSFile. canEditCode state: usr canEditCode. canEditUser state: usr canEditUser. canEvaluateCode state: usr canEvaluateCode. canInspect state: usr canInspect. canRunStartupScript state: usr canRunStartupScript. canShowMorphHalo state: usr canShowMorphHalo. self checkRoot. ]]! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canEvaluateCode ^ canEvaluateCode! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/2/2012 16:36'! initializeWidgets isRoot := self instantiate: CheckBoxModel. canBrowse := self instantiate: CheckBoxModel. canDebug := self instantiate: CheckBoxModel. canDropOSFile := self instantiate: CheckBoxModel. canEditCode := self instantiate: CheckBoxModel. canEditUser := self instantiate: CheckBoxModel. canEvaluateCode := self instantiate: CheckBoxModel. canInspect := self instantiate: CheckBoxModel. canRunStartupScript := self instantiate: CheckBoxModel. canShowMorphHalo := self instantiate: CheckBoxModel. self initializeCheckBoxes. ! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! initializeDialogWindow: aWindow aWindow okAction: [ user value ifNotNil: [ :usr | usr canBrowse: canBrowse state. usr canDebug: canDebug state. usr canDropOSFile: canDropOSFile state. usr canEditCode: canEditCode state. usr canEditUser: canEditUser state. usr canEvaluateCode: canEvaluateCode state. usr canInspect: canInspect state. usr canRunStartupScript: canRunStartupScript state. usr canShowMorphHalo: canShowMorphHalo state ] ]! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:05'! setCanShowMorphHalo canShowMorphHalo state: false; enabled: false; whenChangedDo: [ self checkRoot ]; label: 'Can show halo of morphs ?'! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:05'! setCanEvaluateCode canEvaluateCode state: false; enabled: false; whenChangedDo: [ self checkRoot ]; label: 'Can evaluate code ?'! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:25'! checkRoot | bool | bool := ( (canBrowse state and: [ canDebug state and: [ canDropOSFile state and: [ canEditCode state and: [ canEditUser state and: [ canEvaluateCode state and: [ canInspect state and: [ canRunStartupScript state and: [ canShowMorphHalo state ]]]]]]]]) = true ) . lock := true. isRoot state: bool. lock := false! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:05'! setCanDebug canDebug state: false; enabled: false; whenChangedDo: [ self checkRoot ]; label: 'Can debug code ?'! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:17'! registerIsRootEvents isRoot whenChangedDo: [ :bool | lock ifFalse: [ canBrowse state: bool. canDebug state: bool. canDropOSFile state: bool. canEditCode state: bool. canEditUser state: bool. canEvaluateCode state: bool. canInspect state: bool. canRunStartupScript state: bool. canShowMorphHalo state: bool ]]! ! !PermissionsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:05'! setCanEditCode canEditCode state: false; enabled: false; whenChangedDo: [ self checkRoot ]; label: 'Can edit code ?'! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canShowMorphHalo ^ canShowMorphHalo! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canDebug ^ canDebug! ! !PermissionsEditor class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 9/27/2013 10:48'! internSpec ^{#ContainerModel. #add:. {{#model. #isRoot }. #layout:. #(FrameLayout bottomFraction: 0 bottomOffset: 25) }. #add:. {{#model. #canBrowse }. #layout:. #(FrameLayout bottomFraction: 0 topOffset: 25 bottomOffset: 50) }. #add:. {{#model. #canDebug }. #layout:. #(FrameLayout bottomFraction: 0 topOffset: 50 bottomOffset: 75) }. #add:. {{#model. #canDropOSFile }. #layout:. #(FrameLayout bottomFraction: 0 topOffset: 75 bottomOffset: 100)}. #add:. {{#model. #canEditCode }. #layout:. #(FrameLayout bottomFraction: 0 topOffset: 100 bottomOffset: 125)}. #add:. {{#model. #canEditUser }. #layout:. #(FrameLayout bottomFraction: 0 topOffset: 125 bottomOffset: 150)}. #add:. {{#model. #canEvaluateCode }. #layout:. #(FrameLayout bottomFraction: 0 topOffset: 150 bottomOffset: 175)}. #add:. {{#model. #canRunStartupScript }. #layout:. #(FrameLayout bottomFraction: 0 topOffset: 175 bottomOffset: 200)}. #add:. {{#model. #canShowMorphHalo }. #layout:. #(FrameLayout bottomFraction: 0 topOffset: 200 bottomOffset: 225)}}! ! !PersonDataExample commentStamp: 'TorstenBergmann 2/3/2014 23:52'! Data object for a grid example! !PersonDataExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 11:51'! married: anObject "Set the value of married" married := anObject! ! !PersonDataExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 11:51'! firstName "Answer the value of firstName" ^ firstName! ! !PersonDataExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 11:51'! firstName: anObject "Set the value of firstName" firstName := anObject! ! !PersonDataExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 11:51'! secondName "Answer the value of secondName" ^ secondName! ! !PersonDataExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 11:51'! age: anObject "Set the value of age" age := anObject! ! !PersonDataExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 11:51'! married "Answer the value of married" ^ married! ! !PersonDataExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 11:51'! secondName: anObject "Set the value of secondName" secondName := anObject! ! !PersonDataExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 11:51'! age "Answer the value of age" ^ age! ! !PersonDataExample class methodsFor: 'instance creation' stamp: 'AlainPlantec 2/1/2010 11:53'! firstName: fname secondName: sname age: age married: married ^ (self new) firstName: fname; secondName: sname; age: age; married: married; yourself! ! !Pharo3TabPanelBorder commentStamp: ''! Specialized border for TabGroup. Does not draw border beneath the selectd tab and only draws on top.! !Pharo3TabPanelBorder methodsFor: 'drawing' stamp: 'tg 9/10/2010 07:42'! frameRectangle: aRectangle on: aCanvas "Draw the border taking the currently selected tab into account. Only works for top-positioned tabs for the moment." |w h r tab| w := self width. w isPoint ifTrue: [h := w y. w := w x] ifFalse:[h := w]. tab := self selectedTab. tab ifNil: [ r := aRectangle topLeft + (w@0) corner: aRectangle topRight - (w@h negated). aCanvas fillRectangle: r color: self color. ^self]. "top" r := aRectangle topLeft + (w@0) corner: tab bounds left + w@(aRectangle top + h). aCanvas fillRectangle: r color: self color. "top 1" r := tab bounds left + w@ aRectangle top corner: tab bounds right - w@(aRectangle top + h). aCanvas fillRectangle: r color: tab paneColor. "top 2" r := tab bounds right - w@ aRectangle top corner: aRectangle topRight - (w@h negated). aCanvas fillRectangle: r color: self color. "top 3"! ! !Pharo3Theme commentStamp: ''! The theme is developed in the context of the Glamour project, and its goal is to create a look that: - does not look like a specific operating system. In particular, the icons should be operating system agnostic, because, for example, people in Windows are confused by the red, yellow, green buttons of apple. - uses a limited amount of colors and effects. - is fast. self defaultSettings: nil. self beCurrent. Is adopted as the theme for Pharo3, but it was renamed to avoid collisions with the glamour team,! !Pharo3Theme methodsFor: 'growl - specific' stamp: 'TudorGirba 4/18/2012 09:12'! growlLabelColorFor: aGrowlMorph ^ Color white twiceDarker! ! !Pharo3Theme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 14:18'! newWindowCloseOverForm "Answer a new form for a window menu box." ^ self newWindowCloseForm! ! !Pharo3Theme methodsFor: 'border-styles' stamp: 'tg 9/4/2010 20:56'! taskbarThumbnailNormalBorderStyleFor: aWindow ^ self buttonNormalBorderStyleFor: aWindow! ! !Pharo3Theme methodsFor: 'border-styles-scrollbars' stamp: 'TudorGirba 4/8/2011 00:01'! scrollbarNormalThumbBorderStyleFor: aScrollbar "Return the normal thumb borderStyle for the given scrollbar." ^ BorderStyle simple width: 0; baseColor: Color transparent! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'TudorGirba 5/23/2012 15:32'! taskbarFillStyleFor: aTaskbar ^ "self buttonNormalFillStyleFor: aTaskbar" SolidFillStyle color: Color transparent ! ! !Pharo3Theme methodsFor: 'border-styles' stamp: 'TudorGirba 5/23/2012 14:24'! configureWindowDropShadowFor: aWindow aWindow hasDropShadow: false! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! windowMaximizePassiveForm "Answer the form to use for passive (background) window maximize/restore buttons" ^Pharo3UIThemeIcons windowMaximizeInactiveForm! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'TudorGirba 5/31/2012 22:51'! windowInactiveTitleFillStyleFor: aWindow "We do not want the lighting effect when the window goes inactive" ^ SolidFillStyle color: Color transparent! ! !Pharo3Theme methodsFor: 'initialize-release' stamp: 'TudorGirba 5/23/2012 14:22'! initialize "self beCurrent" super initialize. self windowActiveDropShadowStyle: #diffuse! ! !Pharo3Theme methodsFor: 'fill-styles-scrollbars' stamp: 'tg 9/4/2010 21:03'! scrollbarNormalFillStyleFor: aScrollbar "Return the normal scrollbar fillStyle for the given scrollbar." ^ "(self glamorousBaseColorFor: aScrollbar) muchLighter" Color r: 245 g: 245 b: 245 range: 255! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! radioButtonForm "Answer the form to use for a normal radio button." ^ Pharo3UIThemeIcons radioButtonUnselectedForm! ! !Pharo3Theme methodsFor: 'defaults' stamp: 'tg 9/6/2010 14:04'! buttonMinHeight "Answer the minumum height of a button for this theme." ^24! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'TudorGirba 8/21/2011 16:46'! splitterPressedFillStyleFor: aSplitter "Return the pressed splitter fillStyle for the given splitter." |aColor| aColor := self glamorousBaseColorFor: aSplitter. ^ (GradientFillStyle ramp: {0.0->aColor lighter. 0.9-> aColor}) origin: aSplitter topLeft; direction: (aSplitter splitsTopAndBottom ifTrue: [0 @ aSplitter height] ifFalse: [aSplitter width @ 0]); radial: false! ! !Pharo3Theme methodsFor: 'private' stamp: 'PhilippeBack 3/26/2014 09:37'! glamorousVeryLightFillStyleFor: aMorph height: anInteger "Return the very light button fillStyle for the given button." " | baseColor | baseColor := self glamorousBaseColorFor: aMorph. ^ self glamorousNormalFillStyleWithBaseColor: baseColor for: aMorph height: anInteger " ^ SolidFillStyle color: (self glamorousVeyLightSelectionColorFor: aMorph)! ! !Pharo3Theme methodsFor: 'defaults' stamp: 'tg 9/6/2010 14:04'! buttonMinWidth "Answer the minumum width of a button for this theme." ^24! ! !Pharo3Theme methodsFor: 'initialize-release' stamp: 'TudorGirba 4/8/2011 01:08'! newWindowInactiveControlForm "Answer a new form for an inactive window control box." ^(Form extent: 16@16 depth: 32 fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4291677645 4288585374 4286085240 4284243036 4284243036 4286085240 4288585374 4291677645 0 0 0 0 0 0 0 4289572269 4285756275 4286479998 4288716960 4289835441 4289835441 4288716960 4286479998 4285756275 4289572269 0 0 0 0 0 4289506476 4284835173 4287335307 4290559164 4292598747 4293322470 4293322470 4292598747 4290559164 4287335307 4284703587 4289506476 0 0 0 4291546059 4285493103 4286414205 4288980132 4291217094 4292335575 4292598747 4292598747 4292335575 4291282887 4288980132 4286282619 4285493103 4291546059 0 0 4288980132 4285361517 4287466893 4288782753 4289835441 4290295992 4290295992 4290427578 4290164406 4289835441 4288782753 4287466893 4285361517 4288980132 0 0 4286282619 4286611584 4288059030 4288716960 4289177511 4289572269 4289835441 4289835441 4289703855 4289374890 4288782753 4288059030 4286611584 4286282619 0 0 4285164138 4287664272 4288782753 4289374890 4289835441 4290427578 4290624957 4290624957 4290559164 4290032820 4289374890 4288914339 4287664272 4285164138 0 0 4285361517 4288322202 4289703855 4290295992 4290822336 4291414473 4291677645 4291677645 4291414473 4291085508 4290427578 4289703855 4288453788 4285624689 0 0 4287072135 4288716960 4290427578 4291217094 4291677645 4292203989 4292598747 4292598747 4292335575 4291809231 4291217094 4290427578 4288716960 4287203721 0 0 4288980132 4288256409 4290624957 4291677645 4292335575 4292927712 4293256677 4293256677 4293059298 4292598747 4291809231 4290822336 4288256409 4289177511 0 0 4291677645 4287664272 4290295992 4292006610 4293059298 4293454056 4293585642 4293585642 4293454056 4293125091 4292203989 4290427578 4287730065 4291677645 0 0 4293256677 4290032820 4288124823 4291217094 4292796126 4293322470 4293717228 4293717228 4293454056 4292927712 4291677645 4288256409 4290032820 4293256677 0 0 0 4293454056 4290032820 4288322202 4289967027 4291546059 4292598747 4292664540 4291677645 4290295992 4288716960 4290032820 4293454056 0 0 0 0 0 4293322470 4292203989 4289835441 4288782753 4288322202 4288453788 4288980132 4289835441 4292335575 4293322470 0 0 0 0 0 0 0 4293059298 4293585642 4293717228 4293585642 4293585642 4293585642 4293585642 4293059298 0 0 0 0) offset: 0@0)! ! !Pharo3Theme methodsFor: 'private' stamp: 'tg 9/9/2010 22:02'! glamorousLightColorFor: aButton ^ self class lightBaseColor! ! !Pharo3Theme methodsFor: 'growl - specific' stamp: 'TudorGirba 4/18/2012 09:32'! growlBorderColorFor: aGrowlMorph ^ Color white alpha: 0.5! ! !Pharo3Theme methodsFor: 'initialize-release' stamp: 'TudorGirba 4/8/2011 01:09'! initializeForms "Initialize the receiver's image forms." |inactiveForm| super initializeForms. inactiveForm := self newWindowInactiveControlForm. self forms at: #windowCloseOver put: self newWindowCloseOverForm; at: #windowMinimizeOver put: self newWindowMinimizeOverForm; at: #windowMaximizeOver put: self newWindowMaximizeOverForm; at: #windowClosePassive put: inactiveForm; at: #windowMinimizePassive put: inactiveForm; at: #windowMaximizePassive put: inactiveForm! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! newCheckboxMarkerForm "Answer a new checkbox marker form." ^Pharo3UIThemeIcons checkboxMarkerForm! ! !Pharo3Theme methodsFor: 'border-styles-scrollbars' stamp: 'tg 8/31/2010 13:27'! scrollbarThumbCornerStyleIn: aThemedMorph ^#square! ! !Pharo3Theme methodsFor: 'border-styles-buttons' stamp: 'tg 9/4/2010 23:06'! buttonCornerStyleIn: aThemedMorph "If asked, we only allow square corners" ^ #square! ! !Pharo3Theme methodsFor: 'basic-colors' stamp: 'TudorGirba 4/8/2011 00:02'! treeLineWidth "Answer the width of the tree lines." ^0! ! !Pharo3Theme methodsFor: 'fill-styles-buttons' stamp: 'tg 9/13/2010 10:37'! buttonSelectedFillStyleFor: aButton "Return the normal button fillStyle for the given button." | top bottom | top := self glamorousLightSelectionColorFor: aButton. bottom := self glamorousLightColorFor: aButton. ^(GradientFillStyle ramp: { 0.0->top. 0.7->bottom.}) origin: aButton bounds origin; direction: 0 @ aButton height; radial: false! ! !Pharo3Theme methodsFor: 'border-styles' stamp: 'tg 9/4/2010 23:09'! textEditorNormalBorderStyleFor: aTextEditor "Return the normal text editor borderStyle for the given text editor." ^self buttonNormalBorderStyleFor: aTextEditor! ! !Pharo3Theme methodsFor: 'scrollbars' stamp: 'tg 9/4/2010 20:16'! verticesForSimpleArrow: aRectangle "PRIVATE - answer a collection of vertices to draw a simple arrow" | vertices | vertices := OrderedCollection new. "" vertices add: aRectangle bottomLeft. vertices add: aRectangle center x @ (aRectangle top + (aRectangle width / 8)). vertices add: aRectangle bottomRight. vertices add: aRectangle bottomRight + (0@0.01). "" ^ vertices " | vertices | vertices := OrderedCollection new. vertices add: (aRectangle center x - (aRectangle width / 4)) @ (aRectangle bottom - 8). vertices add: aRectangle center x @ (aRectangle top). vertices add: (aRectangle center x + (aRectangle width / 4)) @ (aRectangle bottom - 8). vertices add: (aRectangle center x + (aRectangle width / 4)) @ (aRectangle bottom - 8) + (0@0.01). ^ vertices" " ^ super verticesForSimpleArrow: aRectangle "! ! !Pharo3Theme methodsFor: 'label-styles' stamp: 'tg 8/31/2010 08:32'! buttonLabelForText: aTextOrString "Answer the label to use for the given text." ^aTextOrString isString ifTrue: [(LabelMorph contents: aTextOrString) color: Color black] ifFalse: [super buttonLabelForText: aTextOrString]! ! !Pharo3Theme methodsFor: 'border-styles' stamp: 'tg 9/9/2010 23:51'! groupPanelBorderStyleFor: aGroupPanel "Answer the normal border style for a group panel." ^ SimpleBorder new width: 1; baseColor: ((self glamorousBaseColorFor: aGroupPanel))! ! !Pharo3Theme methodsFor: 'watcher window' stamp: 'TudorGirba 5/23/2012 14:10'! watcherWindowInactiveFillStyleFor: aWindow ^ SolidFillStyle color: (Color veryVeryLightGray alpha: 0.6)! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:51'! progressBarFillStyleFor: aProgressBar ^ self glamorousBasePassiveBackgroundColorFor: aProgressBar! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! checkboxSelectedForm "Answer the form to use for a selected checkbox." ^Pharo3UIThemeIcons checkboxSelectedForm! ! !Pharo3Theme methodsFor: 'morph creation' stamp: 'TudorGirba 4/8/2011 01:15'! newCloseControlIn: aThemedMorph for: aModel action: aValuable help: helpText "Answer a button for closing things." |form msb| form := self windowCloseForm. msb := MultistateButtonMorph new extent: form extent. msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form). form := self windowClosePassiveForm. msb extent: form extent. msb activeDisabledNotOverUpFillStyle: (ImageFillStyle form: form). msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). msb passiveDisabledNotOverUpFillStyle: (ImageFillStyle form: form). form := self windowCloseOverForm. msb extent: form extent. msb activeEnabledOverUpFillStyle: (ImageFillStyle form: form); passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). form := self windowClosePassiveForm. msb extent: form extent; activeEnabledOverDownFillStyle: (ImageFillStyle form: form); passiveEnabledOverDownFillStyle: (ImageFillStyle form: form); addUpAction: aValuable; setBalloonText: helpText. ^msb! ! !Pharo3Theme methodsFor: 'fill-styles-buttons' stamp: 'tg 8/31/2010 11:13'! tabLabelSelectedFillStyleFor: aTabLabel ^ self buttonSelectedFillStyleFor: aTabLabel ! ! !Pharo3Theme methodsFor: 'private' stamp: 'TudorGirba 4/12/2011 08:24'! glamorousLightSelectionColorFor: aMorph ^ self class lightSelectionColor! ! !Pharo3Theme methodsFor: 'label-styles' stamp: 'TudorGirba 4/8/2011 01:14'! windowMaximizeOverForm "Answer the form to use for mouse over window maximize buttons" ^self forms at: #windowMaximizeOver ifAbsent: [Form extent: 16@16 depth: Display depth]! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:48'! listDisabledFillStyleFor: aList "Return the disabled fillStyle for the given list." ^ self textEditorDisabledFillStyleFor: aList! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:47'! dropListDisabledFillStyleFor: aDropList "Return the disabled fillStyle for the given drop list." ^ self textEditorDisabledFillStyleFor: aDropList! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:48'! sliderDisabledFillStyleFor: aSlider "Return the disabled fillStyle for the given slider." ^ self textEditorDisabledFillStyleFor: aSlider! ! !Pharo3Theme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 15:09'! newWindowMinimizeOverForm "Answer a new form for a window menu box." ^ self newWindowMinimizeForm! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'TudorGirba 5/31/2012 22:28'! windowActiveFillStyleFor: aWindow "We do not want the lighting effect when the window goes inactive" ^SolidFillStyle color: self class baseColor! ! !Pharo3Theme methodsFor: 'label-styles' stamp: 'TudorGirba 4/8/2011 00:12'! configureWindowLabelAreaFor: aWindow "Configure the label area for the given window." |padding| padding := 0. aWindow labelArea addMorphBack: (Morph new extent: aWindow class borderWidth @ 0). aWindow hasCloseBox ifTrue: [aWindow addCloseBox. padding := padding + 1]. aWindow hasCollapseBox ifTrue: [aWindow addCollapseBox. padding := padding + 1]. aWindow hasExpandBox ifTrue: [aWindow addExpandBox. padding := padding + 1]. aWindow hasMenuBox ifTrue: [padding := padding - 1]. aWindow labelArea addMorphBack: (Morph new extent: aWindow class borderWidth @ 0; hResizing: #spaceFill). aWindow basicLabel ifNotNil: [:label | aWindow labelArea addMorphBack: label; hResizing: #shrinkWrap]. aWindow labelArea addMorphBack: (Morph new extent: aWindow class borderWidth @ 0; hResizing: #spaceFill). padding > 0 ifTrue: [ aWindow labelArea addMorphBack: (Morph new extent: (aWindow boxExtent x * padding) @ 0)]. aWindow hasMenuBox ifTrue: [aWindow addMenuControl]. aWindow labelArea addMorphBack: (Morph new extent: aWindow class borderWidth @ 0)! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! newWindowMenuForm "Answer a new form for a window menu box." ^ Pharo3UIThemeIcons windowMenuForm! ! !Pharo3Theme methodsFor: 'initialize-release' stamp: 'tg 9/6/2010 14:38'! newRadioMarkerForm "Answer a new checkbox marker form." ^Form extent: 12@12 depth: 32! ! !Pharo3Theme methodsFor: 'private' stamp: 'TudorGirba 4/11/2011 01:37'! glamorousNormalFillStyleWithBaseColor: aColor for: aMorph height: anInteger | top bottom | top := aColor darker. bottom := aColor. ^(GradientFillStyle ramp: { 0.0->top. 0.7->bottom.}) origin: aMorph bounds origin; direction: 0 @ anInteger; radial: false! ! !Pharo3Theme methodsFor: 'border-styles' stamp: 'tg 9/4/2010 20:23'! taskbarThumbnailCornerStyleFor: aMorph "Answer the corner style for the taskbar thumbnail/tasklist." ^#square! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! menuPinForm "Answer the form to use for the pin button of a menu." ^ Pharo3UIThemeIcons menuPinForm! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'TudorGirba 8/21/2011 16:47'! morphTreeSplitterNormalFillStyleFor: aSplitter ^ self splitterNormalFillStyleFor: aSplitter! ! !Pharo3Theme methodsFor: 'fill-styles-buttons' stamp: 'tg 9/10/2010 08:12'! menuItemInDockingBarSelectedFillStyleFor: aMenuItem "Answer the selected fill style to use for the given menu item that is in a docking bar." ^ self buttonSelectedFillStyleFor: aMenuItem! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! newWindowMinimizeForm "Answer a new form for a window minimize box." ^ Pharo3UIThemeIcons windowMinimizeForm! ! !Pharo3Theme methodsFor: 'fill-styles-buttons' stamp: 'tg 8/31/2010 11:13'! tabLabelNormalFillStyleFor: aTabLabel ^ self buttonNormalFillStyleFor: aTabLabel ! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'TudorGirba 5/31/2012 22:51'! windowActiveTitleFillStyleFor: aWindow ^ "self glamorousNormalFillStyleFor: aWindow height: aWindow labelHeight" SolidFillStyle color: Color transparent! ! !Pharo3Theme methodsFor: 'accessing' stamp: 'TudorGirba 4/7/2011 23:46'! windowActiveDropShadowStyle: anObject "Set the value of windowActiveDropShadowStyle" windowActiveDropShadowStyle := anObject! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'TudorGirba 8/21/2011 16:49'! morphTreeSplitterPressedFillStyleFor: aSplitter ^ self splitterPressedFillStyleFor: aSplitter! ! !Pharo3Theme methodsFor: 'label-styles' stamp: 'tg 9/3/2010 10:52'! windowMenuPassiveForm "Answer the form to use for passive (background) window menu buttons" ^self newWindowMenuPassiveForm! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:41'! splitterNormalFillStyleFor: aSplitter "Return the normal splitter fillStyle for the given splitter." ^ SolidFillStyle color: Color transparent! ! !Pharo3Theme methodsFor: 'private' stamp: 'tg 9/5/2010 20:40'! glamorousBasePassiveBackgroundColorFor: aButton ^ self class basePassiveBackgroundColor! ! !Pharo3Theme methodsFor: 'private' stamp: 'PhilippeBack 3/26/2014 09:33'! glamorousVeyLightSelectionColorFor: aMorph ^ self class veryLightSelectionColor! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! newRadioButtonMarkerForm "Answer a new radio button marker form. We make it empty because we already have the selected radio button take care of the state." ^Pharo3UIThemeIcons radioButtonMarkerForm ! ! !Pharo3Theme methodsFor: 'growl - specific' stamp: 'TudorGirba 4/18/2012 09:30'! growlFillColorFor: aGrowlMorph ^ Color darkGray alpha: 0.5! ! !Pharo3Theme methodsFor: 'border-styles-scrollbars' stamp: 'tg 8/31/2010 13:27'! scrollbarPagingAreaCornerStyleIn: aThemedMorph ^#square! ! !Pharo3Theme methodsFor: 'fill-styles-scrollbars' stamp: 'TudorGirba 4/11/2011 01:38'! scrollbarNormalThumbFillStyleFor: aScrollbar "Return the normal scrollbar fillStyle for the given scrollbar." "^ (self glamorousNormalFillStyleWithBaseColor: aScrollbar paneColor for: aScrollbar height: aScrollbar height) direction: (aScrollbar bounds isWide ifTrue: [0 @ aScrollbar height] ifFalse: [aScrollbar width @ 0])" ^ self glamorousNormalFillStyleFor: aScrollbar height: aScrollbar height! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! radioButtonSelectedForm "Answer the form to use for a selected radio button." ^ Pharo3UIThemeIcons radioButtonSelectedForm ! ! !Pharo3Theme methodsFor: 'private' stamp: 'tg 9/9/2010 22:50'! glamorousDarkBaseColorFor: aButton ^ self class darkBaseColor! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! checkboxUnselectedForm "Answer the form to use for a selected checkbox." ^ Pharo3UIThemeIcons checkboxUnselectedForm! ! !Pharo3Theme methodsFor: 'watcher window' stamp: 'TudorGirba 5/23/2012 14:26'! configureWatcherWindowLabelAreaFor: aWindow "Configure the label area for the given Watcher window." |padding| padding := 0. aWindow labelArea addMorphBack: (Morph new extent: aWindow class borderWidth @ 0). aWindow hasCloseBox ifTrue: [aWindow addCloseBox. padding := padding + 1]. " aWindow hasCollapseBox ifTrue: [aWindow addCollapseBox. padding := padding + 1]. aWindow hasExpandBox ifTrue: [aWindow addExpandBox. padding := padding + 1]. aWindow hasMenuBox ifTrue: [padding := padding - 1]. " aWindow labelArea addMorphBack: (Morph new extent: aWindow class borderWidth @ 0; hResizing: #spaceFill). aWindow basicLabel ifNotNil: [:label | aWindow labelArea addMorphBack: label; hResizing: #shrinkWrap]. aWindow labelArea addMorphBack: (Morph new extent: aWindow class borderWidth @ 0; hResizing: #spaceFill). padding > 0 ifTrue: [ aWindow labelArea addMorphBack: (Morph new extent: (aWindow boxExtent x * padding) @ 0)]. " aWindow hasMenuBox ifTrue: [aWindow addMenuControl]." aWindow labelArea addMorphBack: (Morph new extent: aWindow class borderWidth @ 0)! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 9/4/2010 23:14'! separatorFillStyleFor: aSeparator "Return the separator fillStyle for the given separator." ^ SolidFillStyle color: (self glamorousBaseColorFor: aSeparator) darker! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! newWindowMenuPassiveForm "Answer a new form for a window menu box." ^ Pharo3UIThemeIcons windowMenuInactiveForm! ! !Pharo3Theme methodsFor: 'border-styles' stamp: 'tg 9/4/2010 22:55'! dropListNormalBorderStyleFor: aDropList "Return the normal borderStyle for the given drop list" ^ self buttonNormalBorderStyleFor: aDropList! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 9/3/2010 12:30'! dockingBarNormalFillStyleFor: aToolDockingBar ^ SolidFillStyle color: Color transparent! ! !Pharo3Theme methodsFor: 'private' stamp: 'PhilippeBack 3/26/2014 11:39'! glamorousSelectedFillStyleFor: aMorph height: anInteger ^ SolidFillStyle color: (self glamorousLightSelectionColorFor: aMorph) ! ! !Pharo3Theme methodsFor: 'forms' stamp: 'PhilippeBack 3/26/2014 11:38'! scrollbarPressedThumbFillStyleFor: aScrollbar "Return the pressed scrollbar thumb fillStyle for the given scrollbar." "Return the normal scrollbar fillStyle for the given scrollbar." "^ (self glamorousNormalFillStyleWithBaseColor: aScrollbar paneColor for: aScrollbar height: aScrollbar height) direction: (aScrollbar bounds isWide ifTrue: [0 @ aScrollbar height] ifFalse: [aScrollbar width @ 0])" " ^ SolidFillStyle color: Color lightGray lighter." ^ self glamorousSelectedFillStyleFor: aScrollbar height: aScrollbar height! ! !Pharo3Theme methodsFor: 'defaults' stamp: 'TudorGirba 5/19/2013 21:26'! windowShadowColor "Answer the window shadow color to use." ^ Color gray! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 1/14/2010 03:10'! resizerGripNormalFillStyleFor: aResizer "Return the normal fillStyle for the given resizer. For the moment, answer a transparent colour for no drawing, non transparent to draw as normal." ^Color transparent! ! !Pharo3Theme methodsFor: 'watcher window' stamp: 'TudorGirba 5/23/2012 14:09'! watcherWindowActiveFillStyleFor: aWindow ^ SolidFillStyle color: (Color veryVeryLightGray alpha: 0.6)! ! !Pharo3Theme methodsFor: 'growl - specific' stamp: 'TudorGirba 4/17/2012 15:00'! growlContentsColorFor: aGrowlMorph ^ Color white! ! !Pharo3Theme methodsFor: 'basic-colors' stamp: 'tg 9/6/2010 15:03'! taskbarButtonLabelColorFor: aButton "Answer the colour for the label of the given taskbar button." ^aButton model ifNil: [super taskbarButtonLabelColorFor: aButton] ifNotNil: [:win | win isActive ifTrue: [Color black] ifFalse: [Color gray darker]]! ! !Pharo3Theme methodsFor: 'border-styles-buttons' stamp: 'tg 8/31/2010 11:09'! buttonSelectedBorderStyleFor: aButton ^ self buttonNormalBorderStyleFor: aButton! ! !Pharo3Theme methodsFor: 'private' stamp: 'tg 9/3/2010 12:32'! glamorousBaseColorFor: aButton ^ self class baseColor "unfortunately, it looks like paneColor does not always return the wanted color" "aButton paneColorOrNil ifNil: [Color r: 200 g: 200 b: 200 range: 255]"! ! !Pharo3Theme methodsFor: 'initialize-release' stamp: 'TudorGirba 4/8/2011 01:06'! newTreeExpandedForm "Answer a new form for an expanded tree item." ^(Form extent: 9@9 depth: 32 fromArray: #( 1049135240 2290649224 2290649224 2290649224 2290649224 2290649224 2290649224 2290649224 1200130184 478709896 4169697416 4287137928 4287137928 4287137928 4287137928 4287137928 4236806280 646482056 16777215 2508753032 4287137928 4287137928 4287137928 4287137928 4287137928 2726856840 16777215 16777215 495487112 4186474632 4287137928 4287137928 4287137928 4236806280 612927624 16777215 16777215 16777215 2542307464 4287137928 4287137928 4287137928 2676525192 16777215 16777215 16777215 16777215 478709896 4169697416 4287137928 4220029064 579373192 16777215 16777215 16777215 16777215 16777215 2424866952 4287137928 2626193544 16777215 16777215 16777215 16777215 16777215 16777215 394823816 4018702472 529041544 16777215 16777215 16777215 16777215 16777215 16777215 16777215 864585864 16777215 16777215 16777215 16777215) offset: 0@0)! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'TudorGirba 4/14/2011 10:28'! progressFillStyleFor: aProgress "Return the progress fillStyle for the given progress morph." ^ self windowActiveFillStyleFor: aProgress ! ! !Pharo3Theme methodsFor: 'scrollbars' stamp: 'TudorGirba 5/19/2013 14:46'! scrollBarButtonArrowVertices: aRectangle ^ self verticesForSimpleArrow: aRectangle! ! !Pharo3Theme methodsFor: 'border-styles-buttons' stamp: 'TudorGirba 4/12/2011 08:18'! buttonNormalBorderStyleFor: aButton "Return the normal button borderStyle for the given button." | outerColor innerColor | (aButton valueOfProperty: #noBorder ifAbsent: [false]) ifTrue: [ ^ SimpleBorder new width: 0; baseColor: Color transparent ]. outerColor := self glamorousDarkBaseColorFor: aButton. ^SimpleBorder new width: 1; baseColor: outerColor! ! !Pharo3Theme methodsFor: 'label-styles' stamp: 'tg 9/3/2010 11:34'! createMenuBoxFor: aSystemWindow "Answer a button for the window menu." " ^aSystemWindow createBox labelGraphic: (self windowMenuIconFor: aSystemWindow); extent: aSystemWindow boxExtent; actWhen: #buttonDown; actionSelector: #offerWindowMenu; setBalloonText: 'window menu' translated" |form msb| form := self windowMenuForm. msb := MultistateButtonMorph new extent: form extent. msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form). form := self windowMenuPassiveForm. msb extent: form extent. msb activeDisabledNotOverUpFillStyle: (ImageFillStyle form: form). msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). msb passiveDisabledNotOverUpFillStyle: (ImageFillStyle form: form). form := self windowMenuForm. msb extent: form extent. msb activeEnabledOverUpFillStyle: (ImageFillStyle form: form); passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). form := self windowMenuPassiveForm. msb extent: form extent; activeEnabledOverDownFillStyle: (ImageFillStyle form: form); passiveEnabledOverDownFillStyle: (ImageFillStyle form: form); addUpAction: [aSystemWindow offerWindowMenu]; setBalloonText: 'window menu' translated; extent: aSystemWindow boxExtent. ^msb! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! windowClosePassiveForm "Answer the form to use for passive (background) window close buttons" ^Pharo3UIThemeIcons windowCloseInactiveForm! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 9/4/2010 23:04'! dropListNormalFillStyleFor: aDropList "Return the normal fillStyle for the given drop list." ^ SolidFillStyle color: Color white! ! !Pharo3Theme methodsFor: 'label-styles' stamp: 'TudorGirba 4/8/2011 01:14'! windowMinimizeOverForm "Answer the form to use for mouse over window minimize buttons" ^self forms at: #windowMinimizeOver ifAbsent: [Form extent: 16@16 depth: Display depth]! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! windowMinimizePassiveForm "Answer the form to use for passive (background) window minimize buttons" ^Pharo3UIThemeIcons windowMinimizeInactiveForm! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'TudorGirba 1/25/2011 15:39'! expanderTitleNormalFillStyleFor: anExpanderTitle "Return the normal expander title fillStyle for the given expander title." ^ self buttonNormalFillStyleFor: anExpanderTitle! ! !Pharo3Theme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 14:18'! newWindowMaximizeOverForm "Answer a new form for a window menu box." ^ self newWindowMaximizeForm! ! !Pharo3Theme methodsFor: 'private' stamp: 'tg 9/5/2010 20:40'! glamorousBaseSelectionColorFor: aButton ^ self class baseSelectionColor! ! !Pharo3Theme methodsFor: 'defaults' stamp: 'TudorGirba 7/26/2011 12:08'! dialogWindowPreferredCornerStyleFor: aDialogWindow "Answer the preferred corner style for the given dialog." ^#square! ! !Pharo3Theme methodsFor: 'label-styles' stamp: 'TudorGirba 4/8/2011 01:17'! createExpandBoxFor: aSystemWindow "Answer a button for maximising/restoring the window." |form msb| form := self windowMaximizeForm. msb := MultistateButtonMorph new extent: form extent. msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form). form := self windowMaximizePassiveForm. msb extent: form extent. msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). form := self windowMaximizeOverForm. msb extent: form extent. msb activeEnabledOverUpFillStyle: (ImageFillStyle form: form); passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). form := self windowMaximizePassiveForm. msb extent: form extent; activeEnabledOverDownFillStyle: (ImageFillStyle form: form); passiveEnabledOverDownFillStyle: (ImageFillStyle form: form); addUpAction: [aSystemWindow expandBoxHit]; setBalloonText: 'Expand to full screen' translated; extent: aSystemWindow boxExtent. ^msb! ! !Pharo3Theme methodsFor: 'morph creation' stamp: 'tg 9/5/2010 21:28'! newFocusIndicatorMorphFor: aMorph "Answer a new focus indicator for the given morph." |radius| radius := aMorph focusIndicatorCornerRadius. ^ BorderedMorph new fillStyle: Color transparent; borderStyle: (SimpleBorder new width: 1; baseColor: (self glamorousBaseSelectionColorFor: aMorph)); bounds: aMorph focusBounds! ! !Pharo3Theme methodsFor: 'border-styles' stamp: 'tg 9/3/2010 14:50'! plainGroupPanelBorderStyleFor: aGroupPanel "Answer the normal border style for a plain group panel." ^SimpleBorder new width: 1; baseColor: Color transparent! ! !Pharo3Theme methodsFor: 'border-styles' stamp: 'TudorGirba 6/1/2012 19:40'! configureWindowBorderFor: aWindow " super configureWindowBorderFor: aWindow. aWindow roundedCorners: #()" | aStyle | aStyle := SimpleBorder new color: (Color lightGray); width: 1. aWindow borderStyle: aStyle.! ! !Pharo3Theme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 09:08'! checkboxForm "Answer the form to use for a normal checkbox." ^self checkboxUnselectedForm! ! !Pharo3Theme methodsFor: 'border-styles' stamp: 'EstebanLorenzano 10/10/2013 17:36'! tabPanelBorderStyleFor: aTabGroup ^ Pharo3TabPanelBorder new width: 1; baseColor: ((self glamorousDarkBaseColorFor: aTabGroup)); tabSelector: aTabGroup tabSelectorMorph! ! !Pharo3Theme methodsFor: 'label-styles' stamp: 'TudorGirba 4/8/2011 01:13'! windowCloseOverForm "Answer the form to use for mouse over window close buttons" ^self forms at: #windowCloseOver ifAbsent: [Form extent: 16@16 depth: Display depth]! ! !Pharo3Theme methodsFor: 'basic-colors' stamp: 'tg 9/13/2010 10:36'! subgroupColorFrom: paneColor "Answer the colour for a subgroup given the pane colour." ^ self glamorousLightColorFor: paneColor" self class baseColor"! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 9/2/2010 13:52'! windowInactiveFillStyleFor: aWindow "We do not want the lighting effect when the window goes inactive" ^self windowActiveFillStyleFor: aWindow! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! newWindowMaximizeForm "Answer a new form for a window maximize box." ^ Pharo3UIThemeIcons windowMaximizeForm! ! !Pharo3Theme methodsFor: 'private' stamp: 'TudorGirba 4/11/2011 21:25'! glamorousNormalFillStyleFor: aMorph height: anInteger "Return the normal button fillStyle for the given button." " | baseColor | baseColor := self glamorousBaseColorFor: aMorph. ^ self glamorousNormalFillStyleWithBaseColor: baseColor for: aMorph height: anInteger " ^ SolidFillStyle color: (self glamorousLightColorFor: aMorph)! ! !Pharo3Theme methodsFor: 'border-styles' stamp: 'tg 8/31/2010 15:28'! tabLabelNormalBorderStyleFor: aTabLabel " ^SimpleBorder new width: 0; baseColor: (self buttonBaseColorFor: aTabLabel) darker " ^ self buttonNormalBorderStyleFor: aTabLabel! ! !Pharo3Theme methodsFor: 'growl - specific' stamp: 'TudorGirba 4/18/2012 09:16'! growlDismissHandleFor: aGrowlMorph | form image | form := self windowCloseForm. image := ImageMorph new. image image: form. image color: Color yellow. ^ image! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 9/7/2010 13:52'! progressBarProgressFillStyleFor: aProgressBar ^ (self glamorousLightSelectionColorFor: aProgressBar)! ! !Pharo3Theme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:46'! textEditorDisabledFillStyleFor: aTextEditor "Return the disabled fillStyle for the given text editor." ^self glamorousBasePassiveBackgroundColorFor: aTextEditor! ! !Pharo3Theme methodsFor: 'fill-styles-scrollbars' stamp: 'tg 9/13/2010 10:52'! scrollbarNormalButtonFillStyleFor: aScrollbar "Return the normal scrollbar button fillStyle for the given scrollbar." ^ self scrollbarNormalThumbFillStyleFor: aScrollbar! ! !Pharo3Theme methodsFor: 'fill-styles-buttons' stamp: 'tg 9/3/2010 12:21'! buttonNormalFillStyleFor: aButton "Return the normal button fillStyle for the given button." (aButton valueOfProperty: #noFill ifAbsent: [false]) ifTrue: [^ SolidFillStyle color: Color transparent ]. ^ self glamorousNormalFillStyleFor: aButton height: aButton height! ! !Pharo3Theme methodsFor: 'initialize-release' stamp: 'TudorGirba 4/8/2011 01:06'! newTreeUnexpandedForm "Answer a new form for an unexpanded tree item." ^(Form extent: 9@9 depth: 32 fromArray: #( 1049135240 461932680 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2324203656 4152920200 2458421384 428378248 16777215 16777215 16777215 16777215 16777215 2357758088 4287137928 4287137928 4152920200 2408089736 394823816 16777215 16777215 16777215 2391312520 4287137928 4287137928 4287137928 4287137928 4119365768 2324203656 344492168 16777215 2408089736 4287137928 4287137928 4287137928 4287137928 4287137928 4287137928 3968370824 780699784 2391312520 4287137928 4287137928 4287137928 4287137928 4236806280 2659747976 529041544 16777215 2357758088 4287137928 4287137928 4253583496 2810742920 646482056 16777215 16777215 16777215 2324203656 4253583496 2777188488 696813704 16777215 16777215 16777215 16777215 16777215 1200130184 663259272 16777215 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !Pharo3Theme methodsFor: 'label-styles' stamp: 'TudorGirba 4/8/2011 01:17'! createCollapseBoxFor: aSystemWindow "Answer a button for minimising the window." |form msb| form := self windowMinimizeForm. msb := MultistateButtonMorph new extent: form extent. msb activeEnabledNotOverUpFillStyle: (ImageFillStyle form: form). form := self windowMinimizePassiveForm. msb extent: form extent. msb passiveEnabledNotOverUpFillStyle: (ImageFillStyle form: form). form := self windowMinimizeOverForm. msb extent: form extent. msb activeEnabledOverUpFillStyle: (ImageFillStyle form: form); passiveEnabledOverUpFillStyle: (ImageFillStyle form: form). form := self windowMinimizePassiveForm. msb extent: form extent; activeEnabledOverDownFillStyle: (ImageFillStyle form: form); passiveEnabledOverDownFillStyle: (ImageFillStyle form: form); addUpAction: [aSystemWindow collapseBoxHit]; setBalloonText: 'Collapse this window' translated; extent: aSystemWindow boxExtent. ^msb! ! !Pharo3Theme methodsFor: 'forms' stamp: 'EstebanLorenzano 10/10/2013 17:36'! newWindowCloseForm "Answer a new form for a window close box." ^ Pharo3UIThemeIcons windowCloseForm ! ! !Pharo3Theme class methodsFor: 'private' stamp: 'EstebanLorenzano 10/10/2013 17:36'! importGlamorousIcons "utility method to import the icons necessary for the theme from the file system" "self importGlamorousIcons" | icons | icons := #( 'glamorousMax' 'glamorousMin' 'glamorousClose' 'glamorousMenu' 'glamorousMaxInactive' 'glamorousMinInactive' 'glamorousCloseInactive' 'glamorousMenuInactive' 'glamorousMenuPin' 'glamorousCheckboxSelected' 'glamorousCheckboxUnselected' 'glamorousRadioSelected' 'glamorousRadioUnselected'). self importIcons: icons fromFolder: 'icons' inClass: Pharo3UIThemeIcons category: '*glamour-morphic-theme'! ! !Pharo3Theme class methodsFor: 'accessing' stamp: 'TudorGirba 5/31/2012 22:33'! darkBaseColor ^ Color r: 200 g: 200 b: 200 range: 255! ! !Pharo3Theme class methodsFor: 'private' stamp: 'tg 9/3/2010 14:28'! importIcons: icons fromFolder: aString inClass: aClass category: aCategory icons do: [:each | | method form | form := PNGReadWriter formFromFileNamed: aString, '/', each , '.png'. method := each , Character cr asString , (aClass methodStart: each), form storeString, aClass methodEnd. aClass class compile: method classified: aCategory ]. aClass initialize! ! !Pharo3Theme class methodsFor: 'testing' stamp: 'TudorGirba 4/7/2011 23:45'! isAbstract "Answer whether the receiver is considered to be abstract." ^false! ! !Pharo3Theme class methodsFor: 'settings' stamp: 'TudorGirba 2/16/2011 20:56'! setPreferredShoutColors "self setPreferredShoutColors" SHTextStylerST80 styleTable: #( "(symbol color [emphasisSymbolOrArray [textStyleName [pixelHeight]]])" (default black) (invalid red) (excessCode red) (comment (gray darker)) (unfinishedComment (red muchDarker)) (#'$' (red muchDarker)) (character (red muchDarker)) (integer (red muchDarker)) (number (red muchDarker)) (#- (red muchDarker)) (symbol (magenta muchDarker)) (stringSymbol (magenta muchDarker)) (literalArray (magenta muchDarker)) (string (magenta muchDarker) normal) (unfinishedString red normal) (assignment nil) (ansiAssignment nil) (literal nil italic) (keyword (black)) (binary (black)) (unary (black)) (incompleteKeyword red) (incompleteBinary red) (incompleteUnary red ) (undefinedKeyword red) (undefinedBinary red) (undefinedUnary red) (patternKeyword nil bold) (patternBinary nil bold) (patternUnary nil bold) (#self (cyan muchDarker )) (#super (cyan muchDarker )) (#true (red muchDarker)) (#false (red muchDarker)) (#nil (red muchDarker)) (#thisContext (cyan muchDarker )) (#return (cyan muchDarker ) bold) (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) (leftBrace black) (rightBrace black) (cascadeSeparator black) (statementSeparator black) (externalCallType black) (externalCallTypePointerIndicator black) (primitiveOrExternalCallStart black bold) (primitiveOrExternalCallEnd black bold) (methodTempBar (black)) (blockTempBar (black)) (blockArgsBar (black)) (primitive (green muchDarker)) (pragmaKeyword (green muchDarker)) (pragmaUnary (green muchDarker)) (pragmaBinary (green muchDarker)) (externalFunctionCallingConvention (green muchDarker) bold) (module (green muchDarker) bold) (blockTempVar (blue muchDarker)) (blockPatternTempVar (blue muchDarker)) (instVar (blue muchDarker)) (workspaceVar (blue muchDarker)) (undefinedIdentifier red) (incompleteIdentifier red) (tempVar (blue muchDarker)) (patternTempVar (blue muchDarker)) (poolConstant (blue muchDarker)) (classVar (blue muchDarker)) (globalVar (blue muchDarker))) ! ! !Pharo3Theme class methodsFor: 'settings' stamp: 'EstebanLorenzano 5/23/2013 20:21'! setPreferredPreferences "NECPreferences expandPrefixes: true; popupShowWithShortcut: Character tab asShortcut."! ! !Pharo3Theme class methodsFor: 'accessing' stamp: 'tg 9/7/2010 13:51'! lightSelectionColor ^ Color r: 175 g: 213 b: 250 range: 255! ! !Pharo3Theme class methodsFor: 'accessing' stamp: 'tg 9/5/2010 20:50'! basePassiveBackgroundColor ^ Color r: 245 g: 245 b: 245 range: 255! ! !Pharo3Theme class methodsFor: 'accessing' stamp: 'TudorGirba 5/31/2012 22:51'! baseColor ^ Color r: 210 g: 210 b: 210 range: 255! ! !Pharo3Theme class methodsFor: 'accessing' stamp: 'tg 9/5/2010 21:46'! baseSelectionColor ^ Color r: 97 g: 163 b: 225 range: 255! ! !Pharo3Theme class methodsFor: 'accessing' stamp: 'TudorGirba 5/31/2012 22:35'! lightBaseColor ^ Color r: 230 g: 230 b: 230 range: 255! ! !Pharo3Theme class methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/10/2013 17:44'! themeName ^ 'Pharo3'! ! !Pharo3Theme class methodsFor: 'settings' stamp: 'TudorGirba 4/8/2011 00:13'! setPreferredWorldBackground "self setPreferredWorldBackground" World color: Color white! ! !Pharo3Theme class methodsFor: 'accessing' stamp: 'TudorGirba 11/29/2012 09:19'! veryLightSelectionColor ^ self lightSelectionColor muchLighter! ! !Pharo3Theme class methodsFor: 'settings' stamp: 'TudorGirba 4/2/2013 23:18'! newDefaultSettings self setPreferredPreferences. BalloonMorph setBalloonColorTo: self lightSelectionColor. ^super newDefaultSettings menuColor: self baseColor; menuTitleColor: self baseColor; windowColor: self baseColor; selectionColor: self lightSelectionColor; menuSelectionColor: self baseSelectionColor; progressBarColor: self baseColor; standardColorsOnly: true; autoSelectionColor: false; preferRoundCorner: false; fadedBackgroundWindows: false; secondarySelectionColor: self veryLightSelectionColor; flatMenu: true! ! !Pharo3UIThemeIcons commentStamp: 'TudorGirba 1/30/2011 22:49'! This class holds a set of icons to be used in the Glamorous UI Theme.! !Pharo3UIThemeIcons methodsFor: 'see class side' stamp: 'TudorGirba 1/30/2011 22:49'! seeClassSide! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:40'! radioButtonSelectedForm ^ self form16x16FromContents: self radioButtonSelectedFormContents! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowCloseForm ^ self form16x16FromContents: self windowCloseFormContents ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:40'! checkboxUnselectedForm ^ self form16x16FromContents: self checkboxUnselectedFormContents ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowMinimizeForm ^self form16x16FromContents: self windowMinimizeFormContents ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:26'! menuPinFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 83886080 100663296 83886080 0 0 0 0 0 0 0 0 0 0 0 0 1291845632 3774873600 4194304000 3774873600 788529152 0 0 0 0 0 0 0 0 0 0 1107296256 4278190080 4278190080 4278190080 4278190080 4278190080 788529152 0 0 0 0 0 0 0 0 83886080 3992977408 4278190080 4278190080 4278190080 4278190080 4278190080 3774873600 83886080 0 0 0 0 0 0 0 100663296 4194304000 4278190080 4278190080 4278190080 4278190080 4278190080 4194304000 100663296 0 0 0 0 0 0 0 83886080 3774873600 4278190080 4278190080 4278190080 4278190080 4278190080 3992977408 83886080 0 0 0 0 0 0 0 0 1291845632 4261412864 4278190080 4278190080 4278190080 4261412864 1107296256 0 0 0 0 0 0 0 0 0 0 1107296256 3992977408 4194304000 3774873600 1291845632 0 0 0 0 0 0 0 0 0 0 0 0 83886080 100663296 83886080 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 14:10'! checkboxSelectedFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4261412864 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4261412864 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4261412864 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4261412864 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:15'! windowMenuInactiveFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 360282489 3565191296 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 3565191296 360282489 0 0 0 0 0 0 0 360282489 3565191296 4286611584 4286611584 4286611584 4286611584 3565191296 360282489 0 0 0 0 0 0 0 0 0 360282489 3565191296 4286611584 4286611584 3565191296 360282489 0 0 0 0 0 0 0 0 0 0 0 377520256 3565191296 3565191296 360282489 0 0 0 0 0 0 0 0 0 0 0 0 0 377520256 360282489 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/27/2010 15:13'! radioUnselectedFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 50331648 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 1023410176 3238002688 3909091328 3909091328 3238002688 1023410176 0 0 0 0 0 0 0 0 0 2097152000 3976200192 1275068416 452984832 452984832 1275068416 3976200192 872415232 0 0 0 0 0 0 0 1023410176 4278190080 335544320 0 0 0 0 335544320 4278190080 1023410176 0 0 0 0 0 50331648 3238002688 1275068416 0 0 0 0 0 0 1275068416 3238002688 50331648 0 0 0 0 0 3909091328 452984832 0 0 0 0 0 0 452984832 3909091328 0 0 0 0 0 0 3909091328 452984832 0 0 0 0 0 0 452984832 3909091328 0 0 0 0 0 33554432 3238002688 1275068416 0 0 0 0 0 0 1275068416 3238002688 50331648 0 0 0 0 0 1006632960 3992977408 335544320 0 0 0 0 335544320 4278190080 1023410176 0 0 0 0 0 0 0 2097152000 4278190080 1275068416 452984832 452984832 1275068416 3976200192 2097152000 0 0 0 0 0 0 0 0 0 1006632960 3238002688 3909091328 3909091328 3238002688 1023410176 0 0 0 0 0 0 0 0 0 0 0 33554432 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:27'! radioButtonSelectedFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 50331648 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 1023410176 3422946822 4043572228 4043572228 3422946822 1023410176 0 0 0 0 0 0 0 0 0 2214987270 4161078533 4284045657 4285690482 4285690482 4284045657 4161078533 1058280468 0 0 0 0 0 0 0 1023410176 4278190080 4285887861 4286611584 4286611584 4286611584 4286611584 4285887861 4278190080 1023410176 0 0 0 0 0 50331648 3422946822 4284045657 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4284045657 3422946822 50331648 0 0 0 0 0 4043572228 4285690482 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4285690482 4043572228 0 0 0 0 0 0 4043572228 4285690482 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4285690482 4043572228 0 0 0 0 0 33554432 3422946822 4284045657 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4284045657 3422946822 50331648 0 0 0 0 0 1006632960 4161078533 4285887861 4286611584 4286611584 4286611584 4286611584 4285887861 4278190080 1023410176 0 0 0 0 0 0 0 2214987270 4278190080 4284045657 4285690482 4285690482 4284045657 4161078533 2214987270 0 0 0 0 0 0 0 0 0 1006632960 3422946822 4043572228 4043572228 3422946822 1023410176 0 0 0 0 0 0 0 0 0 0 0 33554432 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/27/2010 15:24'! windowCloseFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 167772160 0 0 0 0 0 0 0 0 167772160 3875536896 4076863488 234881024 0 234881024 2919235584 3858759680 0 0 0 0 0 0 0 0 402653184 3674210304 4261412864 3758096384 671088640 3758096384 4261412864 4278190080 335544320 0 0 0 0 0 0 0 0 352321536 3758096384 4143972352 4211081216 4143972352 3758096384 352321536 0 0 0 0 0 0 0 0 0 0 671088640 4211081216 4261412864 4211081216 671088640 0 0 0 0 0 0 0 0 0 0 352321536 3758096384 4143972352 4211081216 4143972352 3758096384 352321536 0 0 0 0 0 0 0 0 335544320 4278190080 4244635648 3758096384 671088640 3758096384 4143972352 3724541952 402653184 0 0 0 0 0 0 0 0 3892314112 2919235584 234881024 0 234881024 4278190080 1761607680 167772160 0 0 0 0 0 0 0 0 167772160 67108864 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/27/2010 15:13'! radioSelectedFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 50331648 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 1023410176 3422946822 4043572228 4043572228 3422946822 1023410176 0 0 0 0 0 0 0 0 0 2214987270 4161078533 4284045657 4285690482 4285690482 4284045657 4161078533 1058280468 0 0 0 0 0 0 0 1023410176 4278190080 4285887861 4286611584 4286611584 4286611584 4286611584 4285887861 4278190080 1023410176 0 0 0 0 0 50331648 3422946822 4284045657 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4284045657 3422946822 50331648 0 0 0 0 0 4043572228 4285690482 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4285690482 4043572228 0 0 0 0 0 0 4043572228 4285690482 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4285690482 4043572228 0 0 0 0 0 33554432 3422946822 4284045657 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4284045657 3422946822 50331648 0 0 0 0 0 1006632960 4161078533 4285887861 4286611584 4286611584 4286611584 4286611584 4285887861 4278190080 1023410176 0 0 0 0 0 0 0 2214987270 4278190080 4284045657 4285690482 4285690482 4284045657 4161078533 2214987270 0 0 0 0 0 0 0 0 0 1006632960 3422946822 4043572228 4043572228 3422946822 1023410176 0 0 0 0 0 0 0 0 0 0 0 33554432 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:40'! radioButtonUnselectedForm ^ self form16x16FromContents: self radioButtonUnselectedFormContents ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/27/2010 15:23'! windowMaximizeInactiveFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:52'! windowMenuFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 352321536 3556769792 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 3556769792 352321536 0 0 0 0 0 0 0 352321536 3556769792 4278190080 4278190080 4278190080 4278190080 3556769792 352321536 0 0 0 0 0 0 0 0 0 352321536 3556769792 4278190080 4278190080 3556769792 352321536 0 0 0 0 0 0 0 0 0 0 0 369098752 3556769792 3556769792 352321536 0 0 0 0 0 0 0 0 0 0 0 0 0 369098752 352321536 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/27/2010 15:23'! windowMinimizeInactiveFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:40'! menuPinForm ^self form16x16FromContents: self menuPinFormContents ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:26'! checkboxUnselectedFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4261412864 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4261412864 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4261412864 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4261412864 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowMaximizeInactiveForm ^ self form16x16FromContents: self windowMaximizeInactiveFormContents ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:07'! windowMaximizeFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/27/2010 15:23'! windowCloseInactiveFromContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 176193664 0 0 0 0 0 0 0 0 176193664 3883958400 4085284992 243302528 0 243302528 2927657088 3867181184 0 0 0 0 0 0 0 0 411074688 3682631808 4269834368 3766517888 679049593 3766517888 4269834368 4286611584 343965824 0 0 0 0 0 0 0 0 360282489 3766517888 4152328063 4219436927 4152393856 3766517888 360282489 0 0 0 0 0 0 0 0 0 0 679049593 4219436927 4269834368 4219436927 679049593 0 0 0 0 0 0 0 0 0 0 360282489 3766517888 4152393856 4219436927 4152328063 3766517888 360282489 0 0 0 0 0 0 0 0 343965824 4286611584 4253057152 3766517888 679049593 3766517888 4152328063 3732963456 411074688 0 0 0 0 0 0 0 0 3900735616 2927657088 243302528 0 243302528 4286611584 1769897598 176193664 0 0 0 0 0 0 0 0 176193664 75530368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowCloseInactiveForm ^ self form16x16FromContents: self windowCloseInactiveFromContents ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:39'! form16x16FromContents: aByteArray ^ Form extent: 16@16 depth: 32 fromArray: aByteArray offset: 0@0! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowMaximizeForm ^ self form16x16FromContents: self windowMaximizeFormContents ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:22'! checkboxMarkerForm "Answer a new radio button marker form. We make it empty because we already have the selected radio button take care of the state." ^Form extent: 12@12 depth: 32! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/27/2010 15:14'! radioSelectedForm ^ Form fromBinaryStream: ( Base64MimeConverter mimeDecodeToBytes: self radioSelectedFormContents readStream) ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:52'! windowMenuForm ^self form16x16FromContents: self windowMenuFormContents ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/27/2010 15:14'! radioUnselectedForm ^ Form fromBinaryStream: ( Base64MimeConverter mimeDecodeToBytes: self radioUnselectedFormContents readStream) ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 14:10'! checkboxSelectedForm ^ self form16x16FromContents: self checkboxSelectedFormContents ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:27'! radioButtonUnselectedFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 50331648 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 1023410176 3238002688 3909091328 3909091328 3238002688 1023410176 0 0 0 0 0 0 0 0 0 2097152000 3976200192 1275068416 452984832 452984832 1275068416 3976200192 872415232 0 0 0 0 0 0 0 1023410176 4278190080 335544320 0 0 0 0 335544320 4278190080 1023410176 0 0 0 0 0 50331648 3238002688 1275068416 0 0 0 0 0 0 1275068416 3238002688 50331648 0 0 0 0 0 3909091328 452984832 0 0 0 0 0 0 452984832 3909091328 0 0 0 0 0 0 3909091328 452984832 0 0 0 0 0 0 452984832 3909091328 0 0 0 0 0 33554432 3238002688 1275068416 0 0 0 0 0 0 1275068416 3238002688 50331648 0 0 0 0 0 1006632960 3992977408 335544320 0 0 0 0 335544320 4278190080 1023410176 0 0 0 0 0 0 0 2097152000 4278190080 1275068416 452984832 452984832 1275068416 3976200192 2097152000 0 0 0 0 0 0 0 0 0 1006632960 3238002688 3909091328 3909091328 3238002688 1023410176 0 0 0 0 0 0 0 0 0 0 0 33554432 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 09:11'! radioButtonMarkerForm "Answer a new radio button marker form. We make it empty because we already have the selected radio button take care of the state." ^Form extent: 12@12 depth: 32! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowMenuInactiveForm ^self form16x16FromContents: self windowMenuInactiveFormContents ! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:09'! windowMinimizeFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !Pharo3UIThemeIcons class methodsFor: 'icons' stamp: 'FernandoOlivero 10/28/2010 13:42'! windowMinimizeInactiveForm ^self form16x16FromContents: self windowMinimizeInactiveFormContents ! ! !PharoChangesCondenser commentStamp: 'CamilloBruni 2/21/2014 22:29'! I create a new more compact changes files with a single version of each method in the image.! !PharoChangesCondenser methodsFor: 'helper' stamp: 'CamilloBruni 2/21/2014 23:40'! nextChunkDo: aBlock stream nextChunkPut: (String streamContents: aBlock)! ! !PharoChangesCondenser methodsFor: 'private - 1 writing' stamp: 'CamilloBruni 2/23/2014 21:39'! stampOfMethod: aMethod "Optimized version of: aMethod stamp Reuse the same stream instead of reopening a new stream on each read" ^ aMethod timeStampFromFile: (self sourceStreamOfMethod: aMethod).! ! !PharoChangesCondenser methodsFor: 'private - 1 writing' stamp: 'CamilloBruni 2/23/2014 21:52'! sourceCodeOfMethod: aMethod "Optimized version of: aMethod sourceCode Reuse the same stream instead of reopening a new stream on each read" ^ (self sourceStreamOfMethod: aMethod) nextChunk! ! !PharoChangesCondenser methodsFor: 'private - 2 swapping' stamp: 'CamilloBruni 2/22/2014 00:26'! swapSourcePointers job title: 'Swapping source pointers'; currentValue: 0. Smalltalk allClassesAndTraitsDo: [ :classOrTrait | job increment. self swapSourcePointerOfClassOrTrait: classOrTrait ] ! ! !PharoChangesCondenser methodsFor: 'accessing' stamp: 'CamilloBruni 2/23/2014 20:36'! temporaryFile ^ (Smalltalk changesFile, 'new') nextVersion.! ! !PharoChangesCondenser methodsFor: 'private' stamp: 'Camillobruni 4/28/2014 16:51'! condenseClassOrTrait: classOrTrait self writeClassComment: classOrTrait. classOrTrait theNonMetaClass methodsDo: [ :method | (self shouldCondenseMethod: method) ifTrue: [ self writeMethodSource: method ]]. classOrTrait theMetaClass methodsDo: [ :method | (self shouldCondenseMethod: method) ifTrue: [ self writeMethodSource: method ]]! ! !PharoChangesCondenser methodsFor: 'private - 2 swapping' stamp: 'MarcusDenker 4/29/2014 10:56'! swapSourcePointerOfClassOrTrait: classOrTrait self swapClassComment: classOrTrait. classOrTrait methodsDo: [ :method | self swapSourcePointerOfMethod: method ]. classOrTrait classSide methodsDo: [ :method | self swapSourcePointerOfMethod: method ]! ! !PharoChangesCondenser methodsFor: 'private - 3 installing' stamp: 'CamilloBruni 2/23/2014 20:35'! backupOldChanges | changesFile | changesFile := self originalFile. changesFile moveTo: (changesFile , 'bak') nextVersion. ! ! !PharoChangesCondenser methodsFor: 'public' stamp: 'CamilloBruni 2/22/2014 00:14'! condense job := [ newChangesFile writeStreamDo: [ :aStream | stream := aStream. self basicCondense ]] asJob. job title: 'Condensing Changes'; max: Smalltalk classNames size + Smalltalk traitNames size; run.! ! !PharoChangesCondenser methodsFor: 'accessing' stamp: 'CamilloBruni 2/23/2014 20:32'! fileIndex "Return the index into the SourceFiles: 1: the .sources file 2. the .changes file" ^ 2! ! !PharoChangesCondenser methodsFor: 'initialization' stamp: 'CamilloBruni 2/23/2014 20:34'! initialize self reset.! ! !PharoChangesCondenser methodsFor: 'private - 3 installing' stamp: 'CamilloBruni 2/23/2014 21:27'! installNewChangesFile (SourceFiles at: self fileIndex) close. self updateQuitPosition. stream flush close. self backupOldChanges. self originalFile ensureDelete. newChangesFile moveTo: self originalFile . Smalltalk openSourceFiles.! ! !PharoChangesCondenser methodsFor: 'private - 2 swapping' stamp: 'CamilloBruni 2/23/2014 20:30'! swapClassComment: classOrTrait remoteStringMap at: classOrTrait ifPresent: [ :remoteString | classOrTrait organization comment: remoteString ]! ! !PharoChangesCondenser methodsFor: 'helper' stamp: 'CamilloBruni 2/21/2014 23:44'! nextCommentChunkDo: aBlock stream cr; nextPut: $!!. self nextChunkDo: aBlock. stream cr! ! !PharoChangesCondenser methodsFor: 'private - testing' stamp: 'CamilloBruni 2/23/2014 20:27'! shouldCondenseMethod: aMethod "Only write methods with changes in the current file (not .sources)" ^ aMethod hasSourceCodeInChangesFile! ! !PharoChangesCondenser methodsFor: 'private - 1 writing' stamp: 'CamilloBruni 2/23/2014 21:40'! sourceStreamOfMethod: aMethod | aStream | aStream := sourceStreams at: aMethod fileIndex. aStream position: aMethod filePosition. ^ aStream ! ! !PharoChangesCondenser methodsFor: 'private' stamp: 'CamilloBruni 2/21/2014 23:25'! condenseClassesAndTraits Smalltalk allClassesAndTraitsDo: [ :classOrTrait | self condenseClassOrTrait: classOrTrait ] ! ! !PharoChangesCondenser methodsFor: 'initialization' stamp: 'CamilloBruni 2/23/2014 21:40'! reset. remoteStringMap := IdentityDictionary new. newChangesFile := self temporaryFile. "Keep a copy of the source streams for performance" sourceStreams := Array with: PharoFilesOpener default sourcesFileOrNil with: PharoFilesOpener default changesFileOrNil! ! !PharoChangesCondenser methodsFor: 'private - 1 writing' stamp: 'MarcusDenker 4/29/2014 10:45'! writeClassComment: aClass | organizer commentRemoteString stamp | organizer := aClass organization. commentRemoteString := organizer commentRemoteStr. (commentRemoteString isNil or: [ commentRemoteString sourceFileNumber = 1 ]) ifTrue: [ ^ self ]. self nextCommentChunkDo: [ :strm | strm nextPutAll: aClass name; nextPutAll: ' commentStamp: '. stamp := organizer commentStamp ifNil: ['']. stamp storeOn: strm ]. self writeRemoteString: organizer classComment for: aClass! ! !PharoChangesCondenser methodsFor: 'private' stamp: 'CamilloBruni 2/23/2014 20:33'! basicCondense self condenseClassesAndTraits; swapSourcePointers; installNewChangesFile; reset! ! !PharoChangesCondenser methodsFor: 'private - 1 writing' stamp: 'Camillobruni 4/28/2014 16:44'! writeMethodSource: aMethod self nextCommentChunkDo: [ :strm | strm nextPutAll: aMethod methodClass name; nextPutAll: ' methodsFor: '; store: aMethod category asString; nextPutAll: ' stamp: '; store: (self stampOfMethod: aMethod) ]. self writeRemoteString: (self sourceCodeOfMethod: aMethod) for: aMethod. stream nextPutAll: ' !!'; cr.! ! !PharoChangesCondenser methodsFor: 'private - 3 installing' stamp: 'CamilloBruni 2/23/2014 20:39'! updateQuitPosition Smalltalk lastQuitLogPosition: stream position.! ! !PharoChangesCondenser methodsFor: 'private - 2 swapping' stamp: 'CamilloBruni 2/22/2014 00:36'! swapSourcePointerOfMethod: method remoteStringMap at: method ifPresent: [ :remoteString | method setSourcePointer: remoteString sourcePointer ]! ! !PharoChangesCondenser methodsFor: 'accessing' stamp: 'CamilloBruni 2/23/2014 20:35'! originalFile ^ Smalltalk changesFile! ! !PharoChangesCondenser methodsFor: 'private - 1 writing' stamp: 'CamilloBruni 2/23/2014 20:30'! writeRemoteString: aString for: reference | remoteString | remoteString := RemoteString newString: aString onFileNumber: self fileIndex toFile: stream. remoteStringMap at: reference put: remoteString. ^ remoteString! ! !PharoChangesCondenser class methodsFor: 'helper' stamp: 'CamilloBruni 2/22/2014 00:07'! condense ^ self new condense! ! !PharoClassInstaller commentStamp: ''! I am the default class installer. I install a new or modified class in the globals dictionary and announce this change publicly. The default environment can be changed to any SystemDictionary. Example: PharoClassInstaller example! !PharoClassInstaller methodsFor: 'notifications' stamp: 'MartinDias 6/28/2013 12:50'! classAdded: aClass inCategory: aCategory " Install the new class in the system " environment at: aClass name put: aClass. environment flushClassNameCache. " Update the system's organization " environment organization classify: aClass name under: aCategory. aClass environment: environment. self systemAnnouncer classAdded: aClass inCategory: aCategory. " Inform superclass of new subclass " aClass superclass addSubclass: aClass.! ! !PharoClassInstaller methodsFor: 'migrating' stamp: 'MartinDias 7/1/2013 15:59'! updateInstancesFrom: old to: new | oldInstances variable instSize newInstances map | oldInstances := old allInstances asArray. variable := new isVariable. instSize := new instSize. newInstances := Array new: oldInstances size. map := new instVarMappingFrom: old. 1 to: oldInstances size do: [ :i | newInstances at: i put: ( new newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map) ]. oldInstances elementsForwardIdentityTo: newInstances.! ! !PharoClassInstaller methodsFor: 'migrating' stamp: 'CamilleTeruel 12/18/2013 13:56'! fixClassBindings: newClass methodUpdateStrategy updateClassLiteralKeysIn: newClass! ! !PharoClassInstaller methodsFor: 'migrating' stamp: 'ToonVerwaest 3/22/2011 18:54'! shallowCopyMethodsFrom: oldClass to: newClass using: classModification newClass methodDict: oldClass methodDict! ! !PharoClassInstaller methodsFor: 'notifications' stamp: 'MartinDias 1/28/2014 15:18'! slotsChangedFrom: oldClass to: newClass by: classModification self classDefinitionChangedFrom: oldClass to: newClass by: classModification! ! !PharoClassInstaller methodsFor: 'private' stamp: 'MartinDias 4/26/2013 17:07'! systemAnnouncer ^ SystemAnnouncer uniqueInstance! ! !PharoClassInstaller methodsFor: 'accessing' stamp: 'ToonVerwaest 3/22/2011 17:03'! classAt: aName ifAbsent: aBlock ^ (environment at: aName ifAbsent: aBlock) ifNil: aBlock! ! !PharoClassInstaller methodsFor: 'notifications' stamp: 'MartinDias 1/28/2014 16:13'! classDefinitionChangedFrom: oldClass to: newClass by: classModification self copyMethodsFrom: oldClass to: newClass using: classModification; basicClassDefinitionChangedFrom: oldClass to: newClass using: classModification; fixClassBindings: newClass ! ! !PharoClassInstaller methodsFor: 'accessing' stamp: 'CamilloBruni 6/28/2013 14:03'! environment ^ environment! ! !PharoClassInstaller methodsFor: 'notifications' stamp: 'MartinDias 1/28/2014 16:13'! shallowClassDefinitionChangedFrom: oldClass to: newClass by: classModification " Copy over the method organization " " Update the superclass links " self shallowCopyMethodsFrom: oldClass to: newClass using: classModification; basicClassDefinitionChangedFrom: oldClass to: newClass using: classModification! ! !PharoClassInstaller methodsFor: 'initialization' stamp: 'MartinDias 7/30/2012 00:03'! initialize super initialize. environment := nil environment. methodUpdateStrategy := MethodRecompileStrategy new.! ! !PharoClassInstaller methodsFor: 'notifications' stamp: 'MartinDias 7/1/2013 15:56'! formatChangedFrom: oldClass to: newClass by: classModification self classDefinitionChangedFrom: oldClass to: newClass by: classModification ! ! !PharoClassInstaller methodsFor: 'notifications' stamp: 'EstebanLorenzano 4/11/2014 15:52'! basicClassDefinitionChangedFrom: oldClass to: newClass using: classModification " Copy over the trait composition " self copyTraitCompositionFrom: oldClass to: newClass. " Copy over the method organization " newClass organization: oldClass organization. " Update the subclass links " oldClass superclass == newClass superclass ifFalse: [ oldClass superclass removeSubclass: oldClass. newClass superclass addSubclass: newClass ]. " Announce if necessary " classModification isPropagation ifFalse: [ self systemAnnouncer classDefinitionChangedFrom: oldClass to: newClass ].! ! !PharoClassInstaller methodsFor: 'accessing' stamp: 'ToonVerwaest 3/22/2011 16:55'! environment: anEnvironment environment := anEnvironment! ! !PharoClassInstaller methodsFor: 'migrating' stamp: 'CamilleTeruel 4/4/2014 16:18'! updateClass: oldClass to: newClass newClass layout compactClassIndex: oldClass layout compactClassIndex. self updateInstancesFrom: oldClass to: newClass! ! !PharoClassInstaller methodsFor: 'migrating' stamp: 'MartinDias 7/1/2013 15:58'! migrateClasses: old to: new using: anInstanceModification instanceModification := anInstanceModification. old ifEmpty: [ ^ self ]. [ 1 to: old size do: [ :index | self updateClass: (old at: index) to: (new at: index)]. old elementsForwardIdentityTo: new. " Garbage collect away the zombie instances left behind in garbage memory in #updateInstancesFrom: " " If we don't clean up this garbage, a second update would revive them with a wrong layout!! " " (newClass rather than oldClass, since they are now both newClass) " Smalltalk garbageCollect. ] valueUnpreemptively! ! !PharoClassInstaller methodsFor: 'notifications' stamp: 'MartinDias 7/1/2013 15:55'! superclassChangedFrom: oldClass to: newClass by: classModification self shallowClassDefinitionChangedFrom: oldClass to: newClass by: classModification ! ! !PharoClassInstaller methodsFor: 'migrating' stamp: 'MartinDias 7/30/2012 00:08'! copyMethodsFrom: oldClass to: newClass using: classModification methodUpdateStrategy transform: oldClass to: newClass using: classModification methodModification! ! !PharoClassInstaller methodsFor: 'notifications' stamp: 'SebastianTleye 8/26/2013 16:23'! recategorize: aClass to: newCategory | oldCategory | oldCategory := aClass category. oldCategory asSymbol == newCategory asSymbol ifTrue: [ ^ self ]. environment organization classify: aClass name under: newCategory. self systemAnnouncer class: aClass recategorizedFrom: oldCategory to: newCategory! ! !PharoClassInstaller class methodsFor: 'example' stamp: 'MartinDias 7/1/2013 16:10'! example ^ PharoClassInstaller make: [ :aSlotClassBuilder | aSlotClassBuilder superclass: Object; name: #MyClass; slots: #(varA varB); category: 'My-Category' ].! ! !PharoClassInstaller class methodsFor: 'testing' stamp: 'MartinDias 11/6/2012 11:32'! validateClassName: aString "Validate if a string can be the name of a new class. Raise an error if not." self new builder name: aString.! ! !PharoCommandLineHandler commentStamp: ''! Usage: [--no-preferences|--preference-file=][] [--help] [--copyright] [--version] [--list] [ --no-quit ] --help print this help message --copyright print the copyrights --version print the version for the image and the vm --list list a description of all active command line handlers --no-quit keep the image running without activating any other command line handler a valid subcommand in --list Preference File Modification: --preference-file load the preferences from the given --no-default-preferences do not load any preferences from the default locations Documentation: A PharoCommandLineHandler handles default command line arguments and options. The PharoCommandLineHandler is activated before all other handlers. It first checks if another handler is available. If so it will activate the found handler.! !PharoCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 9/16/2013 01:23'! activate self isChangingPreferences ifTrue: [ self changePreferences ] ifFalse: [ self runPreferences ]. ^ super activate.! ! !PharoCommandLineHandler methodsFor: 'commands' stamp: 'CamilloBruni 5/26/2013 14:08'! default Smalltalk isHeadless ifFalse: [ ^ self noQuit ]. ^ super default! ! !PharoCommandLineHandler methodsFor: 'private - preferences' stamp: 'CamilloBruni 9/16/2013 01:15'! isChangingPreferences ^ self isOverridingPreferences or: [ self isOmittingPreferences ]! ! !PharoCommandLineHandler methodsFor: 'private - preferences' stamp: 'SeanDeNigris 10/4/2013 13:15'! isOmittingPreferences ^ self hasOption: 'no-default-preferences'! ! !PharoCommandLineHandler methodsFor: 'private - preferences' stamp: 'CamilloBruni 9/16/2013 01:36'! isOverridingPreferences ^ self hasOption: 'preferences-file'! ! !PharoCommandLineHandler methodsFor: 'private - preferences' stamp: 'CamilloBruni 9/16/2013 01:18'! runPreferences StartupPreferencesLoader default loadFromDefaultLocations! ! !PharoCommandLineHandler methodsFor: 'private - preferences' stamp: 'CamilloBruni 9/16/2013 01:37'! changePreferences | preferenceFile | self isOmittingPreferences ifTrue: [ commandLine := commandLine copySubcommand. ^ self ]. preferenceFile := (self optionAt: 'preferences-file') asFileReference. commandLine := commandLine copySubcommand. StartupPreferencesLoader default load: { preferenceFile }.! ! !PharoCommandLineHandler class methodsFor: 'handler selection' stamp: 'EstebanLorenzano 5/23/2013 15:15'! isResponsibleFor: aCommandLine "I do not match ever, because my activation is manual" ^ true! ! !PharoCommandLineHandler class methodsFor: 'instance creation' stamp: 'AlainPlantec 7/9/2013 12:39'! activateWith: aCommandLine Smalltalk tools userManager canRunStartupScript ifFalse: [ ^ self ]. "Make sure that the PharoCommandLineHandler starts at the top of the stack in the main UI thread." UIManager default defer: [ super activateWith: aCommandLine ]! ! !PharoCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 5/31/2013 11:32'! priority "Highest priority" ^ Float infinity! ! !PharoCommandLineHandler class methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/23/2013 14:28'! description ^ 'responsible for the default options and activating other commands'! ! !PharoFilesOpener commentStamp: ''! My role is to open the .sources and .changes files. My only public methods are in the 'public' protocol. The most important method is #checkAndOpenSourcesAndChanges.! !PharoFilesOpener methodsFor: 'messages' stamp: 'DamienCassou 8/15/2013 11:28'! badContentMsg ^ '&fileRef has been injured by an unpacking utility. Crs were changed to CrLfs. Please set the preferences in your decompressing program to "do not convert text files" and unpack the system again.'! ! !PharoFilesOpener methodsFor: 'public' stamp: 'DamienCassou 8/16/2013 10:34'! setInformAboutReadOnlyChanges "Make sure the user is informed when the .changes file can not be written to." shouldInformAboutReadOnlyChanges := true! ! !PharoFilesOpener methodsFor: 'open sources' stamp: 'DamienCassou 8/15/2013 11:18'! informCannotLocateSources | msg | msg := self cannotLocateMsg. Smalltalk os isMacOS ifTrue: [ msg := msg , ' Make sure the sources file is not an Alias.' ]. self inform: msg withSourceRef: self sourcesName! ! !PharoFilesOpener methodsFor: 'delegated' stamp: 'DamienCassou 8/15/2013 10:06'! lastImagePath ^ Smalltalk lastImagePath! ! !PharoFilesOpener methodsFor: 'public' stamp: 'MartinDias 11/4/2013 17:27'! changesFileOrNil | changes | changes := self openChanges: self changesName. changes ifNil: [ self informProblemInChanges: self cannotLocateMsg. ^ nil ]. (changes isReadOnly and: [ self shouldInformAboutReadOnlyChanges ]) ifTrue: [ self informProblemInChanges: self cannotWriteMsg ]. ((changes next: 200) includesSubstring: String crlf) ifTrue: [ self informProblemInChanges: self badContentMsg ]. ^ changes! ! !PharoFilesOpener methodsFor: 'public' stamp: 'MartinDias 11/4/2013 17:27'! sourcesFileOrNil | sources | sources := self openOrDownloadSources. ^ (sources isNil or: [ sources atEnd ]) ifTrue: [ self informCannotLocateSources. nil ] ifFalse: [ sources ]! ! !PharoFilesOpener methodsFor: 'messages' stamp: 'DamienCassou 8/15/2013 10:16'! cannotWriteMsg ^ 'Pharo cannot write to &fileRef. Please check that you have write permission for this file. You won''t be able to save this image correctly until you fix this.'! ! !PharoFilesOpener methodsFor: 'open sources' stamp: 'SvenVanCaekenberghe 1/19/2014 19:08'! openSources: fullSourcesName forImage: imagePath "Look in various places for a sources file, return an open stream to it." | sourcesFile sourcesName | sourcesFile := fullSourcesName asFileReference. sourcesName := sourcesFile basename. "look for the sources file or an alias to it in the VM's directory" OSPlatform current potentialLocationsOfSourcesFile do: [ :dir | self ignoreIfFail: [ (sourcesFile := dir / sourcesName) exists ifTrue: [ sourcesFile readStream ifNotNil: [ :stream | ^ stream ] ] ] ]. "look for the sources file or an alias to it in the image directory" (sourcesFile := imagePath asFileReference parent / sourcesName) exists ifTrue: [ ^ sourcesFile readStream ifNotNil: [ :stream | ^ stream ] ]. "look for the sources in the current directory" (sourcesFile := sourcesName asFileReference) exists ifTrue: [ ^ sourcesFile readStream ifNotNil: [ :stream | ^ stream ] ]. ^ nil! ! !PharoFilesOpener methodsFor: 'user interaction' stamp: 'DamienCassou 8/15/2013 10:19'! inform: msg withRef: fileRef self inform: (msg copyReplaceAll: '&fileRef' with: fileRef)! ! !PharoFilesOpener methodsFor: 'public' stamp: 'DamienCassou 8/16/2013 10:33'! shouldInformAboutReadOnlyChanges "Answer true if and only if the user must be informed when the .changes file can not be written to." ^ shouldInformAboutReadOnlyChanges ifNil: [ shouldInformAboutReadOnlyChanges := true ]! ! !PharoFilesOpener methodsFor: 'public' stamp: 'DamienCassou 8/16/2013 10:34'! unsetInformAboutReadOnlyChanges "Make sure the user is *not* informed when the .changes file can not be written to." shouldInformAboutReadOnlyChanges := false! ! !PharoFilesOpener methodsFor: 'delegated' stamp: 'DamienCassou 8/15/2013 10:05'! changesName ^ Smalltalk changesName! ! !PharoFilesOpener methodsFor: 'user interaction' stamp: 'DamienCassou 8/15/2013 11:30'! inform: msg withChangesRef: fileRef self inform: msg withRef: 'the changes file named ' , fileRef! ! !PharoFilesOpener methodsFor: 'user interaction' stamp: 'DamienCassou 8/15/2013 11:30'! informProblemInChanges: msg self inform: msg withChangesRef: self changesName! ! !PharoFilesOpener methodsFor: 'delegated' stamp: 'DamienCassou 8/15/2013 10:07'! sourcesName ^ Smalltalk sourcesName! ! !PharoFilesOpener methodsFor: 'messages' stamp: 'DamienCassou 8/15/2013 10:15'! cannotLocateMsg ^ 'Pharo cannot locate &fileRef. Please check that the file is named properly and is in the same directory as this image.'! ! !PharoFilesOpener methodsFor: 'open sources' stamp: 'DamienCassou 8/15/2013 10:44'! openOrDownloadSources | sources | (sources := self openSources) ifNil: [ [ Smalltalk downloadSources "this method only exists when Zinc is loaded" ] on: MessageNotUnderstood do: [ ^ nil ]. sources := self openSources ]. ^ sources! ! !PharoFilesOpener methodsFor: 'open changes' stamp: 'DamienCassou 9/13/2013 16:16'! openChanges: changesPath | fileColocatedWithImage fileInWorkingDirectory locations | fileColocatedWithImage := changesPath asFileReference. fileInWorkingDirectory := FileSystem workingDirectory / fileColocatedWithImage basename. "locations references all possible path where to search for the .changes file." locations := Array with: fileColocatedWithImage with: fileInWorkingDirectory. "We first try to open a writeStream and, if we can't, we open a readStream. We have to use #ignoreIfFail: here because Pharo has no way to really tell us beforehand if opening a writeStream will work. Sending #isWritable is not enough because #isWritable does not check if the current user is the owner of the file or not." locations do: [ :file | self ignoreIfFail: [ ^ file writeStream ] ]. locations do: [ :file | self ignoreIfFail: [ ^ file readStream ] ]. ^ nil! ! !PharoFilesOpener methodsFor: 'open sources' stamp: 'DamienCassou 8/15/2013 10:38'! openSources ^ self openSources: self sourcesName forImage: self lastImagePath! ! !PharoFilesOpener methodsFor: 'helper' stamp: 'DamienCassou 9/13/2013 16:16'! ignoreIfFail: aBlock ^ [ aBlock value ] ifError: [ ]! ! !PharoFilesOpener methodsFor: 'user interaction' stamp: 'DamienCassou 8/15/2013 11:30'! inform: msg withSourceRef: fileRef self inform: msg withRef: 'the sources file named ' , fileRef! ! !PharoFilesOpener class methodsFor: 'singleton' stamp: 'DamienCassou 8/16/2013 10:04'! reset Default := nil! ! !PharoFilesOpener class methodsFor: 'singleton' stamp: 'DamienCassou 8/16/2013 10:04'! default ^ Default ifNil: [ Default := PharoFilesOpener new ]! ! !PharoSourcesCondenser commentStamp: 'CamilloBruni 2/23/2014 20:30'! I create a more compact version of the .sources file. I move the source code from all methods to a new .sources file where I keep only one version. Additionally I will empty the current .changes file.! !PharoSourcesCondenser methodsFor: 'accessing' stamp: 'CamilloBruni 2/23/2014 20:37'! temporaryFile ^ 'new.sources' asFileReference nextVersion! ! !PharoSourcesCondenser methodsFor: 'private - 3 installing' stamp: 'CamilloBruni 2/23/2014 20:45'! installFreshChangesFile | changesFile | "install a new .changes file" changesFile := Smalltalk changesFile. changesFile moveTo: (changesFile , 'bak') nextVersion. "create a fresh changes file " changesFile writeStreamDo: [ :strm | strm timeStamp ].! ! !PharoSourcesCondenser methodsFor: 'private - 3 installing' stamp: 'CamilloBruni 2/23/2014 20:39'! updateQuitPosition "We use an empty .changes file, hence the last quit position is 0" Smalltalk lastQuitLogPosition: 0.! ! !PharoSourcesCondenser methodsFor: 'accessing' stamp: 'CamilloBruni 2/23/2014 20:37'! originalFile ^ Smalltalk sourcesFile! ! !PharoSourcesCondenser methodsFor: 'private - 3 installing' stamp: 'CamilloBruni 2/23/2014 20:41'! backupOldChanges super backupOldChanges. self installFreshChangesFile.! ! !PharoSourcesCondenser methodsFor: 'private - testing' stamp: 'CamilloBruni 2/23/2014 21:52'! shouldCondenseMethod: aCompiledMethod "The sources condenser moves ALL method sources to a new file" ^ aCompiledMethod hasSourcePointer! ! !PharoSourcesCondenser methodsFor: 'accessing' stamp: 'CamilloBruni 2/23/2014 21:21'! fileIndex "We are working on the .sources file which has index = 1" ^ 1! ! !PharoSourcesCondenser methodsFor: 'public' stamp: 'CamilloBruni 2/23/2014 21:12'! newSourceVersion: version "Create a new version of the .soruces file by copying the existing file to a new location" | originalSourcesFile newSourcesFile | "Create a copy with the new name" originalSourcesFile := self originalFile resolve. Smalltalk sourceFileVersionString: 'PharoV', version asString. newSourcesFile := Smalltalk sourcesFile. originalSourcesFile copyTo: newSourcesFile. "Use the new sources file" Smalltalk openSourceFiles.! ! !PharoSourcesCondenser class methodsFor: 'helper' stamp: 'CamilloBruni 2/23/2014 21:04'! condenseNewSources | condenser | condenser := self new. condenser newSourceVersion: (SystemVersion current major) * 10. condenser condense.! ! !PharoSyntaxTutorial commentStamp: 'CamilloBruni 2/22/2014 19:04'! The default Pharo tutorial to learn the Pharo syntax! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:50'! messageSyntaxExecutionOrderParentheses ^ Lesson title: 'Message syntax: Parentheses' lesson: '"Use parentheses to change order of evaluation" (2 + 3) squared. (2 raisedTo: 3) + 2. (0@0 extent: 100@200) bottomRight. PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:49'! blocks ^ Lesson title: 'Blocks' lesson: '"Cascade is cool !! Let''s talk about blocks. Blocks are anonymous methods that can be stored into variables and executed on demand. Blocks are delimited by square brackets: []" [Browser open]. "does not open a Browser because the block is not executed. Here is a block that adds 2 to its argument (its argument is named x):" [:x | x+2]. "We can execute a block by sending it value messages." [:x | x+2] value: 5. [Browser open] value. [:x | x+2] value: 10. [:x :y| x + y] value:3 value:5. [PharoTutorial next] value.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 19:04'! pharoEnvironment ^ Lesson title: 'Pharo environment' lesson: '"Pharo is full of objects. There are windows, text, numbers, dates, colors, points and much more. You can interact with objects in a much more direct way than is possible with other programming languages. Every object understands the message ''explore''. As a result, you get an Explorer window that shows details about the object." Date today explore. "This shows that the date object consists of a point in time (start) and a duration (one day long)." PharoTutorial explore. "You see, PharoTutorial class has a lot of objects. Let''s take a look at my code:" PharoTutorial browse. PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:51'! reflectionContinued ^ Lesson title: 'Reflection continued' lesson: '"So cool, isn''t it ? Before going further, let''s remove this method:" PharoTutorial respondsTo: #goToNextLesson. PharoTutorial class removeSelector: #goToNextLesson. PharoTutorial respondsTo: #goToNextLesson. "Then move forward:" PharoTutorial default executeMethod: (PharoTutorial lookupSelector:#next).'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:53'! mathematicalPrecedence ^ Lesson title: 'Mathematical precedence' lesson: '"Traditional precedence rules from mathematics do not apply in Pharo." 2 * 10 + 2. "Here the message * is sent to 2, which answers 20, then 20 receive the message + Remember that all messages always follow a simple left-to-right precedence rule, * without exceptions *." 2 + 2 * 10. 2 + (2 * 10). 8 - 5 / 2. (8 - 5) / 2. 8 - (5 / 2). PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:48'! basicTypesDynamicArray ^ Lesson title: 'Basic types: Dynamic Array' lesson: '"Dynamic Arrays are created at execution time:" { (2+3) . (6*6) }. { (2+3) . (6*6) . ''hello'', '' Stef''} size. { PharoTutorial } first next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:50'! messageSyntaxBinary ^ Lesson title: 'Message syntax: Binary messages' lesson: '"Binary messages have the following form: anObject + anotherObject" 3 * 2. Date today + 3 weeks. false | false. true & true. true & false. 10 @ 100. 10 <= 12. ''ab'', ''cd''. Date today < Date yesterday. PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:48'! basicTypesCharacters ^ Lesson title: 'Basic types: Characters' lesson: '"A Character can be instantiated using $ operator:" $A. $A class. $B charCode. Character cr. Character space. "You can print all 256 characters of the ASCII extended set:" Character allByteCharacters. PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'initialize-release' stamp: 'LaurentLaffont 12/12/2010 17:18'! initialize super initialize. self prepareDebuggerExample.! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:49'! blocksAssignation ^ Lesson title: 'Block assignation' lesson: '"Blocks can be assigned to a variable then executed later. Note that |b| is the declaration of a variable named ''b'' and that '':='' assigns a value to a variable. Select the three lines then Print It:" |b| b := [:x | x+2]. b value: 12. PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:51'! printing ^ Lesson title: 'Doing VS Printing: Printing' lesson: '"Now you''re a Do It master !! Let''s talk about printing. It''s a Do It which prints the result next to the expression you''ve selected. For example, select the text below, open the menu and click on ''print it (p)'':" 1 + 2. "You''ve seen the letter ''p'' between parentheses next to ''print it'' ? It indicates the ALT- shortcut to execute this command. Try ALT-p on the following expressions:" Date today. Time now. "The result is selected, so you can erase it using the backspace key. Try it !!" SmalltalkImage current datedVersion. PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:53'! theEnd ^ Lesson title: 'Tutorial done !!' lesson: '"This tutorial is done. Enjoy programming with Pharo. Don''t forget to read ''Pharo By Example'' found here: http://pharo-project.org/PharoByExample. You can run this tutorial again by evaluating: PharoTutorial go. Do you want to create your own interactive tutorial with PharoTutorial ? That''s very easy!!!! How ? There''s a PharoTutorial interactive tutorial for that :D Just evaluate the following code: PharoTutorial goOn: HowToMakeYourOwnTutorial See you soon !!" '! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:52'! debugger ^ Lesson title: 'Debugger' lesson: '"The Debugger may be the most famous tool of Smalltalk environments. It will open as soon as an unmanaged Exception occurs. The following code will open the debugger on the message stack, select PharoSyntaxTutorial>>divideTwoByZero". PharoSyntaxTutorial new divideTwoByZero. '! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:50'! messageSyntaxCascade ^ Lesson title: 'Message syntax: Cascade' lesson: '"; is the cascade operator. It''s useful to send message to the SAME receiver Open a Transcript (console):" Transcript open. "Then:" Transcript show: ''hello''. Transcript show: ''Pharo''. Transcript cr. "is equivalent to:" Transcript show: ''hello''; show: ''Pharo'' ; cr. "Try to go to the next lesson with a cascade of two ''next'' messages:" PharoTutorial'.! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:49'! basicTypesString ^ Lesson title: 'Basic types: Strings' lesson: '"A String is a collection of characters. Use single quotes to create a String object. Print these expressions:" ''PharoTutorial''. ''PharoTutorial'' size. ''abc'' asUppercase. ''Hello World'' reverse. "You can access each character using at: message" ''PharoTutorial'' at: 1. "String concatenation uses the comma operator:" ''PharoTutorial'', '' is cool''. PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:49'! basicTypesSymbol ^ Lesson title: 'Basic types: Symbols' lesson: '"A Symbol is a String which is guaranteed to be globally unique. There is one and only one Symbol #PharoTutorial. There may be several ''PharoTutorial'' String objects. (Message == returns true if the two objects are the SAME)" ''PharoTutorial'' asSymbol. #PharoTutorial asString. (2 asString) == (2 asString). (2 asString) asSymbol == (2 asString) asSymbol. (Smalltalk at: #PharoTutorial) next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:50'! messageSyntaxUnary ^ Lesson title: 'Message syntax: Unary messages' lesson: '"Messages are sent to objects. There are three types of message: Unary, Binary and Keyword. Unary messages have the following form: anObject aMessage You''ve already sent unary messages. For example:" 1 class. false not. Time now. Date today. Float pi. "And of course: " PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:49'! instanciation ^ Lesson title: 'Instanciation' lesson: '"Objects are instances of their class. Usually, we send the message #new to a class for creating an instance of this class. The message #allInstances sent to a class answers an Array with all instances of this class. For example, let''s look at how many instances of SimpleButtonMorph exist:" SimpleButtonMorph allInstances size. "Now create a new instance of it:" SimpleButtonMorph new label: ''A nice button''; openCenteredInWorld. "See the button centered on the world ? The list of all instances should contains one more instance:" SimpleButtonMorph allInstances size. "Let''s play with it:" SimpleButtonMorph allInstances last label: ''PharoTutorial is cooooool !!''; color: Color cyan. "Let''s delete it and ask the system to clean the memory:" SimpleButtonMorph allInstances last delete. Smalltalk garbageCollect. SimpleButtonMorph allInstances size. "Click on the button to go to next lesson:" SimpleButtonMorph new label: ''Go to next lesson''; target: [PharoTutorial next. SimpleButtonMorph allInstances last delete]; actionSelector: #value; openCenteredInWorld.'! ! !PharoSyntaxTutorial methodsFor: 'interactive' stamp: 'CamilloBruni 2/22/2014 18:50'! prepareDebuggerExample self class compile: 'divideTwoByZero 2/0. "Oups!! 2/0 raises a ZeroDivide exception. So the debugger opens to let you fix the code. - Remove the line of code above. - Right-click and select ''Accept'' to compile the new version of the method - click the button ''Proceed'' to continue execution. ". PharoTutorial next. ' classified: 'interactive'.! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:50'! loops ^ Lesson title: 'Loops' lesson: '"Loops are high-level collection iterators, implemented as regular methods." "Basic loops: to:do: to:by:do" 1 to: 100 do: [:i | Transcript show: i asString; cr ]. 1 to: 100 by: 3 do: [:i | Transcript show: i asString; cr]. 100 to: 0 by: -2 do: [:i | Transcript show: i asString; cr]. 1 to: 1 do: [:i | PharoTutorial next].'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:51'! welcome ^ Lesson title: 'Welcome' lesson: '"Hello!! I''m Professor Stef. You must want me to help you learn Pharo. So let''s go to the first lesson. Select the text below, right-click and choose ''do it (d)''" PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'interactive' stamp: 'CamilloBruni 2/22/2014 19:17'! divideTwoByZero 2/0. "Oups!! 2/0 raises a ZeroDivide exception. So the debugger opens to let you fix the code. - Remove the line of code above. - Right-click and select 'Accept' to compile the new version of the method - click the button 'Proceed' to continue execution. ". PharoTutorial next. ! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:52'! basicTypesNumbers ^ Lesson title: 'Basic types: Numbers' lesson: '"You now know how to execute Pharo code. Now let''s talk about basic objects. 1, 2, 100, 2/3 ... are Numbers, and respond to many messages evaluating mathematical expressions. Evaluate these ones:" 2. 20 factorial. 1000 factorial / 999 factorial. (1/3). (1/3) + (4/5). (1/3) asFloat. 1 class. 1 class maxVal class. (1 class maxVal + 1) class. PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:51'! basicTypesArray ^ Lesson title: 'Basic types: Array' lesson: '"Literal arrays are created at parse time:" #(1 2 3). #( 1 2 3 #(4 5 6)) size. #(1 2 4) isEmpty. #(1 2 3) first. #(''hello'' ''World'') at: 2 put: ''Pharo''; yourself. PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:50'! messageSyntaxCascadeShouldNotBeHere ^ Lesson title: 'Lost ?' lesson: '"Hey, you should not be here !!!! Go back and use a cascade !!" PharoTutorial previous.'.! ! !PharoSyntaxTutorial methodsFor: 'tutorial' stamp: 'LaurentLaffont 2/6/2011 19:05'! tutorial ^ #( welcome doingVSPrinting printing basicTypesNumbers basicTypesCharacters basicTypesString basicTypesSymbol basicTypesArray basicTypesDynamicArray messageSyntaxUnary messageSyntaxBinary messageSyntaxKeyword messageSyntaxExecutionOrder messageSyntaxExecutionOrderParentheses mathematicalPrecedence messageSyntaxCascade messageSyntaxCascadeShouldNotBeHere blocks blocksAssignation conditionals loops iterators instanciation reflection reflectionContinued pharoEnvironment debugger theEnd )! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:49'! conditionals ^ Lesson title: 'Conditionals' lesson: '"Conditionals are just messages sent to Boolean objects" 1 < 2 ifTrue: [100] ifFalse: [42]. "Here the message is ifTrue:ifFalse Try this:" Transcript open. 3 > 10 ifTrue: [Transcript show: ''maybe there''''s a bug ....''] ifFalse: [Transcript show: ''No : 3 is less than 10'']. 3 = 3 ifTrue: [PharoTutorial next].'.! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 19:05'! reflection ^ Lesson title: 'Reflection' lesson: '"You can inspect and change the system at runtime. Take a look at method #ifFalse:ifTrue: source code of class True:" (True>>#ifFalse:ifTrue:) definition. "Or just its comment:" (True>>#ifFalse:ifTrue:) comment. "Here''s all the methods I implement:" PharoTutorial selectors. "Let''s create a new method to go to the next lesson:" PharoTutorial class compile:''goToNextLesson self next''. "Wow !! I can''t wait to use my new method !! " PharoTutorial goToNextLesson.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:50'! iterators ^ Lesson title: 'Iterators' lesson: '"The message do: is sent to a collection of objects (Array, Set, OrderedCollection), evaluating the block for each element. Here we want to print all the numbers on the Transcript (a console)" #(11 38 3 -2 10) do: [:each | Transcript show: each printString; cr]. "Some other really nice iterators" #(11 38 3 -2 10) collect: [:each | each abs]. #(11 38 3 -2 10) collect: [:each | each odd]. #(11 38 3 -2 10) select: [:each | each odd]. #(11 38 3 -2 10) select: [:each | each > 10]. #(11 38 3 -2 10) reject: [:each | each > 10]. #(11 38 3 -2 10) do: [:each | Transcript show: each printString] separatedBy: [Transcript show: ''.'']. PharoTutorial allInstances do: [:aPharoTutorial | aPharoTutorial next].'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:50'! messageSyntaxKeyword ^ Lesson title: 'Message syntax: Keyword messages' lesson: '"Keyword Messages are messages with arguments. They have the following form: anObject akey: anotherObject akey2: anotherObject2" 4 between: 0 and: 10. "The message is between:and: sent to the Number 4" 1 max: 3. Color r:1 g:0 b:0. "The message is r:g:b: implemented on class Color. Note you can also write" Color r:1 g:1 b:0. PharoTutorial perform: #next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:52'! doingVSPrinting ^ Lesson title: 'Doing VS Printing: Doing' lesson: '"Cool !! (I like to say Cooool :) ). You''ve just executed a Pharo expression. More precisely, you sent the message ''next'' to PharoTutorial class (it''s me !!). Note you can run this tutorial again by evaluating: ''PharoTutorial go''. ''PharoTutorial previous'' returns to the previous lesson. You can also Do It using the keyboard shortcut ''ALT d'' (this varies according to your operating system/computer: it can be ''CMD d'' or ''CTRL d''). Try to evaluate these expressions:" Browser open. SmalltalkImage current aboutThisSystem. "Then go to the next lesson:" PharoTutorial next.'! ! !PharoSyntaxTutorial methodsFor: 'lessons' stamp: 'CamilloBruni 2/22/2014 18:50'! messageSyntaxExecutionOrder ^ Lesson title: 'Message syntax: Execution order' lesson: '"Unary messages are executed first, then binary messages and finally keyword messages: Unary > Binary > Keywords" 2 + 3 squared. 2 raisedTo: 3 + 2. (0@0) class. 0@0 corner: 100@200. (0@0 corner: 100@200) class. "Between messages of similar precedence, expressions are executed from left to right" -3 abs negated reciprocal. PharoTutorial next.'! ! !PharoSyntaxTutorialTest commentStamp: 'CamilloBruni 2/22/2014 18:58'! SUnit tests for PharoSyntaxTutorial! !PharoSyntaxTutorialTest methodsFor: 'tests' stamp: ''! testLessonAtReturnsCorrespondingLesson | answer | 1 to: (self testedTutorial tutorial size) do: [:index| answer := self testedTutorial lessonAt: index. self assert: (answer isKindOf: Lesson) ] ! ! !PharoSyntaxTutorialTest methodsFor: 'requirements' stamp: 'CamilloBruni 2/22/2014 18:48'! testedTutorial "Returns an instance of an AbstractTutorial subclass" ^ PharoSyntaxTutorial new! ! !PharoSyntaxTutorialTest methodsFor: 'tests' stamp: ''! testNotEmpty self assert: self testedTutorial tutorial notEmpty.! ! !PharoSyntaxTutorialTest methodsFor: 'tests' stamp: ''! testEachSelectorReturnsALesson | answer | self testedTutorial tutorial do: [:aSelector| answer := (self testedTutorial perform: aSelector). self assert: (answer isKindOf: Lesson). ]! ! !PharoSyntaxTutorialTest methodsFor: 'tests' stamp: 'LaurentLaffont 12/12/2010 22:20'! testDivideTwoByZeroSignalsZeroDivide [self testedTutorial divideTwoByZero. self fail] on: ZeroDivide do: []! ! !PharoSyntaxTutorialTest methodsFor: 'tests' stamp: 'LaurentLaffont 2/1/2010 22:07'! testEachSelectorExists self testedTutorial tutorial do: [:aSelector| self assert: (self testedTutorial respondsTo: aSelector) ]! ! !PharoSyntaxTutorialTest methodsFor: 'tests' stamp: ''! testSizeReturnsNumberOfSelectors self assert: (self testedTutorial tutorial size) equals: self testedTutorial size.! ! !PharoTutorial commentStamp: 'CamilloBruni 2/22/2014 19:02'! A PharoTutorial is the Pharo teacher. To start the tutorial, evaluate: PharoTutorial go. To go to the next lesson evaluate: PharoTutorial next. To execute your own tutorial: PharoTutorial goOn: MyOwnTutorial To see a table of contents with all defined tutorials: PharoTutorial contents! !PharoTutorial methodsFor: 'starting' stamp: 'CamilloBruni 2/22/2014 18:48'! go ^ self goOn: PharoSyntaxTutorial.! ! !PharoTutorial methodsFor: 'navigating' stamp: 'DannyChan 2/9/2010 19:28'! last self player last. ^ self showCurrentLesson.! ! !PharoTutorial methodsFor: 'gui' stamp: 'LaurentLaffont 1/21/2010 21:05'! close self lessonView close! ! !PharoTutorial methodsFor: 'navigating' stamp: 'DannyChan 2/1/2010 19:23'! tutorial: aTutorialClass lessonAt: lessonIndex self player tutorial: aTutorialClass new. self player tutorialPosition: lessonIndex. self showCurrentLesson.! ! !PharoTutorial methodsFor: 'navigating' stamp: 'DannyChan 2/9/2010 19:28'! first self player first. ^ self showCurrentLesson.! ! !PharoTutorial methodsFor: 'navigating' stamp: 'tg 2/1/2010 16:02'! next self player next. ^ self showCurrentLesson.! ! !PharoTutorial methodsFor: 'accessing' stamp: 'LaurentLaffont 1/21/2010 20:38'! player ^ player ifNil: [player := TutorialPlayer new]! ! !PharoTutorial methodsFor: 'gui' stamp: 'CamilloBruni 2/22/2014 19:44'! showCurrentLesson | progressInfo lesson | lesson := self player currentLesson. progressInfo := '(', self tutorialPositionString, '/', self tutorialSizeString, ')'. ^ self lessonView showLesson: lesson withTitle: lesson title, ' ', progressInfo.! ! !PharoTutorial methodsFor: 'accessing' stamp: 'LaurentLaffont 1/21/2010 20:37'! tutorialPositionString ^ player tutorialPosition asString.! ! !PharoTutorial methodsFor: 'accessing' stamp: 'LaurentLaffont 1/21/2010 20:38'! tutorialSizeString ^ self player size asString! ! !PharoTutorial methodsFor: 'navigating' stamp: 'DannyChan 2/1/2010 21:23'! tutorial: aTutorialClass lesson: aSelector | tutorial | tutorial := aTutorialClass new. self player tutorial: tutorial. self tutorial: aTutorialClass lessonAt: (tutorial indexOfLesson: aSelector).! ! !PharoTutorial methodsFor: 'accessing' stamp: 'DannyChan 2/2/2010 19:16'! lessonView: aLessonView lessonView := aLessonView.! ! !PharoTutorial methodsFor: 'accessing' stamp: 'DannyChan 2/2/2010 19:39'! lessonView ^ lessonView ifNil: [lessonView := LessonView new]! ! !PharoTutorial methodsFor: 'starting' stamp: 'tg 2/1/2010 16:02'! goOn: aTutorialClass self player tutorial: aTutorialClass new. ^ self open.! ! !PharoTutorial methodsFor: 'gui' stamp: 'tg 2/1/2010 16:02'! open self player first. ^ self showCurrentLesson.! ! !PharoTutorial methodsFor: 'accessing' stamp: 'LaurentLaffont 1/21/2010 20:39'! player: aTutorialPlayer player := aTutorialPlayer.! ! !PharoTutorial methodsFor: 'navigating' stamp: 'tg 2/1/2010 16:02'! previous self player previous. ^ self showCurrentLesson.! ! !PharoTutorial class methodsFor: 'navigating' stamp: 'LaurentLaffont 9/18/2011 20:01'! go ^ self default go.! ! !PharoTutorial class methodsFor: 'navigating' stamp: 'DannyChan 2/9/2010 19:30'! last ^ self default last.! ! !PharoTutorial class methodsFor: 'starting' stamp: 'DannyChan 2/1/2010 19:23'! tutorial: aTutorialClass lessonAt: lessonIndex self default tutorial: aTutorialClass lessonAt: lessonIndex.! ! !PharoTutorial class methodsFor: 'class initialization' stamp: 'CamilloBruni 2/22/2014 19:45'! default ^ Instance ifNil: [Instance := self new]! ! !PharoTutorial class methodsFor: 'navigating' stamp: 'DannyChan 2/9/2010 19:30'! first ^ self default first.! ! !PharoTutorial class methodsFor: 'navigating' stamp: 'tg 2/1/2010 16:01'! next ^ self default next.! ! !PharoTutorial class methodsFor: 'starting' stamp: 'DannyChan 2/1/2010 19:23'! tutorial: aTutorialClass lesson: aSelector self default tutorial: aTutorialClass lesson: aSelector.! ! !PharoTutorial class methodsFor: 'class initialization' stamp: 'CamilloBruni 2/22/2014 19:45'! reset Instance := nil! ! !PharoTutorial class methodsFor: 'navigating' stamp: 'tg 2/1/2010 16:01'! previous ^ self default previous.! ! !PharoTutorial class methodsFor: 'navigating' stamp: 'LaurentLaffont 9/18/2011 20:01'! goOn: aTutorialClass ^ self default goOn: aTutorialClass.! ! !PharoTutorialAPIHelp commentStamp: 'CamilloBruni 2/22/2014 18:59'! I'm a PharoTutorial which builds a HelpSystem book by collecting comment from classes and method.! !PharoTutorialAPIHelp class methodsFor: 'accessing' stamp: 'LaurentLaffont 9/19/2010 15:14'! bookName ^ 'Reference'! ! !PharoTutorialAPIHelp class methodsFor: 'defaults' stamp: 'LaurentLaffont 9/19/2010 15:14'! builder ^ PackageAPIHelpBuilder! ! !PharoTutorialAPIHelp class methodsFor: 'accessing' stamp: 'CamilloBruni 2/22/2014 19:17'! helpPackages ^ #('ProfStef-Core')! ! !PharoTutorialHelp commentStamp: 'CamilloBruni 2/22/2014 18:59'! HelpSystem book documenting PharoTutorial! !PharoTutorialHelp class methodsFor: 'accessing' stamp: 'LaurentLaffont 9/19/2010 15:13'! pages ^ #(introduction listOfTutorials createATutorial)! ! !PharoTutorialHelp class methodsFor: 'pages' stamp: 'LaurentLaffont 9/19/2010 15:13'! createATutorial ^ HelpTopic title: 'Create a tutorial' contents: 'See AbstractTutorial comment: ', AbstractTutorial comment.! ! !PharoTutorialHelp class methodsFor: 'accessing' stamp: 'CamilloBruni 2/22/2014 18:59'! bookName ^ 'Pharo Tutorial'! ! !PharoTutorialHelp class methodsFor: 'testing' stamp: 'AlainPantec 2/23/2012 08:16'! canHaveSyntaxHighlighting ^ true ! ! !PharoTutorialHelp class methodsFor: 'pages' stamp: 'CamilloBruni 2/22/2014 18:59'! listOfTutorials |contents| contents := String streamContents: [:aStream| AbstractTutorial tutorials do: [:aTutorial| aStream nextPutAll: aTutorial title; cr; tab; nextPutAll: 'PharoTutorial goOn:'; nextPutAll: aTutorial name; cr;cr. ] ]. ^ HelpTopic title: 'List of tutorials' contents: contents.! ! !PharoTutorialHelp class methodsFor: 'pages' stamp: 'CamilloBruni 2/22/2014 18:59'! introduction ^ HelpTopic title: 'Introduction' contents: 'PharoTutorial is a framework to create interactive tutorials'.! ! !PharoTutorialHelpTest commentStamp: 'CamilloBruni 2/22/2014 18:58'! SUnit tests for PharoTutorialHelp! !PharoTutorialHelpTest methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:58'! testCreateATutorial | helpTopic | helpTopic := PharoTutorialHelp createATutorial. self assert: helpTopic notNil. self assert: helpTopic class == HelpTopic. self assert: helpTopic title = 'Create a tutorial'! ! !PharoTutorialHelpTest methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:58'! testIntroduction | helpTopic | helpTopic := PharoTutorialHelp introduction. self assert: helpTopic notNil. self assert: helpTopic class == HelpTopic. self assert: helpTopic title = 'Introduction'! ! !PharoTutorialHelpTest methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:58'! testPages self assert: PharoTutorialHelp pages isCollection. self assert: (PharoTutorialHelp pages allSatisfy: #isSymbol).! ! !PharoTutorialHelpTest methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:58'! testBookName self assert: PharoTutorialHelp bookName isString! ! !PharoTutorialHelpTest methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:58'! testListOfTutorials | helpTopic | helpTopic := PharoTutorialHelp listOfTutorials. self assert: (helpTopic notNil). self assert: (helpTopic title = 'List of tutorials' )! ! !PharoTutorialHelpTutorialBuilder commentStamp: 'CamilloBruni 2/22/2014 18:59'! I build HelpSystem topics to browse PharoTutorial tutorials! !PharoTutorialHelpTutorialBuilder methodsFor: 'building' stamp: 'LaurentLaffont 9/19/2010 15:30'! buildTutorialTopicFor: aTutorial |tutorialTopic| tutorialTopic := HelpTopic named: aTutorial title. aTutorial new lessons do:[:aLesson| tutorialTopic addSubtopic: (HelpTopic title: aLesson title contents: aLesson lesson) ]. ^ tutorialTopic ! ! !PharoTutorialHelpTutorialBuilder methodsFor: 'building' stamp: 'LaurentLaffont 9/19/2010 15:25'! build topicToBuild := HelpTopic named: rootToBuildFrom bookName. AbstractTutorial tutorials do: [:aTutorial| topicToBuild addSubtopic: (self buildTutorialTopicFor: aTutorial) ]. ^ topicToBuild.! ! !PharoTutorialHelpTutorialBuilder class methodsFor: 'instance creation' stamp: 'LaurentLaffont 4/26/2011 13:00'! new "We prohibid new" ^ (self class lookupSelector: #buildHelpTopicFrom:) == thisContext sender method ifFalse:[self error: 'Please use buildHelpTopicFrom: instead'] ifTrue: [super new]! ! !PharoTutorialHelpTutorialBuilderTest commentStamp: 'CamilloBruni 2/22/2014 18:58'! SUnit tests for PharoTutorialHelpTutorialBuilder! !PharoTutorialHelpTutorialBuilderTest methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:59'! testInstantiation self should: [ PharoTutorialHelpTutorialBuilder new ] raise: Error! ! !PharoTutorialHelpTutorialBuilderTest methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 19:44'! testBuild | helpTopic tutorial | tutorial := PharoTutorialsHelp. helpTopic := PharoTutorialHelpTutorialBuilder buildHelpTopicFrom: tutorial. self assert: helpTopic notNil! ! !PharoTutorialTestGo commentStamp: 'TorstenBergmann 2/12/2014 22:52'! SUnit tests for tutorial navigation! !PharoTutorialTestGo methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:48'! testGoOpenSmalltalkSyntaxTutorial | displayedText expected | PharoTutorial go. displayedText := PharoTutorial default lessonView text. expected := PharoSyntaxTutorial new welcome lesson. self assert: displayedText equals: expected.! ! !PharoTutorialTestGo methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:42'! testGoOnMockTutorial | displayedText expected | PharoTutorial goOn: MockTutorial. displayedText := PharoTutorial default lessonView text. expected := MockTutorial new firstLesson lesson. self assert: displayedText equals: expected.! ! !PharoTutorialTestGo methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:48'! testGoTwiceUseSameLessonView | firstLessonView | PharoTutorial go. firstLessonView := PharoTutorial default lessonView. PharoTutorial goOn: PharoSyntaxTutorial. self assert: (firstLessonView == PharoTutorial default lessonView).! ! !PharoTutorialTestGo methodsFor: 'running' stamp: 'CamilloBruni 2/22/2014 18:42'! tearDown PharoTutorial default close! ! !PharoTutorialTestGo methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:48'! testGoTwiceShowLessonViewIfNotVisible | firstLessonView | PharoTutorial go. firstLessonView := PharoTutorial default lessonView. firstLessonView close. PharoTutorial goOn: PharoSyntaxTutorial. self assert: (World systemWindows includes: firstLessonView window).! ! !PharoTutorialTestGoOnMockTutorial commentStamp: 'TorstenBergmann 2/12/2014 22:52'! SUnit tests for tutorial navigation! !PharoTutorialTestGoOnMockTutorial methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:42'! testFirstLessonShouldBeDisplayed. self assert: 'First lesson' equals: PharoTutorial default lessonView text! ! !PharoTutorialTestGoOnMockTutorial methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:42'! testLastShouldGoToThirdLesson PharoTutorial last. self assert: 'Third lesson' equals: PharoTutorial default lessonView text! ! !PharoTutorialTestGoOnMockTutorial methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:42'! testLastThenFirstShouldGoToFirstLesson PharoTutorial last; first. self assert: 'First lesson' equals: PharoTutorial default lessonView text! ! !PharoTutorialTestGoOnMockTutorial methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:42'! testLastThenPreviousShouldGoToSecondLesson PharoTutorial last; previous. self assert: 'Second lesson' equals: PharoTutorial default lessonView text! ! !PharoTutorialTestGoOnMockTutorial methodsFor: 'running' stamp: 'CamilloBruni 2/22/2014 18:42'! tearDown PharoTutorial default close! ! !PharoTutorialTestGoOnMockTutorial methodsFor: 'running' stamp: 'CamilloBruni 2/22/2014 18:42'! setUp PharoTutorial tutorial: MockTutorial lesson: #firstLesson ! ! !PharoTutorialTestGoOnMockTutorial methodsFor: 'tests' stamp: 'CamilloBruni 2/22/2014 18:42'! testNextShouldGoToSecondLesson PharoTutorial next. self assert: 'Second lesson' equals: PharoTutorial default lessonView text! ! !PharoTutorialTestNavigation commentStamp: 'TorstenBergmann 2/12/2014 22:52'! SUnit tests for tutorial navigation! !PharoTutorialTestNavigation methodsFor: 'tests' stamp: 'LaurentLaffont 2/15/2011 22:11'! testSequenceNextNextPreviousOpenSecondLesson prof next; next; previous. self assert: mockView title equals: 'second (2/3)'. self assert: mockView lesson lesson equals: 'Second lesson'.! ! !PharoTutorialTestNavigation methodsFor: 'tests' stamp: 'LaurentLaffont 2/15/2011 22:12'! testShowingLessonByIndex prof tutorial: MockTutorial lessonAt: 2. self assert: mockView title equals: 'second (2/3)'. self assert: mockView lesson lesson equals: 'Second lesson'.! ! !PharoTutorialTestNavigation methodsFor: 'tests' stamp: 'LaurentLaffont 1/21/2010 16:27'! testShowFirstLessonOnGo | lesson | lesson := mockView lesson. self assert: lesson title equals: 'first'. self assert: lesson lesson equals: 'First lesson'.! ! !PharoTutorialTestNavigation methodsFor: 'tests' stamp: 'LaurentLaffont 2/15/2011 22:13'! testNextOpenSecondLesson prof next. self assert: mockView title equals: 'second (2/3)'. self assert: mockView lesson lesson equals: 'Second lesson'.! ! !PharoTutorialTestNavigation methodsFor: 'tests' stamp: 'LaurentLaffont 2/15/2011 22:12'! testShowingLessonBySelector prof tutorial: MockTutorial lesson: #firstLesson. self assert: mockView title equals: 'first (1/3)'. self assert: mockView lesson lesson equals: 'First lesson'.! ! !PharoTutorialTestNavigation methodsFor: 'tests' stamp: 'LaurentLaffont 2/15/2011 22:12'! testSequenceNextNextOpenThirdLesson prof next; next. self assert: mockView title equals: 'third (3/3)'. self assert: mockView lesson lesson equals: 'Third lesson'.! ! !PharoTutorialTestNavigation methodsFor: 'running' stamp: 'CamilloBruni 2/22/2014 18:42'! setUp prof := PharoTutorial new. prof player: ( TutorialPlayer new tutorial: MockTutorial new; yourself). mockView := MockLessonView new. prof lessonView: mockView. prof open.! ! !PharoTutorialsHelp commentStamp: 'CamilloBruni 2/22/2014 18:59'! I'm a HelpSystem book which list all Pharo tutorials! !PharoTutorialsHelp class methodsFor: 'accessing' stamp: 'LaurentLaffont 9/19/2010 15:16'! bookName ^ 'Browse tutorials'! ! !PharoTutorialsHelp class methodsFor: 'defaults' stamp: 'CamilloBruni 2/22/2014 18:59'! builder ^ PharoTutorialHelpTutorialBuilder! ! !PharoTutorialsHelp class methodsFor: 'menu' stamp: 'CamilloBruni 2/22/2014 19:00'! menuCommandOn: aBuilder (aBuilder item: #'Pharo Tutorials') parent: #Help; action:[ HelpBrowser openOn: self ]; help: 'Browse and create Pharo tutorials'.! ! !PharoUIThemeIcons commentStamp: 'TorstenBergmann 2/5/2014 10:30'! Theme icons for Pharo UI! !PharoUIThemeIcons methodsFor: 'forms' stamp: 'EstebanLorenzano 5/9/2013 10:58'! radioButtonSelectedForm ^ self form16x16FromContents: self radioButtonSelectedFormContents! ! !PharoUIThemeIcons methodsFor: 'label-styles' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowCloseForm ^ self form16x16FromContents: self windowCloseFormContents ! ! !PharoUIThemeIcons methodsFor: 'forms' stamp: 'EstebanLorenzano 5/9/2013 10:58'! checkboxUnselectedForm ^ self form16x16FromContents: self checkboxUnselectedFormContents ! ! !PharoUIThemeIcons methodsFor: 'label-styles' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMinimizeForm ^self form16x16FromContents: self windowMinimizeFormContents ! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! menuPinFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 83886080 100663296 83886080 0 0 0 0 0 0 0 0 0 0 0 0 1291845632 3774873600 4194304000 3774873600 788529152 0 0 0 0 0 0 0 0 0 0 1107296256 4278190080 4278190080 4278190080 4278190080 4278190080 788529152 0 0 0 0 0 0 0 0 83886080 3992977408 4278190080 4278190080 4278190080 4278190080 4278190080 3774873600 83886080 0 0 0 0 0 0 0 100663296 4194304000 4278190080 4278190080 4278190080 4278190080 4278190080 4194304000 100663296 0 0 0 0 0 0 0 83886080 3774873600 4278190080 4278190080 4278190080 4278190080 4278190080 3992977408 83886080 0 0 0 0 0 0 0 0 1291845632 4261412864 4278190080 4278190080 4278190080 4261412864 1107296256 0 0 0 0 0 0 0 0 0 0 1107296256 3992977408 4194304000 3774873600 1291845632 0 0 0 0 0 0 0 0 0 0 0 0 83886080 100663296 83886080 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! checkboxSelectedFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4261412864 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4261412864 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4278190080 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4278190080 0 0 0 0 0 0 4261412864 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4261412864 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMenuInactiveFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 360282489 3565191296 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 3565191296 360282489 0 0 0 0 0 0 0 360282489 3565191296 4286611584 4286611584 4286611584 4286611584 3565191296 360282489 0 0 0 0 0 0 0 0 0 360282489 3565191296 4286611584 4286611584 3565191296 360282489 0 0 0 0 0 0 0 0 0 0 0 377520256 3565191296 3565191296 360282489 0 0 0 0 0 0 0 0 0 0 0 0 0 377520256 360282489 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! radioUnselectedFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 50331648 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 1023410176 3238002688 3909091328 3909091328 3238002688 1023410176 0 0 0 0 0 0 0 0 0 2097152000 3976200192 1275068416 452984832 452984832 1275068416 3976200192 872415232 0 0 0 0 0 0 0 1023410176 4278190080 335544320 0 0 0 0 335544320 4278190080 1023410176 0 0 0 0 0 50331648 3238002688 1275068416 0 0 0 0 0 0 1275068416 3238002688 50331648 0 0 0 0 0 3909091328 452984832 0 0 0 0 0 0 452984832 3909091328 0 0 0 0 0 0 3909091328 452984832 0 0 0 0 0 0 452984832 3909091328 0 0 0 0 0 33554432 3238002688 1275068416 0 0 0 0 0 0 1275068416 3238002688 50331648 0 0 0 0 0 1006632960 3992977408 335544320 0 0 0 0 335544320 4278190080 1023410176 0 0 0 0 0 0 0 2097152000 4278190080 1275068416 452984832 452984832 1275068416 3976200192 2097152000 0 0 0 0 0 0 0 0 0 1006632960 3238002688 3909091328 3909091328 3238002688 1023410176 0 0 0 0 0 0 0 0 0 0 0 33554432 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! radioButtonSelectedFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 50331648 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 1023410176 3422946822 4043572228 4043572228 3422946822 1023410176 0 0 0 0 0 0 0 0 0 2214987270 4161078533 4284045657 4285690482 4285690482 4284045657 4161078533 1058280468 0 0 0 0 0 0 0 1023410176 4278190080 4285887861 4286611584 4286611584 4286611584 4286611584 4285887861 4278190080 1023410176 0 0 0 0 0 50331648 3422946822 4284045657 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4284045657 3422946822 50331648 0 0 0 0 0 4043572228 4285690482 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4285690482 4043572228 0 0 0 0 0 0 4043572228 4285690482 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4285690482 4043572228 0 0 0 0 0 33554432 3422946822 4284045657 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4284045657 3422946822 50331648 0 0 0 0 0 1006632960 4161078533 4285887861 4286611584 4286611584 4286611584 4286611584 4285887861 4278190080 1023410176 0 0 0 0 0 0 0 2214987270 4278190080 4284045657 4285690482 4285690482 4284045657 4161078533 2214987270 0 0 0 0 0 0 0 0 0 1006632960 3422946822 4043572228 4043572228 3422946822 1023410176 0 0 0 0 0 0 0 0 0 0 0 33554432 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowCloseFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 167772160 0 0 0 0 0 0 0 0 167772160 3875536896 4076863488 234881024 0 234881024 2919235584 3858759680 0 0 0 0 0 0 0 0 402653184 3674210304 4261412864 3758096384 671088640 3758096384 4261412864 4278190080 335544320 0 0 0 0 0 0 0 0 352321536 3758096384 4143972352 4211081216 4143972352 3758096384 352321536 0 0 0 0 0 0 0 0 0 0 671088640 4211081216 4261412864 4211081216 671088640 0 0 0 0 0 0 0 0 0 0 352321536 3758096384 4143972352 4211081216 4143972352 3758096384 352321536 0 0 0 0 0 0 0 0 335544320 4278190080 4244635648 3758096384 671088640 3758096384 4143972352 3724541952 402653184 0 0 0 0 0 0 0 0 3892314112 2919235584 234881024 0 234881024 4278190080 1761607680 167772160 0 0 0 0 0 0 0 0 167772160 67108864 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! radioSelectedFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 50331648 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 1023410176 3422946822 4043572228 4043572228 3422946822 1023410176 0 0 0 0 0 0 0 0 0 2214987270 4161078533 4284045657 4285690482 4285690482 4284045657 4161078533 1058280468 0 0 0 0 0 0 0 1023410176 4278190080 4285887861 4286611584 4286611584 4286611584 4286611584 4285887861 4278190080 1023410176 0 0 0 0 0 50331648 3422946822 4284045657 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4284045657 3422946822 50331648 0 0 0 0 0 4043572228 4285690482 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4285690482 4043572228 0 0 0 0 0 0 4043572228 4285690482 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4285690482 4043572228 0 0 0 0 0 33554432 3422946822 4284045657 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4284045657 3422946822 50331648 0 0 0 0 0 1006632960 4161078533 4285887861 4286611584 4286611584 4286611584 4286611584 4285887861 4278190080 1023410176 0 0 0 0 0 0 0 2214987270 4278190080 4284045657 4285690482 4285690482 4284045657 4161078533 2214987270 0 0 0 0 0 0 0 0 0 1006632960 3422946822 4043572228 4043572228 3422946822 1023410176 0 0 0 0 0 0 0 0 0 0 0 33554432 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0! ! !PharoUIThemeIcons methodsFor: 'forms' stamp: 'EstebanLorenzano 5/9/2013 10:58'! radioButtonUnselectedForm ^ self form16x16FromContents: self radioButtonUnselectedFormContents ! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMaximizeInactiveFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMenuFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 352321536 3556769792 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 3556769792 352321536 0 0 0 0 0 0 0 352321536 3556769792 4278190080 4278190080 4278190080 4278190080 3556769792 352321536 0 0 0 0 0 0 0 0 0 352321536 3556769792 4278190080 4278190080 3556769792 352321536 0 0 0 0 0 0 0 0 0 0 0 369098752 3556769792 3556769792 352321536 0 0 0 0 0 0 0 0 0 0 0 0 0 369098752 352321536 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMinimizeInactiveFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 0 0 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'forms' stamp: 'EstebanLorenzano 5/9/2013 10:58'! menuPinForm ^self form16x16FromContents: self menuPinFormContents ! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! checkboxUnselectedFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4261412864 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4261412864 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 0 0 4278190080 0 0 0 0 0 0 4261412864 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4261412864 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'forms' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMaximizeInactiveForm ^ self form16x16FromContents: self windowMaximizeInactiveFormContents ! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMaximizeFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) ! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowCloseInactiveFromContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 176193664 0 0 0 0 0 0 0 0 176193664 3883958400 4085284992 243302528 0 243302528 2927657088 3867181184 0 0 0 0 0 0 0 0 411074688 3682631808 4269834368 3766517888 679049593 3766517888 4269834368 4286611584 343965824 0 0 0 0 0 0 0 0 360282489 3766517888 4152328063 4219436927 4152393856 3766517888 360282489 0 0 0 0 0 0 0 0 0 0 679049593 4219436927 4269834368 4219436927 679049593 0 0 0 0 0 0 0 0 0 0 360282489 3766517888 4152393856 4219436927 4152328063 3766517888 360282489 0 0 0 0 0 0 0 0 343965824 4286611584 4253057152 3766517888 679049593 3766517888 4152328063 3732963456 411074688 0 0 0 0 0 0 0 0 3900735616 2927657088 243302528 0 243302528 4286611584 1769897598 176193664 0 0 0 0 0 0 0 0 176193664 75530368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'forms' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowCloseInactiveForm ^ self form16x16FromContents: self windowCloseInactiveFromContents ! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! form16x16FromContents: aByteArray ^ Form extent: 16@16 depth: 32 fromArray: aByteArray offset: 0@0! ! !PharoUIThemeIcons methodsFor: 'label-styles' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMaximizeForm ^ self form16x16FromContents: self windowMaximizeFormContents ! ! !PharoUIThemeIcons methodsFor: 'label-styles' stamp: 'EstebanLorenzano 5/9/2013 10:58'! checkboxMarkerForm "Answer a new radio button marker form. We make it empty because we already have the selected radio button take care of the state." ^Form extent: 12@12 depth: 32! ! !PharoUIThemeIcons methodsFor: 'forms' stamp: 'EstebanLorenzano 5/9/2013 10:58'! radioSelectedForm ^ Form fromBinaryStream: ( Base64MimeConverter mimeDecodeToBytes: self radioSelectedFormContents readStream) ! ! !PharoUIThemeIcons methodsFor: 'label-styles' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMenuForm ^self form16x16FromContents: self windowMenuFormContents ! ! !PharoUIThemeIcons methodsFor: 'forms' stamp: 'EstebanLorenzano 5/9/2013 10:58'! radioUnselectedForm ^ Form fromBinaryStream: ( Base64MimeConverter mimeDecodeToBytes: self radioUnselectedFormContents readStream) ! ! !PharoUIThemeIcons methodsFor: 'forms' stamp: 'EstebanLorenzano 5/9/2013 10:58'! checkboxSelectedForm ^ self form16x16FromContents: self checkboxSelectedFormContents ! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! radioButtonUnselectedFormContents ^#( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 50331648 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 1023410176 3238002688 3909091328 3909091328 3238002688 1023410176 0 0 0 0 0 0 0 0 0 2097152000 3976200192 1275068416 452984832 452984832 1275068416 3976200192 872415232 0 0 0 0 0 0 0 1023410176 4278190080 335544320 0 0 0 0 335544320 4278190080 1023410176 0 0 0 0 0 50331648 3238002688 1275068416 0 0 0 0 0 0 1275068416 3238002688 50331648 0 0 0 0 0 3909091328 452984832 0 0 0 0 0 0 452984832 3909091328 0 0 0 0 0 0 3909091328 452984832 0 0 0 0 0 0 452984832 3909091328 0 0 0 0 0 33554432 3238002688 1275068416 0 0 0 0 0 0 1275068416 3238002688 50331648 0 0 0 0 0 1006632960 3992977408 335544320 0 0 0 0 335544320 4278190080 1023410176 0 0 0 0 0 0 0 2097152000 4278190080 1275068416 452984832 452984832 1275068416 3976200192 2097152000 0 0 0 0 0 0 0 0 0 1006632960 3238002688 3909091328 3909091328 3238002688 1023410176 0 0 0 0 0 0 0 0 0 0 0 33554432 0 0 50331648 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'label-styles' stamp: 'EstebanLorenzano 5/9/2013 10:58'! radioButtonMarkerForm "Answer a new radio button marker form. We make it empty because we already have the selected radio button take care of the state." ^Form extent: 12@12 depth: 32! ! !PharoUIThemeIcons methodsFor: 'forms' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMenuInactiveForm ^self form16x16FromContents: self windowMenuInactiveFormContents ! ! !PharoUIThemeIcons methodsFor: 'private - contents' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMinimizeFormContents ^ #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 0 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)! ! !PharoUIThemeIcons methodsFor: 'forms' stamp: 'EstebanLorenzano 5/9/2013 10:58'! windowMinimizeInactiveForm ^self form16x16FromContents: self windowMinimizeInactiveFormContents ! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! radioButtonSelectedForm ^ self current radioButtonSelectedForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! windowCloseForm ^ self current windowCloseForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! checkboxUnselectedForm ^ self current checkboxUnselectedForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! windowMinimizeForm ^ self current windowMinimizeForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! windowMaximizeInactiveForm ^ self current windowMaximizeInactiveForm.! ! !PharoUIThemeIcons class methodsFor: 'testing' stamp: 'EstebanLorenzano 10/17/2013 13:34'! isAbstract ^ self ~= PharoUIThemeIcons! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! windowCloseInactiveForm ^ self current windowCloseInactiveForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! windowMaximizeForm ^ self current windowMaximizeForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! radioButtonUnselectedForm ^ self current radioButtonUnselectedForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! checkboxMarkerForm ^ self current checkboxMarkerForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! radioSelectedForm ^ self current radioSelectedForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! windowMenuForm ^ self current windowMenuForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! radioUnselectedForm ^ self current radioUnselectedForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! checkboxSelectedForm ^ self current checkboxSelectedForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! windowMenuInactiveForm ^ self current windowMenuInactiveForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! radioButtonMarkerForm ^ self current radioButtonMarkerForm.! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! windowMinimizeInactiveForm ^ self current windowMinimizeInactiveForm.! ! !PharoUIThemeIcons class methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/17/2013 13:33'! iconSetName ^ 'FamFamFam'! ! !PharoUIThemeIcons class methodsFor: 'private - icons' stamp: 'EstebanLorenzano 5/9/2013 19:34'! menuPinForm ^ self current menuPinForm.! ! !PharoUser commentStamp: ''! A PharoUser is a simple object with a username and an avatar. It also works as a factory to keep already generated instances! !PharoUser methodsFor: 'protocol-forward' stamp: 'BenjaminVanRyseghem 5/11/2012 16:40'! setUserName: user forGroup: group ^ self unlockedKeychain setUserName: user forGroup: group! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 16:40'! unlockedKeychain ^ unlockedKeychain! ! !PharoUser methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/16/2012 15:40'! defaultAvatar ^ ImageMorph new color: Color transparent; height: 1; width: 1; yourself ! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 13:55'! avatar ^ avatar! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 16:11'! keychain ^ keychain! ! !PharoUser methodsFor: 'protocol-forward' stamp: 'BenjaminVanRyseghem 5/11/2012 16:40'! userNameFor: aGroup ^ self unlockedKeychain userNameFor: aGroup ! ! !PharoUser methodsFor: 'protocol-forward' stamp: 'BenjaminVanRyseghem 5/9/2012 16:11'! setPassword: aString ^ self keychain setPassword: aString ! ! !PharoUser methodsFor: 'protocol-forward' stamp: 'BenjaminVanRyseghem 5/9/2012 16:11'! userNamePasswordFor: aGroup ^ self keychain userNamePasswordFor: aGroup ! ! !PharoUser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/11/2012 16:37'! unlock ^ keychain unlock! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 13:55'! username ^ username! ! !PharoUser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/20/2012 03:25'! lock ^ keychain lock! ! !PharoUser methodsFor: 'error handling' stamp: 'BenjaminVanRyseghem 5/16/2012 15:04'! doesNotUnderstand: aMessage ^ [ self permissions perform: aMessage selector withEnoughArguments: aMessage arguments ] on: MessageNotUnderstood do: [ super doesNotUnderstand: aMessage ]! ! !PharoUser methodsFor: 'initialization' stamp: 'MarcusDenker 9/11/2013 13:52'! initialize super initialize. avatar := self defaultAvatar. keychain := KeyChain new. unlockedKeychain := UnlockedKeyChain new.! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/16/2012 15:02'! permissions ^ permissions ifNil: [ permissions := PharoUserPermissions new ]! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 13:55'! username: anObject username := anObject! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 16:27'! avatar: email self updateGravatarFor: email! ! !PharoUser methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 5/9/2012 14:03'! printOn: aStream super printOn: aStream. aStream nextPut: $(. username printOn: aStream. aStream nextPut: $)! ! !PharoUser methodsFor: 'gravatar' stamp: 'BenjaminVanRyseghem 5/9/2012 22:11'! updateGravatarFor: email | newAvatar | newAvatar := [ self retrieveGravatarFromMail: email ] on: Error do: [ nil ]. newAvatar ifNotNil: [ avatar := newAvatar ].! ! !PharoUser methodsFor: 'protocol-forward' stamp: 'BenjaminVanRyseghem 5/9/2012 16:11'! setUserName: user password: pass forGroup: group ^ self keychain setUserName: user password: pass forGroup: group! ! !PharoUser methodsFor: 'gravatar' stamp: 'BenjaminVanRyseghem 5/9/2012 17:00'! retrieveGravatarFromMail: email ^ self retrieveGravatarFromMail: email size: 120! ! !PharoUser methodsFor: 'gravatar' stamp: 'SvenVanCaekenberghe 1/15/2013 15:48'! retrieveGravatarFromMail: email size: size | response | response := ZnClient new timeout: 10; url: 'http://www.gravatar.com/avatar'; addPathSegment: (ZnDigestAuthenticator md5Hash: email); queryAt: #s put: size asString; queryAt: #d put: #retro; get. ^ ImageMorph fromStream: response readStream! ! !PharoUser class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/4/2013 12:56'! username: username ^ Smalltalk tools userManager users detect: [:e | e username = username ] ifNone: [ self new username: username; yourself ]! ! !PharoUserPermissions commentStamp: ''! A PharoUserPermissions is a wrapper which stores the permissions of a PharoUser! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canBrowse: anObject canBrowse := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canDebug: anObject canDebug := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canRunStartupScript ^ canRunStartupScript! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canBrowse ^ canBrowse! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canEditCode ^ canEditCode! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canDropOSFile ^ canDropOSFile! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canEditCode: anObject canEditCode := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canEvaluateCode ^ canEvaluateCode! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canInspect ^ canInspect! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 13:50'! canEditUser ^ canEditUser! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canShowMorphHalo: anObject canShowMorphHalo := anObject! ! !PharoUserPermissions methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/24/2014 11:54'! isRoot: aBoolean canBrowse := aBoolean. canDebug := aBoolean. canDropOSFile := aBoolean. canEditCode := aBoolean. canEvaluateCode := aBoolean. canInspect := aBoolean. canRunStartupScript := aBoolean. canShowMorphHalo := aBoolean. canEditUser := aBoolean. canSaveImage := aBoolean.! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/7/2013 18:57'! canSaveImage ^ canSaveImage! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canEvaluateCode: anObject canEvaluateCode := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 13:50'! canEditUser: anObject canEditUser := anObject! ! !PharoUserPermissions methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:06'! initialize super initialize. canBrowse := false. canDebug := false. canDropOSFile := false. canEditCode := false. canEvaluateCode := false. canInspect := false. canRunStartupScript := false. canShowMorphHalo := false. canEditUser := false. canSaveImage := false.! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/7/2013 18:57'! canSaveImage: anObject canSaveImage := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canRunStartupScript: anObject canRunStartupScript := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canShowMorphHalo ^ canShowMorphHalo! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canDebug ^ canDebug! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canDropOSFile: anObject canDropOSFile := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canInspect: anObject canInspect := anObject! ! !PharoVMInterpreterTest commentStamp: ''! I allow to test basic and tricky cases for the Pharo interpreter, such as non local returns, exception handling, ensure blocks. Test me when you refactor / change Pharo interpreter. Instance Variables ! !PharoVMInterpreterTest methodsFor: 'basic asserting' stamp: 'ClementBera 11/2/2012 13:23'! testInstanceCreation self assert: ((Array new) isKindOf: Array). self assert: ((Error new) isKindOf: Error). self assert: ((MessageNotUnderstood new) isKindOf: MessageNotUnderstood)! ! !PharoVMInterpreterTest methodsFor: 'tricky asserting' stamp: 'ClementBera 11/2/2012 13:22'! testExceptionReturn self assert: ([ Error signal ] on: Error do: [ :err| err return: 5 + 1 ]) = 6. self assert: [[ Error signal ] on: Error do: [ :err| err return: 5 + 1 ]. true] value = true.! ! !PharoVMInterpreterTest methodsFor: 'basic asserting' stamp: 'ClementBera 11/2/2012 13:07'! testBlock self assert: ([ 1 ] isKindOf: BlockClosure). self assert: [ 1 ] value = 1. self assert: [^1] value = 1. self assert: [ 1 + 2 ] value = 3. self assert: (true ifTrue: [ 1 ] ifFalse: [ 0 ]) = 1. self assert: (false ifTrue: [ 1 ] ifFalse: [ 0 ]) = 0. ! ! !PharoVMInterpreterTest methodsFor: 'tricky asserting' stamp: 'ClementBera 11/2/2012 13:21'! testExceptionHandling self assert: ([ ] on: Error do: [ :err| false ]) = nil. self assert: [[ ] on: Error do: [ :err| false ]. true] value = true. self assert: [[ ] on: Error do: [ :err| ^ false ]. true] value = true. self assert: ([ Error signal ] on: Error do: [ :err| false ]) = false. self assert: [[ Error signal ] on: Error do: [ :err| false ]. true] value = true. self assert: [[ Error signal ] on: Error do: [ :err| ^ false ]. true] value = false. self assert: ([[ Error signal ] value ] on: Error do: [ :err| false ]) = false. self assert: [[[ Error signal ] value ] on: Error do: [ :err| false ]. true] value = true. self assert: [[[ Error signal ] value ] on: Error do: [ :err| ^ false ]. true] value = false. self assert: ([self errorBlock value] on: Error do: [:err | false]) equals: false. self assert: [[self errorBlock value ] on: Error do: [ :err| false ]. true] value = true. self assert: [[self errorBlock value ] on: Error do: [ :err| ^ false ]. true] value = false.! ! !PharoVMInterpreterTest methodsFor: 'basic asserting' stamp: 'ClementBera 11/2/2012 13:29'! testUnarySend self assert: 1 asInteger = 1. self assert: 1 class = SmallInteger.! ! !PharoVMInterpreterTest methodsFor: 'tricky asserting' stamp: 'ClementBera 11/2/2012 13:17'! testEnsure self assert: ([ ] ensure: [ 2 ]) = nil. self assert: ([ 1 ] ensure: [ 2 ]) = 1. self assert: [[ 1 ] ensure: [ 2 ]. 3] value = 3. self assert: [[ 1 ] ensure: [ ^ 2 ]. 3] value = 2. self assert: [[ ^ 1 ] ensure: [ ^ 2 ]. 3] value = 2. self should: [ [ Error signal ] ensure: [ ^ 2 ]. 3 ] raise: InterpretationError. self should: [ [ [Error signal] value ] ensure: [ ^ 2 ]. 3 ] raise: InterpretationError! ! !PharoVMInterpreterTest methodsFor: 'basic asserting' stamp: 'ClementBera 11/2/2012 13:08'! testBlockVar self assert: [ |a| a := 1. a ] value = 1. self assert: [ |a| a := 1 + 2. a + 3 ] value = 6. self assert: [ |a| [ a := 1 ] value ] value = 1. self assert: [ |a| a := 1. [ a := 2 ] value ] value = 2. self assert: [ |a| a := 1. [ a := a + 1 ] value ] value = 2. self assert: ([ :b ||a| a := 1. [ :c| a := a + 1 + c ] value: b ] value: 3) = 5! ! !PharoVMInterpreterTest methodsFor: 'basic asserting' stamp: 'ClementBera 11/2/2012 13:28'! testSend self assert: (#(1 2) at: 1) = 1. self assert: 1 + 2 = 3. "this is for future use :)" self assert: 123 asString = '123'.! ! !PharoVMInterpreterTest methodsFor: 'basic asserting' stamp: 'ClementBera 11/2/2012 09:59'! testBasicCode self assert: [ true ifTrue: [ nil ] ifFalse: [ 1 ]] value equals: nil. self assert: [ false ifTrue: [ nil ] ifFalse: [ 1 ]] value equals: 1. self assert: [ |a| a :=1. [ a < 10 ] whileTrue: [ a := a + 1]. a] value equals: 10.! ! !PharoVMInterpreterTest methodsFor: 'basic asserting' stamp: 'ClementBera 11/2/2012 10:01'! testBinarySend self assert: 1 + 2 equals: 3. self assert: 1 < 2 equals: true.! ! !PharoVMInterpreterTest methodsFor: 'basic asserting' stamp: 'ClementBera 11/2/2012 13:07'! testBlockArgument self assert: ([ :a| a ] value: 1) = 1. self assert: ([ :a| a + 3 ] value: 3) = 6. ! ! !PharoVMInterpreterTest methodsFor: 'tricky asserting' stamp: 'ClementBera 11/2/2012 13:18'! testException [ Error signal: #anErrorHappened ] on: Error do: [ :err | self assert: (err isKindOf: Error). self assert: err messageText equals: #anErrorHappened. ^ #success ]. self fail.! ! !PharoVMInterpreterTest methodsFor: 'tricky asserting' stamp: 'ClementBera 11/2/2012 13:22'! testExceptionResume self assert: ([ 1 + Exception signal ] on: Exception do: [ :err| err resume: 5 ]) = 6. self assert: [[ 1 + Exception signal ] on: Exception do: [ :err| err resume: 5 ]. true] value = true.! ! !PharoVMInterpreterTest methodsFor: 'tricky asserting' stamp: 'ClementBera 11/2/2012 13:27'! testNonLocalReturnPart2 self should: [ ASTInterpreterTest new returningBlock value ] raise: BlockCannotReturn. self should: [ ASTInterpreterTest new errorBlock value ] raise: Error. self assert: (ASTInterpreterTest new block value) equals: 2.! ! !PharoVMInterpreterTest methodsFor: 'basic asserting' stamp: 'ClementBera 11/2/2012 13:27'! testPrimitive self assert: 1 + 1 = 2. "simple" self assert: 1 + 1.5 = 2.5. "with fallback"! ! !PharoVMInterpreterTest methodsFor: 'tricky asserting' stamp: 'ClementBera 11/2/2012 13:25'! testNonLocalReturn self assert: [false ifTrue: [ ^ 1 ]. ^ 1 + 1] value = 2. self assert: [true ifTrue: [ ^ 1 ]. ^ 1 + 1] value = 1. self assert: [false ifTrue: [ ^ 1 ] ifFalse: [^ 2]. 1 + 1 + 1] value = 2.! ! !PharoVMInterpreterTest methodsFor: 'tricky asserting' stamp: 'ClementBera 11/2/2012 13:10'! testDNU | error | [ 1 aMessageNotUnderstoodBySmallInteger ] on: Error do: [ :err| error := err ]. self assert: error message selector = #aMessageNotUnderstoodBySmallInteger.! ! !PickListModel commentStamp: ''! A PickList is a tick list done using spec.! !PickListModel methodsFor: 'protocol' stamp: ''! resetSelection listModel resetSelection! ! !PickListModel methodsFor: 'protocol' stamp: ''! itemFor: aCheckbox ^ associationsWrapperToItem at: aCheckbox ifAbsent: [ nil ]! ! !PickListModel methodsFor: 'protocol-events' stamp: 'StephaneDucasse 5/17/2012 19:32'! whenSelectionChanged: aBlock listModel whenSelectionChanged: aBlock! ! !PickListModel methodsFor: 'protocol' stamp: 'CamilloBruni 10/8/2012 21:56'! setSelectedIndex: anIndex listModel setSelectedIndex: anIndex! ! !PickListModel methodsFor: 'accessing' stamp: ''! listModel ^ listModel! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! labelClickable ^ labelClickableHolder value! ! !PickListModel methodsFor: 'accessing' stamp: ''! wrapHolder ^ wrapHolder! ! !PickListModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/23/2014 12:01'! initialize wrapHolder := [ :i | i printString ] asReactiveVariable. pickedItemsHolder := OrderedCollection new asReactiveVariable. associationsWrapperToItem := Dictionary new asReactiveVariable. associationsItemToWrapper := Dictionary new asReactiveVariable. associationsIndexToWrapper := Dictionary new asReactiveVariable. labelClickableHolder := true asReactiveVariable. defaultValueHolder := false asReactiveVariable. blockToPerformOnWrappers := [:wrapper | ] asReactiveVariable. super initialize.! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/22/2013 00:25'! indexFor: aCheckbox ^ listModel listItems indexOf: aCheckbox.! ! !PickListModel methodsFor: 'initialization' stamp: 'CamilloBruni 10/8/2012 22:23'! initializePresenter labelClickableHolder whenChangedDo: [:aBoolean | associationsWrapperToItem keys do: [:e | e labelClickable: aBoolean ]]. defaultValueHolder whenChangedDo: [:value | associationsWrapperToItem keysDo: [:cb | cb state: value ]].! ! !PickListModel methodsFor: 'protocol' stamp: ''! checkboxFor: anItem ^ associationsItemToWrapper at: anItem ifAbsent: [ nil ]! ! !PickListModel methodsFor: 'protocol-events' stamp: 'bvr 5/31/2012 13:34'! whenListChanged: aBlock listModel whenListChanged: aBlock! ! !PickListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! wrap: item at: index | checkBox | associationsIndexToWrapper at: index ifPresent: [:cb | ^ cb ]. checkBox := self instantiate: CheckBoxModel. blockToPerformOnWrappers value value: checkBox. checkBox label: (wrapHolder value cull: item cull: self). checkBox whenActivatedDo: [ self addPicked: item. listModel setSelectedItem: checkBox. listModel takeKeyboardFocus ]. checkBox whenDesactivatedDo: [ self removePicked: item. listModel setSelectedItem: checkBox. listModel takeKeyboardFocus ]. checkBox state: self defaultValue; labelClickable: self labelClickable. associationsWrapperToItem at: checkBox put: item. associationsItemToWrapper at: item put: checkBox. associationsIndexToWrapper at: index put: checkBox. ^ checkBox! ! !PickListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2013 16:46'! addPicked: item pickedItemsHolder add: item. pickedItemsHolder valueChanged: true to: item.! ! !PickListModel methodsFor: 'protocol' stamp: ''! selectedItem ^ associationsWrapperToItem at: listModel selectedItem ifAbsent: [ nil ]! ! !PickListModel methodsFor: 'protocol-events' stamp: 'bvr 5/31/2012 13:34'! whenSelectedItemChanged: aBlock | newBlock | newBlock := [ :item | aBlock cull: (associationsWrapperToItem at: item ifAbsent: [ nil ])]. listModel whenSelectedItemChanged: newBlock! ! !PickListModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! blockToPerformOnWrappers ^ blockToPerformOnWrappers value! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/21/2013 23:45'! wrappers ^ associationsWrapperToItem keys! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! defaultValue ^ defaultValueHolder value! ! !PickListModel methodsFor: 'protocol' stamp: ''! selectedIndex ^ listModel selectedIndex! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:05'! pickedItems "Returns the selected items according to the order they have been picked" ^ pickedItemsHolder value! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! labelClickable: aBoolean labelClickableHolder value: aBoolean! ! !PickListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/24/2013 14:18'! removePicked: item pickedItemsHolder remove: item ifAbsent: [ ^ self ].! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! defaultValue: aBoolean defaultValueHolder value: aBoolean! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! displayBlock: aBlock wrapHolder value: aBlock! ! !PickListModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 9/25/2013 18:24'! initializeWidgets self instantiateModels: #( listModel #ListModel ). listModel displayBlock: [ :item | item ]. self focusOrder add: listModel! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/6/2013 19:06'! selectedItems "Returns the selected items according to the list order" | wrappers items | wrappers := listModel listItems. items := wrappers collect: [:e || value | value := associationsWrapperToItem at: e ifAbsent: [ nil ]. (value isNil or: [ e state not ]) ifTrue: [ nil ] ifFalse: [ value ]] thenSelect: [ :e | e notNil ]. ^ items! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/24/2013 14:18'! items: aCollection associationsWrapperToItem removeAll. pickedItemsHolder removeAll. listModel items: (aCollection collectWithIndex: [:e :i | self wrap: e at: i ]).! ! !PickListModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/17/2013 16:06'! blockToPerformOnWrappers: aBlock blockToPerformOnWrappers value: aBlock! ! !PickListModel methodsFor: 'protocol-events' stamp: 'bvr 5/31/2012 13:34'! whenSelectionIndexChanged: aBlock listModel whenSelectionIndexChanged: aBlock! ! !PickListModel methodsFor: 'protocol-events' stamp: 'bvr 5/31/2012 13:34'! whenPickedItemsChanged: aBlock pickedItemsHolder whenChangedDo: aBlock! ! !PickListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 6/12/2012 18:32'! defaultSpec ^ SpecLayout composed add: #listModel; yourself! ! !PickListModel class methodsFor: 'example' stamp: ''! example "self example" | instance | instance := self new. instance openWithSpec. instance items: { {1. 2. 4}. 'Foo'. 123}! ! !PickListModel class methodsFor: 'specs' stamp: ''! title ^ 'Pick List Example'! ! !PickOneSettingDeclaration commentStamp: 'AlainPlantec 1/3/2011 10:53'! A CheckListSettingDeclaration is a setting for which the value domain is a list. Each element of the list is an instance of FixedSettingValue. If domainValues is set, then the list of valid values is constant (initialized at declaration time). Instead, if getter is set, then the setting list is always dynamically computed. See SettingManager comment for more explanations. Instance Variables ! !PickOneSettingDeclaration methodsFor: 'user interface' stamp: 'alain.plantec 10/17/2009 23:44'! index self realValue ifNil: [self realValue: self default]. ^ self domainValues indexOf: (self domainValues detect: [:dv | dv realValue = self realValue] ifNone: [^ 0])! ! !PickOneSettingDeclaration methodsFor: 'user interface' stamp: 'FernandoOlivero 4/12/2011 10:11'! inputWidget | widget row | row := self theme newRowIn: World for: { widget := (self theme newDropListIn: World for: self list: #domainValuesLabels getSelected: #index setSelected: #index: getEnabled: #enabled useIndex: true help: self description) extent: 1 @ 30}. widget hResizing: #rigid. widget width: (self maxNameWidthForFont: widget font) + 50. ^ row! ! !PickOneSettingDeclaration methodsFor: 'user interface' stamp: 'AlainPlantec 11/30/2009 14:23'! chooseValue | chosen | chosen := UIManager default chooseFrom: self domainValuesLabels values: self domainValues title: self label translated, ' choices' translated. chosen ifNotNil: [self realValue: chosen realValue]! ! !PickOneSettingDeclaration methodsFor: 'user interface' stamp: 'alain.plantec 10/17/2009 23:47'! content ^ (self domainValues detect: [:v | v realValue = self realValue] ifNone: [^ 'nil']) name! ! !PickOneSettingDeclaration methodsFor: 'user interface' stamp: 'alain.plantec 10/17/2009 23:39'! index: anInteger self realValue: (self domainValues at: anInteger) realValue. ! ! !PickOneSettingDeclaration methodsFor: 'user interface' stamp: 'AlainPlantec 9/3/2010 11:19'! defaultValue ^ self default value ifNil: [self domainValues first realValue] ! ! !PlainGroupboxMorph commentStamp: 'gvc 5/18/2007 12:36'! Groupbox without title with a vertical layout. Appears in a lighter colour than the owner's pane colour.! !PlainGroupboxMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/17/2008 11:45'! adoptPaneColor: paneColor "Change our color too." super adoptPaneColor: (self theme subgroupColorFrom: paneColor). self borderStyle: (self theme plainGroupPanelBorderStyleFor: self)! ! !PlainGroupboxMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 9/7/2013 12:39'! initialize "Initialize the receiver." super initialize. self borderStyle: (self theme plainGroupPanelBorderStyleFor: self); changeTableLayout; layoutInset: 4; cellInset: 8; vResizing: #spaceFill; hResizing: #spaceFill! ! !PlainGroupboxMorph methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 12/11/2009 07:41'! paneColorOrNil "Answer the window's pane color or nil otherwise." ^super paneColorOrNil ifNotNil: [:c | self theme subgroupColorFrom: c]! ! !PlatformIndependentEnvironment commentStamp: 'EstebanLorenzano 1/24/2014 16:41'! I'm a platform independent environment who is intent to work when none other works. Specially, I'm intended to work as a replacement for environments when there is no NativeBoost present, therefore I provide stubs for method calls that answers just default values. ! !PlatformIndependentEnvironment methodsFor: 'private' stamp: 'EstebanLorenzano 1/24/2014 16:36'! getEnv: aVariableName ^ nil! ! !PlatformIndependentEnvironment methodsFor: 'enumeration' stamp: 'EstebanLorenzano 1/24/2014 16:36'! keysAndValuesDo: aBlock "Do nothing"! ! !PlatformIndependentEnvironment methodsFor: 'private' stamp: 'EstebanLorenzano 1/24/2014 16:37'! unsetEnv: aString ^ self setEnv: aString value: nil! ! !PlatformIndependentEnvironment methodsFor: 'private' stamp: 'EstebanLorenzano 1/24/2014 16:37'! setEnv: nameString value: valueString "Do nothing"! ! !PlatformIndependentEnvironment class methodsFor: 'testing' stamp: 'EstebanLorenzano 1/24/2014 16:40'! isAvailable ^ true! ! !PlatformIndependentEnvironment class methodsFor: 'testing' stamp: 'EstebanLorenzano 1/24/2014 16:40'! isDefaultFor: aPlatform ^ false! ! !PlatformResolver commentStamp: 'cwp 11/18/2009 11:56'! I am an abstract superclass for platform-specific resolvers.! !PlatformResolver methodsFor: 'origins' stamp: 'CamilloBruni 5/24/2012 12:07'! preferences ^ self subclassResponsibility! ! !PlatformResolver methodsFor: 'private' stamp: 'cami 7/22/2013 18:17'! directoryFromEnvVariableNamed: aString or: aBlock | envValue | envValue := [ Smalltalk os environment at: aString ] on: Error do: [ ^ aBlock value ]. ^ envValue isEmptyOrNil ifTrue: [ aBlock value ] ifFalse: [ self resolveString: envValue ]! ! !PlatformResolver methodsFor: 'origins' stamp: 'cwp 10/27/2009 21:01'! home ^ self subclassResponsibility! ! !PlatformResolver methodsFor: 'origins' stamp: 'DamienCassou 6/28/2013 14:40'! cache "Operating Systems often define standard locations for a personal cache directory. The cache directory is a user-specific non-essential (cached) place where data should be written." self subclassResponsibility! ! !PlatformResolver methodsFor: 'origins' stamp: 'lr 7/13/2010 15:35'! desktop ^ self subclassResponsibility! ! !PlatformResolver methodsFor: 'origins' stamp: 'DamienCassou 12/20/2013 11:50'! temp "Where to put files that are not supposed to last long" ^ self subclassResponsibility ! ! !PlatformResolver methodsFor: 'origins' stamp: 'lr 7/13/2010 15:35'! documents ^ self subclassResponsibility! ! !PlatformResolver methodsFor: 'resolving' stamp: 'DamienCassou 12/20/2013 11:51'! supportedOrigins ^ #(home desktop documents preferences cache temp)! ! !PlatformResolver methodsFor: 'private' stamp: 'DamienCassou 7/4/2013 15:44'! cantFindOriginError ^ Error signal: 'Can''t find the requested origin' ! ! !PlatformResolver methodsFor: 'private' stamp: 'DamienCassou 7/4/2013 15:47'! directoryFromEnvVariableNamed: aString ^ self directoryFromEnvVariableNamed: aString or: [ self cantFindOriginError ]! ! !PlatformResolver class methodsFor: 'private' stamp: 'CamilloBruni 8/12/2011 17:36'! primitiveGetUntrustedUserDirectory self primitiveFailed. self flag: 'use a more decent way to get a path in the users home directory'.! ! !PlatformResolver class methodsFor: 'accessing' stamp: 'cwp 10/27/2009 10:58'! platformName ^ nil! ! !PlatformResolver class methodsFor: 'instance creation' stamp: 'tg 11/8/2010 19:05'! forCurrentPlatform | platformName | platformName := Smalltalk os platformName. ^ (self allSubclasses detect: [:ea | ea platformName = platformName]) new! ! !PlatformResolverTest commentStamp: 'TorstenBergmann 1/31/2014 11:36'! SUnit tests for PlatformResolver! !PlatformResolverTest methodsFor: 'tests' stamp: 'DamienCassou 6/28/2013 14:38'! testCache | cache | cache := self assertOriginResolves: #cache! ! !PlatformResolverTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/2/2012 11:39'! createResolver ^ PlatformResolver forCurrentPlatform! ! !PlatformResolverTest methodsFor: 'tests' stamp: 'DamienCassou 6/28/2013 14:35'! testHome | home | home := self assertOriginResolves: #home. self assert: home isDirectory! ! !PluggableButtonMorph commentStamp: ''! A PluggableButtonMorph is a combination of an indicator for a boolean value stored in its model and an action button. The action of a button is often, but not always, to toggle the boolean value that it shows. Its pluggable selectors are: getStateSelector fetch a boolean value from the model actionSelector invoke this button's action on the model getLabelSelector fetch this button's lable from the model getMenuSelector fetch a pop-up menu for this button from the model Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if getStateSelector is nil, then this button shows the state of a read-only boolean that is always false. The model informs its view(s) of changes by sending #changed: to itself with getStateSelector as a parameter. The view tells the model when the button is pressed by sending actionSelector. If the actionSelector takes one or more arguments, then the following are relevant: arguments A list of arguments to provide when the actionSelector is called. argumentsProvider The object that is sent the argumentSelector to obtain arguments, if dynamic argumentsSelector The message sent to the argumentProvider to obtain the arguments. Options: askBeforeChanging have model ask user before allowing a change that could lose edits triggerOnMouseDown do this button's action on mouse down (vs. up) transition shortcutCharacter a place to record an optional shortcut key ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 3/4/2010 12:17'! borderStyleToUse "Return the borderStyle to use for the receiver." self gradientLook ifFalse:[^super borderStyle]. ^self perform: (self availableBorderStyles at: ( self interactionStates indexOf: self interactionState)) ! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! selectedFillStyle "Return the selected fillStyle of the receiver." ^self theme buttonSelectedFillStyleFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:35'! onColor: colorWhenOn offColor: colorWhenOff "Set the fill colors to be used when this button is on/off." onColor := colorWhenOn. offColor := colorWhenOff. self update: #onOffColor. self update: getStateSelector. ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2007 15:53'! disabledBorderStyle "Return the disabled borderStyle of the receiver." ^self theme buttonDisabledBorderStyleFor: self! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! pressedBorderStyle "Return the pressed borderStyle of the receiver." ^self theme buttonPressedBorderStyleFor: self! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! selectedPressedBorderStyle "Return the selected pressed borderStyle of the receiver." ^self theme buttonSelectedPressedBorderStyleFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/31/2013 13:10'! color: aColor "Check to avoid repeats of the same color." aColor ifNil: [^self]. (lastColor = aColor and: [ self getModelState = (self valueOfProperty: #lastState)]) ifTrue: [^self]. super color: aColor. self class gradientButtonLook ifTrue: [self adoptColor: aColor]! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'gvc 5/8/2006 13:40'! handlesMouseOver: evt ^ true! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/2/2012 11:40'! performAction "backward compatibility" self performAction: nil! ! !PluggableButtonMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/5/2014 02:33'! initialize "Initialize the state of the receiver." super initialize. self rubberBandCells: false; listDirection: #topToBottom; hResizing: #shrinkWrap; vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #center. enabled := true. self initializeLabelMorph. "this is a safe guard for enabled: among others." askBeforeChanging := false. triggerOnMouseDown := false. showSelectionFeedback := false. arguments := #(). self layoutInset: (self theme buttonLabelInsetFor: self); borderStyle: BorderStyle thinGray; extent: 20 @ 15; setProperty: #lastState toValue: false; cornerStyle: (self theme buttonCornerStyleIn: nil). self clipSubmorphs: true! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 12/28/2000 16:19'! offColor: colorWhenOff "Set the fill colors to be used when this button is off." self onColor: onColor offColor: colorWhenOff ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 1/23/2007 11:25'! action "Answer the action selector." ^self actionSelector! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:53'! mouseOverBorderStyle "Return the mouse over borderStyle of the receiver." ^self theme buttonMouseOverBorderStyleFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2007 15:54'! selectedDisabledBorderStyle "Return the selected disabled borderStyle of the receiver." ^self theme buttonSelectedDisabledBorderStyleFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 1/10/2007 12:17'! isDefault: aBoolean "Set whether the button is to be considered default." aBoolean ifTrue: [self setProperty: #isDefault toValue: true] ifFalse: [self removeProperty: #isDefault]. self changed! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! selectedPressedFillStyle "Return the selected pressed fillStyle of the receiver." ^self theme buttonSelectedPressedFillStyleFor: self! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/2/2010 17:36'! paneColorChanged "Use changed to update the appearance." self changed! ! !PluggableButtonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:39'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/2/2012 11:20'! performAction: event "Inform the model that this button has been pressed. Sent by the controller when this button is pressed. If the button's actionSelector takes any arguments, they are obtained dynamically by sending the argumentSelector to the argumentsProvider" enabled ifFalse: [^self]. askBeforeChanging ifTrue: [model okToChange ifFalse: [^ self]]. self actionBlock ifNotNil: [ ^ self actionBlock cull: event ]. actionSelector ifNotNil: [actionSelector numArgs = 0 ifTrue: [model perform: actionSelector] ifFalse: [argumentsProvider ifNotNil: [arguments := argumentsProvider perform: argumentsSelector]. model perform: actionSelector withArguments: arguments]]! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 17:47'! feedbackColor: aColor "Set the color of this button's selection feedback border." feedbackColor := aColor. self changed. ! ! !PluggableButtonMorph methodsFor: 'private' stamp: 'GuillermoPolito 5/29/2011 14:52'! getMenu: shiftPressed "Answer the menu for this button, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | menu | getMenuSelector isNil ifTrue: [^nil]. menu := UIManager default newMenuIn: self for: model. getMenuSelector numArgs = 1 ifTrue: [^model perform: getMenuSelector with: menu]. getMenuSelector numArgs = 2 ifTrue: [^model perform: getMenuSelector with: menu with: shiftPressed]. ^self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'AlainPlantec 12/13/2009 13:24'! gradientLook: aBoolean gradientLook := aBoolean! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 12/4/2007 16:23'! focusBounds "Answer the bounds for drawing the focus indication." ^self theme buttonFocusBoundsFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:11'! disable "Disable the button." self enabled: false! ! !PluggableButtonMorph methodsFor: 'updating' stamp: 'gvc 7/24/2007 16:14'! adoptColor: aColor "Go through paneColorChanged instead." self paneColorChanged! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:30'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: ''! action: aSymbol "Set actionSelector to be the action defined by aSymbol." actionSelector := aSymbol. ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 3/4/2010 12:16'! availableBorderStyles "Return the selectors of the the available border styles for each state. Must match the order of interactionStates." ^#(normalBorderStyle mouseOverBorderStyle pressedBorderStyle disabledBorderStyle selectedBorderStyle selectedPressedBorderStyle selectedMouseOverBorderStyle selectedDisabledBorderStyle)! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:26'! getColorSelector: aSymbol getColorSelector := aSymbol. self update: getColorSelector.! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'StephaneDucasse 12/16/2011 17:57'! mouseEnter: evt "Update the appearance." self setProperty: #mouseEntered toValue: true. self gradientLook ifTrue: [self changed] ifFalse: ["0.09375 is exact in floating point so no cumulative rounding error will occur" self color: (self color adjustBrightness: -0.09375)]. super mouseEnter: evt! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'GuillermoPolito 5/23/2012 11:40'! keyboardFocusChange: aBoolean "The message is sent to a morph when its keyboard focus changes. Update for focus feedback." super keyboardFocusChange: aBoolean. self focusChanged! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 7/1/2010 15:16'! fillStyleToUse "Return the fillStyle to use for the receiver." ^self perform: (self availableFillStyles at: ( self interactionStates indexOf: self interactionState)) ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 12/28/2000 16:17'! actionSelector "Answer the receiver's actionSelector" ^ actionSelector! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 4/25/2007 18:44'! onColor "Answer the on color." ^onColor ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 6/8/2009 14:26'! showSelectionFeedback "Answer whether the feedback should be shown for being pressed." ^showSelectionFeedback! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'! shortcutCharacter "Return the Character to be used as a shortcut to turn on this switch, or nil if this switch doesn't have a keyboard shortcut." ^ shortcutCharacter ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:29'! getEnabledSelector: aSymbol getEnabledSelector := aSymbol. self update: aSymbol.! ! !PluggableButtonMorph methodsFor: 'drawing' stamp: 'StephaneDucasse 5/31/2013 17:51'! drawSubmorphsOn: aCanvas "Display submorphs back to front. Draw the focus here since we are using inset bounds for the focus rectangle." super drawSubmorphsOn: aCanvas. self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 5/2/2012 11:20'! mouseUp: evt "Perform the button action if the mouse pointer is in a button in the group. Optimised feedback updates." |all| all := allButtons copy. all ifNotNil: [all do: [:m | m showSelectionFeedback ifTrue: [ m showSelectionFeedback: false; changed; layoutChanged]]]. all ifNil: [^ self]. allButtons := nil. all do: [:m | (m containsPoint: evt cursorPoint) ifTrue: [m enabled ifTrue: [ m performAction: evt ]]]. self showSelectionFeedback ifTrue: [self changed] ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 1/11/2007 15:00'! focusColor "Answer the keyboard focus indication color." ^self color contrastingColor! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:53'! mouseOverFillStyle "Return the mouse over fillStyle of the receiver." ^self theme buttonMouseOverFillStyleFor: self! ! !PluggableButtonMorph methodsFor: 'private' stamp: 'RAA 6/12/2000 09:04'! invokeMenu: evt "Invoke my menu in response to the given event." | menu | menu := self getMenu: evt shiftPressed. menu ifNotNil: [menu popUpEvent: evt in: self world]! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/11/2009 16:40'! roundedCorners: anArray "Adjust the layout inset if necessary." super roundedCorners: anArray. self layoutInset: (self theme buttonLabelInsetFor: self)! ! !PluggableButtonMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 16:53'! veryDeepFixupWith: deepCopier "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. model := deepCopier references at: model ifAbsent: [model]. ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 18:53'! askBeforeChanging ^ askBeforeChanging ! ! !PluggableButtonMorph methodsFor: 'updating' stamp: 'GaryChambers 4/13/2012 13:40'! changed "Update the fillStyle here." |lc pc bs| self assureExtension. extension borderStyle: (bs := self borderStyleToUse). borderColor := bs style. borderWidth := bs width. extension fillStyle: self fillStyleToUse. self layoutInset: (self theme buttonLabelInsetFor: self). color := self fillStyle asColor. (self labelMorph respondsTo: #interactionState:) ifTrue: [self labelMorph interactionState: self interactionState] ifFalse: [(self labelMorph isNil or: [label isMorph]) ifFalse: [ pc := self normalColor. lc := self enabled ifTrue: [pc contrastingColor] ifFalse: [pc contrastingColor muchDarker]. self labelMorph color: lc]]. super changed! ! !PluggableButtonMorph methodsFor: 'updating' stamp: 'StephaneDucasse 5/31/2013 18:27'! updateLabelEnablement "Set the enabled state of the label if possible." self labelMorph enabled: self enabled! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 12/3/2008 17:22'! minWidth "Consult the theme also." ^super minWidth max: self theme buttonMinWidth! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/15/2009 12:23'! showSelectionFeedback: aBoolean "Set the feedback." showSelectionFeedback := aBoolean! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'FernandoOlivero 4/12/2011 10:12'! gradientLook ^ gradientLook ifNil: [gradientLook := self theme currentSettings preferGradientFill]! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'jrp 7/3/2005 18:13'! mouseLeaveDragging: evt self mouseLeave: evt! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/7/98 19:17'! askBeforeChanging: aBoolean "If this preference is turned on, then give the model an opportunity to ask the user before accepting a change that might cause unaccepted edits to be lost." askBeforeChanging := aBoolean. ! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! newLabel "Answer a new label for the receiver." ^self theme buttonLabelFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 3/4/2010 12:15'! availableFillStyles "Return the selectors of the the available fill styles for each state. Must match the order of interactionStates." ^#(normalFillStyle mouseOverFillStyle pressedFillStyle disabledFillStyle selectedFillStyle selectedPressedFillStyle selectedMouseOverFillStyle selectedDisabledFillStyle)! ! !PluggableButtonMorph methodsFor: 'updating' stamp: 'gvc 6/8/2009 14:22'! updateFeedbackForEvt: evt | newState | newState := self containsPoint: evt cursorPoint. newState = showSelectionFeedback ifFalse: [ self showSelectionFeedback: newState. self changed; layoutChanged]. ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 2/11/2009 16:42'! cornerStyle: aSymbol "Adjust the layout inset." super cornerStyle: aSymbol. self layoutInset: (self theme buttonLabelInsetFor: self)! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 4/24/2007 13:34'! model "Answer the receiver's model." ^model! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:38'! label "Answer the DisplayObject used as this button's label." ^ label ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/31/2013 18:05'! label: aStringOrTextOrMorph font: aFont "Label this button with the given string or morph." | r | self removeAllMorphs. "nest label in a row for centering" r := AlignmentMorph newRow borderWidth: 0; layoutInset: 0; color: Color transparent; hResizing: #shrinkWrap; vResizing: #spaceFill; wrapCentering: #center; listCentering: #center; cellPositioning: #center. label := aStringOrTextOrMorph. labelMorph := aStringOrTextOrMorph isMorph ifTrue: [ aStringOrTextOrMorph ] ifFalse: [ self newLabel: aFont ]. r addMorph: labelMorph. self addMorph: r. self labelMorph enabled: self enabled. self updateLabelEnablement ! ! !PluggableButtonMorph methodsFor: 'compatibility' stamp: 'BenjaminVanRyseghem 7/25/2012 11:55'! isMorphicModel ^ true! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 5/2/2012 11:20'! mouseDown: evt "Details: If this button is triggered on mouse down or the event is the menu gesture, handle it immediately. Otherwise, make a list of buttons (including the receiver) for mouseMove feedback. This allows a simple radio-button effect among the button submorphs of a given morph." self enabled ifFalse: [^self]. allButtons := nil. evt yellowButtonPressed ifTrue: [^ self invokeMenu: evt]. self wantsKeyboardFocusOnMouseDown ifTrue: [self takeKeyboardFocus]. triggerOnMouseDown ifTrue: [ self performAction: evt ] ifFalse: [ allButtons := owner submorphs select: [:m | m class = self class]. self updateFeedbackForEvt: evt]. ! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/9/2009 17:47'! focusIndicatorCornerRadius "Answer the corner radius preferred for the focus indicator for the receiver for themes that support this." ^self theme buttonFocusIndicatorCornerRadiusFor: self ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 1/23/2007 11:27'! arguments "Answer the static arguments. SimpleButtonMorph cross-compatibility." ^arguments! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'MarcusDenker 2/29/2012 17:28'! target ^model! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! selectedMouseOverBorderStyle "Return the selected mouse over borderStyle of the receiver." ^self theme buttonSelectedMouseOverBorderStyleFor: self! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'MarcusDenker 11/22/2012 22:04'! themeChanged "Set the border style to thin gray in the case of going to StandardSqueak." |labelColor| self layoutInset: (self theme buttonLabelInsetFor: self); cornerStyle: (self theme buttonCornerStyleIn: self window). (self labelMorph isNil or: [self label isMorph or: [self labelMorph isTextMorph]]) ifFalse: [ labelColor := self labelMorph color. self label: self label font: self labelMorph font. self labelMorph color: labelColor]. super themeChanged! ! !PluggableButtonMorph methodsFor: 'initialization' stamp: 'AlainPlantec 12/16/2009 12:32'! defaultColor "answer the default color/fill style for the receiver" ^ self containingWindow ifNil: [Color lightGreen] ifNotNil: [:w | w defaultBackgroundColor]! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:11'! enabled ^ enabled ifNil: [enabled := true]! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'GaryChambers 7/5/2010 14:22'! keyStroke: event "Process spacebar for action and tab keys for navigation." (self navigationKey: event) ifTrue: [^self]. (event keyCharacter = Character space or: [event keyCharacter = Character cr]) ifTrue: [self performAction]! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/4/2010 12:14'! interactionStates "Return all the states that the receiver may be in at any given moment." ^#(normal mouseOver pressed disabled selected selectedPressed selectedMouseOver selectedDisabled)! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'! shortcutCharacter: aCharacter "Set the character to be used as a keyboard shortcut for turning on this switch." shortcutCharacter := aCharacter. ! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'jm 5/4/1998 16:57'! handlesMouseDown: evt ^ true ! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 12/10/2009 07:20'! layoutBounds: aRectangle "Set the bounds for laying out children of the receiver. Update the fillstyle since it may depend on the bounds." super layoutBounds: aRectangle. self gradientLook ifTrue: [ self fillStyle isOrientedFill ifTrue: [self fillStyle: self fillStyleToUse]]! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/28/2011 13:34'! getModelState "Answer the result of sending the receiver's model the getStateSelector message. If the selector expects arguments then supply as for the actionSelector." model ifNil: [^ false]. ^getStateSelector ifNil: [false] ifNotNil: [getStateSelector numArgs = 0 ifTrue: [model perform: getStateSelector] ifFalse: [argumentsProvider ifNotNil: [ arguments := argumentsProvider perform: argumentsSelector]. model perform: getStateSelector withEnoughArguments: arguments]]! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/21/2009 12:59'! on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel "Set up the pluggable parameters. Update label and state." self model: anObject. getStateSelector := getStateSel. actionSelector := actionSel. getLabelSelector := labelSel. getMenuSelector := menuSel. self update: labelSel; update: getStateSel ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:11'! enable "Enable the button." self enabled: true! ! !PluggableButtonMorph methodsFor: 'copying' stamp: 'sw 2/17/2002 05:29'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. "model := model. Weakly copied" label := label veryDeepCopyWith: deepCopier. "getStateSelector := getStateSelector. a Symbol" "actionSelector := actionSelector. a Symbol" "getLabelSelector := getLabelSelector. a Symbol" "getMenuSelector := getMenuSelector. a Symbol" shortcutCharacter := shortcutCharacter veryDeepCopyWith: deepCopier. askBeforeChanging := askBeforeChanging veryDeepCopyWith: deepCopier. triggerOnMouseDown := triggerOnMouseDown veryDeepCopyWith: deepCopier. offColor := offColor veryDeepCopyWith: deepCopier. onColor := onColor veryDeepCopyWith: deepCopier. feedbackColor := feedbackColor veryDeepCopyWith: deepCopier. showSelectionFeedback := showSelectionFeedback veryDeepCopyWith: deepCopier. allButtons := nil. "a cache" arguments := arguments veryDeepCopyWith: deepCopier. argumentsProvider := argumentsProvider veryDeepCopyWith: deepCopier. argumentsSelector := argumentsSelector. " a Symbol" ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/31/2013 18:26'! label: aStringOrTextOrMorph "Label this button with the given string or morph." self label: aStringOrTextOrMorph font: self theme buttonFont! ! !PluggableButtonMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 5/31/2013 18:39'! initializeLabelMorph labelMorph := Morph new color: Color transparent; extent: 0 @ 0; yourself "this is a safe guard for enabled: among others."! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 1/23/2007 11:26'! actionSelector: aSymbol "Set actionSelector to be the action defined by aSymbol. SimpleButtonMorph cross-compatibility" actionSelector := aSymbol. ! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'gvc 1/11/2007 14:37'! handlesKeyboard: evt "Answer true, we'll handle spacebar for pressing plus the usual tab navigation." ^true! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 4/13/2007 15:53'! getMenuSelector: aSymbol "Set the menu selector." getMenuSelector := aSymbol! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'GaryChambers 10/17/2011 16:03'! wantsKeyboardFocusOnMouseDown "Answer whether the receiver would like keyboard focus on a mouse down event. use a property here for apps that want to take keyboard focus when the button is pressed (so that other morphs can, e.g. accept on focus change)." ^self wantsKeyboardFocus and: [self valueOfProperty: #wantsKeyboardFocusOnMouseDown ifAbsent: [false]]! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2007 15:54'! selectedBorderStyle "Return the selected borderStyle of the receiver." ^self theme buttonSelectedBorderStyleFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 19:26'! triggerOnMouseDown ^ triggerOnMouseDown ! ! !PluggableButtonMorph methodsFor: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:53'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation. aKMDispatcher attachCategory: #PluggableButtonMorph! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! selectedMouseOverFillStyle "Return the selected mouse over fillStyle of the receiver." ^self theme buttonSelectedMouseOverFillStyleFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:17'! actionBlock ^ actionBlock ! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! selectedDisabledFillStyle "Return the selected disabled fillStyle of the receiver." ^self theme buttonSelectedDisabledFillStyleFor: self! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 14:40'! newLabel: aFont "Answer a new label for the receiver with the given font." ^self newLabel font: aFont! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 16:52'! model: anObject "Set my model and make me me a dependent of the given object." model ifNotNil: [model removeDependent: self]. anObject ifNotNil: [anObject addDependent: self]. model := anObject. ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:19'! actionBlock: aBlock "an action can be either specified by a block or a selector. If the block is set it takes priority over selector." actionBlock := aBlock! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! normalBorderStyle "Return the normal borderStyle of the receiver." ^self theme buttonNormalBorderStyleFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2009 14:08'! colorToUse "Answer the color we should use." |c| c := self getModelState ifTrue: [onColor ifNil: [self paneColor] ifNotNil: [onColor isTransparent ifTrue: [self paneColor] ifFalse: [onColor]]] ifFalse: [offColor ifNil: [self paneColor] ifNotNil: [offColor isTransparent ifTrue: [self paneColor] ifFalse: [offColor]]]. ^c! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! normalColor "Return the normal colour for the receiver." ^self theme buttonColorFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 10/25/1999 14:36'! offColor ^ offColor ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 1/10/2007 12:13'! isDefault "Answer whether the button is considered to be a default one." ^self valueOfProperty: #isDefault ifAbsent: [false] ! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'StephaneDucasse 12/16/2011 17:54'! interactionState "Return the state that the receiver is in, #pressed, #normal etc.." |state mo| state := self getModelState. mo := (self valueOfProperty: #mouseEntered) == true. ^(self enabled ifNil: [true]) ifTrue: [showSelectionFeedback ifTrue: [state ifTrue: [#selectedPressed] ifFalse: [#pressed]] ifFalse: [mo ifTrue: [state ifTrue: [#selectedMouseOver] ifFalse: [#mouseOver]] ifFalse: [state ifTrue: [#selected] ifFalse: [#normal]]]] ifFalse: [state ifTrue: [#selectedDisabled] ifFalse: [#disabled]]! ! !PluggableButtonMorph methodsFor: 'updating' stamp: 'gvc 7/1/2010 15:13'! adoptPaneColor: aColor super adoptPaneColor: aColor. aColor ifNil: [^self]. self adoptColor: self colorToUse! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! normalFillStyle "Return the normal fillStyle of the receiver." ^self theme buttonNormalFillStyleFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:26'! getColorSelector ^getColorSelector! ! !PluggableButtonMorph methodsFor: 'arguments' stamp: 'sw 2/17/2002 05:29'! argumentsProvider: anObject argumentsSelector: aSelector "Set the argument provider and selector" argumentsProvider := anObject. argumentsSelector := aSelector! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'GaryChambers 12/7/2011 17:57'! enabled: aBoolean "Set the enabled state of the receiver." enabled = aBoolean ifTrue: [^self]. enabled := aBoolean. self updateLabelEnablement. self changed! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'jm 5/4/1998 17:30'! mouseMove: evt allButtons ifNil: [^ self]. allButtons do: [:m | m updateFeedbackForEvt: evt]. ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/7/98 19:16'! triggerOnMouseDown: aBoolean "If this preference is turned on, then trigger my action immediately when the mouse goes down." triggerOnMouseDown := aBoolean. ! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'gvc 5/8/2006 13:41'! handlesMouseOverDragging: evt ^ true! ! !PluggableButtonMorph methodsFor: 'private' stamp: 'MarcusDenker 5/5/2013 09:13'! browseAction | classDefiningAction | classDefiningAction := self model class whichClassIncludesSelector: self actionSelector. Smalltalk tools browser newOnClass: classDefiningAction selector: self actionSelector.! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/8/2007 13:43'! wantsKeyboardFocusNavigation "Answer whether the receiver would like keyboard focus when navigated to by keyboard." ^super wantsKeyboardFocusNavigation and: [ self valueOfProperty: #wantsKeyboardFocusNavigation ifAbsent: [true]]! ! !PluggableButtonMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/11/2013 15:18'! update: aParameter |state| aParameter ifNil: [^self]. getLabelSelector ifNotNil: [ aParameter == getLabelSelector ifTrue: [ self label: (model perform: getLabelSelector) ]]. state := self getModelState. (state ~= (self valueOfProperty: #lastState) or: [ getStateSelector isNil and: [aParameter == #onOffColor]]) ifTrue: [self color: self colorToUse. self setProperty: #lastState toValue: state]. aParameter == getEnabledSelector ifTrue: [^self enabled: (model perform: getEnabledSelector)]. getColorSelector ifNotNil: [ | cc | color = (cc := model perform: getColorSelector) ifFalse: [ color := cc. self onColor: color offColor: color. self changed ]]. aParameter isArray ifFalse: [ ^ self ]. aParameter size == 2 ifFalse: [ ^ self ]. aParameter first = #askBeforeChanging: ifTrue: [ self askBeforeChanging: aParameter second ]! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 12/10/2009 07:19'! extent: aPoint "Set the receiver's extent to value provided. Update the gradient fills." |answer| aPoint = self extent ifTrue: [^super extent: aPoint]. answer := super extent: aPoint. self gradientLook ifTrue: [ self fillStyle isOrientedFill ifTrue: [self fillStyle: self fillStyleToUse]]. ^answer! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:29'! getEnabledSelector ^getEnabledSelector! ! !PluggableButtonMorph methodsFor: 'drawing' stamp: 'gvc 9/11/2009 17:56'! indicateModalChild "Flash the button border." |fs c w d| fs := self fillStyle. c := self color alphaMixed: 0.5 with: Color black. w := self world. d := 0. self assureExtension. 2 timesRepeat: [ (Delay forDuration: d milliSeconds) wait. d := 200. extension fillStyle: c. color := c. self invalidRect: self bounds. w ifNotNil: [w displayWorldSafely]. (Delay forDuration: d milliSeconds) wait. self fillStyle: fs. w ifNotNil: [w displayWorldSafely]. self invalidRect: self bounds] ! ! !PluggableButtonMorph methodsFor: 'arguments' stamp: 'sw 2/17/2002 01:03'! arguments: args "If the receiver takes argument(s) that are static, they can be filled by calling this. If its argument(s) are to be dynamically determined, then use an argumentProvider and argumentSelector instead" arguments := args! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! pressedFillStyle "Return the pressed fillStyle of the receiver." ^self theme buttonPressedFillStyleFor: self! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 5/31/2013 18:06'! labelMorph "Answer the actual label morph." ^ labelMorph! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 12/3/2008 17:23'! minHeight "Consult the theme also." ^super minHeight max: self theme buttonMinHeight! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'StephaneDucasse 12/16/2011 17:57'! mouseLeave: evt "Update the appearance." self setProperty: #mouseEntered toValue: false. self gradientLook ifTrue: [self changed] ifFalse: ["0.09375 is exact in floating point so no cumulative rounding error will occur" self color: (self color adjustBrightness: 0.09375). self update: nil]. super mouseLeave: evt! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2007 15:53'! disabledFillStyle "Return the disabled fillStyle of the receiver." ^self theme buttonDisabledFillStyleFor: self! ! !PluggableButtonMorph methodsFor: 'private' stamp: 'SeanDeNigris 2/3/2012 11:50'! addStandardHaloMenuItemsTo: aMenu hand: aHandMorph aMenu add: 'browse action' translated action: #browseAction. aMenu addLine. super addStandardHaloMenuItemsTo: aMenu hand: aHandMorph.! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'gvc 1/19/2007 13:04'! contentHolder "Answer the alignment morph for extra control." ^self submorphs first! ! !PluggableButtonMorph class methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/10/2009 07:18'! gradientButtonLook: aBoolean UseGradientLook := aBoolean! ! !PluggableButtonMorph class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 4/12/2011 10:12'! gradientButtonLook ^ UseGradientLook ifNil: [UseGradientLook := self theme settings preferGradientFill]! ! !PluggableButtonMorph class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 3/19/2013 19:12'! buildPluggableButtonShortcutsOn: aBuilder (aBuilder shortcut: #action1) category: #PluggableButtonMorph default: Character space asKeyCombination | Character cr asKeyCombination do: [ :target :morph :event | morph performAction ].! ! !PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:28'! on: anObject getState: getStateSel action: actionSel ^ self new on: anObject getState: getStateSel action: actionSel label: nil menu: nil ! ! !PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:29'! on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel ^ self new on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel ! ! !PluggableButtonMorph class methodsFor: 'instance creation' stamp: ''! on: anObject ^ self on: anObject getState: #isOn action: #switch ! ! !PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:28'! on: anObject getState: getStateSel action: actionSel label: labelSel ^ self new on: anObject getState: getStateSel action: actionSel label: labelSel menu: nil ! ! !PluggableCanvas commentStamp: ''! An abstract canvas which modifies the behavior of an underlying canvas in some way. Subclasses should implement apply:, which takes a one argument block and an actual canvas to draw on. See apply: for the specific definition.! !PluggableCanvas methodsFor: 'drawing-support' stamp: 'ls 3/20/2000 19:59'! clipBy: newClipRect during: aBlock self apply: [ :c | c clipBy: newClipRect during: aBlock ]! ! !PluggableCanvas methodsFor: 'drawing-text' stamp: 'tween 3/10/2009 07:49'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc self apply: [ :clippedCanvas | clippedCanvas drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c underline: underline underlineColor: uc strikethrough: strikethrough strikethroughColor: sc]! ! !PluggableCanvas methodsFor: 'accessing' stamp: 'RAA 8/13/2000 18:57'! origin self apply: [ :c | ^c origin ]. ! ! !PluggableCanvas methodsFor: 'drawing' stamp: 'ls 3/20/2000 20:31'! line: pt1 to: pt2 width: w color: c self apply: [ :clippedCanvas | clippedCanvas line: pt1 to: pt2 width: w color: c ]! ! !PluggableCanvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:46'! roundCornersOf: aMorph in: bounds during: aBlock aMorph wantsRoundedCorners ifFalse:[^aBlock value]. (self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds)) ifTrue: ["Don't bother with corner logic if the region is inside them" ^ aBlock value]. CornerRounder roundCornersOf: aMorph on: self in: bounds displayBlock: aBlock borderWidth: aMorph borderWidthForRounding corners: aMorph roundedCorners! ! !PluggableCanvas methodsFor: 'drawing-support' stamp: 'ls 3/20/2000 20:37'! translateBy: delta during: aBlock self apply: [ :clippedCanvas | clippedCanvas translateBy: delta during: aBlock ]! ! !PluggableCanvas methodsFor: 'other' stamp: 'ls 3/20/2000 21:16'! flushDisplay self apply: [ :c | c flushDisplay ]! ! !PluggableCanvas methodsFor: 'drawing-ovals' stamp: 'ls 3/20/2000 20:03'! fillOval: r color: c borderWidth: borderWidth borderColor: borderColor self apply: [ :clippedCanvas | clippedCanvas fillOval: r color: c borderWidth: borderWidth borderColor: borderColor ]! ! !PluggableCanvas methodsFor: 'drawing-rectangles' stamp: 'IgorStasenko 7/18/2011 18:21'! fillRectangle: aRectangle basicFillStyle: aFillStyle "Fill the given rectangle with the given, non-composite, fill style." | pattern | (aFillStyle isKindOf: InfiniteForm) ifTrue: [ ^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle ]. aFillStyle isSolidFill ifTrue:[ ^self fillRectangle: aRectangle color: aFillStyle asColor]. "We have a very special case for filling with infinite forms" (aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[ pattern := aFillStyle form. (aFillStyle direction = (pattern width @ 0) and:[aFillStyle normal = (0@pattern height)]) ifTrue:[ "Can use an InfiniteForm" ^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)]. ]. "Use a BalloonCanvas instead" self balloonFillRectangle: aRectangle fillStyle: aFillStyle. ! ! !PluggableCanvas methodsFor: 'other' stamp: 'RAA 7/20/2000 16:49'! forceToScreen: rect self apply: [ :c | c forceToScreen: rect ]! ! !PluggableCanvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:28'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c self apply: [ :clippedCanvas | clippedCanvas drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! ! !PluggableCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 20:30'! image: aForm at: aPoint sourceRect: sourceRect rule: rule self apply: [ :c | c image: aForm at: aPoint sourceRect: sourceRect rule: rule ]! ! !PluggableCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 20:46'! apply: aBlock "evaluate aBlock with a canvas to do a drawing command on. See implementors for examples"! ! !PluggableCanvas methodsFor: 'drawing' stamp: 'ls 3/20/2000 20:34'! render: anObject self apply: [ :c | c render: anObject ]! ! !PluggableCanvas methodsFor: 'drawing-support' stamp: 'ls 3/20/2000 20:35'! transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize self apply: [ :clippedCanvas | clippedCanvas transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize ]! ! !PluggableCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:02'! clipRect | innerClipRect | self apply: [ :c | innerClipRect := c clipRect ]. ^innerClipRect! ! !PluggableCanvas methodsFor: 'accessing' stamp: 'ls 3/26/2000 13:57'! contentsOfArea: aRectangle into: aForm self apply: [ :c | c contentsOfArea: aRectangle into: aForm ]. ^aForm! ! !PluggableCanvas methodsFor: 'drawing-polygons' stamp: 'ls 3/20/2000 20:01'! drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc self apply: [ :c | c drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc ]! ! !PluggableCanvas methodsFor: 'drawing-images' stamp: 'ls 3/20/2000 20:32'! paintImage: aForm at: aPoint self apply: [ :c | c paintImage: aForm at: aPoint ]! ! !PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 8/25/2000 13:34'! infiniteFillRectangle: aRectangle fillStyle: aFillStyle self apply: [ :c | c infiniteFillRectangle: aRectangle fillStyle: aFillStyle ]! ! !PluggableCanvas methodsFor: 'drawing-ovals' stamp: 'IgorStasenko 7/18/2011 18:21'! fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc "Fill the given oval." (aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[ self flag: #fixThis. ^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc]. (aFillStyle isSolidFill) ifTrue:[ ^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc]. "Use a BalloonCanvas instead" self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc! ! !PluggableCanvas methodsFor: 'drawing-images' stamp: 'ls 3/20/2000 20:32'! paintImage: aForm at: aPoint sourceRect: sourceRect self apply: [ :c | c paintImage: aForm at: aPoint sourceRect: sourceRect ]! ! !PluggableCanvas methodsFor: 'drawing-images' stamp: 'ls 3/20/2000 20:35'! stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor self apply: [ :c | c stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor ]! ! !PluggableCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:14'! shadowColor: color self apply: [ :c | c shadowColor: color ]! ! !PluggableCanvas methodsFor: 'accessing' stamp: 'RAA 8/13/2000 18:56'! extent self apply: [ :c | ^c extent ]. ! ! !PluggableCanvas methodsFor: 'other' stamp: 'ls 3/20/2000 20:37'! translateBy: aPoint clippingTo: aRect during: aBlock self apply: [ :clippedCanvas | clippedCanvas translateBy: aPoint clippingTo: aRect during: aBlock ]! ! !PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 11/6/2000 16:33'! balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc self apply: [ :c | c balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc ]! ! !PluggableCanvas methodsFor: 'drawing' stamp: 'ls 3/20/2000 20:33'! paragraph: paragraph bounds: bounds color: color self apply: [ :c | c paragraph: paragraph bounds: bounds color: color ]! ! !PluggableCanvas methodsFor: 'drawing-rectangles' stamp: 'ls 3/20/2000 20:04'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor self apply: [ :c | c frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor ]! ! !PluggableCanvas methodsFor: 'initialization' stamp: 'ls 3/20/2000 21:16'! flush self apply: [ :c | c flush ]! ! !PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/25/2000 15:53'! showAt: pt invalidRects: updateRects self apply: [ :c | c showAt: pt invalidRects: updateRects ]! ! !PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 7/28/2000 06:52'! balloonFillRectangle: aRectangle fillStyle: aFillStyle self apply: [ :c | c balloonFillRectangle: aRectangle fillStyle: aFillStyle ]! ! !PluggableDialogWindow commentStamp: 'gvc 8/8/2007 14:08'! Pluggable form of dialog window supporting custom selector on model for applying changes along with configurable content and buttons.! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 14:06'! useOKDefaultCancelButton "Set the buttons to be an OK button and a default cancel button. Only effective before the model is set." self buttons: {self newOKButton. self newCancelButton isDefault: true}! ! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/8/2007 14:02'! buttons: anObject "Set the value of buttons" buttons := anObject! ! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/9/2011 15:01'! defaultFocusMorph: aMorph defaultFocusMorph := aMorph! ! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/9/2011 14:26'! newContentMorph "Answer the plugged content." ^self contentMorph ! ! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'jrd 12/1/2008 23:56'! statusValue ^statusValue! ! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/9/2007 13:34'! contentMorph: anObject "Set the value of contentMorph" contentMorph := anObject! ! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/9/2007 13:34'! contentMorph "Answer the value of contentMorph" ^ contentMorph! ! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 14:05'! useDefaultOKButton "Set the buttons to be just an OK button. Only effective before the model is set." self buttons: {self newOKButton isDefault: true}! ! !PluggableDialogWindow methodsFor: 'initialization' stamp: 'gvc 8/8/2007 14:03'! initialize "Initialize the receiver." super initialize. self buttons: super newButtons! ! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/12/2007 12:56'! applyChangesSelector "Answer the value of applyChangesSelector" ^ applyChangesSelector! ! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/9/2011 15:01'! defaultFocusMorph ^ defaultFocusMorph ifNil: [super defaultFocusMorph]! ! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 14:02'! newButtons "Answer the plugged buttons." ^self buttons! ! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 14:06'! useDefaultOKCancelButton "Set the buttons to be a default OK button and a cancel button. Only effective before the model is set." self buttons: super newButtons! ! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'jrd 12/1/2008 23:56'! statusValue: val statusValue := val! ! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/8/2007 14:02'! buttons "Answer the value of buttons" ^ buttons! ! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 12/11/2009 07:41'! applyChanges "Apply the changes." super applyChanges. self applyChangesSelector ifNotNil: [:s | self model perform: s withEnoughArguments: {self}]! ! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/12/2007 12:56'! applyChangesSelector: anObject "Set the value of applyChangesSelector" applyChangesSelector := anObject! ! !PluggableDictionary commentStamp: ''! Class PluggableDictionary allows the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the dictionary. See the class comment of PluggableSet for an example. Instance variables: hashBlock A one argument block used for hashing the elements. equalBlock A two argument block used for comparing the elements. ! !PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'! hashBlock: aBlock "Set a new hash block. The block must accept one argument and must return the hash value of the given argument." hashBlock := aBlock.! ! !PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/27/1998 23:55'! equalBlock: aBlock "Set a new equality block. The block must accept two arguments and return true if the argumets are considered to be equal, false otherwise" equalBlock := aBlock.! ! !PluggableDictionary methodsFor: 'copying' stamp: 'nice 10/5/2009 10:15'! copyEmpty ^super copyEmpty hashBlock: hashBlock; equalBlock: equalBlock! ! !PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'! hashBlock "Return the block used for hashing the elements in the receiver." ^hashBlock! ! !PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'! equalBlock "Return the block used for comparing the elements in the receiver." ^equalBlock! ! !PluggableDictionary methodsFor: 'private' stamp: 'dvf 6/11/2000 01:33'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | element start finish | start := (hashBlock ifNil: [anObject hash] ifNotNil: [hashBlock value: anObject]) \\ array size + 1. finish := array size. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element := array at: index) == nil or: [equalBlock ifNil: [element key = anObject] ifNotNil: [equalBlock value: element key value: anObject]]) ifTrue: [^ index]]. "Search from 1 to where we started." 1 to: start - 1 do: [:index | ((element := array at: index) == nil or: [equalBlock ifNil: [element key = anObject] ifNotNil: [equalBlock value: element key value: anObject]]) ifTrue: [^ index]]. ^ 0"No match AND no empty slot"! ! !PluggableDictionary methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 22:52'! scanForEmptySlotFor: aKey "Scan the key array for the first slot containing an empty slot (indicated by a nil). Answer the index of that slot. This method will be overridden in various subclasses that have different interpretations for matching elements." | index start | index := start := (hashBlock ifNil: [ aKey hash ] ifNotNil: [ hashBlock value: aKey ]) \\ array size + 1. [ (array at: index) ifNil: [ ^index ]. (index := index \\ array size + 1) = start ] whileFalse. self errorNoFreeSpace! ! !PluggableDictionary class methodsFor: 'as yet unclassified' stamp: 'dvf 6/10/2000 18:13'! integerDictionary ^ self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! ! !PluggableDictionaryTest commentStamp: 'TorstenBergmann 2/20/2014 15:21'! SUnit tests for pluggable dictionaries! !PluggableDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 12:35'! classToBeTested ^ PluggableDictionary! ! !PluggableDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 13:28'! shouldInheritSelectors ^true! ! !PluggableDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 12:36'! classToBeTested ^ IdentitySet! ! !PluggableIconListMorph commentStamp: 'gvc 5/18/2007 12:31'! A type of PluggableListMorph that supports a single icon (Form) for items. Useful for lists with icons.! !PluggableIconListMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2007 17:56'! getIconSelector: anObject "Set the value of getIconSelector" getIconSelector := anObject! ! !PluggableIconListMorph methodsFor: 'model access' stamp: 'BenjaminVanRyseghem 11/29/2011 09:56'! getList "Answer the list to be displayed. Caches the returned list in the 'list' ivar" getListSelector isNil ifTrue: [^#()]. list := model perform: getListSelector. list isNil ifTrue: [^ #()]. list := list collectWithIndex: [ :item :index | self itemMorphFor: item index: index ]. ^list! ! !PluggableIconListMorph methodsFor: 'action' stamp: 'BenjaminVanRyseghem 8/23/2011 14:38'! interactWithSelectedItem self selection ifNotNil: [: sel | sel submorphs do: [:each | each update: #interact ]]! ! !PluggableIconListMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2007 17:56'! getIconSelector "Answer the value of getIconSelector" ^ getIconSelector! ! !PluggableIconListMorph methodsFor: 'model access' stamp: 'BenjaminVanRyseghem 4/25/2012 15:48'! getListItem: index "get the index-th item in the displayed list" getListElementSelector ifNotNil: [ ^self itemMorphFor: (model perform: getListElementSelector with: index) index: index]. (list notNil and: [list size >= index]) ifTrue: [ ^list at: index ]. ^ self wrapItem: (self getList at: index) index: index! ! !PluggableIconListMorph methodsFor: 'event' stamp: 'BenjaminVanRyseghem 5/5/2013 13:03'! basicKeyPressed: aChar ^ aChar == Character space ifTrue: [ self interactWithSelectedItem ] ifFalse: [ super basicKeyPressed: aChar ]! ! !PluggableIconListMorph methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/6/2013 23:48'! itemMorphFor: anObject index: anIndex "Answer a morph for the object with the appropriate icon." |item icon| item := IconicListItem new originalObject: anObject; yourself. icon := self getIconSelector ifNotNil: [self model perform: self getIconSelector withEnoughArguments: {anObject. anIndex}]. icon ifNotNil: [ item icon: icon asMorph]. item morph: (self wrapItem: anObject index: anIndex) asMorph. ^item! ! !PluggableListItemWrapper commentStamp: 'ar 10/14/2003 23:51'! luggableListItemWrapper makes it more easy for clients to use hierarchical lists. Rather than having to write a subclass of ListItemWrapper, a PluggableListItemWrapper can be used to provide the appropriate information straight from the model: string - an explicit string representation (contrary to the 'item' which contains any kind of object) getStringSelector - a message invoked to retrieve the sting representation of its item dynamically from its model (when a constant representation is undesirable) hasContentsSelector - a message invoked in the model to answer whether the item has any children or not. getContentsSelector - a message invoked in the model to retrieve the contents for its item. All callback selectors can have zero, one or two arguments with the item and the wrapper as first and second argument.! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! getContentsSelector ^getContentsSelector! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:48'! getStringSelector ^getStringSelector! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'! string: aString string := aString! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! hasContentsSelector ^hasContentsSelector! ! !PluggableListItemWrapper methodsFor: 'private' stamp: 'ar 10/11/2003 21:50'! validateSelector: aSymbol (aSymbol numArgs between: 0 and: 2) ifFalse:[^self error: 'Invalid pluggable selector'].! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'! string ^string! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! hasContentsSelector: aSymbol self validateSelector: aSymbol. hasContentsSelector := aSymbol.! ! !PluggableListItemWrapper methodsFor: 'private' stamp: 'ar 10/11/2003 21:47'! sendToModel: aSelector aSelector numArgs = 0 ifTrue:[^model perform: aSelector]. aSelector numArgs = 1 ifTrue:[^model perform: aSelector with: item]. aSelector numArgs = 2 ifTrue:[^model perform: aSelector with: item with: self].! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! getStringSelector: aSymbol self validateSelector: aSymbol. getStringSelector := aSymbol.! ! !PluggableListItemWrapper methodsFor: 'printing' stamp: 'ar 10/11/2003 23:21'! printOn: aStream super printOn: aStream. aStream nextPut:$(; nextPutAll: self asString; nextPut:$).! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:50'! getContentsSelector: aSymbol self validateSelector: aSymbol. getContentsSelector := aSymbol.! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:48'! contents getContentsSelector ifNil:[^#()]. ^self sendToModel: getContentsSelector.! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:53'! hasContents hasContentsSelector ifNil:[^super hasContents]. ^self sendToModel: hasContentsSelector ! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'! asString string ifNotNil:[^string]. getStringSelector ifNil:[^super asString]. ^self sendToModel: getStringSelector ! ! !PluggableListMorph commentStamp: ''! ... When a PluggableListMorph is in focus, type in a letter (or several letters quickly) to go to the next item that begins with that letter. Special keys (up, down, home, etc.) are also supported.! !PluggableListMorph methodsFor: 'menus' stamp: 'PeterHugossonMiller 9/3/2009 10:19'! copyListToClipboard "Copy my items to the clipboard as a multi-line string" | stream | stream := (String new: self getList size * 40) writeStream. list do: [:ea | stream nextPutAll: ea asString] separatedBy: [stream nextPut: Character cr]. Clipboard clipboardText: stream contents! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 2/9/2002 01:03'! getListSelector: sel "Set the receiver's getListSelector as indicated, and trigger a recomputation of the list" getListSelector := sel. self changed. self updateList.! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'di 4/10/98 16:20'! autoDeselect: trueOrFalse "Enable/disable autoDeselect (see class comment)" autoDeselect := trueOrFalse.! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! startDrag: evt onItem: itemMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:21'! font: aFontOrNil self listMorph font: aFontOrNil. ! ! !PluggableListMorph methodsFor: 'scrolling' stamp: 'gvc 2/19/2009 12:26'! hUnadjustedScrollRange "Return the entire scrolling range." ^self listMorph hUnadjustedScrollRange! ! !PluggableListMorph methodsFor: '*Spec-Core' stamp: ''! getIndexSelector: aSelector getIndexSelector := aSelector! ! !PluggableListMorph methodsFor: '*Spec-Core' stamp: ''! initialize super initialize. self initForKeystrokes.! ! !PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'! resetHScrollRangeIfNecessary hScrollRangeCache ifNil: [ ^self deriveHScrollRange ]. (list isNil or: [list isEmpty]) ifTrue:[^hScrollRangeCache := Array with: 0 with: 0 with: 0 with: 0 with: 0]. "Make a guess as to whether the scroll ranges need updating based on whether the size, first item, or last item of the list has changed" ( (hScrollRangeCache third == list size) and: [ (hScrollRangeCache fourth == list first) and: [ (hScrollRangeCache fifth == list last) ]]) ifFalse:[self deriveHScrollRange]. ! ! !PluggableListMorph methodsFor: 'separator' stamp: 'BenjaminVanRyseghem 5/7/2012 15:14'! separatorAfterARow: aRow aRow ifNil: [ ^ false ]. self separatorBlockOrSelector ifNotNil: [:blockOrSelector || anItem | anItem := getListElementSelector ifNil: [ list at: aRow ifAbsent: [ ^ false ]] ifNotNil: [ model perform: getListElementSelector with: aRow ]. ^ blockOrSelector isBlock ifTrue: [ blockOrSelector cull: anItem cull: aRow ] ifFalse: [ blockOrSelector isSymbol ifTrue: [ blockOrSelector numArgs == 0 ifTrue: [ anItem perform: blockOrSelector ] ifFalse: [ self model perform: blockOrSelector withEnoughArguments: { anItem. aRow} ]] ifFalse: [ false ]]]. ^ false! ! !PluggableListMorph methodsFor: 'wrapping' stamp: 'BenjaminVanRyseghem 11/29/2011 09:53'! wrapItem: anItem index: anIndex "Use the wrapSelector to get the text or string representation of a list item." ^ self wrapSelector ifNil: [ anItem asStringOrText] ifNotNil: [:selector | selector numArgs == 0 ifTrue: [ anItem perform: selector ] ifFalse: [ self model perform: selector withEnoughArguments: { anItem. anIndex } ]].! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:32'! dragItemSelector ^dragItemSelector! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:10'! potentialDropRow "return the row of the item that the most recent drop hovered over, or 0 if there is no potential drop target" ^potentialDropRow ifNil: [ 0 ]. ! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/20/2006 10:24'! mouseDownRow: anIntegerOrNil "Set the mouse down row or nil if none." self listMorph mouseDownRow: anIntegerOrNil! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/3/2008 13:05'! optimalExtent "Answer the extent of the list morph." ^self listMorph extent + (self borderWidth * 2) + self scrollBarThickness! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:26'! isMultipleSelection ^ self multipleSelection! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'sw 1/18/2001 13:08'! keystrokeActionSelector: keyActionSel "Set the keystroke action selector as specified" keystrokeActionSelector := keyActionSel! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/16/2013 12:26'! startDragExtended: evt "This method was defined in PluggableListMorphPlus (a subclass that got merged)" dragItemSelector ifNil: [^self]. evt hand hasSubmorphs ifTrue: [^ self]. [ | dragIndex draggedItem ddm ddRect | (self dragEnabled and: [model okToChange]) ifFalse: [^ self]. dragIndex := self rowAtLocation: evt position. dragIndex = 0 ifTrue: [^self]. draggedItem := model perform: dragItemSelector with: dragIndex. draggedItem ifNil: [^self]. self mouseDownRow: nil. ddm := self model transferFor: draggedItem from: self. ddRect := ddm draggedMorph bounds. ddm position: evt position - (ddRect center - ddRect origin). ddm dragTransferType: #dragTransfer. evt hand grabMorph: ddm] ensure: [Cursor normal show. evt hand newMouseFocus: self]! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 11:28'! getListElementSelector ^ getListElementSelector! ! !PluggableListMorph methodsFor: 'menu' stamp: 'tk 12/10/2001 20:33'! getMenu: shiftKeyState "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | aMenu | aMenu := super getMenu: shiftKeyState. aMenu ifNotNil: [aMenu commandKeyHandler: self]. ^ aMenu! ! !PluggableListMorph methodsFor: 'model access' stamp: 'GuillermoPolito 2/24/2012 12:37'! commandKeyTypedIntoMenu: evt "The user typed a command-key into a menu which has me as its command-key handler" ^ self modifierKeyPressed: evt! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 13:34'! disable "Disable the receiver." self enabled: false! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'gvc 1/11/2007 14:06'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/1/2009 15:18'! focusBounds "Answer the bounds for drawing the focus indication." ^self theme listFocusBoundsFor: self! ! !PluggableListMorph methodsFor: 'searching' stamp: 'BenjaminVanRyseghem 4/4/2011 16:59'! searchedElement ^ searchedElement! ! !PluggableListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 20:53'! highlightSelection! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'AlainPlantec 1/7/2010 22:32'! mouseEnter: event "Changed to take keyboardFocusOnMouseDown into account." super mouseEnter: event. self wantsKeyboardFocus ifFalse: [^self]. self keyboardFocusOnMouseDown ifFalse: [self takeKeyboardFocus]! ! !PluggableListMorph methodsFor: 'separator' stamp: 'BenjaminVanRyseghem 9/16/2011 17:07'! separatorColor ^ separatorColor ifNil: [ separatorColor := Color gray ]! ! !PluggableListMorph methodsFor: 'scrolling' stamp: 'sps 12/24/2002 18:31'! hExtraScrollRange "Return the amount of extra blank space to include to the right of the scroll content." ^5 ! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/23/2012 11:40'! keyboardFocusChange: aBoolean "The message is sent to a morph when its keyboard focus changes. Update for focus feedback." super keyboardFocusChange: aBoolean. self focusChanged! ! !PluggableListMorph methodsFor: 'events' stamp: 'ls 10/14/2001 13:08'! handleBasicKeys: aBoolean "set whether the list morph should handle basic keys like arrow keys, or whether everything should be passed to the model" handlesBasicKeys := aBoolean! ! !PluggableListMorph methodsFor: 'scrolling' stamp: 'sps 12/26/2002 13:36'! vUnadjustedScrollRange "Return the height extent of the receiver's submorphs." (scroller submorphs size > 0) ifFalse:[ ^0 ]. ^(scroller submorphs last fullBounds bottom) ! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 12:39'! fillStyleToUse "Answer the fillStyle that should be used for the receiver." ^self enabled ifTrue: [self theme listNormalFillStyleFor: self] ifFalse: [self theme listDisabledFillStyleFor: self]! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/10/2014 10:02'! autoDeselect ^ autoDeselect ifNil: [ self resetListSelector notNil ] ifNotNil: [ autoDeselect ]! ! !PluggableListMorph methodsFor: 'events' stamp: 'BenjaminVanRyseghem 2/9/2012 18:17'! navigationKey: anEvent self isMultipleSelection ifTrue: [ | keyString | keyString := anEvent keyString. keyString = '' ifTrue: [ self selectAll. ^ true ]. keyString = '' ifTrue: [ self deselectAll. ^ true ] ]. ^ super navigationKey: anEvent! ! !PluggableListMorph methodsFor: 'model access' stamp: 'GuillermoPolito 9/1/2010 18:47'! getCurrentSelectionIndex "Answer the index of the current selection." getIndexSelector ifNil: [^0]. ^model perform: getIndexSelector! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 11:46'! getEnabledSelector: aSymbol "Set the value of getEnabledSelector" self setProperty: #getEnabledSelector toValue: aSymbol. self updateEnabled! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:32'! dropItemSelector ^dropItemSelector! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'EstebanLorenzano 9/21/2012 13:18'! getListElementSelector: aSymbol "specify a selector that can be used to obtain a single element in the underlying list" self basicGetListElementSelector: aSymbol. list := nil. "this cache will not be updated if getListElementSelector has been specified, so go ahead and remove it" self updateList.! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 6/1/2011 11:31'! mouseUp: evt self isMultipleSelection ifTrue: [ self mouseUpOnMultiple: evt ] ifFalse: [ self mouseUpOnSingle: evt ]! ! !PluggableListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 6/1/2011 11:13'! unhighlightSelection self searchedElement: nil.! ! !PluggableListMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 6/4/2011 15:21'! resetListSelection self resetListSelectionSilently. self changed! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'stephaneDucasse 7/18/2010 11:45'! wantsDroppedMorph: aMorph event: anEvent ^ aMorph dragTransferType == #dragTransfer ifTrue: [ dropItemSelector ifNil: [^false]. wantsDropSelector ifNil: [^true]. (model perform: wantsDropSelector with: aMorph passenger)] ifFalse: [ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self]! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 8/17/2012 14:36'! mouseEnterDragging: evt "The mouse has entered with a button down. Workaround for apparent flaw in MouseOverHandler constantly sending this message when dragging. Do nothing if disabled." |row oldPDR| self enabled ifFalse: [^self]. row := self rowAtLocation: evt position. (self dragEnabled or: [evt hand hasSubmorphs]) ifFalse: [ row = 0 ifTrue: [ ^self ]. self listMorph mouseDownRow: row]. (evt hand hasSubmorphs and:[self dropEnabled]) ifFalse: ["no d&d" ^super mouseEnterDragging: evt]. potentialDropRow = row ifTrue: [^self]. oldPDR := potentialDropRow. potentialDropRow := row. evt hand newMouseFocus: self. "above is ugly but necessary for now" (self wantsDroppedMorph: evt hand firstSubmorph event: evt ) ifTrue: [self changed] ifFalse: [(oldPDR ifNil: [0]) > 0 ifTrue: [self resetPotentialDropRow] ifFalse: [potentialDropRow := 0]]! ! !PluggableListMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:46'! selection: item "Called from outside to request setting a new selection." self selectionIndex: (self getList indexOf: item)! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'stephaneDucasse 7/18/2010 11:48'! acceptDroppingMorph: aMorph event: evt "This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. The default implementation just adds the given morph to the receiver." "Here we let the model do its work." dropItemSelector ifNotNil: [| item | dropItemSelector ifNil:[^self]. item := aMorph passenger. model perform: dropItemSelector with: item with: potentialDropRow ] ifNil: [ self model acceptDroppingMorph: aMorph event: evt inMorph: self ]. self resetPotentialDropRow. evt hand releaseMouseFocus: self. Cursor normal show. ! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'gvc 9/12/2006 15:28'! mouseLeaveDragging: anEvent "The mouse has left with a button down." (self dragEnabled or: [anEvent hand hasSubmorphs]) ifFalse: [ self listMorph mouseDownRow: nil]. (self dropEnabled and: [anEvent hand hasSubmorphs]) ifFalse: ["no d&d" ^super mouseLeaveDragging: anEvent]. self resetPotentialDropRow. anEvent hand releaseMouseFocus: self. "above is ugly but necessary for now"! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:33'! wantsDropSelector: aSymbol wantsDropSelector := aSymbol! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/16/2013 12:25'! startDrag: evt | transferMorph draggedItem passenger | dragItemSelector ifNotNil: [ ^self startDragExtended: evt ]. evt hand hasSubmorphs ifTrue: [^ self]. self dragEnabled ifFalse: [^ self]. "Here I ensure at least one element is selected " ActiveHand anyButtonPressed ifFalse: [ ^self ]. draggedItem := self getListItem: (self mouseDownRow ifNil: [ self lastNonZeroIndex ]). draggedItem ifNil: [ ^ self ]. passenger := self model dragPassengersFor: draggedItem inMorph: self. passenger ifNil: [ ^ self ]. transferMorph := self model transferFor: passenger from: self. transferMorph align: transferMorph draggedMorph bottomLeft with: evt position. self mouseDownRow: nil. transferMorph dragTransferType: (self model dragTransferTypeForMorph: self). [evt hand grabMorph: transferMorph ] ensure: [ Cursor normal show. evt hand releaseMouseFocus: self] ! ! !PluggableListMorph methodsFor: 'model access' stamp: 'BenjaminVanRyseghem 11/29/2011 09:57'! getList "Answer the list to be displayed. Caches the returned list in the 'list' ivar" getListSelector == nil ifTrue: [^ #()]. list := model perform: getListSelector. list == nil ifTrue: [^ #()]. list := list collectWithIndex: [ :item :index | self wrapItem: item index: index ]. ^ list! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:33'! dropItemSelector: aSymbol dropItemSelector := aSymbol. aSymbol ifNotNil:[self dropEnabled: true].! ! !PluggableListMorph methodsFor: 'submorphs-accessing' stamp: 'di 11/14/2001 13:57'! allSubmorphNamesDo: nameBlock "Assume list morphs do not have named parts -- saves MUCH time" ^ self! ! !PluggableListMorph methodsFor: 'searching' stamp: 'BenjaminVanRyseghem 4/4/2011 17:01'! secondarySelectionColor ^ self theme settings secondarySelectionColor! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:41'! listSelectionAt: index put: value self searchedElement: nil. setSelectionListSelector ifNil:[^false]. ^model perform: setSelectionListSelector with: index with: value! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 4/17/2012 16:51'! initForKeystrokes canMove := true. lastKeystrokeTime := 0. lastKeystrokes := ''! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:32'! dragItemSelector: aSymbol dragItemSelector := aSymbol. aSymbol ifNotNil:[self dragEnabled: true].! ! !PluggableListMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:56'! addCustomMenuItems: aMenu hand: aHandMorph "Add halo menu items to be handled by the invoking hand. The halo menu is invoked by clicking on the menu-handle of the receiver's halo." super addCustomMenuItems: aMenu hand: aHandMorph. aMenu addLine. aMenu add: 'list font...' translated target: self action: #setListFont. aMenu add: 'copy list to clipboard' translated target: self action: #copyListToClipboard. aMenu add: 'copy selection to clipboard' translated target: self action: #copySelectionToClipboard! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 11:44'! selectionColorToUse: aColor "Set the colour for selected items." aColor = self selectionColorToUse ifTrue: [^self]. aColor ifNil: [self removeProperty: #selectionColorToUse] ifNotNil: [self setProperty: #selectionColorToUse toValue: aColor]. self listMorph selectionFrameChanged! ! !PluggableListMorph methodsFor: 'searching' stamp: 'BenjaminVanRyseghem 5/10/2011 13:18'! searchedElement: anInteger searchedElement := anInteger. anInteger ifNil: [ " just for redrawn " self vScrollValue: (self scrollValue y) ] ifNotNil: [ self vScrollValue: ((anInteger-1)/self getListSize) ]! ! !PluggableListMorph methodsFor: '*Spec-Core' stamp: ''! setMultipleSelection: aBoolean multipleSelection := aBoolean! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'EstebanLorenzano 9/21/2012 13:17'! basicGetListElementSelector: aSymbol "specify a selector that can be used to obtain a single element in the underlying list" getListElementSelector := aSymbol. ! ! !PluggableListMorph methodsFor: 'selection' stamp: 'di 6/21/1998 22:19'! getListSelector ^ getListSelector! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/17/2001 09:04'! listMorphClass ^LazyListMorph! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/8/2011 15:14'! wrapSelector ^ wrapSelector! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'ls 2/5/2004 18:01'! listMorph listMorph ifNil: [ "crate this lazily, in case the morph is legacy" listMorph := self listMorphClass new. listMorph listSource: self. listMorph width: self scroller width. listMorph color: self textColor ]. listMorph owner ~~ self scroller ifTrue: [ "list morph needs to be installed. Again, it's done this way to accomodate legacy PluggableListMorphs" self scroller removeAllMorphs. self scroller addMorph: listMorph ]. ^listMorph! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'GuillermoPolito 8/17/2012 13:58'! mouseMoveOnSingle: evt "The mouse has moved with a button down. Do nothing if disabled." |row| self enabled ifFalse: [^self]. row := self rowAtLocation: evt position. evt hand hasSubmorphs ifFalse: [ ((self containsPoint: evt position) and: [ row ~= 0 ]) ifTrue: [self mouseDownRow: row] ifFalse: [self mouseDownRow: nil]]. (self dropEnabled and:[evt hand hasSubmorphs]) ifFalse: [^self eventHandler ifNotNil: [self eventHandler mouseMove: evt fromMorph: self]]. (self containsPoint: evt position) ifTrue: [self mouseEnterDragging: evt] ifFalse: [self mouseLeaveDragging: evt]! ! !PluggableListMorph methodsFor: '*FreeType-override' stamp: 'AlainPlantec 12/19/2009 23:59'! setListFont "set the font for the list" StandardFonts chooseFontWithTitle: 'Choose the font for this list' translated for: self setSelector: #font: getSelector: #font ! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/3/2013 10:53'! mouseDown: evt "Changed to only take focus if wanted." | selectors row | row := self rowAtLocation: evt position. evt yellowButtonPressed ifTrue: [ self isMultipleSelection ifTrue: [ evt commandKeyPressed ifFalse: [ "right click" (self yellowButtonActivity: evt shiftPressed) ifTrue: [ ^ super mouseDown: evt ] ] ] ifFalse: [ (self yellowButtonActivity: evt shiftPressed) ifTrue: [ ^ super mouseDown: evt ] ] ]. "First check for option (menu) click" self enabled ifFalse: [ ^ super mouseDown: evt ]. self wantsKeyboardFocus ifTrue: [ self takeKeyboardFocus ]. row := self rowAtLocation: evt position. row = 0 ifTrue: [ ^ super mouseDown: evt ]. self mouseDownRow: row. self isMultipleSelection ifTrue: [ self mouseDownOnMultiple: evt forRow: row ]. selectors := Array with: #click: with: (doubleClickSelector ifNotNil: [ #doubleClick: ]) with: nil with: (self dragEnabled ifTrue: [ #startDrag: ] ifFalse: [ nil ]). evt hand waitForClicksOrDrag: self event: evt selectors: selectors threshold: 10. "pixels" super mouseDown: evt! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:40'! textHighlightColor "Answer my default text highlight color." ^self valueOfProperty: #textHighlightColor ifAbsent: [ Color red ]. ! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/22/2001 18:21'! getListSizeSelector: aSymbol "specify a selector that can be used to specify the list's size" getListSizeSelector := aSymbol! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 8/19/2001 14:20'! selectedMorph "this doesn't work with the LargeLists patch!! Use #selectionIndex and #selection instead." ^self scroller submorphs at: self selectionIndex! ! !PluggableListMorph methodsFor: 'scrolling' stamp: 'adrian-lienhard 6/22/2009 00:00'! numSelectionsInView "Answer the scroller's height based on the average number of submorphs." "ugly hack, due to code smell. PluggableListMorph added another level of indirection, There is always only one submorph - a LazyListMorph which holds the actual list, but TransformMorph doesn't know that and we are left with a breach of interface." ^scroller numberOfItemsPotentiallyInViewWith: scroller submorphs last getListSize.! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 13:34'! enabled "Answer the enablement state of the receiver." ^self valueOfProperty: #enabled ifAbsent: [true]! ! !PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'! deriveHScrollRange | unadjustedRange totalRange | (list isNil or: [list isEmpty]) ifTrue:[hScrollRangeCache := Array with: 0 with: 0 with: 0 with: 0 with: 0 ] ifFalse:[ unadjustedRange := self listMorph hUnadjustedScrollRange. totalRange := unadjustedRange + self hExtraScrollRange + self hMargin. hScrollRangeCache := Array with: totalRange with: unadjustedRange with: list size with: list first with: list last . ]. ! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/22/2007 14:48'! themeChanged "Update the selection colour." self selectionColor ifNotNil: [ self selectionColor: self theme selectionColor]. super themeChanged! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 2/9/2012 17:27'! keyStroke: event "Process keys specialKeys are things like up, down, etc. ALWAYS HANDLED modifierKeys are regular characters either 1) accompanied with ctrl, cmd or 2) any character if the list doesn't want to handle basic keys (handlesBasicKeys returns false) basicKeys are any characters" | aChar | (self scrollByKeyboard: event) ifTrue: [^self]. (self navigationKey: event) ifTrue: [^self]. aChar := event keyCharacter. keystrokeSelector ifNotNil: [ (self keystrokeAction: event) ifTrue: [ ^ self ] ]. aChar asciiValue < 32 ifTrue: [^ self specialKeyPressed: event ]. (event anyModifierKeyPressed or: [self handlesBasicKeys not]) ifTrue: [^ self modifierKeyPressed: event]. ^ self basicKeyPressed: aChar! ! !PluggableListMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 12/20/2012 16:25'! scrollSelectionIntoView "make sure that the current selection is visible" | row | row := self getCurrentSelectionIndex. self scrollSelectionToRow: row! ! !PluggableListMorph methodsFor: 'events' stamp: 'BenjaminVanRyseghem 4/17/2012 16:19'! specialKeyPressed: anEvent "A special key with the given ascii-value was pressed; dispatch it" | keyString max nextSelection oldSelection howManyItemsShowing | keyString := anEvent keyString. keyString = '' ifTrue: [" escape key" ^ ActiveEvent shiftPressed ifTrue: [ActiveWorld invokeWorldMenuFromEscapeKey] ifFalse:[ (self yellowButtonActivity: false) ifTrue: [ ^ self ]]]. keyString = '' ifTrue: [ "enter pressed" self selectSearchedElement ]. max := self maximumSelection. max > 0 ifFalse: [^ self]. nextSelection := oldSelection := self getCurrentSelectionIndex. keyString = '' ifTrue: [" down arrow" self resetListSelectionSilently. nextSelection := oldSelection + 1. nextSelection > max ifTrue: [nextSelection := max]]. keyString = '' ifTrue: [ " up arrow" self resetListSelectionSilently. nextSelection := oldSelection - 1. nextSelection < 1 ifTrue: [nextSelection := 1]]. keyString = '' ifTrue: [" home" self resetListSelectionSilently. nextSelection := 1]. keyString = '' ifTrue: [" end" self resetListSelectionSilently. nextSelection := max]. howManyItemsShowing := self numSelectionsInView. keyString = '' ifTrue: [" page up" self resetListSelectionSilently. nextSelection := 1 max: oldSelection - howManyItemsShowing]. keyString = '' ifTrue: [" page down" self resetListSelectionSilently. nextSelection := oldSelection + howManyItemsShowing min: max]. (self enabled and: [model okToChange]) ifFalse: [^ self]. "No change if model is locked" oldSelection = nextSelection ifTrue: [^ self]. ^ self changeModelSelection: nextSelection! ! !PluggableListMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 12/20/2012 16:25'! selectionIndex: index "Called internally to select the index-th item." | row | self unhighlightSelection. row := index ifNil: [ 0 ]. row := row min: self maximumSelection. "make sure we don't select past the end" self listMorph selectedRow: row. self highlightSelection. self scrollSelectionToRow: row.! ! !PluggableListMorph methodsFor: 'searching' stamp: 'BenjaminVanRyseghem 5/7/2012 15:01'! listForSearching ^ getListSelector ifNotNil: [ self getList ] ifNil: [ getListElementSelector ifNil: [ #() ] ifNotNil: [ (1 to: self getListSize) collect: [:index | self getListItem: index ]]] ! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 4/17/2012 17:14'! mouseMoveOnMultiple: event "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" | oldIndex oldVal row | canMove ifFalse: [ ^ self ]. event position y < self top ifTrue: [ scrollBar scrollUp: 1. row := self rowAtLocation: scroller topLeft + (1 @ 1)] ifFalse: [ row := event position y > self bottom ifTrue: [scrollBar scrollDown: 1. self rowAtLocation: scroller bottomLeft + (1 @ -1)] ifFalse: [ self rowAtLocation: event position ]]. row = 0 ifTrue: [ ^ super mouseDown: event ]. (self potentialDropItem notNil and: [ self dropEnabled ]) ifTrue: [ ^ self ]. dragOnOrOff ifNil: ["Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" dragOnOrOff := (self listSelectionAt: row) not ]. "Set meaning for subsequent dragging of selection" oldIndex := self getCurrentSelectionIndex. oldIndex ~= 0 ifTrue: [ oldVal := self listSelectionAt: oldIndex ]. "Need to restore the old one, due to how model works, and set new one." oldIndex ~= 0 ifTrue: [ self listSelectionAt: oldIndex put: oldVal ]. self listSelectionAt: row put: dragOnOrOff. row changed! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! mouseLeaveDragging: anEvent onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 2/11/2011 16:35'! selectionColorToUse "Answer the colour to use for selected items." ^self valueOfProperty: #selectionColorToUse ifAbsent: [self theme settings selectionColor] ! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 8/19/2001 14:29'! selection self selectionIndex = 0 ifTrue: [ ^nil ]. list ifNotNil: [ ^list at: self selectionIndex ]. ^ self getListItem: self selectionIndex! ! !PluggableListMorph methodsFor: 'selection' stamp: 'di 5/6/1998 21:20'! setSelectedMorph: aMorph self changeModelSelection: (scroller submorphs indexOf: aMorph)! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 13:34'! enable "Enable the receiver." self enabled: true! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'ls 5/17/2001 20:31'! rowAtLocation: aPoint "Return the row at the given point or 0 if outside" | pointInListMorphCoords | pointInListMorphCoords := (self scroller transformFrom: self) transform: aPoint. ^self listMorph rowAtLocation: pointInListMorphCoords.! ! !PluggableListMorph methodsFor: 'scroll cache' stamp: 'sps 4/3/2005 15:29'! resetHScrollRange hScrollRangeCache := nil. self deriveHScrollRange. ! ! !PluggableListMorph methodsFor: 'debug and other' stamp: 'bf 2/17/2006 17:25'! userString ^list! ! !PluggableListMorph methodsFor: 'separator' stamp: 'BenjaminVanRyseghem 9/16/2011 17:07'! separatorSize ^ separatorSize ifNil: [ separatorSize := 1 ]! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/23/2013 01:02'! lastNonZeroIndex ^ lastNonZeroIndex ifNil: [ lastNonZeroIndex := 0 ]! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:26'! isSingleSelection ^ self multipleSelection not! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! removeObsoleteEventHandlers scroller submorphs do:[:m| m eventHandler: nil; highlightForMouseDown: false; resetExtension].! ! !PluggableListMorph methodsFor: 'background coloring' stamp: 'BenjaminVanRyseghem 9/16/2011 16:46'! backgroundColoringBlockOrSelector ^ backgroundColoringBlockOrSelector ! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 22:57'! handlesKeyboard: evt ^true! ! !PluggableListMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 6/4/2011 15:21'! resetListSelectionSilently self resetListSelector ifNotNil: [:sel | self model perform: sel ]! ! !PluggableListMorph methodsFor: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:26'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation! ! !PluggableListMorph methodsFor: 'updating' stamp: 'AlainPlantec 1/7/2010 22:32'! verifyContents "Verify the contents of the receiver, reconstituting if necessary. Called whenever window is reactivated, to react to possible structural changes. Also called periodically in morphic if the smartUpdating setting is true" | newList existingSelection oldList | oldList := list ifNil: [ #() ]. newList := self getList. ((oldList == newList) "fastest" or: [oldList = newList]) ifTrue: [^ self]. existingSelection := oldList isEmpty ifTrue: [self listMorph selectedRow] ifFalse: [(self selectionIndex between: 1 and: newList size) ifTrue: [self selectionIndex] ifFalse: [nil]]. self updateList. existingSelection notNil ifTrue: [model noteSelectionIndex: existingSelection for: getListSelector. self selectionIndex: existingSelection] ifFalse: [self changeModelSelection: 0]! ! !PluggableListMorph methodsFor: 'menus' stamp: 'MarcusDenker 10/3/2013 23:48'! copySelectionToClipboard "Copy my selected item to the clipboard as a string" self selection ifNotNil: [ Clipboard clipboardText: self selection asString ] ifNil: [ self flash ]! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/8/2009 13:25'! updateEnabled "Update the enablement state." self model ifNotNil: [ self getEnabledSelector ifNotNil: [ self enabled: (self model perform: self getEnabledSelector)]]! ! !PluggableListMorph methodsFor: 'events' stamp: 'ls 10/14/2001 13:09'! handlesBasicKeys " if ya don't want the list to automatically handle non-modifier key (excluding shift key) input, return false" ^ handlesBasicKeys ifNil: [ true ]! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 2/11/2011 16:38'! selectionColor: aColor "Set the colour for selected items." | w | aColor ifNil: [self removeProperty: #selectionColor] ifNotNil: [self setProperty: #selectionColor toValue: aColor]. w := self ownerThatIsA: SystemWindow. self selectionColorToUse: ((self theme settings fadedBackgroundWindows not or: [w isNil or: [w isActive]]) ifTrue: [aColor] ifFalse: [self theme unfocusedSelectionColor])! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/19/2006 15:24'! vExtraScrollRange "Return the amount of extra blank space to include below the bottom of the scroll content." ^8 ! ! !PluggableListMorph methodsFor: 'separator' stamp: 'CamilloBruni 9/16/2011 16:24'! separatorBlockOrSelector ^ separatorBlockOrSelector! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 5/5/2013 13:08'! basicKeyPressed: aChar "Return the index of the element matching the keystrokes. Returns 0 if nothing found" | nextSelection milliSeconds slowKeyStroke oldSelection | nextSelection := oldSelection := self getCurrentSelectionIndex. milliSeconds := Time millisecondClockValue. slowKeyStroke := milliSeconds - lastKeystrokeTime > 500. lastKeystrokeTime := milliSeconds. self searchedElement: nil. slowKeyStroke ifTrue: ["forget previous keystrokes and search in following elements" lastKeystrokes := aChar asLowercase asString.] ifFalse: ["append quick keystrokes but don't move selection if it still matches" lastKeystrokes := lastKeystrokes , aChar asLowercase asString.]. "Get rid of blanks and style used in some lists" nextSelection := self listForSearching findFirst: [:a | a beginsWith: lastKeystrokes fromList: self ]. nextSelection isZero ifTrue: [ ^ 0 ]. "No change if model is locked" model okToChange ifFalse: [ ^ 0 ]. "No change if model is locked" "The following line is a workaround around the behaviour of OBColumn>>selection:, which deselects when called twice with the same argument." oldSelection = nextSelection ifTrue: [ ^ 0 ]. "change scrollbarvalue" self searchedElement: nextSelection. ^ nextSelection! ! !PluggableListMorph methodsFor: 'separator' stamp: 'BenjaminVanRyseghem 9/16/2011 16:57'! separatorColor: aColor separatorColor := aColor! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:19'! doubleClick: event onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'sw 1/12/2000 16:22'! doubleClickSelector: aSymbol doubleClickSelector := aSymbol! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:50'! defaultMultipleSelectionValue ^ false! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! mouseEnterDragging: anEvent onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'di 5/22/1998 00:32'! listItemHeight "This should be cleaned up. The list should get spaced by this parameter." ^ 12! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 16:16'! handleMouseMove: anEvent "Reimplemented because we really want #mouseMove when a morph is dragged around" anEvent wasHandled ifTrue:[^self]. "not interested" (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self]. anEvent wasHandled: true. self mouseMove: anEvent. (self handlesMouseStillDown: anEvent) ifTrue:[ "Step at the new location" self startStepping: #handleMouseStillDown: at: Time millisecondClockValue arguments: {anEvent copy resetHandlerFields} stepTime: 1]. ! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:50'! multipleSelection ^ multipleSelection ifNil: [ multipleSelection := self defaultMultipleSelectionValue ]! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:21'! font ^ self listMorph font ! ! !PluggableListMorph methodsFor: 'model access' stamp: 'BenjaminVanRyseghem 2/23/2013 01:03'! changeModelSelection: anInteger "Change the model's selected item index to be anInteger." setIndexSelector ifNotNil: [model perform: setIndexSelector with: anInteger]. self isMultipleSelection ifTrue: [ self listSelectionAt: self lastNonZeroIndex put: false. self listSelectionAt: anInteger put: true ]! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:01'! potentialDropItem "return the item that the most recent drop hovered over, or nil if there is no potential drop target" self potentialDropRow = 0 ifTrue: [ ^self ]. ^self getListItem: self potentialDropRow! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 10/7/2011 20:06'! listSelectionAt: index index isZero ifFalse:[ lastNonZeroIndex := index ]. getSelectionListSelector ifNil:[^false]. ^model perform: getSelectionListSelector with: index! ! !PluggableListMorph methodsFor: 'model access' stamp: 'BenjaminVanRyseghem 11/29/2011 09:57'! getListItem: index "get the index-th item in the displayed list" | element | getListElementSelector ifNotNil: [ ^ self wrapItem: (model perform: getListElementSelector with: index) index: index ]. list ifNotNil: [ ^ list at: index ]. element := self getList at: index. ^ self wrapItem: element index: index! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:24'! beSingleSelection multipleSelection := false! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:54'! on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel "setup a whole load of pluggability options" getSelectionListSelector := getListSel. setSelectionListSelector := setListSel. self on: anObject list: listSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel. self beMultipleSelection. ^ self ! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:01'! resetPotentialDropRow potentialDropRow ifNotNil: [ potentialDropRow ~= 0 ifTrue: [ potentialDropRow := 0. self changed. ] ]! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:41'! textColor "Answer my default text color." ^self valueOfProperty: #textColor ifAbsent: [ Color black ] ! ! !PluggableListMorph methodsFor: 'geometry' stamp: 'ls 5/17/2001 21:01'! scrollDeltaHeight "Return the increment in pixels which this pane should be scrolled." ^ self font height! ! !PluggableListMorph methodsFor: 'updating' stamp: 'ThierryGoubier 9/10/2012 17:00'! updateList | index | "the list has changed -- update from the model" self listMorph listChanged. self setScrollDeltas. scrollBar setValue: 0.0. index := self getCurrentSelectionIndex. self resetPotentialDropRow. index := index min: self getListSize. index > 0 ifTrue: [ self selectionIndex: index]. self searchedElement: nil. ! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:33'! wantsDropSelector ^wantsDropSelector! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:23'! mouseUpOnMultiple: event "Reset the mouseDownRow." dragOnOrOff := nil. "So improperly started drags will have not effect". event hand hasSubmorphs ifFalse: [ self mouseDownRow: nil]! ! !PluggableListMorph methodsFor: 'background coloring' stamp: 'BenjaminVanRyseghem 1/6/2014 15:54'! backgroundColorFor: aRow | return | aRow ifNil: [ ^ nil ]. self enabled ifFalse: [ return := Color white darker darker ]. self backgroundColoringBlockOrSelector ifNotNil: [:blockOrSelector || anItem | anItem := getListElementSelector ifNil: [ list at: aRow ifAbsent: [ ^ nil ]] ifNotNil: [ model perform: getListElementSelector with: aRow ]. return := blockOrSelector isBlock ifTrue: [ blockOrSelector cull: anItem cull: aRow ] ifFalse: [ blockOrSelector isSymbol ifTrue: [ blockOrSelector numArgs == 0 ifTrue: [ anItem perform: blockOrSelector ] ifFalse: [ self model perform: blockOrSelector withEnoughArguments: { anItem. aRow} ]] ifFalse: [ nil ]]]. ^ return isColor ifTrue: [ return ] ifFalse: [ nil ]! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/22/2001 22:49'! selectionIndex "return the index we have currently selected, or 0 if none" ^self listMorph selectedRow ifNil: [ 0 ]! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 4/17/2012 17:14'! mouseDownOnMultiple: event forRow: row | anInteger oldIndex oldVal valueKeeper | "Set meaning for subsequent dragging of selection" canMove ifFalse: [ ^ self ]. canMove := false. model okToChange ifFalse: [ canMove := true. ^ self ]. canMove := true. dragOnOrOff := (self listSelectionAt: row) not. valueKeeper := dragOnOrOff. " I store the value because #mouseUpOnMultiple: can reset dragOnOrOff before the end of this method (in case of halt by example)" (event shiftPressed not and: [event yellowButtonPressed not and: [ self autoDeselect ]]) ifTrue: [ self resetListSelection ]. oldIndex := self getCurrentSelectionIndex. oldIndex ~= 0 ifTrue: [oldVal := self listSelectionAt: oldIndex]. "Set or clear new primary selection (listIndex)" anInteger := valueKeeper ifTrue: [ row ] ifFalse: [ 0 ]. setIndexSelector ifNotNil: [ model perform: setIndexSelector with: anInteger ]. "Need to restore the old one, due to how model works, and set new one." oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. event shiftPressed ifTrue: [((oldIndex max: 1) min: row) to: (oldIndex max: row) do: [:i | self listSelectionAt: i put: valueKeeper]. self changed] ifFalse: [self listSelectionAt: row put: valueKeeper].! ! !PluggableListMorph methodsFor: 'model access' stamp: 'MarcusDenker 9/13/2013 16:27'! keystrokeAction: event | returnValue | keystrokeSelector ifNil: [ ^ nil ]. returnValue := model perform: keystrokeSelector withEnoughArguments: { event. self }. ^ returnValue = true! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/12/2006 14:52'! handleFocusEvent: anEvent "Handle the given event. This message is sent if the receiver currently has the focus and is therefore receiving events directly from some hand." self processEvent: anEvent. "give submorphs a chance" (anEvent isMouse and: [anEvent isMouseDown and: [(self fullContainsPoint: anEvent position) not]]) ifFalse: [^super handleFocusEvent: anEvent]. "click outside - pass to event handler" self eventHandler ifNotNil: [self eventHandler mouseDown: anEvent fromMorph: self]! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 5/17/2001 23:06'! maximumSelection ^ self getListSize! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:47'! resetListSelector ^ resetListSelector! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 2/11/2011 16:50'! adoptPaneColor: paneColor "Pass on to the border too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self selectionColor: self selectionColor. self fillStyle: self fillStyleToUse. self borderWidth > 0 ifTrue: [ self borderStyle: self borderStyleToUse]! ! !PluggableListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:20'! minimumSelection ^ 1! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 2/5/2004 18:02'! textColor: aColor "Set my default text color." self setProperty: #textColor toValue: aColor. self listMorph color: aColor.! ! !PluggableListMorph methodsFor: 'searching' stamp: 'BenjaminVanRyseghem 2/18/2012 16:14'! selectSearchedElement self searchedElement ifNotNil: [: index | ActiveEvent commandKeyPressed ifFalse: [ self resetListSelectionSilently ]. self changeModelSelection: index. self isMultipleSelection ifTrue: [ self listSelectionAt: index put: true ]. self vScrollValue: ((index-1)/self getListSize) ]! ! !PluggableListMorph methodsFor: 'model access' stamp: 'CamilloBruni 8/11/2011 06:29'! keystrokeSelector: aSymbol keystrokeSelector := aSymbol! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 2/11/2011 10:29'! selectionColor "Answer the colour to use for selected items." ^self valueOfProperty: #selectionColor ifAbsent: [self theme selectionColor] ! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:17'! beMultipleSelection multipleSelection := true! ! !PluggableListMorph methodsFor: 'separator' stamp: 'BenjaminVanRyseghem 9/16/2011 16:53'! separatorBlockOrSelector: aBlockOrSelector separatorBlockOrSelector := aBlockOrSelector! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'ar 3/17/2001 15:32'! itemFromPoint: aPoint "Return the list element (morph) at the given point or nil if outside" | ptY | scroller hasSubmorphs ifFalse:[^nil]. (scroller fullBounds containsPoint: aPoint) ifFalse:[^nil]. ptY := (scroller firstSubmorph point: aPoint from: self) y. "note: following assumes that submorphs are vertical, non-overlapping, and ordered" scroller firstSubmorph top > ptY ifTrue:[^nil]. scroller lastSubmorph bottom < ptY ifTrue:[^nil]. "now use binary search" ^scroller findSubmorphBinary:[:item| (item top <= ptY and:[item bottom >= ptY]) ifTrue:[0] "found" ifFalse:[ (item top + item bottom // 2) > ptY ifTrue:[-1] ifFalse:[1]]]! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/21/2012 13:13'! wrapSelector: aSymbol self basicWrapSelector: aSymbol. self updateList.! ! !PluggableListMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 2/9/2012 17:32'! selectAll self isMultipleSelection ifFalse: [ ^ self ]. 1 to: self maximumSelection do: [: i | self listSelectionAt: i put: true ]! ! !PluggableListMorph methodsFor: '*Spec-Core' stamp: ''! setIndexSelector: aSelector setIndexSelector := aSelector! ! !PluggableListMorph methodsFor: 'separator' stamp: 'BenjaminVanRyseghem 9/16/2011 16:57'! separatorSize: anInteger separatorSize := anInteger! ! !PluggableListMorph methodsFor: 'model access' stamp: 'ls 5/17/2001 22:04'! getListSize "return the current number of items in the displayed list" getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ]. ^self getList size! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 13:34'! enabled: aBoolean "Set the enablement state of the receiver." aBoolean = self enabled ifFalse: [self setProperty: #enabled toValue: aBoolean. self adoptPaneColor: self paneColor; changed]! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'gvc 9/12/2006 14:23'! handlesMouseOverDragging: evt "Yes, for mouse down highlight." ^true! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 4/17/2012 16:44'! mouseMove: evt self isMultipleSelection ifTrue: [ self mouseMoveOnMultiple: evt ] ifFalse: [ self mouseMoveOnSingle:evt ]! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:37'! textHighlightColor: aColor "Set my default text highlight color." self setProperty: #textHighlightColor toValue: aColor. ! ! !PluggableListMorph methodsFor: 'model access' stamp: 'BenjaminVanRyseghem 4/17/2012 15:34'! itemSelectedAmongMultiple: index "return whether the index-th row is selected. Always false in PluggableListMorph, but sometimes true in PluggableListMorphOfMany" ^ self isMultipleSelection ifTrue: [ (self listSelectionAt: index) == true ] ifFalse: [ false ]! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/21/2012 13:13'! basicWrapSelector: aSymbol wrapSelector := aSymbol.! ! !PluggableListMorph methodsFor: 'model access' stamp: 'CamilloBruni 8/11/2011 06:42'! modifierKeyPressed: event | args aChar | aChar := event keyCharacter. keystrokeActionSelector ifNil: [ ^ nil ]. args := keystrokeActionSelector numArgs. args = 1 ifTrue: [^ model perform: keystrokeActionSelector with: aChar]. args = 2 ifTrue: [^model perform: keystrokeActionSelector with: aChar with: self]. ^self error: 'keystrokeActionSelector must be a 1- or 2-keyword symbol'! ! !PluggableListMorph methodsFor: 'background coloring' stamp: 'CamilloBruni 9/16/2011 16:34'! backgroundColoringBlockOrSelector: aSelector backgroundColoringBlockOrSelector := aSelector! ! !PluggableListMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 7/18/2013 14:20'! update: aParameter "Refer to the comment in View|update:." (aParameter == getListSelector or: [ aParameter == getListElementSelector ]) ifTrue: [self updateList. ^ self]. aParameter == getIndexSelector ifTrue: [self selectionIndex: self getCurrentSelectionIndex. ^ self]. aParameter == #allSelections ifTrue: [self selectionIndex: self getCurrentSelectionIndex. ^ self changed]. aParameter isArray ifFalse: [ ^ self ]. aParameter size == 2 ifFalse: [ ^ self ]. aParameter first = #setMultipleSelection: ifTrue: [ self setMultipleSelection: aParameter second ]! ! !PluggableListMorph methodsFor: 'geometry' stamp: 'sps 3/9/2004 15:33'! extent: newExtent super extent: newExtent. "Change listMorph's bounds to the new width. It is either the size of the widest list item, or the size of self, whatever is bigger" self listMorph width: ((self width max: listMorph hUnadjustedScrollRange) + 20). ! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 1/10/2014 09:49'! mouseUpOnSingle: event "The mouse came up within the list; take appropriate action" | row mdr | row := self rowAtLocation: event position. event hand hasSubmorphs ifFalse: [ mdr := self mouseDownRow. self mouseDownRow: nil. mdr ifNil: [^self]]. (self enabled and: [model okToChange]) ifFalse: [^ self]. "No change if model is locked or receiver disabled" row == self selectionIndex ifTrue: [ self autoDeselect ifTrue: [ row = 0 ifFalse: [ self changeModelSelection: 0 ] ] ifFalse: [ self changeModelSelection: row ] ] ifFalse: [ self changeModelSelection: row ]. Cursor normal show! ! !PluggableListMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 2/9/2012 17:41'! deselectAll self isMultipleSelection ifFalse: [ ^ self ]. self resetListSelection! ! !PluggableListMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 12/20/2012 16:25'! scrollSelectionToRow: row "make sure that the current selection is visible" row = 0 ifTrue: [ ^ self ]. self scrollToShow: (self listMorph drawBoundsForRow: row)! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 11:47'! getEnabledSelector "Answer the value of getEnabledSelector" ^self valueOfProperty: #getEnabledSelector! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:19'! mouseDown: event onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'scrolling' stamp: 'gvc 8/27/2009 11:58'! resizeScrollBars "Fixed to not use deferred message that incorrectly sets scroll deltas/interval." (self extent = self defaultExtent) ifFalse: [super resizeScrollBars]! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/1/2011 12:01'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel self model: anObject. getListSelector := getListSel. getIndexSelector := getSelectionSel. setIndexSelector := setSelectionSel. getMenuSelector := getMenuSel. keystrokeActionSelector := keyActionSel. self autoDeselect: true. self borderWidth: 1. self updateList. self selectionIndex: self getCurrentSelectionIndex. self initForKeystrokes! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/20/2006 10:24'! mouseDownRow "Answer the mouse down row or nil if none." ^self listMorph mouseDownRow! ! !PluggableListMorph methodsFor: '*Spec-Core' stamp: ''! setSelectionListSelector: getListSel. setSelectionListSelector := getListSel! ! !PluggableListMorph methodsFor: '*Spec-Core' stamp: ''! getSelectionListSelector: getListSel. getSelectionListSelector := getListSel! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! mouseUp: event onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'events' stamp: 'GuillermoPolito 9/1/2010 18:40'! doubleClick: event | index | doubleClickSelector ifNil: [^super doubleClick: event]. index := self rowAtLocation: event position. index = 0 ifTrue: [^super doubleClick: event]. "selectedMorph ifNil: [self setSelectedMorph: aMorph]." ^ self model perform: doubleClickSelector! ! !PluggableListMorph methodsFor: 'geometry' stamp: 'sps 3/9/2004 17:31'! scrollDeltaWidth "A guess -- assume that the width of a char is approx 1/2 the height of the font" ^ self scrollDeltaHeight // 2 ! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:47'! resetListSelector: aSelector resetListSelector := aSelector! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 12:42'! borderStyleToUse "Answer the borderStyle that should be used for the receiver." ^self enabled ifTrue: [self theme listNormalBorderStyleFor: self] ifFalse: [self theme listDisabledBorderStyleFor: self]! ! !PluggableListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:33'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel "Create a 'pluggable' list view on the given model parameterized by the given message selectors." ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel ! ! !PluggableListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:33'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel "Create a 'pluggable' list view on the given model parameterized by the given message selectors." ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: nil keystroke: #arrowKey:from: "default"! ! !PluggableListMorph class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/1/2011 11:47'! on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel ^ self new on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel! ! !PluggableListMorph class methodsFor: 'instance creation' stamp: 'md 7/13/2005 16:33'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel "Create a 'pluggable' list view on the given model parameterized by the given message selectors." ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: #arrowKey:from: "default" ! ! !PluggableListMorph class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/1/2011 11:47'! on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel ^ self new on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: #arrowKey:from: "default"! ! !PluggableMenuItemSpec methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 11/29/2013 15:16'! addToMenuGroupModel: aMenuGroupModel aMenuGroupModel addItem: [ :item | item fromSpec: self ]! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:28'! separator "Answer whether the receiver should be followed by a separator" ^separator ifNil:[false]! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 17:24'! enabled "Answer whether the receiver is enabled" ^ enabledBlock ifNil:[enabled ifNil: [ true ]] ifNotNil: [ enabledBlock value ]! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:22'! separator: aBool "Indicate whether the receiver should be followed by a separator" separator := aBool.! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:22'! subMenu: aMenuSpec "Answer the receiver's subMenu" subMenu := aMenuSpec! ! !PluggableMenuItemSpec methodsFor: 'initialize' stamp: 'AlainPlantec 2/15/2010 11:28'! analyzeLabel "For Morphic compatiblity. Some labels include markup such as , etc. Analyze the label for these annotations and take appropriate action." label ifNotNil: [ | marker | marker := label copyFrom: 1 to: (label indexOf: $>). (marker = '' or:[marker = '']) ifTrue:[ checked := true. label := label copyFrom: marker size+1 to: label size. ]. (marker = '' or:[marker = '']) ifTrue:[ checked := false. label := label copyFrom: marker size+1 to: label size. ]] ! ! !PluggableMenuItemSpec methodsFor: 'Morphic-Base-Menus' stamp: 'EstebanLorenzano 1/30/2013 16:45'! asMenuItemMorphFrom: parentMenu isLast: aBoolean | it act lbl menu | it := self morphClass new. lbl := self label ifNil: ['']. "here checked can be nil, true, false" checked notNil ifTrue: [ lbl := self hasCheckBox -> lbl]. it contents: lbl. it icon: self icon. it keyText: self keyText. it isEnabled: self enabled. (act := self action) ifNotNil: [ it target: act receiver; selector: act selector; arguments: act arguments ]. (menu := self subMenu) ifNotNil: [ self enabled ifTrue: [ it subMenu: (menu asMenuMorph) ]]. parentMenu ifNotNil: [ parentMenu addMorphBack: it ]. aBoolean ifFalse: [ self separator ifTrue: [ parentMenu addLine ] ]. ^it! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'AlainPlantec 2/10/2010 08:19'! hasCheckBox ^ checked notNil! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/30/2013 16:44'! keyText: aString keyText := aString.! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:23'! action: aMessageSend "Answer the action associated with the receiver" action := aMessageSend! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 17:23'! enabledBlock ^ enabledBlock! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'AlainPlantec 2/12/2010 22:22'! icon: aForm icon := aForm! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:22'! subMenu "Answer the receiver's subMenu" ^subMenu! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'AlainPlantec 2/8/2010 11:16'! checked "Answer whether the receiver is checked" ^checked ! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:23'! action "Answer the action associated with the receiver" ^action! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:20'! label "Answer the receiver's label" ^label! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:21'! checked: aBool "Indicate whether the receiver is checked" checked := aBool.! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 17:23'! enabledBlock: aBlock enabledBlock := aBlock! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/30/2013 16:45'! keyText ^keyText! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:21'! enabled: aBool "Indicate whether the receiver is enabled" enabled := aBool! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:21'! label: aString "Set the receiver's label" label := aString! ! !PluggableMenuItemSpec methodsFor: 'Morphic-Base-Menus' stamp: 'StephaneDucasse 6/10/2011 22:14'! morphClass ^ ToggleMenuItemMorph! ! !PluggableMenuItemSpec methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 11/29/2013 16:05'! addToMenuItemModel: aMenuItemModel | en | en := self enabledBlock ifNil: [ self enabled ]. aMenuItemModel name: self label; state: self checked; enabled: en; icon: self icon; shortcut: self keyText; subMenu:self subMenu; action: self action! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'AlainPlantec 2/12/2010 22:22'! icon ^ icon! ! !PluggableMenuSpec commentStamp: 'StephaneDucasse 6/6/2011 22:13'! I'm a spec for a menu. The World menu pragma based registration uses it for now. I'm moved in this package so that later the ToolBuilder package can be unloaded. We could probably avoid MenuSpec and just use MenuMorph instead. ! !PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:12'! label: aString label := aString.! ! !PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:27'! addMenuItem | item | item := self newMenuItem. self items add: item. ^item! ! !PluggableMenuSpec methodsFor: 'accessing' stamp: 'cwp 6/8/2005 23:36'! model: anObject model := anObject! ! !PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:25'! addSeparator self items isEmpty ifTrue:[^nil]. self items last separator: true.! ! !PluggableMenuSpec methodsFor: '*Spec-Core' stamp: 'StephaneDucasse 3/5/2014 10:10'! addToMenuModel: aMenuModel | groups tmp | groups := OrderedCollection new. self label ifNotNil: [ aMenuModel title: self label ]. "only change the title when a new one is specified" tmp := OrderedCollection new. self items do: [ :each | tmp add: each. each separator ifTrue: [ groups add: tmp copy. tmp removeAll ] ]. tmp ifNotEmpty: [ groups add: tmp copy ]. groups do: [ :each | aMenuModel addGroup: [ :group | each do: [ :spec | group addItem: [ :item | item fromSpec: spec ] ] ] ]! ! !PluggableMenuSpec methodsFor: 'accessing' stamp: 'cwp 6/8/2005 23:36'! model ^ model! ! !PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:26'! add: aString action: aMessageSend | item | item := self addMenuItem. item label: aString. item action: aMessageSend. ^item! ! !PluggableMenuSpec methodsFor: 'Morphic-Base-Menus' stamp: 'MarcusDenker 9/26/2011 10:51'! asMenuMorph | prior menu myitems | prior := parentMenu. parentMenu := menu := self morphClass new. self label ifNotNil: [parentMenu addTitle: self label]. prior ifNil: [menu addStayUpIcons]. myitems := self items. myitems do:[:each| each asMenuItemMorphFrom: parentMenu isLast: (each = myitems last)]. parentMenu := prior. ^menu! ! !PluggableMenuSpec methodsFor: 'Morphic-Base-Menus' stamp: 'BenjaminVanRyseghem 4/17/2011 15:06'! buildWith: aBuilder ^ self asMenuMorph! ! !PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:12'! label ^label! ! !PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:27'! newMenuItem ^PluggableMenuItemSpec new! ! !PluggableMenuSpec methodsFor: 'construction' stamp: 'AlainPlantec 2/8/2010 11:23'! add: aString ^ self add: aString action: nil ! ! !PluggableMenuSpec methodsFor: 'construction' stamp: 'AlainPlantec 2/13/2010 12:35'! add: aString selector: aSelector argumentList: anArray ^self add: aString action: (MessageSend receiver: model selector: aSelector arguments: anArray).! ! !PluggableMenuSpec methodsFor: 'construction' stamp: 'FernandoOlivero 4/12/2011 10:12'! addList: aList "Add the given items to this menu, where each item is a pair ( ).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help." aList do: [:tuple | (tuple == #-) ifTrue: [self addSeparator] ifFalse:[ | item | item := self add: tuple first target: model selector: tuple second argumentList: #(). (tuple size > 2 and: [tuple third notNil]) ifTrue: [item help: tuple third]. (tuple size > 3 and: [tuple fourth notNil]) ifTrue: [item icon: (self theme iconNamed: tuple fourth)]]]! ! !PluggableMenuSpec methodsFor: 'Morphic-Base-Menus' stamp: 'BenjaminVanRyseghem 4/11/2011 19:34'! morphClass ^ MenuMorph! ! !PluggableMenuSpec methodsFor: 'construction' stamp: 'AlainPlantec 2/11/2010 15:25'! analyzeItemLabels "Analyze the item labels" items ifNotNil: [items do:[:item| item analyzeLabel]] ! ! !PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:25'! add: aString target: anObject selector: aSelector argumentList: anArray ^self add: aString action: (MessageSend receiver: anObject selector: aSelector arguments: anArray).! ! !PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:27'! items ^ items ifNil: [items := OrderedCollection new]! ! !PluggableMenuSpec class methodsFor: 'example' stamp: 'MarcusDenker 7/8/2012 12:12'! exampleWithTwoSimpleItems "self exampleWithTwoSimpleItems" | s | s := (self withModel: Transcript ) label: 'Hello'. s add: 'Print Hello' action: (MessageSend receiver: [Transcript show: 'Hello', String cr] selector: #value). s add: 'Print Hello again' selector: #show: argumentList: {'Hello again', String cr}. s asMenuMorph popUpInWorld! ! !PluggableMenuSpec class methodsFor: 'example' stamp: 'MarcusDenker 7/8/2012 12:11'! exampleWithOneSingleItem "self exampleWithOneSingleItem" | s | s := (self withModel: nil ) label: 'Hello'. s add: 'Print Hello' action: (MessageSend receiver: [Transcript show: 'Hello', String cr] selector: #value). s asMenuMorph popUpInWorld! ! !PluggableMenuSpec class methodsFor: 'instance creation' stamp: 'cwp 6/9/2005 00:22'! withModel: aModel ^ self new model: aModel! ! !PluggableMenuSpec class methodsFor: 'example' stamp: 'MarcusDenker 7/8/2012 12:13'! exampleWithSubMenu " self exampleWithSubMenu " | s i sub | s := (self withModel: nil ) label: 'Tools'. i := s add: 'Tools'. sub := (self withModel: nil ). sub add: 'System browser' target: Smalltalk tools selector: #openClassBrowser argumentList: #(). sub add: 'Workspace' target: Smalltalk tools selector: #openWorkspace argumentList: #(). i subMenu: sub. s asMenuMorph popUpInWorld! ! !PluggableMorphListMorph commentStamp: 'gvc 5/18/2007 12:30'! A type of PluggableListMorph that supports morphs for items. Useful for lists with icons etc.! !PluggableMorphListMorph methodsFor: 'geometry' stamp: 'gvc 5/3/2006 14:23'! extent: newExtent "Change listMorph's bounds to the new width. It is either the size of the widest list item, or the size of self, whatever is bigger" super extent: newExtent. self listMorph width: (self innerBounds width max: listMorph hUnadjustedScrollRange). ! ! !PluggableMorphListMorph methodsFor: 'scrolling' stamp: 'gvc 5/3/2006 14:24'! hExtraScrollRange "Return the amount of extra blank space to include to the right of the scroll content." ^12! ! !PluggableMorphListMorph methodsFor: 'initialization' stamp: 'gvc 5/3/2006 09:50'! listMorphClass "Answer the class to use for the list morph." ^LazyMorphListMorph! ! !PluggableMorphListMorph methodsFor: 'model access' stamp: 'gvc 10/17/2008 12:38'! getList "Answer the list to be displayed. Caches the returned list in the 'list' ivar" getListSelector isNil ifTrue: [^#()]. list := model perform: getListSelector. list isNil ifTrue: [^ #()]. ^list! ! !PluggableMultiColumnListMorph commentStamp: ''! This morph can be used to show a list having multiple columns, The columns are self width sized to make the largest entry in each list fit. In some cases the pane may then be too narrow. Use it like a regular PluggableListMorph except pass in an array of lists instead of a single list. There are base assumptions made here that each list in the array of lists is the same size. Also, the highlight color for the selection is easy to modify in the #highlightSelection method. I used blue when testing just to see it work.! !PluggableMultiColumnListMorph methodsFor: 'model access' stamp: 'BenjaminVanRyseghem 11/29/2011 09:57'! getList "fetch and answer the lists to be displayed" getListSelector == nil ifTrue: [^ #()]. list := model perform: getListSelector. list == nil ifTrue: [^ #()]. list := list collectWithIndex: [ :each :index | self wrapItem: each index: index]. ^ list! ! !PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'BenjmainVanRyseghem 11/5/2011 11:33'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel wrapSelector: wrapSel self model: anObject. getListSelector := getListSel. getIndexSelector := getSelectionSel. setIndexSelector := setSelectionSel. getMenuSelector := getMenuSel. keystrokeActionSelector := keyActionSel. wrapSelector := wrapSel. self autoDeselect: true. self borderWidth: 1. self updateList. self selectionIndex: self getCurrentSelectionIndex. self initForKeystrokes! ! !PluggableMultiColumnListMorph methodsFor: 'searching' stamp: 'BenjaminVanRyseghem 2/13/2012 17:38'! listForSearching ^ super listForSearching collect: #first! ! !PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'nk 4/5/2001 23:18'! itemFromPoint: aPoint "Return the list element (morph) at the given point or nil if outside" | ptY | scroller hasSubmorphs ifFalse:[^nil]. (scroller fullBounds containsPoint: aPoint) ifFalse:[^nil]. ptY := (scroller firstSubmorph point: aPoint from: self) y. "note: following assumes that submorphs are vertical, non-overlapping, and ordered" scroller firstSubmorph top > ptY ifTrue:[^nil]. scroller lastSubmorph bottom < ptY ifTrue:[^nil]. "now use binary search" ^scroller submorphThat: [ :item | item top <= ptY and:[item bottom >= ptY] ] ifNone: []. ! ! !PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/8/2011 13:01'! gapSize ^ gapSize ifNil: [ gapSize := 10 ]! ! !PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/6/2011 15:40'! getListSize | l | getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ]. l := self getList. l isEmpty ifTrue: [ ^ 0 ]. ^l size! ! !PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/6/2011 13:42'! getListRow: row "return the strings that should appear in the requested row" getListElementSelector ifNotNil: [ ^model perform: getListElementSelector with: row ]. ^self getList at: row! ! !PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'ls 5/17/2001 20:01'! listMorphClass ^MulticolumnLazyListMorph! ! !PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/8/2011 13:09'! gapSize: anInteger gapSize := anInteger.! ! !PluggableMultiColumnListMorph methodsFor: 'model access' stamp: 'ls 11/14/2002 13:13'! basicKeyPressed: aChar "net supported for multi-column lists; which column should be used?!! The issue is that the base class implementation uses getList expecting a single collectino to come back instead of several of them" ^self! ! !PluggableMultiColumnListMorph class methodsFor: 'instance creation' stamp: 'BenjmainVanRyseghem 11/5/2011 11:36'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel wrapSelector: wrapSel "Create a 'pluggable' list view on the given model parameterized by the given message selectors." ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: #arrowKey:from: "default" wrapSelector: wrapSel! ! !PluggableMultiColumnListMorph class methodsFor: 'instance creation' stamp: 'BenjmainVanRyseghem 11/5/2011 11:32'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel wrapSelector: wrapSel "Create a 'pluggable' list view on the given model parameterized by the given message selectors." ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel wrapSelector: wrapSel! ! !PluggablePanelMorph commentStamp: 'ar 2/11/2005 20:13'! A pluggable panel morph which deals with changing children.! !PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:48'! model ^model! ! !PluggablePanelMorph methodsFor: 'update' stamp: 'marcus.denker 9/14/2008 18:59'! update: what what ifNil: [^self]. what == getChildrenSelector ifTrue:[ self removeAllMorphs. self addAllMorphs: (model perform: getChildrenSelector). self submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. ].! ! !PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:47'! getChildrenSelector ^getChildrenSelector! ! !PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:48'! model: aModel model ifNotNil:[model removeDependent: self]. model := aModel. model ifNotNil:[model addDependent: self].! ! !PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:47'! getChildrenSelector: aSymbol getChildrenSelector := aSymbol.! ! !PluggableSet commentStamp: 'MarcusDenker 3/23/2010 18:47'! PluggableSets allow the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the set which in turn can heavily improve the performance of sets and dictionaries. Note: As of Pharo 1.1#11284, using normal Dictionary is actually faster as the bench below shows... ;-) Instance variables: hashBlock A one argument block used for hashing the elements. equalBlock A two argument block used for comparing the elements. Example: Adding 1000 integer points in the range (0@0) to: (100@100) to a set. | rnd set max pt | set := Set new: 1000. rnd := Random new. max := 100. Time millisecondsToRun:[ 1 to: 1000 do:[:i| pt := (rnd next * max) truncated @ (rnd next * max) truncated. set add: pt. ]. ]. The above is way slow since the default hashing function of points leads to an awful lot of collisions in the set. And now the same, with a somewhat different hash function: | rnd set max pt | set := PluggableSet new: 1000. set hashBlock:[:item| (item x bitShift: 16) + item y]. rnd := Random new. max := 100. Time millisecondsToRun:[ 1 to: 1000 do:[:i| pt := (rnd next * max) truncated @ (rnd next * max) truncated. set add: pt. ]. ]. ! !PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 19:02'! hashBlock: aBlock "Set a new hash block. The block must accept one argument and return the hash value of the given argument." hashBlock := aBlock.! ! !PluggableSet methodsFor: 'accessing' stamp: 'ar 11/27/1998 23:55'! equalBlock: aBlock "Set a new equality block. The block must accept two arguments and return true if the argumets are considered equal, false otherwise" equalBlock := aBlock.! ! !PluggableSet methodsFor: 'copying' stamp: 'nice 10/5/2009 10:15'! copyEmpty ^super copyEmpty hashBlock: hashBlock; equalBlock: equalBlock! ! !PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:43'! hashBlock "Return the block used for hashing the elements in the receiver." ^hashBlock! ! !PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:43'! equalBlock "Return the block used for comparing the elements in the receiver." ^equalBlock! ! !PluggableSet methodsFor: 'private' stamp: 'IgorStasenko 5/30/2011 18:54'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or raise an error if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | index start | index := start := (hashBlock ifNil: [anObject hash] ifNotNil: [ hashBlock value: anObject]) \\ array size + 1. [ | element | ((element := array at: index) == nil or: [ equalBlock ifNil: [element enclosedSetElement = anObject] ifNotNil: [ equalBlock value: element enclosedSetElement value: anObject ]]) ifTrue: [ ^index ]. (index := index \\ array size + 1) = start ] whileFalse. self errorNoFreeSpace! ! !PluggableSet methodsFor: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 22:52'! scanForEmptySlotFor: aKey "Scan the key array for the first slot containing an empty slot (indicated by a nil). Answer the index of that slot. This method will be overridden in various subclasses that have different interpretations for matching elements." | index start | index := start := (hashBlock ifNil: [ aKey hash ] ifNotNil: [ hashBlock value: aKey ]) \\ array size + 1. [ (array at: index) ifNil: [ ^index ]. (index := index \\ array size + 1) = start ] whileFalse. self errorNoFreeSpace! ! !PluggableSet class methodsFor: 'as yet unclassified' stamp: 'dvf 6/10/2000 18:13'! integerSet ^self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! ! !PluggableSetTest commentStamp: 'TorstenBergmann 2/20/2014 15:28'! SUnit tests for pluggable sets! !PluggableSetTest methodsFor: 'requirements' stamp: 'CamilloBruni 7/3/2013 12:58'! classToBeTested ^ PluggableSet! ! !PluggableSetTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 12:34'! classToBeTested ^ IdentitySet! ! !PluggableSliderMorph commentStamp: 'gvc 7/16/2007 13:57'! A pluggable slider (rather than one that auto-generates access selectors). Needs to be themed...! !PluggableSliderMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2012 16:14'! updateLabel "Update the label." self model ifNotNil: [:m | self getLabelSelector ifNotNil: [:selector | self label: (m perform: selector) ]]! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 6/20/2007 14:31'! getValueSelector "Answer the value of getValueSelector" ^ getValueSelector! ! !PluggableSliderMorph methodsFor: 'initialization' stamp: 'gvc 6/20/2007 15:02'! defaultColor "Answer the default color/fill style for the receiver." ^Color white! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/3/2007 15:19'! enabled "Answer the value of enabled" ^ enabled! ! !PluggableSliderMorph methodsFor: 'protocol' stamp: 'gvc 8/3/2007 15:25'! borderStyleToUse "Answer the borderStyle that should be used for the receiver." ^self enabled ifTrue: [self theme sliderNormalBorderStyleFor: self] ifFalse: [self theme sliderDisabledBorderStyleFor: self]! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 10:43'! max "Answer the value of max" ^ max! ! !PluggableSliderMorph methodsFor: 'event handling' stamp: 'gvc 6/20/2007 14:27'! handlesMouseDown: evt "Answer true." ^true! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/7/2007 11:58'! adoptPaneColor: paneColor "Pass on to the border too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self fillStyle: self fillStyleToUse; borderStyle: self borderStyleToUse; sliderColor: (self enabled ifTrue: [paneColor twiceDarker] ifFalse: [self paneColor twiceDarker paler])! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 6/20/2007 14:31'! setValueSelector: aSymbol "Directly set the selector to make more flexible." setValueSelector := aSymbol! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 6/20/2007 14:31'! getValueSelector: anObject "Set the value of getValueSelector" getValueSelector := anObject! ! !PluggableSliderMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/18/2012 16:05'! initialize "Initialize the receiver." min := 0. max := 1. label := ''. super initialize. self enabled: true! ! !PluggableSliderMorph methodsFor: 'protocol' stamp: 'gvc 8/3/2007 15:19'! enable "Enable the receiver." self enabled: true! ! !PluggableSliderMorph methodsFor: 'layout' stamp: 'gvc 8/3/2007 15:14'! layoutBounds: aRectangle "Set the bounds for laying out children of the receiver. Note: written so that #layoutBounds can be changed without touching this method" super layoutBounds: aRectangle. self computeSlider! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:14'! quantum "Answer the value of quantum" ^ quantum! ! !PluggableSliderMorph methodsFor: 'scrolling' stamp: 'gvc 8/7/2007 10:37'! scrollAbsolute: event "Ignore if disabled." self enabled ifFalse: [^self]. ^super scrollAbsolute: event! ! !PluggableSliderMorph methodsFor: 'other events' stamp: 'gvc 8/7/2007 10:36'! mouseDownInSlider: event "Ignore if disabled." self enabled ifFalse: [^self]. ^super mouseDownInSlider: event! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:18'! setValueSelector "Answer the set selector." ^setValueSelector! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:05'! getLabelSelector ^ getLabelSelector! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/3/2007 15:21'! enabled: anObject "Set the value of enabled" enabled = anObject ifTrue: [^self]. enabled := anObject. self changed: #enabled. self adoptPaneColor: self paneColor; changed! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:20'! quantum: anObject "Set the value of quantum" quantum := anObject. self setValue: self value! ! !PluggableSliderMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:18'! fontColor ^ Color black! ! !PluggableSliderMorph methodsFor: 'event handling' stamp: 'gvc 6/20/2007 14:28'! scrollPoint: event "Scroll to the event position." | r p | r := self roomToMove. bounds isWide ifTrue: [r width = 0 ifTrue: [^ self]] ifFalse: [r height = 0 ifTrue: [^ self]]. p := event position - (self sliderThickness // 2) adhereTo: r. self descending ifFalse: [self setValue: (bounds isWide ifTrue: [(p x - r left) asFloat / r width] ifFalse: [(p y - r top) asFloat / r height])] ifTrue: [self setValue: (bounds isWide ifTrue: [(r right - p x) asFloat / r width] ifFalse: [(r bottom - p y) asFloat / r height])]! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/14/2013 15:44'! label: aLabel label := aLabel. self changed.! ! !PluggableSliderMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:34'! labelGap ^ 2! ! !PluggableSliderMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2013 14:34'! update: aParameter aParameter = getEnabledSelector ifTrue: [ ^ self updateEnabled ]. aParameter = getValueSelector ifTrue: [ ^ self updateValue ]. aParameter = getLabelSelector ifTrue: [ ^ self updateLabel ]. aParameter isArray ifFalse: [ ^ self ]. aParameter size == 2 ifFalse: [ ^ self ]. aParameter first = #max: ifTrue: [ self max: aParameter second ]. aParameter first = #min: ifTrue: [ self min: aParameter second ]. aParameter first = #quantum: ifTrue: [ self quantum: aParameter second ]. aParameter first = #scaledValue: ifTrue: [ self scaledValue: aParameter second ]. aParameter first = #value: ifTrue: [ self value: aParameter second ].! ! !PluggableSliderMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:32'! drawOn: aCanvas super drawOn: aCanvas. aCanvas drawString: self label in: self labelBounds font: self font color: self fontColor. ! ! !PluggableSliderMorph methodsFor: '*Athens-Morphic' stamp: 'IgorStasenko 10/11/2012 14:41'! drawOnAthensCanvas: aCanvas super drawOn: aCanvas. aCanvas morphicDrawString: self label in: self labelBounds font: self font color: self fontColor. ! ! !PluggableSliderMorph methodsFor: 'protocol' stamp: 'gvc 8/3/2007 15:19'! disable "Disable the receiver." self enabled: false! ! !PluggableSliderMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2012 16:14'! updateEnabled "Update the enablement state." self model ifNotNil: [:m | self getEnabledSelector ifNotNil: [:s | self enabled: (m perform: s)]]! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:21'! min: anObject "Set the value of min" min := anObject. self setValue: self value! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 10:43'! min "Answer the value of min" ^ min! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/13/2012 05:01'! max: anObject "Set the value of max" max := anObject. self setValue: self value! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2009 13:03'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:13'! getLabelSelector: aSymbol getLabelSelector := aSymbol. self updateLabel! ! !PluggableSliderMorph methodsFor: 'instance creation' stamp: 'gvc 6/20/2007 14:29'! on: anObject getValue: getSel setValue: setSel "Use the given selectors as the interface." self model: anObject; getValueSelector: getSel; setValueSelector: setSel; updateValue! ! !PluggableSliderMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2012 16:14'! updateValue "Update the value." self model ifNotNil: [:m | self getValueSelector ifNotNil: [:s | self scaledValue: (m perform: s)]]! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'GaryChambers 10/13/2011 17:46'! scaledValue: newValue "Set the scaled value." |val| val := newValue. self quantum ifNotNil: [:q | val := val roundTo: q]. self value: (self max <= self min ifTrue: [0] ifFalse: [val - self min / (self max - self min)])! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'MarcusDenker 12/11/2009 07:41'! scaledValue "Answer the scaled value." |val| val := self value * (self max - self min) + self min. self quantum ifNotNil: [:q | val := val roundTo: q]. ^(val max: self min) min: self max! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:07'! label ^ label! ! !PluggableSliderMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:42'! labelBounds | deltaY deltaX labelWidth treshold bnd | bnd := self innerBounds. labelWidth := self font widthOfStringOrText: self label. deltaY := self height - self font height / 2. treshold := (bnd left + self labelGap + labelWidth). ((slider left < treshold) or: [ (sliderShadow visible and: [sliderShadow left < treshold])]) ifTrue: [ deltaX := bnd width - self labelGap - labelWidth ] ifFalse: [ deltaX := self labelGap ]. ^ bnd translateBy: (deltaX@deltaY)! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/3/2007 15:24'! fillStyleToUse "Answer the fillStyle that should be used for the receiver." ^self enabled ifTrue: [self theme sliderNormalFillStyleFor: self] ifFalse: [self theme sliderDisabledFillStyleFor: self]! ! !PluggableSliderMorph methodsFor: 'layout' stamp: 'gvc 8/8/2007 15:32'! minHeight "Answer the receiver's minimum height. Give it a bit of a chance..." ^8 max: super minHeight! ! !PluggableSliderMorph methodsFor: 'event handling' stamp: 'gvc 8/7/2007 10:35'! mouseDown: anEvent "Set the value directly." self enabled ifTrue: [ self scrollPoint: anEvent; computeSlider]. super mouseDown: anEvent. self enabled ifFalse: [^self]. anEvent hand newMouseFocus: slider event: anEvent. slider mouseEnter: anEvent copy; mouseDown: anEvent copy ! ! !PluggableSliderMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:18'! font ^ StandardFonts defaultFont! ! !PluggableSliderMorph methodsFor: 'initialization' stamp: 'gvc 6/20/2007 15:00'! initializeSlider "Make the slider raised." super initializeSlider. slider borderStyle: (BorderStyle raised baseColor: slider color; width: 1)! ! !PluggableSliderMorph methodsFor: 'access' stamp: 'gvc 6/20/2007 14:57'! sliderColor: newColor "Set the slider colour." super sliderColor: newColor. slider ifNotNil: [slider borderStyle baseColor: newColor]! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/10/2009 13:32'! getEnabledSelector: aSymbol "Set the value of getEnabledSelector" getEnabledSelector := aSymbol. self updateEnabled! ! !PluggableSliderMorph methodsFor: 'model access' stamp: 'BenjaminVanRyseghem 7/18/2012 15:21'! setValue: newValue "Called internally for propagation to model." |scaled| value := newValue. self scaledValue: (scaled := self scaledValue). self model ifNotNil: [ self setValueSelector ifNotNil: [:sel | self model perform: sel with: scaled]]! ! !PluggableSliderMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:28'! on: anObject getValue: getSel setValue: setSel "Answer a new instance of the receiver with the given selectors as the interface." ^self new on: anObject getValue: getSel setValue: setSel! ! !PluggableSliderMorph class methodsFor: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:27'! on: anObject getValue: getSel setValue: setSel min: min max: max quantum: quantum "Answer a new instance of the receiver with the given selectors as the interface." ^self new min: min; max: max; quantum: quantum; on: anObject getValue: getSel setValue: setSel! ! !PluggableSystemWindow commentStamp: 'ar 2/11/2005 20:14'! A pluggable system window. Fixes the issues with label retrieval and adds support for changing children.! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'! getChildrenSelector: aSymbol getChildrenSelector := aSymbol! ! !PluggableSystemWindow methodsFor: 'updating' stamp: 'ar 2/11/2005 20:15'! update: what what ifNil:[^self]. what == getLabelSelector ifTrue:[self setLabel: (model perform: getLabelSelector)]. what == getChildrenSelector ifTrue:[ children ifNil:[children := #()]. self removeAllMorphsIn: children. children := model perform: getChildrenSelector. self addAllMorphs: children. children do:[:m| m hResizing: #spaceFill; vResizing: #spaceFill]. ]. ^super update: what! ! !PluggableSystemWindow methodsFor: 'initialization' stamp: 'ar 9/17/2005 21:08'! delete closeWindowSelector ifNotNil:[model perform: closeWindowSelector]. super delete. ! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:05'! closeWindowSelector: aSymbol closeWindowSelector := aSymbol! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:52'! label ^label contents! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'! getChildrenSelector ^getChildrenSelector! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'md 8/31/2005 07:59'! addPaneMorph: aMorph self addMorph: aMorph fullFrame: aMorph layoutFrame! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'! getLabelSelector ^getLabelSelector! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:51'! label: aString self setLabel: aString.! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:53'! getLabelSelector: aSymbol getLabelSelector := aSymbol. self update: aSymbol.! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:05'! closeWindowSelector ^closeWindowSelector! ! !PluggableTabBarMorph commentStamp: 'KLC 9/17/2004 11:26'! This morph manages a set of PluggableTabButtonMorphs. Each tab should be added in the left to right order that they should be displayed. Each tab will be evenly sized to fit the available space. This morph intercepts mouse clicks, figures out which tab was clicked, pops up the new tab as the active tab and triggers the registered event. See PluggableTabButtonMorph for information on what a tab can consist of. Example: (PluggableTabBarMorph on: nil) addTab: (Text fromString: 'Test') withAction: [Transcript show: 'Test'; cr]; addTab: (Text fromString: 'Another') withAction: [Transcript show: 'Another'; cr]; width: 200; openInHand ! !PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 13:25'! tabs tabs ifNil: [ tabs := OrderedCollection new ]. ^ tabs! ! !PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 10:37'! target ^ target! ! !PluggableTabBarMorph methodsFor: 'actions' stamp: 'tlk 7/17/2004 14:35'! performActiveTabAction "Look up the Symbol or Block associated with the currently active tab, and perform it." | tabActionAssoc aSymbolOrBlock | tabActionAssoc := self tabs detect: [ :assoc | assoc key = self activeTab.] ifNone: [ Association new ]. aSymbolOrBlock := tabActionAssoc value. aSymbolOrBlock ifNil: [ ^ false ]. ^ aSymbolOrBlock isSymbol ifTrue: [ self target perform: aSymbolOrBlock ] ifFalse: [ aSymbolOrBlock value ]. ! ! !PluggableTabBarMorph methodsFor: 'drawing' stamp: 'KLC 2/24/2004 15:10'! drawOn: aCanvas self tabs size > 0 ifFalse: [^ self ]. self tabs do: [ :anAssociation | | tab | tab := anAssociation key. tab drawOn: aCanvas]! ! !PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 14:17'! activeTab activeTab ifNil: [ self tabs size > 0 ifTrue: [ activeTab := self tabs first key. activeTab active: true]]. ^ activeTab ! ! !PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/2/2004 17:49'! layoutChanged "Fix up our tabs bounds" | tabsCount | super layoutChanged. tabsCount := self tabs size. tabsCount isZero ifFalse: [ | tabInnerExtent count | tabInnerExtent := ((self width - ((self tabs first key outerGap + self tabs last key outerGap) // 2) - tabsCount) // tabsCount) @ (self height). count := 1. self tabs do: [ :anAssociation | | tab | tab := anAssociation key. tab innerExtent: tabInnerExtent. count = 1 ifTrue: [tab position: self position] ifFalse: [ tab position: (self position translateBy: ((tabInnerExtent x + 1) * (count - 1))@0)]. count := count + 1 ] ]. self changed.! ! !PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/24/2004 15:14'! mouseDown: anEvent | xPosition newTab | xPosition := anEvent cursorPoint x. newTab := ((self tabs detect: [ :anAssociation | | tabBounds | tabBounds := anAssociation key bounds. (tabBounds left <= xPosition) and: [ tabBounds right >= xPosition]] ifNone: [nil]) key). newTab ifNil: [^ self]. newTab = activeTab ifFalse: [ self activeTab: newTab ] ! ! !PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/2/2004 16:22'! handlesMouseDown: anEvent ^ true! ! !PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/24/2004 15:26'! addTab: aStringOrTextOrMorph withAction: aSymbolOrBlock "Add a new tab. The tab will be added onto the end of the list and displayed on the far right of previously added tabs. The first argument can be a simple String, a Text, or any Morph. The second argument is the action to be performed when the tab is selected. It can either be a symbol for a unary method on the target object or a block. Each tab is stored as an Association with the created tab as the key and the selector as the value." | tabMorph | tabMorph := PluggableTabButtonMorph on: nil label: [ aStringOrTextOrMorph]. tabMorph color: self color. self addMorphBack: tabMorph. self tabs ifEmpty: [ self activeTab: tabMorph ]. self tabs add: (Association key: tabMorph value: aSymbolOrBlock). self layoutChanged. self changed.! ! !PluggableTabBarMorph methodsFor: 'private - access' stamp: 'BenjaminVanRyseghem 1/9/2012 18:26'! activeTab: aTabMorph self activeTab ifNotNil: [self activeTab toggle]. activeTab := aTabMorph. self activeTab toggle. aTabMorph delete. self addMorphFront: aTabMorph. aTabMorph takeKeyboardFocus. self performActiveTabAction. self changed. ! ! !PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 17:36'! color: aFillStyle color := aFillStyle. self tabs do: [ :anAssociation | anAssociation key color: aFillStyle ] ! ! !PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 10:37'! target: anObject target := anObject! ! !PluggableTabBarMorph class methodsFor: 'instance creation' stamp: 'KLC 2/2/2004 10:38'! on: anObject ^ super new target: anObject! ! !PluggableTabButtonMorph commentStamp: 'KLC 9/17/2004 11:27'! This is a specialized pluggable button morph that is meant to represent a tab in a set of tabs arranged horizontally. Each tab will overlap slightly when drawn. All but one tab will be drawn in left to right order in the specified color, but lighter. The active tab will be drawn last in the full color and slightly taller to indicate that it is selected. Clicking the active tab has no effect but clicking any other tab will change the active tab to the clicked tab. This morph does not itself accept any events. The parent tab set will grab the mouse clicks and handle notifying the appropriate tabs that they have been activated or deactivated. There is a single selector which provides the text for the button label and affects the width of the tab. When the width changes the tab will inform its parent that it has changed and that the layout needs to be updated. The model for the text selector of course should be the client for the tab set. The button label can be a String, Text, or Morph. Texts work better than plain Strings.! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 14:36'! arcLengths arcLengths ifNil: [ self calculateArcLengths ]. ^ arcLengths! ! !PluggableTabButtonMorph methodsFor: 'event' stamp: 'BenjaminVanRyseghem 1/9/2012 18:25'! keyStroke: event (self navigationKey: event) ifTrue: [^self]. super keyStroke: event! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! textSelector: aSymbol textSelector := aSymbol! ! !PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 1/23/2004 17:31'! stepTime ^ self subMorph stepTime ! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! textSelector ^ textSelector ! ! !PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 9/17/2004 11:24'! drawSubMorphOn: aCanvas | morphBounds | morphBounds := self bounds insetBy: (self cornerRadius + 3) @ (self topInactiveGap // 2 + 2). morphBounds := morphBounds translateBy: 0@(self topInactiveGap // 2 + 1). self active ifTrue: [ morphBounds := morphBounds translateBy: 0@((self topInactiveGap // 2 + 1) negated)]. self subMorph bounds height < (morphBounds height) ifTrue: [ morphBounds := morphBounds insetBy: 0@((morphBounds height - self subMorph bounds height) // 2)]. self subMorph bounds width < (morphBounds width) ifTrue: [ morphBounds := morphBounds insetBy: ((morphBounds width - self subMorph bounds width) // 2)@0]. self subMorph bounds: morphBounds. aCanvas drawMorph: self subMorph! ! !PluggableTabButtonMorph methodsFor: 'updating' stamp: 'KLC 1/23/2004 17:02'! update: aSelector self textSelector ifNotNil: [ aSelector = self textSelector ifTrue: [ | morph | (aSelector isSymbol and: [model notNil]) ifTrue: [ morph := (self model perform: aSelector) asMorph] ifFalse: [ morph := aSelector value asMorph]. self subMorph: morph]]. self changed! ! !PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 1/23/2004 15:49'! drawOn: aCanvas self drawTabOn: aCanvas. self drawSubMorphOn: aCanvas! ! !PluggableTabButtonMorph methodsFor: 'event' stamp: 'BenjaminVanRyseghem 1/9/2012 18:23'! handlesKeyboard: evt "Yes, we do it here." ^true! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 16:40'! subMorph: aMorph subMorph := aMorph ! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:25'! active active ifNil: [ active := false ]. ^ active! ! !PluggableTabButtonMorph methodsFor: 'event' stamp: 'BenjaminVanRyseghem 1/9/2012 18:04'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !PluggableTabButtonMorph methodsFor: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:31'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:26'! active: aBoolean active := aBoolean. self changed.! ! !PluggableTabButtonMorph methodsFor: 'precalculations' stamp: 'KLC 1/23/2004 14:46'! calculateArcLengths | array radius | radius := self cornerRadius. array := Array new: radius. 1 to: radius do: [ :i | | x | x := i - 0.5. array at: i put: (radius - ((2 * x * radius) - (x * x)) sqrt) asInteger]. self arcLengths: array! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 14:07'! outerGap "The horizontal distance of the outer left and right edges of the tab excluding the inner visible part" ^ self cornerRadius * 2! ! !PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 2/2/2004 10:15'! step self subMorph step. self changed. ! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! model ^ model ! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 16:40'! subMorph subMorph ifNil: [ self update: self textSelector ]. ^ subMorph! ! !PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 2/2/2004 15:07'! drawTabOn: aCanvas | top myColor cornerRadius myArcLengths myBounds | cornerRadius := self cornerRadius. myBounds := self bounds. self active ifTrue: [ top := myBounds top. myColor := self color ] ifFalse: [ top := myBounds top + self topInactiveGap. myColor := self color whiter whiter ]. aCanvas fillRectangle: ((myBounds left + cornerRadius) @ (top + cornerRadius) corner: (myBounds right - cornerRadius) @ self bottom) color: myColor. aCanvas fillRectangle: ((myBounds left + (cornerRadius * 2)) @ top corner: (myBounds right - (cornerRadius * 2)) @ (top + cornerRadius)) color: myColor. aCanvas fillOval: ((myBounds left + self cornerRadius) @ top corner: (myBounds left + (self cornerRadius * 3)) @ (top + (self cornerRadius * 2))) color: myColor. aCanvas fillOval: ((myBounds right - (self cornerRadius * 3)) @ top corner: (myBounds right - self cornerRadius) @ (top + (self cornerRadius * 2))) color: myColor. myArcLengths := self arcLengths. 1 to: myArcLengths size do: [ :i | | length | length := myArcLengths at: i. aCanvas line: (myBounds left + cornerRadius - i) @ (myBounds bottom - 1 ) to: (myBounds left + cornerRadius - i) @ (myBounds bottom - length - 1) color: myColor. aCanvas line: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - 1) to: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - length - 1) color: myColor] ! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 11:30'! topInactiveGap ^ 5! ! !PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 1/23/2004 17:31'! wantsSteps ^ self subMorph wantsSteps! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 11:30'! cornerRadius ^ 5 ! ! !PluggableTabButtonMorph methodsFor: 'actions' stamp: 'KLC 1/23/2004 15:38'! toggle self active: self active not! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 14:37'! arcLengths: anArrayOfIntegers arcLengths := anArrayOfIntegers ! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 14:05'! innerExtent: aPoint "Set the extent based on the primary visible part of the tab. In other words add twice the cornerRadius to this extent" self extent: (aPoint x + (self cornerRadius * 2)) @ (aPoint y)! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! model: anObject model := anObject! ! !PluggableTabButtonMorph class methodsFor: 'instance creation' stamp: 'KLC 1/22/2004 14:46'! on: anObject label: getTextSelector | instance | instance := super new. instance model: anObject. instance textSelector: getTextSelector. ^ instance ! ! !PluggableTextAttribute commentStamp: ''! An attribute which evaluates an arbitrary block when it is selected.! !PluggableTextAttribute methodsFor: 'accessing' stamp: 'ls 6/21/2001 18:06'! evalBlock: aBlock evalBlock := aBlock! ! !PluggableTextAttribute methodsFor: 'evaluating' stamp: 'SeanDeNigris 11/5/2013 14:20'! actOnClick: anEvent for: anObject in: paragraph editor: editor evalBlock ifNil: [ ^self ]. evalBlock numArgs = 0 ifTrue: [ evalBlock value. ^true ]. evalBlock numArgs = 1 ifTrue: [ evalBlock value: anObject. ^true ]. self error: 'evalBlock should have 0 or 1 arguments'! ! !PluggableTextAttribute class methodsFor: 'instance creation' stamp: 'ls 6/21/2001 18:09'! evalBlock: aBlock ^super new evalBlock: aBlock! ! !PluggableTextEditorMorph commentStamp: 'GaryChambers 4/24/2012 13:52'! Multi-line text editor with support for accepting on both each change and/or when keyboard focus changes. Also supports custom selection colour and clickable highlights. Used for plain text, no styling, no code menu etc. to see later uses: TEnableOnHaloMenu ! !PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: ''! enabledString "Answer the string to be shown in a menu to represent the 'enabled' status" ^ (self enabled) -> 'enabled' translated! ! !PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: ''! addToggleItemsToHaloMenu: aCustomMenu "Add toggle-items to the halo menu" super addToggleItemsToHaloMenu: aCustomMenu. aCustomMenu addUpdating: #enabledString target: self action: #toggleEnabled! ! !PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 12/21/2011 11:15'! textMorphClass "Answer the class used to create the receiver's textMorph" ^TextMorphForEditorView! ! !PluggableTextEditorMorph methodsFor: 'as yet unclassified' stamp: ''! toggleEnabled "Toggle the enabled state." self enabled: self enabled not! ! !PluggableTextEditorMorph class methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/20/2012 14:37'! stylingClass "No styling for plain text..." ^nil! ! !PluggableTextFieldMorph commentStamp: 'gvc 5/18/2007 12:39'! Single-line text field editor with DialogWindow key integration (return for default, escape for cancel) and keyboard focus navigation (tab/shift-tab). Additionally supports pluggable converters to translate between an object and its string form and vice-versa.! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/14/2009 11:29'! ghostText: aText "Set the value of helpText" ghostText := aText ifNotNil: [aText asString] ! ! !PluggableTextFieldMorph methodsFor: 'encryption' stamp: 'BenjaminVanRyseghem 1/25/2013 15:24'! beEncrypted self textMorph font: (StrikeFont passwordFontSize: self theme textFont pointSize).! ! !PluggableTextFieldMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/26/2010 18:09'! outOfWorld: aWorld self closeChooser. super outOfWorld: aWorld! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 12:21'! converter: anObject "Set the value of converter" converter := anObject! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 12:21'! converter "Answer the value of converter" ^ converter! ! !PluggableTextFieldMorph methodsFor: '*Polymorph-Widgets' stamp: 'GaryChambers 10/11/2011 13:58'! hasValidText "Return true if the text is valid with respect to the converter." |string| self converter ifNil: [^super hasValidText]. string := self text asString. ^(string isEmpty and: [self default notNil]) or: [ self converter isStringValid: string]! ! !PluggableTextFieldMorph methodsFor: 'Polymorph-Widgets-override' stamp: 'GaryChambers 3/8/2011 11:45'! acceptTextInModel "Inform the model that the receiver's textMorph's text should be accepted. Answer true if the model accepted ok, false otherwise" | objectToAccept text | self hasValidText ifFalse: [^false]. text := self text. objectToAccept := self converter ifNil: [text] ifNotNil: [self default ifNil: [self converter stringAsObject: text asString] ifNotNil: [text ifEmpty: [self default] ifNotEmpty: [self converter stringAsObject: text asString]]]. ^ setTextSelector isNil or: [setTextSelector numArgs = 2 ifTrue: [model perform: setTextSelector with: objectToAccept with: self] ifFalse: [model perform: setTextSelector with: objectToAccept]]! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:00'! maxLength "Answer the maximum number of characters that may be typed." ^self textMorph maxLength! ! !PluggableTextFieldMorph methodsFor: 'encryption' stamp: 'BenjaminVanRyseghem 10/25/2012 14:23'! encrypted: aBoolean aBoolean ifTrue: [ self beEncrypted ] ifFalse: [ self beDecrypted ]! ! !PluggableTextFieldMorph methodsFor: 'editor access' stamp: 'NicolaiHess 2/15/2014 01:01'! scrollSelectionIntoView: event "Scroll my text into view if necessary and return true, else return false. Redone here to deal with horizontal scrolling!!" | selRects delta selRect rectToTest transform cpHere | self selectionInterval: textMorph editor selectionInterval. selRects := textMorph paragraph selectionRects. selRects isEmpty ifTrue: [^ false]. rectToTest := selRects first merge: selRects last. transform := scroller transformFrom: self. (event notNil and: [event anyButtonPressed]) ifTrue: "Check for autoscroll" [cpHere := transform localPointToGlobal: event cursorPoint. cpHere x <= self left ifTrue: [rectToTest := selRects first topLeft extent: 2@2] ifFalse: [cpHere x >= self right ifTrue: [rectToTest := selRects last bottomRight extent: 2@2] ifFalse: [^ false]]]. selRect := transform localBoundsToGlobal: rectToTest. selRect width > bounds width ifTrue: [^ false]. "Would not fit, even if we tried to scroll" (delta := selRect amountToTranslateWithin: self innerBounds) ~= (0@0) ifTrue: ["Scroll end of selection into view if necessary" self scrollBy: delta truncated. ^ true]. ^ false! ! !PluggableTextFieldMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/4/2012 17:07'! textMorphClass "Answer the class used to create the receiver's textMorph" ^ textMorphClass! ! !PluggableTextFieldMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 11/26/2013 22:22'! initialize textMorphClass := TextMorphForFieldView. super initialize. self beDecrypted! ! !PluggableTextFieldMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/27/2010 23:29'! innerBounds | inb | inb := super innerBounds. endRow ifNotNil: [inb := inb withRight: (inb right - endRow fullBounds width)]. ^ inb! ! !PluggableTextFieldMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/24/2010 20:46'! mouseDownFromTextMorph: anEvent super mouseDownFromTextMorph: anEvent. entryCompletion ifNotNil: [entryCompletion mouseDownFromTextMorph: anEvent]! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/28/2010 09:09'! entryCompletion: anEntryCompletion entryCompletion := anEntryCompletion. entryCompletion ifNotNil: [ entryCompletion chooseBlock isNil ifTrue: [entryCompletion chooseBlock: [:v | self setText: v. self acceptTextInModel ]] ifFalse: [ | blk | blk := entryCompletion chooseBlock. entryCompletion chooseBlock: [:v | self setText: v. self acceptTextInModel. blk value: v]]]. ! ! !PluggableTextFieldMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/27/2010 22:31'! layoutChanged super layoutChanged. endRow ifNotNil: [ | deltaY | deltaY := (self height - endRow fullBounds height) // 2. endRow position: self boundsInWorld topRight - (endRow fullBounds width @ deltaY negated)]. ! ! !PluggableTextFieldMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/28/2010 10:07'! keystrokeFromTextMorph: anEvent anEvent keyCharacter = Character cr ifTrue: [self closeChooser]. ^ (super keystrokeFromTextMorph: anEvent) or: [entryCompletion notNil and: [entryCompletion keystroke: anEvent from: self]] ! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/23/2010 22:18'! closeChooser entryCompletion ifNotNil: [entryCompletion closeChooser]! ! !PluggableTextFieldMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/28/2010 09:08'! withDropListButton | downArrow downArrowBtn | endRow := AlignmentMorph newRow. downArrow := (self theme basicCreateArrowOfDirection: #bottom size: (textMorph textStyle defaultFont height) color: Color veryLightGray). downArrowBtn := IconicButton new labelGraphic: downArrow. downArrowBtn height: self innerBounds height. downArrowBtn borderWidth: 0. downArrowBtn color: Color transparent. downArrowBtn actionSelector: #openChooserWithAllOrCloseFrom:. downArrowBtn target: entryCompletion. downArrowBtn arguments: (Array with: self). endRow addMorph: downArrowBtn. self addMorph: endRow.! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 9/7/2013 13:08'! textMarginsWidth ^ self textMorph margins asMargin left ! ! !PluggableTextFieldMorph methodsFor: 'updating' stamp: 'gvc 6/21/2007 10:51'! update: aSymbol "Update the receiver based on the given aspect. Override to not accept an #appendText for a text field since if broadcast by a model it will append to ALL text fields/editors." aSymbol == #appendEntry ifTrue: [^self]. ^super update: aSymbol! ! !PluggableTextFieldMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 11/26/2013 23:07'! drawOn: aCanvas "Eventually draw the helpText" super drawOn: aCanvas. self ghostText ifNotEmpty: [ self text isEmpty ifTrue: [| ghostBounds | ghostBounds := ((self scroller submorphBounds topLeft corner: self innerBounds bottomRight) translateBy: 0 @ (self scroller height - self theme textFont height / 2) rounded) insetBy: self textMarginsWidth @ 0. aCanvas drawString: self ghostText in: ghostBounds font: self theme textFont color: Color lightGray]]. entryCompletion ifNotNil: [entryCompletion closeIfNotNeeded: self].! ! !PluggableTextFieldMorph methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 9/8/2013 17:59'! chooserHasFocus ^ entryCompletion notNil and: [entryCompletion chooser notNil and: [entryCompletion chooser hasKeyboardFocus]]! ! !PluggableTextFieldMorph methodsFor: 'model access' stamp: 'GaryChambers 4/18/2012 17:56'! getText "Retrieve the current model text. Set the converter to convert between the class of the returned object and string form." | newObj | getTextSelector isNil ifTrue: [^super getText]. newObj := model perform: getTextSelector. (newObj isNil and: [self converter isNil]) ifTrue: [^Text new]. self converter isNil ifTrue: [self convertTo: newObj class]. ^(self converter objectAsString: newObj) ifNil: [''] ifNotNil: [:s | s shallowCopy]! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/14/2009 11:29'! default: anObject default := anObject! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/14/2009 11:29'! ghostText "Answer the value of helpText" ^ ghostText ifNil: [ghostText := '']! ! !PluggableTextFieldMorph methodsFor: 'encryption' stamp: 'BenjaminVanRyseghem 1/25/2013 15:24'! beDecrypted self textMorph font: TextStyle defaultFont.! ! !PluggableTextFieldMorph methodsFor: 'model access' stamp: 'gvc 9/18/2006 14:06'! getSelection "Answer the model's selection interval. If not available keep the current selection." getSelectionSelector isNil ifFalse: [^super getSelection]. ^selectionInterval ifNil: [super getSelection]! ! !PluggableTextFieldMorph methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 4/23/2013 00:34'! accept self acceptBasic. acceptAction ifNotNil: [acceptAction value: textMorph contents asText].! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2010 19:01'! openChooser entryCompletion ifNotNil: [entryCompletion openChooserWith: textMorph text string from: self]! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/14/2009 11:29'! default ^ default! ! !PluggableTextFieldMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/29/2008 16:59'! handlesMouseWheel: evt "Do I want to receive mouseWheel events?." ^false! ! !PluggableTextFieldMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/25/2010 22:12'! focusChanged | outerMorph | (self hasFocus or: [self chooserHasFocus]) ifFalse: [self closeChooser]. super focusChanged ! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 14:59'! maxLength: anInteger "Set the maximum number of characters that may be typed." self textMorph maxLength: anInteger! ! !PluggableTextFieldMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/25/2010 18:34'! textChanged super textChanged. self openChooser! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 5/23/2007 13:04'! fillStyleToUse "Answer the fillStyle that should be used for the receiver." ^self enabled ifTrue: [self theme textFieldNormalFillStyleFor: self] ifFalse: [self theme textFieldDisabledFillStyleFor: self]! ! !PluggableTextFieldMorph methodsFor: '*Polymorph-Widgets' stamp: 'GuillermoPolito 5/23/2012 11:40'! keyboardFocusChange: aBoolean self closeChooser. super keyboardFocusChange: aBoolean. ! ! !PluggableTextFieldMorph methodsFor: 'model access' stamp: 'gvc 9/18/2006 12:22'! convertTo: aClass "Set the converter object class." self converter isNil ifTrue: [self converter: (ObjectStringConverter forClass: aClass)] ifFalse: [self converter objectClass: aClass]! ! !PluggableTextFieldMorph methodsFor: 'event handling' stamp: 'gvc 1/4/2007 15:36'! scrollByKeyboard: event "If event is ctrl+up/down then scroll and answer true. Just don't, really!!" ^false! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/23/2013 00:43'! hasUnacceptedEdits: aBoolean "Set the hasUnacceptedEdits flag to the given value. " aBoolean == hasUnacceptedEdits ifFalse: [hasUnacceptedEdits := aBoolean. self changed]. aBoolean ifFalse: [hasEditingConflicts := false]. self okToStyle ifTrue: [ self styler styleInBackgroundProcess: textMorph contents]! ! !PluggableTextFieldMorph methodsFor: 'styling' stamp: 'AlainPlantec 8/27/2011 16:03'! okToStyle ^ false! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 5/23/2007 13:08'! borderStyleToUse "Answer the borderStyle that should be used for the receiver." ^self enabled ifTrue: [self theme textFieldNormalBorderStyleFor: self] ifFalse: [self theme textFieldDisabledBorderStyleFor: self]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! methodNamesContainingIt self handleEdit: [textMorph editor methodNamesContainingIt]! ! !PluggableTextMorph methodsFor: '*NodeNavigation' stamp: 'GiselaDecuzzi 5/14/2013 15:38'! standOutPreviousSelection self handleEdit: [ NNavNavigation new navigate: textMorph editor direction: NNavDirectionPreviousSelection ]! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'SeanDeNigris 2/2/2013 09:45'! cursorEnd: aKeyboardEvent ^ textMorph editor cursorEnd: aKeyboardEvent.! ! !PluggableTextMorph methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:10'! replaceSelectionWith: aText ^ textMorph editor replaceSelectionWith: aText! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! tallyIt self handleEdit: [textMorph editor tallyIt]! ! !PluggableTextMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 8/26/2011 13:05'! classOrMetaClass: aBehavior "set the classOrMetaClass in the receiver's styler to aBehavior" self styler classOrMetaClass: aBehavior! ! !PluggableTextMorph methodsFor: 'private' stamp: 'AlainPlantec 11/8/2010 22:10'! hUnadjustedScrollRange "Return the width of the widest item in the list" textMorph ifNil: [ ^0 ]. textMorph isWrapped ifTrue:[ ^0 ]. ^super hUnadjustedScrollRange ! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'AlainPlantec 8/26/2011 13:05'! font: aFont textMorph beAllFont: aFont. self styler font: aFont! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'AlainPlantec 8/27/2011 14:32'! initialize "initialize the state of the receiver" super initialize. hasUnacceptedEdits := false. hasEditingConflicts := false. askBeforeDiscardingEdits := true. enabled := true. highlights := OrderedCollection new! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! browseIt self handleEdit: [textMorph editor browseIt]! ! !PluggableTextMorph methodsFor: '*Spec-MorphicAdapters' stamp: 'BenjaminVanRyseghem 10/1/2013 13:20'! registerScrollChanges: aSelector self announcer weak on: PaneScrolling send: aSelector to: self model! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'CamilloBruni 9/2/2011 13:12'! keystrokeFromTextMorph: anEvent self eventHandler ifNotNil: [^ self eventHandler keyStroke: anEvent fromMorph: self]. ^ false! ! !PluggableTextMorph methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:10'! bsText self changeText: (self text copyFrom: 1 to: (self text size - 1 max: 0))! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'MarianoMartinezPeck 9/5/2012 14:09'! setTextBasic: aText scrollBar setValue: 0.0. ((self textMorph contents size = 0) and: [self wrapFlag]) ifTrue: [ self textMorph contents: aText wrappedTo: self innerExtent x ] ifFalse: [ self textMorph newContents: aText]. self hasUnacceptedEdits: false. self setScrollDeltas.! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 1/2/2011 10:33'! nextTokenFrom: start direction: dir ^ textMorph nextTokenFrom: start direction: dir! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:48'! textExtent "Answer the text morph extent." ^(textMorph ifNil: [^0@0]) extent! ! !PluggableTextMorph methodsFor: 'styling' stamp: 'BenjaminVanRyseghem 1/10/2014 12:13'! basicHasUnacceptedEdits: aBoolean "Set the hasUnacceptedEdits flag to the given value. " Smalltalk tools userManager canEditCode ifFalse: [ aBoolean ifTrue: [ ^ self ]]. aBoolean == hasUnacceptedEdits ifFalse: [hasUnacceptedEdits := aBoolean. self changed]. aBoolean ifFalse: [hasEditingConflicts := false]. self okToStyle ifTrue: [ self styler styleInBackgroundProcess: textMorph contents]! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 11/8/2010 22:10'! notify: aString at: anInteger in: aStream ^ textMorph editor notify: aString at: anInteger in: aStream! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'SeanDeNigris 2/5/2013 14:55'! cut self handleEdit: [textMorph editor cut]. self autoAccept ifTrue: [ self accept ].! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'CamilloBruni 2/4/2012 14:48'! yellowButtonActivity "Called when the shifted-menu's 'more' item is chosen" ^ self yellowButtonActivity: false! ! !PluggableTextMorph methodsFor: 'drawing' stamp: 'AlainPlantec 2/21/2011 18:52'! drawOn: aCanvas "Indicate unaccepted edits, conflicts etc." super drawOn: aCanvas. self wantsFrameAdornments ifTrue: [ self theme drawTextAdornmentsFor: self on: aCanvas]. self drawHighlightsOn: aCanvas! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:58'! acceptBasic "should be refactored with accept that comes from PluugableTextMorphPlus " "Inform the model of text to be accepted, and return true if OK." | ok saveSelection saveScrollerOffset | saveSelection := self selectionInterval copy. saveScrollerOffset := scroller offset copy. (self canDiscardEdits and: [self alwaysAccept not]) ifTrue: [^ self flash]. self hasEditingConflicts ifTrue: [(self confirm: 'Caution!! This method may have been changed elsewhere since you started editing it here. Accept anyway?' translated) ifFalse: [^ self flash]]. ok := self acceptTextInModel. ok==true ifTrue: [self setText: self getText. self hasUnacceptedEdits: false]. ["During the step for the browser, updateCodePaneIfNeeded is called, and invariably resets the contents of the codeholding PluggableTextMorph at that time, resetting the cursor position and scroller in the process. The following line forces that update without waiting for the step, then restores the cursor and scrollbar" ok ifTrue: "(don't bother if there was an error during compile)" [(model respondsTo: #updateCodePaneIfNeeded) ifTrue: [model updateCodePaneIfNeeded]. scroller offset: saveScrollerOffset. self setScrollDeltas. self selectFrom: saveSelection first to: saveSelection last]] on: Error do: [] ! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/8/2010 22:10'! focusBounds "Answer the bounds for drawing the focus indication (when externalFocusForPluggableText is enabled)." ^self theme textFocusBoundsFor: self! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:23'! disable "Disable the receiver." self enabled: false! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/8/2010 22:10'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'NicolaiHess 2/15/2014 00:01'! on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel setSelection: setSelectionSel self model: anObject. getTextSelector := getTextSel. setTextSelector := setTextSel. getSelectionSelector := getSelectionSel. setSelectionSelector := setSelectionSel. getMenuSelector := getMenuSel. self borderWidth: 1. self setText: self getText. self setSelection: self getSelection.! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 5/16/2013 13:06'! handlesDoubleClick ^ doubleClickSelector notNil! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'MarcusDenker 4/14/2011 10:55'! exploreIt self handleEdit: [textMorph editor evaluateSelectionAndDo: [:result | result explore]].! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'AlainPlantec 2/21/2011 18:24'! drawHighlightsOn: aCanvas "Draw the highlights." |b o| b := self innerBounds. o := self scroller offset. aCanvas clipBy: self clippingBounds during: [:c | self highlights do: [:h | h drawOn: c in: b offset: o]]! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'AlainPlantec 11/8/2010 22:10'! setTextMorphToSelectAllOnMouseEnter "Tell my textMorph's editor to select all when the mouse enters" textMorph on: #mouseEnter send: #selectAll to: textMorph! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/8/2010 22:10'! mouseEnter: event "Changed to take keyboardFocusOnMouseDown into account." super mouseEnter: event. self textMorph ifNil: [^self]. selectionInterval ifNotNil: [self textMorph editor selectInterval: selectionInterval; setEmphasisHere]. self textMorph selectionChanged. self wantsKeyboardFocus ifFalse: [^self]. self keyboardFocusOnMouseDown ifFalse: [self textMorph takeKeyboardFocus]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:10'! getColorSelector: aSymbol getColorSelector := aSymbol. self update: getColorSelector.! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 9/26/2011 03:42'! navigationKey: event "Check for tab key activity and change focus as appropriate. Must override here rather than in #tabKey: otherwise the tab will get passed to the window and change the focus." (event keyCharacter = Character tab and: [ (event anyModifierKeyPressed or: [event shiftPressed]) not]) ifTrue: [^false]. ^super navigationKey: event! ! !PluggableTextMorph methodsFor: 'menu messages' stamp: 'StephaneDucasse 5/13/2012 21:26'! methodCaseSensitiveStringsContainingit self handleEdit: [textMorph editor methodCaseSensitiveStringsContainingit]! ! !PluggableTextMorph methodsFor: 'drawing' stamp: 'AlainPlantec 11/8/2010 22:10'! wantsFrameAdornments: aBoolean self setProperty: #wantsFrameAdornments toValue: aBoolean! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:20'! fillStyleToUse "Answer the fillStyle that should be used for the receiver." ^self enabled ifTrue: [self theme textEditorNormalFillStyleFor: self] ifFalse: [self theme textEditorDisabledFillStyleFor: self]! ! !PluggableTextMorph methodsFor: 'dependents access' stamp: 'ClementBera 9/30/2013 11:05'! canDiscardEdits "Return true if this view either has no text changes or does not care." ^ (hasUnacceptedEdits and: [askBeforeDiscardingEdits]) not ! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! printerSetup self handleEdit: [textMorph editor printerSetup]! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'GuillermoPolito 5/23/2012 11:40'! keyboardFocusChange: aBoolean "Pass on to text morph." super keyboardFocusChange: aBoolean. aBoolean ifTrue: [self textMorph takeKeyboardFocus]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/18/2013 12:23'! setSelectionSelector: aSelector setSelectionSelector := aSelector ! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/11/2011 04:28'! changedAction: aBlock changedAction := aBlock! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! chooseAlignment self handleEdit: [textMorph editor changeAlignment]! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:32'! getEnabledSelector: anObject "Set the value of getEnabledSelector" getEnabledSelector := anObject. self updateEnabled! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! implementorsOfIt self handleEdit: [textMorph editor implementorsOfIt]! ! !PluggableTextMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 10/19/2011 13:29'! styler: aStyler "Set the styler responsible for highlighting text in the receiver" styler := aStyler! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! changeStyle self handleEdit: [textMorph editor changeStyle]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:16'! acceptOnFocusChange "Answer whether the editor accepts its contents when it loses the keyboard focus." ^acceptOnFocusChange ifNil: [false]! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'CamilloBruni 2/19/2014 18:20'! handleEdit: editBlock | result | textMorph editor selectFrom: selectionInterval first to: selectionInterval last; model: model. "For, eg, evaluateSelection" textMorph handleEdit: [result := editBlock value]. "Update selection after edit" self scrollSelectionIntoView. self textChanged. ^ result! ! !PluggableTextMorph methodsFor: 'styling' stamp: 'BenjaminVanRyseghem 1/10/2014 12:19'! hasUnacceptedEdits: aBoolean "Set the hasUnacceptedEdits flag to the given value. " (model respondsTo: #hasUnacceptedEdits:) ifTrue: [ model hasUnacceptedEdits: aBoolean ] ifFalse: [ self basicHasUnacceptedEdits: aBoolean ]! ! !PluggableTextMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/8/2010 22:10'! extraScrollRange ^ self height // 4! ! !PluggableTextMorph methodsFor: '*Shout' stamp: ''! stylerStyled: styledCopyOfText textMorph contents runs: styledCopyOfText runs. textMorph updateFromParagraph. selectionInterval ifNotNil: [textMorph editor selectInvisiblyFrom: selectionInterval first to: selectionInterval last; storeSelectionInParagraph; setEmphasisHere]. textMorph editor blinkParen. self scrollSelectionIntoView! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! copySelection self handleEdit: [textMorph editor copySelection]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/28/2010 10:02'! crAction: anAction self textMorph crAction: anAction! ! !PluggableTextMorph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 11/8/2010 22:10'! wantsDroppedMorph: aMorph event: anEvent ^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:10'! acceptAction ^acceptAction! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/24/2010 21:03'! mouseDownFromTextMorph: anEvent "Nothing to do here normally"! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/8/2010 22:10'! minWidth "Implemented here since extent: overriden." ^super minWidth max: 36! ! !PluggableTextMorph methodsFor: 'layout' stamp: 'AlainPlantec 11/8/2010 22:10'! acceptDroppingMorph: aMorph event: evt "This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. The default implementation just adds the given morph to the receiver." "Here we let the model do its work." self model acceptDroppingMorph: aMorph event: evt inMorph: self. ! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:10'! getTextSelector ^getTextSelector! ! !PluggableTextMorph methodsFor: 'private' stamp: 'AlainPlantec 2/21/2011 18:50'! vScrollBarValue: scrollValue super vScrollBarValue: scrollValue. textMorph ifNotNil: [textMorph selectionChanged]. self triggerEvent: #vScroll with: scrollValue! ! !PluggableTextMorph methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/16/2013 14:06'! startDrag: event | aTransferMorph itemMorph passenger | self dragEnabled ifFalse: [ ^ self ]. itemMorph := self selectedContents asMorph. passenger := self model dragPassengerFor: itemMorph inMorph: self. passenger ifNotNil: [ aTransferMorph := self model transferFor: passenger from: self. "Ask the draggedMorph otherwise the transferMorph has not yet its bounds" aTransferMorph align: aTransferMorph draggedMorph center with: event position. aTransferMorph dragTransferType: (self model dragTransferTypeForMorph: self). event hand grabMorph: aTransferMorph]. event hand releaseMouseFocus: self! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'SeanDeNigris 2/5/2013 14:56'! pasteRecent "Paste an item chosen from RecentClippings." | clipping | (clipping := Clipboard chooseRecentClipping) ifNil: [^ self]. Clipboard clipboardText: clipping. self paste.! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:12'! autoAccept: aBoolean "Answer whether the editor accepts its contents on each change." autoAccept := aBoolean. self textMorph ifNotNil: [:t | t autoAccept: aBoolean]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! prettyPrint self handleEdit: [textMorph editor prettyPrint]! ! !PluggableTextMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 8/27/2011 14:37'! styler "The styler responsible for highlighting text in the receiver" ^ styler ifNil: [styler := self defaultStyler]! ! !PluggableTextMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 9/19/2011 19:34'! styled: aBoolean self styler stylingEnabled: aBoolean ! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'SeanDeNigris 2/2/2013 09:45'! cursorHome: aKeyboardEvent ^ textMorph editor cursorHome: aKeyboardEvent.! ! !PluggableTextMorph methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:10'! changeText: aText "The paragraph to be edited is changed to aText." self setText: aText! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'EstebanLorenzano 8/1/2012 11:20'! textMorph: aTextMorph textMorph ifNotNil: [ scrollBar removeMorph: textMorph ]. textMorph := aTextMorph. self configureTextMorph: textMorph.! ! !PluggableTextMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/5/2012 21:09'! scrollBy: delta "Move the contents in the direction delta." super scrollBy: delta. self triggerEvent: #hScroll with: self scrollValue x. self triggerEvent: #vScroll with: self scrollValue y ! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 11/22/2012 17:54'! addHighlightFrom: start to: end color: col self highlights add: ( (TextHighlight on: self) color: col; lineRange: (start to: end))! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/8/2010 22:10'! onKeyStrokeSend: sel to: recipient textMorph on: #keyStroke send: sel to: recipient.! ! !PluggableTextMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 9/19/2011 19:39'! defaultStyler ^ self stylerClass new view: self! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'SeanDeNigris 2/5/2013 14:45'! paste self handleEdit: [textMorph editor paste]. self autoAccept ifTrue: [ self accept ].! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 11/8/2010 22:10'! wantsFrameAdornments "Answer whether the receiver wishes to have red borders, etc., used to show editing state" "A 'long-term temporary workaround': a nonmodular, unsavory, but expedient way to get the desired effect, sorry. Clean up someday." ^ self valueOfProperty: #wantsFrameAdornments ifAbsent: [self showTextEditingState ifTrue: [(#(searchString infoViewContents ) includes: getTextSelector) not] ifFalse: [false]]! ! !PluggableTextMorph methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:10'! appendEntry "Append the text in the model's writeStream to the editable text. " textMorph asText size > model characterLimit ifTrue: ["Knock off first half of text" self selectInvisiblyFrom: 1 to: textMorph asText size // 2. self replaceSelectionWith: Text new]. self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size. self replaceSelectionWith: model contents asText. self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! offerFontMenu self handleEdit: [textMorph editor changeTextFont]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'BenjaminVanRyseghem 5/4/2013 12:55'! doIt Smalltalk tools userManager canEvaluateCode ifFalse: [ ^ false ]. self handleEdit: [textMorph editor evaluateSelection]! ! !PluggableTextMorph methodsFor: 'styling' stamp: 'AlainPlantec 11/8/2010 22:10'! hasEditingConflicts "Return true if a conflicting edit to the same code (typically) is known to have occurred after the current contents started getting edited" ^ hasEditingConflicts == true! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:34'! scrollToTop "Scroll to the top." self vScrollBarValue: 0; setScrollDeltas! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 11/8/2010 22:10'! select ^ textMorph editor select! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'StephaneDucasse 2/11/2014 10:56'! cancelWithoutConfirmation self setText: self getText. self setSelection: self getSelection. ! ! !PluggableTextMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/5/2012 21:09'! hScrollBarValue: scrollValue super hScrollBarValue: scrollValue. textMorph ifNotNil: [textMorph selectionChanged]. self triggerEvent: #hScroll with: scrollValue! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/8/2010 22:10'! hasKeyboardFocus "Answer whether the receiver has keyboard focus." ^super hasKeyboardFocus or: [(self textMorph ifNil: [^false]) hasKeyboardFocus]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! fileItIn self handleEdit: [textMorph editor fileItIn]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:29'! enabled "Answer whether the receiver is enabled." ^enabled ifNil: [true]! ! !PluggableTextMorph methodsFor: '*NodeNavigation' stamp: 'GiselaDecuzzi 5/13/2013 17:56'! standOutOverScope self handleEdit: [NNavNavigation new navigate: textMorph editor direction: NNavDirectionParent] ! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'AlainPlantec 11/11/2010 11:10'! scrollSelectionIntoView "Scroll my text into view if necessary and return true, else return false" ^ self scrollSelectionIntoView: nil! ! !PluggableTextMorph methodsFor: 'geometry' stamp: 'MarcusDenker 10/1/2013 21:25'! resetExtent "Reset the extent while maintaining the current selection. Needed when resizing while the editor is active (when inside the pane)." | tempSelection | textMorph notNil ifTrue: ["the current selection gets munged by resetting the extent, so store it" tempSelection := self selectionInterval. super resetExtent. "adjust scroller" self extent: self extent. self setSelection: tempSelection]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/11/2011 04:28'! changedAction ^ changedAction! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'GaryChambers 3/8/2011 12:00'! hasValidText "Return true if the text is valid for acceptance." ^true! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'kilonalios 10/13/2013 13:58'! cancel (self confirm: 'This action will cancel your changes. Is it OK to cancel changes?' translated) ifTrue: [self setText: self getText. self setSelection: self getSelection.]! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'NicolaiHess 2/15/2014 01:01'! setSelection: sel self selectionInterval: sel. textMorph editor selectFrom: sel first to: sel last. self scrollSelectionIntoView ifFalse: [scroller changed].! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 9/13/2011 13:59'! keyStroke: evt "A keystroke was hit while the receiver had keyboard focus. Pass the keywtroke on to my textMorph, and and also, if I have an event handler, pass it on to that handler" self eventHandler ifNotNil: [self eventHandler keyStroke: evt fromMorph: self]. ! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'NicolaiHess 2/15/2014 00:59'! scrollSelectionIntoView: event "Scroll my text into view if necessary and return true, else return false" | selRects delta selRect rectToTest transform cpHere editor | editor := textMorph editor. self selectionInterval: editor selectionInterval. selRects := textMorph paragraph selectionRects. selRects isEmpty ifTrue: [^ false]. rectToTest := selRects first merge: selRects last. transform := scroller transformFrom: self. (event notNil and: [event anyButtonPressed]) ifTrue: "Check for autoscroll" [cpHere := transform localPointToGlobal: event cursorPoint. cpHere y <= self top ifTrue: [rectToTest := selRects first topLeft extent: 2@2] ifFalse: [cpHere y >= self bottom ifTrue: [rectToTest := selRects last bottomRight extent: 2@2] ifFalse: [^ false]]]. selRect := transform localBoundsToGlobal: rectToTest. selRect height > bounds height ifTrue: [(editor pointIndex - editor markIndex) < 0 ifTrue: [self scrollBy: 0@(self innerBounds top - selRect top)] ifFalse: [self scrollBy: 0@(self innerBounds bottom - selRect bottom)]. ^ true]. (delta := selRect amountToTranslateWithin: self innerBounds) y ~= 0 ifTrue: ["Scroll end of selection into view if necessary" self scrollBy: 0@delta y. ^ true]. ^ false ! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'LucFabresse 10/20/2013 00:52'! toggleCommentOnSelectionOrLine "Tell my textMorph's editor to comment or uncomment current selection or line if no there is no selection" textMorph editor toggleCommentOnSelectionOrLine ! ! !PluggableTextMorph methodsFor: 'styling' stamp: 'AlainPlantec 11/8/2010 22:10'! askBeforeDiscardingEdits: aBoolean "Set the flag that determines whether the user should be asked before discarding unaccepted edits." askBeforeDiscardingEdits := aBoolean! ! !PluggableTextMorph methodsFor: '*NodeNavigation' stamp: 'GiselaDecuzzi 5/13/2013 18:03'! standOutPreviousChild self handleEdit: [ NNavNavigation new navigate: textMorph editor direction: NNavDirectionPreviousBrother ]! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:29'! enable "Enable the receiver." self enabled: true! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 11/8/2010 22:10'! selectInvisiblyFrom: start to: stop ^ textMorph editor selectInvisiblyFrom: start to: stop! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 8/5/2012 22:40'! layoutBounds: aRectangle "Set the bounds for laying out children of the receiver. Note: written so that #layoutBounds can be changed without touching this method" super layoutBounds: aRectangle. textMorph ifNotNil: [textMorph extent: (self innerExtent x)@self height]. self setScrollDeltas ! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'MarianoMartinezPeck 9/5/2012 14:08'! wrapFlag "Answer the wrap flag on the text morph." ^self textMorph wrapFlag! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! findAgain self handleEdit: [textMorph editor findAgain]! ! !PluggableTextMorph methodsFor: 'styling' stamp: 'AlainPlantec 11/8/2010 22:10'! promptForCancel "Ask for the appropriate action to take when unaccepted contents would be overwritten." | choice | choice := ( UIManager default confirm: 'Code has been modified.\What do you want to do?' translated withCRs trueChoice: 'Accept' translated falseChoice: 'Discard' translated cancelChoice: 'Cancel' translated default: nil ). choice ifNotNil: [ choice ifTrue: [ self accept ] ifFalse: [ self model clearUserEditFlag ]]! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'NicolaiHess 2/15/2014 00:01'! on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel self on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel setSelection: nil. ! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! sendersOfIt self handleEdit: [textMorph editor sendersOfIt]! ! !PluggableTextMorph methodsFor: 'geometry' stamp: 'BenjaminVanRyseghem 8/5/2012 22:39'! innerExtent ^ self innerBounds extent - 6! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:13'! autoAccept "Answer whether the editor accepts its contents on each change." ^autoAccept ifNil: [false]! ! !PluggableTextMorph methodsFor: 'updating' stamp: 'AlainPlantec 11/8/2010 22:10'! scrollBarMenuButtonPressed: event "The menu button in the scrollbar was pressed; put up the menu" | menu | (menu := self getMenu: event shiftPressed) ifNotNil: ["Set up to use perform:orSendTo: for model/view dispatch" menu setInvokingView: self. menu invokeModal]! ! !PluggableTextMorph methodsFor: '*Shout' stamp: ''! stylerStyledInBackground: styledCopyOfText textMorph contents string = styledCopyOfText string ifTrue: [self stylerStyled: styledCopyOfText]! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 11/8/2010 22:10'! correctFrom: start to: stop with: aString unstyledAcceptText ifNotNil: [unstyledAcceptText replaceFrom: start to: stop with: aString ]. ^ self handleEdit: [textMorph editor correctFrom: start to: stop with: aString]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! acceptTextInModelBasic "Inform the model that the receiver's textMorph's text should be accepted. Answer true if the model accepted ok, false otherwise" | textToAccept | textToAccept := textMorph asText. ^setTextSelector isNil or: [setTextSelector numArgs = 2 ifTrue: [model perform: setTextSelector with: textToAccept with: self] ifFalse: [model perform: setTextSelector with: textToAccept]] ! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/8/2010 22:10'! handlesKeyboard: evt ^true! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! methodSourceContainingIt self handleEdit: [textMorph editor methodSourceContainingIt]! ! !PluggableTextMorph methodsFor: '*NodeNavigation' stamp: 'GiselaDecuzzi 5/13/2013 17:56'! standOutIntoScope self handleEdit: [NNavNavigation new navigate: textMorph editor direction: NNavDirectionChild]! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:34'! updateEnabled "Update the enablement state." self model ifNotNil: [ self getEnabledSelector ifNotNil: [ self enabled: (self model perform: self getEnabledSelector)]]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'MarcusDenker 12/2/2013 14:08'! yellowButtonActivity: shiftKeyState "Called when the shifted-menu's 'more' item is chosen" (self getMenu: shiftKeyState) ifNotNil: [ :menu| menu setInvokingView: self. menu invokeModal. ^ true]. ^ false! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! again self handleEdit: [textMorph editor again]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! setSearchString self handleEdit: [textMorph editor setSearchString]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:39'! selectionColor: aColor "Set the colour to use for the text selection." selectionColor := aColor. self textMorph ifNotNil: [:t | t selectionColor: aColor]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! methodStringsContainingit self handleEdit: [textMorph editor methodStringsContainingit]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'nice 3/31/2011 22:43'! inspectIt self handleEdit: [textMorph editor evaluateSelectionAndDo: [:result | result inspect]]! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:49'! textExtent: newExtent "If autoFit is on then override to false for the duration of the extent call." textMorph ifNil: [^self]. textMorph overrideExtent: newExtent! ! !PluggableTextMorph methodsFor: 'scrolling' stamp: 'FernandoOlivero 5/30/2011 09:26'! scrollToBottom "Scroll to the bottom." self vScrollBarValue: self vTotalScrollRange; setScrollDeltas! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/8/2010 22:10'! wantsKeyboardFocus "Answer whether the receiver would like keyboard focus in the general case (mouse action normally). Even if disabled we allow for text morphs since can potentially copy text." ^self takesKeyboardFocus and: [ self visible and: [ self enabled or: [self valueOfProperty: #wantsKeyboardFocusWhenDisabled ifAbsent: [true]]]] ! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 5/4/2013 12:55'! accept Smalltalk tools userManager canEditCode ifFalse: [ ^ self hasUnacceptedEdits: false ]. self acceptBasic. acceptAction ifNotNil: [acceptAction value: textMorph contents asText].! ! !PluggableTextMorph methodsFor: 'scroll bar events' stamp: 'AlainPlantec 11/8/2010 22:10'! showTextEditingState ^ self class showTextEditingState! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'SeanDeNigris 2/5/2013 14:56'! undo self handleEdit: [textMorph editor undo]. self autoAccept ifTrue: [ self accept ].! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! debugIt self handleEdit: [textMorph editor debugIt]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:15'! acceptOnFocusChange: aBoolean "Set whether the editor accepts its contents when it loses the keyboard focus." acceptOnFocusChange := aBoolean. self textMorph ifNotNil: [:t | t acceptOnFocusChange: aBoolean]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 9/19/2011 19:39'! stylerClass ^ self class stylingClass ifNil: [NullTextStyler]! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'FernandoOlivero 5/30/2011 09:47'! selectedContents ^ textMorph editor selection! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/8/2010 22:10'! appendText: aTextOrString "Append the given text to the receiver." self handleEdit: [ self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size; replaceSelectionWith: aTextOrString; selectFrom: textMorph asText size + 1 to: textMorph asText size; hasUnacceptedEdits: false; scrollSelectionIntoView; changed]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'GaryChambers 4/24/2012 15:10'! font "Answer the probable font" ^self textMorph ifNil: [TextStyle defaultFont] ifNotNil: [:m | m font]! ! !PluggableTextMorph methodsFor: 'dependents access' stamp: 'AlainPlantec 11/8/2010 22:10'! hasUnacceptedEdits "Return true if this view has unaccepted edits." ^ hasUnacceptedEdits! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:33'! highlights: aCollectionOfHighlight "Set the value of highlights" highlights := aCollectionOfHighlight! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'FernandoOlivero 5/10/2011 06:51'! model: aModel "Update the enablement state too." super model: aModel. self updateEnabled! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'NicolaiHess 2/15/2014 00:59'! selectAll "Tell my textMorph's editor to select all" self textMorph editor selectAll. self selectionInterval: self textMorph editor selectionInterval! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'SvenVanCaekenberghe 12/12/2012 09:49'! printIt | oldEditor printString | textMorph editor selectFrom: selectionInterval first to: selectionInterval last; model: model. "For, eg, evaluateSelection" textMorph handleEdit: [ (oldEditor := textMorph editor) evaluateSelectionAndDo: [ :result | printString := [ result printString ] on: Error do: [ '' ]. selectionInterval := oldEditor selectionInterval. textMorph installEditorToReplace: oldEditor. textMorph handleEdit: [ oldEditor afterSelectionInsertAndSelect: printString ]. selectionInterval := oldEditor selectionInterval. textMorph editor selectFrom: selectionInterval first to: selectionInterval last. self scrollSelectionIntoView ] ]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! referencesToIt self handleEdit: [textMorph editor referencesToIt]! ! !PluggableTextMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/8/2010 22:10'! scrollDeltaHeight "Return the increment in pixels which this pane should be scrolled." ^ scroller firstSubmorph defaultLineHeight ! ! !PluggableTextMorph methodsFor: 'formatting' stamp: 'GuillermoPolito 11/7/2013 13:22'! formatSourceCode self handleEdit: [ | source tree formatted | source := self textMorph text asString. tree := RBParser parseMethod: source onError: [ :msg :pos | ^ self ]. formatted := tree formattedCode. formatted = source ifTrue: [ ^ self ]. self editString: formatted; hasUnacceptedEdits: true ]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! classNamesContainingIt self handleEdit: [textMorph editor classNamesContainingIt]! ! !PluggableTextMorph methodsFor: '*NodeNavigation' stamp: 'GiselaDecuzzi 5/13/2013 18:04'! standOutIntoFirstScope self handleEdit: [NNavNavigation new navigate: textMorph editor direction: NNavDirectionFirstChild ]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:57'! alwaysAccept ^ alwaysAccept ifNil: [false]! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 2/21/2011 18:21'! adoptPaneColor: paneColor "Pass on to the border too." super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self borderStyle baseColor: (self enabled ifTrue: [paneColor twiceDarker] ifFalse: [paneColor darker]). self fillStyle: self fillStyleToUse. self borderWidth > 0 ifTrue: [self borderStyle: self borderStyleToUse]! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/22/2011 17:20'! highlights "Answer the value of highlights" ^ highlights ifNil: [#()]! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'AlainPlantec 11/8/2010 22:10'! textColor: aColor "Set the color of my text to the given color" textMorph textColor: aColor! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'NicolaiHess 2/15/2014 01:01'! selectFrom: start to: stop self textMorph editor selectFrom: start to: stop. self selectionInterval: self textMorph editor selectionInterval. ^ self selectionInterval! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:10'! getColorSelector ^getColorSelector! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/8/2010 22:10'! editString: aString "Jam some text in. This is treated as clean text by default." self setText: aString asText! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/4/2012 14:14'! alwaysAccept: aBoolean "Set the always accept flag." "This flag is used when there are unsaved changes in my text field and an exterior actor tries to modify me" "If the flag is true, I will accept to change even if I have pending modification instead of poping up the Accept/Discard/Cancel window" alwaysAccept := aBoolean ! ! !PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'AlainPlantec 11/8/2010 22:15'! textMorphClass "Answer the class used to create the receiver's textMorph" ^TextMorphForEditView ! ! !PluggableTextMorph methodsFor: 'styling' stamp: 'BenjaminVanRyseghem 6/19/2012 21:08'! hasEditingConflicts: aBoolean hasEditingConflicts := aBoolean. self changed! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 8/26/2011 10:49'! acceptTextInModel "#correctFrom:to:with: is sent when the method source is manipulated during compilation (removing unused temps, changing selectors etc). But #correctFrom:to:with: operates on the textMorph's text, and we may be saving an unstyled copy of the text. This means that these corrections will be lost unless we also apply the corrections to the unstyled copy that we are saving. So remember the unstyled copy in unstyledAcceptText, so that when #correctFrom:to:with: is received we can also apply the correction to it" | acceptedText | acceptedText := self styler unstyledTextFrom: textMorph asText. [^setTextSelector isNil or: [setTextSelector numArgs = 2 ifTrue: [model perform: setTextSelector with: acceptedText with: self] ifFalse: [model perform: setTextSelector with: acceptedText]] ] ensure: [unstyledAcceptText := nil]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'BenjaminVanRyseghem 2/8/2013 23:52'! redo self handleEdit: [ textMorph editor redo ]. self autoAccept ifTrue: [ self accept ].! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 11/8/2010 22:10'! correctSelectionWithString: aString | result newPosition | "I can't tell if this is a hack or if it's the right thing to do." self setSelection: selectionInterval. result := self correctFrom: selectionInterval first to: selectionInterval last with: aString. newPosition := selectionInterval first + aString size. self setSelection: (newPosition to: newPosition - 1). ^ result! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:38'! selectionColor "Answer the color to use for the text selection." ^ selectionColor ! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'AlainPlantec 11/8/2010 22:10'! text ^ textMorph contents! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:30'! enabled: aBoolean "Set the value of enabled" enabled = aBoolean ifTrue: [^self]. enabled := aBoolean. self changed: #enabled. self adoptPaneColor: self paneColor; changed! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/8/2010 22:10'! acceptOnCR: trueOrFalse textMorph acceptOnCR: trueOrFalse! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:51'! wrapFlag: aBoolean self textMorph ifNil: [self setText: '']. textMorph wrapFlag: aBoolean! ! !PluggableTextMorph methodsFor: '*NodeNavigation' stamp: 'GiselaDecuzzi 5/13/2013 17:57'! standOutHorizontalScope self handleEdit: [NNavNavigation new navigate: textMorph editor direction: NNavDirectionSibling ] ! ! !PluggableTextMorph methodsFor: 'geometry' stamp: 'BenjaminVanRyseghem 8/5/2012 22:39'! extent: newExtent "The inner bounds may have changed due to scrollbar visibility." super extent: (newExtent max: 36 @ 16). textMorph ifNotNil: [ self innerExtent = textMorph extent ifFalse: [ textMorph extent: self innerExtent ] ]. self setScrollDeltas. (self fillStyle notNil and: [ self fillStyle isSolidFill not ]) ifTrue: [ self fillStyle: self fillStyleToUse ]! ! !PluggableTextMorph methodsFor: 'transcript' stamp: 'BenjaminVanRyseghem 6/19/2012 21:08'! update: aSymbol aSymbol ifNil: [^self]. (aSymbol == getColorSelector) ifTrue: [^ self color: (model perform: getColorSelector)]. aSymbol == #flash ifTrue: [^self flash]. aSymbol == getTextSelector ifTrue: [self setText: self getText. ^self setSelection: self getSelection]. aSymbol == getSelectionSelector ifTrue: [^self setSelection: self getSelection]. (aSymbol == #autoSelect and: [getSelectionSelector notNil]) ifTrue: [self handleEdit: [(textMorph editor) setSelectorSearch: model autoSelectString. textMorph editor findAgain]]. aSymbol == #clearUserEdits ifTrue: [^self hasUnacceptedEdits: false]. aSymbol == #wantToChange ifTrue: [self canDiscardEdits ifFalse: [^self promptForCancel]. ^self]. aSymbol == #appendEntry ifTrue: [self handleEdit: [self appendEntry]. ^self ]. aSymbol == #clearText ifTrue: [self handleEdit: [self changeText: Text new]. ^self ]. aSymbol == #bs ifTrue: [self handleEdit: [self bsText]. ^self ]. aSymbol == #codeChangedElsewhere ifTrue: [self hasEditingConflicts: true. ^self]. aSymbol == self getEnabledSelector ifTrue: [self updateEnabled]. ^ self! ! !PluggableTextMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 8/26/2011 17:18'! shoutEnabled ^ self class shoutEnabled! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'BenjaminVanRyseghem 8/3/2012 17:52'! getText "Retrieve the current model text" | newText | getTextSelector ifNil: [^Text new]. newText := model perform: getTextSelector withEnoughArguments: {self}. newText ifNil: [^Text new]. ^newText shallowCopy! ! !PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'EstebanLorenzano 8/1/2012 11:17'! configureTextMorph: aTextMorph "I prepare a text morph for use" aTextMorph setEditView: self. scroller addMorph: aTextMorph. aTextMorph autoAccept: self autoAccept; selectionColor: self selectionColor. aTextMorph editor installKeymappingsOn: self. ! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:32'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:10'! acceptAction: anAction acceptAction := anAction! ! !PluggableTextMorph methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 5/3/2013 14:42'! smartSuggestions self handleEdit: [textMorph editor smartSuggestions]! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 11/8/2010 22:10'! deselect ^ textMorph editor deselect! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'AlainPlantec 8/26/2011 13:04'! setText: aText self okToStyle ifFalse: [ self setTextBasic: aText ] ifTrue: [ self setTextBasic: (self styler format: aText). aText size < 4096 ifTrue: [ self styler style: textMorph contents ] ifFalse: [ self styler styleInBackgroundProcess: textMorph contents ] ]! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'BenjaminVanRyseghem 8/4/2012 01:03'! getSelection "Answer the model's selection interval." getSelectionSelector ifNil: [^1 to: 0]. "null selection" ^model perform: getSelectionSelector withEnoughArguments: { self }! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 11/8/2010 22:10'! selectionInterval ^ textMorph editor selectionInterval! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 11/22/2012 18:08'! setViewToFirstHighlight | min lines | min := (self highlights detectMin: [:e | e lineNumber ]) lineNumber. lines := self textMorph paragraph lines size. self vScrollValue: (min/lines)! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'CamilloBruni 9/2/2011 13:01'! textChanged "this is used in the case where we want to listen for live changes in a text morph. otherwise we're limited to the accept behavior" changedAction ifNotNil: [changedAction value: textMorph contents asText].! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/18/2013 12:23'! setSelectionSelector ^ setSelectionSelector! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/8/2010 22:10'! minHeight "Implemented here since extent: overriden." ^super minHeight max: 16! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'EstebanLorenzano 8/1/2012 11:19'! textMorph ^ textMorph ifNil: [ self textMorph: self textMorphClass new. textMorph ]! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'NicolaiHess 2/15/2014 00:02'! selectionInterval: sel selectionInterval := sel. setSelectionSelector ifNotNil: [ model perform:setSelectionSelector with: sel ].! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! classCommentsContainingIt self handleEdit: [textMorph editor classCommentsContainingIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! find self handleEdit: [textMorph editor find]! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/8/2010 22:10'! mouseLeave: event "The mouse has left the area of the receiver" textMorph ifNotNil: [selectionInterval := textMorph editor selectionInterval]. super mouseLeave: event. self mouseOverForKeyboardFocus ifTrue: [event hand releaseKeyboardFocus: textMorph]! ! !PluggableTextMorph methodsFor: 'scrolling' stamp: 'StephaneDucasse 9/4/2011 22:23'! okToStyle self shoutEnabled ifFalse: [^ false]. (model respondsTo: #shoutAboutToStyle:) ifFalse: [^false]. ^model shoutAboutToStyle: self ! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:23'! borderStyleToUse "Answer the borderStyle that should be used for the receiver." ^self enabled ifTrue: [self theme textEditorNormalBorderStyleFor: self] ifFalse: [self theme textEditorDisabledBorderStyleFor: self]! ! !PluggableTextMorph class methodsFor: 'accessing' stamp: 'AlainPlantec 8/26/2011 17:18'! shoutEnabled ^ (Smalltalk globals includesKey: #SHPreferences) and: [(Smalltalk globals at: #SHPreferences) enabled]! ! !PluggableTextMorph class methodsFor: 'accessing' stamp: 'AlainPlantec 8/27/2011 15:54'! stylingClass ^ StylingClass! ! !PluggableTextMorph class methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:10'! showTextEditingState: aBoolean ShowTextEditingState := aBoolean! ! !PluggableTextMorph class methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:10'! showTextEditingState ^ ShowTextEditingState ifNil: [ShowTextEditingState := true]! ! !PluggableTextMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 11/8/2010 22:10'! on: anObject text: getTextSel accept: setTextSel ^ self on: anObject text: getTextSel accept: setTextSel readSelection: nil menu: nil! ! !PluggableTextMorph class methodsFor: 'instance creation' stamp: 'NicolaiHess 2/15/2014 00:01'! on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel ^ self new on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel setSelection: nil! ! !PluggableTextMorph class methodsFor: 'accessing' stamp: 'AlainPlantec 8/27/2011 15:54'! stylingClass: aClass StylingClass := aClass! ! !PluggableTextMorph class methodsFor: 'instance creation' stamp: 'NicolaiHess 2/15/2014 00:00'! on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel setSelection: setSelectionSel ^ self new on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel setSelection: setSelectionSel! ! !PluggableTextMorphWithLimits commentStamp: ''! I have a warningLimit ( 350 by default ) and an alertLimit ( 2* warningLimit by default ), and the number of characters of the text displayed is counted ( without space, tabs, cr etc). If my text size is below the warning limit, the background is white ( or the default color ), if it is between warningLimit and alertLimit, the background turns more and more yellow, and if it's above the alertLimit, the background turns orange :) Test it with: self example. I am designed for editing method source code !!! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 01:26'! alertLimit: anObject alertLimit := anObject! ! !PluggableTextMorphWithLimits methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 8/6/2012 01:27'! lockSelector ^ lockSelector! ! !PluggableTextMorphWithLimits methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/27/2012 11:31'! defaultOpenMorph ^ (AlphaImageMorph new image: self defaultUnLockIcon) alpha: 0.6! ! !PluggableTextMorphWithLimits methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/27/2012 11:29'! defaultLockIcon "^ UITheme current lockIcon" ^(Form extent: 16@16 depth: 32 fromArray: #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 536870912 1763976231 2152220746 2017213502 1090519040 0 0 0 0 0 0 0 0 16777217 0 1778384896 4202726023 4291019976 4291283147 4291217611 4289441201 3056480051 0 0 0 0 0 0 0 0 1107296256 4286678155 4291086543 3546177637 2671262270 2991016013 4288060064 4290823372 2887655202 0 0 0 0 0 0 0 3140168752 4290363850 3425776439 0 0 0 1828716544 4287928993 4135025795 570425344 0 0 0 0 0 0 3410315862 4287995304 1795820311 0 0 0 16777216 4284310124 4287797925 838860800 0 0 0 0 0 1510935808 4064757804 4287928968 3392352778 2519805440 2620666368 2587111936 2787714816 4284244555 4287731072 2819492352 33554432 0 0 0 0 4202126080 4294961683 4261409308 4294965029 4294964006 4294964261 4294964005 4294964262 4278187808 4227854104 4291404035 1342177280 0 0 0 0 4034548736 4294954779 4294958122 4278115368 4294958631 4294959657 4294959143 4294892583 4278115368 4227848229 4291400451 1325400064 0 0 0 0 4017705216 4294950663 4294887947 4294954762 4294559499 4268183567 4290943244 4294956298 4278110986 4227843593 4291267073 1308622848 0 0 0 0 4017704704 4294948352 4294819586 4278174209 4294952962 4281870593 4274821634 4278176001 4294951169 4227841281 4291266048 1308622848 0 0 0 0 4017704448 4294947584 4294818816 4294884608 4294951936 4289694976 4277977088 4278173184 4294950144 4227840256 4291265536 1308622848 0 0 0 0 4000992768 4294947584 4261198592 4261264640 4261198848 4261397248 4261264896 4261264640 4261199104 4210931712 4291199744 1308622848 0 0 0 0 4168239106 4294616837 4294290950 4294356998 4294356998 4294357254 4294356997 4294356998 4294356997 4294421509 4290542083 1308622848 0 0 0 0 1342966019 2367953415 2250709769 2250644233 2250644233 2250644233 2250644233 2250644233 2250644233 2250841097 2148929541 100663296 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0)! ! !PluggableTextMorphWithLimits methodsFor: 'private' stamp: ''! textSize ^ self class textSizeOf: self text! ! !PluggableTextMorphWithLimits methodsFor: 'drawing' stamp: 'CamilloBruni 10/9/2012 17:58'! basicColor ^ extension ifNil: [ color] ifNotNil: [ extension fillStyle ifNil: [ color ] ifNotNil: [ :fillStyle | fillStyle asColor ]].! ! !PluggableTextMorphWithLimits methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/6/2012 01:27'! stringColor | size | size := self textSize. self warningLimit negative ifTrue: [ ^ Color black ]. ^ size >= self warningLimit ifTrue: [ size >= self alertLimit ifTrue: [ Color red ] ifFalse: [ Color orange ]] ifFalse: [ Color black ].! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 01:26'! alertLimit ^ alertLimit ifNil: [ alertLimit := 2 * (self warningLimit) ]! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/4/2012 00:52'! lock self locked: true! ! !PluggableTextMorphWithLimits methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:06'! initialize super initialize. locked := false. lockIcon := self defaultOpenMorph. self addIcon. lockIcon on: #mouseEnter send: #colorize to: self. lockIcon on: #mouseLeave send: #decolorize to: self. lockIcon on: #click send: #toggleLock to: self! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 01:27'! warningLimit ^ warningLimit ifNil: [ warningLimit := self class defaultWarningLimit ]! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 01:30'! forceRedraw self fullDrawOn: World canvas! ! !PluggableTextMorphWithLimits methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 8/6/2012 00:44'! colorize self ifLocked: [ ^ self ]. lockIcon alpha: 1! ! !PluggableTextMorphWithLimits methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 8/6/2012 00:44'! decolorize self ifLocked: [ ^ self ]. lockIcon alpha: 0.6! ! !PluggableTextMorphWithLimits methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 8/5/2012 23:46'! lockSelector: aSelector lockSelector := aSelector! ! !PluggableTextMorphWithLimits methodsFor: 'test' stamp: 'BenjaminVanRyseghem 8/5/2012 23:34'! innerExtent "self halt." " lock := lock +1. " ^ (self innerBounds extent - 6" - (10+((self textSize printString size+1)*(self basicWidth)))") max: 0@0! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 00:24'! canLockChangeSelector: aSelector canLockChangeSelector := aSelector! ! !PluggableTextMorphWithLimits methodsFor: 'geometry' stamp: 'BenjaminVanRyseghem 8/6/2012 01:20'! extent: newExtent "The inner bounds may have changed due to scrollbar visibility." | delta | super extent: newExtent. lockIcon ifNil: [ ^ self ]. lockIcon extent: 16@16. self vIsScrollbarShowing ifTrue: [ delta := 13 ] ifFalse: [ delta := 0 ]. lockIcon topRight: (self bounds right - 8 - delta ) @ (self bounds top + 8)! ! !PluggableTextMorphWithLimits methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 8/6/2012 01:37'! drawOn: aCanvas | rect stringColor size top bottom newRect | super drawOn: aCanvas. size := self textSize. rect := self buildRectFrom: self bounds. top := self bounds top + self borderWidth. bottom := self bounds bottom - self borderWidth. stringColor := self stringColor. newRect := (rect left-self basicWidth-10)@top corner: (rect right)@bottom. aCanvas fillRectangle: newRect fillStyle: (self backgroundColorFor: newRect ). self wantsFrameAdornments ifTrue: [ self theme drawTextAdornmentsFor: self on: aCanvas]. (self warningLimit negative or: [ self warningLimit isZero ]) ifFalse: [ aCanvas drawString: size printString in: rect font: TextStyle defaultFont color: stringColor ].! ! !PluggableTextMorphWithLimits methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/27/2012 11:30'! defaultUnLockIcon "^ UITheme current lockIcon" ^(Form extent: 16@16 depth: 32 fromArray: #(0 0 0 0 0 0 0 5592147 0 0 553648128 721420288 704643072 65332446 0 16843009 0 0 0 0 0 0 1117968 0 251658240 3121943830 4067060333 4187132310 4136011145 3794874930 1459617792 0 0 0 0 0 0 0 0 285212672 3962186029 4290954954 4291743700 4288849064 4289967289 4293323247 4284375141 1779503121 0 0 0 0 0 19474729 0 2434077717 4288389285 4287862940 3306558744 1728250885 2416774413 4283322451 4292007904 4030084923 0 0 0 0 0 0 0 3761057329 4289771971 3677040432 0 0 0 2097152000 4287797409 4284967793 187182949 704643072 671088640 671088640 671088640 738197504 469762048 4027519529 4289574351 3305178143 370154881 0 0 1308622848 4286482061 4219175047 3444196907 4287397895 4287792646 4287726598 4287726598 4287726854 4287595012 4288516623 4276410968 4288581898 4234040595 671088674 0 1493172224 4282928210 4282796368 4284962839 4294962178 4294957827 4294957571 4294957571 4294956802 4294957571 4294957825 4278177536 4294959105 4291141640 1375731713 0 490486844 1578768664 1528305431 4268053271 4294955008 4294950912 4294950913 4278107905 4294953992 4294886402 4278042624 4294950913 4294951936 4290810373 1275068417 0 0 0 0 4284895767 4278177025 4294819329 4294950656 4278174729 4279439628 4290284299 4278175744 4294819329 4294951424 4290875397 1275068417 0 0 0 0 4284960281 4278175236 4294752004 4294883076 4278172678 4285416465 4292910091 4278172676 4294817540 4294949892 4290873864 1258291200 0 0 0 0 4284893978 4278173194 4294684936 4277973000 4278170632 4292053266 4294289676 4278039048 4277973001 4294948104 4290806284 1275068416 0 15529452 0 0 4284695837 4244618773 4244616980 4244616980 4244616724 4244618515 4244616979 4244616724 4244616724 4244618260 4290673173 1442840588 0 0 0 0 2822188320 4285022227 4234952979 4251664659 4234887443 4234952723 4234887187 4218110227 4218110227 4268704530 3964153623 572797508 0 0 0 0 0 33554432 33554432 16777216 33554432 33554432 33554432 33554432 33554432 33554432 0 0 18487065 15529709 0 0 2040093 17630726 17498117 17432837 17498373 17563909 17498373 17563909 17563909 17498116 920589 16777215 0 0 0 0) offset: 0@0)! ! !PluggableTextMorphWithLimits methodsFor: 'initialize' stamp: 'IgorStasenko 12/19/2012 18:14'! addIcon self addMorph: lockIcon fullFrame: ((1 @ 0 corner: 1 @ 0) asLayoutFrame leftOffset: -20; bottomOffset: 20)! ! !PluggableTextMorphWithLimits methodsFor: 'actions' stamp: 'CamilloBruni 9/21/2013 11:58'! acceptBasic "should be refactored with accept that comes from PluggableTextMorphPlus " "Inform the model of text to be accepted, and return true if OK." | saveSelection saveScrollerOffset | self locked ifFalse: [ ^ super acceptBasic ]. saveSelection := self selectionInterval copy. saveScrollerOffset := scroller offset copy. (self canDiscardEdits and: [self alwaysAccept not]) ifTrue: [^ self flash]. self hasEditingConflicts ifTrue:[ (self confirm: 'Caution!! This method may have been changed elsewhere since you started editing it here. Accept anyway?' translated) ifFalse: [^ self flash]]. [ method methodClass compile: (self styler unstyledTextFrom: textMorph asText) classified: method category notifying: self ] ensure: [ unstyledAcceptText := nil ]. self hasUnacceptedEdits: false. ["During the step for the browser, updateCodePaneIfNeeded is called, and invariably resets the contents of the codeholding PluggableTextMorph at that time, resetting the cursor position and scroller in the process. The following line forces that update without waiting for the step, then restores the cursor and scrollbar" (model respondsTo: #updateCodePaneIfNeeded) ifTrue: [model updateCodePaneIfNeeded]. scroller offset: saveScrollerOffset. self setScrollDeltas. self selectFrom: saveSelection first to: saveSelection last ] on: Error do: []! ! !PluggableTextMorphWithLimits methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 3/20/2012 17:30'! buildRectFrom: rect | top bottom right left | top := (rect bottom - StandardFonts defaultFont height - 4). bottom := rect bottom. right := rect right. left := right - ((self textSize printString size+1)*(self basicWidth)). self vIsScrollbarShowing ifTrue: [ right := right - scrollBar width. left := left - scrollBar width ]. ^ (left-5@top corner: right-5@bottom)! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/4/2012 01:10'! ifLocked: aBlock self ifLocked: aBlock ifUnlocked: []! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/4/2012 00:52'! unlock self locked: false! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/4/2012 01:08'! ifLocked: aBlock ifUnlocked: anotherBlock self locked ifTrue: aBlock ifFalse: anotherBlock! ! !PluggableTextMorphWithLimits methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 3/20/2012 16:46'! basicWidth ^ StandardFonts defaultFont widthOf: $2! ! !PluggableTextMorphWithLimits methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/5/2012 22:16'! setBalloonTextFrom: aMethod | string | string := String streamContents: [:s | s << aMethod methodClass name << '>>#' << aMethod selector ]. self setBalloonText: string! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/27/2012 11:31'! toggleLock self canChangeLock ifFalse: [ ^ self ]. self ifLocked: [ self unlock. lockIcon image: self defaultUnLockIcon ] ifUnlocked: [ self lock. lockIcon image: self defaultLockIcon ]. self model ifNotNil: [:m | self lockSelector ifNotNil: [:s | m perform: s withEnoughArguments: { self locked . self } ]]! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 17:53'! locked ^ locked! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/5/2012 22:15'! lockFrom: aMethod self lock. method := aMethod. self setBalloonTextFrom: aMethod ! ! !PluggableTextMorphWithLimits methodsFor: 'drawing' stamp: 'BenComan 3/23/2014 23:43'! backgroundColorFor: rect "Return the current fillStyle of the receiver." | basicColor defaultColor | defaultColor := Smalltalk ui theme textEditorNormalFillStyleFor: self. "The next line is the minimal change to get Vistary Theme working for Case 13112 during Pharo 3 Beta. Case 13121 is logged to clean this further in Pharo 4" (defaultColor isKindOf: FillStyle) ifTrue: [ ^defaultColor ]. basicColor := self basicColor. self warningLimit negative ifTrue: [ ^ basicColor ]. textMorph ifNotNil: [ | size | size := self textSize. ( size >= self warningLimit ) ifTrue: [ | overshoot transitionSpan transitionColor | transitionSpan := self warningLimit. transitionColor := Color yellow mixed: 0.6 with: self basicColor. ( size >= self alertLimit ) ifFalse: [ overshoot := size - self warningLimit ] ifTrue: [ transitionSpan := self alertLimit - self warningLimit. basicColor := transitionColor mixed: 0.5 with: self basicColor. transitionColor := (Color orange mixed: 0.5 with: Color red) mixed: 0.5 with: self basicColor. overshoot := size - self alertLimit ]. ^ CompositeFillStyle fillStyles: { (GradientFillStyle ramp: {0->transitionColor. 1 -> basicColor }) origin: (rect width/2) asFloat @ rect bottom; direction: 0@((12+(2*rect height*overshoot / transitionSpan)) negated asFloat); normal: 0@1; radial: false; yourself. (GradientFillStyle ramp: {0 -> defaultColor. 0.3->(defaultColor alpha: 0.01) }) origin: rect left @ (rect height/2) asFloat; direction: (rect width)@0; normal: 1@0; radial: false; yourself } " ^ transitionColor mixed: overshoot / transitionSpan with: basicColor" ] ]. ^ basicColor ! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 17:53'! locked: anObject locked := anObject! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/5/2012 23:56'! canChangeLock self model ifNotNil: [:m | self canLockChangeSelector ifNotNil: [:s | ^ m perform: s withEnoughArguments: { self } ]]. ^ true! ! !PluggableTextMorphWithLimits methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 8/5/2012 23:56'! canLockChangeSelector ^ canLockChangeSelector! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 01:27'! warningLimit: anObject warningLimit := anObject! ! !PluggableTextMorphWithLimits class methodsFor: 'accessing' stamp: ''! defaultWarningLimit: anInteger " self defaultWarningLimit:nil " DefaultWarningLimit := anInteger! ! !PluggableTextMorphWithLimits class methodsFor: 'text' stamp: ''! textSizeOf: aText | result count ignoredCharacters | result := 0. count := true. ignoredCharacters := self ignoredCharacters. aText do: [:char | (char = $") ifTrue: [ count := count not ] ifFalse: [ ((ignoredCharacters includes: char) not and: [ count ]) ifTrue: [ result := result + 1 ]]]. ^ result.! ! !PluggableTextMorphWithLimits class methodsFor: 'text' stamp: ''! ignoredCharacters ^ { Character space. Character tab. Character cr. $.. $;. $:. $'. $(. $) }! ! !PluggableTextMorphWithLimits class methodsFor: 'example' stamp: ''! example " self example " | window textMorph | textMorph := self on: self text: #getText accept: nil. window := StandardWindow new. window addMorph: textMorph frame: (0@0 corner: 1@1). window openInWorld. window title: 'PluggableTextMorphWithLimits example'! ! !PluggableTextMorphWithLimits class methodsFor: 'example' stamp: ''! getText ^ ' " an example to show that comments are not counted " asdasf a s d f as d kfj. ha,sdkjhfaksdjhfakjsdhfakjsh. df.kajhsdf.kajhsdf.kjahsd.fkj. ahs.dkja.sdkfjha.sdkfjha.skdjfh.kasjdhf.kasjd hf.aksjdhfakjsdhfwuelriuweliuqywerliquyerliqwuyerlqiwuyerliq wuyerliqwuyerlqiuweyrlqiwueyrlqwieuyrlqwiueyrlqwieuyrlqiweuyrlqwiuerylqiwueyrlqiwueyrlqiwueyrlqwiuerylqiwueyrlqiweuyrlqwieuyrlqwiueyrlqweiuyrlqwieuryqlwiehfgh ((ENTER RANDOM CHARACTERS NOW))'! ! !PluggableTextMorphWithLimits class methodsFor: 'accessing' stamp: ''! resetDefaultWarningLimit " self resetDefaultWarningLimit " self defaultWarningLimit: nil! ! !PluggableTextMorphWithLimits class methodsFor: 'accessing' stamp: ''! defaultWarningLimit ^ DefaultWarningLimit ifNil: [ DefaultWarningLimit := 350 ]! ! !PluggableThreePhaseButtonMorph commentStamp: ''! A PluggableThreePhaseButtonMorph is an extesion of ThreePhaseButtonMorph to make it pluggable Then a model can be defined, and queried for state, on image, off image and pressed image.! !PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 1/21/2012 23:01'! updatePressedImage self pressedImage: ( target perform: pressedImageSelector )! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:07'! offImageSelector: anObject offImageSelector := anObject! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! pressedImageSelector ^ pressedImageSelector! ! !PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 1/21/2012 23:16'! update: aSymbol aSymbol == stateSelector ifTrue: [ ^ self updateState ]. aSymbol == onImageSelector ifTrue: [ ^ self updateOnImage ]. aSymbol == offImageSelector ifTrue: [ ^ self updateOffImage ]. aSymbol == pressedImageSelector ifTrue: [ ^ self updatePressedImage ]. ^ super update: aSymbol! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! offImageSelector ^ offImageSelector! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! stateSelector: anObject stateSelector := anObject! ! !PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 1/21/2012 23:01'! updateOnImage self onImage: ( target perform: onImageSelector )! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! pressedImageSelector: anObject pressedImageSelector := anObject! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! onImageSelector ^ onImageSelector! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:25'! balloonText ^ self helpText! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:25'! helpText: anObject helpText := anObject! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! onImageSelector: anObject onImageSelector := anObject! ! !PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 1/21/2012 23:15'! updateState ( target perform: stateSelector ) ifTrue: [ self state: #on ] ifFalse:[ self state: #off ]! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:25'! helpText ^ helpText! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! stateSelector ^ stateSelector! ! !PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 1/21/2012 23:01'! updateOffImage self offImage: ( target perform: offImageSelector )! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:04'! target: anObject target ifNotNil: [ target removeDependent: self ]. anObject ifNotNil: [ anObject addDependent: self ]. target := anObject.! ! !PluggableThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 1/21/2012 22:53'! on: aModel ^ self new target: aModel; yourself! ! !PluggableTreeItemNode commentStamp: 'ar 2/12/2005 04:37'! Tree item for PluggableTreeMorph.! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! asString ^model printNode: self! ! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! balloonText ^model balloonTextForNode: self! ! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! acceptDroppingObject: anotherItem ^model dropNode: anotherItem on: self! ! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:02'! canBeDragged ^model isDraggableNode: self! ! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! wantsDroppedObject: anotherItem ^model wantsDroppedNode: anotherItem on: self! ! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! hasContents ^model hasNodeContents: self! ! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:03'! contents ^model contentsOfNode: self! ! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:04'! icon ^model iconOfNode: self! ! !PluggableTreeMorph commentStamp: 'ar 2/12/2005 04:38'! A pluggable tree morph.! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! dropItemSelector ^dropItemSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! wantsDropSelector ^wantsDropSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! getRootsSelector ^getRootsSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! hasChildrenSelector ^hasChildrenSelector! ! !PluggableTreeMorph methodsFor: 'updating' stamp: 'ar 2/12/2005 17:29'! selectPath: path in: listItem path isEmpty ifTrue: [^self setSelectedMorph: nil]. listItem withSiblingsDo: [:each | (each complexContents item = path first) ifTrue: [ each isExpanded ifFalse: [ each toggleExpandedState. self adjustSubmorphPositions. ]. each changed. path size = 1 ifTrue: [ ^self setSelectedMorph: each ]. each firstChild ifNil: [^self setSelectedMorph: nil]. ^self selectPath: path allButFirst in: each firstChild ]. ]. ^self setSelectedMorph: nil ! ! !PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:20'! printNode: node getLabelSelector ifNil:[^node item printString]. ^model perform: getLabelSelector with: node item! ! !PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:19'! balloonTextForNode: node getHelpSelector ifNil:[^nil]. ^model perform: getHelpSelector with: node item! ! !PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 01:13'! contentsOfNode: node | children | getChildrenSelector ifNil:[^#()]. children := model perform: getChildrenSelector with: node item. ^children collect:[:item| PluggableTreeItemNode with: item model: self]! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:33'! getSelectedPathSelector: aSymbol getSelectedPathSelector := aSymbol.! ! !PluggableTreeMorph methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 3/25/2013 13:33'! wantsDroppedMorph: aMorph event: anEvent aMorph dragTransferType == #dragTransfer ifFalse: [ ^ false ]. ^ wantsDropSelector ifNil: [ model wantsDroppedMorph: aMorph event: anEvent inMorph: self ] ifNotNil: [ model perform: wantsDropSelector with: aMorph passenger ]! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! getHelpSelector: aSymbol getHelpSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:20'! dropNode: srcNode on: dstNode dropItemSelector ifNil:[^nil]. model perform: dropItemSelector with: srcNode item with: dstNode item! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! getChildrenSelector ^getChildrenSelector! ! !PluggableTreeMorph methodsFor: 'selection' stamp: 'LaurentLaffont 3/17/2010 21:41'! setSelectedMorph: aMorph selectedWrapper := aMorph complexContents. self selection: selectedWrapper. setSelectionSelector ifNotNil:[ model perform: setSelectionSelector with: (selectedWrapper ifNotNil:[selectedWrapper item]). ].! ! !PluggableTreeMorph methodsFor: 'node access' stamp: 'BenjaminVanRyseghem 3/25/2013 13:33'! wantsDroppedNode: srcNode on: dstNode dropItemSelector ifNil:[^false]. wantsDropSelector ifNil:[^true]. ^(model perform: wantsDropSelector with: srcNode with: dstNode) == true! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! getLabelSelector ^getLabelSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'mvdg 2/11/2007 13:53'! dragItemSelector ^dragItemSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'LaurentLaffont 3/17/2010 21:42'! setSelectedSelector ^setSelectionSelector! ! !PluggableTreeMorph methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 3/25/2013 13:16'! acceptDroppingMorph: aMorph event: evt | item dropTarget | dropItemSelector ifNil:[ model acceptDroppingMorph: aMorph event: evt inMorph: self ] ifNotNil: [ item := aMorph passenger. dropTarget := (self itemFromPoint: evt position) withoutListWrapper. model perform: dropItemSelector with: item with: dropTarget ]. evt hand releaseMouseFocus: self. Cursor normal show. ! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:27'! wantsDropSelector: aSymbol wantsDropSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! getHelpSelector ^getHelpSelector! ! !PluggableTreeMorph methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/5/2013 11:22'! startDrag: anEvent | aTransferMorph itemMorph passenger | self dragEnabled ifTrue: [itemMorph := scroller submorphs detect: [:any | any highlightedForMouseDown] ifNone: []]. (itemMorph isNil or: [anEvent hand hasSubmorphs]) ifTrue: [^ self]. itemMorph highlightForMouseDown: false. itemMorph ~= self selectedMorph ifTrue: [self setSelectedMorph: itemMorph]. passenger := dragItemSelector ifNil: [ self model dragPassengerFor: itemMorph withoutListWrapper inMorph: self ] ifNotNil: [ self model perform: dragItemSelector withEnoughArguments: { itemMorph withoutListWrapper. self } ]. passenger ifNotNil: [aTransferMorph := self model transferFor: passenger from: self. aTransferMorph dragTransferType: #dragTransfer. aTransferMorph align: aTransferMorph draggedMorph center with: anEvent position. anEvent hand grabMorph: aTransferMorph]. anEvent hand releaseMouseFocus: self! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'mvdg 2/9/2007 21:37'! dropItemSelector: aSymbol dropItemSelector := aSymbol. aSymbol ifNotNil:[self dropEnabled: true].! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! getIconSelector: aSymbol getIconSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:58'! keystrokeActionSelector ^keystrokeActionSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:58'! keystrokeActionSelector: aSymbol keystrokeActionSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'updating' stamp: 'ar 2/12/2005 19:11'! update: what what ifNil:[^self]. what == getRootsSelector ifTrue:[ self roots: (model perform: getRootsSelector) ]. what == getSelectedPathSelector ifTrue:[ ^self selectPath: (model perform: getSelectedPathSelector) in: (scroller submorphs at: 1 ifAbsent: [^self]) ]. ^super update: what! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'mvdg 2/11/2007 13:53'! dragItemSelector: aSymbol dragItemSelector := aSymbol. aSymbol ifNotNil:[self dragEnabled: true].! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 01:11'! roots: anArray roots := anArray collect:[:item| PluggableTreeItemNode with: item model: self]. self list: roots.! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:22'! roots ^roots! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:33'! getSelectedPathSelector ^getSelectedPathSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! hasChildrenSelector: aSymbol hasChildrenSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! getLabelSelector: aSymbol getLabelSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! getRootsSelector: aSelector getRootsSelector := aSelector. self update: getRootsSelector.! ! !PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:11'! hasNodeContents: node hasChildrenSelector ifNil:[^node contents isEmpty not]. ^model perform: hasChildrenSelector with: node item! ! !PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:20'! iconOfNode: node getIconSelector ifNil:[^nil]. ^model perform: getIconSelector with: node item! ! !PluggableTreeMorph methodsFor: 'node access' stamp: 'ar 2/12/2005 00:02'! isDraggableNode: node ^true! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'LaurentLaffont 3/17/2010 21:42'! setSelectedSelector: aSymbol setSelectionSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! getIconSelector ^getIconSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! getChildrenSelector: aSymbol getChildrenSelector := aSymbol.! ! !PluginBasedJPEGReadWriter commentStamp: ''! I provide fast JPEG compression and decompression. I require the VM pluginJPEGReadWriter2Plugin, which is typically stored in same directory as the Squeak virtual machine. JPEGReadWriter2Plugin is based on LIBJPEG library. This sentence applies to the plugin: "This software is based in part on the work of the Independent JPEG Group". The LIBJPEG license allows it to be used free for any purpose so long as its origin and copyright are acknowledged. You can read more about LIBJPEG and get the complete source code at www.ijg.org. ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'jmv 12/7/2001 13:45'! primJPEGReadImage: aJPEGDecompressStruct fromByteArray: source onForm: form doDithering: ditherFlag errorMgr: aJPEGErrorMgr2Struct self primitiveFailed ! ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'ar 11/27/2001 00:39'! primJPEGPluginIsPresent ^false! ! !PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: 'jm 11/20/2001 10:21'! nextPutImage: aForm "Encode the given Form on my stream with default quality." ^ self nextPutImage: aForm quality: -1 progressiveJPEG: false ! ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGDecompressStructSize self primitiveFailed ! ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGErrorMgr2StructSize self primitiveFailed ! ! !PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! nextImageSuggestedDepth: depth "Decode and answer a Form of the given depth from my stream. Close the stream if it is a file stream. Possible depths are 16-bit and 32-bit." | bytes width height form jpegDecompressStruct jpegErrorMgr2Struct depthToUse | bytes := stream upToEnd. stream close. jpegDecompressStruct := ByteArray new: self primJPEGDecompressStructSize. jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. self primJPEGReadHeader: jpegDecompressStruct fromByteArray: bytes errorMgr: jpegErrorMgr2Struct. width := self primImageWidth: jpegDecompressStruct. height := self primImageHeight: jpegDecompressStruct. "Odd width images of depth 16 gave problems. Avoid them (or check carefully!!)" depthToUse := depth = 32 | width odd ifTrue: [ 32 ] ifFalse: [ 16 ]. form := Form extent: width @ height depth: depthToUse. (width = 0 or: [ height = 0 ]) ifTrue: [ ^ form ]. self primJPEGReadImage: jpegDecompressStruct fromByteArray: bytes onForm: form doDithering: true errorMgr: jpegErrorMgr2Struct. ^ form! ! !PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! compress: aForm quality: quality "Encode the given Form and answer the compressed ByteArray. Quality goes from 0 (low) to 100 (high), where -1 means default." | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount | aForm unhibernate. "odd width images of depth 16 give problems; avoid them." sourceForm := aForm depth = 32 | (aForm width even & (aForm depth = 16)) ifTrue: [ aForm ] ifFalse: [ aForm asFormOfDepth: 32 ]. jpegCompressStruct := ByteArray new: self primJPEGCompressStructSize. jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. buffer := ByteArray new: sourceForm width * sourceForm height + 1024. byteCount := self primJPEGWriteImage: jpegCompressStruct onByteArray: buffer form: sourceForm quality: quality progressiveJPEG: false errorMgr: jpegErrorMgr2Struct. byteCount = 0 ifTrue: [ self error: 'buffer too small for compressed data' ]. ^ buffer copyFrom: 1 to: byteCount! ! !PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! nextPutImage: aForm quality: quality progressiveJPEG: progressiveFlag "Encode the given Form on my stream with the given settings. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG." | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount | aForm unhibernate. "odd width images of depth 16 give problems; avoid them." sourceForm := aForm depth = 32 | (aForm width even & (aForm depth = 16)) ifTrue: [ aForm ] ifFalse: [ aForm asFormOfDepth: 32 ]. jpegCompressStruct := ByteArray new: self primJPEGCompressStructSize. jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. buffer := ByteArray new: sourceForm width * sourceForm height + 1024. byteCount := self primJPEGWriteImage: jpegCompressStruct onByteArray: buffer form: sourceForm quality: quality progressiveJPEG: progressiveFlag errorMgr: jpegErrorMgr2Struct. byteCount = 0 ifTrue: [ self error: 'buffer too small for compressed data' ]. stream next: byteCount putAll: buffer startingAt: 1. self close! ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primImageWidth: aJPEGCompressStruct self primitiveFailed ! ! !PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! imageExtent: aByteArray "Answer the extent of the compressed image encoded in the given ByteArray." | jpegDecompressStruct jpegErrorMgr2Struct w h | jpegDecompressStruct := ByteArray new: self primJPEGDecompressStructSize. jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. self primJPEGReadHeader: jpegDecompressStruct fromByteArray: aByteArray errorMgr: jpegErrorMgr2Struct. w := self primImageWidth: jpegDecompressStruct. h := self primImageHeight: jpegDecompressStruct. ^ w @ h! ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGReadHeader: aJPEGDecompressStruct fromByteArray: source errorMgr: aJPEGErrorMgr2Struct self primitiveFailed ! ! !PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! uncompress: aByteArray into: aForm doDithering: ditherFlag "Uncompress an image from the given ByteArray into the given Form. Fails if the given Form has the wrong dimensions or depth. If aForm has depth 16 and ditherFlag = true, do ordered dithering." | jpegDecompressStruct jpegErrorMgr2Struct w h | aForm unhibernate. jpegDecompressStruct := ByteArray new: self primJPEGDecompressStructSize. jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. self primJPEGReadHeader: jpegDecompressStruct fromByteArray: aByteArray errorMgr: jpegErrorMgr2Struct. w := self primImageWidth: jpegDecompressStruct. h := self primImageHeight: jpegDecompressStruct. aForm width = w & (aForm height = h) ifFalse: [ ^ self error: 'form dimensions do not match' ]. "odd width images of depth 16 give problems; avoid them" w odd ifTrue: [ aForm depth = 32 ifFalse: [ ^ self error: 'must use depth 32 with odd width' ] ] ifFalse: [ aForm depth = 16 | (aForm depth = 32) ifFalse: [ ^ self error: 'must use depth 16 or 32' ] ]. self primJPEGReadImage: jpegDecompressStruct fromByteArray: aByteArray onForm: aForm doDithering: ditherFlag errorMgr: jpegErrorMgr2Struct! ! !PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: 'jm 11/20/2001 10:23'! nextImage "Decode and answer a Form from my stream." ^ self nextImageSuggestedDepth: Display depth ! ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGWriteImage: aJPEGCompressStruct onByteArray: destination form: form quality: quality progressiveJPEG: progressiveFlag errorMgr: aJPEGErrorMgr2Struct self primitiveFailed ! ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGCompressStructSize self primitiveFailed ! ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:34'! primImageHeight: aJPEGCompressStruct self primitiveFailed ! ! !PluginBasedJPEGReadWriter methodsFor: 'testing' stamp: 'ar 11/27/2001 00:39'! understandsImageFormat "Answer true if the image stream format is understood by this decoder." self isPluginPresent ifFalse:[^false]. "cannot read it otherwise" self next = 16rFF ifFalse: [^ false]. self next = 16rD8 ifFalse: [^ false]. ^ true ! ! !PluginBasedJPEGReadWriter methodsFor: 'testing' stamp: 'ar 11/27/2001 00:40'! isPluginPresent ^self primJPEGPluginIsPresent! ! !PluginBasedJPEGReadWriter methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! uncompress: aByteArray into: aForm "Uncompress an image from the given ByteArray into the given Form. Fails if the given Form has the wrong dimensions or depth. If aForm has depth 16, do ordered dithering." | jpegDecompressStruct jpegErrorMgr2Struct w h | aForm unhibernate. jpegDecompressStruct := ByteArray new: self primJPEGDecompressStructSize. jpegErrorMgr2Struct := ByteArray new: self primJPEGErrorMgr2StructSize. self primJPEGReadHeader: jpegDecompressStruct fromByteArray: aByteArray errorMgr: jpegErrorMgr2Struct. w := self primImageWidth: jpegDecompressStruct. h := self primImageHeight: jpegDecompressStruct. aForm width = w & (aForm height = h) ifFalse: [ ^ self error: 'form dimensions do not match' ]. "odd width images of depth 16 give problems; avoid them" w odd ifTrue: [ aForm depth = 32 ifFalse: [ ^ self error: 'must use depth 32 with odd width' ] ] ifFalse: [ aForm depth = 16 | (aForm depth = 32) ifFalse: [ ^ self error: 'must use depth 16 or 32' ] ]. self primJPEGReadImage: jpegDecompressStruct fromByteArray: aByteArray onForm: aForm doDithering: true errorMgr: jpegErrorMgr2Struct! ! !PluginBasedJPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'usmanbhatti 11/5/2013 11:26'! putForm: aForm quality: quality progressiveJPEG: progressiveFlag onFileNamed: fileName "Store the given Form as a JPEG file of the given name, overwriting any existing file of that name. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG." | writer | fileName asFileReference ensureDelete. writer := self on: (FileStream newFileNamed: fileName) binary. Cursor write showWhile: [ writer nextPutImage: aForm quality: quality progressiveJPEG: progressiveFlag ]. writer close! ! !PluginBasedJPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'ar 6/16/2002 18:54'! primJPEGPluginIsPresent ^false! ! !PluginBasedJPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('jpg' 'jpeg')! ! !PluginTreeNode commentStamp: ''! A PluginTreeNode is a node of a NautilusPluginManagerTree! !PluginTreeNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/25/2011 14:50'! getSelectedPosition ^ selectedPosition ifNil: [| it | it := self item ifNotNil: [ self item second ]. selectedPosition := self getPositionsList indexOf: it ]! ! !PluginTreeNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/25/2011 14:56'! buildDropListFor: aSelector | dropList | dropList := self theme newDropListIn: World for: self list: #getPositionsList getSelected: #getSelectedPosition setSelected: #setSelectedPosition: getEnabled: nil useIndex: true help: 'Select the position where the plugin will be displayed'. dropList hResizing: #rigid. dropList width: 75. ^ dropList! ! !PluginTreeNode methodsFor: 'morphs' stamp: 'BenjaminVanRyseghem 8/25/2011 14:17'! firstMorph ^ self item ifNotNil: [:it | it first pluginName asStringMorph ]! ! !PluginTreeNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/25/2011 14:59'! setSelectedPosition: anIndex | position | selectedPosition := anIndex. position := self getPositionsList at: anIndex. self item at: 2 put: position. self changed: #getSelectedPosition! ! !PluginTreeNode methodsFor: 'morphs' stamp: 'BenjaminVanRyseghem 8/25/2011 14:22'! secondMorph ^ self item ifNotNil: [:it | self buildDropListFor: it second ]! ! !PluginTreeNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/25/2011 15:04'! getPositionsList ^ self item ifNil: [ {} ] ifNotNil: [:it | it first possiblePositions ]! ! !Point commentStamp: ''! I represent an x-y pair of numbers usually designating a location on the screen.! !Point methodsFor: 'accessing' stamp: ''! x "Answer the x coordinate." ^x! ! !Point methodsFor: 'polar coordinates' stamp: 'hk 11/10/2005 10:07'! theta "Answer the angle the receiver makes with origin in radians. right is 0; down is 90. Corrected the constants from single precision to 64 Bit precision and changed the sends in case of overflow to constants HK 2005-07-23" | tan theta | x = 0 ifTrue: [y >= 0 ifTrue: [^ 1.570796326794897 "90.0 degreesToRadians"] ifFalse: [^ 4.71238898038469 "270.0 degreesToRadians"]] ifFalse: [tan := y asFloat / x asFloat. theta := tan arcTan. x >= 0 ifTrue: [y >= 0 ifTrue: [^theta] ifFalse: [^"360.0 degreesToRadians" 6.283185307179586 + theta]] ifFalse: [^"180.0 degreesToRadians" 3.141592653589793 + theta]]! ! !Point methodsFor: 'point functions' stamp: '6/9/97 14:51 di'! quadrantOf: otherPoint "Return 1..4 indicating relative direction to otherPoint. 1 is downRight, 2=downLeft, 3=upLeft, 4=upRight" ^ x <= otherPoint x ifTrue: [y < otherPoint y ifTrue: [1] ifFalse: [4]] ifFalse: [y <= otherPoint y ifTrue: [2] ifFalse: [3]] " [Sensor anyButtonPressed] whileFalse: [(Display boundingBox center quadrantOf: Sensor cursorPoint) printString displayAt: 0@0] "! ! !Point methodsFor: 'point functions' stamp: 'jm 2/24/98 08:34'! onLineFrom: p1 to: p2 within: epsilon "Answer true if the receiver lies on the given line segment between p1 and p2 within a small epsilon." "is this point within the box spanning p1 and p2 expanded by epsilon? (optimized)" p1 x < p2 x ifTrue: [ ((x < (p1 x - epsilon)) or: [x > (p2 x + epsilon)]) ifTrue: [^ false]] ifFalse: [ ((x < (p2 x - epsilon)) or: [x > (p1 x + epsilon)]) ifTrue: [^ false]]. p1 y < p2 y ifTrue: [ ((y < (p1 y - epsilon)) or: [y > (p2 y + epsilon)]) ifTrue: [^ false]] ifFalse: [ ((y < (p2 y - epsilon)) or: [y > (p1 y + epsilon)]) ifTrue: [^ false]]. "it's in the box; is it on the line?" ^ (self dist: (self nearestPointAlongLineFrom: p1 to: p2)) <= epsilon! ! !Point methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! bitShiftPoint: bits x := x bitShift: bits. y := y bitShift: bits! ! !Point methodsFor: 'comparing' stamp: ''! < aPoint "Answer whether the receiver is above and to the left of aPoint." ^x < aPoint x and: [y < aPoint y]! ! !Point methodsFor: 'transforming' stamp: 'di 12/4/97 14:34'! scaleFrom: rect1 to: rect2 "Produce a point stretched according to the stretch from rect1 to rect2" ^ rect2 topLeft + (((x-rect1 left) * rect2 width // rect1 width) @ ((y-rect1 top) * rect2 height // rect1 height))! ! !Point methodsFor: 'geometry' stamp: 'lr 7/4/2009 10:42'! sideOf: otherPoint "Returns #left, #right or #center if the otherPoint lies to the left, right or on the line given by the vector from 0@0 to self" | side | side := (self crossProduct: otherPoint) sign. ^ { #right. #center. #left } at: side + 2! ! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! \\ arg "Answer a Point that is the mod of the receiver and arg." arg isPoint ifTrue: [^ (x \\ arg x) @ (y \\ arg y)]. ^ arg adaptToPoint: self andSend: #\\! ! !Point methodsFor: 'extent functions' stamp: 'StephaneDucasse 5/27/2010 22:11'! scaleTo: anExtent "Return a Point scalefactor for shrinking a thumbnail of the receiver's extent to fit within anExtent" " self and anExtent are expected to have positive nonZero x and y. " | factor sX sY | factor := 3.0 reciprocal . "EccentricityThreshhold reciprical" sX := anExtent x / self x asFloat . sY := anExtent y / self y asFloat . sX = sY ifTrue: [ ^ sX @ sY ] . "Same aspect ratio" ^ sX < sY ifTrue: [ sX @ (sX max: sY * factor) ] ifFalse: [ (sY max: sX * factor ) @ sY ] ! ! !Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! grid: aPoint "Answer a Point to the nearest rounded grid modules specified by aPoint." | newX newY | newX := x + (aPoint x // 2) truncateTo: aPoint x. newY := y + (aPoint y // 2) truncateTo: aPoint y. ^ newX @ newY! ! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! // arg "Answer a Point that is the quotient of the receiver and arg." arg isPoint ifTrue: [^ (x // arg x) @ (y // arg y)]. ^ arg adaptToPoint: self andSend: #//! ! !Point methodsFor: 'converting' stamp: ''! asIntegerPoint ^ x asInteger @ y asInteger! ! !Point methodsFor: '*Polymorph-Geometry' stamp: 'gvc 10/31/2006 11:01'! directionToLineFrom: p1 to: p2 "Answer the direction of the line from the receiver position. < 0 => left (receiver to right) = => on line > 0 => right (receiver to left)." ^((p2 x - p1 x) * (self y - p1 y)) - ((self x - p1 x) * (p2 y - p1 y))! ! !Point methodsFor: 'polar coordinates' stamp: ''! r "Answer the receiver's radius in polar coordinate system." ^(self dotProduct: self) sqrt! ! !Point methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/17/2008 13:36'! angleWith: aPoint "Answer the angle in radians between the vectors represented by the receiver and aPoint from the origin." |ar ap| ar := self angle. ap := aPoint angle. ^ap >= ar ifTrue: [ap - ar] ifFalse: [Float pi * 2 - ar + ap]! ! !Point methodsFor: 'geometry' stamp: 'laza 1/24/2000 03:44'! isInsideCircle: a with: b with: c "Returns TRUE if self is inside the circle defined by the points a, b, c. See Guibas and Stolfi (1985) p.107" ^ (a dotProduct: a) * (b triangleArea: c with: self) - ((b dotProduct: b) * (a triangleArea: c with: self)) + ((c dotProduct: c) * (a triangleArea: b with: self)) - ((self dotProduct: self) * (a triangleArea: b with: c)) > 0.0! ! !Point methodsFor: 'comparing' stamp: ''! >= aPoint "Answer whether the receiver is neither above nor to the left of aPoint." ^x >= aPoint x and: [y >= aPoint y]! ! !Point methodsFor: 'transforming' stamp: 'CamilloBruni 8/1/2012 16:12'! negated "Answer a point whose x and y coordinates are the negatives of those of the receiver." ^ (0 - x) @ (0 - y)! ! !Point methodsFor: 'transforming' stamp: ''! translateBy: delta "Answer a Point translated by delta (an instance of Point)." ^(delta x + x) @ (delta y + y)! ! !Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! squaredDistanceTo: aPoint "Answer the distance between aPoint and the receiver." | delta | delta := aPoint - self. ^ delta dotProduct: delta! ! !Point methodsFor: 'point functions' stamp: 'di 6/11/97 16:08'! flipBy: direction centerAt: c "Answer a Point which is flipped according to the direction about the point c. Direction must be #vertical or #horizontal." direction == #vertical ifTrue: [^ x @ (c y * 2 - y)]. direction == #horizontal ifTrue: [^ (c x * 2 - x) @ y]. self error: 'unrecognizable direction'! ! !Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! octantOf: otherPoint "Return 1..8 indicating relative direction to otherPoint. 1=ESE, 2=SSE, ... etc. clockwise to 8=ENE" "[Sensor anyButtonPressed] whileFalse: [(Display boundingBox center octantOf: Sensor cursorPoint) printString displayAt: 0@0]" | quad moreHoriz | (x = otherPoint x and: [ y > otherPoint y ]) ifTrue: [ ^ 6 ]. "special case" (y = otherPoint y and: [ x < otherPoint x ]) ifTrue: [ ^ 8 ]. quad := self quadrantOf: otherPoint. moreHoriz := (x - otherPoint x) abs >= (y - otherPoint y) abs. (quad even eqv: moreHoriz) ifTrue: [ ^ quad * 2 ] ifFalse: [ ^ quad * 2 - 1 ]! ! !Point methodsFor: 'transforming' stamp: ''! scaleBy: factor "Answer a Point scaled by factor (an instance of Point)." ^(factor x * x) @ (factor y * y)! ! !Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! normalized "Optimized for speed -- ar 8/26/2001" | r | r := (x * x + (y * y)) sqrt. ^ (x / r) @ (y / r)! ! !Point methodsFor: 'converting' stamp: 'di 11/9/1998 12:44'! adaptToNumber: rcvr andSend: selector "If I am involved in arithmetic with an Integer, convert it to a Point." ^ rcvr@rcvr perform: selector with: self! ! !Point methodsFor: 'point functions' stamp: 'di 12/1/97 12:12'! onLineFrom: p1 to: p2 ^ self onLineFrom: p1 to: p2 within: 2! ! !Point methodsFor: 'converting' stamp: 'di 11/6/1998 13:47'! adaptToString: rcvr andSend: selector "If I am involved in arithmetic with a String, convert it to a Number." ^ rcvr asNumber perform: selector with: self! ! !Point methodsFor: 'point functions' stamp: 'FBS 1/5/2004 13:08'! bearingToPoint: anotherPoint "Return the bearing, in degrees, from the receiver to anotherPoint. Adapted from Playground, where the ultimate provenance of the algorithm was a wild earlier method of Jay Fenton's which I never checked carefully, but the thing has always seemed to work" | deltaX deltaY | deltaX := anotherPoint x - x. deltaY := anotherPoint y - y. deltaX abs < 0.001 ifTrue: [^ deltaY > 0 ifTrue: [180] ifFalse: [0]]. ^ ((deltaX >= 0 ifTrue: [90] ifFalse: [270]) - ((deltaY / deltaX) arcTan negated radiansToDegrees)) rounded ! ! !Point methodsFor: 'point functions' stamp: 'ar 4/18/1999 05:17'! sortsBefore: otherPoint "Return true if the receiver sorts before the other point" ^y = otherPoint y ifTrue:[x <= otherPoint x] ifFalse:[y <= otherPoint y]! ! !Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! dist: aPoint "Answer the distance between aPoint and the receiver." | dx dy | dx := aPoint x - x. dy := aPoint y - y. ^ (dx * dx + (dy * dy)) sqrt! ! !Point methodsFor: 'point functions' stamp: 'StephaneDucasse 7/7/2010 23:38'! sign ^ (x sign @ y sign)! ! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'! + arg "Answer a Point that is the sum of the receiver and arg." arg isPoint ifTrue: [^ (x + arg x) @ (y + arg y)]. ^ arg adaptToPoint: self andSend: #+! ! !Point methodsFor: 'polar coordinates' stamp: 'lr 7/4/2009 10:42'! degrees "Answer the angle the receiver makes with origin in degrees. right is 0; down is 90." | tan theta | x = 0 ifTrue: [ y >= 0 ifTrue: [ ^ 90.0 ] ifFalse: [ ^ 270.0 ] ] ifFalse: [ tan := y asFloat / x asFloat. theta := tan arcTan. x >= 0 ifTrue: [ y >= 0 ifTrue: [ ^ theta radiansToDegrees ] ifFalse: [ ^ 360.0 + theta radiansToDegrees ] ] ifFalse: [ ^ 180.0 + theta radiansToDegrees ] ]! ! !Point methodsFor: 'comparing' stamp: ''! min: aMin max: aMax ^ (self min: aMin) max: aMax! ! !Point methodsFor: 'printing' stamp: 'StephaneDucasse 11/18/2011 22:38'! printOn: aStream "The receiver prints on aStream in terms of infix notation." aStream nextPut: $(. x printOn: aStream. aStream nextPut: $@. (y notNil and: [y negative]) ifTrue: [ "Avoid ambiguous @- construct" aStream space]. y printOn: aStream. aStream nextPut: $).! ! !Point methodsFor: 'truncation and roundoff' stamp: 'wiz 1/11/2006 18:32'! isIntegerPoint ^ x isInteger and: [ y isInteger ] ! ! !Point methodsFor: 'extent functions' stamp: 'wiz 8/9/2005 02:44'! guarded "Return a positive nonzero extent." self max: 1@1 .! ! !Point methodsFor: 'truncation and round off' stamp: 'nice 2/5/2006 16:35'! roundTo: grid "Answer a Point that is the receiver's x and y rounded to grid x and grid y." | gridPoint | gridPoint := grid asPoint. ^(x roundTo: gridPoint x) @ (y roundTo: gridPoint y)! ! !Point methodsFor: 'point functions' stamp: 'nice 3/5/2010 22:39'! fourNeighbors ^ Array with: self + (1 @ 0) with: self + (0 @ 1) with: self + (-1 @ 0) with: self + (0 @ -1) ! ! !Point methodsFor: 'point functions' stamp: 'StephaneDucasse 7/7/2010 23:58'! eightNeighbors ^ { self + (1 @ 0) . self + (1 @ 1) . self + (0 @ 1) . self + (-1 @ 1) . self + (-1 @ 0) . self + (-1 @ -1) . self + (0 @ -1) . self + (1 @ -1)} ! ! !Point methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setX: xValue setY: yValue x := xValue. y := yValue! ! !Point methodsFor: 'printing' stamp: 'ar 7/8/2006 19:15'! storeOn: aStream "x@y printed form is good for storing too" aStream nextPut: $(. self printOn: aStream. aStream nextPut: $). ! ! !Point methodsFor: 'comparing' stamp: ''! min: aPoint "Answer the upper left corner of the rectangle uniquely defined by the receiver and the argument, aPoint." ^ (x min: aPoint x) @ (y min: aPoint y)! ! !Point methodsFor: '*Deprecated30' stamp: 'StephaneDucasse 8/15/2013 18:30'! rect: aPoint "Answer a Rectangle that encompasses the receiver and aPoint. This is the most general infix way to create a rectangle." self deprecated: 'Use rectangle: instead' on: '15 August 2013' in: #Pharo30. ^ self rectangle: aPoint! ! !Point methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/12/2006 10:13'! min "Answer a number that is the minimum of the x and y of the receiver." ^self x min: self y! ! !Point methodsFor: 'transforming' stamp: 'di 4/30/1998 11:16'! adhereTo: aRectangle "If the receiver lies outside aRectangle, return the nearest point on the boundary of the rectangle, otherwise return self." (aRectangle containsPoint: self) ifTrue: [^ self]. ^ ((x max: aRectangle left) min: aRectangle right) @ ((y max: aRectangle top) min: aRectangle bottom)! ! !Point methodsFor: 'interpolating' stamp: 'jsp 3/22/1999 16:31'! interpolateTo: end at: amountDone "Interpolate between the instance and end after the specified amount has been done (0 - 1)." ^ self + ((end - self) * amountDone).! ! !Point methodsFor: 'comparing' stamp: ''! = aPoint self species = aPoint species ifTrue: [^x = aPoint "Refer to the comment in Object|=." x and: [y = aPoint y]] ifFalse: [^false]! ! !Point methodsFor: 'geometry' stamp: 'laza 1/17/2000 15:47'! triangleArea: b with: c "Returns twice the area of the oriented triangle (a, b, c), i.e., the area is positive if the triangle is oriented counterclockwise" ^ b x - self x * (c y - self y) - (b y - self y * (c x - self x))! ! !Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! insideTriangle: p1 with: p2 with: p3 "Return true if the receiver is within the triangle defined by the three coordinates. Note: This method computes the barycentric coordinates for the receiver and tests those coordinates." | p0 b0 b1 b2 b3 | p0 := self. b0 := (p2 x - p1 x) * (p3 y - p1 y) - ((p3 x - p1 x) * (p2 y - p1 y)). b0 isZero ifTrue: [ ^ false ]. "degenerate" b0 := 1.0 / b0. b1 := ((p2 x - p0 x) * (p3 y - p0 y) - ((p3 x - p0 x) * (p2 y - p0 y))) * b0. b2 := ((p3 x - p0 x) * (p1 y - p0 y) - ((p1 x - p0 x) * (p3 y - p0 y))) * b0. b3 := ((p1 x - p0 x) * (p2 y - p0 y) - ((p2 x - p0 x) * (p1 y - p0 y))) * b0. b1 < 0.0 ifTrue: [ ^ false ]. b2 < 0.0 ifTrue: [ ^ false ]. b3 < 0.0 ifTrue: [ ^ false ]. ^ true! ! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'! * arg "Answer a Point that is the product of the receiver and arg." arg isPoint ifTrue: [^ (x * arg x) @ (y * arg y)]. ^ arg adaptToPoint: self andSend: #*! ! !Point methodsFor: 'geometry' stamp: 'laza 1/5/2000 11:50'! to: end sideOf: otherPoint "Returns #left, #right, #center if the otherPoint lies to the left, right or on the line given by the vector from self to end" ^ end - self sideOf: otherPoint - self! ! !Point methodsFor: 'comparing' stamp: ''! <= aPoint "Answer whether the receiver is neither below nor to the right of aPoint." ^x <= aPoint x and: [y <= aPoint y]! ! !Point methodsFor: 'geometry' stamp: 'lr 7/4/2009 10:42'! to: end1 intersects: start2 to: end2 "Returns true if the linesegment from start1 (=self) to end1 intersects with the segment from start2 to end2, otherwise false." | start1 sideStart sideEnd | start1 := self. (((start1 = start2 or: [ end1 = end2 ]) or: [ start1 = end2 ]) or: [ start2 = end1 ]) ifTrue: [ ^ true ]. sideStart := start1 to: end1 sideOf: start2. sideEnd := start1 to: end1 sideOf: end2. sideStart = sideEnd ifTrue: [ ^ false ]. sideStart := start2 to: end2 sideOf: start1. sideEnd := start2 to: end2 sideOf: end1. sideStart = sideEnd ifTrue: [ ^ false ]. ^ true! ! !Point methodsFor: 'converting' stamp: 'di 11/6/1998 13:45'! adaptToCollection: rcvr andSend: selector "If I am involved in arithmetic with a Collection, return a Collection of the results of each element combined with me in that expression." ^ rcvr collect: [:element | element perform: selector with: self]! ! !Point methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/12/2006 10:12'! max "Answer a number that is the maximum of the x and y of the receiver." ^self x max: self y! ! !Point methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setR: rho degrees: degrees | radians | radians := degrees asFloat degreesToRadians. x := rho asFloat * radians cos. y := rho asFloat * radians sin! ! !Point methodsFor: 'truncation and roundoff' stamp: 'nice 2/5/2006 16:43'! ceiling "Answer a Point that is the receiver's x and y ceiling. Answer the receiver if its coordinates are already integral." (x isInteger and: [y isInteger]) ifTrue: [^ self]. ^ x ceiling @ y ceiling ! ! !Point methodsFor: 'point functions' stamp: 'StephaneDucasse 7/7/2010 23:42'! normal "Answer a Point representing the unit vector rotated 90 deg clockwise. For the zero point return -1@0." | n d | n := y negated @ x. (d := (n x * n x + (n y * n y))) = 0 ifTrue: [ ^ -1 @0]. ^n / d sqrt! ! !Point methodsFor: 'converting' stamp: ''! asPoint "Answer the receiver itself." ^self! ! !Point methodsFor: 'accessing' stamp: ''! y "Answer the y coordinate." ^y! ! !Point methodsFor: 'point functions' stamp: 'StephaneDucasse 8/15/2013 18:28'! nearestPointOnLineFrom: p1 to: p2 "This will not give points beyond the endpoints" ^ (self nearestPointAlongLineFrom: p1 to: p2) adhereTo: (p1 rectangle: p2)! ! !Point methodsFor: 'truncation and roundoff' stamp: 'nice 2/5/2006 16:42'! roundDownTo: grid "Answer a Point that is the receiver's x and y rounded to grid x and grid y by lower value (toward negative infinity)." | gridPoint | gridPoint := grid asPoint. ^(x roundDownTo: gridPoint x) @ (y roundDownTo: gridPoint y)! ! !Point methodsFor: 'arithmetic' stamp: ''! abs "Answer a Point whose x and y are the absolute values of the receiver's x and y." ^ x abs @ y abs! ! !Point methodsFor: 'converting' stamp: 'di 11/6/1998 07:45'! isPoint ^ true! ! !Point methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/17/2008 13:36'! angle "Answer the angle in radians between the vectors represented by the receiver and (1, 0) from the origin." ^self y arcTan: self x! ! !Point methodsFor: 'point functions' stamp: 'ar 11/12/1998 01:44'! transposed ^y@x! ! !Point methodsFor: 'arithmetic' stamp: 'TRee 6/3/2004 11:09'! reciprocal " Answer a Point with coordinates that are the reciprocals of mine. " " Method was missing from release. " " 20040301 20:50:35 TRee(Squeak3.6-5429-tree07.38) " ^ x reciprocal @ y reciprocal. ! ! !Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! rotateBy: direction centerAt: c "Answer a Point which is rotated according to direction, about the point c. Direction must be one of #right (CW), #left (CCW) or #pi (180 degrees)." | offset | offset := self - c. direction == #right ifTrue: [ ^ offset y negated @ offset x + c ]. direction == #left ifTrue: [ ^ offset y @ offset x negated + c ]. direction == #pi ifTrue: [ ^ c - offset ]. self error: 'unrecognizable direction'! ! !Point methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/17/2008 13:36'! reflectedAbout: aPoint "Answer a new point that is the reflection of the receiver about the given point." ^(self - aPoint) negated + aPoint! ! !Point methodsFor: 'converting' stamp: ''! corner: aPoint "Answer a Rectangle whose origin is the receiver and whose corner is aPoint. This is one of the infix ways of expressing the creation of a rectangle." ^Rectangle origin: self corner: aPoint! ! !Point methodsFor: 'converting' stamp: ''! asFloatPoint ^ x asFloat @ y asFloat! ! !Point methodsFor: 'converting' stamp: 'wiz 11/25/2004 12:48'! asNonFractionalPoint (x isFraction or: [y isFraction]) ifTrue:[^ x asFloat @ y asFloat]! ! !Point methodsFor: 'truncation and round off' stamp: 'jm 6/3/1998 12:21'! rounded "Answer a Point that is the receiver's x and y rounded. Answer the receiver if its coordinates are already integral." (x isInteger and: [y isInteger]) ifTrue: [^ self]. ^ x rounded @ y rounded ! ! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! / arg "Answer a Point that is the quotient of the receiver and arg." arg isPoint ifTrue: [^ (x / arg x) @ (y / arg y)]. ^ arg adaptToPoint: self andSend: #/! ! !Point methodsFor: 'transforming' stamp: 'lr 7/4/2009 10:42'! rotateBy: angle about: center "Even though Point.theta is measured CW, this rotates with the more conventional CCW interpretateion of angle." | p r theta | p := self - center. r := p r. theta := angle asFloat - p theta. ^ (center x asFloat + (r * theta cos)) @ (center y asFloat - (r * theta sin))! ! !Point methodsFor: 'comparing' stamp: 'Alexandre Bergel 8/2/2010 12:20'! closeTo: aPoint ^ (x closeTo: aPoint x) and: [ y closeTo: aPoint y ]! ! !Point methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitPoint: self ! ! !Point methodsFor: 'point functions' stamp: 'StephaneDucasse 7/7/2010 23:39'! leftRotated "Return the receiver rotated 90 degrees. i.e., self rotateBy: #left centerAt: 0 asPoint. Compare to transposed and normal." ^y @x negated! ! !Point methodsFor: 'truncation and roundoff' stamp: 'nice 2/5/2006 16:43'! floor "Answer a Point that is the receiver's x and y floor. Answer the receiver if its coordinates are already integral." (x isInteger and: [y isInteger]) ifTrue: [^ self]. ^ x floor @ y floor ! ! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! - arg "Answer a Point that is the difference of the receiver and arg." arg isPoint ifTrue: [^ (x - arg x) @ (y - arg y)]. ^ arg adaptToPoint: self andSend: #-! ! !Point methodsFor: 'converting' stamp: 'StephaneDucasse 8/15/2013 18:26'! rectangle: aPoint "Answer a Rectangle that encompasses the receiver and aPoint. This is the most general infix way to create a rectangle." ^ Rectangle origin: (self min: aPoint) corner: (self max: aPoint)! ! !Point methodsFor: 'copying' stamp: 'tk 8/19/1998 16:05'! veryDeepCopyWith: deepCopier "Return self. I am immutable in the Morphic world. Do not record me."! ! !Point methodsFor: 'truncation and round off' stamp: 'jm 5/29/1998 15:53'! truncated "Answer a Point whose x and y coordinates are integers. Answer the receiver if its coordinates are already integral." (x isInteger and: [y isInteger]) ifTrue: [^ self]. ^ x truncated @ y truncated ! ! !Point methodsFor: 'point functions' stamp: 'lr 7/4/2009 10:42'! nearestPointAlongLineFrom: p1 to: p2 "Note this will give points beyond the endpoints. Streamlined by Gerardo Richarte 11/3/97" | x21 y21 t x1 y1 | p1 x = p2 x ifTrue: [ ^ p1 x @ y ]. p1 y = p2 y ifTrue: [ ^ x @ p1 y ]. x1 := p1 x asFloat. y1 := p1 y asFloat. x21 := p2 x asFloat - x1. y21 := p2 y asFloat - y1. t := ((y asFloat - y1) / x21 + ((x asFloat - x1) / y21)) / (x21 / y21 + (y21 / x21)). ^ (x1 + (t * x21)) @ (y1 + (t * y21)) " | old new | Pen new place: 200@100; goto: (old := 500@300). Display reverse: (old extent: 10@10). [Sensor anyButtonPressed] whileFalse: [(new := (Sensor cursorPoint nearestPointAlongLineFrom: 200@100 to: 500@300) ) = old ifFalse: [Display reverse: (old extent: 10@10). Display reverse: ((old := new) extent: 10@10)]] "! ! !Point methodsFor: 'truncation and round off' stamp: 'lr 7/4/2009 10:42'! truncateTo: grid "Answer a Point that is the receiver's x and y truncated to grid x and grid y." | gridPoint | gridPoint := grid asPoint. ^ (x truncateTo: gridPoint x) @ (y truncateTo: gridPoint y)! ! !Point methodsFor: 'comparing' stamp: 'SqR 11/3/2000 17:08'! hash "Hash is reimplemented because = is implemented." ^(x hash hashMultiply + y hash) hashMultiply! ! !Point methodsFor: 'comparing' stamp: ''! > aPoint "Answer whether the receiver is below and to the right of aPoint." ^x > aPoint x and: [y > aPoint y]! ! !Point methodsFor: 'converting' stamp: ''! extent: aPoint "Answer a Rectangle whose origin is the receiver and whose extent is aPoint. This is one of the infix ways of expressing the creation of a rectangle." ^Rectangle origin: self extent: aPoint! ! !Point methodsFor: 'copying' stamp: ''! deepCopy "Implemented here for better performance." ^x deepCopy @ y deepCopy! ! !Point methodsFor: 'truncation and roundoff' stamp: 'nice 2/5/2006 16:41'! roundUpTo: grid "Answer a Point that is the receiver's x and y rounded to grid x and grid y by upper value (toward infinity)." | gridPoint | gridPoint := grid asPoint. ^(x roundUpTo: gridPoint x) @ (y roundUpTo: gridPoint y)! ! !Point methodsFor: 'point functions' stamp: 'StephaneDucasse 7/7/2010 23:40'! fourDirections "Return vertices for a square centered at 0 asPoint with the receiver as first corner. Returns the four rotation of the reciever in counter clockwise order with the receiver appearing last." ^ Array with: self leftRotated with: self negated with: self rightRotated with: self ! ! !Point methodsFor: 'comparing' stamp: ''! max: aPoint "Answer the lower right corner of the rectangle uniquely defined by the receiver and the argument, aPoint." ^ (x max: aPoint x) @ (y max: aPoint y)! ! !Point methodsFor: 'point functions' stamp: 'StephaneDucasse 7/7/2010 23:38'! rightRotated "Return the receiver rotated 90 degrees, i.e. self rotateBy: #right centerAt: 0 asPoint. Compare to transposed and normal." ^y negated @x! ! !Point methodsFor: 'point functions' stamp: 'ar 10/30/1998 03:05'! crossProduct: aPoint "Answer a number that is the cross product of the receiver and the argument, aPoint." ^ (x * aPoint y) - (y * aPoint x)! ! !Point methodsFor: 'point functions' stamp: 'di 9/11/1998 16:22'! dotProduct: aPoint "Answer a number that is the dot product of the receiver and the argument, aPoint. That is, the two points are multipled and the coordinates of the result summed." ^ (x * aPoint x) + (y * aPoint y)! ! !Point methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:48'! isSelfEvaluating ^ self class == Point! ! !Point methodsFor: 'converting' stamp: 'StephaneDucasse 9/7/2013 13:10'! asMargin ^ Margin fromPoint: self.! ! !Point methodsFor: 'testing' stamp: 'ar 10/29/2000 19:02'! isZero ^x isZero and:[y isZero]! ! !Point class methodsFor: '*System-Settings-Browser' stamp: 'alain.plantec 4/21/2009 09:57'! settingInputWidgetForNode: aSettingNode ^ aSettingNode inputWidgetForPoint! ! !Point class methodsFor: 'instance creation' stamp: 'md 12/2/2004 23:44'! x: xInteger y: yInteger "Answer an instance of me with coordinates xInteger and yInteger." ^self basicNew setX: xInteger setY: yInteger! ! !Point class methodsFor: 'instance creation' stamp: 'md 12/2/2004 23:44'! r: rho degrees: degrees "Answer an instance of me with polar coordinates rho and theta." ^self basicNew setR: rho degrees: degrees! ! !PointArray commentStamp: ''! This class stores 32bit Integer points in place. It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.! !PointArray methodsFor: 'converting' stamp: 'NS 5/30/2001 20:54'! asPointArray ^ self! ! !PointArray methodsFor: 'accessing' stamp: ''! bounds | min max | min := max := self at: 1. self do:[:pt| min := min min: pt. max := max max: pt]. ^min corner: max ! ! !PointArray methodsFor: 'accessing' stamp: ''! at: index ^(super at: index * 2 - 1) @ (super at: index * 2)! ! !PointArray methodsFor: 'accessing' stamp: ''! at: index put: aPoint super at: index * 2 - 1 put: aPoint x asInteger. super at: index * 2 put: aPoint y asInteger. ^aPoint! ! !PointArray methodsFor: 'accessing' stamp: ''! defaultElement "Return the default element of the receiver" ^0@0! ! !PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'! size "Return the number of elements in the receiver" ^super size // 2! ! !PointArray class methodsFor: 'instance creation' stamp: 'ar 10/16/1998 00:04'! new: n ^super new: n*2! ! !PointArrayTest commentStamp: 'tbn 3/25/2011 15:06'! SUnit Test for PointArray! !PointArrayTest methodsFor: 'testing' stamp: 'hjo 1/17/2011 10:14'! testAtPut pointArray at: 2 put: -1 @ -1. self assert: 0 @ 0 equals: (pointArray at: 1). self assert: -1 @ -1 equals: (pointArray at: 2) ! ! !PointArrayTest methodsFor: 'testing' stamp: 'hjo 1/17/2011 12:05'! testAtPutInt4 pointArray at: 2 put: 405933 @ -405933. self assert: 405933@ -405933 equals: (pointArray at: 2) ! ! !PointArrayTest methodsFor: 'testing' stamp: 'hjo 1/17/2011 11:59'! testAtPutLargeInteger self should: [pointArray at: 2 put: 123456789012345678901234567890@987654323456787654378989] raise: Error. ! ! !PointArrayTest methodsFor: 'testing' stamp: 'hjo 1/17/2011 10:15'! testDefaultElement self assert: 0@0 equals: pointArray defaultElement ! ! !PointArrayTest methodsFor: 'testing' stamp: 'hjo 1/17/2011 10:15'! testBounds self assert: (0@0 corner: 10@3) equals: pointArray bounds ! ! !PointArrayTest methodsFor: 'testing' stamp: 'hjo 1/17/2011 11:56'! testAtPutFraction pointArray at: 2 put: 1/2 @ 51/5. self assert: 0 @ 10 equals: (pointArray at: 2) ! ! !PointArrayTest methodsFor: 'testing' stamp: 'hjo 1/17/2011 10:16'! testSize self assert: 2 equals: pointArray size ! ! !PointArrayTest methodsFor: 'testing' stamp: 'hjo 1/17/2011 10:13'! testAt self assert: 0@0 equals: (pointArray at: 1). self assert: 10@3 equals: (pointArray at: 2) ! ! !PointArrayTest methodsFor: 'running' stamp: 'hjo 1/15/2011 19:54'! setUp super setUp. pointArray := PointArray with: 0@0 with: 10@3! ! !PointArrayTest methodsFor: 'testing' stamp: 'hjo 1/17/2011 11:54'! testAtPutFloat pointArray at: 2 put: 1.2 @ 5.5. self assert: 1 @ 5 equals: (pointArray at: 2) ! ! !PointTest commentStamp: 'StephaneDucasse 7/7/2010 23:43'! This is the unit test for the class Point. ! !PointTest methodsFor: 'tests - testing' stamp: 'lr 3/7/2010 12:05'! testBearingToPoint self assert: (0 @ 0 bearingToPoint: 0 @ 0) = 0. self assert: (0 @ 0 bearingToPoint: 0 @ -1) = 0. self assert: (0 @ 0 bearingToPoint: 1 @ 0) = 90. self assert: (0 @ 0 bearingToPoint: 0 @ 1) = 180. self assert: (0 @ 0 bearingToPoint: -1 @ 0) = 270. self assert: (0 @ 0 bearingToPoint: 1 @ 1) = 135. self assert: (0 @ 0 bearingToPoint: 0.01 @ 0) = 90. self assert: (0 @ 0 bearingToPoint: -2 @ -3) = 326. self assert: (0 @ 0 bearingToPoint: -0 @ 0) = 0. self assert: (-2 @ -3 bearingToPoint: 0 @ 0) = 146! ! !PointTest methodsFor: 'tests - testing' stamp: 'StephaneDucasse 7/8/2010 00:10'! testRightRotated self assert: (10 @ 20) rightRotated = (-20@10)! ! !PointTest methodsFor: 'tests - testing' stamp: 'sd 6/5/2005 10:16'! testIsZero self assert: (0@0) isZero. self deny: (0@1) isZero. self deny: (1@0) isZero. self deny: (1@1) isZero.! ! !PointTest methodsFor: 'tests - testing' stamp: 'StephaneDucasse 7/7/2010 23:59'! testSign self assert: (-3 @ -2) sign = ( -1@ -1). self assert: (-3 @ 2) sign = ( -1@ 1). self assert: (3 @ -2) sign = ( 1@ -1). self assert: (3 @ 2) sign = ( 1@ 1).! ! !PointTest methodsFor: 'tests - testing' stamp: 'StephaneDucasse 7/7/2010 23:54'! testBasicFourDirections "fourDirections returns the four rotation of the receiver in counter clockwise order with the receiver appearing last." | samples results rejects | self assert: (0@0) fourDirections = {(0@0). (0@0). (0@0). (0@0)}. self assert: (0@0) eightNeighbors = {(1@0). (1@1). (0@1). (-1@1). (-1@0). (-1@ -1). (0@ -1). (1@ -1)}. samples := {(1@0). (1@1). (0@1). (-1@1). (-1@0). (-1@ -1). (0@ -1). (1@ -1)}. results := { {0@ -1 . -1@0 . 0@1 . 1@0} . {1@ -1 . -1@ -1 . -1@1 . 1@1} . {1@0 . 0@ -1 . -1@0 . 0@1} . {1@1 . 1@ -1 . -1@ -1 . -1@1} . {0@1 . 1@0 . 0@ -1 . -1@0} . {-1@1 . 1@1 . 1@ -1 . -1@ -1} . {-1@0 . 0@1 . 1@0 . 0@ -1} . {-1@ -1 . -1@1 . 1@1 . 1@ -1} } . rejects := (1 to: samples size ) reject: [ :each | (samples at: each) fourDirections = (results at: each) ]. self assert: ( rejects isEmpty). ! ! !PointTest methodsFor: 'tests - testing' stamp: 'Alexandre Bergel 8/2/2010 12:22'! testCloseTo | x y | x := 0.00001000001. y := 0.0000100000001. self assert: (x closeTo: 0.00001). self assert: (y closeTo: 0.00001). self assert: (x@y closeTo: (0.00001@0.00001))! ! !PointTest methodsFor: 'tests - testing' stamp: 'StephaneDucasse 7/8/2010 00:09'! testLeftRotated self assert: (10 @ 20) leftRotated = (20@ -10)! ! !PointTest methodsFor: 'tests - testing' stamp: 'nice 3/5/2010 22:39'! testTheta | result dir tan x y | self assert: ((0 @ 1) theta - 90.0 degreesToRadians) abs < 1e-15. self assert: ((0 @ -1) theta - 270.0 degreesToRadians) abs < 1e-15. " See code of old and new theta" x := 1.0 . y := -1.0. tan := y / x . dir := tan arcTan. result := 360.0 degreesToRadians + dir. self assert: ((x @ y) theta - result) abs < 1e-15. x := -1.0. "Don't reuse old results whenyou want numeric precision!!" tan := y / x . dir := tan arcTan. result := 180.0 degreesToRadians + dir. self assert: ((x @ y) theta - result) abs < 1e-15. ! ! !PointerExplorer commentStamp: 'avi 8/21/2004 20:01'! A variant on the ObjectExlorer that works "backwards": like the ObjectExplorer, it shows a tree of objects, but expanding a node won't show the objects which that node references, but rather the objects that reference that node. Its main use is to track down memory leaks: if you want to know why a particular object is still alive, open a PointerExplorer on it and drill down until you find the root object that's referencing it. For example, find all the references to the symbol #zot with: PointerExplorer new openExplorerFor: #zot For the "name" of the object, the PointerExplorer shows each object's identityHash, to allow the user to identify when two similar objects are identical and notice cycles.! !PointerExplorer methodsFor: 'accessing' stamp: 'ab 8/22/2003 18:51'! getList ^Array with: (PointerExplorerWrapper with: rootObject name: rootObject identityHash asString model: self) ! ! !PointerExplorer class methodsFor: 'tools registry' stamp: 'IgorStasenko 2/20/2011 15:08'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools class]" registry register: self as: #pointerExplorer ! ! !PointerExplorerWrapper commentStamp: 'avi 8/21/2004 19:58'! A subclass of ObjectExplorerWrapper for use with PointerExplorer. #contents is overridden to work backwards: it returns wrappers for the objects pointing to item rather than for the objects that item points to.! !PointerExplorerWrapper methodsFor: 'testing' stamp: 'ab 8/22/2003 18:39'! hasContents ^true! ! !PointerExplorerWrapper methodsFor: 'accessing' stamp: 'AndyKellens 6/11/2010 14:15'! contents | objects | objects := item pointersToExcept: (Array with: self with: model). ^(objects reject: [:ea | ea class = self class]) collect: [:ea| self class with: ea name: ea identityHash asString model: item]! ! !PointerFinderTest commentStamp: 'TorstenBergmann 2/4/2014 20:46'! SUnit tests for PointerFinder! !PointerFinderTest methodsFor: 'as yet unclassified' stamp: 'AndyKellens 6/11/2010 14:16'! testBasic1 | myObject myArray | myObject := Object new. myArray := {myObject . myObject}. self assert: (myObject pointersTo) asArray = {myArray}! ! !PointerFinderTest methodsFor: 'as yet unclassified' stamp: 'AndyKellens 6/11/2010 14:17'! testNoPointingObject | myObject | myObject := Object new. self assert: (myObject pointersTo) isEmpty! ! !PointerFinderTest methodsFor: 'as yet unclassified' stamp: 'AndyKellens 6/11/2010 14:17'! testCycle | myObject myArray myArray2 pointingObjects | myObject := Object new. myArray := {myObject . myObject}. myArray2 := {myObject . myArray}. pointingObjects := (myObject pointersTo) asArray. self assert: pointingObjects size = 2. self assert: (pointingObjects includesAllOf: {myArray . myArray2}). "PointerFinder loops in presence of cycles" " myArray at: 1 put: myArray. pointingObjects := (PointerFinder pointersTo: myObject) asArray. self assert: pointingObjects = {myArray}. "! ! !PointerLayout commentStamp: ''! I am the superclass for all layouts with Slots.! !PointerLayout methodsFor: 'extending' stamp: 'ToonVerwaest 4/2/2011 17:31'! extendWeak: newScope ^ WeakLayout new slotScope: newScope! ! !PointerLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/7/2011 12:10'! resolveSlot: aName ^ slotScope atName: aName! ! !PointerLayout methodsFor: 'diff' stamp: 'ToonVerwaest 4/1/2011 02:45'! popSlot: aSlot from: collection collection withIndexDo: [ :slot :index | slot name == aSlot name ifTrue: [ ^ collection removeAt: index ]]. ^ nil! ! !PointerLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/4/2011 13:48'! instanceVariables ^ slotScope visibleSlotNames! ! !PointerLayout methodsFor: 'testing' stamp: 'ToonVerwaest 4/1/2011 01:16'! hasFields ^ slotScope hasFields! ! !PointerLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 01:13'! slotScope ^ slotScope! ! !PointerLayout methodsFor: 'format' stamp: 'ToonVerwaest 4/1/2011 01:33'! instanceSpecification | base | base := self instanceSpecificationBase. ^ self hasFields ifTrue: [ base + 1 ] ifFalse: [ base ]! ! !PointerLayout methodsFor: 'testing' stamp: 'ToonVerwaest 4/1/2011 02:25'! hasSlots ^ slotScope hasSlots! ! !PointerLayout methodsFor: 'extending' stamp: 'CamilloBruni 4/4/2011 15:39'! extend: aScope ^ self species new slotScope: aScope! ! !PointerLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 01:13'! slotScope: anObject slotScope := anObject! ! !PointerLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 01:28'! fieldSize ^ slotScope fieldSize! ! !PointerLayout methodsFor: 'validation' stamp: 'MartinDias 7/8/2013 17:21'! checkIntegrity self checkSanity; checkParentScopes; checkInheritedSlots! ! !PointerLayout methodsFor: 'compatibility' stamp: 'ToonVerwaest 4/1/2011 15:26'! includesName: aName self atName: aName ifAbsent: [ ^ false ]. ^ true! ! !PointerLayout methodsFor: 'reshaping' stamp: 'ToonVerwaest 4/1/2011 17:24'! reshapeTo: aModification | newScope | newScope := slotScope rebase: aModification originalScope to: aModification newScope. ^ aModification newLayout extendAgain: self with: newScope.! ! !PointerLayout methodsFor: 'diff' stamp: 'ToonVerwaest 4/7/2011 11:53'! computeChangesFrom: other in: modification | additions changes removals copies | other hasSlots ifFalse: [ ^ modification additions: self allSlots asArray ]. additions := self allSlots. removals := OrderedCollection new. copies := modification copies. changes := modification changes. other allSlots do: [ :oldSlot | (self popSlot: oldSlot from: additions) ifNil: [ removals add: oldSlot ] ifNotNil: [ :newSlot | newSlot = oldSlot ifTrue: [ copies at: newSlot put: oldSlot ] ifFalse: [ changes at: newSlot put: oldSlot ]]]. modification additions: additions asArray; removals: removals asArray.! ! !PointerLayout methodsFor: 'comparing' stamp: 'MartinDias 4/12/2013 13:24'! hash ^ self class hash bitXor: self slotScope hash! ! !PointerLayout methodsFor: 'testing' stamp: 'CamilloBruni 10/16/2011 20:20'! size ^ slotScope fieldSize! ! !PointerLayout methodsFor: 'compatibility' stamp: 'ToonVerwaest 4/1/2011 14:03'! atName: aName ifAbsent: aBlock ^ slotScope atName: aName ifAbsent: aBlock! ! !PointerLayout methodsFor: 'instance initialization' stamp: 'ToonVerwaest 4/1/2011 01:54'! initializeInstance: anInstance self allSlotsDo: [ :slot | slot initialize: anInstance ]! ! !PointerLayout methodsFor: 'accessing' stamp: 'CamilloBruni 10/16/2011 20:12'! slotAt: index self flag: 'clean..'. ^ self allSlots at: index! ! !PointerLayout methodsFor: 'compatibility' stamp: 'CamilloBruni 4/4/2011 13:20'! atName: aName ^ slotScope atName: aName! ! !PointerLayout methodsFor: 'extending' stamp: 'ToonVerwaest 4/2/2011 17:31'! extendVariable: newScope ^ VariableLayout new slotScope: newScope! ! !PointerLayout methodsFor: 'printing' stamp: 'ToonVerwaest 4/1/2011 01:40'! printSlotDefinitionOn: aStream slotScope printSlotDefinitionOn: aStream! ! !PointerLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/1/2011 02:23'! allSlots ^ slotScope flatten! ! !PointerLayout methodsFor: 'comparing' stamp: 'MartinDias 4/12/2013 13:23'! = other ^ super = other ifFalse: [ false ] ifTrue: [ self slotScope = other slotScope ]! ! !PointerLayout methodsFor: 'validation' stamp: 'MartinDias 7/8/2013 15:52'! checkSanity super checkSanity. self checkSlotNames; checkSlotIndices! ! !PointerLayout methodsFor: 'validation' stamp: 'ToonVerwaest 4/1/2011 02:43'! checkSlotIndices | slots current | slots := slotScope flatten. [ slots size > 1 ] whileTrue: [ current := slots removeFirst. self assert: slots first index = (current index + current size) ]! ! !PointerLayout methodsFor: 'copying' stamp: 'ToonVerwaest 4/2/2011 21:00'! postCopy slotScope := slotScope copy! ! !PointerLayout methodsFor: 'validation' stamp: 'MartinDias 7/8/2013 16:40'! checkInheritedSlots self host superclass ifNil: [ ^ self ]. self host layout ifNil: [ ^ self ]. self assert: (self host superclass layout size <= self host layout size) description: [ (self host name, ' does not inherit all slots from ', self host superclass name) ]. "check that the we have the same slots at the same indices as in the superclass" self host superclass layout allSlots withIndexDo: [ :slot :index| | localSlot | localSlot := (self host layout slotAt: index). self assert: slot = localSlot description: [ 'Slot "', localSlot name, '" index at position ', index asString, ' conflicts with slot "', slot name, '" in ', self host superclass asString ]].! ! !PointerLayout methodsFor: 'reshaping' stamp: 'ToonVerwaest 4/1/2011 03:25'! extendAgain: aLayout with: someScope | result | result := aLayout copy. result slotScope: someScope. ^ result! ! !PointerLayout methodsFor: 'extending' stamp: 'MartinDias 9/5/2013 15:49'! extend "Answer a default layout extending me." ^ self extend: self slotScope extend! ! !PointerLayout methodsFor: 'validation' stamp: 'CamilloBruni 7/17/2013 14:29'! checkParentScopes | parentScope superclassScope | parentScope := self slotScope parentScope. self host superclass ifNil: [ ^ self ]. superclassScope := self host superclass layout slotScope. self assert: parentScope = superclassScope description: 'Parent slot scope is out of sync'! ! !PointerLayout methodsFor: 'accessing' stamp: 'ToonVerwaest 4/4/2011 13:30'! allVisibleSlots ^ slotScope allVisibleSlots! ! !PointerLayout methodsFor: 'validation' stamp: 'MartinDias 7/24/2013 14:07'! checkSlotNames | slots current | slots := slotScope allVisibleSlots. [ slots isEmpty ] whileFalse: [ current := slots removeLast. slots do: [ :other | other name = current name ifTrue: [ DuplicatedSlotName new oldSlot: current; newSlot: other; host: host; signal ]]]! ! !Polygon commentStamp: 'LaurentLaffont 3/31/2011 21:05'! I'm a Polygon PathShape (see PathShape).! !Polygon methodsFor: 'as yet unclassified' stamp: 'gvc 10/31/2006 10:52'! segmentsDo: aBlock "Evaluate the two-argument block with each vertex and its successor." self vertices size < 2 ifTrue: [^self]. super segmentsDo: aBlock. aBlock value: self vertices last value: self vertices first! ! !Polygon methodsFor: 'as yet unclassified' stamp: 'gvc 6/25/2007 14:43'! containsPoint: aPoint "Answer whether the receiver contains the given point." |wind| (self basicContainsPoint: aPoint) ifFalse: [^false]. wind := 0. self segmentsDo: [:p1 :p2 | p1 y <= aPoint y ifTrue: [p2 y = aPoint y ifTrue: [(aPoint directionToLineFrom: p1 to: p2) = 0 ifTrue: [^true]] ifFalse: [(p2 y > aPoint y and: [(aPoint directionToLineFrom: p1 to: p2) > 0]) ifTrue: [wind := wind + 1]]] ifFalse: [p2 y = aPoint y ifTrue: [(aPoint directionToLineFrom: p1 to: p2) = 0 ifTrue: [^true]]. (p2 y < aPoint y and: [(aPoint directionToLineFrom: p1 to: p2) < 0]) ifTrue: [wind := wind - 1]]]. ^wind ~= 0! ! !PolygonMorph commentStamp: 'md 2/24/2006 20:34'! This class implements a morph which can behave as four different objects depending on the the following two facts: - is it OPEN or CLOSED? - is it SEGMENTED or SMOOTHED. 1. The OPEN and SEGMENTED variant looks like polyline. 2. The OPEN and SMOOTHED variant looks like spline (kind of curve) 3. The CLOSED and SEGMENTED variant looks like polygon. This is actually what you get when you do PolygonMorph new openInWorld You get a triangle. See below how to manipulate these objects... 4. The CLOSED and SMOOTHED variant looks like blob (???) Prototypes of this morph can also be found in "Object Catalog". Several (different variants) of this object are among "Basic" morphs. Explore the assiciated morph-menu. It enables you - to toggle showing of "handles". They make it possible to - reposition already existing vertices (by moving yellow handles) - create new vertices (by moving green handles) - delete already existing vertices (by dragging and dropping one yellow handle closely nearby the adjacent yellow handle Handles can be made visible/hidden by shift+leftclicking the morph. This way it is possible to quickly show handles, adjust vertices and then again hide handles. - making closed polygon open, i.e. converting it to a curve (and vice versa) - toggle smoothed/segmented line/outline - set up custom dashing (for line, curves or borders of closed polygons - set up custom arrow-heads (for lines resp. curves) ------------------------------------------------------------------------------------------ Implementation notes: This class combines the old Polygon and Curve classes. The 1-bit fillForm to make display and containment tests reasonably fast. However, this functionality is in the process of being supplanted by balloon capabilities, which should eventually provide anti-aliasing as well. wiz 7/18/2004 21:26 s have made some changes to this class to 1) correct some bugs associated with one vertex polygons. 2) prepare for some enhancements with new curves. 3) add shaping items to menu.! !PolygonMorph methodsFor: 'dashes' stamp: 'StephaneDucasse 12/22/2013 21:38'! borderDashOffset borderDashSpec size < 4 ifTrue: [^0.0]. ^ (borderDashSpec fourth) asFloat! ! !PolygonMorph methodsFor: 'drawing' stamp: 'AlainPlantec 12/19/2009 23:37'! drawArrowOn: aCanvas at: endPoint from: priorPoint "Draw a triangle oriented along the line from priorPoint to endPoint. Answer the wingBase." | pts spec wingBase | pts := self arrowBoundsAt: endPoint from: priorPoint. wingBase := pts size = 4 ifTrue: [pts third] ifFalse: [(pts copyFrom: 2 to: 3) average]. spec := self valueOfProperty: #arrowSpec ifAbsent: [PolygonMorph defaultArrowSpec]. spec x sign = spec y sign ifTrue: [aCanvas drawPolygon: pts fillStyle: borderColor] ifFalse: [aCanvas drawPolygon: pts fillStyle: Color transparent borderWidth: (borderWidth + 1) // 2 borderColor: borderColor]. ^wingBase! ! !PolygonMorph methodsFor: 'drawing' stamp: 'wiz 2/23/2006 19:19'! drawArrowsOn: aCanvas "Answer (possibly modified) endpoints for border drawing" "ArrowForms are computed only upon demand" | array | self hasArrows ifFalse: [^ #() ]. "Nothing to do" array := Array with: vertices first with: vertices last. "Prevent crashes for #raised or #inset borders" borderColor isColor ifFalse: [ ^array ]. (arrows == #forward or: [arrows == #both]) ifTrue: [ array at: 2 put: (self drawArrowOn: aCanvas at: vertices last from: self nextToLastPoint) ]. (arrows == #back or: [arrows == #both]) ifTrue: [ array at: 1 put: (self drawArrowOn: aCanvas at: vertices first from: self nextToFirstPoint) ]. ^array! ! !PolygonMorph methodsFor: 'editing' stamp: 'jannik.laval 2/5/2010 21:40'! addHandles "Put moving handles at the vertices. Put adding handles at edge midpoints. Moving over adjacent vertex and dropping will delete a vertex. " | tri | self removeHandles. handles := OrderedCollection new. tri := Array with: 0 @ -4 with: 4 @ 3 with: -3 @ 3. vertices withIndexDo: [:vertPt :vertIndex | | handle newVert | handle := EllipseMorph newBounds: (Rectangle center: vertPt extent: 8 @ 8) color: (self handleColorAt: vertIndex) . handle on: #mouseMove send: #dragVertex:event:fromHandle: to: self withValue: vertIndex. handle on: #mouseUp send: #dropVertex:event:fromHandle: to: self withValue: vertIndex. handle on: #click send: #clickVertex:event:fromHandle: to: self withValue: vertIndex. self addMorph: handle. handles addLast: handle. (closed or: [1 = vertices size "Give a small polygon a chance to grow. -wiz" or: [vertIndex < vertices size]]) ifTrue: [newVert := PolygonMorph vertices: (tri collect: [:p | p + (vertPt + (vertices atWrap: vertIndex + 1) // 2)]) color: Color green borderWidth: 1 borderColor: Color black. newVert on: #mouseDown send: #newVertex:event:fromHandle: to: self withValue: vertIndex. self addMorph: newVert. handles addLast: newVert]]. self isCurvy ifTrue: [self updateHandles; layoutChanged]. self changed! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nice 1/5/2010 15:59'! closestPointTo: aPoint | closestPoint minDist | closestPoint := minDist := nil. self lineSegmentsDo: [:p1 :p2 | | dist curvePoint | curvePoint := aPoint nearestPointOnLineFrom: p1 to: p2. dist := curvePoint dist: aPoint. (closestPoint isNil or: [dist < minDist]) ifTrue: [closestPoint := curvePoint. minDist := dist]]. ^closestPoint! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:06'! lineBorderColor: aColor self borderColor: aColor! ! !PolygonMorph methodsFor: 'rotate scale and flex' stamp: 'AlainPlantec 5/7/2010 21:26'! prepareForScaling "When scaling from a halo, I can do this without a flex shell" ^ self ! ! !PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 23:15'! drawClippedBorderOn: aCanvas usingEnds: anArray aCanvas clipBy: self bounds during:[:cc| self drawBorderOn: cc usingEnds: anArray].! ! !PolygonMorph methodsFor: 'private' stamp: 'di 9/7/2000 16:17'! getVertices smoothCurve ifFalse: [^ vertices]. "For curves, enumerate the full set of interpolated points" ^ Array streamContents: [:s | self lineSegmentsDo: [:pt1 :pt2 | s nextPut: pt1]]! ! !PolygonMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 12/22/2013 21:59'! initialize super initialize. vertices := Array with: 5 @ 0 with: 20 @ 10 with: 0 @ 20. closed := true. smoothCurve := false. arrows := #none. self computeBounds. self isCurvier ifTrue: [ self beSmoothCurve. self diamondOval]! ! !PolygonMorph methodsFor: 'accessing' stamp: 'dgd 12/11/2003 13:14'! openOrClosePhrase | curveName | curveName := (self isCurve ifTrue: ['curve'] ifFalse: ['polygon']) translated. ^ closed ifTrue: ['make open {1}' translated format: {curveName}] ifFalse: ['make closed {1}' translated format: {curveName}]! ! !PolygonMorph methodsFor: 'drawing' stamp: 'nice 1/5/2010 15:59'! drawDashedBorderOn: aCanvas usingEnds: anArray "Display my border on the canvas. NOTE: mostly copied from drawBorderOn:" | bevel topLeftColor bottomRightColor bigClipRect lineColor segmentOffset | (borderColor isNil or: [borderColor isColor and: [borderColor isTransparent]]) ifTrue: [^ self]. lineColor := borderColor. bevel := false. "Border colors for bevelled effects depend on CW ordering of vertices" borderColor == #raised ifTrue: [topLeftColor := color lighter. bottomRightColor := color darker. bevel := true]. borderColor == #inset ifTrue: [topLeftColor := owner colorForInsets darker. bottomRightColor := owner colorForInsets lighter. bevel := true]. bigClipRect := aCanvas clipRect expandBy: self borderWidth + 1 // 2. segmentOffset := self borderDashOffset. self lineSegmentsDo: [:p1 :p2 | | p2i p1i | p1i := p1 asIntegerPoint. p2i := p2 asIntegerPoint. self hasArrows ifTrue: ["Shorten line ends so as not to interfere with tip of arrow." ((arrows == #back or: [arrows == #both]) and: [p1 = vertices first]) ifTrue: [p1i := anArray first asIntegerPoint]. ((arrows == #forward or: [arrows == #both]) and: [p2 = vertices last]) ifTrue: [p2i := anArray last asIntegerPoint]]. (closed or: ["bigClipRect intersects: (p1i rect: p2i) optimized:" ((p1i min: p2i) max: bigClipRect origin) <= ((p1i max: p2i) min: bigClipRect corner)]) ifTrue: [bevel ifTrue: [lineColor := (p1i quadrantOf: p2i) > 2 ifTrue: [topLeftColor] ifFalse: [bottomRightColor]]. segmentOffset := aCanvas line: p1i to: p2i width: borderWidth color: lineColor dashLength: borderDashSpec first secondColor: borderDashSpec third secondDashLength: borderDashSpec second startingOffset: segmentOffset]]! ! !PolygonMorph methodsFor: 'menu' stamp: 'wiz 12/29/2004 13:53'! addPolyArrowMenuItems: aMenu hand: aHandMorph aMenu addLine. aMenu addWithLabel: '---' enablement: [self isOpen and: [arrows ~~ #none]] action: #makeNoArrows. aMenu addWithLabel: '-->' enablement: [self isOpen and: [arrows ~~ #forward]] action: #makeForwardArrow. aMenu addWithLabel: '<--' enablement: [self isOpen and: [arrows ~~ #back]] action: #makeBackArrow. aMenu addWithLabel: '<->' enablement: [self isOpen and: [arrows ~~ #both]] action: #makeBothArrows. aMenu add: 'customize arrows' translated action: #customizeArrows:. (self hasProperty: #arrowSpec) ifTrue: [aMenu add: 'standard arrows' translated action: #standardArrows]! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:47'! lineWidth ^self borderWidth! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 3/30/2002 12:29'! intersectionsWith: aRectangle "Answer a Set of points where the given Rectangle intersects with me. Ignores arrowForms." | retval | retval := IdentitySet new: 4. (self bounds intersects: aRectangle) ifFalse: [^ retval]. self lineSegmentsDo: [ :lp1 :lp2 | | polySeg | polySeg := LineSegment from: lp1 to: lp2. aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg int | rectSeg := LineSegment from: rp1 to: rp2. int := polySeg intersectionWith: rectSeg. int ifNotNil: [ retval add: int ]. ]. ]. ^retval ! ! !PolygonMorph methodsFor: 'rotate scale and flex' stamp: 'AlainPlantec 5/7/2010 21:26'! prepareForRotating "When rotating from a halo, I can do this without a flex shell" ^ self ! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'nice 1/5/2010 15:59'! lineSegmentsDo: endPointsBlock "Emit a sequence of segment endpoints into endPointsBlock." "Unlike the method this one replaces we expect the curve coefficents not the dirivatives" "Also unlike the replaced method the smooth closed curve does not need an extra vertex. We take care of the extra endpoint here. Just like for segmented curves." | cs x y beginPoint | vertices size < 1 ifTrue: [^ self]. "test too few vertices first" self isCurvy ifFalse: [beginPoint := nil. "smoothCurve ifTrue: [cs := self coefficients]." "some things still depend on smoothCurves having curveState" vertices do: [:vert | beginPoint ifNotNil: [endPointsBlock value: beginPoint value: vert]. beginPoint := vert]. (closed or: [vertices size = 1]) ifTrue: [endPointsBlock value: beginPoint value: vertices first]. ^ self]. "For curves we include all the interpolated sub segments." "self assert: [(vertices size > 2 )]. " cs := self coefficients. beginPoint := (x := cs first first) @ (y := cs fifth first). (closed ifTrue: [1 to: cs first size] ifFalse: [1 to: cs first size - 1]) do: [:i | | t n x3 y3 x1 endPoint x2 y1 y2 | "taylor series coefficients" x1 := cs second at: i. y1 := cs sixth at: i. x2 := cs third at: i. y2 := cs seventh at: i. x3 := cs fourth at: i. y3 := cs eighth at: i. n := cs ninth at: i. "guess n n := 5 max: (x2 abs + y2 abs * 2.0 + (cs third atWrap: i + 1) abs + (cs seventh atWrap: i + 1) abs / 100.0) rounded." 1 to: n - 1 do: [:j | t := j asFloat / n asFloat. endPoint := x3 * t + x2 * t + x1 * t + x @ (y3 * t + y2 * t + y1 * t + y). endPointsBlock value: beginPoint value: endPoint. beginPoint := endPoint]. endPoint := (x := cs first atWrap: i + 1) @ (y := cs fifth atWrap: i + 1). endPointsBlock value: beginPoint value: endPoint. beginPoint := endPoint]! ! !PolygonMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 18:57'! mergeDropThird: mv in: hv from: shared "We are merging two polygons. In this case, they have at least three identical shared vertices. Make sure they are sequential in each, and drop the middle one from vertex lists mv, hv, and shared. First vertices on lists are identical already." "know (mv first = hv first)" | mdrop vv | (shared includes: (mv at: mv size - 2)) ifTrue: [(shared includes: mv last) ifTrue: [mdrop := mv last]] ifFalse: [(shared includes: mv last) ifTrue: [(shared includes: mv second) ifTrue: [mdrop := mv first]]]. (shared includes: (mv third)) ifTrue: [(shared includes: mv second) ifTrue: [mdrop := mv second]]. mdrop ifNil: [^nil]. mv remove: mdrop. hv remove: mdrop. shared remove: mdrop. [shared includes: mv first] whileFalse: ["rotate them" vv := mv removeFirst. mv addLast: vv]. [mv first = hv first] whileFalse: ["rotate him until same shared vertex is first" vv := hv removeFirst. hv addLast: vv]! ! !PolygonMorph methodsFor: 'testing' stamp: 'di 9/9/2000 09:24'! stepTime ^ 100! ! !PolygonMorph methodsFor: 'attachments' stamp: 'nk 2/25/2001 17:19'! lastVertex ^vertices last! ! !PolygonMorph methodsFor: 'shaping' stamp: 'StephaneDucasse 12/22/2013 21:09'! rectangleOval "Set my vertices to an array of corner vertices. Order of vertices is in the tradion of warpblt quads." self setVertices: self bounds corners.! ! !PolygonMorph methodsFor: 'drawing' stamp: 'IgorStasenko 7/18/2011 18:30'! drawOn: aCanvas "Display the receiver, a spline curve, approximated by straight line segments." | array | vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point']. closed ifTrue: [aCanvas drawPolygon: self getVertices fillStyle: self fillStyle ]. array := self drawArrowsOn: aCanvas. self drawClippedBorderOn: aCanvas usingEnds: array. ! ! !PolygonMorph methodsFor: 'cubic support' stamp: 'FernandoOlivero 9/10/2013 10:53'! transform: coefficients toCubicPointPolynomialAt: vIndex "From curve information assemble a 4-array of points representing the coefficents for curve segment between to points. Beginning point is first point in array endpoint is the pointSum of the array. Meant to be sent to newcurves idea of curve coefficents." | transformed | transformed := (1 to: 4) collect: [:i | ((coefficients at: i) at: vIndex) @ ((coefficients at: 4 + i) at: vIndex)]. ^ Cubic withAll: transformed! ! !PolygonMorph methodsFor: 'private' stamp: 'marcus.denker 11/10/2008 10:04'! privateMoveBy: delta super privateMoveBy: delta. vertices := vertices collect: [:p | p + delta]. self arrowForms do: [:f | f offset: f offset + delta]. curveState := nil. "Force recomputation" (self valueOfProperty: #referencePosition) ifNotNil: [:oldPos | self setProperty: #referencePosition toValue: oldPos + delta]! ! !PolygonMorph methodsFor: 'drawing' stamp: 'di 6/24/1998 14:36'! areasRemainingToFill: aRectangle "Could be improved by quick check of inner rectangle" ^ Array with: aRectangle! ! !PolygonMorph methodsFor: 'menu' stamp: 'AlainPlantec 12/19/2009 23:37'! arrowSpec: specPt "Specify a custom arrow for this line. specPt x abs gives the length of the arrow (point to base) in terms of borderWidth. If specPt x is negative, then the base of the arrow will be concave. specPt y abs gives the width of the arrow. The standard arrow is equivalent to arrowSpec: PolygonMorph defaultArrowSpec. See arrowBoundsAt:From: for details." self setProperty: #arrowSpec toValue: specPt. self computeBounds! ! !PolygonMorph methodsFor: 'dashes' stamp: 'nk 2/27/2001 12:11'! dashedBorder ^borderDashSpec "A dash spec is a 3- or 5-element array with { length of normal border color. length of alternate border color. alternate border color. starting offset. amount to add to offset at each step } Starting offset is usually = 0, but changing it moves the dashes along the curve." ! ! !PolygonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 12/22/2013 21:33'! step borderDashSpec ifNil: [^super step]. borderDashSpec size < 5 ifTrue: [^super step]. "Only for dashed lines with creep" borderDashSpec at: 4 put: (borderDashSpec fourth) + borderDashSpec fifth. self changed. ^ super step! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'GuillermoPolito 9/1/2010 18:41'! computeNextToEndPoints | pointAfterFirst pointBeforeLast | pointAfterFirst := nil. self lineSegmentsDo: [:p1 :p2 | pointAfterFirst ifNil: [pointAfterFirst := p2 asIntegerPoint]. pointBeforeLast := p1 asIntegerPoint]. curveState at: 2 put: pointAfterFirst. curveState at: 3 put: pointBeforeLast! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nice 1/5/2010 15:59'! closestSegmentTo: aPoint "Answer the starting index of my (big) segment nearest to aPoint" | closestPoint minDist vertexIndex closestVertexIndex | vertexIndex := 0. closestVertexIndex := 0. closestPoint := minDist := nil. self lineSegmentsDo: [:p1 :p2 | | curvePoint dist | (p1 = (self vertices at: vertexIndex + 1)) ifTrue: [ vertexIndex := vertexIndex + 1 ]. curvePoint := aPoint nearestPointOnLineFrom: p1 to: p2. dist := curvePoint dist: aPoint. (closestPoint isNil or: [dist < minDist]) ifTrue: [closestPoint := curvePoint. minDist := dist. closestVertexIndex := vertexIndex. ]]. ^ closestVertexIndex! ! !PolygonMorph methodsFor: 'private' stamp: 'di 11/21/97 21:29'! lineSegments | lineSegments | lineSegments := OrderedCollection new. self lineSegmentsDo: [:p1 :p2 | lineSegments addLast: (Array with: p1 with: p2)]. ^ lineSegments! ! !PolygonMorph methodsFor: 'geometry' stamp: 'StephaneDucasse 12/22/2013 21:58'! rotationCenter "Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." | refPos | refPos := self valueOfProperty: #referencePosition ifAbsent: [^ 0.5@0.5]. ^ (refPos - self bounds origin) / self bounds extent asFloatPoint! ! !PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! makeNoArrows arrows := #none. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! makeForwardArrow arrows := #forward. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 10/3/2000 07:12'! standardArrows self removeProperty: #arrowSpec. self computeBounds! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:48'! lineWidth: anInteger self borderWidth: (anInteger rounded max: 1)! ! !PolygonMorph methodsFor: 'initialization' stamp: 'di 9/8/2000 09:45'! beStraightSegments smoothCurve == false ifFalse: [smoothCurve := false. self computeBounds]! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'StephaneDucasse 12/22/2013 22:01'! slopes: knots "Choose slopes according to state of polygon" self isCurvy ifFalse: [^ self segmentedSlopesOf: knots ]. ^ (closed and: [self isCurvier]) ifTrue: [ self closedCubicSlopesOf: knots ] ifFalse: [ self naturalCubicSlopesOf: knots ]! ! !PolygonMorph methodsFor: 'geometry' stamp: 'StephaneDucasse 12/22/2013 21:42'! arrowsContainPoint: aPoint "Answer an Array of two Booleans that indicate whether the given point is inside either arrow" | retval f | retval := { false . false }. (super containsPoint: aPoint) ifFalse: [^ retval ]. (closed or: [arrows == #none or: [vertices size < 2]]) ifTrue: [^ retval]. (arrows == #forward or: [arrows == #both]) ifTrue: [ "arrowForms first has end form" f := self arrowForms first. retval at: 2 put: ((f pixelValueAt: aPoint - f offset) > 0) ]. (arrows == #back or: [arrows == #both]) ifTrue: [ "arrowForms last has start form" f := self arrowForms last. retval at: 1 put: ((f pixelValueAt: aPoint - f offset) > 0) ]. ^retval.! ! !PolygonMorph methodsFor: 't-rotating' stamp: ''! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !PolygonMorph methodsFor: 'menu' stamp: 'StephaneDucasse 5/28/2011 13:45'! unrotatedLength "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" vertices size = 2 ifTrue: [^ (vertices second - vertices first) r]. ^ ((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) height! ! !PolygonMorph methodsFor: 'geometry' stamp: 'StephaneDucasse 12/22/2013 21:58'! rotationCenter: aPointOrNil "Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position." | box | aPointOrNil isNil ifTrue: [self removeProperty: #referencePosition] ifFalse: [box := self bounds. self setProperty: #referencePosition toValue: box origin + (aPointOrNil * box extent)] ! ! !PolygonMorph methodsFor: 'attachments' stamp: 'nk 4/18/2001 11:43'! endShapeColor: aColor self borderColor: aColor. self isClosed ifTrue: [ self color: aColor ].! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 4/27/2003 15:39'! nextDuplicateVertexIndex vertices doWithIndex: [:vert :index | ((index between: 2 and: vertices size - 1) and: [| epsilon v1 v2 | v1 := vertices at: index - 1. v2 := vertices at: index + 1. epsilon := ((v1 x - v2 x) abs max: (v1 y - v2 y) abs) // 32 max: 1. vert onLineFrom: v1 to: v2 within: epsilon]) ifTrue: [^ index]]. ^ 0! ! !PolygonMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:57'! handlesShowingPhrase ^ (self showingHandles ifTrue: ['hide handles'] ifFalse: ['show handles']) translated! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:48'! lineColor ^self borderColor! ! !PolygonMorph methodsFor: 'testing' stamp: 'StephaneDucasse 12/19/2011 18:45'! isAnimated borderDashSpec ifNil: [^false]. ^ borderDashSpec size = 5 and: [(borderDashSpec fifth) > 0]! ! !PolygonMorph methodsFor: 'drawing' stamp: 'nice 1/5/2010 15:59'! drawBorderOn: aCanvas usingEnds: anArray "Display my border on the canvas." "NOTE: Much of this code is also copied in drawDashedBorderOn: (should be factored)" | bigClipRect style | borderDashSpec ifNotNil: [^ self drawDashedBorderOn: aCanvas usingEnds: anArray]. style := self borderStyle. bigClipRect := aCanvas clipRect expandBy: self borderWidth + 1 // 2. self lineSegmentsDo: [:p1 :p2 | | p1i p2i | p1i := p1 asIntegerPoint. p2i := p2 asIntegerPoint. self hasArrows ifTrue: ["Shorten line ends so as not to interfere with tip of arrow." ((arrows == #back or: [arrows == #both]) and: [p1 = vertices first]) ifTrue: [p1i := anArray first asIntegerPoint]. ((arrows == #forward or: [arrows == #both]) and: [p2 = vertices last]) ifTrue: [p2i := anArray last asIntegerPoint]]. (closed or: ["bigClipRect intersects: (p1i rect: p2i) optimized:" ((p1i min: p2i) max: bigClipRect origin) <= ((p1i max: p2i) min: bigClipRect corner)]) ifTrue: [style drawLineFrom: p1i to: p2i on: aCanvas]]! ! !PolygonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 12/22/2013 21:35'! borderWidth: anInteger borderColor ifNil: [ borderColor := Color black ]. borderWidth := anInteger max: 0. self computeBounds! ! !PolygonMorph methodsFor: 'geometry' stamp: 'CamilloBruni 8/1/2012 16:28'! reduceVertices "Reduces the vertices size, when 3 vertices are on the same line with a little epsilon." | dup | [ (dup := self nextDuplicateVertexIndex) > 0 ] whileTrue: [ self setVertices: (vertices copyWithoutIndex: dup) ]. ^vertices size.! ! !PolygonMorph methodsFor: 'accessing' stamp: 'sw 9/14/97 18:22'! vertices ^ vertices! ! !PolygonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 12/22/2013 21:36'! midVertices "Return and array of midpoints for this line or closed curve" | midPts nextVertIx tweens | vertices size < 2 ifTrue: [^ vertices]. midPts := OrderedCollection new. nextVertIx := 2. tweens := OrderedCollection new. tweens add: vertices first asIntegerPoint. "guarantee at least two points." self lineSegmentsDo: [:p1 :p2 | tweens addLast: p2 asIntegerPoint. p2 = (vertices atWrap: nextVertIx) ifTrue: ["Found endPoint." midPts addLast: (tweens atWrap: tweens size + 1 // 2) + (tweens at: tweens size // 2 + 1) // 2. tweens := OrderedCollection new. tweens add: p2 asIntegerPoint. "guarantee at least two points." nextVertIx := nextVertIx + 1]]. ^ midPts asArray! ! !PolygonMorph methodsFor: 'shaping' stamp: 'StephaneDucasse 12/22/2013 22:00'! diamondOval "Set my vertices to an array of edge midpoint vertices. Order of vertices is in the tradion of warpblt quads." | b | b := self bounds. self setVertices: { b leftCenter. b bottomCenter. b rightCenter. b topCenter }! ! !PolygonMorph methodsFor: 'cubic support' stamp: 'MarcusDenker 9/13/2013 15:57'! naturalCubicSlopesOf: knots "Sent to knots returns the slopes of a natural cubic curve fit." "We solve the equation for knots with end conditions: 2*b1+b2 = 3(a1 - a0) bN1+2*bN = 3*(aN-aN1) and inbetween: b2+4*b3+b4=3*(a4-a2) where a2 is (knots atWrap: index + 1) etc. and the b's are the slopes . N is the last index (knots size) N1 is N-1. by using row operations to convert the matrix to upper triangular and then back sustitution. The D[i] are the derivatives at the knots." | x gamma delta D n1 | n1 := knots size. n1 < 3 ifTrue: [self error: 'Less than 3 points makes a poor curve']. x := knots. gamma := Array new: n1. delta := Array new: n1. D := Array new: n1. gamma at: 1 put: 1.0 / 2.0. 2 to: n1 - 1 do: [:i | gamma at: i put: 1.0 / (4.0 - (gamma at: i - 1))]. gamma at: n1 put: 1.0 / (2.0 - (gamma at: n1 - 1)). delta at: 1 put: 3.0 * ((x at: 2) - (x at: 1)) * (gamma at: 1). 2 to: n1 - 1 do: [:i | delta at: i put: 3.0 * ((x at: i + 1) - (x at: i - 1)) - (delta at: i - 1) * (gamma at: i)]. delta at: n1 put: 3.0 * ((x at: n1) - (x at: n1 - 1)) - (delta at: n1 - 1) * (gamma at: n1). D at: n1 put: (delta at: n1). (1 to: n1 - 1) reverseDo: [:i | D at: i put: (delta at: i) - ((gamma at: i) * (D at: i + 1))]. ^ D! ! !PolygonMorph methodsFor: 'cubic support' stamp: 'StephaneDucasse 12/22/2013 21:37'! closedCubicSlopesOf: knots "Sent to knots returns the slopes of a closed cubic spline. From the same set of java sources as naturalCubic. This is a smalltalk transliteration of the java code." "from java code NatCubicClosed extends NatCubic solves for the set of equations for all knots: b1+4*b2+b3=3*(a3-a1) where a1 is (knots atWrap: index + 1) etc. and the b's are the slopes . by decomposing the matrix into upper triangular and lower matrices and then back sustitution. See Spath 'Spline Algorithms for Curves and Surfaces' pp 19--21. The D[i] are the derivatives at the knots. " | v w x y z n1 D F G H | n1 := knots size. n1 < 3 ifTrue: [self error: 'Less than 3 points makes a poor curve']. v := Array new: n1. w := Array new: n1. y := Array new: n1. D := Array new: n1. x := knots. z := 1.0 / 4.0. v at: 2 put: z. w at: 2 put: z. y at: 1 put: z * 3.0 * ((x at: 2) - (x at: n1)). H := 4.0. F := 3 * ((x at: 1) - (x at: n1 - 1)). G := 1. 2 to: n1 - 1 do: [:k | z := 1.0 / (4.0 - (v at: k)). v at: k + 1 put: z. w at: k + 1 put: z negated * (w at: k). y at: k put: z * (3.0 * ((x at: k + 1) - (x at: k - 1)) - (y at: k - 1)). H := H - (G * (w at: k)). F := F - (G * (y at: k - 1)). G := (v at: k) negated * G]. H := H - (G + 1 * ((v at: n1) + (w at: n1))). y at: n1 put: F - (G + 1 * (y at: n1 - 1)). D at: n1 put: (y at: n1) / H. D at: n1 - 1 put: (y at: n1 - 1) - ((v at: n1) + (w at: n1) * (D at: n1)). (1 to: n1 - 2) reverseDo: [:k | D at: k put: (y at: k) - ((v at: k + 1) * (D at: k + 1)) - ((w at: k + 1) * (D at: n1))]. ^ D ! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'StephaneDucasse 12/22/2013 22:00'! coefficients curveState ifNotNil: [^ curveState at: 1]. ^ self vertices size < 1 ifTrue: [ self ] ifFalse: [ self coefficientsForMoreThanThreePoints ]. ! ! !PolygonMorph methodsFor: 'editing' stamp: 'StephaneDucasse 6/28/2013 11:25'! dragVertex: ix event: evt fromHandle: handle | p | p := evt cursorPoint. handle position: p - (handle extent // 2). self verticesAt: ix put: p! ! !PolygonMorph methodsFor: 'menu' stamp: 'wiz 12/29/2004 14:42'! addCustomMenuItems: aMenu hand: aHandMorph | | super addCustomMenuItems: aMenu hand: aHandMorph. aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles. vertices size > 2 ifTrue: [ self addPolyLIneCurveMenuItems: aMenu hand: aHandMorph ]. aMenu add: 'specify dashed line' translated action: #specifyDashedLine. "aMenu add: 'use debug border' translated action: #showSegmentsBorderStyle." self isOpen ifTrue: [self addPolyArrowMenuItems: aMenu hand: aHandMorph] ifFalse: [self addPolyShapingMenuItems: aMenu hand: aHandMorph]! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 9/24/2000 09:25'! setRotationCenterFrom: aPoint "Polygons store their referencePosition." self setProperty: #referencePosition toValue: aPoint! ! !PolygonMorph methodsFor: 'accessing' stamp: 'MarcusDenker 4/13/2012 08:49'! cornerStyle: aSymbol "Set the receiver's corner style. But, in this case, do *not*" (extension isNil or: [self cornerStyle == aSymbol]) ifTrue: [^self]. extension cornerStyle: nil. self changed! ! !PolygonMorph methodsFor: 't-rotating' stamp: ''! heading "Return the receiver's heading" ^ self owner ifNil: [self forwardDirection] ifNotNil: [self forwardDirection + self owner degreesOfFlex]! ! !PolygonMorph methodsFor: 'drawing' stamp: 'nk 10/4/2000 12:23'! drawDashedBorderOn: aCanvas self drawDashedBorderOn: aCanvas usingEnds: (Array with: vertices first with: vertices last)! ! !PolygonMorph methodsFor: 'menu' stamp: 'CamilloBruni 8/1/2012 16:15'! removeHandles handles ifNotNil: [ handles do: [:h | h delete]. handles := nil].! ! !PolygonMorph methodsFor: 'private' stamp: 'wiz 2/12/2006 02:58'! curveBounds "Compute the bounds from actual curve traversal, with leeway for borderWidth. Also note the next-to-first and next-to-last points for arrow directions." "wiz - to avoid roundoff errors we return unrounded curvebounds." "we expect our receiver to take responsibility for approriate rounding adjustment." "hint: this is most likely 'self curveBounds expanded' " | pointAfterFirst pointBeforeLast oX oY cX cY | self isCurvy ifFalse: [^ (Rectangle encompassing: vertices) expandBy: borderWidth * 0.5 ]. curveState := nil. "Force recomputation" "curveBounds := vertices first corner: vertices last." pointAfterFirst := nil. self lineSegmentsDo: [:p1 :p2 | pointAfterFirst isNil ifTrue: [pointAfterFirst := p2 floor . oX := cX := p1 x. oY := cY := p1 y. ]. "curveBounds := curveBounds encompass: p2 ." oX:= oX min: p2 x. cX := cX max: p2 x. oY := oY min: p2 y. cY := cY max: p2 y. pointBeforeLast := p1 floor ]. curveState at: 2 put: pointAfterFirst. curveState at: 3 put: pointBeforeLast. ^ ( oX @ oY corner: cX @ cY ) expandBy: borderWidth * 0.5 ! ! !PolygonMorph methodsFor: 'menu' stamp: 'sw 8/19/2000 15:17'! showingHandles ^ handles notNil! ! !PolygonMorph methodsFor: 'private' stamp: 'IgorStasenko 7/18/2011 18:45'! borderForm "A form must be created for drawing the border whenever the borderColor is translucent." | borderCanvas | borderForm ifNotNil: [^ borderForm]. borderCanvas := (Display defaultCanvasClass extent: bounds extent depth: 1) asShadowDrawingCanvas: Color black. borderCanvas translateBy: bounds topLeft negated during:[:tempCanvas| self drawBorderOn: tempCanvas]. borderForm := borderCanvas form. self arrowForms do: [:f | "Eliminate overlap between line and arrowheads if transparent." borderForm copy: f boundingBox from: f to: f offset - self position rule: Form erase]. ^ borderForm! ! !PolygonMorph methodsFor: 'private' stamp: 'StephaneDucasse 10/25/2013 16:18'! computeArrowFormAt: endPoint from: priorPoint "Compute a triangle oriented along the line from priorPoint to endPoint. Then draw those lines in a form and return that form, with appropriate offset" | p1 pts box arrowForm bb origin | pts := self arrowBoundsAt: endPoint from: priorPoint. box := ((pts first rectangle: pts last) encompass: (pts second)) expandBy: 1. arrowForm := Form extent: box extent asIntegerPoint. bb := (BitBlt toForm: arrowForm) sourceForm: nil; fillColor: Color black; combinationRule: Form over; width: 1; height: 1. origin := box topLeft. p1 := pts last - origin. pts do: [:p | bb drawFrom: p1 to: p - origin. p1 := p - origin]. arrowForm convexShapeFill: Color black. ^arrowForm offset: box topLeft! ! !PolygonMorph methodsFor: 'event handling' stamp: 'nk 8/8/2001 12:13'! mouseDown: evt ^ evt shiftPressed ifTrue: [((owner isKindOf: PolygonMorph) and: [owner includesHandle: self]) ifTrue: ["Prevent insertion handles from getting edited" ^ super mouseDown: evt]. self toggleHandles. handles ifNil: [^ self]. vertices withIndexDo: "Check for click-to-drag at handle site" [:vertPt :vertIndex | ((handles at: vertIndex*2-1 ifAbsent: [ ^self ]) containsPoint: evt cursorPoint) ifTrue: ["If clicked near a vertex, jump into drag-vertex action" evt hand newMouseFocus: (handles at: vertIndex*2-1)]]] ifFalse: [super mouseDown: evt]! ! !PolygonMorph methodsFor: 'menu' stamp: 'marcus.denker 11/10/2008 10:04'! customizeArrows: evt | handle origin aHand | aHand := evt ifNil: [self primaryHand] ifNotNil: [evt hand]. origin := aHand position. handle := HandleMorph new forEachPointDo: [:newPoint | handle removeAllMorphs. handle addMorph: (LineMorph from: origin to: newPoint color: Color black width: 1). self arrowSpec: (newPoint - origin) / 5.0] lastPointDo: [:newPoint | handle deleteBalloon. self halo ifNotNil: [:halo | halo addHandles].]. aHand attachMorph: handle. handle setProperty: #helpAtCenter toValue: true. handle showBalloon: 'Move cursor left and right to change arrow length and style. Move it up and down to change width. Click when done.' hand: evt hand. handle startStepping! ! !PolygonMorph methodsFor: 'menu' stamp: 'nk 2/26/2001 20:11'! arrows ^arrows! ! !PolygonMorph methodsFor: 'cubic support' stamp: 'FernandoOlivero 9/10/2013 10:45'! segmentedSlopesOf: knots "For a collection of floats. Returns the slopes for straight segments between vertices." "last slope closes the polygon. Always return same size as self. " ^ knots collectWithIndex: [:x :i | (knots atWrap: i + 1) - x]! ! !PolygonMorph methodsFor: 'private' stamp: 'di 8/31/2000 13:46'! includesHandle: aMorph handles ifNil: [^ false]. ^ handles includes: aMorph! ! !PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'! defaultColor "answer the default color/fill style for the receiver" ^ Color orange! ! !PolygonMorph methodsFor: 'geometry' stamp: 'ar 10/6/2000 15:40'! transformedBy: aTransform self setVertices: (self vertices collect:[:v| aTransform localPointToGlobal: v])! ! !PolygonMorph methodsFor: 'menu' stamp: 'StephaneDucasse 5/28/2011 13:45'! unrotatedLength: aLength "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" vertices size = 2 ifTrue: [^ self arrowLength: aLength]. self setVertices: ((((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) height: aLength) rotationDegrees: 0) vertices! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:38'! isBordered ^false! ! !PolygonMorph methodsFor: 'cubic support' stamp: 'StephaneDucasse 12/22/2013 21:37'! changeInSlopes: slopes of: verts "A message to knots of a spline. Returns an array with the 3rd cubic coeff." "The last nth item is correct iff this is a closed cubic. Presumably that is the only time we care. We always return the same sized array as self." | n slopeChanges | n := verts size. n = slopes size ifFalse: [^ self error: 'vertices and slopes differ in number']. slopeChanges := Array new: n. 1 to: n do: [:i | slopeChanges at: i put: (verts atWrap: i + 1) - (verts at: i) * 3 - ((slopes at: i) * 2) - (slopes atWrap: i + 1)]. ^ slopeChanges! ! !PolygonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 12/22/2013 21:36'! toggleOpenOrClosed "toggle the open/closed status of the receiver" closed ifTrue: [ self makeOpen ] ifFalse: [ self makeClosed ]! ! !PolygonMorph methodsFor: 'editing' stamp: 'StephaneDucasse 12/22/2013 21:40'! handleColorAt: vertIndex "This is a backstop for MixedCurveMorph" ^ Color yellow ! ! !PolygonMorph methodsFor: 'event handling' stamp: 'di 8/20/2000 14:29'! handlesMouseDown: evt ^ (super handlesMouseDown: evt) or: [evt shiftPressed]! ! !PolygonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 12/22/2013 21:35'! fillStyle ^ self isOpen ifTrue: [ self borderColor "easy access to line color from halo"] ifFalse: [ super fillStyle ]! ! !PolygonMorph methodsFor: 't-rotating' stamp: ''! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !PolygonMorph methodsFor: 'private' stamp: 'nk 3/27/2001 21:23'! transformVerticesFrom: oldOwner to: newOwner | oldTransform newTransform world newVertices | world := self world. oldTransform := oldOwner ifNil: [ IdentityTransform new ] ifNotNil: [ oldOwner transformFrom: world ]. newTransform := newOwner ifNil: [ IdentityTransform new ] ifNotNil: [ newOwner transformFrom: world ]. newVertices := vertices collect: [ :ea | newTransform globalPointToLocal: (oldTransform localPointToGlobal: ea) ]. self setVertices: newVertices. ! ! !PolygonMorph methodsFor: 'private' stamp: 'di 9/8/2000 10:36'! setVertices: newVertices vertices := newVertices. handles ifNotNil: [self removeHandles; addHandles]. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 19:23'! arrowLength: aLength "Assumes that I have exactly two vertices" | theta horizontalOffset verticalOffset newTip delta | delta := vertices second - vertices first. theta := delta theta. horizontalOffset := aLength * (theta cos). verticalOffset := aLength * (theta sin). newTip := vertices first + (horizontalOffset @ verticalOffset). self verticesAt: 2 put: newTip! ! !PolygonMorph methodsFor: 'attachments' stamp: 'StephaneDucasse 12/22/2013 21:30'! nudgeForLabel: aRectangle "Try to move the label off me. Prefer labels on the top and right." | i flags nudge | (self bounds intersects: aRectangle) ifFalse: [ ^ 0 @ 0 ]. flags := 0. nudge := 0 @ 0. i := 1. aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg | rectSeg := LineSegment from: rp1 to: rp2. self straightLineSegmentsDo: [ :lp1 :lp2 | | polySeg int | polySeg := LineSegment from: lp1 to: lp2. int := polySeg intersectionWith: rectSeg. int ifNotNil: [ flags := flags bitOr: i ]. ]. i := i * 2. ]. "Now flags has bitflags for which sides" nudge := flags caseOf: { "no intersection" [ 0 ] -> [ 0 @ 0 ]. "2 adjacent sides only" [ 9 ] -> [ 1 @ 1 ]. [ 3 ] -> [ -1 @ 1 ]. [ 12 ] -> [ 1 @ -1 ]. [ 6 ] -> [ -1 @ -1 ]. "2 opposite sides only" [ 10 ] -> [ 0 @ -1 ]. [ 5 ] -> [ 1 @ 0 ]. "only 1 side" [ 8 ] -> [ -1 @ 0 ]. [ 1 ] -> [ 0 @ -1 ]. [ 2 ] -> [ 1 @ 0 ]. [ 4 ] -> [ 0 @ 1 ]. "3 sides" [ 11 ] -> [ 0 @ 1 ]. [ 13 ] -> [ 1 @ 0 ]. [ 14 ] -> [ 0 @ -1 ]. [ 7 ] -> [ -1 @ 0 ]. "all sides" [ 15 ] -> [ 1 @ -1 "move up and to the right" ]. }. ^nudge! ! !PolygonMorph methodsFor: 'geometry' stamp: 'AlainPlantec 5/8/2010 00:03'! rotationDegrees: degrees | flex center | (center := self valueOfProperty: #referencePosition) ifNil: [self setProperty: #referencePosition toValue: (center := self bounds center)]. flex := (MorphicTransform offset: center negated) withAngle: (degrees - self forwardDirection) degreesToRadians. self setVertices: (vertices collect: [:v | (flex transform: v) - flex offset]). self forwardDirection: degrees. ! ! !PolygonMorph methodsFor: 'menu' stamp: 'StephaneDucasse 12/22/2013 21:09'! addPolyShapingMenuItems: aMenu hand: aHandMorph aMenu addLine. aMenu addWithLabel: 'make inscribed diamondOval' enablement: [self isClosed ] action: #diamondOval. aMenu addWithLabel: 'make enclosing rectangleOval' enablement: [self isClosed ] action: #rectangleOval. ! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:48'! lineColor: aColor self borderColor: aColor! ! !PolygonMorph methodsFor: 'geometry' stamp: 'StephaneDucasse 12/22/2013 21:43'! flipVAroundY: centerY "Flip me vertically around the center. If centerY is nil, compute my center of gravity." | cent | cent := centerY ifNil: [ bounds center y ] "average is the center" ifNotNil: [ centerY ]. self setVertices: (vertices collect: [:vv | vv x @ ((vv y - cent) * -1 + cent)]) reversed.! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'nk 4/23/2002 15:48'! straightLineSegmentsDo: endPointsBlock "Emit a sequence of segment endpoints into endPointsBlock. Work the same way regardless of whether I'm curved." | beginPoint | beginPoint := nil. vertices do: [:vert | beginPoint ifNotNil: [endPointsBlock value: beginPoint value: vert]. beginPoint := vert]. (closed or: [vertices size = 1]) ifTrue: [endPointsBlock value: beginPoint value: vertices first].! ! !PolygonMorph methodsFor: 'initialization' stamp: 'StephaneDucasse 12/22/2013 21:10'! vertices: verts color: aColor borderWidth: borderWidthInteger borderColor: anotherColor super initialize. vertices := verts. color := aColor. borderWidth := borderWidthInteger. borderColor := anotherColor. closed := vertices size > 2. arrows := #none. self computeBounds! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'StephaneDucasse 12/22/2013 22:00'! coefficientsForMoreThanThreePoints "Less than three points handled as segments by our lineSegmentsDo:" | verts coefficients vertXs slopeXs vertYs slopeYs bestSegments | verts := self vertices. (self isCurvier not and: [ closed ]) ifTrue: [ verts := verts , verts first asOrderedCollection]. coefficients := { vertXs := verts collect: [:p | p x asFloat]. slopeXs := self slopes: vertXs. self changeInSlopes: slopeXs of: vertXs . self changeOfChangesInSlopes: slopeXs of: vertXs. vertYs := verts collect: [:p | p y asFloat]. slopeYs := self slopes: vertYs. self changeInSlopes: slopeYs of: vertYs. self changeOfChangesInSlopes: slopeYs of: vertYs. Array new: verts size withAll: 12}. bestSegments := (1 to: verts size) collect: [:i | (self transform: coefficients toCubicPointPolynomialAt: i) bestSegments]. coefficients at: 9 put:bestSegments. self isCurvier not & closed ifTrue: [ coefficients := coefficients collect: [:each | each allButLast]]. curveState := {coefficients. nil. nil}. self computeNextToEndPoints. ^ coefficients! ! !PolygonMorph methodsFor: 'testing' stamp: 'di 9/7/2000 16:18'! isCurve ^ smoothCurve! ! !PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! makeBothArrows arrows := #both. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 9/7/2000 15:43'! toggleSmoothing smoothCurve := smoothCurve not. handles ifNotNil: [self removeHandles; addHandles]. self computeBounds! ! !PolygonMorph methodsFor: 'editing' stamp: 'StephaneDucasse 12/22/2013 21:40'! dropVertex: ix event: evt fromHandle: handle "Leave vertex in new position. If dropped ontop another vertex delete this one. Check for too few vertices before deleting. The alternative is not pretty" | p | p := vertices at: ix. (vertices size >= 2 and: ["check for too few vertices before deleting. The alternative is not pretty -wiz" ((vertices atWrap: ix - 1) dist: p) < 3 or: [((vertices atWrap: ix + 1) dist: p) < 3]]) ifTrue: ["Drag a vertex onto its neighbor means delete" self deleteVertexAt: ix .]. evt shiftPressed ifTrue: [self removeHandles] ifFalse: [self addHandles "remove then add to recreate"]! ! !PolygonMorph methodsFor: 'private' stamp: 'wiz 6/22/2004 15:54'! arrowForms "ArrowForms are computed only upon demand" arrowForms ifNotNil: [^ arrowForms]. arrowForms := Array new. self hasArrows ifFalse: [^ arrowForms]. (arrows == #forward or: [arrows == #both]) ifTrue: [arrowForms := arrowForms copyWith: (self computeArrowFormAt: vertices last from: self nextToLastPoint)]. (arrows == #back or: [arrows == #both]) ifTrue: [arrowForms := arrowForms copyWith: (self computeArrowFormAt: vertices first from: self nextToFirstPoint)]. ^ arrowForms! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:31'! toggleHandles handles ifNil: [self addHandles] ifNotNil: [self removeHandles]. ! ! !PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:18'! unrotatedWidth: aWidth "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" self borderWidth: aWidth! ! !PolygonMorph methodsFor: 'menu' stamp: 'StephaneDucasse 12/22/2013 21:34'! addPolyLIneCurveMenuItems: aMenu hand: aHandMorph aMenu addLine; addUpdating: #openOrClosePhrase target: self action: #toggleOpenOrClosed. aMenu addUpdating: #smoothOrSegmentedPhrase target: self action: #toggleSmoothing.! ! !PolygonMorph methodsFor: 'geometry' stamp: 'StephaneDucasse 12/22/2013 21:42'! flipHAroundX: centerX "Flip me horizontally around the center. If centerX is nil, compute my center of gravity." | cent | cent := centerX ifNil: [ bounds center x ] "average is the center" ifNotNil: [ centerX ]. self setVertices: (vertices collect: [ :vv | ((vv x - cent) * -1 + cent) @ vv y ]) reversed.! ! !PolygonMorph methodsFor: 'attachments' stamp: 'nk 2/25/2001 17:19'! firstVertex ^vertices first! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:27'! makeClosed closed := true. handles ifNotNil: [self removeHandles; addHandles]. self computeBounds! ! !PolygonMorph methodsFor: 'testing' stamp: 'StephaneDucasse 12/22/2013 22:01'! hasArrows "Are all the conditions meet for having arrows?" ^ (closed or: [arrows == #none or: [vertices size < 2]]) not! ! !PolygonMorph methodsFor: 'menu' stamp: 'sw 8/19/2000 15:16'! showOrHideHandles self showingHandles ifTrue: [self removeHandles] ifFalse: [self addHandles]! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:07'! lineBorderWidth ^self borderWidth! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 11/16/2004 19:54'! nextToFirstPoint "For arrow direction" self isCurvy ifTrue: [curveState ifNil: [self coefficients]. ^ curveState second] ifFalse: [^ vertices second]! ! !PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! makeBackArrow arrows := #back. self computeBounds! ! !PolygonMorph methodsFor: 'dashes' stamp: 'nk 2/25/2001 17:05'! vertexAt: n ^vertices at: (n min: vertices size).! ! !PolygonMorph methodsFor: 'testing' stamp: 'sw 8/25/2000 22:37'! isClosed ^ closed! ! !PolygonMorph methodsFor: 'private' stamp: 'wiz 2/12/2006 00:04'! computeBounds | oldBounds delta excludeHandles | vertices ifNil: [^ self]. self changed. oldBounds := bounds. self releaseCachedState. bounds := self curveBounds expanded. self arrowForms do: [:f | bounds := bounds merge: (f offset extent: f extent)]. handles ifNotNil: [self updateHandles]. "since we are directly updating bounds, see if any ordinary submorphs exist and move them accordingly" (oldBounds notNil and: [(delta := bounds origin - oldBounds origin) ~= (0@0)]) ifTrue: [ excludeHandles := IdentitySet new. handles ifNotNil: [excludeHandles addAll: handles]. self submorphsDo: [ :each | (excludeHandles includes: each) ifFalse: [ each position: each position + delta ]. ]. ]. self layoutChanged. self changed. ! ! !PolygonMorph methodsFor: 'editing' stamp: 'StephaneDucasse 12/22/2013 21:40'! deleteVertexAt: anIndex "This acts as a backstop for MixedCurveMorph." self setVertices: (vertices copyReplaceFrom: anIndex to: anIndex with: #()). ! ! !PolygonMorph methodsFor: 'editing' stamp: 'nice 1/5/2010 15:59'! updateHandles | newVert | self isCurvy ifTrue: [handles first center: vertices first. handles last center: vertices last. self midVertices withIndexDo: [:midPt :vertIndex | (closed or: [vertIndex < vertices size]) ifTrue: [newVert := handles atWrap: vertIndex * 2. newVert position: midPt - (newVert extent // 2)]]] ifFalse: [vertices withIndexDo: [:vertPt :vertIndex | | oldVert | oldVert := handles at: vertIndex * 2 - 1. oldVert position: vertPt - (oldVert extent // 2). (closed or: [vertIndex < vertices size]) ifTrue: [newVert := handles at: vertIndex * 2. newVert position: vertPt + (vertices atWrap: vertIndex + 1) - newVert extent // 2 + (1 @ -1)]]]! ! !PolygonMorph methodsFor: 'attachments' stamp: 'StephaneDucasse 12/22/2013 21:31'! defaultAttachmentPointSpecs ^{ { #firstVertex } . { #midpoint } . { #lastVertex } }! ! !PolygonMorph methodsFor: 'editing' stamp: 'StephaneDucasse 12/22/2013 21:40'! insertVertexAt: anIndex put: aValue "This serves as a hook and a backstop for MixedCurveMorph." self setVertices: (vertices copyReplaceFrom: anIndex + 1 to: anIndex with: (Array with: aValue)).! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:06'! lineBorderColor ^self borderColor! ! !PolygonMorph methodsFor: 'cubic support' stamp: 'FernandoOlivero 9/10/2013 10:58'! changeOfChangesInSlopes: slopes of: verts "A message to knots of a spline. Returns an array with the 4rd cubic coeff." "The last nth item is correct iff this is a closed cubic. Presumably that is the only time we care. We always return the same sized array as self." | n changes | n := verts size. n = slopes size ifFalse: [^ self error: 'vertices and slopes differ in number']. changes := Array new: n. 1 to: n do: [:i | changes at: i put: (verts at: i) - (verts atWrap: i + 1) * 2 + (slopes at: i) + (slopes atWrap: i + 1)]. ^ changes! ! !PolygonMorph methodsFor: 'testing' stamp: 'jm 11/19/97 18:55'! isOpen ^ closed not! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'dgd 2/22/2003 14:16'! derivs: a first: point1 second: point2 third: point3 "Compute the first, second and third derivitives (in coeffs) from the Points in this Path (coeffs at: 1 and coeffs at: 5)." | len v anArray | len := a size. len < 2 ifTrue: [^self]. len > 2 ifTrue: [v := Array new: len. v at: 1 put: 4.0. anArray := Array new: len. anArray at: 1 put: 6.0 * (a first - (a second * 2.0) + (a third)). 2 to: len - 2 do: [:i | v at: i put: 4.0 - (1.0 / (v at: i - 1)). anArray at: i put: 6.0 * ((a at: i) - ((a at: i + 1) * 2.0) + (a at: i + 2)) - ((anArray at: i - 1) / (v at: i - 1))]. point2 at: len - 1 put: (anArray at: len - 2) / (v at: len - 2). len - 2 to: 2 by: 0 - 1 do: [:i | point2 at: i put: ((anArray at: i - 1) - (point2 at: i + 1)) / (v at: i - 1)]]. point2 at: 1 put: (point2 at: len put: 0.0). 1 to: len - 1 do: [:i | point1 at: i put: (a at: i + 1) - (a at: i) - (((point2 at: i) * 2.0 + (point2 at: i + 1)) / 6.0). point3 at: i put: (point2 at: i + 1) - (point2 at: i)]! ! !PolygonMorph methodsFor: 'testing' stamp: 'wiz 5/2/2004 22:03'! isCurvy "Test for significant curves. Small smoothcurves in practice are straight." ^ smoothCurve and: [vertices size > 2]! ! !PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 23:15'! drawBorderOn: aCanvas self drawClippedBorderOn: aCanvas usingEnds: (Array with: vertices first with: vertices last)! ! !PolygonMorph methodsFor: 'attachments' stamp: 'StephaneDucasse 3/20/2010 11:42'! midpoint "Answer the midpoint along my segments" | middle | middle := self totalLength. middle < 2 ifTrue: [ ^ self center ]. middle := middle / 2. self lineSegmentsDo: [ :a :b | | dist | dist := (a dist: b). middle < dist ifTrue: [ ^(a + ((b - a) * (middle / dist))) asIntegerPoint ]. middle := middle - dist. ]. self error: 'can''t happen'! ! !PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/7/2006 23:35'! clickVertex: ix event: evt fromHandle: handle "Backstop for MixedCurveMorph"! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nice 2/16/2008 02:30'! bounds: newBounds "This method has to be reimplemented since self extent: will also change self bounds origin, super bounds would leave me in wrong position when container is growing. Always change extent first then position" self extent: newBounds extent; position: newBounds topLeft ! ! !PolygonMorph methodsFor: 'caching' stamp: 'StephaneDucasse 12/22/2013 21:32'! releaseCachedState super releaseCachedState. filledForm := nil. arrowForms := nil. borderForm := nil. curveState := nil. (self hasProperty: #flex) ifTrue: [self removeProperty: #flex]. ! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:46'! lineBorderWidth: anInteger self borderWidth: anInteger! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 3/6/2001 16:36'! straighten self setVertices: { vertices first . vertices last }! ! !PolygonMorph methodsFor: 'editing' stamp: 'di 9/8/2000 10:39'! verticesAt: ix put: newPoint vertices at: ix put: newPoint. self computeBounds! ! !PolygonMorph methodsFor: 'attachments' stamp: 'StephaneDucasse 12/22/2013 21:29'! totalLength "Answer the full length of my segments. Can take a long time if I'm curved." | length | length := 0. self lineSegmentsDo: [ :a :b | length := length + (a dist: b) ]. ^ length.! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 4/27/2003 16:15'! intersects: aRectangle "Answer whether any of my segments intersects aRectangle, which is in World coordinates." | rect | (super intersects: aRectangle) ifFalse: [ ^false ]. rect := self bounds: aRectangle in: self world. self lineSegmentsDo: [:p1 :p2 | (rect intersectsLineFrom: p1 to: p2) ifTrue: [^ true]]. ^ false! ! !PolygonMorph methodsFor: 'menu' stamp: 'StephaneDucasse 5/28/2011 13:45'! unrotatedWidth "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" vertices size = 2 ifTrue: [^ self borderWidth]. ^ ((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) width! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'wiz 11/16/2004 19:51'! nextToLastPoint "For arrow direction" self isCurvy ifTrue: [curveState ifNil: [self coefficients]. ^ curveState third] ifFalse: [^ vertices at: vertices size - 1]! ! !PolygonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 12/22/2013 21:33'! smoothOrSegmentedPhrase | lineName | lineName := (closed ifTrue: ['outline'] ifFalse: ['line']) translated. ^ self isCurve ifTrue: [ 'make segmented {1}' translated format: {lineName} ] ifFalse: [ 'make smooth {1}' translated format: {lineName} ].! ! !PolygonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 12/22/2013 21:35'! fillStyle: newColor ^ self isOpen ifTrue: [ self borderColor: newColor asColor "easy access to line color from halo"] ifFalse: [ super fillStyle: newColor ]! ! !PolygonMorph methodsFor: 't-rotating' stamp: ''! setDirectionFrom: aPoint | delta degrees | delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition. degrees := delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! !PolygonMorph methodsFor: 'testing' stamp: 'nk 10/13/2003 18:36'! isLineMorph ^closed not! ! !PolygonMorph methodsFor: 'private' stamp: 'StephaneDucasse 10/25/2013 16:18'! filledForm "Note: The filled form is actually 2 pixels bigger than bounds, and the point corresponding to this morphs' position is at 1@1 in the form. This is due to the details of the fillig routines, at least one of which requires an extra 1-pixel margin around the outside. Computation of the filled form is done only on demand." | bb origin | closed ifFalse: [^ filledForm := nil]. filledForm ifNotNil: [^ filledForm]. filledForm := Form extent: bounds extent+2. "Draw the border..." bb := (BitBlt toForm: filledForm) sourceForm: nil; fillColor: Color black; combinationRule: Form over; width: 1; height: 1. origin := bounds topLeft asIntegerPoint-1. self lineSegmentsDo: [:p1 :p2 | bb drawFrom: p1 asIntegerPoint-origin to: p2 asIntegerPoint-origin]. "Fill it in..." filledForm convexShapeFill: Color black. (borderColor isColor and: [borderColor isTranslucentButNotTransparent]) ifTrue: ["If border is stored as a form, then erase any overlap now." filledForm copy: self borderForm boundingBox from: self borderForm to: 1@1 rule: Form erase]. ^ filledForm! ! !PolygonMorph methodsFor: 'private' stamp: 'AlainPlantec 12/19/2009 23:36'! arrowBoundsAt: endPoint from: priorPoint "Answer a triangle oriented along the line from priorPoint to endPoint." | d v angle wingBase arrowSpec length width | v := endPoint - priorPoint. angle := v degrees. d := borderWidth max: 1. arrowSpec := self valueOfProperty: #arrowSpec ifAbsent: [PolygonMorph defaultArrowSpec]. length := arrowSpec x abs. width := arrowSpec y abs. wingBase := endPoint + (Point r: d * length degrees: angle + 180.0). arrowSpec x >= 0 ifTrue: [^ { endPoint. wingBase + (Point r: d * width degrees: angle + 125.0). wingBase + (Point r: d * width degrees: angle - 125.0) }] ifFalse: ["Negative length means concave base." ^ { endPoint. wingBase + (Point r: d * width degrees: angle + 125.0). wingBase. wingBase + (Point r: d * width degrees: angle - 125.0) }]! ! !PolygonMorph methodsFor: 'testing' stamp: 'ClementBera 9/30/2013 11:03'! containsPoint: aPoint (super containsPoint: aPoint) ifFalse: [^ false]. (closed and: [color isTransparent not]) ifTrue: [ ^ (self filledForm pixelValueAt: aPoint - bounds topLeft + 1) > 0]. self lineSegmentsDo: [ :p1 :p2 | (aPoint onLineFrom: p1 to: p2 within: (3 max: borderWidth+1//2) asFloat) ifTrue: [^ true]]. self arrowForms do: [ :f | (f pixelValueAt: aPoint - f offset) > 0 ifTrue: [^ true]]. ^ false! ! !PolygonMorph methodsFor: 'dashes' stamp: 'di 9/9/2000 09:20'! dashedBorder: dashSpec "A dash spec is a 3- or 5-element array with { length of normal border color. length of alternate border color. alternate border color. starting offset. amount to add to offset at each step } Starting offset is usually = 0, but changing it moves the dashes along the curve." borderDashSpec := dashSpec. self changed! ! !PolygonMorph methodsFor: 'menu' stamp: 'ClementBera 9/30/2013 11:04'! specifyDashedLine | executableSpec newSpec | executableSpec := UIManager default request: 'Enter a dash specification as { major dash length. minor dash length. minor dash color } The major dash will have the normal border color. A blank response will remove the dash specification. [Note: You may give 5 items as, eg, {10. 5. Color white. 0. 3} where the 4th ityem is zero, and the 5th is the number of pixels by which the dashes will move in each step of animation]' translated initialAnswer: '{ 10. 5. Color red }'. executableSpec isEmptyOrNil ifTrue: [^ self stopStepping; dashedBorder: nil]. newSpec := [self class compiler evaluate: executableSpec] ifError: [^ self stopStepping; dashedBorder: nil]. (newSpec first isNumber and: [newSpec second isNumber and: [newSpec third isColor]]) ifFalse: [^ self stopStepping; dashedBorder: nil]. newSpec size = 3 ifTrue: [^ self stopStepping; dashedBorder: newSpec]. (newSpec size = 5 and: [newSpec fourth isNumber and: [newSpec fifth isNumber]]) ifTrue: [^ self dashedBorder: newSpec; startStepping]. ! ! !PolygonMorph methodsFor: 'geometry' stamp: 'di 9/24/2000 08:44'! extent: newExtent "Not really advisable, but we can preserve most of the geometry if we don't shrink things too small." | safeExtent center | center := self referencePosition. safeExtent := newExtent max: 20@20. self setVertices: (vertices collect: [:p | p - center * (safeExtent asFloatPoint / (bounds extent max: 1@1)) + center])! ! !PolygonMorph methodsFor: 'drawing' stamp: 'StephaneDucasse 12/22/2013 21:39'! drawOnFormCanvas: aCanvas "Display the receiver, a spline curve, approximated by straight line segments." vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point']. closed & color isTransparent not ifTrue: [aCanvas stencil: self filledForm at: bounds topLeft - 1 color: color]. (borderColor isColor and: [borderColor isTranslucentButNotTransparent]) ifTrue: [aCanvas stencil: self borderForm at: bounds topLeft color: borderColor] ifFalse: [self drawBorderOn: aCanvas]. self arrowForms do: [:f | aCanvas stencil: f at: f offset color: (borderColor isColor ifTrue: [borderColor] ifFalse: [color])]! ! !PolygonMorph methodsFor: 'attachments' stamp: 'AlainPlantec 5/7/2010 23:35'! endShapeWidth: aWidth | originalWidth originalVertices transform | originalWidth := self valueOfProperty: #originalWidth ifAbsentPut: [ self borderWidth isZero ifFalse: [ self borderWidth ] ifTrue: [ 2 ] ]. self borderWidth: aWidth. originalVertices := self valueOfProperty: #originalVertices ifAbsentPut: [ self vertices collect: [ :ea | (ea - (self referencePosition)) rotateBy: self heading degreesToRadians about: 0@0 ] ]. transform := MorphicTransform offset: 0@0 angle: self heading degreesToRadians scale: originalWidth / aWidth. self setVertices: (originalVertices collect: [ :ea | ((transform transform: ea) + self referencePosition) asIntegerPoint ]). self computeBounds.! ! !PolygonMorph methodsFor: 'initialization' stamp: 'di 9/8/2000 09:44'! beSmoothCurve smoothCurve == true ifFalse: [smoothCurve := true. self computeBounds]! ! !PolygonMorph methodsFor: 'accessing' stamp: 'sw 11/24/1999 14:57'! couldHaveRoundedCorners ^ false! ! !PolygonMorph methodsFor: 'testing' stamp: 'AlainPlantec 12/10/2009 08:25'! isCurvier "Test used by smoothing routines. If true use true closed curve splines for closed curves. If not mimic old stodgy curveMorph curves with one sharp bend.. Override this routine in classes where backward compatability is still needed." ^ self class curvierByDefault ! ! !PolygonMorph methodsFor: 'drawing' stamp: 'MarcusDenker 9/13/2013 16:25'! drawDropShadowOn: aCanvas "Display the receiver, a spline curve, approximated by straight line segments." self assert: [vertices notEmpty] description: 'a polygon must have at least one point'. closed ifTrue: [aCanvas drawPolygon: self getVertices fillStyle: self shadowColor].! ! !PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:25'! newVertex: ix event: evt fromHandle: handle "Insert a new vertex and fix everything up!! Install the drag-handle of the new vertex as recipient of further mouse events." | pt | "(self hasProperty: #noNewVertices) ifFalse: [pt := evt cursorPoint. self setVertices: (vertices copyReplaceFrom: ix + 1 to: ix with: (Array with: pt)). evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1)]" "modified to remove now vestigial test. see PolygonMorph class>>arrowprototype" pt := evt cursorPoint. self insertVertexAt: ix put: pt . evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1)! ! !PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color r: 0.0 g: 0.419 b: 0.935! ! !PolygonMorph methodsFor: 'testing' stamp: 'StephaneDucasse 12/19/2011 18:46'! wantsSteps super wantsSteps ifTrue: [^true]. "For crawling ants effect of dashed line." ^ self isAnimated! ! !PolygonMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 18:56'! merge: aPolygon "Expand myself to enclose the other polygon. (Later merge overlapping or disjoint in a smart way.) For now, the two polygons must share at least two vertices. Shared vertices must come one after the other in each polygon. Polygons must not overlap." | shared mv vv hv xx | shared := vertices select: [:mine | aPolygon vertices includes: mine]. shared size < 2 ifTrue: [^nil]. "not sharing a segment" mv := vertices asOrderedCollection. [shared includes: mv first] whileFalse: ["rotate them" vv := mv removeFirst. mv addLast: vv]. hv := aPolygon vertices asOrderedCollection. [mv first = hv first] whileFalse: ["rotate him until same shared vertex is first" vv := hv removeFirst. hv addLast: vv]. [shared size > 2] whileTrue: [shared := shared asOrderedCollection. (self mergeDropThird: mv in: hv from: shared) ifNil: [^nil]]. "works by side effect on the lists" (mv second) = hv last ifTrue: [mv removeFirst; removeFirst. ^self setVertices: (hv , mv) asArray]. (hv second) = mv last ifTrue: [hv removeFirst; removeFirst. ^self setVertices: (mv , hv) asArray]. (mv second) = (hv second) ifTrue: [hv removeFirst. mv remove: (mv second). xx := mv removeFirst. ^self setVertices: (hv , (Array with: xx) , mv reversed) asArray]. mv last = hv last ifTrue: [mv removeLast. hv removeFirst. ^self setVertices: (mv , hv reversed) asArray]. ^nil! ! !PolygonMorph methodsFor: 'geometry' stamp: 'di 9/24/2000 08:38'! referencePosition "Return the current reference position of the receiver" ^ self valueOfProperty: #referencePosition ifAbsent: [super referencePosition] ! ! !PolygonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 12/22/2013 21:36'! borderColor: aColor super borderColor: aColor. (borderColor isColor and: [borderColor isTranslucentButNotTransparent]) == (aColor isColor and: [aColor isTranslucentButNotTransparent]) ifFalse: ["Need to recompute fillForm and borderForm if translucency of border changes." self releaseCachedState ]! ! !PolygonMorph methodsFor: 'geometry' stamp: 'StephaneDucasse 12/22/2013 21:10'! scale: scaleFactor | flex center ratio | ratio := self scaleFactor / scaleFactor. self borderWidth: ((self borderWidth / ratio) rounded max: 0). center := self referencePosition. flex := (MorphicTransform offset: center negated) withScale: ratio. self setVertices: (vertices collect: [:v | (flex transform: v) - flex offset]). super scale: scaleFactor.! ! !PolygonMorph methodsFor: 'dashes' stamp: 'nk 4/5/2001 16:02'! removeVertex: aVert "Make sure that I am not left with less than two vertices" | newVertices | vertices size < 2 ifTrue: [ ^self ]. newVertices := vertices copyWithout: aVert. newVertices size caseOf: { [1] -> [ newVertices := { newVertices first . newVertices first } ]. [0] -> [ newVertices := { aVert . aVert } ] } otherwise: []. self setVertices: newVertices ! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:27'! makeOpen closed := false. handles ifNotNil: [self removeHandles; addHandles]. self computeBounds! ! !PolygonMorph methodsFor: 'rotate scale and flex' stamp: 'AlainPlantec 5/7/2010 23:53'! rotationDegrees ^ self forwardDirection! ! !PolygonMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 5/5/2010 09:16'! vertices: verts color: c borderWidth: bw borderColor: bc "(PolygonMorph vertices: {261@400. 388@519. 302@595. 222@500. 141@583. 34@444} color: Color blue borderWidth: 3 borderColor: Color black) openInWorld" ^ self basicNew beStraightSegments vertices: verts color: c borderWidth: bw borderColor: bc! ! !PolygonMorph class methodsFor: 'examples' stamp: 'StephaneDucasse 12/22/2013 21:01'! example1 "self example1" ^ (PolygonMorph vertices: {261@400. 388@519. 302@595. 222@500. 141@583. 34@444} color: Color blue borderWidth: 3 borderColor: Color black) openInWorld! ! !PolygonMorph class methodsFor: 'instance creation' stamp: 'MarcusDenker 9/13/2013 16:26'! fromHandFreehand: hand "Let the user draw a polygon, holding the mouse down, and ending by clicking within 5 of the first point..." "self fromHandFreehand: ActiveHand" | p1 poly pN opposite | "wait till guy will press the mouse button" hand captureEventsUntil: [:evt | evt isMouse ifTrue: [ p1 := evt cursorPoint]. (evt isMouse and: [ evt anyButtonPressed ]) ]. opposite := (Display colorAt: p1) negated. opposite = Color transparent ifTrue: [opposite := Color red]. (poly := LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld. hand captureEventsWhile: [:evt | evt isMouse ifTrue:[ pN := evt cursorPoint. (pN dist: poly vertices last) > 3 ifTrue: [poly setVertices: (poly vertices copyWith: pN) ]. evt anyButtonPressed ] ifFalse: [ true ] ]. ^ (poly setVertices: (poly vertices copyWith: p1)) delete ! ! !PolygonMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/22/2013 21:12'! arrowPrototype "Answer an instance of the receiver that will serve as a prototypical arrow" "PolygonMorph arrowPrototype openInWorld" | aa | aa := self new. aa vertices: (Array with: 0@0 with: 40@40) color: Color black borderWidth: 2 borderColor: Color black. aa makeForwardArrow. aa computeBounds. ^ aa! ! !PolygonMorph class methodsFor: 'examples' stamp: 'StephaneDucasse 12/22/2013 21:07'! example2 "self example2" | poly | poly := PolygonMorph vertices: {261@400. 388@519. 302@595. 222@500. 141@583. 34@444} color: Color blue borderWidth: 3 borderColor: Color black. poly beSmoothCurve. poly openInWorld! ! !PolygonMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 08:22'! curvierByDefault ^ CurvierByDefault ifNil: [CurvierByDefault := true]! ! !PolygonMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:38'! defaultArrowSpec ^ 5@4! ! !PolygonMorph class methodsFor: 'examples' stamp: 'StephaneDucasse 12/22/2013 21:06'! example4 "self example4" | poly | poly := (PolygonMorph vertices: {261@400. 388@519. 302@595. 222@500. 141@583. 34@444} color: Color blue borderWidth: 3 borderColor: Color black). poly dashedBorder: { 5 . 5. Color red. 50 . 0 }. poly openInWorld! ! !PolygonMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 08:21'! curvierByDefault: aBoolean CurvierByDefault := aBoolean! ! !PolygonMorph class methodsFor: 'instance creation' stamp: 'MarcusDenker 9/13/2013 16:26'! fromHand: hand "Let the user draw a polygon, clicking at each vertex, and ending by clicking within 5 of the first point..." "self fromHand: ActiveHand" | p1 poly oldVerts pN opposite | "wait till guy will press the mouse button" hand captureEventsUntil: [:evt | evt isMouse ifTrue: [ p1 := evt cursorPoint]. (evt isMouse and: [ evt anyButtonPressed ]) not ]. opposite := (Display colorAt: p1) negated. opposite = Color transparent ifTrue: [opposite := Color red]. (poly := LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld. oldVerts := {p1}. [true] whileTrue: [ "wait till button release" hand captureEventsWhile: [:evt | evt isMouse ifTrue: [ pN := evt cursorPoint. poly setVertices: (oldVerts copyWith: pN). evt anyButtonPressed ] ifFalse: [ true ] ]. (oldVerts size > 1 and: [(pN dist: p1) < 5]) ifFalse: [ oldVerts := poly vertices. "loop till button will be pressed" hand captureEventsUntil: [:evt | evt isMouse ifTrue: [ pN := evt cursorPoint. poly setVertices: (oldVerts copyWith: pN). evt anyButtonPressed ] ifFalse: [ false ]]] ifTrue: [ ^ (poly setVertices: (poly vertices copyWith: p1)) delete]. ]! ! !PolygonMorph class methodsFor: 'examples' stamp: 'StephaneDucasse 12/22/2013 21:06'! example5 "self example5" | poly | poly := (PolygonMorph vertices: {261@400. 388@519. 302@595. 222@500. 141@583. 34@444} color: Color blue borderWidth: 3 borderColor: Color black). poly dashedBorder: { 5 . 5. Color red. 50 . 0 }. poly openInWorld! ! !PolygonMorph class methodsFor: 'examples' stamp: 'StephaneDucasse 12/22/2013 21:07'! example3 "self example3" | poly | poly := PolygonMorph vertices: {261@400. 388@519. 302@595. 222@500. 141@583. 34@444} color: Color blue borderWidth: 3 borderColor: Color black. poly makeOpen. poly openInWorld! ! !PolygonMorphTest commentStamp: 'nice 2/16/2008 02:13'! This class holds tests for PolygonMorph! !PolygonMorphTest methodsFor: 'bounds' stamp: 'IgorStasenko 12/20/2012 14:04'! 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: ((0.1 @ 0.1 corner: 0.9 @ 0.9) asLayoutFrame). 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). ! ! !PolymorphSystemSettings commentStamp: 'LaurentLaffont 3/15/2011 20:46'! I provide settings for Morphic appearance (theme, fonts, colors, ...) that can be found and changed in the Settings browser.! !PolymorphSystemSettings class methodsFor: 'sound' stamp: 'AlainPlantec 1/10/2010 07:54'! soundThemeClass: aSoundThemeClass aSoundThemeClass ifNil: [^ self]. self soundThemeClass ~= aSoundThemeClass ifTrue: [aSoundThemeClass beCurrent]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/28/2009 15:49'! useDesktopGradientFill: aBoolean UseDesktopGradientFill := aBoolean. self desktopBackgroundChanged! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:15'! pharoLogo ^ ImageMorph withForm: self pharoLogoForm! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/28/2009 16:10'! desktopGradientOrigin: aSymbol "#Radial #Vertical or #Horizontal" DesktopGradientOrigin := aSymbol. self desktopBackgroundChanged ! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'SeanDeNigris 11/30/2011 14:31'! morphicWindowsSettingsOn: aBuilder (aBuilder group: #windows) label: 'Windows' translated; description: 'All windows settings' translated; noOrdering; with: [ (aBuilder setting: #windowColor) target: UITheme; targetSelector: #currentSettings; label: 'Window color' translated; description: 'The window color' translated. (aBuilder setting: #preferRoundCorner) target: UITheme; targetSelector: #currentSettings; label: 'Rounded corners' translated; description: 'If true, then windows, menu and other popups will have their corners rounded.' translated. (aBuilder range: #fullscreenMargin) target: SystemWindow; label: 'Fullscreen margin' translated; description: 'Specify the amount of space that is let around a windows when it''s opened fullscreen' translated; range: (-5 to: 100). (aBuilder setting: #fadedBackgroundWindows) target: UITheme; targetSelector: #currentSettings; label: 'Fade background windows' translated; description: 'If true then, background windows appear more "washed out" to distinguish from the active window' translated. (aBuilder setting: #fastDragging) target: UITheme; targetSelector: #currentSettings; label: 'Fast dragging' translated; description: 'If true, window drag will be done by dragging an outline of the window instead of the whole window. It is very convenient on a slow machine' translated. (aBuilder range: #textEntryFieldMinimumWidth) label: 'Text entry dialog width' translated; target: TextEntryDialogWindow; selector: #minimumWidth; range: (100 to: 800); description: 'Set the default text field width of the text entry dialog window' translated] ! ! !PolymorphSystemSettings class methodsFor: 'sound' stamp: 'AlainPlantec 1/10/2010 07:54'! soundThemeClass ^ SoundTheme current class ! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'AlainPlantec 1/10/2010 09:29'! morphicAnimationSettingsOn: aBuilder (aBuilder setting: #useAnimation) label: 'Animation' translated; target: UITheme; targetSelector: #currentAnimationSettings; description: 'If true, some animations will be use when opening and closing windows' translated; noOrdering; with: [ (aBuilder setting: #animateClosing) label: 'Animate closing' translated; description: 'If true, then windows closing is animated' translated. (aBuilder range: #animationDelay) label: 'Delay' translated; description: 'The delay between each step of the window animation in milliseconds.' translated; selector: #delay; range: (0 to: 30). (aBuilder range: #animationNumberOfSteps) label: 'Number of steps' translated; description: 'The number of steps in the window animation.' translated; selector: #numberOfSteps; range: (0 to: 100). ]! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'AlainPlantec 2/25/2011 15:59'! windowPositionStrategySettingsOn: aBuilder (aBuilder pickOne: #usedStrategy) label: 'Window position strategy' translated; parent: #windows; target: RealEstateAgent; domainValues: {'Reverse Stagger' translated -> #staggerFor:initialExtent:world:. 'Cascade' translated -> #cascadeFor:initialExtent:world:. 'Standard' translated -> #standardFor:initialExtent:world:}; description: 'If Reversed Stagger, windows are placed in free space, if Cascade, windows are placed in cascade based on current active window or based on cursor position.' translated.! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/28/2009 15:50'! desktopGradientFillColor: aColor DesktopGradientFillColor := aColor. self desktopBackgroundChanged! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 08:08'! desktopLogoChanged self showDesktopLogo ifFalse: [self setDesktopLogoWith: nil. ^ self]. self desktopLogoFileName ifEmpty: [self setDesktopLogoWith: self pharoLogo] ifNotEmpty: [[self setDesktopLogoWith: (ImageMorph withForm: (Form fromFileNamed: self desktopLogoFileName))] on: Error do: [self setDesktopLogoWith: self pharoLogo]]. ! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 1/10/2010 09:37'! desktopColor ^ DesktopColor ifNil: [DesktopColor := World defaultWorldColor] ! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:15'! desktopLogo ^ DesktopLogo ifNil: [self showDesktopLogo ifTrue: [DesktopLogo := self pharoLogo]] ! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:43'! desktopLogoFileName: aFileName DesktopLogoFileName = aFileName ifTrue: [^ self]. DesktopLogoFileName := aFileName. self desktopLogoChanged ! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/30/2009 06:31'! useDesktopGradientFill ^ UseDesktopGradientFill ifNil: [UseDesktopGradientFill := false]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:04'! pharoLogoForm ^ Form fromBinaryStream: self pharoLogoContents base64Decoded asByteArray readStream! ! !PolymorphSystemSettings class methodsFor: 'sound' stamp: 'StephaneDucasse 8/3/2013 22:55'! soundSettingsOn: aBuilder (aBuilder setting: #soundEnabled) label: 'Sound'; target: SoundSystem; noOrdering; with: [ (aBuilder setting: #useThemeSounds) label: 'Use theme sounds'; target: SoundTheme; with: [ (aBuilder pickOne: #soundThemeClass) label: 'Sound theme' translated; target: self; domainValues: self soundThemeClassChoices]]! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'AlainPlantec 9/17/2011 18:53'! morphicSettingsOn: aBuilder (aBuilder group: #morphic) label: 'Morphic' translated; description: 'All morphic settings' translated; noOrdering; with: [ self morphicWindowsSettingsOn: aBuilder. self morphicMenuSettingsOn: aBuilder. self morphicHaloSettingsOn: aBuilder. self morphicAnimationSettingsOn: aBuilder. (aBuilder setting: #keyboardFocusOnMouseDown) label: 'Keyboard focus on mouse down' translated; target: MorphicModel; description: 'When enabled the mouse button must be clicked within a morph for it to take the keyboard focus.' translated. (aBuilder setting: #mouseOverForKeyboardFocus) label: 'Lose keyboard focus when mouse leave' translated; target: MorphicModel; description: 'When true, the mouse must be over a text or list pane in morphic for keystrokes to be felt, and when the mouse is out over the desktop, the so-called desktop-command-keys, such as cmd-b and cmd-R, are honored. When false, list panes and text panes in morphic remain sensitive to keystrokes even after the mouse is no longer over the pane.' translated. (aBuilder setting: #showTextEditingState) label: 'Show text editing state' translated; target: PluggableTextMorph; description: 'When enabled the editing state of PluggableTextMorphs is shown as a colored inset border.' translated. (aBuilder setting: #balloonHelpEnabled) label: 'Balloon help'; target: UITheme; targetSelector: #currentSettings. (aBuilder setting: #editableStringMorph) label: 'String morphs are editable' translated; target: StringMorph; description: 'If true, editing on StringMorph is possible if the shift key is pressed while selecting the morphs.' translated. (aBuilder setting: #defaultYellowButtonMenuEnabled) label: 'Show default action click menu' translated; target: Morph; description: 'If true, populate an action click menu (default context menu).' translated. (aBuilder setting: #easySelectingWorld) label: 'Easy selection' translated; target: WorldState; description: 'If true, select multiple Morphs in the world by dragging a selection box around them.' translated. (aBuilder setting: #usePolymorphDiffMorph) label: 'Use Polymorph DiffMorph' translated; target: self; default: true ; description: 'If true, whenever requested the Polymorph DiffMorph will be used for comparison of two methods' translated ]. ! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'FernandoOlivero 3/30/2011 16:14'! usePolymorphDiffMorph: aBoolean usePolymorphDiffMorph := aBoolean! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'SvenVanCaekenberghe 4/25/2014 16:09'! pharoLogoContents ^ 'iVBORw0KGgoAAAANSUhEUgAAAWkAAAB5CAYAAAD72tBhAAAKQWlDQ1BJQ0MgUHJvZmlsZQAA SA2dlndUU9kWh8+9N73QEiIgJfQaegkg0jtIFQRRiUmAUAKGhCZ2RAVGFBEpVmRUwAFHhyJj RRQLg4Ji1wnyEFDGwVFEReXdjGsJ7601896a/cdZ39nnt9fZZ+9917oAUPyCBMJ0WAGANKFY FO7rwVwSE8vE9wIYEAEOWAHA4WZmBEf4RALU/L09mZmoSMaz9u4ugGS72yy/UCZz1v9/kSI3 QyQGAApF1TY8fiYX5QKUU7PFGTL/BMr0lSkyhjEyFqEJoqwi48SvbPan5iu7yZiXJuShGlnO Gbw0noy7UN6aJeGjjAShXJgl4GejfAdlvVRJmgDl9yjT0/icTAAwFJlfzOcmoWyJMkUUGe6J 8gIACJTEObxyDov5OWieAHimZ+SKBIlJYqYR15hp5ejIZvrxs1P5YjErlMNN4Yh4TM/0tAyO MBeAr2+WRQElWW2ZaJHtrRzt7VnW5mj5v9nfHn5T/T3IevtV8Sbsz55BjJ5Z32zsrC+9FgD2 JFqbHbO+lVUAtG0GQOXhrE/vIADyBQC03pzzHoZsXpLE4gwnC4vs7GxzAZ9rLivoN/ufgm/K v4Y595nL7vtWO6YXP4EjSRUzZUXlpqemS0TMzAwOl89k/fcQ/+PAOWnNycMsnJ/AF/GF6FVR 6JQJhIlou4U8gViQLmQKhH/V4X8YNicHGX6daxRodV8AfYU5ULhJB8hvPQBDIwMkbj96An3r WxAxCsi+vGitka9zjzJ6/uf6Hwtcim7hTEEiU+b2DI9kciWiLBmj34RswQISkAd0oAo0gS4w AixgDRyAM3AD3iAAhIBIEAOWAy5IAmlABLJBPtgACkEx2AF2g2pwANSBetAEToI2cAZcBFfA DXALDIBHQAqGwUswAd6BaQiC8BAVokGqkBakD5lC1hAbWgh5Q0FQOBQDxUOJkBCSQPnQJqgY KoOqoUNQPfQjdBq6CF2D+qAH0CA0Bv0BfYQRmALTYQ3YALaA2bA7HAhHwsvgRHgVnAcXwNvh SrgWPg63whfhG/AALIVfwpMIQMgIA9FGWAgb8URCkFgkAREha5EipAKpRZqQDqQbuY1IkXHk AwaHoWGYGBbGGeOHWYzhYlZh1mJKMNWYY5hWTBfmNmYQM4H5gqVi1bGmWCesP3YJNhGbjS3E VmCPYFuwl7ED2GHsOxwOx8AZ4hxwfrgYXDJuNa4Etw/XjLuA68MN4SbxeLwq3hTvgg/Bc/Bi fCG+Cn8cfx7fjx/GvyeQCVoEa4IPIZYgJGwkVBAaCOcI/YQRwjRRgahPdCKGEHnEXGIpsY7Y QbxJHCZOkxRJhiQXUiQpmbSBVElqIl0mPSa9IZPJOmRHchhZQF5PriSfIF8lD5I/UJQoJhRP ShxFQtlOOUq5QHlAeUOlUg2obtRYqpi6nVpPvUR9Sn0vR5Mzl/OX48mtk6uRa5Xrl3slT5TX l3eXXy6fJ18hf0r+pvy4AlHBQMFTgaOwVqFG4bTCPYVJRZqilWKIYppiiWKD4jXFUSW8koGS txJPqUDpsNIlpSEaQtOledK4tE20Otpl2jAdRzek+9OT6cX0H+i99AllJWVb5SjlHOUa5bPK UgbCMGD4M1IZpYyTjLuMj/M05rnP48/bNq9pXv+8KZX5Km4qfJUilWaVAZWPqkxVb9UU1Z2q bapP1DBqJmphatlq+9Uuq43Pp893ns+dXzT/5PyH6rC6iXq4+mr1w+o96pMamhq+GhkaVRqX NMY1GZpumsma5ZrnNMe0aFoLtQRa5VrntV4wlZnuzFRmJbOLOaGtru2nLdE+pN2rPa1jqLNY Z6NOs84TXZIuWzdBt1y3U3dCT0svWC9fr1HvoT5Rn62fpL9Hv1t/ysDQINpgi0GbwaihiqG/ YZ5ho+FjI6qRq9Eqo1qjO8Y4Y7ZxivE+41smsImdSZJJjclNU9jU3lRgus+0zwxr5mgmNKs1 u8eisNxZWaxG1qA5wzzIfKN5m/krCz2LWIudFt0WXyztLFMt6ywfWSlZBVhttOqw+sPaxJpr XWN9x4Zq42Ozzqbd5rWtqS3fdr/tfTuaXbDdFrtOu8/2DvYi+yb7MQc9h3iHvQ732HR2KLuE fdUR6+jhuM7xjOMHJ3snsdNJp9+dWc4pzg3OowsMF/AX1C0YctFx4bgccpEuZC6MX3hwodRV 25XjWuv6zE3Xjed2xG3E3dg92f24+ysPSw+RR4vHlKeT5xrPC16Il69XkVevt5L3Yu9q76c+ Oj6JPo0+E752vqt9L/hh/QL9dvrd89fw5/rX+08EOASsCegKpARGBFYHPgsyCRIFdQTDwQHB u4IfL9JfJFzUFgJC/EN2hTwJNQxdFfpzGC4sNKwm7Hm4VXh+eHcELWJFREPEu0iPyNLIR4uN FksWd0bJR8VF1UdNRXtFl0VLl1gsWbPkRoxajCCmPRYfGxV7JHZyqffS3UuH4+ziCuPuLjNc lrPs2nK15anLz66QX8FZcSoeGx8d3xD/iRPCqeVMrvRfuXflBNeTu4f7kufGK+eN8V34ZfyR BJeEsoTRRJfEXYljSa5JFUnjAk9BteB1sl/ygeSplJCUoykzqdGpzWmEtPi000IlYYqwK10z PSe9L8M0ozBDuspp1e5VE6JA0ZFMKHNZZruYjv5M9UiMJJslg1kLs2qy3mdHZZ/KUcwR5vTk muRuyx3J88n7fjVmNXd1Z752/ob8wTXuaw6thdauXNu5Tnddwbrh9b7rj20gbUjZ8MtGy41l G99uit7UUaBRsL5gaLPv5sZCuUJR4b0tzlsObMVsFWzt3WazrWrblyJe0fViy+KK4k8l3JLr 31l9V/ndzPaE7b2l9qX7d+B2CHfc3em681iZYlle2dCu4F2t5czyovK3u1fsvlZhW3FgD2mP ZI+0MqiyvUqvakfVp+qk6oEaj5rmvep7t+2d2sfb17/fbX/TAY0DxQc+HhQcvH/I91BrrUFt xWHc4azDz+ui6rq/Z39ff0TtSPGRz0eFR6XHwo911TvU1zeoN5Q2wo2SxrHjccdv/eD1Q3sT q+lQM6O5+AQ4ITnx4sf4H++eDDzZeYp9qukn/Z/2ttBailqh1tzWibakNml7THvf6YDTnR3O HS0/m/989Iz2mZqzymdLz5HOFZybOZ93fvJCxoXxi4kXhzpXdD66tOTSna6wrt7LgZevXvG5 cqnbvfv8VZerZ645XTt9nX297Yb9jdYeu56WX+x+aem172296XCz/ZbjrY6+BX3n+l37L972 un3ljv+dGwOLBvruLr57/17cPel93v3RB6kPXj/Mejj9aP1j7OOiJwpPKp6qP6391fjXZqm9 9Oyg12DPs4hnj4a4Qy//lfmvT8MFz6nPK0a0RupHrUfPjPmM3Xqx9MXwy4yX0+OFvyn+tveV 0auffnf7vWdiycTwa9HrmT9K3qi+OfrW9m3nZOjk03dp76anit6rvj/2gf2h+2P0x5Hp7E/4 T5WfjT93fAn88ngmbWbm3/eE8/syOll+AAAACXBIWXMAAAsTAAALEwEAmpwYAABAAElEQVR4 AexdB4AU1fl/U3f3KnAcB4gKSL1eUCOKorGiJjEKJiZqjAU4ioLJX03++XuaajQi7SjGaKIx ComJGk2MMTY0Frh+R5EOSq9Xtkz7/77Z22P3bu92d2aOkuyDvZl58973yrz3ve997TGWDMke SPZAsgeSPZDsgWQPJHsg2QPJHkj2QLIHkj2Q7IFkD/wX9oBhGPx/arP/Yxv2n/rBku1K9kCy ByJ7AAiaQ0x6ZOx/zlMSSf/nfMtkS5I98F/ZAxzHGWg4cLWJrP8r+yDZ6OPVAzTIkgPtePV2 spz/oB4gdgd+ff6DmtTRFNomJIOjPWBw5835t7tlZJqbU41UprNUXuKzNMHoI2pGCscbWZoh pXJMdzFD78cxPl3n9BSeEzMZ01MEQRb8qv+O+vLCzY5WKwks2QP/4T0AJN0XTTzcTln/x7RW /I9pyUnSkPzFDUO8XOZ2mecY5zq2BoocOEv4jwHEsOTT5gw1Dv54JgBf63hGesPQRZ7l4CGJ pE+Sb5qsRu/2wOQVK4Tq3SWiSwhIPKdJsuAS/N6A4PL4TXasT/UYblFUfa2qriqC4h+wSxm6 janvVFysdqqZD8+UR+sUf0o/JpG0w5/PYAGXKKQwXdeCeLgDfnzjRjd0TtOE0zqyJW+SPfAf 1gOFC2uHYUdZIjDpPNAnYzfvM07LkALZgihLmDQiSBfenSIDN8kmleORqAM4NSVN0kHHKHog Rz08UD1UurTpc0NRN6iC8G+OqWtAAK03jLfdSBzfZDtF+vUYqXeKVPhkr2bBwroClyzX6Xrn RT7OmoPi1gx1Wu30wmVx5kgmS/bASdsD+YvrTxeYNpbnxQsEURyva9rZQMQZPA98TDtJg3aQ tKeke9pZxhkwT0zkhZ0ph3uabwbjvOmi0NisqO/qmv6BprO6htkFm+KEeNImS1LSTn8ajqVx PLrVKpKmoabxHqerlYSX7IHj1QOn/ezjrKyMtLt43rhDFMThjJPMnaWuHiNcdF2xVx0gdxOl E25vJ5whdfe0KPo4oO1xkiTeKwN5Fy+u3wNe9e9VTZjfeHfednuFnpjcSSTtcL+LzEihYWMr iFwSSdvqwGTm490D+b+qP110s1sEUfo6xCrFJHqhaWB5R2mrAYa5KBDXgxf4HFDac0XBmFu2 fG2Tqqh/M1T9mbq7ixpsFWEhMxaLdLBkmhPNmkTSifZYjPSgg9NsIWkMbI7DcE+GZA+c5D2Q V9EocwP0MS5eeJhx/FeBmJmuBanlRDgXvdpMVMQw2lnUGsuVBDHXkLh7i5c2rmJK4EeCrH2y Zuq4tt6sA5AzCTP747fPSjmm9NRKxmSe6D3AGUZ/A0JDywED3dCVQ5bzJzMme+A49EBBZc1t 7kFCvYsXqzFiv2qAvRdC0Meh+C5FdPCnwakO/euSCBE6ELaBhURg7AJBcr3NcenrSxbX3B8t rRNxQNAy4GTht8+qamCvU9KlS9ZeweuBXjDZFJmma60Gx6n4Kq0qx1pETj3KfOxwzZySw050 sBUYhsBybDI7sFWzUnIyT7IHerkHKir4ouzrvyYI/E95ThhzYlgZx9pI6qzYueIf38I4faOh qvsMnkthBqenynymz5CxI9WywL4mHdc+pnASqUlYCeQJQIjR9CGC6P45NEXu1nX9R3sF3/Nf OERZowzaEaeinpYo6FBLex1JM874KxNJncb5IEDjOAiVYxIvwFaPMzTOp5ctbjiE+081jv3d 61X+vGFu8efOlx4dIgbMEPDkor+MKxaDTtAPxJU0mSjZA8epB3KX1JS4efcfwWgeBvVSTjeO CQGPSxWIyQ1BoBnar6qqNKqc/rCvSXp5Y9ZohT3YLgwCHvDuWjt088HA/orGRu++pmzui7T0 Pikp8sVgJv5UFOWR5gLTzpNpX2wGioLw5CCW9ot+S2q+0zC9+K922gUEDbYnqsxxtueyuUuw U5me8hYuqP0SVB//HVKz6Smto+/wQUktx/xkhDAFcauuqB8D+a2oemvty2zlFBv8iJ5rWrp0 /avMUK7pOVX3b3ksNgEt8LW68qJXuk+VfJPsgePTA6MXVg32SO55oLKmmLSnLQIkjjqbc5cI X41oZJqnrRrPreV0vVHT9FpOYLvhqaPVrysNa2eWbusOIpAkaVdnA0l+0TlN/sL6cbLAXweh 4uVINy6SqAJKRB2APN5WFO3u+lmF9Z3zx3oGzAFIE0DZjuzoexVJl1TW/FgQ3P97ordFZqfS SgzdTEUL+NCJP+b9amVvsEXKlq+rAc+rKNaH7O499En1gOIfXzez6OPu0iTjkz3Q+z1gcPlL G65z8fIL4DeTkUnvFgmiCmO/VVEC+3he/41X0F9sWdu2Y+e88V4rBWOOE24rA6Jc3VP+oiX1 U2DhuFTTlb6RbaQdLakO+u6t7rduPpsSH2GHcgejPDJNd0wY2atIuqyyvho6MMWRK1VPXXY8 3qHzUQwnCNB511Yc8eydufW2i8mc1JEA3tZRkAGWefC8IKlKwFtcO7O40ZEKJYEkeyDBHhj+ izcz+/Q5/SWI2S4J7YLNnSngkCUtEFCCELtPzguQLWnqUd0wZmgB9mb/w/sPRDH37h5AD2+A MIlY2o769iiIL1u2OlPT3b8WBekGXeukv02UPS/Waa1tXwVRt7WH4ojPPaK9vEBP6RJ951xv dyp59CPr0lMz9S/wkYk3c1IGrNzwf6Qf1VTtttoZBRiU9sLw+avPyJQ920icYTXwosvnC/hG Ncwo2GEVRjJfsges9kDR4poLeFH+K29wmaRnTII5zJMjGtNfNhTfKo6X7gHSy42kOi2URuxI ULm6ojxYM7PwdQsQYmYB0iTB3dmo7/s9JiaqG3zs4sXV33LLnv8NaNqY8PbRAmUKHQ39xqrp BSs6w0I5xFoZhd9GlOXv/N7uc6+p4Hnc3oH4uKR+ctIGkw2j6xmSKP6xZGnja3YrmiZK5wsC lHvsBF3VxYCasMK7nSKTeZM9QD1QVFn3f5Kc+h74v5kcHITBjYwCwvnbvrZDo5mqK6LoXg6q zhaCNhGeAf8bTP1a1dSxZ/cWgqb2AGGaO2Qg0Z4nZdAfNau++aw3/j2+rggi0at4UeqQjJqc ALB7BMH1Ykll4wsEOxQAmwzPiGJf2xsImsrpNSSNFo00eVlUykkeSFoNMeyksmXr1pGgxHJ1 ee4KfDTL2WkAw8/XwZojh1ssA0lmTPZAoj1Q8bZYurRhhSRID+lqgEjnLxS/7xtV5XkyBHX9 3Cl9N0LIdjuxOuwEjhegp8w9f4DpOTXTCl+2AyuBvDuRNiOu9OnpmVzelEDdtLy/K17vOdDc e4VDB4SCBn4Mz3M3Fi9t+jDj8Q/7Gc3NJCAcDuS8Gj87Kl2hIqJeew1Jg9c0HitQr7FTorbG RiS5CoVEeXSq5Nk+dn71SCugBIMfH75NsgIDxjBbWFcXjFZAJfMkeyB2DxCCHpjzb9Brk4nA AFLaFfBqpRCaCcWVDZug9rYAfNo0WwZaqAUvyG1QmZtVPX3st7aXF/bII45d6YRS7Efq8bFy tFPEHcRR7ezi6prpY7+q6MoTkBN1ZCeqGsyP8/LS+65bc4TlATn3uuyo15A0NhuXd7TslLkB FWzogsflem/Ego/iW33b25b3eGM/uFocbEdIyvHw5mWwd06Z7kpW9JTugbyKt9PGDR4MJGOM g+onCb6mwfDsAsnNvyHy3O8FnhtuGzkDLkjzrYFD3tG1MwoXHe8OAxIl1mEftC01Rtk037ss HnXlhXN0LXBjOEVNhJhf1bPvfP2LF0csbcyNAdf2695B0pMnw7JEL7ZduxMCgEQlbGCmmF4z 8WnTN21cteBcOhz1myagcaWPloioeew93ov2LhmX7AEne+CsxZ+c7hk4cCuQ8CioL/gDft8N wD27NF7aBCegRfBrTkjbVpFgbygQOC5as2fFWXX3FRHb4USFj1BwXozCh+J9Bx86PC0JCwOq cpHOCRAKhpgDwBOakt2HE2qL51X3Kq7rFSQ99uL7z4YA7dgeIbzFp8A9UcMwLx122DfgF/FW V+SMfPDsbLWZJMj63gM0oJIh2QO91gODK1an9BHTPwVJkAXL3M8DfjVPEeAgV+Behp00kLNd 9ioQGeQr/oA6vnpq3ixWUWEXoK2+ADW9CQCGdAcEi5Eb7zJ64ivXzyx8b3Zxxs/82OqGBygf iGJqyvv5C+rPCo938r5XkLTEYH7poC6lkw2OGxbxngT+7sJFVV+OJw/4VheCVRJP0m7TYEu1 qbHi4g6+WLcJky+SPWCxB8p+sTpz0KD0Wuic5WDbtsqv7h4jauoBDy88S7w2u8HUp+b5A/6A r7hhVkGPhiR2ywrlB5KFe+CYQWtHxtESno3IbdFeUBzy9cXvxtvOlR43NO1CEoCi/zqSw7FU mssl1hY8tnpMR6SDN84jaegc4gy/CeRt6lQPOMeKiZJ7IZTdY1PIunGlnfaaH93QGuzASOZN 9kCsHjD6pPwT+7URqqH8pao8d0LjjItbIIRZAUyUZuoCxwLQw3vwngGG+7Rq14sDGmeX1vaQ 1OlXhID7xwC6Ee8v6ZwG+QgHjsbvs87v6JkQNC5ww8q9yHEDWppmF71vGIGrsNMOS46e07VU OT3tH2xFDHW/sFzx3jqOpPNWNsFlqzTCCVdu6BhQsxLUXqL8zHiox/QixU50BbQtxqoBscvH De9g8KT6wPEWWRtZD/TRVT1pCm69B5M5Y/RA8dK1r2K+jMPcfLdmWsF1lDx/fvV4CKwvi5E1 5msSPOqcUcXxrecfb/YG8AQZkBwGQj0dP1c3lV2P+AK870xwEavDBxhdthFIW4h31DfP4dcR qqYV/R3s+lupzRHB0E4vObCuLhFZVkT+bh7EbuItR6tbBBfryw104ixIcIY3wA/G83Da3aWe HLm849hAaCeOFCRpCFDcIFDvHix9luseLaOJqEWxEu+65TlxonyhAH1KO57BYMnFFCNQFa0O ybhkD9jtgdLFdXNAz1yD8fxh1fS8iQSvDHxUQxb+Qf6VbQUA1gz2r+ppeXGxBm2V1U1mIFlq xA4gVkLEh/C8MzwpvUc8IepB+G0Pe0esjs1hz+Yt0l6ImzOR79nO7+i5elru74oqG86C57z/ C2nAIA9Y8UbuEd+Ax5GkPFo+K3FdkJ8VIOF5PLL3LKbJln1XdMAis1Fd/XNNeeFDHXHRbrC/ GrFwoyzyB9M8YtpN0Mh8FGPGZZc/3FEUOl4S5eFkLls7o3hVR3zYjS5pl8NtalhM4rcafAZo mq8m8ZzJHMke6LkHiiurrxYkz+Mwxjhc9VYjIR9WUFnXVxfEVbyhp9oha4hNhymyb9+GQ9f0 XIvj8xZItR7IEu6CDdop/AXP4c17D3ETWP71fXKG5pzJGZK72estTfd4fhVeO+T9Np53dIeg Q2lr+zc9XHJw7FCBl27pcCIHDS1BkKcXL6rfUjOz4NFQWjtXe5glWskucZLpfyrauwTiBPKr oXOxKUt8hI2zR/rXzTz3AFbyhW1HD2aDub+MmPtOBaI0eE6MOggnr1ghwIjlHDvWWBgMYH7p Wxvu+dIep+qchJPsAeoBHHGVxgnupyDc8uPfhJCbXpkXn8bkH0jUn60gCPDaqJ9n1VudrbK7 yYz5RFT0B/h9G+0bRskmVlSI2VdOn/HwM6+8mDN0UC3U6V4ZNiRrxa9fee/+M6d878+Zl02F y1JDwu8OJCenTO9Svh4DPONVTyu4Fbbzb5E2Syjomh+yLOnHTml8HIMcKsH+9atAObYDqQFp XCBhX67r77uguXpGwTQ4TbqPHCg5EUhnlBOlS6LB2rlzCA4lloZEexd/HEf60a/Fnz6ZMtkD 8fWANED7p8hxOS1+7z2hw1fJRwdQM468sifcN/nQiv+uhtkFpOJ2UgUg2b34EaviWiDey+o+ 3vcyL8sPb9+931Uy6kzmC6is+Kwz2P4jLay1zXdBZp/0j+o371iI9B8h33uJNCbFS762uSPH ND5od6G5JIGjhcJ2cBZJ08GU8Dpld3GmxoIy9TbMKFtrtYU1M/J/qWkaPpITSwZqoWmlEIh0 6a8DLKUfaks2/JYDpO2M+dmfLANIZkz2QJQeIF/Joug6V9G0FevvLl1KSUoWN3xTFOSH7LID yQIP8+v+6hlFT0Up+mSKWvTzZ15+cObkKyedPnAA27m+mk0p7sumn7WDXZfnYelH1rP8nBR2 4xUXC9/48VNT5Ytu7SxYjNmWD+fktpyexl0drsSAhYHxopBTvKTxJzEBxEjgDKnZXkhJll6I wx05OGmJUWyM19j+G7oRe7sRA8y+zzKm5oxtvRbsij4xksbx2hDys6//UgOr+DA8cZrELsCC You3AlZK215Ns6ayBN8LI/p5Uvrxmebg0qRWTvSrgY8Hbm+N11F5eHtO+D1kDEMfeseVmj1A 9GvNvJqeExCbVWPjrBEBTAKbe/MT3rqEKzAUVq+uvYMkF+/HiZ6i0liRF9fkGv3IqnSwDJ/F RAroqno/FXw2rAwNQXi+g3+acG2CGUBpgvbR1wX6c/Msgjhu2TKuKh+JYXPu/GtOY2/fOZCl 767DqYOwhP8y6K3B+9llbe+z+y84l9Wv+hnbrg1iu1Kzfw7bcFOdFoiW8CP9aG6F7smzZwiR k5c92o40v/ytMR8WL2laLPH8DNp5U6CdisALP4R157JNM87ZYUZa+OMokjZ4Ix8ksIVqdM5C c1F/uXNsos87553uza6sfwMddWOo4xKFEUrPwwWpZGhfwnMEkjYEcQqdvWbLSovj9rhFuTVU VqzrkMc/9GSJ6d8URP06gxPyBZ7PMATJ/JY868NUWdHKDuQd0hbXr4aJ73NVM/JfjQXzRL7H MWsTeIm/UtC587QlDadzA/qnkd6lW8zgdW+LH8eIamVLGtv0yrrdQNRN8K64ptkn/n3TvSel z22OVUAqU2HdK1rxwrrJOLTzOvRHse4z+sDzBAThki6kGd6SyvrPdY57Ex5tn8fRTuuifjcs dJ6ljc8Clcp+Tf9W/awiOO0yeJVvega7vqhZEokEFb3vsF8o3jhlZFwLRiKwnU57pqznvV70 T23AvjbRqD2bKWMvZ0xBtfudxthRhRlp5zCtehUb1a8/+8OVLvaulJ8y4VXjTkx3IuxoG34U v634bcZvL370TJok+AyRREPhEuVhqBnMwLtjAQg7Q0j7J1uxItcq0eQoksZxJ7YEaKGWkfcM XvW/GXq2c9U57WmBk260u70DZY/hzUWz0b+UtjZWA1loKZqyeeMsUEizu4dChyikZPqv4Zh8 K9boyzFAiJ6B2h8UFcnnhx5+yhBROlxfURSHQ81+Clyw7oL2yCJB8D+xxqGTkLuvaew3hUtq B/CGcBXP8zegEROxwqXh9Asc8qyROYQJAEcKo5loBpxOUaBYnomgivgJBtQVM1M0VrqsaTfy vg/K8DVFEN9unJq33Uxs80/p4sYRqMtpGm94OJXP4Hg9A58/FYt9Bnq6L8eEvqhVOhaSTFQw E/6X01G/FOjUpwE991ONpgrQaw8lUo3ixY3FILtmY0s2GfnSCD0YPEYc/QNFRnPC/M8Jpwsc /yVoFP2o7Ml12w2f/7aqWUX/Ci9r7IKaEYLHcw0ouer68rzn6V1u/6aLsZhfYkfATXBovAZU 9faNs8eQbvJJHTAvOQhK/+Fd7VY1MdPFtmJ46NVMOLOQOtesO8dlMXHsFGJnMsN7lE0cNHiN KpiGLduQYA9mWVu8jaybXrS3tLJuKpQWloVwAl0xbkYW7sudhDFhiVhyFEnDeX4+qZLZDRBI HATtsMsuHMqv7pE+4HNUGt82gzlNhoUDGf1E7Wj4KMmwM/BNM1pV/6DbrTyKLVzW9F0Qk4sE 3u0OHe9D6wIhLgrBa6cWIsExq099kCCIP+V04b78yvoJDeUFGC/HP5z2s4+zBvRJmQdK7Gb4 5SW5A3BssB5Gp3ETaltHAiQji7iIHYtuDET0ZPBdJ4sABP7fPwHnHrtHj3Ei/wQcvF8tYvED AdteMi545kHWUz3MYAreCIEGA13J6k404jdsGlrxtrtPTs5voG/7Tfq2IVjHbkLfF2/M/8f6 gNOMM1TW1UeOSxJfAmoXVE25n2pGHhrdAv+GbnOXS2QBvtnsuhkFlpBNsJes/zWRbtfsaYgK /cjqMKv9R2rAaYGrf5PC60skFvAxwwd862sFMsZcIRN48jp5eB8o6beZfmgXk3U/83nbPurz 0nXvIK+l0Np89A9pfbJ/hsOoqR5mABHBCTxbjgfS0U44OIqk8QGLEq5BlAygDndn7Gp2ZCsF Hl5L6bLGL/BRBkcpKqEofNoI/e8UiRXQh2bmZE0IVEdiE/Ew7vWOiLAbCH5uFpeLD6OAobQi hxB0WJK4b01JPsdlyLy0unhB9Yya2SVPxp3ZZsKxjzWd6UkzHgUC+wowjYsQLc0RpwLUy0xQ oDAvNUS5oXRpYzX666fV0/MtCWOxawpous9y9YDWB8STuXRxw7WYvfQdcqx8W3iYY762SA2o gvnVX4XLXDj7UldCr/8fVA/Zwy+E6Sz5Io2nWt2kAbXASft4obnXBIX4ZmT9RxaDRHEQbqJn +hHZS3Kf0C+4cgbXL+IJ0zNdd+K3BT+iFGlQ+Nt+eLObX18311AVHGAgMtfXbweixn7tyBHG pWMjpLiZMOJixg58wbQ17zPtUDOyWQ+kXVa8qO4FQZZnhBsJQdNsYGFl7QN15UU/TxS6Y0g6 d1FNHhBORqIV6Jye1HpUVW1w6jBKE77GduCz20bSgBUxyjnSj8Y2yVbQdK1O8laFwyh7bHV/ I83zDNiyV8OXbfgrW/eE6LHCS5InbTmU7bdC2f5NWwBjZB769BZ3pretHFTzr2jWQS0pRg57 r8Oo7BL03R9Llqx9V/MHptbdU0SWZvEHDnzgiC8df9bgEOFiIunSJXVT4Qh/qZ3vC4zlX39f 6RfhtZNcrnvBdtEUVf0FxY+ZVz0UOOwm89uHJ0zwnuNEpqj+p2pnjAM5ai+gLkT50pAg5Es/ 6m0ZP+LZEXKld8ROOQjqnRCw5WCUDeaPCB6MPJmJU77DWvxu1vL2G0xMAaryyMyTV8Rafv8s 85SewzKvvIOletJOM1ZNd6Ncy6u0wvl+IhgiWRxSO8xg6AqTRXf5iAWfPU52HaH4eK6OIWmR eIw2TaODFeYZeIHvx1P5eNOA/RSIZPHHmzMyHbaQHZ1uvpHkEobOtxN0nvuUTR3XAQTU83Uc Lz+Nj5ppZwJ3XyeY8Kp+Ug/6R+HC2uF1JFTqhUAeweRA4DVYAQ0n5GwZ51msG00KTLSL5BRX fdHi+t/goOFp8YLCWuaJ/NDx5gymgzyJEE+3oWRJw5OgrO6w+30hNN4WXkjugsYSHAM3ARTc hrqZhdWkMup2iy8jDgukvS+Avc8eOO1/ILw8G/emkBzfx16lYlRgWUrKoOe2HJojs72e02+4 nckH/azp2Xksc9AI2D0cZoc+q2EF94xgR0aeyzb//jnmSk9lWWPP+0HhWbll6K8lqN+qGEVE fd0445zdhYubZsqisPgYK5Q01tQhqZI+CZn+HDVjN5E9DqZu8kSNxikOXwmjZKKmiSfSwK5F bg38M5608aZB9wT3w/Fm6CYdGA4HIl9p0QSJkUl6ejJxvvG3UBJoMDwm8sJLOhB0KK63roSE BJf0AmavHXwUtXrYxs+R01PXYlACQdsihKLCjzsSiAlsBIhKxKmlS5vqyhbWFcSTF+zyCLZW PHniTVOytOFXIGbusKsGZ5bHcRFI2iXpy4kw9TNlLog4oyDrmlGS4Mq1u4MhuQkEuQ/G28ZY 6Qg59zaC/nWGa4THw76A1PX72Vd+QzAEjjUumcfU5qPMk3Ma8+3ZjbHhY5ue+x3rX1zA0nOG M82vsd1Vb2e9dd3VN713262PAFHfih/sPhI/zEPbZ/waYx87+GPTi1Yk3mCVsfqn83tHkDRc eaaAW1RA/FW7AR3SvOZ749bZhROZn7OvJ02dbXBbQ3DHLKoZBQQXyz1iKHnUK1T3DN1vvE/9 h9PKq6HJcC9pahyPQMgTG8lzChbXT3CqvLwVjTIO6XyDF8XHg9Zs9seD/boRBQM2i6EXcC5X dcHCuptiwUSt+8VKY+V9yaLGh+DnYa5dpGmWjfGoqQHiwZohf1n9WYLoLsSytKWhvOQ1ipR5 z+0aDvkO23UHEyf4F9oKPkNVT4iwMMGqdiSXJUPSQJtlFU1gms/P1v/hNyZHmzYU7qy+TPEe hjhJYm37drC9H3/MhlxxFbAXBMOII2ej2/664nMsJL8FQGJ7lAMv5XYAj+OG9NmNgDqD1HOh AaSRlg7wBbk+Hli8tI6o6biDI0ha04UBkIY75YHuw7hrH2dC9M3pcSbtNhl1Ms6hrwklcHHs amLv2AlQOwtofKCZGSnVoFWKj22N7EBNJC8GDS88k0iO7tKOWFCV7TrEfSRw3OWOUIndFWQj HlS1IEvS74uXNi7rEYxmU7YShY8KYdJdvCT8nxUBYbS6tlO3W0LvJI27AQ7JZOxeXqE48oGu 88ZMQgx2AqlAqor/r9WzInnfdmAej7x+6B3kFOFcaJCuO995mcF9slksB4m1nJnJVI04LkTl cmz7my+D4OWZp+9gdJdmxvKMJx45sczqcVmEH44ENL6O3ziKjydUzS56Fd71m5DnIL7CGsCC ph9OHGfiN+PJH0rjCJLmNOEMDJCQFU4ItqUrqPG3LWXsJhPp5GJ3ZYviJdCmMYzO1oSKwQqJ M+HsUb3gDRuiKP8LbR5lF1aoXgldMYHh5nVYwdK6CxPK1ylx/hP1OemyqxbzoSRIQXdKcBI9 0iQUOeEuUPzvj35qVRe2xmmLPs4CRznWoaU9tMikmfaGJ4DHuTLJ5V5GfHKnApWi8sbmDng8 P4ucikEO/UeKUxXXzfDGRpoRtgI0XZprZhTeaAvICch87ae1PrXNt25v1bsmdRyqgsDDLgis cLJ7CAVelNmWv77Ahl77NZroQNTGRkUXTcErpQFyVQlZ4/cSHr14j7lvetqLSaVpiu95qOlm q4b6qanEG1w0vxoqO56rI0gavXAeqEDbsDDIdN6vfhBPxeNNI+jsSp5zYP3AV2lYlW865TfZ O7yYZ5dKQRvc6LR0B+DE2x1d0hFlJ6p8QoMmHAhpD8ge8TOMe/jztrdohcPtzXui9KGEdUGa krW686nwfXRpiH3HXNyRUP3zFjemuQTxn2BNIIooN2cCqZPBAbnJ7iipbPwKhIXvQPtic8id Lliwl9B5hXaC6UDJ0H8MGKfGh21vLKbq4NThw1uqPv6oyOBcAcKLhJKBfpmYkcWMAJQrjuFo 803gyGG275PVLCu/lLWqbefcdvDoR+3gIi5A1I2I+At+1CeXo6zhEQk6PeB0p+U0L3B4iQ/i 83vJWx6o9vSCJXXf6pS020fbiNWEzHGXdVtCAi8wOZQ2Acx2pwIJxTjhm4YDckNOEOrYSpjE IQQ0eaAIB7300U/5gBHMS+JEK+0YA6oz1eN6DxYOoEhPsb6gmctxo1L8MDkLC7wgloTJesLe xH9raHqHIZYscq9hGNqXiXQq3kT6orgDCzwGpX4B0MA/kMTkG5P7XGCFXLvsM+oivy6s6FT0 Sf0IpEm7I196evq+CkxV3ZBaVaheq7COo5+cncPajh7FvWz+NDCg6aeDu7G7/kMmpmVB84Ol 9NTIdsr6C1xJ6E9sEBIuDsavyypcPbt0H3aXH2CX+TXR6/0DrGxVkPFwMcHu7amM8HeOIGnU 7NxwoJbuMTNU1d/aHPBFbBUtwWrPVPhYXQoOLT8HnWcHDE1mECVKx8oKcd8I8P4cIM/tVcup 3GABlLC7liXUnvOfWpeeyqc1oQ7g99vsX6cakiActPvzuu+fuyU8G44YLQ5/Tvwe+kk820T5 ipbWzMLkvJBYLE4HYivVv71uW9nyNaKh+Z+FRdu9YNO8TuVU7y4BR0foa6dM4tFCy+hfa2fm brMD53jmxTxPmQoEDeR5sDIzs+/irIyzNU52a/CHpMM2hn5yTg478vle3Mv4AUHjav5IgUPM YHsb6tjoydN/WJnqvvTJ1NScWPVHWZ/h9ynSkYCRkHXXBVll94C3P9TncQ8wFA1EKLEZPWOI TRgLPr23jaQLFq4ew/EcKafbCiYnT2eNO+eO99oCFJaZT+XLYRptW1IPiTw07PU3Q6B5Xr4A W5guq2bo/al35biionMvSKTeXr/6R+hAD3CSl06IAawzMAW4FuyA6iF0+QTb+k3g5WHiIR48 VycDlt63IuDBCRFOiC+0w1cnggAqfGsL59WWipx7gZP9E6orkAL10UZy4A9fLAr8mZ8myu4C kflXURpD8Q2AlhAWT+uB2oHDVk0hpHUoxzfngkHDbiweeOZLywadvo1zZ+zlxcxPNNHl0WA5 rwlAxpjHEijp5r37QTkjDtSz+QM7VMdPw6+tpZXt+uCT6Z5+A99k7pTdT2XlbHkyK/u3i/sN 7rE/aWHA7xO0WEbfnYVfdqj1suHeAHZHm6AZk1WmwfoTxp+65uJ5fVQoTU9XMLbsBU5yXQGH M1gb7LGtghM0KPSwV6Ng7rHzmgaBL/dLJyaJCoGP/6iLtpPBoLOrSOHxxARaG5wtm9SEQFWM B+C342lT8eK65WALOKrFAVYXHLZp76mq9pP6mYXvhzdy8uQVwmcXjvwS2DLf4wUXylVSbPPx qc2aHoGk83KbRO6QMAS7pHi6IXoawPWrvg2pKSl/RD2RpjfWcsDUNdrFmAE4GxaFbOcRf6ZG EWke/lJ42RDsjBJsy9E9iimEDJZy8v6twNLe57QRb8HJ/kQNgj8cZkis32Cg+/b5QgsP1DBZ 2xEoVJkuT0JzqT0NdRjiD0OHOuPMYaxt8ybgU3GoyBlDeVUjqvfKdqjdXoCoiROwF2Vl4kdI eOfU5Wu8a9T0raA/Juzf0HLlgFGZv0I8z8nyxbjSWO8xhJrSY6KeXkIAc75dAQXBJ2GOYOhv 9FRWIu88Kdx8aOAnkiVqWnPx0PVfr79vTLOZoGKFDARdGjVxb0USdQkqEkOJ3MStxU0zuU51 KgQXMiOubX7xsuqroQd9pzNqdtj20WQxuFd9LUdHVk/PuxwI+j20K+LDrQTFWDOr5IMqnHCt +VtGYtL9zi7yA8kMib1RE9GHTYwOrYhrCxqRL+wBVHSzxOSfoU+hqkVIoDcCsVSENSZkUP+S nHqZEmh9J2RuDAT9I3ulovt5fp/Iq4fswTk+uSsIfXD820Qtq1C106GtodFVCt6rost81iBs 1SUX80JvWpUoLZ7phzGoUl7EBfO5WPPBA0weOAgUuIh3YsDrEW5KpDVA1iQ8/gw/Y9ldZTlp orpKktPyRmT6FewQ/0HyLDCz4xLY20LSE+FwHg7r852Q6gMZHl5dnqCPhW56rWxR/Wz4L5hM K6fdgG2lonNyRQhOUfaoc+B60Fa/hWDFuppbfEE8iDMbnzW0wHlAYmLV1LzcqvL8DPg3ucbg BZyJ6AwigM73yFj1gRn5MJ65/oopEStpzPcYxFh4xLaAzzutqjzvKw33xucUnfR117zV9F3b QluOC7Tp4ufhFXUN0IdrhganDtYDhHXpoOhA2drvo+5qQeNaNIIykuLs+sdAVQ/EQkcIgeU8 WpuKnh1mZ+yTdosS8P/lZHBr210fdI6fu3PDw17Gv6kTWwNImpCuAnaGAiSs4UfPGiHo5lac kw2kDcRMzwoQOP00IHRC0EHkLTM/jtfSwJYAt2Szn2NT5+7cebBzmbGeMcbJstKL385Jg+Qf KwFvljBs4HBN8VYKKBPWZMVsMoi+GMEWsmkelC4DSYPysI8MsbrUxqhrXK/pyCBsIx53ZJIA kWAB+qh2z6gOaT3Wv5hbnrgqGiMRqVhpuvr0dkU7s7q84Jaq8qIOwSVlrSkveA2uKMeTUNOJ oHN6jxJtKkOU5KecQtC6wXsNVS+qnV3cs2FJlMYVTRz1ZXi8i/Imviha/HQl8Pm6mWMPhOeA hsTV1qGGINHm2v58CEGLdkX9gabbNpvvOO6OYBrd5EcP8uiX4nSkaNkSiEMLNOMnCWQ4KZJ+ f0v9FW1+bpQicR8b7UiXEHb4r/VoC6hpdxBJYzEiZE0Udwd/mvjUQOgMfQj+9PQ9Z+eNnfP5 1mfsNvC+SSN3wofKobYA99VHC6VqKEmA3yHwBReMKYgF29aY9LVyg6H1AMGcTUQBRAM+YH2s ysZ6XwSfESIvvkiWZbHSxvOeznFTNfX7HadsQMVGFPjxvSGtD9WHEAjUp7arinpJTXnhd/fN yGsJvet8rS8v3IxV5FG7iNpEKgZLISu1zmWEngsW183BZ7o49Gz1araPcVsV/5FhVTPyNlqB wxv8FVjUrWQN5qHxxoy/dwVgTLI9lrsCTTiGdhlEzbb3FfJjfiGOnmlMQgjll7TsvcULqydK kiudjGS8fs8GsyBDxDbb3iIBQ499dbOLdiZc8ROcAb1k/GhnzWf3r6v5UoCJfzGRMxCuycoA Nc2npbNWUNKG2x1kbbSzN1Rid5jsD0LoxCIB5S1KH87d2rS0YuXKgGPN4oXXvao66YqLCnbg a/4bHxKOztiFseCLsRL09F50SVeamoH2xgStKPBDoJBk1FKg89w86X0rBYH/th3JfGThtHDo L9TNLDINWOjdiIUbZd4tDnfKtDeyPJqH4PAz1uBqPXTOv+PUcgkE9OfcHmmubuA8CRuBmA++ XdGdv+UtazzDxYm/tN9uEznuPXzYW7z5/i8Rz85SgNbB5aRrajWAFQZtHeVPEfmxQMGJ/gWO 7MAiAMf/QMiZEySvpvh34riBV1WN/cOt+9Z+zvHeQTxLCWjcaYIolIIiKwkM1HzSXqmYxrth 8Ps2zB1tsm6ww77W7nfCuVDb4q/1yZlS8evTpQzXtboOJWhgb2xLGZ/Rh7X5FPCgaafRGWmR 8JBCMB6blXfNRwf/BAL+P0kCW0kgoSz9K1nXIZjl8mIVYQtJQwI8CcMKzerc4FjFdnpPvaMr dZ1i43g0uLKlTfej+78HxkQ/5xA0yU0EvaXN+0B4JVxqINUwhAHhcU7dk2MXVVdXCLz320DQ pBYQV5B4ZRfHuwMwy/fElaH7REbjIG/UDynqxiMGp9oaK4SAoJzm9ftbz958/zjLCLp4XnUf mNIPtYOIgADV+rc3rgrvinzNNZb8O4QOEAh/19v3Qcs+1goK9iEcGruien/+jo7dW3vhu4PX bbh8GKpPUWX98HZ5UMeOxM/037iYMDeIcEIpE7sCXdne1SZWYi+kHpq6Xz8i/Bluj4sNTndj bzJE7teHHfliH1NdEjkXAz4+NtyD/YURSqha1xcGDOFnTteK9+ofCP3SuLHzq0e2KS1vyu6+ rSDLRpJBEii0Y5XpVLD1iYcvyS0xvowO6AQy8UeyjFJ5cShcSfp9irC3cUjuETYlaN0XDu28 x3d4vJ79OfAjMxwsW5yP13QbnJG7OQd9IlB5tNXEqnffujklW8PLx84J/qNtI8NwkOY9UdCg nl6pmZm4j4R9qq8lW5P9QIKWHVzRQqtzamu4X+tQJQsW1V0IJ0zfsLsAgj2h+duaxzfOOWd7 CLaVq87zQzCN3FbyhvJAr7iWdIxDz3TlOT0XEzk8qtfvaeEC6ezDwvCUfy83N96TwEMVEzmu P81s/LaE4gSoehPSDz8VJPQuvqupULs+vrQnb6qKd94hPcrJD5ReMUE22F8CArTH0jKgnrfX 5D+bn9pE0kEK2vwWir46oCp3/bjp/ereaFnd94v2liyuP5Ai8P3S93u3NA/qswWaUlkTH3pH eCd42EHUYi0j6ZKFVWN5tyQ7Qnmgs+Cd7M9AjqpbUrWSA01+rrLhACTUB9GZELNiDvHcID9/ NEviU0R4tsLxc6rJG9CNuInOqB3QOdJEWIb2BpzhP9b5HS9qU8xTfWxstTvDJIVO7EQ+4qXA DV3exRGRkypj58S1YKJ2tXSKI38oCSa3P3QfupL2zhFJnG8XQYOHSt6/ZgFBR6q8hQpK4GpI xtnQp7Y8bkFakGVrl3rASVixxjk7lnpqFnmXA4beEtACl5qyhZ4Sd/NOBe9YgDEA2BMdBmDQ SEghvjUxdKwEYHhDUfzkn+LEhRkvjGKLvxHksduoxf+Mm3SzJEu/U6CNhGMGmZTiwekf4AqK wcWYaFc6EAGq1YehPXXj+tH93lq5cmXE4m2j+K5ZYa7P7eNEqHyMwMlTHxdW1n8ky+4rd/Yb QqzKbj+Y5cGuSXIhWPFdK2IxBoiAw+QjwZVElBKQciYom+EmOLOWQGVA5k4cdNt9FVEyLxxS 9QO3REuDAzcmkQctpwJKwwQzNvK7vF9eU3HsdJZE4MOAgc8QfW6Q/4lk65IWSsNQ54sMh7Oz S2ARUWynxbToQd7wKjRUlkRCt/YEnylX29EwMeUfhkJmvBFBkIR88Doi4nrrgRC0ZhjLa3av mM4qKixvRYFQYelLspNj3vBkPgCPjzG1unpqGljcxxxE9ZSw1955AiZ/3Q787589aSDn8iz1 0z6DhK0QDH5heEBFA5kAMZN2EFhF+3U18MvmLGPBwr+96T/m49JOyT3knYLd25L6vThxbxil gnuJnVBDTc1Wd/Ed/Koo2S0jaWDMUqiIRQHpTFRQz9MOeki8HjAY8So8K6ubej5ZDUWEsnmr B8EQfEg4HysigYUHTpD9hrd1EhB0m4XsZhbBu0dmmf3A6rA8181By+tcV8qFY8+FBClW6wfx 9V6eNV9vOX+njLzGru7qxqZToh4eCUGKhtSVkmYs93iMNuwWwdnS7qmdnbeoh2rG98rQP4Us 47uCYJwRyqDr4lkgG0OPiV85Xhd4LUI1MXEgNnM8dgs5e7YV9PSMn2OHmUJkMo1hXpaYq+Uw O4pdnSiJAdgZ/NZzcP3MisbG7rQ3iIZyfEgAh6yFX5Wx1Di4rACeMdyBVLKh6j5YJr8kUS62 hRi6r9MJeQOqBHxh5at1d47ZEq0ChiwViaQ/6VRAeX7FN6vm7hLTCMEqWMmVCSdSsuXvSOUS Pw7UWMQWFyeYXCWKEvxcWx+nZCUJ1sL/kX8Jq+0Lz5e3pPYSJgq2+NEqXIYe0eUIJN3/kXXp oM5N6ia8PGfvwfuk/lAC1zuCoFE5aKLQbp12mOTcJxh4PdUWboEQSw/A6fIpHuDmYGLQYCVo pMJ7UlhzW4B0oF9Q/PyoR97/4109IGg2/eJvXtgbXQBayiMKYt8gbGEYPh6neIh50H2wQUnr Rd2DPbXeYMuhaKp2U0+nZ4PZcrYzptBAirRF5bm/188ofNJuT/Gy3gd629a/Iyqgg2cHd5cR En1REqZCB95W9eAi9iMcXpqwsUp3hUoa/207PlOCi5H+Ych8OlTO6emBCwzyOd4L3upCZYAv j6PSfLfUzCp+ORRn9wreZn+omMFzDmsOwRKZWKTbWFixYpOKQ3fUZaiYk/p61VVXuRTdPZQW MArkZkdISd3efLRt6rx3n4+iHx9MF/p795fvyNFE/Zd4PjcU59zV+NjgxVsInsAbcCSGf10Y jZGlWZrcefMbz4AOca+ookVWr7efQN0IkH16AxNr7i7oUG2KViovyKVOnT8IPwOg2gP3RCsn 0ThB53JABtvSkSYVSkHROlQgz13wUYZqsK9ap6ExMURZC/jVGYm2p7v0pqENJ51vXWshCJnT hb90LgNygSuhKeEkJyuiCNK2UBTlhtpZxXSyh2MBfkKAjk3XZukmULibRTOut7X7gRZOgMnd GlA5VvleBDSADRhigAdtLmDYsaqa9vD3lj+0MCMjY3+sYm+/4vZ+MG6hnVawT2NlSPA9p5OH R9OtKYlAdiB7zF1wzATR6iCI+mXEHjilAxAlx8uf6/7Wc2MhaLOdHF/iSHtRLva8D9Y55KcE KjwloIRtfQz0xIGaOSWHQ+3zS6kP2xFEkkqhrio1dTNzq0Iw7V5bAmnZQEnD7cLRWKALJQuB 8KW9RkUTgla1X9TOKHAUQVM/gIgm3xDkR8wkmLIHX+ACv94S4RXqV+wWdRfMQUPPp+LVJfYZ ZMD025BcR32aMWnx35Y9iEMAYtIcd1498wrZndqoS+JAXRRSb758muOEKD6ZC5PVpPHx8eIi rix9UPgXuo5W8FM1kB60ZuifVO364nxWcXFMKcuox1b3x9b9TCfaC6pq12FdesQJWAQDWgIX mbqINgACqXYIDcsqcPI7x99qV+0OiOnbNqrUJSu8iN0OlGRpvIaAwZrvoMh5d4ae6Uq7hoAg YmfYG5odmIu6vqJ2Rn6EUVR4+XbuDQ1+ts1prptjMydbPx2qGUEMYAGwqa+vaevDF2wLYE54 Fr8k9INqm3GkueX8Z/+2pKG9Qt1+4JsLv5fqOktbKvDit0PKEESEwgBjBPJ2USKw00CB51tg iDWaYOBg6wYw/2OO6ZgJOlcor6JR5nV2Dp3Ce6oFGoS0uMCy766arKbfsGmRBg3dtSclRbgc RjMg5GLi8+5AmPFAEth6+ZZtnF3URSe5x4w9vOQ5Y4Kt9RKUGKin9aEi9CxXLrz8pdthK2A2 vFM/q3BdCKYTV1gJ3gufYvZA6fqe9F04RjosqCw1G5MTFrrdzuGw1PHfEoWrM25P25GDd8Sf K7GUUMQ4nfjPvMH1pZxHjx7endUHrnTsBI5ts5P9ZMhrYNEFJlz+7GsLQgiaqtVF/ek7X7un D9zcPSjx/HdhPZ6hEC8fc9QM+H5wcToS9z2yQYOJ4/8L4tAropgRs1538UbzF4aeqkoouScI CW+TxRwlW5DkE3p4ak8NivbO3BJC9Qnf4J9+rXVQzfT8JxnpLMYZsCu50QlNFjiRaq2ZXvRQ nMXGTFa2oP4s1K1/zIQ9JCC9YbhC7bCwMmT+a3iOaxsWDSwOAyBWxzPR3lmNK66svloUXZl2 tBZMvrDqq4IRQcRK6xe0s3rjKDRsZfWjbd4L1t93QYdQz2r7u81HAxsrNHjqJmbe/sCEQ7D6 2t5t+rheGClxJTs5EnEMBledq2II7iPPrHhkWigePHrCcx1I+lvf+p8hN9/4fz9hnvRD8Jh5 j8LzGaavaXILQN4n6Uc8bd49PATDqSu4EJfCBmT3xoWT/IxL6YtP2HZAzuqoW7RyujQwWqKI OEU6zeA1B3XRIqA7+kCCU6JeNc1fB6ujmxum59eb0usESqGdAybCubbZO8QDZ0ZFAkXHTArr u+t5yB1g4hMzbXcJyCWq7jvmgRDG+N+2Y7BDFqg4qdJR/iu07qYGT9vurhXxxPPQguDf7ZxS 5qRxZEjVOd7OMy1Umqr+YNPcso124MTMazDoE1PV9awRC153bZw9yQ89cPI/fkbMvN0l0J0/ NLe7ohyIN1jjvi5UqE9b+2In2NRJKml99O1/7jMSJ12ncaoruFojO+QGJgGAW0qIeYo/iMOA 6QTH/qNuDFMM7R0TkMCD2NVbswKHtK09QE64EoJIqmg4avNkDYQMwU+CTmobpt6fA5r3y9XT C4oaygvqEkXQ1EShnzoAVFwfu6J/UHKKz+9d4Vi3kT4r4y6zy4JRAz7409VJms1KH18zAqv8 mVbrGGQnseedpB7zF9aPAyV0rdU6hfKRe1m/Gngj9By6gsaaGLp35EpsDlVfjwMaSIWrVwMQ ymY6+gxjS5SMQSZiBvtjq/VCSfvOPG07DhDgPd217BjVjSPO4sjkfJJOPlioAJh2R7C0nlv+ 0oBb7nz0wb4DLzzECa5vBDjmMilnLKZgjUAdln5Sxz1ZJeLkG9amBWyryHZuMDQc+/K68jeK xyGHxRD+Hlyzq6xHKitxZMuLl9rZdkZUmnZrDgUMVBxUIuGIM20TGPLlR/xiv5ppeV+vm170 LztFYKuBM+9Mc3XLYIICmUBN493jtlsG0inj0Ge2ugTeNdaeuhX6n9cb4TviEIE3XNINxBaw GqguOlPnW83fOR9Rh5LE/9mJ8Qae9t6o/W9w53Qu184zXBkonNJ2uRWCIOFyDQYvpuSJk2c4 fWM45dcCvldIMG4l0PczBH5I3uJGmJvHCtApWb6rw4hGGqjnx8pxIt5fd9svr3mrfuc2lRPv h18TjwoCjo7LIraGbiLjIHuj4xnxnJyi+nX+upUrH3FsvobaDtoqDQdeHKRncGGG4ZSWHZ09 HobShq6Jf01DGx/KbOeKNduv64EfCJx4NrYbY+G4YwR4a6m03xBoq0HIghj54cFkwQERtBtZ gO93gBO4RhyT/oGqKKvA6m+smVm6LTyL3Xs4Dh/PGfZ2DiTvUlT2Q7t1Cc8vH24ebHjE08Lj rNyDGRak7jF64FfgIjuHsMIo6IDIvOHCGitV6siTIZ15J+jEIVh4O+Is3xjcW53z5s1ffQZ0 jXFgaOc31p4JYWrQ5qhxcDHuqSY6JE/mBh3jCzsgEE/sDdh076Z6WDUNx5mTkuRtJTlHS09l B99VYPhg3Ex8SFAWfqM2dvrjm2Ly1PmvoMRrSWda8WE9AXI2WRmIpE8e1H2gOyxOuAiEuDVt q6p4b1z53P9+gheOhjGLPs4SZE+W0ubFOaXwC/nk+lI1oH4cq5CEkDQNalAIA7ogz1ildHof lHdoW2vLix8PfwWDhZRWThwi+QKDBFFEOSwV/Js+YA1hZ0/om+2FS8mjakDcsU/RN+35fpFt G//w8qPd49Dky+1QqwQTFf+iYWbBm9HgW41LcXPfpQFnB79QXkFTVlId8lY2STAvH2nLqtLQ tg/vt9m/xmqjwvIVw+cuem6hIwgai7vGtC5IWnBJE00WjR2/J2F1BqshgF1ch8Aq7FWv3EIF 77AhwgkiLEZBTefSxOcWrwGV5rFeHlmvyuJgANgaHxBQ1O9078EtPhjOprr85kdT09JSq8Du hFsDnbXio9BpKzQRUduOACtb3BNaAcLmuMMBTV3+0lP33mdG9MKfFD7lNN3vDzTMLtg0gn3m 4lPlXEP1z4tVVEJIWpTFS2k7jLPeY8Ht8T3pcEPA1IU/2H7w5QZkpt9JEXCKx3m2KkI8Sjoq x/kwNWy8WYIOyncfRu02yixsUyWWKVrWFGn3Lle9MgGtmW4rjROwBff6V+xQ9eGwyakRp6lV 4XF0DyQ3Ht6WOkdbejZ9v2ja9xpnFMRBgVoqoksmXRE+1+AnmTaYvCiNoYWWJyZrO+LpkiGO CMxtbG6F2UjqqOpZHEU7liQlq89vVM0YFSQmgWuAmQ0BbKEgPsaHx4zEZ4cVMewMNCbgsAUU /thLy+f06rfzwykdGC0mDZOt7uP9at8UprR8FKvhCfGkOUNw5Hgh4lziNJXXYlXuRL8vnF+b j61jhp16EL8QOsdOEJcd1SheXH22JMj97exoTLVETd0IoYXJV9Rd/EAIhKHmZjFAgIWz6ru4 ALUCrWhA0zMQ9I2xkjdaHtCXAR5HUkW8w0Lg4oRi8lviRDA44ajhV591Ala8MBrn5h0EPt4U JBH5LHXLIZcuwjlSCBnFCygiHVwlGOxoRNRJ9QCLptkru2W5XlH+6xHgP08xecygnoO8ZggF 2+9NISEd1Ct79gU47pdKizHopcoZFSsrZ/QqgqYudLs8BVgA/0H3gdShnKGqO+u+39XjJr0P D3FT0pPhsHrTQR7+K+zzB+nIn1bN/W54RU7Ge7jnviKosWC9zeTwPqArpvaEU22E7w9oddhD LmSco+jKmyGhBSjNAmIvWg9YenV/tfX8wZxwhP6AJIo3h+QOduGZrLWAsrt6Vsl+RvRhe5h4 5la5JSAMtsq7DcGhKwnq/Ip/fn2YaX34+968h3+Kv+Bsz3vRjkwhNe0MnIVx1BCsj1ezrgYb 1rXOocERzjDomqr3Y4DbDv2uW/637pKnwaQbxHJ7H4QJHEL8aAzUX77eZ9sD8fnyJh1rB46f QsfoAe9kWVWvpD7ytW4d7PKkx0W8ESkUsAAAIIpJREFUxU1J72s9W8KxQ4Oc+Ag8J67r7InM CbjOwqBBKUCQZm/A6wpOnTME28grvG2i4LrGroUc8XqNgPZ8CK4oC6UmQgtFJHgleFybvi3B bBHJCxfX3i4L0s+cQtAEnBZZlen/wk0EX2PfoV0p2ARbZu9EVBwne9Tve6kiIu44PUCt8A+h HZVLEL/dcGB/DfovYIflgeX2y0H7gLBGVLwjsIqHIJGMI8xZ4ZHueaE0jpTWkjzbg79pUZyg gyVLFDNpbxggkhgEh4YI1gYvPQJuzuDXn/juffEg6Infedo9afbTt1qrZGSunO+9kQr2Yp8D LN3c0Unu9NvgcsdUxYtM2fUpbkp6/8F92a7UNNuD2pT/6VpD16qcXDFly9agb1LH2ELSJj9a 39lYXrDbqdYVPlo7AKyA8+zQvFQXTje21N1TtD5ULzgiB3uBoEbgstDr2FfouDW28Za3yUUL 6i+XZfnXQaMVu607Vl1TrUzV/3AsJngnuFNHQTBiQ8LWDpHYPJr2u3gmfec6OPHcVxvQFODb DoB/n4Uvdyt80TxgLG38KSwFHrIq8IaWA8eyW85H/d7uqGMnS82O+IgbEDaTH5LYvClehbEu MoCIpL3wUAYvgFCvOx3sLdBXwbMLsc/BdFE/ONLCTf608psJzUMhy3UlbG+vR1WftlvdnKGD 78au+rONB0eYbBXgwTGQVj0XD9y4KWk+Je18fPS403dXOFSFMKj14/4Bu6tPd/Huw2luUGE5 3b2PJ54WJHSZo1odfBp3Lx39YysEJSgR/FNsm8+wAxO+XGDA5YkwuY4XXnFl7a2SS/47jtlC FucQtFk+MFfdIfH9znWBmuck6K11jk742TQm0f0RfZkwEBsZhgz5N50Uv4kYyTgweBBpxSit OpCKvS26qMuXJ14tVGJlBaj4ExM8/dLSOLcnQ4eQUCehoOg+gl3UZf/0rL3o08opCSHoi763 4jzBLf9Z48RhTrQGeG8CfPe+RuzF0Y+sSscwv9C/j98UD+y4R6mga5PtbIc7KgPLHsEwHOXR dsB28OaQp3kE1NFsCQ2JkvHr2h+dqtaIBVDbYcLtZD1nJ5C2Q4D5SIc0LJD/B2A0qwFqn0Oh IZlo9uLKhjtE0f0MdOYdxs7tNeHh4a8irwvigLbaJFvtBXiaDzD/Xlc9q3R1ou12Kj1p0/h1 dSWO0cLXQ30k4fL+zft3gVG+1moZZNoPTa4rSA5lFcaJyMeL6X2AnEUdrA1VEN48eHT/0Ld/ NvmtRHc5l9z/p+tEj+t9GL/QmYjkZMlWmFixxS2J0kWt/qPLCJAnNeMS8ED/FO/p8PFPKo67 xO6gpgoSvzGgCxFHNVH8yRZkwX29XawBKivQVzAcm8Au5h8DC2Dbxhc4KqvNqyqfRfS5Ydha kICxhLTs/tkRMGM8lFTWL8ERXU8GedB2ezt6YUBbHSydjhTLVkvQty+zyg4IwSGZFAxKfhB6 PlHXHUd3PEWIlVQWoex+NTmRUv3+X5GKmeVgcHnbj4y1zd60XL6FjIos9tElWcaJ4L96r+Ka y2ueuK3DR3q84C568K9PGympL2kYz2QarkuCNOGB1xMa153LOjyg+RYdpxRtmDv+c3oHdswE pisPd07X3XNcSLpw4bph8N6EY5psUFpmDWj7r+1vvDtve3cVOlniYT16re268PzevUrKEdtw 2gHIMv9NTMa45QjRyiU9d81Q39g4+0sR/GMMHFsfF+5NmcgZV0Urs3Nc4cKPh5UtX/9v1GWa k0LCzuUQO0NR1Q2d44tVIc8WAmsHKAjCEd/RI//sDP94Px954JpDmJqPm6wig11VUFnXt3ZW 4dPo281W6wLhoQzx4x1W85+IfKB6x/hU/dEPH7zye4mWf97Dr9100U/+uRk87e+o6EzzfEQS OsopcFlqDEwUXnh6yAd+ic3vo6E4TDUBu68vQs+xrnEhaYH5C0iVzG6g7SHOzvyXXTi9nd/0 XWBwhXYWJeJH40TizyEoIEarQ8HAcVS2cCl2WQap3v20c4WAom2RsrqukCrazIlRXEeGyiKL UlDP00Q5czPOT/ySXTXCENzurnRKKyZEFyQNhmVukC3fXc744gOqvna99/zW+FL3cirV/wtB dnlJmwV+t39Cpfl9geuJtWWlZBoMWLj/B1SVrXFhpWyreQQmqx+pFz8Qb/7JcApV+uM3x47/ 6b+qeTnt9+CJDQvqV8NNKbktJe0QsE7A7Ld8QgsWzEsFV4pbZdpHVK/RlfWF6FiToo63nnEh abjtKwsKdeIFGz2dOSk55hiPNnop9mN5TSsTSOHdRjD9J3D6RyE9ZBugzKzFlXU3gfJMswsH lnEbGmeUdJEJQLBhbzHB2oHZXHBkQP8oEusKvmRJ/b0cS92INixxQjc5nn4gN7W6wXXZtcHV c6EG9oCdQLrRmMJ/c+r72qkL5a2eXbpP9be9Sfshl+y6ddSy1f3VDM8m7Fy9VmATgYKdQgZk Bg9ayX8i8vj4tnfi/R7jHnnnsu3nDPlEcqfWaaJQjDM9TdNxFQabKu026ScG73UBXjAtBomX ygO+tmUhJ2YezvgOzEMTwoFxbZ2hnlUM/1oWq3ksG3i0ulfzOe645FgJztyJol5IPD57gVTn NWe2wrCO47imu8DQt1UlorIg6PprVCC6sQeerYZEfRdnJC3C2HHdWLq06UqON940dG4P6LGx GP8XQCPF8dNPYlWL/JCIHN9lW8lJciEHS0PUy3IgrykKU1+0DKAXMrb6/XNS3eJXOFVNTeVS b6m+fczjxUvq3hR56TorevWUBz50HixaUPN67ezik37eVv9g0r6eupW8KvZR+l7BOPE+qL+N h8tMJIdRGHEJICINMvyCW8qQVxzSt9ZEzRJvvt+CzzIMPdCvVvTfSPUiwb+utzXWzRi7lZ7j DfFR0rwBEj1ekN2ng/38gRRJ77Eju899/N4YnAQn//h4NoKG7b/qbfvQBoiOrOf2+ziNF4RS O+wXAkYsK2xeX+oAHHaDLfJWkxYOi7Nya/rbMPRMQzNuAG9rBrbLl8D/yXFH0FR3XVVZi+Dv gqThzCHX9nDWjH1OHSZspZ+j5dkw5+zNAsdWEeKBM4KbKY1fE39CFr6WAyhqXhZM9ollGBYz ytNeyCemi8XsEdmKHl8zJVUfuEuX3S+rPDeeNDeCqnrktjTI2jBZHaCkzZNZoC0D4xe8Ax1L SNxCOEP03wxkv55NHWfuUt2878K9mtZJqyo24JhIOu/xD/vBjHJobFBxpNC1XZ3PmIsj13FP gjPvioFcbJULzuDGxrnjD9oC0p7ZJ6bfCqOadFuwwIRVAr49ODrsg2hwVN6Aiaq9NkeDe0Lj sJnZMHXcgfA6jMDBs0BiZ4bHWbnX+ZNTthJQlcUCnZTN8cWFi9dcuRYntmMH1WCljZSHdkci L19asLTuPKswuuYD4g0/MKBrAjOGk0U/rBytI2nwnPMX1swqWtK0ATygF5ko9NUI5xMCNpEx XcPvCUHjHFJC2vQefGmwP9RmXX+1myoGoyuedkd7j71ait6qzQ29g77I8N0HSyLGY+hdT9eY 7A5BSr2Y+Ku2LO9QA9IqUFSlrvMZcz1V7kS8y5vcKOO0k1x7ZZue7960B+NYboEzHqJDWO2g UBrp4Ed3SxFJAf1f5mHzx4o9pe9ISA0DHTJgiOi2NDFjAtmwQA3RevuoMw3NkV2S9UpEz9mm p/yZU3xvSbzwZZ7z3Acs+4ZaWbtMEt0Lrbqh1TSFwzFjs1CiQ94cwVhYztqit+BYrH/B9RvZ HQES2oFtlkCAfvfofYUXAmv9AW5Xc1QVIkGoa8FWHC5JQ3Do++MhbJdBM8wcFfhDVotg8x7V A8r5OGmo624sBIaue91Q0TN2hhgmEJBLR/yZfF35yA6NDhhs3QPo78bLMw8HH5OSFgV+cuQw D8+eyL1Z1KpEcpyQtBcqF4Py6PiUVupA2XUWeMdK3s55ChbVTQKbom+IR9b5fdzPvNB8mPd2 axkn8t61YKn03qGpcVc0mJD451DNSDBX5+R8FNaacbVdtg58z+iKHljdubST4Zl84viZcgec vTKB5y4qXlYzQt0nLQd/GUjRRn9y7Jtj5lUPPb5tBDL/9U0JIeixj1WdOfZIyUeyJPyLE/gc nPeIZhPDGT/0SZDFQVfykIcraXFAQEg/opyJ9WG43VC7k1YdPOobW3d3UcxdSArUuMIp/oAh X5YueeeE+so0CtL1xtrpxZZ8+PSMpCGwgvAH2xwbPK32mpKVXEDQ/hWq+Ml6haBpit26QQ8e bC8p5seNpxwZTnNIvc1OIHVATNKazbvKukXCnoPeNvC8t9opx6m8hKDhQvRP4GXvtw6T1O/U vZ3zoycmhlNPnd/H9YzzKg1VA+V0coZ100u2tvn3DQUVvZ3TxeVk2aYy9oAdHE3sv1S31EEZ nlwtD/KtcyvXX8WlpW2Ff+hxQUFpvLslLF4mUQBELkjb4FN7etO0MRN23BefLnPb8pt3hVs1 giIXgDffC/XRB03DXdiLWN6F9Iik8/s0ZIsed7ZdgRVVFqdHNK+dVvJZqOIn5RU6oSLPXUwD 0l7gAl61JSEKIFp5ZcuWSTi5+3q7OxnzRHBVWdTTVovYULqqvUaqZScyEFsMutzvVpfn34At p99WXTQuAsmfC2k7joc6w+54xunz3kNuFgHbVj17IfPamedv8+n6baInbWLBwrqrMgztWRzM 0O0iHasKQfVZ/obSJY0zY6U97u/vWi4O/sUHX+Uk4XXaw5p1TaASQVVNeE/WtO/k9qk6Cwh6 aQLZO5IWLqgdUlJZdVHdtKJXa2YUBNlhIHT7p0pc44y8lo6ECd70iKRhOzsQFIOcIMzoyXne 8koSHaDzsSULq/tzomtgoh85vCbEC4VN7ufrZp6bsIAgHA7dq9r5/wu1Rdv9r+nq/tqZxSs6 w+/83KwFHrfrF6QzzESeaYEAq3glTtqeGMzH7Uokf5e0PAdm5LHg41sHgjdpqz9NKl8z1n0x dVxMnuqxkk/MXeOM/LcVX/MKSXb9ahUOG9Z07SMan1YDzQuMx4V5OHTCKoxgPlC+odPFKyq6 4qCrXne5Zv9xUlgZPVd68F1av8zsOYmoqJrsNBAE0DH8FIvurc1tB7LXlY/9rZ2ThXhReItj 0qGwejMijOpsHvPXtYPCSoAaWgn0o9ES+wGI4qRndRiC6zTQ/LYmMW2bdI7ZFhqSdR5cRs4O btvs9b+uc4/FA2EjDCKgFTDPFu8ynoKipcGEASn/26ppY4+xm9qP9oqWPHYcRq/BvohIpwtD MZFtbRVocvOc9rcIuCfxQ830whthdTkWso274BfvcZM3a6O+5DfcLbp+e97jH3qsgwGveeWU oNL/F6PIsVckEv7bJL/BBYLsJELmd684vaeyRvTbKOHklTPi2gGbAkFJ0Tm9SlECExrvHHHO 2mm5v9s5d7wlox+zXlhoSpY0fAKLT7WqvKCup7paedcjkuYl6SInjhcChUQyVNMs0kolj1ce XYDTHU21tSjRVloQjD/brbMWcJ0D+SPUxewFXnQpmhq/Jz5vW+uj0OYBC/P4BdIeUpXAnVAP /E5EqTq3LuI5wQf0X8Tk5yXuXCx6EXEJgiTePugW/fVE853I9HCR+R23J22R37/jE2hpRRGm Jly7sW2e9E8SzhUtw/KbwDYKmpGEvw7MvymI7AiZz5+ynd38u1TwfaPiK5/qpvg0IPtwEBH3 xPIjMxWca/lYQNHGNN01pmzDjLxVEYkmr8jsoPAjXvT8UDxgym9EQTrb33L0mz2ntPY2aqND oECLXBK6t3WFoIXTjO22YByHzDITJtrVooCwS2/27XzfdnVF4V5YPfb4fWKVwUHtSAl4G+h0 4lhpQ+/Xzhm3S1XavntceNOgauDoaLviN86rm1n061AdQlddUTc64fM5BA972wuP3Vu7A7sg cCJdk1qpdc3Mot+qgVZR9pz5d07nKuywPKh8Op0cKn754E//1Ep9eswDyjmHEHLn0N/dx7O/ 4Lxo+tVu8XMJaD7F3AF2xtO0s2X8HhhZPREIHMpsKh/1/Q3lozZ3Bk/P0un6UNbX44r2Lmoc UdCVjUskSbq1zdda3HBP2TEq2kGfJ90igVGPre6PBe6MqJVLJBJ0iwFMwXxsbyLZTkRaTdMv s12uIDZunD3JlsCrcP6n+aIgXGO3LkTVq7xG+q0JhdqZpc/CfPwXTniK665gUPhQGtKfM4yj I+pm50bfZQlaI7kS6A5GrHjYykWOb0MbFytPzPecsDZmmpMwAcbCfIFnZ2tM+y6QtOU+DTWN dtgQ7P6g6PGavFCcU9c9h6Fx2jnMm/J5lqRVsQ2jIuQMlEziM/ri5EPToITGPP1IfdPA5+c0 9j9Hdh8d3jh1zJzOnh87F6E8/o1atvzauGQNhU/Uji7JmbwOZvPTfGrLtxtnl3acu0jvRv/m A1D2zoTIQRwGU3a7JuBs97AYa7d0WjbOBl9vl3lurfT4c5FklvQq488RPaWhBY6tptGTxI7l 5VZFVx82BPETGmxBZ03dfqpu4WEy1jdOL4lqYdhtpvYX1TPyH1A15ac4lw0xtjgEHUUR94F4 ulBRbMDJrVeDf3fzmnaT2Y5EYTfwWPIF2g79w65zNixZ97e63sGTHr2wdhh2FpYd5YQKAUXm iGplCN7xutaUF87VGbddFMUyINjEB1OUigINMiHV9XyUV9aiyp8eaPKqXw1DlJNXeBjOGiSA O3EsF3vnYpWVryDWRseg5HUjB6bvgjlXsBLB5zrc8bLlPOcf2FA+6tEvKpwV8hYvrrtT9siN As+PBDGztH56ye9DDYYHzYEtnOhdf/sFljVpQrBC124/ligaX6ZG2/3BaoeUYl4NFXiyXtHh l5tbfBttJvUxTWfVdttYN6toS+20vAer7xpz7v5DWj9NUX8IrYtNvCgH4t3+U12gY/+0nbrU TM/7X43p1wG5eeMtt7vygGyxAeSOwlfvtDXTxhasnpkbk6/bd8+hParqPRBcpBIci8R/hIQv VB8PDDuc+L6qrteEYJ5iV3iH9V0G9UbbVHRHu0Gxgr1XCA+HT3bE2bmpvG13KHv6jJey2Kzn MoC0veyZ23zy3StuCr2DMyQILY/xsVWJjSRCQvUHiO98wOv1jls3bfTUhjsLbKvBdpRJNxjB RQtrrpBcnmWQTdCicDjgYz8Mpcl/oj7HpakjNzvsLz86qYzK6Esb3w4EyGG6vW8KvUWR+fQX Qw05Wa+6pm2BOfgcHbPQah2x9RF5Q/iT1fzR8m1/oPDQdsZ+hhHy87JlTacrinauJIs3YcP6 NVD+Jn8w2rwjpzp+w/u7aDATiauZmvuX4nnVgw236zaRE+4HJTyAxkQsrROYoGPe0KKlYvrw b2iGsUBvVt5NZEdFutsFC6vuAHIdgzZ2INx46o9FildV471QWtjfbQSPe66aIJxQfrqKEodT 5Ngr4XGn0j3UMDdAZzpPkvhPsadJM9kCNhtAYw8WsXfAU96TiXjKI1/OK9O1HPabb3bsdsKr 0uxp8bGj3iBrY8afzgzMv54odi5t2u+yW1y+CB/eHBNzTVsA3fvCtnW1lb55k9ccg0UU9zGE fiw+8buSpU2/FWTPTVrAx3GidNB3uOWcxv8ZZ/rnKZu3epAqaIVVs4rfSBxyzzk6tgw9J0u+ Pdl6YMSs113pY864EYch3ySIchHMX83TI2jSEEsBFPATNdPyO0xTnap//tL6y2SN/wZsqkoF Xu4HDmAKKAwXWCsiJj1R+m0QoTdDJ3cd1N3eaObZHzdNLzrp5RFO9c+pAId4ppJHXoUVvr8T iBqrMAL/j6ppuVfE3/4KPm1WblbLwildtU3uer4/6+P1s1/eHmIZUAlBntddKzJlmZ2hMW6I 5lOqyGx8VOXaV7Ho7FlfPuaOjvJJdQ+aIZ7yleO9rh3VbN5cyyp2Q6BumO3J/AzykdPIjoAT 5BZfW+sljfeUfErlEYtD5PTJteUFCzvKd/AmiaQd7MwTAgq7nrLlazxevzhalqVpsOO/VZA8 QttRf07j3Dxzle+NetEJLFvPHCqmtrWJaZrMqy54tPDvM1SXSOp7ypq7ykBCO0PB9Eb9/9th 0onVKWn9ngAX6rtOIGoiDEBTv39o967Lt1Zc7IurfysqRNaYK5ksjfAM3wKbY4CcziAsDI8O v3ff/dLPfVLLT9hjt7SOXbLuybXVLeVsedAlaHi6IO86+jjMr1xTyLG2HfXlEw5F5jn2VLyw 4XycbbsUsoh8ioV1oq8toI2Bd8Ft9IydCU6tYlNq+6+rYDgUmOKcDkkk7XSPnmh4oCCKLskr q52W+2kSSZ7oj3GSlw9vcWUHC1YBkTlylFkQURsfBJj/rsZppU1RW4/x6e4vnOlbcv3mqO8p cvJkgeXlGayRiWzlgwq7+dkU9uwt7SyOIPtCnvPilMC8G1e45r4watSI3H3eV99p2zZ8cLFs 6NtawWVjnmYf25LeZgoiuymopLLuvexW46p/RLEILFrUdDMnGNMFjjuP1HJJ6A0+6Aa9LfD1 2rnFjQSyaEnDFeDnnV07s/An3RThSHQSSTvSjUkgyR44NXtgYsUWd/PAtr2gptOdaQHQGZQF VM24tu+e3X8nuYJtuMS6yGsyWMWDpFtnBA1OmjwsOzeNce4stvgrQJpA3hUrJXZgN8cWzoYf 6hWy6xB/l3/+DYu6K3/Moqrz1s0s/TeDf43iATVXcZxUigIKeYNBiYDPgMIDwAJBQ76CS8PB 3XvODu0SShbVTkdL86pmFs7sDr5T8ZDuJEOyB5I98N/aA+9UDPMFmHYFqZTbNXIJ9iHoThw9 Bx/orx4dOPCz0sX1FZb6lhBzKKycosv7c/Oku/80w4wauBsKD7leSeAHyWIArisQZrw40nWU v9RE0HiUDglFvF+Pavk78ekt7pLKhj/JTCouWtTwi7JB63fCpctfwXN+GMe83QBXwxnmaTbA zEGHX+ypqrcaiglBT15hCMVLG/8K19TK8UDQ1LQkJU29kAzJHvgv74G8BQ1FLln8Gzb1g6Jp C1ntHvgoB0fAeF/xaZMb7klAJW7WApeJcO9+PocFIJBe8q1DmTNfGeZ1tbgCzc2bXCzzjAyR 33PUJfzc0P1PdpiRhyr6naf75BePcwku/jZe10bi4IInRUE+YojCLKimfiaJ8k85Q/eYLBpo IHUJZJ/A8X5F1ebWzcivpPcFy1aPEQ3PMghbflQ/LbdDc6hLXocjkkja4Q5Ngkv2wKnaA3Dq lanrnp8LvDA96MPcOfQAo6hWaEZ8Aq2fN+B+97W66WHO9MknR0VFdNVXUNSpfVhB62nZDQys E3H2H8arRuYatnCSX5z1x1+JIrfYN68rfzsX7lk9LteLoOrTiRQ1LVc5XoMAUCKWCQLKM45R 62EfzaSeGVvj97V+vfHucdvxiitdUncPDqX9VqD18OVOHYsXVmSPt859hR6LSb5M9kCyB06V HihZXH87L4rkTqDI1PwgfOZAIKqVfkCOTDH0B92B5ic+nv2lo2wiLArfuc3HRsxysSFf10yr wijlSbNeKmKCl4MN6iGcqpIe8B3ZzJZPbeuctHh+9UgxNXWNrgQS4rNT3WBw1QbfJAvgLvcH VNGixfVfl0TxpxozPqyemnt757KOx3MSSR+PXk6WkeyBU7AHCpfUThcNfg4sXUfoOOfQySbA NYDJbNVU/V2dqb+AcM7DFKWvLzVl5fodo1vZg6RS0a46N7lCNrU8QAG7Z794sU9orpWNvk8H Wg7exX59ZxerwsLK2jtk0fUkHJTFXWWyRoWBVn1Lq/eSojM2H/p069DsrPSUpYwXr2aKdsH/ t3cuIVFFYRw/555774zjNCqmi4TUaBFoglFGUdHSTcvATYu2ThlC0LbHplWgFemylVi0q02r JHsIafmAkF6SUMIsVEZz5s499/Q/dxwQUUm8M83oNzDcyzy+c85v4D+H73yP0StNI/9sLOAP Bgo+4LmROSJABIqAQOuDiXPMNJ8ZnO/fQcLmhivRh5U6S0XLsX/lhoPTuhnsgr8iumIWUj7l cctZSfKB6W9DUeyc/UYQZ5/8rpldTiVnLjemELMfTtQwJFNV1UsVno8Kbxg5040bDrjmxezY OriOvU5J1ZVOJL+X10Q67XCkG6UYalGO4N7SvLw5feNILqlmzbcLd0siXTjWNBIRKFkCush/ KlIxiOiHdkQ+oFurltR8PlBMYLW0gC6n47oZbKzZPMohJBBZ4eDarCOmoe7JbPigFltfcP0d uu+m2WR6fhQLFw7iUKakm76eVqGJiJC3sXXvNK2Qrm0+aWdUx0hX08ax3pvYzdfLJNL5Ikt2 icAuJNDSM94sbKtfCHEaLpD/sEJIllatbf5JaGHmBrqBey7KCKu+pYzsK0OmoC2sOMS5EjZt lFaYQ+eZS4ZwhraqzljoRZNIF5o4jUcEdgGB448mzyvDuoMgiTOoAVLUK4K/2/E8NQwBfouj S2FYdh0OBy/ivsx33xj8s3LdnrF4S38xLoREuhh/FZoTESgRAi0Pxy8I03oKwQsF7a8ODIFi KPzF0sIM7UO8tA7AY9y0mYTfG1Em8an40ZeBjZUHQyTSeYBKJonAXiJw6O6HioqqcqRJs6tw KhzQO+sgE2KCYKlrkmuPNYrsJpjkj13PGUDLtrEgbOfbBol0vgmTfSKwhwj4pWw9dk1Y4RPY WVdni+MDwDZ9yDtGpk8bMSYSUyQSaRYyMjWqXHkfNbWf79h2gQ2QSBcYOA1HBPYCgZO9X2J/ +Eq9Jcx2ZBh2QDOP6Uw+/fAbRgQt2hjA8GOvsVtGmjfMT+JuMO25L8Km/IGDwMVS5U4iXaq/ HM2bCJQQgcO972NlZqyNM9mGeOtWCGqD4EL3JkTXWRnN7rThkNA7YF+V1kvTaiA11NcPvcPa IcvLaAuzgIpOc1K5P+Fr/ojU8zGWZm8+dbculBCeLae6nsSWH6Y3iQARIAKBEECzCnaL8Yb6 V3Z5orbSiMo6U6oGzxAHlaliQhnVHvQ4Nxb3PBTmx5PzXxklZ9hyZjZmuovvuk9lGwzkshNz X6ArESACRIAIEAEiQASIABEgAkSACBABIkAEiAARIAJEgAgQASKwbQJ/AQb4me4AfccBAAAA AElFTkSuQmCC'! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:05'! showDesktopLogo ^ ShowDesktopLogo ifNil: [ShowDesktopLogo := true]! ! !PolymorphSystemSettings class methodsFor: 'growl' stamp: 'tbn 3/27/2013 01:30'! growlPosition: aPosition GrowlMorph position: aPosition! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/30/2009 06:37'! desktopGradientOrigin "#topLeft #topCenter #topRight #rightCenter #bottomRight #bottomCenter #bottomLeft #leftCenter #center" ^ DesktopGradientOrigin ifNil: [DesktopGradientOrigin := #topLeft]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/30/2009 06:33'! desktopGradientDirection "#Radial #Vertical or #Horizontal" ^ DesktopGradientDirection ifNil: [DesktopGradientDirection := #Vertical]! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'AlainPlantec 12/10/2009 16:02'! uiThemeClassChoices ^ UITheme allThemeClasses collect: [:c | c themeName -> c]! ! !PolymorphSystemSettings class methodsFor: 'settings' stamp: 'tbn 3/27/2013 01:22'! appearanceSettingsOn: aBuilder (aBuilder group: #appearance) label: 'Appearance' translated; description: 'All settings concerned with the look''n feel of your system' translated; with: [ (aBuilder pickOne: #uiThemeClass) label: 'User interface theme' translated; target: self; default: UITheme standardThemeClass; order: 1; domainValues: self uiThemeClassChoices. self morphicSettingsOn: aBuilder. self desktopSettingsOn: aBuilder. self soundSettingsOn: aBuilder. self growlSettingsOn: aBuilder]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/28/2009 15:47'! desktopImageFileName: aFileName DesktopImageFileName := aFileName. self desktopBackgroundChanged! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:31'! desktopColorSettingsOn: aBuilder (aBuilder setting: #desktopColor) label: 'Color'; description: 'This is the only color of your desktop if no gradient is used. If you make use of a gradient, then this color is the first one of the gradient' translated; with: [(aBuilder setting: #useDesktopGradientFill) label: 'Gradient'; description: 'If true, then more settings will be available in order to define the desktop background color gradient'; noOrdering; with: [(aBuilder setting: #desktopGradientFillColor) label: 'Other color'; description: 'This is the second color of your gradient (the first one is given by the "Color" setting' translated. (aBuilder pickOne: #desktopGradientDirection) label: 'Direction'; domainValues: {#Horizontal. #Vertical. #Radial}. (aBuilder pickOne: #desktopGradientOrigin) label: 'Origin'; domainValues: { 'Top left' translated -> #topLeft. 'Top' translated -> #topCenter. 'Top right' translated -> #topRight. 'Right' translated -> #rightCenter. 'Bottom right' translated -> #bottomRight. 'Bottom' translated -> #bottomCenter. 'Bottom left' translated -> #bottomLeft. 'Left' translated -> #leftCenter. 'Center' translated -> #center}]]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:40'! desktopLogoFileName ^ DesktopLogoFileName ifNil: [DesktopLogoFileName := '']! ! !PolymorphSystemSettings class methodsFor: 'settings' stamp: 'SeanDeNigris 4/24/2012 20:01'! morphicHaloSettingsOn: aBuilder (aBuilder group: #halo) label: 'Halo' translated; parent: #morphic; description: 'All halo settings' translated; noOrdering; with: [ (aBuilder setting: #cycleHalosBothDirections) label: 'Cycle both directions' translated; target: Morph; description: 'By default, halos only cycle from front-most submorph to parent (shift key down). This setting enables halos to also cycle from top-level morph down through the submorphs (no shift key)' translated. (aBuilder setting: #haloEnclosesFullBounds) label: 'Encloses fullbounds' translated; target: HaloMorph; description: 'If true, halos will enclose the full bounds of the target Morph, rather than just the bounds' translated. (aBuilder setting: #showBoundsInHalo) label: 'Exhibits bounds' translated; target: HaloMorph; description: 'If true, halos will include a fine rectangle around the bounds of the target morph.' translated ]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/28/2009 15:50'! desktopColor: aColor DesktopColor := aColor. self desktopBackgroundChanged! ! !PolymorphSystemSettings class methodsFor: 'growl' stamp: 'tbn 3/27/2013 01:31'! growlSettingsOn: aBuilder (aBuilder group: #growl) label: 'Growl' translated; description: 'All settings concerned with the look''n feel of your system' translated; with: [ (aBuilder pickOne: #growlPosition) label: 'Growl position' translated; target: self; default: #topRight; order: 1; domainValues: self growlPositionChoices.]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/30/2009 06:32'! desktopGradientFillColor ^ DesktopGradientFillColor ifNil: [DesktopGradientFillColor := self desktopColor]! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'AlainPlantec 11/6/2011 13:16'! morphicMenuSettingsOn: aBuilder (aBuilder group: #menu) label: 'Menu' translated; parent: #morphic; description: 'All menu settings' translated; target: UITheme; targetSelector: #currentSettings; noOrdering; with: [ (aBuilder setting: #preferGradientFill) label: 'Gradient filling' translated; description: 'If true, then menus will have a gradient look' translated. (aBuilder setting: #flatMenu) label: 'Flat appearance' translated; description: 'If true, then menu will without 3D like borders.' translated. (aBuilder setting: #autoMenuColor) label: 'Computed color' translated; description: 'If true, then the menu color will be computed from world dressing.' translated. (aBuilder setting: #menuColor) label: 'Menu color' translated; description: 'The menu color to use if it is not computed automatically (see the ''Computed color'' setting)' translated. (aBuilder setting: #menuSelectionColor) label: 'Menu selection color' translated; description: 'The background color of a selected menu item' translated. (aBuilder setting: #menuSelectionTextColor) description: 'The text color of a selected menu item' translated; label: 'Menu selection text color' translated. ]! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'CarloTeixeira 5/23/2011 15:47'! usePolymorphDiffMorph ^ usePolymorphDiffMorph ifNil: [usePolymorphDiffMorph := false.]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:16'! desktopLogo: anImageMorph DesktopLogo := anImageMorph! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:24'! showDesktopLogo: aBoolean ShowDesktopLogo = aBoolean ifTrue: [^ self]. ShowDesktopLogo := aBoolean. self desktopLogoChanged! ! !PolymorphSystemSettings class methodsFor: 'sound' stamp: 'AlainPlantec 1/10/2010 07:54'! soundThemeClassChoices ^ SoundTheme allThemeClasses collect: [:c | c themeName -> c]! ! !PolymorphSystemSettings class methodsFor: 'growl' stamp: 'tbn 3/27/2013 01:29'! growlPositionChoices ^#(topRight 'top right' bottomLeft 'bottom left' bottomRight 'bottom right' topLeft 'topLeft') pairsCollect: [:a :b | b -> a]! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'AlainPlantec 2/11/2011 18:42'! uiThemeClass: aUIThemeClass | themeClass | themeClass := aUIThemeClass ifNil: [ UITheme standardThemeClass ]. themeClass beCurrent! ! !PolymorphSystemSettings class methodsFor: 'growl' stamp: 'tbn 3/27/2013 01:30'! growlPosition ^GrowlMorph position! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/28/2009 12:00'! desktopImageFileName ^ DesktopImageFileName ifNil: [DesktopImageFileName := '']! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/28/2009 15:50'! desktopGradientDirection: aSymbol "#Radial #Vertical or #Horizontal" DesktopGradientDirection := aSymbol. self desktopBackgroundChanged ! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'EstebanLorenzano 5/10/2013 09:27'! uiThemeClass ^ UITheme current class ! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 5/13/2011 09:20'! desktopBackgroundChanged | fill | self desktopImageFileName ifEmpty: [UIManager default currentWorld world backgroundMorph: nil] ifNotEmpty: [^ [Form setBackgroundFromImageFileNamed: self desktopImageFileName] on: Error do: []]. self useDesktopGradientFill ifTrue: [World fillStyle isGradientFill ifTrue: [fill := World fillStyle] ifFalse: [fill := GradientFillStyle new]. fill colorRamp: {0.0 -> self desktopColor darker. 1.0 -> self desktopGradientFillColor lighter}. fill origin: (World perform: self desktopGradientOrigin). self desktopGradientDirection = #Vertical ifTrue: [fill radial: false. fill normal: World width @ 0. fill direction: 0 @ World height]. self desktopGradientDirection = #Horizontal ifTrue: [fill radial: false. fill normal: 0 @ World height. fill direction: World width @ 0]. self desktopGradientDirection = #Radial ifTrue: [ fill radial: true. self desktopGradientOrigin = #center ifTrue: [fill direction: World width // 2 @ 0. fill normal: 0 @ (World height // 2)] ifFalse: [fill direction: World width @ 0. fill normal: 0 @ World height]]. World fillStyle: fill] ifFalse: [World color: self desktopColor]. World changed! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'BenjaminVanRyseghem 6/25/2013 20:16'! setDesktopLogoWith: aMorph self desktopLogo ifNotNil: [self desktopLogo delete]. self desktopLogo: aMorph. self desktopLogo ifNotNil: [ self desktopLogo openInWorld; top: HandMorph upperHandLimit; beSticky; lock; goBehind]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'CamilloBruni 9/7/2013 11:28'! desktopSettingsOn: aBuilder (aBuilder group: #desktopSettings) label: 'Desktop'; target: self; noOrdering; with: [ (aBuilder setting: #showDesktopLogo) label: 'Show logo' translated; description: 'If true, then a logo if shown on the top left of the desktop' translated; with: [ (aBuilder setting: #desktopLogoFileName) type: #FilePathEncoder; description: 'The path of an image file for your own logo, the default pharo logo is used if empty.' translated; label: 'Logo image file name']. self desktopColorSettingsOn: aBuilder. (aBuilder setting: #desktopImageFileName) type: #FilePathEncoder; description: 'The path of an image file which will be imported as a form and displayed as your desktop background' translated; label: 'Desktop background image file name'] ! ! !PoolDefiner commentStamp: 'TorstenBergmann 2/5/2014 08:39'! A pool used for testing purposes! !PoolDefiner class methodsFor: 'initialize' stamp: 'StephaneDucasse 10/7/2011 21:17'! initialize "self initialize" Gloups := 42. Author := 'Ducasse'.! ! !PoolDefiner2 commentStamp: 'TorstenBergmann 2/5/2014 08:39'! A pool used for testing purposes! !PoolDefiner2 class methodsFor: 'initialize' stamp: 'StephaneDucasse 12/13/2011 16:01'! initialize "self initialize" VariableInPoolDefiner2 := 33. Author := 'NotDucasse'.! ! !PopupChoiceDialogWindow commentStamp: 'gvc 5/18/2007 12:26'! Presents a list of options in a popup format. If the list is long it will split into multiple columns. If very long, the columns will be scrollable. Maximum extent of the content area is half the display extent.! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! labels "Answer the value of labels" ^ labels! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'GabrielOmarCotelli 11/30/2013 17:04'! switchToPreviousColumn "Give the previous embedded menu keyboard focus." (self choiceMenus isNil or: [ self choiceMenus isEmpty ]) ifTrue: [ ^ self ]. self choiceMenus detect: [ :m | m hasKeyboardFocus ] ifFound: [ :menuWithFocus | menuWithFocus navigateFocusBackward ]. self choiceMenus detect: [ :m | m hasKeyboardFocus ] ifNone: [ self choiceMenus last takeKeyboardFocus ]! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/15/2007 16:00'! choose: index "Set the given choice and ok." self choice: (self model ifNil: [index] ifNotNil: [self model at: index]). self ok! ! !PopupChoiceDialogWindow methodsFor: 'event handling' stamp: 'AlainPlantec 11/22/2010 12:37'! keyStroke: anEvent "Look for a matching item?" (super keyStroke: anEvent) ifTrue: [^true]. anEvent keyCharacter = Character backspace ifTrue: [self filter ifNotEmpty: [self filter: self filter allButLast]]. anEvent keyCharacter = Character arrowUp ifTrue: [self selectLastEnabledItem. ^true]. anEvent keyCharacter = Character arrowDown ifTrue: [self selectFirstEnabledItem. ^true]. anEvent keyCharacter = Character arrowLeft ifTrue: [self switchToPreviousColumn. ^true]. anEvent keyCharacter = Character arrowRight ifTrue: [self switchToNextColumn. ^true]. (anEvent keyCharacter ~= Character cr and: [ anEvent keyCharacter < Character space]) ifTrue: [^false]. "ignore pageup/down etc." (anEvent keyCharacter = Character space or: [ anEvent keyCharacter = Character cr]) ifTrue: [ ^self processEnter: anEvent ]. anEvent keyCharacter = Character backspace ifFalse: [ self filter: self filter, anEvent keyCharacter asString]. ^false! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 11/21/2010 21:55'! newContentMorph "Answer a new content morph." |sp choices| self choicesMorph: (choices := self newChoicesMorph). sp := (self newScrollPaneFor: choices) scrollTarget: choices; hResizing: #spaceFill; vResizing: #spaceFill. sp minWidth: ((choices width min: Display width // 2) + sp scrollBarThickness max: TextEntryDialogWindow minimumWidth); minHeight: (choices height min: Display height // 2). choices width > sp minWidth ifTrue: [sp minHeight: sp minHeight + sp scrollBarThickness]. sp updateScrollbars. ^self newGroupboxFor: sp! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! lines "Answer the value of lines" ^ lines! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'GabrielOmarCotelli 11/30/2013 17:03'! switchToNextColumn "Give the next embedded menu keyboard focus." (self choiceMenus isNil or: [ self choiceMenus isEmpty ]) ifTrue: [ ^ self ]. self choiceMenus detect: [ :m | m hasKeyboardFocus ] ifFound: [ :menuWithFocus | menuWithFocus navigateFocusForward ]. self choiceMenus detect: [ :m | m hasKeyboardFocus ] ifNone: [ self choiceMenus first takeKeyboardFocus ]! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! lines: anObject "Set the value of lines" lines := anObject! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:45'! choice "Answer the value of choice" ^ choice! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/6/2009 13:13'! choicesMorph: anObject "Set the value of choicesMorph" choicesMorph := anObject! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 13:03'! rootMenu "Answer the root menu. Answer self." ^self! ! !PopupChoiceDialogWindow methodsFor: 'initialization' stamp: 'GaryChambers 7/5/2010 15:57'! initialize "Initialize the receiver." super initialize. self labels: #(); lines: #(); filter: ''! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'GaryChambers 7/5/2010 15:54'! filter "Answer the value of filter" ^ filter! ! !PopupChoiceDialogWindow methodsFor: 'event handling' stamp: 'MarcusDenker 12/11/2009 07:41'! processEnter: anEvent self choiceMenus do: [:embeddedMenu | embeddedMenu selectedItem ifNotNil: [:item | item invokeWithEvent: anEvent. ^true ] ]. ^false! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 12/2/2010 16:52'! choiceMenus "Answer the value of choiceMenus" ^ choiceMenus ifNil: [#()] ! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 12:21'! newButtons "Answer new buttons as appropriate." self filterMorph: self newFilterEntry. ^{self filterMorph. self newCancelButton}! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 7/5/2010 15:55'! selectFirstEnabledItem "Select the first enabled item in any of the embedded menus" |found| found := false. (self choiceMenus ifNil: [^self]) do: [:embeddedMenu | embeddedMenu selectItem: nil event: nil]. "clear selection in other menus" self choiceMenus do: [:embeddedMenu | (embeddedMenu selectMatch: self filter) ifNotNil: [:menuItem | found ifFalse: [ embeddedMenu selectItem: menuItem event: nil. self activeHand newKeyboardFocus: embeddedMenu. found := true]]]! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:45'! choice: anObject "Set the value of choice" choice := anObject! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/6/2009 13:13'! choicesMorph "Answer the value of choicesMorph" ^ choicesMorph! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 7/30/2009 17:15'! extent: aPoint "Make the choices area at least fill the scroll area." |m| super extent: aPoint. m := self choicesMorph. m ifNotNil: [m width: (m width max: self scrollPane width)]! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/27/2008 15:24'! filterMorph "Answer the value of filterMorph" ^ filterMorph! ! !PopupChoiceDialogWindow methodsFor: 'event handling' stamp: 'gvc 7/30/2009 12:44'! handlesKeyboard: evt "True when either the filter morph doesn't have the focus and the key is a text key or backspace or no menus have the focus and is up or down arrow." ^(super handlesKeyboard: evt) or: [ (self choiceMenus anySatisfy: [:m | m hasKeyboardFocus]) ifTrue: [evt keyCharacter = Character backspace or: [evt keyCharacter > Character space or: [evt keyCharacter = Character cr or: [evt keyCharacter = Character arrowLeft or: [evt keyCharacter = Character arrowRight]]]]] ifFalse: [evt keyCharacter = Character arrowUp or: [evt keyCharacter = Character arrowDown or: [self filterMorph hasKeyboardFocus not]]]]! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2009 13:12'! newChoicesMorph "Answer a row of columns of buttons and separators based on the model." |answer morphs str maxLines| answer := self newRow cellPositioning: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap. self labels ifEmpty: [^answer]. maxLines := Display height - 100 // 2 // (self newChoiceButtonFor: 1) height. morphs := OrderedCollection new. 1 to: self labels size do: [:i | morphs add: (self newChoiceButtonFor: i). (self lines includes: i) ifTrue: [ morphs add: self newSeparator]]. str := morphs readStream. [str atEnd] whileFalse: [ answer addMorphBack: (self newMenuWith: (str next: maxLines)); addMorphBack: self newVerticalSeparator]. answer removeMorph: answer submorphs last. answer submorphs last hResizing: #spaceFill. self choiceMenus: (answer submorphs select: [:m| m isKindOf: MenuMorph]). ^answer! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'GaryChambers 7/5/2010 15:55'! selectLastEnabledItem "Select the last enabled item in any of the embedded menus" |found| found := false. (self choiceMenus ifNil: [^self]) do: [:embeddedMenu | embeddedMenu selectItem: nil event: nil]. "clear selection in other menus" self choiceMenus reverseDo: [:embeddedMenu | (embeddedMenu selectLastMatch: self filter) ifNotNil: [:menuItem | found ifFalse: [ embeddedMenu selectItem: menuItem event: nil. self activeHand newKeyboardFocus: embeddedMenu. found := true]]]! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 13:27'! activate: evt "Backstop." ! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 11/25/2010 14:26'! newFilterEntry "Answer a new filter entry field." |entry| entry := self newAutoAcceptTextEntryFor: self getText: #filter setText: #filter: getEnabled: nil help: 'Filters the options according to a matching substring' translated. entry acceptOnCR: false. entry textMorph crAction: (MessageSend receiver: self selector: #ok). ^entry ! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 16:27'! newChoiceButtonFor: index "Answer a new choice button." ^(ToggleMenuItemMorph new contents: (self labels at: index) asString; target: self; selector: #choose:; arguments: {index}; getStateSelector: nil; enablementSelector: nil) cornerStyle: #square; hResizing: #spaceFill ! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 14:24'! newMenuWith: morphs "Answer menu with the given morphs." ^(self newEmbeddedMenu addAllMorphs: morphs) borderWidth: 0; removeDropShadow; color: Color transparent; hResizing: #spaceFill; cornerStyle: #square; stayUp: true; beSticky; popUpOwner: (MenuItemMorph new privateOwner: self)! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/4/2008 15:43'! choiceMenus: anObject "Set the value of choiceMenus" choiceMenus := anObject! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! labels: anObject "Set the value of labels" labels := anObject! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/27/2008 15:24'! filterMorph: anObject "Set the value of filterMorph" filterMorph := anObject! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 12:23'! deleteIfPopUp: evt "For compatibility with MenuMorph."! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 16:07'! scrollPane "Answer the scroll pane." ^self findDeeplyA: GeneralScrollPane! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 12/2/2010 16:57'! filter: aString "Set the value of filter, used to match the valid choices." filter := aString. self changed: #filter. self filterMorph ifNil: [^self]. (self choiceMenus ifNil: [^self]) do: [:embeddedMenu | embeddedMenu selectItem: nil event: nil]. "clear selection in other menus" self choiceMenus do: [:embeddedMenu | embeddedMenu selectMatch: self filter asLowercase]. self filterMorph hasKeyboardFocus ifFalse: [ self activeHand newKeyboardFocus: self filterMorph. self filterMorph selectFrom: filter size + 1 to: filter size + 1]! ! !PopupChoiceDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallQuestionIcon! ! !PopupChoiceDialogWindowWithMessage commentStamp: 'LaurentLaffont 3/4/2011 22:43'! I'm a dialog which ask the user to select a element in a list. See me in action: UIManager default inform: (UIManager default chooseFrom: #(one two three) values: #('1' '2' '3') message: 'Select one' title: 'PopupChoiceDialogWindowWithMessage example').! !PopupChoiceDialogWindowWithMessage methodsFor: 'as yet unclassified' stamp: 'gvc 2/6/2009 13:41'! initialExtent "Answer the initial extent for the receiver. Adjust the text if the text would be wider than 1/2 the display width." |ext| ext := super initialExtent. self textMorph width > (Display width // 2) ifTrue: [ self textMorph wrapFlag: true; hResizing: #rigid; extent: Display width // 2 @ 0. ext := super initialExtent]. ^ext! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:34'! iconMorph: anObject "Set the value of iconMorph" iconMorph := anObject! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'as yet unclassified' stamp: 'alain.plantec 2/6/2009 10:04'! newContentMorph | top bottom | self textMorph: self newTextMorph. self text: self message. self iconMorph: self newIconMorph. top := self newRow: {self iconMorph. self textMorph}. bottom := super newContentMorph. ^ self newGroupboxFor: (self newColumn: {top. bottom}).! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 10:08'! message: aStringOrText message := aStringOrText! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:34'! textMorph: anObject "Set the value of textMorph" textMorph := anObject! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 5/23/2013 18:39'! newIconMorph "Answer an icon for the receiver." ^ImageMorph new form: self icon! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'gvc 7/30/2009 14:07'! text: aStringOrText "Set the text." |t| t := aStringOrText isString ifTrue: [aStringOrText asText addAttribute: (TextFontReference toFont: self textFont); yourself] ifFalse: [aStringOrText]. t addAttribute: TextAlignment centered. self textMorph newContents: t! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'as yet unclassified' stamp: 'alain.plantec 2/6/2009 09:32'! newTextMorph "Answer a text morph." ^self newText: ''! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:41'! textFont "Answer the text font." ^textFont! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:35'! iconMorph "Answer the value of iconMorph" ^ iconMorph! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:34'! textMorph "Answer the value of textMorph" ^ textMorph! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 10:08'! message ^ message! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 09:41'! textFont: aFont "Set the text font." textFont := aFont! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon "Answer an icon for the receiver." ^ Smalltalk ui icons questionIcon! ! !PopupChoiceOrRequestDialogWindow methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/21/2009 12:34'! extent: aPoint "Make the choices area at least fill the scroll area." ^super extent: (aPoint x max: self class minWidth)@(aPoint y).! ! !PopupChoiceOrRequestDialogWindow methodsFor: 'accessing' stamp: 'GaryChambers 7/5/2010 16:01'! filterValue ^filter isEmpty ifTrue: [ nil ] ifFalse: [ filter ]! ! !PopupChoiceOrRequestDialogWindow methodsFor: 'event handling' stamp: 'AlainPlantec 11/22/2010 12:33'! processEnter: anEvent (super processEnter: anEvent) ifFalse: [ self okButton performAction ]. ^true! ! !PopupChoiceOrRequestDialogWindow methodsFor: 'private' stamp: 'EstebanLorenzano 11/21/2009 12:19'! okButton: aMorph okButton := aMorph! ! !PopupChoiceOrRequestDialogWindow methodsFor: 'initialization' stamp: 'EstebanLorenzano 11/21/2009 12:18'! newButtons "Answer new buttons as appropriate." self filterMorph: self newFilterEntry. self okButton: self newOKButton. ^Array with: self filterMorph with: self okButton with: self newCancelButton! ! !PopupChoiceOrRequestDialogWindow methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/21/2009 12:19'! okButton ^okButton! ! !PopupChoiceOrRequestDialogWindow methodsFor: 'accessing' stamp: 'GaryChambers 7/5/2010 15:58'! filter: aString "Set the value of filter used to match the choices. Clear any selected items here so that potential requests for non-listed items can be handled." super filter: aString. (self choiceMenus ifNil: [^self]) do: [:embeddedMenu | embeddedMenu selectItem: nil event: nil]. "clear selection in other menus" ! ! !PopupChoiceOrRequestDialogWindow class methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 11/21/2009 12:34'! minWidth ^250! ! !PositionableStream commentStamp: ''! I represent an accessor for a sequence of objects (a collection) that are externally named by indices so that the point of access can be repositioned. I am abstract in that I do not implement the messages next and nextPut: which are inherited from my superclass Stream.! !PositionableStream methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:12'! originalContents "Answer the receiver's actual contents collection, NOT a copy." ^ collection! ! !PositionableStream methodsFor: '*System-Changes' stamp: 'tk 12/29/97 12:37'! skipStyleChunk "Get to the start of the next chunk that is not a style for the previous chunk" | pos | pos := self position. self skipSeparators. self peek == $] ifTrue: [(self upTo: $[) = ']text' "old -- no longer needed" "now positioned past the open bracket" ifFalse: [self nextChunk]] "absorb ]style[ and its whole chunk" ifFalse: [self position: pos] "leave untouched" ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'! uint16 "Answer the next unsigned, 16-bit integer from this (binary) stream." | n | n := self next. n := (n bitShift: 8) + (self next). ^ n ! ! !PositionableStream methodsFor: '*System-Changes' stamp: ''! trailer "If the stream requires a standard trailer, override this message. See HtmlFileStream"! ! !PositionableStream methodsFor: 'accessing' stamp: 'nice 12/7/2009 08:40'! nextLine "Answer next line (may be empty) without line end delimiters, or nil if at end. Let the stream positioned after the line delimiter(s). Handle a zoo of line delimiters CR, LF, or CR-LF pair" self atEnd ifTrue: [^nil]. ^self upToAnyOf: CharacterSet crlf do: [:char | char = Character cr ifTrue: [self peekFor: Character lf]]! ! !PositionableStream methodsFor: 'positioning' stamp: 'SeanDeNigris 6/21/2012 08:42'! untilEnd: aBlock displayingProgress: aString aString displayProgressFrom: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar current: self position. aBlock value]].! ! !PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:53'! nextInto: aCollection "Read the next elements of the receiver into aCollection. Return aCollection or a partial copy if less than aCollection size elements have been read." ^self next: aCollection size into: aCollection startingAt: 1.! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'tk 6/8/1998 21:01'! nextStringOld "Read a string from the receiver. The first byte is the length of the string, unless it is greater than 192, in which case the first *two* bytes encode the length. Max size 16K. " | aString length | length := self next. "first byte." length >= 192 ifTrue: [length := (length - 192) * 256 + self next]. aString := String new: length. 1 to: length do: [:ii | aString at: ii put: self next asCharacter]. ^aString! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'! nextWordPut: aWord "Append to the receiver an Integer as the next two bytes." self nextPut: ((aWord bitShift: -8) bitAnd: 255). self nextPut: (aWord bitAnd: 255). ^aWord! ! !PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:58'! next: n into: aCollection "Read n objects into the given collection. Return aCollection or a partial copy if less than n elements have been read." ^self next: n into: aCollection startingAt: 1! ! !PositionableStream methodsFor: 'testing' stamp: 'ar 1/2/2000 17:24'! isBinary "Return true if the receiver is a binary byte stream" ^collection class == ByteArray! ! !PositionableStream methodsFor: 'accessing' stamp: ''! peekFor: anObject "Answer false and do not move over the next element if it is not equal to the argument, anObject, or if the receiver is at the end. Answer true and increment the position for accessing elements, if the next element is equal to anObject." | nextObject | self atEnd ifTrue: [^false]. nextObject := self next. "peek for matching element" anObject = nextObject ifTrue: [^true]. "gobble it if found" position := position - 1. ^false! ! !PositionableStream methodsFor: 'positioning' stamp: 'damiencassou 5/30/2008 11:45'! backUpTo: subCollection "Back up the position to he subCollection. Position must be somewhere within the stream initially. Leave it just after it. Return true if succeeded. No wildcards, and case does matter." "Example: | strm | strm := ReadStream on: 'zabc abdc'. strm setToEnd; backUpTo: 'abc'; position " | pattern startMatch | pattern := subCollection reversed readStream. startMatch := nil. [ pattern atEnd ] whileFalse: [ self position = 0 ifTrue: [ ^ false ]. self skip: -1. self next = pattern next ifTrue: [ pattern position = 1 ifTrue: [ startMatch := self position ] ] ifFalse: [ pattern position: 0. startMatch ifNotNil: [ self position: startMatch - 1. startMatch := nil ] ]. self skip: -1 ]. self position: startMatch. ^ true! ! !PositionableStream methodsFor: 'accessing' stamp: 'sw 3/10/98 13:55'! contentsOfEntireFile "For non-file streams" ^ self contents! ! !PositionableStream methodsFor: 'positioning' stamp: 'damiencassou 5/30/2008 11:45'! match: subCollection "Set the access position of the receiver to be past the next occurrence of the subCollection. Answer whether subCollection is found. No wildcards, and case does matter." | pattern startMatch | pattern := subCollection readStream. startMatch := nil. [ pattern atEnd ] whileFalse: [ self atEnd ifTrue: [ ^ false ]. self next = pattern next ifTrue: [ pattern position = 1 ifTrue: [ startMatch := self position ] ] ifFalse: [ pattern position: 0. startMatch ifNotNil: [ self position: startMatch. startMatch := nil ] ] ]. ^ true! ! !PositionableStream methodsFor: 'positioning' stamp: 'nice 3/10/2008 22:29'! position: anInteger "Set the current position for accessing the objects to be anInteger, as long as anInteger is within the bounds of the receiver's contents. If it is not, create an error notification." (anInteger >= 0 and: [anInteger <= readLimit]) ifTrue: [position := anInteger] ifFalse: [self positionError]! ! !PositionableStream methodsFor: '*System-Changes' stamp: 'StephaneDucasse 9/12/2010 09:45'! copyMethodChunkFrom: aStream at: pos "Copy the next chunk from aStream (must be different from the receiver)." aStream position: pos. self nextChunkPut: aStream nextChunkText.! ! !PositionableStream methodsFor: '*System-Changes' stamp: ''! verbatim: aString "Do not attempt to translate the characters. Use to override nextPutAll:" ^ self nextPutAll: aString! ! !PositionableStream methodsFor: 'data get/put' stamp: 'ClementBera 9/30/2013 10:57'! uint32: anInteger "Store the given unsigned, 32-bit integer on this (binary) stream." (anInteger < 0 or: [ anInteger >= 16r100000000 ]) ifTrue: [self error: 'outside unsigned 32-bit integer range']. self nextPut: (anInteger digitAt: 4). self nextPut: (anInteger digitAt: 3). self nextPut: (anInteger digitAt: 2). self nextPut: (anInteger digitAt: 1). ! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'stephane.ducasse 4/13/2009 20:31'! nextLittleEndianNumber: n put: value "Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant." | bytes | bytes := ByteArray new: n. 1 to: n do: [:i | bytes at: i put: (value digitAt: i)]. self nextPutAll: bytes! ! !PositionableStream methodsFor: 'private' stamp: ''! on: aCollection collection := aCollection. readLimit := aCollection size. position := 0. self reset! ! !PositionableStream methodsFor: '*System-Changes' stamp: 'PeterHugossonMiller 9/3/2009 10:20'! backChunk "Answer the contents of the receiver back to the previous terminator character. Doubled terminators indicate an embedded terminator character." | terminator out ch | terminator := $!!. out := (String new: 1000) writeStream. [(ch := self back) == nil] whileFalse: [ (ch == terminator) ifTrue: [ self oldPeekBack == terminator ifTrue: [ self oldBack. "skip doubled terminator" ] ifFalse: [ ^ out contents reversed "we're done!!" ]. ]. out nextPut: ch. ]. ^ out contents reversed! ! !PositionableStream methodsFor: 'data get/put' stamp: 'ClementBera 9/30/2013 10:56'! int16: anInteger "Store the given signed, 16-bit integer on this (binary) stream." | n | ((anInteger < -16r8000) or: [anInteger >= 16r8000]) ifTrue: [self error: 'outside 16-bit integer range']. anInteger < 0 ifTrue: [n := 16r10000 + anInteger] ifFalse: [n := anInteger]. self nextPut: (n digitAt: 2). self nextPut: (n digitAt: 1). ! ! !PositionableStream methodsFor: 'accessing' stamp: ''! peek "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil." | nextObject | self atEnd ifTrue: [^nil]. nextObject := self next. position := position - 1. ^nextObject! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'! nextNumber: n put: v "Append to the receiver the argument, v, which is a positive SmallInteger or a LargePositiveInteger, as the next n bytes. Possibly pad with leading zeros." 1 to: n do: [:i | self nextPut: (v digitAt: n+1-i)]. ^ v ! ! !PositionableStream methodsFor: 'accessing' stamp: 'pavel.krivanek 3/12/2009 11:01'! oldBack "Go back one element and return it. Use indirect messages in case I am a StandardFileStream" "The method is a misconception about what a stream is. A stream contains a pointer *between* elements with past and future elements. This method considers that the pointer is *on* an element. Please consider unit tests which verifies #back and #oldBack behavior. (Damien Cassou - 1 August 2007)" self position = 0 ifTrue: [self positionError]. self position = 1 ifTrue: [self position: 0. ^ nil]. self skip: -2. ^ self next ! ! !PositionableStream methodsFor: '*System-Changes' stamp: 'MarcusDenker 5/8/2013 19:26'! decodeString: string andRuns: runsRaw | strm runLength runValues newString index | strm := ReadStream on: runsRaw from: 1 to: runsRaw size. (strm peekFor: $() ifFalse: [ ^ nil ]. runLength := OrderedCollection new. [ strm skipSeparators. strm peekFor: $) ] whileFalse: [ runLength add: (Number readFrom: strm) ]. runValues := OrderedCollection new. [ strm atEnd ] whileFalse: [ runValues add: (Number readFrom: strm). strm next ]. newString := WideString new: string size. index := 1. runLength with: runValues do: [ :length :leadingChar | index to: index + length - 1 do: [ :pos | newString at: pos put: (Character leadingChar: leadingChar code: (string at: pos) charCode) ]. index := index + length ]. ^ newString! ! !PositionableStream methodsFor: 'accessing' stamp: 'ar 1/2/2000 15:32'! next: anInteger putAll: aCollection "Store the next anInteger elements from the given collection." ^self next: anInteger putAll: aCollection startingAt: 1! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 9/5/2001 12:09'! string: aString "Store the given string on this (binary) stream. The string must contain 65535 or fewer characters." aString size > 16rFFFF ifTrue: [self error: 'string too long for this format']. self uint16: aString size. self nextPutAll: aString asByteArray. ! ! !PositionableStream methodsFor: 'testing' stamp: 'damiencassou 5/15/2009 15:06'! isEmpty "Answer whether the receiver's contents has no elements." "Returns true if both the set of past and future sequence values of the receiver are empty. Otherwise returns false" ^ self atEnd and: [position = 0]! ! !PositionableStream methodsFor: '*System-Changes' stamp: 'sumim 11/20/2003 18:13'! nextChunkText "Deliver the next chunk as a Text. Decode the following ]style[ chunk if present. Position at start of next real chunk." | string runsRaw strm runs peek pos | "Read the plain text" string := self nextChunk. "Test for ]style[ tag" pos := self position. peek := self skipSeparatorsAndPeekNext. peek = $] ifFalse: [self position: pos. ^ string asText]. "no tag" (self upTo: $[) = ']style' ifFalse: [self position: pos. ^ string asText]. "different tag" "Read and decode the style chunk" runsRaw := self basicNextChunk. "style encoding" strm := ReadStream on: runsRaw from: 1 to: runsRaw size. runs := RunArray scanFrom: strm. ^ Text basicNew setString: string setRunsChecking: runs. ! ! !PositionableStream methodsFor: 'positioning' stamp: ''! reset "Set the receiver's position to the beginning of the sequence of objects." position := 0! ! !PositionableStream methodsFor: 'accessing' stamp: 'sw 3/10/98 13:55'! next: anInteger "Answer the next anInteger elements of my collection. Must override because default uses self contents species, which might involve a large collection." | newArray | newArray := collection species new: anInteger. 1 to: anInteger do: [:index | newArray at: index put: self next]. ^newArray! ! !PositionableStream methodsFor: 'positioning' stamp: 'sw 3/10/98 13:55'! resetContents "Set the position and limits to 0." position := 0. readLimit := 0! ! !PositionableStream methodsFor: 'accessing' stamp: 'StephaneDucasse 10/25/2013 16:18'! nextWordsInto: aBitmap "Fill the word based buffer from my collection. Stored on stream as Big Endian. Optimized for speed. Read in BigEndian, then restoreEndianness." | blt pos source byteSize | collection class isBytes ifFalse: [^ self next: aBitmap size into: aBitmap startingAt: 1]. byteSize := aBitmap byteSize. "is the test on collection basicSize \\ 4 necessary?" ((self position bitAnd: 3) = 0 and: [ (collection basicSize bitAnd: 3) = 0]) ifTrue: [source := collection. pos := self position. self skip: byteSize] ifFalse: ["forced to copy it into a buffer" source := self next: byteSize. pos := 0]. "Now use BitBlt to copy the bytes to the bitmap." blt := (BitBlt toForm: (Form new hackBits: aBitmap)) sourceForm: (Form new hackBits: source). blt combinationRule: Form over. "store" blt sourceX: 0; sourceY: pos // 4; height: byteSize // 4; width: 4. blt destX: 0; destY: 0. blt copyBits. "And do whatever the bitmap needs to do to convert from big-endian order." aBitmap restoreEndianness. ^ aBitmap "May be WordArray, ColorArray, etc" ! ! !PositionableStream methodsFor: 'accessing' stamp: 'pavel.krivanek 3/12/2009 11:01'! back "Go back one element and return it." self position = 0 ifTrue: [self positionError]. self skip: -1. ^ self peek! ! !PositionableStream methodsFor: 'accessing' stamp: 'nice 12/7/2009 08:30'! upToAnyOf: subcollection do: aBlock "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of any object in the collection. Evaluate aBlock with this occurence as argument. If no matching object is found, don't evaluate aBlock and answer the entire rest of the receiver." ^self collectionSpecies new: 1000 streamContents: [ :stream | | ch | [ self atEnd or: [ (subcollection includes: (ch := self next)) and: [aBlock value: ch. true] ] ] whileFalse: [ stream nextPut: ch ] ]! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'! nextWord "Answer the next two bytes from the receiver as an Integer." | high low | high := self next. high==nil ifTrue: [^false]. low := self next. low==nil ifTrue: [^false]. ^(high asInteger bitShift: 8) + low asInteger! ! !PositionableStream methodsFor: 'data get/put' stamp: 'ClementBera 9/30/2013 10:57'! uint24: anInteger "Store the given unsigned, 24-bit integer on this (binary) stream." (anInteger < 0 or: [ anInteger >= 16r1000000 ]) ifTrue: [self error: 'outside unsigned 24-bit integer range']. self nextPut: (anInteger digitAt: 3). self nextPut: (anInteger digitAt: 2). self nextPut: (anInteger digitAt: 1). ! ! !PositionableStream methodsFor: 'accessing' stamp: 'nice 12/7/2009 08:38'! upToAnyOf: aCollection "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of any object in the collection. If no matching object is found, answer the entire rest of the receiver." ^self upToAnyOf: aCollection do: [:matchingObject | ]! ! !PositionableStream methodsFor: 'private' stamp: ''! setFrom: newStart to: newStop position := newStart - 1. readLimit := newStop! ! !PositionableStream methodsFor: 'positioning' stamp: ''! position "Answer the current position of accessing the sequence of objects." ^position! ! !PositionableStream methodsFor: '*System-Changes' stamp: 'StephaneDucasse 9/12/2010 09:45'! copyMethodChunkFrom: aStream "Copy the next chunk from aStream (must be different from the receiver)." self nextChunkPut: aStream nextChunkText! ! !PositionableStream methodsFor: 'private' stamp: ''! positionError "Since I am not necessarily writable, it is up to my subclasses to override position: if expanding the collection is preferrable to giving this error." self error: 'Attempt to set the position of a PositionableStream out of bounds'! ! !PositionableStream methodsFor: 'converting' stamp: 'tk 2/7/2000 11:08'! asBinaryOrTextStream "Convert to a stream that can switch between bytes and characters" ^ (RWBinaryOrTextStream with: self contentsOfEntireFile) reset! ! !PositionableStream methodsFor: '*System-Changes' stamp: 'sumim 11/20/2003 18:11'! parseLangTagFor: aString | string peek runsRaw pos | string := aString. "Test for ]lang[ tag" pos := self position. peek := self skipSeparatorsAndPeekNext. peek = $] ifFalse: [self position: pos. ^ string]. "no tag" (self upTo: $[) = ']lang' ifTrue: [ runsRaw := self basicNextChunk. string := self decodeString: aString andRuns: runsRaw ] ifFalse: [ self position: pos ]. ^ string. ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 10/5/2001 12:11'! boolean: aBoolean "Store the given boolean value on this (binary) stream." self nextPut: (aBoolean ifTrue: [1] ifFalse: [0]). ! ! !PositionableStream methodsFor: 'positioning' stamp: ''! skip: anInteger "Set the receiver's position to be the current position+anInteger. A subclass might choose to be more helpful and select the minimum of the receiver's size and position+anInteger, or the maximum of 1 and position+anInteger for the repositioning." self position: position + anInteger! ! !PositionableStream methodsFor: '*System-Changes' stamp: 'sd 5/23/2003 14:40'! checkForPreamble: chunk ((chunk beginsWith: '"Change Set:') and: [ChangeSet current preambleString == nil]) ifTrue: [ChangeSet current preambleString: chunk]. ((chunk beginsWith: '"Postscript:') and: [ChangeSet current postscriptString == nil]) ifTrue: [ChangeSet current postscriptString: chunk]. ! ! !PositionableStream methodsFor: 'accessing' stamp: 'tk 7/18/1999 17:10'! upToAll: aCollection "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aCollection. If aCollection is not in the stream, answer the entire rest of the stream." | startPos endMatch result | startPos := self position. (self match: aCollection) ifTrue: [endMatch := self position. self position: startPos. result := self next: endMatch - startPos - aCollection size. self position: endMatch. ^ result] ifFalse: [self position: startPos. ^ self upToEnd]! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:02'! peekBack "Return the element at the previous position, without changing position. Use indirect messages in case self is a StandardFileStream." | element | element := self back. self skip: 1. ^ element! ! !PositionableStream methodsFor: 'private' stamp: 'nice 11/22/2009 18:03'! collectionSpecies "Answer the species of collection into which the receiver can stream" ^collection species! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:43'! int16 "Answer the next signed, 16-bit integer from this (binary) stream." | n | n := self next. n := (n bitShift: 8) + (self next). n >= 16r8000 ifTrue: [n := n - 16r10000]. ^ n ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 9/5/2001 07:35'! string "Answer the next string from this (binary) stream." | size | size := self uint16. ^ (self next: size) asString ! ! !PositionableStream methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:51'! upToAny: aCollection "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of any objects in the given collection in the receiver. If any of these is not in the collection, answer the entire rest of the receiver." | newStream element | newStream := (collection species new: 100) writeStream. [self atEnd or: [aCollection includes: (element := self next)]] whileFalse: [newStream nextPut: element]. ^newStream contents! ! !PositionableStream methodsFor: 'positioning' stamp: ''! skipTo: anObject "Set the access position of the receiver to be past the next occurrence of anObject. Answer whether anObject is found." [self atEnd] whileFalse: [self next = anObject ifTrue: [^true]]. ^false! ! !PositionableStream methodsFor: '*System-Changes' stamp: ''! header "If the stream requires a standard header, override this message. See HtmlFileStream"! ! !PositionableStream methodsFor: 'positioning' stamp: 'tak 8/5/2005 10:34'! untilEndWithFork: aBlock displayingProgress: aString | sem done result | sem := Semaphore new. done := false. [[result := aBlock value] ensure: [done := true. sem signal]] fork. self untilEnd: [done ifTrue: [^ result]. (Delay forSeconds: 0.2) wait] displayingProgress: aString. sem wait. ^ result! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'! uint32 "Answer the next unsigned, 32-bit integer from this (binary) stream." | n | n := self next. n := (n bitShift: 8) + self next. n := (n bitShift: 8) + self next. n := (n bitShift: 8) + self next. ^ n ! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: ''! nextNumber: n "Answer the next n bytes as a positive Integer or LargePositiveInteger." | s | s := 0. 1 to: n do: [:i | s := (s bitShift: 8) bitOr: self next asInteger]. ^ s normalize! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'jm 4/9/98 21:36'! nextLittleEndianNumber: n "Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant." | bytes s | bytes := self next: n. s := 0. n to: 1 by: -1 do: [:i | s := (s bitShift: 8) bitOr: (bytes at: i)]. ^ s ! ! !PositionableStream methodsFor: 'positioning' stamp: 'di 5/25/1998 15:16'! padToNextLongPut: char "Make position be on long word boundary, writing the padding character, char, if necessary." [self position \\ 4 = 0] whileFalse: [self nextPut: char]! ! !PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:59'! nextInto: aCollection startingAt: startIndex "Read the next elements of the receiver into aCollection. Return aCollection or a partial copy if less than aCollection size elements have been read." ^self next: (aCollection size - startIndex+1) into: aCollection startingAt: startIndex.! ! !PositionableStream methodsFor: 'data get/put' stamp: 'ClementBera 9/30/2013 10:56'! int32: anInteger "Store the given signed, 32-bit integer on this (binary) stream." | n | (anInteger < -16r80000000 or: [anInteger >= 16r80000000]) ifTrue: [self error: 'outside 32-bit integer range']. anInteger < 0 ifTrue: [n := 16r100000000 + anInteger] ifFalse: [n := anInteger]. self nextPut: (n digitAt: 4). self nextPut: (n digitAt: 3). self nextPut: (n digitAt: 2). self nextPut: (n digitAt: 1). ! ! !PositionableStream methodsFor: '*System-Changes' stamp: 'PeterHugossonMiller 9/3/2009 10:43'! basicNextChunk "Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character." | terminator out ch | terminator := $!!. out := (String new: 1000) writeStream. self skipSeparators. [(ch := self next) == nil] whileFalse: [ (ch == terminator) ifTrue: [ self peek == terminator ifTrue: [ self next. "skip doubled terminator" ] ifFalse: [ ^ out contents "terminator is not doubled; we're done!!" ]. ]. out nextPut: ch. ]. ^ out contents! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'yo 4/16/2001 17:56'! nextStringPut: s "Append the string, s, to the receiver. Only used by DataStream. Max size of 64*256*256*256." | length | (length := s size) < 192 ifTrue: [self nextPut: length] ifFalse: [self nextPut: (length digitAt: 4)+192. self nextPut: (length digitAt: 3). self nextPut: (length digitAt: 2). self nextPut: (length digitAt: 1)]. self nextPutAll: s asByteArray. ^s! ! !PositionableStream methodsFor: 'accessing' stamp: 'damiencassou 11/23/2008 17:04'! oldPeekBack "Return the element at the previous position, without changing position. Use indirect messages in case self is a StandardFileStream." "The method is a misconception about what a stream is. A stream contains a pointer *between* elements with past and future elements. This method considers that the pointer is *on* an element. Please consider unit tests which verifies #peekBack and #oldPeekBack behavior. (Damien Cassou - 1 August 2007)" | element | element := self oldBack. self skip: 1. ^ element ! ! !PositionableStream methodsFor: 'public' stamp: 'di 6/13/97 12:00'! skipSeparators [self atEnd] whileFalse: [self next isSeparator ifFalse: [^ self position: self position-1]]! ! !PositionableStream methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:50'! nextDelimited: terminator "Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character. For example: 'this '' was a quote'. Start postioned before the initial terminator." | out ch | out := (String new: 1000) writeStream. self atEnd ifTrue: [^ '']. self next == terminator ifFalse: [self skip: -1]. "absorb initial terminator" [(ch := self next) == nil] whileFalse: [ (ch == terminator) ifTrue: [ self peek == terminator ifTrue: [ self next. "skip doubled terminator" ] ifFalse: [ ^ out contents "terminator is not doubled; we're done!!" ]. ]. out nextPut: ch. ]. ^ out contents! ! !PositionableStream methodsFor: 'positioning' stamp: 'damiencassou 5/30/2008 11:45'! positionOfSubCollection: subCollection ifAbsent: exceptionBlock "Return a position such that that element at the new position equals the first element of sub, and the next elements equal the rest of the elements of sub. Begin the search at the current position. If no such match is found, answer the result of evaluating argument, exceptionBlock." | pattern startPosition currentPosition | pattern := subCollection readStream. startPosition := self position. [ pattern atEnd ] whileFalse: [ self atEnd ifTrue: [ ^ exceptionBlock value ]. self next = pattern next ifFalse: [ self position: self position - pattern position + 1. pattern reset ] ]. currentPosition := self position. self position: startPosition. ^ pattern atEnd ifTrue: [ currentPosition + 1 - subCollection size ] ifFalse: [ exceptionBlock value ]! ! !PositionableStream methodsFor: 'public' stamp: 'di 1/13/98 16:08'! skipSeparatorsAndPeekNext "A special function to make nextChunk fast" | peek | [self atEnd] whileFalse: [(peek := self next) isSeparator ifFalse: [self position: self position-1. ^ peek]]! ! !PositionableStream methodsFor: '*System-Changes' stamp: 'SergeStinckwich 7/31/2009 15:25'! copyPreamble: preamble from: aStream at: pos "Look for a changeStamp for this method by peeking backward. Write a method preamble, with that stamp if found." | terminator last50 stamp i | terminator := $!!. "Look back to find stamp in old preamble, such as... Polygon methodsFor: 'private' stamp: 'di 6/25/97 21:42' prior: 34957598!! " aStream position: pos. aStream backChunk. "to beginning of method" last50 := aStream backChunk. "to get preamble" aStream position: pos. stamp := String new. (i := last50 findLastOccurrenceOfString: 'stamp:' startingAt: 1) > 0 ifTrue: [ stamp := (last50 copyFrom: i + 8 to: last50 size) copyUpTo: $' ]. "Write the new preamble, with old stamp if any." self cr; nextPut: terminator. self nextChunkPut: (String streamContents: [ :strm | strm nextPutAll: preamble. stamp size > 0 ifTrue: [ strm nextPutAll: ' stamp: '; print: stamp ] ]). self cr! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 10/5/2001 12:09'! boolean "Answer the next boolean value from this (binary) stream." ^ self next ~= 0 ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 08:07'! uint24 "Answer the next unsigned, 24-bit integer from this (binary) stream." | n | n := self next. n := (n bitShift: 8) + self next. n := (n bitShift: 8) + self next. ^ n ! ! !PositionableStream methodsFor: 'positioning' stamp: ''! setToEnd "Set the position of the receiver to the end of the sequence of objects." position := readLimit! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'yo 3/1/2005 06:03'! nextString "Read a string from the receiver. The first byte is the length of the string, unless it is greater than 192, in which case the first four bytes encode the length. I expect to be in ascii mode when called (caller puts back to binary)." | length aByteArray | "read the length in binary mode" self binary. length := self next. "first byte." length >= 192 ifTrue: [length := length - 192. 1 to: 3 do: [:ii | length := length * 256 + self next]]. aByteArray := ByteArray new: length. self nextInto: aByteArray. ^aByteArray asString. ! ! !PositionableStream methodsFor: 'positioning' stamp: 'mir 6/29/2004 17:35'! positionOfSubCollection: subCollection "Return a position such that that element at the new position equals the first element of sub, and the next elements equal the rest of the elements of sub. Begin the search at the current position. If no such match is found, answer 0." ^self positionOfSubCollection: subCollection ifAbsent: [0]! ! !PositionableStream methodsFor: '*Fuel' stamp: 'StephaneDucasse 10/25/2013 16:18'! fuelNextWordsInto: aWordObject "This method is the same as nextWordsInto: but the restoreEndianness is only done if needed" | blt pos source byteSize | byteSize := aWordObject byteSize. "is the test on collection basicSize \\ 4 necessary?" ((self position bitAnd: 3) = 0 and: [ (collection basicSize bitAnd: 3) = 0]) ifTrue: [source := collection. pos := self position. self skip: byteSize] ifFalse: ["forced to copy it into a buffer" source := self next: byteSize. pos := 0]. "Now use BitBlt to copy the bytes to the bitmap." blt := (BitBlt toForm: (Form new hackBits: aWordObject)) sourceForm: (Form new hackBits: source). blt combinationRule: Form over. "store" blt sourceX: 0; sourceY: pos // 4; height: byteSize // 4; width: 4. blt destX: 0; destY: 0. blt copyBits. ^ aWordObject ! ! !PositionableStream methodsFor: 'positioning' stamp: 'mir 5/14/2003 18:45'! pushBack: aString "Compatibility with SocketStreams" self skip: aString size negated! ! !PositionableStream methodsFor: 'testing' stamp: ''! atEnd "Primitive. Answer whether the receiver can access any more objects. Optional. See Object documentation whatIsAPrimitive." ^position >= readLimit! ! !PositionableStream methodsFor: 'data get/put' stamp: 'ClementBera 9/30/2013 10:57'! uint16: anInteger "Store the given unsigned, 16-bit integer on this (binary) stream." (anInteger < 0 or: [ anInteger >= 16r10000 ]) ifTrue: [self error: 'outside unsigned 16-bit integer range']. self nextPut: (anInteger digitAt: 2). self nextPut: (anInteger digitAt: 1). ! ! !PositionableStream methodsFor: '*System-Changes' stamp: 'PeterHugossonMiller 9/3/2009 10:43'! nextChunk "Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character." | terminator out ch | terminator := $!!. out := (String new: 1000) writeStream. self skipSeparators. [(ch := self next) == nil] whileFalse: [ (ch == terminator) ifTrue: [ self peek == terminator ifTrue: [ self next. "skip doubled terminator" ] ifFalse: [ ^ self parseLangTagFor: out contents "terminator is not doubled; we're done!!" ]. ]. out nextPut: ch. ]. ^ self parseLangTagFor: out contents. ! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'! nextInt32Put: int32 "Write a signed integer to the next 4 bytes" | pos | pos := int32 < 0 ifTrue: [(0-int32) bitInvert32 + 1] ifFalse: [int32]. 1 to: 4 do: [:i | self nextPut: (pos digitAt: 5-i)]. ^ int32! ! !PositionableStream methodsFor: 'positioning' stamp: 'di 2/15/98 14:41'! padTo: nBytes put: aCharacter "Pad using the argument, aCharacter, to the next boundary of nBytes characters." | rem | rem := nBytes - (self position \\ nBytes). rem = nBytes ifTrue: [^ 0]. self next: rem put: aCharacter.! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'! nextInt32 "Read a 32-bit signed integer from the next 4 bytes" | s | s := 0. 1 to: 4 do: [:i | s := (s bitShift: 8) + self next]. (s bitAnd: 16r80000000) = 0 ifTrue: [^ s] ifFalse: [^ -1 - s bitInvert32]! ! !PositionableStream methodsFor: '*Compression' stamp: 'ar 1/2/2000 15:32'! asZLibReadStream ^ZLibReadStream on: collection from: position+1 to: readLimit! ! !PositionableStream methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:51'! upTo: anObject "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of anObject in the receiver. If anObject is not in the collection, answer the entire rest of the receiver." | newStream element | newStream := (collection species new: 100) writeStream. [self atEnd or: [(element := self next) = anObject]] whileFalse: [newStream nextPut: element]. ^newStream contents! ! !PositionableStream methodsFor: 'accessing' stamp: 'PeterHugossonMiller 9/3/2009 10:51'! upToEnd "Answer a subcollection from the current access position through the last element of the receiver." | newStream | newStream := (collection species new: 100) writeStream. [self atEnd] whileFalse: [ newStream nextPut: self next ]. ^ newStream contents! ! !PositionableStream methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/26/2011 19:37'! next: requestedCount into: aCollection startingAt: startIndex "Read requestedCount objects into the given collection. Return aCollection or a partial copy if less elements have been read." | readCount | readCount := self readInto: aCollection startingAt: startIndex count: requestedCount. ^ readCount = requestedCount ifTrue: [ ^ aCollection ] ifFalse: [ ^ aCollection copyFrom: 1 to: startIndex + readCount - 1 ]! ! !PositionableStream methodsFor: 'accessing' stamp: ''! contents "Answer with a copy of my collection from 1 to readLimit." ^collection copyFrom: 1 to: readLimit! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 15:15'! int32 "Answer the next signed, 32-bit integer from this (binary) stream." "Details: As a fast check for negative number, check the high bit of the first digit" | n firstDigit | n := firstDigit := self next. n := (n bitShift: 8) + self next. n := (n bitShift: 8) + self next. n := (n bitShift: 8) + self next. firstDigit >= 128 ifTrue: [n := -16r100000000 + n]. "decode negative 32-bit integer" ^ n ! ! !PositionableStream methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/26/2011 09:26'! readInto: aCollection startingAt: startIndex count: n "Read n objects into the given collection. Return number of elements that have been read." | obj | 0 to: n - 1 do: [ :i | (obj := self next) == nil ifTrue: [ ^ i ]. aCollection at: startIndex + i put: obj ]. ^ n! ! !PositionableStream class methodsFor: '*FuelTests' stamp: 'MaxLeske 8/5/2013 09:00'! with: aCollectionOrStream do: aBlock "Evaluates a block with a new stream based on the collection or stream. Answers the result of the block evaluation. Follows the style of FileStream>>fileNamed:do:." | aStream | aStream := self on: aCollectionOrStream. [ ^ aBlock value: aStream ] ensure: [ aStream close ]! ! !PositionableStream class methodsFor: 'instance creation' stamp: ''! on: aCollection from: firstIndex to: lastIndex "Answer an instance of me, streaming over the elements of aCollection starting with the element at firstIndex and ending with the one at lastIndex." ^self basicNew on: (aCollection copyFrom: firstIndex to: lastIndex)! ! !PositionableStream class methodsFor: 'instance creation' stamp: ''! on: aCollection "Answer an instance of me, streaming over the elements of aCollection." ^self basicNew on: aCollection! ! !PostorderGuide commentStamp: 'cwp 11/18/2009 12:16'! I traverse the filesystem in depth-first post order. Given this hierarchy: alpha beta gamma delta epsilon I would visit the nodes in the following order: beta, gamma, alpha, epsilon, delta. I use my work instance variable as a stack. I push messages that cause nodes to be traversed or visited, and execute them in reverse order.! !PostorderGuide methodsFor: 'showing' stamp: 'CamilloBruni 8/12/2011 18:18'! pushTraverse: aReference self push: (Message selector: #traverse: argument: aReference)! ! !PostorderGuide methodsFor: 'showing' stamp: 'CamilloBruni 4/10/2013 12:30'! traverse: anEntry self pushVisit: anEntry. anEntry isDirectory ifTrue: [ (self shouldVisitChildrenOf: anEntry) ifFalse: [ ^ self ]. anEntry reference entries reverseDo: [ :each | self pushTraverse: each ]]! ! !PostorderGuide methodsFor: 'showing' stamp: 'CamilloBruni 8/12/2011 18:18'! pushVisit: aReference self push: (Message selector: #visit: argument: aReference)! ! !PostorderGuide methodsFor: 'showing' stamp: 'CamilloBruni 4/10/2013 11:55'! show: aReference self pushTraverse: aReference entry. self whileNotDoneDo: [ self pop sendTo: self ]! ! !PostorderGuide methodsFor: 'showing' stamp: 'CamilloBruni 4/10/2013 12:25'! visit: anEntry anEntry isDirectory ifTrue: [ visitor visitDirectory: anEntry ] ifFalse: [ visitor visitFile: anEntry ]! ! !PostorderGuideTest commentStamp: 'TorstenBergmann 1/31/2014 11:43'! SUnit tests for class PostorderGuide! !PostorderGuideTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:38'! testAll guide := PostorderGuide for: self. guide show: (filesystem / 'alpha'). self assertVisitedIs: #( 'delta' 'gamma' 'beta' 'zeta' 'epsilon' 'alpha' )! ! !Pragma commentStamp: ''! I represent an occurrence of a pragma in a compiled method. A pragma is a literal message pattern that occurs between angle brackets at the start of a method after any temporaries. A common example is the primitive pragma: but one can add one's own and use them as metadata attached to a method. Because pragmas are messages one can browse senders and implementors and perform them. One can query a method for its pragmas by sendng it the pragmas message, which answers an Array of instances of me, one for each pragma in the method. I can provide information about the defining class, method, its selector, as well as the information about the pragma keyword and its arguments. See the two 'accessing' protocols for details. 'accessing-method' provides information about the method the pragma is found in, while 'accessing-pragma' is about the pragma itself. Instances are retrieved using one of the pragma search methods of the 'finding' protocol on the class side. To browse all methods with pragmas in the system evaluate SystemNavigation new browseAllSelect: [:m| m pragmas notEmpty] and to browse all nonprimitive methods with pragmas evaluate SystemNavigation new browseAllSelect: [:m| m primitive isZero and: [m pragmas notEmpty]]! !Pragma methodsFor: 'accessing-method' stamp: 'eem 12/1/2008 10:43'! selector "Answer the selector of the method containing the pragma. Do not confuse this with the selector of the pragma's message pattern." ^method selector! ! !Pragma methodsFor: 'processing' stamp: 'lr 3/19/2007 11:37'! withArgumentsDo: aBlock "Pass the arguments of the receiving pragma into aBlock and answer the result." ^ aBlock valueWithArguments: self arguments! ! !Pragma methodsFor: 'comparing' stamp: 'eem 3/7/2009 11:54'! analogousCodeTo: anObject ^self class == anObject class and: [keyword == anObject keyword and: [arguments = anObject arguments]]! ! !Pragma methodsFor: 'accessing-pragma' stamp: 'eem 12/1/2008 10:42'! keyword "Answer the keyword of the pragma (the selector of its message pattern). For a pragma defined as this will answer #key1:key2:." ^ keyword! ! !Pragma methodsFor: 'initialization' stamp: 'lr 1/19/2006 23:39'! setMethod: aCompiledMethod method := aCompiledMethod! ! !Pragma methodsFor: 'initialization' stamp: 'lr 1/20/2006 00:53'! setKeyword: aSymbol keyword := aSymbol! ! !Pragma methodsFor: 'testing' stamp: 'eem 11/29/2008 16:39'! hasLiteral: aLiteral ^keyword == aLiteral or: [arguments hasLiteral: aLiteral]! ! !Pragma methodsFor: 'accessing-method' stamp: 'lr 1/20/2006 02:04'! method "Answer the compiled-method containing the pragma." ^ method! ! !Pragma methodsFor: 'processing' stamp: 'lr 3/19/2007 11:37'! sendTo: anObject "Send the pragma keyword together with its arguments to anObject and answer the result." ^ anObject perform: self keyword withArguments: self arguments! ! !Pragma methodsFor: 'comparing' stamp: 'GabrielBarbuto 11/30/2010 11:26'! hash | hash | hash := self method hash bitXor: self keyword hash. 1 to: self basicSize do: [:index | hash := hash bitXor: (self basicAt: index) hash]. ^hash.! ! !Pragma methodsFor: 'accessing-method' stamp: 'lr 1/20/2006 02:08'! methodClass "Answer the class of the method containing the pragma." ^ method methodClass! ! !Pragma methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 5/23/2013 08:39'! method: aCompiledMethod method := aCompiledMethod! ! !Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/20/2006 02:10'! argumentAt: anInteger "Answer one of the arguments of the pragma." ^ self arguments at: anInteger.! ! !Pragma methodsFor: 'initialization' stamp: 'lr 1/20/2006 00:53'! setArguments: anArray arguments := anArray! ! !Pragma methodsFor: 'comparing' stamp: 'GabrielBarbuto 11/30/2010 11:26'! = aPragma self == aPragma ifTrue: [^true]. self species == aPragma species ifFalse: [^false]. self method = aPragma method ifFalse: [^false]. self keyword = aPragma keyword ifFalse: [^false]. self arguments = aPragma arguments ifFalse: [^false]. ^true.! ! !Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/20/2006 02:10'! numArgs "Answer the number of arguments in the pragma." ^ self arguments size.! ! !Pragma methodsFor: 'printing' stamp: 'lr 2/6/2006 19:56'! printOn: aStream aStream nextPut: $<. self keyword precedence = 1 ifTrue: [ aStream nextPutAll: self keyword ] ifFalse: [ self keyword keywords with: self arguments do: [ :key :arg | aStream nextPutAll: key; space; print: arg; space ]. aStream skip: -1 ]. aStream nextPut: $>.! ! !Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/19/2006 20:55'! message "Answer the message of the receiving pragma." ^ Message selector: self keyword arguments: self arguments. ! ! !Pragma methodsFor: 'accessing-pragma' stamp: 'lr 1/19/2006 20:54'! arguments "Answer the arguments of the receiving pragma. For a pragma defined as this will answer #(val1 val2)." ^ arguments! ! !Pragma methodsFor: 'accessing-pragma' stamp: 'eem 12/1/2008 10:42'! key "Answer the keyword of the pragma (the selector of its message pattern). This accessor provides polymorphism with Associations used for properties." ^keyword! ! !Pragma methodsFor: 'testing' stamp: 'eem 11/29/2008 17:03'! hasLiteralSuchThat: aBlock "Answer true if litBlock returns true for any literal in the receiver, even if embedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralSuchThat:" ^(aBlock value: keyword) or: [arguments hasLiteralSuchThat: aBlock]! ! !Pragma class methodsFor: 'private' stamp: 'lr 1/20/2006 00:34'! keyword: aSymbol arguments: anArray ^ self new setKeyword: aSymbol; setArguments: anArray; yourself.! ! !Pragma class methodsFor: 'instance creation' stamp: 'eem 11/29/2008 14:00'! for: aMethod selector: aSelector arguments: anArray ^self new setMethod: aMethod; setKeyword: aSelector; setArguments: anArray; yourself! ! !Pragma class methodsFor: 'private' stamp: 'lr 1/20/2006 08:50'! withPragmasIn: aClass do: aBlock aClass selectorsAndMethodsDo: [ :selector :method | method pragmas do: aBlock ].! ! !Pragma class methodsFor: 'finding' stamp: 'lr 1/19/2006 20:06'! allNamed: aSymbol in: aClass sortedUsing: aSortBlock "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol, sorted according to aSortBlock." ^ (self allNamed: aSymbol in: aClass) sort: aSortBlock.! ! !Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 18:16'! allNamed: aSymbol in: aClass sortedByArgument: anInteger "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol, sorted according to argument anInteger." ^ self allNamed: aSymbol in: aClass sortedUsing: [ :a :b | (a argumentAt: anInteger) < (b argumentAt: anInteger) ].! ! !Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 08:55'! allNamed: aSymbol in: aClass "Answer a collection of all pragmas found in methods of aClass whose keyword is aSymbol." ^ Array streamContents: [ :stream | self withPragmasIn: aClass do: [ :pragma | pragma keyword = aSymbol ifTrue: [ stream nextPut: pragma ] ] ].! ! !Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 08:54'! allNamed: aSymbol from: aSubClass to: aSuperClass "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol." ^ Array streamContents: [ :stream | aSubClass withAllSuperclassesDo: [ :class | self withPragmasIn: class do: [ :pragma | pragma keyword = aSymbol ifTrue: [ stream nextPut: pragma ] ]. aSuperClass = class ifTrue: [ ^ stream contents ] ] ].! ! !Pragma class methodsFor: 'finding' stamp: 'lr 1/19/2006 20:12'! allNamed: aSymbol from: aSubClass to: aSuperClass sortedUsing: aSortBlock "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol, sorted according to aSortBlock." ^ (self allNamed: aSymbol from: aSubClass to: aSuperClass) sort: aSortBlock.! ! !Pragma class methodsFor: 'finding' stamp: 'lr 1/20/2006 18:16'! allNamed: aSymbol from: aSubClass to: aSuperClass sortedByArgument: anInteger "Answer a collection of all pragmas found in methods of all classes between aSubClass and aSuperClass (inclusive) whose keyword is aSymbol, sorted according to argument anInteger." ^ self allNamed: aSymbol from: aSubClass to: aSuperClass sortedUsing: [ :a :b | (a argumentAt: anInteger) < (b argumentAt: anInteger) ].! ! !PragmaAdded commentStamp: 'alain.plantec 10/20/2009 11:34'! A PragmaAdded is announced by a PragamColllector when a method defined with an acceptable pragma according to the PragmaCollector filter is added. Instance Variables ! !PragmaAnnouncement commentStamp: 'alain.plantec 10/20/2009 11:34'! A PragmaAnnouncement is announced by a PragmaCollector when it adds, removes or updates a PragmaHandler. Instance Variables pragma: pragma - the pragma which has been added, removed or updated ! !PragmaAnnouncement methodsFor: 'accessing' stamp: 'alain.plantec 9/18/2009 22:39'! pragma: aPragma pragma := aPragma! ! !PragmaAnnouncement methodsFor: 'accessing' stamp: 'alain.plantec 9/18/2009 22:39'! pragma ^ pragma! ! !PragmaAnnouncement class methodsFor: 'instance creation' stamp: 'alain.plantec 10/19/2009 10:47'! pragma: aPragma ^ self new pragma: aPragma! ! !PragmaCollector commentStamp: 'AlainPlantec 11/28/2009 01:09'! A PragmaCollector is used in order to collect some Pragma instances. A PragmaCollector makes use of SystemChangeNotifier event notifications in order to maintain its contents up-to-date according to its filter: when a method is added, removed or updated, if the method is defined with a pragma which is acceptable according to its filter, then the collector contents is updated. A PragmaCollector makes use of an announcer in order to notify all registered listeners when a pragma is added, removed or updated. A PragmaAnnouncement is announced when a Pragma is added, removed or updated. Corresponding announcement classes are, respectiveley, PragmaAdded, PragmaRemoved and PragmaUpdated. Explore the result of the expression below. In the collected instance variable should be stored all pragmas of the system: --------------------------- (PragmaCollector filter: [:pragma | true]) reset --------------------------- In the following example, collected pragma are thoses with the 'primitive:' keyword () --------------------------- (PragmaCollector filter: [:prg | prg keyword = 'primitive:']) reset --------------------------- Instance Variables announcer: collected: filter: announcer the announcer which is used to announce the adding, the removing or the updating of a method with an acceptable pragma declaration collected the current collection of Pragma filter a block or a message send which is used in order to filter the pragma. This is a one argument valuable. When evaluated, the candidate pragam is passed as argument and the result must be a boolean. ! !PragmaCollector methodsFor: 'enumerating' stamp: 'alain.plantec 9/18/2009 15:26'! detect: aBlock ^ self collected detect: aBlock ifNone:[] ! ! !PragmaCollector methodsFor: 'accessing' stamp: 'alain.plantec 10/20/2009 13:15'! collected ^ collected ifNil: [collected := OrderedCollection new] ! ! !PragmaCollector methodsFor: 'subscription' stamp: 'alain.plantec 10/19/2009 10:42'! whenResetSend: aSelector to: anObject "record a change listener" self subscribe: PragmaCollectorReset send: aSelector to: anObject ! ! !PragmaCollector methodsFor: 'updating' stamp: 'alain.plantec 10/19/2009 10:48'! removePragma: aPragma "remove an handler an announce it" self collected remove: aPragma ifAbsent: []. self announce: (PragmaRemoved pragma: aPragma)! ! !PragmaCollector methodsFor: 'querying' stamp: 'alain.plantec 9/18/2009 15:30'! pragmasOfClass: aClass "return all handlers of class aClass" ^ self select: [:prag | prag methodClass = aClass ]! ! !PragmaCollector methodsFor: 'enumerating' stamp: 'alain.plantec 9/18/2009 15:26'! reject: aBlock ^ self collected reject: aBlock ! ! !PragmaCollector methodsFor: 'subscription' stamp: 'alain.plantec 9/18/2009 15:26'! announce: anAnnouncement "see Announcements packages" self announcer ifNotNil: [announcer announce: anAnnouncement]! ! !PragmaCollector methodsFor: 'accessing' stamp: 'alain.plantec 10/19/2009 10:59'! filter ^ filter ifNil: [filter := [:prg | true]]! ! !PragmaCollector methodsFor: 'initialization' stamp: 'alain.plantec 9/18/2009 15:26'! initialize super initialize. announcer := Announcer new. self installSystemNotifications! ! !PragmaCollector methodsFor: 'querying' stamp: 'alain.plantec 9/18/2009 15:44'! pragmaWithSelector: aSelector inClass: aClass "return the handler corresponding to a pragma method which selector is aSelector in class aClass" ^ (self detect: [:prag | prag methodClass = aClass and: [prag selector = aSelector]]) ! ! !PragmaCollector methodsFor: 'subscription' stamp: 'alain.plantec 9/18/2009 15:26'! whenChangedSend: aSelector to: anObject "record a change listener" self subscribe: PragmaAnnouncement send: aSelector to: anObject ! ! !PragmaCollector methodsFor: 'system changes' stamp: 'GuillermoPolito 8/3/2012 14:41'! modifiedEventOccurs: anEvent " a method has been updated: try to update an handler: 1 - I already have one for the method, then do nothing, 2 - I do not have one but method has an acceptable pragma in it, then I try to add a new handler 3 - I have one but changed method has no more acceptable pragma in it, then the handler is removed. " Pragma withPragmasIn: anEvent methodClass do: [:pragma | pragma selector = anEvent selector ifTrue: [(self detect: [:oldprag | oldprag selector = pragma selector and: [oldprag methodClass = anEvent methodClass]]) ifNotNil: [:oldprag | ^ self updatePragma: oldprag]. ^ self addPragma: pragma]]. "No pragma but an handler for the method" (self pragmaWithSelector: anEvent selector inClass: anEvent methodClass) ifNotNil: [:found | self removePragma: found]! ! !PragmaCollector methodsFor: 'system changes' stamp: 'alain.plantec 9/18/2009 15:26'! noMoreAnnounceWhile: aBlock "unplug the announcer during aBlock" | oldAnnouncer | [oldAnnouncer := announcer. announcer := nil. aBlock value] ensure: [announcer := oldAnnouncer]! ! !PragmaCollector methodsFor: 'subscription' stamp: 'alain.plantec 9/18/2009 15:26'! unsubscribe: anObject "see Announcements packages" self announcer unsubscribe: anObject ! ! !PragmaCollector methodsFor: 'dependents access' stamp: 'alain.plantec 9/18/2009 22:09'! release self noMoreNotifications. announcer := nil. collected := nil. super release! ! !PragmaCollector methodsFor: 'enumerating' stamp: 'alain.plantec 9/18/2009 15:26'! noneSatisfy: aBlock ^ self collected noneSatisfy: aBlock! ! !PragmaCollector methodsFor: 'accessing' stamp: 'alain.plantec 9/18/2009 15:26'! announcer ^ announcer! ! !PragmaCollector methodsFor: 'testing' stamp: 'alain.plantec 9/18/2009 15:26'! isNotEmpty ^ self collected isNotEmpty! ! !PragmaCollector methodsFor: 'testing' stamp: 'alain.plantec 9/18/2009 15:26'! isEmpty ^ self collected isEmpty! ! !PragmaCollector methodsFor: 'updating' stamp: 'alain.plantec 10/19/2009 10:49'! updatePragma: aPragma "only announce that the pragma has been updated" self announcer announce: (PragmaUpdated pragma: aPragma)! ! !PragmaCollector methodsFor: 'initializing' stamp: 'alain.plantec 10/19/2009 11:46'! reset "reinitialize current system settings" self noMoreAnnounceWhile: [self collected copy do: [:pragma | self removePragma: pragma]. self class allSystemPragmas do: [:pragma | self addPragma: pragma]]. self announce: (PragmaCollectorReset collector: self)! ! !PragmaCollector methodsFor: 'system changes' stamp: 'StephaneDucasse 8/5/2013 22:24'! installSystemNotifications "Allows myself to be kept up-to-date regarding system changes" SystemAnnouncer uniqueInstance unsubscribe: self. SystemAnnouncer uniqueInstance weak on: ClassRemoved send: #classRemovedEventOccurs: to: self; on: MethodRemoved send: #removedEventOccurs: to: self; on: MethodAdded send: #addedEventOccurs: to: self; on: MethodModified send: #modifiedEventOccurs: to: self! ! !PragmaCollector methodsFor: 'system changes' stamp: 'alain.plantec 9/18/2009 15:26'! noMoreNotificationsWhile: aBlock "don not receive any system change notification during aBloc" self noMoreNotifications. [ aBlock value ] ensure: [ self installSystemNotifications ]! ! !PragmaCollector methodsFor: 'updating' stamp: 'alain.plantec 10/19/2009 10:58'! keepPragma: aPragma ^ self filter value: aPragma ! ! !PragmaCollector methodsFor: 'subscription' stamp: 'alain.plantec 9/18/2009 15:26'! subscribe: anAnnouncement send: aSelector to: anObject "see Announcements packages" self announcer subscribe: anAnnouncement send: aSelector to: anObject ! ! !PragmaCollector methodsFor: 'testing' stamp: 'alain.plantec 9/18/2009 15:26'! ifNotEmpty: aBlock self collected ifNotEmpty: aBlock! ! !PragmaCollector methodsFor: 'enumerating' stamp: 'alain.plantec 9/18/2009 15:26'! select: aBlock ^ self collected select: aBlock ! ! !PragmaCollector methodsFor: 'enumerating' stamp: 'alain.plantec 9/18/2009 15:26'! collect: aBlock ^ self collected collect: aBlock ! ! !PragmaCollector methodsFor: 'enumerating' stamp: 'alain.plantec 9/18/2009 15:26'! do: aBlock self collected do: aBlock ! ! !PragmaCollector methodsFor: 'system changes' stamp: 'GuillermoPolito 8/3/2012 14:40'! addedEventOccurs: anEvent "method adding event occured: if the concerned method contains a pragma then try to update myself with it" Pragma withPragmasIn: anEvent methodClass do: [:pragma | pragma selector = anEvent selector ifTrue: [self addPragma: pragma]] ! ! !PragmaCollector methodsFor: 'system changes' stamp: 'GuillermoPolito 8/3/2012 14:41'! removedEventOccurs: anEvent "a method has been removed, remove any corresponding handler if found" (self detect: [:prag | prag selector = anEvent selector and: [prag methodClass = anEvent methodClass ]]) ifNotNil: [:found | self removePragma: found]! ! !PragmaCollector methodsFor: 'system changes' stamp: 'GuillermoPolito 8/3/2012 14:42'! classRemovedEventOccurs: anEvent "a class has been removed: first see if the class is not my class because then I must be unplugged from system event notifications" anEvent classRemoved = self class ifTrue: [^ self noMoreNotifications]. "remove all handler which are from the removed class" (self pragmasOfClass: anEvent classRemoved class) do: [:handler | self removePragma: handler] ! ! !PragmaCollector methodsFor: 'system changes' stamp: 'EstebanLorenzano 8/3/2012 14:08'! noMoreNotifications "Do not receiver any system change notification anymore" SystemAnnouncer uniqueInstance unsubscribe: self.! ! !PragmaCollector methodsFor: 'updating' stamp: 'alain.plantec 10/19/2009 10:54'! addPragma: aPragma "if aPragma is to be kept, then add it and announce its adding" (self keepPragma: aPragma) ifTrue: [self collected add: aPragma. self announce: (PragmaAdded pragma: aPragma)]! ! !PragmaCollector methodsFor: 'accessing' stamp: 'alain.plantec 10/19/2009 11:00'! filter: aOneArgValuable filter := aOneArgValuable! ! !PragmaCollector class methodsFor: 'utilities' stamp: 'MarcusDenker 7/12/2012 17:59'! allSystemPragmas ^ (Array streamContents: [:stream | SystemNavigation new allBehaviorsDo: [:behavior | Pragma withPragmasIn: behavior do: [:pragma | stream nextPut: pragma]]]) ! ! !PragmaCollector class methodsFor: 'instance creation' stamp: 'alain.plantec 10/19/2009 16:16'! filter: aOneArgValuable ^ self new filter: aOneArgValuable! ! !PragmaCollectorReset commentStamp: 'alain.plantec 10/20/2009 11:14'! A PragmaCollectorReset is an announce which is announced by a PragamColllector when it is reset. see PragmaCollector>>reset. Instance Variables collector: collector - the collector which is reset ! !PragmaCollectorReset methodsFor: 'accessing' stamp: 'alain.plantec 10/19/2009 11:45'! collector: aCollector collector := aCollector! ! !PragmaCollectorReset methodsFor: 'accessing' stamp: 'DanielAvivEstebanAllende 1/29/2013 10:45'! collector ^collector! ! !PragmaCollectorReset class methodsFor: 'instance creation' stamp: 'alain.plantec 10/19/2009 11:45'! collector: aCollector ^ self new collector: aCollector! ! !PragmaMenuAndShortcutRegistration commentStamp: ''! A PragmaMenuAndShortcutRegistration is the list items holder! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 22:36'! currentRoot ^ currentRoot! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'GuillermoPolito 9/24/2012 11:57'! category: aByteSymbol shortcut: aKMModifiedShortcut do: aBlockClosure description: aByteString self currentItem category: aByteSymbol; default: aKMModifiedShortcut; action: aBlockClosure; help: aByteString! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:49'! parent: aSymbol self currentItem parent: aSymbol ! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:45'! precondition: aBlock self currentItem precondition: aBlock ! ! !PragmaMenuAndShortcutRegistration methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/7/2012 20:50'! itemClass ^ PragmaMenuAndShortcutRegistrationItem! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:48'! currentItem ^ items last! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 22:59'! category: aByteSymbol self currentItem category: aByteSymbol! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:00'! item: aSymbol self createNewItem. self currentItem item: aSymbol! ! !PragmaMenuAndShortcutRegistration methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:06'! initialize super initialize. items := OrderedCollection new.! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'YuriyTymchuk 12/20/2013 15:22'! keyText: aString if: aBoolean aBoolean ifFalse: [ ^ self ]. self keyText: aString! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:27'! description: aByteString self currentItem help: aByteString! ! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:26'! enabled: aBoolean self currentItem enabled: aBoolean! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:49'! label: aString self currentItem label: aString! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:49'! help: aString self currentItem help: aString ! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:12'! platform: anArray anArray isEmpty ifTrue: [ platform := #all ] ifFalse: [ platform := anArray first ]! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:19'! target: aSymbol self currentItem target: aSymbol ! ! !PragmaMenuAndShortcutRegistration methodsFor: 'initialization' stamp: 'SeanDeNigris 7/16/2012 12:36'! attachShortcutCategory: aSymbol to: aClass KMRepository default attachCategoryName: aSymbol to: aClass.! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'EstebanLorenzano 1/30/2013 16:47'! keyText: aString self currentItem keyText: aString! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'GuillermoPolito 5/3/2013 15:49'! setAsGlobalCategory: aGlobalCategory KMRepository default setAsGlobalCategory: aGlobalCategory! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'GuillermoPolito 9/24/2012 11:58'! category: aByteSymbol default: aKMModifiedShortcut do: aBlockClosure description: aByteString self currentItem category: aByteSymbol; default: aKMModifiedShortcut; action: aBlockClosure; help: aByteString! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:00'! group: aSymbol self createNewItem. self currentItem group: aSymbol! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'GuillermoPolito 9/24/2012 11:57'! category: aByteSymbol shortcut: aKMModifiedShortcut do: aBlockClosure self currentItem category: aByteSymbol; default: aKMModifiedShortcut; action: aBlockClosure ! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:43'! with: aBlock self currentItem with: aBlock! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'GuillermoPolito 9/24/2012 11:58'! shortcut: aSymbol self createNewItem. self currentItem shortcut: aSymbol! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:48'! action: aBlock self currentItem action: aBlock! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:00'! createNewItem items add: self itemClass new. self currentItem platform: platform; parent: currentRoot! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:17'! arguments: anArray self currentItem arguments: anArray! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 22:59'! default: aKMModifiedShortcut self currentItem default: aKMModifiedShortcut! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:06'! selector: aSelector self currentItem selector: aSelector! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:49'! icon: anIcon self currentItem icon: anIcon! ! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:16'! model ^ model! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:49'! withSeparatorAfter self currentItem withSeparatorAfter! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:37'! order: anInteger self currentItem order: anInteger ! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'GuillermoPolito 9/24/2012 11:58'! category: aByteSymbol default: aKMModifiedShortcut do: aBlockClosure self currentItem category: aByteSymbol; default: aKMModifiedShortcut; action: aBlockClosure ! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:27'! do: aBlockClosure self currentItem action: aBlockClosure! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:49'! enabledBlock: aBlock self currentItem enabledBlock: aBlock! ! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:16'! model: aModel model := aModel.! ! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:25'! items ^ items! ! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 22:37'! currentRoot: aMenuRegistration currentRoot := aMenuRegistration! ! !PragmaMenuAndShortcutRegistration class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/7/2012 23:16'! model: aModel ^ self new model: aModel; yourself! ! !PragmaMenuAndShortcutRegistrationItem commentStamp: ''! A PragmaMenuAndShortcutRegistrationItem is an item of a menu or keymap! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! category: aByteSymbol category := aByteSymbol! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:29'! selector ^ selector! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:43'! enabled ^ enabled! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! parent: aSymbol parent := aSymbol ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:48'! with ^ with! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! item: aSymbol item := aSymbol! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! platform ^ platform! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:43'! enabledBlock ^ enabledBlock! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:07'! initialize super initialize. withSeparatorAfter := false.! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:27'! action ^ action! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:34'! parent ^ parent! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/30/2013 16:48'! keyText ^keyText! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:26'! enabled: aBoolean enabled := aBoolean! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! label: aString label := aString! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'GuillermoPolito 9/24/2012 11:56'! shortcutName ^shortcutName! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:47'! group ^ group! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:19'! target: aSymbol target := aSymbol ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! help: aString help := aString ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! platform: aSymbol platform := aSymbol! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'EstebanLorenzano 1/30/2013 16:47'! keyText: aString keyText := aString! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:41'! group: aSymbol group := aSymbol! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! category ^ category! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:52'! with: aBlock with := aBlock! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:29'! isWithSeparatorAfter ^ withSeparatorAfter! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:10'! shortcut: aSymbol shortcut := aSymbol! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! action: aBlock action := aBlock! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! default: aKMModifiedShortcut default := aKMModifiedShortcut ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:17'! arguments: anArray arguments := anArray! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:34'! order ^ order! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:07'! selector: aSymbol selector := aSymbol ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! icon: anIcon icon := anIcon! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:10'! shortcut ^ shortcut! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:19'! withSeparatorAfter withSeparatorAfter := true! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! default ^ default! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:28'! label ^ label! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:27'! item ^ item! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:37'! order: anInteger order := anInteger! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'GuillermoPolito 9/24/2012 11:56'! shortcutName: aSymbol shortcutName := aSymbol! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:28'! help ^ help! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! enabledBlock: aBlock enabledBlock := aBlock! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:29'! arguments ^ arguments! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:45'! precondition: aBlock precondition := aBlock ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:29'! target ^ target! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:28'! icon ^ icon! ! !PragmaMenuBuilder commentStamp: 'AlainPlantec 11/16/2010 19:48'! For the impatients, see MenuRegistrationExample class methods and try it with: --------------- ((PragmaMenuBuilder pragmaKeyword: MenuRegistrationExample pragmaKeyword model: nil) menuEntitled: 'World') popUpInWorld --------------- PragmaMenuBuilder is for the dynamic building of menus based on pragmas. A PragmaMenuBuilder instance is the root of a tree of MenuRegistration instances. The basic principle is that each menu sub-tree is specified by a method which is tagged by a specific pragma. Such methods are dynamically retrieved and then evaluated with a MenuRegistration passed as argument (see #retrieveRegistrations). The result is a tree of MenuRegistration which roots are stored in my itemList inst. var. After the tree of MenuRegistration has been built, it is re-organized (re-organization is based on the parent declaration) and is re-ordered (based on the MenuRegistration order indications). Then the tree of MenuRegistration can serve as input for the building of a PluggableMenuSpec. The PluggableMenuSpec is itself used in order to build a MenuMorph with the help of the current ToolBuilder. (see MenuRegistration comment for more informations about how to specify menu entries). The tree of MenuRegistration is built by #buildTree in three steps (1) the collecting of the MenuRegistration instances (2) the re-organization and (3) the sorting: 1) The first step consists in evaluating all pragma methods by passing a builder (a PragmaMenuBuilder instance) as argument. Each pragma method invocation build a sub-tree which root is added to the builder itemList collection. (see #collectRegistrations). As an example, this first step could produce a tree as follow (stored in a PragmaMenuBuilder itemList inst var) : #Tools #'Other tool', parentName: #Tools / \ | (#Worspace) (#browser) (#'Test runner' ) 2) The second step consists is re-organizing the tree. A MenuRegistration can be declared with a particular parent name (by sending #parent: to it with a symbol as argument). If the parentName of a MenuRegistration X is the name of another MenuRegistration Z, then it means that X must be placed as a child of Z. This is the goal of this re-arrangement step which moves badly placed nodes at their good place. (see #arrangeRegistrations). With previous example, the second step produces: #Tools / | \ (#Worspace) (#browser) #'Other tool' , parentName: #Tools | (#'Test runner') 2) The third step consists in sorting the tree according to the order inst. var. value of each MenuRegistration. This is done in two passes: the first pass tries to assign as much order inst. var. as possible (If an item is given with a specific order, then, previous and following items order can be automatically computed - see #assignOrderWithBlock: and #orderAssignBlock). The second pass consists in a smple sort according to a sort block given by #itemSortBlock. Instance Variables model: pragmaCollector: pragmaKeywords: currentRoot: model - Serves as the default target for the menu. Note that a default target can also be declared at menu item level pragmaKeywords - The list of pragma keywords used for the declaring of my menu items pragmaCollector - The PragmaCollector associated with this builder. When a method declared with the same pragma as my pragmaKeyword is updated/added/removed my menu items are recomputed so that the resulting menu is always in sync with currently declared items. currentRoot - the current MenuRegistration in which new items are to be added ! !PragmaMenuBuilder methodsFor: 'registrations handling' stamp: 'BenjaminVanRyseghem 4/7/2012 22:19'! collectRegistrations "Retrieve all pragma methods and evaluate them by passing the MenuRegistration class as argument. The result is a list of trees stored in my itemList inst var" | menu | menu := PragmaMenuAndShortcutRegistration model: self model. self pragmaCollector do: [:prg | self currentRoot: self while: [ prg methodClass theNonMetaClass perform: prg selector with: menu ]]. self interpretRegistration: menu.! ! !PragmaMenuBuilder methodsFor: 'registrations handling' stamp: 'AlainPlantec 2/18/2010 11:46'! arrangeRegistrations. self allMisplacedItems do: [:item | (self itemNamed: item parentName) ifNotNil: [:newOwner | item owner removeItem: item. item owner: newOwner. newOwner addItem: item]]. ! ! !PragmaMenuBuilder methodsFor: 'public menu building' stamp: 'StephaneDucasse 6/5/2011 22:48'! menuSpecAt: aName "returns a PluggableMenuSpec build from my contents starting at the inner MenuRegistration named aName or from here if aName is nil" | root | self buildTree. root := PluggableMenuSpec withModel: nil. (aName ifNil: [self] ifNotNil: [self itemNamed: aName]) ifNotNil: [:top | top precondition value ifTrue: [top buildMenuSpec: root]]. ^ root! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 11/16/2010 20:53'! pragmaKeyword "Deprecated" ^ pragmaKeywords isEmptyOrNil ifFalse: [pragmaKeywords first]! ! !PragmaMenuBuilder methodsFor: 'registrations handling' stamp: 'AlainPlantec 11/16/2010 19:55'! pragmaCollector "Return an up-to-date pragmaCollector which contains all pragmas which keyword is self pragmaKeyword" ^ pragmaCollector ifNil: [pragmaCollector:= (PragmaCollector filter: [:prg | (self pragmaKeywords includes: prg keyword) and: [prg selector numArgs = 1]]). (self pragmaKeywords notNil and: [self pragmaKeywords notEmpty]) ifTrue: [pragmaCollector reset]. pragmaCollector whenChangedSend: #reset to: self. pragmaCollector]! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 11/16/2010 19:45'! pragmaKeywords: aCollection "Returns the pragma keyword used to select pragmas (see #pragmaCollector)" pragmaKeywords addAll: (aCollection collect: [:k | k asSymbol])! ! !PragmaMenuBuilder methodsFor: 'initialization' stamp: 'AlainPlantec 11/16/2010 19:55'! initialize super initialize. isGroup := true. currentRoot := self. pragmaKeywords := OrderedCollection new. ! ! !PragmaMenuBuilder methodsFor: 'private' stamp: 'SeanDeNigris 6/16/2013 13:48'! fallbackMenu ^ FallbackMenu when: self fails: model.! ! !PragmaMenuBuilder methodsFor: 'menu building' stamp: 'AlainPlantec 2/16/2010 16:36'! currentRoot: anItem while: aBlock | old | old := currentRoot. currentRoot := anItem. [aBlock value] ensure: [currentRoot := old]! ! !PragmaMenuBuilder methodsFor: 'public menu building' stamp: 'SeanDeNigris 6/16/2013 14:24'! menuAt: aName "returns a MenuMorph from my menuSpec" ^ self menuFrom: [ self menuSpecAt: aName ].! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 11/16/2010 19:37'! pragmaKeywords "Returns the pragma keyword used to select pragmas (see #pragmaCollector)" ^ pragmaKeywords ! ! !PragmaMenuBuilder methodsFor: 'menu building' stamp: 'AlainPlantec 2/16/2010 16:58'! newSubItem | reg | reg := MenuRegistration owner: currentRoot. currentRoot addItem: reg. ^ reg! ! !PragmaMenuBuilder methodsFor: 'initialize-release' stamp: 'AlainPlantec 2/15/2010 11:21'! release self pragmaCollector unsubscribe: self. pragmaCollector := nil. model := nil. super release ! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:52'! builder ^ self! ! !PragmaMenuBuilder methodsFor: 'public menu building' stamp: 'SeanDeNigris 6/16/2013 13:26'! menu "returns a MenuMorph build from my menuSpec" ^ self menuFrom: [ self menuSpec ].! ! !PragmaMenuBuilder methodsFor: 'public menu building' stamp: 'AlainPlantec 2/14/2010 14:09'! menuSpec "returns a PluggableMenuSpec build from my contents" ^ self menuSpecAt: nil! ! !PragmaMenuBuilder methodsFor: 'registrations handling' stamp: 'AlainPlantec 2/12/2010 23:21'! sortRegistrations "Try to update MenuRegistration order inst. var and the sort the trees" self assignOrderWithBlock: self class orderAssignBlock. self sort: self class itemSortBlock! ! !PragmaMenuBuilder methodsFor: 'private' stamp: 'EstebanLorenzano 1/30/2013 16:54'! interpretRegistration: aRegistration | root | root := MenuRegistration owner: self. aRegistration items do: [:item || node | node := item group ifNil: [ root item: item item ] ifNotNil: [:grp | root group: grp ]. item with ifNotNil: [:block || old | old := aRegistration currentRoot. aRegistration currentRoot: node name. [ node with: block ] ensure: [ aRegistration currentRoot: old ]] ifNil: [ item action ifNil: [ node target: item target; arguments: item arguments; selector: item selector ] ifNotNil:[ node action: item action ]]. node keyText: item keyText; help: item help; icon: item icon; order: item order; parent: item parent. item enabled ifNil: [ node enabledBlock: item enabledBlock ] ifNotNil: [:boolean | node enabled: boolean ]. item label ifNotNil: [ node label: item label ]. item default ifNotNil: [ :d | node label: node label, ' (', d asString, ')']. item isWithSeparatorAfter ifTrue: [ node withSeparatorAfter ]]! ! !PragmaMenuBuilder methodsFor: 'private' stamp: 'SeanDeNigris 6/16/2013 13:25'! menuFrom: specBlock ^ [ specBlock value asMenuMorph ] on: Error do: [ self reset. self fallbackMenu ].! ! !PragmaMenuBuilder methodsFor: 'menu building' stamp: 'BenComan 10/15/2013 14:03'! buildTree "Retrieve all menu registrations with the help of a PragmaCollector then, reorganise the tree and sort it - see class comment for more informations" itemList := OrderedCollection new. self collectRegistrations. self arrangeRegistrations. self sortRegistrations! ! !PragmaMenuBuilder methodsFor: 'registrations handling' stamp: 'AlainPlantec 2/12/2010 14:34'! allMisplacedItems | misplaced | self collectMisplacedItemsIn: (misplaced := OrderedCollection new). ^ misplaced ! ! !PragmaMenuBuilder methodsFor: 'public menu building' stamp: 'SeanDeNigris 6/16/2013 13:24'! menuEntitled: aTitle "returns a MenuMorph build from my menuSpec" ^ self menuFrom: [ self menuSpec label: aTitle ].! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:40'! model ^ model! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 11/16/2010 19:45'! pragmaKeyword: aString "Set the pragma keyword used to select pragmas (see #pragmaCollector)" pragmaKeywords add: aString asSymbol. self pragmaCollector reset.! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:57'! itemReceiver ^ model! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:40'! model: anObject model := anObject! ! !PragmaMenuBuilder class methodsFor: 'private' stamp: 'GabrielOmarCotelli 12/4/2013 08:39'! orderAssignBlock "The block which is used to set MenuRegistration tree node order inst var (which is used to sort the tree)" ^ [ :list | list detect: [ :n | n order notNil ] ifFound: [ :firstWithOrder | | idx order | "A menu registration with an order indication hase been found - then compute order of previous and next nodes" idx := list indexOf: firstWithOrder. order := firstWithOrder order. idx > 1 ifTrue: [ idx - 1 to: 1 do: [ :pos | (list at: pos) order: order - 1. order := order - 1 ] ]. order := firstWithOrder order. idx + 1 to: list size do: [ :pos | (list at: pos) order ifNil: [ (list at: pos) order: order + 1 ] ifNotNil: [ order := (list at: pos) order ]. order := order + 1 ]. list ] ifNone: [ list ] "No order has been set - do not touch anything, the list order is ok" ]! ! !PragmaMenuBuilder class methodsFor: 'private' stamp: 'AlainPlantec 2/16/2010 19:35'! itemSortBlock "The block which is used to sort a menu tree" ^ [:a :b | ((a order notNil and: [b order notNil]) and: [a order ~= b order]) ifTrue: [a order < b order] ifFalse: [((a order isNil and: [b order isNil]) or: [a order = b order]) ifTrue: [true] ifFalse: [a order ifNil: [false] ifNotNil: [true]]]]! ! !PragmaMenuBuilder class methodsFor: 'instance creation' stamp: 'AlainPlantec 11/16/2010 19:46'! pragmaKeyword: aPragmaKeyword model: aModel "Build a builder using aPragmaKeyword as the pragma keyword and aModel a the model of the resulting builder" ^ self withAllPragmaKeywords: (Array with: aPragmaKeyword) model: aModel! ! !PragmaMenuBuilder class methodsFor: 'instance creation' stamp: 'SeanDeNigris 6/16/2013 14:18'! withAllPragmaKeywords: aCollection model: aModel "Build a builder using aPragmaKeyword as the pragma keyword and aModel a the model of the resulting builder" ^ self new pragmaKeywords: aCollection; model: aModel; yourself.! ! !PragmaRemoved commentStamp: 'alain.plantec 10/20/2009 11:33'! A PragmaRemoved is announced by a PragamColllector when a method defined with an acceptable pragma according to the PragmaCollector filter is removed. Instance Variables ! !PragmaSetting commentStamp: 'AlainPlantec 1/3/2011 10:54'! A PragmaSetting is a holder for a setting. A setting is declared in a class method which contains a pragma (as examples, or ). Settings can be collected on the fly by a PragmaCollector and browsed by a SettingBrowser. Settings are organized in trees. Instance Variables allowedInStyle: description: dialog: icon: label: name: order: ordering: precondition: target: targetSelector: allowedInStyle - xxxxx description - xxxxx dialog - xxxxx icon - xxxxx label - xxxxx name - xxxxx order - xxxxx ordering - xxxxx precondition - xxxxx target - xxxxx targetSelector - xxxxx ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 21:15'! targetSelector ^ targetSelector! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 12/2/2009 16:40'! target ^ target! ! !PragmaSetting methodsFor: 'user interface' stamp: 'alain.plantec 3/12/2009 12:58'! enabled ^ true! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/13/2009 15:52'! description "Answer the value of description" ^ description ifNil: [description := '']! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 21:16'! targetSelector: aSelector targetSelector := aSelector! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 1/29/2010 14:03'! hasEditableList ^ false! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 1/29/2010 14:04'! notInStyle allowedInStyle := false! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 1/29/2010 14:12'! getFont ^ FontChooser openWithWindowTitle: 'Font for ' , self name for: self setSelector: #realValue: getSelector: #realValue ! ! !PragmaSetting methodsFor: '*StartupPreferences' stamp: 'BenjaminVanRyseghem 8/1/2012 15:44'! exportSettingAction ^ nil! ! !PragmaSetting methodsFor: 'user interface' stamp: 'EstebanLorenzano 5/14/2013 09:44'! defaultIcon ^ Smalltalk ui icons smallConfigurationIcon! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 2/11/2011 14:09'! labelMorphFor: aContainer ^ StringMorph contents: (aContainer model viewedLabelOfSetting: self)! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 1/30/2010 08:07'! inputWidget "return the default widget for the input a the setting" ^ self dialog ifNotNil: [:d | d numArgs = 0 ifTrue: [d value] ifFalse: [d value: self]] ! ! !PragmaSetting methodsFor: 'accessing' stamp: 'alain.plantec 3/25/2009 19:36'! description: aText "Set the value of description" description := aText! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 11/25/2009 08:18'! ordering ^ ordering ifNil: [ordering := true]! ! !PragmaSetting methodsFor: '*StartupPreferences' stamp: 'BenjaminVanRyseghem 2/5/2013 15:17'! isExportable ^ false! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/23/2009 14:11'! label: aStringOrBlockOrMessageSend label := aStringOrBlockOrMessageSend! ! !PragmaSetting methodsFor: 'user interface' stamp: 'alain.plantec 3/11/2009 15:38'! asString ^ self name! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 21:15'! target: anObject target := anObject! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 1/29/2010 14:12'! fontButtonLabel | emphases | emphases := IdentityDictionary new at: nil put: 'Regular' translated; at: 0 put: 'Regular' translated; at: 1 put: 'Bold' translated; at: 2 put: 'Italic' translated; at: 4 put: 'Underlined' translated; at: 8 put: 'Narrow' translated; at: 16 put: 'StruckOut' translated; yourself. ^ StringMorph contents: self realValue familyName , ' ' , (emphases at: self realValue emphasis ifAbsent: ['']) , ' ' , self realValue pointSize asString font: self realValue! ! !PragmaSetting methodsFor: 'comparing' stamp: 'alain.plantec 4/20/2009 15:19'! hash ^ self species hash bitXor: self name hash ! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 1/30/2010 07:59'! dialog: aValuable dialog := aValuable! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 1/29/2010 14:02'! hasDefault ^ false! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 1/29/2010 10:47'! settingReceiver ^ self targetSelector ifNil: [self realTarget] ifNotNil: [self realTarget perform: self targetSelector]! ! !PragmaSetting methodsFor: 'user interface' stamp: 'FernandoOlivero 4/12/2011 10:13'! chooseFileDirectory | result | result := self theme chooseDirectoryIn: World title: 'Choose a file' path: nil. result ifNotNil: [ self realValue: result fullName ].! ! !PragmaSetting methodsFor: 'accessing' stamp: 'lr 3/14/2010 21:13'! realTarget ^ target isSymbol ifTrue: [ Smalltalk globals at: target ifAbsent: [ ] ] ifFalse: [ target ]! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 1/29/2010 13:58'! allowedInStyle ^ allowedInStyle ifNil: [allowedInStyle := self hasValue]! ! !PragmaSetting methodsFor: 'accessing' stamp: 'alain.plantec 4/2/2009 11:59'! order ^ order! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 12/5/2009 08:42'! precondition ^ precondition ifNil: [precondition := [true]].! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 11/23/2009 22:18'! icon: aForm icon := aForm! ! !PragmaSetting methodsFor: 'comparing' stamp: 'alain.plantec 4/20/2009 15:18'! = other ^ self species = other species and: [self name = other name]! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/23/2009 14:11'! label ^ label ifNil: [self name] ifNotNil: [label value]! ! !PragmaSetting methodsFor: 'accessing' stamp: 'alain.plantec 10/18/2009 12:39'! name: aNameOrBlockOrMessageSend name := aNameOrBlockOrMessageSend! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 11/25/2009 08:18'! noOrdering ordering := false! ! !PragmaSetting methodsFor: 'accessing' stamp: 'alain.plantec 4/2/2009 10:53'! order: aNumber order := aNumber! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 1/30/2010 08:07'! dialog ^ dialog! ! !PragmaSetting methodsFor: 'user interface' stamp: 'FernandoOlivero 4/12/2011 10:13'! chooseFilePath | result | result := self theme fileOpenIn: World title: 'Choose a file' extensions: nil path: nil preview: true. result ifNotNil: [ self realValue: result name. result close]! ! !PragmaSetting methodsFor: 'user interface' stamp: 'FernandoOlivero 4/12/2011 10:13'! inputMorphFor: aContainer ^ self inputWidget ifNotNil: [:iw | ( self theme newRowIn: World for: {iw}) clipSubmorphs: true; hResizing: #shrinkWrap; cellInset: 0; yourself]! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 1/29/2010 14:03'! hasValue ^ false! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 12/5/2009 08:43'! precondition: aValuable precondition := aValuable! ! !PragmaSetting methodsFor: 'accessing' stamp: 'alain.plantec 10/18/2009 12:40'! name ^ name ifNil: [super name] ifNotNil: [name value]! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 11/25/2009 08:27'! icon ^ icon ifNil: [icon := self defaultIcon]! ! !PragmaTest commentStamp: 'TorstenBergmann 2/5/2014 08:42'! SUnit tests for Pragma class! !PragmaTest methodsFor: 'tests' stamp: 'GabrielBarbuto 11/30/2010 11:26'! testEqual self assert: atPragma = atPragma. "Reflexivity" self assert: atPragma = anotherAtPragma. "Simmetry" self assert: anotherAtPragma = atPragma. self assert: atPragma = anotherAtPragma. "Transitivity" self assert: anotherAtPragma = yetAnotherAtPragma. self assert: yetAnotherAtPragma = atPragma. self deny: atPragma = atPutPragma.! ! !PragmaTest methodsFor: 'tests' stamp: 'GabrielBarbuto 11/30/2010 11:26'! testHash self assert: atPragma hash = atPragma hash. self assert: atPragma hash = anotherAtPragma hash. self assert: anotherAtPragma hash = atPragma hash. self assert: atPragma hash = anotherAtPragma hash. self assert: anotherAtPragma hash = yetAnotherAtPragma hash. self assert: yetAnotherAtPragma hash = atPragma hash.! ! !PragmaTest methodsFor: 'tests' stamp: 'GabrielBarbuto 11/30/2010 11:26'! testCopy | copy | copy := atPragma copy. self deny: atPragma == copy. self assert: atPragma method == copy method. self assert: atPragma keyword == copy keyword. self assert: atPragma arguments == copy arguments.! ! !PragmaTest methodsFor: 'running' stamp: 'GabrielBarbuto 11/30/2010 11:25'! setUp atPragma := Pragma for: (Object methodDict at: #at:) selector: #primitive: arguments: (Array with: 60). anotherAtPragma := Pragma for: (Object methodDict at: #at:) selector: #primitive: arguments: (Array with: 60). yetAnotherAtPragma := Pragma for: (Object methodDict at: #at:) selector: #primitive: arguments: (Array with: 60). atPutPragma := Pragma for: (Object methodDict at: #at:) selector: #primitive: arguments: (Array with: 61). ! ! !PragmaUpdated commentStamp: 'alain.plantec 10/20/2009 11:33'! A PragmaUpdated is announced by a PragamColllector when a method defined with an acceptable pragma according to the PragmaCollector filter is updated (recompiled). Instance Variables ! !PreDebugAction commentStamp: ''! A PreDebugAction is a debugging actions sending a unary message to the pre debug window. ! !PreDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:20'! preDebugWindow ^ preDebugWindow! ! !PreDebugAction methodsFor: 'initialization' stamp: 'AndreiChis 9/25/2013 17:33'! initialize super initialize. self needsUpdate: false. self needsValidation: false.! ! !PreDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:20'! preDebugWindow: anObject preDebugWindow := anObject! ! !PreDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:05'! receiver ^ self preDebugWindow! ! !PreDebugAction class methodsFor: 'actions creation' stamp: 'AndreiChis 9/30/2013 17:23'! debugActionsFor: aDebugger ^ { self new id: #abandonAction; selector: #close; order: 10; label: 'Abandon'. self new id: #openFullDebuggerAction; selector: #openFullDebugger; order: 15; label: 'Debug' }! ! !PreDebugDoesNotUnderstandAction commentStamp: ''! A PreDebugDoesNotUnderstandAction adds the DoesNotUnderstandDebugAction debugging actions to the pre debug window. When executed, it will further close the pre debug window and open the full debugger. Instance Variables preDebugWindow: preDebugWindow - xxxxx ! !PreDebugDoesNotUnderstandAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:20'! preDebugWindow ^ preDebugWindow! ! !PreDebugDoesNotUnderstandAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:14'! id ^ #preDebugDoesNotUnderstand! ! !PreDebugDoesNotUnderstandAction methodsFor: 'actions' stamp: 'AndreiChis 9/30/2013 17:24'! executeAction "The create method from the session will trigger #contextChanged, which will make the debgger update the stack. Sof it safe to just open the debugger." super executeAction. self preDebugWindow openFullDebugger! ! !PreDebugDoesNotUnderstandAction methodsFor: 'initialization' stamp: 'AndreiChis 9/25/2013 17:32'! initialize super initialize. self needsUpdate: false. self needsValidation: false! ! !PreDebugDoesNotUnderstandAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:20'! preDebugWindow: anObject preDebugWindow := anObject! ! !PreDebugDoesNotUnderstandAction class methodsFor: 'registration' stamp: 'AndreiChis 9/24/2013 18:16'! actionType ! ! !PreDebugResumeDebugAction commentStamp: ''! A PreDebugResumeDebugAction adds the ResumeDebugAction to the pre debug window. Instance Variables preDebugWindow: preDebugWindow - xxxxx ! !PreDebugResumeDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:21'! preDebugWindow ^ preDebugWindow! ! !PreDebugResumeDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 17:42'! id ^ #preDebugResume! ! !PreDebugResumeDebugAction methodsFor: 'actions' stamp: 'AndreiChis 9/24/2013 17:44'! executeAction self session resume; clear. self preDebugWindow close. ! ! !PreDebugResumeDebugAction methodsFor: 'initialization' stamp: 'AndreiChis 9/25/2013 17:33'! initialize super initialize. self needsUpdate: false. self needsValidation: false! ! !PreDebugResumeDebugAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:21'! preDebugWindow: anObject preDebugWindow := anObject! ! !PreDebugResumeDebugAction class methodsFor: 'registration' stamp: 'AndreiChis 9/24/2013 18:15'! actionType ! ! !PreDebugSubclassResponsabilityAction commentStamp: ''! A PreDebugSubclassResponsabilityAction adds the SubclassResponsabilityDebugAction debugging actions to the pre debug window. When executed, it will further close the pre debug window and open the full debugger. Instance Variables preDebugWindow: preDebugWindow - xxxxx ! !PreDebugSubclassResponsabilityAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:21'! preDebugWindow ^ preDebugWindow! ! !PreDebugSubclassResponsabilityAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 17:53'! id ^ #preDebugSubclassResponsability! ! !PreDebugSubclassResponsabilityAction methodsFor: 'actions' stamp: 'AndreiChis 9/30/2013 17:24'! executeAction super executeAction. self preDebugWindow openFullDebugger "Open the full debugger"! ! !PreDebugSubclassResponsabilityAction methodsFor: 'initialization' stamp: 'AndreiChis 9/25/2013 17:34'! initialize super initialize. self needsUpdate: false. self needsValidation: false! ! !PreDebugSubclassResponsabilityAction methodsFor: 'accessing' stamp: 'AndreiChis 9/24/2013 18:21'! preDebugWindow: anObject preDebugWindow := anObject! ! !PreDebugSubclassResponsabilityAction class methodsFor: 'registration' stamp: 'AndreiChis 9/24/2013 18:15'! actionType ! ! !PreorderGuide commentStamp: 'cwp 11/18/2009 12:18'! I traverse the filesystem in depth-first pre order. Given this hierarchy: alpha beta gamma delta epsilon I would visit the nodes in the following order: alpha, beta, gamma, delta, epsilon. I use my work instance variable as a stack. I push nodes to be visited and visit them in reverse order.! !PreorderGuide methodsFor: 'showing' stamp: 'CamilloBruni 4/10/2013 12:14'! pushAll: aCollection aCollection reverseDo: [ :each | work add: each ]! ! !PreorderGuide methodsFor: 'showing' stamp: 'CamilloBruni 4/10/2013 12:42'! visitNextEntry: entry entry isFile ifTrue: [ visitor visitFile: entry ] ifFalse: [ visitor visitDirectory: entry. (self shouldVisitChildrenOf: entry) ifTrue: [ self pushAll: entry reference entries ]]! ! !PreorderGuide methodsFor: 'showing' stamp: 'CamilloBruni 4/10/2013 12:39'! show: aReference self push: aReference entry. self whileNotDoneDo: [ self visitNextEntry: self pop ]! ! !PreorderGuideTest commentStamp: 'TorstenBergmann 1/31/2014 11:44'! SUnit tests for class PreorderGuide! !PreorderGuideTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:38'! testAll guide := PreorderGuide for: self. guide show: (filesystem / 'alpha'). self assertVisitedIs: #( 'alpha' 'beta' 'delta' 'gamma' 'epsilon' 'zeta' )! ! !PrettyTextDiffBuilder commentStamp: 'HenrikSperreJohansen 5/21/2010 01:42'! I'm like TextDiffBuilder, but I use the pretty-printed version of the source code if available. Instance Variables sourceClass: sourceClass - this class provides the pretty-printer ! !PrettyTextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:16'! sourceClass: aClass sourceClass := aClass.! ! !PrettyTextDiffBuilder methodsFor: 'initialize' stamp: 'MarcusDenker 8/28/2013 10:29'! split: aString | formatted trimmed | trimmed := aString asString trimBoth. trimmed isEmpty ifTrue: [ ^super split: '' ]. formatted := [ sourceClass source: trimmed; class: sourceClass; format] on: Error do: [ :ex | trimmed ]. ^ super split: formatted! ! !PrettyTextDiffBuilder class methodsFor: 'instance creation' stamp: 'nk 10/29/2000 12:35'! from: srcString to: dstString inClass: srcClass ^ (self new sourceClass: srcClass) from: srcString to: dstString ! ! !PrimitiveFailed commentStamp: 'SvenVanCaekenberghe 4/21/2011 12:31'! I am PrimitiveFailed, an exception signaled when a primitive fails.! !PrimitiveFailed methodsFor: 'printing' stamp: 'nice 12/2/2011 23:36'! standardMessageText "Generate a standard textual description" ^ String streamContents: [ :stream | stream << 'primitive '. stream print: self selector. stream << ' in '. stream print: self signaler class. stream << ' failed' ]! ! !PrintVersionCommandLineHandler commentStamp: ''! Usage: printVersion [ --numeric | --release ] --numeric Print the full version number only (e.g. 12345) --release Print the major relase number only (e.g. 1.2) Documentation: Prints the version number in an easy to parse format. This can be used in Jenkins with the "Description Setter" Plugin. Configure it like this: Regular expression: \[version\] (.*) Description: \1 Examples: pharo Pharo.image printVersion #result will be something like: [version] 3.0 #30100 pharo Pharo.image printVersion --numeric # will print a simpler version 30100 pharo Pharo.image printVersion --release # prints the Pharo release version 3.0! !PrintVersionCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 3/26/2013 21:09'! printRelease self stdout print: SystemVersion current major; nextPutAll: '.'; print: SystemVersion current minor; lf.! ! !PrintVersionCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 3/26/2013 21:09'! printVersion self stdout nextPutAll: '[version] '; print: SystemVersion current major; nextPutAll: '.'; print: SystemVersion current minor; nextPutAll: ' #' ; print: SystemVersion current highestUpdate; lf.! ! !PrintVersionCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 3/26/2013 21:09'! printNumericVersion self stdout print: SystemVersion current highestUpdate; lf! ! !PrintVersionCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 3/26/2013 21:13'! activate self activateHelp ifTrue: [ ^ self ]. (self hasOption: 'numeric') ifTrue: [ self printNumericVersion. ^ self exitSuccess]. (self hasOption: 'release') ifTrue: [ self printRelease. ^ self exitSuccess ]. self hasArguments ifFalse: [ self printVersion. ^ self exitSuccess ]. self printHelp. ^ self exitFailure! ! !PrintVersionCommandLineHandler class methodsFor: 'accessing' stamp: 'MarcusDenker 11/16/2012 14:50'! description ^ 'Print image version'! ! !PrintVersionCommandLineHandler class methodsFor: 'accessing' stamp: 'MarcusDenker 11/16/2012 14:50'! commandName ^ 'printVersion'! ! !ProceedDialogWindow commentStamp: 'gvc 5/18/2007 12:22'! Yes/no dialog. Test result as to whether the dialog is cancelled (no) or not (yes).! !ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 5/14/2013 09:44'! icon "Answer an icon for the receiver." ^ Smalltalk ui icons questionIcon! ! !ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2007 17:34'! yes "Answer yes." self ok! ! !ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 16:37'! handlesKeyboard: evt "Return true if the receiver wishes to handle the given keyboard event" (super handlesKeyboard: evt) ifTrue: [^true]. ^evt keyCharacter = $y or: [ evt keyCharacter = $n] ! ! !ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 13:50'! newButtons "Answer new buttons as appropriate." ^{self newOKButton. self newCancelButton isDefault: true}! ! !ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 16:38'! keyStroke: evt "Additionally check for y and n keys (aliases for ok and cancel)." (super keyStroke: evt) ifTrue: [^true]. evt keyCharacter = $y ifTrue: [self yes. ^true]. evt keyCharacter = $n ifTrue: [self no. ^true]. ^false! ! !ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2007 17:34'! no "Answer no." self cancel! ! !ProceedDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/14/2013 09:44'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons smallQuestionIcon! ! !Process commentStamp: 'IgorStasenko 11/7/2011 11:25'! I represent an independent path of control in the system. This path of control may be stopped (by sending the message suspend) in such a way that it can later be restarted (by sending the message resume). When any one of several paths of control can be advanced, the single instance of ProcessorScheduler named Processor determines which one will actually be advanced partly using the value of priority. (If anyone ever makes a subclass of Process, be sure to use allSubInstances in anyProcessesAbove:.) Process-specific storage: An old implementation using #environmentAt: [ifAbsent:/put:] protocol are no longer supported. One must not use a process-specific storage (PSS) methods directly, and instead use ProcessSpecificVariable (or subclass) instances to access process-specific storage. A new implemention is a revision towards making an access to PSS faster. When new instance of ProcessSpecificVariable are created, it obtains an unique index, which is registered using #allocatePSKey: (see class side). This allows to dynamically create as many process-specific variables as needed, and access them in fast manner via simple array index (instead of dictionary lookup, as in previous implementation). Another important aspect of new implementation is that all values in PSS are held weakly. This is done to prevent accidental memory leaks as well as no need to manually unregistering a process-specific keys , once they are no longer in use.! !Process methodsFor: 'accessing' stamp: 'ajh 1/24/2003 19:44'! isActiveProcess ^ self == Processor activeProcess! ! !Process methodsFor: 'accessing' stamp: 'ajh 1/27/2003 18:39'! copyStack ^ self copy install: suspendedContext copyStack! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:16'! completeStep: aContext "Resume self until aContext is on top, or if already on top, complete next step" | callee | self suspendedContext == aContext ifFalse: [ ^ self complete: (self calleeOf: aContext)]. callee := self step. callee == aContext ifTrue: [^ callee]. aContext isDead ifTrue: [^ self suspendedContext]. "returned" ^ self complete: callee "finish send"! ! !Process methodsFor: 'changing process state' stamp: 'StephaneDucasse 3/7/2010 15:50'! terminate "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating." | ctxt unwindBlock oldList | self isActiveProcess ifTrue: [ ctxt := thisContext. [ ctxt := ctxt findNextUnwindContextUpTo: nil. ctxt isNil ] whileFalse: [ (ctxt tempAt: 2) ifNil: [ ctxt tempAt: 2 put: nil. unwindBlock := ctxt tempAt: 1. thisContext terminateTo: ctxt. unwindBlock value ]]. thisContext terminateTo: nil. self suspend ] ifFalse: [ "Always suspend the process first so it doesn't accidentally get woken up" oldList := self suspend. suspendedContext ifNotNil:[ "Figure out if we are terminating the process while waiting in Semaphore>>critical: In this case, pop the suspendedContext so that we leave the ensure: block inside Semaphore>>critical: without signaling the semaphore." (oldList class == Semaphore and:[ suspendedContext method == (Semaphore compiledMethodAt: #critical:)]) ifTrue:[ suspendedContext := suspendedContext home.]. "If we are terminating a process halfways through an unwind, try to complete that unwind block first." (suspendedContext findNextUnwindContextUpTo: nil) ifNotNil: [ :outer | (suspendedContext findContextSuchThat: [ :c | c closure == (outer tempAt: 1)]) ifNotNil: [ :inner | "This is an unwind block currently under evaluation" suspendedContext runUntilErrorOrReturnFrom: inner ]]. ctxt := self popTo: suspendedContext bottomContext. ctxt == suspendedContext bottomContext ifFalse: [ self debug: ctxt title: 'Unwind error during termination']] ]. ! ! !Process methodsFor: 'accessing' stamp: 'ajh 1/24/2003 14:53'! calleeOf: aContext "Return the context whose sender is aContext. Return nil if aContext is on top. Raise error if aContext is not in process chain." suspendedContext == aContext ifTrue: [^ nil]. ^ (suspendedContext findContextSuchThat: [:c | c sender == aContext]) ifNil: [self error: 'aContext not in process chain']! ! !Process methodsFor: 'changing process state' stamp: 'tpr 2/14/2001 10:00'! primitiveResume "Primitive. Allow the process that the receiver represents to continue. Put the receiver in line to become the activeProcess. Fail if the receiver is already waiting in a queue (in a Semaphore or ProcessScheduler). Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !Process methodsFor: 'accessing' stamp: 'MarcusDenker 1/30/2014 17:42'! isTerminated self isActiveProcess ifTrue: [^ false]. ^suspendedContext isNil or: ["If the suspendedContext is the bottomContext it is the block in Process>>newProcess. If so, and the pc is greater than the startpc, the bock has alrteady sent and returned from value and there is nothing more to do." suspendedContext isBottomContext and: [ suspendedContext isDead not and: [ suspendedContext pc > suspendedContext startpc ] ] ] ! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 21:43'! completeTo: aContext "Resume self until aContext is on top" self suspendedContext == aContext ifTrue: [^ aContext]. ^ self complete: (self calleeOf: aContext)! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:17'! stepToSendOrReturn ^ suspendedContext := suspendedContext stepToSendOrReturn! ! !Process methodsFor: 'signaling' stamp: 'ar 12/7/2007 17:09'! signalException: anException "Signal an exception in the receiver process...if the receiver is currently suspended, the exception will get signaled when the receiver is resumed. If the receiver is blocked on a Semaphore, it will be immediately re-awakened and the exception will be signaled; if the exception is resumed, then the receiver will return to a blocked state unless the blocking Semaphore has excess signals" | oldList | "If we are the active process, go ahead and signal the exception" self isActiveProcess ifTrue: [^anException signal]. "Suspend myself first to ensure that I won't run away in the midst of the following modifications." myList ifNotNil:[oldList := self suspend]. "Add a new method context to the stack that will signal the exception" suspendedContext := MethodContext sender: suspendedContext receiver: self method: (self class lookupSelector: #pvtSignal:list:) arguments: (Array with: anException with: oldList). "If we are on a list to run, then suspend and restart the receiver (this lets the receiver run if it is currently blocked on a semaphore). If we are not on a list to be run (i.e. this process is suspended), then when the process is resumed, it will signal the exception" oldList ifNotNil: [self resume]. ! ! !Process methodsFor: 'accessing' stamp: 'dkh 4/25/2009 13:34'! isSuspended ^myList isNil or: [ myList isEmpty ]! ! !Process methodsFor: 'accessing' stamp: ''! suspendingList "Answer the list on which the receiver has been suspended." ^myList! ! !Process methodsFor: 'accessing' stamp: ''! suspendedContext "Answer the context the receiver has suspended." ^suspendedContext! ! !Process methodsFor: 'printing' stamp: 'ajh 10/2/2001 14:36'! longPrintOn: stream | ctxt | super printOn: stream. stream cr. ctxt := self suspendedContext. [ctxt == nil] whileFalse: [ stream space. ctxt printOn: stream. stream cr. ctxt := ctxt sender. ]. ! ! !Process methodsFor: 'changing suspended state' stamp: 'gk 12/18/2003 13:09'! popTo: aContext value: aValue "Replace the suspendedContext with aContext, releasing all contexts between the currently suspendedContext and it." | callee | self == Processor activeProcess ifTrue: [^ self error: 'The active process cannot pop contexts']. callee := (self calleeOf: aContext) ifNil: [^ self]. "aContext is on top" self return: callee value: aValue! ! !Process methodsFor: 'private' stamp: 'GiovanniCorriga 8/30/2009 15:40'! environmentKeyNotFound self error: 'Environment key not found'! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/31/2003 14:45'! step: aContext "Resume self until aContext is on top, or if already on top, do next step" ^ self suspendedContext == aContext ifTrue: [self step] ifFalse: [self complete: (self calleeOf: aContext)]! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:13'! complete: aContext "Run self until aContext is popped or an unhandled error is raised. Return self's new top context, unless an unhandled error was raised then return the signaler context (rather than open a debugger)." | ctxt pair error | ctxt := suspendedContext. suspendedContext := nil. "disable this process while running its stack in active process below" pair := ctxt runUntilErrorOrReturnFrom: aContext. suspendedContext := pair first. error := pair second. error ifNotNil: [^ error signalerContext]. ^ suspendedContext! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 22:06'! stepToCallee "Step until top context changes" | ctxt | ctxt := suspendedContext. [ctxt == suspendedContext] whileTrue: [ suspendedContext := suspendedContext step]. ^ suspendedContext! ! !Process methodsFor: 'printing' stamp: ''! printOn: aStream super printOn: aStream. aStream nextPutAll: ' in '. suspendedContext printOn: aStream! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 7/18/2003 22:13'! stepToHome: aContext "Resume self until the home of top context is aContext. Top context may be a block context." | home ctxt | home := aContext home. [ ctxt := self step. home == ctxt home. ] whileFalse: [ home isDead ifTrue: [^ self suspendedContext]. ]. ^ self suspendedContext! ! !Process methodsFor: 'debugging' stamp: 'CamilloBruni 9/21/2012 13:52'! debug: context title: title "Open debugger on self with context shown on top" ^ self debug: context title: title full: false. ! ! !Process methodsFor: 'signaling' stamp: 'svp 9/19/2003 18:41'! pvtSignal: anException list: aList "Private. This method is used to signal an exception from another process...the receiver must be the active process. If the receiver was previously waiting on a Semaphore, then return the process to the waiting state after signaling the exception and if the Semaphore has not been signaled in the interim" "Since this method is not called in a normal way, we need to take care that it doesn't directly return to the caller (because I believe that could have the potential to push an unwanted object on the caller's stack)." | blocker | self isActiveProcess ifFalse: [^self]. anException signal. blocker := Semaphore new. [self suspend. suspendedContext := suspendedContext swapSender: nil. aList class == Semaphore ifTrue: [aList isSignaled ifTrue: [aList wait. "Consume the signal that would have restarted the receiver" self resume] ifFalse: ["Add us back to the Semaphore's list (and remain blocked)" myList := aList. aList add: self]] ifFalse: [self resume]] fork. blocker wait. ! ! !Process methodsFor: 'changing suspended state' stamp: 'nk 7/10/2004 11:16'! restartTopWith: method "Rollback top context and replace with new method. Assumes self is suspended" method isQuick ifTrue: [ self popTo: suspendedContext sender ] ifFalse: [ suspendedContext privRefreshWith: method ]. ! ! !Process methodsFor: 'private' stamp: ''! suspendedContext: aContext suspendedContext := aContext! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:26'! return: aContext value: value "Pop thread down to aContext's sender. Execute any unwind blocks on the way. See #popTo: comment and #runUntilErrorOrReturnFrom: for more details." suspendedContext == aContext ifTrue: [ ^ suspendedContext := aContext return: value from: aContext]. self activateReturn: aContext value: value. ^ self complete: aContext. ! ! !Process methodsFor: 'changing process state' stamp: 'tpr 2/14/2001 10:03'! resume "Allow the process that the receiver represents to continue. Put the receiver in line to become the activeProcess. Check for a nil suspendedContext, which indicates a previously terminated Process that would cause a vm crash if the resume attempt were permitted" suspendedContext ifNil: [^ self primitiveFailed]. ^ self primitiveResume! ! !Process methodsFor: 'changing suspended state' stamp: ''! install: aContext "Replace the suspendedContext with aContext." self == Processor activeProcess ifTrue: [^self error: 'The active process cannot install contexts']. suspendedContext := aContext! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 20:40'! restartTop "Rollback top context and replace with new method. Assumes self is suspended" suspendedContext privRefresh! ! !Process methodsFor: 'process specific' stamp: 'IgorStasenko 11/2/2011 19:25'! resetPSValueAt: index "NOTE: this method are PRIVATE. " env ifNil: [ ^ self ]. index > env size ifTrue: [ ^ self ]. env at: index put: nil! ! !Process methodsFor: 'changing process state' stamp: 'ajh 1/23/2003 23:02'! run "Suspend current process and execute self instead" | proc | proc := Processor activeProcess. [ proc suspend. self resume. ] forkAt: Processor highestPriority! ! !Process methodsFor: 'process specific' stamp: 'SeanDeNigris 7/16/2012 07:42'! psValueAt: index put: value "Set a value for given index in process-specific storage" "NOTE: this method are PRIVATE. Do not use it directly, instead use ProcessSpecificVariable (or its subclasses) " env ifNil: [ env := WeakArray new: PSKeys size ]. env size < PSKeys size ifTrue: [ env := env grownBy: PSKeys size - env size ]. ^ env at: index put: value.! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:26'! popTo: aContext "Pop self down to aContext by remote returning from aContext's callee. Unwind blocks will be executed on the way. This is done by pushing a new context on top which executes 'aContext callee return' then resuming self until aContext is reached. This way any errors raised in an unwind block will get handled by senders in self and not by senders in the activeProcess. If an unwind block raises an error that is not handled then the popping stops at the error and the signalling context is returned, othewise aContext is returned." | callee | self == Processor activeProcess ifTrue: [^ self error: 'The active process cannot pop contexts']. callee := (self calleeOf: aContext) ifNil: [^ aContext]. "aContext is on top" ^ self return: callee value: callee receiver! ! !Process methodsFor: 'printing' stamp: 'nk 10/28/2000 07:33'! browserPrintString ^self browserPrintStringWith: suspendedContext! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:17'! step ^ suspendedContext := suspendedContext step! ! !Process methodsFor: 'changing process state' stamp: 'ar 12/7/2007 17:10'! suspend "Primitive. Stop the process that the receiver represents in such a way that it can be restarted at a later time (by sending the receiver the message resume). If the receiver represents the activeProcess, suspend it. Otherwise remove the receiver from the list of waiting processes. The return value of this method is the list the receiver was previously on (if any)." | oldList | "This is fallback code for VMs which only support the old primitiveSuspend which would not accept processes that are waiting to be run." myList ifNil:[^nil]. "this allows us to use suspend multiple times" oldList := myList. myList := nil. oldList remove: self ifAbsent:[]. ^oldList! ! !Process methodsFor: 'accessing' stamp: 'svp 12/5/2002 14:42'! name: aString name := aString! ! !Process methodsFor: 'process specific' stamp: 'IgorStasenko 11/2/2011 19:44'! psValueAt: index "Answer a process-specific value at given index, or nil if value at given index is not defined" "NOTE: this method are PRIVATE. Do not use it directly, instead use ProcessSpecificVariable (or its subclasses) " env ifNil: [ ^ nil ]. ^ env at: index ifAbsent: nil! ! !Process methodsFor: 'debugging' stamp: 'CamilloBruni 9/21/2012 13:52'! debug: context title: title full: bool ^ Smalltalk tools debugger openOn: self context: context label: title contents: nil fullView: bool. ! ! !Process methodsFor: 'accessing' stamp: 'ar 7/8/2001 17:04'! priority: anInteger "Set the receiver's priority to anInteger." (anInteger >= Processor lowestPriority and:[anInteger <= Processor highestPriority]) ifTrue: [priority := anInteger] ifFalse: [self error: 'Invalid priority: ', anInteger printString]! ! !Process methodsFor: 'accessing' stamp: ''! priority "Answer the priority of the receiver." ^priority! ! !Process methodsFor: 'debugging' stamp: 'CamilloBruni 9/21/2012 13:52'! debug ^ self debugWithTitle: 'Debug'.! ! !Process methodsFor: 'accessing' stamp: 'MartinMcClure 1/10/2010 17:54'! name ^name ifNil: [ self hash asString forceTo: 10 paddingStartWith: $ ]! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 16:14'! activateReturn: aContext value: value "Activate 'aContext return: value', so execution will return to aContext's sender" ^ suspendedContext := suspendedContext activateReturn: aContext value: value! ! !Process methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 10:51'! browserPrintStringWith: anObject | stream | stream := (String new: 100) writeStream. stream nextPut: $(. priority printOn: stream. self isSuspended ifTrue: [stream nextPut: $s]. stream nextPutAll: ') '. stream nextPutAll: self name. stream nextPut: $:. stream space. stream nextPutAll: anObject asString. ^ stream contents! ! !Process methodsFor: 'debugging' stamp: 'CamilloBruni 9/21/2012 13:52'! debugWithTitle: title "Open debugger on self" | context | context := self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext]. ^ self debug: context title: title full: true. ! ! !Process class methodsFor: 'process specific' stamp: 'MarianoMartinezPeck 8/28/2012 14:53'! allocatePSKey: anObject "Add a new process-specific key. If an object already registered as a key, answer its index, if object is not registered, first search for an empty slot for insertion and if not found, grow an array to add new object" | index | PSKeysSema ifNil: [ PSKeysSema := Semaphore forMutualExclusion ]. PSKeysSema critical: [ PSKeys ifNil: [ PSKeys := WeakArray with: anObject. index := 1 ] ifNotNil: [ index := PSKeys indexOf: anObject. index = 0 ifTrue: [ index := PSKeys indexOf: nil. index = 0 ifTrue: [ index := (PSKeys := PSKeys copyWith: anObject) size ] ifFalse: [ "Yes, this is slow, but we have to make sure that if we reusing index, all existing processes having value at given index reset to nil. We don't care if new processes will be created during this loop, since their env variable will be initially nil anyways, hence nothing to reset " Process allSubInstancesDo: [:p | p resetPSValueAt: index ]. PSKeys at: index put: anObject. ] ] ] ]. ^ index! ! !Process class methodsFor: 'instance creation' stamp: ''! forContext: aContext priority: anInteger "Answer an instance of me that has suspended aContext at priority anInteger." | newProcess | newProcess := self new. newProcess suspendedContext: aContext. newProcess priority: anInteger. ^newProcess! ! !ProcessBrowser commentStamp: ''! Change Set: ProcessBrowser Date: 14 March 2000 Author: Ned Konz email: ned@bike-nomad.com This is distributed under the Squeak License. Added 14 March: CPUWatcher integration automatically start and stop CPUWatcher added CPUWatcher to process list menu Added 29 October: MVC version 2.8, 2.7 compatibility rearranged menus added pointer inspection and chasing added suspend/resume recognized more well-known processes misc. bug fixes Added 26 October: highlight pc in source code Added 27 October: added 'signal semaphore' added 'inspect receiver', 'explore receiver', 'message tally' to stack list menu added 'find context', 'next context' to process list menu added 'change priority' and 'debug' choices to process list menu 27 October mods by Bob Arning: alters process display in Ned's ProcessBrowser to - show process priority - drop 'a Process in' that appears on each line - show in priority order - prettier names for known processes - fix to Utilities to forget update downloading process when it ends (1 less dead process) - correct stack dump for the active process ! !ProcessBrowser methodsFor: 'stack list' stamp: 'eem 6/12/2008 12:44'! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." (selectedContext isNil or: [methodText isEmptyOrNil]) ifTrue: [^ 1 to: 0]. ^selectedContext debuggerMap rangeForPC: (selectedContext pc ifNotNil: [:pc| pc] ifNil: [selectedContext method endPC]) contextIsActiveContext: stackListIndex = 1! ! !ProcessBrowser methodsFor: 'initialization' stamp: 'lr 3/14/2010 21:13'! stopCPUWatcher | pw | pw := Smalltalk globals at: #CPUWatcher ifAbsent: [ ^ self ]. pw ifNotNil: [ pw stopMonitoring. self updateProcessList. startedCPUWatcher := false "so a manual restart won't be killed later" ]! ! !ProcessBrowser methodsFor: 'initialization' stamp: 'nk 3/14/2001 08:03'! windowIsClosing startedCPUWatcher ifTrue: [ CPUWatcher stopMonitoring ]! ! !ProcessBrowser methodsFor: 'accessing' stamp: 'sd 3/25/2012 20:53'! selectedMethod ^ methodText ifNil: [methodText := selectedContext ifNil: [''] ifNotNil: [| pcRange | methodText := [ selectedContext sourceCode ] ifError: [ 'error getting method text' ]. pcRange := self pcRange. methodText asText addAttribute: TextColor red from: pcRange first to: pcRange last; addAttribute: TextEmphasis bold from: pcRange first to: pcRange last]]! ! !ProcessBrowser methodsFor: 'updating' stamp: 'AlainPlantec 7/9/2013 12:40'! setUpdateCallbackAfter: seconds deferredMessageRecipient ifNotNil: [ | d | d := Delay forSeconds: seconds. [ d wait. d := nil. deferredMessageRecipient defer: [self updateProcessList] ] fork ]! ! !ProcessBrowser methodsFor: 'process list' stamp: 'StephaneDucasse 5/18/2012 18:29'! keyEventsDict ^ keyEventsDict ifNil: [ keyEventsDict := Dictionary newFromPairs: #( $i #inspectProcess $I #exploreProcess $e #explorePointers $P #inspectPointers $t #terminateProcess $r #resumeProcess $s #suspendProcess $d #debugProcess $p #changePriority $m #messageTally $f #findContext $g #nextContext $a #toggleAutoUpdate $u #updateProcessList $S #signalSemaphore $k #moreStack ) ] ! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'EstebanLorenzano 1/31/2013 19:25'! stackListMenu: aMenu selectedContext ifNil: [^ aMenu]. ^aMenu addAllFromPragma: 'processBrowserStackListMenu' target: self! ! !ProcessBrowser methodsFor: 'accessing' stamp: ''! processList ^ processList! ! !ProcessBrowser methodsFor: 'initialization' stamp: 'StephaneDucasse 5/18/2012 18:08'! initialize super initialize. self class registerWellKnownProcesses. methodText := ''. stackListIndex := 0. searchString := ''. lastUpdate := 0. startedCPUWatcher := CPUWatcher cpuWatcherEnabled and: [ self startCPUWatcher ]. self updateProcessList; processListIndex: 1! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 09:58'! signalSemaphore (selectedProcess suspendingList isKindOf: Semaphore) ifFalse: [^ self]. [selectedProcess suspendingList signal] fork. (Delay forMilliseconds: 300) wait. "Hate to make the UI wait, but it's convenient..." self updateProcessList! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 12:13'! moreStack self updateStackList: 2000! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'DamienCassou 9/29/2009 13:07'! changePriority | str newPriority nameAndRules | nameAndRules := self nameAndRulesForSelectedProcess. nameAndRules third ifFalse: [self inform: 'Nope, won''t change priority of ' , nameAndRules first. ^ self]. str := UIManager default request: 'New priority' initialAnswer: selectedProcess priority asString. str ifNil: [str := String new]. newPriority := str asNumber asInteger. newPriority ifNil: [^ self]. (newPriority < 1 or: [newPriority > Processor highestPriority]) ifTrue: [self inform: 'Bad priority'. ^ self]. self class setProcess: selectedProcess toPriority: newPriority. self updateProcessList! ! !ProcessBrowser methodsFor: 'initialization' stamp: 'JuanVuletich 10/26/2010 14:05'! mayBeStartCPUWatcher startedCPUWatcher ifTrue: [ self setUpdateCallbackAfter: 7 ]. ! ! !ProcessBrowser methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/31/2013 18:20'! selectedProcess ^selectedProcess! ! !ProcessBrowser methodsFor: '*Shout-Styling' stamp: 'AlainPlantec 8/27/2011 00:03'! shoutAboutToStyle: aPluggableShoutMorphOrView selectedContext ifNil: [^false]. aPluggableShoutMorphOrView classOrMetaClass: self selectedClass. ^ true ! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'BernardoContreras 8/15/2011 20:29'! messageTally | secString secs | secString := UIManager default request: 'Profile for how many seconds?' initialAnswer: '4'. secString ifNil: [secString := String new]. secs := secString asNumber asInteger. (secs isNil or: [secs isZero]) ifTrue: [^ self]. [ Smalltalk tools timeProfiler spyOnProcess: selectedProcess forMilliseconds: secs * 1000 ] forkAt: selectedProcess priority + 1.! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'IgorStasenko 4/26/2011 15:35'! browseContext selectedContext ifNil: [^ self]. Smalltalk tools browser newOnClass: self selectedClass selector: self selectedSelector! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 7/8/2000 20:23'! inspectContext selectedContext inspect! ! !ProcessBrowser methodsFor: 'process list' stamp: 'CamilloBruni 5/25/2012 18:19'! processNameList "since processList is a WeakArray, we have to strengthen the result" | pw tally | pw := Smalltalk globals at: #CPUWatcher ifAbsent: [ ]. tally := pw ifNotNil: [ pw current ifNotNil: [ pw current tally ] ]. ^ (processList asOrderedCollection copyWithout: nil) collect: [ :each | | percent | percent := tally ifNotNil: [ (((tally occurrencesOf: each) * 100.0 / tally size roundTo: 1) asString padLeftTo: 2) , '% ' ] ifNil: [ '' ]. percent , (self prettyNameForProcess: each) ]! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 13:23'! resumeProcess selectedProcess ifNil: [^ self]. self class resumeProcess: selectedProcess. self updateProcessList! ! !ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/28/2000 08:19'! notify: errorString at: location in: aStream "A syntax error happened when I was trying to highlight my pc. Raise a signal so that it can be ignored." Warning signal: 'syntax error'! ! !ProcessBrowser methodsFor: 'updating' stamp: 'sd 11/20/2005 21:27'! stopAutoUpdate autoUpdateProcess ifNotNil: [ autoUpdateProcess terminate. autoUpdateProcess := nil]. self updateProcessList! ! !ProcessBrowser methodsFor: 'updating' stamp: 'nk 10/28/2000 21:50'! toggleAutoUpdate self isAutoUpdating ifTrue: [ self stopAutoUpdate ] ifFalse: [ self startAutoUpdate ]. ! ! !ProcessBrowser methodsFor: 'process list' stamp: 'sd 11/20/2005 21:27'! prettyNameForProcess: aProcess | nameAndRules | aProcess ifNil: [ ^'' ]. nameAndRules := self nameAndRulesFor: aProcess. ^ aProcess browserPrintStringWith: nameAndRules first! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:28'! exploreContext selectedContext explore! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'sd 11/20/2005 21:27'! debugProcess | nameAndRules | nameAndRules := self nameAndRulesForSelectedProcess. nameAndRules third ifFalse: [self inform: 'Nope, won''t debug ' , nameAndRules first. ^ self]. self class debugProcess: selectedProcess.! ! !ProcessBrowser methodsFor: 'accessing' stamp: ''! stackListIndex ^ stackListIndex! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'sd 11/20/2005 21:27'! suspendProcess | nameAndRules | selectedProcess isSuspended ifTrue: [^ self]. nameAndRules := self nameAndRulesForSelectedProcess. nameAndRules second ifFalse: [self inform: 'Nope, won''t suspend ' , nameAndRules first. ^ self]. self class suspendProcess: selectedProcess. self updateProcessList! ! !ProcessBrowser methodsFor: 'process list' stamp: 'DamienCassou 9/29/2009 13:07'! findContext | initialProcessIndex initialStackIndex found | initialProcessIndex := self processListIndex. initialStackIndex := self stackListIndex. searchString := UIManager default request: 'Enter a string to search for in the process stack lists' initialAnswer: searchString. searchString isEmptyOrNil ifTrue: [^ false]. self processListIndex: 1. self stackListIndex: 1. found := self nextContext. found ifFalse: [self processListIndex: initialProcessIndex. self stackListIndex: initialStackIndex]. ^ found! ! !ProcessBrowser methodsFor: 'accessing' stamp: 'md 2/17/2006 12:07'! selectedSelector "Answer the class in which the currently selected context's method was found." ^ selectedSelector ifNil: [selectedSelector := selectedContext receiver ifNil: [selectedClass := selectedContext method methodClass selectedContext method selector] ifNotNil: [selectedContext selector]]! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'sd 11/20/2005 21:27'! updateStackList: depth | suspendedContext oldHighlight | selectedProcess ifNil: [^ self changeStackListTo: nil]. (stackList notNil and: [ stackListIndex > 0 ]) ifTrue: [oldHighlight := stackList at: stackListIndex]. selectedProcess == Processor activeProcess ifTrue: [self changeStackListTo: (thisContext stackOfSize: depth)] ifFalse: [suspendedContext := selectedProcess suspendedContext. suspendedContext ifNil: [self changeStackListTo: nil] ifNotNil: [self changeStackListTo: (suspendedContext stackOfSize: depth)]]. self stackListIndex: (stackList ifNil: [0] ifNotNil: [stackList indexOf: oldHighlight])! ! !ProcessBrowser methodsFor: 'process list' stamp: 'EstebanLorenzano 8/17/2012 16:40'! nextContext | initialProcessIndex initialStackIndex found | searchString isEmpty ifTrue: [ ^false ]. initialProcessIndex := self processListIndex. initialStackIndex := self stackListIndex. found := false. initialProcessIndex to: self processList size do: [:pi | found ifFalse: [self processListIndex: pi. self stackNameList withIndexDo: [:name :si | (found not and: [pi ~= initialProcessIndex or: [si > initialStackIndex]]) ifTrue: [(name includesSubstring: searchString) ifTrue: [self stackListIndex: si. found := true]]]]]. found ifFalse: [self processListIndex: initialProcessIndex. self stackListIndex: initialStackIndex]. ^ found! ! !ProcessBrowser methodsFor: 'process list' stamp: ''! inspectProcess selectedProcess inspect! ! !ProcessBrowser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! processListIndex: index processListIndex := index. selectedProcess := processList at: index ifAbsent: []. self updateStackList. self changed: #processListIndex.! ! !ProcessBrowser methodsFor: 'views' stamp: 'MarcusDenker 10/15/2012 21:21'! openAsMorph | window aTextMorph | window := (SystemWindow labelled: 'later') model: self. self deferredMessageRecipient: WorldState. window addMorph: ((PluggableListMorph on: self list: #processNameList selected: #processListIndex changeSelected: #processListIndex: menu: #processListMenu: keystroke: #processListKey:from:) enableDragNDrop: false) frame: (0 @ 0 extent: 0.5 @ 0.5). window addMorph: ((PluggableListMorph on: self list: #stackNameList selected: #stackListIndex changeSelected: #stackListIndex: menu: #stackListMenu: keystroke: #stackListKey:from:) enableDragNDrop: false) frame: (0.5 @ 0.0 extent: 0.5 @ 0.5). aTextMorph := PluggableTextMorph on: self text: #selectedMethod accept: nil readSelection: nil menu: nil. aTextMorph askBeforeDiscardingEdits: false. aTextMorph font: StandardFonts codeFont. window addMorph: aTextMorph frame: (0 @ 0.5 corner: 1 @ 1). window setUpdatablePanesFrom: #(#processNameList #stackNameList ). (window setLabel: 'Process Browser') openInWorld. self mayBeStartCPUWatcher. ^ window! ! !ProcessBrowser methodsFor: 'accessing' stamp: 'nk 10/28/2000 08:36'! text ^methodText! ! !ProcessBrowser methodsFor: 'accessing' stamp: ''! processListIndex ^ processListIndex! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'IgorStasenko 1/22/2012 14:42'! explorePointers | saved | selectedProcess ifNil: [ ^ self ]. saved := selectedProcess. [ selectedProcess := nil. (Smalltalk tools hasToolNamed: #pointerExplorer) ifTrue: [ Smalltalk tools pointerExplorer openOn: saved ] ifFalse: [ self inspectPointers ] ] ensure: [ selectedProcess := saved ]! ! !ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/27/2000 09:24'! exploreProcess selectedProcess explore! ! !ProcessBrowser methodsFor: 'process list' stamp: 'StephaneDucasse 5/18/2012 18:31'! processListKey: aKey from: aView self perform: (self keyEventsDict at: aKey ifAbsent: [ ^ self ])! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 16:18'! stackNameList ^ stackList ifNil: [#()] ifNotNil: [stackList collect: [:each | each asString]]! ! !ProcessBrowser methodsFor: 'accessing' stamp: 'eem 6/12/2008 12:41'! stackListIndex: index stackListIndex := index. selectedContext := (stackList notNil and: [index > 0]) ifTrue: [stackList at: index ifAbsent: []]. selectedClass := nil. selectedSelector := nil. methodText := nil. self changed: #stackListIndex. self changed: #selectedMethod! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'sd 11/20/2005 21:27'! terminateProcess | nameAndRules | nameAndRules := self nameAndRulesForSelectedProcess. nameAndRules second ifFalse: [self inform: 'Nope, won''t kill ' , nameAndRules first. ^ self]. self class terminateProcess: selectedProcess. self updateProcessList! ! !ProcessBrowser methodsFor: 'views' stamp: 'nk 10/28/2000 11:44'! hasView ^self dependents isEmptyOrNil not! ! !ProcessBrowser methodsFor: 'updating' stamp: 'AlainPlantec 7/9/2013 12:40'! startAutoUpdate self isAutoUpdatingPaused ifTrue: [ ^autoUpdateProcess resume ]. self isAutoUpdating ifFalse: [| delay | delay := Delay forSeconds: 2. autoUpdateProcess := [[self hasView] whileTrue: [delay wait. deferredMessageRecipient ifNotNil: [ deferredMessageRecipient defer: [self updateProcessList]] ifNil: [ self updateProcessList ]]. autoUpdateProcess := nil] fork]. self updateProcessList! ! !ProcessBrowser methodsFor: 'accessing' stamp: 'JuanVuletich 10/26/2010 14:01'! deferredMessageRecipient: anObject deferredMessageRecipient := anObject! ! !ProcessBrowser methodsFor: 'process list' stamp: 'EstebanLorenzano 1/31/2013 19:25'! processListMenu: menu ^menu addAllFromPragma: 'processBrowserProcessListMenu' target: self! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:41'! inspectReceiver selectedContext ifNotNil: [selectedContext receiver inspect]! ! !ProcessBrowser methodsFor: 'accessing' stamp: 'md 2/17/2006 09:32'! selectedClass "Answer the class in which the currently selected context's method was found." ^ selectedClass ifNil: [selectedClass := selectedContext receiver ifNil: [selectedSelector := selectedContext method selector. selectedContext method methodClass] ifNotNil: [selectedContext methodClass]]! ! !ProcessBrowser methodsFor: 'views' stamp: 'StephaneDucasse 5/18/2012 18:37'! stackListKey: aKey from: aView aKey = $c ifTrue: [ self inspectContext]. aKey = $C ifTrue: [ self exploreContext]. aKey = $i ifTrue: [ self inspectReceiver]. aKey = $I ifTrue: [ self exploreReceiver]. aKey = $b ifTrue: [ self browseContext]. ! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'ClementBera 9/30/2013 09:51'! inspectPointers | tc pointers | selectedProcess ifNil: [ ^ self ]. tc := thisContext. pointers := selectedProcess pointersToExcept: { self processList. tc. self}. pointers ifEmpty: [ ^ self ]. pointers inspectWithLabel: 'Objects pointing to ' , selectedProcess browserPrintString! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 13:35'! nameAndRulesFor: aProcess "Answer a nickname and two flags: allow-stop, and allow-debug" aProcess == autoUpdateProcess ifTrue: [ ^{'my auto-update process'. true. true} ]. ^self class nameAndRulesFor: aProcess ! ! !ProcessBrowser methodsFor: 'updating' stamp: 'nk 6/18/2003 07:20'! isAutoUpdatingPaused ^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended ]! ! !ProcessBrowser methodsFor: 'updating' stamp: 'nk 6/18/2003 07:20'! pauseAutoUpdate self isAutoUpdating ifTrue: [ autoUpdateProcess suspend ]. self updateProcessList! ! !ProcessBrowser methodsFor: 'accessing' stamp: ''! stackList ^ stackList! ! !ProcessBrowser methodsFor: 'updating' stamp: 'nk 10/28/2000 21:48'! isAutoUpdating ^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended not ]! ! !ProcessBrowser methodsFor: 'process list' stamp: 'GuillermoPolito 9/4/2010 20:39'! updateProcessList | oldSelectedProcess newIndex now | now := Time millisecondClockValue. now - lastUpdate < 500 ifTrue: [^ self]. "Don't update too fast" lastUpdate := now. oldSelectedProcess := selectedProcess. processList := selectedProcess := selectedSelector := nil. Smalltalk garbageCollectMost. "lose defunct processes" processList := Process allSubInstances reject: [:each | each isTerminated]. processList := processList sort: [:a :b | a priority >= b priority]. processList := WeakArray withAll: processList. newIndex := processList indexOf: oldSelectedProcess ifAbsent: [0]. self changed: #processNameList. self processListIndex: newIndex! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:41'! exploreReceiver selectedContext ifNotNil: [ selectedContext receiver explore ]! ! !ProcessBrowser methodsFor: 'initialization' stamp: 'lr 3/14/2010 21:13'! startCPUWatcher "Answers whether I started the CPUWatcher" | pw | pw := Smalltalk globals at: #CPUWatcher ifAbsent: [ ^ self ]. pw ifNotNil: [ pw isMonitoring ifFalse: [ pw startMonitoringPeriod: 5 rate: 100 threshold: 0.85. self setUpdateCallbackAfter: 7. ^ true ] ]. ^ false! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 7/8/2000 20:24'! updateStackList self updateStackList: 20! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 08:56'! wasProcessSuspendedByProcessBrowser: aProcess ^self class suspendedProcesses includesKey: aProcess! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/28/2000 20:31'! nameAndRulesForSelectedProcess "Answer a nickname and two flags: allow-stop, and allow-debug" ^self nameAndRulesFor: selectedProcess! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'sd 11/20/2005 21:27'! changeStackListTo: aCollection stackList := aCollection. self changed: #stackNameList. self stackListIndex: 0! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'GabrielOmarCotelli 11/30/2013 16:24'! unregisterWellKnownProcess: aProcess "Remove the first registry entry that matches aProcess. Use with caution if more than one registry entry may match aProcess." "self unregisterWellKnownProcess: Smalltalk lowSpaceWatcherProcess" WellKnownProcesses detect: [ :e | e key value == aProcess ] ifFound: [ :entry | WellKnownProcesses remove: entry ]! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'dtl 2/5/2005 09:07'! registerWellKnownProcess: aBlockForProcess label: nickname allowStop: allowStop allowDebug: allowDebug "Add an entry to the registry of well known processes. aBlockForProcess evaluates to a known process to be identified by nickname, and allowStop and allowDebug are flags controlling allowable actions for this process in the browser." WellKnownProcesses add: aBlockForProcess->[{nickname . allowStop . allowDebug}]! ! !ProcessBrowser class methodsFor: '*Polymorph-Widgets' stamp: 'EstebanLorenzano 5/14/2013 09:43'! theme ^ Smalltalk ui theme! ! !ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'AlainPlantec 7/9/2013 12:40'! tallyCPUUsageFor: seconds every: msec "Compute CPU usage using a msec millisecond sample for the given number of seconds, then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile" "ProcessBrowser tallyCPUUsageFor: 10 every: 100" | promise | promise := Processor tallyCPUUsageFor: seconds every: msec. [ | tally | tally := promise value. UIManager default defer: [ self dumpTallyOnTranscript: tally ]. ] fork.! ! !ProcessBrowser class methodsFor: 'initialization' stamp: 'MarcusDenker 5/20/2011 08:32'! initialize "ProcessBrowser initialize" SuspendedProcesses ifNil: [ SuspendedProcesses := IdentityDictionary new ]. self registerWellKnownProcesses! ! !ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'IgorStasenko 4/26/2011 15:52'! dumpPigStackOn: aStream andClose: aBoolean "Must run forked on its own process, so the monitored behavior is not affected too much" | promise tally process depth stack suspendedContext | promise := Processor tallyCPUUsageFor: 1 every: 10. tally := promise value. "WorldState addDeferredUIMessage: [self dumpTallyOnTranscript: tally]." aStream nextPutAll: '====Al processes===='; cr. self dumpTally: tally on: aStream. aStream cr; nextPutAll: '====Process using most CPU===='; cr. process := tally sortedCounts first value. (100.0 * (tally occurrencesOf: process) / tally size) rounded printOn: aStream. aStream nextPutAll: ' % '; nextPutAll: (process browserPrintStringWith: (self nameAndRulesFor: process) first); cr. depth := 20. stack := process == Processor activeProcess ifTrue: [thisContext stackOfSize: depth] ifFalse: [suspendedContext := process suspendedContext. suspendedContext ifNotNil: [suspendedContext stackOfSize: depth]]. stack ifNil: [ aStream nextPutAll: 'No context'; cr] ifNotNil: [ stack do: [ :c | c printOn: aStream. aStream cr]]. aBoolean ifTrue: [aStream close]! ! !ProcessBrowser class methodsFor: 'tools registry' stamp: 'IgorStasenko 2/19/2011 03:01'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #processBrowser ! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 17:09'! debugProcess: aProcess self resumeProcess: aProcess. aProcess debugWithTitle: 'Interrupted from the Process Browser'. ! ! !ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'jmv 5/22/2009 12:30'! dumpTallyOnTranscript: tally "tally is from ProcessorScheduler>>tallyCPUUsageFor: Dumps lines with percentage of time, hash of process, and a friendly name" self dumpTally: tally on: Transcript. Transcript flush.! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'! setProcess: aProcess toPriority: priority | oldPriority | oldPriority := self suspendedProcesses at: aProcess ifAbsent: [ ]. oldPriority ifNotNil: [ self suspendedProcesses at: aProcess put: priority ]. aProcess priority: priority. ^oldPriority! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'CamilloBruni 8/21/2013 19:24'! nameAndRulesFor: aProcess "Answer a nickname and two flags: allow-stop, and allow-debug" | rules | rules := {nil. true. true}. WellKnownProcesses do: [:blockAndRules | blockAndRules key value == aProcess ifTrue: [ rules := blockAndRules value value ]]. rules first ifNil: [ rules at: 1 put: aProcess suspendedContext asString ]. ^ rules! ! !ProcessBrowser class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'EstebanLorenzano 5/15/2013 13:50'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ Smalltalk ui icons iconNamed: #processBrowserIcon! ! !ProcessBrowser class methodsFor: 'world menu' stamp: 'TorstenBergmann 2/12/2014 09:25'! menuCommandOn: aBuilder (aBuilder item: #'Process Browser') parent: #Tools; order: 0.42; action:[self open]; icon: self taskbarIcon.! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'! suspendProcess: aProcess | priority | priority := aProcess priority. self suspendedProcesses at: aProcess put: priority. "Need to take the priority down below the caller's so that it can keep control after signaling the Semaphore" (aProcess suspendingList isKindOf: Semaphore) ifTrue: [aProcess priority: Processor lowestPriority. aProcess suspendingList signal]. [aProcess suspend] on: Error do: [:ex | self suspendedProcesses removeKey: aProcess]. aProcess priority: priority. ! ! !ProcessBrowser class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:25'! menuStackList: aBuilder (aBuilder item: #'Inspect context') keyText: 'c'; selector: #inspectContext. (aBuilder item: #'Explore context') keyText: 'C'; selector: #exploreContext; withSeparatorAfter. (aBuilder item: #'Inspect receiver') keyText: 'i'; selector: #inspectReceiver. (aBuilder item: #'Explore receiver') keyText: 'I'; selector: #exploreReceiver; withSeparatorAfter. (aBuilder item: #'Browse') keyText: 'b'; selector: #browseContext.! ! !ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'nk 3/8/2001 12:49'! tallyCPUUsageFor: seconds "Compute CPU usage using a 10-msec sample for the given number of seconds, then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile" "ProcessBrowser tallyCPUUsageFor: 10" ^self tallyCPUUsageFor: seconds every: 10! ! !ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'stephane.ducasse 8/5/2009 17:07'! dumpTally: tally on: aStream "tally is from ProcessorScheduler>>tallyCPUUsageFor: Dumps lines with percentage of time, hash of process, and a friendly name" tally sortedCounts do: [ :assoc | | procName | procName := (self nameAndRulesFor: assoc value) first. (((assoc key / tally size) * 100.0) roundTo: 1) printOn: aStream. aStream nextPutAll: '% '; print: assoc value identityHash; space; nextPutAll: procName; cr. ]! ! !ProcessBrowser class methodsFor: 'initialization' stamp: 'MarcusDenker 10/2/2013 20:17'! cleanUp "Remove terminated processes from my suspended list" self suspendedProcesses keysDo: [:ea | ea isTerminated ifTrue: [self suspendedProcesses removeKey: ea]]! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 13:26'! wasProcessSuspendedByProcessBrowser: aProcess ^self suspendedProcesses includesKey: aProcess! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'! suspendedProcesses "Answer a collection of processes that my instances have suspended. This is so that they don't get garbage collected." ^ SuspendedProcesses ifNil: [SuspendedProcesses := IdentityDictionary new]! ! !ProcessBrowser class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:18'! menuProcessList: aBuilder | target selectedProcess | target := aBuilder model. selectedProcess := target selectedProcess. selectedProcess ifNotNil: [ | nameAndRules | nameAndRules := target nameAndRulesForSelectedProcess. (aBuilder item: #'Inspect') keyText: 'i'; selector: #inspectProcess. (aBuilder item: #'Explore') keyText: 'I'; selector: #exploreProcess. (aBuilder item: #'Inspect Pointers') keyText: 'P'; selector: #inspectPointers. (Smalltalk globals includesKey: #PointerExplorer) ifTrue: [ (aBuilder item: #'Explore pointers') keyText: 'e'; selector: #explorePointers ]. nameAndRules second ifTrue: [ (aBuilder item: #'Terminate') keyText: 't'; selector: #terminateProcess. selectedProcess isSuspended ifTrue: [ (aBuilder item: #'Resume') keyText: 'r'; selector: #resumeProcess ] ifFalse: [ (aBuilder item: #'Suspend') keyText: 's'; selector: #suspendProcess ] ]. nameAndRules third ifTrue: [ (aBuilder item: #'Change priority') keyText: 'p'; selector: #changePriority. (aBuilder item: #'Debug') keyText: 'd'; selector: #debugProcess ]. (aBuilder item: #'Profile messages') keyText: 'm'; selector: #messageTally. (selectedProcess suspendingList isKindOf: Semaphore) ifTrue: [ (aBuilder item: #'Signal Semaphore') keyText: 'S'; selector: #signalSemaphore ]. (aBuilder item: #'Full stack') keyText: 'k'; selector: #moreStack; withSeparatorAfter ]. (aBuilder item: #'Find context...') keyText: 'f'; selector: #findContext. (aBuilder item: #'Find again') keyText: 'g'; selector: #nextContext; withSeparatorAfter. (aBuilder item: (target isAutoUpdating ifTrue: [ #'Turn off auto-update' ] ifFalse: [ #'Turn on auto-update' ])) keyText: 'a'; selector: #toggleAutoUpdate. (aBuilder item: #'Update list') keyText: 'u'; selector: #updateProcessList. Smalltalk globals at: #CPUWatcher ifPresent: [ :pw | aBuilder withSeparatorAfter. pw isMonitoring ifTrue: [ (aBuilder item: #'Stop CPUWatcher') selector: #stopCPUWatcher ] ifFalse: [ (aBuilder item: #'Start CPUWatcher') selector: #startCPUWatcher ] ].! ! !ProcessBrowser class methodsFor: 'instance creation' stamp: 'alain.plantec 6/1/2008 19:03'! open "ProcessBrowser open" "Create and schedule a ProcessBrowser." Smalltalk garbageCollect. ^ self new openAsMorph! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'! resumeProcess: aProcess | priority | priority := self suspendedProcesses removeKey: aProcess ifAbsent: [aProcess priority]. aProcess priority: priority. aProcess suspendedContext ifNotNil: [ aProcess resume ] ! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 13:25'! terminateProcess: aProcess aProcess ifNotNil: [ self suspendedProcesses removeKey: aProcess ifAbsent: []. aProcess terminate ]. ! ! !ProcessBrowser class methodsFor: 'initialization' stamp: 'CamilloBruni 8/21/2013 19:21'! registerWellKnownProcesses "Associate each well-known process with a nickname and two flags: allow-stop, and allow-debug. Additional processes may be added to this list as required" WellKnownProcesses := OrderedCollection new. self registerWellKnownProcess: [ ] label: 'no process' allowStop: false allowDebug: false. self registerWellKnownProcess: [ Smalltalk lowSpaceWatcherProcess ] label: nil allowStop: false allowDebug: false. self registerWellKnownProcess: [ WeakArray runningFinalizationProcess ] label: nil allowStop: false allowDebug: false. self registerWellKnownProcess: [ Processor backgroundProcess ] label: nil allowStop: false allowDebug: false. self registerWellKnownProcess: [ InputEventFetcher default fetcherProcess ] label: nil allowStop: false allowDebug: false. self registerWellKnownProcess: [ UIManager default uiProcess ] label: nil allowStop: false allowDebug: false. self registerWellKnownProcess: [ Smalltalk globals at: #SoundPlayer ifPresent: [ :sp | sp playerProcess ] ] label: 'the Sound Player' allowStop: false allowDebug: false. self registerWellKnownProcess: [ Smalltalk globals at: #CPUWatcher ifPresent: [ :cw | cw currentWatcherProcess ] ] label: 'the CPUWatcher' allowStop: false allowDebug: false. self registerWellKnownProcess: [ Delay schedulingProcess ] label: nil allowStop: false allowDebug: false! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'JuanVuletich 11/1/2010 10:13'! isUIProcess: aProcess ^ aProcess == UIManager default uiProcess! ! !ProcessLocalVariable commentStamp: 'mvl 3/13/2007 12:28'! My subclasses have values specific to the active process. They can be read with #value and set with #value:! !ProcessLocalVariable methodsFor: 'evaluating' stamp: 'IgorStasenko 11/7/2011 11:20'! value: anObject Processor activeProcess psValueAt: index put: anObject! ! !ProcessLocalVariable class methodsFor: 'accessing' stamp: 'IgorStasenko 11/2/2011 18:41'! value: anObject ^ self soleInstance value: anObject! ! !ProcessSpecificTest commentStamp: 'mvl 3/13/2007 13:52'! A ProcessSpecificTest is a test case for process local and dynamic variables. ! !ProcessSpecificTest methodsFor: 'testing' stamp: 'mvl 3/13/2007 14:13'! checkLocal: value self assert: TestLocalVariable value = value! ! !ProcessSpecificTest methodsFor: 'testing' stamp: 'mvl 3/13/2007 15:03'! testLocalVariable | s1 s2 p1stopped p2stopped | s1 := Semaphore new. s2 := Semaphore new. p1stopped := p2stopped := false. [ self checkLocal: 0. TestLocalVariable value: 1. self checkLocal: 1. (Delay forMilliseconds: 30) wait. self checkLocal: 1. TestLocalVariable value: 2. self checkLocal: 2. p1stopped := true. s1 signal. ] fork. [ (Delay forMilliseconds: 30) wait. self checkLocal: 0. TestLocalVariable value: 3. self checkLocal: 3. (Delay forMilliseconds: 30) wait. self checkLocal: 3. TestLocalVariable value: 4. self checkLocal: 4. p2stopped := true. s2 signal. ] fork. "Set a maximum wait timeout so that the test case will complete even if the processes fail to signal us." s1 waitTimeoutMSecs: 5000. s2 waitTimeoutMSecs: 5000. self assert: p1stopped. self assert: p2stopped. ! ! !ProcessSpecificTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/3/2012 21:52'! testDynamicVariableBlockReturnValue | returnValue | returnValue := TestDynamicVariable value: 10 during: [ TestDynamicVariable value + 1 ]. self assert: returnValue equals: 11! ! !ProcessSpecificTest methodsFor: 'testing' stamp: 'mvl 3/13/2007 14:13'! checkDynamic: value self assert: TestDynamicVariable value = value! ! !ProcessSpecificTest methodsFor: 'testing' stamp: 'mvl 3/13/2007 15:02'! testDynamicVariable | s1 s2 p1stopped p2stopped | s1 := Semaphore new. s2 := Semaphore new. p1stopped := p2stopped := false. [ TestDynamicVariable value: 1 during:[ self checkDynamic: 1. (Delay forMilliseconds: 30) wait. self checkDynamic: 1. TestDynamicVariable value: 3 during:[ (Delay forMilliseconds: 30) wait. self checkDynamic: 3 ]. self checkDynamic: 1. ]. self checkDynamic: nil. p1stopped := true. s1 signal. ] fork. [ TestDynamicVariable value: 2 during:[ self checkDynamic: 2. (Delay forMilliseconds: 30) wait. self checkDynamic: 2. ]. self checkDynamic: nil. p2stopped := true. s2 signal. ] fork. "Set a maximum wait timeout so that the test case will complete even if the processes fail to signal us." s1 waitTimeoutSeconds: 2. s2 waitTimeoutSeconds: 2. self assert: p1stopped. self assert: p2stopped.! ! !ProcessSpecificVariable commentStamp: 'mvl 3/13/2007 13:53'! My subclasses (not instances of them) keep state specific to the current process. There are two kinds of process-specific variables: process-local (state available for read and write in all methods inside the process), and dynamic variables (implementing dynamic scope).! !ProcessSpecificVariable methodsFor: 'accessing' stamp: 'IgorStasenko 11/2/2011 19:26'! value ^ (Processor activeProcess psValueAt: index) ifNil: [ self default ]! ! !ProcessSpecificVariable methodsFor: 'accessing' stamp: 'IgorStasenko 11/2/2011 18:27'! default "Answer the default value for the variable. The default for the default value is nil." ^nil! ! !ProcessSpecificVariable methodsFor: 'accessing' stamp: 'IgorStasenko 11/2/2011 18:53'! valueOrNil "a faster version, which doesn't using ifAbsent: to avoid using block closure" ^ Processor activeProcess psValueAt: index ! ! !ProcessSpecificVariable methodsFor: 'accessing' stamp: 'IgorStasenko 11/7/2011 11:18'! index: anInteger index := anInteger! ! !ProcessSpecificVariable class methodsFor: 'accessing' stamp: 'IgorStasenko 11/2/2011 18:40'! soleInstance ^ soleInstance ifNil: [ soleInstance := self new ]! ! !ProcessSpecificVariable class methodsFor: 'class initialization' stamp: 'MarianoMartinezPeck 8/28/2012 14:53'! initialize "Add Process::env if it is missing" (Process instVarNames includes: 'env') ifFalse: [ Process addInstVarNamed: 'env']. self resetSoleInstance.! ! !ProcessSpecificVariable class methodsFor: 'accessing' stamp: 'IgorStasenko 11/2/2011 18:40'! value "Answer the current value for this variable in the current context." ^ self soleInstance value! ! !ProcessSpecificVariable class methodsFor: 'instance creation' stamp: 'IgorStasenko 11/2/2011 18:19'! new | instance | instance := super new. instance index: (Process allocatePSKey: instance). ^ instance! ! !ProcessSpecificVariable class methodsFor: 'class initialization' stamp: 'MarianoMartinezPeck 8/28/2012 14:53'! resetSoleInstance soleInstance := nil.! ! !ProcessTerminateBug commentStamp: 'TorstenBergmann 2/5/2014 08:42'! SUnit tests for Process termination! !ProcessTerminateBug methodsFor: 'tests' stamp: 'StephaneDucasse 3/7/2010 15:40'! testUnwindFromActiveProcess "self debug: #testUnwindFromActiveProcess" | sema process | sema := Semaphore forMutualExclusion. self assert: (sema isSignaled). process := [ sema critical: [ self deny: sema isSignaled. Processor activeProcess terminate.]] forkAt: Processor userInterruptPriority. self assert: sema isSignaled.! ! !ProcessTerminateBug methodsFor: 'tests' stamp: 'StephaneDucasse 3/7/2010 15:43'! testTerminationDuringUnwind "An illustration of the issue of process termination during unwind. This uses a well-behaved unwind block that we should allow to complete if at all possible." "self debug: #testTerminationDuringUnwind" | unwindStarted unwindFinished p | unwindStarted := unwindFinished := false. p := [[] ensure: [ unwindStarted := true. Processor yield. unwindFinished := true. ]] fork. self deny: unwindStarted. Processor yield. self assert: unwindStarted. self deny: unwindFinished. p terminate. self assert: unwindFinished.! ! !ProcessTerminateBug methodsFor: 'tests' stamp: 'CamilloBruni 8/31/2013 20:23'! testUnwindFromForeignProcess "self debug:#testUnwindFromForeignProcess" | sema process | sema := Semaphore forMutualExclusion. self assert: sema isSignaled. process := [ sema critical: [ self deny: sema isSignaled. sema wait "deadlock" ] ] forkAt: Processor userInterruptPriority. self deny: sema isSignaled. "This is for illustration only - the BlockCannotReturn cannot be handled here (it's truncated already)" process terminate. self assert: sema isSignaled! ! !ProcessTerminateBug methodsFor: 'tests' stamp: 'StephaneDucasse 3/7/2010 15:39'! testSchedulerTermination "self debug: #testSchedulerTermination" | process sema gotHere sema2 | gotHere := false. sema := Semaphore new. sema2 := Semaphore new. process := [ sema signal. sema2 wait. "will be suspended here" gotHere := true. "e.g., we must *never* get here" ] forkAt: Processor activeProcess priority. sema wait. "until process gets scheduled" process terminate. sema2 signal. Processor yield. "will give process a chance to continue and horribly screw up" self assert: gotHere not. ! ! !ProcessTest commentStamp: 'GiovanniCorriga 8/30/2009 14:56'! A ProcessTest holds test cases for generic Process-related behaviour.! !ProcessTest methodsFor: 'testing' stamp: 'SeanDeNigris 6/1/2012 22:52'! testNewProcessWith | hasBlockRun block return passedArguments receivedArgument1 receivedArgument2 | hasBlockRun := false. block := [ :a :b | receivedArgument1 := a. receivedArgument2 := b. hasBlockRun := true ]. passedArguments := #(1 2). return := block newProcessWith: passedArguments. "Returns immediately" self deny: hasBlockRun. self assert: (return isKindOf: Process). "Process has not been scheduled" self assert: return isSuspended. return resume. Processor yield. "Each element in the collection argument was passed separately to the block" self assert: { receivedArgument1. receivedArgument2 } equals: passedArguments.! ! !ProcessTest methodsFor: 'testing' stamp: 'SeanDeNigris 6/1/2012 22:48'! testFork | hasBlockRun block return | hasBlockRun := false. block := [ hasBlockRun := true ]. return := block fork. "Returns immediately" self deny: hasBlockRun. "Returns a process - Blue book specifies that it returns the block itself" self assert: (return isKindOf: Process). "Forked process has been scheduled" self assert: Processor nextReadyProcess equals: return.! ! !ProcessTest methodsFor: 'testing' stamp: 'SeanDeNigris 6/1/2012 00:55'! testForkAtHigherPriority | hasBlockRun block return | hasBlockRun := false. block := [ hasBlockRun := true ]. return := block forkAt: Processor activeProcess priority + 1. "Preempts current process" self assert: hasBlockRun.! ! !ProcessTest methodsFor: 'testing' stamp: 'SeanDeNigris 6/1/2012 00:52'! testSchedulingIsFirstComeFirstServed | priorityWaitingLonger priorityWaitingLess | priorityWaitingLonger := [ ] fork. priorityWaitingLess := [ ] fork. self assert: Processor nextReadyProcess equals: priorityWaitingLonger.! ! !ProcessTest methodsFor: 'testing' stamp: 'SeanDeNigris 6/1/2012 00:34'! testNewProcess | hasBlockRun block return | hasBlockRun := false. block := [ hasBlockRun := true ]. return := block newProcess. "Returns immediately" self deny: hasBlockRun. "Returns a process - Blue book specifies the block" self assert: (return isKindOf: Process). "Forked process has not been scheduled" self assert: return isSuspended.! ! !ProcessTest methodsFor: 'testing' stamp: 'SeanDeNigris 6/1/2012 00:52'! testHighPriorityOverridesWaitTime | lowerPriorityWaitingLonger higherPriorityWaitingLess | lowerPriorityWaitingLonger := [ ] forkAt: 10. higherPriorityWaitingLess := [ ] forkAt: 12. self assert: Processor nextReadyProcess equals: higherPriorityWaitingLess.! ! !ProcessTest methodsFor: 'testing' stamp: 'SeanDeNigris 6/1/2012 22:54'! testTerminateActive | lastStatementEvaluated block1HasRun block2HasRun | block1HasRun := block2HasRun := lastStatementEvaluated := false. [ block1HasRun := true. Processor activeProcess terminate. lastStatementEvaluated := true ] fork. [ block2HasRun := true. Processor terminateActive. lastStatementEvaluated := true ] fork. Processor yield. "Expressions following terminate are never executed" self assert: block1HasRun. self assert: block2HasRun. self deny: lastStatementEvaluated.! ! !ProcessTest methodsFor: 'testing' stamp: 'NouryBouraqadi 10/1/2009 07:45'! testIsSelfEvaluating self assert: Processor printString = 'Processor'! ! !ProcessTest methodsFor: 'testing' stamp: 'SeanDeNigris 6/1/2012 22:56'! testYield | lowerHasRun lowerPriority same1HasRun same2HasRun | lowerHasRun := same1HasRun := same2HasRun := false. lowerPriority := Processor activeProcess priority - 10 min: 10. [ lowerHasRun := true ] forkAt: lowerPriority. [ same1HasRun := true ] fork. [ same2HasRun := true ] fork. Processor yield. "All processes of same priority have been given a chance to execute" self assert: same1HasRun. self assert: same2HasRun. self deny: lowerHasRun.! ! !ProcessorScheduler commentStamp: ''! My single instance, named Processor, coordinates the use of the physical processor by all Processes requiring service.! !ProcessorScheduler methodsFor: 'priority names' stamp: 'ar 7/8/2001 17:02'! lowestPriority "Return the lowest priority that is allowed with the scheduler" ^SystemRockBottomPriority! ! !ProcessorScheduler methodsFor: 'process state change' stamp: 'tpr 4/28/2004 17:53'! yield "Give other Processes at the current priority a chance to run." | semaphore | semaphore := Semaphore new. [semaphore signal] fork. semaphore wait! ! !ProcessorScheduler methodsFor: 'priority names' stamp: ''! systemBackgroundPriority "Answer the priority at which system background processes should run. Examples are an incremental garbage collector or status checker." ^SystemBackgroundPriority! ! !ProcessorScheduler methodsFor: 'priority names' stamp: ''! timingPriority "Answer the priority at which the system processes keeping track of real time should run." ^TimingPriority! ! !ProcessorScheduler methodsFor: 'accessing' stamp: 'ar 8/22/2001 17:33'! preemptedProcess "Return the process that the currently active process just preempted." | list | activeProcess priority to: 1 by: -1 do:[:priority| list := quiescentProcessLists at: priority. list isEmpty ifFalse:[^list last]. ]. ^nil "Processor preemptedProcess"! ! !ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/17/2001 10:06'! tallyCPUUsageFor: seconds every: msec "Start a high-priority process that will tally the next ready process for the given number of seconds. Answer a Block that will return the tally (a Bag) after the task is complete" | tally sem delay endDelay | tally := IdentityBag new: 200. delay := Delay forMilliseconds: msec truncated. endDelay := Delay forSeconds: seconds. endDelay schedule. sem := Semaphore new. [ [ endDelay isExpired ] whileFalse: [ delay wait. tally add: Processor nextReadyProcess ]. sem signal. ] forkAt: self highestPriority. ^[ sem wait. tally ]! ! !ProcessorScheduler methodsFor: 'priority names' stamp: ''! userInterruptPriority "Answer the priority at which user processes desiring immediate service should run. Processes run at this level will preempt the window scheduler and should, therefore, not consume the processor forever." ^UserInterruptPriority! ! !ProcessorScheduler methodsFor: 'priority names' stamp: ''! userSchedulingPriority "Answer the priority at which the window scheduler should run." ^UserSchedulingPriority! ! !ProcessorScheduler methodsFor: 'accessing' stamp: 'ar 7/8/2001 16:21'! waitingProcessesAt: aPriority "Return the list of processes at the given priority level." ^quiescentProcessLists at: aPriority! ! !ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/8/2001 12:56'! nextReadyProcess quiescentProcessLists reverseDo: [ :list | list isEmpty ifFalse: [ | proc | proc := list first. proc suspendedContext ifNotNil: [ ^proc ]]]. ^nil! ! !ProcessorScheduler methodsFor: 'accessing' stamp: ''! highestPriority "Answer the number of priority levels currently available for use." ^quiescentProcessLists size! ! !ProcessorScheduler methodsFor: 'printing' stamp: 'NouryBouraqadi 10/1/2009 07:48'! printOn: aStream self isSelfEvaluating ifFalse: [^super printOn: aStream]. aStream nextPutAll: #Processor! ! !ProcessorScheduler methodsFor: 'process state change' stamp: ''! terminateActive "Terminate the process that is currently running." activeProcess terminate! ! !ProcessorScheduler methodsFor: 'accessing' stamp: 'nk 10/27/2000 16:27'! backgroundProcess "Answer the background process" ^ BackgroundProcess! ! !ProcessorScheduler methodsFor: 'accessing' stamp: 'IgorStasenko 2/6/2012 13:18'! scanSchedule: aBlock startingAt: topPriority "Iterate over scheduled processes list, starting from topPriority down to lowest one. " topPriority to: 1 by: -1 do:[:priority | | list | list := quiescentProcessLists at: priority. list do: [:proc | aBlock value: proc ]. ]. ! ! !ProcessorScheduler methodsFor: 'accessing' stamp: ''! highestPriority: newHighestPriority "Change the number of priority levels currently available for use." | continue newProcessLists | (quiescentProcessLists size > newHighestPriority and: [self anyProcessesAbove: newHighestPriority]) ifTrue: [self error: 'There are processes with priority higher than ' ,newHighestPriority printString]. newProcessLists := Array new: newHighestPriority. 1 to: ((quiescentProcessLists size) min: (newProcessLists size)) do: [:priority | newProcessLists at: priority put: (quiescentProcessLists at: priority)]. quiescentProcessLists size to: newProcessLists size do: [:priority | newProcessLists at: priority put: LinkedList new]. quiescentProcessLists := newProcessLists! ! !ProcessorScheduler methodsFor: 'priority names' stamp: ''! userBackgroundPriority "Answer the priority at which user background processes should run." ^UserBackgroundPriority! ! !ProcessorScheduler methodsFor: 'removing' stamp: ''! remove: aProcess ifAbsent: aBlock "Remove aProcess from the list on which it is waiting for the processor and answer aProcess. If it is not waiting, evaluate aBlock." (quiescentProcessLists at: aProcess priority) remove: aProcess ifAbsent: aBlock. ^aProcess! ! !ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/8/2001 12:48'! tallyCPUUsageFor: seconds "Start a high-priority process that will tally the next ready process for the given number of seconds. Answer a Block that will return the tally (a Bag) after the task is complete" ^self tallyCPUUsageFor: seconds every: 10 ! ! !ProcessorScheduler methodsFor: 'priority names' stamp: ''! lowIOPriority "Answer the priority at which most input/output processes should run. Examples are the process handling input from the user (keyboard, pointing device, etc.) and the process distributing input from a network." ^LowIOPriority! ! !ProcessorScheduler methodsFor: 'process state change' stamp: ''! suspendFirstAt: aPriority ifNone: noneBlock "Suspend the first Process that is waiting to run with priority aPriority. If no Process is waiting, evaluate the argument, noneBlock." | aList | aList := quiescentProcessLists at: aPriority. aList isEmpty ifTrue: [^noneBlock value] ifFalse: [^aList first suspend]! ! !ProcessorScheduler methodsFor: 'priority names' stamp: ''! highIOPriority "Answer the priority at which the most time critical input/output processes should run. An example is the process handling input from a network." ^HighIOPriority! ! !ProcessorScheduler methodsFor: 'accessing' stamp: ''! activeProcess "Answer the currently running Process." ^activeProcess! ! !ProcessorScheduler methodsFor: 'self evaluating' stamp: 'NouryBouraqadi 10/1/2009 07:47'! isSelfEvaluating ^self == Processor! ! !ProcessorScheduler methodsFor: 'process state change' stamp: ''! suspendFirstAt: aPriority "Suspend the first Process that is waiting to run with priority aPriority." ^self suspendFirstAt: aPriority ifNone: [self error: 'No Process to suspend']! ! !ProcessorScheduler methodsFor: 'accessing' stamp: ''! activePriority "Answer the priority level of the currently running Process." ^activeProcess priority! ! !ProcessorScheduler methodsFor: 'private' stamp: 'tk 6/24/1999 11:27'! anyProcessesAbove: highestPriority "Do any instances of Process exist with higher priorities?" ^(Process allInstances "allSubInstances" select: [:aProcess | aProcess priority > highestPriority]) isEmpty "If anyone ever makes a subclass of Process, be sure to use allSubInstances."! ! !ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/11/97 10:44'! idleProcess "A default background process which is invisible." [true] whileTrue: [self relinquishProcessorForMicroseconds: 1000]! ! !ProcessorScheduler class methodsFor: 'class initialization' stamp: 'ar 7/8/2001 16:39'! initialize SystemRockBottomPriority := 10. SystemBackgroundPriority := 20. UserBackgroundPriority := 30. UserSchedulingPriority := 40. UserInterruptPriority := 50. LowIOPriority := 60. HighIOPriority := 70. TimingPriority := 80. "ProcessorScheduler initialize."! ! !ProcessorScheduler class methodsFor: 'instance creation' stamp: ''! new "New instances of ProcessorScheduler should not be created." self error: 'New ProcessSchedulers should not be created since the integrity of the system depends on a unique scheduler'! ! !ProcessorScheduler class methodsFor: 'background process' stamp: 'ClementBera 9/27/2013 17:53'! startUp "Install a background process of the lowest possible priority that is always runnable." "Details: The virtual machine requires that there is aways some runnable process that can be scheduled; this background process ensures that this is the case." Smalltalk installLowSpaceWatcher. BackgroundProcess ifNotNil: [BackgroundProcess terminate]. BackgroundProcess := [self idleProcess] newProcess. BackgroundProcess priority: SystemRockBottomPriority. BackgroundProcess name: 'Idle Process'. BackgroundProcess resume. ! ! !ProcessorScheduler class methodsFor: 'background process' stamp: 'VeronicaUquillas 6/11/2010 12:57'! relinquishProcessorForMicroseconds: anInteger "Platform specific. This primitive is used to return processor cycles to the host operating system when Pharo's idle process is running (i.e., when no other Pharo process is runnable). On some platforms, this primitive causes the entire Pharo application to sleep for approximately the given number of microseconds. No Pharo process can run while the Pharo application is sleeping, even if some external event makes it runnable. On the Macintosh, this primitive simply calls GetNextEvent() to give other applications a chance to run. On platforms without a host operating system, it does nothing. This primitive should not be used to add pauses to a Pharo process; use a Delay instead." "don't fail if primitive is not implemented, just do nothing" ! ! !ProfStef commentStamp: 'CamilloBruni 2/22/2014 19:01'! I am here for backwards compatibility. PharoTutorial was called ProfStef before.! !ProgressBarMorph commentStamp: ''! Instances of this morph get used by SystemProgressMorph or a JobProgressBar to display a bar (i.e., the rectangular part of a progress bar). Here is an example of how to use it. | p | p := ProgressBarMorph from: 0 to: 200. p extent: 200@20. p openInWorld. [ (1 to: 200) do: [ :i | p value: i. (Delay forMilliseconds: 10) wait ]. p delete ] fork | p | p := ProgressBarMorph from: 0 to: 200. p extent: 600@7. p openInWorld. [ (1 to: 200) do: [ :i | p value: i. (Delay forMilliseconds: 5) wait ]. p delete ] fork! !ProgressBarMorph methodsFor: 't-rotating' stamp: ''! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 5/14/2012 19:50'! decrement self value: self value - 1.! ! !ProgressBarMorph methodsFor: 'drawing' stamp: 'StephanEggermont 9/3/2013 16:09'! drawOn: aCanvas "Draw the receiver with the fill style for the bar, clipping to the inner bounds." | area | area := self innerBounds. aCanvas fillRectangle: area fillStyle: self fillStyle. value > 0 ifTrue: [ area := area origin extent: cachedWidth @ area height. aCanvas fillRectangle: area fillStyle: self barFillStyle]. self borderStyle frameRectangle: self bounds on: aCanvas ! ! !ProgressBarMorph methodsFor: 'geometry' stamp: 'FernandoOlivero 4/12/2011 10:31'! extent: aPoint "Update the bar fillStyle if appropriate." super extent: aPoint. self fillStyle isOrientedFill ifTrue: [ self fillStyle: (self theme progressBarFillStyleFor: self)]. self barFillStyle isOrientedFill ifTrue: [ self barFillStyle: ( self theme progressBarProgressFillStyleFor: self)]! ! !ProgressBarMorph methodsFor: 'private' stamp: 'SeanDeNigris 5/14/2012 20:13'! completedWidth | range fraction progress | range := end - start. progress := value - start. fraction := progress / range. ^ (fraction * self totalBarWidth) truncated.! ! !ProgressBarMorph methodsFor: 'private' stamp: 'SeanDeNigris 5/14/2012 15:36'! endAt: aNumber end := aNumber.! ! !ProgressBarMorph methodsFor: 'private' stamp: 'gvc 4/23/2007 17:04'! privateMoveBy: delta "Update the bar fillStyle if appropriate." | fill | super privateMoveBy: delta. fill := self barFillStyle. fill isOrientedFill ifTrue: [fill origin: fill origin + delta]! ! !ProgressBarMorph methodsFor: 't-rotating' stamp: ''! heading "Return the receiver's heading" ^ self owner ifNil: [self forwardDirection] ifNotNil: [self forwardDirection + self owner degreesOfFlex]! ! !ProgressBarMorph methodsFor: 'private' stamp: 'SeanDeNigris 5/14/2012 20:01'! startAt: aNumber value := start := aNumber.! ! !ProgressBarMorph methodsFor: 't-rotating' stamp: ''! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 5/14/2012 19:50'! increment self value: self value + 1.! ! !ProgressBarMorph methodsFor: 'initialization' stamp: 'StephanEggermont 9/3/2013 16:07'! initialize "Initialize the receiver from the current theme." super initialize. value := 0. start := 0. end := 100. height := DefaultHeight. width := DefaultWidth. cachedWidth := 0. self fillStyle: (self theme progressBarFillStyleFor: self); borderStyle: (self theme progressBarBorderStyleFor: self); barFillStyle: (self theme progressBarProgressFillStyleFor: self); extent: width@height + (2 * self borderWidth).! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 5/14/2012 19:47'! value ^ value.! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'StephanEggermont 9/3/2013 16:07'! value: aNumber |testWidth| value := aNumber. testWidth := self completedWidth. testWidth ~= cachedWidth ifTrue: [ cachedWidth := testWidth. self changed]! ! !ProgressBarMorph methodsFor: 'private' stamp: 'gvc 4/23/2007 17:04'! barFillStyle: aFillStyle "Set the fillStyle for the bar." ^self setProperty: #barFillStyle toValue: aFillStyle! ! !ProgressBarMorph methodsFor: 'private' stamp: 'SeanDeNigris 5/14/2012 19:41'! totalBarWidth ^ self width - (2 * self borderWidth).! ! !ProgressBarMorph methodsFor: 'private' stamp: 'CamilloBruni 9/1/2012 20:05'! barFillStyle "Answer the fillStyle for the bar if present or the theme menuTitleColor otherwise." ^ self valueOfProperty: #barFillStyle ifAbsent: [ self theme menuTitleColor ]! ! !ProgressBarMorph methodsFor: 't-rotating' stamp: ''! setDirectionFrom: aPoint | delta degrees | delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition. degrees := delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! !ProgressBarMorph methodsFor: 't-rotating' stamp: ''! rotationDegrees: degrees "redefined in all morphs which are using myself"! ! !ProgressBarMorph methodsFor: 't-rotating' stamp: ''! prepareForRotating "If I require a flex shell to rotate, then wrap it in one and return it. Polygons, eg, may override to do nothing." ^ self addFlexShell! ! !ProgressBarMorph methodsFor: 't-rotating' stamp: ''! rotationDegrees "Default implementation." ^ 0.0 ! ! !ProgressBarMorph class methodsFor: 'initialization' stamp: 'Sd 11/30/2012 20:16'! defaultHeight: aNumber DefaultHeight := aNumber! ! !ProgressBarMorph class methodsFor: 'instance-creation' stamp: 'SeanDeNigris 5/14/2012 15:18'! from: startNumber to: endNumber ^ self new startAt: startNumber; endAt: endNumber.! ! !ProgressBarMorph class methodsFor: 'initialization' stamp: 'Sd 11/30/2012 21:59'! initialize "ProgressBarMorph initialize" self defaultWidth: 120. self defaultHeight: 10.! ! !ProgressBarMorph class methodsFor: 'initialization' stamp: 'Sd 11/30/2012 20:15'! defaultWidth: aNumber DefaultWidth := aNumber. ! ! !ProgressNotification commentStamp: ''! Used to signal progress without requiring a specific receiver to notify. Caller/callee convention could be to simply count the number of signals caught or to pass more substantive information with #signal:.! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:11'! amount ^amount! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! amount: aNumber amount := aNumber! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:11'! done ^done! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! done: aNumber done := aNumber! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! extraParam ^extra! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! extraParam: anObject extra := anObject! ! !ProgressNotification class methodsFor: 'exceptioninstantiator' stamp: 'ajh 1/22/2003 23:51'! signal: signalerText extra: extraParam "TFEI - Signal the occurrence of an exceptional condition with a specified textual description." | ex | ex := self new. ex extraParam: extraParam. ^ex signal: signalerText! ! !ProportionalLayout commentStamp: ''! I represent a layout that places all children of some morph in their given LayoutFrame.! !ProportionalLayout methodsFor: 'layout' stamp: 'nice 1/5/2010 15:59'! minExtentOf: aMorph in: newBounds "Return the minimal size aMorph's children would require given the new bounds" | min | min := 0@0. aMorph submorphsDo:[:m| | extent frame | "Map the minimal size of the child through the layout frame. Note: This is done here and not in the child because its specific for proportional layouts. Perhaps we'll generalize this for table layouts but I'm not sure how and when." extent := m minExtent. frame := m layoutFrame. frame ifNotNil:[extent := frame minExtentFrom: extent]. min := min max: extent]. ^min! ! !ProportionalLayout methodsFor: 'testing' stamp: 'ar 10/29/2000 01:29'! isProportionalLayout ^true! ! !ProportionalLayout methodsFor: 'layout' stamp: 'ar 10/29/2000 01:24'! layout: aMorph in: newBounds "Compute the layout for the given morph based on the new bounds" aMorph submorphsDo:[:m| m layoutProportionallyIn: newBounds].! ! !ProportionalSplitterMorph commentStamp: 'jmv 1/29/2006 17:16'! I am the morph the user grabs to adjust pane splitters.! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/14/2007 13:32'! overlapsVertical: aSplitter "Answer whether the receiver overlaps the given spiltter in the vertical plane." ^aSplitter top <= self bottom and: [aSplitter bottom >= self top]! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'jrp 8/6/2005 23:59'! handleSize ^ self class splitterWidth @ 30! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/19/2008 15:31'! mouseUp: anEvent "Change the cursor back to normal if necessary and change the color back to normal." (self bounds containsPoint: anEvent cursorPoint) ifFalse: [anEvent hand showTemporaryCursor: nil]. self class fastSplitterResize ifTrue: [self updateFromEvent: anEvent]. traceMorph ifNotNil: [traceMorph delete. traceMorph := nil]. self adoptPaneColor: self paneColor. self triggerEvent: #mouseUp! ! !ProportionalSplitterMorph methodsFor: 'event handling' stamp: 'nice 1/5/2010 15:59'! updateFromEvent: anEvent "Update the splitter and attached morph positions from the mouse event. Take into account the mouse down offset." | pNew pOld delta selfTop selfBottom selfLeft selfRight| pNew := anEvent cursorPoint - lastMouse second. pOld := lastMouse first - lastMouse second. delta := splitsTopAndBottom ifTrue: [0 @ ((self normalizedY: pNew y) - pOld y)] ifFalse: [(self normalizedX: pNew x) - pOld x @ 0]. lastMouse at: 1 put: (splitsTopAndBottom ifTrue: [pNew x @ (self normalizedY: pNew y) + lastMouse second] ifFalse: [(self normalizedX: pNew x) @ pNew y + lastMouse second]). leftOrTop do: [:each | | firstRight firstBottom | firstRight := each layoutFrame rightOffset ifNil: [0]. firstBottom := each layoutFrame bottomOffset ifNil: [0]. each layoutFrame rightOffset: firstRight + delta x. each layoutFrame bottomOffset: firstBottom + delta y. (each layoutFrame leftFraction = each layoutFrame rightFraction and: [ each layoutFrame leftFraction ~= 0]) "manual splitter" ifTrue: [each layoutFrame leftOffset: (each layoutFrame leftOffset ifNil: [0]) + delta x]. (each layoutFrame topFraction = each layoutFrame bottomFraction and: [ each layoutFrame topFraction ~= 0]) "manual splitter" ifTrue: [each layoutFrame topOffset: (each layoutFrame topOffset ifNil: [0]) + delta y]]. rightOrBottom do: [:each | | secondLeft secondTop | secondLeft := each layoutFrame leftOffset ifNil: [0]. secondTop := each layoutFrame topOffset ifNil: [0]. each layoutFrame leftOffset: secondLeft + delta x. each layoutFrame topOffset: secondTop + delta y. (each layoutFrame leftFraction = each layoutFrame rightFraction and: [ each layoutFrame rightFraction ~= 1]) "manual splitter" ifTrue: [each layoutFrame rightOffset: (each layoutFrame rightOffset ifNil: [0]) + delta x]. (each layoutFrame topFraction = each layoutFrame bottomFraction and: [ each layoutFrame bottomFraction ~= 1]) "manual splitter" ifTrue: [each layoutFrame bottomOffset: (each layoutFrame bottomOffset ifNil: [0]) + delta y]]. selfTop := self layoutFrame topOffset ifNil: [0]. selfBottom := self layoutFrame bottomOffset ifNil: [0]. selfLeft := self layoutFrame leftOffset ifNil: [0]. selfRight := self layoutFrame rightOffset ifNil: [0]. self layoutFrame topOffset: selfTop + delta y. self layoutFrame bottomOffset: selfBottom + delta y. self layoutFrame leftOffset: selfLeft + delta x. self layoutFrame rightOffset: selfRight + delta x. self owner layoutChanged! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:32'! shouldDraw "Answer whether the resizer should be drawn." ^super shouldDraw or: [self class showSplitterHandles]! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/14/2007 13:32'! overlapsHorizontal: aSplitter "Answer whether the receiver overlaps the given spiltter in the horizontal plane." ^aSplitter left <= self right and: [aSplitter right >= self left]! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/26/2007 10:22'! adoptPaneColor: paneColor "Change our color too." super adoptPaneColor: paneColor. self fillStyle: self normalFillStyle! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:46'! hasRightOrBottom: aMorph "Answer whether the reciver has the given morph as one of of its right or bottom morphs." ^rightOrBottom includes: aMorph! ! !ProportionalSplitterMorph methodsFor: 'operations' stamp: 'bvs 3/24/2004 16:39'! beSplitsTopAndBottom splitsTopAndBottom := true. ! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'MarcusDenker 12/11/2009 09:58'! leftBoundary "Answer the left boundary position by calculating the minimum of the minimum widths of the left morphs." |morphs| morphs := leftOrTop reject: [:m | m layoutFrame leftFraction ~= 0 and: [ m layoutFrame leftFraction = m layoutFrame rightFraction]]. morphs ifEmpty: [ ^(self splitterLeft ifNil: [self containingWindow panelRect left] ifNotNil: [:s | s left]) + 25]. ^(morphs collect: [:m | m left + m minExtent x + (self layoutFrame leftOffset ifNil: [0]) - (m layoutFrame rightOffset ifNil: [0])]) max! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! normalFillStyle "Return the normal fillStyle of the receiver." ^self theme splitterNormalFillStyleFor: self! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'apl 7/8/2005 13:38'! getOldColor ^ oldColor ifNil: [Color transparent]! ! !ProportionalSplitterMorph methodsFor: 'initialization' stamp: 'jrp 7/5/2005 21:46'! initialize super initialize. self hResizing: #spaceFill. self vResizing: #spaceFill. splitsTopAndBottom := false. leftOrTop := OrderedCollection new. rightOrBottom := OrderedCollection new! ! !ProportionalSplitterMorph methodsFor: 'testing' stamp: 'jrp 7/9/2005 17:44'! isCursorOverHandle ^ self class showSplitterHandles not or: [self handleRect containsPoint: ActiveHand cursorPoint]! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/31/2012 18:42'! topBoundary "Answer the top boundary position by calculating the minimum of the minimum heights of the top morphs." |morphs| morphs := leftOrTop reject: [:m | m layoutFrame topFraction ~= 0 and: [ m layoutFrame topFraction = m layoutFrame bottomFraction]]. morphs ifEmpty: [ ^(self splitterAbove ifNil: [self containingWindow panelRect top] ifNotNil: [:s | s first top]) + 25]. ^(morphs collect: [:m | m top + m minExtent y + (self layoutFrame topOffset ifNil: [0]) - (m layoutFrame bottomOffset ifNil: [0])]) max! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/13/2008 10:36'! shouldInvalidateOnMouseTransition "Answer whether the resizer should be invalidated when the mouse enters or leaves." ^self class showSplitterHandles! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:46'! hideRightOrBottom "Hide the receiver and all right or bottom morphs." self hide. rightOrBottom do: [:m | m hide]! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:40'! hideLeftOrTop "Hide the receiver and all left or top morphs." self hide. leftOrTop do: [:m | m hide]! ! !ProportionalSplitterMorph methodsFor: 'event handling' stamp: 'jrp 3/21/2006 23:11'! mouseMove: anEvent anEvent hand temporaryCursor ifNil: [^ self]. self class fastSplitterResize ifFalse: [self updateFromEvent: anEvent] ifTrue: [traceMorph ifNil: [traceMorph := Morph newBounds: self bounds. traceMorph borderColor: Color lightGray. traceMorph borderWidth: 1. self owner addMorph: traceMorph]. splitsTopAndBottom ifTrue: [traceMorph position: traceMorph position x @ (self normalizedY: anEvent cursorPoint y)] ifFalse: [traceMorph position: (self normalizedX: anEvent cursorPoint x) @ traceMorph position y]]! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/31/2012 18:42'! bottomBoundary "Answer the bottom boundary position by calculating the minimum of the minimum heights of the bottom morphs." |morphs| morphs := rightOrBottom reject: [:m | m layoutFrame bottomFraction ~= 1 and: [ m layoutFrame topFraction = m layoutFrame bottomFraction]]. morphs ifEmpty: [ ^(self splitterBelow ifNil: [self containingWindow panelRect bottom] ifNotNil: [self splitterBelow first top]) - 25]. ^(morphs collect: [:m | m bottom - m minExtent y - (m layoutFrame topOffset ifNil: [0]) + (self layoutFrame bottomOffset ifNil: [0])]) min - self class splitterWidth! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/31/2012 18:42'! splitterLeft "Answer the splitter to the left of the receiver that overlaps in its vertical range." |splitters| splitters := ((self siblingSplitters select: [:each | each left < self left and: [self overlapsVertical: each]]) asSortedCollection: [:a :b | a left > b left]). ^ splitters ifEmpty: [ nil ] ifNotEmpty: [:s | s first ]! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 7/9/2013 12:41'! noteNewOwner: o "Update the fill style." super noteNewOwner: o. self defer: [self adoptPaneColor: self paneColor]! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:40'! showLeftOrTop "Show the receiver and all left or top morphs." self show. leftOrTop do: [:m | m show]! ! !ProportionalSplitterMorph methodsFor: 'drawing' stamp: 'gvc 1/20/2009 11:47'! drawOn: aCanvas | dotBounds size alphaCanvas dotSize | self shouldDraw ifFalse: [^self]. super drawOn: aCanvas. self class showSplitterHandles ifTrue: [ size := self splitsTopAndBottom ifTrue: [self handleSize transposed] ifFalse: [self handleSize]. dotSize := self splitsTopAndBottom ifTrue: [6 @ self class splitterWidth] ifFalse: [self class splitterWidth @ 6]. alphaCanvas := aCanvas asAlphaBlendingCanvas: 0.7. dotBounds := Rectangle center: self bounds center extent: size. alphaCanvas fillRectangle: dotBounds color: self handleColor. dotBounds := Rectangle center: self bounds center extent: dotSize. alphaCanvas fillRectangle: dotBounds color: self dotColor]! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'bvs 3/24/2004 17:25'! splitsTopAndBottom ^ splitsTopAndBottom! ! !ProportionalSplitterMorph methodsFor: 'operations' stamp: 'jrp 3/21/2006 23:12'! normalizedY: y ^ (y max: self topBoundary) min: self bottomBoundary! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'MarcusDenker 12/11/2009 09:58'! rightBoundary "Answer the right boundary position by calculating the minimum of the minimum widths of the right morphs." |morphs| morphs := rightOrBottom reject: [:m | m layoutFrame rightFraction ~= 1 and: [ m layoutFrame leftFraction = m layoutFrame rightFraction]]. morphs ifEmpty: [ ^(self splitterRight ifNil: [self containingWindow panelRect right] ifNotNil: [:s | s left]) + 25]. ^(morphs collect: [:m | m right - m minExtent x - (m layoutFrame leftOffset ifNil: [0]) + (self layoutFrame rightOffset ifNil: [0])]) min - self class splitterWidth! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/31/2012 18:41'! splitterBelow "Answer the splitter below the receiver that overlaps in its horizontal range." |splitters| splitters := ((self siblingSplitters select: [:each | each top < self top and: [self overlapsHorizontal: each]]) asSortedCollection: [:a :b | a top > b top]). ^ splitters ifEmpty: [ nil ] ifNotEmpty: [:s | s first ]! ! !ProportionalSplitterMorph methodsFor: 'actions' stamp: 'bvs 3/24/2004 16:39'! resizeCursor ^ Cursor resizeForEdge: (splitsTopAndBottom ifTrue: [#top] ifFalse: [#left]) ! ! !ProportionalSplitterMorph methodsFor: 'operations' stamp: 'jrp 3/21/2006 22:45'! normalizedX: x ^ (x max: self leftBoundary) min: self rightBoundary! ! !ProportionalSplitterMorph methodsFor: 'operations' stamp: 'bvs 3/24/2004 16:55'! addRightOrBottom: aMorph rightOrBottom add: aMorph. ! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 4/27/2010 11:53'! siblingSplitters ^ self owner submorphsSatisfying: [:each | (each isKindOf: self class) and: [self splitsTopAndBottom = each splitsTopAndBottom and: [each ~= self]]]! ! !ProportionalSplitterMorph methodsFor: 'operations' stamp: 'bvs 3/24/2004 16:57'! addLeftOrTop: aMorph leftOrTop add: aMorph! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/31/2012 18:41'! splitterAbove "Answer the splitter above the receiver that overlaps in its horizontal range." |splitters| splitters := ((self siblingSplitters select: [:each | each top > self top and: [self overlapsHorizontal: each]]) asSortedCollection: [:a :b | a top < b top]). ^ splitters ifEmpty: [ nil ] ifNotEmpty: [:s | s first ]! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/31/2012 18:42'! splitterRight "Answer the splitter to the right of the receiver that overlaps in its vertical range." |splitters| splitters := ((self siblingSplitters select: [:each | each left > self left and: [self overlapsVertical: each]]) asSortedCollection: [:a :b | a left < b left]). ^ splitters ifEmpty: [ nil ] ifNotEmpty: [:s | s first ]! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:46'! hasLeftOrTop: aMorph "Answer whether the reciver has the given morph as one of of its left or top morphs." ^leftOrTop includes: aMorph! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! pressedFillStyle "Return the pressed fillStyle of the receiver." ^self theme splitterPressedFillStyleFor: self! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/9/2007 10:47'! showRightOrBottom "Show the receiver and all right or bottom morphs." self show. rightOrBottom do: [:m | m show]! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/26/2007 10:21'! setGrabbedColor "Set the color of the receiver when it is grabbed." self fillStyle: self pressedFillStyle! ! !ProportionalSplitterMorph methodsFor: 'accessing' stamp: 'jrp 7/4/2005 10:50'! handleRect ^ Rectangle center: self bounds center extent: (self splitsTopAndBottom ifTrue: [self handleSize transposed] ifFalse: [self handleSize])! ! !ProportionalSplitterMorph methodsFor: 'event handling' stamp: 'gvc 6/15/2007 11:27'! mouseDown: anEvent "A mouse button has been pressed. Update the color for feedback and store the mouse position and relative offset to the receiver." |cp| (self class showSplitterHandles not and: [self bounds containsPoint: anEvent cursorPoint]) ifTrue: [oldColor := self color. self setGrabbedColor]. cp := anEvent cursorPoint. lastMouse := {cp. cp - self position}! ! !ProportionalSplitterMorph class methodsFor: 'preferences' stamp: 'AlainPlantec 12/14/2009 21:44'! showSplitterHandles ^ ShowHandles ifNil: [ShowHandles := false]! ! !ProportionalSplitterMorph class methodsFor: 'as yet unclassified' stamp: 'jrp 8/6/2005 23:59'! splitterWidth ^ 4! ! !ProportionalSplitterMorph class methodsFor: 'preferences' stamp: 'AlainPlantec 12/14/2009 21:36'! fastSplitterResize ^ self theme settings fastDragging! ! !ProportionalSplitterMorph class methodsFor: 'preferences' stamp: 'AlainPlantec 12/14/2009 21:45'! showSplitterHandles: aBoolean ShowHandles := aBoolean! ! !ProtoObject commentStamp: ''! ProtoObject establishes minimal behavior required of any object in Pharo, even objects that should balk at normal object behavior. Generally these are proxy objects designed to read themselves in from the disk, or to perform some wrapper behavior, before responding to a message. ProtoObject has no instance variables, nor should any be added.! !ProtoObject methodsFor: 'executing' stamp: 'ClementBera 11/5/2013 10:21'! executeMethod: compiledMethod ^ self withArgs: #( ) executeMethod: compiledMethod! ! !ProtoObject methodsFor: 'debugging' stamp: 'simon.denier 6/11/2010 14:47'! doOnlyOnce: aBlock "If the 'one-shot' mechanism is armed, evaluate aBlock once and disarm the one-shot mechanism. To rearm the mechanism, evaluate 'self rearmOneShot' manually." (Smalltalk globals at: #OneShotArmed ifAbsent: [ true ]) ifTrue: [ Smalltalk globals at: #OneShotArmed put: false. aBlock value ]! ! !ProtoObject methodsFor: 'testing' stamp: 'HenrikSperreJohansen 6/1/2010 13:30'! ifNotNil: ifNotNilBlock ifNil: nilBlock "If I got here, I am not nil, so evaluate the block ifNotNilBlock" ^ ifNotNilBlock cull: self! ! !ProtoObject methodsFor: 'reflective operations' stamp: 'ajh 10/9/2001 17:20'! doesNotUnderstand: aMessage ^ MessageNotUnderstood new message: aMessage; receiver: self; signal! ! !ProtoObject methodsFor: 'initialization' stamp: 'MarianoMartinezPeck 8/24/2012 15:59'! initialize "Subclasses should redefine this method to perform initializations on instance creation" ! ! !ProtoObject methodsFor: 'pointing to' stamp: 'PavelKrivanek 2/18/2012 23:47'! pointersToExcept: objectsToExclude "Find all objects in the system that hold a pointer to me, excluding those listed" | c pointers object objectsToAlwaysExclude | Smalltalk garbageCollect. pointers := OrderedCollection new. "SystemNavigation >> #allObjectsDo: is inlined here with a slight modification: the marker object is pointers. This gives better results, because the value of pointers, it's inner objects and transient method contexts will not be iterated over." object := self someObject. [ object == pointers ] whileFalse: [ ( object pointsTo: self ) ifTrue: [ pointers add: object ]. object := object nextObject ]. objectsToAlwaysExclude := { thisContext. thisContext sender. thisContext sender sender. objectsToExclude. }. c := thisContext. ^(pointers removeAllSuchThat: [ :ea | (ea == thisContext sender) or: [ "warning: this expression is dependent on closure structure of this method" (objectsToAlwaysExclude identityIncludes: ea) or: [objectsToExclude identityIncludes: ea ]] ]) asArray! ! !ProtoObject methodsFor: 'debugging' stamp: 'simon.denier 6/11/2010 14:47'! rearmOneShot "Call this manually to arm the one-shot mechanism; use the mechanism in code by calling self doOnlyOnce: " Smalltalk globals at: #OneShotArmed put: true "self rearmOneShot" ! ! !ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:23'! ifNil: nilBlock "Return self, or evaluate the block if I'm == nil (q.v.)" ^ self! ! !ProtoObject methodsFor: '*Fuel-Collections' stamp: 'MarianoMartinezPekc 1/10/2012 18:56'! fuelPointsTo: anObject "This method returns true if self contains a pointer to anObject, and returns false otherwise" "This is the same as the following smalltalk code: 1 to: self class instSize do: [:i | (self instVarAt: i) == anObject ifTrue: [^ true]]. 1 to: self basicSize do: [:i | (self basicAt: i) == anObject ifTrue: [^ true]]. ^ false" ! ! !ProtoObject methodsFor: 'class membership' stamp: 'MarcusDenker 3/22/2013 17:23'! class "Primitive. Answer the object which is the receiver's class. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !ProtoObject methodsFor: 'testing' stamp: 'HenrikSperreJohansen 6/1/2010 13:29'! ifNil: nilBlock ifNotNil: ifNotNilBlock "Evaluate the block, unless I'm == nil (q.v.)" ^ ifNotNilBlock cull: self! ! !ProtoObject methodsFor: 'testing' stamp: 'HenrikSperreJohansen 6/1/2010 13:29'! ifNotNil: ifNotNilBlock "Evaluate the block, unless I'm == nil (q.v.)" ^ ifNotNilBlock cull: self! ! !ProtoObject methodsFor: 'comparing' stamp: 'SeanDeNigris 5/1/2012 15:16'! ~~ anObject "Answer whether the receiver and the argument are different objects (do not have the same object pointer)." "This seemingly redundant implementation is for performance (and possibly other) reasons. See http://forum.world.st/About-and-td3898409.html for more details" self == anObject ifTrue: [^ false] ifFalse: [^ true]! ! !ProtoObject methodsFor: 'pointing to' stamp: 'AndyKellens 6/11/2010 14:14'! pointersTo ^self pointersToExcept: #()! ! !ProtoObject methodsFor: 'instropection' stamp: 'MarianoMartinezPeck 12/22/2011 21:04'! instVarsInclude: anObject "Answers true if anObject is among my named or indexed instance variables, and false otherwise" 1 to: self class instSize do: [:i | (self instVarAt: i) == anObject ifTrue: [^ true]]. 1 to: self basicSize do: [:i | (self basicAt: i) == anObject ifTrue: [^ true]]. ^ false! ! !ProtoObject methodsFor: '*Fuel-Collections' stamp: 'ul 12/18/2011 11:14'! largeIdentityHash self primitiveFailed! ! !ProtoObject methodsFor: 'comparing' stamp: 'G.C 10/23/2008 10:13'! == anObject "Primitive. Answer whether the receiver and the argument are the same object (have the same object pointer). Do not redefine the message == in any other class!! Essential. No Lookup. Do not override in any subclass. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !ProtoObject methodsFor: 'memory scanning' stamp: 'md 11/24/1999 19:58'! nextObject "Primitive. Answer the next object after the receiver in the enumeration of all objects. Return 0 when all objects have been enumerated." self primitiveFailed.! ! !ProtoObject methodsFor: 'flagging' stamp: 'marcus.denker 8/25/2008 09:12'! flag: aSymbol "Send this message, with a relevant symbol as argument, to flag a message for subsequent retrieval. For example, you might put the following line in a number of messages: self flag: #returnHereUrgently Then, to retrieve all such messages, browse all senders of #returnHereUrgently."! ! !ProtoObject methodsFor: 'memory scanning' stamp: 'md 11/24/1999 19:58'! nextInstance "Primitive. Answer the next instance after the receiver in the enumeration of all instances of this class. Fails if all instances have been enumerated. Essential. See Object documentation whatIsAPrimitive." ^nil! ! !ProtoObject methodsFor: 'executing' stamp: 'eem 4/8/2009 19:10'! withArgs: argArray executeMethod: compiledMethod "Execute compiledMethod against the receiver and args in argArray" self primitiveFailed! ! !ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:26'! isNil "Coerces nil to true and everything else to false." ^false! ! !ProtoObject methodsFor: 'pointing to' stamp: 'MarcusDenker 10/29/2013 21:21'! pointsTo: anObject "Answers true if I hold a reference to anObject, or false otherwise an object points to a class via the header either directly or indirectly via the compact classes array" ^ (self instVarsInclude: anObject) or: [ ^self class == anObject]! ! !ProtoObject methodsFor: 'comparing' stamp: 'MartinMcClure 3/21/2010 16:40'! identityHash "Answer a SmallInteger whose value is related to the receiver's identity. This method must not be overridden, except by SmallInteger. Do not override." ^ self basicIdentityHash bitShift: 18! ! !ProtoObject methodsFor: 'reflective operations' stamp: 'MartinMcClure 1/12/2010 21:10'! basicIdentityHash "Answer a SmallInteger whose value is related to the receiver's identity. This method must not be overridden, except by SmallInteger. Primitive. Fails if the receiver is a SmallInteger. Essential. See Object documentation whatIsAPrimitive. Do not override. Use #identityHash unless you really know what you're doing.'" self primitiveFailed! ! !ProtoObject methodsFor: 'reflective operations' stamp: 'md 11/24/1999 19:30'! become: otherObject "Primitive. Swap the object pointers of the receiver and the argument. All variables in the entire system that used to point to the receiver now point to the argument, and vice-versa. Fails if either object is a SmallInteger" (Array with: self) elementsExchangeIdentityWith: (Array with: otherObject)! ! !ProtoObject methodsFor: 'reflective operations' stamp: 'ClementBera 9/27/2013 17:52'! cannotInterpret: aMessage "Handle the fact that there was an attempt to send the given message to the receiver but a null methodDictionary was encountered while looking up the message selector. Hopefully this is the result of encountering a stub for a swapped out class which induces this exception on purpose." "If this is the result of encountering a swap-out stub, then simulating the lookup in Smalltalk should suffice to install the class properly, and the message may be resent." (self class lookupSelector: aMessage selector) ifNotNil: ["Simulated lookup succeeded -- resend the message." ^ aMessage sentTo: self]. "Could not recover by simulated lookup -- it's an error" Error signal: 'MethodDictionary fault'. "Try again in case an error handler fixed things" ^ aMessage sentTo: self! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'IgorStasenko 3/16/2012 20:06'! tryPrimitive: primIndex withArgs: argumentArray "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailTokenFor: code! ! !ProtoObjectTest commentStamp: ''! This is the unit test for the class ProtoObject. 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 - there is a chapter in the PharoByExample book (http://pharobyexample.org) - the sunit class category! !ProtoObjectTest methodsFor: 'tests - testing' stamp: 'ul 12/18/2009 15:48'! testIfNotNilIfNil | object returnValue block | object := ProtoObject new. returnValue := Object new. self should: [ object ifNotNil: [ self halt ] ifNil: [ self error ] ] raise: Halt. self should: [ object ifNotNil: [ :o | self halt ] ifNil: [ self error ] ] raise: Halt. self assert: (object ifNotNil: [ :o | o == object ] ifNil: [ false ]). self assert: (object ifNotNil: [ returnValue ] ifNil: [ false ]) == returnValue. self assert: (object ifNotNil: [ :o | returnValue ] ifNil: [ false ]) == returnValue. "Now the same without inlining." block := [ self halt ]. self should: [ object ifNotNil: block ifNil: [ self error ] ] raise: Halt. block := [ :o | self halt ]. self should: [ object ifNotNil: block ifNil: [ self error ] ] raise: Halt. block := [ :o | o == object ]. self assert: (object ifNotNil: block ifNil: [ false ]). block := [ returnValue ]. self assert: (object ifNotNil: block ifNil: [ false ]) == returnValue. block := [ :o | returnValue ]. self assert: (object ifNotNil: block ifNil: [ false ]) == returnValue! ! !ProtoObjectTest methodsFor: 'tests - testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testIfNil | object block | object := ProtoObject new. object ifNil: [ self halt ]. self assert: (object ifNil: [ nil ]) == object. "Now the same without inlining." block := [ self halt ]. object ifNil: block. block := [ nil ]. self assert: (object ifNil: block) == object! ! !ProtoObjectTest methodsFor: 'tests - testing' stamp: 'SeanDeNigris 5/1/2012 14:50'! testNotTheSame | object1 object2 | object1 := ProtoObject new. object2 := ProtoObject new. self assert: object1 ~~ object2. self deny: object1 ~~ object1.! ! !ProtoObjectTest methodsFor: 'tests - testing' stamp: 'ul 12/18/2009 15:48'! testIsNil self deny: ProtoObject new isNil! ! !ProtoObjectTest methodsFor: 'tests - testing' stamp: 'ul 12/18/2009 15:49'! testIfNilIfNotNil | object returnValue block | object := ProtoObject new. returnValue := Object new. self should: [ object ifNil: [ self error ] ifNotNil: [ self halt ] ] raise: Halt. self should: [ object ifNil: [ self error ] ifNotNil: [ :o | self halt ] ] raise: Halt. self assert: (object ifNil: [ false ] ifNotNil: [ :o | o == object ]). self assert: (object ifNil: [ nil ] ifNotNil: [ returnValue ]) == returnValue. self assert: (object ifNil: [ nil ] ifNotNil: [ :o | returnValue ]) == returnValue. "Now the same without inlining." block := [ self halt ]. self should: [ object ifNil: [ self error ] ifNotNil: block ] raise: Halt. block := [ :o | self halt ]. self should: [ object ifNil: [ self error ] ifNotNil: block ] raise: Halt. block := [ :o | o == object ]. self assert: (object ifNil: [ false ] ifNotNil: block). block := [ returnValue ]. self assert: (object ifNil: [ nil ] ifNotNil: block) = returnValue. block := [ :o | returnValue ]. self assert: (object ifNil: [ nil ] ifNotNil: block) = returnValue! ! !ProtoObjectTest methodsFor: 'tests - testing' stamp: 'ul 12/18/2009 15:48'! testIfNotNil | object returnValue block | object := ProtoObject new. returnValue := Object new. self should: [ object ifNotNil: [ self halt ] ] raise: Halt. self should: [ object ifNotNil: [ :o | self halt ] ] raise: Halt. self assert: (object ifNotNil: [ :o | o == object ]). self assert: (object ifNotNil: [ returnValue ]) == returnValue. self assert: (object ifNotNil: [ :o | returnValue ]) == returnValue. "Now the same without inlining." block := [ self halt ]. self should: [ object ifNotNil: block ] raise: Halt. block := [ :o | self halt ]. self should: [ object ifNotNil: block ] raise: Halt. block := [ :o | o == object ]. self assert: (object ifNotNil: block). block := [ returnValue ]. self assert: (object ifNotNil: block) = returnValue. block := [ :o | returnValue ]. self assert: (object ifNotNil: block) = returnValue! ! !ProtoObjectTest methodsFor: 'tests - testing' stamp: 'CamilloBruni 8/31/2013 20:23'! testFlag ProtoObject new flag: #hallo! ! !Protocol commentStamp: ''! A Protocol is a simple value holder representing a protocol. It's composed of a name and a set of method selectors! !Protocol methodsFor: 'testing' stamp: 'EstebanLorenzano 11/29/2013 16:04'! canBeRenamed ^ true! ! !Protocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:12'! rename: newName self name: newName! ! !Protocol methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 4/12/2012 16:27'! isEmpty ^ self methods isEmpty! ! !Protocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:21'! methods ^ methods! ! !Protocol methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/16/2014 11:23'! addMethod: aSymbol ^ methods add: aSymbol! ! !Protocol methodsFor: 'testing' stamp: 'EstebanLorenzano 6/27/2013 15:53'! isVirtualProtocol "A virtual protocol is a calculated one (it does not have any methods by it self)" ^ false! ! !Protocol methodsFor: 'accessing' stamp: 'SebastianTleye 8/28/2013 17:03'! removeAllMethods ^ methods removeAll.! ! !Protocol methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:07'! initialize super initialize. methods := IdentitySet new.. name := self class defaultName.! ! !Protocol methodsFor: 'accessing' stamp: 'SebastianTleye 8/28/2013 17:22'! addAllMethodsFrom: aProtocol aProtocol methods do: [ :each | self addMethod: each ].! ! !Protocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:02'! methods: anObject methods := anObject! ! !Protocol methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/29/2013 15:57'! name: anObject name := anObject asSymbol! ! !Protocol methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:28'! printOn: aStream aStream nextPutAll: (self class name); nextPutAll: ' ('; nextPutAll: (self name); nextPutAll: ') - '; nextPutAll: (self methods size asString); nextPutAll: ' selector(s)'.! ! !Protocol methodsFor: 'testing' stamp: 'EstebanLorenzano 6/28/2013 16:04'! includesSelector: selector ^ methods includes: selector! ! !Protocol methodsFor: 'private' stamp: 'EstebanLorenzano 6/17/2013 12:51'! canBeRemoved ^ self isEmpty ! ! !Protocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:21'! name ^ name! ! !Protocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:11'! removeMethod: aSymbol ^ methods remove: aSymbol! ! !Protocol methodsFor: 'testing' stamp: 'EstebanLorenzano 10/2/2013 16:23'! isExtensionProtocol ^ self name first = $*.! ! !Protocol class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/12/2012 14:02'! name: nm methods: methods ^ self new methods: methods; name: nm; yourself! ! !Protocol class methodsFor: 'instance creation' stamp: 'MarcusDenker 10/3/2013 17:49'! empty ^ self name: #''! ! !Protocol class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/12/2012 14:06'! name: nm ^ self new name: nm; yourself! ! !Protocol class methodsFor: 'accessing' stamp: 'MarcusDenker 10/3/2013 17:49'! nullCategory ^ #'no messages'! ! !Protocol class methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/28/2013 14:16'! defaultName ^ self unclassified! ! !Protocol class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 5/28/2013 13:21'! ambiguous ^ #ambiguous! ! !Protocol class methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/28/2013 14:15'! unclassified ^ #'as yet unclassified'! ! !ProtocolAdded commentStamp: ''! This class is not used, but should be used when we hook into the addition and removal of protocols. Right now, we only get ClassReorganizedAnnouncement! !ProtocolAnnouncement commentStamp: ''! I'm an abstract announcement for protocols! !ProtocolAnnouncement methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/3/2013 12:44'! protocol ^ protocol! ! !ProtocolAnnouncement methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/3/2013 11:59'! classReorganized: anObject classReorganized := anObject! ! !ProtocolAnnouncement methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/3/2013 11:58'! classAffected ^self classReorganized! ! !ProtocolAnnouncement methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/3/2013 11:59'! classReorganized ^ classReorganized! ! !ProtocolAnnouncement methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/3/2013 12:44'! protocol: aString protocol := aString! ! !ProtocolBrowser commentStamp: 'BenjaminVanRyseghem 1/21/2014 16:36'! I am a complete UI used to view the protocol methods (via a ProtocolViewer) as well as their source code. I am used to expose the construction of a spec UI in the Spec documentation.! !ProtocolBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2014 15:48'! viewer ^ viewer! ! !ProtocolBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/21/2014 16:30'! initializeWidgets text := self newText. viewer := self instantiate: ProtocolViewer. text aboutToStyle: true. self focusOrder add: viewer; add: text! ! !ProtocolBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/27/2014 11:48'! initializePresenter viewer whenClassChanged: [ :class | text behavior: class ]. viewer whenProtocolChangedDo: [ :item | item ifNil: [ text text: '' ] ifNotNil: [ text text: item sourceCode ] ]. viewer whenEventChangedDo: [ :item | item ifNil: [ text text: '' ] ifNotNil: [ text text: item sourceCode ] ]! ! !ProtocolBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/27/2014 17:24'! title ^ 'Protocols browser'! ! !ProtocolBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2014 15:48'! text ^ text! ! !ProtocolBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 16:27'! initialExtent ^ 750@600! ! !ProtocolBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/21/2014 15:57'! defaultSpec ^ SpecLayout composed newColumn: [ :col | col newRow: [ :r | r add: #(viewer models); newColumn: [ :c | c add: #(viewer protocols); add: #(viewer events) ] ]; add: #text ]; yourself! ! !ProtocolClient commentStamp: 'gk 12/13/2005 00:34'! ProtocolClient is the abstract super class for a variety of network protocol clients. It uses a stream rather than the direct network access so it could also work for streams on serial connections etc. Structure: stream stream representing the connection to and from the server connectInfo information required for opening a connection lastResponse remembers the last response from the server. progressObservers any object understanding #show: can be registered as a progress observer (login, transfer, etc)! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 14:54'! progressObservers progressObservers ifNil: [progressObservers := OrderedCollection new]. ^progressObservers! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:50'! fetchPendingResponse ^pendingResponses ifNil: [self fetchNextResponse; lastResponse] ifNotNil: [self popResponse]! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:38'! port: aPortNumber ^self connectionInfo at: #port put: aPortNumber! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:40'! openOnHost: hostIP port: portNumber self host: hostIP. self port: portNumber. self ensureConnection! ! !ProtocolClient methodsFor: 'actions' stamp: 'mir 3/7/2002 13:10'! close self stream ifNotNil: [ self stream close. stream := nil]! ! !ProtocolClient methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:42'! responseIsError self subclassResponsibility! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'! stream: aStream stream := aStream! ! !ProtocolClient methodsFor: 'private' stamp: 'md 8/14/2005 18:27'! ensureConnection self isConnected ifTrue: [^self]. self stream ifNotNil: [self stream close]. self stream: (SocketStream openConnectionToHost: self host port: self port). self checkResponse. self login! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 13:35'! lastResponse: aString lastResponse := aString. ! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:55'! popResponse | pendingResponse | pendingResponse := self pendingResponses removeFirst. pendingResponses isEmpty ifTrue: [pendingResponses := nil]. ^pendingResponse! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 11/11/2002 16:19'! user ^self connectionInfo at: #user ifAbsent: [nil]! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 3/5/2002 14:31'! sendStreamContents: aStream self stream sendStreamContents: aStream! ! !ProtocolClient methodsFor: 'actions' stamp: 'mir 3/7/2002 13:11'! reopen self ensureConnection! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:35'! connectionInfo connectInfo ifNil: [connectInfo := Dictionary new]. ^connectInfo! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'BenjaminVanRyseghem 3/14/2013 14:29'! checkResponse self checkResponseOnError: [:response | (TelnetProtocolError protocolInstance: self) signal: response] onWarning: [:response | (TelnetProtocolError protocolInstance: self) signal: response]! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 5/9/2003 15:52'! response ^self protocolInstance lastResponse! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 3/7/2002 14:55'! logProgressToTranscript self progressObservers add: Transcript! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:45'! pendingResponses pendingResponses ifNil: [pendingResponses := OrderedCollection new]. ^pendingResponses! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:37'! host: hostId ^self connectionInfo at: #host put: hostId! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:39'! user: aString ^self connectionInfo at: #user put: aString! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:52'! checkForPendingError "If data is waiting, check it to catch any error reports. In case the response is not an error, push it back." self stream isDataAvailable ifFalse: [^self]. self fetchNextResponse. self checkResponse: self lastResponse onError: [:response | (TelnetProtocolError protocolInstance: self) signal] onWarning: [:response | (TelnetProtocolError protocolInstance: self) signal]. "if we get here, it wasn't an error" self pushResponse: self lastResponse! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:56'! host ^self connectionInfo at: #host! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 13:35'! lastResponse ^lastResponse! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:35'! resetConnectionInfo connectInfo := nil! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'! stream ^stream! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 5/12/2003 18:10'! sendCommand: aString self stream sendCommand: aString. ! ! !ProtocolClient methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:42'! responseIsWarning self subclassResponsibility! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 5/12/2003 18:10'! logProgress: aString self progressObservers do: [:each | each show: aString]. ! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:45'! pushResponse: aResponse self pendingResponses add: aResponse! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:51'! checkResponse: aResponse onError: errorBlock onWarning: warningBlock "Get the response from the server and check for errors. Invoke one of the blocks if an error or warning is encountered. See class comment for classification of error codes." self responseIsError ifTrue: [errorBlock value: aResponse]. self responseIsWarning ifTrue: [warningBlock value: aResponse]. ! ! !ProtocolClient methodsFor: 'testing' stamp: 'mir 3/7/2002 14:33'! isConnected ^stream notNil and: [stream isConnected]! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 3/7/2002 13:16'! fetchNextResponse self lastResponse: self stream nextLine! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:56'! password ^self connectionInfo at: #password! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 2/25/2002 19:34'! defaultPortNumber ^self class defaultPortNumber! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:37'! password: aString ^self connectionInfo at: #password put: aString! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:54'! checkResponseOnError: errorBlock onWarning: warningBlock "Get the response from the server and check for errors. Invoke one of the blocks if an error or warning is encountered. See class comment for classification of error codes." self fetchPendingResponse. self checkResponse: self lastResponse onError: errorBlock onWarning: warningBlock! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:57'! port ^self connectionInfo at: #port! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 2/25/2002 19:07'! logFlag ^self class logFlag! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 5/9/2003 15:52'! messageText ^super messageText ifNil: [self response]! ! !ProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 16:00'! defaultPortNumber self subclassResponsibility! ! !ProtocolClient class methodsFor: 'instance creation' stamp: 'mir 2/25/2002 15:58'! openOnHostNamed: hostName port: portNumber | serverIP | serverIP := NetNameResolver addressForName: hostName timeout: 20. ^self openOnHost: serverIP port: portNumber ! ! !ProtocolClient class methodsFor: 'instance creation' stamp: 'mir 2/25/2002 15:59'! openOnHost: hostIP port: portNumber ^self new openOnHost: hostIP port: portNumber! ! !ProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 19:07'! logFlag self subclassResponsibility! ! !ProtocolClient class methodsFor: 'instance creation' stamp: 'gk 3/2/2004 11:10'! openOnHostNamed: hostName "If the hostname uses the colon syntax to express a certain portnumber we use that instead of the default port number." | i | i := hostName indexOf: $:. i = 0 ifTrue: [ ^self openOnHostNamed: hostName port: self defaultPortNumber] ifFalse: [ | s p | s := hostName truncateTo: i - 1. p := (hostName copyFrom: i + 1 to: hostName size) asInteger. ^self openOnHostNamed: s port: p] ! ! !ProtocolClientError commentStamp: 'mir 5/12/2003 18:05'! Abstract super class for protocol clients protocolInstance reference to the protocol client throughing the exception. Exception handlers can access the client in order close, respond or whatever may be appropriate ! !ProtocolClientError methodsFor: 'accessing' stamp: 'mir 10/30/2000 13:48'! protocolInstance: aProtocolInstance protocolInstance := aProtocolInstance! ! !ProtocolClientError methodsFor: 'accessing' stamp: 'mir 5/16/2003 11:18'! response ^self protocolInstance lastResponse! ! !ProtocolClientError methodsFor: 'accessing' stamp: 'mir 5/16/2003 11:17'! messageText ^super messageText ifNil: [self response]! ! !ProtocolClientError methodsFor: 'accessing' stamp: 'mir 10/30/2000 13:48'! protocolInstance ^protocolInstance! ! !ProtocolClientError class methodsFor: 'instance creation' stamp: 'mir 10/30/2000 16:15'! protocolInstance: aProtocolInstance ^self new protocolInstance: aProtocolInstance! ! !ProtocolList commentStamp: 'BenjaminVanRyseghem 1/21/2014 16:35'! I am widget displaying a list with a label. I am used to expose the construction of a spec UI in the Spec documentation.! !ProtocolList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 16:17'! resetSelection protocols resetSelection! ! !ProtocolList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2014 15:25'! protocols ^ protocols! ! !ProtocolList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2014 15:25'! label ^ label! ! !ProtocolList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 16:37'! title ^ 'Protocol widget'! ! !ProtocolList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 16:19'! displayBlock: aBlock protocols displayBlock: aBlock! ! !ProtocolList methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/21/2014 16:30'! initializeWidgets protocols := self newList. label := self newLabel. label text: 'Protocol'. self focusOrder add: protocols! ! !ProtocolList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 15:26'! items: aCollection protocols items: aCollection! ! !ProtocolList methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 1/21/2014 16:16'! whenSelectedItemChanged: aBlock protocols whenSelectedItemChanged: aBlock! ! !ProtocolList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 15:26'! label: aText label text: aText! ! !ProtocolList class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/27/2014 16:33'! defaultSpec ^ SpecLayout composed newColumn: [ :column | column add: #label height: self toolbarHeight; add: #protocols ]; yourself! ! !ProtocolOrganizer commentStamp: ''! A ProtocolOrganizer is part of a ClassOrganizer. It manages the protocols of the class that owns it! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/24/2012 14:16'! getProtocolNamed: aByteString ifNone: aBlockClosure ^ protocols detect: [:e | e name = aByteString ] ifNone: aBlockClosure ! ! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:17'! allMethods ^ self protocols gather: [:p | p methods ].! ! !ProtocolOrganizer methodsFor: 'protocol - adding' stamp: 'BenjaminVanRyseghem 4/12/2012 14:11'! addProtocol: aProtocol ^ protocols add: aProtocol! ! !ProtocolOrganizer methodsFor: 'private' stamp: 'EstebanLorenzano 1/16/2014 11:22'! moveMethodsFrom: fromProtocolNamed to: toProtocolNamed | fromProtocol toProtocol | fromProtocol := self protocolNamed: fromProtocolNamed. toProtocol := self protocolNamed: toProtocolNamed. toProtocol addAllMethodsFrom: fromProtocol. fromProtocol removeAllMethods. ^ toProtocol.! ! !ProtocolOrganizer methodsFor: 'initialization' stamp: 'EstebanLorenzano 6/26/2013 18:01'! importFrom: aClassOrganizer aClassOrganizer categories do: [:cat || protocol methods | cat = Protocol nullCategory ifFalse: [ methods := aClassOrganizer listAtCategoryNamed: cat. protocol := self addProtocolNamed: cat asString. methods do: [:m | protocol addMethod: m ]]].! ! !ProtocolOrganizer methodsFor: 'testing' stamp: 'EstebanLorenzano 6/27/2013 16:08'! hasProtocolNamed: aString ^ self allProtocols anySatisfy: [ :each | each name = aString ]! ! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:19'! allProtocol ^ allProtocol! ! !ProtocolOrganizer methodsFor: 'protocol - adding' stamp: 'EstebanLorenzano 6/21/2013 14:37'! addProtocolNamed: aName ^ protocols add: (Protocol name: aName)! ! !ProtocolOrganizer methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2013 23:07'! initialize super initialize. protocols := IdentitySet new. allProtocol := AllProtocol protocolOrganizer: self.! ! !ProtocolOrganizer methodsFor: 'protocol - adding' stamp: 'EstebanLorenzano 5/28/2013 14:11'! classify: aSymbol inProtocolNamed: aProtocolName | name protocol | name := aProtocolName. name = allProtocol name ifTrue: [ name := Protocol unclassified ]. "maybe here we should check if this method already belong to another protocol" (self protocolsOfSelector: aSymbol) do: [:p | p removeMethod: aSymbol ]. protocol := self getProtocolNamed: name ifNone: [ self addProtocolNamed: name ]. protocol addMethod: aSymbol ! ! !ProtocolOrganizer methodsFor: 'importing' stamp: 'BenjaminVanRyseghem 4/13/2012 13:45'! fromSpec: aSpec aSpec do: [:spec || name methods | name := spec first asSymbol. methods := spec allButFirst asSet. self addProtocol: (Protocol name: name methods: methods) ]! ! !ProtocolOrganizer methodsFor: 'testing' stamp: 'EstebanLorenzano 6/28/2013 16:03'! includesSelector: selector ^ protocols anySatisfy: [ :each | each includesSelector: selector ]! ! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 14:38'! removeMethod: aSymbol (self protocolsOfSelector: aSymbol) do: [ :p | p removeMethod: aSymbol ]! ! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 15:10'! allProtocols ^ { allProtocol }, protocols asArray! ! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/16/2014 11:22'! renameProtocol: oldName into: newName (self existsProtocolNamed: newName) ifTrue: [ self moveMethodsFrom: oldName to: newName. self removeProtocolNamed: oldName ] ifFalse: [ ^ (self protocolNamed: oldName) name: newName; yourself ].! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'EstebanLorenzano 6/28/2013 16:05'! protocolsOfSelector: aSelector ^ (self protocols select: [:each | each includesSelector: aSelector ]) asArray! ! !ProtocolOrganizer methodsFor: 'protocol - removing' stamp: 'EstebanLorenzano 11/29/2013 16:09'! removeProtocolNamed: aName | protocolToRemove | protocolToRemove := self protocolNamed: aName. ^ self removeProtocol: protocolToRemove! ! !ProtocolOrganizer methodsFor: 'protocol - removing' stamp: 'EstebanLorenzano 6/27/2013 16:10'! removeProtocol: aProtocol aProtocol canBeRemoved ifFalse: [ "Virtual protocols who cannot be removed should not raise an error" aProtocol isVirtualProtocol ifTrue: [ ^ self ]. ProtocolRemovalException signal ]. ^ protocols remove: aProtocol ifAbsent: [ ]! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'EstebanLorenzano 6/21/2013 14:51'! protocolsSorted ^ (self protocols collect: #name as: Array) sort copyWithFirst: allProtocol name! ! !ProtocolOrganizer methodsFor: 'private' stamp: 'MarcusDenker 10/5/2013 21:18'! existsProtocolNamed: aProtocolName ^self allProtocols anySatisfy: [ :e | e name = aProtocolName ] ! ! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/29/2013 16:09'! protocolNamed: aName ^ self protocolNamed: aName ifAbsent: [ Protocol empty ]! ! !ProtocolOrganizer methodsFor: 'protocol - removing' stamp: 'BenjaminVanRyseghem 4/24/2012 14:38'! removeEmptyProtocols (self protocols select: [:e | e isEmpty and: [ e canBeRemoved ] ]) do: [:p | self removeProtocol: p ]! ! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'MarcusDenker 11/26/2013 15:56'! protocols ^ protocols asArray! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'EstebanLorenzano 6/21/2013 15:31'! classify: aSymbol inProtocolNamed: aProtocolName suppressIfDefault: aBoolean | oldProtocols | oldProtocols := self protocolsOfSelector: aSymbol. self classify: aSymbol inProtocolNamed: aProtocolName. aBoolean ifTrue: [ (oldProtocols select: #canBeRemoved) do: [:e | self removeProtocol: e ] ].! ! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 15:12'! allProtocolsNames ^ self allProtocols collect: #name! ! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/27/2013 18:03'! protocolsNames ^ protocols collect: #name as: Array! ! !ProtocolOrganizer methodsFor: 'backward compatibility' stamp: 'EstebanLorenzano 11/29/2013 16:09'! methodsInProtocolNamed: aName aName = AllProtocol defaultName ifTrue: [ ^ self allMethods ]. ^ (self protocolNamed: aName) methods! ! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/29/2013 16:08'! protocolNamed: aString ifAbsent: aBlock ^ self allProtocols detect: [ :e | e name = aString ] ifNone: aBlock! ! !ProtocolOrganizer methodsFor: 'backward compatibility - file in/out' stamp: 'BenjaminVanRyseghem 4/12/2012 18:10'! stringForFileOut ^ String streamContents: [:aStream | self protocols do: [:p | aStream << $( << p name printString. p methods do: [:m | aStream << ' ' << m asString ]. aStream << $); cr ]]! ! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/4/2013 14:45'! extensionProtocols ^ self protocols select: #isExtensionProtocol! ! !ProtocolOrganizer class methodsFor: 'import' stamp: 'BenjaminVanRyseghem 4/13/2012 13:45'! fromSpec: aSpec ^ self new fromSpec: aSpec; yourself! ! !ProtocolOrganizer class methodsFor: 'import' stamp: 'BenjaminVanRyseghem 4/12/2012 14:35'! importFrom: aClassOrganizer ^ self new importFrom: aClassOrganizer; yourself! ! !ProtocolRemovalException commentStamp: ''! A ProtocolRemovalException is an error raised when someone try to remove a protocol that should not be removed! !ProtocolRemoved commentStamp: ''! This class is not used, but should be used when we hook into the addition and removal of protocols. Right now, we only get ClassReorganizedAnnouncement! !ProtocolViewer commentStamp: 'BenjaminVanRyseghem 1/21/2014 16:36'! I am a widget gathering a list of models with two protocol list:one for the methods in 'protocol', the other for the methods in 'protocol-events'. I am used to expose the construction of a spec UI in the Spec documentation.! !ProtocolViewer methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 1/21/2014 16:16'! whenEventChangedDo: aBlock events whenSelectedItemChanged: aBlock! ! !ProtocolViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2014 15:33'! protocols ^ protocols! ! !ProtocolViewer methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/27/2014 11:48'! initializePresenter models whenSelectedItemChanged: [ :class | protocols resetSelection. events resetSelection. class ifNil: [ protocols items: #(). events items: #() ] ifNotNil: [ protocols items: (self methodsIn: class for: 'protocol'). events items: (self methodsIn: class for: 'protocol-events') ] ]. protocols whenSelectedItemChanged: [ :method | method ifNotNil: [ self resetEventSelection ] ]. events whenSelectedItemChanged: [ :method | method ifNotNil: [ self resetProtocolSelection ] ].! ! !ProtocolViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2014 15:33'! events ^ events! ! !ProtocolViewer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 16:15'! resetEventSelection events resetSelection! ! !ProtocolViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/21/2014 16:21'! methodsIn: class for: protocol ^ (class methodsInProtocol: protocol) sorted: [ :a :b | a selector < b selector ]! ! !ProtocolViewer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 16:38'! title ^ 'Protocol viewer'! ! !ProtocolViewer methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 1/21/2014 16:22'! whenClassChanged: aBlock models whenSelectedItemChanged: aBlock! ! !ProtocolViewer methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/21/2014 16:30'! initializeWidgets models := self instantiate: ModelList. protocols := self instantiate: ProtocolList. events := self instantiate: ProtocolList. protocols label: 'protocol'; displayBlock: [ :m | m selector ]. events label: 'protocol-events'; displayBlock: [ :m | m selector ]. self focusOrder add: models; add: protocols; add: events ! ! !ProtocolViewer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 1/21/2014 16:15'! resetProtocolSelection protocols resetSelection! ! !ProtocolViewer methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 1/21/2014 16:16'! whenProtocolChangedDo: aBlock protocols whenSelectedItemChanged: aBlock! ! !ProtocolViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2014 15:33'! models ^ models! ! !ProtocolViewer class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/27/2014 16:33'! defaultSpec ^ SpecLayout composed newColumn: [ :column | column add: #models; add: #protocols; add: #events ]; yourself! ! !PrototypeTester commentStamp: 'mjr 8/20/2003 13:09'! I am a simple holder of a prototype object and hand out copies when requested.! !PrototypeTester methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/3/2006 22:39'! prototype: aPrototype "Set my prototype" prototype := aPrototype copy ! ! !PrototypeTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:57'! result "Perform the test the default number of times" ^ self resultFor: self class defaultRuns ! ! !PrototypeTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! prototype "Get a prototype" ^ prototype copy ! ! !PrototypeTester class methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 13:08'! defaultRuns "the default number of times to test" ^ 50! ! !PrototypeTester class methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 13:08'! with: aPrototype ^self new prototype:aPrototype! ! !ProvideAnswerNotification commentStamp: 'TorstenBergmann 1/31/2014 11:56'! Notify to provide an answer! !PseudoClass commentStamp: ''! I provide an inert model of a Class, used by FileContentsBrowser to manipulate filedout code. Instead of a method dictionary or selectors onto CompiledMethods, I have a dictionary ("source") of selectors onto ChangeRecords, which were, in the case of FileContentsBrowser, parsed from a source or change set file.! !PseudoClass methodsFor: 'class' stamp: ''! comment: aString self commentString: aString.! ! !PseudoClass methodsFor: 'filein/fileout' stamp: ''! fileInCategory: aCategory ^self fileInMethods: (self organization listAtCategoryNamed: aCategory)! ! !PseudoClass methodsFor: 'categories' stamp: ''! removeCategory: selector (self organization listAtCategoryNamed: selector) do:[:sel| self organization removeElement: sel. self sourceCode removeKey: sel. ]. self organization removeCategory: selector.! ! !PseudoClass methodsFor: 'filein/fileout' stamp: 'PeterHugossonMiller 9/3/2009 10:52'! fileOutCategory: categoryName | internalStream | internalStream := (String new: 1000) writeStream. self fileOutMethods: (self organization listAtCategoryNamed: categoryName) on: internalStream. FileStream writeSourceCodeFrom: internalStream baseName: (self name, '-', categoryName) isSt: true! ! !PseudoClass methodsFor: 'organization updating' stamp: 'MarcusDenker 10/3/2013 17:09'! notifyOfRecategorizedSelector: aString from: aString2 to: aString3 ! ! !PseudoClass methodsFor: 'class' stamp: ''! metaClass ^metaClass ifNil:[metaClass := PseudoMetaclass new name: (self name)].! ! !PseudoClass methodsFor: 'accessing' stamp: 'nk 3/9/2004 10:24'! instVarNames ^ #()! ! !PseudoClass methodsFor: 'accessing' stamp: 'nk 4/29/2004 06:59'! allCallsOn ^ (self realClass ifNil: [ ^#() ]) allCallsOn! ! !PseudoClass methodsFor: 'filein/fileout' stamp: ''! fileInMethods ^self fileInMethods: self selectors! ! !PseudoClass methodsFor: 'class' stamp: 'BJP 4/23/2001 13:50'! comment | rStr | rStr := self organization commentRemoteStr. ^rStr isNil ifTrue:[self name,' has not been commented in this file'] ifFalse:[rStr string]! ! !PseudoClass methodsFor: 'categories' stamp: ''! whichCategoryIncludesSelector: aSelector "Answer the category of the argument, aSelector, in the organization of the receiver, or answer nil if the receiver does not inlcude this selector." ^ self organization categoryOfElement: aSelector! ! !PseudoClass methodsFor: 'removing' stamp: ''! removeAllUnmodified | stClass | self exists ifFalse:[^self]. self removeUnmodifiedMethods: self selectors. stClass := self realClass. (self hasDefinition and:[stClass definition = self definition]) ifTrue:[definition := nil]. (self hasComment and:[stClass comment asString = self commentString]) ifTrue:[ self classComment: nil]. metaClass isNil ifFalse:[metaClass removeAllUnmodified].! ! !PseudoClass methodsFor: 'testing' stamp: 'StephaneDucasse 2/20/2010 21:50'! needsInitialize ^self hasMetaclass and: [self metaClass includesSelector: #initialize]! ! !PseudoClass methodsFor: 'filein/fileout' stamp: ''! fileOutOn: aStream "FileOut the receiver" self fileOutDefinitionOn: aStream. metaClass ifNotNil:[metaClass fileOutDefinitionOn: aStream]. self fileOutMethods: self selectors on: aStream. metaClass ifNotNil:[metaClass fileOutMethods: metaClass selectors on: aStream].! ! !PseudoClass methodsFor: 'accessing' stamp: 'wod 5/19/1998 17:42'! theNonMetaClass "Sent to a class or metaclass, always return the class" ^self! ! !PseudoClass methodsFor: 'private' stamp: 'MarcusDenker 8/28/2013 10:18'! evaluate: aString ^self compiler source: aString; logged: true; evaluate ! ! !PseudoClass methodsFor: 'private' stamp: 'lr 3/14/2010 21:13'! makeSureSuperClassExists: aString | theClass | theClass := Smalltalk globals at: aString asSymbol ifAbsent: [ nil ]. theClass ifNotNil: [ ^ true ]. ^ self confirm: 'The super class ' , aString , ' does not exist in the system. Use nil instead?'! ! !PseudoClass methodsFor: 'class' stamp: 'ar 2/5/2004 15:18'! commentString ^self comment asString! ! !PseudoClass methodsFor: 'testing' stamp: 'lr 3/14/2010 21:13'! exists ^ (Smalltalk globals at: self name asSymbol ifAbsent: [ ^ false ]) isKindOf: Behavior! ! !PseudoClass methodsFor: 'methods' stamp: ''! removeMethod: selector self organization removeElement: selector. self sourceCode removeKey: selector. ! ! !PseudoClass methodsFor: 'accessing' stamp: 'EstebanLorenzano 10/2/2013 14:47'! organization ^ organization ifNil: [organization := PseudoClassOrganization forClass: self ]. ! ! !PseudoClass methodsFor: 'testing method dictionary' stamp: 'marcus.denker 11/10/2008 10:04'! bindingOf: varName self exists ifTrue:[ (self realClass bindingOf: varName) ifNotNil:[:binding| ^binding]. ]. ^Smalltalk bindingOf: varName asSymbol! ! !PseudoClass methodsFor: 'methods' stamp: ''! removeSelector: aSelector | catName | catName := self removedCategoryName. self organization addCategory: catName before: self organization categories first. self organization classify: aSelector under: catName. self sourceCodeAt: aSelector put:'methodWasRemoved' asText.! ! !PseudoClass methodsFor: 'private' stamp: ''! confirmRemovalOf: aString ^self confirm:'Remove ',aString,' ?'! ! !PseudoClass methodsFor: 'accessing' stamp: ''! fullName ^self name! ! !PseudoClass methodsFor: 'testing' stamp: ''! hasMetaclass ^metaClass notNil! ! !PseudoClass methodsFor: 'accessing' stamp: 'nk 2/18/2004 18:32'! allSuperclasses ^ (self realClass ifNil: [ ^#() ]) allSuperclasses! ! !PseudoClass methodsFor: 'methods' stamp: ''! sourceCodeTemplate ^''! ! !PseudoClass methodsFor: 'accessing' stamp: 'StephaneDucasse 4/30/2011 21:38'! allCallsOnIn: aSystemNavigation ^ (self realClass ifNil: [ ^#() ]) allCallsOn! ! !PseudoClass methodsFor: 'private' stamp: 'nk 2/18/2004 18:33'! allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level ^ (self realClass ifNil: [ ^self ]) allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level! ! !PseudoClass methodsFor: '*MonticelloGUI' stamp: 'MartinDias 11/7/2013 18:11'! asClassDefinition ^ MCClassDefinition name: self name superclassName: self superclass name category: self category instVarNames: self instVarNames classVarNames: self classVarNames asSortedCollection poolDictionaryNames: self sharedPoolNames classInstVarNames: self class instVarNames type: self typeOfClass comment: self organization classComment asString commentStamp: self organization commentStamp ! ! !PseudoClass methodsFor: 'accessing' stamp: ''! name: anObject name := anObject! ! !PseudoClass methodsFor: 'class' stamp: ''! commentString: aString self classComment: aString asText. "Just wrap it"! ! !PseudoClass methodsFor: 'filein/fileout' stamp: 'nice 1/5/2010 15:59'! fileInMethods: aCollection "FileIn all methods with selectors taken from aCollection" | theClass | self exists ifFalse:[^self classNotDefined]. theClass := self realClass. aCollection do:[:sel| | cat | cat := self organization categoryOfElement: sel. cat = self removedCategoryName ifFalse:[ theClass compile: (self sourceCodeAt: sel) classified: cat withStamp: (self stampAt: sel) notifying: nil. ]. ].! ! !PseudoClass methodsFor: 'filein/fileout' stamp: ''! fileIn "FileIn the receiver" self hasDefinition ifTrue:[self fileInDefinition]. self fileInMethods: self selectors. metaClass ifNotNil:[metaClass fileIn]. self needsInitialize ifTrue:[ self evaluate: self name,' initialize'. ].! ! !PseudoClass methodsFor: 'methods' stamp: ''! sourceCodeAt: sel ^(self sourceCode at: sel) string! ! !PseudoClass methodsFor: 'accessing' stamp: ''! name ^name! ! !PseudoClass methodsFor: 'filein/fileout' stamp: 'PeterHugossonMiller 9/3/2009 10:52'! fileOutMethod: selector | internalStream | internalStream := (String new: 1000) writeStream. self fileOutMethods: (Array with: selector) on: internalStream. FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true! ! !PseudoClass methodsFor: 'errors' stamp: ''! classNotDefined ^self inform: self name,' is not defined in the system. You have to define this class first.'.! ! !PseudoClass methodsFor: 'filein/fileout' stamp: 'ar 2/7/2004 01:04'! fileOutMethods: aCollection on: aStream "FileOut all methods with selectors taken from aCollection" | cat categories | categories := Dictionary new. aCollection do:[:sel| cat := self organization categoryOfElement: sel. cat = self removedCategoryName ifFalse:[ (categories includesKey: cat) ifFalse:[categories at: cat put: Set new]. (categories at: cat) add: sel]. ]. categories associationsDo:[:assoc| cat := assoc key. assoc value do:[:sel| aStream cr. (self sourceCode at: sel) fileOutOn: aStream. ]. ].! ! !PseudoClass methodsFor: 'testing' stamp: ''! hasComment ^self organization commentRemoteStr notNil! ! !PseudoClass methodsFor: 'methods' stamp: 'sw 6/10/2003 17:31'! stampAt: selector "Answer the authoring time-stamp of the change" | code | ^ ((code := self sourceCode at: selector) isKindOf: ChangeRecord) ifTrue: [code stamp] ifFalse: [code string]! ! !PseudoClass methodsFor: 'class' stamp: 'di 1/13/1999 12:00'! sharedPools self exists ifFalse: [^ nil]. ^ self realClass sharedPools! ! !PseudoClass methodsFor: 'class' stamp: ''! definition: aString definition := aString! ! !PseudoClass methodsFor: 'class' stamp: ''! classComment: aChangeRecord self organization classComment: aChangeRecord! ! !PseudoClass methodsFor: 'methods' stamp: 'MarcusDenker 4/28/2013 11:15'! addMethodChange: aChangeRecord | selector | selector := self compiler parseSelector: aChangeRecord string. self organization classify: selector under: aChangeRecord category. self sourceCodeAt: selector put: aChangeRecord! ! !PseudoClass methodsFor: 'filein/fileout' stamp: 'ar 7/16/2005 14:06'! fileInDefinition self hasDefinition ifFalse:[^self]. (self makeSureSuperClassExists: (definition copyUpTo: Character space)) ifFalse:[^self]. self hasDefinition ifTrue:[ Transcript cr; show:'Defining ', self name. self evaluate: self definition]. self exists ifFalse:[^self]. self hasComment ifTrue:[self realClass classComment: self comment].! ! !PseudoClass methodsFor: 'testing' stamp: 'marcus.denker 7/29/2009 15:27'! hasChanges self sourceCode isEmpty ifFalse:[^true]. self organization hasComment ifTrue:[^true]. definition isNil ifFalse:[^true]. metaClass isNil ifFalse:[^metaClass hasChanges]. ^false! ! !PseudoClass methodsFor: 'filein/fileout' stamp: ''! fileOutMethodsOn: aStream ^self fileOutMethods: self selectors on: aStream.! ! !PseudoClass methodsFor: 'filein/fileout' stamp: ''! fileInMethod: selector ^self fileInMethods: (Array with: selector)! ! !PseudoClass methodsFor: 'filein/fileout' stamp: 'mir 9/25/2008 15:04'! fileOutDefinitionOn: aStream self hasDefinition ifFalse:[^self]. aStream nextChunkPut: self definition; cr. self hasComment ifTrue: [ aStream cr. self organization commentRemoteStr fileOutOn: aStream]! ! !PseudoClass methodsFor: 'accessing' stamp: 'NorbertHartl 6/20/2008 21:25'! theMetaClass ^ self metaClass! ! !PseudoClass methodsFor: 'testing' stamp: ''! hasDefinition ^definition notNil! ! !PseudoClass methodsFor: 'methods' stamp: ''! methodChange: aChangeRecord aChangeRecord isMetaClassChange ifTrue:[ ^self metaClass addMethodChange: aChangeRecord. ] ifFalse:[ ^self addMethodChange: aChangeRecord. ]. ! ! !PseudoClass methodsFor: 'accessing' stamp: 'jb 7/1/2011 10:54'! compilerClass ^ (Smalltalk globals at: name ifAbsent: [ ^ self class compilerClass ]) compilerClass! ! !PseudoClass methodsFor: 'printing' stamp: 'ar 2/5/2004 16:04'! printOn: aStream super printOn: aStream. aStream nextPut:$(; print: name; nextPut:$)! ! !PseudoClass methodsFor: 'methods' stamp: 'StephaneDucasse 2/20/2010 21:53'! includesSelector: aSymbol "Answer whether the message whose selector is the argument is in the method dictionary of the receiver's class." ^ self exists ifTrue: [self realClass includesSelector: aSymbol] ifFalse: [false] "Note that this method is only used to check whether the class should initialized so returning false is better than raising an error"! ! !PseudoClass methodsFor: 'methods' stamp: ''! sourceCode ^source ifNil:[source := Dictionary new]! ! !PseudoClass methodsFor: 'class' stamp: 'LC 10/8/2001 04:46'! definition | link linkText defText | ^definition ifNil: [defText := Text fromString: 'There is no class definition for '. link := TextLink new. linkText := link analyze: self name with: 'Definition'. linkText := Text string: (linkText ifNil: ['']) attribute: link. defText append: linkText; append: ' in this file'].! ! !PseudoClass methodsFor: 'accessing' stamp: 'sma 6/16/1999 22:59'! allInstVarNames ^#()! ! !PseudoClass methodsFor: 'override' stamp: 'nk 2/18/2004 18:30'! isMeta ^false! ! !PseudoClass methodsFor: 'accessing' stamp: 'lr 3/14/2010 21:13'! realClass ^ Smalltalk globals at: self name asSymbol ifAbsent: [ ]! ! !PseudoClass methodsFor: 'class' stamp: 'di 1/13/1999 12:00'! classPool self exists ifFalse: [^ nil]. ^ self realClass classPool! ! !PseudoClass methodsFor: 'removing' stamp: ''! removeUnmodifiedMethods: aCollection | stClass | self exists ifFalse:[^self]. stClass := self realClass. aCollection do:[:sel| (self sourceCodeAt: sel) = (stClass sourceCodeAt: sel ifAbsent:['']) asString ifTrue:[ self removeMethod: sel. ]. ]. self organization removeEmptyCategories.! ! !PseudoClass methodsFor: 'methods' stamp: ''! sourceCodeAt: sel put: object self sourceCode at: sel put: object! ! !PseudoClass methodsFor: 'accessing' stamp: 'MarcusDenker 4/28/2013 20:05'! compiler ^ self compilerClass new! ! !PseudoClass methodsFor: 'printing' stamp: 'sma 6/17/1999 00:00'! literalScannedAs: scannedLiteral notifying: requestor ^ scannedLiteral! ! !PseudoClass methodsFor: 'class' stamp: 'nk 2/18/2004 18:30'! renameTo: aString self hasDefinition ifTrue:[ self isMeta ifTrue:[ self definition: (self definition copyReplaceAll: name,' class' with: aString, ' class'). ] ifFalse:[ self definition: (self definition copyReplaceAll:'ubclass: #',name with:'ubclass: #', aString)]]. name := aString. metaClass ifNotNil:[metaClass renameTo: aString].! ! !PseudoClass methodsFor: 'accessing' stamp: 'IgorStasenko 10/13/2013 21:00'! users ^ #()! ! !PseudoClass methodsFor: 'methods' stamp: 'StephaneDucasse 10/15/2013 22:19'! selectors ^self sourceCode keys sorted! ! !PseudoClass methodsFor: 'filein/fileout' stamp: 'PeterHugossonMiller 9/3/2009 10:52'! fileOut | internalStream | internalStream := (String new: 1000) writeStream. self fileOutOn: internalStream. self needsInitialize ifTrue:[ internalStream cr; nextChunkPut: self name,' initialize'. ]. FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true! ! !PseudoClass methodsFor: 'categories' stamp: ''! removedCategoryName ^'*** removed methods ***' asSymbol! ! !PseudoClassOrganization commentStamp: ''! I'm a pseudo class organization. I override the use of RemoteString to store class coments. ! !PseudoClassOrganization methodsFor: 'comment accessing' stamp: 'EstebanLorenzano 10/2/2013 14:45'! classComment: aChangeRecord comment := aChangeRecord! ! !PseudoClassOrganization methodsFor: 'comment accessing' stamp: 'EstebanLorenzano 10/2/2013 14:45'! classComment "Answer the comment associated with the object that refers to the receiver." comment ifNil: [ ^ '' ]. ^ comment! ! !PseudoMetaclass commentStamp: 'TorstenBergmann 1/31/2014 10:17'! I provide an inert model of a Metaclass, used by FileContentsBrowser to manipulate filedout code. ! !PseudoMetaclass methodsFor: 'accessing' stamp: ''! realClass ^super realClass class! ! !PseudoMetaclass methodsFor: 'accessing' stamp: 'FBS 3/4/2004 14:17'! theNonMetaClass "Sent to a class or metaclass, always return the class" ^self realClass theNonMetaClass! ! !PseudoMetaclass methodsFor: 'testing' stamp: 'nk 2/18/2004 18:30'! isMeta ^true! ! !PseudoMetaclass methodsFor: 'accessing' stamp: ''! fullName ^self name,' class'! ! !QSystemTally commentStamp: ''! Tally for assembling system profiles. It's a subclass of Link so we can chain tallies together in the receivers list.! !QSystemTally methodsFor: 'accessing' stamp: 'ar 6/11/2007 21:58'! tally "Answer the tally count for this node" ^tally! ! !QSystemTally methodsFor: 'report' stamp: 'AlexandreBergel 1/29/2013 11:11'! getNewTabsFor: tabs ^ tabs size < self maxTabs ifTrue: [ tabs ] ifFalse: [ (tabs select: [ :x | x = '[' ]) copyWith: '[' ]! ! !QSystemTally methodsFor: 'accessing' stamp: 'ar 6/11/2007 22:24'! maxClassPlusSelectorSize "Return the default maximum width of the class plus selector together (not counting the '>>')" ^60! ! !QSystemTally methodsFor: 'copying' stamp: 'ar 6/11/2007 22:31'! copyWithTally: hitCount ^ (QSystemTally new class: class method: method) bumpBy: hitCount! ! !QSystemTally methodsFor: 'accessing' stamp: 'bgf 3/6/2008 12:21'! maxTabs "Return the default number of tabs after which leading white space is compressed" ^36! ! !QSystemTally methodsFor: 'report' stamp: 'AlexandreBergel 1/29/2013 11:00'! printOn: aStream total: total totalTime: totalTime tallyExact: isExact | className myTally aClass percentage | isExact ifTrue:[ myTally := tally. receivers ifNotNil: [ receivers asArray do: [ :r | myTally := myTally - r tally ] ]. aStream print: myTally; space. ] ifFalse:[ percentage := tally asFloat / total * 100.0 roundTo: 0.1. aStream print: percentage; nextPutAll: ' ('; nextPutAll: (percentage * totalTime / 100) rounded asStringWithCommas; nextPutAll: ') '. ]. self isPrimitives ifTrue:[ aStream nextPutAll: 'primitives'; cr ] ifFalse:[ aClass := method methodClass. className := aClass name contractTo: self maxClassNameSize. aStream nextPutAll: class name; nextPutAll: (aClass = class ifTrue: [' '] ifFalse: [' [' , aClass name , '] ']); nextPutAll: (method selector contractTo: self maxClassPlusSelectorSize - className size); cr. ].! ! !QSystemTally methodsFor: 'report' stamp: 'AlexandreBergel 1/29/2013 11:00'! sonsOver: threshold "Answer the sons with tallys over the given threshold" "threshold is a number " receivers ifNil: [ ^ #() ]. ^ receivers asArray select: [ :son | son tally > threshold ].! ! !QSystemTally methodsFor: 'report' stamp: 'AlexandreBergel 1/29/2013 11:11'! treePrintOn: aStream tabs: tabs thisTab: myTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold "aStream contains the output of the print " "tabs is a collection of strings " | sons sonTab | tabs do: [ :tab | aStream nextPutAll: tab ]. tabs size > 0 ifTrue: [ self printOn: aStream total: total totalTime: totalTime tallyExact: isExact ]. sons := isExact ifTrue: [ receivers ] ifFalse: [ self sonsOver: threshold ]. sons isNil ifTrue: [ ^ self ]. sons notEmpty ifTrue: [ tabs addLast: myTab. sons := self asSortedCollection: sons. 1 to: sons size do: [ :i | sonTab := i < sons size ifTrue: [ ' |' ] ifFalse: [ ' ' ]. (sons at: i) treePrintOn: aStream tabs: (self getNewTabsFor: tabs) thisTab: sonTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold ]. tabs removeLast ]! ! !QSystemTally methodsFor: 'printing' stamp: 'MarcusDenker 4/21/2013 18:02'! printOn: aStream aStream print: class; nextPutAll: '>>'; print: (method ifNotNil:[method selector]). aStream nextPutAll: ' -- '; print: tally.! ! !QSystemTally methodsFor: 'report' stamp: 'AlexandreBergel 1/29/2013 10:34'! bump: hitCount fromSender: senderTally "Add this hitCount to the total, and include a reference to the sender responsible for the increment" self bumpBy: hitCount. senders ifNil: [ senders := OrderedCollection new ]. senderTally ifNotNil: [ senders add: (senderTally copyWithTally: hitCount) ]! ! !QSystemTally methodsFor: 'report' stamp: 'AlexandreBergel 1/29/2013 11:43'! leavesPrintOn: aStream tallyExact: isExact orThreshold: threshold time: totalTime "@TODO: Apparently, providing true as isExact will always produce an error " | dict | dict := IdentityDictionary new: 100. self leavesInto: dict fromSender: nil. isExact ifTrue: [ (self asSortedCollection: dict) do: [ :node | node printOn: aStream total: tally totalTime: nil tallyExact: isExact. node printSenderCountsOn: aStream ] ] ifFalse:[ ((self asSortedCollection: dict) select: [ :node | node tally > threshold ]) do: [ :node | node printOn: aStream total: tally totalTime: totalTime tallyExact: isExact ] ]! ! !QSystemTally methodsFor: 'initialize' stamp: 'ar 6/11/2007 22:07'! class: aClass method: aCompiledMethod class := aClass. method := aCompiledMethod. tally := 0.! ! !QSystemTally methodsFor: 'converting' stamp: 'AlexandreBergel 1/29/2013 10:33'! asArray | link | ^Array streamContents: [ :s | link := self. [link == nil] whileFalse: [ s nextPut: link. link := link nextLink. ]. ].! ! !QSystemTally methodsFor: 'tallying' stamp: 'ar 6/11/2007 21:54'! bumpBy: count "Bump this tally by the specified amount" tally := tally + count! ! !QSystemTally methodsFor: 'report' stamp: 'ar 6/11/2007 22:28'! fullPrintOn: aStream tallyExact: isExact orThreshold: perCent time: totalTime | threshold | isExact ifFalse: [threshold := (perCent asFloat / 100 * tally) rounded]. aStream nextPutAll: '**Tree**'; cr. self treePrintOn: aStream tabs: OrderedCollection new thisTab: '' total: tally totalTime: totalTime tallyExact: isExact orThreshold: threshold. aStream nextPut: Character newPage; cr. aStream nextPutAll: '**Leaves**'; cr. self leavesPrintOn: aStream tallyExact: isExact orThreshold: threshold time: totalTime.! ! !QSystemTally methodsFor: 'accessing' stamp: 'ar 6/11/2007 21:57'! method "Answer the CompiledMethod associated with this tally" ^method! ! !QSystemTally methodsFor: 'tallying' stamp: 'ar 2/27/2008 12:01'! tallyMethod: aMethod by: count "Called explicitly and needs to decrement receiver's tally count" | node | node := receivers. [node == nil] whileFalse:[ node method == aMethod ifTrue:[^node bumpBy: count]. node := node nextLink. ]. node := QSystemTally new class: aMethod methodClass method: aMethod. node nextLink: receivers. receivers := node. ^node bumpBy: count! ! !QSystemTally methodsFor: 'initialize' stamp: 'ar 6/11/2007 22:50'! primitives: anInteger "Make the receiver be a node of unassigned primitives" tally := anInteger. method := nil. "indicates primitives"! ! !QSystemTally methodsFor: 'report' stamp: 'ar 6/11/2007 22:30'! into: leafDict fromSender: senderTally | leafNode | leafNode := leafDict at: method ifAbsent: [leafDict at: method put: (QSystemTally new class: class method: method)]. leafNode bump: tally fromSender: senderTally! ! !QSystemTally methodsFor: 'accessing' stamp: 'ar 6/11/2007 22:24'! maxClassNameSize "Return the default maximum width of the class name alone" ^30! ! !QSystemTally methodsFor: 'report' stamp: 'ar 6/11/2007 22:29'! leavesInto: leafDict fromSender: senderTally | rcvrs | rcvrs := self sonsOver: 0. rcvrs size = 0 ifTrue: [self into: leafDict fromSender: senderTally] ifFalse: [rcvrs do:[:node | node isPrimitives ifTrue: [node leavesInto: leafDict fromSender: senderTally] ifFalse: [node leavesInto: leafDict fromSender: self]]]! ! !QSystemTally methodsFor: 'tallying' stamp: 'ClementBera 6/28/2013 10:37'! tallyPath: context by: count "Tally the context chain" | aMethod aTally | aMethod := context method. aTally := receivers. [aTally == nil] whileFalse:[ aTally method == aMethod ifTrue:[^aTally bumpBy: count]. aTally := aTally nextLink. ]. aTally := QSystemTally new class: context receiver class method: aMethod. aTally nextLink: receivers. receivers := aTally. ^aTally bumpBy: count! ! !QSystemTally methodsFor: 'testing' stamp: 'ar 6/11/2007 22:50'! isPrimitives "Detect pseudo node used to carry tally of local hits" ^ method == nil! ! !QSystemTally methodsFor: 'tallying' stamp: 'ar 6/11/2007 22:01'! tally: context by: count "Explicitly tally the specified context and its stack." | root | (root := context home sender) ifNil:[^(self bumpBy: count) tallyPath: context by: count] ifNotNil:[^(self tally: root by: count) tallyPath: context by: count]! ! !QSystemTally methodsFor: 'converting' stamp: 'AlexandreBergel 1/29/2013 10:33'! asSortedCollection: aCollection "Create a sorted collection from the given input" ^aCollection asSortedCollection: [ :tA :tB | tA tally >= tB tally ]! ! !QSystemTally class methodsFor: 'LICENSE' stamp: 'RJT 1/23/2013 15:34'! LICENSE ^'Project Squeak In Memory of Andreas Raab. Author, Friend, Colleague. http://forum.world.st/In-Memory-of-Andreas-Raab-td4663424.html Copyright (c) 2005-2013, 3D Immersive Collaboration Consulting, LLC., All Rights Reserved Redistributions in source code form must reproduce the above copyright and this condition. Licensed under MIT License (MIT) Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.'! ! !QuestionDialogWindow commentStamp: 'gvc 5/18/2007 12:20'! A yes/no/cancel message dialog. Cancel (escape & return) is the default.! !QuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:44'! answer "Answer the value of answer" ^ answer! ! !QuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:44'! yes "Answer yes." self answer: true; ok! ! !QuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:44'! newButtons "Answer new buttons as appropriate." ^{self newYesButton. self newNoButton. self newCancelButton isDefault: true}! ! !QuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:44'! answer: anObject "Set the value of answer" answer := anObject! ! !QuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2007 17:36'! no "Answer no." self answer: false; ok! ! !QuestionWithoutCancelDialogWindow commentStamp: 'gvc 5/18/2007 12:20'! A yes/no message dialog. Yes (return) is the default. Escape will answer no.! !QuestionWithoutCancelDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:44'! escapePressed "Default is to cancel." self no! ! !QuestionWithoutCancelDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:45'! newButtons "Answer new buttons as appropriate." ^{self newYesButton isDefault: true. self newNoButton}! ! !QuotedPrintableMimeConverter commentStamp: ''! I am QuotedPrintableMimeConverter. I am a MimeConverter. Quoted-Printable, or QP encoding, is an encoding using printable ASCII characters (alphanumeric and the equals sign "=") to transmit 8-bit data over a 7-bit data path or, generally, over a medium which is not 8-bit clean. It is defined as a MIME content transfer encoding for use in e-mail. QP works by using the equals sign "=" as an escape character. It also limits line length to 76, as some software has limits on line length. See also http://en.wikipedia.org/wiki/Quoted-printable http://tools.ietf.org/html/rfc2045 I do quoted printable MIME decoding as specified in RFC 2045 "MIME Part One: Format of Internet Message Bodies". Short version of RFC2045, Sect. 6.7: (1) Any octet, except a CR or LF that is part of a CRLF line break of the canonical (standard) form of the data being encoded, may be represented by an "=" followed by a two digit hexadecimal representation of the octet's value. [...] (2) Octets with decimal values of 33 through 60 inclusive, and 62 through 126, inclusive, MAY be represented as the US-ASCII characters which correspond to those octets [...]. (3) Octets with values of 9 and 32 MAY be represented as US-ASCII TAB (HT) and SPACE characters, respectively, but MUST NOT be so represented at the end of an encoded line. [...] (4) A line break in a text body, represented as a CRLF sequence in the text canonical form, must be represented by a (RFC 822) line break, which is also a CRLF sequence, in the Quoted-Printable encoding. [...] (5) The Quoted-Printable encoding REQUIRES that encoded lines be no more than 76 characters long. If longer lines are to be encoded with the Quoted-Printable encoding, "soft" line breaks must be used. An equal sign as the last character on a encoded line indicates such a non-significant ("soft") line break in the encoded text.! !QuotedPrintableMimeConverter methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/8/2013 23:25'! initialize super initialize. newline := String cr! ! !QuotedPrintableMimeConverter methodsFor: 'conversion' stamp: 'SvenVanCaekenberghe 12/8/2013 23:26'! mimeEncode | char charValue lineLength | lineLength := 0. [ dataStream atEnd ] whileFalse: [ lineLength >= 74 ifTrue: [ mimeStream nextPut: $=; nextPutAll: newline. lineLength := 0]. char := dataStream next. charValue := char asInteger. (charValue = 9 | (charValue between: 32 and: 60) | (charValue between: 62 and: 126)) ifTrue: [ mimeStream nextPut: char. lineLength := lineLength + 1 ] ifFalse: [ (char = Character cr) | (char = Character lf) ifTrue: [ mimeStream nextPutAll: '=0D=0A'. char = Character cr ifTrue: [ dataStream peekFor: Character lf ]. lineLength := 0 ] ifFalse: [ charValue > 255 ifTrue: [ self error: 'Character out of range' ]. mimeStream nextPut: $=. char asInteger printOn: mimeStream base: 16 length: 2 padded: true. lineLength := lineLength + 3 ] ] ]! ! !QuotedPrintableMimeConverter methodsFor: 'initialize' stamp: 'SvenVanCaekenberghe 12/8/2013 23:33'! newline: string "Set another newline convention, like CRLF or LF that I should use. By default I use CR." newline := string! ! !QuotedPrintableMimeConverter methodsFor: 'conversion' stamp: 'SvenVanCaekenberghe 12/8/2013 23:26'! mimeDecode | char outChar previousChar | previousChar := nil. [ mimeStream atEnd ] whileFalse: [ char := mimeStream next. outChar := (char = $= ifTrue: [ ((char := mimeStream next) = Character cr) | (char = Character lf) ifTrue: [ char = Character cr ifTrue: [ mimeStream peekFor: Character lf ]. nil ] ifFalse: [ Character codePoint: char digitValue * 16 + mimeStream next digitValue ] ] ifFalse: [ char ]). outChar notNil ifTrue: [ (outChar = Character lf) & (previousChar = Character cr) ifTrue: [ dataStream nextPutAll: newline ] ifFalse: [ (outChar = Character cr) | (outChar = Character lf) ifFalse: [ dataStream nextPut: outChar ] ]. previousChar := outChar ] ]! ! !QuotedPrintableMimeConverterTest commentStamp: 'TorstenBergmann 2/5/2014 10:12'! SUnit tests for QuotedPrintableMimeConverter! !QuotedPrintableMimeConverterTest methodsFor: 'accesing' stamp: 'SvenVanCaekenberghe 12/8/2013 23:10'! decode: string ^ coder mimeDecode: string as: String! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:04'! testDecodeDecodedStrings self assert: (self decode: 'Hätten Hüte ein ß im Namen, wären sie möglicherweise keine Hüte mehr') equals: 'Hätten Hüte ein ß im Namen, wären sie möglicherweise keine Hüte mehr'! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:04'! testDecodeSoftLinebreakCRLF self assert: (self decode: 'This is text may not be=', String crlf, ' decoded as two lines') equals: 'This is text may not be decoded as two lines'! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 23:37'! testDecodeCustomNewline | decoder output | decoder := coder new. output := String new writeStream. decoder newline: String lf; mimeStream: 'foo=0D=0Abar' readStream; dataStream: output; mimeDecode. self assert: output contents equals: 'foo', String lf, 'bar' ! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:05'! testEncodeLF self assert: (self encode: 'This is the first line', String lf, 'and this is the second') equals: 'This is the first line=0D=0Aand this is the second'! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:05'! testEncodeCR self assert: (self encode: 'This is the first line', String cr, 'and this is the second') equals: 'This is the first line=0D=0Aand this is the second'! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:05'! testEncodeSimpleStrings self assert: (self encode: 'Zürich') equals: 'Z=FCrich'. self assert: (self encode: 'Über die Fährverbindungen nach Föhr wüßte ich nicht viel') equals: '=DCber die F=E4hrverbindungen nach F=F6hr w=FC=DFte ich nicht viel'! ! !QuotedPrintableMimeConverterTest methodsFor: 'running' stamp: 'SvenVanCaekenberghe 12/8/2013 23:09'! setUp coder := QuotedPrintableMimeConverter! ! !QuotedPrintableMimeConverterTest methodsFor: 'accesing' stamp: 'SvenVanCaekenberghe 12/8/2013 23:10'! encode: string ^ coder mimeEncode: string! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:04'! testDecodeSoftLinebreakCR self assert: (self decode: 'This is text may not be=', String cr, ' decoded as two lines') equals: 'This is text may not be decoded as two lines'! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:05'! testEncodeEncodedStrings "An = becomes =3D and is then not decodable any more (only if you know you have to do it twice ;-) )" self assert: (self encode: 'Z=FCrich') equals: 'Z=3DFCrich'! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:04'! testDecodeSimpleStrings self assert: (self decode: 'Z=FCrich') equals: 'Zürich'. self assert: (self decode: 'H=E4tten H=FCte ein =DF im Namen, w=E4ren sie m=F6glicherweise keine H=FCte mehr') equals: 'Hätten Hüte ein ß im Namen, wären sie möglicherweise keine Hüte mehr'! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:05'! testEncodeSoftLinebreak | original encoded | original := 'Cowards die many times before their deaths; The valiant never taste of death but once. Of all the wonders that I yet have heard, it seems to me most strange that men should fear; Seeing that death, a necessary end, will come when it will come'. encoded := 'Cowards die many times before their deaths; The valiant never taste of dea= th but once.=0D=0AOf all the wonders that I yet have heard, it seems to me most strange that= men should fear;=0D=0ASeeing that death, a necessary end, will come when it will come'. self assert: (self encode: original) equals: encoded. self assert: (self decode: encoded) equals: original! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:04'! testDecodeCRLF self assert: (self decode: 'This is the first line=0D=0A and this is the second') equals: 'This is the first line and this is the second'! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:04'! testDecodeSoftLinebreak self assert: (self decode: 'This is text may not be= decoded as two lines') equals: 'This is text may not be decoded as two lines'! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:05'! testLongLine | input output | input := (String new: 74 withAll: $A), (String new: 47 withAll: $B). output := (String new: 74 withAll: $A), '= ', (String new: 47 withAll: $B). self assert: (self encode: input) equals: output! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:05'! testEncodeCRLF self assert: (self encode: 'This is the first line', String crlf, 'and this is the second') equals: 'This is the first line=0D=0Aand this is the second'! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 23:18'! testEncodeLongLine | input output | input := (String new: 74 withAll: $A), (String new: 47 withAll: $B). output := (String new: 74 withAll: $A), '= ', (String new: 47 withAll: $B). self assert: (self encode: input) equals: output! ! !QuotedPrintableMimeConverterTest methodsFor: 'testing' stamp: 'SvenVanCaekenberghe 12/8/2013 19:04'! testDecodeSoftLinebreakLF self assert: (self decode: 'This is text may not be=', String lf, ' decoded as two lines') equals: 'This is text may not be decoded as two lines'! ! !RBAbstractClass methodsFor: 'accessing' stamp: 'lr 2/3/2008 13:33'! subclasses ^subclasses isNil ifTrue: [subclasses := self isDefined ifTrue: [((self realClass subclasses collect: [:each | model classFor: each]) reject: [ :each | each isNil ]) asOrderedCollection] ifFalse: [OrderedCollection new]] ifFalse: [subclasses]! ! !RBAbstractClass methodsFor: 'method accessing' stamp: ''! allSelectors | class selectors | class := self. selectors := Set new. [class notNil] whileTrue: [selectors addAll: class selectors. class := class superclass]. ^selectors! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! directlyDefinesMethod: aSelector self isDefined ifTrue: [(self hasRemoved: aSelector) ifTrue: [^false]. (self realClass includesSelector: aSelector) ifTrue: [^true]]. ^newMethods notNil and: [newMethods includesKey: aSelector]! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'lr 1/18/2010 19:40'! existingMethodsThatReferToInstanceVariable: aString | existingMethods | existingMethods := self realClass whichSelectorsAccess: aString. (newMethods isNil and: [ removedMethods isNil ]) ifTrue: [ ^ existingMethods ]. ^ existingMethods reject: [ :each | (self hasRemoved: each) or: [ self newMethods includesKey: each ] ]! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! hierarchyDefinesInstanceVariable: aString (self definesInstanceVariable: aString) ifTrue: [^true]. ^(self allSubclasses detect: [:each | each directlyDefinesInstanceVariable: aString] ifNone: [nil]) notNil! ! !RBAbstractClass methodsFor: 'accessing' stamp: 'lr 10/26/2009 22:08'! soleInstance ^ self theNonMetaClass! ! !RBAbstractClass methodsFor: 'variable accessing' stamp: ''! whoDefinesClassVariable: aString | sprClass | (self directlyDefinesClassVariable: aString) ifTrue: [^self]. sprClass := self superclass. ^sprClass isNil ifTrue: [nil] ifFalse: [sprClass whoDefinesClassVariable: aString]! ! !RBAbstractClass methodsFor: 'method accessing' stamp: ''! whoDefinesMethod: aSelector | sprClass | (self directlyDefinesMethod: aSelector) ifTrue: [^self]. sprClass := self superclass. ^sprClass isNil ifTrue: [nil] ifFalse: [sprClass whoDefinesMethod: aSelector]! ! !RBAbstractClass methodsFor: 'initialization' stamp: ''! initialize name := #'Unknown Class'! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! instanceVariableNames ^self privateInstanceVariableNames copy! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'lr 3/17/2010 18:42'! whichSelectorsReferToSymbol: aSymbol | selectors | selectors := Set new. newMethods isNil ifFalse: [ newMethods do: [ :each | (each refersToSymbol: aSymbol) ifTrue: [ selectors add: each selector ] ] ]. self isDefined ifTrue: [ selectors addAll: (self existingMethodsThatReferTo: aSymbol) ]. ^ selectors! ! !RBAbstractClass methodsFor: 'accessing' stamp: 'lr 10/26/2009 22:08'! theNonMetaClass ^ model classNamed: self name! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'lr 11/1/2009 23:47'! compile: aString ^ self compile: aString withAttributesFrom: (self methodFor: (RBParser parseMethodPattern: aString))! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! withAllSubclasses ^(self allSubclasses) add: self; yourself! ! !RBAbstractClass methodsFor: 'method accessing' stamp: ''! sourceCodeFor: aSelector | class | class := self whoDefinesMethod: aSelector. class isNil ifTrue: [^nil]. ^(class methodFor: aSelector) source! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'md 1/17/2006 14:17'! bindingOf: aString ^self realClass classPool associationAt: aString asSymbol ifAbsent: [self realClass classPool associationAt: aString asString ifAbsent: [nil]]! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'lr 11/1/2009 23:47'! compile: aString classified: aSymbolCollection | change method | change := model compile: aString in: self classified: aSymbolCollection. method := RBMethod for: self source: aString selector: change selector. self addMethod: method. ^ change! ! !RBAbstractClass methodsFor: 'method accessing' stamp: ''! methodFor: aSelector ^self newMethods at: aSelector ifAbsent: [| compiledMethod class | (self hasRemoved: aSelector) ifTrue: [^nil]. class := self realClass. class isNil ifTrue: [^nil]. compiledMethod := class compiledMethodAt: aSelector ifAbsent: [nil]. compiledMethod isNil ifTrue: [nil] ifFalse: [RBMethod for: self fromMethod: compiledMethod andSelector: aSelector]]! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! definesInstanceVariable: aString (self directlyDefinesInstanceVariable: aString) ifTrue: [^true]. ^self superclass notNil and: [self superclass definesInstanceVariable: aString]! ! !RBAbstractClass methodsFor: 'method accessing' stamp: ''! parseTreeFor: aSelector | class | class := self whoDefinesMethod: aSelector. class isNil ifTrue: [^nil]. ^(class methodFor: aSelector) parseTree! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! includesClass: aRBClass | currentClass | currentClass := self. [currentClass notNil and: [currentClass ~= aRBClass]] whileTrue: [currentClass := currentClass superclass]. ^currentClass = aRBClass! ! !RBAbstractClass methodsFor: 'private' stamp: ''! addSubclass: aRBClass self subclasses add: aRBClass! ! !RBAbstractClass methodsFor: 'method accessing' stamp: ''! removeMethod: aSelector self newMethods removeKey: aSelector ifAbsent: []. model removeMethod: aSelector from: self. self removedMethods add: aSelector! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! definesPoolDictionary: aSymbol (self directlyDefinesPoolDictionary: aSymbol) ifTrue: [^true]. ^self inheritsPoolDictionaries and: [self superclass notNil and: [self superclass definesPoolDictionary: aSymbol]]! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'lr 3/17/2010 18:43'! whichSelectorsReferToClass: aRBClass | selectors | selectors := Set new. newMethods isNil ifFalse: [ newMethods do: [ :each | (each refersToClassNamed: aRBClass name) ifTrue: [ selectors add: each selector ] ] ]. (self isDefined and: [ aRBClass isDefined ]) ifTrue: [ selectors addAll: (self existingMethodsThatReferTo: aRBClass classBinding). selectors addAll: (self existingMethodsThatReferTo: aRBClass name) ]. ^ selectors! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'cwp 5/10/2010 23:49'! existingMethodsThatReferTo: aSymbol | existingMethods special byte | special := Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [ :value | byte := value ]. existingMethods := self realClass thoroughWhichSelectorsReferTo: aSymbol special: special byte: byte. (newMethods isNil and: [ removedMethods isNil ]) ifTrue: [ ^ existingMethods ]. ^ existingMethods reject: [ :each | (self hasRemoved: each) or: [ self newMethods includesKey: each ] ]! ! !RBAbstractClass methodsFor: 'variable accessing' stamp: ''! whoDefinesInstanceVariable: aString | sprClass | (self directlyDefinesInstanceVariable: aString) ifTrue: [^self]. sprClass := self superclass. ^sprClass isNil ifTrue: [nil] ifFalse: [sprClass whoDefinesInstanceVariable: aString]! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! allSuperclasses | supers sprClass | supers := OrderedCollection new. sprClass := self superclass. [sprClass notNil] whileTrue: [supers add: sprClass. sprClass := sprClass superclass]. ^supers! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! isDefined ^self realClass notNil! ! !RBAbstractClass methodsFor: 'testing' stamp: 'SebastianTleye 8/1/2013 16:11'! directlyDefinesLocalMethod: aSelector self isDefined ifTrue: [(self hasRemoved: aSelector) ifTrue: [^false]. (self realClass includesLocalSelector: aSelector) ifTrue: [^true]]. ^newMethods notNil and: [newMethods includesKey: aSelector]! ! !RBAbstractClass methodsFor: 'private' stamp: ''! privateInstanceVariableNames instanceVariableNames isNil ifTrue: [self isDefined ifTrue: [self instanceVariableNames: self realClass instVarNames] ifFalse: [instanceVariableNames := OrderedCollection new]]. ^instanceVariableNames! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! name: aSymbol name := aSymbol! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'lr 11/1/2009 23:16'! compile: aString withAttributesFrom: aRBMethod | change method | change := model compile: aString in: self classified: aRBMethod protocols. method := RBMethod for: self source: aString selector: change selector. self addMethod: method. ^ change! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! hierarchyDefinesPoolDictionary: aString (self definesPoolDictionary: aString) ifTrue: [^true]. ^(self allSubclasses detect: [:each | each directlyDefinesPoolDictionary: aString] ifNone: [nil]) notNil! ! !RBAbstractClass methodsFor: 'private' stamp: ''! superclass: aRBClass self superclass notNil ifTrue: [self superclass removeSubclass: self]. superclass := aRBClass. superclass notNil ifTrue: [superclass addSubclass: self].! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! definesMethod: aSelector (self directlyDefinesMethod: aSelector) ifTrue: [^true]. ^self superclass notNil and: [self superclass definesMethod: aSelector]! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! hierarchyDefinesMethod: aSelector (self definesMethod: aSelector) ifTrue: [^true]. ^self subclassRedefines: aSelector! ! !RBAbstractClass methodsFor: 'enumerating' stamp: 'MarcusDenker 9/18/2012 14:12'! allSubclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's subclasses." self subclassesDo: [:cl | aBlock value: cl. cl allSubclassesDo: aBlock]! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'lr 3/17/2010 18:42'! whichSelectorsReferToInstanceVariable: aString | selectors | selectors := Set new. newMethods isNil ifFalse: [ newMethods do: [ :each | (each refersToVariable: aString) ifTrue: [ selectors add: each selector ] ] ]. self isDefined ifTrue: [ selectors addAll: (self existingMethodsThatReferToInstanceVariable: aString) ]. ^ selectors! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! name ^name! ! !RBAbstractClass methodsFor: 'initialize-release' stamp: ''! model: aRBSmalltalk model := aRBSmalltalk! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! hasRemoved: aSelector ^removedMethods notNil and: [removedMethods includes: aSelector]! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! newMethods ^newMethods isNil ifTrue: [newMethods := IdentityDictionary new] ifFalse: [newMethods]! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! removeSubclass: aRBClass self subclasses remove: aRBClass ifAbsent: []! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'lr 9/8/2011 20:25'! protocolsFor: aSelector | change | change := self isMeta ifTrue: [model changes changeForMetaclass: name selector: aSelector] ifFalse: [model changes changeForClass: name selector: aSelector]. ^change isNil ifTrue: [self isDefined ifTrue: [Array with: (RBBrowserEnvironment new whichProtocolIncludes: aSelector in: self realClass)] ifFalse: [#(#accessing)]] ifFalse: [change protocols]! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! directlyDefinesVariable: aVariableName ^(self directlyDefinesClassVariable: aVariableName) or: [self directlyDefinesInstanceVariable: aVariableName]! ! !RBAbstractClass methodsFor: 'variable accessing' stamp: ''! renameInstanceVariable: oldName to: newName around: aBlock self privateInstanceVariableNames at: (self privateInstanceVariableNames indexOf: oldName asString) put: newName asString. model renameInstanceVariable: oldName to: newName in: self around: aBlock! ! !RBAbstractClass methodsFor: 'testing' stamp: 'MarcusDenker 4/24/2013 10:51'! canUnderstand: aSelector ^self definesMethod: aSelector! ! !RBAbstractClass methodsFor: 'method accessing' stamp: ''! addMethod: aRBMethod self newMethods at: aRBMethod selector put: aRBMethod. removedMethods notNil ifTrue: [removedMethods remove: aRBMethod selector ifAbsent: []]! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'lr 11/1/2009 23:48'! compileTree: aRBMethodNode ^ (self methodFor: aRBMethodNode selector) compileTree: aRBMethodNode! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'lr 1/18/2010 19:39'! existingMethodsThatReferToClassVariable: aString | binding existingMethods | binding := (self bindingOf: aString) ifNil: [ ^ #() ]. existingMethods := self realClass whichSelectorsReferTo: binding. (newMethods isNil and: [ removedMethods isNil ]) ifTrue: [ ^ existingMethods ]. ^ existingMethods reject: [ :each | (self hasRemoved: each) or: [ self newMethods includesKey: each ] ]! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! instanceVariableNames: aCollectionOfStrings instanceVariableNames := aCollectionOfStrings asOrderedCollection! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! hierarchyDefinesClassVariable: aString (self definesClassVariable: aString) ifTrue: [^true]. ^(self allSubclasses detect: [:each | each directlyDefinesClassVariable: aString] ifNone: [nil]) notNil! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! hierarchyDefinesVariable: aString (self definesVariable: aString) ifTrue: [^true]. ^(self allSubclasses detect: [:each | each directlyDefinesVariable: aString] ifNone: [nil]) notNil! ! !RBAbstractClass methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: self name! ! !RBAbstractClass methodsFor: 'accessing' stamp: 'lr 10/26/2009 22:09'! theMetaClass ^ model metaclassNamed: self name! ! !RBAbstractClass methodsFor: 'testing' stamp: 'lr 1/3/2010 11:47'! subclassRedefines: aSelector "Return true, if one of your subclasses redefines the method with name, aMethod" ^ self allSubclasses anySatisfy: [ :each | each directlyDefinesMethod: aSelector ]! ! !RBAbstractClass methodsFor: 'variable accessing' stamp: ''! typeOfClassVariable: aSymbol ^model classNamed: #Object! ! !RBAbstractClass methodsFor: 'variable accessing' stamp: ''! removeInstanceVariable: aString self privateInstanceVariableNames remove: aString. model removeInstanceVariable: aString from: self! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! directlyDefinesClassVariable: aString self subclassResponsibility! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! definesVariable: aVariableName ^(self definesClassVariable: aVariableName) or: [self definesInstanceVariable: aVariableName]! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! allSubclasses | allSubclasses index | index := 1. allSubclasses := self subclasses asOrderedCollection. [index <= allSubclasses size] whileTrue: [allSubclasses addAll: (allSubclasses at: index) subclasses. index := index + 1]. ^allSubclasses! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! withAllSuperclasses ^(self allSuperclasses) add: self; yourself! ! !RBAbstractClass methodsFor: 'enumerating' stamp: 'MarcusDenker 9/18/2012 14:12'! subclassesDo: aBlock self subclasses do: aBlock! ! !RBAbstractClass methodsFor: 'comparing' stamp: ''! hash ^self name hash bitXor: self class hash! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! allClassVariableNames ^self subclassResponsibility! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! allPoolDictionaryNames ^self subclassResponsibility! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! isAbstract (self whichSelectorsReferToSymbol: #subclassResponsibility) isEmpty ifFalse: [^true]. model allReferencesToClass: self do: [:each | ^false]. ^true! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! isMeta self subclassResponsibility! ! !RBAbstractClass methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPutAll: self name! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! allInstanceVariableNames | sprClass | sprClass := self superclass. ^sprClass isNil ifTrue: [self instanceVariableNames] ifFalse: [sprClass allInstanceVariableNames , self instanceVariableNames]! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! realClass ^realClass! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! removedMethods ^removedMethods isNil ifTrue: [removedMethods := Set new] ifFalse: [removedMethods]! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! model ^model! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! realClass: aClass realClass := aClass. superclass isNil ifTrue: [superclass := LookupSuperclass]! ! !RBAbstractClass methodsFor: 'comparing' stamp: ''! = aRBClass ^self class = aRBClass class and: [self name = aRBClass name and: [self model = aRBClass model]]! ! !RBAbstractClass methodsFor: 'variable accessing' stamp: ''! addInstanceVariable: aString self privateInstanceVariableNames add: aString. model addInstanceVariable: aString to: self! ! !RBAbstractClass methodsFor: 'accessing' stamp: 'lr 7/23/2010 08:02'! classBinding ^ Smalltalk globals associationAt: self name! ! !RBAbstractClass methodsFor: 'testing' stamp: 'dc 5/18/2007 14:53'! definesClassVariable: aSymbol self realClass isTrait ifTrue: [^false]. (self directlyDefinesClassVariable: aSymbol) ifTrue: [^true]. ^self superclass notNil and: [self superclass definesClassVariable: aSymbol]! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! inheritsPoolDictionaries ^false! ! !RBAbstractClass methodsFor: 'accessing' stamp: ''! superclass ^superclass == LookupSuperclass ifTrue: [model classFor: self realClass superclass] ifFalse: [superclass]! ! !RBAbstractClass methodsFor: 'method accessing' stamp: ''! selectors | selectors | selectors := Set new. selectors addAll: self newMethods keys. self isDefined ifTrue: [selectors addAll: self realClass selectors. removedMethods notNil ifTrue: [removedMethods do: [:each | selectors remove: each ifAbsent: []]]]. ^selectors! ! !RBAbstractClass methodsFor: 'method accessing' stamp: 'lr 3/17/2010 18:42'! whichSelectorsReferToClassVariable: aString | selectors | selectors := Set new. newMethods isNil ifFalse: [ newMethods do: [ :each | (each refersToVariable: aString) ifTrue: [ selectors add: each selector ] ] ]. self isDefined ifTrue: [ selectors addAll: (self existingMethodsThatReferToClassVariable: aString) ]. ^ selectors! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! directlyDefinesPoolDictionary: aString self subclassResponsibility! ! !RBAbstractClass methodsFor: 'testing' stamp: ''! directlyDefinesInstanceVariable: aString ^self instanceVariableNames includes: aString! ! !RBAbstractClass class methodsFor: 'class initialization' stamp: ''! initialize LookupSuperclass := Object new! ! !RBAbstractClassRule commentStamp: ''! See my #rationale.! !RBAbstractClassRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBAbstractClassRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 00:34'! initialize super initialize. subclassResponsibilitySymbol := 'subclassResponsibility' asSymbol! ! !RBAbstractClassRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 11:22'! category ^ 'Potential Bugs'! ! !RBAbstractClassRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for references to classes that have subclassResponsibility methods. Such references might be creating instances of the abstract class or more commonly being used as the argument to an isKindOf: message which is considered bad style.'! ! !RBAbstractClassRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBAbstractClassRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'References an abstract class'! ! !RBAbstractClassRule methodsFor: 'running' stamp: 'lr 7/23/2010 08:03'! checkClass: aContext (aContext selectedClass whichSelectorsReferTo: subclassResponsibilitySymbol) isEmpty ifFalse: [ (aContext uses: (Smalltalk globals associationAt: aContext selectedClass name ifAbsent: [ nil ])) ifTrue: [ result addClass: aContext selectedClass ] ]! ! !RBAbstractClassRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'AbstractClassRule'! ! !RBAbstractClassVariableRefactoring methodsFor: 'private-accessing' stamp: 'lr 9/8/2011 20:11'! accessorsRefactoring ^accessorsRefactoring isNil ifTrue: [accessorsRefactoring := RBCreateAccessorsForVariableRefactoring model: self model variable: variableName asString class: class classVariable: true] ifFalse: [accessorsRefactoring]! ! !RBAbstractClassVariableRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! abstractClassReferences | replacer | replacer := RBParseTreeRewriter variable: variableName getter: self accessorsRefactoring getterMethod setter: self accessorsRefactoring setterMethod. self convertClasses: class theMetaClass withAllSubclasses select: [ :aClass | (aClass whichSelectorsReferToClassVariable: variableName) reject: [ :each | aClass == class theMetaClass and: [ each == self accessorsRefactoring getterMethod or: [ each == self accessorsRefactoring setterMethod ] ] ] ] using: replacer! ! !RBAbstractClassVariableRefactoring methodsFor: 'transforming' stamp: ''! transform self createAccessors. self abstractInstanceReferences. self abstractClassReferences! ! !RBAbstractClassVariableRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition isMetaclass: class) not & (RBCondition directlyDefinesClassVariable: variableName asSymbol in: class) & ((RBCondition withBlock: [(#(#Object #Behavior #ClassDescription #Class) includes: class name) not]) errorMacro: 'This refactoring does not work for Object, Behavior, ClassDescription, or Class')! ! !RBAbstractClassVariableRefactoring methodsFor: 'transforming' stamp: ''! createAccessors self performComponentRefactoring: self accessorsRefactoring! ! !RBAbstractClassVariableRefactoring methodsFor: 'transforming' stamp: 'TestRunner 11/3/2009 09:40'! abstractInstanceReferences | replacer | replacer := RBParseTreeRewriter variable: variableName getter: 'class ' , self accessorsRefactoring getterMethod setter: 'class ' , self accessorsRefactoring setterMethod. self convertClasses: class withAllSubclasses select: [ :aClass | aClass whichSelectorsReferToClassVariable: variableName ] using: replacer! ! !RBAbstractClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMetaClassFailure self shouldFail: (RBAbstractClassVariableRefactoring variable: #RecursiveSelfRule class: RBTransformationRuleTest class)! ! !RBAbstractClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelAbstractClassVariableOverridenMethodsInSubclass | refactoring meta class | class := model classNamed: #Foo. meta := class theMetaClass. refactoring := RBAbstractClassVariableRefactoring model: model variable: 'ClassVarName2' class: class. self executeRefactoring: refactoring. self assert: (meta parseTreeFor: #classVarName21) = (RBParser parseMethod: 'classVarName21 ^ClassVarName2'). self assert: (meta parseTreeFor: #classVarName21:) = (RBParser parseMethod: 'classVarName21: anObject ClassVarName2 := anObject')! ! !RBAbstractClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelAbstractClassVariable | refactoring meta class | class := model classNamed: #Foo. meta := class theMetaClass. refactoring := RBAbstractClassVariableRefactoring model: model variable: 'ClassVarName1' class: class. self executeRefactoring: refactoring. self assert: (meta parseTreeFor: #classVarName1) = (RBParser parseMethod: 'classVarName1 ^ClassVarName1'). self assert: (meta parseTreeFor: #classVarName1:) = (RBParser parseMethod: 'classVarName1: anObject ^ClassVarName1 := anObject'). self assert: (meta parseTreeFor: #foo) = (RBParser parseMethod: 'foo ^self classVarName1: self classVarName1 * self classVarName1 * self classVarName1'). self assert: (class parseTreeFor: #classVarName1) = (RBParser parseMethod: 'classVarName1 ^self class classVarName1'). self assert: (class parseTreeFor: #classVarName1:) = (RBParser parseMethod: 'classVarName1: anObject ^self class classVarName1: anObject'). self assert: (class parseTreeFor: #asdf) = (RBParser parseMethod: 'asdf ^self classVarName1: (self class classVarName1: self class classVarName1 + 1)'). self assert: ((model classNamed: #Bar) parseTreeFor: #foo) = (RBParser parseMethod: 'foo instVarName1 := instVarName1 + instVarName2 + self class classVarName1'). self assert: ((model classNamed: #Bar) parseTreeFor: #foo) = (RBParser parseMethod: 'foo instVarName1 := instVarName1 + instVarName2 + self class classVarName1')! ! !RBAbstractClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testInheritedName self shouldFail: (RBAbstractClassVariableRefactoring variable: #DependentsFields class: RBBasicLintRuleTest)! ! !RBAbstractClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAbstractClassVariable | refactoring meta class | refactoring := RBAbstractClassVariableRefactoring variable: 'RecursiveSelfRule' class: RBTransformationRuleTest. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBTransformationRuleTest. meta := class theMetaClass. self assert: (meta parseTreeFor: #recursiveSelfRule) = (RBParser parseMethod: 'recursiveSelfRule ^RecursiveSelfRule'). self assert: (meta parseTreeFor: #recursiveSelfRule:) = (RBParser parseMethod: 'recursiveSelfRule: anObject RecursiveSelfRule := anObject'). self assert: (meta parseTreeFor: #nuke) = (RBParser parseMethod: 'nuke self recursiveSelfRule: nil'). self assert: (meta parseTreeFor: #initializeAfterLoad1) = (RBParser parseMethod: 'initializeAfterLoad1 self recursiveSelfRule: RBParseTreeSearcher new. self recursiveSelfRule addMethodSearches: #(''`@methodName: `@args | `@temps | self `@methodName: `@args'' ''`@methodName: `@args | `@temps | ^self `@methodName: `@args'') -> [:aNode :answer | true]'). self assert: (class parseTreeFor: #checkMethod:) = (RBParser parseMethod: 'checkMethod: aSmalllintContext class := aSmalllintContext selectedClass. (rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: [(self class recursiveSelfRule executeTree: rewriteRule tree initialAnswer: false) ifFalse: [builder compile: rewriteRule tree printString in: class classified: aSmalllintContext protocols]]')! ! !RBAbstractClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBAbstractClassVariableRefactoring variable: #Foo class: RBBasicLintRuleTest)! ! !RBAbstractClassVariableTest methodsFor: 'set up' stamp: 'CamilloBruni 8/27/2013 15:05'! setUp super setUp. model := self abstractVariableTestData.! ! !RBAbstractCondition methodsFor: 'private' stamp: ''! errorStringFor: aBoolean ^self errorMacro expandMacrosWith: aBoolean! ! !RBAbstractCondition methodsFor: 'logical operations' stamp: ''! | aCondition "(A | B) = (A not & B not) not" ^(self not & aCondition not) not! ! !RBAbstractCondition methodsFor: 'accessing' stamp: ''! errorString ^self errorStringFor: false! ! !RBAbstractCondition methodsFor: 'private' stamp: ''! errorMacro: aString errorMacro := aString! ! !RBAbstractCondition methodsFor: 'checking' stamp: ''! check self subclassResponsibility! ! !RBAbstractCondition methodsFor: 'logical operations' stamp: ''! & aCondition ^RBConjunctiveCondition new left: self right: aCondition! ! !RBAbstractCondition methodsFor: 'accessing' stamp: ''! errorBlock ^self errorBlockFor: false! ! !RBAbstractCondition methodsFor: 'logical operations' stamp: ''! not ^RBNegationCondition on: self! ! !RBAbstractCondition methodsFor: 'private' stamp: ''! errorBlockFor: aBoolean ^nil! ! !RBAbstractCondition methodsFor: 'private' stamp: ''! errorMacro ^errorMacro isNil ifTrue: ['unknown'] ifFalse: [errorMacro]! ! !RBAbstractInstanceVariableRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! abstractReferences | replacer | replacer := RBParseTreeRewriter variable: variableName getter: self accessorsRefactoring getterMethod setter: self accessorsRefactoring setterMethod. self convertClasses: class withAllSubclasses select: [:aClass | (aClass whichSelectorsReferToInstanceVariable: variableName) reject: [:each | aClass == class and: [each == self accessorsRefactoring getterMethod or: [each == self accessorsRefactoring setterMethod]]]] using: replacer! ! !RBAbstractInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''! transform self createAccessors. self abstractReferences! ! !RBAbstractInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^RBCondition directlyDefinesInstanceVariable: variableName in: class! ! !RBAbstractInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''! createAccessors self performComponentRefactoring: self accessorsRefactoring! ! !RBAbstractInstanceVariableRefactoring methodsFor: 'private-accessing' stamp: 'lr 9/8/2011 20:11'! accessorsRefactoring ^accessorsRefactoring isNil ifTrue: [accessorsRefactoring := RBCreateAccessorsForVariableRefactoring model: self model variable: variableName class: class classVariable: false] ifFalse: [accessorsRefactoring]! ! !RBAbstractInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAbstractWithDefaultNamesUsed | refactoring class | class := model classNamed: #Foo. refactoring := RBAbstractInstanceVariableRefactoring model: model variable: 'instVarName1' class: class. self executeRefactoring: refactoring. self assert: (class parseTreeFor: #bar) = (RBParser parseMethod: 'bar "Add one to instVarName1" self instVarName11: self instVarName11 + 1'). self assert: (class parseTreeFor: #instVarName11:) = (RBParser parseMethod: 'instVarName11: anObject instVarName1 := anObject'). self assert: (class parseTreeFor: #instVarName11) = (RBParser parseMethod: 'instVarName11 ^instVarName1'). self assert: ((model classNamed: #Bar) parseTreeFor: #foo) = (RBParser parseMethod: 'foo self instVarName11: self instVarName11 + instVarName2 + ClassVarName1')! ! !RBAbstractInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAbstractWithAssignmentUsed | refactoring class | class := model classNamed: #Foo. refactoring := RBAbstractInstanceVariableRefactoring model: model variable: 'instVarName2' class: class. self executeRefactoring: refactoring. self assert: (class parseTreeFor: #foo) = (RBParser parseMethod: 'foo ^self instVarName21: 3'). self assert: (class parseTreeFor: #instVarName2:) = (RBParser parseMethod: 'instVarName2: anObject self instVarName21: anObject'). self assert: (class parseTreeFor: #instVarName21:) = (RBParser parseMethod: 'instVarName21: anObject ^instVarName2 := anObject'). self assert: (class parseTreeFor: #instVarName2) = (RBParser parseMethod: 'instVarName2 ^instVarName2'). self assert: ((model classNamed: #Bar) parseTreeFor: #foo) = (RBParser parseMethod: 'foo instVarName1 := instVarName1 + self instVarName2 + ClassVarName1')! ! !RBAbstractInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testInheritedName self shouldFail: (RBAbstractInstanceVariableRefactoring variable: 'name' class: RBBasicLintRuleTest)! ! !RBAbstractInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAbstractInstanceVariable | refactoring class | refactoring := RBAbstractInstanceVariableRefactoring variable: 'class' class: RBTransformationRuleTest. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBTransformationRuleTest. self assert: (class parseTreeFor: #class1) = (RBParser parseMethod: 'class1 ^class'). self assert: (class parseTreeFor: #class:) = (RBParser parseMethod: 'class: anObject class := anObject'). self assert: (class parseTreeFor: #superSends) = (RBParser parseMethod: 'superSends | rule | rule := RBParseTreeRewriter new. rule addSearch: ''super `@message: ``@args'' -> ( [:aNode | (self class1 withAllSubclasses detect: [:each | each includesSelector: aNode selector] ifNone: [nil]) isNil] -> ''self `@message: ``@args''). self rewriteUsing: rule'). self assert: (class parseTreeFor: #checkMethod:) = (RBParser parseMethod: 'checkMethod: aSmalllintContext self class: aSmalllintContext selectedClass. (rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: [(RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false) ifFalse: [builder compile: rewriteRule tree printString in: self class1 classified: aSmalllintContext protocols]]')! ! !RBAbstractInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBAbstractInstanceVariableRefactoring variable: 'foo' class: RBBasicLintRuleTest)! ! !RBAbstractInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testMetaclassInstanceVariables | refactoring class | class := model metaclassNamed: #Foo. class addInstanceVariable: 'foo'. class compile: 'zzz ^foo := foo + foo * 2' classified: #(#testing). refactoring := RBAbstractInstanceVariableRefactoring model: model variable: 'foo' class: class. self executeRefactoring: refactoring. self assert: (class parseTreeFor: #foo1) = (RBParser parseMethod: 'foo1 ^foo'). self assert: (class parseTreeFor: #foo:) = (RBParser parseMethod: 'foo: anObject ^foo := anObject'). self assert: (class parseTreeFor: #zzz) = (RBParser parseMethod: 'zzz ^self foo: self foo1 + self foo1 * 2')! ! !RBAbstractInstanceVariableTest methodsFor: 'set up' stamp: 'CamilloBruni 8/27/2013 15:05'! setUp super setUp. model := self abstractVariableTestData.! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: 'lr 10/26/2009 22:08'! classVariableNames | nonMetaClass | nonMetaClass := fromClass theNonMetaClass. ^ (nonMetaClass allClassVariableNames collect: [ :each | each asString ]) asSet! ! !RBAbstractVariablesRefactoring methodsFor: 'accessing' stamp: ''! parseTree ^tree! ! !RBAbstractVariablesRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^RBCondition empty! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''! transform self hasVariablesToAbstract ifTrue: [self refactoringWarning: 'This method has direct variable references whichwill need to be converted to getter/setters.' expandMacros]. self abstractInstanceVariables. self abstractClassVariables! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! abstractInstanceVariable: aString | refactoring rewriter | refactoring := RBCreateAccessorsForVariableRefactoring model: self model variable: aString class: fromClass classVariable: false. self performComponentRefactoring: refactoring. rewriter := RBParseTreeRewriter new. rewriter replace: aString , ' := ``@object' with: ('self <1s> ``@object' expandMacrosWith: refactoring setterMethod); replace: aString with: 'self ' , refactoring getterMethod. (rewriter executeTree: tree) ifTrue: [tree := rewriter tree]! ! !RBAbstractVariablesRefactoring methodsFor: 'testing' stamp: 'lr 2/6/2010 13:34'! hasVariablesToAbstract ^ instVarReaders notEmpty or: [ instVarWriters notEmpty or: [ classVarReaders notEmpty or: [ classVarWriters notEmpty ] ] ]! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! computeVariablesToAbstract | searcher | instVarReaders := Set new. instVarWriters := Set new. classVarReaders := Set new. classVarWriters := Set new. searcher := RBParseTreeSearcher new. searcher matches: '`var := ``@anything' do: [:aNode :answer | self processAssignmentNode: aNode]; matches: '`var' do: [:aNode :answer | self processReferenceNode: aNode]. searcher executeTree: tree. self removeDefinedClassVariables! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''! instanceVariableNames ^fromClass allInstanceVariableNames asSet! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''! processAssignmentNode: aNode | varName | varName := aNode variable name. ignore = varName ifTrue: [^self]. (aNode whoDefines: varName) notNil ifTrue: [^self]. (self instanceVariableNames includes: varName) ifTrue: [instVarWriters add: varName]. (self classVariableNames includes: varName) ifTrue: [classVarWriters add: varName]! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: 'lr 2/6/2010 13:34'! abstractInstanceVariables | variables | (instVarReaders isEmpty and: [ instVarWriters isEmpty ]) ifTrue: [ ^ self]. variables := Set new. variables addAll: instVarReaders; addAll: instVarWriters. variables do: [ :each | self abstractInstanceVariable: each ]! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! abstractClassVariable: aString | refactoring rewriter nonMetaClass | nonMetaClass := fromClass theNonMetaClass. refactoring := RBCreateAccessorsForVariableRefactoring model: self model variable: aString class: nonMetaClass classVariable: true. self performComponentRefactoring: refactoring. rewriter := RBParseTreeRewriter new. fromClass isMeta ifTrue: [ rewriter replace: aString , ' := ``@object' with: ('self <1s> ``@object' expandMacrosWith: refactoring setterMethod); replace: aString with: 'self ' , refactoring getterMethod ] ifFalse: [ rewriter replace: aString , ' := ``@object' with: ('self class <1s> ``@object' expandMacrosWith: refactoring setterMethod); replace: aString with: 'self class ' , refactoring getterMethod ]. (rewriter executeTree: tree) ifTrue: [ tree := rewriter tree ]! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: ''! processReferenceNode: aNode | varName | varName := aNode name. ignore = varName ifTrue: [^self]. (aNode whoDefines: varName) notNil ifTrue: [^self]. (self instanceVariableNames includes: varName) ifTrue: [instVarReaders add: varName]. (self classVariableNames includes: varName) ifTrue: [classVarReaders add: varName]! ! !RBAbstractVariablesRefactoring methodsFor: 'initialize-release' stamp: 'lr 9/8/2011 20:11'! abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ignoring: aVariableName | poolRefactoring | tree := aBRProgramNode. fromClass := self classObjectFor: fromBehavior. toClasses := behaviorCollection collect: [:each | self classObjectFor: each]. ignore := aVariableName. poolRefactoring := RBExpandReferencedPoolsRefactoring model: self model forMethod: tree fromClass: fromClass toClasses: toClasses. self performComponentRefactoring: poolRefactoring. self computeVariablesToAbstract! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: 'lr 10/26/2009 22:08'! removeDefinedClassVariables | selectionBlock nonMetaClass | nonMetaClass := fromClass theNonMetaClass. selectionBlock := [ :varName | (toClasses detect: [ :each | (each theNonMetaClass includesClass: (nonMetaClass whoDefinesClassVariable: varName)) not ] ifNone: [ nil ]) notNil ]. classVarReaders := classVarReaders select: selectionBlock. classVarWriters := classVarWriters select: selectionBlock! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming' stamp: 'lr 2/6/2010 13:33'! abstractClassVariables | variables | (classVarReaders isEmpty and: [ classVarWriters isEmpty ]) ifTrue: [ ^ self ]. variables := Set new. variables addAll: classVarReaders; addAll: classVarWriters. variables do: [ :each | self abstractClassVariable: each ]! ! !RBAbstractVariablesRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ignoring: aVariableName ^(self new) model: aRBSmalltalk; abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ignoring: aVariableName; yourself! ! !RBAbstractVariablesRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ^self model: aRBSmalltalk abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ignoring: nil! ! !RBAccessorClassRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^ self refactorings inject: RBCondition empty into: [ :result :each | result & each preconditions ]! ! !RBAccessorClassRefactoring methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/25/2012 18:02'! refactorings | class | class := self classObjectFor: className asSymbol. ^ class instanceVariableNames collect: [ :each | RBCreateAccessorsForVariableRefactoring variable: each class: class classVariable: false ]! ! !RBAccessorClassRefactoring methodsFor: 'transforming' stamp: ''! transform self refactorings do: [ :each | self performComponentRefactoring: each ]! ! !RBAddClassChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 18:52'! classVariableNames ^ classVariableNames! ! !RBAddClassChange methodsFor: 'private' stamp: 'lr 10/2/2010 13:37'! definitionClass ^ Smalltalk globals at: (self superclassName ifNil: [ ^ ProtoObject ])! ! !RBAddClassChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 18:52'! superclassName ^ superclassName! ! !RBAddClassChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 18:52'! instanceVariableNames ^ instanceVariableNames! ! !RBAddClassChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 18:52'! category ^ category! ! !RBAddClassChange methodsFor: '*NautilusRefactoring' stamp: ''! nameToDisplay ^ self changeString! ! !RBAddClassChange methodsFor: 'accessing' stamp: 'MartinDias 11/7/2013 18:11'! sharedPoolNames ^ poolDictionaryNames! ! !RBAddClassChange methodsFor: 'private' stamp: 'lr 10/1/2010 14:36'! fillOutDefinition: aDictionary superclassName := (aDictionary at: '`@superclass') ifNotNil: [ :value | value asSymbol ]. className := (aDictionary at: '`#className') asSymbol. instanceVariableNames := self namesIn: (aDictionary at: '`#instanceVariableNames' ifAbsent: [ String new ]). classVariableNames := self namesIn: (aDictionary at: '`#classVariableNames' ifAbsent: [ String new ]). poolDictionaryNames := self namesIn: (aDictionary at: '`#poolDictionaries' ifAbsent: [ String new ]). category := (aDictionary at: '`#category' ifAbsent: [ #Unclassified ]) asSymbol! ! !RBAddClassChange methodsFor: '*NautilusRefactoring' stamp: ''! textToDisplay ^ self definition! ! !RBAddClassChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation | class | class := Smalltalk globals at: self changeClassName ifAbsent: [ nil ]. ^ class isBehavior ifTrue: [ RBAddClassChange definition: class definition ] ifFalse: [ RBRemoveClassChange removeClassName: self changeClassName ]! ! !RBAddClassChange class methodsFor: 'private' stamp: 'lr 10/2/2010 13:32'! definitionPatterns ^ #('`@superclass subclass: `#className instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries category: `#category' '`@superclass subclass: `#className uses: `@traitComposition instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries category: `#category' '`@superclass variableByteSubclass: `#className instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries category: `#category' '`@superclass variableByteSubclass: `#className uses: `@traitComposition instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries category: `#category' '`@superclass variableSubclass: `#className instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries category: `#category' '`@superclass variableSubclass: `#className uses: `@traitComposition instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries category: `#category' '`@superclass variableWordSubclass: `#className instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries category: `#category' '`@superclass variableWordSubclass: `#className uses: `@traitComposition instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries category: `#category' '`@superclass weakSubclass: `#className instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries category: `#category' '`@superclass weakSubclass: `#className uses: `@traitComposition instanceVariableNames: `#instanceVariableNames classVariableNames: `#classVariableNames poolDictionaries: `#poolDictionaries category: `#category') gather: [ :each | Array with: each with: (each copyReplaceAll: '`@superclass' with: 'ProtoObject') , '. `className superclass: `@superclass' ]! ! !RBAddClassRefactoring methodsFor: 'initialize-release' stamp: ''! addClass: aName superclass: aClass subclasses: aCollection category: aSymbol self className: aName. superclass := self classObjectFor: aClass. subclasses := aCollection collect: [:each | self classObjectFor: each]. category := aSymbol! ! !RBAddClassRefactoring methodsFor: 'preconditions' stamp: ''! preconditions | cond | cond := ((RBCondition isMetaclass: superclass) errorMacro: 'Superclass must not be a metaclass') not. cond := subclasses inject: cond into: [:sub :each | sub & ((RBCondition isMetaclass: each) errorMacro: 'Subclass must <1?not :>be a metaclass') not & (RBCondition isImmediateSubclass: each of: superclass)]. ^cond & (RBCondition isValidClassName: className) & (RBCondition isGlobal: className in: self model) not & (RBCondition isSymbol: category) & ((RBCondition withBlock: [category isEmpty not]) errorMacro: 'Invalid category name')! ! !RBAddClassRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' addClass: #'; nextPutAll: className; nextPutAll: ' superclass: '. superclass storeOn: aStream. aStream nextPutAll: ' subclasses: '. subclasses asArray storeOn: aStream. aStream nextPutAll: ' category: '. category storeOn: aStream. aStream nextPut: $)! ! !RBAddClassRefactoring methodsFor: 'transforming' stamp: 'bh 4/10/2001 14:25'! transform (self model) defineClass: ('<1p> subclass: #<2s> instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: <3p>' expandMacrosWith: superclass with: className with: category asString); reparentClasses: subclasses to: (self model classNamed: className asSymbol)! ! !RBAddClassRefactoring class methodsFor: 'instance creation' stamp: ''! addClass: aName superclass: aClass subclasses: aCollection category: aSymbol ^self new addClass: aName superclass: aClass subclasses: aCollection category: aSymbol! ! !RBAddClassRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk addClass: aName superclass: aClass subclasses: aCollection category: aSymbol ^(self new) model: aRBSmalltalk; addClass: aName superclass: aClass subclasses: aCollection category: aSymbol; yourself! ! !RBAddClassTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelAddClass | refactoring newClass superClass subclass | subclass := model classNamed: #Bar. superClass := model classNamed: #Foo. refactoring := RBAddClassRefactoring model: model addClass: #FooTest superclass: superClass subclasses: (Array with: subclass) category: #'Refactory-Testing'. self executeRefactoring: refactoring. newClass := model classNamed: #FooTest. self assert: newClass superclass = superClass. self assert: (superClass subclasses includes: newClass). self assert: newClass theMetaClass superclass = superClass theMetaClass. self assert: (superClass theMetaClass subclasses includes: newClass theMetaClass). self assert: subclass superclass = newClass. self assert: (newClass subclasses includes: subclass). self assert: subclass theMetaClass superclass = newClass theMetaClass. self assert: (newClass theMetaClass subclasses includes: subclass theMetaClass)! ! !RBAddClassTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMetaClassFailure self shouldFail: (RBAddClassRefactoring addClass: #Foo superclass: self class class subclasses: #() category: #'Refactory-Testing')! ! !RBAddClassTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelInvalidSubclass | refactoring | refactoring := RBAddClassRefactoring model: model addClass: #Foo2 superclass: Object subclasses: (Array with: (model classNamed: #Bar)) category: #'Refactory-Tesing'. self shouldFail: refactoring! ! !RBAddClassTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testExistingName self shouldFail: (RBAddClassRefactoring addClass: #Object superclass: self class subclasses: #() category: #'Refactory-Testing')! ! !RBAddClassTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAddClass | refactoring newClass superClass classTest | refactoring := RBAddClassRefactoring addClass: #FooTest superclass: RBRefactoringTest subclasses: (Array with: self class) category: #'Refactory-Testing'. self executeRefactoring: refactoring. newClass := refactoring model classNamed: #FooTest. superClass := refactoring model classNamed: #RBRefactoringTest. classTest := refactoring model classNamed: self class name. self assert: newClass superclass = superClass. self assert: (superClass subclasses includes: newClass). self assert: newClass theMetaClass superclass = superClass theMetaClass. self assert: (superClass theMetaClass subclasses includes: newClass theMetaClass). self assert: classTest superclass = newClass. self assert: (newClass subclasses includes: classTest). self assert: classTest theMetaClass superclass = newClass theMetaClass. self assert: (newClass theMetaClass subclasses includes: classTest theMetaClass)! ! !RBAddClassTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testInvalidSubclass self shouldFail: (RBAddClassRefactoring addClass: #Foo superclass: RBCompositeLintRuleTest subclasses: (Array with: RBBasicLintRuleTest) category: #'Refactory-Tesing')! ! !RBAddClassTest methodsFor: 'set up' stamp: 'CamilloBruni 8/27/2013 15:05'! setUp super setUp. model := self abstractVariableTestData.! ! !RBAddClassTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelExistingName | refactoring | refactoring := RBAddClassRefactoring model: model addClass: #Foo superclass: Object subclasses: #() category: #'Refactory-Testing'. self shouldFail: refactoring! ! !RBAddClassTraitChange methodsFor: 'private' stamp: 'lr 9/30/2010 19:47'! definitionClass ^ self changeClass! ! !RBAddClassTraitChange methodsFor: 'initialization' stamp: 'lr 10/1/2010 14:36'! fillOutDefinition: aDictionary className := (aDictionary at: '`traitName') asSymbol! ! !RBAddClassTraitChange methodsFor: 'converting' stamp: 'lr 9/30/2010 19:47'! asUndoOperation ^ self class definition: self changeClass classTrait definition! ! !RBAddClassTraitChange class methodsFor: 'private' stamp: 'lr 9/30/2010 19:46'! definitionPatterns ^ #('`traitName classTrait uses: `@traitComposition')! ! !RBAddClassVariableChange methodsFor: 'private' stamp: 'lr 3/20/2011 11:27'! changeSymbol ^ #addClassVarNamed:! ! !RBAddClassVariableChange methodsFor: 'accessing' stamp: 'lr 10/15/2010 08:31'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !RBAddClassVariableChange methodsFor: 'printing' stamp: 'lr 10/15/2010 09:37'! changeString ^ 'Add class variable <1s> to <2s>' expandMacrosWith: self variable with: self displayClassName! ! !RBAddClassVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBRemoveClassVariableChange remove: self variable from: self changeClass! ! !RBAddClassVariableRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition isMetaclass: class) not & (RBCondition isValidClassVarName: variableName for: class) & (RBCondition hierarchyOf: class definesVariable: variableName asString) not & (RBCondition isGlobal: variableName in: self model) not! ! !RBAddClassVariableRefactoring methodsFor: 'transforming' stamp: ''! transform class addClassVariable: variableName! ! !RBAddClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMetaClassFailure self shouldFail: (RBAddClassVariableRefactoring variable: #VariableName class: RBTransformationRuleTest class)! ! !RBAddClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelMetaclass | refactoring | refactoring := RBAddClassVariableRefactoring model: model variable: #ClassVarName3 class: (model classNamed: #Bar) theMetaClass. self shouldFail: refactoring! ! !RBAddClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testAlreadyExistingName self shouldFail: (RBAddClassVariableRefactoring variable: #RecursiveSelfRule class: RBTransformationRuleTest); shouldFail: (RBAddClassVariableRefactoring variable: self objectClassVariable class: RBTransformationRuleTest)! ! !RBAddClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMetaclass | refactoring | refactoring := RBAddClassVariableRefactoring variable: #ClassVarName3 class: (model classNamed: #Object) theMetaClass. refactoring model: model. self shouldFail: refactoring! ! !RBAddClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelAddClassVariable | refactoring | refactoring := RBAddClassVariableRefactoring model: model variable: #ClassVarName3 class: (model classNamed: #Bar). self executeRefactoring: refactoring. self assert: ((model classNamed: #Bar) directlyDefinesClassVariable: #ClassVarName3)! ! !RBAddClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAddClassVariable | refactoring | refactoring := RBAddClassVariableRefactoring variable: 'Asdf' class: RBTransformationRuleTest. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBTransformationRuleTest) directlyDefinesClassVariable: #Asdf)! ! !RBAddClassVariableTest methodsFor: 'set up' stamp: 'CamilloBruni 8/27/2013 15:05'! setUp super setUp. model := self abstractVariableTestData.! ! !RBAddClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelAlreadyExistingName | refactoring | refactoring := RBAddClassVariableRefactoring model: model variable: #ClassVarName2 class: (model classNamed: #Bar). self shouldFail: refactoring! ! !RBAddInstanceVariableChange methodsFor: 'printing' stamp: 'lr 10/14/2010 20:52'! changeString ^ 'Add instance variable <1s> to <2s>' expandMacrosWith: self variable with: self displayClassName! ! !RBAddInstanceVariableChange methodsFor: 'private' stamp: 'lr 3/20/2011 11:26'! changeSymbol ^ #addInstVarNamed:! ! !RBAddInstanceVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBRemoveInstanceVariableChange remove: self variable from: self changeClass! ! !RBAddInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition isValidInstanceVariableName: variableName for: class) & (RBCondition hierarchyOf: class definesVariable: variableName) not & (RBCondition isGlobal: variableName in: self model) not! ! !RBAddInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''! transform class addInstanceVariable: variableName! ! !RBAddInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAddToModel | refactoring | model := RBNamespace new. model name: 'Add instance variable'. model defineClass: 'Object subclass: #FOOBAR instanceVariableNames: ''fdsa'' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. refactoring := RBAddInstanceVariableRefactoring model: model variable: 'asdf' class: (model classNamed: #FOOBAR). self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #FOOBAR) directlyDefinesInstanceVariable: 'asdf')! ! !RBAddInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNewExistingName | refactoring | model := RBNamespace new. model name: 'Add instance variable'. model defineClass: 'Object subclass: #FOOBAR instanceVariableNames: ''asdf'' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. refactoring := RBAddInstanceVariableRefactoring model: model variable: 'asdf' class: (model classNamed: #FOOBAR). self shouldFail: refactoring! ! !RBAddInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelMetaclassAlreadyExistingName | refactoring | (model metaclassNamed: #Foo) addInstanceVariable: 'instVarName1'. refactoring := RBAddInstanceVariableRefactoring model: model variable: 'instVarName1' class: (model classNamed: #Bar). self shouldFail: refactoring! ! !RBAddInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNewHierarchyExistingName | refactoring | model := RBNamespace new. model name: 'Add instance variable'. model defineClass: 'Object subclass: #FOOBAR instanceVariableNames: ''asdf'' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'FOOBAR subclass: #BARFOO instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''Refactory-Test data'''. refactoring := RBAddInstanceVariableRefactoring model: model variable: 'asdf' class: (model classNamed: #BARFOO). self shouldFail: refactoring! ! !RBAddInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testAlreadyExistingName self shouldFail: (RBAddInstanceVariableRefactoring variable: 'class' class: RBTransformationRuleTest); shouldFail: (RBAddInstanceVariableRefactoring variable: 'name' class: RBTransformationRuleTest)! ! !RBAddInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAddInstanceVariable | refactoring | refactoring := RBAddInstanceVariableRefactoring variable: 'asdf' class: RBTransformationRuleTest. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBTransformationRuleTest) directlyDefinesInstanceVariable: 'asdf')! ! !RBAddInstanceVariableTest methodsFor: 'set up' stamp: 'CamilloBruni 8/27/2013 15:05'! setUp super setUp. model := self abstractVariableTestData.! ! !RBAddInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelAlreadyExistingName | refactoring | refactoring := RBAddInstanceVariableRefactoring model: model variable: 'instVarName1' class: (model classNamed: #Bar). self shouldFail: refactoring! ! !RBAddMetaclassChange methodsFor: 'private' stamp: 'lr 9/30/2010 14:21'! definitionClass ^ self changeClass! ! !RBAddMetaclassChange methodsFor: 'initialization' stamp: 'lr 10/1/2010 14:37'! fillOutDefinition: aDictionary className := (aDictionary at: '`className') asSymbol. classInstanceVariableNames := self namesIn: (aDictionary at: '`#instanceVariableNames' ifAbsent: [ String new ])! ! !RBAddMetaclassChange methodsFor: 'converting' stamp: 'lr 9/30/2010 14:32'! asUndoOperation ^ self class definition: self changeClass class definition! ! !RBAddMetaclassChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 18:57'! classInstanceVariableNames ^ classInstanceVariableNames! ! !RBAddMetaclassChange class methodsFor: 'private' stamp: 'lr 9/30/2010 19:19'! definitionPatterns ^ #('`className class instanceVariableNames: `#instanceVariableNames' '`className class uses: `@traitComposition instanceVariableNames: `#instanceVariableNames')! ! !RBAddMethodChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 21:24'! selector selector isNil ifTrue: [ selector := RBParser parseMethodPattern: source. selector isNil ifTrue: [ selector := #unknown ] ]. ^ selector! ! !RBAddMethodChange methodsFor: 'comparing' stamp: 'lr 9/6/2010 21:25'! hash ^ self parseTree hash! ! !RBAddMethodChange methodsFor: 'accessing' stamp: 'lr 9/7/2010 19:10'! protocol ^ self protocols first! ! !RBAddMethodChange methodsFor: 'private' stamp: 'lr 9/6/2010 21:27'! parseTree ^ RBParser parseMethod: source onError: [ :str :pos | ^ nil ]! ! !RBAddMethodChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 11:29'! changeForMetaclass: aClassName selector: aSelector ^ (isMeta and: [ self selector = aSelector and: [ className = aClassName ] ]) ifTrue: [ self ] ifFalse: [ nil ]! ! !RBAddMethodChange methodsFor: 'initialize-release' stamp: 'lr 9/8/2011 20:25'! class: aClass source: aString contoller: aController self changeClass: aClass. source := aString. self protocols: (RBBrowserEnvironment new whichProtocolIncludes: self selector in: aClass). controller := aController! ! !RBAddMethodChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 11:28'! changeForClass: aClassName selector: aSelector ^ (isMeta not and: [ self selector = aSelector and: [ className = aClassName ] ]) ifTrue: [ self ] ifFalse: [ nil ]! ! !RBAddMethodChange methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 6/28/2013 12:25'! protocols: aCollectionOrString protocols := aCollectionOrString isString ifTrue: [ aCollectionOrString = Protocol unclassified ifTrue: [ protocols := #(accessing) ] ifFalse: [ Array with: aCollectionOrString ] ] ifFalse: [ aCollectionOrString ]. ! ! !RBAddMethodChange methodsFor: 'initialize-release' stamp: ''! class: aClass protocol: aProtocol source: aString self changeClass: aClass. self protocols: aProtocol. source := aString! ! !RBAddMethodChange methodsFor: 'printing' stamp: 'lr 4/7/2010 08:22'! changeString ^ self displayClassName , '>>' , self selector! ! !RBAddMethodChange methodsFor: '*NautilusRefactoring' stamp: 'MarcusDenker 9/5/2013 14:07'! accept: aText notifying: aController "Just to make sure that it compiles, try with the standard compiler." | compiler | compiler := self changeClass ifNil: [ Object compiler ] ifNotNil: [:changeClass | changeClass compiler ]. compiler source: aText asString; class: self changeClass; requestor: aController; failBlock: [ ^ false ]; translate. self class: self changeClass protocol: self protocol source: aText asString. ^ true! ! !RBAddMethodChange methodsFor: 'initialize-release' stamp: 'lr 9/30/2010 20:02'! controller: aController controller := aController! ! !RBAddMethodChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 21:24'! protocols ^ protocols! ! !RBAddMethodChange methodsFor: 'comparing' stamp: 'lr 9/6/2010 21:24'! = anAddMethodChange super = anAddMethodChange ifFalse: [ ^ false ]. ^ self parseTree = anAddMethodChange parseTree! ! !RBAddMethodChange methodsFor: 'initialize-release' stamp: 'lr 9/30/2010 20:04'! class: aClass protocol: aProtocol source: aString controller: aController self changeClass: aClass. self protocols: aProtocol. source := aString. controller := aController! ! !RBAddMethodChange methodsFor: 'printing' stamp: 'StephaneDucasse 9/13/2013 21:43'! printOn: aStream aStream nextPut: $!!; nextPutAll: self displayClassName; nextPutAll: ' methodsFor: '''; nextPutAll: self protocol; nextPutAll: ''' stamp: '; print: self changeStamp; nextPut: $!!; cr; nextPutAll: (source copyReplaceAll: '!!' with: '!!!!'); nextPutAll: '!! !!'! ! !RBAddMethodChange methodsFor: '*NautilusRefactoring' stamp: ''! oldVersionTextToDisplay | class | class := Smalltalk at: className asSymbol ifAbsent: [ ^ super oldVersionTextToDisplay ]. ^ class methodDict at: self selector ifPresent: [:method | method sourceCode ] ifAbsent: [ super oldVersionTextToDisplay ]! ! !RBAddMethodChange methodsFor: 'accessing' stamp: 'lr 11/1/2009 23:25'! source ^ source! ! !RBAddMethodChange methodsFor: 'private' stamp: 'lr 9/30/2010 20:02'! controller ^ controller! ! !RBAddMethodChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 20:02'! definedSelector ^ definedSelector! ! !RBAddMethodChange methodsFor: 'private' stamp: 'lr 10/14/2010 20:50'! primitiveExecute definedSelector := self changeClass compile: self source classified: self protocol notifying: self controller! ! !RBAddMethodChange methodsFor: '*NautilusRefactoring' stamp: ''! textToDisplay ^ self source! ! !RBAddMethodChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:25'! asUndoOperation ^ (self changeClass includesSelector: self selector) ifTrue: [ | oldProtocol | oldProtocol := RBBrowserEnvironment new whichProtocolIncludes: self selector in: self changeClass. oldProtocol isNil ifTrue: [ oldProtocol := #accessing ]. RBAddMethodChange compile: (self methodSourceFor: self selector) in: self changeClass classified: oldProtocol ] ifFalse: [ RBRemoveMethodChange remove: selector from: self changeClass ]! ! !RBAddMethodChange class methodsFor: 'instance creation' stamp: 'lr 9/30/2010 20:12'! compile: aString in: aClass ^ self compile: aString in: aClass for: nil! ! !RBAddMethodChange class methodsFor: 'instance creation' stamp: 'lr 9/30/2010 20:04'! compile: aString in: aBehavior classified: aProtocol for: aController ^ self new class: aBehavior protocol: aProtocol source: aString controller: aController! ! !RBAddMethodChange class methodsFor: 'instance creation' stamp: 'lr 9/30/2010 20:12'! compile: aString in: aBehavior classified: aProtocol ^ self compile: aString in: aBehavior classified: aProtocol for: nil! ! !RBAddMethodChange class methodsFor: 'instance creation' stamp: 'lr 9/30/2010 20:04'! compile: aString in: aClass for: aController ^ self new class: aClass source: aString contoller: aController! ! !RBAddMethodRefactoring methodsFor: 'initialize-release' stamp: ''! addMethod: aString toClass: aClass inProtocols: protocolList class := self classObjectFor: aClass. source := aString. protocols := protocolList! ! !RBAddMethodRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/7/2012 23:57'! preconditions | selector method | method := RBParser parseMethod: source onError: [:string :position | ^RBCondition withBlock: [self refactoringFailure: 'The sources could not be parsed']]. selector := method selector. selector isNil ifTrue: [self refactoringFailure: 'Invalid source.']. ^(RBCondition canUnderstand: selector in: class) not! ! !RBAddMethodRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' addMethod: '''; nextPutAll: source; nextPutAll: ''' toClass: '. class storeOn: aStream. aStream nextPutAll: ' inProtocols: '. protocols storeOn: aStream. aStream nextPut: $)! ! !RBAddMethodRefactoring methodsFor: 'transforming' stamp: ''! transform class compile: source classified: protocols! ! !RBAddMethodRefactoring class methodsFor: 'instance creation' stamp: ''! addMethod: aString toClass: aClass inProtocols: protocolList ^self new addMethod: aString toClass: aClass inProtocols: protocolList! ! !RBAddMethodRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk addMethod: aString toClass: aClass inProtocols: protocolList ^(self new) model: aRBSmalltalk; addMethod: aString toClass: aClass inProtocols: protocolList; yourself! ! !RBAddMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testExistingSelector self shouldFail: (RBAddMethodRefactoring addMethod: 'printString ^super printString' toClass: RBBasicLintRuleTest inProtocols: #(#accessing ))! ! !RBAddMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelAddMethod | refactoring class | class := model metaclassNamed: #Bar. refactoring := RBAddMethodRefactoring model: model addMethod: 'printString1 ^super printString' toClass: class inProtocols: #(#accessing). self executeRefactoring: refactoring. self assert: (class parseTreeFor: #printString1) = (RBParser parseMethod: 'printString1 ^super printString')! ! !RBAddMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelExistingSelector | refactoring | refactoring := RBAddMethodRefactoring model: model addMethod: 'classVarName1 ^super printString' toClass: (model classNamed: #Bar) inProtocols: #(#accessing). self shouldFail: refactoring! ! !RBAddMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAddMethod | refactoring | refactoring := RBAddMethodRefactoring addMethod: 'printString1 ^super printString' toClass: RBBasicLintRuleTest inProtocols: #(#accessing ). self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBBasicLintRuleTest) parseTreeFor: #printString1) = (RBParser parseMethod: 'printString1 ^super printString')! ! !RBAddMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadMethod self shouldFail: (RBAddMethodRefactoring addMethod: 'asdf ^super ^printString' toClass: RBBasicLintRuleTest inProtocols: #(#accessing ))! ! !RBAddMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelInheritedSelector | refactoring | refactoring := RBAddMethodRefactoring model: model addMethod: 'printString ^super printString' toClass: (model classNamed: #Bar) inProtocols: #(#accessing). self shouldFail: refactoring! ! !RBAddMethodTest methodsFor: 'set up' stamp: 'CamilloBruni 8/27/2013 15:05'! setUp super setUp. model := self abstractVariableTestData.! ! !RBAddParameterRefactoring methodsFor: 'preconditions' stamp: 'lr 11/2/2009 00:14'! checkVariableReferencesIn: aParseTree | searcher | searcher := RBParseTreeSearcher new. searcher matches: '`var' do: [:aNode :answer | | name | name := aNode name. (aNode whoDefines: name) isNil ifTrue: [self checkSendersAccessTo: name]]. searcher executeTree: aParseTree! ! !RBAddParameterRefactoring methodsFor: 'private' stamp: ''! newSelectorString | stream keywords | stream := WriteStream on: String new. keywords := newSelector keywords. 1 to: keywords size do: [:i | stream nextPutAll: (keywords at: i). i == keywords size ifTrue: [stream nextPut: $(; nextPutAll: initializer; nextPut: $)] ifFalse: [stream nextPutAll: ' ``@arg'; nextPutAll: i printString]. stream nextPut: $ ]. ^stream contents! ! !RBAddParameterRefactoring methodsFor: 'private' stamp: 'lr 2/21/2010 14:52'! modifyImplementorParseTree: parseTree in: aClass | name newArg allTempVars | allTempVars := parseTree allDefinedVariables. name := self safeVariableNameFor: aClass temporaries: allTempVars. newArg := RBVariableNode named: name. parseTree renameSelector: newSelector andArguments: parseTree arguments , (Array with: newArg)! ! !RBAddParameterRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:13'! verifyInitializationExpression | tree | tree := RBParser parseExpression: initializer onError: [:msg :index | self refactoringFailure: 'Illegal initialization code because:.' , msg]. tree isValue ifFalse: [self refactoringFailure: 'The initialization code cannot be a return node or a list of statements']. self checkVariableReferencesIn: tree! ! !RBAddParameterRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:13'! myConditions ^RBCondition withBlock: [oldSelector numArgs + 1 = newSelector numArgs ifFalse: [self refactoringFailure: newSelector printString , ' doesn''t have the proper number of arguments.']. self verifyInitializationExpression. true]! ! !RBAddParameterRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' addParameterToMethod: #'; nextPutAll: oldSelector; nextPutAll: ' in: '. class storeOn: aStream. aStream nextPutAll: ' newSelector: #'; nextPutAll: newSelector; nextPutAll: ' initializer: '''; nextPutAll: initializer; nextPutAll: ''')'! ! !RBAddParameterRefactoring methodsFor: 'private' stamp: ''! senders senders isNil ifTrue: [senders := Set new. self model allReferencesTo: oldSelector do: [:each | senders add: each modelClass]]. ^senders! ! !RBAddParameterRefactoring methodsFor: 'private' stamp: 'lr 11/2/2009 00:14'! parseTreeRewriter | rewriteRule oldString newString | rewriteRule := RBParseTreeRewriter new. oldString := self buildSelectorString: oldSelector. newString := self newSelectorString. rewriteRule replace: '``@object ' , oldString with: '``@object ' , newString. ^rewriteRule! ! !RBAddParameterRefactoring methodsFor: 'initialize-release' stamp: 'md 3/15/2006 17:28'! addParameterToMethod: aSelector in: aClass newSelector: newSel initializer: init self renameMethod: aSelector in: aClass to: newSel permutation: (1 to: newSel numArgs). initializer := init! ! !RBAddParameterRefactoring methodsFor: 'preconditions' stamp: ''! checkSendersAccessTo: name | violatorClass | (#('self' 'super') includes: name) ifTrue: [^self]. violatorClass := self senders detect: [:each | (self canReferenceVariable: name in: each) not] ifNone: [nil]. violatorClass notNil ifTrue: [self refactoringError: ('<1s> doesn''t appear to be defined in <2p>' expandMacrosWith: name with: violatorClass)]! ! !RBAddParameterRefactoring methodsFor: 'private' stamp: ''! safeVariableNameFor: aClass temporaries: allTempVars | baseString i newString | newString := baseString := 'anObject'. i := 0. [(allTempVars includes: newString) or: [aClass definesInstanceVariable: newString]] whileTrue: [i := i + 1. newString := baseString , i printString]. ^newString! ! !RBAddParameterRefactoring class methodsFor: 'instance creation' stamp: ''! addParameterToMethod: aSelector in: aClass newSelector: newSelector initializer: init ^self new addParameterToMethod: aSelector in: aClass newSelector: newSelector initializer: init! ! !RBAddParameterRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk addParameterToMethod: aSelector in: aClass newSelector: newSelector initializer: init ^(self new) model: aRBSmalltalk; addParameterToMethod: aSelector in: aClass newSelector: newSelector initializer: init; yourself! ! !RBAddParameterTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAddParameterForTwoArgumentMessage | refactoring class | refactoring := RBAddParameterRefactoring addParameterToMethod: ('called:' , 'on:') asSymbol in: RBRefactoryTestDataApp newSelector: #called:bar:on: initializer: '#(1.0)'. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBRefactoryTestDataApp. self assert: (class parseTreeFor: #called:bar:on:) = (RBParser parseMethod: 'called: anObject bar: aBlock on: anObject1 Transcript show: anObject printString; cr. aBlock value'). self assert: (class parseTreeFor: #caller) = (RBParser parseMethod: 'caller | anObject | anObject := 5. self called: anObject + 1 bar: [^anObject] on: #(1.0)'). self deny: (class directlyDefinesMethod: ('called:' , 'on:') asSymbol)! ! !RBAddParameterTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelNonExistantName | refactoring | (model classNamed: #RBLintRuleTest) removeMethod: #name. refactoring := RBAddParameterRefactoring model: model addParameterToMethod: #name in: RBLintRuleTest newSelector: #nameNew: initializer: 'nil'. self shouldFail: refactoring! ! !RBAddParameterTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testPrimitiveMethods | refactoring | (model classNamed: #Object) compile: 'foo ^#() primitiveFailed' classified: #(#accessing). refactoring := RBAddParameterRefactoring model: model addParameterToMethod: #foo in: Object newSelector: #foo123124321s: initializer: '1'. self shouldFail: refactoring. refactoring := RBAddParameterRefactoring addParameterToMethod: #at: in: Object newSelector: #at:foo: initializer: '1'. self shouldFail: refactoring. ! ! !RBAddParameterTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadInitializationCode self shouldFail: (RBAddParameterRefactoring addParameterToMethod: #name in: RBLintRuleTest newSelector: #name: initializer: 'foo:'); shouldFail: (RBAddParameterRefactoring addParameterToMethod: #name in: RBLintRuleTest newSelector: #name: initializer: 'foo')! ! !RBAddParameterTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAddParameterThatReferencesSelf | refactoring class | refactoring := RBAddParameterRefactoring addParameterToMethod: ('test' , 'Foo:') asSymbol in: RBRefactoryTestDataApp newSelector: #testFoo:bar: initializer: 'self printString'. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBRefactoryTestDataApp. self assert: (class parseTreeFor: #testFoo:bar:) = (RBParser parseMethod: 'testFoo: anObject bar: anObject1 ^self class + anObject'). self assert: (class parseTreeFor: #callFoo) = (RBParser parseMethod: 'callFoo ^self testFoo: 5 bar: (self printString)'). self deny: (class directlyDefinesMethod: ('test' , 'Foo:') asSymbol)! ! !RBAddParameterTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAddParameterThatReferencesModelGlobal | refactoring class | refactoring := RBAddParameterRefactoring model: model addParameterToMethod: ('test' , 'Foo:') asSymbol in: RBRefactoryTestDataApp newSelector: #testFoo:bar: initializer: 'Bar new'. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBRefactoryTestDataApp. self assert: (class parseTreeFor: #testFoo:bar:) = (RBParser parseMethod: 'testFoo: anObject bar: anObject1 ^self class + anObject'). self assert: (class parseTreeFor: #callFoo) = (RBParser parseMethod: 'callFoo ^self testFoo: 5 bar: (Bar new)'). self deny: (class directlyDefinesMethod: ('test' , 'Foo:') asSymbol)! ! !RBAddParameterTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelBadInitializationCode | refactoring | model removeClassNamed: #RBRefactoring. refactoring := RBAddParameterRefactoring model: model addParameterToMethod: #name1 in: RBLintRuleTest newSelector: #name1: initializer: 'AddParameterRefactoring new'. self shouldFail: refactoring! ! !RBAddParameterTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBAddParameterRefactoring addParameterToMethod: #name1 in: RBLintRuleTest newSelector: #name1: initializer: 'nil')! ! !RBAddParameterTest methodsFor: 'set up' stamp: 'CamilloBruni 8/27/2013 15:06'! setUp super setUp. model := self abstractVariableTestData.! ! !RBAddParameterTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testAddParameterThatReferencesGlobalAndLiteral | refactoring class | refactoring := RBAddParameterRefactoring addParameterToMethod: ('test' , 'Foo:') asSymbol in: RBRefactoryTestDataApp newSelector: #testFoo:bar: initializer: 'OrderedCollection new: 5'. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBRefactoryTestDataApp. self assert: (class parseTreeFor: #testFoo:bar:) = (RBParser parseMethod: 'testFoo: anObject bar: anObject1 ^self class + anObject'). self assert: (class parseTreeFor: #callFoo) = (RBParser parseMethod: 'callFoo ^self testFoo: 5 bar: (OrderedCollection new: 5)'). self deny: (class directlyDefinesMethod: ('test' , 'Foo:') asSymbol)! ! !RBAddPoolVariableChange methodsFor: 'private' stamp: 'lr 9/6/2010 21:30'! changeSymbol ^ #addSharedPool:! ! !RBAddPoolVariableChange methodsFor: 'accessing' stamp: 'lr 10/15/2010 08:31'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !RBAddPoolVariableChange methodsFor: 'printing' stamp: 'lr 4/7/2010 08:19'! changeString ^ 'Add pool variable <1s> to <2s>' expandMacrosWith: self variable with: self displayClassName! ! !RBAddPoolVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBRemovePoolVariableChange remove: self variable from: self changeClass! ! !RBAddRemoveDependentsRule commentStamp: ''! See my #rationale.! !RBAddRemoveDependentsRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBAddRemoveDependentsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check that the number of addDependent: message sends in a class is less than or equal to the number of removeDependent: messages. If there are more addDependent: messages that may signify that some dependents are not being released, which may lead to memory leaks.'! ! !RBAddRemoveDependentsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBAddRemoveDependentsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Number of addDependent: messages > removeDependent:'! ! !RBAddRemoveDependentsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 14:11'! category ^ 'Potential Bugs'! ! !RBAddRemoveDependentsRule methodsFor: 'running' stamp: 'lr 11/2/2009 23:38'! checkClass: aContext | count | count := 0. ((Set withAll: (aContext selectedClass whichSelectorsReferTo: #addDependent:)) addAll: (aContext selectedClass whichSelectorsReferTo: #removeDependent:); yourself) do: [ :sel | (aContext selectedClass compiledMethodAt: sel) messagesDo: [ :each | each = #addDependent: ifTrue: [ count := count + 1 ]. each = #removeDependent: ifTrue: [ count := count - 1 ] ] ]. count > 0 ifTrue: [ result addClass: aContext selectedClass ]! ! !RBAddRemoveDependentsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'AddRemoveDependentsRule'! ! !RBAddTraitChange methodsFor: 'private' stamp: 'lr 9/30/2010 19:39'! definitionClass ^ Trait! ! !RBAddTraitChange methodsFor: 'initialization' stamp: 'lr 10/1/2010 14:37'! fillOutDefinition: aDictionary className := (aDictionary at: '`#traitName') asSymbol. category := (aDictionary at: '`#category' ifAbsent: [ #Unclassified ]) asSymbol! ! !RBAddTraitChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 19:29'! category ^ category! ! !RBAddTraitChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation | trait | trait := Smalltalk globals at: self changeClassName ifAbsent: [ nil ]. ^ trait isTrait ifTrue: [ RBAddTraitChange definition: trait definition ] ifFalse: [ RBRemoveClassChange removeClassName: self changeClassName ]! ! !RBAddTraitChange class methodsFor: 'private' stamp: 'lr 9/30/2010 19:46'! definitionPatterns ^ #('Trait named: `#traitName uses: `@traitComposition category: `#category')! ! !RBAllAnyNoneSatisfyRule commentStamp: ''! See rationale! !RBAllAnyNoneSatisfyRule methodsFor: 'initialization' stamp: 'lr 1/3/2010 12:04'! initialize super initialize. self rewriteRule " allSatisfy: " replaceMethod: '`@method: `@args | `@temps | `@.statements. `@collection do: [ :`each | | `@blocktemps | `@.blockstatements. `@condition ifFalse: [ ^ false ] ]. ^ true' with: '`@method: `@args | `@temps | `@.statements. ^ `@collection allSatisfy: [ :`each | | `@blocktemps | `@.blockstatements. `@condition ]'; " anySatisfy: " replaceMethod: '`@method: `@args | `@temps | `@.statements. `@collection do: [ :`each | | `@blocktemps | `@.blockstatements. `@condition ifTrue: [ ^ true ] ]. ^ false' with: '`@method: `@args | `@temps | `@.statements. ^ `@collection anySatisfy: [ :`each | | `@blocktemps | `@.blockstatements. `@condition ]'; " noneSatisfy: " replaceMethod: '`@method: `@args | `@temps | `@.statements. `@collection do: [ :`each | | `@blocktemps | `@.blockstatements. `@condition ifTrue: [ ^ false ] ]. ^ true' with: '`@method: `@args | `@temps | `@.statements. ^ `@collection noneSatisfy: [ :`each | | `@blocktemps | `@.blockstatements. `@condition ]'! ! !RBAllAnyNoneSatisfyRule methodsFor: 'accessing' stamp: 'lr 1/3/2010 11:35'! group ^ 'Transformations'! ! !RBAllAnyNoneSatisfyRule methodsFor: 'accessing' stamp: 'lr 1/3/2010 11:53'! name ^ 'Replace with #allSatsify:, #anySatisfy: or #noneSatsify:'! ! !RBAllAnyNoneSatisfyRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:47'! category ^ 'Coding Idiom Violation'! ! !RBAllAnyNoneSatisfyRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'AllAnyNoneSatisfyRule'! ! !RBAndEnvironment methodsFor: 'testing' stamp: ''! includesClass: aClass | doesntHaveSelectors | (environment includesClass: aClass) ifFalse: [^false]. (andedEnvironment includesClass: aClass) ifFalse: [^false]. doesntHaveSelectors := true. environment selectorsForClass: aClass do: [:each | doesntHaveSelectors := false. (andedEnvironment includesSelector: each in: aClass) ifTrue: [^true]]. ^doesntHaveSelectors! ! !RBAndEnvironment methodsFor: 'accessing' stamp: ''! classesDo: aBlock environment classesDo: [:each | (self includesClass: each) ifTrue: [aBlock value: each]]! ! !RBAndEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. environment storeOn: aStream. aStream nextPutAll: ' & '. andedEnvironment storeOn: aStream. aStream nextPut: $)! ! !RBAndEnvironment methodsFor: 'testing' stamp: ''! includesCategory: aCategory ^(self classNamesFor: aCategory) isEmpty not! ! !RBAndEnvironment methodsFor: 'private' stamp: ''! andedEnvironment ^andedEnvironment! ! !RBAndEnvironment methodsFor: 'testing' stamp: ''! includesSelector: aSelector in: aClass ^(environment includesSelector: aSelector in: aClass) and: [andedEnvironment includesSelector: aSelector in: aClass]! ! !RBAndEnvironment methodsFor: 'initialize-release' stamp: ''! andedEnvironment: aBrowserEnvironment andedEnvironment := aBrowserEnvironment! ! !RBAndEnvironment methodsFor: 'testing' stamp: 'CamilloBruni 8/27/2013 02:09'! includesProtocol: aProtocol in: aClass ^ (environment includesProtocol: aProtocol in: aClass) and: [ andedEnvironment includesProtocol: aProtocol in: aClass ]! ! !RBAndEnvironment methodsFor: 'accessing' stamp: ''! problemCount ^environment isClassEnvironment ifTrue: [self numberClasses] ifFalse: [super problemCount]! ! !RBAndEnvironment methodsFor: 'printing' stamp: 'CamilloBruni 8/27/2013 02:29'! printOn: aStream environment printOn: aStream. aStream nextPutAll: ' & '. andedEnvironment printOn: aStream.! ! !RBAndEnvironment methodsFor: 'accessing' stamp: ''! numberSelectors | total | total := 0. environment classesAndSelectorsDo: [:each :sel | (andedEnvironment includesSelector: sel in: each) ifTrue: [total := total + 1]]. ^total! ! !RBAndEnvironment methodsFor: 'accessing' stamp: 'bh 5/8/2000 21:01'! selectionIntervalFor: aString | interval | interval := super selectionIntervalFor: aString. interval notNil ifTrue: [^interval]. ^andedEnvironment selectionIntervalFor: aString ! ! !RBAndEnvironment methodsFor: 'accessing' stamp: ''! selectorsForClass: aClass do: aBlock environment selectorsForClass: aClass do: [:each | (andedEnvironment includesSelector: each in: aClass) ifTrue: [aBlock value: each]]! ! !RBAndEnvironment class methodsFor: 'instance creation' stamp: ''! onEnvironment: anEnvironment and: anotherEnvironment ^(self onEnvironment: anEnvironment) andedEnvironment: anotherEnvironment; yourself! ! !RBArgumentNode commentStamp: ''! I am a specific variable node for method and block arguments.! !RBArgumentNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:32'! isArgument ^ true! ! !RBArgumentNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:35'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitArgumentNode: self! ! !RBArrayNode commentStamp: ''! A RBArrayNode is an AST node for runtime arrays. Instance Variables left: position of { periods: the positions of all the periods that separate the statements right: position of } statements: the statement nodes! !RBArrayNode methodsFor: 'testing' stamp: 'lr 10/18/2009 16:11'! isArray ^ true! ! !RBArrayNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:44'! addNodes: aCollection before: anotherNode aCollection do: [ :each | self addNode: each before: anotherNode ]. ^ aCollection! ! !RBArrayNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:23'! periods: anArray periods := anArray! ! !RBArrayNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:44'! addNodesFirst: aCollection statements := statements asOrderedCollection addAllFirst: aCollection; yourself. aCollection do: [ :each | each parent: self ]. ^ aCollection! ! !RBArrayNode methodsFor: 'accessing-token' stamp: 'lr 11/1/2009 19:52'! right: anInteger right := anInteger! ! !RBArrayNode methodsFor: 'accessing' stamp: 'lr 11/1/2009 19:53'! stopWithoutParentheses ^ right! ! !RBArrayNode methodsFor: 'accessing-token' stamp: 'lr 11/1/2009 19:52'! left ^ left! ! !RBArrayNode methodsFor: 'accessing' stamp: 'lr 11/1/2009 18:36'! children ^ self statements! ! !RBArrayNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:29'! isFaulty ^self statements anySatisfy: #isFaulty! ! !RBArrayNode methodsFor: 'accessing-token' stamp: 'lr 11/1/2009 19:52'! right ^ right! ! !RBArrayNode methodsFor: 'initialization' stamp: 'lr 8/14/2011 12:01'! initialize super initialize. statements := periods := #()! ! !RBArrayNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:42'! addNodeFirst: aNode statements := statements asOrderedCollection addFirst: aNode; yourself. aNode parent: self. ^ aNode! ! !RBArrayNode methodsFor: 'accessing' stamp: 'ls 1/24/2000 00:32'! statements ^statements! ! !RBArrayNode methodsFor: 'accessing' stamp: 'lr 6/6/2008 16:16'! statements: statements0 statements := statements0. statements do: [:statement | statement parent: self]! ! !RBArrayNode methodsFor: 'private' stamp: 'lr 5/15/2010 17:29'! indexOfNode: aNode "Try to find the node by first looking for ==, and then for =" ^ (1 to: statements size) detect: [ :each | (statements at: each) == aNode ] ifNone: [ statements indexOf: aNode ]! ! !RBArrayNode methodsFor: 'testing' stamp: 'lr 11/1/2009 18:39'! references: aVariableName ^ statements anySatisfy: [ :each | each references: aVariableName ]! ! !RBArrayNode methodsFor: 'testing' stamp: 'ls 1/24/2000 00:28'! lastIsReturn statements isEmpty ifTrue:[ ^false ]. ^statements last lastIsReturn! ! !RBArrayNode methodsFor: 'comparing' stamp: 'lr 3/7/2010 13:48'! hash ^ self hashForCollection: self statements! ! !RBArrayNode methodsFor: 'accessing-token' stamp: 'lr 11/1/2009 20:44'! periods ^ periods! ! !RBArrayNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:35'! copyInContext: aDictionary ^ self class statements: (self copyList: self statements inContext: aDictionary)! ! !RBArrayNode methodsFor: 'accessing' stamp: 'lr 4/26/2010 20:44'! precedence ^0! ! !RBArrayNode methodsFor: 'replacing' stamp: 'lr 6/6/2008 16:15'! replaceNode: oldNode withNode: newNode self statements: (statements collect: [ :statement | statement == oldNode ifTrue: [ newNode ] ifFalse: [ statement ] ])! ! !RBArrayNode methodsFor: 'accessing' stamp: 'lr 11/1/2009 19:52'! startWithoutParentheses ^ left! ! !RBArrayNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:40'! addNode: aNode before: anotherNode | index | aNode isReturn ifTrue: [ self error: 'Cannot add return node' ]. index := self indexOfNode: anotherNode. index = 0 ifTrue: [ ^ self addNode: aNode ]. statements := statements asOrderedCollection add: aNode beforeIndex: index; yourself. aNode parent: self. ^ aNode! ! !RBArrayNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:36'! acceptVisitor: aProgramNodeVisitor ^ aProgramNodeVisitor visitArrayNode: self! ! !RBArrayNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:43'! addNodes: aCollection statements := statements asOrderedCollection addAll: aCollection; yourself. aCollection do: [ :each | each parent: self ]. ^ aCollection! ! !RBArrayNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:40'! addNode: aNode statements := statements asOrderedCollection add: aNode; yourself. aNode parent: self. ^ aNode! ! !RBArrayNode methodsFor: 'comparing' stamp: 'lr 10/18/2009 16:15'! equalTo: anObject withMapping: aDictionary self class = anObject class ifFalse: [ ^ false ]. self statements size = anObject statements size ifFalse: [ ^ false ]. self statements with: anObject statements do: [ :first :second | (first equalTo: second withMapping: aDictionary) ifFalse: [ ^ false ] ]. aDictionary values asSet size = aDictionary size ifFalse: [ ^ false ]. ^ true! ! !RBArrayNode methodsFor: 'testing' stamp: 'lr 11/1/2009 18:40'! uses: aNode ^ (statements anySatisfy: [ :each | each == aNode ]) or: [ self isUsed ]! ! !RBArrayNode methodsFor: 'comparing' stamp: 'lr 11/1/2009 18:36'! = anObject self == anObject ifTrue: [ ^ true ]. self class = anObject class ifFalse: [ ^ false ]. self statements size = anObject statements size ifFalse: [ ^ false ]. 1 to: self statements size do: [ :i | (self statements at: i) = (anObject statements at: i) ifFalse: [ ^ false ] ]. ^ true! ! !RBArrayNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:36'! postCopy super postCopy. self statements: (self statements collect: [ :each | each copy ])! ! !RBArrayNode methodsFor: 'accessing-token' stamp: 'lr 11/1/2009 19:52'! left: anInteger left := anInteger! ! !RBArrayNode methodsFor: 'matching' stamp: 'lr 5/30/2010 11:34'! match: aNode inContext: aDictionary aNode class = self class ifFalse: [ ^ false ]. ^ self matchList: statements against: aNode statements inContext: aDictionary! ! !RBArrayNode methodsFor: 'testing' stamp: 'lr 11/1/2009 20:24'! needsParenthesis ^ false! ! !RBArrayNode methodsFor: 'accessing' stamp: 'lr 11/1/2009 20:25'! statementComments ^self comments! ! !RBArrayNode class methodsFor: 'instance creation' stamp: 'ajh 3/4/2003 02:03'! statements: statements ^ self new statements: statements! ! !RBAsOrderedCollectionNotNeededRule commentStamp: ''! See rationale! !RBAsOrderedCollectionNotNeededRule methodsFor: 'initialization' stamp: 'CAMILLETERUEL 3/29/2013 12:42'! initialize super initialize. #('addAll:' 'withAll:' 'removeAll:' 'includesAll:' 'copyWithoutAll:') do: [ :collectionMessage | #('asArray' 'asOrderedCollection' 'asSortedCollection') do: [ :conversionMessage | | baseString | baseString := '``@receiver ' , collectionMessage , ' ``@arg '. self rewriteRule replace: baseString , conversionMessage with: baseString ] ]! ! !RBAsOrderedCollectionNotNeededRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:44'! rationale ^ 'A prior convertion to an Array or OrderedCollection is not necessary when adding all elements to a collection.'! ! !RBAsOrderedCollectionNotNeededRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBAsOrderedCollectionNotNeededRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ '#asOrderedCollection/#asArray not needed'! ! !RBAsOrderedCollectionNotNeededRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:19'! category ^'Optimization'! ! !RBAsOrderedCollectionNotNeededRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'AsOrderedCollectionNotNeededRule'! ! !RBAssignmentInBlockRule methodsFor: 'initialization' stamp: 'lr 11/19/2009 14:47'! initialize super initialize. self matcher matchesAnyOf: #( '`@cursor showWhile: [| `@temps | `@.Statements1. `var := `@object]' '`@cursor showWhile: [| `@temps | `@.Statements1. ^`@object]' '[| `@temps | `@.Statements. `var := `@object] ensure: `@block' '[| `@temps | `@.Statements. ^`@object] ensure: `@block' '[| `@temps | `@.Statements. `var := `@object] ifCurtailed: `@block' '[| `@temps | `@.Statements. ^`@object] ifCurtailed: `@block' ) do: [ :node :answer | node ]! ! !RBAssignmentInBlockRule methodsFor: 'accessing' stamp: 'lr 11/19/2009 14:47'! rationale ^ 'Checks ensure:, ifCurtailed:, and showWhile: blocks for assignments or returns that are the last statement in the block. These assignments or returns can be moved outside the block since these messages return the value of the block.'! ! !RBAssignmentInBlockRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBAssignmentInBlockRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Unnecessary assignment or return in block'! ! !RBAssignmentInBlockRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:20'! category ^'Coding Idiom Violation'! ! !RBAssignmentInBlockRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'AssignmentInBlockRule'! ! !RBAssignmentInIfTrueRule commentStamp: ''! See rationale! !RBAssignmentInIfTrueRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:24'! initialize super initialize. self rewriteRule replace: '``@Boolean ifTrue: [`variable := ``@true] ifFalse: [`variable := ``@false]' with: '`variable := ``@Boolean ifTrue: [``@true] ifFalse: [``@false]'; replace: '``@Boolean ifFalse: [`variable := ``@true] ifTrue: [`variable := ``@false]' with: '`variable := ``@Boolean ifFalse: [``@true] ifTrue: [``@false]'! ! !RBAssignmentInIfTrueRule methodsFor: 'accessing' stamp: 'lr 9/7/2010 20:25'! rationale ^ 'Moving assignements outside blocks leads to shorter and more efficient code.'! ! !RBAssignmentInIfTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBAssignmentInIfTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Move variable assignment outside of single statement ifTrue:ifFalse: blocks'! ! !RBAssignmentInIfTrueRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:48'! category ^ 'Optimization'! ! !RBAssignmentInIfTrueRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/12/2012 13:55'! longDescription ^ 'Moving assignements outside blocks leads to shorter and more efficient code. For example: test ifTrue: [var := 1] ifFlase: [var:= 2] is equivalent to: var := test ifTrue: [1] ifFlase: [2]'! ! !RBAssignmentInIfTrueRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'AssignmentInIfTrueRule'! ! !RBAssignmentNode commentStamp: ''! RBAssignmentNode is an AST node for assignment statements Instance Variables: assignment position of the := value the value that we're assigning variable the variable being assigned ! !RBAssignmentNode methodsFor: 'testing' stamp: ''! directlyUses: aNode ^aNode = value ifTrue: [true] ifFalse: [self isDirectlyUsed]! ! !RBAssignmentNode methodsFor: 'initialize-release' stamp: ''! variable: aVariableNode value: aValueNode position: anInteger self variable: aVariableNode. self value: aValueNode. assignment := anInteger! ! !RBAssignmentNode methodsFor: 'accessing' stamp: ''! stopWithoutParentheses ^value stop! ! !RBAssignmentNode methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 6/12/2013 13:49'! specialCommands ^ SugsSuggestionFactory commandsForAssignment.! ! !RBAssignmentNode methodsFor: 'querying' stamp: 'ClementBera 7/26/2013 17:15'! bestNodeFor: anInterval (self intersectsInterval: anInterval) ifFalse: [^nil]. (self containedBy: anInterval) ifTrue: [^self]. assignment ifNil: [^super bestNodeFor: anInterval]. ((anInterval first between: assignment and: assignment + 1) or: [assignment between: anInterval first and: anInterval last]) ifTrue: [^self]. self children do: [:each | | node | node := each bestNodeFor: anInterval. node notNil ifTrue: [^node]]! ! !RBAssignmentNode methodsFor: 'accessing' stamp: ''! children ^Array with: value with: variable! ! !RBAssignmentNode methodsFor: 'replacing' stamp: 'lr 12/4/2009 15:23'! replaceSourceWith: aNode "Check if we need to convert the assignment. Also check if we are being replaced with a setter message send. If so, create the replacements to edit the original source." (aNode isAssignment and: [ aNode assignmentOperator ~= self assignmentOperator ]) ifTrue: [ self addReplacement: (RBStringReplacement replaceFrom: self assignmentPosition to: self assignmentPosition + self assignmentOperator size - 1 with: aNode assignmentOperator). (aNode variable = variable and: [ aNode value = value ]) ifTrue: [ ^ self ] ]. aNode isMessage ifFalse: [^super replaceSourceWith: aNode]. aNode receiver isVariable ifFalse: [^super replaceSourceWith: aNode]. aNode numArgs = 1 ifFalse: [^super replaceSourceWith: aNode]. (self mappingFor: self value) = aNode arguments first ifFalse: [^super replaceSourceWith: aNode]. (self value hasParentheses not and: [aNode arguments first precedence >= aNode precedence]) ifTrue: [self addReplacement: (RBStringReplacement replaceFrom: self value start to: self value start - 1 with: '('); addReplacement: (RBStringReplacement replaceFrom: self value stop + 1 to: self value stop with: ')')]. self addReplacement: (RBStringReplacement replaceFrom: self variable start to: self assignmentPosition + 1 with: aNode receiver name , ' ' , aNode selector)! ! !RBAssignmentNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/10/2013 13:31'! isFaulty ^self variable isFaulty or: [ self value isFaulty].! ! !RBAssignmentNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:23'! assignment ^ assignment! ! !RBAssignmentNode methodsFor: 'accessing' stamp: 'StephaneDucasse 3/29/2013 17:33'! assignmentOperator ^ ':=' ! ! !RBAssignmentNode methodsFor: 'accessing' stamp: ''! value ^value! ! !RBAssignmentNode methodsFor: 'accessing' stamp: ''! value: aValueNode value := aValueNode. value parent: self! ! !RBAssignmentNode methodsFor: 'testing' stamp: ''! assigns: aVariableName ^variable name = aVariableName or: [value assigns: aVariableName]! ! !RBAssignmentNode methodsFor: 'comparing' stamp: ''! hash ^self variable hash bitXor: self value hash! ! !RBAssignmentNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:35'! copyInContext: aDictionary ^ self class new variable: (self variable copyInContext: aDictionary); value: (self value copyInContext: aDictionary); yourself! ! !RBAssignmentNode methodsFor: 'accessing' stamp: ''! variable: varNode variable := varNode. variable parent: self! ! !RBAssignmentNode methodsFor: 'accessing' stamp: ''! precedence ^5! ! !RBAssignmentNode methodsFor: 'replacing' stamp: ''! replaceNode: aNode withNode: anotherNode value == aNode ifTrue: [self value: anotherNode]. variable == aNode ifTrue: [self variable: anotherNode]! ! !RBAssignmentNode methodsFor: 'accessing' stamp: ''! startWithoutParentheses ^variable start! ! !RBAssignmentNode methodsFor: 'comparing' stamp: ''! equalTo: anObject withMapping: aDictionary ^self class = anObject class and: [(self variable equalTo: anObject variable withMapping: aDictionary) and: [self value equalTo: anObject value withMapping: aDictionary]]! ! !RBAssignmentNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:36'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitAssignmentNode: self! ! !RBAssignmentNode methodsFor: 'testing' stamp: ''! uses: aNode ^aNode = value ifTrue: [true] ifFalse: [self isUsed]! ! !RBAssignmentNode methodsFor: 'testing' stamp: ''! isAssignment ^true! ! !RBAssignmentNode methodsFor: 'comparing' stamp: ''! = anObject self == anObject ifTrue: [^true]. self class = anObject class ifFalse: [^false]. ^self variable = anObject variable and: [self value = anObject value]! ! !RBAssignmentNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:35'! postCopy super postCopy. self variable: self variable copy. self value: self value copy! ! !RBAssignmentNode methodsFor: 'accessing' stamp: ''! variable ^variable! ! !RBAssignmentNode methodsFor: 'matching' stamp: 'lr 5/30/2010 11:34'! match: aNode inContext: aDictionary aNode class = self class ifFalse: [^false]. ^(variable match: aNode variable inContext: aDictionary) and: [value match: aNode value inContext: aDictionary]! ! !RBAssignmentNode methodsFor: 'testing' stamp: 'ClementBera 7/26/2013 17:15'! needsParenthesis ^parent ifNil: [false] ifNotNil: [self precedence > parent precedence]! ! !RBAssignmentNode methodsFor: 'accessing' stamp: 'lr 11/2/2009 20:50'! assignmentPosition ^ assignment! ! !RBAssignmentNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:24'! assignment: anInteger assignment := anInteger! ! !RBAssignmentNode class methodsFor: 'instance creation' stamp: ''! variable: aVariableNode value: aValueNode position: anInteger ^(self new) variable: aVariableNode value: aValueNode position: anInteger; yourself! ! !RBAssignmentNode class methodsFor: 'instance creation' stamp: ''! variable: aVariableNode value: aValueNode ^self variable: aVariableNode value: aValueNode position: nil! ! !RBAssignmentToken commentStamp: 'md 8/9/2005 14:51'! RBAssignmentToken is the first-class representation of the assignment token ':=' ! !RBAssignmentToken methodsFor: 'private' stamp: ''! length ^2! ! !RBAssignmentToken methodsFor: 'testing' stamp: ''! isAssignment ^true! ! !RBAssignmentWithoutEffectRule methodsFor: 'initialization' stamp: 'lr 3/13/2009 13:56'! initialize super initialize. self matcher matches: '`var := `var' do: [ :node :answer | node ]! ! !RBAssignmentWithoutEffectRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:42'! category ^ 'Optimization'! ! !RBAssignmentWithoutEffectRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:41'! longDescription ^'This smell arises when a statement such as x := x is found. This statement has not effect, it can be removed.'! ! !RBAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 13:55'! rationale ^ 'A statement such as x := x has no effect.'! ! !RBAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 13:55'! group ^ 'Unnecessary code'! ! !RBAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:09'! severity ^ #information! ! !RBAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 13:55'! name ^ 'Assignment has no effect'! ! !RBAssignmentWithoutEffectRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'AssignmentWithoutEffectRule'! ! !RBAtIfAbsentRule commentStamp: ''! See rationale! !RBAtIfAbsentRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:26'! initialize super initialize. self rewriteRule replace: '``@dictionary at: ``@key ifAbsent: [| `@temps | ``@.Statements1. ``@dictionary at: ``@key put: ``@object. ``@.Statements2. ``@object]' with: '``@dictionary at: ``@key ifAbsentPut: [| `@temps | ``@.Statements1. ``@.Statements2. ``@object]'; replace: '``@dictionary at: ``@key ifAbsent: [| `@temps | ``@.Statements. ``@dictionary at: ``@key put: ``@object]' with: '``@dictionary at: ``@key ifAbsentPut: [| `@temps | ``@.Statements. ``@object]'! ! !RBAtIfAbsentRule methodsFor: 'accessing' stamp: 'lr 9/7/2010 20:26'! rationale ^ 'The use of #at:ifAbsentPut: leads to more readable and faster code.'! ! !RBAtIfAbsentRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBAtIfAbsentRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'at:ifAbsent: -> at:ifAbsentPut:'! ! !RBAtIfAbsentRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:48'! category ^ 'Coding Idiom Violation'! ! !RBAtIfAbsentRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/12/2012 14:40'! longDescription ^ ' Replaces at:ifAbsent: by at:ifAbsentPut:'! ! !RBAtIfAbsentRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'AtIfAbsentRule'! ! !RBBadMessageRule commentStamp: ''! See my #rationale. The message sends I identify often suggest poor design, costly execution, or other inadequate practices. See #badSelectors for the list of messages that are checked.! !RBBadMessageRule methodsFor: 'private' stamp: 'CamilleTeruel 9/18/2013 11:25'! badSelectors ^ #( #become: #isKindOf: #changeClassToThatOf: #respondsTo: #isMemberOf: #perform: #perform:arguments: #perform:with: #perform:with:with: #perform:with:with:with: #allOwners #instVarAt: #instVarAt:put: #nextInstance instVarsInclude: #nextObject #halt caseOf: caseOf:otherwise: caseError isThisEverCalled isThisEverCalled: becomeForward: instVarNamed: instVarNamed:put: someObject primitiveChangeClassTo:)! ! !RBBadMessageRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 09:59'! category ^ 'Coding Idiom Violation'! ! !RBBadMessageRule methodsFor: '*Manifest-Core' stamp: 'ah 8/2/2012 13:27'! longDescription ^ 'This smell arises when methods send messages that perform low level things. You might want to limit the number of such messages in your application. Messages such as #isKindOf: can signify a lack of polymorphism. You can see which methods are "questionable" by editing the RBBadMessageRule>>badSelectors method. Some examples are: #respondsTo: #isMemberOf: #performMethod: and #performMethod:arguments:'! ! !RBBadMessageRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check methods that send messages that perform low level things. You might want to limit the number of such messages in your application. For example, using become: throughout your application might not be the best thing. Also, messages such as isKindOf: can signify a lack of polymorphism. You can change which methods are "questionable" by editing the BasicLintRule>>badSelectors method.'! ! !RBBadMessageRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBBadMessageRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Sends "questionable" message'! ! !RBBadMessageRule methodsFor: 'running' stamp: 'CamilleTeruel 11/14/2013 14:06'! checkMethod: aContext self badSelectors do: [ :badSelector | (aContext compiledMethod sendsSelector: badSelector) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector; searchStrings: self badSelectors ] ] ! ! !RBBadMessageRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'BadMessageRule'! ! !RBBasicLintRule commentStamp: ''! I am a rule that has a result. It is not clear why it is not merged with its superclass but this is ok too.! !RBBasicLintRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 08:28'! resultClass self subclassResponsibility! ! !RBBasicLintRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 21:39'! initialize super initialize. self resetResult ! ! !RBBasicLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:40'! problemCount ^ self result problemCount! ! !RBBasicLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:37'! isEmpty ^ self result isEmpty! ! !RBBasicLintRule methodsFor: 'running' stamp: 'lr 2/23/2009 21:39'! resetResult result := self resultClass new. result label: self name! ! !RBBasicLintRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! filteredResult "Be very careful when filtering results not to introduce new items and not to lose the dedicated browser environments. Try the following steps in order: - If this is a selector environment use the set-operations of the refactoring browser. - If this is a class environment, remove the classes that have a filter annotation in any of its methods. - If this is a variable environment, remove the classes and all its variables that have a filter annotation in any of its methods. - Otherwise return the unfiltered environment." | filter | result isEmpty ifTrue: [ ^ result ]. filter := RBPragmaEnvironment onEnvironment: RBBrowserEnvironment new keywords: #( lint: lint:rationale: lint:rationale:author: lint:author: ignoreLintRule: ignoreLintRule:rationale: ignoreLintRule:rationale:author: ignoreLintRule:author: ). filter condition: [ :pragma | pragma arguments first = self name or: [ pragma arguments first = self group or: [ pragma arguments first = self class name ] ] ]. result isSelectorEnvironment ifTrue: [ ^ (result & filter not) label: result label ]. result isClassEnvironment ifTrue: [ filter classesDo: [ :class | result removeClass: class theMetaClass; removeClass: class theNonMetaClass ] ] ifFalse: [ result isVariableEnvironment ifTrue: [ filter classesDo: [ :class | class classVarNames do: [ :var | result removeClass: class classVariable: var ]. class instVarNames do: [ :var | result removeClass: class instanceVariable: var ] ] ] ]. ^ result! ! !RBBasicLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:40'! result ^ result! ! !RBBasicLintRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'BasicLintRule'! ! !RBBasicLintRuleTest methodsFor: 'initialize-release' stamp: ''! methodBlock: aBlock methodBlock := aBlock! ! !RBBasicLintRuleTest methodsFor: 'testing' stamp: ''! isEmpty ^result isEmpty! ! !RBBasicLintRuleTest methodsFor: 'private' stamp: ''! viewResults result openEditor! ! !RBBasicLintRuleTest methodsFor: 'accessing' stamp: ''! result ^result! ! !RBBasicLintRuleTest methodsFor: 'accessing' stamp: ''! checkMethod: aSmalllintContext ^methodBlock value: aSmalllintContext value: result! ! !RBBasicLintRuleTest methodsFor: 'accessing' stamp: ''! checkClass: aSmalllintContext ^classBlock value: aSmalllintContext value: result! ! !RBBasicLintRuleTest methodsFor: 'initialization' stamp: 'lr 9/8/2011 20:32'! initialize super initialize. classBlock := [:context :aResult | ]. methodBlock := [:context :aResult | ]. self resultClass: RBSelectorEnvironment! ! !RBBasicLintRuleTest methodsFor: 'accessing' stamp: ''! problemCount ^result problemCount! ! !RBBasicLintRuleTest methodsFor: 'initialize-release' stamp: ''! resetResult result := result copyEmpty. result label: name! ! !RBBasicLintRuleTest methodsFor: 'initialize-release' stamp: ''! resultClass: aClass result := aClass new! ! !RBBasicLintRuleTest methodsFor: 'accessing' stamp: 'bh 4/3/2000 10:19'! foobar ^#( true false )! ! !RBBasicLintRuleTest methodsFor: 'initialize-release' stamp: ''! classBlock: aBlock classBlock := aBlock testMethod1! ! !RBBasicLintRuleTest methodsFor: 'initialize-release' stamp: ''! result: aResult result := aResult copyEmpty! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: 'lr 11/2/2009 00:14'! collectionMessagesToExternalObject | detector matcher | detector := self new. detector name: 'Sends add:/remove: to external collection'. matcher := RBParseTreeSearcher new. matcher addSearches: (#(#add: #remove: #addAll: #removeAll:) collect: [:each | ('(`@Object `@message: `@args) <1s> `@Arg' expandMacrosWith: each) asString]) -> [:aNode :answer | answer or: [(aNode receiver selector copyFrom: 1 to: (aNode receiver selector size min: 2)) ~= 'as' and: [| receiver | receiver := aNode receiver receiver. receiver isVariable not or: [((#('self' 'super') includes: receiver name) or: [Smalltalk includesKey: receiver name asSymbol]) not]]]]. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: ''! atIfAbsent ^self createParseTreeRule: #('`@object at: `@atArg ifAbsent: [| `@temps | `@.Statements. `@object at: `@atArg put: `@putArg]' '`@object at: `@atArg ifAbsent: [| `@temps | `@.Statements. `@object at: `@atArg put: `@putArg. `@.xStatements1. `@putArg]') name: 'Uses at:ifAbsent: instead of at:ifAbsentPut:'! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'lr 9/8/2011 20:32'! collectionCopyEmpty | detector | detector := self new. detector name: 'Subclass of collection that has instance variable but doesn''t define copyEmpty'. detector resultClass: RBClassEnvironment. detector classBlock: [:context :result | (context selectedClass isVariable and: [(context selectedClass includesSelector: #copyEmpty:) not and: [context selectedClass instVarNames isEmpty not and: [context selectedClass inheritsFrom: Collection]]]) ifTrue: [result addClass: context selectedClass]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'lr 11/2/2009 00:14'! usesAdd | detector addSearcher | detector := self new. detector name: 'Uses the result of an add: message'. addSearcher := RBParseTreeSearcher usesResultOfAdd. detector methodBlock: [:context :result | (addSearcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: ''! collectionProtocol ^self createParseTreeRule: #('`@collection do: [:`each | | `@temps | `@.Statements1. `@object add: `@arg. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifTrue: [| `@blockTemps | `@.BlockStatements1. `@object add: `each. `@.BlockStatements2]. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifFalse: [| `@blockTemps | `@.BlockStatements1. `@object add: `each. `@.BlockStatements2]. `@.Statements2]') name: 'Uses do: instead of collect: or select:''s'! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: 'lr 10/26/2009 22:11'! refersToClass | detector | detector := self new. detector name: 'Refers to class name instead of "self class"'. detector classBlock: [:context :result | | sels className | className := context selectedClass theNonMetaClass name. sels := context selectedClass whichSelectorsReferTo: (Smalltalk associationAt: className). sels isEmpty ifFalse: [result addSearchString: className. sels do: [:each | result addClass: context selectedClass selector: each]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: ''! sentNotImplementedInApplication | detector | detector := self new. detector name: 'Messages sent but not implemented in application'. detector methodBlock: [:context :result | | message class block | message := context messages detect: [:each | (context isItem: each in: context application) not] ifNone: [nil]. class := context selectedClass. block := [:each | | app | app := context application. (self canCall: each in: class from: app) not]. message isNil ifTrue: [message := context selfMessages detect: block ifNone: [nil]]. message isNil ifTrue: [class := class superclass. class isNil ifTrue: [context superMessages isEmpty ifFalse: [message := context superMessages asArray first]] ifFalse: [message := context superMessages detect: block ifNone: [nil]]]. message notNil ifTrue: [result addSearchString: message. result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'private' stamp: 'CamilleTeruel 9/18/2013 11:25'! badSelectors ^#(#become: #isKindOf: #changeClassToThatOf: #respondsTo: #isMemberOf: #perform: #perform:arguments: #perform:with: #perform:with:with: #perform:with:with:with: #allOwners #allOwnersWeakly: #firstOwner #instVarAt: #instVarAt:put: #nextInstance #nextObject #ownerAfter: #primBecome: #halt)! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: ''! guardingClause ^self createParseTreeRule: #('`@MethodName: `@args | `@temps | `@.Statements. `@condition ifTrue: [| `@BlockTemps | `.Statement1. `.Statement2. `@.BStatements]' '`@MethodName: `@args | `@temps | `@.Statements. `@condition ifFalse: [| `@BlockTemps | `.Statement1. `.Statement2. `@.BStatements]') method: true name: 'Guarding clauses'! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: 'lr 11/19/2009 14:47'! assignmentInBlock ^self createParseTreeRule: #( '`@cursor showWhile: [| `@temps | `@.Statements1. `var := `@object]' '`@cursor showWhile: [| `@temps | `@.Statements1. ^`@object]' '[| `@temps | `@.Statements. `var := `@object] ensure: `@block' '[| `@temps | `@.Statements. ^`@object] ensure: `@block' '[| `@temps | `@.Statements. `var := `@object] ifCurtailed: `@block' '[| `@temps | `@.Statements. ^`@object] ifCurtailed: `@block' ) name: 'Unnecessary assignment or return in block'! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: 'lr 9/5/2010 10:40'! missingSubclassResponsibility | detector | detector := self new. detector name: 'Method defined in all subclasses, but not in superclass'. "detector resultClass: MultiEnvironment." detector classBlock: [:context :result | | subs | subs := context selectedClass subclasses. subs size > 1 & context selectedClass isMetaclass not ifTrue: [| sels | sels := Bag new. subs do: [:each | sels addAll: each selectors]. sels asSet do: [:each | ((sels occurrencesOf: each) == subs size and: [(context selectedClass canUnderstand: each) not]) ifTrue: [| envName | envName := context selectedClass name , '>>', each. subs do: [:subClass | result addClass: subClass selector: each into: envName]]]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: ''! returnsIfTrue ^self createParseTreeRule: #('^`@condition ifTrue: [| `@temps | `@.statements]' '^`@condition ifFalse: [| `@temps | `@.statements]') name: 'Returns value of ifTrue:/ifFalse: without ifFalse:/ifTrue: block'! ! !RBBasicLintRuleTest class methodsFor: 'private' stamp: ''! metaclassShouldNotOverride ^#(#name #comment)! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'lr 9/8/2011 20:32'! definesEqualNotHash | detector | detector := self new. detector name: 'Defines = but not hash'. detector resultClass: RBClassEnvironment. detector classBlock: [:context :result | ((context selectedClass includesSelector: #=) and: [(context selectedClass includesSelector: #hash) not]) ifTrue: [result addClass: context selectedClass]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'lr 11/2/2009 00:14'! tempVarOverridesInstVar | detector matcher vars varName | detector := self new. detector name: 'Instance variable overridden by temporary variable'. matcher := (RBParseTreeSearcher new) addArgumentSearch: '`xxxvar' -> [:aNode :answer | answer or: [varName := aNode name. vars includes: varName]]; yourself. detector methodBlock: [:context :result | vars := context instVarNames. (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector. result addSearchString: varName]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'bugs' stamp: 'lr 9/8/2011 20:32'! overridesSpecialMessage | detector | detector := self new. detector name: 'Overrides a "special" message'. detector resultClass: RBClassEnvironment. detector classBlock: [:context :result | ((context selectedClass isMetaclass ifTrue: [self metaclassShouldNotOverride] ifFalse: [self classShouldNotOverride]) detect: [:each | context selectedClass superclass notNil and: [(context selectedClass superclass canUnderstand: each) and: [context selectedClass includesSelector: each]]] ifNone: [nil]) notNil ifTrue: [result addClass: context selectedClass]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: ''! instVarInSubclasses | detector | detector := self new. detector name: 'Instance variables defined in all subclasses'. detector result: nil pullUpInstVar. detector classBlock: [:context :result | | subs | subs := context selectedClass subclasses. subs size > 1 ifTrue: [| sels | sels := Bag new. subs do: [:each | sels addAll: each instVarNames]. sels asSet do: [:val | (sels occurrencesOf: val) == subs size ifTrue: [result addInstVar: val for: context selectedClass]]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: ''! detectContains ^self createParseTreeRule: #('`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifFalse: [| `@BlockTemps | `@.BlockStatements1. ^`each]. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifTrue: [| `@BlockTemps | `@.BlockStatements1. ^`each]. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifFalse: [| `@BlockTemps | `@.BlockStatements1. ^true]. `@.Statements2]' '`@Collection do: [:`each | | `@temps | `@.Statements1. `@condition ifTrue: [| `@BlockTemps | `@.BlockStatements1. ^true]. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifFalse: [| `@BlockTemps | `@.BlockStatements1. ^false]. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifTrue: [| `@BlockTemps | `@.BlockStatements1. ^false]. `@.Statements2]') name: 'Uses do: instead of contains: or detect:''s'! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'MarcusDenker 9/20/2013 15:06'! returnsBooleanAndOther | detector matcher | detector := self new. detector name: 'Returns a boolean and non boolean'. matcher := RBParseTreeSearcher new. matcher addSearch: '^``@xObject' -> [:aNode :answer | answer add: aNode value; yourself]. detector methodBlock: [:context :result | | hasBool hasSelf | hasBool := false. hasSelf := context parseTree lastIsReturn not. (matcher executeTree: context parseTree initialAnswer: Set new) do: [:each | hasBool := hasBool or: [(each isLiteralNode and: [{true. false} includes: each value]) or: [each isMessage and: [#(#and: #or:) includes: each selector]]]. hasSelf := hasSelf or: [(each isVariable and: [each name = 'self']) or: [each isLiteralNode and: [({true. false} includes: each value) not]]]]. hasSelf & hasBool ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'private' stamp: 'lr 11/2/2009 00:14'! createMatcherFor: codeStrings method: aBoolean | matcher | matcher := RBParseTreeSearcher new. aBoolean ifTrue: [matcher addMethodSearches: codeStrings -> [:aNode :answer | true]] ifFalse: [matcher addSearches: codeStrings -> [:aNode :answer | true]]. ^matcher! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code' stamp: 'lr 9/8/2011 20:32'! classNotReferenced | detector | detector := self new. detector name: 'Class not referenced'. detector resultClass: RBClassEnvironment. detector classBlock: [:context :result | (context selectedClass isMetaclass or: [context isApplication or: [context selectedClass subclasses isEmpty not]]) ifFalse: [| assoc | assoc := Smalltalk associationAt: context selectedClass name. ((context uses: assoc) or: [context uses: context selectedClass name]) ifFalse: [result addClass: context selectedClass; addClass: context selectedClass class]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: 'lr 11/2/2009 00:14'! precedence | detector matcher | detector := self new. detector name: 'Inspect instances of "A + B * C" might be "A + (B * C)"'. matcher := RBParseTreeSearcher new. matcher addSearches: #('``@A + ``@B * ``@C' '``@A - ``@B * ``@C') -> [:aNode :answer | answer or: [aNode receiver parentheses isEmpty]]. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'lr 11/2/2009 00:14'! missingYourself | detector matcher | detector := self new. detector name: 'Possible missing "; yourself"'. matcher := RBParseTreeSearcher new. matcher addSearch: '``@xobject `@messages: ``@args' -> [:aNode :answer | answer or: [aNode parent isCascade and: [aNode isDirectlyUsed and: [aNode selector ~~ #yourself]]]]. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'private' stamp: ''! superMessages ^#(#release #postCopy #postBuildWith: #preBuildWith: #postOpenWith: #noticeOfWindowClose: #initialize)! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: 'lr 10/26/2009 22:11'! classNameInSelector | detector | detector := self new. detector name: 'Redundant class name in selector'. detector methodBlock: [:context :result | (context selectedClass isMetaclass and: [(context selector indexOfSubCollection: context selectedClass theNonMetaClass name startingAt: 1) > 0]) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code' stamp: ''! implementedNotSent | detector | detector := self new. detector name: 'Methods implemented but not sent'. detector methodBlock: [:context :result | (context uses: context selector) ifFalse: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: 'MarcusDenker 9/20/2013 15:28'! variableAssignedLiteral | detector | detector := self new. detector name: 'Variable is only assigned a single literal value'. detector result: nil references. detector classBlock: [:context :result | | allSubclasses | allSubclasses := context selectedClass withAllSubclasses. context selectedClass instVarNames do: [:each | | defClass selector | (allSubclasses inject: 0 into: [:sum :class | | sels | sels := class whichSelectorsWrite: each. sels size == 1 ifTrue: [selector := sels asArray first. defClass := class]. sum + sels size]) == 1 ifTrue: [| tree searcher | searcher := RBParseTreeSearcher new. searcher addSearch: (each , ' := ``@object') -> [:aNode :answer | answer isNil and: [aNode value isLiteralNode]]. tree := defClass parseTreeFor: selector. tree notNil ifTrue: [(searcher executeTree: tree initialAnswer: nil) == true ifTrue: [result addInstVar: each for: context selectedClass]]]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code' stamp: ''! variableReferencedOnce | detector | detector := self new. detector name: 'Variable referenced in only one method and always assigned first'. detector classBlock: [:context :result | | allSubclasses | allSubclasses := context selectedClass withAllSubclasses. context selectedClass instVarNames do: [:each | | defClass selector | (allSubclasses inject: 0 into: [:sum :class | | sels | sels := class whichSelectorsAccess: each. sels size == 1 ifTrue: [selector := sels asArray first. defClass := class]. sum + sels size]) == 1 ifTrue: [| tree | tree := defClass parseTreeFor: selector. tree notNil ifTrue: [(RBReadBeforeWrittenTester readBeforeWritten: (Array with: each) in: tree) isEmpty ifTrue: [result addClass: defClass selector: selector. result addSearchString: each]]]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'accessing' stamp: ''! protocols ^#('bugs' 'possible bugs' 'unnecessary code' 'intention revealing' 'miscellaneous')! ! !RBBasicLintRuleTest class methodsFor: 'instance creation' stamp: ''! createParseTreeRule: codeStrings name: aName ^self createParseTreeRule: codeStrings method: false name: aName! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'lr 9/4/2010 17:29'! modifiesCollection | detector addSearcher | detector := self new. detector name: 'Modifies collection while iterating over it'. addSearcher := RBBasicLintRuleTest modifiesCollection. detector methodBlock: [:context :result | addSearcher executeTree: context parseTree initialAnswer: false. addSearcher answer ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'private' stamp: ''! classShouldNotOverride ^#(#== #class)! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'lr 11/19/2009 14:48'! fileBlocks ^self createParseTreeRule: #('[| `@temps | `var := `@object. `@.statements] ensure: [`var `@messages: `@args]' '[| `@temps | `var := `@object. `@.statements] ifCurtailed: [`var `@messages: `@args]') name: 'Assignment inside unwind blocks should be outside.'! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: 'lr 11/2/2009 00:14'! toDo | detector matcher | detector := self new. detector name: 'Uses to:do: instead of do:, with:do: or timesRepeat:'. matcher := RBParseTreeSearcher new. matcher addSearch: '1 to: ``@object size do: [:`each | | `@temps | `@.Statements]' -> [:aNode :answer | answer or: [| varName variableMatcher | varName := aNode arguments last arguments first name. "`each" variableMatcher := RBParseTreeSearcher new. variableMatcher addSearch: varName -> [:node :ans | ans and: [node parent isMessage and: [node parent selector == #at:]]]. variableMatcher executeTree: aNode arguments last body initialAnswer: true]]. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code' stamp: ''! unreferencedVariables | detector | detector := self new. detector name: 'Variables not referenced'. detector result: nil unreferenced. detector classBlock: [:context :result | | allSubclasses | allSubclasses := context selectedClass withAllSubclasses. context selectedClass instVarNames do: [:each | allSubclasses detect: [:class | (class whichSelectorsAccess: each) isEmpty not] ifNone: [result addInstVar: each for: context selectedClass]]. context selectedClass isMetaclass ifFalse: [context selectedClass classPool associationsDo: [:each | (context uses: each) ifFalse: [result addClassVar: each key for: context selectedClass]]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code' stamp: 'TommasoDalSasso 10/6/2013 01:37'! onlyReadOrWritten | detector | detector := self new. detector name: 'Instance variables not read AND written'. detector result: nil references. detector classBlock: [:context :result | | allSubclasses | allSubclasses := context selectedClass withAllSubclasses. context selectedClass instVarNames do: [:each | | reads writes | reads := false. writes := false. allSubclasses detect: [:class | reads ifFalse: [reads := (class whichSelectorsRead: each) isEmpty not]. writes ifFalse: [writes := (class whichSelectorsWrite: each) isEmpty not]. reads & writes] ifNone: [result addInstVar: each for: context selectedClass]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: 'lr 11/2/2009 00:14'! yourselfNotUsed | detector addSearcher | detector := self new. detector name: 'Doesn''t use the result of a yourself message'. addSearcher := RBParseTreeSearcher new. addSearcher addSearch: '`@object yourself' -> [:aNode :answer | answer or: [aNode isUsed not]]. detector methodBlock: [:context :result | (addSearcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'private' stamp: ''! utilityProtocols "If a method is defined in one of these protocols, then don't check if its a utility method." ^#('*utilit*')! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'lr 9/8/2011 20:32'! abstractClass | detector subclassResponsibilitySymbol | detector := self new. detector name: 'References an abstract class'. detector resultClass: RBClassEnvironment. subclassResponsibilitySymbol := 'subclassResponsibility' asSymbol. detector classBlock: [:context :result | (context selectedClass whichSelectorsReferTo: subclassResponsibilitySymbol) isEmpty ifFalse: [(context uses: (Smalltalk associationAt: context selectedClass name ifAbsent: [nil])) ifTrue: [result addClass: context selectedClass]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code' stamp: 'lr 11/2/2009 00:14'! equalsTrue | detector matcher | detector := self new. detector name: 'Unnecessary "= true"'. matcher := (RBParseTreeSearcher new) addSearches: #('true' 'false') -> [:aNode :answer | answer or: [aNode parent isMessage and: [#(#= #== #~= #~~) includes: aNode parent selector]]]; yourself. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'lr 11/2/2009 00:14'! tempsReadBeforeWritten | detector | detector := self new. detector name: 'Temporaries read before written'. detector methodBlock: [:context :result | | variables | variables := RBParseTreeSearcher nonBlockTempsIn: context parseTree. variables isEmpty ifFalse: [(RBReadBeforeWrittenTester variablesReadBeforeWrittenIn: context parseTree) do: [:each | result addClass: context selectedClass selector: context selector. result addSearchString: each]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'private' stamp: 'VanessaPena 1/29/2013 10:32'! canCall: aSelector in: aClass from: anApplication "This method contains on purpose not implemented messages, such as rootApplication " | methodApp root | (aClass canUnderstand: aSelector) ifFalse: [^false]. root := anApplication rootApplication. methodApp := ((aClass whichClassIncludesSelector: aSelector) compiledMethodAt: aSelector) application rootApplication. ^methodApp == root or: [root isBasedOn: methodApp]! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: 'lr 11/2/2009 00:14'! utilityMethods | detector | detector := self new. detector name: 'Utility methods'. detector methodBlock: [:context :result | (context selectedClass isMetaclass | (context selector numArgs == 0) or: [(context protocols detect: [:each | (self utilityProtocols detect: [:protocol | protocol match: each] ifNone: [nil]) notNil] ifNone: [nil]) notNil]) ifFalse: [(self subclassOf: context selectedClass overrides: context selector) ifFalse: [(context superMessages isEmpty and: [context selfMessages isEmpty]) ifTrue: [(RBParseTreeSearcher references: context selectedClass allInstVarNames , context selectedClass allClassVarNames asArray , #('self') in: context parseTree) isEmpty ifTrue: [result addClass: context selectedClass selector: context selector]]]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'private' stamp: ''! longMethodSize ^10! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: 'lr 11/2/2009 00:14'! ifTrueBlocks | detector matcher | detector := self new. detector name: 'Non-blocks in ifTrue:/ifFalse: messages'. matcher := RBParseTreeSearcher new. matcher addSearches: #('``@condition ifTrue: ``@block' '``@condition ifFalse: ``@block' '``@condition ifTrue: ``@block1 ifFalse: ``@block2' '``@condition ifFalse: ``@block1 ifTrue: ``@block2') -> [:aNode :answer | answer or: [(aNode arguments detect: [:each | each isBlock not] ifNone: [nil]) notNil]]. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: ''! whileTrue ^self createParseTreeRule: #('| `@temps | `@.Statements1. [`index <= `@stop] whileTrue: [| `@blockTemps | `@.BlockStmts1. `index := `index + 1]. `@.Statements2' '| `@temps | `@.Statements1. [`index < `@stop] whileTrue: [| `@blockTemps | `@.BlockStmts1. `index := `index + 1]. `@.Statements2' '| `@temps | `@.Statements1. [`index >= `@stop] whileTrue: [| `@blockTemps | `@.BlockStmts1. `index := `index - 1]. `@.Statements2' '| `@temps | `@.Statements1. [`index > `@stop] whileTrue: [| `@blockTemps | `@.BlockStmts1. `index := `index - 1]. `@.Statements2') name: 'Uses whileTrue: instead of to:do:'! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'lr 11/2/2009 00:14'! threeElementPoint | detector matcher | detector := self new. detector name: 'Possible three element point (e.g., x @ y + q @ r)'. matcher := (RBParseTreeSearcher new) addSearch: '``@x @ ``@y' -> [:aNode :answer | answer or: [| current | current := aNode parent. [current isNil or: [current isMessage and: [current selector == #@ or: [current selector isInfix not]]]] whileFalse: [current := current parent]. (current isNil or: [current isMessage and: [current selector isInfix not]]) not]]; yourself. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'bugs' stamp: ''! usesTrue | detector trueBinding falseBinding | detector := self new. trueBinding := Smalltalk associationAt: #True. falseBinding := Smalltalk associationAt: #False. detector name: 'Uses True/False instead of true/false'. detector methodBlock: [:context :result | | method | method := context compiledMethod. ((method referencesLiteral: trueBinding) or: [method referencesLiteral: falseBinding]) ifTrue: [result addClass: context selectedClass selector: context selector. result searchStrings: #('True' 'False')]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: 'lr 11/2/2009 00:14'! stringConcatenation | detector matcher concatenationMatcher | detector := self new. detector name: 'String concatenation instead of streams'. matcher := RBParseTreeSearcher new. concatenationMatcher := RBParseTreeSearcher new. concatenationMatcher addSearch: '`@receiver , `@argument' -> [:aNode :answer | true]. matcher addSearches: #('``@collection do: [:`each | | `@temps | ``@.Statements]' '``@collection do: [:`each | | `@temps | ``@.Statements] separatedBy: [| `@temps1 | ``@.Statements1]' '``@number to: ``@endNumber do: [:`i | | `@temps | ``@.Statements]' '``@collection detect: [:`each | | `@temps | ``@.Statements]' '``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [| `@temps1 | ``@.Statements1]' '``@collection select: [:`each | | `@temps | ``@.Statements]' '``@collection inject: ``@value into: [:`each | | `@temps | ``@.Statements]') -> [:aNode :answer | answer or: [(aNode arguments detect: [:each | each isBlock and: [concatenationMatcher executeTree: each initialAnswer: false]] ifNone: [nil]) notNil]]. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: ''! consistencyCheck ^self createParseTreeRule: #('`@object size == 0' '`@object size = 0' '`@object size > 0' '`@object size >= 1' '`@object == nil' '`@object = nil') name: 'Uses "size = 0" or "= nil" instead of "isEmpty" or "isNil"'! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: ''! sizeCheck ^self createParseTreeRule: (#(#do: #collect: #reject: #select:) collect: [:each | '`@object size > 0 ifTrue: [`@object ' , each , ' [:`each | | `@temps | `@.Statements1]. `@.Statements2]']) , (#(#do: #collect: #reject: #select:) collect: [:each | '`@object isEmpty ifFalse: [`@object ' , each , ' [:`each | | `@temps | `@.Statements1]. `@.Statements2]']) name: 'Unnecessary size check'! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: ''! assignmentInIfTrue ^self createParseTreeRule: #('`@boolean ifTrue: [| `@temps1 | `@.Statements1. `var := `@object1] ifFalse: [| `@temps2 | `@.Statements2. `var := `@object2]' '`@boolean ifFalse: [| `@temps1 | `@.Statements1. `var := `@object1] ifTrue: [| `@temps2 | `@.Statements2. `var := `@object2]') name: 'Assignment to same variable and end of ifTrue:ifFalse: blocks'! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code' stamp: ''! extraBlock ^self createParseTreeRule: (#('value' 'value: `@value' 'value: `@value1 value: `@value2' 'value: `@value1 value: `value2 value: `@value3' 'valueWithArguments: `@values') collect: [:each | '[:`@params | | `@temps | `@.statements] ' , each]) name: 'Block immediately evaluated'! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: ''! superSends | detector | detector := self new. detector name: 'Missing super sends'. detector methodBlock: [:context :result | (context selectedClass isMetaclass not and: [self superMessages includes: context selector]) ifTrue: [(context selectedClass superclass notNil and: [context selectedClass superclass canUnderstand: context selector]) ifTrue: [(context superMessages includes: context selector) ifFalse: [result addClass: context selectedClass selector: context selector]]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: 'lr 9/8/2011 20:32'! addRemoveDependents | detector | detector := self new. detector resultClass: RBClassEnvironment. detector name: 'Number of addDependent: messages > removeDependent:'. detector classBlock: [:context :result | | count | count := 0. ((Set withAll: (context selectedClass whichSelectorsReferTo: #addDependent:)) addAll: (context selectedClass whichSelectorsReferTo: #removeDependent:); yourself) do: [:sel | (context selectedClass compiledMethodAt: sel) messagesDo: [:each | each == #addDependent: ifTrue: [count := count + 1]. each == #removeDependent: ifTrue: [count := count - 1]]]. count > 0 ifTrue: [result addClass: context selectedClass]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs' stamp: ''! sendsDifferentSuper | detector | detector := self new. detector name: 'Sends different super message'. detector methodBlock: [:context :result | | message | (message := context superMessages detect: [:each | each ~= context selector] ifNone: [nil]) notNil ifTrue: [result addSearchString: message. result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'bugs' stamp: ''! subclassResponsibilityNotDefined | detector subclassResponsibilitySymbol | detector := self new. subclassResponsibilitySymbol := 'subclassResponsibility' asSymbol. detector name: 'Subclass responsibility not defined'. detector classBlock: [:context :result | (context selectedClass whichSelectorsReferTo: subclassResponsibilitySymbol) do: [:each | (context selectedClass withAllSubclasses detect: [:class | class subclasses isEmpty and: [(class whichClassIncludesSelector: each) == context selectedClass]] ifNone: [nil]) notNil ifTrue: [result addClass: context selectedClass selector: each]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'bugs' stamp: ''! booleanPrecedence ^self createParseTreeRule: #('`@object1 | `@object2 = `@object3' '`@object1 | `@object2 == `@object3' '`@object1 & `@object2 = `@object3' '`@object1 & `@object2 == `@object3' '`@object1 | `@object2 ~= `@object3' '`@object1 | `@object2 ~~ `@object3' '`@object1 & `@object2 ~= `@object3' '`@object1 & `@object2 ~~ `@object3') name: 'Uses A | B = C instead of A | (B = C)'! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: ''! contains ^self createParseTreeRule: #('(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) isNil' '(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) notNil' '(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) = nil' '(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) == nil' '(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) ~= nil' '(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) ~~ nil' '`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [| `@temps1 | `@.Statements2. ^`@anything]') name: 'Uses detect:ifNone: instead of contains:'! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: 'bh 4/8/2000 19:05'! fullBlocks "skip this test in squeak." " | detector | detector := self new. detector name: 'Method with full blocks'. detector methodBlock: [:context :result | context compiledMethod withAllBlockMethodsDo: [:method | method needsHybridFrame ifTrue: [result addClass: context selectedClass selector: context selector]]]. ^detector"! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: ''! badMessage | detector badMessages | detector := self new. detector name: 'Sends "questionable" message'. badMessages := self badSelectors. detector classBlock: [:context :result | | selectors | selectors := badMessages inject: Set new into: [:set :each | set addAll: (context selectedClass whichSelectorsReferTo: each); yourself]. selectors do: [:each | result addClass: context selectedClass selector: each]. selectors isEmpty ifFalse: [result searchStrings: badMessages]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: 'MarcusDenker 9/20/2013 15:05'! ifTrueReturns | detector matcher | detector := self new. detector name: 'ifTrue:/ifFalse: returns instead of and:/or:''s'. matcher := RBParseTreeSearcher new. matcher addSearches: #('| `@temps | ``@.Statements. ``@object ifTrue: [^``@value1]. ^``@value2' '| `@temps | ``@.Statements. ``@object ifFalse: [^``@value1]. ^``@value2') -> [:aNode :answer | answer or: [| node | node := (aNode statements at: aNode statements size - 1) arguments first body statements last value. "``@value1" (node isLiteralNode and: [{true. false} includes: node value]) or: [node := aNode statements last value. node isLiteralNode and: [{true. false} includes: node value]]]]. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'miscellaneous' stamp: 'lr 11/2/2009 00:14'! longMethods | detector matcher | detector := self new. detector name: 'Long methods'. matcher := RBParseTreeSearcher new. matcher addSearch: '`.Stmt' -> [:aNode :answer | (aNode children inject: answer into: [:sum :each | matcher executeTree: each initialAnswer: sum]) + 1]. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: 0) >= self longMethodSize ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing' stamp: 'lr 11/2/2009 00:14'! minMax | detector matcher | detector := self new. detector name: 'Uses ifTrue:/ifFalse: instead of min: or max:'. matcher := RBParseTreeSearcher new. matcher addSearches: #('(`x `message: `@y) `ifTrue: [`x := `@y]' '(`@x `message: `@y) `ifTrue: [`@x] `ifFalse: [`@y]') -> [:aNode :answer | answer or: [(#(#ifTrue: #ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue:) includes: aNode selector) and: [#(#< #<= #> #>=) includes: aNode receiver selector]]]. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'private' stamp: 'nk 2/23/2005 16:09'! new ^super new! ! !RBBasicLintRuleTest class methodsFor: 'private' stamp: ''! subclassOf: aClass overrides: aSelector | subs | subs := aClass subclasses. 1 to: subs size do: [:i | | each | each := subs at: i. (each includesSelector: aSelector) ifTrue: [^true]. (self subclassOf: each overrides: aSelector) ifTrue: [^true]]. ^false! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code' stamp: 'lr 11/2/2009 00:14'! endTrueFalse | detector matcher | detector := self new. detector name: 'Check for same statements at end of ifTrue:ifFalse: blocks'. matcher := (RBParseTreeSearcher new) addSearches: #('`@object ifTrue: [| `@temps1 | `@.Statements1. `.Statement] ifFalse: [| `@temps2 | `@.Statements2. `.Statement]' '`@object ifTrue: [| `@temps1 | `.Statement. `@.Statements1] ifFalse: [| `@temps2 | `.Statement. `@.Statements2]' '`@object ifFalse: [| `@temps1 | `@.Statements1. `.Statement] ifTrue: [| `@temps2 | `@.Statements2. `.Statement]' '`@object ifFalse: [| `@temps1 | `.Statement. `@.Statements1] ifTrue: [| `@temps2 | `.Statement. `@.Statement2]') -> [:aNode :answer | answer or: [| node | node := aNode arguments first body statements last. (node isVariable and: [node = aNode arguments last body statements last]) not]]; yourself. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code' stamp: 'lr 11/2/2009 00:14'! justSendsSuper | detector matcher | detector := self new. detector name: 'Method just sends super message'. matcher := RBParseTreeSearcher justSendsSuper. detector methodBlock: [:context :result | (context parseTree tag isNil and: [matcher executeMethod: context parseTree initialAnswer: false]) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'bugs' stamp: ''! sentNotImplemented | detector | detector := self new. detector name: 'Messages sent but not implemented'. detector methodBlock: [:context :result | | message | message := context messages detect: [:each | (context implements: each) not] ifNone: [nil]. message isNil ifTrue: [message := context superMessages detect: [:each | context selectedClass superclass isNil or: [(context selectedClass superclass canUnderstand: each) not]] ifNone: [nil]. message isNil ifTrue: [message := context selfMessages detect: [:each | (context selectedClass canUnderstand: each) not] ifNone: [nil]]]. message notNil ifTrue: [result addSearchString: message. result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'instance creation' stamp: ''! createParseTreeRule: codeStrings method: aBoolean name: aName | detector matcher | detector := self new. detector name: aName. matcher := self createMatcherFor: codeStrings method: aBoolean. detector methodBlock: [:context :result | (matcher executeTree: context parseTree initialAnswer: false) ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code' stamp: ''! equivalentSuperclassMethods | detector | detector := self new. detector name: 'Methods equivalently defined in superclass'. detector methodBlock: [:context :result | context selectedClass superclass notNil ifTrue: [(context selectedClass superclass canUnderstand: context selector) ifTrue: [(((context selectedClass superclass whichClassIncludesSelector: context selector) compiledMethodAt: context selector) equivalentTo: context compiledMethod) ifTrue: [result addClass: context selectedClass selector: context selector]]]]. ^detector! ! !RBBetweenAndRule commentStamp: ''! See rationale! !RBBetweenAndRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:29'! initialize super initialize. self rewriteRule replace: '``@a >= ``@b and: [``@a <= ``@c]' with: '``@a between: ``@b and: ``@c'; replace: '``@a >= ``@b & (``@a <= ``@c)' with: '``@a between: ``@b and: ``@c'; replace: '``@b <= ``@a and: [``@a <= ``@c]' with: '``@a between: ``@b and: ``@c'; replace: '``@b <= ``@a & (``@a <= ``@c)' with: '``@a between: ``@b and: ``@c'; replace: '``@a <= ``@c and: [``@a >= ``@b]' with: '``@a between: ``@b and: ``@c'; replace: '``@a <= ``@c & (``@a >= ``@b)' with: '``@a between: ``@b and: ``@c'; replace: '``@c >= ``@a and: [``@a >= ``@b]' with: '``@a between: ``@b and: ``@c'; replace: '``@c >= ``@a & (``@a >= ``@b)' with: '``@a between: ``@b and: ``@c'; replace: '``@a >= ``@b and: [``@c >= ``@a]' with: '``@a between: ``@b and: ``@c'; replace: '``@a >= ``@b & (``@c >= ``@a)' with: '``@a between: ``@b and: ``@c'; replace: '``@b <= ``@a and: [``@c >= ``@a]' with: '``@a between: ``@b and: ``@c'; replace: '``@b <= ``@a & (``@c >= ``@a)' with: '``@a between: ``@b and: ``@c'; replace: '``@a <= ``@c and: [``@b <= ``@a]' with: '``@a between: ``@b and: ``@c'; replace: '``@a <= ``@c & (``@b <= ``@a)' with: '``@a between: ``@b and: ``@c'; replace: '``@c >= ``@a and: [``@b <= ``@a]' with: '``@a between: ``@b and: ``@c'; replace: '``@c >= ``@a & (``@b <= ``@a)' with: '``@a between: ``@b and: ``@c'! ! !RBBetweenAndRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBBetweenAndRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ '"a >= b and: [a <= c]" -> "a between: b and: c"'! ! !RBBetweenAndRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:49'! category ^ 'Coding Idiom Violation'! ! !RBBetweenAndRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/12/2012 14:40'! longDescription ^ ' Replaces "a >= b and: [a <= c]" by "a between: b and: c"'! ! !RBBetweenAndRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'BetweenAndRule'! ! !RBBinarySelectorToken commentStamp: 'md 8/9/2005 14:51'! RBBinarySelectorToken is the first-class representation of a binary selector (e.g. +) ! !RBBinarySelectorToken methodsFor: 'testing' stamp: ''! isBinary ^true! ! !RBBlockLintRule commentStamp: ''! I am a special kind of rule where the verification is specified using a block. The methods checkClass: and checkMethods are the hooks to specify such verifications.! !RBBlockLintRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBSelectorEnvironment! ! !RBBlockLintRule class methodsFor: 'testing' stamp: 'lr 2/24/2009 17:09'! isVisible ^ self name ~= #RBBlockLintRule! ! !RBBlockLintRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'BlockLintRule'! ! !RBBlockNode commentStamp: ''! RBBlockNode is an AST node that represents a block "[...]". Instance Variables: arguments the arguments for the block bar position of the | after the arguments body the code inside the block colons positions of each : before each argument left position of [ right position of ] ! !RBBlockNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 16:42'! hasTemporaryNamed: aString ^ self temporaries anySatisfy: [ :temp| temp name = aString ]! ! !RBBlockNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 7/26/2013 15:18'! isInlinedLoop parent isMessage ifFalse: [ ^ false ]. parent isInlineToDo ifTrue: [^ true]. parent isInlineWhile ifTrue: [^ true]. parent isInlineTimesRepeat ifTrue: [^ true]. (parent parent isArray and: [parent parent parent isMessage and: [parent parent parent isInlineCase]]) ifTrue: [^ true]. parent isInlineCase ifTrue: [^ true]. "otherwise branch" ^ false! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! right: anInteger right := anInteger! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! children ^self arguments copyWith: self body! ! !RBBlockNode methodsFor: 'testing' stamp: ''! isBlock ^true! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! colons: anArray colons := anArray! ! !RBBlockNode methodsFor: 'testing' stamp: ''! isImmediateNode ^true! ! !RBBlockNode methodsFor: 'testing' stamp: ''! references: aVariableName ^body references: aVariableName! ! !RBBlockNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/15/2011 16:28'! scope ^ scope! ! !RBBlockNode methodsFor: 'testing' stamp: ''! isLast: aNode ^body isLast: aNode! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! precedence ^0! ! !RBBlockNode methodsFor: 'replacing' stamp: ''! replaceNode: aNode withNode: anotherNode body == aNode ifTrue: [self body: anotherNode]. self arguments: (arguments collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! ! !RBBlockNode methodsFor: 'testing' stamp: ''! uses: aNode aNode = body ifFalse: [^false]. ^parent isMessage ifTrue: [(#(#ifTrue:ifFalse: #ifTrue: #ifFalse: #ifFalse:ifTrue:) includes: parent selector) not or: [parent isUsed]] ifFalse: [self isUsed]! ! !RBBlockNode methodsFor: 'testing' stamp: ''! defines: aName ^arguments anySatisfy: [:each | each name = aName]! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! bar: anInteger bar := anInteger! ! !RBBlockNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:36'! postCopy super postCopy. self arguments: (self arguments collect: [ :each | each copy ]). self body: self body copy! ! !RBBlockNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/15/2011 16:28'! scope: aScopedNode scope := aScopedNode! ! !RBBlockNode methodsFor: 'matching' stamp: 'lr 5/30/2010 11:34'! match: aNode inContext: aDictionary aNode class = self class ifFalse: [^false]. ^(self matchList: arguments against: aNode arguments inContext: aDictionary) and: [body match: aNode body inContext: aDictionary]! ! !RBBlockNode methodsFor: 'testing' stamp: ''! needsParenthesis ^false! ! !RBBlockNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 7/26/2013 15:28'! methodOrBlockNode "^ self"! ! !RBBlockNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 16:42'! hasArgumentNamed: aString ^ self arguments anySatisfy: [ :argument| argument name = aString ]! ! !RBBlockNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2012 17:18'! temporaries ^ self body temporaries! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! allDefinedVariables ^(self argumentNames asOrderedCollection) addAll: super allDefinedVariables; yourself! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! body: stmtsNode body := stmtsNode. body parent: self! ! !RBBlockNode methodsFor: 'testing' stamp: ''! directlyUses: aNode ^false! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! bar ^ bar! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! stopWithoutParentheses ^right! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! left ^ left! ! !RBBlockNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:29'! isFaulty ^(self arguments anySatisfy: #isFaulty ) or: [ self body isFaulty]! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! right ^ right! ! !RBBlockNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/8/2011 15:17'! temporaryNames ^ self body temporaryNames! ! !RBBlockNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 8/5/2013 11:03'! isClean "a block is clean if it has no escaping vars, has no non local return and its children are clean" self isInlined ifTrue: [ ^ false ]. self scope hasEscapingVars ifTrue: [ ^ false ]. self lastIsReturn ifTrue: [ ^ false ]. ^ super isClean ! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! allArgumentVariables ^(self argumentNames asOrderedCollection) addAll: super allArgumentVariables; yourself! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! blockVariables | vars | vars := super blockVariables asOrderedCollection. vars addAll: self argumentNames. ^vars! ! !RBBlockNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2012 16:43'! statements ^ self body statements! ! !RBBlockNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 8/5/2013 11:04'! lastIsReturn ^ self body lastIsReturn! ! !RBBlockNode methodsFor: 'comparing' stamp: 'lr 3/7/2010 13:48'! hash ^ (self hashForCollection: self arguments) bitXor: self body hash! ! !RBBlockNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:35'! copyInContext: aDictionary ^ self class new arguments: (self copyList: self arguments inContext: aDictionary); body: (self body copyInContext: aDictionary); yourself! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! startWithoutParentheses ^left! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! arguments: argCollection arguments := argCollection. arguments do: [:each | each parent: self]! ! !RBBlockNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:36'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitBlockNode: self! ! !RBBlockNode methodsFor: 'comparing' stamp: ''! equalTo: anObject withMapping: aDictionary self class = anObject class ifFalse: [^false]. self arguments size = anObject arguments size ifFalse: [^false]. 1 to: self arguments size do: [:i | ((self arguments at: i) equalTo: (anObject arguments at: i) withMapping: aDictionary) ifFalse: [^false]]. (self body equalTo: anObject body withMapping: aDictionary) ifFalse: [^false]. self arguments do: [:each | aDictionary removeKey: each name]. ^true! ! !RBBlockNode methodsFor: '*opalcompiler-core' stamp: 'jorgeRessia 11/20/2009 16:40'! owningScope ^ self scope ifNil: ["inlined" ^ parent owningScope]! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! body ^body! ! !RBBlockNode methodsFor: 'comparing' stamp: ''! = anObject self == anObject ifTrue: [^true]. self class = anObject class ifFalse: [^false]. self body = anObject body ifFalse: [^false]. self arguments size = anObject arguments size ifFalse: [^false]. 1 to: self arguments size do: [:i | (self arguments at: i) = (anObject arguments at: i) ifFalse: [^false]]. ^true! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! colons ^ colons! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! left: anInteger left := anInteger! ! !RBBlockNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 7/26/2013 15:11'! isInlined parent isMessage ifFalse: [ ^ false ]. parent isInlineAndOr ifTrue: [^ true]. parent isInlineIf ifTrue: [^ true]. parent isInlineIfNil ifTrue: [^ true]. ^ self isInlinedLoop! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! arguments ^arguments! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! argumentNames ^self arguments collect: [:each | each name]! ! !RBBlockNode methodsFor: 'accessing' stamp: ''! statementComments ^self comments! ! !RBBlockNode methodsFor: '*opalcompiler-core' stamp: 'CamilleTeruel 2/14/2014 14:37'! enclosingMethodOrBlockNode ^ parent ifNotNil: [ parent methodOrBlockNode ]! ! !RBBlockNode class methodsFor: 'instance creation' stamp: ''! arguments: argNodes body: sequenceNode ^(self new) arguments: argNodes; body: sequenceNode; yourself! ! !RBBlockNode class methodsFor: 'instance creation' stamp: ''! body: sequenceNode ^self arguments: #() body: sequenceNode! ! !RBBlockReplaceRule commentStamp: 'md 8/9/2005 14:55'! RBBlockReplaceRule replaces the matching node by the result of evaluating replaceBlock. This allows arbitrary computation to come up with a replacement. Instance Variables: replaceBlock The block that returns the node to replace to matching node with. ! !RBBlockReplaceRule methodsFor: 'initialization' stamp: ''! initialize super initialize. replaceBlock := [:aNode | aNode]! ! !RBBlockReplaceRule methodsFor: 'initialize-release' stamp: ''! searchFor: searchString replaceWith: aBlock self searchString: searchString. replaceBlock := aBlock! ! !RBBlockReplaceRule methodsFor: 'initialize-release' stamp: ''! searchForMethod: searchString replaceWith: aBlock self methodSearchString: searchString. replaceBlock := aBlock! ! !RBBlockReplaceRule methodsFor: 'initialize-release' stamp: ''! searchForTree: aBRProgramNode replaceWith: aBlock searchTree := aBRProgramNode. replaceBlock := aBlock! ! !RBBlockReplaceRule methodsFor: 'initialize-release' stamp: ''! searchForTree: aBRProgramNode replaceWith: replBlock when: verifyBlock self searchForTree: aBRProgramNode replaceWith: replBlock. verificationBlock := verifyBlock! ! !RBBlockReplaceRule methodsFor: 'matching' stamp: ''! foundMatchFor: aProgramNode | newNode | newNode := replaceBlock value: aProgramNode. aProgramNode replaceMethodSource: newNode. ^newNode! ! !RBBlockReplaceRule methodsFor: 'initialize-release' stamp: ''! searchForMethod: searchString replaceWith: replBlock when: verifyBlock self searchForMethod: searchString replaceWith: replBlock. verificationBlock := verifyBlock! ! !RBBlockReplaceRule methodsFor: 'initialize-release' stamp: ''! searchFor: searchString replaceWith: replBlock when: verifyBlock self searchFor: searchString replaceWith: replBlock. verificationBlock := verifyBlock! ! !RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''! searchForMethod: searchString replaceWith: replaceBlock ^self new searchForMethod: searchString replaceWith: replaceBlock! ! !RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''! searchForMethod: searchString replaceWith: replaceBlock when: aBlock ^self new searchForMethod: searchString replaceWith: replaceBlock when: aBlock! ! !RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''! searchForTree: aRBProgramNode replaceWith: replaceBlock when: aBlock ^self new searchForTree: aRBProgramNode replaceWith: replaceBlock when: aBlock! ! !RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''! searchFor: searchString replaceWith: replaceBlock ^self new searchFor: searchString replaceWith: replaceBlock! ! !RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''! searchForTree: aRBProgramNode replaceWith: replaceBlock ^self new searchForTree: aRBProgramNode replaceWith: replaceBlock! ! !RBBlockReplaceRule class methodsFor: 'instance creation' stamp: ''! searchFor: searchString replaceWith: replaceBlock when: aBlock ^self new searchFor: searchString replaceWith: replaceBlock when: aBlock! ! !RBBooleanPrecedenceRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:18'! initialize super initialize. self matcher matchesAnyOf: #( '`@object1 | `@object2 = `@object3' '`@object1 | `@object2 == `@object3' '`@object1 & `@object2 = `@object3' '`@object1 & `@object2 == `@object3' '`@object1 | `@object2 ~= `@object3' '`@object1 | `@object2 ~~ `@object3' '`@object1 & `@object2 ~= `@object3' '`@object1 & `@object2 ~~ `@object3' ) do: [ :node :answer | node ]! ! !RBBooleanPrecedenceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks precedence ordering of & and | with equality operators. Since | and & have the same precedence as =, there are common mistakes where parenthesis are missing around the equality operators.'! ! !RBBooleanPrecedenceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBBooleanPrecedenceRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:03'! severity ^ #error! ! !RBBooleanPrecedenceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses A | B = C instead of A | (B = C)'! ! !RBBooleanPrecedenceRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:21'! category ^ 'Potential Bugs'! ! !RBBooleanPrecedenceRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'BooleanPrecedenceRule'! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'lr 3/20/2011 11:30'! systemDictionary "The root system dictionary as the source of all objects in this environment." ^ Smalltalk globals! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 1/3/2010 11:11'! isVariableEnvironment ^ false! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! instVarReadersTo: instVarName in: aClass ^RBVariableEnvironment on: self readersOfInstanceVariable: instVarName in: aClass! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: ''! searchStrings: aCollection searchStrings := aCollection! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: ''! instanceVariablesFor: aClass ^aClass instVarNames! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'lr 2/8/2009 12:28'! addSearchString: aString searchStrings isNil ifTrue: [ searchStrings := SortedCollection sortBlock: [ :a :b | (a indexOf: $: ifAbsent: [ a size ]) > (b indexOf: $: ifAbsent: [ b size ]) ] ]. (searchStrings includes: aString) ifFalse: [ searchStrings add: aString ]! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! forClasses: classCollection | classes | classes := OrderedCollection new: classCollection size * 2. classCollection do: [:each | classes add: each; add: each class]. ^RBClassEnvironment onEnvironment: self classes: classes! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/27/2011 15:45'! packageOrganizer ^ RPackageOrganizer default! ! !RBBrowserEnvironment methodsFor: '*NautilusCommon' stamp: 'SebastianTleye 4/23/2013 13:14'! packagesWithoutExtensions ^ self packageOrganizer packagesWithoutExtensions! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! instVarRefsTo: instVarName in: aClass ^RBVariableEnvironment on: self referencesToInstanceVariable: instVarName in: aClass! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! not self isSystem ifTrue: [^RBSelectorEnvironment new]. ^RBNotEnvironment onEnvironment: self! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: ''! searchStrings ^searchStrings isNil ifTrue: [#()] ifFalse: [searchStrings]! ! !RBBrowserEnvironment methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 5/13/2012 19:45'! traits | traits | traits := IdentitySet new: 4096. self traitsDo: [ :each | traits add: each ]. ^ traits! ! !RBBrowserEnvironment methodsFor: '*Nautilus' stamp: 'BenjaminVanRyseghem 10/17/2013 16:01'! browse ^ Smalltalk tools browser openInEnvironment: self! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'CamilloBruni 7/7/2013 18:37'! includesPackage: packageName ^ true! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! implementorsMatching: aString ^RBSelectorEnvironment implementorsMatching: aString in: self! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: ''! numberClasses ^self classNames size! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'SebastianTleye 4/24/2013 10:55'! allClassesAndTraits " compatibility method with SystemDictionary " | classesAndTraits | classesAndTraits := IdentitySet new: 4096. self classesAndTraitsDo: [ :each | classesAndTraits add: each theNonMetaClass ]. ^ classesAndTraits asArray! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:26'! & anEnvironment "If we or anEnvironment includes everything, then just include the other environment (optimization)" self isSystem ifTrue: [^anEnvironment]. anEnvironment isSystem ifTrue: [^self]. ^RBAndEnvironment onEnvironment: self and: anEnvironment! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 11/25/2009 08:31'! classNames | names | names := IdentitySet new: 4096. self classesDo: [ :each | names add: each theNonMetaClass name ]. ^ names! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 8/17/2013 22:29'! methodsDo: aBlock self classesDo: [ :aClass| self selectorsForClass: aClass do: [ :selector | aBlock value: (aClass >> selector) ]]! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'lr 3/20/2011 11:19'! rootEnvironment "The root environment representing everything." ^ self! ! !RBBrowserEnvironment methodsFor: 'initialize-release' stamp: ''! label: aString label := aString! ! !RBBrowserEnvironment methodsFor: 'accessing-packages' stamp: 'CamilloBruni 7/7/2013 18:55'! packageAt: aName ^ self packageAt: aName ifAbsent: [ NotFound signalFor: aName in: self ]! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! includesClass: aClass ^ true! ! !RBBrowserEnvironment methodsFor: '*manifest-core' stamp: 'SimonAllier 3/30/2012 11:42'! isMultiEnvironment ^ false! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 6/10/2010 15:29'! allClasses "Answer all the unique non-metaclasses of all the classes and metaclasses in this environment." | classes | classes := IdentitySet new: 4096. self classesDo: [ :each | classes add: each theNonMetaClass ]. ^ classes asArray! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! isEmpty ^ false! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 8/17/2013 22:29'! methods | methods | methods := IdentitySet new: 4096. self methodsDo: [ :each | methods add: each ]. ^ methods! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! implementorsOf: aSelector ^RBSelectorEnvironment implementorsOf: aSelector in: self! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: ''! whichProtocolIncludes: aSelector in: aClass ^aClass organization categoryOfElement: aSelector! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! classVarRefsTo: instVarName in: aClass ^ RBVariableEnvironment on: self referencesToClassVariable: instVarName in: aClass! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! includesSelector: aSelector in: aClass ^ true! ! !RBBrowserEnvironment methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 5/13/2012 19:49'! traitsDo: aBlock self systemDictionary allTraitsDo: [ :each | aBlock value: each ]! ! !RBBrowserEnvironment methodsFor: '*NautilusCommon' stamp: 'CamilloBruni 8/29/2013 15:53'! asSystemNavigationEnvironment | env globalsNames | "Optimization for the default environment AKA Smalltalk" self class == RBBrowserEnvironment ifTrue: [ ^ Smalltalk globals ]. env := SystemDictionary new. self classesDo: [:each | env add: ( Smalltalk globals associationAt: each theNonMetaClass name )]. self traitsDo: [:each | env add: ( Smalltalk globals associationAt: each name )]. globalsNames := Smalltalk globals keys asOrderedCollection. globalsNames removeAll: ( Smalltalk globals classNames ). globalsNames removeAll: ( Smalltalk globals traitNames ). globalsNames do: [:each | env add: ( Smalltalk globals associationAt: each )]. ^ env! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: ''! selectorsFor: aProtocol in: aClass ^(aClass organization listAtCategoryNamed: aProtocol) select: [:each | self includesSelector: each in: aClass]! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! includesProtocol: aProtocol in: aClass ^ true! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 1/3/2010 11:11'! isClassEnvironment ^ false! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 13:00'! isSelectorEnvironment ^ false! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! instVarWritersTo: instVarName in: aClass ^RBVariableEnvironment on: self writersOfInstanceVariable: instVarName in: aClass! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! matches: aString ^RBSelectorEnvironment matches: aString in: self! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! isSystem ^ true! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: ''! selectorsForClass: aClass do: aBlock aClass selectorsAndMethodsDo: [:each :meth | (self includesSelector: each in: aClass) ifTrue: [aBlock value: each]]! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'lr 8/9/2011 21:00'! categories ^ self systemDictionary organization categories select: [ :each | self includesCategory: each ]! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 14:45'! classesDo: aBlock self allClassesDo: [ :each | (self includesClass: each) ifTrue: [ aBlock value: each ] ]! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/28/2013 11:28'! protocolsFor: aClass ^aClass organization realCategories select: [:each | self includesProtocol: each in: aClass]! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'SebastianTleye 4/22/2013 14:00'! allClassesAndTraitsDo: aBlock self systemDictionary allClassesAndTraitsDo: [ :each | aBlock value: each; value: each class ]! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! includesCategory: aCategory ^ true! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'lr 8/9/2011 21:00'! whichCategoryIncludes: aClassName ^ self systemDictionary organization categoryOfElement: aClassName! ! !RBBrowserEnvironment methodsFor: 'accessing-packages' stamp: 'CamilloBruni 7/7/2013 19:01'! packages ^ self packageOrganizer packages select: [ :package | self includesCategory: package name ]! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'lr 3/18/2011 21:07'! environment ^ self! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: ''! referencesTo: aLiteral in: aClass | classes | classes := aClass withAllSuperclasses asSet. classes addAll: aClass allSubclasses; addAll: aClass class withAllSuperclasses; addAll: aClass class allSubclasses. ^(self forClasses: classes) referencesTo: aLiteral! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'lr 9/4/2010 15:45'! selectionParseTreeIntervalFor: aString | parseTree answerBlock | parseTree := RBParser parseMethod: aString onError: [ :str :pos | ^ nil ]. answerBlock := [ :aNode :answer | ^ aNode sourceInterval ]. self searchStrings do: [ :each | | matcher tree | matcher := RBParseTreeSearcher new. matcher matchesTree: (RBLiteralNode value: each) do: answerBlock. each isSymbol ifTrue: [ tree := RBParseTreeSearcher buildSelectorTree: each. tree notNil ifTrue: [ matcher matchesTree: tree do: answerBlock ] ] ifFalse: [ tree := RBVariableNode named: each. matcher matchesTree: tree do: answerBlock; matchesArgumentTree: tree do: answerBlock ]. matcher executeTree: parseTree ]. ^ nil! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 3/20/2011 11:18'! associationAt: aKey ifAbsent: aBlock | association class | association := self systemDictionary associationAt: aKey ifAbsent: [ ^ aBlock value ]. class := association value isBehavior ifTrue: [ association value ] ifFalse: [ association value class ]. ^ ((self includesClass: class) or: [ self includesClass: class class ]) ifTrue: [ association ] ifFalse: [ nil ]! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'CamilloBruni 8/17/2013 22:27'! allClassesDo: aBlock self systemDictionary allClassesDo: [ :each | aBlock value: each; value: each theMetaClass ]! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 14:46'! at: aKey ^ self at: aKey ifAbsent: [ self error: aKey printString , ' not found' ]! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 1/23/2010 17:15'! at: aKey ifAbsent: aBlock | association | association := self associationAt: aKey ifAbsent: [ nil ]. ^ association isNil ifTrue: [ aBlock value ] ifFalse: [ association value ]! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 7/2/2013 23:18'! numberSelectors | total | total := 0. self selectorsDo: [:sel | total := total + 1 ]. ^total! ! !RBBrowserEnvironment methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: self label! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! referencesTo: aLiteral ^RBSelectorEnvironment referencesTo: aLiteral in: self! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! forClass: aClass selectors: selectorCollection ^(RBSelectorEnvironment onMethods: selectorCollection forClass: aClass in: self) label: aClass name , '>>' , (selectorCollection detect: [:each | true] ifNone: ['']); yourself! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! selectMethods: aBlock | env | env := RBSelectorEnvironment onEnvironment: self. self classesAndSelectorsDo: [:each :sel | (aBlock value: (each compiledMethodAt: sel)) ifTrue: [env addClass: each selector: sel]]. ^env! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'lr 2/26/2009 14:29'! selectorsForClass: aClass | selectors | selectors := IdentitySet new. self selectorsForClass: aClass do: [ :each | selectors add: each ]. ^ selectors! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! forClass: aClass protocols: protocolCollection ^RBProtocolEnvironment onEnvironment: self class: aClass protocols: protocolCollection! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'SebastianTleye 4/22/2013 13:59'! classesAndTraitsDo: aBlock self allClassesAndTraitsDo: [ :each | (self includesClass: each) ifTrue: [ aBlock value: each ] ]! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:31'! forCategories: categoryList ^RBCategoryEnvironment onEnvironment: self categories: categoryList! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! | anEnvironment "If we or anEnvironment includes everything, then return it instead of creating an or that will include everything." self isSystem ifTrue: [^self]. anEnvironment isSystem ifTrue: [^anEnvironment]. ^ RBOrEnvironment onEnvironment: self or: anEnvironment! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! asSelectorEnvironment ^(RBClassEnvironment onEnvironment: self classes: self classes) asSelectorEnvironment! ! !RBBrowserEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPutAll: self class name; nextPutAll: ' new'! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'CamilloBruni 8/17/2013 22:15'! includesMethod: aMethod ^ self includesSelector: aMethod selector in: aMethod methodClass! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'lr 8/9/2011 21:00'! classNamesFor: aCategoryName ^ (self systemDictionary organization listAtCategoryNamed: aCategoryName) select: [ :each | | class | class := self systemDictionary at: each ifAbsent: [ nil ]. class notNil and: [ (self includesClass: class) or: [ self includesClass: class class ] ] ]! ! !RBBrowserEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:23'! copyEmpty ^ self class new! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 3/20/2011 11:18'! keys | keys | keys := Set new. self systemDictionary keysAndValuesDo: [ :key :value | | class | value isBehavior ifTrue: [ (self includesClass: value) ifTrue: [ keys add: key ] ]. class := value class. (self includesClass: class) ifTrue: [ keys add: key ] ]. ^ keys! ! !RBBrowserEnvironment methodsFor: 'accessing-packages' stamp: 'CamilloBruni 7/7/2013 18:57'! packageAt: aName ifAbsent: absentBlock | package | package := self packageOrganizer packageNamed: aName ifAbsent: absentBlock. ^ (self includesCategory: aName) ifTrue: [ package ] ifFalse: absentBlock! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 6/10/2010 15:29'! allMetaClasses "Answer all the unique non-metaclasses of all metaclasses in this environment." | classes | classes := IdentitySet new: 4096. self classesDo: [ :each | each isMeta ifTrue: [ classes add: each theNonMetaClass ] ]. ^ classes asArray! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 14:45'! classes | classes | classes := IdentitySet new: 4096. self classesDo: [ :each | classes add: each ]. ^ classes! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 08:37'! definesClass: aClass ^ true! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 8/17/2013 22:32'! classesAndSelectorsDo: aBlock self classesDo: [ :class | self selectorsForClass: class do: [ :sel | aBlock value: class value: sel ]]! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'lr 3/18/2011 21:07'! label ^ label isNil ifTrue: [ self defaultLabel ] ifFalse: [ label ]! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! forPackages: aCollection ^ RBPackageEnvironment onEnvironment: self packages: aCollection! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! forPackageNames: aCollection ^ RBPackageEnvironment onEnvironment: self packageNames: aCollection! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'bh 5/8/2000 21:02'! selectionIntervalFor: aString | interval | self searchStrings isEmpty ifTrue: [^nil]. interval := self selectionParseTreeIntervalFor: aString. interval notNil ifTrue: [^interval]. self searchStrings do: [:each | | search index | search := each isSymbol ifTrue: [each keywords first] ifFalse: [each]. index := aString indexOfSubCollection: search startingAt: 1. index > 0 ifTrue: [^index to: index + search size - 1]]. ^nil! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: ''! problemCount ^self numberSelectors! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 7/2/2013 23:18'! selectors ^ Array streamContents: [ :stream | self selectorsDo: [ :selector | stream nextPut: selector ]]! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 1/23/2010 17:10'! associationAt: aKey ^ self associationAt: aKey ifAbsent: [ self error: aKey printString , ' not found' ]! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! forPragmas: aKeywordCollection ^ RBPragmaEnvironment onEnvironment: self keywords: aKeywordCollection! ! !RBBrowserEnvironment methodsFor: 'accessing-classes' stamp: 'lr 6/10/2010 15:29'! allNonMetaClasses "Answer all the unique non-metaclasses of all of all the non-metaclasses in this environment." | classes | classes := IdentitySet new: 4096. self classesDo: [ :each | each isMeta ifFalse: [ classes add: each ] ]. ^ classes asArray! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: ''! classVariablesFor: aClass ^aClass classVarNames! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'lr 3/18/2011 21:07'! defaultLabel ^ 'Smalltalk'! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 7/2/2013 23:17'! selectorsDo: aBlock self allClassesDo: [ :each | self selectorsForClass: each do: aBlock ].! ! !RBBrowserEnvironment class methodsFor: 'accessing' stamp: 'CamilloBruni 7/2/2013 23:23'! default ^ RBBrowserEnvironment new! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'lr 9/8/2011 20:26'! testEnvironmentWrapper | printString wrapper | printString := RBBrowserEnvironment new referencesTo: #printString. wrapper := RBBrowserEnvironmentWrapper onEnvironment: printString. self assert: wrapper numberSelectors = printString numberSelectors. self assert: wrapper numberClasses = printString numberClasses. self assert: wrapper environment == printString! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'lr 9/8/2011 20:32'! testProtocolEnvironment | aProtocolEnvironment size | aProtocolEnvironment := RBProtocolEnvironment onEnvironment: RBBrowserEnvironment new class: Object protocols: #(#printing #testing). self universalTestFor: aProtocolEnvironment. self assert: (aProtocolEnvironment implementorsOf: #printString) numberSelectors = 1. size := 0. aProtocolEnvironment classesDo: [:each | size := size + 1]. self assert: size = 1. aProtocolEnvironment selectorsForClass: Object do: [:each | self assert: (#(#printing #testing) includes: (RBBrowserEnvironment new whichProtocolIncludes: each in: Object))]! ! !RBBrowserEnvironmentTest methodsFor: 'private' stamp: 'lr 9/5/2010 10:11'! protocolsFor: aBrowserEnvironment aBrowserEnvironment classesAndSelectorsDo: [ :class :selector | | protocol | protocol := aBrowserEnvironment whichProtocolIncludes: selector in: class. self assert: (aBrowserEnvironment includesProtocol: protocol in: class) ]! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'lr 9/8/2011 20:25'! testBrowserEnvironment self universalTestFor: RBBrowserEnvironment new! ! !RBBrowserEnvironmentTest methodsFor: 'testing' stamp: 'lr 9/8/2011 20:25'! testImplementorsMatching | print | print := RBBrowserEnvironment new implementorsMatching: '*print*'. self universalTestFor: print. self assert: (print implementorsOf: #printString) numberSelectors = (RBBrowserEnvironment new implementorsOf: #printString) numberSelectors. print classesAndSelectorsDo: [:class :sel | self assert: ('*print*' match: sel)]! ! !RBBrowserEnvironmentTest methodsFor: 'testing' stamp: 'lr 9/8/2011 20:32'! testConstructedClassEnvironment | environment | environment := RBClassEnvironment new. environment addClass: Object; addClass: OrderedCollection; addClass: Collection. self assert: (environment includesClass: Object). self assert: (environment includesClass: OrderedCollection). self assert: (environment includesClass: Collection). self deny: (environment includesClass: Object class). environment removeClass: Collection. self assert: (environment includesClass: Object). self assert: (environment includesClass: OrderedCollection). self deny: (environment includesClass: Collection). self assert: environment numberClasses = 2. environment addClass: Object class. self assert: environment numberClasses = 2. self assert: (environment includesClass: Object class). environment removeClass: self class. self assert: environment numberClasses = 2! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'CamilloBruni 8/27/2013 01:47'! testPackageEnvironment | aPackageEnvironment | aPackageEnvironment := universalEnvironment forPackageNames: (Array with: 'Refactoring-Tests-Environment' with: 'Refactoring-Tests-Critics'). self universalTestFor: aPackageEnvironment. self assert: (aPackageEnvironment implementorsOf: #testPackageEnvironment) numberSelectors equals: 1! ! !RBBrowserEnvironmentTest methodsFor: 'private' stamp: 'lr 9/5/2010 10:07'! universalTestFor: aBrowserEnvironment self labelFor: aBrowserEnvironment. self uniqueClassesIn: aBrowserEnvironment. self numberSelectorsFor: aBrowserEnvironment. self storeStringFor: aBrowserEnvironment. self classNamesFor: aBrowserEnvironment. self copyFor: aBrowserEnvironment. self categoriesFor: aBrowserEnvironment. self protocolsFor: aBrowserEnvironment. self classesFor: aBrowserEnvironment. self keysFor: aBrowserEnvironment. self assert: aBrowserEnvironment problemCount = 0 = aBrowserEnvironment isEmpty! ! !RBBrowserEnvironmentTest methodsFor: 'private' stamp: 'lr 9/8/2011 20:25'! classesFor: aBrowserEnvironment | allClasses | allClasses := aBrowserEnvironment classes asSet. allClasses addAll: aBrowserEnvironment not classes. RBBrowserEnvironment new allClassesDo: [:each | allClasses remove: each]. self assert: allClasses isEmpty! ! !RBBrowserEnvironmentTest methodsFor: 'testing' stamp: 'lr 12/29/2011 17:30'! testVariableEnvironmentInstVars | refs writers readers classRefs | refs := RBVariableEnvironment referencesToInstanceVariable: 'universalEnvironment' in: self class. writers := RBVariableEnvironment writersOfInstanceVariable: 'universalEnvironment' in: self class. readers := RBVariableEnvironment readersOfInstanceVariable: 'universalEnvironment' in: self class. classRefs := RBVariableEnvironment referencesToClassVariable: 'ClassVariable' in: self class. self universalTestFor: refs. self universalTestFor: writers. self universalTestFor: readers. self universalTestFor: classRefs. self deny: universalEnvironment isVariableEnvironment. self assert: refs isVariableEnvironment. self assert: refs numberSelectors = (writers | readers) numberSelectors! ! !RBBrowserEnvironmentTest methodsFor: 'testing' stamp: 'lr 9/8/2011 20:25'! testMatches | envEnvironment environmentEnvironment | envEnvironment := RBBrowserEnvironment new matches: '*env*'. environmentEnvironment := RBBrowserEnvironment new referencesTo: #environment. self assert: (envEnvironment referencesTo: #environment) numberSelectors = environmentEnvironment numberSelectors! ! !RBBrowserEnvironmentTest methodsFor: 'mockup' stamp: 'lr 9/5/2010 09:55'! classVariableReader ^ ClassVariable! ! !RBBrowserEnvironmentTest methodsFor: 'testing' stamp: 'lr 9/8/2011 20:25'! testSelectMethods | environment | environment := RBBrowserEnvironment new selectMethods: [:each | false]. self assert: environment numberSelectors = 0. self assert: environment numberClasses = 0. environment := RBBrowserEnvironment new selectMethods: [:each | true]. self assert: environment numberSelectors = RBBrowserEnvironment new numberSelectors. environment := RBBrowserEnvironment new selectMethods: [:each | each refersToLiteral: #environment]. self assert: environment numberSelectors = (RBBrowserEnvironment new referencesTo: #environment) numberSelectors! ! !RBBrowserEnvironmentTest methodsFor: 'private' stamp: 'MarcusDenker 4/25/2013 15:10'! storeStringFor: aBrowserEnvironment | newEnvironment | newEnvironment := Smalltalk evaluate: aBrowserEnvironment storeString. self assert: newEnvironment numberSelectors = aBrowserEnvironment numberSelectors. self assert: (newEnvironment not & aBrowserEnvironment) numberSelectors = 0 ! ! !RBBrowserEnvironmentTest methodsFor: 'testing' stamp: 'lr 9/8/2011 20:25'! testSystemIntegrity | classes environment | classes := IdentitySet new. environment := RBBrowserEnvironment new. environment allClassesDo: [ :class | (classes includes: class) ifFalse: [ classes add: class ] ifTrue: [ self error: 'The class ' , class name , ' that is available under two or more names. This causes problems with the refactoring browser.' ] ]! ! !RBBrowserEnvironmentTest methodsFor: 'private' stamp: 'lr 9/4/2010 17:33'! keysFor: aBrowserEnvironment | allKeys | allKeys := IdentitySet withAll: aBrowserEnvironment keys. allKeys addAll: aBrowserEnvironment not keys. allKeys removeAll: Smalltalk keys. self assert: allKeys isEmpty! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'StephaneDucasse 8/29/2013 20:52'! testOrEnvironment | env1 env2 orEnvironment | env2 := #printOn:. env2 := universalEnvironment forClass: Object selectors: #(#fullPrintString). env1 := universalEnvironment forClass: Object selectors: #(#printOn:). self assert: (env1 | env2) numberSelectors = 2. self assert: (env2 | env1) numberSelectors = 2. self universalTestFor: env1 | env2. self assert: (env1 | env1) numberSelectors = 1. orEnvironment := env1 | env1 not. self universalTestFor: orEnvironment. self assert: orEnvironment numberSelectors = universalEnvironment numberSelectors. self assert: orEnvironment classNames asSortedCollection = universalEnvironment classNames asSortedCollection. self assert: (orEnvironment protocolsFor: Object) = ((universalEnvironment protocolsFor: Object) reject: [:each| (Object allSelectorsInProtocol: each) isEmpty ]) ! ! !RBBrowserEnvironmentTest methodsFor: 'private' stamp: 'lr 9/4/2010 17:33'! copyFor: aBrowserEnvironment | newEnvironment | newEnvironment := aBrowserEnvironment copy. self assert: newEnvironment numberSelectors = aBrowserEnvironment numberSelectors. self assert: (newEnvironment not & aBrowserEnvironment) numberSelectors = 0! ! !RBBrowserEnvironmentTest methodsFor: 'testing' stamp: 'lr 9/8/2011 20:32'! testConstructedSelectorEnvironment | environment newEnvironment | environment := RBSelectorEnvironment new. environment addClass: Object selector: #printString; addClass: OrderedCollection selector: #add:; addClass: Collection. self assert: (environment includesClass: Object). self assert: (environment selectorsForClass: Object) size = 1. self assert: (environment includesClass: OrderedCollection). self assert: (environment selectorsForClass: OrderedCollection) size = 1. self assert: (environment includesClass: Collection). self assert: (environment selectorsForClass: Collection) size = Collection selectors size. self deny: (environment includesClass: Object class). newEnvironment := environment copy. newEnvironment removeClass: OrderedCollection; addClass: Object selector: #printOn:; removeClass: Object selector: #printString. self assert: (newEnvironment includesClass: Object). self deny: (newEnvironment includesSelector: #printString in: Object). self deny: (newEnvironment includesClass: OrderedCollection). self assert: (newEnvironment includesClass: Collection). self assert: newEnvironment numberClasses = 2. self assert: newEnvironment numberSelectors + 1 = environment numberSelectors. newEnvironment addClass: Object class. self assert: newEnvironment numberClasses = 2. self assert: (newEnvironment includesClass: Object class). newEnvironment removeClass: self class. self assert: newEnvironment numberClasses = 2! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'lr 9/5/2010 09:42'! testPragmaEnvironment | aPragmaEnvironment | aPragmaEnvironment := universalEnvironment forPragmas: #(primitive:). self universalTestFor: aPragmaEnvironment! ! !RBBrowserEnvironmentTest methodsFor: 'private' stamp: 'lr 9/4/2010 17:33'! categoriesFor: anEnvironment | allCategories | allCategories := IdentitySet withAll: universalEnvironment categories. allCategories removeAll: anEnvironment categories. anEnvironment not categories do: [ :each | allCategories remove: each ifAbsent: [ ] ]. allCategories do: [ :each | self assert: (universalEnvironment classNamesFor: each) isEmpty ]! ! !RBBrowserEnvironmentTest methodsFor: 'private' stamp: 'lr 9/4/2010 17:33'! numberSelectorsFor: aBrowserEnvironment | numberSelectors numberSelectorsNot | numberSelectors := aBrowserEnvironment numberSelectors. numberSelectorsNot := aBrowserEnvironment not numberSelectors. self assert: numberSelectors + numberSelectorsNot = universalEnvironment numberSelectors. self assert: (aBrowserEnvironment & aBrowserEnvironment not) numberSelectors = 0. self assert: (universalEnvironment & aBrowserEnvironment) numberSelectors = numberSelectors. self assert: (aBrowserEnvironment & universalEnvironment) numberSelectors = numberSelectors! ! !RBBrowserEnvironmentTest methodsFor: 'private' stamp: 'lr 9/4/2010 17:33'! classNamesFor: anEnvironment | classNames allClassNames | classNames := IdentitySet new addAll: anEnvironment classNames asSet; addAll: anEnvironment not classNames; yourself. allClassNames := universalEnvironment classNames asSortedCollection. self assert: classNames asSortedCollection = allClassNames. self assert: (anEnvironment & anEnvironment not) classNames isEmpty. self assert: (anEnvironment | anEnvironment not) classNames asSortedCollection = allClassNames! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'lr 9/5/2010 09:19'! testAndEnvironment | originalEnvironment objectPrintStringEnvironment andEnvironment | originalEnvironment := universalEnvironment referencesTo: #printOn:. objectPrintStringEnvironment := universalEnvironment forClass: Object selectors: #(#fullPrintString). andEnvironment := objectPrintStringEnvironment & originalEnvironment. self universalTestFor: andEnvironment. self assert: andEnvironment numberSelectors = 1. self assert: andEnvironment classNames asArray = #(#Object). self assert: (andEnvironment protocolsFor: Object) size = 1. andEnvironment := originalEnvironment & (universalEnvironment referencesTo: #printString). self assert: andEnvironment numberSelectors = (originalEnvironment referencesTo: #printString) numberSelectors. self assert: andEnvironment classNames asSortedCollection = (originalEnvironment referencesTo: #printString) classNames asSortedCollection! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'CamilloBruni 8/27/2013 01:55'! testCategoryEnvironment | aCategoryEnvironment | self skip: 'Use RBPackageEnvironment instead.'. aCategoryEnvironment := RBCategoryEnvironment onEnvironment: RBBrowserEnvironment new categories: #(#'Kernel-Objects'). self universalTestFor: aCategoryEnvironment. self assert: (aCategoryEnvironment implementorsOf: #printString) numberSelectors equals: 1! ! !RBBrowserEnvironmentTest methodsFor: 'private' stamp: 'lr 9/4/2010 17:33'! uniqueClassesIn: aBrowserEnvironment | allClasses | allClasses := IdentitySet new. aBrowserEnvironment classesDo: [ :each | self deny: (allClasses includes: each). allClasses add: each ]! ! !RBBrowserEnvironmentTest methodsFor: 'running' stamp: 'lr 9/8/2011 20:25'! setUp super setUp. universalEnvironment := RBBrowserEnvironment new! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'lr 9/5/2010 09:32'! testNotEnvironment | notPrintStringEnvironment printStringEnvironment | printStringEnvironment := universalEnvironment referencesTo: #printString. notPrintStringEnvironment := printStringEnvironment not. self universalTestFor: notPrintStringEnvironment. self assert: (notPrintStringEnvironment referencesTo: #printString) isEmpty. self assert: (notPrintStringEnvironment not includesClass: RBBrowserEnvironmentTest). self assert: (notPrintStringEnvironment not includesSelector: #testNotEnvironment in: RBBrowserEnvironmentTest)! ! !RBBrowserEnvironmentTest methodsFor: 'mockup' stamp: 'lr 9/5/2010 09:55'! classVariableWriter ClassVariable := nil! ! !RBBrowserEnvironmentTest methodsFor: 'private' stamp: 'lr 9/5/2010 10:01'! labelFor: aBrowserEnvironment self deny: aBrowserEnvironment label isNil. self deny: aBrowserEnvironment label isEmpty. self deny: aBrowserEnvironment defaultLabel isNil. self deny: aBrowserEnvironment defaultLabel isEmpty! ! !RBBrowserEnvironmentTest methodsFor: 'testing' stamp: 'lr 9/8/2011 20:32'! testRemoveSelectorByAndAndNot | aBrowserEnvironment objectPrintString | aBrowserEnvironment := RBBrowserEnvironment new. objectPrintString := RBSelectorEnvironment onEnvironment: aBrowserEnvironment. objectPrintString addClass: Object selector: #printString. self assert: aBrowserEnvironment numberSelectors - 1 = (aBrowserEnvironment & objectPrintString not) numberSelectors. self universalTestFor: aBrowserEnvironment & objectPrintString not! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'lr 9/8/2011 20:25'! testSelectorEnvironment | printString | printString := RBBrowserEnvironment new referencesTo: #printString. self universalTestFor: printString. self deny: universalEnvironment isSelectorEnvironment. self assert: printString isSelectorEnvironment. self assert: printString numberSelectors = (printString referencesTo: #printString) numberSelectors. self assert: printString numberClasses = (printString referencesTo: #printString) numberClasses! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'lr 9/8/2011 20:32'! testClassEnvironment | aClassEnvironment | aClassEnvironment := RBClassEnvironment onEnvironment: universalEnvironment classes: (Array with: Object with: Object class). self universalTestFor: aClassEnvironment. self deny: (universalEnvironment isClassEnvironment). self assert: (aClassEnvironment isClassEnvironment). self assert: (aClassEnvironment implementorsOf: #printString) numberSelectors = 1! ! !RBBrowserEnvironmentTest methodsFor: 'testing' stamp: 'lr 9/8/2011 20:32'! testVariableEnvironmentAddRemove | refs | refs := RBVariableEnvironment new. refs addClass: self class instanceVariable: 'universalEnvironment'. self assert: refs numberSelectors > 0. self assert: refs numberClasses = 1. refs removeClass: self class instanceVariable: 'universalEnvironment'. self assert: refs numberSelectors = 0. self assert: refs numberClasses = 0. refs addClass: self class instanceVariableReader: 'universalEnvironment'. self assert: refs numberSelectors > 0. self assert: refs numberClasses = 1. refs removeClass: self class instanceVariableReader: 'universalEnvironment'. self assert: refs numberSelectors = 0. self assert: refs numberClasses = 0. refs addClass: self class instanceVariableWriter: 'universalEnvironment'. self assert: refs numberSelectors > 0. self assert: refs numberClasses = 1. refs removeClass: self class instanceVariableWriter: 'universalEnvironment'. self assert: refs numberSelectors = 0. self assert: refs numberClasses = 0. refs addClass: self class classVariable: 'ClassVariable'. self assert: refs numberSelectors > 0. self assert: refs numberClasses = 1. refs removeClass: self class classVariable: 'ClassVariable'. self assert: refs numberSelectors = 0. self assert: refs numberClasses = 0 ! ! !RBBrowserEnvironmentTest class methodsFor: 'as yet unclassified' stamp: 'lr 9/5/2010 09:37'! packageNamesUnderTest ^ #('Refactoring-Environment')! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! includesClass: aClass ^environment includesClass: aClass! ! !RBBrowserEnvironmentWrapper methodsFor: 'private' stamp: 'lr 3/20/2011 11:18'! systemDictionary ^ environment systemDictionary! ! !RBBrowserEnvironmentWrapper methodsFor: '*NautilusCommon' stamp: 'SebastianTleye 4/23/2013 18:05'! packagesWithoutExtensions ^ (self classes gather: [:each | each packagesWithoutExtensions]) asSet! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! isEmpty self classesDo: [:each | ^false]. ^true! ! !RBBrowserEnvironmentWrapper methodsFor: 'initialize-release' stamp: ''! onEnvironment: anEnvironment environment := anEnvironment! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! includesCategory: aCategory ^environment includesCategory: aCategory! ! !RBBrowserEnvironmentWrapper methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPutAll: '('; nextPutAll: self class name; nextPutAll: ' onEnvironment: '. environment storeOn: aStream. aStream nextPut: $)! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! includesSelector: aSelector in: aClass ^(self includesClass: aClass) and: [environment includesSelector: aSelector in: aClass]! ! !RBBrowserEnvironmentWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/10/2012 20:30'! packages ^ (self classes gather: [:each | each packages]) asSet! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: 'lr 11/25/2009 08:38'! definesClass: aClass ^ environment definesClass: aClass! ! !RBBrowserEnvironmentWrapper methodsFor: 'private' stamp: 'lr 3/18/2011 21:07'! environment ^ environment! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! includesProtocol: aProtocol in: aClass ^(self includesClass: aClass) and: [environment includesProtocol: aProtocol in: aClass]! ! !RBBrowserEnvironmentWrapper methodsFor: 'accessing' stamp: 'bh 5/8/2000 21:03'! selectionIntervalFor: aString | interval | interval := super selectionIntervalFor: aString. ^interval notNil ifTrue: [interval] ifFalse: [environment selectionIntervalFor: aString]! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: ''! isSystem ^false! ! !RBBrowserEnvironmentWrapper methodsFor: 'private' stamp: 'lr 3/20/2011 11:17'! rootEnvironment ^ environment rootEnvironment! ! !RBBrowserEnvironmentWrapper class methodsFor: 'instance creation' stamp: ''! onEnvironment: anEnvironment ^(self basicNew) initialize; onEnvironment: anEnvironment; yourself! ! !RBBrowserEnvironmentWrapper class methodsFor: 'instance creation' stamp: 'lr 9/8/2011 20:25'! new ^ self onEnvironment: RBBrowserEnvironment new! ! !RBCascadeNode commentStamp: ''! RBCascadeNode is an AST node for cascaded messages (e.g., "self print1 ; print2"). Instance Variables: messages the messages semicolons positions of the ; between messages ! !RBCascadeNode methodsFor: 'testing' stamp: ''! directlyUses: aNode ^messages last = aNode and: [self isDirectlyUsed]! ! !RBCascadeNode methodsFor: 'accessing' stamp: ''! stopWithoutParentheses ^messages last stop! ! !RBCascadeNode methodsFor: 'querying' stamp: ''! bestNodeFor: anInterval | selectedChildren | (self intersectsInterval: anInterval) ifFalse: [^nil]. (self containedBy: anInterval) ifTrue: [^self]. messages reverseDo: [:each | (each containedBy: anInterval) ifTrue: [^each]]. selectedChildren := (messages collect: [:each | each bestNodeFor: anInterval]) reject: [:each | each isNil]. ^selectedChildren detect: [:each | true] ifNone: [nil]! ! !RBCascadeNode methodsFor: 'accessing' stamp: ''! children ^self messages! ! !RBCascadeNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:29'! isFaulty ^self messages anySatisfy: #isFaulty! ! !RBCascadeNode methodsFor: 'accessing' stamp: ''! messages ^messages! ! !RBCascadeNode methodsFor: 'initialize-release' stamp: ''! messages: messageNodes semicolons: integerCollection self messages: messageNodes. semicolons := integerCollection! ! !RBCascadeNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:26'! semicolons: anArray semicolons := anArray! ! !RBCascadeNode methodsFor: 'accessing' stamp: ''! messages: messageNodeCollection messages := messageNodeCollection. messages do: [:each | each parent: self]! ! !RBCascadeNode methodsFor: 'comparing' stamp: 'lr 3/7/2010 13:49'! hash ^ self hashForCollection: self messages! ! !RBCascadeNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:36'! copyInContext: aDictionary ^ self class new messages: (self copyList: self messages inContext: aDictionary); yourself! ! !RBCascadeNode methodsFor: 'querying' stamp: ''! whichNodeIsContainedBy: anInterval | selectedChildren | (self intersectsInterval: anInterval) ifFalse: [^nil]. (self containedBy: anInterval) ifTrue: [^self]. messages reverseDo: [:each | (each containedBy: anInterval) ifTrue: [^each]]. selectedChildren := (messages collect: [:each | each whichNodeIsContainedBy: anInterval]) reject: [:each | each isNil]. ^selectedChildren detect: [:each | true] ifNone: [nil]! ! !RBCascadeNode methodsFor: 'accessing' stamp: ''! precedence ^4! ! !RBCascadeNode methodsFor: 'replacing' stamp: ''! replaceNode: aNode withNode: anotherNode self messages: (messages collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! ! !RBCascadeNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:26'! semicolons ^ semicolons! ! !RBCascadeNode methodsFor: 'comparing' stamp: 'lr 5/30/2010 11:34'! equalTo: anObject withMapping: aDictionary self class = anObject class ifFalse: [^false]. self messages size = anObject messages size ifFalse: [^false]. 1 to: self messages size do: [:i | ((self messages at: i) equalTo: (anObject messages at: i) withMapping: aDictionary) ifFalse: [^false]]. ^true! ! !RBCascadeNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:36'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitCascadeNode: self! ! !RBCascadeNode methodsFor: 'accessing' stamp: ''! receiver ^self messages first receiver! ! !RBCascadeNode methodsFor: 'accessing' stamp: ''! startWithoutParentheses ^messages first start! ! !RBCascadeNode methodsFor: 'testing' stamp: ''! uses: aNode ^messages last = aNode and: [self isUsed]! ! !RBCascadeNode methodsFor: 'comparing' stamp: ''! = anObject self == anObject ifTrue: [^true]. self class = anObject class ifFalse: [^false]. self messages size = anObject messages size ifFalse: [^false]. 1 to: self messages size do: [:i | (self messages at: i) = (anObject messages at: i) ifFalse: [^false]]. ^true! ! !RBCascadeNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:36'! postCopy super postCopy. self messages: (self messages collect: [ :each | each copy ])! ! !RBCascadeNode methodsFor: 'matching' stamp: 'lr 5/30/2010 11:34'! match: aNode inContext: aDictionary aNode class = self class ifFalse: [^false]. ^self matchList: messages against: aNode messages inContext: aDictionary! ! !RBCascadeNode methodsFor: 'testing' stamp: 'ClementBera 7/26/2013 17:15'! needsParenthesis ^parent ifNil: [false] ifNotNil: [self precedence > parent precedence]! ! !RBCascadeNode methodsFor: 'testing' stamp: ''! isCascade ^true! ! !RBCascadeNode methodsFor: 'accessing' stamp: ''! statementComments | statementComments | statementComments := OrderedCollection withAll: self comments. statementComments addAll: messages first receiver statementComments. messages do: [:each | each arguments do: [:arg | statementComments addAll: arg statementComments]]. ^statementComments asSortedCollection: [:a :b | a first < b first]! ! !RBCascadeNode class methodsFor: 'instance creation' stamp: ''! messages: messageNodes ^self new messages: messageNodes! ! !RBCascadeNode class methodsFor: 'instance creation' stamp: ''! messages: messageNodes semicolons: integerCollection ^self new messages: messageNodes semicolons: integerCollection! ! !RBCascadedNextPutAllsRule commentStamp: ''! See rationale! !RBCascadedNextPutAllsRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:29'! initialize super initialize. self rewriteRule replace: '``@rcvr nextPutAll: ``@object1 , ``@object2' with: '``@rcvr nextPutAll: ``@object1; nextPutAll: ``@object2'; replace: '``@rcvr show: ``@object1 , ``@object2' with: '``@rcvr show: ``@object1; show: ``@object2'! ! !RBCascadedNextPutAllsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBCascadedNextPutAllsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Use cascaded nextPutAll:''s instead of #, in #nextPutAll:'! ! !RBCascadedNextPutAllsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:50'! category ^ 'Coding Idiom Violation'! ! !RBCascadedNextPutAllsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'CascadedNextPutAllsRule'! ! !RBCategoryEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 08:31'! includesClass: aClass ^ (super includesClass: aClass) and: [ categories includes: aClass theNonMetaClass category ]! ! !RBCategoryEnvironment methodsFor: 'initialization' stamp: 'lr 2/26/2009 14:25'! initialize super initialize. categories := IdentitySet new! ! !RBCategoryEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:21'! postCopy super postCopy. categories := categories copy! ! !RBCategoryEnvironment methodsFor: 'testing' stamp: ''! isEmpty ^categories isEmpty! ! !RBCategoryEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. super storeOn: aStream. aStream nextPutAll: ' categories: '. categories asArray storeOn: aStream. aStream nextPut: $)! ! !RBCategoryEnvironment methodsFor: 'testing' stamp: ''! includesCategory: aCategory ^(categories includes: aCategory) and: [super includesCategory: aCategory]! ! !RBCategoryEnvironment methodsFor: 'private' stamp: ''! defaultLabel | stream | stream := String new writeStream. categories do: [:each | stream nextPutAll: each; nextPut: $ ]. ^stream contents! ! !RBCategoryEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 8/27/2013 01:54'! numberSelectors | total | total := 0. self classesDo: [:each | self selectorsForClass: each do: [ :sel | total := total + 1 ]]. ^total! ! !RBCategoryEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 14:32'! classNames ^ self categories inject: IdentitySet new into: [ :answer :each | answer addAll: (self classNamesFor: each); yourself ]! ! !RBCategoryEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/26/2009 14:25'! categories: aCollection categories addAll: aCollection! ! !RBCategoryEnvironment methodsFor: 'adding' stamp: 'lr 2/8/2009 10:46'! addCategory: aSymbol categories add: aSymbol! ! !RBCategoryEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:23'! onEnvironment: anEnvironment categories: aCollection ^(self onEnvironment: anEnvironment) categories: aCollection; yourself! ! !RBCategoryEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:23'! categories: aCollection ^ self onEnvironment: self default categories: aCollection! ! !RBCategoryEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:24'! category: aCategory ^ self categories: { aCategory }! ! !RBCategoryRegexRefactoring methodsFor: 'transforming' stamp: ''! transform | replacement | self model allClassesDo: [ :class | (class isNil or: [ class isMeta ]) ifFalse: [ replacement := self execute: class category. replacement = class category asString ifFalse: [ class category: replacement. self model defineClass: class definitionString ] ] ]! ! !RBChangeMethodNameRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/7/2012 23:59'! renameImplementors self implementors do: [:each | | parseTree | parseTree := each parseTreeFor: oldSelector. parseTree isNil ifTrue: [self refactoringFailure: 'Could not parse source code.']. self implementorsCanBePrimitives ifFalse: [parseTree isPrimitive ifTrue: [self refactoringFailure: ('<1p>''s implementation of #<2s> is a primitive' expandMacrosWith: each with: oldSelector)]]. self modifyImplementorParseTree: parseTree in: each. (each methodFor: oldSelector) compileTree: parseTree]! ! !RBChangeMethodNameRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/7/2012 23:29'! preconditions "This refactoring only preserves behavior if all implementors are renamed." | conditions | conditions := self myConditions & (RBCondition definesSelector: oldSelector in: class) & (RBCondition isValidMethodName: newSelector for: class). conditions := self implementors inject: conditions into: [ :condition :each | condition & (RBCondition hierarchyOf: each canUnderstand: newSelector) not ]. ^conditions & (RBCondition withBlock: [self implementors size > 1 ifTrue: [self refactoringWarning: ('This will modify all <1p> implementors.' expandMacrosWith: self implementors size)]. true])! ! !RBChangeMethodNameRefactoring methodsFor: 'preconditions' stamp: ''! myConditions ^self subclassResponsibility! ! !RBChangeMethodNameRefactoring methodsFor: 'transforming' stamp: 'lr 12/23/2009 20:00'! transform self renameImplementors. self renameMessageSends. self removeRenamedImplementors! ! !RBChangeMethodNameRefactoring methodsFor: 'accessing' stamp: ''! newSelector ^newSelector! ! !RBChangeMethodNameRefactoring methodsFor: 'transforming' stamp: 'lr 12/23/2009 19:59'! removeRenamedImplementors oldSelector = newSelector ifTrue: [ ^ self ]. self implementors do: [ :each | each removeMethod: oldSelector ]! ! !RBChangeMethodNameRefactoring methodsFor: 'initialize-release' stamp: 'md 3/15/2006 17:27'! renameMethod: aSelector in: aClass to: newSel permutation: aMap oldSelector := aSelector asSymbol. newSelector := newSel asSymbol. class := self classObjectFor: aClass. permutation := aMap! ! !RBChangeMethodNameRefactoring methodsFor: 'private' stamp: 'lr 11/23/2009 10:58'! modifyImplementorParseTree: parseTree in: aClass | oldArgs | oldArgs := parseTree arguments. parseTree renameSelector: newSelector andArguments: (permutation collect: [:each | oldArgs at: each]) ! ! !RBChangeMethodNameRefactoring methodsFor: 'private' stamp: 'lr 11/2/2009 00:14'! parseTreeRewriter | rewriteRule oldString newString | rewriteRule := RBParseTreeRewriter new. oldString := self buildSelectorString: oldSelector. newString := self buildSelectorString: newSelector withPermuteMap: permutation. rewriteRule replace: '``@object ' , oldString with: '``@object ' , newString. ^rewriteRule! ! !RBChangeMethodNameRefactoring methodsFor: 'testing' stamp: ''! hasPermutedArguments oldSelector numArgs = newSelector numArgs ifFalse: [^true]. 1 to: oldSelector numArgs do: [:i | (permutation at: i) = i ifFalse: [^true]]. ^false! ! !RBChangeMethodNameRefactoring methodsFor: 'transforming' stamp: ''! renameMessageSends self convertAllReferencesTo: oldSelector using: self parseTreeRewriter! ! !RBChangeMethodNameRefactoring methodsFor: 'private' stamp: ''! implementors implementors isNil ifTrue: [implementors := self model allImplementorsOf: oldSelector]. ^implementors! ! !RBChangeMethodNameRefactoring methodsFor: 'testing' stamp: ''! implementorsCanBePrimitives ^false! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-methods' stamp: ''! computeSubclassSupersOf: aClass | selectors | selectors := Set new. aClass subclasses do: [:each | each selectors do: [:sel | selectors addAll: (each parseTreeFor: sel) superMessages]]. ^selectors! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-variables' stamp: 'MartinDias 11/7/2013 18:11'! pullUpPoolVariables "Don't remove the pool variables from the subclass since they might be referenced there." | newSuperclass | newSuperclass := self abstractSuperclass. parent sharedPoolNames do: [:each | newSuperclass addPoolDictionary: each]! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-methods' stamp: ''! subclassResponsibilityFor: aSelector in: aClass | methodNode position source | source := aClass sourceCodeFor: aSelector. methodNode := RBParser parseMethod: source onError: [:err :pos | ^nil]. position := methodNode arguments isEmpty ifTrue: [methodNode selectorParts last stop] ifFalse: [methodNode arguments last stop]. ^'<1s>self subclassResponsibility' expandMacrosWith: (source copyFrom: 1 to: position)! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-methods' stamp: 'lr 10/26/2009 22:09'! shouldPushUp: aSelector from: aClass ^ ((aClass isMeta ifTrue: [ subclasses collect: [ :each | each theMetaClass ] ] ifFalse: [ subclasses ]) detect: [ :each | (each directlyDefinesMethod: aSelector) not ] ifNone: [ nil ]) notNil! ! !RBChildrenToSiblingsRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^subclasses inject: ((RBCondition isMetaclass: parent) errorMacro: 'Superclass must not be a metaclass') not & (RBCondition isValidClassName: className) & (RBCondition isGlobal: className in: self model) not into: [:sub :each | sub & ((RBCondition isMetaclass: each) errorMacro: 'Subclass must <1?not :>be a metaclass') not & (RBCondition isImmediateSubclass: each of: parent)]! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-variables' stamp: 'lr 9/8/2011 20:11'! pullUpClassVariables | newSuperclass | newSuperclass := self abstractSuperclass. parent classVariableNames do: [:each | self performComponentRefactoring: (RBPullUpClassVariableRefactoring model: self model variable: each class: newSuperclass)]! ! !RBChildrenToSiblingsRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' name: #'; nextPutAll: className; nextPutAll: ' class: '. parent storeOn: aStream. aStream nextPutAll: ' subclasses: '. subclasses asArray storeOn: aStream. aStream nextPut: $)! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-variables' stamp: 'lr 9/8/2011 20:11'! pullUpInstanceVariables | newSuperclass | newSuperclass := self abstractSuperclass. parent instanceVariableNames do: [:each | self performComponentRefactoring: (RBPullUpInstanceVariableRefactoring model: self model variable: each class: newSuperclass)]! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-methods' stamp: ''! selectorsToPushUpFrom: aClass | superSelectors | superSelectors := self computeSubclassSupersOf: aClass. ^aClass selectors select: [:each | (superSelectors includes: each) or: [self shouldPushUp: each from: aClass]]! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-accessing' stamp: ''! abstractSuperclass ^self model classNamed: className asSymbol! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-methods' stamp: ''! pushUp: aSelector in: aClass | source | source := aClass sourceCodeFor: aSelector. source isNil ifFalse: [aClass superclass compile: source classified: (aClass protocolsFor: aSelector)]! ! !RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: 'lr 7/17/2010 23:24'! pullUpMethods self pushUpMethodsFrom: parent. self pushUpMethodsFrom: parent theMetaClass! ! !RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: ''! reparentSubclasses self model reparentClasses: subclasses to: self abstractSuperclass! ! !RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: ''! pushUpVariables self pullUpInstanceVariables. self pullUpClassInstanceVariables. self pullUpClassVariables. self pullUpPoolVariables! ! !RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: 'lr 7/17/2010 23:24'! transform self addSuperclass; pushUpVariables; pullUpMethods; changeIsKindOfReferences; reparentSubclasses! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-methods' stamp: ''! createSubclassResponsibilityFor: aSelector in: aClass | source | (aClass superclass definesMethod: aSelector) ifTrue: [^self]. source := self subclassResponsibilityFor: aSelector in: aClass. source isNil ifTrue: [^self]. aClass superclass compile: source classified: (aClass protocolsFor: aSelector)! ! !RBChildrenToSiblingsRefactoring methodsFor: 'initialize-release' stamp: ''! name: aClassName class: aClass subclasses: subclassCollection className := aClassName asSymbol. parent := self model classFor: aClass. subclasses := subclassCollection collect: [:each | self model classFor: each]! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-methods' stamp: ''! pushUpMethodsFrom: aClass | selectorsToPushUp | selectorsToPushUp := self selectorsToPushUpFrom: aClass. aClass selectors do: [:each | (selectorsToPushUp includes: each) ifTrue: [self pushUp: each in: aClass] ifFalse: [self createSubclassResponsibilityFor: each in: aClass]]. selectorsToPushUp do: [:each | aClass removeMethod: each]! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-variables' stamp: 'lr 9/8/2011 20:11'! pullUpClassInstanceVariables | newSuperclass | newSuperclass := self abstractSuperclass theMetaClass. parent theMetaClass instanceVariableNames do: [ :each | self performComponentRefactoring: (RBPullUpInstanceVariableRefactoring model: self model variable: each class: newSuperclass) ]! ! !RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! changeIsKindOfReferences | replacer | replacer := RBParseTreeRewriter new. replacer replace: '``@object isKindOf: ' , parent name with: '``@object isKindOf: ' , className. self convertAllReferencesToClass: parent using: replacer! ! !RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! addSuperclass self performComponentRefactoring: (RBAddClassRefactoring model: self model addClass: className superclass: parent superclass subclasses: (Array with: parent) category: parent category)! ! !RBChildrenToSiblingsRefactoring class methodsFor: 'instance creation' stamp: ''! name: aClassName class: aClass subclasses: subclassCollection ^(self new) name: aClassName class: aClass subclasses: subclassCollection; yourself! ! !RBChildrenToSiblingsRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk name: aClassName class: aClass subclasses: subclassCollection ^(self new) model: aRBSmalltalk; name: aClassName class: aClass subclasses: subclassCollection; yourself! ! !RBChildrenToSiblingsTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadName self shouldFail: (RBChildrenToSiblingsRefactoring name: #'Obje ct' class: RBLintRuleTest subclasses: (Array with: RBBasicLintRuleTest with: RBCompositeLintRuleTest))! ! !RBChildrenToSiblingsTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelChildrenToSibling | refactoring class subclass superclass | class := model classNamed: #ConcreteSuperclass. subclass := model classNamed: #ConcreteSubclass. refactoring := RBChildrenToSiblingsRefactoring model: model name: #AbstractSuperclass class: class subclasses: (Array with: subclass). self executeRefactoring: refactoring. superclass := refactoring model classNamed: #AbstractSuperclass. self assert: class superclass = superclass. self assert: class theMetaClass superclass = superclass theMetaClass. self assert: subclass superclass = superclass. self assert: subclass theMetaClass superclass = superclass theMetaClass. self assert: (superclass parseTreeFor: #same) = (RBParser parseMethod: 'same ^self initialize isKindOf: AbstractSuperclass'). self assert: (superclass parseTreeFor: #different) = (RBParser parseMethod: 'different self subclassResponsibility'). self assert: (superclass parseTreeFor: #initialize) = (RBParser parseMethod: 'initialize instVarName1 := instVarName2 := ClassVarName1 := ClassVarName2 := 0'). self assert: (superclass directlyDefinesInstanceVariable: 'instVarName1'). self assert: (superclass directlyDefinesInstanceVariable: 'instVarName2'). self assert: (superclass directlyDefinesClassVariable: 'ClassVarName1'). self assert: (superclass directlyDefinesClassVariable: 'ClassVarName2'). self assert: (superclass theMetaClass directlyDefinesInstanceVariable: 'classInstVarName1'). self assert: (superclass theMetaClass parseTreeFor: #foo) = (RBParser parseMethod: 'foo ^classInstVarName1 + ClassVarName1 + ClassVarName2'). self assert: (superclass theMetaClass parseTreeFor: #new) = (RBParser parseMethod: 'new ^super new initialize'). self assert: (superclass theMetaClass parseTreeFor: #bar) = (RBParser parseMethod: 'bar self subclassResponsibility'). self deny: (class directlyDefinesInstanceVariable: 'instVarName1'). self deny: (class directlyDefinesInstanceVariable: 'instVarName2'). self deny: (class directlyDefinesClassVariable: 'ClassVarName1'). self deny: (class directlyDefinesClassVariable: 'ClassVarName2'). self deny: (class theMetaClass directlyDefinesInstanceVariable: 'classInstVarName1'). self deny: (class directlyDefinesMethod: #same). self deny: (class directlyDefinesMethod: #initialize). self deny: (class theMetaClass directlyDefinesMethod: #new). self assert: (class parseTreeFor: #different) = (RBParser parseMethod: 'different ^instVarName1 + instVarName2'). self assert: (class theMetaClass parseTreeFor: #bar) = (RBParser parseMethod: 'bar ^self printString')! ! !RBChildrenToSiblingsTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMetaClassFailure self shouldFail: (RBChildrenToSiblingsRefactoring name: #Foo class: RBLintRuleTest class subclasses: (Array with: RBBasicLintRuleTest class with: RBCompositeLintRuleTest class))! ! !RBChildrenToSiblingsTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testInvalidSubclass self shouldFail: (RBChildrenToSiblingsRefactoring name: #Foo class: RBRefactoringTest subclasses: (Array with: RBBasicLintRuleTest with: RBCompositeLintRuleTest))! ! !RBChildrenToSiblingsTest methodsFor: 'set up' stamp: 'MarcusDenker 4/25/2013 15:10'! setUp super setUp. model := Smalltalk evaluate: self childrenToSiblingTestData! ! !RBChildrenToSiblingsTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testExistingName self shouldFail: (RBChildrenToSiblingsRefactoring name: #Object class: RBLintRuleTest subclasses: (Array with: RBBasicLintRuleTest with: RBCompositeLintRuleTest)); shouldFail: (RBChildrenToSiblingsRefactoring name: #Processor class: RBLintRuleTest subclasses: (Array with: RBBasicLintRuleTest with: RBCompositeLintRuleTest))! ! !RBClass methodsFor: 'accessing' stamp: ''! category: aSymbol category := aSymbol! ! !RBClass methodsFor: 'accessing' stamp: ''! classVariableNames ^self privateClassVariableNames copy! ! !RBClass methodsFor: 'accessing' stamp: 'lr 7/1/2008 10:55'! comment: aString model comment: (comment := aString) in: self! ! !RBClass methodsFor: 'accessing' stamp: ''! classVariableNames: aCollectionOfStrings classVariableNames := (aCollectionOfStrings collect: [:each | each asSymbol]) asOrderedCollection! ! !RBClass methodsFor: 'variable accessing' stamp: ''! renameClassVariable: oldName to: newName around: aBlock self privateClassVariableNames at: (self privateClassVariableNames indexOf: oldName asSymbol) put: newName asSymbol. model renameClassVariable: oldName to: newName in: self around: aBlock! ! !RBClass methodsFor: 'accessing' stamp: 'lr 7/1/2008 11:09'! comment ^ comment = LookupComment ifTrue: [ comment := self isDefined ifTrue: [ self realClass comment ] ifFalse: [ nil ] ] ifFalse: [ comment ]! ! !RBClass methodsFor: 'initialization' stamp: 'lr 7/1/2008 10:58'! initialize super initialize. comment := LookupComment! ! !RBClass methodsFor: 'accessing' stamp: 'lr 10/26/2009 22:08'! theNonMetaClass ^ self! ! !RBClass methodsFor: 'variable accessing' stamp: ''! addClassVariable: aString self privateClassVariableNames add: aString asSymbol. model addClassVariable: aString to: self! ! !RBClass methodsFor: 'testing' stamp: ''! directlyDefinesClassVariable: aString ^self classVariableNames includes: aString asSymbol! ! !RBClass methodsFor: 'private' stamp: 'djr 3/31/2010 14:00'! privatePoolDictionaryNames (self isDefined and: [poolDictionaryNames isNil]) ifTrue: [self poolDictionaryNames: (self realClass sharedPools collect: [:each | self realClass environment keyAtValue: each])]. ^poolDictionaryNames! ! !RBClass methodsFor: 'variable accessing' stamp: ''! removeClassVariable: aString self privateClassVariableNames remove: aString asSymbol. model removeClassVariable: aString from: self! ! !RBClass methodsFor: 'accessing' stamp: ''! allClassVariableNames | sprClass | sprClass := self superclass. ^sprClass isNil ifTrue: [self classVariableNames] ifFalse: [sprClass allClassVariableNames , self classVariableNames]! ! !RBClass methodsFor: 'accessing' stamp: 'MartinDias 11/7/2013 18:11'! allPoolDictionaryNames | sprClass | sprClass := self superclass. ^sprClass isNil ifTrue: [self sharedPoolNames] ifFalse: [sprClass allPoolDictionaryNames , self sharedPoolNames]! ! !RBClass methodsFor: 'accessing' stamp: 'bh 11/8/2000 15:22'! category ^category isNil ifTrue: [self isDefined ifTrue: [category := self realClass category] ifFalse: [model environment whichCategoryIncludes: self name]] ifFalse: [category] ! ! !RBClass methodsFor: 'testing' stamp: ''! isMeta ^false! ! !RBClass methodsFor: 'private' stamp: ''! privateClassVariableNames (self isDefined and: [classVariableNames isNil]) ifTrue: [self classVariableNames: self realClass classVarNames]. ^classVariableNames! ! !RBClass methodsFor: 'accessing' stamp: 'MartinDias 11/7/2013 18:11'! sharedPoolNames ^self privatePoolDictionaryNames copy! ! !RBClass methodsFor: 'initialize-release' stamp: 'lr 7/23/2010 07:49'! realName: aSymbol self realClass: (self class environment at: aSymbol)! ! !RBClass methodsFor: 'variable accessing' stamp: ''! addPoolDictionary: aString self privatePoolDictionaryNames add: aString asSymbol. model addPool: aString to: self! ! !RBClass methodsFor: 'variable accessing' stamp: ''! removePoolDictionary: aString self privatePoolDictionaryNames remove: aString asSymbol! ! !RBClass methodsFor: 'accessing' stamp: 'MartinDias 11/7/2013 18:11'! definitionString | definitionStream | definitionStream := WriteStream on: ''. definitionStream nextPutAll: self superclass printString; nextPutAll: ' subclass: #'; nextPutAll: self name; nextPutAll: ' instanceVariableNames: '''. self instanceVariableNames do: [:each | definitionStream nextPutAll: each; nextPut: $ ]. definitionStream nextPutAll: ''' classVariableNames: '''. self classVariableNames do: [:each | definitionStream nextPutAll: each; nextPut: $ ]. definitionStream nextPutAll: ''' poolDictionaries: '''. self sharedPoolNames do: [:each | definitionStream nextPutAll: each; nextPut: $ ]. definitionStream nextPutAll: ''' category: #'''. definitionStream nextPutAll: self category asString. definitionStream nextPut: $'. ^definitionStream contents! ! !RBClass methodsFor: 'accessing' stamp: ''! poolDictionaryNames: aCollectionOfStrings poolDictionaryNames := (aCollectionOfStrings collect: [:each | each asSymbol]) asOrderedCollection! ! !RBClass methodsFor: 'testing' stamp: 'MartinDias 11/7/2013 18:11'! directlyDefinesPoolDictionary: aString ^self sharedPoolNames includes: aString asSymbol! ! !RBClass methodsFor: 'accessing' stamp: 'lr 7/23/2010 08:03'! sharedPools ^ self allPoolDictionaryNames collect: [ :each | Smalltalk globals at: each asSymbol ifAbsent: [ Dictionary new ] ]! ! !RBClass class methodsFor: 'instance creation' stamp: ''! named: aSymbol ^(self new) name: aSymbol; yourself! ! !RBClass class methodsFor: 'class initialization' stamp: 'lr 7/1/2008 10:57'! initialize LookupComment := Object new! ! !RBClass class methodsFor: 'instance creation' stamp: ''! existingNamed: aSymbol ^(self named: aSymbol) realName: aSymbol; yourself! ! !RBClassEnvironment methodsFor: 'testing' stamp: ''! includesClass: aClass ^(aClass isMeta ifTrue: [metaClasses includes: aClass soleInstance name] ifFalse: [classes includes: aClass name]) and: [super includesClass: aClass]! ! !RBClassEnvironment methodsFor: 'accessing-classes' stamp: 'lr 3/20/2011 11:18'! classesDo: aBlock classes do: [ :each | | class | class := self systemDictionary at: each ifAbsent: [ nil ]. (class notNil and: [ environment includesClass: class ]) ifTrue: [ aBlock value: class ] ]. metaClasses do: [ :each | | class | class := self systemDictionary at: each ifAbsent: [ nil ]. (class notNil and: [ environment includesClass: class class ]) ifTrue: [ aBlock value: class class ] ]! ! !RBClassEnvironment methodsFor: 'printing' stamp: 'lr 3/20/2011 11:18'! metaClassSelectorDictionary ^ metaClasses inject: (IdentityDictionary new: metaClasses size) into: [ :answer :class | answer at: class put: (self systemDictionary at: class) class selectors; yourself ]! ! !RBClassEnvironment methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! asSelectorEnvironment ^RBSelectorEnvironment new searchStrings:#(); label:self label; onEnvironment: self environment; classSelectors: self classSelectorDictionary metaClassSelectors: self metaClassSelectorDictionary; yourself.! ! !RBClassEnvironment methodsFor: 'testing' stamp: ''! isEmpty ^classes isEmpty and: [metaClasses isEmpty]! ! !RBClassEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. super storeOn: aStream. aStream nextPutAll: ' classes: (('. classes asArray storeOn: aStream. aStream nextPutAll: ' inject: OrderedCollection new into: [:sum :each | | class | class := Smalltalk at: each ifAbsent: [nil]. class notNil ifTrue: [sum add: class]. sum]) , ('. metaClasses asArray storeOn: aStream. aStream nextPutAll: ' inject: OrderedCollection new into: [:sum :each | | class | class := Smalltalk at: each ifAbsent: [nil]. class notNil ifTrue: [sum add: class class]. sum])))'! ! !RBClassEnvironment methodsFor: 'testing' stamp: 'CamilloBruni 7/7/2013 18:40'! includesCategory: aCategory ^ (super includesCategory: aCategory) and: [ (environment classNamesFor: aCategory) inject: false into: [ :bool :each | bool or: [ | class | class := self systemDictionary at: each ifAbsent: [ nil ]. class notNil and: [ (self includesClass: class) or: [ self includesClass: class class ]]]]]! ! !RBClassEnvironment methodsFor: 'initialization' stamp: 'lr 2/26/2009 13:35'! initialize super initialize. classes := IdentitySet new. metaClasses := IdentitySet new! ! !RBClassEnvironment methodsFor: 'printing' stamp: 'lr 3/20/2011 11:18'! classSelectorDictionary ^ classes inject: (IdentityDictionary new: classes size) into: [ :answer :class | answer at: class put: (self systemDictionary at: class) selectors; yourself ]! ! !RBClassEnvironment methodsFor: 'initialize-release' stamp: 'lr 9/14/2010 13:06'! classes: aCollection aCollection do: [ :each | self addClass: each ]! ! !RBClassEnvironment methodsFor: 'private' stamp: ''! defaultLabel | stream | stream := String new writeStream. classes do: [:each | stream nextPutAll: each; nextPut: $ ]. ^stream contents! ! !RBClassEnvironment methodsFor: 'adding' stamp: 'lr 9/14/2010 13:07'! addClass: aClass aClass isMeta ifTrue: [ metaClasses add: aClass soleInstance name ] ifFalse: [ classes add: aClass name ]! ! !RBClassEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 14:24'! classNames ^ IdentitySet new addAll: classes; addAll: metaClasses; yourself! ! !RBClassEnvironment methodsFor: 'testing' stamp: ''! isClassEnvironment ^true! ! !RBClassEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:24'! postCopy super postCopy. classes := classes copy. metaClasses := metaClasses copy! ! !RBClassEnvironment methodsFor: 'accessing' stamp: ''! problemCount ^self numberClasses! ! !RBClassEnvironment methodsFor: '*manifest-core' stamp: 'SimonAllier 3/27/2013 10:11'! smallLintCritics ^ self allClasses! ! !RBClassEnvironment methodsFor: 'removing' stamp: ''! removeClass: aClass aClass isMeta ifTrue: [metaClasses remove: aClass soleInstance name ifAbsent: []] ifFalse: [classes remove: aClass name ifAbsent: []]! ! !RBClassEnvironment class methodsFor: 'instance creation' stamp: ''! onEnvironment: anEnvironment classes: aCollection ^(self onEnvironment: anEnvironment) classes: aCollection; yourself! ! !RBClassEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:20'! class: aClass ^ self classes: { aClass }! ! !RBClassEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:22'! classes: aCollection ^ self onEnvironment: self default classes: aCollection! ! !RBClassInstVarNotInitializedRule commentStamp: ''! See my #rationale.! !RBClassInstVarNotInitializedRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBClassInstVarNotInitializedRule methodsFor: 'accessing' stamp: 'StephaneDucasse 12/23/2012 14:22'! rationale ^ 'Checks that all classes that have class instance variables also have an initialize method. This makes sure that all class instance variables are initialized properly when the class is filed-into a new image. Having well initialized instance variables also make sure that clients can rely on default values and to not have to spread their code with ifNil statement and cumbersome logic.'! ! !RBClassInstVarNotInitializedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBClassInstVarNotInitializedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Has class instance variables but no initialize method'! ! !RBClassInstVarNotInitializedRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:00'! category ^ 'Potential Bugs'! ! !RBClassInstVarNotInitializedRule methodsFor: 'running' stamp: 'pmm 6/26/2011 13:16'! checkClass: aContext | definesVar class | aContext selectedClass isMeta ifTrue: [ class := aContext selectedClass. definesVar := false. [ definesVar or: [ class isNil or: [ class isMeta not ] ] ] whileFalse: [ definesVar := class instVarNames isEmpty not "TestCase defines Announcers but does not initialize it -> all tests are reported so we exclude it here" and: [ class ~= TestCase class and: [ aContext selectedClass ~= TestCase ] ]. class := class superclass ]. (definesVar and: [ (aContext selectedClass includesSelector: #initialize) not ]) ifTrue: [ result addClass: aContext selectedClass ] ]! ! !RBClassInstVarNotInitializedRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ClassInstVarNotInitializedRule'! ! !RBClassNameInSelectorRule commentStamp: ''! See my #rationale.! !RBClassNameInSelectorRule methodsFor: 'accessing' stamp: 'StephaneDucasse 12/23/2012 15:58'! rationale ^ 'Checks for the class name in a selector. This is redundant since to call the you must already refer to the class name. For example, openHierarchyBrowserFrom: is a redundant name for HierarchyBrowser. Avoiding selector including class name gives a chance to have more polymorphic methods.'! ! !RBClassNameInSelectorRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBClassNameInSelectorRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Redundant class name in selector'! ! !RBClassNameInSelectorRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:01'! category ^ 'Style'! ! !RBClassNameInSelectorRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkMethod: aContext (aContext selectedClass isMeta and: [ (aContext selector indexOfSubCollection: aContext selectedClass soleInstance name startingAt: 1) > 0 ]) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBClassNameInSelectorRule methodsFor: '*Manifest-Core' stamp: 'ah 8/2/2012 13:03'! longDescription ^ 'This smell arises when the class name is found in a selector. This is redundant since to call the you must already refer to the class name. For example, #openHierarchyBrowserFrom: is a redundant name for HierarchyBrowser.'! ! !RBClassNameInSelectorRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ClassNameInSelectorRule'! ! !RBClassNotReferencedRule commentStamp: ''! See my #rationale.! !RBClassNotReferencedRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBClassNotReferencedRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:02'! category ^ 'Design Flaws'! ! !RBClassNotReferencedRule methodsFor: '*Manifest-Core' stamp: 'ah 8/2/2012 13:06'! longDescription ^ 'This smell arises when a class is not referenced either directly or indirectly by a symbol. If a class is not referenced, it can be removed.'! ! !RBClassNotReferencedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check if a class is referenced either directly or indirectly by a symbol. If a class is not referenced, it can be removed.'! ! !RBClassNotReferencedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBClassNotReferencedRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:09'! severity ^ #information! ! !RBClassNotReferencedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Class not referenced'! ! !RBClassNotReferencedRule methodsFor: 'running' stamp: 'lr 3/7/2011 21:46'! checkClass: aContext | assoc | (aContext selectedClass isMeta or: [ aContext selectedClass subclasses notEmpty or: [ aContext includesBehaviorNamed: #TestCase ] ]) ifTrue: [ ^ self ]. assoc := Smalltalk globals associationAt: aContext selectedClass name. ((aContext uses: assoc) or: [ aContext uses: aContext selectedClass name ]) ifFalse: [ result addClass: aContext selectedClass; addClass: aContext selectedClass class ]! ! !RBClassNotReferencedRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ClassNotReferencedRule'! ! !RBClassRefactoring methodsFor: 'initialize-release' stamp: ''! className: aName className := aName! ! !RBClassRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk className: aName ^(self new) model: aRBSmalltalk; className: aName; yourself! ! !RBClassRefactoring class methodsFor: 'instance creation' stamp: ''! className: aName ^self new className: aName! ! !RBClassReference commentStamp: ''! I am a specific variable node used for ClassReferences! !RBClassRegexRefactoring methodsFor: 'private' stamp: 'MartinDias 11/7/2013 18:11'! copyFrom: aSourceClass to: aTargetClass aSourceClass instanceVariableNames do: [ :each | aTargetClass addInstanceVariable: each ]. aSourceClass isMeta ifFalse: [ aSourceClass allClassVariableNames do: [ :each | aTargetClass addClassVariable: each ]. aSourceClass sharedPoolNames do: [ :each | aTargetClass addPoolDictionary: each ] ]. aSourceClass selectors do: [ :each | aTargetClass compile: (aSourceClass sourceCodeFor: each) classified: (aSourceClass protocolsFor: each) ]! ! !RBClassRegexRefactoring methodsFor: 'transforming' stamp: ''! create: aClass name: aSymbol ^ self duplicate: aClass name: aSymbol deep: false! ! !RBClassRegexRefactoring methodsFor: 'initialization' stamp: ''! initialize super initialize. self createClasses! ! !RBClassRegexRefactoring methodsFor: 'actions' stamp: ''! copyClasses mode := #copy:name:! ! !RBClassRegexRefactoring methodsFor: 'transforming' stamp: 'BenjaminVanRyseghem 4/25/2012 18:05'! rename: aClass name: aSymbol ^ RBRenameClassRefactoring model: self model rename: aClass to: aSymbol! ! !RBClassRegexRefactoring methodsFor: 'transforming' stamp: ''! transform | replacement refactoring | self model allClassesDo: [ :class | (class isNil or: [ class isMeta ]) ifFalse: [ replacement := self execute: class name. replacement = class name asString ifFalse: [ refactoring := self perform: mode with: class with: replacement asSymbol. (refactoring notNil and: [ refactoring preconditions check ]) ifTrue: [ refactoring transform ] ] ] ]! ! !RBClassRegexRefactoring methodsFor: 'transforming' stamp: ''! copy: aClass name: aSymbol ^ self duplicate: aClass name: aSymbol deep: true! ! !RBClassRegexRefactoring methodsFor: 'initialization' stamp: ''! rootClass: aClass rootClass := aClass theNonMetaClass! ! !RBClassRegexRefactoring methodsFor: 'private' stamp: ''! duplicate: aClass name: aSymbol deep: aBoolean | superclass superclassName name class | (self model includesClassNamed: aSymbol) ifTrue: [ ^ nil ]. superclass := aClass superclass ifNil: [ self rootClass ]. superclassName := (self model includesClassNamed: superclass name) ifFalse: [ superclass name ] ifTrue: [ (name := self execute: superclass name) = superclass name ifFalse: [ self duplicate: superclass name: name deep: aBoolean ]. name ]. self model defineClass: ('<1s> subclass: #<2s> instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: <3p>' expandMacrosWith: superclassName with: aSymbol with: aClass category asString). aBoolean ifTrue: [ (class := self model classNamed: aSymbol) ifNil: [ ^ self ]. self copyFrom: aClass to: class. self copyFrom: aClass theMetaClass to: class theMetaClass ]. ^ nil! ! !RBClassRegexRefactoring methodsFor: 'accessing' stamp: ''! rootClass ^ rootClass ifNil: [ Object ]! ! !RBClassRegexRefactoring methodsFor: 'actions' stamp: ''! renameClasses mode := #rename:name:! ! !RBClassRegexRefactoring methodsFor: 'actions' stamp: ''! createClasses mode := #create:name:! ! !RBClassTest methodsFor: 'method tests' stamp: 'lr 10/26/2009 22:09'! testHierarchy | meta | meta := objectClass theMetaClass. self assert: (objectClass withAllSubclasses includes: meta). self assert: (meta withAllSuperclasses includes: objectClass)! ! !RBClassTest methodsFor: 'method tests' stamp: ''! testDefinesInstanceVariable self deny: (objectClass definesInstanceVariable: 'instanceVariable1'). self assert: (newClass definesInstanceVariable: 'instanceVariable1'). self deny: (messageNodeClass definesInstanceVariable: 'instanceVariable1'). self assert: (messageNodeClass definesInstanceVariable: 'parent'). self assert: (messageNodeClass definesInstanceVariable: 'selector')! ! !RBClassTest methodsFor: 'method tests' stamp: ''! testDefinesClassVariable self deny: (objectClass definesClassVariable: #ClassVariable1). self assert: (objectClass definesClassVariable: self objectClassVariable). self assert: (newClass definesClassVariable: #ClassVariable1). self deny: (messageNodeClass definesClassVariable: #ClassVariable1). self assert: (messageNodeClass definesClassVariable: self objectClassVariable)! ! !RBClassTest methodsFor: 'tests' stamp: 'CamilloBruni 1/28/2013 17:29'! testObjectIsNotAbstract self deny: objectClass isAbstract. self deny: objectClass theMetaClass isAbstract.! ! !RBClassTest methodsFor: 'method tests' stamp: ''! testDefinesMethod self assert: (objectClass definesMethod: #printString). self assert: (newClass definesMethod: #printString). self assert: (messageNodeClass definesMethod: #printString)! ! !RBClassTest methodsFor: 'method tests' stamp: 'bh 4/3/2000 22:22'! testDefinesPoolDictionary self deny: (objectClass definesPoolDictionary: #OpcodePool). self assert: (newClass definesPoolDictionary: #TextConstants). self deny: (messageNodeClass definesPoolDictionary: #OpcodePool). self assert: ((RBNamespace new classNamed: #Text) definesPoolDictionary: #TextConstants)! ! !RBClassTest methodsFor: 'set up' stamp: 'bh 11/8/2000 14:12'! setUp | st | super setUp. st := RBNamespace new. objectClass := st classNamed: #Object. messageNodeClass := st classNamed: #RBMessageNode. st defineClass: 'Object subclass: #SomeClassName instanceVariableNames: ''instanceVariable1 instanceVariable2'' classVariableNames: ''ClassVariable1'' poolDictionaries: ''TextConstants'' category: #''Refactory-Testing'''. newClass := st classNamed: #SomeClassName! ! !RBClassToRename methodsFor: 'performing' stamp: ''! method2 ^self method1! ! !RBClassToRename methodsFor: 'performing' stamp: ''! method1 ^self method2! ! !RBClassVariableCapitalizationRule commentStamp: ''! This smell arises when class or pool variable names do not start with an uppercase letter, which is a standard style in Smalltalk. In fact a lowercase character is used to represent variables with a local scope such as instance variables, temporary variables, method and block arguments. Uppercase is used to represent the case where the scope of a variable is either global (class name and global variables such as Transcript) or shared among different classes (class variables or pool variables).! !RBClassVariableCapitalizationRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !RBClassVariableCapitalizationRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:02'! category ^ 'Style'! ! !RBClassVariableCapitalizationRule methodsFor: '*Manifest-Core' stamp: 'ah 8/6/2012 11:40'! longDescription ^ 'This smell arises when class or pool variable names do not start with an uppercase letter, which is a standart style in Smalltalk'! ! !RBClassVariableCapitalizationRule methodsFor: 'accessing' stamp: 'lr 7/3/2009 20:34'! rationale ^ 'Class and pool variable names should start with an uppercase letter.'! ! !RBClassVariableCapitalizationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBClassVariableCapitalizationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Class variable capitalization'! ! !RBClassVariableCapitalizationRule methodsFor: 'running' stamp: 'MartinDias 11/7/2013 18:11'! checkClass: aContext aContext selectedClass isMeta ifTrue: [ ^ self ]. aContext selectedClass classVarNames do: [ :each | each first isUppercase ifFalse: [ result addClass: aContext selectedClass classVariable: each ] ]. aContext selectedClass sharedPoolNames do: [ :each | each first isUppercase ifFalse: [ result addClass: aContext selectedClass classVariable: each ] ]! ! !RBClassVariableCapitalizationRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ClassVariableCapitalizationRule'! ! !RBCodeCruftLeftInMethodsRule commentStamp: ''! See rationale! !RBCodeCruftLeftInMethodsRule methodsFor: 'initialization' stamp: 'CAMILLETERUEL 3/29/2013 12:00'! initialize super initialize. #('`@object clearHaltOnce' '`@object doOnlyOnce: `@object1' '`@object halt' '`@object halt: `@object1 onCount: `@object2' '`@object haltOnCount: `@object1' '`@object haltOnce' '`@object hatIf: `@object1' '`@object inspectOnCount: `@object1' '`@object inspectOnce' '`@object inspectUntilCount: `@object1' '`@object rearmOneShot' '`@object setHaltOnce' '`@object flag: `@object1' '`@object isThisEverCalled' '`@object isThisEverCalled: `@object1' '`@object logEntry' '`@object logExecution' '`@object logExit' '`@object needsWork' 'Transcript `@message: `@object1') do: [ :matchingString | self rewriteRule replace: matchingString with: '' ]! ! !RBCodeCruftLeftInMethodsRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:49'! category ^ 'Bugs'! ! !RBCodeCruftLeftInMethodsRule methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 9/13/2013 21:33'! longDescription ^ 'This smell arises when a breakpoints, logging statements, etc is found in a method. This debugging code should not be left in production code. Here are messages currently checked: clearHaltOnce, doOnlyOnce: , halt, halt: onCount: object2, haltOnCount: , haltOnce, hatIf: , inspectOnCount: , inspectOnce, inspectUntilCount: , rearmOneShot, setHaltOnce, flag: , isThisEverCalled, isThisEverCalled: , logEntry, logExecution, logExit, needsWork and Transcript message:'! ! !RBCodeCruftLeftInMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Breakpoints, logging statements, etc. should not be left in production code.'! ! !RBCodeCruftLeftInMethodsRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBCodeCruftLeftInMethodsRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:11'! severity ^ #error! ! !RBCodeCruftLeftInMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Debugging code left in methods'! ! !RBCodeCruftLeftInMethodsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'CodeCruftLeftInMethodsRule'! ! !RBCollectSelectNotUsedRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:20'! initialize super initialize. self matcher matches: '`{:node | node isMessage and: [(#(#select: #collect: #reject:) includes: node selector) and: [node isUsed not]]}' do: [ :node :answer | node ]! ! !RBCollectSelectNotUsedRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:34'! rationale ^ 'Checks for senders of typical collection enumeration methods that return an unused result.'! ! !RBCollectSelectNotUsedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBCollectSelectNotUsedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Doesn''t use the result of a collect:/select:'! ! !RBCollectSelectNotUsedRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:24'! category ^ 'Optimization'! ! !RBCollectSelectNotUsedRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'CollectSelectNotUsedRule'! ! !RBCollectionCopyEmptyRule commentStamp: ''! See my #rationale.! !RBCollectionCopyEmptyRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBCollectionCopyEmptyRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks that all subclasses of the Collection classes that add an instance variable also redefine the copyEmpty method. This method is used when the collection grows. It copies over the necessary instance variables to the new larger collection.'! ! !RBCollectionCopyEmptyRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBCollectionCopyEmptyRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Subclass of collection that has instance variable but doesn''t define copyEmpty'! ! !RBCollectionCopyEmptyRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:04'! category ^ 'Potential Bugs'! ! !RBCollectionCopyEmptyRule methodsFor: 'running' stamp: 'CamilloBruni 9/12/2013 11:23'! checkClass: aContext ((aContext selectedClass inheritsFrom: Collection) and: [ aContext selectedClass isVariable and: [ (aContext selectedClass includesSelector: #copyEmpty) not and: [ aContext selectedClass instVarNames isEmpty not ]]]) ifTrue: [ result addClass: aContext selectedClass ]! ! !RBCollectionCopyEmptyRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'CollectionCopyEmptyRule'! ! !RBCollectionMessagesToExternalObjectRule methodsFor: 'initialization' stamp: 'lr 7/23/2010 08:03'! initialize | queries | super initialize. queries := #( add: remove: addAll: removeAll: ) collect: [ :each | '(`@Object `@message: `@args) <1s> `@Arg' expandMacrosWith: each ]. self matcher matchesAnyOf: queries do: [ :node :answer | answer isNil ifTrue: [ ((node receiver selector copyFrom: 1 to: (node receiver selector size min: 2)) ~= 'as' and: [ | receiver | receiver := node receiver receiver. receiver isVariable not or: [ ((#('self' 'super') includes: receiver name) or: [ Smalltalk globals includesKey: receiver name asSymbol ]) not ] ]) ifTrue: [ node ] ifFalse: [ nil ] ] ifFalse: [ answer ] ]! ! !RBCollectionMessagesToExternalObjectRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for methods that appear to be modifying a collection that is owned by another object. Such modifications can cause problems especially if other variables are modified when the collection is modified. For example, CompositePart must set the container''s of all its parts when adding a new component.'! ! !RBCollectionMessagesToExternalObjectRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBCollectionMessagesToExternalObjectRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Sends add:/remove: to external collection'! ! !RBCollectionMessagesToExternalObjectRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:21'! category ^'Coding Idiom Violation'! ! !RBCollectionMessagesToExternalObjectRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'CollectionMessagesToExternalObjectRule'! ! !RBCollectionProtocolRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:23'! initialize super initialize. self matcher matchesAnyOf: #( '`@collection do: [:`each | | `@temps | `@.Statements1. `@object add: `@arg. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifTrue: [| `@blockTemps | `@.BlockStatements1. `@object add: `each. `@.BlockStatements2]. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifFalse: [| `@blockTemps | `@.BlockStatements1. `@object add: `each. `@.BlockStatements2]. `@.Statements2]' ) do: [ :node :answer | node ]! ! !RBCollectionProtocolRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for people using the do: method instead of using the collect: or select: methods. This often occurs with new people writing code. The collect: and select: variants express the source code''s intentions better.'! ! !RBCollectionProtocolRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBCollectionProtocolRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses do: instead of collect: or select:''s'! ! !RBCollectionProtocolRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:22'! category ^'Coding Idiom Violation'! ! !RBCollectionProtocolRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'CollectionProtocolRule'! ! !RBCommentChange methodsFor: 'accessing' stamp: 'lr 7/1/2008 10:41'! comment: aString comment := aString! ! !RBCommentChange methodsFor: 'printing' stamp: 'StephaneDucasse 9/13/2013 21:45'! printOn: aStream aStream nextPutAll: self displayClassName; nextPutAll: ' classComment: '; print: (self comment copyReplaceAll: '!!' with: '!!!!'); nextPutAll: ' stamp: '; print: (self changeStamp); nextPutAll: '!!'! ! !RBCommentChange methodsFor: 'accessing' stamp: 'lr 7/1/2008 10:44'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !RBCommentChange methodsFor: 'private' stamp: 'StephaneDucasse 9/13/2013 21:45'! primitiveExecute self changeClass classComment: comment stamp: self changeStamp. SystemAnnouncer uniqueInstance classCommented: self changeClass! ! !RBCommentChange methodsFor: 'printing' stamp: 'lr 7/1/2008 10:48'! changeString ^ 'Comment ' , self displayClassName! ! !RBCommentChange methodsFor: 'accessing' stamp: 'lr 7/1/2008 10:41'! comment ^ comment! ! !RBCommentChange methodsFor: 'converting' stamp: 'lr 9/6/2010 10:48'! asUndoOperation ^ self copy comment: self changeClass organization classComment; yourself! ! !RBCommentChange class methodsFor: 'instance creation' stamp: 'lr 7/1/2008 10:50'! comment: aString in: aClass ^ self new changeClass: aClass; comment: aString; yourself! ! !RBCompositeLintRule commentStamp: ''! A RBCompositeLintRule is a composite rule holding rules.! !RBCompositeLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:09'! changes ^ rules gather: [ :each | each changes ]! ! !RBCompositeLintRule methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 11/21/2012 18:25'! leaves ^ rules gather: [ :rule | rule leaves ] ! ! !RBCompositeLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:12'! isEmpty ^ rules allSatisfy: [ :each | each isEmpty ]! ! !RBCompositeLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:11'! isComposite ^ true! ! !RBCompositeLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:11'! hasConflicts ^ rules anySatisfy: [ :each | each hasConflicts ]! ! !RBCompositeLintRule methodsFor: '*Manifest-CriticBrowser' stamp: 'StephaneDucasse 11/21/2012 18:25'! removeRule: aRule (rules anySatisfy: [ :rule | rule name = aRule name] ) ifTrue: [rules := rules reject: [ :rule | rule name = aRule name]] ifFalse: [rules do: [ :rule | rule isComposite ifTrue: [rule removeRule: aRule]]] ! ! !RBCompositeLintRule methodsFor: 'running' stamp: 'lr 2/23/2009 21:10'! checkMethod: aContext rules do: [ :each | each checkMethod: aContext ]! ! !RBCompositeLintRule methodsFor: 'running' stamp: 'lr 2/23/2009 21:10'! checkClass: aContext rules do: [ :each | each checkClass: aContext ]! ! !RBCompositeLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:33'! name: aString name := aString! ! !RBCompositeLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:11'! problemCount ^ rules inject: 0 into: [ :count :each | count + each problemCount ]! ! !RBCompositeLintRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 21:11'! resetResult rules do: [ :each | each resetResult ]! ! !RBCompositeLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:32'! rules: aCollection rules := aCollection! ! !RBCompositeLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:11'! rules ^ rules! ! !RBCompositeLintRule methodsFor: '*Manifest-CriticBrowser' stamp: 'StephaneDucasse 3/21/2013 09:46'! sort: aBlock rules first isComposite ifTrue: [ rules do: [ :rule | rule sort: aBlock ]] ifFalse: [ self rules: (rules sort: aBlock) ]! ! !RBCompositeLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:32'! name ^ name! ! !RBCompositeLintRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 11:08'! rulesClassifiedFor: aRuleClass | groups rules | groups := Dictionary new. (self rulesFor: aRuleClass) do: [ :each | (groups at: each category ifAbsentPut: [ OrderedCollection new ]) addLast: each ]. rules := SortedCollection sortBlock: [ :a :b | a name <= b name ]. groups keysAndValuesDo: [ :group :elements | rules addLast: (RBCompositeLintRule rules: elements asArray name: group) ]. ^ rules asArray! ! !RBCompositeLintRule class methodsFor: 'instance creation' stamp: 'lr 2/23/2009 21:55'! rules: aCollection ^ self new rules: aCollection; yourself! ! !RBCompositeLintRule class methodsFor: 'accessing' stamp: 'lr 2/23/2009 22:48'! transformations ^ self rules: (self rulesGroupedFor: RBTransformationRule) name: 'Transformations'! ! !RBCompositeLintRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'CompositeLintRule'! ! !RBCompositeLintRule class methodsFor: '*Manifest-Core' stamp: 'MarcusDenker 10/3/2013 22:26'! removedRules ^ {(RBCompositeLintRule new name: 'Spelling'). RBMissingTranslationsInMenusRule new. RBGuardingClauseRule new. RBAssignmentWithoutEffectRule new. RBUtilityMethodsRule new. RBMethodHasNoTimeStampRule new. } ! ! !RBCompositeLintRule class methodsFor: 'instance creation' stamp: 'lr 2/23/2009 21:56'! rules: aCollection name: aString ^ self new rules: aCollection; name: aString; yourself! ! !RBCompositeLintRule class methodsFor: 'instance creation' stamp: 'lr 2/23/2009 22:44'! rulesGroupedFor: aRuleClass | groups rules | groups := Dictionary new. (self rulesFor: aRuleClass) do: [ :each | (groups at: each group ifAbsentPut: [ OrderedCollection new ]) addLast: each ]. rules := SortedCollection sortBlock: [ :a :b | a name <= b name ]. groups keysAndValuesDo: [ :group :elements | rules addLast: (RBCompositeLintRule rules: elements asArray name: group) ]. ^ rules asArray! ! !RBCompositeLintRule class methodsFor: 'accessing' stamp: 'lr 2/23/2009 22:50'! allRules ^ self rules: (Array with: self lintChecks with: self transformations) name: 'All checks'! ! !RBCompositeLintRule class methodsFor: 'accessing' stamp: 'lr 2/23/2009 22:48'! lintChecks ^ self rules: (self rulesGroupedFor: RBBasicLintRule) name: 'Lint checks'! ! !RBCompositeLintRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 13:51'! allGoodRules | rules | rules := self rules: (self rulesClassifiedFor: RBLintRule) name: 'All Rules'. self removedRules do: [:r | rules removeRule: r]. rules removeRule: (RBCompositeLintRule new name: 'Spelling'). rules removeRule: RBMissingTranslationsInMenusRule new. rules removeRule: RBGuardingClauseRule new. ^ rules ! ! !RBCompositeLintRule class methodsFor: 'instance creation' stamp: 'lr 2/24/2009 17:11'! rulesFor: aRuleClass | rules | rules := SortedCollection sortBlock: [ :a :b | a name <= b name ]. aRuleClass withAllSubclassesDo: [ :each | each isVisible ifTrue: [ rules add: each new ] ]. ^ rules asArray! ! !RBCompositeLintRuleTest methodsFor: 'initialize-release' stamp: ''! rules: aCollection rules := aCollection! ! !RBCompositeLintRuleTest methodsFor: 'accessing' stamp: ''! problemCount ^rules inject: 0 into: [:count :each | count + each problemCount]! ! !RBCompositeLintRuleTest methodsFor: 'testing' stamp: ''! isEmpty ^(rules detect: [:each | each isEmpty not] ifNone: [nil]) isNil! ! !RBCompositeLintRuleTest methodsFor: 'initialize-release' stamp: ''! resetResult rules do: [:each | each resetResult]! ! !RBCompositeLintRuleTest methodsFor: 'accessing' stamp: ''! rules ^rules! ! !RBCompositeLintRuleTest methodsFor: 'testing' stamp: ''! isComposite ^true! ! !RBCompositeLintRuleTest methodsFor: 'accessing' stamp: ''! failedRules ^rules inject: OrderedCollection new into: [:oc :each | oc addAll: each failedRules; yourself]! ! !RBCompositeLintRuleTest methodsFor: 'testing' stamp: ''! hasConflicts ^(rules detect: [:each | each hasConflicts] ifNone: [nil]) notNil! ! !RBCompositeLintRuleTest methodsFor: 'private' stamp: ''! viewResults rules do: [:each | each viewResults]! ! !RBCompositeLintRuleTest methodsFor: 'accessing' stamp: ''! checkMethod: aSmalllintContext rules do: [:each | each checkMethod: aSmalllintContext. Processor yield]! ! !RBCompositeLintRuleTest methodsFor: 'accessing' stamp: ''! checkClass: aSmalllintContext rules do: [:each | each checkClass: aSmalllintContext. Processor yield]! ! !RBCompositeLintRuleTest class methodsFor: 'instance creation' stamp: ''! rules: aCollection name: aString ^(self new) rules: aCollection; name: aString; yourself! ! !RBCompositeLintRuleTest class methodsFor: 'instance creation' stamp: ''! rules: aCollection ^self new rules: aCollection! ! !RBCompositeLintRuleTest class methodsFor: 'all checks' stamp: 'lr 2/26/2009 14:51'! transformations ^ self ruleFor: RBTransformationRuleTest protocol: 'transformations'! ! !RBCompositeLintRuleTest class methodsFor: 'instance creation' stamp: 'lr 9/8/2011 20:25'! ruleFor: aClass protocol: aProtocol ^self rules: (((RBBrowserEnvironment new selectorsFor: aProtocol asSymbol in: aClass class) collect: [:selector | aClass perform: selector]) asSortedCollection: [:a :b | a name < b name]) name: ((aProtocol asString copy) at: 1 put: aProtocol first asUppercase; yourself)! ! !RBCompositeLintRuleTest class methodsFor: 'instance creation' stamp: ''! allRules ^self ruleFor: self protocol: 'all checks'! ! !RBCompositeLintRuleTest class methodsFor: 'all checks' stamp: 'lr 2/26/2009 14:51'! lintChecks ^ self rules: (RBBasicLintRuleTest protocols collect: [ :each | self ruleFor: RBBasicLintRuleTest protocol: each ]) name: 'Lint checks'! ! !RBCompositeRefactoryChange methodsFor: 'private-inspector accessing' stamp: 'lr 9/6/2010 17:28'! changes ^ changes! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! addInstanceVariable: variableName to: aClass ^ self addChange: (RBAddInstanceVariableChange add: variableName to: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 11:30'! changeForMetaclass: aClassName selector: aSelector changes reverseDo: [ :each | | change | change := each changeForMetaclass: aClassName selector: aSelector. change notNil ifTrue: [ ^ change ] ]. ^ nil! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! compile: source in: class ^ self addChange: (RBAddMethodChange compile: source in: class)! ! !RBCompositeRefactoryChange methodsFor: 'private' stamp: 'lr 5/9/2010 11:31'! executeNotifying: aBlock | undos undo | undos := changes collect: [ :each | each executeNotifying: aBlock ]. undo := self copy. undo changes: undos reversed. ^ undo! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! removeInstanceVariable: variableName from: aClass ^ self addChange: (RBRemoveInstanceVariableChange remove: variableName from: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! addClassVariable: variableName to: aClass ^ self addChange: (RBAddClassVariableChange add: variableName to: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'initialization' stamp: ''! initialize super initialize. changes := OrderedCollection new! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! defineClass: aString ^ self addChange: (RBAddClassChange definition: aString)! ! !RBCompositeRefactoryChange methodsFor: 'printing' stamp: 'lr 9/6/2010 17:28'! printOn: aStream name isNil ifTrue: [ ^ super printOn: aStream ]. aStream nextPutAll: name! ! !RBCompositeRefactoryChange methodsFor: 'private-inspector accessing' stamp: ''! changes: aCollection changes := aCollection! ! !RBCompositeRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:27'! addChange: aRefactoryChange changes add: aRefactoryChange. ^ aRefactoryChange! ! !RBCompositeRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 13:56'! renameChangesForClass: oldClassName to: newClassName ^ self copy changes: (self changes collect: [ :each | each renameChangesForClass: oldClassName to: newClassName ]); yourself! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! removeClass: aClass ^ self addChange: (RBRemoveClassChange removeClassName: aClass name)! ! !RBCompositeRefactoryChange methodsFor: 'comparing' stamp: 'lr 9/6/2010 17:31'! hash ^ self class hash bitXor: self changes size hash! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! comment: aString in: aClass ^ self addChange: (RBCommentChange comment: aString in: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! removeMethod: aSelector from: aClass ^ self addChange: (RBRemoveMethodChange remove: aSelector from: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 11:29'! changeForClass: aClassName selector: aSelector changes reverseDo: [ :each | | change | change := each changeForClass: aClassName selector: aSelector. change notNil ifTrue: [ ^ change ] ]. ^ nil! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! removeClassNamed: aSymbol ^ self addChange: (RBRemoveClassChange removeClassName: aSymbol)! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! removePool: aPoolVariable from: aClass ^ self addChange: (RBRemovePoolVariableChange remove: aPoolVariable from: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:27'! changesSize ^ changes inject: 0 into: [ :sum :each | sum + each changesSize ]! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! addPool: aPoolVariable to: aClass ^ self addChange: (RBAddPoolVariableChange add: aPoolVariable to: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! renameInstanceVariable: oldName to: newName in: aClass ^ self addChange: (RBRenameInstanceVariableChange rename: oldName to: newName in: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! renameClass: class to: newName ^ self addChange: (RBRenameClassChange rename: class name to: newName)! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! renameClassVariable: oldName to: newName in: aClass ^ self addChange: (RBRenameClassVariableChange rename: oldName to: newName in: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'comparing' stamp: 'lr 9/6/2010 17:27'! = aRefactoryBuilder self class = aRefactoryBuilder class ifFalse: [ ^ false ]. changes size = aRefactoryBuilder changes size ifFalse: [ ^ false ]. changes with: aRefactoryBuilder changes do: [ :first :second | first = second ifFalse: [ ^ false ] ]. ^ true! ! !RBCompositeRefactoryChange methodsFor: 'copying' stamp: 'lr 9/6/2010 17:27'! postCopy super postCopy. changes := changes collect: [ :each | each copy ]! ! !RBCompositeRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:27'! problemCount ^ self changesSize! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! compile: source in: class classified: aProtocol ^ self addChange: (RBAddMethodChange compile: source in: class classified: aProtocol)! ! !RBCompositeRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:29'! removeChange: aChange ^ changes remove: aChange ifAbsent: [ nil ]! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! removeClassVariable: variableName from: aClass ^ self addChange: (RBRemoveClassVariableChange remove: variableName from: aClass)! ! !RBCompositeRefactoryChange methodsFor: '*NautilusRefactoring' stamp: ''! whatToDisplayIn: aBrowser ^ self changes gather: [:each | each whatToDisplayIn: aBrowser ]! ! !RBCompositeRefactoryChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:43'! named: aString ^ self new name: aString; yourself! ! !RBCondition methodsFor: 'checking' stamp: ''! check ^block value! ! !RBCondition methodsFor: 'initialize-release' stamp: ''! errorBlock: anObject errorBlock := anObject! ! !RBCondition methodsFor: 'initialize-release' stamp: 'lr 11/19/2009 11:45'! type: aSymbol block: aBlock errorString: aString type := aSymbol. block := aBlock. self errorMacro: aString! ! !RBCondition methodsFor: 'accessing' stamp: ''! errorBlockFor: aBoolean ^errorBlock! ! !RBCondition methodsFor: 'initialize-release' stamp: ''! withBlock: aBlock block := aBlock. type := #(#generic)! ! !RBCondition methodsFor: 'printing' stamp: 'bh 4/10/2001 16:51'! printOn: aStream aStream nextPutAll: type asString! ! !RBCondition class methodsFor: 'utilities' stamp: ''! checkInstanceVariableName: aName in: aClass | string | aName isString ifFalse: [^false]. string := aName asString. string isEmpty ifTrue: [^false]. (self reservedNames includes: string) ifTrue: [^false]. string first isUppercase ifTrue: [^false]. ^RBScanner isVariable: string! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! isMetaclass: anObject ^self new type: (Array with: #IsMetaclass with: anObject) block: [anObject isMeta] errorString: anObject printString , ' is <1?:not >a metaclass'! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! isSymbol: aString ^self new type: (Array with: #isSymbol with: aString) block: [aString isSymbol] errorString: aString , ' is <1?:not >a symbol'! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! withBlock: aBlock errorString: aString ^self new type: #unknown block: aBlock errorString: aString! ! !RBCondition class methodsFor: 'instance creation' stamp: 'lr 12/7/2011 21:48'! isSubclass: subclass of: superClass ^self new type: (Array with: #subclass with: superClass with: subclass) block: [subclass includesClass: superClass] errorString: subclass printString , ' is <1?:not >a subclass of ' , superClass printString! ! !RBCondition class methodsFor: 'instance creation' stamp: 'GiselaDecuzzi 4/22/2013 17:39'! canUnderstand: aSelector in: aClass ^self new type: (Array with: #understandsSelector with: aClass with: aSelector) block: [aClass canUnderstand: aSelector] errorString: aClass printString , ' <1?:does not >understand<1?s:> ' , aSelector printString! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! isValidInstanceVariableName: aString for: aClass ^self new type: (Array with: #validInstVarName with: aString with: aClass) block: [self checkInstanceVariableName: aString in: aClass] errorString: aString , ' is <1?:not >a valid instance variable name'! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! definesTempVar: aString in: aClass ignoreClass: subclass | condition | condition := self new. condition type: (Array with: #definesTempVarIgnoring with: aClass with: aString with: subclass) block: [| method | method := self methodDefiningTemporary: aString in: aClass ignore: [:class :aSelector | class includesClass: subclass]. method notNil ifTrue: [condition errorMacro: method printString , ' defines variable ' , aString]. method notNil] errorString: aClass printString , ' <1?:does not >define<1?s:> temporary variable ' , aString. ^condition! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! isEmptyClass: anObject ^self new type: (Array with: #IsEmptyClass with: anObject) block: [anObject classVariableNames isEmpty and: [anObject instanceVariableNames isEmpty and: [anObject selectors isEmpty]]] errorString: anObject printString , ' is <1?:not > empty'! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! subclassesOf: aClass referToSelector: aSelector ^self new type: (Array with: #subclassReferences with: aClass with: aSelector) block: [(aClass subclasses detect: [:each | (each selectors detect: [:sel | | tree | tree := each parseTreeFor: sel. tree notNil and: [tree superMessages includes: aSelector]] ifNone: [nil]) notNil] ifNone: [nil]) notNil] errorString: '<1?:no:a> subclass of ' , aClass printString , ' refers to ' , aSelector printString! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! referencesInstanceVariable: aString in: aClass ^self new type: (Array with: #referencesInstVar with: aClass with: aString) block: [(aClass whichSelectorsReferToInstanceVariable: aString) isEmpty not] errorString: aClass printString , ' <1?:does not >reference<1?s:> instance variable ' , aString! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! isGlobal: aString in: aRBSmalltalk ^self new type: (Array with: #isGlobal with: aString) block: [aRBSmalltalk includesGlobal: aString asSymbol] errorString: aString , ' is <1?:not >a class or global variable'! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! isValidClassName: aString ^self new type: (Array with: #validClassName with: aString) block: [self validClassName: aString] errorString: aString , ' is <1?:not >a valid class name'! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! hierarchyOf: aClass canUnderstand: aSelector ^self new type: (Array with: #hierarchyUnderstandsSelector with: aClass with: aSelector) block: [aClass hierarchyDefinesMethod: aSelector] errorString: aClass printString , ' <1?or a subclass:and all subclasses do not> understand<1?s:> ' , aSelector printString! ! !RBCondition class methodsFor: 'utilities' stamp: 'lr 11/2/2009 00:14'! methodDefiningTemporary: aString in: aClass ignore: aBlock | searcher method | searcher := RBParseTreeSearcher new. method := nil. "Shut-up the warning" searcher matches: aString do: [:aNode :answer | ^method]. aClass withAllSubclasses do: [:class | class selectors do: [:each | (aBlock value: class value: each) ifFalse: [| parseTree | method := class methodFor: each. parseTree := class parseTreeFor: each. parseTree notNil ifTrue: [searcher executeTree: parseTree]]]]. ^nil! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! empty "Returns an empty condition" ^self new type: (Array with: #empty) block: [true] errorString: 'Empty'! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! isValidMethodName: aString for: aClass ^self new type: (Array with: #validMethodName with: aString with: aClass) block: [self checkMethodName: aString in: aClass] errorString: aString printString , ' is <1?:not >a valid method name'! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! hierarchyOf: aClass referencesInstanceVariable: aString ^self new type: (Array with: #hierarchyReferencesInstVar with: aClass with: aString) block: [(aClass withAllSubclasses detect: [:each | (each whichSelectorsReferToInstanceVariable: aString) isEmpty not] ifNone: [nil]) notNil] errorString: aClass printString , ' or subclass <1?:does not >reference<1?s:> instance variable ' , aString! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! isAbstractClass: aClass ^self new type: (Array with: #IsAbstractClass with: aClass) block: [aClass isAbstract] errorString: aClass printString , ' is <1?:not >an abstract class'! ! !RBCondition class methodsFor: 'utilities' stamp: ''! checkMethodName: aName in: aClass ^aName isString and: [RBScanner isSelector: aName]! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! isImmediateSubclass: subclass of: superClass ^self new type: (Array with: #immediateSubclass with: superClass with: subclass) block: [subclass superclass = superClass] errorString: subclass printString , ' is <1?:not >an immediate subclass of ' , superClass printString! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! hierarchyOf: aClass definesVariable: aString ^self new type: (Array with: #hierarchyDefinesInstVar with: aClass with: aString) block: [aClass hierarchyDefinesVariable: aString] errorString: aClass printString , ' or one of its subclasses <1?:does not >define<1?s:> variable ' , aString! ! !RBCondition class methodsFor: 'utilities' stamp: ''! reservedNames ^#('self' 'true' 'false' 'nil' 'thisContext' 'super')! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! isClass: anObject ^self new type: (Array with: #IsClass with: anObject) block: [anObject isBehavior] errorString: anObject printString , ' is <1?:not >a behavior'! ! !RBCondition class methodsFor: 'utilities' stamp: ''! validClassName: aString "Class names and class variable names have the same restrictions" ^self checkClassVarName: aString in: self! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! directlyDefinesInstanceVariable: aString in: aClass ^self new type: (Array with: #directlyDefinesInstanceVariable with: aClass with: aString) block: [aClass directlyDefinesInstanceVariable: aString] errorString: aClass printString , ' <1?:does not >directly define<1?s:> instance variable ' , aString! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! isValidClassVarName: aString for: aClass ^self new type: (Array with: #validClassVarName with: aString with: aClass) block: [self checkClassVarName: aString in: aClass] errorString: aString , ' is <1?:not >a valid class variable name'! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! withBlock: aBlock ^self new withBlock: aBlock! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! definesSelector: aSelector in: aClass ^self new type: (Array with: #definesSelector with: aClass with: aSelector) block: [aClass directlyDefinesMethod: aSelector] errorString: aClass printString , ' <1?:does not >define<1?s:> ' , aSelector printString! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! definesTemporaryVariable: aString in: aClass | condition | condition := self new. condition type: (Array with: #definesTempVar with: aClass with: aString) block: [| method | method := self methodDefiningTemporary: aString in: aClass ignore: [:class :selector | false]. method notNil ifTrue: [condition errorMacro: method printString , ' defines variable ' , aString]. method notNil] errorString: aClass printString , ' <1?:does not >define<1?s:> temporary variable ' , aString. ^condition! ! !RBCondition class methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/23/2013 15:43'! hasInstanceVariable: aClass ^self new type: (Array with: aClass) block: [aClass allInstVarNames isEmpty not] errorString: aClass printString , ' <1?:does not >define any instance variable ' , aClass asString ! ! !RBCondition class methodsFor: 'utilities' stamp: ''! checkClassVarName: aName in: aClass | string | aName isString ifFalse: [^false]. string := aName asString. (self reservedNames includes: string) ifTrue: [^false]. string isEmpty ifTrue: [^false]. string first isUppercase ifFalse: [^false]. ^RBScanner isVariable: string! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! definesClassVariable: aString in: aClass ^self new type: (Array with: #definesClassVar with: aClass with: aString) block: [aClass definesClassVariable: aString] errorString: aClass printString , ' <1?:does not >define<1?s:> class variable ' , aString! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! definesInstanceVariable: aString in: aClass ^self new type: (Array with: #definesInstVar with: aClass with: aString) block: [aClass definesInstanceVariable: aString] errorString: aClass printString , ' <1?:does not >define<1?s:> instance variable ' , aString! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! directlyDefinesClassVariable: aString in: aClass ^self new type: (Array with: #directlyDefinesClassVar with: aClass with: aString) block: [aClass directlyDefinesClassVariable: aString] errorString: aClass printString , ' <1?:does not >directly define<1?s:> class variable ' , aString! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! hasSubclasses: aClass ^self new type: (Array with: #hasSubclasses with: aClass) block: [aClass subclasses isEmpty not] errorString: aClass printString , ' has <1?:no >subclasses'! ! !RBCondition class methodsFor: 'instance creation' stamp: ''! hasSuperclass: aClass ^self new type: (Array with: #hasSuperclass with: aClass) block: [aClass superclass isNil not] errorString: aClass printString , ' has <1?a:no> superclass'! ! !RBConfigurableFormatter commentStamp: ''! RBConfigurableFormatter formats the Refactoring Browser's parse trees. It has many more formatting options than the default formatter used by the RB. To change the RB to use this formatter, execute "RBProgramNode formatterClass: RBConfigurableFormatter". For some refactorings the RB must reformat the code after the change, so it is good to have a formatter configured to your tastes. Instance Variables: codeStream the stream we are writing our output to indent how many times are we indenting a new line -- indents are normally tabs but could be any whitespace string lineStart the position of the character that started the current line. This is used for calculating the line length. lookaheadCode sometimes we need to lookahead while formatting, this dictionary contains the nodes that have already been formatted by lookahead originalSource the original source before we started formatting. This is used to extract the comments from the original source. ! !RBConfigurableFormatter methodsFor: 'initialize-release' stamp: ''! indent: anInteger indent := anInteger! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:56'! visitCascadeNode: aCascadeNode self visitNode: aCascadeNode receiver. self indentAround: [NewLineBeforeFirstCascade ifTrue: [self newLine] ifFalse: [self space]. aCascadeNode messages do: [:each | self indentAround: [self formatSelectorAndArguments: each firstSeparator: [] restSeparator: ((self isMultiLineMessage: each) ifTrue: [[self newLine]] ifFalse: [[self space]])]] separatedBy: [codeStream nextPut: $;. NewLineAfterCascade ifTrue: [self newLine] ifFalse: [self space]]]! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:55'! visitArrayNode: anArrayNode self bracketWith: '{}' around: [ self formatArray: anArrayNode ]! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:56'! visitPatternBlockNode: aRBPatternBlockNode codeStream nextPut: $`. self bracketWith: '{}' around: [self formatBlock: aRBPatternBlockNode]! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: 'lr 12/27/2009 10:28'! isMultiLineMessage: aMessageNode | messageStream | (MultiLineMessages includes: aMessageNode selector) ifTrue: [ ^ true ]. (OneLineMessages includes: aMessageNode selector) ifTrue: [ ^ false ]. (NumberOfArgumentsForMultiLine <= aMessageNode arguments size) ifTrue: [ ^ true ]. (aMessageNode arguments anySatisfy: [ :each | self indent: IndentsForKeywords + 1 around: [ self willBeMultiline: each ] ]) ifTrue: [ ^ true ]. aMessageNode isUnary ifTrue: [ ^ self isLineTooLong: aMessageNode selector ]. messageStream := WriteStream on: (String new: 100). self with: aMessageNode selectorParts and: aMessageNode arguments do: [ :sel :arg | messageStream nextPutAll: sel value; space; nextPutAll: (self formattedSourceFor: arg) ] separatedBy: [ messageStream space ]. ^ self isLineTooLong: messageStream contents! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: 'lr 11/2/2009 09:22'! formatMethodBodyFor: aMethodNode self indentAround: [self newLines: NewLinesAfterMethodPattern. self formatMethodCommentFor: aMethodNode. self formatPragmasFor: aMethodNode. self visitNode: aMethodNode body]! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! formatTemporariesFor: aSequenceNode aSequenceNode temporaries isEmpty ifTrue: [^self]. self bracketWith: '|' around: [self space. aSequenceNode temporaries do: [:each | self visitNode: each. FormatCommentWithStatements ifTrue: [self formatCommentsFor: each]. self space]]. self newLines: NewLinesAfterTemporaries! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! indentAround: aBlock self indent: 1 around: aBlock! ! !RBConfigurableFormatter methodsFor: 'initialization' stamp: ''! initialize super initialize. lineStart := 0. indent := 0. lookaheadCode := IdentityDictionary new. codeStream := WriteStream on: (String new: 256)! ! !RBConfigurableFormatter methodsFor: 'private' stamp: 'lr 11/22/2009 17:17'! isLineTooLong: aString ^ self currentLineLength + (aString indexOf: Character cr ifAbsent: [ aString size ]) >= MaxLineLength! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: ''! formatCommentsFor: aNode originalSource isNil ifTrue: [^self]. aNode comments do: [:each | codeStream space; nextPutAll: (originalSource copyFrom: each first to: each last)]! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:57'! visitPragmaNode: aPragmaNode codeStream nextPut: $<. self formatSelectorAndArguments: aPragmaNode firstSeparator: [ aPragmaNode selector isInfix ifTrue: [ self space ] ] restSeparator: [ self space ]. codeStream nextPut: $>! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:57'! visitSequenceNode: aSequenceNode self formatTemporariesFor: aSequenceNode. self formatSequenceCommentsFor: aSequenceNode. self formatSequenceNodeStatementsFor: aSequenceNode! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: ''! visitNode: aNode | needsParenthesis | (lookaheadCode includesKey: aNode) ifTrue: [^self writeString: (lookaheadCode at: aNode)]. needsParenthesis := self needsParenthesisFor: aNode. self bracketWith: (needsParenthesis ifTrue: ['()'] ifFalse: ['']) around: [needsParenthesis ifTrue: [codeStream nextPutAll: StringInsideParentheses]. super visitNode: aNode. (FormatCommentWithStatements or: [aNode isMethod or: [aNode isSequence]]) ifFalse: [self formatCommentsFor: aNode]. needsParenthesis ifTrue: [codeStream nextPutAll: StringInsideParentheses]]! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! newLinesBeforeStartingAt: anIndex | count cr lf index char | (anIndex isNil or: [anIndex > originalSource size]) ifTrue: [^0]. cr := Character value: 13. lf := Character value: 10. count := 0. index := anIndex - 1. [index > 0 and: [(char := originalSource at: index) isSeparator]] whileTrue: [char == lf ifTrue: [count := count + 1. (originalSource at: (index - 1 max: 1)) == cr ifTrue: [index := index - 1]]. char == cr ifTrue: [count := count + 1]. index := index - 1]. ^count! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: 'StephaneDucasse 3/29/2013 17:25'! formatSelectorAndArguments: aMessageNode firstSeparator: firstBlock restSeparator: restBlock | separatorBlock | separatorBlock := firstBlock. aMessageNode isUnary ifTrue: [ self handleLineForSelector: aMessageNode selector withSeparatorBlock: separatorBlock. codeStream nextPutAll: aMessageNode selector ] ifFalse: [ aMessageNode selectorParts with: aMessageNode arguments do: [ :selector :argument | self handleLineForSelector: selector value withSeparatorBlock: separatorBlock. separatorBlock := restBlock. self indentAround: [ codeStream nextPutAll: selector value. (KeepBlockInMessage and: [ argument isBlock ]) ifTrue: [ self space; visitNode: argument ] ifFalse: [ ((self willBeMultiline: argument) or: [ self isLineTooLong: (self formattedSourceFor: argument) ]) ifTrue: [ self newLine ] ifFalse: [ self space ]. self visitNode: argument ] ] ] ]! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: ''! formatSequenceNodeStatementsFor: aSequenceNode | statements | statements := aSequenceNode statements. statements isEmpty ifTrue: [^self]. 1 to: statements size do: [:i | self visitNode: (statements at: i). (i < statements size or: [aSequenceNode parent ifNil: [self class periodsAsTerminators] ifNotNil: [:parent | parent isBlock ifTrue: [self class periodsAtEndOfBlock] ifFalse: [self class periodsAtEndOfMethod]]]) ifTrue: [codeStream nextPut: $.]. self formatStatementCommentsFor: (statements at: i). i < statements size ifTrue: [self addNewLinesBeforeStatementStartingAt: (statements at: i + 1) start]]! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! indent: anInteger around: aBlock indent := indent + anInteger. ^aBlock ensure: [indent := indent - anInteger]! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:55'! visitAssignmentNode: anAssignmentNode self visitNode: anAssignmentNode variable. codeStream space; nextPutAll: anAssignmentNode assignmentOperator; space. self visitNode: anAssignmentNode value! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'MarcusDenker 9/20/2013 10:30'! visitLiteralNode: aLiteralNode aLiteralNode value isLiteral ifFalse: [ self writeString: '''''' ] ifTrue: [ self writeString: aLiteralNode token storeString ]! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:57'! visitReturnNode: aReturnNode codeStream nextPut: $^; nextPutAll: StringFollowingReturn. self visitNode: aReturnNode value! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: 'lr 11/2/2009 09:31'! formatArray: anArrayNode self formatSequenceCommentsFor: anArrayNode. self formatSequenceNodeStatementsFor: anArrayNode! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! precedenceOf: parentSelector greaterThan: childSelector "Put parenthesis around things that are preceived to have 'lower' precedence. For example, 'a + b * c' -> '(a + b) * c' but 'a * b + c' -> 'a * b + c'" | childIndex parentIndex | childIndex := 0. parentIndex := 0. 1 to: TraditionalBinaryPrecedence size do: [:i | ((TraditionalBinaryPrecedence at: i) includes: parentSelector first) ifTrue: [parentIndex := i]. ((TraditionalBinaryPrecedence at: i) includes: childSelector first) ifTrue: [childIndex := i]]. ^childIndex < parentIndex! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! currentLineLength ^codeStream position - lineStart! ! !RBConfigurableFormatter methodsFor: 'utility' stamp: ''! with: firstCollection and: secondCollection do: aBlock separatedBy: separatorBlock firstCollection isEmpty ifTrue: [^self]. aBlock value: firstCollection first value: secondCollection first. 2 to: firstCollection size do: [:i | separatorBlock value. aBlock value: (firstCollection at: i) value: (secondCollection at: i)]! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:56'! visitMessageNode: aMessageNode self visitNode: aMessageNode receiver. self formatSelectorAndArguments: aMessageNode! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! willBeMultiline: aNode ^(self formattedSourceFor: aNode) includes: Character cr! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: ''! formatMethodCommentFor: aMethodNode originalSource isNil ifTrue: [^self]. (FormatCommentWithStatements ifTrue: [aMethodNode methodComments] ifFalse: [aMethodNode comments]) do: [:each | codeStream nextPutAll: (originalSource copyFrom: each first to: each last). self newLines: NewLinesAfterMethodComment]! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:56'! visitMethodNode: aMethodNode self formatMethodPatternFor: aMethodNode. self formatMethodBodyFor: aMethodNode! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:57'! visitVariableNode: aVariableNode codeStream nextPutAll: aVariableNode name! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:56'! visitBlockNode: aBlockNode self bracketWith: '[]' around: [self formatBlock: aBlockNode]! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: 'lr 2/28/2010 22:17'! formatSelectorAndArguments: aMessageNode | newLineBetweenArguments | newLineBetweenArguments := self isMultiLineMessage: aMessageNode. self indent: (newLineBetweenArguments ifTrue: [ IndentsForKeywords ] ifFalse: [ 0 ]) around: [ self formatSelectorAndArguments: aMessageNode firstSeparator: ((newLineBetweenArguments or: [ NewLineBeforeFirstKeyword ]) ifTrue: [ [ self newLine ] ] ifFalse: [ [ self space ] ]) restSeparator: (newLineBetweenArguments ifTrue: [ [ self newLine ] ] ifFalse: [ [ self space ] ]) ]! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:56'! visitLiteralArrayNode: aRBArrayLiteralNode | brackets | codeStream nextPut: $#. brackets := aRBArrayLiteralNode isForByteArray ifTrue: ['[]'] ifFalse: ['()']. self bracketWith: brackets around: [aRBArrayLiteralNode contents do: [:each | self visitNode: each] separatedBy: [self space]]! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! writeString: aString | index | index := aString lastIndexOf: Character cr ifAbsent: [0]. codeStream nextPutAll: aString. index > 0 ifTrue: [lineStart := codeStream position - (aString size - index)]! ! !RBConfigurableFormatter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:56'! visitPatternWrapperBlockNode: aRBPatternWrapperBlockNode self visitNode: aRBPatternWrapperBlockNode wrappedNode. codeStream nextPut: $`. self bracketWith: '{}' around: [self formatBlock: aRBPatternWrapperBlockNode]! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! newLines: anInteger anInteger + IndentString size = 0 ifTrue: [codeStream space]. anInteger timesRepeat: [codeStream cr]. lineStart := codeStream position. indent timesRepeat: [codeStream nextPutAll: IndentString]! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: ''! formatSequenceCommentsFor: aSequenceNode originalSource isNil ifTrue: [^self]. aSequenceNode comments do: [:each | codeStream nextPutAll: (originalSource copyFrom: each first to: each last). self newLine]! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: 'lr 11/2/2009 10:09'! formatPragmasFor: aMethodNode aMethodNode pragmas do: [ :each | self visitNode: each; newLine ]! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: 'StephaneDucasse 3/29/2013 17:23'! handleLineForSelector: selector withSeparatorBlock: aBlock ^ (self isLineTooLong: selector) ifTrue: [ self newLine ] ifFalse: [ aBlock value ]! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! newLine self newLines: 1! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! addNewLinesBeforeStatementStartingAt: anInteger | newLines | newLines := MinimumNewLinesBetweenStatements max: (RetainBlankLinesBetweenStatements ifTrue: [self newLinesBeforeStartingAt: anInteger] ifFalse: [0]). newLines = 0 ifTrue: [self space] ifFalse: [self newLines: newLines]! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! space codeStream space! ! !RBConfigurableFormatter methodsFor: 'public interface' stamp: ''! format: aParseTree originalSource := aParseTree source. self visitNode: aParseTree. ^codeStream contents! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: 'lr 2/28/2010 21:54'! formatBlock: aBlockNode (LineUpBlockBrackets and: [ self willBeMultiline: aBlockNode body ]) ifTrue: [ self newLine ] ifFalse: [ codeStream nextPutAll: StringInsideBlocks ]. self formatBlockArgumentsFor: aBlockNode. (self willBeMultiline: aBlockNode body) ifTrue: [ self newLine ]. self visitNode: aBlockNode body. (LineUpBlockBrackets and: [ self willBeMultiline: aBlockNode body ]) ifTrue: [ self newLine ] ifFalse: [ codeStream nextPutAll: StringInsideBlocks ]! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! formattedSourceFor: aNode ^lookaheadCode at: aNode ifAbsentPut: [self class format: aNode withIndents: indent]! ! !RBConfigurableFormatter methodsFor: 'private' stamp: ''! bracketWith: bracketString around: aBlock bracketString isEmpty ifTrue: [^aBlock value]. codeStream nextPut: bracketString first. ^aBlock ensure: [codeStream nextPut: bracketString last]! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: 'lr 2/28/2010 21:59'! formatBlockArgumentsFor: aBlockNode aBlockNode arguments isEmpty ifTrue: [ ^ self ]. aBlockNode arguments do: [ :each | codeStream nextPut: $:. self visitNode: each. FormatCommentWithStatements ifTrue: [ self formatCommentsFor: each ]. self space ]. codeStream nextPutAll: '| '! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: ''! formatStatementCommentsFor: aStatementNode originalSource isNil ifTrue: [^self]. FormatCommentWithStatements ifFalse: [^self]. aStatementNode statementComments do: [:each | codeStream tab; nextPutAll: (originalSource copyFrom: each first to: each last)]! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: ''! formatMethodPatternFor: aMethodNode aMethodNode arguments isEmpty ifTrue: [codeStream nextPutAll: aMethodNode selector] ifFalse: [self with: aMethodNode selectorParts and: aMethodNode arguments do: [:key :arg | codeStream nextPutAll: key value. self space. self visitNode: arg] separatedBy: [MethodSignatureOnMultipleLines ifTrue: [self newLine] ifFalse: [self space]]]! ! !RBConfigurableFormatter methodsFor: 'private' stamp: 'CamilloBruni 10/31/2012 17:11'! needsParenthesisFor: aNode | parent grandparent | aNode ifNil: [ ^ false ]. aNode isValue ifFalse: [ ^ false ]. parent := aNode parent ifNil: [ ^ false ]. (CascadedMessageInsideParentheses and: [ aNode isMessage and: [ parent isMessage and: [ parent receiver == aNode ] ] ]) ifTrue: [ grandparent := parent parent. (grandparent notNil and: [ grandparent isCascade ]) ifTrue: [ ^ true ] ]. (aNode precedence < parent precedence) ifTrue: [ ^ false ]. (aNode isAssignment and: [ parent isAssignment ]) ifTrue: [ ^ false ]. (aNode isAssignment and: [ aNode isCascade ]) ifTrue: [ ^ true ]. (aNode precedence = 0) ifTrue: [ ^ false ]. (aNode isMessage) ifFalse: [ ^ true ]. (aNode precedence = parent precedence) ifFalse: [ ^ true ]. (aNode isUnary) ifTrue: [ ^ false ]. (aNode isKeyword) ifTrue: [ ^ true ]. (parent receiver == aNode) ifFalse: [ ^ true ]. ^ UseTraditionalBinaryPrecedenceForParentheses and: [ self precedenceOf: parent selector greaterThan: aNode selector ]! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 9/11/2010 17:20'! oneLineMessages ^ OneLineMessages printString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 2/28/2010 21:50'! keepBlockInMessage: aBoolean KeepBlockInMessage := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! minimumNewLinesBetweenStatements ^ MinimumNewLinesBetweenStatements! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! stringFollowingReturn: aString StringFollowingReturn := aString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! lineUpBlockBrackets ^ LineUpBlockBrackets! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! useTraditionalBinaryPrecedenceForParentheses ^ UseTraditionalBinaryPrecedenceForParentheses! ! !RBConfigurableFormatter class methodsFor: 'initialization' stamp: 'lr 7/25/2011 20:55'! initialize CascadedMessageInsideParentheses := false. FormatCommentWithStatements := true. IndentString := String with: Character tab. IndentsForKeywords := 1. KeepBlockInMessage := true. LineUpBlockBrackets := false. MaxLineLength := 120. MethodSignatureOnMultipleLines := false. MinimumNewLinesBetweenStatements := 1. MultiLineMessages := #(#ifTrue:ifFalse: #ifFalse:ifTrue: #ifTrue: #ifFalse: #on:do: #ensure: #ifCurtailed:). NewLineAfterCascade := true. NewLineBeforeFirstCascade := true. NewLineBeforeFirstKeyword := false. NewLinesAfterMethodComment := 2. NewLinesAfterMethodPattern := 1. NewLinesAfterTemporaries := 1. NumberOfArgumentsForMultiLine := 4. OneLineMessages := #(#to: #to:do: #to:by: #to:by:do:). PeriodsAtEndOfBlock := false. PeriodsAtEndOfMethod := false. RetainBlankLinesBetweenStatements := false. StringFollowingReturn := ' '. StringInsideBlocks := ' '. StringInsideParentheses := ''. TraditionalBinaryPrecedence := #(#($| $& $?) #($= $~ $< $>) #($- $+) #($* $/ $% $\) #($@)). UseTraditionalBinaryPrecedenceForParentheses := true! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'MarcusDenker 4/30/2013 11:21'! multiLineMessages: aString MultiLineMessages := self compiler evaluate: aString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! stringInsideParentheses: aString StringInsideParentheses := aString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! newLinesAfterMethodPattern: anInteger NewLinesAfterMethodPattern := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! indentsForKeywords: anInteger IndentsForKeywords := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! stringInsideBlocks: aString StringInsideBlocks := aString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'MarcusDenker 4/30/2013 11:20'! oneLineMessages: aString OneLineMessages := self compiler evaluate: aString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLinesAfterTemporaries ^ NewLinesAfterTemporaries! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! numberOfArgumentsForMultiLine ^ NumberOfArgumentsForMultiLine! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLinesAfterMethodComment ^ NewLinesAfterMethodComment! ! !RBConfigurableFormatter class methodsFor: 'public' stamp: 'lr 12/27/2009 13:05'! format: aParseTree withIndents: anInteger ^ self new indent: anInteger; format: aParseTree! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLineBeforeFirstKeyword ^ NewLineBeforeFirstKeyword! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! stringInsideBlocks ^ StringInsideBlocks! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! formatCommentWithStatements: aBoolean FormatCommentWithStatements := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 7/25/2011 20:53'! cascadedMessageInsideParentheses: aBoolean CascadedMessageInsideParentheses := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! formatCommentWithStatements ^ FormatCommentWithStatements! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 7/25/2011 20:53'! cascadedMessageInsideParentheses ^ CascadedMessageInsideParentheses! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! indentString: aString IndentString := aString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! indentString ^ IndentString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! newLineBeforeFirstKeyword: aBoolean NewLineBeforeFirstKeyword := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! newLinesAfterTemporaries: anInteger NewLinesAfterTemporaries := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! periodsAsTerminators: aBoolean PeriodsAtEndOfBlock := aBoolean. PeriodsAtEndOfMethod := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! stringInsideParentheses ^ StringInsideParentheses! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 9/11/2010 17:20'! traditionalBinaryPrecedence ^ TraditionalBinaryPrecedence printString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! methodSignatureOnMultipleLines ^ MethodSignatureOnMultipleLines! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! minimumNewLinesBetweenStatements: anInteger MinimumNewLinesBetweenStatements := anInteger! ! !RBConfigurableFormatter class methodsFor: 'settings' stamp: 'lr 7/25/2011 20:53'! settingsOn: aBuilder (aBuilder group: #configurableFormatter) target: self; parentName: #refactoring; label: 'Configurable Formatter'; description: 'Settings related to the formatter'; with: [ (aBuilder setting: #cascadedMessageInsideParentheses) label: 'Cascaded message inside parentheses'. (aBuilder setting: #formatCommentWithStatements) label: 'Format comment with statements'. (aBuilder setting: #indentString) label: 'Indent string'. (aBuilder setting: #indentsForKeywords) label: 'Indents for keywords'. (aBuilder setting: #keepBlockInMessage) label: 'Keep block in message'. (aBuilder setting: #lineUpBlockBrackets) label: 'Line up block brackets'. (aBuilder setting: #methodSignatureOnMultipleLines) label: 'Method signature on multiple lines'. (aBuilder setting: #maxLineLength) label: 'Max line length'. (aBuilder setting: #oneLineMessages) label: 'One line messages'. (aBuilder setting: #multiLineMessages) label: 'Multi line messages'. (aBuilder setting: #minimumNewLinesBetweenStatements) label: 'Minimum new lines between statements'. (aBuilder setting: #newLineAfterCascade) label: 'New line after cascade'. (aBuilder setting: #newLineBeforeFirstCascade) label: 'New line before first cascade'. (aBuilder setting: #newLineBeforeFirstKeyword) label: 'New line before first keyword'. (aBuilder setting: #newLinesAfterMethodComment) label: 'New lines after method comment'. (aBuilder setting: #newLinesAfterMethodPattern) label: 'New lines after method pattern'. (aBuilder setting: #newLinesAfterTemporaries) label: 'New lines after temporaries'. (aBuilder setting: #numberOfArgumentsForMultiLine) label: 'Number of arguments for multi line'. (aBuilder setting: #periodsAsTerminators) label: 'Periods as terminators'. (aBuilder setting: #periodsAtEndOfBlock) label: 'Periods at end of block'. (aBuilder setting: #periodsAtEndOfMethod) label: 'Periods at end of method'. (aBuilder setting: #stringFollowingReturn) label: 'String following return'. (aBuilder setting: #stringInsideBlocks) label: 'String inside blocks'. (aBuilder setting: #stringInsideParentheses) label: 'String inside parentheses'. (aBuilder setting: #traditionalBinaryPrecedence) label: 'Traditional binary precedence'. (aBuilder setting: #useTraditionalBinaryPrecedenceForParentheses) label: 'Use traditional binary precedence for parentheses' ]! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! useTraditionalBinaryPrecedenceForParentheses: aBoolean UseTraditionalBinaryPrecedenceForParentheses := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 2/28/2010 21:49'! keepBlockInMessage ^ KeepBlockInMessage! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 9/11/2010 17:20'! multiLineMessages ^ MultiLineMessages printString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! retainBlankLinesBetweenStatements: aBoolean RetainBlankLinesBetweenStatements := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'MarcusDenker 4/30/2013 11:22'! traditionalBinaryPrecedence: aString TraditionalBinaryPrecedence := self compiler evaluate: aString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLineAfterCascade ^ NewLineAfterCascade! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! newLineAfterCascade: aBoolean NewLineAfterCascade := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! periodsAtEndOfMethod ^ PeriodsAtEndOfMethod! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLineBeforeFirstCascade ^ NewLineBeforeFirstCascade! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! stringFollowingReturn ^ StringFollowingReturn! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! maxLineLength ^ MaxLineLength! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! methodSignatureOnMultipleLines: aBoolean MethodSignatureOnMultipleLines := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! indentsForKeywords ^ IndentsForKeywords! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLinesAfterMethodComment: anInteger NewLinesAfterMethodComment := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! periodsAsTerminators ^ PeriodsAtEndOfBlock and: [ PeriodsAtEndOfMethod ]! ! !RBConfigurableFormatter class methodsFor: 'public' stamp: ''! format: aParseTree ^self format: aParseTree withIndents: 0! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! maxLineLength: anInteger MaxLineLength := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! newLineBeforeFirstCascade: aBoolean NewLineBeforeFirstCascade := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! periodsAtEndOfBlock ^ PeriodsAtEndOfBlock! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! numberOfArgumentsForMultiLine: anInteger NumberOfArgumentsForMultiLine := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: ''! lineUpBlockBrackets: aBoolean LineUpBlockBrackets := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! retainBlankLinesBetweenStatements ^ RetainBlankLinesBetweenStatements! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLinesAfterMethodPattern ^ NewLinesAfterMethodPattern! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! periodsAtEndOfBlock: aBoolean PeriodsAtEndOfBlock := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! periodsAtEndOfMethod: aBoolean PeriodsAtEndOfMethod := aBoolean! ! !RBConjunctiveCondition methodsFor: 'private' stamp: ''! unknownFailed ^(left errorStringFor: false) , ' OR ' , (right errorStringFor: false)! ! !RBConjunctiveCondition methodsFor: 'private' stamp: ''! errorStringFor: aBoolean ^aBoolean ifTrue: [self neitherFailed] ifFalse: [self perform: failed]! ! !RBConjunctiveCondition methodsFor: 'private' stamp: ''! rightFailed ^right errorStringFor: false! ! !RBConjunctiveCondition methodsFor: 'printing' stamp: 'bh 4/10/2001 16:52'! printOn: aStream aStream nextPutAll: left asString; nextPutAll: ' & '; nextPutAll: right asString ! ! !RBConjunctiveCondition methodsFor: 'checking' stamp: ''! check left check ifFalse: [failed := #leftFailed. ^false]. right check ifFalse: [failed := #rightFailed. ^false]. ^true! ! !RBConjunctiveCondition methodsFor: 'initialize-release' stamp: ''! left: aCondition right: aCondition2 left := aCondition. right := aCondition2. failed := #unknownFailed! ! !RBConjunctiveCondition methodsFor: 'private' stamp: ''! leftFailed ^left errorStringFor: false! ! !RBConjunctiveCondition methodsFor: 'private' stamp: ''! neitherFailed ^(left errorStringFor: true) , ' AND ' , (right errorStringFor: true)! ! !RBConjunctiveCondition methodsFor: 'private' stamp: 'lr 11/2/2009 23:38'! errorBlockFor: aBoolean ^aBoolean ifTrue: [nil] ifFalse: [failed = #leftFailed ifTrue: [left errorBlock] ifFalse: [right errorBlock]]! ! !RBConjunctiveCondition methodsFor: 'private' stamp: ''! longMacro ^'(' , left errorMacro , ') <1?AND:OR> (' , right errorMacro , ')'! ! !RBConjunctiveCondition methodsFor: 'private' stamp: ''! errorMacro ^errorMacro isNil ifTrue: [self longMacro] ifFalse: [super errorMacro]! ! !RBConsistencyCheckRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:24'! initialize super initialize. self matcher matchesAnyOf: #( '`@object size == 0' '`@object size = 0' '`@object size > 0' '`@object size >= 1' '`@object == nil' '`@object = nil' '`@collection at: 1' '`@collection at: `@collection size' ) do: [ :node :answer | node ]! ! !RBConsistencyCheckRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for people using equality tests instead of the message sends. Since the code "aCollection size = 0" works for all objects, it is more difficult for someone reading such code to determine that "aCollection" is a collection. Whereas, if you say "aCollection isEmpty" then aCollection must be a collection since isEmpty is only defined for collections.'! ! !RBConsistencyCheckRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBConsistencyCheckRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses "size = 0", "= nil", or "at: 1" instead of "isEmpty", "isNil", or "first"'! ! !RBConsistencyCheckRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:24'! category ^'Coding Idiom Violation'! ! !RBConsistencyCheckRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ConsistencyCheckRule'! ! !RBContainsRule methodsFor: 'initialization' stamp: 'CamilleTeruel 4/3/2013 17:22'! initialize super initialize. self matcher matchesAnyOf: #( '(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) isNil' '(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) notNil' '(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) = nil' '(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) == nil' '(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) ~= nil' '(`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [nil]) ~~ nil' '`@object detect: [:`each | | `@temps| `@.Statements] ifNone: [| `@temps1 | `@.Statements2. ^`@anything]' ) do: [ :node :answer | node ]! ! !RBContainsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for the common code fragment: "(aCollection detect: [:each | ''some condition''] ifNone: [nil]) ~= nil". contains: can simplify this code to "aCollection contains: [:each | ''some condition'']". Not only is the contains: variant shorter, it better signifies what the code is doing.'! ! !RBContainsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBContainsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses detect:ifNone: instead of contains:'! ! !RBContainsRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:51'! category ^ 'Optimization'! ! !RBContainsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ContainsRule'! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'testing' stamp: ''! needsReturnForSetter needsReturn isNil ifTrue: [needsReturn := self usesAssignmentOf: variableName in: class classVariable: classVariable]. ^needsReturn! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing' stamp: ''! possibleGetterSelectors ^self methodsReferencingVariable select: [:each | each numArgs == 0]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing' stamp: 'lr 10/26/2009 22:09'! definingClass ^ classVariable ifTrue: [ class theMetaClass ] ifFalse: [ class ]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^classVariable ifTrue: [RBCondition definesClassVariable: variableName asSymbol in: class] ifFalse: [RBCondition definesInstanceVariable: variableName in: class]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing' stamp: ''! setterMethod ^setterMethod! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' variable: '. variableName storeOn: aStream. aStream nextPutAll: ' class: '. class storeOn: aStream. aStream nextPutAll: ' classVariable: '. classVariable storeOn: aStream. aStream nextPut: $)! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: ''! transform self createGetterAccessor; createSetterAccessor! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing' stamp: ''! methodsReferencingVariable ^classVariable ifTrue: [self definingClass whichSelectorsReferToClassVariable: variableName] ifFalse: [self definingClass whichSelectorsReferToInstanceVariable: variableName]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing' stamp: 'lr 11/2/2009 00:14'! findGetterMethod | definingClass matcher | definingClass := self definingClass. matcher := RBParseTreeSearcher getterMethod: variableName. ^self possibleGetterSelectors detect: [:each | (self checkClass: definingClass selector: each using: matcher) notNil and: [(definingClass subclassRedefines: each) not]] ifNone: [nil]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'initialize-release' stamp: ''! classVariable: aBoolean classVariable := aBoolean! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing' stamp: ''! getterMethod ^getterMethod! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: ''! createSetterAccessor setterMethod := self findSetterMethod. setterMethod isNil ifTrue: [setterMethod := self defineSetterMethod]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: ''! createGetterAccessor getterMethod := self findGetterMethod. getterMethod isNil ifTrue: [getterMethod := self defineGetterMethod]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing' stamp: ''! possibleSetterSelectors ^self methodsReferencingVariable select: [:each | each numArgs == 1]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: 'dc 4/4/2007 16:41'! defineSetterMethod | selector definingClass string | definingClass := self definingClass. string := self needsReturnForSetter ifTrue: ['<1s> anObject^ <2s> := anObject'] ifFalse: ['<1s> anObject<2s> := anObject']. selector := self safeMethodNameFor: definingClass basedOn: variableName asString , ':'. definingClass compile: (string expandMacrosWith: selector with: variableName) classified: #accessing. ^selector! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'testing' stamp: 'lr 11/2/2009 00:14'! usesAssignmentOf: aString in: aClass classVariable: isClassVar | matcher definingClass | matcher := RBParseTreeSearcher new. matcher answer: false; matches: aString , ' := ``@object' do: [ :aNode :answer | answer or: [ aNode isUsed ] ]. definingClass := isClassVar ifTrue: [ aClass theNonMetaClass ] ifFalse: [ aClass ]. ^ (definingClass withAllSubclasses , (isClassVar ifTrue: [ definingClass theMetaClass withAllSubclasses ] ifFalse: [ #() ]) detect: [ :each | ((isClassVar ifTrue: [ each whichSelectorsReferToClassVariable: aString ] ifFalse: [ each whichSelectorsReferToInstanceVariable: aString ]) detect: [ :sel | self checkClass: each selector: sel using: matcher ] ifNone: [ nil ]) notNil ] ifNone: [ nil ]) notNil! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming' stamp: 'dc 4/4/2007 16:41'! defineGetterMethod | selector definingClass | definingClass := self definingClass. selector := self safeMethodNameFor: definingClass basedOn: variableName asString. definingClass compile: ('<1s>^ <2s>' expandMacrosWith: selector with: variableName) classified: #(#accessing). ^selector! ! !RBCreateAccessorsForVariableRefactoring methodsFor: '*NautilusRefactoring' stamp: 'CamilloBruni 11/17/2013 16:00'! whatToDisplayIn: aBrowser ^ (self changes changes select: [:change | {getterMethod. setterMethod} includes: change selector ]) gather: [:change | change whatToDisplayIn: aBrowser ]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing' stamp: 'lr 11/2/2009 00:14'! findSetterMethod | definingClass matcher | definingClass := self definingClass. matcher := self needsReturnForSetter ifTrue: [RBParseTreeSearcher returnSetterMethod: variableName] ifFalse: [RBParseTreeSearcher setterMethod: variableName]. ^self possibleSetterSelectors detect: [:each | (self checkClass: definingClass selector: each using: matcher) notNil and: [(definingClass subclassRedefines: each) not]] ifNone: [nil]! ! !RBCreateAccessorsForVariableRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk variable: aVarName class: aClass classVariable: aBoolean ^(self model: aRBSmalltalk variable: aVarName class: aClass) classVariable: aBoolean; yourself! ! !RBCreateAccessorsForVariableRefactoring class methodsFor: 'instance creation' stamp: ''! variable: aVarName class: aClass classVariable: aBoolean ^(self variable: aVarName class: aClass) classVariable: aBoolean; yourself! ! !RBCreateAccessorsForVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testNewInstanceVariableAccessors | ref class | ref := RBCreateAccessorsForVariableRefactoring variable: 'foo1' class: RBLintRuleTest classVariable: false. self executeRefactoring: ref. class := ref model classNamed: #RBLintRuleTest. self deny: ref changes changes isEmpty. self assert: ref setterMethod == #foo1:. self assert: ref getterMethod == #foo1. self assert: (class parseTreeFor: #foo1) = (RBParser parseMethod: 'foo1 ^foo1'). self assert: (class parseTreeFor: #foo1:) = (RBParser parseMethod: 'foo1: anObject foo1 := anObject')! ! !RBCreateAccessorsForVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBCreateAccessorsForVariableRefactoring variable: #Foo class: RBBasicLintRuleTest classVariable: true); shouldFail: (RBCreateAccessorsForVariableRefactoring variable: 'foo' class: RBBasicLintRuleTest classVariable: true)! ! !RBCreateAccessorsForVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testExistingInstanceVariableAccessors | ref | ref := RBCreateAccessorsForVariableRefactoring variable: 'name' class: RBLintRuleTest classVariable: false. self executeRefactoring: ref. self assert: ref changes changes isEmpty. self assert: ref setterMethod == #name:. self assert: ref getterMethod == #name! ! !RBCreateAccessorsForVariableTest methodsFor: 'set up' stamp: 'CamilloBruni 8/27/2013 15:06'! setUp super setUp. model := self abstractVariableTestData.! ! !RBCreateAccessorsForVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testNewClassVariableAccessors | ref class | ref := RBCreateAccessorsForVariableRefactoring variable: 'Foo1' class: RBLintRuleTest classVariable: true. self executeRefactoring: ref. class := ref model metaclassNamed: #RBLintRuleTest. self deny: ref changes changes isEmpty. self assert: ref setterMethod == #foo1:. self assert: ref getterMethod == #foo1. self assert: (class parseTreeFor: #foo1) = (RBParser parseMethod: 'foo1 ^Foo1'). self assert: (class parseTreeFor: #foo1:) = (RBParser parseMethod: 'foo1: anObject Foo1 := anObject')! ! !RBCreateCascadeRefactoring commentStamp: ''! A RBCreateCascadeRefactoring is a refactoring used to generate cascades in source code. Copied from OB-Refactory-Tools and should be moved into RB instead ! !RBCreateCascadeRefactoring methodsFor: 'transforming' stamp: ''! compileCode class compileTree: (RBParseTreeRewriter replaceStatements: sequenceNode formattedCode with: transformedNode formattedCode in: self parseTree onInterval: selectedInterval)! ! !RBCreateCascadeRefactoring methodsFor: 'accessing' stamp: ''! selectedSource ^ self parseTree source copyFrom: selectedInterval first to: selectedInterval last! ! !RBCreateCascadeRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:13'! addStatementNode: aNode aNode isMessage ifTrue: [ ^ statementNodes add: aNode ]. aNode isCascade ifTrue: [ ^ statementNodes addAll: aNode messages ]. self refactoringFailure: aNode formattedCode , ' is not a valid message'! ! !RBCreateCascadeRefactoring methodsFor: 'preconditions' stamp: ''! findStatementNodes "Find the sequence to be combined." statementNodes := OrderedCollection new. sequenceNode statements do: [ :each | (sequenceNode isLast: each) ifFalse: [ self addStatementNode: each ] ifTrue: [ | current | current := each. [ current isReturn or: [ current isAssignment ] ] whileTrue: [ current := current value ]. self addStatementNode: current ] ]! ! !RBCreateCascadeRefactoring methodsFor: 'accessing' stamp: 'CamilloBruni 10/7/2012 23:59'! parseTree parseTree isNil ifTrue: [ parseTree := class parseTreeFor: selector. parseTree isNil ifTrue: [ self refactoringFailure: 'Could not parse sources' ] ]. ^ parseTree! ! !RBCreateCascadeRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^ (RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [ self findSequenceNode; findStatementNodes; findReceiverNode. true ])! ! !RBCreateCascadeRefactoring methodsFor: 'transforming' stamp: ''! transform self combineMessages. self compileCode! ! !RBCreateCascadeRefactoring methodsFor: 'initialization' stamp: ''! combine: anInterval from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. selectedInterval := anInterval! ! !RBCreateCascadeRefactoring methodsFor: 'transforming' stamp: ''! combineMessages "This combines the messages and adds the assignements of the last statement to the cascade. This is not necessary if there is a return, because the refactoring engine automatically compensates for that." | expression | transformedNode := RBCascadeNode messages: (statementNodes collect: [ :each | each copy ]). expression := statementNodes last parent. [ expression isAssignment ] whileTrue: [ transformedNode := RBAssignmentNode variable: expression variable value: transformedNode. expression := expression parent ]! ! !RBCreateCascadeRefactoring methodsFor: 'preconditions' stamp: ''! findReceiverNode "Find the sequence to be combined." | receiverNodes | receiverNodes := statementNodes collect: [ :each | each receiver ]. receiverNodes asSet size = 1 ifFalse: [ self refactoringError: 'All statements must have the same receiver' ]. (receiverNodes first isLiteralNode or: [ receiverNodes first isVariable ]) ifFalse: [ self refactoringWarning: 'The receiver is an expression. Proceed with caution' ]! ! !RBCreateCascadeRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:12'! findSequenceNode "Find the sequence to be combined." sequenceNode := RBParser parseExpression: self selectedSource onError: [ :msg :pos | self refactoringFailure: 'Invalid source to rewrite' ]. (sequenceNode isSequence and: [ sequenceNode statements size > 1 ]) ifFalse: [ self refactoringFailure: 'You must select two or more statements' ]! ! !RBCreateCascadeRefactoring class methodsFor: 'instance-creation' stamp: ''! combine: anInterval from: aSelector in: aClass ^ self new combine: anInterval from: aSelector in: aClass; yourself! ! !RBCreateCascadeRefactoring class methodsFor: 'instance-creation' stamp: ''! model: aNamespace combine: anInterval from: aSelector in: aClass ^ self new model: aNamespace; combine: anInterval from: aSelector in: aClass; yourself! ! !RBDefinesEqualNotHashRule commentStamp: ''! See my #rationale. When a class defines = also and not hash, this can lead to really subtle bugs and behavior where sometimes it appears that an object is in a set and sometimes not. One pattern proposed by Kent Beck in Best Smalltalk Practices is to define hash in terms of instance variable hash xor. Here is an example: Book>>= anotherBook ^ (self author = anotherBook author) and: [self title = anotherBook title] Book>>hash ^ (self title hash bitXor: self title hash ! !RBDefinesEqualNotHashRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBDefinesEqualNotHashRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:05'! category ^ 'Potential Bugs'! ! !RBDefinesEqualNotHashRule methodsFor: '*Manifest-Core' stamp: 'ah 8/2/2012 13:12'! longDescription ^ 'This smell arises when a class defines #= also and not #hash. If #hash is not defined then the instances of the class might not be able to be used in sets since equal element must have the same hash.'! ! !RBDefinesEqualNotHashRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks that all classes that define = also define hash. If hash is not defined then the instances of the class might not be able to be used in sets since equal element must have the same hash.'! ! !RBDefinesEqualNotHashRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBDefinesEqualNotHashRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Defines = but not hash'! ! !RBDefinesEqualNotHashRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkClass: aContext ((aContext selectedClass includesSelector: #=) and: [ (aContext selectedClass includesSelector: #hash) not ]) ifTrue: [ result addClass: aContext selectedClass ]! ! !RBDefinesEqualNotHashRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'DefinesEqualNotHashRule'! ! !RBDetectContainsRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:24'! initialize super initialize. self matcher matchesAnyOf: #( '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifFalse: [| `@BlockTemps | `@.BlockStatements1. ^`each]. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifTrue: [| `@BlockTemps | `@.BlockStatements1. ^`each]. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifFalse: [| `@BlockTemps | `@.BlockStatements1. ^true]. `@.Statements2]' '`@Collection do: [:`each | | `@temps | `@.Statements1. `@condition ifTrue: [| `@BlockTemps | `@.BlockStatements1. ^true]. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifFalse: [| `@BlockTemps | `@.BlockStatements1. ^false]. `@.Statements2]' '`@collection do: [:`each | | `@temps | `@.Statements1. `@condition ifTrue: [| `@BlockTemps | `@.BlockStatements1. ^false]. `@.Statements2]' ) do: [ :node :answer | node ]! ! !RBDetectContainsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for people using the do: method instead of using the contains: or detect: methods.'! ! !RBDetectContainsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBDetectContainsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses do: instead of contains: or detect:''s'! ! !RBDetectContainsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:24'! category ^'Coding Idiom Violation'! ! !RBDetectContainsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'DetectContainsRule'! ! !RBDetectIfNoneRule commentStamp: ''! See rationale! !RBDetectIfNoneRule methodsFor: 'initialization' stamp: 'lr 1/3/2010 11:56'! initialize super initialize. self rewriteRule replace: '``@collection contains: [:`each | | `@temps | ``@.Statements]' with: '``@collection anySatisfy: [:`each | | `@temps | ``@.Statements]'; replace: '(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) isNil' with: '(``@collection anySatisfy: [:`each | | `@temps | ``@.Statements]) not'; replace: '(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) = nil' with: '(``@collection anySatisfy: [:`each | | `@temps | ``@.Statements]) not'; replace: '(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) == nil' with: '(``@collection anySatisfy: [:`each | | `@temps | ``@.Statements]) not'; replace: '(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) notNil' with: '``@collection anySatisfy: [:`each | | `@temps | ``@.Statements]'; replace: '(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) ~= nil' with: '``@collection anySatisfy: [:`each | | `@temps | ``@.Statements]'; replace: '(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) ~~ nil' with: '``@collection anySatisfy: [:`each | | `@temps | ``@.Statements]'! ! !RBDetectIfNoneRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBDetectIfNoneRule methodsFor: 'accessing' stamp: 'lr 1/3/2010 11:55'! name ^ '#detect:ifNone: -> anySatisfy:'! ! !RBDetectIfNoneRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:50'! category ^ 'Coding Idiom Violation'! ! !RBDetectIfNoneRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/12/2012 14:38'! longDescription ^ 'Replaces detect:ifNone: by anySatisfy:'! ! !RBDetectIfNoneRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'DetectIfNoneRule'! ! !RBEmptyExceptionHandlerRule methodsFor: 'initialization' stamp: 'lr 3/13/2009 14:12'! initialize super initialize. self matcher matches: '`@block on: `{ :node | | class | node isVariable and: [ (class := Smalltalk classNamed: node name) notNil and: [ (class includesBehavior: Exception) and: [ (class includesBehavior: Notification) not ] ] ] } do: [ :`@err | | `@temps | ]' do: [ :node :answer | node ]! ! !RBEmptyExceptionHandlerRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 14:05'! rationale ^ 'Empty exception handler blocks hide potential bugs. The situation should be handled in a more robust way.'! ! !RBEmptyExceptionHandlerRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 13:31'! group ^ 'Possible bugs'! ! !RBEmptyExceptionHandlerRule methodsFor: 'accessing' stamp: 'lr 3/9/2010 16:07'! name ^ 'Empty exception handler'! ! !RBEmptyExceptionHandlerRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:25'! category ^'Potential Bugs'! ! !RBEmptyExceptionHandlerRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'EmptyExceptionHandlerRule'! ! !RBEndTrueFalseRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:27'! initialize super initialize. self matcher matchesAnyOf: #( '`@object ifTrue: [| `@temps1 | `@.Statements1. `.Statement] ifFalse: [| `@temps2 | `@.Statements2. `.Statement]' '`@object ifTrue: [| `@temps1 | `.Statement. `@.Statements1] ifFalse: [| `@temps2 | `.Statement. `@.Statements2]' '`@object ifFalse: [| `@temps1 | `@.Statements1. `.Statement] ifTrue: [| `@temps2 | `@.Statements2. `.Statement]' '`@object ifFalse: [| `@temps1 | `.Statement. `@.Statements1] ifTrue: [| `@temps2 | `.Statement. `@.Statement2]') do: [ :node :answer | answer isNil ifTrue: [ | statement | statement := node arguments first body statements last. (statement isVariable and: [ statement = node arguments last body statements last ]) ifFalse: [ node ] ifTrue: [ nil ] ] ifFalse: [ answer ] ]! ! !RBEndTrueFalseRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:25'! category ^'Optimization'! ! !RBEndTrueFalseRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/12/2012 13:10'! longDescription ^ 'Checks for ifTrue:ifFalse: blocks that have the same code at the beginning or end. While you might not originally write such code, as it is modified, it is easier to create such code. Instead of having the same code in two places, you should move it outside the blocks. For example, test ifTrue:[self foo. self bar] ifFalse: [self foo. self baz] is equivalent to: self foo. test ifTrue:[self bar] ifFalse: [self baz]'! ! !RBEndTrueFalseRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for ifTrue:ifFalse: blocks that have the same code at the beginning or end. While you might not originally write such code, as it is modified, it is easier to create such code. Instead of having the same code in two places, you should move it outside the blocks.'! ! !RBEndTrueFalseRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBEndTrueFalseRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:09'! severity ^ #information! ! !RBEndTrueFalseRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Check for same statements at end of ifTrue:ifFalse: blocks'! ! !RBEndTrueFalseRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'EndTrueFalseRule'! ! !RBEqualNilRule commentStamp: ''! See rationale! !RBEqualNilRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:31'! initialize super initialize. self rewriteRule replace: '``@object = nil' with: '``@object isNil'; replace: '``@object == nil' with: '``@object isNil'; replace: '``@object ~= nil' with: '``@object notNil'; replace: '``@object ~~ nil' with: '``@object notNil'! ! !RBEqualNilRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBEqualNilRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ '= nil -> isNil AND ~= nil -> notNil'! ! !RBEqualNilRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:50'! category ^ 'Coding Idiom Violation'! ! !RBEqualNilRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/12/2012 14:38'! longDescription ^ 'Replaces = nil and == nil by isNil, ~= nil and ~~ nil by notNil, '! ! !RBEqualNilRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'EqualNilRule'! ! !RBEqualNotUsedRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:26'! initialize super initialize. self matcher matches: '`{:node | node isMessage and: [node isUsed not and: [#(#= #== #~= #~~ #< #> #<= #>=) includes: node selector]]}' do: [ :node :answer | node ]! ! !RBEqualNotUsedRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:53'! rationale ^ 'Checks for senders of comparator messages that do not use the result.'! ! !RBEqualNotUsedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBEqualNotUsedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Doesn''t use the result of a =, ~=, etc.'! ! !RBEqualNotUsedRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:27'! category ^'Potential Bugs'! ! !RBEqualNotUsedRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'EqualNotUsedRule'! ! !RBEqualsTrueRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:27'! initialize super initialize. self matcher matchesAnyOf: #('true' 'false') do: [ :node :answer | answer isNil ifTrue: [ (node parent isMessage and: [ #(#= #== #~= #~~) includes: node parent selector ]) ifTrue: [ node ] ifFalse: [ nil ] ] ifFalse: [ answer ] ]! ! !RBEqualsTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for a =, ==, ~=, or ~~ message being sent to true/false or with true/false as the argument. Many times these can be eliminated since their receivers are already booleans. For example, "anObject isFoo == false" could be replaced with "anObject isFoo not" if isFoo always returns a boolean. Sometimes variables might refer to true, false, and something else, but this is considered bad style since the variable has multiple types.'! ! !RBEqualsTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBEqualsTrueRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:09'! severity ^ #information! ! !RBEqualsTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Unnecessary "= true"'! ! !RBEqualsTrueRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:27'! category ^'Optimization'! ! !RBEqualsTrueRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'EqualsTrueRule'! ! !RBEquivalentSuperclassMethodsRule commentStamp: ''! See my #rationale. The methods are equivalent when they have the same abstract syntax tree, except for variable names. The methods new and initialize are ignored because they are often overridden for compatilbity with other platforms. The ignored methods can be edited in #ignoredSelectors! !RBEquivalentSuperclassMethodsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 11:22'! category ^ 'Design Flaws'! ! !RBEquivalentSuperclassMethodsRule methodsFor: 'accessing' stamp: 'lr 4/30/2010 12:08'! ignoredSelectors "These methods are often overridden for compatilbity with other platforms." ^ #( new initialize )! ! !RBEquivalentSuperclassMethodsRule methodsFor: '*Manifest-Core' stamp: 'ah 8/6/2012 10:49'! longDescription ^ 'This smell arises when a method is equivalent to its superclass method. The methods are equivalent when they have the same abstract syntax tree, except for variables names. Such method does not add anything to the computation and can be removed since the superclass method have the same behaviour. Furthermore, the methods #new and #initialize are ignored once they are often overridden for compatilbity with other platforms. The ignored methods can be edited in RBEquivalentSuperclassMethodsRule>>ignoredSelectors'! ! !RBEquivalentSuperclassMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for methods that are equivalent to their superclass methods. Such methods don''t add anything to the computation and can be removed since the superclass''s method will work just fine.'! ! !RBEquivalentSuperclassMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBEquivalentSuperclassMethodsRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:09'! severity ^ #information! ! !RBEquivalentSuperclassMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Methods equivalently defined in superclass'! ! !RBEquivalentSuperclassMethodsRule methodsFor: 'running' stamp: 'lr 4/30/2010 12:07'! checkMethod: aContext | superclass supertree | (self ignoredSelectors includes: aContext selector) ifTrue: [ ^ self ]. aContext selectedClass superclass notNil ifTrue: [ superclass := aContext selectedClass superclass whichClassIncludesSelector: aContext selector. superclass notNil ifTrue: [ supertree := superclass parseTreeFor: aContext selector. (supertree notNil and: [ supertree equalTo: aContext parseTree exceptForVariables: supertree allDefinedVariables ]) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ] ] ]! ! !RBEquivalentSuperclassMethodsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'EquivalentSuperclassMethodsRule'! ! !RBErrorToken commentStamp: ''! I'm an scanned error. I can have multiple causes.! !RBErrorToken methodsFor: 'accessing' stamp: 'GiselaDecuzzi 6/10/2013 15:51'! location ^ location! ! !RBErrorToken methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/10/2013 15:51'! value: theValue start: tokenStart cause: errorCause location: errorPosition self value: theValue start: tokenStart . location := errorPosition. cause := errorCause .! ! !RBErrorToken methodsFor: 'accesing' stamp: 'GiselaDecuzzi 6/10/2013 10:48'! cause ^ cause! ! !RBErrorToken methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/10/2013 10:40'! isError ^true! ! !RBErrorToken class methodsFor: 'instance creation' stamp: 'GiselaDecuzzi 6/10/2013 15:54'! value: value start: tokenStart cause: errorCause location: thePosition ^ self new value: value start: tokenStart cause: errorCause location: thePosition; yourself! ! !RBExcessiveArgumentsRule commentStamp: ''! See my #rationale. If the arguments are used in multiple methods this is a clear indication for the creation of an object representing the context in which the computation should occur. The defined number of arguments can be edited in #argumentsCount.! !RBExcessiveArgumentsRule methodsFor: 'private' stamp: 'lr 6/15/2009 15:59'! argumentsCount ^ 5! ! !RBExcessiveArgumentsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:06'! category ^ 'Design Flaws'! ! !RBExcessiveArgumentsRule methodsFor: '*Manifest-Core' stamp: 'ah 8/2/2012 13:42'! longDescription ^ 'This smell arises when a method contains a long number of argument (five or more), which can indicate that a new object should be created to wrap the numerous parameters. The defined number of arguments can be edited in RBExcessiveArgumentsRule>>argumentsCount.'! ! !RBExcessiveArgumentsRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 08:38'! rationale ^ 'Long argument lists (five or more) can indicate that a new object should be created to wrap the numerous parameters.'! ! !RBExcessiveArgumentsRule methodsFor: 'accessing' stamp: 'lr 6/15/2009 15:52'! group ^ 'Miscellaneous'! ! !RBExcessiveArgumentsRule methodsFor: 'accessing' stamp: 'lr 6/15/2009 16:00'! name ^ 'Excessive number of arguments'! ! !RBExcessiveArgumentsRule methodsFor: 'running' stamp: 'lr 6/15/2009 16:00'! checkMethod: aContext aContext selector numArgs >= self argumentsCount ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBExcessiveArgumentsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ExcessiveArgumentsRule'! ! !RBExcessiveInheritanceRule commentStamp: ''! See my #rationale. Several possibilities can occur. Here are some hints: - check whether some classes in the hierarchy just do not add enough behavior to require a class in itself - check whether all the classes are the root of a kind of little inheritance hierarchy. Note that often a framework may already define a certain level of inheritance, with other layers added by user code. This rule does not take these frameworks into account. The defined inheritance depth can be edited in #inheritanceDepth.! !RBExcessiveInheritanceRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBExcessiveInheritanceRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:06'! category ^ 'Design Flaws'! ! !RBExcessiveInheritanceRule methodsFor: '*Manifest-Core' stamp: 'ah 8/2/2012 13:48'! longDescription ^ 'This smell arises when a deep inheritance is found (depth of ten or more), which is usually a sign of a design flaw. It should be broken down and reduced to something manageable. The defined inheritance depth can be edited in RBExcessiveInheritanceRule>>inheritanceDepth.'! ! !RBExcessiveInheritanceRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 08:40'! rationale ^ 'Deep inheritance (10+ depth) is usually a sign of a design flaw. Try to break it down, and reduce the inheritance to something manageable.'! ! !RBExcessiveInheritanceRule methodsFor: 'private' stamp: 'lr 6/15/2009 16:22'! inheritanceDepth ^ 10! ! !RBExcessiveInheritanceRule methodsFor: 'accessing' stamp: 'lr 6/15/2009 16:03'! group ^ 'Miscellaneous'! ! !RBExcessiveInheritanceRule methodsFor: 'accessing' stamp: 'lr 6/15/2009 16:03'! name ^ 'Excessive inheritance depth'! ! !RBExcessiveInheritanceRule methodsFor: 'running' stamp: 'lr 8/11/2010 18:49'! checkClass: aContext | count current | aContext selectedClass isMeta ifTrue: [ ^ self ]. count := 1. current := aContext selectedClass. [ current isNil ] whileFalse: [ self inheritanceDepth < count ifTrue: [ ^ result addClass: aContext selectedClass; addClass: aContext selectedClass class ]. current := current superclass. count := count + 1 ]! ! !RBExcessiveInheritanceRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ExcessiveInheritanceRule'! ! !RBExcessiveMethodsRule commentStamp: ''! See my #rationale. A good design assigns one responsibility to a class. Ask yourself, "what is the key responsibility of this class?" Using the strategy design pattern may be a solution to structure and delegate some behavior. An indication that a class may have too many responsibilities is when different groups of methods access a subpart of the instance variables. In a large system, having some large classes is often inevitable; but when there are more than a couple of large classes, you should really reconsider your design. The defined number of methods can be edited in #methodsCount.! !RBExcessiveMethodsRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBExcessiveMethodsRule methodsFor: 'private' stamp: 'CamilleTeruel 3/29/2013 17:43'! methodsCount ^ 60! ! !RBExcessiveMethodsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:06'! category ^ 'Design Flaws'! ! !RBExcessiveMethodsRule methodsFor: '*Manifest-Core' stamp: 'ah 8/6/2012 10:42'! longDescription ^ 'This smell arises when a large class is found (with 40 or more methods). Large classes are indications that it has too much responsibility. Try to break it down, and reduce the size to something manageable. The defined number of methods can be edit in RBExcessiveMethodsRule>>methodsCount.'! ! !RBExcessiveMethodsRule methodsFor: 'accessing' stamp: 'lr 6/15/2009 15:58'! rationale ^ 'Large classes are indications that the class may be trying to do too much. Try to break it down, and reduce the size to something manageable.'! ! !RBExcessiveMethodsRule methodsFor: 'accessing' stamp: 'lr 6/15/2009 15:57'! group ^ 'Miscellaneous'! ! !RBExcessiveMethodsRule methodsFor: 'accessing' stamp: 'lr 6/15/2009 15:58'! name ^ 'Excessive number of methods'! ! !RBExcessiveMethodsRule methodsFor: 'running' stamp: 'lr 6/15/2009 16:14'! checkClass: aContext aContext selectedClass selectors size >= self methodsCount ifTrue: [ result addClass: aContext selectedClass ]! ! !RBExcessiveMethodsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ExcessiveMethodsRule'! ! !RBExcessiveVariablesRule commentStamp: ''! See my #rationale. Sometimes instance variables are used instead of method arguments or temporaries. You can check if an instance variable's value is always valid during the complete lifetime of an object. In addition, looking at methods used together by a group of methods may be an indication that a new object should be created. Large classes often exhibit a large number of instance variables. Some people also confuse classes and namespaces. The defined number of instance variables can be edited in #variablesCount.! !RBExcessiveVariablesRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBExcessiveVariablesRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:07'! category ^ 'Design Flaws'! ! !RBExcessiveVariablesRule methodsFor: '*Manifest-Core' stamp: 'ah 8/6/2012 10:45'! longDescription ^ 'This smell arises when a class has too many instance variables (10 or more). Such classes could be redesigned to have fewer fields, possibly through some nested object grouping. The defined number of instance variables can be edited in RBExcessiveVariablesRule>>variablesCount.'! ! !RBExcessiveVariablesRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 08:48'! rationale ^ 'Classes that have too many instance variables (10+) could be redesigned to have fewer fields, possibly through some nested object grouping.'! ! !RBExcessiveVariablesRule methodsFor: 'accessing' stamp: 'lr 6/15/2009 16:09'! group ^ 'Miscellaneous'! ! !RBExcessiveVariablesRule methodsFor: 'accessing' stamp: 'lr 6/15/2009 16:09'! name ^ 'Excessive number of variables'! ! !RBExcessiveVariablesRule methodsFor: 'private' stamp: 'lr 6/15/2009 16:23'! variablesCount ^ 10! ! !RBExcessiveVariablesRule methodsFor: 'running' stamp: 'lr 6/15/2009 16:16'! checkClass: aContext (aContext selectedClass instVarNames size >= self variablesCount or: [ aContext selectedClass classVarNames size >= self variablesCount ]) ifTrue: [ result addClass: aContext selectedClass ]! ! !RBExcessiveVariablesRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ExcessiveVariablesRule'! ! !RBExpandReferencedPoolsRefactoring methodsFor: 'transforming' stamp: ''! movePoolVariables pools do: [:poolDict | toClasses do: [:each | self movePool: poolDict toClass: each]]! ! !RBExpandReferencedPoolsRefactoring methodsFor: 'transforming' stamp: ''! whichPoolDefines: varName | currentClass | currentClass := fromClass. [currentClass isNil] whileFalse: [currentClass allPoolDictionaryNames do: [:each | ((self poolVariableNamesIn: each) includes: varName) ifTrue: [^each]]. currentClass := currentClass superclass]. ^nil! ! !RBExpandReferencedPoolsRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! computePoolsToMove | poolVariables searcher | poolVariables := self poolVariableNamesFor: fromClass. pools := Set new. searcher := RBParseTreeSearcher new. searcher matches: '`var' do: [:aNode :answer | | varName pool | varName := aNode name. (aNode whoDefines: varName) isNil ifTrue: [(poolVariables includes: varName) ifTrue: [pool := self whichPoolDefines: varName. pool notNil ifTrue: [pools add: pool]]]]. searcher executeTree: parseTree! ! !RBExpandReferencedPoolsRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^RBCondition empty! ! !RBExpandReferencedPoolsRefactoring methodsFor: 'transforming' stamp: ''! transform self computePoolsToMove. self hasPoolsToMove ifTrue: [self refactoringWarning: 'This method contains references to poolswhich may need to be moved.' expandMacros]. self movePoolVariables! ! !RBExpandReferencedPoolsRefactoring methodsFor: 'transforming' stamp: 'lr 7/23/2010 08:04'! poolVariableNamesIn: poolName ^(Smalltalk globals at: poolName ifAbsent: [Dictionary new]) keys collect: [:name | name asString]! ! !RBExpandReferencedPoolsRefactoring methodsFor: 'transforming' stamp: 'lr 10/26/2009 22:08'! movePool: aSymbol toClass: aClass | nonMetaClass | nonMetaClass := aClass theNonMetaClass. (nonMetaClass definesPoolDictionary: aSymbol) ifFalse: [ nonMetaClass addPoolDictionary: aSymbol ]! ! !RBExpandReferencedPoolsRefactoring methodsFor: 'testing' stamp: ''! hasPoolsToMove ^pools isEmpty not! ! !RBExpandReferencedPoolsRefactoring methodsFor: 'initialize-release' stamp: ''! forMethod: aParseTree fromClass: aClass toClasses: classCollection fromClass := self model classFor: aClass. parseTree := aParseTree. toClasses := classCollection collect: [:each | self model classFor: each]! ! !RBExpandReferencedPoolsRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBNamespace forMethod: aParseTree fromClass: aClass toClasses: classCollection ^(self new) model: aRBNamespace; forMethod: aParseTree fromClass: aClass toClasses: classCollection; yourself! ! !RBExpandReferencedPoolsRefactoring class methodsFor: 'instance creation' stamp: ''! forMethod: aParseTree fromClass: aClass toClasses: classCollection ^(self new) forMethod: aParseTree fromClass: aClass toClasses: classCollection; yourself! ! !RBExplicitRequirementMethodsRule methodsFor: 'accessing' stamp: 'SebastianTleye 7/19/2013 10:15'! name ^ 'Explicit requirement methods'! ! !RBExplicitRequirementMethodsRule methodsFor: 'accessing' stamp: 'SebastianTleye 7/19/2013 10:13'! rationale ^ 'Classes that use traits with explicit requirement methods should either implement the method or inherit it.'! ! !RBExplicitRequirementMethodsRule methodsFor: 'running' stamp: 'CamilloBruni 8/31/2013 22:01'! checkClass: aContext | selectedClass explicitRequirementMethods | explicitRequirementMethods := Set new. selectedClass := aContext selectedClass. selectedClass isTrait ifTrue: [ ^ self ]. selectedClass traitComposition allSelectors do: [ :selector | | method | method := selectedClass>>selector. (method isRequired and: [ method isSubclassResponsibility not ]) ifTrue: [ explicitRequirementMethods add: method ]]. explicitRequirementMethods do: [ :method | aContext selectedClass withAllSuperclasses detect: [ :superclass | superclass canPerform: method selector ] ifNone: [result addClass: aContext selectedClass selector: method selector]].! ! !RBExplicitVariableParser commentStamp: ''! I am a specialized version of the RBParser that takes the specialized sublcasses of RBVariableNode into account.! !RBExplicitVariableParser methodsFor: 'private-classes' stamp: 'CamilloBruni 12/15/2011 16:15'! variableNodeClass ^ currentVariableNodeClass ifNil: [ RBVariableNode ]! ! !RBExplicitVariableParser methodsFor: 'private-classes' stamp: 'CamilloBruni 12/15/2011 16:15'! useVariable: aVariableNodeClass during: aBlock currentVariableNodeClass := aVariableNodeClass. ^ aBlock ensure: [ currentVariableNodeClass := nil]! ! !RBExplicitVariableParser methodsFor: 'private-classes' stamp: 'CamilloBruni 12/15/2011 16:16'! argumentNodeClass ^ RBArgumentNode! ! !RBExplicitVariableParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 12/15/2011 16:30'! parsePrimitiveIdentifier | token node | token := currentToken. self step. node := (self lookupVariableNodeClass: token value) identifierToken: token. self addCommentsTo: node. ^node! ! !RBExplicitVariableParser methodsFor: 'private-classes' stamp: 'CamilloBruni 12/15/2011 16:35'! lookupVariableNodeClass: aName | scope | currentVariableNodeClass notNil ifTrue: [ ^ currentVariableNodeClass ]. scope := currentScope. [ scope isNil ] whileFalse: [ (scope hasTemporaryNamed: aName) ifTrue: [ ^ RBTemporaryNode ]. (scope hasArgumentNamed: aName) ifTrue: [ ^ RBArgumentNode ]. scope := scope scope. ]. ^ RBVariableNode! ! !RBExplicitVariableParser methodsFor: 'private-classes' stamp: 'CamilloBruni 12/15/2011 16:16'! temporaryNodeClass ^ RBTemporaryNode! ! !RBExplicitVariableParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:38'! parseBlock | position node | position := currentToken start. self step. node := self blockNodeClass new. self pushScope: node. self useVariable: RBArgumentNode during: [ self parseBlockArgsInto: node ]. node left: position. node body: self sequenceNodeClass new. (self parseStatements: false into: node body). (currentToken isSpecial and: [currentToken value = $]]) ifFalse: [ ^ self parserError: ''']'' expected']. node right: currentToken start. self step. self popScope. ^node! ! !RBExplicitVariableParser methodsFor: 'scoping' stamp: 'CamilloBruni 12/15/2011 16:27'! pushScope: aNode aNode scope: currentScope. currentScope := aNode! ! !RBExplicitVariableParser methodsFor: 'private-parsing' stamp: 'ClementBera 7/26/2013 17:10'! parseMethod | methodNode | self useVariable: RBArgumentNode during: [methodNode := self parseMessagePattern]. self pushScope: methodNode. self parsePragmas. self addCommentsTo: methodNode. methodNode body: self sequenceNodeClass new. (self parseStatements: false into: methodNode body). pragmas ifNotNil: [ methodNode pragmas: pragmas ]. ^methodNode! ! !RBExplicitVariableParser methodsFor: 'scoping' stamp: 'CamilloBruni 12/15/2011 16:27'! popScope currentScope := currentScope scope! ! !RBExplicitVariableParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 12/15/2011 16:17'! parseTemps | args | args := OrderedCollection new. self useVariable: RBTemporaryNode during: [ [currentToken isIdentifier] whileTrue: [args add: self parseVariableNode]]. ^args! ! !RBExtraBlockRule methodsFor: 'initialization' stamp: 'CAMILLETERUEL 3/29/2013 12:50'! initialize super initialize. self matcher matches: '`{:node | node isMessage and: [node receiver isBlock and: [node parent isCascade not and: [#(#value #value: #value:value: #value:value:value: #valueWithArguments:) includes: node selector]]]}' do: [ :node :answer | node ]! ! !RBExtraBlockRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:28'! category ^'Optimization'! ! !RBExtraBlockRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/12/2012 11:41'! longDescription ^'Check for blocks that are immediately evaluated. Since the block is immediately evaluated, there is no need for the statements to be in a block. For example, [:x | 1 + x] value: 4 is equivalent to 1 + 4'! ! !RBExtraBlockRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for blocks that are immediately evaluated. Since the block is immediately evaluated, there is no need for the statements to be in a block.'! ! !RBExtraBlockRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBExtraBlockRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:09'! severity ^ #information! ! !RBExtraBlockRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Block immediately evaluated'! ! !RBExtraBlockRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ExtraBlockRule'! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''! isParseTreeEquivalentTo: aSelector | tree definingClass | definingClass := class whoDefinesMethod: aSelector. tree := definingClass parseTreeFor: aSelector. tree isNil ifTrue: [^false]. tree isPrimitive ifTrue: [^false]. (tree body equalTo: extractedParseTree body exceptForVariables: (tree arguments collect: [:each | each name])) ifFalse: [^false]. (definingClass = class or: [(tree superMessages detect: [:each | (class superclass whichClassIncludesSelector: aSelector) ~= (definingClass superclass whichClassIncludesSelector: each)] ifNone: [nil]) isNil]) ifFalse: [^false]. ^self shouldUseExistingMethod: aSelector! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:10'! placeholderNode | node | node := RBParseTreeSearcher treeMatching: self methodDelimiter in: modifiedParseTree. node isNil ifTrue: [self refactoringFailure: 'Cannot extract code']. ^node! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! checkSelfReturns | searcher | searcher := RBParseTreeSearcher new. searcher matches: '^self' do: [:aNode :answer | answer]; matches: '^`@anything' do: [:aNode :answer | true]. (searcher executeTree: extractedParseTree initialAnswer: false) ifTrue: [self placeholderNode asReturn]! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/23/2009 11:00'! nameNewMethod: aSymbol | args newSend | args := parameters collect: [:parm | RBVariableNode named: parm]. extractedParseTree renameSelector: aSymbol andArguments: args asArray. aSymbol numArgs = 0 ifTrue: [modifiedParseTree := RBParseTreeRewriter replace: self methodDelimiter with: 'self ' , aSymbol asString in: modifiedParseTree. ^self]. newSend := WriteStream on: ''. aSymbol keywords with: parameters do: [:key :arg | newSend nextPutAll: key asString; nextPut: $ ; nextPutAll: arg asString; nextPut: $ ]. modifiedParseTree := RBParseTreeRewriter replace: self methodDelimiter with: 'self ' , newSend contents in: modifiedParseTree! ! !RBExtractMethodRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [self extractMethod. self checkSpecialExtractions. self checkReturn. needsReturn ifTrue: [extractedParseTree addReturn]. self checkTemporaries. true])! ! !RBExtractMethodRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' extract: '. extractionInterval storeOn: aStream. aStream nextPutAll: ' from: #'; nextPutAll: selector; nextPutAll: ' in: '. class storeOn: aStream. aStream nextPut: $)! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/1/2009 23:04'! transform | existingSelector | existingSelector := self existingSelector. self nameNewMethod: (existingSelector isNil ifTrue: [self getNewMethodName] ifFalse: [existingSelector]). existingSelector isNil ifTrue: [class compile: extractedParseTree newSource withAttributesFrom: (class methodFor: selector)]. class compileTree: modifiedParseTree! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:11'! getExtractedSource | source | source := class sourceCodeFor: selector. ((extractionInterval first between: 1 and: source size) and: [extractionInterval last between: 1 and: source size]) ifFalse: [self refactoringFailure: 'Invalid interval']. ^source copyFrom: extractionInterval first to: extractionInterval last! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''! checkAssignments: variableNames | node outsideVars removeAssigned | removeAssigned := variableNames copy. node := self placeholderNode. outsideVars := variableNames select: [:each | (node whoDefines: each) references: each]. outsideVars size == 1 ifTrue: [self checkSingleAssignment: outsideVars asArray first]. outsideVars size > 1 ifTrue: [self refactoringError: 'Cannot extract assignment without all references.']. removeAssigned removeAll: outsideVars. (RBReadBeforeWrittenTester readBeforeWritten: removeAssigned in: extractedParseTree) isEmpty ifFalse: [self refactoringError: 'Cannot extract assignment if read before written.']. removeAssigned do: [:each | (node whoDefines: each) removeTemporaryNamed: each]. self createTemporariesInExtractedMethodFor: variableNames! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:12'! checkSpecialExtractions | node | node := self placeholderNode parent. node isNil ifTrue: [^self]. (node isAssignment and: [node variable = self placeholderNode]) ifTrue: [self refactoringFailure: 'Cannot extract left hand side of an assignment']. node isCascade ifTrue: [self refactoringError: 'Cannot extract first message of a cascaded message']! ! !RBExtractMethodRefactoring methodsFor: 'initialize-release' stamp: ''! extract: anInterval from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. extractionInterval := anInterval! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''! methodDelimiter ^'#''place.holder.for.method'''! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: 'bh 5/10/2000 21:58'! existingSelector "Try to find an existing method instead of creating a new one" ^class allSelectors detect: [:each | self isMethodEquivalentTo: each] ifNone: [nil]! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:11'! extractMethod | parseTree isSequence extractCode subtree newCode | extractCode := self getExtractedSource. extractedParseTree := RBParser parseExpression: extractCode onError: [:string :pos | self refactoringError: 'Invalid source to extract - ', string]. extractedParseTree isNil ifTrue: [self refactoringError: 'Invalid source to extract']. (extractedParseTree isSequence and: [extractedParseTree statements isEmpty]) ifTrue: [self refactoringError: 'Select some code to extract']. isSequence := extractedParseTree isSequence or: [extractedParseTree isReturn]. extractedParseTree := RBMethodNode selector: #value arguments: #() body: (extractedParseTree isSequence ifTrue: [extractedParseTree] ifFalse: [RBSequenceNode temporaries: #() statements: (OrderedCollection with: extractedParseTree)]). extractedParseTree body temporaries isEmpty not ifTrue: [extractedParseTree body temporaries: #()]. extractedParseTree source: extractCode. parseTree := class parseTreeFor: selector. parseTree isNil ifTrue: [self refactoringFailure: 'Could not parse ' , selector printString]. subtree := isSequence ifTrue: [RBParseTreeSearcher treeMatchingStatements: extractedParseTree body formattedCode in: parseTree] ifFalse: [RBParseTreeSearcher treeMatching: extractCode in: parseTree]. subtree isNil ifTrue: [self refactoringFailure: 'Could not extract code from method']. newCode := self methodDelimiter. isSequence ifTrue: [| stmts | stmts := extractedParseTree body statements. stmts isEmpty ifFalse: [stmts last isAssignment ifTrue: [| name | name := stmts last variable name. (self shouldExtractAssignmentTo: name) ifFalse: [newCode := '<1s> := <2s>' expandMacrosWith: name with: newCode. stmts at: stmts size put: stmts last value]]]]. modifiedParseTree := isSequence ifTrue: [RBParseTreeRewriter replaceStatements: subtree formattedCode with: newCode in: parseTree onInterval: extractionInterval] ifFalse: [RBParseTreeRewriter replace: subtree formattedCode with: newCode in: parseTree onInterval: extractionInterval]! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''! createTemporariesInExtractedMethodFor: assigned assigned do: [:each | extractedParseTree body addTemporaryNamed: each]! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:10'! reorderParametersToMatch: aSelector | tree dictionary | tree := class parseTreeFor: aSelector. dictionary := Dictionary new. tree body equalTo: extractedParseTree body withMapping: dictionary. parameters := tree arguments collect: [:each | dictionary at: each name ifAbsent: [self refactoringFailure: 'An internal error occured, please report this error.']]! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:11'! getNewMethodName | newSelector methodName newMethodName | methodName := RBMethodName new. methodName arguments: parameters. [newMethodName := self requestMethodNameFor: methodName. newMethodName isNil ifTrue: [self refactoringFailure: 'Did not extract code']. newSelector := newMethodName selector. (self checkMethodName: newSelector in: class) ifFalse: [self refactoringWarning: newSelector , ' is not a valid selector name.'. newSelector := nil]. (class hierarchyDefinesMethod: newSelector asSymbol) ifTrue: [(self shouldOverride: newSelector in: class) ifFalse: [newSelector := nil]]. newSelector isNil] whileTrue: []. parameters := newMethodName arguments asOrderedCollection. ^newSelector asSymbol! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''! remainingTemporaries | temps | temps := modifiedParseTree allDefinedVariables asSet. extractedParseTree allDefinedVariables do: [:each | temps remove: each ifAbsent: []]. ^temps! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''! isMethodEquivalentTo: aSelector selector == aSelector ifTrue: [^false]. aSelector numArgs ~~ parameters size ifTrue: [^false]. (self isParseTreeEquivalentTo: aSelector) ifFalse: [^false]. self reorderParametersToMatch: aSelector. ^true! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! checkSingleAssignment: varName ((RBReadBeforeWrittenTester isVariable: varName readBeforeWrittenIn: extractedParseTree) or: [extractedParseTree containsReturn]) ifTrue: [self refactoringError: 'Cannot extract assignments to temporaries without all references']. extractedParseTree addNode: (RBReturnNode value: (RBVariableNode named: varName)). modifiedParseTree := RBParseTreeRewriter replace: self methodDelimiter with: varName , ' := ' , self methodDelimiter in: modifiedParseTree! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''! checkReturn needsReturn := self placeholderNode isUsed. extractedParseTree containsReturn ifFalse: [^self]. extractedParseTree lastIsReturn ifTrue: [^self]. (modifiedParseTree isLast: self placeholderNode) ifFalse: [self refactoringError: 'Couldn''t extract code since it contains a return.']. self checkSelfReturns! ! !RBExtractMethodRefactoring methodsFor: 'transforming' stamp: ''! checkTemporaries | temps accesses assigned | temps := self remainingTemporaries. accesses := temps select: [:each | extractedParseTree references: each]. assigned := accesses select: [:each | extractedParseTree assigns: each]. assigned isEmpty ifFalse: [self checkAssignments: assigned]. ^parameters := (accesses asOrderedCollection) removeAll: assigned; yourself! ! !RBExtractMethodRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk extract: anInterval from: aSelector in: aClass ^(self new) model: aRBSmalltalk; extract: anInterval from: aSelector in: aClass; yourself! ! !RBExtractMethodRefactoring class methodsFor: 'instance creation' stamp: ''! extract: anInterval from: aSelector in: aClass ^self new extract: anInterval from: aSelector in: aClass! ! !RBExtractMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadInterval self shouldFail: (RBExtractMethodRefactoring extract: (self convertInterval: (24 to: 30) for: (RBRefactoryTestDataApp sourceCodeAt: #testMethod)) from: #testMethod in: RBRefactoryTestDataApp); shouldFail: (RBExtractMethodRefactoring extract: (self convertInterval: (80 to: 147) for: (RBBasicLintRuleTest class sourceCodeAt: #subclassOf:overrides:)) from: #subclassOf:overrides: in: RBBasicLintRuleTest class)! ! !RBExtractMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testExtractMethodThatNeedsArgument | refactoring class | refactoring := RBExtractMethodRefactoring extract: (self convertInterval: (145 to: 343) for: (RBTransformationRuleTest sourceCodeAt: #checkMethod:)) from: #checkMethod: in: RBTransformationRuleTest. self setupMethodNameFor: refactoring toReturn: #foo:. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBTransformationRuleTest. self assert: (class parseTreeFor: #checkMethod:) = (RBParser parseMethod: 'checkMethod: aSmalllintContext class := aSmalllintContext selectedClass. (rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: [self foo: aSmalllintContext]'). self assert: (class parseTreeFor: #foo:) = (RBParser parseMethod: 'foo: aSmalllintContext (RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false) ifFalse: [builder compile: rewriteRule tree printString in: class classified: aSmalllintContext protocols]')! ! !RBExtractMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testExtractMethodAtEndOfMethodThatNeedsReturn | refactoring class | refactoring := RBExtractMethodRefactoring extract: (self convertInterval: (52 to: 133) for: (RBLintRuleTest sourceCodeAt: #openEditor)) from: #openEditor in: RBLintRuleTest. self setupMethodNameFor: refactoring toReturn: #foo:. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBLintRuleTest. self assert: (class parseTreeFor: #openEditor) = (RBParser parseMethod: 'openEditor | rules | rules := self failedRules. ^self foo: rules'). self assert: (class parseTreeFor: #foo:) = (RBParser parseMethod: 'foo: rules rules isEmpty ifTrue: [^self]. rules size == 1 ifTrue: [^rules first viewResults]')! ! !RBExtractMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantSelector self shouldFail: (RBExtractMethodRefactoring extract: (10 to: 20) from: #checkClass1: in: RBBasicLintRuleTest)! ! !RBExtractMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelExtractMethodWithTemporaryAssigned | class refactoring | model := RBNamespace new. class := model classNamed: self class name. class compile: 'foo | temp bar | bar := 5. temp := bar * bar. Transcript show: temp printString; cr. ^temp * temp' classified: #(#accessing). refactoring := RBExtractMethodRefactoring model: model extract: (26 to: 102) from: #foo in: class. self setupMethodNameFor: refactoring toReturn: #foobar. self executeRefactoring: refactoring. self assert: (class parseTreeFor: #foo) = (RBParser parseMethod: 'foo | temp | temp := self foobar. ^temp * temp'). self assert: ((class parseTreeFor: #foobar) = (RBParser parseMethod: 'foobar | bar temp | bar := 5. temp := bar * bar. Transcript show: temp printString; cr. ^temp.')) | ((class parseTreeFor: #foobar) = (RBParser parseMethod: 'foobar | temp bar | bar := 5. temp := bar * bar. Transcript show: temp printString; cr. ^temp.'))! ! !RBExtractMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testExtractFailure self shouldFail: (RBExtractMethodRefactoring extract: (self convertInterval: (80 to: 269) for: (RBBasicLintRuleTest class sourceCodeAt: #subclassOf:overrides:)) from: #subclassOf:overrides: in: RBBasicLintRuleTest class); shouldFail: (RBExtractMethodRefactoring extract: (self convertInterval: (53 to: 56) for: (RBBasicLintRuleTest class sourceCodeAt: #subclassOf:overrides:)) from: #subclassOf:overrides: in: RBBasicLintRuleTest class); shouldFail: (RBExtractMethodRefactoring extract: (self convertInterval: (77 to: 222) for: (RBBasicLintRuleTest class sourceCodeAt: #subclassResponsibilityNotDefined)) from: #subclassResponsibilityNotDefined in: RBBasicLintRuleTest class)! ! !RBExtractMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelExtractMethodWithTemporariesSelected | class refactoring | model := RBNamespace new. class := model classNamed: self class name. class compile: 'foo [| temp | temp := 5. temp * temp] value' classified: #(#accessing). refactoring := RBExtractMethodRefactoring model: model extract: (6 to: 36) from: #foo in: class. self setupMethodNameFor: refactoring toReturn: #foobar. self executeRefactoring: refactoring. self assert: (class parseTreeFor: #foo) = (RBParser parseMethod: 'foo [self foobar] value'). self assert: (class parseTreeFor: #foobar) = (RBParser parseMethod: 'foobar |temp | temp := 5. ^temp * temp')! ! !RBExtractMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testExtractMethodThatMovesTemporaryVariable | refactoring class | refactoring := RBExtractMethodRefactoring extract: (self convertInterval: (22 to: 280) for: (RBTransformationRuleTest sourceCodeAt: #superSends)) from: #superSends in: RBTransformationRuleTest. self setupMethodNameFor: refactoring toReturn: #foo. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBTransformationRuleTest. self assert: (class parseTreeFor: #superSends) = (RBParser parseMethod: 'superSends | rule | rule := self foo. self rewriteUsing: rule'). self assert: (class parseTreeFor: #foo) = (RBParser parseMethod: 'foo | rule | rule := RBParseTreeRewriter new. rule addSearch: ''super `@message: ``@args'' -> ( [:aNode | (class withAllSubclasses detect: [:each | each includesSelector: aNode selector] ifNone: [nil]) isNil] -> ''self `@message: ``@args''). ^rule')! ! !RBExtractMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testExtractMethodThatNeedsTemporaryVariable | refactoring class | refactoring := RBExtractMethodRefactoring extract: (self convertInterval: (78 to: 197) for: (RBLintRuleTest sourceCodeAt: #displayName)) from: #displayName in: RBLintRuleTest. self setupMethodNameFor: refactoring toReturn: #foo:. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBLintRuleTest. self assert: (class parseTreeFor: #displayName) = (RBParser parseMethod: 'displayName | nameStream | nameStream := WriteStream on: (String new: 64). self foo: nameStream. ^nameStream contents'). self assert: (class parseTreeFor: #foo:) = (RBParser parseMethod: 'foo: nameStream nameStream nextPutAll: self name; nextPutAll: '' (''. self problemCount printOn: nameStream. nameStream nextPut: $).')! ! !RBExtractMethodToComponentRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! inlineForwarder | refactoring | refactoring := RBInlineAllSendersRefactoring model: self model sendersOf: extractedMethodSelector in: class. refactoring setOption: #inlineExpression toUse: [:ref :string | true]. self performComponentRefactoring: refactoring! ! !RBExtractMethodToComponentRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! extractMethod | refactoring | refactoring := RBExtractMethodRefactoring model: self model extract: extractionInterval from: selector in: class. refactoring setOption: #methodName toUse: [:ref :methodName | extractedMethodSelector := ref uniqueMethodNameFor: methodName arguments size. methodName selector: extractedMethodSelector; yourself]. self performComponentRefactoring: refactoring! ! !RBExtractMethodToComponentRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^RBCondition empty! ! !RBExtractMethodToComponentRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' extract: '. extractionInterval storeOn: aStream. aStream nextPutAll: ' from: #'; nextPutAll: selector; nextPutAll: ' in: '. class storeOn: aStream. aStream nextPut: $)! ! !RBExtractMethodToComponentRefactoring methodsFor: 'transforming' stamp: ''! transform self extractMethod; moveMethod; inlineForwarder! ! !RBExtractMethodToComponentRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:10'! moveMethod | variable refactoring | variable := self selectVariableToMoveMethodTo: extractedMethodSelector class: class. variable isNil ifTrue: [self refactoringFailure: 'Did not extract method']. refactoring := RBMoveMethodRefactoring model: self model selector: extractedMethodSelector class: class variable: variable. self performComponentRefactoring: refactoring! ! !RBExtractMethodToComponentRefactoring methodsFor: 'initialize-release' stamp: ''! extract: anInterval from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. extractionInterval := anInterval! ! !RBExtractMethodToComponentRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk extract: anInterval from: aSelector in: aClass ^(self new) model: aRBSmalltalk; extract: anInterval from: aSelector in: aClass; yourself! ! !RBExtractMethodToComponentRefactoring class methodsFor: 'instance creation' stamp: ''! extract: anInterval from: aSelector in: aClass ^self new extract: anInterval from: aSelector in: aClass! ! !RBExtractMethodToComponentTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testExtractFailure self shouldFail: (RBExtractMethodToComponentRefactoring extract: (self convertInterval: (80 to: 269) for: (RBBasicLintRuleTest class sourceCodeAt: #subclassOf:overrides:)) from: #subclassOf:overrides: in: RBBasicLintRuleTest class); shouldFail: (RBExtractMethodToComponentRefactoring extract: (self convertInterval: (53 to: 56) for: (RBBasicLintRuleTest class sourceCodeAt: #subclassOf:overrides:)) from: #subclassOf:overrides: in: RBBasicLintRuleTest class); shouldFail: (RBExtractMethodToComponentRefactoring extract: (self convertInterval: (77 to: 222) for: (RBBasicLintRuleTest class sourceCodeAt: #subclassResponsibilityNotDefined)) from: #subclassResponsibilityNotDefined in: RBBasicLintRuleTest class)! ! !RBExtractMethodToComponentTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadInterval self shouldFail: (RBExtractMethodToComponentRefactoring extract: (self convertInterval: (24 to: 30) for: (RBRefactoryTestDataApp sourceCodeAt: #testMethod)) from: #testMethod in: RBRefactoryTestDataApp); shouldFail: (RBExtractMethodToComponentRefactoring extract: (self convertInterval: (80 to: 147) for: (RBBasicLintRuleTest class sourceCodeAt: #subclassOf:overrides:)) from: #subclassOf:overrides: in: RBBasicLintRuleTest class)! ! !RBExtractMethodToComponentTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testExtractMethodAtEndOfMethodThatNeedsReturn | refactoring class selectorsSize | refactoring := RBExtractMethodToComponentRefactoring extract: (self convertInterval: (52 to: 133) for: (RBLintRuleTest sourceCodeAt: #openEditor)) from: #openEditor in: RBLintRuleTest. self setupMethodNameFor: refactoring toReturn: #foo:. self setupSelfArgumentNameFor: refactoring toReturn: 'asdf'. self setupVariableToMoveToFor: refactoring toReturn: 'rules'. self setupVariableTypesFor: refactoring toReturn: (Array with: (refactoring model classNamed: #Collection)). class := refactoring model classNamed: #RBLintRuleTest. selectorsSize := class selectors size. self proceedThroughWarning: [ self executeRefactoring: refactoring ]. self assert: (class parseTreeFor: #openEditor) = (RBParser parseMethod: 'openEditor | rules | rules := self failedRules. ^rules foo: self'). self assert: ((refactoring model classNamed: #Collection) parseTreeFor: #foo:) = (RBParser parseMethod: 'foo: asdf self isEmpty ifTrue: [^asdf]. self size == 1 ifTrue: [^self first viewResults]. ^asdf'). self assert: class selectors size = selectorsSize! ! !RBExtractMethodToComponentTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testMoveWithoutSelfReference | refactoring class selectorsSize | refactoring := RBExtractMethodToComponentRefactoring extract: (self convertInterval: (118 to: 286) for: (RBReadBeforeWrittenTester sourceCodeAt: #copyDictionary:)) from: #copyDictionary: in: RBReadBeforeWrittenTester. self setupMethodNameFor: refactoring toReturn: #copyWithAssociations. self setupVariableToMoveToFor: refactoring toReturn: 'aDictionary'. self setupVariableTypesFor: refactoring toReturn: (Array with: (refactoring model classNamed: #Dictionary)). class := refactoring model classNamed: #RBReadBeforeWrittenTester. selectorsSize := class selectors size. self executeRefactoring: refactoring. self assert: (class parseTreeFor: #copyDictionary:) = (RBParser parseMethod: 'copyDictionary: aDictionary ^aDictionary copyWithAssociations'). self assert: ((refactoring model classNamed: #Dictionary) parseTreeFor: #copyWithAssociations) = (RBParser parseMethod: 'copyWithAssociations | newDictionary | newDictionary := Dictionary new: self size. self keysAndValuesDo: [:key :value | newDictionary at: key put: value]. ^newDictionary'). self assert: class selectors size = selectorsSize! ! !RBExtractMethodToComponentTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantSelector self shouldFail: (RBExtractMethodToComponentRefactoring extract: (10 to: 20) from: #checkClass1: in: RBBasicLintRuleTest)! ! !RBExtractToTemporaryRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:10'! verifySelectedInterval | selectedParseTree selectedSources | selectedSources := self selectedSource. selectedParseTree := RBParser parseExpression: selectedSources onError: [:message :position | self refactoringFailure: 'Invalid selection']. selectedParseTree isSequence ifTrue: [self refactoringFailure: 'Cannot assign temp to multiple statements']! ! !RBExtractToTemporaryRefactoring methodsFor: 'initialize-release' stamp: ''! extract: anInterval to: aString from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. sourceInterval := anInterval. newVariableName := aString! ! !RBExtractToTemporaryRefactoring methodsFor: 'private-accessing' stamp: 'CamilloBruni 10/7/2012 23:59'! parseTree parseTree isNil ifTrue: [parseTree := class parseTreeFor: selector. parseTree isNil ifTrue: [self refactoringFailure: 'Could not parse method']]. ^parseTree! ! !RBExtractToTemporaryRefactoring methodsFor: 'transforming' stamp: ''! compileNewMethod class compileTree: self parseTree! ! !RBExtractToTemporaryRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition definesSelector: selector in: class) & (RBCondition isValidInstanceVariableName: newVariableName for: class) & (RBCondition withBlock: [self verifySelectedInterval. self checkVariableName. true])! ! !RBExtractToTemporaryRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' extract: '. sourceInterval storeOn: aStream. aStream nextPutAll: ' to: '''; nextPutAll: newVariableName; nextPutAll: ''' from: #'; nextPutAll: selector; nextPutAll: ' in: '. class storeOn: aStream. aStream nextPut: $)! ! !RBExtractToTemporaryRefactoring methodsFor: 'transforming' stamp: ''! transform self insertTemporary; compileNewMethod! ! !RBExtractToTemporaryRefactoring methodsFor: 'private-accessing' stamp: 'CamilloBruni 10/8/2012 00:10'! selectedSource | source | source := class sourceCodeFor: selector. source isNil ifTrue: [self refactoringFailure: 'Couldn''t find sources']. ((sourceInterval first between: 1 and: source size) and: [sourceInterval last between: 1 and: source size]) ifFalse: [self refactoringFailure: 'Invalid interval']. ^source copyFrom: sourceInterval first to: sourceInterval last! ! !RBExtractToTemporaryRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:10'! insertTemporary | node statementNode | node := self parseTree whichNodeIsContainedBy: sourceInterval. (node notNil and: [node isValue]) ifFalse: [self refactoringFailure: 'Cannot assign to non-value nodes']. statementNode := node statementNode. node replaceWith: (RBVariableNode named: newVariableName). (statementNode parent) addNode: (self constructAssignmentFrom: node) before: (node == statementNode ifTrue: [RBVariableNode named: newVariableName] ifFalse: [statementNode]); addTemporaryNamed: newVariableName! ! !RBExtractToTemporaryRefactoring methodsFor: 'transforming' stamp: ''! constructAssignmentFrom: aNode | valueNode | valueNode := RBVariableNode named: newVariableName. ^RBAssignmentNode variable: valueNode value: aNode! ! !RBExtractToTemporaryRefactoring methodsFor: 'preconditions' stamp: ''! checkVariableName (class whoDefinesInstanceVariable: newVariableName) notNil ifTrue: [self refactoringError: ('<1p> defines an instance variable named <2s>' expandMacrosWith: class with: newVariableName)]. (class whoDefinesClassVariable: newVariableName) notNil ifTrue: [self refactoringError: ('<1p> defines a class variabled named <2s>' expandMacrosWith: class with: newVariableName)]. (self parseTree allDefinedVariables includes: newVariableName) ifTrue: [self refactoringError: ('<1s> is already a temporary variable name' expandMacrosWith: newVariableName)]! ! !RBExtractToTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk extract: anInterval to: aString from: aSelector in: aClass ^(self new) model: aRBSmalltalk; extract: anInterval to: aString from: aSelector in: aClass; yourself! ! !RBExtractToTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''! extract: anInterval to: aString from: aSelector in: aClass ^self new extract: anInterval to: aString from: aSelector in: aClass! ! !RBExtractToTemporaryTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadName self shouldFail: (RBExtractToTemporaryRefactoring extract: (self convertInterval: (14 to: 23) for: (RBRefactoryTestDataApp sourceCodeAt: #testMethod)) to: 'a sdf' from: #testMethod in: RBRefactoryTestDataApp)! ! !RBExtractToTemporaryTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testExtractToTemporaryInsideBlock | refactoring | refactoring := RBExtractToTemporaryRefactoring extract: (self convertInterval: (133 to: 141) for: (RBRefactoryTestDataApp sourceCodeAt: #noMoveDefinition)) to: 'asdf' from: #noMoveDefinition in: RBRefactoryTestDataApp. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #noMoveDefinition) = (RBParser parseMethod: 'noMoveDefinition | temp | ^(self collect: [:each | temp := each printString. temp , temp]) select: [:each | | asdf | asdf := each size. temp := asdf + temp]')! ! !RBExtractToTemporaryTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadInterval self shouldFail: (RBExtractToTemporaryRefactoring extract: (self convertInterval: (24 to: 30) for: (RBRefactoryTestDataApp sourceCodeAt: #testMethod)) to: 'asdf' from: #testMethod in: RBRefactoryTestDataApp); shouldFail: (RBExtractToTemporaryRefactoring extract: (self convertInterval: (14 to: 105) for: (RBRefactoryTestDataApp sourceCodeAt: #testMethod1)) to: 'asdf' from: #testMethod1 in: RBRefactoryTestDataApp); shouldFail: (RBExtractToTemporaryRefactoring extract: (self convertInterval: (61 to: 101) for: (RBRefactoryTestDataApp sourceCodeAt: #noMoveDefinition)) to: 'asdf' from: #noMoveDefinition in: RBRefactoryTestDataApp)! ! !RBExtractToTemporaryTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testExtractToTemporaryForLastStatementInBlock | refactoring | refactoring := RBExtractToTemporaryRefactoring extract: (self convertInterval: (52 to: 73) for: (RBRefactoryTestDataApp sourceCodeAt: #caller2)) to: 'temp' from: #caller2 in: RBRefactoryTestDataApp. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #caller2) = (RBParser parseMethod: 'caller2 ^(1 to: 10) inject: 1 into: [:sum :each | | temp | temp := sum * (self foo: each). temp]')! ! !RBExtractToTemporaryTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantSelector self shouldFail: (RBExtractToTemporaryRefactoring extract: (14 to: 23) to: 'asdf' from: #checkClass1: in: RBRefactoryTestDataApp)! ! !RBFileBlocksRule methodsFor: 'initialization' stamp: 'lr 11/19/2009 14:46'! initialize super initialize. self matcher matchesAnyOf: #( '[| `@temps | `var := `@object. `@.statements] ensure: [`var `@messages: `@args]' '[| `@temps | `var := `@object. `@.statements] ifCurtailed: [`var `@messages: `@args]' ) do: [ :node :answer | node ]! ! !RBFileBlocksRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks assignment to a variable that is the first statement inside the value block that is also used in the unwind block.'! ! !RBFileBlocksRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBFileBlocksRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Assignment inside unwind blocks should be outside.'! ! !RBFileBlocksRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:29'! category ^'Potential Bugs'! ! !RBFileBlocksRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'FileBlocksRule'! ! !RBFloatEqualityComparisonRule methodsFor: 'initialization' stamp: 'MarcusDenker 9/20/2013 15:38'! initialize super initialize. self matcher matchesAnyOf: #( '`{ :node | node isLiteralNode and: [ node value isFloat ] } = `@expr' '`{ :node | node isLiteralNode and: [ node value isFloat ] } ~= `@expr' '`@expr = `{ :node | node isLiteralNode and: [ node value isFloat ] }' '`@expr ~= `{ :node | node isLiteralNode and: [ node value isFloat ] }' ) do: [ :node :answer | node ]! ! !RBFloatEqualityComparisonRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 14:03'! rationale ^ 'Floating point types are imprecise. Using the operators = or ~= might not yield the expected result due to internal rounding differences.'! ! !RBFloatEqualityComparisonRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 13:57'! group ^ 'Possible bugs'! ! !RBFloatEqualityComparisonRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 13:58'! name ^ 'Float equality comparison'! ! !RBFloatEqualityComparisonRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 13:58'! category ^ 'Potential Bugs'! ! !RBFloatEqualityComparisonRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'FloatEqualityComparisonRule'! ! !RBFormatterTests commentStamp: 'TorstenBergmann 2/4/2014 21:53'! SUnit tests for RBFormatter! !RBFormatterTests methodsFor: 'testing' stamp: 'lr 9/4/2010 16:55'! testCoreSystem #(Object Behavior Boolean True False Integer SmallInteger Collection String) do: [ :each | | class | class := Smalltalk globals classNamed: each. self formatClass: class; formatClass: class class ]! ! !RBFormatterTests methodsFor: 'private' stamp: 'lr 9/4/2010 16:56'! formatClass: aClass aClass selectors do: [ :each | self formatClass: aClass selector: each ]! ! !RBFormatterTests methodsFor: 'private' stamp: 'MarcusDenker 4/20/2013 03:19'! formatClass: aClass selector: aSymbol | source tree1 tree2 | source := aClass sourceCodeAt: aSymbol. tree1 := RBParser parseMethod: source. tree2 := RBParser parseMethod: (RBConfigurableFormatter new format: tree1) onError: [ :err :pos | self assert: false ]. self assert: tree1 = tree2! ! !RBGenerateEqualHashRefactoring methodsFor: 'accessing' stamp: ''! variables: anArray variables := anArray! ! !RBGenerateEqualHashRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^ variables inject: RBCondition empty into: [ :condition :variable | condition & (RBCondition definesInstanceVariable: variable in: self theClass) ]! ! !RBGenerateEqualHashRefactoring methodsFor: 'transforming' stamp: ''! compileHash | method statement hash | method := RBParser parseMethod: 'hash "Answer an integer value that is related to the identity of the receiver."'. statement := nil. variables reversed do: [ :each | hash := RBMessageNode receiver: (RBVariableNode named: each) selector: #hash. statement := statement isNil ifTrue: [ hash ] ifFalse: [ RBMessageNode receiver: hash selector: #bitXor: arguments: (Array with: statement) ] ]. method addNode: statement; addReturn. self theClass compile: method formattedCode classified: #(comparing)! ! !RBGenerateEqualHashRefactoring methodsFor: 'transforming' stamp: 'BenjaminVanRyseghem 4/25/2012 18:02'! accessorForVariable: aString | refactoring | refactoring := RBCreateAccessorsForVariableRefactoring model: self model variable: aString class: self theClass classVariable: false. refactoring createGetterAccessor. ^ refactoring getterMethod! ! !RBGenerateEqualHashRefactoring methodsFor: 'transforming' stamp: ''! transform self compileHash. self compileEqual! ! !RBGenerateEqualHashRefactoring methodsFor: 'transforming' stamp: ''! compileEqual | method statement comparison | method := RBParser parseMethod: '= anObject "Answer whether the receiver and anObject represent the same object." self == anObject ifTrue: [ ^ true ]. self class = anObject class ifFalse: [ ^ false ]'. statement := nil. variables reversed do: [ :each | | accessor | accessor := self accessorForVariable: each. comparison := RBMessageNode receiver: (RBVariableNode named: each) selector: #= arguments: (Array with: (RBMessageNode receiver: (RBVariableNode named: 'anObject') selector: accessor)). statement := statement isNil ifTrue: [ comparison ] ifFalse: [ RBMessageNode receiver: comparison selector: #and: arguments: (Array with: (RBBlockNode body: (RBSequenceNode statements: (Array with: statement)))) ] ]. method addNode: statement; addReturn. self theClass compile: method formattedCode classified: #(comparing)! ! !RBGenerateEqualHashRefactoring methodsFor: 'accessing' stamp: ''! theClass ^ (self classObjectFor: className) theNonMetaClass! ! !RBGenerateEqualHashRefactoring class methodsFor: 'instance-creation' stamp: ''! model: aNamespace className: aClass variables: anArray ^ (self model: aNamespace className: aClass) variables: anArray! ! !RBGenerateEqualHashRefactoring class methodsFor: 'instance-creation' stamp: ''! className: aClass variables: anArray ^ (self className: aClass) variables: anArray! ! !RBGeneratePrintStringRefactoring methodsFor: 'transforming' stamp: ''! transform | method | method := RBParser parseMethod: 'printOn: aStream "Append a sequence of characters to aStream that identify the receiver." super printOn: aStream'. variables do: [ :each | method body addNode: (RBParser parseExpression: ('aStream nextPutAll: '' <1s>: ''; print: <1s>' expandMacrosWith: each)) ]. self theClass compile: method formattedCode classified: #(printing)! ! !RBGeneratePrintStringRefactoring methodsFor: 'accessing' stamp: ''! variables: anArray variables := anArray! ! !RBGeneratePrintStringRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^ variables inject: RBCondition empty into: [ :condition :variable | condition & (RBCondition definesInstanceVariable: variable in: self theClass) ]! ! !RBGeneratePrintStringRefactoring methodsFor: 'accessing' stamp: ''! theClass ^ (self classObjectFor: className) theNonMetaClass! ! !RBGeneratePrintStringRefactoring class methodsFor: 'instance-creation' stamp: ''! model: aNamespace className: aClass variables: anArray ^ (self model: aNamespace className: aClass) variables: anArray! ! !RBGeneratePrintStringRefactoring class methodsFor: 'instance-creation' stamp: ''! className: aClass variables: anArray ^ (self className: aClass) variables: anArray! ! !RBGuardClauseRule commentStamp: ''! See rationale! !RBGuardClauseRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:33'! initialize super initialize. self rewriteRule replaceMethod: '`@methodName: `@args | `@temps | `@.Statements. `@condition ifTrue: [| `@trueTemps | `.Statement1. `.Statement2. `@.Statements1]' with: '`@methodName: `@args | `@temps `@trueTemps | `@.Statements. `@condition ifFalse: [^self]. `.Statement1. `.Statement2. `@.Statements1'; replaceMethod: '`@methodName: `@args | `@temps | `@.Statements. `@condition ifFalse: [| `@falseTemps | `.Statement1. `.Statement2. `@.Statements1]' with: '`@methodName: `@args | `@temps `@falseTemps | `@.Statements. `@condition ifTrue: [^self]. `.Statement1. `.Statement2. `@.Statements1'! ! !RBGuardClauseRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBGuardClauseRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Eliminate guarding clauses'! ! !RBGuardClauseRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:50'! category ^ 'Coding Idiom Violation'! ! !RBGuardClauseRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'GuardClauseRule'! ! !RBGuardingClauseRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:28'! initialize super initialize. self matcher matchesAnyMethodOf: #( '`@MethodName: `@args | `@temps | `@.Statements. `@condition ifTrue: [| `@BlockTemps | `.Statement1. `.Statement2. `@.BStatements]' '`@MethodName: `@args | `@temps | `@.Statements. `@condition ifFalse: [| `@BlockTemps | `.Statement1. `.Statement2. `@.BStatements]' ) do: [ :node :answer | answer isNil ifTrue: [ node body statements last ] ifFalse: [ answer ] ]! ! !RBGuardingClauseRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for ifTrue: or ifFalse: conditions at end of methods that have two or more statements inside their blocks. Such code might better represent the true meaning of the code if they returned self instead.'! ! !RBGuardingClauseRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBGuardingClauseRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Guarding clauses'! ! !RBGuardingClauseRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:31'! category ^ 'Coding Idiom Violation'! ! !RBGuardingClauseRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'GuardingClauseRule'! ! !RBIdentifierToken commentStamp: 'md 8/9/2005 14:51'! RBIdentifierToken is the first class representation of an identifier token (e.g. Class) ! !RBIdentifierToken methodsFor: 'testing' stamp: ''! isIdentifier ^true! ! !RBIdentifierToken methodsFor: 'testing' stamp: 'lr 11/7/2009 15:30'! isPatternVariable ^value first = RBScanner patternVariableCharacter! ! !RBIfTrueBlocksRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:28'! initialize super initialize. self matcher matchesAnyOf: #( '`@condition ifTrue: `{:node | node isBlock not} ifFalse: `@block' '`@condition ifTrue: `@block ifFalse: `{:node | node isBlock not}' '`@condition ifFalse: `{:node | node isBlock not} ifTrue: `@block' '`@condition ifFalse: `@block ifTrue: `{:node | node isBlock not}' '`@condition ifTrue: `{:node | node isBlock not}' '`@condition ifFalse: `{:node | node isBlock not}' '`@condition and: `{:node | node isBlock not}' '`@condition or: `{:node | node isBlock not}' '`{:node | node isBlock not} whileTrue' '`{:node | node isBlock not} whileFalse' '`{:node | node isBlock not} whileTrue: `@block' '`@block whileTrue: `{:node | node isBlock not}' '`{:node | node isBlock not} whileFalse: `@block' '`@block whileFalse: `{:node | node isBlock not}' '`@from to: `@to do: `{:node | node isBlock not}' '`@from to: `@to by: `@by do: `{:node | node isBlock not}' '`@condition ifNil: `{:node | node isBlock not}' '`@condition ifNotNil: `{:node | node isBlock not}' '`@condition ifNil: `{:node | node isBlock not} ifNotNil: `@block' '`@condition ifNil: `@block ifNotNil: `{:node | node isBlock not}' '`@condition ifNotNil: `{:node | node isBlock not} ifNil: `@block' '`@condition ifNotNil: `@block ifNil: `{:node | node isBlock not}' ) do: [ :node :answer | node ]! ! !RBIfTrueBlocksRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for methods that don''t use blocks in the special messages. People new to Smalltalk might write code such as: "aBoolean ifTrue: (self doSomething)" instead of the correct version: "aBoolean ifTrue: [self doSomething]". Even if these pieces of code could be correct, they cannot be optimized by the compiler.'! ! !RBIfTrueBlocksRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBIfTrueBlocksRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Non-blocks in special messages'! ! !RBIfTrueBlocksRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:34'! category ^ 'Optimization'! ! !RBIfTrueBlocksRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'IfTrueBlocksRule'! ! !RBIfTrueReturnsRule methodsFor: 'initialization' stamp: 'MarcusDenker 9/20/2013 15:08'! initialize super initialize. self matcher matchesAnyOf: #( '| `@temps | ``@.Statements. ``@object ifTrue: [^``@value1]. ^``@value2' '| `@temps | ``@.Statements. ``@object ifFalse: [^``@value1]. ^``@value2' ) do: [ :node :answer | answer isNil ifTrue: [ | condition | condition := (node statements at: node statements size - 1) arguments first body statements last value. "``@value1" ((condition isLiteralNode and: [ #(true false) includes: condition value ]) or: [ condition := node statements last value. condition isLiteralNode and: [ #(true false) includes: condition value ] ]) ifTrue: [ node ] ifFalse: [ nil ] ] ifFalse: [ answer ] ]! ! !RBIfTrueReturnsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for common ifTrue: returns that could be simplified using a boolean expression.'! ! !RBIfTrueReturnsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBIfTrueReturnsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'ifTrue:/ifFalse: returns instead of and:/or:''s'! ! !RBIfTrueReturnsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:21'! category ^ 'Optimization'! ! !RBIfTrueReturnsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'IfTrueReturnsRule'! ! !RBImplementedNotSentRule commentStamp: ''! See my #rationale. This rule pays attention not to flag methods with pragmas and test methods which are likely to be sent through reflection. Now if your code is used and extended by others, better use a deprecation mechanism, following the pattern: foo self deprecated: ''Use bar instead ''. ^ self bar! !RBImplementedNotSentRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:13'! category ^ 'Design Flaws'! ! !RBImplementedNotSentRule methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 12/30/2012 20:38'! longDescription ^ 'This smell arises when a method is implemented but never sent. If a method is not sent, it can be removed. This rule pays attention not to identify as unsent methods, methods with pragmas and test methods since they are likely to be sent through reflection. Now if your code is used and extended by others better use a deprecation mechanism. To define a deprecate method follow the pattern: foo self deprecated: ''Use bar instead ''. ^ self bar '! ! !RBImplementedNotSentRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for methods that are never sent. If a method is not sent, it can be removed.'! ! !RBImplementedNotSentRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBImplementedNotSentRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:02'! severity ^ #information! ! !RBImplementedNotSentRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Methods implemented but not sent'! ! !RBImplementedNotSentRule methodsFor: 'running' stamp: 'lr 3/7/2011 21:52'! checkMethod: aContext "Check if there are any senders. Furthermore methods with pragmas are likely to be sent through reflection, thus do not report those. Also test methods are sent through reflection, so ignore those as well." (aContext uses: aContext selector) ifTrue: [ ^ self ]. (aContext compiledMethod pragmas isEmpty) ifFalse: [ ^ self ]. (aContext selectedClass isMeta not and: [ aContext includesBehaviorNamed: #TestCase ]) ifTrue: [ ^ self ]. result addClass: aContext selectedClass selector: aContext selector! ! !RBImplementedNotSentRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ImplementedNotSentRule'! ! !RBInconsistentMethodClassificationRule commentStamp: ''! See my #rationale. Extension methods: Superclass extenstion methods are ignored, since they may have a different protocol name. Pay attention when you apply automatic recategorization because it may move the subclass's method in another package.! !RBInconsistentMethodClassificationRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:15'! resultClass ^ RBMultiEnvironment! ! !RBInconsistentMethodClassificationRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:14'! category ^ 'Design Flaws'! ! !RBInconsistentMethodClassificationRule methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 12/30/2012 20:40'! longDescription ^ 'This smell arises when a method protocol is not equivalent to the one defined in the superclass of such method class. All methods should be put into a protocol (method category) that is equivalent to the one of the superclass, which is a standart style in Smalltalk. Furthermore, methods which are extended in the superclass are ignored, since they may have different protocol name. Pay attention when you apply automatic recategorisation because it may move method in antoher package if the method is defined in the superclass as an extension.'! ! !RBInconsistentMethodClassificationRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 08:57'! rationale ^ 'All methods should be put into a protocol (method category) that is equivalent to the one of the superclass, which is a Smalltalk style convention.'! ! !RBInconsistentMethodClassificationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBInconsistentMethodClassificationRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:02'! severity ^ #information! ! !RBInconsistentMethodClassificationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Inconsistent method classification'! ! !RBInconsistentMethodClassificationRule methodsFor: 'running' stamp: 'lr 3/13/2009 11:41'! checkMethod: aContext | superClass superProtocol ownerProtocol | aContext selectedClass superclass isNil ifFalse: [ superClass := aContext selectedClass superclass whichClassIncludesSelector: aContext selector. superClass isNil ifFalse: [ superProtocol := superClass whichCategoryIncludesSelector: aContext selector. ownerProtocol := aContext selectedClass whichCategoryIncludesSelector: aContext selector. (superProtocol isNil or: [ superProtocol isEmpty or: [ superProtocol first = $* or: [ ownerProtocol isNil or: [ ownerProtocol isEmpty or: [ ownerProtocol first = $* ] ] ] ] ]) ifFalse: [ superProtocol = ownerProtocol ifFalse: [ result addClass: superClass selector: aContext selector into: superProtocol; addClass: aContext selectedClass selector: aContext selector into: superProtocol ] ] ] ]! ! !RBInconsistentMethodClassificationRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'InconsistentMethodClassificationRule'! ! !RBInlineAllMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineMethodWithMultipleSendersInMethod | refactoring | refactoring := RBInlineAllSendersRefactoring sendersOf: #caller2 in: RBRefactoryTestDataApp. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineLast) = (RBParser parseMethod: 'inlineLast 5 = 3 ifTrue: [^self caller] ifFalse: [^(1 to: 10) inject: 1 into: [:sum :each | sum * (self foo: each)]] '). self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #multipleCalls) = (RBParser parseMethod: 'multipleCalls (1 to: 10) inject: 1 into: [:sum :each | sum * (self foo: each)]. (1 to: 10) inject: 1 into: [:sum1 :each1 | sum1 * (self foo: each1)]')! ! !RBInlineAllMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRecursiveMethod | class | model := RBNamespace new. class := model classNamed: self class name. class compile: 'foo ^self foo' classified: #(#accessing); compile: 'bar ^self foo' classified: #(#accessing). self executeRefactoring: (RBInlineAllSendersRefactoring model: model sendersOf: #foo in: class). self assert: (class parseTreeFor: #foo) = (RBParser parseMethod: 'foo ^self foo'). self assert: (class parseTreeFor: #bar) = (RBParser parseMethod: 'bar ^self foo')! ! !RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''! inlineSelfSends class withAllSubclasses do: [:each | | selectors | selectors := each selectors. selectors remove: selector ifAbsent: []. selectors do: [:sel | self inlineMessagesInClass: each andSelector: sel]]! ! !RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! removeMethod self onError: [self performComponentRefactoring: (RBRemoveMethodRefactoring model: self model removeMethods: (Array with: selector) from: class)] do: []! ! !RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! selfSendIn: aTree | searcher | searcher := RBParseTreeSearcher new. searcher matches: self messagePattern do: [:aNode :answer | ^aNode]. ^searcher executeTree: aTree initialAnswer: nil! ! !RBInlineAllSendersRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^RBCondition canUnderstand: selector in: class! ! !RBInlineAllSendersRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' sendersOf: #'; nextPutAll: selector; nextPutAll: ' in: '. class storeOn: aStream. aStream nextPut: $)! ! !RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! numberOfSelfSendsIn: aParseTree | search | search := RBParseTreeSearcher new. search matches: self messagePattern do: [:aNode :answer | answer + 1]. ^search executeTree: aParseTree initialAnswer: 0! ! !RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''! transform self inlineSelfSends; removeMethod; checkInlinedMethods! ! !RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:10'! checkInlinedMethods numberReplaced = 0 ifTrue: [self refactoringFailure: 'Could not inline any senders']! ! !RBInlineAllSendersRefactoring methodsFor: 'initialize-release' stamp: ''! sendersOf: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. numberReplaced := numberNotReplaced := 0! ! !RBInlineAllSendersRefactoring methodsFor: 'accessing' stamp: ''! messagesNotReplaced ^numberNotReplaced! ! !RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! inlineMessagesInClass: aClass andSelector: aSelector | messagesToInline previousCountOfMessages | previousCountOfMessages := 4294967295. "Some really large number > # of initial self sends." [messagesToInline := self numberOfSelfSendsIn: (aClass parseTreeFor: aSelector). messagesToInline > 0 and: [previousCountOfMessages > messagesToInline]] whileTrue: [| node | previousCountOfMessages := messagesToInline. node := self selfSendIn: (aClass parseTreeFor: aSelector). self onError: [self performComponentRefactoring: (RBInlineMethodRefactoring model: self model inline: node sourceInterval inMethod: aSelector forClass: aClass). numberReplaced := numberReplaced + 1] do: []]. numberNotReplaced := numberNotReplaced + messagesToInline! ! !RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: ''! messagePattern ^'self ' , (self buildSelectorString: selector)! ! !RBInlineAllSendersRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk sendersOf: aSelector in: aClass ^(self new) model: aRBSmalltalk; sendersOf: aSelector in: aClass; yourself! ! !RBInlineAllSendersRefactoring class methodsFor: 'instance creation' stamp: ''! sendersOf: aSelector in: aClass ^self new sendersOf: aSelector in: aClass! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''! addArgumentToSelector: aSymbol ^aSymbol isInfix ifTrue: [#value:value:] ifFalse: [(aSymbol , 'value:') asSymbol]! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: 'lr 11/23/2009 11:02'! addSelfReferenceToSourceMessage | newArguments | newArguments := sourceMessage arguments asOrderedCollection. newArguments addFirst: sourceMessage receiver copy. sourceMessage renameSelector: (self addArgumentToSelector: sourceMessage selector) andArguments: newArguments! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'testing' stamp: 'CamilloBruni 9/13/2012 14:21'! isOverridden | selector| selector := self inlineSelector. self inlineClass allSubclassesDo: [:each | (each directlyDefinesMethod: selector) ifTrue: [ ^ true ]]. ^ false! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:08'! findSelectedMessage sourceParseTree := class parseTreeFor: sourceSelector. sourceParseTree isNil ifTrue: [self refactoringFailure: 'Could not parse sources']. sourceMessage := sourceParseTree whichNodeIsContainedBy: sourceInterval. sourceMessage isNil ifTrue: [self refactoringFailure: 'The selection doesn''t appear to be a message send']. sourceMessage isCascade ifTrue: [sourceMessage := sourceMessage messages last]. sourceMessage isMessage ifFalse: [self refactoringFailure: 'The selection doesn''t appear to be a message send']! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:08'! inlineClass | imps | inlineClass notNil ifTrue: [^inlineClass]. imps := (self model allImplementorsOf: self inlineSelector) asOrderedCollection. imps size = 1 ifTrue: [^inlineClass := imps first]. imps isEmpty ifTrue: [self refactoringFailure: 'Nobody defines a method named ' , self inlineSelector]. inlineClass := self requestImplementorToInline: imps. inlineClass isNil ifTrue: [self refactoringFailure: 'No implementor selected']. ^inlineClass! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: 'lr 10/26/2009 22:08'! newNameForSelf | variableName index originalName nonMetaClass | nonMetaClass := inlineClass theNonMetaClass. variableName := originalName := (nonMetaClass name first isVowel ifTrue: [ 'an' ] ifFalse: [ 'a' ]) , nonMetaClass name. index := 1. [ variableName := self safeVariableNameBasedOn: variableName. inlineParseTree allDefinedVariables includes: variableName ] whileTrue: [ variableName := originalName , index printString. index := index + 1 ]. ^ variableName! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''! safeVariableNameBasedOn: aString "Creates an unused variable name containing aString" | baseString newString i allTempVars | allTempVars := inlineParseTree allTemporaryVariables. baseString := aString copy. baseString at: 1 put: baseString first asLowercase. newString := baseString. i := 0. [(allTempVars includes: newString) or: [class definesInstanceVariable: newString]] whileTrue: [i := i + 1. newString := baseString , i printString]. ^newString! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''! transform self abstractVariableReferences. self renameSelfReferences. super transform! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''! checkSuperMessages inlineParseTree superMessages isEmpty ifFalse: [self refactoringError: 'Cannot inline method since it sends a super message']! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: 'lr 11/23/2009 11:03'! addSelfReferenceToInlineParseTree | variableName rewriter newArguments | variableName := self newNameForSelf. rewriter := RBParseTreeRewriter rename: 'self' to: variableName. (rewriter executeTree: inlineParseTree) ifTrue: [inlineParseTree := rewriter tree]. newArguments := inlineParseTree arguments asOrderedCollection. newArguments addFirst: (RBVariableNode named: variableName). inlineParseTree renameSelector: (self addArgumentToSelector: inlineParseTree selector) andArguments: newArguments. sourceMessage receiver replaceWith: (RBVariableNode named: variableName)! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! abstractVariableReferences | refactoring | refactoring := RBAbstractVariablesRefactoring model: self model abstractVariablesIn: inlineParseTree from: inlineClass toAll: (Array with: class). self performComponentRefactoring: refactoring. inlineParseTree := refactoring parseTree! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming' stamp: ''! renameSelfReferences self addSelfReferenceToSourceMessage. self addSelfReferenceToInlineParseTree.! ! !RBInlineMethodFromComponentTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineComponentIntoCascadedMessage | refactoring | self proceedThroughWarning: [ refactoring := RBInlineMethodFromComponentRefactoring inline: (self convertInterval: (35 to: 79) for: (RBRefactoryTestDataApp sourceCodeAt: #inlineComponent)) inMethod: #inlineComponent forClass: RBRefactoryTestDataApp. (refactoring model classNamed: #Behavior) compile: 'hasImmediateInstances ^self format = 0' classified: #(#accessing ). self setupInlineExpressionFor: refactoring toReturn: false. self executeRefactoring: refactoring ]. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineComponent) = (RBParser parseMethod: 'inlineComponent | a aBehavior | a := 5. aBehavior := a class. aBehavior superclass. aBehavior format = 0. ^aBehavior yourself')! ! !RBInlineMethodFromComponentTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineEmptyComponentMethod | refactoring | self proceedThroughWarning: [ refactoring := RBInlineMethodFromComponentRefactoring inline: (self convertInterval: (35 to: 91) for: (RBRefactoryTestDataApp sourceCodeAt: #inlineComponent)) inMethod: #inlineComponent forClass: RBRefactoryTestDataApp. self setupInlineExpressionFor: refactoring toReturn: false. "The following line is needed because some people implement #yourself themselves." self setupImplementorToInlineFor: refactoring toReturn: (refactoring model classNamed: #Object). self executeRefactoring: refactoring ]. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineComponent) = (RBParser parseMethod: 'inlineComponent | a anObject | a := 5. anObject := a class. anObject superclass. anObject hasImmediateInstances. ^anObject')! ! !RBInlineMethodFromComponentTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineComponentMethodMax | refactoring | self proceedThroughWarning: [ | class | refactoring := RBInlineMethodFromComponentRefactoring inline: (self convertInterval: (47 to: 58) for: (RBRefactoryTestDataApp sourceCodeAt: #inlineMax)) inMethod: #inlineMax forClass: RBRefactoryTestDataApp. self setupInlineExpressionFor: refactoring toReturn: true. class := refactoring model classNamed: #Magnitude. class compile: 'max: aMagnitude "Answer the receiver or the argument, whichever has the greater magnitude." self > aMagnitude ifTrue: [^self] ifFalse: [^aMagnitude]' classified: #(#accessing ). self setupImplementorToInlineFor: refactoring toReturn: class. self executeRefactoring: refactoring ]. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineMax) = (RBParser parseMethod: 'inlineMax | x y q | x := 5. y := 10. q := x + 1 > y ifTrue: [x + 1] ifFalse: [y]. ^q')! ! !RBInlineMethodFromComponentTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelInlineMethodWithSameVariableNames2 | class refactoring | model := RBNamespace new. class := model classNamed: self class name. class compile: 'a9: a b9: b ^self + a + b' classified: #(#accessing). (model classNamed: #Object) compile: 'foo | a b c | a := InlineMethodFromComponentTest new. b := 1. c := 2. ^c a9: b b9: a' classified: #(#accessing). self proceedThroughWarning: [refactoring := RBInlineMethodFromComponentRefactoring model: model inline: (72 to: 84) inMethod: #foo forClass: (model classNamed: #Object). self setupInlineExpressionFor: refactoring toReturn: false. self executeRefactoring: refactoring]. self assert: ((refactoring model classNamed: #Object) parseTreeFor: #foo) = (RBParser parseMethod: 'foo | a b c | a := InlineMethodFromComponentTest new. b := 1. c := 2. ^c + b + a')! ! !RBInlineMethodFromComponentTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testInlineMethodFromComponentFailure self shouldFail: (RBInlineMethodFromComponentRefactoring inline: (self convertInterval: (50 to: 64) for: (RBRefactoryTestDataApp sourceCodeAt: #inlineFailed)) inMethod: #inlineFailed forClass: RBRefactoryTestDataApp)! ! !RBInlineMethodFromComponentTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelInlineMethodWithSameVariableNames1 | class refactoring | model := RBNamespace new. class := model classNamed: #Rectangle. class compile: 'rectangleRelativeTo: aRectangle ^self origin extent: aRectangle extent' classified: #(#accessing). (model classNamed: #Object) compile: 'foo | aRectangle temp | aRectangle := 0@0 corner: 1@1. temp := aRectangle. ^aRectangle rectangleRelativeTo: temp' classified: #(#accessing). self proceedThroughWarning: [refactoring := RBInlineMethodFromComponentRefactoring model: model inline: (77 to: 112) inMethod: #foo forClass: (model classNamed: #Object). self setupInlineExpressionFor: refactoring toReturn: false. self setupImplementorToInlineFor: refactoring toReturn: class. self executeRefactoring: refactoring]. self assert: ((refactoring model classNamed: #Object) parseTreeFor: #foo) = (RBParser parseMethod: 'foo | aRectangle temp | aRectangle := 0@0 corner: 1@1. temp := aRectangle. ^aRectangle origin extent: temp extent')! ! !RBInlineMethodFromComponentTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelInlineMethodWithSameVariableNames | class refactoring | model := RBNamespace new. class := model classNamed: self class name. class compile: 'a9: a b9: b ^self + a + b' classified: #(#accessing). (model classNamed: #Object) compile: 'foo | a b c | a := InlineMethodFromComponentTest new. b := 1. c := 2. ^a a9: b b9: c' classified: #(#accessing). self proceedThroughWarning: [refactoring := RBInlineMethodFromComponentRefactoring model: model inline: (72 to: 84) inMethod: #foo forClass: (model classNamed: #Object). self setupInlineExpressionFor: refactoring toReturn: false. self executeRefactoring: refactoring]. self assert: ((refactoring model classNamed: #Object) parseTreeFor: #foo) = (RBParser parseMethod: 'foo | a b c | a := InlineMethodFromComponentTest new. b := 1. c := 2. ^a + b + c')! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! normalizeReturns | rewriter | rewriter := RBParseTreeRewriter new. rewriter replace: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ^``@r1] ifFalse: [| `@t2 | `@.Stmts2. ^``@r2]' with: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ``@r1] ifFalse: [| `@t2 | `@.Stmts2. ``@r2]'; replace: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ^``@r1] ifTrue: [| `@t2 | `@.Stmts2. ^``@r2]' with: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ``@r1] ifTrue: [| `@t2 | `@.Stmts2. ``@r2]'; replace: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ``@r1] ifFalse: [| `@t2 | `@.Stmts2. ^``@r2]' with: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ``@r1] ifFalse: [| `@t2 | `@.Stmts2. ``@r2]'; replace: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ``@r1] ifTrue: [| `@t2 | `@.Stmts2. ^``@r2]' with: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ``@r1] ifTrue: [| `@t2 | `@.Stmts2. ``@r2]'; replace: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ^``@r1] ifFalse: [| `@t2 | `@.Stmts2. ``@r2]' with: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ``@r1] ifFalse: [| `@t2 | `@.Stmts2. ``@r2]'; replace: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ^``@r1] ifTrue: [| `@t2 | `@.Stmts2. ``@r2]' with: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ``@r1] ifTrue: [| `@t2 | `@.Stmts2. ``@r2]'; replace: '``@boolean ifTrue: [| `@t1 | `@.Stmts1. ^``@r1] ifFalse: [| `@t2 | `@.Stmts2. ^``@r2]' with: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ``@r1] ifFalse: [| `@t2 | `@.Stmts2. ``@r2]'; replace: '``@boolean ifFalse: [| `@t1 | `@.Stmts1. ^``@r1] ifTrue: [| `@t2 | `@.Stmts2. ^``@r2]' with: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ``@r1] ifTrue: [| `@t2 | `@.Stmts2. ``@r2]'. [rewriter executeTree: inlineParseTree] whileTrue: [inlineParseTree := rewriter tree]! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:09'! parseInlineMethod self inlineClass isNil ifTrue: [self refactoringFailure: ('<1p> or its superclasses don''t contain method <2s>' expandMacrosWith: class with: self inlineSelector)]. inlineParseTree := self inlineClass parseTreeFor: self inlineSelector. inlineParseTree isNil ifTrue: [self refactoringFailure: 'Could not parse sources']. inlineParseTree lastIsReturn ifFalse: [inlineParseTree addSelfReturn]! ! !RBInlineMethodRefactoring methodsFor: 'testing' stamp: 'CamilloBruni 9/13/2012 14:20'! isOverridden | selector| selector := self inlineSelector. class allSubclassesDo: [:each | (each directlyDefinesMethod: selector) ifTrue: [ ^ true ]]. ^ false ! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! insertInlinedMethod | node | node := sourceMessage. self moveComments. node parent isCascade ifTrue: [self rewriteCascadedMessage. node := node parent]. node parent isReturn ifTrue: [node := node parent] ifFalse: [self removeReturns]. self replaceArguments. self inlineSourceReplacing: node. sourceParseTree removeDeadCode. self removeEmptyIfTrues. self removeImmediateBlocks! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! inlineClass ^inlineClass isNil ifTrue: [inlineClass := (sourceMessage receiver name = 'super' ifTrue: [class superclass] ifFalse: [class]) whoDefinesMethod: self inlineSelector] ifFalse: [inlineClass]! ! !RBInlineMethodRefactoring methodsFor: 'testing' stamp: 'lr 11/2/2009 00:14'! hasMultipleReturns "Do we have multiple returns? If the last statement isn't a return, then we have an implicit return of self." | searcher | searcher := RBParseTreeSearcher new. searcher matches: '^``@object' do: [:aNode :hasAReturn | hasAReturn ifTrue: [^true]. true]. searcher executeTree: inlineParseTree initialAnswer: inlineParseTree lastIsReturn not. ^false! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! inlineSourceReplacing: aParseTree | statements nodeUnderSequence | statements := inlineParseTree body statements. (statements size > 1 and: [aParseTree isEvaluatedFirst not]) ifTrue: [self refactoringWarning: 'To inline this method, we need to move some of its statements before the original message send.This could change the order of execution, which can change the behavior.Do you want to proceed?' expandMacros]. nodeUnderSequence := aParseTree. [nodeUnderSequence parent isSequence] whileFalse: [nodeUnderSequence := nodeUnderSequence parent]. (nodeUnderSequence parent) addNodes: (statements copyFrom: 1 to: (statements size - 1 max: 0)) before: nodeUnderSequence; addTemporariesNamed: inlineParseTree body temporaryNames. aParseTree parent replaceNode: aParseTree withNode: (statements isEmpty ifTrue: [RBVariableNode named: 'self'] ifFalse: [statements last])! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: 'MarcusDenker 9/20/2013 13:29'! replaceArguments sourceMessage arguments reversed with: inlineParseTree arguments reversed do: [ :replacement :source | (replacement isImmediateNode or: [ self shouldInlineExpression: replacement newSource ]) ifTrue: [ self replaceArgument: source with: replacement ] ifFalse: [ self addTemporary: source assignedTo: replacement ] ]! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! addSelfReturn inlineParseTree addSelfReturn! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! renameTemporary: oldName to: newName | rewriter | rewriter := RBParseTreeRewriter new. rewriter replace: oldName with: newName; replaceArgument: oldName with: newName. (rewriter executeTree: inlineParseTree) ifTrue: [inlineParseTree := rewriter tree]! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! transform self renameConflictingTemporaries; insertInlinedMethod; compileMethod! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! removeImmediateBlocks | rewriter | rewriter := RBParseTreeRewriter new. rewriter replace: '[``.object] value' with: '``.object' when: [:aNode | aNode parent isCascade not]. rewriter replace: '| `@temps | ``@.Stmts1. [| `@bTemps | ``@.bStmts] value. ``@.Stmts2' with: '| `@temps `@bTemps | ``@.Stmts1. ``@.bStmts. ``@.Stmts2'. (rewriter executeTree: sourceParseTree) ifTrue: [sourceParseTree := rewriter tree]! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! inlineSelector sourceMessage isNil ifTrue: [self findSelectedMessage]. ^sourceMessage selector! ! !RBInlineMethodRefactoring methodsFor: 'initialize-release' stamp: ''! inline: anInterval inMethod: aSelector forClass: aClass sourceSelector := aSelector. class := self classObjectFor: aClass. sourceInterval := anInterval! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! rewriteCascadedMessage | index messages | messages := sourceMessage parent messages. index := (1 to: messages size) detect: [:i | sourceMessage == (messages at: i)] ifNone: [0]. inlineParseTree body addNodesFirst: (messages copyFrom: 1 to: index - 1). self removeReturns. inlineParseTree body addNodes: (messages copyFrom: index + 1 to: messages size). inlineParseTree addReturn! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! renameConflictingTemporary: aName | allNames newName index seqNode | allNames := (Set new) addAll: inlineParseTree allDefinedVariables; yourself. allNames remove: aName ifAbsent: []. seqNode := sourceMessage. [seqNode isSequence] whileFalse: [seqNode := seqNode parent]. allNames addAll: seqNode allDefinedVariables. "Add those variables defined in blocks. This might cause a few variables to be renamed that don't need to be, but this should be safe." newName := aName. index := 0. [(sourceMessage whoDefines: newName) notNil or: [(class hierarchyDefinesVariable: newName) or: [allNames includes: newName]]] whileTrue: [index := index + 1. newName := aName , index printString]. newName = aName ifFalse: [self renameTemporary: aName to: newName]. ^newName! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! removeReturns | rewriter | rewriter := RBParseTreeRewriter new. rewriter replace: '^``@object' with: '``@object'. (rewriter executeTree: inlineParseTree) ifTrue: [inlineParseTree := rewriter tree]! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! addTemporary: sourceNode assignedTo: replacementNode | newName | newName := self renameConflictingTemporary: sourceNode name. (inlineParseTree body) addTemporaryNamed: newName; addNodeFirst: (RBAssignmentNode variable: (RBVariableNode named: newName) value: replacementNode)! ! !RBInlineMethodRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition definesSelector: sourceSelector in: class) & (RBCondition withBlock: [self findSelectedMessage. self isOverridden ifTrue: [self refactoringWarning: ('<1p>>><2s> is overriden. Do you want to inline it anyway?' expandMacrosWith: self inlineClass with: self inlineSelector)]. self parseInlineMethod. self isPrimitive ifTrue: [self refactoringError: 'Cannot inline primitives']. self checkSuperMessages. self rewriteInlinedTree. (sourceMessage parent isReturn or: [self hasMultipleReturns not]) ifFalse: [self refactoringError: 'Cannot inline method since it contains multiple returns that cannot be rewritten']. true])! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! renameConflictingTemporaries inlineParseTree allDefinedVariables do: [:each | self renameConflictingTemporary: each]! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:09'! findSelectedMessage sourceParseTree := class parseTreeFor: sourceSelector. sourceParseTree isNil ifTrue: [self refactoringFailure: 'Could not parse sources']. sourceMessage := sourceParseTree whichNodeIsContainedBy: sourceInterval. sourceMessage isNil ifTrue: [self refactoringFailure: 'The selection doesn''t appear to be a message send']. sourceMessage isCascade ifTrue: [sourceMessage := sourceMessage messages last]. sourceMessage isMessage ifFalse: [self refactoringFailure: 'The selection doesn''t appear to be a message send']. (sourceMessage receiver isVariable and: [#('self' 'super') includes: sourceMessage receiver name]) ifFalse: [self refactoringError: 'Cannot inline non-self messages']! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! replaceArgument: sourceNode with: replacementNode | rewriter | rewriter := RBParseTreeRewriter new. rewriter replaceTree: sourceNode withTree: replacementNode. (rewriter executeTree: inlineParseTree body) ifTrue: [inlineParseTree body: rewriter tree]! ! !RBInlineMethodRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' inline: '. sourceInterval storeOn: aStream. aStream nextPutAll: ' inMethod: #'; nextPutAll: sourceSelector; nextPutAll: ' forClass: '. class storeOn: aStream. aStream nextPut: $)! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! compileMethod class compileTree: sourceParseTree! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! checkSuperMessages self inlineClass = class ifTrue: [^self]. self inlineClass superclass isNil ifTrue: [^self]. inlineParseTree superMessages do: [:each | (self inlineClass superclass whoDefinesMethod: each) = (class superclass whoDefinesMethod: each) ifFalse: [self refactoringError: ('Cannot inline method since it sends a super message <1s> that is overriden' expandMacrosWith: each)]]! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! removeEmptyIfTrues | rewriter | rewriter := RBParseTreeRewriter new. rewriter replace: '``@boolean ifTrue: [] ifFalse: [| `@temps | ``@.Stmts]' with: '``@boolean ifFalse: [|`@temps | ``@.Stmts]'; replace: '``@boolean ifFalse: [] ifTrue: [| `@temps | ``@.Stmts]' with: '``@boolean ifTrue: [|`@temps | ``@.Stmts]'; replace: '``@boolean ifTrue: [| `@temps | ``@.Stmts] ifFalse: []' with: '``@boolean ifTrue: [|`@temps | ``@.Stmts]'; replace: '``@boolean ifFalse: [| `@temps | ``@.Stmts] ifTrue: []' with: '``@boolean ifFalse: [|`@temps | ``@.Stmts]'. (rewriter executeTree: sourceParseTree) ifTrue: [sourceParseTree := rewriter tree]! ! !RBInlineMethodRefactoring methodsFor: 'testing' stamp: ''! isPrimitive ^inlineParseTree isPrimitive! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! rewriteInlinedTree sourceMessage parent isReturn ifTrue: [(sourceParseTree isLast: sourceMessage parent) ifFalse: [self addSelfReturn]] ifFalse: [self writeGuardClauses; normalizeIfTrues; normalizeReturns; addSelfReturn]! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! normalizeIfTrues | rewriter | rewriter := RBParseTreeRewriter new. rewriter replace: '| `@temps | ``@.s1. ``@boolean ifTrue: [| `@t1 | ``@.Stmts1. ^`@r1]. ``@.s2. ^``@r2' with: '| `@temps | ``@.s1. ``@boolean ifTrue: [| `@t1 | ``@.Stmts1. ^`@r1] ifFalse: [``@.s2. ^``@r2]'; replace: '| `@temps | ``@.s1. ``@boolean ifFalse: [| `@t1 | ``@.Stmts1. ^`@r1]. ``@.s2. ^``@r2' with: '| `@temps | ``@.s1. ``@boolean ifTrue: [``@.s2. ^``@r2] ifFalse: [| `@t1 | ``@.Stmts1. ^`@r1]'. [rewriter executeTree: inlineParseTree] whileTrue: [inlineParseTree := rewriter tree]! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! writeGuardClauses | rewriter | rewriter := RBParseTreeRewriter new. rewriter replaceMethod: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [| `@t1 | `@.Stmts1. ^`@r1]. `@.s2. ^`@r2' with: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [| `@t1 | `@.Stmts1. ^`@r1] ifFalse: [`@.s2. ^`@r2]'; replaceMethod: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifFalse: [| `@t1 | `@.Stmts1. ^`@r1]. `@.s2. ^`@r2' with: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [`@.s2. ^`@r2] ifFalse: [| `@t1 | `@.Stmts1. ^`@r1]'; replaceMethod: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [| `@t1 | `@.Stmts1. ^`@r1]. `@.s2' with: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [| `@t1 | `@.Stmts1. ^`@r1] ifFalse: [`@.s2. ^self]'; replaceMethod: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifFalse: [| `@t1 | `@.Stmts1. ^`@r1]. `@.s2' with: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [`@.s2. ^self] ifFalse: [| `@t1 | `@.Stmts1. ^`@r1]'. [rewriter executeTree: inlineParseTree] whileTrue: [inlineParseTree := rewriter tree]! ! !RBInlineMethodRefactoring methodsFor: 'transforming' stamp: ''! moveComments inlineParseTree nodesDo: [:each | each comments: (each comments collect: [:anInterval | | start stop source | source := sourceParseTree source. start := source size + 1. source := source , (inlineParseTree source copyFrom: anInterval first to: anInterval last). stop := source size. sourceParseTree source: source. start to: stop])]! ! !RBInlineMethodRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk inline: anInterval inMethod: aSelector forClass: aClass ^(self new) model: aRBSmalltalk; inline: anInterval inMethod: aSelector forClass: aClass; yourself! ! !RBInlineMethodRefactoring class methodsFor: 'instance creation' stamp: ''! inline: anInterval inMethod: aSelector forClass: aClass ^self new inline: anInterval inMethod: aSelector forClass: aClass! ! !RBInlineMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadInterval self shouldFail: (RBInlineMethodRefactoring inline: (self convertInterval: (13 to: 23) for: (RBRefactoryTestDataApp sourceCodeAt: #testMethod)) inMethod: #testMethod forClass: RBRefactoryTestDataApp); shouldFail: (RBInlineMethodRefactoring inline: (self convertInterval: (14 to: 17) for: (RBRefactoryTestDataApp sourceCodeAt: #testMethod)) inMethod: #testMethod forClass: RBRefactoryTestDataApp); shouldFail: (RBInlineMethodRefactoring inline: (self convertInterval: (24 to: 30) for: (RBRefactoryTestDataApp sourceCodeAt: #testMethod)) inMethod: #testMethod forClass: RBRefactoryTestDataApp); shouldFail: (RBInlineMethodRefactoring inline: (self convertInterval: (1 to: 30) for: (RBRefactoryTestDataApp sourceCodeAt: #testMethod)) inMethod: #testMethod forClass: RBRefactoryTestDataApp)! ! !RBInlineMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineMethod1 | refactoring | refactoring := RBInlineMethodRefactoring inline: (self convertInterval: (39 to: 84) for: (RBRefactoryTestDataApp sourceCodeAt: #caller)) inMethod: #caller forClass: RBRefactoryTestDataApp. self setupInlineExpressionFor: refactoring toReturn: false. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #caller) = (RBParser parseMethod: 'caller | anObject anObject1 | anObject := 5. anObject1 := anObject + 1. Transcript show: anObject1 printString; cr. ^anObject')! ! !RBInlineMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineRecursiveCascadedMethod | refactoring | refactoring := RBInlineMethodRefactoring inline: (self convertInterval: (33 to: 62) for: (RBRefactoryTestDataApp sourceCodeAt: #inlineMethod)) inMethod: #inlineMethod forClass: RBRefactoryTestDataApp. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineMethod) = (RBParser parseMethod: 'inlineMethod | temp temp1 | self foo. temp1 := self foo; inlineMethod; bar. temp := self bar. ^temp')! ! !RBInlineMethodTest methodsFor: 'failure tests' stamp: 'MarcusDenker 4/25/2013 15:10'! testInlineMethodForSuperSendThatAlsoSendsSuper | refactoring | model := Smalltalk evaluate: self inlineMethodTestData. refactoring := RBInlineMethodRefactoring inline: (102 to: 131) inMethod: #executeNotifying: forClass: (model classNamed: #RBRenameInstanceVariableChange). self shouldFail: refactoring! ! !RBInlineMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineMethod4 | refactoring | refactoring := RBInlineMethodRefactoring inline: (self convertInterval: (31 to: 112) for: (RBRefactoryTestDataApp sourceCodeAt: #inlineJunk)) inMethod: #inlineJunk forClass: RBRefactoryTestDataApp. self setupInlineExpressionFor: refactoring toReturn: false. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineJunk) = (RBParser parseMethod: 'inlineJunk | asdf bar1 baz1 asdf1 | bar1 := [:each | | temp | temp := each. temp , temp] value: self. baz1 := bar1 + bar1. asdf1 := baz1 + bar1. asdf := asdf1. ^asdf foo: [:bar | | baz | baz := bar. baz * baz]')! ! !RBInlineMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelInlineRecursiveMethod | refactoring class | class := model classNamed: #Object. class compile: 'foo self bar. self foo. self bar' classified: #(#accessing). refactoring := RBInlineMethodRefactoring model: model inline: (15 to: 23) inMethod: #foo forClass: class. self executeRefactoring: refactoring. self assert: (class parseTreeFor: #foo) = (RBParser parseMethod: 'foo self bar. self bar. self foo. self bar. self bar')! ! !RBInlineMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineMethod3 | refactoring | refactoring := RBInlineMethodRefactoring inline: (self convertInterval: (58 to: 73) for: (RBRefactoryTestDataApp sourceCodeAt: #caller2)) inMethod: #caller2 forClass: RBRefactoryTestDataApp. self setupInlineExpressionFor: refactoring toReturn: false. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #caller2) = (RBParser parseMethod: 'caller2 ^(1 to: 10) inject: 1 into: [:sum :each | sum * ((1 to: 10) inject: each into: [:sum1 :each1 | sum1 + each1])] ')! ! !RBInlineMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineMethod2 | refactoring | refactoring := RBInlineMethodRefactoring inline: (self convertInterval: (40 to: 120) for: (RBRefactoryTestDataApp sourceCodeAt: #caller1)) inMethod: #caller1 forClass: RBRefactoryTestDataApp. self setupInlineExpressionFor: refactoring toReturn: false. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #caller1) = (RBParser parseMethod: 'caller1 | anObject each1 anObject1 | anObject := 5. anObject1 := anObject + 1. each1 := anObject1 printString. Transcript show: each1; cr. [:each | each printString. ^anObject] value: each1')! ! !RBInlineMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineMethod | refactoring | refactoring := RBInlineMethodRefactoring inline: (self convertInterval: (455 to: 504) for: (RBBasicLintRuleTest class sourceCodeAt: #sentNotImplementedInApplication)) inMethod: #sentNotImplementedInApplication forClass: RBBasicLintRuleTest class. self executeRefactoring: refactoring. self assert: ((refactoring model metaclassNamed: #RBBasicLintRuleTest) parseTreeFor: #sentNotImplementedInApplication) = (RBParser parseMethod: 'sentNotImplementedInApplication | detector | detector := self new. detector name: ''Messages sent but not implemented in application''. detector methodBlock: [:context :result | | message class block | message := context messages detect: [:each | (context isItem: each in: context application) not] ifNone: [nil]. class := context selectedClass. block := [:each | | app methodApp root | app := context application. ((class canUnderstand: each) ifTrue: [root := app rootApplication. methodApp := ((class whichClassIncludesSelector: each) compiledMethodAt: each) application rootApplication. methodApp == root or: [root isBasedOn: methodApp]] ifFalse: [false]) not]. message isNil ifTrue: [message := context selfMessages detect: block ifNone: [nil]]. message isNil ifTrue: [class := class superclass. class isNil ifTrue: [context superMessages isEmpty ifFalse: [message := context superMessages asArray first]] ifFalse: [message := context superMessages detect: block ifNone: [nil]]]. message notNil ifTrue: [result addSearchString: message. result addClass: context selectedClass selector: context selector]]. ^detector')! ! !RBInlineMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineMethod5 | refactoring | refactoring := RBInlineMethodRefactoring inline: (self convertInterval: (53 to: 64) for: (RBRefactoryTestDataApp sourceCodeAt: #inlineLast)) inMethod: #inlineLast forClass: RBRefactoryTestDataApp. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineLast) = (RBParser parseMethod: 'inlineLast 5 = 3 ifTrue: [^self caller] ifFalse: [^ (1 to: 10) inject: 1 into: [:sum :each | sum * (self foo: each)]]')! ! !RBInlineMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantSelector self shouldFail: (RBInlineMethodRefactoring inline: (14 to: 17) inMethod: #checkClass1: forClass: RBRefactoryTestDataApp)! ! !RBInlineMethodTest methodsFor: 'tests' stamp: 'MarcusDenker 4/25/2013 15:10'! testInlineMethodForSuperSend | refactoring | model := Smalltalk evaluate: self inlineMethodTestData. (model classNamed: #RBRenameVariableChange) removeMethod: #executeNotifying:. refactoring := RBInlineMethodRefactoring model: model inline: (self convertInterval: (102 to: 131) for: ((model classNamed: #RBRenameInstanceVariableChange) sourceCodeFor: #executeNotifying:)) inMethod: #executeNotifying: forClass: (model classNamed: #RBRenameInstanceVariableChange). self executeRefactoring: refactoring. self assert: ((model classNamed: #RBRenameInstanceVariableChange) parseTreeFor: #executeNotifying:) = (RBParser parseMethod: 'executeNotifying: aBlock | undo undos undo1 | self addNewVariable. self copyOldValuesToNewVariable. undos := changes collect: [:each | each executeNotifying: aBlock]. undo1 := self copy. undo1 changes: undos reverse. undo := undo1. self removeOldVariable. ^undo')! ! !RBInlineMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testPrimitive self shouldFail: (RBInlineMethodRefactoring inline: (self convertInterval: (14 to: 23) for: (RBRefactoryTestDataApp sourceCodeAt: #testMethod)) inMethod: #testMethod forClass: RBRefactoryTestDataApp)! ! !RBInlineMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testOverriden self shouldWarn: (RBInlineMethodRefactoring inline: (self convertInterval: (15 to: 26) for: (RBLintRuleTest sourceCodeAt: #failedRules)) inMethod: #failedRules forClass: RBLintRuleTest)! ! !RBInlineMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testReturn self shouldFail: (RBInlineMethodRefactoring inline: (self convertInterval: (418 to: 485) for: (RBBasicLintRuleTest class sourceCodeAt: #utilityMethods)) inMethod: #utilityMethods forClass: RBBasicLintRuleTest class)! ! !RBInlineParameterRefactoring methodsFor: 'private' stamp: 'lr 11/2/2009 00:14'! expressionsToInlineFrom: aTree | searcher | searcher := RBParseTreeSearcher new. searcher matches: '``@obj ' , (self buildSelectorString: oldSelector) do: [:aNode :answer | answer add: (aNode arguments at: parameterIndex); yourself]. ^searcher executeTree: aTree initialAnswer: OrderedCollection new! ! !RBInlineParameterRefactoring methodsFor: 'private' stamp: ''! allExpressionsToInline | coll | coll := Set new. self model allReferencesTo: oldSelector do: [:each | | tree | tree := each parseTree. tree notNil ifTrue: [coll addAll: (self expressionsToInlineFrom: tree)]]. ^coll asOrderedCollection! ! !RBInlineParameterRefactoring methodsFor: 'transforming' stamp: ''! modifyImplementorParseTree: parseTree in: aClass | node assignment | node := (parseTree arguments at: parameterIndex) copy. parseTree body addTemporaryNamed: node name. assignment := RBAssignmentNode variable: node copy value: expressions first. parseTree body addNodeFirst: assignment. super modifyImplementorParseTree: parseTree in: aClass! ! !RBInlineParameterRefactoring methodsFor: 'preconditions' stamp: 'MarcusDenker 9/20/2013 15:06'! myConditions self getNewSelector. expressions := self allExpressionsToInline. ^(RBCondition definesSelector: oldSelector in: class) & ((RBCondition withBlock: [expressions isEmpty not]) errorMacro: 'No callers. Use Remove Method instead.') & ((RBCondition withBlock: [expressions size = 1]) errorMacro: 'All values passed as this argument must be identical.') & ((RBCondition withBlock: [expressions first isLiteralNode]) errorMacro: 'All values passed must be literal.')! ! !RBInlineParameterRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' inlineParameter: '''; nextPutAll: argument; nextPutAll: ''' in: '. class storeOn: aStream. aStream nextPutAll: ' selector: #'; nextPutAll: oldSelector; nextPut: $)! ! !RBInlineParameterRefactoring methodsFor: 'initialize-release' stamp: ''! inlineParameter: aString in: aClass selector: aSelector oldSelector := aSelector. class := self classObjectFor: aClass. argument := aString! ! !RBInlineParameterRefactoring class methodsFor: 'instance creation' stamp: ''! inlineParameter: aString in: aClass selector: aSelector ^self new inlineParameter: aString in: aClass selector: aSelector! ! !RBInlineParameterRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk inlineParameter: aString in: aClass selector: aSelector ^(self new) model: aRBSmalltalk; inlineParameter: aString in: aClass selector: aSelector; yourself! ! !RBInlineParameterTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineLiteralArray | refactoring class | refactoring := RBInlineParameterRefactoring inlineParameter: 'aSymbol' in: RBRefactoryTestDataApp selector: ('inline' , 'ParameterMethod:') asSymbol. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBRefactoryTestDataApp. self assert: (class parseTreeFor: #inlineParameterMethod) = (RBParser parseMethod: 'inlineParameterMethod | aSymbol | aSymbol := #(asdf). ^aSymbol isSymbol'). self assert: (class parseTreeFor: #sendInlineParameterMethod) = (RBParser parseMethod: 'sendInlineParameterMethod ^self inlineParameterMethod'). self deny: (class directlyDefinesMethod: ('inline' , 'ParameterMethod:') asSymbol)! ! !RBInlineParameterTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testInlineBlockFailure self shouldFail: (RBInlineParameterRefactoring inlineParameter: 'aBlock' in: RBRefactoryTestDataApp selector: ('inline' , 'Foo:') asSymbol)! ! !RBInlineTemporaryRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:08'! verifySelectedInterval sourceTree := class parseTreeFor: selector. sourceTree isNil ifTrue: [self refactoringFailure: 'Could not parse source']. assignmentNode := sourceTree whichNodeIsContainedBy: sourceInterval. assignmentNode isAssignment ifFalse: [self refactoringFailure: 'The selected node is not an assignment statement']. definingNode := assignmentNode whoDefines: assignmentNode variable name. self hasOnlyOneAssignment ifFalse: [self refactoringError: 'There are multiple assignments to the variable']. (RBReadBeforeWrittenTester isVariable: assignmentNode variable name writtenBeforeReadIn: definingNode) ifFalse: [self refactoringError: 'The variable is possible read before it is assigned']! ! !RBInlineTemporaryRefactoring methodsFor: 'initialize-release' stamp: ''! inline: anInterval from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. sourceInterval := anInterval! ! !RBInlineTemporaryRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [self verifySelectedInterval. true])! ! !RBInlineTemporaryRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' inline: '. sourceInterval storeOn: aStream. aStream nextPutAll: ' from: #'; nextPutAll: selector; nextPutAll: ' in: '. class storeOn: aStream. aStream nextPut: $)! ! !RBInlineTemporaryRefactoring methodsFor: 'transforming' stamp: ''! transform self replaceAssignment; replaceReferences; compileMethod! ! !RBInlineTemporaryRefactoring methodsFor: 'testing' stamp: 'lr 11/2/2009 00:14'! hasOnlyOneAssignment | searcher | searcher := RBParseTreeSearcher new. searcher matches: assignmentNode variable name , ' := ``@object' do: [:aNode :answer | answer + 1]. ^(searcher executeTree: definingNode initialAnswer: 0) == 1! ! !RBInlineTemporaryRefactoring methodsFor: 'transforming' stamp: ''! compileMethod class compileTree: sourceTree! ! !RBInlineTemporaryRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! replaceReferences | rewriter | rewriter := RBParseTreeRewriter new. rewriter replaceTree: assignmentNode variable withTree: assignmentNode value. definingNode removeTemporaryNamed: assignmentNode variable name. rewriter executeTree: definingNode! ! !RBInlineTemporaryRefactoring methodsFor: 'transforming' stamp: ''! replaceAssignment assignmentNode parent isSequence ifTrue: [assignmentNode parent removeNode: assignmentNode] ifFalse: [assignmentNode replaceWith: assignmentNode value]! ! !RBInlineTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''! inline: anInterval from: aSelector in: aClass ^self new inline: anInterval from: aSelector in: aClass! ! !RBInlineTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk inline: anInterval from: aSelector in: aClass ^(self new) model: aRBSmalltalk; inline: anInterval from: aSelector in: aClass; yourself! ! !RBInlineTemporaryTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineTemporaryBadInterval self shouldFail: (RBInlineTemporaryRefactoring inline: (self convertInterval: (29 to: 100) for: (RBRefactoryTestDataApp sourceCodeAt: #moveDefinition)) from: #moveDefinition in: RBRefactoryTestDataApp)! ! !RBInlineTemporaryTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineTemporary | refactoring | refactoring := RBInlineTemporaryRefactoring inline: (self convertInterval: (24 to: 72) for: (RBRefactoryTestDataApp sourceCodeAt: #inlineMethod)) from: #inlineMethod in: RBRefactoryTestDataApp. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #inlineMethod) = (RBParser parseMethod: 'inlineMethod ^self foo; inlineMethod; bar')! ! !RBInlineTemporaryTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineTemporaryReadBeforeWritten self shouldFail: (RBInlineTemporaryRefactoring inline: (self convertInterval: (48 to: 56) for: (RBRefactoryTestDataApp sourceCodeAt: #inlineTemporary)) from: #inlineTemporary in: RBRefactoryTestDataApp)! ! !RBInlineTemporaryTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineTemporaryMutlipleAssignment self shouldFail: (RBInlineTemporaryRefactoring inline: (self convertInterval: (60 to: 83) for: (RBRefactoryTestDataApp sourceCodeAt: #moveDefinition)) from: #moveDefinition in: RBRefactoryTestDataApp)! ! !RBInstVarInSubclassesRule commentStamp: ''! See my #rationale. In addition, have a look at the initialize method in each of the subclasses because if the instance variable is really the same, it will be initialized similarly in different places.! !RBInstVarInSubclassesRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !RBInstVarInSubclassesRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:21'! category ^ 'Design Flaws'! ! !RBInstVarInSubclassesRule methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 12/30/2012 20:44'! longDescription ^ 'This smell arises when instance variables are defined in all subclasses. Many times you might want to pull the instance variable up into the class so that all the subclasses do not have to define it. In addition have a look at the initialize method in each of the subclasses because if the instance variable is really the same, it will be initialized similarly in different places.'! ! !RBInstVarInSubclassesRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks classes for instance variables that are defined in all subclasses. Many times you might want to pull the instance variable up into the class so that all the subclasses do not have to define it.'! ! !RBInstVarInSubclassesRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBInstVarInSubclassesRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:03'! severity ^ #information! ! !RBInstVarInSubclassesRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Instance variables defined in all subclasses'! ! !RBInstVarInSubclassesRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkClass: aContext | subs | subs := aContext selectedClass subclasses. subs size > 1 ifTrue: [ | sels | sels := Bag new. subs do: [ :each | sels addAll: each instVarNames ]. sels asSet do: [ :val | | count | count := sels occurrencesOf: val. count == subs size ifTrue: [ result addClass: aContext selectedClass instanceVariable: val ] ] ]! ! !RBInstVarInSubclassesRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'InstVarInSubclassesRule'! ! !RBInstanceVariableCapitalizationRule commentStamp: ''! See my #rationale.! !RBInstanceVariableCapitalizationRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !RBInstanceVariableCapitalizationRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:14'! category ^ 'Style'! ! !RBInstanceVariableCapitalizationRule methodsFor: '*Manifest-Core' stamp: 'ah 8/6/2012 15:07'! longDescription ^ 'This smell arises when instance variable names (in instance and class side) do not start with an lowercase letter, which is a standart style in Smalltalk.'! ! !RBInstanceVariableCapitalizationRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:01'! rationale ^ 'Instance variable names on the instance- and class-side should start with a lowercase letter. A lowercase letter is used to represent variables with a local scope such as instance variables, temporary variables, method and block arguments. Uppercase is used to represent the case where the scope of a variable is either global (class name and global variables such Transcript) or shared mong different classes (class variables or pool variables).'! ! !RBInstanceVariableCapitalizationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBInstanceVariableCapitalizationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Instance variable capitalization'! ! !RBInstanceVariableCapitalizationRule methodsFor: 'running' stamp: 'lr 7/3/2009 20:34'! checkClass: aContext aContext selectedClass instVarNames do: [ :each | each first isLowercase ifFalse: [ result addClass: aContext selectedClass instanceVariable: each ] ]! ! !RBInstanceVariableCapitalizationRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'InstanceVariableCapitalizationRule'! ! !RBJustSendsSuperRule commentStamp: ''! See my #rationale. Just sending super often happens due to code changes or when you simply forget that you wanted to extend the behavior of a superclass method.! !RBJustSendsSuperRule methodsFor: 'initialization' stamp: 'lr 11/2/2009 00:14'! initialize super initialize. matcher := RBParseTreeSearcher justSendsSuper! ! !RBJustSendsSuperRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:21'! category ^ 'Optimization'! ! !RBJustSendsSuperRule methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 12/30/2012 20:45'! longDescription ^ 'This smell arises when a method just forwards the message to its superclass. This often happens due to code changes or when you simply forget that you wanted to extend the behavior of a superclass method. These methods can be removed.'! ! !RBJustSendsSuperRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for methods that just forward the message to its superclass. These methods can be removed.'! ! !RBJustSendsSuperRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBJustSendsSuperRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:10'! severity ^ #information! ! !RBJustSendsSuperRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Method just sends super message'! ! !RBJustSendsSuperRule methodsFor: 'running' stamp: 'lr 2/24/2009 00:11'! checkMethod: aContext (aContext parseTree isPrimitive not and: [ matcher executeMethod: aContext parseTree initialAnswer: false ]) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBJustSendsSuperRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'JustSendsSuperRule'! ! !RBKeywordToken commentStamp: 'md 8/9/2005 14:52'! RBKeywordToken is the first-class representation of a keyword token (e.g. add:)! !RBKeywordToken methodsFor: 'testing' stamp: ''! isKeyword ^true! ! !RBKeywordToken methodsFor: 'testing' stamp: 'lr 11/7/2009 15:30'! isPatternVariable ^value first = RBScanner patternVariableCharacter! ! !RBLintRule commentStamp: ''! I represent an executable check applied on an environment (groups of classes, methods... )! !RBLintRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 08:29'! changes ^ #()! ! !RBLintRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 5/21/2012 14:38'! leaves ^ {self}! ! !RBLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:51'! isEmpty self subclassResponsibility! ! !RBLintRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 11:05'! category "Bugs, Potential Bugs, Design Flaws, Coding Idiom Violation, Optinization, Style " ^ 'Unclassified rules'! ! !RBLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:52'! isComposite ^ false! ! !RBLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:52'! hasConflicts ^ false! ! !RBLintRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 14:59'! rationale "Answer a detailled explanation of the rule." ^ String new! ! !RBLintRule methodsFor: 'running' stamp: 'lr 9/8/2011 20:15'! run ^ RBSmalllintChecker runRule: self! ! !RBLintRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:01'! severity "Answer the severity of issues reported by this rule. This method should return one of #error, #warning, or #information." ^ #warning! ! !RBLintRule methodsFor: 'running' stamp: 'StephaneDucasse 12/30/2012 16:32'! checkMethod: aContext "Is a hook to specify a check that is performed at the method level"! ! !RBLintRule methodsFor: 'running' stamp: 'StephaneDucasse 12/30/2012 16:32'! checkClass: aContext "Is a hook to specify a check that is performed at the class level" ! ! !RBLintRule methodsFor: '*Manifest-Core' stamp: ''! result ^ self subclassResponsibility! ! !RBLintRule methodsFor: 'private' stamp: 'lr 2/24/2009 15:46'! genericPatternForSelector: aSymbol ^ String streamContents: [ :stream | aSymbol keywords keysAndValuesDo: [ :index :value | stream space; nextPutAll: value. aSymbol last = $: ifTrue: [ stream space; nextPutAll: '`@object'; print: index ] ] ]! ! !RBLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:41'! problemCount self subclassResponsibility! ! !RBLintRule methodsFor: 'printing' stamp: 'lr 2/26/2009 16:06'! printOn: aStream super printOn: aStream. self name isNil ifFalse: [ aStream nextPutAll: ' name: '; print: self name ]! ! !RBLintRule methodsFor: 'running' stamp: 'lr 2/23/2009 21:35'! resetResult! ! !RBLintRule methodsFor: 'running' stamp: 'lr 9/8/2011 20:15'! runOnEnvironment: anEnvironment ^ RBSmalllintChecker runRule: self onEnvironment: anEnvironment! ! !RBLintRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 3/27/2013 10:15'! critics ^ self result smallLintCritics ! ! !RBLintRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 8/22/2012 11:22'! longDescription ^ self rationale ! ! !RBLintRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 14:59'! group "Answer a human readable group name of this rule." ^ String new! ! !RBLintRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 14:58'! name "Answer a human readable name of the rule." self subclassResponsibility! ! !RBLintRule methodsFor: '*Manifest-Core' stamp: ''! isTransformationRule ^ false ! ! !RBLintRule class methodsFor: '*Manifest-Core' stamp: ''! identifierMinorVersionNumber "This number identifies the version of the rule definition. Each time the rule is updated and its changes invalidates previous false positives identification (and as such should be reassessed by developers) the number should be increased." ^ 1! ! !RBLintRule class methodsFor: 'testing' stamp: 'lr 2/24/2009 17:08'! isVisible "Answer true if the class should be visible in the GUI." ^ false! ! !RBLintRule class methodsFor: '*Manifest-Core' stamp: ''! uniqueIdentifierNumber "This number should be unique and should change only when the rule completely change semantics" ^ 0! ! !RBLintRuleTest methodsFor: 'accessing' stamp: ''! displayName | nameStream | nameStream := WriteStream on: (String new: 64). nameStream nextPutAll: self name; nextPutAll: ' ('. self problemCount printOn: nameStream. nameStream nextPut: $). ^nameStream contents! ! !RBLintRuleTest methodsFor: 'testing' stamp: ''! isEmpty self subclassResponsibility! ! !RBLintRuleTest methodsFor: 'testing' stamp: ''! isComposite ^false! ! !RBLintRuleTest methodsFor: 'testing' stamp: ''! hasConflicts ^false! ! !RBLintRuleTest methodsFor: 'accessing' stamp: ''! run ^Object printOn: self! ! !RBLintRuleTest methodsFor: 'private' stamp: ''! viewResults self subclassResponsibility! ! !RBLintRuleTest methodsFor: 'accessing' stamp: ''! checkMethod: aSmalllintContext! ! !RBLintRuleTest methodsFor: 'accessing' stamp: ''! checkClass: aSmalllintContext! ! !RBLintRuleTest methodsFor: 'initialization' stamp: ''! initialize name := ''! ! !RBLintRuleTest methodsFor: 'accessing' stamp: ''! name: aString name := aString! ! !RBLintRuleTest methodsFor: 'accessing' stamp: 'lr 8/7/2009 17:38'! openEditor | rules | rules := self failedRules. rules isEmpty ifTrue: [^self]. rules size == 1 ifTrue: [^rules first viewResults]! ! !RBLintRuleTest methodsFor: 'printing' stamp: ''! printOn: aStream name isNil ifTrue: [super printOn: aStream] ifFalse: [aStream nextPutAll: name]! ! !RBLintRuleTest methodsFor: 'accessing' stamp: ''! problemCount ^self subclassResponsibility! ! !RBLintRuleTest methodsFor: 'initialize-release' stamp: ''! resetResult! ! !RBLintRuleTest methodsFor: 'accessing' stamp: ''! runOnEnvironment: anEnvironment ^Object printOn: self onEnvironment: anEnvironment! ! !RBLintRuleTest methodsFor: 'private' stamp: ''! failedRules ^self isEmpty ifTrue: [#()] ifFalse: [Array with: self]! ! !RBLintRuleTest methodsFor: 'accessing' stamp: ''! name ^name! ! !RBLintRuleTest methodsFor: 'testing' stamp: 'lr 2/26/2009 15:07'! junk ^ RBRefactoryTestDataApp printString copyFrom: 1 to: CR! ! !RBLiteralArrayCharactersRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:32'! initialize super initialize. self matcher matches: '`#literal' do: [ :node :answer | answer isNil ifTrue: [ (node value class == Array and: [ self isArrayOfCharacters: node value ]) ifTrue: [ node ] ifFalse: [ nil ] ] ifFalse: [ answer ] ]! ! !RBLiteralArrayCharactersRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:35'! rationale ^ 'Literal arrays containing only characters can more efficiently represented as strings.'! ! !RBLiteralArrayCharactersRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBLiteralArrayCharactersRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Literal array contains only characters'! ! !RBLiteralArrayCharactersRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:22'! category ^ 'Optimization'! ! !RBLiteralArrayCharactersRule methodsFor: 'private' stamp: 'lr 2/24/2009 00:25'! isArrayOfCharacters: anArray anArray isEmpty ifTrue: [^false]. 1 to: anArray size do: [:each | (anArray at: each) class == Character ifFalse: [^false]]. ^true! ! !RBLiteralArrayCharactersRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'LiteralArrayCharactersRule'! ! !RBLiteralArrayContainsCommaRule commentStamp: ''! See my #rationale.! !RBLiteralArrayContainsCommaRule methodsFor: 'private' stamp: 'lr 2/6/2010 13:32'! doesLiteralArrayContainComma: aLiteral aLiteral class = Array ifFalse: [ ^ false ]. (aLiteral includes: #,) ifTrue: [ ^ true ]. ^ aLiteral anySatisfy: [ :each | self doesLiteralArrayContainComma: each ]! ! !RBLiteralArrayContainsCommaRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:05'! rationale ^ 'Checks for literal arrays that contain the #, symbol. The user may have thought that it was a separator'! ! !RBLiteralArrayContainsCommaRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBLiteralArrayContainsCommaRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Literal array contains a #,'! ! !RBLiteralArrayContainsCommaRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 14:13'! category ^ 'Coding Idiom Violation'! ! !RBLiteralArrayContainsCommaRule methodsFor: 'running' stamp: 'lr 2/6/2010 13:32'! checkMethod: aContext (aContext compiledMethod allLiterals anySatisfy: [ :each | self doesLiteralArrayContainComma: each ]) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBLiteralArrayContainsCommaRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'LiteralArrayContainsCommaRule'! ! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule commentStamp: ''! See my #rationale. This smell checks methods having #(#true #false #nil) in their literal frame, which may be a bug. ! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: 'initialization' stamp: 'lr 2/6/2010 13:50'! initialize super initialize. matcher := RBParseTreeSearcher new. matcher matches: '`#array `{ :node | node isLiteralArray and: [ node isForByteArray not ] }' do: [ :node :answer | answer addAll: (self literalTrueFalseOrNilSymbolsIn: node value); yourself ]! ! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: 'private' stamp: 'lr 2/6/2010 13:21'! literalTrueFalseOrNilSymbolsIn: aLiteral | retval | aLiteral class == Array ifFalse: [ ^ #() ]. retval := OrderedCollection withAll: (aLiteral select: [ :each | each isSymbol and: [ #(#true #false #nil ) includes: each ] ]). aLiteral do: [ :each | retval addAll: (self literalTrueFalseOrNilSymbolsIn: each) ]. ^ retval! ! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 14:12'! category ^ 'Potential Bugs'! ! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 12/30/2012 20:56'! longDescription ^ 'Some times ago, arrays were not allowed to contain true false and nil objects. They only contain their symbol representation: evaluating #(true false nil) returns #(#true #false #nil). Nowadays, #(true false nil) is equivalent to {true . false . nil }, i.e., it returns an array with the objects true, false, and nil. This smells checks methods having #(#true #false #nil) in their literal frame since it can be the source of potential bugs. '! ! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'With ANSI changes, #(true false nil) now is equal to {true. false. nil} not {#true. #false. #nil} as it used to be. This may be a bug.'! ! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Literal array contains a #true, #false, or #nil but the source doesn''t.'! ! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule methodsFor: 'running' stamp: 'lr 9/7/2010 21:59'! checkMethod: aContext | compiledLits parsedLits | compiledLits := aContext compiledMethod allLiterals inject: OrderedCollection new into: [ :collection :literal | collection addAll: (self literalTrueFalseOrNilSymbolsIn: literal); yourself ]. compiledLits size > 0 ifTrue: [ parsedLits := OrderedCollection new. matcher executeTree: aContext parseTree initialAnswer: parsedLits. compiledLits size ~= parsedLits size ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ] ]! ! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'LiteralArrayContainsSuspiciousTrueFalseOrNilRule'! ! !RBLiteralArrayNode commentStamp: ''! A RBLiteralArrayNode is an AST node that represents literal arrays and literal byte arrays. Instance Variables contents: literal nodes of the array isByteArray: if the receiver is a literal byte array start: source position of #( or #[ stop: source position of ) or ]! !RBLiteralArrayNode methodsFor: 'accessing' stamp: ''! stopWithoutParentheses ^stop! ! !RBLiteralArrayNode methodsFor: 'testing' stamp: ''! isLiteralArray ^true! ! !RBLiteralArrayNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:36'! copyInContext: aDictionary ^ self class startPosition: nil contents: (self copyList: self contents inContext: aDictionary) stopPosition: nil isByteArray: isByteArray! ! !RBLiteralArrayNode methodsFor: 'accessing' stamp: ''! children ^contents! ! !RBLiteralArrayNode methodsFor: 'replacing' stamp: ''! replaceNode: aNode withNode: anotherNode self contents: (contents collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! ! !RBLiteralArrayNode methodsFor: 'private-replacing' stamp: ''! replaceSourceWith: aNode (self class = aNode class and: [self isForByteArray = aNode isForByteArray and: [self contents size = aNode contents size]]) ifFalse: [^super replaceSourceWith: aNode]. 1 to: self contents size do: [:i | (self contents at: i) = (aNode contents at: i) ifFalse: [(self contents at: i) replaceSourceWith: (aNode contents at: i)]]! ! !RBLiteralArrayNode methodsFor: 'comparing' stamp: ''! equalTo: anObject withMapping: aDictionary self class = anObject class ifFalse: [^false]. self isForByteArray = anObject isForByteArray ifFalse: [^false]. self contents size = anObject contents size ifFalse: [^false]. 1 to: self contents size do: [:i | ((self contents at: i) equalTo: (anObject contents at: i) withMapping: aDictionary) ifFalse: [^false]]. ^true! ! !RBLiteralArrayNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:36'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitLiteralArrayNode: self! ! !RBLiteralArrayNode methodsFor: 'accessing' stamp: ''! startWithoutParentheses ^start! ! !RBLiteralArrayNode methodsFor: 'testing' stamp: ''! isForByteArray ^isByteArray! ! !RBLiteralArrayNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:29'! isFaulty ^self contents anySatisfy: #isFaulty! ! !RBLiteralArrayNode methodsFor: 'accessing' stamp: ''! value | array | array := (isByteArray ifTrue: [ByteArray] ifFalse: [Array]) new: contents size. 1 to: contents size do: [:each | array at: each put: (contents at: each) value]. ^array! ! !RBLiteralArrayNode methodsFor: 'comparing' stamp: ''! = anObject super = anObject ifFalse: [^false]. self isForByteArray = anObject isForByteArray ifFalse: [^false]. self contents size = anObject contents size ifFalse: [^false]. 1 to: self contents size do: [:i | (self contents at: i) = (anObject contents at: i) ifFalse: [^false]]. ^true! ! !RBLiteralArrayNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:35'! postCopy super postCopy. self contents: (self contents collect: [ :each | each copy ])! ! !RBLiteralArrayNode methodsFor: 'matching' stamp: 'lr 5/30/2010 11:34'! match: aNode inContext: aDictionary aNode class = self class ifFalse: [^false]. self isForByteArray = aNode isForByteArray ifFalse: [^false]. ^self matchList: contents against: aNode contents inContext: aDictionary! ! !RBLiteralArrayNode methodsFor: 'initialize-release' stamp: ''! startPosition: startInteger contents: anArray stopPosition: stopInteger isByteArray: aBoolean start := startInteger. self contents: anArray. stop := stopInteger. isByteArray := aBoolean! ! !RBLiteralArrayNode methodsFor: 'initialize-release' stamp: ''! contents: aRBLiteralNodeCollection contents := aRBLiteralNodeCollection. contents do: [:each | each parent: self]! ! !RBLiteralArrayNode methodsFor: 'accessing' stamp: ''! contents ^contents! ! !RBLiteralArrayNode class methodsFor: 'instance creation' stamp: ''! value: aValue ^(self new) startPosition: nil contents: (aValue asArray collect: [:each | RBLiteralNode value: each]) stopPosition: nil isByteArray: aValue class ~~ Array; yourself! ! !RBLiteralArrayNode class methodsFor: 'instance creation' stamp: ''! startPosition: startInteger contents: anArray stopPosition: stopInteger isByteArray: aBoolean ^(self new) startPosition: startInteger contents: anArray stopPosition: stopInteger isByteArray: aBoolean; yourself! ! !RBLiteralArrayToken methodsFor: 'testing' stamp: ''! isLiteralArrayToken ^true! ! !RBLiteralArrayToken methodsFor: 'testing' stamp: ''! isForByteArray ^value last = $[! ! !RBLiteralNode commentStamp: ''! RBLiteralNode is an AST node that represents literals.! !RBLiteralNode methodsFor: 'comparing' stamp: ''! hash ^self value hash! ! !RBLiteralNode methodsFor: 'accessing' stamp: ''! value ^self subclassResponsibility! ! !RBLiteralNode methodsFor: 'comparing' stamp: 'lr 5/30/2010 11:34'! = anObject self == anObject ifTrue: [^true]. ^self class = anObject class! ! !RBLiteralNode methodsFor: 'testing' stamp: ''! needsParenthesis ^false! ! !RBLiteralNode methodsFor: 'accessing' stamp: ''! precedence ^0! ! !RBLiteralNode methodsFor: 'private-replacing' stamp: ''! replaceSourceWith: aNode self addReplacement: (RBStringReplacement replaceFrom: self start to: self stop with: aNode formattedCode)! ! !RBLiteralNode methodsFor: 'private-replacing' stamp: ''! replaceSourceFrom: aNode self addReplacement: (RBStringReplacement replaceFrom: aNode start to: aNode stop with: self formattedCode)! ! !RBLiteralNode methodsFor: 'testing' stamp: ''! isLiteralNode ^true! ! !RBLiteralNode methodsFor: 'testing' stamp: ''! isImmediateNode ^true! ! !RBLiteralNode class methodsFor: 'instance creation' stamp: ''! literalToken: aLiteralToken ^(aLiteralToken realValue class == Array or: [aLiteralToken realValue class == ByteArray]) ifTrue: [RBLiteralArrayNode startPosition: aLiteralToken start contents: (aLiteralToken value asArray collect: [:each | RBLiteralNode literalToken: each]) stopPosition: aLiteralToken stop isByteArray: aLiteralToken value class ~~ Array] ifFalse: [RBLiteralValueNode literalToken: aLiteralToken]! ! !RBLiteralNode class methodsFor: 'instance creation' stamp: ''! value: aValue ^((aValue class == Array or: [aValue class == ByteArray]) ifTrue: [RBLiteralArrayNode] ifFalse: [RBLiteralValueNode]) value: aValue! ! !RBLiteralToken commentStamp: 'md 8/9/2005 14:52'! RBLiteralToken is the first-class representation of a literal token (entire literals, even literal arrays, are a single token in the ST80 grammar.). Instance Variables: stopPosition The position within the source code where the token terminates. ! !RBLiteralToken methodsFor: 'testing' stamp: ''! isMultiKeyword ^false! ! !RBLiteralToken methodsFor: 'testing' stamp: ''! isLiteralToken ^true! ! !RBLiteralToken methodsFor: 'printing' stamp: ''! storeOn: aStream value isSymbol ifTrue: [aStream nextPut: $#. ((RBScanner isSelector: value) and: [value ~~ #'||']) ifTrue: [aStream nextPutAll: value] ifFalse: [value asString printOn: aStream]. ^self]. value class == Character ifTrue: [aStream nextPut: $$; nextPut: value. ^self]. value storeOn: aStream! ! !RBLiteralToken methodsFor: 'private' stamp: ''! length ^stopPosition - self start + 1! ! !RBLiteralToken methodsFor: 'accessing' stamp: ''! stop: anObject stopPosition := anObject! ! !RBLiteralToken methodsFor: 'initialize-release' stamp: ''! value: aString start: anInteger stop: stopInteger value := aString. sourcePointer := anInteger. stopPosition := stopInteger! ! !RBLiteralToken methodsFor: 'accessing' stamp: ''! realValue ^value! ! !RBLiteralToken class methodsFor: 'instance creation' stamp: ''! value: anObject | literal | literal := anObject class == Array ifTrue: [anObject collect: [:each | self value: each]] ifFalse: [anObject]. ^self value: literal start: nil stop: nil! ! !RBLiteralToken class methodsFor: 'instance creation' stamp: ''! value: aString start: anInteger stop: stopInteger ^(self new) value: aString start: anInteger stop: stopInteger; yourself! ! !RBLiteralValueNode commentStamp: ''! RBLiteralNode is an AST node that represents literal values (e.g., #foo, true, 1, etc.), but not literal arrays. Instance Variables: token the token that contains the literal value as well as its source positions! !RBLiteralValueNode methodsFor: 'initialize-release' stamp: ''! literalToken: aLiteralToken token := aLiteralToken! ! !RBLiteralValueNode methodsFor: 'accessing' stamp: ''! stopWithoutParentheses ^token stop! ! !RBLiteralValueNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:36'! copyInContext: aDictionary ^ self class literalToken: self token copy removePositions! ! !RBLiteralValueNode methodsFor: 'accessing' stamp: ''! value ^token realValue! ! !RBLiteralValueNode methodsFor: 'comparing' stamp: 'lr 5/30/2010 11:36'! = anObject ^ super = anObject and: [ self value = anObject value and: [ self value species = anObject value species ] ]! ! !RBLiteralValueNode methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 5/15/2013 14:57'! specialCommands ^ SugsSuggestionFactory commandsFoLiteralNode.! ! !RBLiteralValueNode methodsFor: 'accessing' stamp: ''! startWithoutParentheses ^token start! ! !RBLiteralValueNode methodsFor: 'accessing' stamp: ''! token ^token! ! !RBLiteralValueNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:30'! isFaulty ^false.! ! !RBLiteralValueNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:37'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitLiteralNode: self! ! !RBLiteralValueNode class methodsFor: 'instance creation' stamp: 'StephaneDucasse 3/29/2013 17:52'! literalToken: aLiteralToken ^ self new literalToken: aLiteralToken; yourself! ! !RBLiteralValueNode class methodsFor: 'instance creation' stamp: ''! value: aValue ^self literalToken: (RBLiteralToken value: aValue)! ! !RBLocalMethodsOfAClassNotInItsTraitComposition methodsFor: 'accessing' stamp: 'SebastianTleye 7/19/2013 13:40'! name ^ 'Repeated methods in the trait composition'! ! !RBLocalMethodsOfAClassNotInItsTraitComposition methodsFor: 'accessing' stamp: 'SebastianTleye 7/19/2013 13:41'! rationale ^ 'If a class has a method in its trait composition, the method should not be implemented in the class'! ! !RBLocalMethodsOfAClassNotInItsTraitComposition methodsFor: 'running' stamp: 'SebastianTleye 7/19/2013 14:30'! checkClass: aContext "The comparison between methods is made using the ast, this is better than comparing source code only since it does not take into account identations, extra parenthesis, etc" | selectedClass | selectedClass := aContext selectedClass. selectedClass hasTraitComposition ifTrue: [ selectedClass localMethods do: [ :method | |traitCompositionMethod | traitCompositionMethod := (selectedClass traitComposition methodDescriptionForSelector: method selector) effectiveMethod. traitCompositionMethod ifNotNil: [ (traitCompositionMethod ast = method ast) ifTrue: [ result addClass: selectedClass selector: method selector ]]]].! ! !RBLongMethodsRule commentStamp: ''! See my #rationale. Long methods should often be split into several smaller ones. When you start to need an empty line to separate groups of statements, this is an indication that you should probably define a new method. Do not forget that methods are points of extension in an object-oriented language. It means that each time you define a method, a subclass may override and extend it while taking advantage and reusing the calling context of your method. This is the basis for the Hook and Template Design Pattern and central to good object-oriented design. So keep your methods short. Use the extract method refactoring, which even checks whether the method you are extracting already exists in the class. The defined number of statements can be edited in #longMethodSize. In the future such rule should hold state and not be based on method redefinition for its customization. ! !RBLongMethodsRule methodsFor: 'initialization' stamp: 'lr 11/2/2009 00:14'! initialize super initialize. matcher := RBParseTreeSearcher new. matcher matches: '`.Stmt' do: [:aNode :answer | (aNode children inject: answer into: [:sum :each | matcher executeTree: each initialAnswer: sum]) + 1].! ! !RBLongMethodsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:23'! category ^ 'Design Flaws'! ! !RBLongMethodsRule methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 12/30/2012 21:01'! longDescription ^ 'This smell arises when a long method is found (with 10 or more statements). Note that, it counts statements, not lines. Long methods should often be split into several smaller ones. When you start to have empty line to separate groups of methods, this is an indication that you should probably define a new method. Do not forget that methods are unit of extensions in an object-oriented language. It means that each time you define a method a subclass may override and extend it while taking advantage and reusing the calling context of your method. This is the basis for Hook and Template Design Pattern and central to good object-oriented design. So keep your methods short. Use the extract method refactoring, it even checks whether the method you are extracting already exists in the class. The defined number of statements can be edited in RBLongMethodsRule>>longMethodSize.'! ! !RBLongMethodsRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:17'! rationale ^ 'Returns all methods that have #longMethodSize number of statements. This check counts statements, not lines.'! ! !RBLongMethodsRule methodsFor: 'private' stamp: 'CamilleTeruel 3/29/2013 17:44'! longMethodSize ^ 20! ! !RBLongMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBLongMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Long methods'! ! !RBLongMethodsRule methodsFor: 'running' stamp: 'lr 6/15/2009 15:56'! checkMethod: aContext (matcher executeTree: aContext parseTree initialAnswer: 0) >= self longMethodSize ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBLongMethodsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'LongMethodsRule'! ! !RBMessageNode commentStamp: 'md 8/9/2005 14:58'! RBMessageNode is an AST node that represents a message send. Instance Variables: arguments our argument nodes receiver the receiver's node selector the selector we're sending (cached) selectorParts the tokens for each keyword ! !RBMessageNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 7/22/2013 16:04'! isInlineWhile self methodNode compilationContext optionInlineWhile ifFalse: [ ^false ]. self isCascaded ifTrue: [^ false]. (#(whileFalse: whileTrue: whileFalse whileTrue) includes: self selector) ifFalse: [^ false]. self receiver isBlock ifFalse: [^ false]. self receiver arguments isEmpty ifFalse: [self notify: 'while receiver block must have no arguments'. ^ false]. self arguments isEmpty ifFalse: [ self arguments first isBlock ifFalse: [^ false]. self arguments first arguments isEmpty ifFalse: [self notify: 'while takes a zero-arg block as its argument'. ^ false]. ]. ^ true! ! !RBMessageNode methodsFor: 'testing' stamp: ''! isMessage ^true! ! !RBMessageNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 7/22/2013 16:04'! isInlineAndOr self methodNode compilationContext optionInlineAndOr ifFalse: [ ^false ]. self receiver isBlock ifTrue: [^ false]. self isCascaded ifTrue: [^ false]. (#(and: or:) includes: self selector) ifFalse: [^ false]. (self arguments allSatisfy: [ :each | each isBlock ]) ifFalse: [^ false]. (self arguments allSatisfy: [ :each | each arguments isEmpty ]) ifFalse: [ self notify: 'and: (or:) takes zero-arg block'. ^ false ]. ^ true! ! !RBMessageNode methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/19/2013 10:08'! specialCommands ^ SugsSuggestionFactory commandsForMessage! ! !RBMessageNode methodsFor: 'testing' stamp: 'lr 11/2/2009 23:37'! isKeyword ^selectorParts first value last = $:! ! !RBMessageNode methodsFor: 'querying' stamp: ''! bestNodeFor: anInterval (self intersectsInterval: anInterval) ifFalse: [^nil]. (self containedBy: anInterval) ifTrue: [^self]. selectorParts do: [:each | ((anInterval first between: each start and: each stop) or: [each start between: anInterval first and: anInterval last]) ifTrue: [^self]]. self children do: [:each | | node | node := each bestNodeFor: anInterval. node notNil ifTrue: [^node]]! ! !RBMessageNode methodsFor: 'accessing' stamp: ''! children ^(OrderedCollection with: self receiver) addAll: self arguments; yourself! ! !RBMessageNode methodsFor: 'testing' stamp: ''! isBinary ^(self isUnary or: [self isKeyword]) not! ! !RBMessageNode methodsFor: 'private-replacing' stamp: ''! replaceSourceWith: aNode (self isContainmentReplacement: aNode) ifTrue: [^self replaceContainmentSourceWith: aNode]. aNode isMessage ifFalse: [^super replaceSourceWith: aNode]. ^self replaceSourceWithMessageNode: aNode! ! !RBMessageNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 9/20/2013 15:06'! isInlineToDo | block step | self methodNode compilationContext optionInlineToDo ifFalse: [ ^false ]. self receiver isBlock ifTrue: [^ false]. self isCascaded ifTrue: [^ false]. (#(to:do: to:by:do:) includes: self selector) ifFalse: [^ false]. block := self arguments last. block isBlock ifFalse: [^ false]. block arguments size = 1 ifFalse: [ self notify: 'to:do: block must take one arg'. ^ false]. self arguments first isVariable ifTrue: [ (RBParseTreeSearcher new matches: self arguments first name , ' := `@object' do: [:n :a | true]; executeTree: block initialAnswer: false) ifTrue: [^ false]. ]. self arguments size = 3 "to:by:do:" ifTrue: [ step := self arguments second. step isLiteralNode ifFalse: [^ false]. step value = 0 ifTrue: [^ false]. ]. ^ true! ! !RBMessageNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 9/30/2013 14:54'! isInlineTimesRepeat | block | self methodNode compilationContext optionInlineTimesRepeat ifFalse: [ ^false ]. self receiver isBlock ifTrue: [^ false]. self isCascaded ifTrue: [^ false]. #timesRepeat: = self selector ifFalse: [^ false]. block := self arguments last. block isBlock ifFalse: [^ false]. block arguments size isZero ifFalse: [ "self notify: 'timesRepeat: block must take zero arg'." ^ false]. ^ true! ! !RBMessageNode methodsFor: 'accessing' stamp: ''! renameSelector: newSelector andArguments: varNodeCollection self arguments: varNodeCollection; selector: newSelector! ! !RBMessageNode methodsFor: 'accessing' stamp: 'lr 5/30/2010 14:21'! sentMessages ^ super sentMessages add: self selector; yourself! ! !RBMessageNode methodsFor: 'accessing' stamp: 'jorgeRessia 11/20/2009 16:40'! debugHighlightStart ^ self selectorParts first start! ! !RBMessageNode methodsFor: 'accessing' stamp: ''! precedence ^self isUnary ifTrue: [1] ifFalse: [self isKeyword ifTrue: [3] ifFalse: [2]]! ! !RBMessageNode methodsFor: 'accessing' stamp: ''! receiver: aValueNode receiver := aValueNode. receiver parent: self! ! !RBMessageNode methodsFor: 'private-replacing' stamp: ''! replaceContainmentSourceWith: aNode | originalNode needsParenthesis | needsParenthesis := aNode hasParentheses not and: [aNode needsParenthesis]. originalNode := (self mappingFor: self receiver) = aNode ifTrue: [self receiver] ifFalse: [self arguments detect: [:each | (self mappingFor: each) = aNode]]. self addReplacement: (RBStringReplacement replaceFrom: self start to: originalNode start - 1 with: (needsParenthesis ifTrue: ['('] ifFalse: [''])); addReplacement: (RBStringReplacement replaceFrom: originalNode stop + 1 to: self stop with: (needsParenthesis ifTrue: [')'] ifFalse: ['']))! ! !RBMessageNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 7/22/2013 16:03'! isInlineIf self methodNode compilationContext optionInlineIf ifFalse: [ ^false ]. self receiver isBlock ifTrue: [^ false]. self isCascaded ifTrue: [^ false]. (#(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:) includes: self selector) ifFalse: [^ false]. self arguments do: [:node | node isBlock ifFalse: [^ false]]. self arguments do: [:block | block arguments isEmpty ifFalse: [ OCSemanticError new node: self; compilationContext: self methodNode compilationContext; messageText: 'ifTrue:ifFalse: takes zero-arg blocks'; signal. ^ false ] ]. ^ true! ! !RBMessageNode methodsFor: 'replacing' stamp: ''! replaceNode: aNode withNode: anotherNode "If we're inside a cascade node and are changing the receiver, change all the receivers" receiver == aNode ifTrue: [self receiver: anotherNode. (parent notNil and: [parent isCascade]) ifTrue: [parent messages do: [:each | each receiver: anotherNode]]]. self arguments: (arguments collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! ! !RBMessageNode methodsFor: 'accessing' stamp: 'lr 8/8/2010 13:16'! selector: aSelector | keywords numArgs | keywords := aSelector keywords. numArgs := aSelector numArgs. numArgs == arguments size ifFalse: [self error: 'Attempting to assign selector with wrong number of arguments.']. selectorParts := numArgs == 0 ifTrue: [Array with: (RBIdentifierToken value: keywords first start: nil)] ifFalse: [keywords first last = $: ifTrue: [keywords collect: [:each | RBKeywordToken value: each start: nil]] ifFalse: [Array with: (RBBinarySelectorToken value: aSelector start: nil)]]. selector := aSelector asSymbol! ! !RBMessageNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 7/22/2013 16:06'! isInlineCase self methodNode compilationContext optionInlineCase ifFalse: [ ^false ]. self isCascaded ifTrue: [^ false]. (#(caseOf: caseOf:otherwise:) includes: self selector) ifFalse: [^ false]. self arguments size = 2 ifTrue: [ "otherwise block" self arguments last isBlock ifFalse: [^ false]]. self arguments first isArray ifFalse: [^ false]. self arguments first statements do: [:assoc | (assoc isMessage and: [assoc selector == #->]) ifFalse: [^ false]. assoc receiver isBlock ifFalse: [^ false]. assoc receiver arguments isEmpty ifFalse: [self notify: 'caseOf: takes zero-arg blocks'. ^ false]. assoc arguments first isBlock ifFalse: [^ false]. assoc arguments first arguments isEmpty ifFalse: [self notify: 'caseOf: takes zero-arg blocks']. ]. ^ true! ! !RBMessageNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:36'! postCopy super postCopy. self receiver: self receiver copy. self arguments: (self arguments collect: [ :each | each copy ])! ! !RBMessageNode methodsFor: 'testing' stamp: 'lr 10/20/2009 11:43'! isSelfSend ^ self receiver isVariable and: [ self receiver name = 'self' ]! ! !RBMessageNode methodsFor: 'matching' stamp: 'lr 5/30/2010 11:34'! match: aNode inContext: aDictionary aNode class = self class ifFalse: [^false]. self selector = aNode selector ifFalse: [^false]. (receiver match: aNode receiver inContext: aDictionary) ifFalse: [^false]. 1 to: arguments size do: [:i | ((arguments at: i) match: (aNode arguments at: i) inContext: aDictionary) ifFalse: [^false]]. ^true! ! !RBMessageNode methodsFor: 'testing' stamp: 'ClementBera 7/26/2013 17:16'! needsParenthesis ^parent ifNil: [false] ifNotNil: [self precedence > parent precedence or: [self precedence = parent precedence and: [self isUnary not]]]! ! !RBMessageNode methodsFor: 'testing' stamp: ''! isUnary ^arguments isEmpty! ! !RBMessageNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:16'! selector ^ selector ifNil: [selector := self buildSelector]! ! !RBMessageNode methodsFor: 'accessing' stamp: ''! stopWithoutParentheses ^arguments isEmpty ifTrue: [selectorParts first stop] ifFalse: [arguments last stop]! ! !RBMessageNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:30'! isFaulty ^self receiver isFaulty or: [self arguments anySatisfy: #isFaulty]! ! !RBMessageNode methodsFor: 'private-replacing' stamp: ''! isContainmentReplacement: aNode ^(self mappingFor: self receiver) = aNode or: [self arguments anySatisfy: [:each | (self mappingFor: each) = aNode]]! ! !RBMessageNode methodsFor: 'testing' stamp: ''! isCascaded ^parent notNil and: [parent isCascade]! ! !RBMessageNode methodsFor: 'private' stamp: 'MarcusDenker 4/12/2013 10:23'! buildSelector ^(String streamContents: [ :selectorStream | selectorParts do: [ :each | selectorStream nextPutAll: each value ]]) asSymbol! ! !RBMessageNode methodsFor: 'testing' stamp: 'lr 10/20/2009 11:43'! isSuperSend ^ self receiver isVariable and: [ self receiver name = 'super' ]! ! !RBMessageNode methodsFor: 'private' stamp: 'lr 5/30/2010 09:36'! selectorParts: tokenCollection selectorParts := tokenCollection! ! !RBMessageNode methodsFor: 'accessing' stamp: 'jorgeRessia 11/20/2009 16:40'! debugHighlightStop ^ self stopWithoutParentheses! ! !RBMessageNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 12/2/2013 14:12'! isInlineIfNil | assertNone assertOneOrNone | self methodNode compilationContext optionInlineIfNil ifFalse: [ ^false ]. self receiver isBlock ifTrue: [^ false]. self isCascaded ifTrue: [^ false]. (#(ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:) includes: self selector) ifFalse: [^ false]. self arguments do: [:node | node isBlock ifFalse: [^ false]]. assertNone := [:block | block arguments isEmpty ifFalse: [self notify: 'ifNil: takes zero-arg block'. ^ false] ]. assertOneOrNone := [:block | block arguments size > 1 ifTrue: [self notify: 'ifNotNil: takes zero- or one-arg block'. ^ false] ]. self selector == #ifNil: ifTrue: [assertNone value: self arguments first]. self selector == #ifNil:ifNotNil: ifTrue: [assertNone value: self arguments first. assertOneOrNone value: self arguments last]. self selector == #ifNotNil: ifTrue: [assertOneOrNone value: self arguments first]. self selector == #ifNotNil:ifNil: ifTrue: [assertOneOrNone value: self arguments first. assertNone value: self arguments last]. ^ true! ! !RBMessageNode methodsFor: 'testing' stamp: 'lr 12/4/2011 16:30'! lastIsReturn ^ (#(#ifTrue:ifFalse: #ifFalse:ifTrue: #ifNil:ifNotNil: #ifNotNil:ifNil:) includes: self selector) and: [ arguments first isBlock and: [ arguments first body lastIsReturn and: [ arguments last isBlock and: [ arguments last body lastIsReturn ] ] ] ]! ! !RBMessageNode methodsFor: 'comparing' stamp: 'lr 3/7/2010 13:50'! hash ^ (self receiver hash bitXor: self selector hash) bitXor: (self hashForCollection: self arguments)! ! !RBMessageNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:36'! copyInContext: aDictionary ^ self class new receiver: (self receiver copyInContext: aDictionary); selectorParts: (self selectorParts collect: [ :each | each copy removePositions ]); arguments: (self arguments collect: [ :each | each copyInContext: aDictionary ]); yourself! ! !RBMessageNode methodsFor: 'accessing' stamp: ''! startWithoutParentheses ^receiver start! ! !RBMessageNode methodsFor: 'initialize-release' stamp: ''! receiver: aValueNode selectorParts: keywordTokens arguments: valueNodes self receiver: aValueNode. selectorParts := keywordTokens. self arguments: valueNodes! ! !RBMessageNode methodsFor: 'accessing' stamp: ''! arguments: argCollection arguments := argCollection. arguments do: [:each | each parent: self]! ! !RBMessageNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:37'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitMessageNode: self! ! !RBMessageNode methodsFor: 'comparing' stamp: ''! equalTo: anObject withMapping: aDictionary self class = anObject class ifFalse: [^false]. ((self receiver equalTo: anObject receiver withMapping: aDictionary) and: [self selector = anObject selector]) ifFalse: [^false]. 1 to: self arguments size do: [:i | ((self arguments at: i) equalTo: (anObject arguments at: i) withMapping: aDictionary) ifFalse: [^false]]. ^true! ! !RBMessageNode methodsFor: 'accessing' stamp: ''! receiver ^receiver! ! !RBMessageNode methodsFor: 'comparing' stamp: ''! = anObject self == anObject ifTrue: [^true]. self class = anObject class ifFalse: [^false]. (self receiver = anObject receiver and: [self selector = anObject selector]) ifFalse: [^false]. 1 to: self arguments size do: [:i | (self arguments at: i) = (anObject arguments at: i) ifFalse: [^false]]. ^true! ! !RBMessageNode methodsFor: 'private-replacing' stamp: 'eem 5/25/2010 21:07'! replaceSourceWithMessageNode: aNode | isBinaryToKeyword | self numArgs = aNode numArgs ifFalse: [^super replaceSourceWith: aNode]. self arguments with: aNode arguments do: [:old :new | (self mappingFor: old) = new ifFalse: [^super replaceSourceWith: aNode]]. (self mappingFor: self receiver) = aNode receiver ifFalse: [(self receiver isVariable and: [aNode receiver isVariable]) ifFalse: [^super replaceSourceWith: aNode]. self addReplacement: (RBStringReplacement replaceFrom: self receiver start to: self receiver stop with: aNode receiver name)]. (isBinaryToKeyword := self isBinary and: [aNode isKeyword]) ifTrue: [(self hasParentheses not and: [self parent precedence <= aNode precedence]) ifTrue: [self addReplacement: (RBStringReplacement replaceFrom: self start to: self start - 1 with: '('); addReplacement: (RBStringReplacement replaceFrom: self stop + 1 to: self stop with: ')')]]. self selectorParts with: aNode selectorParts do: [:old :new | old value ~= new value ifTrue: [self addReplacement: (RBStringReplacement replaceFrom: old start to: old stop with: ((isBinaryToKeyword and: [(self source at: old start - 1) isSeparator not]) ifTrue: [' ' , new value] ifFalse: [new value]))]]! ! !RBMessageNode methodsFor: 'accessing' stamp: ''! numArgs ^self selector numArgs! ! !RBMessageNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 9/30/2013 14:39'! isInlined self methodNode compilationContext optIlineNone ifTrue: [ ^false ]. self isInlineIf ifTrue: [^true]. self isInlineIfNil ifTrue: [^true]. self isInlineAndOr ifTrue: [^true]. self isInlineWhile ifTrue: [^true]. self isInlineToDo ifTrue: [^true]. self isInlineTimesRepeat ifTrue: [^true]. self isInlineCase ifTrue: [^true]. self isInlineTimesRepeat ifTrue: [ ^true]. ^false.! ! !RBMessageNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:15'! arguments ^arguments ifNil: [#()] ifNotNil: [arguments]! ! !RBMessageNode methodsFor: 'private' stamp: 'lr 5/30/2010 09:36'! selectorParts ^ selectorParts! ! !RBMessageNode methodsFor: 'testing' stamp: ''! isFirstCascaded ^self isCascaded and: [parent messages first == self]! ! !RBMessageNode class methodsFor: 'instance creation' stamp: ''! receiver: aValueNode selectorParts: keywordTokens arguments: valueNodes ^(self new) receiver: aValueNode selectorParts: keywordTokens arguments: valueNodes; yourself! ! !RBMessageNode class methodsFor: 'instance creation' stamp: ''! receiver: aValueNode selector: aSymbol ^self receiver: aValueNode selector: aSymbol arguments: #()! ! !RBMessageNode class methodsFor: 'instance creation' stamp: ''! receiver: aValueNode selector: aSymbol arguments: valueNodes ^(self new) receiver: aValueNode; arguments: valueNodes; selector: aSymbol; yourself! ! !RBMetaclass methodsFor: 'accessing' stamp: 'lr 10/26/2009 22:08'! allClassVariableNames ^ self theNonMetaClass allClassVariableNames! ! !RBMetaclass methodsFor: 'accessing' stamp: 'lr 10/26/2009 22:08'! allPoolDictionaryNames ^ self theNonMetaClass allPoolDictionaryNames! ! !RBMetaclass methodsFor: 'printing' stamp: ''! storeOn: aStream super storeOn: aStream. aStream nextPutAll: ' class'! ! !RBMetaclass methodsFor: 'testing' stamp: ''! isMeta ^true! ! !RBMetaclass methodsFor: 'initialize-release' stamp: 'lr 7/23/2010 08:03'! realName: aSymbol self realClass: (Smalltalk globals at: aSymbol) classSide! ! !RBMetaclass methodsFor: 'printing' stamp: ''! printOn: aStream super printOn: aStream. aStream nextPutAll: ' class'! ! !RBMetaclass methodsFor: 'accessing' stamp: 'lr 10/26/2009 22:09'! theMetaClass ^ self! ! !RBMetaclass methodsFor: 'testing' stamp: 'lr 10/26/2009 22:08'! directlyDefinesClassVariable: aString ^ self theNonMetaClass directlyDefinesClassVariable: aString! ! !RBMetaclass methodsFor: 'testing' stamp: 'lr 10/26/2009 22:08'! directlyDefinesPoolDictionary: aString ^ self theNonMetaClass directlyDefinesPoolDictionary: aString! ! !RBMetaclass class methodsFor: 'instance creation' stamp: ''! existingNamed: aSymbol ^(self named: aSymbol) realName: aSymbol; yourself! ! !RBMetaclass class methodsFor: 'instance creation' stamp: ''! named: aSymbol ^(self new) name: aSymbol; yourself! ! !RBMethod methodsFor: 'accessing' stamp: ''! method: aCompiledMethod compiledMethod := aCompiledMethod! ! !RBMethod methodsFor: 'accessing' stamp: ''! selector ^selector! ! !RBMethod methodsFor: 'accessing' stamp: ''! parseTree ^RBParser parseMethod: self source onError: [:str :pos | ^nil]! ! !RBMethod methodsFor: 'private' stamp: 'lr 1/3/2010 11:47'! literal: anObject containsReferenceTo: aSymbol anObject = aSymbol ifTrue: [ ^ true ]. anObject class = Array ifFalse: [ ^ false ]. ^ anObject anySatisfy: [ :each | self literal: each containsReferenceTo: aSymbol ]! ! !RBMethod methodsFor: 'accessing' stamp: ''! method ^compiledMethod! ! !RBMethod methodsFor: 'compiling' stamp: 'lr 11/1/2009 23:53'! compileTree: aBRMethodNode | method sourceCode change | sourceCode := aBRMethodNode newSource. change := self modelClass model compile: sourceCode in: self modelClass classified: self protocols. method := self class for: self modelClass source: sourceCode selector: aBRMethodNode selector. self modelClass addMethod: method. ^ change! ! !RBMethod methodsFor: 'accessing' stamp: ''! selector: aSymbol selector := aSymbol! ! !RBMethod methodsFor: 'testing' stamp: 'lr 11/2/2009 00:14'! refersToClassNamed: aSymbol | searcher | searcher := RBParseTreeSearcher new. searcher matches: aSymbol asString do: [:node :answer | true]. ^(searcher executeTree: self parseTree initialAnswer: false) or: [self refersToSymbol: aSymbol]! ! !RBMethod methodsFor: 'accessing' stamp: 'lr 11/1/2009 23:15'! protocols ^ self modelClass protocolsFor: self selector! ! !RBMethod methodsFor: 'accessing' stamp: 'lr 11/1/2009 23:15'! source ^ source ifNil: [ source := (class realClass sourceCodeAt: selector) asString ]! ! !RBMethod methodsFor: 'printing' stamp: ''! printOn: aStream class printOn: aStream. aStream nextPutAll: '>>'; nextPutAll: self selector! ! !RBMethod methodsFor: 'testing' stamp: 'lr 11/2/2009 00:14'! refersToVariable: aString | searcher tree | tree := self parseTree. ((tree defines: aString) or: [tree body defines: aString]) ifTrue: [^false]. searcher := RBParseTreeSearcher new. searcher matches: aString do: [:node :answer | true]; matches: '[:`@vars | | `@temps | `@.Stmts]' do: [:node :answer | answer or: [((node defines: aString) or: [node body defines: aString]) not and: [searcher executeTree: node body initialAnswer: false]]]. ^searcher executeTree: self parseTree initialAnswer: false! ! !RBMethod methodsFor: 'accessing' stamp: ''! modelClass ^class! ! !RBMethod methodsFor: 'accessing' stamp: ''! source: aString source := aString! ! !RBMethod methodsFor: 'testing' stamp: 'lr 11/2/2009 00:14'! refersToSymbol: aSymbol | searcher | searcher := RBParseTreeSearcher new. searcher matches: aSymbol printString do: [:node :answer | true]; matches: '`#literal' do: [:node :answer | answer or: [self literal: node value containsReferenceTo: aSymbol]]. (RBScanner isSelector: aSymbol) ifTrue: [searcher matches: '`@object ' , (RBParseTreeSearcher buildSelectorString: aSymbol) do: [:node :answer | true]]. ^searcher executeTree: self parseTree initialAnswer: false! ! !RBMethod methodsFor: 'accessing' stamp: ''! modelClass: aRBClass class := aRBClass! ! !RBMethod class methodsFor: 'instance creation' stamp: ''! for: aRBClass source: aString selector: aSelector ^(self new) modelClass: aRBClass; selector: aSelector; source: aString; yourself! ! !RBMethod class methodsFor: 'instance creation' stamp: ''! for: aRBClass fromMethod: aCompiledMethod andSelector: aSymbol ^(self new) modelClass: aRBClass; method: aCompiledMethod; selector: aSymbol; yourself! ! !RBMethodHasNoTimeStampRule commentStamp: ''! See my #rationale.! !RBMethodHasNoTimeStampRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:20'! rationale ^ 'For proper versioning, every method should have a timestamp.'! ! !RBMethodHasNoTimeStampRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBMethodHasNoTimeStampRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:11'! severity ^ #error! ! !RBMethodHasNoTimeStampRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Method has no timeStamp'! ! !RBMethodHasNoTimeStampRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkMethod: aContext aContext compiledMethod timeStamp isEmpty ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBMethodHasNoTimeStampRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:24'! category ^ 'Bugs' ! ! !RBMethodHasNoTimeStampRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'MethodHasNoTimeStampRule'! ! !RBMethodName methodsFor: 'accessing' stamp: ''! selector ^selector! ! !RBMethodName methodsFor: 'accessing' stamp: ''! arguments ^arguments! ! !RBMethodName methodsFor: 'testing' stamp: 'lr 6/15/2010 10:26'! isValid ^ (RBCondition checkMethodName: self selector in: self class) and: [ self selector numArgs = self arguments size ]! ! !RBMethodName methodsFor: 'accessing' stamp: ''! arguments: nameCollection arguments := nameCollection. self changed: #arguments! ! !RBMethodName methodsFor: 'accessing' stamp: 'lr 6/15/2010 10:25'! selector: aSymbol selector := aSymbol asSymbol. self changed: #selector! ! !RBMethodName methodsFor: 'printing' stamp: 'lr 6/15/2010 10:25'! printOn: aStream | argumentStream | self isValid ifFalse: [ ^ aStream nextPutAll: '(invalid)' ]. argumentStream := self arguments readStream. self selector keywords keysAndValuesDo: [ :key :part | key = 1 ifFalse: [ aStream space ]. aStream nextPutAll: part. (self selector isUnary or: [ argumentStream atEnd ]) ifTrue: [ ^ self ]. aStream space; nextPutAll: argumentStream next ]! ! !RBMethodName class methodsFor: 'instance creation' stamp: ''! selector: aSymbol arguments: stringCollection ^(self new) selector: aSymbol; arguments: stringCollection; yourself! ! !RBMethodNode commentStamp: ''! RBMethodNode is the AST that represents a Smalltalk method. Instance Variables: arguments the arguments to the method body the body/statements of the method nodeReplacements a dictionary of oldNode -> newNode replacements replacements the collection of string replacements for each node replacement in the parse tree selector the method name (cached) selectorParts the tokens for the selector keywords source the source we compiled tags the source location of any resource/primitive tags ! !RBMethodNode methodsFor: 'testing' stamp: ''! isMethod ^true! ! !RBMethodNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 16:32'! hasTemporaryNamed: aString ^ self temporaries anySatisfy: [ :temp| temp name = aString ]! ! !RBMethodNode methodsFor: 'replacing' stamp: ''! map: oldNode to: newNode nodeReplacements at: oldNode put: newNode! ! !RBMethodNode methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/19/2013 10:08'! specialCommands ^SugsSuggestionFactory commandsForMethod.! ! !RBMethodNode methodsFor: 'accessing' stamp: 'lr 11/1/2009 19:57'! children ^ OrderedCollection new addAll: self arguments; addAll: self pragmas; add: self body; yourself! ! !RBMethodNode methodsFor: 'replacing' stamp: ''! clearReplacements replacements := nil! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'GabrielOmarCotelli 12/4/2013 09:27'! primitiveFromPragma pragmas ifNil: [ ^ IRPrimitive null ]. ^ pragmas detect: [ :each | each isPrimitive ] ifFound: [ :aPragmaPrimitive | aPragmaPrimitive asPrimitive ] ifNone: [ IRPrimitive null ]! ! !RBMethodNode methodsFor: 'initialization' stamp: ''! initialize replacements := SortedCollection sortBlock: [:a :b | a startPosition < b startPosition or: [a startPosition = b startPosition and: [a stopPosition < b stopPosition]]]. nodeReplacements := IdentityDictionary new! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'JorgeRessia 11/24/2009 18:56'! properties: aMethodeProperties ^self propertyAt: #methodProperties put: aMethodeProperties! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! methodNode ^self! ! !RBMethodNode methodsFor: 'accessing' stamp: 'GiselaDecuzzi 5/27/2013 18:59'! statements: aCollection self body statements: aCollection ! ! !RBMethodNode methodsFor: 'accessing' stamp: 'lr 11/1/2009 19:34'! pragmas: aCollection pragmas := aCollection. pragmas do: [ :each | each parent: self ]! ! !RBMethodNode methodsFor: 'private' stamp: 'TestRunner 12/23/2009 21:13'! reformatSource | stream newSource newTree | stream := WriteStream on: (String new: source size + 100). stream nextPutAll: (source copyFrom: (replacements inject: 1 into: [ :sum :each | stream nextPutAll: (source copyFrom: sum to: each startPosition - 1); nextPutAll: (each string). each stopPosition + 1 ]) to: source size). newSource := stream contents. newTree := RBParser parseMethod: newSource onError: [ :msg :pos | ^ self formattedCode ]. self = newTree ifFalse: [ ^ self formattedCode ]. ^ newSource! ! !RBMethodNode methodsFor: 'testing' stamp: ''! references: aVariableName ^body references: aVariableName! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'JorgeRessia 11/24/2009 19:05'! ir: aIRMethodNode ^ self propertyAt: #ir put: aIRMethodNode.! ! !RBMethodNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/15/2011 16:28'! scope ^ scope! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! renameSelector: newSelector andArguments: varNodeCollection | oldSelectorParts oldArguments | oldSelectorParts := selectorParts. oldArguments := arguments. self arguments: varNodeCollection; selector: newSelector. self changeSourceSelectors: oldSelectorParts arguments: oldArguments! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'ClementBera 7/26/2013 15:25'! decompileString ^ self formattedCode ! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 7/5/2013 17:03'! properties ^self propertyAt: #methodProperties ifAbsent: nil! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 4/23/2013 16:45'! rewriteTempNamedRead: aTempName forContext: aContext | rewriter offset | offset := aContext tempNames indexOf: aTempName. rewriter := RBParseTreeRewriter new. rewriter replace: aTempName with: 'ThisContext namedTempAt:', offset asString. (rewriter executeTree: self) ifTrue: [^rewriter tree] ifFalse: [^self].! ! !RBMethodNode methodsFor: 'testing' stamp: ''! isLast: aNode ^body isLast: aNode! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 4/23/2013 16:44'! rewriteTempNamedWrite: aTempName forContext: aContext | rewriter offset | offset := aContext tempNames indexOf: aTempName. rewriter := RBParseTreeRewriter new. rewriter replace: aTempName, ' := ``@object' with: 'ThisContext namedTempAt:', offset asString, 'put: ``@object'. (rewriter executeTree: self) ifTrue: [^rewriter tree] ifFalse: [^self].! ! !RBMethodNode methodsFor: 'accessing' stamp: 'TestRunner 11/5/2009 11:48'! primitiveSources ^ self pragmas collect: [ :each | self source copyFrom: each first to: each last ]! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 4/29/2013 15:06'! sourceText: aString self source: aString! ! !RBMethodNode methodsFor: 'replacing' stamp: ''! replaceNode: aNode withNode: anotherNode aNode == body ifTrue: [self body: anotherNode]. self arguments: (arguments collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! ! !RBMethodNode methodsFor: 'testing' stamp: ''! uses: aNode ^body == aNode and: [aNode lastIsReturn]! ! !RBMethodNode methodsFor: 'testing' stamp: 'lr 11/1/2009 19:37'! isPrimitive ^ self pragmas anySatisfy: [ :each | each isPrimitive ]! ! !RBMethodNode methodsFor: 'accessing' stamp: 'lr 8/8/2010 13:15'! selector: aSelector | keywords numArgs | keywords := aSelector keywords. numArgs := aSelector numArgs. numArgs == arguments size ifFalse: [self error: 'Attempting to assign selector with wrong number of arguments.']. selectorParts := numArgs == 0 ifTrue: [Array with: (RBIdentifierToken value: keywords first start: nil)] ifFalse: [keywords first last = $: ifTrue: [keywords collect: [:each | RBKeywordToken value: each start: nil]] ifFalse: [Array with: (RBBinarySelectorToken value: aSelector start: nil)]]. selector := aSelector asSymbol! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'ajh 6/28/2004 13:52'! compiledMethod ^ self ir compiledMethod! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 11/20/2012 16:30'! generate: trailer ^ self generateIR compiledMethodWith: trailer.! ! !RBMethodNode methodsFor: 'testing' stamp: ''! defines: aName ^arguments anySatisfy: [:each | each name = aName]! ! !RBMethodNode methodsFor: 'copying' stamp: 'lr 11/24/2009 23:22'! postCopy super postCopy. self arguments: (self arguments collect: [ :each | each copy ]). self pragmas: (self pragmas collect: [ :each | each copy ]). self body: self body copy! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'ClementBera 7/26/2013 15:26'! generateIR | ir | scope ifNil: [self doSemanticAnalysisInContext: self compilationContext ]. ir := (self compilationContext astTranslatorClass new visitNode: self) ir. ^ self ir: ir! ! !RBMethodNode methodsFor: 'matching' stamp: 'lr 5/30/2010 12:22'! match: aNode inContext: aDictionary self class = aNode class ifFalse: [ ^ false ]. aDictionary at: '-source-' put: aNode source. self selector = aNode selector ifFalse: [ ^ false ]. ^ (self matchList: arguments against: aNode arguments inContext: aDictionary) and: [ (self matchPragmas: self pragmas against: aNode pragmas inContext: aDictionary) and: [ body match: aNode body inContext: aDictionary ] ]! ! !RBMethodNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/15/2011 16:28'! scope: aScopedNode scope := aScopedNode! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'ClementBera 7/26/2013 15:27'! methodOrBlockNode "^ self"! ! !RBMethodNode methodsFor: 'accessing' stamp: 'MarcusDenker 5/13/2013 11:44'! compilationContext: aCompilationContext compilationContext := aCompilationContext.! ! !RBMethodNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 16:32'! hasArgumentNamed: aString ^ self arguments anySatisfy: [ :argument| argument name = aString ]! ! !RBMethodNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2012 16:41'! temporaries ^ self body temporaries! ! !RBMethodNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:13'! newSource replacements ifNil: [^self formattedCode]. ^[self reformatSource] on: Error do: [:ex | ex return: self formattedCode]! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'jorgeRessia 11/22/2009 10:30'! ir ^ self propertyAt: #ir ifAbsent: [self generateIR].! ! !RBMethodNode methodsFor: 'accessing' stamp: 'lr 1/4/2012 21:38'! addReturn ^ body addReturn! ! !RBMethodNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:13'! selector ^ selector ifNil: [selector := self buildSelector]! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! allDefinedVariables ^(self argumentNames asOrderedCollection) addAll: super allDefinedVariables; yourself! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! body: stmtsNode body := stmtsNode. body parent: self! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 1/30/2013 13:13'! generateWithSource "Answer a CompiledMethod with source encoded in trailer." "for doits, we need to store the source pretty printed from the AST to get the return and methodName correct" self selector isDoIt ifTrue: [source := self formattedCode]. ^self generate: (CompiledMethodTrailer new sourceCode: source).! ! !RBMethodNode methodsFor: 'accessing' stamp: 'lr 11/1/2009 19:34'! pragmas ^ pragmas ifNil: [ #() ]! ! !RBMethodNode methodsFor: 'accessing' stamp: 'lr 1/4/2012 21:38'! addSelfReturn ^ body addSelfReturn! ! !RBMethodNode methodsFor: 'private-replacing' stamp: 'lr 2/21/2010 13:51'! changeSourceSelectors: oldSelectorParts arguments: oldArguments "If this is the same number of arguments, we try a one to one replacement of selector parts and arguments. If this is not the case try to rewrite the signature as a whole, what unfortunately drops the comments within the signature." [ (oldSelectorParts size = selectorParts size and: [ oldArguments size = arguments size ]) ifTrue: [ oldSelectorParts with: selectorParts do: [ :old :new | self addReplacement: (RBStringReplacement replaceFrom: old start to: old stop with: new value) ]. oldArguments with: arguments do: [ :old :new | self addReplacement: (RBStringReplacement replaceFrom: old start to: old stop with: new name) ] ] ifFalse: [ self addReplacement: (RBStringReplacement replaceFrom: oldSelectorParts first start to: (oldArguments notEmpty ifTrue: [ oldArguments last stop ] ifFalse: [ oldSelectorParts last stop ]) with: (String streamContents: [ :stream | selectorParts keysAndValuesDo: [ :index :part | index = 1 ifFalse: [ stream space ]. stream nextPutAll: part value. index <= arguments size ifTrue: [ stream space; nextPutAll: (arguments at: index) name ] ] ])) ] ] on: Error do: [ :ex | ex return ]! ! !RBMethodNode methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 15:41'! methodClass ^self compilationContext getClass ! ! !RBMethodNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:30'! isFaulty (self arguments anySatisfy: #isFaulty) ifTrue:[ ^true]. (self pragmas anySatisfy: #isFaulty) ifTrue:[ ^true]. ^self body isFaulty! ! !RBMethodNode methodsFor: 'private' stamp: 'MarcusDenker 4/12/2013 10:23'! buildSelector ^(String streamContents: [ :selectorStream | selectorParts do: [ :each | selectorStream nextPutAll: each value ]]) asSymbol! ! !RBMethodNode methodsFor: 'private' stamp: ''! selectorParts: tokenCollection selectorParts := tokenCollection! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! allArgumentVariables ^(self argumentNames asOrderedCollection) addAll: super allArgumentVariables; yourself! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! source ^source! ! !RBMethodNode methodsFor: 'replacing' stamp: ''! mappingFor: oldNode ^nodeReplacements at: oldNode ifAbsent: [oldNode]! ! !RBMethodNode methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: self formattedCode! ! !RBMethodNode methodsFor: 'initialize-release' stamp: ''! selectorParts: tokenCollection arguments: variableNodes selectorParts := tokenCollection. self arguments: variableNodes! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! start ^1! ! !RBMethodNode methodsFor: 'testing' stamp: 'CamilloBruni 3/6/2013 15:15'! hasPragmaNamed: aSymbol self pragmaNamed: aSymbol ifAbsent: [ ^ false ]. ^ true! ! !RBMethodNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2012 16:42'! statements ^ self body statements! ! !RBMethodNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/8/2011 16:19'! temporaryNames ^ self body temporaryNames! ! !RBMethodNode methodsFor: 'testing' stamp: 'CamilloBruni 3/6/2013 15:14'! pragmaNamed: aSymbol ^ self pragmaNamed: aSymbol ifAbsent: [ KeyNotFound signalFor: aSymbol ]! ! !RBMethodNode methodsFor: 'testing' stamp: 'CamilloBruni 3/6/2013 15:15'! pragmaNamed: aSymbol ifAbsent: absentBlock ^ self pragmas detect: [ :pragma| pragma selector = aSymbol ] ifNone: absentBlock! ! !RBMethodNode methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 15:49'! methodClass: aClass compilationContext ifNil: [compilationContext := aClass compiler compilationContext]. self compilationContext class: aClass! ! !RBMethodNode methodsFor: 'accessing' stamp: 'MarcusDenker 4/12/2013 10:27'! sourceCode "compatibility to MethodNode" ^source! ! !RBMethodNode methodsFor: 'testing' stamp: ''! lastIsReturn ^body lastIsReturn! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 7/10/2013 15:55'! doSemanticAnalysis self compilationContext ifNil: [ self methodClass: nil class ]. self compilationContext semanticAnalyzerClass new compilationContext: self compilationContext; analyze: self! ! !RBMethodNode methodsFor: 'comparing' stamp: 'lr 3/7/2010 13:55'! hash ^ ((self selector hash bitXor: (self hashForCollection: self arguments)) bitXor: (self hashForCollection: self pragmas)) bitXor: self body hash! ! !RBMethodNode methodsFor: 'replacing' stamp: 'ClementBera 7/26/2013 17:13'! addReplacement: aStringReplacement replacements ifNil: [^self]. replacements add: aStringReplacement! ! !RBMethodNode methodsFor: 'matching' stamp: 'lr 5/30/2010 12:26'! copyInContext: aDictionary ^ self class new selectorParts: (self selectorParts collect: [ :each | each copy removePositions ]); arguments: (self arguments collect: [ :each | each copyInContext: aDictionary ]); pragmas: (self pragmas isEmpty ifTrue: [ aDictionary at: '-pragmas-' ifAbsent: [ #() ] ] ifFalse: [ self copyList: self pragmas inContext: aDictionary ]); body: (self body copyInContext: aDictionary); source: (aDictionary at: '-source-' ifAbsentPut: [ self source ]); yourself! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'ClementBera 5/21/2013 14:30'! doSemanticAnalysisIn: behavior self methodClass: behavior. self doSemanticAnalysis! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'ClementBera 7/26/2013 15:25'! generate "The receiver is the root of a parse tree. Answer a CompiledMethod. The argument, trailer, is the references to the source code that is stored with every CompiledMethod." ^ self generate: CompiledMethodTrailer empty! ! !RBMethodNode methodsFor: 'accessing' stamp: 'MarcusDenker 4/28/2013 20:10'! firstPrecodeComment | sourceInterval | self comments ifEmpty: [ ^nil ]. sourceInterval := self comments first. ^self source copyFrom: sourceInterval first to: sourceInterval last.! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'ClementBera 7/26/2013 15:25'! doSemanticAnalysisInContext: aCompilationContext self compilationContext: aCompilationContext. self doSemanticAnalysis.! ! !RBMethodNode methodsFor: '*AST-Interpreter-Core' stamp: 'GuillermoPolito 5/14/2013 11:22'! method ^self! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! stop ^source size! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'cb 6/27/2013 16:55'! startWithoutParentheses ^ 1! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! arguments: variableNodes arguments := variableNodes. arguments do: [:each | each parent: self]! ! !RBMethodNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:37'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitMethodNode: self! ! !RBMethodNode methodsFor: 'comparing' stamp: 'lr 10/18/2009 15:44'! equalTo: anObject withMapping: aDictionary self class = anObject class ifFalse: [ ^ false ]. (self selector = anObject selector and: [ self pragmas size = anObject pragmas size and: [ self body equalTo: anObject body withMapping: aDictionary ] ]) ifFalse: [ ^ false ]. self arguments with: anObject arguments do: [ :first :second | (first equalTo: second withMapping: aDictionary) ifFalse: [ ^ false ]. aDictionary removeKey: first name ]. self pragmas with: anObject pragmas do: [ :first :second | (first equalTo: second withMapping: aDictionary) ifFalse: [ ^ false ] ]. ^ true! ! !RBMethodNode methodsFor: 'accessing' stamp: 'lr 1/4/2012 21:40'! addNode: aNode ^ body addNode: aNode! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! methodComments | methodComments | methodComments := OrderedCollection withAll: self comments. arguments do: [:each | methodComments addAll: each comments]. ^methodComments asSortedCollection: [:a :b | a first < b first]! ! !RBMethodNode methodsFor: 'matching' stamp: 'lr 5/30/2010 12:23'! matchPragmas: matchNodes against: pragmaNodes inContext: aDictionary matchNodes isEmpty ifTrue: [ aDictionary at: '-pragmas-' put: pragmaNodes. ^ true ]. ^ matchNodes allSatisfy: [ :matchNode | pragmaNodes anySatisfy: [ :pragmaNode | matchNode match: pragmaNode inContext: aDictionary ] ]! ! !RBMethodNode methodsFor: 'comparing' stamp: 'lr 10/18/2009 16:03'! = anObject self == anObject ifTrue: [ ^ true ]. self class = anObject class ifFalse: [ ^ false ]. (self selector = anObject selector and: [ self pragmas size = anObject pragmas size and: [ self body = anObject body ] ]) ifFalse: [ ^ false ]. self arguments with: anObject arguments do: [ :first :second | first = second ifFalse: [ ^ false ] ]. self pragmas with: anObject pragmas do: [ :first :second | first = second ifFalse: [ ^ false ] ]. ^ true! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! body ^body! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! numArgs ^self selector numArgs! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 6/29/2012 16:04'! owningScope ^ self scope! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 4/19/2013 08:32'! sourceNodeForPC: anInteger ^(self ir instructionForPC: anInteger) sourceNode! ! !RBMethodNode methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 15:49'! compilationContext ^ compilationContext! ! !RBMethodNode methodsFor: 'private' stamp: ''! selectorParts ^selectorParts! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! arguments ^arguments! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! source: anObject source := anObject! ! !RBMethodNode methodsFor: 'accessing' stamp: ''! argumentNames ^self arguments collect: [:each | each name]! ! !RBMethodNode methodsFor: '*OpalCompiler-Core' stamp: 'MarcusDenker 4/29/2013 15:25'! tempNames "compatibility method to old MethodNode" self flag: #Clean. ^ self argumentNames, self temporaryNames! ! !RBMethodNode class methodsFor: 'instance creation' stamp: ''! selector: aSymbol arguments: variableNodes body: aSequenceNode ^(self new) arguments: variableNodes; selector: aSymbol; body: aSequenceNode; yourself! ! !RBMethodNode class methodsFor: 'instance creation' stamp: ''! selector: aSymbol body: aSequenceNode ^self selector: aSymbol arguments: #() body: aSequenceNode! ! !RBMethodNode class methodsFor: 'instance creation' stamp: ''! selectorParts: tokenCollection arguments: variableNodes ^(self new) selectorParts: tokenCollection arguments: variableNodes; yourself! ! !RBMethodRefactoring methodsFor: 'private' stamp: ''! buildSelectorString: aSelector withPermuteMap: anIntegerCollection | stream keywords | aSelector numArgs == 0 ifTrue: [^aSelector asString]. stream := WriteStream on: String new. keywords := aSelector keywords. keywords with: anIntegerCollection do: [:each :i | stream nextPutAll: each; nextPutAll: ' ``@arg'; nextPutAll: i printString; nextPut: $ ]. ^stream contents! ! !RBMethodRefactoring methodsFor: 'private' stamp: ''! buildSelectorString: aSelector aSelector numArgs = 0 ifTrue: [^aSelector]. ^self buildSelectorString: aSelector withPermuteMap: (1 to: aSelector numArgs)! ! !RBMethodSourceContainsLinefeedsRule commentStamp: ''! See my #rationale.! !RBMethodSourceContainsLinefeedsRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:21'! rationale ^ 'Pharo code should not contain linefeed characters.'! ! !RBMethodSourceContainsLinefeedsRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBMethodSourceContainsLinefeedsRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:11'! severity ^ #error! ! !RBMethodSourceContainsLinefeedsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Method source contains linefeeds'! ! !RBMethodSourceContainsLinefeedsRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkMethod: aContext (aContext sourceCode includes: Character lf) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBMethodSourceContainsLinefeedsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 14:11'! category ^ 'Bugs'! ! !RBMethodSourceContainsLinefeedsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'MethodSourceContainsLinefeedsRule'! ! !RBMinMaxRule commentStamp: ''! See rationale! !RBMinMaxRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:35'! initialize super initialize. self rewriteRule replace: '``@a < ``@b ifTrue: [``@a] ifFalse: [``@b]' with: '``@a min: ``@b'; replace: '``@a <= ``@b ifTrue: [``@a] ifFalse: [``@b]' with: '``@a min: ``@b'; replace: '``@a > ``@b ifTrue: [``@a] ifFalse: [``@b]' with: '``@a max: ``@b'; replace: '``@a >= ``@b ifTrue: [``@a] ifFalse: [``@b]' with: '``@a max: ``@b'; replace: '``@a < ``@b ifTrue: [``@b] ifFalse: [``@a]' with: '``@a max: ``@b'; replace: '``@a <= ``@b ifTrue: [``@b] ifFalse: [``@a]' with: '``@a max: ``@b'; replace: '``@a > ``@b ifTrue: [``@b] ifFalse: [``@a]' with: '``@a min: ``@b'; replace: '``@a >= ``@b ifTrue: [``@b] ifFalse: [``@a]' with: '``@a min: ``@b'; replace: '`a < ``@b ifTrue: [`a := ``@b]' with: '`a := `a max: ``@b'; replace: '`a <= ``@b ifTrue: [`a := ``@b]' with: '`a := `a max: ``@b'; replace: '`a < ``@b ifFalse: [`a := ``@b]' with: '`a := `a min: ``@b'; replace: '`a <= ``@b ifFalse: [`a := ``@b]' with: '`a := `a min: ``@b'; replace: '`a > ``@b ifTrue: [`a := ``@b]' with: '`a := `a min: ``@b'; replace: '`a >= ``@b ifTrue: [`a := ``@b]' with: '`a := `a min: ``@b'; replace: '`a > ``@b ifFalse: [`a := ``@b]' with: '`a := `a max: ``@b'; replace: '`a >= ``@b ifFalse: [`a := ``@b]' with: '`a := `a max: ``@b'; replace: '``@b < `a ifTrue: [`a := ``@b]' with: '`a := `a min: ``@b'; replace: '``@b <= `a ifTrue: [`a := ``@b]' with: '`a := `a min: ``@b'; replace: '``@b < `a ifFalse: [`a := ``@b]' with: '`a := `a max: ``@b'; replace: '``@b <= `a ifFalse: [`a := ``@b]' with: '`a := `a max: ``@b'; replace: '``@b > `a ifTrue: [`a := ``@b]' with: '`a := `a max: ``@b'; replace: '``@b >= `a ifTrue: [`a := ``@b]' with: '`a := `a max: ``@b'; replace: '``@b > `a ifFalse: [`a := ``@b]' with: '`a := `a min: ``@b'; replace: '``@b >= `a ifFalse: [`a := ``@b]' with: '`a := `a min: ``@b'! ! !RBMinMaxRule methodsFor: 'accessing' stamp: 'lr 9/7/2010 20:27'! rationale ^ 'The use of the messages #min: and #max: improves code readability and avoids heavily nested conditionals.'! ! !RBMinMaxRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBMinMaxRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Rewrite ifTrue:ifFalse: using min:/max:'! ! !RBMinMaxRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:51'! category ^ 'Coding Idiom Violation'! ! !RBMinMaxRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'MinMaxRule'! ! !RBMissingSubclassResponsibilityRule commentStamp: ''! See my #rationale.! !RBMissingSubclassResponsibilityRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:15'! resultClass ^ RBMultiEnvironment! ! !RBMissingSubclassResponsibilityRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:28'! category ^ 'Design Flaws'! ! !RBMissingSubclassResponsibilityRule methodsFor: '*Manifest-Core' stamp: 'ah 8/6/2012 12:14'! longDescription ^ 'This smell arises when a class defines a method in all subclasses, but not in itself as an abstract method. Such methods should most likely be defined as subclassResponsibility methods. Furthermore, this check helps to find similar code that might be occurring in all the subclasses that should be pulled up into the superclass.'! ! !RBMissingSubclassResponsibilityRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks classes for methods that are defined in all subclasses, but not defined in self. Such methods should most likely be defined as subclassResponsibility methods to help document the class. Furthermore, this check helps to find similar code that might be occurring in all the subclasses that should be pulled up into the superclass.'! ! !RBMissingSubclassResponsibilityRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:21'! group ^ 'Intention revealing'! ! !RBMissingSubclassResponsibilityRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Method defined in all subclasses, but not in superclass'! ! !RBMissingSubclassResponsibilityRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkClass: aContext | subs | subs := aContext selectedClass subclasses. (subs size > 1 and: [ aContext selectedClass isMeta not ]) ifTrue: [ | sels | sels := Bag new. subs do: [ :each | sels addAll: each selectors ]. sels asSet do: [ :each | ((sels occurrencesOf: each) == subs size and: [ (aContext selectedClass canUnderstand: each) not ]) ifTrue: [ | envName | envName := aContext selectedClass name , '>>' , each. subs do: [ :subClass | result addClass: subClass selector: each into: envName ] ] ] ]! ! !RBMissingSubclassResponsibilityRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'MissingSubclassResponsibilityRule'! ! !RBMissingSuperSendsRule commentStamp: ''! See my #rationale.! !RBMissingSuperSendsRule methodsFor: 'private' stamp: 'lr 2/24/2009 00:17'! superMessages ^#(#release #postCopy #postBuildWith: #preBuildWith: #postOpenWith: #noticeOfWindowClose: #initialize)! ! !RBMissingSuperSendsRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:23'! rationale ^ 'Checks that methods that should always contain a super message send, actually contain a super message send. For example, the postCopy method should always contain a "super postCopy". The list of methods that should contain super message sends is in #superMessages.'! ! !RBMissingSuperSendsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:53'! group ^ 'Possible bugs'! ! !RBMissingSuperSendsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:53'! name ^ 'Missing super sends in selected methods.'! ! !RBMissingSuperSendsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:29'! category ^ 'Potential Bugs'! ! !RBMissingSuperSendsRule methodsFor: 'running' stamp: 'MarcusDenker 12/2/2013 14:08'! checkMethod: aContext | definer superMethod | (aContext selectedClass isMeta not and: [ self superMessages includes: aContext selector ]) ifTrue: [ definer := aContext selectedClass superclass ifNotNil: [ :sc | sc whichClassIncludesSelector: aContext selector ]. definer ifNotNil: [ "super defines same method" (aContext superMessages includes: aContext selector) ifFalse: [ "but I don't call it" superMethod := definer compiledMethodAt: aContext selector ifAbsent: [ ]. (superMethod isReturnSelf or: [ superMethod sendsSelector: #subclassResponsibility ]) ifFalse: [ result addClass: aContext selectedClass selector: aContext selector ] ] ] ]! ! !RBMissingSuperSendsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'MissingSuperSendsRule'! ! !RBMissingTranslationsInMenusRule methodsFor: 'initialization' stamp: 'lr 11/2/2009 22:15'! initialize super initialize. self matcher matchesAnyOf: #( '`@menu add: `#label action: `#sym' '`@menu add: `#label selector: `#sym arguments: `@stuff' '`@menu add: `#label subMenu: `@stuff target: `@targ selector: `#sel argumentList: `@args' '`@menu add: `#label subMenu: `@stuff' '`@menu add: `#label target: `@targ action: `#sel' '`@menu add: `#label target: `@targ selector `#sel argument: `@arg' '`@menu add: `#label target: `@targ selector `#sel arguments: `@arg' '`@menu add: `#label target: `@targ selector `#sel' '`@menu addList: `{ :n | n isLiteral and: [ n value isArray and: [ n value anySatisfy: [ :row | (row isKindOf: Array) and: [ row first isLiteral ] ] ] ] }' '`@menu addTitle: `#label updatingSelector: `#sel updateTarget: `@targ' '`@menu addTitle: `#label' '`@menu addWithLabel: `#label enablement: `#esel action: `#sel' '`@menu addWithLabel: `#label enablementSelector: `#esel target: `@targ selector: `#sel argumentList: `@args' '`@menu balloonTextForLastItem: `#label' '`@menu labels: `#lit lines: `@lines selections: `@sels' '`@menu title: `#title' ) do: [ :node :answer | node ]! ! !RBMissingTranslationsInMenusRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Literal strings shown to users in menus should be translated.'! ! !RBMissingTranslationsInMenusRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBMissingTranslationsInMenusRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Menus missing translations'! ! !RBMissingTranslationsInMenusRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'MissingTranslationsInMenusRule'! ! !RBMissingYourselfRule commentStamp: ''! When using cascaded messages, it is often important to finish the cascade with a yourself message. Why? for several reasons. First the messages in the cascade may not return the last receiver but the argument as in the well known case of adding elements in a collection. | col | col := (OrderedCollection new: 2) add: 1; add: 2. In this example, col will be assigned to 2 instead of an orderedCollection because add: returns its argument and not the receiver. The correct way to do it is using yourself (since yourself returns the receiver). | col | col := (OrderedCollection new: 2) add: 1; add: 2 ; yourself. Second case. Using yourself you can block the influence of redefined method. Imagine the following example: a method creating an instance, initializing it and returning it. Box class >> new | inst | inst := self new. inst initialize. ^ inst What this code ensures is that the instance is returned. Using ^ inst initialize would have return the same (but with the risk that if initialize did not return the receiver the new method would not return the right instance) The previous code can be expressed as follow: Box class >> new ^ self new initialize ; yourself Here yourself play the same role as the ^ inst above. ! !RBMissingYourselfRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:32'! initialize super initialize. self matcher matches: '`{:node | node isMessage and: [node parent isCascade and: [node isDirectlyUsed and: [node selector ~~ #yourself]]]}' do: [ :node :answer | node ]! ! !RBMissingYourselfRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for missing "; yourself" cascaded message send for cascaded messages that are used. This helps locate common coding mistakes such as "anArray := (Array new: 2) at: 1 put: 1; at: 2 put: 2". In this example, anArray would be assigned to 2 not the array object.'! ! !RBMissingYourselfRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBMissingYourselfRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Possible missing "; yourself"'! ! !RBMissingYourselfRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:24'! category ^ 'Potential Bugs'! ! !RBMissingYourselfRule methodsFor: '*Manifest-Core' stamp: 'Sd 11/30/2012 17:05'! longDescription ^ 'When using cascaded messages, it is often important to finish the cascade with a yourself message. Why? for several reasons. First the messages in the cascade may not return the last receiver but the argument as in the well known case of adding elements in a collection. | col | col := (OrderedCollection new: 2) add: 1; add: 2. In this example, col will be assigned to 2 instead of an orderedCollection because add: returns its argument and not the receiver. The correct way to do it is using yourself (since yourself returns the receiver). | col | col := (OrderedCollection new: 2) add: 1; add: 2 ; yourself. Second case. Using yourself you can block the influence of redefined method. Imagine the following example: a method creating an instance, initializing it and returning it. Box class >> new | inst | inst := self new. inst initialize. ^ inst What this code ensures is that the instance is returned. Using ^ inst initialize would have return the same (but with the risk that if initialize did not return the receiver the new method would not return the right instance) The previous code can be expressed as follow: Box class >> new ^ self new initialize ; yourself Here yourself play the same role as the ^ inst above. '! ! !RBMissingYourselfRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'MissingYourselfRule'! ! !RBModifiesCollectionRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:33'! initialize super initialize. self matcher matchesAnyOf: #( '`@object do: [:`each | | `@temps | ``@.Statements]' '`@object collect: [:`each | | `@temps | ``@.Statements]' '`@object select: [:`each | | `@temps | ``@.Statements]' '`@object reject: [:`each | | `@temps | ``@.Statements]' '`@object inject: `@value into: [:`sum :`each | | `@temps | ``@.Statements]') do: [ :node :answer | answer isNil ifTrue: [ (self modifiesTree: node receiver in: node arguments last) ifTrue: [ node ] ifFalse: [ nil ] ] ifFalse: [ answer ] ]! ! !RBModifiesCollectionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for remove:''s of elements inside of collection iteration methods such as do:. These can cause the do: method to break since it will walk of the end of the collection. The common fix for this problem is to copy the collection before iterating over it.'! ! !RBModifiesCollectionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBModifiesCollectionRule methodsFor: 'private' stamp: 'TestRunner 11/3/2009 16:33'! modifiesTree: aCollectionTree in: aParseTree | notifier args | notifier := RBParseTreeSearcher new. args := Array with: (RBPatternVariableNode named: '`@object'). notifier matchesAnyTreeOf: (#(add: addAll: remove: removeAll:) collect: [:each | RBMessageNode receiver: aCollectionTree selector: each arguments: args]) do: [:aNode :answer | true]. ^notifier executeTree: aParseTree initialAnswer: false! ! !RBModifiesCollectionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Modifies collection while iterating over it'! ! !RBModifiesCollectionRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:25'! category ^ 'Potential Bugs'! ! !RBModifiesCollectionRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ModifiesCollectionRule'! ! !RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: 'lr 11/2/2009 00:14'! checkForSuperReferences | searcher | searcher := RBParseTreeSearcher new. searcher matches: 'super `@message: `@args' do: [:aNode :answer | true]. (searcher executeTree: parseTree initialAnswer: false) ifTrue: [self refactoringError: 'Cannot move the method since it has a super message send.']! ! !RBMoveMethodRefactoring methodsFor: 'private-accessing' stamp: 'CamilloBruni 10/8/2012 00:07'! getClassForGlobalOrClassVariable | definingClass type | definingClass := class whoDefinesClassVariable: variable. definingClass isNil ifTrue: [type := self model classNamed: variable. type isNil ifTrue: [type := self model classNamed: #Object]] ifFalse: [type := definingClass typeOfClassVariable: variable]. moveToClasses := self selectVariableTypesFrom: (Array with: type) selected: (Array with: type). moveToClasses isNil ifTrue: [self refactoringFailure: 'Method not moved']! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: 'PabloHerrero 10/15/2013 16:30'! compileDelegatorMethod | statementNode delegatorNode tree | delegatorNode := RBMessageNode receiver: (RBVariableNode named: variable) selectorParts: parseTree selectorParts arguments: (parseTree argumentNames collect: [:each | RBVariableNode named: (each = selfVariableName ifTrue: ['self'] ifFalse: [each])]). self hasOnlySelfReturns ifFalse: [delegatorNode := RBReturnNode value: delegatorNode]. statementNode := RBSequenceNode temporaries: #() statements: (Array with: delegatorNode). (tree := class parseTreeFor: selector) body: statementNode. class compileTree: tree! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: 'PabloHerrero 10/15/2013 16:30'! transform self abstractVariables; addSelfReturn; replaceSelfReferences; replaceVariableReferences; compileNewMethods; compileDelegatorMethod! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''! abstractVariables self performComponentRefactoring: self abstractVariablesRefactoring. parseTree := self abstractVariablesRefactoring parseTree! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''! addSelfReturn self hasOnlySelfReturns ifTrue: [^self]. parseTree addSelfReturn! ! !RBMoveMethodRefactoring methodsFor: 'private-accessing' stamp: 'CamilloBruni 10/8/2012 00:07'! getClassesForInstanceVariable | definingClass typer types | definingClass := class whoDefinesInstanceVariable: variable. typer := RBRefactoryTyper newFor: self model. typer runOn: definingClass. types := typer typesFor: variable. types isEmpty ifTrue: [types := OrderedCollection with: (self model classNamed: #Object)]. moveToClasses := self selectVariableTypesFrom: types selected: (typer guessTypesFor: variable). moveToClasses isNil ifTrue: [self refactoringFailure: 'Method not moved']! ! !RBMoveMethodRefactoring methodsFor: 'initialize-release' stamp: ''! selector: aSymbol class: aClass variable: aVariableName selector := aSymbol. class := self classObjectFor: aClass. variable := aVariableName! ! !RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: 'lr 11/2/2009 00:14'! checkAssignmentsToVariable | searcher | searcher := RBParseTreeSearcher new. searcher matches: variable , ' := `@object' do: [:aNode :answer | true]. (searcher executeTree: parseTree initialAnswer: false) ifTrue: [self refactoringError: ('Cannot move the method into <1s> since it is assigned' expandMacrosWith: variable)]! ! !RBMoveMethodRefactoring methodsFor: 'testing' stamp: 'lr 11/2/2009 00:14'! hasSelfReferences | searcher | searcher := RBParseTreeSearcher new. searcher matches: 'self' do: [:aNode :answer | true]. self hasOnlySelfReturns ifTrue: [searcher matches: '^self' do: [:aNode :answer | answer]]. ^searcher executeTree: parseTree initialAnswer: false! ! !RBMoveMethodRefactoring methodsFor: 'testing' stamp: ''! isMovingToInstVar ^self isMovingToArgument not and: [(class whoDefinesInstanceVariable: variable) notNil]! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! abstractVariablesRefactoring ^RBAbstractVariablesRefactoring model: self model abstractVariablesIn: parseTree from: class toAll: moveToClasses ignoring: variable! ! !RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:07'! getNewMethodName | newSelector parameters alreadyDefined methodName newMethodName | self removeArgument. parameters := parseTree argumentNames asOrderedCollection. "parameters remove: variable ifAbsent: []." self needsToReplaceSelfReferences ifTrue: [parameters add: selfVariableName]. methodName := RBMethodName selector: (self uniqueMethodNameFor: parameters size) arguments: parameters. [newMethodName := self requestMethodNameFor: methodName. newMethodName isNil ifTrue: [self refactoringFailure: 'Did not move method']. newMethodName isValid ifTrue: [newSelector := newMethodName selector] ifFalse: [self refactoringWarning: 'Invalid method name']. parameters := newMethodName arguments. (self checkMethodName: newSelector in: class) ifFalse: [self refactoringWarning: newSelector , ' is not a valid selector name.'. newSelector := nil]. alreadyDefined := moveToClasses detect: [:each | each hierarchyDefinesMethod: newSelector] ifNone: [nil]. alreadyDefined notNil ifTrue: [self refactoringWarning: ('<1s> is already defined by <2p> or a super/subclassTry another?' expandMacrosWith: newSelector with: alreadyDefined). newSelector := nil]. newSelector isNil] whileTrue: []. parseTree renameSelector: newSelector andArguments: (parameters collect: [:each | RBVariableNode named: each]) asArray! ! !RBMoveMethodRefactoring methodsFor: 'private' stamp: 'CamilloBruni 10/7/2012 23:59'! buildParseTree parseTree := (class parseTreeFor: selector) copy. parseTree isNil ifTrue: [self refactoringFailure: 'Could not parse method']! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! replaceSelfReferences | replacer | self needsToReplaceSelfReferences ifTrue: [ replacer := RBParseTreeRewriter new. replacer replace: 'self' with: selfVariableName. self hasOnlySelfReturns ifTrue: [replacer replace: '^self' with: '^self']. replacer executeTree: parseTree. parseTree := replacer tree].! ! !RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: ''! checkTemporaryVariableNames | varNames | varNames := parseTree allDefinedVariables. selfVariableName notNil ifTrue: [varNames add: selfVariableName]. varNames do: [:name | moveToClasses do: [:each | (self canReferenceVariable: name in: each) ifTrue: [self refactoringError: ('<1p> already defines a variable called <2s>' expandMacrosWith: each with: name)]]]! ! !RBMoveMethodRefactoring methodsFor: 'testing' stamp: ''! isMovingToArgument ^(parseTree arguments collect: [:each | each name]) includes: variable! ! !RBMoveMethodRefactoring methodsFor: 'private-accessing' stamp: 'CamilloBruni 10/8/2012 00:07'! getClassesForTemporaryVariable | types | types := RBRefactoryTyper typesFor: variable in: parseTree model: self model. types isEmpty ifTrue: [types := OrderedCollection with: (self model classNamed: #Object)]. moveToClasses := self selectVariableTypesFrom: types selected: types. moveToClasses isNil ifTrue: [self refactoringFailure: 'Method not moved']! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! hasOnlySelfReturns ^hasOnlySelfReturns isNil ifTrue: [| searcher | searcher := RBParseTreeSearcher new. searcher matches: '^self' do: [:aNode :answer | answer]; matches: '^`@object' do: [:aNode :answer | false]. hasOnlySelfReturns := searcher executeTree: parseTree initialAnswer: true] ifFalse: [hasOnlySelfReturns]! ! !RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [self buildParseTree. self checkForPrimitiveMethod. self checkForSuperReferences. self checkAssignmentsToVariable. self getClassesToMoveTo. self getArgumentNameForSelf. self checkTemporaryVariableNames. self getNewMethodName. true])! ! !RBMoveMethodRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' selector: #'; nextPutAll: selector; nextPutAll: ' class: '. class storeOn: aStream. aStream nextPutAll: ' variable: '''; nextPutAll: variable; nextPutAll: ''')'! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: 'rr 3/16/2004 15:15'! removeArgument "Removes the excess argument if any. This argument is the variable which is referenced by self in the classes the method is moved to. " | removeIndex | removeIndex := parseTree argumentNames indexOf: variable. removeIndex = 0 ifFalse: [parseTree arguments: ((parseTree arguments asOrderedCollection) removeAt: removeIndex; yourself) asArray. parseTree selectorParts: ((parseTree selectorParts asOrderedCollection) removeAt: removeIndex; yourself) asArray].! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: 'lr 1/3/2010 11:48'! verifyTemporaryVariableDoesNotOverride (parseTree allDefinedVariables includes: selfVariableName) ifTrue: [ ^ false ]. ^ moveToClasses noneSatisfy: [ :each | each definesVariable: selfVariableName ]! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/1/2009 23:05'! compileNewMethods moveToClasses do: [:each | each compile: parseTree newSource withAttributesFrom: (class methodFor: selector)]! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! replaceVariableReferences | replacer | replacer := RBParseTreeRewriter new. replacer replace: variable with: 'self'. replacer executeTree: parseTree. parseTree := replacer tree! ! !RBMoveMethodRefactoring methodsFor: 'private-accessing' stamp: 'CamilloBruni 10/8/2012 00:07'! getClassesToMoveTo self isMovingToArgument ifTrue: [self getClassesForTemporaryVariable] ifFalse: [self isMovingToInstVar ifTrue: [self getClassesForInstanceVariable] ifFalse: [self getClassForGlobalOrClassVariable]]. moveToClasses isEmpty ifTrue: [self refactoringFailure: 'No classes selected, method not moved.']! ! !RBMoveMethodRefactoring methodsFor: 'preconditions' stamp: ''! checkForPrimitiveMethod parseTree isPrimitive ifTrue: [self refactoringError: 'Cannot move primitive methods']! ! !RBMoveMethodRefactoring methodsFor: 'transforming' stamp: ''! getArgumentNameForSelf self needsToReplaceSelfReferences ifFalse: [^self]. [selfVariableName := self requestSelfArgumentName. (self checkInstanceVariableName: selfVariableName in: class) ifTrue: [self verifyTemporaryVariableDoesNotOverride ifFalse: [self refactoringWarning: 'The variable is already defined in one of the classes you''re moving the method to.Try another?' expandMacros. selfVariableName := nil]] ifFalse: [self refactoringWarning: 'The variable name is not a valid Smalltalk temporary variable nameTry again?' expandMacros. selfVariableName := nil]. selfVariableName isNil] whileTrue: []! ! !RBMoveMethodRefactoring methodsFor: 'testing' stamp: ''! needsToReplaceSelfReferences ^self hasSelfReferences or: [self abstractVariablesRefactoring hasVariablesToAbstract]! ! !RBMoveMethodRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk selector: aSymbol class: aClass variable: aVariableName ^(self new) model: aRBSmalltalk; selector: aSymbol class: aClass variable: aVariableName; yourself! ! !RBMoveMethodRefactoring class methodsFor: 'instance creation' stamp: ''! selector: aSymbol class: aClass variable: aVariableName ^(self new) selector: aSymbol class: aClass variable: aVariableName; yourself! ! !RBMoveMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testMoveMethodIntoInstanceVariable | refactoring class | self proceedThroughWarning: [ refactoring := RBMoveMethodRefactoring selector: #checkMethod: class: RBTransformationRuleTest variable: 'rewriteRule'. self setupSelfArgumentNameFor: refactoring toReturn: 'transformationRule'. self setupVariableTypesFor: refactoring toReturn: (Array with: (refactoring model classNamed: #RBParseTreeRewriter)). self setupMethodNameFor: refactoring toReturn: #foo:foo: withArguments: #('transformationRule' 'aSmalllintContext' ). self executeRefactoring: refactoring ]. class := refactoring model classNamed: #RBTransformationRuleTest. self assert: (class parseTreeFor: #checkMethod:) = (RBParser parseMethod: 'checkMethod: aSmalllintContext rewriteRule foo: self foo: aSmalllintContext'). self assert: ((refactoring model classNamed: #RBParseTreeRewriter) parseTreeFor: #foo:foo:) = (RBParser parseMethod: 'foo: transformationRule foo: aSmalllintContext transformationRule class: aSmalllintContext selectedClass. (self executeTree: aSmalllintContext parseTree) ifTrue: [(transformationRule class recursiveSelfRule executeTree: self tree initialAnswer: false) ifFalse: [transformationRule builder compile: self tree printString in: transformationRule class1 classified: aSmalllintContext protocols]]'). self assert: (class parseTreeFor: #class1) = (RBParser parseMethod: 'class1 ^class'). self assert: (class parseTreeFor: #class:) = (RBParser parseMethod: 'class: anObject class := anObject'). self assert: (class theMetaClass parseTreeFor: #recursiveSelfRule:) = (RBParser parseMethod: 'recursiveSelfRule: anObject RecursiveSelfRule := anObject'). self assert: (class theMetaClass parseTreeFor: #recursiveSelfRule) = (RBParser parseMethod: 'recursiveSelfRule ^RecursiveSelfRule'). self assert: (class parseTreeFor: #builder) = (RBParser parseMethod: 'builder ^builder'). self assert: (class parseTreeFor: #builder:) = (RBParser parseMethod: 'builder: anObject builder := anObject')! ! !RBMoveMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMovePrimitiveMethod | refactoring | (model classNamed: #Object) compile: 'foo ^#() primitiveFailed' classified: #(#accessing). refactoring := RBMoveMethodRefactoring model: model selector: #foo class: Object variable: 'OrderedCollection'. self shouldFail: refactoring! ! !RBMoveMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testMoveMethodThatReferencesPoolDictionary | refactoring class | self proceedThroughWarning: [ refactoring := RBMoveMethodRefactoring selector: #junk class: RBLintRuleTest variable: 'RefactoryTestDataApp'. self setupSelfArgumentNameFor: refactoring toReturn: 'transformationRule'. self setupVariableTypesFor: refactoring toReturn: (Array with: (refactoring model classNamed: 'RBRefactoryTestDataApp class' asSymbol)). self setupMethodNameFor: refactoring toReturn: #junk1. self executeRefactoring: refactoring ]. class := refactoring model classNamed: #RBLintRuleTest. self assert: (class parseTreeFor: #junk) = (RBParser parseMethod: 'junk ^RefactoryTestDataApp junk1'). self assert: ((refactoring model metaclassNamed: #RBRefactoryTestDataApp) parseTreeFor: #junk1) = (RBParser parseMethod: 'junk1 ^RBRefactoryTestDataApp printString copyFrom: 1 to: CR'). self assert: (class directlyDefinesPoolDictionary: 'TextConstants' asSymbol)! ! !RBMoveMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testMoveMethodIntoClassVariable | refactoring class | self proceedThroughWarning: [ refactoring := RBMoveMethodRefactoring selector: #checkMethod: class: RBTransformationRuleTest variable: 'RecursiveSelfRule'. self setupSelfArgumentNameFor: refactoring toReturn: 'transformationRule'. self setupVariableTypesFor: refactoring toReturn: (Array with: (refactoring model classNamed: #RBParseTreeSearcher)). self setupMethodNameFor: refactoring toReturn: #foo:foo: withArguments: #('transformationRule' 'aSmalllintContext' ). self executeRefactoring: refactoring ]. class := refactoring model classNamed: #RBTransformationRuleTest. self assert: (class parseTreeFor: #checkMethod:) = (RBParser parseMethod: 'checkMethod: aSmalllintContext RecursiveSelfRule foo: self foo: aSmalllintContext'). self assert: ((refactoring model classNamed: #RBParseTreeSearcher) parseTreeFor: #foo:foo:) = (RBParser parseMethod: 'foo: transformationRule foo: aSmalllintContext transformationRule class: aSmalllintContext selectedClass. (transformationRule rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: [(self executeTree: transformationRule rewriteRule tree initialAnswer: false) ifFalse: [transformationRule builder compile: transformationRule rewriteRule tree printString in: transformationRule class1 classified: aSmalllintContext protocols]]'). self assert: (class parseTreeFor: #class1) = (RBParser parseMethod: 'class1 ^class'). self assert: (class parseTreeFor: #class:) = (RBParser parseMethod: 'class: anObject class := anObject'). self assert: (class parseTreeFor: #builder) = (RBParser parseMethod: 'builder ^builder'). self assert: (class parseTreeFor: #builder:) = (RBParser parseMethod: 'builder: anObject builder := anObject'). self assert: (class parseTreeFor: #rewriteRule) = (RBParser parseMethod: 'rewriteRule ^rewriteRule'). self assert: (class parseTreeFor: #rewriteRule:) = (RBParser parseMethod: 'rewriteRule: anObject rewriteRule := anObject')! ! !RBMoveMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:15'! testMoveMethodIntoArgument | refactoring class | self proceedThroughWarning: [ refactoring := RBMoveMethodRefactoring selector: #checkMethod: class: RBTransformationRuleTest variable: 'aSmalllintContext'. self setupSelfArgumentNameFor: refactoring toReturn: 'transformationRule'. self setupVariableTypesFor: refactoring toReturn: (Array with: (refactoring model classNamed: #RBSmalllintContext)). self setupMethodNameFor: refactoring toReturn: #foo:. self executeRefactoring: refactoring ]. class := refactoring model classNamed: #RBTransformationRuleTest. self assert: (class parseTreeFor: #checkMethod:) = (RBParser parseMethod: 'checkMethod: aSmalllintContext aSmalllintContext foo: self'). self assert: ((refactoring model classNamed: #RBSmalllintContext) parseTreeFor: #foo:) = (RBParser parseMethod: 'foo: transformationRule transformationRule class: self selectedClass. (transformationRule rewriteRule executeTree: self parseTree) ifTrue: [(transformationRule class recursiveSelfRule executeTree: transformationRule rewriteRule tree initialAnswer: false) ifFalse: [transformationRule builder compile: transformationRule rewriteRule tree printString in: transformationRule class1 classified: self protocols]]'). self assert: (class parseTreeFor: #class1) = (RBParser parseMethod: 'class1 ^class'). self assert: (class parseTreeFor: #class:) = (RBParser parseMethod: 'class: anObject class := anObject'). self assert: (class theMetaClass parseTreeFor: #recursiveSelfRule:) = (RBParser parseMethod: 'recursiveSelfRule: anObject RecursiveSelfRule := anObject'). self assert: (class theMetaClass parseTreeFor: #recursiveSelfRule) = (RBParser parseMethod: 'recursiveSelfRule ^RecursiveSelfRule'). self assert: (class parseTreeFor: #builder) = (RBParser parseMethod: 'builder ^builder'). self assert: (class parseTreeFor: #builder:) = (RBParser parseMethod: 'builder: anObject builder := anObject'). self assert: (class parseTreeFor: #rewriteRule) = (RBParser parseMethod: 'rewriteRule ^rewriteRule'). self assert: (class parseTreeFor: #rewriteRule:) = (RBParser parseMethod: 'rewriteRule: anObject rewriteRule := anObject')! ! !RBMoveVariableDefinitionRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:06'! checkParseTree | node | blockNodes := OrderedCollection new. node := self whichVariableNode: parseTree inInterval: interval name: name. node isNil ifTrue: [self refactoringFailure: 'Unable to locate node in parse tree']. definingNode := node whoDefines: name. definingNode isNil ifTrue: [self refactoringFailure: 'Cannot locate variable definition']. definingNode isSequence ifFalse: [self refactoringError: 'Variable is an argument']. (self usesDirectly: definingNode) ifTrue: [self refactoringError: 'Variable already bound tightly as possible']. (self checkNodes: (self subblocksIn: definingNode)) ifFalse: [self refactoringError: 'Variable is possibly read before written']! ! !RBMoveVariableDefinitionRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:06'! preconditions ^(RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [| methodSource | interval first <= interval last ifFalse: [self refactoringFailure: 'Invalid variable name']. methodSource := class sourceCodeFor: selector. methodSource size >= interval last ifFalse: [self refactoringFailure: 'Invalid range for variable']. name := methodSource copyFrom: interval first to: interval last. (self checkInstanceVariableName: name in: class) ifFalse: [self refactoringFailure: name , ' does not seem to be a valid variable name.']. parseTree := class parseTreeFor: selector. self checkParseTree. true])! ! !RBMoveVariableDefinitionRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' bindTight: '. interval storeOn: aStream. aStream nextPutAll: ' in: '. class storeOn: aStream. aStream nextPutAll: ' selector: #'; nextPutAll: selector. aStream nextPut: $)! ! !RBMoveVariableDefinitionRefactoring methodsFor: 'transforming' stamp: ''! transform definingNode removeTemporaryNamed: name. blockNodes do: [:each | each body addTemporaryNamed: name]. class compileTree: parseTree! ! !RBMoveVariableDefinitionRefactoring methodsFor: 'transforming' stamp: ''! checkNodes: sequenceNodes (sequenceNodes detect: [:each | RBReadBeforeWrittenTester isVariable: name readBeforeWrittenIn: each] ifNone: [nil]) notNil ifTrue: [^false]. sequenceNodes do: [:each | (self usesDirectly: each body) ifTrue: [blockNodes add: each] ifFalse: [(self checkNodes: (self subblocksIn: each body)) ifFalse: [blockNodes add: each]]]. ^true! ! !RBMoveVariableDefinitionRefactoring methodsFor: 'initialize-release' stamp: ''! class: aClass selector: aSelector interval: anInterval interval := anInterval. class := self classObjectFor: aClass. selector := aSelector! ! !RBMoveVariableDefinitionRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! usesDirectly: aParseTree | searcher | searcher := RBParseTreeSearcher new. searcher matches: '[:`@args | | `@temps | `@.Statements]' do: [:aNode :answer | answer]; matches: name do: [:aNode :answer | true]. ^searcher executeTree: aParseTree initialAnswer: false! ! !RBMoveVariableDefinitionRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! subblocksIn: aParseTree | searcher | searcher := RBParseTreeSearcher new. searcher matches: '[:`@blockTemps | | `@temps | `@.Statements]' do: [:aNode :answer | (aNode references: name) ifTrue: [answer add: aNode]. answer]. ^searcher executeTree: aParseTree initialAnswer: OrderedCollection new! ! !RBMoveVariableDefinitionRefactoring class methodsFor: 'instance creation' stamp: ''! bindTight: anInterval in: aClass selector: aSelector ^self new class: aClass selector: aSelector interval: anInterval! ! !RBMoveVariableDefinitionRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk bindTight: anInterval in: aClass selector: aSelector ^(self new) model: aRBSmalltalk; class: aClass selector: aSelector interval: anInterval; yourself! ! !RBMoveVariableDefinitionTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testMoveDefinition | refactoring | refactoring := RBMoveVariableDefinitionRefactoring bindTight: (self convertInterval: (19 to: 22) for: (RBRefactoryTestDataApp sourceCodeAt: #moveDefinition)) in: RBRefactoryTestDataApp selector: #moveDefinition. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #moveDefinition) = (RBParser parseMethod: 'moveDefinition ^(self collect: [:each | | temp | temp := each printString. temp , temp]) select: [:each | | temp | temp := each size. temp odd]')! ! !RBMoveVariableDefinitionTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBMoveVariableDefinitionRefactoring bindTight: (1 to: 10) in: RBLintRuleTest selector: #name1); shouldFail: (RBMoveVariableDefinitionRefactoring bindTight: (self convertInterval: (44 to: 54) for: (RBLintRuleTest sourceCodeAt: #displayName)) in: RBLintRuleTest selector: #displayName); shouldFail: (RBMoveVariableDefinitionRefactoring bindTight: (self convertInterval: (16 to: 25) for: (RBLintRuleTest sourceCodeAt: #displayName)) in: RBLintRuleTest selector: #displayName)! ! !RBMoveVariableDefinitionTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testNoMoveDefinition self shouldFail: (RBMoveVariableDefinitionRefactoring bindTight: (self convertInterval: (21 to: 24) for: (RBRefactoryTestDataApp sourceCodeAt: #moveDefinition)) in: RBRefactoryTestDataApp selector: #noMoveDefinition)! ! !RBMoveVariableDefinitionTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testMoveDefinitionIntoBlockThatIsAReceiverOfACascadedMessage | refactoring | refactoring := RBMoveVariableDefinitionRefactoring bindTight: (self convertInterval: (48 to: 58) for: (RBRefactoryTestDataApp sourceCodeAt: #referencesConditionFor:)) in: RBRefactoryTestDataApp selector: #referencesConditionFor:. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) parseTreeFor: #referencesConditionFor:) = (RBParser parseMethod: 'referencesConditionFor: aClass | environment | ^(RBCondition withBlock: [| association |association := Smalltalk associationAt: aClass name ifAbsent: [self refactoringError: ''Could not find class'']. environment := (self environment referencesTo: association) | (self environment referencesTo: aClass name). environment isEmpty]) errorMacro: aClass , '' is referenced.Browse references?''; errorBlock: [environment openEditor]; yourself')! ! !RBMultiEnvironment methodsFor: 'testing' stamp: 'lr 3/13/2009 11:52'! includesClass: aClass ^ (super includesClass: aClass) and: [ environmentDictionaries anySatisfy: [ :env | env includesClass: aClass ] ]! ! !RBMultiEnvironment methodsFor: '*Manifest-CriticBrowser' stamp: 'SimonAllier 3/30/2012 11:43'! isMultiEnvironment ^ true! ! !RBMultiEnvironment methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! asSelectorEnvironment | s | s := RBSelectorEnvironment new. s label: self label. environmentDictionaries do: [:each | | env | env := each asSelectorEnvironment. env classesDo: [:cls | env selectorsForClass: cls do: [:sel | s addClass: cls selector: sel]]]. ^ s ! ! !RBMultiEnvironment methodsFor: 'testing' stamp: ''! isEmpty ^environmentDictionaries isEmpty! ! !RBMultiEnvironment methodsFor: 'removing' stamp: 'lr 9/8/2011 20:32'! removeClass: aClass selector: aSelector into: aValue (environmentDictionaries at: aValue ifAbsentPut: [RBSelectorEnvironment new]) removeClass: aClass selector: aSelector! ! !RBMultiEnvironment methodsFor: 'testing' stamp: 'lr 3/13/2009 11:53'! includesCategory: aCategory ^ (super includesCategory: aCategory) and: [ environmentDictionaries anySatisfy: [ :env | env includesCategory: aCategory ] ]! ! !RBMultiEnvironment methodsFor: 'testing' stamp: 'lr 3/13/2009 11:53'! includesSelector: aSelector in: aClass ^ (super includesSelector: aSelector in: aClass) and: [ environmentDictionaries anySatisfy: [ :env | env includesSelector: aSelector in: aClass ] ]! ! !RBMultiEnvironment methodsFor: 'adding' stamp: 'lr 9/8/2011 20:32'! addClass: aClass into: aValue (environmentDictionaries at: aValue ifAbsentPut: [RBSelectorEnvironment new]) addClass: aClass! ! !RBMultiEnvironment methodsFor: 'initialization' stamp: 'lr 9/8/2011 20:32'! initialize super initialize. environmentDictionaries := Dictionary new. environment := RBSelectorEnvironment new! ! !RBMultiEnvironment methodsFor: 'testing' stamp: 'lr 3/13/2009 11:54'! includesProtocol: aProtocol in: aClass ^ (super includesProtocol: aProtocol in: aClass) and: [ environmentDictionaries anySatisfy: [ :env | env includesProtocol: aProtocol in: aClass ] ]! ! !RBMultiEnvironment methodsFor: 'adding' stamp: 'lr 9/8/2011 20:32'! addClass: aClass selector: aSymbol into: aValue (environmentDictionaries at: aValue ifAbsentPut: [RBSelectorEnvironment new]) addClass: aClass selector: aSymbol! ! !RBMultiEnvironment methodsFor: 'accessing' stamp: ''! problemCount ^environmentDictionaries size! ! !RBMultiEnvironment methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! selectEnvironment: aValue environment := environmentDictionaries at: aValue ifAbsent: [RBSelectorEnvironment new]! ! !RBMultiEnvironment methodsFor: 'removing' stamp: 'lr 9/8/2011 20:32'! removeClass: aClass into: aValue (environmentDictionaries at: aValue ifAbsent: [RBSelectorEnvironment new]) removeClass: aClass! ! !RBMultiEnvironment methodsFor: '*Manifest-CriticBrowser' stamp: 'SimonAllier 3/27/2013 10:14'! smallLintCritics ^ self asSelectorEnvironment smallLintCritics! ! !RBMultiEnvironment methodsFor: 'accessing' stamp: ''! environments ^environmentDictionaries keys! ! !RBMultiEnvironment methodsFor: '*Manifest-CriticBrowser' stamp: 'MarcusDenker 10/2/2013 20:17'! removeClass: aClass environmentDictionaries keysDo: [ :key | (environmentDictionaries at: key) removeClass: aClass ]! ! !RBMultiKeywordLiteralToken methodsFor: 'testing' stamp: ''! isMultiKeyword ^true! ! !RBNamespace methodsFor: 'testing' stamp: ''! includesClassNamed: aSymbol ^(self classNamed: aSymbol) notNil! ! !RBNamespace methodsFor: 'accessing' stamp: ''! changes ^changes! ! !RBNamespace methodsFor: 'testing' stamp: ''! includesGlobal: aSymbol (self hasRemoved: aSymbol) ifTrue: [^false]. (self includesClassNamed: aSymbol) ifTrue: [^true]. environment at: aSymbol ifAbsent: [^false]. ^true! ! !RBNamespace methodsFor: 'accessing' stamp: 'lr 1/20/2010 18:08'! description ^ self changes name! ! !RBNamespace methodsFor: 'accessing-classes' stamp: 'lr 10/31/2009 17:35'! classFor: aBehavior aBehavior isNil ifTrue: [ ^ nil ]. ^ aBehavior isMeta ifTrue: [ self metaclassNamed: aBehavior theNonMetaClass name ] ifFalse: [ self classNamed: aBehavior theNonMetaClass name ]! ! !RBNamespace methodsFor: 'private-changes' stamp: ''! addInstanceVariable: aString to: aRBClass ^changes addInstanceVariable: aString to: aRBClass! ! !RBNamespace methodsFor: 'accessing' stamp: ''! allReferencesToClass: aRBClass do: aBlock self allClassesDo: [:each | (each whichSelectorsReferToClass: aRBClass) do: [:sel | aBlock value: (each methodFor: sel)]]! ! !RBNamespace methodsFor: 'private' stamp: 'SebastianTleye 8/1/2013 16:11'! privateImplementorsOf: aSelector | classes | classes := Set new. self allClassesDo: [ :class | (class directlyDefinesLocalMethod: aSelector) ifTrue: [ classes add: class ] ]. ^ classes! ! !RBNamespace methodsFor: 'private' stamp: 'lr 4/7/2010 13:45'! privateRootClasses | classes | classes := OrderedCollection new. Class rootsOfTheWorld do: [ :each | | class | class := self classFor: each. (class notNil and: [ class superclass isNil ]) ifTrue: [ classes add: class ] ]. ^ classes! ! !RBNamespace methodsFor: 'private-changes' stamp: ''! removeInstanceVariable: aString from: aRBClass ^changes removeInstanceVariable: aString from: aRBClass! ! !RBNamespace methodsFor: 'changes' stamp: ''! reparentClasses: aRBClassCollection to: newClass aRBClassCollection do: [:aClass | self defineClass: (self replaceClassNameIn: aClass definitionString to: newClass name)]! ! !RBNamespace methodsFor: 'accessing-classes' stamp: ''! whichCategoryIncludes: aSymbol ^self environment whichCategoryIncludes: aSymbol! ! !RBNamespace methodsFor: 'private-changes' stamp: ''! compile: aString in: aRBClass classified: aSymbol | change | change := changes compile: aString in: aRBClass classified: aSymbol. self flushCaches. ^change! ! !RBNamespace methodsFor: 'accessing-classes' stamp: 'lr 10/26/2009 22:09'! classNamed: aSymbol | class classes index | aSymbol isNil ifTrue: [ ^ nil ]. (self hasRemoved: aSymbol) ifTrue: [ ^ nil ]. (newClasses includesKey: aSymbol) ifTrue: [ ^ (newClasses at: aSymbol) first ]. (changedClasses includesKey: aSymbol) ifTrue: [ ^ (changedClasses at: aSymbol) first ]. class := environment at: aSymbol ifAbsent: [ nil ]. (class isBehavior or: [ class isTrait ]) ifTrue: [ classes := self createNewClassFor: class. ^ class isMeta ifTrue: [ classes last ] ifFalse: [ classes first ] ]. index := aSymbol indexOfSubCollection: ' class' startingAt: 1 ifAbsent: [ ^ nil ]. class := self classNamed: (aSymbol copyFrom: 1 to: index - 1) asSymbol. ^ class isNil ifTrue: [ nil ] ifFalse: [ class theMetaClass ]! ! !RBNamespace methodsFor: 'accessing' stamp: 'lr 4/7/2010 13:44'! allReferencesTo: aSymbol do: aBlock (self allReferencesTo: aSymbol) do: aBlock! ! !RBNamespace methodsFor: 'private-changes' stamp: 'lr 10/26/2009 22:09'! addChangeToClass: aRBClass ^ changedClasses at: aRBClass name put: (Array with: aRBClass theNonMetaClass with: aRBClass theMetaClass)! ! !RBNamespace methodsFor: 'private-changes' stamp: ''! addClassVariable: aString to: aRBClass ^changes addClassVariable: aString to: aRBClass! ! !RBNamespace methodsFor: 'private' stamp: 'lr 10/31/2009 17:37'! classNameFor: aBehavior ^ aBehavior theNonMetaClass name! ! !RBNamespace methodsFor: 'accessing' stamp: ''! environment ^environment! ! !RBNamespace methodsFor: 'private' stamp: ''! hasCreatedClassFor: aBehavior | className | className := self classNameFor: aBehavior. ^(newClasses includesKey: className) or: [changedClasses includesKey: className]! ! !RBNamespace methodsFor: 'accessing' stamp: 'lr 3/17/2010 19:11'! allClassesDo: aBlock | seen evalBlock | seen := Set new. evalBlock := [ :each | seen add: each first name. aBlock value: each first; value: each last ]. newClasses do: evalBlock. changedClasses do: evalBlock. environment classesDo: [ :each | each isObsolete ifFalse: [ | class | class := each theNonMetaClass. ((seen includes: class name) or: [ self hasRemoved: (self classNameFor: class) ]) ifFalse: [ (class := self classFor: each) isNil ifFalse: [ seen add: class name. aBlock value: class; value: class theMetaClass ] ] ] ]! ! !RBNamespace methodsFor: 'accessing' stamp: 'lr 4/7/2010 18:53'! allImplementorsOf: aSelector do: aBlock (self allImplementorsOf: aSelector) do: aBlock! ! !RBNamespace methodsFor: 'accessing' stamp: 'lr 4/7/2010 13:44'! allReferencesTo: aSymbol ^ sendersCache at: aSymbol ifAbsentPut: [ self privateReferencesTo: aSymbol ]! ! !RBNamespace methodsFor: 'changes' stamp: 'MartinDias 11/7/2013 18:11'! defineClass: aString | change newClass newClassName | change := changes defineClass: aString. newClassName := change changeClassName. newClass := self classNamed: newClassName. newClass isNil ifTrue: [ | newMetaclass | removedClasses remove: newClassName ifAbsent: [ ]; remove: newClassName , ' class' ifAbsent: [ ]. newClass := RBClass named: newClassName. newMetaclass := RBMetaclass named: newClassName. newClass model: self. newMetaclass model: self. newClasses at: newClassName put: (Array with: newClass with: newMetaclass) ]. newClass superclass: (self classNamed: change superclassName). newClass superclass isNil ifTrue: [ self rootClasses add: newClass. newClass theMetaClass superclass: (self classFor: Object class superclass) ] ifFalse: [ newClass theMetaClass superclass: newClass superclass theMetaClass ]. newClass instanceVariableNames: change instanceVariableNames. newClass classVariableNames: change classVariableNames. newClass poolDictionaryNames: change sharedPoolNames. newClass category: change category. ^ change! ! !RBNamespace methodsFor: 'accessing' stamp: 'lr 1/20/2010 18:08'! description: aString self changes name: aString! ! !RBNamespace methodsFor: 'accessing' stamp: ''! environment: aBrowserEnvironment environment := aBrowserEnvironment! ! !RBNamespace methodsFor: 'initialization' stamp: 'lr 9/8/2011 20:25'! initialize changes := RBCompositeRefactoryChange new. environment := RBBrowserEnvironment new. newClasses := IdentityDictionary new. changedClasses := IdentityDictionary new. removedClasses := Set new. implementorsCache := IdentityDictionary new. sendersCache := IdentityDictionary new! ! !RBNamespace methodsFor: 'private-changes' stamp: ''! replaceClassNameIn: definitionString to: aSymbol | parseTree | parseTree := RBParser parseExpression: definitionString. parseTree receiver: (RBVariableNode named: aSymbol). ^parseTree formattedCode! ! !RBNamespace methodsFor: 'accessing' stamp: 'lr 4/7/2010 13:38'! rootClasses ^ rootClasses ifNil: [ rootClasses := self privateRootClasses]! ! !RBNamespace methodsFor: 'changes' stamp: ''! removeClass: aRBClass self removeClassNamed: aRBClass name! ! !RBNamespace methodsFor: 'changes' stamp: 'lr 9/8/2011 20:10'! renameClass: aRBClass to: aSymbol around: aBlock | change value dict | change := RBRenameClassChange rename: aRBClass name to: aSymbol. self performChange: change around: aBlock. self flushCaches. dict := (newClasses includesKey: aRBClass name) ifTrue: [newClasses] ifFalse: [changedClasses]. removedClasses add: aRBClass name; add: aRBClass name , ' class'. value := dict at: aRBClass name. dict removeKey: aRBClass name. dict at: aSymbol put: value. value first name: aSymbol. value last name: aSymbol. value first subclasses do: [:each | each superclass: value first]. value last subclasses do: [:each | each superclass: value last]. ^change! ! !RBNamespace methodsFor: 'changes' stamp: 'lr 7/1/2008 11:06'! comment: aString in: aClass ^ changes comment: aString in: aClass! ! !RBNamespace methodsFor: 'private-changes' stamp: ''! removeMethod: aSelector from: aRBClass self flushCaches. ^changes removeMethod: aSelector from: aRBClass! ! !RBNamespace methodsFor: 'changes' stamp: ''! removeClassNamed: aSymbol (self classNamed: aSymbol) subclasses do: [:each | self removeClassNamed: each name]. removedClasses add: aSymbol; add: aSymbol , ' class'. newClasses removeKey: aSymbol ifAbsent: []. changedClasses removeKey: aSymbol ifAbsent: []. self flushCaches. ^changes removeClassNamed: aSymbol! ! !RBNamespace methodsFor: 'private-changes' stamp: 'lr 10/26/2009 22:09'! changeClass: aRBClass changedClasses at: aRBClass name put: (Array with: aRBClass theNonMetaClass with: aRBClass theMetaClass). self flushCaches! ! !RBNamespace methodsFor: 'private-changes' stamp: ''! addPool: aString to: aRBClass ^changes addPool: aString to: aRBClass! ! !RBNamespace methodsFor: 'private-changes' stamp: ''! flushCaches implementorsCache := IdentityDictionary new. sendersCache := IdentityDictionary new! ! !RBNamespace methodsFor: 'private-changes' stamp: ''! performChange: aCompositeRefactoryChange around: aBlock | oldChanges | changes addChange: aCompositeRefactoryChange. oldChanges := changes. changes := aCompositeRefactoryChange. aBlock ensure: [changes := oldChanges]. ^aCompositeRefactoryChange! ! !RBNamespace methodsFor: 'accessing' stamp: ''! name: aString ^changes name: aString! ! !RBNamespace methodsFor: 'private' stamp: 'lr 4/7/2010 13:45'! privateReferencesTo: aSelector | methods | methods := OrderedCollection new. self allClassesDo: [ :class | (class whichSelectorsReferToSymbol: aSelector) do: [ :selector | methods add: (class methodFor: selector) ] ]. ^ methods! ! !RBNamespace methodsFor: 'private-changes' stamp: 'lr 9/8/2011 20:10'! renameInstanceVariable: oldName to: newName in: aRBClass around: aBlock ^self performChange: (RBRenameInstanceVariableChange rename: oldName to: newName in: aRBClass) around: aBlock! ! !RBNamespace methodsFor: 'private-changes' stamp: 'lr 9/8/2011 20:10'! renameClassVariable: oldName to: newName in: aRBClass around: aBlock ^self performChange: (RBRenameClassVariableChange rename: oldName to: newName in: aRBClass) around: aBlock! ! !RBNamespace methodsFor: 'accessing-classes' stamp: 'lr 10/31/2009 17:36'! createNewClassFor: aBehavior | nonMeta meta className | className := aBehavior theNonMetaClass name. nonMeta := (RBClass existingNamed: className) model: self; yourself. meta := (RBMetaclass existingNamed: className) model: self; yourself. ^changedClasses at: className put: (Array with: nonMeta with: meta)! ! !RBNamespace methodsFor: 'accessing' stamp: 'lr 4/7/2010 13:40'! allImplementorsOf: aSelector ^ implementorsCache at: aSelector ifAbsentPut: [ self privateImplementorsOf: aSelector ]! ! !RBNamespace methodsFor: 'testing' stamp: ''! hasRemoved: aSymbol ^removedClasses includes: aSymbol! ! !RBNamespace methodsFor: 'accessing-classes' stamp: 'dc 5/8/2007 13:44'! metaclassNamed: aSymbol | class | aSymbol isNil ifTrue: [^nil]. (self hasRemoved: aSymbol) ifTrue: [^nil]. (newClasses includesKey: aSymbol) ifTrue: [^(newClasses at: aSymbol) last]. (changedClasses includesKey: aSymbol) ifTrue: [^(changedClasses at: aSymbol) last]. class := environment at: aSymbol ifAbsent: [nil]. (class isBehavior or: [class isTrait]) ifTrue: [^ (self createNewClassFor: class) last]. ^ nil! ! !RBNamespace methodsFor: 'private-changes' stamp: ''! removeClassVariable: aString from: aRBClass ^changes removeClassVariable: aString from: aRBClass! ! !RBNamespace methodsFor: 'accessing' stamp: ''! name ^changes name! ! !RBNamespace class methodsFor: 'instance creation' stamp: ''! onEnvironment: aBrowserEnvironment ^(self new) environment: aBrowserEnvironment; yourself! ! !RBNamespaceTest methodsFor: 'class tests' stamp: 'lr 3/17/2010 18:51'! testReferencesPrintOnAfterRemove | hasFoundObject hasFoundSelf smalltalk | hasFoundObject := false. hasFoundSelf := false. smalltalk := RBNamespace new. (smalltalk classNamed: #Object) removeMethod: #printString. (smalltalk classNamed: self class name) removeMethod: #testReferencesPrintOnAfterRemove. smalltalk allReferencesTo: #printOn: do: [ :each | hasFoundObject := hasFoundObject or: [ each selector = #printString and: [ each modelClass = (smalltalk classNamed: #Object) ] ]. hasFoundSelf := hasFoundSelf or: [ each selector = #testReferencesPrintOnAfterRemove and: [ each modelClass = (smalltalk classNamed: self class name) ] ] ]. self deny: hasFoundObject. self deny: hasFoundSelf! ! !RBNamespaceTest methodsFor: 'class tests' stamp: 'lr 9/8/2011 20:25'! testModelImplementorsSenders | model class modelImps refs found | model := RBNamespace new. model defineClass: 'Object subclass: #Asdf instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Testing'''. class := model classNamed: #Asdf. class compile: 'storeOn: aStream ^super storeOn: aStream' classified: #(#printing). modelImps := model allImplementorsOf: #storeOn:. self assert: (modelImps includes: class). self assert: modelImps size - 1 = (RBBrowserEnvironment new implementorsOf: #storeOn:) numberSelectors. refs := RBBrowserEnvironment new referencesTo: #storeOn:. found := false. model allReferencesTo: #storeOn: do: [:each | each modelClass = class ifTrue: [found := true] ifFalse: [self assert: (refs includesSelector: each selector in: each modelClass realClass)]]. self assert: found ! ! !RBNamespaceTest methodsFor: 'class tests' stamp: 'bh 11/8/2000 14:13'! testDefineClassChange | st | st := RBNamespace new. st defineClass: 'RefactoringBrowserTest subclass: #SmalltalkTestXXX instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Testing'''. self assert: (st includesClassNamed: #SmalltalkTestXXX). self assert: (st classNamed: #SmalltalkTestXXX) notNil! ! !RBNamespaceTest methodsFor: 'class tests' stamp: 'bh 11/8/2000 14:13'! testRedefineClassChange | st | st := RBNamespace new. st defineClass: 'nil subclass: #Object instanceVariableNames: ''a'' classVariableNames: ''A'' poolDictionaries: ''TextConstants'' category: #''Refactory-Testing'''. self assert: (st includesClassNamed: #Object). self assert: (st classNamed: #Object) notNil! ! !RBNamespaceTest methodsFor: 'class tests' stamp: ''! testReparentSuperclassChange | st superclass subclasses | st := RBNamespace new. superclass := st classFor: TestCase superclass. subclasses := TestCase subclasses collect: [:each | st classFor: each]. st reparentClasses: subclasses to: superclass. subclasses do: [:each | self assert: each superclass = superclass]! ! !RBNamespaceTest methodsFor: 'class tests' stamp: 'lr 3/17/2010 18:50'! testReferencesPrintOnAfterAddition | hasFoundObject hasFoundSelf smalltalk | hasFoundObject := false. hasFoundSelf := false. smalltalk := RBNamespace new. (smalltalk classNamed: #Object) compile: 'someTestReference self printOn: nil' classified: #(testing). (smalltalk classNamed: self class name) compile: 'someTestReference ^ #printOn:' classified: #(testing). smalltalk allReferencesTo: #printOn: do: [ :each | hasFoundObject := hasFoundObject or: [ each selector = #someTestReference and: [ each modelClass = (smalltalk classNamed: #Object) ] ]. hasFoundSelf := hasFoundSelf or: [ each selector = #someTestReference and: [ each modelClass = (smalltalk classNamed: self class name) ] ] ]. self assert: hasFoundObject. self assert: hasFoundSelf! ! !RBNamespaceTest methodsFor: 'class tests' stamp: 'lr 9/8/2011 20:25'! testAllClassesDo | model classes | classes := 0. model := RBNamespace new. model allClassesDo: [:each | each name = #Object ifTrue: [each allSubclasses]. classes := classes + 1]. RBBrowserEnvironment new classesDo: [:each | classes := classes - 1]. self assert: classes = 0! ! !RBNamespaceTest methodsFor: 'class tests' stamp: 'lr 3/17/2010 18:52'! testReferencesPrintOn | hasFoundObject hasFoundSelf smalltalk | hasFoundObject := false. hasFoundSelf := false. smalltalk := RBNamespace new. smalltalk allReferencesTo: #printOn: do: [ :each | hasFoundObject := hasFoundObject or: [ each selector = #fullPrintString and: [each modelClass = (smalltalk classNamed: #Object) ] ]. hasFoundSelf := hasFoundSelf or: [ each selector = #testReferencesPrintOn and: [ each modelClass = (smalltalk classNamed: self class name) ] ] ]. self assert: hasFoundObject. self assert: hasFoundSelf! ! !RBNamespaceTest methodsFor: 'class tests' stamp: 'bh 4/3/2000 15:47'! testRoots | model | model := RBNamespace new. self assert: (model rootClasses asSortedCollection: [:a :b | a name < b name]) asArray = ((Class rootsOfTheWorld collect: [:each | model classFor: each]) asSortedCollection: [:a :b | a name < b name]) asArray! ! !RBNamespaceTest methodsFor: 'class tests' stamp: ''! testDefineClassAfterDeletedChange | st | st := RBNamespace new. st removeClassNamed: self class name. self deny: (st includesClassNamed: self class name). st defineClass: self class definition. self assert: (st includesClassNamed: self class name). self assert: (st classNamed: self class name) notNil! ! !RBNamespaceTest methodsFor: 'class tests' stamp: 'lr 9/8/2011 20:32'! testIncludesClass self assert: (RBNamespace new includesClassNamed: #Object). self deny: (RBNamespace new includesClassNamed: #Object1). self deny: ((RBNamespace onEnvironment: (RBClassEnvironment onEnvironment: RBBrowserEnvironment new classes: (Array with: Object))) includesClassNamed: #OrderedCollection)! ! !RBNamespaceTest methodsFor: 'class tests' stamp: ''! testRemoveClassChange | st | st := RBNamespace new. st removeClassNamed: self class name. self deny: (st includesClassNamed: self class name). self assert: (st classNamed: self class name) isNil! ! !RBNamespaceTest methodsFor: 'class tests' stamp: 'lr 7/1/2008 11:11'! testCommentChange | st cl | st := RBNamespace new. cl := st classNamed: self class name. self assert: cl comment isString. cl comment: 'a comment'. self assert: cl comment = 'a comment'. self assert: st changes changes size = 1. self assert: st changes changes first comment = 'a comment'. cl comment: nil. self assert: cl comment isNil. self assert: st changes changes size = 2. self assert: st changes changes last comment isNil! ! !RBNamespaceTest methodsFor: 'class tests' stamp: ''! testImplementors | st | st := RBNamespace new. self assert: ((st allImplementorsOf: #printString) includes: (st classNamed: #Object)). (st classNamed: #Object) removeMethod: #printString. self deny: ((st allImplementorsOf: #printString) includes: (st classNamed: #Object))! ! !RBNegationCondition methodsFor: 'private' stamp: ''! errorStringFor: aBoolean ^condition errorStringFor: aBoolean not! ! !RBNegationCondition methodsFor: 'initialize-release' stamp: ''! condition: aCondition condition := aCondition. self errorMacro: condition errorMacro! ! !RBNegationCondition methodsFor: 'private' stamp: ''! errorBlockFor: aBoolean ^condition errorBlockFor: aBoolean not! ! !RBNegationCondition methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: 'NOT '; print: condition! ! !RBNegationCondition methodsFor: 'checking' stamp: ''! check ^condition check not! ! !RBNegationCondition class methodsFor: 'instance creation' stamp: ''! on: aCondition ^self new condition: aCondition! ! !RBNoClassCommentRule commentStamp: ''! See my #rationale.! !RBNoClassCommentRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBNoClassCommentRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:32'! category ^ 'Coding Idiom Violation'! ! !RBNoClassCommentRule methodsFor: '*Manifest-Core' stamp: 'ah 8/6/2012 12:16'! longDescription ^ 'This smell arises when a class has no comment. Classes should have comments to explain their purpose, collaborations with other classes, and optionally provide examples of use.'! ! !RBNoClassCommentRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:23'! rationale ^ 'Classes should have comments to explain their purpose, collaborations with other classes, and optionally provide examples of use.'! ! !RBNoClassCommentRule methodsFor: 'accessing' stamp: 'cyrille.delaunay 8/11/2010 16:50'! group ^ 'Miscellaneous'! ! !RBNoClassCommentRule methodsFor: 'accessing' stamp: 'cyrille.delaunay 8/11/2010 16:51'! name ^ 'No class comment'! ! !RBNoClassCommentRule methodsFor: 'running' stamp: 'lr 3/7/2011 21:40'! checkClass: aContext (aContext selectedClass isMeta or: [ aContext includesBehaviorNamed: #TestCase ]) ifTrue: [ ^ self ]. aContext selectedClass organization classComment isEmpty ifTrue: [ result addClass: aContext selectedClass; addClass: aContext selectedClass class ]! ! !RBNoClassCommentRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'NoClassCommentRule'! ! !RBNotEliminationRule commentStamp: ''! See rationale! !RBNotEliminationRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:38'! initialize super initialize. self rewriteRule replace: '``@object not not' with: '``@object'; replace: '``@object not ifTrue: ``@block' with: '``@object ifFalse: ``@block'; replace: '``@object not ifFalse: ``@block' with: '``@object ifTrue: ``@block'; replace: '``@collection select: [:`each | | `@temps | ``@.Statements. ``@object not]' with: '``@collection reject: [:`each | | `@temps | ``@.Statements. ``@object]'; replace: '``@collection reject: [:`each | | `@temps | ``@.Statements. ``@object not]' with: '``@collection select: [:`each | | `@temps | ``@.Statements. ``@object]'; replace: '[| `@temps | ``@.Statements. ``@object not] whileTrue: ``@block' with: '[| `@temps | ``@.Statements. ``@object] whileFalse: ``@block'; replace: '[| `@temps | ``@.Statements. ``@object not] whileFalse: ``@block' with: '[| `@temps | ``@.Statements. ``@object] whileTrue: ``@block'; replace: '[| `@temps | ``@.Statements. ``@object not] whileTrue' with: '[| `@temps | ``@.Statements. ``@object] whileFalse'; replace: '[| `@temps | ``@.Statements. ``@object not] whileFalse' with: '[| `@temps | ``@.Statements. ``@object] whileTrue'; replace: '(``@a <= ``@b) not' with: '``@a > ``@b'; replace: '(``@a < ``@b) not' with: '``@a >= ``@b'; replace: '(``@a = ``@b) not' with: '``@a ~= ``@b'; replace: '(``@a == ``@b) not' with: '``@a ~~ ``@b'; replace: '(``@a ~= ``@b) not' with: '``@a = ``@b'; replace: '(``@a ~~ ``@b) not' with: '``@a == ``@b'; replace: '(``@a >= ``@b) not' with: '``@a < ``@b'; replace: '(``@a > ``@b) not' with: '``@a <= ``@b'! ! !RBNotEliminationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBNotEliminationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Eliminate unnecessary not''s'! ! !RBNotEliminationRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:51'! category ^ 'Optimization'! ! !RBNotEliminationRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/12/2012 13:16'! longDescription ^ 'Eliminate unnecessary not''s. For example test not ifTrue:[] is equivalent to test ifFalse:[]' ! ! !RBNotEliminationRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'NotEliminationRule'! ! !RBNotEnvironment methodsFor: 'testing' stamp: ''! includesClass: aClass (environment includesClass: aClass) ifFalse: [^true]. aClass selectorsAndMethodsDo: [:each :meth | (environment includesSelector: each in: aClass) ifFalse: [^true]]. ^false! ! !RBNotEnvironment methodsFor: 'environments' stamp: ''! not ^environment! ! !RBNotEnvironment methodsFor: 'testing' stamp: 'CamilloBruni 8/27/2013 02:19'! includesProtocol: aProtocol in: aClass ^(aClass organization protocolOrganizer getProtocolNamed: aProtocol ifNone: [ ^ false ]) methods anySatisfy: [ :selector | self includesSelector: selector in: aClass ]! ! !RBNotEnvironment methodsFor: 'testing' stamp: ''! includesSelector: aSelector in: aClass ^(environment includesSelector: aSelector in: aClass) not! ! !RBNotEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream environment storeOn: aStream. aStream nextPutAll: ' not'! ! !RBNotEnvironment methodsFor: 'testing' stamp: ''! includesCategory: aCategory ^(self classNamesFor: aCategory) isEmpty not! ! !RBNumberLiteralToken methodsFor: 'accessing' stamp: ''! source ^source! ! !RBNumberLiteralToken methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPutAll: source! ! !RBNumberLiteralToken methodsFor: 'initialize-release' stamp: ''! source: aString source := aString! ! !RBNumberLiteralToken class methodsFor: 'instance creation' stamp: ''! value: aNumber start: anInteger stop: stopInteger source: sourceString ^(self value: aNumber start: anInteger stop: stopInteger) source: sourceString; yourself! ! !RBOnlyReadOrWrittenTemporaryRule methodsFor: 'initialization' stamp: 'lr 6/4/2010 14:31'! initialize super initialize. self matcher matches: '| `@temps | ``@.stmts' do: [ :sequence :answer | answer isNil ifFalse: [ answer ] ifTrue: [ sequence temporaries detect: [ :temp | | isRead isWritten | isRead := false. isWritten := false. sequence statements do: [ :statement | statement nodesDo: [ :node | (node isVariable and: [ node name = temp name ]) ifTrue: [ isRead := isRead or: [ node isUsed ]. isWritten := isWritten or: [ node isWrite ] ] ] ]. (isRead and: [ isWritten ]) not ] ifNone: [ nil ] ] ]! ! !RBOnlyReadOrWrittenTemporaryRule methodsFor: 'accessing' stamp: 'lr 6/4/2010 12:11'! rationale ^ 'Checks that all temporary variables are both read and written. If an temporary variable is only read, you can replace all of the reads with nil, since it couldn''t have been assigned a value. If the variable is only written, then we don''t need to store the result since we never use it.'! ! !RBOnlyReadOrWrittenTemporaryRule methodsFor: 'accessing' stamp: 'lr 6/4/2010 12:10'! group ^ 'Unnecessary code'! ! !RBOnlyReadOrWrittenTemporaryRule methodsFor: 'accessing' stamp: 'lr 6/4/2010 12:10'! severity ^ #information! ! !RBOnlyReadOrWrittenTemporaryRule methodsFor: 'accessing' stamp: 'lr 6/4/2010 12:10'! name ^ 'Temporary variables not read AND written'! ! !RBOnlyReadOrWrittenTemporaryRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:26'! category ^ 'Optimization'! ! !RBOnlyReadOrWrittenTemporaryRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'OnlyReadOrWrittenTemporaryRule'! ! !RBOnlyReadOrWrittenVariableRule commentStamp: ''! See my #rationale.! !RBOnlyReadOrWrittenVariableRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !RBOnlyReadOrWrittenVariableRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:33'! category ^ 'Optimization'! ! !RBOnlyReadOrWrittenVariableRule methodsFor: '*Manifest-Core' stamp: 'ah 8/6/2012 12:25'! longDescription ^ 'This smell arises when an instance variable is not both read and written. If an instance variable is only read, the reads can be replaced by nil, since it could not have been assigned a value. If the variable is only written, then it does not need to store the result since it is never used. This check does not work for the data model classes since they use the #instVarAt:put: messages to set instance variables.'! ! !RBOnlyReadOrWrittenVariableRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:24'! rationale ^ 'Checks that all instance variables are both read and written. If an instance variable is only read, you can replace all of the reads with nil, since it couldn''t have been assigned a value. If the variable is only written, then we don''t need to store the result since we never use it. This check does not work for the data model classes, or other classes which use the instVarXyz:put: messages to set instance variables.'! ! !RBOnlyReadOrWrittenVariableRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBOnlyReadOrWrittenVariableRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:10'! severity ^ #information! ! !RBOnlyReadOrWrittenVariableRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Instance variables not read AND written'! ! !RBOnlyReadOrWrittenVariableRule methodsFor: 'running' stamp: 'TommasoDalSasso 10/6/2013 01:37'! checkClass: aContext | allSubclasses | allSubclasses := aContext selectedClass withAllSubclasses. aContext selectedClass instVarNames do: [ :each | | isRead isWritten | isRead := false. isWritten := false. allSubclasses detect: [ :class | isRead ifFalse: [ isRead := (class whichSelectorsRead: each) isEmpty not ]. isWritten ifFalse: [ isWritten := (class whichSelectorsAssign: each) isEmpty not ]. isRead and: [ isWritten ] ] ifNone: [ result addClass: aContext selectedClass instanceVariable: each ] ]! ! !RBOnlyReadOrWrittenVariableRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'OnlyReadOrWrittenVariableRule'! ! !RBOrEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 00:53'! includesClass: aClass (environment includesClass: aClass) ifTrue: [ ^ true ]. (orEnvironment includesClass: aClass) ifTrue: [ ^ true ]. (environment selectorsForClass: aClass) isEmpty ifFalse: [ ^ true ]. (orEnvironment selectorsForClass: aClass) isEmpty ifFalse: [ ^ true ]. ^ false! ! !RBOrEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:25'! classesDo: aBlock | enumerated | enumerated := IdentitySet new. environment classesDo: [ :each | aBlock value: each. enumerated add: each]. orEnvironment classesDo: [ :each | (enumerated includes: each) ifFalse: [ aBlock value: each ] ]! ! !RBOrEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 00:53'! includesProtocol: aProtocol in: aClass ^ (environment includesProtocol: aProtocol in: aClass) or: [ orEnvironment includesProtocol: aProtocol in: aClass ]! ! !RBOrEnvironment methodsFor: 'printing' stamp: 'lr 11/25/2009 00:51'! storeOn: aStream aStream nextPut: $(. environment storeOn: aStream. aStream nextPutAll: ' | '. orEnvironment storeOn: aStream. aStream nextPut: $)! ! !RBOrEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:25'! numberSelectors | total | total := 0. self classesDo: [ :each | self selectorsForClass: each do: [ :selector | total := total + 1 ] ]. ^ total! ! !RBOrEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 08:26'! includesCategory: aCategory ^ (environment includesCategory: aCategory) or: [ orEnvironment includesCategory: aCategory ]! ! !RBOrEnvironment methodsFor: 'initialization' stamp: 'lr 11/25/2009 00:49'! orEnvironment: aBrowserEnvironment orEnvironment := aBrowserEnvironment! ! !RBOrEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 00:54'! selectionIntervalFor: aString ^ (environment selectionIntervalFor: aString) ifNil: [ orEnvironment selectionIntervalFor: aString ]! ! !RBOrEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:26'! selectorsForClass: aClass do: aBlock | enumerated | enumerated := IdentitySet new. environment selectorsForClass: aClass do: [ :each | enumerated add: each. aBlock value: each ]. orEnvironment selectorsForClass: aClass do: [:each | (enumerated includes: each) ifFalse: [ aBlock value: each ] ]! ! !RBOrEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 00:53'! includesSelector: aSelector in: aClass ^ (environment includesSelector: aSelector in: aClass) or: [ orEnvironment includesSelector: aSelector in: aClass ]! ! !RBOrEnvironment class methodsFor: 'instance creation' stamp: 'lr 11/25/2009 00:51'! onEnvironment: anEnvironment or: anotherEnvironment ^ (self onEnvironment: anEnvironment) orEnvironment: anotherEnvironment; yourself! ! !RBOverridesSpecialMessageRule commentStamp: ''! See my #rationale.! !RBOverridesSpecialMessageRule methodsFor: 'private' stamp: 'lr 2/24/2009 20:12'! classShouldNotOverride ^ #( #== #~~ #class #basicAt: #basicAt:put: #basicSize #identityHash )! ! !RBOverridesSpecialMessageRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:34'! category ^ 'Bugs'! ! !RBOverridesSpecialMessageRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/12/2012 11:28'! longDescription ^ 'Checks that a class does not override a message that is essential to the base system. For example, if you override the #class method from object, you are likely to crash your image. In the class the messages we should not override are: ', (', ' join: (self classShouldNotOverride) ),'. In the class side the messages we should not override are: ', (', ' join: (self metaclassShouldNotOverride) ),'.' ! ! !RBOverridesSpecialMessageRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:26'! rationale ^ 'Checks that a class does not override a message that is essential to the base system. For example, if you override the #class method from object, you are likely to crash your image. #classShouldNotOverride returns the list of messages which should not be overriden.'! ! !RBOverridesSpecialMessageRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBOverridesSpecialMessageRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:04'! severity ^ #error! ! !RBOverridesSpecialMessageRule methodsFor: 'private' stamp: 'lr 2/24/2009 20:13'! metaclassShouldNotOverride ^ #( #basicNew #basicNew #class #comment #name )! ! !RBOverridesSpecialMessageRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Overrides a "special" message'! ! !RBOverridesSpecialMessageRule methodsFor: 'running' stamp: 'lr 1/21/2010 23:42'! checkClass: aContext | selectors | selectors := aContext selectedClass isMeta ifTrue: [ self metaclassShouldNotOverride ] ifFalse: [ self classShouldNotOverride ]. selectors do: [ :each | (aContext selectedClass superclass notNil and: [ (aContext selectedClass superclass canUnderstand: each) and: [ (aContext selectedClass includesSelector: each) ] ]) ifTrue: [ result addClass: aContext selectedClass selector: each ] ]! ! !RBOverridesSpecialMessageRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'OverridesSpecialMessageRule'! ! !RBPackageEnvironment methodsFor: 'testing' stamp: 'CamilloBruni 7/7/2013 18:33'! includesClass: aClass ^ (super includesClass: aClass) and: [ self packages anySatisfy: [ :package | (package includesClass: aClass) or: [ (package extensionCategoriesForClass: aClass) notEmpty ]]]! ! !RBPackageEnvironment methodsFor: 'accessing' stamp: 'lr 12/3/2009 10:16'! classesDo: aBlock | enumerated enumerator | enumerated := IdentitySet new. enumerator := [ :each | (enumerated includes: each) ifFalse: [ (environment includesClass: each) ifTrue: [ aBlock value: each ]. (environment includesClass: each class) ifTrue: [ aBlock value: each class ]. enumerated add: each ] ]. packages do: [ :package | package classes do: enumerator. package extensionClasses do: enumerator ]! ! !RBPackageEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:49'! packageNames ^ packages collect: [ :each | each packageName ]! ! !RBPackageEnvironment methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! asSelectorEnvironment | result | result := RBSelectorEnvironment onEnvironment: environment. self classesAndSelectorsDo: [ :class :selector | result addClass: class selector: selector ]. ^ result! ! !RBPackageEnvironment methodsFor: 'printing' stamp: 'TestRunner 12/23/2009 21:22'! storeOn: aStream aStream nextPut: $(; nextPutAll: self class name; nextPutAll: ' onEnvironment: '. environment storeOn: aStream. aStream nextPutAll: ' packageNames: '. self packageNames asArray storeOn: aStream. aStream nextPut: $)! ! !RBPackageEnvironment methodsFor: 'testing' stamp: 'CamilloBruni 7/7/2013 18:34'! includesCategory: aCategory ^ (super includesCategory: aCategory) and: [ self packages anySatisfy: [ :package | package includesSystemCategory: aCategory ] ]! ! !RBPackageEnvironment methodsFor: 'testing' stamp: 'CamilloBruni 8/27/2013 01:49'! includesSelector: aSelector in: aClass ^ (environment includesSelector: aSelector in: aClass) and: [ self packages anySatisfy: [ :package | package includesSelector: aSelector ofClass: aClass ] ]! ! !RBPackageEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:46'! packages ^ packages! ! !RBPackageEnvironment methodsFor: 'testing' stamp: 'lr 5/15/2010 09:39'! definesClass: aClass ^ (super definesClass: aClass) and: [ self packages anySatisfy: [ :package | package includesClass: aClass ] ]! ! !RBPackageEnvironment methodsFor: 'initialize-release' stamp: 'lr 12/20/2009 09:29'! packages: aCollection packages addAll: aCollection! ! !RBPackageEnvironment methodsFor: 'accessing' stamp: 'CamilloBruni 8/27/2013 01:42'! classesAndSelectorsDo: aBlock packages do: [ :package | package methods do: [ :method | (environment includesSelector: method selector in: method methodClass) ifTrue: [ aBlock value: method methodClass value: method selector ] ] ]! ! !RBPackageEnvironment methodsFor: 'initialization' stamp: 'lr 4/12/2010 15:25'! initialize super initialize. packages := Set new! ! !RBPackageEnvironment methodsFor: 'testing' stamp: 'lr 12/3/2009 10:13'! includesProtocol: aProtocol in: aClass ^ (environment includesProtocol: aProtocol in: aClass) and: [ self packages anySatisfy: [ :package | package includesMethodCategory: aProtocol ofClass: aClass ] ]! ! !RBPackageEnvironment methodsFor: 'copying' stamp: 'lr 4/12/2010 15:26'! postCopy super postCopy. packages := packages copy! ! !RBPackageEnvironment methodsFor: 'printing' stamp: 'CamilloBruni 8/27/2013 01:36'! printOn: aStream self storeOn: aStream! ! !RBPackageEnvironment methodsFor: 'accessing' stamp: 'lr 12/3/2009 13:30'! numberSelectors ^ packages inject: 0 into: [ :result :package | result + package methods size ]! ! !RBPackageEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:24'! packageName: aName ^ self packageNames: { aName }! ! !RBPackageEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:22'! packageNames: aCollection ^ self onEnvironment: self default packageNames: aCollection! ! !RBPackageEnvironment class methodsFor: 'instance creation' stamp: 'lr 11/25/2009 08:54'! onEnvironment: anEnvironment packages: aCollection ^ (self onEnvironment: anEnvironment) packages: aCollection; yourself! ! !RBPackageEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:24'! package: aPackage ^ self packages: { aPackage }! ! !RBPackageEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:22'! packages: aCollection ^ self onEnvironment: self default packages: aCollection! ! !RBPackageEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/27/2013 01:39'! onEnvironment: anEnvironment packageNames: aCollection ^ self onEnvironment: anEnvironment packages: (aCollection collect: [ :each | RPackageOrganizer default packageNamed: each ])! ! !RBParseErrorNode commentStamp: ''! I am a node representing a source code segement that could not be parsed. I am manly used for source-code coloring where we should parse as far as possible and mark the rest as a failure.! !RBParseErrorNode methodsFor: 'accessing' stamp: 'CamilloBruni 10/31/2012 18:52'! token: anObject token := anObject! ! !RBParseErrorNode methodsFor: 'accessing' stamp: 'CamilloBruni 10/31/2012 18:52'! errorMessage ^ errorMessage! ! !RBParseErrorNode methodsFor: 'accessing' stamp: 'CamilloBruni 11/1/2012 13:51'! start ^ token start! ! !RBParseErrorNode methodsFor: 'accessing' stamp: 'CamilloBruni 11/1/2012 13:51'! stop ^ token stop! ! !RBParseErrorNode methodsFor: 'accessing' stamp: 'CamilloBruni 10/31/2012 18:52'! errorMessage: anObject errorMessage := anObject! ! !RBParseErrorNode methodsFor: 'accessing' stamp: 'CamilloBruni 10/31/2012 18:52'! token ^ token! ! !RBParseErrorNode methodsFor: 'accessing' stamp: 'GiselaDecuzzi 6/5/2013 10:30'! isFaulty ^true.! ! !RBParseErrorNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:37'! acceptVisitor: aProgramNodeVisitor ^ aProgramNodeVisitor visitParseErrorNode: self.! ! !RBParseErrorNode methodsFor: 'accessing' stamp: 'g 6/24/2013 18:03'! binding: anOCTempVariable "only for compatibility" ! ! !RBParseErrorNode class methodsFor: 'instance creation' stamp: 'MarcusDenker 6/13/2013 16:44'! errorMessage: aString token: anRBToken ^ self new errorMessage: aString; token: anRBToken; yourself! ! !RBParseTreeEnvironment methodsFor: 'initialize-release' stamp: ''! matcher: aParseTreeSearcher matcher := aParseTreeSearcher! ! !RBParseTreeEnvironment methodsFor: 'accessing' stamp: 'lr 5/14/2010 13:42'! selectionIntervalFor: aString | parseTree node | matcher isNil ifTrue: [ ^ super selectionIntervalFor: aString ]. parseTree := RBParser parseMethod: aString onError: [ :error :position | ^ super selectionIntervalFor: aString ]. node := matcher executeTree: parseTree initialAnswer: nil. ^ (node isKindOf: RBProgramNode) ifTrue: [ node sourceInterval ] ifFalse: [ super selectionIntervalFor: aString ]! ! !RBParseTreeLintRule commentStamp: ''! A RBParseTreeLintRule is a rule that is expressed using a parse tree matcher on a method AST.! !RBParseTreeLintRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:15'! resultClass ^ RBParseTreeEnvironment! ! !RBParseTreeLintRule methodsFor: 'initialization' stamp: 'lr 11/2/2009 00:14'! initialize super initialize. matcher := RBParseTreeSearcher new! ! !RBParseTreeLintRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 00:01'! matcher ^ matcher! ! !RBParseTreeLintRule methodsFor: 'running' stamp: 'lr 2/24/2009 08:21'! resetResult super resetResult. self result matcher: self matcher! ! !RBParseTreeLintRule methodsFor: 'running' stamp: 'lr 2/24/2009 08:21'! checkMethod: aContext (self matcher canMatchMethod: aContext compiledMethod) ifFalse: [ ^ self ]. (self matcher executeTree: aContext parseTree initialAnswer: nil) isNil ifFalse: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBParseTreeLintRule class methodsFor: 'testing' stamp: 'lr 2/24/2009 17:09'! isVisible ^ self name ~= #RBParseTreeLintRule! ! !RBParseTreeLintRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ParseTreeLintRule'! ! !RBParseTreeRewriter commentStamp: ''! ParseTreeRewriter walks over and transforms its RBProgramNode (tree). If the tree is modified, then answer is set to true, and the modified tree can be retrieved by the #tree method. Instance Variables: tree the parse tree we're transforming! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replaceArgument: searchString withValueFrom: replaceBlock self addArgumentRule: (RBBlockReplaceRule searchFor: searchString replaceWith: replaceBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replaceTree: searchTree withTree: replaceTree when: aBlock self addRule: (RBStringReplaceRule searchForTree: searchTree replaceWith: replaceTree when: aBlock)! ! !RBParseTreeRewriter methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 16:29'! visitArgumentNodes: aNodeCollection ^aNodeCollection collect: [:each | self visitArgumentNode: each]! ! !RBParseTreeRewriter methodsFor: 'private' stamp: ''! foundMatch answer := true! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'StephaneDucasse 3/29/2013 16:28'! visitCascadeNode: aCascadeNode | newMessages notFound | newMessages := OrderedCollection new: aCascadeNode messages size. notFound := OrderedCollection new: aCascadeNode messages size. aCascadeNode messages do: [:each | | newNode | newNode := self performSearches: searches on: each. newNode isNil ifTrue: [newNode := each. notFound add: newNode]. newNode isMessage ifTrue: [newMessages add: newNode] ifFalse: [newNode isCascade ifTrue: [newMessages addAll: newNode messages] ifFalse: [Transcript show: 'Cannot replace message node inside of cascaded node with non-message node.'; cr. newMessages add: each]]]. notFound size = aCascadeNode messages size ifTrue: [| receiver | receiver := self visitNode: aCascadeNode messages first receiver. newMessages do: [:each | each receiver: receiver]]. notFound do: [:each | each arguments: (each arguments collect: [:arg | self visitNode: arg])]. aCascadeNode messages: newMessages! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'StephaneDucasse 3/29/2013 16:32'! visitMessageNode: aMessageNode aMessageNode receiver: (self visitNode: aMessageNode receiver). aMessageNode arguments: (aMessageNode arguments collect: [ :each | self visitNode: each ])! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replace: searchString with: replaceString when: aBlock self addRule: (RBStringReplaceRule searchFor: searchString replaceWith: replaceString when: aBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replaceMethod: searchString withValueFrom: replaceBlock when: conditionBlock self addRule: (RBBlockReplaceRule searchForMethod: searchString replaceWith: replaceBlock when: conditionBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replaceTree: searchTree withTree: replaceTree self addRule: (RBStringReplaceRule searchForTree: searchTree replaceWith: replaceTree)! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replace: searchString withValueFrom: replaceBlock self addRule: (RBBlockReplaceRule searchFor: searchString replaceWith: replaceBlock)! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'StephaneDucasse 3/29/2013 16:30'! visitArrayNode: anArrayNode anArrayNode statements: (anArrayNode statements collect: [:each | self visitNode: each])! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'StephaneDucasse 3/29/2013 16:28'! visitBlockNode: aBlockNode aBlockNode arguments: (self visitArgumentNodes: aBlockNode arguments). aBlockNode body: (self visitNode: aBlockNode body)! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'StephaneDucasse 3/29/2013 16:32'! visitMethodNode: aMethodNode aMethodNode arguments: (self visitArgumentNodes: aMethodNode arguments). aMethodNode pragmas: (aMethodNode pragmas collect: [ :each | self visitNode: each ]). aMethodNode body: (self visitNode: aMethodNode body)! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'StephaneDucasse 3/29/2013 16:32'! visitLiteralArrayNode: aRBArrayLiteralNode aRBArrayLiteralNode contents: (aRBArrayLiteralNode contents collect: [ :each | self visitNode: each ])! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replaceArgument: searchString withValueFrom: replaceBlock when: conditionBlock self addArgumentRule: (RBBlockReplaceRule searchFor: searchString replaceWith: replaceBlock when: conditionBlock)! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'StephaneDucasse 3/29/2013 16:32'! visitPragmaNode: aPragmaNode aPragmaNode arguments: (aPragmaNode arguments collect: [ :each | self visitNode: each ])! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replaceMethod: searchString with: replaceString self addRule: (RBStringReplaceRule searchForMethod: searchString replaceWith: replaceString)! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replaceArgument: searchString with: replaceString when: aBlock self addArgumentRule: (RBStringReplaceRule searchFor: searchString replaceWith: replaceString when: aBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replaceArgument: searchString with: replaceString self addArgumentRule: (RBStringReplaceRule searchFor: searchString replaceWith: replaceString)! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'StephaneDucasse 3/29/2013 16:31'! visitSequenceNode: aSequenceNode aSequenceNode temporaries: (self visitTemporaryNodes: aSequenceNode temporaries). aSequenceNode statements: (aSequenceNode statements collect: [ :each | self visitNode: each ])! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replace: searchString withValueFrom: replaceBlock when: conditionBlock self addRule: (RBBlockReplaceRule searchFor: searchString replaceWith: replaceBlock when: conditionBlock)! ! !RBParseTreeRewriter methodsFor: 'accessing' stamp: ''! tree ^tree! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replace: searchString with: replaceString self addRule: (RBStringReplaceRule searchFor: searchString replaceWith: replaceString)! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'StephaneDucasse 3/29/2013 16:28'! visitAssignmentNode: anAssignmentNode anAssignmentNode variable: (self visitNode: anAssignmentNode variable). anAssignmentNode value: (self visitNode: anAssignmentNode value)! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replaceMethod: searchString with: replaceString when: aBlock self addRule: (RBStringReplaceRule searchForMethod: searchString replaceWith: replaceString when: aBlock)! ! !RBParseTreeRewriter methodsFor: 'accessing' stamp: 'MarcusDenker 3/25/2013 21:02'! executeTree: aParseTree | oldContext | oldContext := context. context := SmallDictionary new. answer := false. tree := self visitNode: aParseTree. context := oldContext. ^answer! ! !RBParseTreeRewriter methodsFor: 'replacing' stamp: ''! replaceMethod: searchString withValueFrom: replaceBlock self addRule: (RBBlockReplaceRule searchForMethod: searchString replaceWith: replaceBlock)! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'StephaneDucasse 3/29/2013 16:29'! visitReturnNode: aReturnNode aReturnNode value: (self visitNode: aReturnNode value)! ! !RBParseTreeRewriter methodsFor: 'private' stamp: 'CamilloBruni 8/31/2013 20:51'! lookForMoreMatchesInContext: oldContext oldContext keysAndValuesDo: [:key :value | (key isString not and: [key recurseInto]) ifTrue: [oldContext at: key put: (value collect: [:each | self visitNode: each])]]! ! !RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''! rename: varName to: newVarName handler: aBlock "Rename varName to newVarName, evaluating aBlock if there is a temporary variable with the same name as newVarName. This does not change temporary variables with varName." | rewriteRule | rewriteRule := self new. rewriteRule replace: varName with: newVarName; replaceArgument: newVarName withValueFrom: [:aNode | aBlock value. aNode]. ^rewriteRule! ! !RBParseTreeRewriter class methodsFor: 'accessing' stamp: ''! replace: code with: newCode in: aParseTree onInterval: anInterval | rewriteRule | rewriteRule := self new. ^rewriteRule replace: code with: newCode when: [:aNode | aNode intersectsInterval: anInterval]; executeTree: aParseTree; tree! ! !RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''! replace: code with: newCode method: aBoolean | rewriteRule | rewriteRule := self new. aBoolean ifTrue: [rewriteRule replaceMethod: code with: newCode] ifFalse: [rewriteRule replace: code with: newCode]. ^rewriteRule! ! !RBParseTreeRewriter class methodsFor: 'instance creation' stamp: 'lr 11/23/2009 14:27'! variable: aVarName getter: getMethod setter: setMethod ^self variable: aVarName getter: getMethod setter: setMethod receiver: 'self'! ! !RBParseTreeRewriter class methodsFor: 'instance creation' stamp: 'lr 11/23/2009 14:27'! variable: aVarName getter: getMethod setter: setMethod receiver: aString | rewriteRule | rewriteRule := self new. rewriteRule replace: aVarName , ' := ``@object' with: aString , ' ' , setMethod , ' ``@object'; replace: aVarName with: aString , ' ' , getMethod. ^rewriteRule! ! !RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''! removeTemporaryNamed: aName | rewriteRule | rewriteRule := self new. rewriteRule replace: '| `@temps1 ' , aName , ' `@temps2 | ``@.Statements' with: '| `@temps1 `@temps2 | ``@.Statements'. ^rewriteRule! ! !RBParseTreeRewriter class methodsFor: 'accessing' stamp: ''! replaceStatements: code with: newCode in: aParseTree onInterval: anInterval | tree replaceStmt | tree := self buildTree: code method: false. tree isSequence ifFalse: [tree := RBSequenceNode statements: (Array with: tree)]. tree temporaries: (Array with: (RBPatternVariableNode named: '`@temps')). tree addNodeFirst: (RBPatternVariableNode named: '`@.S1'). tree lastIsReturn ifTrue: [replaceStmt := '| `@temps | `@.S1. ^' , newCode] ifFalse: [tree addNode: (RBPatternVariableNode named: '`@.S2'). replaceStmt := '| `@temps | `@.S1. ' , newCode , '. `@.S2']. ^self replace: tree formattedCode with: replaceStmt in: aParseTree onInterval: anInterval! ! !RBParseTreeRewriter class methodsFor: 'accessing' stamp: ''! replace: code with: newCode in: aParseTree ^(self replace: code with: newCode method: false) executeTree: aParseTree; tree! ! !RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''! replaceLiteral: literal with: newLiteral | rewriteRule | rewriteRule := self new. rewriteRule replaceTree: (RBLiteralNode value: literal) withTree: (RBLiteralNode value: newLiteral). ^rewriteRule! ! !RBParseTreeRewriter class methodsFor: 'instance creation' stamp: ''! rename: varName to: newVarName | rewriteRule | rewriteRule := self new. rewriteRule replace: varName with: newVarName; replaceArgument: varName with: newVarName. ^rewriteRule! ! !RBParseTreeRule commentStamp: 'md 8/9/2005 14:55'! RBParseTreeRule is the abstract superclass of all of the parse tree searching rules. A parse tree rule is the first class representation of a particular rule to search for. The owner of a rule is the algorithm that actually executes the search. This arrangement allows multiple searches to be conducted by a single Searcher. Instance Variables: owner The searcher that is actually performing the search. searchTree The parse tree to be searched. ! !RBParseTreeRule methodsFor: 'accessing' stamp: ''! sentMessages ^searchTree sentMessages! ! !RBParseTreeRule methodsFor: 'initialize-release' stamp: ''! methodSearchString: aString searchTree := RBParser parseRewriteMethod: aString! ! !RBParseTreeRule methodsFor: 'matching' stamp: ''! canMatch: aProgramNode ^true! ! !RBParseTreeRule methodsFor: 'initialize-release' stamp: ''! owner: aParseTreeSearcher owner := aParseTreeSearcher! ! !RBParseTreeRule methodsFor: 'matching' stamp: ''! performOn: aProgramNode self context empty. ^((searchTree match: aProgramNode inContext: self context) and: [self canMatch: aProgramNode]) ifTrue: [owner recusivelySearchInContext. self foundMatchFor: aProgramNode] ifFalse: [nil]! ! !RBParseTreeRule methodsFor: 'matching' stamp: ''! foundMatchFor: aProgramNode ^aProgramNode! ! !RBParseTreeRule methodsFor: 'private' stamp: ''! context ^owner context! ! !RBParseTreeRule methodsFor: 'initialize-release' stamp: ''! searchString: aString searchTree := RBParser parseRewriteExpression: aString! ! !RBParseTreeRule class methodsFor: 'instance creation' stamp: ''! search: aString ^(self new) searchString: aString; yourself! ! !RBParseTreeRule class methodsFor: 'instance creation' stamp: ''! methodSearch: aString ^(self new) methodSearchString: aString; yourself! ! !RBParseTreeSearcher commentStamp: ''! ParseTreeSearcher walks over a normal source code parse tree using the visitor pattern, and then matches these nodes against the meta-nodes using the match:inContext: methods defined for the meta-nodes. Instance Variables: answer the "answer" that is propagated between matches argumentSearches argument searches (search for the BRProgramNode and perform the BlockClosure when its found) context a dictionary that contains what each meta-node matches against. This could be a normal Dictionary that is created for each search, but is created once and reused (efficiency). messages the sent messages in our searches searches non-argument searches (search for the BRProgramNode and perform the BlockClosure when its found)! !RBParseTreeSearcher methodsFor: 'private' stamp: 'CamilloBruni 12/15/2011 15:28'! performSearches: aSearchCollection on: aNode | value | aSearchCollection do: [ :aSearchRule| value := aSearchRule performOn: aNode. value notNil ifTrue: [self foundMatch. ^value]]. ^nil! ! !RBParseTreeSearcher methodsFor: 'accessing' stamp: ''! answer ^answer! ! !RBParseTreeSearcher methodsFor: 'private' stamp: ''! foundMatch! ! !RBParseTreeSearcher methodsFor: 'initialization' stamp: 'MarcusDenker 3/25/2013 21:02'! initialize super initialize. context := SmallDictionary new. searches := OrderedCollection new. argumentSearches := OrderedCollection new: 0. answer := nil! ! !RBParseTreeSearcher methodsFor: 'searching' stamp: ''! matchesAnyOf: aStringCollection do: aBlock aStringCollection do: [:each | self matches: each do: aBlock]! ! !RBParseTreeSearcher methodsFor: 'accessing' stamp: ''! addArgumentRules: ruleCollection ruleCollection do: [:each | self addArgumentRule: each]! ! !RBParseTreeSearcher methodsFor: 'searching' stamp: ''! matchesAnyTreeOf: treeCollection do: aBlock treeCollection do: [:each | self matchesTree: each do: aBlock]! ! !RBParseTreeSearcher methodsFor: 'accessing' stamp: ''! addRules: ruleCollection ruleCollection do: [:each | self addRule: each]! ! !RBParseTreeSearcher methodsFor: 'accessing' stamp: ''! messages messages notNil ifTrue: [^messages]. argumentSearches notEmpty ifTrue: [^messages := #()]. messages := Set new. searches do: [:each | | searchMessages | searchMessages := each sentMessages. RBProgramNode optimizedSelectors do: [:sel | searchMessages remove: sel ifAbsent: []]. searchMessages isEmpty ifTrue: [^messages := #()]. messages addAll: searchMessages]. ^messages := messages asArray! ! !RBParseTreeSearcher methodsFor: 'searching' stamp: ''! matchesTree: aBRProgramNode do: aBlock self addRule: (RBSearchRule searchForTree: aBRProgramNode thenDo: aBlock)! ! !RBParseTreeSearcher methodsFor: 'searching' stamp: ''! matchesAnyMethodOf: aStringCollection do: aBlock aStringCollection do: [:each | self matchesMethod: each do: aBlock]! ! !RBParseTreeSearcher methodsFor: 'initialize-release' stamp: ''! answer: anObject answer := anObject! ! !RBParseTreeSearcher methodsFor: 'accessing' stamp: ''! addRule: aParseTreeRule searches add: aParseTreeRule. aParseTreeRule owner: self! ! !RBParseTreeSearcher methodsFor: 'testing' stamp: 'lr 1/3/2010 11:48'! canMatchMethod: aCompiledMethod | actualMessages | self messages isEmpty ifTrue: [ ^ true ]. actualMessages := aCompiledMethod messages. ^ self messages anySatisfy: [ :each | actualMessages includes: each ]! ! !RBParseTreeSearcher methodsFor: 'searching' stamp: ''! matchesArgumentTree: aBRProgramNode do: aBlock self addArgumentRule: (RBSearchRule searchForTree: aBRProgramNode thenDo: aBlock)! ! !RBParseTreeSearcher methodsFor: 'searching' stamp: ''! matches: aString do: aBlock self addRule: (RBSearchRule searchFor: aString thenDo: aBlock)! ! !RBParseTreeSearcher methodsFor: 'searching' stamp: ''! matchesMethod: aString do: aBlock self addRule: (RBSearchRule searchForMethod: aString thenDo: aBlock)! ! !RBParseTreeSearcher methodsFor: 'private' stamp: 'MarcusDenker 3/25/2013 21:02'! recusivelySearchInContext "We need to save the matched context since the other searches might overwrite it." | oldContext | oldContext := context. context := SmallDictionary new. self lookForMoreMatchesInContext: oldContext. context := oldContext! ! !RBParseTreeSearcher methodsFor: 'visiting' stamp: 'CamilleTeruel 4/3/2013 16:23'! visitNode: aNode | value | value := self performSearches: searches on: aNode. ^ value ifNil: [ super visitNode: aNode. aNode ] ifNotNil: [ value ]! ! !RBParseTreeSearcher methodsFor: 'visiting' stamp: 'CamilleTeruel 4/3/2013 16:22'! visitArgumentNode: aNode | value | value := self performSearches: argumentSearches on: aNode. ^ value ifNil: [ super visitArgumentNode: aNode. aNode ] ifNotNil: [ value ]! ! !RBParseTreeSearcher methodsFor: 'searching' stamp: ''! matchesAnyArgumentOf: stringCollection do: aBlock stringCollection do: [:each | self matchesArgument: each do: aBlock]! ! !RBParseTreeSearcher methodsFor: 'accessing' stamp: ''! addArgumentRule: aParseTreeRule argumentSearches add: aParseTreeRule. aParseTreeRule owner: self! ! !RBParseTreeSearcher methodsFor: 'accessing' stamp: ''! executeMethod: aParseTree initialAnswer: anObject answer := anObject. searches detect: [:each | (each performOn: aParseTree) notNil] ifNone: []. ^answer! ! !RBParseTreeSearcher methodsFor: 'accessing' stamp: 'MarcusDenker 3/25/2013 21:02'! executeTree: aParseTree "Save our current context, in case someone is performing another search inside a match." | oldContext | oldContext := context. context := SmallDictionary new. self visitNode: aParseTree. context := oldContext. ^answer! ! !RBParseTreeSearcher methodsFor: 'accessing' stamp: ''! executeTree: aParseTree initialAnswer: aValue answer := aValue. ^self executeTree: aParseTree! ! !RBParseTreeSearcher methodsFor: 'searching' stamp: ''! matchesArgument: aString do: aBlock self addArgumentRule: (RBSearchRule searchFor: aString thenDo: aBlock)! ! !RBParseTreeSearcher methodsFor: 'testing' stamp: ''! hasRules ^searches notEmpty! ! !RBParseTreeSearcher methodsFor: 'private' stamp: ''! lookForMoreMatchesInContext: oldContext oldContext keysAndValuesDo: [:key :value | (key isString not and: [key recurseInto]) ifTrue: [value do: [:each | self visitNode: each]]]! ! !RBParseTreeSearcher methodsFor: 'accessing' stamp: ''! context ^context! ! !RBParseTreeSearcher class methodsFor: 'private' stamp: ''! buildTree: aString method: aBoolean ^aBoolean ifTrue: [RBParser parseRewriteMethod: aString] ifFalse: [RBParser parseRewriteExpression: aString]! ! !RBParseTreeSearcher class methodsFor: 'private' stamp: ''! buildSelectorString: aSelector | stream keywords | aSelector numArgs = 0 ifTrue: [^aSelector]. stream := WriteStream on: String new. keywords := aSelector keywords. 1 to: keywords size do: [:i | stream nextPutAll: (keywords at: i); nextPutAll: ' ``@arg'; nextPutAll: i printString; nextPut: $ ]. ^stream contents! ! !RBParseTreeSearcher class methodsFor: 'private' stamp: ''! buildSelectorTree: aSelector aSelector isEmpty ifTrue: [^nil]. ^RBParser parseRewriteExpression: '``@receiver ' , (self buildSelectorString: aSelector) onError: [:err :pos | ^nil]! ! !RBParseTreeSearcher class methodsFor: 'instance creation' stamp: ''! returnSetterMethod: aVarName ^(self new) matchesMethod: '`method: `Arg ^' , aVarName , ' := `Arg' do: [:aNode :ans | aNode selector]; yourself! ! !RBParseTreeSearcher class methodsFor: 'instance creation' stamp: ''! getterMethod: aVarName ^(self new) matchesMethod: '`method ^' , aVarName do: [:aNode :ans | aNode selector]; yourself! ! !RBParseTreeSearcher class methodsFor: 'instance creation' stamp: ''! setterMethod: aVarName ^(self new) matchesAnyMethodOf: (Array with: '`method: `Arg ' , aVarName , ' := `Arg' with: '`method: `Arg ^' , aVarName , ' := `Arg') do: [:aNode :ans | aNode selector]; yourself! ! !RBParseTreeSearcher class methodsFor: 'accessing' stamp: ''! treeMatching: aString in: aParseTree (self new) matches: aString do: [:aNode :answer | ^aNode]; executeTree: aParseTree. ^nil! ! !RBParseTreeSearcher class methodsFor: 'accessing' stamp: ''! treeMatchingStatements: aString in: aParseTree | notifier tree | notifier := self new. tree := RBParser parseExpression: aString. tree isSequence ifFalse: [tree := RBSequenceNode statements: (Array with: tree)]. tree temporaries: (Array with: (RBPatternVariableNode named: '`@temps')). tree addNodeFirst: (RBPatternVariableNode named: '`@.S1'). tree lastIsReturn ifFalse: [tree addNode: (RBPatternVariableNode named: '`@.S2')]. notifier matchesTree: tree do: [:aNode :answer | ^RBParser parseExpression: aString]. notifier executeTree: aParseTree. ^nil! ! !RBParseTreeSearcher class methodsFor: 'instance creation' stamp: 'lr 11/4/2009 11:44'! justSendsSuper ^ self new matchesAnyMethodOf: #( '`@method: `@args ^ super `@method: `@args' '`@method: `@args super `@method: `@args') do: [ :node :answer | true ]; yourself! ! !RBParser commentStamp: ''! RBParser takes a source code string and generates an AST for it. This is a hand-written, recursive descent parser and has been optimized for speed. The simplest way to call this is either 'RBParser parseExpression: aString' if you want the AST for an expression, or 'RBParser parseMethod: aString' if you want to parse an entire method. Instance Variables: currentToken The current token being processed. emptyStatements True if empty statements are allowed. In IBM, they are, in VW they aren't. errorBlock The block to evaluate on a syntax error. nextToken The next token that will be processed. This allows one-token lookahead. scanner The scanner that generates a stream of tokens to parse. source The source code to parse tags The source intervals of the tags appearing at the top of a method (e.g. Primitive calls) Shared Variables: ParserType the type code we are parsing! !RBParser methodsFor: 'private-classes' stamp: 'CamilloBruni 12/15/2011 16:15'! variableNodeClass ^ RBVariableNode! ! !RBParser methodsFor: 'private-parsing' stamp: 'lr 11/9/2009 21:08'! parseUnaryPragma | selector | selector := currentToken. self step. ^ self pragmaNodeClass selectorParts: (Array with: selector) arguments: #()! ! !RBParser methodsFor: 'private-classes' stamp: 'CamilloBruni 8/30/2011 17:03'! thisContextNodeClass ^ RBThisContextNode! ! !RBParser methodsFor: 'accessing' stamp: 'GiselaDecuzzi 5/27/2013 18:55'! parseMethod: aString | node errorNode | node := self parseMethod. self atEnd ifFalse: [ errorNode := self parserError: 'Unknown input at end'. errorNode ifNotNil: [ node statements: node statements, {errorNode }] ]. node source: aString. ^ node! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parseKeywordMessage ^self parseKeywordMessageWith: self parseBinaryMessage! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:37'! parseLiteralArray | stream start stop | start := currentToken start. stream := WriteStream on: (Array new: 5). self step. [self atEnd or: [currentToken isSpecial and: [currentToken value = $)]]] whileFalse: [stream nextPut: self parseLiteralArrayObject]. (currentToken isSpecial and: [currentToken value = $)]) ifFalse: [ ^ self parserError: ''')'' expected']. stop := currentToken stop. self step. ^self literalArrayNodeClass startPosition: start contents: stream contents stopPosition: stop isByteArray: false! ! !RBParser methodsFor: 'private-parsing' stamp: 'MarcusDenker 3/27/2014 11:08'! parseStatementList: pragmaBoolean into: sequenceNode | statements return periods returnPosition node | return := false. statements := OrderedCollection new. periods := OrderedCollection new. self addCommentsTo: sequenceNode. pragmaBoolean ifTrue: [self parsePragmas]. [currentToken isSpecial and: [currentToken value = $.]] whileTrue: [periods add: currentToken start. self step]. [self atEnd or: [currentToken isSpecial and: ['])}' includes: currentToken value]]] whileFalse: [ return ifTrue: [ (self parserError: 'End of statement list encountered') ifNotNil: [ :errorNode | statements add: errorNode. sequenceNode statements: statements. sequenceNode periods: periods. self step. ^sequenceNode] ]. (currentToken isSpecial and: [currentToken value = $^]) ifTrue: [returnPosition := currentToken start. self step. node := self returnNodeClass return: returnPosition value: self parseAssignment. statements add: node. return := true] ifFalse: [ "check for pragmas" (currentToken isBinary and: [ currentToken value == #<]) ifTrue: [ self parsePragma ] ifFalse: [ node := self parseAssignment. statements add: node ]]. (currentToken isSpecial and: [currentToken value = $.]) ifTrue: [periods add: currentToken start. self step. self addCommentsTo: node] ifFalse: [ "check for closing pragmas" (currentToken isBinary and: [ currentToken value == #>]) ifFalse: [ return := true ] ifTrue: [ self step ]]. [currentToken isSpecial and: [currentToken value = $.]] whileTrue: [periods add: currentToken start. self step] ]. statements notEmpty ifTrue: [self addCommentsTo: statements last]. sequenceNode statements: statements; periods: periods. ^sequenceNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! returnNodeClass ^ RBReturnNode! ! !RBParser methodsFor: 'initialization' stamp: 'lr 11/1/2009 19:17'! initialize comments := OrderedCollection new! ! !RBParser methodsFor: 'accessing' stamp: ''! scannerClass ^RBScanner! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:36'! parseBinaryPragma | binaryToken | currentToken isBinary ifFalse: [ ^ self parserError: 'Message pattern expected' ]. binaryToken := currentToken. self step. ^ self pragmaNodeClass selectorParts: (Array with: binaryToken) arguments: (Array with: self parsePragmaLiteral)! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parseBinaryMessage | node | node := self parseUnaryMessage. [currentToken isLiteralToken ifTrue: [self patchNegativeLiteral]. currentToken isBinary] whileTrue: [node := self parseBinaryMessageWith: node]. ^node! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 11/13/2012 10:22'! parsePragmas [ currentToken isBinary and: [ currentToken value = #< ] ] whileTrue: [ self parsePragma. self step ]! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parseAssignment "Need one token lookahead to see if we have a ':='. This method could make it possible to assign the literals true, false and nil." | node position | (currentToken isIdentifier and: [self nextToken isAssignment]) ifFalse: [^self parseCascadeMessage]. node := self parseVariableNode. position := currentToken start. self step. ^self assignmentNodeClass variable: node value: self parseAssignment position: position! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:37'! parseParenthesizedExpression | leftParen node | leftParen := currentToken start. self step. node := self parseAssignment. ^(currentToken isSpecial and: [currentToken value = $)]) ifTrue: [node addParenthesis: (leftParen to: currentToken start). self step. node] ifFalse: [ self parserError: ''')'' expected']! ! !RBParser methodsFor: 'private-parsing' stamp: 'GiselaDecuzzi 6/10/2013 13:46'! parsePrimitiveObject currentToken isIdentifier ifTrue: [^self parsePrimitiveIdentifier]. (currentToken isLiteralToken and: [currentToken isMultiKeyword not]) ifTrue: [^self parsePrimitiveLiteral]. currentToken isLiteralArrayToken ifTrue: [^currentToken isForByteArray ifTrue: [self parseLiteralByteArray] ifFalse: [self parseLiteralArray]]. currentToken isSpecial ifTrue: [currentToken value = $[ ifTrue: [^self parseBlock]. currentToken value = $( ifTrue: [^self parseParenthesizedExpression]. currentToken value = ${ ifTrue: [^self parseArray]]. (currentToken isBinary and: [ currentToken value = #- ]) ifTrue: [ ^self parseNegatedNumber ]. ^ self parserError: 'Variable or expression expected'! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:37'! parseLiteralByteArrayObject (currentToken isLiteralToken and: [currentToken value isInteger and: [currentToken value between: 0 and: 255]]) ifFalse: [ ^ self parserError: 'Expecting 8-bit integer']. ^self parsePrimitiveLiteral! ! !RBParser methodsFor: 'private-parsing' stamp: 'lr 11/2/2009 23:37'! parseLiteralArrayObject currentToken isSpecial ifTrue: [currentToken value = $( ifTrue: [^self parseLiteralArray]. "currentToken value == $[ ifTrue: [^self parseLiteralByteArray]"]. currentToken isLiteralArrayToken ifTrue: [^currentToken isForByteArray ifTrue: [self parseLiteralByteArray] ifFalse: [self parseLiteralArray]]. currentToken isLiteralToken ifFalse: [self patchLiteralArrayToken]. ^self parsePrimitiveLiteral! ! !RBParser methodsFor: 'private-parsing' stamp: 'GiselaDecuzzi 6/3/2013 16:09'! parseBlock | position node | position := currentToken start. self step. node := self blockNodeClass new. self parseBlockArgsInto: node. node left: position. node body: self sequenceNodeClass new. (self parseStatements: false into: node body). (currentToken isSpecial and: [currentToken value = $]]) ifFalse: [^ self parserError: ''']'' expected' translated]. node right: currentToken start. self step. ^node! ! !RBParser methodsFor: 'private' stamp: 'ClementBera 7/26/2013 17:09'! nextToken ^nextToken ifNil: [nextToken := scanner next] ifNotNil: [nextToken]! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:49'! cascadeNodeClass ^ RBCascadeNode! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parseUnaryMessage | node | node := self parsePrimitiveObject. self addCommentsTo: node. [currentToken isLiteralToken ifTrue: [self patchLiteralMessage]. currentToken isIdentifier] whileTrue: [node := self parseUnaryMessageWith: node]. self addCommentsTo: node. ^node! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parseMessagePattern currentToken isLiteralToken ifTrue: [self patchLiteralMessage]. ^currentToken isIdentifier ifTrue: [self parseUnaryPattern] ifFalse: [currentToken isKeyword ifTrue: [self parseKeywordPattern] ifFalse: [self parseBinaryPattern]]! ! !RBParser methodsFor: 'private-parsing' stamp: 'GiselaDecuzzi 6/3/2013 16:08'! parseVariableNode currentToken isIdentifier ifFalse: [ ^ self parserError: 'Variable name expected' translated]. ^self parsePrimitiveIdentifier! ! !RBParser methodsFor: 'private' stamp: 'lr 11/2/2009 23:37'! patchNegativeLiteral "Handle the special negative number case for binary message sends." currentToken value isNumber ifFalse: [^self]. currentToken value <= 0 ifFalse: [^self]. currentToken value = 0 ifTrue: [(source notNil and: [source notEmpty and: [(source at: (currentToken start min: source size)) = $-]]) ifFalse: [^self]]. nextToken := currentToken. currentToken := RBBinarySelectorToken value: #- start: nextToken start. nextToken value: nextToken value negated. (nextToken isKindOf: RBNumberLiteralToken) ifTrue: [nextToken source: (nextToken source copyFrom: 2 to: nextToken source size)]. nextToken start: nextToken start + 1! ! !RBParser methodsFor: 'private' stamp: 'GiselaDecuzzi 5/28/2013 17:11'! step (currentToken notNil and: [currentToken comments notNil]) ifTrue: [comments addAll: currentToken comments]. nextToken notNil ifTrue: [currentToken := nextToken. nextToken := nil] ifFalse: [currentToken := scanner next].! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parseKeywordPattern | keywords args node | keywords := OrderedCollection new: 2. args := OrderedCollection new: 2. [currentToken isKeyword] whileTrue: [keywords add: currentToken. self step. args add: self parseVariableNode]. node := self methodNodeClass selectorParts: keywords arguments: args. node comments: (node comments, args last comments). args last comments: nil. ^node! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parsePrimitiveIdentifier | token node | token := currentToken. self step. node := self variableNodeClass identifierToken: token. self addCommentsTo: node. ^node! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parseArgs | args | args := OrderedCollection new. [currentToken isIdentifier] whileTrue: [args add: self parseVariableNode]. ^args! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 12/15/2011 16:41'! parseStatements: pragmaBoolean ^ self parseStatements: pragmaBoolean into: self sequenceNodeClass new! ! !RBParser methodsFor: 'private-parsing' stamp: 'lr 5/30/2010 14:40'! parseKeywordPragma | keywords arguments | keywords := OrderedCollection new: 2. arguments := OrderedCollection new: 2. [ currentToken isKeyword ] whileTrue: [ keywords addLast: currentToken. self step. arguments addLast: self parsePragmaLiteral ]. ^ self pragmaNodeClass selectorParts: keywords arguments: arguments! ! !RBParser methodsFor: 'private-classes' stamp: 'CamilloBruni 8/23/2011 16:12'! selfNodeClass ^ RBSelfNode! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:36'! parseBinaryPattern | binaryToken node args | currentToken isBinary ifFalse: [ ^ self parserError: 'Message pattern expected']. binaryToken := currentToken. self step. args := Array with: self parseVariableNode. node := self methodNodeClass selectorParts: (Array with: binaryToken) arguments: args. node comments: node comments , args last comments. args last comments: nil. ^node! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! messageNodeClass ^ RBMessageNode! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:37'! parseCascadeMessage | node receiver messages semicolons | node := self parseKeywordMessage. (currentToken isSpecial and: [currentToken value = $; and: [node isMessage]]) ifFalse: [^node]. receiver := node receiver. messages := OrderedCollection new: 3. semicolons := OrderedCollection new: 3. messages add: node. [currentToken isSpecial and: [currentToken value = $;]] whileTrue: [semicolons add: currentToken start. self step. messages add: (currentToken isIdentifier ifTrue: [self parseUnaryMessageWith: receiver] ifFalse: [currentToken isKeyword ifTrue: [self parseKeywordMessageWith: receiver] ifFalse: [| temp | currentToken isLiteralToken ifTrue: [self patchNegativeLiteral]. currentToken isBinary ifFalse: [ ^ self parserError: 'Message expected']. temp := self parseBinaryMessageWith: receiver. temp == receiver ifTrue: [ ^ self parserError: 'Message expected']. temp]])]. ^self cascadeNodeClass messages: messages semicolons: semicolons! ! !RBParser methodsFor: 'private-classes' stamp: 'CamilloBruni 8/23/2011 16:12'! superNodeClass ^ RBSuperNode! ! !RBParser methodsFor: 'error handling' stamp: 'GiselaDecuzzi 6/10/2013 13:48'! parseErrorNode: aMessageString | token sourceString | currentToken isError ifTrue: [ ^ RBParseErrorNode errorMessage: currentToken cause token: currentToken ]. sourceString := source copyFrom: self errorPosition to: source size. token := RBValueToken value: sourceString start: self errorPosition. ^ RBParseErrorNode errorMessage: aMessageString token: token! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 12/15/2011 16:18'! parseTemps | temps | temps := OrderedCollection new. [currentToken isIdentifier] whileTrue: [temps add: self parsePrimitiveIdentifier]. ^temps! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:49'! arrayNodeClass ^ RBArrayNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! sequenceNodeClass ^ RBSequenceNode! ! !RBParser methodsFor: 'private' stamp: ''! addCommentsTo: aNode aNode comments: aNode comments , comments. comments := OrderedCollection new! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:49'! assignmentNodeClass ^ RBAssignmentNode! ! !RBParser methodsFor: 'accessing' stamp: ''! errorBlock: aBlock errorBlock := aBlock. scanner notNil ifTrue: [scanner errorBlock: aBlock]! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! literalArrayNodeClass ^ RBLiteralArrayNode! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:37'! parseLiteralByteArray | stream start stop | start := currentToken start. stream := WriteStream on: (Array new: 5). self step. [self atEnd or: [currentToken isSpecial and: [currentToken value = $]]]] whileFalse: [stream nextPut: self parseLiteralByteArrayObject]. (currentToken isSpecial and: [currentToken value = $]]) ifFalse: [^ self parserError: ''']'' expected']. stop := currentToken stop. self step. ^self literalArrayNodeClass startPosition: start contents: stream contents stopPosition: stop isByteArray: true! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! literalNodeClass ^ RBLiteralNode! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 11/13/2012 10:12'! basicParsePragma ^ currentToken isIdentifier ifTrue: [ self parseUnaryPragma ] ifFalse: [ currentToken isKeyword ifTrue: [ self parseKeywordPragma ] ifFalse: [ self parseBinaryPragma ] ]! ! !RBParser methodsFor: 'private' stamp: 'lr 11/1/2009 20:03'! patchLiteralArrayToken (currentToken isIdentifier and: [self nextToken isAssignment and: [currentToken stop + 1 = self nextToken start]]) ifTrue: [currentToken := RBLiteralToken value: (currentToken value , ':') asSymbol start: currentToken start stop: self nextToken start. nextToken := RBLiteralToken value: #= start: nextToken stop stop: nextToken stop. ^self]. currentToken isAssignment ifTrue: [currentToken := RBLiteralToken value: #':' start: currentToken start stop: currentToken start. nextToken := RBLiteralToken value: #= start: currentToken stop stop: currentToken stop. ^self]. currentToken isSpecial ifTrue: [currentToken := RBLiteralToken value: (String with: currentToken value) asSymbol start: currentToken start stop: currentToken stop. ^self]. (currentToken isIdentifier and: [currentToken value includes: $.]) ifTrue: [currentToken := RBLiteralToken value: currentToken value start: currentToken start stop: currentToken stop. ^self]. (currentToken isIdentifier or: [currentToken isBinary or: [currentToken isKeyword]]) ifFalse: [^self parserError: 'Invalid token']. currentToken := RBLiteralToken value: currentToken value asSymbol start: currentToken start stop: currentToken stop! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:49'! blockNodeClass ^ RBBlockNode! ! !RBParser methodsFor: 'private-parsing' stamp: 'ClementBEra 1/30/2013 15:06'! parsePragma | start pragma | start := currentToken start. self step. pragma := self basicParsePragma. (currentToken isBinary and: [ currentToken value == #> ]) ifFalse: [ ^ self parserError: '''>'' expected' ]. pragma left: start; right: currentToken start. self addPragma: pragma.! ! !RBParser methodsFor: 'private-parsing' stamp: 'lr 5/30/2010 14:40'! parsePragmaLiteral ^ self parseLiteralArrayObject! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parseUnaryPattern | selector | selector := currentToken. self step. ^self methodNodeClass selectorParts: (Array with: selector) arguments: #()! ! !RBParser methodsFor: 'error handling' stamp: 'ClementBera 7/26/2013 17:09'! errorBlock ^errorBlock ifNil: [[:message :position | ]] ifNotNil: [errorBlock]! ! !RBParser methodsFor: 'accessing' stamp: 'GiselaDecuzzi 6/10/2013 11:42'! initializeParserWith: aString source := aString. self scanner: (self scannerClass on: (ReadStream on: aString)) ! ! !RBParser methodsFor: 'error handling' stamp: 'GiselaDecuzzi 6/5/2013 09:31'! errorPosition ^currentToken ifNotNil: [ :token | token start] ifNil:[1]! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/9/2009 21:08'! pragmaNodeClass ^ RBPragmaNode! ! !RBParser methodsFor: 'private' stamp: ''! patchLiteralMessage currentToken value == true ifTrue: [^currentToken := RBIdentifierToken value: 'true' start: currentToken start]. currentToken value == false ifTrue: [^currentToken := RBIdentifierToken value: 'false' start: currentToken start]. currentToken value == nil ifTrue: [^currentToken := RBIdentifierToken value: 'nil' start: currentToken start]! ! !RBParser methodsFor: 'initialize-release' stamp: 'GiselaDecuzzi 6/5/2013 09:43'! scanner: aScanner scanner := aScanner. pragmas := nil. self initialize. self step.! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 11/8/2012 16:01'! parseStatements: pragmaBoolean into: aSequenceNode | temps leftBar rightBar | temps := #(). leftBar := rightBar := nil. currentToken isBinary ifTrue: [currentToken value = #| ifTrue: [leftBar := currentToken start. self step. temps := self parseTemps. (currentToken isBinary and: [currentToken value = #|]) ifFalse: [ ^ self parserError: '''|'' expected']. rightBar := currentToken start. self step] ifFalse: [currentToken value = #'||' ifTrue: [rightBar := (leftBar := currentToken start) + 1. self step]]]. ^self parseStatementList: pragmaBoolean into: (aSequenceNode leftBar: leftBar temporaries: temps rightBar: rightBar)! ! !RBParser methodsFor: 'testing' stamp: ''! atEnd ^currentToken class == RBToken! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parseKeywordMessageWith: node | args isKeyword keywords | args := OrderedCollection new: 3. keywords := OrderedCollection new: 3. isKeyword := false. [currentToken isKeyword] whileTrue: [keywords add: currentToken. self step. args add: self parseBinaryMessage. isKeyword := true]. ^isKeyword ifTrue: [self messageNodeClass receiver: node selectorParts: keywords arguments: args] ifFalse: [node]! ! !RBParser methodsFor: 'private-parsing' stamp: 'MarcusDenker 9/20/2013 15:07'! parseNegatedNumber | token | (self nextToken isLiteralToken not or: [ self nextToken realValue isNumber not ]) ifTrue: [ ^ self parserError: 'only numbers may be negated' ]. token := RBLiteralToken value: self nextToken realValue negated start: currentToken start stop: nextToken stop. self step; step. ^ self literalNodeClass literalToken: token ! ! !RBParser methodsFor: 'error handling' stamp: 'GiselaDecuzzi 6/10/2013 15:53'! parserError: aString "Let the errorBlock try to recover from the error." | errorNode errorMessage errorPosition | errorNode := self errorBlock cull: aString cull: self errorPosition cull: self. errorNode ifNotNil: [ ^ errorNode ]. currentToken isError ifTrue: [ errorMessage := currentToken cause. errorPosition := currentToken location ] ifFalse: [errorMessage := aString. errorPosition := currentToken start]. SyntaxErrorNotification inClass: Object category: nil withCode: source doitFlag: false errorMessage: errorMessage location: errorPosition! ! !RBParser methodsFor: 'accessing' stamp: 'MarcusDenker 5/17/2013 14:15'! parseLiterals: aString | stream | stream := WriteStream on: (Array new: 5). [self atEnd or: [currentToken isSpecial and: [currentToken value = $)]]] whileFalse: [stream nextPut: self parseLiteralArrayObject]. self atEnd ifFalse: [ ^ self parserError: 'Unknown input at end']. ^stream contents collect: [ :each | each value ]! ! !RBParser methodsFor: 'private-parsing' stamp: 'ClementBera 7/26/2013 17:10'! parseMethod | methodNode | methodNode := self parseMessagePattern. self parsePragmas. self addCommentsTo: methodNode. methodNode body: self sequenceNodeClass new. (self parseStatements: false into: methodNode body). pragmas ifNotNil: [ methodNode pragmas: pragmas ]. ^methodNode! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parsePrimitiveLiteral | token | token := currentToken. self step. ^self literalNodeClass literalToken: token! ! !RBParser methodsFor: 'accessing' stamp: 'CamilloBruni 10/31/2012 18:37'! parseExpression: aString | node | node := self parseStatements: false. (RBMethodNode selector: #noMethod body: node) source: aString. "Make the sequence node have a method node as its parent" self atEnd ifFalse: [ ^ self parserError: 'Unknown input at end']. ^node! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parseUnaryMessageWith: aNode | selector | selector := currentToken. self step. ^self messageNodeClass receiver: aNode selectorParts: (Array with: selector) arguments: #()! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:37'! parseBlockArgsInto: node | verticalBar args colons | args := OrderedCollection new: 2. colons := OrderedCollection new: 2. verticalBar := false. [currentToken isSpecial and: [currentToken value = $:]] whileTrue: [colons add: currentToken start. self step. ":" verticalBar := true. args add: self parseVariableNode]. verticalBar ifTrue: [currentToken isBinary ifTrue: [node bar: currentToken start. currentToken value = #| ifTrue: [self step] ifFalse: [currentToken value = #'||' ifTrue: ["Hack the current token to be the start of temps bar" currentToken value: #|; start: currentToken start + 1] ifFalse: [ ^ self parserError: '''|'' expected']]] ifFalse: [(currentToken isSpecial and: [currentToken value = $]]) ifFalse: [ ^ self parserError: '''|'' expected']]]. node arguments: args; colons: colons. ^node! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:36'! parseArray | position node | position := currentToken start. self step. node := self arrayNodeClass new. node left: position. self parseStatementList: false into: node. (currentToken isSpecial and: [currentToken value = $}]) ifFalse: [ ^ self parserError: 'expected }']. node right: currentToken start. self step. ^ node! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! methodNodeClass ^ RBMethodNode! ! !RBParser methodsFor: 'private' stamp: 'ClementBera 7/26/2013 17:09'! addPragma: aPragma pragmas ifNil: [ pragmas := OrderedCollection new ]. pragmas addLast: aPragma! ! !RBParser methodsFor: 'private-parsing' stamp: ''! parseBinaryMessageWith: aNode | binaryToken | binaryToken := currentToken. self step. ^self messageNodeClass receiver: aNode selectorParts: (Array with: binaryToken) arguments: (Array with: self parseUnaryMessage)! ! !RBParser class methodsFor: 'accessing' stamp: 'GiselaDecuzzi 5/28/2013 13:22'! errorNodeBlock ^ [ :aString :position :parser| parser parseErrorNode: aString ]! ! !RBParser class methodsFor: 'parsing' stamp: ''! parseRewriteExpression: aString onError: aBlock ^RBPatternParser parseExpression: aString onError: aBlock! ! !RBParser class methodsFor: 'parsing' stamp: 'MarcusDenker 5/17/2013 14:08'! parseLiterals: aString | parser | parser := self new. parser initializeParserWith: aString. ^parser parseLiterals: aString! ! !RBParser class methodsFor: 'parsing' stamp: ''! parseMethodPattern: aString | parser | parser := self new. parser errorBlock: [:error :position | ^nil]. parser initializeParserWith: aString. ^parser parseMessagePattern selector! ! !RBParser class methodsFor: 'parsing' stamp: ''! parseMethod: aString ^self parseMethod: aString onError: nil! ! !RBParser class methodsFor: 'parsing' stamp: ''! parseRewriteExpression: aString ^self parseRewriteExpression: aString onError: nil! ! !RBParser class methodsFor: 'parsing' stamp: ''! parseRewriteMethod: aString onError: aBlock ^RBPatternParser parseMethod: aString onError: aBlock! ! !RBParser class methodsFor: 'parsing' stamp: 'GiselaDecuzzi 5/28/2013 15:09'! parseExpression: aString onError: aBlock | node parser | parser := self new. parser errorBlock: aBlock. parser initializeParserWith: aString. node := parser parseExpression: aString. ^(node statements size == 1 and: [node temporaries isEmpty]) ifTrue: [node statements first] ifFalse: [node]! ! !RBParser class methodsFor: 'parsing' stamp: 'GiselaDecuzzi 6/5/2013 09:53'! parseFaultyMethod: aString ^self parseMethod: aString onError: self errorNodeBlock! ! !RBParser class methodsFor: 'parsing' stamp: ''! parseExpression: aString ^self parseExpression: aString onError: nil! ! !RBParser class methodsFor: 'accessing' stamp: 'MarcusDenker 12/21/2012 12:13'! parseCompiledMethod: aCompiledMethod ^ self parseMethod: aCompiledMethod sourceCode! ! !RBParser class methodsFor: 'parsing' stamp: 'GiselaDecuzzi 5/28/2013 15:09'! parseMethod: aString onError: aBlock | parser | parser := self new. parser errorBlock: aBlock. parser initializeParserWith: aString. ^parser parseMethod: aString! ! !RBParser class methodsFor: 'parsing' stamp: ''! parseRewriteMethod: aString ^self parseRewriteMethod: aString onError: nil! ! !RBParser class methodsFor: 'parsing' stamp: 'CamilloBruni 10/31/2012 19:08'! parseFaultyExpression: aString ^self parseExpression: aString onError: self errorNodeBlock! ! !RBParserTest commentStamp: 'TorstenBergmann 2/4/2014 21:53'! SUnit tests for RBParser! !RBParserTest methodsFor: 'tests' stamp: 'lr 11/2/2009 00:14'! testBlockRewrites | rewriter tree | tree := RBParser parseMethod: 'method: asdf ^asdf + self foo + asdf'. rewriter := RBParseTreeRewriter new. rewriter replace: 'asdf' with: 'fdsa' when: [:aNode | aNode parent parent isReturn]. rewriter replace: 'self foo' withValueFrom: [:aNode | RBVariableNode named: aNode selector asString]. rewriter replaceArgument: 'asdf' withValueFrom: [:aNode | RBVariableNode named: 'xxx'] when: [:aNode | false]. rewriter executeTree: tree. self compare: tree to: (RBParser parseMethod: 'method: asdf ^asdf + foo + fdsa')! ! !RBParserTest methodsFor: 'tests' stamp: ''! testReadBeforeWritten1 self assert: (RBReadBeforeWrittenTester variablesReadBeforeWrittenIn: (RBParser parseMethod: 'addAll: aCollection "Answer aCollection, having added all elements of aCollection to the receiver. Fail if aCollection is not a kind of Collection." | newSize elementsSize growSize | (newSize := aCollection size * 2) > elements size ifTrue: [self rehash: newSize]. elementsSize := elements size. growSize := elementsSize // 2. aCollection do: [:newObject | | hashIndex element | newObject == nil ifFalse: [hashIndex := self hashIndexFor: newObject. [(element := elements at: hashIndex) == nil ifTrue: [elements at: hashIndex put: newObject. (elementCount := elementCount + 1) > growSize ifTrue: [self expand. elementsSize := elements size. growSize := elementsSize // 2]. true] ifFalse: [element == newObject]] whileFalse: [(hashIndex := hashIndex + 1) > elementsSize ifTrue: [hashIndex := 1]]]]. ^aCollection')) isEmpty! ! !RBParserTest methodsFor: 'tests' stamp: ''! testQuerying | tree aNode arg1Node bNode | tree := RBParser parseMethod: ('test: a` | b |` b := (self foo: a; bar) baz.` b := super test: b.` ^[:arg1 | self foa1 + (super foo: arg1 foo: a foo: b)]' copyReplaceAll: '`' with: (String with: (Character value: 13))). self assert: tree selfMessages asSortedCollection asArray = #(#bar #foa1 #foo:). self assert: tree superMessages asSortedCollection asArray = #(#foo:foo:foo: #test:). aNode := tree whichNodeIsContainedBy: (112 to: 112). self assert: aNode name = 'a'. bNode := tree whichNodeIsContainedBy: (119 to: 119). self assert: bNode name = 'b'. arg1Node := tree whichNodeIsContainedBy: (102 to: 105). self assert: arg1Node name = 'arg1'. self assert: (arg1Node statementNode isMessage and: [arg1Node statementNode selector = #+]). self assert: (arg1Node whoDefines: 'arg1') isBlock. self assert: (aNode whoDefines: 'a') isMethod. self assert: (aNode whoDefines: 'b') isSequence. self assert: (tree whichNodeIsContainedBy: (91 to: 119)) selector = #foo:foo:foo:. self assert: (tree whichNodeIsContainedBy: (69 to: 121)) isBlock. self assert: (tree whichNodeIsContainedBy: (69 to: 118)) isNil. self assert: aNode blockVariables asSortedCollection asArray = #('arg1'). self assert: aNode temporaryVariables asSortedCollection asArray = #('b'). self assert: tree allDefinedVariables asSortedCollection asArray = #('a' 'arg1' 'b'). self assert: tree allArgumentVariables asSortedCollection asArray = #('a' 'arg1'). self assert: tree allTemporaryVariables asSortedCollection asArray = #('b')! ! !RBParserTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:58'! exampleClasses ^ Array with: RBParser with: RBScanner with: RBProgramNode with: RBConfigurableFormatter! ! !RBParserTest methodsFor: 'tests' stamp: 'nk 2/23/2005 15:58'! testReadBeforeWritten #(('a ifTrue: [^self]' true ) ('self foo. a := b' false ) ('condition ifTrue: [a := b] ifFalse: [self foo: a]' true ) ('condition ifTrue: [a := b] ifFalse: [self foo]. a isNil' true ) ('condition ifTrue: [a := b]. a := c' false ) ('[a := b] whileFalse: [a isNil]' false ) ('self foo: b' false ) ) do: [:each | self assert: ((RBReadBeforeWrittenTester readBeforeWritten: #('a' ) in: (RBParser parseExpression: each first)) includes: 'a') == each last. self assert: (RBReadBeforeWrittenTester isVariable: 'a' readBeforeWrittenIn: (RBParser parseExpression: each first)) = each last]. #('| temp read written written1 | read ifTrue: [^self]. written1 := self foo ifFalse: [written := true] ifTrue: [written := false]. [temp := true] whileTrue: [temp notNil & written]. ^temp' '| read written | self foo ifTrue: [written := true] ifFalse: [written := false]. self foo ifTrue: [read := true]. ^read' '| read written | self foo do: [:i | i]. [| i | i := 1. i == 1] whileFalse: [read notNil]' '| written | [written := 2] whileFalse. self do: [:each | | read | each & read]' '| read | self do: [:each | read := each]. self do: [:each | each & read]' ) do: [:each | | read | read := RBReadBeforeWrittenTester variablesReadBeforeWrittenIn: (RBParser parseExpression: each). self assert: (read size = 1 and: [read includes: 'read'])]! ! !RBParserTest methodsFor: 'tests' stamp: 'GiselaDecuzzi 5/27/2013 19:31'! testParseFaultyMethodExpresionHasErrorNodeAsFinal | node strangeExpression | strangeExpression := 'method: asd ^ asd. n'. node := self parseFaultyMethod: strangeExpression. self assert: node isMethod. self assert: node isFaulty. self assert: node statements size equals: 2. self assert: node statements last isFaulty ! ! !RBParserTest methodsFor: 'private' stamp: 'GiselaDecuzzi 5/27/2013 18:31'! parseFaultyMethod: text ^RBParser parseFaultyMethod: text.! ! !RBParserTest methodsFor: 'tests' stamp: 'ms 4/1/2007 13:49'! testPrimitives self assert: (Object parseTreeFor: #basicAt:) isPrimitive. #(('foo ^true' false ) ('foo ^true' false ) (' foo ^true' true ) ) do: [:each | self assert: (RBParser parseMethod: each first) isPrimitive = each last]! ! !RBParserTest methodsFor: 'tests' stamp: 'GiselaDecuzzi 6/10/2013 11:38'! testParseFaultyMethod | node strangeExpressions | strangeExpressions := OrderedCollection new . strangeExpressions add: 'method: asd self ,'; add: 'method: asd self a:'; "message without needed argument" add: 'method: asd []]'; add: 'method: asd [ ] ,';"binary message without second argument" add: 'method: ^^'; "returning twice" add: 'method: asd ['; "opening a block" add: 'method: asd ^ asd. n'; "invalid expresion after return" add: 'method: asd ^ {'; "Only Open a literal array" add: 'selector '''; add: 'selector #^'; add: 'selector ¿'. strangeExpressions do: [ :exp | node := self parseFaultyMethod: exp. self assert: node isMethod. self assert: node isFaulty. ]. ! ! !RBParserTest methodsFor: 'tests' stamp: 'ms 4/1/2007 12:32'! testPositions | blockNode | blockNode := RBParser parseExpression: '[:a :b | ]'. self assert: blockNode left = 1. self assert: blockNode right = 10. self assert: blockNode bar = 8. self assert: blockNode sourceInterval = (1 to: 10). self assert: blockNode size = 1. "test dummy collection protocol" blockNode printString. "coverage" self deny: (blockNode isLast: (RBVariableNode named: 'b')). self compare: blockNode to: (RBBlockNode arguments: (OrderedCollection with: (RBVariableNode named: 'a') with: (RBVariableNode named: 'b')) body: (RBSequenceNode statements: OrderedCollection new)). ! ! !RBParserTest methodsFor: 'tests' stamp: 'GiselaDecuzzi 6/10/2013 13:30'! testParseMethodWithErrorTokenIsWellFormed | node strangeMethod body statement message errorNode | strangeMethod := ' selector |temp| temp := ''this is right'', ''wrong because no end. ^temp'. node := self parseFaultyMethod: strangeMethod. self assert: node isMethod. self assert: node isFaulty. self assert: node arguments isEmpty. body := node body. self assert: body isSequence. self assert: body isFaulty. self assert: (body temporaries includes: (RBVariableNode named: 'temp')). statement := body statements first. self assert: statement isFaulty. self assert: statement isAssignment . message := statement value. self assert: message isFaulty. self assert: message arguments size equals: 1. errorNode := message arguments at: 1. self assert: errorNode isFaulty. self assert: errorNode token isError. self assert: errorNode errorMessage equals: 'Unmatched '' in string literal.' translated. ! ! !RBParserTest methodsFor: 'tests' stamp: 'CamilloBruni 3/6/2013 15:03'! testPragmaPrimitiveError | tree pragma | tree := RBParser parseMethod: 'veryBasicAt: index ^ code'. self assert: tree pragmas size equals: 1. pragma := tree pragmas first. self assert: pragma selector equals: #primitive:module:error:.! ! !RBParserTest methodsFor: 'private' stamp: 'lr 9/18/2011 15:09'! treeWithEverything ^ RBParser parseMethod: 'method: arg1 | temps | temps := #(10). temps foo; foo. ^(temps collect: [:e | ])'! ! !RBParserTest methodsFor: 'private' stamp: 'lr 9/18/2011 15:09'! treeWithReallyEverything ^ RBParser parseMethod: 'method: arg1 | temps | temps := #[ 1 2 3 ]. temps := #(true false nil 1 1.2 $a foo #foo ''foo'' #() #(1 2) #[] #[1 2]). { 1 negated. 1 + 2. 1 raisedTo: 2 }. temps foo; foo: self. ^ (temps collect: [:e | | btemps | ((e isNil)) ])'! ! !RBParserTest methodsFor: 'accessing' stamp: ''! compare: anObject to: anotherObject self assert: anObject hash = anotherObject hash. self assert: anObject = anotherObject! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 12/16/2009 19:16'! testNumberParsing | numbers node | numbers := #(('1' 1) ('-1' -1) ('123' 123) ('123' 123) ('-123' -123) ('1.1' 1.1) ('-1.1' -1.1) ('1.23' 1.23) ('-1.23' -1.23) ('1e3' 1e3) ('1d3' 1d3) ('1q3' 1q3) ('-1e3' -1e3) ('1e-3' 1e-3) ('-1e-3' -1e-3) ('2r1e8' 2r1e8) ('-2r1e8' -2r1e8) ('2r1e-8' 2r1e-8) ('-2r1e-8' -2r1e-8) ('0.50s2' 0.50s2) ('0.500s3' 0.500s3) ('0.050s3' 0.050s3)). numbers do: [ :spec | node := RBParser parseExpression: spec first. self assert: node token source = spec first. self assert: node value = spec second ]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 9/18/2011 15:19'! testEqualToWithMapping | tree | tree := self treeWithEverything. self assert: (tree equalTo: tree withMapping: Dictionary new). tree := self treeWithReallyEverything. self assert: (tree equalTo: tree withMapping: Dictionary new). self exampleClasses do: [ :class | class selectors do: [ :each | tree := class parseTreeFor: each. self assert: (tree equalTo: tree withMapping: Dictionary new) ] ]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 11/2/2009 00:14'! testPatternCascade | rewriter | rewriter := RBParseTreeRewriter new. rewriter replace: 'self `;messages; foo: 4; `;messages1' with: 'self `;messages1; bar: 4; `;messages'. self compare: (rewriter executeTree: (RBParser parseExpression: 'self foo; printString; foo: 4; bar. self foo: 4'); tree) to: (RBParser parseExpression: 'self bar; bar: 4; foo; printString. self foo:4')! ! !RBParserTest methodsFor: 'tests' stamp: 'ClementBEra 1/30/2013 15:05'! testSymbolLiteral | tree | #( '#<' #< '#>' #> '#<>' #<> '# foo' #foo '#"bar"foo' #foo '##foo' #foo '###foo' #foo '#foo:' #foo: '#foo::' #'foo::' '#foo::bar' #'foo::bar' '#foo::bar:' #'foo::bar:' '#foo::bar::' #'foo::bar::') pairsDo: [ :parseString :expectedResult | tree := RBParser parseExpression: parseString. self assert: tree value equals: expectedResult. self assert: tree start equals: 1. self assert: tree stop equals: parseString size ]. #(('#1' 1) ('#12' 12) ('#12.3' 12.3) ('# 1' 1) ('##1' 1) ('#"bar"1' 1)) do: [ :pair | tree := RBParser parseExpression: pair first. self assert: tree value = pair second. self assert: tree start > 1. self assert: tree stop = pair first size ]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 5/30/2010 12:15'! testRewriteMethods "#('source' 'target' 'source pattern' 'target pattern')" #(#('arg1: a arg2: b | temp1 temp2 | self stmt1 ifTrue: [^a]. self arg1: a arg2: b' 'arg2: a arg1: b | temp1 temp2 | self stmt1 ifTrue: [^a]. self arg2: b arg2: a' '`arg1: `var1 `arg2: `var2 | `@temps | ``@.stmts. self `arg1: `var1 `arg2: `var2. `@.stmts1' '`arg2: `var1 `arg1: `var2 | `@temps | ``@.stmts. self `arg2: `var2 `arg2: `var1. `@.stmts1') #('arg1: a arg2: b | temp1 temp2 | self stmt1. self arg1: a arg2: b' 'arg1: a arg2: b | temp1 temp2 | [self stmt1] repeat' '`@args: `@vars | `@temps | `@.stmts. self `@args: `@vars' '`@args: `@vars | `@temps | [`@.stmts] repeat') #('+ a | temps | ^self primitiveValue' '- a | temps | ^self primitiveValue' '+ `temp | `@tmps | `@.stmts' '- `temp | `@tmps | `@.stmts') #('a self stmt1. self stmt2' 'a self stmt1. self stmt2' 'b | `@temps | `@.stmts' 'c | `@temps | `@.stmts') #('a ' 'a ' 'a <`sel1: `#arg1 `sel2: `#arg2>' 'a <`sel2: `#arg2 `sel1: `#arg1>') #('a self foo' 'b self foo' 'a `@.stmts' 'b `@.stmts')) do: [:each | | rewrite | rewrite := RBParseTreeRewriter new. rewrite replaceMethod: (each at: 3) with: each last. self compare: (RBParser parseMethod: (rewrite executeTree: (RBParser parseMethod: each first); tree) formattedCode) to: (RBParser parseMethod: (each at: 2)). rewrite := RBParseTreeRewriter new. rewrite replaceTree: (RBParser parseRewriteMethod: (each at: 3)) withTree: (RBParser parseRewriteMethod: each last). self compare: (RBParser parseMethod: (rewrite executeTree: (RBParser parseMethod: each first); tree) formattedCode) to: (RBParser parseMethod: (each at: 2))]! ! !RBParserTest methodsFor: 'tests' stamp: 'nk 2/23/2005 15:58'! testEquivalentExceptRenaming #(('a 3-4' 'a 4-3' false ) ('a #[3 4]' 'a #(3 4)' false ) ('a variable1 ~~ "comment" variable2' 'a variable1 ~~ variable2' true ) ('a variable1' 'a variable2' false ) ('a [:a :b | a + b]' 'a [:b :a | a + b]' false ) ('a | a b | a + b' 'a | b a | a + b' true ) ('a | a | a msg1; msg2' 'a | b | b msg2; msg2' false ) ('a c' 'a d' true ) ('a | a b | a := b. ^b msg1' 'a | a b | b := a. ^a msg1' true ) ('a | a b | a := b. ^b msg1: a' 'a | a b | b := a. ^b msg1: a' false ) ('a: b b + 4' 'a: e e + 4' true ) ('a: b b + 4' 'b: b b + 4' false ) ('a: b b: c b + c' 'a: c b: b c + b' true ) ('a: a b: b a + b' 'a: b b: a a + b' false ) ) do: [:each | self assert: ((RBParser parseMethod: each first) equalTo: (RBParser parseMethod: (each at: 2)) exceptForVariables: #('c' )) == each last ]! ! !RBParserTest methodsFor: 'tests' stamp: 'ClementBEra 1/30/2013 15:29'! testPragmas | tree node | #(('foo ' #foo ()) ('foo ' #foo: (1)) ('foo ' #foo: (1.2)) ('foo ' #foo: (-3)) ('foo ' #foo: (a)) ('foo ' #foo: (a)) ('foo ' #foo: (<)) ('foo >' #foo: (>)) ('foo ' #foo: ($a)) ('foo ' #foo: ('bar')) ('foo ' #foo: (true)) ('foo ' #foo: (false)) ('foo ' #foo: (nil)) ('foo ' #foo: ((1 2))) ('foo ' #foo:bar: (1 2)) ('foo |t| ' #foo: (1.2)) ('foo self. ' #foo: ($a)) ('foo |t| ' #foo:bar: (1 2)) ) do: [ :each | tree := RBParser parseMethod: each first. self assert: (tree pragmas size = 1). node := tree pragmas first. self assert: node selector = each second. 1 to: node arguments size do: [ :i | self assert: (node arguments at: i) value = (each last at: i) ]. self assert: (each first at: node start) equals: $<. self assert: (each first at: node stop) equals: $> ]. self assert: (RBParser parseMethod: 'selector ') isMethod. self assert: (RBParser parseMethod: ' selector "comment1" |temp| "comment2" #<. ^1') isMethod. self should: [RBParser parseMethod: ' selector "comment1" |temp| "comment2" <. ^1'] raise: SyntaxErrorNotification.! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 11/2/2009 00:14'! testSearching | searcher | searcher := RBParseTreeSearcher new. searcher matches: '``@rcv at: ``@arg `sel: ``@arg1' do: [:aNode :answer | answer + 1]. self assert: (searcher executeTree: (RBParser parseExpression: 'self at: 1 put: 2; at: 2 ifAbsent: []; ifAbsent: 2 at: 1; at: 4; foo') initialAnswer: 0) = 2. searcher := RBParseTreeSearcher new. searcher matches: '``@rcv `at: ``@arg1 `at: ``@arg2' do: [:aNode :answer | answer + 1]. self assert: (searcher executeTree: (RBParser parseExpression: 'self at: 1 at: 3; at: 1 put: 32; at: 2; foo; at: 1 at: 1 at: 2') initialAnswer: 0) = 1. searcher := RBParseTreeSearcher new. searcher matchesMethod: 'at: `object `put: `o1 ``@rcv `put: 1' do: [:aNode :answer | true]. self assert: (searcher executeTree: (RBParser parseMethod: 'at: a put: b self foo put: 1') initialAnswer: false)! ! !RBParserTest methodsFor: 'tests' stamp: 'MarcusDenker 9/20/2013 15:07'! testIntervals | tree | tree := self treeWithReallyEverything. tree nodesDo: [:each | (each parent isNil or: [each parent isCascade not and: [ each parent isLiteralNode not]]) ifTrue: [| newNode source | source := tree source copyFrom: each start to: each stop. each isPragma ifFalse: [ newNode := each isMethod ifTrue: [RBParser parseMethod: source] ifFalse: [RBParser parseExpression: source]. self compare: each to: newNode]]]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 9/18/2011 15:18'! testCopy | tree | tree := self treeWithEverything. self compare: tree to: tree copy. tree := self treeWithReallyEverything. self compare: tree to: tree copy. self exampleClasses do: [ :class | class selectors do: [ :each | tree := class parseTreeFor: each. self compare: tree to: tree copy ] ]! ! !RBParserTest methodsFor: 'tests' stamp: 'ms 4/1/2007 12:11'! testCreationProtocol | messageNode | self compare: (RBMessageNode receiver: (RBVariableNode named: 'self') selector: #+ arguments: (Array with: (RBLiteralNode value: 0))) to: (RBParser parseExpression: 'self + 0'). messageNode := RBMessageNode receiver: (RBVariableNode named: 'self') selector: #foo. self compare: (RBMethodNode selector: #bar body: (RBSequenceNode statements: (OrderedCollection with: (RBCascadeNode messages: (OrderedCollection with: messageNode with: messageNode))))) to: (RBParser parseMethod: 'bar self foo; foo')! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 11/2/2009 00:14'! testMultimatch | rewriter count | count := 0. rewriter := RBParseTreeRewriter new. rewriter replace: '``@object at: ``@foo' with: '``@object foo: ``@foo' when: [:aNode | (count := count + 1) == 2]. self compare: (rewriter executeTree: (RBParser parseExpression: 'self at: (bar at: 3)'); tree) to: (RBParser parseExpression: 'self at: (bar foo: 3)')! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 11/1/2009 20:44'! testArray | tree | #(('{}' 0 0) ('{.}' 0 1) ('{..}' 0 2) ('{foo. bar}' 2 1) ('{foo. bar.}' 2 2) ('{foo. bar. .}' 2 3) ('{. foo. bar}' 2 2) ('{foo.. bar}' 2 2)) do: [ :each | tree := RBParser parseExpression: each first. self assert: tree statements size = each second. self assert: tree periods size = each last. self assert: tree left = 1. self assert: tree right = each first size ]! ! !RBParserTest methodsFor: 'tests' stamp: ''! testCascadeReplacement | cascade | cascade := RBParser parseExpression: 'self foo; bar; baz'. (cascade messages at: 2) replaceWith: (RBParser parseExpression: 'self bar: 2'). self compare: cascade to: (RBParser parseExpression: 'self foo; bar: 2; baz')! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 11/1/2009 20:50'! testNodesDo | size | size := 0. self treeWithEverything nodesDo: [:e | size := size + 1]. self assert: size = 19! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 4/29/2010 21:22'! testSymbolNumber | tree | #(('#1' 1) ('#12' 12) ('#12.3' 12.3) ('# 1' 1) ('##1' 1) ('#"bar"1' 1)) do: [ :pair | tree := RBParser parseExpression: pair first. self assert: tree value = pair second. self assert: tree start > 1. self assert: tree stop = pair first size ]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 11/1/2009 20:40'! testLiteralIntevals | tree | tree := RBParser parseExpression: '#(#a b #( c ))'. self assert: tree contents first start = 3. self assert: tree contents first stop = 4. self assert: tree contents last contents first start = 11! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 9/18/2011 15:19'! testComparingTrees self compare: self treeWithEverything to: self treeWithEverything. self compare: self treeWithReallyEverything to: self treeWithReallyEverything. self exampleClasses do: [ :class | class selectors do: [ :selector | self compare: (class parseTreeFor: selector) to: (class parseTreeFor: selector) ] ]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 11/1/2009 20:38'! testParserErrors #(#('self foo. + 3' 11) #('#(' 3) #('self 0' 6) #('self asdf;;asfd' 11)) do: [:each | self parseError: each]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 9/18/2011 15:20'! testFormatter self exampleClasses do: [ :class | class selectors do: [ :selector | self compare: (class parseTreeFor: selector) to: (RBParser parseMethod: (class parseTreeFor: selector) printString) ] ]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 11/1/2009 20:36'! testLiteralArray | tree collection | tree := RBParser parseExpression: '#( a #b #''c'' . + - 1 -2 3.4 #true true #false false #nil nil "comment" ''string'' #[ 1 2 3 ] #(1 2 3))'. collection := OrderedCollection new. collection add: #a; add: #b; add: #c; add: #'.'; add: #+; add: #-; add: 1; add: -2; add: 3.4; add: #true; add: true; add: #false; add: false; add: #nil; add: nil; add: 'string'; add: #[1 2 3]; add: #(1 2 3). tree value with: collection do: [ :token :value | self assert: token value = value ]! ! !RBParserTest methodsFor: 'tests' stamp: 'SeanDeNigris 2/9/2013 15:02'! testRewrites "#('source' 'target' 'source pattern' 'target pattern')" #( ( '[:c | |a| a foo1; foo2]' '[:c | |a| b foo1; foo2]' 'a' 'b' ) ( 'self foo: 1. bar foo1 foo: 2. (self foo: a) foo: (b foo: c)' 'self bar: 1. bar foo1 bar: 2. (self bar: a) bar: (b bar: c)' '``@rcvr foo: ``@arg1' '``@rcvr bar: ``@arg1' ) ('3 + 4' '4 + 4' '3' '4' ) ('a := self a' 'b := self a' 'a' 'b' ) ( '^self at: 1 put: 2' '^self put: 1 put: 2' '^`@rcvr `at: `@arg1 put: `@arg2' '^`@rcvr put: `@arg1 put: `@arg2' ) ('1 + 2 + 3' '0 + 0 + 0' '`#literal' '0' ) ( '1 + 2 + 3. 3 foo: 4' '3 + (2 + 1). 4 foo: 3' '``@rcvr `msg: ``@arg' '``@arg `msg: ``@rcvr' ) ( 'self foo: a bar: b. 1 foo: a bar: b' '2 foo: a bar: b. 1 foo: a bar: b' 'self `@msg: `@args' '2 `@msg: `@args' ) ( 'a := b. a := c + d' 'b := a. a := c + d' '`var1 := `var2' '`var2 := `var1' ) ( '^self foo value: 1' 'self return: (self foo value: 1)' '^`@anything' 'self return: `@anything' ) ( 'self first; second. self first; second. self a. self b' '2 timesRepeat: [self first; second]. self a. self b' '`.Stmt1. `.Stmt1. `@.stmts' '2 timesRepeat: [`.Stmt1]. `@.stmts' ) ( '[:a | self a: 1 c: 2; b]' '[:a | self d: 2 e: 1; f. self halt]' '`@rcvr `msg1: `@arg1 `msg2: `@arg2; `msg' '`@rcvr d: `@arg2 e: `@arg1; f. self halt' ) ) do: [:each | | rewrite | rewrite := RBParseTreeRewriter new. rewrite replace: (each at: 3) with: each last. self compare: (RBParser parseExpression: (rewrite executeTree: (RBParser parseExpression: each first); tree) formattedCode) to: (RBParser parseExpression: (each at: 2))]! ! !RBParserTest methodsFor: 'tests' stamp: ''! testMethodPatterns #(#('+ a ^self + a' #+) #('foo ^self foo' #foo) #('foo: a bar: b ^a + b' #foo:bar:)) do: [:each | self assert: (RBParser parseMethodPattern: each first) == each last]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 11/1/2009 20:32'! testStatements | tree | #(('' 0 0) ('.' 0 1) ('| bar |' 0 0) ('| bar | .' 0 1) ('| bar | ..' 0 2) ('foo. bar' 2 1) ('foo. bar.' 2 2) ('foo. bar. .' 2 3) ('. foo. bar' 2 2)) do: [ :each | tree := RBParser parseExpression: each first. self assert: tree statements size = each second. self assert: tree periods size = each last ]! ! !RBParserTest methodsFor: 'tests' stamp: 'ClementBEra 1/30/2013 15:09'! testString self assert: (RBParser parseMethod: 'selector ^ ''<''') isMethod. self assert: (RBParser parseMethod: 'selector ^ ''<'', self') isMethod. self assert: (RBParser parseMethod: 'selector ''=''') isMethod. self assert: (RBParser parseMethod: 'selector '':=''') isMethod. self assert: (RBParser parseMethod: 'selector ''<''') isMethod. self assert: (RBParser parseMethod: 'selector ''>''') isMethod. self assert: (RBParser parseMethod: 'selector ^ ''<>''') isMethod.! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 12/16/2009 09:22'! testNumberRadixParsing 2 to: 32 do: [ :radix | | radixString | radixString := radix printString, 'r'. 0 to: 72 do: [ :i | self assert: (RBParser parseExpression: (radixString, (i radix: radix))) value = i ] ]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 10/27/2009 14:31'! testBestNodeFor | tree | tree := self treeWithReallyEverything. tree nodesDo: [:each | each sourceInterval isEmpty ifFalse: [self assert: ((tree bestNodeFor: each sourceInterval) = each or: [each parent isCascade and: [each parent messages last = each]])]]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 9/18/2011 15:18'! testCopyInContext | tree | tree := self treeWithEverything. self compare: tree to: (tree copyInContext: Dictionary new). tree := self treeWithReallyEverything. self compare: tree to: (tree copyInContext: Dictionary new). self exampleClasses do: [ :class | class selectors do: [ :each | tree := class parseTreeFor: each. self compare: tree to: (tree copyInContext: Dictionary new) ] ]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 11/2/2009 00:14'! testReplacingNodes | tree search block | tree := RBParser parseMethod: '+ a | a b | self ifTrue: [a] ifFalse: [b := c]. a := b. [:b :c :a | a foo: a; foo1: a; foo2: a foo: b]. {a. b}. ^a'. search := RBParseTreeSearcher new. block := [:aNode :answer | aNode replaceWith: (RBVariableNode named: 'q')]. search matches: 'a' do: block; matchesArgument: 'a' do: block. search executeTree: tree. self assert: tree = (RBParser parseMethod: '+ q | q b | self ifTrue: [q] ifFalse: [b := c]. q := b. [:b :c :q | q foo: q; foo1: q; foo2: q foo: b]. {q. b}. ^q'). self assert: tree removeDeadCode = (RBParser parseMethod: '+ q | q b | self ifTrue: [] ifFalse: [b := c]. q := b. {q. b}. ^q')! ! !RBParserTest methodsFor: 'tests' stamp: 'md 2/26/2006 14:48'! testModifying | tree | tree := RBParser parseMethod: 'foo: a bar: b | c | self first. self second. a + b + c'. self deny: tree lastIsReturn. self deny: (tree body statements at: 2) isUsed. self assert: tree body statements last arguments first isUsed. self assert: (tree isLast: tree body statements last). self deny: (tree isLast: tree body statements first). self assert: (tree defines: 'a'). self deny: (tree defines: 'c'). self assert: (tree body defines: 'c'). self deny: (tree body defines: 'a'). tree addReturn; selector: #bar:foo:. (tree body) addTemporaryNamed: 'd'; removeTemporaryNamed: 'c'. self compare: tree to: (RBParser parseMethod: 'bar: a foo: b | d | self first. self second. ^a + b + c'). self assert: ((tree argumentNames asSet) removeAll: #('a' 'b'); yourself) isEmpty. self assert: ((tree allDefinedVariables asSet) removeAll: #('a' 'b' 'd'); yourself) isEmpty. tree := RBParser parseExpression: 'self foo: 0'. tree selector: #+. self compare: tree to: (RBParser parseExpression: 'self + 0'). self should: [tree selector: #foo] raise: TestResult error.! ! !RBParserTest methodsFor: 'tests' stamp: 'MarcusDenker 9/20/2013 15:07'! testIsA | nodes types | nodes := Bag new. types := Set new. #(#(#isAssignment 1) #(#isBlock 1) #(#isCascade 1) #(#isLiteralNode 2) #(#isMessage 3) #(#isMethod 1) #(#isReturn 1) #(#isSequence 2) #(#isValue 15) #(#isVariable 7) #(#isUsed 10) #(#isDirectlyUsed 9) #(#hasParentheses 1) #(#isBinary 0) #(#isPrimitive 0) #(#isImmediateNode 10) #(#isWrite 1) #(#isRead 3)) do: [:each | each last timesRepeat: [nodes add: each first]. types add: each first]. self treeWithEverything nodesDo: [:each | types do: [:sel | ((each respondsTo: sel) and: [each perform: sel]) ifTrue: [nodes remove: sel]]]. self assert: nodes isEmpty! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 5/26/2010 19:03'! testParents (Array with: self treeWithEverything with: self treeWithReallyEverything) do: [ :tree | (Array with: tree with: tree copy) do: [ :root | root nodesDo: [ :node | node children do: [ :each | (each parent isMessage and: [ each parent isCascaded ]) ifFalse: [ self assert: each parent == node. self assert: each methodNode == root ] ] ] ] ]! ! !RBParserTest methodsFor: 'private' stamp: 'lr 9/18/2011 15:10'! parseError: each RBParser parseExpression: each first onError: [ :string :pos | ^ self assert: pos = each last ]. self assert: false description: 'Parser didn''t fail'! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 9/18/2011 15:21'! testMatchInContext | tree | tree := self treeWithEverything. self assert: (tree match: tree inContext: Dictionary new). tree := self treeWithReallyEverything. self assert: (tree match: tree inContext: Dictionary new). self exampleClasses do: [ :class | class selectors do: [ :each | tree := class parseTreeFor: each. self assert: (tree match: tree inContext: Dictionary new) ] ]! ! !RBParserTest methodsFor: 'tests' stamp: 'lr 10/27/2009 15:53'! testParsingLiteralMessages self assert: (RBParser parseExpression: 'nil self nil') isMessage. self assert: (RBParser parseExpression: 'self true') isMessage. self assert: (RBParser parseExpression: 'self false') isMessage. self assert: (RBParser parseExpression: 'self -1') isMessage. self assert: (RBParser parseMethod: 'nil') isMethod. self assert: (RBParser parseMethod: 'true') isMethod. self assert: (RBParser parseMethod: 'false') isMethod! ! !RBPatternBlockNode commentStamp: 'md 8/9/2005 14:56'! RBPatternBlockNode is the node in matching parse trees (it never occurs in normal Smalltalk code) that executes a block to determine if a match occurs. valueBlock takes two arguments, the first is the actual node that we are trying to match against, and second node is the dictionary that contains all the metavariable bindings that the matcher has made thus far. Instance Variables: valueBlock The block to execute when attempting to match this to a node. ! !RBPatternBlockNode methodsFor: 'accessing' stamp: 'lr 5/30/2010 14:27'! sentMessages ^ OrderedCollection new! ! !RBPatternBlockNode methodsFor: 'matching' stamp: ''! createReplacingBlock | newBlock | self arguments size > 1 ifTrue: [self error: 'Replace blocks can only contain an argument for the matching dictionary']. newBlock := RBBlockNode arguments: arguments body: body. self arguments isEmpty ifTrue: [self addArgumentWithNameBasedOn: 'aDictionary' to: newBlock]. ^self createBlockFor: newBlock! ! !RBPatternBlockNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:30'! copyInContext: aDictionary ^ self replacingBlock value: aDictionary! ! !RBPatternBlockNode methodsFor: 'matching' stamp: ''! replacePatternNodesIn: aRBBlockNode aRBBlockNode body nodesDo: [:each | (each isVariable and: [each isPatternNode]) ifTrue: [each replaceWith: (self constructLookupNodeFor: each name in: aRBBlockNode)]]! ! !RBPatternBlockNode methodsFor: 'matching' stamp: 'ClementBera 7/26/2013 17:16'! replacingBlock ^ valueBlock ifNil: [valueBlock := self createReplacingBlock]! ! !RBPatternBlockNode methodsFor: 'matching' stamp: 'MarcusDenker 8/28/2013 10:20'! createBlockFor: aRBBlockNode self replacePatternNodesIn: aRBBlockNode. ^Smalltalk compiler source: aRBBlockNode formattedCode; receiver: self; evaluate! ! !RBPatternBlockNode methodsFor: 'matching' stamp: ''! lookupMatchFor: aString in: aDictionary ^aDictionary at: aString ifAbsent: [| variableNode | variableNode := RBPatternVariableNode named: aString. aDictionary at: variableNode ifAbsent: [nil]]! ! !RBPatternBlockNode methodsFor: 'matching' stamp: ''! addArgumentWithNameBasedOn: aString to: aRBBlockNode | name index vars | name := aString. vars := aRBBlockNode allDefinedVariables. index := 0. [vars includes: name] whileTrue: [index := index + 1. name := name , index printString]. aRBBlockNode arguments: (aRBBlockNode arguments copyWith: (RBVariableNode named: name))! ! !RBPatternBlockNode methodsFor: 'matching' stamp: ''! createMatchingBlock | newBlock | self arguments size > 2 ifTrue: [self error: 'Search blocks can only contain arguments for the node and matching dictionary']. newBlock := RBBlockNode arguments: arguments body: body. newBlock arguments isEmpty ifTrue: [self addArgumentWithNameBasedOn: 'aNode' to: newBlock]. newBlock arguments size = 1 ifTrue: [self addArgumentWithNameBasedOn: 'aDictionary' to: newBlock]. ^self createBlockFor: newBlock! ! !RBPatternBlockNode methodsFor: 'visitor' stamp: 'StephaneDucasse 3/29/2013 15:37'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitPatternBlockNode: self! ! !RBPatternBlockNode methodsFor: 'matching' stamp: ''! constructLookupNodeFor: aString in: aRBBlockNode | argumentNode | argumentNode := RBLiteralNode literalToken: (RBLiteralToken value: aString start: nil stop: nil). ^RBMessageNode receiver: (RBVariableNode named: 'self') selector: #lookupMatchFor:in: arguments: (Array with: argumentNode with: aRBBlockNode arguments last)! ! !RBPatternBlockNode methodsFor: 'matching' stamp: ''! match: aNode inContext: aDictionary ^self matchingBlock value: aNode value: aDictionary! ! !RBPatternBlockNode methodsFor: 'matching' stamp: 'ClementBera 7/26/2013 17:16'! matchingBlock ^ valueBlock ifNil: [valueBlock := self createMatchingBlock]! ! !RBPatternBlockToken commentStamp: 'md 8/9/2005 14:52'! RBPatternBlockToken is the first-class representation of the pattern block token. ! !RBPatternBlockToken methodsFor: 'testing' stamp: ''! isPatternBlock ^true! ! !RBPatternMessageNode commentStamp: 'md 8/9/2005 14:58'! RBPatternMessageNode is a RBMessageNode that will match other message nodes without their selectors being equal. Instance Variables: isCascadeList are we matching a list of message nodes in a cascaded message isList are we matching each keyword or matching all keywords together (e.g., `keyword1: would match a one argument method whereas `@keywords: would match 0 or more arguments)! !RBPatternMessageNode methodsFor: 'testing-matching' stamp: ''! isList ^isCascadeList and: [parent notNil and: [parent isCascade]]! ! !RBPatternMessageNode methodsFor: 'accessing' stamp: 'lr 5/30/2010 14:22'! sentMessages ^ super sentMessages remove: self selector ifAbsent: [ ]; yourself! ! !RBPatternMessageNode methodsFor: 'matching' stamp: 'lr 5/30/2010 10:35'! matchArgumentsAgainst: aNode inContext: aDictionary self arguments size = aNode arguments size ifFalse: [ ^ false ]. (self matchSelectorAgainst: aNode inContext: aDictionary) ifFalse: [ ^ false ]. self arguments with: aNode arguments do: [ :first :second | (first match: second inContext: aDictionary) ifFalse: [ ^ false ] ]. ^ true! ! !RBPatternMessageNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:40'! copyInContext: aDictionary | selectors | self isList ifTrue: [ ^ aDictionary at: self ]. selectors := self isSelectorList ifTrue: [ (aDictionary at: selectorParts first value) keywords ] ifFalse: [ self selectorParts collect: [ :each | aDictionary at: each value ] ]. ^ RBMessageNode new receiver: (self receiver copyInContext: aDictionary); selectorParts: (selectors collect: [ :each | (each last = $: ifTrue: [ RBKeywordToken ] ifFalse: [ RBIdentifierToken ]) value: each start: nil ]); arguments: (self copyList: self arguments inContext: aDictionary); yourself! ! !RBPatternMessageNode methodsFor: 'matching' stamp: 'lr 5/30/2010 10:38'! matchSelectorAgainst: aNode inContext: aDictionary self selectorParts with: aNode selectorParts do: [ :first :second | | keyword | keyword := aDictionary at: first value ifAbsentPut: [ first isPatternVariable ifTrue: [ second value ] ifFalse: [ first value ] ]. keyword = second value ifFalse: [ ^ false ] ]. ^ true! ! !RBPatternMessageNode methodsFor: 'testing-matching' stamp: ''! isPatternNode ^true! ! !RBPatternMessageNode methodsFor: 'matching' stamp: ''! match: aNode inContext: aDictionary aNode class == self matchingClass ifFalse: [^false]. (receiver match: aNode receiver inContext: aDictionary) ifFalse: [^false]. self isSelectorList ifTrue: [^(aDictionary at: selectorParts first value ifAbsentPut: [aNode selector]) == aNode selector and: [(aDictionary at: arguments first ifAbsentPut: [aNode arguments]) = aNode arguments]]. ^self matchArgumentsAgainst: aNode inContext: aDictionary! ! !RBPatternMessageNode methodsFor: 'testing-matching' stamp: ''! isSelectorList ^isList! ! !RBPatternMessageNode methodsFor: 'private' stamp: ''! matchingClass ^RBMessageNode! ! !RBPatternMessageNode methodsFor: 'initialize-release' stamp: ''! receiver: aValueNode selectorParts: keywordTokens arguments: valueNodes | message | super receiver: aValueNode selectorParts: keywordTokens arguments: valueNodes. isCascadeList := isList := false. message := keywordTokens first value. 2 to: message size do: [:i | | character | character := message at: i. character == self listCharacter ifTrue: [isList := true] ifFalse: [character == self cascadeListCharacter ifTrue: [isCascadeList := true] ifFalse: [^self]]]! ! !RBPatternMessageNode class methodsFor: 'instance creation' stamp: ''! receiver: aValueNode selectorParts: keywordTokens arguments: valueNodes ^(keywordTokens anySatisfy: [:each | each isPatternVariable]) ifTrue: [super receiver: aValueNode selectorParts: keywordTokens arguments: valueNodes] ifFalse: [RBMessageNode receiver: aValueNode selectorParts: keywordTokens arguments: valueNodes]! ! !RBPatternMethodNode commentStamp: 'md 8/9/2005 14:59'! RBPatternMethodNode is a RBMethodNode that will match other method nodes without their selectors being equal. Instance Variables: isList are we matching each keyword or matching all keywords together (e.g., `keyword1: would match a one argument method whereas `@keywords: would match 0 or more arguments) ! !RBPatternMethodNode methodsFor: 'matching' stamp: 'lr 5/30/2010 10:35'! matchArgumentsAgainst: aNode inContext: aDictionary self arguments size = aNode arguments size ifFalse: [ ^ false ]. (self matchSelectorAgainst: aNode inContext: aDictionary) ifFalse: [ ^ false ]. self arguments with: aNode arguments do: [ :first :second | (first match: second inContext: aDictionary) ifFalse: [ ^ false ] ]. ^ true! ! !RBPatternMethodNode methodsFor: 'matching' stamp: 'lr 5/30/2010 12:26'! copyInContext: aDictionary | selectors | selectors := self isSelectorList ifTrue: [ (aDictionary at: selectorParts first value) keywords ] ifFalse: [ self selectorParts collect: [ :each | aDictionary at: each value ] ]. ^ RBMethodNode new selectorParts: (selectors collect: [ :each | (each last = $: ifTrue: [ RBKeywordToken ] ifFalse: [ RBIdentifierToken ]) value: each start: nil ]); arguments: (self copyList: self arguments inContext: aDictionary); pragmas: (self pragmas isEmpty ifTrue: [ aDictionary at: '-pragmas-' ifAbsent: [ #() ] ] ifFalse: [ self copyList: self pragmas inContext: aDictionary ]); body: (self body copyInContext: aDictionary); source: (aDictionary at: '-source-'); yourself! ! !RBPatternMethodNode methodsFor: 'matching' stamp: 'lr 5/30/2010 10:38'! matchSelectorAgainst: aNode inContext: aDictionary self selectorParts with: aNode selectorParts do: [ :first :second | | keyword | keyword := aDictionary at: first value ifAbsentPut: [ first isPatternVariable ifTrue: [ second value ] ifFalse: [ first value ] ]. keyword = second value ifFalse: [ ^ false ] ]. ^ true! ! !RBPatternMethodNode methodsFor: 'testing-matching' stamp: ''! isPatternNode ^true! ! !RBPatternMethodNode methodsFor: 'matching' stamp: 'lr 5/30/2010 12:05'! match: aNode inContext: aDictionary aNode class = self matchingClass ifFalse: [ ^ false ]. aDictionary at: '-source-' put: aNode source. self isSelectorList ifTrue: [ ^ (aDictionary at: selectorParts first value ifAbsentPut: [ aNode selector ]) = aNode selector and: [ (aDictionary at: arguments first ifAbsentPut: [ aNode arguments ]) = aNode arguments and: [ (self matchPragmas: self pragmas against: aNode pragmas inContext: aDictionary) and: [ body match: aNode body inContext: aDictionary ] ] ] ]. ^(self matchArgumentsAgainst: aNode inContext: aDictionary) and: [ (self matchPragmas: self pragmas against: aNode pragmas inContext: aDictionary) and: [ body match: aNode body inContext: aDictionary ] ]! ! !RBPatternMethodNode methodsFor: 'initialize-release' stamp: ''! selectorParts: tokenCollection arguments: variableNodes super selectorParts: tokenCollection arguments: variableNodes. isList := (tokenCollection first value at: 2) == self listCharacter! ! !RBPatternMethodNode methodsFor: 'testing' stamp: ''! isSelectorList ^isList! ! !RBPatternMethodNode methodsFor: 'private' stamp: ''! matchingClass ^RBMethodNode! ! !RBPatternMethodNode class methodsFor: 'instance creation' stamp: ''! selectorParts: tokenCollection arguments: variableNodes ^(tokenCollection anySatisfy: [:each | each isPatternVariable]) ifTrue: [super selectorParts: tokenCollection arguments: variableNodes] ifFalse: [RBMethodNode selectorParts: tokenCollection arguments: variableNodes]! ! !RBPatternParser commentStamp: ''! RBPatternParser is a subclass of RBParser that allows the extended syntax that creates matching trees. These trees can be used by the ParseTreeMatcher to search and transform source code. ! !RBPatternParser methodsFor: 'private-classes' stamp: ''! variableNodeClass ^RBPatternVariableNode! ! !RBPatternParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 11/8/2012 16:00'! parsePatternBlock: aClass | position node | position := currentToken start. self step. node := self parseBlockArgsInto: aClass new. node left: position. node body: self sequenceNodeClass new. (self parseStatements: false into: node body). (currentToken isSpecial and: [currentToken value = $}]) ifFalse: [ ^ self parserError: '''}'' expected']. node right: currentToken start. self step. ^node! ! !RBPatternParser methodsFor: 'private-parsing' stamp: 'lr 5/30/2010 11:23'! parseLiteralByteArrayObject | node | (currentToken isIdentifier and: [currentToken isPatternVariable]) ifTrue: [node := self variableNodeClass identifierToken: currentToken. node isLiteralNode ifTrue: [self step. ^node]]. ^super parseLiteralByteArrayObject! ! !RBPatternParser methodsFor: 'private-parsing' stamp: ''! parsePrimitiveObject currentToken isPatternBlock ifTrue: [^self parsePatternBlock: RBPatternBlockNode]. ^super parsePrimitiveObject! ! !RBPatternParser methodsFor: 'private-parsing' stamp: ''! parseUnaryMessage | node | node := self parsePrimitiveObject. self addCommentsTo: node. [currentToken isLiteralToken ifTrue: [self patchLiteralMessage]. currentToken isPatternBlock ifTrue: [node := (self parsePatternBlock: RBPatternWrapperBlockNode) wrappedNode: node; yourself]. currentToken isIdentifier] whileTrue: [node := self parseUnaryMessageWith: node]. self addCommentsTo: node. ^node! ! !RBPatternParser methodsFor: 'private' stamp: ''! patchLiteralArrayToken (currentToken isIdentifier and: [currentToken isPatternVariable]) ifTrue: [^self]. super patchLiteralArrayToken! ! !RBPatternParser methodsFor: 'private-parsing' stamp: 'lr 5/30/2010 14:44'! parsePragmaLiteral | node | currentToken isPatternBlock ifTrue: [ ^ self parsePatternBlock: RBPatternBlockNode ]. (currentToken isIdentifier and: [ currentToken isPatternVariable ]) ifTrue: [ node := self variableNodeClass identifierToken: currentToken. node isLiteralNode ifFalse: [ self parseError: 'Literal pattern expected' ]. self step. currentToken isPatternBlock ifTrue: [ node := (self parsePatternBlock: RBPatternWrapperBlockNode) wrappedNode: node; yourself ]. ^ node ]. ^ super parsePragmaLiteral! ! !RBPatternParser methodsFor: 'private-parsing' stamp: ''! parsePrimitiveLiteral | node | (currentToken isIdentifier and: [currentToken isPatternVariable]) ifTrue: [node := self variableNodeClass identifierToken: currentToken. node isLiteralNode ifTrue: [self step. ^node]. currentToken := RBLiteralToken value: currentToken value asSymbol start: currentToken start stop: currentToken stop]. ^super parsePrimitiveLiteral! ! !RBPatternParser methodsFor: 'accessing' stamp: ''! scannerClass ^RBPatternScanner! ! !RBPatternParser methodsFor: 'private-classes' stamp: ''! methodNodeClass ^RBPatternMethodNode! ! !RBPatternParser methodsFor: 'private-classes' stamp: ''! messageNodeClass ^RBPatternMessageNode! ! !RBPatternParser methodsFor: 'private-parsing' stamp: 'StephaneDucasse 3/29/2013 17:16'! parseError: aString self error: aString! ! !RBPatternParser methodsFor: 'private-classes' stamp: 'lr 5/30/2010 09:44'! pragmaNodeClass ^RBPatternPragmaNode! ! !RBPatternPragmaNode methodsFor: 'accessing' stamp: 'lr 5/30/2010 14:22'! sentMessages ^ super sentMessages remove: self selector ifAbsent: [ ]; yourself! ! !RBPatternPragmaNode methodsFor: 'matching' stamp: 'lr 5/30/2010 10:07'! matchArgumentsAgainst: aNode inContext: aDictionary self arguments size = aNode arguments size ifFalse: [ ^ false ]. (self matchSelectorAgainst: aNode inContext: aDictionary) ifFalse: [ ^ false ]. self arguments with: aNode arguments do: [ :first :second | (first match: second inContext: aDictionary) ifFalse: [ ^ false ] ]. ^ true! ! !RBPatternPragmaNode methodsFor: 'matching' stamp: 'lr 5/30/2010 10:42'! copyInContext: aDictionary | selectors | selectors := self isSelectorList ifTrue: [ (aDictionary at: selectorParts first value) keywords ] ifFalse: [ self selectorParts collect: [ :each | aDictionary at: each value ] ]. ^ RBPragmaNode new selectorParts: (selectors collect: [ :each | (each last = $: ifTrue: [ RBKeywordToken ] ifFalse: [ RBIdentifierToken ]) value: each start: nil ]); arguments: (self copyList: self arguments inContext: aDictionary); yourself! ! !RBPatternPragmaNode methodsFor: 'matching' stamp: 'lr 5/30/2010 10:38'! matchSelectorAgainst: aNode inContext: aDictionary self selectorParts with: aNode selectorParts do: [ :first :second | | keyword | keyword := aDictionary at: first value ifAbsentPut: [ first isPatternVariable ifTrue: [ second value ] ifFalse: [ first value ] ]. keyword = second value ifFalse: [ ^ false ] ]. ^ true! ! !RBPatternPragmaNode methodsFor: 'testing-matching' stamp: 'lr 5/30/2010 09:40'! isPatternNode ^ true! ! !RBPatternPragmaNode methodsFor: 'matching' stamp: 'lr 5/30/2010 10:33'! match: aNode inContext: aDictionary aNode class = self matchingClass ifFalse: [ ^ false ]. self isSelectorList ifTrue: [ ^ (aDictionary at: selectorParts first value ifAbsentPut: [ aNode selector ]) = aNode selector and: [ (aDictionary at: arguments first ifAbsentPut: [ aNode arguments ]) = aNode arguments ] ]. ^ self matchArgumentsAgainst: aNode inContext: aDictionary! ! !RBPatternPragmaNode methodsFor: 'initialization' stamp: 'lr 5/30/2010 10:40'! selectorParts: keywordTokens arguments: valueNodes super selectorParts: keywordTokens arguments: valueNodes. isList := (keywordTokens first value at: 2) == self listCharacter! ! !RBPatternPragmaNode methodsFor: 'testing-matching' stamp: 'lr 5/30/2010 09:40'! isSelectorList ^ isList! ! !RBPatternPragmaNode methodsFor: 'private' stamp: 'lr 5/30/2010 09:40'! matchingClass ^ RBPragmaNode! ! !RBPatternPragmaNode class methodsFor: 'instance creation' stamp: 'lr 5/30/2010 09:47'! selectorParts: keywordTokens arguments: valueNodes ^ (keywordTokens anySatisfy: [ :each | each isPatternVariable ]) ifTrue: [ super selectorParts: keywordTokens arguments: valueNodes ] ifFalse: [ RBPragmaNode selectorParts: keywordTokens arguments: valueNodes ]! ! !RBPatternScanner commentStamp: ''! RBPatternScanner is a subclass of RBScanner that allows the extended syntax of pattern matching trees. ! !RBPatternScanner methodsFor: 'accessing' stamp: 'lr 11/7/2009 15:31'! scanToken currentCharacter = PatternVariableCharacter ifTrue: [^self scanPatternVariable]. currentCharacter = $} ifTrue: [^self scanSpecialCharacter]. ^super scanToken! ! !RBPatternVariableNode commentStamp: 'md 8/9/2005 14:59'! RBPatternVariableNode is an AST node that is used to match several other types of nodes (literals, variables, value nodes, statement nodes, and sequences of statement nodes). The different types of matches are determined by the name of the node. If the name contains a # character, then it will match a literal. If it contains, a . then it matches statements. If it contains no extra characters, then it matches only variables. These options are mutually exclusive. The @ character can be combined with the name to match lists of items. If combined with the . character, then it will match a list of statement nodes (0 or more). If used without the . or # character, then it matches anything except for list of statements. Combining the @ with the # is not supported. Adding another ` in the name will cause the search/replace to look for more matches inside the node that this node matched. This option should not be used for top level expressions since that would cause infinite recursion (e.g., searching only for "``@anything"). Instance Variables: isAnything can we match any type of node isList can we match a list of items (@) isLiteral only match a literal node (#) isStatement only match statements (.) recurseInto search for more matches in the node we match (`) ! !RBPatternVariableNode methodsFor: 'testing-matching' stamp: ''! isList ^isList! ! !RBPatternVariableNode methodsFor: 'testing-matching' stamp: ''! isAnything ^isAnything! ! !RBPatternVariableNode methodsFor: 'accessing' stamp: ''! parent: aBRProgramNode "Fix the case where '``@node' should match a single node, not a sequence node." super parent: aBRProgramNode. parent isSequence ifTrue: [(self isStatement or: [parent temporaries includes: self]) ifFalse: [isList := false]]! ! !RBPatternVariableNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:37'! copyInContext: aDictionary ^ (aDictionary at: self) copy! ! !RBPatternVariableNode methodsFor: 'testing-matching' stamp: ''! isPatternNode ^true! ! !RBPatternVariableNode methodsFor: 'matching' stamp: ''! matchStatement: aNode inContext: aDictionary (aNode parent notNil and: [aNode parent isSequence]) ifFalse: [^false]. ^(aDictionary at: self ifAbsentPut: [aNode]) = aNode! ! !RBPatternVariableNode methodsFor: 'matching' stamp: ''! matchLiteral: aNode inContext: aDictionary ^aNode isLiteralNode and: [(aDictionary at: self ifAbsentPut: [aNode]) = aNode]! ! !RBPatternVariableNode methodsFor: 'private' stamp: ''! matchingClass ^RBVariableNode! ! !RBPatternVariableNode methodsFor: 'initialize-release' stamp: ''! initializePatternVariables | name | name := self name. isAnything := isList := isLiteral := isStatement := recurseInto := false. 2 to: name size do: [:i | | character | character := name at: i. character == self listCharacter ifTrue: [isAnything := isList := true] ifFalse: [character == self literalCharacter ifTrue: [isLiteral := true] ifFalse: [character == self statementCharacter ifTrue: [isStatement := true] ifFalse: [character == self recurseIntoCharacter ifTrue: [recurseInto := true] ifFalse: [^self]]]]]! ! !RBPatternVariableNode methodsFor: 'testing-matching' stamp: ''! isLiteralNode ^isLiteral! ! !RBPatternVariableNode methodsFor: 'matching' stamp: 'CamilloBruni 12/15/2011 15:32'! match: aNode inContext: aDictionary self isAnything ifTrue: [^(aDictionary at: self ifAbsentPut: [aNode]) = aNode]. self isLiteralNode ifTrue: [^self matchLiteral: aNode inContext: aDictionary]. self isStatement ifTrue: [^self matchStatement: aNode inContext: aDictionary]. (aNode isKindOf: self matchingClass) ifFalse: [^false]. ^(aDictionary at: self ifAbsentPut: [aNode]) = aNode! ! !RBPatternVariableNode methodsFor: 'initialize-release' stamp: ''! identifierToken: anIdentifierToken super identifierToken: anIdentifierToken. self initializePatternVariables! ! !RBPatternVariableNode methodsFor: 'testing-matching' stamp: ''! recurseInto ^recurseInto! ! !RBPatternVariableNode methodsFor: 'testing-matching' stamp: ''! isStatement ^isStatement! ! !RBPatternVariableNode class methodsFor: 'instance creation' stamp: ''! identifierToken: anIdentifierToken ^anIdentifierToken isPatternVariable ifTrue: [super identifierToken: anIdentifierToken] ifFalse: [RBVariableNode identifierToken: anIdentifierToken]! ! !RBPatternWrapperBlockNode commentStamp: ''! RBPatternWrapperBlockNode allows further matching using a block after a node has been matched by a pattern node. Instance Variables: wrappedNode The original pattern node to match! !RBPatternWrapperBlockNode methodsFor: 'matching' stamp: ''! match: aNode inContext: aDictionary (wrappedNode match: aNode inContext: aDictionary) ifFalse: [^false]. ^super match: aNode inContext: aDictionary! ! !RBPatternWrapperBlockNode methodsFor: 'accessing' stamp: ''! precedence ^1! ! !RBPatternWrapperBlockNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:30'! copyInContext: aDictionary "I don't know what this would mean, so ignore it." ^ wrappedNode copyInContext: aDictionary! ! !RBPatternWrapperBlockNode methodsFor: 'accessing' stamp: ''! wrappedNode ^wrappedNode! ! !RBPatternWrapperBlockNode methodsFor: 'visitor' stamp: 'StephaneDucasse 3/29/2013 15:38'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitPatternWrapperBlockNode: self! ! !RBPatternWrapperBlockNode methodsFor: 'accessing' stamp: ''! wrappedNode: aRBProgramNode wrappedNode := aRBProgramNode. aRBProgramNode parent: self! ! !RBPlatformDependentUserInteractionRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:33'! initialize super initialize. self matcher matchesAnyOf: #( 'FillInTheBlank multiLineRequest: `@object1 centerAt: `@object2 initialAnswer: `@object3 answerHeight: `@object4' 'FillInTheBlank request: `@object1 initialAnswer: `@object2 centerAt: `@object3' 'FillInTheBlank request: `@object1 initialAnswer: `@object2' 'FillInTheBlank request: `@object1' 'FillInTheBlank requestPassword: `@object1' 'PopUpMenu confirm: `@object1 orCancel: `@object2' 'PopUpMenu confirm: `@object1 trueChoice: `@object2 falseChoice: `@object3' 'PopUpMenu confirm: `@object1' 'PopUpMenu inform: `@object1' 'PopUpMenu initialize' 'PopUpMenu labelArray: `@object1 lines: `@object2' 'PopUpMenu labelArray: `@object1' 'PopUpMenu labels: `@object1 lines: `@object2' 'PopUpMenu labels: `@object1' 'PopUpMenu withCaption: `@object1 chooseFrom: `@object2' 'SelectionMenu fromArray: `@object1' 'SelectionMenu labelList: `@object1 lines: `@object2 selections: `@object3' 'SelectionMenu labelList: `@object1 lines: `@object2' 'SelectionMenu labelList: `@object1 selections: `@object2' 'SelectionMenu labelList: `@object1' 'SelectionMenu labels: `@object1 lines: `@object2 selections: `@object3' 'SelectionMenu labels: `@object1 lines: `@object2' 'SelectionMenu labels: `@object1 selections: `@object2' 'SelectionMenu selections: `@object1 lines: `@object2' 'SelectionMenu selections: `@object1' ) do: [ :node :answer | node ]! ! !RBPlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'The method uses platform dependent user interactions.'! ! !RBPlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBPlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:12'! severity ^ #error! ! !RBPlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Platform dependent user interaction'! ! !RBPlatformDependentUserInteractionRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:26'! category ^ 'Potential Bugs'! ! !RBPlatformDependentUserInteractionRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'PlatformDependentUserInteractionRule'! ! !RBPragmaEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 10:43'! includesClass: aClass ^ (environment includesClass: aClass) and: [ aClass selectors anySatisfy: [ :each | self includesSelector: each in: aClass ] ]! ! !RBPragmaEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/24/2009 19:38'! keywords: aCollection keywords addAll: aCollection! ! !RBPragmaEnvironment methodsFor: 'initialize-release' stamp: 'lr 7/21/2008 10:34'! condition: aBlock condition := aBlock! ! !RBPragmaEnvironment methodsFor: 'initialization' stamp: 'lr 2/26/2009 13:35'! initialize super initialize. keywords := IdentitySet new. condition := [ :pragma | true ]! ! !RBPragmaEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 12:42'! includesProtocol: aProtocol in: aClass ^ (environment includesProtocol: aProtocol in: aClass) and: [ (self selectorsFor: aProtocol in: aClass) notEmpty ]! ! !RBPragmaEnvironment methodsFor: 'printing' stamp: 'lr 7/21/2008 10:37'! storeOn: aStream aStream nextPut: $(. super storeOn: aStream. aStream nextPutAll: ' keywords: '. keywords asArray storeOn: aStream. aStream nextPut: $)! ! !RBPragmaEnvironment methodsFor: 'copying' stamp: 'lr 7/21/2008 10:37'! postCopy super postCopy. keywords := keywords copy! ! !RBPragmaEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 12:42'! includesCategory: aCategory ^ (environment includesCategory: aCategory) and: [ (self classNamesFor: aCategory) notEmpty ]! ! !RBPragmaEnvironment methodsFor: 'adding' stamp: 'lr 7/21/2008 10:20'! addKeyword: aSymbol keywords add: aSymbol! ! !RBPragmaEnvironment methodsFor: 'private' stamp: 'lr 7/21/2008 10:40'! defaultLabel | stream | stream := String new writeStream. keywords do: [ :each | stream nextPut: $<; nextPutAll: each; nextPut: $>; nextPut: $ ]. ^ stream contents! ! !RBPragmaEnvironment methodsFor: 'testing' stamp: 'lr 1/3/2010 11:48'! includesSelector: aSelector in: aClass (environment includesSelector: aSelector in: aClass) ifFalse: [ ^ false ]. ^ (aClass compiledMethodAt: aSelector) pragmas anySatisfy: [ :each | self includesPragma: each ]! ! !RBPragmaEnvironment methodsFor: 'testing' stamp: 'lr 7/21/2008 10:34'! includesPragma: aPragma ^ (keywords includes: aPragma keyword) and: [ condition value: aPragma ]! ! !RBPragmaEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:26'! keywords: aKeywordCollection ^ self onEnvironment: self default keywords: aKeywordCollection! ! !RBPragmaEnvironment class methodsFor: 'instance creation' stamp: 'lr 7/21/2008 10:38'! onEnvironment: anEnvironment keywords: aKeywordCollection ^ (self onEnvironment: anEnvironment) keywords: aKeywordCollection; yourself! ! !RBPragmaNode commentStamp: ''! RBPragmaNode is an AST node that represents a method pragma. Instance Variables: arguments our argument nodes left position of < right position of > selector the selector we're sending (cached) selectorParts the tokens for each keyword! !RBPragmaNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/26/2014 18:28'! argumentAt: keywordSelector ifAbsent: absentBlock self selectorParts with: self arguments do: [ :selectorPart :argument | selectorPart value = keywordSelector ifTrue: [ ^ argument ]]. ^ absentBlock value! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 10/13/2009 13:55'! selector ^ selector ifNil: [ selector := self buildSelector ]! ! !RBPragmaNode methodsFor: 'testing' stamp: 'lr 11/2/2009 23:37'! isKeyword ^ selectorParts first value last = $:! ! !RBPragmaNode methodsFor: 'accessing-token' stamp: 'lr 11/5/2009 10:40'! right: anInteger right := anInteger! ! !RBPragmaNode methodsFor: 'accessing-token' stamp: 'lr 11/5/2009 10:40'! left ^ left! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 10/27/2009 11:57'! children ^ self arguments! ! !RBPragmaNode methodsFor: 'testing' stamp: 'lr 10/13/2009 14:00'! isBinary ^ (self isUnary or: [self isKeyword]) not! ! !RBPragmaNode methodsFor: '*opalcompiler-core' stamp: 'CamilloBruni 2/26/2014 16:50'! asPrimitive | args module name spec | args := (self arguments collect: [ :each | each value ]) asArray. self isPrimitive ifFalse: [ IRPrimitive null ]. args first isString ifTrue: [ name := args first. module := self argumentAt: #module: ifAbsent: [ nil ]. spec := {(module ifNotNil: [ module value asSymbol ]). (name asSymbol). 0. 0}. ^ IRPrimitive new num: 117; spec: spec; yourself ] ifFalse: [ ^ IRPrimitive new num: args first; spec: nil; yourself ]! ! !RBPragmaNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:30'! isFaulty ^self arguments anySatisfy: #isFaulty.! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/26/2014 18:28'! argumentAt: keywordSelector ^ self argumentAt: keywordSelector ifAbsent: [ KeyNotFound signalFor: keywordSelector ]! ! !RBPragmaNode methodsFor: 'accessing-token' stamp: 'lr 11/5/2009 10:40'! right ^ right! ! !RBPragmaNode methodsFor: 'private' stamp: 'MarcusDenker 4/12/2013 10:23'! buildSelector ^(String streamContents: [ :selectorStream | selectorParts do: [ :each | selectorStream nextPutAll: each value ]]) asSymbol! ! !RBPragmaNode methodsFor: 'testing' stamp: 'lr 10/13/2009 14:00'! isPragma ^ true! ! !RBPragmaNode methodsFor: 'private' stamp: 'lr 10/13/2009 13:54'! selectorParts: tokenCollection selectorParts := tokenCollection! ! !RBPragmaNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 5/14/2013 16:32'! asPragma ^ Pragma keyword: selector arguments: (arguments collect: [ :each | each value ]) asArray! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 11/5/2009 10:41'! start ^ left! ! !RBPragmaNode methodsFor: 'initialization' stamp: 'lr 10/27/2009 11:58'! selectorParts: keywordTokens arguments: valueNodes self selectorParts: keywordTokens. self arguments: valueNodes! ! !RBPragmaNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 5/14/2013 13:48'! isCompilerOption ^ self selector = #compilerOptions:! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 5/30/2010 14:22'! sentMessages ^ super sentMessages add: self selector; yourself! ! !RBPragmaNode methodsFor: 'comparing' stamp: 'lr 3/7/2010 13:47'! hash ^ self selector hash bitXor: (self hashForCollection: self arguments)! ! !RBPragmaNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:37'! copyInContext: aDictionary ^ self class new selectorParts: (self selectorParts collect: [ :each | each copy removePositions ]); arguments: (self arguments collect: [ :each | each copyInContext: aDictionary ]); yourself! ! !RBPragmaNode methodsFor: '*opalcompiler-core' stamp: 'CamilloBruni 2/26/2014 16:20'! isPrimitiveError ^ #( primitive:error: primitive:module:error: primitive:error:module:) includes: self selector! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 11/5/2009 10:41'! stop ^ right! ! !RBPragmaNode methodsFor: 'replacing' stamp: 'lr 10/13/2009 14:00'! replaceNode: aNode withNode: anotherNode self arguments: (arguments collect: [ :each | each == aNode ifTrue: [ anotherNode ] ifFalse: [ each ] ])! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 10/13/2009 14:01'! arguments: aLiteralCollection arguments := aLiteralCollection. arguments do: [ :each | each parent: self ]! ! !RBPragmaNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:38'! acceptVisitor: aProgramNodeVisitor ^ aProgramNodeVisitor visitPragmaNode: self! ! !RBPragmaNode methodsFor: 'comparing' stamp: 'lr 5/30/2010 09:33'! equalTo: anObject withMapping: aDictionary self class = anObject class ifFalse: [ ^ false ]. self selector = anObject selector ifFalse: [ ^ false ]. self arguments with: anObject arguments do: [ :first :second | (first equalTo: second withMapping: aDictionary) ifFalse: [ ^ false ] ]. ^ true! ! !RBPragmaNode methodsFor: 'testing' stamp: 'lr 11/9/2009 20:06'! isPrimitive ^ #(primitive: primitive:error: primitive:error:module: primitive:module: primitive:module:error:) includes: self selector! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 8/8/2010 13:16'! selector: aSelector | keywords numArgs | keywords := aSelector keywords. numArgs := aSelector numArgs. numArgs == arguments size ifFalse: [self error: 'Attempting to assign selector with wrong number of arguments.']. selectorParts := numArgs == 0 ifTrue: [Array with: (RBIdentifierToken value: keywords first start: nil)] ifFalse: [keywords first last = $: ifTrue: [keywords collect: [:each | RBKeywordToken value: each start: nil]] ifFalse: [Array with: (RBBinarySelectorToken value: aSelector start: nil)]]. selector := aSelector asSymbol! ! !RBPragmaNode methodsFor: 'comparing' stamp: 'lr 11/9/2009 20:58'! = anObject self == anObject ifTrue: [^true]. self class = anObject class ifFalse: [^false]. self selector = anObject selector ifFalse: [^false]. 1 to: self arguments size do: [:i | (self arguments at: i) = (anObject arguments at: i) ifFalse: [^false]]. ^true! ! !RBPragmaNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:37'! postCopy super postCopy. self arguments: (self arguments collect: [ :each | each copy ])! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 5/30/2010 09:30'! numArgs ^ self selector numArgs! ! !RBPragmaNode methodsFor: 'accessing-token' stamp: 'lr 11/5/2009 10:40'! left: anInteger left := anInteger! ! !RBPragmaNode methodsFor: 'matching' stamp: 'lr 5/30/2010 10:06'! match: aNode inContext: aDictionary aNode class = self class ifFalse: [ ^ false ]. self selector = aNode selector ifFalse: [ ^ false ]. self arguments with: aNode arguments do: [ :first :second | (first match: second inContext: aDictionary) ifFalse: [ ^ false ] ]. ^ true! ! !RBPragmaNode methodsFor: 'private' stamp: 'lr 5/30/2010 09:37'! selectorParts ^ selectorParts! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 10/18/2009 12:14'! arguments ^ arguments ifNil: [ #() ]! ! !RBPragmaNode methodsFor: 'testing' stamp: 'lr 10/13/2009 14:01'! isUnary ^ arguments isEmpty! ! !RBPragmaNode class methodsFor: 'instance creation' stamp: 'lr 10/13/2009 14:21'! selectorParts: keywordTokens arguments: valueNodes ^ self new selectorParts: keywordTokens arguments: valueNodes ! ! !RBPrecedenceRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:33'! initialize super initialize. self matcher matches: '`{:node | node isMessage and: [node hasParentheses not and: [#(#+ #-) includes: node selector]]} * `@C' do: [ :node :answer | node ]! ! !RBPrecedenceRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:45'! rationale ^ 'Checks for mathematical expressions that might be evaluated different (from left-to-right) than the developer thinks.'! ! !RBPrecedenceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBPrecedenceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Inspect instances of "A + B * C" might be "A + (B * C)"'! ! !RBPrecedenceRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:27'! category ^ 'Potential Bugs'! ! !RBPrecedenceRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'PrecedenceRule'! ! !RBPrettyPrintCodeRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^ RBCondition empty! ! !RBPrettyPrintCodeRefactoring methodsFor: 'transforming' stamp: ''! transform | source tree formatted | self model allClassesDo: [ :class | class selectors do: [ :selector | (self model environment includesSelector: selector in: class realClass) ifTrue: [ source := class sourceCodeFor: selector. source isNil ifFalse: [ tree := class parseTreeFor: selector. tree isNil ifFalse: [ formatted := tree formattedCode. (source ~= formatted and: [ (RBParser parseMethod: formatted) = tree ]) ifTrue: [ class compile: formatted classified: (class protocolsFor: selector) ] ] ] ] ] ] ! ! !RBProgramNode commentStamp: ''! RBProgramNode is an abstract class that represents an abstract syntax tree node in a Smalltalk program. Subclasses must implement the following messages: accessing start stop visitor acceptVisitor: The #start and #stop methods are used to find the source that corresponds to this node. "source copyFrom: self start to: self stop" should return the source for this node. The #acceptVisitor: method is used by RBProgramNodeVisitors (the visitor pattern). This will also require updating all the RBProgramNodeVisitors so that they know of the new node. Subclasses might also want to redefine match:inContext: and copyInContext: to do parse tree searching and replacing. Subclasses that contain other nodes should override equalTo:withMapping: to compare nodes while ignoring renaming temporary variables, and children that returns a collection of our children nodes. Instance Variables: comments the intervals in the source that have comments for this node parent the node we're contained in Shared Variables: FormatterClass the formatter class that is used when we are formatted! !RBProgramNode methodsFor: 'replacing' stamp: ''! replaceMethodSource: aNode "We are being replaced with aNode -- if possible try to perform an in place edit of the source." | method | method := self methodNode. method notNil ifTrue: [method map: self to: aNode]. aNode parent: self parent. [self replaceSourceWith: aNode] on: Error do: [:ex | self clearReplacements. ex return]! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! children ^#()! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! comments: aCollection comments := aCollection! ! !RBProgramNode methodsFor: 'meta variable-accessing' stamp: ''! literalCharacter ^$#! ! !RBProgramNode methodsFor: 'properties' stamp: 'md 3/29/2007 14:51'! removeProperty: aKey "Remove the property with aKey. Answer the property or raise an error if aKey isn't found." ^ self removeProperty: aKey ifAbsent: [ self error: 'Property not found' ].! ! !RBProgramNode methodsFor: 'replacing' stamp: 'ClementBera 7/26/2013 17:10'! clearReplacements parent ifNil: [^self]. parent clearReplacements! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isImmediateNode ^false! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! parent ^parent! ! !RBProgramNode methodsFor: 'private-replacing' stamp: 'lr 10/29/2010 11:37'! replaceSourceFrom: aNode self == aNode ifFalse: [ self clearReplacements ]! ! !RBProgramNode methodsFor: 'testing-matching' stamp: ''! isList ^false! ! !RBProgramNode methodsFor: 'testing-matching' stamp: ''! canMatchMethod: aCompiledMethod ^self sentMessages allSatisfy: [:each | (self class optimizedSelectors includes: each) or: [aCompiledMethod refersToLiteral: each]]! ! !RBProgramNode methodsFor: 'accessing' stamp: 'lr 5/30/2010 14:22'! sentMessages ^ self children inject: Set new into: [ :messages :each | messages addAll: each sentMessages; yourself ]! ! !RBProgramNode methodsFor: 'testing-matching' stamp: ''! isPatternNode ^false! ! !RBProgramNode methodsFor: 'querying' stamp: 'lr 11/2/2009 00:14'! superMessages | searcher | searcher := RBParseTreeSearcher new. searcher matches: 'super `@msg: ``@args' do: [:aNode :answer | answer add: aNode selector; yourself]. ^searcher executeTree: self initialAnswer: Set new! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! precedence ^6! ! !RBProgramNode methodsFor: 'iterating' stamp: 'lr 11/1/2009 20:49'! allChildren | children | children := OrderedCollection new. self nodesDo: [ :each | children addLast: each ]. ^ children! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isAssignment ^false! ! !RBProgramNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:40'! match: aNode inContext: aDictionary ^ self = aNode! ! !RBProgramNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 7/26/2013 15:24'! methodOrBlockNode ^ parent ifNotNil: [ parent methodOrBlockNode ]! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! newSource ^self formattedCode! ! !RBProgramNode methodsFor: 'testing' stamp: ''! directlyUses: aNode ^true! ! !RBProgramNode methodsFor: 'iterating' stamp: 'lr 11/1/2009 20:49'! nodesDo: aBlock aBlock value: self. self children do: [ :each | each nodesDo: aBlock ]! ! !RBProgramNode methodsFor: 'replacing' stamp: 'ClementBera 7/26/2013 17:13'! replaceWith: aNode parent ifNil: [self error: 'This node doesn''t have a parent']. self replaceMethodSource: aNode. parent replaceNode: self withNode: aNode! ! !RBProgramNode methodsFor: 'testing' stamp: 'ClementBera 7/26/2013 17:11'! isUsed "Answer true if this node could be used as part of another expression. For example, you could use the result of this node as a receiver of a message, an argument, the right part of an assignment, or the return value of a block. This differs from isDirectlyUsed in that it is conservative since it also includes return values of blocks." ^parent ifNil: [false] ifNotNil: [parent uses: self]! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isLiteralNode ^false! ! !RBProgramNode methodsFor: 'querying' stamp: 'lr 11/2/2009 00:14'! selfMessages | searcher | searcher := RBParseTreeSearcher new. searcher matches: 'self `@msg: ``@args' do: [:aNode :answer | answer add: aNode selector; yourself]. ^searcher executeTree: self initialAnswer: Set new! ! !RBProgramNode methodsFor: 'properties' stamp: 'MarcusDenker 3/25/2013 21:02'! propertyAt: aKey put: anObject "Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject." ^ (properties ifNil: [ properties := SmallDictionary new: 1 ]) at: aKey put: anObject! ! !RBProgramNode methodsFor: 'matching' stamp: ''! copyList: matchNodes inContext: aDictionary | newNodes | newNodes := OrderedCollection new. matchNodes do: [:each | | object | object := each copyInContext: aDictionary. newNodes addAll: object]. ^newNodes! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! allArgumentVariables | children | children := self children. children isEmpty ifTrue: [^#()]. ^children inject: OrderedCollection new into: [:vars :each | vars addAll: each allArgumentVariables; yourself]! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! source ^parent notNil ifTrue: [parent source] ifFalse: [nil]! ! !RBProgramNode methodsFor: 'printing' stamp: 'lr 11/1/2009 19:28'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(; nextPutAll: self formattedCode; nextPut: $)! ! !RBProgramNode methodsFor: '*NodeNavigation' stamp: 'GiselaDecuzzi 5/13/2013 11:12'! statements ^ #().! ! !RBProgramNode methodsFor: 'testing' stamp: ''! evaluatedFirst: aNode self children do: [:each | each == aNode ifTrue: [^true]. each isImmediateNode ifFalse: [^false]]. ^false! ! !RBProgramNode methodsFor: 'copying' stamp: ''! copyCommentsFrom: aNode "Add all comments from aNode to us. If we already have the comment, then don't add it." | newComments | newComments := OrderedCollection new. aNode nodesDo: [:each | newComments addAll: each comments]. self nodesDo: [:each | each comments do: [:comment | newComments remove: comment ifAbsent: []]]. newComments isEmpty ifTrue: [^self]. newComments := newComments asSortedCollection: [:a :b | a first < b first]. self comments: newComments! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! sourceInterval ^self start to: self stop! ! !RBProgramNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 5/24/2013 13:44'! doSemanticAnalysis ^ self method doSemanticAnalysis. ! ! !RBProgramNode methodsFor: 'testing' stamp: 'ClementBera 7/26/2013 17:11'! isDirectlyUsed "This node is directly used as an argument, receiver, or part of an assignment." ^parent ifNil: [false] ifNotNil: [parent directlyUses: self]! ! !RBProgramNode methodsFor: 'replacing' stamp: 'ClementBera 7/26/2013 17:10'! addReplacement: aStringReplacement parent ifNil: [^self]. parent addReplacement: aStringReplacement! ! !RBProgramNode methodsFor: 'enumeration' stamp: ''! size "Hacked to fit collection protocols" ^1! ! !RBProgramNode methodsFor: 'querying' stamp: ''! whichNodeIsContainedBy: anInterval | selectedChildren | (self intersectsInterval: anInterval) ifFalse: [^nil]. (self containedBy: anInterval) ifTrue: [^self]. selectedChildren := self children select: [:each | each intersectsInterval: anInterval]. ^selectedChildren size == 1 ifTrue: [selectedChildren first whichNodeIsContainedBy: anInterval] ifFalse: [nil]! ! !RBProgramNode methodsFor: 'deprecated' stamp: ''! isImmediate ^self isImmediateNode! ! !RBProgramNode methodsFor: 'testing' stamp: ''! intersectsInterval: anInterval ^(anInterval first between: self start and: self stop) or: [self start between: anInterval first and: anInterval last]! ! !RBProgramNode methodsFor: 'visiting' stamp: ''! acceptVisitor: aProgramNodeVisitor self subclassResponsibility! ! !RBProgramNode methodsFor: 'replacing' stamp: ''! removeDeadCode self children do: [:each | each removeDeadCode]! ! !RBProgramNode methodsFor: 'properties' stamp: 'lr 10/18/2009 17:19'! hasProperty: aKey "Test if the property aKey is present." ^ properties notNil and: [ properties includesKey: aKey ]! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! methodComments ^self comments! ! !RBProgramNode methodsFor: '*opalcompiler-core' stamp: ''! owningScope ^ parent owningScope ! ! !RBProgramNode methodsFor: 'accessing' stamp: 'lr 3/26/2010 17:29'! formattedCode ^ self formatterClass new format: self! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! statementComments | statementComments | statementComments := OrderedCollection withAll: self comments. self children do: [:each | statementComments addAll: each statementComments]. ^statementComments asSortedCollection: [:a :b | a first < b first]! ! !RBProgramNode methodsFor: 'matching' stamp: ''! matchList: matchNodes against: programNodes inContext: aDictionary ^self matchList: matchNodes index: 1 against: programNodes index: 1 inContext: aDictionary! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isMethod ^false! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isMessage ^false! ! !RBProgramNode methodsFor: 'matching' stamp: ''! matchList: matchNodes index: matchIndex against: programNodes index: programIndex inContext: aDictionary | node currentIndex currentDictionary nodes | matchNodes size < matchIndex ifTrue: [^programNodes size < programIndex]. node := matchNodes at: matchIndex. node isList ifTrue: [currentIndex := programIndex - 1. [currentDictionary := aDictionary copy. programNodes size < currentIndex or: [nodes := programNodes copyFrom: programIndex to: currentIndex. (currentDictionary at: node ifAbsentPut: [nodes]) = nodes and: [(self matchList: matchNodes index: matchIndex + 1 against: programNodes index: currentIndex + 1 inContext: currentDictionary) ifTrue: [currentDictionary keysAndValuesDo: [:key :value | aDictionary at: key put: value]. ^true]. false]]] whileFalse: [currentIndex := currentIndex + 1]. ^false]. programNodes size < programIndex ifTrue: [^false]. (node match: (programNodes at: programIndex) inContext: aDictionary) ifFalse: [^false]. ^self matchList: matchNodes index: matchIndex + 1 against: programNodes index: programIndex + 1 inContext: aDictionary! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! parent: aRBProgramNode parent := aRBProgramNode! ! !RBProgramNode methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/5/2013 17:12'! specialCommands ^#().! ! !RBProgramNode methodsFor: 'accessing' stamp: 'lr 3/26/2010 17:29'! formatterClass ^ self class formatterClass! ! !RBProgramNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:32'! isSelf ^ false! ! !RBProgramNode methodsFor: 'testing' stamp: ''! containsReturn ^self children anySatisfy: [:each | each containsReturn]! ! !RBProgramNode methodsFor: 'querying' stamp: ''! bestNodeFor: anInterval | selectedChildren | (self intersectsInterval: anInterval) ifFalse: [^nil]. (self containedBy: anInterval) ifTrue: [^self]. selectedChildren := self children select: [:each | each intersectsInterval: anInterval]. ^selectedChildren size == 1 ifTrue: [selectedChildren first bestNodeFor: anInterval] ifFalse: [self]! ! !RBProgramNode methodsFor: 'comparing' stamp: ''! equalTo: aNode exceptForVariables: variableNameCollection | dictionary | dictionary := Dictionary new. (self equalTo: aNode withMapping: dictionary) ifFalse: [^false]. dictionary keysAndValuesDo: [:key :value | (key = value or: [variableNameCollection includes: key]) ifFalse: [^false]]. ^true! ! !RBProgramNode methodsFor: 'testing' stamp: ''! hasMultipleReturns | count | count := 0. self nodesDo: [:each | each isReturn ifTrue: [count := count + 1]]. ^count > 1! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isReturn ^false! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isSequence ^false! ! !RBProgramNode methodsFor: 'properties' stamp: 'lr 12/29/2009 12:45'! propertyAt: aKey "Answer the property value associated with aKey." ^ self propertyAt: aKey ifAbsent: [ self error: 'Property not found' ]! ! !RBProgramNode methodsFor: 'private-replacing' stamp: ''! replaceSourceWith: aNode aNode replaceSourceFrom: self! ! !RBProgramNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:13'! temporaryVariables ^parent ifNil: [#()] ifNotNil: [parent temporaryVariables]! ! !RBProgramNode methodsFor: 'testing' stamp: 'lr 10/27/2009 14:33'! isPragma ^false! ! !RBProgramNode methodsFor: 'querying' stamp: ''! whoDefines: aName ^(self defines: aName) ifTrue: [self] ifFalse: [parent notNil ifTrue: [parent whoDefines: aName] ifFalse: [nil]]! ! !RBProgramNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:12'! methodNode ^parent ifNotNil: [parent methodNode]! ! !RBProgramNode methodsFor: '*Deprecated30' stamp: 'StephaneDucasse 3/29/2013 17:15'! accept: aProgramNodeVisitor self deprecated: 'Use acceptVisitor: instead' on: '29/03/2013' in: #Pharo30. self acceptVisitor: aProgramNodeVisitor ! ! !RBProgramNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:12'! parents ^ parent ifNil: [ OrderedCollection with: self ] ifNotNil: [ parent parents addLast: self; yourself ]! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isVariable ^false! ! !RBProgramNode methodsFor: 'testing' stamp: ''! assigns: aVariableName ^self children anySatisfy: [:each | each assigns: aVariableName]! ! !RBProgramNode methodsFor: 'testing' stamp: ''! references: aVariableName ^self children anySatisfy: [:each | each references: aVariableName]! ! !RBProgramNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 7/26/2013 15:24'! scope ^ self methodOrBlockNode scope! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! debugHighlightStart ^ self start ! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isLast: aNode | children | children := self children. ^children notEmpty and: [children last == aNode]! ! !RBProgramNode methodsFor: 'comparing' stamp: 'lr 3/7/2010 13:47'! hashForCollection: aCollection ^ aCollection isEmpty ifTrue: [ 0 ] ifFalse: [ aCollection first hash ]! ! !RBProgramNode methodsFor: 'querying' stamp: ''! statementNode "Return your topmost node that is contained by a sequence node." (parent isNil or: [parent isSequence]) ifTrue: [^self]. ^parent statementNode! ! !RBProgramNode methodsFor: 'properties' stamp: 'ClementBera 7/26/2013 17:12'! propertyAt: aKey ifAbsent: aBlock "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." ^ properties ifNil: [ aBlock value ] ifNotNil: [ properties at: aKey ifAbsent: aBlock ]! ! !RBProgramNode methodsFor: 'replacing' stamp: ''! replaceNode: aNode withNode: anotherNode self error: 'I don''t store other nodes'! ! !RBProgramNode methodsFor: 'testing' stamp: ''! uses: aNode ^true! ! !RBProgramNode methodsFor: 'meta variable-accessing' stamp: ''! cascadeListCharacter ^$;! ! !RBProgramNode methodsFor: 'testing' stamp: ''! defines: aName ^false! ! !RBProgramNode methodsFor: 'enumeration' stamp: ''! collect: aBlock "Hacked to fit collection protocols" ^aBlock value: self! ! !RBProgramNode methodsFor: 'copying' stamp: 'lr 12/29/2009 12:44'! postCopy super postCopy. properties := properties copy! ! !RBProgramNode methodsFor: 'accessing' stamp: 'MarcusDenker 12/17/2012 15:53'! debugHighlightRange ^ self debugHighlightStart to: self debugHighlightStop .! ! !RBProgramNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 7/26/2013 15:24'! printAsIfCompiledOn: aStream aStream nextPutAll: self formattedCode! ! !RBProgramNode methodsFor: 'testing-matching' stamp: ''! recurseInto ^false! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! allDefinedVariables | children | children := self children. children isEmpty ifTrue: [^#()]. ^children inject: OrderedCollection new into: [:vars :each | vars addAll: each allDefinedVariables; yourself]! ! !RBProgramNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:11'! comments "Answer the comments of the receiving parse tree node as intervals of starting and ending indices." ^ comments ifNil: [ #() ] ifNotNil: [ comments ]! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isLiteralArray ^false! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isEvaluatedFirst "Return true if we are the first thing evaluated in this statement." ^parent isNil or: [parent isSequence or: [parent evaluatedFirst: self]]! ! !RBProgramNode methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 6/12/2013 11:35'! suggestions ^SugsSuggestionFactory globalCommands addAll: self specialCommands; yourself ! ! !RBProgramNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:27'! isFaulty self subclassResponsibility! ! !RBProgramNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 8/5/2013 11:03'! isClean ^ self children allSatisfy: [ :child | child isClean ]! ! !RBProgramNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:10'! blockVariables ^parent ifNil: [#()] ifNotNil: [parent blockVariables]! ! !RBProgramNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:11'! mappingFor: aNode | method | method := self methodNode. method ifNil: [^aNode]. ^method mappingFor: aNode! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! start self subclassResponsibility! ! !RBProgramNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:32'! isTemp ^ false! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! debugHighlightStop ^ self stop ! ! !RBProgramNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:31'! isArgument ^false! ! !RBProgramNode methodsFor: 'properties' stamp: 'ClementBera 7/26/2013 17:12'! removeProperty: aKey ifAbsent: aBlock "Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock." | answer | properties ifNil: [ ^ aBlock value ]. answer := properties removeKey: aKey ifAbsent: aBlock. properties isEmpty ifTrue: [ properties := nil ]. ^ answer! ! !RBProgramNode methodsFor: 'testing' stamp: ''! lastIsReturn ^self isReturn! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isValue ^false! ! !RBProgramNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:30'! copyInContext: aDictionary ^ self copy! ! !RBProgramNode methodsFor: '*AST-Interpreter-Core' stamp: 'GuillermoPolito 5/14/2013 11:22'! method ^self parent method! ! !RBProgramNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:10'! asReturn "Change the current node to a return node." parent ifNil: [self error: 'Cannot change to a return without a parent node.']. parent isSequence ifFalse: [self error: 'Parent node must be a sequence node.']. (parent isLast: self) ifFalse: [self error: 'Return node must be last.']. ^parent addReturn! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! stop self subclassResponsibility! ! !RBProgramNode methodsFor: 'accessing' stamp: ''! allTemporaryVariables | children | children := self children. children isEmpty ifTrue: [^#()]. ^children inject: OrderedCollection new into: [:vars :each | vars addAll: each allTemporaryVariables; yourself]! ! !RBProgramNode methodsFor: 'comparing' stamp: ''! equalTo: aNode withMapping: aDictionary ^self = aNode! ! !RBProgramNode methodsFor: 'meta variable-accessing' stamp: ''! listCharacter ^$@! ! !RBProgramNode methodsFor: 'meta variable-accessing' stamp: ''! statementCharacter ^$.! ! !RBProgramNode methodsFor: 'testing' stamp: ''! containedBy: anInterval ^anInterval first <= self start and: [anInterval last >= self stop]! ! !RBProgramNode methodsFor: 'enumeration' stamp: ''! do: aBlock "Hacked to fit collection protocols" aBlock value: self! ! !RBProgramNode methodsFor: 'properties' stamp: 'lr 12/29/2009 12:45'! propertyAt: aKey ifAbsentPut: aBlock "Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value." ^ self propertyAt: aKey ifAbsent: [ self propertyAt: aKey put: aBlock value ]! ! !RBProgramNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 12/18/2012 14:08'! irInstruction "search for the first ir instruction that I generate" self methodNode ir sourceNode == self ifTrue: [^self methodNode ir]. ^self methodNode ir firstInstructionMatching: [:instr | instr sourceNode == self ] ! ! !RBProgramNode methodsFor: 'testing' stamp: 'MarcusDenker 6/27/2013 16:59'! isSuper ^false! ! !RBProgramNode methodsFor: 'testing' stamp: ''! isCascade ^false! ! !RBProgramNode methodsFor: 'meta variable-accessing' stamp: ''! recurseIntoCharacter ^$`! ! !RBProgramNode methodsFor: '*opalcompiler-core' stamp: 'CamilleTeruel 2/14/2014 14:33'! enclosingMethodOrBlockNode ^ self methodOrBlockNode ! ! !RBProgramNode class methodsFor: 'accessing' stamp: 'MarcusDenker 12/16/2013 20:16'! formatterClass: aClass FormatterClass := aClass ! ! !RBProgramNode class methodsFor: 'accessing' stamp: 'lr 11/7/2009 15:37'! optimizedSelectors ^ #( and: caseOf: caseOf:otherwise: ifFalse: ifFalse:ifTrue: ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: ifTrue: ifTrue:ifFalse: or: to:by:do: to:do: whileFalse whileFalse: whileTrue whileTrue: )! ! !RBProgramNode class methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:30'! formatterClass ^ FormatterClass ifNil: [ RBConfigurableFormatter ] ifNotNil: [ FormatterClass ]! ! !RBProgramNode class methodsFor: 'settings' stamp: 'LukasRenggli 12/18/2009 10:35'! settingsOn: aBuilder (aBuilder group: #refactoring) label: 'Refactoring Engine'; description: 'Settings related to the refactoring tools'; with: [ (aBuilder pickOne: #formatterClass) label: 'Formatter'; domainValues: (RBProgramNodeVisitor allSubclasses select: [ :each | each canUnderstand: #format: ]) ]! ! !RBProgramNodeTest commentStamp: 'TorstenBergmann 2/4/2014 21:53'! SUnit tests for RBProgramNode! !RBProgramNodeTest methodsFor: 'testing-replacing' stamp: 'lr 5/26/2010 08:39'! testReplaceVariable | tree | tree := self parseMethod: 'run "1" foo "2"'. tree body statements first replaceWith: (self parseExpression: 'zork'). self assert: tree newSource = 'run "1" zork "2"'. tree := self parseMethod: 'run "1" foo "2"'. tree body statements first replaceWith: (self parseExpression: '123'). self assert: tree newSource = 'run "1" 123 "2"'! ! !RBProgramNodeTest methodsFor: 'testing-adding' stamp: 'lr 1/4/2012 22:12'! testAddNode | tree treeNode | tree := self parseExpression: '1. 2'. treeNode := tree addNode: (self parseExpression: '3'). self assert: (self parseExpression: '1. 2. 3') = tree. self assert: tree statements last = treeNode. tree := self parseExpression: '{ 1. 2 }'. treeNode := tree addNode: (self parseExpression: '3'). self assert: (self parseExpression: '{ 1. 2. 3 }') = tree. self assert: tree statements last = treeNode! ! !RBProgramNodeTest methodsFor: 'testing-replacing' stamp: 'lr 5/26/2010 08:39'! testReplaceMethodBinary | tree | tree := self parseMethod: '= "1" anObject "2" ^ "3" 4 "5"'. tree renameSelector: #runCase andArguments: #(). self assert: tree newSource = 'runCase "2" ^ "3" 4 "5"'. tree := self parseMethod: '= "1" anObject "2" ^ "3" 4 "5"'. tree renameSelector: #~~ andArguments: (Array with: (self parseExpression: 'first')). self assert: tree newSource = '~~ "1" first "2" ^ "3" 4 "5"'. tree := self parseMethod: '= "1" anObject "2" ^ "3" 4 "5"'. tree renameSelector: #assert: andArguments: (Array with: (RBVariableNode named: 'first')). self assert: tree newSource = 'assert: "1" first "2" ^ "3" 4 "5"'. tree := self parseMethod: '= "1" anObject "2" ^ "3" 4 "5"'. tree renameSelector: #assert:description: andArguments: (Array with: (RBVariableNode named: 'first') with: (RBVariableNode named: 'second')). self assert: tree newSource = 'assert: first description: second "2" ^ "3" 4 "5"'! ! !RBProgramNodeTest methodsFor: 'accessing' stamp: 'lr 2/21/2010 12:17'! parseMethod: aString ^ RBParser parseMethod: aString! ! !RBProgramNodeTest methodsFor: 'testing-replacing' stamp: 'lr 5/26/2010 08:39'! testReplaceMethodKeywordLong | tree | tree := self parseMethod: 'deny: "1" anObject "2" description: "3" anotherObject "4" ^ "5" 6 "7"'. tree renameSelector: #runCase andArguments: #(). self assert: tree newSource = 'runCase "4" ^ "5" 6 "7"'. tree := self parseMethod: 'deny: "1" anObject "2" description: "3" anotherObject "4" ^ "5" 6 "7"'. tree renameSelector: #~~ andArguments: (Array with: (self parseExpression: 'first')). self assert: tree newSource = '~~ first "4" ^ "5" 6 "7"'. tree := self parseMethod: 'deny: "1" anObject "2" description: "3" anotherObject "4" ^ "5" 6 "7"'. tree renameSelector: #assert: andArguments: (Array with: (self parseExpression: 'first')). self assert: tree newSource = 'assert: first "4" ^ "5" 6 "7"'. tree := self parseMethod: 'deny: "1" anObject "2" description: "3" anotherObject "4" ^ "5" 6 "7"'. tree renameSelector: #assert:description: andArguments: (Array with: (self parseExpression: 'first') with: (self parseExpression: 'second')). self assert: tree newSource = 'assert: "1" first "2" description: "3" second "4" ^ "5" 6 "7"'! ! !RBProgramNodeTest methodsFor: 'testing-adding' stamp: 'lr 1/4/2012 22:11'! testAddNodesFirst | tree treeNodes | tree := self parseExpression: '3. 4'. treeNodes := tree addNodesFirst: (self parseExpression: '1. 2') statements. self assert: (self parseExpression: '1. 2. 3. 4') = tree. self assert: (tree statements at: 1) = treeNodes first. self assert: (tree statements at: 2) = treeNodes last. tree := self parseExpression: '{ 3. 4 }'. treeNodes := tree addNodesFirst: (self parseExpression: '1. 2') statements. self assert: (self parseExpression: '{ 1. 2. 3. 4 }') = tree. self assert: (tree statements at: 1) = treeNodes first. self assert: (tree statements at: 2) = treeNodes last! ! !RBProgramNodeTest methodsFor: 'testing-adding' stamp: 'lr 1/4/2012 21:55'! testAddTemporaryNamed | tree variable | tree := self parseExpression: '| a | a'. variable := tree addTemporaryNamed: 'b'. self assert: variable isVariable. self assert: variable name = 'b'. self assert: tree temporaries last = variable! ! !RBProgramNodeTest methodsFor: 'testing-adding' stamp: 'lr 1/4/2012 22:09'! testAddNodes | tree treeNodes | tree := self parseExpression: '1. 2'. treeNodes := tree addNodes: (self parseExpression: '3. 4') statements. self assert: (self parseExpression: '1. 2. 3. 4') = tree. self assert: (tree statements at: 3) = treeNodes first. self assert: (tree statements at: 4) = treeNodes last. tree := self parseExpression: '{ 1. 2 }'. treeNodes := tree addNodes: (self parseExpression: '3. 4') statements. self assert: (self parseExpression: '{ 1. 2. 3. 4 }') = tree. self assert: (tree statements at: 3) = treeNodes first. self assert: (tree statements at: 4) = treeNodes last! ! !RBProgramNodeTest methodsFor: 'testing-adding' stamp: 'lr 1/4/2012 22:11'! testAddNodeBefore | tree treeNode | tree := self parseExpression: '1. 3'. treeNode := tree addNode: (self parseExpression: '2') before: tree statements last. self assert: (self parseExpression: '1. 2. 3') = tree. self assert: (tree statements at: 2) = treeNode. tree := self parseExpression: '{ 1. 3 }'. treeNode := tree addNode: (self parseExpression: '2') before: tree statements last. self assert: (self parseExpression: '{ 1. 2. 3 }') = tree. self assert: (tree statements at: 2) = treeNode! ! !RBProgramNodeTest methodsFor: 'testing-replacing' stamp: 'lr 5/26/2010 08:38'! testReplaceLiteral | tree | tree := self parseMethod: 'run "1" 123 "2"'. tree body statements first replaceWith: (self parseExpression: '$a'). self assert: tree newSource = 'run "1" $a "2"'. tree := self parseMethod: 'run "1" 123 "2"'. tree body statements first replaceWith: (self parseExpression: 'zork'). self assert: tree newSource = 'run "1" zork "2"'! ! !RBProgramNodeTest methodsFor: 'testing-replacing' stamp: 'lr 2/21/2010 13:50'! testReplaceMessage | tree | tree := self parseMethod: 'run "1" self "2" run "3"'. tree body statements first replaceWith: (self parseExpression: 'self runCase'). self assert: tree newSource = 'run "1" self "2" runCase "3"'! ! !RBProgramNodeTest methodsFor: 'testing-replacing' stamp: 'lr 5/26/2010 08:39'! testReplaceMethodKeyword | tree | tree := self parseMethod: 'deny: "1" anObject "2" ^ "3" 4 "5"'. tree renameSelector: #runCase andArguments: #(). self assert: tree newSource = 'runCase "2" ^ "3" 4 "5"'. tree := self parseMethod: 'deny: "1" anObject "2" ^ "3" 4 "5"'. tree renameSelector: #~~ andArguments: (Array with: (self parseExpression: 'first')). self assert: tree newSource = '~~ "1" first "2" ^ "3" 4 "5"'. tree := self parseMethod: 'deny: "1" anObject "2" ^ "3" 4 "5"'. tree renameSelector: #assert: andArguments: (Array with: (RBVariableNode named: 'first')). self assert: tree newSource = 'assert: "1" first "2" ^ "3" 4 "5"'. tree := self parseMethod: 'deny: "1" anObject "2" ^ "3" 4 "5"'. tree renameSelector: #assert:description: andArguments: (Array with: (RBVariableNode named: 'first') with: (RBVariableNode named: 'second')). self assert: tree newSource = 'assert: first description: second "2" ^ "3" 4 "5"'! ! !RBProgramNodeTest methodsFor: 'testing-adding' stamp: 'lr 1/4/2012 22:10'! testAddNodesBefore | tree treeNodes | tree := self parseExpression: '1. 4'. treeNodes := tree addNodes: (self parseExpression: '2. 3') statements before: tree statements last. self assert: (self parseExpression: '1. 2. 3. 4') = tree. self assert: (tree statements at: 2) = treeNodes first. self assert: (tree statements at: 3) = treeNodes last. tree := self parseExpression: '{ 1. 4 }'. treeNodes := tree addNodes: (self parseExpression: '2. 3') statements before: tree statements last. self assert: (self parseExpression: '{ 1. 2. 3. 4 }') = tree. self assert: (tree statements at: 2) = treeNodes first. self assert: (tree statements at: 3) = treeNodes last! ! !RBProgramNodeTest methodsFor: 'testing-properties' stamp: 'lr 12/29/2009 12:49'! testPropertyAtIfAbsent self assert: (self node propertyAt: #foo ifAbsent: [ true ]). self node propertyAt: #foo put: true. self assert: (self node propertyAt: #foo ifAbsent: [ false ])! ! !RBProgramNodeTest methodsFor: 'testing-replacing' stamp: 'lr 5/26/2010 08:36'! testReplaceMessageArgument | tree | tree := self parseMethod: 'foo "1" self "2" foo: "3" foo "4"'. tree body statements first arguments first replaceWith: (self parseExpression: 'bar'). self assert: tree newSource = 'foo "1" self "2" foo: "3" bar "4"'. tree := self parseMethod: 'foo "1" self "2" foo: "3" foo "4"'. tree body statements first arguments first replaceWith: (self parseExpression: 'bar msg1 msg2'). self assert: tree newSource = 'foo "1" self "2" foo: "3" bar msg1 msg2 "4"'. tree := self parseMethod: 'foo "1" self "2" foo: "3" foo bar "4"'. tree body statements first arguments first replaceWith: (self parseExpression: 'bar'). self assert: tree newSource = 'foo "1" self "2" foo: "3" bar "4"'. ! ! !RBProgramNodeTest methodsFor: 'testing-replacing' stamp: 'lr 5/26/2010 08:36'! testReplaceMessageReceiver | tree | tree := self parseMethod: 'foo "1" self "2" foo: "3" 123 "4"'. tree body statements first receiver replaceWith: (self parseExpression: 'bar'). self assert: tree newSource = 'foo "1" bar "2" foo: "3" 123 "4"'. tree := self parseMethod: 'foo "1" self "2" foo: "3" 123 "4"'. tree body statements first receiver replaceWith: (self parseExpression: 'bar msg1 msg2'). self assert: tree newSource = 'foo "1" bar msg1 msg2 "2" foo: "3" 123 "4"'. tree := self parseMethod: 'foo "1" self foo "2" foo: "3" 123 "4"'. tree body statements first receiver replaceWith: (self parseExpression: 'bar'). self assert: tree newSource = 'foo "1" bar "2" foo: "3" 123 "4"'! ! !RBProgramNodeTest methodsFor: 'accessing' stamp: 'lr 12/29/2009 12:48'! node ^ node ifNil: [ node := RBProgramNode new ]! ! !RBProgramNodeTest methodsFor: 'testing-adding' stamp: 'lr 1/4/2012 22:01'! testAddSelfReturn | tree return | tree := self parseExpression: '1. 2'. return := tree addSelfReturn. self assert: tree statements last = return. self assert: (self parseExpression: '1. 2. ^ self') = tree. tree := self parseExpression: '3. ^ 4'. return := tree addSelfReturn. self assert: tree statements last = return. self assert: (self parseExpression: '3. ^ 4') = tree! ! !RBProgramNodeTest methodsFor: 'testing-properties' stamp: 'lr 12/29/2009 12:47'! testRemovePropertyIfAbsent self assert: (self node removeProperty: #foo ifAbsent: [ true ]). self node propertyAt: #foo put: true. self assert: (self node removeProperty: #foo ifAbsent: [ false ])! ! !RBProgramNodeTest methodsFor: 'testing-adding' stamp: 'lr 1/4/2012 21:57'! testAddTemporariesNamed | tree variables | tree := self parseExpression: '| a | a'. variables := tree addTemporariesNamed: #('b' 'c'). self assert: variables first isVariable. self assert: variables first name = 'b'. self assert: variables second isVariable. self assert: variables second name = 'c'. self assert: tree temporaries second = variables first. self assert: tree temporaries last = variables second ! ! !RBProgramNodeTest methodsFor: 'testing-properties' stamp: 'lr 12/29/2009 12:47'! testRemoveProperty self should: [ self node removeProperty: #foo ] raise: Error. self node propertyAt: #foo put: true. self assert: (self node removeProperty: #foo)! ! !RBProgramNodeTest methodsFor: 'testing-properties' stamp: 'lr 12/29/2009 12:46'! testPropertyAtIfAbsentPut self assert: (self node propertyAt: #foo ifAbsentPut: [ true ]). self assert: (self node propertyAt: #foo ifAbsentPut: [ false ])! ! !RBProgramNodeTest methodsFor: 'testing-properties' stamp: 'lr 12/29/2009 12:49'! testHasProperty self deny: (self node hasProperty: #foo). self node propertyAt: #foo put: 123. self assert: (self node hasProperty: #foo)! ! !RBProgramNodeTest methodsFor: 'testing-replacing' stamp: 'lr 5/26/2010 08:39'! testReplaceMethodUnary | tree | tree := self parseMethod: 'run "1" ^ "2" 3 "4"'. tree renameSelector: #runCase andArguments: #(). self assert: tree newSource = 'runCase "1" ^ "2" 3 "4"'. tree := self parseMethod: 'run "1" ^ "2" 3 "4"'. tree renameSelector: #~~ andArguments: (Array with: (self parseExpression: 'first')). self assert: tree newSource = '~~ first "1" ^ "2" 3 "4"'. tree := self parseMethod: 'run "1" ^ "2" 3 "4"'. tree renameSelector: #assert: andArguments: (Array with: (self parseExpression: 'first')). self assert: tree newSource = 'assert: first "1" ^ "2" 3 "4"'. tree := self parseMethod: 'run "1" ^ "2" 3 "4"'. tree renameSelector: #assert:description: andArguments: (Array with: (self parseExpression: 'first') with: (self parseExpression: 'second')). self assert: tree newSource = 'assert: first description: second "1" ^ "2" 3 "4"'! ! !RBProgramNodeTest methodsFor: 'accessing' stamp: 'lr 2/21/2010 12:17'! parseExpression: aString ^ RBParser parseExpression: aString! ! !RBProgramNodeTest methodsFor: 'testing-adding' stamp: 'lr 1/4/2012 22:01'! testAddReturn | tree return | tree := self parseExpression: '1. 2'. return := tree addReturn. self assert: tree statements last = return. self assert: (self parseExpression: '1. ^ 2') = tree. tree := self parseExpression: '3. ^ 4'. return := tree addReturn. self assert: tree statements last = return. self assert: (self parseExpression: '3. ^ 4') = tree! ! !RBProgramNodeTest methodsFor: 'testing-adding' stamp: 'lr 1/4/2012 22:12'! testAddNodeFirst | tree treeNode | tree := self parseExpression: '2. 3'. treeNode := tree addNodeFirst: (self parseExpression: '1'). self assert: (self parseExpression: '1. 2. 3') = tree. self assert: tree statements first = treeNode. tree := self parseExpression: '{ 2. 3 }'. treeNode := tree addNodeFirst: (self parseExpression: '1'). self assert: (self parseExpression: '{ 1. 2. 3 }') = tree. self assert: tree statements first = treeNode! ! !RBProgramNodeTest methodsFor: 'testing-replacing' stamp: 'lr 5/26/2010 08:38'! testReplaceLiteralArray | tree | tree := self parseMethod: 'run "1" #(1 2 3) "2"'. tree body statements first replaceWith: (self parseExpression: '#[1 2 3]'). self assert: tree newSource = 'run "1" #[1 2 3] "2"'. tree := self parseMethod: 'run "1" #(1 2 3) "2"'. tree body statements first replaceWith: (self parseExpression: '123'). self assert: tree newSource = 'run "1" 123 "2"'. tree := self parseMethod: 'run "1" #[1 2 3] "2"'. tree body statements first replaceWith: (self parseExpression: '#(1 2 3)'). self assert: tree newSource = 'run "1" #(1 2 3) "2"'. tree := self parseMethod: 'run "1" #[1 2 3] "2"'. tree body statements first replaceWith: (self parseExpression: '123'). self assert: tree newSource = 'run "1" 123 "2"' ! ! !RBProgramNodeTest methodsFor: 'testing-properties' stamp: 'lr 12/29/2009 12:49'! testPropertyAt self should: [ self node propertyAt: #foo ] raise: Error. self node propertyAt: #foo put: true. self assert: (self node propertyAt: #foo)! ! !RBProgramNodeTest class methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:06'! packageNamesUnderTest ^ #('AST-Core')! ! !RBProgramNodeVisitor commentStamp: ''! RBProgramNodeVisitor is an abstract visitor for the RBProgramNodes. ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptThisContextNode: aThisContextNode self deprecated: 'Use visitThisContextNode: instead' on: '29/03/2013' in: #Pharo30. ^ self visitThisContextNode: aThisContextNode! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptSelfNode: aSelfNode self deprecated: 'Use visitSelfNode: instead' on: '29/03/2013' in: #Pharo30. ^ self visitSelfNode: aSelfNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitSuperNode: aSuperNode ^ self visitVariableNode: aSuperNode! ! !RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''! visitArgumentNodes: aNodeCollection "Sent *once* when visiting method and block nodes" ^aNodeCollection do: [ :each | self visitArgumentNode: each ]! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitCascadeNode: aCascadeNode aCascadeNode messages do: [:each | self visitNode: each]! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitMessageNode: aMessageNode (aMessageNode isCascaded not or: [aMessageNode isFirstCascaded]) ifTrue: [self visitNode: aMessageNode receiver]. aMessageNode arguments do: [:each | self visitNode: each]! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitMethodNode: aMethodNode self visitArgumentNodes: aMethodNode arguments. aMethodNode pragmas do: [ :each | self visitNode: each ]. self visitNode: aMethodNode body! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitArrayNode: anArrayNode anArrayNode children do: [:each | self visitNode: each]! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptSequenceNode: aSequenceNode self deprecated: 'Use visitSequenceNode: instead' on: '29/03/2013' in: #Pharo30. self visitSequenceNode: aSequenceNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitBlockNode: aBlockNode self visitArgumentNodes: aBlockNode arguments. self visitNode: aBlockNode body! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitPatternBlockNode: aRBPatternBlockNode self visitArgumentNodes: aRBPatternBlockNode arguments. self visitNode: aRBPatternBlockNode body! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitSelfNode: aSelfNode ^ self visitVariableNode: aSelfNode! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptAssignmentNode: anAssignmentNode self deprecated: 'Use visitAssignmentNode: instead' on: '29/03/2013' in: #Pharo30. self visitAssignmentNode: anAssignmentNode variable. ! ! !RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''! visitTemporaryNode: aNode "Sent *each time* a temporary node is found" ^ self visitVariableNode: aNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitThisContextNode: aThisContextNode ^ self visitVariableNode: aThisContextNode! ! !RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''! visitVariableNode: aVariableNode ^ aVariableNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitLiteralArrayNode: aRBLiteralArrayNode aRBLiteralArrayNode contents do: [:each | self visitNode: each]! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptCascadeNode: aCascadeNode self deprecated: 'Use visitCascadeNode: instead' on: '29/03/2013' in: #Pharo30. self visitCascadeNode: aCascadeNode ! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! visitTemporaries: aNodeCollection self deprecated: 'Use visitTemporaryNodes: instead' on: '29/03/2013' in: #Pharo30. ^ self visitTemporaryNodes: aNodeCollection! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitPatternWrapperBlockNode: aRBPatternWrapperBlockNode self visitNode: aRBPatternWrapperBlockNode wrappedNode. self visitArgumentNodes: aRBPatternWrapperBlockNode arguments. self visitNode: aRBPatternWrapperBlockNode body! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptPragmaNode: aPragmaNode self deprecated: 'Use visitPragmaNode: instead' on: '29/03/2013' in: #Pharo30. self visitPragmaNode: aPragmaNode ! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptPatternBlockNode: aRBPatternBlockNode self deprecated: 'Use visitPatternBlockNode: instead' on: '29/03/2013' in: #Pharo30. self visitPatternBlockNode: aRBPatternBlockNode ! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitPragmaNode: aPragmaNode aPragmaNode arguments do: [ :each | self visitNode: each ]! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! visitArgument: each self deprecated: 'Use visitArgumentNode: instead' on: '29/03/2013' in: #Pharo30. ^self visitArgumentNode: each! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptLiteralNode: aLiteralNode self deprecated: 'Use visitLiteralNode: instead' on: '29/03/2013' in: #Pharo30. self visitLiteralNode: aLiteralNode! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! visitArguments: aNodeCollection self deprecated: 'Use visitArgumentsNodes: instead' on: '29/03/2013' in: #Pharo30. ^self visitArgumentNodes: aNodeCollection! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptArrayNode: anArrayNode self deprecated: 'Use visitArrayNode: instead' on: '29/03/2013' in: #Pharo30. self visitArrayNode: anArrayNode! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptArgumentNode: anArgumentNode self deprecated: 'Use visitArgumentNode: instead' on: '29/03/2013' in: #Pharo30. ^ self visitArgumentNode: anArgumentNode! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptTemporaryNode: anTemporaryNode self deprecated: 'Use visitTemporaryNode: instead' on: '29/03/2013' in: #Pharo30. ^ self visitTemporaryNode: anTemporaryNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitParseErrorNode: anErrorNode! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptSuperNode: aSuperNode self deprecated: 'Use visitSuperNode: instead' on: '29/03/2013' in: #Pharo30. ^ self visitSuperNode: aSuperNode! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptLiteralArrayNode: aRBLiteralArrayNode self deprecated: 'Use visitLiteralArrayNode: instead' on: '29/03/2013' in: #Pharo30. self visitLiteralArrayNode: aRBLiteralArrayNode ! ! !RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''! visitNode: aNode ^aNode acceptVisitor: self! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptMethodNode: aMethodNode self deprecated: 'Use visitMethodNode: instead' on: '29/03/2013' in: #Pharo30. self visitMethodNode: aMethodNode! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptPatternWrapperBlockNode: aRBPatternWrapperBlockNode self deprecated: 'Use visitPatternWrapperNode: instead' on: '29/03/2013' in: #Pharo30. self visitPatternWrapperBlockNode: aRBPatternWrapperBlockNode ! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptReturnNode: aReturnNode self deprecated: 'Use visitReturnNode: instead' on: '29/03/2013' in: #Pharo30. ^ self visitReturnNode: aReturnNode value! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptBlockNode: aBlockNode self deprecated: 'Use visitBlockNode: instead' on: '29/03/2013' in: #Pharo30. self visitBlockNode: aBlockNode ! ! !RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''! visitArgumentNode: anArgumentNode "Sent *each time* an argument node is found" ^ self visitVariableNode: anArgumentNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitSequenceNode: aSequenceNode self visitTemporaryNodes: aSequenceNode temporaries. aSequenceNode statements do: [:each | self visitNode: each]! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitAssignmentNode: anAssignmentNode self visitNode: anAssignmentNode variable. self visitNode: anAssignmentNode value! ! !RBProgramNodeVisitor methodsFor: 'visiting' stamp: ''! visitTemporaryNodes: aNodeCollection "This is triggered when defining the temporaries between the pipes" ^self visitArgumentNodes: aNodeCollection! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitLiteralNode: aLiteralNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified' stamp: ''! visitReturnNode: aReturnNode ^ self visitNode: aReturnNode value! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptMessageNode: aMessageNode self deprecated: 'Use visitMessageNode: instead' on: '29/03/2013' in: #Pharo30. self visitMessageNode: aMessageNode ! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptVariableNode: aVariableNode self deprecated: 'Use visitVariableNode: instead' on: '29/03/2013' in: #Pharo30. self visitVariableNode: aVariableNode! ! !RBProgramNodeVisitor methodsFor: '*Deprecated30' stamp: ''! acceptParseErrorNode: anErrorNode self deprecated: 'Use visitParseErrorNode: instead' on: '29/03/2013' in: #Pharo30. self visitParseErrorNode: anErrorNode! ! !RBProtectInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^RBCondition definesInstanceVariable: variableName in: class! ! !RBProtectInstanceVariableRefactoring methodsFor: 'private-accessing' stamp: 'lr 11/2/2009 00:14'! getterSetterMethods | matcher | matcher := RBParseTreeSearcher new. matcher answer: Set new; matchesAnyMethodOf: (Array with: '`method ^' , variableName with: ('`method: `arg <1s> := `arg' expandMacrosWith: variableName) with: ('`method: `arg ^<1s> := `arg' expandMacrosWith: variableName)) do: [:aNode :answer | (class subclassRedefines: aNode selector) ifFalse: [answer add: aNode selector]. answer]. (class whichSelectorsReferToInstanceVariable: variableName) do: [:each | self checkClass: class selector: each using: matcher]. ^matcher answer! ! !RBProtectInstanceVariableRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! inline: aSelector self onError: [self performComponentRefactoring: (RBInlineAllSendersRefactoring model: self model sendersOf: aSelector in: class)] do: []! ! !RBProtectInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''! transform self setOption: #inlineExpression toUse: [:ref :string | true]. self getterSetterMethods do: [:each | self inline: each]! ! !RBProtectInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testVariableNotDefined | refactoring | refactoring := RBProtectInstanceVariableRefactoring variable: 'rewrite' class: RBSubclassOfClassToRename. self shouldFail: refactoring! ! !RBProtectInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testProtectInstanceVariable | refactoring class | refactoring := RBProtectInstanceVariableRefactoring variable: 'rewrite' , 'Rule1' class: RBSubclassOfClassToRename. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBSubclassOfClassToRename. self assert: (class parseTreeFor: #calls1) = (RBParser parseMethod: 'calls1 ^rewriteRule1 := (rewriteRule1 := self calls)'). self assert: (class parseTreeFor: #calls) = (RBParser parseMethod: 'calls ^rewriteRule1 := rewriteRule1 , rewriteRule1'). self deny: (class directlyDefinesMethod: ('rewrite' , 'Rule1') asSymbol). self deny: (class directlyDefinesMethod: ('rewrite' , 'Rule1:') asSymbol)! ! !RBProtocolEnvironment methodsFor: 'testing' stamp: ''! includesClass: aClass ^aClass == class and: [super includesClass: aClass]! ! !RBProtocolEnvironment methodsFor: 'testing' stamp: ''! includesProtocol: aProtocol in: aClass ^aClass == class and: [(super includesProtocol: aProtocol in: aClass) and: [protocols includes: aProtocol]]! ! !RBProtocolEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:29'! postCopy super postCopy. protocols := protocols copy! ! !RBProtocolEnvironment methodsFor: 'testing' stamp: ''! isEmpty ^protocols isEmpty! ! !RBProtocolEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. super storeOn: aStream. aStream nextPutAll: ' class: '; nextPutAll: class name; nextPutAll: ' protocols: '. protocols asArray storeOn: aStream. aStream nextPut: $)! ! !RBProtocolEnvironment methodsFor: 'testing' stamp: 'lr 3/20/2011 11:18'! includesCategory: aCategory ^ (super includesCategory: aCategory) and: [ (environment classNamesFor: aCategory) inject: false into: [ :bool :each | bool or: [ | aClass | aClass := self systemDictionary at: each ifAbsent: [ nil ]. aClass == class or: [ aClass class == class ] ] ] ]! ! !RBProtocolEnvironment methodsFor: 'private' stamp: ''! defaultLabel | stream | stream := String new writeStream. stream nextPutAll: class name; nextPut: $>. protocols do: [:each | stream nextPutAll: each; nextPut: $ ]. ^stream contents! ! !RBProtocolEnvironment methodsFor: 'initialize-release' stamp: ''! class: aClass protocols: aCollection class := aClass. protocols := aCollection! ! !RBProtocolEnvironment methodsFor: 'testing' stamp: ''! includesSelector: aSelector in: aClass ^(super includesSelector: aSelector in: aClass) and: [protocols includes: (environment whichProtocolIncludes: aSelector in: aClass)]! ! !RBProtocolEnvironment class methodsFor: 'instance creation' stamp: ''! onEnvironment: anEnvironment class: aClass protocols: aCollection ^(self onEnvironment: anEnvironment) class: aClass protocols: aCollection; yourself! ! !RBProtocolEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:25'! class: aClass protocols: aCollection ^ self onEnvironment: self default class: aClass protocols: aCollection! ! !RBProtocolRegexRefactoring methodsFor: 'transforming' stamp: ''! transform | original replacement | self model allClassesDo: [ :class | class selectors do: [ :selector | original := (class realClass whichCategoryIncludesSelector: selector) asString. original isNil ifFalse: [ replacement := self execute: original. replacement = original ifFalse: [ class compile: (class sourceCodeFor: selector) classified: replacement ] ] ] ]! ! !RBPullUpClassVariableRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition isMetaclass: class) not! ! !RBPullUpClassVariableRefactoring methodsFor: 'private-accessing' stamp: 'CamilloBruni 10/8/2012 00:06'! subclassDefiningVariable | subclasses | subclasses := class allSubclasses select: [ :each | each isMeta not and: [ each directlyDefinesClassVariable: variableName ] ]. subclasses isEmpty ifTrue: [ self refactoringFailure: 'Could not find a class defining ' , variableName ]. subclasses size > 1 ifTrue: [ self refactoringError: 'Multiple subclasses define ' , variableName ]. ^ subclasses asArray first! ! !RBPullUpClassVariableRefactoring methodsFor: 'transforming' stamp: ''! transform | subclass | subclass := self subclassDefiningVariable. subclass removeClassVariable: variableName. class addClassVariable: variableName! ! !RBPullUpClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMetaClassFailure self shouldFail: (RBPullUpClassVariableRefactoring variable: #RecursiveSelfRule class: RBLintRuleTest class)! ! !RBPullUpClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testPullUpClassVariable | refactoring | refactoring := RBPullUpClassVariableRefactoring variable: #RecursiveSelfRule class: RBLintRuleTest. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBLintRuleTest) directlyDefinesClassVariable: #RecursiveSelfRule). self deny: ((refactoring model classNamed: #RBTransformationRuleTest) directlyDefinesClassVariable: #RecursiveSelfRule)! ! !RBPullUpClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBPullUpClassVariableRefactoring variable: #Foo class: RBLintRuleTest)! ! !RBPullUpInstanceVariableRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:06'! preconditions ^RBCondition withBlock: [(class hierarchyDefinesInstanceVariable: variableName) ifFalse: [self refactoringFailure: 'No subclass defines ' , variableName]. (class subclasses detect: [:each | (each directlyDefinesInstanceVariable: variableName) not] ifNone: [nil]) notNil ifTrue: [self refactoringWarning: 'Not all subclasses have an instance variable named ' , variableName , '.']. true]! ! !RBPullUpInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''! transform class allSubclasses do: [:each | (each directlyDefinesInstanceVariable: variableName) ifTrue: [each removeInstanceVariable: variableName]]. class addInstanceVariable: variableName! ! !RBPullUpInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testPullUpInstVar | refactoring | self proceedThroughWarning: [ refactoring := RBPullUpInstanceVariableRefactoring variable: 'result' class: RBLintRuleTest. self executeRefactoring: refactoring ]. self assert: ((refactoring model classNamed: #RBLintRuleTest) directlyDefinesInstanceVariable: 'result'). self deny: ((refactoring model classNamed: #RBBasicLintRuleTest) directlyDefinesInstanceVariable: 'result')! ! !RBPullUpInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testPullUpVariableNotDefined self shouldFail: (RBPullUpInstanceVariableRefactoring variable: 'notDefinedVariable' class: RBLintRuleTest)! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: 'lr 7/17/2010 22:44'! checkBackReferencesTo: aSelector | definingClass pushUpParseTree | definingClass := class superclass whoDefinesMethod: aSelector. definingClass isNil ifTrue: [^self]. pushUpParseTree := class parseTreeFor: aSelector. class superclass allSubclasses do: [:each | each selectors do: [:sel | | parseTree | parseTree := each parseTreeFor: sel. (parseTree notNil and: [(parseTree superMessages includes: aSelector) and: [definingClass == (each whoDefinesMethod: aSelector)]]) ifTrue: [removeDuplicates := true. (aSelector == sel and: [parseTree equalTo: pushUpParseTree exceptForVariables: #()]) ifFalse: [self refactoringError: ('Cannot pull up <1s> since it would override the method defined in <2p>' expandMacrosWith: aSelector with: definingClass)]]]]! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''! checkClassVars selectors do: [:each | self checkClassVarsFor: each]! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''! checkSuperSendsFromSiblings | siblings | siblings := class superclass subclasses reject: [:each | each = class]. siblings do: [:aRBClass | self checkSiblingSuperSendsFrom: aRBClass]! ! !RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: ''! copyDownMethods selectors do: [:each | self copyDownMethod: each]! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''! checkSuperclass | overrideSelectors | overrideSelectors := selectors select: [:each | class superclass definesMethod: each]. overrideSelectors := overrideSelectors reject: [:each | | myTree superTree | myTree := class parseTreeFor: each. superTree := class superclass parseTreeFor: each. superTree equalTo: myTree exceptForVariables: #()]. overrideSelectors isEmpty ifTrue: [^self]. class superclass isAbstract ifFalse: [self refactoringError: ('Non-abstract class <2p> already defines <1p>' expandMacrosWith: overrideSelectors asArray first with: class superclass)]. overrideSelectors do: [:each | self checkBackReferencesTo: each]! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(selectors inject: (RBCondition hasSuperclass: class) into: [:cond :each | cond & (RBCondition definesSelector: each in: class)]) & (RBCondition withBlock: [self checkInstVars. self checkClassVars. self checkSuperclass. self checkSuperMessages. true])! ! !RBPullUpMethodRefactoring methodsFor: 'printing' stamp: 'lr 7/17/2010 23:23'! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' pullUp: '. selectors asArray storeOn: aStream. aStream nextPutAll: ' from: '. class storeOn: aStream. aStream nextPut: $)! ! !RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: 'lr 7/17/2010 23:24'! transform self copyDownMethods; pullUpMethods; removePulledUpMethods; removeDuplicateMethods! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''! checkSuperMessages self checkSuperSendsFromPushedUpMethods. self checkSuperSendsFromSiblings! ! !RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: 'lr 7/17/2010 23:24'! pullUpMethods selectors do: [:each | self pullUp: each]! ! !RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: ''! removeDuplicatesOf: aSelector | tree | tree := class superclass parseTreeFor: aSelector. class superclass allSubclasses do: [:each | ((each directlyDefinesMethod: aSelector) and: [(tree equalTo: (each parseTreeFor: aSelector) exceptForVariables: #()) and: [(each superclass whoDefinesMethod: aSelector) == class superclass]]) ifTrue: [removeDuplicates ifFalse: [removeDuplicates := true. self refactoringWarning: 'Do you want to remove duplicate subclass methods?']. each removeMethod: aSelector]]! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: 'lr 10/26/2009 22:08'! checkClassVarsFor: aSelector class theNonMetaClass classVariableNames do: [ :each | ((class whichSelectorsReferToClassVariable: each) includes: aSelector) ifTrue: [ self refactoringError: ('<1p> refers to <2s> which is defined in <3p>' expandMacrosWith: aSelector with: each with: class) ] ]! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: 'lr 7/17/2010 22:44'! checkSuperSendsFromPushedUpMethods selectors do: [:each | | parseTree | parseTree := class parseTreeFor: each. (parseTree superMessages detect: [:sup | class superclass directlyDefinesMethod: sup] ifNone: [nil]) notNil ifTrue: [self refactoringError: ('Cannot pull up <1s> since it sends a super message that is defined in the superclass.' expandMacrosWith: each)]]! ! !RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:04'! pullUp: aSelector | source refactoring | source := class sourceCodeFor: aSelector. source isNil ifTrue: [self refactoringFailure: 'Source for method not available']. refactoring := RBExpandReferencedPoolsRefactoring model: self model forMethod: (class parseTreeFor: aSelector) fromClass: class toClasses: (Array with: class superclass). self performComponentRefactoring: refactoring. class superclass compile: source classified: (class protocolsFor: aSelector)! ! !RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: 'lr 7/17/2010 23:24'! removePulledUpMethods selectors do: [:each | class removeMethod: each]! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: 'lr 7/17/2010 22:44'! checkSiblingSuperSendsFrom: aRBClass aRBClass selectors do: [:each | | tree | tree := aRBClass parseTreeFor: each. tree notNil ifTrue: [tree superMessages do: [:aSelector | (selectors includes: aSelector) ifTrue: [| definer | definer := aRBClass superclass whoDefinesMethod: aSelector. (definer notNil and: [class includesClass: definer]) ifTrue: [self refactoringError: ('Cannot pull up <1s> since <2p>>><3s> sends a super message to it.' expandMacrosWith: aSelector with: aRBClass with: each)]]]]]. aRBClass allSubclasses do: [:each | self checkSiblingSuperSendsFrom: each]! ! !RBPullUpMethodRefactoring methodsFor: 'private' stamp: 'CamilloBruni 10/8/2012 00:05'! copyDownMethod: aSelector | oldProtocol oldSource superclassDefiner subclasses refactoring | superclassDefiner := class superclass whoDefinesMethod: aSelector. superclassDefiner isNil ifTrue: [^self]. oldSource := superclassDefiner sourceCodeFor: aSelector. oldSource isNil ifTrue: [self refactoringFailure: ('Source code for <1s> superclass method not available' expandMacrosWith: aSelector)]. oldProtocol := superclassDefiner protocolsFor: aSelector. subclasses := class superclass subclasses reject: [:each | each directlyDefinesMethod: aSelector]. subclasses isEmpty ifTrue: [^self]. ((superclassDefiner parseTreeFor: aSelector) superMessages detect: [:each | superclassDefiner directlyDefinesMethod: each] ifNone: [nil]) notNil ifTrue: [self refactoringError: ('Cannot pull up <1s> since we must copy down the superclass method in <2p>to the other subclasses, and the superclass method sends a super message which is overriden.' expandMacrosWith: aSelector with: superclassDefiner)]. self refactoringWarning: 'Do you want to copy down the superclass method to the classes that don''t define ' , aSelector. refactoring := RBExpandReferencedPoolsRefactoring model: self model forMethod: (superclassDefiner parseTreeFor: aSelector) fromClass: superclassDefiner toClasses: subclasses. self performComponentRefactoring: refactoring. subclasses do: [:each | each compile: oldSource classified: oldProtocol]! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''! checkInstVarsFor: aSelector class instanceVariableNames do: [:each | ((class whichSelectorsReferToInstanceVariable: each) includes: aSelector) ifTrue: [self refactoringError: ('<1p> refers to <2s> which is defined in <3p>' expandMacrosWith: aSelector with: each with: class)]]! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions' stamp: ''! checkInstVars selectors do: [:each | self checkInstVarsFor: each]! ! !RBPullUpMethodRefactoring methodsFor: 'initialize-release' stamp: 'lr 7/17/2010 23:23'! pullUp: selectorCollection from: aClass class := self classObjectFor: aClass. selectors := selectorCollection. removeDuplicates := false! ! !RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: ''! removeDuplicateMethods selectors do: [:each | self removeDuplicatesOf: each]! ! !RBPullUpMethodRefactoring class methodsFor: 'instance creation' stamp: 'lr 7/17/2010 23:23'! model: aRBSmalltalk pullUp: selectorCollection from: aClass ^(self new) model: aRBSmalltalk; pullUp: selectorCollection from: aClass; yourself! ! !RBPullUpMethodRefactoring class methodsFor: 'instance creation' stamp: 'lr 7/17/2010 23:23'! pullUp: selectorCollection from: aClass ^self new pullUp: selectorCollection from: aClass! ! !RBPullUpMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testPullUpWithSuperSendThatCannotBeCopiedDown | class | model defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: ''Foo'' poolDictionaries: '''' category: #''Refactory-Test data'''. (model classNamed: #Object) compile: 'foo ^3' classified: #(#accessing). model defineClass: 'SomeClass subclass: #Subclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. (model classNamed: #Subclass) compile: 'foo ^super foo' classified: #(#accessing). model defineClass: 'Subclass subclass: #Foo1 instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'Subclass subclass: #Foo2 instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. (class := model classNamed: #Foo2) compile: 'foo ^1' classified: #(#accessing). self shouldFail: (RBPullUpMethodRefactoring model: model pullUp: #(#foo) from: class)! ! !RBPullUpMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testPullUpClassMethod | class | class := model classNamed: #Object. class addClassVariable: #Foo. class theMetaClass compile: 'foo ^Foo' classified: #(#accessing ). self shouldFail: (RBPullUpMethodRefactoring model: model pullUp: #(#foo ) from: class theMetaClass)! ! !RBPullUpMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testPullUpWithInvalidSuperSend | class | model defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: ''Foo'' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'SomeClass subclass: #Subclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'Subclass subclass: #Foo1 instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'Subclass subclass: #Foo2 instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. (model classNamed: #Foo2) compile: 'yourself ^super yourself + 1' classified: #(#accessing). class := model classNamed: #Foo1. class compile: 'yourself ^1' classified: #(#accessing). self shouldFail: (RBPullUpMethodRefactoring model: model pullUp: #(#yourself) from: class)! ! !RBPullUpMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testPullUpMethodWithCopyOverriddenMethodsDown | refactoring | self proceedThroughWarning: [ refactoring := RBPullUpMethodRefactoring pullUp: #(#isComposite ) from: RBCompositeLintRuleTest. self executeRefactoring: refactoring ]. self assert: ((refactoring model classNamed: #RBBasicLintRuleTest) parseTreeFor: #isComposite) = (RBParser parseMethod: 'isComposite ^false'). self assert: ((refactoring model classNamed: ('RBFoo' , 'LintRuleTest') asSymbol) parseTreeFor: #isComposite) = (RBParser parseMethod: 'isComposite ^false'). self assert: ((refactoring model classNamed: #RBLintRuleTest) parseTreeFor: #isComposite) = (RBParser parseMethod: 'isComposite ^true'). self deny: ((refactoring model classNamed: #RBCompositeLintRuleTest) directlyDefinesMethod: #isComposite)! ! !RBPullUpMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testPullUpAndCopyDown | class | model defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: ''Foo'' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'SomeClass subclass: #Subclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'Subclass subclass: #Foo1 instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'Subclass subclass: #Foo2 instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. class := model classNamed: #Foo1. class compile: 'yourself ^1' classified: #(#accessing). self executeRefactoring: (RBPullUpMethodRefactoring model: model pullUp: #(#yourself) from: class). self assert: (class superclass parseTreeFor: #yourself) = (RBParser parseMethod: 'yourself ^1'). self deny: (class directlyDefinesMethod: #yourself). class := model classNamed: #Foo2. self assert: (class directlyDefinesMethod: #yourself). self assert: (class parseTreeFor: #yourself) = ((model classNamed: #Object) parseTreeFor: #yourself)! ! !RBPullUpMethodTest methodsFor: 'failure tests' stamp: 'CamilloBruni 1/13/2013 18:21'! testPullUpWithMethodThatCannotBePushedDown model defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: ''Foo'' poolDictionaries: '''' category: #''Refactory-Test data'''. (model classNamed: #SomeClass) compile: 'yourself ^54' classified: #(#accessing). self shouldFail: (RBPullUpMethodRefactoring model: model pullUp: #(#yourself) from: (model classNamed: #SomeClass))! ! !RBPullUpMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testPullUpReferencesInstVar self shouldFail: (RBPullUpMethodRefactoring pullUp: #(#checkClass: ) from: RBBasicLintRuleTest)! ! !RBPushDownClassVariableRefactoring methodsFor: 'transforming' stamp: ''! transform class removeClassVariable: variableName. destinationClass isNil ifTrue: [^self]. destinationClass addClassVariable: variableName! ! !RBPushDownClassVariableRefactoring methodsFor: 'preconditions' stamp: ''! signalMultipleReferenceError self signalReferenceError: ('Multiple subclasses reference <1s>' expandMacrosWith: variableName)! ! !RBPushDownClassVariableRefactoring methodsFor: 'preconditions' stamp: 'TestRunner 11/3/2009 09:28'! findDestinationClass | classes | classes := class withAllSubclasses reject: [ :each | (each whichSelectorsReferToClassVariable: variableName) isEmpty and: [ (each theMetaClass whichSelectorsReferToClassVariable: variableName) isEmpty ] ]. destinationClass := classes isEmpty ifTrue: [ nil ] ifFalse: [ classes asOrderedCollection first ]. classes do: [ :each | (destinationClass includesClass: each) ifTrue: [ destinationClass := each ] ifFalse: [ (each includesClass: destinationClass) ifFalse: [ self signalMultipleReferenceError ] ] ]. destinationClass = class ifTrue: [ self signalStillReferencedError ]. ^ destinationClass! ! !RBPushDownClassVariableRefactoring methodsFor: 'preconditions' stamp: ''! signalStillReferencedError self signalReferenceError: ('<1p> has references to <2s>' expandMacrosWith: class with: variableName)! ! !RBPushDownClassVariableRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/7/2012 23:56'! signalReferenceError: errorString class realClass isNil ifTrue: [ self refactoringError: errorString ] ifFalse: [| classVarName error | error := '<1s>Browse references?' expandMacrosWith: errorString. classVarName := variableName asSymbol. self refactoringError: error with: [ self openBrowserOn: (RBVariableEnvironment referencesToClassVariable: classVarName in: class realClass)]]! ! !RBPushDownClassVariableRefactoring methodsFor: 'preconditions' stamp: ''! preconditions "Preconditions are that only one subclass refers to the class variable." ^(RBCondition definesClassVariable: variableName in: class) & (RBCondition withBlock: [self findDestinationClass. true])! ! !RBPushDownClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelPushDownVariable | class | model defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: ''Foo'' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'SomeClass subclass: #Subclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. class := model classNamed: #Subclass. class compile: 'foo ^Foo' classified: #(#accessing). self executeRefactoring: (RBPushDownClassVariableRefactoring model: model variable: #Foo class: class superclass). self deny: (class superclass directlyDefinesClassVariable: #Foo). self assert: (class directlyDefinesClassVariable: #Foo)! ! !RBPushDownClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelNonExistantName model defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. self shouldFail: (RBPushDownClassVariableRefactoring model: model variable: #Foo class: (model classNamed: #SomeClass))! ! !RBPushDownClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelPushDownVariableToMultipleClassesInSameHierarchy | class | model defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: ''Foo'' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'SomeClass subclass: #Subclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. class := model classNamed: #Subclass. class compile: 'foo ^Foo' classified: #(#accessing). model defineClass: 'Subclass subclass: #AnotherSubclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. (model metaclassNamed: #AnotherSubclass) compile: 'bar ^Foo' classified: #(#accessing). self executeRefactoring: (RBPushDownClassVariableRefactoring model: model variable: #Foo class: class superclass). self deny: (class superclass directlyDefinesClassVariable: #Foo). self assert: (class directlyDefinesClassVariable: #Foo)! ! !RBPushDownClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelPushDownToMultipleSubclassesFailure model defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: ''Foo'' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'SomeClass subclass: #Subclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. (model classNamed: #Subclass) compile: 'foo ^Foo' classified: #(#accessing). model defineClass: 'SomeClass subclass: #AnotherSubclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. (model metaclassNamed: #AnotherSubclass) compile: 'bar ^Foo' classified: #(#accessing). self shouldFail: (RBPushDownClassVariableRefactoring model: model variable: #Foo class: (model classNamed: #SomeClass))! ! !RBPushDownClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelRemoveUnusedVariable model defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: ''Foo'' poolDictionaries: '''' category: #''Refactory-Test data'''. self assert: ((model classNamed: #SomeClass) directlyDefinesVariable: #Foo). model defineClass: 'SomeClass subclass: #Subclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. self executeRefactoring: (RBPushDownClassVariableRefactoring model: model variable: #Foo class: (model classNamed: #SomeClass)). self deny: ((model classNamed: #SomeClass) directlyDefinesVariable: #Foo). self deny: ((model classNamed: #Subclass) directlyDefinesVariable: #Foo)! ! !RBPushDownClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testPushDownClassVariable | refactoring | refactoring := RBPushDownClassVariableRefactoring variable: #Foo1 class: RBLintRuleTest. self assert: ((refactoring model classNamed: #RBLintRuleTest) directlyDefinesClassVariable: #Foo1). self executeRefactoring: refactoring. (refactoring model classNamed: #RBLintRuleTest) withAllSubclasses do: [ :each | self deny: (each directlyDefinesClassVariable: #Foo1) ]! ! !RBPushDownClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBPushDownClassVariableRefactoring variable: #Foo class: RBBasicLintRuleTest)! ! !RBPushDownClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelPushDownVariableToClassDownTwoLevels | class | model defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: ''Foo'' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'SomeClass subclass: #Subclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'Subclass subclass: #AnotherSubclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. class := model metaclassNamed: #AnotherSubclass. class compile: 'bar ^Foo' classified: #(#accessing ). class := class theNonMetaClass. self executeRefactoring: (RBPushDownClassVariableRefactoring model: model variable: #Foo class: class superclass superclass). self deny: (class superclass superclass directlyDefinesClassVariable: #Foo). self deny: (class superclass directlyDefinesClassVariable: #Foo). self assert: (class directlyDefinesClassVariable: #Foo)! ! !RBPushDownInstanceVariableRefactoring methodsFor: 'preconditions' stamp: 'lr 9/8/2011 20:25'! preconditions | references | references := RBCondition referencesInstanceVariable: variableName in: class. class realClass isNil ifTrue: [references errorMacro: ('<1s> is referenced.' expandMacrosWith: variableName)] ifFalse: [references errorMacro: ('<1s> is referenced.Browse references?' expandMacrosWith: variableName); errorBlock: [self openBrowserOn: (RBBrowserEnvironment new instVarRefsTo: variableName in: class realClass)]]. ^(RBCondition definesInstanceVariable: variableName in: class) & references not! ! !RBPushDownInstanceVariableRefactoring methodsFor: 'transforming' stamp: 'SebastianTleye 8/28/2013 13:47'! transform class removeInstanceVariable: variableName. class subclasses do: [:each | each addInstanceVariable: variableName]! ! !RBPushDownInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelPushDownToMetaclass model defineClass: 'Object subclass: #SomeClass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. (model metaclassNamed: #SomeClass) addInstanceVariable: 'foo'. model defineClass: 'SomeClass subclass: #Subclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. (model metaclassNamed: #Subclass) compile: 'foo ^foo' classified: #(#accessing). self executeRefactoring: (RBPushDownInstanceVariableRefactoring model: model variable: 'foo' class: (model metaclassNamed: #SomeClass)). self deny: ((model metaclassNamed: #SomeClass) directlyDefinesVariable: 'foo'). self assert: ((model metaclassNamed: #Subclass) directlyDefinesVariable: 'foo')! ! !RBPushDownInstanceVariableTest methodsFor: 'tests' stamp: 'SebastianTleye 8/28/2013 16:12'! testPushDownInstanceVariable | refactoring | refactoring := RBPushDownInstanceVariableRefactoring variable: 'foo1' class: RBLintRuleTest. self executeRefactoring: refactoring. (refactoring model classNamed: #RBLintRuleTest) subclasses do: [ :each | self assert: (each directlyDefinesInstanceVariable: 'foo1') ]! ! !RBPushDownInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelPushDownToMultipleSubclasses model defineClass: 'Object subclass: #SomeClass instanceVariableNames: ''foo'' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'SomeClass subclass: #Subclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. (model classNamed: #Subclass) compile: 'foo ^foo' classified: #(#accessing). model defineClass: 'SomeClass subclass: #AnotherSubclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. (model classNamed: #AnotherSubclass) compile: 'bar ^foo' classified: #(#accessing). self executeRefactoring: (RBPushDownInstanceVariableRefactoring model: model variable: 'foo' class: (model classNamed: #SomeClass)). self deny: ((model classNamed: #SomeClass) directlyDefinesVariable: 'foo'). self assert: ((model classNamed: #Subclass) directlyDefinesVariable: 'foo'). self assert: ((model classNamed: #AnotherSubclass) directlyDefinesVariable: 'foo')! ! !RBPushDownInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBPushDownInstanceVariableRefactoring variable: 'foo' class: RBBasicLintRuleTest)! ! !RBPushDownInstanceVariableTest methodsFor: 'tests' stamp: 'SebastianTleye 8/28/2013 16:10'! testModelRemoveUnusedVariable model defineClass: 'Object subclass: #SomeClass instanceVariableNames: ''foo'' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. model defineClass: 'SomeClass subclass: #Subclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. self executeRefactoring: (RBPushDownInstanceVariableRefactoring model: model variable: 'foo' class: (model classNamed: #SomeClass)). self deny: ((model classNamed: #SomeClass) directlyDefinesVariable: 'foo'). self assert: ((model classNamed: #Subclass) directlyDefinesVariable: 'foo')! ! !RBPushDownMethodRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! pushDown: aSelector | code protocols refactoring | code := class sourceCodeFor: aSelector. protocols := class protocolsFor: aSelector. refactoring := RBExpandReferencedPoolsRefactoring model: self model forMethod: (class parseTreeFor: aSelector) fromClass: class toClasses: class subclasses. self performComponentRefactoring: refactoring. class subclasses do: [:each | (each directlyDefinesMethod: aSelector) ifFalse: [each compile: code classified: protocols]]! ! !RBPushDownMethodRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 1/12/2013 12:50'! preconditions | condition | condition := selectors inject: RBCondition empty into: [ :cond :each | cond & (RBCondition definesSelector: each in: class) & (RBCondition subclassesOf: class referToSelector: each) not]. ^condition & (RBCondition isAbstractClass: class)! ! !RBPushDownMethodRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' pushDown: '. selectors asArray storeOn: aStream. aStream nextPutAll: ' from: '. class storeOn: aStream. aStream nextPut: $)! ! !RBPushDownMethodRefactoring methodsFor: 'initialize-release' stamp: ''! pushDown: selectorCollection from: aClass class := self classObjectFor: aClass. selectors := selectorCollection! ! !RBPushDownMethodRefactoring methodsFor: 'transforming' stamp: ''! transform selectors do: [:each | self pushDown: each]. selectors do: [:each | class removeMethod: each]! ! !RBPushDownMethodRefactoring class methodsFor: 'instance creation' stamp: ''! pushDown: selectorCollection from: aClass ^self new pushDown: selectorCollection from: aClass! ! !RBPushDownMethodRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk pushDown: selectorCollection from: aClass ^(self new) model: aRBSmalltalk; pushDown: selectorCollection from: aClass; yourself! ! !RBPushDownMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testPushDownMethod | refactoring class | refactoring := RBPushDownMethodRefactoring pushDown: #(#name: ) from: RBLintRuleTest. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBLintRuleTest. self deny: (class directlyDefinesMethod: #name:). class subclasses do: [ :each | self assert: (each parseTreeFor: #name:) = (RBParser parseMethod: 'name: aString name := aString') ]! ! !RBPushDownMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testPushDownNonExistantMenu | refactoring | refactoring := RBPushDownMethodRefactoring pushDown: #(#someMethodThatDoesNotExist ) from: RBLintRuleTest. self shouldFail: refactoring! ! !RBPushDownMethodTest methodsFor: 'failure tests' stamp: 'CamilloBruni 8/27/2013 15:18'! testPushDownMethodOnNonAbstractClass | refactoring | refactoring := RBPushDownMethodRefactoring pushDown: #(#isArray) from: Array. self shouldFail: refactoring! ! !RBPushDownMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testPushDownMethodThatReferencesPoolDictionary | refactoring class parseTree | parseTree := RBLintRuleTest parseTreeFor: #junk. self proceedThroughWarning: [ refactoring := RBPushDownMethodRefactoring pushDown: #(#junk ) from: RBLintRuleTest. self executeRefactoring: refactoring ]. class := refactoring model classNamed: #RBLintRuleTest. self deny: (class directlyDefinesMethod: #junk). class subclasses do: [ :each | self assert: (each parseTreeFor: #junk) = parseTree. self assert: (each directlyDefinesPoolDictionary: 'TextConstants' asSymbol) ]! ! !RBReadBeforeWrittenTester commentStamp: ''! RBReadBeforeWrittenTester is a visitor that identifies variables that may have been read before they are initialized. Instance Variables: checkNewTemps description of checkNewTemps read description of read scopeStack description of scopeStack ! !RBReadBeforeWrittenTester methodsFor: 'initialize-release' stamp: ''! checkNewTemps: aBoolean checkNewTemps := aBoolean! ! !RBReadBeforeWrittenTester methodsFor: 'initialize-release' stamp: ''! initializeVars: varNames varNames do: [:each | self currentScope at: each put: nil]! ! !RBReadBeforeWrittenTester methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 16:04'! visitMessageNode: aMessageNode ((#(#whileTrue: #whileFalse: #whileTrue #whileFalse) includes: aMessageNode selector) and: [aMessageNode receiver isBlock]) ifTrue: [self executeTree: aMessageNode receiver body] ifFalse: [(aMessageNode isCascaded not or: [aMessageNode isFirstCascaded]) ifTrue: [self visitNode: aMessageNode receiver]]. ((#(#ifTrue:ifFalse: #ifFalse:ifTrue:) includes: aMessageNode selector) and: [aMessageNode arguments allSatisfy: [:each | each isBlock]]) ifTrue: [^self processIfTrueIfFalse: aMessageNode]. aMessageNode arguments do: [:each | self visitNode: each]! ! !RBReadBeforeWrittenTester methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 16:04'! visitSequenceNode: aSequenceNode self processStatementNode: aSequenceNode! ! !RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''! createScope scopeStack add: (self copyDictionary: scopeStack last)! ! !RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''! currentScope ^scopeStack last! ! !RBReadBeforeWrittenTester methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 16:04'! visitBlockNode: aBlockNode self processBlock: aBlockNode! ! !RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''! processBlock: aNode | newScope | self createScope. self executeTree: aNode body. newScope := self removeScope. newScope keysAndValuesDo: [:key :value | (value == true and: [(self currentScope at: key) isNil]) ifTrue: [self currentScope at: key put: value]]! ! !RBReadBeforeWrittenTester methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 16:05'! visitVariableNode: aVariableNode self variableRead: aVariableNode! ! !RBReadBeforeWrittenTester methodsFor: 'initialization' stamp: ''! initialize super initialize. scopeStack := OrderedCollection with: Dictionary new. read := Set new. checkNewTemps := true! ! !RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''! removeScope ^scopeStack removeLast! ! !RBReadBeforeWrittenTester methodsFor: 'accessing' stamp: ''! read self currentScope keysAndValuesDo: [:key :value | value == true ifTrue: [read add: key]]. ^read! ! !RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''! variableRead: aNode (self currentScope includesKey: aNode name) ifTrue: [(self currentScope at: aNode name) isNil ifTrue: [self currentScope at: aNode name put: true]]! ! !RBReadBeforeWrittenTester methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 16:04'! visitAssignmentNode: anAssignmentNode self visitNode: anAssignmentNode value. self variableWritten: anAssignmentNode! ! !RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''! variableWritten: aNode (self currentScope includesKey: aNode variable name) ifTrue: [(self currentScope at: aNode variable name) isNil ifTrue: [self currentScope at: aNode variable name put: false]]! ! !RBReadBeforeWrittenTester methodsFor: 'accessing' stamp: ''! executeTree: aParseTree ^self visitNode: aParseTree! ! !RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''! processStatementNode: aNode | temps | (checkNewTemps not or: [aNode temporaries isEmpty]) ifTrue: [aNode statements do: [:each | self executeTree: each]. ^self]. self createScope. temps := aNode temporaries collect: [:each | each name]. self initializeVars: temps. aNode statements do: [:each | self executeTree: each]. self removeScope keysAndValuesDo: [:key :value | (temps includes: key) ifTrue: [value == true ifTrue: [read add: key]] ifFalse: [(self currentScope at: key) isNil ifTrue: [self currentScope at: key put: value]]]! ! !RBReadBeforeWrittenTester methodsFor: 'private' stamp: 'TestRunner 11/3/2009 09:10'! copyDictionary: aDictionary "We could send aDictionary the copy message, but that doesn't copy the associations." | newDictionary | newDictionary := Dictionary new: aDictionary size. aDictionary keysAndValuesDo: [ :key :value | newDictionary at: key put: value ]. ^ newDictionary! ! !RBReadBeforeWrittenTester methodsFor: 'private' stamp: ''! processIfTrueIfFalse: aNode | trueScope falseScope | self createScope. self executeTree: aNode arguments first body. trueScope := self removeScope. self createScope. self executeTree: aNode arguments last body. falseScope := self removeScope. self currentScope keysAndValuesDo: [:key :value | value isNil ifTrue: [(trueScope at: key) == (falseScope at: key) ifTrue: [self currentScope at: key put: (trueScope at: key)] ifFalse: [((trueScope at: key) == true or: [(falseScope at: key) == true]) ifTrue: [self currentScope at: key put: true]]]]! ! !RBReadBeforeWrittenTester class methodsFor: 'accessing' stamp: ''! variablesReadBeforeWrittenIn: aParseTree ^(self new) executeTree: aParseTree; read! ! !RBReadBeforeWrittenTester class methodsFor: 'accessing' stamp: ''! isVariable: aString writtenBeforeReadIn: aBRProgramNode ^(self readBeforeWritten: (Array with: aString) in: aBRProgramNode) isEmpty! ! !RBReadBeforeWrittenTester class methodsFor: 'accessing' stamp: ''! readBeforeWritten: varNames in: aParseTree ^(self new) checkNewTemps: false; initializeVars: varNames; executeTree: aParseTree; read! ! !RBReadBeforeWrittenTester class methodsFor: 'accessing' stamp: ''! isVariable: aString readBeforeWrittenIn: aBRProgramNode ^(self isVariable: aString writtenBeforeReadIn: aBRProgramNode) not! ! !RBRealizeClassRefactoring commentStamp: 'lr 10/19/2007 09:16'! Make a given class concrete, by providing empty templates for all the abstract methods.! !RBRealizeClassRefactoring methodsFor: 'transforming' stamp: ''! transform: aClass | class method parseTree | aClass allSelectors do: [ :selector | class := aClass whoDefinesMethod: selector. (class notNil and: [ class ~= aClass ]) ifTrue: [ method := class methodFor: selector. (method notNil and: [ method refersToSymbol: #subclassResponsibility ]) ifTrue: [ parseTree := method parseTree. parseTree body temporaries: OrderedCollection new; statements: OrderedCollection new; addNode: (RBMessageNode receiver: (RBVariableNode named: 'self') selector: #shouldBeImplemented). aClass compile: parseTree newSource withAttributesFrom: method ] ] ]! ! !RBRealizeClassRefactoring methodsFor: 'transforming' stamp: ''! transform self transform: self theClass. self transform: self theClass theMetaClass! ! !RBRealizeClassRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^ RBCondition withBlock: [ (self theClass withAllSubclasses detect: [ :each | (each whichSelectorsReferToSymbol: #subclassResponsibility) notEmpty or: [ (each theMetaClass whichSelectorsReferToSymbol: #subclassResponsibility) notEmpty ] ] ifNone: [ nil ]) isNil ] errorString: self theClass printString , ' is abstract or has abstract subclasses.'! ! !RBRealizeClassRefactoring methodsFor: 'accessing' stamp: ''! theClass ^ (self classObjectFor: className) theNonMetaClass! ! !RBRefactoring methodsFor: 'utilities' stamp: ''! checkInstanceVariableName: aName in: aClass ^RBCondition checkInstanceVariableName: aName in: aClass! ! !RBRefactoring methodsFor: 'accessing' stamp: ''! changes ^self model changes! ! !RBRefactoring methodsFor: 'support' stamp: ''! checkClass: aRBClass selector: aSelector using: aMatcher | parseTree | parseTree := aRBClass parseTreeFor: aSelector. parseTree notNil ifTrue: [aMatcher executeTree: parseTree]. ^aMatcher answer! ! !RBRefactoring methodsFor: 'support' stamp: ''! convertAllReferencesToClass: aRBClass using: searchReplacer self model allReferencesToClass: aRBClass do: [:method | self convertMethod: method selector for: method modelClass using: searchReplacer]! ! !RBRefactoring methodsFor: 'private' stamp: 'lr 10/5/2010 16:13'! refactoringError: aString ^ RBRefactoringError signal: aString! ! !RBRefactoring methodsFor: 'preconditions' stamp: ''! checkPreconditions | conditions block | conditions := self preconditions. conditions check ifFalse: [block := conditions errorBlock. block notNil ifTrue: [self refactoringError: conditions errorString with: block] ifFalse: [self refactoringError: conditions errorString]]! ! !RBRefactoring methodsFor: 'accessing' stamp: ''! copyOptionsFrom: aDictionary | dict | dict := self options. dict == self class refactoringOptions ifTrue: [^self options: aDictionary copy]. dict keysAndValuesDo: [:key :value | value == (self class refactoringOptions at: key) ifTrue: [dict at: key put: (aDictionary at: key)]]. self options: dict! ! !RBRefactoring methodsFor: 'support' stamp: ''! convertAllReferencesTo: aSymbol using: searchReplacer self model allReferencesTo: aSymbol do: [:method | self convertMethod: method selector for: method modelClass using: searchReplacer]! ! !RBRefactoring methodsFor: 'transforming' stamp: ''! transform self subclassResponsibility! ! !RBRefactoring methodsFor: 'requests' stamp: ''! shouldOverride: aSelector in: aClass ^(self options at: #alreadyDefined) value: self value: aClass value: aSelector! ! !RBRefactoring methodsFor: 'support' stamp: ''! convertMethod: selector for: aClass using: searchReplacer "Convert the parse tree for selector using the searchReplacer. If a change is made then compile it into the changeBuilder." | parseTree | parseTree := aClass parseTreeFor: selector. parseTree isNil ifTrue: [^self]. (searchReplacer executeTree: parseTree) ifTrue: [aClass compileTree: searchReplacer tree]! ! !RBRefactoring methodsFor: 'transforming' stamp: ''! performComponentRefactoring: aRefactoring aRefactoring copyOptionsFrom: self options. aRefactoring primitiveExecute! ! !RBRefactoring methodsFor: 'private' stamp: 'lr 1/4/2010 20:10'! safeVariableNameFor: aClass temporaries: allTempVars basedOn: aString | baseString i newString | newString := baseString := aString. i := 0. [ (allTempVars includes: newString) or: [ aClass definesInstanceVariable: newString ] ] whileTrue: [ i := i + 1. newString := baseString , i printString ]. ^ newString! ! !RBRefactoring methodsFor: 'accessing' stamp: ''! options ^options isNil ifTrue: [self class refactoringOptions] ifFalse: [options]! ! !RBRefactoring methodsFor: 'private' stamp: 'CamilloBruni 10/7/2012 23:54'! refactoringFailure: aString ^ RBRefactoringFailure signal: aString! ! !RBRefactoring methodsFor: 'accessing' stamp: ''! options: aDictionary options := aDictionary! ! !RBRefactoring methodsFor: 'support' stamp: ''! convertClasses: classSet select: aBlock using: searchReplacer classSet do: [:aClass | (aBlock value: aClass) do: [:selector | self convertMethod: selector for: aClass using: searchReplacer]]! ! !RBRefactoring methodsFor: 'requests' stamp: ''! shouldUseExistingMethod: aSelector ^(self options at: #useExistingMethod) value: self value: aSelector! ! !RBRefactoring methodsFor: 'utilities' stamp: ''! checkMethodName: aName in: aClass ^RBCondition checkMethodName: aName in: aClass! ! !RBRefactoring methodsFor: 'private' stamp: 'lr 10/5/2010 16:13'! refactoringError: aString with: aBlock ^ RBRefactoringError signal: aString with: aBlock! ! !RBRefactoring methodsFor: 'private' stamp: ''! primitiveExecute self checkPreconditions. self transform! ! !RBRefactoring methodsFor: 'requests' stamp: ''! requestSelfArgumentName ^(self options at: #selfArgumentName) value: self! ! !RBRefactoring methodsFor: 'private' stamp: ''! uniqueMethodNameFor: anInteger | before after index name | before := 'a'. after := ''. anInteger timesRepeat: [after := after , 'z:']. index := 0. [name := before , index printString , after. (Symbol findInterned: name) notNil] whileTrue: [index := index + 1]. ^name asSymbol! ! !RBRefactoring methodsFor: 'testing' stamp: ''! canReferenceVariable: aString in: aClass (aClass definesVariable: aString) ifTrue: [^true]. (self model includesGlobal: aString asSymbol) ifTrue: [^true]. ^(self poolVariableNamesFor: aClass) includes: aString! ! !RBRefactoring methodsFor: 'preconditions' stamp: ''! preconditions self subclassResponsibility! ! !RBRefactoring methodsFor: 'utilities' stamp: 'lr 7/23/2010 08:04'! poolVariableNamesFor: aClass | pools | pools := Set new. aClass withAllSuperclasses do: [:each | each allPoolDictionaryNames do: [:pool | pools addAll: ((Smalltalk globals at: pool asSymbol) keys collect: [:name | name asString])]]. ^pools! ! !RBRefactoring methodsFor: 'private' stamp: ''! onError: aBlock do: errorBlock ^aBlock on: self class preconditionSignal do: [:ex | errorBlock value. ex return: nil]! ! !RBRefactoring methodsFor: 'requests' stamp: 'dvf 9/8/2001 19:32'! requestMethodNameFor: aMethodName ^(self options at: #methodName) value: self value: aMethodName! ! !RBRefactoring methodsFor: 'requests' stamp: ''! shouldExtractAssignmentTo: aString ^(self options at: #extractAssignment) value: self value: aString! ! !RBRefactoring methodsFor: 'utilities' stamp: 'lr 11/2/2009 00:14'! whichVariableNode: aParseTree inInterval: anInterval name: aName | matcher block | matcher := RBParseTreeSearcher new. block := [:aNode :answer | (aNode intersectsInterval: anInterval) ifTrue: [aNode] ifFalse: [answer]]. matcher matches: aName do: block; matchesArgument: aName do: block. ^matcher executeTree: aParseTree initialAnswer: nil! ! !RBRefactoring methodsFor: 'requests' stamp: ''! openBrowserOn: anEnvironment ^(self options at: #openBrowser) value: self value: anEnvironment! ! !RBRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:25'! defaultEnvironment ^RBBrowserEnvironment new! ! !RBRefactoring methodsFor: 'transforming' stamp: ''! model ^model isNil ifTrue: [model := (RBNamespace onEnvironment: self defaultEnvironment) name: self printString; yourself] ifFalse: [model]! ! !RBRefactoring methodsFor: 'private' stamp: 'CamilloBruni 10/7/2012 23:55'! refactoringFailure: aString with: aBlock ^ RBRefactoringFailure signal: aString with: aBlock! ! !RBRefactoring methodsFor: 'utilities' stamp: ''! associationForClassVariable: aName in: aClass ifAbsent: aBlock ^aClass realClass classPool associationAt: aName asSymbol ifAbsent: [aClass realClass classPool associationAt: aName asString ifAbsent: aBlock]! ! !RBRefactoring methodsFor: 'utilities' stamp: ''! safeMethodNameFor: aClass basedOn: aString "Creates an unused method name containing aString" | baseString newString hasParam i | baseString := aString copy. baseString at: 1 put: baseString first asLowercase. newString := baseString. hasParam := newString last = $:. hasParam ifTrue: [baseString := newString copyFrom: 1 to: newString size - 1]. i := 0. [aClass hierarchyDefinesMethod: newString asSymbol] whileTrue: [i := i + 1. newString := baseString , i printString , (hasParam ifTrue: [':'] ifFalse: [''])]. ^newString asSymbol! ! !RBRefactoring methodsFor: 'requests' stamp: 'lr 2/14/2009 11:23'! selectVariableTypesFrom: initialTypeCollection selected: selectedTypeCollection ^ (self options at: #variableTypes) value: self value: initialTypeCollection value: selectedTypeCollection ! ! !RBRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:14'! execute self primitiveExecute. RBRefactoringManager instance addRefactoring: self! ! !RBRefactoring methodsFor: 'requests' stamp: ''! selectVariableToMoveMethodTo: aSelector class: aClass ^(self options at: #selectVariableToMoveTo) value: self value: aClass value: aSelector! ! !RBRefactoring methodsFor: 'requests' stamp: ''! requestImplementorToInline: implementorsCollection ^(self options at: #implementorToInline) value: self value: implementorsCollection! ! !RBRefactoring methodsFor: 'private' stamp: 'lr 10/5/2010 16:13'! refactoringWarning: aString ^ RBRefactoringWarning signal: aString! ! !RBRefactoring methodsFor: 'accessing' stamp: ''! setOption: aSymbol toUse: aBlock | dict | dict := self options. dict == self class refactoringOptions ifTrue: [dict := dict copy]. dict at: aSymbol put: aBlock. self options: dict! ! !RBRefactoring methodsFor: 'private' stamp: 'dc 5/8/2007 12:05'! classObjectFor: anObject (anObject isBehavior or: [anObject isTrait]) ifTrue: [^self model classFor: anObject]. anObject isSymbol ifTrue: [^self model classNamed: anObject]. ^anObject! ! !RBRefactoring methodsFor: 'initialize-release' stamp: ''! model: aRBNamespace model := aRBNamespace! ! !RBRefactoring methodsFor: 'requests' stamp: ''! shouldInlineExpression: aString ^(self options at: #inlineExpression) value: self value: aString! ! !RBRefactoring methodsFor: '*NautilusRefactoring' stamp: ''! whatToDisplayIn: aBrowser ^ self changes changes gather: [:e | e whatToDisplayIn: aBrowser ]! ! !RBRefactoring class methodsFor: 'initialization' stamp: 'lr 2/14/2009 11:20'! initializeRefactoringOptions RefactoringOptions := IdentityDictionary new. RefactoringOptions at: #implementorToInline put: [ :ref :imps | self error: #implementorToInline ]; at: #methodName put: [ :ref :methodName | self error: #methodName ]; at: #selfArgumentName put: [ :ref | self error: #selfArgumentName ]; at: #selectVariableToMoveTo put: [ :ref :class :selector | self error: #selectVariableToMoveTo ]; at: #variableTypes put: [ :ref :types :selected | self error: #variableTypes ]; at: #extractAssignment put: [ :ref :varName | self error: #extractAssignment ]; at: #inlineExpression put: [ :ref :string | self error: #inlineExpression ]; at: #alreadyDefined put: [ :ref :cls :selector | self error: #alreadyDefined ]; at: #useExistingMethod put: [ :ref :selector | self error: #useExistingMethod ]; at: #openBrowser put: [ :ref :env | self error: #openBrowser ]! ! !RBRefactoring class methodsFor: 'initialization' stamp: 'lr 1/18/2010 21:02'! initialize self initializeRefactoringOptions! ! !RBRefactoring class methodsFor: 'accessing' stamp: 'lr 1/18/2010 21:03'! refactoringOptions ^ RefactoringOptions! ! !RBRefactoring class methodsFor: 'accessing signal' stamp: 'lr 10/5/2010 16:13'! preconditionSignal ^ RBRefactoringError , RBRefactoringWarning! ! !RBRefactoring class methodsFor: 'accessing' stamp: ''! setDefaultOption: aSymbol to: aBlock self refactoringOptions at: aSymbol put: aBlock! ! !RBRefactoring class methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 10/11/2013 11:05'! cleanUp "RefactoringOptions holds on to blocks, we should make sure to recreate them so the block references the current method" self initializeRefactoringOptions.! ! !RBRefactoringBrowserTest methodsFor: 'private' stamp: 'CamilloBruni 1/12/2013 12:49'! proceedThroughWarning: aBlock aBlock on: RBRefactoringWarning do: [ :ex | ex resume ]! ! !RBRefactoringBrowserTest methodsFor: 'private' stamp: ''! convertInterval: anInterval for: aString "Convert the interval to ignore differences in end of line conventions." ^anInterval! ! !RBRefactoringBrowserTest methodsFor: 'private' stamp: ''! objectClassVariable ^Object classPool keys detect: [:each | true]! ! !RBRefactoringBrowserTest methodsFor: 'private' stamp: ''! executeRefactoring: aRefactoring aRefactoring primitiveExecute. RBParser parseExpression: aRefactoring storeString! ! !RBRefactoringBrowserTest class methodsFor: 'testing' stamp: 'lr 10/27/2009 14:01'! isAbstract ^ self name = #RBRefactoringBrowserTest! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 08:33'! testCompileInClassified | change | change := changes compile: 'setUp' in: self class classified: #accessing. self assert: change controller isNil. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change selector = #setUp. self assert: change source = 'setUp'. self assert: change protocol = #accessing. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 09:12'! testRenameClass | change | change := changes renameClass: self class to: self class name , 'Plus'. self assert: change oldName = self class name. self assert: change newName = (self class name , 'Plus'). self assert: change changeClass = self class. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 09:10'! testRemoveInstanceVariable | change | change := changes removeInstanceVariable: 'instVar' from: self class. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change variable = 'instVar'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'mocking' stamp: 'MarcusDenker 6/17/2013 15:05'! createMockClass self class compiler evaluate: 'Object subclass: #RBRefactoringChangeMock instanceVariableNames: ''instVar'' classVariableNames: ''ClassVar'' poolDictionaries: '''' category: ''Refactoring-Tests-Changes'''. self class compiler evaluate: 'RBRefactoringChangeMock class instanceVariableNames: ''classInstVar'''. self changeMock compile: 'one ^ 1' classified: 'accessing'.! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:20'! testPerformAddRemoveClassVariable | change | change := changes addClassVariable: 'Foo' to: self changeMock. self perform: change do: [ self assert: (change changeClass classVarNames includes: 'Foo') ]. self deny: (change changeClass classVarNames includes: 'Foo')! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:24'! testPerformAddRemoveClass | change | change := changes defineClass: 'Object subclass: #' , self changeMock name , 'Temporary instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''' , self class category , ''''. self perform: change do: [ self assert: (Smalltalk hasClassNamed: change changeClassName). self assert: change definedClass name = change changeClassName. self assert: change definedClass isBehavior ]. self deny: (Smalltalk hasClassNamed: change changeClassName). self assert: change definedClass isObsolete! ! !RBRefactoringChangeTests methodsFor: 'accessing' stamp: 'CamilloBruni 8/27/2013 02:41'! exampleClasses ^ { "Standard Classes" ProtoObject. Object. Class. Metaclass. Behavior. ClassDescription. Dictionary. Trait. "Lots of class vars" SmalltalkImage "" }! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 08:29'! testAddClassVariable | change | change := changes addClassVariable: 'ClassVar' to: self class. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change variable = 'ClassVar'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:34'! testPerformCompositeChange changes compile: 'method1 ^ 1' in: self changeMock; compile: 'method2 ^ 2' in: self changeMock. self perform: changes do: [ self assert: (self changeMock canUnderstand: #method1). self assert: (self changeMock canUnderstand: #method2) ]. self deny: (self changeMock canUnderstand: #method1). self deny: (self changeMock canUnderstand: #method2) ! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 09:09'! testRemoveClass | change | change := changes removeClass: self class. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'utilities' stamp: 'lr 9/8/2011 20:10'! universalTestFor: aChange self equalityTestFor: aChange. self stringTestFor: aChange. (aChange isKindOf: RBRefactoryClassChange) ifTrue: [ self undoTestFor: aChange ]! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 09:11'! testRemoveMethod | change | change := changes removeMethod: #setUp from: self class. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change selector = #setUp. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 9/5/2010 20:02'! testRenameInstanceVariable | change | change := changes renameInstanceVariable: 'instVar1' to: 'instVar2' in: self class. self assert: change changeClassName = self class name. self assert: change oldName = 'instVar1'. self assert: change newName = 'instVar2'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 08:33'! testCompileInMetaclass | change | change := changes compile: 'new' in: self class class. self assert: change controller isNil. self assert: change changeClassName = self class name. self assert: change changeClass = self class class. self assert: change isMeta. self assert: change selector = #new. self assert: change source = 'new'. self assert: change protocol = #accessing. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 08:30'! testAddPool | change | change := changes addPool: 'PoolDict' to: self class. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change variable = 'PoolDict'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:28'! testPerformAddRemoveClassMethod | change source | change := changes compile: 'method ^ 1' in: self changeMock class classified: #utilities. self perform: change do: [ self assert: (self changeMock respondsTo: #method) ]. self deny: (self changeMock respondsTo: #method). self assert: change definedSelector = #method! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 08:28'! testAddInstanceVariable | change | change := changes addInstanceVariable: 'instVar' to: self class. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change variable = 'instVar'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'utilities' stamp: 'lr 10/15/2010 09:13'! equalityTestFor: aChange self assert: aChange = aChange. self assert: aChange hash = aChange hash. self assert: aChange copy = aChange. self assert: aChange copy hash = aChange hash! ! !RBRefactoringChangeTests methodsFor: 'tests-pattern' stamp: 'CamilloBruni 8/27/2013 02:42'! testAddTraitPattern "Make sure that all trait definitions can be parsed." self exampleTraits do: [ :trait | | change | change := changes defineClass: trait definition. self assert: (change isKindOf: RBAddTraitChange). self assert: (change changeClassName = trait name). self assert: (change category = trait category). self universalTestFor: change ]! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 9/8/2011 20:10'! testPerformAddRemoveClassInteractively | change | change := RBAddClassChange definition: 'Object subclass: #' , self changeMock name , 'Temporary instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''' , self class category , '''' for: self. self perform: change do: [ self assert: (Smalltalk hasClassNamed: change changeClassName). self assert: change definedClass name = change changeClassName. self assert: change definedClass isBehavior ]. self deny: (Smalltalk hasClassNamed: change changeClassName). self assert: change definedClass isObsolete ! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:31'! testPerformChangeMetaclass | change | change := changes defineClass: self changeMock name , ' class instanceVariableNames: '''''. self perform: change do: [ self assert: change changeClass class instVarNames isEmpty ]. self assert: change changeClass class instVarNames notEmpty. self assert: change definedClass = self changeMock class! ! !RBRefactoringChangeTests methodsFor: 'tests-pattern' stamp: 'CamilloBruni 8/27/2013 02:41'! testAddClassTraitPattern "Make sure that all class trait definitions can be parsed." self exampleTraits do: [ :trait | | change | change := changes defineClass: trait classTrait definition. self assert: (change isKindOf: RBAddClassTraitChange). self assert: (change changeClassName = trait name). self universalTestFor: change ]! ! !RBRefactoringChangeTests methodsFor: 'mocking' stamp: 'MarcusDenker 6/17/2013 14:53'! changeMock ^ Smalltalk at: #RBRefactoringChangeMock! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 9/5/2010 20:02'! testRenameClassVariable | change | change := changes renameClassVariable: 'ClassVar1' to: 'ClassVar2' in: self class. self assert: change changeClassName = self class name. self assert: change oldName = 'ClassVar1'. self assert: change newName = 'ClassVar2'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'utilities' stamp: 'CamilloBruni 9/11/2012 16:40'! perform: aChange do: aBlock "Perform a change in the system silently, evaluate aBlock and then undo the change again." | undo | ^ SystemAnnouncer uniqueInstance suspendAllWhile: [ undo := aChange execute. aBlock ensure: [ undo execute ] ]! ! !RBRefactoringChangeTests methodsFor: 'tests-pattern' stamp: 'CamilloBruni 8/27/2013 02:41'! testAddMetaclassPattern "Make sure that metaclass definitions can be parsed." self exampleClasses do: [ :class | (class isObsolete or: [ class superclass notNil and: [ class superclass isObsolete ] ]) ifFalse: [ | change | change := changes defineClass: class class definition. self assert: (change isKindOf: RBAddMetaclassChange). self assert: change changeClassName equals: class name. self assert: change classInstanceVariableNames equals: class class instVarNames. self universalTestFor: change ]]! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:36'! testPerformRenameClassInstanceVariable | change | change := changes renameInstanceVariable: 'classInstVar' to: 'classInstVarPlus' in: self changeMock class. self perform: change do: [ self deny: (change changeClass instVarNames includes: change oldName). self assert: (change changeClass instVarNames includes: change newName) ]. self assert: (change changeClass instVarNames includes: change oldName). self deny: (change changeClass instVarNames includes: change newName)! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 9/6/2010 11:31'! testComposite changes compile: 'method ^ 1' in: self class classified: #utilities; compile: 'method ^ 2' in: self class class classified: #utilities. self assert: (changes changesSize = 2). self assert: (changes problemCount = 2). self assert: (changes changeForClass: self class name selector: #method) notNil. self assert: (changes changeForMetaclass: self class name selector: #method) notNil. self universalTestFor: changes! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 09:10'! testRemoveClassVariable | change | change := changes removeClassVariable: 'ClassVar' from: self class. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change variable = 'ClassVar'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:30'! testPerformChangeClass | change | change := changes defineClass: self class name , ' subclass: #' , self changeMock name , ' instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''' , self class category , ''''. self perform: change do: [ self assert: change changeClass superclass = self class. self assert: change changeClass instVarNames isEmpty ]. self assert: change changeClass superclass = Object. self assert: change changeClass instVarNames notEmpty. self assert: change definedClass = self changeMock! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 09:11'! testRemoveClassInstanceVariable | change | change := changes removeInstanceVariable: 'instVar' from: self class class. self assert: change changeClassName = self class name. self assert: change changeClass = self class class. self assert: change isMeta. self assert: change variable = 'instVar'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 9/8/2011 20:10'! testCompileInInteractively | change | change := RBAddMethodChange compile: 'setUp' in: self class classified: #running for: self. self assert: change controller = self. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change selector = #setUp. self assert: change source = 'setUp'. self assert: change protocol = #running. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'mocking' stamp: 'MarcusDenker 6/17/2013 15:24'! text "for #testPerformAddRemoveMethodInteractively" ^'method ^1'! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:34'! testPerformRenameClass | change | change := changes renameClass: self changeMock to: self changeMock name , 'Plus'. self perform: change do: [ self deny: (Smalltalk hasClassNamed: change oldName). self assert: (Smalltalk hasClassNamed: change newName) ]. self assert: (Smalltalk hasClassNamed: change oldName). self deny: (Smalltalk hasClassNamed: change newName)! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 08:28'! testAddClassInstanceVariable | change | change := changes addInstanceVariable: 'instVar' to: self class class. self assert: change changeClassName = self class name. self assert: change changeClass = self class class. self assert: change isMeta. self assert: change variable = 'instVar'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 09:11'! testRemovePool | change | change := changes removePool: 'PoolDict' from: self class. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change variable = 'PoolDict'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:28'! testPerformAddRemoveInstanceVariable | change | change := changes addInstanceVariable: 'foo' to: self changeMock. self perform: change do: [ self assert: (change changeClass instVarNames includes: 'foo') ]. self deny: (change changeClass instVarNames includes: 'foo')! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'MartinDias 11/7/2013 18:11'! testAddClassInteractively | change | change := RBAddClassChange definition: 'TestCase subclass: #' , self class name , ' instanceVariableNames: ''instVar'' classVariableNames: ''ClassVar'' poolDictionaries: ''PoolDict'' category: ''' , self class category , '''' for: self. self assert: change controller = self. self assert: change superclassName = self class superclass name. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change instanceVariableNames size = 1. self assert: change instanceVariableNames first = 'instVar'. self assert: change classVariableNames size = 1. self assert: change classVariableNames first = 'ClassVar'. self assert: change sharedPoolNames size = 1. self assert: change sharedPoolNames first = 'PoolDict'. self assert: change category = self class category. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests-pattern' stamp: 'MartinDias 11/7/2013 18:11'! testAddClassPattern "Make sure that all class definitions can be parsed." self exampleClasses do: [ :class | (class isObsolete or: [ class superclass notNil and: [ class superclass isObsolete ] ]) ifFalse: [ | change | change := changes defineClass: class definition. self assert: (change isKindOf: RBAddClassChange). self assert: (change changeClassName = class name). self assert: (class superclass isNil ifTrue: [ change definitionClass = ProtoObject ] ifFalse: [ change definitionClass = class superclass ]). self assert: (change instanceVariableNames = class instVarNames asArray). self assert: (change classVariableNames = class classVarNames asArray). self assert: (change sharedPoolNames = class sharedPoolNames asArray). self assert: (change category = class category). self universalTestFor: change ] ]! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:18'! testPerformAddRemoveClassInstanceVariable | change | change := changes addInstanceVariable: 'foo' to: self changeMock class. self perform: change do: [ self assert: (change changeClass instVarNames includes: 'foo') ]. self deny: (change changeClass instVarNames includes: 'foo')! ! !RBRefactoringChangeTests methodsFor: 'utilities' stamp: 'lr 9/8/2011 20:10'! undoTestFor: aChange | undo | undo := aChange asUndoOperation. self assert: (undo isKindOf: RBRefactoryChange)! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:28'! testPerformAddRemoveMethod | change source | change := changes compile: 'method ^ 1' in: self changeMock classified: #utilities. self perform: change do: [ self assert: (self changeMock canUnderstand: #method) ]. self deny: (self changeMock canUnderstand: #method). self assert: change definedSelector = #method! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 08:33'! testCompileInClass | change | change := changes compile: 'setUp' in: self class. self assert: change controller isNil. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change selector = #setUp. self assert: change source = 'setUp'. self assert: change protocol = #running. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 09:10'! testRemoveClassNamed | change | change := changes removeClassNamed: self class name. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'running' stamp: 'MarcusDenker 6/17/2013 15:02'! tearDown super tearDown. self removeMockClass. ! ! !RBRefactoringChangeTests methodsFor: 'mocking' stamp: 'lr 9/6/2010 13:38'! selectionInterval ^ 1 to: 0! ! !RBRefactoringChangeTests methodsFor: 'running' stamp: 'MarcusDenker 6/17/2013 14:53'! setUp super setUp. self createMockClass. changes := RBCompositeRefactoryChange named: 'testing'! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:35'! testPerformRenameInstanceVariable | change | change := changes renameInstanceVariable: 'instVar' to: 'instVarPlus' in: self changeMock. self perform: change do: [ self deny: (change changeClass instVarNames includes: change oldName). self assert: (change changeClass instVarNames includes: change newName) ]. self assert: (change changeClass instVarNames includes: change oldName). self deny: (change changeClass instVarNames includes: change newName)! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 9/8/2011 20:10'! testPerformAddRemoveMethodInteractively | change source | change := RBAddMethodChange compile: 'method ^ 1' in: self changeMock classified: #utilities for: self. self perform: change do: [ self assert: (self changeMock canUnderstand: #method) ]. self deny: (self changeMock canUnderstand: #method). self assert: change definedSelector = #method! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 08:32'! testComment | change | change := changes comment: 'Some Comment' in: self class. self assert: change changeClassName = self class name. self assert: change changeClass = self class. self assert: change isMeta not. self assert: change comment = 'Some Comment'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests' stamp: 'lr 10/15/2010 09:12'! testRenameClassInstanceVariable | change | change := changes renameInstanceVariable: 'instVar1' to: 'instVar2' in: self class class. self assert: change changeClassName = self class name. self assert: change oldName = 'instVar1'. self assert: change newName = 'instVar2'. self universalTestFor: change! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:33'! testPerformChangeMethod | change source | change := changes compile: 'one ^ 2' in: self changeMock. source := change changeClass sourceCodeAt: #one. self perform: change do: [ self assert: (change changeClass sourceCodeAt: #one) = 'one ^ 2' ]. self assert: (change changeClass sourceCodeAt: #one) = source! ! !RBRefactoringChangeTests methodsFor: 'utilities' stamp: 'lr 9/5/2010 20:07'! stringTestFor: aChange self assert: (aChange name isString and: [ aChange name notEmpty ]). self assert: (aChange printString isString and: [ aChange printString notEmpty ]). self assert: (aChange changeString isString and: [ aChange changeString notEmpty ]). self assert: (aChange displayString isString and: [ aChange displayString notEmpty ])! ! !RBRefactoringChangeTests methodsFor: 'accessing' stamp: 'CamilloBruni 8/27/2013 02:43'! exampleTraits ^ { TBehavior. TClass. TAssertable }! ! !RBRefactoringChangeTests methodsFor: 'mocking' stamp: 'MarcusDenker 6/17/2013 14:56'! removeMockClass Smalltalk removeClassNamed: #RBRefactoringChangeMock.! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:32'! testPerformChangeComment | change comment | change := changes comment: 'Some Comment' in: self changeMock. comment := change changeClass organization classComment. self perform: change do: [ self assert: (change changeClass comment = 'Some Comment') ]. self assert: change changeClass organization classComment = comment! ! !RBRefactoringChangeTests methodsFor: 'tests-perform' stamp: 'lr 10/15/2010 09:35'! testPerformRenameClassVariable | change | change := changes renameClassVariable: 'ClassVar' to: 'ClassVarPlus' in: self changeMock. self perform: change do: [ self deny: (change changeClass classVarNames includes: change oldName). self assert: (change changeClass classVarNames includes: change newName) ]. self assert: (change changeClass classVarNames includes: change oldName). self deny: (change changeClass classVarNames includes: change newName)! ! !RBRefactoringChangeTests class methodsFor: 'accessing' stamp: 'lr 9/5/2010 19:39'! packageNamesUnderTest ^ #('Refactoring-Changes')! ! !RBRefactoringError commentStamp: 'lr 10/5/2010 16:17'! The receiver is signaled whenever a precondition of a refactoring is violated. The action block, if defined, might help the user to resolve the issue.! !RBRefactoringError methodsFor: 'accessing' stamp: 'lr 10/5/2010 16:07'! actionBlock ^ actionBlock ! ! !RBRefactoringError methodsFor: 'accessing' stamp: 'lr 10/5/2010 16:07'! actionBlock: aBlock actionBlock := aBlock! ! !RBRefactoringError methodsFor: 'testing' stamp: 'CamilloBruni 10/7/2012 23:11'! isResumable ^ true! ! !RBRefactoringError class methodsFor: 'signalling' stamp: 'lr 10/5/2010 16:07'! signal: aString with: aBlock ^ self new actionBlock: aBlock; signal: aString! ! !RBRefactoringFailure commentStamp: ''! This error is signalled whenever there is a non recoverable error during refactorings.! !RBRefactoringFailure methodsFor: 'testing' stamp: 'CamilloBruni 10/7/2012 23:53'! isResumable ^ false! ! !RBRefactoringManager methodsFor: 'public access' stamp: 'lr 9/8/2011 20:10'! addRefactoring: aRefactoring RBRefactoryChangeManager instance performChange: aRefactoring changes. refactorings add: aRefactoring class name! ! !RBRefactoringManager methodsFor: 'initialization' stamp: ''! initialize refactorings := Bag new! ! !RBRefactoringManager methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: '# Refactoring'; cr; nextPutAll: '--- -----------------------------------------------'; cr. refactorings asSet asSortedCollection do: [:name | aStream nextPutAll: (refactorings occurrencesOf: name) printString; nextPutAll: ' '; nextPutAll: name; cr]! ! !RBRefactoringManager class methodsFor: 'public' stamp: 'lr 4/4/2010 08:32'! unload self nuke! ! !RBRefactoringManager class methodsFor: 'instance creation' stamp: 'lr 4/4/2010 08:31'! instance ^ Instance ifNil: [ Instance := self basicNew initialize ]! ! !RBRefactoringManager class methodsFor: 'instance creation' stamp: 'lr 4/4/2010 08:31'! new ^ self shouldNotImplement! ! !RBRefactoringManager class methodsFor: 'public' stamp: 'lr 4/4/2010 08:32'! nuke Instance notNil ifTrue: [ Instance release ]. Instance := nil! ! !RBRefactoringTest methodsFor: 'set up' stamp: ''! setupMethodNameFor: aRefactoring toReturn: aSelector withArguments: stringCollection | options | options := aRefactoring options copy. options at: #methodName put: [:ref :aMethodName | aMethodName selector: aSelector; arguments: stringCollection; yourself]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'set up' stamp: 'lr 9/8/2011 20:14'! tearDown super tearDown. RBRefactoringManager instance release. (RBRefactoringManager classPool associationAt: #Instance ifAbsent: [RBRefactoringManager classPool associationAt: 'Instance']) value: manager! ! !RBRefactoringTest methodsFor: 'set up' stamp: ''! setupVariableToMoveToFor: aRefactoring toReturn: aString | options | options := aRefactoring options copy. options at: #selectVariableToMoveTo put: [:ref :class :selector | aString]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'set up' stamp: ''! setupImplementorToInlineFor: aRefactoring toReturn: anObject | options | options := aRefactoring options copy. options at: #implementorToInline put: [:ref :imps | anObject]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'set up' stamp: ''! setupVariableTypesFor: aRefactoring toReturn: anObject | options | options := aRefactoring options copy. options at: #variableTypes put: [:ref :ignore1 :ignore2 | anObject]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:14'! testPrintRefactoringManager self assert: RBRefactoringManager instance printString isString! ! !RBRefactoringTest methodsFor: 'private' stamp: 'StephaneDucasse 8/27/2013 21:56'! abstractVariableTestData | newModel classEnvironment classes | classes := #(#Bar #Foo) inject: OrderedCollection new into: [ :sum :each | Smalltalk globals at: each ifPresent: [ :class | sum add: class; add: class class ]. sum ]. classEnvironment := RBClassEnvironment classes: classes. newModel := RBNamespace onEnvironment: classEnvironment not. newModel name: 'Test'. #('Object subclass: #Foo instanceVariableNames: ''instVarName1 instVarName2'' classVariableNames: ''ClassVarName1 ClassVarName2 '' poolDictionaries: '''' category: ''Testing'' ' 'Foo subclass: #Bar instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''Testing'' ' ) do: [ :each | newModel defineClass: each ]. #(#(#Bar #( #('instVarName1 ^1242321' #tests) #('foo instVarName1 := instVarName1 + instVarName2 + ClassVarName1' #tests))) #(#Foo #( #('foo ^instVarName2 := 3' #tests) #('bar "Add one to instVarName1" instVarName1 := instVarName1 + 1' #tests) #('classVarName1 ^ClassVarName1' #tests) #('instVarName1: anObject ^anObject' #tests) #('asdf ^self classVarName1: (ClassVarName1 := ClassVarName1 + 1)' #tests) #('instVarName2 ^instVarName2' #tests) #('instVarName2: anObject instVarName2 := anObject' #tests) #('classVarName1: anObject ^ClassVarName1 := anObject' #tests))) #('Bar class' #( #('classVarName2: anObject ClassVarName2 := anObject' #tests) #('classVarName2 ^ClassVarName2' #tests))) #('Foo class' #( #('foo ^ClassVarName1 := ClassVarName1 * ClassVarName1 * ClassVarName1' #tests)))) do: [:each | | class | class := newModel classNamed: each first. each last do: [ :methodPair | class compile: methodPair first classified: methodPair last]]. ^ newModel! ! !RBRefactoringTest methodsFor: 'private' stamp: 'lr 9/8/2011 20:58'! childrenToSiblingTestData ^' | m | (m:= RBNamespace onEnvironment: ((RBClassEnvironment onEnvironment: RBBrowserEnvironment new) classes: (#(#ConcreteSubclass #ConcreteSuperclass #NoMoveSubclass) inject: OrderedCollection new into: [:sum :each | | class | class := Smalltalk at: each ifAbsent: [nil]. class notNil ifTrue: [sum add: class]. sum]) , (#(#ConcreteSubclass #ConcreteSuperclass #NoMoveSubclass) inject: OrderedCollection new into: [:sum :each | | class | class := Smalltalk at: each ifAbsent: [nil]. class notNil ifTrue: [sum add: class class]. sum])) not) name: ''Test''. #(''ConcreteSuperclass subclass: #NoMoveSubclass instanceVariableNames: '''''''' classVariableNames: '''''''' poolDictionaries: '''''''' category: ''''Testing'''''' ''Object subclass: #ConcreteSuperclass instanceVariableNames: ''''instVarName1 instVarName2 '''' classVariableNames: ''''ClassVarName1 ClassVarName2 '''' poolDictionaries: '''''''' category: ''''Testing'''''' ''ConcreteSuperclass subclass: #ConcreteSubclass instanceVariableNames: '''''''' classVariableNames: '''''''' poolDictionaries: '''''''' category: ''''Testing'''''') do: [:each | m defineClass: each]. (m metaclassNamed: #ConcreteSuperclass) addInstanceVariable: ''classInstVarName1''. #(#(#ConcreteSubclass #(#(''initialize super initialize. instVarName1 := nil'' #everyone) #(''different ^0'' #everyone))) #(#ConcreteSuperclass #(#(''same ^self initialize isKindOf: ConcreteSuperclass'' #''one def'') #(''different ^instVarName1 + instVarName2'' #everyone) #(''initialize instVarName1 := instVarName2 := ClassVarName1 := ClassVarName2 := 0'' #everyone))) #(#NoMoveSubclass #(#(''same ^123'' #''one def''))) #(''ConcreteSubclass class'' #(#(''bar ^self storeString'' #testing))) #(''ConcreteSuperclass class'' #(#(''foo ^classInstVarName1 + ClassVarName1 + ClassVarName2'' #testing) #(''new ^super new initialize'' #testing) #(''bar ^self printString'' #testing))) #(''NoMoveSubclass class'' #())) do: [:each | | class | class := m classNamed: each first. each last do: [:meth | class compile: meth first classified: meth last]]. m '! ! !RBRefactoringTest methodsFor: 'private' stamp: 'lr 9/8/2011 21:02'! inlineMethodTestData ^ ' | m | (m := RBNamespace onEnvironment: ((RBClassEnvironment onEnvironment: RBBrowserEnvironment new) classes: (#(#RBRenameClassVariableChange #RBVariableCompositeRefactoryChange #RBRenameInstanceVariableChange #RBCompositeRefactoryChange #RBRenameVariableChange #RBRefactoryChange) inject: OrderedCollection new into: [:sum :each | | class | class := Smalltalk at: each ifAbsent: [nil]. class notNil ifTrue: [sum add: class]. sum]) , (#() inject: OrderedCollection new into: [:sum :each | | class | class := Smalltalk at: each ifAbsent: [nil]. class notNil ifTrue: [sum add: class class]. sum])) not) name: ''Test''. #(''Object subclass: #RBRefactoryChange instanceVariableNames: ''''name '''' classVariableNames: '''''''' poolDictionaries: '''''''' category: ''''Refactory-Support'''''' ''RBRefactoryChange subclass: #RBCompositeRefactoryChange instanceVariableNames: ''''changes '''' classVariableNames: '''''''' poolDictionaries: '''''''' category: ''''Refactory-Support'''''' ''RBCompositeRefactoryChange subclass: #RBVariableCompositeRefactoryChange instanceVariableNames: ''''className isMeta '''' classVariableNames: '''''''' poolDictionaries: '''''''' category: ''''Refactory-Support'''''' ''RBVariableCompositeRefactoryChange subclass: #RBRenameVariableChange instanceVariableNames: ''''oldName newName '''' classVariableNames: '''''''' poolDictionaries: '''''''' category: ''''Refactory-Support'''''' ''RBRenameVariableChange subclass: #RBRenameClassVariableChange instanceVariableNames: '''''''' classVariableNames: '''''''' poolDictionaries: '''''''' category: ''''Refactory-Support'''''' ''RBRenameVariableChange subclass: #RBRenameInstanceVariableChange instanceVariableNames: '''''''' classVariableNames: '''''''' poolDictionaries: '''''''' category: ''''Refactory-Support'''''') do: [:each | m defineClass: each]. #(#(#RBRenameClassVariableChange #(#(''removeOldVariable (RBRemoveClassVariableChange remove: oldName from: self changeClass) execute'' #private) #(''addNewVariable (RBAddClassVariableChange add: newName to: self changeClass) execute'' #private) #(''executeNotifying: aBlock | undo | self addNewVariable. self copyOldValuesToNewVariable. undo := super executeNotifying: aBlock. self removeOldVariable. ^undo'' #private) #(''copyOldValuesToNewVariable | oldValue | oldValue := self changeClass classPool at: oldName ifAbsent: []. self changeClass at: newName asSymbol put: oldValue'' #private))) #(#RBVariableCompositeRefactoryChange #(#(''displayClassName ^isMeta ifTrue: [self changeClassName , '''' class''''] ifFalse: [self changeClassName asString]'' #printing) #(''isMeta ^isMeta'' #private) #(''changeClass: aBehavior isMeta := aBehavior isMeta. className := isMeta ifTrue: [aBehavior soleInstance name] ifFalse: [aBehavior name]'' #accessing) #(''hash ^self changeClassName hash'' #comparing) #(''changeClassName: aSymbol className := aSymbol. isMeta isNil ifTrue: [isMeta := false]'' #accessing) #(''changeClass | class | class := Smalltalk at: self changeClassName ifAbsent: [^nil]. ^isMeta ifTrue: [class class] ifFalse: [class]'' #accessing) #(''printOn: aStream aStream nextPutAll: self displayString'' #printing) #(''changeClassName ^className'' #accessing) #(''= aRefactoryClassChange self class = aRefactoryClassChange class ifFalse: [^false]. ^className = aRefactoryClassChange changeClassName and: [isMeta = aRefactoryClassChange isMeta]'' #comparing))) #(#RBRenameInstanceVariableChange #(#(''removeOldVariable (RBRemoveInstanceVariableChange remove: oldName from: self changeClass) execute'' #private) #(''addNewVariable (RBAddInstanceVariableChange add: newName to: self changeClass) execute'' #private) #(''executeNotifying: aBlock | undo | self addNewVariable. self copyOldValuesToNewVariable. undo := super executeNotifying: aBlock. self removeOldVariable. ^undo'' #private) #(''copyOldValuesToNewVariable | newIndex oldIndex | oldIndex := self changeClass allInstVarNames indexOf: oldName asString. newIndex := self changeClass allInstVarNames indexOf: newName asString. self changeClass withAllSubclasses do: [:each | each allInstances do: [:inst | each instVarAt: newIndex put: (each instVarAt: oldIndex)]]'' #private))) #(#RBCompositeRefactoryChange #(#(''compile: source in: class ^self addChange: (RBAddMethodChange compile: source in: class)'' #''refactory-changes'') #(''addClassVariable: variableName to: aClass ^self addChange: (RBAddClassVariableChange add: variableName to: aClass)'' #''refactory-changes'') #(''addChangeFirst: aRefactoryChange changes addFirst: aRefactoryChange. ^aRefactoryChange'' #accessing) #(''removeChange: aChange changes remove: aChange ifAbsent: []'' #''private-inspector accessing'') #(''addPool: aPoolVariable to: aClass ^self addChange: (RBAddPoolVariableChange add: aPoolVariable to: aClass)'' #''refactory-changes'') #(''initialize super initialize. changes := OrderedCollection new'' #''initialize-release'') #(''defineClass: aString ^self addChange: (RBAddClassChange definition: aString)'' #''refactory-changes'') #(''changeForClass: aRBClass selector: aSelector changes reverseDo: [:each | | change | change := each changeForClass: aRBClass selector: aSelector. change notNil ifTrue: [^change]]. ^nil'' #accessing) #(''removeInstanceVariable: variableName from: aClass ^self addChange: (RBRemoveInstanceVariableChange remove: variableName from: aClass)'' #''refactory-changes'') #(''printOn: aStream aStream nextPutAll: name'' #printing) #(''inspect RefactoryBuilderInspector openOn: self'' #''user interface'') #(''flattenOnto: aCollection changes do: [:each | each flattenOnto: aCollection]'' #private) #(''hash ^changes size'' #comparing) #(''= aRefactoryBuilder self class = aRefactoryBuilder class ifFalse: [^false]. changes size = aRefactoryBuilder changes size ifFalse: [^false]. changes with: aRefactoryBuilder changes do: [:each :change | each = change ifFalse: [^false]]. ^true'' #comparing) #(''renameClass: class to: newName ^self addChange: (RenameClassChange rename: class name to: newName)'' #''refactory-changes'') #(''renameChangesForClass: aClassName to: newClassName ^(self copy) changes: (self changes collect: [:each | each renameChangesForClass: aClassName to: newClassName]); yourself'' #accessing) #(''postCopy super postCopy. changes := changes collect: [:each | each copy]'' #copying) #(''changes: aCollection changes := aCollection'' #''private-inspector accessing'') #(''addInstanceVariable: variableName to: aClass ^self addChange: (RBAddInstanceVariableChange add: variableName to: aClass)'' #''refactory-changes'') #(''compile: source in: class classified: aProtocol ^self addChange: (RBAddMethodChange compile: source in: class classified: aProtocol)'' #''refactory-changes'') #(''changeForMetaclass: aSymbol selector: aSelector changes reverseDo: [:each | | change | change := each changeForMetaclass: aSymbol selector: aSelector. change notNil ifTrue: [^change]]. ^nil'' #accessing) #(''removeClassVariable: variableName from: aClass ^self addChange: (RBRemoveClassVariableChange remove: variableName from: aClass)'' #''refactory-changes'') #(''executeNotifying: aBlock | undos undo | undos := changes collect: [:each | each executeNotifying: aBlock]. undo := self copy. undo changes: undos reverse. ^undo'' #private) #(''changes ^changes'' #''private-inspector accessing'') #(''removeMethod: aSelector from: aClass ^self addChange: (RBRemoveMethodChange remove: aSelector from: aClass)'' #''refactory-changes'') #(''removeClass: aClass ^self addChange: (RBRemoveClassChange removeClassName: aClass)'' #''refactory-changes'') #(''addChange: aRefactoryChange changes add: aRefactoryChange. ^aRefactoryChange'' #accessing) #(''changesSize ^changes inject: 0 into: [:sum :each | sum + each changesSize]'' #accessing) #(''displayString ^super displayString asText allBold'' #printing) #(''problemCount ^self changesSize'' #accessing))) #(#RBRenameVariableChange #(#(''oldName: aString oldName := aString'' #private) #(''executeNotifying: aBlock | undo | undo := super executeNotifying: aBlock. undo oldName: newName; newName: oldName. ^undo'' #private) #(''newName: aString newName := aString'' #private) #(''changeString ^''''Rename '''' , oldName , '''' to '''' , newName'' #printing))) #(#RBRefactoryChange #(#(''flattenedChanges | changes | changes := OrderedCollection new. self flattenOnto: changes. ^changes'' #private) #(''name: aString name := aString'' #''initialize-release'') #(''initialize'' #''initialize-release'') #(''changeForMetaclass: aSymbol selector: aSelector ^nil'' #accessing) #(''changeString ^self class name'' #printing) #(''changeForClass: aRBClass selector: aSelector ^nil'' #accessing) #(''executeWithMessage: aString | tally controller m done | m := 0 asValue. done := 0. tally := self changesSize. controller := aString isNil ifTrue: [nil] ifFalse: [ProgressWidgetView progressOpenOn: m label: aString]. m value: 0. ^ [self executeNotifying: [done := done + 1. m value: done asFloat / tally]] ensure: [controller notNil ifTrue: [controller closeAndUnschedule]]'' #''performing-changes'') #(''executeNotifying: aBlock self subclassResponsibility'' #private) #(''changes ^Array with: self'' #accessing) #(''execute ^self executeNotifying: []'' #''performing-changes'') #(''inspect ^((RBCompositeRefactoryChange new) changes: (Array with: self); yourself) inspect'' #''user interface'') #(''flattenOnto: aCollection aCollection add: self'' #private) #(''name ^name isNil ifTrue: [self changeString] ifFalse: [name]'' #accessing) #(''changesSize ^1'' #accessing) #(''displayString ^name isNil ifTrue: [self changeString] ifFalse: [name]'' #printing) #(''renameChangesForClass: aClassName to: newClassName "We are in the middle of performing a rename operation. If we stored the class name, we need to change the class name to the new name to perform the compiles." self subclassResponsibility'' #accessing)))) do: [:each | | class | class := m classNamed: each first. each last do: [:meth | class compile: meth first classified: meth last]]. m '! ! !RBRefactoringTest methodsFor: 'set up' stamp: 'lr 9/8/2011 20:14'! setUp | assoc | super setUp. assoc := RBRefactoringManager classPool associationAt: #Instance ifAbsent: [RBRefactoringManager classPool associationAt: 'Instance']. manager := assoc value. assoc value: nil. model := RBNamespace new! ! !RBRefactoringTest methodsFor: 'private' stamp: 'lr 10/5/2010 16:13'! shouldWarn: aRefactoring self should: [ self executeRefactoring: aRefactoring ] raise: RBRefactoringWarning! ! !RBRefactoringTest methodsFor: 'set up' stamp: ''! setupInlineExpressionFor: aRefactoring toReturn: aBoolean | options | options := aRefactoring options copy. options at: #inlineExpression put: [:ref :string | aBoolean]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'set up' stamp: ''! setupSelfArgumentNameFor: aRefactoring toReturn: aString | options | options := aRefactoring options copy. options at: #selfArgumentName put: [:ref | aString]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'set up' stamp: ''! setupMethodNameFor: aRefactoring toReturn: aSelector | options | options := aRefactoring options copy. options at: #methodName put: [:ref :aMethodName | aMethodName selector: aSelector; yourself]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'tests' stamp: 'bh 4/2/2000 22:28'! testConditions | condition newCondition | condition := RBCondition new type: #false block: [false] errorString: 'false'. condition errorMacro: '<1?true:false>'. self deny: condition check. self assert: condition errorString = 'false'. self assert: condition not check. self assert: condition printString = 'false'. self assert: condition not printString = 'NOT false'. self deny: (condition not & condition) check. self assert: (condition not & condition) printString = 'NOT false & false'. self assert: (condition & condition) not check. self assert: (condition | condition not) check. self deny: (newCondition := condition | condition) check. self assert: newCondition errorString = 'false AND false'. self assert: (condition not | condition not) check. self deny: (newCondition := condition & condition) check. self assert: newCondition errorString = 'false'. self assert: (condition not & condition not) check. self assert: (condition & condition) errorString = 'false OR false'! ! !RBRefactoringTest methodsFor: 'private' stamp: 'lr 10/5/2010 16:13'! shouldFail: aRefactoring self proceedThroughWarning: [ self should: [ self executeRefactoring: aRefactoring ] raise: RBRefactoringError ]! ! !RBRefactoringWarning commentStamp: 'lr 10/5/2010 16:17'! The receiver is a warning that usually requires the user to validate. This is used in situations where either the behavior of the program will not be strictly preserved or the change may have a wider impact than the user may think. ! !RBRefactoryChange commentStamp: ''! I am the superclass of all refactoring change objects. All I have is a name for the refactoring, but I can perform one or more refactoring operations with the message #execute. I am a composite object. To know about my components, ask me with #changes and #changesSize. ! !RBRefactoryChange methodsFor: 'accessing' stamp: ''! changes ^Array with: self! ! !RBRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 11:29'! changeForMetaclass: aClassName selector: aSelector ^ nil! ! !RBRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 11:29'! changeForClass: aClassName selector: aSelector ^ nil! ! !RBRefactoryChange methodsFor: 'private' stamp: ''! executeNotifying: aBlock self subclassResponsibility! ! !RBRefactoryChange methodsFor: 'printing' stamp: ''! displayString ^name isNil ifTrue: [self changeString] ifFalse: [name]! ! !RBRefactoryChange methodsFor: 'accessing' stamp: ''! changesSize ^1! ! !RBRefactoryChange methodsFor: 'printing' stamp: ''! changeString ^self class name! ! !RBRefactoryChange methodsFor: '*NautilusRefactoring' stamp: ''! accept: aText notifying: aController ^ false! ! !RBRefactoryChange methodsFor: '*NautilusRefactoring' stamp: ''! nameToDisplay ^ self name! ! !RBRefactoryChange methodsFor: 'initialize-release' stamp: ''! name: aString name := aString! ! !RBRefactoryChange methodsFor: 'accessing' stamp: 'StephaneDucasse 9/13/2013 21:43'! changeStamp ^ Author changeStamp! ! !RBRefactoryChange methodsFor: '*NautilusRefactoring' stamp: ''! oldVersionTextToDisplay ^ ''! ! !RBRefactoryChange methodsFor: 'performing-changes' stamp: ''! execute ^self executeNotifying: []! ! !RBRefactoryChange methodsFor: '*NautilusRefactoring' stamp: ''! whatToDisplayIn: aChangeBrowser ^ { self }! ! !RBRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 13:56'! renameChangesForClass: oldClassName to: newClassName "We're in the middle of performing a rename operation. If we stored the class name, we need to change the class name to the new name to perform the compiles." self subclassResponsibility! ! !RBRefactoryChange methodsFor: 'accessing' stamp: ''! name ^name isNil ifTrue: [self changeString] ifFalse: [name]! ! !RBRefactoryChange methodsFor: '*NautilusRefactoring' stamp: ''! textToDisplay ^ self name! ! !RBRefactoryChangeManager methodsFor: 'private' stamp: ''! clearUndoRedoList undo := OrderedCollection new. redo := OrderedCollection new! ! !RBRefactoryChangeManager methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 8/3/2012 14:20'! connectToChanges SystemAnnouncer uniqueInstance weak on: CategoryAdded, CategoryRemoved, CategoryRenamed, ClassAdded, ClassModifiedClassDefinition, ClassRemoved, ClassRenamed, ClassReorganized, MethodAdded, MethodModified, MethodRemoved, ProtocolAdded, ProtocolRemoved send: #update: to: self.! ! !RBRefactoryChangeManager methodsFor: 'initialize-release' stamp: ''! release super release. self disconnectFromChanges! ! !RBRefactoryChangeManager methodsFor: 'updating' stamp: 'GuillermoPolito 7/2/2012 11:54'! update: anEvent isPerformingRefactoring ifFalse: [ self clearUndoRedoList ]! ! !RBRefactoryChangeManager methodsFor: 'public access' stamp: 'lr 9/7/2010 19:12'! redoOperation redo isEmpty ifTrue: [ ^ self ]. self ignoreChangesWhile: [ | change | change := redo removeLast. undo add: change execute ]! ! !RBRefactoryChangeManager methodsFor: 'public access' stamp: 'lr 9/7/2010 19:12'! undoOperation undo isEmpty ifTrue: [ ^ self ]. self ignoreChangesWhile: [ | change | change := undo removeLast. redo add: change execute ]! ! !RBRefactoryChangeManager methodsFor: 'public access' stamp: 'lr 9/7/2010 19:11'! redoChange ^ redo last! ! !RBRefactoryChangeManager methodsFor: 'public access' stamp: 'lr 9/7/2010 19:11'! ignoreChangesWhile: aBlock isPerformingRefactoring ifTrue: [ ^ aBlock value ]. isPerformingRefactoring := true. aBlock ensure: [ isPerformingRefactoring := false ]! ! !RBRefactoryChangeManager methodsFor: 'public access' stamp: 'lr 9/7/2010 19:11'! addUndo: aRefactoringChange undo addLast: aRefactoringChange. undo size > UndoSize ifTrue: [ undo removeFirst ]. redo := OrderedCollection new! ! !RBRefactoryChangeManager methodsFor: 'initialization' stamp: ''! initialize undo := OrderedCollection new. redo := OrderedCollection new. isPerformingRefactoring := false. self connectToChanges! ! !RBRefactoryChangeManager methodsFor: 'initialize-release' stamp: 'CamilleTeruel 7/29/2012 18:46'! disconnectFromChanges SystemAnnouncer uniqueInstance unsubscribe: self! ! !RBRefactoryChangeManager methodsFor: 'public access' stamp: 'lr 9/7/2010 19:12'! undoChange ^ undo last! ! !RBRefactoryChangeManager methodsFor: 'testing' stamp: 'lr 9/7/2010 19:11'! hasUndoableOperations ^ undo isEmpty not! ! !RBRefactoryChangeManager methodsFor: 'testing' stamp: 'lr 9/7/2010 19:11'! hasRedoableOperations ^ redo isEmpty not! ! !RBRefactoryChangeManager methodsFor: 'public access' stamp: 'lr 9/7/2010 19:11'! performChange: aRefactoringChange self ignoreChangesWhile: [ self addUndo: aRefactoringChange execute ]! ! !RBRefactoryChangeManager class methodsFor: 'class initialization' stamp: 'lr 4/4/2010 08:32'! initialize self nuke. UndoSize := 20! ! !RBRefactoryChangeManager class methodsFor: 'instance creation' stamp: 'lr 4/4/2010 08:35'! instance ^ Instance ifNil: [ Instance := self basicNew initialize ]! ! !RBRefactoryChangeManager class methodsFor: 'instance creation' stamp: 'lr 4/4/2010 08:33'! new ^ self shouldNotImplement! ! !RBRefactoryChangeManager class methodsFor: 'class initialization' stamp: 'lr 4/4/2010 08:33'! undoSize ^ UndoSize! ! !RBRefactoryChangeManager class methodsFor: 'class initialization' stamp: ''! undoSize: anInteger UndoSize := anInteger max: 0! ! !RBRefactoryChangeManager class methodsFor: 'public' stamp: 'lr 4/4/2010 08:34'! nuke Instance notNil ifTrue: [ Instance release ]. Instance := nil! ! !RBRefactoryChangeManager class methodsFor: 'settings' stamp: 'LukasRenggli 12/18/2009 10:42'! settingsOn: aBuilder (aBuilder setting: #undoSize) target: self; label: 'Undo size'; parentName: #refactoring! ! !RBRefactoryChangeManager class methodsFor: 'public' stamp: 'lr 4/4/2010 08:34'! unload self nuke! ! !RBRefactoryClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 21:19'! changeClassName: aSymbol className := aSymbol. isMeta isNil ifTrue: [ isMeta := false ]! ! !RBRefactoryClassChange methodsFor: 'printing' stamp: 'lr 9/6/2010 21:19'! displayClassName ^ isMeta ifTrue: [ self changeClassName , ' class' ] ifFalse: [ self changeClassName asString ]! ! !RBRefactoryClassChange methodsFor: 'comparing' stamp: 'lr 9/6/2010 21:19'! hash ^ self changeClassName hash! ! !RBRefactoryClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 21:19'! changeClassName ^ className! ! !RBRefactoryClassChange methodsFor: 'private' stamp: 'lr 9/6/2010 21:19'! isMeta ^ isMeta! ! !RBRefactoryClassChange methodsFor: 'private' stamp: 'lr 9/6/2010 21:19'! executeNotifying: aBlock | undo | undo := self asUndoOperation. undo name: self name. self primitiveExecute. aBlock value. ^ undo! ! !RBRefactoryClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 21:18'! changeClass | class | class := Smalltalk globals at: self changeClassName ifAbsent: [ ^ nil ]. ^ isMeta ifTrue: [ class classSide ] ifFalse: [ class ]! ! !RBRefactoryClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 21:19'! methodSourceFor: aSymbol ^ (self changeClass includesSelector: aSymbol) ifTrue: [ self changeClass sourceCodeAt: aSymbol ]! ! !RBRefactoryClassChange methodsFor: 'accessing' stamp: 'lr 10/31/2009 17:37'! changeClass: aBehavior isMeta := aBehavior isMeta. className := aBehavior theNonMetaClass name! ! !RBRefactoryClassChange methodsFor: 'printing' stamp: 'lr 9/6/2010 21:19'! changeString ^ self displayClassName! ! !RBRefactoryClassChange methodsFor: 'comparing' stamp: 'lr 9/6/2010 21:18'! = aRefactoryClassChange self class = aRefactoryClassChange class ifFalse: [ ^ false ]. ^ className = aRefactoryClassChange changeClassName and: [ isMeta = aRefactoryClassChange isMeta ]! ! !RBRefactoryClassChange methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: self displayString! ! !RBRefactoryClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 13:57'! renameChangesForClass: oldClassName to: newClassName ^ self changeClassName = oldClassName ifFalse: [ self ] ifTrue: [ self copy changeClassName: newClassName; yourself ]! ! !RBRefactoryClassChange methodsFor: 'private' stamp: 'lr 9/6/2010 13:29'! primitiveExecute ^ self subclassResponsibility! ! !RBRefactoryClassChange methodsFor: 'converting' stamp: ''! asUndoOperation ^self subclassResponsibility! ! !RBRefactoryDefinitionChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 14:08'! definition ^ definition! ! !RBRefactoryDefinitionChange methodsFor: 'initialization' stamp: 'lr 10/1/2010 14:37'! definition: aString controller: aController isMeta := false. definition := aString. controller := aController! ! !RBRefactoryDefinitionChange methodsFor: 'private' stamp: 'lr 9/30/2010 14:20'! definitionClass self subclassResponsibility! ! !RBRefactoryDefinitionChange methodsFor: 'comparing' stamp: 'lr 9/30/2010 14:07'! hash ^ definition hash! ! !RBRefactoryDefinitionChange methodsFor: 'comparing' stamp: 'lr 9/30/2010 14:07'! = aDefinitionChange ^ self class = aDefinitionChange class and: [ self definition = aDefinitionChange definition ]! ! !RBRefactoryDefinitionChange methodsFor: 'printing' stamp: 'lr 9/30/2010 14:12'! printOn: aStream aStream nextPutAll: definition; nextPut: $!!! ! !RBRefactoryDefinitionChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 14:09'! definedClass ^ definedClass! ! !RBRefactoryDefinitionChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 14:13'! controller ^ controller! ! !RBRefactoryDefinitionChange methodsFor: 'initialization' stamp: 'lr 10/1/2010 14:32'! fillOutDefinition: aDictionary self subclassResponsibility! ! !RBRefactoryDefinitionChange methodsFor: 'private' stamp: 'MarcusDenker 8/28/2013 10:52'! primitiveExecute definedClass := self definitionClass compiler source: self definition; requestor: self controller; logged: true; evaluate! ! !RBRefactoryDefinitionChange methodsFor: 'printing' stamp: 'lr 9/30/2010 14:12'! changeString ^ 'Define ' , self displayClassName! ! !RBRefactoryDefinitionChange methodsFor: 'private' stamp: 'lr 9/30/2010 19:21'! namesIn: aString | names scanner token | names := OrderedCollection new. scanner := RBScanner on: (ReadStream on: aString) errorBlock: [ :msg :pos | ^ names ]. [ scanner atEnd ] whileFalse: [ token := scanner next. token isIdentifier ifTrue: [ names add: token value ] ]. ^ names asArray! ! !RBRefactoryDefinitionChange class methodsFor: 'private' stamp: 'lr 10/1/2010 14:32'! definitionPatterns self subclassResponsibility! ! !RBRefactoryDefinitionChange class methodsFor: 'instance creation' stamp: 'lr 9/30/2010 14:01'! definition: aString ^ self definition: aString for: nil! ! !RBRefactoryDefinitionChange class methodsFor: 'instance creation' stamp: 'MarcusDenker 3/25/2013 21:02'! definition: aString for: aController | parseTree context | parseTree := RBParser parseExpression: aString onError: [ :err :pos | ^ self error: 'Invalid definition string' ]. context := SmallDictionary new. RBRefactoryDefinitionChange allSubclassesDo: [ :class | class definitionPatterns do: [ :pattern | ((RBParser parseRewriteExpression: pattern) match: parseTree inContext: context empty) ifTrue: [ ^ class definition: aString for: aController context: context ] ] ]. ^ self error: 'Invalid definition string'! ! !RBRefactoryDefinitionChange class methodsFor: 'private' stamp: 'MarcusDenker 9/20/2013 15:07'! definition: aString for: aController context: aDictionary | dictionary | dictionary := SmallDictionary new. aDictionary keysAndValuesDo: [ :key :node | dictionary at: key formattedCode put: (node isVariable ifTrue: [ node name ] ifFalse: [ node isLiteralNode ifTrue: [ node value ] ifFalse: [ node ] ]) ]. ^ self new definition: aString controller: aController; fillOutDefinition: dictionary; yourself! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! collectionMessagesToExternalObject self someObject collection remove: 10! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! literalArrayCharacters ^#($a $b $c) includes: $a! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'md 3/14/2006 16:47'! atIfAbsent ^ Smalltalk at: #MyTest ifAbsent: [| collection | collection := #(). Smalltalk at: #MyTest put: collection]! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! inlineComponent | a | a := 5. ^a class superclass; hasImmediateInstances; yourself! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! usesAdd ^(1 to: 10) asOrderedCollection addAll: (11 to: 20)! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! collectionProtocol | newCollection | newCollection := OrderedCollection new. (1 to: 10) asOrderedCollection do: [:each | | new | new := each * 2. newCollection add: new]. ^newCollection! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'lr 2/26/2009 15:07'! refersToClass ^ RBRefactoryTestDataApp! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! returnInEnsure [self error: 'asdf'] ensure: [^4]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! guardingClause self isSymbol ifFalse: [self printString. self isSymbol printString]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! assignmentInBlock [^self printString] ensure: [self close]! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! moveDefinition | temp | ^(self collect: [:each | temp := each printString. temp , temp]) select: [:each | temp := each size. temp odd]! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! sendInlineParameterMethod ^self inlineParameterMethod: #(#asdf)! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! symbolReference ^#(#renameThisMethod: #(4 #renameThisMethod:))! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! returnsIfTrue ^self isNil ifTrue: [4]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'bh 4/2/2000 22:25'! searchingLiteral ^self printString = #a or: [#() = self printString | ( #() == self printString)]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! release self printString! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! tempVarOverridesInstVar | temporaryVariable | temporaryVariable := 4. ^temporaryVariable! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'nk 2/25/2005 16:50'! variableAssignedLiteral temporaryVariable := #() ! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! detectContains ^(1 to: 10) do: [:each | each > 2 ifTrue: [^each]]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'nk 3/5/2005 14:51'! noIsNil: arg ^arg = nil or: [ arg ~= nil ]! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! noMoveDefinition | temp | ^(self collect: [:each | temp := each printString. temp , temp]) select: [:each | temp := each size + temp]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! returnsBooleanAndOther self isVariable ifTrue: [^false]. self printString! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! precedence ^self isArray ifFalse: [self block + 5 * 34] ifTrue: [self printString = 10]! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! inlineParameterMethod: aSymbol ^aSymbol isSymbol! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! missingYourself ^(OrderedCollection new) add: 1; add: 2; removeFirst! ! !RBRefactoryTestDataApp methodsFor: 'accessing' stamp: ''! referencesConditionFor: aClass | environment association | ^(RBCondition withBlock: [association := Smalltalk associationAt: aClass name ifAbsent: [self refactoringError: 'Could not find class']. environment := (self environment referencesTo: association) | (self environment referencesTo: aClass name). environment isEmpty]) errorMacro: aClass , ' is referenced.Browse references?'; errorBlock: [environment openEditor]; yourself! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! modifiesCollection | collection | collection := (1 to: 10) asOrderedCollection. collection do: [:each | each > 5 ifTrue: [collection remove: each]]. ^collection! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! fileBlocks | file | ^ [file := 'asdf' asFilename readStream. file contents] ensure: [file close]! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! called: anObject on: aBlock Transcript show: anObject printString; cr. aBlock value! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! inlineTemporary | temp | self isNil ifTrue: [temp := 4]. ^temp! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! testFoo: anObject ^self class + anObject! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! toDo 1 to: self size do: [:i | (self at: i) printString]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! yourselfNotUsed self printString; printString; yourself! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! multipleCalls self caller2. self caller2! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! toDoCollect | array | array := Array new: 10. 1 to: 10 do: [:i | array at: i put: i * i]. ^array! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! equalsTrue ^true == self! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! tempsReadBeforeWritten | temp | self isVariable ifTrue: [temp := 4]. ^temp! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! renameThisMethod: anArg ^self! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! callFoo ^self testFoo: 5! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'nk 3/4/2005 16:40'! literalArrayWithTrueFalseOrNil2 | b c | b := #(#true #false #nil). c := #(#true (#true #false #nil) #false #nil). ^b! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! inlineJunk | asdf | asdf := self inlineFoo: [:each | | temp | temp := each. temp , temp]. ^asdf foo: [:bar | | baz | baz := bar. baz * baz]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! whileTrue | i | i := 1. [i < self size] whileTrue: [(self at: i) printString. i := i + 1]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! threeElementPoint ^5 @ 5 + 6 @ 6! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! exampleCall ^self rename: 1 two: 2! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! inlineFailed | x y q | x := 5. y := 10. q := x + 1 fooMax: y. ^q! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! asOrderedCollectionNotNeeded self foo addAll: (1 to: 10) asOrderedCollection! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! inlineMax | x y q | x := 5. y := 10. q := x + 1 max: y. ^q! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! selectorNotReferenced ^self selectorNotReferenced + 4! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! stringConcatenation | string | string := '' yourself. (1 to: 10) do: [:i | string := string , i printString]. ^string! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! caller2 ^(1 to: 10) inject: 1 into: [:sum :each | sum * (self foo: each)]! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! rename: this two: argumentMethod ^self printString , this , argumentMethod! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! consistencyCheck ^(1 to: 10) at: 1! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! testMethod1 ^self testMethod1 , ([:each | each testMethod1] value: #(#(#testMethod1) 2 #testMethod1))! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! sizeCheck self isEmpty ifFalse: [self do: [:each | Transcript show: each; cr]]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'lr 7/1/2008 10:14'! cruft self halt! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! inlineLast 5 = 3 ifTrue: [^self caller] ifFalse: [^self caller2]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'nk 3/5/2005 15:28'! assignmentInIfTrue | variable | self isVariable ifTrue: [variable := self] ifFalse: [variable := self printString]. ^variable! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! collectSelectNotUsed (1 to: 10) select: [:each | each = 4]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! extraBlock ^[:arg | arg + 43] value: 45! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'nk 3/4/2005 14:52'! literalArrayWithTrueFalseOrNil | a b c | a := #(true false nil). b := #(#true #false #nil). c := {true. false. nil}. ^{a. b. c}! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! caller1 | anObject | anObject := 5. self called: anObject + 1 on1: [:each | each printString. ^anObject]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'nk 3/5/2005 15:28'! sendsDifferentSuper super printString! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! called: anObject on1: aBlock | each | each := anObject printString. Transcript show: each; cr. aBlock value: each! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! inlineMethod | temp | temp := self foo; inlineMethod; bar. ^temp! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! foo: aValue ^(1 to: 10) inject: aValue into: [:sum :each | sum + each]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! toDoWithIncrement | counter | counter := 0. 1 to: 10 by: 2 do: [:i | counter := counter + 2]. ^counter! ! !RBRefactoryTestDataApp methodsFor: 'inline' stamp: ''! caller | anObject | anObject := 5. self called: anObject + 1 on: [^anObject]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! booleanPrecedence ^true & 4 = 45! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'nk 3/5/2005 15:28'! contains ^((1 to: 10) detect: [:each | each > 2] ifNone: [nil]) isNil! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! fullBlocks ^[thisContext]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! badMessage self become: String new! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! ifTrueReturns self isSymbol ifFalse: [^true]. ^false! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! longMethods self printString. self printString. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'nk 3/5/2005 15:28'! minMax "Bug in 3<5 ifTrue: [3] ifFalse: [5]" ^3<5 ifTrue: [3] ifFalse: [5] " | var | var := 4. var < 5 ifTrue: [var := 5]. ^var"! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! testMethod ^self class! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! equalNotUsed | string | string = '' yourself. (1 to: 10) do: [:i | string := i printString]. ^string! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! endTrueFalse self isVariable ifTrue: [self printString. self isVariable printString] ifFalse: [self printString. ^4]! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! inlineFoo: aBlock | bar baz asdf | bar := aBlock value: self. baz := bar + bar. asdf := baz + bar. ^asdf! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: ''! justSendsSuper super justSendsSuper! ! !RBRefactoryTestDataApp methodsFor: 'test' stamp: ''! callMethod ^self renameThisMethod: 5! ! !RBRefactoryTyper methodsFor: 'private' stamp: ''! executeSearch: searcher class withAllSubclasses do: [:each | each selectors do: [:sel | | parseTree | methodName := sel. parseTree := each parseTreeFor: sel. parseTree notNil ifTrue: [searcher executeTree: parseTree]]]! ! !RBRefactoryTyper methodsFor: 'private' stamp: 'lr 8/10/2009 16:36'! backpointersDictionary "Create a special dictionary, because the host systems wrongly treats #abc and 'abc' as equal." ^ PluggableDictionary new equalBlock: [ :a :b | a class == b class and: [ a = b ] ]; hashBlock: [ :a | a class identityHash bitXor: a hash ]; yourself! ! !RBRefactoryTyper methodsFor: 'accessing' stamp: ''! guessTypesFor: anInstVarName ^bestGuesses at: anInstVarName ifAbsent: [self typesFor: anInstVarName]! ! !RBRefactoryTyper methodsFor: 'initialization' stamp: ''! initialize model := RBNamespace new. class := model classFor: Object. variableTypes := Dictionary new. variableMessages := Dictionary new. selectorLookup := IdentityDictionary new. bestGuesses := Dictionary new! ! !RBRefactoryTyper methodsFor: 'computing types' stamp: 'lr 5/29/2010 09:45'! findTypeFor: selectorCollection ^selectorCollection inject: self rootClasses into: [:classes :each | self refineTypes: classes with: (selectorLookup at: each ifAbsentPut: [self implementorsOf: each])]! ! !RBRefactoryTyper methodsFor: 'computing types' stamp: ''! computeTypes variableMessages keysAndValuesDo: [:key :value | variableTypes at: key put: (self findTypeFor: value)]! ! !RBRefactoryTyper methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: class name; cr. class instanceVariableNames do: [:each | aStream tab; nextPutAll: each; tab; nextPut: $<. self printTypeFor: each on: aStream. aStream nextPut: $>; cr]! ! !RBRefactoryTyper methodsFor: 'private' stamp: 'lr 5/29/2010 10:01'! rootClasses ^ model rootClasses! ! !RBRefactoryTyper methodsFor: 'accessing' stamp: ''! selectedClass: aClass class := model classFor: aClass! ! !RBRefactoryTyper methodsFor: 'printing' stamp: ''! printTypeFor: aString on: aStream | types | types := (self guessTypesFor: aString) asSortedCollection: [:a :b | a name < b name]. 1 to: types size do: [:i | i == 1 ifFalse: [aStream nextPutAll: ' | ']. self printType: (types at: i) for: aString on: aStream]! ! !RBRefactoryTyper methodsFor: 'computing types' stamp: ''! refineTypes: aClassCollection with: anotherClassCollection | classSet | classSet := Set new. aClassCollection do: [:each | anotherClassCollection do: [:cls | (cls includesClass: each) ifTrue: [classSet add: cls] ifFalse: [(each includesClass: cls) ifTrue: [classSet add: each]]]]. ^classSet! ! !RBRefactoryTyper methodsFor: 'equivalence classes' stamp: 'lr 11/2/2009 00:14'! computeEquivalenceClassesForMethodsAndVars | searcher | backpointers := self backpointersDictionary. class instanceVariableNames do: [:each | backpointers at: each put: (self backpointersSetWith: each)]. class withAllSubclasses do: [:sub | sub selectors do: [:each | backpointers at: each put: (self backpointersSetWith: each)]]. searcher := RBParseTreeSearcher new. searcher matches: '^``@object' do: [:aNode :answer | self processNode: aNode value]. self executeSearch: searcher! ! !RBRefactoryTyper methodsFor: 'assignments' stamp: 'lr 11/2/2009 23:38'! refineTypesByLookingAtAssignments | searcher needsSearch | needsSearch := false. searcher := RBParseTreeSearcher new. variableTypes keysAndValuesDo: [:key :value | (key first = $-) ifFalse: [needsSearch := true. searcher matches: key , ' := ``@object' do: [:aNode :answer | self guessTypeFromAssignment: aNode]]]. needsSearch ifTrue: [self executeSearch: searcher]! ! !RBRefactoryTyper methodsFor: 'accessing' stamp: ''! guessTypesFor: anInstVarName in: aClass class = aClass ifFalse: [self runOn: aClass]. ^bestGuesses at: anInstVarName ifAbsent: [self typesFor: anInstVarName in: aClass]! ! !RBRefactoryTyper methodsFor: 'private' stamp: 'lr 8/10/2009 16:37'! backpointersSetWith: anObject "Create a special set, because the host systems wrongly treats #abc and 'abc' as equal." ^ PluggableSet new equalBlock: [ :a :b | a class == b class and: [ a = b ] ]; hashBlock: [ :a | a class identityHash bitXor: a hash ]; add: anObject; yourself! ! !RBRefactoryTyper methodsFor: 'selectors-collections' stamp: 'lr 5/29/2010 09:40'! processCollectionMessagesFor: variableName in: aParseTree | parent block | aParseTree isMessage ifFalse: [ ^ self ]. (#(anyOne at: at:ifAbsent: at:ifAbsentPut: atPin: atRandom atRandom: atWrap: eight fifth first fourth last middle ninth second seventh sixth third) includes: aParseTree selector) ifTrue: [ parent := aParseTree parent. (parent notNil and: [ parent isMessage ]) ifFalse: [ ^ self ]. aParseTree == parent receiver ifFalse: [ ^ self ]. (variableMessages at: (self collectionNameFor: variableName) ifAbsentPut: [Set new]) add: parent selector. self processCollectionMessagesFor: (self collectionNameFor: variableName) in: parent ]. (#(allSatisfy: anySatisfy: collect: collect:as: detect: detect:ifNone: detectMax: detectMin: detectSum: do: do:displayingProgress: do:separatedBy: gather: noneSatisfy: reject: select:) includes: aParseTree selector) ifTrue: [ block := aParseTree arguments first. block isBlock ifFalse: [ ^ self ]. self processCollectionFor: variableName messagesTo: block arguments first name in: block ]. (#(reduce: reduceLeft: reduceRight:) includes: aParseTree selector) ifTrue: [ block := aParseTree arguments last. block isBlock ifFalse: [ ^ self ]. block arguments do: [ :node | self processCollectionFor: variableName messagesTo: node name in: block ] ]. #inject:into: = aParseTree selector ifTrue: [ block := aParseTree arguments last. block isBlock ifFalse: [ ^ self ]. self processCollectionFor: variableName messagesTo: block arguments last name in: block ]! ! !RBRefactoryTyper methodsFor: 'computing types' stamp: 'lr 5/29/2010 09:46'! implementorsOf: aSelector | classes | classes := OrderedCollection new. self rootClasses do: [:each | self implementorsOf: aSelector in: each storeIn: classes]. ^classes! ! !RBRefactoryTyper methodsFor: 'assignments' stamp: 'MarcusDenker 9/20/2013 15:07'! guessTypeFromAssignment: aNode | type set newType | type := nil. aNode value isAssignment ifTrue: [^self guessTypeFromAssignment: (RBAssignmentNode variable: aNode variable value: aNode value value)]. aNode value isBlock ifTrue: [type := model classFor: [] class]. aNode value isLiteralNode ifTrue: [aNode value value isNil ifTrue: [^self]. type := model classFor: (self typeFor: aNode value value)]. aNode value isMessage ifTrue: [aNode value receiver isVariable ifTrue: [type := model classNamed: aNode value receiver name asSymbol]. aNode value selector = #asValue ifTrue: [type := model classNamed: #ValueHolder]. (#(#and: #or: #= #== #~= #~~ #<= #< #~~ #> #>=) includes: aNode value selector) ifTrue: [type := model classFor: Boolean]]. type isNil ifTrue: [^self]. set := variableTypes at: aNode variable name. newType := set detect: [:each | type includesClass: each] ifNone: [nil]. newType isNil ifTrue: [^self]. ((self rootClasses includes: newType) or: [ newType = (model classFor: Object) ]) ifTrue: [newType := type]. (bestGuesses at: aNode variable name ifAbsentPut: [Set new]) add: newType! ! !RBRefactoryTyper methodsFor: 'printing' stamp: ''! collectionNameFor: aString ^'-<1s>-' expandMacrosWith: aString! ! !RBRefactoryTyper methodsFor: 'selectors' stamp: 'lr 11/19/2009 11:45'! computeMessagesSentToVariables | searcher | variableMessages := Dictionary new. class instanceVariableNames do: [:each | variableMessages at: each put: Set new]. searcher := RBParseTreeSearcher new. class instanceVariableNames do: [:each | | block | block := [:aNode :answer | (variableMessages at: each ifAbsentPut: [Set new]) add: aNode selector. self processCollectionMessagesFor: each in: aNode]. searcher matches: each , ' `@messageName: ``@args' do: block. (backpointers at: each) do: [:sel | sel isSymbol ifTrue: [searcher matches: ('(self <1s>) `@messageName: ``@args' expandMacrosWith: (RBParseTreeSearcher buildSelectorString: sel)) asString do: block]]]. searcher answer: variableMessages. self executeSearch: searcher! ! !RBRefactoryTyper methodsFor: 'computing types' stamp: ''! implementorsOf: aSelector in: aClass storeIn: classes (aClass directlyDefinesMethod: aSelector) ifTrue: [classes add: aClass. ^self]. aClass subclasses do: [:each | self implementorsOf: aSelector in: each storeIn: classes]! ! !RBRefactoryTyper methodsFor: 'private' stamp: ''! model ^model! ! !RBRefactoryTyper methodsFor: 'printing' stamp: ''! printType: aClass for: aString on: aStream | name colTypes | colTypes := #(). name := self collectionNameFor: aString. (aClass includesClass: (model classFor: Collection)) ifTrue: [colTypes := self guessTypesFor: name]. colTypes isEmpty ifFalse: [aStream nextPut: $(]. aClass printOn: aStream. colTypes isEmpty ifFalse: [aStream nextPutAll: ' of: '. colTypes size > 1 ifTrue: [aStream nextPut: $(]. self printTypeFor: name on: aStream. colTypes size > 1 ifTrue: [aStream nextPut: $)]]. colTypes isEmpty ifFalse: [aStream nextPut: $)]! ! !RBRefactoryTyper methodsFor: 'accessing' stamp: ''! runOn: aClass variableTypes := Dictionary new. variableMessages := Dictionary new. bestGuesses := Dictionary new. class := model classFor: aClass. class instanceVariableNames isEmpty ifTrue: [^self]. self selectedClass: aClass; computeEquivalenceClassesForMethodsAndVars; computeMessagesSentToVariables; computeTypes; refineTypesByLookingAtAssignments! ! !RBRefactoryTyper methodsFor: 'assignments' stamp: 'lr 7/1/2008 10:25'! typeFor: anObject anObject isString ifTrue: [ ^ String ]. anObject isInteger ifTrue: [ ^ Integer ]. ^ (anObject == true or: [ anObject == false ]) ifTrue: [ Boolean ] ifFalse: [ anObject class ]! ! !RBRefactoryTyper methodsFor: 'equivalence classes' stamp: 'CamilloBruni 8/1/2012 16:11'! merge: aName | set1 set2 | set1 := backpointers at: methodName ifAbsent: [nil]. set2 := backpointers at: aName ifAbsent: [nil]. (set1 isNil or: [set2 isNil or: [set1 == set2]]) ifTrue: [^self]. set1 addAll: set2. set2 do: [:each | backpointers at: each put: set1]! ! !RBRefactoryTyper methodsFor: 'equivalence classes' stamp: ''! processNode: aNode (aNode isVariable and: [class instanceVariableNames includes: aNode name]) ifTrue: [^self merge: aNode name]. (aNode isMessage and: [aNode receiver isVariable and: [aNode receiver name = 'self']]) ifTrue: [^self merge: aNode selector]. aNode isAssignment ifTrue: [self processNode: aNode value; processNode: aNode variable]. (aNode isMessage and: [#(#ifTrue: #ifFalse: #ifTrue:ifFalse: #ifFalse:ifTrue:) includes: aNode selector]) ifTrue: [aNode arguments do: [:each | each isBlock ifTrue: [each body statements isEmpty ifFalse: [self processNode: each body statements last]]]]! ! !RBRefactoryTyper methodsFor: 'accessing' stamp: ''! typesFor: anInstVarName in: aClass class = aClass ifFalse: [self runOn: aClass]. ^variableTypes at: anInstVarName ifAbsent: [Set new]! ! !RBRefactoryTyper methodsFor: 'private' stamp: ''! model: aRBSmalltalk model := aRBSmalltalk! ! !RBRefactoryTyper methodsFor: 'selectors-collections' stamp: 'lr 5/29/2010 09:40'! processCollectionFor: key messagesTo: aName in: aBlock | searcher | searcher := RBParseTreeSearcher new. searcher matches: aName , ' `@message: ``@args' do: [ :aNode :answer | self processCollectionMessagesFor: key in: aNode. answer add: aNode selector; yourself ]. searcher executeTree: aBlock initialAnswer: (variableMessages at: (self collectionNameFor: key) ifAbsentPut: [ Set new ])! ! !RBRefactoryTyper methodsFor: 'accessing' stamp: ''! typesFor: anInstVarName ^variableTypes at: anInstVarName ifAbsent: [Set new]! ! !RBRefactoryTyper class methodsFor: 'instance creation' stamp: ''! newFor: aRBNamespace ^(self new) model: aRBNamespace; yourself! ! !RBRefactoryTyper class methodsFor: 'accessing' stamp: 'lr 11/2/2009 00:14'! typesFor: variableName in: aParseTree model: aRBSmalltalk | searcher messages | searcher := RBParseTreeSearcher new. searcher matches: variableName , ' `@message: ``@args' do: [:aNode :answer | answer add: aNode selector; yourself]. messages := searcher executeTree: aParseTree initialAnswer: Set new. ^(self new) model: aRBSmalltalk; findTypeFor: messages! ! !RBRefactoryVariableChange methodsFor: 'comparing' stamp: 'lr 10/15/2010 09:37'! hash ^ self changeClassName hash bitXor: self variable hash! ! !RBRefactoryVariableChange methodsFor: 'comparing' stamp: 'lr 10/15/2010 09:37'! = aRefactoryVariableChange ^ super = aRefactoryVariableChange and: [ self variable = aRefactoryVariableChange variable ]! ! !RBRefactoryVariableChange methodsFor: 'private' stamp: 'lr 9/6/2010 21:29'! variable ^ variable! ! !RBRefactoryVariableChange methodsFor: 'printing' stamp: 'lr 5/18/2010 20:48'! printOn: aStream aStream nextPutAll: self displayClassName; nextPut: $ ; nextPutAll: self changeSymbol; nextPut: $ ; print: self variable; nextPut: $!!! ! !RBRefactoryVariableChange methodsFor: 'private' stamp: 'lr 9/6/2010 21:27'! changeObject ^ self variable! ! !RBRefactoryVariableChange methodsFor: 'private' stamp: ''! changeSymbol self subclassResponsibility! ! !RBRefactoryVariableChange methodsFor: 'private' stamp: 'lr 10/15/2010 09:43'! primitiveExecute self changeClass perform: self changeSymbol with: self changeObject! ! !RBRefactoryVariableChange methodsFor: 'initialize-release' stamp: ''! class: aBehavior variable: aString self changeClass: aBehavior. variable := aString! ! !RBRefactoryVariableChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:44'! remove: aVariable from: aBehavior "This should only be called on the Remove*Change subclasses, but is here so we don't need to copy it to all subclasses" ^ self new class: aBehavior variable: aVariable! ! !RBRefactoryVariableChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:44'! add: aVariable to: aBehavior "This should only be called on the Add*Change subclasses, but is here so we don't need to copy it to all subclasses" ^ self new class: aBehavior variable: aVariable! ! !RBRefersToClassRule commentStamp: ''! See my #rationale.! !RBRefersToClassRule methodsFor: '*Manifest-Core' stamp: 'ah 8/6/2012 13:09'! longDescription ^ 'This smell arises when a class has its class name directly in the source instead of "self class". The self class variant allows you to create subclasses without needing to redefine that method.'! ! !RBRefersToClassRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for classes that have their class name directly in the source instead of "self class". The self class variant allows you to create subclasses without needing to redefine that method.'! ! !RBRefersToClassRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBRefersToClassRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Refers to class name instead of "self class"'! ! !RBRefersToClassRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:35'! category ^ 'Design Flaws'! ! !RBRefersToClassRule methodsFor: 'running' stamp: 'lr 7/23/2010 08:03'! checkClass: aContext | sels className | className := aContext selectedClass theNonMetaClass name. sels := aContext selectedClass whichSelectorsReferTo: (Smalltalk globals associationAt: className). sels do: [ :each | result addClass: aContext selectedClass selector: each ]. sels isEmpty ifFalse: [ result addSearchString: className ]! ! !RBRefersToClassRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'RefersToClassRule'! ! !RBRegexRefactoring methodsFor: 'private' stamp: ''! execute: aString replace: aRegex with: aReadStream | stream | ^ aRegex copy: aString translatingMatchesUsing: [ :match | stream := WriteStream on: (String new: 2 * aString size). [ aReadStream atEnd ] whileFalse: [ stream nextPutAll: (aReadStream upTo: $$). aReadStream atEnd ifFalse: [ aReadStream peek isDigit ifFalse: [ stream nextPut: aReadStream next ] ifTrue: [ stream nextPutAll: (aRegex subexpression: aReadStream next asInteger - $0 asInteger + 1) ] ] ]. aReadStream reset. stream contents ]! ! !RBRegexRefactoring methodsFor: 'initialization' stamp: ''! initialize super initialize. matchers := OrderedCollection new! ! !RBRegexRefactoring methodsFor: 'private' stamp: ''! execute: aString "Perform all searches on aString and return the transformation." ^ matchers inject: aString asString into: [ :string :assoc | self execute: string replace: assoc key with: assoc value ]! ! !RBRegexRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^ RBCondition empty! ! !RBRegexRefactoring methodsFor: 'searching' stamp: ''! replace: aFindString with: aReplaceString self replace: aFindString with: aReplaceString ignoreCase: false! ! !RBRegexRefactoring methodsFor: 'searching' stamp: ''! replace: aFindString with: aReplaceString ignoreCase: aBoolean "Replace all matches of aFindString (regular expression) with aReplaceString, where $0 references the whole match, and $1..$9 the matched groups." | regex stream | regex := RxParser preferredMatcherClass for: (RxParser new parse: aFindString) ignoreCase: aBoolean. stream := aReplaceString readStream. matchers add: regex -> stream! ! !RBRemoveAssignmentWithoutEffectRule commentStamp: ''! See my #longDescription .! !RBRemoveAssignmentWithoutEffectRule methodsFor: 'initialization' stamp: 'SimonAllier 2/8/2013 16:43'! initialize super initialize. self rewriteRule replace: '`var := `var' with: ''! ! !RBRemoveAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: 'SimonAllier 9/5/2012 14:24'! group ^ 'Transformations'! ! !RBRemoveAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: 'SimonAllier 9/5/2012 14:21'! name ^ 'Remove assignment has no effect'! ! !RBRemoveAssignmentWithoutEffectRule methodsFor: 'as yet unclassified' stamp: 'SimonAllier 9/7/2012 14:05'! category ^ 'Optimization'! ! !RBRemoveAssignmentWithoutEffectRule methodsFor: 'as yet unclassified' stamp: 'SimonAllier 9/12/2012 14:02'! longDescription ^ 'Remove assignment has no effect. For example, var := var is unless'! ! !RBRemoveClassChange methodsFor: 'accessing' stamp: 'lr 10/15/2010 09:10'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !RBRemoveClassChange methodsFor: 'private' stamp: ''! primitiveExecute self changeClass removeFromSystem! ! !RBRemoveClassChange methodsFor: 'printing' stamp: 'lr 4/7/2010 08:20'! changeString ^ 'Remove ' , self displayClassName! ! !RBRemoveClassChange methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPutAll: self displayClassName; nextPutAll: ' removeFromSystem'; nextPut: $!!! ! !RBRemoveClassChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation | classChanges | classChanges := RBCompositeRefactoryChange new. self changeClass withAllSubclasses do: [ :each | classChanges defineClass: each definition. each class instVarNames do: [ :varName | classChanges addInstanceVariable: varName to: each class ]. each selectors do: [ :selector | classChanges compile: (each sourceCodeAt: selector) in: each ]. each class selectors do: [ :selector | classChanges compile: (each class sourceCodeAt: selector) in: each class ] ]. ^ classChanges! ! !RBRemoveClassChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:45'! removeClassName: aSymbol ^ self new changeClassName: aSymbol! ! !RBRemoveClassChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:44'! remove: aClass ^ self new changeClass: aClass! ! !RBRemoveClassRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:03'! preconditions ^classNames inject: RBCondition empty into: [:sum :each | | aClass | aClass := self model classNamed: each asSymbol. aClass isNil ifTrue: [self refactoringFailure: 'No such class']. sum & (((RBCondition isMetaclass: aClass) errorMacro: 'Cannot remove just the metaclass') not & ((RBCondition withBlock: [(self hasReferencesTo: each asSymbol) not]) errorMacro: each , ' is referenced.Browse references?'; errorBlock: [self openBrowserOn: (RBBrowserEnvironment new referencesTo: (Smalltalk globals associationAt: each ifAbsent: [each]))]; yourself) & ((RBCondition hasSubclasses: aClass) not | ((RBCondition isEmptyClass: aClass) & ((RBCondition withBlock: [aClass superclass notNil]) errorMacro: 'Cannot remove top level classwhen it has subclasses'; yourself))))]! ! !RBRemoveClassRefactoring methodsFor: 'transforming' stamp: ''! removeClasses classNames do: [:each | self model removeClassNamed: each]! ! !RBRemoveClassRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' classNames: '. classNames asArray storeOn: aStream. aStream nextPut: $)! ! !RBRemoveClassRefactoring methodsFor: 'transforming' stamp: ''! transform self reparentSubclasses; removeClasses! ! !RBRemoveClassRefactoring methodsFor: 'preconditions' stamp: 'lr 9/8/2011 20:25'! hasReferencesTo: aSymbol | literal | literal := Smalltalk globals associationAt: aSymbol. RBBrowserEnvironment new classesDo: [:each | (classNames includes: (each isMeta ifTrue: [each soleInstance] ifFalse: [each]) name) ifFalse: [(each whichSelectorsReferTo: literal) isEmpty ifFalse: [^true]. (each whichSelectorsReferTo: aSymbol) isEmpty ifFalse: [^true]]]. ^false! ! !RBRemoveClassRefactoring methodsFor: 'initialize-release' stamp: ''! classNames: aClassNameCollection classNames := aClassNameCollection! ! !RBRemoveClassRefactoring methodsFor: 'transforming' stamp: ''! reparentSubclasses classNames do: [:each | | class | class := self model classNamed: each. self model reparentClasses: class subclasses copy to: class superclass]! ! !RBRemoveClassRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk classNames: aClassNameCollection ^(self new) model: aRBSmalltalk; classNames: aClassNameCollection; yourself! ! !RBRemoveClassRefactoring class methodsFor: 'instance creation' stamp: ''! classNames: aClassNameCollection ^self new classNames: aClassNameCollection! ! !RBRemoveClassTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadName self shouldFail: (RBRemoveClassRefactoring classNames: #(#RecursiveSelfRule))! ! !RBRemoveClassTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testRemoveReferenced self shouldFail: (RBRemoveClassRefactoring classNames: #(#RBBasicLintRuleTest ))! ! !RBRemoveClassTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRemoveClass | refactoring | refactoring := RBRemoveClassRefactoring classNames: (Array with: ('RBFoo' , 'LintRuleTest') asSymbol). self executeRefactoring: refactoring. self assert: (refactoring model classNamed: ('RBFoo' , 'LintRuleTest') asSymbol) isNil. self assert: (refactoring model classNamed: #RBTransformationRuleTest) superclass = (refactoring model classNamed: #RBLintRuleTest)! ! !RBRemoveClassVariableChange methodsFor: 'private' stamp: 'lr 3/20/2011 11:28'! changeSymbol ^ #removeClassVarNamed:! ! !RBRemoveClassVariableChange methodsFor: 'accessing' stamp: 'lr 10/15/2010 08:31'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !RBRemoveClassVariableChange methodsFor: 'printing' stamp: 'lr 10/15/2010 09:37'! changeString ^ 'Remove class variable <1s> from <2s>' expandMacrosWith: self variable with: self displayClassName! ! !RBRemoveClassVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBAddClassVariableChange add: self variable to: self changeClass! ! !RBRemoveClassVariableRefactoring methodsFor: 'preconditions' stamp: 'lr 9/8/2011 20:32'! preconditions ^ (RBCondition isMetaclass: class) not & (RBCondition definesClassVariable: variableName in: class) & (RBCondition withBlock: [ | block | block := [ :each | (each whichSelectorsReferToClassVariable: variableName) isEmpty ifFalse: [ class realClass isNil ifTrue: [ self refactoringError: ('<1s> is referenced.' expandMacrosWith: variableName) ] ifFalse: [ self refactoringError: ('<1s> is referenced.Browse references?' expandMacrosWith: variableName) with: [ self openBrowserOn: (RBVariableEnvironment referencesToClassVariable: variableName in: class realClass) ] ] ] ]. class withAllSubclasses do: block. class theMetaClass withAllSubclasses do: block. true ])! ! !RBRemoveClassVariableRefactoring methodsFor: 'transforming' stamp: ''! transform class removeClassVariable: variableName! ! !RBRemoveClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBRemoveClassVariableRefactoring variable: #RecursiveSelfRule1 class: RBTransformationRuleTest)! ! !RBRemoveClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRemoveClassVar | refactoring class | refactoring := RBRemoveClassVariableRefactoring variable: 'Foo1' class: RBLintRuleTest. class := refactoring model classNamed: #RBLintRuleTest. self assert: (class definesClassVariable: 'Foo1'). self executeRefactoring: refactoring. self deny: (class definesClassVariable: 'Foo1')! ! !RBRemoveClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testReferencedVariable self shouldFail: (RBRemoveClassVariableRefactoring variable: #RecursiveSelfRule class: RBTransformationRuleTest)! ! !RBRemoveInstanceVariableChange methodsFor: 'printing' stamp: 'lr 10/14/2010 20:53'! changeString ^ 'Remove instance variable <1s> from <2s>' expandMacrosWith: self variable with: self displayClassName! ! !RBRemoveInstanceVariableChange methodsFor: 'private' stamp: 'lr 3/20/2011 11:27'! changeSymbol ^ #removeInstVarNamed:! ! !RBRemoveInstanceVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBAddInstanceVariableChange add: self variable to: self changeClass! ! !RBRemoveInstanceVariableRefactoring methodsFor: 'preconditions' stamp: 'lr 9/8/2011 20:25'! preconditions | references | references := RBCondition hierarchyOf: class referencesInstanceVariable: variableName. class realClass isNil ifTrue: [references errorMacro: ('<1s> is referenced.' expandMacrosWith: variableName)] ifFalse: [references errorMacro: ('<1s> is referenced.Browse references?' expandMacrosWith: variableName); errorBlock: [self openBrowserOn: (RBBrowserEnvironment new instVarRefsTo: variableName in: class realClass)]]. ^(RBCondition definesInstanceVariable: variableName asString in: class) & references not! ! !RBRemoveInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''! transform class removeInstanceVariable: variableName! ! !RBRemoveInstanceVariableRefactoring class methodsFor: 'as yet unclassified' stamp: 'lr 1/20/2010 08:43'! remove: variable from: class ^ self variable: variable class: class! ! !RBRemoveInstanceVariableRefactoring class methodsFor: 'as yet unclassified' stamp: 'lr 1/20/2010 08:43'! model: aNamespace remove: variable from: class ^ self model: aNamespace variable: variable class: class! ! !RBRemoveInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testReferencedVariable self shouldFail: (RBRemoveInstanceVariableRefactoring variable: 'name' class: RBLintRuleTest)! ! !RBRemoveInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelRemoveInstanceVariable | class | model defineClass: 'nil subclass: #Object instanceVariableNames: ''foo1'' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. class := model classNamed: #Object. self assert: (class definesInstanceVariable: 'foo1'). self executeRefactoring: (RBRemoveInstanceVariableRefactoring model: model variable: 'foo1' class: class). self deny: (class definesInstanceVariable: 'foo1')! ! !RBRemoveInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBRemoveInstanceVariableRefactoring variable: 'name1' class: RBLintRuleTest)! ! !RBRemoveInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRemoveInstVar | refactoring class | refactoring := RBRemoveInstanceVariableRefactoring variable: 'foo1' class: RBLintRuleTest. class := refactoring model classNamed: #RBLintRuleTest. self assert: (class definesInstanceVariable: 'foo1'). self executeRefactoring: refactoring. self deny: (class definesInstanceVariable: 'foo1')! ! !RBRemoveMethodChange methodsFor: 'private' stamp: 'lr 9/7/2010 19:11'! selector ^ selector! ! !RBRemoveMethodChange methodsFor: 'comparing' stamp: 'lr 9/7/2010 19:11'! hash ^ selector hash! ! !RBRemoveMethodChange methodsFor: 'comparing' stamp: 'lr 9/7/2010 19:10'! = aRemoveMethodChange super = aRemoveMethodChange ifFalse: [ ^ false ]. ^ selector = aRemoveMethodChange selector! ! !RBRemoveMethodChange methodsFor: 'printing' stamp: 'lr 2/8/2008 09:29'! printOn: aStream aStream nextPutAll: self displayClassName; nextPutAll: ' removeSelector: '; print: self selector; nextPut: $!!! ! !RBRemoveMethodChange methodsFor: 'private' stamp: 'lr 9/7/2010 19:11'! primitiveExecute ^ self changeClass removeSelector: selector! ! !RBRemoveMethodChange methodsFor: 'printing' stamp: 'lr 4/7/2010 08:21'! changeString ^ 'Remove <1s>>>#<2s>' expandMacrosWith: self displayClassName with: selector! ! !RBRemoveMethodChange methodsFor: 'initialize-release' stamp: 'lr 9/7/2010 19:11'! selector: aSymbol selector := aSymbol! ! !RBRemoveMethodChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBAddMethodChange compile: (self methodSourceFor: selector) in: self changeClass! ! !RBRemoveMethodChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:45'! remove: aSymbol from: aClass ^ self new changeClass: aClass; selector: aSymbol; yourself! ! !RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(selectors inject: RBCondition empty into: [:cond :each | cond & (RBCondition definesSelector: each in: class)]) & (RBCondition withBlock: [self checkSuperMethods. true])! ! !RBRemoveMethodRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' removeMethods: '. selectors asArray storeOn: aStream. aStream nextPutAll: ' from: '. class storeOn: aStream. aStream nextPut: $)! ! !RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''! checkReferencesToSuperSendsToAnyOf: superMessages [superMessages isEmpty] whileFalse: [self refactoringWarning: ('Although <1s> is equivalent to a superclass method,it contains a super send so it might modify behavior.' expandMacrosWith: superMessages first). superMessages remove: superMessages first]! ! !RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: 'lr 11/2/2009 00:14'! justSendsSuper: aSelector | matcher parseTree superclass | matcher := RBParseTreeSearcher justSendsSuper. parseTree := class parseTreeFor: aSelector. (matcher executeTree: parseTree initialAnswer: false) ifFalse: [^false]. parseTree lastIsReturn ifTrue: [^true]. superclass := class superclass whichClassIncludesSelector: aSelector. superclass isNil ifTrue: [^true]. "Since there isn't a superclass that implements the message, we can delete it since it would be an error anyway." parseTree := superclass parseTreeFor: aSelector. matcher := RBParseTreeSearcher new. matcher matches: '^``@object' do: [:aNode :answer | answer add: aNode value; yourself]. matcher executeTree: parseTree initialAnswer: Set new. ^(matcher answer detect: [:each | (each isVariable and: [each name = 'self']) not] ifNone: [nil]) isNil! ! !RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''! superclassEquivalentlyDefines: aSelector | superTree myTree | class superclass isNil ifTrue: [^false]. superTree := class superclass parseTreeFor: aSelector. myTree := class parseTreeFor: aSelector. (superTree isNil or: [myTree isNil]) ifTrue: [^false]. ^superTree equalTo: myTree exceptForVariables: #()! ! !RBRemoveMethodRefactoring methodsFor: 'transforming' stamp: ''! transform selectors do: [:each | class removeMethod: each]! ! !RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: ''! checkSuperMethods | superMessages nonSupers | nonSupers := OrderedCollection new. superMessages := OrderedCollection new. (selectors reject: [:each | self justSendsSuper: each]) do: [:each | (self superclassEquivalentlyDefines: each) ifTrue: [(class parseTreeFor: each) superMessages isEmpty ifFalse: [superMessages add: each]] ifFalse: [nonSupers add: each]]. nonSupers isEmpty & superMessages isEmpty ifTrue: [^self]. self checkReferencesToAnyOf: nonSupers. self checkReferencesToSuperSendsToAnyOf: superMessages! ! !RBRemoveMethodRefactoring methodsFor: 'preconditions' stamp: 'lr 9/8/2011 20:25'! checkReferencesToAnyOf: aSelectorCollection aSelectorCollection do: [:each | self model allReferencesTo: each do: [:aRBMethod | (aSelectorCollection includes: aRBMethod selector) ifFalse: [self refactoringError: ('Possible call to <2s> in <1p>Browse references?' expandMacrosWith: aRBMethod modelClass with: each) with: [self openBrowserOn: (RBBrowserEnvironment new referencesTo: each)]]]]! ! !RBRemoveMethodRefactoring methodsFor: 'initialize-release' stamp: ''! removeMethods: selectorCollection from: aClass class := self classObjectFor: aClass. selectors := selectorCollection! ! !RBRemoveMethodRefactoring class methodsFor: 'instance creation' stamp: ''! removeMethods: selectorCollection from: aClass ^self new removeMethods: selectorCollection from: aClass! ! !RBRemoveMethodRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk removeMethods: selectorCollection from: aClass ^(self new) model: aRBSmalltalk; removeMethods: selectorCollection from: aClass; yourself! ! !RBRemoveMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testRemoveReferenced self shouldFail: (RBRemoveMethodRefactoring removeMethods: #(#checkClass: ) from: RBBasicLintRuleTest)! ! !RBRemoveMethodTest methodsFor: 'accessing' stamp: 'TestRunner 1/3/2010 12:35'! expectedFailures ^ #(testRemoveSameMethodButSendsSuper)! ! !RBRemoveMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testRemoveSameMethodButSendsSuper self shouldWarn: (RBRemoveMethodRefactoring removeMethods: #(#new ) from: RBBasicLintRuleTest class)! ! !RBRemoveMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRemoveMethod | refactoring selectors | selectors := Array with: ('selectorNot' , 'Referenced') asSymbol. refactoring := RBRemoveMethodRefactoring removeMethods: selectors from: RBRefactoryTestDataApp. self assert: ((refactoring model classNamed: #RBRefactoryTestDataApp) directlyDefinesMethod: selectors first). self executeRefactoring: refactoring. self deny: ((refactoring model classNamed: #RBRefactoryTestDataApp) directlyDefinesMethod: selectors first)! ! !RBRemoveMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelRecursiveMethodThatIsNotReferencedFromOtherMethods | class otherClass | class := model classNamed: #Object. class compile: 'someMethodThatIsNotReferenced ^2' classified: #(#accessing). self assert: (class definesMethod: #someMethodThatIsNotReferenced). otherClass := model metaclassNamed: self class superclass name. otherClass compile: 'someMethodThatIsNotReferenced ^3 someMethodThatIsNotReferenced' classified: #(#accessing). model removeClassNamed: self class name. self executeRefactoring: (RBRemoveMethodRefactoring model: model removeMethods: #(#someMethodThatIsNotReferenced) from: class). self deny: (class definesMethod: #someMethodThatIsNotReferenced)! ! !RBRemoveParameterRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:02'! hasReferencesToTemporaryIn: each | tree | tree := each parseTreeFor: oldSelector. tree isNil ifTrue: [self refactoringFailure: 'Cannot parse sources.']. ^tree references: (tree argumentNames at: parameterIndex)! ! !RBRemoveParameterRefactoring methodsFor: 'private' stamp: 'CamilloBruni 10/8/2012 00:03'! computeNewSelector | keywords stream | oldSelector numArgs == 0 ifTrue: [self refactoringFailure: 'This method contains no arguments']. oldSelector isInfix ifTrue: [self refactoringFailure: 'Cannot remove parameters of infix selectors']. keywords := oldSelector keywords asOrderedCollection. keywords size = 1 ifTrue: [^(keywords first copyWithout: $:) asSymbol]. keywords removeAt: parameterIndex. stream := WriteStream on: ''. keywords do: [:each | stream nextPutAll: each]. ^stream contents asSymbol! ! !RBRemoveParameterRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:03'! getNewSelector | tree | (class directlyDefinesMethod: oldSelector) ifFalse: [self refactoringFailure: 'Method doesn''t exist']. tree := class parseTreeFor: oldSelector. tree isNil ifTrue: [self refactoringFailure: 'Cannot parse sources']. parameterIndex := tree argumentNames indexOf: argument ifAbsent: [self refactoringFailure: 'Select a parameter!!!!']. permutation := (1 to: oldSelector numArgs) copyWithout: parameterIndex. newSelector := self computeNewSelector! ! !RBRemoveParameterRefactoring methodsFor: 'preconditions' stamp: 'lr 3/9/2010 16:08'! myConditions | imps | imps := self model allImplementorsOf: oldSelector. self getNewSelector. ^imps inject: (RBCondition definesSelector: oldSelector in: class) into: [:cond :each | cond & (RBCondition withBlock: [(self hasReferencesToTemporaryIn: each) not] errorString: 'This argument is still referenced in at least one implementor!!!!')]! ! !RBRemoveParameterRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' removeParameter: '''; nextPutAll: argument; nextPutAll: ''' in: '. class storeOn: aStream. aStream nextPutAll: ' selector: #'; nextPutAll: oldSelector. aStream nextPut: $)! ! !RBRemoveParameterRefactoring methodsFor: 'initialize-release' stamp: ''! removeParameter: aString in: aClass selector: aSelector oldSelector := aSelector. class := self classObjectFor: aClass. argument := aString! ! !RBRemoveParameterRefactoring class methodsFor: 'instance creation' stamp: ''! removeParameter: aString in: aClass selector: aSelector ^self new removeParameter: aString in: aClass selector: aSelector! ! !RBRemoveParameterRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk removeParameter: aString in: aClass selector: aSelector ^(self new) model: aRBSmalltalk; removeParameter: aString in: aClass selector: aSelector; yourself! ! !RBRemoveParameterTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testPrimitiveMethods | refactoring | (model classNamed: #Object) compile: 'foo123: a ^#() primitiveFailed' classified: #(#accessing). refactoring := RBRemoveParameterRefactoring model: model removeParameter: 'a' in: Object selector: #foo123:. self shouldFail: refactoring! ! !RBRemoveParameterTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRemoveParameter | refactoring class | refactoring := RBRemoveParameterRefactoring removeParameter: 'anArg' in: RBRefactoryTestDataApp selector: ('rename' , 'ThisMethod:') asSymbol. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBRefactoryTestDataApp. self assert: (class parseTreeFor: #renameThisMethod) = (RBParser parseMethod: 'renameThisMethod ^self'). self assert: (class parseTreeFor: #callMethod) = (RBParser parseMethod: 'callMethod ^(self renameThisMethod)'). self deny: (class directlyDefinesMethod: ('rename' , 'ThisMethod:') asSymbol)! ! !RBRemoveParameterTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBRemoveParameterRefactoring removeParameter: 'asdf' in: RBBasicLintRuleTest selector: #checkClass:); shouldFail: (RBRemoveParameterRefactoring removeParameter: 'aSmalllintContext' in: RBBasicLintRuleTest selector: #checkClass1:)! ! !RBRemovePoolVariableChange methodsFor: 'private' stamp: 'lr 9/6/2010 21:31'! changeSymbol ^ #removeSharedPool:! ! !RBRemovePoolVariableChange methodsFor: 'accessing' stamp: 'lr 10/15/2010 08:31'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !RBRemovePoolVariableChange methodsFor: 'printing' stamp: 'lr 4/7/2010 08:20'! changeString ^ 'Remove pool variable <1s> from <2s>' expandMacrosWith: self variable with: self displayClassName! ! !RBRemovePoolVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBAddPoolVariableChange add: self variable to: self changeClass! ! !RBRenameClassChange methodsFor: 'comparing' stamp: 'lr 5/18/2010 20:56'! hash ^ (self class hash bitXor: self oldName hash) bitXor: self newName hash! ! !RBRenameClassChange methodsFor: '*NautilusRefactoring' stamp: ''! nameToDisplay ^ self printString! ! !RBRenameClassChange methodsFor: 'comparing' stamp: 'lr 9/6/2010 17:33'! = aRenameClassChange super class = aRenameClassChange class ifFalse: [ ^ false ]. ^oldName = aRenameClassChange oldName and: [ newName = aRenameClassChange newName ]! ! !RBRenameClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:31'! oldName ^ oldName! ! !RBRenameClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:31'! newName ^ newName! ! !RBRenameClassChange methodsFor: 'printing' stamp: 'lr 2/7/2008 22:18'! printOn: aStream aStream nextPutAll: self oldName; nextPutAll: ' rename: '; print: self newName; nextPut: $!!! ! !RBRenameClassChange methodsFor: 'private' stamp: 'lr 9/6/2010 17:31'! executeNotifying: aBlock | undos | self changeClass rename: newName. undos := changes collect: [ :each | (each renameChangesForClass: oldName asSymbol to: newName asSymbol) executeNotifying: aBlock ]. ^ self copy changes: undos reverse; rename: newName to: oldName; yourself! ! !RBRenameClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:30'! changeClass ^ Smalltalk globals at: oldName asSymbol ifAbsent: [ Smalltalk globals at: newName asSymbol ]! ! !RBRenameClassChange methodsFor: '*NautilusRefactoring' stamp: ''! whatToDisplayIn: aChangeBrowser | result | result := OrderedCollection with: self. ^ result, (self changes gather: [:e | e changes ])! ! !RBRenameClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 13:57'! renameChangesForClass: oldClassName to: newClassName | change | change := super renameChangesForClass: oldClassName to: newClassName. oldName asSymbol = oldClassName ifTrue: [ change rename: newClassName to: newName ]. ^ change! ! !RBRenameClassChange methodsFor: '*NautilusRefactoring' stamp: ''! textToDisplay ^ self printString! ! !RBRenameClassChange methodsFor: 'initialize-release' stamp: ''! rename: oldString to: newString oldName := oldString. newName := newString! ! !RBRenameClassChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:43'! rename: oldString to: newString ^ self new rename: oldString to: newString; yourself! ! !RBRenameClassRefactoring methodsFor: 'transforming' stamp: ''! transform self model renameClass: class to: newName around: [self renameReferences]! ! !RBRenameClassRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition withBlock: [class notNil and: [class isMeta not]] errorString: className , ' is not a valid class name') & (RBCondition isValidClassName: newName) & (RBCondition isGlobal: newName in: self model) not! ! !RBRenameClassRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' rename: '. class storeOn: aStream. aStream nextPutAll: ' to: #'; nextPutAll: newName; nextPut: $)! ! !RBRenameClassRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:02'! renameReferences | replacer | replacer := (RBParseTreeRewriter replaceLiteral: className with: newName) replace: className with: newName; replaceArgument: newName withValueFrom: [:aNode | self refactoringFailure: newName , ' already exists within the reference scope']; yourself. self model allReferencesToClass: class do: [:method | (method modelClass hierarchyDefinesVariable: newName) ifTrue: [self refactoringFailure: newName , ' is already defined in hierarchy of ' , method modelClass printString]. self convertMethod: method selector for: method modelClass using: replacer]! ! !RBRenameClassRefactoring methodsFor: 'initialize-release' stamp: ''! className: aName newName: aNewName className := aName asSymbol. class := self model classNamed: className. newName := aNewName asSymbol! ! !RBRenameClassRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk rename: aClass to: aNewName ^(self new) model: aRBSmalltalk; className: aClass name newName: aNewName; yourself! ! !RBRenameClassRefactoring class methodsFor: 'instance creation' stamp: ''! rename: aClass to: aNewName ^self new className: aClass name newName: aNewName! ! !RBRenameClassTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadName self shouldFail: (RBRenameClassRefactoring rename: RBLintRuleTest to: self objectClassVariable); shouldFail: (RBRenameClassRefactoring rename: RBLintRuleTest to: #'Ob ject')! ! !RBRenameClassTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRenameClass | refactoring class | refactoring := RBRenameClassRefactoring rename: (Smalltalk at: ('RBClass' , 'ToRename') asSymbol) to: 'RBNew' , 'ClassName' asSymbol. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: ('RBNew' , 'ClassName') asSymbol) parseTreeFor: #method1) = (RBParser parseMethod: 'method1 ^self method2'). self deny: (refactoring model includesClassNamed: ('RBClass' , 'ToRename') asSymbol). class := refactoring model classNamed: ('RBSubclass' , 'OfClassToRename') asSymbol. self assert: class superclass = (refactoring model classNamed: ('RBNew' , 'ClassName') asSymbol). self assert: (class parseTreeFor: #symbolReference) = (RBParser parseMethod: 'symbolReference ^#RBNewClassName'). self assert: (class parseTreeFor: #reference) = (RBParser parseMethod: 'reference ^RBNewClassName new')! ! !RBRenameClassTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMetaClassFailure self shouldFail: (RBRenameClassRefactoring rename: self class class to: #Foo)! ! !RBRenameClassTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelRenameSequenceClass model defineClass: 'Object subclass: #Foo1 instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. (model classNamed: #Foo1) compile: 'foo ^ Foo1' classified: #(accessing); compile: 'objectName ^ #(Foo1)' classified: #(accessing). self executeRefactoring: (RBRenameClassRefactoring model: model rename: (model classNamed: #Foo1) to: #Foo2). self executeRefactoring: (RBRenameClassRefactoring model: model rename: (model classNamed: #Foo2) to: #Foo3). self deny: (model includesClassNamed: #Foo1). self deny: (model includesClassNamed: #Foo2). self assert: (model includesClassNamed: #Foo3). self assert: ((model classNamed: #Foo3) parseTreeFor: #foo) = (RBParser parseMethod: 'foo ^ Foo3'). self assert: ((model classNamed: #Foo3) parseTreeFor: #objectName) = (RBParser parseMethod: 'objectName ^ #(Foo3)')! ! !RBRenameClassTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testModelRenameClass | refactoring class | model defineClass: 'Object subclass: #Foo instanceVariableNames: ''a'' classVariableNames: '''' poolDictionaries: '''' category: #''Refactory-Test data'''. class := model classNamed: #Foo. class compile: 'foo ^Object' classified: #(#accessing); compile: 'objectName ^#(Object)' classified: #(#accessing). refactoring := RBRenameClassRefactoring model: model rename: Object to: #Thing. self executeRefactoring: refactoring. self assert: (model includesClassNamed: #Thing). self deny: (model includesClassNamed: #Object). self assert: (class parseTreeFor: #foo) = (RBParser parseMethod: 'foo ^Thing'). self assert: (class parseTreeFor: #objectName) = (RBParser parseMethod: 'objectName ^#(Thing)'). self assert: class superclass name = #Thing! ! !RBRenameClassTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testExistingName self shouldFail: (RBRenameClassRefactoring rename: self class to: #Object)! ! !RBRenameClassVariableChange methodsFor: 'private' stamp: 'lr 9/8/2011 20:10'! addNewVariable (RBAddClassVariableChange add: newName to: self changeClass) execute! ! !RBRenameClassVariableChange methodsFor: 'private' stamp: 'lr 9/6/2010 13:48'! copyOldValuesToNewVariable | oldValue | oldValue := self changeClass classPool at: oldName ifAbsent: [ nil ]. self changeClass classPool at: newName asSymbol put: oldValue! ! !RBRenameClassVariableChange methodsFor: 'printing' stamp: 'lr 5/18/2010 20:37'! printOn: aStream aStream nextPutAll: self displayClassName; nextPutAll: ' removeClassVarName: '; print: self oldName; nextPut: $!!; cr. aStream nextPutAll: self displayClassName; nextPutAll: ' addClassVarName: '; print: self newName; nextPut: $!!! ! !RBRenameClassVariableChange methodsFor: 'private' stamp: 'lr 9/8/2011 20:10'! removeOldVariable (RBRemoveClassVariableChange remove: oldName from: self changeClass) execute! ! !RBRenameClassVariableRefactoring methodsFor: 'transforming' stamp: ''! transform class renameClassVariable: variableName to: newName around: [self renameReferences]! ! !RBRenameClassVariableRefactoring methodsFor: 'initialize-release' stamp: ''! rename: aVarName to: aName in: aClass self variable: aVarName class: aClass. newName := aName! ! !RBRenameClassVariableRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition isMetaclass: class) not & (RBCondition isValidClassVarName: newName asString for: class) & (RBCondition definesClassVariable: variableName asString in: class) & (RBCondition hierarchyOf: class definesVariable: newName asString) not & (RBCondition isGlobal: newName asString in: self model) not! ! !RBRenameClassVariableRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! renameReferences | replacer subclasses | replacer := RBParseTreeRewriter rename: variableName to: newName handler: [ self refactoringError: ('<1s> is already defined as a method or block temporary variable in this class or one of its subclasses' expandMacrosWith: newName) ]. subclasses := class withAllSubclasses asSet. subclasses addAll: class theMetaClass withAllSubclasses. self convertClasses: subclasses select: [ :aClass | aClass whichSelectorsReferToClassVariable: variableName ] using: replacer! ! !RBRenameClassVariableRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' rename: '''; nextPutAll: variableName; nextPutAll: ''' to: '''; nextPutAll: newName; nextPutAll: ''' in: '. class storeOn: aStream. aStream nextPut: $)! ! !RBRenameClassVariableRefactoring class methodsFor: 'instance creation' stamp: ''! rename: aVarName to: aName in: aClass ^self new rename: aVarName to: aName in: aClass! ! !RBRenameClassVariableRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk rename: aVarName to: aName in: aClass ^(self new) model: aRBSmalltalk; rename: aVarName to: aName in: aClass; yourself! ! !RBRenameClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMetaClassFailure self shouldFail: (RBRenameClassVariableRefactoring rename: #RecursiveSelfRule to: #Foo in: RBTransformationRuleTest class)! ! !RBRenameClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBRenameClassVariableRefactoring rename: #foo to: #newFoo in: RBBasicLintRuleTest)! ! !RBRenameClassVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRenameClassVar | refactoring class | refactoring := RBRenameClassVariableRefactoring rename: #RecursiveSelfRule to: #RSR in: RBTransformationRuleTest. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBTransformationRuleTest. self assert: (class directlyDefinesClassVariable: #RSR). self deny: (class directlyDefinesClassVariable: #RecursiveSelfRule). self assert: (class theMetaClass parseTreeFor: #initializeAfterLoad1) = (RBParser parseMethod: 'initializeAfterLoad1 RSR := RBParseTreeSearcher new. RSR addMethodSearches: #(''`@methodName: `@args | `@temps | self `@methodName: `@args'' ''`@methodName: `@args | `@temps | ^self `@methodName: `@args'') -> [:aNode :answer | true]'). self assert: (class theMetaClass parseTreeFor: #nuke) = (RBParser parseMethod: 'nuke RSR := nil'). self assert: (class parseTreeFor: #checkMethod:) = (RBParser parseMethod: 'checkMethod: aSmalllintContext class := aSmalllintContext selectedClass. (rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: [(RSR executeTree: rewriteRule tree initialAnswer: false) ifFalse: [builder compile: rewriteRule tree printString in: class classified: aSmalllintContext protocols]]')! ! !RBRenameClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testAlreadyExistingName self shouldFail: (RBRenameClassVariableRefactoring rename: #RecursiveSelfRule to: self objectClassVariable in: RBTransformationRuleTest)! ! !RBRenameInstanceVariableChange methodsFor: 'private' stamp: 'lr 9/8/2011 20:10'! addNewVariable (RBAddInstanceVariableChange add: newName to: self changeClass) execute! ! !RBRenameInstanceVariableChange methodsFor: 'private' stamp: 'lr 9/6/2010 13:48'! copyOldValuesToNewVariable | newIndex oldIndex | oldIndex := self changeClass allInstVarNames indexOf: oldName asString. newIndex := self changeClass allInstVarNames indexOf: newName asString. self changeClass withAllSubclasses do: [ :class | class allInstances do: [ :each | each instVarAt: newIndex put: (each instVarAt: oldIndex) ] ]! ! !RBRenameInstanceVariableChange methodsFor: 'printing' stamp: 'lr 5/18/2010 20:39'! printOn: aStream aStream nextPutAll: self displayClassName; nextPutAll: ' removeInstVarName: '; print: self oldName; nextPut: $!!; cr. aStream nextPutAll: self displayClassName; nextPutAll: ' addInstVarName: '; print: self newName; nextPut: $!!! ! !RBRenameInstanceVariableChange methodsFor: 'private' stamp: 'lr 9/8/2011 20:10'! removeOldVariable (RBRemoveInstanceVariableChange remove: oldName from: self changeClass) execute! ! !RBRenameInstanceVariableRefactoring methodsFor: 'transforming' stamp: ''! transform class renameInstanceVariable: variableName to: newName around: [self renameReferences]! ! !RBRenameInstanceVariableRefactoring methodsFor: 'initialize-release' stamp: ''! rename: aVarName to: aName in: aClass self variable: aVarName class: aClass. newName := aName! ! !RBRenameInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition isValidInstanceVariableName: newName for: class) & (RBCondition definesInstanceVariable: variableName in: class) & (RBCondition hierarchyOf: class definesVariable: newName) not & (RBCondition isGlobal: newName in: self model) not! ! !RBRenameInstanceVariableRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! renameReferences | replacer | replacer := RBParseTreeRewriter rename: variableName to: newName handler: [self refactoringError: ('<1s> is already defined as a method or block temporary variable in this class or one of its subclasses' expandMacrosWith: newName)]. self convertClasses: class withAllSubclasses select: [:aClass | aClass whichSelectorsReferToInstanceVariable: variableName] using: replacer! ! !RBRenameInstanceVariableRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' rename: '''; nextPutAll: variableName; nextPutAll: ''' to: '''; nextPutAll: newName; nextPutAll: ''' in: '. class storeOn: aStream. aStream nextPut: $)! ! !RBRenameInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''! rename: aVarName to: aName in: aClass ^self new rename: aVarName to: aName in: aClass! ! !RBRenameInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk rename: aVarName to: aName in: aClass ^(self new) model: aRBSmalltalk; rename: aVarName to: aName in: aClass; yourself! ! !RBRenameInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testAlreadyExistingName self shouldFail: (RBRenameInstanceVariableRefactoring rename: 'classBlock' to: 'name' in: RBBasicLintRuleTest)! ! !RBRenameInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBRenameInstanceVariableRefactoring rename: 'foo' to: 'newFoo' in: RBBasicLintRuleTest)! ! !RBRenameInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 22:52'! testRenameInstVar | refactoring class | refactoring := RBRenameInstanceVariableRefactoring rename: 'classBlock' to: 'asdf' in: RBBasicLintRuleTest. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBBasicLintRuleTest. self assert: (class directlyDefinesInstanceVariable: 'asdf'). self deny: (class directlyDefinesInstanceVariable: 'classBlock'). self assert: (class parseTreeFor: #checkClass:) = (RBParser parseMethod: 'checkClass: aSmalllintContext ^asdf value: aSmalllintContext value: result'). self assert: (class parseTreeFor: #classBlock:) = (RBParser parseMethod: 'classBlock: aBlock asdf := aBlock testMethod1'). self assert: (class parseTreeFor: #initialize) = (RBParser parseMethod: 'initialize super initialize. asdf := [:context :aResult | ]. methodBlock := [:context :aResult | ]. self resultClass: RBSelectorEnvironment.')! ! !RBRenameMethodRefactoring methodsFor: 'transforming' stamp: 'lr 11/2/2009 00:14'! parseTreeRewriter | rewriteRule oldString newString | oldString := self buildSelectorString: oldSelector. newString := self buildSelectorString: newSelector withPermuteMap: permutation. rewriteRule := self hasPermutedArguments ifTrue: [RBParseTreeRewriter new] ifFalse: [RBParseTreeRewriter replaceLiteral: oldSelector with: newSelector]. rewriteRule replace: '``@object ' , oldString with: '``@object ' , newString. ^rewriteRule! ! !RBRenameMethodRefactoring methodsFor: 'testing' stamp: ''! hasPermutedArguments ^hasPermutedArguments isNil ifTrue: [hasPermutedArguments := super hasPermutedArguments] ifFalse: [hasPermutedArguments]! ! !RBRenameMethodRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/7/2012 23:32'! preconditions | newCondition | newCondition := (RBCondition withBlock: [newSelector = oldSelector] errorString: 'The selectors are <1?:not >equivalent') & (RBCondition withBlock: [permutation asArray ~= (1 to: oldSelector numArgs) asArray] errorString: 'The arguments are <1?:not >permuted'). ^newCondition | super preconditions! ! !RBRenameMethodRefactoring methodsFor: 'preconditions' stamp: ''! myConditions ^RBCondition withBlock: [oldSelector numArgs = newSelector numArgs] errorString: newSelector printString , ' doesn''t have the correct number of arguments.'! ! !RBRenameMethodRefactoring methodsFor: 'printing' stamp: 'lr 3/9/2010 16:09'! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' renameMethod: #'; nextPutAll: oldSelector; nextPutAll: ' in: '. class storeOn: aStream. aStream nextPutAll: ' to: #'; nextPutAll: newSelector; nextPutAll: ' permutation: '. permutation storeOn: aStream. aStream nextPut: $)! ! !RBRenameMethodRefactoring methodsFor: 'testing' stamp: ''! implementorsCanBePrimitives ^self hasPermutedArguments not! ! !RBRenameMethodRefactoring class methodsFor: 'instance creation' stamp: 'md 3/15/2006 17:26'! renameMethod: aSelector in: aClass to: newSelector permutation: aMap ^self new renameMethod: aSelector in: aClass to: newSelector permutation: aMap! ! !RBRenameMethodRefactoring class methodsFor: 'instance creation' stamp: 'md 3/15/2006 17:29'! model: aRBSmalltalk renameMethod: aSelector in: aClass to: newSelector permutation: aMap ^(self new) model: aRBSmalltalk; renameMethod: aSelector in: aClass to: newSelector permutation: aMap; yourself! ! !RBRenameMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRenameTestMethod1 | refactoring class | refactoring := RBRenameMethodRefactoring renameMethod: ('test' , 'Method1') asSymbol in: RBRefactoryTestDataApp to: #testMethod2 permutation: (1 to: 0). self executeRefactoring: refactoring. class := refactoring model classNamed: #RBRefactoryTestDataApp. self assert: (class parseTreeFor: #testMethod2) = (RBParser parseMethod: 'testMethod2 ^self testMethod2 , ([:each | each testMethod2] value: #(#(#testMethod2) 2 #testMethod2))'). self assert: ((refactoring model classNamed: #RBBasicLintRuleTest) parseTreeFor: #classBlock:) = (RBParser parseMethod: 'classBlock: aBlock classBlock := aBlock testMethod2'). self deny: (class directlyDefinesMethod: ('test' , 'Method1') asSymbol)! ! !RBRenameMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testExistingSelector self shouldFail: (RBRenameMethodRefactoring renameMethod: #checkClass: in: RBBasicLintRuleTest to: #runOnEnvironment: permutation: (1 to: 1))! ! !RBRenameMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRenamePrimitive | refactoring count | count := 0. model allReferencesTo: #basicAt:put: do: [:method | count := count + 1]. refactoring := RBRenameMethodRefactoring model: model renameMethod: #basicAt:put: in: Object to: ('at:' , 'bar:') asSymbol permutation: (1 to: 2). self proceedThroughWarning: [self executeRefactoring: refactoring]. model allReferencesTo: #basicAt:put: do: [:method | count := count - 1. self assert: method source isNil]. model allReferencesTo: ('at:' , 'bar:') asSymbol do: [:method | count := count - 1]. self assert: count = 0! ! !RBRenameMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMultipleSelectors self shouldWarn: (RBRenameMethodRefactoring renameMethod: #checkClass: in: RBBasicLintRuleTest to: #foo: permutation: (1 to: 1))! ! !RBRenameMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRenameTestMethod | refactoring class | refactoring := RBRenameMethodRefactoring renameMethod: ('rename' , 'ThisMethod:') asSymbol in: RBRefactoryTestDataApp to: #renameThisMethod2: permutation: (1 to: 1). self executeRefactoring: refactoring. class := refactoring model classNamed: #RBRefactoryTestDataApp. self assert: (class parseTreeFor: #renameThisMethod2:) = (RBParser parseMethod: 'renameThisMethod2: anArg ^self'). self assert: (class parseTreeFor: #callMethod) = (RBParser parseMethod: 'callMethod ^(self renameThisMethod2: 5)'). self assert: (class parseTreeFor: #symbolReference) = (RBParser parseMethod: 'symbolReference ^ #(#renameThisMethod2: #(4 #renameThisMethod2:))'). self deny: (class directlyDefinesMethod: ('rename' , 'ThisMethod:') asSymbol)! ! !RBRenameMethodTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRenamePermuteArgs | refactoring class | refactoring := RBRenameMethodRefactoring renameMethod: ('rename:' , 'two:') asSymbol in: RBRefactoryTestDataApp to: ('rename:' , 'two:') asSymbol permutation: #(2 1 ). self executeRefactoring: refactoring. class := refactoring model classNamed: #RBRefactoryTestDataApp. self assert: (class parseTreeFor: ('rename:' , 'two:') asSymbol) = (RBParser parseMethod: 'rename: argumentMethod two: this ^self printString, this, argumentMethod'). self assert: (class parseTreeFor: #exampleCall) = (RBParser parseMethod: 'exampleCall ^self rename: 2 two: 1')! ! !RBRenameTemporaryRefactoring methodsFor: 'initialize-release' stamp: ''! class: aClass selector: aSelector interval: anInterval newName: aString class := self classObjectFor: aClass. selector := aSelector. interval := anInterval. newName := aString! ! !RBRenameTemporaryRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:02'! preconditions ^(RBCondition definesSelector: selector in: class) & (RBCondition isValidInstanceVariableName: newName for: class) & (RBCondition definesInstanceVariable: newName in: class) not & (RBCondition definesClassVariable: newName in: class) not & (RBCondition withBlock: [| methodSource | interval first > interval last ifTrue: [self refactoringFailure: 'Invalid variable name']. methodSource := class sourceCodeFor: selector. methodSource size >= interval last ifFalse: [self refactoringFailure: 'Invalid range for variable']. oldName := methodSource copyFrom: interval first to: interval last. true])! ! !RBRenameTemporaryRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' renameTemporaryFrom: '. interval storeOn: aStream. aStream nextPutAll: ' to: '''; nextPutAll: newName; nextPutAll: ''' in: '. class storeOn: aStream. aStream nextPutAll: ' selector: #'; nextPutAll: selector. aStream nextPut: $)! ! !RBRenameTemporaryRefactoring methodsFor: 'tranforming' stamp: 'CamilloBruni 10/8/2012 00:01'! renameNode: aParseTree (aParseTree whoDefines: newName) notNil ifTrue: [self refactoringError: newName , ' is already defined']. (aParseTree allDefinedVariables includes: newName) ifTrue: [self refactoringError: newName , ' is already defined']. (RBParseTreeRewriter rename: oldName to: newName) executeTree: aParseTree! ! !RBRenameTemporaryRefactoring methodsFor: 'tranforming' stamp: 'CamilloBruni 10/8/2012 00:01'! transform | definingNode variableNode | parseTree := class parseTreeFor: selector. variableNode := self whichVariableNode: parseTree inInterval: interval name: oldName. (variableNode isNil or: [variableNode isVariable not]) ifTrue: [self refactoringFailure: oldName , ' isn''t a valid variable']. variableNode name = oldName ifFalse: [self refactoringFailure: 'Invalid selection']. definingNode := variableNode whoDefines: oldName. definingNode isNil ifTrue: [self refactoringFailure: oldName , ' isn''t defined by the method']. self renameNode: definingNode. class compileTree: parseTree! ! !RBRenameTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''! renameTemporaryFrom: anInterval to: newName in: aClass selector: aSelector ^self new class: aClass selector: aSelector interval: anInterval newName: newName! ! !RBRenameTemporaryRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk renameTemporaryFrom: anInterval to: newName in: aClass selector: aSelector ^(self new) model: aRBSmalltalk; class: aClass selector: aSelector interval: anInterval newName: newName; yourself! ! !RBRenameTemporaryTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadName self shouldFail: (RBRenameTemporaryRefactoring renameTemporaryFrom: (self convertInterval: (15 to: 19) for: (RBLintRuleTest sourceCodeAt: #openEditor)) to: 'name' in: RBLintRuleTest selector: #openEditor); shouldFail: (RBRenameTemporaryRefactoring renameTemporaryFrom: (self convertInterval: (15 to: 19) for: (RBLintRuleTest sourceCodeAt: #openEditor)) to: 'rules' in: RBLintRuleTest selector: #openEditor); shouldFail: (RBRenameTemporaryRefactoring renameTemporaryFrom: (self convertInterval: (15 to: 19) for: (RBLintRuleTest sourceCodeAt: #openEditor)) to: 'DependentFields' in: RBLintRuleTest selector: #openEditor); shouldFail: (RBRenameTemporaryRefactoring renameTemporaryFrom: (self convertInterval: (15 to: 19) for: (RBLintRuleTest sourceCodeAt: #openEditor)) to: 'a b' in: RBLintRuleTest selector: #openEditor)! ! !RBRenameTemporaryTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelBadName | class | model := RBNamespace new. class := model classNamed: #Object. class compile: 'aMethod: temp1 ^[| temp2 | temp2 := [:temp3 | temp3 = 5] value: 5. temp2] value' classified: #(#accessing). self shouldFail: (RBRenameTemporaryRefactoring renameTemporaryFrom: (20 to: 24) to: 'temp3' in: class selector: #aMethod:); shouldFail: (RBRenameTemporaryRefactoring renameTemporaryFrom: (20 to: 24) to: 'temp1' in: class selector: #aMethod:)! ! !RBRenameTemporaryTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testBadInterval self shouldFail: (RBRenameTemporaryRefactoring renameTemporaryFrom: (self convertInterval: (14 to: 17) for: (RBRefactoryTestDataApp sourceCodeAt: #testMethod)) to: 'asdf' in: RBRefactoryTestDataApp selector: #testMethod)! ! !RBRenameTemporaryTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testRenameTemporary | refactoring | refactoring := RBRenameTemporaryRefactoring renameTemporaryFrom: (self convertInterval: (15 to: 19) for: (RBLintRuleTest sourceCodeAt: #openEditor)) to: 'asdf' in: RBLintRuleTest selector: #openEditor. self executeRefactoring: refactoring. self assert: ((refactoring model classNamed: #RBLintRuleTest) parseTreeFor: #openEditor) = (RBParser parseMethod: 'openEditor | asdf | asdf := self failedRules. asdf isEmpty ifTrue: [^self]. asdf size == 1 ifTrue: [^asdf first viewResults]')! ! !RBRenameVariableChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:32'! changeClassName: aSymbol className := aSymbol. isMeta isNil ifTrue: [ isMeta := false ]! ! !RBRenameVariableChange methodsFor: 'printing' stamp: 'lr 9/6/2010 21:17'! displayClassName ^ isMeta ifTrue: [ self changeClassName , ' class' ] ifFalse: [ self changeClassName asString ]! ! !RBRenameVariableChange methodsFor: 'comparing' stamp: 'lr 9/6/2010 17:33'! hash ^ (self class hash bitXor: self oldName hash) bitXor: self newName hash! ! !RBRenameVariableChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:32'! changeClassName ^ className! ! !RBRenameVariableChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:32'! oldName ^ oldName! ! !RBRenameVariableChange methodsFor: 'private' stamp: 'lr 9/6/2010 13:46'! isMeta ^ isMeta! ! !RBRenameVariableChange methodsFor: 'private' stamp: 'lr 9/6/2010 13:46'! executeNotifying: aBlock | undo | self addNewVariable. self copyOldValuesToNewVariable. undo := super executeNotifying: aBlock. undo oldName: newName; newName: oldName. self removeOldVariable. ^ undo! ! !RBRenameVariableChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:32'! changeClass | class | class := Smalltalk globals at: self changeClassName ifAbsent: [ ^ nil ]. ^ isMeta ifTrue: [ class class ] ifFalse: [ class ]! ! !RBRenameVariableChange methodsFor: 'private' stamp: ''! addNewVariable self subclassResponsibility! ! !RBRenameVariableChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:32'! changeClass: aBehavior isMeta := aBehavior isMeta. className := isMeta ifTrue: [ aBehavior soleInstance name ] ifFalse: [ aBehavior name ]! ! !RBRenameVariableChange methodsFor: 'printing' stamp: 'lr 9/6/2010 17:34'! changeString ^ 'Rename ' , oldName , ' to ' , newName! ! !RBRenameVariableChange methodsFor: 'private' stamp: ''! copyOldValuesToNewVariable self subclassResponsibility! ! !RBRenameVariableChange methodsFor: 'private' stamp: ''! oldName: aString oldName := aString! ! !RBRenameVariableChange methodsFor: '*NautilusRefactoring' stamp: ''! nameToDisplay ^ 'Rename ', self oldName, ' into ', self newName! ! !RBRenameVariableChange methodsFor: 'comparing' stamp: 'lr 9/6/2010 17:34'! = aRenameVariableChange self class = aRenameVariableChange class ifFalse: [ ^ false ]. ^ className = aRenameVariableChange changeClassName and: [ isMeta = aRenameVariableChange isMeta and: [ oldName = aRenameVariableChange oldName and: [ newName = aRenameVariableChange newName ] ] ]! ! !RBRenameVariableChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:32'! newName ^ newName! ! !RBRenameVariableChange methodsFor: 'printing' stamp: 'lr 9/6/2010 13:55'! printOn: aStream aStream nextPutAll: self displayString! ! !RBRenameVariableChange methodsFor: 'private' stamp: ''! newName: aString newName := aString! ! !RBRenameVariableChange methodsFor: 'private' stamp: ''! removeOldVariable self subclassResponsibility! ! !RBRenameVariableChange methodsFor: '*NautilusRefactoring' stamp: ''! whatToDisplayIn: aChangeBrowser | result | result := OrderedCollection with: self. ^ result, (self changes gather: [:e | e changes ])! ! !RBRenameVariableChange methodsFor: '*NautilusRefactoring' stamp: ''! textToDisplay self printString! ! !RBRenameVariableChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:43'! rename: oldName to: newName in: aClass ^ self new oldName: oldName; newName: newName; changeClass: aClass; yourself! ! !RBRepeteadMethodsInTheSuperclassRule commentStamp: ''! See my #rationale.! !RBRepeteadMethodsInTheSuperclassRule methodsFor: 'running' stamp: 'CamilloBruni 8/28/2013 03:12'! find: selector inSuperclassesOf: selectedClass do: aBlock selectedClass allSuperclassesDo: [ :superclass | (superclass includesSelector: selector) ifTrue: [ ^ aBlock value: superclass ]]! ! !RBRepeteadMethodsInTheSuperclassRule methodsFor: 'accessing' stamp: 'CamilloBruni 8/28/2013 03:00'! rationale ^ 'If a class is overriding a method, it should use a different code. Is meaningless to have a method in a class and in its superclass'! ! !RBRepeteadMethodsInTheSuperclassRule methodsFor: 'accessing' stamp: 'SebastianTleye 7/19/2013 13:40'! name ^ 'Repeated method in the superclasses'! ! !RBRepeteadMethodsInTheSuperclassRule methodsFor: 'running' stamp: 'CamilloBruni 8/28/2013 03:21'! checkClass: aContext "The comparison between methods is made using the ast, this is better than comparing source code only since it does not take into account identations, extra parenthesis, etc" | selectedClass | selectedClass := aContext selectedClass. selectedClass methodsDo: [ :method | | selector | selector := method selector. self find: selector inSuperclassesOf: selectedClass do: [ :overriddenSuperclass | method ast = (overriddenSuperclass >> selector) ast ifTrue: [ result addClass: selectedClass selector: selector ] ] ]! ! !RBReplaceRule commentStamp: 'md 8/9/2005 14:56'! RBReplaceRule is the abstract superclass of all of the transforming rules. The rules change the source code by replacing the node that matches the rule. Subclasses implement different strategies for this replacement. Subclasses must implement the following messages: matching foundMatchFor: Instance Variables: verificationBlock Is evaluated with the matching node. This allows for further verification of a match beyond simple tree matching. ! !RBReplaceRule methodsFor: 'initialization' stamp: ''! initialize super initialize. verificationBlock := [:aNode | true]! ! !RBReplaceRule methodsFor: 'matching' stamp: ''! replace: aProgramNode with: newNode aProgramNode replaceMethodSource: newNode! ! !RBReplaceRule methodsFor: 'matching' stamp: 'StephaneDucasse 3/29/2013 18:00'! searchFor: searchString replaceWith: replaceString self subclassResponsibility! ! !RBReplaceRule methodsFor: 'matching' stamp: ''! canMatch: aProgramNode ^verificationBlock value: aProgramNode! ! !RBReplaceRule methodsFor: 'matching' stamp: 'StephaneDucasse 3/29/2013 18:01'! searchForMethod: searchString replaceWith: replaceString self subclassResponsibility! ! !RBReplaceRule methodsFor: 'matching' stamp: 'StephaneDucasse 3/29/2013 18:01'! searchForTree: aBRProgramNode replaceWith: replaceNode self subclassResponsibility! ! !RBReplaceRule methodsFor: 'matching' stamp: 'StephaneDucasse 3/29/2013 18:01'! searchForTree: aBRProgramNode replaceWith: replaceString when: aBlock self subclassResponsibility! ! !RBReplaceRule methodsFor: 'matching' stamp: ''! foundMatchFor: aProgramNode self subclassResponsibility! ! !RBReplaceRule methodsFor: 'matching' stamp: 'StephaneDucasse 3/29/2013 18:01'! searchForMethod: searchString replaceWith: replaceString when: aBlock self subclassResponsibility! ! !RBReplaceRule methodsFor: 'matching' stamp: 'StephaneDucasse 3/29/2013 18:01'! searchFor: searchString replaceWith: replaceString when: aBlock self subclassResponsibility! ! !RBReturnInEnsureRule methodsFor: 'initialization' stamp: 'lr 11/19/2009 14:48'! initialize | returnMatcher | super initialize. returnMatcher := RBParseTreeSearcher new. returnMatcher matches: '^ `@object' do: [ :node :answer | true ]. self matcher matchesAnyOf: #( '``@rcv ensure: [| `@temps | ``@.Stmts]' '``@rcv ifCurtailed: [| `@temps | ``@.Stmts]') do: [ :node :answer | answer isNil ifTrue: [ (returnMatcher executeTree: node arguments first initialAnswer: false) ifTrue: [ node ] ifFalse: [ nil ] ] ifFalse: [ answer ] ]! ! !RBReturnInEnsureRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:51'! rationale ^ 'Checks for return statements within ensure: blocks that can have unintended side-effects.'! ! !RBReturnInEnsureRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBReturnInEnsureRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Contains a return in an ensure: block'! ! !RBReturnInEnsureRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:27'! category ^ 'Potential Bugs'! ! !RBReturnInEnsureRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ReturnInEnsureRule'! ! !RBReturnNode commentStamp: ''! RBReturnNode is an AST node that represents a return expression. Instance Variables: return the position of the ^ character value the value that is being returned ! !RBReturnNode methodsFor: 'comparing' stamp: ''! hash ^self value hash! ! !RBReturnNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:35'! copyInContext: aDictionary ^ self class new value: (self value copyInContext: aDictionary); yourself! ! !RBReturnNode methodsFor: 'testing' stamp: ''! containsReturn ^true! ! !RBReturnNode methodsFor: 'accessing' stamp: ''! children ^Array with: value! ! !RBReturnNode methodsFor: 'testing' stamp: ''! isReturn ^true! ! !RBReturnNode methodsFor: 'replacing' stamp: ''! replaceNode: aNode withNode: anotherNode value == aNode ifTrue: [self value: anotherNode]! ! !RBReturnNode methodsFor: 'accessing' stamp: ''! stop ^value stop! ! !RBReturnNode methodsFor: 'comparing' stamp: ''! equalTo: anObject withMapping: aDictionary ^self class = anObject class and: [self value equalTo: anObject value withMapping: aDictionary]! ! !RBReturnNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:38'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitReturnNode: self! ! !RBReturnNode methodsFor: 'converting' stamp: 'MarcusDenker 1/29/2013 14:22'! asSequenceNode ^RBSequenceNode statements: {self} ! ! !RBReturnNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:30'! isFaulty ^self value isFaulty.! ! !RBReturnNode methodsFor: 'accessing' stamp: ''! value ^value! ! !RBReturnNode methodsFor: 'comparing' stamp: ''! = anObject self == anObject ifTrue: [^true]. self class = anObject class ifFalse: [^false]. ^self value = anObject value! ! !RBReturnNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:34'! postCopy super postCopy. self value: self value copy! ! !RBReturnNode methodsFor: 'accessing' stamp: ''! start ^return! ! !RBReturnNode methodsFor: 'matching' stamp: 'lr 5/30/2010 11:35'! match: aNode inContext: aDictionary aNode class = self class ifFalse: [^false]. ^value match: aNode value inContext: aDictionary! ! !RBReturnNode methodsFor: 'accessing' stamp: ''! value: valueNode value := valueNode. value parent: self! ! !RBReturnNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:21'! return: anInteger return := anInteger! ! !RBReturnNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:21'! return ^ return! ! !RBReturnNode methodsFor: 'initialize-release' stamp: ''! return: returnInteger value: aValueNode return := returnInteger. self value: aValueNode! ! !RBReturnNode class methodsFor: 'instance creation' stamp: ''! return: returnInteger value: aValueNode ^self new return: returnInteger value: aValueNode! ! !RBReturnNode class methodsFor: 'instance creation' stamp: ''! value: aNode ^self return: nil value: aNode! ! !RBReturnsBooleanAndOtherRule commentStamp: ''! See my #rationale.! !RBReturnsBooleanAndOtherRule methodsFor: 'initialization' stamp: 'lr 11/2/2009 00:14'! initialize super initialize. matcher := RBParseTreeSearcher new. matcher matches: '^ ``@object' do: [ :node :answer | answer add: node value; yourself ]! ! !RBReturnsBooleanAndOtherRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 11:22'! category ^ 'Potential Bugs'! ! !RBReturnsBooleanAndOtherRule methodsFor: '*Manifest-Core' stamp: 'ah 8/6/2012 13:16'! longDescription ^ 'This smell arises when a method return a boolean value (true or false) and return some other value such as (nil or self). If the method is suppose to return a boolean, then this signifies that there is one path through the method that might return a non-boolean. If the method doesn''t need to return a boolean, it should be probably rewriten to return some non-boolean value since other programmers reading the method might assume that it returns a boolean.'! ! !RBReturnsBooleanAndOtherRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:27'! rationale ^ 'Checks for methods that return a boolean value (true or false) and return some other value such as (nil or self). If the method is supposed to return a boolean, then this signifies that there is one path through the method that might return a non-boolean. If the method doesn''t need to return a boolean, you should probably rewrite it to return some non-boolean value since other programmers reading your method might assume that it returns a boolean.'! ! !RBReturnsBooleanAndOtherRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBReturnsBooleanAndOtherRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Returns a boolean and non boolean'! ! !RBReturnsBooleanAndOtherRule methodsFor: 'running' stamp: 'MarcusDenker 9/20/2013 15:08'! checkMethod: aContext | hasBool hasSelf | hasBool := false. hasSelf := aContext parseTree lastIsReturn not. (matcher executeTree: aContext parseTree initialAnswer: Set new) do: [ :each | hasBool := hasBool or: [ (each isLiteralNode and: [ #(true false) includes: each value ]) or: [ (each isMessage and: [ #(and: or:) includes: each selector ]) ] ]. hasSelf := hasSelf or: [ (each isVariable and: [ each name = 'self' ]) or: [ (each isLiteralNode and: [ (#(true false) includes: each value) not ]) ] ] ]. (hasSelf and: [ hasBool ]) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBReturnsBooleanAndOtherRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ReturnsBooleanAndOtherRule'! ! !RBReturnsIfTrueRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:34'! initialize super initialize. self matcher matchesAnyOf: #( '^`@condition ifTrue: [| `@temps | `@.statements]' '^`@condition ifFalse: [| `@temps | `@.statements]' ) do: [ :node :answer | node ]! ! !RBReturnsIfTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for methods that return the value of an ifTrue: or ifFalse: message. These statements return nil when the block is not executed.'! ! !RBReturnsIfTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBReturnsIfTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Returns value of ifTrue:/ifFalse: without ifFalse:/ifTrue: block'! ! !RBReturnsIfTrueRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:27'! category ^ 'Potential Bugs'! ! !RBReturnsIfTrueRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ReturnsIfTrueRule'! ! !RBScanner commentStamp: ''! RBScanner is a stream that returns a sequence of token from the string that it is created on. The tokens know where they came from in the source code and which comments were attached to them. Instance Variables: buffer Accumulates the text for the current token. characterType The type of the next character. (e.g. #alphabetic, etc.) classificationTable Mapping from Character values to their characterType. comments Source intervals of scanned comments that must be attached to the next token. currentCharacter The character currently being processed. errorBlock The block to execute on lexical errors. extendedLiterals True if IBM-type literals are allowed. In VW, this is false. nameSpaceCharacter The character used to separate namespaces. numberType The method to perform: to scan a number. separatorsInLiterals True if separators are allowed within literals. stream Contains the text to be scanned. tokenStart The source position of the beginning of the current token Class Instance Variables: classificationTable the default classification table for all characters Shared Variables: PatternVariableCharacter the character that starts a pattern node! !RBScanner methodsFor: 'accessing' stamp: 'GiselaDecuzzi 5/28/2013 13:28'! errorBlock: aBlock errorBlock := aBlock! ! !RBScanner methodsFor: 'testing' stamp: ''! isReadable ^true! ! !RBScanner methodsFor: 'private-scanning' stamp: ''! scanLiteralArrayToken | token | token := RBLiteralArrayToken value: (String with: $# with: currentCharacter) start: tokenStart. self step. ^token! ! !RBScanner methodsFor: 'testing' stamp: ''! isWritable ^false! ! !RBScanner methodsFor: 'accessing' stamp: 'GiselaDecuzzi 6/10/2013 14:53'! next | token | buffer reset. tokenStart := stream position. token := characterType = #eof ifTrue: [RBToken start: tokenStart + 1 "The EOF token should occur after the end of input"] ifFalse: [self scanToken]. self stripSeparators. token comments: self getComments. ^token! ! !RBScanner methodsFor: 'error handling' stamp: 'GiselaDecuzzi 6/10/2013 13:08'! scannerError: aString (self errorBlock cull: aString cull: self errorPosition cull: self) ifNil: [ ^ SyntaxErrorNotification inClass: Object category: nil withCode: stream contents doitFlag: false errorMessage: aString location: stream position + 1 ]! ! !RBScanner methodsFor: 'private-scanning' stamp: 'lr 11/2/2009 23:37'! stripSeparators [[characterType = #separator] whileTrue: [self step]. currentCharacter = $"] whileTrue: [self stripComment]! ! !RBScanner methodsFor: 'accessing' stamp: 'GiselaDecuzzi 6/10/2013 10:22'! scanToken "fast-n-ugly. Don't write stuff like this. Has been found to cause cancer in laboratory rats. Basically a case statement. Didn't use Dictionary because lookup is pretty slow." characterType = #alphabetic ifTrue: [^self scanIdentifierOrKeyword]. (characterType = #digit or: [currentCharacter = $- and: [(self classify: stream peek) = #digit]]) ifTrue: [^self scanNumber]. characterType = #binary ifTrue: [^self scanBinary: RBBinarySelectorToken]. characterType = #special ifTrue: [^self scanSpecialCharacter]. currentCharacter = $' ifTrue: [^self scanLiteralString]. currentCharacter = $# ifTrue: [^self scanLiteral]. currentCharacter = $$ ifTrue: [^self scanLiteralCharacter]. ^self scanError: 'Unknown character' translated! ! !RBScanner methodsFor: 'private' stamp: 'lr 11/2/2009 23:37'! previousStepPosition ^characterType = #eof ifTrue: [stream position] ifFalse: [stream position - 1]! ! !RBScanner methodsFor: 'private-scanning' stamp: 'GiselaDecuzzi 6/10/2013 10:47'! scanLiteral self step. self stripSeparators. characterType = #alphabetic ifTrue: [ ^ self scanSymbol ]. characterType = #binary ifTrue: [ ^ (self scanBinary: RBLiteralToken) stop: self previousStepPosition ]. currentCharacter = $' ifTrue: [ ^ self scanStringSymbol ]. (currentCharacter = $( or: [ currentCharacter = $[ ]) ifTrue: [ ^ self scanLiteralArrayToken]. "Accept some strange literals like '#1', '# species' and '##species:'" characterType = #digit ifTrue: [ ^ self scanNumber ]. currentCharacter = $# ifTrue: [ ^ self scanLiteral ]. ^self scanError: 'Expecting a literal type' translated.! ! !RBScanner methodsFor: 'private-scanning' stamp: ''! scanLiteralCharacter | token | self step. "$" token := RBLiteralToken value: currentCharacter start: tokenStart stop: stream position. self step. "char" ^token! ! !RBScanner methodsFor: 'private-scanning' stamp: 'CamilloBruni 11/13/2012 10:03'! scanSpecialCharacter | character | currentCharacter = $: ifTrue: [ self step. ^ currentCharacter = $= ifTrue: [ self step. RBAssignmentToken start: tokenStart] ifFalse: [ RBSpecialCharacterToken value: $: start: tokenStart ]]. currentCharacter = $_ ifTrue: [ self step. ^ RBShortAssignmentToken start: tokenStart ]. character := currentCharacter. self step. ^ RBSpecialCharacterToken value: character start: tokenStart! ! !RBScanner methodsFor: 'private-scanning' stamp: 'lr 11/2/2009 23:37'! scanAnySymbol characterType = #alphabetic ifTrue: [^self scanSymbol]. characterType = #binary ifTrue: [^self scanBinary: RBLiteralToken]. ^RBToken new! ! !RBScanner methodsFor: 'error handling' stamp: 'GiselaDecuzzi 6/10/2013 13:11'! errorBlock ^errorBlock ifNil: [[:message :position | ]] ifNotNil: [errorBlock]! ! !RBScanner methodsFor: 'initialize-release' stamp: 'lr 11/1/2009 18:31'! on: aStream buffer := WriteStream on: (String new: 60). stream := aStream. classificationTable := self class classificationTable. comments := OrderedCollection new! ! !RBScanner methodsFor: 'private-scanning' stamp: 'GiselaDecuzzi 6/10/2013 13:07'! stripComment | start stop | start := stream position. [self step = $"] whileFalse: [characterType = #eof ifTrue: [^self scannerError: 'Unmatched " in comment.' translated]]. stop := stream position. self step. comments add: (start to: stop)! ! !RBScanner methodsFor: 'private' stamp: ''! classify: aCharacter | index | aCharacter isNil ifTrue: [^nil]. index := aCharacter asInteger. index == 0 ifTrue: [^#separator]. index > 255 ifTrue: [^aCharacter isLetter ifTrue: [#alphabetic] ifFalse: [aCharacter isSeparator ifTrue: [#separator] ifFalse: [nil]]]. ^classificationTable at: index! ! !RBScanner methodsFor: 'error handling' stamp: 'GiselaDecuzzi 6/10/2013 13:12'! errorPosition ^stream position! ! !RBScanner methodsFor: 'private-scanning' stamp: 'lr 11/2/2009 23:37'! scanName [characterType = #alphabetic or: [characterType = #digit]] whileTrue: [buffer nextPut: currentCharacter. self step]! ! !RBScanner methodsFor: 'private-scanning' stamp: 'lr 11/2/2009 23:37'! scanKeyword | outputPosition inputPosition name | [currentCharacter = $:] whileTrue: [buffer nextPut: currentCharacter. outputPosition := buffer position. inputPosition := stream position. self step. ":" [characterType = #alphabetic] whileTrue: [self scanName]]. buffer position: outputPosition. stream position: inputPosition. self step. name := buffer contents. ^(name occurrencesOf: $:) == 1 ifTrue: [RBKeywordToken value: name start: tokenStart] ifFalse: [RBMultiKeywordLiteralToken value: name asSymbol start: tokenStart stop: tokenStart + name size - 1]! ! !RBScanner methodsFor: 'private-scanning' stamp: 'lr 3/7/2010 11:41'! scanBinary: aClass | val | buffer nextPut: currentCharacter. self step. [ characterType = #binary ] whileTrue: [ buffer nextPut: currentCharacter. self step ]. val := buffer contents. val := val asSymbol. ^aClass value: val start: tokenStart! ! !RBScanner methodsFor: 'private-scanning' stamp: 'GiselaDecuzzi 6/10/2013 10:47'! scanPatternVariable buffer nextPut: currentCharacter. self step. currentCharacter = ${ ifTrue: [self step. ^RBPatternBlockToken value: '`{' start: tokenStart]. [characterType = #alphabetic] whileFalse: [characterType = #eof ifTrue: [self scanError: 'Meta variable expected']. buffer nextPut: currentCharacter. self step]. ^self scanIdentifierOrKeyword! ! !RBScanner methodsFor: 'testing' stamp: 'lr 11/2/2009 23:37'! atEnd ^characterType = #eof! ! !RBScanner methodsFor: 'accessing' stamp: ''! nextPut: anObject "Provide an error notification that the receiver does not implement this message." self shouldNotImplement! ! !RBScanner methodsFor: 'accessing' stamp: ''! getComments | oldComments | comments isEmpty ifTrue: [^nil]. oldComments := comments. comments := OrderedCollection new: 1. ^oldComments! ! !RBScanner methodsFor: 'private-scanning' stamp: 'lr 11/16/2009 15:48'! scanSymbol [ characterType = #alphabetic or: [ currentCharacter = $: ] ] whileTrue: [ self scanName. currentCharacter = $: ifTrue: [ buffer nextPut: $:. self step ] ]. ^ RBLiteralToken value: buffer contents asSymbol start: tokenStart stop: self previousStepPosition! ! !RBScanner methodsFor: 'private-scanning' stamp: 'GiselaDecuzzi 6/10/2013 15:53'! scanError: theCause currentCharacter ifNotNil: [ :char | buffer nextPut: char ]. ^ RBErrorToken value: buffer contents asString start: tokenStart cause: theCause location: stream position + 1! ! !RBScanner methodsFor: 'private-scanning' stamp: 'YuriyTymchuk 10/29/2013 11:10'! scanNumber | start number stop string | start := stream position. stream position: start - 1. number := [NumberParser parse: stream] on: Error do: [:err | self scannerError: err messageText]. stop := stream position. stream position: start - 1. string := stream next: stop - start + 1. stream position: stop. self step. ^RBNumberLiteralToken value: number start: start stop: stop source: string! ! !RBScanner methodsFor: 'private-scanning' stamp: 'GiselaDecuzzi 6/10/2013 11:05'! scanLiteralString self step. [currentCharacter isNil ifTrue: [^self scanError: 'Unmatched '' in string literal.' translated]. currentCharacter = $' and: [self step ~= $']] whileFalse: [buffer nextPut: currentCharacter. self step]. ^RBLiteralToken value: buffer contents start: tokenStart stop: self previousStepPosition! ! !RBScanner methodsFor: 'private-scanning' stamp: ''! scanStringSymbol | literalToken | literalToken := self scanLiteralString. literalToken value: literalToken value asSymbol. ^literalToken! ! !RBScanner methodsFor: 'private' stamp: ''! step stream atEnd ifTrue: [characterType := #eof. ^currentCharacter := nil]. currentCharacter := stream next. characterType := self classify: currentCharacter. ^currentCharacter! ! !RBScanner methodsFor: 'accessing' stamp: ''! flush! ! !RBScanner methodsFor: 'private-scanning' stamp: 'lr 3/7/2010 11:47'! scanIdentifierOrKeyword | name | self scanName. (currentCharacter = $: and: [stream peek ~= $=]) ifTrue: [^self scanKeyword]. name := buffer contents. name = 'true' ifTrue: [^RBLiteralToken value: true start: tokenStart stop: self previousStepPosition]. name = 'false' ifTrue: [^RBLiteralToken value: false start: tokenStart stop: self previousStepPosition]. name = 'nil' ifTrue: [^RBLiteralToken value: nil start: tokenStart stop: self previousStepPosition]. ^RBIdentifierToken value: name start: tokenStart! ! !RBScanner methodsFor: 'accessing' stamp: 'lr 11/23/2009 14:18'! contents | contentsStream | contentsStream := WriteStream on: (Array new: 50). [ self atEnd ] whileFalse: [ contentsStream nextPut: self next ]. ^ contentsStream contents! ! !RBScanner class methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/10/2013 11:42'! isVariable: aString | scanner token | scanner := self on: (ReadStream on: aString). token := scanner next. token isIdentifier ifFalse: [^false]. (token start = 1 and: [token stop = aString size]) ifFalse: [^false]. ^(aString includes: $.) not! ! !RBScanner class methodsFor: 'class initialization' stamp: 'lr 12/23/2009 16:40'! initialize self initializeClassificationTable! ! !RBScanner class methodsFor: 'testing' stamp: ''! isSelector: aSymbol | scanner token | scanner := self basicNew. scanner on: (ReadStream on: aSymbol asString). scanner step. token := scanner scanAnySymbol. token isLiteralToken ifFalse: [^false]. token value isEmpty ifTrue: [^false]. ^scanner atEnd! ! !RBScanner class methodsFor: 'class initialization' stamp: 'lr 8/30/2010 11:54'! initializeClassificationTable PatternVariableCharacter := $`. classificationTable := Array new: 255. self initializeChars: (Character allCharacters select: [ :each | each isLetter ]) to: #alphabetic. self initializeUnderscore. self initializeChars: '01234567890' to: #digit. self initializeChars: '!!%&*+,-/<=>?@\~|' to: #binary. classificationTable at: 177 put: #binary. "plus-or-minus" classificationTable at: 183 put: #binary. "centered dot" classificationTable at: 215 put: #binary. "times" classificationTable at: 247 put: #binary. "divide" self initializeChars: '().:;[]{}^' to: #special. self initializeChars: (Character allCharacters select: [ :each | each isSeparator ]) to: #separator! ! !RBScanner class methodsFor: 'instance creation' stamp: 'lr 8/30/2010 11:56'! new self initializeUnderscore. ^ super new! ! !RBScanner class methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 16:31'! classificationTable classificationTable ifNil: [ self initializeClassificationTable ]. ^ classificationTable! ! !RBScanner class methodsFor: 'class initialization' stamp: 'MarcusDenker 4/24/2013 15:51'! initializeUnderscore self classificationTable at: $_ asInteger put: #alphabetic! ! !RBScanner class methodsFor: 'instance creation' stamp: 'GiselaDecuzzi 6/10/2013 13:00'! on: aStream errorBlock: aBlock | str | str := self new on: aStream. str errorBlock: aBlock; step; stripSeparators. ^str! ! !RBScanner class methodsFor: 'class initialization' stamp: 'lr 11/23/2009 14:46'! initializeChars: characters to: aSymbol characters do: [:c | classificationTable at: c asInteger put: aSymbol]! ! !RBScanner class methodsFor: 'instance creation' stamp: 'lr 11/23/2009 14:50'! on: aStream | str | str := self new on: aStream. str step; stripSeparators. ^str! ! !RBScanner class methodsFor: 'accessing' stamp: 'lr 11/7/2009 15:31'! patternVariableCharacter ^ PatternVariableCharacter! ! !RBScannerTest commentStamp: 'TorstenBergmann 2/4/2014 21:53'! SUnit tests for RBScanner! !RBScannerTest methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/10/2013 11:10'! verifyErrorToken: scannedToken message: message valueExpected: valueExpected self assert: scannedToken isError. self assert: scannedToken cause equals: message. self assert: scannedToken value equals: valueExpected. self assert: scannedToken start equals: 1.! ! !RBScannerTest methodsFor: 'next' stamp: 'GiselaDecuzzi 6/10/2013 11:10'! testNextWithAnOpeningStringsGetError | source scannedToken | source := '''only the opening'. scannedToken := (self buildScannerForText: source) next. self verifyErrorToken: scannedToken message: 'Unmatched '' in string literal.' translated valueExpected: 'only the opening'! ! !RBScannerTest methodsFor: 'next' stamp: 'GiselaDecuzzi 5/30/2013 15:28'! testNextWithAnOpeningCommentGetError | source | source := '"only the opening'. self should: [(self buildScannerForText: source) next] raise: SyntaxErrorNotification! ! !RBScannerTest methodsFor: 'next' stamp: 'GiselaDecuzzi 6/10/2013 11:03'! testNextWithAnIdentifierTokenGetTheIdentifierToken | source scanner token | source := 'identifierToken'. scanner := self buildScannerForText: source. token := scanner next. self assert: token isIdentifier. self deny: token isError. self assert: token value equals: source.! ! !RBScannerTest methodsFor: 'next' stamp: 'GiselaDecuzzi 6/10/2013 11:09'! testNextWithAWrongSymbolGetError | source scanner scannedToken | source := '#^'. scanner := self buildScannerForText: source. scannedToken := scanner next. self verifyErrorToken: scannedToken message: 'Expecting a literal type' translated valueExpected: '^'! ! !RBScannerTest methodsFor: 'next' stamp: 'GiselaDecuzzi 6/10/2013 11:13'! testNextWithAnUnknownCharacterGetError | source scanner scannedToken | source := '¿'. scanner := self buildScannerForText: source. scannedToken := scanner next. self verifyErrorToken: scannedToken message: 'Unknown character' translated valueExpected: source! ! !RBScannerTest methodsFor: 'initialize' stamp: 'GiselaDecuzzi 5/30/2013 14:38'! buildScannerForText: source ^RBScanner on: (ReadStream on: source)! ! !RBSearchRule commentStamp: 'md 8/9/2005 14:56'! RBSearchRule is a parse tree rule that simply searches for matches to the rule. Every time a match is found, answerBlock is evaluated with the node that matches and the cureent answer. This two-argument approach allows a collection to be formed from all of the matches (Think inject:into:). Instance Variables: answerBlock Block to evaluate with the matching node and the current answer. ! !RBSearchRule methodsFor: 'initialize-release' stamp: ''! searchForMethod: aString thenDo: aBlock self methodSearchString: aString. answerBlock := aBlock! ! !RBSearchRule methodsFor: 'testing' stamp: ''! canMatch: aProgramNode owner answer: (answerBlock value: aProgramNode value: owner answer). ^true! ! !RBSearchRule methodsFor: 'initialize-release' stamp: ''! searchForTree: aBRProgramNode thenDo: aBlock searchTree := aBRProgramNode. answerBlock := aBlock! ! !RBSearchRule methodsFor: 'initialize-release' stamp: ''! searchFor: aString thenDo: aBlock self searchString: aString. answerBlock := aBlock! ! !RBSearchRule class methodsFor: 'instance creation' stamp: ''! searchForMethod: aString thenDo: aBlock ^self new searchForMethod: aString thenDo: aBlock! ! !RBSearchRule class methodsFor: 'instance creation' stamp: ''! searchForTree: aBRProgramNode thenDo: aBlock ^self new searchForTree: aBRProgramNode thenDo: aBlock! ! !RBSearchRule class methodsFor: 'instance creation' stamp: ''! searchFor: aString thenDo: aBlock ^self new searchFor: aString thenDo: aBlock! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:56'! buildMethodSearch "Simple forwarders" self createMethodSearchWith: '`@methodName: `@args ^`@object `@methodName: `@args' selectors: #(#problemCount #isEmpty ) inClass: RBTransformationRuleTest! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:56'! buildSimpleVariableSearch self createSearchWith: 'result' selectors: #( #checkClass: #checkMethod: #isEmpty #problemCount #resetResult #resetResult #resetResult #result #result: #resultClass: #viewResults ) inClass: RBBasicLintRuleTest! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:56'! buildStatementSearch "Two or more statements" self createSearchWith: '| `@temps | ``@.Stmts1. ``.Stmt1. ``@.Stmts2. ``.Stmt2. ``@.Stmts3' selectors: #( #checkMethod: #rewriteUsing: #viewResults #superSends ) inClass: RBTransformationRuleTest! ! !RBSearchTest methodsFor: 'tests' stamp: 'lr 9/18/2011 15:57'! testAllSearches classSearches keysAndValuesDo: [:class :searches | class selectors do: [:sel | currentSelector := sel. searches do: [:each | each executeTree: (class parseTreeFor: sel) initialAnswer: each answer]]]. classSearches do: [:searches | searches do: [:each | self assert: each answer isEmpty]]! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:56'! buildSimpleLiteralSearch | search | search := RBParseTreeSearcher new. search matchesAnyTreeOf: (Array with: (RBParser parseExpression: '#(''bugs'' ''possible bugs'' ''unnecessary code'' ''intention revealing'' ''miscellaneous'')')) do: [ :aNode :answer | answer remove: self currentSelector ifAbsent: [ self error: 'failed' ]; yourself ]. search answer: #(#protocols ) asBag. (classSearches at: RBBasicLintRuleTest class ifAbsentPut: [ Set new ]) add: search! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:57'! createMethodSearchWith: aCodeString selectors: selectorCollection inClass: aClass | search | search := RBParseTreeSearcher new. search matchesAnyMethodOf: (Array with: aCodeString) do: [:aNode :answer | answer remove: self currentSelector ifAbsent: [self error: 'failed']; yourself]. search answer: selectorCollection asBag. (classSearches at: aClass ifAbsentPut: [Set new]) add: search! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:56'! buildMethodArgumentSearch "Two argument methods" self createMethodSearchWith: '`arg1: `arg1 `arg2: `arg2 | `@temps | `@.Stmts' selectors: #( #subclassOf:overrides: #createMatcherFor:method: #createParseTreeRule:name: ) inClass: RBBasicLintRuleTest class! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:57'! createSearchWith: aCodeString selectors: selectorCollection inClass: aClass | search | search := RBParseTreeSearcher new. search matches: aCodeString do: [:aNode :answer | answer remove: self currentSelector ifAbsent: [self error: 'failed']; yourself]. search answer: selectorCollection asBag. (classSearches at: aClass ifAbsentPut: [Set new]) add: search! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:57'! setUp super setUp. classSearches := Dictionary new. self buildMethodSearch; buildSimpleVariableSearch; buildSimpleLiteralSearch; buildMessageSearch; buildStatementSearch; buildArgumentSearch; buildMethodTitleSearch; buildMethodArgumentSearch! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:56'! buildMethodTitleSearch self createMethodSearchWith: 'initialize | `@temps | `@.Stmts' selectors: #(#initialize ) inClass: RBBasicLintRuleTest! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:56'! buildArgumentSearch self createArgumentSearchWith: 'aSmalllintContext' selectors: #(#checkMethod: #checkClass: ) inClass: RBBasicLintRuleTest! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:57'! createArgumentSearchWith: aCodeString selectors: selectorCollection inClass: aClass | search | search := RBParseTreeSearcher new. search matchesAnyArgumentOf: (Array with: aCodeString) do: [:aNode :answer | answer remove: self currentSelector ifAbsent: [self error: 'failed']; yourself]. search answer: selectorCollection asBag. (classSearches at: aClass ifAbsentPut: [Set new]) add: search! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:56'! buildMessageSearch self createSearchWith: '``@receiver -> ``@arg' selectors: #(#superSends #superSends ) inClass: RBTransformationRuleTest! ! !RBSearchTest methodsFor: 'accessing' stamp: 'lr 10/19/2011 20:10'! currentSelector ^ currentSelector! ! !RBSearchingLiteralRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:35'! initialize super initialize. self matcher matchesAnyOf: #( '``@object = `#literal or: [``@expression]' '``@object == `#literal or: [``@expression]' '`#literal = ``@object or: [``@expression]' '`#literal == ``@object or: [``@expression]' '``@expression | (``@object = `#literal)' '``@expression | (``@object == `#literal)' '``@expression | (`#literal = ``@object)' '``@expression | (`#literal == ``@object)') do: [ :node :answer | answer isNil ifTrue: [ (self isSearchingLiteralExpression: node) ifTrue: [ node ] ifFalse: [ nil ] ] ifFalse: [ answer ] ]! ! !RBSearchingLiteralRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:28'! category ^ 'Optimization'! ! !RBSearchingLiteralRule methodsFor: 'private' stamp: 'MarcusDenker 9/20/2013 15:07'! isSearchingLiteralExpression: aMessageNode | equalNode expressionNode | equalNode := aMessageNode selector = #| ifTrue: [aMessageNode arguments first] ifFalse: [aMessageNode receiver]. expressionNode := equalNode receiver isLiteralNode ifTrue: [equalNode arguments first] ifFalse: [equalNode receiver]. ^self isSearchingLiteralExpression: aMessageNode for: expressionNode! ! !RBSearchingLiteralRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:38'! rationale ^ 'Checks for repeated literal equalitity tests that should rather be implemented as a search in a literal collection.'! ! !RBSearchingLiteralRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBSearchingLiteralRule methodsFor: 'private' stamp: 'MarcusDenker 9/20/2013 15:03'! isSearchingLiteralExpression: aSearchingNode for: anObjectNode | argument arguments | aSearchingNode isMessage ifFalse: [^false]. arguments := aSearchingNode arguments. arguments size = 1 ifFalse: [^false]. argument := arguments first. (#(#= #==) includes: aSearchingNode selector) ifTrue: [^(aSearchingNode receiver = anObjectNode and: [aSearchingNode arguments first isLiteralNode]) or: [aSearchingNode arguments first = anObjectNode and: [aSearchingNode receiver isLiteralNode]]]. aSearchingNode selector = #| ifTrue: [^(self isSearchingLiteralExpression: aSearchingNode receiver for: anObjectNode) and: [self isSearchingLiteralExpression: argument for: anObjectNode]]. aSearchingNode selector = #or: ifFalse: [^false]. argument isBlock ifFalse: [^false]. argument body statements size = 1 ifFalse: [^false]. ^(self isSearchingLiteralExpression: aSearchingNode receiver for: anObjectNode) and: [self isSearchingLiteralExpression: argument body statements first for: anObjectNode]! ! !RBSearchingLiteralRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses or''s instead of a searching literal'! ! !RBSearchingLiteralRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'SearchingLiteralRule'! ! !RBSelectorEnvironment methodsFor: 'accessing-classes' stamp: 'lr 3/20/2011 11:18'! classesDo: aBlock classSelectors keysDo: [ :each | | class | class := self systemDictionary at: each ifAbsent: [ nil ]. (class notNil and: [ environment includesClass: class ]) ifTrue: [ aBlock value: class ] ]. metaClassSelectors keysDo: [ :each | | class | class := self systemDictionary at: each ifAbsent: [ nil ]. (class notNil and: [ environment includesClass: class class ]) ifTrue: [ aBlock value: class class ] ]! ! !RBSelectorEnvironment methodsFor: 'testing' stamp: 'TestRunner 1/3/2010 12:36'! includesCategory: aCategory ^(super includesCategory: aCategory) and: [(self classNamesFor: aCategory) anySatisfy: [:className | (classSelectors includesKey: className) or: [metaClassSelectors includesKey: className]]]! ! !RBSelectorEnvironment methodsFor: 'accessing' stamp: 'ThierryGoubier 9/6/2013 17:26'! packages "Check that packages have really class and selector included." | pSet | pSet := Set new. self classes do: [ :each | each packages do: [ :p | self selectorsForClass: each do: [ :s | (p includesSelector: s ofClass: each) ifTrue: [ pSet add: p ] ] ] ]. ^ pSet! ! !RBSelectorEnvironment methodsFor: 'initialization' stamp: ''! initialize super initialize. classSelectors := IdentityDictionary new. metaClassSelectors := IdentityDictionary new! ! !RBSelectorEnvironment methodsFor: 'adding' stamp: 'lr 2/26/2009 13:36'! addClass: aClass selector: aSymbol (aClass isMeta ifTrue: [ metaClassSelectors at: aClass soleInstance name ifAbsentPut: [ IdentitySet new ] ] ifFalse: [ classSelectors at: aClass name ifAbsentPut: [ IdentitySet new ] ]) add: aSymbol! ! !RBSelectorEnvironment methodsFor: 'accessing' stamp: ''! numberSelectors "This doesn't compute the correct result when a method that is included in our method list is not in the environment we are wrapping. It is implemented this way for efficiency." ^(classSelectors inject: 0 into: [:sum :each | sum + each size]) + (metaClassSelectors inject: 0 into: [:sum :each | sum + each size])! ! !RBSelectorEnvironment methodsFor: 'adding' stamp: 'lr 9/14/2010 11:40'! addClass: aClass aClass isMeta ifTrue: [ metaClassSelectors at: aClass soleInstance name put: aClass selectors asIdentitySet ] ifFalse: [ classSelectors at: aClass name put: aClass selectors asIdentitySet ]! ! !RBSelectorEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 13:35'! classNames ^ IdentitySet new addAll: classSelectors keys; addAll: metaClassSelectors keys; yourself! ! !RBSelectorEnvironment methodsFor: 'initialize-release' stamp: 'lr 9/14/2010 11:40'! on: aDictionary aDictionary keysAndValuesDo: [ :class :selectors | class isMeta ifTrue: [ metaClassSelectors at: class soleInstance name put: selectors asIdentitySet ] ifFalse: [ classSelectors at: class name put: selectors asIdentitySet ] ]! ! !RBSelectorEnvironment methodsFor: 'removing' stamp: ''! removeClass: aClass aClass isMeta ifTrue: [metaClassSelectors removeKey: aClass soleInstance name ifAbsent: []] ifFalse: [classSelectors removeKey: aClass name ifAbsent: []]! ! !RBSelectorEnvironment methodsFor: 'testing' stamp: ''! includesClass: aClass ^(self privateSelectorsForClass: aClass) isEmpty not and: [super includesClass: aClass]! ! !RBSelectorEnvironment methodsFor: 'private' stamp: ''! privateIncludesSelector: aSelector inClass: aClass ^(self privateSelectorsForClass: aClass) includes: aSelector! ! !RBSelectorEnvironment methodsFor: 'accessing' stamp: 'rr 4/19/2004 16:06'! asSelectorEnvironment ^ self! ! !RBSelectorEnvironment methodsFor: 'testing' stamp: ''! isEmpty ^classSelectors isEmpty and: [metaClassSelectors isEmpty]! ! !RBSelectorEnvironment methodsFor: 'printing' stamp: ''! storeOn: aStream | classBlock | aStream nextPutAll: '(('; nextPutAll: self class name; nextPutAll: ' onEnvironment: '. environment storeOn: aStream. aStream nextPut: $); nextPutAll: ' classes: #('. classBlock := [:key :value | aStream nextPutAll: '#('; nextPutAll: key; nextPutAll: ' #('. value do: [:each | aStream nextPutAll: each; nextPut: $ ]. aStream nextPutAll: '))'; cr]. classSelectors keysAndValuesDo: classBlock. aStream nextPutAll: ') metaClasses: #('. metaClassSelectors keysAndValuesDo: classBlock. aStream nextPutAll: '))'! ! !RBSelectorEnvironment methodsFor: 'testing' stamp: ''! includesSelector: aSelector in: aClass ^(environment includesSelector: aSelector in: aClass) and: [self privateIncludesSelector: aSelector inClass: aClass]! ! !RBSelectorEnvironment methodsFor: 'removing' stamp: ''! removeClass: aClass selector: aSelector (aClass isMeta ifTrue: [metaClassSelectors at: aClass soleInstance name ifAbsent: [^self]] ifFalse: [classSelectors at: aClass name ifAbsent: [^self]]) remove: aSelector ifAbsent: []! ! !RBSelectorEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/26/2009 13:36'! classes: classArray metaClasses: metaArray "Used to recreate an environment from its storeString" classSelectors := IdentityDictionary new. metaClassSelectors := IdentityDictionary new. classArray do: [ :each | classSelectors at: each first put: each last asIdentitySet ]. metaArray do: [ :each | metaClassSelectors at: each first put: each last asIdentitySet ]! ! !RBSelectorEnvironment methodsFor: 'private' stamp: ''! privateSelectorsForClass: aClass ^aClass isMeta ifTrue: [metaClassSelectors at: aClass soleInstance name ifAbsent: [#()]] ifFalse: [classSelectors at: aClass name ifAbsent: [#()]]! ! !RBSelectorEnvironment methodsFor: 'testing' stamp: 'TestRunner 1/3/2010 12:36'! includesProtocol: aProtocol in: aClass ^(super includesProtocol: aProtocol in: aClass) and: [(environment selectorsFor: aProtocol in: aClass) anySatisfy: [:aSelector | self privateIncludesSelector: aSelector inClass: aClass]]! ! !RBSelectorEnvironment methodsFor: 'initialize-release' stamp: ''! classSelectors: classSelectorDictionary metaClassSelectors: metaClassSelectorDictionary classSelectors := classSelectorDictionary. metaClassSelectors := metaClassSelectorDictionary! ! !RBSelectorEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 13:00'! isSelectorEnvironment ^ true! ! !RBSelectorEnvironment methodsFor: 'private' stamp: ''! defaultLabel ^'some methods'! ! !RBSelectorEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:29'! postCopy | newDict | super postCopy. newDict := classSelectors copy. newDict keysAndValuesDo: [:key :value | newDict at: key put: value copy]. classSelectors := newDict. newDict := metaClassSelectors copy. newDict keysAndValuesDo: [:key :value | newDict at: key put: value copy]. metaClassSelectors := newDict! ! !RBSelectorEnvironment methodsFor: '*manifest-core' stamp: 'SimonAllier 3/27/2013 10:11'! smallLintCritics | array | array := OrderedCollection new: self numberSelectors. self classes do: [:cl | self selectorsForClass: cl do: [:sel | array add: (cl>>sel)]]. ^ array! ! !RBSelectorEnvironment methodsFor: 'accessing' stamp: ''! selectorsForClass: aClass do: aBlock ^(self privateSelectorsForClass: aClass) do: [:each | (aClass includesSelector: each) ifTrue: [aBlock value: each]]! ! !RBSelectorEnvironment class methodsFor: 'instance creation' stamp: 'lr 9/14/2010 12:07'! referencesTo: aLiteral in: anEnvironment | classDict literalPrintString specialFlag specialByte | literalPrintString := aLiteral isVariableBinding ifTrue: [ aLiteral key asString ] ifFalse: [ aLiteral isString ifTrue: [ aLiteral ] ifFalse: [ aLiteral printString ] ]. classDict := IdentityDictionary new. specialFlag := Smalltalk hasSpecialSelector: aLiteral ifTrueSetByte: [ :byte | specialByte := byte ]. anEnvironment classesDo: [ :class | | selectors | selectors := (class thoroughWhichSelectorsReferTo: aLiteral special: specialFlag byte: specialByte) select: [ :selector | anEnvironment includesSelector: selector in: class ]. selectors isEmpty ifFalse: [ classDict at: class put: selectors asIdentitySet ] ]. ^ (self onEnvironment: anEnvironment) on: classDict; label: 'References to: ' , literalPrintString; searchStrings: (Array with: literalPrintString); yourself! ! !RBSelectorEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:28'! implementorsMatching: aString ^ self implementorsMatching: aString in: self default! ! !RBSelectorEnvironment class methodsFor: 'instance creation' stamp: 'lr 9/14/2010 12:01'! matches: aString in: anEnvironment | newEnvironment | newEnvironment := (self onEnvironment: anEnvironment) label: 'Matching: ' , aString; searchStrings: (Array with: aString); yourself. anEnvironment classesAndSelectorsDo: [ :class :selector | | method | method := class compiledMethodAt: selector. method allLiterals do: [ :literal | literal isString ifTrue: [ (aString match: literal) ifTrue: [ newEnvironment addClass: class selector: selector ] ] ] ]. ^ newEnvironment! ! !RBSelectorEnvironment class methodsFor: 'instance creation' stamp: 'lr 9/14/2010 12:06'! onMethods: selectorCollection forClass: aClass in: anEnvironment | environemnt | environemnt := self onEnvironment: anEnvironment. selectorCollection do: [ :each | environemnt addClass: aClass selector: each ]. ^ environemnt! ! !RBSelectorEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:30'! referencesTo: aLiteral ^ self referencesTo: aLiteral in: self default ! ! !RBSelectorEnvironment class methodsFor: 'instance creation' stamp: 'lr 9/14/2010 11:59'! implementorsMatching: aString in: anEnvironment | classDict metaDict | classDict := IdentityDictionary new. metaDict := IdentityDictionary new. anEnvironment classesDo: [ :class | | selectors | selectors := IdentitySet new. anEnvironment selectorsForClass: class do: [ :each | (aString match: each) ifTrue: [ selectors add: each ] ]. selectors isEmpty ifFalse: [ class isMeta ifTrue: [ metaDict at: class soleInstance name put: selectors ] ifFalse: [ classDict at: class name put: selectors ] ] ]. ^ (self onEnvironment: anEnvironment) classSelectors: classDict metaClassSelectors: metaDict; label: 'Implementors of ' , aString; yourself! ! !RBSelectorEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:29'! implementorsOf: aSelector ^ self implementorsOf: aSelector in: self default ! ! !RBSelectorEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:29'! matches: aString ^ self matches: aString in: self default! ! !RBSelectorEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:29'! onMethods: selectorCollection forClass: aClass ^ self onMethods: selectorCollection forClass: aClass in: self default ! ! !RBSelectorEnvironment class methodsFor: 'instance creation' stamp: 'SebastianTleye 8/2/2013 09:52'! implementorsOf: aSelector in: anEnvironment | classDict metaDict selectors | classDict := IdentityDictionary new. metaDict := IdentityDictionary new. selectors := IdentitySet with: aSelector. anEnvironment classesDo: [ :class | ((class includesLocalSelector: aSelector) and: [ anEnvironment includesSelector: aSelector in: class ]) ifTrue: [ class isMeta ifTrue: [ metaDict at: class soleInstance name put: selectors copy ] ifFalse: [ classDict at: class name put: selectors copy ] ] ]. ^ (self onEnvironment: anEnvironment) classSelectors: classDict metaClassSelectors: metaDict; label: 'Implementors of ' , aSelector; yourself! ! !RBSelfNode commentStamp: ''! I am a specialized version for the 'self'! !RBSelfNode methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/16/2013 17:14'! specialCommands ^#().! ! !RBSelfNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:33'! isSelf ^ true! ! !RBSelfNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:38'! acceptVisitor: aProgramNodeVisitor ^ aProgramNodeVisitor visitSelfNode: self! ! !RBSendsDeprecatedMethodToGlobalRule methodsFor: 'initialization' stamp: 'CamilleTeruel 3/22/2013 11:30'! initialize | patterns pattern wellKnownGlobals | super initialize. patterns := OrderedCollection new. wellKnownGlobals := IdentityDictionary new. Smalltalk globals keysAndValuesDo: [ :name :object | object isBehavior ifFalse: [ (wellKnownGlobals at: object class ifAbsentPut: [ IdentitySet new ]) add: name ] ]. self selectors do: [ :symbol | (RBBrowserEnvironment new referencesTo: symbol) classesAndSelectorsDo: [ :class :selector | class isMeta ifTrue: [ class withAllSubclassesDo: [ :subclass | patterns add: (String streamContents: [ :stream | stream nextPutAll: subclass theNonMetaClass name; nextPutAll: (self genericPatternForSelector: selector) ]) ] ] ifFalse: [ wellKnownGlobals keysAndValuesDo: [ :global :names | (global includesBehavior: class) ifTrue: [ names do: [ :each | patterns add: (String streamContents: [ :stream | stream nextPutAll: each; nextPutAll: (self genericPatternForSelector: selector) ]) ] ] ] ] ] ]. self matcher matchesAnyOf: patterns do: [ :node :answer | node ]! ! !RBSendsDeprecatedMethodToGlobalRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:28'! category ^ 'Design Flaws'! ! !RBSendsDeprecatedMethodToGlobalRule methodsFor: 'accessing' stamp: 'lr 9/4/2010 14:04'! selectors ^ #(deprecated: deprecated:on:in: deprecated:explanation: deprecated:block: greaseDeprecatedApi:details:)! ! !RBSendsDeprecatedMethodToGlobalRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:49'! rationale ^ 'Checks for sends of deprecated messages that might be removed in upcoming releases of Pharo.'! ! !RBSendsDeprecatedMethodToGlobalRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBSendsDeprecatedMethodToGlobalRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:12'! severity ^ #error! ! !RBSendsDeprecatedMethodToGlobalRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Sends a deprecated message to a known global'! ! !RBSendsDeprecatedMethodToGlobalRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'SendsDeprecatedMethodToGlobalRule'! ! !RBSendsDifferentSuperRule commentStamp: ''! See my #rationale. A common example of this is in creation methods. You might define a method such as: createInstance ^super new initialize If the new method is not defined in the class, you should probably rewrite this to use self instead. Also, if the new method is defined, you might question why you need to send new to the superclass instead of to the class.! !RBSendsDifferentSuperRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for methods whose source sends a different super message.'! ! !RBSendsDifferentSuperRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBSendsDifferentSuperRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Sends different super message'! ! !RBSendsDifferentSuperRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 14:08'! category ^ 'Design Flaws'! ! !RBSendsDifferentSuperRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkMethod: aContext | message | (message := aContext superMessages detect: [ :each | each ~= aContext selector ] ifNone: [ nil ]) notNil ifTrue: [ result addSearchString: message. result addClass: aContext selectedClass selector: aContext selector ]! ! !RBSendsDifferentSuperRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'SendsDifferentSuperRule'! ! !RBSendsMethodDictRule methodsFor: '*Manifest-Core' stamp: 'MarcusDenker 10/6/2013 08:44'! category ^ 'Bugs'! ! !RBSendsMethodDictRule methodsFor: '*Manifest-Core' stamp: 'MarcusDenker 10/6/2013 08:47'! longDescription ^ 'nobody should directly access the method dictionary. It is purely an implementation artefact that we use one dictionary and it might change in the future'! ! !RBSendsMethodDictRule methodsFor: 'accessing' stamp: 'MarcusDenker 10/6/2013 08:47'! rationale ^ 'nobody should directly access the method dictionary. It is purely an implementation artefact that we use one dictionary and it might change in the future'! ! !RBSendsMethodDictRule methodsFor: 'accessing' stamp: 'MarcusDenker 10/6/2013 08:44'! group ^ 'Bugs'! ! !RBSendsMethodDictRule methodsFor: 'accessing' stamp: 'MarcusDenker 10/6/2013 08:44'! severity ^ #error! ! !RBSendsMethodDictRule methodsFor: 'accessing' stamp: 'MarcusDenker 10/6/2013 08:47'! name ^ 'No direct access of methodDict'! ! !RBSendsMethodDictRule methodsFor: 'running' stamp: 'MarcusDenker 10/6/2013 08:58'! checkMethod: aContext ({Behavior. ClassDescription. Class.TBehavior . TClassDescription . TApplyingOnClassSide } includes: aContext selectedClass) ifTrue: [ ^ self ]. (aContext messages includes: #methodDict) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector. result addSearchString: 'methodDict' ]! ! !RBSendsMethodDictRule class methodsFor: '*Manifest-Core' stamp: 'MarcusDenker 10/6/2013 08:57'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'NobodyShouldSendMethodDict'! ! !RBSendsUnknownMessageToGlobalRule methodsFor: 'initialization' stamp: 'lr 8/15/2010 17:17'! initialize super initialize. self matcher matches: '`{:node :context | node isVariable and: [ Smalltalk includesKey: node name asSymbol ] } `@message: `@args' do: [ :node :answer | answer isNil ifTrue: [ | what | what := Smalltalk globals at: node receiver name asSymbol. (what notNil and: [ (what respondsTo: node selector) not ]) ifTrue: [ node ] ifFalse: [ nil ] ] ifFalse: [ answer ] ]! ! !RBSendsUnknownMessageToGlobalRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:32'! rationale ^ 'Checks for messages that are sent but not implemented by a global. Reported methods will certainly cause a doesNotUnderstand: message when they are executed.'! ! !RBSendsUnknownMessageToGlobalRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBSendsUnknownMessageToGlobalRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:04'! severity ^ #error! ! !RBSendsUnknownMessageToGlobalRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Sends unknown message to global'! ! !RBSendsUnknownMessageToGlobalRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:29'! category ^ 'Bugs'! ! !RBSendsUnknownMessageToGlobalRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'SendsUnknownMessageToGlobalRule'! ! !RBSentNotImplementedRule commentStamp: ''! See my #rationale.! !RBSentNotImplementedRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 13:51'! category ^ 'Bugs'! ! !RBSentNotImplementedRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 13:49'! longDescription ^ 'This smell arises when a message is sent by a method, but no class in the system implements such a message. This method sent will certainly cause a doesNotUnderstand: message when they are executed. Further this rule checks if messages sent to self or super exist in the hierarchy, since these can be statically typed.'! ! !RBSentNotImplementedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for messages that are sent by a method, but no class in the system implements such a message. Further checks if messages sent to self or super exist in the hierarchy, since these can be statically typed. Reported methods will certainly cause a doesNotUnderstand: message when they are executed.'! ! !RBSentNotImplementedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBSentNotImplementedRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:04'! severity ^ #error! ! !RBSentNotImplementedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Messages sent but not implemented'! ! !RBSentNotImplementedRule methodsFor: 'running' stamp: 'CamilleTeruel 11/8/2013 16:21'! checkMethod: aContext | message | message := aContext messages detect: [ :each | (aContext implements: each) not ] ifNone: [ aContext superMessages detect: [ :each | aContext selectedClass superclass isNil or: [ (aContext selectedClass superclass canUnderstand: each) not ] ] ifNone: [ aContext selfMessages detect: [ :each | (aContext selectedClass allSelectors includes: each) not ] ifNone: [ nil ] ] ]. message notNil ifTrue: [ result addSearchString: message. result addClass: aContext selectedClass selector: aContext selector ]! ! !RBSentNotImplementedRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'SentNotImplementedRule'! ! !RBSequenceNode commentStamp: ''! RBSequenceNode is an AST node that represents a sequence of statements. Both RBBlockNodes and RBMethodNodes contain these. Instance Variables: leftBar the position of the left | in the temporaries definition periods the positions of all the periods that separate the statements rightBar the position of the right | in the temporaries definition statements the statement nodes temporaries the temporaries defined ! !RBSequenceNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:21'! periods: anArray periods := anArray! ! !RBSequenceNode methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 4/19/2013 10:08'! specialCommands ^ SugsSuggestionFactory commandsForSource.! ! !RBSequenceNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:44'! addNodesFirst: aCollection aCollection do: [ :each | each parent: self ]. statements := statements asOrderedCollection addAllFirst: aCollection; yourself. ^ aCollection! ! !RBSequenceNode methodsFor: 'querying' stamp: ''! bestNodeFor: anInterval | node | node := super bestNodeFor: anInterval. node == self ifTrue: [(temporaries isEmpty and: [statements size == 1]) ifTrue: [^statements first]]. ^node! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! children ^(OrderedCollection new) addAll: self temporaries; addAll: self statements; yourself! ! !RBSequenceNode methodsFor: 'testing' stamp: ''! isSequence ^true! ! !RBSequenceNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:45'! addTemporaryNamed: aString | variableNode | variableNode := RBVariableNode named: aString. variableNode parent: self. temporaries := temporaries copyWith: variableNode. ^ variableNode! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! temporaryVariables ^(super temporaryVariables asOrderedCollection) addAll: self temporaryNames; yourself! ! !RBSequenceNode methodsFor: 'initialization' stamp: 'lr 2/19/2010 14:44'! initialize super initialize. periods := statements := temporaries := #()! ! !RBSequenceNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:42'! addNodeFirst: aNode aNode parent: self. statements := statements asOrderedCollection addFirst: aNode; yourself. ^ aNode! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! statements: stmtCollection statements := stmtCollection. statements do: [:each | each parent: self]! ! !RBSequenceNode methodsFor: 'testing' stamp: ''! references: aVariableName ^statements anySatisfy: [:each | each references: aVariableName]! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! temporaries: tempCollection temporaries := tempCollection. temporaries do: [:each | each parent: self]! ! !RBSequenceNode methodsFor: 'accessing-token' stamp: 'lr 11/1/2009 20:30'! periods ^ periods! ! !RBSequenceNode methodsFor: 'testing' stamp: ''! isLast: aNode | last | statements isEmpty ifTrue: [^false]. last := statements last. ^last == aNode or: [last isMessage and: [(#(#ifTrue:ifFalse: #ifFalse:ifTrue:) includes: last selector) and: [last arguments anySatisfy: [:each | each isLast: aNode]]]]! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! removeTemporaryNamed: aName temporaries := temporaries reject: [:each | each name = aName]! ! !RBSequenceNode methodsFor: 'converting' stamp: 'MarcusDenker 1/29/2013 14:19'! asSequenceNode ^self! ! !RBSequenceNode methodsFor: 'replacing' stamp: ''! replaceNode: aNode withNode: anotherNode self statements: (statements collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]]). self temporaries: (temporaries collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! ! !RBSequenceNode methodsFor: 'testing' stamp: ''! uses: aNode statements isEmpty ifTrue: [^false]. aNode == statements last ifFalse: [^false]. ^self isUsed! ! !RBSequenceNode methodsFor: 'testing' stamp: ''! defines: aName ^temporaries anySatisfy: [:each | each name = aName]! ! !RBSequenceNode methodsFor: 'replacing' stamp: ''! replaceNode: aNode withNodes: aCollection | index newStatements | self clearReplacements. index := self indexOfNode: aNode. newStatements := OrderedCollection new: statements size + aCollection size. 1 to: index - 1 do: [:i | newStatements add: (statements at: i)]. newStatements addAll: aCollection. index + 1 to: statements size do: [:i | newStatements add: (statements at: i)]. aCollection do: [:each | each parent: self]. statements := newStatements! ! !RBSequenceNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:37'! postCopy super postCopy. self temporaries: (self temporaries collect: [ :each | each copy ]). self statements: (self statements collect: [ :each | each copy ])! ! !RBSequenceNode methodsFor: 'matching' stamp: 'lr 5/30/2010 11:35'! match: aNode inContext: aDictionary self class = aNode class ifFalse: [^false]. ^(self matchList: temporaries against: aNode temporaries inContext: aDictionary) and: [self matchList: statements against: aNode statements inContext: aDictionary]! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! temporaries ^temporaries! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! allDefinedVariables ^(self temporaryNames asOrderedCollection) addAll: super allDefinedVariables; yourself! ! !RBSequenceNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 5/19/2013 16:00'! transformLastToReturn | last | statements ifEmpty: [ ^self]. last := statements last. last isReturn ifFalse: [self replaceNode: last withNode: (RBReturnNode value: last )]! ! !RBSequenceNode methodsFor: 'accessing' stamp: 'lr 1/4/2012 21:38'! addReturn | node | statements isEmpty ifTrue: [ ^ nil ]. statements last isReturn ifTrue: [ ^ statements last ]. node := RBReturnNode value: statements last. statements at: statements size put: node. node parent: self. ^ node! ! !RBSequenceNode methodsFor: 'testing' stamp: ''! directlyUses: aNode ^false! ! !RBSequenceNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:44'! addNodes: aCollection before: anotherNode aCollection do: [ :each | self addNode: each before: anotherNode ]. ^ aCollection! ! !RBSequenceNode methodsFor: 'initialize-release' stamp: ''! leftBar: leftInteger temporaries: variableNodes rightBar: rightInteger leftBar := leftInteger. self temporaries: variableNodes. rightBar := rightInteger! ! !RBSequenceNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:22'! leftBar: anInteger leftBar := anInteger! ! !RBSequenceNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:39'! addSelfReturn | node | self lastIsReturn ifTrue: [ ^ self statements last ]. node := RBReturnNode value: (RBVariableNode named: 'self'). ^ self addNode: node! ! !RBSequenceNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:30'! isFaulty ^self statements anySatisfy: #isFaulty.! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! temporaryNames ^temporaries collect: [:each | each name]! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! statements ^statements! ! !RBSequenceNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:14'! start ^ leftBar ifNil: [statements isEmpty ifTrue: [1] ifFalse: [statements first start]]! ! !RBSequenceNode methodsFor: 'private' stamp: ''! indexOfNode: aNode "Try to find the node by first looking for ==, and then for =" ^(1 to: statements size) detect: [:each | (statements at: each) == aNode] ifNone: [statements indexOf: aNode]! ! !RBSequenceNode methodsFor: 'accessing-token' stamp: 'lr 1/11/2010 15:42'! leftBar ^ leftBar! ! !RBSequenceNode methodsFor: 'testing' stamp: ''! lastIsReturn ^statements notEmpty and: [statements last lastIsReturn]! ! !RBSequenceNode methodsFor: 'comparing' stamp: 'lr 3/7/2010 13:48'! hash ^ (self hashForCollection: self temporaries) bitXor: (self hashForCollection: self statements)! ! !RBSequenceNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:35'! copyInContext: aDictionary ^ self class new temporaries: (self copyList: self temporaries inContext: aDictionary); statements: (self copyList: self statements inContext: aDictionary); yourself! ! !RBSequenceNode methodsFor: 'querying' stamp: ''! whichNodeIsContainedBy: anInterval | node | node := super whichNodeIsContainedBy: anInterval. node == self ifTrue: [(temporaries isEmpty and: [statements size == 1]) ifTrue: [^statements first]]. ^node! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! stop ^(periods isEmpty ifTrue: [0] ifFalse: [periods last]) max: (statements isEmpty ifTrue: [0] ifFalse: [statements last stop])! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! allTemporaryVariables ^(self temporaryNames asOrderedCollection) addAll: super allTemporaryVariables; yourself! ! !RBSequenceNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:41'! addNode: aNode before: anotherNode | index | index := self indexOfNode: anotherNode. index = 0 ifTrue: [ ^ self addNode: aNode ]. statements := statements asOrderedCollection add: aNode beforeIndex: index; yourself. aNode parent: self. ^ aNode! ! !RBSequenceNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:38'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitSequenceNode: self! ! !RBSequenceNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:43'! addNodes: aCollection aCollection do: [ :each | each parent: self ]. (statements notEmpty and: [ statements last isReturn ]) ifTrue: [ self error: 'Cannot add statement after return node' ]. statements := statements asOrderedCollection addAll: aCollection; yourself. ^ aCollection! ! !RBSequenceNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:40'! addNode: aNode aNode parent: self. (statements notEmpty and: [ statements last isReturn ]) ifTrue: [ self error: 'Cannot add statement after return node' ]. statements := statements asOrderedCollection add: aNode; yourself. ^ aNode! ! !RBSequenceNode methodsFor: 'comparing' stamp: 'lr 5/30/2010 11:34'! equalTo: anObject withMapping: aDictionary self class = anObject class ifFalse: [^false]. self statements size = anObject statements size ifFalse: [^false]. 1 to: self statements size do: [:i | ((self statements at: i) equalTo: (anObject statements at: i) withMapping: aDictionary) ifFalse: [^false]]. aDictionary values asSet size = aDictionary size ifFalse: [^false]. "Not a one-to-one mapping" self temporaries do: [:each | aDictionary removeKey: each name ifAbsent: []]. ^true! ! !RBSequenceNode methodsFor: 'accessing' stamp: ''! methodComments | methodComments | methodComments := OrderedCollection withAll: self comments. temporaries do: [:each | methodComments addAll: each comments]. (parent notNil and: [parent isBlock]) ifTrue: [parent arguments do: [:each | methodComments addAll: each comments]]. ^methodComments asSortedCollection: [:a :b | a first < b first]! ! !RBSequenceNode methodsFor: 'comparing' stamp: ''! = anObject "Can't send = to the temporaries and statements collection since they might change from arrays to OCs" self == anObject ifTrue: [^true]. self class = anObject class ifFalse: [^false]. self temporaries size = anObject temporaries size ifFalse: [^false]. 1 to: self temporaries size do: [:i | (self temporaries at: i) = (anObject temporaries at: i) ifFalse: [^false]]. self statements size = anObject statements size ifFalse: [^false]. 1 to: self statements size do: [:i | (self statements at: i) = (anObject statements at: i) ifFalse: [^false]]. ^true! ! !RBSequenceNode methodsFor: 'replacing' stamp: 'lr 11/1/2009 20:34'! removeDeadCode (self isUsed ifTrue: [statements size - 1] ifFalse: [statements size]) to: 1 by: -1 do: [:i | (statements at: i) isImmediateNode ifTrue: [self clearReplacements. statements removeAt: i]]. super removeDeadCode! ! !RBSequenceNode methodsFor: 'replacing' stamp: ''! removeNode: aNode self replaceNode: aNode withNodes: #()! ! !RBSequenceNode methodsFor: 'accessing-token' stamp: 'lr 1/11/2010 15:42'! rightBar ^ rightBar! ! !RBSequenceNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:22'! rightBar: anInteger rightBar := anInteger! ! !RBSequenceNode methodsFor: 'adding nodes' stamp: 'lr 1/4/2012 21:45'! addTemporariesNamed: aCollection ^ aCollection collect: [ :each | self addTemporaryNamed: each ]! ! !RBSequenceNode class methodsFor: 'instance creation' stamp: ''! leftBar: leftInteger temporaries: variableNodes rightBar: rightInteger ^(self new) leftBar: leftInteger temporaries: variableNodes rightBar: rightInteger; yourself! ! !RBSequenceNode class methodsFor: 'instance creation' stamp: ''! temporaries: variableNodes statements: statementNodes ^(self new) temporaries: variableNodes; statements: statementNodes; yourself! ! !RBSequenceNode class methodsFor: 'instance creation' stamp: ''! statements: statementNodes ^self temporaries: #() statements: statementNodes! ! !RBShortAssignmentToken methodsFor: 'private' stamp: 'lr 11/1/2009 20:45'! length ^ 1! ! !RBShouldntRaiseErrorRule commentStamp: ''! See rationale.! !RBShouldntRaiseErrorRule methodsFor: 'initialization' stamp: 'CamilloBruni 11/4/2013 19:43'! initialize super initialize. self rewriteRule replace: 'self shouldnt: [ `@statements ] raise: Error' with: '`@statements'; replace: 'self shouldnt: [ `@statements ] raise: Exception' with: '`@statements'! ! !RBShouldntRaiseErrorRule methodsFor: 'accessing' stamp: 'CamilloBruni 11/4/2013 19:30'! rationale ^ 'Replaces `shouldnt: [ ... ] raise: Error` with `[ ... ]`'! ! !RBShouldntRaiseErrorRule methodsFor: 'accessing' stamp: 'CamilloBruni 11/4/2013 19:29'! group ^ 'Transformations'! ! !RBShouldntRaiseErrorRule methodsFor: 'accessing' stamp: 'CamilloBruni 11/4/2013 19:29'! name ^ '= nil -> isNil AND ~= nil -> notNil'! ! !RBShouldntRaiseErrorRule methodsFor: '*Manifest-Core' stamp: 'CamilloBruni 11/4/2013 19:29'! category ^ 'Coding Idiom Violation'! ! !RBShouldntRaiseErrorRule methodsFor: '*Manifest-Core' stamp: 'CamilloBruni 11/4/2013 19:42'! longDescription ^ '#shouldnt:raise: is a rather tricky method, it is mostly used to make a test "read" nicer, however it some severe drawbacks. Hence, it should only be used in certain cases. Consider the following examples. Example 1: ---------- self shouldnt: [ 1 somethingNotUnderstood ] raise: MessageNotUnderstood. In this particular case the expectations meet the result, the test fails with an assertion failure since a MNU is raised. Example 2: ---------- self shouldnt: [ 1/0 ] raise: MessageNotUnderstood. In this case the test will fail with a ZeroDivide. So in the negative case #shouldnt:raise: is not very helpful. As a result, #shouldnt:raise: does not change much on the test outcome, the statement itself produces the same failures. However there is the third and most common use case. Example 3: ---------- self shouldnt: [ 1/0 ] raise: Error. In this case the test fails, as expected, however not on a ZeroDivide but an internal error message that shadows the real error. Using Error as argument for #shouldnt:raise: shadows any possible error that might happen and thus should be avoided.'! ! !RBShouldntRaiseErrorRule class methodsFor: '*Manifest-Core' stamp: 'CamilloBruni 11/4/2013 23:38'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ShouldntRaiseErrorRule'! ! !RBSizeCheckRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:46'! initialize | patterns | super initialize. patterns := OrderedCollection new. patterns addAll: (self selectors collect: [ :each | '`@object size > 0 ifTrue: [`@object' , (self genericPatternForSelector: each) , '. `@.Statements2]' ]). patterns addAll: (self selectors collect: [ :each | '`@object isEmpty ifFalse: [`@object' , (self genericPatternForSelector: each) , '. `@.Statements2]' ]). patterns addAll: (self selectors collect: [ :each | '`@object notEmpty ifTrue: [`@object' , (self genericPatternForSelector: each) , '. `@.Statements2]' ]). patterns addAll: (self selectors collect: [ :each | '`@object size = 0 ifFalse: [`@object' , (self genericPatternForSelector: each) , '. `@.Statements2]' ]). self matcher matchesAnyOf: patterns do: [ :node :answer | node ]! ! !RBSizeCheckRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for code that checks that a collection is non-empty before sending it an iteration message (e.g., do:, collect:, etc.). Since the collection iteration messages work for empty collections, we do not need to clutter up our method with the extra size check.'! ! !RBSizeCheckRule methodsFor: 'private' stamp: 'lr 2/24/2009 20:47'! selectors ^ #( collect: do: reject: select: )! ! !RBSizeCheckRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBSizeCheckRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Unnecessary size check'! ! !RBSizeCheckRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:30'! category ^ 'Optimization'! ! !RBSizeCheckRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'SizeCheckRule'! ! !RBSmalllintChecker commentStamp: ''! I apply a lint rule to all classes and methods in a given environment. My main API is - ==run== which resets and runs the rules.! !RBSmalllintChecker methodsFor: 'accessing' stamp: ''! methodBlock: aBlock methodBlock := aBlock! ! !RBSmalllintChecker methodsFor: 'initialization' stamp: 'CamilloBruni 5/7/2013 17:38'! initialize methodBlock := []. environment := RBBrowserEnvironment new. context := RBSmalllintContext newNoCache! ! !RBSmalllintChecker methodsFor: 'private' stamp: 'SebastianTleye 8/13/2013 17:27'! checkClass: aClass context selectedClass: aClass. (environment includesClass: aClass) ifTrue: [rule checkClass: context]! ! !RBSmalllintChecker methodsFor: 'accessing' stamp: ''! rule: aLintRule rule := aLintRule! ! !RBSmalllintChecker methodsFor: 'accessing' stamp: ''! context: aSmalllintContext context := aSmalllintContext! ! !RBSmalllintChecker methodsFor: 'private' stamp: 'CamilleTeruel 11/14/2013 13:32'! checkMethodsForClass: aClass context selectedClass: aClass. ^environment selectorsForClass: aClass do: [:each | context selector: each. rule checkMethod: context. methodBlock value]! ! !RBSmalllintChecker methodsFor: 'accessing' stamp: ''! environment: aBrowserEnvironment environment := aBrowserEnvironment! ! !RBSmalllintChecker methodsFor: 'actions' stamp: 'CamilloBruni 8/31/2013 20:42'! run rule resetResult. environment allClassesAndTraitsDo: [ :class | self checkClass: class. self checkMethodsForClass: class ]! ! !RBSmalllintChecker methodsFor: 'initialize-release' stamp: ''! release context release. super release! ! !RBSmalllintChecker class methodsFor: 'instance creation' stamp: 'nk 11/12/2002 13:12'! runRule: aLintRule (self new) rule: aLintRule; run. ^aLintRule! ! !RBSmalllintChecker class methodsFor: 'instance creation' stamp: ''! runRule: aLintRule onEnvironment: aBrowserEnvironment (self new) rule: aLintRule; environment: aBrowserEnvironment; run. ^aLintRule! ! !RBSmalllintChecker class methodsFor: 'instance creation' stamp: 'lr 9/8/2011 20:15'! newWithContext ^(self new) context: RBSmalllintContext new; yourself! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! selector ^selector! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! parseTree ^parseTree isNil ifTrue: [parseTree := self buildParseTree] ifFalse: [parseTree]! ! !RBSmalllintContext methodsFor: 'testing' stamp: 'lr 3/7/2011 21:40'! includesBehaviorNamed: aClassName | current | current := self selectedClass. [ current isNil ] whileFalse: [ current name = aClassName ifTrue: [ ^ true ]. current := current superclass ]. ^ false! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! instVarNames ^self selectedClass allInstVarNames! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! selfMessages selfMessages isNil ifTrue: [self computeMessages]. ^selfMessages! ! !RBSmalllintContext methodsFor: 'initialization' stamp: ''! initialize self computeLiterals! ! !RBSmalllintContext methodsFor: 'printing' stamp: 'lr 3/28/2009 14:39'! printOn: aStream super printOn: aStream. self selectedClass isNil ifFalse: [ aStream nextPut: $ ; nextPutAll: self selectedClass name. self selector isNil ifFalse: [ aStream nextPutAll: '>>'; print: self selector ] ]! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! messages messages isNil ifTrue: [self computeMessages]. ^messages! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! selectedClass: anObject class := anObject. self selector: nil! ! !RBSmalllintContext methodsFor: 'accessing' stamp: 'nk 2/26/2005 10:19'! sourceCode ^self selectedClass sourceCodeAt: self selector ifAbsent: [ '' ].! ! !RBSmalllintContext methodsFor: 'private' stamp: ''! buildParseTree | tree | tree := self selectedClass parseTreeFor: self selector. tree isNil ifTrue: [^RBParser parseMethod: 'method']. ^tree! ! !RBSmalllintContext methodsFor: 'private' stamp: 'lr 11/2/2009 00:14'! computeMessages | searcher | selfMessages := Set new. superMessages := Set new. messages := Set new. searcher := RBParseTreeSearcher new. searcher matches: 'self `@message: ``@args' do: [:aNode :answer | selfMessages add: aNode selector]; matches: 'super `@message: ``@args' do: [:aNode :answer | superMessages add: aNode selector]; matches: '``@receiver `@message: ``@args' do: [:aNode :answer | messages add: aNode selector]. searcher executeTree: self parseTree initialAnswer: nil! ! !RBSmalllintContext methodsFor: 'initialize-release' stamp: ''! release literalProcess notNil ifTrue: [literalProcess terminate]. super release! ! !RBSmalllintContext methodsFor: 'testing' stamp: 'lr 7/23/2010 08:05'! isAbstract: aClass ^(aClass isMeta or: [(self literals includes: aClass name) or: [self literals includes: (Smalltalk globals associationAt: aClass name)]]) not! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! protocol ^self selectedClass whichCategoryIncludesSelector: self selector! ! !RBSmalllintContext methodsFor: 'private' stamp: ''! computeLiteralsForClass: aClass (selectors addAll: aClass selectors) do: [:sel | self computeLiteralsForSelector: sel in: aClass. Processor yield]! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! selectedClass ^class! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! superMessages superMessages isNil ifTrue: [self computeMessages]. ^superMessages! ! !RBSmalllintContext methodsFor: 'testing' stamp: ''! uses: anObject ^self literals includes: anObject! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! selector: anObject selector := anObject. parseTree := compiledMethod := selfMessages := superMessages := messages := nil! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! compiledMethod ^compiledMethod notNil ifTrue: [compiledMethod] ifFalse: [compiledMethod := class compiledMethodAt: selector]! ! !RBSmalllintContext methodsFor: 'testing' stamp: ''! implements: aSelector ^self selectors includes: aSelector! ! !RBSmalllintContext methodsFor: 'private' stamp: ''! checkLiteral: aLiteral (aLiteral isSymbol or: [aLiteral isVariableBinding]) ifTrue: [literals add: aLiteral] ifFalse: [aLiteral class == Array ifTrue: [aLiteral do: [:each | self checkLiteral: each]]]! ! !RBSmalllintContext methodsFor: 'private' stamp: ''! computeLiterals literalSemaphore := Semaphore new. literalProcess := [self primitiveComputeLiterals] fork! ! !RBSmalllintContext methodsFor: 'private' stamp: ''! computeLiteralsForSelector: aSelector in: aClass | method | method := aClass compiledMethodAt: aSelector ifAbsent: [nil]. method isNil ifTrue: [^self]. self addLiteralsFor: method! ! !RBSmalllintContext methodsFor: 'private' stamp: 'lr 9/8/2011 20:25'! primitiveComputeLiterals | semaphore | literals := IdentitySet new: 25000. literals addAll: self specialSelectors keys. selectors := IdentitySet new. RBBrowserEnvironment new classesDo: [ :each | self computeLiteralsForClass: each ]. semaphore := literalSemaphore. literalSemaphore := nil. self signalProcesses: semaphore. ^literalProcess := nil! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! protocols ^Array with: self protocol! ! !RBSmalllintContext methodsFor: 'private' stamp: ''! signalProcesses: aSemaphore aSemaphore isNil ifTrue: [^self]. [aSemaphore isEmpty] whileFalse: [aSemaphore signal]! ! !RBSmalllintContext methodsFor: 'private' stamp: 'lr 2/5/2010 15:50'! addLiteralsFor: aCompiledMethod 2 to: aCompiledMethod numLiterals - 1 do: [ :index | self checkLiteral: (aCompiledMethod objectAt: index) ]! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! selectors literalSemaphore isNil ifTrue: [selectors isNil ifTrue: [self computeLiterals. literalSemaphore wait]] ifFalse: [literalSemaphore wait]. ^selectors! ! !RBSmalllintContext methodsFor: 'private' stamp: 'dvf 9/15/2001 17:39'! specialSelectors | answer | answer := IdentityDictionary new. (Smalltalk specialSelectors select: [:sel | sel isSymbol]) do: [:sel | answer at: sel put: nil.]. ^answer.! ! !RBSmalllintContext methodsFor: 'accessing' stamp: ''! literals literalSemaphore isNil ifTrue: [literals isNil ifTrue: [self computeLiterals. literalSemaphore wait]] ifFalse: [literalSemaphore wait]. ^literals! ! !RBSmalllintContext class methodsFor: 'instance creation' stamp: ''! newNoCache ^self basicNew! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testDetectContains self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:12'! testRefersToClass self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'MarcusDenker 9/20/2013 15:35'! testEquivalentSuperclassMethods | returnedEnvironment rule | RBSmalllintChecker runRule: (rule := RBEquivalentSuperclassMethodsRule new) onEnvironment: self smalllintTestEnvironment. returnedEnvironment := RBSelectorEnvironment new. returnedEnvironment addClass: RBSmalllintTestObject selector: #isLiteral. self checkRule: rule isEqualTo: returnedEnvironment! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testStringConcatenation self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testToDoWithIncrement self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'CamilloBruni 11/4/2013 23:36'! testShouldntRaiseError self ruleFor: self currentSelector plusSelectors: #(shouldntRaiseException)! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testCollectionMessagesToExternalObject self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:15'! testConsistencyCheck self ruleFor: self currentSelector plusSelectors: #(#noIsNil: )! ! !RBSmalllintTest methodsFor: 'private' stamp: 'lr 12/24/2008 16:50'! currentSelector ^ testSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:12'! testTempVarOverridesInstVar self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:12'! testTempsReadBeforeWritten self ruleFor: self currentSelector plusSelectors: #(#inlineTemporary #noMoveDefinition #tempsReadBeforeWritten #equalNotUsed #fileBlocks #referencesConditionFor:)! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testToDoCollect self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testUsesAdd self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testGuardingClause self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testBooleanPrecedence self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testToDo self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testIfTrueReturns self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'private' stamp: 'lr 9/7/2010 20:19'! compare: subEnvironment to: superEnvironment subEnvironment classesDo: [ :class | (subEnvironment selectorsForClass: class) do: [ :selector | self assert: (superEnvironment includesSelector: selector in: class) ] ]! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:41'! testUnclassifiedMethods self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:12'! testReturnsBooleanAndOther self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:50'! testUncommonMessageSend self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'private' stamp: 'lr 2/26/2009 16:10'! ruleFor: aSelector self ruleFor: aSelector plusSelectors: #()! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:13'! testAtIfAbsent self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:15'! testExtraBlock self ruleFor: self currentSelector plusSelectors: #(#testMethod1 )! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testReturnInEnsure self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:47'! testCodeCruftLeftInMethods self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testEqualsTrue self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testCollectionProtocol self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testAssignmentInIfTrue self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testIfTrueBlocks self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:12'! testLongMethods self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'bh 4/8/2000 19:06'! testFullBlocks "skip this test in squeak" " self blockRuleFor: self currentSelector plusSelectors: #(#caller1 #fullBlocks #detectContains #fileBlocks #moveDefinition #caller #assignmentInBlock #equalNotUsed #stringConcatenation #noMoveDefinition #referencesConditionFor: #returnInEnsure)"! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testLiteralArrayCharacters self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testFileBlocks self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testCollectSelectNotUsed self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 21:03'! testTemporaryVariableCapitalization self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:12'! testJustSendsSuper self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:13'! testAssignmentInBlock self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testPrecedence self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'private' stamp: ''! checkRule: aLintRule isEqualTo: anEnvironment | returnedEnvironment | returnedEnvironment := aLintRule result. self compare: returnedEnvironment to: anEnvironment. self compare: anEnvironment to: returnedEnvironment! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testMinMax self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:58'! testFloatEqualityComparison self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testSearchingLiteral self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testEqualNotUsed self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 21:04'! testAssignmentWithoutEffect self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testEndTrueFalse self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'CamilloBruni 1/15/2013 23:56'! testBadMessage self ruleFor: self currentSelector plusSelectors: #(codeCruftLeftInMethods collectionMessagesToExternalObject)! ! !RBSmalllintTest methodsFor: 'private' stamp: 'lr 9/8/2011 20:32'! smalllintTestEnvironment | classEnvironment | classEnvironment := RBClassEnvironment new. classEnvironment addClass: RBSmalllintTestObject. ^ classEnvironment! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:15'! testMissingYourself self ruleFor: self currentSelector plusSelectors: #(#inlineMethod )! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testSizeCheck self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testModifiesCollection self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 21:05'! testEmptyExceptionHandler self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testReturnsIfTrue self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testContains self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:58'! testLiteralArrayContainsComma self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:42'! testUsesTrue self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testThreeElementPoint self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:12'! testSendsDifferentSuper self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testWhileTrue self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testYourselfNotUsed self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:46'! testUnoptimizedAndOr self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:13'! testAsOrderedCollectionNotNeeded self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:56'! testOnlyReadOrWrittenTemporary self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'private' stamp: 'CamilloBruni 11/4/2013 19:56'! ruleFor: aSelector plusSelectors: symbolCollection | returnedEnvironment rule class selector className | selector := aSelector asString copyFrom: 5 to: aSelector size. className := 'RB' , selector , 'Rule'. class := Smalltalk classNamed: className. class isNil ifTrue: [ self error: className , ' class not found' ]. selector at: 1 put: selector first asLowercase. selector := selector asSymbol. RBSmalllintChecker runRule: (rule := class new) onEnvironment: self smalllintTestEnvironment. returnedEnvironment := RBSelectorEnvironment new. returnedEnvironment addClass: RBSmalllintTestObject selector: selector. symbolCollection do: [ :each | returnedEnvironment addClass: RBSmalllintTestObject selector: each ]. self assert: (RBSmalllintTestObject includesSelector: selector) description: 'Missing test method RBSmalllintTestObject>>', selector printString. self assert: (rule name isString and: [ rule name notEmpty ]) description: 'Missing rule name'. self assert: (rule group isString and: [ rule group notEmpty ]) description: 'Missing group name'. self assert: (rule rationale isString and: [ rule rationale notEmpty ]) description: 'Missing rationale'. self assert: (#(error warning information) includes: rule severity) description: 'Invalid severity'. self checkRule: rule isEqualTo: returnedEnvironment! ! !RBSmalllintTest class methodsFor: 'accessing' stamp: 'lr 9/5/2010 10:48'! packageNamesUnderTest ^ #('Refactoring-Critics')! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! collectionMessagesToExternalObject self someObject collection remove: 10! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! literalArrayCharacters ^#($a $b $c) includes: $a! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! atIfAbsent ^ Smalltalk at: #MyTest ifAbsent: [| collection | collection := #(). Smalltalk at: #MyTest put: collection]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! usesAdd ^(1 to: 10) asOrderedCollection addAll: (11 to: 20)! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! collectionProtocol | newCollection | newCollection := OrderedCollection new. (1 to: 10) asOrderedCollection do: [:each | | new | new := each * 2. newCollection add: new]. ^newCollection! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:17'! refersToClass ^ RBSmalllintTestObject! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! returnInEnsure [self error: 'asdf'] ensure: [^4]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! guardingClause self isSymbol ifFalse: [self printString. self isSymbol printString]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! assignmentInBlock [^self printString] ensure: [self close]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 21:05'! emptyExceptionHandler [ ] on: Error do: [ :err | ]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! returnsIfTrue ^self isNil ifTrue: [4]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! searchingLiteral ^self printString = #a or: [#() = self printString | ( #() == self printString)]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:56'! onlyReadOrWrittenTemporary | a | a := 1! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! release self printString! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! tempVarOverridesInstVar | temporaryVariable | temporaryVariable := 4. ^temporaryVariable! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! variableAssignedLiteral temporaryVariable := #() ! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! detectContains ^(1 to: 10) do: [:each | each > 2 ifTrue: [^each]]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! noIsNil: arg ^arg = nil or: [ arg ~= nil ]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! returnsBooleanAndOther self isVariable ifTrue: [^false]. self printString! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! precedence ^self isArray ifFalse: [self block + 5 * 34] ifTrue: [self printString = 10]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! missingYourself ^(OrderedCollection new) add: 1; add: 2; removeFirst! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! modifiesCollection | collection | collection := (1 to: 10) asOrderedCollection. collection do: [:each | each > 5 ifTrue: [collection remove: each]]. ^collection! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:55'! uncommonMessageSend true false! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 21:06'! assignmentWithoutEffect | a | a := 1. a := a! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! fileBlocks | file | ^ [file := 'asdf' asFilename readStream. file contents] ensure: [file close]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:58'! literalArrayContainsComma ^ #(#,)! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:46'! unoptimizedAndOr ^ (true and: [ false ]) and: [ true ]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! toDo 1 to: self size do: [:i | (self at: i) printString]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'CamilloBruni 11/4/2013 23:35'! shouldntRaiseError self shouldnt: [ 0/1 ] raise: Error! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! yourselfNotUsed self printString; printString; yourself! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! toDoCollect | array | array := Array new: 10. 1 to: 10 do: [:i | array at: i put: i * i]. ^array! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! equalsTrue ^true == self! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! tempsReadBeforeWritten | temp | self isVariable ifTrue: [temp := 4]. ^temp! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! whileTrue | i | i := 1. [i < self size] whileTrue: [(self at: i) printString. i := i + 1]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 21:03'! temporaryVariableCapitalization | Capital | Capital := 'Bern'. ^ Capital! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'CamilloBruni 11/4/2013 23:34'! ifTrueBlocks ^ true ifFalse: self foo! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! threeElementPoint ^5 @ 5 + 6 @ 6! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:43'! usesTrue ^ True! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! asOrderedCollectionNotNeeded self foo addAll: (1 to: 10) asOrderedCollection! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:47'! codeCruftLeftInMethods self halt! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! stringConcatenation | string | string := '' yourself. (1 to: 10) do: [:i | string := string , i printString]. ^string! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! consistencyCheck ^(1 to: 10) at: 1! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:48'! sizeCheck self isEmpty ifFalse: [self do: [:each | ]]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! assignmentInIfTrue | variable | self isVariable ifTrue: [variable := self] ifFalse: [variable := self printString]. ^variable! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! collectSelectNotUsed (1 to: 10) select: [:each | each = 4]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! extraBlock ^[:arg | arg + 43] value: 45! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! sendsDifferentSuper super printString! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'CamilloBruni 11/4/2013 23:35'! shouldntRaiseException self shouldnt: [ 0/1 ] raise: Exception! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! toDoWithIncrement | counter | counter := 0. 1 to: 10 by: 2 do: [:i | counter := counter + 2]. ^counter! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! booleanPrecedence ^true & 4 = 45! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! contains ^((1 to: 10) detect: [:each | each > 2] ifNone: [nil]) isNil! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! fullBlocks ^[thisContext]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! badMessage self become: String new! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! ifTrueReturns self isSymbol ifFalse: [^true]. ^false! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'CamilleTeruel 4/3/2013 18:12'! longMethods self printString. self printString. self printString. self printString. self printString. self printString. self printString. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]. self isVariable ifTrue: [self printString]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! minMax "Bug in 3<5 ifTrue: [3] ifFalse: [5]" ^3<5 ifTrue: [3] ifFalse: [5] " | var | var := 4. var < 5 ifTrue: [var := 5]. ^var"! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! equalNotUsed | string | string = '' yourself. (1 to: 10) do: [:i | string := i printString]. ^string! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! endTrueFalse self isVariable ifTrue: [self printString. self isVariable printString] ifFalse: [self printString. ^4]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:59'! floatEqualityComparison ^ 1.0 = 1! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! justSendsSuper super justSendsSuper! ! !RBSmalllintTestObject methodsFor: 'as yet unclassified' stamp: 'lr 9/7/2010 20:41'! unclassifiedMethods "intentionally unclassified method"! ! !RBSourceRegexRefactoring methodsFor: 'private' stamp: ''! parseMethod: aString ^ [ RBParser parseMethod: aString ] on: Error do: [ :err | nil ]! ! !RBSourceRegexRefactoring methodsFor: 'transforming' stamp: 'MarcusDenker 4/28/2013 11:17'! transform | original replacement protocols | self model allClassesDo: [ :class | class selectors do: [ :selector | original := class sourceCodeFor: selector. replacement := self execute: original. replacement = original ifFalse: [ (self parseMethod: replacement) isNil ifFalse: [ protocols := class protocolsFor: selector. (class compiler parseSelector: replacement) = selector ifFalse: [ class removeMethod: selector ]. class compile: replacement classified: protocols ] ] ] ]! ! !RBSpecialCharacterToken commentStamp: 'md 8/9/2005 14:53'! RBSpecialCharacterToken is the first class representation of special characters. ! !RBSpecialCharacterToken methodsFor: 'private' stamp: ''! length ^1! ! !RBSpecialCharacterToken methodsFor: 'testing' stamp: ''! isSpecial ^true! ! !RBSplitCascadeRefactoring methodsFor: 'transforming' stamp: ''! splitCascade ancestorNode parent addNode: (beforeNodes size > 1 ifTrue: [ RBCascadeNode messages: beforeNodes ] ifFalse: [ beforeNodes first ]) before: ancestorNode. afterNodes size > 1 ifTrue: [ cascadeNode messages: afterNodes ] ifFalse: [ cascadeNode replaceWith: afterNodes first ]. class compileTree: ancestorNode methodNode! ! !RBSplitCascadeRefactoring methodsFor: 'accessing' stamp: 'CamilloBruni 10/7/2012 23:58'! parseTree parseTree isNil ifTrue: [ parseTree := class parseTreeFor: selector. parseTree isNil ifTrue: [ self refactoringFailure: 'Could not parse sources' ] ]. ^ parseTree! ! !RBSplitCascadeRefactoring methodsFor: 'transforming' stamp: ''! extractReceiver | name | (cascadeNode receiver isLiteralNode or: [ cascadeNode receiver isVariable ]) ifTrue: [ ^ self ]. name := self safeVariableNameFor: class temporaries: self parseTree allDefinedVariables basedOn: 'receiver'. ancestorNode parent addTemporaryNamed: name; addNode: (RBAssignmentNode variable: (RBVariableNode named: name) value: cascadeNode receiver) before: ancestorNode. cascadeNode messages do: [ :each | each receiver: (RBVariableNode named: name) ] ! ! !RBSplitCascadeRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:00'! findAncestorNode "The ancestor node is the node that is contained within the sequence. In most cases this is the cascade itself, but it also can be an assignment or a return node." ancestorNode := cascadeNode. [ ancestorNode parent isSequence not and: [ ancestorNode parent isAssignment ] ] whileTrue: [ ancestorNode := ancestorNode parent ]. [ ancestorNode parent isSequence not and: [ ancestorNode parent isReturn ] ] whileTrue: [ ancestorNode := ancestorNode parent ]. ancestorNode parent isSequence ifFalse: [ self refactoringFailure: 'To split this cascade, you must extract it to a temporary first' ]! ! !RBSplitCascadeRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:00'! findCascadeNode "Find the cascade to be split." cascadeNode := self parseTree bestNodeFor: selectedInterval. [ cascadeNode isNil or: [ cascadeNode isCascade ] ] whileFalse: [ cascadeNode := cascadeNode parent ]. cascadeNode isNil ifTrue: [ self refactoringFailure: 'The selection doesn''t appear to be within a cascade' ]! ! !RBSplitCascadeRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^ (RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [ self findCascadeNode; findAncestorNode; findMessageNodes. true ])! ! !RBSplitCascadeRefactoring methodsFor: 'initialization' stamp: ''! split: anInterval from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. selectedInterval := anInterval! ! !RBSplitCascadeRefactoring methodsFor: 'transforming' stamp: ''! transform self extractReceiver. self splitCascade! ! !RBSplitCascadeRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/8/2012 00:00'! findMessageNodes "Find the nodes that form the first part of the cascade and the second part of the cascade." beforeNodes := cascadeNode messages select: [ :each | each stop <= selectedInterval first ]. afterNodes := cascadeNode messages select: [ :each | selectedInterval last <= each selectorParts first start ]. (beforeNodes isEmpty or: [ afterNodes isEmpty ]) ifTrue: [ self refactoringFailure: 'Splitting a cascade into the whole cascade and an empty one is pointless' ]. (beforeNodes size + afterNodes size = cascadeNode messages size) ifFalse: [ self refactoringFailure: 'To set the split boundary place the cursor inbetween two cascaded messages' ]! ! !RBSplitCascadeRefactoring class methodsFor: 'instance-creation' stamp: ''! split: anInterval from: aSelector in: aClass ^ self new split: anInterval from: aSelector in: aClass; yourself! ! !RBSplitCascadeRefactoring class methodsFor: 'instance-creation' stamp: ''! model: aNamespace split: anInterval from: aSelector in: aClass ^ self new model: aNamespace; split: anInterval from: aSelector in: aClass; yourself! ! !RBSplitClassRefactoring methodsFor: 'private-transforming' stamp: 'lr 9/8/2011 20:11'! abstractReferenceTo: each | setterMethod replacer accessorRef getterMethod | accessorRef := RBCreateAccessorsForVariableRefactoring variable: each class: newClass classVariable: false. self performComponentRefactoring: accessorRef. getterMethod := accessorRef getterMethod. setterMethod := accessorRef setterMethod. replacer := RBParseTreeRewriter variable: each getter: getterMethod setter: setterMethod receiver: referenceVariableName. self convertClasses: class withAllSubclasses select: [:aClass | aClass whichSelectorsReferToInstanceVariable: each] using: replacer. self performComponentRefactoring: (RBRemoveInstanceVariableRefactoring remove: each from: class)! ! !RBSplitClassRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition isValidClassName: newClassName) & (RBCondition isGlobal: newClassName in: self model) not & (RBCondition isValidInstanceVariableName: referenceVariableName for: class) & (RBCondition hierarchyOf: class definesVariable: referenceVariableName) not & (RBCondition isGlobal: referenceVariableName in: self model) not & (RBCondition definesTemporaryVariable: referenceVariableName in: class) not! ! !RBSplitClassRefactoring methodsFor: 'private-transforming' stamp: 'TorstenBergmann 2/26/2014 09:08'! addClass self performComponentRefactoring: (RBAddClassRefactoring model: self model addClass: newClassName superclass: Object subclasses: #() category: class category). newClass := self model classNamed: newClassName asSymbol! ! !RBSplitClassRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' class: '. class storeOn: aStream. aStream nextPutAll: ' instanceVariables: '. instanceVariables asArray storeOn: aStream. aStream nextPutAll: ' newClassName: #'; nextPutAll: newClassName; nextPutAll: ' referenceVariableName: '''; nextPutAll: referenceVariableName; nextPutAll: ''')'! ! !RBSplitClassRefactoring methodsFor: 'private-transforming' stamp: 'lr 9/8/2011 20:11'! addInstanceVariables instanceVariables do: [:each | self performComponentRefactoring: (RBAddInstanceVariableRefactoring model: self model variable: each class: newClass)]! ! !RBSplitClassRefactoring methodsFor: 'transforming' stamp: ''! transform self createNewClass; createReference; abstractVariableReferences! ! !RBSplitClassRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! createReference self performComponentRefactoring: (RBAddInstanceVariableRefactoring variable: referenceVariableName class: class)! ! !RBSplitClassRefactoring methodsFor: 'transforming' stamp: ''! createNewClass self addClass; addInstanceVariables! ! !RBSplitClassRefactoring methodsFor: 'transforming' stamp: ''! abstractVariableReferences instanceVariables do: [:each | self abstractReferenceTo: each]! ! !RBSplitClassRefactoring methodsFor: 'initialize-release' stamp: ''! class: aClass instanceVariables: instVars newClassName: className referenceVariableName: newVariable class := self model classFor: aClass. instanceVariables := instVars. newClassName := className. referenceVariableName := newVariable! ! !RBSplitClassRefactoring class methodsFor: 'instance creation' stamp: ''! class: class instanceVariables: instVars newClassName: className referenceVariableName: newVariable ^(self new) class: class instanceVariables: instVars newClassName: className referenceVariableName: newVariable; yourself! ! !RBSplitClassRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk class: class instanceVariables: instVars newClassName: className referenceVariableName: newVariable ^(self new) model: aRBSmalltalk; class: class instanceVariables: instVars newClassName: className referenceVariableName: newVariable; yourself! ! !RBStringConcatenationRule commentStamp: ''! Check for string concatenation inside some iteration message. Since string concatenation is O(n^2), it is better to use streaming since it is O(n) - assuming that n is large enough. As a general principal avoid , since the receiver is copied. Therefore chaining , messages will lead to multiple useless copies of the receiver. Instead of writing | string | string := String new. #(1 2 3) do: [ :each | string := string, each asString]. ^ string Write, it is much more efficient. String streamContents: [:s | #(1 2 3) do: [:each | s nextPutAll: each asString]] ! !RBStringConcatenationRule methodsFor: 'initialization' stamp: 'lr 6/4/2010 12:03'! initialize | concatenationMatcher | super initialize. concatenationMatcher := RBParseTreeSearcher new. concatenationMatcher matches: '`@receiver , `@argument' do: [ :node :answer | true ]. self matcher matchesAnyOf: #( '``@collection do: ``@argument' '``@collection do: ``@argument1 separatedBy: ``@argument2' '``@start to: ``@stop do: ``@argument' '``@collection detect: ``@argument' '``@collection detect: ``@argument1 ifNone: ``@argument2' '``@collection select: ``@argument' '``@collection reject: ``@argument' '``@collection inject: ``@value into: ``@argument' '``@collection anySatisfy: ``@argument' '``@collection allSatisfy: ``@argument' '``@collection noneSatisfy: ``@argument' ) do: [ :node :answer | answer isNil ifTrue: [ (node arguments detect: [ :each | each isBlock and: [ concatenationMatcher executeTree: each initialAnswer: false ] ] ifNone: [ nil ]) notNil ifTrue: [ node ] ifFalse: [ nil ] ] ifFalse: [ answer ] ]! ! !RBStringConcatenationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for people using string concatenation inside some iteration message. Since string concatenation is O(n^2), it is better to use streaming since it is O(n) - assuming that n is large enough.'! ! !RBStringConcatenationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBStringConcatenationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'String concatenation instead of streams'! ! !RBStringConcatenationRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:31'! category ^ 'Optimization'! ! !RBStringConcatenationRule methodsFor: '*Manifest-Core' stamp: 'BenComan 11/17/2013 15:08'! longDescription ^ 'Check for string concatenation inside some iteration message. Since string concatenation is O(n^2), it is better to use streaming since it is O(n) - assuming that n is large enough. As a general principal avoid , since the receiver is copied. Therefore chaining , messages will lead to multiple useless copies of the receiver. Instead of writing... | string | string := String new. {1. 1+1. 3} do: [ :each | string := string, each asString]. ^ string the following is much more efficient... String streamContents: [:s | {1. 1+1. 3} do: [:each | s nextPutAll: each asString]] or more concisely... '''' join: {1. 1+1. 3} '! ! !RBStringConcatenationRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'StringConcatenationRule'! ! !RBStringReplaceRule commentStamp: 'md 8/9/2005 14:56'! RBStringReplaceRule replaces a matched tree with another tree (which may include metavariable from the matching tree). This is a very succint syntax for specifying most rewrites. Instance Variables: replaceTree The tree to replace the matched tree with. ! !RBStringReplaceRule methodsFor: 'initialize-release' stamp: ''! searchFor: searchString replaceWith: replaceString self searchString: searchString. self replaceString: replaceString! ! !RBStringReplaceRule methodsFor: 'initialize-release' stamp: ''! searchForMethod: searchString replaceWith: replaceString self methodSearchString: searchString. self methodReplaceString: replaceString! ! !RBStringReplaceRule methodsFor: 'initialize-release' stamp: ''! searchForTree: aBRProgramNode replaceWith: replaceNode searchTree := aBRProgramNode. replaceTree := replaceNode! ! !RBStringReplaceRule methodsFor: 'initialize-release' stamp: ''! searchForTree: aBRProgramNode replaceWith: replaceString when: aBlock self searchForTree: aBRProgramNode replaceWith: replaceString. verificationBlock := aBlock! ! !RBStringReplaceRule methodsFor: 'matching' stamp: ''! foundMatchFor: aProgramNode | newNode | newNode := replaceTree copyInContext: self context. aProgramNode replaceMethodSource: newNode. newNode copyCommentsFrom: aProgramNode. ^newNode! ! !RBStringReplaceRule methodsFor: 'initialize-release' stamp: ''! methodReplaceString: replaceString replaceTree := RBParser parseRewriteMethod: replaceString! ! !RBStringReplaceRule methodsFor: 'initialize-release' stamp: ''! replaceString: replaceString replaceTree := RBParser parseRewriteExpression: replaceString. searchTree isSequence = replaceTree isSequence ifFalse: [searchTree isSequence ifTrue: [replaceTree := RBSequenceNode statements: (Array with: replaceTree)] ifFalse: [searchTree := RBSequenceNode statements: (Array with: searchTree)]]! ! !RBStringReplaceRule methodsFor: 'initialize-release' stamp: ''! searchForMethod: searchString replaceWith: replaceString when: aBlock self searchForMethod: searchString replaceWith: replaceString. verificationBlock := aBlock! ! !RBStringReplaceRule methodsFor: 'initialize-release' stamp: ''! searchFor: searchString replaceWith: replaceString when: aBlock self searchFor: searchString replaceWith: replaceString. verificationBlock := aBlock! ! !RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''! searchForMethod: searchString replaceWith: replaceString ^(self new) searchForMethod: searchString replaceWith: replaceString; yourself! ! !RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''! searchForMethod: searchString replaceWith: replaceString when: aBlock ^self new searchForMethod: searchString replaceWith: replaceString when: aBlock! ! !RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''! searchForTree: aRBProgramNode replaceWith: replaceString when: aBlock ^self new searchForTree: aRBProgramNode replaceWith: replaceString when: aBlock! ! !RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''! searchFor: searchString replaceWith: replaceString ^self new searchFor: searchString replaceWith: replaceString! ! !RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''! searchForTree: aRBProgramNode replaceWith: replaceString ^self new searchForTree: aRBProgramNode replaceWith: replaceString! ! !RBStringReplaceRule class methodsFor: 'instance creation' stamp: ''! searchFor: searchString replaceWith: replaceString when: aBlock ^self new searchFor: searchString replaceWith: replaceString when: aBlock! ! !RBStringReplacement commentStamp: ''! RBStringReplacement represents replacing source in the original method with a different string. These are used when reformatting code after a parse tree change has been made. Depending on the change, it may be possible to minimally change the parse tree without needing to format it. Instance Variables: startPosition the start position in the original source stopPosition the end position in the original source string replaces everything from the startPosition to the endPosition with this string ! !RBStringReplacement methodsFor: 'accessing' stamp: ''! string ^string! ! !RBStringReplacement methodsFor: 'accessing' stamp: ''! startPosition ^startPosition! ! !RBStringReplacement methodsFor: 'initialize-release' stamp: ''! stopPosition: anInteger stopPosition := anInteger! ! !RBStringReplacement methodsFor: 'accessing' stamp: ''! stopPosition ^stopPosition! ! !RBStringReplacement methodsFor: 'initialize-release' stamp: ''! string: aString string := aString! ! !RBStringReplacement methodsFor: 'initialize-release' stamp: ''! startPosition: anInteger startPosition := anInteger! ! !RBStringReplacement class methodsFor: 'instance creation' stamp: ''! replaceFrom: startInteger to: stopInteger with: aString ^(self new) startPosition: startInteger; stopPosition: stopInteger; string: aString; yourself! ! !RBSubclassOfClassToRename methodsFor: 'accessing' stamp: ''! calls1 ^self rewriteRule1: (self rewriteRule1: self calls)! ! !RBSubclassOfClassToRename methodsFor: 'accessing' stamp: ''! calls ^self rewriteRule1: self name , self rewriteRule1! ! !RBSubclassOfClassToRename methodsFor: 'accessing' stamp: ''! rewriteRule1: anObject ^rewriteRule1 := anObject! ! !RBSubclassOfClassToRename methodsFor: 'performing' stamp: 'lr 2/26/2009 14:51'! symbolReference ^ #RBClassToRename! ! !RBSubclassOfClassToRename methodsFor: 'performing' stamp: 'lr 2/26/2009 14:51'! reference ^ RBClassToRename new! ! !RBSubclassOfClassToRename methodsFor: 'accessing' stamp: ''! rewriteRule1 ^rewriteRule1! ! !RBSubclassOfClassToRename methodsFor: 'accessing' stamp: ''! name ^rewriteRule1! ! !RBSubclassResponsibilityNotDefinedRule commentStamp: ''! See my #rationale.! !RBSubclassResponsibilityNotDefinedRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:12'! category ^ 'Bugs'! ! !RBSubclassResponsibilityNotDefinedRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:11'! longDescription ^ 'This rule checks if all subclassResponsibility methods are defined in all leaf classes. if such a method is not overridden, a subclassResponsibility message can be occur when this method is called' ! ! !RBSubclassResponsibilityNotDefinedRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:39'! rationale ^ 'Checks that all methods which send #subclassResponsibility, which indicates that they are abstract, are defined in all leaf classes.'! ! !RBSubclassResponsibilityNotDefinedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBSubclassResponsibilityNotDefinedRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:04'! severity ^ #error! ! !RBSubclassResponsibilityNotDefinedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Subclass responsibility not defined'! ! !RBSubclassResponsibilityNotDefinedRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkClass: aContext (aContext selectedClass whichSelectorsReferTo: #subclassResponsibility) do: [ :each | (aContext selectedClass withAllSubclasses detect: [ :class | class subclasses isEmpty and: [ (class whichClassIncludesSelector: each) == aContext selectedClass ] ] ifNone: [ nil ]) notNil ifTrue: [ result addClass: aContext selectedClass selector: each ] ]! ! !RBSubclassResponsibilityNotDefinedRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'SubclassResponsibilityNotDefinedRule'! ! !RBSuperNode commentStamp: ''! I am a specialized variable node for 'super'! !RBSuperNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:33'! isSuper ^ true! ! !RBSuperNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:39'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitSuperNode: self! ! !RBSuperSendsNewRule commentStamp: ''! See my #rationale.! !RBSuperSendsNewRule methodsFor: 'initialization' stamp: 'lr 11/2/2009 00:14'! initialize super initialize. matcher := RBParseTreeSearcher new. matcher matchesAnyOf: #( 'super new initialize' '(super new: `@expr) initialize' 'self new initialize' '(self new: `@expr) initialize' ) do: [ :answer :node | true ].! ! !RBSuperSendsNewRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:19'! category ^ 'Bugs'! ! !RBSuperSendsNewRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:19'! longDescription ^' This rule checks for method that wrongly initialize an object twice. Contrary to other Smalltalk implementations Pharo automatically calls #initiailize on object creation. For example, a warning is raised when the statment self new initialize is found in a method.'! ! !RBSuperSendsNewRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:39'! rationale ^ 'Checks for methods that wrongly initialize an object twice. Contrary to other Smalltalk implementations Pharo automatically calls #initiailize on object creation.'! ! !RBSuperSendsNewRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBSuperSendsNewRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Sends super new initialize'! ! !RBSuperSendsNewRule methodsFor: 'running' stamp: 'lr 2/26/2009 16:32'! checkMethod: aContext aContext selectedClass isMeta ifTrue: [ ^ self ]. (matcher executeTree: aContext parseTree initialAnswer: false) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBSuperSendsNewRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'SuperSendsNewRule'! ! !RBSuperSendsRule commentStamp: ''! See rationale! !RBSuperSendsRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:44'! initialize super initialize. self rewriteRule replace: 'super `@message: ``@args' with: 'self `@message: ``@args' when: [ :node | (class withAllSubclasses detect: [:each | each includesSelector: node selector] ifNone: [ nil ]) isNil ]! ! !RBSuperSendsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBSuperSendsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Rewrite super messages to self messages when both refer to same method'! ! !RBSuperSendsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:52'! category ^ 'Design Flaws'! ! !RBSuperSendsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'SuperSendsRule'! ! !RBSwapMethodRefactoring commentStamp: 'lr 10/19/2007 09:16'! Move a method from the class to the instance side, or vice versa. Normally this is not considered to be a refactoring.! !RBSwapMethodRefactoring methodsFor: 'preconditions' stamp: ''! checkInstVars class instanceVariableNames do: [ :each | (target instanceVariableNames includes: each) ifFalse: [ ((class whichSelectorsReferToInstanceVariable: each) includes: selector) ifTrue: [ self refactoringError: ('<1p> refers to <2s>, which is not defined in <3p>' expandMacrosWith: selector with: each with: target) ] ] ]! ! !RBSwapMethodRefactoring methodsFor: 'initialization' stamp: ''! swapMethod: aSelector in: aClass class := self classObjectFor: aClass. target := self classObjectFor: (class isMeta ifTrue: [ class theNonMetaClass ] ifFalse: [ class theMetaClass ]). selector := aSelector! ! !RBSwapMethodRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^ (RBCondition definesSelector: selector in: class) & (RBCondition definesSelector: selector in: target) not & (RBCondition withBlock: [ self checkInstVars. true ])! ! !RBSwapMethodRefactoring methodsFor: 'transforming' stamp: ''! transform target compile: (class sourceCodeFor: selector) classified: (class protocolsFor: selector). class removeMethod: selector! ! !RBSwapMethodRefactoring class methodsFor: 'instance-creation' stamp: ''! model: aRBSmalltalk swapMethod: aSelector in: aClass ^ self new model: aRBSmalltalk; swapMethod: aSelector in: aClass; yourself! ! !RBSwapMethodRefactoring class methodsFor: 'instance-creation' stamp: ''! swapMethod: aSelector in: aClass ^ self new swapMethod: aSelector in: aClass! ! !RBTempVarOverridesInstVarRule commentStamp: ''! See my #rationale.! !RBTempVarOverridesInstVarRule methodsFor: 'initialization' stamp: 'CamilloBruni 11/18/2013 17:31'! initialize super initialize. matcher := RBParseTreeSearcher new. matcher matchesArgument: '`var' do: [ :aNode :answer | answer or: [ varName := aNode name. vars includes: varName ]]! ! !RBTempVarOverridesInstVarRule methodsFor: 'copying' stamp: 'CamilloBruni 11/18/2013 17:33'! postCopy super postCopy. self initialize.! ! !RBTempVarOverridesInstVarRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 13:59'! category ^ 'Potential Bugs'! ! !RBTempVarOverridesInstVarRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:43'! rationale ^ 'Finds methods whose temporary variables override an instance variable. This causes problems if you want to use the instance variable inside the method.'! ! !RBTempVarOverridesInstVarRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBTempVarOverridesInstVarRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Instance variable overridden by temporary variable'! ! !RBTempVarOverridesInstVarRule methodsFor: 'running' stamp: 'lr 2/24/2009 00:14'! checkMethod: aContext vars := aContext instVarNames. (matcher executeTree: aContext parseTree initialAnswer: false) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector. result addSearchString: varName ]! ! !RBTempVarOverridesInstVarRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'TempVarOverridesInstVarRule'! ! !RBTemporaryNode commentStamp: ''! I am a specialized variable node for temporary variables! !RBTemporaryNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:39'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitTemporaryNode: self! ! !RBTemporaryNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:32'! isTemp ^ true! ! !RBTemporaryToInstanceVariableRefactoring methodsFor: 'preconditions' stamp: 'CamilloBruni 10/7/2012 23:58'! checkForValidTemporaryVariable | parseTree | parseTree := class parseTreeFor: selector. (parseTree allTemporaryVariables includes: temporaryVariableName) ifFalse: [self refactoringFailure: temporaryVariableName , ' isn''t a valid temporary variable name']. (parseTree allArgumentVariables includes: temporaryVariableName) ifTrue: [self refactoringFailure: temporaryVariableName , ' is a block parameter']. (RBReadBeforeWrittenTester isVariable: temporaryVariableName readBeforeWrittenIn: parseTree) ifTrue: [self refactoringWarning: ('<1s> is read before it is written.Proceed anyway?' expandMacrosWith: temporaryVariableName)]! ! !RBTemporaryToInstanceVariableRefactoring methodsFor: 'preconditions' stamp: ''! preconditions ^(RBCondition definesSelector: selector in: class) & (RBCondition hierarchyOf: class definesVariable: temporaryVariableName asString) not & (RBCondition withBlock: [self checkForValidTemporaryVariable. true])! ! !RBTemporaryToInstanceVariableRefactoring methodsFor: 'initialize-release' stamp: ''! class: aClass selector: aSelector variable: aVariableName class := self classObjectFor: aClass. selector := aSelector. temporaryVariableName := aVariableName! ! !RBTemporaryToInstanceVariableRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' class: '. class storeOn: aStream. aStream nextPutAll: ' selector: #'; nextPutAll: selector; nextPutAll: ' variable: '''; nextPutAll: temporaryVariableName; nextPut: $'. aStream nextPut: $)! ! !RBTemporaryToInstanceVariableRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/7/2012 23:58'! transform | parseTree matcher method | method := class methodFor: selector. parseTree := method parseTree. parseTree isNil ifTrue: [self refactoringFailure: 'Could not parse method']. class removeMethod: selector. class addInstanceVariable: temporaryVariableName. (matcher := RBParseTreeRewriter removeTemporaryNamed: temporaryVariableName) executeTree: parseTree. method compileTree: matcher tree! ! !RBTemporaryToInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''! class: aClass selector: aSelector variable: aVariableName ^self new class: aClass selector: aSelector variable: aVariableName! ! !RBTemporaryToInstanceVariableRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk class: aClass selector: aSelector variable: aVariableName ^(self new) model: aRBSmalltalk; class: aClass selector: aSelector variable: aVariableName; yourself! ! !RBTemporaryToInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBTemporaryToInstanceVariableRefactoring class: RBBasicLintRuleTest selector: #checkClass: variable: 'asdf'); shouldFail: (RBTemporaryToInstanceVariableRefactoring class: RBBasicLintRuleTest selector: #checkClass1: variable: 'aSmalllintContext')! ! !RBTemporaryToInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testRedefinedTemporary | class | class := model classNamed: #Foo. class compile: 'someMethod | instVarName1 | instVarName1 := 4. ^instVarName1' classified: #(#accessing). self shouldFail: (RBTemporaryToInstanceVariableRefactoring class: class selector: #someMethod variable: 'instVarName1')! ! !RBTemporaryToInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testTemporaryToInstanceVariable | refactoring class | refactoring := RBTemporaryToInstanceVariableRefactoring class: RBLintRuleTest selector: #displayName variable: 'nameStream'. self executeRefactoring: refactoring. class := refactoring model classNamed: #RBLintRuleTest. self assert: (class parseTreeFor: #displayName) = (RBParser parseMethod: 'displayName nameStream := WriteStream on: (String new: 64). nameStream nextPutAll: self name; nextPutAll: '' (''. self problemCount printOn: nameStream. nameStream nextPut: $). ^nameStream contents'). self assert: (class directlyDefinesInstanceVariable: 'nameStream')! ! !RBTemporaryToInstanceVariableTest methodsFor: 'set up' stamp: 'CamilloBruni 8/27/2013 15:06'! setUp super setUp. model := self abstractVariableTestData.! ! !RBTemporaryVariableCapitalizationRule commentStamp: ''! See my #rationale.! !RBTemporaryVariableCapitalizationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Temporary and argument variable names should start with a lowercase letter.'! ! !RBTemporaryVariableCapitalizationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBTemporaryVariableCapitalizationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Temporary variable capitalization'! ! !RBTemporaryVariableCapitalizationRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:20'! category ^ 'Style'! ! !RBTemporaryVariableCapitalizationRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkMethod: aContext aContext parseTree allDefinedVariables do: [ :each | each first isLowercase ifFalse: [ result addClass: aContext selectedClass selector: aContext selector. result addSearchString: each ] ]! ! !RBTemporaryVariableCapitalizationRule methodsFor: '*Manifest-Core' stamp: 'ah 8/6/2012 15:07'! longDescription ^ 'This smell arises when a temporary or argument variable do not start with a lowercase letter, which is a standart style in Smalltalk.'! ! !RBTemporaryVariableCapitalizationRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'TemporaryVariableCapitalizationRule'! ! !RBTempsReadBeforeWrittenRule commentStamp: ''! See my #rationale.! !RBTempsReadBeforeWrittenRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks that all temporaries are assigned before they are used. This can help find possible paths through the code where a variable might be unassigned when it is used.'! ! !RBTempsReadBeforeWrittenRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBTempsReadBeforeWrittenRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Temporaries read before written'! ! !RBTempsReadBeforeWrittenRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:40'! category ^ 'Potential Bugs'! ! !RBTempsReadBeforeWrittenRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkMethod: aContext (RBReadBeforeWrittenTester variablesReadBeforeWrittenIn: aContext parseTree) do: [ :each | result addClass: aContext selectedClass selector: aContext selector. result addSearchString: each ]! ! !RBTempsReadBeforeWrittenRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'TempsReadBeforeWrittenRule'! ! !RBThemeAPIUpdateRule commentStamp: ''! See rationale! !RBThemeAPIUpdateRule methodsFor: 'initialization' stamp: 'DamienCassou 5/14/2013 16:23'! initialize super initialize. self rewriteRule replace: 'UITheme current' with: 'Smalltalk ui theme'; replace: 'ThemeIcons current' with: 'Smalltalk ui icons'! ! !RBThemeAPIUpdateRule methodsFor: 'accessing' stamp: 'DamienCassou 5/14/2013 16:49'! rationale ^ 'You should not refer to the UITheme or ThemeIcons classes directly because we will kill these classes.'! ! !RBThemeAPIUpdateRule methodsFor: 'accessing' stamp: 'DamienCassou 5/14/2013 16:22'! group ^ 'Transformations'! ! !RBThemeAPIUpdateRule methodsFor: 'accessing' stamp: 'DamienCassou 5/14/2013 16:21'! name ^ 'Use "Smalltalk ui theme" and "Smalltalk ui icons" instead of "UITheme current" and "ThemeIcons current".'! ! !RBThemeAPIUpdateRule methodsFor: '*Manifest-Core' stamp: 'DamienCassou 5/14/2013 16:11'! category ^'Coding Idiom Violation'! ! !RBThemeAPIUpdateRule class methodsFor: '*Manifest-Core' stamp: 'DamienCassou 5/14/2013 16:29'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ThemeAPIUpdateRule'! ! !RBThisContextNode commentStamp: ''! I represent the specialized variable named 'thisContext'! !RBThisContextNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:39'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitThisContextNode: self! ! !RBThreeElementPointRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:50'! initialize super initialize. self matcher matches: '``@x @ ``@y' do: [ :node :answer | answer isNil ifTrue: [ | current | current := node parent. [ current isNil or: [ current isMessage and: [ current selector = #@ or: [ current selector isInfix not ] ] ] ] whileFalse: [ current := current parent ]. (current isNil or: [ current isMessage and: [ current selector isInfix not ] ]) ifTrue: [ nil ] ifFalse: [ node ] ] ifFalse: [ answer ] ]! ! !RBThreeElementPointRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks arithmetic statements for possible three element points (i.e., a point that has another point in its x or y part).'! ! !RBThreeElementPointRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBThreeElementPointRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Possible three element point (e.g., x @ y + q @ r)'! ! !RBThreeElementPointRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:32'! category ^ 'Potential Bugs'! ! !RBThreeElementPointRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ThreeElementPointRule'! ! !RBToDoCollectRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:50'! initialize super initialize. self matcher matchesAnyOf: #( '| `@temps1 | `@.Stmts1. `collection := Array new: `@size. `@.Stmts2. 1 to: `@size do: [:`i | | `@Btemps2 | `@.BStmts1. `collection at: `i put: `@obj. `@.BStmt2]. `@.Stmts3' '| `@temps1 | `@.Stmts1. `collection := Array new: `@size. `@.Stmts2. 1 to: `collection size do: [:`i | | `@Btemps2 | `@.BStmts1. `collection at: `i put: `@obj. `@.BStmt2]. `@.Stmts3' ) do: [ :node :answer | node ]! ! !RBToDoCollectRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:39'! rationale ^ 'Checks for users of to:do: when the shorter collect: would work.'! ! !RBToDoCollectRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBToDoCollectRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'to:do: doesn''t use collect:'! ! !RBToDoCollectRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:33'! category ^ 'Coding Idiom Violation'! ! !RBToDoCollectRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ToDoCollectRule'! ! !RBToDoRule methodsFor: 'initialization' stamp: 'lr 11/2/2009 23:38'! initialize super initialize. self matcher matches: '1 to: ``@object size do: [:`each | | `@temps | `@.Statements]' do: [ :node :answer | answer isNil ifTrue: [ | varName variableMatcher | varName := node arguments last arguments first. "`each" variableMatcher := RBParseTreeSearcher new. variableMatcher matchesTree: varName do: [ :nod :ans | ans and: [ nod parent isMessage and: [ nod parent selector = #at: ] ] ]. (variableMatcher executeTree: node arguments last body initialAnswer: true) ifTrue: [ node ] ifFalse: [ nil ] ] ifFalse: [ answer ] ]! ! !RBToDoRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for people using to:do: when a do:, with:do: or timesRepeat: should be used.'! ! !RBToDoRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBToDoRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses to:do: instead of do:, with:do: or timesRepeat:'! ! !RBToDoRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:33'! category ^ 'Coding Idiom Violation'! ! !RBToDoRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ToDoRule'! ! !RBToDoWithIncrementRule methodsFor: 'initialization' stamp: 'lr 5/15/2010 17:41'! initialize super initialize. self matcher matchesAnyOf: #( '`@i to: `@j do: [:`e | | `@temps | `@.Stmts. `x := `x + 1. `@.Stmts2]' '`@i to: `@j by: `@k do: [:`e | | `@temps | `@.Stmts. `x := `x + `@k. `@.Stmts2]' '`@i to: `@j do: [:`e | | `@temps | `@.Stmts. `x := `x - 1. `@.Stmts2]' '`@i to: `@j by: `@k do: [:`e | | `@temps | `@.Stmts. `x := `x - `@k. `@.Stmts2]') do: [ :node :answer | node ]! ! !RBToDoWithIncrementRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:42'! rationale ^ 'Checks for users of to:do: that also increment or decrement a counter.'! ! !RBToDoWithIncrementRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBToDoWithIncrementRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'to:do: loop also increments a counter'! ! !RBToDoWithIncrementRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:33'! category ^ 'Coding Idiom Violation'! ! !RBToDoWithIncrementRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'ToDoWithIncrementRule'! ! !RBToken commentStamp: ''! RBToken is the abstract superclass of all of the RB tokens. These tokens (unlike the standard parser's) remember where they came from in the original source code. Subclasses must implement the following messages: accessing length Instance Variables: sourcePointer The position in the original source code where this token began. ! !RBToken methodsFor: 'accessing' stamp: ''! comments ^comments! ! !RBToken methodsFor: 'testing' stamp: ''! isIdentifier ^false! ! !RBToken methodsFor: 'accessing' stamp: ''! removePositions sourcePointer := nil! ! !RBToken methodsFor: 'testing' stamp: ''! isKeyword ^false! ! !RBToken methodsFor: 'testing' stamp: ''! isPatternVariable ^false! ! !RBToken methodsFor: 'testing' stamp: ''! isLiteralArrayToken ^false! ! !RBToken methodsFor: 'testing' stamp: ''! isBinary ^false! ! !RBToken methodsFor: 'testing' stamp: ''! isSpecial ^false! ! !RBToken methodsFor: 'accessing' stamp: ''! comments: anObject comments := anObject! ! !RBToken methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:17'! stop ^ sourcePointer ifNil: [ -1 ] ifNotNil: [ self start + self length - 1 ]! ! !RBToken methodsFor: 'testing' stamp: ''! isAssignment ^false! ! !RBToken methodsFor: 'testing' stamp: ''! isLiteralToken ^false! ! !RBToken methodsFor: 'printing' stamp: ''! printOn: aStream aStream nextPut: $ ; nextPutAll: self class name! ! !RBToken methodsFor: 'testing' stamp: ''! isPatternBlock ^false! ! !RBToken methodsFor: 'accessing' stamp: 'lr 2/18/2010 17:25'! start ^ sourcePointer ifNil: [ 0 ]! ! !RBToken methodsFor: 'accessing' stamp: ''! length ^self subclassResponsibility! ! !RBToken methodsFor: 'initialize-release' stamp: ''! start: anInteger sourcePointer := anInteger! ! !RBToken methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/10/2013 10:40'! isError ^false! ! !RBToken class methodsFor: 'instance creation' stamp: ''! start: anInterval ^self new start: anInterval! ! !RBTransformationRule commentStamp: ''! A RBTransformationRule is a special rule that not only detects problems but also can automatically transform the good.! !RBTransformationRule methodsFor: 'accessing' stamp: 'CamilleTeruel 4/3/2013 17:24'! changes ^ self builder changes! ! !RBTransformationRule methodsFor: 'initialization' stamp: 'lr 11/2/2009 00:14'! initialize super initialize. rewriteRule := RBParseTreeRewriter new! ! !RBTransformationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:46'! problemCount ^ builder problemCount! ! !RBTransformationRule methodsFor: 'testing' stamp: 'lr 2/23/2009 23:47'! isEmpty ^ builder changes isEmpty! ! !RBTransformationRule methodsFor: 'running' stamp: 'lr 9/8/2011 20:10'! resetResult builder := RBCompositeRefactoryChange named: self name! ! !RBTransformationRule methodsFor: 'accessing' stamp: 'CamilleTeruel 4/3/2013 17:24'! builder ^ builder ifNil: [ self resetResult. builder ]! ! !RBTransformationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:23'! rewriteRule ^ rewriteRule! ! !RBTransformationRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 3/29/2013 10:59'! transform: aCritic | changeCode | changeCode := (self changes detect: [ :ch | (ch isMeta = aCritic methodClass isMeta) & (ch changeClassName = aCritic criticTheNonMetaclassClass name) & (ch selector = aCritic selector)]) source. aCritic methodClass compile: changeCode! ! !RBTransformationRule methodsFor: 'testing' stamp: 'lr 2/23/2009 23:47'! hasConflicts ^ true! ! !RBTransformationRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:15'! result | environment | environment := RBParseTreeEnvironment new. environment matcher: self rewriteRule. environment label: self name. self changes do: [ :change | (change isKindOf: RBAddMethodChange) ifTrue: [ environment addClass: change changeClass selector: change selector ] ]. ^ environment! ! !RBTransformationRule methodsFor: 'running' stamp: 'CamilloBruni 8/31/2013 20:51'! checkMethod: aContext aContext compiledMethod isFromTrait ifTrue: [ ^ self ]. (self rewriteRule canMatchMethod: aContext compiledMethod) ifFalse: [ ^ self ]. class := aContext selectedClass. (self rewriteRule executeTree: aContext parseTree) ifTrue: [ (self class recursiveSelfRule executeTree: rewriteRule tree initialAnswer: false) ifFalse: [ builder compile: rewriteRule tree newSource in: class classified: aContext protocol ] ]! ! !RBTransformationRule methodsFor: '*Manifest-Core' stamp: ''! isTransformationRule ^ true ! ! !RBTransformationRule class methodsFor: 'initialization' stamp: 'lr 11/2/2009 00:14'! initializeRecursiveSelfRule RecursiveSelfRule := RBParseTreeSearcher new. RecursiveSelfRule matchesAnyMethodOf: #( '`@methodName: `@args | `@temps | self `@methodName: `@args1' '`@methodName: `@args | `@temps | ^ self `@methodName: `@args1') do: [ :node :answer | true ]. ^ RecursiveSelfRule! ! !RBTransformationRule class methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:48'! initialize self initializeRecursiveSelfRule! ! !RBTransformationRule class methodsFor: 'testing' stamp: 'lr 2/24/2009 17:09'! isVisible ^ self name ~= #RBTransformationRule! ! !RBTransformationRule class methodsFor: 'accessing' stamp: 'MarcusDenker 10/12/2013 00:09'! recursiveSelfRule ^ RecursiveSelfRule ifNil: [ self initializeRecursiveSelfRule ]! ! !RBTransformationRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'TransformationRule'! ! !RBTransformationRule class methodsFor: 'cleanup' stamp: 'MarcusDenker 10/11/2013 11:21'! cleanUp RecursiveSelfRule := nil.! ! !RBTransformationRuleTest methodsFor: 'rules' stamp: 'lr 11/2/2009 00:14'! superSends | rule | rule := RBParseTreeRewriter new. rule addSearch: 'super `@message: ``@args' -> ( [:aNode | (class withAllSubclasses detect: [:each | each includesSelector: aNode selector] ifNone: [nil]) isNil] -> 'self `@message: ``@args'). self rewriteUsing: rule! ! !RBTransformationRuleTest methodsFor: 'testing' stamp: ''! isEmpty ^builder changes isEmpty! ! !RBTransformationRuleTest methodsFor: 'accessing' stamp: ''! problemCount ^builder problemCount! ! !RBTransformationRuleTest methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:10'! resetResult builder := RBCompositeRefactoryChange new! ! !RBTransformationRuleTest methodsFor: 'testing' stamp: ''! hasConflicts ^true! ! !RBTransformationRuleTest methodsFor: 'private' stamp: ''! viewResults "I reset the result so that we don't fill up memory with methods to compile in the builder." builder inspect. self resetResult! ! !RBTransformationRuleTest methodsFor: 'accessing' stamp: ''! checkMethod: aSmalllintContext class := aSmalllintContext selectedClass. (rewriteRule executeTree: aSmalllintContext parseTree) ifTrue: [(RecursiveSelfRule executeTree: rewriteRule tree initialAnswer: false) ifFalse: [builder compile: rewriteRule tree printString in: class classified: aSmalllintContext protocols]]! ! !RBTransformationRuleTest methodsFor: 'initialize-release' stamp: ''! rewriteUsing: searchReplacer rewriteRule := searchReplacer. self resetResult! ! !RBTransformationRuleTest class methodsFor: 'transformations' stamp: ''! assignmentInIfTrue ^self rewrite: #( #('``@Boolean ifTrue: [`variable := ``@true] ifFalse: [`variable := ``@false]' "->" '`variable := ``@Boolean ifTrue: [``@true] ifFalse: [``@false]') #('``@Boolean ifFalse: [`variable := ``@true] ifTrue: [`variable := ``@false]' "->" '`variable := ``@Boolean ifFalse: [``@true] ifTrue: [``@false]')) methods: false name: 'Move variable assignment outside of single statement ifTrue:ifFalse: blocks'! ! !RBTransformationRuleTest class methodsFor: 'transformations' stamp: ''! betweenAnd ^self rewrite: #( #('``@a >= ``@b and: [``@a <= ``@c]' "->" '``@a between: ``@b and: ``@c') #('``@a >= ``@b & (``@a <= ``@c)' "->" '``@a between: ``@b and: ``@c') #('``@b <= ``@a and: [``@a <= ``@c]' "->" '``@a between: ``@b and: ``@c') #('``@b <= ``@a & (``@a <= ``@c)' "->" '``@a between: ``@b and: ``@c') #('``@a <= ``@c and: [``@a >= ``@b]' "->" '``@a between: ``@b and: ``@c') #('``@a <= ``@c & (``@a >= ``@b)' "->" '``@a between: ``@b and: ``@c') #('``@c >= ``@a and: [``@a >= ``@b]' "->" '``@a between: ``@b and: ``@c') #('``@c >= ``@a & (``@a >= ``@b)' "->" '``@a between: ``@b and: ``@c') #('``@a >= ``@b and: [``@c >= ``@a]' "->" '``@a between: ``@b and: ``@c') #('``@a >= ``@b & (``@c >= ``@a)' "->" '``@a between: ``@b and: ``@c') #('``@b <= ``@a and: [``@c >= ``@a]' "->" '``@a between: ``@b and: ``@c') #('``@b <= ``@a & (``@c >= ``@a)' "->" '``@a between: ``@b and: ``@c') #('``@a <= ``@c and: [``@b <= ``@a]' "->" '``@a between: ``@b and: ``@c') #('``@a <= ``@c & (``@b <= ``@a)' "->" '``@a between: ``@b and: ``@c') #('``@c >= ``@a and: [``@b <= ``@a]' "->" '``@a between: ``@b and: ``@c') #('``@c >= ``@a & (``@b <= ``@a)' "->" '``@a between: ``@b and: ``@c')) methods: false name: '"a >= b and: [a <= c]" -> "a between: b and: c"'! ! !RBTransformationRuleTest class methodsFor: 'transformations' stamp: ''! superSends ^(self new) name: 'Rewrite super messages to self messages when both refer to same method'; superSends; yourself! ! !RBTransformationRuleTest class methodsFor: 'transformations' stamp: ''! atIfAbsent ^self rewrite: #( #('``@dictionary at: ``@key ifAbsent: [| `@temps | ``@.Statements1. ``@dictionary at: ``@key put: ``@object. ``@.Statements2. ``@object]' "->" '``@dictionary at: ``@key ifAbsentPut: [| `@temps | ``@.Statements1. ``@.Statements2. ``@object]') #('``@dictionary at: ``@key ifAbsent: [| `@temps | ``@.Statements. ``@dictionary at: ``@key put: ``@object]' "->" '``@dictionary at: ``@key ifAbsentPut: [| `@temps | ``@.Statements. ``@object]')) methods: false name: 'at:ifAbsent: -> at:ifAbsentPut:'! ! !RBTransformationRuleTest class methodsFor: 'transformations' stamp: ''! guardClause ^self rewrite: #( #('`@methodName: `@args | `@temps | `@.Statements. `@condition ifTrue: [| `@trueTemps | `.Statement1. `.Statement2. `@.Statements1]' "->" '`@methodName: `@args | `@temps `@trueTemps | `@.Statements. `@condition ifFalse: [^self]. `.Statement1. `.Statement2. `@.Statements1') #('`@methodName: `@args | `@temps | `@.Statements. `@condition ifFalse: [| `@falseTemps | `.Statement1. `.Statement2. `@.Statements1]' "->" '`@methodName: `@args | `@temps `@falseTemps | `@.Statements. `@condition ifTrue: [^self]. `.Statement1. `.Statement2. `@.Statements1')) methods: true name: 'Eliminate guarding clauses'! ! !RBTransformationRuleTest class methodsFor: 'transformations' stamp: ''! showWhileBlocks ^self rewrite: #( #('``@cursor showWhile: [| `@temps | ``@.Statements. `var := ``@object]' "->" '`var := ``@cursor showWhile: [| `@temps | ``@.Statements. ``@object]') #('``@cursor showWhile: [| `@temps | ``@.Statements. ^``@object]' "->" '^``@cursor showWhile: [| `@temps | ``@.Statements. ``@object]')) methods: false name: 'Move assignment out of showWhile: blocks'! ! !RBTransformationRuleTest class methodsFor: 'transformations' stamp: ''! minMax ^self rewrite: #( #('``@a < ``@b ifTrue: [``@a] ifFalse: [``@b]' "->" '``@a min: ``@b') #('``@a <= ``@b ifTrue: [``@a] ifFalse: [``@b]' "->" '``@a min: ``@b') #('``@a > ``@b ifTrue: [``@a] ifFalse: [``@b]' "->" '``@a max: ``@b') #('``@a >= ``@b ifTrue: [``@a] ifFalse: [``@b]' "->" '``@a max: ``@b') #('``@a < ``@b ifTrue: [``@b] ifFalse: [``@a]' "->" '``@a max: ``@b') #('``@a <= ``@b ifTrue: [``@b] ifFalse: [``@a]' "->" '``@a max: ``@b') #('``@a > ``@b ifTrue: [``@b] ifFalse: [``@a]' "->" '``@a min: ``@b') #('``@a >= ``@b ifTrue: [``@b] ifFalse: [``@a]' "->" '``@a min: ``@b') #('`a < ``@b ifTrue: [`a := ``@b]' "->" '`a := `a max: ``@b') #('`a <= ``@b ifTrue: [`a := ``@b]' "->" '`a := `a max: ``@b') #('`a < ``@b ifFalse: [`a := ``@b]' "->" '`a := `a min: ``@b') #('`a <= ``@b ifFalse: [`a := ``@b]' "->" '`a := `a min: ``@b') #('`a > ``@b ifTrue: [`a := ``@b]' "->" '`a := `a min: ``@b') #('`a >= ``@b ifTrue: [`a := ``@b]' "->" '`a := `a min: ``@b') #('`a > ``@b ifFalse: [`a := ``@b]' "->" '`a := `a max: ``@b') #('`a >= ``@b ifFalse: [`a := ``@b]' "->" '`a := `a max: ``@b') #('``@b < `a ifTrue: [`a := ``@b]' "->" '`a := `a min: ``@b') #('``@b <= `a ifTrue: [`a := ``@b]' "->" '`a := `a min: ``@b') #('``@b < `a ifFalse: [`a := ``@b]' "->" '`a := `a max: ``@b') #('``@b <= `a ifFalse: [`a := ``@b]' "->" '`a := `a max: ``@b') #('``@b > `a ifTrue: [`a := ``@b]' "->" '`a := `a max: ``@b') #('``@b >= `a ifTrue: [`a := ``@b]' "->" '`a := `a max: ``@b') #('``@b > `a ifFalse: [`a := ``@b]' "->" '`a := `a min: ``@b') #('``@b >= `a ifFalse: [`a := ``@b]' "->" '`a := `a min: ``@b')) methods: false name: 'Rewrite ifTrue:ifFalse: using min:/max:'! ! !RBTransformationRuleTest class methodsFor: 'transformations' stamp: ''! detectIfNone ^self rewrite: #( #('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) isNil' "->" '(``@collection contains: [:`each | | `@temps | ``@.Statements]) not') #('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) = nil' "->" '(``@collection contains: [:`each | | `@temps | ``@.Statements]) not') #('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) == nil' "->" '(``@collection contains: [:`each | | `@temps | ``@.Statements]) not') #('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) notNil' "->" '``@collection contains: [:`each | | `@temps | ``@.Statements]') #('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) ~= nil' "->" '``@collection contains: [:`each | | `@temps | ``@.Statements]') #('(``@collection detect: [:`each | | `@temps | ``@.Statements] ifNone: [nil]) ~~ nil' "->" '``@collection contains: [:`each | | `@temps | ``@.Statements]')) methods: false name: 'detect:ifNone: -> contains:'! ! !RBTransformationRuleTest class methodsFor: 'class initialization' stamp: 'lr 11/2/2009 00:14'! initializeAfterLoad1 RecursiveSelfRule := RBParseTreeSearcher new. RecursiveSelfRule addMethodSearches: #('`@methodName: `@args | `@temps | self `@methodName: `@args' '`@methodName: `@args | `@temps | ^self `@methodName: `@args') -> [:aNode :answer | true]! ! !RBTransformationRuleTest class methodsFor: 'instance creation' stamp: 'lr 11/2/2009 00:14'! rewrite: stringArrays methods: aBoolean name: aName | rewriteRule | rewriteRule := RBParseTreeRewriter new. stringArrays do: [:each | aBoolean ifTrue: [rewriteRule addMethodSearch: each first -> each last] ifFalse: [rewriteRule addSearch: each first -> each last]]. ^(self new) name: aName; rewriteUsing: rewriteRule; yourself! ! !RBTransformationRuleTest class methodsFor: 'cleanup' stamp: 'MarcusDenker 10/11/2013 11:19'! cleanUp self nuke! ! !RBTransformationRuleTest class methodsFor: 'class initialization' stamp: ''! nuke RecursiveSelfRule := nil! ! !RBTransformationRuleTest class methodsFor: 'transformations' stamp: ''! equalNil ^self rewrite: #( #('``@object = nil' "->" '``@object isNil') #('``@object == nil' "->" '``@object isNil') #('``@object ~= nil' "->" '``@object notNil') #('``@object ~~ nil' "->" '``@object notNil')) methods: false name: '= nil -> isNil AND ~= nil -> notNil'! ! !RBTransformationRuleTest class methodsFor: 'transformations' stamp: ''! notElimination ^self rewrite: #( #('``@object not not' "->" '``@object') #('``@object not ifTrue: ``@block' "->" '``@object ifFalse: ``@block') #('``@object not ifFalse: ``@block' "->" '``@object ifTrue: ``@block') #('``@collection select: [:`each | | `@temps | ``@.Statements. ``@object not]' "->" '``@collection reject: [:`each | | `@temps | ``@.Statements. ``@object]') #('``@collection reject: [:`each | | `@temps | ``@.Statements. ``@object not]' "->" '``@collection select: [:`each | | `@temps | ``@.Statements. ``@object]') #('[| `@temps | ``@.Statements. ``@object not] whileTrue: ``@block' "->" '[| `@temps | ``@.Statements. ``@object] whileFalse: ``@block') #('[| `@temps | ``@.Statements. ``@object not] whileFalse: ``@block' "->" '[| `@temps | ``@.Statements. ``@object] whileTrue: ``@block') #('[| `@temps | ``@.Statements. ``@object not] whileTrue' "->" '[| `@temps | ``@.Statements. ``@object] whileFalse') #('[| `@temps | ``@.Statements. ``@object not] whileFalse' "->" '[| `@temps | ``@.Statements. ``@object] whileTrue') #('(``@a <= ``@b) not' "->" '``@a > ``@b') #('(``@a < ``@b) not' "->" '``@a >= ``@b') #('(``@a = ``@b) not' "->" '``@a ~= ``@b') #('(``@a == ``@b) not' "->" '``@a ~~ ``@b') #('(``@a ~= ``@b) not' "->" '``@a = ``@b') #('(``@a ~~ ``@b) not' "->" '``@a == ``@b') #('(``@a >= ``@b) not' "->" '``@a < ``@b') #('(``@a > ``@b) not' "->" '``@a <= ``@b')) methods: false name: 'Eliminate unnecessary not''s'! ! !RBTransformationRuleTest class methodsFor: 'transformations' stamp: 'lr 11/19/2009 14:49'! unwindBlocks ^self rewrite: #( #('[| `@temps | ``@.Statements. `var := ``@object] ensure: ``@block' "->" '`var := [| `@temps | ``@.Statements. ``@object] ensure: ``@block') #('[| `@temps | ``@.Statements. ^``@object] ensure: ``@block' "->" '^[| `@temps | ``@.Statements. ``@object] ensure: ``@block') #('[| `@temps | ``@.Statements. `var := ``@object] ifCurtailed: ``@block' "->" '`var := [| `@temps | ``@.Statements. ``@object] ifCurtailed: ``@block') #('[| `@temps | ``@.Statements. ^``@object] ifCurtailed: ``@block' "->" '^[| `@temps | ``@.Statements. ``@object] ifCurtailed: ``@block')) methods: false name: 'Move assignment out of unwind blocks'! ! !RBTranslateLiteralsInMenusRule commentStamp: ''! See rationale! !RBTranslateLiteralsInMenusRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:41'! initialize super initialize. self rewriteRule replace: '`@menu add: `#label action: `#sym' with: '`@menu add: `#label translated action: `#sym'; replace: '`@menu add: `#label selector: `#sym arguments: `@stuff' with: '`@menu add: `#label translated selector: `#sym arguments: `@stuff'; replace: '`@menu add: `#label subMenu: `@stuff' with: '`@menu add: `#label translated subMenu: `@stuff'; replace: '`@menu add: `#label subMenu: `@stuff target: `@targ selector: `#sel argumentList: `@args' with: '`@menu add: `#label translated subMenu: `@stuff target: `@targ selector: `#sel argumentList: `@args'; replace: '`@menu add: `#label target: `@targ action: `#sel' with: '`@menu add: `#label translated target: `@targ action: `#sel'; replace: '`@menu add: `#label target: `@targ selector `#sel' with: '`@menu add: `#label translated target: `@targ selector `#sel'; replace: '`@menu add: `#label target: `@targ selector `#sel argument: `@arg' with: '`@menu add: `#label translated target: `@targ selector `#sel argument: `@arg'; replace: '`@menu add: `#label target: `@targ selector `#sel arguments: `@arg' with: '`@menu add: `#label translated target: `@targ selector `#sel arguments: `@arg'; replace: '`@menu addTitle: `#label' with: '`@menu addTitle: `#label translated'; replace: '`@menu addTitle: `#label updatingSelector: `#sel updateTarget: `@targ' with: '`@menu addTitle: `#label translated updatingSelector: `#sel updateTarget: `@targ'; replace: '`@menu addWithLabel: `#label enablement: `#esel action: `#sel' with: '`@menu addWithLabel: `#label translated enablement: `#esel action: `#sel'; replace: '`@menu addWithLabel: `#label enablementSelector: `#esel target: `@targ selector: `#sel argumentList: `@args' with: '`@menu addWithLabel: `#label translated enablementSelector: `#esel target: `@targ selector: `#sel argumentList: `@args'; replace: '`@menu balloonTextForLastItem: `#label' with: '`@menu balloonTextForLastItem: `#label translated'; replace: '`@menu labels: `#lit lines: `@lines selections: `@sels' with: '`@menu labels: (`#lit collect: [ :l | l translated ]) lines: `@lines selections: `@sels'; replace: '`@menu title: `#title' with: '`@menu title: `#title translated'! ! !RBTranslateLiteralsInMenusRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBTranslateLiteralsInMenusRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'add translations to strings in menus'! ! !RBTranslateLiteralsInMenusRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 11:22'! category ^ 'Potential Bugs'! ! !RBTranslateLiteralsInMenusRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'TranslateLiteralsInMenusRule'! ! !RBTrueFalseDuplicationRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:27'! initialize super initialize. self matcher matchesAnyOf: #( '`@object ifTrue: [| `@temps1 | `@.Statements1. `.Statement] ifFalse: [| `@temps2 | `@.Statements2. `.Statement]' '`@object ifTrue: [| `@temps1 | `.Statement. `@.Statements1] ifFalse: [| `@temps2 | `.Statement. `@.Statements2]' '`@object ifFalse: [| `@temps1 | `@.Statements1. `.Statement] ifTrue: [| `@temps2 | `@.Statements2. `.Statement]' '`@object ifFalse: [| `@temps1 | `.Statement. `@.Statements1] ifTrue: [| `@temps2 | `.Statement. `@.Statement2]') do: [ :node :answer | answer isNil ifTrue: [ | statement | statement := node arguments first body statements last. (statement isVariable and: [ statement = node arguments last body statements last ]) ifFalse: [ node ] ifTrue: [ nil ] ] ifFalse: [ answer ] ]! ! !RBTrueFalseDuplicationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for ifTrue:ifFalse: blocks that have the same code at the beginning or end. While you might not originally write such code, as it is modified, it is easier to create such code. Instead of having the same code in two places, you should move it outside the blocks.'! ! !RBTrueFalseDuplicationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBTrueFalseDuplicationRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:09'! severity ^ #information! ! !RBTrueFalseDuplicationRule methodsFor: 'accessing' stamp: 'CAMILLETERUEL 3/29/2013 13:09'! name ^ 'Check for same statements in ifTrue:ifFalse: blocks'! ! !RBUnclassifiedMethodsRule commentStamp: ''! See my #rationale.! !RBUnclassifiedMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'All methods should be put into a protocol (method category) for better readability.'! ! !RBUnclassifiedMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBUnclassifiedMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Unclassified methods'! ! !RBUnclassifiedMethodsRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:57'! category ^ 'Style'! ! !RBUnclassifiedMethodsRule methodsFor: 'running' stamp: 'EstebanLorenzano 6/26/2013 18:09'! checkMethod: aContext (aContext selectedClass organization categoryOfElement: aContext selector) = Protocol unclassified ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBUnclassifiedMethodsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UnclassifiedMethodsRule'! ! !RBUncommonMessageSendRule commentStamp: ''! See my #rationale.! !RBUncommonMessageSendRule methodsFor: 'initialization' stamp: 'SeanDeNigris 1/31/2013 09:45'! initialize super initialize. literalNames := self commonLiterals.! ! !RBUncommonMessageSendRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:41'! category ^ 'Potential Bugs'! ! !RBUncommonMessageSendRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:45'! commonLiterals ^ #(#self #super #thisContext #true #false #nil) asIdentitySet! ! !RBUncommonMessageSendRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 10:01'! rationale ^ 'Sending messages with a common literal (e.g. "Object self") or an uppercase selector name are usually bugs, introduced through missing statement separators.'! ! !RBUncommonMessageSendRule methodsFor: 'accessing' stamp: 'lr 3/28/2009 14:21'! group ^ 'Possible bugs'! ! !RBUncommonMessageSendRule methodsFor: 'accessing' stamp: 'lr 3/28/2009 14:22'! name ^ 'Uncommon message send'! ! !RBUncommonMessageSendRule methodsFor: 'running' stamp: 'lr 3/28/2009 14:26'! checkMethod: aContext aContext messages do: [ :each | (each isEmpty or: [ each first isUppercase or: [ literalNames includes: each ] ]) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector. result addSearchString: each ] ]! ! !RBUncommonMessageSendRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UncommonMessageSendRule'! ! !RBUnconditionalRecursionRule methodsFor: 'initialization' stamp: 'lr 5/15/2010 18:09'! initialize super initialize. self matcher matchesMethod: '`@message: `@args | `@temps | `@.before. self `@message: `@args. `@.after' do: [ :node :answer | | index | index := node body statements findFirst: [ :each | each isMessage and: [ each selector = node selector ] ]. ((node body statements copyFrom: 1 to: index) anySatisfy: [ :each | each containsReturn ]) ifTrue: [ answer ] ifFalse: [ node ] ]! ! !RBUnconditionalRecursionRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:55'! rationale ^ 'Checks for unconditional recursion that might cause the image to hang when executed.'! ! !RBUnconditionalRecursionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBUnconditionalRecursionRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:55'! severity ^ #error! ! !RBUnconditionalRecursionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Unconditional recursion'! ! !RBUnconditionalRecursionRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:34'! category ^ 'Potential Bugs'! ! !RBUnconditionalRecursionRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UnconditionalRecursionRule'! ! !RBUndeclaredReferenceRule commentStamp: ''! See my #rationale.! !RBUndeclaredReferenceRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 10:02'! rationale ^ 'Checks for references to a variable in the Undeclared dictionary. If you remove a referenced variable from a class, you will create an undeclared variable reference for those methods that accessed the variable.'! ! !RBUndeclaredReferenceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBUndeclaredReferenceRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:04'! severity ^ #error! ! !RBUndeclaredReferenceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'References an undeclared variable'! ! !RBUndeclaredReferenceRule methodsFor: 'running' stamp: 'lr 6/4/2010 12:05'! checkMethod: aContext | undeclared | undeclared := Undeclared associations detect: [ :each | (aContext uses: each) and: [ aContext compiledMethod refersToLiteral: each ] ] ifNone: [ nil ]. undeclared notNil ifTrue: [ result addSearchString: undeclared key. result addClass: aContext selectedClass selector: aContext selector ]! ! !RBUndeclaredReferenceRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:42'! category ^ 'Bugs'! ! !RBUndeclaredReferenceRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UndeclaredReferenceRule'! ! !RBUnderscoreAssignmentRule commentStamp: ''! See rationale! !RBUnderscoreAssignmentRule methodsFor: 'initialization' stamp: 'lr 11/7/2009 18:31'! initialize super initialize. self rewriteRule replace: '`var := ``@object' with: '`var := ``@object' when: [ :node | node assignmentOperator = '_' ]! ! !RBUnderscoreAssignmentRule methodsFor: 'accessing' stamp: 'lr 7/3/2009 22:02'! group ^ 'Transformations'! ! !RBUnderscoreAssignmentRule methodsFor: 'accessing' stamp: 'lr 7/3/2009 22:05'! name ^ 'Underscore assignements should be avoided'! ! !RBUnderscoreAssignmentRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:52'! category ^ 'Style'! ! !RBUnderscoreAssignmentRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UnderscoreAssignmentRule'! ! !RBUnnecessaryAssignmentRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:53'! initialize super initialize. self matcher matches: '^`{:aNode | aNode isAssignment and: [(aNode whoDefines: aNode variable name) notNil]}' do: [ :node :answer | node ]! ! !RBUnnecessaryAssignmentRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 18:04'! rationale ^ 'Checks for assignements to temporaries that are not used afterwards.'! ! !RBUnnecessaryAssignmentRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 13:55'! group ^ 'Unnecessary code'! ! !RBUnnecessaryAssignmentRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:10'! severity ^ #information! ! !RBUnnecessaryAssignmentRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 13:55'! name ^ 'Unnecessary assignment to a temporary variable'! ! !RBUnnecessaryAssignmentRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:34'! category ^ 'Optimization'! ! !RBUnnecessaryAssignmentRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UnnecessaryAssignmentRule'! ! !RBUnoptimizedAndOrRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:53'! initialize super initialize. self matcher matchesAnyOf: #( '(`@a and: `@b) and: `@c' '(`@a or: `@b) or: `@c' ) do: [ :node :answer | node ]! ! !RBUnoptimizedAndOrRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:46'! rationale ^ 'Checks for inefficient nesting of logical conditions.'! ! !RBUnoptimizedAndOrRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBUnoptimizedAndOrRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses "(a and: [b]) and: [c]" instead of "a and: [b and: [c]]"'! ! !RBUnoptimizedAndOrRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:34'! category ^ 'Optimization'! ! !RBUnoptimizedAndOrRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UnoptimizedAndOrRule'! ! !RBUnoptimizedToDoRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:53'! initialize super initialize. self matcher matches: '(`@a to: `@b) do: `@c' do: [ :node :answer | node ]! ! !RBUnoptimizedToDoRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:48'! rationale ^ 'Checks for inefficient uses of to:do: that create an unnecessary Interval instance.'! ! !RBUnoptimizedToDoRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBUnoptimizedToDoRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses (to:)do: instead of to:do:'! ! !RBUnoptimizedToDoRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:35'! category ^ 'Optimization'! ! !RBUnoptimizedToDoRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UnoptimizedToDoRule'! ! !RBUnpackagedCodeRule commentStamp: ''! See my #rationale.! !RBUnpackagedCodeRule methodsFor: 'initialization' stamp: 'EstebanLorenzano 9/12/2012 13:37'! initialize super initialize. packages := MCWorkingCopy allManagers inject: #() into: [ :all :each | all, (each packageSet packages) ]! ! !RBUnpackagedCodeRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:43'! category ^'Potential Bugs'! ! !RBUnpackagedCodeRule methodsFor: 'accessing' stamp: 'lr 3/9/2010 16:08'! rationale ^ 'Code that is not contained in a Monticello package is not versioned and cannot be brought into a different image.'! ! !RBUnpackagedCodeRule methodsFor: 'accessing' stamp: 'lr 3/20/2009 17:21'! group ^ 'Possible bugs'! ! !RBUnpackagedCodeRule methodsFor: 'accessing' stamp: 'lr 3/20/2009 08:20'! name ^ 'Unpackaged code'! ! !RBUnpackagedCodeRule methodsFor: 'private' stamp: 'lr 3/20/2009 09:17'! packageSatisfying: aBlock "Answer the first package satisfying aBlock or nil. This method assumes that it is likely that the last matching package matches the given condition again and thus it tries that one first." (package notNil and: [ aBlock value: package ]) ifTrue: [ ^ package ]. packages do: [ :info | (aBlock value: info) ifTrue: [ ^ package := info ] ]. ^ nil! ! !RBUnpackagedCodeRule methodsFor: 'running' stamp: 'lr 3/20/2009 09:14'! checkMethod: aContext (self packageSatisfying: [ :info | info includesMethod: aContext selector ofClass: aContext selectedClass ]) isNil ifTrue: [ self result addClass: aContext selectedClass selector: aContext selector ]! ! !RBUnpackagedCodeRule methodsFor: 'running' stamp: 'lr 3/20/2009 09:14'! checkClass: aContext (aContext selectedClass isMeta not and: [ (self packageSatisfying: [ :info | info includesSystemCategory: aContext selectedClass category ]) isNil ]) ifTrue: [ self result addClass: aContext selectedClass ]! ! !RBUnpackagedCodeRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UnpackagedCodeRule'! ! !RBUnreferencedVariablesRule commentStamp: ''! See my #rationale.! !RBUnreferencedVariablesRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !RBUnreferencedVariablesRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:44'! category ^ 'Design Flaws'! ! !RBUnreferencedVariablesRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for variables not referenced. If a variable is not used in a class, it should be deleted.'! ! !RBUnreferencedVariablesRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBUnreferencedVariablesRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:10'! severity ^ #information! ! !RBUnreferencedVariablesRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Variables not referenced'! ! !RBUnreferencedVariablesRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkClass: aContext | allSubclasses | allSubclasses := aContext selectedClass withAllSubclasses. aContext selectedClass instVarNames do: [ :each | allSubclasses detect: [ :class | (class whichSelectorsAccess: each) isEmpty not ] ifNone: [ result addClass: aContext selectedClass instanceVariable: each ] ]. aContext selectedClass isMeta ifFalse: [ aContext selectedClass classPool associationsDo: [ :each | (aContext uses: each) ifFalse: [ result addClass: aContext selectedClass classVariable: each key ] ] ]! ! !RBUnreferencedVariablesRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UnreferencedVariablesRule'! ! !RBUnwindBlocksRule commentStamp: ''! See rationale! !RBUnwindBlocksRule methodsFor: 'initialization' stamp: 'lr 11/4/2009 09:26'! initialize super initialize. self rewriteRule replace: '[| `@temps | ``@.Statements. `var := ``@object] ensure: ``@block' with: '`var := [| `@temps | ``@.Statements. ``@object] ensure: ``@block'; replace: '[| `@temps | ``@.Statements. ^``@object] ensure: ``@block' with: '^[| `@temps | ``@.Statements. ``@object] ensure: ``@block'; replace:'[| `@temps | ``@.Statements. `var := ``@object] ifCurtailed: ``@block' with: '`var := [| `@temps | ``@.Statements. ``@object] ifCurtailed: ``@block'; replace:'[| `@temps | ``@.Statements. ^``@object] ifCurtailed: ``@block' with: '^[| `@temps | ``@.Statements. ``@object] ifCurtailed: ``@block'! ! !RBUnwindBlocksRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Transformations'! ! !RBUnwindBlocksRule methodsFor: 'accessing' stamp: 'lr 11/19/2009 14:41'! name ^ 'Move assignment out of unwind blocks'! ! !RBUnwindBlocksRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:54'! category ^ 'Optimization'! ! !RBUnwindBlocksRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UnwindBlocksRule'! ! !RBUsesAddRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:53'! initialize super initialize. self matcher matches: '`{:node | node isMessage and: [(node selector == #add: or: [node selector == #addAll:]) and: [node isDirectlyUsed]]}' do: [ :node :answer | node ]! ! !RBUsesAddRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for possible uses of the result returned by an add: or addAll: messages. These messages return their arguments not the receiver. As a result, may uses of the results are wrong.'! ! !RBUsesAddRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBUsesAddRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses the result of an add: message'! ! !RBUsesAddRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:35'! category ^ 'Potential Bugs'! ! !RBUsesAddRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UsesAddRule'! ! !RBUsesTrueRule commentStamp: ''! See my #rationale.! !RBUsesTrueRule methodsFor: 'initialization' stamp: 'lr 7/23/2010 08:04'! initialize super initialize. trueBinding := Smalltalk globals associationAt: #True. falseBinding := Smalltalk globals associationAt: #False! ! !RBUsesTrueRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:46'! category ^ 'Bugs'! ! !RBUsesTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for uses of the classes True and False instead of the objects true and false.'! ! !RBUsesTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBUsesTrueRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:04'! severity ^ #error! ! !RBUsesTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses True/False instead of true/false'! ! !RBUsesTrueRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkMethod: aContext | method | method := aContext compiledMethod. ((method refersToLiteral: trueBinding) or: [ method refersToLiteral: falseBinding ]) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector. result searchStrings: #('True' 'False' ) ]! ! !RBUsesTrueRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UsesTrueRule'! ! !RBUtilityMethodsRule commentStamp: ''! See my #rationale.! !RBUtilityMethodsRule methodsFor: 'private' stamp: 'lr 2/24/2009 00:18'! utilityProtocols ^ #('*utilit*')! ! !RBUtilityMethodsRule methodsFor: 'private' stamp: 'lr 2/24/2009 00:18'! subclassOf: aClass overrides: aSelector ^(aClass subclasses detect: [:each | (each includesSelector: aSelector) or: [self subclassOf: each overrides: aSelector]] ifNone: [nil]) notNil! ! !RBUtilityMethodsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:46'! category ^ 'Design Flaws'! ! !RBUtilityMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'List methods that have one or more arguments and do no refer to self or an instance variable. These methods might be better defined in some other class or as class methods.'! ! !RBUtilityMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBUtilityMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Utility methods'! ! !RBUtilityMethodsRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkMethod: aContext (aContext selectedClass isMeta or: [ aContext selector numArgs == 0 or: [ (aContext protocols detect: [ :each | (self utilityProtocols detect: [ :protocol | protocol match: each ] ifNone: [ ]) notNil ] ifNone: [ ]) notNil ] ]) ifFalse: [ (self subclassOf: aContext selectedClass overrides: aContext selector) ifFalse: [ (aContext superMessages isEmpty and: [ aContext selfMessages isEmpty ]) ifTrue: [ (aContext selectedClass allInstVarNames , aContext selectedClass allClassVarNames asArray , #('self' ) detect: [ :each | aContext parseTree references: each ] ifNone: [ ]) isNil ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ] ] ] ]! ! !RBUtilityMethodsRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'UtilityMethodsRule'! ! !RBValueNode commentStamp: ''! RBValueNode is an abstract class that represents a node that returns some value. Subclasses must implement the following messages: accessing startWithoutParentheses stopWithoutParentheses testing needsParenthesis Instance Variables: parentheses the positions of the parethesis around this node. We need a collection of intervals for stupid code such as "((3 + 4))" that has multiple parethesis around the same expression. ! !RBValueNode methodsFor: 'testing' stamp: ''! hasParentheses ^self parentheses notEmpty! ! !RBValueNode methodsFor: 'testing' stamp: ''! isValue ^true! ! !RBValueNode methodsFor: 'accessing' stamp: ''! stopWithoutParentheses ^self subclassResponsibility! ! !RBValueNode methodsFor: 'testing' stamp: ''! containedBy: anInterval ^anInterval first <= self startWithoutParentheses and: [anInterval last >= self stopWithoutParentheses]! ! !RBValueNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:14'! start ^parentheses ifNil: [self startWithoutParentheses] ifNotNil: [parentheses last first]! ! !RBValueNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:14'! addParenthesis: anInterval parentheses ifNil: [parentheses := OrderedCollection new: 1]. parentheses add: anInterval! ! !RBValueNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:14'! parentheses ^parentheses ifNil: [#()] ifNotNil: [parentheses]! ! !RBValueNode methodsFor: 'testing' stamp: ''! needsParenthesis ^self subclassResponsibility! ! !RBValueNode methodsFor: 'converting' stamp: 'MarcusDenker 1/29/2013 14:25'! asSequenceNode ^RBSequenceNode statements: {self} ! ! !RBValueNode methodsFor: 'accessing' stamp: 'ClementBera 7/26/2013 17:15'! stop ^parentheses ifNil: [self stopWithoutParentheses] ifNotNil: [parentheses last last]! ! !RBValueNode methodsFor: 'accessing' stamp: ''! startWithoutParentheses ^self subclassResponsibility! ! !RBValueToken commentStamp: ''! RBValueToken is the abstract superclass of all tokens that have additional information attached. For example, the BinarySelector token holds onto the actual character (e.g. $+). Instance Variables: value The value of this token ! !RBValueToken methodsFor: 'private' stamp: ''! length ^value size! ! !RBValueToken methodsFor: 'accessing' stamp: ''! value ^value! ! !RBValueToken methodsFor: 'accessing' stamp: ''! value: anObject value := anObject! ! !RBValueToken methodsFor: 'printing' stamp: 'CamilloBruni 2/20/2012 23:11'! printOn: aStream super printOn: aStream. aStream nextPut: $(. value printOn: aStream. aStream nextPutAll: ')'! ! !RBValueToken methodsFor: 'initialize-release' stamp: ''! value: aString start: anInteger value := aString. sourcePointer := anInteger! ! !RBValueToken class methodsFor: 'instance creation' stamp: ''! value: aString start: anInteger ^self new value: aString start: anInteger! ! !RBVariableAssignedLiteralRule commentStamp: ''! See my #rationale.! !RBVariableAssignedLiteralRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !RBVariableAssignedLiteralRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'If a variable is only assigned a single literal value then that variable is either nil or that literal value. If the variable is always initialized with that literal value, then you could replace each variable reference with a message send to get the value. If the variable can also be nil, then you might want to replace that variable with another that stores true or false depending on whether the old variable had been assigned.'! ! !RBVariableAssignedLiteralRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBVariableAssignedLiteralRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Variable is only assigned a single literal value'! ! !RBVariableAssignedLiteralRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:48'! category ^ 'Design Flaws'! ! !RBVariableAssignedLiteralRule methodsFor: 'running' stamp: 'MarcusDenker 9/20/2013 15:27'! checkClass: aContext | allSubclasses | allSubclasses := aContext selectedClass withAllSubclasses. aContext selectedClass instVarNames do: [ :each | | defClass selector | (allSubclasses inject: 0 into: [ :sum :class | | sels | sels := class whichSelectorsAssign: each. sels size == 1 ifTrue: [ selector := sels asArray first. defClass := class ]. sum + sels size ]) == 1 ifTrue: [ | tree searcher | searcher := RBParseTreeSearcher new. searcher matches: each , ' := ``@object' do: [ :aNode :answer | answer isNil and: [ aNode value isLiteralNode ] ]. tree := defClass parseTreeFor: selector. tree notNil ifTrue: [ (searcher executeTree: tree initialAnswer: nil) == true ifTrue: [ result addClass: aContext selectedClass instanceVariable: each ] ] ] ]! ! !RBVariableAssignedLiteralRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'VariableAssignedLiteralRule'! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! classVariables ^classVariables! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! instanceVariablesFor: aClass | vars name | vars := Set new. name := aClass name. vars addAll: (instanceVariables at: name ifAbsent: [#()]); addAll: (instanceVariableReaders at: name ifAbsent: [#()]); addAll: (instanceVariableWriters at: name ifAbsent: [#()]). ^vars! ! !RBVariableEnvironment methodsFor: 'private' stamp: 'lr 3/20/2011 11:18'! classForName: aString | name isMeta class | isMeta := aString includes: $ . name := (isMeta ifTrue: [ aString copyFrom: 1 to: (aString size - 6 max: 1) ] ifFalse: [ aString ]) asSymbol. class := self systemDictionary at: name ifAbsent: [ nil ]. ^ (class notNil and: [ isMeta ]) ifTrue: [ class class ] ifFalse: [ class ]! ! !RBVariableEnvironment methodsFor: 'testing' stamp: ''! includesCategory: aCategory ^(self classNamesFor: aCategory) isEmpty not! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! instanceVariableWriters ^instanceVariableWriters! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! instanceVariables ^instanceVariables! ! !RBVariableEnvironment methodsFor: 'private' stamp: 'lr 11/25/2009 00:42'! selectorCacheFor: aClass ^self selectorCache at: aClass name ifAbsentPut: [ self computeSelectorCacheFor: aClass ]! ! !RBVariableEnvironment methodsFor: 'private' stamp: 'lr 11/25/2009 08:32'! classVariableSelectorsFor: aClass | selectors classVars | selectors := Set new. classVars := Set new. classVariables keysDo: [:each | | cls | cls := self classForName: each. (cls notNil and: [aClass theNonMetaClass includesBehavior: cls]) ifTrue: [classVars addAll: (classVariables at: each)]]. classVars do: [:each | | binding | binding := aClass bindingOf: each. binding notNil ifTrue: [selectors addAll: (aClass whichSelectorsReferTo: binding)]]. ^selectors! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! addClass: aClass instanceVariableWriter: aString (instanceVariableWriters at: aClass name ifAbsentPut: [Set new]) add: aString. self flushCachesFor: aClass. self addSearchString: aString! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! instanceVariableReaders: anObject instanceVariableReaders := anObject! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! instanceVariableWriters: anObject instanceVariableWriters := anObject! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! removeClass: aClass instanceVariableReader: aString | vars | vars := instanceVariableReaders at: aClass name ifAbsent: [Set new]. vars remove: aString ifAbsent: []. vars isEmpty ifTrue: [instanceVariableReaders removeKey: aClass name ifAbsent: []]. self flushCachesFor: aClass! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! addClass: aClass instanceVariable: aString (instanceVariables at: aClass name ifAbsentPut: [Set new]) add: aString. self flushCachesFor: aClass. self addSearchString: aString! ! !RBVariableEnvironment methodsFor: 'initialization' stamp: ''! initialize super initialize. instanceVariables := Dictionary new. classVariables := Dictionary new. instanceVariableReaders := Dictionary new. instanceVariableWriters := Dictionary new! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! allClassesDo: aBlock | classes instVarBlock | classes := Set new. instVarBlock := [:each | | class | class := self classForName: each. classes addAll: class withAllSubclasses]. instanceVariables keysDo: instVarBlock. instanceVariableReaders keysDo: instVarBlock. instanceVariableWriters keysDo: instVarBlock. classVariables keysDo: [:each | | class | class := self classForName: each. class notNil ifTrue: [classes addAll: class withAllSubclasses; addAll: class class withAllSubclasses]]. classes do: aBlock! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: 'TommasoDalSasso 10/6/2013 01:37'! environmentForInstanceVariable: aString in: aClass | selectorEnvironment isReader isWriter | selectorEnvironment := RBSelectorEnvironment onEnvironment: self. selectorEnvironment addSearchString: aString. isReader := isWriter := false. ((instanceVariables at: aClass name ifAbsent: [#()]) includes: aString) ifTrue: [isReader := true. isWriter := true]. ((instanceVariableWriters at: aClass name ifAbsent: [#()]) includes: aString) ifTrue: [isWriter := true]. ((instanceVariableReaders at: aClass name ifAbsent: [#()]) includes: aString) ifTrue: [isReader := true]. aClass withAllSubAndSuperclassesDo: [:each | isWriter ifTrue: [(each whichSelectorsAssign: aString) do: [:sel | selectorEnvironment addClass: each selector: sel]]. isReader ifTrue: [(each whichSelectorsRead: aString) do: [:sel | selectorEnvironment addClass: each selector: sel]]]. ^selectorEnvironment! ! !RBVariableEnvironment methodsFor: 'private' stamp: 'lr 11/25/2009 00:40'! flushCachesFor: aClass selectorCache isNil ifTrue: [ ^ self] . aClass theNonMetaClass withAllSubclasses do: [ :each | selectorCache removeKey: each ifAbsent: []; removeKey: each class ifAbsent: [] ]! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! numberVariables ^self accessorMethods inject: 0 into: [:sum :each | sum + ((self perform: each) inject: 0 into: [:s :e | s + e size])]! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! addClass: aClass classVariable: aSymbol (classVariables at: aClass name ifAbsentPut: [Set new]) add: aSymbol. self flushCachesFor: aClass. self addSearchString: aSymbol! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! removeClass: aClass instanceVariable: aString | vars | vars := instanceVariables at: aClass name ifAbsent: [Set new]. vars remove: aString ifAbsent: []. vars isEmpty ifTrue: [instanceVariables removeKey: aClass name ifAbsent: []]. self flushCachesFor: aClass! ! !RBVariableEnvironment methodsFor: 'testing' stamp: 'lr 2/9/2008 10:51'! includesClass: aClass (super includesClass: aClass) ifFalse: [^false]. (instanceVariables includesKey: aClass name) ifTrue: [^true]. (classVariables includesKey: aClass name) ifTrue: [^true]. ^((self selectorCacheFor: aClass) detect: [:each | self includesSelector: each in: aClass] ifNone: [nil]) notNil! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! instanceVariables: anObject instanceVariables := anObject! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! removeClass: aClass classVariable: aSymbol | vars | vars := classVariables at: aClass name ifAbsent: [Set new]. vars remove: aSymbol ifAbsent: []. vars isEmpty ifTrue: [classVariables removeKey: aClass name ifAbsent: []]. self flushCachesFor: aClass! ! !RBVariableEnvironment methodsFor: 'testing' stamp: 'TestRunner 1/3/2010 11:29'! isEmpty ^ self accessorMethods allSatisfy: [ :each | (self perform: each) isEmpty ]! ! !RBVariableEnvironment methodsFor: 'printing' stamp: 'lr 4/29/2010 19:06'! storeOn: aStream aStream nextPut: $(; nextPutAll: self class name; nextPutAll: ' new '. self accessorMethods do: [ :each | aStream nextPutAll: each; nextPutAll: ': '. (self perform: each) storeOn: aStream. aStream nextPutAll: '; ']. aStream nextPutAll: 'yourself)'! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! addClass: aClass instanceVariableReader: aString (instanceVariableReaders at: aClass name ifAbsentPut: [Set new]) add: aString. self flushCachesFor: aClass. self addSearchString: aString! ! !RBVariableEnvironment methodsFor: 'testing' stamp: ''! includesSelector: aSymbol in: aClass ^(environment includesSelector: aSymbol in: aClass) and: [(self selectorCacheFor: aClass) includes: aSymbol]! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! environmentForClassVariable: aSymbol in: aClass | selectorEnvironment assoc block | selectorEnvironment := RBSelectorEnvironment onEnvironment: self. selectorEnvironment addSearchString: aSymbol. ((classVariables at: aClass name ifAbsent: [#()]) includes: aSymbol) ifFalse: [^selectorEnvironment]. assoc := aClass bindingOf: aSymbol. block := [:each | (each whichSelectorsReferTo: assoc) do: [:sel | selectorEnvironment addClass: each selector: sel]]. aClass withAllSubAndSuperclassesDo: [:each | block value: each; value: each class]. ^selectorEnvironment! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! classNamesWithVariables | classNames | classNames := Set new. classNames addAll: instanceVariables keys; addAll: instanceVariableReaders keys; addAll: instanceVariableWriters keys; addAll: classVariables keys. ^classNames! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! selectorCache ^selectorCache isNil ifTrue: [selectorCache := Dictionary new] ifFalse: [selectorCache]! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! accessorMethods ^#(#instanceVariables #instanceVariableReaders #instanceVariableWriters #classVariables)! ! !RBVariableEnvironment methodsFor: 'testing' stamp: ''! includesProtocol: aProtocol in: aClass ^(self selectorsFor: aProtocol in: aClass) isEmpty not! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! instanceVariableReaders ^instanceVariableReaders! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! computeSelectorCacheFor: aClass ^(self instanceVariableSelectorsFor: aClass) addAll: (self classVariableSelectorsFor: aClass); yourself! ! !RBVariableEnvironment methodsFor: 'copying' stamp: ''! postCopy super postCopy. instanceVariables := self copyDictionary: instanceVariables. instanceVariableReaders := self copyDictionary: instanceVariableReaders. instanceVariableWriters := self copyDictionary: instanceVariableWriters. classVariables := self copyDictionary: classVariables. selectorCache := nil! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! problemCount ^self numberVariables! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! removeClass: aClass instanceVariableWriter: aString | vars | vars := instanceVariableWriters at: aClass name ifAbsent: [Set new]. vars remove: aString ifAbsent: []. vars isEmpty ifTrue: [instanceVariableWriters removeKey: aClass name ifAbsent: []]. self flushCachesFor: aClass! ! !RBVariableEnvironment methodsFor: 'private' stamp: 'TommasoDalSasso 10/6/2013 01:37'! instanceVariableSelectorsFor: aClass | selectors | selectors := Set new. #(#instanceVariables #instanceVariableReaders #instanceVariableWriters) with: #(#whichSelectorsAccess: #whichSelectorsRead: #whichSelectorsAssign:) do: [:var :sel | | instVars | instVars := Set new. (self perform: var) keysDo: [:each | | cls | cls := self classForName: each. (cls notNil and: [aClass includesBehavior: cls]) ifTrue: [instVars addAll: ((self perform: var) at: each)]]. instVars do: [:each | selectors addAll: (aClass perform: sel with: each)]]. ^selectors! ! !RBVariableEnvironment methodsFor: 'private' stamp: ''! classVariables: anObject classVariables := anObject! ! !RBVariableEnvironment methodsFor: '*manifest-core' stamp: 'SimonAllier 3/27/2013 10:12'! smallLintCritics ^ self allClasses! ! !RBVariableEnvironment methodsFor: 'accessing' stamp: ''! classVariablesFor: aClass ^classVariables at: aClass name ifAbsent: [#()]! ! !RBVariableEnvironment methodsFor: 'copying' stamp: ''! copyDictionary: aDictionary | copy | copy := Dictionary new: aDictionary size. aDictionary keysAndValuesDo: [:key :value | copy at: key put: value]. ^copy! ! !RBVariableEnvironment methodsFor: 'testing' stamp: 'lr 1/3/2010 11:11'! isVariableEnvironment ^ true! ! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:31'! referencesToClassVariable: aSymbol in: aClass ^ self on: self default referencesToClassVariable: aSymbol in: aClass ! ! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:32'! referencesToInstanceVariable: aString in: aClass ^ self on: self default referencesToInstanceVariable: aString in: aClass ! ! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'md 1/17/2006 14:17'! on: anEnvironment referencesToClassVariable: aSymbol in: aClass | newEnv definingClass assoc | newEnv := (self onEnvironment: anEnvironment) label: 'References to ''' , aSymbol , ''' in ' , aClass name; yourself. definingClass := aClass whichClassDefinesClassVar: aSymbol. assoc := definingClass bindingOf: aSymbol. definingClass withAllSubclassesDo: [:cls | (cls whichSelectorsReferTo: assoc) isEmpty ifFalse: [newEnv addClass: cls classVariable: aSymbol]]. ^newEnv! ! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'TommasoDalSasso 10/6/2013 01:37'! on: anEnvironment readersOfInstanceVariable: aString in: aClass | newEnv | newEnv := (self onEnvironment: anEnvironment) label: 'Readers of ''' , aString , ''' in ' , aClass name; yourself. (aClass whichClassDefinesInstVar: aString) withAllSubclassesDo: [:cls | (cls whichSelectorsRead: aString) isEmpty ifFalse: [newEnv addClass: cls instanceVariableReader: aString]]. ^newEnv! ! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'nk 3/4/2005 13:17'! on: anEnvironment writersOfInstanceVariable: aString in: aClass | newEnv | newEnv := (self onEnvironment: anEnvironment) label: 'Writers of ''' , aString , ''' in ' , aClass name; yourself. (aClass whichClassDefinesInstVar: aString) withAllSubclassesDo: [:cls | (cls whichSelectorsAssign: aString) isEmpty ifFalse: [newEnv addClass: cls instanceVariableWriter: aString]]. ^newEnv! ! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'TommasoDalSasso 10/6/2013 01:38'! on: anEnvironment referencesToInstanceVariable: aString in: aClass | newEnv | newEnv := (self onEnvironment: anEnvironment) label: 'References to ''' , aString , ''' in ' , aClass name; yourself. (aClass whichClassDefinesInstVar: aString) withAllSubclassesDo: [:cls | ((cls whichSelectorsRead: aString) isEmpty not or: [(cls whichSelectorsAssign: aString) isEmpty not]) ifTrue: [newEnv addClass: cls instanceVariable: aString]]. ^newEnv! ! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:32'! writersOfInstanceVariable: aString in: aClass ^ self on: self default writersOfInstanceVariable: aString in: aClass ! ! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/2/2013 23:33'! readersOfInstanceVariable: aString in: aClass ^ self on: self default readersOfInstanceVariable: aString in: aClass! ! !RBVariableNode commentStamp: 'md 8/9/2005 15:00'! RBVariableNode is an AST node that represent a variable (global, inst var, temp, etc.). Instance Variables: token the token that contains our name and position ! !RBVariableNode methodsFor: 'accessing' stamp: ''! stopWithoutParentheses ^token stop! ! !RBVariableNode methodsFor: '*SmartSuggestions' stamp: 'GiselaDecuzzi 5/22/2013 15:38'! specialCommands ^self binding specialCommands! ! !RBVariableNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 8/5/2013 11:07'! isSpecialVariable ^ self binding isSpecialVariable! ! !RBVariableNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 5/22/2013 16:50'! isInstance ^self binding isInstance! ! !RBVariableNode methodsFor: 'replacing' stamp: ''! replaceSourceWith: aNode self addReplacement: (RBStringReplacement replaceFrom: self start to: self stop with: aNode formattedCode)! ! !RBVariableNode methodsFor: '*opalcompiler-core' stamp: 'jorgeRessia 11/20/2009 16:40'! isGlobal ^self binding isGlobal! ! !RBVariableNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 5/22/2013 16:51'! binding: aSemVar aSemVar ifNil: [^self removeProperty: #binding ifAbsent: []]. self propertyAt: #binding put: aSemVar.! ! !RBVariableNode methodsFor: 'testing' stamp: ''! isImmediateNode ^true! ! !RBVariableNode methodsFor: 'testing' stamp: 'GiselaDecuzzi 6/5/2013 10:30'! isFaulty ^false! ! !RBVariableNode methodsFor: 'testing' stamp: 'TestRunner 11/2/2009 21:18'! isRead ^ self isWrite not and: [ self isUsed ]! ! !RBVariableNode methodsFor: '*opalcompiler-core' stamp: 'ClementBera 8/5/2013 11:03'! isClean ^ (self isInstance | self isSpecialVariable) not! ! !RBVariableNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 6/14/2013 15:44'! isUndeclared ^self binding isUndeclared! ! !RBVariableNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 5/22/2013 16:50'! isTemp ^self binding isTemp! ! !RBVariableNode methodsFor: 'testing' stamp: ''! isVariable ^true! ! !RBVariableNode methodsFor: 'testing' stamp: ''! references: aVariableName ^self name = aVariableName! ! !RBVariableNode methodsFor: 'replacing' stamp: ''! replaceSourceFrom: aNode self addReplacement: (RBStringReplacement replaceFrom: aNode start to: aNode stop with: self name)! ! !RBVariableNode methodsFor: 'testing' stamp: 'TestRunner 11/2/2009 21:21'! isWrite ^ self parent notNil and: [ self parent isAssignment and: [ self parent variable == self ] ]! ! !RBVariableNode methodsFor: 'comparing' stamp: ''! hash ^self name hash! ! !RBVariableNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:43'! copyInContext: aDictionary ^ self class identifierToken: token copy removePositions! ! !RBVariableNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 5/22/2013 16:50'! isArg ^self binding isArg! ! !RBVariableNode methodsFor: 'accessing' stamp: ''! precedence ^0! ! !RBVariableNode methodsFor: 'accessing' stamp: ''! startWithoutParentheses ^token start! ! !RBVariableNode methodsFor: 'accessing' stamp: 'lr 2/18/2010 17:44'! token ^ token! ! !RBVariableNode methodsFor: 'comparing' stamp: ''! equalTo: anObject withMapping: aDictionary ^self class = anObject class and: [(aDictionary at: self name ifAbsentPut: [anObject name]) = anObject name]! ! !RBVariableNode methodsFor: 'visiting' stamp: 'StephaneDucasse 3/29/2013 15:39'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor visitVariableNode: self! ! !RBVariableNode methodsFor: '*opalcompiler-core' stamp: 'MarcusDenker 5/22/2013 16:50'! binding ^self propertyAt: #binding ifAbsent: [nil].! ! !RBVariableNode methodsFor: 'comparing' stamp: 'CamilloBruni 12/15/2011 15:17'! = anObject self == anObject ifTrue: [^true]. ((anObject isKindOf: self class) or: [self isKindOf: anObject class]) ifFalse: [^false]. ^self name = anObject name! ! !RBVariableNode methodsFor: 'testing' stamp: ''! needsParenthesis ^false! ! !RBVariableNode methodsFor: 'initialize-release' stamp: ''! identifierToken: anIdentifierToken token := anIdentifierToken! ! !RBVariableNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/6/2012 14:05'! name ^token value asSymbol! ! !RBVariableNode class methodsFor: 'instance creation' stamp: 'CamilloBruni 12/5/2011 19:19'! withToken: anIdentifierToken ^(self new) identifierToken: anIdentifierToken; yourself! ! !RBVariableNode class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/12/2012 16:50'! identifierToken: anIdentifierToken anIdentifierToken value = 'self' ifTrue: [ ^ RBSelfNode withToken: anIdentifierToken ]. anIdentifierToken value = 'thisContext' ifTrue: [ ^ RBThisContextNode withToken: anIdentifierToken ]. anIdentifierToken value = 'super' ifTrue: [ ^ RBSuperNode withToken: anIdentifierToken ]. ^ self withToken: anIdentifierToken! ! !RBVariableNode class methodsFor: 'instance creation' stamp: ''! named: aString ^self identifierToken: (RBIdentifierToken value: aString start: 0)! ! !RBVariableNotDefinedRule commentStamp: ''! See my #rationale.! !RBVariableNotDefinedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'This check is similar to the "References an undeclared variable" check, but it looks for variables that are not defined in the class or in the undeclared dictionary. You probably had to work hard to get your code in this state.'! ! !RBVariableNotDefinedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBVariableNotDefinedRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:04'! severity ^ #error! ! !RBVariableNotDefinedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Variable used, but not defined anywhere'! ! !RBVariableNotDefinedRule methodsFor: 'running' stamp: 'MarcusDenker 10/5/2013 17:20'! checkMethod: aContext aContext compiledMethod literals allButLastDo: [ :literal | (literal isVariableBinding and: [ literal key notNil ]) ifTrue: [ ((Smalltalk globals associationAt: literal key ifAbsent: [ ]) == literal or: [ (Undeclared associationAt: literal key ifAbsent: [ ]) == literal ]) ifFalse: [ (aContext selectedClass bindingOf: literal key) == literal ifFalse: [ result addClass: aContext selectedClass selector: aContext selector. result addSearchString: literal key ] ] ] ]! ! !RBVariableNotDefinedRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:49'! category ^ 'Bugs'! ! !RBVariableNotDefinedRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'VariableNotDefinedRule'! ! !RBVariableRefactoring methodsFor: 'initialize-release' stamp: ''! variable: aVarName class: aClass class := self classObjectFor: aClass. variableName := aVarName! ! !RBVariableRefactoring methodsFor: 'printing' stamp: ''! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' variable: '. variableName storeOn: aStream. aStream nextPutAll: ' class: '. class storeOn: aStream. aStream nextPut: $)! ! !RBVariableRefactoring class methodsFor: 'instance creation' stamp: ''! model: aRBSmalltalk variable: aVarName class: aClass ^(self new) model: aRBSmalltalk; variable: aVarName class: aClass; yourself! ! !RBVariableRefactoring class methodsFor: 'instance creation' stamp: ''! variable: aVarName class: aClass ^self new variable: aVarName class: aClass! ! !RBVariableReferencedOnceRule commentStamp: ''! See my #rationale.! !RBVariableReferencedOnceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for instance variables that might better be defined as temporary variables. If an instance variable is only used in one method and it is always assigned before it is used, then that method could define that variable as a temporary variable of the method instead (assuming that the method is not recursive).'! ! !RBVariableReferencedOnceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBVariableReferencedOnceRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:10'! severity ^ #information! ! !RBVariableReferencedOnceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Variable referenced in only one method and always assigned first'! ! !RBVariableReferencedOnceRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:49'! category ^ 'Design Flaws'! ! !RBVariableReferencedOnceRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkClass: aContext | allSubclasses | allSubclasses := aContext selectedClass withAllSubclasses. aContext selectedClass instVarNames do: [ :each | | defClass selector | (allSubclasses inject: 0 into: [ :sum :class | | sels | sels := class whichSelectorsAccess: each. sels size == 1 ifTrue: [ selector := sels asArray first. defClass := class ]. sum + sels size ]) == 1 ifTrue: [ | tree | tree := defClass parseTreeFor: selector. tree notNil ifTrue: [ (RBReadBeforeWrittenTester isVariable: each writtenBeforeReadIn: tree) ifTrue: [ result addClass: defClass selector: selector. result addSearchString: each ] ] ] ]! ! !RBVariableReferencedOnceRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'VariableReferencedOnceRule'! ! !RBVariableTypeTest methodsFor: 'tests' stamp: 'lr 10/5/2010 16:14'! testCompositeLintRuleTypes | typer types | typer := RBRefactoryTyper new runOn: RBCompositeLintRuleTest. types := typer guessTypesFor: 'rules'. self assert: (types includes: (typer model classFor: Collection)). types := typer typesFor: '-rules-'. self assert: (types includes: (typer model classFor: RBLintRuleTest)). self assert: (typer guessTypesFor: 'asdf') isEmpty. typer printString! ! !RBVariableTypeTest methodsFor: 'tests' stamp: 'lr 10/5/2010 16:14'! testParseTreeTypes | types model | model := RBNamespace new. types := RBRefactoryTyper typesFor: 'foo' in: (RBParser parseExpression: 'foo printString; testBasicLintRuleTypes; testParseTreeTypes') model: model. self assert: types size = 1. self assert: (types includes: (model classFor: self class))! ! !RBVariableTypeTest methodsFor: 'tests' stamp: 'lr 10/5/2010 16:14'! testBasicLintRuleTypes | typer types | typer := RBRefactoryTyper new. types := typer guessTypesFor: 'classBlock' in: RBBasicLintRuleTest. "self assert: types size = 1." self assert: ([ ] class withAllSuperclasses detect: [ :each | types includes: (typer model classFor: each) ] ifNone: [ nil ]) notNil. types := typer typesFor: 'methodBlock' in: (typer model classFor: RBBasicLintRuleTest). "self should: [types size = 2]." self assert: ([ ] class withAllSuperclasses detect: [ :each | types includes: (typer model classFor: each) ] ifNone: [ nil ]) notNil. "self should: [types includes: MessageChannel]." typer printString! ! !RBVariableTypeTest methodsFor: 'tests' stamp: 'lr 10/5/2010 16:14'! testLintRuleTypes | typer types | typer := RBRefactoryTyper new. types := typer guessTypesFor: 'name' in: RBLintRuleTest. self assert: types size = 1. self assert: (types includes: (typer model classFor: String))! ! !RBWhileTrueRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:53'! initialize super initialize. self matcher matchesAnyOf: #( '| `@temps | `@.Statements1. [`index <= `@stop] whileTrue: [| `@blockTemps | `@.BlockStmts1. `index := `index + 1]. `@.Statements2' '| `@temps | `@.Statements1. [`index < `@stop] whileTrue: [| `@blockTemps | `@.BlockStmts1. `index := `index + 1]. `@.Statements2' '| `@temps | `@.Statements1. [`index >= `@stop] whileTrue: [| `@blockTemps | `@.BlockStmts1. `index := `index - 1]. `@.Statements2' '| `@temps | `@.Statements1. [`index > `@stop] whileTrue: [| `@blockTemps | `@.BlockStmts1. `index := `index - 1]. `@.Statements2' ) do: [ :node :answer | node ]! ! !RBWhileTrueRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 17:39'! rationale ^ 'Checks for users of whileTrue: when the shorter to:do: would work.'! ! !RBWhileTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBWhileTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses whileTrue: instead of to:do:'! ! !RBWhileTrueRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:36'! category ^ 'Coding Idiom Violation'! ! !RBWhileTrueRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'WhileTrueRule'! ! !RBYourselfNotUsedRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:54'! initialize super initialize. self matcher matches: '`{:node | node parent isUsed not} yourself' do: [ :node :answer | node ]! ! !RBYourselfNotUsedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for methods sending the yourself message when it is not necessary.'! ! !RBYourselfNotUsedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBYourselfNotUsedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Doesn''t use the result of a yourself message'! ! !RBYourselfNotUsedRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:36'! category ^ 'Optimization'! ! !RBYourselfNotUsedRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 4/13/2012 16:58'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'YourselfNotUsedRule'! ! !RBkeysDoRule commentStamp: ''! See rationale! !RBkeysDoRule methodsFor: 'initialization' stamp: 'MarcusDenker 10/5/2013 20:02'! initialize super initialize. self rewriteRule replace: '``@object keys do: ``@block' with: '``@object keysDo: ``@block'; replace: '``@object values do: ``@block' with: '``@object valuesDo: ``@block' ! ! !RBkeysDoRule methodsFor: 'accessing' stamp: 'MarcusDenker 10/5/2013 20:02'! rationale ^ 'The use of keysDo:/valuesDo: means one intermediate collection created less'! ! !RBkeysDoRule methodsFor: 'accessing' stamp: 'MarcusDenker 10/5/2013 19:44'! group ^ 'Transformations'! ! !RBkeysDoRule methodsFor: 'accessing' stamp: 'MarcusDenker 10/5/2013 20:02'! name ^ 'keys do: -> keysDo: and valuesDo:'! ! !RBkeysDoRule methodsFor: '*Manifest-Core' stamp: 'MarcusDenker 10/5/2013 19:55'! category ^'Optimization'! ! !RBkeysDoRule methodsFor: '*Manifest-Core' stamp: 'MarcusDenker 10/5/2013 20:02'! longDescription ^ 'Replaces keys/values do: by keysDo: and valuesDo: '! ! !RBkeysDoRule class methodsFor: '*Manifest-Core' stamp: 'MarcusDenker 10/5/2013 19:44'! uniqueIdentifierName "This number should be unique and should change only when the rule completely change semantics" ^'EqualNilRule'! ! !RFC2047MimeConverter commentStamp: ''! I do quoted printable MIME decoding as specified in RFC 2047 ""MIME Part Three: Message Header Extensions for Non-ASCII Text". See String>>decodeMimeHeader! !RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/11/2000 23:16'! encodeChar: aChar to: aStream aChar = Character space ifTrue: [^ aStream nextPut: $_]. ((aChar asciiValue between: 32 and: 127) and: [('?=_' includes: aChar) not]) ifTrue: [^ aStream nextPut: aChar]. aStream nextPut: $=; nextPut: (Character digitValue: aChar asciiValue // 16); nextPut: (Character digitValue: aChar asciiValue \\ 16) ! ! !RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'PeterHugossonMiller 9/3/2009 11:08'! readWord | strm | strm := (String new: 20) writeStream. dataStream skipSeparators. [dataStream atEnd] whileFalse: [ | c | c := dataStream next. strm nextPut: c. c isSeparator ifTrue: [^ strm contents]]. ^ strm contents! ! !RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/12/2000 14:36'! isStructuredField: aString | fName | fName := aString copyUpTo: $:. ('Resent' sameAs: (fName copyUpTo: $-)) ifTrue: [fName := fName copyFrom: 8 to: fName size]. ^#('Sender' 'From' 'Reply-To' 'To' 'cc' 'bcc') anySatisfy: [:each | fName sameAs: each]! ! !RFC2047MimeConverter methodsFor: 'conversion' stamp: 'bf 3/10/2000 16:06'! mimeEncode "Do conversion reading from dataStream writing to mimeStream. Break long lines and escape non-7bit chars." | word pos wasGood isGood max | true ifTrue: [mimeStream nextPutAll: dataStream upToEnd]. pos := 0. max := 72. wasGood := true. [dataStream atEnd] whileFalse: [ word := self readWord. isGood := word allSatisfy: [:c | c asciiValue < 128]. wasGood & isGood ifTrue: [ pos + word size < max ifTrue: [dataStream nextPutAll: word. pos := pos + word size] ifFalse: [] ] ]. ^ mimeStream! ! !RFC2047MimeConverter methodsFor: 'conversion' stamp: 'sd 3/20/2008 22:23'! mimeDecode "Do conversion reading from mimeStream writing to dataStream. See String>>decodeMimeHeader" | c | [mimeStream atEnd] whileFalse: [ c := mimeStream next. c = $= ifTrue: [c := Character value: mimeStream next digitValue * 16 + mimeStream next digitValue] ifFalse: [c = $_ ifTrue: [c := $ ]]. dataStream nextPut: c]. ^ dataStream! ! !RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/11/2000 23:13'! encodeWord: aString (aString allSatisfy: [:c | c asciiValue < 128]) ifTrue: [^ aString]. ^ String streamContents: [:stream | stream nextPutAll: '=?iso-8859-1?Q?'. aString do: [:c | self encodeChar: c to: stream]. stream nextPutAll: '?=']! ! !RGAbstractContainer commentStamp: 'VeronicaUquillas 5/12/2011 10:59'! This is the abstract class for container-based elements. Elements are separated in groups by kind (e.g classes, methods, pools, etc.) Subclasses have to define the kind of collection for a particular group of entities. For a container the use of a dictionary or another collection (e.g. SortedCollection) to store group of elements is independent. ! !RGAbstractContainer methodsFor: 'lookup elements' stamp: 'VeronicaUquillas 4/14/2011 14:41'! elementNamed: elementName in: aCollection | aSymbol | aSymbol:= elementName asSymbol. ^aCollection isDictionary ifTrue: [ aCollection at: aSymbol ifAbsent: [ nil ] ] ifFalse:[ aCollection detect:[ :each| each fullName = aSymbol ] ifNone:[ nil ] ]! ! !RGAbstractContainer methodsFor: 'managing elements groups' stamp: 'VeronicaUquillas 4/15/2011 09:47'! elementsCategorized: aSymbol with: aCollection "Allows to define other groups of elements with a particular kind of collection" elements at: aSymbol put: aCollection! ! !RGAbstractContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/14/2011 12:17'! addElement: anObject anObject addInContainer: self! ! !RGAbstractContainer methodsFor: 'managing elements groups' stamp: 'VeronicaUquillas 4/15/2011 14:34'! elementsCategorized: aSymbol "Retrieves a group of elements. If does not exist set an Set" ^elements at: aSymbol ifAbsentPut:[ Set ]! ! !RGAbstractContainer methodsFor: 'managing elements groups' stamp: 'VeronicaUquillas 4/15/2011 09:48'! removeElementsCategorized: aSymbol "Deletes a group of elements" elements removeKey: aSymbol ifAbsent:[ ]! ! !RGAbstractContainer methodsFor: 'initialization' stamp: 'VeronicaUquillas 4/14/2011 10:20'! initialize super initialize. elements:= IdentityDictionary new.! ! !RGAbstractContainer methodsFor: 'lookup elements' stamp: 'VeronicaUquillas 4/13/2011 16:07'! elementNamed: elementName | aSymbol found | aSymbol:= elementName asSymbol. elements do:[ :collection| (found:= self elementNamed: aSymbol in: collection) notNil ifTrue:[ ^found ] ]. ^nil! ! !RGAbstractContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/14/2011 20:08'! addElement: anObject in: aCollection aCollection isDictionary ifTrue: [ aCollection at: anObject fullName put: anObject ] ifFalse:[ aCollection add: anObject ]! ! !RGAbstractContainer methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/14/2011 10:21'! elements "Retrieves the elements" ^elements! ! !RGAbstractContainer methodsFor: 'iterating elements' stamp: 'MarcusDenker 10/7/2013 13:01'! elementsDo: aBlock elements valuesDo: [ :collection | collection do: [ :each | aBlock value: each ] ]! ! !RGAbstractContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 4/13/2011 16:01'! includesElementNamed: elementName | aSymbol | aSymbol:= elementName asSymbol. elements do:[ :collection| (self includesElementNamed: aSymbol in: collection) ifTrue:[ ^true ] ]. ^false! ! !RGAbstractContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 7/29/2011 10:51'! includesElement: anRGDefinition ^anRGDefinition isIncludedInContainer: self! ! !RGAbstractContainer methodsFor: 'testing' stamp: 'MarcusDenker 10/7/2013 13:04'! includesElementNamed: elementName in: aCollection | aSymbol | aSymbol:= elementName asSymbol. ^aCollection isDictionary ifTrue: [ aCollection includesKey: aSymbol ] ifFalse:[ aCollection anySatisfy: [ :each| each name = aSymbol ] ]! ! !RGAbstractContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/14/2011 12:25'! removeElement: anObject from: aCollection aCollection isDictionary ifTrue: [ aCollection removeKey: anObject fullName ifAbsent:[ ] ] ifFalse:[ aCollection remove: anObject ifAbsent:[ ] ]! ! !RGAbstractContainer methodsFor: 'initialize-release' stamp: 'VeronicaUquillas 4/15/2011 09:43'! flushElements elements:= IdentityDictionary new! ! !RGAbstractContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/14/2011 12:17'! removeElement: anObject anObject removeFromContainer: self! ! !RGBehaviorDefinition commentStamp: 'VeronicaUquillas 5/9/2011 14:30'! An RGBehaviorDefinition is an abstract definition for class-alike entities (e.g. classes, traits) Instance Variables methods: protocols: superclass: ! !RGBehaviorDefinition methodsFor: 'annotations' stamp: 'VeronicaUquillas 6/28/2011 15:22'! superclassName "Retrieves the name of the superclass if exists" ^self annotationNamed: self class superclassNameKey! ! !RGBehaviorDefinition methodsFor: 'adding/removing protocols' stamp: 'VeronicaUquillas 5/13/2011 23:42'! addProtocol: anObject "Adds a protocol named anObject. Protocols are not repeated" anObject ifNil:[ ^self ]. protocols add: anObject! ! !RGBehaviorDefinition methodsFor: 'accessing methods' stamp: 'VeronicaUquillas 3/21/2011 17:14'! allSelectors "Retrieves all the selectos of the receiver in the chain hierarchy" | class selectors | class:= self. selectors := Set new. [class notNil] whileTrue: [selectors addAll: class selectors. class := class superclass ]. ^selectors! ! !RGBehaviorDefinition methodsFor: 'testing class hierarchy' stamp: 'DamienCassou 4/29/2013 15:25'! includesBehavior: aClass ^self == aClass or: [self inheritsFrom: aClass]! ! !RGBehaviorDefinition methodsFor: 'compatibility' stamp: 'VeronicaUquillas 4/14/2011 11:13'! soleInstance "to be depracated in the future" ^self theNonMetaClass! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 9/19/2011 14:01'! traits "Retrieves ring traits based on the names in the traitComposition and from the environment if it is a ring object" ^ self environment isRingObject ifTrue: [ self traitNames collect:[ :each| self environment traitNamed: each ] ] ifFalse:[ #() ]! ! !RGBehaviorDefinition methodsFor: 'tools' stamp: 'BenjaminVanRyseghem 2/8/2012 17:10'! browse ^ Smalltalk tools browser fullOnClass: self realClass selector: nil! ! !RGBehaviorDefinition methodsFor: 'managing container' stamp: 'VeronicaUquillas 5/9/2011 14:34'! removeFromContainer: aRGContainer aRGContainer removeClass: self! ! !RGBehaviorDefinition methodsFor: 'initialization' stamp: 'VeronicaUquillas 5/12/2011 10:33'! initialize super initialize. methods:= IdentityDictionary new. protocols:= Set new.! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: ''! theNonMetaClass self subclassResponsibility! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: ''! package self subclassResponsibility! ! !RGBehaviorDefinition methodsFor: 'accessing class hierarchy' stamp: 'VeronicaUquillas 3/19/2011 16:22'! withAllSubclasses "if allSubclasses is stored should not affect the collection" ^self allSubclasses, {self}! ! !RGBehaviorDefinition methodsFor: 'annotations' stamp: 'VeronicaUquillas 6/28/2011 15:23'! traitCompositionSource: anString "Stores aString representing the traits used by the receiver " self annotationNamed: self class traitCompositionSourceKey put: anString ! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 3/21/2011 17:03'! hasProtocols "Validates the existance of protocols" ^protocols notEmpty! ! !RGBehaviorDefinition methodsFor: 'adding/removing methods' stamp: 'VeronicaUquillas 4/29/2011 13:58'! removeMethod: aRGMethodDefinition "Removes aRGMethodDefinition from the methods dictionary" self removeMethod: aRGMethodDefinition from: methods! ! !RGBehaviorDefinition methodsFor: 'managing container' stamp: 'VeronicaUquillas 5/9/2011 14:34'! addInContainer: aRGContainer aRGContainer addClass: self! ! !RGBehaviorDefinition methodsFor: 'adding/removing methods' stamp: 'VeronicaUquillas 4/29/2011 13:59'! removeSelector: selector "Removes a method named as selector" methods removeKey: selector ifAbsent:[]! ! !RGBehaviorDefinition methodsFor: 'subclassing' stamp: 'VeronicaUquillas 9/16/2011 16:49'! addSubclass: aRGBehaviorDefinition "Adds a direct subclass of the receiver" (self subclasses includes: aRGBehaviorDefinition) ifFalse:[ self subclasses add: aRGBehaviorDefinition ]! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'MarcusDenker 10/8/2013 11:16'! includesProtocol: aString "Looks for a protocols named = aString" ^protocols includes: aString! ! !RGBehaviorDefinition methodsFor: 'managing container' stamp: 'VeronicaUquillas 5/9/2011 14:34'! isIncludedInContainer: aRGContainer ^aRGContainer includesClass: self! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 3/21/2011 16:58'! protocols: aCollection "set the protocols of the class" protocols:= aCollection! ! !RGBehaviorDefinition methodsFor: 'accessing class hierarchy' stamp: 'VeronicaUquillas 6/28/2011 15:23'! allSuperclasses "Answer an OrderedCollection of the receiver's and the receiver's ancestor's superclasses" "Is implementation of Behavior more efficient?" ^self annotationNamed: self class allSuperclassesKey ifAbsentPut:[ | supers sprClass | supers := OrderedCollection new. sprClass := self superclass. [sprClass notNil] whileTrue: [supers add: sprClass. sprClass := sprClass superclass]. supers ]! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 4/13/2011 16:41'! isDefined "If the class exists in the environment" ^self realClass notNil ! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 11/17/2010 11:01'! methods ^methods! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 9/19/2011 16:51'! hasMetaclass ^ false! ! !RGBehaviorDefinition methodsFor: 'accessing methods' stamp: 'VeronicaUquillas 4/20/2011 17:31'! compiledMethodNamed: selector "Retrieves the compiled method from aRGMethodDefinition" | method | ^(method:= self methodNamed: selector) notNil ifTrue: [ method compiledMethod ] ifFalse:[ nil ]! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/13/2011 16:43'! protocols "retrieves the protocols of the class" ^protocols! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 5/2/2011 16:24'! methods: aDictionary methods:= aDictionary! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 9/19/2011 13:39'! superclass: aRGBehaviorDefinition "The superclass is assigned. If aRGBehaviorDefinition is not nil the receiver is added as a subclass and the superclass assignment also happens for theMetaClass" superclass := aRGBehaviorDefinition. superclass notNil ifTrue: [ self superclassName: aRGBehaviorDefinition name. aRGBehaviorDefinition addSubclass: self. self hasMetaclass ifTrue: [ self theMetaClass superclass: aRGBehaviorDefinition theMetaClass ] ]! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'ST 6/19/2013 15:53'! traitNames "Assuming that traits in a composition can be identified by testing for the first character being an uppercase character (and thus not a special character such as {, # etc.)" | tokens | tokens := self traitCompositionSource parseLiterals flattened. ^tokens select: [:each | each first isUppercase].! ! !RGBehaviorDefinition methodsFor: 'accessing methods' stamp: 'StephaneDucasse 8/29/2013 21:02'! methodsInProtocol: aString "Retrieves the methods classified in protocol named aString" ^methods select: [ :each | each protocol = aString ]! ! !RGBehaviorDefinition methodsFor: 'accessing methods' stamp: 'VeronicaUquillas 8/8/2011 12:47'! extensionMethods ^self methods select:[ :each | each isExtension ]! ! !RGBehaviorDefinition methodsFor: 'annotations' stamp: 'VeronicaUquillas 6/28/2011 15:22'! traitCompositionSource "Retrieves aString representing the used traits" ^self annotationNamed: self class traitCompositionSourceKey ifAbsentPut:[ '{}' ]! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 11/24/2010 16:40'! hasSuperclass ^superclass notNil! ! !RGBehaviorDefinition methodsFor: 'subclassing' stamp: 'VeronicaUquillas 4/29/2011 09:12'! removeSubclass: aRGBehaviorDefinition "Removes aRGAbstractClassDefinition from the direct subclasses - without failing if does not exist" self subclasses remove: aRGBehaviorDefinition ifAbsent: []! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 3/22/2011 16:38'! hasTraitComposition ^self traitCompositionSource ~= '{}'! ! !RGBehaviorDefinition methodsFor: 'adding/removing methods' stamp: 'VeronicaUquillas 4/29/2011 09:21'! addMethod: aRGMethodDefinition "Adds aRGMethodDefinition in the methods dictionary. Adds the protocol of such method too" self addMethod: aRGMethodDefinition in: methods. self addProtocol: aRGMethodDefinition protocol! ! !RGBehaviorDefinition methodsFor: 'annotations' stamp: 'VeronicaUquillas 6/28/2011 15:22'! subclasses: aCollection "Stores direct subclasses of the receiver as an annotation" self annotationNamed: self class subclassesKey ifAbsentPut:[ aCollection ]! ! !RGBehaviorDefinition methodsFor: 'accessing class hierarchy' stamp: 'VeronicaUquillas 6/28/2011 15:22'! allSubclasses: aCollection "Stores all the subclasses (direct and indirect) as an annotation" self annotationNamed: self class allSubclassesKey ifAbsentPut:[ aCollection ]! ! !RGBehaviorDefinition methodsFor: 'accessing methods' stamp: 'VeronicaUquillas 4/20/2011 17:31'! methodNamed: selector "Retrieves aRGMethodDefinition that matches the selector given as argument" "RB defines methodFor:" ^methods at: selector asSymbol ifAbsent:[ nil ]! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 4/13/2011 16:40'! hasMethods "validates the existance of methods" ^methods notEmpty! ! !RGBehaviorDefinition methodsFor: 'accessing class hierarchy' stamp: 'MarcusDenker 10/7/2013 13:05'! allSuperclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's superclasses." self superclass isNil ifFalse: [ aBlock value: superclass. superclass allSuperclassesDo: aBlock ]! ! !RGBehaviorDefinition methodsFor: 'printing' stamp: 'VeronicaUquillas 11/17/2010 14:31'! printOn: aStream aStream nextPutAll: self name! ! !RGBehaviorDefinition methodsFor: 'annotations' stamp: 'VeronicaUquillas 6/28/2011 15:21'! definitionSource "Retrieves the definition template of the receiver -> aString. This value is kept as an annotation" ^self annotationNamed: self class definitionSourceKey! ! !RGBehaviorDefinition methodsFor: 'accessing methods' stamp: 'VeronicaUquillas 4/13/2011 23:54'! includesSelector: selector "Looks if selector is a key in the methods dictionary" ^methods includesKey: selector asSymbol! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: ''! theMetaClass self subclassResponsibility! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 7/18/2011 14:30'! isSameRevisionAs: aRGBehaviorDefinition "This method look for equality of the properties of the receiver" ^self class = aRGBehaviorDefinition class and:[ self name == aRGBehaviorDefinition name ]! ! !RGBehaviorDefinition methodsFor: 'accessing class hierarchy' stamp: 'VeronicaUquillas 7/28/2011 15:59'! allSubclasses "Retrieves all the subclasses of the receiver in the chan hiearchy - value is kept as an annotation" "is a good idea storing this?" ^self annotationNamed: self class allSubclassesKey ifAbsentPut:[ | collection index | index := 1. collection := OrderedCollection withAll: self subclasses. [index <= collection size] whileTrue: [collection addAll: (collection at: index) subclasses. index := index + 1]. collection ]! ! !RGBehaviorDefinition methodsFor: 'accessing class hierarchy' stamp: 'DamienCassou 4/29/2013 15:32'! methodDict ^ methods! ! !RGBehaviorDefinition methodsFor: 'accessing class hierarchy' stamp: 'VeronicaUquillas 3/19/2011 16:22'! withAllSuperclasses "if allSuperclasses is stored should not affect the collection" ^self allSuperclasses, {self}! ! !RGBehaviorDefinition methodsFor: 'adding/removing methods' stamp: 'VeronicaUquillas 4/28/2011 15:58'! addSelector: selectorName classified: protocolName sourced: source self addMethod: ((self factory createMethodNamed: selectorName parent: self) protocol: protocolName; sourceCode: source; yourself)! ! !RGBehaviorDefinition methodsFor: 'accessing class hierarchy' stamp: 'VeronicaUquillas 6/28/2011 15:22'! allSuperclasses: aCollection "Stores all the superclasses (direct and indirect) as an annotation" self annotationNamed: self class allSuperclassesKey ifAbsentPut:[ aCollection ]! ! !RGBehaviorDefinition methodsFor: 'private' stamp: 'VeronicaUquillas 4/29/2011 13:58'! removeMethod: aRGMethodDefinition from: aCollection "Removes aRGMethodDefinition from the collection received" aCollection removeKey: aRGMethodDefinition selector ifAbsent:[]! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: ''! isMeta "By default is considered a non-meta class" ^false! ! !RGBehaviorDefinition methodsFor: 'adding/removing protocols' stamp: 'VeronicaUquillas 4/29/2011 09:29'! removeProtocol: aString "Removes a protocol named aString (if exists)" protocols remove: aString ifAbsent:[]! ! !RGBehaviorDefinition methodsFor: 'printing' stamp: 'VeronicaUquillas 2/25/2011 19:25'! storeOn: aStream aStream nextPutAll: self name! ! !RGBehaviorDefinition methodsFor: 'annotations' stamp: 'VeronicaUquillas 6/28/2011 15:21'! superclassName: aSymbol self annotationNamed: self class superclassNameKey put: aSymbol! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: ''! realClass "Retrieves the current class existing in the runtime environment" ^self rootEnvironment classNamed: self name ! ! !RGBehaviorDefinition methodsFor: 'private' stamp: 'VeronicaUquillas 6/6/2011 10:47'! addMethod: aRGMethodDefinition in: aCollection "Adds aRGMethodDefinition in the collection received" aRGMethodDefinition parent ifNil:[ aRGMethodDefinition parent: self ]. aCollection at: aRGMethodDefinition selector put: aRGMethodDefinition! ! !RGBehaviorDefinition methodsFor: 'annotations' stamp: 'VeronicaUquillas 6/28/2011 15:23'! definitionSource: aString "Sets the definition template of the receiver -> aString. It's stored as an annotation" self annotationNamed: self class definitionSourceKey put: aString! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 11/17/2010 11:01'! superclass ^superclass! ! !RGBehaviorDefinition methodsFor: 'accessing methods' stamp: 'VeronicaUquillas 3/21/2011 17:23'! selectors "Retrieves the method selectors" ^methods keys! ! !RGBehaviorDefinition methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 9/1/2011 14:41'! addCategory: newName before: aCategory ^ self addProtocol: newName! ! !RGBehaviorDefinition methodsFor: 'annotations' stamp: 'VeronicaUquillas 6/28/2011 15:22'! subclasses "Retrieves the direct subclasses of the receiver. This value is kept as an annotation" ^self annotationNamed: self class subclassesKey ifAbsentPut:[ OrderedCollection new ]! ! !RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! superclassesKey ^#superclasses! ! !RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! traitCompositionSourceKey ^#traitCompositionSource! ! !RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'VeronicaUquillas 8/2/2011 13:43'! usersKey ^#users! ! !RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'VeronicaUquillas 8/2/2011 13:35'! isPoolKey ^#isPool! ! !RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! allSuperclassesKey ^#allSuperclasses! ! !RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! superclassNameKey ^#superclassName! ! !RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! allSubclassesKey ^#allSubclasses! ! !RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! subclassesKey ^#subclasses! ! !RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! definitionSourceKey ^#definitionSource! ! !RGClassDefinition commentStamp: 'VeronicaUquillas 4/19/2011 16:01'! RGClassDefinition is the concrete representation of a class (no trait)! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 5/17/2011 13:46'! comment: anObject "Sets a RGCommentDefinition object based on the argument" comment:= self factory createComment: anObject parent: self.! ! !RGClassDefinition methodsFor: 'behavior' stamp: 'VeronicaUquillas 5/11/2011 11:36'! withMetaclass "Registers explicitly the metaclass of a class" metaClass:= self factory createMetaclassOf: self. ! ! !RGClassDefinition methodsFor: 'managing pool users' stamp: 'VeronicaUquillas 8/2/2011 13:41'! isPool: aBoolean ^self annotationNamed: self class isPoolKey put: aBoolean! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 5/17/2011 14:47'! stamp: aString self hasComment ifTrue: [ self comment stamp: aString ] ifFalse:[ self factory createComment parent: self; stamp: aString ]! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/27/2011 10:45'! comment "Retrieves the comment definition object" ^comment! ! !RGClassDefinition methodsFor: 'managing pool users' stamp: 'MartinDias 10/28/2013 16:20'! addUser: aRGClassDefinition "The receiver registers the aRGClassDefinition as an user. An reinforces its status as a shared pool." aRGClassDefinition isClass ifFalse:[ ^self ]. (aRGClassDefinition theNonMetaClass sharedPoolNamed: self name) isNil ifTrue: [ aRGClassDefinition theNonMetaClass addSharedPoolNamed: self name ]. self isPool: true. self users add: aRGClassDefinition theNonMetaClass! ! !RGClassDefinition methodsFor: 'behavior' stamp: 'VeronicaUquillas 5/12/2011 13:20'! withMetaclass: aRGMetaclassDefinition "Registers explicitly the metaclass of a class" metaClass:= aRGMetaclassDefinition. metaClass baseClass: self. ! ! !RGClassDefinition methodsFor: 'initialization' stamp: 'MartinDias 10/28/2013 16:20'! initialize super initialize. classVariables:= OrderedCollection new. sharedPools:= OrderedCollection new.! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 5/9/2011 14:28'! package: aRGPackage "Sets the package in which this class is contained" package:= aRGPackage! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 12/2/2010 18:27'! theNonMetaClass ^self! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/14/2011 12:40'! package "Retrieves the package in which this class is contained, if exists" ^package! ! !RGClassDefinition methodsFor: 'class variables' stamp: 'VeronicaUquillas 4/29/2011 09:25'! allClassVariables "Answer a collection of the receiver's classVariables, including those defined its superclasses" ^self hasSuperclass ifFalse:[ classVariables ] ifTrue:[ self superclass allClassVariables, classVariables ]! ! !RGClassDefinition methodsFor: 'class variables' stamp: 'VeronicaUquillas 5/15/2011 18:07'! addClassVarNamed: aString | var | var:= self factory createClassVariableNamed: aString parent: self. self addVariable: var in: classVariables. ^var! ! !RGClassDefinition methodsFor: 'class variables' stamp: 'VeronicaUquillas 4/29/2011 13:39'! removeClassVarNamed: aString self removeVariable: (self classVarNamed: aString) from: classVariables! ! !RGClassDefinition methodsFor: 'class variables' stamp: 'VeronicaUquillas 4/28/2011 21:27'! addClassVariable: aRCClassVariable self addVariable: (aRCClassVariable parent: self) in: classVariables! ! !RGClassDefinition methodsFor: 'class variables' stamp: 'VeronicaUquillas 2/25/2011 20:38'! allClassVarNames ^self allClassVariables collect:[ :cvar| cvar name ]! ! !RGClassDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 5/12/2011 10:09'! hasStamp ^self stamp isEmptyOrNil not! ! !RGClassDefinition methodsFor: 'class variables' stamp: 'VeronicaUquillas 4/29/2011 13:39'! removeClassVariable: aRGClassVariableDefinition self removeVariable: aRGClassVariableDefinition from: classVariables! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/14/2011 11:15'! category "retrieves a tag for its package" ^category! ! !RGClassDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 12/2/2010 18:26'! hasMetaclass ^metaClass notNil! ! !RGClassDefinition methodsFor: 'managing pool users' stamp: 'VeronicaUquillas 8/2/2011 13:46'! includesUser: aRGBehaviorDefinition ^self users includes: aRGBehaviorDefinition! ! !RGClassDefinition methodsFor: 'shared pools' stamp: 'MartinDias 10/28/2013 16:20'! sharedPoolNamed: poolName ^sharedPools detect:[ :v| v name = poolName asSymbol ] ifNone:[ nil ]! ! !RGClassDefinition methodsFor: 'shared pools' stamp: 'MartinDias 10/28/2013 16:20'! sharedPoolNames ^sharedPools collect:[ :pool| pool name ]! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 5/12/2011 10:08'! stamp ^self hasComment ifTrue:[ self comment stamp ] ifFalse:[ nil ]! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 5/2/2011 16:26'! classVariables: aCollection classVariables:= aCollection! ! !RGClassDefinition methodsFor: 'shared pools' stamp: 'MartinDias 10/28/2013 16:19'! allSharedPoolNames ^ self allSharedPools collect: [ :pool | pool name ]! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'MartinDias 10/28/2013 16:42'! sharedPools "Keeps the pool variable relationship of the receiver" ^ sharedPools! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 3/21/2011 16:53'! category: aSymbol "stores a tag for its package" category := aSymbol! ! !RGClassDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 5/12/2011 14:41'! hasComment ^comment isEmptyOrNil not! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/28/2011 21:30'! classVariables ^classVariables! ! !RGClassDefinition methodsFor: 'shared pools' stamp: 'MartinDias 10/28/2013 16:21'! removeSharedPool: aRGPoolVariableDefinition self removeVariable: aRGPoolVariableDefinition from: sharedPools! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'MartinDias 10/28/2013 16:42'! sharedPools: aCollection sharedPools := aCollection! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 12/2/2010 18:27'! theMetaClass ^metaClass! ! !RGClassDefinition methodsFor: 'class variables' stamp: 'VeronicaUquillas 4/29/2011 09:25'! classVarNames "Answer a collection of the names of the class variables defined in the receiver." ^classVariables collect:[ :cvar| cvar name ]! ! !RGClassDefinition methodsFor: 'managing pool users' stamp: 'MartinDias 10/28/2013 16:21'! removeUser: aRGClassDefinition "Removes this RGClassDefinition from the users of the receiver" aRGClassDefinition isClass ifFalse:[ ^self ]. aRGClassDefinition theNonMetaClass removeSharedPoolNamed: self name. self users remove: aRGClassDefinition theNonMetaClass ifAbsent:[ ]! ! !RGClassDefinition methodsFor: 'class variables' stamp: 'MarcusDenker 6/24/2013 11:04'! classVarNamed: aString ^classVariables detect:[ :v| v name = aString asSymbol ] ifNone:[ nil ]! ! !RGClassDefinition methodsFor: 'to be removed - compatibility for now' stamp: 'StephaneDucasse 7/26/2011 14:04'! classSymbol ^ self className! ! !RGClassDefinition methodsFor: 'testing' stamp: 'MartinDias 10/28/2013 16:20'! isSameRevisionAs: aRGClassDefinition "This method look for equality of the properties of the receiver" ^(super isSameRevisionAs: aRGClassDefinition) and:[ self superclassName == aRGClassDefinition superclassName and:[ self category = aRGClassDefinition category and:[ self classVarNames sorted = aRGClassDefinition classVarNames sorted and:[ self sharedPoolNames sorted = aRGClassDefinition sharedPoolNames sorted and:[ self traitCompositionSource = aRGClassDefinition traitCompositionSource and:[ ((self hasComment and:[ self comment isSameRevisionAs: aRGClassDefinition comment ]) or:[ self hasComment not ]) and:[ (self theMetaClass isSameRevisionAs: aRGClassDefinition theMetaClass) ] ] ] ] ] ] ]! ! !RGClassDefinition methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 9/1/2011 14:18'! definition ^ self realClass definition! ! !RGClassDefinition methodsFor: 'shared pools' stamp: 'MartinDias 10/28/2013 16:20'! addSharedPool: aRGPoolVariableDefinition self addVariable: (aRGPoolVariableDefinition parent: self) in: sharedPools! ! !RGClassDefinition methodsFor: 'shared pools' stamp: 'MartinDias 10/28/2013 16:21'! removeSharedPoolNamed: poolName self removeVariable: (self sharedPoolNamed: poolName) from: sharedPools! ! !RGClassDefinition methodsFor: 'shared pools' stamp: 'MartinDias 10/28/2013 16:20'! allSharedPools "Answer a collection of the pools the receiver shares, including those defined in the superclasses of the receiver." ^ self hasSuperclass ifFalse: [ sharedPools ] ifTrue: [ self superclass allSharedPools , sharedPools ]! ! !RGClassDefinition methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 9/1/2011 14:28'! compile: aString classified: aCategory notifying: aController self realClass compile: aString classified: aCategory notifying: aController! ! !RGClassDefinition methodsFor: 'managing pool users' stamp: 'VeronicaUquillas 8/2/2011 14:07'! users "If the reciever is a SharedPool then retrieves its users" ^self isPool ifTrue: [ self annotationNamed: self class usersKey ifAbsentPut: [ OrderedCollection new ] ] ifFalse:[ #() ]! ! !RGClassDefinition methodsFor: 'managing pool users' stamp: 'VeronicaUquillas 8/2/2011 14:03'! isPool "The receiver is a shared pool if it inherits from SharedPool" ^self annotationNamed: self class isPoolKey ifAbsent: [ self superclassName == #SharedPool ]! ! !RGClassDefinition methodsFor: 'shared pools' stamp: 'MartinDias 10/28/2013 16:19'! addSharedPools: aCollection aCollection do: [ :pool | self addSharedPoolNamed: pool ]! ! !RGClassDefinition methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 8/28/2011 18:33'! inheritsFrom: aClass ^ self realClass inheritsFrom: aClass! ! !RGClassDefinition methodsFor: 'class variables' stamp: 'VeronicaUquillas 11/24/2010 17:24'! addClassVariables: aCollection aCollection do: [:var | self addClassVarNamed: var ]! ! !RGClassDefinition methodsFor: 'shared pools' stamp: 'MartinDias 10/28/2013 16:20'! addSharedPoolNamed: poolName | pool | pool:= self factory createPoolVariableNamed: poolName parent: self. self addVariable: pool in: sharedPools. ^pool! ! !RGClassDefinitionTest commentStamp: 'TorstenBergmann 2/12/2014 23:09'! SUnit tests for class definitions! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'MartinDias 10/28/2013 16:42'! testWithPoolDictionaries | newClass poolVar | newClass:= (RGFactory current createClassNamed: #Text) addSharedPoolNamed: #TextConstants; yourself. self assert: (newClass sharedPools size = 1). self assert: (newClass sharedPoolNames size = 1). self assert: (newClass allSharedPools size = 1). "no hierarchy" self assert: (newClass allSharedPoolNames size = 1). poolVar:= newClass sharedPoolNamed: #TextConstants. self assert: (poolVar notNil). self assert: (poolVar isPoolVariable). self assert: (poolVar isVariable). self assert: (poolVar parent = newClass). self assert: (poolVar parentName == newClass name). self assert: (poolVar realClass = Text). newClass withMetaclass. self assert: (newClass theMetaClass allSharedPoolNames size = 1). newClass removeSharedPoolNamed: #TextConstants. self assert: (newClass sharedPools isEmpty).! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 4/28/2011 16:43'! testAddingMethods | newMethod newClass | newClass:= RGFactory current createClassNamed: #OrderedCollection. newMethod:= (RGFactory current createMethodNamed: #add: parent: newClass) protocol: 'adding'; sourceCode: 'add: newObject ^self addLast: newObject'. self assert: (newMethod isMetaSide not). self assert: (newClass hasMethods not). newClass addMethod: newMethod. newClass addSelector: #size classified: 'accessing' sourced: 'fakeMethod ^lastIndex - firstIndex + 1'. self assert: (newClass hasMethods). self assert: (newClass selectors = #(add: size)). self assert: (newClass includesSelector: #add:). self assert: ((newClass methodNamed: #add:) = newMethod). self assert: (newClass methods size = 2). self assert: (newClass selectors size = 2). self assert: (newClass allSelectors size = 2). "no hierarchy" newMethod:= newClass methodNamed: #size. self assert: (newMethod parent = newClass). self assert: ((newClass compiledMethodNamed: #size) notNil). self assert: ((newClass compiledMethodNamed: #fakeMethod) isNil)! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 5/12/2011 19:16'! testWithSuperclass | newClass supClass classVar | supClass:= (RGFactory current createClassNamed: #Object) superclassName: #ProtoObject; yourself. self assert: (supClass hasSuperclass not). self assert: (supClass superclassName == #ProtoObject). "kept as annotation" self assert: (supClass annotations size = 1). newClass:= RGFactory current createClassNamed: #OrderedCollection subclassOf: supClass. self assert: (newClass superclass = supClass). self assert: (newClass superclassName == #Object). self assert: (newClass withAllSuperclasses size = 2). self assert: (newClass allSuperclasses size = 1). self assert: (supClass subclasses size = 1). self assert: (supClass withAllSubclasses size = 2). self assert: (supClass allSubclasses size = 1).! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 4/28/2011 16:11'! testWithCategory | newClass | newClass:= (RGFactory current createClassNamed: #Object) category: 'Kernel-Objects'; yourself. self assert: (newClass package isNil). self assert: (newClass category = 'Kernel-Objects').! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 4/28/2011 16:10'! testExistingClass | newClass metaClass | newClass:= RGFactory current createClassNamed: #OrderedCollection. self assert: (newClass isClass). self assert: (newClass isDefined). self assert: (newClass realClass = OrderedCollection). self assert: (newClass isMeta not). newClass withMetaclass. self assert: (newClass hasMetaclass). metaClass:= newClass theMetaClass. self assert: (metaClass isMeta). self assert: (metaClass name = 'OrderedCollection class'). self assert: (metaClass theNonMetaClass = newClass). self assert: (metaClass realClass = OrderedCollection class).! ! !RGClassDefinitionTest methodsFor: '*Ring-Tests-Monticello' stamp: 'VeronicaUquillas 9/19/2011 17:56'! testAsClassDefinition3 | newClass newSlice | newClass:= OrderedCollection asRingDefinitionWithMethods: true withSuperclasses: false withSubclasses: false withPackages: false. newSlice := newClass environment. self assert: (newClass methods size = OrderedCollection methods size). self assert: newSlice isSlice. self assert: newSlice classes size = 1. self assert: (newSlice classNamed: #OrderedCollection) = newClass. newClass:= OrderedCollection asRingDefinitionWithMethods: false withSuperclasses: true withSubclasses: false withPackages: false. newSlice := newClass environment. self assert: (newClass superclass isRingObject). self assert: (newClass superclass name = OrderedCollection superclass name). self assert: (newClass allSuperclasses size = OrderedCollection allSuperclasses size). self assert: newClass superclass = (newSlice classNamed: newClass superclassName). newClass:= RGBehaviorDefinition asRingDefinitionWithMethods: false withSuperclasses: false withSubclasses: true withPackages: false. newSlice := newClass environment. self assert: (newClass subclasses size = RGBehaviorDefinition subclasses size). self assert: (newClass allSubclasses size = RGBehaviorDefinition allSubclasses size). self assert: (newClass subclasses allSatisfy:[ :each| newSlice classes values includes: each ]). newClass:= RGBehaviorDefinition asRingDefinitionWithMethods: false withSuperclasses: false withSubclasses: false withPackages: true. newSlice := newClass environment. self assert: (newClass package name = #'Ring-Core-Kernel'). self assert: (newSlice packageNamed: #'Ring-Core-Kernel') = newClass package. self assert: (newClass package classes size = 1). self assert: (newClass package classes values first = newClass). newClass:= Class asRingDefinitionWithMethods: true withSuperclasses: false withSubclasses: false withPackages: true. newSlice := newClass environment. self assert: (newClass package name = #Kernel). self assert: (newClass extensionMethods notEmpty). self assert: (newSlice methods size = (newClass methods size + newClass theMetaClass methods size)). self assert: (newSlice packageNamed: #'Ring-Core-Kernel') methods size > 1. ! ! !RGClassDefinitionTest methodsFor: '*Manifest-Tests' stamp: ''! testStoreOn "self debug: #testStoreOn" | st | st := String streamContents: [:s | (Point) asRingDefinition storeOn: s. s contents]. self assert: st = '(RGClassDefinition named: #Point)'. st := String streamContents: [:s | (Point class) asRingDefinition storeOn: s. s contents]. self assert: st = '((RGMetaclassDefinition named: #Point class) baseClass:(RGClassDefinition named: #Point))'! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'ST 6/20/2013 16:50'! testAsClassDefinitionSourceDefinition | newClass | newClass:= Trait asRingDefinition. self assert: (newClass definitionSource = 'TraitDescription subclass: #Trait uses: TClass instanceVariableNames: ''name environment classTrait category'' classVariableNames: '''' poolDictionaries: '''' category: ''Traits-Kernel'''). self assert: (newClass theMetaClass definitionSource = 'Trait class uses: TClass classTrait instanceVariableNames: '''''). ! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 5/9/2011 16:19'! testWithDefaultNamespace | newClass | newClass:= RGFactory current createClassNamed: #Object. self assert: (newClass parent = Smalltalk globals). self assert: (newClass realClass = Object).! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'MartinDias 11/12/2013 18:50'! testWithInstanceVariables | newClass instVar | newClass:= RGFactory current createClassNamed: #OrderedCollection. newClass addInstanceVariables: #(array firstIndex). newClass addInstVarNamed: #lastIndex. self assert: (newClass instanceVariables size = 3). self assert: (newClass instVarNames size = 3). self assert: (newClass allInstVarNames size = 3). instVar:= newClass instanceVariableNamed: #firstIndex. self assert: (instVar notNil). self assert: (instVar parent = newClass). self assert: (instVar isInstanceVariable). self assert: (instVar isVariable). self assert: (instVar parentName == newClass name). self assert: (instVar realClass = OrderedCollection). newClass removeInstVarNamed: #array. self assert: (newClass instanceVariables size = 2). self assert: ((newClass instanceVariableNamed: #array) isNil). ! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 4/28/2011 16:11'! testWithClassVariables | newClass classVar | newClass:= (RGFactory current createClassNamed: #Object) addClassVariables: #(DependentsFields); addClassVarNamed: #FakeVariable; yourself. self assert: (newClass classVariables size = 2). self assert: (newClass classVarNames size = 2). self assert: (newClass allClassVarNames size = 2). "no hierarchy" classVar:= newClass classVarNamed: #DependentsFields. self assert: (classVar notNil). self assert: (classVar isClassVariable). self assert: (classVar isVariable). self assert: (classVar parent = newClass). self assert: (classVar parentName == newClass name). self assert: (classVar realClass = Object). newClass withMetaclass. self assert: (newClass theMetaClass allClassVarNames size = 2). newClass removeClassVarNamed: #DependentsFields. self assert: (newClass classVariables size = 1).! ! !RGClassDefinitionTest methodsFor: '*Ring-Tests-Monticello' stamp: 'CamilloBruni 11/8/2013 18:27'! testAsFullClassDefinition "self debug: #testAsFullClassDefinition" | rgClass | rgClass := Class asRingDefinition. self assert: rgClass methods isEmpty. self assert: rgClass superclass isNil. self assert: rgClass subclasses isEmpty. self assert: rgClass package name equals: #Kernel. rgClass := Class asFullRingDefinition. self assert: rgClass methods notEmpty. self assert: (rgClass methodNamed: #asRingDefinition) package name = #'Ring-Core-Kernel'. self assert: rgClass superclass notNil. self assert: rgClass superclass name = #ClassDescription. self assert: rgClass subclasses notEmpty. self assert: rgClass package notNil. self assert: rgClass package = rgClass theNonMetaClass package. self assert: rgClass package name = #Kernel. self assert: rgClass category = #'Kernel-Classes'. self assert: rgClass extensionMethods notEmpty. self assert: rgClass superclass superclass isNil. self assert: rgClass superclass package name equals: #Kernel. self assert: rgClass subclasses first package name equals: #Kernel. rgClass := RGClassDefinition theMetaClass asFullRingDefinition. self assert: rgClass package = rgClass theNonMetaClass package.! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'MartinDias 11/12/2013 18:51'! testWithClassInstanceVariables | newClass metaClass classInstVar | newClass:= RGFactory current createClassNamed: #HashTableSizes. newClass withMetaclass. metaClass:= newClass theMetaClass. metaClass addInstanceVariables: #(sizes). self assert: (metaClass instanceVariables size = 1). self assert: (metaClass instVarNames size = 1). self assert: (metaClass allInstVarNames size = 1). classInstVar:= metaClass instanceVariableNamed: #sizes. self assert: (classInstVar notNil). self assert: (classInstVar parent = metaClass). self assert: (classInstVar isClassInstanceVariable). self assert: (classInstVar isVariable). self assert: (classInstVar parentName = metaClass name). self assert: (classInstVar realClass = HashTableSizes class). metaClass removeInstVarNamed: #sizes. self assert: (metaClass instanceVariables isEmpty). self assert: ((metaClass instanceVariableNamed: #sizes) isNil). ! ! !RGClassDefinitionTest methodsFor: '*Manifest-Tests' stamp: ''! testReadFrom "self debug: #testReadFrom" | st rg | rg := (Point) asRingDefinition. st := String streamContents: [:s | rg storeOn: s. s contents]. self assert: (Object readFrom: st) = rg. rg := (Point class ) asRingDefinition. st := String streamContents: [:s | rg storeOn: s. s contents]. self assert: (Object readFrom: st) = rg ! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'MarcusDenker 10/16/2013 13:41'! testWithComment | newClass newComment | newClass:= RGFactory current createClassNamed: #Object. newComment:= RGFactory current createComment parent: newClass; content: 'This is a comment for test'; stamp: 'VeronicaUquillas 3/22/2011 14:51'; yourself. newClass comment: newComment. self assert: (newClass hasComment). self assert: (newClass hasStamp). self assert: (newClass = newComment parent). self assert: (newComment content = 'This is a comment for test'). self assert: (newComment author = 'VeronicaUquillas'). self assert: (newComment timeStamp = '3/22/2011 14:51' asDateAndTime). newClass comment: nil. self assert: (newClass hasComment not). newClass comment: 'This is a comment for test'; stamp: 'VeronicaUquillas 3/22/2011 14:51'. self assert: (newClass comment isRingObject). ! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'MartinDias 11/12/2013 18:01'! testAsRingDefinition self assert: OrderedCollection asRingDefinition asRingDefinition isRingObject! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 5/12/2011 19:31'! testAsClassDefinition | newClass | newClass:= OrderedCollection asRingDefinition. self assert: (newClass isRingObject). self assert: (newClass isClass). self assert: (newClass name == #OrderedCollection). self assert: (newClass category notNil). self assert: (newClass superclassName notNil). self assert: (newClass theMetaClass isRingObject). self assert: (newClass theMetaClass isClass).! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'ST 6/20/2013 17:06'! testAsClassDefinition2 | newClass | newClass:= Trait asRingDefinition. self assert: (newClass isRingObject). self assert: (newClass isClass). self assert: (newClass name == #Trait). self assert: (newClass category notNil). self assert: (newClass superclassName notNil). self assert: (newClass traitCompositionSource = 'TClass'). self assert: (newClass theMetaClass isRingObject). self assert: (newClass theMetaClass isClass). self assert: (newClass theMetaClass traitCompositionSource = 'TClass classTrait'). ! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 4/28/2011 16:44'! testWithProtocols | newMethod newClass | newClass:= RGFactory current createClassNamed: #OrderedCollection. newMethod:= (RGFactory current createMethodNamed: #add: parent: newClass) protocol: 'adding'; sourceCode: 'add: newObject ^self addLast: newObject'. newClass addMethod: newMethod. newClass addProtocol: 'accessing'. self assert: (newClass hasProtocols). self assert: (newClass protocols size = 2). self assert: (newClass includesProtocol: 'accessing'). self assert: ((newClass methodsInProtocol: 'adding') size = 1). self assert: ((newClass methodsInProtocol: 'accessing') isEmpty)! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 4/28/2011 16:44'! testRemovingMethods | newMethod newClass | newClass:= RGFactory current createClassNamed: #OrderedCollection. newMethod:= (RGFactory current createMethodNamed: #add: parent: newClass) protocol: 'adding'; sourceCode: 'add: newObject ^self addLast: newObject'. self assert: (newClass hasMethods not). newClass addMethod: newMethod. newClass addSelector: #size classified: 'accessing' sourced: 'size ^ lastIndex - firstIndex + 1'. self assert: (newClass selectors = #(add: size)). newClass removeSelector: #join:. self assert: (newClass selectors = #(add: size)). newClass removeMethod: newMethod. self assert: ((newClass includesSelector: #add:) not). newClass removeSelector: #size. self assert: (newClass hasMethods not).! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 8/10/2011 11:42'! testClassEquality | newClass | self assert: OrderedCollection asRingDefinition = OrderedCollection asRingDefinition. newClass := (OrderedCollection asRingDefinition) category: #Kernel. self assert: (OrderedCollection asRingDefinition = newClass) ! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'MartinDias 10/28/2013 16:42'! testNonExistingClass | newClass | newClass:= RGFactory current createClassNamed: #Connection. self assert: (newClass isClass). self assert: (newClass instanceVariables isEmpty). self assert: (newClass classVariables isEmpty). self assert: (newClass sharedPools isEmpty). self assert: (newClass hasMetaclass not). self assert: (newClass hasComment not). self assert: (newClass hasStamp not). self assert: (newClass parent = Smalltalk globals). self assert: (newClass package isNil). self assert: (newClass category isNil). self assert: (newClass hasMethods not). self assert: (newClass hasSuperclass not). self assert: (newClass hasTraitComposition not). self assert: (newClass isDefined not). self assert: (newClass hasProtocols not). ! ! !RGClassDescriptionDefinition commentStamp: 'VeronicaUquillas 4/19/2011 16:00'! RGClassDescriptionDefinition is the common parent for classes and metaclasses defining instance variables! !RGClassDescriptionDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 11/19/2010 11:59'! isClass ^true! ! !RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'MartinDias 11/12/2013 18:50'! removeInstVarNamed: aString self removeVariable: (self instanceVariableNamed: aString) from: instanceVariables! ! !RGClassDescriptionDefinition methodsFor: '*NautilusCommon' stamp: 'DamienCassou 4/29/2013 15:19'! packagesWithoutExtensions ^ Set new add: self package; yourself.! ! !RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'VeronicaUquillas 4/29/2011 09:24'! instVarNames "Answer a collection of the names of the instance variables defined in the receiver." ^instanceVariables collect:[ :ivar| ivar name ]! ! !RGClassDescriptionDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 11/16/2010 11:20'! instanceVariables ^instanceVariables! ! !RGClassDescriptionDefinition methodsFor: '*GroupManagerUI' stamp: 'BenjaminVanRyseghem 2/25/2012 16:36'! prettyName ^ self printString! ! !RGClassDescriptionDefinition methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 9/1/2011 14:39'! extendingPackages ^ self realClass extendingPackages! ! !RGClassDescriptionDefinition methodsFor: 'initialization' stamp: 'VeronicaUquillas 11/24/2010 14:00'! initialize super initialize. instanceVariables:= OrderedCollection new.! ! !RGClassDescriptionDefinition methodsFor: 'private' stamp: 'VeronicaUquillas 4/29/2011 13:37'! removeVariable: aRGVariableDefinition from: aCollection "Removes a variable from a particular collection. This behavior is the same for any kind of variable" aCollection remove: aRGVariableDefinition ifAbsent:[]! ! !RGClassDescriptionDefinition methodsFor: '*Manifest-Core' stamp: 'SimonAllier 7/26/2012 15:51'! arrayStringForManifest |array| array := Array new:2. array at: 1 put: (self class asString asSymbol). array at: 2 put: { name asSymbol.}. ^ array ! ! !RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'VeronicaUquillas 4/29/2011 13:38'! removeInstanceVariable: aRGVariableDefinition "aRGVariableDefinition is a instance variable or class instance variable" self removeVariable: aRGVariableDefinition from: instanceVariables! ! !RGClassDescriptionDefinition methodsFor: 'testing' stamp: 'MarcusDenker 10/7/2013 21:25'! isSameRevisionAs: aRGClassDescriptionDefinition "This method look for equality of the properties of the receiver" "Instances variables are compared at the level of names but without any sorting" ^(super isSameRevisionAs: aRGClassDescriptionDefinition) and:[ self instVarNames sort = aRGClassDescriptionDefinition instVarNames sort ]! ! !RGClassDescriptionDefinition methodsFor: 'organization' stamp: 'EstebanLorenzano 6/26/2013 18:16'! organization "Answer the instance of ClassOrganizer that represents the organization of the messages of the receiver." organization ifNil: [ self organization: (ClassOrganization forClass: self) ]. "Making sure that subject is set correctly. It should not be necessary." organization ifNotNil: [ organization setSubject: self ]. ^ organization! ! !RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'VeronicaUquillas 4/29/2011 09:24'! allInstanceVariables "Answer a collection of the receiver's instanceVariables, including those defined in its superclass" ^self hasSuperclass ifFalse:[ instanceVariables ] ifTrue:[ self superclass allInstanceVariables, instanceVariables ]! ! !RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'VeronicaUquillas 2/25/2011 20:38'! allInstVarNames ^self allInstanceVariables collect:[ :ivar| ivar name ]! ! !RGClassDescriptionDefinition methodsFor: 'comparing' stamp: 'VeronicaUquillas 2/25/2011 20:17'! hash ^self name hash bitXor: self class hash! ! !RGClassDescriptionDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 2/26/2011 12:02'! instanceVariables: aCollection instanceVariables:= aCollection! ! !RGClassDescriptionDefinition methodsFor: '*Manifest-Core' stamp: ''! storeOn: aStream aStream nextPutAll: '('; nextPutAll: self class name; nextPutAll: ' named: #'; nextPutAll: name; nextPut: $). ! ! !RGClassDescriptionDefinition methodsFor: 'accessing' stamp: 'DamienCassou 4/29/2013 15:28'! organization: aClassOrg "Install an instance of ClassOrganizer that represents the organization of the messages of the receiver." aClassOrg ifNotNil: [aClassOrg setSubject: self]. organization := aClassOrg! ! !RGClassDescriptionDefinition methodsFor: 'private' stamp: 'VeronicaUquillas 4/29/2011 09:23'! addVariable: aRGVariableDefinition in: aCollection "Adds a RGVariableDefinition in the collection received" aCollection add: aRGVariableDefinition! ! !RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'MartinDias 11/12/2013 18:51'! instanceVariableNamed: aString ^ instanceVariables detect: [ :v | v name = aString asSymbol ] ifNone: [ nil ]! ! !RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'VeronicaUquillas 8/16/2011 15:24'! addInstVarNamed: aString | var | var:= self factory createInstanceVariableNamed: aString parent: self. self addVariable: var in: instanceVariables. ^var! ! !RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'VeronicaUquillas 2/19/2011 00:42'! addInstanceVariables: aCollection aCollection do: [:var | self addInstVarNamed: var ]! ! !RGClassDescriptionDefinition methodsFor: 'comparing' stamp: 'VeronicaUquillas 5/11/2011 14:03'! = aRGClassDefinition ^self class = aRGClassDefinition class and: [ self name = aRGClassDefinition name and: [ self environment = aRGClassDefinition environment ] ]! ! !RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'VeronicaUquillas 4/28/2011 21:30'! addInstanceVariable: aRGVariableDefinition "aRGVariableDefinition is a instance variable or class instance variable" self addVariable: (aRGVariableDefinition parent: self) in: instanceVariables! ! !RGClassDescriptionDefinition class methodsFor: '*manifest-core' stamp: 'SimonAllier 8/22/2012 16:30'! manifestReadOn: aArray ^ self named:( aArray first)! ! !RGClassInstanceVariableDefinition commentStamp: 'TorstenBergmann 2/12/2014 23:07'! A class instance variable definition! !RGClassInstanceVariableDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 11/16/2010 14:46'! isClassInstanceVariable ^true! ! !RGClassInstanceVariableDefinition methodsFor: 'initialization' stamp: 'VeronicaUquillas 2/15/2011 15:47'! initialize super initialize. self isMetaSide: true.! ! !RGClassVariableDefinition commentStamp: 'TorstenBergmann 2/12/2014 23:07'! A class variable definition! !RGClassVariableDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 11/16/2010 14:46'! isClassVariable ^true! ! !RGCommentDefinition commentStamp: 'VeronicaUquillas 5/6/2011 10:54'! RGCommentDefinition is a first-class representation of class's comments! !RGCommentDefinition methodsFor: 'comparing' stamp: 'VeronicaUquillas 8/25/2011 22:22'! <= aRGCommentDefinition "Sort comment definition according to: 1) name of the class" ^(self parentName <= aRGCommentDefinition parentName)! ! !RGCommentDefinition methodsFor: 'to remove as soon as possible' stamp: 'VeronicaUquillas 9/3/2011 20:53'! selector self flag: 'if comments are mixed with methods use #name instead'. ^self name! ! !RGCommentDefinition methodsFor: 'type of comments' stamp: 'VeronicaUquillas 9/18/2011 14:44'! isPassive "A ring comment isPassive by default. In this case it will retrieve the data that was assigned in its creation" ^(self annotationNamed: self class statusKey) ifNil:[ true ] ifNotNil:[ :status| status == #passive ]! ! !RGCommentDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/27/2011 10:42'! stamp: anObject stamp:= anObject! ! !RGCommentDefinition methodsFor: 'type of comments' stamp: 'VeronicaUquillas 9/19/2011 16:53'! fromActiveToHistorical "If the receiver was generated as an active comment, it can be converted to a historical one by reading the data of the real class (if exists)" self isActive ifTrue: [ self asHistorical ]! ! !RGCommentDefinition methodsFor: 'source pointers' stamp: 'VeronicaUquillas 8/25/2011 14:33'! sourcePointer "Retrieves the sourcePointer for this definition if exists" ^self annotationNamed: self class sourcePointerKey ! ! !RGCommentDefinition methodsFor: 'to remove as soon as possible' stamp: 'VeronicaUquillas 9/3/2011 20:53'! methodClass self flag: 'if comments are mixed with methods use #realClass instead'. ^self realClass! ! !RGCommentDefinition methodsFor: 'type of comments' stamp: 'VeronicaUquillas 9/18/2011 14:46'! asPassive "Sets the receiver as passive object, which will allow itself to retrieve its data that was assigned in its creation" self annotationNamed: self class statusKey put: #passive! ! !RGCommentDefinition methodsFor: 'stamp values' stamp: 'MarcusDenker 10/16/2013 13:44'! author: aString self annotationNamed: self class authorKey put: aString ! ! !RGCommentDefinition methodsFor: 'stamp values' stamp: 'VeronicaUquillas 6/28/2011 15:22'! timeStamp: aTimestamp self annotationNamed: self class timeStampKey put: aTimestamp ! ! !RGCommentDefinition methodsFor: 'converting' stamp: 'VeronicaUquillas 8/26/2011 11:27'! asStringOrText | text | self realClass ifNil: [ ^self fullName ]. text := self fullName asText. text addAttribute: TextEmphasis italic. ^ text! ! !RGCommentDefinition methodsFor: 'type of comments' stamp: 'VeronicaUquillas 9/18/2011 14:44'! isHistorical "A ring comment can be used to point an old version of the receiver, in this case it will use the sourcePointer to retrieve its information" ^(self annotationNamed: self class statusKey) ifNil:[ false ] ifNotNil:[ :status| status == #historical ]! ! !RGCommentDefinition methodsFor: 'printing' stamp: 'VeronicaUquillas 9/1/2011 10:02'! printOn: aStream self parentName ifNotNil: [ aStream nextPutAll: self parentName; nextPutAll: ' ' ]. aStream nextPutAll: self name! ! !RGCommentDefinition methodsFor: 'source pointers' stamp: 'VeronicaUquillas 9/18/2011 15:44'! stampAtPointer "A RGMethodDefinition may be created to point the sourceFile in which case it retrieves the stamp" ^ self sourcePointer notNil ifTrue: [ SourceFiles timeStampAt: self sourcePointer for: self commentDataPointers ] ifFalse:[ nil ] ! ! !RGCommentDefinition methodsFor: 'stamp values' stamp: 'VeronicaUquillas 9/19/2011 11:10'! timeStamp ^ self annotationNamed: self class timeStampKey ifAbsentPut: [ self class parseTimestampFrom: self stamp default: (DateAndTime epoch) ]! ! !RGCommentDefinition methodsFor: 'to remove as soon as possible' stamp: 'StephaneDucasse 8/21/2011 18:01'! isValid "for compatibility with method definition" ^ true! ! !RGCommentDefinition methodsFor: 'backward compatibility' stamp: 'VeronicaUquillas 8/25/2011 22:37'! sourceCode ^ self content ! ! !RGCommentDefinition methodsFor: 'type of comments' stamp: 'VeronicaUquillas 9/18/2011 15:41'! isActive "A ring comment isActive when it needs to access the class organization for retrieving its data" ^(self annotationNamed: self class statusKey) ifNil:[ false ] ifNotNil:[ :status| status == #active ]! ! !RGCommentDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 7/18/2011 14:28'! isSameRevisionAs: aRGCommentDefinition "This method look for equality of the properties of the receiver" "A comment validates only its contents and not its stamp" ^(super isSameRevisionAs: aRGCommentDefinition) and:[ self content = aRGCommentDefinition content ]! ! !RGCommentDefinition methodsFor: 'testing' stamp: 'MarcusDenker 10/6/2012 14:57'! isFromTrait ^false! ! !RGCommentDefinition methodsFor: 'type of comments' stamp: 'VeronicaUquillas 9/19/2011 16:55'! fromActiveToPassive "If the receiver was generated as an active comment, it can be converted to a passive one by reading the data of the real class organization" self isActive ifTrue: [ | realClass | realClass := self realClass. realClass notNil ifTrue: [ self content: realClass organization classComment. self stamp: realClass organization commentStamp ]. self asPassive ]! ! !RGCommentDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 4/27/2011 10:48'! hasStamp ^stamp isEmptyOrNil not ! ! !RGCommentDefinition methodsFor: 'testing' stamp: 'MarcusDenker 10/16/2013 13:43'! hasAuthor ^self hasStamp and:[ self author isEmptyOrNil not ]! ! !RGCommentDefinition methodsFor: 'to remove as soon as possible' stamp: 'MarianoMartinezPeck 5/7/2012 11:31'! category ^self realClass category! ! !RGCommentDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 7/28/2011 10:13'! fullName "Keeps a unique description for the receiver. As annotation to avoid converting each time is invoked" ^self annotationNamed: self class fullNameKey ifAbsentPut:[ (self parentName, ' ', self name) asSymbol ]! ! !RGCommentDefinition methodsFor: 'type of comments' stamp: 'VeronicaUquillas 9/18/2011 15:40'! asActive "Sets the receiver as active object, which will allow itself to retrieve its data from the class organization" self annotationNamed: self class statusKey put: #active.! ! !RGCommentDefinition methodsFor: 'source pointers' stamp: 'VeronicaUquillas 9/18/2011 15:44'! contentAtPointer "A RGCommentDefinition may be created to point the sourceFile in which case it retrieves the class comment" ^ self sourcePointer notNil ifTrue: [ SourceFiles sourceCodeAt: self sourcePointer ] ifFalse:[ '' ]! ! !RGCommentDefinition methodsFor: 'source pointers' stamp: 'VeronicaUquillas 8/25/2011 14:32'! sourcePointer: aNumber self annotationNamed: self class sourcePointerKey put: aNumber ! ! !RGCommentDefinition methodsFor: 'type of comments' stamp: 'VeronicaUquillas 9/19/2011 16:53'! asHistorical "Sets the receiver as historical object, which will allow itself to retrieve its data using the sourcePointer" | realClass | self annotationNamed: self class statusKey put: #historical. self sourcePointer ifNil:[ realClass := self realClass. realClass notNil ifTrue: [ realClass organization commentRemoteStr ifNotNil: [:str | self sourcePointer: str sourcePointer ] ] ]! ! !RGCommentDefinition methodsFor: 'stamp values' stamp: 'MarcusDenker 10/16/2013 13:44'! author ^self annotationNamed: self class authorKey ifAbsentPut:[ self class parseAuthorAliasFrom: stamp ]! ! !RGCommentDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 9/19/2011 22:04'! stamp "Retrieves the user-alias + timestamp associated to the receiver (if exists)" self isActive ifTrue: [ ^ self realClass organization commentStamp ]. self isHistorical ifTrue: [ ^ self stampAtPointer ifNil:[ self realClass ifNil:[ stamp ] ifNotNil:[ :rc| rc organization commentStamp ] ] ]. ^ stamp! ! !RGCommentDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 9/19/2011 22:03'! content self isActive ifTrue: [ ^ self realClass organization classComment ]. self isHistorical ifTrue: [ ^ self contentAtPointer ifNil:[ self realClass ifNil:[ content ] ifNotNil:[ :rc| rc organization classComment ] ] ]. ^ content! ! !RGCommentDefinition methodsFor: 'source pointers' stamp: 'VeronicaUquillas 8/25/2011 14:41'! commentDataPointers "Retrieves the combination key to look for information of the receiver in the source file" ^'commentStamp:' -> #commentStamp:! ! !RGCommentDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 4/27/2011 10:41'! isComment ^true! ! !RGCommentDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 8/26/2011 15:25'! name ^name ifNil:[ name := #Comment ]! ! !RGCommentDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 5/17/2011 09:57'! isEmptyOrNil ^content isEmptyOrNil ! ! !RGCommentDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/27/2011 16:02'! content: anObject content:= anObject! ! !RGCommentDefinition methodsFor: 'to remove as soon as possible' stamp: 'StephaneDucasse 7/26/2011 14:09'! isCommentReference ^ true! ! !RGCommentDefinition class methodsFor: 'instance creation' stamp: 'VeronicaUquillas 9/18/2011 15:41'! realClass: aClass "Creates a ring comment definition from a Smalltalk class" ^(super realClass: aClass) asActive; yourself! ! !RGCommentDefinitionTest commentStamp: 'TorstenBergmann 2/12/2014 23:09'! SUnit tests for comment definitions! !RGCommentDefinitionTest methodsFor: 'testing' stamp: 'MarcusDenker 10/16/2013 13:43'! testNewComment | newComment | newComment:= RGFactory current createComment content: 'This is a comment for test'; stamp: 'VeronicaUquillas 3/22/2011 14:51'; yourself. self assert: newComment isComment. self assert: newComment isPassive. self assert: newComment name = #Comment. self assert: newComment hasStamp. self assert: newComment hasAuthor. self assert: newComment timeStamp notNil. self assert: (newComment author = 'VeronicaUquillas'). self assert: (newComment timeStamp = '3/22/2011 14:51' asDateAndTime). self assert: (newComment parent = nil). self assert: (newComment environment = Smalltalk globals).! ! !RGCommentDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 8/26/2011 15:14'! testingConversion | rgComm | rgComm := RGCommentDefinition realClass: RGClassDefinition. self assert: rgComm asStringOrText = 'RGClassDefinition Comment'. rgComm := RGCommentDefinition class: (RGClassDefinition named: #Foo). self assert: rgComm asStringOrText = 'Foo Comment'! ! !RGCommentDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 9/19/2011 17:02'! testActiveComment | rgComment | rgComment := RGCommentDefinition realClass: RGClassDefinition. self assert: rgComment isActive. self assert: rgComment sourcePointer isNil. self assert: rgComment content notNil. self assert: rgComment stamp notNil. rgComment content: ''. "it always reads from the organization and the previous changes was not commited" self assert: rgComment content ~= ''. rgComment fromActiveToPassive. self assert: rgComment isPassive. self assert: rgComment sourcePointer isNil. self assert: rgComment content notNil. self assert: rgComment stamp notNil. rgComment content: ''. self assert: rgComment content = ''. rgComment := RGCommentDefinition realClass: RGClassDefinition. rgComment fromActiveToHistorical. self assert: rgComment isHistorical. self assert: rgComment sourcePointer notNil. self assert: rgComment content notNil. self assert: rgComment stamp notNil. rgComment content: ''. "it always reads from the source file and the previous changes was not commited" self assert: rgComment content ~= ''! ! !RGCommentDefinitionTest methodsFor: 'testing' stamp: 'MarcusDenker 10/16/2013 13:43'! testCommentWithoutAuthor | newComment | newComment:= RGFactory current createComment content: 'This is a comment for test'; stamp: '3/22/2011 14:51'; yourself. self assert: (newComment hasAuthor not).! ! !RGCommentDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 9/18/2011 16:05'! testCommentFromSourceFile | rgComment | rgComment := (RGCommentDefinition realClass: RGClassDefinition) asHistorical. self assert: rgComment isHistorical. self assert: rgComment sourcePointer notNil. self assert: rgComment content notNil. self assert: rgComment stamp notNil! ! !RGCommentDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 8/25/2011 22:42'! testSorting | rgComm1 rgComm2 | rgComm1 := RGCommentDefinition realClass: RGClassDefinition. rgComm2 := RGCommentDefinition realClass: RGElementDefinition. self assert: rgComm1 <= rgComm2! ! !RGContainer commentStamp: 'VeronicaUquillas 9/6/2011 16:12'! A concrete container already knows how to treat classes, methods and packages. ! !RGContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 9/6/2011 17:43'! includesClassNamed: className "Returns true if the receiver includes the className in the defined classes" self flag: 'can a metaclass be stored without its nonMetaClass? Check this'. ^self includesElementNamed: (self theNonMetaClassNameOf: className) in: self definedClasses.! ! !RGContainer methodsFor: 'utilities' stamp: 'VeronicaUquillas 9/6/2011 16:39'! theNonMetaClassNameOf: aSymbol "Rejects the prefix ' class' or ' classTrait' of the argument" | index | index := aSymbol indexOfSubCollection: ' class' startingAt: 1 ifAbsent: [ ^aSymbol asSymbol ]. ^(aSymbol copyFrom: 1 to: index - 1) asSymbol! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 9/6/2011 17:20'! traits "Retrieves a collection (by default a dictionary) containing only defined traits" ^self definedClasses select:[ :each| each isTrait ]! ! !RGContainer methodsFor: 'lookup by name' stamp: 'VeronicaUquillas 7/27/2011 15:18'! packageNamed: packageName "Look for a child package named packageName" ^self elementNamed: packageName in: self packages! ! !RGContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 7/27/2011 15:18'! includesPackage: aRGPackage "Verifies if a child package == aRGPackage exists" ^self packages includes: aRGPackage! ! !RGContainer methodsFor: 'initialization' stamp: 'VeronicaUquillas 9/7/2011 13:53'! initialize super initialize. self definedClasses: IdentityDictionary new. self methods: IdentityDictionary new. self packages: IdentityDictionary new.! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 9/6/2011 15:08'! withoutPackages self removeElementsCategorized: #packages! ! !RGContainer methodsFor: 'utilities' stamp: 'VeronicaUquillas 4/19/2011 14:11'! isMetaclassName: aSymbol "Validates if the arguments corresponds to a nonMetaClass" ^(aSymbol indexOfSubCollection: ' class' startingAt: 1) > 0! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 7/27/2011 15:18'! addPackageNamed: packageName "adds a child package with the given name" | cPackage | (self includesPackageNamed: packageName) ifTrue:[ ^self ]. cPackage:= self factory createPackageNamed: packageName. self addPackage: cPackage! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/28/2011 15:50'! addClassNamed: className "Creates a class with the given name" | cls | cls:= self factory createClassNamed: className. self addClass: cls! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 9/6/2011 17:23'! addClass: aRGBehaviorDefinition "aRGBehaviorDefinition has to be a class, trait or metaclass" self flag: 'when i am adding a metaclass? check this?'. (aRGBehaviorDefinition isClass or:[ aRGBehaviorDefinition isTrait ]) ifFalse:[ ^self ]. self addElement: aRGBehaviorDefinition in: self definedClasses! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 9/6/2011 17:21'! classNames "Retrieves class names (including traits)" ^ self definedClasses isDictionary ifTrue: [ self definedClasses keys ] ifFalse:[ self definedClasses collect:[ :class| class name ] ]! ! !RGContainer methodsFor: 'iterating' stamp: 'VeronicaUquillas 4/19/2011 14:13'! methodsDo: aBlock self methods do:[ :each| aBlock value: each ]! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/28/2011 15:52'! removeMethod: aRGMethodDefinition self removeElement: aRGMethodDefinition from: self methods! ! !RGContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 4/19/2011 14:13'! includesMethodNamed: fullSelectorName ^self includesElementNamed: fullSelectorName in: self methods! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 9/6/2011 16:49'! removeClass: aRGAbstractClassDefinition self removeElement: aRGAbstractClassDefinition from: self definedClasses! ! !RGContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 9/6/2011 17:41'! includesClass: aRGBehaviorDefinition "Returns true if the receiver includes aRGBehaviorDefinition in the defined classes" ^self definedClasses includes: aRGBehaviorDefinition! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 9/6/2011 16:49'! withoutClasses self removeElementsCategorized: #definedClasses! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 9/6/2011 17:29'! allClasses "convenient method" ^self classes! ! !RGContainer methodsFor: 'image package loading' stamp: 'VeronicaUquillas 9/19/2011 14:22'! cleanEmptyPackages (self packages select:[ :pck| pck classes size isZero and:[ pck methods size isZero ] ]) do:[ :pck| self removePackage: pck ]! ! !RGContainer methodsFor: 'accessing' stamp: 'VeronicaUquillas 9/7/2011 13:50'! methods "Retrieves methods defined in the container" ^self elements at: #methods ifAbsentPut:[ IdentityDictionary new ]! ! !RGContainer methodsFor: 'accessing' stamp: 'VeronicaUquillas 7/27/2011 15:18'! packages: aCollection self elementsCategorized: #packages with: aCollection! ! !RGContainer methodsFor: 'iterating' stamp: 'VeronicaUquillas 9/6/2011 17:39'! traitsDo: aBlock self traits do: [ :each| aBlock value: each. each hasMetaclass ifTrue:[ aBlock value: each theMetaClass ] ]! ! !RGContainer methodsFor: 'image package loading' stamp: 'VeronicaUquillas 9/19/2011 16:49'! findPackageOfMethod: aRGMethodDefinition using: packageKeys "Look for the package of an extension method. nil otherwise" | pair lname | self packages isEmpty ifTrue: [ ^nil ]. (aRGMethodDefinition protocol beginsWith: '*') ifFalse:[ ^ nil ]. lname := aRGMethodDefinition protocol asLowercase. pair := packageKeys detect:[ :assoc| self class category: lname matches: assoc value ] ifNone:[ nil ]. ^ pair ifNotNil:[ self packages at: pair key ]! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 9/6/2011 17:30'! allTraits "convenient method" ^self allClasses select:[ :each | each isTrait ]! ! !RGContainer methodsFor: 'image package loading' stamp: 'StephaneDucasse 6/2/2012 20:42'! loadPackagesFromImage | rgPackage rgPackageKeys | rgPackageKeys := OrderedCollection new. self class allManagers do: [ :pck | rgPackage := RGPackage named: pck package name asSymbol. rgPackageKeys add: (rgPackage name -> ('*', rgPackage name asLowercase)). self addPackage: rgPackage ]. ^ rgPackageKeys! ! !RGContainer methodsFor: 'accessing' stamp: 'VeronicaUquillas 7/27/2011 15:20'! methods: aCollection "Set the methods collection" self elements at: #methods put: aCollection! ! !RGContainer methodsFor: 'image class and method loading' stamp: 'VeronicaUquillas 9/19/2011 13:22'! loadMethod: aRGMethodDefinition inClass: aRGBehaviorDefinition using: packageKeys self addMethod: aRGMethodDefinition. aRGBehaviorDefinition addMethod: aRGMethodDefinition. self setPackageOfMethod: aRGMethodDefinition ofClass: aRGBehaviorDefinition using: packageKeys! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 9/6/2011 17:19'! traitNames "Retrieves the names of defined traits" ^ self traits isDictionary ifTrue: [ self traits keys ] ifFalse:[ self traits collect:[ :trait| trait name ] ]! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 7/27/2011 15:18'! removePackage: aRGPackage "removes a child aRGPackage" aRGPackage isPackage ifFalse:[ ^self ]. self removeElement: aRGPackage from: self packages! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 9/6/2011 17:20'! extensionMethods "Retrieves a collection (by default a dictionary) with the extensions methods of the receiver" ^self methods values select:[ :mth| mth isExtension ]! ! !RGContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 9/6/2011 17:22'! hasClasses ^self definedClasses notEmpty! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/28/2011 15:52'! removeTrait: aRGTraitDefinition "convenient method" self removeClass: aRGTraitDefinition! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/28/2011 15:51'! addTraitNamed: traitName "Creates a trait with the given name" | trait | trait:= self factory createTraitNamed: traitName. self addClass: trait! ! !RGContainer methodsFor: 'iterating' stamp: 'VeronicaUquillas 9/6/2011 17:38'! classesDo: aBlock self classes do: [ :each| aBlock value: each. each hasMetaclass ifTrue:[ aBlock value: each theMetaClass ] ]! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/28/2011 15:50'! addTrait: aRGTraitDefinition "convenient method" self addClass: aRGTraitDefinition! ! !RGContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 7/27/2011 15:18'! includesPackageNamed: packageName "Verifies if a child package with name = packageName exists" ^self includesElementNamed: packageName in: self packages! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/28/2011 15:50'! addMethod: aRGMethodDefinition "aRGMethodDefinition needs to satisfy the status isMethod" aRGMethodDefinition isMethod ifFalse:[ ^self ]. self addElement: aRGMethodDefinition in: self methods! ! !RGContainer methodsFor: 'accessing' stamp: 'VeronicaUquillas 9/6/2011 16:48'! definedClasses: aCollection "Set the classes collection" self elements at: #definedClasses put: aCollection! ! !RGContainer methodsFor: 'image package loading' stamp: 'VeronicaUquillas 9/19/2011 16:49'! findPackageOfClass: aRGBehaviorDefinition using: packageKeys "Look for the package of a class. It is nil when there is not a package created for a category in MC" | pair | self packages isEmpty ifTrue: [ ^ nil ]. ^ self packages at: aRGBehaviorDefinition category ifAbsent:[ pair := packageKeys detect:[ :each| self class category: aRGBehaviorDefinition category matches: each key ] ifNone:[ nil ]. pair ifNotNil:[ self packages at: pair key ] ]! ! !RGContainer methodsFor: 'image class and method loading' stamp: 'VeronicaUquillas 9/19/2011 13:47'! loadClass: aRGBehaviorDefinition using: packageKeys self setPackageOfClass: aRGBehaviorDefinition using: packageKeys. self addClass: aRGBehaviorDefinition! ! !RGContainer methodsFor: 'accessing' stamp: 'VeronicaUquillas 9/7/2011 13:50'! packages "Retrieves the children packages defined in the receiver" ^self elements at: #packages ifAbsentPut:[ IdentityDictionary new ]! ! !RGContainer methodsFor: 'lookup by name' stamp: 'VeronicaUquillas 7/28/2011 16:59'! classNamed: className "Retrieves an RGBehaviorDefinition object. className could be theMetaClass name" ^self classOrTraitNamed: className! ! !RGContainer methodsFor: 'image class and method loading' stamp: 'MarcusDenker 10/7/2013 13:02'! loadTraitUsers "Set the users of a trait" | users | users := self classes select: [ :cls | cls hasTraitComposition ]. users do:[ :each | | rgTrait | each traitNames do:[ :tname| rgTrait := self traitNamed: tname. rgTrait notNil ifTrue: [ rgTrait addUser: each. rgTrait theMetaClass addUser: each theMetaClass ] ] ]! ! !RGContainer methodsFor: 'lookup by name' stamp: 'VeronicaUquillas 4/19/2011 14:13'! methodNamed: fullSelectorName ^self elementNamed: fullSelectorName in: self methods! ! !RGContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 4/19/2011 14:13'! hasMethods ^self methods notEmpty! ! !RGContainer methodsFor: 'iterating' stamp: 'VeronicaUquillas 7/29/2011 10:48'! allClassesDo: aBlock "Evaluate the argument, aBlock, for each class and its metaclass" self allClasses do: [ :each| aBlock value: each. each hasMetaclass ifTrue:[ aBlock value: each theMetaClass ] ]! ! !RGContainer methodsFor: 'image package loading' stamp: 'VeronicaUquillas 9/19/2011 13:14'! setPackageOfMethod: rgMethod ofClass: rgClass using: packageKeys "Set the package to aRGMethodDefinition and its value isExtension" (self findPackageOfMethod: rgMethod using: packageKeys) ifNil:[ rgClass package ifNotNil:[ :pck| pck addMethod: rgMethod. rgMethod isExtension: false ] ] ifNotNil:[ :pck| pck addMethod: rgMethod. rgMethod isExtension: (rgMethod package ~= rgClass package) ]! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 7/27/2011 15:18'! addPackage: aRGPackage "adds a child package" aRGPackage isPackage ifFalse:[ ^self ]. self addElement: aRGPackage in: self packages! ! !RGContainer methodsFor: 'iterating' stamp: 'VeronicaUquillas 7/29/2011 10:48'! allTraitsDo: aBlock "Evaluate the argument, aBlock, for each trait" self allTraits do: [ :each| aBlock value: each. each hasMetaclass ifTrue:[ aBlock value: each theMetaClass ] ]! ! !RGContainer methodsFor: 'lookup by name' stamp: 'VeronicaUquillas 7/28/2011 16:30'! traitNamed: traitName "Retrieves an RGTraitDefinition object. traitName could be theMetaClass name" | trait | ^(trait:= self classOrTraitNamed: traitName) isTrait ifTrue:[ trait ] ifFalse:[ nil ]! ! !RGContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 4/28/2011 15:49'! includesMethod: aRGMethodDefinition ^self methods includes: aRGMethodDefinition! ! !RGContainer methodsFor: 'image package loading' stamp: 'VeronicaUquillas 9/19/2011 13:11'! setPackageOfClass: rgClass using: packageKeys "Set the package to aRGBehaviorDefinition" (self findPackageOfClass: rgClass using: packageKeys) ifNotNil:[ :pck| pck addClass: rgClass ] ! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/19/2011 14:23'! withoutMethods self removeElementsCategorized: #methods! ! !RGContainer methodsFor: 'accessing' stamp: 'VeronicaUquillas 9/7/2011 13:50'! definedClasses "Retrieves classes (traits are included)" ^self elements at: #definedClasses ifAbsentPut:[ IdentityDictionary new ]! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 9/6/2011 16:50'! classes "convenient method" ^self definedClasses! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 10/10/2011 21:15'! classes: aCollection "convenient method" self definedClasses: aCollection! ! !RGContainer methodsFor: 'iterating' stamp: 'VeronicaUquillas 9/6/2011 17:37'! definedClassesDo: aBlock self definedClasses do: [ :each| aBlock value: each. each hasMetaclass ifTrue:[ aBlock value: each theMetaClass ] ]! ! !RGContainer methodsFor: 'lookup by name' stamp: 'VeronicaUquillas 9/6/2011 17:21'! classOrTraitNamed: className "A class or metaclass can be reached by its name" | theClass | className ifNil: [^nil ]. theClass:= self elementNamed: (self theNonMetaClassNameOf: className) in: self definedClasses. theClass ifNil:[ ^nil ]. ^(self isMetaclassName: className) ifTrue: [ theClass theMetaClass ] ifFalse:[ theClass ] ! ! !RGContainer methodsFor: 'lookup by name' stamp: 'VeronicaUquillas 4/19/2011 14:11'! metaclassNamed: metaclassName | theClass | theClass:= (self classOrTraitNamed: metaclassName). theClass notNil ifTrue:[ ^theClass isMeta ifTrue: [ theClass ] ifFalse:[ theClass theMetaClass ] ]. ^nil! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 8/8/2011 10:21'! allMethods "convenient method" ^self methods! ! !RGContainer class methodsFor: 'image package loading' stamp: 'StephaneDucasse 6/2/2012 19:46'! packageNames ^ self allManagers collect: [ :pck | pck package name asSymbol ]! ! !RGContainer class methodsFor: 'image package loading' stamp: 'VeronicaUquillas 9/19/2011 16:38'! packageOfMethod: aRGMethodDefinition ^ self packageOfMethod: aRGMethodDefinition using: self packageKeys! ! !RGContainer class methodsFor: 'image package loading' stamp: 'PavelKrivanek 11/13/2012 10:47'! allManagers ^ Smalltalk globals at: #MCWorkingCopy ifPresent: [:mcwc | mcwc allManagers ] ifAbsent: [OrderedCollection new ] ! ! !RGContainer class methodsFor: 'image package loading' stamp: 'StephaneDucasse 6/2/2012 19:47'! packageKeys ^ self allManagers collect: [ :pck | pck package name asSymbol -> ('*', pck package name asLowercase) ]! ! !RGContainer class methodsFor: 'image package loading' stamp: 'VeronicaUquillas 9/19/2011 14:55'! category: categoryName matches: prefix | prefixSize catSize | categoryName ifNil: [ ^false ]. catSize := categoryName size. prefixSize := prefix size. catSize < prefixSize ifTrue: [ ^false ]. (categoryName findString: prefix startingAt: 1 caseSensitive: true) = 1 ifFalse: [ ^false ]. ^(categoryName at: prefix size + 1 ifAbsent: [ ^true ]) = $-! ! !RGContainer class methodsFor: 'image package loading' stamp: 'VeronicaUquillas 9/19/2011 16:50'! packageOfMethod: aRGMethodDefinition using: packageKeys "Looks for the package of aRGMethodDefinition from the image" | pName parentPackage | (aRGMethodDefinition protocol notNil and:[ aRGMethodDefinition protocol beginsWith: '*' ]) ifFalse:[ parentPackage := (aRGMethodDefinition parent ifNotNil:[ aRGMethodDefinition parent package ]). ^ parentPackage ifNil:[ self packageOfClass: aRGMethodDefinition parent ] ]. aRGMethodDefinition protocol ifNil: [ ^ nil ]. pName := (packageKeys detect: [ :each| self category: aRGMethodDefinition protocol asLowercase matches: each value ] ifNone:[ nil ]). ^ pName ifNotNil:[ RGPackage named: pName key ]! ! !RGContainer class methodsFor: 'image package loading' stamp: 'VeronicaUquillas 9/19/2011 16:50'! packageOfClass: aRGBehaviorDefinition using: packageNames "Looks for the package of aRGBehaviorDefinition from the image" | pName | aRGBehaviorDefinition ifNil:[ ^nil ]. pName := (packageNames detect: [ :each| each = aRGBehaviorDefinition category ] ifNone: [ packageNames detect:[ :each| self category: aRGBehaviorDefinition category matches: each ] ifNone:[ nil ] ]). ^ pName ifNotNil:[ RGPackage named: pName ]! ! !RGContainer class methodsFor: 'image package loading' stamp: 'VeronicaUquillas 9/19/2011 16:38'! packageOfClass: aRGBehaviorDefinition ^ self packageOfClass: aRGBehaviorDefinition using: self packageNames.! ! !RGContainerTest commentStamp: 'TorstenBergmann 2/12/2014 23:08'! SUnit tests for container! !RGContainerTest methodsFor: '*Ring-Tests-Monticello' stamp: 'VeronicaUquillas 9/19/2011 15:57'! testRetrievingPackages | rgClass rgMethod | rgClass := OrderedCollection asRingDefinition. rgClass package: (RGContainer packageOfClass: rgClass). self assert: rgClass package name = #'Collections-Sequenceable'. rgMethod := (RGMethodDefinition realClass: Class selector: #asRingDefinition). rgMethod package: (RGContainer packageOfMethod: rgMethod). self assert: rgMethod parent isNil. self assert: rgMethod package name = #'Ring-Core-Kernel'. rgMethod := (RGMethodDefinition realClass: OrderedCollection selector: #size). rgMethod package: (RGContainer packageOfMethod: rgMethod). self assert: rgMethod package isNil. rgMethod := (RGMethodDefinition class: rgClass selector: #size). rgMethod package: (RGContainer packageOfMethod: rgMethod). self assert: rgMethod parent notNil. self assert: rgMethod package notNil. self assert: rgMethod package = rgClass package! ! !RGDefinition commentStamp: 'TorstenBergmann 2/12/2014 23:07'! Common superclass for definitions! !RGDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 11/25/2011 12:40'! rootEnvironment "Retrieves the runtime environment of an RGObject" "If the receiver is defined in an RGContainer the runtime environment is the one associated to its container" | parent | parent:= self environment. [ parent isRingObject ] whileTrue:[ parent:= parent environment ]. ^parent! ! !RGDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 1/20/2012 10:05'! environment: namespace namespace = self class environment ifFalse:[ self annotationNamed: #environment put: namespace ]! ! !RGDefinition methodsFor: 'converting' stamp: 'MartinDias 11/12/2013 18:04'! asRingDefinition ^ self! ! !RGDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 1/20/2012 10:05'! environment "If the receiver has not namespace assigned the default is used" "self class environment = Smalltalk globals" ^ self annotationNamed: #environment ifAbsent: [ self class environment ]! ! !RGElementDefinition commentStamp: 'StephaneDucasse 7/26/2011 14:02'! RGElementDefinition is the abstract class for representing elements of a class-alike definition (i.e., methods, variables, comment). parent holds the RGClassDefinition or RGMetaclassDefinition defining this element. Now a RingEntityDefinition offers two APIs: one that is generic and works for all the source code entities and this is the one we just presented: parent, parentName and realParent. Having such interface is important to build generic tools that could manipulate any entities in a polymorphic way (yes no isKindOf: everywhere). In addition, a ring method definition offers a specific interface that should only be used when you know that you are solely manipulate specific entity such as class element: method definition, class comment, and variables. Here is the equivalence table realParent realClass parent ringClass parentName className For example for a methodDefinition we will have the following: GENERIC API ------------------ * To access the ring class definition name, use parentName aRGMethodDefinition parentName Example: (Point>>#dist:) asRingDefinition parentName -> #Point * If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent aRGMethodDefinition parent Example: aRGMethodDefinition(Point>>#dist:) parent -> aRGClassDefinition(Point) * If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realParent aRGMethodDefinition realParent Example: (Point>>#dist:) asRingDefinition realParent -> Point CLASS Element specific API ------------------------------------------ * The message class returns the class of the object :). Yes as you see we could not use class and className because class is already used to refer to the class of the object. Example: (Point>>#dist:) asRingDefinition class -> RingMethodDefinition * The message className returns the name of the ring class defining the reingMethodDefinition. Example: (Point>>#dist:) asRingDefinition className -> #Point * If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent aRGMethodDefinition ringClass Example: aRGMethodDefinition(Point>>#dist:) ringClass -> aRGClassDefinition(Point) * If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realClass aRGMethodDefinition realClass Example: (Point>>#dist:) asRingDefinition realClass -> Point ! !RGElementDefinition methodsFor: 'generic parent api' stamp: 'StephaneDucasse 7/26/2011 14:00'! parent: aRGBehaviorDefinition "Set the class associated to the receiver" parent := aRGBehaviorDefinition. self setParentInfo: aRGBehaviorDefinition.! ! !RGElementDefinition methodsFor: 'comparing' stamp: 'VeronicaUquillas 8/31/2011 19:34'! hash "Hash is re-implemented because #= is re-implemented" ^self class hash bitXor: (self parentName hash bitXor: self isMetaSide hash)! ! !RGElementDefinition methodsFor: 'accessing' stamp: 'StephaneDucasse 7/26/2011 14:01'! isMetaSide: aBoolean self annotationNamed: self class isMetaSideKey put: aBoolean! ! !RGElementDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 9/1/2011 15:50'! fullName: aString ^ self annotationNamed: self class fullNameKey put: aString asSymbol! ! !RGElementDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 7/19/2011 14:21'! isDefined "isDefined when the receiver has its realClass defined in the system" ^self realClass notNil! ! !RGElementDefinition methodsFor: 'generic parent api' stamp: 'StephaneDucasse 7/26/2011 14:01'! parentName "Retrieves the name of the class defining the receiver. Its value is kept as an annotation" ^ self annotationNamed: self class classNameKey! ! !RGElementDefinition methodsFor: 'private' stamp: 'VeronicaUquillas 8/16/2011 14:33'! setParentInfo: anObject "anObject is aRGBehaviorDefinition or aClass/aTrait" self parentName: anObject name. self isMetaSide: anObject isMeta! ! !RGElementDefinition methodsFor: 'generic parent api' stamp: 'VeronicaUquillas 5/4/2011 13:19'! theNonMetaParentName "Rejects the prefix ' class' or ' classTrait' of the parentName" | index | index := self parentName indexOfSubCollection: ' class' startingAt: 1 ifAbsent: [ ^self parentName ]. ^(self parentName copyFrom: 1 to: index - 1) asSymbol! ! !RGElementDefinition methodsFor: 'class element specific api' stamp: 'StephaneDucasse 7/26/2011 14:02'! realClass "Retrieves the Class/Trait/.. object in the System corresponding to the class of the this element." ^ self realParent! ! !RGElementDefinition methodsFor: 'generic parent api' stamp: 'VeronicaUquillas 8/31/2011 17:31'! parentName: aString self annotationNamed: self class classNameKey put: aString asSymbol! ! !RGElementDefinition methodsFor: 'tools' stamp: 'BenjaminVanRyseghem 2/8/2012 17:10'! browse ^ self systemNavigation browseClass: self realClass! ! !RGElementDefinition methodsFor: 'class element specific api' stamp: 'StephaneDucasse 7/26/2011 14:02'! className ^ self parentName! ! !RGElementDefinition methodsFor: 'accessing' stamp: 'StephaneDucasse 7/26/2011 14:01'! isMetaSide "Even thought several class elements do not define this property (ie. class variables, pool variables) they understand it" "This is a derived property from the class definining the receiver and thus its value is kept as an annotation" "Default value is false" ^self annotationNamed: self class isMetaSideKey ifAbsentPut: [ false ]! ! !RGElementDefinition methodsFor: 'backward compatibility' stamp: 'VeronicaUquillas 9/1/2011 15:07'! actualClass "returns the Smalltalk class of the receiver" ^ self realClass! ! !RGElementDefinition methodsFor: 'comparing' stamp: 'VeronicaUquillas 8/31/2011 19:22'! = aRGElementDefinition "This method look for equality of the properties of the receiver" "Verifies the class and the parentName of the receiver" ^self class = aRGElementDefinition class and:[ self parentName == aRGElementDefinition parentName and:[ self isMetaSide = aRGElementDefinition isMetaSide ] ]! ! !RGElementDefinition methodsFor: 'class element specific api' stamp: 'VeronicaUquillas 8/25/2011 22:47'! theNonMetaClassName ^self theNonMetaParentName ! ! !RGElementDefinition methodsFor: 'class element specific api' stamp: 'StephaneDucasse 7/26/2011 14:21'! className: aName ^ self parentName: aName! ! !RGElementDefinition methodsFor: 'generic parent api' stamp: 'StephaneDucasse 7/26/2011 13:58'! realParent "Retrieves the Class/Trait/.. object in the System corresponding to the class of the this element." ^self parent notNil ifTrue: [ self parent realClass ] ifFalse: [ self rootEnvironment classNamed: self parentName ]! ! !RGElementDefinition methodsFor: 'generic parent api' stamp: 'StephaneDucasse 7/26/2011 14:00'! parent "The parent of a class definition element: method, comment and variable is the class definition. This method retrieves the class that defines such element" ^ parent! ! !RGElementDefinition methodsFor: 'accessing' stamp: 'LeoGassman 11/7/2013 12:25'! package ^self parent package ! ! !RGElementDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 7/18/2011 14:28'! isSameRevisionAs: aRGElementDefinition "This method look for equality of the properties of the receiver" "Verifies the class and the parentName of the receiver" ^self class = aRGElementDefinition class and:[ self parentName == aRGElementDefinition parentName ]! ! !RGElementDefinition methodsFor: 'class element specific api' stamp: 'StephaneDucasse 7/26/2011 13:59'! ringClass "Return the ring definition of the class containing the receiver." ^ self parent! ! !RGElementDefinition class methodsFor: 'elements-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! isMetaSideKey ^#isMetaSide! ! !RGElementDefinition class methodsFor: 'class initialization' stamp: 'VeronicaUquillas 8/16/2011 14:37'! class: aRGBehaviorDefinition "The argument is a ring object and serves as the parent of a method, variable or class comment" ^self new parent: aRGBehaviorDefinition; yourself! ! !RGElementDefinition class methodsFor: 'elements-annotations' stamp: 'VeronicaUquillas 9/17/2011 18:04'! statusKey ^#statusKey! ! !RGElementDefinition class methodsFor: 'class initialization' stamp: 'LeoGassman 11/7/2013 12:24'! realClass: aClass "The argument is a Smalltalk class and the parent of a method, variable, class comment. However it is not set as parent but only its name and scope (instance/class)" ^self new parent: aClass asRingDefinition; yourself! ! !RGElementDefinition class methodsFor: 'elements-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! classNameKey ^#className! ! !RGElementDefinition class methodsFor: 'parsing stamp' stamp: 'VeronicaUquillas 8/22/2012 15:12'! parseTimestampFrom: aString default: anObject "Parse a date-time from a timestamp-string that is extracted from a source file. If there is no timestamp, or we cannot make sense of it, we return the default value." | tokens dateStartIndex unknown | "The following timestamp strings are supported (source: squeak sources archeological survey):